mirror of
https://github.com/PDP-10/its.git
synced 2026-03-24 09:30:29 +00:00
286 lines
8.7 KiB
Common Lisp
Executable File
286 lines
8.7 KiB
Common Lisp
Executable File
;;; GENFNS -*-LISP-*-
|
|
;;; **************************************************************
|
|
;;; ***** MACLISP ****** LISP FUNCTIONS ENUMERATOR (GENFNS) ******
|
|
;;; **************************************************************
|
|
;;; ** (C) COPYRIGHT 1979 MASSACHUSETTS INSTITUTE OF TECHNOLOGY **
|
|
;;; ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) *******
|
|
;;; **************************************************************
|
|
|
|
;;; To use this file, simply get a current LISP, load this file in,
|
|
;;; and do (GENFNS). It will then produce the summary file QIOORD
|
|
;;; Its purpose is to produce a listing of all function names and
|
|
;;; variables in the initial LISP; for output, it will make the file
|
|
;;; .INFO.;QIOORD verno on ITS systems
|
|
;;; <MACLISP>QIOORD.DOC.verno on DEC20 systems
|
|
;;; LISP:QIOORD.DOC on DEC10 systems
|
|
;;; DSK:[MAC,LSP]QIOORD.DOC on the SAIL system
|
|
;;; To write onto another file, do (GENFNS (DEV USR) FN1 FN2)
|
|
|
|
|
|
(DECLARE (SPECIAL * + - ^R ^W BASE QUUX CHRCT OUTFILES
|
|
UWRITE LINEL ALLSTATUSOPS)
|
|
(*FEXPR GENFNS)
|
|
(*EXPR *GENFNS PRINCRUFT PRINPROPS GETVALUES PRIN10 2PRIN10)
|
|
(*LEXPR LINEL)
|
|
(FIXNUM I J NL NC MX SP))
|
|
|
|
(SSTATUS FEATURE NOLDMSG)
|
|
|
|
(DEFUN GENFNS FEXPR (V)
|
|
(LET ((^R 'T) (^W 'T) (DEFAULTF DEFAULTF))
|
|
(COND (V
|
|
(SETQ V (NAMELIST V))
|
|
(APPLY 'UWRITE (CAR V))
|
|
(*GENFNS)
|
|
(APPLY 'UFILE (CDR V)))
|
|
((STATUS FEATURE ITS)
|
|
(UWRITE DSK /.INFO/.)
|
|
(*GENFNS)
|
|
(APPLY 'UFILE `(QIOORD ,(status lispversion))))
|
|
((STATUS FEATURE DEC20)
|
|
(UWRITE DSK MACLISP)
|
|
(*GENFNS)
|
|
(APPLY 'UFILE `((DSK MACLISP) QIOORD DOC ,(status lispversion))))
|
|
((COND ((STATUS FEATURE SAIL) (UWRITE DSK (MAC LSP)) 'T)
|
|
((STATUS FEATURE DEC10) (UWRITE LISP) 'T))
|
|
(*GENFNS)
|
|
(UFILE QIOORD DOC)))))
|
|
|
|
(MAPC (FUNCTION (LAMBDA (X) (PUTPROP X 'LAP 'FUNNYFN)))
|
|
'(*DELQ *DELETE *APPEND *TIMES *GREAT *LESS
|
|
*PLUS *NCONC *APPLY *EVAL *PRINT
|
|
*PRIN1 *PRINC *TERPRI *TYO GETDDTSYM
|
|
LAPSETUP/| TTSR/| LH/|
|
|
SQOZ/| PUTDDTSYM GCPROTECT
|
|
GETMIDASOP PURCOPY PURIFY
|
|
FASLAPSETUP/| PAGEBPORG))
|
|
|
|
(MAPC (FUNCTION (LAMBDA (X) (PUTPROP X 'LAP 'FUNNYVAR)))
|
|
'(*PURE PURCLOBRL PURE TTSR/| LAPSETUP/|
|
|
PUTPROP BPORG BPEND GCPROTECT))
|
|
|
|
|
|
(DEFUN INTERNAL-TEST (X)
|
|
(COND ((GETL X '(FUNNYFN FUNNYVAR)) () )
|
|
((GET X 'INTERNAL-TEST))
|
|
((OR (AND (EQ (GETCHAR X 1) '+)
|
|
(MEMQ (GETCHAR X 2) '(I /i))
|
|
(MEMQ (GETCHAR X 3) '(N /n))
|
|
(MEMQ (GETCHAR X 4) '(T /t))
|
|
(MEMQ (GETCHAR X 5) '(E /e))
|
|
(MEMQ (GETCHAR X 6) '(R /r))
|
|
(MEMQ (GETCHAR X 7) '(N /n))
|
|
(MEMQ (GETCHAR X 8) '(A /a))
|
|
(MEMQ (GETCHAR X 9) '(L /l))
|
|
(EQ (GETCHAR X 10.) '/-))
|
|
(LET ((N (FLATC X)))
|
|
(DO I 1 (1+ I) (> I N)
|
|
(AND (MEMQ (GETCHAR X I) '(/| | | |`| |,|))
|
|
(RETURN 'T)))))
|
|
(PUTPROP X 'INTERNAL-TEST 'T)
|
|
'T)))
|
|
|
|
|
|
(SETQ ALLSTATUSOPS '(
|
|
+ ABBREVIATE ARRAY BPSH BPSL BREAK CHTRAN CLI CRFIL
|
|
CRUNIT DATE DAYTIME DIVOV DOW EVALHOOK FASLOAD FEATURE
|
|
FILEMODE FLPDL FLUSH FTV FTVSIZE FTVTITLE FXPDL GCMAX
|
|
GCMIN GCSIZE GCTIME GCWHO HACTRN HOMEDIR HSNAM ITS JCL
|
|
JNAME JNUMBER LINMODE LISPVERSION LOSEF MACRO MAR MEMFREE
|
|
NEWLINE NOFEATURE OSPEED PDL PDLMAX PDLNAMES PDLROOOM
|
|
PDLSIZE PUNT PURSIZE PURSPACENAMES RANDOM SEGLOG SPCNAMES
|
|
SPCSIZE SPDL SSTATUS STATUS SUBSYS SYNTAX SYSTEM TABSIZE
|
|
TERPRI TOPLEVEL TTY TTYCONS TTYINT TTYREAD TTYSCAN TTYSIZE
|
|
TTYTYPE UDIR UNAME UREAD USERI UUOLINKS UWRITE WHO1 WHO2
|
|
WHO3 XUNAM _
|
|
))
|
|
|
|
(MAPC '(LAMBDA (X) ((LAMBDA (Y) (COND ((CDDDDR Y) ;PDP-10 ONLY
|
|
(RPLACD (CDDDDR Y) NIL)
|
|
(PUTPROP (IMPLODE Y) X 'STATUSOP))))
|
|
(EXPLODEN X)))
|
|
ALLSTATUSOPS)
|
|
|
|
(DEFUN PRIN10 (X) ((LAMBDA (BASE *NOPOINT) (PRINC X)) 10. T))
|
|
|
|
(DEFUN 2PRIN10 (X)
|
|
((LAMBDA (BASE *NOPOINT)
|
|
(PRINC (// X 10.))
|
|
(PRINC (\ X 10.)))
|
|
10. T))
|
|
|
|
(DEFUN PHLATC (F X)
|
|
(COND (F (FLATC X))
|
|
((+ 2 (FLATC (CAR X))))))
|
|
|
|
(DEFUN PRINCRUFT (M L)
|
|
(PROG (MX NL NC AT LL)
|
|
(COND (L (SETQ L (COND ((SETQ AT (ATOM (CAR L)))
|
|
(SORT L (FUNCTION ALPHALESSP)))
|
|
((SORTCAR L (FUNCTION ALPHALESSP)))))
|
|
(TERPRI)
|
|
(TERPRI)
|
|
(PRINC M)
|
|
(TERPRI)
|
|
(TERPRI)
|
|
(SETQ MX (DO ((X L (CDR X))
|
|
(I 0 (MAX I (PHLATC AT (CAR X)))))
|
|
((NULL X) I)))
|
|
(SETQ NL (// LINEL (+ MX 4)))
|
|
(SETQ NC (// (+ (LENGTH L) (1- NL)) NL))
|
|
(DO ((I NL (1- I)))
|
|
((PROG2 (SETQ LL (CONS L LL)) (= I 1)))
|
|
(DO ((J NC (1- J)))
|
|
((OR (NULL L) (ZEROP J)))
|
|
(SETQ L (CDR L))))
|
|
(SETQ LL (NREVERSE LL))
|
|
(DO ((I NC (1- I)) (SP 0 0))
|
|
((ZEROP I))
|
|
(MAP (FUNCTION (LAMBDA (X)
|
|
(COND ((CAR X)
|
|
(PRINC '| |)
|
|
(DO ((J SP (1- J)))
|
|
((ZEROP J))
|
|
(PRINC '| |))
|
|
(COND (AT (PRINC (CAAR X)))
|
|
(T (PRINC (CDAAR X))
|
|
(PRINC '| |)
|
|
(PRINC (CAAAR X))))
|
|
(SETQ SP (- MX (PHLATC AT (CAAR X))))
|
|
(RPLACA X (CDAR X))))))
|
|
LL)
|
|
(TERPRI))))))
|
|
|
|
|
|
(DEFUN *GENFNS NIL
|
|
(PROG (DATE TIME USRSUBRS USRLSUBRS USRFSUBRS LAPFNS INTFNS STATUSOPS
|
|
SYSVARS LAPVARS SYSARRAYS USERAUTOS SYSAUTOS PMFLAG)
|
|
(TERPRI)
|
|
(COND ((STATUS FEATURE ITS) (PRINC '|ITS |))
|
|
((STATUS FEATURE DEC20) (PRINC '|TOPS-20//TENEX |))
|
|
((STATUS FEATURE SAIL) (PRINC '|SAIL |))
|
|
((STATUS FEATURE CMU) (PRINC '|CMU |))
|
|
((STATUS FEATURE TOPS-10) (PRINC '|TOPS-10 |)))
|
|
(PRINC '|MacLISP |)
|
|
(PRINC (STATUS LISPVERSION))
|
|
(PRINC '| Functions and Other Features|)
|
|
(TERPRI)
|
|
(PRINC '|This file was created by |)
|
|
(PRINC (STATUS USERID))
|
|
(PRINC '| on |)
|
|
(DO ((X (EXPLODEN (STATUS DOW)) (CDR X))
|
|
(N 0 40))
|
|
((NULL X))
|
|
(TYO (+ (CAR X) N)))
|
|
(PRINC '|, |)
|
|
(SETQ DATE (STATUS DATE))
|
|
(PRINC (DO ((I (CADR DATE) (1- I))
|
|
(L '(|January| |February| |March| |April| |May| |June|
|
|
|July| |August| |September| |October|
|
|
|November| |December|)
|
|
(CDR L)))
|
|
((= I 1) (CAR L))))
|
|
(PRINC '| |)
|
|
(PRIN10 (CADDR DATE))
|
|
(PRINC '|, 19|)
|
|
(PRIN10 (CAR DATE))
|
|
(SETQ TIME (STATUS DAYTIME))
|
|
(PRINC '| at |)
|
|
(AND (> (CAR TIME) 11.)
|
|
(RPLACA TIME (- (CAR TIME) 12.))
|
|
(SETQ PMFLAG T))
|
|
(AND (ZEROP (CAR TIME)) (RPLACA TIME '0))
|
|
(PRIN10 (CAR TIME))
|
|
(PRINC '|:|)
|
|
(2PRIN10 (CADR TIME))
|
|
(COND (PMFLAG (PRINC '| PM|))
|
|
((PRINC '| AM|)))
|
|
(TERPRI)
|
|
(SETQ LINEL (LINEL (OR UWRITE TYO)))
|
|
(MAPATOMS (FUNCTION
|
|
(LAMBDA (QUUX)
|
|
((LAMBDA (F V)
|
|
(MAPCAR (FUNCTION (LAMBDA (P)
|
|
(COND ((MEMQ P '(SUBR FSUBR LSUBR))
|
|
(COND ((EQ F 'LAP) (PUSH QUUX LAPFNS))
|
|
((INTERNAL-TEST QUUX) (PUSH QUUX INTFNS))
|
|
((EQ P 'SUBR) (PUSH QUUX USRSUBRS))
|
|
((EQ P 'FSUBR) (PUSH QUUX USRFSUBRS))
|
|
((EQ P 'LSUBR) (PUSH QUUX USRLSUBRS)) ))
|
|
((EQ P 'VALUE)
|
|
(COND ((EQ V 'LAP) (PUSH QUUX LAPVARS))
|
|
(T (PUSH QUUX SYSVARS))))
|
|
((EQ P 'ARRAY) (PUSH QUUX SYSARRAYS))
|
|
((EQ P 'AUTOLOAD)
|
|
(COND ((INTERNAL-TEST QUUX)
|
|
(PUSH QUUX SYSAUTOS))
|
|
((PUSH QUUX USERAUTOS))) ))))
|
|
(STATUS SYSTEM QUUX)))
|
|
(GET QUUX 'FUNNYFN)
|
|
(GET QUUX 'FUNNYVAR)))))
|
|
(MAPC (FUNCTION (LAMBDA (X)
|
|
(AND (APPLY 'STATUS (LIST 'STATUS X))
|
|
(PUSH (CONS (OR (GET X 'STATUSOP)
|
|
((LAMBDA (Y)
|
|
(COND ((CDDDDR Y) ;PDP-10 ONLY
|
|
(IMPLODE (APPEND Y '(/ ?))))
|
|
(T X)))
|
|
(EXPLODEN X)))
|
|
(COND ((APPLY 'STATUS
|
|
(LIST 'SSTATUS X))
|
|
'*)
|
|
(T '/ )))
|
|
STATUSOPS))))
|
|
(STATUS STATUS))
|
|
(PRINCRUFT '|User SUBRs:| USRSUBRS)
|
|
(PRINCRUFT '|User FSUBRs:| USRFSUBRS)
|
|
(PRINCRUFT '|User LSUBRs:| USRLSUBRS)
|
|
(PRINCRUFT '|STATUS options (* = can use with SSTATUS too):| STATUSOPS)
|
|
(PRINCRUFT '|Initial arrays:| SYSARRAYS)
|
|
(PRINPROPS '|Initial User AUTOLOAD properties:|
|
|
(MAPCAR (FUNCTION (LAMBDA (X)
|
|
(CONS X (GET X 'AUTOLOAD))))
|
|
USERAUTOS))
|
|
(PRINCRUFT '|LAP and FASLOAD functions:| LAPFNS)
|
|
(PRINCRUFT '|Internal system functions:| INTFNS)
|
|
(PRINPROPS '|Internal system AUTOLOAD properties:|
|
|
(MAPCAR (FUNCTION (LAMBDA (X)
|
|
(CONS X (GET X 'AUTOLOAD))))
|
|
SYSAUTOS))
|
|
(PRINPROPS '|System variables:| (GETVALUES SYSVARS))
|
|
(PRINPROPS '|LAP and FASLOAD variables:| (GETVALUES LAPVARS))
|
|
))
|
|
|
|
(DEFUN GETVALUES (X)
|
|
((LAMBDA (^R ^W * + - OUTFILES DEFAULTF UREAD UWRITE)
|
|
(MAPCAR (FUNCTION (LAMBDA (Y)
|
|
(CONS Y
|
|
(COND ((BOUNDP Y)
|
|
(SYMEVAL Y))
|
|
(T 'UNBOUND)))))
|
|
X))
|
|
NIL NIL '* '+ '- NIL '((DSK LOSER) @ @) NIL NIL))
|
|
|
|
(DEFUN PRINPROPS (M L)
|
|
(COND (L (SETQ L (SORTCAR L (FUNCTION ALPHALESSP)))
|
|
(TERPRI)
|
|
(TERPRI)
|
|
(PRINC M)
|
|
(TERPRI)
|
|
(TERPRI)
|
|
(PRINC '| NAME OF ATOM INITIAL VALUE|)
|
|
(TERPRI)
|
|
(TERPRI)
|
|
(DO ((X L (CDR X)))
|
|
((NULL X))
|
|
(PRINC '| |)
|
|
(PRIN1 (CAAR X))
|
|
(DO ((I (- 32. (CHARPOS (OR UWRITE T))) (1- I)))
|
|
((NOT (PLUSP I)))
|
|
(DECLARE (FIXNUM I))
|
|
(PRINC '| |))
|
|
(PRINC '| |)
|
|
(PRIN1 (CDAR X))
|
|
(TERPRI)))))
|
|
|