;;; -*- Mode: Lisp; Package: System-Internals; Base: 8 -*-

;;; This file contains random hacks to help recompile and build new lispm
;;; worlds.  Feel free to add to it.

;;; DLA's hack to find the creation dates of all installed QFASL files.

(DEFVAR QFASL-SOURCE-FILE-PLISTS-ALIST NIL)
(DEFUN QFASL-SOURCE-FILE-PLISTS (&OPTIONAL (SYSTEM "System"))
  (AND (OR (NOT (ASSOC SYSTEM QFASL-SOURCE-FILE-PLISTS-ALIST))
	   (Y-OR-N-P "Recompute QFASL source files? "))
       (LET ((FILES (MAPCAR #'(LAMBDA (X)
				(FUNCALL X ':NEW-PATHNAME ':TYPE "QFASL" ':VERSION ':NEWEST))
			    (SYSTEM-SOURCE-FILES SYSTEM ':ALL))))
	 (PUSH (CONS SYSTEM
		     (SORT (DEL #'(LAMBDA (IGNORE X) (NULL (GET X ':CREATION-DATE-AND-TIME)))
				NIL
				(FS:MULTIPLE-FILE-PROPERTY-LISTS T FILES))
			   #'(LAMBDA (X Y)
			       (< (GET X ':CREATION-DATE-AND-TIME)
				  (GET Y ':CREATION-DATE-AND-TIME)))))
	       QFASL-SOURCE-FILE-PLISTS-ALIST)))
  (CDR (ASSOC SYSTEM QFASL-SOURCE-FILE-PLISTS-ALIST)))

(DEFUN LIST-QFASL-SOURCE-FILES (FILENAME &OPTIONAL (SYSTEM "System"))
  (LET ((FILES (QFASL-SOURCE-FILE-PLISTS SYSTEM)))
    (WITH-OPEN-FILE (STREAM FILENAME '(OUT))
      (DOLIST (P FILES)
	(FORMAT STREAM "~30A" (CAR P))
	(TIME:PRINT-UNIVERSAL-TIME (GET P ':CREATION-DATE-AND-TIME) STREAM)
	(FUNCALL STREAM ':TYO #\CR)))))

(DEFUN RECOMPILE-FILES-AFTER-DATE (AFTER-DATE &OPTIONAL (SYSTEM "System")
				   &AUX RECOM-FILES TEM)
  (AND (STRINGP (SETQ AFTER-DATE (TIME:PARSE-UNIVERSAL-TIME AFTER-DATE 0 NIL NIL)))
       (FERROR NIL AFTER-DATE))
  (DOLIST (P (QFASL-SOURCE-FILE-PLISTS SYSTEM))
    (COND ((AND (> (GET P ':CREATION-DATE-AND-TIME) AFTER-DATE)
		(SETQ TEM (FUNCALL (FUNCALL (CAR P) ':GENERIC-PATHNAME)
				   ':GET ':QFASL-SOURCE-FILE-UNIQUE-ID)))
	   (PUSH (FUNCALL (FS:MERGE-PATHNAME-DEFAULTS TEM) ':NEW-VERSION ':NEWEST)
		 RECOM-FILES))))
  (DOLIST (F (NREVERSE RECOM-FILES))
    (COND ((PROBEF F)
	   (FORMAT T "~%Recompiling ~A ..." F)
	   (QC-FILE F))
	  (T (FORMAT T "~%~A does not exist.")))))

(DEFUN RECOMPILE-FILES-BEFORE-DATE (BEFORE-DATE &OPTIONAL (SYSTEM "System")
				    &AUX RECOM-FILES TEM)
  (AND (STRINGP (SETQ BEFORE-DATE (TIME:PARSE-UNIVERSAL-TIME BEFORE-DATE 0 NIL NIL)))
       (FERROR NIL BEFORE-DATE))
  (DOLIST (P (QFASL-SOURCE-FILE-PLISTS SYSTEM))
    (COND ((AND (> BEFORE-DATE (GET P ':CREATION-DATE-AND-TIME))
		(SETQ TEM (FUNCALL (FUNCALL (CAR P) ':GENERIC-PATHNAME)
				   ':GET ':QFASL-SOURCE-FILE-UNIQUE-ID)))
	   (PUSH (FUNCALL (FS:MERGE-PATHNAME-DEFAULTS TEM) ':NEW-VERSION ':NEWEST)
		 RECOM-FILES))))
  (DOLIST (F (NREVERSE RECOM-FILES))
    (COND ((PROBEF F)
	   (FORMAT T "~%Recompiling ~A ..." F)
	   (QC-FILE F))
	  (T (FORMAT T "~%~A does not exist.")))))


;;; DLA's hack to search through the sources of QFASL files compiled after a certain
;;; date for bad strings.  Useful when a macro has expanded wrong, or the compiler
;;; broke in certain cases.

(DEFUN SOURCE-SCAN-AFTER-DATE (SUBSTRING AFTER-DATE &OPTIONAL (SYSTEM "System")
							      (FUNCTION 'STRING-SEARCH)
						    &AUX BAD-FILES FILE)
  (SETQ AFTER-DATE (TIME:PARSE-UNIVERSAL-TIME AFTER-DATE))
  (DOLIST (F (QFASL-SOURCE-FILE-PLISTS SYSTEM))
    (COND ((> (GET F ':CREATION-DATE-AND-TIME) AFTER-DATE)
	   (SETQ FILE (FUNCALL (CAR F) ':NEW-PATHNAME ':TYPE "LISP" ':VERSION ':NEWEST))
	   (FUNCALL STANDARD-OUTPUT ':CLEAR-SCREEN)
	   (FORMAT T "File ~A ..." FILE)
	   (AND (SCAN-SOURCE-FILE FILE SUBSTRING FUNCTION)
		(PUSH FILE BAD-FILES)))))
  BAD-FILES)

(DEFUN SOURCE-SCAN-MULTIPLE (STRINGS &OPTIONAL (SYSTEM "System"))
  (SOURCE-SCAN (LIST STRINGS NIL) SYSTEM 'ZWEI:FSM-STRING-SEARCH))

(DEFUN SOURCE-SCAN (SUBSTRING &OPTIONAL (SYSTEM "System") (FUNCTION 'STRING-SEARCH))
  (LOOP FOR FILE IN (SYSTEM-SOURCE-FILES SYSTEM)
	DO (FORMAT T "~:|File ~A ..." FILE)
	WHEN (SCAN-SOURCE-FILE FILE SUBSTRING FUNCTION)
	COLLECT FILE))

(DEFUN SCAN-SOURCE-FILE (FILE SUBSTRING FUNCTION &AUX LINE EOF)
  (LET* ((BUFFER (CIRCULAR-LIST NIL NIL NIL NIL NIL NIL NIL))
	 (LINE-IN-POINT (CDDDDR BUFFER)))
    (WITH-OPEN-FILE (STREAM FILE)
      (DO () (NIL)
	(MULTIPLE-VALUE (LINE EOF)
	  (FUNCALL STREAM ':LINE-IN T))
	(AND EOF (OR (NULL LINE)
		     (EQUAL LINE ""))
	     (SETQ LINE ':EOF))
	(SETF (CAR LINE-IN-POINT) LINE)
	(SETQ BUFFER (CDR BUFFER)
	      LINE-IN-POINT (CDR LINE-IN-POINT))
	(COND ((NULL (CAR BUFFER)))		;Beginning of file
	      ((EQ (CAR BUFFER) ':EOF)
	       (RETURN NIL))
	      ((FUNCALL FUNCTION SUBSTRING (CAR BUFFER))
	       (FUNCALL STANDARD-OUTPUT ':SET-CURSORPOS 0 3 ':CHARACTER)
	       (FUNCALL STANDARD-OUTPUT ':CLEAR-EOF)
	       (DO ((L (CDR LINE-IN-POINT) (CDR L)))
		   ((EQ L LINE-IN-POINT))
		 (FUNCALL STANDARD-OUTPUT ':LINE-OUT
			  (COND ((NULL (CAR L)) "[Beginning of file]")
				((SYMBOLP (CAR L)) "[End of file]")
				(T (CAR L)))))
	       (FORMAT T "~% Is this OK? ")
	       (OR (Y-OR-N-P)
		   (RETURN T))))))))

;;; RG's Source compare hack.

;start dribble file if you want to save results.
(DEFUN SOURCE-COMPARE-SYSTEM-UPDATES (&OPTIONAL SYSTEMS)
  (COND ((NULL SYSTEMS) (SETQ SYSTEMS *SYSTEMS-LIST*))
	((NLISTP SYSTEMS) (SETQ SYSTEMS (LIST SYSTEMS))))
  (LET (FILES)
    (DOLIST (SYSTEM SYSTEMS)
      (SETQ FILES (APPEND FILES (SYSTEM-SOURCE-FILES SYSTEM))))
    (SETQ FILES (ELIMINATE-DUPLICATES FILES))
    (DOLIST (FILE FILES)
      (SOURCE-COMPARE-FILE-UPDATES FILE))))

(DEFUN SOURCE-COMPARE-FILE-UPDATES (FILE &AUX CURRENT-PROBE INSTALLED-PROBE)
  (UNWIND-PROTECT
    (PROG (CURRENT-VERSION INSTALLED-VERSION FILE-TO-COMPARE)
	(SETQ CURRENT-PROBE (OPEN FILE ':PROBE))
	(COND ((ERRORP CURRENT-PROBE)
	       (FORMAT T "~% No source for ~A  (~A)" FILE CURRENT-PROBE)
	       (RETURN NIL))
	      (T (SETQ CURRENT-VERSION (FUNCALL CURRENT-PROBE ':TRUENAME))))
	(SETQ INSTALLED-VERSION (FUNCALL (FUNCALL FILE ':GENERIC-PATHNAME)
					 ':GET
					 ':QFASL-SOURCE-FILE-UNIQUE-ID))
	(COND ((NULL INSTALLED-VERSION)
	       (FORMAT T "~%Installed version of ~A unrecorded, trying oldest" FILE)
	       (GO OLD))
	      ((STRINGP INSTALLED-VERSION)
	       (SETQ INSTALLED-VERSION (FS:PARSE-PATHNAME INSTALLED-VERSION))))
	;Get installed version from current sys host, not the one it was compiled on
	(SETQ INSTALLED-VERSION (FUNCALL CURRENT-VERSION ':NEW-VERSION
					 (FUNCALL INSTALLED-VERSION ':VERSION)))
	(SETQ INSTALLED-PROBE (OPEN INSTALLED-VERSION ':PROBE))
	(COND ((ERRORP INSTALLED-PROBE)
	       (FORMAT T "~%Installed version ~A not available (~A), trying oldest" 
		         INSTALLED-VERSION INSTALLED-PROBE)
	       (GO OLD))
	      (T
	       (SETQ FILE-TO-COMPARE INSTALLED-VERSION)
	       (GO COMP)))
  OLD	(SETQ FILE-TO-COMPARE (FUNCALL CURRENT-VERSION ':NEW-VERSION ':OLDEST))
	(SETQ INSTALLED-PROBE (OPEN FILE-TO-COMPARE ':PROBE))
	(COND ((ERRORP INSTALLED-PROBE)
	       (FORMAT T "~% Can't get oldest version (~A), giving up." INSTALLED-PROBE)
	       (RETURN NIL)))
	(SETQ FILE-TO-COMPARE (FUNCALL INSTALLED-PROBE ':TRUENAME))
  COMP  (COND ((SAME-FILE-P FILE-TO-COMPARE CURRENT-VERSION)
	       (COND ((AND INSTALLED-VERSION
			   (SAME-FILE-P INSTALLED-VERSION CURRENT-VERSION))
		      (FORMAT T "~%No change to file ~A" FILE))
		     (T (FORMAT T "~%Only one version to compare ~A" FILE))))
	      (T (FORMAT T "~%Comparing ~A~% and ~A~%"
			   (ZWEI:DESCRIBE-FILE-ID (FUNCALL INSTALLED-PROBE ':INFO))
			   (ZWEI:DESCRIBE-FILE-ID (FUNCALL CURRENT-PROBE ':INFO)))
		 (*CATCH 'SYS:COMMAND-LEVEL
		   (SRCCOM:SOURCE-COMPARE FILE-TO-COMPARE CURRENT-VERSION)))))
    (AND INSTALLED-PROBE (NOT (ERRORP INSTALLED-PROBE)) (CLOSE INSTALLED-PROBE))
    (AND CURRENT-PROBE (NOT (ERRORP CURRENT-PROBE)) (CLOSE CURRENT-PROBE))))

(DEFUN SAME-FILE-P (F1 F2)
  (OR (EQ F1 F2)
      (AND (EQUAL (FUNCALL F1 ':DIRECTORY) (FUNCALL F2 ':DIRECTORY))
	   (EQUAL (FUNCALL F1 ':NAME) (FUNCALL F2 ':NAME))
	   (EQUAL (FUNCALL F1 ':VERSION) (FUNCALL F2 ':VERSION))
	   (OR (EQUAL (FUNCALL F1 ':TYPE) (FUNCALL F2 ':TYPE))
	       (AND (MEMQ (FUNCALL F1 ':TYPE) '(:UNSPECIFIC NIL))
		    (MEMQ (FUNCALL F2 ':TYPE) '(:UNSPECIFIC NIL)))))))

;;; DLA's hack to purge source files of a system.

(DEFUN UNIQUE-IDS-OF-SYSTEM (&OPTIONAL (SYSTEM "System"))
  (LET ((FILES (SYSTEM-SOURCE-FILES SYSTEM)))
    (DO ((F FILES (CDR F)))
	((NULL F))
      (SETF (CAR F)
	    (FUNCALL (FUNCALL (CAR F) ':GENERIC-PATHNAME)
		     ':GET ':QFASL-SOURCE-FILE-UNIQUE-ID))
      (AND (STRINGP (CAR F))
	   (SETF (CAR F) (FS:MERGE-PATHNAME-DEFAULTS (CAR F)))))
    (DELQ NIL FILES)))

;; This function maps through the source files of a system, and deletes all files
;; which are not either installed or newest.
(DEFUN SYSTEM-SOURCE-FILE-PURGE (&OPTIONAL (SYSTEM "System") (QUERY-P T) (KEEP 1)
				 (IGNORE-DONT-REAP T) &AUX DIR DIR-LIST)
  (LET ((FILES (UNIQUE-IDS-OF-SYSTEM SYSTEM)))
    (DO ((DIR-DELETE-P NIL NIL)) ((NULL FILES))
      (SETQ DIR (FS:PATHNAME-DIRECTORY (CAR FILES))
	    DIR-LIST (FS:DIRECTORY-LIST (FUNCALL (CAR FILES) ':NEW-PATHNAME
					  ':NAME ':WILD ':TYPE ':WILD ':VERSION ':WILD)))
      ;; This puts the directory in descending order.
      (SETQ DIR-LIST (SORT (CDR DIR-LIST)
			   #'(LAMBDA (X Y) (NOT (< (GET X ':CREATION-DATE)
						   (GET Y ':CREATION-DATE))))))
      (DOLIST (FILE FILES)
	(COND ((EQUAL (FS:PATHNAME-DIRECTORY FILE) DIR)
	       (DO ((D DIR-LIST (CDR D))
		    (NEWEST KEEP)
		    (NAME (FS:PATHNAME-NAME FILE))
		    (TYPE (FS:PATHNAME-TYPE FILE))
		    (VERSION (FS:PATHNAME-VERSION FILE))
		    (RELEVANT-FILES NIL)
		    (DELETE-P NIL))
		   ((NULL D)
		    (COND (DELETE-P
			   (FORMAT T "~%~%")
			   (COND ((NOT DIR-DELETE-P)
				  (FORMAT T "~A:~%" DIR)
				  (SETQ DIR-DELETE-P T)))
			   (MAPC 'ZWEI:DEFAULT-LIST-ONE-FILE RELEVANT-FILES)
			   (COND ((OR (NOT QUERY-P)
				      (Y-OR-N-P "Delete them? "))
				  (DOLIST (F RELEVANT-FILES)
				    (AND (GET F ':DELETED)
					 (DELETEF (CAR F)))))))))
		 (AND (EQUAL NAME (FS:PATHNAME-NAME (CAAR D)))
		      (EQUAL TYPE (FS:PATHNAME-TYPE (CAAR D)))
		      (COND ((OR ;Don't delete if you still have to keep some files
				 (PLUSP NEWEST)
				 ;Or if this is an installed version
				 (EQUAL VERSION (FS:PATHNAME-VERSION (CAAR D)))
				 ;Or if this has a dont-reap bit, and we're checking
				 (NOT (OR IGNORE-DONT-REAP (NOT (GET (CAR D) ':DONT-REAP)))))
			     (PUSH (CAR D) RELEVANT-FILES)
			     (SETQ NEWEST (1- NEWEST)))
			    (T (PUTPROP (CAR D) T ':DELETED)
			       (SETQ DELETE-P T)
			       (PUSH (CAR D) RELEVANT-FILES))))))))
      (SETQ FILES (DEL #'(LAMBDA (DIR FILE) (EQUAL DIR (FS:PATHNAME-DIRECTORY FILE)))
		       DIR FILES)))))

(DEFUN SET-SYSTEM-SOURCE-FILE-REAP (&OPTIONAL (SYSTEM "System") (DONT-REAP-P T))
  (LOOP FOR FILE IN (UNIQUE-IDS-OF-SYSTEM SYSTEM)
	AS RESPONSE = (FS:CHANGE-FILE-PROPERTIES FILE NIL ':DONT-REAP DONT-REAP-P)
	WHEN (STRINGP RESPONSE)
	DO (FORMAT T "~%~A -- ~A" FILE RESPONSE)))


(DEFUN LIST-MISSING-INSTALLED-VERSIONS (&OPTIONAL (SYSTEMS *SYSTEMS-LIST*))
  (OR (LISTP SYSTEMS) (SETQ SYSTEMS (LIST SYSTEMS)))
  (FUNCALL STANDARD-OUTPUT ':FRESH-LINE)
  (LOOP FOR (FILE . PLIST)
	 IN (FS:MULTIPLE-FILE-PROPERTY-LISTS NIL
	      (LOOP FOR FILE IN (ELIMINATE-DUPLICATES
				  (LOOP FOR SYSTEM IN SYSTEMS
					APPEND (SYSTEM-SOURCE-FILES SYSTEM)))
		    AS SOURCE = (FUNCALL (FUNCALL FILE ':GENERIC-PATHNAME)
					 ':GET ':QFASL-SOURCE-FILE-UNIQUE-ID)
		    AS VERSION = (AND SOURCE (FUNCALL (FS:PARSE-PATHNAME SOURCE) ':VERSION))
		    UNLESS (NULL VERSION)
		      COLLECT (FUNCALL (FUNCALL FILE ':NEW-VERSION VERSION)
				       ':TRANSLATED-PATHNAME)))
       WHEN (NULL PLIST)
         DO (PRINC FILE) (TERPRI)))

(DEFUN LIST-COMPILATION-INFO (&OPTIONAL (S STANDARD-OUTPUT) &AUX *LIST* TEM)
  (DECLARE (SPECIAL *LIST*))
  (MAPHASH-EQUAL #'(LAMBDA (IGNORE PATH)
		     (AND (FUNCALL PATH ':GET ':QFASL-SOURCE-FILE-UNIQUE-ID)
			  (PUSH PATH *LIST*)))
		 FS:*PATHNAME-HASH-TABLE*)
  (SETQ *LIST* (SORT (COPYLIST *LIST*)
		     #'(LAMBDA (X Y)
			 (STRING-LESSP
			   (FUNCALL X ':STRING-FOR-PRINTING)
			   (FUNCALL Y ':STRING-FOR-PRINTING)))))
  (DOLIST (PATHNAME *LIST*)
    (FORMAT S "~%~A" (FUNCALL PATHNAME ':GET ':QFASL-SOURCE-FILE-UNIQUE-ID))
    (COND ((SETQ TEM (FUNCALL PATHNAME ':GET ':COMPILE-DATA))
	   (FORMAT S "~30T~D.~D~38T~A~46T~A~69T"
			(FOURTH TEM) (FIFTH TEM)
			(FIRST TEM) (SECOND TEM))
		(TIME:PRINT-UNIVERSAL-TIME (THIRD TEM))))))

(DEFUN RECOMPILE-SOURCE-FILES (SOURCE-FILE-LIST)
  (DOLIST (FILE SOURCE-FILE-LIST)
    (SETQ FILE (FUNCALL FILE ':NEW-PATHNAME ':TYPE "LISP" ':VERSION ':NEWEST))
    (FORMAT T "~&Compiling ~A" FILE)
    (QC-FILE FILE)))

(DEFUN RECOMPILE-INCORRECT-COMPILE-FLAVOR-METHODS ()
  (RECOMPILE-SOURCE-FILES
    (ELIMINATE-DUPLICATES
      (LOOP FOR METH IN *FLAVOR-COMPILATIONS*
	    AS SF = (GET-SOURCE-FILE-NAME METH)
	    WHEN SF COLLECT SF))))

(DEFUN RECOMPILE-ALL-COMPILE-FLAVOR-METHODS ()
  (RECOMPILE-SOURCE-FILES
    (ELIMINATE-DUPLICATES
      (LOOP FOR FLAVOR IN *ALL-FLAVOR-NAMES*
	    AS SF = (GET (LOCF (FLAVOR-PLIST (GET FLAVOR 'FLAVOR))) ':COMPILE-FLAVOR-METHODS)
	    WHEN SF COLLECT SF))))

;; Hack for ITS files which have nulls tacked onto their tails due to
;; cretinous software.
(DEFUN FILE-REMOVE-NULLS (FILE &AUX BUF LOW HIGH FOUND (COUNT 0))
  (WITH-OPEN-FILE (IN FILE '(:IN :RAW))
    (WITH-OPEN-FILE (OUT (FUNCALL IN ':TRUENAME) '(:OUT :RAW))
      (FUNCALL OUT ':CHANGE-PROPERTIES T
	       ':CREATION-DATE (FUNCALL IN ':CREATION-DATE))
      (LOOP DOING
	(OR (MULTIPLE-VALUE (BUF LOW HIGH)
	      (FUNCALL IN ':READ-INPUT-BUFFER))
	    (RETURN NIL))
	WHEN FOUND DO (LOOP REPEAT COUNT DOING (FUNCALL OUT ':TYO 0))
	DO
	(SETQ FOUND NIL COUNT 0)
	(LOOP WHILE (AND (> HIGH LOW) (ZEROP (AREF BUF (1- HIGH))))
	      DO (SETQ FOUND T) (INCF COUNT) (DECF HIGH))
	(FUNCALL OUT ':STRING-OUT BUF LOW HIGH)
	(FUNCALL IN ':ADVANCE-INPUT-BUFFER))
      (FORMAT T "~%~:[No nulls found.~;~D. nulls removed from file.~]" FOUND COUNT))))