;;; -*- Mode:LISP; Package:USER; Base:10; Readtable:CL; Fonts:(CPTFONT CPTFONTB) -*-

1;;; APROPOS2FILE -- use APROPOS listings to compare LISP worlds or
;;; environments.  Saves info on each variable in all or selected
;;; package(s) that has a value or function binding. Use two such
;;; listings (e.g., from different revs of systems) to compare the
;;; symbol usages.  Detects variables and functions that are missing
;;; from the first or added with the second version.*

(defvar *apropos2list* nil "Apropos symbol main stack")
(defvar *apropos2list1* nil "Apropos symbol comparison stack 1")
(defvar *apropos2list2* nil "Apropos symbol comparison stack 2")

(defun apropos2file(&optional default-pathname pkg 
		    &aux (filename (or (pathname-name default-pathname)
				       "APROPOS")))
  "Processes and saves output from (APROPOS \"\" PKG ...) for use in
comparing symbols in different world loads/environments.
  APROPOS output is saved in file indicated by DEFAULT-PATHNAME;
defaults to file APROPOS with current defaults.
  Output .TEXT file has APROPOS listing. Output .LIST file is
suitable for processing by APROPOS2FILE-COMPARE.  It contains
a sorted list containing an entry for each interesting symbol.
  PKG defaults to NIL, meaning all packages; a package or list of
packages may be specified.  If PKG is T, then APROPOS is not run;
rather, the previously saved .TEXT file indicated by DEFAULT-PATHNAME
is re-read and processed. (This is useful if things crap out.)"
  (declare(values listfile))
  (setq default-pathname
	(make-pathname :name filename :defaults default-pathname))
  (let((textfile (make-pathname :type :text :defaults default-pathname))
       (listfile (make-pathname :type "LIST" :defaults default-pathname))
       (reprocess-p (eq pkg t))
       (*print-pretty* nil)
       (*print-circle* nil)
       (*readtable* si:initial-common-lisp-readtable))
    (unless reprocess-p
      ;;Write out APROPOS output
      (format t "~%>>> Save APROPOS output in ~a" (namestring textfile))
      (with-open-file(standard-output textfile :direction :output)
	(apropos "" pkg :inherited nil :inheritors nil)))
    ;;Read back in, save interesting stuff on list (pkg, symbol, description)
    (format t "~%>>> ~:[P~;Rep~]rocess APROPOS output~:*~:[~; from ~a~]"
	    reprocess-p
	    (namestring textfile))
    (setq *apropos2list* nil)
    (with-open-file(in textfile)
      (do ((line (readline in :eof) (readline in :eof)))
	  ((eq line :eof))
	(when (and line (> (string-length line) 0))
	  ;;Read tokens, trapping erros
	  (multiple-value-bind (entry errorp)
	      (catch-error
		(multiple-value-bind(sym desc)
		    (with-input-from-string(ln line)
		      (values (read ln nil :eof)
			      (readline ln :eof)))
		  ;;Got OK tokens
		  (when (and sym (neq sym :eof)
			     (stringp desc)
			     (> (string-length desc) 0))
		    (push (list (package-name (symbol-package sym))
				(symbol-name sym)
				desc
				(fboundp sym)
				(boundp sym))
			  *apropos2list*))))
	    (and (null entry) errorp
		 (format t "%>>> Preceding error while processing ~a"
			 line)))
	  )))

    ;;Sort list of good stuff
    (format t "~%>>> Sort intermediate result")
    (setq *apropos2list*
	  (sort *apropos2list*
		#'(lambda (x y)
		    (cond
		      ((string-lessp (first x) (first y)) t)
		      ((string-equal (first x) (first y))
		       (string-lessp (second x) (second y)))
		      (t nil)))))
    ;;Write LISP list of good stuff
    (format t "~%>>> Save resulting list in ~a"
	    (namestring listfile))
    (with-open-file(out listfile :direction :output)
      (print *apropos2list* out))
    listfile))

