In article <···················@panda.cs.man.ac.uk> ·····@cs.man.ac.uk (Stephen J Bevan) writes:
> [example of a pattern matching dispatch deleted]
> This notation is particularly nice if you are writing simple
> evaluators for languages.
> [...]
> Here's the problem. I've tried to implement this in Lisp myself, but
> to no avail. [...]
I have written and often use a macro called SELECT which
does a job like this. Your example can be rewritten like
this:
(defun eval-expr (x)
(select x
('add x y) => (+ x y)
('sub x y) => (- x y)
('mul x y) => (* x y)
('div x y) => (/ x y)
)
)
I have made the source available by JANET ftp.
The site is uk.ac.soton.ecs and the file is
<FTP>lisp/select.lisp
The select macro is not only useful for writing
interpreters:
(defun my-append (a b)
(select a
'nil => b
(hd . tl) => (cons hd (my-append tl b))))
(defun fact (n)
(select n
'0 => 1
n => (* n (fact (1- n)))))
The file also contains a macro called IN which is similar
to the `where' clause of SML and Miranda.
--
______________________________________________________________
Stephen Adams ·········@ecs.soton.ac.uk
Computer Science ·········@sot-ecs.uucp
Southampton University
Southampton SO9 5NH, UK
Previously I wrote
> I have made the source available by JANET ftp.
> The site is uk.ac.soton.ecs and the file is
> <FTP>lisp/select.lisp
I have received quite a few mail messages from people who
cannot ftp from JANET (i.e. UK) sites so I am posting the
source directly.
I hope that the comments at the beginning of the source
answer some of the queries and requests for more information
that I have received.
------------------------------------------------------------------------
;;
;; SELECT macro (and IN macro)
;;
;; Copyright 1990 Stephen Adams
;;
;; You are free to copy, distribute and make derivative works of this
;; source provided that this copyright notice is displayed near the
;; beginning of the file. No liability is accepted for the
;; correctness or performance of the code. If you modify the code
;; please indicate this fact both at the place of modification and in
;; this copyright message.
;;
;; Stephen Adams
;; Department of Electronics and Computer Science
;; University of Southampton
;; SO9 5NH, UK
;;
;; ···@ecs.soton.ac.uk
;;
;;
;; Synopsis:
;;
;; (select expression
;; (pattern action+)*
;; )
;;
;; --- or ---
;;
;; (select expression
;; pattern => expression
;; pattern => expression
;; ...
;; )
;;
;; pattern -> constant ;egs 1, #\x, #c(1.0 1.1)
;; | symbol ;matches anything
;; | 'anything ;must be EQUAL
;; | (pattern = pattern) ;both patterns must match
;; | (#'function pattern) ;predicate test
;; | (pattern . pattern) ;cons cell
;;
;; Example
;;
;; (select item
;; (('if e1 e2 e3) 'if-then-else) ;(1)
;; ((#'oddp k) 'an-odd-integer) ;(2)
;; (((#'treep tree) = (hd . tl)) 'something-else) ;(3)
;; (other 'anything-else)) ;(4)
;;
;; Notes
;;
;; . Each pattern is tested in turn. The first match is taken.
;;
;; . If no pattern matches, an error is signalled.
;;
;; . Constant patterns (things X for which (CONSTANTP X) is true, i.e.
;; numbers, strings, characters, etc.) match things which are EQUAL.
;;
;; . Quoted patterns (which are CONSTANTP) are constants.
;;
;; . Symbols match anything. The symbol is bound to the matched item
;; for the execution of the actions.
;; For example, (SELECT '(1 2 3)
;; (1 . X) => X
;; )
;; returns (2 3) because X is bound to the cdr of the candidate.
;;
;; . The two pattern match (p1 = p2) can be used to name parts
;; of the matched structure. For example, (ALL = (HD . TL))
;; matches a cons cell. ALL is bound to the cons cell, HD to its car
;; and TL to its tail.
;;
;; . A predicate test applies the predicate to the item being matched.
;; If the predicate returns NIL then the match fails.
;; If it returns truth, then the nested pattern is matched. This is
;; often just a symbol like K in the example.
;;
;; . Care should be taken with the domain values for predicate matches.
;; If, in the above eg, item is not an integer, an error would occur
;; during the test. A safer pattern would be
;; (#'integerp (#'oddp k))
;; This would only test for oddness of the item was an integer.
;;
;; . A single symbol will match anything so it can be used as a default
;; case, like OTHER above.
;;
(eval-when (compile) (proclaim '(optimize (safety 2))))
(defmacro select (expression &rest patterns)
(let* ( (do-let (not (atom expression)))
(key (if do-let (gensym) expression))
(cbody (expand-select-patterns key patterns))
(cform `(cond . ,cbody))
)
(if do-let
`(let ((,key ,expression)) ,cform)
cform))
)
(defun expand-select-patterns (key patterns)
(if (eq (second patterns) '=>)
(expand-select-patterns-style-2 key patterns)
(expand-select-patterns-style-1 key patterns)))
(defun expand-select-patterns-style-1 (key patterns)
(if (null patterns)
`((T (error "Case select pattern match failure on ~S" ,key)))
(let ((pattern (caar patterns))
(actions (cdar patterns))
(rest (cdr patterns)) )
(let ( (test (compile-select-test key pattern))
(bindings (compile-select-bindings key pattern actions)))
`( ,(if bindings `(,test (let ,bindings . ,actions))
`(,test . ,actions))
. ,(if (eq test t)
nil
(expand-select-patterns-style-1 key rest)))
)
)
))
(defun expand-select-patterns-style-2 (key patterns)
(if (null patterns)
`((T (error "Case select pattern match failure on ~S" ,key)))
(let ((pattern (first patterns))
(arrow (if (or (< (length patterns) 3)
(not (eq (second patterns) '=>)))
(error "Illegal patterns: ~S" patterns)))
(actions (list (third patterns)))
(rest (cdddr patterns)) )
(let ( (test (compile-select-test key pattern))
(bindings (compile-select-bindings key pattern actions)))
`( ,(if bindings `(,test (let ,bindings . ,actions))
`(,test . ,actions))
. ,(if (eq test t)
nil
(expand-select-patterns-style-2 key rest)))
)
)
))
(defun compile-select-test (key pattern)
(let ((tests (remove-if
#'(lambda (item) (eq item t))
(compile-select-tests key pattern))))
(cond
;; note AND does this anyway, but this allows us to tell if
;; the pattern will always match.
((null tests) t)
((= (length tests) 1) (car tests))
(T `(and . ,tests)))))
(defun compile-select-tests (key pattern)
(cond ((constantp pattern) `((,(cond ((numberp pattern) 'eql)
((symbolp pattern) 'eq)
(T 'equal))
,key ,pattern)))
((symbolp pattern) '(T))
((select-double-match? pattern)
(append
(compile-select-tests key (first pattern))
(compile-select-tests key (third pattern))))
((select-predicate? pattern)
(append
`((,(second (first pattern)) ,key))
(compile-select-tests key (second pattern))))
((consp pattern)
(append
`((consp ,key))
(compile-select-tests (!cs-car key) (car pattern))
(compile-select-tests (!cs-cdr key) (cdr pattern))))
('T (error "Illegal select pattern: ~S" pattern))
)
)
(defun compile-select-bindings (key pattern action)
(cond ((constantp pattern) '())
((symbolp pattern)
(if (select!-in-tree pattern action) `((,pattern ,key))
'()))
((select-double-match? pattern)
(append
(compile-select-bindings key (first pattern) action)
(compile-select-bindings key (third pattern) action)))
((select-predicate? pattern)
(compile-select-bindings key (second pattern) action))
((consp pattern)
(append
(compile-select-bindings (!cs-car key) (car pattern) action)
(compile-select-bindings (!cs-cdr key) (cdr pattern) action)))
)
)
(defun select!-in-tree (atom tree)
(or (eq atom tree)
(if (consp tree)
(or (select!-in-tree atom (car tree))
(select!-in-tree atom (cdr tree))))))
(defun select-double-match? (pattern)
;; (<pattern> = <pattern>)
(and (consp pattern) (consp (cdr pattern)) (consp (cddr pattern))
(null (cdddr pattern))
(eq (second pattern) '=)))
(defun select-predicate? (pattern)
;; ((function <f>) <pattern>)
(and (consp pattern)
(consp (cdr pattern))
(null (cddr pattern))
(consp (first pattern))
(consp (cdr (first pattern)))
(null (cddr (first pattern)))
(eq (caar pattern) 'function)))
(defun !cs-car (exp)
(!cs-car/cdr 'car exp '(
(car . caar) (cdr . cadr) (caar . caaar) (cadr . caadr)
(cdar . cadar) (cddr . caddr)
(caaar . caaaar) (caadr . caaadr) (cadar . caadar)
(caddr . caaddr) (cdaar . cadaar) (cdadr . cadadr)
(cddar . caddar) (cdddr . cadddr))))
(defun !cs-cdr (exp)
(!cs-car/cdr 'cdr exp '(
(car . cdar) (cdr . cddr) (caar . cdaar) (cadr . cdadr)
(cdar . cddar) (cddr . cdddr)
(caaar . cdaaar) (caadr . cdaadr) (cadar . cdadar)
(caddr . cdaddr) (cdaar . cddaar) (cdadr . cddadr)
(cddar . cdddar) (cdddr . cddddr))))
(defun !cs-car/cdr (op exp table)
(if (and (consp exp) (= (length exp) 2))
(let ((replacement (assoc (car exp) table)))
(if replacement
`(,(cdr replacement) ,(second exp))
`(,op ,exp)))
`(,op ,exp)))
;(setf c1 '(select x (a 1) (b 2 3 4)))
;(setf c2 '(select (car y)
; (1 (print 100) 101) (2 200) ("hello" 5) (:x 20) (else (1+ else))))
;(setf c3 '(select (caddr y)
; ((all = (x y)) (list x y all))
; ((a '= b) (list 'assign a b))
; ((#'oddp k) (1+ k)))))
;;
;; IN macro
;;
;; (IN exp LET pat1 = exp1
;; pat2 = exp2
;; ...)
;;
;; (IN exp LET* pat1 = exp1
;; pat2 = exp2
;; ...)
;;
(defmacro in (&rest form)
(select form
(exp 'let . pats) =>
(let* ( (exps (select-in-let-parts pats 'exp))
(pats (select-in-let-parts pats 'pat))
(vars (mapcar #'(lambda (x) (gensym)) exps))
)
`(let ,(mapcar #'list vars exps)
,(reduce
#'(lambda (var-pat subselection)
(let ((var (first var-pat))
(pat (second var-pat)))
`(select ,var
,pat => ,subselection
else => (error "IN-LET type error: ~S doesnt match ~S" ,var ',pat))))
(mapcar #'list vars pats)
:from-end t
:initial-value exp)))
(exp 'let*) => exp
(exp 'let* pat '= patexp . pats) =>
(let ((var (gensym)))
`(let ((,var ,patexp))
(select ,var
,pat => (in ,exp let* . ,pats)
else => (error "IN-LET type error: ~S doesnt match ~S" ,var ',pat))))
else =>
(error "Illegal IN form ~S" form)))
(defun select-in-let-parts (pats part)
(select pats
nil =>
nil
(pat '= exp . rest) =>
(cons (select part
'exp => exp
'pat => pat)
(select-in-let-parts rest part))
other =>
(error "Illegal LET form(s): ~S" pats)))
;(setf eg1 '(in (list h1 h2 t1 t2)
; let
; (h1 . t1) = (foo x)
; (h2 . t2) = (bar y))))
--
______________________________________________________________
Stephen Adams ·········@ecs.soton.ac.uk
Computer Science ·········@sot-ecs.uucp
Southampton University
Southampton SO9 5NH, UK
From: Richard A. O'Keefe
Subject: Re: Select macro available [long, mostly source]
Date:
Message-ID: <3857@goanna.cs.rmit.oz.au>
In article <·················@alonzo.ecs.soton.ac.uk>, ···@ecs.soton.ac.uk (Stephen Adams) writes:
> ;; SELECT macro (and IN macro)
A word of warning: Scheme uses 'select' for a variant of 'case', and
I've come across the same usage elsewhere. Another name might be less
confusing. Perhaps SELECT-MATCH?
--
Fixed in the next release.
In article <····@goanna.cs.rmit.oz.au> ··@goanna.cs.rmit.oz.au (Richard A. O'Keefe) writes:
> In article <·················@alonzo.ecs.soton.ac.uk>, ···@ecs.soton.ac.uk (Stephen Adams) writes:
> > ;; SELECT macro (and IN macro)
>
> A word of warning: Scheme uses 'select' for a variant of 'case', and
> I've come across the same usage elsewhere. Another name might be less
> confusing. Perhaps SELECT-MATCH?
Point taken.
One of the problems with writing general purpose macros for
a language the size of Common Lisp is that there are so many
standard symbols that it is difficult to think of new short
and snappy ones. `All the nice ones are taken.'
I did think about this and I looked in the index of CLtL.
I didn't find SELECT so I chose that name.
I think a more serious criticism of my code is that all the
auxiliary functions are not hidden in a package. But that
is nearly as easy as changing the name of the macro if that
is what you need to do.
--
Stephen Adams ·········@ecs.soton.ac.uk
Computer Science ·········@sot-ecs.uucp
Southampton University
Southampton SO9 5NH, UK