closette

#1 (defun (setf <access-fn>) ...) - 日々ごちゃごちゃと考える
defunはclosette付属のnewcl.lispの定義をそのまま使って、あとxyzzyにないtypecase, ecase, print-unreadable-object等を適当に書き、んでstd-instanceの定義のprint-functionで引っかかってたのを誤魔化したらとりあえずeval-bufferとbyte-compileは通るように。
しかしコンパイルしたのをロードしたら落ちた。

めんどそうなのでそこはとりあえず無視してclosette-test.lispを走らせてみたのだけれど、構造体に循環参照があるせいでpprint等でスタックオーバーフローに。
その辺を(write ... :circle t)などとまた誤魔化してみたら、むっちゃ重かったけどなんとか通った。

closette.l
closette-tests.l

テストログ
*standard-output*
*trace-output*

print-functionが全く働いてなくて悲惨なログになってるけど(修正済み)、ざっと見まともに動いてる??

(defmacro typecase (var &rest clauses)
  (let ((type-of-var (gensym)))
    `(let ((,type-of-var (type-of ,var)))
       (case ,type-of-var
	 ,@clauses))))

(defmacro ecase (var &rest clauses)
  (let ((wanted (mapcar #'car clauses)))
    `(case ,var
       ,@clauses
       (t (type-error ,var ',wanted)))))

(defun pprint (object &optional (os *standard-output*))
  (write object :stream os :circle t :escape t :pretty t))

(defmacro print-unreadable-object
  ((object stream &key type identity) &body body)
  (with-gensyms (gs gobj)
    `(let ((,gs ,stream)
	   (,gobj ,object))
       (format ,gs "#<")
       ,(when type
	  `(format ,gs "~S" (type-of ,gobj)))
       ,(when (and type (or body identity))
	  `(format ,gs " "))
       ,@body
       ,(when (and identity body)
	  `(format ,gs " "))
       ,(when identity
	  `(format ,gs "~X" (si:address-of ,gobj)))
       (format ,gs ">")
       nil)))

;;テスト
(time
 (w/infile (is "~/site-lisp/cl/closette-tests.l")
   (w/outfile (os "~/site-lisp/cl/closette-test_log.txt")
     (w/outfile (*trace-output* "~/site-lisp/cl/closette-test_trace.txt")
       (w/outfile (*standard-output* "~/site-lisp/cl/closette-test_stdout.txt")
	 (whilet sexp (read is nil nil t)
	   (format os "~&~A~%  ; => ~A~%~%" sexp (eval sexp))
	   (fresh-line)))))))
16813 msec

正しくコンパイルされるように直すのは色々しんどそうだなぁ。