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

reformatted

Browse Source 
svn: r4916
This commit is contained in:
Eli Barzilay 2006-11-22 00:06:01 +00:00
parent 404fad489d
commit 11debcdcdc
1 changed files with 288 additions and 272 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

560
collects/mzlib/etc.ss
View File

@ -4,52 +4,52 @@
(require (lib "main-collects.ss" "setup")) (require (lib "main-collects.ss" "setup"))
(require-for-syntax (lib "kerncase.ss" "syntax") (require-for-syntax (lib "kerncase.ss" "syntax")
(lib "stx.ss" "syntax") (lib "stx.ss" "syntax")
(lib "name.ss" "syntax") (lib "name.ss" "syntax")
(lib "context.ss" "syntax") (lib "context.ss" "syntax")
(lib "main-collects.ss" "setup") (lib "main-collects.ss" "setup")
"private/stxset.ss") "private/stxset.ss")
(provide true false
boolean=? symbol=?
identity
compose
build-string
build-vector
build-list
loop-until
opt-lambda
local
recur
rec
evcase
nor
nand
let+
namespace-defined? (provide true false
this-expression-source-directory boolean=? symbol=?
identity
compose
build-string
build-vector
build-list
loop-until
opt-lambda
local
recur
rec
evcase
nor
nand
let+
namespace-defined?
this-expression-source-directory
this-expression-file-name this-expression-file-name
define-syntax-set define-syntax-set
hash-table hash-table
begin-with-definitions begin-with-definitions
begin-lifted)
begin-lifted)
(define true #t) (define true #t)
(define false #f) (define false #f)
(define identity (lambda (x) x)) (define identity (lambda (x) x))
(define compose (define compose
(case-lambda (case-lambda
[(f) (if (procedure? f) f (raise-type-error 'compose "procedure" f))] [(f) (if (procedure? f) f (raise-type-error 'compose "procedure" f))]
[(f g) [(f g)
(let ([f (compose f)] (let ([f (compose f)]
@ -188,7 +188,7 @@
(let ([d (local-expand (let ([d (local-expand
defn defn
expand-context expand-context
(kernel-form-identifier-list (kernel-form-identifier-list
(quote-syntax here)))] (quote-syntax here)))]
[check-ids (lambda (ids) [check-ids (lambda (ids)
(for-each (for-each
@ -240,7 +240,7 @@
(define-syntax (recur stx) (define-syntax (recur stx)
(syntax-case stx () (syntax-case stx ()
[(_ . rest) (syntax/loc stx (let . rest))])) [(_ . rest) (syntax/loc stx (let . rest))]))
;; define a recursive value ;; define a recursive value
;; implementation by Jens Axel Soegaard ;; implementation by Jens Axel Soegaard
(define-syntax (rec stx) (define-syntax (rec stx)
@ -261,180 +261,186 @@
(raise-syntax-error (raise-syntax-error
#f "expects either a variable followed by an expresion, or a (possibly dotted) sequence of variables followed by a body" stx)])) #f "expects either a variable followed by an expresion, or a (possibly dotted) sequence of variables followed by a body" stx)]))
(define-syntax (evcase stx) (define-syntax (evcase stx)
(syntax-case stx () (syntax-case stx ()
[(_ val [test body ...] ...) [(_ val [test body ...] ...)
(let ([tests (syntax->list (syntax (test ...)))]) (let ([tests (syntax->list (syntax (test ...)))])
(with-syntax ([(a-test ...) (with-syntax ([(a-test ...)
(map (lambda (t) (map (lambda (t)
(syntax-case t (else) (syntax-case t (else)
[else (syntax #t)] [else (syntax #t)]
[_else (with-syntax ([t t]) [_else (with-syntax ([t t])
(syntax (eqv? evcase-v t)))])) (syntax (eqv? evcase-v t)))]))
tests)]) tests)])
;; Make sure else is last: ;; Make sure else is last:
(unless (null? tests) (unless (null? tests)
(let loop ([tests tests]) (let loop ([tests tests])
(unless (null? (cdr tests)) (unless (null? (cdr tests))
(when (and (identifier? (car tests)) (when (and (identifier? (car tests))
(module-identifier=? (quote-syntax else) (car tests))) (module-identifier=? (quote-syntax else)
(raise-syntax-error (car tests)))
#f "else is not in last clause" stx (car tests)))
(loop (cdr tests)))))
(syntax/loc stx
(let ([evcase-v val])
(cond [a-test (begin body ...)]
...)))))]
[(_ val something ...)
;; Provide a good error message:
(for-each
(lambda (s)
(syntax-case s ()
[(t a ...) (raise-syntax-error #f "invalid clause" stx s)]))
(syntax->list (syntax (something ...))))]))
(define-syntax (nor stx)
(syntax-case stx ()
[(_ expr ...) (syntax/loc stx (not (or expr ...)))]))
(define-syntax (nand stx)
(syntax-case stx ()
[(_ expr ...) (syntax/loc stx (not (and expr ...)))]))
(define-syntax (let+ stx)
(syntax-case stx ()
[(_ [clause ...] body1 body ...)
(let ([clauses (syntax->list (syntax (clause ...)))]
[bad (lambda (c n)
(raise-syntax-error (raise-syntax-error
#f (format "illegal use of ~a for a clause" n) stx c))] #f "else is not in last clause" stx (car tests)))
[var? (lambda (x) (loop (cdr tests)))))
(or (identifier? x) (syntax/loc stx
(let ([l (syntax->list x)]) (let ([evcase-v val])
(and l (cond [a-test (begin body ...)]
(pair? l) ...)))))]
(eq? (syntax-e (car l)) 'values) [(_ val something ...)
(andmap identifier? (cdr l))))))] ;; Provide a good error message:
[normal-var (lambda (x) (for-each
(if (identifier? x) (lambda (s)
(list x) (syntax-case s ()
(cdr (syntax-e x))))]) [(t a ...) (raise-syntax-error #f "invalid clause" stx s)]))
;; syntax checks (syntax->list (syntax (something ...))))]))
(for-each
(lambda (clause)
(syntax-case* clause (val rec vals recs _)
(lambda (a b) (eq? (syntax-e b) (syntax-e a)))
[(val var expr)
(var? (syntax var))
'ok]
[(rec var expr)
(var? (syntax var))
'ok]
[(vals (var expr) ...)
(andmap var? (syntax->list (syntax (var ...))))
'ok]
[(recs (var expr) ...)
(andmap var? (syntax->list (syntax (var ...))))
'ok]
[(_ expr0 expr ...)
'ok]
[(val . __) (bad clause "val")]
[(rec . __) (bad clause "rec")]
[(vals . __) (bad clause "vals")]
[(recs . __) (bad clause"recs")]
[(_ . __) (bad clause "_")]
[_else (raise-syntax-error #f "bad clause" stx clause)]))
clauses)
;; result
(let loop ([clauses clauses])
(if (null? clauses)
(syntax (let () body1 body ...))
(with-syntax ([rest (loop (cdr clauses))])
(syntax-case* (car clauses) (val rec vals recs _)
(lambda (a b) (eq? (syntax-e b) (syntax-e a)))
[(val var expr)
(with-syntax ([vars (normal-var (syntax var))])
(syntax (let-values ([vars expr]) rest)))]
[(rec var expr)
(with-syntax ([vars (normal-var (syntax var))])
(syntax (letrec-values ([vars expr]) rest)))]
[(vals (var expr) ...)
(with-syntax ([(vars ...) (map normal-var (syntax->list (syntax (var ...))))])
(syntax (let-values ([vars expr] ...) rest)))]
[(recs (var expr) ...)
(with-syntax ([(vars ...) (map normal-var (syntax->list (syntax (var ...))))])
(syntax (letrec-values ([vars expr] ...) rest)))]
[(_ expr0 expr ...)
(syntax (begin expr0 expr ... rest))])))))]))
(define ns-undefined (gensym)) (define-syntax (nor stx)
(syntax-case stx ()
[(_ expr ...) (syntax/loc stx (not (or expr ...)))]))
(define (namespace-defined? n) (define-syntax (nand stx)
(unless (symbol? n) (syntax-case stx ()
(raise-type-error 'namespace-defined? "symbol" n)) [(_ expr ...) (syntax/loc stx (not (and expr ...)))]))
(not (eq? (namespace-variable-value n #t (lambda () ns-undefined))
ns-undefined)))
(define-syntax (this-expression-source-directory stx) (define-syntax (let+ stx)
(syntax-case stx () (syntax-case stx ()
[(_) [(_ [clause ...] body1 body ...)
(let* ([source (syntax-source stx)] (let ([clauses (syntax->list (syntax (clause ...)))]
[source (and (path? source) source)] [bad (lambda (c n)
[local (or (current-load-relative-directory) (current-directory))] (raise-syntax-error
[dir (path->main-collects-relative #f (format "illegal use of ~a for a clause" n) stx c))]
(or (and source (file-exists? source) [var? (lambda (x)
(let-values ([(base file dir?) (split-path source)]) (or (identifier? x)
(and (path? base) (let ([l (syntax->list x)])
(path->complete-path base local)))) (and l
local))]) (pair? l)
(if (and (pair? dir) (eq? 'collects (car dir))) (eq? (syntax-e (car l)) 'values)
(with-syntax ([d dir]) (andmap identifier? (cdr l))))))]
#'(main-collects-relative->path 'd)) [normal-var (lambda (x)
(with-syntax ([d (if (bytes? dir) dir (path->bytes dir))]) (if (identifier? x)
#'(bytes->path d))))])) (list x)
(cdr (syntax-e x))))])
;; syntax checks
(for-each
(lambda (clause)
(syntax-case* clause (val rec vals recs _)
(lambda (a b) (eq? (syntax-e b) (syntax-e a)))
[(val var expr)
(var? (syntax var))
'ok]
[(rec var expr)
(var? (syntax var))
'ok]
[(vals (var expr) ...)
(andmap var? (syntax->list (syntax (var ...))))
'ok]
[(recs (var expr) ...)
(andmap var? (syntax->list (syntax (var ...))))
'ok]
[(_ expr0 expr ...)
'ok]
[(val . __) (bad clause "val")]
[(rec . __) (bad clause "rec")]
[(vals . __) (bad clause "vals")]
[(recs . __) (bad clause"recs")]
[(_ . __) (bad clause "_")]
[_else (raise-syntax-error #f "bad clause" stx clause)]))
clauses)
;; result
(let loop ([clauses clauses])
(if (null? clauses)
(syntax (let () body1 body ...))
(with-syntax ([rest (loop (cdr clauses))])
(syntax-case* (car clauses) (val rec vals recs _)
(lambda (a b) (eq? (syntax-e b) (syntax-e a)))
[(val var expr)
(with-syntax ([vars (normal-var (syntax var))])
(syntax (let-values ([vars expr]) rest)))]
[(rec var expr)
(with-syntax ([vars (normal-var (syntax var))])
(syntax (letrec-values ([vars expr]) rest)))]
[(vals (var expr) ...)
(with-syntax ([(vars ...)
(map normal-var
(syntax->list (syntax (var ...))))])
(syntax (let-values ([vars expr] ...) rest)))]
[(recs (var expr) ...)
(with-syntax ([(vars ...)
(map normal-var
(syntax->list (syntax (var ...))))])
(syntax (letrec-values ([vars expr] ...) rest)))]
[(_ expr0 expr ...)
(syntax (begin expr0 expr ... rest))])))))]))
(define-syntax (this-expression-file-name stx) (define ns-undefined (gensym))
(syntax-case stx ()
[(_)
(let* ([f (syntax-source stx)]
[f (and f (path? f) (file-exists? f)
(let-values ([(base file dir?) (split-path f)]) file))])
(if f
(with-syntax ([f (path->bytes f)]) #'(bytes->path f))
#'#f))]))
;; This is a macro-generating macro that wants to expand (define (namespace-defined? n)
;; expressions used in the generated macro. So it's weird, (unless (symbol? n)
;; and we put much of the work in a helper macro, (raise-type-error 'namespace-defined? "symbol" n))
;; `finish-syntax-set'. (not (eq? (namespace-variable-value n #t (lambda () ns-undefined))
(define-syntax (define-syntax-set stx) ns-undefined)))
(syntax-case stx ()
[(_ (id ...) defn ...)
(let ([ids (syntax->list (syntax (id ...)))])
;; Check ids ------------------------------
(for-each (lambda (id)
(unless (identifier? id)
(raise-syntax-error
#f
"not an identifier or two identifier in parentheses"
stx
id)))
ids)
(let ([dup (check-duplicate-identifier ids)])
(when dup
(raise-syntax-error
#f
"duplicate identifier"
stx
dup)))
;; We'd like to check the `defns', but that requires (define-syntax (this-expression-source-directory stx)
;; and expansion in a different phase. So we move (syntax-case stx ()
;; into that phase using `finish-syntax-set': [(_)
(with-syntax ([orig-stx stx]) (let* ([source (syntax-source stx)]
(syntax/loc stx [source (and (path? source) source)]
(define-syntaxes (id ...) [local (or (current-load-relative-directory) (current-directory))]
(finish-syntax-set orig-stx)))))])) [dir (path->main-collects-relative
(or (and source (file-exists? source)
(let-values ([(base file dir?)
(split-path source)])
(and (path? base)
(path->complete-path base local))))
local))])
(if (and (pair? dir) (eq? 'collects (car dir)))
(with-syntax ([d dir])
#'(main-collects-relative->path 'd))
(with-syntax ([d (if (bytes? dir) dir (path->bytes dir))])
#'(bytes->path d))))]))
(define-syntax (this-expression-file-name stx)
(syntax-case stx ()
[(_)
(let* ([f (syntax-source stx)]
[f (and f (path? f) (file-exists? f)
(let-values ([(base file dir?) (split-path f)]) file))])
(if f
(with-syntax ([f (path->bytes f)]) #'(bytes->path f))
#'#f))]))
;; This is a macro-generating macro that wants to expand
;; expressions used in the generated macro. So it's weird,
;; and we put much of the work in a helper macro,
;; `finish-syntax-set'.
(define-syntax (define-syntax-set stx)
(syntax-case stx ()
[(_ (id ...) defn ...)
(let ([ids (syntax->list (syntax (id ...)))])
;; Check ids ------------------------------
(for-each (lambda (id)
(unless (identifier? id)
(raise-syntax-error
#f
"not an identifier or two identifier in parentheses"
stx
id)))
ids)
(let ([dup (check-duplicate-identifier ids)])
(when dup
(raise-syntax-error
#f
"duplicate identifier"
stx
dup)))
;; We'd like to check the `defns', but that requires
;; and expansion in a different phase. So we move
;; into that phase using `finish-syntax-set':
(with-syntax ([orig-stx stx])
(syntax/loc stx
(define-syntaxes (id ...)
(finish-syntax-set orig-stx)))))]))
(define-syntax (hash-table stx) (define-syntax (hash-table stx)
(syntax-case stx (quote) (syntax-case stx (quote)
@ -455,77 +461,87 @@
;; `(define-values () ... (values))' as needed, and add a (void) ;; `(define-values () ... (values))' as needed, and add a (void)
;; at the end if needed. ;; at the end if needed.
(let* ([def-ctx (syntax-local-make-definition-context)] (let* ([def-ctx (syntax-local-make-definition-context)]
[ctx (list (gensym 'intdef))] [ctx (list (gensym 'intdef))]
[kernel-forms (kernel-form-identifier-list [kernel-forms (kernel-form-identifier-list
(quote-syntax here))] (quote-syntax here))]
[init-exprs (let ([v (syntax->list stx)]) [init-exprs (let ([v (syntax->list stx)])
(unless v (unless v
(raise-syntax-error #f "bad syntax" stx)) (raise-syntax-error #f "bad syntax" stx))
(cdr v))] (cdr v))]
[exprs (let loop ([exprs init-exprs]) [exprs (let loop ([exprs init-exprs])
(apply (apply
append append
(map (lambda (expr) (map (lambda (expr)
(let ([expr (local-expand (let ([expr (local-expand
expr expr
ctx ctx
kernel-forms kernel-forms
def-ctx)]) def-ctx)])
(syntax-case expr (begin define-syntaxes define-values) (syntax-case expr (begin define-syntaxes define-values)
[(begin . rest) [(begin . rest)
(loop (syntax->list #'rest))] (loop (syntax->list #'rest))]
[(define-syntaxes (id ...) rhs) [(define-syntaxes (id ...) rhs)
(andmap identifier? (syntax->list #'(id ...))) (andmap identifier? (syntax->list #'(id ...)))
(with-syntax ([rhs (local-transformer-expand (with-syntax ([rhs (local-transformer-expand
#'rhs #'rhs
'expression 'expression
null)]) null)])
(syntax-local-bind-syntaxes (syntax->list #'(id ...)) #'rhs def-ctx) (syntax-local-bind-syntaxes
(list #'(define-syntaxes (id ...) rhs)))] (syntax->list #'(id ...))
[(define-values (id ...) rhs) #'rhs def-ctx)
(andmap identifier? (syntax->list #'(id ...))) (list #'(define-syntaxes (id ...) rhs)))]
(let ([ids (syntax->list #'(id ...))]) [(define-values (id ...) rhs)
(syntax-local-bind-syntaxes ids #f def-ctx) (andmap identifier? (syntax->list #'(id ...)))
(list expr))] (let ([ids (syntax->list #'(id ...))])
[else (syntax-local-bind-syntaxes ids #f def-ctx)
(list expr)]))) (list expr))]
exprs)))]) [else
(let loop ([exprs exprs][prev-stx-defns null][prev-defns null][prev-exprs null]) (list expr)])))
(cond exprs)))])
[(null? exprs) (let loop ([exprs exprs]
#`(letrec-syntaxes+values [prev-stx-defns null]
#,(map stx-cdr (reverse prev-stx-defns)) [prev-defns null]
#,(map stx-cdr (reverse prev-defns)) [prev-exprs null])
#,@(if (null? prev-exprs) (cond
(list #'(void)) [(null? exprs)
(reverse prev-exprs)))] #`(letrec-syntaxes+values
[(and (stx-pair? (car exprs)) #,(map stx-cdr (reverse prev-stx-defns))
(identifier? (stx-car (car exprs))) #,(map stx-cdr (reverse prev-defns))
(module-identifier=? #'define-syntaxes (stx-car (car exprs)))) #,@(if (null? prev-exprs)
(loop (cdr exprs) (cons (car exprs) prev-stx-defns) prev-defns prev-exprs)] (list #'(void))
[(and (stx-pair? (car exprs)) (reverse prev-exprs)))]
(identifier? (stx-car (car exprs))) [(and (stx-pair? (car exprs))
(module-identifier=? #'define-values (stx-car (car exprs)))) (identifier? (stx-car (car exprs)))
(loop (cdr exprs) (module-identifier=? #'define-syntaxes (stx-car (car exprs))))
prev-stx-defns (loop (cdr exprs)
(cons (car exprs) (cons (car exprs) prev-stx-defns)
(append prev-defns
(map (lambda (expr) prev-exprs)]
#`(define-values () (begin #,expr (values)))) [(and (stx-pair? (car exprs))
prev-exprs) (identifier? (stx-car (car exprs)))
prev-defns)) (module-identifier=? #'define-values (stx-car (car exprs))))
null)] (loop (cdr exprs)
[else prev-stx-defns
(loop (cdr exprs) prev-stx-defns prev-defns (cons (car exprs) prev-exprs))])))) (cons (car exprs)
(append
(map (lambda (expr)
#`(define-values () (begin #,expr (values))))
prev-exprs)
prev-defns))
null)]
[else (loop (cdr exprs)
prev-stx-defns
prev-defns
(cons (car exprs) prev-exprs))]))))
(define-syntax (begin-lifted stx) (define-syntax (begin-lifted stx)
(syntax-case stx () (syntax-case stx ()
[(_ expr0 expr ...) [(_ expr0 expr ...)
(let ([name (syntax-local-name)]) (let ([name (syntax-local-name)])
(if name (if name
(with-syntax ([name name]) (with-syntax ([name name])
(syntax-local-lift-expression (syntax-local-lift-expression
#'(let ([name (begin expr0 expr ...)]) #'(let ([name (begin expr0 expr ...)])
name))) name)))
(syntax-local-lift-expression (syntax-local-lift-expression
#'(begin expr0 expr ...))))]))) #'(begin expr0 expr ...))))])))