[Common Lisp] asdf で fasl のバージョンが古いとき自動的にリコンパイルする

処理系をアップデートしたあと、(require :xxx) するとよく fasl のバージョンがあってないよとデバッガがたちあがったりする。

そのとき自動的にリコンパイルする方法が CLiki にのってた。

~/.sbclrc とかに以下を追加しておく。

(defmethod asdf:perform :around ((o asdf:load-op) (c asdf:cl-source-file))
  (handler-case (call-next-method o c)
    (#+sbcl sb-ext:invalid-fasl
     #+allegro excl::file-incompatible-fasl-error
     #+lispworks conditions:fasl-error
     #+cmu ext:invalid-fasl
     #-(or sbcl allegro lispworks cmu) error ()
     (asdf:perform (make-instance 'asdf:compile-op) c)
     (call-next-method))))

[Common Lisp] swank-backend::openmcl-set-debug-switches

Clozure CL で SLIME するときは ~/.swank.lisp で swank-backend::openmcl-set-debug-switches を呼ぶとよさそう。

しかし、swank:*globally-redirect-io* の方が効いていない気がする。。。

~/.swank.lisp

(setq swank:*globally-redirect-io* t)

#+:ccl
(swank-backend::openmcl-set-debug-switches)

[Common Lisp] Clozure CL での日本語のための設定

Clozure CL での日本語のための設定はこんな感じでいいのかな。

~/ccl-init.lisp

(setf ccl:*default-external-format*
      (ccl:make-external-format :character-encoding :utf-8
                                :line-termination :unix)
      ccl:*default-file-character-encoding* :utf-8
      ccl:*default-socket-character-encoding* :utf-8)

[Common Lisp] Clozure CL の require で asdf:oos する

なぜか SBCL + SLIME が動かないので Clozure + SLIME に浮気してみた。コンパイルとロードが速い!!

で、ひとつ気になったのが SBCL のように require で asdf:*central-registry* にあるライブラリをロードしてくれないこと。

以前、MCL でなんかしたなぁ、というのを思い出しつつ ccl::*module-provider-functions* に pushnew してみた。

~/ccl-init.lisp

;;;; -*- lisp -*-

;;; 最適化
(declaim (optimize (debug 3) (safety 3) (speed 0) (space 0)
                   (compilation-speed 3)))
;;(declaim (optimize (debug 0) (safety 0) (speed 3) (space 0)
;;                   (compilation-speed 0)))


;;; 文字コード
(setf ccl:*default-external-format*
      (ccl:make-external-format :character-encoding :utf-8
                                :line-termination :unix)
      ccl:*default-file-character-encoding* :utf-8
      ccl:*default-socket-character-encoding* :utf-8)


;;; asdf
(require :asdf)

;; ~/letter/lib 以下の asd を登録する。
(loop for path in (directory (translate-logical-pathname
                                       "home:letter;lisp;lib;**;*.asd"))
      do (let ((pd (pathname-directory path)))
           (unless (member "_darcs" pd :test #'equal)
             (pushnew (make-pathname :directory pd)
                      asdf:*central-registry*
                      :test #'equal))))

;; clbuild
(pushnew (translate-logical-pathname "home:letter;lisp;clbuild;systems;")
         asdf:*central-registry*)

;; require で asdf:oos する
(defun asdf-module-provider-function (module)
  (when (asdf:find-system module nil)
    (asdf:oos 'asdf:load-op module)
    t))
(pushnew 'asdf-module-provider-function
         ccl::*module-provider-functions*)

[Common Lisp] [*scratch*] gray stream

なんかもうどうでもいいから、昔書いたコードをアップしたりする（笑

(defpackage :koto.iconv-stream
  (:nicknames :iconv-stream)
  (:use :cl :sb-gray)
  (:export
   :make-iconv-output-stream
   :make-iconv-input-stream
   ))

(in-package :iconv-stream)

(defclass iconv-stream-mixin ()
  ((external-format :initform "UTF-8" :initarg :external-format)
   (internal-format :initform "UTF-8" :initarg :internal-format)))

(defclass iconv-output-stream (fundamental-character-output-stream
                               iconv-stream-mixin)
  ((base-stream :initarg :base-stream)
   (buffer :initform (make-string 4096))
   (fill-pointer :initform 0)
   (column :initform 0)))

(defmethod stream-write-char ((stream iconv-output-stream) char)
  (with-slots (buffer fill-pointer column) stream
    (setf (schar buffer fill-pointer) char)
    (incf fill-pointer)
    (if (char= #\newline char)
        (setf column 0)
        (incf column))
    (if (= fill-pointer (length buffer))
        (force-output stream)))
  char)

(defmethod stream-line-column ((stream iconv-output-stream))
  (slot-value stream 'column))

(defmethod stream-force-output ((stream iconv-output-stream))
  (with-slots (buffer fill-pointer external-format internal-format base-stream)
      stream
    (unless (zerop fill-pointer)
      (let ((vector (sb-ext:string-to-octets buffer :end fill-pointer)))
        (write-sequence (iconv:iconv internal-format external-format vector)
                        base-stream))
      (setf fill-pointer 0)))
  nil)

(defmethod close ((stream iconv-output-stream) &key abort)
  (with-slots (base-stream) stream
    (stream-force-output stream)
    (close base-stream :abort abort)))

(defun make-iconv-output-stream (file external-format &key if-exists)
  (make-instance 'iconv-output-stream
                 :external-format external-format
                 :base-stream (open file
                                    :direction :output
                                    :if-exists if-exists
                                    :element-type '(unsigned-byte 8))))


(defclass iconv-input-stream (fundamental-character-input-stream
                              iconv-stream-mixin)
  ((base-stream :initarg :base-stream)
   (base-buffer :initform
                (make-array 4096
                            :element-type '(unsigned-byte 8)))
   (base-index :initform 0)
   (buffer :initform "")
   (index :initform 0)))

(defmethod stream-read-char ((stream iconv-input-stream))
  (with-slots (buffer index base-stream base-buffer base-index external-format
                      internal-format)
      stream
    (when (= index (length buffer))
      (let ((length (read-sequence base-buffer base-stream :start base-index)))
        (if (zerop length)
            (return-from stream-read-char :eof))
        (multiple-value-bind (out remain)
            (iconv:iconv external-format internal-format
                         (subseq base-buffer 0 length))
          (setf buffer (sb-ext:octets-to-string out)
                base-index (length remain)
                index 0)
          (loop for i from 0 below base-index
                do (setf (aref base-buffer i) (aref remain i))))))
    (prog1 (aref buffer index)
      (incf index))))

(defmethod stream-listen ((stream iconv-input-stream))
  (with-slots (buffer index) stream
    (< index (length buffer))))

(defmethod stream-unread-char ((stream iconv-input-stream) char)
  (with-slots (buffer index) stream
    (cond ((zerop index)
           (setf buffer (format nil "~a~a" char buffer)))
          (t
           (decf index)
           (setf (aref buffer index) char))))
  nil)

(defmethod stream-clear-input ((stream iconv-input-stream))
  (with-slots (buffer index base-index) stream
    (setf buffer ""
          index 0
          base-index 0))
  nil)

(defmethod stream-line-column ((stream iconv-input-stream))
  nil)

(defmethod close ((stream iconv-input-stream) &key abort)
  (with-slots (base-stream) stream
    (close base-stream :abort abort)))

(defun make-iconv-input-stream (file external-format)
  (make-instance 'iconv-input-stream
                 :external-format external-format
                 :base-stream (open file :element-type '(unsigned-byte 8))))

[日記] バレエ発表会

年末恒例のバレエ発表会が終った。娘は幼稚園組の真ん中で踊って、わずからがらソロもあった。よくがんばった。フレンチカンカンは楽しくてよかった。

ま、あと関係ないジャンクコードだけど

(eval-when (:compile-toplevel :load-toplevel :execute)
  (require :bordeaux-threads)
  (require :usocket)
  (require :cl-ppcre)
  (require :puri)
  (require :flexi-streams)
  (require :quek))

(defun start ()
  "プロキシサーバを開始する。"
  ;; スレッドで
  (threads:make-thread
   (lambda ()
     ;; ポート5555でリッスンする
     (usocket:with-socket-listener (socket "localhost" 5555)
       (loop
         ;; アクセプト
        (usocket:with-connected-socket (stream-socket
                                        (usocket:socket-accept
                                         socket
                                         :element-type '(unsigned-byte 8)))
          ;; ソケットとストリームを取り出してアクセプト時の処理を呼び出す
          (accept-handler (usocket:socket stream-socket)
                          (flexi-streams:make-flexi-stream
                           (usocket:socket-stream stream-socket)))))))
   ;; スレッドに名前を付けおく
   :name "プロキシで遊んでいるスレッド"))

(defun accept-handler (socket stream)
  "アクセプト時の処理"
  (declare (ignorable socket stream))
  ;; GET http://li31-15.members.linode.com/ HTTP/1.1 みたいなのを取り出す
  (ppcre:register-groups-bind (command url version)
      ("(.*) (.*) (.*)" (rcv-line stream))
    (declare (ignore version))
    ;; ヘッダをパースして
    (let ((headers (series:choose-if
                    (lambda (header)
                      (not (member (car header) '("Keep-Alive"
                                                  "Proxy-Connection")
                                   :test #'string=)))
                    (parse-header stream))))
      ;; リクエストを処理。めんどうなので HTTP/1.0 で
      (request command (puri:parse-uri url) "HTTP/1.0" headers stream))))

(defun parse-header (stream)
  "ヘッダをパースする"
  (#M(lambda (line)
       (ppcre:register-groups-bind (var value) ("(.*?): (.*)" line)
         (cons var value)))
     (read-header-part stream)))

(defun read-header-part (stream)
  "空行までのヘッダ部分を読み込む"
  (series:scan
   (series:collect ;  collect を入れないと scan-stream で何故かブロックしてしまう。
       (series:until-if
        (lambda (x) (string= x ""))
        (series:scan-stream stream #'rcv-line)))))

(defun request (command uri version headers client-stream)
  "本来のサーバにリクエストを投げてクライアントにレスポンスを返す"
  (let ((port (or (puri:uri-port uri) 80))
        (path (compute-path uri))
        (host (puri:uri-host uri)))
    (usocket:with-client-socket (server-socket
                                 server-stream
                                 host
                                 port
                                 :element-type '(unsigned-byte 8))
      (let ((server-stream (flexi-streams:make-flexi-stream server-stream)))
        ;; リクエストを送信
        (request-send server-stream command path version headers)
        ;; レスポンスを読み込みながらクライアントに返す
        (request-recieve server-stream client-stream)))))

(defun compute-path (uri)
  (q:string+
   (or (puri:uri-path uri) "/")
   (q:awhen (puri:uri-fragment uri)
     (q:string+ "#" q:it))
   (q:awhen (puri:uri-query uri)
     (q:string+ "?" q:it))))

(defun request-send (stream command path version headers)
  ;; 標準出力にもはきたいのでサーバのストリームに標準出力をくっつける
  (let ((out (make-broadcast-stream stream *standard-output*)))
    ;; GET / HTTP/1.1 みたいなのをサーバに送信
    (snd-line #"""#,command #,path #,version""" out)
    ;; ヘッダをサーバに送信
    (write-headers out headers)
    ;; ヘッダの終りを送信
    (snd-line "" out)
    ;; POST の場合
    (when (string-equal command "POST")
      nil)
    ;; ストリームをフラッシュ
    (force-output out)))

(defun request-recieve (server-stream client-stream)
  "サーバから受信してクライアントにそのまま送信する"
  ;; 標準出力にもはきたいのでクライアントのストリームに標準出力をくっつける
  (let ((out (make-broadcast-stream client-stream *standard-output*)))
    ;; レスポンスを読み込みながらクライアントに返す
    (snd-line (rcv-line server-stream) out) ; ステータス
    (let ((headers (parse-header server-stream)))
      (write-headers out headers)       ; ヘッダ
      (snd-line "" out)
      (if (text-content-p headers)
          ;; テキスト
          (series:collect-stream
           out (series:scan-stream server-stream #'read-char) #'write-char)
          ;; バイナリ
          (series:collect-stream
           client-stream (series:scan-stream server-stream #'read-byte)
           #'write-byte)))
    ;; ストリームをフラッシュ
    (force-output out)))

(defun write-headers (stream headers)
  (series:collect-stream stream
                         (#M(lambda (x)
                              #"""#,(car x): #,(cdr x)""")
                            headers)
                         #'snd-line))

(defun snd-line (value stream)
  "1行出力"
  (princ value stream)
  (princ #\Return stream)
  (princ #\Newline stream))

(defun rcv-line (stream &optional (eof-error-p nil) eof-value)
  "1行入力"
  (let ((line (read-line stream eof-error-p eof-value)))
    (when line
      (string-trim '(#\Return #\Newline) line))))

(defun text-content-p (headers)
  "内容がテキストか否か"
  nil)
;;  (q:awhen (series:collect-first
;;            (series:choose-if (lambda (x) (string= (car x) "Content-Type"))
;;                              headers))
;;    (member (cdr q:it)
;;            '("text")
;;            :test #'q:string-start-p)))

日記

友人が結婚した。意表をつかれた。おめでとう。

祖父の一回忌で帰省。近所に安い温泉があるのはいいな。

娘が長靴をはいて猫になった。上手だったよ。

なんか他にも書いておこうと思っていたことがいろいろあったように思うが、思い出せない。

三重の思う。