defclass-star 便利

defclass は defstruct にくらべると、:initarg や :initform を明示的に指定しなければならないあたりが面倒。
それを解決してくれのが defclass-star.

;; こんなふうに書くと
(defclass* cat ()
  ((eye-color "blue")
   (body-color "シールポイント")
   (lovely t :type boolean)))

;; こんなふうに展開される。
(DEFCLASS CAT NIL
  ((EYE-COLOR :INITFORM "blue" :ACCESSOR EYE-COLOR-OF :INITARG
              :EYE-COLOR)
   (BODY-COLOR :INITFORM "シールポイント" :ACCESSOR BODY-COLOR-OF :INITARG
               :BODY-COLOR)
   (LOVELY :INITFORM T :ACCESSOR LOVELY-P :INITARG :LOVELY :TYPE
           BOOLEAN)))

type boolean とするとちゃんと

accessor が xxx-p となってくれる。

この人は :accessor を xxx-of にするんだね。
このへんの命名規則は歴史的にもいろいろとあるのかな？

小さな Forth もどきを作ってみた

(def-primitive :|create| のことろで codes-index を 0 に設定してなかったので、2回目以降の呼び出しが何もせず終っていた。
修正した。(2005/05/05)

今日はちょっと初心にかえって小さな Forth もどきを作ってみた。
実装は Common Lisp で、参考にしたのはもちろん jonesforth.

: 1+ 1 + ;
9 1+ .

で10を出力くらしか動かないけど。

それでもこんな小さなコードでまがりなりにもプログラムが動くってのは不思議に思える。

(defparameter *data-stack* nil)
(defparameter *return-stack* nil)
(defparameter *code-point* nil)
(defparameter *dictionary* (make-hash-table))

(defstruct codes
  (codes (make-array 0 :adjustable t :fill-pointer t))
  (index 0))

(defun codes-next (&optional (codes *code-point*))
  (unless (codes-end-p codes)
    (prog1
        (aref (codes-codes codes) (codes-index codes))
      (incf (codes-index codes)))))

(defun codes-end-p (&optional (codes *code-point*))
  (>= (codes-index codes) (length (codes-codes codes))))

(defun run ()
  (loop
     while
     (progn
       (loop while (and *code-point* (codes-end-p))
          do (setf *code-point* (por)))
       ;;(format t "~%~s~%~s~%~s~%" *return-stack* *data-stack* *code-point*)
       *code-point*)
     do (let ((word (codes-next)))
          (let ((def (fnd word)))
            (if def
                (funcall def)
                (error "~s is unbound." word))))))

(defun put-dic (k v)
  (setf (gethash k *dictionary*) v))

(defun get-dic (k)
  (gethash k *dictionary*))

(defmacro def-primitive (word (&optional immediate) &body body)
  `(progn
     (setf (get ',word 'immediate) ,immediate)
     (put-dic ,word #'(lambda () ,@body))))

(defmacro def-word (word (&optional immediate) &body body)
  `(progn
     (setf (get ',word 'immediate) ,immediate)
     (put-dic ,word #'(lambda ()
                        (pur *code-point*)
                        (setf *code-point*
                              (make-codes :codes (coerce ',body 'vector)))))))

(defun fnd (word)
  (get-dic word))

(defun po ()
  (pop *data-stack*))

(defun pu (x)
  (push x *data-stack*))

(defun por ()
  (pop *return-stack*))

(defun pur (x)
  (push x *return-stack*))


(def-primitive :|t| ()
               (pu t))
(def-primitive :|nil| ()
               (pu nil))
(defgeneric g= (x y)
  (:method (x y)
    (equal x y)))
(def-primitive :|=| ()
               (pu (g= (po) (po))))

(def-primitive :|dup| ()
               (pu (car *data-stack*)))

(def-primitive :|+| ()
               (pu (+ (po) (po))))

(def-primitive :|.| ()
               (print (po)))

(def-primitive :|lit| ()
               (pu (codes-next)))
(def-primitive :|exit| ()
               (setf *code-point* (por)))
(def-primitive :|create| ()
               (let ((word (po)))
                 (let ((codes (make-codes)))
                   (put-dic word #'(lambda ()
                                     (pur *code-point*)
                                     (setf (codes-index codes) 0)
                                     (setf *code-point* codes)))
                   (def-primitive :|latest| ()
                                  codes))))
(defun latest ()
  (funcall (fnd :|latest|)))
(defun comma (word)
  (let ((codes (latest)))
    (vector-push-extend word (codes-codes codes))))
(def-primitive :|,| ()
               (comma (po)))
