(nsubst new old (basic-combination-args dest))))))
(flush-dest old)
- (setf (continuation-dest new) dest))
+ (setf (continuation-dest new) dest)
+ (setf (continuation-%externally-checkable-type new) nil))
(values))
;;; Replace all uses of OLD with uses of NEW, where NEW has an
;;; slot values. Values for the alist slots are NCONCed to the
;;; beginning of the current value, rather than replacing it entirely.
(defun make-lexenv (&key (default *lexenv*)
- funs vars blocks tags type-restrictions options
+ funs vars blocks tags
+ type-restrictions weakend-type-restrictions
(lambda (lexenv-lambda default))
(cleanup (lexenv-cleanup default))
(policy (lexenv-policy default)))
(frob blocks lexenv-blocks)
(frob tags lexenv-tags)
(frob type-restrictions lexenv-type-restrictions)
- lambda cleanup policy
- (frob options lexenv-options))))
+ (frob weakend-type-restrictions lexenv-weakend-type-restrictions)
+ lambda cleanup policy)))
+
+;;; Makes a LEXENV, suitable for using in a MACROLET introduced
+;;; macroexpander
+(defun make-restricted-lexenv (lexenv)
+ (flet ((fun-good-p (fun)
+ (destructuring-bind (name . thing) fun
+ (declare (ignore name))
+ (etypecase thing
+ (functional nil)
+ (global-var t)
+ (cons (aver (eq (car thing) 'macro))
+ t))))
+ (var-good-p (var)
+ (destructuring-bind (name . thing) var
+ (declare (ignore name))
+ (etypecase thing
+ (leaf nil)
+ (cons (aver (eq (car thing) 'macro))
+ t)
+ (heap-alien-info nil)))))
+ (internal-make-lexenv
+ (remove-if-not #'fun-good-p (lexenv-funs lexenv))
+ (remove-if-not #'var-good-p (lexenv-vars lexenv))
+ nil
+ nil
+ (lexenv-type-restrictions lexenv) ; XXX
+ (lexenv-weakend-type-restrictions lexenv)
+ nil
+ nil
+ (lexenv-policy lexenv))))
\f
;;;; flow/DFO/component hackery
`(when (eq (,slot last) old)
(setf (,slot last) new))))
(frob if-consequent)
- (frob if-alternative))))
+ (frob if-alternative)
+ (when (eq (if-consequent last)
+ (if-alternative last))
+ (setf (component-reoptimize (block-component block)) t)))))
(t
(unless (member new (block-succ block) :test #'eq)
(link-blocks block new)))))
(let* ((bind-block (node-block bind))
(component (block-component bind-block))
(return (lambda-return clambda)))
- (aver (null (leaf-refs clambda)))
+ (dolist (ref (lambda-refs clambda))
+ (let ((home (node-home-lambda ref)))
+ (aver (eq home clambda))))
(unless (leaf-ever-used clambda)
(let ((*compiler-error-context* bind))
(compiler-note "deleting unused function~:[.~;~:*~% ~S~]"
(unless (eq (continuation-kind cont) :deleted)
(aver (continuation-dest cont))
(setf (continuation-dest cont) nil)
+ (setf (continuation-%externally-checkable-type cont) nil)
(do-uses (use cont)
(let ((prev (node-prev use)))
(unless (eq (continuation-kind prev) :deleted)
(setf (continuation-kind cont) :deleted)
(setf (continuation-dest cont) nil)
+ (setf (continuation-%externally-checkable-type cont) nil)
(setf (continuation-next cont) nil)
(setf (continuation-asserted-type cont) *empty-type*)
(setf (continuation-%derived-type cont) *empty-type*)
+ (setf (continuation-type-to-check cont) *empty-type*)
(setf (continuation-use cont) nil)
(setf (continuation-block cont) nil)
(setf (continuation-reoptimize cont) nil)
(reoptimize-continuation cont)))
(dolist (b (block-pred block))
- (unlink-blocks b block))
+ (unlink-blocks b block)
+ ;; In bug 147 the almost-all-blocks-have-a-successor invariant was
+ ;; broken when successors were deleted without setting the
+ ;; BLOCK-DELETE-P flags of their predececessors. Make sure that
+ ;; doesn't happen again.
+ (aver (not (and (null (block-succ b))
+ (not (block-delete-p b))
+ (not (eq b (component-head (block-component b))))))))
(dolist (b (block-succ block))
(unlink-blocks block b))
(before-args (subseq outside-args 0 arg-position))
(after-args (subseq outside-args (1+ arg-position))))
(dolist (arg inside-args)
- (setf (continuation-dest arg) outside))
+ (setf (continuation-dest arg) outside)
+ (setf (continuation-%externally-checkable-type arg) nil))
(setf (combination-args inside) nil)
(setf (combination-args outside)
(append before-args inside-args after-args))
(setf (node-derived-type inside) *wild-type*)
(flush-dest cont)
(setf (continuation-asserted-type cont) *wild-type*)
+ (setf (continuation-type-to-check cont) *wild-type*)
(values))))))
\f
;;;; leaf hackery
;;; Apply a function to some arguments, returning a list of the values
;;; resulting of the evaluation. If an error is signalled during the
-;;; application, then we print a warning message and return NIL as our
-;;; second value to indicate this. Node is used as the error context
-;;; for any error message, and Context is a string that is spliced
-;;; into the warning.
-(declaim (ftype (function ((or symbol function) list node string)
+;;; application, then we produce a warning message using WARN-FUN and
+;;; return NIL as our second value to indicate this. NODE is used as
+;;; the error context for any error message, and CONTEXT is a string
+;;; that is spliced into the warning.
+(declaim (ftype (function ((or symbol function) list node function string)
(values list boolean))
careful-call))
-(defun careful-call (function args node context)
+(defun careful-call (function args node warn-fun context)
(values
(multiple-value-list
(handler-case (apply function args)
(error (condition)
(let ((*compiler-error-context* node))
- (compiler-warn "Lisp error during ~A:~%~A" context condition)
+ (funcall warn-fun "Lisp error during ~A:~%~A" context condition)
(return-from careful-call (values nil nil))))))
t))
+
+;;; Variations of SPECIFIER-TYPE for parsing possibly wrong
+;;; specifiers.
+(macrolet
+ ((deffrob (basic careful compiler transform)
+ `(progn
+ (defun ,careful (specifier)
+ (handler-case (,basic specifier)
+ (simple-error (condition)
+ (values nil (list* (simple-condition-format-control condition)
+ (simple-condition-format-arguments condition))))))
+ (defun ,compiler (specifier)
+ (multiple-value-bind (type error-args) (,careful specifier)
+ (or type
+ (apply #'compiler-error error-args))))
+ (defun ,transform (specifier)
+ (multiple-value-bind (type error-args) (,careful specifier)
+ (or type
+ (apply #'give-up-ir1-transform
+ error-args)))))))
+ (deffrob specifier-type careful-specifier-type compiler-specifier-type ir1-transform-specifier-type)
+ (deffrob values-specifier-type careful-values-specifier-type compiler-values-specifier-type ir1-transform-values-specifier-type))
+
\f
;;;; utilities used at run-time for parsing &KEY args in IR1
projects / sbcl.git / blobdiff