310 lines
11 KiB
Racket
310 lines
11 KiB
Racket
#lang mzscheme
|
|
(require setup/main-collects
|
|
racket/local
|
|
racket/bool
|
|
racket/block
|
|
racket/private/this-expression-source-directory
|
|
(only racket/function
|
|
identity)
|
|
(only racket/base
|
|
build-string
|
|
build-list
|
|
build-vector
|
|
compose)
|
|
(rename racket/base base-else else))
|
|
|
|
(require-for-syntax syntax/name
|
|
setup/main-collects
|
|
"private/stxset.rkt")
|
|
|
|
(provide boolean=? symbol=?
|
|
identity
|
|
compose
|
|
|
|
true false
|
|
|
|
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
|
|
define-syntax-set
|
|
|
|
hash-table
|
|
|
|
(rename block begin-with-definitions)
|
|
|
|
begin-lifted)
|
|
|
|
(define (loop-until start done? next body)
|
|
(let loop ([i start])
|
|
(unless (done? i)
|
|
(body i)
|
|
(loop (next i)))))
|
|
|
|
(define-syntax (opt-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))))])))
|
|
|
|
;; 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)
|
|
(syntax-case stx ()
|
|
[(rec id expr)
|
|
(identifier? #'id)
|
|
#`(letrec ((id expr))
|
|
#,(syntax-property #'id 'inferred-name (syntax-e #'id)))]
|
|
[(rec (name id ...) body ...)
|
|
(andmap identifier? (syntax->list #'(name id ...)))
|
|
#`(letrec ((name (lambda (id ...) body ...)))
|
|
#,(syntax-property #'name 'inferred-name (syntax-e #'name)))]
|
|
[(rec (name id ... . did) body ...)
|
|
(andmap identifier? (syntax->list #'(name did id ...)))
|
|
#`(letrec ((name (lambda (id ... . did) body ...)))
|
|
#,(syntax-property #'name 'inferred-name (syntax-e #'name)))]
|
|
[_
|
|
(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)
|
|
(syntax-case stx ()
|
|
[(_ val [test body ...] ...)
|
|
(let ([tests (syntax->list (syntax (test ...)))])
|
|
(with-syntax ([(a-test ...)
|
|
(map (lambda (t)
|
|
(syntax-case t (else base-else)
|
|
[else (syntax #t)]
|
|
[base-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))
|
|
(module-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 (let+ 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-argument-error 'namespace-defined? "symbol?" n))
|
|
(not (eq? (namespace-variable-value n #t (lambda () ns-undefined))
|
|
ns-undefined)))
|
|
|
|
(define-syntax (this-expression-file-name stx)
|
|
(syntax-case stx ()
|
|
[(_ sub)
|
|
(let ([stx #'sub])
|
|
(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-expression-file-name #,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 ...)))])
|
|
;; 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 (quote)
|
|
[(_ x ...)
|
|
(let loop ([xs #'(x ...)] [flags '()])
|
|
(syntax-case xs (quote)
|
|
[('flag x ...) (loop #'(x ...) (cons #''flag flags))]
|
|
[([key val] ...)
|
|
(with-syntax ([(flag ...) (reverse flags)])
|
|
(syntax/loc stx
|
|
(let ([ht (make-hash-table flag ...)])
|
|
(hash-table-put! ht key val) ...
|
|
ht)))]
|
|
[_else (raise-syntax-error 'hash-table "bad syntax" stx)]))]))
|
|
|
|
(define-syntax (begin-lifted stx)
|
|
(syntax-case stx ()
|
|
[(_ expr0 expr ...)
|
|
(let ([name (syntax-local-name)])
|
|
(if name
|
|
(with-syntax ([name name])
|
|
(syntax-local-lift-expression
|
|
#'(let ([name (begin expr0 expr ...)])
|
|
name)))
|
|
(syntax-local-lift-expression
|
|
#'(begin expr0 expr ...))))]))
|