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

Fixes bugs 175025 and 175026: let-values and let*-values are fixed/added

This commit is contained in:
Abdulaziz Ghuloum 2007-12-09 02:53:12 -05:00
parent 0e93ac2db9
commit efd233ad0e
5 changed files with 102 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
scheme/ikarus.boot.prebuilt
View File

Binary file not shown.

3
scheme/ikarus.pretty-print.ss
View File

@ -618,11 +618,12 @@
(set-fmt! 'quasisyntax '(read-macro . "#`"))
(set-fmt! 'unsyntax '(read-macro . "#,"))
(set-fmt! 'unsyntax-splicing '(read-macro . "#,@"))
(set-fmt! '|#primitive| '(read-macro . "#%"))
;(set-fmt! '|#primitive| '(read-macro . "#%"))
(set-fmt! 'let '(alt
(_ (0 [e 0 e] ...) tab e ...)
(_ x (0 [e 0 e] ...) tab e ...)))
(set-fmt! 'letrec '(_ (0 [e 0 e] ...) tab e ...))
(set-fmt! 'letrec* '(_ (0 [e 0 e] ...) tab e ...))
(set-fmt! 'let-syntax '(_ (0 [e 0 e] ...) tab e ...))
(set-fmt! 'letrec-syntax '(_ (0 [e 0 e] ...) tab e ...))
(set-fmt! 'let* '(_ (0 [e 0 e] ...) tab e ...))

2
scheme/last-revision
View File

@ -1 +1 @@
1198
1199

5
scheme/makefile.ss
View File

@ -125,9 +125,10 @@
[unless (core-macro . unless)]
[parameterize (core-macro . parameterize)]
[case (core-macro . case)]
[let-values (core-macro . let-values)]
[record-type-descriptor (core-macro . record-type-descriptor)]
[record-constructor-descriptor (core-macro . record-constructor-descriptor)]
[let-values (macro . let-values)]
[let*-values (macro . let*-values)]
[define-struct (macro . define-struct)]
[include (macro . include)]
[include-into (macro . include-into)]
@ -590,7 +591,7 @@
[if i r ba se ne]
[let i r ba se ne]
[let* i r ba se ne]
[let*-values r ba]
[let*-values i r ba]
[let-syntax i r ba se ne]
[let-values i r ba]
[letrec i r ba se ne]

119
scheme/psyntax.expander.ss
View File

@ -787,33 +787,6 @@
(add-lexicals (cdr lab*) (cdr lex*)
(add-lexical (car lab*) (car lex*) r))))))
;;;
(define let-values-transformer ;;; go away
(lambda (e r mr)
(syntax-match e ()
((_ (((fml** ...) rhs*) ...) b b* ...)
(let ((rhs* (chi-expr* rhs* r mr)))
(let ((lex** (map (lambda (ls) (map gen-lexical ls)) fml**))
(lab** (map (lambda (ls) (map gen-label ls)) fml**)))
(let ((fml* (apply append fml**))
(lab* (apply append lab**))
(lex* (apply append lex**)))
(let f ((lex** lex**) (rhs* rhs*))
(cond
((null? lex**)
(chi-internal
(add-subst
(make-full-rib fml* lab*)
(cons b b*))
(add-lexicals lab* lex* r)
mr))
(else
(build-application no-source
(build-primref no-source 'call-with-values)
(list
(build-lambda no-source '() (car rhs*))
(build-lambda no-source (car lex**)
(f (cdr lex**) (cdr rhs*)))))))))))))))
(define letrec-helper
(lambda (e r mr build)
(syntax-match e ()
@ -846,7 +819,6 @@
(stx-error e "invalid type"))
(build-data no-source (binding-value b)))))))
(define record-type-descriptor-transformer
(lambda (e r mr)
(syntax-match e ()
@ -1021,6 +993,94 @@
(,f . ,rhs*)))
(invalid-fmls-error stx lhs*))))))
(define let-values-macro
(lambda (stx)
(define (rename x old* new*)
(unless (id? x)
(syntax-violation #f "not an indentifier" stx x))
(when (bound-id-member? x old*)
(syntax-violation #f "duplicate binding" stx x))
(let ([y (gensym (syntax->datum x))])
(values y (cons x old*) (cons y new*))))
(define (rename* x* old* new*)
(cond
[(null? x*) (values '() old* new*)]
[else
(let*-values ([(x old* new*) (rename (car x*) old* new*)]
[(x* old* new*) (rename* (cdr x*) old* new*)])
(values (cons x x*) old* new*))]))
(syntax-match stx ()
((_ () b b* ...)
(cons* (bless 'let) '() b b*))
((_ ((lhs* rhs*) ...) b b* ...)
(bless
(let f ([lhs* lhs*] [rhs* rhs*] [old* '()] [new* '()])
(cond
[(null? lhs*)
`(let ,(map list old* new*) ,b . ,b*)]
[else
(syntax-match (car lhs*) ()
[(x* ...)
(let-values ([(y* old* new*) (rename* x* old* new*)])
`(call-with-values
(lambda () ,(car rhs*))
(lambda ,y*
,(f (cdr lhs*) (cdr rhs*) old* new*))))]
[(x* ... . x)
(let*-values ([(y old* new*) (rename x old* new*)]
[(y* old* new*) (rename* x* old* new*)])
`(call-with-values
(lambda () ,(car rhs*))
(lambda ,(append y* y)
,(f (cdr lhs*) (cdr rhs*)
old* new*))))]
[others
(syntax-violation #f "malformed bindings"
stx others)])])))))))
(define let*-values-macro
(lambda (stx)
(define (check x*)
(unless (null? x*)
(let ([x (car x*)])
(unless (id? x)
(syntax-violation #f "not an identifier" stx x))
(check (cdr x*))
(when (bound-id-member? x (cdr x*))
(syntax-violation #f "duplicate identifier" stx x)))))
(syntax-match stx ()
((_ () b b* ...)
(cons* (bless 'let) '() b b*))
((_ ((lhs* rhs*) ...) b b* ...)
(bless
(let f ([lhs* lhs*] [rhs* rhs*])
(cond
[(null? lhs*)
`(begin ,b . ,b*)]
[else
(syntax-match (car lhs*) ()
[(x* ...)
(begin
(check x*)
`(call-with-values
(lambda () ,(car rhs*))
(lambda ,x*
,(f (cdr lhs*) (cdr rhs*)))))]
[(x* ... . x)
(begin
(check (cons x x*))
`(call-with-values
(lambda () ,(car rhs*))
(lambda ,(append x* x)
,(f (cdr lhs*) (cdr rhs*)))))]
[others
(syntax-violation #f "malformed bindings"
stx others)])])))))))
(define trace-lambda-macro
(lambda (stx)
(syntax-match stx ()
@ -2253,7 +2313,6 @@
((quote) quote-transformer)
((lambda) lambda-transformer)
((case-lambda) case-lambda-transformer)
((let-values) let-values-transformer)
((letrec) letrec-transformer)
((letrec*) letrec*-transformer)
((case) case-transformer)
@ -2298,6 +2357,8 @@
((or) or-macro)
((and) and-macro)
((let*) let*-macro)
((let-values) let-values-macro)
((let*-values) let*-values-macro)
((syntax-rules) syntax-rules-macro)
((quasiquote) quasiquote-macro)
((quasisyntax) quasisyntax-macro)