chicken-users
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

Re: [Chicken-users] Feature request: expose quasiquote expander


From: Kon Lovett
Subject: Re: [Chicken-users] Feature request: expose quasiquote expander
Date: Sat, 19 Jan 2008 08:32:57 -0800


On Jan 19, 2008, at 8:24 AM, felix winkelmann wrote:

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).

chicken-sys-macros.scm is also available (but not documented).

(include "chicken-sys-macros")



cheers,
felix


_______________________________________________
Chicken-users mailing list
address@hidden
http://lists.nongnu.org/mailman/listinfo/chicken-users

Best Wishes,
Kon






reply via email to

[Prev in Thread] Current Thread [Next in Thread]