root/lang/scheme/3imp/macro.scm @ 31145

Revision 31145, 1.8 kB (checked in by mokehehe, 5 years ago)

ソース圧縮
whenマクロ追加
elseのないifを許容

Line 
1;;;; macro
2
3(define *macro-table* (make-hash-table))
4
5(define (add-macro name f)
6  (hash-table-put! *macro-table* name f))
7
8(define-macro (define-special-form name . f)
9  (if (pair? name)
10      `(define-special-form ,(car name) (lambda (%sp% ,@(cdr name)) ,@f))
11    `(add-macro ',name ,(car f))))
12
13(define-macro (define-builtin-macro name . f)
14  (if (pair? name)
15      `(define-builtin-macro ,(car name) (lambda ,(cdr name) ,@f))
16    `(add-macro ',name ,(evaluate (car f)))))
17
18(define (macro? name)
19  (and (hash-table-exists? *macro-table* name)
20       (hash-table-get *macro-table* name)))
21
22(define (all f . args)
23  (let loop ((args args))
24    (if (any null? args)
25        #t
26      (and (apply f (map car args))
27           (loop (map cdr args))))))
28
29(define (comp-macroexpand-1-from-stack x s)
30  (if (pair? x)
31      (let1 name (car x)
32        (let ((trns
33               (cond ((macro? name) => (lambda (c)
34                                         (if (primitive-function? c)
35                                             (apply c s (cdr x))
36                                           (vm-apply s c (cdr x)))))
37                     (else (map (lambda (y)
38                                  (comp-macroexpand-1-from-stack y s))
39                                x)))))
40          (if (and (pair? trns)
41;                   (equal? x trns)  ; all �������ƁA�ǂ��炩���Z���ꍇ�ɐ���Ă��܂� (all eq? '(1 2) '(1 2 3)) => #t
42                   (all eq? x trns))
43              x
44            trns)))
45    x))
46
47(define (comp-macroexpand-from-stack x s)
48  (let1 t (comp-macroexpand-1-from-stack x s)
49    (if (eq? t x)
50        x
51      (comp-macroexpand-from-stack t s))))
52
53(define (comp-macroexpand-1 x)
54  (comp-macroexpand-1-from-stack x 0))
55
56(define (comp-macroexpand x)
57  (comp-macroexpand-from-stack x 0))
Note: See TracBrowser for help on using the browser.