(push node-block (block-pred block))
(add-continuation-use node cont)
(unless (eq (continuation-asserted-type cont) *wild-type*)
- (let ((new (values-type-union (continuation-asserted-type cont)
- (or (lexenv-find cont type-restrictions)
- *wild-type*))))
- (when (type/= new (continuation-asserted-type cont))
- (setf (continuation-asserted-type cont) new)
+ (let* ((restriction (or (lexenv-find cont type-restrictions)
+ *wild-type*))
+ (wrestriction (or (lexenv-find cont weakend-type-restrictions)
+ *wild-type*))
+ (newatype (values-type-union (continuation-asserted-type cont)
+ restriction))
+ (newctype (values-type-union (continuation-type-to-check cont)
+ wrestriction)))
+ (when (or (type/= newatype (continuation-asserted-type cont))
+ (type/= newctype (continuation-type-to-check cont)))
+ (setf (continuation-asserted-type cont) newatype)
+ (setf (continuation-type-to-check cont) newctype)
(reoptimize-continuation cont))))))
\f
;;;; exported functions
;;; functional instead.
(defun reference-leaf (start cont leaf)
(declare (type continuation start cont) (type leaf leaf))
- (let* ((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)))
- (maybe-reanalyze-functional functional))))
- leaf))
- (res (make-ref (or (lexenv-find leaf type-restrictions)
- (leaf-type leaf))
- leaf)))
- (push res (leaf-refs leaf))
- (setf (leaf-ever-used leaf) t)
- (link-node-to-previous-continuation res start)
- (use-continuation res cont)))
+ (with-continuation-type-assertion
+ (cont (or (lexenv-find leaf type-restrictions) *wild-type*)
+ "in DECLARE")
+ (let* ((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)))
+ (maybe-reanalyze-functional functional))))
+ leaf))
+ (res (make-ref (leaf-type leaf)
+ leaf)))
+ (push res (leaf-refs leaf))
+ (setf (leaf-ever-used leaf) t)
+ (link-node-to-previous-continuation res start)
+ (use-continuation res cont))))
;;; Convert a reference to a symbolic constant or variable. If the
;;; symbol is entered in the LEXENV-VARS we use that definition,
;; or the cross-compiler which encountered the problem?"
#+sb-xc-host "(in cross-compiler macroexpansion of ~S)"
form))))
- (handler-bind (;; When cross-compiling, we can get style warnings
- ;; about e.g. undefined functions. An unhandled
- ;; CL:STYLE-WARNING (as opposed to a
- ;; SB!C::COMPILER-NOTE) would cause FAILURE-P to be
- ;; set on the return from #'SB!XC:COMPILE-FILE, which
- ;; would falsely indicate an error sufficiently
- ;; serious that we should stop the build process. To
- ;; avoid this, we translate CL:STYLE-WARNING
- ;; conditions from the host Common Lisp into
- ;; cross-compiler SB!C::COMPILER-NOTE calls. (It
- ;; might be cleaner to just make Python use
- ;; CL:STYLE-WARNING internally, so that the
- ;; significance of any host Common Lisp
- ;; CL:STYLE-WARNINGs is understood automatically. But
- ;; for now I'm not motivated to do this. -- WHN
- ;; 19990412)
- (style-warning (lambda (c)
- (compiler-note "~@<~A~:@_~A~:@_~A~:>"
- (wherestring) hint c)
- (muffle-warning-or-die)))
- ;; KLUDGE: CMU CL in its wisdom (version 2.4.6 for
+ (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,
;; and this code does so, by crudely suppressing all
;; warnings in cross-compilation macroexpansion. --
;; WHN 19990412
- #+cmu
+ #+(and cmu sb-xc-host)
(warning (lambda (c)
(compiler-note
"~@<~A~:@_~
(wherestring)
c)
(muffle-warning-or-die)))
+ #-(and cmu sb-xc-host)
+ (warning (lambda (c)
+ (compiler-warn "~@<~A~:@_~A~@:_~A~:>"
+ (wherestring) hint c)
+ (muffle-warning-or-die)))
(error (lambda (c)
(compiler-error "~@<~A~:@_~A~@:_~A~:>"
(wherestring) hint c))))
(let ((node (make-combination fun-cont)))
(setf (continuation-dest fun-cont) node)
(assert-continuation-type fun-cont
- (specifier-type '(or function symbol)))
+ (specifier-type '(or function symbol))
+ (lexenv-policy *lexenv*))
+ (setf (continuation-%externally-checkable-type fun-cont) nil)
(collect ((arg-conts))
(let ((this-start fun-cont))
(dolist (arg args)
;;; macro, we just wrap a THE around the expansion.
(defun process-type-decl (decl res vars)
(declare (list decl vars) (type lexenv res))
- (let ((type (specifier-type (first decl))))
+ (let ((type (compiler-specifier-type (first decl))))
(collect ((restr nil cons)
(new-vars nil cons))
(dolist (var-name (rest decl))
;;; declarations that constrain the type of lexically apparent
;;; functions.
(defun process-ftype-decl (spec res names fvars)
- (declare (list spec names fvars) (type lexenv res))
- (let ((type (specifier-type spec)))
+ (declare (type type-specifier spec)
+ (type list names fvars)
+ (type lexenv res))
+ (let ((type (compiler-specifier-type spec)))
(collect ((res nil cons))
(dolist (name names)
(let ((found (find name fvars
`(values ,@types))
cont
res
- 'values))))
+ "in VALUES declaration"))))
(dynamic-extent
(when (policy *lexenv* (> speed inhibit-warnings))
(compiler-note
(make-lambda-var :%source-name name)))))
;;; 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.
+;;; isn't already used by one of the VARS.
(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)))
(keywordicate symbol)
symbol)))
- (when (eq key :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
(declaim (ftype (function (list) (values list boolean boolean list list))
make-lambda-vars))
(defun make-lambda-vars (list)
- (multiple-value-bind (required optional restp rest keyp keys allowp aux
+ (multiple-value-bind (required optional restp rest keyp keys allowp auxp aux
morep more-context more-count)
(parse-lambda-list list)
+ (declare (ignore auxp)) ; since we just iterate over AUX regardless
(collect ((vars)
(names-so-far)
(aux-vars)
(setf (lambda-tail-set lambda) tail-set)
(setf (lambda-return lambda) return)
(setf (continuation-dest result) return)
+ (setf (continuation-%externally-checkable-type result) nil)
(setf (block-last block) return)
(link-node-to-previous-continuation return result)
(use-continuation return dummy))
(n-allowp (gensym "N-ALLOWP-"))
(n-losep (gensym "N-LOSEP-"))
(allowp (or (optional-dispatch-allowp res)
- (policy *lexenv* (zerop safety)))))
+ (policy *lexenv* (zerop safety))))
+ (found-allow-p nil))
(temps `(,n-index (1- ,n-count)) n-key n-value-temp)
(body `(declare (fixnum ,n-index) (ignorable ,n-key ,n-value-temp)))
(default (arg-info-default info))
(keyword (arg-info-key info))
(supplied-p (arg-info-supplied-p info))
- (n-value (gensym "N-VALUE-")))
- (temps `(,n-value ,default))
- (cond (supplied-p
- (let ((n-supplied (gensym "N-SUPPLIED-")))
- (temps n-supplied)
- (arg-vals n-value n-supplied)
- (tests `((eq ,n-key ',keyword)
- (setq ,n-supplied t)
- (setq ,n-value ,n-value-temp)))))
- (t
- (arg-vals n-value)
- (tests `((eq ,n-key ',keyword)
- (setq ,n-value ,n-value-temp)))))))
+ (n-value (gensym "N-VALUE-"))
+ (clause (cond (supplied-p
+ (let ((n-supplied (gensym "N-SUPPLIED-")))
+ (temps n-supplied)
+ (arg-vals n-value n-supplied)
+ `((eq ,n-key ',keyword)
+ (setq ,n-supplied t)
+ (setq ,n-value ,n-value-temp))))
+ (t
+ (arg-vals n-value)
+ `((eq ,n-key ',keyword)
+ (setq ,n-value ,n-value-temp))))))
+ (when (and (not allowp) (eq keyword :allow-other-keys))
+ (setq found-allow-p t)
+ (setq clause
+ (append clause `((setq ,n-allowp ,n-value-temp)))))
+
+ (temps `(,n-value ,default))
+ (tests clause)))
(unless allowp
(temps n-allowp n-losep)
- (tests `((eq ,n-key :allow-other-keys)
- (setq ,n-allowp ,n-value-temp)))
+ (unless found-allow-p
+ (tests `((eq ,n-key :allow-other-keys)
+ (setq ,n-allowp ,n-value-temp))))
(tests `(t
(setq ,n-losep ,n-key))))
projects / sbcl.git / blobdiff