Implement Gregory Cooper's suggested changes
-apply Dr.Racket indentation formatting -fixup provides -don't know if it is possible to remove mzlib/private/stxset https://github.com/plt/racket/pull/138
This commit is contained in:
Patrick Mahoney
Gregory Cooper
parent
6611b5f519
commit
857b05798b
|
|
@ -1,40 +1,32 @@
|
|||
|
||||
(module etc frtime/frtime-lang-only
|
||||
(require setup/main-collects)
|
||||
(require (for-syntax
|
||||
racket/base
|
||||
syntax/kerncase
|
||||
syntax/stx
|
||||
syntax/name
|
||||
syntax/context
|
||||
setup/main-collects
|
||||
mzlib/private/stxset))
|
||||
|
||||
(provide true false
|
||||
boolean=? symbol=?
|
||||
identity
|
||||
compose
|
||||
|
||||
;build-string
|
||||
;build-vector
|
||||
build-list
|
||||
|
||||
loop-until
|
||||
|
||||
(require (for-syntax racket/base
|
||||
syntax/kerncase
|
||||
syntax/stx
|
||||
syntax/name
|
||||
syntax/context
|
||||
setup/main-collects
|
||||
mzlib/private/stxset))
|
||||
|
||||
(provide true
|
||||
false
|
||||
boolean=? symbol=?
|
||||
identity
|
||||
compose
|
||||
build-list
|
||||
loop-until
|
||||
opt-lambda
|
||||
|
||||
local
|
||||
recur
|
||||
rec
|
||||
evcase
|
||||
nor
|
||||
nand
|
||||
let+
|
||||
|
||||
namespace-defined?
|
||||
this-expression-source-directory
|
||||
define-syntax-set
|
||||
|
||||
local
|
||||
recur
|
||||
rec
|
||||
evcase
|
||||
nor
|
||||
nand
|
||||
let+
|
||||
namespace-defined?
|
||||
this-expression-source-directory
|
||||
define-syntax-set
|
||||
hash-table)
|
||||
|
||||
(define true #t)
|
||||
|
|
@ -64,9 +56,7 @@
|
|||
[(f . more)
|
||||
(let ([m (apply compose more)])
|
||||
(compose f m))]))
|
||||
|
||||
|
||||
#|
|
||||
#|
|
||||
(define build-string
|
||||
(lambda (n fcn)
|
||||
(unless (and (integer? n) (exact? n) (>= n 0))
|
||||
|
|
@ -85,8 +75,7 @@
|
|||
;; (build-vector n f) returns a vector 0..n-1 where the ith element is (f i).
|
||||
;; The eval order is guaranteed to be: 0, 1, 2, ..., n-1.
|
||||
;; eg: (build-vector 4 (lambda (i) i)) ==> #4(0 1 2 3)
|
||||
|
||||
#|
|
||||
#|
|
||||
(define build-vector
|
||||
(lambda (n fcn)
|
||||
(unless (and (integer? n) (exact? n) (>= n 0))
|
||||
|
|
@ -102,21 +91,21 @@
|
|||
|#
|
||||
(define build-list
|
||||
(lambda (n fcn)
|
||||
(unless (and (integer? n) (exact? n) (>= n 0))
|
||||
(error 'build-list "~s must be an exact integer >= 0" n))
|
||||
(unless (procedure? fcn)
|
||||
(error 'build-list "~s must be a procedure" fcn))
|
||||
(let loop ([i (sub1 n)] [p '()])
|
||||
(if (>= i 0)
|
||||
(loop (sub1 i) (cons (fcn i) p))
|
||||
p))))
|
||||
|
||||
(unless (and (integer? n) (exact? n) (>= n 0))
|
||||
(error 'build-list "~s must be an exact integer >= 0" n))
|
||||
(unless (procedure? fcn)
|
||||
(error 'build-list "~s must be a procedure" fcn))
|
||||
(let loop ([i (sub1 n)] [p '()])
|
||||
(if (>= i 0)
|
||||
(loop (sub1 i) (cons (fcn i) p))
|
||||
p))))
|
||||
|
||||
(define loop-until
|
||||
(lambda (start done? next body)
|
||||
(let loop ([i start])
|
||||
(unless (done? i)
|
||||
(body i)
|
||||
(loop (next i))))))
|
||||
(let loop ([i start])
|
||||
(unless (done? i)
|
||||
(body i)
|
||||
(loop (next i))))))
|
||||
|
||||
(define boolean=?
|
||||
(lambda (x y)
|
||||
|
|
@ -129,360 +118,360 @@
|
|||
|
||||
(define (symbol=? x y)
|
||||
(unless (and (symbol? x)
|
||||
(symbol? y))
|
||||
(symbol? y))
|
||||
(raise-type-error 'symbol=? "symbol"
|
||||
(if (symbol? x) y x)))
|
||||
(if (symbol? x) y x)))
|
||||
(eq? x y))
|
||||
|
||||
(define-syntax opt-lambda
|
||||
(lambda (stx)
|
||||
(with-syntax ([name (or (syntax-local-infer-name stx)
|
||||
(quote-syntax opt-lambda-proc))])
|
||||
(syntax-case stx ()
|
||||
[(_ args body1 body ...)
|
||||
(let ([clauses (let loop ([pre-args null]
|
||||
[args (syntax args)]
|
||||
[needs-default? #f])
|
||||
(syntax-case args ()
|
||||
[id
|
||||
(identifier? (syntax id))
|
||||
(with-syntax ([(pre-arg ...) pre-args])
|
||||
(syntax ([(pre-arg ... . id)
|
||||
body1 body ...])))]
|
||||
[()
|
||||
(with-syntax ([(pre-arg ...) pre-args])
|
||||
(syntax ([(pre-arg ...)
|
||||
body1 body ...])))]
|
||||
[(id . rest)
|
||||
(identifier? (syntax id))
|
||||
(begin
|
||||
(when needs-default?
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"default value missing"
|
||||
stx
|
||||
(syntax id)))
|
||||
(loop (append pre-args (list (syntax id)))
|
||||
(syntax rest)
|
||||
#f))]
|
||||
[([id default] . rest)
|
||||
(identifier? (syntax id))
|
||||
(with-syntax ([rest (loop (append pre-args (list (syntax id)))
|
||||
(syntax rest)
|
||||
#t)]
|
||||
[(pre-arg ...) pre-args])
|
||||
(syntax ([(pre-arg ...) (name pre-arg ... default)]
|
||||
. rest)))]
|
||||
[(bad . rest)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"not an identifier or identifier with default"
|
||||
stx
|
||||
(syntax bad))]
|
||||
[else
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"bad identifier sequence"
|
||||
stx
|
||||
(syntax args))]))])
|
||||
(with-syntax ([clauses clauses])
|
||||
(syntax/loc stx
|
||||
(letrec ([name
|
||||
(case-lambda
|
||||
. clauses)])
|
||||
name))))]))))
|
||||
|
||||
(define-syntax local
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ (defn ...) body1 body ...)
|
||||
(let ([defs (let ([expand-context (generate-expand-context)])
|
||||
(let loop ([defns (syntax->list (syntax (defn ...)))])
|
||||
(apply
|
||||
append
|
||||
(map
|
||||
(lambda (defn)
|
||||
(let ([d (local-expand
|
||||
defn
|
||||
expand-context
|
||||
(kernel-form-identifier-list))]
|
||||
[check-ids (lambda (ids)
|
||||
(for-each
|
||||
(lambda (id)
|
||||
(unless (identifier? id)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"not an identifier for definition"
|
||||
stx
|
||||
id)))
|
||||
ids))])
|
||||
(syntax-case d (define-values define-syntaxes begin)
|
||||
[(begin defn ...)
|
||||
(loop (syntax->list (syntax (defn ...))))]
|
||||
[(define-values (id ...) body)
|
||||
(begin
|
||||
(check-ids (syntax->list (syntax (id ...))))
|
||||
(list d))]
|
||||
[(define-values . rest)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"ill-formed definition"
|
||||
stx
|
||||
d)]
|
||||
[(define-syntaxes (id ...) body)
|
||||
(begin
|
||||
(check-ids (syntax->list (syntax (id ...))))
|
||||
(list d))]
|
||||
[(define-syntaxes . rest)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"ill-formed definition"
|
||||
stx
|
||||
d)]
|
||||
[_else
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"not a definition"
|
||||
stx
|
||||
defn)])))
|
||||
defns))))])
|
||||
(let ([ids (apply append
|
||||
(map
|
||||
(lambda (d)
|
||||
(syntax-case d ()
|
||||
[(_ ids . __)
|
||||
(syntax->list (syntax ids))]))
|
||||
defs))])
|
||||
(let ([dup (check-duplicate-identifier ids)])
|
||||
(when dup
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"duplicate identifier"
|
||||
stx
|
||||
dup)))
|
||||
(with-syntax ([(def ...) defs])
|
||||
(syntax/loc
|
||||
stx
|
||||
(let ()
|
||||
def ...
|
||||
(let ()
|
||||
body1
|
||||
body ...))))))]
|
||||
[(_ x body1 body ...)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"not a definition sequence"
|
||||
stx
|
||||
(syntax x))])))
|
||||
|
||||
;; recur is another name for 'let' in a named let
|
||||
(define-syntax recur
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ . rest)
|
||||
(syntax/loc stx (let . rest))])))
|
||||
|
||||
;; define a recursive value
|
||||
(define-syntax rec
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ name expr)
|
||||
(begin
|
||||
(unless (identifier? (syntax name))
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"not an identifier"
|
||||
stx
|
||||
(syntax name)))
|
||||
(syntax/loc stx
|
||||
(letrec ([name expr])
|
||||
name)))])))
|
||||
|
||||
(define-syntax evcase
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ val [test body ...] ...)
|
||||
(let ([tests (syntax->list (syntax (test ...)))])
|
||||
(with-syntax ([(a-test ...)
|
||||
(map
|
||||
(lambda (t)
|
||||
(syntax-case t (else)
|
||||
[else (syntax #t)]
|
||||
[_else (with-syntax ([t t])
|
||||
(syntax (eqv? evcase-v t)))]))
|
||||
tests)])
|
||||
;; Make sure else is last:
|
||||
(unless (null? tests)
|
||||
(let loop ([tests tests])
|
||||
(unless (null? (cdr tests))
|
||||
(when (and (identifier? (car tests))
|
||||
(free-identifier=? (quote-syntax else) (car tests)))
|
||||
(raise-syntax-error
|
||||
#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
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ expr ...)
|
||||
(syntax/loc stx (not (or expr ...)))])))
|
||||
|
||||
(define-syntax nand
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ expr ...)
|
||||
(syntax/loc stx (not (and expr ...)))])))
|
||||
|
||||
(define-syntax let+
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ [clause ...] body1 body ...)
|
||||
(let ([clauses (syntax->list (syntax (clause ...)))]
|
||||
[bad (lambda (c n)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
(format "illegal use of ~a for a clause" n)
|
||||
stx
|
||||
c))]
|
||||
[var? (lambda (x)
|
||||
(or (identifier? x)
|
||||
(let ([l (syntax->list x)])
|
||||
(and l
|
||||
(pair? l)
|
||||
(eq? (syntax-e (car l)) 'values)
|
||||
(andmap identifier? (cdr l))))))]
|
||||
[normal-var (lambda (x)
|
||||
(if (identifier? x)
|
||||
(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 ns-undefined (gensym))
|
||||
|
||||
(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-syntax (this-expression-source-directory stx)
|
||||
(syntax-case stx ()
|
||||
[(_)
|
||||
(let* ([source (syntax-source stx)]
|
||||
[source (and (path? source) source)]
|
||||
[local (or (current-load-relative-directory) (current-directory))]
|
||||
[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))))]))
|
||||
|
||||
;; 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 opt-lambda
|
||||
(lambda (stx)
|
||||
(with-syntax ([name (or (syntax-local-infer-name stx)
|
||||
(quote-syntax opt-lambda-proc))])
|
||||
(syntax-case stx ()
|
||||
[(_ args body1 body ...)
|
||||
(let ([clauses (let loop ([pre-args null]
|
||||
[args (syntax args)]
|
||||
[needs-default? #f])
|
||||
(syntax-case args ()
|
||||
[id
|
||||
(identifier? (syntax id))
|
||||
(with-syntax ([(pre-arg ...) pre-args])
|
||||
(syntax ([(pre-arg ... . id)
|
||||
body1 body ...])))]
|
||||
[()
|
||||
(with-syntax ([(pre-arg ...) pre-args])
|
||||
(syntax ([(pre-arg ...)
|
||||
body1 body ...])))]
|
||||
[(id . rest)
|
||||
(identifier? (syntax id))
|
||||
(begin
|
||||
(when needs-default?
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"default value missing"
|
||||
stx
|
||||
(syntax id)))
|
||||
(loop (append pre-args (list (syntax id)))
|
||||
(syntax rest)
|
||||
#f))]
|
||||
[([id default] . rest)
|
||||
(identifier? (syntax id))
|
||||
(with-syntax ([rest (loop (append pre-args (list (syntax id)))
|
||||
(syntax rest)
|
||||
#t)]
|
||||
[(pre-arg ...) pre-args])
|
||||
(syntax ([(pre-arg ...) (name pre-arg ... default)]
|
||||
. rest)))]
|
||||
[(bad . rest)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"not an identifier or identifier with default"
|
||||
stx
|
||||
(syntax bad))]
|
||||
[else
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"bad identifier sequence"
|
||||
stx
|
||||
(syntax args))]))])
|
||||
(with-syntax ([clauses clauses])
|
||||
(syntax/loc stx
|
||||
(letrec ([name
|
||||
(case-lambda
|
||||
. clauses)])
|
||||
name))))]))))
|
||||
|
||||
(define-syntax local
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ (defn ...) body1 body ...)
|
||||
(let ([defs (let ([expand-context (generate-expand-context)])
|
||||
(let loop ([defns (syntax->list (syntax (defn ...)))])
|
||||
(apply
|
||||
append
|
||||
(map
|
||||
(lambda (defn)
|
||||
(let ([d (local-expand
|
||||
defn
|
||||
expand-context
|
||||
(kernel-form-identifier-list))]
|
||||
[check-ids (lambda (ids)
|
||||
(for-each
|
||||
(lambda (id)
|
||||
(unless (identifier? id)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"not an identifier for definition"
|
||||
stx
|
||||
id)))
|
||||
ids))])
|
||||
(syntax-case d (define-values define-syntaxes begin)
|
||||
[(begin defn ...)
|
||||
(loop (syntax->list (syntax (defn ...))))]
|
||||
[(define-values (id ...) body)
|
||||
(begin
|
||||
(check-ids (syntax->list (syntax (id ...))))
|
||||
(list d))]
|
||||
[(define-values . rest)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"ill-formed definition"
|
||||
stx
|
||||
d)]
|
||||
[(define-syntaxes (id ...) body)
|
||||
(begin
|
||||
(check-ids (syntax->list (syntax (id ...))))
|
||||
(list d))]
|
||||
[(define-syntaxes . rest)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"ill-formed definition"
|
||||
stx
|
||||
d)]
|
||||
[_else
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"not a definition"
|
||||
stx
|
||||
defn)])))
|
||||
defns))))])
|
||||
(let ([ids (apply append
|
||||
(map
|
||||
(lambda (d)
|
||||
(syntax-case d ()
|
||||
[(_ ids . __)
|
||||
(syntax->list (syntax ids))]))
|
||||
defs))])
|
||||
(let ([dup (check-duplicate-identifier ids)])
|
||||
(when dup
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"duplicate identifier"
|
||||
stx
|
||||
dup)))
|
||||
(with-syntax ([(def ...) defs])
|
||||
(syntax/loc
|
||||
stx
|
||||
(let ()
|
||||
def ...
|
||||
(let ()
|
||||
body1
|
||||
body ...))))))]
|
||||
[(_ x body1 body ...)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"not a definition sequence"
|
||||
stx
|
||||
(syntax x))])))
|
||||
|
||||
;; recur is another name for 'let' in a named let
|
||||
(define-syntax recur
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ . rest)
|
||||
(syntax/loc stx (let . rest))])))
|
||||
|
||||
;; define a recursive value
|
||||
(define-syntax rec
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ name expr)
|
||||
(begin
|
||||
(unless (identifier? (syntax name))
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"not an identifier"
|
||||
stx
|
||||
(syntax name)))
|
||||
(syntax/loc stx
|
||||
(letrec ([name expr])
|
||||
name)))])))
|
||||
|
||||
(define-syntax evcase
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ val [test body ...] ...)
|
||||
(let ([tests (syntax->list (syntax (test ...)))])
|
||||
(with-syntax ([(a-test ...)
|
||||
(map
|
||||
(lambda (t)
|
||||
(syntax-case t (else)
|
||||
[else (syntax #t)]
|
||||
[_else (with-syntax ([t t])
|
||||
(syntax (eqv? evcase-v t)))]))
|
||||
tests)])
|
||||
;; Make sure else is last:
|
||||
(unless (null? tests)
|
||||
(let loop ([tests tests])
|
||||
(unless (null? (cdr tests))
|
||||
(when (and (identifier? (car tests))
|
||||
(free-identifier=? (quote-syntax else) (car tests)))
|
||||
(raise-syntax-error
|
||||
#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
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ expr ...)
|
||||
(syntax/loc stx (not (or expr ...)))])))
|
||||
|
||||
(define-syntax nand
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ expr ...)
|
||||
(syntax/loc stx (not (and expr ...)))])))
|
||||
|
||||
(define-syntax let+
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ [clause ...] body1 body ...)
|
||||
(let ([clauses (syntax->list (syntax (clause ...)))]
|
||||
[bad (lambda (c n)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
(format "illegal use of ~a for a clause" n)
|
||||
stx
|
||||
c))]
|
||||
[var? (lambda (x)
|
||||
(or (identifier? x)
|
||||
(let ([l (syntax->list x)])
|
||||
(and l
|
||||
(pair? l)
|
||||
(eq? (syntax-e (car l)) 'values)
|
||||
(andmap identifier? (cdr l))))))]
|
||||
[normal-var (lambda (x)
|
||||
(if (identifier? x)
|
||||
(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 ns-undefined (gensym))
|
||||
|
||||
(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-syntax (this-expression-source-directory stx)
|
||||
(syntax-case stx ()
|
||||
[(_)
|
||||
(let* ([source (syntax-source stx)]
|
||||
[source (and (path? source) source)]
|
||||
[local (or (current-load-relative-directory) (current-directory))]
|
||||
[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))))]))
|
||||
|
||||
;; 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)
|
||||
(syntax-case stx ()
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user