/[gcl]/gcl/lsp/destructuring_bind.lsp
ViewVC logotype

Diff of /gcl/lsp/destructuring_bind.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by camm, Fri Jan 18 03:26:28 2002 UTC revision 1.2 by camm, Sun Feb 3 18:44:07 2002 UTC
# Line 0  Line 1 
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.

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26