Greetings! As you may know, I lifted the destructuring-bind James had
setup in maxima and added it to gcl-2.5.0.
Problem is, it doesn't quite give the correct result for the example
listed in the ansi hyperspec. To wit:
(defun iota (n) (list n (+ n 1) (+ n 2)))
IOTA
Top level.
> (destructuring-bind ((a &optional (b 'bee)) one two three)
`((alpha) ,@(iota 3))
(list a b three two one))
> >
(ALPHA NIL 5 4 3)
(not (ALPHA BEE 3 2 1))
I've included the code below. Could some lisp hacker spot the error?
Take care,
--
Camm Maguire camm@enhanced.com
==========================================================================
"The earth is but one country, and mankind its citizens." -- Baha'u'llah
------- Start of forwarded message -------
To: "Vadim V. Zhytnikov" <vvzhy@mail.ru>
cc: gcl-devel@gnu.org
Subject: Re: [Gcl-devel] GCL cvs build failure on Linux
References: <3C651F67.C7705DD8@mail.ru> <543d0ay37v.fsf@intech19.enhanced.com> <3C664E7B.2ED50E15@mail.ru>
From: Camm Maguire <camm at enhanced>
Message-ID: <54heome6jy.fsf@intech19.enhanced.com>
Date: 12 Feb 2002 16:25:37 -0500
Greetings!
> > Will someone please try the example for destructuring-bind as listed
> > in the ansi hyper-spec? The code I've put in, stolen from Maxima
> > stolen from cmulisp, doesn't seem to give the intended answer.
> >
> > Take care,
> >
"Vadim V. Zhytnikov" <vvzhy@mail.ru> writes:
> I confirm. I've got right result for CLHS example with
> CLISP and CMUCL. But result with GCL from CVS
> is wrong. I guess we've met another GCL ANSI
> incompatibility.
>
> Vadim
OK, Vadim, as our resident lisp expert, could you please look at the
source below and perhaps tell me why its not working as advertised?
=============================================================================
(in-package 'lisp)
(export '(destructuring-bind))
(in-package 'system)
;(proclaim '(optimize (safety 2) (space 3)))
(defmacro memq (item list) `(member ,item ,list :test #'eq))
(defun make-caxr (n form)
(if (< n 4)
`(,(nth n '(car cadr caddr cadddr)) ,form)
(make-caxr (- n 4) `(cddddr ,form))))
(defun make-cdxr (n form)
(cond ((zerop n) form)
((< n 5) `(,(nth n '(identity cdr cddr cdddr cddddr)) ,form))
(t (make-cdxr (- n 4) `(cddddr ,form)))))
)
(defun extract-declarations (body &optional environment)
;;(declare (values documentation declarations body))
(let (documentation declarations form)
(when (and (stringp (car body))
(cdr body))
(setq documentation (pop body)))
(block outer
(loop
(when (null body) (return-from outer nil))
(setq form (car body))
(when (block inner
(loop (cond ((not (listp form))
(return-from outer nil))
((eq (car form) 'declare)
(return-from inner 't))
(t
(multiple-value-bind (newform macrop)
(macroexpand-1 form environment)
(if (or (not (eq newform form)) macrop)
(setq form newform)
(return-from outer nil)))))))
(pop body)
(dolist (declaration (cdr form))
(push declaration declarations)))))
(values documentation
(and declarations `((declare ,.(nreverse declarations))))
body)))
(proclaim '(function destructure-internal (t t) *))
(defun destructure (pattern form)
;;(declare (values setqs binds))
(let ((*destructure-vars* ())
(setqs ()))
(declare (special *destructure-vars*))
(setq *destructure-vars* '(destructure-form)
setqs (list `(setq destructure-form ,form))
form 'destructure-form)
(values (nconc setqs (nreverse (destructure-internal pattern form)))
(delete nil *destructure-vars*))))
(defun destructure-internal (pattern form)
;; When we are called, pattern must be a list. Form should be a symbol
;; which we are free to setq containing the value to be destructured.
;; Optimizations are performed for the last element of pattern cases.
;; we assume that the compiler is smart about gensyms which are bound
;; but only for a short period of time.
(declare (special *destructure-vars*))
(let ((gensym (gensym))
(pending-pops 0)
(var nil)
(setqs ()))
(labels
((make-pop (var form pop-into)
(prog1
(cond ((zerop pending-pops)
`(progn ,(and var `(setq ,var (car ,form)))
,(and pop-into `(setq ,pop-into (cdr ,form)))))
((null pop-into)
(and var `(setq ,var ,(make-caxr pending-pops form))))
(t
`(progn (setq ,pop-into ,(make-cdxr pending-pops form))
,(and var `(setq ,var (pop ,pop-into))))))
(setq pending-pops 0))))
(do ((pat pattern (cdr pat)))
((null pat) ())
(if (symbolp (setq var (car pat)))
(progn
(unless (memq var '(nil ignore))
(push var *destructure-vars*))
(cond ((null (cdr pat))
(push (make-pop var form ()) setqs))
((symbolp (cdr pat))
(push (make-pop var form (cdr pat)) setqs)
(push (cdr pat) *destructure-vars*)
(return ()))
((memq var '(nil ignore)) (incf pending-pops))
((memq (cadr pat) '(nil ignore))
(push (make-pop var form ()) setqs)
(incf pending-pops 1))
(t
(push (make-pop var form form) setqs))))
(progn
(push `(let ((,gensym ()))
,(make-pop gensym
form
(if (symbolp (cdr pat)) (cdr pat) form))
,@(nreverse
(destructure-internal (car pat) gensym)))
setqs)
(when (symbolp (cdr pat))
(push (cdr pat) *destructure-vars*)
(return)))))
setqs)))
)
(defmacro destructuring-bind (pattern form &body body)
(multiple-value-bind (ignore declares body)
(extract-declarations body)
(declare (ignore ignore))
(multiple-value-bind (setqs binds)
(destructure pattern form)
`(let ,binds
,@declares
,@setqs
(progn destructure-form)
. ,body))))
;;; end of destructuring-bind code from cmucl.
=============================================================================
>
> Camm Maguire wrote:
>
> > Greetings!
> >
> > C Y <smustudent1@yahoo.com> writes:
> >
> > > >From Maxima list:
> > >
> > > > And, actually, if a missing destructuring-bind is really the problem,
> > > > I think we should just add a version for maxima and gcl, and wait
> > > > until
> > > > gcl gets it's own version. (Should be able to steal one from CMUCL.)
> > >
> > > Maybe something to add to the TODO list?
> > >
> > > CY
> > >
> > > __________________________________________________
> > > Do You Yahoo!?
> > > Send FREE video emails in Yahoo! Mail!
> > > http://promo.yahoo.com/videomail/
> > >
> > >
> >
> > --
> > Camm Maguire camm@enhanced.com
> > ==========================================================================
> > "The earth is but one country, and mankind its citizens." -- Baha'u'llah
> >
> > _______________________________________________
> > Gcl-devel mailing list
> > Gcl-devel@gnu.org
> > http://mail.gnu.org/mailman/listinfo/gcl-devel
>
> --
>
> [ Vadim V. Zhytnikov <vvzhy@mail.ru> <vvzhy@td.lpi.ac.ru> ]
>
>
>
>
>
>
--
Camm Maguire camm@enhanced.com
==========================================================================
"The earth is but one country, and mankind its citizens." -- Baha'u'llah
_______________________________________________
Gcl-devel mailing list
Gcl-devel@gnu.org
http://mail.gnu.org/mailman/listinfo/gcl-devel
------- End of forwarded message -------