455 lines
22 KiB
Racket
455 lines
22 KiB
Racket
|
|
;;----------------------------------------------------------------------
|
|
;; quasiquote, and, or
|
|
|
|
(module qq-and-or '#%kernel
|
|
(#%require (for-syntax "stx.rkt" '#%kernel))
|
|
|
|
(define-syntaxes (let let* letrec)
|
|
(let-values ([(lambda-stx) (quote-syntax lambda-stx)]
|
|
[(letrec-values-stx) (quote-syntax letrec-values)])
|
|
(let-values ([(go)
|
|
(lambda (stx named? star? target)
|
|
(define-values (stx-cadr) (lambda (x) (stx-car (stx-cdr x))))
|
|
(define-values (id-in-list?)
|
|
(lambda (id l)
|
|
(if (null? l)
|
|
#f
|
|
(if (bound-identifier=? id (car l))
|
|
#t
|
|
(id-in-list? id (cdr l))))))
|
|
(define-values (stx-2list?)
|
|
(lambda (x)
|
|
(if (stx-pair? x)
|
|
(if (stx-pair? (stx-cdr x))
|
|
(stx-null? (stx-cdr (stx-cdr x)))
|
|
#f)
|
|
#f)))
|
|
(if (if (not (stx-list? stx))
|
|
#t
|
|
(let-values ([(tail1) (stx-cdr stx)])
|
|
(if (stx-null? tail1)
|
|
#t
|
|
(if (stx-null? (stx-cdr tail1))
|
|
#t
|
|
(if named?
|
|
(if (symbol? (syntax-e (stx-car tail1)))
|
|
(stx-null? (stx-cdr (stx-cdr tail1)))
|
|
#f)
|
|
#f)))))
|
|
(raise-syntax-error #f "bad syntax" stx)
|
|
(void))
|
|
(let-values ([(name) (if named?
|
|
(let-values ([(n) (stx-cadr stx)])
|
|
(if (symbol? (syntax-e n))
|
|
n
|
|
#f))
|
|
#f)])
|
|
(let-values ([(bindings) (stx->list (stx-cadr (if name
|
|
(stx-cdr stx)
|
|
stx)))]
|
|
[(body) (stx-cdr (stx-cdr (if name
|
|
(stx-cdr stx)
|
|
stx)))])
|
|
(if (not bindings)
|
|
(raise-syntax-error
|
|
#f
|
|
"bad syntax (not a sequence of identifier--expression bindings)"
|
|
stx
|
|
(stx-cadr stx))
|
|
(let-values ([(new-bindings)
|
|
(letrec-values ([(loop)
|
|
(lambda (l)
|
|
(if (null? l)
|
|
null
|
|
(let-values ([(binding) (car l)])
|
|
(cons
|
|
(if (stx-2list? binding)
|
|
(if (symbol? (syntax-e (stx-car binding)))
|
|
(if name
|
|
(cons (stx-car binding)
|
|
(stx-cadr binding))
|
|
(datum->syntax
|
|
lambda-stx
|
|
(cons (cons (stx-car binding)
|
|
null)
|
|
(stx-cdr binding))
|
|
binding))
|
|
(raise-syntax-error
|
|
#f
|
|
"bad syntax (not an identifier)"
|
|
stx
|
|
(stx-car binding)))
|
|
(raise-syntax-error
|
|
#f
|
|
"bad syntax (not an identifier and expression for a binding)"
|
|
stx
|
|
binding))
|
|
(loop (cdr l))))))])
|
|
(loop bindings))])
|
|
(if star?
|
|
(void)
|
|
(if ((length new-bindings) . > . 5)
|
|
(let-values ([(ht) (make-hasheq)])
|
|
(letrec-values ([(check) (lambda (l)
|
|
(if (null? l)
|
|
(void)
|
|
(let*-values ([(id) (if name
|
|
(caar l)
|
|
(stx-car (stx-car (car l))))]
|
|
[(idl) (hash-ref ht (syntax-e id) null)])
|
|
(if (id-in-list? id idl)
|
|
(raise-syntax-error
|
|
#f
|
|
"duplicate identifier"
|
|
stx
|
|
id)
|
|
(begin
|
|
(hash-set! ht (syntax-e id) (cons id idl))
|
|
(check (cdr l)))))))])
|
|
(check new-bindings)))
|
|
(letrec-values ([(check) (lambda (l accum)
|
|
(if (null? l)
|
|
(void)
|
|
(let-values ([(id) (if name
|
|
(caar l)
|
|
(stx-car (stx-car (car l))))])
|
|
(if (id-in-list? id accum)
|
|
(raise-syntax-error
|
|
#f
|
|
"duplicate identifier"
|
|
stx
|
|
id)
|
|
(check (cdr l) (cons id accum))))))])
|
|
(check new-bindings null))))
|
|
(datum->syntax
|
|
lambda-stx
|
|
(if name
|
|
(apply list
|
|
(list
|
|
(quote-syntax letrec-values)
|
|
(list
|
|
(list
|
|
(list name)
|
|
(list* (quote-syntax lambda)
|
|
(apply list (map car new-bindings))
|
|
body)))
|
|
name)
|
|
(map cdr new-bindings))
|
|
(list* target
|
|
new-bindings
|
|
body))
|
|
stx))))))])
|
|
(values
|
|
(lambda (stx) (go stx #t #f (quote-syntax let-values)))
|
|
(lambda (stx) (go stx #f #t (quote-syntax let*-values)))
|
|
(lambda (stx) (go stx #f #f (quote-syntax letrec-values)))))))
|
|
|
|
(define-values (qq-append)
|
|
(lambda (a b)
|
|
(if (list? a)
|
|
(append a b)
|
|
(raise-type-error 'unquote-splicing "proper list" a))))
|
|
|
|
(define-syntaxes (quasiquote)
|
|
(let-values ([(here) (quote-syntax here)] ; id with module bindings, but not lexical
|
|
[(unquote-stx) (quote-syntax unquote)]
|
|
[(unquote-splicing-stx) (quote-syntax unquote-splicing)])
|
|
(lambda (in-form)
|
|
(if (identifier? in-form)
|
|
(raise-syntax-error #f "bad syntax" in-form)
|
|
(void))
|
|
(let-values
|
|
(((form) (if (stx-pair? (stx-cdr in-form))
|
|
(if (stx-null? (stx-cdr (stx-cdr in-form)))
|
|
(stx-car (stx-cdr in-form))
|
|
(raise-syntax-error #f "bad syntax" in-form))
|
|
(raise-syntax-error #f "bad syntax" in-form)))
|
|
((normal)
|
|
(lambda (x old)
|
|
(if (eq? x old)
|
|
(if (stx-null? x)
|
|
(quote-syntax ())
|
|
(list (quote-syntax quote) x))
|
|
x)))
|
|
((apply-cons)
|
|
(lambda (a d)
|
|
(if (stx-null? d)
|
|
(list (quote-syntax list) a)
|
|
(if (if (pair? d)
|
|
(if (free-identifier=? (quote-syntax list) (car d))
|
|
#t
|
|
(free-identifier=? (quote-syntax list*) (car d)))
|
|
#f)
|
|
(list* (car d) a (cdr d))
|
|
(list (quote-syntax list*) a d))))))
|
|
(datum->syntax
|
|
here
|
|
(normal
|
|
(letrec-values
|
|
(((qq)
|
|
(lambda (x level)
|
|
(let-values
|
|
(((qq-list)
|
|
(lambda (x level)
|
|
(let-values
|
|
(((old-first) (stx-car x)))
|
|
(let-values
|
|
(((old-second) (stx-cdr x)))
|
|
(let-values
|
|
(((first) (qq old-first level)))
|
|
(let-values
|
|
(((second) (qq old-second level)))
|
|
(let-values
|
|
()
|
|
(if (if (eq? first old-first)
|
|
(eq? second old-second)
|
|
#f)
|
|
x
|
|
(apply-cons
|
|
(normal first old-first)
|
|
(normal second old-second)))))))))))
|
|
(if (stx-pair? x)
|
|
(let-values
|
|
(((first) (stx-car x)))
|
|
(if (if (if (identifier? first)
|
|
(free-identifier=? first unquote-stx)
|
|
#f)
|
|
(stx-list? x)
|
|
#f)
|
|
(let-values
|
|
(((rest) (stx-cdr x)))
|
|
(if (let-values
|
|
(((g35) (not (stx-pair? rest))))
|
|
(if g35 g35 (not (stx-null? (stx-cdr rest)))))
|
|
(raise-syntax-error
|
|
'unquote
|
|
"expects exactly one expression"
|
|
in-form
|
|
x)
|
|
(void))
|
|
(if (zero? level)
|
|
(stx-car rest)
|
|
(qq-list x (sub1 level))))
|
|
(if (if (if (identifier? first)
|
|
(free-identifier=? first (quote-syntax quasiquote))
|
|
#f)
|
|
(stx-list? x)
|
|
#f)
|
|
(qq-list x (add1 level))
|
|
(if (if (if (identifier? first)
|
|
(free-identifier=? first unquote-splicing-stx)
|
|
#f)
|
|
(stx-list? x)
|
|
#f)
|
|
(raise-syntax-error
|
|
'unquote-splicing
|
|
"invalid context within quasiquote"
|
|
in-form
|
|
x)
|
|
(if (if (stx-pair? first)
|
|
(if (identifier? (stx-car first))
|
|
(if (free-identifier=? (stx-car first)
|
|
unquote-splicing-stx)
|
|
(stx-list? first)
|
|
#F)
|
|
#f)
|
|
#f)
|
|
(let-values
|
|
(((rest) (stx-cdr first)))
|
|
(if (let-values
|
|
(((g34) (not (stx-pair? rest))))
|
|
(if g34
|
|
g34
|
|
(not (stx-null? (stx-cdr rest)))))
|
|
(raise-syntax-error
|
|
'unquote
|
|
"expects exactly one expression"
|
|
in-form
|
|
x)
|
|
(void))
|
|
(let-values
|
|
(((uqsd) (stx-car rest))
|
|
((old-l) (stx-cdr x))
|
|
((l) (qq (stx-cdr x) level)))
|
|
(if (zero? level)
|
|
(let-values
|
|
(((l) (normal l old-l)))
|
|
(if (stx-null? l)
|
|
uqsd
|
|
(list (quote-syntax qq-append)
|
|
uqsd l)))
|
|
(let-values
|
|
(((restx) (qq-list rest (sub1 level))))
|
|
(let-values
|
|
()
|
|
(if (if (eq? l old-l)
|
|
(eq? restx rest)
|
|
#f)
|
|
x
|
|
(apply-cons
|
|
(apply-cons
|
|
(quote-syntax (quote unquote-splicing))
|
|
(normal restx rest))
|
|
(normal l old-l))))))))
|
|
(qq-list x level))))))
|
|
(if (if (syntax? x)
|
|
(vector? (syntax-e x))
|
|
#f)
|
|
(let-values
|
|
(((l) (vector->list (syntax-e x))))
|
|
;; special case: disallow #(unquote <e>)
|
|
(if (stx-pair? l)
|
|
(let-values ([(first) (stx-car l)])
|
|
(if (identifier? first)
|
|
(if (free-identifier=? first unquote-stx)
|
|
(raise-syntax-error
|
|
'unquote
|
|
"invalid context within quasiquote"
|
|
in-form
|
|
first)
|
|
(void))
|
|
(void)))
|
|
(void))
|
|
(let-values
|
|
(((l2) (qq l level)))
|
|
(if (eq? l l2)
|
|
x
|
|
(list (quote-syntax list->vector) l2))))
|
|
(if (if (syntax? x) (box? (syntax-e x)) #f)
|
|
(let-values
|
|
(((v) (unbox (syntax-e x))))
|
|
(let-values
|
|
(((qv) (qq v level)))
|
|
(if (eq? v qv)
|
|
x
|
|
(list (quote-syntax box) qv))))
|
|
(if (if (syntax? x)
|
|
(if (struct? (syntax-e x))
|
|
(prefab-struct-key (syntax-e x))
|
|
#f)
|
|
#f)
|
|
;; pre-fab struct
|
|
(let-values
|
|
(((l) (cdr (vector->list (struct->vector (syntax-e x))))))
|
|
(let-values
|
|
(((l2) (qq l level)))
|
|
(if (eq? l l2)
|
|
x
|
|
(list (quote-syntax apply)
|
|
(quote-syntax make-prefab-struct)
|
|
(list (quote-syntax quote)
|
|
(prefab-struct-key (syntax-e x)))
|
|
l2))))
|
|
;; hash[eq[v]]
|
|
(if (if (syntax? x)
|
|
(hash? (syntax-e x))
|
|
#f)
|
|
(letrec-values
|
|
(((qq-hash-assocs)
|
|
(lambda (x level)
|
|
(if (null? x)
|
|
x
|
|
(let-values
|
|
(((pair) (car x)))
|
|
(let-values ([(val)
|
|
(qq (datum->syntax here (cdr pair)) level)]
|
|
[(rest)
|
|
(qq-hash-assocs (cdr x) level)])
|
|
(if (if (eq? val (cdr pair))
|
|
(eq? rest (cdr x))
|
|
#f)
|
|
x
|
|
(apply-cons
|
|
(list (quote-syntax list*)
|
|
(list (quote-syntax quote)
|
|
(datum->syntax here (car pair)))
|
|
(if (eq? val (cdr pair))
|
|
(list (quote-syntax quote)
|
|
val)
|
|
val))
|
|
(if (eq? rest (cdr x))
|
|
(list (quote-syntax quote)
|
|
rest)
|
|
rest)))))))))
|
|
(let-values (((l0) (hash-map (syntax-e x) cons)))
|
|
(let-values
|
|
(((l) (qq-hash-assocs l0 level)))
|
|
(if (eq? l0 l)
|
|
x
|
|
(list (if (hash-eq? (syntax-e x))
|
|
(quote-syntax make-immutable-hasheq)
|
|
(if (hash-eqv? (syntax-e x))
|
|
(quote-syntax make-immutable-hasheqv)
|
|
(quote-syntax make-immutable-hash)))
|
|
l)))))
|
|
x)))))))))
|
|
(qq form 0))
|
|
form)
|
|
in-form)))))
|
|
|
|
(define-syntaxes (and)
|
|
(let-values ([(here) (quote-syntax here)])
|
|
(lambda (x)
|
|
(if (not (stx-list? x))
|
|
(raise-syntax-error #f "bad syntax" x)
|
|
(void))
|
|
(let-values ([(e) (stx-cdr x)])
|
|
(if (stx-null? e)
|
|
(quote-syntax #t)
|
|
(if (if (stx-pair? e)
|
|
(stx-null? (stx-cdr e))
|
|
#t)
|
|
(datum->syntax
|
|
here
|
|
(list (quote-syntax #%expression)
|
|
(stx-car e))
|
|
x)
|
|
(datum->syntax
|
|
here
|
|
(list (quote-syntax if)
|
|
(stx-car e)
|
|
(cons (quote-syntax and)
|
|
(stx-cdr e))
|
|
(quote-syntax #f))
|
|
x)))))))
|
|
|
|
(define-syntaxes (or)
|
|
(let-values ([(here) (quote-syntax here)])
|
|
(lambda (x)
|
|
(if (identifier? x)
|
|
(raise-syntax-error #f "bad syntax" x)
|
|
(void))
|
|
(let-values ([(e) (stx-cdr x)])
|
|
(if (stx-null? e)
|
|
(quote-syntax #f)
|
|
(if (if (stx-pair? e)
|
|
(stx-null? (stx-cdr e))
|
|
#f)
|
|
(datum->syntax
|
|
here
|
|
(list (quote-syntax #%expression)
|
|
(stx-car e))
|
|
x)
|
|
(if (stx-list? e)
|
|
(let-values ([(tmp) 'or-part])
|
|
(datum->syntax
|
|
here
|
|
(list (quote-syntax let) (list
|
|
(list
|
|
tmp
|
|
(stx-car e)))
|
|
(list (quote-syntax if)
|
|
tmp
|
|
tmp
|
|
(cons (quote-syntax or)
|
|
(stx-cdr e))))
|
|
x))
|
|
(raise-syntax-error
|
|
#f
|
|
"bad syntax"
|
|
x))))))))
|
|
|
|
(#%provide let let* letrec
|
|
quasiquote and or))
|