#:g1: frontpage

今回眺める 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?

(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

(defclass attributes-esd (kmr-mop:standard-effective-slot-definition)
  ((attributes :initarg :attributes :initform nil
               :accessor esd-attributes)))

;; encapsulating macro for Lispworks
(kmr-mop:process-slot-option attributes-class :attributes)

#+(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))

(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>

(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))

(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のメモ")

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

しばらくブログを書いてないと書くこともまた無くなってしまうのですが、そういう時はライブラリを眺めてたことを思いだしたので、久し振りにKMRCLを眺めてみます。 (前回: 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.

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

(defpackage #:kmr-mop
  (:use
   #:cl
   #:kmrcl
   #+kmrcl::sbcl-mop #:sb-mop
   #+kmrcl::cmucl-mop #:mop
   #+allegro #:mop
   #+lispworks #:clos
   #+clisp #:clos
   #+scl #:clos
   #+ccl #:openmcl-mop
   )
  )
#+lispworks
(defun intern-eql-specializer (slot)
  `(eql ,slot))

(in-package #:kmr-mop)
(eql (INTERN-EQL-SPECIALIZER 8)
     (INTERN-EQL-SPECIALIZER 8))
;=>  T

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

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

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

(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))

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

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

(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)

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

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

定数などの定義

(in-package #:kmrcl)
(defconstant +default-repl-server-port+ 4000)

REPLクラス

(defclass repl ()
  ((listener :initarg :listener :accessor listener
             :initform nil)))

MAKE-REPL

(defun make-repl (&key (port +default-repl-server-port+)
                       announce user-checker remote-host-checker)
  (make-instance 'listener
    :port port
    :base-name "repl"
    :function 'repl-worker
    :function-args (list user-checker announce)
    :format :text
    :wait nil
    :remote-host-checker remote-host-checker
    :catch-errors nil))

INIT/REPL

(defun init/repl (repl state)
  (init/listener repl state))

REPL-WORKER

(defun repl-worker (conn user-checker announce)
  (when announce
    (format conn "~A~%" announce)
    (force-output conn))
  (when user-checker
    (let (login password)
      (format conn "login: ")
      (finish-output conn)
      (setq login (read-socket-line conn))
      (format conn "password: ")
      (finish-output conn)
      (setq password (read-socket-line conn))
      (unless (funcall user-checker login password)
        (format conn "Invalid login~%")
        (finish-output conn)
        (return-from repl-worker))))
  #+allegro
  (tpl::start-interactive-top-level
   conn
   #'tpl::top-level-read-eval-print-loop
   nil)
  #-allegro
  (repl-on-stream conn)
  )

READ-SOCKET-LINE

(defun read-socket-line (stream)
  (string-right-trim-one-char #\return
                              (read-line stream nil nil)))

PRINT-PROMPT

(defun print-prompt (stream)
  (format stream "~&~A> " (package-name *package*))
  (force-output stream))

REPL-ON-STREAM

(defun repl-on-stream (stream)
  (let ((*standard-input* stream)
        (*standard-output* stream)
        (*terminal-io* stream)
        (*debug-io* stream))
    #|
    #+sbcl
    (if (and (find-package 'sb-aclrepl)
             (fboundp (intern "REPL-FUN" "SB-ACLREPL")))
        (sb-aclrepl::repl-fun)
        (%repl))
    #-sbcl
    |#
    (%repl)))

%REPL

(defun %repl ()
  (loop
    (print-prompt *standard-output*)
    (let ((form (read *standard-input*)))
      (format *standard-output* "~&~S~%" (eval form)))))

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

setq% rlwrap telnet localhost 4001
Trying ::1...
Trying 127.0.0.1...
Connected to localhost.
Escape character is '^]'.
hello!
login: g000001
password: g000001
COMMON-LISP-USER> (+ 3 3 3 3 )
12
COMMON-LISP-USER>

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

(defun remove-signal-handler (sig &optional old-handler)
  "Removes a handler from signal. Tries, when possible, to restore old-handler."
  (let ((signum (etypecase sig
                  (integer sig)
                  (keyword (signal-key-to-number sig)))))
    ;; allegro automatically restores old handler, because set-signal-handler above
    ;; actually pushes the new handler onto a list of handlers
    #+allegro (declare (ignore old-handler))
    #+allegro (excl:remove-signal-handler signum)
    #+cmu (system:enable-interrupt signum (or old-handler :default))
    ;; lispworks removes handler if old-handler is nil
    #+(and lispworks unix) (system:set-signal-handler signum old-handler)
    #+sbcl (sb-sys:enable-interrupt signum (or old-handler :default))
    #-(or allegro cmu (and lispworks unix) sbcl)
    (declare (ignore sig handler))
    #-(or allegro cmu (and lispworks unix) sbcl)
    (warn "Signal setting not supported on this platform.")))

;; USR1へのハンドラを設定
(kl:set-signal-handler :usr1
                       (lambda (&rest args)
                         (declare (ignore args))
                         (princ "Hello USR1 !")
                         (terpri)
                         (force-output)))
:DEFAULT
* (sb-posix:getpid)
9776
;; 他のシェルから
$ kill -USR1 9776
* Hello USR1 !
;; USR1のハンドラを削除
(kl:remove-signal-handler :usr1)
#<CLOSURE (FLET SB-UNIX::RUN-HANDLER) {1003B40C89}>
T
;; 他のシェルから
$ kill -USR1 9776
* User defined signal 1

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

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

;; 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 !

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

(defun signal-key-to-number (sig)
  "These signals and numbers are only valid on POSIX systems, perhaps
some are Linux-specific."
  (case sig
    (:hup 1)
    (:int 2)
    (:quit 3)
    (:kill 9)
    (:usr1 10)
    (:usr2 12)
    (:pipe 13)
    (:alrm 14)
    (:term 15)
    (t
     (error "Signal ~A not known." sig))))

(kl::signal-key-to-number :usr1)
;=> 10

今回はKMRCLの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)))

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

(defun score-multiword-match (s1 s2)
  "Score a match between two strings with s1 being reference string.
S1 can be a string or a list or strings/conses"
  (let* ((word-list-1 (if (stringp s1)
                          (split-alphanumeric-string s1)
                        s1))
         (word-list-2 (split-alphanumeric-string s2))
         (n1 (length word-list-1))
         (n2 (length word-list-2))
         (unmatched n1)
         (score 0))
    (declare (fixnum n1 n2 score unmatched))
    (decf score (* 4 (abs (- n1 n2))))
    (dotimes (iword n1)
      (declare (fixnum iword))
      (let ((w1 (nth iword word-list-1))
            pos)
        (cond
         ((consp w1)
          (let ((first t))
            (dotimes (i-alt (length w1))
              (setq pos
                (position (nth i-alt w1) word-list-2
                          :test #'string-equal))
              (when pos
                (incf score (- 30
                               (if first 0 5)
                               (abs (- iword pos))))
                (decf unmatched)
                (return))
              (setq first nil))))
         ((stringp w1)
          (kmrcl:awhen (position w1 word-list-2
                               :test #'string-equal)
                       (incf score (- 30 (abs (- kmrcl::it iword))))
                       (decf unmatched))))))
    (decf score (* 4 unmatched))
    score))

(kl:score-multiword-match "foo" "foo")
;=> 30
(kl:score-multiword-match '("foo") "foo")
;=> 30
(kl:score-multiword-match '("foo" "foo") "foo")
;=> 55
(kl:score-multiword-match '("foo" "foo" "foo") "foo")
;=> 79
(kl:score-multiword-match '("foo" "foo" "foo" "foo") "foo")
;=> 102
(kl:score-multiword-match '("foo" "foo" "foo" "foa") "foo")
;=> 71
(kl:score-multiword-match '("foo" "fao" "foo" "foa") "foo")
;=> 38

今回はKMRCLの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\">
;   "

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

(defun doctype-stream (stream top-element availability registered organization type
                       label language url entities)
  (format stream "<!DOCTYPE ~A ~A \"~A//~A//~A ~A//~A\"" top-element
          availability (if registered "+" "-") organization type label language)
  (when url
    (write-char #\space stream)
    (write-char #\" stream)
    (write-string url stream)
    (write-char #\" stream))
  (when entities
    (format stream " [~%~A~%]" entities))
  (write-char #\> stream)
  (write-char #\newline stream))

(with-output-to-string (out)
  (kl::doctype-stream out
                      "html"
                      "PUBLIC"
                      NIL
                      "W3C"
                      "DTD"
                      "XHTML 1.1"
                      "EN"
                      "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd"
                      NIL))
;=> "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\" \"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\">
;   "

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

(defun doctype-format (stream format &key top-element (availability "PUBLIC")
                       (registered nil) organization (type "DTD") label
                       (language "EN") url entities)
  (case format
    ((:xhtml11 :xhtml)
     (doctype-stream stream "html" availability registered "W3C" type "XHTML 1.1" language
                     (if url url "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd")
                     entities))
    (:xhtml10-strict
     (doctype-stream stream "html" availability registered "W3C" type "XHTML 1.0 Strict" language
                     (if url url "http://www.w3.org/TR/xhtml10/DTD/xhtml10-strict.dtd")
                     entities))
    (:xhtml10-transitional
     (doctype-stream stream "html" availability registered "W3C" type "XHTML 1.0 Transitional" language
                     (if url url "http://www.w3.org/TR/xhtml10/DTD/xhtml10-transitional.dtd")
                     entities))
    (:xhtml-frameset
     (doctype-stream stream "html" availability registered "W3C" type "XHTML 1.0 Frameset" language
                     (if url url "http://www.w3.org/TR/xhtml10/DTD/xhtml10-frameset.dtd")
                     entities))
    (:html2
     (doctype-stream stream "HTML" availability registered "IETF" type "HTML" language url entities))
    (:html3
     (doctype-stream stream "HTML" availability registered "IETF" type "HTML 3.0" language url entities))
    (:html3.2
     (doctype-stream stream "HTML" availability registered "W3C" type "HTML 3.2 Final" language url entities))
    ((:html :html4)
     (doctype-stream stream "HTML" availability registered "W3C" type "HTML 4.01 Final" language url entities))
    ((:docbook :docbook42)
     (doctype-stream stream (if top-element top-element "book")
                     availability registered "OASIS" type "Docbook XML 4.2" language
                     (if url url "http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd")
                     entities))
    (t
     (unless top-element (warn "Missing top-element in doctype-format"))
     (unless organization (warn "Missing organization in doctype-format"))
     (unless label (warn "Missing label in doctype-format"))
     (doctype-stream stream top-element availability registered organization type label language url
                     entities))))

(with-output-to-string (out)
  (kl::doctype-format out :xhtml))
;=> "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\" \"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\">
;   "

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

(defun xml-declaration-stream (stream &key (version "1.0") standalone encoding)
  (format stream "<?xml version=\"~A\"~A~A ?>~%"
          version
          (if encoding
              (format nil " encoding=\"~A\"" encoding)
              ""
              )
          (if standalone
              (format nil " standalone=\"~A\"" standalone)
              "")))

(with-output-to-string (out)
  (kl::xml-declaration-stream out :standalone "yes" :encoding "utf-8"))
;=> "<?xml version=\"1.0\" encoding=\"utf-8\" standalone=\"yes\" ?>
;   "

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

(defun write-cdata (str s)
  (declare (simple-string str) (optimize (speed 3) (safety 0) (space 0)))
  (do ((len (length str))
       (i 0 (1+ i)))
      ((= i len) str)
    (declare (fixnum i len))
    (let ((c (schar str i)))
      (case c
        (#\< (write-string "&lt;" s))
        (#\& (write-string "&amp;" s))
        (t   (write-char c s))))))

(kl:write-cdata "<![CDATA[こんにちは]]>" *standard-output*)
;-> &lt;![CDATA[こんにちは]]>
;=> "<![CDATA[こんにちは]]>"

(#\> (write-string ">" s))

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

(kl:cdata-string "<いろはにほへと><ちりぬるを>")
;=> "<![CDATA[<いろはにほへと><ちりぬるを>]]>"

(defun cdata-string (str)
  (concatenate 'string "<![CDATA[" str "]]>"))

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

(kl::xml-tag-contents "foo" "<foo bar=\"1\">hello</foo>")
;⇒ "hello", 24, ("bar=\"1\"")

(defun xml-tag-contents (tag xmlstr &optional (start-xmlstr 0)
                         (end-xmlstr (length xmlstr)))
  "Returns two values: the string between XML start and end tag
and position of character following end tag."
  (multiple-value-bind
      (startpos endpos nextpos attributes)
      (positions-xml-tag-contents tag xmlstr start-xmlstr end-xmlstr)
    (if (and startpos endpos)
        (values (subseq xmlstr startpos endpos) nextpos attributes)
      (values nil nil nil))))

今回はKMRCLの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)))))

(kl::positions-xml-tag-contents "foo" "<foo bar=\"1\">hello</foo>")
;⇒ 13, 18, 24, ("bar=\"1\"")
;; 開始タグ不備
(kl::positions-xml-tag-contents "foo" "foo>hello</foo>")
;⇒ NIL, NIL, NIL, NIL
;; 終了タグ不備
(kl::positions-xml-tag-contents "foo" "<foo>hello</foo")
;⇒ NIL, NIL, NIL, NIL

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

(kmrcl::find-end-tag "foo" 3 "<foo>hello</foo>" 5 16)
;⇒ 10

(defun find-end-tag (tag taglen xmlstr start end)
  (fast-string-search
   (concatenate 'string "</" tag ">") xmlstr
   (+ taglen 3) start end))

(defun find-end-tag (tag taglen xmlstr start end)
  (declare (ignore taglen))
  (search (concatenate 'string "</" tag ">")
          xmlstr
          :start2 start :end2 end ))

今回はKMRCLの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))))

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

(defun cdata-string (str)
  (concatenate 'string "<![CDATA[" str "]]>"))

(kl::cdata-string "今回のでそれが良くわかったよ>>199感謝")
;⇒ "<![CDATA[今回のでそれが良くわかったよ>>199感謝]]>"

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

(defun process-sleep (n)
  #+allegro (mp:process-sleep n)
  #-allegro (sleep n))

(defun hello-sleep-3 ()
  (loop :repeat 3
        :do (princ "Hello")
            (terpri)
            (kl::process-sleep 3)))
(hello-sleep-3)
;→ Hello
;→ Hello
;→ Hello
;⇒ NIL

今回は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*)
(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
;⇒ "時既に時間切れ"

今回は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

今回は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)
  )

(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

今回は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)
  )

(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}>)

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)
  )

(kl::make-process "hello" 
                  (lambda (&aux (*standard-output* #.*standard-output*))
                    (print "hello!")))
;→ "hello!" 
;⇒ #<SB-THREAD:THREAD "hello" FINISHED values: "hello!" {1011C39CC1}>

今回は、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

今回は、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")

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

(defun cmsg-add (condition)
  (pushnew condition *console-msgs-types*))

kl::*console-msgs-types*
;=> NIL
(kl:cmsg-add :debug)
;=> (:DEBUG)

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

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

(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
;->
;; *************************************
;;                  蟲取り                 
;; *************************************

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

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

(kl:cmsg "Hello, World!")
->
;; Hello, World!

(progn
  (kl:cmsg "~37,,,'*A" "")
  (kl:cmsg "~37:@<~A~>" "Hello, World!")
  (kl:cmsg "~37,,,'*A" ""))
;⇒ NIL
;->
;; *************************************
;;             Hello, World!            
;; *************************************

今回は、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))))

anything.elとの連携は、日付をまたいで次のエントリーにしよう(LISP365のため)と思っていたのですが、そんな風にぼーっとしている間に d:id:kitokitoki さんに光速でanything.elのソースを作って頂けました!
- (http://d.hatena.ne.jp/kitokitoki/20100912/p2)
同じものを載せるわけにも行かないので、ちょっと機能を追加しましたｗ
+(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)

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

今回は、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]

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

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

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

今回は、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)))

(DEFSTRUCT FOO X Y Z)
(DEFCLASS BAR ()
  ((A :INITARG :A)
   (B :INITARG :B)
   (C :INITARG :C)))
(KL::GENERALIZED-EQUAL-FIELDED-OBJECT (MAKE-FOO :X 1 :Y 2 :Z 3)
                                      (MAKE-FOO :X 1 :Y 2 :Z 3))
;⇒ T
(KL::GENERALIZED-EQUAL-FIELDED-OBJECT (MAKE-INSTANCE 'BAR :A 1 :B 2 :C 3)
                                      (MAKE-INSTANCE 'BAR :A 1 :B 2 :C 4))
;⇒ NIL

今回は、KMRCLの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)))

(DEFSTRUCT FOO X Y Z)
(KL::CLASS-SLOT-NAMES 'FOO)
;⇒ (X Y Z)
(DEFCLASS BAR ()
  (A B C))
(CLOSER-MOP:FINALIZE-INHERITANCE (FIND-CLASS 'BAR))
(KL::CLASS-SLOT-NAMES 'FOO)
;⇒ (A B C)

今回は、KMRCLの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)))

(LET ((TAB1 (MAKE-HASH-TABLE))
      (TAB2 (MAKE-HASH-TABLE :TEST 'EQUAL)))
  (KL::GENERALIZED-EQUAL-HASH-TABLE TAB1 TAB2))
;⇒ T

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

今回は、KMRCLの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

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

(defun generalized-equal-function (obj1 obj2)
  (string= (function-to-string obj1) (function-to-string obj2)))

(KL::GENERALIZED-EQUAL-FUNCTION #'CAR #'CAR)
;⇒ T ;SBCL/CLISP/Allegro CL

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

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))))))

(KL::FUNCTION-TO-STRING (LAMBDA (X) X))
; Allegro CL
; ⇒ "#'(LAMBDA (X) X)"
; SBCL
; ⇒ "#'(LAMBDA (X))"
; CCL
(BREAK) ; NIL, NIL, NILが返ってくるため

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

(defconstant* +zellers-adj+ #(0 3 2 5 0 3 5 1 4 6 2 4))
(defun day-of-week (year month day)
  "Day of week calculation using Zeller's Congruence.
Input: The year y, month m (1 ≤ m ≤ 12) and day d (1 ≤ d ≤ 31).
Output: n - the day of the week (Sunday = 0, Saturday = 6)."
  (when (< month 3)
    (decf year))
  (mod
   (+ year (floor year 4) (- (floor year 100)) (floor year 400)
      (aref +zellers-adj+ (1- month)) day)
   7))

(STRING (CHAR "日月火水木金土" (KL:DAY-OF-WEEK 2010 8 30)))
;⇒ "月"

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

;; Monthnames taken from net-telent-date to support lml2
(defvar *monthnames*
  '((1 . "January")
    (2 . "February")
    (3 . "March")
    (4 . "April")
    (5 . "May")
    (6 . "June")
    (7 . "July")
    (8 . "August")
    (9 . "September")
    (10 . "October")
    (11 . "November")
    (12 . "December")))
(defun monthname (stream arg colon-p at-p &optional width (mincol 0) (colinc 1) (minpad 0) (padchar #\Space))
  "Print the name of the month (1=January) corresponding to ARG on STREAM.  This is intended for embedding in a FORMAT directive: WIDTH governs the number of characters of text printed, MINCOL, COLINC, MINPAD, PADCHAR work as for ~A"
  (declare (ignore colon-p))
  (let ((monthstring (cdr (assoc arg *monthnames*))))
    (if (not monthstring) (return-from monthname nil))
    (let ((truncate (if width (min width (length monthstring)) nil)))
      (format stream
              (if at-p "~V,V,V,V@A" "~V,V,V,VA")
              mincol colinc minpad padchar
              (subseq monthstring 0 truncate)))))

(FORMAT NIL #'KL::MONTHNAME 9 NIL NIL)
;⇒ "September"
;; 切り詰めてみる
(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"

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

(KL:UTIME-TO-POSIX-TIME (GET-UNIVERSAL-TIME))
;⇒ 1282881649

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

今回は、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)

(defconstant +posix-epoch+
  (encode-universal-time 0 0 0 1 1 1970 0))
(defun posix-time-to-utime (time)
  (+ time +posix-epoch+))

今回は、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))))

(WITH-OUTPUT-TO-STRING (*STANDARD-OUTPUT*)
  (KL:PRINT-FLOAT-UNITS 0.001234567890 "sec"))
;⇒ "1.23 millisec"

今回は、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"

今回は、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"

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

(defun pretty-date (year month day &optional (hour 12) (m 0) (s 0))
  (multiple-value-bind (sec min hr dy mn yr wkday)
    (decode-universal-time
     (encode-universal-time s m hour day month year))
    (values (elt '("Monday" "Tuesday" "Wednesday" "Thursday"
                   "Friday" "Saturday" "Sunday")
                 wkday)
            (elt '("January" "February" "March" "April" "May" "June"
                   "July" "August" "September" "October" "November"
                   "December")
                 (1- mn))
            (format nil "~A" dy)
            (format nil "~A" yr)
            (format nil "~2,'0D:~2,'0D:~2,'0D" hr min sec))))

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

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

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

(KL:PROBE-DIRECTORY "/etc")
;⇒ #P"/etc/"
(KL:PROBE-DIRECTORY "/etc/hosts")
;⇒ NIL
;; 参考: PROBE-FILE
(PROBE-FILE "/etc")
;⇒ #P"/etc/"
(PROBE-FILE "/etc/hosts")
;⇒ #P"/etc/hosts"

今回は、KMRCLの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))))

(KL::CANONICALIZE-DIRECTORY-NAME "/tmp/../etc/hosts.allow")
;; SBCL
;⇒ #P"/tmp/../etc/hosts.allow/" 
;; Allegro CL
;⇒ #P"/etc/hosts.allow/"

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

(defun cwd (&optional dir)
  "Change directory and set default pathname"
  (cond
   ((not (null dir))
    (when (and (typep dir 'logical-pathname)
               (translate-logical-pathname dir))
      (setq dir (translate-logical-pathname dir)))
    (when (stringp dir)
      (setq dir (parse-namestring dir)))
    #+allegro (excl:chdir dir)
    #+clisp (#+lisp=cl ext:cd #-lisp=cl lisp:cd dir)
    #+(or cmu scl) (setf (ext:default-directory) dir)
    #+cormanlisp (ccl:set-current-directory dir)
    #+(and mcl (not openmcl)) (ccl:set-mac-default-directory dir)
    #+openmcl (ccl:cwd dir)
    #+gcl (si:chdir dir)
    #+lispworks (hcl:change-directory dir)
    (setq cl:*default-pathname-defaults* dir))
   (t
    (let ((dir
           #+allegro (excl:current-directory)
           #+clisp (#+lisp=cl ext:default-directory #-lisp=cl lisp:default-directory)
           #+(or cmu scl) (ext:default-directory)
           #+sbcl (sb-unix:posix-getcwd/)
           #+cormanlisp (ccl:get-current-directory)
           #+lispworks (hcl:get-working-directory)
           #+mcl (ccl:mac-default-directory)
           #-(or allegro clisp cmu scl cormanlisp mcl sbcl lispworks) (truename ".")))
      (when (stringp dir)
        (setq dir (parse-namestring dir)))
      dir))))

(KL:CWD "/tmp")
(DIRECTORY ".")
;⇒ (#P"/tmp/")

(SETF (LOGICAL-PATHNAME-TRANSLATIONS "var")
      '(("tmp;**;*.*.*" "/var/tmp/**/*.*")))
(KL:CWD "var:tmp;")
(DIRECTORY "var:tmp;*")
;⇒ (#P"/usr/local/var/tmp/.fasls/"
     ...)

今回は、KMRCLの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 ...

今回は、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")

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)))

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

(defun delete-directory-and-files (dir &key (if-does-not-exist :error) (quiet t) force)
  #+allegro (excl:delete-directory-and-files dir :if-does-not-exist if-does-not-exist
                                             :quiet quiet :force force)
  #-(or allegro) (declare (ignore force))
  #-(or allegro) (cond
                   ((probe-directory dir)
                    (let ((cmd (format nil "rm -rf ~A" (namestring dir))))
                      (unless quiet
                        (format *trace-output* ";; ~A" cmd))
                      (command-output cmd)))
                   ((eq if-does-not-exist :error)
                    (error "Directory ~A does not exist [delete-directory-and-files]." dir))))

(KL:DELETE-DIRECTORY-AND-FILES "/tmp/bar")
;⇒ ""
    ""
    0
;; 権限不足で削除できなかった場合
;⇒ ""
    "rm: ディレクトリ`/tmp/bar/baz/quux'を削除できません: Permission denied
    "
    1

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

(LET ((FILE "/usr/share/dict/words")
      (OUT-FILE "/tmp/bar"))
  (WITH-OPEN-FILE (IN FILE)
    (ALEXANDRIA:WITH-OUTPUT-TO-FILE (OUT OUT-FILE)
      (LOOP :FOR LINE := (READ-LINE IN NIL) :WHILE LINE
            :DO (WRITE-LINE (STRING-UPCASE LINE) OUT))))
  (KL:RUN-SHELL-COMMAND "firefox ~A" OUT-FILE))

(defun run-shell-command (control-string &rest args)
  "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
synchronously execute the result using a Bourne-compatible shell,
returns (VALUES output-string pid)"
  (let ((command (apply #'format nil control-string args)))
    #+sbcl
    (sb-impl::process-exit-code
     (sb-ext:run-program
      "/bin/sh"
      (list  "-c" command)
      :input nil :output nil))
    #+(or cmu scl)
    (ext:process-exit-code
     (ext:run-program
      "/bin/sh"
      (list  "-c" command)
      :input nil :output nil))

    #+allegro
    (excl:run-shell-command command :input nil :output nil
                            :wait t)
    #+lispworks
    (system:call-system-showing-output
     command
     :shell-type "/bin/sh"
     :show-cmd nil
     :prefix ""
     :output-stream nil)
    #+clisp             ;XXX not exactly *verbose-out*, I know
    (ext:run-shell-command  command :output :terminal :wait t)
    #+openmcl
    (nth-value 1
               (ccl:external-process-status
                (ccl:run-program "/bin/sh" (list "-c" command)
                                 :input nil :output nil
                                 :wait t)))
    #-(or openmcl clisp lispworks allegro scl cmu sbcl)
    (error "RUN-SHELL-PROGRAM not implemented for this Lisp")
    ))

今回は、KMRCLの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")
    ))

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

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")))
  )

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)

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)))

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

