(SETQ IBASE (ADD1 7)) 

(DEFPROP INITFNS 
 (NIL PRINQ PRINL MFUNC SAVE MYFNS FOR MAPFOR WHILE UNTIL REPEATWHILE REPEATUNTIL DSETQ BASE *NOPOINT MAP2CAR
 DRAW DPOUT %%%DPSPRINT FRMOUT DISPINIT FRM EDD DSKIN GETQ DPYPRINT REMDEF GRIN CDRQ PANIC CHANGE_NAME) 
VALUE)

(DEFPROP GETQ 
 (LAMBDA (L) (GET (CAR L) (CADR L))) 
FEXPR)

(DEFPROP DPYPRINT 
 (LAMBDA (L) (PROG NIL (DTYOS) (GVECT 0 0 46 1 0) (PRINT L) (DTYOU) (SHOW 17) (CLEAR))) 
EXPR)

(DEFPROP REMDEF 
 (LAMBDA (L) (REMPROP (CAR L) (CADR L))) 
FEXPR)

(DEFPROP GRIN 
 (LAMBDA(L)
  (PROG NIL
	(COND ((GET (QUOTE DTYOS) (QUOTE SUBR)) (PROG2 (CLEAR) (GVECT -1000 714 146 1 0) (DTYOS))) (T NIL))
	((LABEL GRIN1
		(LAMBDA(L M)
		 (COND ((NULL (CDDR L)) NIL)
		       (T
			(PROG2 (TERPRI)
			       ((LAMBDA (L) (SPRINT L 1 1)) (LIST (QUOTE DEFPROP) M (CADR L) (CAR L)))
			       (GRIN1 (CDDR L) M))))))
	 (CDAR L)
	 (CAR L))
	(COND ((GET (QUOTE DTYOS) (QUOTE SUBR)) (PROG NIL (DTYOU) (SHOW 17) (CLEAR))) (T NIL)))) 
FEXPR)

(DEFPROP CDRQ 
 (LAMBDA (L) (CDAR L)) 
FEXPR)

(DEFPROP PANIC 
 (LAMBDA NIL (SAVE (PANIC . LSP))) 
EXPR)

(DEFPROP CHANGE_NAME 
 (LAMBDA(L)
  (PROG (%%%A %%%B)
	(SETQ %%%A (CAR L))
	(SETQ %%%B (CADR L))
	(EVAL (LIST (QUOTE REMOB) %%%B))
	(EVAL (LIST (QUOTE REMOB) %%%A))
	(RPLACA (GET %%%A (QUOTE PNAME)) (CAR (GET %%%B (QUOTE PNAME))))
	(RPLACD (GET %%%A (QUOTE PNAME)) (CDR (GET %%%B (QUOTE PNAME))))
	(INTERN %%%A))) 
FEXPR)

(DEFPROP PRINQ 
 (LAMBDA (L) (PRINL L)) 
FEXPR)

(DEFPROP PRINL 
 (LAMBDA (L) (PROG2 (MAPC (MFUNC (L) (PROG2 (PRINC L) (PRINC (QUOTE " ")))) L) L)) 
EXPR)

(DEFPROP MFUNC 
 (LAMBDA (L) (LIST (QUOTE FUNCTION) (CONS (QUOTE LAMBDA) (CDR L)))) 
MACRO)

(DEFPROP SAVE 
 (LAMBDA (L) (EVAL (LIST (QUOTE DSKOUT) (CAR L) (QUOTE (GRINL ALLFNS))))) 
FEXPR)

(DEFPROP FOR 
 (LAMBDA(L)
  (PROG (%%LOOP)
	(SETQ L (CDR L))
	(RETURN
	 (LIST (QUOTE PROG)
	       (LIST (CAR L))
	       (LIST (QUOTE SETQ) (CAR L) (CAADR L))
	       (SETQ %%LOOP (GENSYM))
	       (LIST (QUOTE COND)
		     (LIST (LIST (QUOTE *LESS) (CADADR L) (CAR L)) (QUOTE (RETURN NIL)))
		     (LIST T (CADDR L)))
	       (LIST (QUOTE SETQ)
		     (CAR L)
		     (COND ((NULL (CDDADR L)) (LIST (QUOTE ADD1) (CAR L)))
			   (T (LIST (QUOTE *PLUS) (CAR L) (CADDR (CADR L))))))
	       (LIST (QUOTE GO) %%LOOP))))) 
MACRO)

