suzanne.soy/2010-m1s1-compilation
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge branch 'master' of https://github.com/dumbs/2010-m1s1-compilation

Browse Source
This commit is contained in:
Bertrand BRUN 2010-11-07 02:26:18 +01:00
commit 534d55ada7
1 changed files with 20 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
match.lisp
View File

@ -40,7 +40,7 @@
((eq (car pred) 'lambda) pred)
(t
`(lambda (x) ,pred))))
(cdr pattern)))
pattern))
(defun pattern-match-do-lambdas-1 (pattern)
(if (atom pattern)
@ -48,15 +48,21 @@
`(list ',(first pattern)
',(second pattern)
,(if (second pattern)
(let ((?-clause (third pattern)))
(cond ((atom (cdr ?-clause)) `(list 'and #'identity))
((eq 'and (second ?-clause)) `(list 'and ,@(pattern-match-do-lambdas-transform (cdr ?-clause))))
((eq 'or (second ?-clause)) `(list 'or ,@(pattern-match-do-lambdas-transform (cdr ?-clause))))
(t `(list 'and ,@(pattern-match-do-lambdas-transform ?-clause)))))
(let ((?-clause (cdr (third pattern)))
(type '_))
(when (and (consp ?-clause) (member (car ?-clause) '(nil _ $ @ @.)))
(setq type (car ?-clause))
(setq ?-clause (cdr ?-clause)))
(cond ((atom ?-clause) `(list ',type 'and #'identity))
((eq 'and (first ?-clause)) `(list ',type 'and ,@(pattern-match-do-lambdas-transform (cdr ?-clause))))
((eq 'or (first ?-clause)) `(list ',type 'or ,@(pattern-match-do-lambdas-transform (cdr ?-clause))))
(t `(list ',type 'and ,@(pattern-match-do-lambdas-transform ?-clause)))))
(pattern-match-do-lambdas-1 (third pattern)))
',(fourth pattern)
,(pattern-match-do-lambdas-1 (fifth pattern)))))
(pattern-match-preprocess (? car cdr))
(defmacro pattern-match-do-lambdas (pattern)
"Transforme les (? (<code>)) et (? (lambda ...)) en vrais lambdas."
(pattern-match-do-lambdas-1 pattern))
@ -328,13 +334,14 @@
(cond
;; (? <prédicat(s)>)
(is-predicate
(when (cond
;; (? and symbole-1 ... symbole-n)
((eq 'and (first pattern))
(every (lambda (predicat) (funcall predicat expr)) (cdr pattern)))
;; (? or symbole-1 ... symbole-n)
((eq 'or (first pattern))
(some (lambda (predicat) (funcall predicat expr)) (cdr pattern))))
(when (and (pattern-match `(nil nil ,(car pattern) nil nil) expr)
(cond
;; (? and symbole-1 ... symbole-n)
((eq 'and (second pattern))
(every (lambda (predicat) (funcall predicat expr)) (cddr pattern)))
;; (? or symbole-1 ... symbole-n)
((eq 'or (second pattern))
(some (lambda (predicat) (funcall predicat expr)) (cddr pattern)))))
(acons-capture capture-name expr nil)))
;; ()
((null pattern)