(setf (info :function :where-from name) :assumed))
(let ((where (info :function :where-from name)))
- (when (eq where :assumed)
+ (when (and (eq where :assumed)
+ ;; In the ordinary target Lisp, it's silly to report
+ ;; undefinedness when the function is defined in the
+ ;; running Lisp. But at cross-compile time, the current
+ ;; definedness of a function is irrelevant to the
+ ;; definedness at runtime, which is what matters.
+ #-sb-xc-host (not (fboundp name)))
(note-undefined-reference name :function))
(make-global-var :kind :global-function
:name name
(slot (find accessor (dd-slots info) :key #'sb!kernel:dsd-accessor))
(type (dd-name info))
(slot-type (dsd-type slot)))
- (assert slot () "Can't find slot ~S." type)
+ (unless slot
+ (error "can't find slot ~S" type))
(make-slot-accessor
:name name
:type (specifier-type
(let ((var (lexenv-find name functions :test #'equal)))
(cond (var
(unless (leaf-p var)
- (assert (and (consp var) (eq (car var) 'macro)))
+ (aver (and (consp var) (eq (car var) 'macro)))
(compiler-error "found macro name ~S ~A" name context))
var)
(t
;;; processed with MAKE-LOAD-FORM. We have to be careful, because
;;; CONSTANT might be circular. We also check that the constant (and
;;; any subparts) are dumpable at all.
-(defconstant list-to-hash-table-threshold 32)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ ;; The EVAL-WHEN is necessary for #.(1+ LIST-TO-HASH-TABLE-THRESHOLD)
+ ;; below. -- AL 20010227
+ (defconstant list-to-hash-table-threshold 32))
(defun maybe-emit-make-load-forms (constant)
(let ((things-processed nil)
(count 0))
#!-sb-fluid (declaim (inline prev-link))
(defun prev-link (node cont)
(declare (type node node) (type continuation cont))
- (assert (not (continuation-next cont)))
+ (aver (not (continuation-next cont)))
(setf (continuation-next cont) node)
(setf (node-prev node) cont))
(declare (type node node) (type continuation cont) (inline member))
(let ((block (continuation-block cont))
(node-block (continuation-block (node-prev node))))
- (assert (eq (continuation-kind cont) :block-start))
- (assert (not (block-last node-block)) () "~S has already ended."
- node-block)
+ (aver (eq (continuation-kind cont) :block-start))
+ (when (block-last node-block)
+ (error "~S has already ended." node-block))
(setf (block-last node-block) node)
- (assert (null (block-succ node-block)) () "~S already has successors."
- node-block)
+ (when (block-succ node-block)
+ (error "~S already has successors." node-block))
(setf (block-succ node-block) (list block))
- (assert (not (member node-block (block-pred block) :test #'eq)) ()
- "~S is already a predecessor of ~S." node-block block)
+ (when (memq node-block (block-pred block))
+ (error "~S is already a predecessor of ~S." node-block block))
(push node-block (block-pred block))
(add-continuation-use node cont)
(unless (eq (continuation-asserted-type cont) *wild-type*)
(global-var
(ir1-convert-srctran start cont lexical-def form))
(t
- (assert (and (consp lexical-def)
- (eq (car lexical-def) 'macro)))
+ (aver (and (consp lexical-def)
+ (eq (car lexical-def) 'macro)))
(ir1-convert start cont
(careful-expand-macro (cdr lexical-def)
form))))))
(compiler-style-warning "reading an ignored variable: ~S" name))
(reference-leaf start cont var))
(cons
- (assert (eq (car var) 'MACRO))
+ (aver (eq (car var) 'MACRO))
(ir1-convert start cont (cdr var)))
(heap-alien-info
(ir1-convert start cont `(%heap-alien ',var)))))
(int (if (or (function-type-p type)
(function-type-p old-type))
type
- (type-intersection old-type type))))
+ (type-approx-intersection2 old-type type))))
(cond ((eq int *empty-type*)
(unless (policy nil (= inhibit-warnings 3))
(compiler-warning
(restr (cons var int))))))
(cons
;; FIXME: non-ANSI weirdness
- (assert (eq (car var) 'MACRO))
+ (aver (eq (car var) 'MACRO))
(new-vars `(,var-name . (MACRO . (the ,(first decl)
,(cdr var))))))
(heap-alien-info
(let ((var (find-in-bindings vars name)))
(etypecase var
(cons
- (assert (eq (car var) 'MACRO))
+ (aver (eq (car var) 'MACRO))
(compiler-error
"~S is a symbol-macro and thus can't be declared special."
name))
;;; RES and returning it as a result. VARS and FVARS are as described in
;;; PROCESS-DECLS.
(defun process-1-decl (raw-spec res vars fvars cont)
- (declare (list spec vars fvars) (type lexenv res) (type continuation cont))
+ (declare (type list raw-spec vars fvars))
+ (declare (type lexenv res))
+ (declare (type continuation cont))
(let ((spec (canonized-decl-spec raw-spec)))
(case (first spec)
(special (process-special-decl spec res vars))
(note-lexical-binding name)
(make-lambda-var :name name)))))
-;;; Make the keyword for a keyword arg, checking that the keyword
-;;; isn't already used by one of the Vars. We also check that the
-;;; keyword isn't the magical :allow-other-keys.
+;;; Make the default keyword for a &KEY arg, checking that the keyword
+;;; isn't already used by one of the VARS. We also check that the
+;;; keyword isn't the magical :ALLOW-OTHER-KEYS.
(declaim (ftype (function (symbol list t) keyword) make-keyword-for-arg))
(defun make-keyword-for-arg (symbol vars keywordify)
(let ((key (if (and keywordify (not (keywordp symbol)))
- (intern (symbol-name symbol) "KEYWORD")
+ (keywordicate symbol)
symbol)))
(when (eq key :allow-other-keys)
- (compiler-error "No keyword arg can be called :ALLOW-OTHER-KEYS."))
+ (compiler-error "No &KEY arg can be called :ALLOW-OTHER-KEYS."))
(dolist (var vars)
(let ((info (lambda-var-arg-info var)))
(when (and info
(eq (arg-info-kind info) :keyword)
- (eq (arg-info-keyword info) key))
+ (eq (arg-info-key info) key))
(compiler-error
"The keyword ~S appears more than once in the lambda-list."
key))))
key))
-;;; Parse a lambda-list into a list of Var structures, stripping off
+;;; Parse a lambda-list into a list of VAR structures, stripping off
;;; any aux bindings. Each arg name is checked for legality, and
;;; duplicate names are checked for. If an arg is globally special,
-;;; the var is marked as :special instead of :lexical. Keyword,
-;;; optional and rest args are annotated with an arg-info structure
+;;; the var is marked as :SPECIAL instead of :LEXICAL. &KEY,
+;;; &OPTIONAL and &REST args are annotated with an ARG-INFO structure
;;; which contains the extra information. If we hit something losing,
-;;; we bug out with Compiler-Error. These values are returned:
-;;; 1. A list of the var structures for each top-level argument.
-;;; 2. A flag indicating whether &key was specified.
-;;; 3. A flag indicating whether other keyword args are allowed.
-;;; 4. A list of the &aux variables.
-;;; 5. A list of the &aux values.
+;;; we bug out with COMPILER-ERROR. These values are returned:
+;;; 1. a list of the var structures for each top-level argument;
+;;; 2. a flag indicating whether &KEY was specified;
+;;; 3. a flag indicating whether other &KEY args are allowed;
+;;; 4. a list of the &AUX variables; and
+;;; 5. a list of the &AUX values.
(declaim (ftype (function (list) (values list boolean boolean list list))
find-lambda-vars))
(defun find-lambda-vars (list)
(names-so-far)
(aux-vars)
(aux-vals))
- ;; Parse-Default deals with defaults and supplied-p args for optionals
- ;; and keywords args.
- (flet ((parse-default (spec info)
+ (flet (;; PARSE-DEFAULT deals with defaults and supplied-p args
+ ;; for optionals and keywords args.
+ (parse-default (spec info)
(when (consp (cdr spec))
(setf (arg-info-default info) (second spec))
(when (consp (cddr spec))
(let ((var (varify-lambda-arg spec (names-so-far))))
(setf (lambda-var-arg-info var)
(make-arg-info :kind :keyword
- :keyword (make-keyword-for-arg spec
- (vars)
- t)))
+ :key (make-keyword-for-arg spec
+ (vars)
+ t)))
(vars var)
(names-so-far spec)))
((atom (first spec))
(var (varify-lambda-arg name (names-so-far)))
(info (make-arg-info
:kind :keyword
- :keyword (make-keyword-for-arg name (vars) t))))
+ :key (make-keyword-for-arg name (vars) t))))
(setf (lambda-var-arg-info var) info)
(vars var)
(names-so-far name)
(t
(let ((head (first spec)))
(unless (proper-list-of-length-p head 2)
- (error "malformed keyword arg specifier: ~S" spec))
+ (error "malformed &KEY argument specifier: ~S" spec))
(let* ((name (second head))
(var (varify-lambda-arg name (names-so-far)))
(info (make-arg-info
:kind :keyword
- :keyword (make-keyword-for-arg (first head)
- (vars)
- nil))))
+ :key (make-keyword-for-arg (first head)
+ (vars)
+ nil))))
(setf (lambda-var-arg-info var) info)
(vars var)
(names-so-far name)
(list (arg-info-default info) nil)
(list (arg-info-default info))))))
-;;; Create the More-Entry function for the Optional-Dispatch Res.
-;;; Entry-Vars and Entry-Vals describe the fixed arguments. Rest is the var
-;;; for any Rest arg. Keys is a list of the keyword arg vars.
+;;; Create the MORE-ENTRY function for the OPTIONAL-DISPATCH RES.
+;;; ENTRY-VARS and ENTRY-VALS describe the fixed arguments. REST is
+;;; the var for any &REST arg. KEYS is a list of the &KEY arg vars.
;;;
-;;; The most interesting thing that we do is parse keywords. We create a
-;;; bunch of temporary variables to hold the result of the parse, and then loop
-;;; over the supplied arguments, setting the appropriate temps for the supplied
-;;; keyword. Note that it is significant that we iterate over the keywords in
-;;; reverse order --- this implements the CL requirement that (when a keyword
-;;; appears more than once) the first value is used.
+;;; The most interesting thing that we do is parse keywords. We create
+;;; a bunch of temporary variables to hold the result of the parse,
+;;; and then loop over the supplied arguments, setting the appropriate
+;;; temps for the supplied keyword. Note that it is significant that
+;;; we iterate over the keywords in reverse order --- this implements
+;;; the CL requirement that (when a keyword appears more than once)
+;;; the first value is used.
;;;
;;; If there is no supplied-p var, then we initialize the temp to the
-;;; default and just pass the temp into the main entry. Since non-constant
-;;; keyword args are forcibly given a supplied-p var, we know that the default
-;;; is constant, and thus safe to evaluate out of order.
+;;; default and just pass the temp into the main entry. Since
+;;; non-constant &KEY args are forcibly given a supplied-p var, we
+;;; know that the default is constant, and thus safe to evaluate out
+;;; of order.
;;;
-;;; If there is a supplied-p var, then we create temps for both the value
-;;; and the supplied-p, and pass them into the main entry, letting it worry
-;;; about defaulting.
+;;; If there is a supplied-p var, then we create temps for both the
+;;; value and the supplied-p, and pass them into the main entry,
+;;; letting it worry about defaulting.
;;;
-;;; We deal with :allow-other-keys by delaying unknown keyword errors until
-;;; we have scanned all the keywords.
+;;; We deal with :ALLOW-OTHER-KEYS by delaying unknown keyword errors
+;;; until we have scanned all the keywords.
;;;
;;; When converting the function, we bind *LEXENV* to change the
;;; compilation policy over to the interface policy, so that keyword
(dolist (key keys)
(let* ((info (lambda-var-arg-info key))
(default (arg-info-default info))
- (keyword (arg-info-keyword info))
+ (keyword (arg-info-key info))
(supplied-p (arg-info-supplied-p info))
(n-value (gensym "N-VALUE-")))
(temps `(,n-value ,default))
(body
`(when (oddp ,n-count)
- (%odd-keyword-arguments-error)))
+ (%odd-key-arguments-error)))
(body
`(locally
(unless allowp
(body `(when (and ,n-losep (not ,n-allowp))
- (%unknown-keyword-argument-error ,n-losep)))))))
+ (%unknown-key-argument-error ,n-losep)))))))
(let ((ep (ir1-convert-lambda-body
`((let ,(temps)
(values))
-;;; Called by IR1-Convert-Hairy-Args when we run into a rest or
-;;; keyword arg. The arguments are similar to that function, but we
-;;; split off any rest arg and pass it in separately. Rest is the rest
-;;; arg var, or NIL if there is no rest arg. Keys is a list of the
-;;; keyword argument vars.
+;;; This is called by IR1-Convert-Hairy-Args when we run into a &REST
+;;; or &KEY arg. The arguments are similar to that function, but we
+;;; split off any &REST arg and pass it in separately. REST is the
+;;; &REST arg var, or NIL if there is no &REST arg. KEYS is a list of
+;;; the &KEY argument vars.
;;;
-;;; When there are keyword arguments, we introduce temporary gensym
+;;; When there are &KEY arguments, we introduce temporary gensym
;;; variables to hold the values while keyword defaulting is in
;;; progress to get the required sequential binding semantics.
;;;
-;;; This gets interesting mainly when there are keyword arguments with
+;;; This gets interesting mainly when there are &KEY arguments with
;;; supplied-p vars or non-constant defaults. In either case, pass in
;;; a supplied-p var. If the default is non-constant, we introduce an
;;; IF in the main entry that tests the supplied-p var and decides
;;; the entry point function will be the same, but when supplied-p args are
;;; present they may be different.
;;;
-;;; When we run into a rest or keyword arg, we punt out to
-;;; IR1-Convert-More, which finishes for us in this case.
+;;; When we run into a &REST or &KEY arg, we punt out to
+;;; IR1-CONVERT-MORE, which finishes for us in this case.
(defun ir1-convert-hairy-args (res default-vars default-vals
entry-vars entry-vals
vars supplied-p-p body aux-vars
(prev-link exit value-cont)
(use-continuation exit (second found))))
-;;; Return a list of the segments of a tagbody. Each segment looks
+;;; Return a list of the segments of a TAGBODY. Each segment looks
;;; like (<tag> <form>* (go <next tag>)). That is, we break up the
;;; tagbody into segments of non-tag statements, and explicitly
;;; represent the drop-through with a GO. The first segment has a
(collect ((segments))
(let ((current (cons nil body)))
(loop
- (let ((tag-pos (position-if-not #'listp current :start 1)))
+ (let ((tag-pos (position-if (complement #'listp) current :start 1)))
(unless tag-pos
(segments `(,@current nil))
(return))
name))
(set-variable start cont leaf (second things)))
(cons
- (assert (eq (car leaf) 'MACRO))
+ (aver (eq (car leaf) 'MACRO))
(ir1-convert start cont `(setf ,(cdr leaf) ,(second things))))
(heap-alien-info
(ir1-convert start cont
;;; referencing it.
(def-ir1-translator %cleanup-function ((name) start cont)
(let ((fun (lexenv-find name functions)))
- (assert (lambda-p fun))
+ (aver (lambda-p fun))
(setf (functional-kind fun) :cleanup)
(reference-leaf start cont fun)))
(dolist (pred (block-pred end-block))
(unlink-blocks pred end-block)
(link-blocks pred cont-block))
- (assert (not (continuation-dest dummy-result)))
+ (aver (not (continuation-dest dummy-result)))
(delete-continuation dummy-result)
(remove-from-dfo end-block))))
\f
;; QDEF should be a sharp-quoted definition. We don't want to make a
;; function of it just yet, so we just drop the sharp-quote.
(def (progn
- (assert (eq 'function (first qdef)))
- (assert (proper-list-of-length-p qdef 2))
+ (aver (eq 'function (first qdef)))
+ (aver (proper-list-of-length-p qdef 2))
(second qdef))))
(unless (symbolp name)
(when (eq x (assoc name variables :test #'eq))
(typecase what
(cons
- (assert (eq (car what) 'macro))
+ (aver (eq (car what) 'macro))
(push x symmacs))
(global-var
- (assert (eq (global-var-kind what) :special))
+ (aver (eq (global-var-kind what) :special))
(push `(special ,name) decls))
(t (return t))))))
nil)
(found (find-free-function name "Eh?")))
(note-name-defined name :function)
(cond ((not (defined-function-p found))
- (assert (not (info :function :inlinep name)))
+ (aver (not (info :function :inlinep name)))
(let* ((where-from (leaf-where-from found))
(res (make-defined-function
:name name
;;; Check a new global function definition for consistency with
;;; previous declaration or definition, and assert argument/result
-;;; types if appropriate. This this assertion is suppressed by the
+;;; types if appropriate. This assertion is suppressed by the
;;; EXPLICIT-CHECK attribute, which is specified on functions that
;;; check their argument types as a consequence of type dispatching.
;;; This avoids redundant checks such as NUMBERP on the args to +,
(info (info :function :info (leaf-name var))))
(assert-definition-type
fun type
- :error-function #'compiler-warning
- :warning-function (cond (info #'compiler-warning)
+ ;; KLUDGE: Common Lisp is such a dynamic language that in general
+ ;; all we can do here in general is issue a STYLE-WARNING. It
+ ;; would be nice to issue a full WARNING in the special case of
+ ;; of type mismatches within a compilation unit (as in section
+ ;; 3.2.2.3 of the spec) but at least as of sbcl-0.6.11, we don't
+ ;; keep track of whether the mismatched data came from the same
+ ;; compilation unit, so we can't do that. -- WHN 2001-02-11
+ ;;
+ ;; FIXME: Actually, I think we could issue a full WARNING if the
+ ;; new definition contradicts a DECLAIM FTYPE.
+ :error-function #'compiler-style-warning
+ :warning-function (cond (info #'compiler-style-warning)
(for-real #'compiler-note)
(t nil))
:really-assert
projects / sbcl.git / blobdiff