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/bool
(only scheme/base
@ -11,13 +10,13 @@
compose)
"kw.ss")
(require-for-syntax syntax/kerncase
(require-for-syntax syntax/kerncase
syntax/stx
syntax/name
(lib "main-collects.ss" "setup")
"private/stxset.ss")
(provide boolean=? symbol=?
(provide boolean=? symbol=?
identity
compose
@ -50,15 +49,15 @@
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])
(unless (done? i)
(body i)
(loop (next i)))))
(define-syntax (opt-lambda stx)
(define-syntax (opt-lambda stx)
(with-syntax ([name (or (syntax-local-infer-name stx)
(quote-syntax opt-lambda-proc))])
(syntax-case stx ()
@ -106,14 +105,14 @@
(syntax/loc stx
(letrec ([name (case-lambda . clauses)]) name))))])))
;; recur is another name for 'let' in a named let
(define-syntax (recur stx)
;; recur is another name for 'let' in a named let
(define-syntax (recur stx)
(syntax-case stx ()
[(_ . rest) (syntax/loc stx (let . rest))]))
;; define a recursive value
;; implementation by Jens Axel Soegaard
(define-syntax (rec stx)
;; define a recursive value
;; implementation by Jens Axel Soegaard
(define-syntax (rec stx)
(syntax-case stx ()
[(rec id expr)
(identifier? #'id)
@ -131,7 +130,7 @@
(raise-syntax-error
#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 ()
[(_ val [test body ...] ...)
(let ([tests (syntax->list (syntax (test ...)))])
@ -164,15 +163,15 @@
[(t a ...) (raise-syntax-error #f "invalid clause" stx s)]))
(syntax->list (syntax (something ...))))]))
(define-syntax (nor stx)
(define-syntax (nor stx)
(syntax-case stx ()
[(_ expr ...) (syntax/loc stx (not (or expr ...)))]))
(define-syntax (nand stx)
(define-syntax (nand stx)
(syntax-case stx ()
[(_ expr ...) (syntax/loc stx (not (and expr ...)))]))
(define-syntax (let+ stx)
(define-syntax (let+ stx)
(syntax-case stx ()
[(_ [clause ...] body1 body ...)
(let ([clauses (syntax->list (syntax (clause ...)))]
@ -242,15 +241,15 @@
[(_ expr0 expr ...)
(syntax (begin expr0 expr ... rest))])))))]))
(define ns-undefined (gensym))
(define ns-undefined (gensym))
(define (namespace-defined? n)
(define (namespace-defined? n)
(unless (symbol? n)
(raise-type-error 'namespace-defined? "symbol" n))
(not (eq? (namespace-variable-value n #t (lambda () ns-undefined))
ns-undefined)))
(define (extract-module-directory stx)
(define (extract-module-directory stx)
(let ([srcmod (let ([mpi (syntax-source-module stx)])
(if (module-path-index? mpi)
(module-path-index-resolve mpi)
@ -261,7 +260,7 @@
(and (path? base)
base))))))
(define-syntax (this-expression-source-directory stx)
(define-syntax (this-expression-source-directory stx)
(syntax-case stx ()
[(_)
(let ([source-path
@ -287,7 +286,7 @@
#,source-path))
source-path)))]))
(define-syntax (this-expression-file-name stx)
(define-syntax (this-expression-file-name stx)
(syntax-case stx ()
[(_)
(let* ([f (syntax-source stx)]
@ -297,11 +296,11 @@
(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)
;; 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 ...)))])
@ -316,11 +315,7 @@
ids)
(let ([dup (check-duplicate-identifier ids)])
(when dup
(raise-syntax-error
#f
"duplicate identifier"
stx
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
@ -330,7 +325,7 @@
(define-syntaxes (id ...)
(finish-syntax-set orig-stx)))))]))
(define-syntax (hash-table stx)
(define-syntax (hash-table stx)
(syntax-case stx (quote)
[(_ x ...)
(let loop ([xs #'(x ...)] [flags '()])
@ -344,7 +339,7 @@
ht)))]
[_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
;; `(define-values () ... (values))' as needed, and add a (void)
;; at the end if needed.
@ -359,11 +354,7 @@
(apply
append
(map (lambda (expr)
(let ([expr (local-expand
expr
ctx
kernel-forms
def-ctx)])
(let ([expr (local-expand expr ctx kernel-forms def-ctx)])
(syntax-case expr (begin define-syntaxes define-values)
[(begin . rest)
(loop (syntax->list #'rest))]
@ -421,7 +412,7 @@
prev-defns
(cons (car exprs) prev-exprs))]))))
(define-syntax (begin-lifted stx)
(define-syntax (begin-lifted stx)
(syntax-case stx ()
[(_ expr0 expr ...)
(let ([name (syntax-local-name)])
@ -431,4 +422,4 @@
#'(let ([name (begin expr0 expr ...)])
name)))
(syntax-local-lift-expression
#'(begin expr0 expr ...))))])))
#'(begin expr0 expr ...))))]))