From 56f96e77ade913d6363a3068c94e60f44ae9b3e7 Mon Sep 17 00:00:00 2001 From: William Harold Newman Date: Mon, 2 Sep 2002 03:18:07 +0000 Subject: [PATCH] 0.7.7.10: got rid of SB-PCL::PROCESS-LAMBDA-LIST in favor of reusing PARSE-LAMBDA-LIST Why is PARSE-LAMBDA-LIST in SB-KERNEL? Move it to SB-INT. Now that we rely on ordinary PARSE-LAMBDA-LIST to catch some of the things Alexey's PROCESS-LAMBDA-LIST caught, it should be a little less credulous about things like non-symbols being used as var names. Argh! PARSE-LAMBDA-LIST isn't just used for lambda lists. That would be too obvious.:-( Instead it's also used for "lambda-list-like" things, in PARSE-ARGS-TYPES. So... ...Split the no-sanity-checking version of P-L-L into PARSE-LAMBDA-LIST-LIKE-THING. ...Make PARSE-ARGS-TYPES call P-L-L-L-THING. ...Define PARSE-LAMBDA-LIST in terms of P-L-L-L-THING. ANSI: MAX and MIN "should signal an error of type TYPE-ERROR if any NUMBER is not a REAL". lrasinen on #lisp: "stupid CMUCL". me: "gotta fix this so SBCL can win ICFP next year". (afterthought: "or this year, if you check this patched version out of CVS and then code really fast":-) (extra afterthought: "or maybe next year after all, since bug 194 seems to keep the new THEs from solving the problem") --- BUGS | 8 ++ package-data-list.lisp-expr | 4 +- src/code/defstruct.lisp | 2 +- src/code/late-type.lisp | 2 +- src/code/numbers.lisp | 2 + src/compiler/parse-lambda-list.lisp | 213 ++++++++++++++++++++++------------- src/compiler/srctran.lisp | 10 +- src/pcl/boot.lisp | 56 +++++---- src/pcl/macros.lisp | 62 ---------- tests/arith.pure.lisp | 9 ++ tests/compiler.pure.lisp | 15 +++ version.lisp-expr | 2 +- 12 files changed, 214 insertions(+), 171 deletions(-) diff --git a/BUGS b/BUGS index ffc5ebb..a2af047 100644 --- a/BUGS +++ b/BUGS @@ -1349,6 +1349,14 @@ WORKAROUND: error message stays the same (even BACKTRACE doesn't tell you what the bad argument value is). +194: "no error from (THE REAL '(1 2 3)) in some cases" + In sbcl-0.7.7.9, + (multiple-value-prog1 (progn (the real '(1 2 3)))) + returns (1 2 3) instead of signalling an error. Also in sbcl-0.7.7.9, + a more complicated instance of this bug kept + (IGNORE-ERRORS (MIN '(1 2 3))) from returning NIL as it should when + the MIN source transform expanded to (THE REAL '(1 2 3)), because + (IGNORE-ERRORS (THE REAL '(1 2 3))) returns (1 2 3). DEFUNCT CATEGORIES OF BUGS IR1-#: diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 966d3b2..b074a2e 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -833,7 +833,7 @@ retained, possibly temporariliy, because it might be used internally." "WHITESPACE-CHAR-P" "LISTEN-SKIP-WHITESPACE" "PACKAGE-INTERNAL-SYMBOL-COUNT" "PACKAGE-EXTERNAL-SYMBOL-COUNT" - "PARSE-BODY" + "PARSE-BODY" "PARSE-LAMBDA-LIST" "PARSE-LAMBDA-LIST-LIKE-THING" "PROPER-LIST-OF-LENGTH-P" "LIST-OF-LENGTH-AT-LEAST-P" "LIST-WITH-LENGTH-P" @@ -1163,7 +1163,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "PACKAGE-DOC-STRING" "PACKAGE-HASHTABLE-SIZE" "PACKAGE-HASHTABLE-FREE" "PACKAGE-INTERNAL-SYMBOLS" "PACKAGE-EXTERNAL-SYMBOLS" - "PARSE-DEFMACRO" "PARSE-LAMBDA-LIST" "PARSE-UNKNOWN-TYPE" + "PARSE-DEFMACRO" "PARSE-UNKNOWN-TYPE" "PARSE-UNKNOWN-TYPE-SPECIFIER" "PATHNAME-DESIGNATOR" #+x86 "*PSEUDO-ATOMIC-ATOMIC*" #+x86 "*PSEUDO-ATOMIC-INTERRUPTED*" diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index 410759c..a0839b3 100644 --- a/src/code/defstruct.lisp +++ b/src/code/defstruct.lisp @@ -1211,7 +1211,7 @@ ;;; the appropriate args to make a constructor. (defun create-boa-constructor (defstruct boa creator) (multiple-value-bind (req opt restp rest keyp keys allowp aux) - (sb!kernel:parse-lambda-list (second boa)) + (parse-lambda-list (second boa)) (collect ((arglist) (vars) (types)) diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index 8a4e03b..e60d1bc 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -251,7 +251,7 @@ (declaim (ftype (function (list args-type) (values)) parse-args-types)) (defun parse-args-types (lambda-list result) (multiple-value-bind (required optional restp rest keyp keys allowp aux) - (parse-lambda-list lambda-list) + (parse-lambda-list-like-thing lambda-list) (when aux (error "&AUX in a FUNCTION or VALUES type: ~S." lambda-list)) (setf (args-type-required result) (mapcar #'specifier-type required)) diff --git a/src/code/numbers.lisp b/src/code/numbers.lisp index 7546444..8e668dc 100644 --- a/src/code/numbers.lisp +++ b/src/code/numbers.lisp @@ -765,6 +765,7 @@ (result number)) ((null nlist) (return result)) (declare (list nlist)) + (declare (type real number result)) (if (> (car nlist) result) (setq result (car nlist))))) (defun min (number &rest more-numbers) @@ -774,6 +775,7 @@ (result number)) ((null nlist) (return result)) (declare (list nlist)) + (declare (type real number result)) (if (< (car nlist) result) (setq result (car nlist))))) (eval-when (:compile-toplevel :execute) diff --git a/src/compiler/parse-lambda-list.lisp b/src/compiler/parse-lambda-list.lisp index 85325e3..998d2cb 100644 --- a/src/compiler/parse-lambda-list.lisp +++ b/src/compiler/parse-lambda-list.lisp @@ -11,8 +11,10 @@ (/show0 "parse-lambda-list.lisp 12") -;;; Break a lambda list into its component parts. We return eleven -;;; values: +;;; Break something like a lambda list (but not necessarily actually a +;;; lambda list, e.g. the representation of argument types which is +;;; used within an FTYPE specification) into its component parts. We +;;; return eleven values: ;;; 1. a list of the required args; ;;; 2. a list of the &OPTIONAL arg specs; ;;; 3. true if a &REST arg was specified; @@ -32,92 +34,143 @@ (declaim (ftype (function (list) (values list list boolean t boolean list boolean list boolean t t)) + parse-lambda-list-like-thing parse-lambda-list)) -(defun parse-lambda-list (list) +(defun parse-lambda-list-like-thing (list) (collect ((required) - (optional) - (keys) - (aux)) + (optional) + (keys) + (aux)) (let ((restp nil) - (rest nil) - (morep nil) - (more-context nil) - (more-count nil) - (keyp nil) - (allowp nil) - (state :required)) + (rest nil) + (morep nil) + (more-context nil) + (more-count nil) + (keyp nil) + (allowp nil) + (state :required)) (declare (type (member :allow-other-keys :aux - :key - :more-context :more-count - :optional - :post-more :post-rest - :required :rest) - state)) + :key + :more-context :more-count + :optional + :post-more :post-rest + :required :rest) + state)) (dolist (arg list) - (if (and (symbolp arg) - (let ((name (symbol-name arg))) - (and (plusp (length name)) - (char= (char name 0) #\&)))) - (case arg - (&optional - (unless (eq state :required) - (compiler-error "misplaced &OPTIONAL in lambda list: ~S" - list)) - (setq state :optional)) - (&rest - (unless (member state '(:required :optional)) - (compiler-error "misplaced &REST in lambda list: ~S" list)) - (setq state :rest)) - (&more - (unless (member state '(:required :optional)) - (compiler-error "misplaced &MORE in lambda list: ~S" list)) - (setq morep t - state :more-context)) - (&key - (unless (member state - '(:required :optional :post-rest :post-more)) - (compiler-error "misplaced &KEY in lambda list: ~S" list)) - (setq keyp t - state :key)) - (&allow-other-keys - (unless (eq state ':key) - (compiler-error "misplaced &ALLOW-OTHER-KEYS in ~ + (if (and (symbolp arg) + (let ((name (symbol-name arg))) + (and (plusp (length name)) + (char= (char name 0) #\&)))) + (case arg + (&optional + (unless (eq state :required) + (compiler-error "misplaced &OPTIONAL in lambda list: ~S" + list)) + (setq state :optional)) + (&rest + (unless (member state '(:required :optional)) + (compiler-error "misplaced &REST in lambda list: ~S" list)) + (setq state :rest)) + (&more + (unless (member state '(:required :optional)) + (compiler-error "misplaced &MORE in lambda list: ~S" list)) + (setq morep t + state :more-context)) + (&key + (unless (member state + '(:required :optional :post-rest :post-more)) + (compiler-error "misplaced &KEY in lambda list: ~S" list)) + (setq keyp t + state :key)) + (&allow-other-keys + (unless (eq state ':key) + (compiler-error "misplaced &ALLOW-OTHER-KEYS in ~ lambda list: ~S" - list)) - (setq allowp t - state :allow-other-keys)) - (&aux - (when (member state '(:rest :more-context :more-count)) - (compiler-error "misplaced &AUX in lambda list: ~S" list)) - (setq state :aux)) - ;; FIXME: I don't think ANSI says this is an error. (It - ;; should certainly be good for a STYLE-WARNING, - ;; though.) - (t - (compiler-error "unknown &KEYWORD in lambda list: ~S" arg))) - (case state - (:required (required arg)) - (:optional (optional arg)) - (:rest - (setq restp t - rest arg - state :post-rest)) - (:more-context - (setq more-context arg - state :more-count)) - (:more-count - (setq more-count arg - state :post-more)) - (:key (keys arg)) - (:aux (aux arg)) - (t - (compiler-error "found garbage in lambda list when expecting ~ - a keyword: ~S" - arg))))) + list)) + (setq allowp t + state :allow-other-keys)) + (&aux + (when (member state '(:rest :more-context :more-count)) + (compiler-error "misplaced &AUX in lambda list: ~S" list)) + (setq state :aux)) + ;; FIXME: I don't think ANSI says this is an error. (It + ;; should certainly be good for a STYLE-WARNING, + ;; though.) + (t + (compiler-error "unknown &KEYWORD in lambda list: ~S" arg))) + (case state + (:required (required arg)) + (:optional (optional arg)) + (:rest + (setq restp t + rest arg + state :post-rest)) + (:more-context + (setq more-context arg + state :more-count)) + (:more-count + (setq more-count arg + state :post-more)) + (:key (keys arg)) + (:aux (aux arg)) + (t + (compiler-error "found garbage in lambda list when expecting ~ + a keyword: ~S" + arg))))) (when (eq state :rest) - (compiler-error "&REST without rest variable")) + (compiler-error "&REST without rest variable")) (values (required) (optional) restp rest keyp (keys) allowp (aux) - morep more-context more-count)))) + morep more-context more-count)))) + +;;; like PARSE-LAMBDA-LIST-LIKE-THING, except our LAMBDA-LIST argument +;;; really *is* a lambda list, not just a "lambda-list-like thing", so +;;; can barf on things which're illegal as arguments in lambda lists +;;; even if they could conceivably be legal in not-quite-a-lambda-list +;;; weirdosities +(defun parse-lambda-list (lambda-list) + + ;; Classify parameters without checking their validity individually. + (multiple-value-bind (required optional restp rest keyp keys allowp aux + morep more-context more-count) + (parse-lambda-list-like-thing lambda-list) + + ;; Check validity of parameters. + (flet ((need-symbol (x why) + (unless (symbolp x) + (compiler-error "~A is not a symbol: ~S" why x)))) + (dolist (i required) + (need-symbol i "Required argument")) + (dolist (i optional) + (typecase i + (symbol) + (cons + (destructuring-bind (var &optional init-form supplied-p) i + (declare (ignore init-form supplied-p)) + (need-symbol var "&OPTIONAL parameter name"))) + (t + (compiler-error "&OPTIONAL parameter is not a symbol or cons: ~S" + i)))) + (when restp + (need-symbol rest "&REST argument")) + (when keyp + (dolist (i keys) + (typecase i + (symbol) + (cons + (destructuring-bind (var-or-kv &optional init-form supplied-p) i + (declare (ignore init-form supplied-p)) + (if (consp var-or-kv) + (destructuring-bind (keyword-name var) var-or-kv + (declare (ignore keyword-name)) + (need-symbol var "&KEY parameter name")) + (need-symbol var-or-kv "&KEY parameter name")))) + (t + (compiler-error "&KEY parameter is not a symbol or cons: ~S" + i)))))) + + ;; Voila. + (values required optional restp rest keyp keys allowp aux + morep more-context more-count))) (/show0 "parse-lambda-list.lisp end of file") diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index 54da0ee..4e6df73 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -3086,18 +3086,20 @@ ;;; Expand MAX and MIN into the obvious comparisons. (define-source-transform max (arg &rest more-args) (if (null more-args) - `(values ,arg) + `(the real ,arg) ; ANSI: should signal TYPE-ERROR if any arg not a REAL (once-only ((arg1 arg) (arg2 `(max ,@more-args))) `(if (> ,arg1 ,arg2) - ,arg1 ,arg2)))) + ,arg1 + ,arg2)))) (define-source-transform min (arg &rest more-args) (if (null more-args) - `(values ,arg) + `(the real ,arg) ; ANSI: should signal TYPE-ERROR if any arg not a REAL (once-only ((arg1 arg) (arg2 `(min ,@more-args))) `(if (< ,arg1 ,arg2) - ,arg1 ,arg2)))) + ,arg1 + ,arg2)))) ;;;; converting N-arg arithmetic functions ;;;; diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index 3a61e87..f4dc2ce 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -234,27 +234,43 @@ bootstrapping. initargs)) ;;; As per section 3.4.2 of the ANSI spec, generic function lambda -;;; lists have a number of limitations, which we check here. +;;; lists have some special limitations, which we check here. (defun check-gf-lambda-list (lambda-list) - (macrolet ((ensure (condition) - `(unless ,condition - (error "Invalid argument ~S in the generic function lambda list ~S." - it lambda-list)))) - (process-lambda-list lambda-list - (&required (ensure (symbolp it))) - (&optional (ensure (or (symbolp it) - (and (consp it) (symbolp (car it)) (null (cdr it)))))) - (&rest (ensure (symbolp it))) - (&key (ensure (or (symbolp it) - (and (consp it) - (or (symbolp (car it)) - (and (consp (car it)) - (symbolp (caar it)) - (symbolp (cadar it)) - (null (cddar it)))) - (null (cdr it)))))) - ((&aux (error "&AUX is not allowed in the generic function lambda list ~S." - lambda-list)))))) + (flet ((ensure (arg ok) + (unless ok + (error + "invalid argument ~S in the generic function lambda list ~S" + arg lambda-list)))) + (multiple-value-bind (required optional restp rest keyp keys allowp aux + morep more-context more-count) + (parse-lambda-list lambda-list) + (declare (ignore required)) ; since they're no different in a gf ll + (declare (ignore restp rest)) ; since they're no different in a gf ll + (declare (ignore allowp)) ; since &ALLOW-OTHER-KEYS is fine either way + (declare (ignore more-context more-count)) ; safely ignored unless MOREP + ;; no defaults allowed for &OPTIONAL arguments + (dolist (i optional) + (ensure i (or (symbolp i) + (and (consp i) (symbolp (car i)) (null (cdr i)))))) + ;; no defaults allowed for &KEY arguments + (when keyp + (dolist (i keys) + (ensure i (or (symbolp i) + (and (consp i) + (or (symbolp (car i)) + (and (consp (car i)) + (symbolp (caar i)) + (symbolp (cadar i)) + (null (cddar i)))) + (null (cdr i))))))) + ;; no &AUX allowed + (when aux + (error "&AUX is not allowed in a generic function lambda list: ~S" + lambda-list)) + ;; Oh, *puhlease*... not specifically as per section 3.4.2 of + ;; the ANSI spec, but the CMU CL &MORE extension does not + ;; belong here! + (aver (not morep))))) (defmacro defmethod (&rest args &environment env) (multiple-value-bind (name qualifiers lambda-list body) diff --git a/src/pcl/macros.lisp b/src/pcl/macros.lisp index b0c5f53..baec938 100644 --- a/src/pcl/macros.lisp +++ b/src/pcl/macros.lisp @@ -216,66 +216,4 @@ (defsetf slot-value set-slot-value) -(defun misplaced-lambda-list-keyword (lambda-list keyword) - (error "Lambda list keyword ~S is misplaced in ~S." keyword lambda-list)) - -(defmacro process-lambda-list (lambda-list &rest clauses) - ;; (process-lambda-list '(a b &optional (c 1)) - ;; (&required) - ;; ((&optional (print "Started processing optional arguments")) - ;; (format "Optional argument: ~S~%" it)) - ;; (&rest (print "Rest"))) - (let ((clauses (loop for clause in clauses - collect - (cond ((symbolp (car clause)) - `(,(car clause) nil . ,(cdr clause))) - ((consp (car clause)) - `(,(caar clause) ,(cdar clause) . ,(cdr clause))) - (t (error "Invalid clause format: ~S." clause))))) - (ll (gensym "LL")) - (state (gensym "STATE")) - (restp (gensym "RESTP")) - (check-state (gensym "CHECK-STATE"))) - `(let ((,ll ,lambda-list) - (,state '&required) - (,restp nil)) - (dolist (it ,ll) - (flet ((,check-state (possible) - (unless (memq ,state possible) - (misplaced-lambda-list-keyword ,ll it)))) - (cond ((memq it lambda-list-keywords) - (case it - (&optional (,check-state '(&required)) - ,@(cadr (assoc '&optional clauses))) - (&rest (,check-state '(&required &optional)) - ,@(cadr (assoc '&rest clauses))) - (&key (,check-state '(&required &optional &rest)) - (when (and (eq ,state '&rest) - (not ,restp)) - (error "Omitted &REST variable in ~S." ,ll)) - ,@(cadr (assoc '&key clauses))) - (&allow-other-keys (,check-state '(&key)) - ,@(cadr (assoc '&allow-other-keys clauses))) - (&aux (when (and (eq ,state '&rest) - (not ,restp)) - (error "Omitted &REST variable in ~S." ,ll)) - ,@(cadr (assoc '&aux clauses))) - (t (error "Unsupported lambda list keyword ~S in ~S." - it ,ll))) - (setq ,state it)) - (t (case ,state - (&required ,@(cddr (assoc '&required clauses))) - (&optional ,@(cddr (assoc '&optional clauses))) - (&rest (when ,restp - (error "Too many variables after &REST in ~S." ,ll)) - (setq ,restp t) - ,@(cddr (assoc '&rest clauses))) - (&key ,@(cddr (assoc '&key clauses))) - (&allow-other-keys (error "Variable ~S after &ALLOW-OTHER-KEY in ~S." - it ,ll)) - (&aux ,@(cddr (assoc '&aux clauses)))))))) - (when (and (eq ,state '&rest) - (not ,restp)) - (error "Omitted &REST variable in ~S." ,ll))))) - (/show "finished with pcl/macros.lisp") diff --git a/tests/arith.pure.lisp b/tests/arith.pure.lisp index a91151e..b46a12c 100644 --- a/tests/arith.pure.lisp +++ b/tests/arith.pure.lisp @@ -47,3 +47,12 @@ (assert (= (coerce 1 '(complex float)) #c(1.0 0.0))) (assert (= (coerce 1/2 '(complex float)) #c(0.5 0.0))) (assert (= (coerce 1.0d0 '(complex float)) #c(1.0d0 0.0d0))) + +;;; ANSI: MIN and MAX should signal TYPE-ERROR if any argument +;;; isn't REAL. SBCL 0.7.7 didn't. (reported as a bug in CMU CL +;;; on IRC by lrasinen 2002-09-01) +;;; +;;; FIXME: Alas, even with the new fixed definition of MIN, no error +;;; is thrown, because of bug 194, so until bug 194 is fixed, we can't +;;; use this test. +#+nil (assert (null (ignore-errors (min '(1 2 3))))) \ No newline at end of file diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index 53b9c67..437eef8 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -147,3 +147,18 @@ (ignore-errors (some-undefined-function)) (assert (null value)) (assert (eq (cell-error-name error) 'some-undefined-function))) + +;;; Non-symbols shouldn't be allowed as VARs in lambda lists. (Where VAR +;;; is a variable name, as in section 3.4.1 of the ANSI spec.) +(assert (null (ignore-errors (eval '(lambda ("foo") 12))))) +(assert (ignore-errors (eval '(lambda (foo) 12)))) +(assert (null (ignore-errors (eval '(lambda (&optional 12) "foo"))))) +(assert (ignore-errors (eval '(lambda (&optional twelve) "foo")))) +(assert (null (ignore-errors (eval '(lambda (&optional (12 12)) "foo"))))) +(assert (ignore-errors (eval '(lambda (&optional (twelve 12)) "foo")))) +(assert (null (ignore-errors (eval '(lambda (&key #\c) "foo"))))) +(assert (ignore-errors (eval '(lambda (&key c) "foo")))) +(assert (null (ignore-errors (eval '(lambda (&key (#\c #\c)) "foo"))))) +(assert (ignore-errors (eval '(lambda (&key (c #\c)) "foo")))) +(assert (null (ignore-errors (eval '(lambda (&key ((#\c #\c) #\c)) "foo"))))) +(assert (ignore-errors (eval '(lambda (&key ((:c cbyanyothername) #\c)) "foo")))) diff --git a/version.lisp-expr b/version.lisp-expr index 5f9fce7..90bbbd6 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; for internal versions, especially for internal versions off the ;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.7.7.9" +"0.7.7.10" -- 1.7.10.4