Remove top-marked? optimization from psyntax

* module/ice-9/psyntax.scm (strip): It used to be that terms in the
source program could have a "top" mark, and when stripping marks we'd
stop recursing when we see an expression with the top mark.  This had
the good effect that source programs could contain quoted syntax
objects, or quoted objects with shared structure -- in theory anyway.
In practice the compiler didn't support objects with shared structure.
Anyway when we switch to "read-syntax", quoted expressions can contain
syntax objects introduced by the reader, which naturally we would want
to strip away in a (quote FOO) form.  Therefore we remove the
top-marked? optimization.

2 files changed, 135 insertions, 192 deletions

diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index b23572a67..8efd082f1 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -523,15 +523,17 @@
          (and (not (null? list))
               (or (bound-id=? x (car list)) (bound-id-member? x (cdr list))))))
      (wrap (lambda (x w defmod) (source-wrap x w #f defmod)))
+     (wrap-syntax
+       (lambda (x w)
+         (make-syntax
+           (syntax-expression x)
+           w
+           (syntax-module x)
+           (syntax-source x))))
      (source-wrap
        (lambda (x w s defmod)
          (cond ((and (null? (car w)) (null? (cdr w)) (not s)) x)
-               ((syntax? x)
-                (make-syntax
-                  (syntax-expression x)
-                  (join-wraps w (syntax-wrap x))
-                  (syntax-module x)
-                  (syntax-source x)))
+               ((syntax? x) (wrap-syntax x (join-wraps w (syntax-wrap x))))
                ((null? x) x)
                (else (make-syntax x w defmod (or s (source-properties x)))))))
      (expand-sequence
@@ -712,7 +714,7 @@
                    e)))))
      (parse-when-list
        (lambda (e when-list)
-         (let ((result (strip when-list '(()))))
+         (let ((result (strip when-list)))
            (let lp ((l result))
              (cond ((null? l) result)
                    ((memq (car l) '(compile load eval expand)) (lp (cdr l)))
@@ -885,8 +887,7 @@
                         #f
                         "source expression failed to match any pattern"
                         tmp-1))))
-                 ((memv key '(constant))
-                  (build-data s (strip (source-wrap e w s mod) '(()))))
+                 ((memv key '(constant)) (build-data s (strip e)))
                  ((memv key '(global)) (build-global-reference s value mod))
                  ((memv key '(call))
                   (expand-call (expand (car e) r w mod) e r w s mod))
@@ -965,17 +966,11 @@
                        (let ((w (syntax-wrap x)))
                          (let ((ms (car w)) (ss (cdr w)))
                            (if (and (pair? ms) (eq? (car ms) #f))
-                             (make-syntax
-                               (syntax-expression x)
-                               (cons (cdr ms) (if rib (cons rib (cdr ss)) (cdr ss)))
-                               (syntax-module x)
-                               (syntax-source x))
-                             (make-syntax
-                               (decorate-source (syntax-expression x) s)
+                             (wrap-syntax x (cons (cdr ms) (if rib (cons rib (cdr ss)) (cdr ss))))
+                             (wrap-syntax
+                               x
                                (cons (cons m ms)
-                                     (if rib (cons rib (cons 'shift ss)) (cons 'shift ss)))
-                               (syntax-module x)
-                               (syntax-source x))))))
+                                     (if rib (cons rib (cons 'shift ss)) (cons 'shift ss))))))))
                       ((vector? x)
                        (let* ((n (vector-length x)) (v (decorate-source (make-vector n) s)))
                          (let loop ((i 0))
@@ -991,11 +986,11 @@
                          (source-wrap e w (cdr w) mod)
                          x))
                       (else (decorate-source x s))))))
-           (let* ((t-680b775fb37a463-d88 transformer-environment)
-                  (t-680b775fb37a463-d89 (lambda (k) (k e r w s rib mod))))
+           (let* ((t-680b775fb37a463-d7b transformer-environment)
+                  (t-680b775fb37a463-d7c (lambda (k) (k e r w s rib mod))))
              (with-fluid*
-               t-680b775fb37a463-d88
-               t-680b775fb37a463-d89
+               t-680b775fb37a463-d7b
+               t-680b775fb37a463-d7c
                (lambda ()
                  (rebuild-macro-output
                    (p (source-wrap e (anti-mark w) s mod))
@@ -1562,11 +1557,11 @@
                                           s
                                           mod
                                           get-formals
-                                          (map (lambda (tmp-680b775fb37a463-ff9
-                                                        tmp-680b775fb37a463-ff8
-                                                        tmp-680b775fb37a463-ff7)
-                                                 (cons tmp-680b775fb37a463-ff7
-                                                       (cons tmp-680b775fb37a463-ff8 tmp-680b775fb37a463-ff9)))
+                                          (map (lambda (tmp-680b775fb37a463-fec
+                                                        tmp-680b775fb37a463-feb
+                                                        tmp-680b775fb37a463-fea)
+                                                 (cons tmp-680b775fb37a463-fea
+                                                       (cons tmp-680b775fb37a463-feb tmp-680b775fb37a463-fec)))
                                                e2*
                                                e1*
                                                args*)))
@@ -1579,21 +1574,20 @@
                      #f
                      "source expression failed to match any pattern"
                      tmp))))))))
-     (strip (lambda (x w)
-              (if (memq 'top (car w))
-                x
-                (let f ((x x))
-                  (cond ((syntax? x) (strip (syntax-expression x) (syntax-wrap x)))
-                        ((pair? x)
-                         (let ((a (f (car x))) (d (f (cdr x))))
-                           (if (and (eq? a (car x)) (eq? d (cdr x))) x (cons a d))))
-                        ((vector? x)
-                         (let* ((old (vector->list x)) (new (map f old)))
-                           (let lp ((l1 old) (l2 new))
-                             (cond ((null? l1) x)
-                                   ((eq? (car l1) (car l2)) (lp (cdr l1) (cdr l2)))
-                                   (else (list->vector new))))))
-                        (else x))))))
+     (strip (lambda (x)
+              (letrec*
+                ((annotate
+                   (lambda (proc datum)
+                     (let ((src (proc x)))
+                       (if (and (pair? src) (supports-source-properties? datum))
+                         (set-source-properties! datum src))
+                       datum))))
+                (cond ((syntax? x) (annotate syntax-source (strip (syntax-expression x))))
+                      ((pair? x)
+                       (annotate source-properties (cons (strip (car x)) (strip (cdr x)))))
+                      ((vector? x)
+                       (annotate source-properties (list->vector (strip (vector->list x)))))
+                      (else x)))))
      (gen-var
        (lambda (id)
          (let ((id (if (syntax? id) (syntax-expression id) id)))
@@ -1659,7 +1653,7 @@
       (lambda (e r w s mod)
         (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ any))))
           (if tmp
-            (apply (lambda (e) (build-data s (strip e w))) tmp)
+            (apply (lambda (e) (build-data s (strip e))) tmp)
             (syntax-violation 'quote "bad syntax" (source-wrap e w s mod))))))
     (global-extend
       'core
@@ -1872,11 +1866,9 @@
               (apply (lambda (args e1 e2)
                        (build-it
                          '()
-                         (map (lambda (tmp-680b775fb37a463-6a0
-                                       tmp-680b775fb37a463-69f
-                                       tmp-680b775fb37a463-69e)
-                                (cons tmp-680b775fb37a463-69e
-                                      (cons tmp-680b775fb37a463-69f tmp-680b775fb37a463-6a0)))
+                         (map (lambda (tmp-680b775fb37a463-1 tmp-680b775fb37a463 tmp-680b775fb37a463-68f)
+                                (cons tmp-680b775fb37a463-68f
+                                      (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1)))
                               e2
                               e1
                               args)))
@@ -1888,11 +1880,11 @@
                   (apply (lambda (docstring args e1 e2)
                            (build-it
                              (list (cons 'documentation (syntax->datum docstring)))
-                             (map (lambda (tmp-680b775fb37a463-6b6
-                                           tmp-680b775fb37a463-6b5
-                                           tmp-680b775fb37a463-6b4)
-                                    (cons tmp-680b775fb37a463-6b4
-                                          (cons tmp-680b775fb37a463-6b5 tmp-680b775fb37a463-6b6)))
+                             (map (lambda (tmp-680b775fb37a463-6a7
+                                           tmp-680b775fb37a463-6a6
+                                           tmp-680b775fb37a463-6a5)
+                                    (cons tmp-680b775fb37a463-6a5
+                                          (cons tmp-680b775fb37a463-6a6 tmp-680b775fb37a463-6a7)))
                                   e2
                                   e1
                                   args)))
@@ -1915,9 +1907,9 @@
               (apply (lambda (args e1 e2)
                        (build-it
                          '()
-                         (map (lambda (tmp-680b775fb37a463-66a tmp-680b775fb37a463-1 tmp-680b775fb37a463)
+                         (map (lambda (tmp-680b775fb37a463-65b tmp-680b775fb37a463-65a tmp-680b775fb37a463)
                                 (cons tmp-680b775fb37a463
-                                      (cons tmp-680b775fb37a463-1 tmp-680b775fb37a463-66a)))
+                                      (cons tmp-680b775fb37a463-65a tmp-680b775fb37a463-65b)))
                               e2
                               e1
                               args)))
@@ -1929,9 +1921,9 @@
                   (apply (lambda (docstring args e1 e2)
                            (build-it
                              (list (cons 'documentation (syntax->datum docstring)))
-                             (map (lambda (tmp-680b775fb37a463 tmp-680b775fb37a463-67f tmp-680b775fb37a463-67e)
-                                    (cons tmp-680b775fb37a463-67e
-                                          (cons tmp-680b775fb37a463-67f tmp-680b775fb37a463)))
+                             (map (lambda (tmp-680b775fb37a463-1 tmp-680b775fb37a463 tmp-680b775fb37a463-66f)
+                                    (cons tmp-680b775fb37a463-66f
+                                          (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1)))
                                   e2
                                   e1
                                   args)))
@@ -2285,7 +2277,7 @@
                                                         (lambda () (cvt x n ids))
                                                         (lambda (p ids) (values (vector 'vector p) ids))))
                                                     tmp-1)
-                                             (let ((x tmp)) (values (vector 'atom (strip p '(()))) ids))))))))))))))))
+                                             (let ((x tmp)) (values (vector 'atom (strip p)) ids))))))))))))))))
                (cvt pattern 0 '()))))
          (build-dispatch-call
            (lambda (pvars exp y r mod)
@@ -2439,7 +2431,7 @@
           (cond ((not source) (source-properties datum))
                 ((and (list? source) (and-map pair? source)) source)
                 (else (syntax-source source))))))
-    (set! syntax->datum (lambda (x) (strip x '(()))))
+    (set! syntax->datum (lambda (x) (strip x)))
     (set! generate-temporaries
       (lambda (ls)
         (let ((x ls))
@@ -2477,8 +2469,8 @@
                who
                message
                (or (source-annotation subform) (source-annotation form))
-               (strip form '(()))
-               (and subform (strip subform '(()))))))
+               (strip form)
+               (strip subform))))
     (letrec*
       ((%syntax-module
          (lambda (id)
@@ -2525,11 +2517,7 @@
                              ((memv key '(ellipsis))
                               (values
                                 'ellipsis
-                                (make-syntax
-                                  (syntax-expression value)
-                                  (anti-mark (syntax-wrap value))
-                                  (syntax-module value)
-                                  (syntax-source value))))
+                                (wrap-syntax value (anti-mark (syntax-wrap value)))))
                              (else (values 'other #f)))))))))))
        (syntax-locally-bound-identifiers
          (lambda (id)
@@ -2644,7 +2632,7 @@
                                     (if (null? xr*) (match-empty (vector-ref p 1) r) (combine xr* r))))))
                           ((memv key '(free-id))
                            (and (id? e) (free-id=? (wrap e w mod) (vector-ref p 1)) r))
-                          ((memv key '(atom)) (and (equal? (vector-ref p 1) (strip e w)) r))
+                          ((memv key '(atom)) (and (equal? (vector-ref p 1) (strip e)) r))
                           ((memv key '(vector))
                            (and (vector? e) (match (vector->list e) (vector-ref p 1) w r mod)))))))))
        (match (lambda (e p w r mod)
@@ -2847,9 +2835,11 @@
                            #f
                            k
                            '()
-                           (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
-                                  (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1)
-                                        tmp-680b775fb37a463-2))
+                           (map (lambda (tmp-680b775fb37a463-110c
+                                         tmp-680b775fb37a463-110b
+                                         tmp-680b775fb37a463-110a)
+                                  (list (cons tmp-680b775fb37a463-110a tmp-680b775fb37a463-110b)
+                                        tmp-680b775fb37a463-110c))
                                 template
                                 pattern
                                 keyword)))
@@ -2865,11 +2855,9 @@
                                #f
                                k
                                (list docstring)
-                               (map (lambda (tmp-680b775fb37a463-113f
-                                             tmp-680b775fb37a463-113e
-                                             tmp-680b775fb37a463-113d)
-                                      (list (cons tmp-680b775fb37a463-113d tmp-680b775fb37a463-113e)
-                                            tmp-680b775fb37a463-113f))
+                               (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
+                                      (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1)
+                                            tmp-680b775fb37a463-2))
                                     template
                                     pattern
                                     keyword)))
@@ -2884,9 +2872,11 @@
                                    dots
                                    k
                                    '()
-                                   (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
-                                          (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1)
-                                                tmp-680b775fb37a463-2))
+                                   (map (lambda (tmp-680b775fb37a463-113e
+                                                 tmp-680b775fb37a463-113d
+                                                 tmp-680b775fb37a463-113c)
+                                          (list (cons tmp-680b775fb37a463-113c tmp-680b775fb37a463-113d)
+                                                tmp-680b775fb37a463-113e))
                                         template
                                         pattern
                                         keyword)))
@@ -2902,9 +2892,11 @@
                                        dots
                                        k
                                        (list docstring)
-                                       (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
-                                              (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1)
-                                                    tmp-680b775fb37a463-2))
+                                       (map (lambda (tmp-680b775fb37a463-115d
+                                                     tmp-680b775fb37a463-115c
+                                                     tmp-680b775fb37a463-115b)
+                                              (list (cons tmp-680b775fb37a463-115b tmp-680b775fb37a463-115c)
+                                                    tmp-680b775fb37a463-115d))
                                             template
                                             pattern
                                             keyword)))
@@ -3052,8 +3044,8 @@
                                                (apply (lambda (p)
                                                         (if (= lev 0)
                                                           (quasilist*
-                                                            (map (lambda (tmp-680b775fb37a463)
-                                                                   (list "value" tmp-680b775fb37a463))
+                                                            (map (lambda (tmp-680b775fb37a463-120d)
+                                                                   (list "value" tmp-680b775fb37a463-120d))
                                                                  p)
                                                             (quasi q lev))
                                                           (quasicons
@@ -3076,8 +3068,8 @@
                                                    (apply (lambda (p)
                                                             (if (= lev 0)
                                                               (quasiappend
-                                                                (map (lambda (tmp-680b775fb37a463-122c)
-                                                                       (list "value" tmp-680b775fb37a463-122c))
+                                                                (map (lambda (tmp-680b775fb37a463)
+                                                                       (list "value" tmp-680b775fb37a463))
                                                                      p)
                                                                 (quasi q lev))
                                                               (quasicons
@@ -3130,8 +3122,8 @@
                                       (apply (lambda (p)
                                                (if (= lev 0)
                                                  (quasiappend
-                                                   (map (lambda (tmp-680b775fb37a463)
-                                                          (list "value" tmp-680b775fb37a463))
+                                                   (map (lambda (tmp-680b775fb37a463-122d)
+                                                          (list "value" tmp-680b775fb37a463-122d))
                                                         p)
                                                    (vquasi q lev))
                                                  (quasicons
@@ -3231,8 +3223,7 @@
                        (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") each-any))))
                          (if tmp-1
                            (apply (lambda (y)
-                                    (k (map (lambda (tmp-680b775fb37a463-129c)
-                                              (list "quote" tmp-680b775fb37a463-129c))
+                                    (k (map (lambda (tmp-680b775fb37a463) (list "quote" tmp-680b775fb37a463))
                                             y)))
                                   tmp-1)
                            (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . each-any))))
@@ -3243,8 +3234,8 @@
                                    (apply (lambda (y z) (f z (lambda (ls) (k (append y ls))))) tmp-1)
                                    (let ((else tmp))
                                      (let ((tmp x))
-                                       (let ((t-680b775fb37a463-12ab tmp))
-                                         (list "list->vector" t-680b775fb37a463-12ab)))))))))))))))))
+                                       (let ((t-680b775fb37a463 tmp))
+                                         (list "list->vector" t-680b775fb37a463)))))))))))))))))
          (emit (lambda (x)
                  (let ((tmp x))
                    (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any))))
