sra@ecs.soton.ac.uk (Stephen Adams) (09/29/90)
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 ;; ;; sra@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 S.R.Adams@ecs.soton.ac.uk Computer Science S.R.Adams@sot-ecs.uucp Southampton University Southampton SO9 5NH, UK
ok@goanna.cs.rmit.oz.au (Richard A. O'Keefe) (10/01/90)
In article <SRA.90Sep28200631@alonzo.ecs.soton.ac.uk>, sra@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.
sra@ecs.soton.ac.uk (Stephen Adams) (10/02/90)
In article <3857@goanna.cs.rmit.oz.au> ok@goanna.cs.rmit.oz.au (Richard A. O'Keefe) writes: > In article <SRA.90Sep28200631@alonzo.ecs.soton.ac.uk>, sra@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 S.R.Adams@ecs.soton.ac.uk Computer Science S.R.Adams@sot-ecs.uucp Southampton University Southampton SO9 5NH, UK