(SETQ IBASE (ADD1 7)) 


(DEFPROP SMILEFNS 
 (NIL !X
      *NOPOINT
      BASE
      %DEFIN
      DV
      ENTER
      SPECIAL
      LPTOUT
      LPT
      OFF
      DSKOUT
      DSKIN
      GETDEF
      GRINL
      TIMER
      DPRINT
      OUTTIME
      UUO
      EDIT
      DEVP
      ALLFNS
      ALLVALUES
      LPTLENGTH) 
VALUE)

(DEFPROP !X 
 T 
SPECIAL)

(DEFPROP *NOPOINT 
 (NIL) 
VALUE)

(DEFPROP *NOPOINT 
 T 
SPECIAL)

(DEFPROP BASE 
 (NIL . 10) 
VALUE)

(DEFPROP BASE 
 T 
SPECIAL)

(DEFPROP %DEFIN 
 (LAMBDA(X V F P)
  (PROG (R)
	(SETQ R (COND ((GETL X (QUOTE (EXPR FEXPR SUBR FSUBR LSUBR MACRO))) (LIST X (QUOTE REDEFINED))) (T X)))
	(SETQ ALLFNS (ENTER X ALLFNS))
	(PUTPROP X (LIST (QUOTE LAMBDA) V F) P)
	(RETURN R))) 
EXPR)

(DEFPROP DV 
 (LAMBDA (%%L) (PROG2 (SETQ ALLVALUES (ENTER (CAR %%L) ALLVALUES)) (SET (CAR %%L) (CADR %%L)))) 
FEXPR)

(DEFPROP ENTER 
 (LAMBDA (X L) (COND ((MEMBER X L) L) (T (CONS X L)))) 
EXPR)

(DEFPROP SPECIAL 
 (LAMBDA(L)
  (MAPC (FUNCTION (LAMBDA (!X) (PROG2 (SET (CAR L) (ENTER !X (EVAL (CAR L)))) (PUTPROP !X T (QUOTE SPECIAL)))))
	(CDR L))) 
FEXPR)

(DEFPROP LPTOUT 
 (LAMBDA (L) (PROG NIL (LPT) (MAPC (FUNCTION EVAL) L) (OFF))) 
FEXPR)

(DEFPROP LPT 
 (LAMBDA NIL
  (PROG NIL
   L    (COND
	 ((NULL (ERRSET (OUTC (OUTPUT LPT:) T) NIL)) (TERPRI)
						     (PRINC
						      (QUOTE
						       "LPT IN USE, TYPE ALTMODE TO TRY AGAIN, BELL TO GIVE UP")
)						     (READCH)
						     (GO L)))
	(OUTTIME)
	(LINELENGTH LPTLENGTH))) 
EXPR)

(DEFPROP OFF 
 (LAMBDA NIL (OUTC NIL T)) 
EXPR)

(DEFPROP DSKOUT 
 (LAMBDA(%%L)
  (PROG (%%D)
	(COND ((DEVP (SETQ %%D (CAR %%L))) (SETQ %%L (CDR %%L))) (T (SETQ %%D (QUOTE DSK:))))
	(EVAL (LIST (QUOTE OUTPUT) %%D (CAR %%L)))
	(OUTC T T)
	(LINELENGTH LPTLENGTH)
	(MAPC (FUNCTION EVAL) (CDR %%L))
	(OFF))) 
FEXPR)

(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)))
	(EVAL (LIST (QUOTE INPUT) %%D (CAR %L)))
	(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)

(DEFPROP GETDEF 
 (LAMBDA(%L)
  (PROG (%X %%D)
	(COND ((DEVP (CAR %L)) (SETQ %%D (CAR %L)) (SETQ %L (CDR %L))) (T (SETQ %%D (QUOTE DSK:))))
	(EVAL (LIST (QUOTE INPUT) %%D (CAR %L)))
	(INC T)
   %L   (SETQ %X (ERRSET (READ) T))
	(COND ((ATOM (SETQ %X (CAR %X))) (RETURN (QUOTE ***)))
	      ((AND (NOT (ATOM %X)) (EQ (CAR %X) (QUOTE DEFPROP)) (MEMQ (CADR %X) (CDR %L)))
	       (PRINT (EVAL %X))))
	(GO %L))) 
FEXPR)

