Common Lisp配置：SBCL

在FreeBSD及ArchLinux中， 我常使用SBCL。

启动脚本：

>cat ~/bin/sb

breakchars="(){}[],^%$#@\"\";:''|\\"
cd /media/E/work
exec rlwrap --remember -c -b "$breakchars" -f "$HOME"/.sbcl_completions -S 'λ> ' sbcl --noinform "$@"

其中，~/.sbcl_completions由以下代码产生：

(let (symbols)
    (do-all-symbols (sym)
        (let ((package (symbol-package sym)))
            (cond
                ((not (fboundp sym)))
                ((or (eql #.(find-package :cl) package)
                     (eql #.(find-package :cl-user) package))
                    (pushnew (symbol-name sym) symbols))
                ((eql #.(find-package :keyword) package)
                    (pushnew (concatenate 'string ":" (symbol-name sym)) symbols))
                (package
                    (pushnew (concatenate 'string (package-name package) ":" (symbol-name sym  symbols)))))

    (with-open-file (output (merge-pathnames ".sbcl_completions" (user-homedir-pathname))
        :direction :output :if-exists :overwrite
        :if-does-not-exist :create)
        (format output "~{~(~A~)~%~}" (sort  symbols   #'string<))))

运行控制文件：

>cat ~/.sbclrc

;;; The following lines added by ql:add-to-init-file:
#-quicklisp
(let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp" (user-homedir-pathname))))
    (when (probe-file quicklisp-init)
        (load quicklisp-init)))

(defun setup-registry (directory-path)
    ;(format t "; adding components under ~A to asdf registry~%" directory-path)
    (mapc (lambda (asd-pathname)
        (pushnew (make-pathname :name nil :type nil :version nil :defaults asd-pathname) asdf:*central-registry*))
        (directory (merge-pathnames #p"*/*.asd" directory-path))))

(setup-registry #p"/media/E/myapp/")
(setup-registry #p"/media/E/www/qachina/")

;(asdf:operate 'asdf:load-op :myapp)
;(myapp:start-myapp)

; disable dubugger same as '--disable-debugger' commmand line option

;(defun debug-ignore (c h) (declare (ignore h)) (print c) (abort))
;(setf*debugger-hook* #'debug-ignore)

;(setf *invoke-debugger-hook*
; (lambda (condition hook)
; (declare (ignore hook))
; Uncomment to get backtraces on errors
; (sb-debug:backtrace 20)
; (format *error-output* "Error: ~A~%" condition)) (abort))

(load "util")

一些常用函数放在util.lisp中：

>cat /media/E/work/util.lisp

;(sys-src-dir "hunchentoot" => #P"/home/sw2wolf/quicklisp/dists/quicklisp/software/hunchentoot-1.2.6/"

defun pkg-src-dir (name)
  (asdf:system-source-directory name))

;(pkg-ver "hunchentoot") => 1.2.6

(defun pkg-ver (system-designator)
   (let ((system (asdf:find-system system-designator nil)))
    (when (and system (slot-boundp system 'asdf:version))
      (asdf:component-version system))))

;在QuickLisp中查找软件包
(defun find-pkg (name)
  (ql:system-apropos name))

(defun leap-year-p (year)
    (destructuring-bind (fh h f)
        (mapcar #'(lambda (n) (zerop (mod year n))) '(400 100 4))
        (or fh (and (not h) f))))

(defun now ()
    (multiple-value-bind (second minute hour day month year) (get-decoded-time)
    (format t "~4,'0D-~2,'0D-~2,'0D ~2,'0D:~2,'0D:~2,'0D" year month day hour minute second)))

(defun my-getenv (name &optional default)
#+CMU
    (let ((x (assoc name ext:*environment-list* :test #'string=)))
        (if x (cdr x) default))
#-CMU
    (or
        #+Allegro (sys:getenv name)
        #+CLISP (ext:getenv name)
        #+ECL (si:getenv name)
        #+SBCL (sb-unix::posix-getenv name)
        #+LISPWORKS (lispworks:environment-variable name)
        default))

(defun sh (cmd)
    #+clisp

        (let ((str (ext:run-shell-command cmd :output:stream)))
            (loop for line = (read-line str nil)
             until (null line)
             do (print line)))

    #+ecl (si:system cmd)
    #+sbcl (sb-ext:run-program "/bin/sh" (list "-c" cmd) :input nil :output *standard-output*)
    #+clozure (ccl:run-program "/bin/sh" (list "-c" cmd) :input nil :output *standard-output*)))

(defun sys-info ()
    (formatt"Machine: ~S ~S ~S~%OS: ~S ~S~%Lisp: ~S ~S~%"
        (machine-type) (machine-version)(machine-instance)
        (software-type) (software-version)

        (lisp-implementation-type) (lisp-implementation-version )))

;根据关键字类型以不同方式查找关联表

(defgeneric assoc* (thing alist)   
  (:method ((thing symbol) alist)
    (assoc thing alist :test #'eq))
  (:method ((thing string) alist)
    (assoc thing alist :test #'string-equal))
  (:method (thing alist)
    (assoc thing alist :test #'eql)))

;阶乘

(defun fac (n)(reduce#'* (loopfor ifrom 1to ncollect i)))

(defun fab (n)

"菲波纳契数列。不用递归，直接加在列表尾部，极高的性能"
  (let ((res (list 1 1)))
    (loop for i from 2to n do
      (nconc res (list (+ (nth (- i 2) res) (nth (- i 1) res)))))
    res))

;返回整数的二进制表示

(defun bits (n) (format t "~b" n))

;完美数
(defun perfectp (n) (= n (loop for ifrom 1below nwhen (= 0 (mod n i))sum i)))

(defun perfect-number (s e)
  (loop for ifrom sto e when (perfectp i)collect i))

...

编译及运行lisp程序的脚本文件：

>cat ~/bin/sbcl.compile
#!/bin/bash
sbcl --noinform --eval "(compile-file \"$1\")" --eval "(quit)" > /dev/null

使用方法
>sbcl.compile hello.lisp

将生成hello.fasl文件

>cat ~/bin/sbcl.run
#!/bin/bash
sbcl --noinform --load --quit $1 --end-toplevel-options "$@"

使用方法
# sbcl.run hello.fasl

BTW, now it is VERY simple to build the newest SBCL from your current sbcl:

$git clone git://git.code.sf.net/p/sbcl/sbcl && cd sbcl

$sh make.sh --prefix=/home/***/sbcl/ --xc-host="sbcl --disable-debugger --no-sysinit --no-userinit"