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

.

Browse Source 
original commit: 2b3f148a039ebb3f77d438efecd2b74506882dea
This commit is contained in:
Matthew Flatt 2001-03-02 22:15:45 +00:00
parent c74ae594a4
commit 61a1937d96
11 changed files with 109 additions and 83 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
collects/mzlib/class.ss
View File

@ -752,12 +752,13 @@
[body-exprs (if (null? body-exprs)
(syntax ((void)))
body-exprs)]
[init (datum->syntax
[init (datum->syntax-object
#f
(if name
(string->symbol (format "~a-init" name))
'init)
#f #f)]
[name (datum->syntax name #f #f)])
#f)]
[name (datum->syntax-object #f name #f)])
(with-syntax ([go
;; Create a sequence of case-lambda
;; clauses, to implement init variable defaults:
@ -801,7 +802,8 @@
(syntax ([(var ... wd-var ...) (init var ... wd-var ... needs-init)]
. rest)))
(syntax rest)))]))]
[go-arity (datum->syntax
[go-arity (datum->syntax-object
#f
(let ([req (let loop ([l init-defs][c 0])
(if (or (null? l) (car l))
c
@ -816,7 +818,7 @@
(list req)
(cons req (loop (add1 req)))))]
[else req]))
#f #f)])
#f)])
;; Assemble the result as a `compose-class-info' call,
;; which does all the run-time checks, and knows how
;; to allocate objects and pass boxes to the init
@ -919,8 +921,8 @@
(interface-expr ...)
init-vars
clauses ...)
(with-syntax ([this (datum->syntax 'this stx (stx-car stx))]
[super-init (datum->syntax 'super-init stx (stx-car stx))])
(with-syntax ([this (datum->syntax-object (stx-car stx) 'this stx)]
[super-init (datum->syntax-object (stx-car stx) 'super-init stx)])
(syntax/loc
stx
(class*/names (this super-init)
@ -935,7 +937,7 @@
[(_ super-expr
init-vars
clauses ...)
(with-syntax ([class* (datum->syntax 'class* stx (stx-car stx))])
(with-syntax ([class* (datum->syntax-object (stx-car stx) 'class* stx)])
(syntax/loc stx (class* super-expr () init-vars clauses ...)))])))
(define-syntax class*-asi
@ -972,7 +974,7 @@
"duplicate name"
stx
dup)))
(with-syntax ([name (datum->syntax name #f #f)])
(with-syntax ([name (datum->syntax-object #f name #f)])
(syntax/loc
stx
(compose-interface

12
collects/mzlib/cmdline.ss
View File

@ -27,11 +27,13 @@
(lambda (l)
(map
(lambda (a)
(datum->syntax (let ([s (symbol->string (syntax-e a))])
(if (char=? #\* (string-ref s (sub1 (string-length s))))
(substring s 0 (sub1 (string-length s)))
s))
#f (quote-syntax here)))
(datum->syntax-object
(quote-syntax here)
(let ([s (symbol->string (syntax-e a))])
(if (char=? #\* (string-ref s (sub1 (string-length s))))
(substring s 0 (sub1 (string-length s)))
s))
#f))
l))])
(let ([clauses
(let loop ([csrcs (syntax->list (syntax (clause ...)))][clauses null])

6
collects/mzlib/compat.ss
View File

@ -94,8 +94,10 @@
(map syntax-e
(syntax->list (syntax (init-field ...)))))]
[+ (lambda args
(datum->syntax (string->symbol (apply string-append args))
(syntax sname) (syntax sname)))])
(datum->syntax-object
(syntax sname)
(string->symbol (apply string-append args))
(syntax sname)))])
(with-syntax ([struct: (+ "struct:" name)]
[make- (+ "make-" name)]
[? (+ name "?")]

26
collects/mzlib/include.ss
View File

@ -18,7 +18,7 @@
(module-identifier=? e (quote-syntax up))
(module-identifier=? e (quote-syntax same))))
(syntax->list (syntax (elem1 elem ...))))
(apply build-path (syntax->datum (syntax (elem1 elem ...))))])])
(apply build-path (syntax-object->datum (syntax (elem1 elem ...))))])])
;; Complete the file name
(let ([c-file
(if (complete-path? file)
@ -83,22 +83,22 @@
[(null? content) null]
[else
(let ([v (syntax-e content)])
(datum->syntax
(datum->syntax-object
stx
(cond
[(pair? v)
(loop v)]
[(vector? v)
(list->vector (loop (vector->list v)))]
[(box? v)
(box (loop (unbox v)))]
[else
v])
content
stx))]))])
(datum->syntax
[(vector? v)
(list->vector (loop (vector->list v)))]
[(box? v)
(box (loop (unbox v)))]
[else
v])
content))]))])
(datum->syntax-object
(quote-syntax here)
`(begin ,@lexed-content)
stx
(quote-syntax here)))))))))
stx))))))))
(provide include))

