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

Contents of /slime/swank-match.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (hide annotations)
Sat Oct 31 22:13:55 2009 UTC (4 years, 5 months ago) by trittweiler
Branch: MAIN
	* slime.el (slime-inside-string-p, slime-inside-comment-p)
	(slime-inside-string-or-comment-p): New.

	* swank-match.lisp: New file. Contains very simple pattern matcher
	from the CMU AI archive.

	* swank-loader.lisp: Compile swank-match.lisp.

	* swank.lisp: Make SWANK package use new SWANK-MATCH package.

	* slime-autodoc.el, swank-arglists.lisp: Large parts were
	rewritten. Autodoc is now able to highlight &key parameters, and
	parameters in nested arglists.

	* slime-parse.el, slime-c-p-c.el, slime-highlighting-edits.el:
	Adapted to changes.
1 trittweiler 1.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     ;;
28     ;; --- or ---
29     ;;
30     ;; (select-match expression
31     ;; pattern => expression
32     ;; pattern => expression
33     ;; ...
34     ;; )
35     ;;
36     ;; pattern -> constant ;egs 1, #\x, #c(1.0 1.1)
37     ;; | symbol ;matches anything
38     ;; | 'anything ;must be EQUAL
39     ;; | (pattern = pattern) ;both patterns must match
40     ;; | (#'function pattern) ;predicate test
41     ;; | (pattern . pattern) ;cons cell
42     ;;
43    
44     ;; Example
45     ;;
46     ;; (select-match item
47     ;; (('if e1 e2 e3) 'if-then-else) ;(1)
48     ;; ((#'oddp k) 'an-odd-integer) ;(2)
49     ;; (((#'treep tree) = (hd . tl)) 'something-else) ;(3)
50     ;; (other 'anything-else)) ;(4)
51     ;;
52     ;; Notes
53     ;;
54     ;; . Each pattern is tested in turn. The first match is taken.
55     ;;
56     ;; . If no pattern matches, an error is signalled.
57     ;;
58     ;; . Constant patterns (things X for which (CONSTANTP X) is true, i.e.
59     ;; numbers, strings, characters, etc.) match things which are EQUAL.
60     ;;
61     ;; . Quoted patterns (which are CONSTANTP) are constants.
62     ;;
63     ;; . Symbols match anything. The symbol is bound to the matched item
64     ;; for the execution of the actions.
65     ;; For example, (SELECT-MATCH '(1 2 3)
66     ;; (1 . X) => X
67     ;; )
68     ;; returns (2 3) because X is bound to the cdr of the candidate.
69     ;;
70     ;; . The two pattern match (p1 = p2) can be used to name parts
71     ;; of the matched structure. For example, (ALL = (HD . TL))
72     ;; matches a cons cell. ALL is bound to the cons cell, HD to its car
73     ;; and TL to its tail.
74     ;;
75     ;; . A predicate test applies the predicate to the item being matched.
76     ;; If the predicate returns NIL then the match fails.
77     ;; If it returns truth, then the nested pattern is matched. This is
78     ;; often just a symbol like K in the example.
79     ;;
80     ;; . Care should be taken with the domain values for predicate matches.
81     ;; If, in the above eg, item is not an integer, an error would occur
82     ;; during the test. A safer pattern would be
83     ;; (#'integerp (#'oddp k))
84     ;; This would only test for oddness of the item was an integer.
85     ;;
86     ;; . A single symbol will match anything so it can be used as a default
87     ;; case, like OTHER above.
88     ;;
89    
90     (defpackage :swank-match
91     (:use :cl)
92     (:export #:match))
93    
94     (in-package :swank-match)
95    
96     (defmacro match (expression &body patterns)
97     `(select-match ,expression ,@patterns))
98    
99     (defmacro select-match (expression &rest patterns)
100     (let* ( (do-let (not (atom expression)))
101     (key (if do-let (gensym) expression))
102     (cbody (expand-select-patterns key patterns))
103     (cform `(cond . ,cbody))
104     )
105    
106     (if do-let
107     `(let ((,key ,expression)) ,cform)
108     cform))
109     )
110    
111    
112     (defun expand-select-patterns (key patterns)
113     (if (eq (second patterns) '=>)
114     (expand-select-patterns-style-2 key patterns)
115     (expand-select-patterns-style-1 key patterns)))
116    
117    
118     (defun expand-select-patterns-style-1 (key patterns)
119    
120     (if (null patterns)
121    
122     `((t (error "Case select pattern match failure on ~S" ,key)))
123    
124     (let ((pattern (caar patterns))
125     (actions (cdar patterns))
126     (rest (cdr patterns)) )
127    
128     (let ( (test (compile-select-test key pattern))
129     (bindings (compile-select-bindings key pattern actions)))
130    
131     `( ,(if bindings `(,test (let ,bindings . ,actions))
132     `(,test . ,actions))
133     . ,(if (eq test t)
134     nil
135     (expand-select-patterns-style-1 key rest)))
136     )
137     )
138     ))
139    
140    
141    
142     (defun expand-select-patterns-style-2 (key patterns)
143    
144     (if (null patterns)
145    
146     `((t (error "Case select pattern match failure on ~S" ,key)))
147    
148     (let ((pattern (first patterns))
149     (arrow (if (or (< (length patterns) 3)
150     (not (eq (second patterns) '=>)))
151     (error "Illegal patterns: ~S" patterns)))
152     (actions (list (third patterns)))
153     (rest (cdddr patterns)) )
154    
155     (let ( (test (compile-select-test key pattern))
156     (bindings (compile-select-bindings key pattern actions)))
157    
158     `( ,(if bindings `(,test (let ,bindings . ,actions))
159     `(,test . ,actions))
160     . ,(if (eq test t)
161     nil
162     (expand-select-patterns-style-2 key rest)))
163     )
164     )
165     ))
166    
167    
168    
169     (defun compile-select-test (key pattern)
170     (let ((tests (remove-if
171     #'(lambda (item) (eq item t))
172     (compile-select-tests key pattern))))
173     (cond
174     ;; note AND does this anyway, but this allows us to tell if
175     ;; the pattern will always match.
176     ((null tests) t)
177     ((= (length tests) 1) (car tests))
178     (t `(and . ,tests)))))
179    
180    
181     (defun compile-select-tests (key pattern)
182    
183     (cond ((constantp pattern) `((,(cond ((numberp pattern) 'eql)
184     ((symbolp pattern) 'eq)
185     (t 'equal))
186     ,key ,pattern)))
187    
188     ((symbolp pattern) '(t))
189    
190     ((select-double-match? pattern)
191     (append
192     (compile-select-tests key (first pattern))
193     (compile-select-tests key (third pattern))))
194    
195     ((select-predicate? pattern)
196     (append
197     `((,(second (first pattern)) ,key))
198     (compile-select-tests key (second pattern))))
199    
200     ((consp pattern)
201     (append
202     `((consp ,key))
203     (compile-select-tests (!cs-car key) (car
204     pattern))
205     (compile-select-tests (!cs-cdr key) (cdr
206     pattern))))
207    
208     (t (error "Illegal select pattern: ~S" pattern))
209     )
210     )
211    
212    
213     (defun compile-select-bindings (key pattern action)
214    
215     (cond ((constantp pattern) '())
216     ((symbolp pattern)
217     (if (select!-in-tree pattern action) `((,pattern ,key))
218     '()))
219    
220     ((select-double-match? pattern)
221     (append
222     (compile-select-bindings key (first pattern) action)
223     (compile-select-bindings key (third pattern)
224     action)))
225    
226     ((select-predicate? pattern)
227     (compile-select-bindings key (second pattern)
228     action))
229    
230     ((consp pattern)
231     (append
232     (compile-select-bindings (!cs-car key) (car pattern)
233     action)
234     (compile-select-bindings (!cs-cdr key) (cdr pattern)
235     action)))
236     )
237     )
238    
239    
240     (defun select!-in-tree (atom tree)
241     (or (eq atom tree)
242     (if (consp tree)
243     (or (select!-in-tree atom (car tree))
244     (select!-in-tree atom (cdr tree))))))
245    
246     (defun select-double-match? (pattern)
247     ;; (<pattern> = <pattern>)
248     (and (consp pattern) (consp (cdr pattern)) (consp (cddr pattern))
249     (null (cdddr pattern))
250     (eq (second pattern) '=)))
251    
252    
253     (defun select-predicate? (pattern)
254     ;; ((function <f>) <pattern>)
255     (and (consp pattern)
256     (consp (cdr pattern))
257     (null (cddr pattern))
258     (consp (first pattern))
259     (consp (cdr (first pattern)))
260     (null (cddr (first pattern)))
261     (eq (caar pattern) 'function)))
262    
263    
264    
265    
266     (defun !cs-car (exp)
267     (!cs-car/cdr 'car exp '(
268     (car . caar) (cdr . cadr) (caar . caaar) (cadr . caadr)
269     (cdar . cadar) (cddr . caddr)
270     (caaar . caaaar) (caadr . caaadr) (cadar . caadar)
271     (caddr . caaddr) (cdaar . cadaar) (cdadr . cadadr)
272     (cddar . caddar) (cdddr . cadddr))))
273    
274     (defun !cs-cdr (exp)
275     (!cs-car/cdr 'cdr exp '(
276     (car . cdar) (cdr . cddr) (caar . cdaar) (cadr . cdadr)
277     (cdar . cddar) (cddr . cdddr)
278     (caaar . cdaaar) (caadr . cdaadr) (cadar . cdadar)
279     (caddr . cdaddr) (cdaar . cddaar) (cdadr . cddadr)
280     (cddar . cdddar) (cdddr . cddddr))))
281    
282     (defun !cs-car/cdr (op exp table)
283     (if (and (consp exp) (= (length exp) 2))
284     (let ((replacement (assoc (car exp) table)))
285     (if replacement
286     `(,(cdr replacement) ,(second exp))
287     `(,op ,exp)))
288     `(,op ,exp)))
289    
290     ;; (setf c1 '(select-match x (a 1) (b 2 3 4)))
291     ;; (setf c2 '(select-match (car y)
292     ;; (1 (print 100) 101) (2 200) ("hello" 5) (:x 20) (else (1+
293     ;; else))))
294     ;; (setf c3 '(select-match (caddr y)
295     ;; ((all = (x y)) (list x y all))
296     ;; ((a '= b) (list 'assign a b))
297     ;; ((#'oddp k) (1+ k)))))
298    
299    

  ViewVC Help
Powered by ViewVC 1.1.5