- 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.
This commit is contained in:
Abdulaziz Ghuloum 2009-05-14 09:52:05 +03:00
parent 39c8e8e23f
commit 3207e14fca
4 changed files with 63 additions and 57 deletions

View File

@ -309,18 +309,60 @@
(list? fml*)) (list? fml*))
body)))))) body))))))
cls*)) 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 (make-funcall
(E rator (list ctxt)) (E rator (list ctxt))
(let f ([arg* arg*] [names names]) (let f ([args args] [names names])
(cond (cond
[(pair? names) [(pair? names)
(cons (cons
(E (car arg*) (car names)) (E (car args) (car names))
(f (cdr arg*) (cdr names)))] (f (cdr args) (cdr names)))]
[else [else
(map (lambda (x) (E x #f)) arg*)]))))) (map (lambda (x) (E x #f)) args)]))))]))
(define (E x ctxt) (define (E x ctxt)
(cond (cond
[(pair? x) [(pair? x)
@ -400,45 +442,8 @@
[(primitive) [(primitive)
(let ([var (cadr x)]) (let ([var (cadr x)])
(make-primref var))] (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)])] [else (E-app (car x) (cdr x) ctxt)])]
[(symbol? x) [(symbol? x)
(cond (cond

View File

@ -1 +1 @@
1774 1775

View File

@ -31,10 +31,11 @@
(if-wants-global-defines (if-wants-global-defines
`(define ,x '#f) `(define ,x '#f)
(build-void))) (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 (define-syntax build-conditional
(syntax-rules () (syntax-rules ()
((_ ae test-exp then-exp else-exp) ((_ ae test-exp then-exp else-exp)

View File

@ -2720,7 +2720,7 @@
(syntax-match e () (syntax-match e ()
((rator rands ...) ((rator rands ...)
(let ((rator (chi-expr rator r mr))) (let ((rator (chi-expr rator r mr)))
(build-application no-source (build-application (syntax-annotation e)
rator rator
(chi-expr* rands r mr))))))) (chi-expr* rands r mr)))))))