Library

Part 1.
;;; ------------------------------------------------------------------ 
;;; String Manipulation 
;;; 
;;; Export control 
;;; o chop$ separator string 
;;; 文字列をセパレータで区切ったリストに変換する． 
;;; 
;;; o chops$ stringﾊ &rest separators 
;;; 文字列をセパレータで区切ったリストにする．複数のセパレータ 
;;; を指定できる．非効率的な実装なので注意を喚起するために引数 
;;; の順番を逆にしてある． 
;;; 
;;; o cat$ &rest string-list 
;;; 文字列を連結する． 
;;;
(defun lib$find (item string) 
 (search item string :test #'string=)) 
; (lib$find "-" "123-456-7890")

(defun chop$ (separator string) 
  (let ((pos (lib$find separator string))) 
    (if (null pos) 
      (list string) 
      (let ((head (subseq string 0 pos)) 
            (rest (subseq string (1+ pos)))) 
        (cons head (cons separator (chop$ separator rest))))))) 
;(chop$ "-" "123-456-7890")

(defun chops$ (string &rest separators) 
  ;; 低速な実装なので引き数を逆にして使用に注意を喚起する 
  (if (null separators) 
    (list string) 
    (let ((chopped (chop$ (first separators) string))) 
      (loop 
        for element in chopped 
        append (apply #'chops$ element (cdr separators)))))) 
; (chops$ "123-456-7890.ldt" "-" ".")

(defun cat$ (&rest string-list) 
  (apply #'concatenate 'string string-list))

(defun lib$tr (from-char to-char string) 
  ;; replace all from-char to to-char in string 
  (apply #'cat$ 
         (loop 
           for tmp in (chop$ from-char string) 
           collect (if (string= from-char tmp) 
                     to-char 
                     tmp)))) 
; (lib$tr "/" ":" "aaa/bbb/ccc") 
 
;;; ------------------------------------------------------------------ 
;;; File System 
;;; 
;;; Export control 
;;; o unix->macintosh-pathname 
;;; o macintosh->unix-pathname 
;;; 
;;; Inport control 
;;; o lib$tr from String manipulation section 
;;;
(defparameter lib$<unix-pathname-separator> "/") 
(defparameter lib$<macintosh-pathname-separator> ":")
(defun lib$unix->macintosh-pathname (unix-pathname) 
  (lib$tr lib$<unix-pathname-separator> 
          lib$<macintosh-pathname-separator> 
          unix-pathname)) 
; (lib$unix->macintosh-pathname "/usr/home/rdl/work/index.html")
(defun lib$macintosh->unix-pathname (macintosh-pathname) 
  (lib$tr lib$<macintosh-pathname-separator> 
          lib$<unix-pathname-separator> 
          macintosh-pathname)) 
; (lib$macintosh->unix-pathname ":usr:home:rdl:work:index.html") 
 
;;; ------------------------------------------------------------------ 
;;; HTML Generation 
;;; 
;;; Export control 
;;; o with-open-html-file ofileﾊ &rest body 
;;; ファイルに body で定義する html を書込む． 
;;; 
;;; o htmlﾊﾊ format-string &rest vars 
;;; html に文字列を書込む．変数を展開することができる． 
;;; 変数展開時は文字列を #'format に渡すので，#'format 
;;; で定義されている出力形式が指定できる． 
;;; 
;;; o hpﾊﾊ tagﾊ &rest body 
;;; 開始／終了タグを１箇所で定義し，閉じ忘れないように 
;;; している．もしも開始タグで変数を展開したい時には， 
;;; これのかわりに #'html を使うこと． 
;;;
(defparameter lib$*html-working-storage* nil)
(defun lib$html-open () 
  (declare (special lib$*html-working-storage*)) 
  (setf lib$*html-working-storage* nil))
(defun html (format-string &rest vars) 
  (declare (special lib$*html-working-storage*)) 
  (push (apply #'format `(nil ,format-string ,@vars)) 
        lib$*html-working-storage*))
(defun lib$html-close () 
  (declare (special lib$*html-working-storage*)) 
  (setf lib$*html-working-storage* 
        (reverse lib$*html-working-storage*)))
(defmacro with-open-html-file (ofile &rest body) 
  `(progn 
     (lib$html-open) 
     ,@body 
     (lib$html-close) 
     (lib$lisp->html-file lib$*html-working-storage* ,ofile)))
(defun lib$lisp->html-file (lisp ofile) 
  (let ((ostream (fred (create-file ofile :if-exists :supersede)))) 
    (loop 
      for string in (lib$flatten lisp) 
      do (format ostream "‾A‾%" (lib$dequoter string))) 
    (fred-update ostream) 
    (window-save ostream) 
    (window-close ostream)))
(defun lib$flatten (s-exp) 
  (cond ((null s-exp) nil) 
        ((not (listp s-exp)) nil) 
        ((stringp (car s-exp)) (cons (car s-exp) (lib$flatten (cdr s-exp)))) 
        (t (append (lib$flatten (car s-exp)) (lib$flatten (cdr s-exp))))))
(defun lib$dequoter (line) 
  ;; sqp - single-quote-position 
  (let ((sqp (position #¥' line :test #'char=))) 
    (if (null sqp) 
      line 
      ;; single or double? 
      (if (char= (elt line (1+ sqp)) #¥') 
        (cat$ (subseq line 0 sqp) "¥"" 
             (lib$dequoter (subseq line (+ sqp 2)))) 
        (cat$ (subseq line 0 sqp) "'" 
             (lib$dequoter (subseq line (1+ sqp)))))))) 
;;;; (lib$dequoter "This is a ''sample''.")
(defmacro hp (tag &rest body) 
  ;; tag = "a href='#'../img/test.gif'' 
  ;; -> <a href=http://www.geocities.jp/server-errors/not_found.html ... </a> 
  (let* ((start-tag (cat$ "<" tag ">")) 
         (tg (subseq tag 0 ; removing options for closing tag 
                     (position #¥Space tag :test #'char=))) 
         (end-tag (cat$ "</" tg ">"))) 
    `(block HTML-CLOSURE 
      (html ,start-tag) 
       ,@body 
       (html ,end-tag))))
Part 2.
この項続く