fixing quasiquotation
This commit is contained in:
Danny Yoo
parent
8d0df44458
commit
bf5698c0fa
|
|
@ -80,6 +80,8 @@
|
|||
'srcloc-column
|
||||
'srcloc-position
|
||||
'srcloc-span
|
||||
|
||||
'raise-type-error
|
||||
))
|
||||
(define-predicate KernelPrimitiveName? KernelPrimitiveName)
|
||||
|
||||
|
|
|
|||
|
|
@ -13,11 +13,13 @@
|
|||
)
|
||||
(all-from-out "private/list.rkt")
|
||||
(all-from-out "list.rkt")
|
||||
(all-from-out "private/map.rkt"))
|
||||
(all-from-out "private/map.rkt")
|
||||
quasiquote)
|
||||
|
||||
(require "private/list.rkt"
|
||||
"private/map.rkt"
|
||||
"list.rkt")
|
||||
"list.rkt"
|
||||
(only-in "private/qq-and-or.rkt" quasiquote))
|
||||
|
||||
|
||||
;; Kludge: This forces modbeg to be compiled and packaged.
|
||||
|
|
|
|||
|
|
@ -91,7 +91,6 @@
|
|||
else
|
||||
case
|
||||
quote
|
||||
quasiquote
|
||||
unquote
|
||||
unquote-splicing
|
||||
lambda
|
||||
|
|
|
|||
454
lang/private/qq-and-or.rkt
Normal file
454
lang/private/qq-and-or.rkt
Normal file
|
|
@ -0,0 +1,454 @@
|
|||
|
||||
;;----------------------------------------------------------------------
|
||||
;; 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))
|
||||
210
lang/private/stx.rkt
Normal file
210
lang/private/stx.rkt
Normal file
|
|
@ -0,0 +1,210 @@
|
|||
;;----------------------------------------------------------------------
|
||||
;; basic syntax utilities
|
||||
|
||||
(module stx '#%kernel
|
||||
|
||||
;; These utilities facilitate operations on syntax objects.
|
||||
;; A syntax object that represents a parenthesized sequence
|
||||
;; can contain a mixture of cons cells and syntax objects,
|
||||
;; hence the need for `stx-null?', `stx-car', etc.
|
||||
|
||||
;; a syntax identifier?
|
||||
(define-values (identifier?)
|
||||
(lambda (p)
|
||||
(if (syntax? p)
|
||||
(symbol? (syntax-e p))
|
||||
#f)))
|
||||
|
||||
;; a syntax null?
|
||||
(define-values (stx-null?)
|
||||
(lambda (p)
|
||||
(if (null? p)
|
||||
#t
|
||||
(if (syntax? p)
|
||||
(null? (syntax-e p))
|
||||
#f))))
|
||||
|
||||
;; null if a syntax null?, else #f
|
||||
(define-values (stx-null/#f)
|
||||
(lambda (p)
|
||||
(if (null? p)
|
||||
null
|
||||
(if (syntax? p)
|
||||
(if (null? (syntax-e p))
|
||||
null
|
||||
#f)
|
||||
#f))))
|
||||
|
||||
;; a syntax pair?
|
||||
(define-values (stx-pair?)
|
||||
(lambda (p)
|
||||
(if (pair? p)
|
||||
#t
|
||||
(if (syntax? p)
|
||||
(pair? (syntax-e p))
|
||||
#f))))
|
||||
|
||||
;; a syntax list?
|
||||
(define-values (stx-list?)
|
||||
(lambda (p)
|
||||
(if (list? p)
|
||||
#t
|
||||
(if (syntax? p)
|
||||
(if (list? (syntax-e p))
|
||||
#t
|
||||
(letrec-values ([(loop)
|
||||
(lambda (l)
|
||||
(if (pair? l)
|
||||
(loop (cdr l))
|
||||
(stx-list? l)))])
|
||||
(loop (syntax-e p))))
|
||||
(if (pair? p)
|
||||
(stx-list? (cdr p))
|
||||
#f)))))
|
||||
|
||||
;; car of a syntax pair
|
||||
(define-values (stx-car)
|
||||
(lambda (p)
|
||||
(if (pair? p)
|
||||
(car p)
|
||||
(car (syntax-e p)))))
|
||||
|
||||
;; cdr of a syntax pair
|
||||
(define-values (stx-cdr)
|
||||
(lambda (p)
|
||||
(if (pair? p)
|
||||
(cdr p)
|
||||
(cdr (syntax-e p)))))
|
||||
|
||||
;; Flattens a syntax list into a list
|
||||
(define-values (stx->list)
|
||||
(lambda (e)
|
||||
(if (syntax? e)
|
||||
(syntax->list e)
|
||||
(let-values ([(flat-end)
|
||||
(letrec-values ([(loop)
|
||||
(lambda (l)
|
||||
(if (null? l)
|
||||
#f
|
||||
(if (pair? l)
|
||||
(loop (cdr l))
|
||||
(if (syntax? l)
|
||||
(syntax->list l)
|
||||
#f))))])
|
||||
(loop e))])
|
||||
(if flat-end
|
||||
;; flatten
|
||||
(letrec-values ([(loop)
|
||||
(lambda (l)
|
||||
(if (null? l)
|
||||
null
|
||||
(if (pair? l)
|
||||
(cons (car l) (loop (cdr l)))
|
||||
(if (syntax? l)
|
||||
flat-end
|
||||
#f))))])
|
||||
(loop e))
|
||||
e)))))
|
||||
|
||||
;; a syntax vector?
|
||||
(define-values (stx-vector?)
|
||||
(lambda (p len)
|
||||
(if (syntax? p)
|
||||
(if (vector? (syntax-e p))
|
||||
(if len
|
||||
(= len (vector-length (syntax-e p)))
|
||||
#t)
|
||||
#f)
|
||||
#f)))
|
||||
|
||||
;; syntax vector reference
|
||||
(define-values (stx-vector-ref)
|
||||
(lambda (p pos)
|
||||
(vector-ref (syntax-e p) pos)))
|
||||
|
||||
(define-values (stx-prefab?)
|
||||
(lambda (key v)
|
||||
(if (syntax? v)
|
||||
(equal? key (prefab-struct-key (syntax-e v)))
|
||||
#f)))
|
||||
|
||||
;; used in pattern-matching with an escape proc
|
||||
(define-values (stx-check/esc)
|
||||
(lambda (v esc)
|
||||
(if v
|
||||
v
|
||||
(esc #f))))
|
||||
|
||||
;; used in pattern-matching where #f on the cdr
|
||||
;; is a failure
|
||||
(define-values (cons/#f)
|
||||
(lambda (i l)
|
||||
(if l
|
||||
(cons i l)
|
||||
#f)))
|
||||
|
||||
;; used in pattern-matching where either
|
||||
;; list can be a failure; if it's null, the first
|
||||
;; part might be an improper list
|
||||
(define-values (append/#f)
|
||||
(lambda (l1 l2)
|
||||
(if l1
|
||||
(if l2
|
||||
(if (null? l2)
|
||||
l1
|
||||
(append l1 l2))
|
||||
#f)
|
||||
#f)))
|
||||
|
||||
;; The rotate procedures are used to
|
||||
;; rotate a list of matches with multiple variables to
|
||||
;; get a list of multiple matches for single variables
|
||||
|
||||
(define-values (stx-rotate)
|
||||
(lambda (l)
|
||||
(apply map list l)))
|
||||
|
||||
(define-values (stx-rotate*)
|
||||
(lambda (l)
|
||||
(apply list* (apply map list l))))
|
||||
|
||||
;; The split procedure is used when matching ellipses
|
||||
;; followed by a certain number of patterns
|
||||
(define-values (split-stx-list)
|
||||
(lambda (s n prop?)
|
||||
(let-values ([(pre post m)
|
||||
(letrec-values ([(loop)
|
||||
(lambda (s)
|
||||
(if (stx-pair? s)
|
||||
(let-values ([(pre post m) (loop (stx-cdr s))])
|
||||
(if (< m n)
|
||||
(values '() s (add1 m))
|
||||
(values (cons (stx-car s) pre) post m)))
|
||||
(values '() s (if prop?
|
||||
(if (stx-null? s)
|
||||
0
|
||||
-inf.0)
|
||||
1))))])
|
||||
(loop s))])
|
||||
(values pre post (= m n)))))
|
||||
|
||||
(define-values (intro) #f)
|
||||
(define-values (gen-temp-id)
|
||||
;; Even though we gensym, using an introducer helps the
|
||||
;; syntax system simplify renamings that can't apply
|
||||
;; to other identifiers (when the generated identifier
|
||||
;; is used as a binding id)
|
||||
(lambda (pfx)
|
||||
(if intro
|
||||
(void)
|
||||
(set! intro (make-syntax-introducer)))
|
||||
(intro (datum->syntax #f (gensym pfx)))))
|
||||
|
||||
(#%provide identifier? stx-null? stx-null/#f stx-pair? stx-list?
|
||||
stx-car stx-cdr stx->list
|
||||
stx-vector? stx-vector-ref
|
||||
stx-prefab?
|
||||
stx-check/esc cons/#f append/#f
|
||||
stx-rotate stx-rotate*
|
||||
split-stx-list
|
||||
gen-temp-id))
|
||||
1
tests/more-tests/quasi.expected
Normal file
1
tests/more-tests/quasi.expected
Normal file
|
|
@ -0,0 +1 @@
|
|||
(0 1 2 4)
|
||||
2
tests/more-tests/quasi.rkt
Normal file
2
tests/more-tests/quasi.rkt
Normal file
|
|
@ -0,0 +1,2 @@
|
|||
#lang planet dyoo/whalesong
|
||||
`(0 ,@(list 1 2) 4)
|
||||
|
|
@ -14,6 +14,7 @@
|
|||
(test "more-tests/hello.rkt")
|
||||
(test "more-tests/sharing.rkt")
|
||||
(test "more-tests/simple-functions.rkt")
|
||||
(test "more-tests/quasi.rkt")
|
||||
(test "more-tests/sk-generator.rkt")
|
||||
(test "more-tests/sk-generator-2.rkt")
|
||||
(test "more-tests/simple-structs.rkt")
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user