(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
#!-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)))))
type
(type-approx-intersection2 old-type type))))
(cond ((eq int *empty-type*)
- (unless (policy nil (= inhibit-warnings 3))
+ (unless (policy *lexenv* (= inhibit-warnings 3))
(compiler-warning
"The type declarations ~S and ~S for ~S conflict."
(type-specifier old-type) (type-specifier type)
(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))
name "in an inline or notinline declaration")))
(etypecase found
(functional
- (when (policy nil (>= speed inhibit-warnings))
+ (when (policy *lexenv* (>= speed inhibit-warnings))
(compiler-note "ignoring ~A declaration not at ~
definition of local function:~% ~S"
sense name)))
(make-lexenv
:default res
:policy (process-optimize-decl spec (lexenv-policy res))))
- (optimize-interface
- (make-lexenv
- :default res
- :interface-policy (process-optimize-decl
- spec
- (lexenv-interface-policy res))))
(type
(process-type-decl (cdr spec) res vars))
(values
`(values ,@types))
cont res 'values))))
(dynamic-extent
- (when (policy nil (> speed inhibit-warnings))
+ (when (policy *lexenv* (> speed inhibit-warnings))
(compiler-note
"compiler limitation:~
~% There's no special support for DYNAMIC-EXTENT (so it's ignored)."))
(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 &KEY arg can be called :ALLOW-OTHER-KEYS."))
;;; sequentially bind each AUX-VAR to the corresponding AUX-VAL before
;;; converting the body. If there are no bindings, just convert the
;;; body, otherwise do one binding and recurse on the rest.
-;;;
-;;; If INTERFACE is true, then we convert bindings with the interface
-;;; policy. For real &AUX bindings, and for implicit aux bindings
-;;; introduced by keyword bindings, this is always true. It is only
-;;; false when LET* directly calls this function.
-(defun ir1-convert-aux-bindings (start cont body aux-vars aux-vals interface)
+(defun ir1-convert-aux-bindings (start cont body aux-vars aux-vals)
(declare (type continuation start cont) (list body aux-vars aux-vals))
(if (null aux-vars)
(ir1-convert-progn-body start cont body)
(let ((fun-cont (make-continuation))
- (fun (ir1-convert-lambda-body body (list (first aux-vars))
- (rest aux-vars) (rest aux-vals)
- interface)))
+ (fun (ir1-convert-lambda-body body
+ (list (first aux-vars))
+ :aux-vars (rest aux-vars)
+ :aux-vals (rest aux-vals))))
(reference-leaf start fun-cont fun)
- (let ((*lexenv* (if interface
- (make-lexenv
- :policy (make-interface-policy *lexenv*))
- *lexenv*)))
- (ir1-convert-combination-args fun-cont cont
- (list (first aux-vals))))))
+ (ir1-convert-combination-args fun-cont cont
+ (list (first aux-vals)))))
(values))
;;; This is similar to IR1-CONVERT-PROGN-BODY except that code to bind
;;; will end up being the innermost one. We force CONT to start a
;;; block outside of this cleanup, causing cleanup code to be emitted
;;; when the scope is exited.
-(defun ir1-convert-special-bindings (start cont body aux-vars aux-vals
- interface svars)
+(defun ir1-convert-special-bindings (start cont body aux-vars aux-vals svars)
(declare (type continuation start cont)
(list body aux-vars aux-vals svars))
(cond
((null svars)
- (ir1-convert-aux-bindings start cont body aux-vars aux-vals interface))
+ (ir1-convert-aux-bindings start cont body aux-vars aux-vals))
(t
(continuation-starts-block cont)
(let ((cleanup (make-cleanup :kind :special-bind))
(let ((*lexenv* (make-lexenv :cleanup cleanup)))
(ir1-convert next-cont nnext-cont '(%cleanup-point))
(ir1-convert-special-bindings nnext-cont cont body aux-vars aux-vals
- interface (rest svars))))))
+ (rest svars))))))
(values))
;;; Create a lambda node out of some code, returning the result. The
;;;
;;; AUX-VARS is a list of VAR structures for variables that are to be
;;; sequentially bound. Each AUX-VAL is a form that is to be evaluated
-;;; to get the initial value for the corresponding AUX-VAR. Interface
-;;; is a flag as T when there are real aux values (see LET* and
-;;; IR1-CONVERT-AUX-BINDINGS.)
-(defun ir1-convert-lambda-body (body vars &optional aux-vars aux-vals
- interface result)
+;;; to get the initial value for the corresponding AUX-VAR.
+(defun ir1-convert-lambda-body (body vars &key aux-vars aux-vals result)
(declare (list body vars aux-vars aux-vals)
(type (or continuation null) result))
(let* ((bind (make-bind))
(prev-link bind cont1)
(use-continuation bind cont2)
(ir1-convert-special-bindings cont2 result body aux-vars aux-vals
- interface (svars)))
+ (svars)))
(let ((block (continuation-block result)))
(when block
;;; then we mark the corresponding var as EVER-USED to inhibit
;;; "defined but not read" warnings for arguments that are only used
;;; by default forms.
-;;;
-;;; We bind *LEXENV* to change the policy to the interface policy.
(defun convert-optional-entry (fun vars vals defaults)
(declare (type clambda fun) (list vars vals defaults))
(let* ((fvars (reverse vars))
:where-from (leaf-where-from var)
:specvar (lambda-var-specvar var)))
fvars))
- (*lexenv* (make-lexenv :policy (make-interface-policy *lexenv*)))
(fun
- (ir1-convert-lambda-body
- `((%funcall ,fun ,@(reverse vals) ,@defaults))
- arg-vars)))
- (mapc #'(lambda (var arg-var)
- (when (cdr (leaf-refs arg-var))
- (setf (leaf-ever-used var) t)))
+ (ir1-convert-lambda-body `((%funcall ,fun
+ ,@(reverse vals)
+ ,@defaults))
+ arg-vars)))
+ (mapc (lambda (var arg-var)
+ (when (cdr (leaf-refs arg-var))
+ (setf (leaf-ever-used var) t)))
fvars arg-vars)
fun))
;;;
;;; 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
-;;; args will be checked even when type checking isn't on in general.
(defun convert-more-entry (res entry-vars entry-vals rest morep keys)
(declare (type optional-dispatch res) (list entry-vars entry-vals keys))
(collect ((arg-vars)
(context-temp (make-lambda-var :name n-context))
(n-count (gensym "N-COUNT-"))
(count-temp (make-lambda-var :name n-count
- :type (specifier-type 'index)))
- (*lexenv* (make-lexenv :policy (make-interface-policy *lexenv*))))
+ :type (specifier-type 'index))))
(arg-vars context-temp count-temp)
(n-allowp (gensym "N-ALLOWP-"))
(n-losep (gensym "N-LOSEP-"))
(allowp (or (optional-dispatch-allowp res)
- (policy nil (zerop safety)))))
+ (policy *lexenv* (zerop safety)))))
(temps `(,n-index (1- ,n-count)) n-key n-value-temp)
(body `(declare (fixnum ,n-index) (ignorable ,n-key ,n-value-temp)))
(values))
-;;; This is called by IR1-Convert-Hairy-Args when we run into a &REST
+;;; 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
(main-vals (arg-info-default info))
(bind-vals n-val)))))
- (let* ((main-entry (ir1-convert-lambda-body body (main-vars)
- (append (bind-vars) aux-vars)
- (append (bind-vals) aux-vals)
- t
- cont))
+ (let* ((main-entry (ir1-convert-lambda-body
+ body (main-vars)
+ :aux-vars (append (bind-vars) aux-vars)
+ :aux-vals (append (bind-vals) aux-vals)
+ :result cont))
(last-entry (convert-optional-entry main-entry default-vars
(main-vals) ())))
(setf (optional-dispatch-main-entry res) main-entry)
;;; arguments, analyzing the arglist on the way down and generating entry
;;; points on the way up.
;;;
-;;; Default-Vars is a reversed list of all the argument vars processed so
-;;; far, including supplied-p vars. Default-Vals is a list of the names of the
-;;; Default-Vars.
+;;; Default-Vars is a reversed list of all the argument vars processed
+;;; so far, including supplied-p vars. Default-Vals is a list of the
+;;; names of the Default-Vars.
;;;
-;;; Entry-Vars is a reversed list of processed argument vars, excluding
-;;; supplied-p vars. Entry-Vals is a list things that can be evaluated to get
-;;; the values for all the vars from the Entry-Vars. It has the var name for
-;;; each required or optional arg, and has T for each supplied-p arg.
+;;; Entry-Vars is a reversed list of processed argument vars,
+;;; excluding supplied-p vars. Entry-Vals is a list things that can be
+;;; evaluated to get the values for all the vars from the Entry-Vars.
+;;; It has the var name for each required or optional arg, and has T
+;;; for each supplied-p arg.
;;;
-;;; Vars is a list of the Lambda-Var structures for arguments that haven't
-;;; been processed yet. Supplied-p-p is true if a supplied-p argument has
-;;; already been processed; only in this case are the Default-XXX and Entry-XXX
-;;; different.
+;;; Vars is a list of the Lambda-Var structures for arguments that
+;;; haven't been processed yet. Supplied-p-p is true if a supplied-p
+;;; argument has already been processed; only in this case are the
+;;; Default-XXX and Entry-XXX different.
;;;
-;;; The result at each point is a lambda which should be called by the above
-;;; level to default the remaining arguments and evaluate the body. We cause
-;;; the body to be evaluated by converting it and returning it as the result
-;;; when the recursion bottoms out.
+;;; The result at each point is a lambda which should be called by the
+;;; above level to default the remaining arguments and evaluate the
+;;; body. We cause the body to be evaluated by converting it and
+;;; returning it as the result when the recursion bottoms out.
;;;
-;;; Each level in the recursion also adds its entry point function to the
-;;; result Optional-Dispatch. For most arguments, the defaulting function and
-;;; the entry point function will be the same, but when supplied-p args are
-;;; present they may be different.
+;;; Each level in the recursion also adds its entry point function to
+;;; the result Optional-Dispatch. For most arguments, the defaulting
+;;; function and 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 &KEY arg, we punt out to
;;; IR1-CONVERT-MORE, which finishes for us in this case.
nil nil nil vars supplied-p-p body aux-vars
aux-vals cont)
(let ((fun (ir1-convert-lambda-body body (reverse default-vars)
- aux-vars aux-vals t cont)))
+ :aux-vars aux-vars
+ :aux-vals aux-vals
+ :result cont)))
(setf (optional-dispatch-main-entry res) fun)
(push (if supplied-p-p
(convert-optional-entry fun entry-vars entry-vals ())
aux-vals cont)))))))
;;; This function deals with the case where we have to make an
-;;; Optional-Dispatch to represent a lambda. We cons up the result and call
-;;; IR1-Convert-Hairy-Args to do the work. When it is done, we figure out the
-;;; min-args and max-args.
+;;; Optional-Dispatch to represent a lambda. We cons up the result and
+;;; call IR1-CONVERT-HAIRY-ARGS to do the work. When it is done, we
+;;; figure out the min-args and max-args.
(defun ir1-convert-hairy-lambda (body vars keyp allowp aux-vars aux-vals cont)
(declare (list body vars aux-vars aux-vals) (type continuation cont))
(let ((res (make-optional-dispatch :arglist vars
(ir1-convert-hairy-lambda forms vars keyp
allow-other-keys
aux-vars aux-vals cont)
- (ir1-convert-lambda-body forms vars aux-vars aux-vals
- t cont))))
+ (ir1-convert-lambda-body forms vars
+ :aux-vars aux-vars
+ :aux-vals aux-vals
+ :result cont))))
(setf (functional-inline-expansion res) form)
(setf (functional-arg-documentation res) (cadr form))
(setf (leaf-name res) name)
(multiple-value-bind (forms decls) (sb!sys:parse-body body nil)
(multiple-value-bind (vars values) (extract-let-variables bindings 'let*)
(let ((*lexenv* (process-decls decls vars nil cont)))
- (ir1-convert-aux-bindings start cont forms vars values nil)))))
+ (ir1-convert-aux-bindings start cont forms vars values)))))
;;; This is a lot like a LET* with no bindings. Unlike LET*, LOCALLY
;;; has to preserves top-level-formness, but we don't need to worry
the Forms are also processed as top-level forms."
(multiple-value-bind (forms decls) (sb!sys:parse-body body nil)
(let ((*lexenv* (process-decls decls nil nil cont)))
- (ir1-convert-aux-bindings start cont forms nil nil nil))))
+ (ir1-convert-aux-bindings start cont forms nil nil))))
\f
;;;; FLET and LABELS
(let* ((ctype (values-specifier-type type))
(old-type (or (lexenv-find cont type-restrictions)
*wild-type*))
- (intersects (values-types-intersect old-type ctype))
+ (intersects (values-types-equal-or-intersect old-type ctype))
(int (values-type-intersection old-type ctype))
(new (if intersects int old-type)))
(when (null (find-uses cont))
(setf (continuation-asserted-type cont) new))
(when (and (not intersects)
- (not (policy nil (= inhibit-warnings 3)))) ;FIXME: really OK to suppress?
+ (not (policy *lexenv*
+ (= inhibit-warnings 3)))) ;FIXME: really OK to suppress?
(compiler-warning
"The type ~S in ~S declaration conflicts with an enclosing assertion:~% ~S"
(type-specifier ctype)
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)
`(,(car x) .
(macro . ,(coerce (cdr x) 'function))))
macros)
- :policy (lexenv-policy *lexenv*)
- :interface-policy (lexenv-interface-policy *lexenv*))))
+ :policy (lexenv-policy *lexenv*))))
(ir1-convert-lambda `(lambda ,@body) name))))
;;; Return a lambda that has been "closed" with respect to ENV,
(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
;; 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)
projects / sbcl.git / blobdiff