From 39c8e8e23f1764d41ee3b50e014aefc8f01cd521 Mon Sep 17 00:00:00 2001
From: Abdulaziz Ghuloum <aghuloum@cs.indiana.edu>
Date: Thu, 14 May 2009 09:09:58 +0300
Subject: [PATCH] removed source annotation from primitive procedures (which
 were not supposed to be there in the first place)

---
 scheme/ikarus.compiler.ss | 35 +++++++++++++++++++----------------
 scheme/last-revision      |  2 +-
 scheme/makefile.ss        |  2 ++
 3 files changed, 22 insertions(+), 17 deletions(-)

diff --git a/scheme/ikarus.compiler.ss b/scheme/ikarus.compiler.ss
index dbc9847..af44c2a 100644
--- a/scheme/ikarus.compiler.ss
+++ b/scheme/ikarus.compiler.ss
@@ -21,7 +21,8 @@
           current-core-eval
           compile-core-expr expand/optimize optimizer-output
           cp0-effort-limit cp0-size-limit optimize-level 
-          perform-tag-analysis tag-analysis-output)
+          perform-tag-analysis tag-analysis-output
+          strip-source-info)
   (import 
     (rnrs hashtables)
     (ikarus system $fx)
@@ -42,6 +43,7 @@
     (ikarus.intel-assembler))
 
 
+(define strip-source-info (make-parameter #f))
 
 (define-syntax struct-case
   (lambda (x)
@@ -307,6 +309,18 @@
                     (list? fml*)) 
                   body))))))
            cls*))
+  (define (E-app rator arg* ctxt)
+    (let ([names (get-fmls rator arg*)])
+      (make-funcall 
+        (E rator (list ctxt))
+        (let f ([arg* arg*] [names names])
+          (cond
+            [(pair? names)
+             (cons 
+               (E (car arg*) (car names))
+               (f (cdr arg*) (cdr names)))]
+            [else
+             (map (lambda (x) (E x #f)) arg*)])))))
   (define (E x ctxt)
     (cond
       [(pair? x)
@@ -375,9 +389,9 @@
               (make-clambda (gensym) cls* #f #f
                 (cons 
                   (and (symbol? ctxt) ctxt)
-                  (if (annotation? ae)
-                      (annotation-source ae)
-                      #f)))))]
+                  (and (not (strip-source-info))
+                       (annotation? ae)
+                       (annotation-source ae))))))]
          [(lambda) 
           (E `(case-lambda ,(cdr x)) ctxt)]
          [(foreign-call)
@@ -425,18 +439,7 @@
              (make-funcall 
                (make-primref 'make-parameter)
                (map (lambda (x) (E x #f)) (cdr x)))])]
-         [else
-          (let ([names (get-fmls (car x) (cdr x))])
-            (make-funcall 
-              (E (car x) (list ctxt))
-              (let f ([arg* (cdr x)] [names names])
-                (cond
-                  [(pair? names)
-                   (cons 
-                     (E (car arg*) (car names))
-                     (f (cdr arg*) (cdr names)))]
-                  [else
-                   (map (lambda (x) (E x #f)) arg*)]))))])]
+         [else (E-app (car x) (cdr x) ctxt)])]
       [(symbol? x)
        (cond
          [(lexical x) =>
diff --git a/scheme/last-revision b/scheme/last-revision
index fc93fdd..bbd4bf1 100644
--- a/scheme/last-revision
+++ b/scheme/last-revision
@@ -1 +1 @@
-1773
+1774
diff --git a/scheme/makefile.ss b/scheme/makefile.ss
index 66b216a..67f2b7b 100755
--- a/scheme/makefile.ss
+++ b/scheme/makefile.ss
@@ -31,6 +31,7 @@
 (perform-tag-analysis #t)
 (pretty-width 160)
 ((pretty-format 'fix) ((pretty-format 'letrec)))
+(strip-source-info #t)
 
 (define scheme-library-files
   ;;; Listed in the order in which they're loaded.
@@ -404,6 +405,7 @@
     [struct-field-accessor                       i]
     [struct-length                               i]
     [struct-ref                                  i]
+    [struct-set!                                 i]
     [struct-printer                              i]
     [struct-name                                 i]
     [struct-type-descriptor                      i]