(def-primitive :|immediate| (t)
               (let ((latest (latest)))
                 (maphash #'(lambda (k v)
                              (when (eq v latest)
                                (setf (get k 'immediate) t)))
                          *dictionary*)))
(def-primitive :|branch| ()
               (let ((offset (1- (codes-next)))) ; 1- is offset it self.
                 (incf (codes-index *code-point*) offset)))
(def-primitive :|0branch| ()
               (if (po)
                   (incf (codes-index *code-point*))
                   (incf (codes-index *code-point*)
                     (codes-next))))

(def-primitive :|cons| ()
               (let ((y (po))
                     (x (po)))
                 (pu (cons x y))))
(def-primitive :|car| ()
               (pu (car (po))))
(def-primitive :|cdr| ()
               (pu (cdr (po))))
(def-primitive :|cons?| ()
               (pu (consp (po))))

(def-primitive :|{}| ()
               (pu (make-hash-table)))

(def-primitive :|*stdin*| ()
               (pu *standard-input*))
(def-primitive :|read-char| ()
               (pu (read-char (po) nil nil)))
(def-primitive :|*stdout*| ()
               (pu *standard-output*))
(def-primitive :|write-char| ()
               (let ((stream (po))
                     (char (po)))
                 (write-char char stream)))

(defun word ()
  (let ((scaned (with-output-to-string (out)
                  (loop for c = (read-char *standard-input* nil nil)
                     if (char> c #\space)
                     do (return (write-char c out)))
                  (loop for c = (read-char *standard-input* nil nil)
                     do (if (char> c #\space)
                            (write-char c out)
                            (return))))))
    (intern scaned :keyword)))
(def-primitive :|word| ()
               (pu (word)))

(def-primitive :|state| ()
               (pu nil))
(def-primitive :|[| (t)
               (def-primitive :|state| ()
                              (pu nil))) ; immediate mode
(def-primitive :|]| ()
               (def-primitive :|state| ()
                              (pu t)))  ; compile mode

(def-word :|quit| ()
          :|interpret|
          :|branch|
          -2)

(def-primitive
    :|interpret| ()
    (let ((word  (progn
                   ;;(format t "~%~s~%~s~%~s~%" *return-stack* *data-stack* *code-point*)
                   (word))))
      (when (eq word :|bye|)
        (break))
      (let ((fnd (fnd word)))
        (if fnd
            (if (get word 'immediate)
                (funcall fnd)
                (if (progn (funcall (fnd :|state|)) (po))
                    (comma word)
                    (funcall fnd)))
            (let ((literal (read-from-string (symbol-name word))))
              (when (symbolp literal)
                (error "~s is unknown." word))
              (if (progn (funcall (fnd :|state|)) (po))
                  (progn
                    (comma :|lit|)
                    (comma literal))
                  (pu literal)))))))


(def-word :|:| ()
          :|word| :|create| :|]|)
(def-word :|;| (t)
          :|[|)


;;;; 以下テスト
(def-word :|double| ()
          :|+| :|+|)

(progn
  (setf *code-point*
        (make-codes :codes #(:|lit| 1 :|lit| 2 :|lit| 3 :|double|)))
  (run)
  (assert (= 6 (print (po)))))

(progn
  (setf *code-point*
        (make-codes
         :codes
         #(:|lit| 1 :|lit| 2 :|lit| 3 :|lit| 4 :|lit| 5
           :|lit| :|triple| :|create|
           :|lit| :|+| :|,|
           :|lit| :|+| :|,|
           :|lit| :|+| :|,|
           :|lit| :|+.| :|create|
           :|lit| :|+| :|,|
           :|lit| :|dup| :|,|
           :|lit| :|.| :|,|
           :|triple|
           :|+.|)))
  (run)
  (assert (= 15 (print (po)))))

(progn
  (setf *code-point* (make-codes :codes #(:|quit|)))
  (run))

mkdir a b c

mkdir って一度に複数のディレクトリを作成できるんだね。

/tmp/a $ mkdir -pv a b c/d/e
/tmp/a $ /bin/mkdir: created directory `a'
/bin/mkdir: created directory `b'
/bin/mkdir: created directory `c'
/bin/mkdir: created directory `c/d'
/bin/mkdir: created directory `c/d/e'

Forth で無名関数の再帰

Perl で JS の arguments.callee 的なことしようと思ってハマった - IT戦記 の件を Forth で。

Forth なら recurse がある。

:noname dup if dup . 1 - recurse else . then ;  ok
10 swap  ok
.s <2> 10 47312420583688  ok
execute  10 9 8 7 6 5 4 3 2 1 0  ok

ところが、名前付きの関数で普通に再帰しようとすると

: foo ." hello" foo ; 
*the terminal*:1: Undefined word
: foo ." hello" foo ;
                ^^^

とエラーになる。

さらに、既に定義してあれば古い定義が呼ばれる。

: bar ." World!" ;  ok
: bar cr  ." Hello " bar ; redefined bar   ok
bar
Hello World! ok

Common Lisp で無名関数の再帰

Common Lisp だとこんな感じ？

(defmacro rlambda (lambda-list &body body)
  `(labels ((self ,lambda-list
              ,@body))
     #'self))

(funcall
 (rlambda (n)
   (print n)
   (unless (zerop n) (self (1- n))))
 10)

ん？ むしろ引数に呼び出し元を持たせるのかな？

funcall read-from-string するわけ

Slime の起動では次のように read-from-string して funcall している。

(progn (load "/slime/swank-loader.lisp" :verbose t) (funcall (read-from-string "swank-loader:init")) (funcall (read-from-string "swank:start-server") "/tmp/slime.13550" :coding-system "utf-8-unix"))

以前なんでだろう？ と疑問に思ったけどスルーしていたが、今日理由がわかった。
read した時点ではまだ swank パッケージが存在しないからだ。
Common Lisp では存在しないパッケージのシンボルを read しようとするとエラーとなる。
(load "/slime/swank-loader.lisp" :verbose t) が終わるまでは普通に swank パッケージのシンボルを書くことができない。
その対策として read 時には文字列で、実行時にシンボルにする。
なるほど。

Drakma 使用時の注意事項

Drakma - A Common Lisp HTTP client を使うときの注意事項。

• *drakma-default-external-format* で external-format を指定しておく。
• text/* 以外の Content-Type をテキストとして扱いたいときは、*text-content-types* に追加する。
• Content-Length は省略すると文字数でカウントされるため、バイト数で明示的に指定する。

(use-package :drakma)

;; UTF-8
(setq *drakma-default-external-format* :utf-8)

;; application/atom+xml をバイナリではなくテキストとして扱う。
(pushnew (cons "application" "atom+xml") *text-content-types*
         :test #'equal)

;; Content-Length はバイトサイズで指定する。
(http-request "http://www.example.com/"
              :method :post
              :content post-data
              :content-length (length (sb-ext:string-to-octets
                                       post-data :external-format :utf-8)))