;;; Use this if you want to sort an APROPOS .TEXT file by symbol

(defun apropos2sort(&optional default-pathname
		    &aux (filename (or (pathname-name default-pathname)
				       "APROPOS")))
  (setq default-pathname
	(make-pathname :name filename :defaults default-pathname))
  (let((textfile (make-pathname :type :text :defaults default-pathname))
       (listfile (make-pathname :type "LIST" :defaults default-pathname))
       (*readtable* si:initial-common-lisp-readtable))
       ;;Rewrite text dump
       (with-open-file(in listfile)
	 (setq *apropos2list* (read in)))
       (with-open-file(out textfile :direction :output)
	 (dolist (elt *apropos2list*)
	   (format out "~&~{~a:~a ~a~2*~}" elt)))))

;;; Use this to read/load back in an APROPOS .LIST file

(defun apropos2load(pathname)
  (let((*readtable* si:initial-common-lisp-readtable))
    (with-open-file(in pathname)
      (read in))))

;;; Define states (used to save comparison information)

(defstruct (state (:type list))
  pkg missing-pkg added-pkg
  missing-vars added-vars
  missing-funs added-funs)

(defun apropos2print-state(state &optional (old 'old) (new 'new))
  (declare(ignore old))
  (let*((pkg (car state))
       (missing-pkg (state-missing-pkg state))
       (added-pkg (state-added-pkg state))
       (missing-vars (state-missing-vars state))
       (missing-funs (state-missing-funs state))
       (added-vars (state-added-vars state))
       (added-funs (state-added-funs state))
       (changed-pkg (or missing-vars missing-funs
			added-vars added-funs)))
    (format t "~2&*** ~a package " pkg)
    (cond
      (missing-pkg (format t "missing from ~a" new))
      (added-pkg (format t "added to ~a" new))
      (changed-pkg
       (format t "some changes:~%")
       (format t "~@[~%--Missing vars: ~~{~45a ?~&~}~~]" missing-vars)
       (format t "~@[~%--Missing funs: ~~{~45a ?~&~}~~]" missing-funs)
       (format t "~@[~%--Added vars: ~~{~45a ?~&~}~~]" added-vars)
       (format t "~@[~%--Added funs: ~~{~45a ?~&~}~~]" added-funs))
      (t (format t "no changes")))))

;;; Define entries (input line entries from .LIST file)

(defstruct (entry (:type list))
  pkg name desc fboundp boundp)

;;; Utility routines for processing states from entries

(defmacro exhaust-missing(entries state)
  `(let((state ,state))
     (do*((rest ,entries (cdr rest))
	  (entry (first rest) (first rest))
	  (name (entry-name entry) (entry-name entry)))
	 ((string-not-equal (state-pkg state) (entry-pkg entry))
	  (setq ,entries rest))
       (when (entry-boundp entry)
	 (push name (state-missing-vars state)))
       (when (entry-fboundp entry)
	 (push name (state-missing-funs state))))))

(defmacro exhaust-added(entries state)
  `(let((state ,state))
     (do*((rest ,entries (cdr rest))
	  (entry (first rest) (first rest))
	  (name (entry-name entry) (entry-name entry)))
	 ((string-not-equal (state-pkg state) (entry-pkg entry))
	  (setq ,entries rest))
       (when (entry-boundp entry)
	 (push name (state-added-vars state)))
       (when (entry-fboundp entry)
	 (push name (state-added-funs state))))))