19
collects/mzlib/match.ss
View File

@ -134,7 +134,7 @@
(define (i v) (match:syntax-err p (format "illegal use of ~a" v)))
(syntax-case p (_ quote $ ? and or not set! get! quasiquote ... ___)
[_ '_]
[(quote x) `(quote ,(syntax->datum (syntax x)))]
[(quote x) `(quote ,(syntax-object->datum (syntax x)))]
[(quote . _) (i "quote")]
[($ struct p ...)
`($ struct ,@(r (syntax (p ...))))]
@ -199,7 +199,7 @@
`(,(parse-quasipattern (syntax p)) ,(syntax-e (syntax ..k)))]
[(i . rest)
(identifier? (syntax i))
`(,(syntax->datum (syntax i)) ,@(parse-quasipattern (syntax rest)))]
`(,(syntax-object->datum (syntax i)) ,@(parse-quasipattern (syntax rest)))]
[(qp . rest)
`(,(parse-quasipattern (syntax qp)) ,@(parse-quasipattern (syntax rest)))]
[_else
@ -218,7 +218,8 @@
(syntax-case stx ()
[(_ exp clause ...)
(with-syntax ([body
(datum->syntax
(datum->syntax-object
(quote-syntax here)
(genmatch
(quote-syntax mv)
(map
@ -237,7 +238,7 @@
"bad match clause")]))
(syntax->list (syntax (clause ...))))
stx)
stx (quote-syntax here))])
stx)])
(syntax
(let ([mv exp])
body)))])))
@ -274,20 +275,22 @@
(lambda (stx)
(syntax-case stx ()
[(_ ([pat exp] ...) body1 body ...)
(datum->syntax
(datum->syntax-object
(quote-syntax here)
(genletrec
(map (lambda (p) (:ucall parse-pattern p)) (syntax->list (syntax (pat ...))))
(syntax->list (syntax (exp ...)))
(syntax->list (syntax (body1 body ...)))
stx)
stx (quote-syntax here))])))
stx)])))
(define-syntax match-define
(lambda (stx)
(syntax-case stx ()
[(_ pat exp)
(datum->syntax
(datum->syntax-object
(quote-syntax here)
(gendefine (map (lambda (p) (:ucall parse-pattern p)) (syntax pat))
(syntax exp)
stx)
stx (quote-syntax here))]))))
stx)]))))

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

@ -93,7 +93,7 @@
(map (lambda (n)
(if (syntax? n)
n
(datum->syntax n #f #f)))
(datum->syntax-object #f n #f)))
names))])
(when dup
(error-k dup)))))
@ -104,7 +104,7 @@
[fields (map symbol->string (map syntax-e fields))]
[+ string-append])
(map (lambda (s)
(datum->syntax (string->symbol s) #f name-stx))
(datum->syntax-object name-stx (string->symbol s) #f))
(append
(list
(+ "make-" name)
@ -430,7 +430,7 @@
(if (and (stx-pair? body)
(stx-pair? (car body))
(eq? 'rename (syntax-e (stx-car (car body)))))
(values (map syntax->datum (cdr (stx->list (car body)))) (cdr body))
(values (map syntax-object->datum (cdr (stx->list (car body)))) (cdr body))
(values null body))])
(unless renames
(syntax-error 'unit/sig expr "illegal use of `.'" (car body)))

8
collects/mzlib/private/unitidmap.ss
View File

@ -2,7 +2,7 @@
(module unitidmap mzscheme
(define (make-id-mapper unbox-stx)
(let ([set!-stx (datum->syntax 'set! #f unbox-stx)])
(let ([set!-stx (datum->syntax-object unbox-stx 'set! #f)])
(make-set!-transformer
(lambda (sstx)
(cond
@ -13,10 +13,10 @@
"cannot set! imported or exported variables"
sstx)]
[else
(datum->syntax
(datum->syntax-object
set!-stx
(cons unbox-stx (cdr (syntax-e sstx)))
sstx
set!-stx)])))))
sstx)])))))
(provide make-id-mapper))

2
collects/mzlib/shared.ss
View File

@ -64,7 +64,7 @@
(let loop ([l l][n 0])
(if (null? l)
null
(cons (datum->syntax n #f (quote-syntax here))
(cons (datum->syntax-object (quote-syntax here) n #f)
(loop (cdr l) (add1 n))))))])
(map (lambda (name expr)
(with-syntax ([name name])

5
collects/mzlib/trace.ss
View File

@ -164,11 +164,12 @@
ids)
(with-syntax ([(traced-name ...)
(map (lambda (id)
(datum->syntax
(datum->syntax-object
id
(string->symbol
(string-append "traced-"
(symbol->string (syntax-e id))))
#f id))
#f))
ids)])
(syntax
(begin

48
collects/mzlib/unit.ss
View File

@ -238,9 +238,10 @@
[var (make-id-mapper (quote-syntax (unbox loc)))])))
(syntax->list
(syntax ((ivar iloc) ... (expname eloc) ...))))]
[num-imports (datum->syntax
[num-imports (datum->syntax-object
(quote-syntax here)
(length (syntax->list (syntax (iloc ...))))
#f (quote-syntax here))])
#f)])
(syntax/loc
stx
(make-unit
@ -522,10 +523,10 @@
[id e])))])
(with-syntax ([ex-poss ex-poss]
[setup setup]
[pos (datum->syntax
[pos (datum->syntax-object
(quote-syntax here)
pos
#f
(quote-syntax here))])
#f)])
(syntax
(vector-ref (car setup)
(vector-ref ex-poss pos))))))
@ -543,18 +544,21 @@
[(import-mapping ...) import-mappings]
[(unit-import-count ...)
(map (lambda (l)
(datum->syntax (apply
+
(map (lambda (v)
(if (identifier? v)
1
(length (cdr (syntax->list v)))))
l))
#f
(quote-syntax here)))
(datum->syntax-object
(quote-syntax here)
(apply
+
(map (lambda (v)
(if (identifier? v)
1
(length (cdr (syntax->list v)))))
l))
#f))
linkages)]
[num-imports (datum->syntax (length imports)
#f (quote-syntax here))]
[num-imports (datum->syntax-object
(quote-syntax here)
(length imports)
#f)]
[export-names export-names]
[export-mapping export-mapping])
(syntax/loc
@ -598,9 +602,10 @@
[(_ unit-expr expr ...)
(let ([exprs (syntax (expr ...))])
(with-syntax ([(bx ...) (generate-temporaries (syntax (expr ...)))]
[num (datum->syntax (length (syntax->list exprs))
#f
(quote-syntax here))])
[num (datum->syntax-object
(quote-syntax here)
(length (syntax->list exprs))
#f)])
(syntax/loc
stx
(let ([u unit-expr])
@ -639,12 +644,13 @@
(syntax-e (syntax prefix)))
":")])
(map (lambda (s)
(datum->syntax
(datum->syntax-object
s
(string->symbol
(string-append
prefix
(symbol->string (syntax-e s))))
s s))
s))
(syntax->list (syntax exports))))
(syntax exports))]
[extract-unit (syntax (unit

40
collects/mzlib/unitsig.ss
View File

@ -42,16 +42,18 @@
(quote-syntax define-values)
(quote-syntax begin))])
(check-signature-unit-body sig a-unit (parse-unit-renames a-unit) 'unit/sig expr)
(with-syntax ([imports (datum->syntax
(with-syntax ([imports (datum->syntax-object
expr
(flatten-signatures (parse-unit-imports a-unit))
expr expr)]
[exports (datum->syntax
expr)]
[exports (datum->syntax-object
expr
(map
(lambda (name)
(list (do-rename name (parse-unit-renames a-unit))
name))
(signature-vars sig))
expr expr)]
expr)]
[body (reverse! (parse-unit-body a-unit))]
[import-sigs (explode-named-sigs (parse-unit-imports a-unit))]
[export-sig (explode-sig sig)])
@ -78,7 +80,7 @@
exploded-imports
exploded-exports)
(parse-compound-unit expr (syntax body))]
[(t) (lambda (l) (datum->syntax l expr expr))])
[(t) (lambda (l) (datum->syntax-object expr l expr))])
(with-syntax ([(tag ...) (t tags)]
[(uexpr ...) (t exprs)]
[(tagx ...) (t (map (lambda (t) (string->symbol (format "u:~a" t))) tags))]
@ -114,10 +116,14 @@
(syntax-case expr ()
[(_ u sig ...)
(let ([sigs (parse-invoke-vars 'invoke-unit/sig (syntax (sig ...)) expr)])
(with-syntax ([exploded-sigs (datum->syntax (explode-named-sigs sigs)
expr expr)]
[flat-sigs (datum->syntax (flatten-signatures sigs)
expr expr)])
(with-syntax ([exploded-sigs (datum->syntax-object
expr
(explode-named-sigs sigs)
expr)]
[flat-sigs (datum->syntax-object
expr
(flatten-signatures sigs)
expr)])
(syntax/loc
expr
(let ([unt u])
@ -138,10 +144,14 @@
(get-sig 'unit->unit/sig expr #f sig))
(syntax->list (syntax (im-sig ...))))]
[ex-sig (get-sig 'unit->unit/sig expr #f (syntax ex-sig))])
(with-syntax ([exploded-imports (datum->syntax (explode-named-sigs im-sigs)
expr expr)]
[exploded-exports (datum->syntax (explode-sig ex-sig)
expr expr)])
(with-syntax ([exploded-imports (datum->syntax-object
expr
(explode-named-sigs im-sigs)
expr)]
[exploded-exports (datum->syntax-object
expr
(explode-sig ex-sig)
expr)])
(syntax
(make-unit/sig
e
@ -243,7 +253,7 @@
(syntax->list (syntax imports)))])
(let ([im-explodeds (explode-named-sigs im-sigs)]
[im-flattened (apply append (map (lambda (x) (flatten-signature #f x)) im-sigs))]
[d->s (lambda (x) (datum->syntax x (syntax orig) (syntax orig)))])
[d->s (lambda (x) (datum->syntax-object (syntax orig) x (syntax orig)))])
(with-syntax ([dv/iu (if (syntax-e (syntax global?))
(quote-syntax global-define-values/invoke-unit)
(quote-syntax define-values/invoke-unit))]
@ -291,7 +301,7 @@
[(_ signame)
(let ([sig (get-sig 'provide-signature-elements stx #f (syntax signame))])
(let ([flattened (flatten-signature #f sig)])
(with-syntax ([flattened (map (lambda (x) (datum->syntax x #f (syntax signame)))
(with-syntax ([flattened (map (lambda (x) (datum->syntax-object (syntax signame) x #f))
flattened)])
(syntax
(provide . flattened)))))]))))