(KL:SHOW :FUNCTIONS :G000001)
;->
Function GITHUB-INSTALL  -> #<FUNCTION GITHUB-INSTALL>
Function AUTO-IMPORT  -> #<FUNCTION AUTO-IMPORT>
Function QUIT  -> #<FUNCTION QUIT>
Function FACT-CPS-LIST  -> #<FUNCTION FACT-CPS-LIST>
Function INSTALL  -> #<FUNCTION INSTALL>
Function OOS  -> #<FUNCTION OOS>
Function CURRY  -> #<FUNCTION CURRY>
Function FACT-CPS  -> #<FUNCTION FACT-CPS>
Function FLATTEN-CPS  -> #<FUNCTION FLATTEN-CPS>
;⇒ NIL

(defun show (&optional (what :variables) (package *package*))
  (ecase what
    (:variables (show-variables package))
    (:functions (show-functions package))))

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

(KL:SHOW-FUNCTIONS :KMRCL)
->
Function KMRCL::STRING-DEFAULT-CASE  -> #<FUNCTION KMRCL::STRING-DEFAULT-CASE>
Function KMRCL::BYTE-ARRAY-OUTPUT-STREAM-OUT  -> #<CLOSURE (LAMBDA
                                                               (SB-KERNEL:INSTANCE)) {1004F93809}>
