mirror of
https://github.com/PDP-10/its.git
synced 2026-01-25 11:47:10 +00:00
259 lines
7.6 KiB
Common Lisp
Executable File
259 lines
7.6 KiB
Common Lisp
Executable File
;-*-LISP-*-
|
||
; maxima utilities. initialy set up for string file manglement.
|
||
; -RWK November 1980.
|
||
; restructed with a DEFTOOLAGE, & merged in my CODESIZE file
|
||
; maker, TAGS file maker, data-base maker for the macsyma->lisp
|
||
; translator, MCL (macsyma source file compiler) check file maker.
|
||
; Comment: Arguments to DEFTOOLAGE should act as more than just
|
||
; documentation, should be processed by the command loop,
|
||
; don't have time for this now.
|
||
; -GJC 4:08pm Thursday, 4 December 1980
|
||
; added a standard argument reader.
|
||
; N.B. Inferiour JOB stuff isn't really handled properly for
|
||
; ^Z ^P P and the like.
|
||
; -GJC 2:47pm Friday, 19 December 1980
|
||
|
||
(HERALD MAXTUL)
|
||
|
||
(eval-when (eval compile)
|
||
(or (get 'defmfile 'version)
|
||
(load '((maxtul)defile)))
|
||
(or (get 'IOTA 'VERSION)
|
||
(load '((LIBLSP)IOTA)))
|
||
(or (get 'ERMSGX 'VERSION)
|
||
(load '((LIBMAX) ERMSGX)))
|
||
(or (get 'TTY 'VERSION)
|
||
(load '((LIBLSP) TTY))))
|
||
|
||
(declare (*EXPR OPEN-MESSAGE-FILE LISPM-DECLARE-FILE-MAKE FASL-IZE DECLARE-FILE-MAKE
|
||
DISP-MACSYMA-SOURCE-FILE GEN-CODEL GEN-COMPLR-CHECK GEN-NTAGS
|
||
MERGE-INCORE-SYSTEM GET-STRING-FILE-NAME READ-UNTIL-CR
|
||
DISPLAY-STRING-FILES-NO-FASLS COMPLETING-READ GET-MFD-INDEXES))
|
||
|
||
(eval-when (eval compile load)
|
||
(or (get 'toolm 'version)
|
||
(load '((maxtul)toolm))))
|
||
|
||
(defun dump-it ()
|
||
(gc)
|
||
(pure-suspend () '|MAXTUL;TS MAXTUL|)
|
||
(load '((MAXDOC)FILES))
|
||
(load '((MAXDOC)MCLDAT))
|
||
(get-mfd-indexes) ;Just in case
|
||
(sstatus tople '(command-loop)))
|
||
|
||
(defun ^^-INT (stream ignore-char)
|
||
(tyi stream)
|
||
(sstatus tople '(command-loop))
|
||
(^g))
|
||
(sstatus ttyint #^^ #'^^-INT)
|
||
|
||
(defvar toolage nil)
|
||
|
||
(defvar command)
|
||
|
||
(defun command-loop ()
|
||
(do ((command))
|
||
(NIL)
|
||
(setq command (car (completing-read '"MAXIMUM TOOLAGE>" toolage)))
|
||
(apply (or (get command 'toolage)
|
||
#'(lambda ignore-n
|
||
(format t "~&BUG: no toolage for ~S~%"
|
||
command)))
|
||
(read-argument-list (get command 'toolage-args)))))
|
||
|
||
(defun read-argument-list (l)
|
||
(mapcar #'read-argument l))
|
||
|
||
(defun read-argument (desc)
|
||
(if (atom desc) (setq desc (cons 's-exp desc)))
|
||
(caseq (car desc)
|
||
(s-exp
|
||
(print (cdr desc) t)
|
||
(read t))
|
||
(string
|
||
(read-until-cr (cdr desc)))
|
||
(t
|
||
(error "unknown type of argument to read-argument" desc
|
||
'fail-act))))
|
||
|
||
(deftoolage load-info ()
|
||
"Recompile MAXDOC;FILES and reload."
|
||
(ljob-run-job 'complr '|DSK:SYS;TS CL| "MAXDOC;FILES (T)")
|
||
(setq info-loaded nil)
|
||
(load-info))
|
||
|
||
(deftoolage load-file ((string . |Filename-> |))
|
||
"Lisp Load a file"
|
||
(load (mergef |Filename-> | "DSK:MAXTUL;FOO *")))
|
||
|
||
(deftoolage REAP-STRING-DISPLAY ()
|
||
"Displays the out-of-core string files from MAXERR and MAXER1"
|
||
"which do not have findable FASL files."
|
||
(display-string-files-no-fasls))
|
||
|
||
(deftoolage GET-FASL-STRING-FILE ((string . |(FASL file) |))
|
||
"Tells the name of the string file which goes with that FASL file"
|
||
(let* ((filename (namelist |(FASL file) |))
|
||
(fasldir (get (cadr filename) 'fasl-dir))
|
||
(answer))
|
||
(if fasldir
|
||
(setq filename
|
||
(mergef filename `((DSK ,fasldir) * FASL))))
|
||
(setq answer (get-string-file-name filename))
|
||
(format T "~&FASL file: ~A --> String file: ~A"
|
||
(namestring filename)
|
||
(if answer (namestring answer)
|
||
"[NONE]"))))
|
||
|
||
(deftoolage GET-STRING-FILE-INFO ((string . |(String file) |))
|
||
"Abstracts the information from the string file directory"
|
||
(display-string-file-info |(String file) |))
|
||
|
||
(deftoolage MERGE-INCORE-SYSTEM ()
|
||
"Merge together the out-of-core strings for the"
|
||
"in-core files in preparation for a new MACSYMA dump."
|
||
(merge-incore-system))
|
||
|
||
(deftoolage gen-tags ()
|
||
"Generate NTAGS file."
|
||
(format t "~&; Generating NTAGS file.~%")
|
||
(GEN-NTAGS)
|
||
(VALRET ": I'm using a VALRET :TAGS MACSYMA;MACSYMA NTAGSî:CONTINUEî")
|
||
(FORMAT T "~&; Now, do :MOVE MACSYMA;MACSYMA NTAGS, MACSYMA TAGS~
|
||
~%; after verifying that things are ok.~%"))
|
||
|
||
(DEFUN MOVE-FILE (X Y)
|
||
(IF (NOT (PROBEF X))
|
||
(ERROR "file-not-found" x 'IO-LOSSAGE))
|
||
(IF (PROBEF Y) (DELETEF Y))
|
||
(RENAMEF X Y))
|
||
|
||
(deftoolage gen-mcl-check ()
|
||
"Generate MCL data base"
|
||
(gen-complr-check))
|
||
|
||
(deftoolage gen-codel ()
|
||
"Generate MAXDOC;CODEL > listing of CODE-SIZEs"
|
||
(GEN-CODEL))
|
||
|
||
(deftoolage display-macsyma-source-file-info ((string . |(first name) |))
|
||
"using information presently in the environment"
|
||
(let* ((name (cadr (namelist |(first name) |)))
|
||
;; uppcase and intern the name with NAMELIST.
|
||
(ob
|
||
(ass #'(lambda (name item)
|
||
(eq name
|
||
(macsyma-source-file-name item)))
|
||
name
|
||
macsyma-source-files)))
|
||
(cond (ob
|
||
(cursorpos 'c)
|
||
(disp-macsyma-source-file ob t))
|
||
(t
|
||
(format t "~&; No data for ~A" name)))))
|
||
|
||
(deftoolage declare-file-make ()
|
||
"Update the declare file used by translated code."
|
||
(declare-file-make)
|
||
(let ((f "DSK:MAXDOC;DCL LOAD"))
|
||
(format t "~&; ~A written, making FASL now." f)
|
||
(fasl-ize f)))
|
||
|
||
(deftoolage lispm-declare-file-make ()
|
||
"Update declare file used by a bare lisp machine."
|
||
(lispm-declare-file-make))
|
||
|
||
(deftoolage QUIT ()
|
||
"To lisp TOPLEVEL"
|
||
(sstatus tople nil)
|
||
(^g))
|
||
|
||
(deftoolage KILL-JOB ()
|
||
"Kill job"
|
||
(if (memq (car (completing-read "Kill job. [Confirm?] "
|
||
'(yes help no maybe why-not what who-me)))
|
||
'(yes maybe why-not))
|
||
(QUIT)))
|
||
|
||
(deftoolage HELP ()
|
||
"Print this cruft."
|
||
(cursorpos 'c)
|
||
(format t "~
|
||
~&Welcome to the MACSYMA TOOL~
|
||
~%The following commands are currently implemented:")
|
||
(mapc #'(lambda (cmd)
|
||
(format t
|
||
"~&~A ~{~A ~}~%~{ ~A~%~}"
|
||
cmd
|
||
(get cmd 'toolage-args)
|
||
(or (get cmd 'toolage-doc)
|
||
'("BUG: no documentation for this!"))))
|
||
toolage)
|
||
(format t
|
||
"~
|
||
~&The command reader completes on altmode or space,~
|
||
~%so the long command names should not deter you.~
|
||
~%"))
|
||
|
||
(defun msgfiles-int (stream char)
|
||
(if (= char (tyipeek () stream -1))
|
||
(tyi stream))
|
||
(format t
|
||
"~&; ~:[Pushing T onto~;Deleting T from~] msgfiles.~%"
|
||
(memq t msgfiles))
|
||
(if (memq t msgfiles)
|
||
(setq msgfiles (delq t msgfiles))
|
||
(push t msgfiles)))
|
||
|
||
(sstatus ttyint #^N #'msgfiles-int)
|
||
|
||
(defvar wall-file ())
|
||
(deftoolage wallpaper ()
|
||
"Toggle wallpaper output"
|
||
(cond (wall-file
|
||
(setq msgfiles (delq wall-file msgfiles))
|
||
(close wall-file)
|
||
(format t "~&; Wall-paper file was ~S~%"
|
||
(namestring (truename wall-file)))
|
||
(setq wall-file nil))
|
||
('else
|
||
(format t "~&; Opening wall-paper file.~%")
|
||
(setq wall-file (open "DSK:MAXTUL;WALL >" 'OUT))
|
||
(push wall-file msgfiles))))
|
||
|
||
|
||
|
||
(defun display-string-file-info (file)
|
||
(phi ((message-file (open-message-file file)))
|
||
(let* ((truename (truename message-file))
|
||
(alist (message-file-alist message-file))
|
||
(temp (or (cdr (assq 'source-file-name alist))
|
||
(cdr (assq 'filename alist))))
|
||
(source-files (if temp (ncons temp)
|
||
(or (cdr (assq 'filenames alist)) '(<NONE?>))))
|
||
(author (or (cdr (assq 'source-file-author alist)) '|???|))
|
||
(creator (or (cdr (assq 'creator alist)) '|???|))
|
||
(fasl (cdr (assq 'output-file-name alist)))
|
||
(funs (mapcar #'CAR (cdr (assq 'fun-doc-alist alist))))
|
||
(vars (mapcar #'CAR (cdr (assq 'var-doc-alist alist)))))
|
||
(format t "~&Filename: ~A~%~
|
||
Creator: ~A~%~
|
||
Source files: ~A~%~
|
||
Author: ~A~%~
|
||
Output file: ~A~%~
|
||
Documented variables: ~S~%~
|
||
Documented functions: ~S~%~
|
||
Total number of strings: ~D~%"
|
||
(namestring truename)
|
||
creator
|
||
(mapcar #'namestring source-files)
|
||
author
|
||
(namestring fasl)
|
||
vars funs
|
||
(cadr (assq 'message-count alist))))))
|
||
|
||
(or (get 'breaklevel 'version)
|
||
(load '((liblsp)break)))
|
||
(sstatus breaklevel '(Breaklevel))
|