HOME Common Lisp 書き込む

3. 構文変換


3.1. はじめに

今回は構文生成用マクロについて解説します。構文生成はマクロの主要な用途であり、以下に 挙げる例は皆様の参考になると思います。

3.2. 構文生成用マクロの例

3.2.1. with-gtk

with-gtk は clisp から gtk-server を利用するためのマクロです。gtk-server は pipe, fifo, local TCP などを使って、多くのプログラム言語に GUI 環境 を提供するソフトです。with-gtk を使わないと gtk-server との接続は この様になります。gtk-server で widget を作成したら、その直後に widget のプロパティを gtk-server に送らなければなりません。そうしないと widget は 消えてしまいます。with-gtk は let のネストを作って、スペシャル変数を作ることなしに、gtk-server との接続を 実現しています。以下に例を示します。with-gtk の本体は let+fn で、 このマクロは let のネストを作るマクロです。再帰定義をしていて、 自分自身を呼び出していますが、widget の数は有限なので、有限回の繰り返しで展開が済みます。 with-gtk は let+fn に加えて、gtk-server とのコミュニケーションをする関数 gtk の定義、 gtk-server の起動と終了を行っています。
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; change *gtk-server* according to your system
(defvar *gtk-server* "C:\\bin\\gtk-server\\gtk-server.exe")
(defvar *gtk-socket* 50000)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; macro with-gtk
(defmacro let+fn (fn argvs &body body)
  (if argvs
      `(let ((,(first (car argvs)) (,fn ,@(second (car argvs)))))
	 ,@(mapcar #'(lambda (x) `(,fn ,@x))
		   (nthcdr 2 (car argvs)))
	 (let+fn ,fn ,(cdr argvs) ,@body))
    `(progn ,@body)))

(defmacro with-gtk (widgets &body body)
  (let ((socket (gensym)))
    `(let ((,socket (gtk-start *gtk-server* *gtk-socket*)))

;; gtk is defined in a closure, so that it refers socket.
;; gtk can be used like "format" function
       (defun gtk (&rest av)                 
	 (princ (apply #'format nil av) ,socket)
	 (read-line ,socket))
       
       (gtk "gtk_init(NULL, NULL)")
       (let+fn gtk ,widgets ,@body)
       (princ "gtk_exit(0)" ,socket))))


;;; Start the gtk-server, it returns socket
;; (gtk-start *gtk-server* *gtk-socket*)
(defun gtk-start (server nsocket) 
  (ext:run-program server :arguments (list (format nil "localhost:~D" nsocket)) :wait nil)
  (sleep 1) ; Wait a little so the server can initialize
  (socket:socket-connect nsocket))


;;;; Design the GUI
(with-gtk ((win ("gtk_window_new(0)")
                ("gtk_window_set_title (~A, This is a title)" win) 
                ("gtk_window_set_default_size (~A, 100, 100)" win)
                ("gtk_window_set_position (~A, 1)" win))
	   
           (table ("gtk_table_new(30, 30, 1 )")
                  ("gtk_container_add (~A,~A)" win table))
	   
           (button1 ("gtk_button_new_with_label (Exit)")
                    ("gtk_table_attach_defaults(~A,~A, 17, 28, 20, 25)" table button1))
	   
           (button2 ("gtk_button_new_with_label (Print text)")
                    ("gtk_table_attach_defaults (~A,~A, 2, 13, 20, 25)" table button2))  

           (entry  ("gtk_entry_new()") 
                   ("gtk_table_attach_defaults (~A,~A, 2, 28, 5, 15)" table entry))) 
;;;; body	  
	  (gtk "gtk_widget_show_all(~A)" win)
	  (terpri)
;;;; This is the mainloop
	  (loop
	    (gtk  "gtk_main_iteration()") ; this should be at the top of the loop
	    (if (or (< 0 (parse-integer (gtk  "gtk_server_callback(~A)" button1)))
		    (< 0 (parse-integer (gtk  "gtk_server_callback(~A)" win))))
		(return))
	    (if (< 0 (parse-integer (gtk  "gtk_server_callback(~A)"  button2)))
		(format t "This is the contents: ~A~%" (gtk  "gtk_entry_get_text(~A)" entry)))))
このプログラムを起動すると右図の様な widget が現れ、entry から入力された文字列を clisp に送ります。 TicTacToe, Eight Queens などもあります。 よろしかったら gtk-server home page をみてください。

3.2.2. with-vars-in-log

あるファイルを開いて、そのファイルに書かれている数値を変数にセットするマクロです。 numerical-mode.l で使われています。 xyzzy 用に書かれているため関数 concat が使われています。clisp 用にするには concatconcatenate 'string に書き換えてください。 使い方は ここを見てください。 logfile は読み込むファイル名、 lpandr は (vari regexpi chari) から なるリストで、vari は変数名、 regexpi は変数の値がある行の値までの正規表現、 chari は数値の後に続く文字です。 chari は省略することが出来ます。
;;; getting values from log file 
(defmacro with-vars-in-log ((logfile . lpandr) &body body)
  (with-gensyms (in line str1 me0)
    (let ((vars (mapcar #'(lambda (x) (car x)) lpandr)))
     `(let ,vars
        (with-open-file (,in (concat (default-directory) ,logfile) :direction :input)
	  (do ((,line (read-line ,in nil nil) (read-line ,in nil nil))) ((or (and ,@vars) (not ,line)))
            ,@(mapcar #'(lambda (p)
		       `(when (string-match ,(second p) ,line)
			  (let ((,me0 (match-end 0)))
			    (setq ,(car p)
				  (read-from-string
				   ,(if (cddr p)
					`(substring ,line ,me0 (position ,(third p) ,line :start (1+ ,me0)))
				      `(substring ,line ,me0)))))))
		   lpandr)))
	(or (and ,@vars) (error "some variables are not bound."))
    ,@body))))

