[plt-scheme] Macro update

In case anyone is feverishly hacking away at the macro
I emailed, I've made substantial progress.  It appears
I've got a working macro, just the funky structures I
defined don't work with match so I'm going to have to
rework it a bit.  I also think I'm long past the time
when I'm getting any return for extra effort so I'm
going to get some sleep.

Noel

The macro is:

  (define-syntax production
    (lambda (stx)
      (syntax-case stx ()
        ((_)
         (syntax (list)))
        ((_ head rest ...)
         (syntax (cons head (production rest ...))))
        ((_ (head subtree ...) rest ...)
         (syntax
          (cons
           (production head subtree ...)
           (production rest ...)))))))
  
  (define-syntax (l-system stx)
    (syntax-case stx ()
      ((l-system
        ((name param ...) rhs ...) ...)
       (datum->syntax-object 
        stx
        (syntax
         (letrec
             ([loop
               (lambda (lst)
                 (cond
                   [(null? lst) lst]
                   [(and (pair? lst)
                         (pair? (car lst)))
                    (append (cons
                             (matcher (car (car lst)))
                             (loop (cdr (car lst))))
                            (loop (cdr lst)))]
                   [(pair? lst)
                    (cons
                     (matcher (car lst)) 
                     (loop (cdr lst)))]))]
              [matcher
               (lambda (head)
                 (match head
                   [(struct name (param ...))
                    (production rhs ...)]
                   ...))])
           loop))))))
  

The funky structs that don't work with match are:

  ;; words for parametric l-systems
  ;; essentially closures that can be inspected
  (define-syntax (define-word stx)
    (syntax-case stx ()
      ((define-word (name param ...) expr ...)
       (with-syntax 
           ([(struct:name name name?)
             (let ((name-sym (syntax-object->datum
(syntax name))))
               (map (lambda (sym)
                      (datum->syntax-object (syntax
name) sym (syntax name)))
                    (list
                     (symbol-append 'struct: name-sym)

                     name-sym
                     (symbol-append name-sym '?))))]
            [(name-param-accessor ...)
             (let ((name-sym (syntax-object->datum
(syntax name))))
               (map (lambda (param)
                      (datum->syntax-object (syntax
name)
                                           
(symbol-append name-sym '- param)
                                            (syntax
name)))
                    (syntax-object->datum 
                     (syntax (param ...)))))])        
                                
         (syntax
          (define-values (struct:name name name?
name-param-accessor ...)
            (let ((number-of-params (length (list
(quote param) ...))))
              (letrec-values (((struct:name make-name
name? name-ref name-set!)
                               (make-struct-type
(quote name)
                                                
struct:word
                                                
number-of-params
                                                 0
                                                 #f
                                                 null
                                                
(current-inspector)
                                                
(lambda (word) 
                                                  
(apply
                                                   
(lambda (param ...) expr ...)
                                                   
(let loop ((i 0))
                                                     
(if (= i number-of-params)
                                                      
   (list)
                                                      
   (cons (name-ref word i)
                                                      
         (loop (add1 i))))))))))
                (apply values
                       struct:name
                       (lambda (param ...)
                         (make-name (quote name) param
...))
                       name?
                       (let loop ((i 0))
                         (if (= i number-of-params)
                             (list)
                             (cons (lambda (word)
(name-ref word i))
                                   (loop (add1
i))))))))))))))
  

An example is:

  (define-word (word-1 a b c) (list a b c))
  
  (define l-system-tests
    (make-test-suite
     "L-System tests"
             
     (make-test-case
      "define-word test"
      (let ((the-word (word-1 1 2 3)))
        (assert-equal? (the-word)
                       (list 1 2 3))))
     (make-test-case
      "word accessor test"
      (let ((the-word (word-1 1 2 3)))
        (assert-equal? (word-1-a the-word) 1)
        (assert-equal? (word-1-b the-word) 2)
        (assert-equal? (word-1-c the-word) 3)))
     (make-test-case
      "word predicate procedure test"
      (assert-true (word-1? (word-1 1 2 3))))
     
     (make-test-case
      "simple parameterised l-system test"
      (assert-equal?
       ((l-system ((word-1 1 b c) (+ b c) (+ b c))
                  ((word-1 a b c) (+ a b c)))
        (list (word-1 1 2 3) (word-1 2 3 4)))
       (list 5 5 9)))

=====
Email: noelwelsh <at> yahoo <dot> com
Jabber: noelw <at> jabber <dot> org

__________________________________
Do you Yahoo!?
Yahoo! SiteBuilder - Free web site building tool. Try it!
http://webhosting.yahoo.com/ps/sb/