perm filename INIT.PRT[4,LMM] blob
sn#037546 filedate 1973-04-23 generic text, type T, neo UTF8
(DEFPROP INITFNS (INITFNS (SPECIAL READFILERESULTS FILELST)
WHEREIS READFILE NOBIND COMMENT LODE
FILEFNS SAVVALUE SAVDEF RESTOREVALUE
RESTOREDEF DECIMAL PACK MAKEFILE PRINT1
EVALQUOTE EXPRTYP FEXPRTYP (SETQ FILELST
NIL)
(INITFN (FUNCTION EVALQUOTE))
(NCONC BREAKMACROS
(QUOTE ((PP LIN ((GRINDEF . LIN)))
(STOP NIL (↑))))))
VALUE)
(SPECIAL READFILERESULTS FILELST)
(DEFPROP WHEREIS
(LAMBDA
(FN)
(FOR NEW X IN FILELST WHEN
(MEMQ FN (CDR (OR# (GET (FILEFNS X)
(QUOTE VALUE))
(QUOTE (NIL)))))
DO
(PRIN1 X)
(PRINC (QUOTE ","))))
EXPR)
(DEFPROP READFILE (LAMBDA (FIL)
(PROG (READFILERESULTS)
(INC (EVAL (CONS (QUOTE INPUT)
FIL)))
LP
(COND ((ERRSET (SETQ READFILERESULTS
(CONS (READ)
READFILERESULTS))
ERRORX)
(GO LP))
(T (RETURN (REVERSE
READFILERESULTS)))))
)
FEXPR)
(DEFPROP NOBIND (LAMBDA (X)
(OR (NOT X)
(EQ (CDR X)
(UNBOUND))))
EXPR)
(DEFPROP COMMENT (LAMBDA (COMMENTL)
COMMENTL)
FEXPR)
(DEFPROP LODE (LAMBDA (FILS)
(PROG NIL (COND ((ATOM FILS)
(SETQ FILS (LIST FILS))))
(SETQ FILELST (UNION FILELST FILS))
(EVAL (CONS (QUOTE DSKIN)
FILS))))
FEXPR)
(DEFPROP FILEFNS
(LAMBDA (FIL)
(PROG2 (SETQ
FIL
(COND
((LITATOM FIL)
FIL)
((LITATOM (CAR FIL))
(CAR FIL))
(T (ERROR (CONS FIL (QUOTE (INVALID
FILE NAME))))
)))
(OR# (GET FIL (QUOTE FILE))
(PUTPROP FIL (PACK FIL (QUOTE FNS))
(QUOTE FILE)))))
EXPR)
(DEFPROP SAVVALUE (LAMBDA (L)
(MAPC (FUNCTION
(LAMBDA (X)
(PUTPROP
X
(GET X (QUOTE VALUE))
(QUOTE OLDVALUE))))
L))
EXPR)
(DEFPROP SAVDEF (LAMBDA (L)
(MAPC (FUNCTION
(LAMBDA
(X)
(COND ((GET X (QUOTE SUBR))
(PUTPROP
X
(GET X (QUOTE SUBR))
(QUOTE OLDSUBR)))
((GET X (QUOTE EXPR))
(PUTPROP
X
(GET X (QUOTE EXPR))
(QUOTE OLDEXPR)))
((GET X (QUOTE FSUBR))
(PUTPROP
X
(GET X (QUOTE FSUBR))
(QUOTE OLDFSUBR)))
((GET X (QUOTE FEXPR))
(PUTPROP
X
(GET X (QUOTE FEXPR))
(QUOTE OLDFEXPR)))
(T NIL))))
L))
EXPR)
(DEFPROP RESTOREVALUE (LAMBDA (L)
(MAPC (FUNCTION
(LAMBDA
(X)
(PUTPROP X
(GET X (QUOTE
OLDVALUE))
(QUOTE VALUE))))
L))
EXPR)
(DEFPROP RESTOREDEF (LAMBDA
(L)
(MAPC (FUNCTION (LAMBDA (X)
(COND
((GET X (QUOTE OLDSUBR))
(PUTPROP X (GET X (QUOTE
OLDSUBR))
(QUOTE SUBR)))
((GET X (QUOTE OLDEXPR))
(PUTPROP X (GET X (QUOTE
OLDEXPR))
(QUOTE EXPR)))
((GET X (QUOTE OLDFSUBR))
(PUTPROP X (GET X (QUOTE
OLDFSUBR))
(QUOTE FSUBR)))
((GET X (QUOTE OLDFEXPR))
(PUTPROP X (GET X (QUOTE
OLDFEXPR))
(QUOTE FEXPR)))
(T NIL))))
L))
EXPR)
(DEFPROP DECIMAL (LAMBDA NIL (PROG2 (SETQ *NOPOINT NIL)
(SETQ BASE (SETQ IBASE
(PLUS 5.0 5.0))))
)
EXPR)
(DEFPROP PACK (LAMBDA L (READLIST
(PROG (FOR-VALUE I)
(SETQ I 1.0)
LOOP*1
(COND ((GREATERP I L)
(GO RETURN)))
(SETQ FOR-VALUE
(NCONC FOR-VALUE
(EXPLODEC (ARG I))))
NEXT*1 NEXT*I (SETQ I (PLUS I 1.0))
(GO LOOP*1)
RETURN
(RETURN FOR-VALUE))))
EXPR)
(DEFPROP MAKEFILE (LAMBDA (FIL)
(EVAL (LIST (QUOTE DSKOUT)
FIL
(FILEFNS FIL))))
EXPR)
(DEFPROP PRINT1 (LAMBDA (MESS)
(PROG1 (PRINT MESS)
(TERPRI)))
EXPR)
(DEFPROP
EVALQUOTE
(LAMBDA
NIL
(PROG
(LISPXLINE TEM)
(DECIMAL)
(PROMPT 95.0)
LOOP
(SETQ LISPXLINE (LINEREAD))
LOOP2
(COND
((SETQ TEM (ASSOC (CAR LISPXLINE)
BREAKMACROS))
(SETQ LISPXLINE (SUBST (CDR LISPXLINE)
(CADR TEM)
(CADDR TEM)))
(GO LOOP2))
((NULL (CDR LISPXLINE))
(COND
((AND (LITATOM (CAR LISPXLINE))
(NOBIND (GET (CAR LISPXLINE)
(QUOTE VALUE))))
(COND
((OR (FEXPRTYP (CAR LISPXLINE))
(GET (CAR LISPXLINE)
(QUOTE SUBR))
(AND (GET (CAR LISPXLINE)
(QUOTE EXPR))
(ZEROP (LENGTH (CADR (GET (CAR LISPXLINE)
(QUOTE EXPR)))))))
(PRINT1 (EVAL LISPXLINE)))
(T (PRINT1 (QUOTE ???)))))
(T (PRINT1 (EVAL (CAR LISPXLINE))))))
((NOT (CDDR LISPXLINE))
(COND ((EXPRTYP (CAR LISPXLINE))
(PRINT1 (APPLY (CAR LISPXLINE)
(CADR LISPXLINE))))
((FEXPRTYP (CAR LISPXLINE))
(PRINT1 (EVAL (CONS (CAR LISPXLINE)
(CADR LISPXLINE)))))
(T (PRINT1 (APPLY (CAR LISPXLINE)
(CDR LISPXLINE))))))
(T (MAPC (QUOTE EVAL)
LISPXLINE)))
(GO LOOP)))
EXPR)
(DEFPROP EXPRTYP (LAMBDA (X)
(COND ((LITATOM X)
(OR (GET X (QUOTE SUBR))
(GET X (QUOTE EXPR))))
((CONSP X)
(EQ (CAR X)
(QUOTE LAMBDA)))
(T NIL)))
EXPR)
(DEFPROP FEXPRTYP (LAMBDA (X)
(AND (LITATOM X)
(OR (GET X (QUOTE SUBR))
(GET X (QUOTE FSUBR)))))
EXPR)
(SETQ FILELST NIL)
(INITFN (FUNCTION EVALQUOTE))
(NCONC BREAKMACROS (QUOTE ((PP LIN ((GRINDEF . LIN)))
(STOP NIL (↑)))))
STOP