From c7410461f77fe65c2913b17d2936c4f6dea2c016 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Mon, 11 Nov 2002 01:55:19 +0000 Subject: [PATCH] 0.7.9.40: Fix PSETQ.7 from the GCL ANSI test suite ... delegate to PSETF, provided the syntax is valid ... performed a little attendant debogobootstrapification 0.7.9.39: (for version.lisp-expr history fanatics) Merge MRD PEEK-CHAR-WRONGLY-ECHOS-TO-ECHO-STREAM patch --- NEWS | 2 + src/code/defboot.lisp | 110 +++++++++++++++++++--------------------------- tests/compiler.pure.lisp | 21 +++++++++ version.lisp-expr | 2 +- 4 files changed, 69 insertions(+), 66 deletions(-) diff --git a/NEWS b/NEWS index 2ab4ef4..441a859 100644 --- a/NEWS +++ b/NEWS @@ -1388,6 +1388,8 @@ changes in sbcl-0.7.10 relative to sbcl-0.7.9: ** LOOP supports DOWNTO and ABOVE properly (thanks to Matthew Danish) ** FUNCALL of special-operators now cause an error of type UNDEFINED-FUNCTION; + ** PSETQ now works as required in the presence of side-effecting + symbol-macro places; * fixed bug 166: compiler preserves "there is a way to go" invariant when deleting code. * fixed bug 172: macro lambda lists with required arguments after diff --git a/src/code/defboot.lisp b/src/code/defboot.lisp index aa4c5a7..383c9f3 100644 --- a/src/code/defboot.lisp +++ b/src/code/defboot.lisp @@ -149,8 +149,6 @@ ;; the only unsurprising choice. (info :function :inline-expansion-designator name))) -;;; Now that we have the definition of MULTIPLE-VALUE-BIND, we can -;;; make a reasonably readable definition of DEFUN. (defmacro-mundanely defun (&environment env name args &body body) "Define a function at top level." #+sb-xc-host @@ -249,7 +247,7 @@ `((unless (boundp ',var) (setq ,var ,val)))) ,@(when docp - `((funcall #'(setf fdocumentation) ',doc ',var 'variable))) + `((setf (fdocumentation ',var 'variable) ',doc ))) ',var)) (defmacro-mundanely defparameter (var val &optional (doc nil docp)) @@ -263,10 +261,7 @@ (declaim (special ,var)) (setq ,var ,val) ,@(when docp - ;; FIXME: The various FUNCALL #'(SETF FDOCUMENTATION) and - ;; other FUNCALL #'(SETF FOO) forms in the code should - ;; unbogobootstrapized back to ordinary SETF forms. - `((funcall #'(setf fdocumentation) ',doc ',var 'variable))) + `((setf (fdocumentation ',var 'variable) ',doc))) ',var)) ;;;; iteration constructs @@ -306,49 +301,40 @@ ;;; defined that it looks as though it's worth just implementing them ;;; ASAP, at the cost of being unable to use the standard ;;; destructuring mechanisms. -(defmacro-mundanely dotimes (var-count-result &body body) - (multiple-value-bind ; to roll our own destructuring - (var count result) - (apply (lambda (var count &optional (result nil)) - (values var count result)) - var-count-result) - (cond ((numberp count) - `(do ((,var 0 (1+ ,var))) - ((>= ,var ,count) ,result) - (declare (type unsigned-byte ,var)) - ,@body)) - (t (let ((v1 (gensym))) - `(do ((,var 0 (1+ ,var)) (,v1 ,count)) - ((>= ,var ,v1) ,result) - (declare (type unsigned-byte ,var)) - ,@body)))))) -(defmacro-mundanely dolist (var-list-result &body body) - (multiple-value-bind ; to roll our own destructuring - (var list result) - (apply (lambda (var list &optional (result nil)) - (values var list result)) - var-list-result) - ;; We repeatedly bind the var instead of setting it so that we - ;; never have to give the var an arbitrary value such as NIL - ;; (which might conflict with a declaration). If there is a result - ;; form, we introduce a gratuitous binding of the variable to NIL - ;; without the declarations, then evaluate the result form in that - ;; environment. We spuriously reference the gratuitous variable, - ;; since we don't want to use IGNORABLE on what might be a special - ;; var. - (multiple-value-bind (forms decls) (parse-body body nil) - (let ((n-list (gensym))) - `(do* ((,n-list ,list (cdr ,n-list))) - ((endp ,n-list) - ,@(if result - `((let ((,var nil)) - ,var - ,result)) - '(nil))) - (let ((,var (car ,n-list))) - ,@decls - (tagbody - ,@forms))))))) +(defmacro-mundanely dotimes ((var count &optional (result nil)) &body body) + (cond ((numberp count) + `(do ((,var 0 (1+ ,var))) + ((>= ,var ,count) ,result) + (declare (type unsigned-byte ,var)) + ,@body)) + (t (let ((v1 (gensym))) + `(do ((,var 0 (1+ ,var)) (,v1 ,count)) + ((>= ,var ,v1) ,result) + (declare (type unsigned-byte ,var)) + ,@body))))) + +(defmacro-mundanely dolist ((var list &optional (result nil)) &body body) + ;; We repeatedly bind the var instead of setting it so that we never + ;; have to give the var an arbitrary value such as NIL (which might + ;; conflict with a declaration). If there is a result form, we + ;; introduce a gratuitous binding of the variable to NIL without the + ;; declarations, then evaluate the result form in that + ;; environment. We spuriously reference the gratuitous variable, + ;; since we don't want to use IGNORABLE on what might be a special + ;; var. + (multiple-value-bind (forms decls) (parse-body body nil) + (let ((n-list (gensym))) + `(do* ((,n-list ,list (cdr ,n-list))) + ((endp ,n-list) + ,@(if result + `((let ((,var nil)) + ,var + ,result)) + '(nil))) + (let ((,var (car ,n-list))) + ,@decls + (tagbody + ,@forms)))))) ;;;; miscellaneous @@ -361,21 +347,15 @@ Set the variables to the values, like SETQ, except that assignments happen in parallel, i.e. no assignments take place until all the forms have been evaluated." - ;; (This macro is used in the definition of DO, so we can't use DO in the - ;; definition of this macro without getting into confusing bootstrap issues.) - (prog ((lets nil) - (setqs nil) - (pairs pairs)) - :again - (when (atom (cdr pairs)) - (return `(let ,(nreverse lets) - (setq ,@(nreverse setqs)) - nil))) - (let ((gen (gensym))) - (setq lets (cons `(,gen ,(cadr pairs)) lets) - setqs (list* gen (car pairs) setqs) - pairs (cddr pairs))) - (go :again))) + ;; Given the possibility of symbol-macros, we delegate to PSETF + ;; which knows how to deal with them, after checking that syntax is + ;; compatible with PSETQ. + (do ((pair pairs (cddr pair))) + ((endp pair) `(psetf ,@pairs)) + (unless (symbolp (car pair)) + (error 'simple-program-error + :format-control "variable ~S in PSETQ is not a SYMBOL" + :format-arguments (list (car pair)))))) (defmacro-mundanely lambda (&whole whole args &body body) (declare (ignore args body)) diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index a4e7476..a7bdfe4 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -222,6 +222,7 @@ (assert (null result)) (assert (typep error 'program-error))) +;;; ECASE should treat a bare T as a literal key (multiple-value-bind (result error) (ignore-errors (ecase 1 (t 0))) (assert (null result)) @@ -247,3 +248,23 @@ (assert (null result)) (assert (typep error 'undefined-function)) (assert (eq (cell-error-name error) 'and))) + +;;; PSETQ should behave when given complex symbol-macro arguments +(multiple-value-bind (sequence index) + (symbol-macrolet ((x (aref a (incf i))) + (y (aref a (incf i)))) + (let ((a (copy-seq #(0 1 2 3 4 5 6 7 8 9))) + (i 0)) + (psetq x (aref a (incf i)) + y (aref a (incf i))) + (values a i))) + (assert (equalp sequence #(0 2 2 4 4 5 6 7 8 9))) + (assert (= index 4))) + +(multiple-value-bind (result error) + (ignore-errors + (let ((x (list 1 2))) + (psetq (car x) 3) + x)) + (assert (null result)) + (assert (typep error 'program-error))) diff --git a/version.lisp-expr b/version.lisp-expr index b27b312..ace327a 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.7.9.38" +"0.7.9.40" -- 1.7.10.4