(DEFPROP GRINL 
 (LAMBDA(%L)
  (PROG NIL
	(PRINT (LIST (QUOTE SETQ) (QUOTE IBASE) (LIST (QUOTE ADD1) (SUB1 BASE))))
	(TERPRI)
	(EVAL (CONS (QUOTE GRINDEF) (CONS (CAR %L) (EVAL (CAR %L))))))) 
FEXPR)

(DEFPROP TIMER 
 (LAMBDA(%L)
  (PROG (%TIME %CONS %GC)
	(GC)
	(SETQ %TIME (TIME NIL))
	(SETQ %CONS (SPEAK))
	(SETQ %GC (GCTIME))
	(MAPC (FUNCTION EVAL) %L)
	(DPRINT
	 (LIST (*DIF (TIME NIL) %TIME)
	       (QUOTE MSEC)
	       (*DIF (SPEAK) %CONS)
	       (QUOTE CONSES)
	       (*DIF (GCTIME) %GC)
	       (QUOTE GCTIME))))) 
FEXPR)

(DEFPROP DPRINT 
 (LAMBDA (X) (PROG (BASE) (SETQ BASE 12) (RETURN (PRINT X)))) 
EXPR)

(DEFPROP OUTTIME 
 (LAMBDA NIL
  (PROG (X BASE *NOPOINT)
	(SETQ *NOPOINT T)
	(SETQ BASE 12)
	(TERPRI)
	(PRINC (QUOTE LISP-OUTPUT/ / ))
	(SETQ X (*QUO (UUO 23) 165140))
	(PRIN1 (*QUO X 74))
	(PRIN1 (QUOTE :))
	(PRIN1 (REMAINDER X 74))
	(PRINC (QUOTE / / ))
	(SETQ X (UUO 14))
	(PRIN1 (ADD1 (REMAINDER X 37)))
	(PRINC (QUOTE /-))
	(SETQ X (*QUO X 37))
	(PRIN1
	 (CDR
	  (ASSOC (REMAINDER X 14)
		 (QUOTE
		  ((0 . JAN) (1 . FEB)
			     (2 . MAR)
			     (3 . APR)
			     (4 . MAY)
			     (5 . JUN)
			     (6 . JUL)
			     (7 . AUG)
			     (10 . SEP)
			     (11 . OCT)
			     (12 . NOV)
			     (13 . DEC))))))
	(PRINC (QUOTE /-))
	(SETQ X (*QUO X 14))
	(PRIN1 (PLUS X 100))
	(TERPRI)
	(TERPRI))) 
EXPR)

(DEFPROP UUO 
 (LAMBDA(N)
  (PROG NIL
	(PUTPROP (QUOTE UUO) (NUMVAL BPORG) (QUOTE SUBR))
	(DEPOSIT BPORG (PLUS 260600000000 (GET (QUOTE NUMVAL) (QUOTE SYM))))
	(DEPOSIT (ADD1 BPORG) 47041000000)
	(SETQ BPORG (PLUS BPORG 3))
	(DEPOSIT (SUB1 BPORG) (PLUS 254000000000 (GET (QUOTE FIX1A) (QUOTE SYM))))
	(RETURN (UUO N)))) 
EXPR)

(DEFPROP EDIT 
 (LAMBDA(%%L)
  (PROG (%%A %%X %%P)
	(SETQ %%A (CAR %%L))
	(COND ((SETQ %%X (GET %%A (QUOTE EXPR))) (SETQ %%P (QUOTE EXPR)) (GO L1))
	      ((SETQ %%X (GET %%A (QUOTE FEXPR))) (SETQ %%P (QUOTE FEXPR)) (GO L1))
	      (T (SETQ %%X (SUBST 0 0 (CADDR %%A))) (SETQ %%P (CADR %%A))))
   L1   (SETQ %%P (PUTPROP %%A (SUBST (CADDR %%L) (CADR %%L) %%X) %%P))
	(RETURN (NOT (EQUAL %%P %%X))))) 
FEXPR)

(DEFPROP DEVP 
 (LAMBDA (X) (OR (EQ (CAR (LAST (EXPLODE X))) (QUOTE :)) (AND (NOT (ATOM X)) (NOT (ATOM (CDR X)))))) 
EXPR)

(DEFPROP ALLFNS 
 (NIL) 
VALUE)

(DEFPROP ALLVALUES 
 (NIL) 
VALUE)

(DEFPROP LPTLENGTH 
 (NIL . 160) 
VALUE)