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")
;=> ファイルがコピーされる。

Paul Graham氏のユーティリティ その11

| 16:18 | Paul Graham氏のユーティリティ その11 - わだばLisperになる を含むブックマーク はてなブックマーク - Paul Graham氏のユーティリティ その11 - わだばLisperになる

PG氏のユーティリティを読んでみることの11回目。

文字列操作系のユーティリティ編です。

Lisp utilities that were not included in On Lisp or ANSI Common Lisp

お題

white?

暗記で再現

(defun white? (c)
  (in c #\Space #\Tab #\Newline #\Return))

できた。文字が空白文字かを判定する。

;; 動作
(with-input-from-string (str "foo bar	baz
quux")
  (do-chars c str
    (princ (if (white? c) "△" c))))
;->foo△bar△baz△quux

お題

constituent

暗記で再現

(defun constituent (c)
  (and (graphic-char-p c)
       (not (char= #\Space c))))

できた。制御文字か空白の場合NIL、普通の文字の文字の場合Tを返すものの様子。

(char= #\ #\Space)のようなので、判別しやすいように#\Spaceと書いてみた。。

;; 動作
(with-input-from-string (str "foo bar^Sbaz^Vquux^F日本語")
 (do-chars c str
   (princ (if (constituent c) c "△"))))
;->foo△bar△baz△quux△日本語

お題

linebreak-pos

暗記で再現

(defun linebreak-pos (string &optional (start 0))
  (or (position #\Newline string :start start)
      (let ((n (position #\Return string :start start)))
	(when n
	  (if (and (not (= n (1- (length string))))
		   (eql (char string (1+ n)) #\Newline))
	      (1+ n)
	      n)))))

できた。改行文字の位置を返すものの様子。LF、CR、CR+LFの3つの場合に対応。次の行の先頭の一つ前の位置を返す。

;; 動作
(let ((s "foo【CR】【LF】
bar"))
  (linebreak-pos s))
;=> 4

(let ((s "foo【LF】
bar"))
  (linebreak-pos s))
;=> 3

お題

blank-line

暗記で再現:失敗

;; 間違い
(defun blank-line (string &optional (start 0))
  (let ((n (linebreak-pos string start)))
    (if (= n (1- (length string)))
	(let ((n2 (linebreak-pos string (1+ n))))
	  (if (find-if-not #'white? string :start n :end n2)
	      (blank-line string n2)
	      nil))
	nil)))

;; 正解
(defun blank-line (string &optional (start 0))
  (let ((n (linebreak-pos string start)))
    (if (and n (not (= n (1- (length string)))))
        (let ((n2 (linebreak-pos string (1+ n))))
          (if n2
              (if (find-if-not #'white? string :start n :end n2)
                  (blank-line string n2)
                  n2)
              nil))
        nil)))

動作を理解していなかったため大分間違えた。空行を見つけ出して、その先頭のポジションを返すというものらしい。

;; 動作
(blank-line "foobar

")
;=> 7

お題

nonwhite-substring

暗記で再現

(defun nonwhite-substring (string start end)
  (if (find-if-not #'white? string :start start :end end)
      (progn
	(while (white? (char string start))
	  (incf start))
	(while (white? (char string (1- end)))
	  (decf end))
	(subseq string start end))
      ""))

できた。指定した範囲をsubseqで切り出すが、周囲の空白文字は除外するというものらしい。

;; 動作
(let ((str "  f o o "))
  (nonwhite-substring str 0 (length str)))
=>"f o o"

お題

extruct-paragraphs

暗記で再現:失敗

;; 間違い
(defun extruct-paragraphs (string &optional (pos 0))
  (if (= pos (length string))
      nil
      (let ((n (linebreak-pos string pos)))
	(if n
	    (cons (nonwhite-substring string pos n)
		  (extruct-paragraphs string (1+ n)))
	    (list (nonwhite-substring string pos (length string)))))))

;; 正解
(defun extruct-paragraphs (string &optional (pos 0))
  (if (= pos (length string))
      nil
      (let ((n (blank-line string pos)))
	(if n
	    (cons (nonwhite-substring string pos n)
		  (extruct-paragraphs string (1+ n)))
	    (if (find-if-not #'white? string :start pos)
		(list (nonwhite-substring string pos (length string)))
		nil)))))

これもコードから動作が思い描けず大分間違えた。文字列から段落を抜き出して、その要素をリストにして返すというものらしい。段落の区切りは空白行になっている。

;; 動作
(print (extruct-paragraphs 
 "NILが空リストだっていいじゃないか。

          Common Lispだもの。

               みつを"
))
;=> ("NILが空リストでもいいじゃないか。" "Common Lispだもの。" "みつを")