suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

r5rs niternal definitions as r5rs letrec instead mz letrec

Browse Source 
svn: r9286
This commit is contained in:
Matthew Flatt 2008-04-13 21:59:02 +00:00
parent aa1a56c3fd
commit b372856777
1 changed files with 149 additions and 35 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

184
collects/r5rs/main.ss
View File

@ -1,7 +1,7 @@
(module main scheme/base (module main scheme/base
(require scheme/mpair (require scheme/mpair
(for-syntax scheme/base) (for-syntax scheme/base syntax/kerncase)
(only-in mzscheme transcript-on transcript-off)) (only-in mzscheme transcript-on transcript-off))
(provide (for-syntax syntax-rules ...) (provide (for-syntax syntax-rules ...)
@ -227,47 +227,60 @@
;; Copied from R5rS, but with an added `let' around body, ;; Copied from R5rS, but with an added `let' around body,
;; and with optimization for precedure letrecs ;; and with optimization for precedure letrecs
(define undefined (letrec ([u u]) u)) (define undefined (letrec ([u u]) u))
(define-syntax r5rs:letrec (define-for-syntax (immediate-value? stx)
(syntax-rules (r5rs:lambda) (let ([v (syntax-e stx)])
((r5rs:letrec ((var1 (r5rs:lambda . _rest)) ...) body ...) (or (number? v)
(letrec ((var1 (r5rs:lambda . _rest)) ...) body ...)) (boolean? v)
(string? v)
(syntax-case stx (r5rs:lambda quote r5rs:quote #%datum)
[(r5rs:lambda . _rest) #t]
[(quote . _) #t]
[(r5rs:quote . _) #t]
[(#%datum . _) #t]
[_ #f]))))
(define-syntax (r5rs:letrec stx)
(syntax-case stx (r5rs:lambda)
((r5rs:letrec ((var1 rhs) ...) body ...)
(andmap immediate-value? (syntax->list #'(rhs ...)))
#'(letrec ((var1 rhs) ...) (r5rs:body body ...)))
((r5rs:letrec ((var1 init1) ...) body ...) ((r5rs:letrec ((var1 init1) ...) body ...)
(r5rs:letrec "generate_temp_names" #'(r5rs:letrec "generate_temp_names"
(var1 ...) (var1 ...)
() ()
((var1 init1) ...) ((var1 init1) ...)
body ...)) body ...))
((r5rs:letrec "generate_temp_names" ((r5rs:letrec "generate_temp_names"
() ()
(temp1 ...) (temp1 ...)
((var1 init1) ...) ((var1 init1) ...)
body ...) body ...)
(let ((var1 undefined) ...) #'(let ((var1 undefined) ...)
(let ((temp1 init1) ...) (let ((temp1 init1) ...)
(set! var1 temp1) (set! var1 temp1)
... ...
(let () (let ()
body ...)))) (r5rs:body
body ...)))))
((r5rs:letrec "generate_temp_names" ((r5rs:letrec "generate_temp_names"
(x y ...) (x y ...)
(temp ...) (temp ...)
((var1 init1) ...) ((var1 init1) ...)
body ...) body ...)
(r5rs:letrec "generate_temp_names" #'(r5rs:letrec "generate_temp_names"
(y ...) (y ...)
(newtemp temp ...) (newtemp temp ...)
((var1 init1) ...) ((var1 init1) ...)
body ...)))) body ...))))
(define-syntax r5rs:lambda (define-syntax r5rs:lambda
;; Convert rest-arg list to mlist: ;; Convert rest-arg list to mlist:
(syntax-rules () (syntax-rules ()
[(_ (id ...) . body) [(_ (id ...) . body)
(#%plain-lambda (id ...) . body)] (#%plain-lambda (id ...) (r5rs:body . body))]
[(_ (id ... . rest) . body) [(_ (id ... . rest) . body)
(#%plain-lambda (id ... . rest) (#%plain-lambda (id ... . rest)
(let ([rest (list->mlist rest)]) (let ([rest (list->mlist rest)])
. body))])) (r5rs:body . body)))]))
(define-syntax (r5rs:define stx) (define-syntax (r5rs:define stx)
;; Use r5rs:lambda ;; Use r5rs:lambda
@ -283,6 +296,12 @@
(define . rest))])) (define . rest))]))
(define-syntax (r5rs:define-syntax stx) (define-syntax (r5rs:define-syntax stx)
;; Disallow in internal-definition contexts:
(when (pair? (syntax-local-context))
(raise-syntax-error
#f
"disallowed as an internal definition"
stx))
(syntax-case stx () (syntax-case stx ()
[(_ id expr) [(_ id expr)
(identifier? #'id) (identifier? #'id)
@ -316,6 +335,98 @@
(apply values (promise-p p))) (apply values (promise-p p)))
(apply values v)))) (apply values v))))
(define-syntax r5rs:let
(syntax-rules ()
[(_ (binding ...) . body)
(let (binding ...) (r5rs:body . body))]
[(_ id (binding ...) . body)
(let id (binding ...) (r5rs:body . body))]))
(define-syntax-rule (r5rs:let* bindings . body)
(let* bindings (r5rs:body . body)))
(define-syntax-rule (r5rs:let-syntax bindings . body)
(let-syntax bindings (r5rs:body . body)))
(define-syntax-rule (r5rs:letrec-syntax bindings . body)
(letrec-syntax bindings (r5rs:body . body)))
(define-syntax (r5rs:body stx)
(syntax-case stx (let)
[(_ (let () . body))
#'(let () . body)]
[_
;; Convert internal definitions to `r5rs:letrec', as opposed
;; to `letrec'.
(let ([def-ctx (syntax-local-make-definition-context)]
[ctx (list (gensym 'intdef))]
[kernel-forms (kernel-form-identifier-list)]
[init-exprs (let ([v (syntax->list stx)])
(unless v
(raise-syntax-error #f "bad syntax" stx))
(cdr v))])
(with-syntax ([(exprs ((id ...) ...) (rhs ...) (stx-ids ...) (stx-rhs ...))
(let loop ([exprs init-exprs]
[idss null][rhss null]
[stx-idss null][stx-rhss null])
(if (null? exprs)
(raise-syntax-error
#f
"no expression in body"
stx)
(let ([expr (local-expand (car exprs) ctx kernel-forms def-ctx)])
(syntax-case expr (begin define-syntaxes define-values)
[(begin . rest)
(let ([l (syntax->list #'rest)])
(if l
(loop (append l exprs) idss rhss stx-idss stx-rhss)
(raise-syntax-error #f expr "bad syntax")))]
[(define-syntaxes (id ...) rhs)
(andmap identifier? (syntax->list #'(id ...)))
(with-syntax ([rhs (local-transformer-expand
#'rhs
'expression
null)])
(syntax-local-bind-syntaxes
(syntax->list #'(id ...))
#'rhs def-ctx)
(loop (cdr exprs)
idss rhss
(cons #'(id ...) stx-idss)
(cons #'rhs stx-rhss)))]
[(define-values (id ...) rhs)
(andmap identifier? (syntax->list #'(id ...)))
(let ([ids (syntax->list #'(id ...))])
(syntax-local-bind-syntaxes ids #f def-ctx)
(loop (cdr exprs)
(cons #'(id ...) idss)
(cons #'rhs rhss)
stx-idss stx-rhss))]
[else
(list (cons expr
(map (lambda (expr)
(local-expand expr ctx kernel-forms def-ctx))
(cdr exprs)))
(reverse idss) (reverse rhss)
(reverse stx-idss) (reverse stx-rhss))]))))])
(if (and (null? (syntax-e #'(stx-rhs ...)))
(andmap (lambda (ids)
(= 1 (length (syntax->list ids))))
(syntax->list #'((id ...) ...))))
;; This is the normal case: use `r5rs:letrec':
#`(r5rs:letrec ([id ... rhs] ...)
(let () . exprs))
;; Unusual case: need to expand to `set!' manually:
(with-syntax ([((tmp-id ...) ...)
(map (lambda (ids)
(generate-temporaries ids))
(syntax->list #'((id ...) ...)))])
#`(letrec-syntaxes+values
([stx-ids stx-rhs] ...)
([(id ...) (values (mk-undefined id) ...)] ...)
(let-values ([(tmp-id ...) rhs] ...)
(begin (set! id tmp-id) ...) ...
. exprs))))))]))
(define-syntax-rule (mk-undefined id) undefined)
(provide unquote unquote-splicing (provide unquote unquote-splicing
(rename-out [r5rs:quote quote] (rename-out [r5rs:quote quote]
[r5rs:quasiquote quasiquote] [r5rs:quasiquote quasiquote]
@ -324,10 +435,13 @@
[r5rs:letrec letrec] [r5rs:letrec letrec]
[r5rs:define define] [r5rs:define define]
[r5rs:define-syntax define-syntax] [r5rs:define-syntax define-syntax]
[r5rs:delay delay]) [r5rs:delay delay]
let and or cond case do [r5rs:let let]
let* begin set! [r5rs:let* let*]
let-syntax letrec-syntax [r5rs:let-syntax let-syntax]
[r5rs:letrec-syntax letrec-syntax])
and or cond case do
begin set!
=> else => else
;; We have to include the following MzScheme-isms to do anything, ;; We have to include the following MzScheme-isms to do anything,