山下 諒蔵
capyb****@df7*****
2004年 4月 4日 (日) 21:05:36 JST
丁寧な返事をいただきありがとうございます。
Schemeのマクロは強力すぎて良く分かっていないんですが、
やっぱり難しいですね。
投稿した後になって Oleg Kiselyovさんのページで、
symbol?? と id-memv?? というマクロを見つけたので、
むりやりR5RSの範囲内に埋め込んでみたんですが、
ちゃんとできているかどうかちょっと自信がありません。
もしよろしければ、試していただけると幸いです。
追伸）reverse にリスト以外のものを渡してもエラーにならなかったんですが
バグでしょうか？（仕様でしたら申し訳ありません）
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;
;;; Oleg Kiselyovさんのマクロです
(define-syntax symbol??
(syntax-rules ()
((symbol?? (x . y) kt kf) kf) ; It's a pair, not a symbol
((symbol?? #(x ...) kt kf) kf) ; It's a vector, not a
symbol
((symbol?? maybe-symbol kt kf)
(let-syntax
((test
(syntax-rules ()
((test maybe-symbol t f) t)
((test x t f) f))))
(test abracadabra kt kf)))))
(define-syntax id-memv??
(syntax-rules ()
((id-memv?? form (id ...) kt kf)
(let-syntax
((test
(syntax-rules (id ...)
((test id _kt _kf) _kt) ...
((test otherwise _kt _kf) _kf))))
(test form kt kf)))))
(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)))))
(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))))))))))
;; 本体
(let ((binds (smatch-help pat sexp '() values)))
(and binds (reverse binds)))
)
)
(define-syntax smatch-lambda
(syntax-rules (quote)
((_ (?pattern ?exp ...) ?clause ...)
(lambda args
(smatch-lambda "args" args (?pattern ?exp ...) ?clause ...)))
((_ "args" ?args ("pattern" ?pattern "formal" ?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 "pattern-vars" "args" ?args (?pattern ?body1 ?body2
...) ?clause ...))
((_ "args" ?args)
(error "Wrong arguments to SMATCH-LAMBDA" ?args))
;; pattern-vars
((_ "pattern-vars" "args" ?args "remove-duplicate" () ?formals
(?pattern . ?bodies) . ?clauses)
(smatch-lambda "args" ?args
("pattern" ?pattern "formal" ?formals . ?bodies)
. ?clauses)
)
((_ "pattern-vars" "args" ?args "remove-duplicate" (?var1 ?var2
...) (?formal ...) ?clause . ?clauses) ;=>
(id-memv?? ?var1 (?formal ...)
(smatch-lambda "pattern-vars" "args" ?args "remove-duplicate" (?var2
...) (?formal ...) ?clause . ?clauses)
(smatch-lambda "pattern-vars" "args" ?args "remove-duplicate" (?var2
...) (?formal ... ?var1) ?clause . ?clauses))
)
((_ "pattern-vars" "args" ?args (?pattern . ?bodies) . ?clauses)
;begin =>
(smatch-lambda "pattern-vars" "args" ?args "pattern" (?pattern)
"var" () (?pattern . ?bodies) . ?clauses)
)
((_ "pattern-vars" "args" ?args "pattern" () "var" (?var ...)
?clause . ?clauses) ;end =>
(smatch-lambda "pattern-vars" "args" ?args "remove-duplicate"
(?var ...) () ?clause . ?clauses)
)
((_ "pattern-vars" "args" ?args "pattern" ((quote . ?pattern1)
?pattern2 ...) "var" (?var ...) ?clause . ?clauses) ;quoted =>
(smatch-lambda "pattern-vars" "args" ?args "pattern" (?pattern2
...) "var" (?var ...) ?clause . ?clauses)
)
((_ "pattern-vars" "args" ?args "pattern" ((?pattern1 . ?pattern2)
. ?patterns) "var" (?var ...) ?clause . ?clauses) ;pair =>
(smatch-lambda "pattern-vars" "args" ?args "pattern" (?pattern1
?pattern2 . ?patterns) "var" (?var ...) ?clause . ?clauses)
)
((_ "pattern-vars" "args" ?args "pattern" (#(?pattern1)
?other-pattern ...) "var" (?var ...) ?clause . ?clauses) ;vector =>
(smatch-lambda "pattern-vars" "args" ?args "pattern" (?pattern1
?other-pattern ...) "var" (?var ...) ?clause . ?clauses)
)
((_ "pattern-vars" "args" ?args "pattern" (#(?pattern1 ?pattern2
...) ?other-pattern ...) "var" (?var ...) ?clause . ?clauses) ;vector =>
(smatch-lambda "pattern-vars" "args" ?args "pattern" (?pattern1
#(?pattern2 ...) ?other-pattern ...) "var" (?var ...) ?clause .
?clauses)
)
((_ "pattern-vars" "args" ?args "pattern" (?pattern1 ?pattern2 ...)
"var" (?var ...) ?clause . ?clauses) ;else =>
(symbol?? ?pattern1
(smatch-lambda "pattern-vars" "args" ?args "pattern" (?pattern2
...) "var" (?var ... ?pattern1) ?clause . ?clauses)
(smatch-lambda "pattern-vars" "args" ?args "pattern" (?pattern2
...) "var" (?var ...) ?clause . ?clauses))
)
)
)