perm filename INIT.LSP[3,LMM] blob
sn#038914 filedate 1973-04-27 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 ((PROGN (SETQ LASTWORD (CAR (LAST (QUOTE 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. 5.)))))
EXPR)
(DEFPROP PACK
(LAMBDA L
(READLIST
(PROG (FOR-VALUE I)
(SETQ I 1.)
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.))
(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)
LOOP (PROMPT 95.)
(SETQ LISPXLINE (LINEREAD))
(PROMPT 33.)
LOOP2
(COND ((NULL LISPXLINE) (GO LOOP))
((SETQ TEM (ASSOC (CAR LISPXLINE) BREAKMACROS))
(SETQ LISPXLINE (SUBST (CDR LISPXLINE) (CADR TEM) (CADDR TEM)))
(GO LOOP2))
((LITATOM (CAR LISPXLINE))
(COND ((NOBIND (GET (CAR LISPXLINE) (QUOTE VALUE)))
(COND ((FEXPRTYP (CAR LISPXLINE)) (PRINT1 (EVAL LISPXLINE)))
((OR (GET (CAR LISPXLINE) (QUOTE SUBR))
(AND (GET (CAR LISPXLINE) (QUOTE EXPR))
(EQUAL (LENGTH (CADR (GET (CAR LISPXLINE) (QUOTE EXPR))))
(LENGTH (CDR LISPXLINE)))))
(PRINT1 (APPLY (CAR LISPXLINE) (CDR LISPXLINE))))
(T (PRINT1 (QUOTE ???)))))
(T (SETQ LASTWORD (CAR LISPXLINE))
(PRINT1 (EVAL (CAR LISPXLINE)))
(SETQ LISPXLINE (CDR LISPXLINE))
(GO LOOP2))))
(T (PRINT1 (EVAL (CAR LISPXLINE))) (SETQ LISPXLINE (CDR LISPXLINE)) (GO LOOP)))
(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 FEXRP)) (GET X (QUOTE FSUBR)))))
EXPR)
(SETQ FILELST NIL)
(INITFN (FUNCTION EVALQUOTE))
(NCONC BREAKMACROS
(QUOTE ((PP LIN ((PROGN (SETQ LASTWORD (CAR (LAST (QUOTE LIN)))) (GRINDEF . LIN)))) (STOP NIL (↑)))))