Clojure始めました

土曜日(3/20)にShibuya.lisp#5に参加した。残念ながら予定があったので懇親会は不参加。

毎度のことながらTT、LTの発表は濃かったりおもしろかったりで素晴らしかったですが、どうも今回はClojure祭り状態のようで、Lisperを目指しているくせに1度も触ったことのない私は精神的ダメージを負うことになったのでした。

会場にオーム社の方々(らしい)が来ており、商魂たくましく(?)会場で書籍の販売を行っている中に狙いすましたかのように「プログラミングClojure」が置いてあったのでついうっかり購入してしまった。

ということで、書籍を読みつつLispの最先端たるClojureを書いてみようと思う。

Emacs使いたるもの、設定をせずにプログラミングを始めるというのはおそらくありえないので、 clojure-modeとswank-clojureの導入を行おうとした。

clojure-contribのコンパイルに、書籍の内容と異なり antではなくmavenというツールを使ったり、各所の解説でrequireしている swank-clojure-autoload.elなんてファイルが存在しなかったりしてだいぶ時間がかかった。

swank-clojure-autoloadの内容をググって調べ、slime-lisp-implementationsの設定にそれっぽい記述をすることで一応動くようになった。

(setq slime-lisp-implementations
      `((sbcl
	 ("/usr/local/bin/sbcl"
	  "--core" "/home/kurohuku/emacslib/sbcl.core-with-swank")
	 :init (lambda (port-file _)
		 (format "(progn
(load \"/home/kurohuku/emacslib/util.lisp\")
(setf swank::*coding-system* \"utf-8-unix\")
(swank:start-server %S))\n" port-file))
	 :coding-system utf-8-unix)
(clojure
 ,(swank-clojure-cmd)
 :init swank-clojure-init)
))

ググってたらClojureでクラスパスを表示する方法を見つけた。便利そうなのでメモっておく。

(println
 (seq
   (.getURLs (java.lang.ClassLoader/getSystemClassLoader))))

regexp->list->nfa

正規表現を文字列で考えていて頭がいたくなってきたので、一旦リストにしてからNFAにするようにしてみる。

;;regexp->list
(defun regexp->list (reg)
  (let* ((top nil)
	 (stack (list top)))
    (loop :for ch across reg
       :do
       (case ch
	 ((#\()
	  (push top stack)
	  (setf top nil))
	 ((#\))
	  (let ((prev (pop stack)))
	    (push top prev)
	    (setf top prev)))
	 ((#\|)
	   (setf top
		 (list top :or)))
	 ((#\*)
	  (let ((tmp (list (pop top) :loop)))
	    (push tmp top)))
	 ((#\.)
	  (push :all top))
	 (T
	  (push ch top)))
       :finally (return-from regexp->list
       (reverse-tree top)))))

(defun reverse-tree (tree)
  (if (listp tree)
      (reverse (mapcar #'reverse-tree tree))
      tree))

(defun list->nfa (lst)
  (reduce
   #'merge-nfa-concat
   (remove
    nil
    (mapcar
    #'(lambda (obj)
	(typecase obj
	  (character
	   (make-nfa-char obj))
	  (list
	   (case (car obj)
	     ((:loop)
	      (make-nfa-loop
	       (list->nfa (cdr obj))))
	     ((:or)
	      (merge-nfa-or
	       (list->nfa (list (second obj)))
	       (list->nfa (cddr obj))))
	     (T
	      (list->nfa obj))))
	   (symbol
	    (case obj
	      ((:all)
	       (make-nfa-all))
	      (T (error "Unexpected symbol:~A" obj))))
	   (T (error "Unexpected type:~A" obj))))
     lst))))

>(match (list->nfa (regexp->list "(hoge|fuga|piyo)*"))
	"foobarhogefugapiyofizzbuzz")
"hogefugapiyo"
6
18
>(match (list->nfa (regexp->list "'.*(hoge|fuga|piyo).*'"))
		"this is 'test hoge.'")
"'test hoge.'"
8
20

NFAの状態遷移図をcl-dotで描画する

正規表現からNFAへ変換処理をデバッグするときに、NFAの状態遷移図どのようになったかを知りたい。手書きするのも面倒くさくなってきたので、cl-dotで描画することにした。

NFAは前回の記事の形式であるとする。

cl-dotのノードや矢印に属性値を指定したい場合、元々のオブジェクトをattributedというクラスのオブジェクトでラップすれば良いようだ。

;;;nfaの遷移図を描画
(defparameter *table* nil)
(defparameter *f* nil)

(defun mklist (lst)
  (if (listp lst) lst (list lst)))

(defmethod cl-dot:graph-object-node ((graph (eql 'nfa)) (key symbol))
  (make-instance 'cl-dot:node
		 :attributes
		 (list :label (format nil "~A" key)
		       :shape :box
		       :fontname "Arial"
		       :style :filled
		       :fillcolor
		       (if (member key *f*)"#aaaaaa" "#ffffff")
		       :color :black)))

(defmethod cl-dot:graph-object-points-to ((graph (eql 'nfa)) (key symbol))
  (let ((alist (gethash key *table*)))
     (mapcan
      #'(lambda (lst)
	  (mapcar
	   #'(lambda (next)
	       (make-instance 'cl-dot:attributed :object next
			      :attributes (list
					  :label (format nil "~A" (car lst))
					  :dir :forward)))
	   (cdr lst)))
      alist)))

(defun run (nfa path &key (format :png))
  (let ((*table* (nfa-table nfa))
	(*f* (mklist (nfa-f nfa))))
    (let ((graph (cl-dot:generate-graph-from-roots
		  'nfa
		  (list (nfa-start nfa)))))
      (cl-dot:dot-graph graph path :format format))))

;;(run nfa
;;     "/home/kurohuku/edit/lisp/graphic/nfa.png")

正規表現からNFAを作る

ドラゴンブックの字句解析の項目を参考に、正規表現を表す文字列からNFAを作る。

(defvar *label-count* 0)

;;遷移図で特殊な入力記号として用いるもの
;; :epsilon イプシロン遷移
;; :all 任意の1文字

(defun mklist (obj)
  (if (listp obj) obj (list obj)))

(defmacro do-hash ((key val) table &body body)
  `(maphash
    #'(lambda (,key ,val)
	,@body)
    ,table))

