ARNESI

Debugging Utilties 

(These were far more usefull in the pre-slime days.)

(defmacro ppm1 (form)
  "(pprint (macroexpand-1 ',form)).

NB: C-RET is even shorter."
  `(pprint (macroexpand-1 ',form)))

(defmacro ppm (form)
  `(pprint (macroexpand ',form)))

A portable flexable APROPOS implementation

(defun apropos-list* (string &key (fbound nil fbound-supplied-p)
                                  (bound nil bound-supplied-p)
                                  (package nil package-supplied-p)
                                  (distance 0 distance-supplied-p))
  (let ((symbols '()))
    (do-all-symbols (sym)
      (block collect-symbol
        (when fbound-supplied-p
          (when (xor fbound (fboundp sym))
            (return-from collect-symbol)))
        (when bound-supplied-p
          (when (xor bound (boundp sym))
            (return-from collect-symbol)))
       (when package-supplied-p
         (unless (eql package (symbol-package sym))
           (return-from collect-symbol)))
       (when distance-supplied-p
         (unless (and
                  (<= (abs (- (length (symbol-name sym)) 
                              (length string)))
                      distance)
                  (<= (levenshtein-distance string (symbol-name sym))
                      distance))
           (return-from collect-symbol)))
       (when (not distance-supplied-p)
         ;; regular string= test
         (unless (search string (symbol-name sym) :test #'char-equal)
           (return-from collect-symbol)))
       ;; all the checks we wanted to perform passed.
       (push sym symbols)))
    symbols))

(defun apropos* (&rest apropos-args)
  (flet ((princ-length (sym)
           (if (keywordp sym)
               (+ 1 (length (symbol-name sym)))
               (+ (length (package-name (symbol-package sym)))
                  1
                  (length (symbol-name sym))))))
    (let* ((syms (apply #'apropos-list* apropos-args))
           (longest (apply #'max (mapcar #'princ-length syms))))
      (dolist (sym syms)
        (if (keywordp sym)
            (progn
              (princ ":" *debug-io*)
              (princ (symbol-name sym) *debug-io*))
            (progn
              (princ (package-name (symbol-package sym)) *debug-io*)
              (princ ":" *debug-io*)
              (princ (symbol-name sym) *debug-io*)))
        (princ (make-string (- longest (princ-length sym))
                            :initial-element #\Space)
               *debug-io*)
        (when (fboundp sym)
          (princ " [FUNC] " *debug-io*))
        (when (boundp sym)
          (princ " [VAR] " *debug-io*))
        (terpri *debug-io*))))
  (values))