1 |
|
(in-package 'lisp) |
2 |
|
|
3 |
|
(export '(destructuring-bind)) |
4 |
|
|
5 |
|
(in-package 'system) |
6 |
|
|
7 |
|
;(proclaim '(optimize (safety 2) (space 3))) |
8 |
|
|
9 |
|
(defmacro memq (item list) `(member ,item ,list :test #'eq)) |
10 |
|
|
11 |
|
(defun make-caxr (n form) |
12 |
|
(if (< n 4) |
13 |
|
`(,(nth n '(car cadr caddr cadddr)) ,form) |
14 |
|
(make-caxr (- n 4) `(cddddr ,form)))) |
15 |
|
|
16 |
|
(defun make-cdxr (n form) |
17 |
|
(cond ((zerop n) form) |
18 |
|
((< n 5) `(,(nth n '(identity cdr cddr cdddr cddddr)) ,form)) |
19 |
|
(t (make-cdxr (- n 4) `(cddddr ,form))))) |
20 |
|
) |
21 |
|
|
22 |
|
(defun extract-declarations (body &optional environment) |
23 |
|
;;(declare (values documentation declarations body)) |
24 |
|
(let (documentation declarations form) |
25 |
|
(when (and (stringp (car body)) |
26 |
|
(cdr body)) |
27 |
|
(setq documentation (pop body))) |
28 |
|
(block outer |
29 |
|
(loop |
30 |
|
(when (null body) (return-from outer nil)) |
31 |
|
(setq form (car body)) |
32 |
|
(when (block inner |
33 |
|
(loop (cond ((not (listp form)) |
34 |
|
(return-from outer nil)) |
35 |
|
((eq (car form) 'declare) |
36 |
|
(return-from inner 't)) |
37 |
|
(t |
38 |
|
(multiple-value-bind (newform macrop) |
39 |
|
(macroexpand-1 form environment) |
40 |
|
(if (or (not (eq newform form)) macrop) |
41 |
|
(setq form newform) |
42 |
|
(return-from outer nil))))))) |
43 |
|
(pop body) |
44 |
|
(dolist (declaration (cdr form)) |
45 |
|
(push declaration declarations))))) |
46 |
|
(values documentation |
47 |
|
(and declarations `((declare ,.(nreverse declarations)))) |
48 |
|
body))) |
49 |
|
(proclaim '(function destructure-internal (t t) *)) |
50 |
|
(defun destructure (pattern form) |
51 |
|
;;(declare (values setqs binds)) |
52 |
|
(let ((*destructure-vars* ()) |
53 |
|
(setqs ())) |
54 |
|
(declare (special *destructure-vars*)) |
55 |
|
(setq *destructure-vars* '(destructure-form) |
56 |
|
setqs (list `(setq destructure-form ,form)) |
57 |
|
form 'destructure-form) |
58 |
|
(values (nconc setqs (nreverse (destructure-internal pattern form))) |
59 |
|
(delete nil *destructure-vars*)))) |
60 |
|
(defun destructure-internal (pattern form) |
61 |
|
;; When we are called, pattern must be a list. Form should be a symbol |
62 |
|
;; which we are free to setq containing the value to be destructured. |
63 |
|
;; Optimizations are performed for the last element of pattern cases. |
64 |
|
;; we assume that the compiler is smart about gensyms which are bound |
65 |
|
;; but only for a short period of time. |
66 |
|
(declare (special *destructure-vars*)) |
67 |
|
(let ((gensym (gensym)) |
68 |
|
(pending-pops 0) |
69 |
|
(var nil) |
70 |
|
(setqs ())) |
71 |
|
(labels |
72 |
|
((make-pop (var form pop-into) |
73 |
|
(prog1 |
74 |
|
(cond ((zerop pending-pops) |
75 |
|
`(progn ,(and var `(setq ,var (car ,form))) |
76 |
|
,(and pop-into `(setq ,pop-into (cdr ,form))))) |
77 |
|
((null pop-into) |
78 |
|
(and var `(setq ,var ,(make-caxr pending-pops form)))) |
79 |
|
(t |
80 |
|
`(progn (setq ,pop-into ,(make-cdxr pending-pops form)) |
81 |
|
,(and var `(setq ,var (pop ,pop-into)))))) |
82 |
|
(setq pending-pops 0)))) |
83 |
|
(do ((pat pattern (cdr pat))) |
84 |
|
((null pat) ()) |
85 |
|
(if (symbolp (setq var (car pat))) |
86 |
|
(progn |
87 |
|
(unless (memq var '(nil ignore)) |
88 |
|
(push var *destructure-vars*)) |
89 |
|
(cond ((null (cdr pat)) |
90 |
|
(push (make-pop var form ()) setqs)) |
91 |
|
((symbolp (cdr pat)) |
92 |
|
(push (make-pop var form (cdr pat)) setqs) |
93 |
|
(push (cdr pat) *destructure-vars*) |
94 |
|
(return ())) |
95 |
|
((memq var '(nil ignore)) (incf pending-pops)) |
96 |
|
((memq (cadr pat) '(nil ignore)) |
97 |
|
(push (make-pop var form ()) setqs) |
98 |
|
(incf pending-pops 1)) |
99 |
|
(t |
100 |
|
(push (make-pop var form form) setqs)))) |
101 |
|
(progn |
102 |
|
(push `(let ((,gensym ())) |
103 |
|
,(make-pop gensym |
104 |
|
form |
105 |
|
(if (symbolp (cdr pat)) (cdr pat) form)) |
106 |
|
,@(nreverse |
107 |
|
(destructure-internal (car pat) gensym))) |
108 |
|
setqs) |
109 |
|
(when (symbolp (cdr pat)) |
110 |
|
(push (cdr pat) *destructure-vars*) |
111 |
|
(return))))) |
112 |
|
setqs))) |
113 |
|
) |
114 |
|
(defmacro destructuring-bind (pattern form &body body) |
115 |
|
(multiple-value-bind (ignore declares body) |
116 |
|
(extract-declarations body) |
117 |
|
(declare (ignore ignore)) |
118 |
|
(multiple-value-bind (setqs binds) |
119 |
|
(destructure pattern form) |
120 |
|
`(let ,binds |
121 |
|
,@declares |
122 |
|
,@setqs |
123 |
|
(progn destructure-form) |
124 |
|
. ,body)))) |
125 |
|
|
126 |
|
|
127 |
|
|
128 |
|
;;; end of destructuring-bind code from cmucl. |