(defun make-new-state ()
  (incf *label-count*)
  (intern (format nil "STATE-~A" *label-count*) :keyword))

(defun get-states (input move-table)
  (or (cdr (assoc input move-table))
      (if (eq input :epsilon)
	  nil
	  (cdr (assoc :all move-table)))))

;;tableはハッシュテーブルで、状態をキーとして、
;;入力とそれに対する遷移後の状態をalistで保存する
(defstruct NFA
  start					;初期状態
  table					;遷移図
  f)					;受理状態の集合

(defun make-nfa-char (ch)
  (let ((i (make-new-state))
	(f (make-new-state)))
    (let ((table (make-hash-table)))
      (setf
       (gethash i table)
       (acons ch (list f) nil))
      (make-nfa
       :start i
       :table table
       :f (list f)))))

;;任意の一文字を受理する
(defun make-nfa-all ()
  (let ((i (make-new-state))
	(f (list (make-new-state)))
	(table (make-hash-table)))
    (setf (gethash i table)
	  (acons :all f nil))
    (make-nfa
     :start i
     :f f
     :table table)))


;;正規表現abを、a,bを表すNFA1,NFA2を連結して作成
(defun merge-nfa-concat (nfa1 nfa2)
  (let ((i (nfa-start nfa1))
	(nfa1f (mklist (nfa-f nfa1)))
	(nfa2i (nfa-start nfa2))
	(f (mklist (nfa-f nfa2))))
    (let ((table (make-hash-table)))
      (do-hash (s val) (nfa-table nfa1)
	(setf
	 (gethash s table)
	 val))
      (do-hash (s val) (nfa-table nfa2)
	(dolist (move val)
	  ;;nfa2の初期状態とnfa1の終了状態をくっつける
	  (if (eq s nfa2i)
	      (dolist (f nfa1f)
		(push
		 move
		 (gethash f table)))
	      (push
	       move
	       (gethash s table)))))
      (make-nfa
       :start i
       :f f
       :table table))))

;;a|bをあらわすNFAを合成する
(defun merge-nfa-or (nfa1 nfa2)
  (let ((newi (make-new-state))
	(newf (make-new-state))
	(table (make-hash-table)))
    ;;遷移図をコピー
    (do-hash (key val) (nfa-table nfa1)
      (setf (gethash key table) val))
    (do-hash (key val) (nfa-table nfa2)
      (setf (gethash key table) val))
    ;;新しい初期状態(newi)からのイプシロン遷移
    (push
     (list :epsilon (nfa-start nfa1) (nfa-start nfa2))
     (gethash newi table))
    ;;新しい終了状態(newf)へのイプシロン遷移を追加
    (dolist (f (mklist (nfa-f nfa1)))
      (let ((old (gethash f table)))
	(push
	 `(:epsilon ,newf ,@(get-states :epsilon old))
	 (gethash f table))))
    (dolist (f (mklist (nfa-f nfa2)))
      (let ((old (gethash f table)))
	(push
	 `(:epsilon ,newf ,@(get-states :epsilon old))
	 (gethash f table))))
    (make-nfa
     :start newi
     :f (list newf)
     :table table)))

