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

.

Browse Source 
original commit: 18d7e54bedb46e00c16fdc28b14f6383812369be
This commit is contained in:
Matthew Flatt 2001-07-04 20:00:03 +00:00
parent b3026df612
commit 7d6762f989
2 changed files with 12 additions and 95 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
collects/mzlib/include.ss
View File

@ -1,13 +1,12 @@
(module include mzscheme
(require-for-syntax (lib "stx.ss" "syntax"))
(define-syntax include
(lambda (stx)
;; Parse the file name
(let ([file
(syntax-case* stx (build-path) (lambda (a b)
(eq? (syntax-e a)
(syntax-e b)))
(syntax-case* stx (build-path) module-or-top-identifier=?
[(_ fn)
(string? (syntax-e (syntax fn)))
(syntax-e (syntax fn))]
@ -15,8 +14,10 @@
(andmap
(lambda (e)
(or (string? (syntax-e e))
(module-identifier=? e (quote-syntax up))
(module-identifier=? e (quote-syntax same))))
(and (identifier? e)
(or
(module-identifier=? e (quote-syntax up))
(module-identifier=? e (quote-syntax same))))))
(syntax->list (syntax (elem1 elem ...))))
(apply build-path (syntax-object->datum (syntax (elem1 elem ...))))])])
;; Complete the file name

96
collects/mzlib/shared.ss
View File

@ -1,99 +1,15 @@
(module shared mzscheme
(require-for-syntax (lib "stx.ss" "syntax")
(lib "kerncase.ss" "syntax")
"include.ss")
(provide shared)
(define undefined (letrec ([x x]) x))
(require (rename mzscheme the-cons cons))
(define-syntax shared
(lambda (stx)
(syntax-case stx ()
[(_ ([name expr] ...) body1 body ...)
(let ([names (syntax->list (syntax (name ...)))]
[exprs (syntax->list (syntax (expr ...)))])
(for-each (lambda (name)
(unless (identifier? name)
(raise-syntax-error
'shared
"not an identifier"
stx
name)))
names)
(let ([dup (check-duplicate-identifier names)])
(when dup
(raise-syntax-error
'shared
"duplicate identifier"
stx
dup)))
(with-syntax ([(init-expr ...)
(map (lambda (expr)
(define (bad n)
(raise-syntax-error
'shared
(format "illegal use of ~a" n)
stx
expr))
(syntax-case expr (cons list box vector)
[(cons a d)
(syntax (cons undefined undefined))]
[(cons . _)
(bad "list")]
[(list e ...)
(with-syntax ([(e ...)
(map (lambda (x) (syntax undefined))
(syntax->list (syntax (e ...))))])
(syntax (list e ...)))]
[(list . _)
(bad "list")]
[(box v)
(syntax (box undefined))]
[(box . _)
(bad "box")]
[(vector e ...)
(with-syntax ([(e ...)
(map (lambda (x) (syntax undefined))
(syntax->list (syntax (e ...))))])
(syntax (vector e ...)))]
[(vector . _)
(bad "vector")]
[_else expr]))
exprs)]
[(finish-expr ...)
(let ([gen-n (lambda (l)
(let loop ([l l][n 0])
(if (null? l)
null
(cons (datum->syntax-object (quote-syntax here) n #f)
(loop (cdr l) (add1 n))))))])
(map (lambda (name expr)
(with-syntax ([name name])
(syntax-case expr (cons list box vector)
[(cons a d)
(syntax (begin
(set-car! name a)
(set-cdr! name d)))]
[(list e ...)
(with-syntax ([(n ...) (gen-n (syntax->list (syntax (e ...))))])
(syntax (let ([lst name])
(set-car! (list-tail lst n) e)
...)))]
[(box v)
(syntax (set-box! name v))]
[(vector e ...)
(with-syntax ([(n ...) (gen-n (syntax->list (syntax (e ...))))])
(syntax (let ([vec name])
(vector-set! vec n e)
...)))]
[_else (syntax (void))])))
names exprs))])
(syntax
(letrec ([name init-expr] ...)
finish-expr
...
body1
body
...))))]))))
(define make-check-cdr #f)
(include (build-path "private" "shared-body.ss")))))