(defun init-scheme-compiler () (init-scheme-macros) ) (defun init-scheme-macros nil (def-scheme-macro and (&rest args) (cond ((null args) 'T) ((null (cdr args)) (car args)) (t `(if ,(car args) (and ,@(cdr args)))))) (def-scheme-macro let (bindings &rest body) `((lambda ,(mapcar #'car bindings) ,@body) ,@(mapcar #'cadr bindings))) (def-scheme-macro let* (bindings &rest body) (if (null bindings) `(begin ,@body) `(let (,(car bindings)) (let* ,(cdr bindings) ,@body)))) (def-scheme-macro or (&rest args) (cond ((null args) 'nil) ((null (cdr args)) (car args)) (t (let ((var (gensym))) `(let ((,var ,(car args))) (if ,var ,var (or ,@(cdr args)))))))) (def-scheme-macro cond (&rest clauses) (cond ((null clauses) nil) ((null (cdr clauses)) `(or ,(car clauses) (cond ,@(cdr clauses)))) ((eq (car (car clauses)) 'else) `(begin ,@(cdr (car clauses)))) (t `(if ,(car (car clauses)) (begin ,@(cdr (car clauses))) (cond ,@(cdr clauses)))))) (def-scheme-macro case (key &rest clauses) (let ((key-val (gensym "KEY"))) `(let ((,key-val ,key)) (cond ,@(mapcar #'(lambda (clause) (if (eq (car clause) 'else) clause `((member ,key-val ',(car clause)) ,@(cdr clause)))) clauses))))) (def-scheme-macro letrec (bindings &rest body) `(let ,(mapcar #'(lambda (v) (list (car v) nil)) bindings) ,@(mapcar #'(lambda (v) `(set! ,@v)) bindings) ,@body)) (def-scheme-macro delay (computation) `(lambda () ,computation)) (def-scheme-macro define (name &rest body) (if (atom name) `(begin (set! ,name ,@body) ',name) `(define ,(car name) (lambda ,(cdr name) ,@body)))) (def-scheme-macro define (name &rest body) (if (atom name) `(name! (set! ,name . ,body) ',name) (scheme-macro-expand `(define ,(car name) (lambda ,(cdr name) . ,body))))) ) (defmacro def-scheme-macro (name parmlist &rest body) `(setf (get ',name 'scheme-macro) #'(lambda ,parmlist ,@body)))式のコンパイルは,その式を本体とした引数変数が無い lambdaフォームをコンパイルするという形で行います.
<cl> (scheme-compile '(begin "doc" (write x) y)) #S(FN :CODE ((ARGS 0) (CONST "doc") (POP) (GVAR X) (GVAR WRITE) (CALL 1) (POP) (GVAR Y) (RETURN)) :ENV NIL :NAME NIL :ARGS NIL)というように,コンパイラは 名前nameフィールドにnilの入ったfn構造体を返します. defineはこの名前フィールドに名前をいれます.