Function KMRCL::%PRINT-BYTE-ARRAY-OUTPUT-STREAM  -> #<FUNCTION KMRCL::%PRINT-BYTE-ARRAY-OUTPUT-STREAM>
Function KMRCL::BYTE-ARRAY-INPUT-STREAM-CHAR-SIZE  -> #<CLOSURE (LAMBDA
                                                                    (SB-KERNEL:INSTANCE)) {1004E9ADD9}>
Function KMRCL::BYTE-ARRAY-OUTPUT-STREAM-EOF-FORCED-P  -> #<CLOSURE (LAMBDA
                                                                        (SB-KERNEL:INSTANCE)) {10041AA599}>
Function KMRCL::BYTE-ARRAY-OUTPUT-STREAM-EXTERNAL-FORMAT  -> #<CLOSURE (LAMBDA
                                                                           (SB-KERNEL:INSTANCE)) {100535A469}>
Function KMRCL::BYTE-ARRAY-INPUT-STREAM-DUAL-CHANNEL-P  -> #<CLOSURE (LAMBDA
                                                                         (SB-KERNEL:INSTANCE)) {10044000B9}>
Function KMRCL::CL-SYMBOLS  -> #<FUNCTION KMRCL::CL-SYMBOLS>
Function KMRCL::BYTE-ARRAY-OUTPUT-STREAM-PATHNAME  -> #<CLOSURE (LAMBDA
                                                                    (SB-KERNEL:INSTANCE)) {1005353729}>
