山下 諒蔵
capyb****@df7*****
2004年 4月 3日 (土) 12:45:09 JST
はじめまして。山下と申します。
ずいぶん長いメールになってしまったのですが、お許し下さい。
関数をこんな感じで定義するためのマクロを作ってみたのですが
(define my-append
(smatch-lambda
(( '() ys) ys)
(( (x . xs) ys) (cons x (my-append xs ys)))))
define-macroとdefine-syntaxが絡み合ってしまって
気持ちが悪いので、全て標準のマクロに直せないかと思い
投稿させていただきました。
まだあまり慣れていないので、見苦しい点がたくさんあると思いますが
どうかよろしくお願いします。
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;
;; シンボルquote で囲まれているようなリスト (quote 何か) であるとき真を返します
(define quoted? (lambda (obj) (and (list? obj) (not (null? obj)) (eq?
(car obj) 'quote))))
;; クオートを取り除く、という意味のつもりです
(define dequote cadr)
(define pattern-var? symbol?)
;; ペアやベクターのように内側に入ってバインドを探しにいくようなオブジェクトなら真を返します
(define pattern-container? (lambda (pat) (and (not (quoted? pat)) (or
(pair? pat) (vector? pat)))))
;;; 例
;(smatch '(a b a) ;長さが３で、第一要素と第三要素が等しいリストにマッチ
; '((c d) 2 (c d))) => ((a (c d)) (b 2))
;(smatch '(1 b 'c) ;長さが３で、第一要素が１、第三要素がシンボルcであるリストにマッチ
; '(1 2 c)) => ((b 2))
;(smatch '(1 a)
; '(1)) => #f
;(smatch '(a (a b)) ;長さが２で、第二要素が 長さが2でcar部が第一要素に等しいリスト、であるリストにマッチ
; '(1 (1 2))) => ((a 1) (b 2))
;(smatch '(a #(b c '(2)) d) ;長さが３で、第二要素が
長さが３で第三要素が'(2)であるベクター、であるリストにマッチ
; '(1 #(2 3 (2)) 4)) => ((a 1) (b 2) (c 3) (d 4))
;(smatch '("ab" b '#(a b c)) ;長さが３で、第一要素が"ab" 第三要素がシンボルa, b,
cからなるベクター、であるリストにマッチ
; '("ab" 2 #(a b c))) => ((b 2))
;(smatch 'args ;何にでもマッチ
; '(a b c)) => ((args (a b c)))
;(smatch '(a . b) ;長さが１以上のリストにマッチ
; '(1 2 3)) => ((a 1) (b (2 3)))
;(smatch '() ;空リストにマッチ
; '()) => ()
(define smatch
(lambda (pat sexp)
;; 内部定義
(define smatch-help
(lambda (pat sexp binds next-match-func)
(cond
((quoted? pat)
(and (equal? (dequote pat) sexp)
(next-match-func binds)))
((pattern-var? pat)
(let ((bind (assq pat binds)))
(if bind
(and (equal? (cadr bind) sexp) (next-match-func binds))
(next-match-func (cons (list pat sexp) binds)))))
((pattern-container? pat)
(let ((more-binds (container-match-help pat sexp binds)))
(and more-binds (next-match-func more-binds))))
(else
(and (equal? pat sexp)
(next-match-func binds))))))
(define container-match-help
(lambda (pat cont binds)
(cond
((pair? pat) (pair-match-help pat cont binds))
((vector? pat) (vector-match-help pat cont binds 0)))))
(define pair-match-help
(lambda (pat pair binds)
(and (pair? pat) (pair? pair)
(let ((x (car pat))
(y (car pair)))
(smatch-help x y binds (lambda (binds) (smatch-help (cdr pat)
(cdr pair) binds values)))))))
(define vector-match-help
(lambda (pat vect binds i)
(and (vector? pat) (vector? vect)
(cond
((and (= (vector-length pat) i) (= (vector-length vect) i))
binds)
((or (= (vector-length pat) i) (= (vector-length vect) i)) #f)
(else
(let ((x (vector-ref pat i))
(y (vector-ref vect i)))
(smatch-help x y binds (lambda (binds) (vector-match-help pat vect
binds (+ i 1))))))))))
;; 本体
(reverse (smatch-help pat sexp '() values))))
(define pattern-for-each
(lambda (proc pat)
;; 内部定義
(define (undef) (if #f #f))
(define pattern-for-each-help
(lambda (proc pat)
(if (pattern-container? pat)
(container-for-each (lambda (pat) (pattern-for-each-help proc
pat)) pat)
(proc pat))))
(define container-for-each
(lambda (proc cont)
(cond
((list? cont) (for-each proc cont))
((pair? cont) (pair-for-each proc cont))
((vector? cont) (vector-for-each proc cont)))))
(define pair-for-each
(lambda (proc pair)
(proc (car pair))
(proc (cdr pair))
(undef)))
(define vector-for-each
(lambda (proc vect)
(let loop ((i 0))
(if (not (= (vector-length vect) i))
(begin
(proc (vector-ref vect i))
(loop proc vect (+ i 1)))))))
;; 本体
(pattern-for-each-help proc pat)
(undef)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; macro
(define-syntax smatch-lambda
(syntax-rules ()
((_ (?pattern ?exp ...) ?clause ...)
(lambda args
(smatch-lambda "args" args (?pattern ?exp ...) ?clause ...)))
((_ "args" ?args ("pattern" ?pattern "formals" ?formals ?body1
?body2 ...) ?clause ...)
(let ((binds (smatch '?pattern ?args)))
(if binds
(apply (lambda ?formals ?body1 ?body2 ...)
(map cadr binds))
(smatch-lambda "args" ?args ?clause ...))))
((_ "args" ?args (?pattern ?body1 ?body2 ...) ?clause ...)
(%smatch-lambda-help ?args (?pattern ?body1 ?body2 ...) ?clause
...))
((_ "args" ?args)
(error "Wrong arguments to SMATCH-LAMBDA" ?args))))
(define-macro %smatch-lambda-help
(lambda (?args ?clause . ?clauses)
;;; 内部定義
;; パターンの中から変数（クオートされてないシンボル）を重複なく取り出す関数です
(define pattern-vars
(lambda (pat)
(let ((adjoin (lambda (lst obj)
(if (member obj lst) lst (cons obj lst))))
(result '()))
(pattern-for-each
(lambda (pat) (if (pattern-var? pat) (set! result (adjoin result
pat))))
pat)
(reverse result))))
;;; 本体
(let* ((?pattern (car ?clause))
(?bodies (cdr ?clause))
(?formals (pattern-vars ?pattern)))
`(smatch-lambda "args" ,?args
("pattern" ,?pattern "formals" ,?formals ,@?bodies)
,@?clauses))))