From ba7ad5d2e676d106d57681069f70f823a0a51df0 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Thu, 13 Nov 2008 00:26:04 +0000
Subject: [PATCH] add support to xform to output source line numbers

svn: r12419
---
 collects/compiler/private/xform.ss | 89 +++++++++++++++++++++---------
 collects/compiler/xform.ss         | 42 +++++++-------
 src/configure                      |  8 ++-
 src/mred/gc2/Makefile.in           |  4 +-
 src/mzscheme/configure.ac          |  2 +
 src/mzscheme/gc2/Makefile.in       |  4 +-
 src/mzscheme/gc2/xform-mod.ss      |  5 ++
 7 files changed, 101 insertions(+), 53 deletions(-)

diff --git a/collects/compiler/private/xform.ss b/collects/compiler/private/xform.ss
index 116b3df357..ebab0237e3 100644
--- a/collects/compiler/private/xform.ss
+++ b/collects/compiler/private/xform.ss
@@ -9,6 +9,7 @@
 		 cpp
 		 file-in
 		 file-out
+                 keep-lines?
 		 palm? pgc? pgc-really?
 		 precompiling-header? precompiled-header
 		 show-info? output-depends-info?
@@ -1044,10 +1045,6 @@
         
         (define (display/indent v s)
           (when next-indent
-            ;; can't get pre-processor line directive to work
-            '(when (and v (tok-file v) (tok-line v))
-               (printf "# ~a ~s~n" (max 1 (- (tok-line v) 1)) (tok-file v)))
-            
             (display (make-string next-indent #\space))
             (set! next-indent #f))
           (display s))
@@ -1099,34 +1096,56 @@
                           (get-variable-size (cdr x)))
                         vars)))
         