;;; macro expansion
(pme (with-vars-in-log ("lorentz.log" (a "a += +")(b "b += +")(c "c += +")) (list a b c)))[ctrl-j]
(let (a b c)
   (with-open-file (#:G1 (concat (default-directory)
				  "lorentz.log")
		     :direction :input)
      (do ((#:G2 (read-line #:G1 nil nil)
	     (read-line #:G1 nil nil)))
	   ((or (and a b c)
		 (not #:G2)))
	 (when (string-match "a += +" #:G2)
	    (let ((#:G4 (match-end 0)))
	       (setq a (read-from-string (substring #:G2 #:G4)))))
	 (when (string-match "b += +" #:G2)
	    (let ((#:G4 (match-end 0)))
	       (setq b (read-from-string (substring #:G2 #:G4)))))
	 (when (string-match "c += +" #:G2)
	    (let ((#:G4 (match-end 0)))
	       (setq c (read-from-string (substring #:G2 #:G4)))))))
   (or (and a b c)
        (error "some variables are not bound."))
   (list a b c))

3.2.3. with-plot

これも numerical-mode.l で使われているマクロです。 pfile にプロット用コマンドを書き込み最後にそれを gnuplot にロードさせます。 使い方は ここを見てください。
;;; writing plot file and send it to gnuplot
(defmacro with-plot ((pfile) &body body)
  (with-gensyms (out)
   `(progn
      (setq *last-plot* ,pfile)
      (with-open-file (,out ,pfile :direction :output)
	,@(mapcar #'(lambda (x)
		      `(format ,out ,@x))
		  body))
      (gplot ,(format nil "load \"~A\"" pfile)))))

;;; macro expansion
(pme (with-plot ("lorentz.plt")
		("set title \"Lorentz's attractor\\n a = ~A, b = ~A, c = ~A\"~%" a b c)
		("set ticslevel 0~%")
		("set xlabel \"X\"~%")
		("set ylabel \"Y\"~%")
		("set zlabel \"Z\"~%")
		("set view 78,221~%")
		("splot \"lorentz.dat\" us 2:3:4 t \"trajectory\" w l 1~%")))[ctrl-j]
(progn (setq *last-plot* "lorentz.plt")
   (with-open-file (#:G5 "lorentz.plt" :direction :output)
      (format #:G5 "set title \"Lorentz's attractor\\n a = ~A, b = ~A, c = ~A\"~%" a b c)
      (format #:G5 "set ticslevel 0~%")
      (format #:G5 "set xlabel \"X\"~%")
      (format #:G5 "set ylabel \"Y\"~%")
      (format #:G5 "set zlabel \"Z\"~%")
      (format #:G5 "set view 78,221~%")
      (format #:G5 "splot \"lorentz.dat\" us 2:3:4 t \"trajectory\" w l 1~%"))
   (gplot "load \"lorentz.plt\""))

3.2.4. call-with-temp-file

外部コマンドを呼び出し、その入出力にテンポラリーファイルを 通して行うためのマクロです。xyzzy 用の aspell.l で使われています。
;;; calling an external command  with temporary files
(defmacro call-with-temp-files (tempfiles cmd er before after)
  (let ((val (gensym)))
    `(unwind-protect
	 (let ,(delete nil
		       (mapcar #'(lambda (x) (and x `(,x (make-temp-file-name))))
			       tempfiles))
	   ,@before
	   (unless
	       (zerop
		(call-process ,cmd
			      :input     ,(first  tempfiles)
			      :output    ,(second tempfiles)
			      :error     ,(third  tempfiles)
			      :show       :hide
			      :environ    (and (not (si:getenv "HOME"))
					       (list (cons "HOME" (user-homedir-pathname))))
			      :wait t))
	     ,er)
	   (let ((,val ,(if after `(progn ,@after))))
	     ,@(delete nil
		       (mapcar #'(lambda(x)
				   (and x `(and ,x (delete-file ,x :in-does-not-exist :skip))))
			       tempfiles))
	     ,val)))))

;;; macro expansion
(pme  (call-with-temp-files
   (fin fout nil)
   (concat *aspell-command* " " op)
   (error "cannot spawn aspell")
   ((write-region p1 p2 fin nil *encoding-euc-jp*))
   ((aspell-create-hash fout))))[ctrl-j]
(unwind-protect (let ((fin (make-temp-file-name))
                      (fout (make-temp-file-name)))
                  (write-region p1 p2 fin nil *encoding-euc-jp*)
                  (unless (zerop (call-process (concat *aspell-command* " " op)
                                                :input fin
                                                :output fout
                                                :error nil
                                                :show :hide
                                                :environ (and (not (system:getenv "HOME"))
                                                              (list (cons "HOME" (user-homedir-pathname))))
                                                :wait t))
                  (error "cannot spawn aspell"))
                  (let ((#:G6 (progn (aspell-create-hash fout))))
                     (and fin (delete-file fin :in-does-not-exist :skip))
                     (and fout (delete-file fout :in-does-not-exist :skip))
                       #:G6)))

3.3. 終わりに

今回紫藤が作成したマクロを用いて構文変換について解説しました。 次回は setf に関わるマクロについて解説します。

不明な点、不正確な点などがありましたら紫藤まで お知らせいただけたら幸いです。(shido_takafumi@ybb.ne.jp)