/[slime]/slime/swank-match.lisp
ViewVC logotype

Contents of /slime/swank-match.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (show annotations)
Thu Dec 17 09:48:19 2009 UTC (4 years, 3 months ago) by sboukarev
Branch: MAIN
CVS Tags: SLIME-2-3, FAIRLY-STABLE, byte-stream, SLIME-2-2, HEAD
Changes since 1.1: +89 -142 lines
swank-match.lisp: Fix formatting and style warnings.
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 :swank-match
88 (:use :cl)
89 (:export #:match))
90
91 (in-package :swank-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

  ViewVC Help
Powered by ViewVC 1.1.5