update bytecode tools for syntax-object source locations

compiler-lib/compiler/decompile.rkt

@@ -200,7 +200,7 @@
       (let ([p (mcons #f #f)])
         (hash-set! stx-ht stx p)
         (match stx
-          [(stx-obj datum wrap tamper-status)
+          [(stx-obj datum wrap srcloc props tamper-status)
            (set-mcar! p (case tamper-status
                           [(clean) 'wrap]
                           [(tainted) 'wrap-tainted]
@@ -223,7 +223,14 @@
                           [(box? datum)
                            (box (decompile-stx (unbox datum) stx-ht))]
                           [else datum])
-                         wrap))
+                         (let* ([l (mcons wrap null)]
+                                [l (if (hash-count props)
+                                       (mcons props l)
+                                       l)]
+                                [l (if srcloc
+                                       (mcons srcloc l)
+                                       l)])
+                           l)))
            p]))))
 
 (define (mpi->string modidx)

compiler-lib/compiler/demodularizer/nodep.rkt

@@ -197,13 +197,13 @@
          empty
          (begin
            (hash-set! REQUIRED ct #t)
-           (list (make-req (make-stx (make-stx-obj ct (wrap empty empty empty) 'clean)) (make-toplevel 0 0 #f #f)))))]
+           (list (make-req (make-stx (make-stx-obj ct (wrap empty empty empty) #f #hasheq() 'clean)) (make-toplevel 0 0 #f #f)))))]
     [(module-path-index? ct)
      (if (hash-has-key? REQUIRED ct)
          empty
          (begin
            (hash-set! REQUIRED ct #t)
-           (list (make-req (make-stx (make-stx-obj ct (wrap empty empty empty) 'clean)) (make-toplevel 0 0 #f #f)))))]
+           (list (make-req (make-stx (make-stx-obj ct (wrap empty empty empty) #f #hasheq() 'clean)) (make-toplevel 0 0 #f #f)))))]
     [(not ct)
      empty]
     [(@phase? ct)

zo-lib/compiler/zo-marshal.rkt

@@ -390,7 +390,7 @@
 
 (define (encode-stx-obj w out)
   (match w
-    [(struct stx-obj (datum wraps tamper-status))
+    [(struct stx-obj (datum wraps srcloc props tamper-status))
      (let* ([enc-datum
              (match datum
                [(cons a b)
@@ -424,12 +424,39 @@
                  (car l)
                  (map (lambda (e) (encode-stx-obj e out)) (cdr l)))]
                [_ datum])]
-            [p (cons enc-datum
+            [e-wraps (share-everywhere (encode-wrap wraps (out-wraps out)) out)]
-                     (share-everywhere (encode-wrap wraps (out-wraps out)) out))])
+            [esrcloc (let ()
-       (case tamper-status
+                       (define (avail? n) (n . >= . 0))
-         [(clean) p]
+                       (define (xvector a b c d e)
-         [(tainted) (vector p)]
+                         (case (hash-ref props 'paren-shape #f)
-         [(armed) (vector p #f)]))]))
+                           [(#\[) (vector a b c d e #\[)]
+                           [(#\{) (vector a b c d e #\{)]
+                           [else (if (or a (avail? b) (avail? c) (avail? d))
+                                     (vector a b c d e)
+                                     #f)]))
+                       (define (norm v) (or v -1))
+                       (share-everywhere
+                        (if srcloc
+                            (xvector (srcloc-source srcloc)
+                                     (norm (srcloc-line srcloc))
+                                     (norm (srcloc-column srcloc))
+                                     (norm (srcloc-position srcloc))
+                                     (norm (srcloc-span srcloc)))
+                            (xvector #f -1 -1 -1 -1))
+                        out))])
+       (cond
+        [esrcloc
+         (case tamper-status
+           [(tainted) (vector enc-datum e-wraps esrcloc 1)]
+           [(armed) (vector enc-datum e-wraps esrcloc 2)]
+           [else (vector enc-datum e-wraps esrcloc)])]
+        [(not (eq? tamper-status 'clean))
+         (vector enc-datum e-wraps 
+                 (case tamper-status
+                   [(tainted) 1]
+                   [(armed) 2]))]
+        [else
+         (cons enc-datum e-wraps)]))]))
 
 (define-struct out (s
                     ;; The output port for writing bytecode.
@@ -940,8 +967,41 @@
         (out-byte CPT_QUOTE out)
         (parameterize ([quoting? #t])
           (out-anything qv out))]
-       [(or (? path?) ; XXX Why not use CPT_PATH?
+       [(? path?)
-            (? regexp?)
+        (out-byte CPT_PATH out)
+        (define (within? p)
+          (and (relative-path? p)
+               (let loop ([p p])
+                 (define-values (base name dir?) (split-path p))
+                 (and (not (eq? name 'up))
+                      (not (eq? name 'same))
+                      (or (not (path? base))
+                          (loop base))))))
+        (define maybe-rel
+          (and (current-write-relative-directory)
+               (let ([dir (current-write-relative-directory)])
+                 (and (or (not dir)
+                          (within? (find-relative-path v
+                                                       (if (pair? dir)
+                                                           (cdr dir)
+                                                           dir))))
+                      (find-relative-path v
+                                          (if (pair? dir)
+                                              (car dir)
+                                              dir))))))
+        (cond
+         [(not maybe-rel)
+          (define bstr (path->bytes v))
+          (out-number (bytes-length bstr) out)
+          (out-bytes bstr out)]
+         [else
+          (out-number 0 out)
+          (out-anything (for/list ([e (in-list (explode-path maybe-rel))])
+                          (if (path? e)
+                              (path-element->bytes e)
+                              e))
+                        out)])]
+       [(or (? regexp?)
             (? byte-regexp?)
             (? number?)
             (? extflonum?))

zo-lib/compiler/zo-parse.rkt

@@ -600,14 +600,17 @@
 
 (define (decode-wrapped cp v)
   (let loop ([v v])
-    (let-values ([(tamper-status v encoded-wraps)
+    (let-values ([(tamper-status v encoded-wraps esrcloc)
                   (match v
-                    [`#((,datum . ,wraps)) (values 'tainted datum wraps)]
+                    [`#(,datum ,wraps 1) (values 'tainted datum wraps #f)]
-                    [`#((,datum . ,wraps) #f) (values 'armed datum wraps)]
+                    [`#(,datum ,wraps 2) (values 'armed datum wraps #f)]
-                    [`(,datum . ,wraps) (values 'clean datum wraps)]
+                    [`#(,datum ,wraps ,esrcloc 1) (values 'tainted datum wraps esrcloc)]
+                    [`#(,datum ,wraps ,esrcloc 2) (values 'armed datum wraps esrcloc)]
+                    [`#(,datum ,wraps ,esrcloc) (values 'clean datum wraps esrcloc)]
+                    [`(,datum . ,wraps) (values 'clean datum wraps #f)]
                     [else (error 'decode-wraps "bad datum+wrap: ~.s" v)])])
       (let* ([wrapped-memo (make-memo)]
-             [add-wrap (lambda (v) (with-memo wrapped-memo v (make-stx-obj v encoded-wraps tamper-status)))])
+             [add-wrap (lambda (v) (with-memo wrapped-memo v (make-stx-obj v encoded-wraps esrcloc #hasheq() tamper-status)))])
         (cond
          [(pair? v)
           (if (eq? #t (car v))
@@ -800,11 +803,15 @@
                 [flags (if (< p* 0) (read-compact-number cp) 0)])
            (make-local #t p flags))]
         [(path)
-         (let* ([p (bytes->path (read-compact-bytes cp (read-compact-number cp)))])
+         (let ([len (read-compact-number cp)])
-           (if (relative-path? p)
+           (if (zero? len)
-             (path->complete-path p (or (current-load-relative-directory)
+               ;; Read a list of byte strings as relative path elements:
-                                        (current-directory)))
+               (let ([p (or (current-load-relative-directory)
-             p))]
+                            (current-directory))])
+                 (for/fold ([p p]) ([e (in-list (read-compact cp))])
+                   (build-path p (if (bytes? e) (bytes->path-element e) e))))
+               ;; Read a path:
+               (bytes->path (read-compact-bytes cp len))))]
         [(small-number)
          (let ([l (- ch cpt-start)])
            l)]
@@ -1145,6 +1152,7 @@
   ;; We do this after building a graph from the input, and `decode-wrap`
   ;; preserves graph structure.
   (define decode-ht (make-hasheq))
+  (define srcloc-ht (make-hasheq))
   (let walk ([p v])
     (match p
       [(compilation-top _ pfx c)
@@ -1182,10 +1190,13 @@
       [(seq-for-syntax _ pfx _ _)
        (struct-copy seq-for-syntax p
                     [prefix (walk pfx)])]
-      [(stx-obj d w _)
+      [(stx-obj d w esrcloc _ _)
+       (define-values (srcloc props) (decode-srcloc+props esrcloc srcloc-ht))
        (struct-copy stx-obj p
                     [datum (walk d)]
-                    [wrap (decode-wrap w decode-ht)])]
+                    [wrap (decode-wrap w decode-ht)]
+                    [srcloc srcloc]
+                    [props props])]
       [(? zo?) p]
       ;; Generic constructors happen inside the `datum` of `stx-obj`,
       ;; for example (with no cycles):
@@ -1217,6 +1228,32 @@
 
 ;; ----------------------------------------
 
+(define (decode-srcloc+props esrcloc ht)
+  (define (norm v) (if (v . < . 0) #f v))
+  (define p
+    (hash-ref! ht
+               esrcloc
+               (lambda ()
+                 (cons (and esrcloc
+                            ;; We could reduce this srcloc to #f if
+                            ;; there's no source, line, column, or position
+                            ;; information, but we want to expose the actual
+                            ;; content of a bytecode stream:
+                            (srcloc (vector-ref esrcloc 0)
+                                    (norm (vector-ref esrcloc 1))
+                                    (norm (vector-ref esrcloc 2))
+                                    (norm (vector-ref esrcloc 3))
+                                    (norm (vector-ref esrcloc 4))))
+                       (if (and esrcloc ((vector-length esrcloc) . > . 5))
+                           (case (vector-ref esrcloc 5)
+                             [(#\[) #hasheq((paren-shape . #\[))]
+                             [(#\{) #hasheq((paren-shape . #\{))]
+                             [else #hasheq()])
+                           #hasheq())))))
+  (values (car p) (cdr p)))
+
+;; ----------------------------------------
+
 (define (decode-wrap encoded-wrap ht)
   (hash-ref! ht
              encoded-wrap
@@ -1307,7 +1344,7 @@
                  [(box (cons base-b (cons (cons sym wraps) phase)))
                   (free-id=?-binding
                    (decode-binding base-b ht)
-                   (stx-obj sym (decode-wrap wraps ht) 'clean)
+                   (stx-obj sym (decode-wrap wraps ht) #f #hasheq() 'clean)
                    phase)]
                  [(? symbol?)
                   (local-binding b)]

zo-lib/compiler/zo-structs.rkt

@@ -184,7 +184,9 @@
 (define-form-struct stx ([content stx-obj?]))
 
 (define-form-struct stx-obj ([datum any/c] ; S-expression with `wrapped` components
-                             [wrap any/c] ; shuold be `wrap?`, but encoded form appears initially
+                             [wrap any/c] ; should be `wrap?`, but encoded form appears initially
+                             [srcloc any/c] ; should be `(or/c #f srcloc?)`, but encoded form appears initially
+                             [props (hash/c symbol? any/c)]
                              [tamper-status (or/c 'clean 'armed 'tainted)]))
 
 (define-form-struct wrap ([shifts (listof module-shift?)]