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
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
|
(export '(destructuring-bind lambda-list-keywords
&allow-other-keys &aux &body &environment &key &optional &rest
&whole))
;; D-B may not expand to (but _may_ itself use!) plain list function
;; calls because these are defined in list-functions.lisp by way of
;; DEFUN, which is in turn based on D-B. Because of this, we define our
;; own functions here.
(%defun* %car (list)
(sys::car list))
(%defun* %cdr (list)
(sys::cdr list))
(setq lambda-list-keywords
'(&allow-other-keys &aux &body &environment &key &optional &rest &whole))
(%defmacro* d-b (lambda-list environment whole-sym expression . body)
;; (ns-log lambda-list)
`(let* ,(unless whole-sym
(let ((real-expression expression))
(setq whole-sym (gensym "WHOLE")
expression (gensym "EXPRESSION"))
`((,expression ,real-expression)
(,whole-sym ,expression))))
,(cond ((consp lambda-list)
(case (car lambda-list)
(&environment
`(let ((,(cadr lambda-list) ,environment))
(d-b ,(cddr lambda-list) ,environment ,whole-sym ,expression
,@body)))
(&aux
(if (or (endp (cdr lambda-list))
(%member (cadr lambda-list) lambda-list-keywords))
`(d-b ,(cdr lambda-list) ,environment ,whole-sym ,expression
,@body)
`(let (,(cadr lambda-list))
(d-b (&aux ,@(cddr lambda-list)) ,environment ,whole-sym ,expression
,@body))))
(&optional
(if (or (endp (cdr lambda-list))
(%member (cadr lambda-list) lambda-list-keywords))
`(d-b ,(cdr lambda-list) ,environment ,whole-sym ,expression
,@body)
(let ((sym (gensym))
(head (cadr lambda-list)))
`(let* ((,sym ,expression)
,@(cond ((atom head)
`((,head (%car ,sym))))
((null (cdr head))
`((,(car head) (%car ,sym))))
((null (cddr head))
`((,(car head) (if (null ,sym)
,(cadr head)
(%car ,sym)))))
(t
`((,(car head) (if (null ,sym)
,(cadr head)
(%car ,sym)))
(,(caddr head) (not (null ,sym)))))))
(d-b (&optional ,@(cddr lambda-list)) ,environment ,whole-sym (%cdr ,sym)
,@body)))))
((&rest &body)
(if (%member (cadr lambda-list) lambda-list-keywords)
`(d-b ,(cdr lambda-list) ,environment ,whole-sym ,expression
,@body)
(let ((sym (gensym)))
`(let* ((,sym ,expression)
(,(cadr lambda-list) ,sym))
(d-b ,(cddr lambda-list) ,environment ,whole-sym ,sym
,@body)))))
(&whole
`(let ((,(cadr lambda-list) ,whole-sym))
(d-b ,(cddr lambda-list) ,environment ,whole-sym ,expression
,@body)))
(&allow-other-keys
`(d-b ,(cdr lambda-list) ,environment ,whole-sym ,expression
,@body))
(&key
(if (or (endp (cdr lambda-list))
(%member (cadr lambda-list) lambda-list-keywords))
`(d-b ,(cdr lambda-list) ,environment ,whole-sym ,expression
,@body)
(let* ((sym (gensym))
(value-sym (gensym))
(missing (gensym "MISSING"))
(head (cadr lambda-list))
(var (if (consp head)
(if (consp (car head))
(cadar head)
(car head))
head))
(keyword-name
(if (and (consp head) (consp (car head)))
(caar head)
(intern (symbol-name var) (find-package '#:keyword)))))
`(let* ((,sym ,expression)
(,value-sym (getf ,sym ,keyword-name ',missing))
,@(cond ((atom head)
`((,var ,value-sym)))
((null (cdr head))
`((,var ,value-sym)))
((null (cddr head))
`((,var (if (eq ,value-sym ',missing)
,(cadr head)
,value-sym))))
(t
`((,var (if (eq ,value-sym ',missing)
,(cadr head)
,value-sym))
(,(caddr head) (not (eq ,value-sym ',missing)))))))
(d-b (&key ,@(cddr lambda-list)) ,environment ,whole-sym ,sym
,@body)))))
(otherwise
(let ((sym (gensym)))
`(let ((,sym ,expression))
(d-b ,(car lambda-list) ,environment ,whole-sym (%car ,sym)
(d-b ,(cdr lambda-list) ,environment ,whole-sym (%cdr ,sym)
,@body)))))))
((null lambda-list)
`(progn ,@body))
(t `(let ((,lambda-list ,expression))
,@body)))))
(%defmacro* destructuring-bind (tree expression . body)
`(d-b ,tree nil nil ,expression ,@body))
|
