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

reformat

Browse Source 
svn: r9039

original commit: 02c33947263e79ecb3a3fea436f91d023b94d899
This commit is contained in:
Eli Barzilay 2008-03-21 13:13:31 +00:00
parent 0b86826a0d
commit 1e11cd39f8
1 changed files with 396 additions and 405 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

73
collects/mzlib/etc.ss
View File

@ -1,7 +1,6 @@
#lang mzscheme
(module etc mzscheme (require (lib "main-collects.ss" "setup")
(require (lib "main-collects.ss" "setup")
scheme/local scheme/local
scheme/bool scheme/bool
(only scheme/base (only scheme/base
@ -11,13 +10,13 @@
compose) compose)
"kw.ss") "kw.ss")
(require-for-syntax syntax/kerncase (require-for-syntax syntax/kerncase
syntax/stx syntax/stx
syntax/name syntax/name
(lib "main-collects.ss" "setup") (lib "main-collects.ss" "setup")
"private/stxset.ss") "private/stxset.ss")
(provide boolean=? symbol=? (provide boolean=? symbol=?
identity identity
compose compose
@ -50,15 +49,15 @@
begin-lifted) begin-lifted)
(define identity (lambda (x) x)) (define identity (lambda (x) x))
(define (loop-until start done? next body) (define (loop-until start done? next body)
(let loop ([i start]) (let loop ([i start])
(unless (done? i) (unless (done? i)
(body i) (body i)
(loop (next i))))) (loop (next i)))))
(define-syntax (opt-lambda stx) (define-syntax (opt-lambda stx)
(with-syntax ([name (or (syntax-local-infer-name stx) (with-syntax ([name (or (syntax-local-infer-name stx)
(quote-syntax opt-lambda-proc))]) (quote-syntax opt-lambda-proc))])
(syntax-case stx () (syntax-case stx ()
@ -106,14 +105,14 @@
(syntax/loc stx (syntax/loc stx
(letrec ([name (case-lambda . clauses)]) name))))]))) (letrec ([name (case-lambda . clauses)]) name))))])))
;; recur is another name for 'let' in a named let ;; recur is another name for 'let' in a named let
(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)
(syntax-case stx () (syntax-case stx ()
[(rec id expr) [(rec id expr)
(identifier? #'id) (identifier? #'id)
@ -131,7 +130,7 @@
(raise-syntax-error (raise-syntax-error
#f "expects either an identifier followed by an expresion, or a (possibly dotted) sequence of identifiers followed by a body" stx)])) #f "expects either an identifier followed by an expresion, or a (possibly dotted) sequence of identifiers 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 ...)))])
@ -164,15 +163,15 @@
[(t a ...) (raise-syntax-error #f "invalid clause" stx s)])) [(t a ...) (raise-syntax-error #f "invalid clause" stx s)]))
(syntax->list (syntax (something ...))))])) (syntax->list (syntax (something ...))))]))
(define-syntax (nor stx) (define-syntax (nor stx)
(syntax-case stx () (syntax-case stx ()
[(_ expr ...) (syntax/loc stx (not (or expr ...)))])) [(_ expr ...) (syntax/loc stx (not (or expr ...)))]))
(define-syntax (nand stx) (define-syntax (nand stx)
(syntax-case stx () (syntax-case stx ()
[(_ expr ...) (syntax/loc stx (not (and expr ...)))])) [(_ expr ...) (syntax/loc stx (not (and expr ...)))]))
(define-syntax (let+ stx) (define-syntax (let+ stx)
(syntax-case stx () (syntax-case stx ()
[(_ [clause ...] body1 body ...) [(_ [clause ...] body1 body ...)
(let ([clauses (syntax->list (syntax (clause ...)))] (let ([clauses (syntax->list (syntax (clause ...)))]
@ -242,15 +241,15 @@
[(_ expr0 expr ...) [(_ expr0 expr ...)
(syntax (begin expr0 expr ... rest))])))))])) (syntax (begin expr0 expr ... rest))])))))]))
(define ns-undefined (gensym)) (define ns-undefined (gensym))
(define (namespace-defined? n) (define (namespace-defined? n)
(unless (symbol? n) (unless (symbol? n)
(raise-type-error 'namespace-defined? "symbol" n)) (raise-type-error 'namespace-defined? "symbol" n))
(not (eq? (namespace-variable-value n #t (lambda () ns-undefined)) (not (eq? (namespace-variable-value n #t (lambda () ns-undefined))
ns-undefined))) ns-undefined)))
(define (extract-module-directory stx) (define (extract-module-directory stx)
(let ([srcmod (let ([mpi (syntax-source-module stx)]) (let ([srcmod (let ([mpi (syntax-source-module stx)])
(if (module-path-index? mpi) (if (module-path-index? mpi)
(module-path-index-resolve mpi) (module-path-index-resolve mpi)
@ -261,7 +260,7 @@
(and (path? base) (and (path? base)
base)))))) base))))))
(define-syntax (this-expression-source-directory stx) (define-syntax (this-expression-source-directory stx)
(syntax-case stx () (syntax-case stx ()
[(_) [(_)
(let ([source-path (let ([source-path
@ -287,7 +286,7 @@
#,source-path)) #,source-path))
source-path)))])) source-path)))]))
(define-syntax (this-expression-file-name stx) (define-syntax (this-expression-file-name stx)
(syntax-case stx () (syntax-case stx ()
[(_) [(_)
(let* ([f (syntax-source stx)] (let* ([f (syntax-source stx)]
@ -297,11 +296,11 @@
(with-syntax ([f (path->bytes f)]) #'(bytes->path f)) (with-syntax ([f (path->bytes f)]) #'(bytes->path f))
#'#f))])) #'#f))]))
;; This is a macro-generating macro that wants to expand ;; This is a macro-generating macro that wants to expand
;; expressions used in the generated macro. So it's weird, ;; expressions used in the generated macro. So it's weird,
;; and we put much of the work in a helper macro, ;; and we put much of the work in a helper macro,
;; `finish-syntax-set'. ;; `finish-syntax-set'.
(define-syntax (define-syntax-set stx) (define-syntax (define-syntax-set stx)
(syntax-case stx () (syntax-case stx ()
[(_ (id ...) defn ...) [(_ (id ...) defn ...)
(let ([ids (syntax->list (syntax (id ...)))]) (let ([ids (syntax->list (syntax (id ...)))])
@ -316,11 +315,7 @@
ids) ids)
(let ([dup (check-duplicate-identifier ids)]) (let ([dup (check-duplicate-identifier ids)])
(when dup (when dup
(raise-syntax-error (raise-syntax-error #f "duplicate identifier" stx dup)))
#f
"duplicate identifier"
stx
dup)))
;; We'd like to check the `defns', but that requires ;; We'd like to check the `defns', but that requires
;; and expansion in a different phase. So we move ;; and expansion in a different phase. So we move
@ -330,7 +325,7 @@
(define-syntaxes (id ...) (define-syntaxes (id ...)
(finish-syntax-set orig-stx)))))])) (finish-syntax-set orig-stx)))))]))
(define-syntax (hash-table stx) (define-syntax (hash-table stx)
(syntax-case stx (quote) (syntax-case stx (quote)
[(_ x ...) [(_ x ...)
(let loop ([xs #'(x ...)] [flags '()]) (let loop ([xs #'(x ...)] [flags '()])
@ -344,7 +339,7 @@
ht)))] ht)))]
[_else (raise-syntax-error 'hash-table "bad syntax" stx)]))])) [_else (raise-syntax-error 'hash-table "bad syntax" stx)]))]))
(define-syntax (begin-with-definitions stx) (define-syntax (begin-with-definitions stx)
;; Body can have mixed exprs and defns. Wrap expressions with ;; Body can have mixed exprs and defns. Wrap expressions with
;; `(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.
@ -359,11 +354,7 @@
(apply (apply
append append
(map (lambda (expr) (map (lambda (expr)
(let ([expr (local-expand (let ([expr (local-expand expr ctx kernel-forms def-ctx)])
expr
ctx
kernel-forms
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))]
@ -421,7 +412,7 @@
prev-defns prev-defns
(cons (car exprs) prev-exprs))])))) (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)])
@ -431,4 +422,4 @@
#'(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 ...))))]))