compile.lにパッチを当てて https://github.com/miyamuko/xl-critic をバイトコンパイル

compile.l.patch

--- compile.l	2002-03-25 02:49:18 +0900
+++ compile_fix.l       2011-05-31 22:48:44 +0900
@@ -649,6 +649,10 @@
 (defun compile-call (form)
   (let ((f (assoc (car form) *macro-environment* :test #'eq)))
     (cond ((null f)
+          (when (and (consp (car form))
+                     (eq 'lambda (caar form)))
+            (format t "~&calling lambda form: ~S~%" form)
+            (push 'funcall form))
           (dolist (f (cdr form))
             (compile-form f))
           (output-insn 'insn-call (car form) (- (length form) 1)))

compile_log.l

(dolist (f (directory "~/site-lisp/critic" :wild "*.l"
		      :recursive t :absolute t))
  (byte-compile-file f))

(defvar *known-pattern-types* '(:single :segment :none))...
(defconstant var-prefix (if (boundp 'var-prefix) (symbol-value 'var-prefix) "?"))...
Compiling pat-var-p...
Compiling single-pat-var-p...
Compiling segment-pat-var-p...
Compiling pat-var-name...
Compiling var-type-name-p...
Compiling prefix-p...
(defvar *pattern-types* (make-hash-table :test 'equal))...
(defvar *pattern-functions* (make-hash-table :test 'equal))...
Compiling pat-function...
Compiling pat-type...
Compiling add-extension...
Compiling pat-extension-p...
Compiling segment-pat-extension-p...
Compiling pat-match...
Compiling match-extension...
Compiling match-segment-extension...
Compiling instantiate-pattern...
Compiling instantiate-cons...
Compiling instantiate-var...
Compiling bind-variable...
Compiling extend-bindings...
Compiling get-binding...
Compiling add-binding...
Compiling binding-variable...
Compiling binding-value...
Compiling match-variable...
calling lambda form: ((lambda (name) (bind-variable name input blists)) (cond (args (car args)) (t nil)))
Compiling match-segment-variable...
calling lambda form: ((lambda (name) (do* ((tail input (rest tail)) (new-blists (match-tail tail name pats input blists) (append (match-tail tail name pats input blists) new-blists))) ((null tail) new-blists))) (cond (args (car args)) (t nil)))
Compiling match-tail...
Compiling match-and...
Compiling match-predicate...
calling lambda form: ((lambda (pred) (and (not (null blists)) (funcall pred input) blists)) (car args))
Compiling match-match...
calling lambda form: ((lambda (pat) ((lambda (input-pat) (loop for blist in blists append (pat-match pat (instantiate-pattern input-pat blist) blists))) (car (cdr args)))) (car args))
calling lambda form: ((lambda (input-pat) (loop for blist in blists append (pat-match pat (instantiate-pattern input-pat blist) blists))) (car (cdr args)))
Compiling match-not...
calling lambda form: ((lambda (pat) (cond ((null blists) nil) ((pat-match pat input blists) nil) (t blists))) (car args))
Compiling match-or...
done.
(defparameter *length-threshold* 55)...
(defvar *critic-version* 1.1)...
(defvar *top-level* nil)...
Compiling lisp-critic-version...
Compiling clear-critique-db...
(defparameter *output-width* 70)...
(defmacro define-lisp-pattern (name pattern format-string &rest args) (unless (symbolp name) (error "Non-symbolic Lisp pattern name ~S" name)) (list 'add-lisp-pattern (list 'quote name) (list 'quote pattern) format-string (list 'quote args)))...
Compiling add-lisp-pattern...
Compiling get-pattern-names...
Compiling remove-lisp-pattern...
(defmacro critique (form) (list 'critique-definition (list 'quote form)))...
Compiling critique-definition...
Compiling critique-file...
Compiling generate-critiques...
Compiling apply-critique-rule...
Compiling print-critique-responses...
Compiling find-critiques...
Compiling critique-match...
Compiling make-critiques...
Compiling print-critique-response...
Compiling make-response-string...
Compiling make-string...
Compiling print-separator...
Compiling match-contains...
calling lambda form: ((lambda (pat) (find-match pat input blists)) (car args))
Compiling find-match...
Compiling match-repeat...
calling lambda form: ((lambda (pat) ((lambda (n) (match-repeat-pat n pat pats input blists)) (cond ((cdr args) nil (car (cdr args))) (t 1)))) (car args))
calling lambda form: ((lambda (n) (match-repeat-pat n pat pats input blists)) (cond ((cdr args) nil (car (cdr args))) (t 1)))
Compiling match-repeat-pat...
Compiling match-optional...
Compiling match-name-contains...
calling lambda form: ((lambda (substring) (and (symbolp input) (position substring (symbol-name input) :test #'string-equal) blists)) (car args))
Compiling match-name-ends-with...
calling lambda form: ((lambda (substring) (and (symbolp input) (string-ends-with (symbol-name input) substring) blists)) (car args))
Compiling string-ends-with...
Compiling match-eql-pred...
calling lambda form: ((lambda (name) (and (member input '(eq eql equal equalp)) (bind-variable name input blists))) (cond (args (car args)) (t nil)))
Compiling match-too-long...
calling lambda form: ((lambda (name) (let ((badness (get-length-badness input))) (when (> badness 0) (bind-variable name (get-badness-phrase badness) blists)))) (cond (args (car args)) (t nil)))
Compiling get-length-badness...
Compiling list-count...
Compiling get-badness-phrase...
Compiling match-sets-free-vars...
calling lambda form: ((lambda (name) (let ((vars (remove-duplicates (find-assigned-free-vars input)))) (if (null vars) nil (bind-variable name vars blists)))) (cond (args (car args)) (t nil)))
Compiling match-top-level...
Compiling find-assigned-free-vars...
Compiling code-assigned-free-vars...
Compiling get-free-vars...
Compiling remove-local-vars...
Compiling code-assigned-vars...
Compiling code-vars...
Compiling get-vars...
Compiling get-var...
Compiling get-loop-vars...
Compiling loop-binder-p...
done.
done.
(defmacro deftable (fn) (let ((set-fn (gentemp))) (list 'eval-when '(:compile-toplevel :load-toplevel :execute) (list 'let* (cons (list 'fn (list 'quote fn)) '((table (get-table fn)))) (list* 'defun fn '((&optional (key nil key-given-p)) (if key-given-p (gethash key table) table))) (list* 'defun set-fn '((arg1 &optional (arg2 nil arg2-p)) (cond (arg2-p (setf (gethash arg1 table) arg2)) (t (set-table fn arg1)))))) (list 'defsetf fn set-fn) (list 'quote fn))))...
(defvar *tables* (make-hash-table) "Table of DEFTABLE functions.")...
Compiling get-table...
Compiling set-table...
Compiling remove-key...
Compiling clear-table...
Compiling map-table...
done.
Compiling write-string...
Compiling write-wrap...
Compiling whitespace-p...
Compiling break-pos...
done.
nil

test.l

(time
 (lisp-critic:critique
  (defun count-a (lst)
    (setq n 0)
    (dolist (x lst)
      (if (equal x 'a)
	  (setq n (+ n 1))))
    n)))
----------------------------------------------------------------------
Don't use setq inside DOLIST to accumulate values for n.
Use DO. Make n a DO variable and don't use SETQ etc at all.
----------------------------------------------------------------------
You have an IF with no else branch. If the return value of the IF
matters, you should explicitly say what the else returns, e.g., NIL.
If the return value doesn't matter, use WHEN or UNLESS.
----------------------------------------------------------------------
INCF would be simpler to add 1 to n than (lisp-critic::?
lisp-critic::FN)
----------------------------------------------------------------------
GLOBALS!! Don't use global variables, i.e., n
----------------------------------------------------------------------
Unless something special is going on, use EQL, not equal.
----------------------------------------------------------------------
Don't use (+ n 1), use (1+ n) for its value or (incf n) to change n,
whichever is appropriate here.
----------------------------------------------------------------------
203 msec