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

wrap module with the typed-scheme module-begin

Browse Source 
svn: r17316
This commit is contained in:
Jon Rafkind 2009-12-15 22:49:01 +00:00
parent a23c519ac8
commit 4f3f35a188
2 changed files with 14 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
collects/honu/private/honu-typed-scheme.ss
View File

@ -1,5 +1,6 @@
#lang scheme/base #lang scheme/base
(require (rename-in typed-scheme/minimal (#%module-begin #%module-begin-typed-scheme)))
(require (for-syntax scheme/base (require (for-syntax scheme/base
syntax/stx syntax/stx
syntax/parse syntax/parse
@ -18,6 +19,7 @@
(define-literal honu-return) (define-literal honu-return)
(begin-for-syntax (begin-for-syntax
(define-values (prop:honu-transformer honu-transformer? honu-transformer-ref) (define-values (prop:honu-transformer honu-transformer? honu-transformer-ref)
@ -83,9 +85,6 @@
(or (bound-transformer stx) (or (bound-transformer stx)
(special-transformer stx))) (special-transformer stx)))
(define (call-values function values-producing)
(call-with-values (lambda () values-producing) function))
;; these functions use parse-block-one ;; these functions use parse-block-one
;; (define parse-a-tail-expr #f) ;; (define parse-a-tail-expr #f)
;; (define parse-an-expr #f) ;; (define parse-an-expr #f)
@ -295,6 +294,7 @@
(parse-expr (syntax->list #'(expr ...)))] (parse-expr (syntax->list #'(expr ...)))]
[else (parse-expr expr-stxs)])) [else (parse-expr expr-stxs)]))
(define (parse-block-one context body combine-k done-k) (define (parse-block-one context body combine-k done-k)
(define (parse-one expr-stxs after-expr terminator) (define (parse-one expr-stxs after-expr terminator)
(define (checks) (define (checks)
@ -331,6 +331,10 @@
) )
(define (show-top-result v)
(unless (void? v)
(printf "~s\n" v)))
(define-syntax (honu-unparsed-begin stx) (define-syntax (honu-unparsed-begin stx)
(syntax-case stx () (syntax-case stx ()
[(_) #'(begin)] [(_) #'(begin)]
@ -344,4 +348,6 @@
#'(begin code (honu-unparsed-begin rest ...))))])) #'(begin code (honu-unparsed-begin rest ...))))]))
(define-syntax-rule (#%dynamic-honu-module-begin forms ...) (define-syntax-rule (#%dynamic-honu-module-begin forms ...)
(#%module-begin-typed-scheme (honu-unparsed-begin forms ...))
#;
(#%plain-module-begin (honu-unparsed-begin forms ...))) (#%plain-module-begin (honu-unparsed-begin forms ...)))

6
collects/honu/private/util.ss
View File

@ -2,7 +2,8 @@
(provide delim-identifier=? (provide delim-identifier=?
extract-until) extract-until
call-values)
(require syntax/stx) (require syntax/stx)
@ -29,6 +30,9 @@
(loop (stx-cdr r) (cons (stx-car r) val-stxs))]))] (loop (stx-cdr r) (cons (stx-car r) val-stxs))]))]
[(r ids) (extract-until r ids #f)])) [(r ids) (extract-until r ids #f)]))
(define-syntax-rule (call-values function values-producing)
(call-with-values (lambda () values-producing) function))
(define (test) (define (test)
(let* ([original #'(a b c d e)] (let* ([original #'(a b c d e)]
[delimiter #'c] [delimiter #'c]