(defun make-nfa-loop (nfa)
  (let ((newi (make-new-state))
	(newf (make-new-state))
	(table (make-hash-table)))
    ;;nfaのテーブルをコピー
    (do-hash (k v) (nfa-table nfa)
      (setf (gethash k table) v))
    ;;newiからnewfへのイプシロン遷移
    ;;newiから(nfa-start nfa)へのイプシロン遷移
    (setf
     (gethash newi table)
     `((:epsilon ,(nfa-start nfa) ,newf)))
    ;;(nfa-f nfa)から(nfa-start nfa),newfへのイプシロン遷移
    (dolist (f (mklist (nfa-f nfa)))
      (let ((old (gethash f table)))
	(push
	 `(:epsilon ,newf ,(nfa-start nfa) ,@(get-states :epsilon old))
	 (gethash f table))))
    (make-nfa
     :start newi
     :f (list newf)
     :table table)))

(defun nfa-start-states (nfa)
  (move-epsilon (nfa-table nfa)
		(nfa-start nfa)))

(defun move (nfa states input)
  (let ((states (mklist states))
	(table (nfa-table nfa)))
    (move-epsilon
     table
     (move-inner table states input))))

(defun move-inner (table states input)
  (if (not (listp states))
      (get-states input (gethash states table))
      (let ((result nil))
	(dolist (s states)
	  (dolist (next (get-states input (gethash s table)))
	    (pushnew next result)))
	result)))

(defun move-epsilon (table states)
  (let ((unchecked (if (listp states) states (list states)))
	(checked nil))
    (do ((s (pop unchecked) (pop unchecked)))
	((null s) checked)
      (push s checked)
      (dolist (next (move-inner table s :epsilon))
	(unless (or (member next checked)
		    (member next unchecked))
	  (push next unchecked))))))

