cyclone/tests/debug/macro-test.scm

;; A temporary testbed file
(import (scheme base)
        (scheme eval)
        ;(scheme file)
        ;(scheme read)
        (scheme write)
        (scheme cyclone common)
        (scheme cyclone util)
        ;(scheme cyclone cgen)
        (scheme cyclone transforms)
        (scheme cyclone macros)
        ;(scheme cyclone libraries)
        )

;(define input-program '(lambda (x) (begin (+ x x) 1 2 3)))
(define input-program 
  '((lambda ()
    (define-syntax test
      (er-macro-transformer
       (lambda (expr rename compare)
         `(begin ,(if (cadr expr) '(test #f) 1) (define tmp #t) 3))))
    (test #t)
    (test #f)
    (write tmp)
    )))

      ;; Load macros for expansion phase
      (let ((macros (filter 
                      (lambda (v) 
                        (macro? (Cyc-get-cvar (cdr v))))
                      (Cyc-global-vars))))
        (set! *defined-macros*
              (append
                macros
                *defined-macros*)))
      (macro:load-env! *defined-macros* (create-environment '() '()))

      ;; Expand macros
      (set! input-program (my-expand input-program (macro:get-env)))
      (write "---------------- after macro expansion:")
      (write input-program) ;pretty-print

;; Expand lambda body here so we can splice in any begin's
(define (expand-body result exp env)
  (cond
   ((null? exp) (reverse result))
   ;; Splice in begin contents and keep expanding body
   ((begin? (car exp))
    (let* ((expr (car exp))
           (begin-exprs (begin->exps expr)))
    (expand-body
     result
     (append begin-exprs (cdr exp))
     env)))
   (else
    (let ((macro #f))
      (when (and (app? (car exp))
                 (symbol? (caar exp)))
        (set! macro (env:lookup (caar exp) env #f)))
      (if (tagged-list? 'macro macro)
          ;; Expand macro here so we can catch begins in the expanded code,
          ;; including nested begins
          (let ((expanded (macro:expand (car exp) macro env)))
            ;; Call with expanded macro in case we need to expand again
            (expand-body
              result
              (cons expanded (cdr exp))
              env))
          ;; No macro, use main expand function to process
          (expand-body
           (cons 
             (inner-expand (car exp) env)
             result)
           (cdr exp)
           env))))))

(define (my-expand exp env)
  (inner-expand exp env))

;; TODO: need to be able to splice expanded begins somehow.
;; maybe pass built up exp list to it and splice the begin into that before
;; continuing expansion
(define (inner-expand exp env) ; body?)
  (cond
    ((const? exp)      exp)
    ((prim? exp)       exp)
    ((ref? exp)        exp)
    ((quote? exp)      exp)
;; TODO: need a way of taking a begin here and splicing its contents
;; into the body
    ((lambda? exp)     `(lambda ,(lambda->formals exp)
                          ,@(expand-body '() (lambda->exp exp) env)
                          ;,@(map 
                          ;  ;; TODO: use extend env here?
                          ;  (lambda (expr) (my-expand expr env))
                          ;  (lambda->exp exp))
                        ))
    ((define? exp)     (if (define-lambda? exp)
                           (inner-expand (define->lambda exp) env)
                          `(define ,(inner-expand (define->var exp) env)
                                ,@(inner-expand (define->exp exp) env))))
    ((set!? exp)       `(set! ,(inner-expand (set!->var exp) env)
                              ,(inner-expand (set!->exp exp) env)))
    ((if? exp)         `(if ,(inner-expand (if->condition exp) env)
                            ,(inner-expand (if->then exp) env)
                            ,(if (if-else? exp)
                                 (inner-expand (if->else exp) env)
                                 ;; Insert default value for missing else clause
                                 ;; FUTURE: append the empty (unprinted) value
                                 ;; instead of #f
                                 #f)))
    ((app? exp)
     (cond
     ((define-syntax? exp)
      (let* ((name (cadr exp))
             (trans (caddr exp))
             (body (cadr trans)))
        (set! *defined-macros* (cons (cons name body) *defined-macros*))
        (macro:add! name body)
        (env:define-variable! name (list 'macro body) env)
        `(define ,name ,(expand body env))))
     ((symbol? (car exp))
      (let ((val (env:lookup (car exp) env #f)))
        (if (tagged-list? 'macro val)
          (inner-expand ; Could expand into another macro
            (macro:expand exp val env)
            env)
          (map
            (lambda (expr) (inner-expand expr env))
            exp))))

     (else
       (map 
        (lambda (expr) (inner-expand expr env))
        exp))))
    (else
      (error "unknown exp: " exp))))