Function KMRCL::BYTE-ARRAY-OUTPUT-STREAM-DELETE-ORIGINAL  -> #<CLOSURE (LAMBDA
                                                                           (SB-KERNEL:INSTANCE)) {10059CD009}>
Function KMRCL::BYTE-ARRAY-INPUT-STREAM-LISTEN  -> #<CLOSURE (LAMBDA
                                                                 (SB-KERNEL:INSTANCE)) {1005A87D89}>
Function KMRCL::REMOTE-HOST  -> #<FUNCTION KMRCL::REMOTE-HOST>
Function KMRCL::REPL-ON-STREAM  -> #<FUNCTION KMRCL::REPL-ON-STREAM>
Function KMRCL::BYTE-ARRAY-BINCH  -> #<FUNCTION KMRCL::BYTE-ARRAY-BINCH>
Function KMRCL::CATCH-ERRORS  -> #<STANDARD-GENERIC-FUNCTION KMRCL::CATCH-ERRORS (1)>
Function KMRCL::BYTE-ARRAY-OUTPUT-STREAM-INSTEAD  -> #<CLOSURE (LAMBDA
                                                                   (SB-KERNEL:INSTANCE)) {1005586FB9}>
Function KMRCL::BUF-USED  -> #<CLOSURE (LAMBDA (SB-KERNEL:INSTANCE)) {10040F4CB9}>
Function KMRCL::BYTE-ARRAY-INPUT-STREAM-TIMEOUT  -> #<CLOSURE (LAMBDA
                                                                  (SB-KERNEL:INSTANCE)) {10053D5B79}>
