-
Notifications
You must be signed in to change notification settings - Fork 22
/
impl.lisp
84 lines (75 loc) · 2.71 KB
/
impl.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
(in-package :trivia.level0)
(defvar *what*)
(defvar *bindings*)
(defvar *env*)
(defmacro match0 (*what* &body clauses &environment *env*)
(once-only (*what*)
(parse-patterns clauses)))
(defmacro ematch0 (what &body clauses)
`(match0 ,what
,@clauses
(_ (error "level0 match error!"))))
(defmacro lambda-match0 (&body clauses)
(alexandria:with-gensyms (arg)
`(lambda (,arg)
(match0 ,arg
,@clauses))))
(defmacro lambda-ematch0 (&body clauses)
(alexandria:with-gensyms (arg)
`(lambda (,arg)
(ematch0 ,arg
,@clauses))))
(defun parse-patterns (clauses)
(if (null clauses)
nil
(destructuring-bind ((pattern &rest body) . rest) clauses
(multiple-value-bind (condition bindings)
(let ((*bindings* nil))
(values (make-pattern-predicate pattern)
*bindings*))
`(if ,condition
(let* ,(reverse bindings)
(declare (ignorable ,@(mapcar #'first bindings)))
,@body)
,(parse-patterns rest))))))
(defun make-pattern-predicate (pattern)
(if (atom pattern)
(cond
((constantp pattern *env*) `(equal ,*what* ,pattern))
((symbolp pattern)
(unless (string= "_" (symbol-name pattern))
(push `(,pattern ,*what*) *bindings*))
t)
(t (error "what is this? ~a" pattern)))
(destructuring-bind (name . args) pattern
(ecase name
(quote `(equal ,*what* ',@args))
(cons
(destructuring-bind (car cdr) args
`(and (consp ,*what*)
,(let* ((what `(car ,*what*))
(*what* what))
(once-only (*what*)
(push `(,*what* ,what) *bindings*)
(make-pattern-predicate car)))
,(let* ((what `(cdr ,*what*))
(*what* what))
(once-only (*what*)
(push `(,*what* ,what) *bindings*)
(make-pattern-predicate cdr))))))
(list
(if args
(destructuring-bind (car . cdr) args
(make-pattern-predicate
(if cdr
`(cons ,car (list ,@cdr))
`(cons ,car nil))))
`(null ,*what*)))
(list*
(assert (not (null args)) nil "invalid list* pattern: needs at least 1 arg")
;; FIXME most lisps allow destructuring-bind on NIL ; ABCL does not. bug?
(destructuring-bind (car . cdr) args
(make-pattern-predicate
(if cdr
`(cons ,car (list* ,@cdr))
car))))))))