Find file
Fetching contributors…
Cannot retrieve contributors at this time
247 lines (224 sloc) 8.88 KB
;; 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
;; 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.
(defpackage :swank-match
(:use :cl)
(:export #:match))
(in-package :swank-match)
(defmacro match (expression &body patterns)
`(select-match ,expression ,@patterns))
(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)
(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))
(test (compile-select-test key pattern))
(bindings (compile-select-bindings key pattern actions)))
`(,(if bindings `(,test (let ,bindings . ,actions))
`(,test . ,actions))
. ,(unless (eq test t)
(expand-select-patterns-style-1 key rest))))))
(defun expand-select-patterns-style-2 (key patterns)
(cond ((null patterns)
`((t (error "Case select pattern match failure on ~S" ,key))))
(t (when (or (< (length patterns) 3)
(not (eq (second patterns) '=>)))
(error "Illegal patterns: ~S" patterns))
(let* ((pattern (first patterns))
(actions (list (third patterns)))
(rest (cdddr patterns))
(test (compile-select-test key pattern))
(bindings (compile-select-bindings key pattern actions)))
`(,(if bindings `(,test (let ,bindings . ,actions))
`(,test . ,actions))
. ,(unless (eq test t)
(expand-select-patterns-style-2 key rest)))))))
(defun compile-select-test (key pattern)
(let ((tests (remove t (compile-select-tests key pattern))))
;; 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)
(compile-select-tests key (first pattern))
(compile-select-tests key (third pattern))))
((select-predicate? pattern)
`((,(second (first pattern)) ,key))
(compile-select-tests key (second pattern))))
((consp pattern)
`((consp ,key))
(compile-select-tests (!cs-car key) (car
(compile-select-tests (!cs-cdr key) (cdr
(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)
(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)
(compile-select-bindings (!cs-car key) (car pattern)
(compile-select-bindings (!cs-cdr key) (cdr pattern)
(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)))))