conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

- 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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

107
scheme/ikarus.compiler.ss
View File

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

2
scheme/last-revision
View File

@ -1 +1 @@
1774
1775

9
scheme/psyntax.builders.ss
View File

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

2
scheme/psyntax.expander.ss
View File

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