;;; -*-LISP-*-
;;; Program to detect reapable LISP's.

(declare (special reapable-stuff))


(defun FIND-REAPABLE-LISPS ()
   (setq reapable-stuff nil)
   (let ((lock-file (open '|DSK:LISP;LOCK >|))
	 (state 'SKIPPING-TO-NEXT-LISP-BLOCK)
	 lisp-file input-line line )
	(eoffn lock-file 'DISPLAY-RESULTS)
	(*catch						;CATCH end-of-file
	  'FIND-REAPABLE-LISPS
	  (do ()					;DO forever, or until
	      (())					; E-O-F throws out
	    (setq input-line (readline lock-file))
	    (cond 
	     ((or (null input-line)
		  (= (flatc input-line) 0)
		  (= (getcharn input-line 1) #/;) 
		  (only-white-spaces? (setq line (exploden input-line))))
	      () )
	     ((cond ((sublist-match line '(L I S P / ))
		     (setq lisp-file (lread-version 5 line)
			   lisp-file `((DSK SYS) PURQIO ,lisp-file))
		     'T)
		    ((sublist-match line '(X L I S P / ))
		     (setq lisp-file (lread-version 6 line)
			   lisp-file `((DSK LISP) PURQIX ,lisp-file))
		     'T))
	      (cond ((not (probef (setq lisp-file (namestring lisp-file))))
		     (terpri)
		     (prin1 lisp-file)
		     (princ '| -- System LISP file is missing|)))
	      (push lisp-file reapable-stuff)
	      (setq state 'LOOKING-FOR-FILES-USING-THIS-LISP))
	     ((eq state 'SKIPPING-TO-NEXT-LISP-BLOCK) () )
	     ((eq state 'LOOKING-FOR-FILES-USING-THIS-LISP)
	      (cond ((not (eq (car reapable-stuff) lisp-file)) () )
		    ((probef input-line)
		      ;; If listed file is not in file sysetm, then . ..
		     (rplaca reapable-stuff () )
		     (setq state 'SKIPPING-TO-NEXT-LISP-BLOCK))))
	     ('T (error '|Bad /"state/" - FIND-REAPABLE-LISPS|)))))
	() ))


(defun ONLY-WHITE-SPACES? (line)
   (do ((c 0))
       ((null line) 'T)
     (setq c (car line))
     (cond ((or (= c #\SPACE)		;Ignore a bunch of chars
		(= c #\TAB) 
		(= c #\FORMFEED) 
		(= c #\LINEFEED)))
	   ((= c #/;) (return 'T))	;Initial ";" means worthless line
	   ('T (return () )))		;Ahh, something worthy found
     (pop line)))

(defun SUBLIST-MATCH (line pat)
   (do ((s1 line (cdr s1))
	(s2 pat (cdr s2))
	(a 0 ) (b 0))
       ((or (null s1) (null s2))
	'T)
     (setq a (car s1) b (car s2))
     (or (eq (typep a) 'FIXNUM) (setq a (getcharn a 1)))
     (or (eq (typep b) 'FIXNUM) (setq b (getcharn b 1)))
     (or (= a b) (return () ))))

(defun LREAD-VERSION (n line)
   (do ((l (nthcdr n line) (cdr l))
	(z () (cons (car l) z)))
       ((or (null l) (not (> (car l) #\SPACE)))
	(implode (nreverse z)))))

(defun DISPLAY-RESULTS (file flag)
   (terpri)
   (cond ((setq reapable-stuff (delq () reapable-stuff))
	  (princ '|These LISP's have been found to be reapable:|)
	  (mapc '(lambda (f) (princ f) (terpri)) reapable-stuff))
	 ('T (princ '|<none>|)))
   (terpri)
   (*throw 'FIND-REAPABLE-LISPS () ))