Function KMRCL::BUF-POP  -> #<FUNCTION KMRCL::BUF-POP>
Function KMRCL::BYTE-ARRAY-INPUT-STREAM-BIN  -> #<CLOSURE (LAMBDA
                                                              (SB-KERNEL:INSTANCE)) {1004E19F49}>
Function KMRCL::BYTE-ARRAY-IN-MISC  -> #<FUNCTION KMRCL::BYTE-ARRAY-IN-MISC>
Function KMRCL::BYTE-ARRAY-INPUT-STREAM-BUFFERING  -> #<CLOSURE (LAMBDA
                                                                    (SB-KERNEL:INSTANCE)) {100517C1B9}>
Function KMRCL::MAPCAR2-APPEND-STRING-NONTAILREC  -> #<FUNCTION KMRCL::MAPCAR2-APPEND-STRING-NONTAILREC>
Function KMRCL::BUF-P  -> #<CLOSURE (LAMBDA (SB-KERNEL::OBJECT)) {100463FB59}>
Function KMRCL::BYTE-ARRAY-INPUT-STREAM-NAME  -> #<CLOSURE (LAMBDA
                                                               (SB-KERNEL:INSTANCE)) {1004245D19}>
Function KMRCL::CANONICALIZE-DIRECTORY-NAME  -> #<FUNCTION KMRCL::CANONICALIZE-DIRECTORY-NAME>
Function KMRCL::FIELD-BUFFERS-BUFFERS  -> #<CLOSURE (LAMBDA
                                                        (SB-KERNEL:INSTANCE)) {100529FFB9}>
