next up previous
Next: 4 任意個数の引数指定機構の実現 Up: 3 マクロ機能の追加 Previous: 3.3 マクロの定義

3.4 マクロ定義用手続き

マクロの定義は,上のようにsetfで属性リストに 代入するという形式になりますから,これらを 行なう手続きを定義しておきます.

(defmacro def-scheme-macro (name parmlist &rest body)
  `(setf (get ',name 'scheme-macro)
         #'(lambda ,parmlist ,@body)))
というdef-scheme-macroを定義すると, andは,

(def-scheme-macro and (&rest args)
  (cond ((null args) 'T)
        (t `(if ,(first args)
                (and ,@(rest args))))))
となります. どのような形にマクロ展開されるかを見てみると,

<cl> (pprint (macroexpand
  '(def-scheme-macro and (&rest args)
   (cond ((null args) 'T)
         (t `(if ,(first args)
                (and ,@(rest args))))))))
(putprop
   'and
   (function
      (lambda (&rest args)
         (cond
            ((null args) 't)
            (t
             (cons
                'if
                (cons
                   (first args)
                   (list
                    (cons 'and
                      (append (rest args) nil)))))))))
   'scheme-macro)
となっています. 前節ではsetfしていましたが,setfもマクロでここにあるputprop に展開されています. letの定義もマクロで以下のようにできます.

(def-scheme-macro let (bindings &rest body)
  `((lambda ,(mapcar #'first bindings) ,@body)
    ,@(mapcar #'second bindings)))
展開してみると,

<cl> (pprint (macroexpand
 '(def-scheme-macro let (bindings &rest body)
  `((lambda ,(mapcar #'first bindings) ,@body)
    ,@(mapcar #'second bindings)))))

(putprop
   'let
   (function
      (lambda (bindings &rest body)
         (cons
            (cons
               'lambda
               (cons (mapcar #'first bindings)
                     (append body nil)))
            (append (mapcar #'second bindings) nil))))
   'scheme-macro)
defineは以下のようになります.

(def-scheme-macro define (name &rest body)
  (if (atom name)
      `(begin (set! ,name  ,@body) ',name)
    `(define ,(first name) 
       (lambda ,(rest name) ,@body))))
この他のマクロとしていかのようなものを定義して おきます.

(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))
condではそれ以外という意味を表すために elseという表記が使われます. delayというのは,遅延評価を行なうものです.letrecはletに似ていますが, 再帰関数をも定義できるものです.CommonLispのlabelsのような働きをします.

(letrec ((f1 (lambda (...) ... (f2 ...)))
         (f2 (lambda (...) ... (f1 ...)))
        )
  body-expr)
f1の定義に,f2が必要で,f2の定義にf1が必要な場合に このletrecが必要です. Common Lispのlabelsというのは,以下のようにローカルな関数を使う関数を 定義するためのもので,

(defun fact (n)
  (labels
   ((tail-recursive-fact
     (counter accumulator)
     (if (> counter n)
          accumulator
       (tail-recursive-fact
        (+ counter 1)
        (* counter accumulator)))))
   (tail-recursive-fact 1 1)))
というように使います. Schemeにおいては,letrecを用いて,

==> (define (fact2 n)
  (letrec
      ((tail-recursive-fact
        (lambda (counter accumulator)
          (if (> counter n)
              accumulator
             (tail-recursive-fact
               (+ counter 1)
               (* counter accumulator))))))
    (tail-recursive-fact 1 1)))
fact2
==> (fact2 7)
5040
というようにできます. scheme-macro-expandを用いて展開を行ってみると,

<cl> (scheme-macro-expand '(and p q))
(IF P (AND Q))
<cl> (scheme-macro-expand '(and q))
Q
<cl> (scheme-macro-expand '(let ((x 1) (y 2)) (+ x y)))
((LAMBDA (X Y) (+ X Y)) 1 2)
<cl> (scheme-macro-expand
     '(letrec
       ((even?
          (lambda (x) (or (= x 0)
                          (odd? (- x 1)))))
        (odd?
          (lambda (x) (not (even? x)))))
        (even? z)))
((LAMBDA (EVEN? ODD?)
   (SET! EVEN? (LAMBDA (X) (OR (= X 0)
                               (ODD? (- X 1)))))
   (SET! ODD? (LAMBDA (X) (NOT (EVEN? X))))
   (EVEN? Z))
 NIL NIL)
<cl> (scheme-macro-expand
    '(define (reverse l)
	(if (null? l) nil
	  (append (reverse (cdr l))
                  (list (car l)))))))

(BEGIN
 (SET! REVERSE
  (LAMBDA (L)
    (IF (NULL? L) NIL
          (APPEND (REVERSE (CDR L))
                  (LIST (CAR L))))))
 'REVERSE)
というぐあいになります.

<cl> (scheme)
==> (define (reverse l)
	(if (null? l) nil
	  (append (reverse (cdr l)) (list (car l)))))

REVERSE 
==> (reverse '(a b c d))

(D C B A) 
==> (let* ((x 5) (y (+ x x)))
      (if (or (= x 0) (and (< 0 y) (< y 20)))
	  (list x y)
	(+ y x)))

(5 10) 
==> (letrec
       ((even?
          (lambda (x) (or (= x 0)
                          (odd? (- x 1)))))
        (odd?
          (lambda (x) (not (even? x)))))
        (even? 4))

T 
==> (letrec
       ((even?
          (lambda (x) (or (= x 0)
                          (odd? (- x 1)))))
        (odd?
          (lambda (x) (not (even? x)))))
        (even? 9))

NIL


generated through LaTeX2HTML. M.Inaba 平成18年5月6日