(defun regexp->nfa (str &optional (start 0))
  (let ((len (length str))
	(result nil))
    (do ((i start (1+ i)))
	((>= i len) (values
		     (reduce #'merge-nfa-concat
			     (nreverse result))
		     i))
      (case (char str i)
	((#\()
	 (multiple-value-bind (nfa next)
	     (regexp->nfa str (1+ i))
	   (push nfa result)
	   (setf i next)))
	((#\))
	 (return-from regexp->nfa
	   (values
	    (reduce #'merge-nfa-concat
		    (nreverse result))
	    i)))
	((#\*)
	 (let ((prev (pop result)))
	   (push (make-nfa-loop prev) result)))
	((#\|)
	 (multiple-value-bind (nfa next)
	     (regexp->nfa str (1+ i))
	   (let ((prev
		  (reduce #'merge-nfa-concat
		   (nreverse result))))
	     (setf result nil)
	     (push
	      (merge-nfa-or prev nfa)
	      result))
	   (setf i next)))
	((#\.)
	 (push (make-nfa-all) result))
	(T
	 (push (make-nfa-char (char str i)) result))))))

(defun match (nfa str)
  (let ((is (nfa-start-states nfa))
	(f (nfa-f nfa))
	(path nil)
	(strlen (length str)))
    (do ((begin 0 (1+ begin)))
	((>= begin strlen) nil)
      (setf path nil)
      (do ((i 0 (1+ i))
	   (crr is crr))
	  ((>= (+ begin i) strlen) nil)
	(setf crr
	      (move nfa crr (char str (+ begin i))))
	(if crr
	    (push crr path)
	    (setf i strlen)))		;次のループで終了する
      (loop
	 :for sts in path
	 :for rest = path then (cdr rest)
	 :when (intersection sts f)
	 :do
	 (let ((end (+ begin (length rest))))
	   (return-from match
	     (values (subseq str begin end)
		     begin end)))))))

;;テスト用
(defun grep-file (reg file &optional (num nil))
  (with-open-file (s file :direction :input)
    (let ((nfa (regexp->nfa reg)))
      (loop
	 :for line = (read-line s nil nil)
	 :for n from 1
	 :while line
	 :when (match nfa line)
	 :do
	 (if num
	     (format t "~A:~A~%" n line)
	     (format t "~A~%" line))))))

いちおう.*|の3種類を特別扱いしてくれるはず。今回のメインなのに、読み取りがうまく出来ないなぁ。

使ってみる。

>(match (regexp->nfa "'.*((lisp|scheme)|c++).*'")
		"I like 'common lisp'")
"'common lisp'"
7
20
>(match (regexp->nfa "'.*((lisp|scheme)|c++).*'")
		"I like 'white space'")
NIL

Modula3でFizzBuzz

Case文がパターンマッチっぽい.

MODULE Main;
IMPORT IO;

BEGIN
     FOR i := 1 TO 100 DO
     	  CASE i MOD 15 OF
     	  | 0 => IO.Put("FizzBuzz");
	  | 3,6,9,12 => IO.Put("Fizz");
	  | 5,10 => IO.Put("Buzz");
	  ELSE
	       IO.PutInt(i);
	  END;
	  IO.Put("\n");
     END;

END Main.

PCIデバイスが存在するか確認する

PCIデバイスがあるかどうか確認する。一応それっぽいデバイスが表示はされる。

io_inXとio_outX,Printfが既に定義されているものとする。 io_inとio_outはそれぞれのビット数のin,out命令。

enum PCI_CONFIGURATION_REGISTER
{
	VenderID = 0x00, //bit0-15
	DeviceID = 0x00, //bit16-32
	CommandRegister = 0x04, //bit0-15
	StatusRegister = 0x04, //bit16-32
	RevisionRegister = 0x08, //bit0-7
	ClassCode = 0x08, //bit8-31
	CacheLineSize = 0x0C, //bit0-7
	MasterLatencyTimer = 0x0C, //bit8-15
	HeaderType = 0x0C, //bit16-32
	BISTRegister = 0x0C, //bit24-31
};

#define CONFIGURATION_ADDRESS 0x0CF8
#define CONFIGURATION_DATA 0x0CFC
#define CONFIGURATION_DATA1 0x0CFD
#define CONFIGURATION_DATA2 0x0CFE
#define CONFIGURATION_DATA3 0x0CFF

struct PCIConfigHeader{
	uint16 venderID;
	uint16 deviceID;
	uint16 command;
	uint16 status;
	uint8 revision;
	uint8 classCode[3]; //3byte
	uint8 chacheLineSize;
	uint8 latency;
	uint8 header;
	uint8 builtInSelftest;
	uint32 baseAddrReg0;
	uint32 baseAddrReg1;
	uint32 baseAddrReg2;
	uint32 baseAddrReg3;
	uint32 baseAddrReg4;
	uint32 baseAddrReg5;
	uint32 cardBusCISPointer;
	uint16 subSystemVenderID;
	uint16 subSystemID;
	uint32 expansionRomAddr;
	uint32 Reserved0;
	uint32 Reserved1;
	uint8 irqLine;
	uint8 interruptPin;
	uint8 minGrant;
	uint8 maxLatency;
};

//bus=バス番号 dev=デバイス番号,reg=レジスタ番号(bit0-7) func = 機能番号
int WriteConfigAddr(int bus, int dev, int reg, int func)
{
	int data;
	data = 0x80000000 |
		((bus << 16) & 0xFF0000) |
		((dev << 11) & 0xF800) |
		((func << 8) & 0x700) |
		(((reg/4) << 2) & 0xFC);
	io_out32(CONFIGURATION_ADDRESS, data);
	return 0;
}

int ReadConfig32(int bus, int dev, int reg, int func)
{
	WriteConfigAddr(bus, dev, reg, func);
	return io_in32(CONFIGURATION_DATA);
}

int CheckBus(int bus)
{
  int dev;
  for(dev=0; dev<32; dev++)
  {
    int vender,devid;
    int tmp = ReadConfig32(bus, dev, VenderID, 0);
    vender = tmp&0xFFFF;
    devid = (tmp>>16)&0xFFFF;
    if(vender == 0xFFFF) //デバイスは存在しない
			continue;
    Printf("PCI bus %d, dev %d Exist. Vender=%x, DevID=%x\n", bus, dev,vender,devid);
  }
  return 0;
}

int CheckPCI()
{
 for(int i = 0; i < 0x0100; i++)
 {
   CheckBus(i);
 }
 return 0;
}

qemuでCheckPCIを呼び出したら以下のように表示された。

PCI bus 0, dev 0 Exist. Vender=8086, DevID=1237
PCI bus 0, dev 1 Exist. Vender=8086, DevID=7000
PCI bus 0, dev 2 Exist. Vender=1013, DevID=B8
PCI bus 0, dev 3 Exist. Vender=10EC, DevID=8029
PCI bus 0, dev 4 Exist. Vender=1AF4, DevID=1002

Modula-3のSLisp

Critical Mass Modula-3のライブラリにSLispというものがある。名前を見るにLispっぽいので使おうと試みる。

ちなみに、m3makefileでimportに書く名前は、 modula3のディレクトリのpkgディレクトリのサブディレクトリの名前だと思う。

MODULE Main;
IMPORT SLisp,Stdio,Rd,Wr,IO;

VAR slisp :SLisp.T;
VAR rd :SLisp.Reader;
VAR wr :SLisp.Writer;

BEGIN
     rd := Stdio.stdin;
     wr := Stdio.stdout;
     slisp := NEW(SLisp.T);
     slisp := slisp.new();
     LOOP
       SLisp.Write(wr ,slisp.eval(SLisp.Read(rd)));
       IO.Put("\n");
     END;

END Main.