Function KMRCL::BYTE-ARRAY-INPUT-STREAM-BYTE-ARRAY  -> #<CLOSURE (LAMBDA
                                                                     (SB-KERNEL:INSTANCE)) {1005979BF9}>
Function KMRCL::BASE-NAME  -> #<STANDARD-GENERIC-FUNCTION KMRCL::BASE-NAME (1)>
Function KMRCL::BYTE-ARRAY-INPUT-STREAM-BOUT  -> #<CLOSURE (LAMBDA
                                                               (SB-KERNEL:INSTANCE)) {1004738469}>
Function KMRCL::BYTE-ARRAY-OUTPUT-STREAM-BUFFERING  -> #<CLOSURE (LAMBDA
                                                                     (SB-KERNEL:INSTANCE)) {100461D8B9}>
Function KMRCL::MAKE-FD-STREAM  -> #<FUNCTION KMRCL::MAKE-FD-STREAM>
....

(defun show-functions (package)
  (do-symbols (s package)
    (multiple-value-bind (sym status)
        (find-symbol (symbol-name s) package)
      (when (and (or (eq status :external)
                     (eq status :internal))
                 (fboundp sym))
        (format t "~&Function ~S~T -> ~S~%"
                sym
                (symbol-function sym))))))

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

(KL:SHOW-VARIABLES :CL)
->
Symbol *ERROR-OUTPUT*  -> #<SWANK-BACKEND::SLIME-OUTPUT-STREAM
                            {100E6B7271}>
