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 (↑)))))