slynk-match.lisp (9079B)
1 ;; 2 ;; SELECT-MATCH macro (and IN macro) 3 ;; 4 ;; Copyright 1990 Stephen Adams 5 ;; 6 ;; You are free to copy, distribute and make derivative works of this 7 ;; source provided that this copyright notice is displayed near the 8 ;; beginning of the file. No liability is accepted for the 9 ;; correctness or performance of the code. If you modify the code 10 ;; please indicate this fact both at the place of modification and in 11 ;; this copyright message. 12 ;; 13 ;; Stephen Adams 14 ;; Department of Electronics and Computer Science 15 ;; University of Southampton 16 ;; SO9 5NH, UK 17 ;; 18 ;; sra@ecs.soton.ac.uk 19 ;; 20 21 ;; 22 ;; Synopsis: 23 ;; 24 ;; (select-match expression 25 ;; (pattern action+)*) 26 ;; 27 ;; --- or --- 28 ;; 29 ;; (select-match expression 30 ;; pattern => expression 31 ;; pattern => expression 32 ;; ...) 33 ;; 34 ;; pattern -> constant ;egs 1, #\x, #c(1.0 1.1) 35 ;; | symbol ;matches anything 36 ;; | 'anything ;must be EQUAL 37 ;; | (pattern = pattern) ;both patterns must match 38 ;; | (#'function pattern) ;predicate test 39 ;; | (pattern . pattern) ;cons cell 40 ;; 41 42 ;; Example 43 ;; 44 ;; (select-match item 45 ;; (('if e1 e2 e3) 'if-then-else) ;(1) 46 ;; ((#'oddp k) 'an-odd-integer) ;(2) 47 ;; (((#'treep tree) = (hd . tl)) 'something-else) ;(3) 48 ;; (other 'anything-else)) ;(4) 49 ;; 50 ;; Notes 51 ;; 52 ;; . Each pattern is tested in turn. The first match is taken. 53 ;; 54 ;; . If no pattern matches, an error is signalled. 55 ;; 56 ;; . Constant patterns (things X for which (CONSTANTP X) is true, i.e. 57 ;; numbers, strings, characters, etc.) match things which are EQUAL. 58 ;; 59 ;; . Quoted patterns (which are CONSTANTP) are constants. 60 ;; 61 ;; . Symbols match anything. The symbol is bound to the matched item 62 ;; for the execution of the actions. 63 ;; For example, (SELECT-MATCH '(1 2 3) 64 ;; (1 . X) => X) 65 ;; returns (2 3) because X is bound to the cdr of the candidate. 66 ;; 67 ;; . The two pattern match (p1 = p2) can be used to name parts 68 ;; of the matched structure. For example, (ALL = (HD . TL)) 69 ;; matches a cons cell. ALL is bound to the cons cell, HD to its car 70 ;; and TL to its tail. 71 ;; 72 ;; . A predicate test applies the predicate to the item being matched. 73 ;; If the predicate returns NIL then the match fails. 74 ;; If it returns truth, then the nested pattern is matched. This is 75 ;; often just a symbol like K in the example. 76 ;; 77 ;; . Care should be taken with the domain values for predicate matches. 78 ;; If, in the above eg, item is not an integer, an error would occur 79 ;; during the test. A safer pattern would be 80 ;; (#'integerp (#'oddp k)) 81 ;; This would only test for oddness of the item was an integer. 82 ;; 83 ;; . A single symbol will match anything so it can be used as a default 84 ;; case, like OTHER above. 85 ;; 86 87 (defpackage :slynk-match 88 (:use :cl) 89 (:export #:match)) 90 91 (in-package :slynk-match) 92 93 (defmacro match (expression &body patterns) 94 `(select-match ,expression ,@patterns)) 95 96 (defmacro select-match (expression &rest patterns) 97 (let* ((do-let (not (atom expression))) 98 (key (if do-let (gensym) expression)) 99 (cbody (expand-select-patterns key patterns)) 100 (cform `(cond . ,cbody))) 101 (if do-let 102 `(let ((,key ,expression)) ,cform) 103 cform))) 104 105 (defun expand-select-patterns (key patterns) 106 (if (eq (second patterns) '=>) 107 (expand-select-patterns-style-2 key patterns) 108 (expand-select-patterns-style-1 key patterns))) 109 110 (defun expand-select-patterns-style-1 (key patterns) 111 (if (null patterns) 112 `((t (error "Case select pattern match failure on ~S" ,key))) 113 (let* ((pattern (caar patterns)) 114 (actions (cdar patterns)) 115 (rest (cdr patterns)) 116 (test (compile-select-test key pattern)) 117 (bindings (compile-select-bindings key pattern actions))) 118 `(,(if bindings `(,test (let ,bindings . ,actions)) 119 `(,test . ,actions)) 120 . ,(unless (eq test t) 121 (expand-select-patterns-style-1 key rest)))))) 122 123 (defun expand-select-patterns-style-2 (key patterns) 124 (cond ((null patterns) 125 `((t (error "Case select pattern match failure on ~S" ,key)))) 126 (t (when (or (< (length patterns) 3) 127 (not (eq (second patterns) '=>))) 128 (error "Illegal patterns: ~S" patterns)) 129 (let* ((pattern (first patterns)) 130 (actions (list (third patterns))) 131 (rest (cdddr patterns)) 132 (test (compile-select-test key pattern)) 133 (bindings (compile-select-bindings key pattern actions))) 134 `(,(if bindings `(,test (let ,bindings . ,actions)) 135 `(,test . ,actions)) 136 . ,(unless (eq test t) 137 (expand-select-patterns-style-2 key rest))))))) 138 139 (defun compile-select-test (key pattern) 140 (let ((tests (remove t (compile-select-tests key pattern)))) 141 (cond 142 ;; note AND does this anyway, but this allows us to tell if 143 ;; the pattern will always match. 144 ((null tests) t) 145 ((= (length tests) 1) (car tests)) 146 (t `(and . ,tests))))) 147 148 (defun compile-select-tests (key pattern) 149 (cond ((constantp pattern) `((,(cond ((numberp pattern) 'eql) 150 ((symbolp pattern) 'eq) 151 (t 'equal)) 152 ,key ,pattern))) 153 ((symbolp pattern) '(t)) 154 ((select-double-match? pattern) 155 (append 156 (compile-select-tests key (first pattern)) 157 (compile-select-tests key (third pattern)))) 158 ((select-predicate? pattern) 159 (append 160 `((,(second (first pattern)) ,key)) 161 (compile-select-tests key (second pattern)))) 162 ((consp pattern) 163 (append 164 `((consp ,key)) 165 (compile-select-tests (cs-car key) (car 166 pattern)) 167 (compile-select-tests (cs-cdr key) (cdr 168 pattern)))) 169 (t (error "Illegal select pattern: ~S" pattern)))) 170 171 172 (defun compile-select-bindings (key pattern action) 173 (cond ((constantp pattern) '()) 174 ((symbolp pattern) 175 (if (select-in-tree pattern action) 176 `((,pattern ,key)) 177 '())) 178 ((select-double-match? pattern) 179 (append 180 (compile-select-bindings key (first pattern) action) 181 (compile-select-bindings key (third pattern) action))) 182 ((select-predicate? pattern) 183 (compile-select-bindings key (second pattern) action)) 184 ((consp pattern) 185 (append 186 (compile-select-bindings (cs-car key) (car pattern) 187 action) 188 (compile-select-bindings (cs-cdr key) (cdr pattern) 189 action))))) 190 191 (defun select-in-tree (atom tree) 192 (or (eq atom tree) 193 (if (consp tree) 194 (or (select-in-tree atom (car tree)) 195 (select-in-tree atom (cdr tree)))))) 196 197 (defun select-double-match? (pattern) 198 ;; (<pattern> = <pattern>) 199 (and (consp pattern) (consp (cdr pattern)) (consp (cddr pattern)) 200 (null (cdddr pattern)) 201 (eq (second pattern) '=))) 202 203 (defun select-predicate? (pattern) 204 ;; ((function <f>) <pattern>) 205 (and (consp pattern) 206 (consp (cdr pattern)) 207 (null (cddr pattern)) 208 (consp (first pattern)) 209 (consp (cdr (first pattern))) 210 (null (cddr (first pattern))) 211 (eq (caar pattern) 'function))) 212 213 (defun cs-car (exp) 214 (cs-car/cdr 'car exp 215 '((car . caar) (cdr . cadr) (caar . caaar) (cadr . caadr) 216 (cdar . cadar) (cddr . caddr) 217 (caaar . caaaar) (caadr . caaadr) (cadar . caadar) 218 (caddr . caaddr) (cdaar . cadaar) (cdadr . cadadr) 219 (cddar . caddar) (cdddr . cadddr)))) 220 221 (defun cs-cdr (exp) 222 (cs-car/cdr 'cdr exp 223 '((car . cdar) (cdr . cddr) (caar . cdaar) (cadr . cdadr) 224 (cdar . cddar) (cddr . cdddr) 225 (caaar . cdaaar) (caadr . cdaadr) (cadar . cdadar) 226 (caddr . cdaddr) (cdaar . cddaar) (cdadr . cddadr) 227 (cddar . cdddar) (cdddr . cddddr)))) 228 229 (defun cs-car/cdr (op exp table) 230 (if (and (consp exp) (= (length exp) 2)) 231 (let ((replacement (assoc (car exp) table))) 232 (if replacement 233 `(,(cdr replacement) ,(second exp)) 234 `(,op ,exp))) 235 `(,op ,exp))) 236 237 ;; (setf c1 '(select-match x (a 1) (b 2 3 4))) 238 ;; (setf c2 '(select-match (car y) 239 ;; (1 (print 100) 101) (2 200) ("hello" 5) (:x 20) (else (1+ 240 ;; else)))) 241 ;; (setf c3 '(select-match (caddr y) 242 ;; ((all = (x y)) (list x y all)) 243 ;; ((a '= b) (list 'assign a b)) 244 ;; ((#'oddp k) (1+ k))))) 245 246