Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
;;
;; SELECT-MATCH 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-match expression
;; (pattern action+)*
;; )
;;
;; --- or ---
;;
;; (select-match 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-match 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-MATCH '(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-match (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-match x (a 1) (b 2 3 4)))
;(setf c2 '(select-match (car y)
; (1 (print 100) 101) (2 200) ("hello" 5) (:x 20) (else (1+
else))))
;(setf c3 '(select-match (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-match 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-match ,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-match ,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-match pats
nil =>
nil
(pat '= exp . rest) =>
(cons (select-match 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))))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.