(when (source-form-has-path-p form)
(gethash form *source-paths*)))
+(defun simplify-source-path-form (form)
+ (if (consp form)
+ (let ((op (car form)))
+ ;; In the compiler functions can be directly represented
+ ;; by leaves. Having leaves in the source path is pretty
+ ;; hard on the poor user, however, so replace with the
+ ;; source-name when possible.
+ (if (and (leaf-p op) (leaf-has-source-name-p op))
+ (cons (leaf-source-name op) (cdr form))
+ form))
+ form))
+
(defun note-source-path (form &rest arguments)
(when (source-form-has-path-p form)
(setf (gethash form *source-paths*)
(eq (info :function :inlinep name) :notinline))))
;; This will get redefined in PCL boot.
-(declaim (notinline update-info-for-gf))
+(declaim (notinline maybe-update-info-for-gf))
(defun maybe-update-info-for-gf (name)
- (declare (ignorable name))
- (values))
+ (declare (ignore name))
+ nil)
+
+(defun maybe-defined-here (name where)
+ (if (and (eq :defined where)
+ (member name *fun-names-in-this-file* :test #'equal))
+ :defined-here
+ where))
;;; Return a GLOBAL-VAR structure usable for referencing the global
;;; function NAME.
;; complain about undefined functions.
(not latep))
(note-undefined-reference name :function))
- (make-global-var
- :kind :global-function
- :%source-name name
- :type (if (and (not latep)
- (or *derive-function-types*
- (member where '(:declared :defined-method))
- (and (member name *fun-names-in-this-file*
- :test #'equal)
- (not (fun-lexically-notinline-p name)))))
- (progn
- (maybe-update-info-for-gf name)
- (info :function :type name))
- (specifier-type 'function))
- :defined-type (if (eq where :defined)
- (info :function :type name)
- *universal-type*)
- :where-from where)))
-
-;;; Has the *FREE-FUNS* entry FREE-FUN become invalid?
+ (let ((ftype (info :function :type name))
+ (notinline (fun-lexically-notinline-p name)))
+ (make-global-var
+ :kind :global-function
+ :%source-name name
+ :type (if (or (eq where :declared)
+ (and (not latep)
+ (not notinline)
+ *derive-function-types*))
+ ftype
+ (specifier-type 'function))
+ :defined-type (if (and (not latep) (not notinline))
+ (or (maybe-update-info-for-gf name) ftype)
+ (specifier-type 'function))
+ :where-from (if notinline
+ where
+ (maybe-defined-here name where))))))
+
+;;; Have some DEFINED-FUN-FUNCTIONALS of a *FREE-FUNS* entry become invalid?
+;;; Drop 'em.
;;;
-;;; In CMU CL, the answer was implicitly always true, so this
-;;; predicate didn't exist.
-;;;
-;;; This predicate was added to fix bug 138 in SBCL. In some obscure
-;;; circumstances, it was possible for a *FREE-FUNS* entry to contain a
-;;; DEFINED-FUN whose DEFINED-FUN-FUNCTIONAL object contained IR1
-;;; stuff (NODEs, BLOCKs...) referring to an already compiled (aka
-;;; "dead") component. When this IR1 stuff was reused in a new
-;;; component, under further obscure circumstances it could be used by
+;;; This was added to fix bug 138 in SBCL. It is possible for a *FREE-FUNS*
+;;; entry to contain a DEFINED-FUN whose DEFINED-FUN-FUNCTIONAL object
+;;; contained IR1 stuff (NODEs, BLOCKs...) referring to an already compiled
+;;; (aka "dead") component. When this IR1 stuff was reused in a new component,
+;;; under further obscure circumstances it could be used by
;;; WITH-IR1-ENVIRONMENT-FROM-NODE to generate a binding for
-;;; *CURRENT-COMPONENT*. At that point things got all confused, since
-;;; IR1 conversion was sending code to a component which had already
-;;; been compiled and would never be compiled again.
-(defun invalid-free-fun-p (free-fun)
+;;; *CURRENT-COMPONENT*. At that point things got all confused, since IR1
+;;; conversion was sending code to a component which had already been compiled
+;;; and would never be compiled again.
+;;;
+;;; Note: as of 1.0.24.41 this seems to happen only in XC, and the original
+;;; BUGS entry also makes it seem like this might not be an issue at all on
+;;; target.
+(defun clear-invalid-functionals (free-fun)
;; There might be other reasons that *FREE-FUN* entries could
;; become invalid, but the only one we've been bitten by so far
;; (sbcl-0.pre7.118) is this one:
- (and (defined-fun-p free-fun)
- (let ((functional (defined-fun-functional free-fun)))
- (or (and functional
- (eql (functional-kind functional) :deleted))
- (and (lambda-p functional)
- (or
- ;; (The main reason for this first test is to bail
- ;; out early in cases where the LAMBDA-COMPONENT
- ;; call in the second test would fail because links
- ;; it needs are uninitialized or invalid.)
- ;;
- ;; If the BIND node for this LAMBDA is null, then
- ;; according to the slot comments, the LAMBDA has
- ;; been deleted or its call has been deleted. In
- ;; that case, it seems rather questionable to reuse
- ;; it, and certainly it shouldn't be necessary to
- ;; reuse it, so we cheerfully declare it invalid.
- (null (lambda-bind functional))
- ;; If this IR1 stuff belongs to a dead component,
- ;; then we can't reuse it without getting into
- ;; bizarre confusion.
- (eql (component-info (lambda-component functional))
- :dead)))))))
+ (when (defined-fun-p free-fun)
+ (setf (defined-fun-functionals free-fun)
+ (delete-if (lambda (functional)
+ (or (eq (functional-kind functional) :deleted)
+ (when (lambda-p functional)
+ (or
+ ;; (The main reason for this first test is to bail
+ ;; out early in cases where the LAMBDA-COMPONENT
+ ;; call in the second test would fail because links
+ ;; it needs are uninitialized or invalid.)
+ ;;
+ ;; If the BIND node for this LAMBDA is null, then
+ ;; according to the slot comments, the LAMBDA has
+ ;; been deleted or its call has been deleted. In
+ ;; that case, it seems rather questionable to reuse
+ ;; it, and certainly it shouldn't be necessary to
+ ;; reuse it, so we cheerfully declare it invalid.
+ (not (lambda-bind functional))
+ ;; If this IR1 stuff belongs to a dead component,
+ ;; then we can't reuse it without getting into
+ ;; bizarre confusion.
+ (eq (component-info (lambda-component functional))
+ :dead)))))
+ (defined-fun-functionals free-fun)))
+ nil))
;;; If NAME already has a valid entry in *FREE-FUNS*, then return
;;; the value. Otherwise, make a new GLOBAL-VAR using information from
(declaim (ftype (sfunction (t string) global-var) find-free-fun))
(defun find-free-fun (name context)
(or (let ((old-free-fun (gethash name *free-funs*)))
- (and (not (invalid-free-fun-p old-free-fun))
- old-free-fun))
+ (when old-free-fun
+ (clear-invalid-functionals old-free-fun)
+ old-free-fun))
(ecase (info :function :kind name)
;; FIXME: The :MACRO and :SPECIAL-FORM cases could be merged.
(:macro
(inlinep (info :function :inlinep name)))
(setf (gethash name *free-funs*)
(if (or expansion inlinep)
- (make-defined-fun
- :%source-name name
- :inline-expansion expansion
- :inlinep inlinep
- :where-from (info :function :where-from name)
- :type (if (eq inlinep :notinline)
- (specifier-type 'function)
- (info :function :type name)))
+ (let ((where (info :function :where-from name)))
+ (make-defined-fun
+ :%source-name name
+ :inline-expansion expansion
+ :inlinep inlinep
+ :where-from (if (eq inlinep :notinline)
+ where
+ (maybe-defined-here name where))
+ :type (if (and (eq inlinep :notinline)
+ (neq where :declared))
+ (specifier-type 'function)
+ (info :function :type name))))
(find-global-fun name nil))))))))
;;; Return the LEAF structure for the lexically apparent function
(t
(find-free-fun name context)))))
+(defun maybe-find-free-var (name)
+ (gethash name *free-vars*))
+
;;; Return the LEAF node for a global variable reference to NAME. If
;;; NAME is already entered in *FREE-VARS*, then we just return the
;;; corresponding value. Otherwise, we make a new leaf using
(let ((kind (info :variable :kind name))
(type (info :variable :type name))
(where-from (info :variable :where-from name)))
- (when (and (eq where-from :assumed) (eq kind :global))
+ (when (eq kind :unknown)
(note-undefined-reference name :variable))
(setf (gethash name *free-vars*)
(case kind
(let* ((forms (if for-value `(,form) `(,form nil)))
(res (ir1-convert-lambda-body
forms ()
- :debug-name (debug-name 'top-level-form form))))
+ :debug-name (debug-name 'top-level-form #+sb-xc-host nil #-sb-xc-host form))))
(setf (functional-entry-fun res) res
(functional-arg-documentation res) ()
(functional-kind res) :toplevel)
(trail form))
(declare (fixnum pos))
(macrolet ((frob ()
- '(progn
+ `(progn
(when (atom subform) (return))
(let ((fm (car subform)))
- (if (consp fm)
- ;; If it's a cons, recurse
- (sub-find-source-paths fm (cons pos path))
- ;; Otherwise store the containing form. It's
- ;; not perfect, but better than nothing.
- (unless (zerop pos)
- (note-source-path subform pos path)))
+ (cond ((consp fm)
+ ;; If it's a cons, recurse.
+ (sub-find-source-paths fm (cons pos path)))
+ ((eq 'quote fm)
+ ;; Don't look into quoted constants.
+ (return))
+ ((not (zerop pos))
+ ;; Otherwise store the containing form. It's not
+ ;; perfect, but better than nothing.
+ (note-source-path subform pos path)))
(incf pos))
(setq subform (cdr subform))
(when (eq subform trail) (return)))))
(defun ir1-convert (start next result form)
(ir1-error-bailout (start next result form)
(let* ((*current-path* (or (get-source-path form)
- (cons form *current-path*)))
+ (cons (simplify-source-path-form form)
+ *current-path*)))
(start (instrument-coverage start nil form)))
(cond ((atom form)
(cond ((and (symbolp form) (not (keywordp form)))
;;; functional instead.
(defun reference-leaf (start next result leaf &optional (name '.anonymous.))
(declare (type ctran start next) (type (or lvar null) result) (type leaf leaf))
- (when (functional-p leaf)
- (assure-functional-live-p leaf))
+ (assure-leaf-live-p leaf)
(let* ((type (lexenv-find leaf type-restrictions))
(leaf (or (and (defined-fun-p leaf)
(not (eq (defined-fun-inlinep leaf)
:notinline))
(let ((functional (defined-fun-functional leaf)))
- (when (and functional
- (not (functional-kind functional))
- ;; Bug MISC.320: ir1-transform
- ;; can create a reference to a
- ;; inline-expanded function,
- ;; defined in another component.
- (not (and (lambda-p functional)
- (neq (lambda-component functional)
- *current-component*))))
+ (when (and functional (not (functional-kind functional)))
(maybe-reanalyze-functional functional))))
(when (and (lambda-p leaf)
(memq (functional-kind leaf)
;; KLUDGE: If the reference is dead, convert using SYMBOL-VALUE
;; which is not flushable, so that unbound dead variables signal
;; an error (bug 412).
- (ir1-convert start next result `(symbol-value ',name))
+ (ir1-convert start next result
+ (if (eq (global-var-kind var) :global)
+ `(symbol-global-value ',name)
+ `(symbol-value ',name)))
(etypecase var
(leaf
(when (lambda-var-p var)
;; CLHS 3.2.2.1.3 specifies that NOTINLINE
;; suppresses compiler-macros.
(not (fun-lexically-notinline-p cmacro-fun-name)))
- (let ((res (careful-expand-macro cmacro-fun form)))
- (if (eq res form)
- (ir1-convert-common-functoid start next result form
- op)
- (ir1-convert start next result res)))
+ (let ((res (careful-expand-macro cmacro-fun form t)))
+ (cond ((eq res form)
+ (ir1-convert-common-functoid start next result form op))
+ (t
+ (unless (policy *lexenv* (zerop store-xref-data))
+ (record-call cmacro-fun-name (ctran-block start) *current-path*))
+ (ir1-convert start next result res))))
(ir1-convert-common-functoid start next result form op)))))))
;;; Handles the "common" cases: any other forms except special forms
;;; Expand FORM using the macro whose MACRO-FUNCTION is FUN, trapping
;;; errors which occur during the macroexpansion.
-(defun careful-expand-macro (fun form)
- (let (;; a hint I (WHN) wish I'd known earlier
- (hint "(hint: For more precise location, try *BREAK-ON-SIGNALS*.)"))
- (flet (;; Return a string to use as a prefix in error reporting,
- ;; telling something about which form caused the problem.
- (wherestring ()
- (let ((*print-pretty* nil)
- ;; We rely on the printer to abbreviate FORM.
- (*print-length* 3)
- (*print-level* 3))
- (format
- nil
- #-sb-xc-host "(in macroexpansion of ~S)"
- ;; longer message to avoid ambiguity "Was it the xc host
- ;; or the cross-compiler which encountered the problem?"
- #+sb-xc-host "(in cross-compiler macroexpansion of ~S)"
- form))))
- (handler-bind ((style-warning (lambda (c)
- (compiler-style-warn
- "~@<~A~:@_~A~@:_~A~:>"
- (wherestring) hint c)
- (muffle-warning-or-die)))
- ;; KLUDGE: CMU CL in its wisdom (version 2.4.6 for
- ;; Debian Linux, anyway) raises a CL:WARNING
- ;; condition (not a CL:STYLE-WARNING) for undefined
- ;; symbols when converting interpreted functions,
- ;; causing COMPILE-FILE to think the file has a real
- ;; problem, causing COMPILE-FILE to return FAILURE-P
- ;; set (not just WARNINGS-P set). Since undefined
- ;; symbol warnings are often harmless forward
- ;; references, and since it'd be inordinately painful
- ;; to try to eliminate all such forward references,
- ;; these warnings are basically unavoidable. Thus, we
- ;; need to coerce the system to work through them,
- ;; and this code does so, by crudely suppressing all
- ;; warnings in cross-compilation macroexpansion. --
- ;; WHN 19990412
- #+(and cmu sb-xc-host)
- (warning (lambda (c)
- (compiler-notify
- "~@<~A~:@_~
- ~A~:@_~
- ~@<(KLUDGE: That was a non-STYLE WARNING. ~
- Ordinarily that would cause compilation to ~
- fail. However, since we're running under ~
- CMU CL, and since CMU CL emits non-STYLE ~
- warnings for safe, hard-to-fix things (e.g. ~
- references to not-yet-defined functions) ~
- we're going to have to ignore it and ~
- proceed anyway. Hopefully we're not ~
- ignoring anything horrible here..)~:@>~:>"
- (wherestring)
- c)
- (muffle-warning-or-die)))
- #-(and cmu sb-xc-host)
- (warning (lambda (c)
- (warn "~@<~A~:@_~A~@:_~A~:>"
- (wherestring) hint c)
- (muffle-warning-or-die)))
- (error (lambda (c)
- (compiler-error "~@<~A~:@_~A~@:_~A~:>"
- (wherestring) hint c))))
- (funcall sb!xc:*macroexpand-hook* fun form *lexenv*)))))
+(defun careful-expand-macro (fun form &optional cmacro)
+ (flet (;; Return a string to use as a prefix in error reporting,
+ ;; telling something about which form caused the problem.
+ (wherestring ()
+ (let (;; We rely on the printer to abbreviate FORM.
+ (*print-length* 3)
+ (*print-level* 3))
+ (format
+ nil
+ #-sb-xc-host "~@<~;during ~A of ~S. Use ~S to intercept:~%~:@>"
+ ;; longer message to avoid ambiguity "Was it the xc host
+ ;; or the cross-compiler which encountered the problem?"
+ #+sb-xc-host "~@<~;during cross-compiler ~A of ~S. Use ~S to intercept:~%~:@>"
+ (if cmacro "compiler-macroexpansion" "macroexpansion")
+ form
+ '*break-on-signals*))))
+ (handler-bind (;; KLUDGE: CMU CL in its wisdom (version 2.4.6 for Debian
+ ;; Linux, anyway) raises a CL:WARNING condition (not a
+ ;; CL:STYLE-WARNING) for undefined symbols when converting
+ ;; interpreted functions, causing COMPILE-FILE to think the
+ ;; file has a real problem, causing COMPILE-FILE to return
+ ;; FAILURE-P set (not just WARNINGS-P set). Since undefined
+ ;; symbol warnings are often harmless forward references,
+ ;; and since it'd be inordinately painful to try to
+ ;; eliminate all such forward references, these warnings
+ ;; are basically unavoidable. Thus, we need to coerce the
+ ;; system to work through them, and this code does so, by
+ ;; crudely suppressing all warnings in cross-compilation
+ ;; macroexpansion. -- WHN 19990412
+ #+(and cmu sb-xc-host)
+ (warning (lambda (c)
+ (compiler-notify
+ "~@<~A~:@_~
+ ~A~:@_~
+ ~@<(KLUDGE: That was a non-STYLE WARNING. ~
+ Ordinarily that would cause compilation to ~
+ fail. However, since we're running under ~
+ CMU CL, and since CMU CL emits non-STYLE ~
+ warnings for safe, hard-to-fix things (e.g. ~
+ references to not-yet-defined functions) ~
+ we're going to have to ignore it and ~
+ proceed anyway. Hopefully we're not ~
+ ignoring anything horrible here..)~:@>~:>"
+ (wherestring)
+ c)
+ (muffle-warning-or-die)))
+ (error (lambda (c)
+ (compiler-error "~@<~A~@:_ ~A~:>"
+ (wherestring) c))))
+ (funcall sb!xc:*macroexpand-hook* fun form *lexenv*))))
\f
;;;; conversion utilities
(defined-fun-inlinep var))))
(if (eq inlinep :notinline)
(ir1-convert-combination start next result form var)
- (let ((transform (info :function
- :source-transform
- (leaf-source-name var))))
+ (let* ((name (leaf-source-name var))
+ (transform (info :function :source-transform name)))
(if transform
(multiple-value-bind (transformed pass) (funcall transform form)
- (if pass
- (ir1-convert-maybe-predicate start next result form var)
- (ir1-convert start next result transformed)))
+ (cond (pass
+ (ir1-convert-maybe-predicate start next result form var))
+ (t
+ (unless (policy *lexenv* (zerop store-xref-data))
+ (record-call name (ctran-block start) *current-path*))
+ (ir1-convert start next result transformed))))
(ir1-convert-maybe-predicate start next result form var))))))
;;; KLUDGE: If we insert a synthetic IF for a function with the PREDICATE
(type leaf var))
(let* ((node (ir1-convert-combination start next result form var))
(fun-lvar (basic-combination-fun node))
- (type (leaf-type var))
- (defined-type (leaf-defined-type var)))
- (when (validate-call-type node type defined-type t)
+ (type (leaf-type var)))
+ (when (validate-call-type node type var t)
(setf (lvar-%derived-type fun-lvar)
(make-single-value-type type))
(setf (lvar-reoptimize fun-lvar) nil)))
(type-specifier old-type)
(type-specifier type)
var-name))))
- (bound-var (setf (leaf-type bound-var) int))
+ (bound-var
+ (setf (leaf-type bound-var) int
+ (leaf-where-from bound-var) :declared))
(t
(restr (cons var int)))))))
(process-var var bound-var)
(declare (list spec vars) (type lexenv res))
(collect ((new-venv nil cons))
(dolist (name (cdr spec))
+ ;; While CLHS seems to allow local SPECIAL declarations for constants,
+ ;; whatever the semantics are supposed to be is not at all clear to me
+ ;; -- since constants aren't allowed to be bound it should be a no-op as
+ ;; no-one can observe the difference portably, but specials are allowed
+ ;; to be bound... yet nowhere does it say that the special declaration
+ ;; removes the constantness. Call it a spec bug and prohibit it. Same
+ ;; for GLOBAL variables.
+ (let ((kind (info :variable :kind name)))
+ (unless (member kind '(:special :unknown))
+ (error "Can't declare ~(~A~) variable locally special: ~S" kind name)))
(program-assert-symbol-home-package-unlocked
context name "declaring ~A special")
(let ((var (find-in-bindings vars name)))
(when (defined-fun-p var)
(setf (defined-fun-inline-expansion res)
(defined-fun-inline-expansion var))
- (setf (defined-fun-functional res)
- (defined-fun-functional var)))
+ (setf (defined-fun-functionals res)
+ (defined-fun-functionals var)))
;; FIXME: Is this really right? Needs we not set the FUNCTIONAL
;; to the original global-var?
res))
(values))
(defun process-dx-decl (names vars fvars kind)
- (flet ((maybe-notify (control &rest args)
- (when (policy *lexenv* (> speed inhibit-warnings))
- (apply #'compiler-notify control args))))
- (let ((dx (cond ((eq 'truly-dynamic-extent kind)
- :truly)
- ((and (eq 'dynamic-extent kind)
- *stack-allocate-dynamic-extent*)
- t))))
- (if dx
- (dolist (name names)
- (cond
- ((symbolp name)
- (let* ((bound-var (find-in-bindings vars name))
- (var (or bound-var
- (lexenv-find name vars)
- (find-free-var name))))
- (etypecase var
- (leaf
- (if bound-var
- (setf (leaf-dynamic-extent var) dx)
- (maybe-notify
- "ignoring DYNAMIC-EXTENT declaration for free ~S"
- name)))
- (cons
- (compiler-error "DYNAMIC-EXTENT on symbol-macro: ~S" name))
- (heap-alien-info
- (compiler-error "DYNAMIC-EXTENT on heap-alien-info: ~S"
- name)))))
- ((and (consp name)
- (eq (car name) 'function)
- (null (cddr name))
- (valid-function-name-p (cadr name)))
- (let* ((fname (cadr name))
- (bound-fun (find fname fvars
- :key #'leaf-source-name
- :test #'equal)))
- (etypecase bound-fun
- (leaf
- #!+stack-allocatable-closures
- (setf (leaf-dynamic-extent bound-fun) dx)
- #!-stack-allocatable-closures
- (maybe-notify
- "ignoring DYNAMIC-EXTENT declaration on a function ~S ~
- (not supported on this platform)." fname))
- (cons
- (compiler-error "DYNAMIC-EXTENT on macro: ~S" fname))
- (null
- (maybe-notify
- "ignoring DYNAMIC-EXTENT declaration for free ~S"
- fname)))))
- (t (compiler-error "DYNAMIC-EXTENT on a weird thing: ~S" name))))
- (maybe-notify "ignoring DYNAMIC-EXTENT declarations for ~S" names)))))
+ (let ((dx (cond ((eq 'truly-dynamic-extent kind)
+ :truly)
+ ((and (eq 'dynamic-extent kind)
+ *stack-allocate-dynamic-extent*)
+ t))))
+ (if dx
+ (dolist (name names)
+ (cond
+ ((symbolp name)
+ (let* ((bound-var (find-in-bindings vars name))
+ (var (or bound-var
+ (lexenv-find name vars)
+ (maybe-find-free-var name))))
+ (etypecase var
+ (leaf
+ (if bound-var
+ (setf (leaf-dynamic-extent var) dx)
+ (compiler-notify
+ "Ignoring free DYNAMIC-EXTENT declaration: ~S" name)))
+ (cons
+ (compiler-error "DYNAMIC-EXTENT on symbol-macro: ~S" name))
+ (heap-alien-info
+ (compiler-error "DYNAMIC-EXTENT on alien-variable: ~S"
+ name))
+ (null
+ (compiler-style-warn
+ "Unbound variable declared DYNAMIC-EXTENT: ~S" name)))))
+ ((and (consp name)
+ (eq (car name) 'function)
+ (null (cddr name))
+ (valid-function-name-p (cadr name)))
+ (let* ((fname (cadr name))
+ (bound-fun (find fname fvars
+ :key #'leaf-source-name
+ :test #'equal))
+ (fun (or bound-fun (lexenv-find fname funs))))
+ (etypecase fun
+ (leaf
+ (if bound-fun
+ #!+stack-allocatable-closures
+ (setf (leaf-dynamic-extent bound-fun) dx)
+ #!-stack-allocatable-closures
+ (compiler-notify
+ "Ignoring DYNAMIC-EXTENT declaration on function ~S ~
+ (not supported on this platform)." fname)
+ (compiler-notify
+ "Ignoring free DYNAMIC-EXTENT declaration: ~S" name)))
+ (cons
+ (compiler-error "DYNAMIC-EXTENT on macro: ~S" name))
+ (null
+ (compiler-style-warn
+ "Unbound function declared DYNAMIC-EXTENT: ~S" name)))))
+ (t
+ (compiler-error "DYNAMIC-EXTENT on a weird thing: ~S" name))))
+ (when (policy *lexenv* (= speed 3))
+ (compiler-notify "Ignoring DYNAMIC-EXTENT declarations: ~S" names)))))
;;; FIXME: This is non-ANSI, so the default should be T, or it should
;;; go away, I think.
(t
(unless (info :declaration :recognized (first spec))
(compiler-warn "unrecognized declaration ~S" raw-spec))
- res))
+ (let ((fn (info :declaration :handler (first spec))))
+ (if fn
+ (funcall fn res spec vars fvars)
+ res))))
result-type)))
;;; Use a list of DECLARE forms to annotate the lists of LAMBDA-VAR
(*post-binding-variable-lexenv* nil))
(dolist (decl decls)
(dolist (spec (rest decl))
- (unless (consp spec)
- (compiler-error "malformed declaration specifier ~S in ~S" spec decl))
- (multiple-value-bind (new-env new-result-type)
- (process-1-decl spec lexenv vars fvars binding-form-p context)
- (setq lexenv new-env)
- (unless (eq new-result-type *wild-type*)
- (setq result-type
- (values-type-intersection result-type new-result-type))))))
+ (progv
+ ;; Kludge: EVAL calls this function to deal with LOCALLY.
+ (when (eq context :compile) (list '*current-path*))
+ (when (eq context :compile) (list (or (get-source-path spec)
+ (get-source-path decl)
+ *current-path*)))
+ (unless (consp spec)
+ (compiler-error "malformed declaration specifier ~S in ~S" spec decl))
+ (multiple-value-bind (new-env new-result-type)
+ (process-1-decl spec lexenv vars fvars binding-form-p context)
+ (setq lexenv new-env)
+ (unless (eq new-result-type *wild-type*)
+ (setq result-type
+ (values-type-intersection result-type new-result-type)))))))
(values lexenv result-type *post-binding-variable-lexenv*)))
(defun %processing-decls (decls vars fvars ctran lvar binding-form-p fun)
(check-type ctran symbol)
(check-type lvar symbol)
(let ((post-binding-lexenv-p (not (null post-binding-lexenv)))
- (post-binding-lexenv (or post-binding-lexenv (gensym))))
+ (post-binding-lexenv (or post-binding-lexenv (sb!xc:gensym "LEXENV"))))
`(%processing-decls ,decls ,vars ,fvars ,ctran ,lvar
,post-binding-lexenv-p
(lambda (,ctran ,lvar ,post-binding-lexenv)
projects / sbcl.git / blobdiff