From 3207e14fcabd987ee4f0b33cb33f54dbbc882af1 Mon Sep 17 00:00:00 2001
From: Abdulaziz Ghuloum <aghuloum@cs.indiana.edu>
Date: Thu, 14 May 2009 09:52:05 +0300
Subject: [PATCH] -  psyntax now produces      `(annotated-call ,annotation
 ,rator ,rands ...)    form for cases when there is an annotation attached to
 the procedure    call.  The compiler just stripps it out and makes no use of
 it.

---
 scheme/ikarus.compiler.ss  | 107 +++++++++++++++++++------------------
 scheme/last-revision       |   2 +-
 scheme/psyntax.builders.ss |   9 ++--
 scheme/psyntax.expander.ss |   2 +-
 4 files changed, 63 insertions(+), 57 deletions(-)

diff --git a/scheme/ikarus.compiler.ss b/scheme/ikarus.compiler.ss
index af44c2a..a0bd079 100644
--- a/scheme/ikarus.compiler.ss
+++ b/scheme/ikarus.compiler.ss
@@ -309,18 +309,60 @@
                     (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-make-parameter args ctxt)
+    (case (length args)
+      [(1)
+       (let ([val-expr (car args)]
+             [t (gensym 't)]
+             [x (gensym 'x)])
+         (E `((lambda (,t) 
+                (case-lambda
+                  [() ,t]
+                  [(,x) (set! ,t ,x)]))
+              ,val-expr)
+            ctxt))]
+      [(2)
+       (let ([val-expr (car args)]
+             [guard-expr (cadr args)]
+             [f (gensym 'f)]
+             [t (gensym 't)]
+             [t0 (gensym 't)]
+             [x (gensym 'x)])
+         (E `((case-lambda 
+                [(,t ,f)
+                 (if ((primitive procedure?) ,f)
+                     ((case-lambda
+                        [(,t0)
+                         (case-lambda
+                           [() ,t0]
+                           [(,x) (set! ,t0 (,f ,x))])])
+                      (,f ,t))
+                     ((primitive die)
+                        'make-parameter 
+                        '"not a procedure"
+                        ,f))])
+              ,val-expr
+              ,guard-expr)
+            ctxt))]
+      [else 
+       (make-funcall 
+         (make-primref 'make-parameter)
+         (map (lambda (x) (E x #f)) args))]))
+  (define (E-app rator args ctxt)
+    (equal-case rator
+      [((primitive make-parameter)) (E-make-parameter args ctxt)]
+      [else
+       (let ([names (get-fmls rator args)])
+         (make-funcall 
+           (E rator (list ctxt))
+           (let f ([args args] [names names])
+             (cond
+               [(pair? names)
+                (cons 
+                  (E (car args) (car names))
+                  (f (cdr args) (cdr names)))]
+               [else
+                (map (lambda (x) (E x #f)) args)]))))]))
   (define (E x ctxt)
     (cond
       [(pair? x)
@@ -400,45 +442,8 @@
          [(primitive)
           (let ([var (cadr x)])
             (make-primref var))]
-         [((primitive make-parameter)) 
-          (case (length x)
-            [(2) 
-             (let ([val-expr (cadr x)]
-                   [t (gensym 't)]
-                   [x (gensym 'x)])
-               (E `((lambda (,t) 
-                      (case-lambda
-                        [() ,t]
-                        [(,x) (set! ,t ,x)]))
-                    ,val-expr)
-                  ctxt))]
-            [(3)
-             (let ([val-expr (cadr x)]
-                   [guard-expr (caddr x)]
-                   [f (gensym 'f)]
-                   [t (gensym 't)]
-                   [t0 (gensym 't)]
-                   [x (gensym 'x)])
-               (E `((case-lambda 
-                      [(,t ,f)
-                       (if ((primitive procedure?) ,f)
-                           ((case-lambda
-                              [(,t0)
-                               (case-lambda
-                                 [() ,t0]
-                                 [(,x) (set! ,t0 (,f ,x))])])
-                            (,f ,t))
-                           ((primitive die)
-                              'make-parameter 
-                              '"not a procedure"
-                              ,f))])
-                    ,val-expr
-                    ,guard-expr)
-                  ctxt))]
-            [else 
-             (make-funcall 
-               (make-primref 'make-parameter)
-               (map (lambda (x) (E x #f)) (cdr x)))])]
+         [(annotated-call) 
+          (E-app (caddr x) (cdddr x) ctxt)]
          [else (E-app (car x) (cdr x) ctxt)])]
       [(symbol? x)
        (cond
diff --git a/scheme/last-revision b/scheme/last-revision
index bbd4bf1..23f6521 100644
--- a/scheme/last-revision
+++ b/scheme/last-revision
@@ -1 +1 @@
-1774
+1775
diff --git a/scheme/psyntax.builders.ss b/scheme/psyntax.builders.ss
index ae72390..2311720 100644
--- a/scheme/psyntax.builders.ss
+++ b/scheme/psyntax.builders.ss
@@ -31,10 +31,11 @@
     (if-wants-global-defines
       `(define ,x '#f)
       (build-void)))
-  (define-syntax build-application
-    (syntax-rules ()
-      ((_ ae fun-exp arg-exps)
-       `(,fun-exp . ,arg-exps))))
+  (define build-application
+    (lambda (ae fun-exp arg-exps)
+      (if ae
+          `(annotated-call ,ae ,fun-exp . ,arg-exps)
+          (cons fun-exp arg-exps))))
   (define-syntax build-conditional
     (syntax-rules ()
       ((_ ae test-exp then-exp else-exp)
diff --git a/scheme/psyntax.expander.ss b/scheme/psyntax.expander.ss
index 2731599..90e4331 100644
--- a/scheme/psyntax.expander.ss
+++ b/scheme/psyntax.expander.ss
@@ -2720,7 +2720,7 @@
       (syntax-match e  ()
         ((rator rands ...)
          (let ((rator (chi-expr rator r mr)))
-           (build-application no-source
+           (build-application (syntax-annotation e)
              rator
              (chi-expr* rands r mr)))))))