0.7.9.14:

[sbcl.git] / src / compiler / ir1util.lisp

diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index 7dd4459..c98f2bf 100644 (file)
--- a/src/compiler/ir1util.lisp
+++ b/src/compiler/ir1util.lisp
@@ -151,7 +151,8 @@
                 (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
@@ -386,7 +387,7 @@
 ;;; 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
                         (lambda (lexenv-lambda default))
                         (cleanup (lexenv-cleanup default))
                         (policy (lexenv-policy default)))
@@ -401,8 +402,36 @@
      (frob blocks lexenv-blocks)
      (frob tags lexenv-tags)
      (frob type-restrictions lexenv-type-restrictions)
-     lambda cleanup policy 
-     (frob options lexenv-options))))
+     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
+     nil
+     nil
+     (lexenv-policy lexenv))))
 \f
 ;;;; flow/DFO/component hackery
 
@@ -469,7 +498,10 @@
                      `(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)))))
@@ -791,6 +823,7 @@
   (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)
@@ -846,6 +879,7 @@
 
   (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*)
@@ -1174,7 +1208,8 @@
               (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))
@@ -1378,6 +1413,29 @@
          (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