@@ -3257,9 +3248,9 @@
                                     (let ((tmp-1 (map emit x)))
                                       (let ((tmp ($sc-dispatch tmp-1 'each-any)))
                                         (if tmp
-                                          (apply (lambda (t-680b775fb37a463-12ba)
+                                          (apply (lambda (t-680b775fb37a463-12a0)
                                                    (cons (make-syntax 'list '((top)) '(hygiene guile))
-                                                         t-680b775fb37a463-12ba))
+                                                         t-680b775fb37a463-12a0))
                                                  tmp)
                                           (syntax-violation
                                             #f
@@ -3275,10 +3266,10 @@
                                             (let ((tmp-1 (list (emit (car x*)) (f (cdr x*)))))
                                               (let ((tmp ($sc-dispatch tmp-1 '(any any))))
                                                 (if tmp
-                                                  (apply (lambda (t-680b775fb37a463-12ce t-680b775fb37a463-12cd)
+                                                  (apply (lambda (t-680b775fb37a463-12b4 t-680b775fb37a463-12b3)
                                                            (list (make-syntax 'cons '((top)) '(hygiene guile))
-                                                                 t-680b775fb37a463-12ce
-                                                                 t-680b775fb37a463-12cd))
+                                                                 t-680b775fb37a463-12b4
+                                                                 t-680b775fb37a463-12b3))
                                                          tmp)
                                                   (syntax-violation
                                                     #f
@@ -3291,9 +3282,9 @@
                                             (let ((tmp-1 (map emit x)))
                                               (let ((tmp ($sc-dispatch tmp-1 'each-any)))
                                                 (if tmp
-                                                  (apply (lambda (t-680b775fb37a463-12da)
+                                                  (apply (lambda (t-680b775fb37a463-12c0)
                                                            (cons (make-syntax 'append '((top)) '(hygiene guile))
-                                                                 t-680b775fb37a463-12da))
+                                                                 t-680b775fb37a463-12c0))
                                                          tmp)
                                                   (syntax-violation
                                                     #f
@@ -3306,9 +3297,9 @@
                                                 (let ((tmp-1 (map emit x)))
                                                   (let ((tmp ($sc-dispatch tmp-1 'each-any)))
                                                     (if tmp
-                                                      (apply (lambda (t-680b775fb37a463-12e6)
+                                                      (apply (lambda (t-680b775fb37a463-12cc)
                                                                (cons (make-syntax 'vector '((top)) '(hygiene guile))
-                                                                     t-680b775fb37a463-12e6))
+                                                                     t-680b775fb37a463-12cc))
                                                              tmp)
                                                       (syntax-violation
                                                         #f
@@ -3319,9 +3310,9 @@
                                          (if tmp-1
                                            (apply (lambda (x)
                                                     (let ((tmp (emit x)))
-                                                      (let ((t-680b775fb37a463-12f2 tmp))
+                                                      (let ((t-680b775fb37a463-12d8 tmp))
                                                         (list (make-syntax 'list->vector '((top)) '(hygiene guile))
-                                                              t-680b775fb37a463-12f2))))
+                                                              t-680b775fb37a463-12d8))))
                                                   tmp-1)
                                            (let ((tmp-1 ($sc-dispatch tmp '(#(atom "value") any))))
                                              (if tmp-1
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 430ba3199..aa13215c2 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -98,33 +98,6 @@
 ;;; compiled.  In this way, psyntax bootstraps off of an expanded
 ;;; version of itself.
 
-;;; This implementation of the expander sometimes uses syntactic
-;;; abstractions when procedural abstractions would suffice.  For
-;;; example, we define top-wrap and top-marked? as
-;;;
-;;;   (define-syntax top-wrap (identifier-syntax '((top))))
-;;;   (define-syntax top-marked?
-;;;     (syntax-rules ()
-;;;       ((_ w) (memq 'top (wrap-marks w)))))
-;;;
-;;; rather than
-;;;
-;;;   (define top-wrap '((top)))
-;;;   (define top-marked?
-;;;     (lambda (w) (memq 'top (wrap-marks w))))
-;;;
-;;; On the other hand, we don't do this consistently; we define
-;;; make-wrap, wrap-marks, and wrap-subst simply as
-;;;
-;;;   (define make-wrap cons)
-;;;   (define wrap-marks car)
-;;;   (define wrap-subst cdr)
-;;;
-;;; In Chez Scheme, the syntactic and procedural forms of these
-;;; abstractions are equivalent, since the optimizer consistently
-;;; integrates constants and small procedures.  This will be true of
-;;; Guile as well, once we implement a proper inliner.
-
 
 ;;; Implementation notes:
 
@@ -626,12 +599,8 @@
     (define-structure (ribcage symnames marks labels))
 
     (define-syntax empty-wrap (identifier-syntax '(())))
-
     (define-syntax top-wrap (identifier-syntax '((top))))
 
-    (define-syntax-rule (top-marked? w)
-      (memq 'top (wrap-marks w)))
-
     ;; Marks must be comparable with "eq?" and distinct from pairs and
     ;; the symbol top.  We do not use integers so that marks will remain
     ;; unique even across file compiles.
@@ -1043,15 +1012,16 @@
       (lambda (x w defmod)
         (source-wrap x w #f defmod)))
 
+    (define (wrap-syntax x w)
+      (make-syntax (syntax-expression x)
+                   w
+                   (syntax-module x)
+                   (syntax-source x)))
     (define source-wrap
       (lambda (x w s defmod)
         (cond
          ((and (null? (wrap-marks w)) (null? (wrap-subst w)) (not s)) x)
-         ((syntax? x)
-          (make-syntax (syntax-expression x)
-                       (join-wraps w (syntax-wrap x))
-                       (syntax-module x)
-                       (syntax-source x)))
+         ((syntax? x) (wrap-syntax x (join-wraps w (syntax-wrap x))))
          ((null? x) x)
          (else (make-syntax x w defmod (or s (source-properties x)))))))
 
@@ -1265,7 +1235,7 @@
         ;; we twingle the definition of eval-when to the bindings of
         ;; eval, load, expand, and compile, which is totally unintended.
         ;; So do a symbolic match instead.
-        (let ((result (strip when-list empty-wrap)))
+        (let ((result (strip when-list)))
           (let lp ((l result))
             (if (null? l)
                 result
@@ -1451,7 +1421,7 @@
                               value
                               (map (lambda (e) (expand e r w mod))
                                    #'(e ...))))))
-          ((constant) (build-data s (strip (source-wrap e w s mod) empty-wrap)))
+          ((constant) (build-data s (strip e)))
           ((global) (build-global-reference s value mod))
           ((call) (expand-call (expand (car e) r w mod) e r w s mod))
           ((begin-form)
@@ -1535,20 +1505,19 @@
                      (let ((ms (wrap-marks w)) (ss (wrap-subst w)))
                        (if (and (pair? ms) (eq? (car ms) the-anti-mark))
                            ;; output is from original text
-                           (make-syntax
-                            (syntax-expression x)
-                            (make-wrap (cdr ms) (if rib (cons rib (cdr ss)) (cdr ss)))
-                            (syntax-module x)
-                            (syntax-source x))
+                           (wrap-syntax
+                            x
+                            (make-wrap (cdr ms)
+                                       (if rib
+                                           (cons rib (cdr ss))
+                                           (cdr ss))))
                            ;; output introduced by macro
-                           (make-syntax
-                            (decorate-source (syntax-expression x) s)
+                           (wrap-syntax
+                            x
                             (make-wrap (cons m ms)
                                        (if rib
                                            (cons rib (cons 'shift ss))
-                                           (cons 'shift ss)))
-                            (syntax-module x)
-                            (syntax-source x))))))
+                                           (cons 'shift ss))))))))
                 
                   ((vector? x)
                    (let* ((n (vector-length x))
@@ -2000,36 +1969,22 @@
 
     ;; data
 
-    ;; strips syntax objects down to top-wrap
-    ;;
-    ;; since only the head of a list is annotated by the reader, not each pair
-    ;; in the spine, we also check for pairs whose cars are annotated in case
-    ;; we've been passed the cdr of an annotated list
-
-    (define strip
-      (lambda (x w)
-        (if (top-marked? w)
-            x
-            (let f ((x x))
-              (cond
-               ((syntax? x)
-                (strip (syntax-expression x) (syntax-wrap x)))
-               ((pair? x)
-                (let ((a (f (car x))) (d (f (cdr x))))
-                  (if (and (eq? a (car x)) (eq? d (cdr x)))
-                      x
-                      (cons a d))))
-               ((vector? x)
-                (let ((old (vector->list x)))
-                  (let ((new (map f old)))
-                    ;; inlined and-map with two args
-                    (let lp ((l1 old) (l2 new))
-                      (if (null? l1)
-                          x
-                          (if (eq? (car l1) (car l2))
-                              (lp (cdr l1) (cdr l2))
-                              (list->vector new)))))))
-               (else x))))))
+    ;; strips syntax objects, recursively.
+
+    (define (strip x)
+      (define (annotate proc datum)
+        (let ((src (proc x)))
+          (when (and (pair? src) (supports-source-properties? datum))
+            (set-source-properties! datum src))
+          datum))
+      (cond
+       ((syntax? x)
+        (annotate syntax-source (strip (syntax-expression x))))
+       ((pair? x)
+        (annotate source-properties (cons (strip (car x)) (strip (cdr x)))))
+       ((vector? x)
+        (annotate source-properties (list->vector (strip (vector->list x)))))
+       (else x)))
 
     ;; lexical variables
 
@@ -2102,7 +2057,7 @@
     (global-extend 'core 'quote
                    (lambda (e r w s mod)
                      (syntax-case e ()
-                       ((_ e) (build-data s (strip #'e w)))
+                       ((_ e) (build-data s (strip #'e)))
                        (_ (syntax-violation 'quote "bad syntax"
                                             (source-wrap e w s mod))))))
 
@@ -2641,7 +2596,7 @@
                                     (call-with-values
                                         (lambda () (cvt (syntax (x ...)) n ids))
                                       (lambda (p ids) (values (vector 'vector p) ids))))
-                                   (x (values (vector 'atom (strip p empty-wrap)) ids))))))
+                                   (x (values (vector 'atom (strip p)) ids))))))
                          (cvt pattern 0 '())))
 
                      (define build-dispatch-call
@@ -2786,7 +2741,7 @@
           ;; accepts any object, since syntax objects may consist partially
           ;; or entirely of unwrapped, nonsymbolic data
           (lambda (x)
-            (strip x empty-wrap)))
+            (strip x)))
 
     (set! generate-temporaries
           (lambda (ls)
@@ -2816,8 +2771,8 @@
             (throw 'syntax-error who message
                    (or (source-annotation subform)
                        (source-annotation form))
-                   (strip form empty-wrap)
-                   (and subform (strip subform empty-wrap)))))
+                   (strip form)
+                   (strip subform))))
 
     (let ()
       (define (%syntax-module id)
@@ -2857,10 +2812,7 @@
                       (values 'global (cons value (cdr mod)))))
                  ((ellipsis)
                   (values 'ellipsis
-                          (make-syntax (syntax-expression value)
-                                       (anti-mark (syntax-wrap value))
-                                       (syntax-module value)
-                                       (syntax-source value))))
+                          (wrap-syntax value (anti-mark (syntax-wrap value)))))
                  (else (values 'other #f))))))))
 
       (define (syntax-locally-bound-identifiers id)
@@ -3010,7 +2962,7 @@
                             (match-empty (vector-ref p 1) r)
                             (combine xr* r))))))
               ((free-id) (and (id? e) (free-id=? (wrap e w mod) (vector-ref p 1)) r))
-              ((atom) (and (equal? (vector-ref p 1) (strip e w)) r))
+              ((atom) (and (equal? (vector-ref p 1) (strip e)) r))
               ((vector)
                (and (vector? e)
                     (match (vector->list e) (vector-ref p 1) w r mod))))))))