diff --git a/pcl/macros.lisp b/pcl/macros.lisp index a09b40a8b46bb64bdd465dea439158a35bc745fc..3de2e8d84864d8ee701b9a4fb84531e5dc9b23b9 100644 --- a/pcl/macros.lisp +++ b/pcl/macros.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/macros.lisp,v 1.15 2001/03/13 15:49:48 pw Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/macros.lisp,v 1.16 2002/08/19 16:52:09 pmai Exp $") ;;; ;;; Macros global variable definitions, and other random support stuff used ;;; by the rest of the system. @@ -195,96 +195,6 @@ (progn (setf ,alist (cons (,make-entry-fn ,key) ,alist)) (car ,alist))))) -;;; A simple version of destructuring-bind. - -;;; This does no more error checking than CAR and CDR themselves do. Some -;;; attempt is made to be smart about preserving intermediate values. It -;;; could be better, although the only remaining case should be easy for -;;; the compiler to spot since it compiles to PUSH POP. -;;; -;;; Common Lisp BUG: -;;; Common Lisp should have destructuring-bind. -;;; -(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)))) - -(eval-when (compile load eval) -(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 collecting-once (&key initial-value) `(let* ((head ,initial-value) (tail ,(and initial-value `(last head)))) diff --git a/pcl/pkg.lisp b/pcl/pkg.lisp index 18d092460b994fbdb266f1cf2c0d52ff23f73ae6..7faf287425d5100e892d410b206c06895411e73b 100644 --- a/pcl/pkg.lisp +++ b/pcl/pkg.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/pkg.lisp,v 1.17 2001/07/08 16:28:08 pw Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/pkg.lisp,v 1.18 2002/08/19 16:52:09 pmai Exp $") ;;; ;;; CMUCL 18a: Jan-1998 -- Changing to DEFPACKAGE. @@ -50,7 +50,6 @@ "*ITERATE-WARNINGS*")) (defpackage "PCL" (:use :common-lisp :walker :iterate) - (:shadow "DESTRUCTURING-BIND") (:shadow "FIND-CLASS" "CLASS-NAME" "CLASS-OF" "CLASS" "BUILT-IN-CLASS" "STRUCTURE-CLASS" "STANDARD-CLASS") diff --git a/pcl/vector.lisp b/pcl/vector.lisp index ae65cb487619689b30facbf2eac41be5be785140..7f3bd6a95638cf4659d6ab8c30821735d318d394 100644 --- a/pcl/vector.lisp +++ b/pcl/vector.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/vector.lisp,v 1.15 1999/05/30 23:14:09 pw Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/vector.lisp,v 1.16 2002/08/19 16:52:09 pmai Exp $") ;;; ;;; Permutation vectors. ;;; @@ -456,23 +456,39 @@ (defun optimize-slot-value (slots sparameter form) (if sparameter - (destructuring-bind (ignore ignore slot-name-form) form + (destructuring-bind (slot-value instance-form slot-name-form) form + (declare (ignore slot-value instance-form)) (let ((slot-name (eval slot-name-form))) (optimize-instance-access slots :read sparameter slot-name nil))) `(accessor-slot-value ,@(cdr form)))) (defun optimize-set-slot-value (slots sparameter form) (if sparameter - (destructuring-bind (ignore ignore slot-name-form new-value) form + (destructuring-bind + (set-slot-value instance-form slot-name-form new-value) form + (declare (ignore set-slot-value instance-form)) (let ((slot-name (eval slot-name-form))) - (optimize-instance-access slots :write sparameter slot-name new-value))) + (optimize-instance-access slots :write sparameter + slot-name new-value))) `(accessor-set-slot-value ,@(cdr form)))) (defun optimize-slot-boundp (slots sparameter form) (if sparameter - (destructuring-bind (ignore ignore slot-name-form new-value) form + ;; + ;; The original PCL code, which used its own definition of + ;; DESTRUCTURING-BIND, had a fourth variable NEW-VALUE below, + ;; that was passed to OPTIMIZE-INSTANCE-ACCESS as its NEW-VALUE + ;; argument; the NEW-VALUE seems not to be used in + ;; OPTIMIZE-INSTANCE-ACCESS for the :BOUNDP case. + ;; + ;; Using CL's DESTRUCTURING-BIND, one gets an error when + ;; building PCL because FORM has 3 elements only, which seems + ;; reasonable for a SLOT-BOUNDP form. I don't see a case where + ;; this function could be called with a form having 4 elements. + (destructuring-bind (slot-boundp instance-form slot-name-form) form + (declare (ignore slot-boundp instance-form)) (let ((slot-name (eval slot-name-form))) - (optimize-instance-access slots :boundp sparameter slot-name new-value))) + (optimize-instance-access slots :boundp sparameter slot-name nil))) `(accessor-slot-boundp ,@(cdr form)))) (defun optimize-reader (slots sparameter gf-name form) @@ -482,7 +498,8 @@ (defun optimize-writer (slots sparameter gf-name form) (if sparameter - (destructuring-bind (ignore ignore new-value) form + (destructuring-bind (writer instance-form new-value) form + (declare (ignore writer instance-form)) (optimize-accessor-call slots :write sparameter gf-name new-value)) form)) ;;;