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.

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

@ -26,14 +26,14 @@
[else [else
(let ([a (f (car ls))]) (let ([a (f (car ls))])
(cons a (map1ltr f (cdr ls))))])) (cons a (map1ltr f (cdr ls))))]))
(define pretty-width (define pretty-width
(make-parameter 60 (make-parameter 60
(lambda (x) (lambda (x)
(unless (and (exact? x) (integer? x) (> x 0)) (unless (and (exact? x) (integer? x) (> x 0))
(error 'pretty-width "invalid argument" x)) (error 'pretty-width "invalid argument" x))
x))) x)))
(define (pretty-indent) 1) (define (pretty-indent) 1)
(define-struct cbox (length boxes)) (define-struct cbox (length boxes))
(define-struct pbox (length ls last)) (define-struct pbox (length ls last))
@ -463,7 +463,7 @@
(f x p 0) (f x p 0)
(newline p)) (newline p))
;;; ;;;
(define (hasher x h) (define (hasher x h)
(define (vec-graph x i j) (define (vec-graph x i j)
(unless (fx= i j) (unless (fx= i j)
@ -532,10 +532,10 @@
(graph x) (graph x)
(dynamic x)) (dynamic x))
rv) rv)
(define-struct setbox (idx data)) (define-struct setbox (idx data))
(define-struct refbox (idx)) (define-struct refbox (idx))
(define (rewrite-shared x h) (define (rewrite-shared x h)
(define counter 0) (define counter 0)
(let f ([x x]) (let f ([x x])
@ -589,7 +589,7 @@
[else [else
(list->vector (map1ltr f (vector->list x)))])] (list->vector (map1ltr f (vector->list x)))])]
[else x]))) [else x])))
(define (unshare x) (define (unshare x)
(let ([h (make-eq-hashtable)]) (let ([h (make-eq-hashtable)])
(if (hasher x h) (if (hasher x h)
@ -618,11 +618,12 @@
(set-fmt! 'quasisyntax '(read-macro . "#`")) (set-fmt! 'quasisyntax '(read-macro . "#`"))
(set-fmt! 'unsyntax '(read-macro . "#,")) (set-fmt! 'unsyntax '(read-macro . "#,"))
(set-fmt! 'unsyntax-splicing '(read-macro . "#,@")) (set-fmt! 'unsyntax-splicing '(read-macro . "#,@"))
(set-fmt! '|#primitive| '(read-macro . "#%")) ;(set-fmt! '|#primitive| '(read-macro . "#%"))
(set-fmt! 'let '(alt (set-fmt! 'let '(alt
(_ (0 [e 0 e] ...) tab e ...) (_ (0 [e 0 e] ...) tab e ...)
(_ x (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! 'letrec* '(_ (0 [e 0 e] ...) tab e ...))
(set-fmt! 'let-syntax '(_ (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! 'letrec-syntax '(_ (0 [e 0 e] ...) tab e ...))
(set-fmt! 'let* '(_ (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)] [unless (core-macro . unless)]
[parameterize (core-macro . parameterize)] [parameterize (core-macro . parameterize)]
[case (core-macro . case)] [case (core-macro . case)]
[let-values (core-macro . let-values)]
[record-type-descriptor (core-macro . record-type-descriptor)] [record-type-descriptor (core-macro . record-type-descriptor)]
[record-constructor-descriptor (core-macro . record-constructor-descriptor)] [record-constructor-descriptor (core-macro . record-constructor-descriptor)]
[let-values (macro . let-values)]
[let*-values (macro . let*-values)]
[define-struct (macro . define-struct)] [define-struct (macro . define-struct)]
[include (macro . include)] [include (macro . include)]
[include-into (macro . include-into)] [include-into (macro . include-into)]
@ -590,7 +591,7 @@
[if i r ba se ne] [if i r ba se ne]
[let i r ba se ne] [let 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-syntax i r ba se ne]
[let-values i r ba] [let-values i r ba]
[letrec i r ba se ne] [letrec i r ba se ne]

119
scheme/psyntax.expander.ss
View File

@ -787,33 +787,6 @@
(add-lexicals (cdr lab*) (cdr lex*) (add-lexicals (cdr lab*) (cdr lex*)
(add-lexical (car lab*) (car lex*) r)))))) (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 (define letrec-helper
(lambda (e r mr build) (lambda (e r mr build)
(syntax-match e () (syntax-match e ()
@ -846,7 +819,6 @@
(stx-error e "invalid type")) (stx-error e "invalid type"))
(build-data no-source (binding-value b))))))) (build-data no-source (binding-value b)))))))
(define record-type-descriptor-transformer (define record-type-descriptor-transformer
(lambda (e r mr) (lambda (e r mr)
(syntax-match e () (syntax-match e ()
@ -1021,6 +993,94 @@
(,f . ,rhs*))) (,f . ,rhs*)))
(invalid-fmls-error stx lhs*)))))) (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 (define trace-lambda-macro
(lambda (stx) (lambda (stx)
(syntax-match stx () (syntax-match stx ()
@ -2253,7 +2313,6 @@
((quote) quote-transformer) ((quote) quote-transformer)
((lambda) lambda-transformer) ((lambda) lambda-transformer)
((case-lambda) case-lambda-transformer) ((case-lambda) case-lambda-transformer)
((let-values) let-values-transformer)
((letrec) letrec-transformer) ((letrec) letrec-transformer)
((letrec*) letrec*-transformer) ((letrec*) letrec*-transformer)
((case) case-transformer) ((case) case-transformer)
@ -2298,6 +2357,8 @@
((or) or-macro) ((or) or-macro)
((and) and-macro) ((and) and-macro)
((let*) let*-macro) ((let*) let*-macro)
((let-values) let-values-macro)
((let*-values) let*-values-macro)
((syntax-rules) syntax-rules-macro) ((syntax-rules) syntax-rules-macro)
((quasiquote) quasiquote-macro) ((quasiquote) quasiquote-macro)
((quasisyntax) quasisyntax-macro) ((quasisyntax) quasisyntax-macro)