improved handling of source locations

svn: r15132

collects/redex/private/bitmap-test.ss

@@ -92,6 +92,7 @@
         (render-metafunction Name))
       "metafunction-Name-vertical.png")
 
+
 ;; makes sure that there is no overlap inside or across metafunction calls  
 ;; or when there are unquotes involved
 (define-metafunction lang

collects/redex/private/core-layout.ss

@@ -457,7 +457,12 @@
            (set! current-line line)
            (set! current-column col))]
         [else
-         (error 'eject "lines going backwards")])
+         (error 'eject
+                "lines going backwards (current-line ~s line ~s atom ~s tokens ~s)" 
+                current-line
+                line
+                atom
+                tokens)])
       (when (< current-column col)
         (let ([space-span (- col current-column)])
           (set! tokens (cons (make-blank-space-token unquoted?

collects/redex/private/loc-wrapper-ct.ss

@@ -0,0 +1,96 @@
+#lang scheme/base
+(require (for-template scheme/base)
+         (for-template "loc-wrapper-rt.ss")
+         "term-fn.ss")
+(provide to-lw/proc to-lw/uq/proc)
+
+(define (process-arg stx quote-depth)
+  (define quoted? (quote-depth . > . 0))
+  (define-values (op cl)
+    (if (syntax? stx)
+        (case (syntax-property stx 'paren-shape)
+          [(#\{) (values "{" "}")]
+          [(#\[) (values "[" "]")]
+          [else (values "(" ")")])
+        (values #f #f)))
+  (define (reader-shorthand arg qd-delta mrk)
+    #`(init-loc-wrapper 
+       (list (init-loc-wrapper #,mrk
+                               #,(syntax-line stx)
+                               #,(syntax-column stx)
+                               #,quoted?)
+             'spring
+             #,(process-arg arg (+ quote-depth qd-delta)))
+       #,(syntax-line stx) 
+       #,(syntax-column stx)
+       #,quoted?))
+  (define (handle-sequence qd-delta)
+    #`(init-loc-wrapper 
+       (list (init-loc-wrapper #,op #,(syntax-line stx) #,(syntax-column stx) #,quoted?)
+             #,@(map (λ (x) (process-arg x (+ qd-delta quote-depth))) (syntax->list stx))
+             (init-loc-wrapper #,cl #f #f #,quoted?))
+       #,(syntax-line stx) 
+       #,(syntax-column stx)
+       #,quoted?))
+  (syntax-case* stx (name unquote quote unquote-splicing term) (λ (x y) (eq? (syntax-e x) (syntax-e y)))
+    ['a (reader-shorthand #'a +1 (if (= quote-depth 0) "" "'"))]
+    [,a (reader-shorthand #'a -1 (if (= quote-depth 1) "" ","))]
+    [,@a (reader-shorthand #'a -1 (if (= quote-depth 1) "" ",@"))]
+    [(term a)
+     (if (= quote-depth 0)
+         #`(init-loc-wrapper 
+            (list (init-loc-wrapper "" #,(syntax-line stx) #,(syntax-column stx) #,quoted?)
+                  'spring
+                  #,(process-arg (cadr (syntax->list stx)) (+ quote-depth 1)))
+            #,(syntax-line stx) 
+            #,(syntax-column stx)
+            #,quoted?)
+         (handle-sequence +1))]
+    [(a ...)
+     (handle-sequence 0)]
+    [(a b ... . c)
+     #`(init-loc-wrapper 
+        (list (init-loc-wrapper #,op #,(syntax-line stx) #,(syntax-column stx) #,quoted?)
+              #,@(map (λ (x) (process-arg x quote-depth)) (syntax->list (syntax (a b ...))))
+              (init-loc-wrapper #," . " #f #f #,quoted?)
+              #,(process-arg #'c quote-depth)
+              (init-loc-wrapper #,cl #f #f #,quoted?))
+        #,(syntax-line stx) 
+        #,(syntax-column stx)
+        #,quoted?)]
+    [x 
+     (and (identifier? #'x)
+          (term-fn? (syntax-local-value #'x (λ () #f))))
+     #`(make-lw
+        '#,(syntax-e #'x)
+        #,(syntax-line stx) 
+        #f
+        #,(syntax-column stx)
+        #f
+        #f
+        #t)]
+    [x 
+     (identifier? #'x)
+     #`(init-loc-wrapper 
+        '#,(syntax-e #'x)
+        #,(syntax-line stx) 
+        #,(syntax-column stx)
+        #,quoted?)]
+    [x 
+     #`(init-loc-wrapper 
+        #,(let ([base (syntax-e #'x)])
+            (if (string? base)
+                #`(rewrite-quotes #,(format "~s" base))
+                (format "~s" (syntax-e #'x))))
+        #,(syntax-line stx) 
+        #,(syntax-column stx)
+        #,quoted?)]))
+
+(define (to-lw/proc stx)
+  (syntax-case stx ()
+    [(_ stx)
+     #`(add-spans #,(process-arg #'stx 1))]))
+(define (to-lw/uq/proc stx)
+  (syntax-case stx ()
+    [(_ stx)
+     #`(add-spans #,(process-arg #'stx 0))]))

collects/redex/private/loc-wrapper-rt.ss

@@ -0,0 +1,96 @@
+#lang scheme/base
+
+;; this is the runtime code for loc-wrapper-ct.ss.
+;; it isn't really its own module, but separated
+;; out in order to get the phases right.
+(provide (all-defined-out))
+
+(require (lib "etc.ss")
+         "term.ss")
+
+(define (init-loc-wrapper e line column quoted?)
+  (make-lw e line #f column #f (not quoted?) #f))
+
+;; lw = (union 'spring loc-wrapper)
+
+;; e : (union string symbol #f (listof lw))
+;; line, line-span, column, column-span : number
+(define-struct lw (e line line-span column column-span unq? metafunction?) 
+  #:mutable
+  #:inspector (make-inspector))
+
+;; build-lw is designed for external consumption
+(define (build-lw e line line-span column column-span)
+  (make-lw e line line-span column column-span #f #f))
+
+(define curly-quotes-for-strings (make-parameter #t))
+
+(define (rewrite-quotes s)
+  (if (curly-quotes-for-strings)
+      (string-append "“"
+                     (substring s 1 (- (string-length s) 1))
+                     "”")
+      s))
+
+
+(define (add-spans lw)
+  (define line-seen-so-far 0)
+  
+  (define (add-spans/lw lw line col)
+    (cond
+      [(eq? lw 'spring) (values line col col)]
+      [else
+       (let ([start-line (or (lw-line lw) line line-seen-so-far)]
+             [start-column (or (lw-column lw) col 0)])
+         (set! line-seen-so-far (max line-seen-so-far start-line))
+         (unless (lw-line lw) (set-lw-line! lw line-seen-so-far))
+         (unless (lw-column lw) (set-lw-column! lw start-column))
+         (let-values ([(last-line first-column last-column)
+                       (add-spans/obj (lw-e lw) start-line start-column)])
+           (set-lw-line-span! lw (- last-line start-line))
+           (let ([new-col (min/f (lw-column lw)
+                                 first-column)])
+             (set-lw-column! lw new-col)
+             (set-lw-column-span! lw (- last-column new-col)))
+           (values last-line first-column last-column)))]))
+  (define (add-spans/obj e line col)
+    (cond
+      [(string? e) 
+       (values line col (+ col (string-length e)))]
+      [(symbol? e)
+       (values line col (+ col (string-length (symbol->string e))))]
+      [(not e) (values line col col)]
+      [else 
+       (let loop ([lws e]
+                  [line line]
+                  [first-column col]
+                  [last-column col]
+                  [current-col col])
+         (cond
+           [(null? lws) (values line first-column last-column)]
+           [else 
+            (let-values ([(last-line inner-first-column inner-last-column)
+                          (add-spans/lw (car lws) line current-col)])
+              (if (= last-line line)
+                  (loop (cdr lws)
+                        last-line
+                        (min inner-first-column first-column)
+                        (max inner-last-column last-column)
+                        inner-last-column)
+                  (loop (cdr lws)
+                        last-line
+                        (min inner-first-column first-column)
+                        inner-last-column
+                        inner-last-column)))]))]))
+  
+  (add-spans/lw lw #f #f)
+  lw)
+
+(define (min/f a b)
+  (cond
+    [(and a b) (min a b)]
+    [a a]
+    [b b]
+    [else 0]))
+
+

collects/redex/private/loc-wrapper.ss

@@ -1,181 +1,12 @@
 #lang scheme/base
 
-(require (lib "etc.ss")
+(require scheme/contract
-         "term.ss"
+         (for-syntax scheme/base)
-         scheme/contract)
+         (for-syntax "loc-wrapper-ct.ss")
-(require (for-syntax "term-fn.ss" scheme/base))
+         "loc-wrapper-rt.ss")
 
-(define (init-loc-wrapper e line column quoted?)
+(define-syntax (to-lw stx) (to-lw/proc stx))
-  (make-lw e line #f column #f (not quoted?) #f))
+(define-syntax (to-lw/uq stx) (to-lw/uq/proc stx))
-
-;; lw = (union 'spring loc-wrapper)
-
-;; e : (union string symbol #f (listof lw))
-;; line, line-span, column, column-span : number
-(define-struct lw (e line line-span column column-span unq? metafunction?) 
-  #:mutable
-  #:inspector (make-inspector))
-
-;; build-lw is designed for external consumption
-(define (build-lw e line line-span column column-span)
-  (make-lw e line line-span column column-span #f #f))
-
-(define curly-quotes-for-strings (make-parameter #t))
-
-(define (rewrite-quotes s)
-  (if (curly-quotes-for-strings)
-      (string-append "“"
-                     (substring s 1 (- (string-length s) 1))
-                     "”")
-      s))
-
-(define-syntax-set (to-lw to-lw/uq)
-  (define (process-arg stx quote-depth)
-    (define quoted? (quote-depth . > . 0))
-    (define-values (op cl)
-      (if (syntax? stx)
-          (case (syntax-property stx 'paren-shape)
-            [(#\{) (values "{" "}")]
-            [(#\[) (values "[" "]")]
-            [else (values "(" ")")])
-          (values #f #f)))
-    (define (reader-shorthand arg qd-delta mrk)
-      #`(init-loc-wrapper 
-         (list (init-loc-wrapper #,mrk
-                                 #,(syntax-line stx)
-                                 #,(syntax-column stx)
-                                 #,quoted?)
-               'spring
-               #,(process-arg arg (+ quote-depth qd-delta)))
-         #,(syntax-line stx) 
-         #,(syntax-column stx)
-         #,quoted?))
-    (define (handle-sequence qd-delta)
-      #`(init-loc-wrapper 
-         (list (init-loc-wrapper #,op #,(syntax-line stx) #,(syntax-column stx) #,quoted?)
-               #,@(map (λ (x) (process-arg x (+ qd-delta quote-depth))) (syntax->list stx))
-               (init-loc-wrapper #,cl #f #f #,quoted?))
-         #,(syntax-line stx) 
-         #,(syntax-column stx)
-         #,quoted?))
-    (syntax-case* stx (name unquote quote unquote-splicing term) (λ (x y) (eq? (syntax-e x) (syntax-e y)))
-      ['a (reader-shorthand #'a +1 (if (= quote-depth 0) "" "'"))]
-      [,a (reader-shorthand #'a -1 (if (= quote-depth 1) "" ","))]
-      [,@a (reader-shorthand #'a -1 (if (= quote-depth 1) "" ",@"))]
-      [(term a)
-       (if (= quote-depth 0)
-           #`(init-loc-wrapper 
-              (list (init-loc-wrapper "" #,(syntax-line stx) #,(syntax-column stx) #,quoted?)
-                    'spring
-                    #,(process-arg (cadr (syntax->list stx)) (+ quote-depth 1)))
-              #,(syntax-line stx) 
-              #,(syntax-column stx)
-              #,quoted?)
-           (handle-sequence +1))]
-      [(a ...)
-       (handle-sequence 0)]
-      [(a b ... . c)
-       #`(init-loc-wrapper 
-          (list (init-loc-wrapper #,op #,(syntax-line stx) #,(syntax-column stx) #,quoted?)
-                #,@(map (λ (x) (process-arg x quote-depth)) (syntax->list (syntax (a b ...))))
-                (init-loc-wrapper #," . " #f #f #,quoted?)
-                #,(process-arg #'c quote-depth)
-                (init-loc-wrapper #,cl #f #f #,quoted?))
-          #,(syntax-line stx) 
-          #,(syntax-column stx)
-          #,quoted?)]
-      [x 
-       (and (identifier? #'x)
-            (term-fn? (syntax-local-value #'x (λ () #f))))
-       #`(make-lw
-          '#,(syntax-e #'x)
-          #,(syntax-line stx) 
-          #f
-          #,(syntax-column stx)
-          #f
-          #f
-          #t)]
-      [x 
-       (identifier? #'x)
-       #`(init-loc-wrapper 
-          '#,(syntax-e #'x)
-          #,(syntax-line stx) 
-          #,(syntax-column stx)
-          #,quoted?)]
-      [x 
-       #`(init-loc-wrapper 
-          #,(let ([base (syntax-e #'x)])
-              (if (string? base)
-                  #`(rewrite-quotes #,(format "~s" base))
-                  (format "~s" (syntax-e #'x))))
-          #,(syntax-line stx) 
-          #,(syntax-column stx)
-          #,quoted?)]))
-  
-  (define (to-lw/proc stx)
-    (syntax-case stx ()
-      [(_ stx)
-       #`(add-spans #,(process-arg #'stx 1))]))
-  (define (to-lw/uq/proc stx)
-    (syntax-case stx ()
-      [(_ stx)
-       #`(add-spans #,(process-arg #'stx 0))])))
-
-(define (add-spans lw)
-  (define (add-spans/lw lw line col)
-    (cond
-      [(eq? lw 'spring) (values line col col)]
-      [else
-       (let ([start-line (or (lw-line lw) line)]
-             [start-column (or (lw-column lw) col)])
-         (when (and start-line  ;; if we don't have src loc info, just give up.
-                    start-column)
-           (let-values ([(last-line first-column last-column)
-                         (add-spans/obj (lw-e lw) start-line start-column)])
-             (unless (lw-line lw)
-               (set-lw-line! lw line))
-             (set-lw-line-span! lw (- last-line start-line))
-             
-             (unless (lw-column lw)
-               (set-lw-column! lw col))
-             (let ([new-col (min (lw-column lw)
-                                 first-column)])
-               (set-lw-column! lw new-col)
-               (set-lw-column-span! lw (- last-column new-col)))
-             
-             (values last-line first-column last-column))))]))
-  (define (add-spans/obj e line col)
-    (cond
-      [(string? e) 
-       (values line col (+ col (string-length e)))]
-      [(symbol? e)
-       (values line col (+ col (string-length (symbol->string e))))]
-      [(not e) (values line col col)]
-      [else 
-       (let loop ([lws e]
-                  [line line]
-                  [first-column col]
-                  [last-column col]
-                  [current-col col])
-         (cond
-           [(null? lws) (values line first-column last-column)]
-           [else 
-            (let-values ([(last-line inner-first-column inner-last-column)
-                          (add-spans/lw (car lws) line current-col)])
-              (if (= last-line line)
-                  (loop (cdr lws)
-                        last-line
-                        (min inner-first-column first-column)
-                        (max inner-last-column last-column)
-                        inner-last-column)
-                  (loop (cdr lws)
-                        last-line
-                        (min inner-first-column first-column)
-                        inner-last-column
-                        inner-last-column)))]))]))
-  
-  (add-spans/lw lw #f #f)
-  lw)
 
 (define pnum (and/c number? (or/c zero? positive?)))
 

collects/redex/private/pict.ss

@@ -580,9 +580,10 @@
                              [column (+ (lw-column fst)
                                         (lw-column-span fst))]
                              [column-span
-                              (- (lw-column snd)
+                              (max (- (lw-column snd)
                                       (+ (lw-column fst)
-                                    (lw-column-span fst)))])
+                                         (lw-column-span fst)))
+                                   0)])
                         (build-lw (make-bar) line line-span column column-span))]
                      [else
                       (build-lw

collects/redex/private/reduction-semantics.ss

@@ -20,6 +20,46 @@
 (define (language-nts lang)
   (hash-map (compiled-lang-ht lang) (λ (x y) x)))
 
+#;
+(define-for-syntax (prune-syntax stx)
+  (datum->syntax
+   (identifier-prune-lexical-context #'whatever '())
+   (let loop ([stx stx])
+     (syntax-case stx (quote)
+       [(quote x) (list (quote-syntax/prune quote)
+                        (syntax->datum #'x))]
+       [x
+        (cond 
+          [(identifier? stx) (identifier-prune-lexical-context stx)] 
+          [(syntax? stx)
+           (datum->syntax (identifier-prune-lexical-context 
+                           #'whatever 
+                           '(#%app))
+                          (syntax-e stx)
+                          stx)]
+          [(pair? stx)
+           (cons (loop (car stx))
+                 (loop (cdr stx)))]
+          [else stx])]))))
+
+(define-for-syntax (prune-syntax stx)
+  stx
+  
+  #;
+  (datum->syntax
+   (identifier-prune-lexical-context #'whatever '(#%app #%datum))
+   (let loop ([stx stx])
+     (syntax-case stx (quote)
+       [(quote x) (list (quote-syntax/prune quote)
+                        (syntax->datum #'x))]
+       [(a . b) (cons (loop #'a) (loop #'b))]
+       [x 
+        (identifier? #'x)
+        (datum->syntax (identifier-prune-lexical-context #'x)
+                       (syntax-e #'x))]
+       [() '()]
+       [_ (syntax->datum stx)]))))
+
 (define-syntax (term-match/single stx)
   (syntax-case stx ()
     [(_ lang [pattern rhs] ...)
@@ -243,6 +283,7 @@
     (syntax-case stx ()
       [(_ id orig-reduction-relation allow-zero-rules? lang . w/domain-args)
        (identifier? #'lang)
+       (prune-syntax
         (let-values ([(domain-pattern main-arrow args)
                       (parse-keywords stx #'id #'w/domain-args)])
           (with-syntax ([(rules ...) (before-with args)]
@@ -258,7 +299,7 @@
                #'(list lws ...)
                (syntax-e #'allow-zero-rules?)
                domain-pattern
-              main-arrow))))]
+               main-arrow)))))]
       [(_ id orig-reduction-relation allow-zero-rules? lang args ...)
        (raise-syntax-error (syntax-e #'id) 
                            "expected an identifier for the language name"
@@ -983,6 +1024,7 @@
            (raise-syntax-error syn-error-name "expected an identifier in the language position" orig-stx #'lang))
          (when (null? (syntax-e #'rest))
            (raise-syntax-error syn-error-name "no clauses" orig-stx))
+         (prune-syntax
           (let-values ([(contract-name dom-ctcs codom-contract pats)
                         (split-out-contract orig-stx syn-error-name #'rest)])
             (with-syntax ([(((original-names lhs-clauses ...) rhs stuff ...) ...) pats]
@@ -1122,7 +1164,7 @@
                                   'name)))
                              (term-define-fn name name2))
                          'disappeared-use
-                            (map syntax-local-introduce (syntax->list #'(original-names ...))))))))))))]
+                         (map syntax-local-introduce (syntax->list #'(original-names ...)))))))))))))]
       [(_ prev-metafunction name lang clauses ...)
        (begin
          (unless (identifier? #'name)
@@ -1361,6 +1403,7 @@
      (identifier? (syntax name))
      (begin
        (check-rhss-not-empty stx (cddr (syntax->list stx)))
+       (prune-syntax
         (with-syntax ([((nt-names orig) ...) (pull-out-names 'define-language stx #'(names ...))])
           (with-syntax ([(subst-names ...) (generate-temporaries (syntax->list #'(nt-names ...)))])
             (syntax/loc stx
@@ -1377,7 +1420,7 @@
                           (identifier? #'x)
                           #'define-language-name])])
                     '(nt-names ...))))
-               (define define-language-name (language name (names rhs ...) ...)))))))]))
+                (define define-language-name (language name (names rhs ...) ...))))))))]))
 
 (define-struct binds (source binds))