LOL defmacro!

LET OVER LAMBDA Edition 1.0 の defmacro! を scheme（Gauche）で書きました。

• vallog: LOL defmacro!

基本的に同じものですが、実験的に g! や o! を変更できるようにしています。
Un-Common Lisp の defmacro* がプレフィックスに g!, o! をつけるのでなく、サフィックスに #, % を付けるスタイルなのを見て、切り替えられるようにしてみても良いかなぁと。切り替え方が不細工ですが、まぁお試しということで。

• 生まれて3日目のUn-Common Lisp - 八発白中

使用例はこんな感じ。

	(use liv.lol.defmacro)
	(use srfi-27)
	;; g!expr, o!expr
	(defmacro! nif (o!expr pos zero neg)
	`(cond ((positive? ,g!expr) ,pos)
	((zero? ,g!expr) ,zero)
	(else ,neg)))
	(macroexpand '(defmacro! nif (o!expr pos zero neg)
	`(cond ((positive? ,g!expr) ,pos)
	((zero? ,g!expr) ,zero)
	(else ,neg))))
	;; (define-macro (nif o!expr pos zero neg)
	;; (let ((g!expr (gensym "expr")))
	;; `(let ,(map list (list g!expr) (list o!expr))
	;; ,(begin `(cond ((positive? ,g!expr) ,pos)
	;; ((zero? ,g!expr) ,zero) (else ,neg))))))
	(macroexpand '(nif (- (random-integer 10)(random-integer 10)) 'pos 'zero 'neg))
	;; (let ((#0=#:expr39 (- (random-integer 10) (random-integer 10))))
	;; (cond ((positive? #0#) 'pos)
	;; ((zero? #0#) 'zero)
	;; (else 'neg)))
	(*g!-symbol* '%)
	(*o!-symbol* '$)
	(*defmacro!-symbol-position* 'sufix)
	(apply-defmacro!-config!)
	;; expr%, expr$
	(macroexpand '(defmacro! nif (expr$ pos zero neg)
	`(cond ((positive? ,expr%) ,pos)
	((zero? ,expr%) ,zero)
	(else ,neg))))
	;; (define-macro (nif expr$ pos zero neg)
	;; (let ((expr% (gensym "expr")))
	;; `(let ,(map list (list expr%) (list expr$))
	;; ,(begin `(cond ((positive? ,expr%) ,pos)
	;; ((zero? ,expr%) ,zero)
	;; (else ,neg))))))
	(apply-defmacro!-config! 'g! 'o! 'prefix)
	(defmacro! nif (o!expr pos zero neg)
	`(cond ((positive? ,g!expr) ,pos)
	((zero? ,g!expr) ,zero)
	(else ,neg)))
	(macroexpand '(defmacro! nif (o!expr pos zero neg)
	`(cond ((positive? ,g!expr) ,pos)
	((zero? ,g!expr) ,zero)
	(else ,neg))))
	;; (define-macro (nif o!expr pos zero neg)
	;; (let ((g!expr (gensym "expr")))
	;; `(let ,(map list (list g!expr) (list o!expr))
	;; ,(begin `(cond ((positive? ,g!expr) ,pos)
	;; ((zero? ,g!expr) ,zero)
	;; (else ,neg))))))

view raw example.scm hosted with ❤ by GitHub

以下 defmacro! のコード。

	(define-module liv.lol.defmacro
	(use srfi-1)
	(use srfi-13)
	(use liv.cl)
	(use liv.onlisp.utils)
	(use gauche.parameter)
	(export *g!-symbol* *o!-symbol* *defmacro!-symbol-position*
	apply-defmacro!-config! defmacro defmacro/g! defmacro!))
	(select-module liv.lol.defmacro)
	(define *g!-symbol* (make-parameter 'g!))
	(define *o!-symbol* (make-parameter 'o!))
	(define *defmacro!-symbol-position* (make-parameter 'prefix))
	(define %string-append string-append)
	(define %mark-position string-prefix?)
	(define %string-drop string-drop)
	(define apply-defmacro!-config!
	(case-lambda
	((g! o! pos)
	(*g!-symbol* g!)
	(*o!-symbol* o!)
	(*defmacro!-symbol-position* pos)
	(apply-defmacro!-config!))
	(()
	(case (*defmacro!-symbol-position*)
	((prefix)
	(set! %string-append string-append)
	(set! %mark-position string-prefix?)
	(set! %string-drop string-drop))
	((sufix)
	(set! %string-append (lambda (s1 s2)
	(string-append s2 s1)))
	(set! %mark-position string-suffix?)
	(set! %string-drop string-drop-right))))))
	(define (mark-symbol? sym mark pred)
	(pred (symbol->string mark)(symbol->string sym)))
	(define (g!-symbol? sym)
	(mark-symbol? sym (*g!-symbol*) %mark-position))
	(define (o!-symbol? sym)
	(mark-symbol? sym (*o!-symbol*) %mark-position))
	(define (remove-mark sym)
	(%string-drop (symbol->string sym)
	(string-length (symbol->string (*o!-symbol*)))))
	(define (o!-symbol->g!-symbol sym)
	(string->symbol
	(%string-append (symbol->string (*g!-symbol*))
	(remove-mark sym))))
	(define-macro (defmacro/g! name args . body)
	(let1 syms (cl:remove-duplicates (filter g!-symbol? (flatten body)))
	`(define-macro (,name ,@args)
	(let ,(map (lambda (s)
	`(,s (gensym ,(remove-mark s)))) syms)
	,@body))))
	(define-macro (defmacro! name args . body)
	(let* ((os (filter o!-symbol? args))
	(gs (map o!-symbol->g!-symbol os)))
	`(defmacro/g! ,name ,args
	`(let ,(map list (list ,@gs)(list ,@os))
	,(begin ,@body)))))
	(define-syntax defmacro
	(syntax-rules ()
	((_ name (arg ...) body ...)
	(define-macro (name arg ...) body ...))))
	(provide "liv/lol/defmacro")

view raw defmacro!.scm hosted with ❤ by GitHub

追記

defmacro! に可変長引数が受け取れないバグがありました。修正しました。

• vallog: 先日書いた defmacro! がバグっていたので