Symbol CALL-ARGUMENTS-LIMIT  -> 1152921504606846975
Symbol *PRINT-BASE*  -> 10
Symbol MOST-NEGATIVE-SINGLE-FLOAT  -> -3.4028235e38
Symbol *LOAD-PRINT*  -> NIL
Symbol *GENSYM-COUNTER*  -> 2959
Symbol BOOLE-ANDC1  -> 12
Symbol BOOLE-C2  -> 5
Symbol LEAST-NEGATIVE-SINGLE-FLOAT  -> -1.4012985e-45
Symbol ARRAY-TOTAL-SIZE-LIMIT  -> 1152921504606846973
Symbol LONG-FLOAT-EPSILON  -> 1.1102230246251568d-16
Symbol *PRINT-RADIX*  -> NIL
Symbol *PRINT-CASE*  -> :UPCASE
Symbol LEAST-POSITIVE-NORMALIZED-SHORT-FLOAT  -> 1.1754944e-38
Symbol ARRAY-RANK-LIMIT  -> 65529
Symbol +  -> (COMMON-LISP-USER::LOGIN 'COMMON-LISP-USER::MC)
Symbol LEAST-POSITIVE-DOUBLE-FLOAT  -> 4.9406564584124654d-324
Symbol ***  -> NIL
Symbol MOST-NEGATIVE-LONG-FLOAT  -> -1.7976931348623157d308
Symbol DOUBLE-FLOAT-EPSILON  -> 1.1102230246251568d-16
Symbol *  -> T
Symbol *LOAD-VERBOSE*  -> NIL
Symbol CHAR-CODE-LIMIT  -> 1114112
Symbol LEAST-NEGATIVE-LONG-FLOAT  -> -4.9406564584124654d-324
Symbol MOST-POSITIVE-LONG-FLOAT  -> 1.7976931348623157d308
Symbol BOOLE-AND  -> 6
Symbol BOOLE-ORC2  -> 15
Symbol MOST-NEGATIVE-FIXNUM  -> -1152921504606846976
Symbol *PRINT-CIRCLE*  -> NIL
....

(defun show-variables (package)
  (do-symbols (s package)
    (multiple-value-bind (sym status)
        (find-symbol (symbol-name s) package)
      (when (and (or (eq status :external)
                     (eq status :internal))
                 (boundp sym))
        (format t "~&Symbol ~S~T -> ~S~%"
                sym
                (symbol-value sym))))))

今回は、KMRCLの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)))

今回は、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

(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)))

(defun ensure-keyword-upcase (desig)
  (nth-value 0 (ensure-keyword (string-upcase desig))))

(defun ensure-keyword-upcase (desig)
  (nth-value 0 (intern (string-upcase desig) :keyword)))

今回は、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)))))

今回は、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

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

(defun concat-symbol-pkg (pkg &rest args)
  (declare (dynamic-extent args))
  (flet ((stringify (arg)
           (etypecase arg
             (string
              (string-upcase arg))
             (symbol
              (symbol-name arg)))))
    (let ((str (apply #'concatenate 'string (mapcar #'stringify args))))
      (nth-value 0 (intern (string-default-case str)
                           (if pkg pkg *package*))))))

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

今回は、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"

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

(defun cl-symbols ()
  (append (cl-variables) (cl-functions)))

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

今回は、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)

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

今回は、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))

今回は、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)))

(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)

(let ((x (list 1 2 3 4)))
  (!!append !x (list 10 20 30 40))
  X)
;⇒ (1 2 3 4 10 20 30 40)

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

