560 lines
20 KiB
Scheme
560 lines
20 KiB
Scheme
;;----------------------------------------------------------------------
|
|
;; syntax-case and syntax
|
|
|
|
(module stxcase '#%kernel
|
|
(#%require "stx.ss" "small-scheme.ss" '#%paramz
|
|
"ellipses.ss"
|
|
(for-syntax "stx.ss" "small-scheme.ss" "sc.ss" '#%kernel))
|
|
|
|
(-define (datum->syntax/shape orig datum)
|
|
(if (syntax? datum)
|
|
datum
|
|
(let ([stx (datum->syntax orig datum orig #f orig)])
|
|
(let ([shape (syntax-property orig 'paren-shape)])
|
|
(if shape
|
|
(syntax-property stx 'paren-shape shape)
|
|
stx)))))
|
|
|
|
(-define (catch-ellipsis-error thunk sexp sloc)
|
|
((let/ec esc
|
|
(with-continuation-mark
|
|
exception-handler-key
|
|
(lambda (exn)
|
|
(esc
|
|
(lambda ()
|
|
(if (exn:break? exn)
|
|
(raise exn)
|
|
(raise-syntax-error
|
|
'syntax
|
|
"incompatible ellipsis match counts for template"
|
|
sexp
|
|
sloc)))))
|
|
(let ([v (thunk)])
|
|
(lambda () v))))))
|
|
|
|
(-define substitute-stop 'dummy)
|
|
|
|
;; pattern-substitute optimizes a pattern substitution by
|
|
;; merging variables that look up the same simple mapping
|
|
(-define-syntax pattern-substitute
|
|
(lambda (stx)
|
|
(let ([pat (stx-car (stx-cdr stx))]
|
|
[subs (stx->list (stx-cdr (stx-cdr stx)))])
|
|
(let ([ht-common (make-hash)]
|
|
[ht-map (make-hasheq)])
|
|
;; Determine merges:
|
|
(let loop ([subs subs])
|
|
(unless (null? subs)
|
|
(let ([id (syntax-e (car subs))]
|
|
[expr (cadr subs)])
|
|
(when (or (identifier? expr)
|
|
(and (stx-pair? expr)
|
|
(memq (syntax-e (stx-car expr))
|
|
'(car cadr caddr cadddr
|
|
cdr cddr cdddr cddddr
|
|
list-ref list-tail))
|
|
(stx-pair? (stx-cdr expr))
|
|
(identifier? (stx-car (stx-cdr expr)))))
|
|
(let ([s-expr (syntax->datum expr)])
|
|
(let ([new-id (hash-ref ht-common s-expr #f)])
|
|
(if new-id
|
|
(hash-set! ht-map id new-id)
|
|
(hash-set! ht-common s-expr id))))))
|
|
(loop (cddr subs))))
|
|
;; Merge:
|
|
(let ([new-pattern (if (zero? (hash-count ht-map))
|
|
pat
|
|
(let loop ([stx pat])
|
|
(cond
|
|
[(pair? stx)
|
|
(let ([a (loop (car stx))]
|
|
[b (loop (cdr stx))])
|
|
(if (and (eq? a (car stx))
|
|
(eq? b (cdr stx)))
|
|
stx
|
|
(cons a b)))]
|
|
[(symbol? stx)
|
|
(let ([new-id (hash-ref ht-map stx #f)])
|
|
(or new-id stx))]
|
|
[(syntax? stx)
|
|
(let ([new-e (loop (syntax-e stx))])
|
|
(if (eq? (syntax-e stx) new-e)
|
|
stx
|
|
(datum->syntax stx new-e stx stx)))]
|
|
[(vector? stx)
|
|
(list->vector (map loop (vector->list stx)))]
|
|
[(box? stx) (box (loop (unbox stx)))]
|
|
[else stx])))])
|
|
(datum->syntax (quote-syntax here)
|
|
`(apply-pattern-substitute
|
|
,new-pattern
|
|
(quote ,(let loop ([subs subs])
|
|
(cond
|
|
[(null? subs) null]
|
|
[(hash-ref ht-map (syntax-e (car subs)) #f)
|
|
;; Drop mapped id
|
|
(loop (cddr subs))]
|
|
[else
|
|
(cons (car subs) (loop (cddr subs)))])))
|
|
. ,(let loop ([subs subs])
|
|
(cond
|
|
[(null? subs) null]
|
|
[(hash-ref ht-map (syntax-e (car subs)) #f)
|
|
;; Drop mapped id
|
|
(loop (cddr subs))]
|
|
[else
|
|
(cons (cadr subs) (loop (cddr subs)))])))
|
|
stx))))))
|
|
|
|
(-define apply-pattern-substitute
|
|
(lambda (stx sub-ids . sub-vals)
|
|
(let loop ([stx stx])
|
|
(cond
|
|
[(pair? stx) (let ([a (loop (car stx))]
|
|
[b (loop (cdr stx))])
|
|
(if (and (eq? a (car stx))
|
|
(eq? b (cdr stx)))
|
|
stx
|
|
(cons a b)))]
|
|
[(symbol? stx)
|
|
(let sloop ([sub-ids sub-ids][sub-vals sub-vals])
|
|
(cond
|
|
[(null? sub-ids) stx]
|
|
[(eq? stx (car sub-ids)) (car sub-vals)]
|
|
[else (sloop (cdr sub-ids) (cdr sub-vals))]))]
|
|
[(syntax? stx)
|
|
(let ([new-e (loop (syntax-e stx))])
|
|
(if (eq? (syntax-e stx) new-e)
|
|
stx
|
|
(datum->syntax/shape stx new-e)))]
|
|
[(vector? stx)
|
|
(list->vector (map loop (vector->list stx)))]
|
|
[(box? stx) (box (loop (unbox stx)))]
|
|
[else stx]))))
|
|
|
|
(-define interp-match
|
|
(lambda (pat e literals immediate=?)
|
|
(let loop ([pat pat][e e][cap e])
|
|
(cond
|
|
[(null? pat)
|
|
(stx-null? e)]
|
|
[(number? pat)
|
|
(and (identifier? e)
|
|
(immediate=? e (vector-ref (syntax-e literals) pat)))]
|
|
[(not pat)
|
|
#t]
|
|
[else
|
|
(let ([i (vector-ref pat 0)])
|
|
(cond
|
|
[(eq? i 'bind)
|
|
(let ([e (if (vector-ref pat 2)
|
|
(datum->syntax cap e cap)
|
|
e)])
|
|
(if (vector-ref pat 1)
|
|
e
|
|
(list e)))]
|
|
[(eq? i 'pair)
|
|
(let ([match-head (vector-ref pat 1)]
|
|
[match-tail (vector-ref pat 2)]
|
|
[mh-did-var? (vector-ref pat 3)]
|
|
[mt-did-var? (vector-ref pat 4)])
|
|
(let ([cap (if (syntax? e) e cap)])
|
|
(and (stx-pair? e)
|
|
(let ([h (loop match-head (stx-car e) cap)])
|
|
(and h
|
|
(let ([t (loop match-tail (stx-cdr e) cap)])
|
|
(and t
|
|
(if mh-did-var?
|
|
(if mt-did-var?
|
|
(append h t)
|
|
h)
|
|
t))))))))]
|
|
[(eq? i 'quote)
|
|
(and (syntax? e)
|
|
(equal? (vector-ref pat 1) (syntax-e e))
|
|
null)]
|
|
[(eq? i 'ellipses)
|
|
(let ([match-head (vector-ref pat 1)]
|
|
[nest-cnt (vector-ref pat 2)]
|
|
[last? (vector-ref pat 3)])
|
|
(and (stx-list? e)
|
|
(if (zero? nest-cnt)
|
|
(andmap (lambda (e) (loop match-head e cap)) (stx->list e))
|
|
(let/ec esc
|
|
(let ([l (map (lambda (e)
|
|
(let ([m (loop match-head e cap)])
|
|
(if m
|
|
m
|
|
(esc #f))))
|
|
(stx->list e))])
|
|
(if (null? l)
|
|
(let loop ([cnt nest-cnt])
|
|
(cond
|
|
[(= 1 cnt) (if last? '() '(()))]
|
|
[else (cons '() (loop (sub1 cnt)))]))
|
|
((if last? stx-rotate* stx-rotate) l)))))))]
|
|
[(eq? i 'mid-ellipses)
|
|
(let ([match-head (vector-ref pat 1)]
|
|
[match-tail (vector-ref pat 2)]
|
|
[tail-cnt (vector-ref pat 3)]
|
|
[prop? (vector-ref pat 4)]
|
|
[mh-did-var? (vector-ref pat 5)]
|
|
[mt-did-var? (vector-ref pat 6)])
|
|
(let-values ([(pre-items post-items ok?)
|
|
(split-stx-list e tail-cnt prop?)]
|
|
[(cap) (if (syntax? e) e cap)])
|
|
(and ok?
|
|
(let ([h (loop match-head pre-items cap)])
|
|
(and h
|
|
(let ([t (loop match-tail post-items cap)])
|
|
(and t
|
|
(if mt-did-var?
|
|
(if mh-did-var?
|
|
(append h t)
|
|
t)
|
|
h))))))))]
|
|
[(eq? i 'veclist)
|
|
(and (stx-vector? e #f)
|
|
(loop (vector-ref pat 1) (vector->list (syntax-e e)) cap))]
|
|
[(eq? i 'vector)
|
|
(and (stx-vector? e (vector-ref pat 1))
|
|
(let vloop ([p (vector-ref pat 2)][pos 0])
|
|
(cond
|
|
[(null? p) null]
|
|
[else
|
|
(let ([clause (car p)])
|
|
(let ([match-elem (car clause)]
|
|
[elem-did-var? (cdr clause)])
|
|
(let ([m (loop match-elem (stx-vector-ref e pos) cap)])
|
|
(and m
|
|
(let ([body (vloop (cdr p) (add1 pos))])
|
|
(and body
|
|
(if elem-did-var?
|
|
(if (null? body)
|
|
m
|
|
(append m body))
|
|
body)))))))])))]
|
|
[(eq? i 'prefab)
|
|
(and (stx-prefab? (vector-ref i 1) e)
|
|
(loop (vector-ref i 2) (cdr (vector->list (struct->vector (syntax-e e)))) cap))]
|
|
[else (error "yikes!" pat)]))]))))
|
|
|
|
(-define-syntax syntax-case**
|
|
(lambda (x)
|
|
(-define l (and (stx-list? x) (cdr (stx->list x))))
|
|
(unless (and (stx-list? x)
|
|
(> (length l) 3))
|
|
(raise-syntax-error
|
|
#f
|
|
"bad form"
|
|
x))
|
|
(let ([who (car l)]
|
|
[arg-is-stx? (cadr l)]
|
|
[expr (caddr l)]
|
|
[kws (cadddr l)]
|
|
[lit-comp (cadddr (cdr l))]
|
|
[clauses (cddddr (cdr l))])
|
|
(unless (stx-list? kws)
|
|
(raise-syntax-error
|
|
(syntax-e who)
|
|
"expected a parenthesized sequence of literal identifiers"
|
|
kws))
|
|
(for-each
|
|
(lambda (lit)
|
|
(unless (identifier? lit)
|
|
(raise-syntax-error
|
|
(syntax-e who)
|
|
"literal is not an identifier"
|
|
lit)))
|
|
(stx->list kws))
|
|
(for-each
|
|
(lambda (clause)
|
|
(unless (and (stx-list? clause)
|
|
(<= 2 (length (stx->list clause)) 3))
|
|
(raise-syntax-error
|
|
(syntax-e who)
|
|
"bad clause"
|
|
clause)))
|
|
clauses)
|
|
(let ([patterns (map stx-car clauses)]
|
|
[fenders (map (lambda (clause)
|
|
(and (stx-pair? (stx-cdr (stx-cdr clause)))
|
|
(stx-car (stx-cdr clause))))
|
|
clauses)]
|
|
[answers (map (lambda (clause)
|
|
(let ([r (stx-cdr (stx-cdr clause))])
|
|
(if (stx-pair? r)
|
|
(stx-car r)
|
|
(stx-car (stx-cdr clause)))))
|
|
clauses)])
|
|
(let* ([arg (quote-syntax arg)]
|
|
[rslt (quote-syntax rslt)]
|
|
[pattern-varss (map
|
|
(lambda (pattern)
|
|
(get-match-vars who pattern pattern (stx->list kws)))
|
|
(stx->list patterns))]
|
|
[lit-comp-is-mod? (and (identifier? lit-comp)
|
|
(free-identifier=?
|
|
lit-comp
|
|
(quote-syntax free-identifier=?)))])
|
|
(datum->syntax
|
|
(quote-syntax here)
|
|
(list (quote-syntax let) (list (list arg (if (syntax-e arg-is-stx?)
|
|
expr
|
|
(list (quote-syntax datum->syntax)
|
|
(list
|
|
(quote-syntax quote-syntax)
|
|
(datum->syntax
|
|
expr
|
|
'here))
|
|
expr))))
|
|
(let loop ([patterns patterns]
|
|
[fenders fenders]
|
|
[unflat-pattern-varss pattern-varss]
|
|
[answers answers])
|
|
(cond
|
|
[(null? patterns)
|
|
(list
|
|
(quote-syntax raise-syntax-error)
|
|
#f
|
|
"bad syntax"
|
|
arg)]
|
|
[else
|
|
(let ([rest (loop (cdr patterns) (cdr fenders)
|
|
(cdr unflat-pattern-varss) (cdr answers))])
|
|
(let ([pattern (car patterns)]
|
|
[fender (car fenders)]
|
|
[unflat-pattern-vars (car unflat-pattern-varss)]
|
|
[answer (car answers)])
|
|
(-define pattern-vars
|
|
(map (lambda (var)
|
|
(let loop ([var var])
|
|
(if (syntax? var)
|
|
var
|
|
(loop (car var)))))
|
|
unflat-pattern-vars))
|
|
(-define temp-vars
|
|
(map
|
|
(lambda (p) (gen-temp-id 'sc))
|
|
pattern-vars))
|
|
(-define tail-pattern-var (sub1 (length pattern-vars)))
|
|
;; Here's the result expression for one match:
|
|
(let* ([do-try-next (if (car fenders)
|
|
(list (quote-syntax try-next))
|
|
rest)]
|
|
[mtch (make-match&env
|
|
who
|
|
pattern
|
|
pattern
|
|
(stx->list kws)
|
|
(not lit-comp-is-mod?))]
|
|
[cant-fail? (if lit-comp-is-mod?
|
|
(equal? mtch '(lambda (e) e))
|
|
(equal? mtch '(lambda (e free-identifier=?) e)))]
|
|
;; Avoid generating gigantic matching expressions.
|
|
;; If it's too big, interpret at run time, instead
|
|
[interp? (and (not cant-fail?)
|
|
(zero?
|
|
(let sz ([mtch mtch][fuel 100])
|
|
(cond
|
|
[(zero? fuel) 0]
|
|
[(pair? mtch) (sz (cdr mtch)
|
|
(sz (car mtch)
|
|
fuel))]
|
|
[(syntax? mtch) (sz (syntax-e mtch) (sub1 fuel))]
|
|
[else (sub1 fuel)]))))]
|
|
[mtch (if interp?
|
|
(let ([interp-box (box null)])
|
|
(let ([pat (make-interp-match pattern (syntax->list kws) interp-box)])
|
|
(list 'lambda
|
|
'(e)
|
|
(list 'interp-match
|
|
(list 'quote pat)
|
|
'e
|
|
(list 'quote-syntax (list->vector (reverse (unbox interp-box))))
|
|
lit-comp))))
|
|
mtch)]
|
|
[m
|
|
;; Do match, bind result to rslt:
|
|
(list (quote-syntax let)
|
|
(list
|
|
(list rslt
|
|
(if cant-fail?
|
|
arg
|
|
(list* (datum->syntax
|
|
(quote-syntax here)
|
|
mtch
|
|
pattern)
|
|
arg
|
|
(if (or interp? lit-comp-is-mod?)
|
|
null
|
|
(list lit-comp))))))
|
|
;; If match succeeded...
|
|
(list
|
|
(quote-syntax if)
|
|
(if cant-fail?
|
|
#t
|
|
rslt)
|
|
;; Extract each name binding into a temp variable:
|
|
(list
|
|
(quote-syntax let)
|
|
(map (lambda (pattern-var temp-var)
|
|
(list
|
|
temp-var
|
|
(let ([pos (stx-memq-pos pattern-var pattern-vars)])
|
|
(let ([accessor (cond
|
|
[(= tail-pattern-var pos)
|
|
(cond
|
|
[(eq? pos 0) 'tail]
|
|
[(eq? pos 1) (quote-syntax cdr)]
|
|
[(eq? pos 2) (quote-syntax cddr)]
|
|
[(eq? pos 3) (quote-syntax cdddr)]
|
|
[(eq? pos 4) (quote-syntax cddddr)]
|
|
[else 'tail])]
|
|
[(eq? pos 0) (quote-syntax car)]
|
|
[(eq? pos 1) (quote-syntax cadr)]
|
|
[(eq? pos 2) (quote-syntax caddr)]
|
|
[(eq? pos 3) (quote-syntax cadddr)]
|
|
[else #f])])
|
|
(cond
|
|
[(eq? accessor 'tail)
|
|
(if (zero? pos)
|
|
rslt
|
|
(list
|
|
(quote-syntax list-tail)
|
|
rslt
|
|
pos))]
|
|
[accessor (list
|
|
accessor
|
|
rslt)]
|
|
[else (list
|
|
(quote-syntax list-ref)
|
|
rslt
|
|
pos)])))))
|
|
pattern-vars temp-vars)
|
|
;; Tell nested `syntax' forms about the
|
|
;; pattern-bound variables:
|
|
(list
|
|
(quote-syntax letrec-syntaxes+values)
|
|
(map (lambda (pattern-var unflat-pattern-var temp-var)
|
|
(list (list pattern-var)
|
|
(list
|
|
(quote-syntax make-syntax-mapping)
|
|
;; Tell it the shape of the variable:
|
|
(let loop ([var unflat-pattern-var][d 0])
|
|
(if (syntax? var)
|
|
d
|
|
(loop (car var) (add1 d))))
|
|
;; Tell it the variable name:
|
|
(list
|
|
(quote-syntax quote-syntax)
|
|
temp-var))))
|
|
pattern-vars unflat-pattern-vars
|
|
temp-vars)
|
|
null
|
|
(if fender
|
|
(list (quote-syntax if) fender
|
|
answer
|
|
do-try-next)
|
|
answer)))
|
|
do-try-next))])
|
|
(if fender
|
|
(list
|
|
(quote-syntax let)
|
|
;; Bind try-next to try next case
|
|
(list (list (quote try-next)
|
|
(list (quote-syntax lambda)
|
|
(list)
|
|
rest)))
|
|
;; Try one match
|
|
m)
|
|
;; Match try already embed the rest case
|
|
m))))])))
|
|
x))))))
|
|
|
|
(-define-syntax syntax
|
|
(lambda (x)
|
|
(-define here-stx (quote-syntax here))
|
|
(unless (and (stx-pair? x)
|
|
(let ([rest (stx-cdr x)])
|
|
(and (stx-pair? rest)
|
|
(stx-null? (stx-cdr rest)))))
|
|
(raise-syntax-error
|
|
#f
|
|
"bad form"
|
|
x))
|
|
(datum->syntax
|
|
here-stx
|
|
(let ([pattern (stx-car (stx-cdr x))])
|
|
(let-values ([(unique-vars all-varss) (make-pexpand pattern #f null #f)])
|
|
(let ([var-bindings
|
|
(map
|
|
(lambda (var)
|
|
(and (let ([v (syntax-local-value var (lambda () #f))])
|
|
(and (syntax-mapping? v)
|
|
v))))
|
|
unique-vars)])
|
|
(if (and (or (null? var-bindings)
|
|
(not (ormap (lambda (x) x) var-bindings)))
|
|
(no-ellipses? pattern))
|
|
;; Constant template:
|
|
(list (quote-syntax quote-syntax) pattern)
|
|
;; Non-constant:
|
|
(let ([proto-r (let loop ([vars unique-vars][bindings var-bindings])
|
|
(if (null? bindings)
|
|
null
|
|
(let ([rest (loop (cdr vars)
|
|
(cdr bindings))])
|
|
(if (car bindings)
|
|
(cons (let loop ([v (car vars)]
|
|
[d (syntax-mapping-depth (car bindings))])
|
|
(if (zero? d)
|
|
v
|
|
(loop (list v) (sub1 d))))
|
|
rest)
|
|
rest))))]
|
|
[non-pattern-vars (let loop ([vars unique-vars][bindings var-bindings])
|
|
(if (null? bindings)
|
|
null
|
|
(let ([rest (loop (cdr vars)
|
|
(cdr bindings))])
|
|
(if (car bindings)
|
|
rest
|
|
(cons (car vars) rest)))))])
|
|
(let ([build-from-template
|
|
;; Even if we don't use the builder, we need to check
|
|
;; for a well-formed pattern:
|
|
(make-pexpand pattern proto-r non-pattern-vars pattern)]
|
|
[r (let loop ([vars unique-vars][bindings var-bindings][all-varss all-varss])
|
|
(cond
|
|
[(null? bindings) null]
|
|
[(car bindings)
|
|
(cons
|
|
(syntax-property
|
|
(let ([id (syntax-mapping-valvar (car bindings))])
|
|
(datum->syntax
|
|
id
|
|
(syntax-e id)
|
|
x))
|
|
'disappeared-use
|
|
(car all-varss))
|
|
(loop (cdr vars) (cdr bindings) (cdr all-varss)))]
|
|
[else (loop (cdr vars) (cdr bindings) (cdr all-varss))]))])
|
|
(if (identifier? pattern)
|
|
;; Simple syntax-id lookup:
|
|
(car r)
|
|
;; General case:
|
|
(list (datum->syntax
|
|
here-stx
|
|
build-from-template
|
|
pattern)
|
|
(let ([len (length r)])
|
|
(cond
|
|
[(zero? len) (quote-syntax ())]
|
|
[(= len 1) (car r)]
|
|
[else
|
|
(cons (quote-syntax list*) r)]))))))))))
|
|
x)))
|
|
|
|
(#%provide (all-from "ellipses.ss") syntax-case** syntax))
|