[Axiom-developer] check algebra in lisp

[daly]

Lisp is good at manipulating lisp. You can use it to skip over
gensyms and linebreaks, comments, and all kinds of other noise,
including knowing that 'asdf and '|ASDF| are equal.

Here is the algebra check program I use. 
It does not require perl, awk, sed, and other tools.

=======================================================================
;;; check is a lisp-based regression test function that complains if
;;; the newly compiled algebra differs from the reference algebra.
;;;
;;; To use it, just invoke the check function
;;; (Note that the directories are hardcoded since they rarely change)
;;; (Note that you must compile this file due to recursion depth)


;;; In this example, the API and NOTTING domains are new and are not in
;;; the reference algebra. The ASTACK, DEQUEUE, FLOAT, and STACK domains
;;; have added missing functions in the latest release. The 
;;;     --- is the new directory function
;;;     +++ is the reference directory function
;;; check exits on first failure.

;  
;  (check)
;  
;  WARNING: /research/reference/int/algebra/API.nrlib/code.lsp does not exist
;  FAILED API
;  
;  FAILED #p/research/test/int/algebra/ASTACK.nrlib
;   ASTACK;pop!;$S;10 ---m
;   ASTACK;pop!;$S;10 +++r
;  
;  FAILED #p/research/test/int/algebra/DEQUEUE.nrlib
;   DEQUEUE;bottom!;$S;1 ---COND
;   DEQUEUE;bottom!;$S;1 +++SPADCALL
;  
;  FAILED #p/research/test/int/algebra/FLOAT.nrlib
;   FLOAT;fixed ---l
;   FLOAT;fixed +++G1898
;  
;  WARNING: /research/reference/int/algebra/NOTTING.nrlib/code.lsp does not 
exist
;  FAILED NOTTING
;  
;  FAILED #p/research/test/int/algebra/STACK.nrlib
;   Stack ---Stack
;   Stack +++STACK;parts;$L;15




;;; gensymp is a simple predicate to recognize gensyms
(defun gensymp (x) (and (symbolp x) (null (symbol-package x))))



;;; a global variable used to remember which function we are in
(defvar fn nil)



;;; same? takes 2 s-expressions, a and b, and recursively compares them.
;;; 
;;; samep is true until a miscompare.
;;; pn is the pathname for printing.
;;; 
;;; it remembers entry into a function by recognizing (defun ...
;;; it remembers entry into a (makeprop ....
;;;
;;; it is robust in the presence of cyclic structures because
;;; it remembers the address of every pair. if the same address
;;; is seen again it will be found in the hashtable and skipped
;;; since we will have already walked the substructure.
;;;
;;; if samep is ever nil then a compare failed and we immediately exit
;;; if a and b are gensyms, we claim they are equal
;;; if a and b are list structures, we recursively walk them
;;;    if the walk fails, we complain and throw out
;;; if a and b are vectors, we recursively walk them
;;; otherwise, we compare a and b for equality
;;; 
(defun same? (a b samep pn)
 (let ((cycle? (gethash a cycle)))
 (declare (special fn))
 (when (and (consp a) (eq (car a) 'defun)) (setq fn (cadr a)))
 (when (and (consp a) (eq (car a) 'makeprop)) 
   (setq fn (list 'makeprop (cadadr a))))
 (if cycle?
  t
  (cond
   ((null samep) nil)
   ((and (gensymp a) (gensymp b)) t)
   ((and (consp a) (consp b))
    (setf (gethash a cycle) a)
    (setq samep 
     (and (same? (car a) (car b) samep pn)
          (same? (cdr a) (cdr b) samep pn)))
    (when (and (not samep) (not (same? (car a) (car b) t pn)))
      (format t "~%FAILED ~a~% ~a ---~a~% ~a +++~a~%" pn fn (car a) fn (car b))
      (throw 'different nil))
    (when (not samep)
      (format t "~%FAILED ~a~% ~a ---~a~% ~a +++~a~%" pn fn (cdr a) fn (cdr b))
      (throw 'different nil))
    samep)
   ((and (vectorp a) (vectorp b))
     (let ((result t) place)
      (dotimes (i (length a))
       (when result
        (setq result (same? (aref a i) (aref b i) t pn)))) 
      result))
   ((setq samep (equal a b)))))))



;;; init is a trivial file-read function and returns a list of all
;;; s-expressions in the file
;;;
(defun init (path)
 (with-open-file (in path)
  (do ((a (read in nil :done) (read in nil :done)) (c nil))
      ((eq a :done) (reverse c))
   (push a c))))



;;; check has hardcoded paths to your build int/algebra directory
;;; and your reference/int/algebra directory.
;;; 
;;; check walks the new int/algebra directory and for each nrlib it:
;;;   reads the code.lsp file (if there)
;;;   reads the reference/int/algebra code.lsp file
;;;   resets the hash table and fn variables
;;;   compares the two code.lsp files
;;; 
(defun check ()
 (let (local flocal reference freference)
 (declare (special cycle fn))
 (dolist (pn (directory (truename "/research/test/int/algebra/*.nrlib")))
  (setq reference
   (concatenate 'string "/research/reference/int/algebra/"
     (pathname-name pn) ".nrlib/code.lsp"))
  (if (probe-file reference)
     (setq freference (init reference))
     (progn
      (format t "~%WARNING: ~a does not exist~%" reference)
      (setq freference nil)))
  (setq local
   (concatenate 'string "/research/test/int/algebra/"
     (pathname-name pn) ".nrlib/code.lsp"))
  (if (probe-file local)
     (setq flocal (init local))
     (format t "WARNING: ~a does not exist~%" local))
  (setq cycle (make-hash-table :test #'equal))
  (setq fn 'unknown)
  (catch 'different
   (if (same? freference flocal t pn)
    (format nil "same ~a~%" (pathname-name pn))
    (format t "FAILED ~a~%" (pathname-name pn)))))))