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-#:
"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"
"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*"
;;; 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))
(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))
(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)
(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)
(/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;
(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")
;;; 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))))
\f
;;;; converting N-arg arithmetic functions
;;;;
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)))))
\f
(defmacro defmethod (&rest args &environment env)
(multiple-value-bind (name qualifiers lambda-list body)
(defsetf slot-value set-slot-value)
\f
-(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")
(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
(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"))))
;;; 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"
projects / sbcl.git / commitdiff