(defmacro defun-memo (fn args &body body)
  "Define a memoized function"
  `(memoize (defun ,fn ,args . ,body)))

(KL:DEFUN-MEMO FIB (N)
  (IF (< N 2)
      N
      (+ (FIB (1- N))
         (FIB (- N 2)))))
(FIB 100)
;⇒ 354224848179261915075

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

(defun memoize (fn-name)
  (setf (fdefinition fn-name) (memo-proc (fdefinition fn-name))))

(DEFUN FIB (N)
  (IF (< N 2)
      N
      (+ (FIB (1- N))
         (FIB (- N 2)))))
;; トレース
(TRACE FIB)
(FIB 5)
0: (FIB 5)
  1: (FIB 4)
    2: (FIB 3)
      3: (FIB 2)
        4: (FIB 1)
        4: FIB returned 1
        4: (FIB 0)
        4: FIB returned 0
      3: FIB returned 1
      3: (FIB 1)
      3: FIB returned 1
    2: FIB returned 2
    2: (FIB 2)
      3: (FIB 1)
      3: FIB returned 1
      3: (FIB 0)
      3: FIB returned 0
    2: FIB returned 1
  1: FIB returned 3
  1: (FIB 3)
    2: (FIB 2)
      3: (FIB 1)
      3: FIB returned 1
      3: (FIB 0)
      3: FIB returned 0
    2: FIB returned 1
    2: (FIB 1)
    2: FIB returned 1
  1: FIB returned 2
0: FIB returned 5
;⇒ 5
;; メモ化発動
(KL:MEMOIZE 'FIB)
(FIB 5)
0: (FIB 5)
  1: (FIB 4)
    2: (FIB 3)
      3: (FIB 2)
        4: (FIB 1)
        4: FIB returned 1
        4: (FIB 0)
        4: FIB returned 0
      3: FIB returned 1
      3: (FIB 1)
      3: FIB returned 1
    2: FIB returned 2
    2: (FIB 2)
    2: FIB returned 1
  1: FIB returned 3
  1: (FIB 3)
  1: FIB returned 2
0: FIB returned 5
;⇒ 5

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

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))

(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)))

今回は、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")

今回は、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))))))

今回は、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"

(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)
        ""))))

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

;;; URL Functions
(defvar *base-url* "")
(defun base-url! (url)
  (setq *base-url* url))

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

(setq kl:*base-url* "http://example.com/")

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

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

動作例は、
(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

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

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

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

(KL:ADD-SQL-QUOTES "foo'")
⇒ "foo''"

(defun add-sql-quotes (s)
  (substitute-string-for-char s #\' "''"))

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

(KL:ESCAPE-BACKSLASHES "foo\\bar\\baz")
⇒ "foo\\\\bar\\\\baz"

(defun escape-backslashes (s)
  (substitute-string-for-char s #\\ "\\\\"))

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

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

今回も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))))

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

;; SBCL
(MAPCAR #'KL:TRIM-NON-ALPHANUMERIC
        '("いろはにほへど、"
          "   ちりぬるを、"
          " わかよたれそ、"
          "        つねならむ"))
;⇒ ("いろはにほへど" "ちりぬるを" "わかよたれそ" "つねならむ")

(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))

(MAPCAR (CURRY #'metatilities:STRING-TRIM-IF
               (COMPLEMENT #'ALPHANUMERICP))
        '("いろはにほへど、"
          "   ちりぬるを、"
          " わかよたれそ、"
          "        つねならむ"))
;⇒ ("いろはにほへど" "ちりぬるを" "わかよたれそ" "つねならむ")

今回は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))))))

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

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

(KL:COLLAPSE-WHITESPACE "foo
bar 
baz
    quux")
⇒
"foo bar baz quux"

(defun collapse-whitespace (s)
  "Convert multiple whitespace characters to a single space character."
  (declare (simple-string s)
           (optimize (speed 3) (safety 0)))
  (with-output-to-string (stream)
    (do ((pos 0 (1+ pos))
         (in-white nil)
         (len (length s)))
        ((= pos len))
      (declare (fixnum pos len))
      (let ((c (schar s pos)))
        (declare (character c))
        (cond
         ((kl:is-char-whitespace c)
          (unless in-white
            (write-char #\space stream))
          (setq in-white t))
         (t
          (setq in-white nil)
          (write-char c stream)))))))

今回はKMRCLの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)
=> ("いろはにほへと" "ちりぬるを" "わかよたれそ" "つねならむ")

今回は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)))))

今回は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"

(LET ((S (MAKE-STRING 10 :INITIAL-ELEMENT #\X)))
  (KL:SHRINK-VECTOR S 5))
⇒ "XXXXXXXXXX"

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

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

(defun string-maybe-shorten (str maxlen)
  (string-elide str maxlen :end))

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

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

(defun string-elide (str maxlen position)
  (declare (fixnum maxlen))
  (let ((len (length str)))
    (declare (fixnum len))
    (cond
     ((<= len maxlen)
      str)
     ((<= maxlen 3)
      "...")
     ((eq position :middle)
      (multiple-value-bind (mid remain) (truncate maxlen 2)
        (let ((end1 (- mid 1))
              (start2 (- len (- mid 2) remain)))
          (concatenate 'string (subseq str 0 end1) "..." (subseq str start2)))))
     ((or (eq position :end) t)
      (concatenate 'string (subseq str 0 (- maxlen 3)) "...")))))

(or (eq position :end) t)

今回はKMRCLの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))))))))

■

今回は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

今回は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)))