(DEFPROP MAPFOR 
 (NIL . UNBOUND) 
VALUE)

(DEFPROP MAPFOR 
 (LAMBDA(L)
  (PROG (%%NAME)
	(SETQ L (CDR L))
	(SETQ %%NAME (GENSYM))
	(RETURN
	 (LIST (LIST (QUOTE LABEL)
 		     %%NAME
		     (LIST (QUOTE LAMBDA)
			   (LIST (CAR L))
			   (LIST (QUOTE COND)
				 (LIST (LIST (QUOTE *LESS) (CADADR L) (CAR L)) NIL)
				 (LIST (QUOTE T)
				       (LIST (QUOTE CONS)
					     (CADDR L)
					     (LIST %%NAME
						   (COND ((NULL (CDDADR L)) (LIST (QUOTE ADD1) (CAR L)))
							 (T
							  (LIST (QUOTE *PLUS) (CAR L) (CADDR (CADR L)))))))))))
	       (CAADR L))))) 
MACRO)

(DEFPROP WHILE 
 (LAMBDA(L)
  (PROG (%%LOOP)
	(RETURN
	 (LIST (QUOTE PROG)
	       (LIST (SETQ %%LOOP (GENSYM)))
 	       %%LOOP
	       (LIST (QUOTE COND) (LIST (CADR L) (CADDR L)) (QUOTE (T (RETURN))))
	       (LIST (QUOTE GO) %%LOOP))))) 
MACRO)

(DEFPROP UNTIL 
 (LAMBDA(L)
  (PROG (%%LOOP)
	(RETURN
	 (LIST (QUOTE PROG)
	       (LIST (SETQ %%LOOP (GENSYM)))
 	       %%LOOP
	       (LIST (QUOTE COND) (LIST (CADR L) (QUOTE (RETURN))) (LIST T (CADDR L)))
	       (LIST (QUOTE GO) %%LOOP))))) 
MACRO)

(DEFPROP REPEATWHILE 
 (LAMBDA(L)
  (PROG (%%LOOP)
	(RETURN
	 (LIST (QUOTE PROG)
	       (LIST (SETQ %%LOOP (GENSYM)))
 	       %%LOOP
	       (CADR L)
	       (LIST (QUOTE COND) (LIST (CADDR L) (LIST (QUOTE GO) %%LOOP)) (QUOTE (T (RETURN)))))))) 
MACRO)

(DEFPROP REPEATUNTIL 
 (LAMBDA(L)
  (PROG (%%LOOP)
	(RETURN
	 (LIST (QUOTE PROG)
	       (LIST (SETQ %%LOOP (GENSYM)))
 	       %%LOOP
	       (CADR L)
	       (LIST (QUOTE COND) (LIST (CADDR L) (QUOTE (RETURN))) (LIST T (LIST (QUOTE GO) %%LOOP))))))) 
MACRO)

(DEFPROP DSETQ 
 (LAMBDA(L)
  (PROG2 (COND ((MEMBER (CAR L) ALLFNS) NIL) (T (SETQ ALLFNS (CONS (CAR L) ALLFNS))))
	 (SET (CAR L) (EVAL (CADR L))))) 
FEXPR)

(DEFPROP BASE 
 (NIL . 10) 
VALUE)

(DEFPROP BASE 
 T 
SPECIAL)

(DEFPROP *NOPOINT 
 T 
SPECIAL)

(DEFPROP MAP2CAR
 (LAMBDA (FN L M) (COND ((NULL L) NIL) (T (CONS (FN L M) (MAP2CAR FN (CDR L) (CDR M)))))) 
EXPR)


(SETQ IBASE (ADD1 7)) 


(DEFPROP LISPDP 
 (NIL DISPINIT FRM FRMOUT EDD %DPSPRINT DPOUT DRAW) 
VALUE)

