Google
 

Trailing-Edge - PDP-10 Archives - decuslib10-01 - 43,50073/lisp.lsp
There are 5 other files named lisp.lsp in the archive. Click here to see a list.
00010	(DEFPROP %DEFIN
00020		 (LAMBDA (X V F P)
00030			 (PROG (R)
00040			       (SETQ R (COND ((GETL X
00050						    (QUOTE (EXPR FEXPR
00060								 SUBR
00070								 FSUBR
00080								 LSUBR
00090								 MACRO)))
00100					      (LIST X (QUOTE Redefined)))
00110					     (T X)))
00120			       (PUTPROP X (LIST (QUOTE LAMBDA) V F) P)
00130			       (RETURN R)))
00140		 EXPR)
00150	
00160	(DEFPROP DE
00170	 (LAMBDA (L) (%DEFIN (CAR L) (CADR L) (CADDR L) (QUOTE EXPR)))
00180	 FEXPR)
00190	
00200	(DEFPROP DF
00210	 (LAMBDA (L) (%DEFIN (CAR L) (CADR L) (CADDR L) (QUOTE FEXPR)))
00220	 FEXPR)
00230	
00240	(DEFPROP DM
00250	 (LAMBDA (L) (%DEFIN (CAR L) (CADR L) (CADDR L) (QUOTE MACRO)))
00260	 FEXPR)
00270	
00280	(DEFPROP PLUS (LAMBDA (L) (*EXPAND L (QUOTE *PLUS))) MACRO)
00290	
00300	(DEFPROP DIFFERENCE (LAMBDA (L) (*EXPAND L (QUOTE *DIF))) MACRO)
00310	
00320	(DEFPROP TIMES (LAMBDA (L) (*EXPAND L (QUOTE *TIMES))) MACRO)
00330	
00340	(DEFPROP QUOTIENT (LAMBDA (L) (*EXPAND L (QUOTE *QUO))) MACRO)
00350	
00360	(DEFPROP LESSP
00370	 (LAMBDA (L)
00380	  (LIST	(QUOTE *LESS)
00390		(*EXPAND1 (CDR (REVERSE (CDR L)))
00400			  (QUOTE (LAMBDA (X Y)
00410					 (COND ((AND X (*LESS X Y)) Y)))))
00420		(CAR (LAST L))))
00430	 MACRO)
00440	
00450	(DEFPROP GREATERP
00460	 (LAMBDA (L)
00470	  (LIST	(QUOTE *GREAT)
00480		(*EXPAND1 (CDR (REVERSE (CDR L)))
00490			  (QUOTE (LAMBDA (X Y)
00500					 (COND ((AND X (*GREAT X Y)) Y)))))
00510		(CAR (LAST L))))
00520	 MACRO)
00530	
00540	(DEFPROP %DEVP
00550		 (LAMBDA (X)
00560			 (OR (EQ (CAR (LAST (EXPLODE X))) (QUOTE :))
00570			     (AND (NOT (ATOM X)) (NOT (ATOM (CDR X))))))
00580		 EXPR)
00590	
00600	(DE %READCHAN (%CHAN %TALK)
00610		      (PROG (%OLDCHAN %SEXPR)
00620			    (SETQ %OLDCHAN (INC %CHAN NIL))
00630		       LOOP (SETQ %SEXPR (ERRSET (READ)))
00640			    (COND ((EQ (CAR %SEXPR) (QUOTE COMMENT))
00650				   (PROG (%XCH)
00660					A
00670					(SETQ %XCH (READCH))
00680					(AND (EQ %XCH (QUOTE /;))
00690					     (RETURN))
00700					(GO A) )
00710				   (GO LOOP)) )
00720			    (COND ((ATOM %SEXPR) (GO END)))
00730			    (SETQ %SEXPR (EVAL (CAR %SEXPR)))
00740			    (COND (%TALK (PRINT %SEXPR)))
00750			    (GO LOOP)
00760		       END  (INC %OLDCHAN T)
00770			    (RETURN NIL)))
00780	
00790	(DE %READAFILE (%DEV %FNAM %TALK)
00800	 (%READCHAN (EVAL (LIST (QUOTE INPUT) (GENSYM) %DEV %FNAM)) %TALK))
00810	
00820	(DE READIN (%DEV %FLIST %TALK)
00830	    (PROG NIL
00840	     LOOP (COND	((NULL %FLIST) (RETURN (QUOTE Finished-Loading)))
00850			((%DEVP (CAR %FLIST)) (SETQ %DEV (CAR %FLIST))
00860					      (SETQ %FLIST (CDR %FLIST))
00870					      (GO LOOP)))
00880		  (%READAFILE %DEV (CAR %FLIST) %TALK)
00890		  (SETQ %FLIST (CDR %FLIST))
00900		  (GO LOOP)))
00910	
00920	
00930	(DF DSKIN (%L) (READIN (QUOTE DSK:) %L T))
00940	
00950	(DF SYSIN (%L) (READIN (QUOTE SYS:) %L NIL))
00960	
00970	(DEFPROP PUTSYM
00980	 (LAMBDA (L)
00990	  (MAPCAR (FUNCTION (LAMBDA (X)
01000			     (COND ((ATOM X) (*PUTSYM X X))
01010				   (T (*PUTSYM (CAR X) (EVAL (CADR X)))))))
01020		  L))
01030	 FEXPR)
01040	
01050	(DEFPROP GETSYM
01060	 (LAMBDA (L)
01070	  (MAPCAR
01080	   (FUNCTION (LAMBDA (X)
01090		      (PROG (V)
01100			    (SETQ V (*GETSYM X))
01110			    (COND (V (PUTPROP X (NUMVAL V) (CAR L)))
01120				  (T (PRINT (CONS X
01130						  (QUOTE (Not in
01140							      Symbol
01150							      Table))))))
01160			    (RETURN V))))
01170	   (CDR L)))
01180	 FEXPR)
01190	
01200	
01210	(DF BREAK (%LL%)
01220		  (PROG (%EX% %ICH% %OCH%)
01230			(SETQ %ICH% (INC NIL NIL))
01240			(SETQ %OCH% (OUTC NIL NIL))
01250			(PRINT (CONS (QUOTE *Break*) (CAR %LL%)))
01260		   LOOP	(TERPRI)
01270			(SETQ %EX% (ERRSET (READ)))
01280			(COND ((ATOM %EX%) (GO LOOP)))
01290			(COND ((EQ (CAR %EX%) *BPROCEED*) (GO END)))
01300			(ERRSET (PRIN1 (EVAL (CAR %EX%))))
01310			(GO LOOP)
01320		   END	(INC %ICH% NIL)
01330			(OUTC %OCH% NIL)
01340			(RETURN (EVAL (CADR %LL%)))))
01350	
01360	(SETQ *BPROCEED* (QUOTE P))
01370	
01380	(PROG (EX)
01390	      (SETQ EX (QUOTE (LAMBDA (L)
01400			       (PROG2 (SYSIN LAP)
01410				      (LIST (QUOTE QUOTE) (EVAL L))))))
01420	      (MAPC (FUNCTION (LAMBDA (X) (PUTPROP X EX (QUOTE MACRO))))
01430		    (QUOTE (DEFSYM LAP OPS))))
01440	
01450	(PROG (EX)
01460	      (SETQ EX (QUOTE (LAMBDA (L)
01470			       (PROG2 (SYSIN (LISP.SOS))
01480				      (LIST (QUOTE QUOTE) (EVAL L))))))
01490	      (MAPC (FUNCTION (LAMBDA (X) (PUTPROP X EX (QUOTE MACRO))))
01500		    (QUOTE (EDFUN FILEIN))))
01510	
01520	(PROG (EX)
01530	      (SETQ EX (QUOTE (LAMBDA (L)
01540			       (PROG2 (SYSIN TRACE)
01550				      (LIST (QUOTE QUOTE) (EVAL L))))))
01560	      (MAPC (FUNCTION (LAMBDA (X) (PUTPROP X EX (QUOTE MACRO))))
01570		    (QUOTE (TRACE UNTRACE
01580				  TRACET
01590				  UNTRACET
01600				  SLST
01610				  UNSLST
01620				  RESET))))
01630	
01640	(DF COMMENT (L) NIL)
01650	
01660	(DF DECLARE (L) (MAPC (FUNCTION EVAL) L))
01670	
01680	(SETQ EIGHT (ADD1 7))
01690	
01700	(SETQ TEN (PLUS 2 EIGHT))
01710	
01720	(DE OCTAL NIL (SETQ BASE (SETQ IBASE EIGHT)))
01730	
01740	(DE DECIMAL NIL (SETQ BASE (SETQ IBASE TEN)))
01750	
01760	(DF DEFBLOCK (L)	 L= (BlockProg OutputFile DefiningFile)
01770	 (PROG	(A B)
01780		(SETQ A BPORG)
01790		(EVAL (CONS (QUOTE DSKIN) (CDDR L)))	 A Lap file.
01800		(WRBLK (CADR L) A (SETQ B (SUB1 BPORG))) Name  A:B
01810		(PUTPROP (CAR L) (CADR L) (QUOTE FILEN))
01820		(SETQ BLKIN (CAR L))
01830		(SETQ BPORG A)
01840		(RETURN (ADD1 B))))
01850	
01860	(DF EXECBLOCK (P)	 P= (BlockProg ...Args...)
01870	 (PROG	(FILEN)
01880		(COND	((EQ (CAR P) BLKIN) (GO L))
01890			((SETQ FILEN (GET (SETQ BLKIN (CAR P))
01900					  (QUOTE FILEN))))
01910			(T (PRINT (QUOTE Block-Not-Def)) (ERR)))
01920		(RDBLK FILEN NIL)	 NIL- DSK:,  T- SYS:
01930	  L	(RETURN (EVAL P))))
01940	
01950	
01960	
01970	
01980	(PROG NIL (INC NIL T)
01990		  (OUTC NIL T)
02000		  (PRINC (QUOTE "
02010	Stanford Lisp 1.6 (Utah version) 1-May-73"))
02020		  (COND ((ERRSET (INPUT INITCHAN DSK: (LISP . INI)) NIL)
02030			 (%READCHAN (QUOTE INITCHAN) NIL)))
02040		  (INC NIL T)
02050		  (OUTC NIL T)
02060		  (EXCISE)
02070		  (CSYM G0000)
02080		  (BAKGAG T)
02090		  (NOUUO T)
02100		  (ERR))