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

299.107

Browse Source 
svn: r259

original commit: 0d4bc2cd9d93b05203f70cccdaf832babee3a4cd
This commit is contained in:
Matthew Flatt 2005-06-28 17:01:03 +00:00
parent a4bc5b8995
commit f5ea87030c
8 changed files with 524 additions and 358 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

48
collects/mzlib/etc.ss
View File

@ -525,8 +525,10 @@
;; Body can have mixed exprs and defns. Wrap expressions with
;; `(define-values () ... (values))' as needed, and add a (void)
;; at the end if needed.
(let* ([ctx (generate-expand-context)]
[kernel-forms (kernel-form-identifier-list #'here)]
(let* ([def-ctx (syntax-local-make-definition-context)]
[ctx (list (gensym 'intdef))]
[kernel-forms (kernel-form-identifier-list
(quote-syntax here))]
[init-exprs (let ([v (syntax->list stx)])
(unless v
(raise-syntax-error #f "bad syntax" stx))
@ -538,27 +540,45 @@
(let ([expr (local-expand
expr
ctx
kernel-forms)])
(syntax-case expr (begin)
kernel-forms
def-ctx)])
(syntax-case expr (begin define-syntaxes define-values)
[(begin . rest)
(loop (syntax->list #'rest))]
[(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)
(list #'(define-syntaxes (id ...) rhs)))]
[(define-values (id ...) rhs)
(andmap identifier? (syntax->list #'(id ...)))
(let ([ids (syntax->list #'(id ...))])
(syntax-local-bind-syntaxes ids #f def-ctx)
(list expr))]
[else
(list expr)])))
exprs)))])
#`(let ()
#,@(let loop ([exprs exprs][prev-defns null][prev-exprs null])
(let loop ([exprs exprs][prev-stx-defns null][prev-defns null][prev-exprs null])
(cond
[(null? exprs) (append
(reverse prev-defns)
(reverse prev-exprs)
(if (null? prev-exprs)
[(null? exprs)
#`(letrec-syntaxes+values
#,(map stx-cdr (reverse prev-stx-defns))
#,(map stx-cdr (reverse prev-defns))
#,@(if (null? prev-exprs)
(list #'(void))
null))]
(reverse prev-exprs)))]
[(and (stx-pair? (car exprs))
(identifier? (stx-car (car exprs)))
(or (module-identifier=? #'define-values (stx-car (car exprs)))
(module-identifier=? #'define-syntaxes (stx-car (car exprs)))))
(module-identifier=? #'define-syntaxes (stx-car (car exprs))))
(loop (cdr exprs) (cons (car exprs) prev-stx-defns) prev-defns prev-exprs)]
[(and (stx-pair? (car exprs))
(identifier? (stx-car (car exprs)))
(module-identifier=? #'define-values (stx-car (car exprs))))
(loop (cdr exprs)
prev-stx-defns
(cons (car exprs)
(append
(map (lambda (expr)
@ -567,7 +587,7 @@
prev-defns))
null)]
[else
(loop (cdr exprs) prev-defns (cons (car exprs) prev-exprs))])))))
(loop (cdr exprs) prev-stx-defns prev-defns (cons (car exprs) prev-exprs))]))))
(define-syntax (begin-lifted stx)
(syntax-case stx ()

83
collects/mzlib/private/sigutil.ss
View File

@ -16,7 +16,7 @@
elems ; list of syms and signatures
ctxs ; list of stx
structs)) ; list of struct-infos
(define-struct parsed-unit (imports renames vars stxes body stx-checks))
(define-struct parsed-unit (imports renames vars import-vars body stx-checks))
(define-struct struct-def (name super-name names))
@ -528,7 +528,10 @@
(let ([vars (map syntax-e (parsed-unit-vars a-unit))])
(for-each
(lambda (var)
(let ([renamed (do-rename var renames)])
(let ([renamed (let ([s (do-rename var renames)])
(if (syntax? s)
(syntax-e s)
s))])
(unless (memq renamed vars)
(syntax-error #f expr
(format
@ -578,7 +581,7 @@
clause)))))
(define parse-unit
(lambda (expr body sig user-stx-forms dv-stx begin-stx)
(lambda (expr body sig user-stx-forms dv-stx ds-stx begin-stx)
(let ([body (stx->list body)])
(unless body
(syntax-error #f expr "illegal use of `.'"))
@ -590,12 +593,22 @@
(let* ([imports (parse-imports 'unit/sig #t #t expr (stx-cdr (car body)) #t)]
[imported-names (flatten-signatures imports #f)]
[exported-names (flatten-signature #f sig #f)]
[def-ctx (syntax-local-make-definition-context)]
[body (cdr body)])
(let-values ([(renames body)
(if (and (stx-pair? body)
(stx-pair? (car body))
(eq? 'rename (syntax-e (stx-car (car body)))))
(values (map syntax-object->datum (cdr (stx->list (car body)))) (cdr body))
(values (map (lambda (p)
(list (stx-car p)
(syntax-e (stx-car (stx-cdr p)))))
(cdr (stx->list
(let ([rn (car body)])
(local-expand rn
'expression
(list (stx-car rn))
def-ctx)))))
(cdr body))
(values null body))])
(unless renames
(syntax-error #f expr "illegal use of `.'" (car body)))
@ -635,14 +648,29 @@
(loop (cdr e))
(cons (car e) (loop (cdr e)))))))]
[local-vars (append renamed-internals filtered-exported-names imported-names)]
[expand-context (generate-expand-context)])
(let loop ([pre-lines null][lines body][port #f][port-name #f][body null][vars null])
[expand-context (generate-expand-context)]
[import-stxes (apply append (map (lambda (i)
(map
(lambda (d)
(datum->syntax-object expr d))
(make-struct-stx-decls i #f #t expr #f)))
imports))]
[import-vars
(let ([vars (map (lambda (sym) (datum->syntax-object expr sym expr))
(flatten-signatures imports 'must-have-ctx))])
;; Treat imported names like internal definitions:
(syntax-local-bind-syntaxes vars #f def-ctx)
(cdr (syntax->list (local-expand #`(stop #,@vars)
'expression
(list #'stop)
def-ctx))))])
(let loop ([pre-lines null][lines (append import-stxes body)][port #f][port-name #f][body null][vars null])
(cond
[(and (null? pre-lines) (not port) (null? lines))
(make-parsed-unit imports
renames
vars
(lambda (src-stx) (apply append (map (lambda (i) (make-struct-stx-decls i #f #t src-stx #f)) imports)))
import-vars
body
(lambda (src-stx)
;; Disabled until we have a mechanism for declaring precise information in signatures:
@ -661,7 +689,8 @@
expand-context
(append
user-stx-forms
local-vars))))]
local-vars)
def-ctx)))]
[(rest-pre-lines)
(if (null? pre-lines)
null
@ -679,17 +708,48 @@
(identifier? (stx-car line))
(module-identifier=? (stx-car line) dv-stx))
(syntax-case line ()
[(_ (id ...) expr)
[(_ (id ...) rhs)
(let ([ids (syntax->list #'(id ...))])
(for-each (lambda (id)
(unless (identifier? #'id)
(syntax-error #f id "not an identifier" line)))
ids)
(syntax-local-bind-syntaxes ids #f def-ctx)
(loop rest-pre-lines
rest-lines
port
port-name
(cons line body)
(append (syntax->list (syntax (id ...))) vars))]
(append ids vars)))]
[else
(syntax-error #f expr
"improper `define-values' clause form"
line)])]
[(and (stx-pair? line)
(identifier? (stx-car line))
(module-identifier=? (stx-car line) ds-stx))
(syntax-case line ()
[(_ (id ...) rhs)
(let ([ids (syntax->list #'(id ...))])
(for-each (lambda (id)
(unless (identifier? #'id)
(syntax-error #f id "not an identifier" line)))
ids)
(with-syntax ([rhs (local-transformer-expand
#'rhs
'expression
null)])
(syntax-local-bind-syntaxes ids #'rhs def-ctx)
(loop rest-pre-lines
rest-lines
port
port-name
(cons line body)
vars)))]
[else
(syntax-error #f expr
"improper `define-syntaxes' clause form"
line)])]
[(and (stx-pair? line)
(identifier? (stx-car line))
(module-identifier=? (stx-car line) begin-stx))
@ -1148,9 +1208,10 @@
parsed-unit-renames
parsed-unit-imports
parsed-unit-stxes
parsed-unit-import-vars
parsed-unit-body
parsed-unit-stx-checks
parsed-unit-vars
make-struct-stx-decls
verify-struct-shape

2
collects/mzlib/process.ss
View File

@ -28,7 +28,7 @@
(build-path d 'up "command.com"))))))])
(list cmd
'exact
(format "~a /c ~a" (path->string cmd) argstr))))
(format "~a /c \"~a\"" (path->string cmd) argstr))))
(else (raise-mismatch-error
who
(format "~a: don't know what shell to use for platform: " who)

7
collects/mzlib/serialize.ss
View File

@ -357,9 +357,7 @@
#,(generate-struct-declaration stx
id super-id field-ids
(syntax-local-context)
(make-make-make-struct-type #'(inspector-expr deserializer-id))
#'continue-define-serializable-struct
#'(inspector-expr deserializer-id))
(make-make-make-struct-type #'(inspector-expr deserializer-id)))
(define deserializer-id (let ([l (internal-deserialize-info struct-type-id)])
(make-deserialize-info
((car l))
@ -404,9 +402,6 @@
(context-check stx)
(main/versions stx)))))
(define-syntax (continue-define-serializable-struct stx)
(generate-delayed-struct-declaration stx make-make-make-struct-type))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; serialize
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

6
collects/mzlib/struct.ss
View File

@ -163,14 +163,10 @@
(generate-struct-declaration stx
id sup-id fields
(syntax-local-context)
(make-make-make-struct-type props+insp)
#'continue-ds/p props+insp)))
(make-make-make-struct-type props+insp))))
(parse-at-main))
(define-syntax (continue-ds/p stx)
(generate-delayed-struct-declaration stx make-make-make-struct-type))
;; ------------------------------------------------------------
;; make->vector

84
collects/mzlib/unit.ss
View File

@ -37,8 +37,9 @@
;; ----------------------------------------------------------------------
;; The `unit' syntactic form
(define-syntax :unit
(lambda (stx)
(define-syntaxes (:unit unit/no-expand)
(let ([do-unit
(lambda (stx expand?)
(syntax-case stx (import export)
[(_ (import ivar ...)
(export evar ...)
@ -53,27 +54,47 @@
[check-renamed-id
(lambda (v)
(syntax-case v ()
[id (identifier? (syntax id)) 'ok]
[id (identifier? (syntax id)) (list v)]
[(lid eid) (and (identifier? (syntax lid))
(identifier? (syntax eid))) 'ok]
(identifier? (syntax eid)))
(list #'lid #'eid)]
[else (raise-syntax-error
#f
"export is not an identifier or renamed identifier"
stx
v)]))]
[expand-context (generate-expand-context)]
[ivars (syntax->list (syntax (ivar ...)))]
[def-ctx (and expand?
(syntax-local-make-definition-context))]
[localify (lambda (ids def-ctx)
(if (andmap identifier? ids)
;; In expand mode, add internal defn context
(if expand?
(begin
;; Treat imports as internal-defn names:
(syntax-local-bind-syntaxes ids #f def-ctx)
(cdr (syntax->list
(local-expand #`(stop #,@ids)
'expression
(list #'stop)
def-ctx))))
ids)
;; Let later checking report an error:
ids))])
(let ([ivars (localify (syntax->list (syntax (ivar ...))) def-ctx)]
[evars (syntax->list (syntax (evar ...)))])
(for-each check-id ivars)
(for-each check-renamed-id evars)
;; Get import/export declared names:
(let* ([exported-names
(localify
(map (lambda (v)
(syntax-case v ()
[(lid eid) (syntax lid)]
[id (syntax id)]))
evars)]
evars)
def-ctx)]
[extnames (map (lambda (v)
(syntax-case v ()
[(lid eid) (syntax eid)]
@ -96,22 +117,21 @@
;; Expand all body expressions
;; so that all definitions are exposed.
(letrec ([expand-all
(if expand?
(lambda (defns&exprs)
(let ([expanded
(apply
append
(map
(lambda (defn-or-expr)
(let ([defn-or-expr
(local-expand
defn-or-expr
expand-context
(append
(kernel-form-identifier-list (quote-syntax here))
declared-names)))
defns&exprs)])
(apply
append
(map
(lambda (defn-or-expr)
(syntax-case defn-or-expr (begin)
declared-names)
def-ctx)])
(syntax-case defn-or-expr (begin define-values define-syntaxes)
[(begin . l)
(let ([l (syntax->list (syntax l))])
(unless l
@ -122,8 +142,22 @@
(expand-all (map (lambda (s)
(syntax-track-origin s defn-or-expr #'begin))
l)))]
[else (list defn-or-expr)]))
expanded))))])
[(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)
(list #'(define-syntaxes (id ...) rhs)))]
[(define-values (id ...) rhs)
(andmap identifier? (syntax->list #'(id ...)))
(begin
(syntax-local-bind-syntaxes (syntax->list #'(id ...)) #f def-ctx)
(list defn-or-expr))]
[else (list defn-or-expr)])))
defns&exprs)))
values)])
(let ([all-expanded (expand-all (syntax->list (syntax (defn&expr ...))))])
;; Get all the defined names, sorting out variable definitions
;; from syntax definitions.
@ -224,7 +258,8 @@
(loop (cdr l))]
[else (cons (car l) (loop (cdr l)))]))])
;; Generate names for import/export boxes, etc:
(with-syntax ([(iloc ...) (generate-temporaries (syntax (ivar ...)))]
(with-syntax ([(ivar ...) ivars]
[(iloc ...) (generate-temporaries ivars)]
[(eloc ...) (generate-temporaries evars)]
[(extname ...) extnames]
[(expname ...) exported-names]
@ -288,7 +323,7 @@
values
(map (lambda (defn-or-expr)
(syntax-case defn-or-expr (define-syntaxes)
[(define-syntaxes . l) defn-or-expr]
[(define-syntaxes . l) #'l]
[else #f]))
all-expanded))])
;; Build up set! redirection chain:
@ -321,11 +356,13 @@
(let ([eloc (box undefined)] ...)
(list (vector eloc ...)
(lambda (iloc ...)
(let ([intname undefined] ...)
(letrec-syntaxes+values redirections ()
stx-defn ...
(letrec-syntaxes+values
(stx-defn ... . redirections)
([(intname) undefined] ...)
(void) ; in case the body would be empty
defn&expr ...))))))))))))))))))])))
defn&expr ...))))))))))))))))))]))])
(values (lambda (stx) (do-unit stx #t))
(lambda (stx) (do-unit stx #f)))))
;; ----------------------------------------------------------------------
;; check-expected-interface: used by the expansion of `compound-unit'
@ -824,7 +861,8 @@
(syntax (define-values (tagged-export ...) invoke-unit)))))))])))])
(values (mk #f) (mk #t))))
(provide (rename :unit unit) compound-unit invoke-unit unit?
(provide (rename :unit unit) unit/no-expand
compound-unit invoke-unit unit?
(struct exn:fail:unit ())
define-values/invoke-unit

19
collects/mzlib/unitsig.ss
View File

@ -44,29 +44,32 @@
(let ([a-unit (parse-unit expr (syntax rest) sig
(kernel-form-identifier-list (quote-syntax here))
(quote-syntax define-values)
(quote-syntax define-syntaxes)
(quote-syntax begin))])
(check-signature-unit-body sig a-unit (parsed-unit-renames a-unit) 'unit/sig expr)
(with-syntax ([imports (datum->syntax-object
expr
(flatten-signatures (parsed-unit-imports a-unit) 'must-have-ctx)
expr)]
(with-syntax ([imports (parsed-unit-import-vars a-unit)]
[exports (datum->syntax-object
expr
(let ([vars (make-hash-table)])
(for-each (lambda (var)
(hash-table-put! vars (syntax-e var) var))
(parsed-unit-vars a-unit))
(map
(lambda (name)
(list (do-rename name (parsed-unit-renames a-unit))
(list (hash-table-get vars
name
(lambda () (do-rename name (parsed-unit-renames a-unit))))
name))
(signature-vars sig))
(signature-vars sig)))
expr)]
[body (append
((parsed-unit-stxes a-unit) expr)
(reverse! (parsed-unit-body a-unit))
((parsed-unit-stx-checks a-unit) expr))]
[import-sigs (explode-named-sigs (parsed-unit-imports a-unit) #f)]
[export-sig (explode-sig sig #f)])
(syntax/loc expr
(make-signed-unit
(unit
(unit/no-expand
(import . imports)
(export . exports)
. body)

53
collects/tests/mzscheme/etc.ss Normal file
View File

@ -0,0 +1,53 @@
(load-relative "loadtest.ss")
(SECTION 'etc)
(require (lib "etc.ss"))
(let ()
(begin-with-definitions
(define-syntax (goo stx)
(syntax-case stx ()
[(_ foo) #'(define-syntax (foo stx) (syntax-case stx () [(_ x) #'(define x 12)]))]))
(goo foo)
(foo x)
(test 12 'bwd x)))
(let-syntax ([goo (lambda (stx) #'(begin (define z 13) (test 13 'bwd z)))])
(let-syntax ([y (lambda (stx) #'goo)])
(let ()
(begin-with-definitions
(define-syntax (goo stx)
(syntax-case stx ()
[(_ foo) #'(define-syntax (foo stx) (syntax-case stx () [(_ x) #'(define x 12)]))]))
(goo foo)
(foo x)
y
(test 12 'bwd x)))))
(let ()
(begin-with-definitions
(define-struct a (b c))
(test 2 'bwd (a-c (make-a 1 2)))))
(let ()
(begin-with-definitions
(define-struct a (b c))
(let ()
(define-struct (d a) (e))
(test 3 'bwd (d-e (make-d 1 2 3))))))
(let ()
(begin-with-definitions
(define-struct a (b c))
(define-struct (d a) (e))
(test 3 'bwd (d-e (make-d 1 2 3)))))
(syntax-test #'(begin-with-definitions
(define-syntax goo 10)
(define goo 10)
12))
(report-errs)