Hatena::Groupcadr

わだばLisperになる このページをアンテナに追加 RSSフィード

2004 | 12 |
2005 | 01 | 02 | 07 | 10 | 11 |
2006 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2007 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2008 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2009 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2010 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2011 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 11 |

2007-10-24

Maclispの入出力ユーティリティを再現してみる

| 18:54 | Maclispの入出力ユーティリティを再現してみる - わだばLisperになる を含むブックマーク はてなブックマーク - Maclispの入出力ユーティリティを再現してみる - わだばLisperになる

MaclispのLispで書かれたシステムソースを漁っていて面白そうな機構があったので再現して遊んでみました。

ファイル名は、IOTA.LSPで、恐らく1980年付近のコードで、オリジナルはKent Pitman氏の作のようです。

このIOTA.LSPの中で、IOTAとPHIという、いわば入出力系のletの様な構文が定義されています。

;IOTA 
(IOTA ((<var1> <filename1> <filemodes1>)
       (<var2> <filename2> <filemodes2>) ...)
      <body>)

; 使用例
(DEFUN FILECOPY (FROM TO)
   (IOTA ((FOO FROM 'IN)
          (BAR TO 'OUT))
         (DO ((C (TYI FOO -1) (TYI FOO -1)))
             ((MINUSP C))
            (TYO C BAR))))
; PHI 
(PHI ((<var1> <form1>)
      (<var2> <form2>) ...)
     <body>)

; 使用例
(DEFUN DUMP-DATA (FROM TO)
   (PHI ((FOO (MY-SFA-MAKER FROM 'INPUT))
         (BAR (MY-SFA-MAKER TO 'OUTPUT)))
        (DO ((C (TYI FOO -1) (TYI FOO -1)))
            ((MINUSP C))
          (TYO C BAR))))

まず名前ですが、IOなので、IOTA、file => PHIleということで、PHI、他にPIってのもあります。

IOTAはAPL由来のSRFIのiotaとは全く動作が違っていて、letとopenが足されたようなものに、closeで後始末をするもの、phiは、IOTAと殆ど同じですがストリームを変数に束縛する方法までは備え付けでないもの、といった感じです。

ということで、sbclのwith-open-file等のmacroexpandの出力を参考に適当にがちゃがちゃ作ってみました。

(defmacro iota ((&rest stream-binds) &body body)
  (with-gensyms (abortp)
    `(let (,@(mapcar (lambda (x)
		       `(,(car x) (open ,(cadr x) ,@(cddr x))))
		     stream-binds)
	   (,abortp t))
       (unwind-protect
	    (multiple-value-prog1
		(progn ,@body)
	      (setq ,abortp nil))
	 (progn
	   ,@(mapcar (lambda (x) `(when ,(car x) (close ,(car x) :abort ,abortp)))
		     stream-binds))))))

(defmacro phi ((&rest stream-binds) &body body)
  (with-gensyms (abortp)
    `(let (,@stream-binds (,abortp t))
       (unwind-protect
	    (multiple-value-prog1
		(progn ,@body)
	      (setq ,abortp nil))
	 (progn
	   ,@(mapcar (lambda (x) `(when ,(car x) (close ,(car x) :abort ,abortp)))
		     stream-binds))))))

(defmacro make-input-stream (path &rest keys)
  `(open ,path :direction :input ,@keys))

(defmacro make-output-stream (path &rest keys)
  `(open ,path :direction :output ,@keys))

make-input-streamとmake-output-streamは別になくても良いと思いますが何となく…。

;使用例
(DEFUN FILECOPY (FROM TO)
  (IOTA ((FOO FROM :direction :input 
	           :element-type 'unsigned-byte)
	 (BAR TO :direction :output 
	         :if-exists :supersede
		 :element-type 'unsigned-byte))
    (DO ((C (read-byte FOO nil -1) (read-byte FOO nil -1)))
	((MINUSP C))
      (write-byte c BAR))))

(filecopy "/tmp/foo.jpg" "/tmp/quux.jpg")
;=> ファイルがコピーされる。

(DEFUN DUMP-DATA (FROM TO)
  (PHI ((FOO (make-input-stream from :element-type 'unsigned-byte))
	(BAR (make-output-stream to :element-type 'unsigned-byte
				    :if-exists :supersede
				    :if-does-not-exist :create)))
    (DO ((C (read-byte foo nil -1) (read-byte foo nil -1)))
	((MINUSP C))
      (write-byte c BAR))))

(dump-data "/tmp/abc.jpg" "/tmp/123.jpg")
;=> ファイルがコピーされる。