[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
Re: [Chicken-users] Feature request: expose quasiquote expander
From: |
felix winkelmann |
Subject: |
Re: [Chicken-users] Feature request: expose quasiquote expander |
Date: |
Sat, 19 Jan 2008 17:24:32 +0100 |
On Jan 18, 2008 10:14 AM, John Cowan <address@hidden> wrote:
> Can you expose and document Chicken's quasiquote expansion function?
> I want to be able to use it for S-expressions other than native Scheme
> ones.
>
I recommend to write your own or take the chicken quasiquote stuff
and re-use it directly, it's not very much code. It's also very ugly:
(##sys#register-macro
'quasiquote
(let ((vector->list vector->list))
(lambda (form)
(define (walk x n) (simplify (walk1 x n)))
(define (walk1 x n)
(if (##core#inline "C_blockp" x)
(cond ((##core#inline "C_vectorp" x)
`(##sys#list->vector ,(walk (vector->list x) n)) )
((not (##core#inline "C_pairp" x)) `(quote ,x))
(else
(let ((head (##sys#slot x 0))
(tail (##sys#slot x 1)) )
(case head
((unquote)
(if (and (##core#inline "C_blockp" tail) (##core#inline
"C_pairp" tail))
(let ((hx (##sys#slot tail 0)))
(if (eq? n 0)
hx
(list '##sys#list '(quote unquote)
(walk hx (fx- n 1)) ) ) )
'(quote unquote) ) )
((quasiquote)
(if (and (##core#inline "C_blockp" tail) (##core#inline
"C_pairp" tail))
`(##sys#list (quote quasiquote)
,(walk (##sys#slot tail 0) (fx+ n 1)) )
(list '##sys#cons (list 'quote 'quasiquote) (walk
tail n)) ) )
(else
(if (and (##core#inline "C_blockp" head) (##core#inline
"C_pairp" head))
(let ((hx (##sys#slot head 0))
(tx (##sys#slot head 1)) )
(if (and (eq? hx 'unquote-splicing)
(##core#inline "C_blockp" tx)
(##core#inline "C_pairp" tx) )
(let ((htx (##sys#slot tx 0)))
(if (eq? n 0)
`(##sys#append ,htx
,(walk tail n) )
`(##sys#cons (##sys#list
'unquote-splicing
,(walk htx (fx- n 1)) )
,(walk tail n) ) ) )
`(##sys#cons ,(walk head n) ,(walk tail n)) ) )
`(##sys#cons ,(walk head n) ,(walk tail n)) ) ) ) )
) )
`(quote ,x) ) )
(define (simplify x)
(cond ((##sys#match-expression x '(##sys#cons a '()) '(a))
=> (lambda (env) (simplify `(##sys#list ,(##sys#slot (assq 'a
env) 1)))) )
((##sys#match-expression x '(##sys#cons a (##sys#list . b)) '(a b))
=> (lambda (env)
(let ([bxs (assq 'b env)])
(if (fx< (length bxs) 32)
(simplify `(##sys#list ,(##sys#slot (assq 'a env) 1)
,@(##sys#slot bxs 1) ) )
x) ) ) )
((##sys#match-expression x '(##sys#append a '()) '(a))
=> (lambda (env) (##sys#slot (assq 'a env) 1)) )
(else x) ) )
(walk form 0) ) ) )
I told you it's ugly.
This code was written for slower chickens, so it's pretty gnarly. Most of
the ##sys#'s and ##core#'s and ##sys#slots can be replaced by the usual
operations (slot #0 is car, and slot #1 is cdr).
cheers,
felix