From: Stephen Adams
Subject: Select macro available [was Help with Macros [longish]]
Date: 
Message-ID: <SRA.90Sep27101434@alonzo.ecs.soton.ac.uk>
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

From: Stephen Adams
Subject: Re: Select macro available [long, mostly source]
Date: 
Message-ID: <SRA.90Sep28200631@alonzo.ecs.soton.ac.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.
From: Stephen Adams
Subject: Re: Select macro available [long, mostly source]
Date: 
Message-ID: <SRA.90Oct1221538@alonzo.ecs.soton.ac.uk>
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