- 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

@@ -309,18 +309,60 @@
                     (list? fml*)) 
                   body))))))
            cls*))
-  (define (E-app rator arg* ctxt)
+  (define (E-make-parameter args ctxt)
-    (let ([names (get-fmls rator arg*)])
+    (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 ([arg* arg*] [names names])
+           (let f ([args args] [names names])
              (cond
                [(pair? names)
                 (cons 
-               (E (car arg*) (car names))
+                  (E (car args) (car names))
-               (f (cdr arg*) (cdr names)))]
+                  (f (cdr args) (cdr names)))]
                [else
-             (map (lambda (x) (E x #f)) arg*)])))))
+                (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)) 
+         [(annotated-call) 
-          (case (length x)
+          (E-app (caddr x) (cdddr x) ctxt)]
-            [(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)))])]
          [else (E-app (car x) (cdr x) ctxt)])]
       [(symbol? x)
        (cond

scheme/last-revision

@@ -1 +1 @@
-1774
+1775

scheme/psyntax.builders.ss

@@ -31,10 +31,11 @@
     (if-wants-global-defines
       `(define ,x '#f)
       (build-void)))
-  (define-syntax build-application
+  (define build-application
-    (syntax-rules ()
+    (lambda (ae fun-exp arg-exps)
-      ((_ ae fun-exp arg-exps)
+      (if ae
-       `(,fun-exp . ,arg-exps))))
+          `(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)

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)))))))