; macroexpand.lisp by Michael Thorpe 2010-08-12 (define #macro-expansions ()) (define #macro-expand-debug #f) (define (macro-expand-list l) (ifelse (pair? l) (let ((a (macro-expand (car l))) (d (macro-expand-list (cdr l)))) (ifelse (and (eq? a (car l)) (eq? d (cdr l))) l (cons a d))) l)) (define (macro-expand o) (ifelse (pair? o) (let ((macro (get #macro-expansions (car o)))) (if macro (let ((expansion #f)) (catch #f (set expansion (macro o)) (progn (if #macro-expand-debug (dprint 'macro-expand 'error: #exception #exceptionvalue)) (throw 'macro-error o))) (unless (eq? expansion o) (set o (macro-expand expansion))))) (macro-expand-list o)) o)) (define (#macro-define macro func) (set #macro-expansions (cons (cons macro func) #macro-expansions)) macro) (macro-define (caar o) `(car (car ,(car (cdr o))))) (macro-define (cadr o) `(car (cdr ,(car (cdr o))))) (macro-define (cdar o) `(cdr (car ,(cadr o)))) (macro-define (cddr o) `(cdr (cdr ,(cadr o)))) (macro-define (caaar o) `(car (car (car ,(cadr o))))) (macro-define (caadr o) `(car (car (cdr ,(cadr o))))) (macro-define (cadar o) `(car (cdr (car ,(cadr o))))) (macro-define (caddr o) `(car (cdr (cdr ,(cadr o))))) (macro-define (cdaar o) `(cdr (car (car ,(cadr o))))) (macro-define (cdadr o) `(cdr (car (cdr ,(cadr o))))) (macro-define (cddar o) `(cdr (cdr (car ,(cadr o))))) (macro-define (cdddr o) `(cdr (cdr (cdr ,(cadr o))))) (macro-define (cadddr o) `(car (cdr (cdr (cdr ,(cadr o)))))) (macro-define (cddddr o) `(cdr (cdr (cdr (cdr ,(cadr o)))))) (macro-define (list o) (ifelse (cdr o) (ifelse (pair? (cddr o)) `(cons ,(cadr o) ,(cons 'list (cddr o))) `(cons ,(cadr o) ,(cddr o))) #f)) (macro-define (progn o) (ifelse (pair? (cddr o)) (list '#prog2of2 (cadr o) (quote (macro-expand (cons 'progn (cddr o))))) (cadr o))) (macro-define (prog1 o) (ifelse (cddr o) `(#prog1of2 ,(cadr o) ,(cons 'progn (cddr o))) (cadr o))) (macro-define (prog2 o) (ifelse (cdddr o) `(#prog1of2 (progn ,(cadr o) ,(caddr o)) ,(cons 'progn (cdddr o))) `(#prog2of2 ,(cadr o) ,(caddr o)))) (macro-define (lambda o) (ifelse (pair? (cdr o)) (list '#lambda (quote (cadr o)) (quote (macro-expand (cons 'progn (cddr o))))) o)) (macro-define (macro-define o) (ifelse (pair? (cadr o)) `(#macro-define ,(quote (caadr o)) (lambda ,(cdadr o) ,(cons 'progn (cddr o)))) (ifelse (cdddr o) (throw 'macro-error o) `(#macro-define ,(quote (cadr o)) ,(caddr o))))) (macro-define (ifelse o) (if (cddddr o) (throw 'macro-error o)) (list '#ifelse (cadr o) (quote (macro-expand (caddr o))) (quote (macro-expand (cadddr o))))) (macro-define (define o) (ifelse (pair? (cadr o)) `(#define ,(quote (caadr o)) (lambda ,(cdadr o) ,(cons 'progn (cddr o)))) (ifelse (cdddr o) (throw 'macro-error o) `(#define ,(quote (cadr o)) ,(caddr o))))) (macro-define (catch o) (if (cddddr o) (throw 'macro-error o)) (list '#catch (cadr o) (quote (macro-expand (caddr o))) (quote (macro-expand (cadddr o))))) (macro-define (let o) (ifelse (pair? (cadr o)) (list '#let (quote (car (caadr o))) (cons 'progn (cdr (caadr o))) (quote (macro-expand (cons 'let (cons (cdadr o) (cddr o)))))) (cons 'progn (cddr o)))) (macro-define (loop o) (list '#loop (quote (macro-expand (cons 'progn (cdr o)))))) (macro-define (neq? o) (if (cdddr o) (throw 'macro-error o)) `(not (eq? ,(cadr o) ,(caddr o)))) (macro-define (set o) (ifelse (pair? (cadr o)) (list '#set (quote (car (cadr o))) (list 'lambda (cdr (cadr o)) (cons 'progn (cddr o)))) (ifelse (cdddr o) (throw 'macro-error o) (list '#set (quote (cadr o)) (caddr o))))) ; Used for macro-define'ing +, -, etc. (define (#two-op-expander op form) (ifelse (cddr form) (ifelse (or (cdddr form) (neq? op (car form))) (let ((new (cadr form))) (set form (cddr form)) (while form (set new (list op new (car form))) (set form (cdr form))) new) form) (cadr form))) (macro-define (+ o) (#two-op-expander '+ o)) (macro-define (- o) (ifelse (cddr o) ; special case; make (- 42) come out -42 (#two-op-expander '- o) (list '- 0 (cadr o)))) (macro-define (* o) (#two-op-expander '* o)) (macro-define (/ o) (#two-op-expander '/ o)) ; Used for macro-define'ing and, or, etc. (define (#two-op-expander-quote2 op form) (ifelse (cddr form) (ifelse (or (cdddr form) (neq? op (car form))) (let ((new (cadr form))) (set form (cddr form)) (while form (set new (list op new (quote (macro-expand (car form))))) (set form (cdr form))) new) form) (cadr form))) (macro-define (and o) (#two-op-expander-quote2 '#and o)) (macro-define (or o) (#two-op-expander-quote2 '#or o)) (macro-define (defined? o) (if (cddr o) (throw 'macro-error o)) (if (not (word? (cadr o))) (throw 'macro-error o)) (list 'catch ''undefined (list 'progn (cadr o) #t) #f)) (macro-define (exit-loop o) (let ((val (ifelse (cdr o) (cons 'progn (cdr o)) #f))) (list '#exit-loop val))) (macro-define (next-loop o) (if (cdr o) (throw 'macro-error o)) (list '#next-loop)) (macro-define (if o) (list 'ifelse (cadr o) (cons 'progn (cddr o)) #f)) (macro-define (unless o) (list 'ifelse (cadr o) #f (cons 'progn (cddr o)))) (macro-define (while o) `(loop (ifelse ,(cadr o) ,(cons 'progn (cddr o)) (exit-loop ,#f)))) (macro-define (string-concatenate o) `(concatenate-strings ,(cons 'list (cdr o)))) (macro-define (map o) (if (cddddr o) (throw 'macro-error o)) (list '#map (quote (cadr o)) (quote (macro-expand (caddr o))) (cadddr o))) (macro-define (map-safe o) (if (cddddr o) (throw 'macro-error o)) (list '#map-safe (quote (cadr o)) (quote (macro-expand (caddr o))) (cadddr o))) (macro-define (filter o) (if (cddddr o) (throw 'macro-error o)) (list '#filter (quote (cadr o)) (quote (macro-expand (caddr o))) (cadddr o))) (macro-define (append o) (let ((arg1 (macro-expand (cadr o)))) (ifelse (cddr o) (ifelse ; Simplify if this is like (append `((op . arg)) `((op . arg))) in compiler.lisp (and (pair? arg1) (eq? (car arg1) 'cons) (cdr arg1) (pair? (cdr arg1)) (cddr arg1) (pair? (cddr arg1)) (not (cdddr arg1)) (not (caddr arg1))) `(cons ,(cadr arg1) ,(cons 'append (cddr o))) `(#append/reversed ,(cons 'append (cddr o)) (#append/reversed #f ,arg1))) arg1))) (macro-define (reverse o) (if (cddr o) (throw 'macro-error o)) `(#append/reversed #f ,(cadr o)))