Trailing-Edge
-
PDP-10 Archives
-
-
There are no other files named in the archive.
(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)