Google
 

Trailing-Edge - PDP-10 Archives - -
There are no other files named in the archive.
00100	
00200	(SETQ IBASE (ADD1 7)) 
00300	
00400	
00500	(DEFPROP SMILEFNS 
00600	 (NIL !X
00700	      *NOPOINT
00800	      BASE
00900	      %DEFIN
01000	      DV
01100	      ENTER
01200	      SPECIAL
01300	      LPTOUT
01400	      LPT
01500	      OFF
01600	      DSKOUT
01700	      DSKIN
01800	      GETDEF
01900	      GRINL
02000	      TIMER
02100	      DPRINT
02200	      OUTTIME
02300	      UUO
02400	      EDIT
02500	      DEVP
02600	      ALLFNS
02700	      ALLVALUES
02800	      LPTLENGTH) 
02900	VALUE)
03000	
03100	(DEFPROP !X 
03200	 T 
03300	SPECIAL)
03400	
03500	(DEFPROP *NOPOINT 
03600	 (NIL) 
03700	VALUE)
03800	
03900	(DEFPROP *NOPOINT 
04000	 T 
04100	SPECIAL)
04200	
04300	(DEFPROP BASE 
04400	 (NIL . 10) 
04500	VALUE)
04600	
04700	(DEFPROP BASE 
04800	 T 
04900	SPECIAL)
05000	
05100	(DEFPROP %DEFIN 
05200	 (LAMBDA(X V F P)
05300	  (PROG (R)
05400		(SETQ R (COND ((GETL X (QUOTE (EXPR FEXPR SUBR FSUBR LSUBR MACRO))) (LIST X (QUOTE REDEFINED))) (T X)))
05500		(SETQ ALLFNS (ENTER X ALLFNS))
05600		(PUTPROP X (LIST (QUOTE LAMBDA) V F) P)
05700		(RETURN R))) 
05800	EXPR)
05900	
06000	(DEFPROP DV 
06100	 (LAMBDA (%%L) (PROG2 (SETQ ALLVALUES (ENTER (CAR %%L) ALLVALUES)) (SET (CAR %%L) (CADR %%L)))) 
06200	FEXPR)
06300	
06400	(DEFPROP ENTER 
06500	 (LAMBDA (X L) (COND ((MEMBER X L) L) (T (CONS X L)))) 
06600	EXPR)
06700	
06800	(DEFPROP SPECIAL 
06900	 (LAMBDA(L)
07000	  (MAPC (FUNCTION (LAMBDA (!X) (PROG2 (SET (CAR L) (ENTER !X (EVAL (CAR L)))) (PUTPROP !X T (QUOTE SPECIAL)))))
07100		(CDR L))) 
07200	FEXPR)
07300	
07400	(DEFPROP LPTOUT 
07500	 (LAMBDA (L) (PROG NIL (LPT) (MAPC (FUNCTION EVAL) L) (OFF))) 
07600	FEXPR)
07700	
07800	(DEFPROP LPT 
07900	 (LAMBDA NIL
08000	  (PROG NIL
08100	   L    (COND
08200		 ((NULL (ERRSET (OUTC (OUTPUT LPT:) T) NIL)) (TERPRI)
08300							     (PRINC
08400							      (QUOTE
08500							       "LPT IN USE, TYPE ALTMODE TO TRY AGAIN, BELL TO GIVE UP")
08600	)						     (READCH)
08700							     (GO L)))
08800		(OUTTIME)
08900		(LINELENGTH LPTLENGTH))) 
09000	EXPR)
09100	
09200	(DEFPROP OFF 
09300	 (LAMBDA NIL (OUTC NIL T)) 
09400	EXPR)
09500	
09600	(DEFPROP DSKOUT 
09700	 (LAMBDA(%%L)
09800	  (PROG (%%D)
09900		(COND ((DEVP (SETQ %%D (CAR %%L))) (SETQ %%L (CDR %%L))) (T (SETQ %%D (QUOTE DSK:))))
10000		(EVAL (LIST (QUOTE OUTPUT) %%D (CAR %%L)))
10100		(OUTC T T)
10200		(LINELENGTH LPTLENGTH)
10300		(MAPC (FUNCTION EVAL) (CDR %%L))
10400		(OFF))) 
10500	FEXPR)
10600	
10700	(DEFPROP DSKIN 
10800	 (LAMBDA(%L)
10900	  (PROG (%X %%D)
11000		(SETQ %%D (QUOTE DSK:))
11100	   L1   (COND ((NULL %L) (RETURN (QUOTE ***)))
11200		      ((DEVP (CAR %L)) (SETQ %%D (CAR %L)) (SETQ %L (CDR %L)) (GO L1)))
11300		(EVAL (LIST (QUOTE INPUT) %%D (CAR %L)))
11400		(INC T)
11500	   L2   (SETQ %X (ERRSET (READ) T))
11600		(COND ((ATOM (SETQ %X (CAR %X))) (SETQ %L (CDR %L)) (GO L1))
11700		      ((AND (NOT (ATOM %X))
11800			    (EQ (CAR %X) (QUOTE DEFPROP))
11900			    (MEMQ (CADDDR %X) (QUOTE (EXPR FEXPR MACRO)))
12000			    (GETL (CADR %X) (QUOTE (EXPR FEXPR SUBR FSUBR LSUBR MACRO))))
12100		       (PRINT (LIST (CADR %X) (QUOTE REDEFINED)))))
12200		(EVAL %X)
12300		(GO L2))) 
12400	FEXPR)
12500	
12600	(DEFPROP GETDEF 
12700	 (LAMBDA(%L)
12800	  (PROG (%X %%D)
12900		(COND ((DEVP (CAR %L)) (SETQ %%D (CAR %L)) (SETQ %L (CDR %L))) (T (SETQ %%D (QUOTE DSK:))))
13000		(EVAL (LIST (QUOTE INPUT) %%D (CAR %L)))
13100		(INC T)
13200	   %L   (SETQ %X (ERRSET (READ) T))
13300		(COND ((ATOM (SETQ %X (CAR %X))) (RETURN (QUOTE ***)))
13400		      ((AND (NOT (ATOM %X)) (EQ (CAR %X) (QUOTE DEFPROP)) (MEMQ (CADR %X) (CDR %L)))
13500		       (PRINT (EVAL %X))))
13600		(GO %L))) 
13700	FEXPR)
13800	
13900	(DEFPROP GRINL 
14000	 (LAMBDA(%L)
14100	  (PROG NIL
14200		(PRINT (LIST (QUOTE SETQ) (QUOTE IBASE) (LIST (QUOTE ADD1) (SUB1 BASE))))
14300		(TERPRI)
14400		(EVAL (CONS (QUOTE GRINDEF) (CONS (CAR %L) (EVAL (CAR %L))))))) 
14500	FEXPR)
14600	
14700	(DEFPROP TIMER 
14800	 (LAMBDA(%L)
14900	  (PROG (%TIME %CONS %GC)
15000		(GC)
15100		(SETQ %TIME (TIME NIL))
15200		(SETQ %CONS (SPEAK))
15300		(SETQ %GC (GCTIME))
15400		(MAPC (FUNCTION EVAL) %L)
15500		(DPRINT
15600		 (LIST (*DIF (TIME NIL) %TIME)
15700		       (QUOTE MSEC)
15800		       (*DIF (SPEAK) %CONS)
15900		       (QUOTE CONSES)
16000		       (*DIF (GCTIME) %GC)
16100		       (QUOTE GCTIME))))) 
16200	FEXPR)
16300	
16400	(DEFPROP DPRINT 
16500	 (LAMBDA (X) (PROG (BASE) (SETQ BASE 12) (RETURN (PRINT X)))) 
16600	EXPR)
16700	
16800	(DEFPROP OUTTIME 
16900	 (LAMBDA NIL
17000	  (PROG (X BASE *NOPOINT)
17100		(SETQ *NOPOINT T)
17200		(SETQ BASE 12)
17300		(TERPRI)
17400		(PRINC (QUOTE LISP-OUTPUT/ / ))
17500		(SETQ X (*QUO (UUO 23) 165140))
17600		(PRIN1 (*QUO X 74))
17700		(PRIN1 (QUOTE :))
17800		(PRIN1 (REMAINDER X 74))
17900		(PRINC (QUOTE / / ))
18000		(SETQ X (UUO 14))
18100		(PRIN1 (ADD1 (REMAINDER X 37)))
18200		(PRINC (QUOTE /-))
18300		(SETQ X (*QUO X 37))
18400		(PRIN1
18500		 (CDR
18600		  (ASSOC (REMAINDER X 14)
18700			 (QUOTE
18800			  ((0 . JAN) (1 . FEB)
18900				     (2 . MAR)
19000				     (3 . APR)
19100				     (4 . MAY)
19200				     (5 . JUN)
19300				     (6 . JUL)
19400				     (7 . AUG)
19500				     (10 . SEP)
19600				     (11 . OCT)
19700				     (12 . NOV)
19800				     (13 . DEC))))))
19900		(PRINC (QUOTE /-))
20000		(SETQ X (*QUO X 14))
20100		(PRIN1 (PLUS X 100))
20200		(TERPRI)
20300		(TERPRI))) 
20400	EXPR)
20500	
20600	(DEFPROP UUO 
20700	 (LAMBDA(N)
20800	  (PROG NIL
20900		(PUTPROP (QUOTE UUO) (NUMVAL BPORG) (QUOTE SUBR))
21000		(DEPOSIT BPORG (PLUS 260600000000 (GET (QUOTE NUMVAL) (QUOTE SYM))))
21100		(DEPOSIT (ADD1 BPORG) 47041000000)
21200		(SETQ BPORG (PLUS BPORG 3))
21300		(DEPOSIT (SUB1 BPORG) (PLUS 254000000000 (GET (QUOTE FIX1A) (QUOTE SYM))))
21400		(RETURN (UUO N)))) 
21500	EXPR)
21600	
21700	(DEFPROP EDIT 
21800	 (LAMBDA(%%L)
21900	  (PROG (%%A %%X %%P)
22000		(SETQ %%A (CAR %%L))
22100		(COND ((SETQ %%X (GET %%A (QUOTE EXPR))) (SETQ %%P (QUOTE EXPR)) (GO L1))
22200		      ((SETQ %%X (GET %%A (QUOTE FEXPR))) (SETQ %%P (QUOTE FEXPR)) (GO L1))
22300		      (T (SETQ %%X (SUBST 0 0 (CADDR %%A))) (SETQ %%P (CADR %%A))))
22400	   L1   (SETQ %%P (PUTPROP %%A (SUBST (CADDR %%L) (CADR %%L) %%X) %%P))
22500		(RETURN (NOT (EQUAL %%P %%X))))) 
22600	FEXPR)
22700	
22800	(DEFPROP DEVP 
22900	 (LAMBDA (X) (OR (EQ (CAR (LAST (EXPLODE X))) (QUOTE :)) (AND (NOT (ATOM X)) (NOT (ATOM (CDR X)))))) 
23000	EXPR)
23100	
23200	(DEFPROP ALLFNS 
23300	 (NIL) 
23400	VALUE)
23500	
23600	(DEFPROP ALLVALUES 
23700	 (NIL) 
23800	VALUE)
23900	
24000	(DEFPROP LPTLENGTH 
24100	 (NIL . 160) 
24200	VALUE)