(DEFPROP DISPINIT 
 (LAMBDA NIL
  (PROG NIL
	(GETSYM SUBR
 		AIVECT
 		AVECT
 		APT
 		RIVECT
 		RVECT
 		RPT
 		DTYOS
 		DTYOU
 		LOCATE
 		CLEAR
 		FIXUP
 		DJUMP
 		DJSR
 		DPINIT
 		SHOW
 		KILL
 		GVECT
 		CHINIT)
	(DPINIT -540 5001)
	(AIVECT -1000 460.)
	(SHOW 16)
	(CHINIT 2 105 -1000)
	(DEFPROP ED (17 1 160 -1000) FRM)
	(ED T)
	(PUTPROP (QUOTE %%DPSPRINT) (GET (QUOTE %DPSPRINT) (QUOTE SUBR)) (QUOTE SUBR))
	(PUTPROP (QUOTE %DPSPRINT) (GET (QUOTE %%%DPSPRINT) (QUOTE EXPR)) (QUOTE EXPR))
	(CLEAR))) 
EXPR)

(DEFPROP FRM 
 (LAMBDA(%%A)
  (PROG (N)
	(CLEAR)
	(SETQ N (GET %%A (QUOTE FRM)))
	(GVECT 0 0 46 (CADR N) 0)
	(SHOW (CAR N))
	(CHINIT (CADR N) (CADDR N) (CADDDR N))
	(RETURN (CAR N)))) 
EXPR)

(DEFPROP FRMOUT 
 (LAMBDA(DP%L)
  (PROG (DP%N)
	(CLEAR)
	(SETQ DP%N (FRM (CAR DP%L)))
	(DTYOS)
	(MAPC (FUNCTION EVAL) (CDR DP%L))
	(DTYOU)
	(KILL DP%N)
	(SHOW DP%N)
	(CLEAR))) 
FEXPR)

(DEFPROP EDD 
 (LAMBDA NIL (PROG NIL
	(KILL 17) (ED) (KILL 17))) 
EXPR)

(DEFPROP %%%DPSPRINT
 (LAMBDA(X)
  (PROG NIL
	(FRMOUT ED
		(COND ((EQ (CAR X) (QUOTE DEFPROP)) (PRINC (QUOTE "
("))						    (PRIN1 (CAR X))
						    (PRINC (QUOTE " "))
						    (PRIN1 (CADR X))
						    (TERPRI)
						    (%%DPSPRINT (CADDR X))
						    (PRIN1 (CADDDR X))
						    (PRINC (QUOTE ")
")))		      (T (%%DPSPRINT X)))))) 
EXPR)

(DEFPROP DPOUT 
 (LAMBDA(L)
  (PROG NIL (CLEAR) (DTYOS) (MAPC (FUNCTION EVAL) (CDR L)) (DTYOU) (KILL (CAR L)) (SHOW (CAR L)) (CLEAR))) 
FEXPR)

(DEFPROP DRAW 
 (LAMBDA (L) (MAPC (FUNCTION (LAMBDA (X) (RVECT (CAR X) (CADR X)))) L)) 
EXPR)

(SYSIN SMILE)
(BAKGAG T)

(DEFPROP DSKIN 
 (LAMBDA(%L)
  (PROG (%X %%D)
	(SETQ %%D (QUOTE DSK:))
   L1   (COND ((NULL %L) (RETURN (QUOTE ***)))
	      ((DEVP (CAR %L)) (SETQ %%D (CAR %L)) (SETQ %L (CDR %L)) (GO L1)))
	(COND ((ERRSET (EVAL (LIST (QUOTE INPUT) %%D (CAR %L))) NIL) T)
	      (T (EVAL (LIST (QUOTE INPUT) %%D (CONS (CAR %L) (QUOTE LSP))))))
	(INC T)
   L2   (SETQ %X (ERRSET (READ) T))
	(COND ((ATOM (SETQ %X (CAR %X))) (SETQ %L (CDR %L)) (GO L1))
	      ((AND (NOT (ATOM %X))
		    (EQ (CAR %X) (QUOTE DEFPROP))
		    (MEMQ (CADDDR %X) (QUOTE (EXPR FEXPR MACRO)))
		    (GETL (CADR %X) (QUOTE (EXPR FEXPR SUBR FSUBR LSUBR MACRO))))
	       (PRINT (LIST (CADR %X) (QUOTE REDEFINED)))))
	(EVAL %X)
	(GO L2))) 
FEXPR)

(PRINQ TVR'S LIBRARY LOADED)