#:g1: frontpage

 

KMRCLを眺める(236) attrib-class.lisp

Posted 2011-11-10 19:57:00 GMT

今回眺める attrib-class.lisp は、スロットに属性が付いたクラスの定義です。 AMOP(The Art of the Metaobject Protocol)でも例題になっていますが、定盤の拡張のようです。 クラスのメンバーは、CLOSではスロットと呼びますが、そのスロットごとに対応するalistが付ける、というものです。 とりあえず、上から順に眺めていきます。 いきなりですが、

;; Disable attrib class until understand changes in sbcl/cmucl
;; using COMPUTE-SLOT-ACCESSOR-INFO and defining method
;; for slot access of ALL-ATTRIBUTES. Does this work on Allegro/LW?
ということで、現在このファイルはライブラリとしては読み込まれていないようです。 asdのファイルもコメントアウトしてありました。 COMPUTE-SLOT-ACCESSOR-INFO が〜とありますが、ちょっとこの辺りは分かりません。とりあえずは、ちょっとした例は動いているようなので、動かしてみます。 とりあえず、札付きのメタクラスの定義
(in-package #:kmrcl)

(defclass attributes-class (kmr-mop:standard-class) () (:documentation "metaclass that implements attributes on slots. Based on example from AMOP"))

次にスロットの定義 ヒョージュン直接スロット定義=サン(ややこしいので日本語にします)を継承した、札付きの直接スロット定義=サンを定義 ヒョージュンと比べてみます。
(describe (make-instance 'kmr-mop:standard-direct-slot-definition))
;>>  #<SB-MOP:STANDARD-DIRECT-SLOT-DEFINITION NIL {1007FCB7F3}>
;>>    [standard-object]
;>>
;>>  Slots with :INSTANCE allocation:
;>>    NAME              = NIL
;>>    INITFORM          = NIL
;>>    INITFUNCTION      = NIL
;>>    READERS           = NIL
;>>    WRITERS           = NIL
;>>    INITARGS          = NIL
;>>    %TYPE             = T
;>>    %DOCUMENTATION    = NIL
;>>    %CLASS            = NIL
;>>    ALLOCATION        = :INSTANCE
;>>    ALLOCATION-CLASS  = NIL
;>>
;=>  <no values>

(describe (make-instance 'attributes-dsd))
;>>  #<ATTRIBUTES-DSD NIL {1007E4D433}>
;>>    [standard-object]
;>>
;>>  Slots with :INSTANCE allocation:
;>>    NAME              = NIL
;>>    INITFORM          = NIL
;>>    INITFUNCTION      = NIL
;>>    READERS           = NIL
;>>    WRITERS           = NIL
;>>    INITARGS          = NIL
;>>    %TYPE             = T
;>>    %DOCUMENTATION    = NIL
;>>    %CLASS            = NIL
;>>    ALLOCATION        = :INSTANCE
;>>    ALLOCATION-CLASS  = NIL
;>>    ATTRIBUTES        = NIL
;>>
;=>  <no values>
あたりまえですが、
;>>    ATTRIBUTES        = NIL
が追加されています。 ヒョージュン実効スロット定義=サンのクラスを継承して、attributesを追加した、 札付きの実効スロット定義=サンを定義
(defclass attributes-esd (kmr-mop:standard-effective-slot-definition)
  ((attributes :initarg :attributes :initform nil
               :accessor esd-attributes)))
LispWorksだけに関わる謎のネンブツ
;; encapsulating macro for Lispworks
(kmr-mop:process-slot-option attributes-class :attributes)
attributes-classは、standard-classのサブクラスであるように、スーパークラス検見奉行=サン(ややこしいので日本語にします)にレイギを教える
#+(or cmu scl sbcl ccl)
(defmethod kmr-mop:validate-superclass ((class attributes-class)
                                        (superclass kmr-mop:standard-class))
  t)

直接スロット定義クラス奉行=サンを定義。上記で定義した、札付きの直接スロット定義クラス=サンを返すようにします。
(defmethod kmr-mop:direct-slot-definition-class ((cl attributes-class) #+kmrcl::normal-dsdc &rest initargs)
  (declare (ignore initargs))
  (kmr-mop:find-class 'attributes-dsd))
※kmrcl::normal-dsdcが*features*にはいってないと&restが評価されないようなので、追加しておく必要があります。
(pushnew 'kmrcl::normal-dsdc *features*)
(kmr-mop:direct-slot-definition-class (make-instance 'attributes-class))
;=>  #<STANDARD-CLASS ATTRIBUTES-DSD>
実効スロット定義クラス奉行=サン(ややこしいので日本語にします)をユビキリ。上記で定義した、札付きの実効スロット定義クラス=サンを返すようなレイギ。
(defmethod kmr-mop:effective-slot-definition-class ((cl attributes-class) #+kmrcl::normal-dsdc &rest initargs)
  (declare (ignore initargs))
  (kmr-mop:find-class 'attributes-esd))
(kmr-mop:effective-slot-definition-class (make-instance 'attributes-class))
;=>  #<STANDARD-CLASS ATTRIBUTES-ESD>
実効スロット勘定奉行=サンの働きを定義 ※kmrcl::normal-cesdが*features*にはいってないと&restが評価されないようなので追加
(pushnew 'kmrcl::normal-cesd *features*)
(defmethod kmr-mop:compute-effective-slot-definition
    ((cl attributes-class) #+kmrcl::normal-cesd name dsds)
  #+kmrcl::normal-cesd (declare (ignore name))
  (let ((esd (call-next-method)))
    (setf (esd-attributes esd) (remove-duplicates (mapappend #'dsd-attributes dsds)))
    esd))
スロット勘定奉行=サンの働きを定義。 札付き実効スロット定義=サンから、札付き実効スロット=サンを作ってギンミします。
;; This does not work in Lispworks prior to version 4.3

(defmethod kmr-mop:compute-slots ((class attributes-class))
  (let* ((normal-slots (call-next-method))
         (alist (mapcar
                 #'(lambda (slot)
                     (cons (kmr-mop:slot-definition-name slot)
                           (mapcar #'(lambda (attr) (list attr))
                                   (esd-attributes slot))))
                 normal-slots)))

(cons (make-instance 'attributes-esd :name 'all-attributes :initform `',alist :initfunction #'(lambda () alist) :allocation :instance :documentation "Attribute bucket" :type t ) normal-slots)))

動かしてみます。 ■札付きスロットクラス
(defclass foo ()
  (a b c)
  (:metaclass kl:attributes-class))

(kmr-mop:finalize-inheritance (find-class 'foo))

(kmr-mop:compute-slots (find-class 'foo)) ;=> (#<ATTRIBUTES-ESD ALL-ATTRIBUTES> #<ATTRIBUTES-ESD A> #<ATTRIBUTES-ESD B> ; #<ATTRIBUTES-ESD C>)

■ヒョージュン
(defclass std ()
  (a b c)
  ;; (:metaclass standard-class)
  )
(kmr-mop:finalize-inheritance (find-class 'std))

(kmr-mop:compute-slots (find-class 'std)) ;=> (#<SB-MOP:STANDARD-EFFECTIVE-SLOT-DEFINITION A> ; #<SB-MOP:STANDARD-EFFECTIVE-SLOT-DEFINITION B> ; #<SB-MOP:STANDARD-EFFECTIVE-SLOT-DEFINITION C>)

札付きスロット係=サンを定義します。結果は、
(defun slot-attribute (instance slot-name attribute)
  (cdr (slot-attribute-bucket instance slot-name attribute)))
結果は、
(let ((foo (make-instance 'foo)))
  (setf (cdr (assoc 'a (slot-value foo 'all-attributes)))
        (acons :memo2 "メモその2"
               (list (cons :memo "aのメモ"))))
  (slot-value foo 'all-attributes))
という定義だとすると、
(let ((foo (make-instance 'foo)))
  (slot-value foo 'all-attributes))
;=>  ((A (:MEMO2 . "メモその2") (:MEMO . "aのメモ")) (B) (C))
という風に、入れ子のalistが返るオキテになっています。 札付きスロット係=サンの書き込みの方法をユビキリします。
(defun (setf slot-attribute) (new-value instance slot-name attribute)
  (setf (cdr (slot-attribute-bucket instance slot-name attribute))
    new-value))
札付きスロット籠係=サンを定義します。
(defun slot-attribute-bucket (instance slot-name attribute)
  (let* ((all-buckets (slot-value instance 'all-attributes))
         (slot-bucket (assoc slot-name all-buckets)))
    (unless slot-bucket
      (error "The slot named ~S of ~S has no attributes."
             slot-name instance))
    (let ((attr-bucket (assoc attribute (cdr slot-bucket))))
      (unless attr-bucket
        (error "The slot named ~S of ~S has no attributes named ~S."
               slot-name instance attribute))
      attr-bucket)))
動作
(let ((foo (make-instance 'foo)))
  (slot-attribute-bucket foo 'a :memo))
;=>  (:MEMO . "aのメモ")
attributes-classでは、、定義したfooのクラス内で属性は共用されますが、そのサブクラスとは共用されないようになっています。
(defclass bar (foo)
  (d)
  (:metaclass kl:attributes-class))

(let ((bar (make-instance 'bar))) (slot-value bar 'all-attributes)) ;=> ((A) (B) (C) (D)) (let ((bar (make-instance 'bar))) (setf (cdr (assoc 'a (slot-value bar 'all-attributes))) (acons :memo2 "bar a メモその2" (list (cons :memo "aのメモ")))) (slot-value bar 'all-attributes)) ;=> ((A (:MEMO2 . "bar a メモその2") (:MEMO . "aのメモ")) (B) (C) (D))

■ という感じにざっと眺めましたが、あまり良く分かっていないので、記述も怪しい感じにしてみました。 ちなみに、ニンジャスレイヤーは、まだ呼んだことがないので、そのうち読んでみたいと思います。 ■

KMRCLを眺める(235) mop.lisp

Posted 2011-11-07 18:49:00 GMT

しばらくブログを書いてないと書くこともまた無くなってしまうのですが、そういう時はライブラリを眺めてたことを思いだしたので、久し振りにKMRCLを眺めてみます。 (前回: KMRCLを眺める(234) repl.lisp) 今回はKMRCLのmop.lispまるごとです。 この mop.lisp は、

;;; This file imports MOP symbols into KMR-MOP packages and then
;;; re-exports them to hide differences in MOP implementations.

とのことなので処理系間のmopの互換性の向上のためのポータビリティレイヤーというところです。最近では、Closer to MOPというプロジェクトがメジャーになりつつあります。 とりあえず、上から順に眺めて行くと、 まず、*features*にkmrcl::処理系-mopという識別シンボルを入れていて、このパッケージの処理に使うようです。
(in-package #:cl-user)

;;;--------------------------------------------------- #+sbcl (eval-when (:compile-toplevel :load-toplevel :execute) (if (find-package 'sb-mop) (pushnew 'kmrcl::sbcl-mop cl:*features*) (pushnew 'kmrcl::sbcl-pcl cl:*features*)))

#+cmu (eval-when (:compile-toplevel :load-toplevel :execute) (if (eq (symbol-package 'pcl:find-class) (find-package 'common-lisp)) (pushnew 'kmrcl::cmucl-mop cl:*features*) (pushnew 'kmrcl::cmucl-pcl cl:*features*)))

;;;----------------------------------- (defpackage #:kmr-mop (:use #:cl #:kmrcl #+kmrcl::sbcl-mop #:sb-mop #+kmrcl::cmucl-mop #:mop #+allegro #:mop #+lispworks #:clos #+clisp #:clos #+scl #:clos #+ccl #:openmcl-mop ) )

#+lispworks (defun intern-eql-specializer (slot) `(eql ,slot))

intern-eql-specializer というのはAMOPで定義されている関数ですが、LispWorksにはないようで、定義があります。 ちなみに、intern-eql-specializer は、EQL-SPECIALIZERメタオブジェクトを返す関数です。
(in-package #:kmr-mop)
(eql (INTERN-EQL-SPECIALIZER 8)
     (INTERN-EQL-SPECIALIZER 8))
;=>  T

(INTERN-EQL-SPECIALIZER 8)
;=>  #<EQL-SPECIALIZER {100C1C2373}>

次の process-class-option、 process-slot-option もLispWorksでなにかするもののようですが、他の処理系ではスルー

(defmacro process-class-option (metaclass slot-name &optional required)
  #+lispworks
  `(defmethod clos:process-a-class-option ((class ,metaclass)
                                           (name (eql ,slot-name))
                                           value)
    (when (and ,required (null value))
      (error "metaclass ~A class slot ~A must have a value" (quote ,metaclass) name))
    (list name `',value))
  #-lispworks
  (declare (ignore metaclass slot-name required))
  )

;;; 同上 (defmacro process-slot-option (metaclass slot-name) #+lispworks `(defmethod clos:process-a-slot-option ((class ,metaclass) (option (eql ,slot-name)) value already-processed-options slot) (list* option `',value already-processed-options)) #-lispworks (declare (ignore metaclass slot-name)) )

ここで、処理系のmop系のパッケージから色々インポート
(eval-when (:compile-toplevel :load-toplevel :execute)
  (shadowing-import
   .......
   ))
そしてエクスポート
(eval-when (:compile-toplevel :load-toplevel :execute)
  (export '(class-of class-name class-slots find-class
            standard-class
            slot-definition-name finalize-inheritance
            standard-direct-slot-definition
            standard-effective-slot-definition validate-superclass
            compute-effective-slot-definition-initargs
            direct-slot-definition-class effective-slot-definition-class
            compute-effective-slot-definition
            slot-value-using-class
            class-prototype generic-function-method-class intern-eql-specializer
            make-method-lambda generic-function-lambda-list
            compute-slots
            class-direct-slots
            ;; KMR-MOP encapsulating macros
            process-slot-option
            process-class-option))
仕事が終ったので、*features*から、先述のシンボルを削除
  #+sbcl
  (if (find-package 'sb-mop)
      (setq cl:*features* (delete 'kmrcl::sbcl-mop cl:*features*))
      (setq cl:*features* (delete 'kmrcl::sbcl-pcl cl:*features*)))

#+cmu (if (find-package 'mop) (setq cl:*features* (delete 'kmrcl::cmucl-mop cl:*features*)) (setq cl:*features* (delete 'kmrcl::cmucl-pcl cl:*features*)))

compute-effective-slot-definition、direct-slot-definition-classの引数が3より少なければ、short-arg-cesd、short-arg-dsdcを*features*に登録するようですが、他のソースでも使っていないようで何に使うのかは不明。
  (when (< (length (generic-function-lambda-list
                     (ensure-generic-function
                      'compute-effective-slot-definition)))
            3)
    (pushnew 'short-arg-cesd cl:*features*))

(when (< (length (generic-function-lambda-list (ensure-generic-function 'direct-slot-definition-class))) 3) (pushnew 'short-arg-dsdc cl:*features*))

) ;; eval-when

以上で、定義は終了。 Closer to MOPと、KMR-MOPの差を調べてみましたが、
(import 'com.informatimago.common-lisp.package:PACKAGE-EXPORTS)
;=>  T

(set-difference  (package-exports :kmr-mop)
                 (package-exports :c2mop)
                 :test #'string=)
;=>  (CLASS-OF COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS CLASS-NAME
;              PROCESS-SLOT-OPTION PROCESS-CLASS-OPTION FIND-CLASS)

となりました。 CLASS-OF、CLASS-NAME、 FIND-CLASS はCLの標準、PROCESS-SLOT-OPTION、PROCESS-CLASS-OPTIONは、KMR-MOPで定義したもの、残る、COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS は、処理系によっては持っているもののようで、スロット定義のINITARGが取得できるようです
(defclass zot ()
  (a b c) )
(finalize-inheritance (find-class 'zot))

(let ((c (find-class 'zot))) (mapcar (lambda (s) (COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS c (list s))) (class-slots c))) ;=> ((:NAME A :INITFORM NIL :INITFUNCTION NIL :INITARGS NIL :ALLOCATION :INSTANCE ; :ALLOCATION-CLASS #<STANDARD-CLASS ZOT> :TYPE T :CLASS #<STANDARD-CLASS ZOT> ; :DOCUMENTATION NIL) ; (:NAME B :INITFORM NIL :INITFUNCTION NIL :INITARGS NIL :ALLOCATION :INSTANCE ; :ALLOCATION-CLASS #<STANDARD-CLASS ZOT> :TYPE T :CLASS #<STANDARD-CLASS ZOT> ; :DOCUMENTATION NIL) ; (:NAME C :INITFORM NIL :INITFUNCTION NIL :INITARGS NIL :ALLOCATION :INSTANCE ; :ALLOCATION-CLASS #<STANDARD-CLASS ZOT> :TYPE T :CLASS #<STANDARD-CLASS ZOT> ; :DOCUMENTATION NIL))

という感じで、久々にKMRCLをつらつら眺めてみましたが、Closer to MOPの方が規模が大きいので、現状では、Closer to MOPを使って互換性を担保するのが吉なのかなというところです。 ■

KMRCLを眺める(234) repl.lisp

Posted 2011-01-08 12:39:00 GMT

今回はKMRCLのrepl.lispまるごとです。
一つ一つの関数をばらして解説というのがちょっと難しそうなのと、それ程長くもない、ということでファイル全体を眺めます。
まず、名前からしてREPLを実現するファイルだろうなということは分かります。
とりあえず上からつらつらと眺めつつ実際に動かしてみます。

定数などの定義

(in-package #:kmrcl)

(defconstant +default-repl-server-port+ 4000)

デフォルトの接続ポートを4000番にしていますが、どうやら外部と通信できるようです。

REPLクラス

(defclass repl ()
  ((listener :initarg :listener :accessor listener
             :initform nil)))
REPLクラスを定義しています。

MAKE-REPL

(defun make-repl (&key (port +default-repl-server-port+)
                       announce user-checker remote-host-checker)
  (make-instance 'listener
    :port port
    :base-name "repl"
    :function 'repl-worker
    :function-args (list user-checker announce)
    :format :text
    :wait nil
    :remote-host-checker remote-host-checker
    :catch-errors nil))
MAKE-REPLというLISTNERのインスタンスを生成するユーティリティを定義していますが、LISTERクラスは、KMRCLのlistener.lispで定義されています。こちらもいつか眺めます。
LISTNERはどうやら通信できることを前提に設定されている様子。

INIT/REPL

(defun init/repl (repl state)
  (init/listener repl state))
INIT/REPLは名前の通りREPLを初期化するものだろうと思われます。
INIT/LISTENERもlistener.lispで定義されています。state引数が謎ですが、定義を辿ってみると、:start、:stop、:restartという引数を取り状態を遷移させるもののようです。

REPL-WORKER

(defun repl-worker (conn user-checker announce)
  (when announce
    (format conn "~A~%" announce)
    (force-output conn))
  (when user-checker
    (let (login password)
      (format conn "login: ")
      (finish-output conn)
      (setq login (read-socket-line conn))
      (format conn "password: ")
      (finish-output conn)
      (setq password (read-socket-line conn))
      (unless (funcall user-checker login password)
        (format conn "Invalid login~%")
        (finish-output conn)
        (return-from repl-worker))))
  #+allegro
  (tpl::start-interactive-top-level
   conn
   #'tpl::top-level-read-eval-print-loop
   nil)
  #-allegro
  (repl-on-stream conn)
  )
REPL-WORKERはLISTENERのFUNCTIONに登録されるものです。接続と、ユーザーチェック(パスワードの確認)の有無、接続時に表示させるアナウンスの内容を取り、一連の処理をした後、REPL-ON-STREAMを呼びます。

READ-SOCKET-LINE

(defun read-socket-line (stream)
  (string-right-trim-one-char #\return
                              (read-line stream nil nil)))
READ-SOCKET-LINEは、REPL-WORKERの中でユーザー名とパスワードを読み取るのに使われています。
STRING-RIGHT-TRIM-ONE-CHARはKMRCLのユーティリティ関数です。

PRINT-PROMPT

(defun print-prompt (stream)
  (format stream "~&~A> " (package-name *package*))
  (force-output stream))
名前の通りプロンプトを表示させるもの。パッケージも表示されるようです。

REPL-ON-STREAM

(defun repl-on-stream (stream)
  (let ((*standard-input* stream)
        (*standard-output* stream)
        (*terminal-io* stream)
        (*debug-io* stream))
    #|
    #+sbcl
    (if (and (find-package 'sb-aclrepl)
             (fboundp (intern "REPL-FUN" "SB-ACLREPL")))
        (sb-aclrepl::repl-fun)
        (%repl))
    #-sbcl
    |#
    (%repl)))
REPL-ON-STREAMは、*standard-input/output*等をストリームに束縛して%REPLを呼ぶというもの。
SBCLの場合は、SB-ACLREPL(SBCLで、Allegro CL風のREPLを実現するもの)を使おうとしたりしているようですが、コメントアウトされています。

%REPL

(defun %repl ()
  (loop
    (print-prompt *standard-output*)
    (let ((form (read *standard-input*)))
      (format *standard-output* "~&~S~%" (eval form)))))
%REPLが実質の本体で、Read-Eval-Print-Loopそのままに、read->eval->format->loopとなっています。

内容は以上ですが、実際に使ってみます。
(require :kmrcl)

(defvar *repl*)

;; REPLインスタンスを生成 (setq *repl* (kl:make-repl :announce "hello!" :port 4001 :user-checker (lambda (user pass) (find (cons user pass) '(("g000001" . "g000001")) :test #'equal)))) ;; 起動 (kl:init/repl *repl* :start)

telnetで接続
setq% rlwrap telnet localhost 4001
Trying ::1...
Trying 127.0.0.1...
Connected to localhost.
Escape character is '^]'.
hello!
login: g000001
password: g000001

COMMON-LISP-USER> (+ 3 3 3 3 )

12 COMMON-LISP-USER>

という感じになります。

KMRCLを眺める(233) REMOVE-SIGNAL-HANDLER

Posted 2011-01-07 10:58:00 GMT

今回はKMRCLのsignals.lispから、REMOVE-SIGNAL-HANDLERです。
前回はハンドラを設定する方でしたが今回は削除する方です。
定義は、

(defun remove-signal-handler (sig &optional old-handler)
  "Removes a handler from signal. Tries, when possible, to restore old-handler."
  (let ((signum (etypecase sig
                  (integer sig)
                  (keyword (signal-key-to-number sig)))))
    ;; allegro automatically restores old handler, because set-signal-handler above
    ;; actually pushes the new handler onto a list of handlers
    #+allegro (declare (ignore old-handler))
    #+allegro (excl:remove-signal-handler signum)
    #+cmu (system:enable-interrupt signum (or old-handler :default))
    ;; lispworks removes handler if old-handler is nil
    #+(and lispworks unix) (system:set-signal-handler signum old-handler)
    #+sbcl (sb-sys:enable-interrupt signum (or old-handler :default))
    #-(or allegro cmu (and lispworks unix) sbcl)
    (declare (ignore sig handler))
    #-(or allegro cmu (and lispworks unix) sbcl)
    (warn "Signal setting not supported on this platform.")))
となっています。
動作は、
;; USR1へのハンドラを設定
(kl:set-signal-handler :usr1
                       (lambda (&rest args)
                         (declare (ignore args))
                         (princ "Hello USR1 !")
                         (terpri)
                         (force-output)))

:DEFAULT * (sb-posix:getpid) 9776

;; 他のシェルから $ kill -USR1 9776

* Hello USR1 ! ;; USR1のハンドラを削除 (kl:remove-signal-handler :usr1) #<CLOSURE (FLET SB-UNIX::RUN-HANDLER) {1003B40C89}> T

;; 他のシェルから $ kill -USR1 9776 * User defined signal 1

というところ

KMRCLを眺める(232) SET-SIGNAL-HANDLER

Posted 2011-01-05 10:54:00 GMT

今回はKMRCLのsignals.lispから、SET-SIGNAL-HANDLERです。
処理系依存で処理系に送られたシグナルをハンドリングする機能があるようですが、それをポータブルに書けるようにしたもののようです。
定義は、

(defun set-signal-handler (sig handler)
  "Sets the handler for a signal to a function. Where possible, returns
the old handler for the function for later restoration with remove-signal-handler
below.

To be portable, signal handlers should use (&rest dummy) function signatures and ignore the value. They should return T to tell some Lisp implementations (Allegro) that the signal was successfully handled." (let ((signum (etypecase sig (integer sig) (keyword (signal-key-to-number sig))))) #+allegro (excl:add-signal-handler signum handler) #+cmu (system:enable-interrupt signum handler) #+(and lispworks unix) ;; non-documented method to get old handler, works in lispworks 5 (let ((old-handler (when (and (boundp 'system::*signal-handler-functions*) (typep system::*signal-handler-functions* 'array)) (aref system::*signal-handler-functions* signum)))) (system:set-signal-handler signum handler) old-handler) #+sbcl (sb-sys:enable-interrupt signum handler) #-(or allegro cmu (and lispworks unix) sbcl) (declare (ignore sig handler)) #-(or allegro cmu (and lispworks unix) sbcl) (warn "Signal setting not supported on this platform.")))

となっていて前回のSIGNAL-KEY-TO-NUMBERが内部で使われています。
長いですが、それぞれの処理系で実質2、3行といったところです。
動作は、
;; USR1へのハンドラを設定
(kl:set-signal-handler :usr1 
                       (lambda (&rest args)
                         (declare (ignore args))
                         (princ "Hello USR1 !")
                         (terpri)
                         (force-output)))
;; プロセスIDを確認
(kl:getpid)
;=> 6269

他のシェル等から $ kill -USR1 6269

;; 処理系が起動しているターミナル等に表示される筈 * Hello USR1 !

というところ

KMRCLを眺める(231) SIGNAL-KEY-TO-NUMBER

Posted 2011-01-03 12:58:00 GMT

strmatch.lispも眺め終えたので、今回はKMRCLのsignals.lispから、SIGNAL-KEY-TO-NUMBERです。
signals.lispはPOSIXのシグナル関係の処理系依存のところを纏めたもののようです。
SIGNAL-KEY-TO-NUMBERは、名前のとおりシグナルの名前から番号に変換するもので定義は、

(defun signal-key-to-number (sig)
  "These signals and numbers are only valid on POSIX systems, perhaps
some are Linux-specific."
  (case sig
    (:hup 1)
    (:int 2)
    (:quit 3)
    (:kill 9)
    (:usr1 10)
    (:usr2 12)
    (:pipe 13)
    (:alrm 14)
    (:term 15)
    (t
     (error "Signal ~A not known." sig))))
となっています。
動作は、
(kl::signal-key-to-number :usr1)
;=> 10
というところ

KMRCLを眺める(230) MULTIWORD-MATCH

Posted 2010-12-04 13:34:00 GMT

今回はKMRCLのstrmatch.lispから、MULTIWORD-MATCHです。
ドキュメント文字列によると、区切り文字や単語の位置には無関係で、大文字小文字も区別しないで文字列に含まれる単語群が同一のものかを判定するようです。
動作は、

(kl:multiword-match "foo        bar   baz" "foo,bar,baz")
;=> T

(kl:multiword-match "***foo/bar/baz**" "FOO,BAZ,bar") ;=> T

(kl:multiword-match "***foo/bar/baz**" "FOO,BAZ,bbb") ;=> NIL

というところ
定義は、
(defun multiword-match (s1 s2)
  "Matches two multiword strings, ignores case, word position, punctuation"
  (let* ((word-list-1 (split-alphanumeric-string s1))
         (word-list-2 (split-alphanumeric-string s2))
         (n1 (length word-list-1))
         (n2 (length word-list-2)))
    (when (= n1 n2)
      ;; remove each word from word-list-2 as walk word-list-1
      (dolist (w word-list-1)
        (let ((p (position w word-list-2 :test #'string-equal)))
          (unless p
            (return-from multiword-match nil))
          (setf (nth p word-list-2) "")))
      t)))
となっています。
SPLIT-ALPHANUMERIC-STRINGが肝ですが、これはKMRCLのもので以前に取り上げています。

KMRCLを眺める(229) SCORE-MULTIWORD-MATCH

Posted 2010-11-26 14:51:00 GMT

xml-utils.lispも眺め終えたので、今回はKMRCLのstrmatch.lispから、SCORE-MULTIWORD-MATCHです。
名前からすると、与えられた引数の文字列の類似度を測定する関数のようです。
定義は、

(defun score-multiword-match (s1 s2)
  "Score a match between two strings with s1 being reference string.
S1 can be a string or a list or strings/conses"
  (let* ((word-list-1 (if (stringp s1)
                          (split-alphanumeric-string s1)
                        s1))
         (word-list-2 (split-alphanumeric-string s2))
         (n1 (length word-list-1))
         (n2 (length word-list-2))
         (unmatched n1)
         (score 0))
    (declare (fixnum n1 n2 score unmatched))
    (decf score (* 4 (abs (- n1 n2))))
    (dotimes (iword n1)
      (declare (fixnum iword))
      (let ((w1 (nth iword word-list-1))
            pos)
        (cond
         ((consp w1)
          (let ((first t))
            (dotimes (i-alt (length w1))
              (setq pos
                (position (nth i-alt w1) word-list-2
                          :test #'string-equal))
              (when pos
                (incf score (- 30
                               (if first 0 5)
                               (abs (- iword pos))))
                (decf unmatched)
                (return))
              (setq first nil))))
         ((stringp w1)
          (kmrcl:awhen (position w1 word-list-2
                               :test #'string-equal)
                       (incf score (- 30 (abs (- kmrcl::it iword))))
                       (decf unmatched))))))
    (decf score (* 4 unmatched))
    score))
となっていますが、どうも自分には、使い方がいまいち不明でした
(kl:score-multiword-match "foo" "foo")
;=> 30

(kl:score-multiword-match '("foo") "foo") ;=> 30

(kl:score-multiword-match '("foo" "foo") "foo") ;=> 55

(kl:score-multiword-match '("foo" "foo" "foo") "foo") ;=> 79

(kl:score-multiword-match '("foo" "foo" "foo" "foo") "foo") ;=> 102

(kl:score-multiword-match '("foo" "foo" "foo" "foa") "foo") ;=> 71

(kl:score-multiword-match '("foo" "fao" "foo" "foa") "foo") ;=> 38

有名なアルゴリズムだったりするのでしょうか。

KMRCLを眺める(228) SGML-HEADER-STREAM

Posted 2010-11-22 13:41:00 GMT

今回はKMRCLのxml-utils.lispから、SGML-HEADER-STREAMです。
名前の通り、SGML系のヘッダを出力するのに使うようです。
定義は、

(defun sgml-header-stream (format stream &key entities (encoding "iso-8859-1") standalone (version "1.0")
                          top-element (availability "PUBLIC") registered organization (type "DTD")
                           label (language "EN") url)
  (when (in format :xhtml :xhtml11 :xhtml10-strict :xhtml10-transitional :xhtml10-frameset :xml :docbook)
    (xml-declaration-stream stream :version version :encoding encoding :standalone standalone))
  (unless (eq :xml format)
    (doctype-format stream format :top-element top-element
                    :availability availability :registered registered
                    :organization organization :type type :label label :language language
                    :url url :entities entities))
  stream)
動作は、
(with-output-to-string (out)
  (kl::sgml-header-stream :xhtml10-transitional
                          out))
;=> "<?xml version=\"1.0\" encoding=\"iso-8859-1\" ?>
;   <!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\" \"http://www.w3.org/TR/xhtml10/DTD/xhtml10-transitional.dtd\">
;   "
といったところ。
ふと気付いたのですが、どうも、一般的には、http://www.w3.org/TR/xhtml10/DTD/xhtml10-transitional.dtdじゃなくて、 http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtdのようなんですが、定義が古かったりするんでしょうか。

KMRCLを眺める(227) DOCTYPE-STREAM

Posted 2010-11-15 12:23:00 GMT

今回はKMRCLのxml-utils.lispから、DOCTYPE-STREAMです。
眺める順番を間違えてしまいましたが、DOCTYPEを作成するためのユーティリティで、ストリームを取って出力するものです。
前回のDOCTYPE-FORMATは内部でこれを利用しています。
定義は、

(defun doctype-stream (stream top-element availability registered organization type
                       label language url entities)
  (format stream "<!DOCTYPE ~A ~A \"~A//~A//~A ~A//~A\"" top-element
          availability (if registered "+" "-") organization type label language)

(when url (write-char #\space stream) (write-char #\" stream) (write-string url stream) (write-char #\" stream))

(when entities (format stream " [~%~A~%]" entities))

(write-char #\> stream) (write-char #\newline stream))

動作は、
(with-output-to-string (out)
  (kl::doctype-stream out
                      "html"
                      "PUBLIC"
                      NIL
                      "W3C"
                      "DTD"
                      "XHTML 1.1"
                      "EN"
                      "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd"
                      NIL))
;=> "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\" \"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\">
;   "
といったところ

KMRCLを眺める(226) DOCTYPE-FORMAT

Posted 2010-11-11 14:51:00 GMT

今回はKMRCLのxml-utils.lispから、DOCTYPE-FORMATです。
名前から大体分かるようにDOCTYPEを作成するためのユーティリティです。
定義は、

(defun doctype-format (stream format &key top-element (availability "PUBLIC")
                       (registered nil) organization (type "DTD") label
                       (language "EN") url entities)
  (case format
    ((:xhtml11 :xhtml)
     (doctype-stream stream "html" availability registered "W3C" type "XHTML 1.1" language
                     (if url url "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd")
                     entities))
    (:xhtml10-strict
     (doctype-stream stream "html" availability registered "W3C" type "XHTML 1.0 Strict" language
                     (if url url "http://www.w3.org/TR/xhtml10/DTD/xhtml10-strict.dtd")
                     entities))
    (:xhtml10-transitional
     (doctype-stream stream "html" availability registered "W3C" type "XHTML 1.0 Transitional" language
                     (if url url "http://www.w3.org/TR/xhtml10/DTD/xhtml10-transitional.dtd")
                     entities))
    (:xhtml-frameset
     (doctype-stream stream "html" availability registered "W3C" type "XHTML 1.0 Frameset" language
                     (if url url "http://www.w3.org/TR/xhtml10/DTD/xhtml10-frameset.dtd")
                     entities))
    (:html2
     (doctype-stream stream "HTML" availability registered "IETF" type "HTML" language url entities))
    (:html3
     (doctype-stream stream "HTML" availability registered "IETF" type "HTML 3.0" language url entities))
    (:html3.2
     (doctype-stream stream "HTML" availability registered "W3C" type "HTML 3.2 Final" language url entities))
    ((:html :html4)
     (doctype-stream stream "HTML" availability registered "W3C" type "HTML 4.01 Final" language url entities))
    ((:docbook :docbook42)
     (doctype-stream stream (if top-element top-element "book")
                     availability registered "OASIS" type "Docbook XML 4.2" language
                     (if url url "http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd")
                     entities))
    (t
     (unless top-element (warn "Missing top-element in doctype-format"))
     (unless organization (warn "Missing organization in doctype-format"))
     (unless label (warn "Missing label in doctype-format"))
     (doctype-stream stream top-element availability registered organization type label language url
                     entities))))
で、色々と条件を指定することができます。
動作は、
(with-output-to-string (out)
  (kl::doctype-format out :xhtml))
;=> "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\" \"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\">
;   "
というところ

KMRCLを眺める(225) XML-DECLARATION-STREAM

Posted 2010-11-10 12:48:00 GMT

今回はKMRCLのxml-utils.lispから、XML-DECLARATION-STREAMです。
名前の通りXMLの宣言を作成するもので定義は、

(defun xml-declaration-stream (stream &key (version "1.0") standalone encoding)
  (format stream "<?xml version=\"~A\"~A~A ?>~%"
          version
          (if encoding
              (format nil " encoding=\"~A\"" encoding)
              ""
              )
          (if standalone
              (format nil " standalone=\"~A\"" standalone)
              "")))
という風。
動作は、
(with-output-to-string (out)
  (kl::xml-declaration-stream out :standalone "yes" :encoding "utf-8"))
;=> "<?xml version=\"1.0\" encoding=\"utf-8\" standalone=\"yes\" ?>
;   "
となっています。

KMRCLを眺める(224) WRITE-CDATA

Posted 2010-11-09 12:35:00 GMT

今回はKMRCLのxml-utils.lispから、WRITE-CDATAです。
定義は、

(defun write-cdata (str s)
  (declare (simple-string str) (optimize (speed 3) (safety 0) (space 0)))
  (do ((len (length str))
       (i 0 (1+ i)))
      ((= i len) str)
    (declare (fixnum i len))
    (let ((c (schar str i)))
      (case c
        (#\< (write-string "&lt;" s))
        (#\& (write-string "&amp;" s))
        (t   (write-char c s))))))
となっていて、単純に"<"や"&"などを、&lt;、&amp;に置き換えるだけのものの様子。
動作は、
(kl:write-cdata "<![CDATA[こんにちは]]>" *standard-output*)
;-> &lt;![CDATA[こんにちは]]>
;=> "<![CDATA[こんにちは]]>"
となっていますが、CDATAセクションの中でCDATAのタグを使うための文字列を生成するというのもちょっとおかしいし、CDATAを表示させるためとしたら、>が置き換えされていないし…、ということでちょっと謎の関数です。
(#\> (write-string "&gt;" s))
が忘れられていたりするんでしょうか。

KMRCLを眺める(223) CDATA-STRING

Posted 2010-11-06 12:46:00 GMT

今回はKMRCLのxml-utils.lispから、CDATA-STRINGです。
動作は、

(kl:cdata-string "<いろはにほへと><ちりぬるを>")
;=> "<![CDATA[<いろはにほへと><ちりぬるを>]]>"
という風。
定義は、単純に
(defun cdata-string (str)
  (concatenate 'string "<![CDATA[" str "]]>"))
となっています。

KMRCLを眺める(222) XML-TAG-CONTENTS

Posted 2010-10-28 11:21:00 GMT

今回はKMRCLのxml-utils.lispから、XML-TAG-CONTENTSです。
前回眺めた、POSITIONS-XML-TAG-CONTENTSを使ってタグの中身を切り出すものです。
動作は、

(kl::xml-tag-contents "foo" "<foo bar=\"1\">hello</foo>")
;⇒ "hello", 24, ("bar=\"1\"")
定義は、
(defun xml-tag-contents (tag xmlstr &optional (start-xmlstr 0)
                         (end-xmlstr (length xmlstr)))
  "Returns two values: the string between XML start and end tag
and position of character following end tag."
  (multiple-value-bind
      (startpos endpos nextpos attributes)
      (positions-xml-tag-contents tag xmlstr start-xmlstr end-xmlstr)
    (if (and startpos endpos)
        (values (subseq xmlstr startpos endpos) nextpos attributes)
      (values nil nil nil))))
となっています。

KMRCLを眺める(221) POSITIONS-XML-TAG-CONTENTS

Posted 2010-10-25 11:40:00 GMT

今回はKMRCLのxml-utils.lispから、POSITIONS-XML-TAG-CONTENTSです。
定義は、

(defun positions-xml-tag-contents (tag xmlstr &optional (start-xmlstr 0)
                                       (end-xmlstr (length xmlstr)))
  "Returns three values: the start and end positions of contents between
 the xml tags and the position following the close of the end tag."
  (let* ((taglen (length tag)))
    (multiple-value-bind (start attributes)
        (find-start-tag tag taglen xmlstr start-xmlstr end-xmlstr)
      (unless start
        (return-from positions-xml-tag-contents (values nil nil nil nil)))
      (let ((end (find-end-tag tag taglen xmlstr start end-xmlstr)))
        (unless end
          (return-from positions-xml-tag-contents (values nil nil nil nil)))
        (values start end (+ end taglen 3) attributes)))))
となっていますが、前回、前々回に眺めた、FIND-START-TAG、FIND-END-TAGを使ってタグに囲まれた中身の開始と終了の位置を切り出している様子。
最初に開始タグの検出、不備があれば脱出、次に終了タグの検出/脱出、開始/終了タグともに問題なければ位置を多値で返す、という風。
動作は、
(kl::positions-xml-tag-contents "foo" "<foo bar=\"1\">hello</foo>")
;⇒ 13, 18, 24, ("bar=\"1\"")

;; 開始タグ不備 (kl::positions-xml-tag-contents "foo" "foo>hello</foo>") ;⇒ NIL, NIL, NIL, NIL

;; 終了タグ不備 (kl::positions-xml-tag-contents "foo" "<foo>hello</foo") ;⇒ NIL, NIL, NIL, NIL

となっています。

KMRCLを眺める(220) FIND-END-TAG

Posted 2010-10-22 09:46:00 GMT

今回はKMRCLのxml-utils.lispから、FIND-END-TAGです。
動作は、

(kmrcl::find-end-tag "foo" 3 "<foo>hello</foo>" 5 16)
;⇒ 10
という感じで前回のFIND-START-TAGの対で終了タグの開始位置を返すものです。
定義は、
(defun find-end-tag (tag taglen xmlstr start end)
  (fast-string-search
   (concatenate 'string "</" tag ">") xmlstr
   (+ taglen 3) start end))
というところ。
簡単に標準の関数で書けば、
(defun find-end-tag (tag taglen xmlstr start end)
  (declare (ignore taglen))
  (search (concatenate 'string "</" tag ">")
          xmlstr
          :start2 start :end2 end ))
というところでしょうか。

KMRCLを眺める(219) FIND-START-TAG

Posted 2010-10-21 12:16:00 GMT

今回はKMRCLのxml-utils.lispから、FIND-START-TAGです。
動作は、

(kl::find-start-tag "foo" 3 "1234<foo bar=\"foo\">hello</foo>" 0 30)
;⇒ 19, ("bar=\"foo\"")
という感じですが、タグの中身の開始位置と存在すれば属性を抜き出すもののようです。
以前眺めたstrings.lispの流れからすると最適化された下請け関数と思われます。
実装は最適化のため若干読みにくくなっていますが、ループしながら目的のものを切り出してゆくという感じです
(defun find-start-tag (tag taglen xmlstr start end)
  "Searches for the start of a tag in an xmlstring. Returns STARTPOS ATTRIBUTE-LIST)"
  (declare (simple-string tag xmlstr)
           (fixnum taglen start end)
           (optimize (speed 3) (safety 0) (space 0)))
  (do* ((search-str (concatenate 'string "<" tag))
        (search-len (1+ taglen))
        (bracketpos (fast-string-search search-str xmlstr search-len start end)
                    (fast-string-search search-str xmlstr search-len start end)))
       ((null bracketpos) nil)
    (let* ((endtag (+ bracketpos 1 taglen))
           (char-after-tag (schar xmlstr endtag)))
      (when (or (char= #\> char-after-tag)
                (char= #\space char-after-tag))
        (if (char= #\> char-after-tag)
            (return-from find-start-tag (values (1+ endtag) nil))
            (let ((endbrack (position-char #\> xmlstr (1+ endtag) end)))
              (if endbrack
                  (return-from find-start-tag
                    (values (1+ endbrack)
                            (string-to-list-skip-delimiter
                             (subseq xmlstr endtag endbrack))))
                  (values nil nil)))))
      (setq start endtag))))

KMRCLを眺める(218) CDATA-STRING

Posted 2010-10-20 13:09:00 GMT

processes.lispも眺め終えてしまったので、今回から、xml-utils.lispです。
ということで、今回はKMRCLのxml-utils.lispから、CDATA-STRINGです。
定義は、

(defun cdata-string (str)
  (concatenate 'string "<![CDATA[" str "]]>"))
となっている通り、ずばりCDATAセクションな文字列を簡便に作成するためのものです。
動作は、
(kl::cdata-string "今回のでそれが良くわかったよ>>199感謝")
;⇒ "<![CDATA[今回のでそれが良くわかったよ>>199感謝]]>"

KMRCLを眺める(217) PROCESS-SLEEP

Posted 2010-10-19 12:12:00 GMT

今回はKMRCLのprocesses.lispから、PROCESS-SLEEPです。
普通のSLEEPと何が違うのかなという感じですが、Allegro CLのマニュアルにあるPROCESS-SLEEPを眺める限りでは、マルチプロセス用のSLEEPのようです。

(defun process-sleep (n)
  #+allegro (mp:process-sleep n)
  #-allegro (sleep n))
ということで処理系によっては、SLEEPと変りませんが、一応…
(defun hello-sleep-3 ()
  (loop :repeat 3
        :do (princ "Hello")
            (terpri)
            (kl::process-sleep 3)))

(hello-sleep-3) ;→ Hello ;→ Hello ;→ Hello ;⇒ NIL


KMRCLを眺める(216) WITH-TIMEOUT

Posted 2010-10-18 11:27:00 GMT

今回はKMRCLのprocesses.lispから、WITH-TIMEOUTです。
指定された時間中でボディの中身を実行し、タイムアウトになったら中止する、というものです。
定義は、

(defmacro with-timeout ((seconds) &body body)
  #+allegro
  `(mp:with-timeout (,seconds) ,@body)
  #+cmu
  `(mp:with-timeout (,seconds) ,@body)
  #+sb-thread
  `(sb-ext:with-timeout ,seconds ,@body)
  #+openmcl
  `(ccl:process-wait-with-timeout "waiting"
                                 (* ,seconds ccl:*ticks-per-second*)
                                 #'(lambda ()
                                     ,@body) nil)
  #-(or allegro cmu sb-thread openmcl)
  `(progn ,@body)に
  )
となっています。
Allegro CL等では、
;; Allegro CL
(defvar *out* #. *standard-output*)

(kl::with-timeout (3) (loop :for i :from 0 :do (format *out* "Hello ~D~%" i) (sleep 2))) ;→ Hello 0 ;→ Hello 1 ;⇒ NIL

というように上手く動きますが、SBCLだとTIMEOUTというコンディションを発生させるので、
;; SBCL
(handler-case 
    (kl::with-timeout (3)
      (loop :for i :from 0
            :do (format *out* "Hello ~D~%" i)
                (sleep 2)))
  (sb-ext:timeout () "時既に時間切れ"))
;→ Hello 0
;→ Hello 1
;⇒ "時既に時間切れ"
と書くようです。
これが書かれた当時は、SBCLもAllegro CLのように書けたのか、最初から統一されていないのかは謎です。

KMRCLを眺める(215) WITH-LOCK-HELD

Posted 2010-10-15 14:45:00 GMT

今回はKMRCLのprocesses.lispから、WITH-LOCK-HELDです。
ボディの中身が指定したロックが有効になった状態で実行されるというものです。
定義は、

(defmacro with-lock-held ((lock) &body body)
  #+allegro
  `(mp:with-process-lock (,lock) ,@body)
  #+cmu
  `(mp:with-lock-held (,lock) ,@body)
  #+lispworks
  `(mp:with-lock (,lock) ,@body)
  #+sb-thread
  `(sb-thread:with-recursive-lock (,lock) ,@body)
  #+openmcl
  `(ccl:with-lock-grabbed (,lock) ,@body)
  #-(or allegro cmu lispworks sb-thread openmcl)
  `(progn ,@body)
  )
となっています。
命名については、各処理系で割とばらばらですが、KMRCLでは今回もCMUCLに沿っているようです。
動作は、前回と同じ例ですが、
(defvar *out* #.*standard-output*)

;; ロックなし (let ((x 0)) (defun inc () (print x *out*) (sleep (/ (random 8) 10)) (incf x)))

;; ロックあり (let ((lock (kl::make-lock "inc")) (x 0)) (defun inc-with-lock () (kl::with-lock-held (lock) (print x *out*) (sleep (/ (random 8) 10)) (incf x))))

;; ロックなし (dotimes (i 10) (kl::make-process (string (gensym)) #'inc)) ;→ 0 0 0 0 0 0 1 1 1 ;⇒ NIL

;; ロックあり with-lock-held+mutex (dotimes (i 10) (kl::make-process (string (gensym)) #'inc-with-lock)) ;→ 0 1 2 3 4 5 6 7 8 9 ;⇒ NIL

というところ

KMRCLを眺める(214) MAKE-LOCK

Posted 2010-10-14 14:50:00 GMT

今回はKMRCLのprocesses.lispから、MAKE-LOCKです。
定義は、

(defun make-lock (name)
  #+allegro (mp:make-process-lock :name name)
  #+cmu (mp:make-lock name)
  #+lispworks (mp:make-lock :name name)
  #+sb-thread (sb-thread:make-mutex :name name)
  #+openmcl (ccl:make-lock name)
  )
となっていて、各処理系のlockのラッパーになっています。やはり命名は、CMUCL方式の様子。
動作は、
(kl::make-lock "foo")
;⇒ #S(SB-THREAD:MUTEX :NAME "foo" :%OWNER NIL :STATE 0)
;; lockなし
(let ((x 0))
  (defun inc ()
    (print x)
    (sleep (/ (random 8) 10))
    (incf x)))

;; lock付き (let ((lock (kl::make-lock "inc")) (x 0)) (defun inc-with-lock () (sb-thread:with-mutex (lock) (print x) (sleep (/ (random 8) 10)) (incf x))))

;; lockなし (loop :repeat 10 :do (kl::make-process (string (gensym)) (lambda (&aux (*standard-output* #.*standard-output*)) (inc)))) ;-> 0 0 0 0 0 0 1 1 1 ;⇒ NIL

;; lock使用 (loop :repeat 10 :do (kl::make-process (string (gensym)) (lambda (&aux (*standard-output* #.*standard-output*)) (inc-with-lock)))) ;-> 0 1 2 3 4 5 6 7 8 9 ;⇒ NIL

というところでしょうか。あまり定番の書き方が分かってないですが…。

KMRCLを眺める(213) DESTROY-PROCESS

Posted 2010-10-13 14:03:00 GMT

今回はKMRCLprocesses.lispから、DESTROY-PROCESSです。
定義は、

(defun destroy-process (process)
  #+cmu (mp:destroy-process process)
  #+allegro (mp:process-kill process)
  #+sb-thread (sb-thread:destroy-thread process)
  #+lispworks (mp:process-kill process)
  #+openmcl (ccl:process-kill process)
  )
となっていてスレッドを殺す関数のラッパーです。やはり命名はCMUCLに合せているようです。
眺めてみるにPROCESS-KILLという名前も定番のようですね。
動作は、SBCLべったりですが、
(kl::make-process "sleep 999"
                  (lambda () (sleep 999)))
;⇒ #<SB-THREAD:THREAD "sleep 999" RUNNING {1011CDDC61}>

(sb-thread:list-all-threads) ;⇒ (#<SB-THREAD:THREAD "worker" RUNNING {1011DEC001}> ; #<SB-THREAD:THREAD "sleep 999" RUNNING {1011CDDC61}> ; #<SB-THREAD:THREAD "repl-thread" RUNNING {1011A9DE91}> ; #<SB-THREAD:THREAD "auto-flush-thread" RUNNING {1011A9DC21}> ; #<SB-THREAD:THREAD "reader-thread" RUNNING {1011425161}> ; #<SB-THREAD:THREAD "control-thread" RUNNING {1011423EE1}> ; #<SB-THREAD:THREAD "Swank 4005" RUNNING {101132EDF1}> ; #<SB-THREAD:THREAD "initial thread" RUNNING {10110E3BB1}>)

(find "sleep 999" (sb-thread:list-all-threads) :test #'string= :key #'sb-thread:thread-name) ;⇒ #<SB-THREAD:THREAD "sleep 999" RUNNING {1011C24351}>

;; スレッドを名前で見付けてDESTROY-PROCESS (kl::destroy-process (find "sleep 999" (sb-thread:list-all-threads) :test #'string= :key #'sb-thread:thread-name)) ;⇒ NIL

(sb-thread:list-all-threads) ;⇒ (#<SB-THREAD:THREAD "worker" RUNNING {1011EEE271}> ; #<SB-THREAD:THREAD "repl-thread" RUNNING {1011A9DE91}> ; #<SB-THREAD:THREAD "auto-flush-thread" RUNNING {1011A9DC21}> ; #<SB-THREAD:THREAD "reader-thread" RUNNING {1011425161}> ; #<SB-THREAD:THREAD "control-thread" RUNNING {1011423EE1}> ; #<SB-THREAD:THREAD "Swank 4005" RUNNING {101132EDF1}> ; #<SB-THREAD:THREAD "initial thread" RUNNING {10110E3BB1}>)

というところ。

KMRCLを眺める(212) MAKE-PROCESS

Posted 2010-10-12 14:24:00 GMT

console.lispも眺め終えたので、今回からKMRCLのprocesses.lispを眺めます。
processes.lisp処理系依存のマルチスレッド/プロセス系関数のラッパーを集めたもののようです。
ということで、今回は、make-processです。
定義は、

(defun make-process (name func)
  #+allegro (mp:process-run-function name func)
  #+cmu (mp:make-process func :name name)
  #+lispworks (mp:process-run-function name nil func)
  #+sb-thread (sb-thread:make-thread func :name name)
  #+openmcl (ccl:process-run-function name func)
  #-(or allegro cmu lispworks sb-thread openmcl) (funcall func)
  )
となっていますが、命名はどうやらCMUCLに合せた様子。
PROCESS-RUN-FUNCTIONという名前も多いようですが、CLでは処理系依存なものでも大体同じ名前とインターフェイスで提供されていることが多い気がします。
過去に同様の機能をLispマシン等が提供していた場合は、それを踏襲することも多いようです。
動作は、
(kl::make-process "hello" 
                  (lambda (&aux (*standard-output* #.*standard-output*))
                    (print "hello!")))
;→ "hello!" 
;⇒ #<SB-THREAD:THREAD "hello" FINISHED values: "hello!" {1011C39CC1}>
というところ。

KMRCLを眺める(211) FIXME

Posted 2010-10-07 11:33:00 GMT

今回は、KMRCLのconsole.lispからFIXMEです。
FIXMEやXXXはコメントの中でお馴染ですが、そのFIXMEを(ログに)出力するもののようです。
定義はこれまでの、CMSG等と同じ感じで

(defun fixme (template &rest args)
  "Format output to console"
  (setq template (concatenate 'string "~&;; ** FIXME ** " template "~%"))
  (apply #'format t template args)
  (values))
となっています。
動作は
(kl:fixme "now")
;→ ;; ** FIXME ** now
といったところ。
なんでもCLで書いてるとこういうのも必要になってくるんでしょうね。

KMRCLを眺める(210) CMSG-REMOVE

Posted 2010-10-04 14:30:00 GMT

今回は、KMRCLのconsole.lispからCMSG-REMOVEです。
前回のCMSG-ADDの逆で、*CONSOLE-MSGS-TYPES*から指定したものを登録を削除するもの

(defun cmsg-remove (condition)
  (setf *console-msgs-types* (remove condition *console-msgs-types*)))
動作は、
kl::*console-msgs-types*
;⇒ (:DEBUG)

(kl:cmsg-remove :debug) ;=> NIL

kl::*console-msgs-types* ;=> NIL

というところ。
elispを書く時なども、こういう風にインターフェイスを考えてみると書いたりすると良いLISP入門になるかもと思いました。
;; elisp
(add-to-list "foo/bar/baz" 'load-path)
ではなく、
(pushnew-load-path "foo/bar/baz")
にしてみるとか。…あまりピンとくる例にもなってないですね。

KMRCLを眺める(209) CMSG-ADD

Posted 2010-10-02 15:02:00 GMT

今回は、KMRCLのconsole.lispからCMSG-ADDです。
前回のCMSG-Cでは、*CONSOLE-MSGS-TYPES*にメッセージを出力する状況のタイプをリストで格納していましたが、そのリストを操作するための関数のようです。
*CONSOLE-MSGS-TYPES*を直接SETQやPUSHしたりはせず、インターフェイスを設けるということですね。

(defun cmsg-add (condition)
  (pushnew condition *console-msgs-types*))
動作は、
kl::*console-msgs-types*
;=> NIL

(kl:cmsg-add :debug) ;=> (:DEBUG)

というところ。

KMRCLを眺める(208) CMSG-C

Posted 2010-10-01 14:36:00 GMT

今回は、KMRCLのconsole.lispからCMSG-Cです。
前回のCMSGを一捻りしたもののようで定義は、

(defvar *console-msgs-types* nil)

(defun cmsg-c (condition template &rest args) "Push CONDITION keywords into *console-msgs-types* to print console msgs for that CONDITION. TEMPLATE and ARGS function identically to (format t TEMPLATE ARGS) " (when (or (member :verbose *console-msgs-types*) (member condition *console-msgs-types*)) (apply #'cmsg template args)))

となっていて、*CONSOLE-MSGS-TYPES*にメッセージを出力する状況のタイプをリストで格納して置いて、CMSG-Cの引数にそのタイプが指定されていた場合は、出力、そうでなければスルーというもののようです。
動作は、
(let ((kl::*console-msgs-types* '(:debug)))
  (kl:cmsg-c :debug "~37@{*~}" t)
  (kl:cmsg-c :debug "~37:@<~A~>" "蟲取り")
  (kl:cmsg-c :debug "~37@{*~}" t))
;=> NIL
;->
;; *************************************
;;                  蟲取り                 
;; *************************************
というところ。
:verboseは予め組込まれています。
しかし、なんとなく微妙な使い勝手に感じました…。
ちなみに、FORMATの引数の"~37@{*~}"というのは、@t33fさんに教えて頂きました。ありがとうございます!

KMRCLを眺める(207) CMSG

Posted 2010-09-28 14:24:00 GMT

random.lispも眺め終えたので、今回は、KMRCLのconsole.lispからCMSGです。
console.lispはその名の通りコンソールでなにかするため(主にログを出力したり)のユーティリティの用です。
CMSGの定義は、

(defvar *console-msgs* t)

(defun cmsg (template &rest args) "Format output to console" (when *console-msgs* (setq template (concatenate 'string "~&;; " template "~%")) (apply #'format t template args)))

となっていて、*CONSOLE-MSGS*の値で出力したりしなかったりを制御できるようにしてあり、あとは先頭にコメントの;; を付けるというシンプルなものです。
(kl:cmsg "Hello, World!")
->
;; Hello, World!
FORMATに投げているので、FORMATのオプションも色々使えます。
(progn
  (kl:cmsg "~37,,,'*A" "")
  (kl:cmsg "~37:@<~A~>" "Hello, World!")
  (kl:cmsg "~37,,,'*A" ""))
;⇒ NIL
;->
;; *************************************
;;             Hello, World!            
;; *************************************
こういう風にFORMATに丸投げする際には、オプションも渡せるようにしてFORMATの高機能を生かすというパターンは良くみかける気がします。

KMRCLを眺める(206) RANDOM-CHOICE

Posted 2010-09-26 13:39:00 GMT

今回は、KMRCLのrandom.lispからRANDOM-CHOICEです。
使い方は、マクロ展開してみると分かりやすいですが、

(kl:random-choice 1 2 3 4 5)
;%=>
(CASE (RANDOM 5)
  (0 1)
  (1 2)
  (2 3)
  (3 4)
  (4 5))
となっていて、引数の式をランダムに選択して実行するというのが良くわかります。
定義は、
(defmacro random-choice (&rest exprs)
  `(case (random ,(length exprs))
     ,@(let ((key -1))
         (mapcar #'(lambda (expr)
                     `(,(incf key) ,expr))
                 exprs))))
となっています。
MAPCARの中で副作用のあるINCFしてるのがちょっと気持ち悪い…という人もいそうです。
自分なら
(defmacro random-choice (&rest exprs)
  `(case (random ,(length exprs))
     ,@(loop :for i :from 0
             :for e :in exprs
             :collect (list i e))))
みたいに書くかもしれません。まあ、Schemeではなくて、CLの話なので趣味の問題ではありますが…。

このブログのKMRCLのエントリーをSLIMEから検索する(2)

Posted 2010-09-12 15:30:00 GMT

anything.elとの連携は、日付をまたいで次のエントリーにしよう(LISP365のため)と思っていたのですが、そんな風にぼーっとしている間に d:id:kitokitoki さんに光速でanything.elのソースを作って頂けました!
- (http://d.hatena.ne.jp/kitokitoki/20100912/p2)
同じものを載せるわけにも行かないので、ちょっと機能を追加しましたw
+(setq anything-c-source-なんとか)というのがどうも馴染めないのでdefanythingというマクロを書きました。
+Googleソースコード検索もおまけで付けました
defanythingは、define-anything-c-sourceのようにanything-c-sourceに限定した方が良いかもしれないですね。
anything側で絞りこまないで外に丸投げする方法が分からなかったので、anything-inputの中身を読むようにしたんですが、これで良いんでしょうか。
thing-at-pointで拾えないときは候補に出ないんですよね…。まあ良いか。
こうなったら
-(http://lispdoc.com/)
-(http://weitz.de/cl-ppcre/)
-(http://l1sp.org/html/)
-(http://www.lisp.org/mop/index.html)
-(http://www.cliki.net/)
-(http://common-lisp.net/project/bknr/static/lmman/frontpage.html)
-(http://www.maclisp.info/)
等、あらゆる物を検索対象にしたいですね。

;; Emacs lisp
(defmacro unless-defined (def name args &rest body)
  (unless (fboundp name)
    `(,def ,name ,args ,@body)))

(unless-defined defun mkstr (&rest args) "writes args into a string and returns that string" (apply #'concat (mapcar (lambda (x) (format "%s" x)) args))) (unless-defined defun symb (&rest args) "creates a new symbol from args" (intern (apply #'mkstr args)))

(unless-defined defun cl-symbol-name (symbol-or-name) (let* ((name (format "%s" symbol-or-name)) (pos (search ":" name :from-end t))) (substring name (if pos (1+ pos) 0))))

(defmacro* defanything ((name type) &rest source) `(setq ,(symb "anything-" type "-" name) ',(mapcar (lambda (x) (cons (car x) (cadr x))) source)))

(defun google-code-search-lisp-lookup (symbol-name) "シンボルをGoogle Codeで検索(lisp決め打ち)" (interactive) (browse-url (format "http://www.google.com/codesearch?q=%s\\++lang:%s+file:\\.%s$&hl=ja&num=20" symbol-name "lisp" "lisp")))

(eval-after-load "anything" '(progn (defanything (hyperspec c-source) (name "Lookup Hyperspec") (candidates (lambda () (let ((symbols () )) (mapatoms #'(lambda (sym) (push (symbol-name sym) symbols)) common-lisp-hyperspec-symbols) symbols))) (action (("Show Hyperspec" . hyperspec-lookup))))

(defanything (cltl2 c-source) (name "Lookup CLtL2") (candidates (lambda () (let ((symbols () )) (mapatoms #'(lambda (sym) (push (symbol-name sym) symbols)) cltl2-symbols) symbols))) (action (("Show CLTL2" . cltl2-lookup))))

(defanything (g000001-kmrcl c-source) (name "Lookup G000001-KMRCL") (candidates (lambda () (let ((symbols () )) (mapatoms #'(lambda (sym) (push (symbol-name sym) symbols)) g000001-kmrcl-symbols) symbols))) (action (("Show G000001-KMRCL" . g000001-kmrcl-lookup))))

(defanything (google-code-search-lisp-lookup c-source) (name "Google Code Search (LISP)") (candidates (lambda () (list anything-input))) ;anything-input (action (("Google Code Search (LISP)" . google-code-search-lisp-lookup))))

(defun anything-cl-lookup () (interactive) (anything (list anything-c-source-hyperspec anything-c-source-google-code-search-lisp-lookup anything-c-source-cltl2 anything-c-source-g000001-kmrcl ) (cl-symbol-name (thing-at-point 'symbol))))))

(define-key slime-mode-map [(control ?c) (control ?d) ?l] 'anything-cl-lookup)


このブログのKMRCLのエントリーをSLIMEから検索する

Posted 2010-09-12 12:12:00 GMT

今日、(http://d.hatena.ne.jp/kitokitoki/20100912/p1)を読んでいて、cltl2.elが割と力技で作られていることを思い出しました。
そして力技で良いんだったら、このブログのKMRCLを読むエントリーも引けるようになるんじゃないか、ということで、誰得なelispを書いてみました。
- (http://github.com/g000001/g000001-kmrcl)
誰得ついでにanythingのソースも作成中です。

KMRCLを眺める(204) GENERALIZED-EQUAL

Posted 2010-09-10 14:05:00 GMT

今回は、KMRCLのequal.lispからGENERALIZED-EQUALです。
GENERALIZED-EQUALは、これまで眺めたequal.lispで定義されている関数群の集大成です。
定義は、

(defun generalized-equal (obj1 obj2)
  (if (not (equal (type-of obj1) (type-of obj2)))
      (progn
        (terpri)
        (describe obj1)
        (describe obj2)
        nil)
    (typecase obj1
      (double-float
       (let ((diff (abs (/ (- obj1 obj2) obj1))))
         (if (> diff (* 10 double-float-epsilon))
             nil
           t)))
      (complex
       (and (generalized-equal (realpart obj1) (realpart obj2))
            (generalized-equal (imagpart obj1) (imagpart obj2))))
      (structure-object
       (generalized-equal-fielded-object obj1 obj2))
      (standard-object
       (generalized-equal-fielded-object obj1 obj2))
      (hash-table
       (generalized-equal-hash-table obj1 obj2))
      (function
       (generalized-equal-function obj1 obj2))
      (string
       (string= obj1 obj2))
      (array
       (generalized-equal-array obj1 obj2))
      (t
       (equal obj1 obj2)))))
となっていて、それぞれの型に応じて切り分けられています。
型が一致していなかった時にDESCRIBEしてみせるというのが面白いですね。
動作は、
(KL:GENERALIZED-EQUAL 'CL:PROGN 1)
;->
COMMON-LISP:PROGN
  [symbol]

PROGN names a special operator: Lambda-list: (&REST FORMS) Documentation: PROGN form*

Evaluates each FORM in order, returning the values of the last form. With no forms, returns NIL. Source file: SYS:SRC;COMPILER;IR1-TRANSLATORS.LISP

Symbol-plist: LTD::CVT-FN -> #<FUNCTION (LAMBDA (EXP)) {1000.. CL-IRREGSEXP::SIMPLIFIER -> #S(CL-IRREGSEXP::SIMPLIFIER.. SERIES::SCAN-TEMPLATE -> (SERIES::Q . #1=(SERIES::E . #1.. SB-WALKER::WALKER-TEMPLATE -> (NIL SB-WALKER::REPEAT (EVAL)) 1 [fixnum]

というところ。
総じて言えることとしてはGENERALIZED-EQUAL-FUNCTIONが処理系によっては上手く機能しないというのが残念ですね。

KMRCLを眺める(203) STRUCTURE-SLOT-NAMES

Posted 2010-09-09 04:18:00 GMT

今回は、KMRCLのequal.lispからSTRUCTURE-SLOT-NAMESです。
クラスのスロット名を取得するものは眺めましたが、今回は構造体用の物です。
定義は、

(defun structure-slot-names (s-name) "Given a STRUCTURE-NAME, returns a list of the slots in the structure." #+allegro (class-slot-names s-name) #+lispworks (structure:structure-class-slot-names (find-class s-name)) #+(or sbcl cmu) (mapcar #'kmr-mop:slot-definition-name (kmr-mop:class-slots (kmr-mop:find-class s-name))) #+scl (mapcar #'kernel:dsd-name (kernel:dd-slots (kernel:layout-info (kernel:class-layout (find-class s-name))))) #+(and mcl (not openmcl)) (let* ((sd (gethash s-name ccl::%defstructs%)) (slots (if sd (ccl::sd-slots sd)))) (mapcar #'car (if (symbolp (caar slots)) slots (cdr slots)))) #-(or allegro lispworks cmu sbcl scl (and mcl (not openmcl))) (declare (ignore s-name)) #-(or allegro lispworks cmu sbcl scl (and mcl (not openmcl))) (error "structure-slot-names is not defined on this platform") )

となっているのですが、#+(or sbcl cmu)では CLASS-SLOT-NAMES と同一の定義です。
動作は、
(DEFSTRUCT FOO X Y Z)

(KL::STRUCTURE-SLOT-NAMES 'FOO) ;⇒ (X Y Z)

しかし、折角定義されているこの関数ですが、どこからも呼ばれていないのが謎です。
CLASS-SLOT-NAMESで間に合ってしまうということなのでしょうか。

KMRCLを眺める(202) GENERALIZED-EQUAL-FIELDED-OBJECT

Posted 2010-09-08 03:51:00 GMT

今回は、KMRCLのequal.lispからGENERALIZED-EQUAL-FIELDED-OBJECTです。
今回も、名前からしてクラス/構造体の同値性を判定するものと思われます。
定義は、

(defun generalized-equal-fielded-object (obj1 obj2)
  (block test
    (when (not (equal (class-of obj1) (class-of obj2)))
      (return-from test nil))
    (dolist (field (class-slot-names (class-name (class-of obj1))))
      (unless (generalized-equal (slot-value obj1 field) (slot-value obj2 field))
        (return-from test nil)))
    (return-from test t)))
+CLASS-OF でクラスを判定して一致していなかったら脱出
+次に前回眺めたCLASS-SLOT-NAMESで各スロットの名前をとりだし、SLOT-VALUEで取り出した値を再帰的にGENERALIZED-EQUALですべてを比較
という感じでしょうか。
動作は、
(DEFSTRUCT FOO X Y Z)

(DEFCLASS BAR () ((A :INITARG :A) (B :INITARG :B) (C :INITARG :C)))

(KL::GENERALIZED-EQUAL-FIELDED-OBJECT (MAKE-FOO :X 1 :Y 2 :Z 3) (MAKE-FOO :X 1 :Y 2 :Z 3)) ;⇒ T

(KL::GENERALIZED-EQUAL-FIELDED-OBJECT (MAKE-INSTANCE 'BAR :A 1 :B 2 :C 3) (MAKE-INSTANCE 'BAR :A 1 :B 2 :C 4)) ;⇒ NIL

というところ。

KMRCLを眺める(201) CLASS-SLOT-NAMES

Posted 2010-09-07 13:21:00 GMT

今回は、KMRCLのequal.lispからCLASS-SLOT-NAMESです。
名前からするとクラスのスロット(他の言語でいうメンバー変数のことをLISP系ではスロットと呼ぶ)の名前を取得するもののようです。

(defun class-slot-names (c-name)
  "Given a CLASS-NAME, returns a list of the slots in the class."
  #+(or allegro cmu lispworks sbcl scl)
  (mapcar #'kmr-mop:slot-definition-name
          (kmr-mop:class-slots (kmr-mop:find-class c-name)))
  #+(and mcl (not openmcl))
  (let* ((class (find-class c-name nil)))
    (when (typep class 'standard-class)
      (nconc (mapcar #'car (ccl:class-instance-slots class))
             (mapcar #'car (ccl:class-class-slots class)))))
  #-(or allegro lispworks cmu sbcl scl (and mcl (not openmcl)))
  (declare (ignore c-name))
  #-(or allegro lispworks cmu sbcl scl (and mcl (not openmcl)))
  (error "class-slot-names is not defined on this platform")
  )
定義の内容としては、
(MAPCAR #'closer-mop:SLOT-DEFINITION-NAME 
        (closer-mop:CLASS-SLOTS (FIND-CLASS 'FOO)))
というのが本体で、MOPの領域になりますが、
+FIND-CLASSでCLASSを取り出して
+CLASS-SLOTSでSLOTを取り出して(リスト)
+SLOT-DEFINITION-NAMEで名前を得る
という感じです。
動作は、
(DEFSTRUCT FOO X Y Z)
(KL::CLASS-SLOT-NAMES 'FOO)
;⇒ (X Y Z)

(DEFCLASS BAR () (A B C))

(CLOSER-MOP:FINALIZE-INHERITANCE (FIND-CLASS 'BAR))

(KL::CLASS-SLOT-NAMES 'FOO) ;⇒ (A B C)

というところ

KMRCLを眺める(200) GENERALIZED-EQUAL-HASH-TABLE

Posted 2010-09-06 13:21:00 GMT

今回は、KMRCLのequal.lispからGENERALIZED-EQUAL-HASH-TABLEです。
KMRCLを眺めつづけてとうとう200回になってしまいました。まだ残りは結構あります…。
今回も引き続きで、名前からしてハッシュテーブルの同値性を判定するものと思われます。
定義は、

(defun generalized-equal-hash-table (obj1 obj2)
  (block test
    (when (not (= (hash-table-count obj1) (hash-table-count obj2)))
      (return-from test nil))
    (maphash
     #'(lambda (k v)
         (multiple-value-bind (value found) (gethash k obj2)
           (unless (and found (generalized-equal v value))
             (return-from test nil))))
     obj1)
    (return-from test t)))
HASH-TABLE-COUNT でサイズを勘定して比較し同じでないなら脱出。サイズが同じなら今度は再帰的にハッシュの要素について GENERALIZED-EQUAL で判定、ということで前回のGENERALIZED-EQUAL-ARRAYと同じ構成です。
(LET ((TAB1 (MAKE-HASH-TABLE))
      (TAB2 (MAKE-HASH-TABLE :TEST 'EQUAL)))
  (KL::GENERALIZED-EQUAL-HASH-TABLE TAB1 TAB2))
;⇒ T
(G000001::AUTO-IMPORT 'ALIST->HASH-TABLE)
;⇒ (:FARE-UTILS)

(LET ((TAB1 (ALIST->HASH-TABLE '((:A . 1) (:B . 2) (:C . 3)))) (TAB2 (ALIST->HASH-TABLE '((:A . 1) (:B . 2) (:c . 3))))) (KL::GENERALIZED-EQUAL-HASH-TABLE TAB1 TAB2)) ;⇒ T


KMRCLを眺める(199) GENERALIZED-EQUAL-ARRAY

Posted 2010-09-04 13:47:00 GMT

今回は、KMRCLのequal.lispからGENERALIZED-EQUAL-ARRAYです。
名前からしてArrayの同値性を判定するものと思われます。
定義は、

(defun generalized-equal-array (obj1 obj2)
  (block test
    (when (not (= (array-total-size obj1) (array-total-size obj2)))
      (return-from test nil))
    (dotimes (i (array-total-size obj1))
      (unless (generalized-equal (aref obj1 i) (aref obj2 i))
        (return-from test nil)))
    (return-from test t)))
というところ。
まず、ARRAY-TOTAL-SIZE を知らべて大きさが違うならば脱出(ちなみに、(NOT (= ...))は(/= ...)と書けますよね)。
次にArrayの要素一つ一つに対してGENERALIZED-EQUALで判定(つまり再帰的に)という風になっています。
その、GENERALIZED-EQUALは、equal.lispで定義されている親玉というか、GENERALIZED-EQUAL-ARRAYのような物を合体したもっとも汎用的なものです。
動作的には、EQUALPとどういう風に違うのか、equal.lispを眺め終える時に確認したいと思います。
動作は、
(KL::GENERALIZED-EQUAL-ARRAY `#(() ,#'CAR ,(LAMBDA (X) 8)) 
                             `#(() ,#'CAR ,(LAMBDA (X) 8)))
;⇒ T ;Allegro CL/CLISP
;⇒ NIL ;SBCL/Clozure CL

;; 比較 EQUALP (EQUALP `#(() ,#'CAR ,(LAMBDA (X) 8)) `#(() ,#'CAR ,(LAMBDA (X) 8))) ;⇒ NIL


KMRCLを眺める(198) GENERALIZED-EQUAL-FUNCTION

Posted 2010-09-02 12:10:00 GMT

今回は、KMRCLのequal.lispからGENERALIZED-EQUAL-FUNCTIONです。
名前からすると同じ関数かどうかを判定するものと思われます。
定義は、

(defun generalized-equal-function (obj1 obj2)
  (string= (function-to-string obj1) (function-to-string obj2)))
前回眺めたFUNCTION-TO-STRINGを使っていて、結果をSTRING=で比較したりしているのですが、FUNCTION-TO-STRINGの大本となるFUNCTION-LAMBDA-EXPRESSIONが処理系依存の動作なため、処理系により上手く結果がでないようです。
(恐らくAllegro CL、CLISPでは多分意図した通り動く)
(KL::GENERALIZED-EQUAL-FUNCTION #'CAR #'CAR)
;⇒ T ;SBCL/CLISP/Allegro CL

(KL::GENERALIZED-EQUAL-FUNCTION (LAMBDA (X) (CAR X)) (LAMBDA (X) (CADR X))) ;⇒ NIL ;Allegro CL/CLISP ;⇒ T ;SBCL

SBCL/Clozure CLではこういうのはどう書いたら良いのか…。

KMRCLを眺める(197) FUNCTION-TO-STRING

Posted 2010-08-31 05:27:00 GMT

datetime.lispも前回で眺め終えたので、今回は、KMRCLのequal.lispからFUNCTION-TO-STRINGです。
関数を文字列にするってなんだろうという感じですが、FUNCTION-LAMBDA-EXPRESSIONの結果をどうにか文字列にしている感じです。

(defun function-to-string (obj)
  "Returns the lambda code for a function. Relies on
Allegro implementation-dependent features."
  (multiple-value-bind (lambda closurep name) (function-lambda-expression obj)
    (declare (ignore closurep))
    (if lambda
          (format nil "#'~s" lambda)
      (if name
          (format nil "#'~s" name)
        (progn
          (print obj)
          (break))))))
しかし、FUNCTION-LAMBDA-EXPRESSIONの動作はかなり実装依存なため、大分ばらばらな動きになっています。
(KL::FUNCTION-TO-STRING (LAMBDA (X) X))
; Allegro CL
; ⇒ "#'(LAMBDA (X) X)"

; SBCL ; ⇒ "#'(LAMBDA (X))"

; CCL (BREAK) ; NIL, NIL, NILが返ってくるため

Allegro CL以外は、有用な結果になってない気がします…。

KMRCLを眺める(196) DAY-OF-WEEK

Posted 2010-08-30 13:05:00 GMT

今回は、KMRCLのdatetime.lispからDAY-OF-WEEKです。
曜日を求めるのには定番のツェラーの公式を利用するものです。

(defconstant* +zellers-adj+ #(0 3 2 5 0 3 5 1 4 6 2 4))

(defun day-of-week (year month day) "Day of week calculation using Zeller's Congruence. Input: The year y, month m (1 ≤ m ≤ 12) and day d (1 ≤ d ≤ 31). Output: n - the day of the week (Sunday = 0, Saturday = 6)."

(when (< month 3) (decf year)) (mod (+ year (floor year 4) (- (floor year 100)) (floor year 400) (aref +zellers-adj+ (1- month)) day) 7))

動作は、
(STRING (CHAR "日月火水木金土" (KL:DAY-OF-WEEK 2010 8 30)))
;⇒ "月"
というところ

KMRCLを眺める(195) MONTHNAME

Posted 2010-08-29 14:48:00 GMT

今回は、KMRCLのdatetime.lispからMONTHNAMEです。
定義を読むと、どうも月の数字から西暦の月の名前を割り出す関数のようです。

;; Monthnames taken from net-telent-date to support lml2

(defvar *monthnames* '((1 . "January") (2 . "February") (3 . "March") (4 . "April") (5 . "May") (6 . "June") (7 . "July") (8 . "August") (9 . "September") (10 . "October") (11 . "November") (12 . "December")))

(defun monthname (stream arg colon-p at-p &optional width (mincol 0) (colinc 1) (minpad 0) (padchar #\Space)) "Print the name of the month (1=January) corresponding to ARG on STREAM. This is intended for embedding in a FORMAT directive: WIDTH governs the number of characters of text printed, MINCOL, COLINC, MINPAD, PADCHAR work as for ~A" (declare (ignore colon-p)) (let ((monthstring (cdr (assoc arg *monthnames*)))) (if (not monthstring) (return-from monthname nil)) (let ((truncate (if width (min width (length monthstring)) nil))) (format stream (if at-p "~V,V,V,V@A" "~V,V,V,VA") mincol colinc minpad padchar (subseq monthstring 0 truncate)))))

引数の並びと定義の感じからして、FORMATTERのように使うような気がしましたが、KMRCLで実際に使われている箇所が探し出せませんでした。
(FORMAT NIL #'KL::MONTHNAME 9 NIL NIL)
;⇒ "September"

;; 切り詰めてみる (FORMAT NIL #'KL::MONTHNAME 9 NIL NIL 3) ;⇒ "Sep"

Googleコード検索で探してみたところでは、
(format nil
        (formatter "~2,'0D-~3/kmrcl::monthname/-~4,'0D ~2,'0D:~2,'0D")
        3 3 2010 10 20)
;⇒ "03-Mar-2010 10:20"
のようなものがみつかりました。
なるほど、こういう風に~//で使ったりもできますね。

KMRCLを眺める(194) UTIME-TO-POSIX-TIME

Posted 2010-08-27 04:04:00 GMT

今回は、KMRCLのdatetime.lispからUTIME-TO-POSIX-TIMEです。
前回のPOSIX-TIME-TO-UTIMEの逆です。

(KL:UTIME-TO-POSIX-TIME (GET-UNIVERSAL-TIME))
;⇒ 1282881649
定義は、単に70年を引いているだけです。
(defun utime-to-posix-time (utime)
  (- utime +posix-epoch+))

KMRCLを眺める(193) POSIX-TIME-TO-UTIME

Posted 2010-08-26 03:24:00 GMT

今回は、KMRCLのdatetime.lispからPOSIX-TIME-TO-UTIMEです。
Common LispのUniversal Timeは、1900/1/1 0:00からスタートになります。
Posix timeとは70年ずれているわけですが、POSIX-TIME-TO-UTIMEは違いを変換するものです。

(LET ((UT (GET-UNIVERSAL-TIME))
      (PT (PARSE-INTEGER (VALUES (KL:COMMAND-OUTPUT "date +%s")))))
  (LIST :UT UT
        :PT->UT (KL:POSIX-TIME-TO-UTIME PT)))
;⇒ (:UT 3491782344 :PT->UT 3491782344)
定義は、単に70年を足しているだけです。
(defconstant +posix-epoch+
  (encode-universal-time 0 0 0 1 1 1970 0))

(defun posix-time-to-utime (time) (+ time +posix-epoch+))


KMRCLを眺める(192) PRINT-FLOAT-UNITS

Posted 2010-08-24 12:08:00 GMT

今回は、KMRCLのdatetime.lispからPRINT-FLOAT-UNITSです。
定義は、

(defun print-float-units (val unit)
  (cond
    ((< val 1d-6)
     (format t "~,2,9F nano~A" val unit))
    ((< val 1d-3)
     (format t "~,2,6F micro~A" val unit))
    ((< val 1)
     (format t "~,2,3F milli~A" val unit))
    ((> val 1d9)
     (format t "~,2,-9F giga~A" val unit))
    ((> val 1d6)
     (format t "~,2,-6F mega~A" val unit))
    ((> val 1d3)
     (format t "~,2,-3F kilo~A" val unit))
    (t
     (format t "~,2F ~A" val unit))))
こんな感じですが、なぜdatetime.lispで定義されているのか不思議なところ。
(WITH-OUTPUT-TO-STRING (*STANDARD-OUTPUT*)
  (KL:PRINT-FLOAT-UNITS 0.001234567890 "sec"))
;⇒ "1.23 millisec"
PRINT-FLOAT-UNITSを呼んでいる周りの関数を眺めるとどうもミリ秒とか、そういうのを表記するのに使いたい様子。

KMRCLを眺める(191) DATE-STRING

Posted 2010-08-23 14:44:00 GMT

今回は、KMRCLのdatetime.lispからDATE-STRINGです。
名前からして日付の文字列を返す感じですが、動作は、

(KL:DATE-STRING)
;⇒ "Mon 23 Aug 2010 23:35:39"
という感じです。
定義は、
(defun date-string (&optional (ut (get-universal-time)))
  (if (typep ut 'integer)
      (multiple-value-bind (sec min hr day mon year dow daylight-p zone)
          (decode-universal-time ut)
        (declare (ignore daylight-p zone))
        (format nil "~[Mon~;Tue~;Wed~;Thu~;Fri~;Sat~;Sun~] ~d ~[Jan~;Feb~;Mar~;Apr~;May~;Jun~;Jul~;Aug~;Sep~;Oct~;Nov~;Dec~] ~d ~2,'0d:~2,'0d:~2,'0d"
                dow
                day
                (1- mon)
                year
                hr min sec))))
となっています。
FORMATが活躍していますが、
(format nil "~[Mon~;Tue~;Wed~;Thu~;Fri~;Sat~;Sun~]" 3)
;⇒ "Thu"
などは使う機会も結構ありそうです。
毎度使いたい時には書式を忘れてますが…

KMRCLを眺める(190) PRETTY-DATE-UT

Posted 2010-08-20 13:12:00 GMT

今回は、KMRCLのdatetime.lispからPRETTY-DATE-UTです。
前回眺めたPRETTY-DATEの結果をDECODE-UNIVERSAL-TIMEして返すものの様子

(defun pretty-date-ut (&optional (tm (get-universal-time)))
  (multiple-value-bind (sec min hr dy mn yr) (decode-universal-time tm)
    (pretty-date yr mn dy hr min sec)))
動作は、
(KL:PRETTY-DATE-UT (GET-UNIVERSAL-TIME))
;⇒ "Friday"
    "August"
    "20"
    "2010"
    "22:11:24"
となっています。
多値での受け渡しは便利なようなそうでもないような。

KMRCLを眺める(189) PRETTY-DATE

Posted 2010-08-18 12:28:00 GMT

前回で、impl.lispも眺め終わったので続いて、datetime.lispを眺めます。
ということで今回は、KMRCLのdatetime.lispからPRETTY-DATEです。
定義は、

(defun pretty-date (year month day &optional (hour 12) (m 0) (s 0))
  (multiple-value-bind (sec min hr dy mn yr wkday)
    (decode-universal-time
     (encode-universal-time s m hour day month year))
    (values (elt '("Monday" "Tuesday" "Wednesday" "Thursday"
                   "Friday" "Saturday" "Sunday")
                 wkday)
            (elt '("January" "February" "March" "April" "May" "June"
                   "July" "August" "September" "October" "November"
                   "December")
                 (1- mn))
            (format nil "~A" dy)
            (format nil "~A" yr)
            (format nil "~2,'0D:~2,'0D:~2,'0D" hr min sec))))
となっていますが、与えられた年月日から曜日や月名を多値で返すもののようです。
(KL:PRETTY-DATE 2010 8 18)
;⇒ "Wednesday"
    "August"
    "18"
    "2010"
    "12:00:00"

(APPLY #'KL:PRETTY-DATE (CDDDR (REVERSE (MULTIPLE-VALUE-LIST (DECODE-UNIVERSAL-TIME (GET-UNIVERSAL-TIME)))))) ;⇒ "Wednesday" "August" "18" "2010" "21:05:12"

ちょっとした時に便利かもしれません。

KMRCLを眺める(188) PROBE-DIRECTORY

Posted 2010-08-17 14:21:00 GMT

今回は、KMRCLのimpl.lispからPROBE-DIRECTORYです。
CLの標準には、PROBE-FILEというのがありますが、これだとディレクトリとファイルで検出結果に区別がつきません。
ということで、処理系依存の機能を使ってディレクトリであるかどうかを調べるものになっています。
定義は、

(defun probe-directory (filename &key (error-if-does-not-exist nil))
  (let* ((path (canonicalize-directory-name filename))
         (probe
          #+allegro (excl:probe-directory path)
          #+clisp (values
                   (ignore-errors
                     (#+lisp=cl ext:probe-directory
                                #-lisp=cl lisp:probe-directory
                                path)))
          #+(or cmu scl) (when (eq :directory
                                   (unix:unix-file-kind (namestring path)))
                           path)
          #+lispworks (when (lw:file-directory-p path)
                        path)
          #+sbcl
          (let ((file-kind-fun
                 (or (find-symbol "NATIVE-FILE-KIND" :sb-impl)
                     (find-symbol "UNIX-FILE-KIND" :sb-unix))))
            (when (eq :directory (funcall file-kind-fun (namestring path)))
              path))
          #-(or allegro clisp cmu lispworks sbcl scl)
          (probe-file path)))
    (if probe
        probe
        (when error-if-does-not-exist
          (error "Directory ~A does not exist." filename)))))
動作は、
(KL:PROBE-DIRECTORY "/etc")
;⇒ #P"/etc/"

(KL:PROBE-DIRECTORY "/etc/hosts") ;⇒ NIL

;; 参考: PROBE-FILE (PROBE-FILE "/etc") ;⇒ #P"/etc/"

(PROBE-FILE "/etc/hosts") ;⇒ #P"/etc/hosts"

という感じです。

KMRCLを眺める(187) CANONICALIZE-DIRECTORY-NAME

Posted 2010-08-16 14:09:00 GMT

今回は、KMRCLのimpl.lispからCANONICALIZE-DIRECTORY-NAMEです。
与えられたファイル名をディレクトリの名前として正規化して返すもののようです。
:unspecificが返ってきてしまう場合にはNILを返すローカル関数を定義して処理しています。
定義は

(defun canonicalize-directory-name (filename)
  (flet ((un-unspecific (value)
           (if (eq value :unspecific) nil value)))
    (let* ((path (pathname filename))
           (name (un-unspecific (pathname-name path)))
           (type (un-unspecific (pathname-type path)))
           (new-dir
            (cond ((and name type) (list (concatenate 'string name "." type)))
                  (name (list name))
                  (type (list type))
                  (t nil))))
      (if new-dir
          (make-pathname
           :directory (append (un-unspecific (pathname-directory path))
                              new-dir)
                    :name nil :type nil :version nil :defaults path)
          path))))
となっていますが、パス名回りは色々と複雑で処理系とOSによって動作は若干変わってくるようです。
(KL::CANONICALIZE-DIRECTORY-NAME "/tmp/../etc/hosts.allow")
;; SBCL
;⇒ #P"/tmp/../etc/hosts.allow/" 
;; Allegro CL
;⇒ #P"/etc/hosts.allow/"

KMRCLを眺める(186) CWD

Posted 2010-08-13 14:09:00 GMT

今回は、KMRCLのimpl.lispからCWDです。
CWDはUNIXのcurrent working directoryのことだと思われ、現在位置しているディレクトリを返すもののようですが、現在位置を返すだけではなくディレクトリも指定した場所に移動するようです。
例のごとく処理系依存の切り分けが定義の殆どを占めています。

(defun cwd (&optional dir)
  "Change directory and set default pathname"
  (cond
   ((not (null dir))
    (when (and (typep dir 'logical-pathname)
               (translate-logical-pathname dir))
      (setq dir (translate-logical-pathname dir)))
    (when (stringp dir)
      (setq dir (parse-namestring dir)))
    #+allegro (excl:chdir dir)
    #+clisp (#+lisp=cl ext:cd #-lisp=cl lisp:cd dir)
    #+(or cmu scl) (setf (ext:default-directory) dir)
    #+cormanlisp (ccl:set-current-directory dir)
    #+(and mcl (not openmcl)) (ccl:set-mac-default-directory dir)
    #+openmcl (ccl:cwd dir)
    #+gcl (si:chdir dir)
    #+lispworks (hcl:change-directory dir)
    (setq cl:*default-pathname-defaults* dir))
   (t
    (let ((dir
           #+allegro (excl:current-directory)
           #+clisp (#+lisp=cl ext:default-directory #-lisp=cl lisp:default-directory)
           #+(or cmu scl) (ext:default-directory)
           #+sbcl (sb-unix:posix-getcwd/)
           #+cormanlisp (ccl:get-current-directory)
           #+lispworks (hcl:get-working-directory)
           #+mcl (ccl:mac-default-directory)
           #-(or allegro clisp cmu scl cormanlisp mcl sbcl lispworks) (truename ".")))
      (when (stringp dir)
        (setq dir (parse-namestring dir)))
      dir))))
動作ですが、普通のパスはもとより
(KL:CWD "/tmp")

(DIRECTORY ".") ;⇒ (#P"/tmp/")

論理パスも扱えるようになっています。
(SETF (LOGICAL-PATHNAME-TRANSLATIONS "var")
      '(("tmp;**;*.*.*" "/var/tmp/**/*.*")))

(KL:CWD "var:tmp;")

(DIRECTORY "var:tmp;*") ;⇒ (#P"/usr/local/var/tmp/.fasls/" ...)


KMRCLを眺める(185) COPY-FILE

Posted 2010-08-08 12:42:00 GMT

今回は、KMRCLのimpl.lispからCOPY-FILEです。
名前からしてファイルをコピーするもののようです。
定義は、

(defun copy-file (from to &key link overwrite preserve-symbolic-links
                  (preserve-time t) remove-destination force verbose)
  #+allegro (sys:copy-file from to :link link :overwrite overwrite
                           :preserve-symbolic-links preserve-symbolic-links
                           :preserve-time preserve-time
                           :remove-destination remove-destination
                           :force force :verbose verbose)
  #-allegro
  (declare (ignore verbose preserve-symbolic-links overwrite))
  (cond
    ((and (typep from 'stream) (typep to 'stream))
     (copy-binary-stream from to))
    ((not (probe-file from))
     (error "File ~A does not exist." from))
    ((eq link :hard)
     (run-shell-command "ln -f ~A ~A" (namestring from) (namestring to)))
    (link
     (multiple-value-bind (stdout stderr status)
         (command-output "ln -f ~A ~A" (namestring from) (namestring to))
       (declare (ignore stdout stderr))
       ;; try symbolic if command failed
       (unless (zerop status)
         (run-shell-command "ln -sf ~A ~A" (namestring from) (namestring to)))))
    (t
     (when (and (or force remove-destination) (probe-file to))
       (delete-file to))
     (let* ((options (if preserve-time
                         "-p"
                         ""))
            (cmd (format nil "cp ~A ~A ~A" options (namestring from) (namestring to))))
       (run-shell-command cmd)))))
となっています。
Allegro CLだと同名の関数があるようですが、それを模した感じになっていて、基本的には、CLからUnixのコマンドを実行しています。
動作は、
(KL:COPY-FILE "/etc/fstab" "/tmp/")
;⇒ 0

$ ls /tmp
... fstab ...
となっています。

KMRCLを眺める(184) COMMAND-LINE-ARGUMENTS

Posted 2010-08-04 14:29:00 GMT

今回は、KMRCLのimpl.lispからCOMMAND-LINE-ARGUMENTSです。
COMMAND-LINE-ARGUMENTSは、起動されている処理系自身の引数を調べるためのもので、大抵の処理系には付いてることが多いみたいです。
定義は、

(defun command-line-arguments ()
  #+allegro (system:command-line-arguments)
  #+sbcl sb-ext:*posix-argv*
  )
のようになっています。
Allegro CLとSBCLの場合しか書かれていませんが、(apropos 'argv)などとすると関数や変数が見付けられる処理系も多いようです。
SWANK別起動でSLIMEを使っている自分だと、
(KL:COMMAND-LINE-ARGUMENTS)
;⇒ ("/var/lisp/swank-sbcl")
のような感じになっています。

KMRCLを眺める(183) QUIT

Posted 2010-08-03 03:47:00 GMT

KMRCLos.lispも眺め終えたので今回からimpl.lispを眺めます。
今回は、QUITです。
QUITは良く使うけど、実は処理系依存というものの代表格かなと思います。
定義は、

(defun quit (&optional (code 0))
  "Function to exit the Lisp implementation. Copied from CLOCC's QUIT function."
    #+allegro (excl:exit code :quiet t)
    #+clisp (#+lisp=cl ext:quit #-lisp=cl lisp:quit code)
    #+(or cmu scl) (ext:quit code)
    #+cormanlisp (win32:exitprocess code)
    #+gcl (lisp:bye code)
    #+lispworks (lw:quit :status code)
    #+lucid (lcl:quit code)
    #+sbcl (sb-ext:quit :unix-status (typecase code (number code) (null 0) (t 1)))
    #+mcl (ccl:quit code)
    #-(or allegro clisp cmu scl cormanlisp gcl lispworks lucid sbcl mcl)
    (error 'not-implemented :proc (list 'quit code)))
のようになっています。
処理系ごとに属するパッケージも違うことが良く分かります。
QUITが標準でない理由は自分も良く分からないのですが、LISPマシンのような場合を考えると処理系を終わらせてOSに抜けるとも限らないからなのかなと思ったりしています。

KMRCLを眺める(182) DELETE-DIRECTORY-AND-FILES

Posted 2010-07-29 14:28:00 GMT

今回は、KMRCLのos.lispから DELETE-DIRECTORY-AND-FILES です。
Allegro CLだと同名の関数があり、処理系にディレクトリを削除する機能があるようですが、他の処理系の場合はKL:COMMAND-OUTPUTを使って、rm -rfするようです。
定義は、

(defun delete-directory-and-files (dir &key (if-does-not-exist :error) (quiet t) force)
  #+allegro (excl:delete-directory-and-files dir :if-does-not-exist if-does-not-exist
                                             :quiet quiet :force force)
  #-(or allegro) (declare (ignore force))
  #-(or allegro) (cond
                   ((probe-directory dir)
                    (let ((cmd (format nil "rm -rf ~A" (namestring dir))))
                      (unless quiet
                        (format *trace-output* ";; ~A" cmd))
                      (command-output cmd)))
                   ((eq if-does-not-exist :error)
                    (error "Directory ~A does not exist [delete-directory-and-files]." dir))))
となっています。
動作は、
(KL:DELETE-DIRECTORY-AND-FILES "/tmp/bar")
;⇒ ""
    ""
    0
;; 権限不足で削除できなかった場合
;⇒ ""
    "rm: ディレクトリ`/tmp/bar/baz/quux'を削除できません: Permission denied
    "
    1
というところ

KMRCLを眺める(181) RUN-SHELL-COMMAND

Posted 2010-07-28 04:42:00 GMT

今回は、KMRCLのos.lispからRUN-SHELL-COMMANDです。
前回のCOMMAND-OUTPUTは出力を取得できましたが、今回のRUN-SHELL-COMMANDは外部のコマンドを実行するのに特化しています。
動作は、

(LET ((FILE "/usr/share/dict/words")
      (OUT-FILE "/tmp/bar"))
  (WITH-OPEN-FILE (IN FILE)
    (ALEXANDRIA:WITH-OUTPUT-TO-FILE (OUT OUT-FILE)
      (LOOP :FOR LINE := (READ-LINE IN NIL) :WHILE LINE
            :DO (WRITE-LINE (STRING-UPCASE LINE) OUT))))
  (KL:RUN-SHELL-COMMAND "firefox ~A" OUT-FILE))
のようなところでしょうか。
定義は、下記のようになっていますが、処理系依存の切り分けが中身の殆どです。
(defun run-shell-command (control-string &rest args)
  "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
synchronously execute the result using a Bourne-compatible shell,
returns (VALUES output-string pid)"
  (let ((command (apply #'format nil control-string args)))
    #+sbcl
    (sb-impl::process-exit-code
     (sb-ext:run-program
      "/bin/sh"
      (list  "-c" command)
      :input nil :output nil))

#+(or cmu scl) (ext:process-exit-code (ext:run-program "/bin/sh" (list "-c" command) :input nil :output nil))

#+allegro (excl:run-shell-command command :input nil :output nil :wait t)

#+lispworks (system:call-system-showing-output command :shell-type "/bin/sh" :show-cmd nil :prefix "" :output-stream nil)

#+clisp ;XXX not exactly *verbose-out*, I know (ext:run-shell-command command :output :terminal :wait t)

#+openmcl (nth-value 1 (ccl:external-process-status (ccl:run-program "/bin/sh" (list "-c" command) :input nil :output nil :wait t)))

#-(or openmcl clisp lispworks allegro scl cmu sbcl) (error "RUN-SHELL-PROGRAM not implemented for this Lisp")

))


KMRCLを眺める(180) COMMAND-OUTPUT

Posted 2010-07-27 12:42:00 GMT

今回は、KMRCLのos.lispからCOMMAND-OUTPUTです。
外部のシェルでコマンドを実行したり外部コマンドの出力を取得したりしたくなることは多いと思うのですが、ANSI CLではその辺りのことは決められていませんので、実装依存になります。
しかし、大抵の実装では、外部シェルとやりとりをする一連の関数が提供されています。
COMMAND-OUTPUTはそういうコマンドを処理系に依存しないようにラッピングするものです。
動作は、

(KL:COMMAND-OUTPUT "ls -l /etc/hosts")
;⇒ "-rw-r--r--. 1 root root 1055 2010-07-24 16:51 /etc/hosts
    "
   ""
   0
で、
+コマンド出力の文字列
+エラー
+コマンドの終了コード
と3つの値を返すようになっていて、大体の処理系は、上記3つを取得できる関数を持っているようです。
定義は、処理系ごとに色々違うので長くなっていますが、下記のようになっています。
(defun command-output (control-string &rest args)
  "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
synchronously execute the result using a Bourne-compatible shell,
returns (VALUES string-output error-output exit-status)"
  (let ((command (apply #'format nil control-string args)))
    #+sbcl
    (let* ((process (sb-ext:run-program
                    "/bin/sh"
                    (list "-c" command)
                    :input nil :output :stream :error :stream))
           (output (read-stream-to-string (sb-impl::process-output process)))
           (error (read-stream-to-string (sb-impl::process-error process))))
      (close (sb-impl::process-output process))
      (close (sb-impl::process-error process))
      (values
       output
       error
       (sb-impl::process-exit-code process)))

#+(or cmu scl) (let* ((process (ext:run-program "/bin/sh" (list "-c" command) :input nil :output :stream :error :stream)) (output (read-stream-to-string (ext::process-output process))) (error (read-stream-to-string (ext::process-error process)))) (close (ext::process-output process)) (close (ext::process-error process))

(values output error (ext::process-exit-code process)))

#+allegro (multiple-value-bind (output error status) (excl.osi:command-output command :whole t) (values output error status))

#+lispworks ;; BUG: Lispworks combines output and error streams (let ((output (make-string-output-stream))) (unwind-protect (let ((status (system:call-system-showing-output command :prefix "" :show-cmd nil :output-stream output))) (values (get-output-stream-string output) nil status)) (close output)))

#+clisp ;; BUG: CLisp doesn't allow output to user-specified stream (values nil nil (ext:run-shell-command command :output :terminal :wait t))

#+openmcl (let* ((process (ccl:run-program "/bin/sh" (list "-c" command) :input nil :output :stream :error :stream :wait t)) (output (read-stream-to-string (ccl::external-process-output-stream process))) (error (read-stream-to-string (ccl::external-process-error-stream process)))) (close (ccl::external-process-output-stream process)) (close (ccl::external-process-error-stream process)) (values output error (nth-value 1 (ccl::external-process-status process))))

#-(or openmcl clisp lispworks allegro scl cmu sbcl) (error "COMMAND-OUTPUT not implemented for this Lisp")

))


KMRCLを眺める(179) FILE-SIZE

Posted 2010-07-24 14:14:00 GMT

KMRCLを眺める、symbols.lispは前回で終了したので、今回は、KMRCLのos.lispからFILE-SIZEです。
CLでファイルのサイズをみるとなると、OPENして、FILE-LENGTHだと思いますが、FILE-SIZEの定義も

(defun file-size (file)
  (when (probe-file file)
    #+allegro (let ((stat (excl.osi:stat (namestring file))))
                (excl.osi:stat-size stat))
    #-allegro
    (with-open-file (in file :direction :input)
      (file-length in))))
となっています。
Allegro CLだと、excl.osi:stat-size というものがあるようで、ACLの場合はそちらを使うようになっています。
動作は、
(KL:FILE-SIZE "/usr/share/dict/words")
;⇒ 931708
というところ

KMRCLを眺める(178) GETPID

Posted 2010-07-23 14:48:00 GMT

KMRCLを眺める、symbols.lispは前回で終了したので、今回は、KMRCLのos.lispからGETPIDです。
OS周りはANSI CLの仕様では決められていないので、処理系の伝統だったり処理系が稼動するホストOSの流儀を取り込んだり色々のようです。
GETPIDは、LISP処理系のプロセスIDを取得するというもので、大概の処理系には含まれているもののようです。
動作は、Linux上のSBCLだと

(KL:GETPID)
;⇒ 3018
という感じです。
シェルで確かめてみると
setq% ps | grep 3018
g000001    3018  2570  0 20:18 pts/4    00:00:36 /var/lisp/swank-sbcl
という風に一致していることが分かります。
定義は、
(defun getpid ()
  "Return the PID of the lisp process."
  #+allegro (excl::getpid)
  #+(and lispworks win32) (win32:get-current-process-id)
  #+(and lispworks (not win32)) (system::getpid)
  #+sbcl (sb-posix:getpid)
  #+cmu (unix:unix-getpid)
  #+openmcl (ccl::getpid)
  #+(and clisp unix) (system::process-id)
  #+(and clisp win32) (cond ((find-package :win32)
                             (funcall (find-symbol "GetCurrentProcessId"
                                                   :win32)))
                            (t
                             (system::getenv "PID")))
  )
というところで、処理系依存の切り分けが殆どで、正味は1行です。

KMRCLを眺める(177) RUN-TESTS-FOR-INSTANCE

Posted 2010-07-21 13:39:00 GMT

KMRCLを眺める、今回は、KMRCLのsymbols.lispからFIND-TEST-GENERIC-FUNCTIONSです。
RUN-TESTS-FOR-INSTANCEは、前回の謎関数FIND-TEST-GENERIC-FUNCTIONSを利用するもので定義は、

(defun run-tests-for-instance (instance)
  (dolist (gf-name(find-test-generic-functions instance))
    (funcall gf-name instance))
  (values))
となっています。これから使い方を想像するに
(DEFCLASS FOO () 
  ((X :INITFORM 1 :ACCESSOR FOO-X)
   (Y :INITFORM 2 :ACCESSOR FOO-Y)
   (Z :INITFORM 3 :ACCESSOR FOO-Z)))

(DEFMETHOD TEST-FOO1 ((X FOO)) (PRINT (LIST '(= 1 (FOO-X (MAKE-INSTANCE 'FOO))) '=> (= 1 (FOO-X (MAKE-INSTANCE 'FOO))))))

(DEFMETHOD TEST-FOO2 ((X FOO)) (PRINT (LIST '(= 2 (FOO-Y (MAKE-INSTANCE 'FOO))) '=> (= 2 (FOO-Y (MAKE-INSTANCE 'FOO))))))

(DEFMETHOD TEST-FOO3 ((X FOO)) (PRINT (LIST '(= 3 (FOO-Z (MAKE-INSTANCE 'FOO))) '=> (= 3 (FOO-Z (MAKE-INSTANCE 'FOO))))))

;; テスト実行 (KL::RUN-TESTS-FOR-INSTANCE (MAKE-INSTANCE 'FOO)) ;-> ((= 2 (FOO-Y (MAKE-INSTANCE 'FOO))) => T) ((= 3 (FOO-Z (MAKE-INSTANCE 'FOO))) => T) ((= 1 (FOO-X (MAKE-INSTANCE 'FOO))) => T)

みたいな感じでしょうか。
とりあえず、TEST-というメソッドを片っ端から実行するんだということは理解できましたが…

KMRCLを眺める(176) FIND-TEST-GENERIC-FUNCTIONS

Posted 2010-07-20 14:44:00 GMT

KMRCLを眺めるのも久々ですが、今回は、KMRCLのsymbols.lispからFIND-TEST-GENERIC-FUNCTIONSです。
とりあえず、ぱっとみで何をするものなのか良く分からないので、ドキュメントストリングを読んだり、コードを眺めたりですが、動作は、

(DEFCLASS FOO () ())

(DEFMETHOD TEST-FOO ((X FOO))) (DEFMETHOD TEST-FOO1 ((X FOO))) (DEFMETHOD TEST-FOO2 ((X FOO)))

(KL::FIND-TEST-GENERIC-FUNCTIONS (MAKE-INSTANCE 'FOO)) ;⇒ (TEST-FOO2 TEST-FOO TEST-FOO1)

となるようです。
上では、FOOというクラスを作って、そのFOOに関連する総称関数を作成していて、それらはすべてTEST-という名前で始まっています。
どうも、FIND-TEST-GENERIC-FUNCTIONSは、こういう総称関数を探し出すもののようです。
テストを書くときに使うと便利だったりするんでしょうか…。
定義は、
(defun find-test-generic-functions (instance)
  "Return a list of symbols for generic functions specialized on the
class of an instance and whose name begins with the string 'test-'"
  (let ((res)
        (package (symbol-package (class-name (class-of instance)))))
    (do-symbols (s package)
      (multiple-value-bind (sym status)
          (find-symbol (symbol-name s) package)
        (when (and (or (eq status :external)
                       (eq status :internal))
                   (fboundp sym)
                   (eq (symbol-package sym) package)
                   (> (length (symbol-name sym)) 5)
                   (string-equal "test-" (subseq (symbol-name sym) 0 5))
                   (typep (symbol-function sym) 'generic-function)
                   (plusp
                    (length
                     (compute-applicable-methods
                      (ensure-generic-function sym)
                      (list instance)))))
          (push sym res))))
    (nreverse res)))
となっています。

KMRCLを眺める(175) SHOW

Posted 2010-07-09 15:13:00 GMT

今回は、KMRCLのsymbols.lispからSHOWです。
前回、前々回のSHOW-VARIABLES、SHOW-FUNCTIONSを纒めたものです。
動作は、

(KL:SHOW :FUNCTIONS :G000001)
;->
Function GITHUB-INSTALL  -> #<FUNCTION GITHUB-INSTALL>
Function AUTO-IMPORT  -> #<FUNCTION AUTO-IMPORT>
Function QUIT  -> #<FUNCTION QUIT>
Function FACT-CPS-LIST  -> #<FUNCTION FACT-CPS-LIST>
Function INSTALL  -> #<FUNCTION INSTALL>
Function OOS  -> #<FUNCTION OOS>
Function CURRY  -> #<FUNCTION CURRY>
Function FACT-CPS  -> #<FUNCTION FACT-CPS>
Function FLATTEN-CPS  -> #<FUNCTION FLATTEN-CPS>
;⇒ NIL
というところ。定義は、
(defun show (&optional (what :variables) (package *package*))
  (ecase what
    (:variables (show-variables package))
    (:functions (show-functions package))))
となっています。
ざっと一覧を眺めるのに便利かもしれません。

KMRCLを眺める(174) SHOW-FUNCTIONS

Posted 2010-07-08 13:41:00 GMT

今回は、KMRCLのsymbols.lispからSHOW-FUNCTIONSです。
前回は、変数でしたが今回はそれの関数版です。
動作は、

(KL:SHOW-FUNCTIONS :KMRCL)
->
Function KMRCL::STRING-DEFAULT-CASE  -> #<FUNCTION KMRCL::STRING-DEFAULT-CASE>
Function KMRCL::BYTE-ARRAY-OUTPUT-STREAM-OUT  -> #<CLOSURE (LAMBDA
                                                               (SB-KERNEL:INSTANCE)) {1004F93809}>
Function KMRCL::%PRINT-BYTE-ARRAY-OUTPUT-STREAM  -> #<FUNCTION KMRCL::%PRINT-BYTE-ARRAY-OUTPUT-STREAM>
Function KMRCL::BYTE-ARRAY-INPUT-STREAM-CHAR-SIZE  -> #<CLOSURE (LAMBDA
                                                                    (SB-KERNEL:INSTANCE)) {1004E9ADD9}>
Function KMRCL::BYTE-ARRAY-OUTPUT-STREAM-EOF-FORCED-P  -> #<CLOSURE (LAMBDA
                                                                        (SB-KERNEL:INSTANCE)) {10041AA599}>
Function KMRCL::BYTE-ARRAY-OUTPUT-STREAM-EXTERNAL-FORMAT  -> #<CLOSURE (LAMBDA
                                                                           (SB-KERNEL:INSTANCE)) {100535A469}>
Function KMRCL::BYTE-ARRAY-INPUT-STREAM-DUAL-CHANNEL-P  -> #<CLOSURE (LAMBDA
                                                                         (SB-KERNEL:INSTANCE)) {10044000B9}>
Function KMRCL::CL-SYMBOLS  -> #<FUNCTION KMRCL::CL-SYMBOLS>
Function KMRCL::BYTE-ARRAY-OUTPUT-STREAM-PATHNAME  -> #<CLOSURE (LAMBDA
                                                                    (SB-KERNEL:INSTANCE)) {1005353729}>
Function KMRCL::BYTE-ARRAY-OUTPUT-STREAM-DELETE-ORIGINAL  -> #<CLOSURE (LAMBDA
                                                                           (SB-KERNEL:INSTANCE)) {10059CD009}>
Function KMRCL::BYTE-ARRAY-INPUT-STREAM-LISTEN  -> #<CLOSURE (LAMBDA
                                                                 (SB-KERNEL:INSTANCE)) {1005A87D89}>
Function KMRCL::REMOTE-HOST  -> #<FUNCTION KMRCL::REMOTE-HOST>
Function KMRCL::REPL-ON-STREAM  -> #<FUNCTION KMRCL::REPL-ON-STREAM>
Function KMRCL::BYTE-ARRAY-BINCH  -> #<FUNCTION KMRCL::BYTE-ARRAY-BINCH>
Function KMRCL::CATCH-ERRORS  -> #<STANDARD-GENERIC-FUNCTION KMRCL::CATCH-ERRORS (1)>
Function KMRCL::BYTE-ARRAY-OUTPUT-STREAM-INSTEAD  -> #<CLOSURE (LAMBDA
                                                                   (SB-KERNEL:INSTANCE)) {1005586FB9}>
Function KMRCL::BUF-USED  -> #<CLOSURE (LAMBDA (SB-KERNEL:INSTANCE)) {10040F4CB9}>
Function KMRCL::BYTE-ARRAY-INPUT-STREAM-TIMEOUT  -> #<CLOSURE (LAMBDA
                                                                  (SB-KERNEL:INSTANCE)) {10053D5B79}>
Function KMRCL::BUF-POP  -> #<FUNCTION KMRCL::BUF-POP>
Function KMRCL::BYTE-ARRAY-INPUT-STREAM-BIN  -> #<CLOSURE (LAMBDA
                                                              (SB-KERNEL:INSTANCE)) {1004E19F49}>
Function KMRCL::BYTE-ARRAY-IN-MISC  -> #<FUNCTION KMRCL::BYTE-ARRAY-IN-MISC>
Function KMRCL::BYTE-ARRAY-INPUT-STREAM-BUFFERING  -> #<CLOSURE (LAMBDA
                                                                    (SB-KERNEL:INSTANCE)) {100517C1B9}>
Function KMRCL::MAPCAR2-APPEND-STRING-NONTAILREC  -> #<FUNCTION KMRCL::MAPCAR2-APPEND-STRING-NONTAILREC>
Function KMRCL::BUF-P  -> #<CLOSURE (LAMBDA (SB-KERNEL::OBJECT)) {100463FB59}>
Function KMRCL::BYTE-ARRAY-INPUT-STREAM-NAME  -> #<CLOSURE (LAMBDA
                                                               (SB-KERNEL:INSTANCE)) {1004245D19}>
Function KMRCL::CANONICALIZE-DIRECTORY-NAME  -> #<FUNCTION KMRCL::CANONICALIZE-DIRECTORY-NAME>
Function KMRCL::FIELD-BUFFERS-BUFFERS  -> #<CLOSURE (LAMBDA
                                                        (SB-KERNEL:INSTANCE)) {100529FFB9}>
Function KMRCL::BYTE-ARRAY-INPUT-STREAM-BYTE-ARRAY  -> #<CLOSURE (LAMBDA
                                                                     (SB-KERNEL:INSTANCE)) {1005979BF9}>
Function KMRCL::BASE-NAME  -> #<STANDARD-GENERIC-FUNCTION KMRCL::BASE-NAME (1)>
Function KMRCL::BYTE-ARRAY-INPUT-STREAM-BOUT  -> #<CLOSURE (LAMBDA
                                                               (SB-KERNEL:INSTANCE)) {1004738469}>
Function KMRCL::BYTE-ARRAY-OUTPUT-STREAM-BUFFERING  -> #<CLOSURE (LAMBDA
                                                                     (SB-KERNEL:INSTANCE)) {100461D8B9}>
Function KMRCL::MAKE-FD-STREAM  -> #<FUNCTION KMRCL::MAKE-FD-STREAM>
....
となっています。定義は、
(defun show-functions (package)
  (do-symbols (s package)
    (multiple-value-bind (sym status)
        (find-symbol (symbol-name s) package)
      (when (and (or (eq status :external)
                     (eq status :internal))
                 (fboundp sym))
        (format t "~&Function ~S~T -> ~S~%"
                sym
                (symbol-function sym))))))
で、変数版とほぼ同一です。

KMRCLを眺める(173) SHOW-VARIABLES

Posted 2010-07-07 13:25:00 GMT

今回は、KMRCLのsymbols.lispからSHOW-VARIABLESです。
変数が束縛されたシンボルとその内容を表示するもののようです。
動作は、

(KL:SHOW-VARIABLES :CL)
->
Symbol *ERROR-OUTPUT*  -> #<SWANK-BACKEND::SLIME-OUTPUT-STREAM
                            {100E6B7271}>
Symbol CALL-ARGUMENTS-LIMIT  -> 1152921504606846975
Symbol *PRINT-BASE*  -> 10
Symbol MOST-NEGATIVE-SINGLE-FLOAT  -> -3.4028235e38
Symbol *LOAD-PRINT*  -> NIL
Symbol *GENSYM-COUNTER*  -> 2959
Symbol BOOLE-ANDC1  -> 12
Symbol BOOLE-C2  -> 5
Symbol LEAST-NEGATIVE-SINGLE-FLOAT  -> -1.4012985e-45
Symbol ARRAY-TOTAL-SIZE-LIMIT  -> 1152921504606846973
Symbol LONG-FLOAT-EPSILON  -> 1.1102230246251568d-16
Symbol *PRINT-RADIX*  -> NIL
Symbol *PRINT-CASE*  -> :UPCASE
Symbol LEAST-POSITIVE-NORMALIZED-SHORT-FLOAT  -> 1.1754944e-38
Symbol ARRAY-RANK-LIMIT  -> 65529
Symbol +  -> (COMMON-LISP-USER::LOGIN 'COMMON-LISP-USER::MC)
Symbol LEAST-POSITIVE-DOUBLE-FLOAT  -> 4.9406564584124654d-324
Symbol ***  -> NIL
Symbol MOST-NEGATIVE-LONG-FLOAT  -> -1.7976931348623157d308
Symbol DOUBLE-FLOAT-EPSILON  -> 1.1102230246251568d-16
Symbol *  -> T
Symbol *LOAD-VERBOSE*  -> NIL
Symbol CHAR-CODE-LIMIT  -> 1114112
Symbol LEAST-NEGATIVE-LONG-FLOAT  -> -4.9406564584124654d-324
Symbol MOST-POSITIVE-LONG-FLOAT  -> 1.7976931348623157d308
Symbol BOOLE-AND  -> 6
Symbol BOOLE-ORC2  -> 15
Symbol MOST-NEGATIVE-FIXNUM  -> -1152921504606846976
Symbol *PRINT-CIRCLE*  -> NIL
....
となっています。定義は、
(defun show-variables (package)
  (do-symbols (s package)
    (multiple-value-bind (sym status)
        (find-symbol (symbol-name s) package)
      (when (and (or (eq status :external)
                     (eq status :internal))
                 (boundp sym))
        (format t "~&Symbol ~S~T -> ~S~%"
                sym
                (symbol-value sym))))))
で、そのままな感じです。

KMRCLを眺める(172) ENSURE-KEYWORD-DEFAULT-CASE

Posted 2010-07-06 13:12:00 GMT

今回は、KMRCLのsymbols.lispからENSURE-KEYWORD-DEFAULT-CASEです。
大文字小文字の違いをKMRCL内で調べてある稼働中の処理系のREADTABLE-CASEの状況に合せてキーワードシンボルを作成します。
動作は、

(LET ((*READTABLE* (COPY-READTABLE)))
  (EVAL
   (READ-FROM-STRING "(kl:ensure-keyword-default-case 'foo)")))
;⇒ :FOO

(LET ((*READTABLE* (COPY-READTABLE))) (SETF (READTABLE-CASE *READTABLE*) :PRESERVE) (EVAL (READ-FROM-STRING "(KL:ENSURE-KEYWORD-DEFAULT-CASE 'foo)"))) ;⇒ :FOO

というところ。
:PRESERVEにしていますが、上のテストの*READTABLE*は標準の状態なので全部大文字にされています。
定義は、
(defun ensure-keyword-default-case (desig)
  (nth-value 0 (intern (string-default-case
                        (symbol-name (ensure-keyword desig))) :keyword)))
となっています。

KMRCLを眺める(171) ENSURE-KEYWORD-UPCASE

Posted 2010-07-03 13:07:00 GMT

今回は、KMRCLのsymbols.lispからENSURE-KEYWORD-UPCASEです。
前回のENSURE-KEYWORDと同じく文字列指示子的なものを与えると、キーワードシンボルを返すというものですが、結果が大文字になることを保証するもののようです。
動作は、

(LET ((*READTABLE* (COPY-READTABLE)))
  (SETF (READTABLE-CASE *READTABLE*) :DOWNCASE)
  (EVAL
   (READ-FROM-STRING "(|KL|:|ENSURE-KEYWORD-UPCASE| 'foo)")))
;⇒ :FOO
というところで、ENSURE-KEYWORDと同じ条件(標準のREADTABLEでない状態)で比較すると
(LET ((*READTABLE* (COPY-READTABLE)))
  (SETF (READTABLE-CASE *READTABLE*) :DOWNCASE)
  (EVAL
   (READ-FROM-STRING "(|KL|:|ENSURE-KEYWORD| 'foo)")))
;⇒ :|foo|
動作が違ってきているのが分かります。
定義は、
(defun ensure-keyword-upcase (desig)
  (nth-value 0 (intern (string-upcase
                        (symbol-name (ensure-keyword desig))) :keyword)))
となっていますが、ENSURE-KEYWORDの使われ方が微妙な気が…
desigは文字列指示子を期待していて、STRING-UPCASEも同様なので、これなら
(defun ensure-keyword-upcase (desig)
  (nth-value 0 (ensure-keyword (string-upcase desig))))
でもOKな気がします。
いやENSURE-KEYWORDが*READTABLE*の値に影響を受けるので、
(defun ensure-keyword-upcase (desig)
  (nth-value 0 (intern (string-upcase desig) :keyword)))
等でないと駄目か。

KMRCLを眺める(170) ENSURE-KEYWORD

Posted 2010-07-01 11:47:00 GMT

今回は、KMRCLのsymbols.lispからENSURE-KEYWORDです。
文字列指示子的なものを与えると、キーワードシンボルを返すというものです。
動作は、

(KL:ENSURE-KEYWORD "foo")
;⇒ :FOO

(KL:ENSURE-KEYWORD 'foo) ;⇒ :FOO

(KL:ENSURE-KEYWORD :foo) ;⇒ :FOO

というところ。
定義は、
(defun ensure-keyword (name)
  "Returns keyword for a name"
  (etypecase name
    (keyword name)
    (string (nth-value 0 (intern (string-default-case name) :keyword)))
    (symbol (nth-value 0 (intern (symbol-name name) :keyword)))))
となっています。
多値の1値目を返すには、(VALUES)を使うのが定番かと思いますが、丁寧にNTH-VALUEで書いているようです。

KMRCLを眺める(169) CONCAT-SYMBOL

Posted 2010-06-29 14:02:00 GMT

今回は、KMRCLのsymbols.lispからCONCAT-SYMBOLです。
定義は、

(defun concat-symbol (&rest args)
  (apply #'concat-symbol-pkg nil args))
となっています。
前回眺めた、CONCAT-SYMBOL-PKGのパッケージ指定の部分にNILを指定して、カレントパッケージにシンボルをインポートしています。
これを眺めるに、前回のCONCAT-SYMBOL-PKGの名前にPKGとついているのは、どうやら、パッケージも指定できるよ、という意味のように思えました。
動作は、
(KL:CONCAT-SYMBOL :foo '- "bar" :- 'baz)
;⇒ FOO-BAR-BAZ
となっています。

KMRCLを眺める(168) CONCAT-SYMBOL-PKG

Posted 2010-06-25 12:54:00 GMT

今回は、KMRCLのsymbols.lispからCONCAT-SYMBOL-PKGです。
定義は、

(defun concat-symbol-pkg (pkg &rest args)
  (declare (dynamic-extent args))
  (flet ((stringify (arg)
           (etypecase arg
             (string
              (string-upcase arg))
             (symbol
              (symbol-name arg)))))
    (let ((str (apply #'concatenate 'string (mapcar #'stringify args))))
      (nth-value 0 (intern (string-default-case str)
                           (if pkg pkg *package*))))))
となっていて、定義と名前からするに、文字列指示子を受け取って文字列が合成されたシンボルを作成するもののようです。
パッケージを指定する機能もあります。
(KL:CONCAT-SYMBOL-PKG NIL "foo" "bar")
;⇒ FOOBAR

(KL:CONCAT-SYMBOL-PKG :KEYWORD "foo" "bar") ;⇒ :FOOBAR

(KL:CONCAT-SYMBOL-PKG :KL "foo" "bar") ;⇒ KMRCL::FOOBAR

pkgにNILを指定するとカレントパッケージが利用されます。

KMRCLを眺める(167) STRING-DEFAULT-CASE

Posted 2010-06-23 04:19:00 GMT

今回は、KMRCLのsymbols.lispからSTRING-DEFAULT-CASEです。
定義は、

;;; Symbol functions

(eval-when (:compile-toplevel :load-toplevel :execute) (when (char= #\a (schar (symbol-name '#:a) 0)) (pushnew :kmrcl-lowercase-reader *features*)) (when (not (string= (symbol-name '#:a) (symbol-name '#:A))) (pushnew :kmrcl-case-sensitive *features*)))

(defun string-default-case (str) #+(and (not kmrcl-lowercase-reader)) (string-upcase str) #+(and kmrcl-lowercase-reader) (string-downcase str))

というものなのですが、文字列を処理系のデフォルトケース応じて変換するもののようです。
デフォルトケースの判定には、:KMRCL-LOWERCASE-READERが、*FEATURES*にあるかどうかを判定しています。
動作は、
(KL::STRING-DEFAULT-CASE "foo")
;⇒ "FOO"

というところ

KMRCLを眺める(166) CL-SYMBOLS

Posted 2010-06-21 04:37:00 GMT

今回は、KMRCLのsymbols.lispからCL-SYMBOLSです。
前回/前々回のCL-VARIABLESと、CL-FUNCTIONSの結果を合体させたものです。
定義は、

(defun cl-symbols ()
  (append (cl-variables) (cl-functions)))
です。
(LENGTH (KL::CL-SYMBOLS))
;⇒ 868

(KL::CL-SYMBOLS) ;⇒ (*ERROR-OUTPUT* CALL-ARGUMENTS-LIMIT *PRINT-BASE* MOST-NEGATIVE-SINGLE-FLOAT .... FILL-POINTER DOLIST)

CLパッケージのシンボルって870もあるんですね。

KMRCLを眺める(165) CL-FUNCTIONS

Posted 2010-06-19 05:49:00 GMT

今回は、KMRCLのsymbols.lispからCL-FUNCTIONSです。
前回は、変数のシンボル一覧でしたが、今回は、関数のシンボル一覧のようです。
定義は、

(defun cl-functions ()
  (let ((funcs '()))
    (do-symbols (s 'common-lisp)
      (multiple-value-bind (sym status)
        (find-symbol (symbol-name s) 'common-lisp)
        (when (and (or (eq status :external)
                       (eq status :internal))
                   (fboundp sym))
          (push sym funcs))))
    (nreverse funcs)))
となっていて動作は、
(KL::CL-FUNCTIONS)
;⇒
(DOCUMENTATION PEEK-CHAR UNLESS ENSURE-DIRECTORIES-EXIST 
 FORMAT NSET-DIFFERENCE
 CADADR LABELS TYPE-ERROR-DATUM KEYWORDP FILE-STRING-LENGTH
 LOAD-LOGICAL-PATHNAME-TRANSLATIONS COUNT-IF-NOT ENDP AND LOGORC2
 ADJUSTABLE-ARRAY-P CIS SUBSTITUTE-IF-NOT SYMBOL-PACKAGE
 GET-MACRO-CHARACTER SUBSTITUTE FUNCALL FIND-RESTART REMOVE WRITE
 ECASE CHAR-NOT-GREATERP DEFINE-COMPILER-MACRO FILE-NAMESTRING
 PPRINT-INDENT FILE-ERROR-PATHNAME NULL REMOVE-METHOD ARRAYP
 DESTRUCTURING-BIND COMPILE LOAD STREAM-ERROR-STREAM LOOP
 LISP-IMPLEMENTATION-TYPE FLOAT-DIGITS SET NTH-VALUE
 COMPILER-MACRO-FUNCTION RESTART-CASE CADDDR PPRINT FMAKUNBOUND
 BYTE-SIZE CODE-CHAR WHEN MACHINE-INSTANCE PROG* LIST
 HASH-TABLE-REHASH-THRESHOLD CAADR PATHNAME-NAME TRUNCATE STRING>
 SYMBOL-FUNCTION RASSOC-IF-NOT CHAR ATOM LIST-ALL-PACKAGES LCM 1+
 PACKAGE-USED-BY-LIST FLOAT-SIGN QUOTE CHAR/= LIST* NINTH CDADDR
 CEILING GET READ ECHO-STREAM-OUTPUT-STREAM DEFVAR
 INTEGER-DECODE-FLOAT VECTOR-PUSH-EXTEND PACKAGE-ERROR-PACKAGE
 EQUAL BIT-ANDC2 SOFTWARE-VERSION SLOT-VALUE COPY-READTABLE PROG2
 OR REALP LDB-TEST NSUBSTITUTE NAMESTRING DEFSETF ALPHANUMERICP
 DECF FILE-AUTHOR INTEGERP MAKE-INSTANCES-OBSOLETE
 INVOKE-DEBUGGER SHORT-SITE-NAME FIND-IF COMPILE-FILE-PATHNAME
 LONG-SITE-NAME MAKE-CONDITION REPLACE GETHASH SXHASH REST
 FTRUNCATE PPRINT-TABULAR TENTH STRING-DOWNCASE PPRINT-TAB
 BIT-ORC1 NOTEVERY OUTPUT-STREAM-P SUBST ED FLOOR COPY-SYMBOL
 ASSERT METHOD-COMBINATION-ERROR STRING-LEFT-TRIM USE-VALUE
 MAKE-DISPATCH-MACRO-CHARACTER PROBE-FILE + CDADAR REQUIRE
 COUNT-IF READTABLEP SUBLIS DO-EXTERNAL-SYMBOLS STRING>=
 PRINT-NOT-READABLE-OBJECT CDAR POSITION-IF
 UPDATE-INSTANCE-FOR-DIFFERENT-CLASS LOAD-TIME-VALUE YES-OR-NO-P
 CAR BROADCAST-STREAM-STREAMS PRINT-UNREADABLE-OBJECT ROOM
 CHAR-LESSP DIRECTORY HANDLER-BIND NOT BIT-ORC2 COMPLEX IMPORT
 TIME FDEFINITION < MEMBER-IF-NOT COMPILE-FILE FLET
 SET-EXCLUSIVE-OR REMF * SCALE-FLOAT CAAR MAPCON MAKE-PATHNAME
 UNUSE-PACKAGE COPY-PPRINT-DISPATCH STRING-NOT-EQUAL ATANH
 LOGICAL-PATHNAME-TRANSLATIONS READ-PRESERVING-WHITESPACE CADAAR
 MAKE-ECHO-STREAM SOME PATHNAME-DIRECTORY PSETF
 WITH-COMPILATION-UNIT DIGIT-CHAR LDIFF ARITHMETIC-ERROR-OPERANDS
 APPEND LISTP INTERSECTION MAKE-STRING REINITIALIZE-INSTANCE
 CAADDR ISQRT FRESH-LINE SET-PPRINT-DISPATCH PATHNAME-MATCH-P
 NSTRING-UPCASE PPRINT-FILL SLOT-MISSING CDDADR FILE-WRITE-DATE
 CLRHASH WITH-OPEN-STREAM ASINH FUNCTION-KEYWORDS MEMBER DEFUN
 MAKUNBOUND COPY-TREE SVREF LOGTEST RATIONALP CONJUGATE
 RESTART-NAME ECHO-STREAM-INPUT-STREAM PPRINT-LINEAR
 GET-UNIVERSAL-TIME WRITE-SEQUENCE CONTINUE FIND-IF-NOT
 WITH-OPEN-FILE ARRAY-IN-BOUNDS-P GENTEMP SIMPLE-STRING-P
 ROW-MAJOR-AREF CDAADR HASH-TABLE-REHASH-SIZE
 USER-HOMEDIR-PATHNAME APPLY PATHNAME-TYPE WITH-OUTPUT-TO-STRING
 ARRAY-DIMENSION CONCATENATED-STREAM-STREAMS HASH-TABLE-P
 MULTIPLE-VALUE-LIST FILE-POSITION EQ DEFCONSTANT NSUBSTITUTE-IF
 MAKE-SEQUENCE PPRINT-LOGICAL-BLOCK COUNT DEFINE-CONDITION
 MAKE-SYMBOL BIT ARRAY-ELEMENT-TYPE GET-DECODED-TIME MAX LOGNAND
 GO SUBSETP ARRAY-RANK LOWER-CASE-P RASSOC READ-FROM-STRING
 MEMBER-IF INCF WITH-SLOTS VALUES EVENP CDDDDR
 ENCODE-UNIVERSAL-TIME DELETE-PACKAGE NOTANY CHARACTER NUMBERP
 LOGNOT NTH ETYPECASE PACKAGE-NAME DEFMACRO RANDOM-STATE-P
 DENOMINATOR SUBST-IF MUFFLE-WARNING ALLOCATE-INSTANCE
 CHAR-DOWNCASE TAGBODY PRINC-TO-STRING REVERSE LET SIGNAL
 LIST-LENGTH BLOCK POSITION-IF-NOT GET-PROPERTIES
 UPGRADED-ARRAY-ELEMENT-TYPE DELETE-FILE SINH CCASE
 TRANSLATE-PATHNAME CHAR-EQUAL IMAGPART TAN DELETE-IF-NOT
 SHARED-INITIALIZE ASSOC CTYPECASE WITH-CONDITION-RESTARTS ACOSH
 WITH-PACKAGE-ITERATOR EVAL-WHEN ARRAY-HAS-FILL-POINTER-P
 FUNCTION-LAMBDA-EXPRESSION SLOT-EXISTS-P
 DEFINE-METHOD-COMBINATION CDAAAR READ-CHAR-NO-HANG
 SIMPLE-CONDITION-FORMAT-CONTROL STRING< REDUCE WITH-ACCESSORS
 DIGIT-CHAR-P RATIONAL WRITE-STRING FLOAT-PRECISION
 LISP-IMPLEMENTATION-VERSION LOGANDC2 NUNION
 GET-DISPATCH-MACRO-CHARACTER SETQ NREVERSE ASH
 COMPILED-FUNCTION-P DO* THE COMPLEXP DO-SYMBOLS
 MAKE-CONCATENATED-STREAM GETF >= CONCATENATE IGNORE-ERRORS
 COERCE RATIONALIZE ACONS READ-DELIMITED-LIST WARN
 DELETE-DUPLICATES 1- PPRINT-NEWLINE FLOAT-RADIX
 MAKE-LOAD-FORM-SAVING-SLOTS STRING-NOT-GREATERP CHAR-NOT-EQUAL
 SHADOW ASSOC-IF PRIN1 PRINC ELT ABORT ODDP ASIN / SEARCH SIGNUM
 MAP-INTO FIND-PACKAGE PPRINT-EXIT-IF-LIST-EXHAUSTED REMHASH
 CADAR CHAR-NAME TERPRI WRITE-CHAR EQL CDDR ZEROP MAKE-HASH-TABLE
 MULTIPLE-VALUE-BIND MACROLET PROVIDE MAKE-STRING-OUTPUT-STREAM
 CATCH BIT-XOR LOOP-FINISH > DECODE-FLOAT COPY-LIST
 NSET-EXCLUSIVE-OR PROG STREAM-EXTERNAL-FORMAT POSITION FLOAT
 DEFPARAMETER LOGICAL-PATHNAME CAAAR CHAR-UPCASE NAME-CHAR
 MAKE-LOAD-FORM UNTRACE MAKE-INSTANCE ARRAY-DISPLACEMENT
 SYNONYM-STREAM-SYMBOL WITH-HASH-TABLE-ITERATOR BIT-EQV
 CHARACTERP CLASS-OF BIT-AND TRACE REM MAPCAR CHAR<=
 GET-SETF-EXPANSION STRING<= LOG PPRINT-DISPATCH LOGEQV UNEXPORT
 COMPUTE-APPLICABLE-METHODS WRITE-BYTE DECLAIM FINISH-OUTPUT
 CHAR-NOT-LESSP FUNCTION PACKAGE-SHADOWING-SYMBOLS CLEAR-INPUT
 BIT-IOR ERROR SIMPLE-BIT-VECTOR-P UNWIND-PROTECT DESCRIBE-OBJECT
 READ-SEQUENCE LOGANDC1 MACHINE-VERSION RETURN-FROM EQUALP COS
 MOD BOTH-CASE-P MAKE-BROADCAST-STREAM PUSHNEW PATHNAME
 TREE-EQUAL LDB SOFTWARE-TYPE TAILP CADDR READ-CHAR MISMATCH POP
 STRING-NOT-LESSP NSTRING-DOWNCASE VALUES-LIST CAAADR FIND-CLASS
 RASSOC-IF DIRECTORY-NAMESTRING CLOSE MERGE-PATHNAMES SORT
 NSUBLIS CONSP FIND-SYMBOL NBUTLAST EXP SCHAR CDR DESCRIBE TANH
 UPDATE-INSTANCE-FOR-REDEFINED-CLASS SQRT SHADOWING-IMPORT CERROR
 ENOUGH-NAMESTRING MAPLIST DEFSTRUCT DEFGENERIC READTABLE-CASE
 IN-PACKAGE BOOLE WRITE-TO-STRING GENSYM IDENTITY ROTATEF
 SPECIAL-OPERATOR-P SIN NTHCDR STRING-TRIM EXPT SECOND DPB
 STRING= STRING PRINT-OBJECT Y-OR-N-P NO-NEXT-METHOD DOTIMES
 COMPUTE-RESTARTS SET-DIFFERENCE LOGCOUNT NO-APPLICABLE-METHOD
 CHAR>= CDDAAR MAPL LOGAND MINUSP RENAME-FILE PATHNAMEP
 SET-SYNTAX-FROM-CHAR DELETE-IF TRUENAME MERGE LOGORC1
 MULTIPLE-VALUE-SETQ LET* BIT-NOR LOCALLY SYMBOL-MACROLET NRECONC
 INTERN IF COSH DEFMETHOD STRING-GREATERP INPUT-STREAM-P
 PATHNAME-VERSION BREAK WILD-PATHNAME-P NCONC FFLOOR REMPROP
 CDADR UNION INSPECT MACROEXPAND-1 INTEGER-LENGTH SLEEP
 VECTOR-PUSH LOGNOR CHAR> DEFINE-SYMBOL-MACRO PUSH OPEN-STREAM-P
 PROG1 RETURN UPGRADED-COMPLEX-PART-TYPE
 TWO-WAY-STREAM-INPUT-STREAM - ATAN SHIFTF LAMBDA
 SET-MACRO-CHARACTER PATHNAME-HOST MAPHASH CHAR-INT NSUBST-IF
 DEFINE-SETF-EXPANDER WRITE-LINE SETF MAPC RPLACA FILL
 MULTIPLE-VALUE-CALL TYPE-OF CDDDAR DRIBBLE CHANGE-CLASS CHAR<
 ROUND PAIRLIS THROW MACROEXPAND SIMPLE-VECTOR-P CONSTANTLY PHASE
 WITH-INPUT-FROM-STRING APROPOS SLOT-BOUNDP CLEAR-OUTPUT TYPEP
 BIT-NOT MULTIPLE-VALUE-PROG1 STEP ENSURE-GENERIC-FUNCTION
 STREAMP FOURTH SYMBOLP SET-DISPATCH-MACRO-CHARACTER STRING-LESSP
 VECTOR NSUBST SYMBOL-NAME BOUNDP FUNCTIONP CASE FLOATP
 REMOVE-DUPLICATES MAKE-STRING-INPUT-STREAM MACHINE-TYPE MIN
 SUBSEQ STRINGP ADJOIN TRANSLATE-LOGICAL-PATHNAME PSETQ
 PPRINT-POP STRING-RIGHT-TRIM FIND-ALL-SYMBOLS
 GET-OUTPUT-STREAM-STRING CAAAAR BYTE HASH-TABLE-TEST
 SUBST-IF-NOT INVOKE-RESTART-INTERACTIVELY DO PACKAGE-USE-LIST
 UPPER-CASE-P STABLE-SORT HOST-NAMESTRING STANDARD-CHAR-P
 DO-ALL-SYMBOLS EIGHTH OPEN READ-BYTE HANDLER-CASE FORMATTER
 PACKAGE-NICKNAMES ARITHMETIC-ERROR-OPERATION REMOVE-IF
 BYTE-POSITION COPY-SEQ RESTART-BIND GET-INTERNAL-RUN-TIME THIRD
 CAADAR NSUBSTITUTE-IF-NOT PROCLAIM MAPCAN MAKE-SYNONYM-STREAM
 VECTORP LOGXOR = UNBOUND-SLOT-INSTANCE PRINT NINTERSECTION
 SIMPLE-CONDITION-FORMAT-ARGUMENTS GCD DEFINE-MODIFY-MACRO
 FCEILING TYPECASE CALL-METHOD FORCE-OUTPUT CADR ARRAY-TOTAL-SIZE
 UNREAD-CHAR PATHNAME-DEVICE STRING/= REMOVE-IF-NOT EXPORT
 SLOT-MAKUNBOUND <= PROGN NUMERATOR REALPART DEFCLASS CONS
 HASH-TABLE-COUNT GRAPHIC-CHAR-P PACKAGEP ALPHA-CHAR-P
 MAKE-RANDOM-STATE LISTEN STRING-UPCASE CADDAR COPY-ALIST SIXTH
 REVAPPEND SYMBOL-VALUE SEVENTH DISASSEMBLE COND SBIT
 TYPE-ERROR-EXPECTED-TYPE BIT-ANDC1 PARSE-INTEGER LOGIOR
 MAKE-ARRAY BIT-NAND INTERACTIVE-STREAM-P BIT-VECTOR-P
 SLOT-UNBOUND APROPOS-LIST FBOUNDP NSTRING-CAPITALIZE
 WITH-SIMPLE-RESTART AREF ASSOC-IF-NOT COMPLEMENT PROGV FROUND
 ARRAY-ROW-MAJOR-INDEX MAKE-TWO-WAY-STREAM STRING-EQUAL
 NSUBST-IF-NOT PLUSP EVERY STREAM-ELEMENT-TYPE CONSTANTP
 FIND-METHOD DELETE CDDAR FILE-LENGTH PARSE-NAMESTRING
 MAKE-PACKAGE READ-LINE DEPOSIT-FIELD ABS RENAME-PACKAGE
 CHECK-TYPE INVOKE-RESTART HASH-TABLE-SIZE USE-PACKAGE RANDOM
 PRIN1-TO-STRING LAST TWO-WAY-STREAM-OUTPUT-STREAM
 ARRAY-DIMENSIONS WITH-STANDARD-IO-SYNTAX MACRO-FUNCTION CHAR=
 LOGBITP UNINTERN COPY-STRUCTURE MASK-FIELD VECTOR-POP
 SYMBOL-PLIST CHAR-CODE METHOD-QUALIFIERS ADJUST-ARRAY DEFPACKAGE
 CDDDR INVALID-METHOD-ERROR CELL-ERROR-NAME CLASS-NAME RPLACD
 CHAR-GREATERP MAKE-LIST INITIALIZE-INSTANCE STRING-CAPITALIZE
 MAP STORE-VALUE ADD-METHOD ACOS FIFTH SUBTYPEP DEFTYPE BUTLAST
 LENGTH /= EVAL CDAAR DECODE-UNIVERSAL-TIME
 GET-INTERNAL-REAL-TIME FIND SUBSTITUTE-IF FIRST FILL-POINTER
 DOLIST)

KMRCLを眺める(164) CL-VARIABLES

Posted 2010-06-16 05:05:00 GMT

functions.lispも終了したので、今回からは、KMRCLのsymbols.lisp眺めることにしました。
ということで、symbols.lispから CL-VARIABLES です。
定義を眺める限りでは、CLパッケージの中から変数が束縛されたシンボルを抜き出すもののようです。

(defun cl-variables ()
  (let ((vars '()))
    (do-symbols (s 'common-lisp)
      (multiple-value-bind (sym status)
          (find-symbol (symbol-name s) 'common-lisp)
        (when (and (or (eq status :external)
                       (eq status :internal))
                   (boundp sym))
          (push sym vars))))
    (nreverse vars)))
動作は、
(KL:CL-VARIABLES)
;⇒ 
(*ERROR-OUTPUT* CALL-ARGUMENTS-LIMIT *PRINT-BASE* MOST-NEGATIVE-SINGLE-FLOAT
 *LOAD-PRINT* *GENSYM-COUNTER* BOOLE-ANDC1 BOOLE-C2 LEAST-NEGATIVE-SINGLE-FLOAT
 ARRAY-TOTAL-SIZE-LIMIT LONG-FLOAT-EPSILON *PRINT-RADIX* *PRINT-CASE*
 LEAST-POSITIVE-NORMALIZED-SHORT-FLOAT ARRAY-RANK-LIMIT +
 LEAST-POSITIVE-DOUBLE-FLOAT *** MOST-NEGATIVE-LONG-FLOAT DOUBLE-FLOAT-EPSILON
 * *LOAD-VERBOSE* CHAR-CODE-LIMIT LEAST-NEGATIVE-LONG-FLOAT
 MOST-POSITIVE-LONG-FLOAT BOOLE-AND BOOLE-ORC2 MOST-NEGATIVE-FIXNUM
 *PRINT-CIRCLE* *RANDOM-STATE* INTERNAL-TIME-UNITS-PER-SECOND *STANDARD-INPUT*
 *COMPILE-FILE-TRUENAME* NIL PI MOST-POSITIVE-DOUBLE-FLOAT
 LEAST-NEGATIVE-NORMALIZED-SINGLE-FLOAT SINGLE-FLOAT-NEGATIVE-EPSILON
 *QUERY-IO* LEAST-NEGATIVE-NORMALIZED-SHORT-FLOAT *LOAD-PATHNAME*
 LEAST-NEGATIVE-SHORT-FLOAT DOUBLE-FLOAT-NEGATIVE-EPSILON BOOLE-NAND
 *PRINT-ARRAY* T *PRINT-LEVEL* *PRINT-GENSYM* MOST-NEGATIVE-SHORT-FLOAT
 BOOLE-C1 *PACKAGE* /// BOOLE-XOR *DEBUG-IO* / +++ // BOOLE-IOR
 LAMBDA-LIST-KEYWORDS MOST-POSITIVE-FIXNUM ** *LOAD-TRUENAME*
 LEAST-POSITIVE-LONG-FLOAT *PRINT-LINES* SINGLE-FLOAT-EPSILON
 LAMBDA-PARAMETERS-LIMIT MOST-POSITIVE-SINGLE-FLOAT *PRINT-LENGTH*
 SHORT-FLOAT-EPSILON *FEATURES* MULTIPLE-VALUES-LIMIT *COMPILE-VERBOSE*
 *COMPILE-PRINT* MOST-NEGATIVE-DOUBLE-FLOAT *READTABLE* *READ-SUPPRESS*
 *PRINT-RIGHT-MARGIN* *MODULES* LEAST-NEGATIVE-DOUBLE-FLOAT
 SHORT-FLOAT-NEGATIVE-EPSILON BOOLE-NOR - BOOLE-ANDC2 *TRACE-OUTPUT*
 *STANDARD-OUTPUT* LEAST-POSITIVE-SINGLE-FLOAT
 LEAST-POSITIVE-NORMALIZED-LONG-FLOAT LEAST-POSITIVE-SHORT-FLOAT BOOLE-2
 LONG-FLOAT-NEGATIVE-EPSILON BOOLE-SET LEAST-POSITIVE-NORMALIZED-SINGLE-FLOAT
 LEAST-NEGATIVE-NORMALIZED-LONG-FLOAT *PRINT-PRETTY* *PRINT-PPRINT-DISPATCH*
 BOOLE-EQV *PRINT-ESCAPE* *PRINT-MISER-WIDTH* *READ-BASE* *PRINT-READABLY*
 *COMPILE-FILE-PATHNAME* ARRAY-DIMENSION-LIMIT *DEBUGGER-HOOK*
 MOST-POSITIVE-SHORT-FLOAT LEAST-NEGATIVE-NORMALIZED-DOUBLE-FLOAT BOOLE-1
 *READ-DEFAULT-FLOAT-FORMAT* ++ *READ-EVAL* BOOLE-ORC1
 LEAST-POSITIVE-NORMALIZED-DOUBLE-FLOAT *TERMINAL-IO* *MACROEXPAND-HOOK*
 *DEFAULT-PATHNAME-DEFAULTS* BOOLE-CLR *BREAK-ON-SIGNALS*)
といったところ。
上のコードを眺めていて、CLパッケージが他を継承していることなんてあるんだろうかと、SBCL/Allegro CL/CCL/XCL/CLISPで CLパッケージ内の :INHERITED を探してみましたが
(let ((vars '()))
  (do-symbols (s 'common-lisp)
    (multiple-value-bind (sym status)
        (find-symbol (symbol-name s) 'common-lisp)
      (when (and (eq status :INHERITED)
                 (boundp sym))
        (push sym vars))))
  (nreverse vars))
;⇒ NIL
でした。
処理系が処理系依存の(CL標準でない)シンボルをCLパッケージにどっかから(CL-INTERNALとかから)継承していたら、:INHERITEDなシンボルがあったりするんでしょうか。

KMRCLを眺める(163) COMPOSE

Posted 2010-06-13 05:09:00 GMT

今回は、KMRCLのfunctions.lispからCOMPOSEです。
COMPOSEは割と有名な関数のようで、CURRY等と同じく色々なライブラリで提供されていることが多いです。
ポール・グレアムのANSI Common Lispでは、Dylanからの引用として紹介されていました。
実際Dylanには標準で用意されていますが、この辺りから広がったのでしょうか。どうでも良いことですが、どの辺りが起源か知りたいです。
動作は、

(MAPCAR (KL:COMPOSE #'INTERN #'STRING-DOWNCASE)
        (LISTQ A B C D))
;⇒ (|a| |b| |c| |d|)
という風に、関数を合体してゆけます。
定義は、
(defun compose (&rest fns)
  (if fns
      (let ((fn1 (car (last fns)))
            (fns (butlast fns)))
        #'(lambda (&rest args)
            (reduce #'funcall fns
                    :from-end t
                    :initial-value (apply fn1 args))))
      #'identity))
という風になっています。
同じCOMPOSEでもライブラリによって定義が違っているので眺めてみると面白いかもしれません。

KMRCLを眺める(162) _F

Posted 2010-06-10 11:16:00 GMT

今回は、KMRCLのfunctions.lispから_Fです。
実装を眺める限り、_FのFはSETFのFから来ているようです。

(defmacro _f (op place &rest args)
  (multiple-value-bind (vars forms var set access)
                       (get-setf-expansion place)
    `(let* (,@(mapcar #'list vars forms)
            (,(car var) (,op ,access ,@args)))
       ,set)))
という風にGET-SETF-EXPANSIONを使っています
使い方は、APPENDFを例にすると、
(LET ((X (LIST 1 2 3 4)))
  (LISPWORKS:APPENDF X (LIST 10 20 30 40))
  X)
;⇒ (1 2 3 4 10 20 30 40)
というところを
;; APPENDF
(LET ((X (LIST 1 2 3 4)))
  (KL:_F APPEND X (LIST 10 20 30 40))
  X)
;⇒ (1 2 3 4 10 20 30 40)
と書けます。
_Fは、Arcいうzapと同じ動きですね。
;; Arc
(let x (list 1 2 3 4)
  (zap + x (list 10 20 30 40))
  x)
;⇒ (1 2 3 4 10 20 30 40)
TAOにもこういうのがあって、
(let ((x (list 1 2 3 4)))
  (!!append !x (list 10 20 30 40))
  X)
;⇒ (1 2 3 4 10 20 30 40)
と書けます。
TAOは、任意に!で代入先を指示できたりするので、より高機能!

KMRCLを眺める(161) DEFUN-MEMO

Posted 2010-06-08 04:48:00 GMT

今回は、KMRCLのfunctions.lispからDEFUN-MEMOです。
前回のMEMOIZEを利用していますが、メモワイズ機能を付きのDEFUNというところです。
定義は、

(defmacro defun-memo (fn args &body body)
  "Define a memoized function"
  `(memoize (defun ,fn ,args . ,body)))
になっていて、DEFUNの返り値を使っているというのは珍しいですね。
(KL:DEFUN-MEMO FIB (N)
  (IF (< N 2)
      N
      (+ (FIB (1- N))
         (FIB (- N 2)))))

(FIB 100) ;⇒ 354224848179261915075

DEFUNを置き換えるだけで簡単にメモ化版関数が定義されます。

KMRCLを眺める(160) MEMOIZE

Posted 2010-06-03 22:55:00 GMT

今回は、KMRCLのfunctions.lispからMEMOIZEです。
前回のMEMO-PROCを利用して既存の関数をメモ化版にするものです。
定義は、

(defun memoize (fn-name)
  (setf (fdefinition fn-name) (memo-proc (fdefinition fn-name))))
動作は、
(DEFUN FIB (N)
  (IF (< N 2)
      N
      (+ (FIB (1- N))
         (FIB (- N 2)))))

;; トレース (TRACE FIB)

(FIB 5) 0: (FIB 5) 1: (FIB 4) 2: (FIB 3) 3: (FIB 2) 4: (FIB 1) 4: FIB returned 1 4: (FIB 0) 4: FIB returned 0 3: FIB returned 1 3: (FIB 1) 3: FIB returned 1 2: FIB returned 2 2: (FIB 2) 3: (FIB 1) 3: FIB returned 1 3: (FIB 0) 3: FIB returned 0 2: FIB returned 1 1: FIB returned 3 1: (FIB 3) 2: (FIB 2) 3: (FIB 1) 3: FIB returned 1 3: (FIB 0) 3: FIB returned 0 2: FIB returned 1 2: (FIB 1) 2: FIB returned 1 1: FIB returned 2 0: FIB returned 5 ;⇒ 5

;; メモ化発動 (KL:MEMOIZE 'FIB)

(FIB 5) 0: (FIB 5) 1: (FIB 4) 2: (FIB 3) 3: (FIB 2) 4: (FIB 1) 4: FIB returned 1 4: (FIB 0) 4: FIB returned 0 3: FIB returned 1 3: (FIB 1) 3: FIB returned 1 2: FIB returned 2 2: (FIB 2) 2: FIB returned 1 1: FIB returned 3 1: (FIB 3) 1: FIB returned 2 0: FIB returned 5 ;⇒ 5

といったところで、FIBをメモ化すると関数の呼び出しが減るのが分かると思います。

KMRCLを眺める(159) MEMO-PROC

Posted 2010-06-01 22:56:00 GMT

ifstar.lispの次のファイルということで、今回は、KMRCLのfunctions.lispからMEMO-PROCです。
MEMO-PROCはをメモワイズ関数化する関数です。
定義は、

(defun memo-proc (fn)
  "Memoize results of call to fn, returns a closure with hash-table"
  (let ((cache (make-hash-table :test #'equal)))
    #'(lambda (&rest args)
        (multiple-value-bind (val foundp) (gethash args cache)
          (if foundp
              val
            (setf (gethash args cache) (apply fn args)))))))
となっています。
引数とその結果が登録されたハッシュ表を引き、結果が既に登録されていれば、その値を返し、なければ計算というしくみで、割と定番かと思います。
動作は、
(DEFUN FIB (N)
  (IF (< N 2)
      N
      (+ (FIB (1- N))
         (FIB (- N 2)))))

(SETF (FDEFINITION 'FIB) ;既にあるFIBを置き換え (KL:MEMO-PROC #'FIB))

(FIB 100) ;⇒ 354224848179261915075

といったところ。

KMRCLを眺める(158) IF*

Posted 2010-05-29 09:41:00 GMT

web-utils.lispも眺め終わったので、次のファイルということで、今回は、KMRCLのifstar.lispからIF*です。
if*は、KMRCLで定義されているというよりは、Franz社がパブリックドメインで公開しているもので、KMRCL内でもexportはされていません。
kmr氏はAllegro CLを良く使っているのか、Allegro向けの定義が良く見掛けられます。
if*なんて邪道、という意見も聞いたことがあるのですが、if*は、FranzLispのifに由来するようなので、Franz社が独自にCLを拡張しようとしているというより社内の伝統なのかもしれません。
(ちなみにFranzLispでは大文字と小文字を区別するので、大文字と小文字を区別するAllegro CLのmlispも、また伝統というかこだわりなのかもしれません)
オリジナルのFranzLispの説明では、

;--- if :: macro for doing conditionalization
;
;  This macro is compatible with both the crufty mit-version and
; the keyword version at ucb.
;
;  simple summary:
;   non-keyword use:
;	(if a b) ==> (cond (a b))
;	(if a b c d e ...) ==> (cond (a b) (t c d e ...))
;   with keywords:
;	(if a then b) ==> (cond (a b))
;	(if a thenret) ==> (cond (a))
;	(if a then b c d e) ==> (cond (a b c d e))
;	(if a then b c  else d) ==> (cond (a b c) (t d))
;	(if a then b c  elseif d  thenret  else g)
;		==> (cond (a b c) (d) (t g))
となっていてIF一つでMIT方式とFranz(UCB)方式の両方の書式に対応できたようです。
使われ方としては、
(IMPORT 'KL::IF*)
(DEFUN S= (S1 S2)
  (AND (STRING= S1 S2) S1))

(let ((s "3")) (if* (s= "1" s) thenret elseif (s= "2" s) thenret elseif (s= "3" s) thenret)) ;⇒ "3"

(let ((s "3")) (if* (string= "1" s) then 1 elseif (string= "2" s) then 2 elseif (string= "3" s) then 3)) ;⇒ 3 (let ((s "3")) (if* (s= "1" s) :thenret :elseif (s= "2" s) :thenret :elseif (s= "3" s) :thenret)) ;⇒ "3"

というところでしょうか。
IF*はCONDに展開されるのですが、CONDの述語部での返り値を利用するTHENRETが使が使えます。
CONDだとスタイル上あまりこの値を利用するのは好ましくないようですが、THENRETと名前が付けば割と見通しも良いのでたまに便利に使えそうでもあります。
ただCONDの述語部では、返り値は多値で返らないので、その辺りに留意する必要がありそうです。

折角なので、インデントにもこだわって行きたいところですが、FranzLispのソースを眺めると
+thenや、elseは行に単独で現われない
+thenや、else、thenretはif*の述語の一個前か、同じ位置から開始
+elseifはif*と同じ位置から開始
とすることが多いようです。
また、CL版は、文字列として比較しているので、キーワードでもOKです。
定義は、
;; the if* macro used in Allegro:
;;
;; This is in the public domain... please feel free to put this definition
;; in your code or distribute it with your version of lisp.

(in-package #:kmrcl)

(eval-when (:compile-toplevel :load-toplevel :execute) (defvar if*-keyword-list '("then" "thenret" "else" "elseif")))

(defmacro if* (&rest args) (do ((xx (reverse args) (cdr xx)) (state :init) (elseseen nil) (totalcol nil) (lookat nil nil) (col nil)) ((null xx) (cond ((eq state :compl) `(cond ,@totalcol)) (t (error "if*: illegal form ~s" args)))) (cond ((and (symbolp (car xx)) (member (symbol-name (car xx)) if*-keyword-list :test #'string-equal)) (setq lookat (symbol-name (car xx)))))

(cond ((eq state :init) (cond (lookat (cond ((string-equal lookat "thenret") (setq col nil state :then)) (t (error "if*: bad keyword ~a" lookat)))) (t (setq state :col col nil) (push (car xx) col)))) ((eq state :col) (cond (lookat (cond ((string-equal lookat "else") (cond (elseseen (error "if*: multiples elses"))) (setq elseseen t) (setq state :init) (push `(t ,@col) totalcol)) ((string-equal lookat "then") (setq state :then)) (t (error "if*: bad keyword ~s" lookat)))) (t (push (car xx) col)))) ((eq state :then) (cond (lookat (error "if*: keyword ~s at the wrong place " (car xx))) (t (setq state :compl) (push `(,(car xx) ,@col) totalcol)))) ((eq state :compl) (cond ((not (string-equal lookat "elseif")) (error "if*: missing elseif clause "))) (setq state :init)))))

となっています。
オリジナルのFranzLispifのコメント文によると4つの状態を持つシンプルなオートマトンになっているとのこと
最初に本体部がREVERSEされて渡されるのでわかりづらいですが、
+init: 完全なパーズ済みのボディか、then節を持った状態
+col: 次のif*のキーワードを待っている状態
+then: thenの直後で次にくる述語を待っている状態
+compl: thenの直後の述語をみた状態で、elseifか終了を待っている状態
の4つの変数で表わされているようです。

再帰で書いたら分かりやすくなるのかなと思い書き直しつつ、thenretで多値も扱えるようにしてみました
(eval-when (:compile-toplevel :load-toplevel :execute)
  (defvar if**-keyword-list '("then" "thenret" "else" "elseif")))

(defmacro IF** (&body body) (multiple-value-bind (body thenret-vars) (parse-if :INIT (reverse body) nil () () () ) (if thenret-vars `(LET ,thenret-vars (COND ,@body)) `(COND ,@body))))

(eval-when (:compile-toplevel :load-toplevel :execute) (defun parse-if (state args elseseen col totalcol thenret-vars) (if (endp args) (if (eq state :compl) (values totalcol thenret-vars) (error "if*: illegal form ~s" args)) (let ((lookat (if (and (symbolp (car args)) (member (symbol-name (car args)) if**-keyword-list :test #'string-equal)) (intern (symbol-name (car args)) :keyword) :non-keyword)) (xx (car args)) (next (cdr args))) (case state (:INIT (case lookat (:non-keyword (parse-if :COL next elseseen (list xx) totalcol thenret-vars)) (:thenret (let ((ret (gensym))) (parse-if :THEN `((car (setq ,ret (multiple-value-list ,(car next)))) ,@(cdr next)) elseseen `((values-list ,ret)) totalcol (cons ret thenret-vars)))) (otherwise (error "if*: bad keyword ~a" lookat)))) (:COL (case lookat (:else (when elseseen (error "if*: multiples elses")) (parse-if :INIT next 'T col `((t ,@col) ,@totalcol) thenret-vars)) (:non-keyword (parse-if :COL next elseseen (cons xx col) totalcol thenret-vars)) (:then (parse-if :THEN next elseseen col totalcol thenret-vars)) (otherwise (error "if*: bad keyword ~s" lookat)))) (:THEN (case lookat (:NON-KEYWORD (parse-if :COMPL next elseseen xx `((,xx ,@col) ,@totalcol) thenret-vars)) (otherwise (error "if*: keyword ~s at the wrong place " xx)))) (:COMPL (case lookat (:elseif (parse-if :INIT next elseseen col totalcol thenret-vars)) (otherwise (error "if*: missing elseif clause ")))))))))

(if** (values 42 nil)
     thenret
 elseif (values nil nil)
     thenret
     else 'foo)
のようなものは、
(LET (#:G2955 #:G2954)
  (COND
    ((CAR (SETQ #:G2955 (MULTIPLE-VALUE-LIST (VALUES 42 NIL))))
     (VALUES-LIST #:G2955))
    ((CAR (SETQ #:G2954 (MULTIPLE-VALUE-LIST (VALUES NIL NIL))))
     (VALUES-LIST #:G2954))
    (T 'FOO)))
と展開されます。
しかし、再帰で書きなおしたものの想像したよりも分かりやすくなってもおらず…。

KMRCLを眺める(157) SPLIT-URI-QUERY-STRING

Posted 2010-05-25 23:00:00 GMT

今回は、KMRCLのweb-utils.lispからSPLIT-URI-QUERY-STRINGです。
foo=1&bar=2&baz=3のようなクエリパラメータをalistにして返す関数のようで動作は、

(KL:SPLIT-URI-QUERY-STRING "foo=1&bar=2&baz=3")
;⇒ (("foo" . "1") ("bar" . "2") ("baz" . "3"))
のような感じです。
定義は、
(defun split-uri-query-string (s)
  (mapcar
   (lambda (pair)
     (let ((pos (position #\= pair)))
       (when pos
         (cons (subseq pair 0 pos)
               (when (> (length pair) pos)
                 (decode-uri-query-string (subseq pair (1+ pos))))))))
   (delimited-string-to-list s #\&)))
となっていて、
(KL:DELIMITED-STRING-TO-LIST "foo=1&bar=2&baz=3" #\&)
;⇒ ("foo=1" "bar=2" "baz=3")
して、POSITIONで#\=の位置を割り出し、SUBSEQで前半と後半を切り出しつつDECODE-URI-QUERY-STRINGもするというところです。

KMRCLを眺める(156) DECODE-URI-QUERY-STRING

Posted 2010-05-24 05:09:00 GMT

今回は、KMRCLのweb-utils.lispからDECODE-URI-QUERY-STRINGです。
エンコードされたURIをデコードするというもので以前眺めた、strings.lispのDECODE-URI-STRINGと殆ど同じですが、クエリ部分を想定しているので+の解釈が違っています。

(SET' URI "foo%2Fbar%2Fbaz+quux")

(KL:DECODE-URI-STRING URI) ⇒ "foo/bar/baz+quux"

(KL:DECODE-URI-QUERY-STRING URI) ⇒ "foo/bar/baz quux"

定義は、
(defun decode-uri-query-string (s)
  "Decode a URI query string field"
  (declare (simple-string s)
           (optimize (speed 3) (safety 0) (space 0)))
  (do* ((old-len (length s))
        (new-len (- old-len (* 2 (the fixnum (count-string-char s #\%)))))
        (new (make-string new-len))
        (p-old 0)
        (p-new 0 (1+ p-new)))
       ((= p-new new-len) new)
    (declare (simple-string new)
             (fixnum p-old p-new old-len new-len))
         (let ((c (schar s p-old)))
           (when (char= c #\+)
             (setq c #\space))
           (case c
             (#\%
              (unless (>= old-len (+ p-old 3))
                (error "#\% not followed by enough characters"))
              (setf (schar new p-new)
                    (code-char
                     (parse-integer (subseq s (1+ p-old) (+ p-old 3))
                                    :radix 16)))
              (incf p-old 3))
             (t
              (setf (schar new p-new) c)
              (incf p-old))))))
となっていますが、これも大体DECODE-URI-STRINGと同じです。

KMRCLを眺める(155) MAKE-URL

Posted 2010-05-21 09:39:00 GMT

今回は、KMRCLのweb-utils.lispからMAKE-URLです。
名前のとおりURLを生成するのに利用します。
使い方は、

(KL:MAKE-URL "page" 
             :FORMAT :HTML
             :VARS '(("foo" . "1")
                     ("bar" . "2"))
             :ANCHOR "baz")
;⇒ "http://example.com/page?foo=1&bar=2#baz"
という風に、パラメータをalist、アンカを文字列で渡せます
定義は、
(defun make-url (page-name &key (base-dir *base-url*) (format :html) vars anchor)
  (let ((amp (case format
               (:html
                "&")
               ((:xml :ie-xml)
                "&amp;"))))
    (concatenate 'string
      base-dir page-name
      (if vars
          (let ((first-var (first vars)))
            (concatenate 'string
              "?"  (car first-var) "=" (cdr first-var)
              (mapcar-append-string
               #'(lambda (var)
                   (when (and (car var) (cdr var))
                     (concatenate 'string
                       amp (string-downcase (car var)) "=" (cdr var))))
               (rest vars))))
        "")
      (if anchor
          (concatenate 'string "#" anchor)
        ""))))
MAPCAR-APPEND-STRINGは以前眺めたKMRCL内のlists.lispで定義されています。

KMRCLを眺める(154) BASE-URL!

Posted 2010-05-18 12:36:00 GMT

今回は、KMRCLのweb-utils.lispからBASE-URL!です。
名前のとおりユーティリティで使うベースのURLを設定するもののようで、定義はずばり

;;; URL Functions
(defvar *base-url* "")
(defun base-url! (url)
  (setq *base-url* url))
となっています。
使い方は、
(KL:BASE-URL! "http://example.com/")

KL:*BASE-URL* ;=> "http://example.com/"

です。大域変数にアクセサを定義しているというところでしょうか。
(setq kl:*base-url* "http://example.com/")
よりは見通しが良さそうです。

KMRCLを眺める(153) USER-AGENT-IE-P

Posted 2010-05-15 08:09:00 GMT

今回は、KMRCLのweb-utils.lispからUSER-AGENT-IE-Pです。
名前のとおりユーザーエージェントがIEかどうかを判定するもののようで定義は、

;;; User agent functions

(defun user-agent-ie-p (agent) "Takes a user-agent string and returns T for Internet Explorer." (or (string-starts-with "Microsoft" agent) (string-starts-with "Internet Explore" agent) (search "Safari" agent) (search "MSIE" agent)))

となっていますが、なぜSafafiを判定しているのかは謎です。そういうものなのでしょうか。
動作例は、
(KL:USER-AGENT-IE-P "127.0.0.1 - - [15/May/2010:15:48:22 +0900] \"GET / HTTP/1.0\" 200 359 \"-\" \"Mozilla/4.0 (compatible; MSIE 6.0; Windows 98)")
;=> 98
となっていて、98が帰ってくると若干混乱しますが、上記の例の場合、SEARCHの結果がそのまま帰ってきているのでこうなっています。
また、KMRCL内で定義したstring-starts-withも利用されています。

KMRCLを眺める(152) HTML/XML constants

Posted 2010-05-13 04:56:00 GMT

strings.lispは眺め終わったので次はどれにしようかというところですが、手軽なところで、web-utils.lispにしてみることにしました。
ウェブプログラミングで使うようなちょっとしたユーティリティといったところです。
ということで、今回は、KMRCLのweb-utils.lispからHTML/XML constantsです。
HTML/XMLで良く使いそうな、定数を定義しています。

;;; HTML/XML constants

(defvar *standard-xml-header* #.(format nil "<?xml version=\"1.0\" encoding=\"iso-8859-1\" standalone=\"yes\"?>~%"))

(defvar *standard-html-header* "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML//EN\">")

(defvar *standard-xhtml-header* #.(format nil "<?xml version=\"1.0\" encoding=\"iso-8859-1\" standalone=\"yes\"?>~%<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\" \"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\">"))

リード時に評価して文字列にしているのは分かるのですが、FORMAT式の中身に評価して展開されるものがないので、ちょっと不思議です。
展開されるものといえば、Newline(~%)位ですが、これが状況によって違ってくる可能性があるからでしょうか。
もしくは、ファイル中の改行を問題と考えているのか…。

KMRCLを眺める(151) ESCAPE-BACKSLASHES

Posted 2010-05-11 05:13:00 GMT

今回もKMRCLのstring.lispの残り、ESCAPE-BACKSLASHESです。
strings.lispも今回で最後。
動作は、

(KL:ADD-SQL-QUOTES "foo'")
⇒ "foo''"
という風に、クォートを二重にして返します。
定義は、
(defun add-sql-quotes (s)
  (substitute-string-for-char s #\' "''"))
となっていて、内部では、 SUBSTITUTE-CHARS-STRINGS を利用しています。

KMRCLを眺める(150) ESCAPE-BACKSLASHES

Posted 2010-05-09 10:20:00 GMT

今回もKMRCLのstring.lispの残り、ESCAPE-BACKSLASHESです。
動作は、

(KL:ESCAPE-BACKSLASHES "foo\\bar\\baz")
⇒ "foo\\\\bar\\\\baz"
というところで、名前のとおりバックスラッシュをエスケープ処理した文字列を返します
定義は、
(defun escape-backslashes (s)
  (substitute-string-for-char s #\\ "\\\\"))
となっていて、内部では、 SUBSTITUTE-CHARS-STRINGS を利用してバックスラッシュを追加しています。

自分もすっかり忘れていたのですが、CLでは、文字列中のバックスラッシュ(とダブルクォート)はエスケープして表現する必要があります。
(LENGTH "123\456\7890")
;⇒ 10

(LENGTH "123\\456\\7890") ;⇒ 12

ちなみに、シンボルの場合も似ていますが、文字列とシンボルでは、ダブルクォートとパイプの役割が逆転した感じになっています。
'|"|
;⇒ |"|

"|" ;⇒ "|"

'|\|| ;⇒ |\||

"\"" ;⇒ "\""

"\\" ;⇒ "\\"

'|\\| ;⇒ |\\|

'|"\foo"| ;⇒ |"foo"|

"|\foo|" ;⇒ "|foo|"


KMRCLを眺める(149) SUBSTITUTE-STRING-FOR-CHAR

Posted 2010-05-05 06:18:00 GMT

今回もKMRCLのstring.lispの残り、SUBSTITUTE-STRING-FOR-CHARです。
動作は、

(SUBSTITUTE-STRING-FOR-CHAR "foo bar baz" #\Space "    ")
⇒ "foo    bar    baz"
というところで、指定した文字を指定した文字列に置換します。
定義は、
(defun substitute-string-for-char (procstr match-char subst-str)
  "Substitutes a string for a single matching character of a string"
  (substitute-chars-strings procstr (list (cons match-char subst-str))))
となっていて、内部では、 SUBSTITUTE-CHARS-STRINGS を利用しています。

KMRCLを眺める(148) TRIM-NON-ALPHANUMERIC

Posted 2010-05-03 06:53:00 GMT

前回で一通りstring.lispは眺め終わったと思ったのですが、何点か抜かしていたようなので、順番が前後しつつ、今回はKMRCLのTRIM-NON-ALPHANUMERICです。
動作は、

;; SBCL
(MAPCAR #'KL:TRIM-NON-ALPHANUMERIC
        '("いろはにほへど、"
          "   ちりぬるを、"
          " わかよたれそ、"
          "        つねならむ"))
;⇒ ("いろはにほへど" "ちりぬるを" "わかよたれそ" "つねならむ")
というところで、STRING-TRIMとNON-ALPHANUMERICPが合体したようなもの。
定義は、
(defun trim-non-alphanumeric (word)
  "Strip non-alphanumeric characters from beginning and end of a word."
  (declare (simple-string word)
           (optimize (speed 3) (safety 0) (space 0)))
  (let* ((start 0)
         (len (length word))
         (end len))
    (declare (fixnum start end len))
    (do ((done nil))
        ((or done (= start end)))
      (if (alphanumericp (schar word start))
          (setq done t)
        (incf start)))
    (when (> end start)
      (do ((done nil))
          ((or done (= start end)))
        (if (alphanumericp (schar word (1- end)))
            (setq done t)
          (decf end))))
    (if (or (plusp start) (/= len end))
        (subseq word start end)
      word))
となっていて、左端を算出して、次に右を算出して、SUBSEQで切り出しという感じです。

TRIM-NON-ALPHANUMERICを眺めていて、STRING-TRIM-IFのようなものを誰か考えていそうだなあ、と思ったので調べてみると、METATILITIESに定義がありました。
(MAPCAR (CURRY #'metatilities:STRING-TRIM-IF
               (COMPLEMENT #'ALPHANUMERICP))
        '("いろはにほへど、"
          "   ちりぬるを、"
          " わかよたれそ、"
          "        つねならむ"))
;⇒ ("いろはにほへど" "ちりぬるを" "わかよたれそ" "つねならむ")
個人的にはこういう方がすっきりしてて好みです。

KMRCLを眺める(147) STRING->LIST

Posted 2010-05-01 06:57:00 GMT

今回はKMRCLのstrings.lispから、STRING->LISTです。
名前からすると、(coerce 文字列 'list)の別名かと思えますが、動作は、

(KL:STRING->LIST "いろはにほへと")
⇒ (いろはにほへと)

(KL:STRING->LIST "foo bar baz") ⇒ (FOO BAR BAZ)

という感じです。
実装を眺めてみると、
(defun string->list (string)
  (let ((eof (list nil)))
    (with-input-from-string (stream string)
      (do ((x (read stream nil eof) (read stream nil eof))
           (l nil (cons x l)))
          ((eq x eof) (nreverse l))))))
文字列をストリームとして読み込んでREADしてリストにして返すということみたいです。
ということで、
(KL:STRING->LIST "(foo bar baz)")
⇒ ((FOO BAR BAZ))

(KL:STRING->LIST "foo: bar: baz:") >>> 読み込みエラー

ということにもなります。

KMRCLを眺める(146) COLLAPSE-WHITESPACE

Posted 2010-04-28 04:49:00 GMT

今回はKMRCLのstrings.lispから、COLLAPSE-WHITESPACEです。
連続した空白を一つの空白に圧縮する関数のようで、動作は、

(KL:COLLAPSE-WHITESPACE "foo

bar baz

quux") ⇒ "foo bar baz quux"

という感じ。
定義は、
(defun collapse-whitespace (s)
  "Convert multiple whitespace characters to a single space character."
  (declare (simple-string s)
           (optimize (speed 3) (safety 0)))
  (with-output-to-string (stream)
    (do ((pos 0 (1+ pos))
         (in-white nil)
         (len (length s)))
        ((= pos len))
      (declare (fixnum pos len))
      (let ((c (schar s pos)))
        (declare (character c))
        (cond
         ((kl:is-char-whitespace c)
          (unless in-white
            (write-char #\space stream))
          (setq in-white t))
         (t
          (setq in-white nil)
          (write-char c stream)))))))
という風にストレートなものです。

KMRCLを眺める(145) SPLIT-ALPHANUMERIC-STRING

Posted 2010-04-27 05:07:00 GMT

今回はKMRCLのstrings.lispから、SPLIT-ALPHANUMERIC-STRINGです。
前回の LEX-STRING はデリミタが空白/改行文字でしたが、今回は、 non alpanumetricな文字が区切りになります

(KL:SPLIT-ALPHANUMERIC-STRING "いろはにほへと,ちりぬるを,わかよたれそ,つねならむ")
=> ("いろはにほへと" "ちりぬるを" "わかよたれそ" "つねならむ")
というところです。
定義も殆ど同じで、LEX-STRINGと2行位違うだけで
(defun split-alphanumeric-string (string)
  "Separates a string at any non-alphanumeric chararacter"
  (declare (simple-string string)
           (optimize (speed 3) (safety 0)))
  (flet ((is-sep (char)
           (declare (character char))
           (and (non-alphanumericp char)
                (not (char= #\_ char)))))
    (let ((tokens nil))
      (do* ((token-start
             (position-if-not #'is-sep string)
             (when token-end
               (position-if-not #'is-sep string :start (1+ token-end))))
            (token-end
             (when token-start
               (position-if #'is-sep string :start token-start))
             (when token-start
               (position-if #'is-sep string :start token-start))))
           ((null token-start) (nreverse tokens))
        (push (subseq string token-start token-end) tokens)))))
となっています。

なんとなく、コピペ的に似たような関数を書くよりは、区切りを判定する関数を受けとる関数を書く方すっきりする気がします。
(SPLIT-STRING "いろはにほへと ちりぬるを,わかよたれそ,つねならむ")
              :TEST #'KL:NON-ALPHANUMERICP)
=> ("いろはにほへと" "ちりぬるを" "わかよたれそ" "つねならむ")
のような感じで。

KMRCLを眺める(144) LEX-STRING

Posted 2010-04-24 08:24:00 GMT

今回はKMRCLのstrings.lispから、LEX-STRINGです。
動作は、以前眺めた DELIMITED-STRING-TO-LIST と大体同じですが、LEX-STRINGは空白文字を複数指定できるところが違うようです。(デフォルトだと、#\Spaceと#\Newline)

(SUBSEQ (KL:LEX-STRING (KL:READ-FILE-TO-STRING "/usr/share/dict/words")
                       :WHITESPACE '(#\Newline))
        10000
        10010)
⇒ ("Loyola" "Loyola's" "Lr" "Lt" "Lt's" "Ltd" "Ltd's" "Lu" "Lu's" "Luanda")
という感じで、定義は
(defun lex-string (string &key (whitespace '(#\space #\newline)))
  "Separates a string at whitespace and returns a list of strings"
  (flet ((is-sep (char) (member char whitespace :test #'char=)))
    (let ((tokens nil))
      (do* ((token-start
             (position-if-not #'is-sep string)
             (when token-end
               (position-if-not #'is-sep string :start (1+ token-end))))
            (token-end
             (when token-start
               (position-if #'is-sep string :start token-start))
             (when token-start
               (position-if #'is-sep string :start token-start))))
           ((null token-start) (nreverse tokens))
        (push (subseq string token-start token-end) tokens)))))
です。
DOの中身が長くなるので縦に伸びています。

KMRCLを眺める(143) SHRINK-VECTOR

Posted 2010-04-22 05:05:00 GMT

今回はKMRCLのstrings.lispから、SHRINK-VECTORです。
定義をみると仮引数にstrとあって文字列を取るのかと思ってしまいますが、VECTOR全般で使えるようです。

(defun shrink-vector (str size)
  #+allegro
  (excl::.primcall 'sys::shrink-svector str size)
  #+cmu
  (lisp::shrink-vector str size)
  #+lispworks
  (system::shrink-vector$vector str size)
  #+sbcl
  (sb-kernel:shrink-vector str size)
  #+scl
  (common-lisp::shrink-vector str size)
  #-(or allegro cmu lispworks sbcl scl)
  (setq str (subseq str 0 size))
  str)
動作は、
(LET ((S (MAKE-STRING 10 :INITIAL-ELEMENT #\X)))
  (KL:SHRINK-VECTOR S 5))
⇒ "XXXXX"
という感じだと思いますが、SBCLだと内部で呼び出しているSB-KERNEL:SHRINK-VECTORは破壊的変更をする関数ではないようで、
(LET ((S (MAKE-STRING 10 :INITIAL-ELEMENT #\X)))
  (KL:SHRINK-VECTOR S 5))
⇒ "XXXXXXXXXX"
となってしまいます。

KMRCLを眺める(142) STRING-MAYBE-SHORTEN

Posted 2010-04-20 04:18:00 GMT

今回はKMRCLのstrings.lispから、STRING-MAYBE-SHORTENです。
前回のSTRING-ELIDEの:ENDを指定したものです

(DEFVAR *IROHA*
  "いろはにほへとちりぬるをわかよたれそつねならむうゐのおくやまけふこえてあさきゆめみしゑひもせす")

(KL:STRING-MAYBE-SHORTEN *IROHA* 10) ⇒ "いろはにほへと..."

定義は、そのまま
(defun string-maybe-shorten (str maxlen)
  (string-elide str maxlen :end))
となっています。

KMRCLを眺める(141) STRING-ELIDE

Posted 2010-04-18 07:10:00 GMT

今回はKMRCLのstrings.lispから、STRING-ELIDEです。
動作は、指定した長さを越える文字列は、省略の...を付けて切り詰めるというものです。

(DEFVAR *IROHA*
  "いろはにほへとちりぬるをわかよたれそつねならむうゐのおくやまけふこえてあさきゆめみしゑひもせす")

(KL:STRING-ELIDE " 10 :END) ⇒ "いろはにほへと..."

(KL:STRING-ELIDE *IROHA* 47 :END) ⇒ "いろはにほへとちりぬるをわかよたれそつねならむうゐのおくやまけふこえてあさきゆめみしゑひもせす"

(KL:STRING-ELIDE *IROHA* 46 :END) ⇒ "いろはにほへとちりぬるをわかよたれそつねならむうゐのおくやまけふこえてあさきゆめみしゑ..."

(KL:STRING-ELIDE *IROHA* 46 :MIDDLE) ⇒ "いろはにほへとちりぬるをわかよたれそつねなら...おくやまけふこえてあさきゆめみしゑひもせす"

という風に、デフォルトの動作は、:ENDを指定したものを一緒で、最後に"..."を、:MIDDLEを指定すると中央に"..."が入ります。
定義は、
(defun string-elide (str maxlen position)
  (declare (fixnum maxlen))
  (let ((len (length str)))
    (declare (fixnum len))
    (cond
     ((<= len maxlen)
      str)
     ((<= maxlen 3)
      "...")
     ((eq position :middle)
      (multiple-value-bind (mid remain) (truncate maxlen 2)
        (let ((end1 (- mid 1))
              (start2 (- len (- mid 2) remain)))
          (concatenate 'string (subseq str 0 end1) "..." (subseq str start2)))))
     ((or (eq position :end) t)
      (concatenate 'string (subseq str 0 (- maxlen 3)) "...")))))
となっています。
ぱっと見たところ
(or (eq position :end) t)
が結局どういうことなんだと思ってしまいますが、良く良く考えると気持ちはなんとなく分かります。

KMRCLを眺める(140) STRING-STRIP-ENDING

Posted 2010-04-16 04:27:00 GMT

今回はKMRCLのstrings.lispから、STRING-STRIP-ENDINGです。
動作は、与えた文字列の末尾が指定した文字列群のうちのどれかと一致するなら、一致した部分を取り除いて返すというもので

(DEFVAR *FILES* '("FOO.LSP" "BAR.LISP" "BAZ.L"))

(MAPCAR (LAMBDA (X) (KL:STRING-STRIP-ENDING X '(".lsp" ".lisp" ".l"))) *FILES*) ⇒ ("FOO" "BAR" "BAZ")

というところ。
定義は、
(defun string-strip-ending (str endings)
  (if (stringp endings)
      (setq endings (list endings)))
  (let ((len (length str)))
    (dolist (ending endings str)
      (when (and (>= len (length ending))
                 (string-equal ending
                               (subseq str (- len
                                              (length ending)))))
        (return-from string-strip-ending
          (subseq str 0 (- len (length ending))))))))
となっています。
endingsにはリストを与えても良いし、文字列単品でも良いみたいです。個人的な趣味ですがifよりwhenの方が読み易いですね。

KMRCLを眺める(139) REMOVE-CHAR-STRING

Posted 2010-04-14 04:56:00 GMT

今回はKMRCLのstrings.lispから、REMOVE-CHAR-STRINGです。
動作は、文字列から指定した文字を取り除くもののようで

(KL:REMOVE-CHAR-STRING #\o "looooooooooooooooooooooooooooop")
⇒ "lp"
というところ。
定義は、
(defun remove-char-string (char str)
  (declare (character char)
           (string str))
  (do* ((len (length str))
        (out (make-string len))
        (pos 0 (1+ pos))
        (opos 0))
       ((= pos len) (subseq out 0 opos))
    (declare (fixnum pos opos len)
             (simple-string out))
    (let ((c (char str pos)))
      (declare (character c))
      (when (char/= c char)
        (setf (schar out opos) c)
        (incf opos)))))
となっています。
元の文字列と同じ長さで文字列を作成して、後は指定した文字と一致していない文字を順に埋めていき、最後に必要な部分だけ返す、という方式です。
文字列の余ったところが、なんだか余っいてもったいなく感じたので、単純に文字列ストリームを使ったり、リストにして集めたのを変換したのと比べてどうなのかということで計測してみましたが、KMRCLの方式の方が効率が良いみたいです。

(DEFVAR *WORDS*
  (KL:READ-FILE-TO-STRING "/usr/share/dict/words"))

(LENGTH *WORDS*) ⇒ 931467

;; KMRCL (PROG () (KL:REMOVE-CHAR-STRING #\o *WORDS*)) ;⇒ NIL ---------- Evaluation took: 0.029 seconds of real time 0.030000 seconds of total run time (0.030000 user, 0.000000 system) [ Run times consist of 0.010 seconds GC time, and 0.020 seconds non-GC time. ] 103.45% CPU 70,205,436 processor cycles 7,258,080 bytes consed

Intel(R) Core(TM)2 Duo CPU P8600 @ 2.40GHz

;; 文字列ストリーム (DEFUN MY-REMOVE-CHAR-STRING (CHAR STR) (DECLARE (CHARACTER CHAR) (STRING STR)) (WITH-OUTPUT-TO-STRING (OUT) (LOOP :FOR C :ACROSS STR :IF (CHAR/= CHAR C) :DO (PRINC C OUT))))

(PROG () (MY-REMOVE-CHAR-STRING #\o *WORDS*)) ;⇒ NIL ---------- Evaluation took: 0.166 seconds of real time 0.170000 seconds of total run time (0.150000 user, 0.020000 system) 102.41% CPU 397,283,913 processor cycles 7,737,024 bytes consed

Intel(R) Core(TM)2 Duo CPU P8600 @ 2.40GHz

;; リストで集めて文字列に変換 (DEFUN MY-REMOVE-CHAR-STRING-2 (CHAR STR) (DECLARE (CHARACTER CHAR) (STRING STR)) (COERCE (LOOP :FOR C :ACROSS STR :IF (CHAR/= CHAR C) :COLLECT C) 'STRING))

(PROG () (MY-REMOVE-CHAR-STRING-2 #\o *WORDS*)) ;⇒ NIL ---------- Evaluation took: 0.087 seconds of real time 0.080000 seconds of total run time (0.080000 user, 0.000000 system) [ Run times consist of 0.030 seconds GC time, and 0.050 seconds non-GC time. ] 91.95% CPU 209,846,160 processor cycles 17,674,400 bytes consed

Intel(R) Core(TM)2 Duo CPU P8600 @ 2.40GHz


KMRCLを眺める(138) STRING-RIGHT-TRIM-ONE-CHAR

Posted 2010-04-12 04:31:00 GMT

今回はKMRCLのstrings.lispから、STRING-RIGHT-TRIM-ONE-CHARです。
指定した文字が文字列の最後に現われるなら文字を切り詰めるというもので、動作は、

(KL:STRING-RIGHT-TRIM-ONE-CHAR #\o "foo")
⇒
"fo"

(KL:STRING-RIGHT-TRIM-ONE-CHAR #\r "foo") ⇒ "foo"

というところ。
定義は、
(defun string-right-trim-one-char (char str)
  (declare (simple-string str))
  (let* ((len (length str))
         (last (1- len)))
    (declare (fixnum len last))
    (if (char= char (schar str last))
        (subseq str 0 last)
      str)))
となっています。

Older entries (135 remaining)