;;; -*- Mode: Lisp;  Package: User; Base: 10. -*-

;;; List of files & dependencies, in format:
;;; ((filesymbol depends-on1 depends-on2 . . .) . . .)
;;; file symbols are symbols with printnames like "INTERP;FOO"
(defvar *files* nil)

;;; List of file symbols representing files that have already been loaded.
(defvar *loaded* nil)

;;; List of files symbols representing files that are currently being
;;; compiled/loaded, to avoid infinite recursion.
(defvar *current* nil)

;;; If non-nil, don't really compile, just say what WOULD have been compiled.
(defvar *testing* nil)

;;; Host wherein live the sources.
(defvar *host* "DJ")

;;; Read in the two file-dependency files, created from the old Makefiles.
(defun read-files (&optional debugger-too?)
  (loop for file in (if debugger-too?
			(list (string-append *host* ": SOLEY;DEPS.LISP")
			      (string-append *host* ": SOLEY;DEBUG.LISP"))
		      (list (string-append *host* ": SOLEY;DEPS.LISP"))) do
	(with-open-file (stream file :direction :input)
	  (loop as file = (read stream) until (eq file 'end) do
		(setq *files* (cons (list file) *files*)))
	  (loop as dep = (read stream) until (eq dep 'end) do
		(let ((find (assq (car dep) *files*)))
		  (if (null find) (setq *files* (cons dep *files*))
		    (rplacd find (cdr dep)))))))
  (setq *files* (nreverse *files*)))

;;; Start a compilation.
(defun compile-files (&optional reset?)
  (if reset? (setq *loaded* nil))
  (loop for (file) in *files* do (compile-a-file file)))

(defun bin-file-exists-and-dont-recompile? (file)
  (let ((exists? (probef (string-append "CT: " file #+Symbolics ".BIN" #+LMI ".QFASL" #+TI ".XFASL"))))
    (cond ((null exists?) nil)
	  (t (y-or-n-p "~A has already been compiled.  Can I use it?" file)))))

;;; Compile and load a single file, insuring that depending files go first.
(defun compile-a-file (file)
  (if (or (memq file *current*) (memq file *loaded*)
	  (eval `(status feature ,(intern (substring (string file) (1+ (string-search-char #/; file))))))) nil
    (let ((deps (assq file *files*)) (*current* (cons file *current*)))
      (mapc #'compile-a-file (cdr deps))
      (cond (*testing* (format t "~&~V@T~A~%" (length *current*) file))
	    (t (unless (bin-file-exists-and-dont-recompile? file)
		 (compiler:compile-file (string-append "CT: " file ".LISP")))
	       (ct_load (intern (substring file (1+ (string-search-char #/; file)))))))
      (push file *loaded*))))

(defun whats-left ()
  (let ((*loaded* *loaded*) (*testing* 't)) (compile-files)))

;;;;;;;;
;;;;       Heave a great sigh, take one.
;;;;;;;;
;;;;
;;;; When we loaded the tapes, the plus/minus symbol (, ascii 12 = ^L) didn't
;;;; get translated to <Page>.  It of course is not treated as whitespace, but
;;;; instead as a one-character symbol appearing at toplevel in the file.

(defvar  nil)

;;;;;;;;
;;;;       Heave a great sigh, take two.
;;;;;;;;
;;;;
;;;; The FASLOADer fails loading INTERP;ADAS40.QFASL because of a bug in the
;;;; stack unwinder (!!!!) that fails to reset a list consing area.

(eval-when (eval compile load)
SYSTEM-INTERNALS:
(defun area-name-1 (x)
  (if (numberp x) (area-name x) x)) )

SYSTEM-INTERNALS:
(advise si:fasl-op-frame :after check3 nil
  (when (not (eq 'working-storage-area (area-name-1 (AREF FASL-TABLE FASL-LIST-AREA))))
    (format t "~&FASL-LIST-AREA bad, setting it back to working storage.~%")
    (setf (AREF FASL-TABLE FASL-LIST-AREA) 'working-storage-area)))


;;; How to compile the system:
;;;
;;; (load "LM: CTLISP.LATEST; CTLOAD")
;;; (read-files)
;;; (compile-files) to compile
;;; (ct_load 'interp) to load what's already there
;;; remember (load "FOO:soley;bigfnt") for big font with correct underscore
;;; (run-ada) to do menu hack

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Hack dem fonts.  Convert .kst files to .QFASL's.

(defvar *fontdir* (fs:parse-pathname "DJ: LMFONTS.LATEST; GLORF.QFASL"))

(defun hack-dem-fonts ()
  (loop for (file) in (cdr (fs:directory-list "angel://lmi//soley//lmfonts//*" :fast)) do
	(let ((font (fed:read-kst-into-font file))
	      (out (send *fontdir* :new-name (send file :name))))
	  (format t "~&Font ~A (from ~A) going to ~A~%" font file out)
	  (compiler:fasd-symbol-value out font))))

;;;;;;;;;;
;;;
;;; A little more night music . . .

(defvar dirs '("ADA" "BARNES" "BOOCH" "BROWSER" "BUILD" "CTLISP" "DEBUG" "DOC"
	       "GRAPH" "INTERP" "LMFONTS" "SOLEY" "WINDOW"))

(defun write-to-tape (&optional (dirlist dirs))
  (loop for dir in dirlist do (fs:copy-directory (string-append "LM:" dir ";*.*#>") "mt:")))

(defvar indent 0)

(defvar example (fs:parse-pathname "lama:*.*#>"))

(defun list-dirs (&optional (stream terminal-io))
  (loop for dir in dirs do (list-a-directory (list dir) stream) (terpri)))

(defun show-dir (path stream)
  (setq path (send path :directory))
  (cond ((stringp path) (princ path stream))
	(t (princ (car path) stream)
	   (loop for name in (cdr path) do (tyo #\/ stream) (princ name stream)))))

(defun list-a-directory (subdir stream)
  (let* ((path (send example :new-directory subdir))
	 (contents (cdr (fs:directory-list path))))
    (format stream "~&~V@TDirectory " indent)
    (show-dir path stream)
    (format stream " -----~%")
    (loop for file in contents if (not (get file :directory)) do
	  (setq file (car file))
	  (format stream "    ~V@T" indent)
	  (show-dir file stream)
	  (format stream "//~A.~A;~D~%" (send file :name) (send file :type) (send file :version)))
    (let ((indent (+ indent 4)))
      (loop for file in contents if (get file :directory) do
	    (list-a-directory (append subdir (list (send (car file) :name))) stream)))))

;;; How to make a big one -- GJC's version, enterred by MLM Tuesday 85-08-19
(defun make-big-lisp-listener ()
  (send (make-instance 'tv:lisp-listener
		       :process
		       '(si:lisp-top-level1 :regular-pdl-size 50000.
					    :special-pdl-size 5000.)
		       :label "Computer * Thought Ada Tools")	;relabelled by mlm
	:select)
  (tv:await-window-exposure))

;;; All of the files in ctlisp and interp that are needed for the interpreter.
(defvar *all-the-files*
	'("CT:CTLISP;AIP.LISP"          "CT:CTLISP;CHARMAC.LISP"    "CT:CTLISP;CHUNKS.LISP"
	  "CT:CTLISP;COMPAT.LISP"	"CT:CTLISP;CTFLAV.LISP"	    "CT:CTLISP;CTHASH.LISP"
	  "CT:CTLISP;CTIO.LISP"		"CT:CTLISP;GCOLOR.LISP"	    "CT:CTLISP;POLLY.LISP"
	  "CT:CTLISP;REFERENCE.LISP"	"CT:CTLISP;TIME.LISP"

	  "CT:INTERP;ADABE.LISP"	"CT:INTERP;ADAS.LISP"       "CT:INTERP;ADAS100.LISP"
	  "CT:INTERP;ADAS120.LISP"	"CT:INTERP;ADAS130.LISP"    "CT:INTERP;ADAS150.LISP"
	  "CT:INTERP;ADAS36.LISP"	"CT:INTERP;ADAS39.LISP"	    "CT:INTERP;ADAS39A.LISP"
	  "CT:INTERP;ADAS40.LISP"	"CT:INTERP;ADAS42.LISP"	    "CT:INTERP;ADAS44.LISP"
	  "CT:INTERP;ADAS50.LISP"	"CT:INTERP;ADAS60.LISP"	    "CT:INTERP;ADAS70.LISP"
	  "CT:INTERP;AGGIES.LISP"	"CT:INTERP;ATTRIBUTE.LISP"  "CT:INTERP;BIFMACS.LISP"
	  "CT:INTERP;CACHE.LISP"	"CT:INTERP;CALENDL.LISP"    "CT:INTERP;CTADADT.LISP"
	  "CT:INTERP;DIANA.LISP"	"CT:INTERP;DIANAIDS.LISP"   "CT:INTERP;DIANAIO.LISP"
	  "CT:INTERP;DIANAPOS.LISP"	"CT:INTERP;DIANATTS.LISP"   "CT:INTERP;DIANGRAF.LISP"
	  "CT:INTERP;DIANODS.LISP"	"CT:INTERP;DIRECTIO.LISP"   "CT:INTERP;DIRIOL.LISP"
	  "CT:INTERP;DRIVER.LISP"	"CT:INTERP;DSMACS.LISP"	    "CT:INTERP;DYNSEM.LISP"
	  "CT:INTERP;EROR.LISP"		"CT:INTERP;FEREC.LISP"	    "CT:INTERP;GENERICS.LISP"
	  "CT:INTERP;INCD.LISP"		"CT:INTERP;INTERP.LISP"	    "CT:INTERP;IOCOMPAT.LISP"
	  "CT:INTERP;IOFLAV.LISP"	"CT:INTERP;LANA.LISP"	    "CT:INTERP;OPERATORS.LISP"
	  "CT:INTERP;PNORMS.LISP"	"CT:INTERP;PSER.LISP"	    "CT:INTERP;QUEUE.LISP"
	  "CT:INTERP;RELEASE.LISP"	"CT:INTERP;RESOLVE.LISP"    "CT:INTERP;SEMA.LISP"
	  "CT:INTERP;SEQIOL.LISP"	"CT:INTERP;SEQUENIO.LISP"   "CT:INTERP;STATEVAL.LISP"
	  "CT:INTERP;STDENV.LISP"	"CT:INTERP;TEXTIO.LISP"	    "CT:INTERP;TEXTIOL.LISP"
	  "CT:INTERP;TYPES.LISP"	"CT:INTERP;VISIBLE.LISP"
	  ))