(defun apropos2state(oldname old newname new
		     &optional debug
		     &aux state)
  (format t "~%+++Compare ~s to ~s~%" oldname newname)
  (macrolet((dump(state)
		 `(let((oldstate ,state))
		    (when oldstate
		      (apropos2print-state
			oldstate oldname newname))
		    (setq ,state (make-state)))))
    ;;Loop on pairs of packages
    (do*((oldstuff (car old) (car old))
	 (newstuff (car new) (car new))
	 (oldpkg (entry-pkg oldstuff) (entry-pkg oldstuff))
	 (newpkg (entry-pkg newstuff) (entry-pkg newstuff)))
	(nil)
      ;;Dump pending state, if any
      (dump state)
      (cond
	((null (and old new))
	 ;;One or both exhausted
	 (when debug (format t "~%Premature end of list"))
	 (let((entries
		(remove-duplicates
		  (or old new)
		  :key #'entry-pkg
		  :test #'string-equal)))
	   (when debug (format t "~%???pkgs left are ~s" entries))
	   (dolist(entry entries)
	     (setf (state-pkg state) (entry-pkg entry))
	     (if old
		 (setf (state-missing-pkg state) t)
	       (setf (state-added-pkg state) t))
	     (dump state)))
	 ;;All done
	 (return))
	;;At beginning of package(s)
	((string-lessp oldpkg newpkg)
	 ;;Current pkg is missing!
	 (when debug (format t "~&Package ~s is missing" oldpkg))
	 (setf (state-pkg state) oldpkg)
	 (setf (state-missing-pkg state) t)
	 (exhaust-missing old (make-state :pkg oldpkg)))
	((string-greaterp oldpkg newpkg)
	 ;;New pkg is added!
	 (when debug (format t "~&Package ~s is added" oldpkg))
	 (setf (state-pkg state) newpkg)
	 (setf (state-added-pkg state) newpkg)
	 (exhaust-added new (make-state :pkg newpkg)))
	(t
	 ;;We have the same package!
	 (setf (state-pkg state) oldpkg)
	 (do*((olds old (cdr olds))
	      (news new (cdr news))
	      (oldstuff (car olds) (car olds))
	      (newstuff (car news) (car news))
	      (oldname (entry-name oldstuff) (entry-name oldstuff))
	      (newname (entry-name newstuff) (entry-name newstuff)))
	     (nil)
	   (setq old olds)
	   (setq new news)
	   (when debug (format t "~%---Compare entry ~~s to~&~~s"
		 oldstuff newstuff))
	   (cond
	     ((string-not-equal oldpkg (entry-pkg oldstuff))
	      ;;End of old package
	      (when debug(format t "~%Done with old ~a" oldpkg))
	      (exhaust-added new state)
	      (return))
	     ((string-not-equal newpkg (entry-pkg newstuff))
	      ;;End of new package
	      (when debug (format t "~%Done with new ~a" newpkg))
	      (setq new news)
	      (exhaust-missing old state)
	      (return))
	     ;;Same package -- same symbol?
	     ((string-lessp oldname newname)
	      (when (entry-fboundp oldstuff)
		(push oldname (state-missing-funs state)))
	      (when (entry-boundp  oldstuff)
		(push oldname (state-missing-vars state)))
	      (push newstuff news))
	     ((string-greaterp oldname newname)
	      (when (entry-fboundp newstuff)
		(push newname (state-added-funs state)))
	      (when (entry-boundp newstuff)
		(push newname (state-added-vars state)))
	      (push oldstuff olds))
	     (t
	      ;;Same symbol...any diff?
	      (when debug (format t "~&---Same symbol ~s!" oldname))
	      (when (entry-fboundp oldstuff)
		(unless (entry-fboundp newstuff)
		  (push oldname (state-missing-funs state))))
	      (when (entry-boundp oldstuff)
		(unless (entry-boundp newstuff)
		  (push oldname (state-missing-vars state))))
	      (when (entry-fboundp newstuff)
		(unless (entry-fboundp oldstuff)
		  (push newname (state-added-funs state))))
	      (when (entry-boundp newstuff)
		(unless (entry-boundp oldstuff)
		  (push newname (state-added-vars state))))))))))))

;;; Compare two saved listings

(defun apropos2file-compare(name1 name2 &optional filename just-print)
  (declare(values complist))
  (setq name1 (make-pathname :type "LIST" :defaults (merge-pathnames name1 name2)))
  (setq name2 (make-pathname :type "LIST" :defaults (merge-pathnames name2 name1)))
  (unless just-print
    (format t "~%>>> Loading ~a" (namestring name1))
    (setq *apropos2list1* (apropos2load name1))
    (format t "~%>>> Loading ~a" (namestring name2))
    (setq *apropos2list2* (apropos2load name2)))
  (let((tag1 (pathname-name name1))
       (tag2 (pathname-name name2))
       (stream (if filename
		   (open (setq filename
			       (make-pathname
				 :defaults (merge-pathnames filename name1)
				 :type "TEXT"))
			 :direction :output)
		 standard-output)))
    (with-open-stream(standard-output stream)
      (apropos2state tag1 *apropos2list1*
		     tag2 *apropos2list2*))
    filename))

;;; Testing code

(defvar able)
(defvar able1)
(defvar able2)
(defvar baker)
(defvar charlie)
(defvar delta)

(defun init()
  (setq able1
	(list
	  (make-entry :pkg "ABLE" :name "DO-SOMETHING"
		      :fboundp t)
	  (make-entry :pkg "ABLE" :name "DO-SOMETHING-ELSE"
		      :fboundp t)))
  (setq able2
	(list
	  (make-entry :pkg "ABLE" :name "SOMETHING"
		      :boundp t)
	  (make-entry :pkg "ABLE" :name "SOMETHING-DONE"
		      :fboundp t)
	  (make-entry :pkg "ABLE" :name "SOMETHING-ELSE"
		      :boundp t)))
  (setq able (append able1 able2))
  (setq baker
	(loop for orig in able
	      as entry = (copy-list orig)
	      do (setf (entry-pkg entry) "BAKER")
	      collect entry))
  (setq charlie
	(list
	  (make-entry :pkg "CHARLIE" :name "JUNK"
		      :boundp t)
	  (make-entry :pkg "CHARLIE" :name "JUNK2"
		      :boundp t)))
  (setq delta
	(list
	  (make-entry :pkg "DELTA" :NAME "DOIT"
		      :fboundp t)
	  (make-entry :pkg "DELTA" :name "DOIT2"
		      :fboundp t))))
  

(defun test1()
  (init)
  (let((testold (copy-tree
		  (append able baker charlie)))
       (testnew (copy-tree
		  (append able charlie delta))))
    (apropos2state 'old testold 'new testnew)))

(defun test2()
  (init)
  (let((testold
	 (copy-tree
	   (append able1
		   ;;SOMETHING added
		   (cdr able2)
		   ;;ZEALOUSLY-LEFT-OUT missing
		   (ncons
		     (make-entry :pkg "ABLE"
				 :name "ZEALOUSLY-LEFT-OUT"
				 :fboundp t))
		   baker
		   (ncons
		     (make-entry :pkg "BAKER"
				 :name "ZEALOUSLY-LEFT-OUT"
				 :boundp t))
		   ;;packages BOOBLE, BOOBLE2 missing
		   (list
		     (make-entry :pkg "BOOBLE"
				 :name "SOME-STUFF"
				 :FBOUNDP T)
		     (make-entry :pkg "BOOBLE"
				 :name "SOME-STUFF2"
				 :FBOUNDP T)
		     (make-entry :pkg "BOOBLE2"
				 :name "SOME-STUFF"
				 :FBOUNDP T))
		   charlie)))
       (testnew
	 (copy-tree
	   (append able
		   baker
		   charlie
		   ;;ZOO-CHARLIE missing
		   (list
		     (make-entry :pkg "CHARLIE"
				 :name "ZOO-CHARLIE-AND THE-HORSE-HE-RODE-IN-ON,WHEN I WAS JUST A BOY"
				 :fboundp t)
		     (make-entry :pkg "CHARLIE"
				 :name "ZOO-CHARLIE2-AND THE-HORSE-HE-RODE-IN-ON,WHEN I WAS JUST A BOY"
				 :fboundp t))
		   delta))))
    (apropos2state 'old testold 'new testnew)))