[Axiom-developer] Lisp comparator

[Waldek Hebisch]

Below is a little utility that I use to compare Lisp files produced
by Axiom.  Axiom uses uninterned (gensymed) symbols in its output.
Such sumbols are printed like '#:G706711' where the numbers depend
on computation history.  When Lisp is reading the file the numbers
does not matter at all -- what matter is if two such symbols are
equal (which is marked in special way) or different.  When comparing
files as texts different numbering of gensymed symbols give a lot
of spuriouos differences.  The program below can discard most such
differences (it does not recurse into arrays, so it may sometimes
show difference for textually identical files).

Note that this _not_ a polished code, just something that other may
find useful (comments show how the code may be called).  BTW, I use
the Lisp code via a shell wrapper:

-------------<start wrapper>------------------
#!/bin/sh
exec /usr/bin/sbcl --noinform --noprint \
       --load /var/tmp/hebisch/axp4/pp/ldiff.fasl \
       --disable-debugger \
       --eval '(make-package "VMLISP")' \
       --eval '(make-package "BOOT")' \
       --eval '(compare-files "'"$1"'" "'"$2"'")' \
       --eval '(sb-ext:quit)'
#      --disable-debugger
-------------<end wrapper>--------------------



(defun read-forms (file)
    (let ((result nil) (pp))
         (do () (nil)
             (setf pp (read file nil nil))
             (if (null pp)
                 (return-from read-forms (reverse result))
                 (setf result (cons pp result))))))

;;; (compare-forms '(ala ola "as" (1 2 3)) '(ala ola "as" (1 2 3)))
(defun compare-forms (f1 f2)
(let ((sym-hash1 (make-hash-table))
      (sym-hash2 (make-hash-table))
      (sym-count 0))

(labels
((compare-forms-0 (f1 f2)
    (cond
         ((consp f1)
             (if (not (consp f2))
                 (return-from compare-forms nil))
             (do () (nil)
                 (let ((el1 (car f1)) (el2 (car f2)))
                      (setf f1 (cdr f1))
                      (setf f2 (cdr f2))
                      (if (not (compare-forms-0 el1 el2))
                          (return-from compare-forms nil)))
                 (if (not (and (consp f1) (consp f2)))
                     (return-from compare-forms-0
                         (compare-forms-0 f1 f2))))
             t)
         ((and (symbolp f1) (not (symbol-package f1)))
             (if (or (not (symbolp f2)) (symbol-package f2))
                 (return-from compare-forms nil))
             (let ((pp1 (gethash f1 sym-hash1))
                   (pp2 (gethash f2 sym-hash2)))
                  (if (not (equal pp1 pp2))
                       (return-from compare-forms nil))
                  (cond
                       ((not pp1)
                            (incf sym-count)
                            (setf (gethash f1 sym-hash1) sym-count)
                            (setf (gethash f2 sym-hash2) sym-count)))
                  t))
         (t (equalp f1 f2)))))
(compare-forms-0 f1 f2))))

(defun print-heading (el)
    (let ((*print-level* 2) (*print-length* 3))
        (pprint el)))
;;; (compare-files 
"/mn/a6/pom/axiom/nn5/ax-build1/int/algebra/INT.NRLIB/code.lsp" 
"/mn/a6/pom/axiom/nn6/ax-build1/int/algebra/INT.NRLIB/code.lsp")
(defun compare-files (name1 name2)
    (let* ((fil1 (open name1 :direction :input :if-does-not-exist :error))
           (fil2 (open name2 :direction :input :if-does-not-exist :error))
           (l1 (read-forms fil1)) (l2 (read-forms fil2)) (el2 nil))
         (dolist (el1 l1)
             (if (not (consp l2))
                 (return-from compare-files (and (format t "short l2~&") nil)))
             (setf el2 (car l2))
             (setf l2 (cdr l2))
             (if (not (compare-forms el1 el2))
                 (progn ()
                      (format t "Difference in:")
                      (print-heading el1)
                      (format t "~&and:")
                      (print-heading el2)
                      (format t "~&")
                      (return-from compare-files nil))))
         (not l2)))




-- 
                              Waldek Hebisch
address@hidden