llibra

(defun square (x) (expt x 2))
;; =>  SQUARE

(define-compiler-macro square (&whole form arg)
  (if (atom arg)
      `(expt ,arg 2)
      (case (car arg)
        (square (if (= (length arg) 2)
                    `(expt ,(nth 1 arg) 4)
                    form))

llibra

(mapcar #'square '(0 1 2 3 4))
;; =>  (0 1 4 9 16)

llibra

(defun mvb (f)
  (declare (optimize (speed 3) (safety 1) (debug 1)))
  (multiple-value-bind (x y) (funcall f)
    (values (+ x y) (- x y))))

(defun mvl (f)
  (declare (optimize (speed 3) (safety 1) (debug 1)))
  (let* ((l (multiple-value-list (funcall f)))
         (x (car l))
         (y (cadr l)))

llibra

;; 元のパッケージに新しいニックネームを付ける
(defmacro define-package-alias (name package-designator)
  (let ((designator (gensym)))
    `(let ((,designator ,package-designator))
       (rename-package ,designator
                       ,designator
                       (union (list (string ,name))
                              (package-nicknames ,designator)
                              :test #'equal)))))

llibra

(values
 (let ((*package* (find-package :keyword)))
   (symbol-package (read-from-string "a")))
 (let ((*package* (find-package :cl-user)))
   (symbol-package (read-from-string "a"))))
;=> #<Package "KEYWORD">, #<Package "COMMON-LISP-USER">

(values
 (let ((*package* (find-package :cl-user)))
   (symbol-package (funcall (eval (read-from-string "#'(lambda () 'a)")))))

llibra

(defmacro do-mvb (var-bindings end-and-result &body body)
  (let* ((bindings nil)
         (first-time-p (gensym))
         (var-bindings-
          (reduce (lambda (result binding)
                    (if (consp binding)
                        (destructuring-bind (value . form) binding
                          (cond ((consp value)
                                 (push (cons value form) bindings)
                                 (append result value))

llibra

(defun hex-dump (seq &key (address-length 8) (address-offset 0))
  (labels ((x->char (x)
             (let ((c (code-char x)))
               (if (and (standard-char-p c) (graphic-char-p c)) c #\.)))
           (x->str (l)
             (coerce (mapcar #'x->char l) 'string))
           (print-header ()
             (princ (make-string address-length :initial-element #\=))
             (let ((l '#.(loop for n below 16 collect n)))
               (format t "== ~{+~x ~}=================~%" l)))

llibra

;; char-code-limit - 1の大きさの配列を表として使うバージョン
;; 0x10ffffという巨大な表を作るため、空間効率が非常に悪い
;; 表を外部に出せば、同じパターンを繰り返し検索する場合には効果的と思われるが、
;; 検索する回数が少ないと元を取れない
(defun quick-search/array (string-x string-y)
  (declare (optimize speed (debug 0) (safety 0))
           (type simple-string string-x string-y))
  (let* ((length-x (length string-x))
         (length-y (length string-y))
         (boundary (- length-y length-x)))

llibra

diff -Nur -x '*~' -x '#*#' portableaserve-20110730-cvs/acl-compat/mcl/acl-mp.lisp portableaserve-20110730-cvs.mod/acl-compat/mcl/acl-mp.lisp
--- portableaserve-20110730-cvs/acl-compat/mcl/acl-mp.lisp	2011-10-30 15:28:17.484375000 +0900
+++ portableaserve-20110730-cvs.mod/acl-compat/mcl/acl-mp.lisp	2011-10-30 15:22:06.296875000 +0900
@@ -181,3 +181,24 @@
           (process-wait-with-timeout (or whostate "Waiting for input") timeout #'collect-fds)
           (process-wait (or whostate "Waiting for input") #'collect-fds)))
     collected-fds))
+
+#+openmcl-native-threads
+(defvar *atomic-lock* (ccl:make-lock))

llibra

(kc.db:with-db (db "test.kch" :reader :writer :create)
  (cffi:with-foreign-strings (((kb ks) "Common") ((vb vs) "Lisp"))
    (let ((ks (1- ks)) (vs (1- vs)))
      (cffi:defcallback full :pointer
          ((kbuf :pointer) (ksiz kc.ffi.core:size_t) (vbuf :pointer)
           (vsiz kc.ffi.core:size_t) (sp :pointer) (opq :pointer))
        (declare (ignore kbuf ksiz vbuf vsiz opq))
        (setf (cffi:mem-aref sp 'kc.ffi.core:size_t) vs)
        vb)
      (cffi:defcallback empty :pointer