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))
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)intern-eql-specializer というのはAMOPで定義されている関数ですが、LispWorksにはないようで、定義があります。 ちなみに、intern-eql-specializer は、EQL-SPECIALIZERメタオブジェクトを返す関数です。;;;--------------------------------------------------- #+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))
(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)) )ここで、処理系のmop系のパッケージから色々インポート;;; 同上 (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)) )
(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*)))compute-effective-slot-definition、direct-slot-definition-classの引数が3より少なければ、short-arg-cesd、short-arg-dsdcを*features*に登録するようですが、他のソースでも使っていないようで何に使うのかは不明。#+cmu (if (find-package 'mop) (setq cl:*features* (delete 'kmrcl::cmucl-mop cl:*features*)) (setq cl:*features* (delete 'kmrcl::cmucl-pcl cl:*features*)))
(when (< (length (generic-function-lambda-list (ensure-generic-function 'compute-effective-slot-definition))) 3) (pushnew 'short-arg-cesd cl:*features*))以上で、定義は終了。 Closer to MOPと、KMR-MOPの差を調べてみましたが、(when (< (length (generic-function-lambda-list (ensure-generic-function 'direct-slot-definition-class))) 3) (pushnew 'short-arg-dsdc cl:*features*))
) ;; eval-when
(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))という感じで、久々にKMRCLをつらつら眺めてみましたが、Closer to MOPの方が規模が大きいので、現状では、Closer to MOPを使って互換性を担保するのが吉なのかなというところです。 ■(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))
Posted 2011-01-08 12:39:00 GMT
今回はKMRCLのrepl.lispまるごとです。
一つ一つの関数をばらして解説というのがちょっと難しそうなのと、それ程長くもない、ということでファイル全体を眺めます。
まず、名前からしてREPLを実現するファイルだろうなということは分かります。
とりあえず上からつらつらと眺めつつ実際に動かしてみます。
(in-package #:kmrcl)デフォルトの接続ポートを4000番にしていますが、どうやら外部と通信できるようです。(defconstant +default-repl-server-port+ 4000)
(defclass repl () ((listener :initarg :listener :accessor listener :initform nil)))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で定義されています。こちらもいつか眺めます。
(defun init/repl (repl state) (init/listener repl state))INIT/REPLは名前の通りREPLを初期化するものだろうと思われます。
(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を呼びます。
(defun read-socket-line (stream) (string-right-trim-one-char #\return (read-line stream nil nil)))READ-SOCKET-LINEは、REPL-WORKERの中でユーザー名とパスワードを読み取るのに使われています。
(defun print-prompt (stream) (format stream "~&~A> " (package-name *package*)) (force-output 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を呼ぶというもの。
(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)telnetで接続(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)
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>
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
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.となっていて前回のSIGNAL-KEY-TO-NUMBERが内部で使われています。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.")))
;; 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 !
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というところ
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)))となっています。
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
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\"> ; "といったところ。
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\"> ; "といったところ
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\"> ; "というところ
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\" ?> ; "となっています。
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 "<" s)) (#\& (write-string "&" s)) (t (write-char c s))))))となっていて、単純に"<"や"&"などを、&lt;、&amp;に置き換えるだけのものの様子。
(kl:write-cdata "<![CDATA[こんにちは]]>" *standard-output*) ;-> <![CDATA[こんにちは]]> ;=> "<![CDATA[こんにちは]]>"となっていますが、CDATAセクションの中でCDATAのタグを使うための文字列を生成するというのもちょっとおかしいし、CDATAを表示させるためとしたら、>が置き換えされていないし…、ということでちょっと謎の関数です。
(#\> (write-string ">" s))が忘れられていたりするんでしょうか。
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 "]]>"))となっています。
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))))となっています。
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
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 ))というところでしょうか。
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\"")という感じですが、タグの中身の開始位置と存在すれば属性を抜き出すもののようです。
(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))))■
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感謝]]>"■
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
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 (defvar *out* #. *standard-output*)というように上手く動きますが、SBCLだとTIMEOUTというコンディションを発生させるので、(kl::with-timeout (3) (loop :for i :from 0 :do (format *out* "Hello ~D~%" i) (sleep 2))) ;→ Hello 0 ;→ Hello 1 ;⇒ NIL
;; 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 ;⇒ "時既に時間切れ"と書くようです。
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) )となっています。
(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
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
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に合せているようです。
(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}>)
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に合せた様子。
(kl::make-process "hello" (lambda (&aux (*standard-output* #.*standard-output*)) (print "hello!"))) ;→ "hello!" ;⇒ #<SB-THREAD:THREAD "hello" FINISHED values: "hello!" {1011C39CC1}>というところ。
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といったところ。
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 (add-to-list "foo/bar/baz" 'load-path)ではなく、
(pushnew-load-path "foo/bar/baz")にしてみるとか。…あまりピンとくる例にもなってないですね。
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)
Posted 2010-10-01 14:36:00 GMT
今回は、KMRCLのconsole.lispからCMSG-Cです。
前回のCMSGを一捻りしたもののようで定義は、
(defvar *console-msgs-types* nil)となっていて、*CONSOLE-MSGS-TYPES*にメッセージを出力する状況のタイプをリストで格納して置いて、CMSG-Cの引数にそのタイプが指定されていた場合は、出力、そうでなければスルーというもののようです。(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)))
(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 ;-> ;; ************************************* ;; 蟲取り ;; *************************************というところ。
Posted 2010-09-28 14:24:00 GMT
random.lispも眺め終えたので、今回は、KMRCLのconsole.lispからCMSGです。
console.lispはその名の通りコンソールでなにかするため(主にログを出力したり)のユーティリティの用です。
CMSGの定義は、
(defvar *console-msgs* t)となっていて、*CONSOLE-MSGS*の値で出力したりしなかったりを制御できるようにしてあり、あとは先頭にコメントの;; を付けるというシンプルなものです。(defun cmsg (template &rest args) "Format output to console" (when *console-msgs* (setq template (concatenate 'string "~&;; " template "~%")) (apply #'format t template args)))
(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の高機能を生かすというパターンは良くみかける気がします。
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))))となっています。
(defmacro random-choice (&rest exprs) `(case (random ,(length exprs)) ,@(loop :for i :from 0 :for e :in exprs :collect (list i e))))みたいに書くかもしれません。まあ、Schemeではなくて、CLの話なので趣味の問題ではありますが…。
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)
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のソースも作成中です。
■
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)))))となっていて、それぞれの型に応じて切り分けられています。
(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]
Posted 2010-09-09 04:18:00 GMT
今回は、KMRCLのequal.lispからSTRUCTURE-SLOT-NAMESです。
クラスのスロット名を取得するものは眺めましたが、今回は構造体用の物です。
定義は、
となっているのですが、#+(or sbcl cmu)では CLASS-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") )
(DEFSTRUCT FOO X Y Z)しかし、折角定義されているこの関数ですが、どこからも呼ばれていないのが謎です。(KL::STRUCTURE-SLOT-NAMES 'FOO) ;⇒ (X Y Z)
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 でクラスを判定して一致していなかったら脱出
(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
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の領域になりますが、
(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)
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
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)))というところ。
(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
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が処理系依存の動作なため、処理系により上手く結果がでないようです。
(KL::GENERALIZED-EQUAL-FUNCTION #'CAR #'CAR) ;⇒ T ;SBCL/CLISP/Allegro CLSBCL/Clozure CLではこういうのはどう書いたら良いのか…。(KL::GENERALIZED-EQUAL-FUNCTION (LAMBDA (X) (CAR X)) (LAMBDA (X) (CADR X))) ;⇒ NIL ;Allegro CL/CLISP ;⇒ T ;SBCL
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)"Allegro CL以外は、有用な結果になってない気がします…。; SBCL ; ⇒ "#'(LAMBDA (X))"
; CCL (BREAK) ; NIL, NIL, NILが返ってくるため
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))) ;⇒ "月"というところ
Posted 2010-08-29 14:48:00 GMT
今回は、KMRCLのdatetime.lispからMONTHNAMEです。
定義を読むと、どうも月の数字から西暦の月の名前を割り出す関数のようです。
;; Monthnames taken from net-telent-date to support lml2引数の並びと定義の感じからして、FORMATTERのように使うような気がしましたが、KMRCLで実際に使われている箇所が探し出せませんでした。(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)))))
(FORMAT NIL #'KL::MONTHNAME 9 NIL NIL) ;⇒ "September"Googleコード検索で探してみたところでは、;; 切り詰めてみる (FORMAT NIL #'KL::MONTHNAME 9 NIL NIL 3) ;⇒ "Sep"
(format nil (formatter "~2,'0D-~3/kmrcl::monthname/-~4,'0D ~2,'0D:~2,'0D") 3 3 2010 10 20) ;⇒ "03-Mar-2010 10:20"のようなものがみつかりました。
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+))■
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+))
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を呼んでいる周りの関数を眺めるとどうもミリ秒とか、そういうのを表記するのに使いたい様子。
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 nil "~[Mon~;Tue~;Wed~;Thu~;Fri~;Sat~;Sun~]" 3) ;⇒ "Thu"などは使う機会も結構ありそうです。
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"となっています。
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"
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"
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/"■
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/" ...)
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)))))となっています。
(KL:COPY-FILE "/etc/fstab" "/tmp/") ;⇒ 0で
$ ls /tmp ... fstab ...となっています。
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* )のようになっています。
(KL:COMMAND-LINE-ARGUMENTS) ;⇒ ("/var/lisp/swank-sbcl")のような感じになっています。
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)))のようになっています。
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というところ
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")
))
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で、
(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")
))
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))))となっています。
(KL:FILE-SIZE "/usr/share/dict/words") ;⇒ 931708というところ
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行です。
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)
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)
(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)))となっています。
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))))となっています。
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))))))で、変数版とほぼ同一です。
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))))))で、そのままな感じです。
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
(defun ensure-keyword-default-case (desig) (nth-value 0 (intern (string-default-case (symbol-name (ensure-keyword desig))) :keyword)))となっています。
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の使われ方が微妙な気が…
(defun ensure-keyword-upcase (desig) (nth-value 0 (ensure-keyword (string-upcase desig))))でもOKな気がします。
(defun ensure-keyword-upcase (desig) (nth-value 0 (intern (string-upcase desig) :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)))))となっています。
Posted 2010-06-29 14:02:00 GMT
今回は、KMRCLのsymbols.lispからCONCAT-SYMBOLです。
定義は、
(defun concat-symbol (&rest args) (apply #'concat-symbol-pkg nil args))となっています。
(KL:CONCAT-SYMBOL :foo '- "bar" :- 'baz) ;⇒ FOO-BAR-BAZとなっています。
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") ;⇒ FOOBARpkgにNILを指定するとカレントパッケージが利用されます。(KL:CONCAT-SYMBOL-PKG :KEYWORD "foo" "bar") ;⇒ :FOOBAR
(KL:CONCAT-SYMBOL-PKG :KL "foo" "bar") ;⇒ KMRCL::FOOBAR
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))
(KL::STRING-DEFAULT-CASE "foo") ;⇒ "FOO"■
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)) ;⇒ 868CLパッケージのシンボルって870もあるんですね。(KL::CL-SYMBOLS) ;⇒ (*ERROR-OUTPUT* CALL-ARGUMENTS-LIMIT *PRINT-BASE* MOST-NEGATIVE-SINGLE-FLOAT .... FILL-POINTER DOLIST)
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)■
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*)といったところ。
(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でした。
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))という風になっています。
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を使っています
(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)と書けます。
;; 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)と書けます。
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)))))DEFUNを置き換えるだけで簡単にメモ化版関数が定義されます。(FIB 100) ;⇒ 354224848179261915075
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)))))といったところで、FIBをメモ化すると関数の呼び出しが減るのが分かると思います。;; トレース (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
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
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"
;; 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)))))
(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)))と展開されます。
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もするというところです。
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と同じです。
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) "&")))) (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で定義されています。
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/")よりは見通しが良さそうです。
Posted 2010-05-15 08:09:00 GMT
今回は、KMRCLのweb-utils.lispからUSER-AGENT-IE-Pです。
名前のとおりユーザーエージェントがIEかどうかを判定するもののようで定義は、
;;; User agent functionsとなっていますが、なぜSafafiを判定しているのかは謎です。そういうものなのでしょうか。(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)))
動作例は、 (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の結果がそのまま帰ってきているのでこうなっています。
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リード時に評価して文字列にしているのは分かるのですが、FORMAT式の中身に評価して展開されるものがないので、ちょっと不思議です。(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\">"))
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 を利用しています。
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 を利用してバックスラッシュを追加しています。
(LENGTH "123\456\7890") ;⇒ 10ちなみに、シンボルの場合も似ていますが、文字列とシンボルでは、ダブルクォートとパイプの役割が逆転した感じになっています。(LENGTH "123\\456\\7890") ;⇒ 12
'|"| ;⇒ |"|■"|" ;⇒ "|"
'|\|| ;⇒ |\||
"\"" ;⇒ "\""
"\\" ;⇒ "\\"
'|\\| ;⇒ |\\|
'|"\foo"| ;⇒ |"foo"|
"|\foo|" ;⇒ "|foo|"
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 を利用しています。
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で切り出しという感じです。
(MAPCAR (CURRY #'metatilities:STRING-TRIM-IF (COMPLEMENT #'ALPHANUMERICP)) '("いろはにほへど、" " ちりぬるを、" " わかよたれそ、" " つねならむ")) ;⇒ ("いろはにほへど" "ちりぬるを" "わかよたれそ" "つねならむ")個人的にはこういう方がすっきりしてて好みです。
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:") >>> 読み込みエラー
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)))))))という風にストレートなものです。
Posted 2010-04-27 05:07:00 GMT
今回はKMRCLのstrings.lispから、SPLIT-ALPHANUMERIC-STRINGです。
前回の LEX-STRING はデリミタが空白/改行文字でしたが、今回は、 non alpanumetricな文字が区切りになります
(KL:SPLIT-ALPHANUMERIC-STRING "いろはにほへと,ちりぬるを,わかよたれそ,つねならむ") => ("いろはにほへと" "ちりぬるを" "わかよたれそ" "つねならむ")というところです。
(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) => ("いろはにほへと" "ちりぬるを" "わかよたれそ" "つねならむ")のような感じで。
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)))))です。
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"となってしまいます。
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))となっています。
Posted 2010-04-18 07:10:00 GMT
今回はKMRCLのstrings.lispから、STRING-ELIDEです。
動作は、指定した長さを越える文字列は、省略の...を付けて切り詰めるというものです。
(DEFVAR *IROHA* "いろはにほへとちりぬるをわかよたれそつねならむうゐのおくやまけふこえてあさきゆめみしゑひもせす")という風に、デフォルトの動作は、:ENDを指定したものを一緒で、最後に"..."を、:MIDDLEを指定すると中央に"..."が入ります。(KL:STRING-ELIDE " 10 :END) ⇒ "いろはにほへと..."
(KL:STRING-ELIDE *IROHA* 47 :END) ⇒ "いろはにほへとちりぬるをわかよたれそつねならむうゐのおくやまけふこえてあさきゆめみしゑひもせす"
(KL:STRING-ELIDE *IROHA* 46 :END) ⇒ "いろはにほへとちりぬるをわかよたれそつねならむうゐのおくやまけふこえてあさきゆめみしゑ..."
(KL:STRING-ELIDE *IROHA* 46 :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)が結局どういうことなんだと思ってしまいますが、良く良く考えると気持ちはなんとなく分かります。
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))))))))となっています。
■
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)))))となっています。
(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
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)))となっています。