lib.l 自前のライブラリ

結構増えてきてしまったので、バックアップとして置いておく。

lib.l - コマンドにならない小さな関数群*1

;;;
;;; lib.l
;;;
(provide "lib")

;;; @@@ loop-at-buffer
;;; バッファを1行ずつ処理する
;;; e.g. (loop-at-buffer (line)
;;;        (dbg-msgbox line))
(defmacro loop-at-buffer ((var &optional buffer) &body body)
  (let ((gbuf (gensym))
        (gstream (gensym)))
    `(let* ((,gbuf (cond ((null ,buffer) (selected-buffer))
                         ((bufferp ,buffer) ,buffer)
                         (t (find-buffer ,buffer))))
            (,gstream (if ,gbuf (make-buffer-stream ,gbuf)
                        (error "\"~A\"という名前のバッファが見つかりません" ,buffer))))
       (loop
         (let ((,var (read-line ,gstream nil)))
           (unless ,var (return nil))
           ,@body)))))


;;; @@@ char-alphabet-p, char-number-p
(defun char-alphabet-p (ch)
  (if (char-not-greaterp #\a ch #\z) t
    nil))

(defun char-number-p (ch)
  (if (char<= #\0 ch #\9) t
    nil))


;;; @@@ windows-local-path-p
(defun windows-local-path-p (path)
  (let ((pos (position #\: path)))
    (if (and (= pos 1)
             (char-alphabet-p (char path 0))) t
      nil)))


;;; @@@ upcase-drive-letter
(defun upcase-drive-letter (s)
  (if (char= #\: (char s 1))
      (string-upcase s :start 0 :end 1)
    s))


;;; @@@ concat-path
(defun concat-path (path1 &rest path)
  (let ((ret (string-right-trim "/" (map-backslash-to-slash path1))))
	(dolist (p path ret)
	  (setq ret (concat ret "/" (string-trim "/" (map-backslash-to-slash p)))))))


;;; @@@ string<, string-lessp
(defun string-length< (x y)
  (cond ((< (length x) (length y)) t)
        ((> (length x) (length y)) nil)
        ((string< x y) t)
        (t nil)))

(defun string-length-lessp (x y)
  (cond ((< (length x) (length y)) t)
        ((> (length x) (length y)) nil)
        ((string-lessp x y) t)
        (t nil)))


;;; @@@ truename
;;; mod: fixed removing trailing slash
(defun truename-mod (path)
  (let ((endc (char path (1- (length path)))))
    (if (or (eq endc #\/)
            (eq endc #\\))
        (append-trail-slash (truename path))
      (truename path))))


;;; @@@ for
;;; e.g.: (for (i 1 10)
;;;         (dbg-msgbox i))
(defmacro for ((var start stop) &body body)
  (let ((gstop (gensym)))
    `(do ((,var ,start (1+ ,var)) (,gstop ,stop))
         ((>= ,var ,gstop))
       ,@body)))


;;; @@@ eol, bol
(defun eol ()
  (save-excursion
    (goto-eol)(point)))

(defun bol ()
  (save-excursion
    (goto-bol)(point)))


;;; @@@ path-delim-to-slash        ; \ --> /
;;;     path-delim-to-back-slash   ; / --> \

;;; ￥ --> /
(defun path-delim-to-slash (path)
  (substitute-string path "\\\\" "/"))

;;; / --> ￥
(defun path-delim-to-back-slash (path)
  (substitute-string path "/" "\\\\"))


;;; @@@ msgbox for lisp debug
;;; usage: (dbg-msgbox args)
(defmacro dbg-msgbox (&rest vars)
  `(msgbox 
    (concat ,@(make-list (length vars) :initial-element "~S\n"))
    ,@vars))

;;; @@@ pme (print macro expand)
;;; http://www.shido.info/lisp/add2li.l.txt
;;; usage: (pme (macro-name args))[C-j]
(defmacro pme (mac)
  `(pprint-1 (macroexpand-1 ',mac)))
           
;; mod
(defun pprint-1 (s0)
  (pp-loop (substitute-string (format nil "~S" s0) "\n" "\\\\n"))
  (values))

(defun pp-loop (str0 &optional then)
  (if (and then (eql 0 (string-match " *[^ (]+" str0)))
      (let ((pe (match-end 0)))
    (insert (substring str0 0 pe))
    (lisp-newline-and-indent)
    (pp-loop (substring str0 pe) nil))
    (progn
      (string-match ")+\\|( *cond +\\|case +[^ (]+" str0)
      (let* ((px   (match-end 0))
         (str1 (substring str0 0 px))
         (pif0 (string-match "\\( *( *if +\\)\\|\\( *( *if +[^ (]+\\)" str1))
         (pif1 (match-end 2))
         (p1   (or pif1 px)))
    (if (and pif0 (< 0 pif0))
        (progn
          (insert (substring str0 0 pif0))
          (lisp-newline-and-indent)
          (insert (substring str0 pif0 p1)))
      (insert (substring str0 0 p1)))
    (lisp-newline-and-indent)
    (if (< p1 (length str0))
        (pp-loop (substring str0 p1) pif0))))))

;;; lib.l ends here

*1:先人達から拝借させてもらったものも含む