1.0.3.9: Allow characters as string designators for SHADOW

[sbcl.git] / src / compiler / ir1-translators.lisp

diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp
index 0ca97d2..a1437e1 100644 (file)
--- a/src/compiler/ir1-translators.lisp
+++ b/src/compiler/ir1-translators.lisp
@@ -126,35 +126,38 @@ extent of the block."
     (link-node-to-previous-ctran exit value-ctran)
     (let ((home-lambda (ctran-home-lambda-or-null start)))
       (when home-lambda
-        (push entry (lambda-calls-or-closes home-lambda))))
+        (sset-adjoin entry (lambda-calls-or-closes home-lambda))))
     (use-continuation exit exit-ctran (third found))))
 
 ;;; Return a list of the segments of a TAGBODY. Each segment looks
 ;;; like (<tag> <form>* (go <next tag>)). That is, we break up the
 ;;; tagbody into segments of non-tag statements, and explicitly
 ;;; represent the drop-through with a GO. The first segment has a
-;;; dummy NIL tag, since it represents code before the first tag. The
+;;; dummy NIL tag, since it represents code before the first tag. Note
+;;; however that NIL may appear as the tag of an inner segment. The
 ;;; last segment (which may also be the first segment) ends in NIL
 ;;; rather than a GO.
 (defun parse-tagbody (body)
   (declare (list body))
-  (collect ((segments))
-    (let ((current (cons nil body)))
+  (collect ((tags)
+            (segments))
+    (let ((current body))
       (loop
-        (let ((tag-pos (position-if (complement #'listp) current :start 1)))
-          (unless tag-pos
-            (segments `(,@current nil))
-            (return))
-          (let ((tag (elt current tag-pos)))
-            (when (assoc tag (segments))
-              (compiler-error
-               "The tag ~S appears more than once in the tagbody."
-               tag))
-            (unless (or (symbolp tag) (integerp tag))
-              (compiler-error "~S is not a legal tagbody statement." tag))
-            (segments `(,@(subseq current 0 tag-pos) (go ,tag))))
-          (setq current (nthcdr tag-pos current)))))
-    (segments)))
+       (let ((next-segment (member-if #'atom current)))
+         (unless next-segment
+           (segments `(,@current nil))
+           (return))
+         (let ((tag (car next-segment)))
+           (when (member tag (tags))
+             (compiler-error
+              "The tag ~S appears more than once in a tagbody."
+              tag))
+           (unless (or (symbolp tag) (integerp tag))
+             (compiler-error "~S is not a legal go tag." tag))
+           (tags tag)
+           (segments `(,@(ldiff current next-segment) (go ,tag))))
+         (setq current (rest next-segment))))
+      (mapcar #'cons (cons nil (tags)) (segments)))))
 
 ;;; Set up the cleanup, emitting the entry node. Then make a block for
 ;;; each tag, building up the tag list for LEXENV-TAGS as we go.
@@ -218,7 +221,7 @@ constrained to be used only within the dynamic extent of the TAGBODY."
     (link-node-to-previous-ctran exit start)
     (let ((home-lambda (ctran-home-lambda-or-null start)))
       (when home-lambda
-        (push entry (lambda-calls-or-closes home-lambda))))
+        (sset-adjoin entry (lambda-calls-or-closes home-lambda))))
     (use-ctran exit (second found))))
 \f
 ;;;; translators for compiler-magic special forms
@@ -643,7 +646,7 @@ form to reference any of the previous VARS."
       (multiple-value-bind (forms decls)
           (parse-body body :doc-string-allowed nil)
         (multiple-value-bind (vars values) (extract-let-vars bindings 'let*)
-          (processing-decls (decls vars nil start next post-binding-lexenv)
+          (processing-decls (decls vars nil next result post-binding-lexenv)
             (ir1-convert-aux-bindings start
                                       next
                                       result
@@ -743,6 +746,7 @@ lexically apparent function definition in the enclosing environment."
       (let ((fvars (mapcar (lambda (n d)
                              (ir1-convert-lambda d
                                                  :source-name n
+                                                 :maybe-add-debug-catch t
                                                  :debug-name (debug-name 'flet n)))
                            names defs)))
         (processing-decls (decls nil fvars next result)
@@ -777,6 +781,7 @@ other."
                 (mapcar (lambda (name def)
                           (ir1-convert-lambda def
                                               :source-name name
+                                              :maybe-add-debug-catch t
                                               :debug-name (debug-name 'labels name)))
                         names defs))))
 
@@ -864,7 +869,7 @@ other."
              (when (lambda-var-p leaf)
                (let ((home-lambda (ctran-home-lambda-or-null start)))
                  (when home-lambda
-                   (pushnew leaf (lambda-calls-or-closes home-lambda))))
+                   (sset-adjoin leaf (lambda-calls-or-closes home-lambda))))
                (when (lambda-var-ignorep leaf)
                  ;; ANSI's definition of "Declaration IGNORE, IGNORABLE"
                  ;; requires that this be a STYLE-WARNING, not a full warning.
@@ -1005,7 +1010,9 @@ due to normal completion or a non-local exit such as THROW)."
   (ir1-convert
    start next result
    (with-unique-names (cleanup-fun drop-thru-tag exit-tag next start count)
-     `(flet ((,cleanup-fun () ,@cleanup nil))
+     `(flet ((,cleanup-fun ()
+               ,@cleanup
+               nil))
         ;; FIXME: If we ever get DYNAMIC-EXTENT working, then
         ;; ,CLEANUP-FUN should probably be declared DYNAMIC-EXTENT,
         ;; and something can be done to make %ESCAPE-FUN have