-        (define (print-it e indent semi-newlines? ordered?)
-          (let loop ([e e][prev #f][prevs null])
-            (unless (null? e)
-              (let ([v (car e)])
+        (define (print-it e indent semi-newlines? ordered? line file)
+          (let loop ([e e][prev #f][prevs null][old-line line][old-file file])
+            (if (null? e)
+              (values old-line old-file)
+              (let* ([v (car e)]
+                     [line (or (and (tok? v) (tok-line v))
+                               old-line)]
+                     [file (or (and (tok? v) (tok-file v))
+                               old-file)]
+                     [inc-line! (lambda () (set! line (add1 line)))])
+                (when keep-lines?
+                  (unless (and (equal? line old-line)
+                               (equal? file old-file))
+                    (if (and (equal? file old-file)
+                             (line . > . old-line)
+                             ((- line old-line) . < . 10))
+                        (display (make-string (- line old-line) #\newline))
+                        (printf "\n# ~a \"~a\"\n" line file))
+                    (set! next-indent indent)))
                 (cond
                   [(pragma? v)
                    (let ([s (format "#pragma ~a" (pragma-s v))])
                      (unless (regexp-match re:boring s)
-                       (printf "\n~a\n\n" s)))]
+                       (printf "\n~a\n\n" s)
+                       (set! line (+ line 3))))]
                   [(seq? v)
                    (display/indent v (tok-n v))
                    (let ([subindent (if (braces? v)
                                         (begin
                                           (newline/indent (+ indent 2))
+                                          (inc-line!)
                                           (+ indent 2))
                                         indent)])
-                     (print-it (seq->list (seq-in v)) subindent
-                               (not (and (parens? v)
-                                         prev
-					 (tok? prev)
-                                         (memq (tok-n prev) '(for))))
-                               (or (braces? v) (callstage-parens? v)))
+                     (let-values ([(l f)
+                                   (print-it (seq->list (seq-in v)) subindent
+                                             (not (and (parens? v)
+                                                       prev
+                                                       (tok? prev)
+                                                       (memq (tok-n prev) '(for))))
+                                             (or (braces? v) (callstage-parens? v))
+                                             line file)])
+                       (set! line l)
+                       (set! file f))
                      (when (and next-indent (= next-indent subindent))
                        (set! next-indent indent)))
                    (display/indent #f (seq-close v))
                    (cond
                      [(braces? v)
-                      (newline/indent indent)]
+                      (newline/indent indent)
+                      (inc-line!)]
                      [(brackets? v)
                       (display/indent v " ")]
                      [(parens? v)
@@ -1135,12 +1154,15 @@
                                (memq (tok-n prev) '(if))
                                (or (null? (cdr e))
                                    (not (braces? (cadr e)))))
-                          (newline/indent (+ indent 2))
+                          (begin
+                            (newline/indent (+ indent 2))
+                            (inc-line!))
                           (display/indent v " "))]
                      [else (error 'xform "unknown brace: ~a" (caar v))])]
                   [(note? v)
                    (display/indent v (note-s v))
-                   (newline/indent indent)]
+                   (newline/indent indent)
+                   (inc-line!)]
                   [(call? v)
                    (if (not (call-nonempty? v))
                        (display/indent v "FUNCCALL_EMPTY(")
@@ -1160,7 +1182,11 @@
                                    (display/indent v ")"))
                                  (display/indent v "_"))
                              (display/indent v "), "))))
-                   (print-it (append (call-func v) (list (call-args v))) indent #f #f)
+                   (let-values ([(l f)
+                                 (print-it (append (call-func v) (list (call-args v))) 
+                                           indent #f #f line file)])
+                     (set! line l)
+                     (set! file f))
                    (display/indent v ")")]
                   [(block-push? v)
                    (let ([size (total-push-size (block-push-vars v))]
@@ -1175,15 +1201,18 @@
                        (display/indent v (format "BLOCK_SETUP~a((" (if (block-push-top? v) "_TOP" "")))
                        (push-vars (block-push-vars v) prev-add "")
                        (display/indent v "));")
-                       (newline))
+                       (newline)
+                       (inc-line!))
                      (printf "#~adefine ~a_COUNT (~a~a)~n" tabbing tag size prev-add)
+                     (inc-line!)
                      (printf "#~adefine SETUP_~a(x) " tabbing tag)
                      (cond
                        [(and (zero? size) (block-push-super-tag v)) 
                         (printf "SETUP_~a(x)" (block-push-super-tag v))]
                        [per-block-push? (printf "SETUP(~a_COUNT)" tag)]
                        [else (printf "x")])
-                     (newline/indent indent))]
+                     (newline/indent indent)
+                     (inc-line!))]
                   [(nested-setup? v)
                    (let ([tabbing (if (zero? indent)
                                       ""
@@ -1203,9 +1232,11 @@
                         (printf "#~aundef BLOCK_SETUP~n" tabbing)
                         (printf "#~aundef FUNCCALL~n" tabbing)
                         (printf "#~aundef FUNCCALL_EMPTY~n" tabbing)
-                        (printf "#~aundef FUNCCALL_AGAIN~n" tabbing)]))]
+                        (printf "#~aundef FUNCCALL_AGAIN~n" tabbing)])
+                     (set! line (+ 4 line)))]
                   [(memq (tok-n v) asm-commands)
                    (newline/indent indent)
+                   (inc-line!)
                    (display/indent v (tok-n v))
                    (display/indent v " ")]
                   [(and (or (eq? '|HIDE_FROM_XFORM| (tok-n v))
@@ -1235,8 +1266,9 @@
                      (display/indent v " "))
                    (when (and (eq? semi (tok-n v))
                               semi-newlines?)
-                     (newline/indent indent))])
-                (loop (cdr e) v (cons v prevs))))))
+                     (newline/indent indent)
+                     (inc-line!))])
+                (loop (cdr e) v (cons v prevs) line file)))))
         
         
         ;; prev-was-funcall? implements a last-ditch optimization: if
@@ -3079,7 +3111,6 @@
                                                [len (if last?
                                                         (length e)
                                                         (sub1 (length e)))])
-                                          (printf "/* this far ~a */~n" (tok-line (car e)))
                                           (let ([k (lift-in-arithmetic? (let loop ([e e])
                                                                           (if (null? ((if last?
                                                                                           cddr 
@@ -3831,7 +3862,9 @@
         
         ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
         
-        (let* ([e e-raw])
+        (let* ([e e-raw]
+               [line -inf.0]
+               [file #f])
           (set! e-raw #f) ;; to allow GC
           (foldl-statement
            e
@@ -3842,7 +3875,9 @@
                                (or (tok-file (car sube))
                                    where))]
                     [sube (top-level sube where #t)])
-               (print-it sube 0 #t #f)
+               (let-values ([(l f) (print-it sube 0 #t #f line file)])
+                 (set! line l)
+                 (set! file f))
                where))
            #f))
         
diff --git a/collects/compiler/xform.ss b/collects/compiler/xform.ss
index 334cc44e9a..63c27773c5 100644
--- a/collects/compiler/xform.ss
+++ b/collects/compiler/xform.ss
@@ -1,23 +1,25 @@
+#lang scheme/base
 
-(module xform mzscheme
-  (require dynext/compile
-	   (prefix xform: "private/xform.ss"))
+(require dynext/compile
+         (prefix-in xform: "private/xform.ss"))
 
-  (provide xform)
+(provide xform)
+
+(define (xform quiet? src dest header-dirs #:keep-lines? keep-lines?)
+  (let ([exe (current-extension-compiler)]
+        [flags (expand-for-compile-variant
+                (current-extension-preprocess-flags))]
+        [headers (apply append
+                        (map (current-make-compile-include-strings)
+                             header-dirs))])
+    (xform:xform quiet?
+                 (cons exe
+                       (append flags headers))
+                 src
+                 dest
+                 keep-lines?
+                 #f #t #t
+                 #f #f
+                 #f #f
+                 #f)))
 
-  (define (xform quiet? src dest header-dirs)
-    (let ([exe (current-extension-compiler)]
-	  [flags (expand-for-compile-variant
-		  (current-extension-preprocess-flags))]
-	  [headers (apply append
-			  (map (current-make-compile-include-strings)
-			       header-dirs))])
-      (xform:xform quiet?
-		   (cons exe
-			 (append flags headers))
-		   src
-		   dest
-		   #f #t #t
-		   #f #f
-		   #f #f
-		   #f))))
diff --git a/src/configure b/src/configure
index e359ba0c96..36740c961d 100755
--- a/src/configure
+++ b/src/configure
@@ -694,6 +694,7 @@ CGCOPTIONS
 GC2OPTIONS
 MROPTIONS
 GCDIR
+XFORMFLAGS
 MZBINTARGET
 MZINSTALLTARGET
 EXTRA_GMP_OBJ
@@ -4189,6 +4190,7 @@ fi
 # If using gcc, we want all warnings:
 if test "$CC" = "gcc" ; then
   COMPFLAGS="$COMPFLAGS -Wall"
+  XFORMFLAGS="$XFORMFLAGS --keep-lines"
 
   # Use -MMD when we have gcc and gnumake:
   is_gmake=`make -v no-such-target-we-hope 2>&1 | grep "GNU Make"`
@@ -11809,6 +11811,7 @@ LIBS="$LIBS $EXTRALIBS"
 
 
 
+
 
 
 mk_needed_dir()
@@ -12675,6 +12678,7 @@ CGCOPTIONS!$CGCOPTIONS$ac_delim
 GC2OPTIONS!$GC2OPTIONS$ac_delim
 MROPTIONS!$MROPTIONS$ac_delim
 GCDIR!$GCDIR$ac_delim
+XFORMFLAGS!$XFORMFLAGS$ac_delim
 MZBINTARGET!$MZBINTARGET$ac_delim
 MZINSTALLTARGET!$MZINSTALLTARGET$ac_delim
 EXTRA_GMP_OBJ!$EXTRA_GMP_OBJ$ac_delim
@@ -12691,7 +12695,6 @@ LIBSFX!$LIBSFX$ac_delim
 WXLIBS!$WXLIBS$ac_delim
 WXVARIANT!$WXVARIANT$ac_delim
 ICP!$ICP$ac_delim
-MRLIBINSTALL!$MRLIBINSTALL$ac_delim
 _ACEOF
 
   if test `sed -n "s/.*$ac_delim\$/X/p" conf$$subs.sed | grep -c X` = 97; then
@@ -12733,6 +12736,7 @@ _ACEOF
 ac_delim='%!_!# '
 for ac_last_try in false false false false false :; do
   cat >conf$$subs.sed <<_ACEOF
+MRLIBINSTALL!$MRLIBINSTALL$ac_delim
 LIBFINISH!$LIBFINISH$ac_delim
 MAKE_MRED!$MAKE_MRED$ac_delim
 MAKE_WBUILD!$MAKE_WBUILD$ac_delim
@@ -12773,7 +12777,7 @@ LIBOBJS!$LIBOBJS$ac_delim
 LTLIBOBJS!$LTLIBOBJS$ac_delim
 _ACEOF
 
-  if test `sed -n "s/.*$ac_delim\$/X/p" conf$$subs.sed | grep -c X` = 38; then
+  if test `sed -n "s/.*$ac_delim\$/X/p" conf$$subs.sed | grep -c X` = 39; then
     break
   elif $ac_last_try; then
     { { echo "$as_me:$LINENO: error: could not make $CONFIG_STATUS" >&5
diff --git a/src/mred/gc2/Makefile.in b/src/mred/gc2/Makefile.in
index db6339a02d..fa1ef5b076 100644
--- a/src/mred/gc2/Makefile.in
+++ b/src/mred/gc2/Makefile.in
@@ -66,8 +66,8 @@ MZMMM = $(MZMMM_@WXVARIANT@)
 XFORM_CMD = $(MZMMM) -cqu $(srcdir)/../../mzscheme/gc2/xform.ss --setup ../../mzscheme/gc2
 XFORM_CPP_ARGS = -I$(srcdir)/../../mzscheme/gc2 $(NOGCINC) $(XINCLUDE) $(OPTIONS) @PREFLAGS@ $(XFORM_INC_@WXVARIANT@) @JPEG_INC@ @ZLIB_INC@
 
-XFORMXX = $(XFORM_CMD) --cpp "$(CXXCPP) $(XFORM_CPP_ARGS)" -o
-XFORM = $(XFORM_CMD) --cpp "$(CPP) $(XFORM_CPP_ARGS)" -o
+XFORMXX = $(XFORM_CMD) --cpp "$(CXXCPP) $(XFORM_CPP_ARGS)" @XFORMFLAGS@ -o
+XFORM = $(XFORM_CMD) --cpp "$(CPP) $(XFORM_CPP_ARGS)" @XFORMFLAGS@ -o
 XFORMDEP = $(srcdir)/../../mzscheme/gc2/xform.ss $(srcdir)/../../mzscheme/gc2/xform-mod.ss $(srcdir)/../../mzscheme/gc2/gc2.h
 
 WXBDIR=../../wxxt
diff --git a/src/mzscheme/configure.ac b/src/mzscheme/configure.ac
index 45727bd374..1ed975c428 100644
--- a/src/mzscheme/configure.ac
+++ b/src/mzscheme/configure.ac
@@ -419,6 +419,7 @@ fi
 # If using gcc, we want all warnings:
 if test "$CC" = "gcc" ; then 
   COMPFLAGS="$COMPFLAGS -Wall"
+  XFORMFLAGS="$XFORMFLAGS --keep-lines"
 
   # Use -MMD when we have gcc and gnumake:
   is_gmake=`make -v no-such-target-we-hope 2>&1 | grep "GNU Make"`
@@ -1309,6 +1310,7 @@ AC_SUBST(CGCOPTIONS)
 AC_SUBST(GC2OPTIONS)
 AC_SUBST(MROPTIONS)
 AC_SUBST(GCDIR)
+AC_SUBST(XFORMFLAGS)
 AC_SUBST(MZBINTARGET)
 AC_SUBST(MZINSTALLTARGET)
 AC_SUBST(EXTRA_GMP_OBJ)
diff --git a/src/mzscheme/gc2/Makefile.in b/src/mzscheme/gc2/Makefile.in
index 0fc6851f72..96d4ad9aac 100644
--- a/src/mzscheme/gc2/Makefile.in
+++ b/src/mzscheme/gc2/Makefile.in
@@ -25,12 +25,12 @@ LIBS = @LIBS@
 DEF_COLLECTS_DIR = +D INITIAL_COLLECTS_DIRECTORY='"'"`cd $(srcdir)/../../../collects; pwd`"'"'
 
 XFORM_SETUP = ../mzscheme@CGC@ -cqu $(srcdir)/xform.ss --setup .
-XFORM_NOPRECOMP = $(XFORM_SETUP) --cpp "$(CPP) $(CPPFLAGS)" -o
+XFORM_NOPRECOMP = $(XFORM_SETUP) --cpp "$(CPP) $(CPPFLAGS)" @XFORMFLAGS@ -o
 XSRCDIR = xsrc
 XFORM = env XFORM_USE_PRECOMP=$(XSRCDIR)/precomp.h $(XFORM_NOPRECOMP)
 SRCDIR = $(srcdir)/../src
 
-XFORM_COMPACT_GC_NOPRECOMP = $(XFORM_SETUP) --cpp "$(CPP) $(CPPFLAGS) -DUSE_COMPACT_3M_GC" -o
+XFORM_COMPACT_GC_NOPRECOMP = $(XFORM_SETUP) --cpp "$(CPP) $(CPPFLAGS) -DUSE_COMPACT_3M_GC" @XFORMFLAGS@ -o
 XFORM_COMPACT_GC = env XFORM_USE_PRECOMP=$(XSRCDIR)/precomp.h $(XFORM_COMPACT_GC_NOPRECOMP)
 
 FOREIGN_USED_OBJ = foreign.@LTO@
diff --git a/src/mzscheme/gc2/xform-mod.ss b/src/mzscheme/gc2/xform-mod.ss
index 3ecab6ef45..a76f94e082 100644
--- a/src/mzscheme/gc2/xform-mod.ss
+++ b/src/mzscheme/gc2/xform-mod.ss
@@ -13,6 +13,8 @@
   (define pgc? #t)
   (define pgc-really? #t)
 
+  (define keep-lines? #f)
+
   (define cpp #f)
   (define file-in #f)
   (define file-out #f)
@@ -36,6 +38,8 @@
      (set! palm? #t)
      (set! pgc? #f)
      (set! pgc-really? #f)]
+    [("--keep-lines") "keep source line information"
+     (set! keep-lines? #t)]
     [("--cgc") "conservative collection mode"
      (set! pgc-really? #f)]
     [("--cpp") cmdline "set CPP command line"
@@ -53,6 +57,7 @@
   (xform #t cpp
 	 file-in
 	 file-out
+         keep-lines?
 	 palm? pgc? pgc-really?
 	 precompiling-header? precompiled-header
 	 show-info? output-depends-info?