reduce-historical/r30/lisp.mac

;LISP.MAC, 9-Apr-81 21:51, Edit by FRICK
;
;NUMVAL redefined. It now gives error if given anything but INUM or FIXNUM.

;LISP.MAC, 26-Sep-80 10:44, Edit by FRICK
;
;%FSLID defined as support for PRELOAD facility.

;LISP.MAC, 25-Aug-80 12:06, Edit by FRICK
;
;Make ^Z comments work inside other comments.

;Corrected bug in initial dialogue. SYLO+1 is CAILE C,"z" instead
; of CAIG C,"z"

;<FRICK>LISP.MAC.28, 22-Nov-79 15:31:17, Edit by FRICK
;
;Define ERJMP for Tenex. Don't include RSCAN for Tenex.

;<FRICK>LISP.MAC.27, 21-Nov-79 11:21:50, Edit by FRICK
;
;Corrected bug in FUNARG. APFNG+6 is MOVN R,APFNG1 instead of HRRZ R,APFNG1.

;<FRICK>LISP.MAC.26, 13-Nov-79 19:48:53, Edit by FRICK
;
;Convert lower case to upper case on answer to start up questions

;<FRICK>LISP.MAC.24, 11-Nov-79 16:46:11, Edit by FRICK
;
;REMD now returns NIL or the removed type . function, as in Standard Lisp.
;Corrected bug in errormessage for index error in GETV, PUTV.
;PROG2 is again a defined function.

;<FRICK>LISP.MAC.20,  8-Nov-79 19:33:42, Edit by FRICK
;
;Added code for new FASLOD. Switches OFLD and NFLD controls assembling
; of new FASLOD and old FASLOAD. Both might be on at the same time.

;<FRICK>LISP.MAC.3,  1-Nov-79 16:26:25, Edit by FRICK
;
;For high core BPS in Tops-10 now computes start of high core.
;
;Fix bug in XEQ by guaranteeing 0 at end of RSCAN string.

;<FRICK>LISP.MAC.1, 28-Oct-79 16:06:56, Edit by FRICK
;
;An atom as first argument to FILEP means a filename for a file on DSK:
; with blank extension.
;
;XEQnow clears the terminal input buffer before simulating terminal
; input.

;<FRICK>LISP.MAC.4, 26-Oct-79 12:32:56, Edit by FRICK
;
;The charcters "+", "-" and "'" are now preceded by a "!" in PRIN1 and
; EXPLODE.

;<FRICK>LISP.MAC.2,  9-Oct-79 12:59:52, Edit by FRICK
;
;EOF is now signaled by returning the value of the interned id $EOF$.
;This value is originally the uninterned id $EOF$, but it can be
; changed.
;
;Cange of edit of 27-Mar-79. TYI (and READCH) now ignores null.

;<FRICK>LISP.MAC.16, 12-Sep-79 13:07:31, Edit by FRICK
;
;READ does now read negative bignums without dropping the minus sign
;
;When using high core in Tops-10, preserves high core data area.

;<FRICK>LISP.MAC.12, 16-Aug-79 16:13:29, Edit by FRICK
;
;BPS in high core now allowed also in Tops-10. 
;Assembler switch SZBPS decides whether size of BPS is user settable.
;SZBPS is allways on if HCBPS is off. EXCORE only defined when SZBPS is
;on.
;
;Function EVLIS now defined.

;<FRICK>LISP.MAC.29,  2-Jul-79 15:11:01, Edit by FRICK
;
;Corrected bug in EQUAL so that EQUAL may return T for vectors.

;<FRICK>LISP.MAC.26, 15-Jun-79 19:08:49, Edit by FRICK
;
;The UUO handler changed to allow UUOs to be executed via a XCT.
;The MAPping functions have been changed to use this.

;<FRICK>LISP.MAC.19,  9-Jun-79 13:39:56, Edit by FRICK
;
;Included "T" and "?" in IDCHTAB.

;<FRICK>LISP.MAC.16, 29-May-79 18:40:20, Edit by FRICK
;
;Corrected error at XTYO so that character count now is reset at CR when
; echoing and TYO treats ascii 37 correctly.

;<FRICK>LISP.MAC.12, 23-May-79 23:07:49, Edit by FRICK
;
;The assembler switch APPL is defined. When on (off by default), EVAL
; return its arg when undefined function or unbound variable.

;<FRICK>LISP.MAC.11, 21-May-79 10:22:03, Edit by FRICK

;
;%SOSSWAP is now under assembler switch SOSSW that is off by default

;<FRICK>LISP.MAC.9, 17-May-79 15:29:09, Edit by FRICK
;
;%SOSSWAP and %SWAP only defined if OPSYS is > 0 (TENEX)
;
;If switch JSYXEQ is on then functions JSYS, %XEQ, ERRSTR and GETAB$ are defined

;<FRICK>LISP.MAC.7, 10-May-79 14:43:10, Edit by FRICK
;
;EOL conversion is now only done on input, not in READ0 routine used by
; COMPRESS or internal string reader READP1.
;The EOL conversion has further been changed so that CR, LF and FF are 
; converted as follows:
; a CR is ignored if the next character is LF, FF or CRLF,
; a LF is converted to CRLF,
; a FF is converted to CRLF followed by FF.

;<FRICK>LISP.MAC.3,  4-May-79 18:12:32, Edit by FRICK
;
;Change unsafe BLT in ARGPDL

;<FRICK>LISP.MAC.16, 17-Apr-79 13:52:39, Edit by FRICK
;Call GET jsys as JSYS 200 to avoid name clash. Use SAV or EXE depending
; on OPSYS switch.

;<FRICK>LISP.MAC.15,  9-Apr-79 13:48:00, Edit by FRICK
;
;Removed <ht> in macro ML1 that gives problems in older MACRO versions

;<FRICK>LISP.MAC.14,  1-Apr-79 16:15:23, Edit by FRICK
;
;This file has been renumbered.

;<FRICK>LISP.MAC.13, 29-Mar-79 15:14:41, Edit by FRICK
;
;If the argument to FREEZE is true then the special stack is unbound
; to top level before halting. FREEZE checks if memory allocation is
; necessary when restarting if the argument is true.

;<FRICK>LISP.MAC.12, 27-Mar-79 18:00:20, Edit by FRICK
;
;The TYI routine now reads all characters exept ^Z but including % and 
; null. This means that READCH reads % and null.

;<FRICK>LISP.MAC.5, 13-Mar-79 17:37:43, Edit by FRICK
;
;RDSLSH now knows about %. (RDSLSH T) sets % to be a normal letter,
; (RDSLSH NIL) sets % to be comment start.

;<FRICK>LISP.MAC.4, 12-Mar-79 16:31:30, Edit by FRICK
;
;Corrected bug in sixbit messages generated by prevoious edit, now 
; generates EOL output again.
;
;*ECHO flag is now tested before *RAISE flag so that the status of
; *RAISE doesn't affect the echoed character.
;
;Corrected bug in MAPCAN, MAPCON: They now work also when NIL is 
; returned as value by the applied function.

;<FRICK>LISP.MAC.26, 13-Feb-79 15:25:31, Edit by FRICK
;
;The character strings CR LF and CR FF are now replaced with the single
; character CRLF (ascii 37) in the routine TYID that does all input.
;CRLF is converted back to CR and LF in the internal routine TYO that
; does all output. The only exeption to this is the Lisp function TYO,
; (TYO 37) still will output a ascii 37.
;$EOL$ has as value the character id CRLF, so that READCH now returns
; the value of $EOL$ at end of line and PRINC $EOL$ is equivalent to
; TERPRI.
;SCAN now returns an interned character id in SCNVAL when seeing a
; delimiter. Because of this, UNTYI is replaced with UNREADCH that is
; similar but takes a character id as argument instead of ascii code.
;
;% now indicates start of a comment that ends with CRLF. Everything from
; % to (but not including) CRLF will be transparent to READ but not to
; READCH. SCAN has initially the same start and end of comment as READ
; and it will also not ignore the comment end character. As a consequence
; a comment can only be placed where a CRLF is legal. The special
; comment that starts with a ^Z and ends with CRLF does ignore the CRLF
; so that it can be placed anywhere.
;
;(AND) returns T.

;<FRICK>LISP.MAC.6, 31-Jan-79 14:03:36, Edit by FRICK
;
;READCH and EXPLODE are speeded up by maintaining an array of all
; interned character ids. This array is initially zero, but it is
; updated by INTERN and REMOB.

;<FRICK>LISP.MAC.4, 29-Jan-79 17:37:09, Edit by FRICK
;
;EXPLODE, READ (and COMPRESS) checks that they have the right scanner
; table and temporarily switches table if necessary. If an error occurs,
; this will leave the tables as if (SCANSET NIL) had been executed.

;<FRICK>LISP.MAC.1, 25-Jan-79 14:41:23, Edit by FRICK
;
;Corrected bug in EVAL when calling compiled EXPR with more than 5 args.

;<FRICK>LISP.MAC.13,  3-Jan-79 17:48:17, Edit by FRICK
;
;The use of L as indicator of octal numbers is now controlled by the
; switch ROCT. If ROCT is on then the change in edit of 26-Nov-78 is
; implemented, otherwise it is not.
;
;The symbol ILLAD is defined as the illegal address that generates a garbage
; collection. Setting it to 775777 (-2001) instead of 777777 (-1) seems to
; allewiate the problems mentioned in edit 25-Oct-78. For this reason
; CNSPRB is off by default in all versions of the system.
;
;The ^Z that indicates an ignored cr-lf is now not output if output is
; going to the terminal.
;
;The HALT that ended FREEZE in the Tops-10 version, is changed to EXIT 1, .

;<FRICK>LISP.MAC.7, 26-Nov-78 19:55:50, Edit by FRICK
;
;A number ended by the letter L, is read as an octal number also when
; the value of IBASE is not 8. When the value of BASE is 8, then end
; integers whith L when printed by PRIN1 but not when printed by PRIN2.

;<FRICK>LISP.MAC.1,  8-Nov-78 18:59:12, Edit by FRICK
;
;An atom as first argument to OPEN means a filename for a file on DSK:
; with blank extension.

;<FRICK>LISP.MAC.29,  3-Nov-78 17:15:24, Edit by FRICK
;
;Define SYM entry LMKSTR to make a Lisp string from top of SPDL

;<FRICK>LISP.MAC.28,  1-Nov-78 18:11:11, Edit by FRICK
;
;Make SETPCHAR return previous prompter as a non-interned identifier

;<FRICK>LISP.MAC.25, 25-Oct-78 19:10:13, Edit by FRICK
;
;Define an assembler switch CNSPRB, that when on will insert two instructions
; in the cons routine. These instructions will check explicitly for end
; of the free list instead of detecting the need for garbage collection
; by an illegal memory reference that occurs when the free list is empty.
; Explicit checking is slightly slower, but there seems to be some problems
; with the illegal memory reference mechanism on some virtual memory
; versions of the Tops-10 monitor.

;<FRICK>LISP.MAC.24, 26-Sep-78 16:38:51, Edit by FRICK
;
;Garbage collector now marks from reg REL also.

;<FRICK.SLSHEEP>LISP.MAC.2, 24-Sep-78 16:38:49, Edit by FRICK
;
;Declare some more symbols internal.

;<FRICK>LISP.MAC.17, 18-Sep-78 19:22:04, Edit by FRICK
;
;Fix bug in GCGAG output, so that it works also when number of cells
; collected are more than an INUM.

;<FRICK>LISP.MAC.11,  3-Sep-78 17:11:44, Edit by FRICK
;
;LINELENGTH now checks that its argument is NIL or greater than 0.
;PAGELENGTH now checks that its argument is NIL or greater than or equal to 0.
;
;DIGIT and LITER now returns NIL if their argument is not an
; interned id with a one character print name.

;<FRICK>LISP.MAC.7, 27-Aug-78 15:44:35, Edit by FRICK
;
;The ERROR print routine (also used by WARNING) doesn't relay any
;more on register T being saved. The stack is used instead.

;<FRICK>LISP.MAC.6, 24-Aug-78 16:53:44, Edit by FRICK
;(EQUAL 1 1.0) now returns NIL instead of T.
;
;The first argument to REMFLAG is a list whose elements now not
; have to be ids. REMFLAG does nothing for those that aren't ids.
;
;SUBR and FSUBR are now completely replaced by EXPR and FEXPR.
;For compatibility reason FASLOD will convert (F)SUBR to (F)EXPR and
;give a message about it the end of each load.
;
;Digits in DIGIT, EXPLODE and READCH are now character ids, not INUMs.
;
;The initialization file LISP.LSP is renamed to LISP.SL.

;<FRICK>LISP.MAC.2, 20-Aug-78 18:10:26, Edit by FRICK
;
;Make PATOM available as a SUBR.

;<FRICK>LISP.MAC.254,  1-Aug-78 17:49:50, Edit by FRICK
;
;Define Fasload type 11 to be similar to 13 but the codepointer
; is put on the property list with PUT instead of PUTD.

;<FRICK>LISP.MAC.252, 27-Jul-78 18:53:43, Edit by FRICK
;
;Make ERREx print the left half of register A if it isn't 0.
;This involves a change to PRINL also.
;Make a small change to PRINEL and remove PRIN1B that now is unnecessary.

;<FRICK>LISP.MAC.250, 25-Jul-78 23:52:04, Edit by FRICK
;
;Include this list of changes and renumber pages.

;<FRICK>LISP.MAC.245, 22-Jul-78 19:46:45, Edit by FRICK
;
;Set *ERRMSG to T on toplevel only if it is NIL.
;
;Make the OP routine (i.e. all binary numerical routines) check
;first that the arguments are numbers so that the error message
;"x IS NOT A NUMBER" gets the right "x".
;
;The garbage collector now also marks from the top element of
;the SPDL.

;<FRICK>LISP.MAC.238, 14-Jul-78 13:50:27, Edit by FRICK
;
;RETURN and GO now works in other than the last statement in
;a PROGN.
;
;SKIPTO now initialize register AR4 so that it doesn't think
;everything is EDIT or SOS line numbers.

;<FRICK>LISP.MAC.237, 10-Jul-78 01:21:58, Edit by FRICK
SUBTTL HISTORY OF CHANGES			--- PAGE 1
;
;COPYRIGHT (C) 1979 University of Utah.
;
;Permission to copy without fee all or part of this material is granted
;provided that copies are not made or distributed for direct commercial
;advantage, the Utah copyright notice  and the title of the program and
;its date appear, and notice  is given that copying is by permission of
;the University of Utah. To copy otherwise, or to republish, requires a
;fee and/or specific permission.
;
SUBTTL 	AC DEFINITIONS AND EXTERNALS		--- PAGE 2
TITLE	LISP INTERPRETER						


COMMENT 	TABLE OF CONTENTS

 1.	History of changes
 2.	Assembling switches, AC Definitions, Symbols and Externals
 3.	Top Level and Initialization
 4.	APR Interrupt routines
 5.	UUO Handler and SUBR-call routines
 6.	ERROR Handler and Backtrace
 7.	TYI and TYO
 8.	INPUT and OUTPUT initialization and control
 9.	PRINT
10.	READ and SCANner tables
11.	Interpretive routines of LISP
12.	Arithmetic routines
13.	Bignum routines
14.	Gfpak. Galois field package
15.	EXPLODE, READLIST, FLATSIZE, etc.
16.	EVAL and APPLY and bindings
17.	ARRAY, EXARRAY, STORE
18.	EXAMINE, DEPOSIT, BOOLE
19.	Garbage Collector
20.	GETSYM, PUTSYM and R50MAK
21.	FASLOAD, FASLOD
22.	ED - Alvine
	LOAD
	EXCISE, MORCOR, MOVSYM, etc.
23.	FILEP
	SOSSWAP
	JSYS, GETAB#, XEQ
24.	RBLK, WBLK
25.	CORE, ALLOC
26.	SETSYS, LSSAVE
27.	Re-allocate code after a ST
	REHASH
28.	Lisp atoms and initial OBLIST
	BPS, FS, FWS
29.	Once-only Lisp Storage Allocator

PAGE
COMMENT 	General differences from Stanford's 1.6 are:

  1)  Octal ppns,
  2)  Explicit i/o for SOS-linkage,
  3)  The '*' prompt-char can be dynamically changed, to
			consist of up to 4 characters;
  4)  The subr CORE(n) is used to increase (or partially cut) core;
  5)  The subr ALLOC() just goes to LISPGO to alloc new core;
  6)  Altmode can be typed as 33 or 175.
  7)  Binary-I/O (36-bit) by INBIN,OUTBIN,BINI,BINO.
  8)  BPS & EXAMINE,DEPOSIT may address to 256K, vs old 64K limit.
  9)  RBLK,WBLK can manipulate overlay-blocks in BPS as files.

Assembles for TOPS-20, TENEX or TOPS-10, operating systems
 depending on the setting of the variable OPSYS.
 N.B.  Code for TENEX and TOPS-20 in CHKACS, CHKAC0, SETAPR 
	 makes assumptions about PA1050's acc and ^O handler locations.
OPSYS is set here 
;OPSYS==0		;Assembles for TOPS-10.
;OPSYS==1		;Assembles for TENEX
OPSYS==-1		;Assembles for TOPS-20.
IFNDEF OPSYS,<OPSYS==-1>	;TOPS-20 is default

	;When OPSYS not is zero, this has the following effects:
		; 1)  The 10x psi is enabled for 10/50 ^O (simulated);
		; 2)  The swapout for the SOS-link is done as an inferior fork,
		;	which returns to LISPGO, unless using LISP.TNX patchs.
		; 3)  The initial start-up questions are slightly changed.

;SYDEV==1	;When on has the following effects:
		; 1) An initial question for system device or directory
		;     to use as SYS: device:
		;     For TENEX version asks for system directory number
		;	(default: number for <REDUCE>, or if that not
		;        exists, the users directory).
		;     For TOPS-10 or -20 version asks for system device 
		;      name (default: SYS: ).
		; 2) The subr SETSYS is used to dynamically change SYS: .

;CNSPRB==1		;When on, will check explicitly for the end of the free list,
			; instead of detecting it by an illegal memory reference.
;STL==0			;When on, will assemble for Standard Lisp
;OCTPPN==0		;When off, will assemble for SU-AI's PPNs.
MOD==1			;When on, will assemble GFPAK modular arithmetics
;ALOD==1  		;When on will assemble LOAD, *PUTSYM and *GETSYM.
;AED==1			;When on will assemble ED and GRINDEF interface.
;NFLD==0		;When off dont assemble new FASLOD
OFLD==1  		;When on, assemble old FASLOAD
;RWB==1			;When on will assemble WBLK and RBLK.
;ASARY==1		;When on will assemble array routines
EPDL==0                 ;When on, will create a 3rd pdl pointed to by EP
;FNRG==0  		;When on, will assemble funarg features
;HCBPS==1		;When on puts BPS in high core
;SZBPS==1		;When on, size of BPS is user decidable, and EXCORE defined.
;ROCT==1		;When on will read an integer followed by L as octal
;JSYXEQ==0		;When off, will not define JSYS, %XEQ, ERRSTR and GETAB$
;SOSSW==1		;When on assembles %SOSSWAP, used by SOSLINK
;APPL==1 		;When on, EVAL returns arg when undefined
PAGE
;Default values for switches

IFE OPSYS,<IFNDEF HCBPS,HCBPS==0	;(Default low core for 10/50)
	IFNDEF SZBPS,SZBPS==1
 IF1,PRINTX   Note: being assembled for TOPS-10, not TENEX or TOPS-20.  
	   SEARCH UUOSYM
	JSYXEQ==0	; JSYSes not defined in TOPS-10
 IFNDEF OCTPPN,<
	   OCTPPN==1
  IF1,PRINTX   Note: if for SU-AI, reassemble with OCTPPN==0   >>

IFN OPSYS,<IFNDEF HCBPS,HCBPS==1     ;(Default high core 400000:676776)
	   IFNDEF SZBPS,SZBPS==0
	   OCTPPN==1	>	;Permit (0,nnn) format if desired.

IFL OPSYS,<SEARCH MONSYM
 IF1,PRINTX  Note: being assembled for TOPS-20, not TENEX or TOPS-10.  >

IFG OPSYS,<SEARCH STENEX
	OPDEF	ERJMP	[JUMP	16,]
 IF1,PRINTX   Note: being assembled for TENEX, not TOPS-10 or TOPS-20. >

IFNDEF STL,<STL==1>

IFN STL,<
IFNDEF AED,AED==0
IFNDEF ALOD,ALOD==0
IFNDEF RWB,RWB==0
IFNDEF ASARY,ASARY==0>

IFNDEF SYDEV,<SYDEV==1>		;Default: SYDEV is on.
IFNDEF CNSPRB,<CNSPRB==0>
IFNDEF MOD,<MOD==0>
IFNDEF ALOD,<ALOD==1>
IFNDEF AED,<AED==1>
IFNDEF RWB,<RWB==1>
IFNDEF ASARY,<ASARY==1>
IFNDEF NFLD,<NFLD==1>
IFNDEF OFLD,<OFLD==0>
IFNDEF EPDL,<EPDL==0>
IFNDEF APPL,<APPL==0>
IFNDEF FNRG,<FNRG==1>
IFNDEF HCBPS,HCBPS==1
IFNDEF SZBPS,SZBPS==1
IFE HCBPS,SZBPS==1
IFNDEF ROCT,<ROCT==0>
IFNDEF JSYXEQ,<JSYXEQ==1>
IFNDEF SOSSW,<SOSSW==0>
PAGE
TEN==^D10
INUMIN=377777		;Lower limit of INUMs.
BCKETS==77
INITBPS== 2000		;Initial (default) size of BPS.
INITCORE==^D12*2000-1	;Initial (default) size of Lisp core .
MAXCORE==^D124		;Maximum size of Lisp core, to allow for I/O buffers.
MINFBPS==1000		;Necessary BPS for Fap bootstrap fisltable
BOTBPS==1320		;Necessary BPS for Fap loaded functions
ILLAD==775777		;Illegal address to generate interrupt when free list exhausted.

;Atom type tags
ID=1000000-1		;identifier
CODE=ID-1		;code pointer
CODMIN==CODE
VECT=CODE-1		;vector
STRNG=VECT-1		;string
FLONU=STRNG-1		;floating point number
FIXNU=FLONU-1		;single word integer
POSNU=FIXNU-1		;positive bignum.  Must be odd
NEGNU=POSNU-1		;negative bignum
ATMIN=NEGNU-1		;addresses bigger than this, are atom tags.

INUM0=1+<INUMIN+ATMIN>/2
IFN <ATMIN+INUMIN-2*INUM0>,<INUMIN=INUMIN+1>
DEFINE PR%%IN (XX)<
PRINTX Maximum INUM modulus is XX
>
IF1,<XX==ATMIN-INUM0
PR%%IN \XX >
PAGE
;Accumulator definitions
;'sacred' means sacred to the interpreter
;'marked' means marked from right and left half by the garbage collector
;'protected' means protected during garbage collection

NIL=0	;sacred, marked, protected	;atom head of NIL
A=1	;marked, protected	;results of functions and first arg of subrs
B=A+1	;marked, protected	;second arg of subrs
C=B+1	;marked, protected	;third arg of subrs
AR4=4	;marked, protected	;fourth arg of subrs	(old AR1)
AR5=5	;marked, protected	;fifth arg of subrs	(old AR2A)
T=6	;marked, protected	;minus number of args internaly
TT=7	;marked, protected
REL=10	;marked, protected	;rarely used
IFE EPDL,<
EP==14
S=11	>
IFN EPDL,<
S==11
EP=11	;sacred, protected	;exp push down stack pointer >
D=12	
R=13	;	 protected
P=14	;sacred, protected	;regular push down stack pointer
F=15	;sacred			;free storage list pointer
FF=16	;sacred			;full word list pointer
SP=17	;sacred, protected	;special pushdown stack pointer

NACS==5		;number of argument acs
NSUA==16	;maximum number of subr arguments

X==0	;X indicates impure (modified) code locations


;  Added Inst-definitions for legibility...

OPDEF	PCALL	[PUSHJ	P,]
OPDEF	PRET	[POPJ	P,]
OPDEF	PSAVE	[PUSH	P,]
OPDEF	PREST	[POP	P,]
OPDEF	PSKPRT	[AOS	(P)]
OPDEF	P1DROP	[SUB	P,[1,,1]]
OPDEF	P2DROP	[SUB	P,[2,,2]]
OPDEF	P3DROP	[SUB	P,[3,,3]]
OPDEF	PXDROP	[SUB	P,]
OPDEF	CARA	[HLRZ	  ]
OPDEF	CDRA	[HRRZ	  ]
OPDEF	RPLCA	[HRLM	  ]
OPDEF	RPLCD	[HRRM	  ]

PAGE
;UUO definitions

	;UUOs used to call functions from compiled code
	;the number of arguments is given by the ac field 
	;the address is a pointer either to the function 
	;name or the code of the function

OPDEF FCALL [34B8]	;ordinary function call-may be changed to PCALL
OPDEF JCALL [35B8]	;terminal function call-may be changed to JRST
OPDEF CALLF [36B8]	;like FCALL but may not be changed to PCALL
OPDEF JCALLF [37B8]	;like JCALL but may not be changed to JRST

;error UUOs 

UOERRE==1
UOERRL==10
UOERRG==20
UOERRI==21
USTRTP==22

;ERRL and ERRE spans more than one UUO, to allow for larger ac-field
;Ac-field contains error number.

OPDEF ERRE1  [1B8]	;  1	;print expression, ordinary lisp error, bactrace
OPDEF ERRE2  [2B8]	;  2
OPDEF ERRE3  [3B8]	;  3
OPDEF ERRE4  [4B8]	;  4
OPDEF ERRE5  [5B8]	;  5
OPDEF ERRE6  [6B8]	;  6
OPDEF ERRE7  [7B8]	;  7
OPDEF ERRL0  [10B8]	;  8	;ordinary lisp error	;gives backtrace
OPDEF ERRL1  [11B8]	;  9
OPDEF ERRL2  [12B8]	; 10
OPDEF ERRL3  [13B8]	; 11
OPDEF ERRL4  [14B8]	; 12
OPDEF ERRL5  [15B8]	; 13
OPDEF ERRL6  [16B8]	; 14
OPDEF ERRL7  [17B8]	; 15
OPDEF ERRG   [20B8]	; 16	;space overflow error	;no backtrace
OPDEF ERRI   [21B8]	; 17	;ill. mem. ref.
OPDEF STRTIP [22B8]	; 18	;print error message and continue

PAGE
;system UUOs

OPDEF TTYUUO [51B8]
OPDEF INCHRW [TTYUUO 0,]
OPDEF OUTCHR [TTYUUO 1,]
OPDEF OUTSTR [TTYUUO 3,]
OPDEF INCHWL [TTYUUO 4,]
OPDEF INCHSL [TTYUUO 5,]
OPDEF CLRBFI [TTYUUO 11,]
OPDEF SKPINC [TTYUUO 13,]
OPDEF TALK   [PCALL TTYCLR]	;this is to turn off control O.
				;when ttyser lets you do this
				;easily, change me

;system uuos
DEVCHR==4
CORE==11
RESET==0
APRINI==16
MSTIME==23
STIME==27
SETUWP==36

PAGE
;I/O bits and constants

LNPRVT==6	;lines per vertical tab
TTYPL==0	;teletype pagelength. No paging
LPTPL==0	;line printer pagelength. No paging
TTYLL==105	;teletype linelength 
LPTLL==160	;line printer linelength
MLIOB==203	;max length of I/O buffer
NIOB==2		;no of I/O buffers per device
NIOCH==17	;number of I/O channels
FSTCH==1	;first I/O channel
TTCH==0		;teletype I/O channel
BLKSIZE==NIOB*MLIOB+COUNT+1
INB==2
OUTB==1
AVLB==40
DIRB==4


;special ASCII characters

ALTMOD==175	;LISP'S ALTMODE (TENEX-PA1050 & SU-AI) 33'S CONVERTED.
IGCRLF==32	;ignored cr-lf
RUBOUT==177
CRLF==37	;TYID converts the sequence CR LF or CR FORMF to CRLF. TYO converts back.
LF==12
CR==15
TAB==11
BELL==7
DBLQT==42	;double quote "
VT==13		;vertical tab
FORMF==14	;form feed

;byte pointer field definitions
ACFLD==^D12	;ac field
XFLD== ^D17	;index field
OPFLD==^D8	;opcode field
SIGN==400000	;sign marker for bignums

PAGE
;external and internal symbols

EXTERNAL .JB41	;instruction to be executed on UUO
EXTERNAL .JBAPR	;address of APR interupt routines
EXTERNAL .JBCNI	;interupt condition flags
EXTERNAL .JBFF	;first location beyond program
EXTERNAL .JBREL	;address of last legal instruction in core image
EXTERNAL .JBREN	;reentry address
EXTERNAL .JBSA	;starting address
EXTERNAL .JBSYM	;address of symbol table
EXTERNAL .JBTPC	;program counter at time of interupt
EXTERNAL .JBUUO	;uuo is put here with effective address computed
EXTERNAL .JBHRL	;RH= High-segment .JBREL, LH set 0.

;apr flags
PDOV==200000	;push down list overflow
MPV==20000	;memory protection violation
NXM==10000	;non-existant memory referenced
APRFLG==PDOV+MPV+NXM	;any of the above


;foolst macros:  these get relocated (RH addr) relative to FS.

DEFINE FOO <
XLIST
BAZ (\FOOCNT)
LIST
	>

DEFINE BAZ (X)
<FOOCNT=FOOCNT+1
FOO'X:!
SUPPRESS FOO'X
>

FOOCNT=0
SUBTTL	TOP LEVEL AND INITIALIZATION		--- PAGE 3


LISPGO:	SETOM	RETFLG#		;enter via INITFN
	JRST	STRT		;go to re-allocator

DEBUGO:	SETZM	RETFLG		;clear return flag to allow INITFN to be changed
	JSR	CHKACS		;entry point to get into read-eval-print loop
	JUMPN	A,LSPRT2	;  without unbinding spec pdl...
				;If NIL looks like an atomheader, we skip
				;  reseting the ACCs, etc, else refresh...

START:	CALLI	RESET		;Initializations for lisp interrupts...
	JSR	APRSET		;Set up APRs and Tenex ^chars.
	JSR	CHKAC0	;Reset NIL if necessary, else retain any user additions.
IFN AED,SETZM	PSAV1
FOO	SETZB	1,VERMSG
	MOVE	17,[1,,2]
	BLT	17,17		;clear acs, other than NIL.
	MOVEI	F,ILLAD		;empty fs list
LSPRT1:	MOVE	P,C2#		;Initialize regular PDL.
IFN EPDL,MOVE	EP,EC2#		;initialize EPDL
	SKIPE	SP,SPSAV#
	 PCALL	TUNBIND		;Unbind spec pdl to top
	MOVE	SP,SC2#		;Initialize special PDL.
	PUSH	SP,[0]		;mark for unbind
FOO	MOVEI	B,TRUTH
FOO	SKIPN	ERRSW		;only change if NIL
FOO	MOVEM	B,ERRSW		;print error messages
	SETZM	ERRTN		;return to top level on errors
	SETOM	PRVCNT#		;initialize counter for errio
IFN OPSYS,SETZM	KBINTF
	SETZM	EXARG		;Delete content of
	MOVE	A,[EXARG,,EXARG+1]	; extended ascs to
	BLT	A,EXARG+NSUA-NACS-1	; allow gc
LSPRT2:	PCALL	TTYRET		;Return output for gc msg.
	JSR	CHKNIL		;initialize nil
	SKIPE	HASHFG#
	 JRST	REHASH		;rehash if necessary
	SKIPN	FF
	 PCALL	AGC2		;garbage collect only if necessary
	SETZM	GCFFLG#
	SKIPN	BSFLG#		;initial bootstrap for macros
	 JRST	BOOTS
	SKIPE	BPSFLG#
	 JRST	BINER2		;BPS OVERFLOW DURING A (LOAD T).
	SKIPN	RETFLG		;test for error return
	 JRST	LISP2
FOO	SKIPE	A,INITF
	 CALLF	0,(A)		;evaluate initialization function
	SETZM	RETFLG
LISP2:	PCALL	TTYRET		;return all i/o to tty
	PCALL	TERPRI
	SKIPE	GOBF#		;garbaged oblist flag
	 STRTIP	[SIXBIT /_***** GARBAGED OBLIST_!/]
	SETZM	GOBF
LISP1:	PCALL	READ		;this is the top level of lisp
	PCALL	EVAL
	PCALL	TERPRI
	PCALL	PRINT
        PCALL	TERPRI
	JRST	LISP1
PAGE
;return from lisp error
LSPRE:	CLRBFI			;clear input buffer
FOO	SKIPE	RSTSW
	 JRST	LISP2	;(*rset t) goes to read-eval-print loop without unbind
LSPRET:	MOVE	P,C2		;return from bell
	PCALL	TERPRI
IFN AED,<SKIPE	P,PSAV1#	;bell from alvine?
	 JRST	[HRRZ REL,ED	;yes, return to alvine
		 JRST 1(REL)]>	;improved magic
	MOVEM	SP,SPSAV	;force unbinding of spec pdl
	SETOM	RETFLG		;set return flag
	JRST	LSPRT1

;bootstrapper for macro definitions & Lisp extensions...
BOOTS:	SETOM	BSFLG
	MOVEI	A,BSTYI
	PCALL	READP1
	PCALL	EVAL
	PCALL	READ		;last prog calls ERR, back to LISP1.
	JRST	.-2

BSTYI:  ILDB    A,[POINT 7,[ASCII /(RDS(OPEN '(SYS:(LISP.SL)) 'INPUT))/]]
	PRET

PAGE
;Verify that NIL is a good atom, perhaps with user properties,
;  else reset it (AC0) to be the Urlisp atomheader...
IFN OPSYS,<
CHKACS:	X			;Tenex-Pa1050 needs to be clever about ^C's.
	CALLI	A,MSTIME	;Do a simple op to ensure PA1050 exists.
	JSR	CHKNIL
	JUMPN	A,@CHKACS	;Didn't have to fix it,
	MOVE	NIL,@700032	;  else check last ac0 saved in PA1050.
	JSR	CHKNIL
	JUMPE	A,@CHKACS	;    Not ok either, have to refresh all accs.
	HRLZ	17,700032	;Was ok, so grab the save-acc blk
	BLT	17,17		;  from PA1050's area.
	JRST	CHKACS+2	;Set ac1 non0 and return successfully.

CHKAC0:	X			;Setup 0 without worrying about 1:17.
	JSR	CHKNIL
	JUMPN	A,@CHKAC0	;Tenex's was ok,
	MOVE	NIL,@700032
	JSR	CHKNIL
	JRST	@CHKAC0	>	;  or PA1050's, else CNIL2 reset.

CHKNIL:	X			;Yet another impure loc, for JSRing.
	JSP	TT,CHKNI1
	JUMPN	A,@CHKNIL	; o.k.
	MOVE	NIL,CNIL3	; refresh NIL
	MOVEI	A,NIL		;Return 0 if have to reset...
	JRST	@CHKNIL

CHKNI1:	HLRO	A,NIL
	AOJN	A,SETNIL	;LH not -1.
	CDRA	A,NIL
	CAILE	A,@GCPP1	;(base of FS)
	CAIL	A,@GCP1		;(base of FWS)
	 JRST	SETNIL		;  proplist addr not in FS.
FOO	MOVEI	B,VALUE
GETNIL:	MOVS	C,(A)		;Make sure it has a VALUE cell,
	MOVS	A,(C)
	CAIN	B,(A)		;  else EVAL would say "#0 Unbound Variable".
	 JRST	GOTNIL
	CARA	A,C
	JUMPN	A,GETNIL
	JRST	(TT)
GOTNIL:	HLRZS	A		;We don't require this to be UrLisp's VNIL cell.
	SKIPE	(A)		;Check that it points back to NIL tho,
SETNIL:	 MOVEI	A,NIL		; else reset it.
	JRST	(TT)		;Return non0: didn't have to reset.

IFE OPSYS,<CHKACS==CHKNIL	;Don't have to worry about separate
	   CHKAC0==CHKNIL>	;  PA1050 accs being present after a ^C.
SUBTTL 	APR INTERRUPT ROUTINES			--- PAGE 4
;arithmetic processor interupts
;mem. protect. violation, nonex. mem. or pdl overflow

APRINT:	MOVEM	R,ACSAV+R
	MOVE	R,.JBCNI	;get interrupt bits
	SETZM	.JBCNI	;Clear for compiled-code Pdl check: <JUMPGE P,@.JBAPR>
	TRNE	R,MPV+NXM	;what kind
	 JRST	ILLMEM
	JUMPN	NIL,MES21	;a pdl overflow
	STRTIP	[SIXBIT /_***** PDL OVERFLOW FROM GC - CAN'T CONTINUE!/]
	JRST	START

MES21:	SETZM	.JBUUO
	SKIPL	P
	 ERRG	^D256,[SIXBIT /REG PUSHDOWN CAPACITY EXCEEDED!/]
	SKIPL	SP
SPDLOV:	 ERRG	^D257,[SIXBIT /SPEC PUSHDOWN CAPACITY EXCEEDED!/]
IFN EPDL,<SKIPL	EP
	 ERRG	^D258,[SIXBIT /EXP PUSHDOWN CAPACITY EXCEEDED!/] >
	TRNN	R,PDOV
	 HALT			;lisp should not be here
BINER2:	SETZM	BPSFLG
	ERRG	^D259,[SIXBIT /BINARY PROGRAM SPACE EXCEEDED!/]

ILLMEM: LDB	R,[POINT 4,@.JBTPC,XFLD]	;get index field of bad word
	CAIN	R,F		;is it F ?
	CAIE	F,ILLAD
	 ERRI	2,@.JBTPC	;no! error
	PSAVE	.JBTPC		;yes! save return address
	MOVEI	R,APRFLG
	CALLI	R,APRINI	;    reset interupt,
	MOVEI	R,AGC1
	JRSTF	@R		;    garbage collect and continue


PAGE
APRSET:	0			;SET UP NECESSARY INTERRUPTS.
	MOVE	A,[JSR UUOH]
	MOVEM	A,.JB41
	MOVEI	A,APRINT
	MOVEM	A,.JBAPR
	MOVEI	A,APRFLG
	CALLI	A,APRINI	;THIS DOES THE 10/50 SETUP.
  IFE OPSYS,<
   IFN HCBPS,<
	SETZ	A,
	CALLI	A,SETUWP	;Necessary as RESET resets high core write bit.
	 HALT	>
	JRST	@APRSET>
  IFN OPSYS,<			;  and for TENEX (Accs 1&2 are free):
	MOVEI	1,400000	;FORK HANDLE FOR THIS FORK.
	RIR			;GET THE PA1050 FILE'S LEVTAB,,CHNTAB.
  IFG OPSYS,<
	MOVE	1,[XWD 1,CHANL0]
	EXCH	1,^D30(2)	;Set channel addresses...
	HRRZS	1		;  Normally would just use chn 0 for ^O
	CAIL	1,700000	;    but PA1050 also diddles on chn 30,
	 HRRM	1,CHANL0 >	;    so do local CHANL0 then PA1050's  CFOBF.
	MOVE	1,[XWD 1,CHANL1]
	MOVEM	1,1(2)
	MOVE	1,[XWD 1,CHANL2]
	MOVEM	1,2(2)
	MOVE	1,[XWD 1,CHANL3]
	MOVEM	1,3(2)
  IFG OPSYS,<
	MOVE	1,["O"-100,,^D30];Set terminal-characters...
	ATI	>
	MOVE	1,["P"-100,,1]
	ATI
	MOVE	1,["E"-100,,2]
	ATI
	MOVE	1,["K"-100,,3]
	ATI
	MOVEI	1,400000
IFG OPSYS,<MOVSI 2,(1B0+1B1+1B2+1B3)>
IFL OPSYS,<MOVSI 2,(1B1+1B2+1B3)>
	AIC
IFG OPSYS,SETZM	CTRLOF#		;Init.
	SETZM	KBINTF#		;Init.
	JRST	@APRSET

IFG OPSYS,<
CHANL0:	SETCMM	CTRLOF		;Flip-flop the ^O flag.
	DEBRK	>
PAGE
CHANL1:	PSAVE	1		; ^P HANDLER...
	PSAVE	2		; Prints current file's <Line>/<Page>.
	PSAVE	3
	MOVEI	1," "
	PBOUT
	SKIPG	LINUM
	 JRST	[MOVM	2,LINUM
		 PCALL	IPNUM
		 JRST	.+3]
	HRROI	1,LINUM
	PSOUT
	MOVEI	1,"/"
	PBOUT
	MOVE	2,PGNUM
	PCALL	IPNUM
IFG OPSYS,MOVEI	1,37
IFL OPSYS,<MOVEI 1,CR
	PBOUT
	MOVEI	1,LF	>
	PBOUT
	PREST	3
	PREST	2
	PREST	1
	DEBRK

IPNUM:	MOVEI	1,101
	ADDI	2,1
	MOVEI	3,^D10
	NOUT
	 PRET
	PRET

CHANL2:	PSAVE	1
	HRROI	1,[ASCIZ /^E
/]
	PSOUT
	PREST	1
	HLLOS	KBINTF		;Flag RH -- next UUO becomes (ERR).
	DEBRK

CHANL3:	PSAVE	1
	HRROI	1,[ASCIZ /^K
/]
	PSOUT
	PREST	1
	HRROS	KBINTF		;Flag LH -- next UUO breaks out to top.
	DEBRK

KBINTH:	MOVE	A,KBINTF	;Handle KB ^char now -- from UUOH, AGC, etc.
	SETZM	KBINTF
IFG OPSYS,SETZM	CTRLOF
	TLNE	A,-1		;Which was it?
	 JRST	LSPRET		;  ^K - escape to top-level.
	MOVEI	A,NIL
	JRST	ERR		;  ^E - (ERR NIL) to ERRSET or top.
   >		;end of IFN OPSYS
SUBTTL 	UUO HANDLER AND SUBR CALL ROUTINES	--- PAGE 5


UUOH:	X			;jsr location
	MOVEM	T,TSV#
	MOVEM	TT,TTSV#
	LDB	T,[POINT 9,.JBUUO,OPFLD] ;get opcode
	CAIGE	T,34		;is it a function call?
	 JRST	ERROR		;or a LISP error?
  IFN OPSYS,<
	SKIPE	KBINTF		;Has user hit ^Chars on KB?
	 JRST	KBINTH		;  Yes, handle it. 	>
	HRRZ	TT,UUOH
	SOSA	TT
	 MOVEI	TT,@(TT)
	LDB	T,[POINT 9,(TT),OPFLD]
	CAIN	T,256		;Is it XCT
	 JRST	.-3
	HRRM	TT,UUOCL-1
	LDB	T,[POINT 5,.JBUUO,ACFLD]
	TRZN	T,20
	 PSAVE	UUOH		;call|callf -- return addr.
	CARA	R,@.JBUUO
	CAIE	R,ID
	 JRST	UUOS		;if wasn't an id head, else...
	CAIE	T,17
	 TDZA	R,R
	 MOVEI	R,1		;R=0 if T=0-16, else 1(17).
	CDRA	T,@.JBUUO
FOO	MOVEI	D,FUNCELL
UUOH1:	JUMPE	T,UUOH3
	MOVS	TT,(T)
	MOVS	T,(TT)
	CAIN	D,(T)
	 JRA	T,UUOH2
	CARA	T,TT
	JRST	UUOH1
PAGE
UUOH2:	CARA	TT,T
	HRL	T,.JBUUO	;name of function, for backtrace
;FOO	CAIN	TT,SUBR
;	 JRST	@UUST(R)
;FOO	CAIN	TT,FSUBR
;	 JRST	@UUFST(R)
	CARA	D,(T)
	CAIE	D,ID
	CAIGE	D,CODMIN
	 JRST	.+2
	 SUBI	R,4		;its a subr or fsubr
FOO	CAIN	TT,EXPR
	 JRST	@UUET(R)
FOO	CAIN	TT,FEXPR
	 JRST	@UUFET(R)
UUOH4:	HRRZ	A,.JBUUO
	ERRE1	^D16,[SIXBIT /UNDEFINED UUO!/]  ;e.g., a MACRO or no def.

UUOH3:	PSAVE	A
	PSAVE	B
	HRRZ	A,.JBUUO
FOO	MOVEI	B,VALUE
	PCALL	GET
	JUMPE	A,UUOH4
	CDRA	T,(A)
	HRL	T,.JBUUO	;name of function, for backtrace
	PREST	B
	PREST	A
	JRST	UUOEXP
PAGE
UUOSC:	CDRA	T,(T)
UUOSBR:
FOO	SKIPE	NOUUOF
	 JRST	UUOCL
	MOVE	TT,.JBUUO
	HRLI	T,(PCALL)
	TLNE	TT,1000		;1000 means no push
	 HRLI	T,(JRST)
	TLNN	TT,2000		;2000 means no clobber
	 MOVEM	T,X
UUOCL:	MOVE	TT,TTSV
	MOVE	R,T
	MOVE	T,TSV
	JRST	(R)

UUOS:	HRRZ	T,.JBUUO	;If not an atomheader, what?
	CAIL	R,CODMIN
	 JRST	UUOSC		; code pointer
	CAILE	T,@GCPP1	;  Base of FS,
	CAIL	T,@GCP1		;	   FWS...
	 JRST	UUOSBR
UUOEXP:	PSAVE	T		;<fn name or NIL,,func def>
	LDB	T,ARGFLD
	JUMPE	T,IAPPLY
	CAIN	T,17
	 MOVEI	T,1
	MOVEI	TT,IAPPLY
	SKIPA	R,T
ARGPDL:	LDB	R,ARGFLD
ARGP1:	HRLZ	T,R
	ADD	P,T
	JUMPGE	P,MES21		;check for stack overflow
	MOVEI	T,1(P)
	HRLI	T,A
	CAIG	R,NACS
	 JRST	.+4
	BLT	T,NACS(P)
	MOVEI	T,NACS+1(P)
	HRLI	T,EXARG
	ADDI	P,(R)
	BLT	T,(P)
	MOVNI	T,(R)
	JRST	(TT)
EXARG:	BLOCK	NSUA-NACS+1

ARGFLD:	POINT	4,.JBUUO,ACFLD
PAGE
	;R=0 => compiler calling a -
	;R=1 => compiler calling f type
	;for an expr or fexpr that has a code pointer, 4 is subtracted
	; from R, to map expr into subr and fexpr into fsubr


UUST:	UUOSC
	UUOS2		;calling f		(page 15 - EVAL).
UUFST:	UUOS9		;calling - its a f
	UUOSC
UUET:	UUOEXP
	UUOS6		;calling f its an expr	(page 15 - EVAL).
UUFET:	UUOS3		;calling - its a fexpr
	UUOEXP	


UUOSFE:	HRRZ	A,.JBUUO
	ERRE1	^D17,[SIXBIT /CALLED AS EXPR!/]

UUOS9:	PSAVE	T
	JSP	TT,ARGPDL
	MOVEI	TT,UUOCL
QTLFY:	MOVEI	A,0		;If AGC and GCGAG(T), can clobber
QTLFY1:	JUMPE	T,(TT)		;  .JBUUO and UUOH, so saved in GC.
	EXCH	A,(P)
	PCALL	QTIFY
	PREST	B
	PCALL	CONS
	AOJA	T,QTLFY1


UUOS3:	PSAVE	T
	JSP	TT,ARGPDL
	JSP	TT,QTLFY
	JRST	UUOS3I
SUBTTL 	ERROR HANDLER AND BACKTRACE		--- PAGE 6

ERRSUB:	HRRZ	A,.JBUUO	;Print SIXBITed messages (errors)...
	JUMPE	A,CPOPJ
	HRLI	A,(POINT 6,0)
	MOVEM	A,ERRPTR#
ERRORB:	ILDB	A,ERRPTR
	CAIN	A,01		;conversion from sixbit
	 PRET
	CAIN	A,77
	 HRREI	A,CRLF-40
	ADDI	A,40
	PCALL	TYO
	JRST	ERRORB

WHEAD:	PCALL	ERRIO
	MOVEI	B,3
	JRST	ERHED+2

ERHED:	PCALL	ERRIO
	MOVEI	B,5
	PCALL	TERPRI
	MOVEI	R,TYO
	XCT	"*",CTY
	SOJG	B,.-1
	XCT	" ",CTY
	PRET

TOURET:	PCALL	TERPRI
;subroutine to return output to previously selected device
OUTRET:	SKIPL	PRVCNT		;if prvcnt<0 then there was no device deselect
	SOSL	PRVCNT		;when prvcnt goes negative, then reselect
	 PRET
	PSAVE	PRVSEL#		;previously selected output
	PREST	TYOD
	PRET

;subroutine to force error messages out on tty
ERRIO:
FOO	CDRA	B,ERRSW
	CAIE	B,INUM0		;inum0 => print message on selected device
	AOSLE	PRVCNT		;Deselected iff PRVCNT already <0.
	 PRET		
	TALK			;undo control o
	MOVE	B,[JRST TTYO]
	EXCH	B,TYOD
	MOVEM	B,PRVSEL
	PRET

ERRTN:	0	;0 => top level				*
		;- => pdl to reset to - stored by errorset
		;+ => string tyo pout rtn flag
PAGE
;subroutine to search oblist for closest function to address in R
ERSUB3:
	JSR	CHKNIL		;Reset AC0 if need be.
FOO	MOVEI	A,QST
	HRLZ	B,INT1
	MOVNS	B
	SETZB	AR5,GOBF
	CAIL	R,STRT
	 MOVEI	AR5,STRT
FOO	CAIL	R,FS
	 MOVEI	A,NIL
	PSAVE	.JBAPR
	MOVEI	C,[SETOM GOBF		;Intercept ill-mem-refs, flag
		   JRST  ERRO2G]	;  "garbaged OBLIST" for LISP2.
	HRRM	C,.JBAPR
	HLRZ	C,@RHX5
ERRO2B:	JUMPE	C,[AOBJN B,.-1
		   PREST .JBAPR		;oblist done, restore
		   JRST  PRIN2D]	;print closest match
	CARA	TT,(C)
	CDRA	TT,(TT)
	JRST	ERRO2C+1

ERRO2C:	CARA	TT,TT
	JUMPE	TT,ERRO2G
	MOVS	TT,(TT)
	CARA	AR4,(TT)
FOO	CAIE	AR4,FUNCELL
	 JRST	ERRO2C
	CDRA	TT,(TT)
	CDRA	TT,(TT)
	CARA	AR4,(TT)
	CAIE	AR4,ID
	CAIGE	AR4,CODMIN
	 JRST	ERRO2G
	CDRA	TT,(TT)
	CAMLE	TT,AR5		;LE to prefer car to quote
	CAMLE	TT,R
	 JRST	ERRO2G
	MOVE	AR5,TT
	CARA	A,(C)
ERRO2G:	CDRA	C,(C)
	JRST	ERRO2B
PAGE
;dispatcher for error message uuos


ERROR:	MOVEI	B,APRFLG	;Enable 10/50 interrupts.
	CALLI	B,APRINI
	LDB	B,[POINT 9,.JBUUO,OPFLD]	;get opcode
	CAIL	B,UOERRE	;what
	CAILE	B,USTRTP	;is it?
	 JRST	ILLUUO		;  an illegal opcode
	LDB	R,[POINT 9,.JBUUO,ACFLD]	;error number
	ADDI	R,INUM0
	CAIL	B,USTRTP
	 JRST	STRTYP		;print message and continue
FOO	SETZM	VERMSG
	CAIL	B,UOERRI
	 JRST	ERROR2		;illegal memory reference
	HRRM	R,ERRX		;error number
	CAIL	B,UOERRG
	 JRST	ERRORG		;space overflow error
	CAIL	B,UOERRL
	 JRST	ERROR1		;ordinary LISP error
FOO	HRRZM	A,VERMSG	;set EMSG* to expression
	PSAVE	A		;save it
FOO	SKIPN	ERRSW
	 JRST	ERREND		;dont print message, call (err nil)
	PCALL	ERHED		;print message on tty
	PREST	A
	PCALL	PRIN1		;print expression
	XCT	" ",CTY
	JRST	ERRORA		;then ordinary Lisp error

ERRORG:	SKIPN	P,ERRTN		;if in errset, restore p to that level
	 MOVE	P,C2		;else to top level
ERROR1:				;and attempt to print message
FOO	SKIPN	ERRSW
	 JRST	ERREND		;dont print message, call (err nil)
	PCALL	ERHED		;print message on tty
ERRORA:	PCALL	ERRSUB		;print the message
	JRST	ERRBK		;go the backtrace

;STRTYP uses acs A, B and R
STRTYP:	PCALL	ERRIO
	PCALL	ERRSUB		;print message and continue
	PCALL	OUTRET
	JRST	@UUOH

ERROR2:	HRRZ	A,.JBUUO
	MOVEI	B,[SIXBIT / ILL MEM REF FROM !/]
	SUBI	R,420
	JRST	ERSUB2
PAGE
ILLUUO:	HRRZ	A,UUOH
	MOVEI	B,[SIXBIT / ILL UUO FROM !/]
	MOVEI	R,INUM0+1
FOO	SETZM	VERMSG
ERSUB2:	HRRM	R,ERRX
FOO	SKIPN	ERRSW
	 JRST	ERREND		;dont print message
	PSAVE	A
	PSAVE	B
	PCALL	ERHED
	PCALL	PRINL2		;print number
	PREST	A
	PCALL	ERRSUB+1	;print message
	PREST	R
	PCALL	ERSUB3		;print nearest oblist match
ERRBK:
FOO	SKIPE	BACTRF
	 PCALL	BKTRC		;print backtrace
	PCALL	TOURET		;return to previous device
ERREND:	JSR	CHKNIL		;Insure NIL is set properly.
ERRX:	MOVEI	A,X		;(ERR x)  error number
ERR2:	SKIPN	ERRTN
	 JRST	LSPRE
ERR:	SKIPN	P,ERRTN
	 JRST	LSPRET		;not in an errset, or bad error -- go to top level
ERR1:	PREST	B
	PCALL	UBD		;unbind to previous errset
IFN EPDL,PREST	EP
FOO	PREST	ERRSW
	PREST	ERRTN
	JRST	ERRP4		;and proceed

ERRORSET:PSAVE	PA3
	PSAVE	PA4
	PSAVE	ERRTN
FOO	EXCH	B,ERRSW		;INUM0 -> print on selected device (not nec TYO).
	PSAVE	B
IFN EPDL,PSAVE	EP
	PSAVE	SP
	MOVEM	P,ERRTN
	PUSH	SP,[0]		;mark for unbind
FOO	EXCH	C,BACTRF	;bind BACTRF on spdl to save from error
FOO	HRLI	C,BACTRF
	PUSH	SP,C
	PCALL	EVAL
	PCALL	NCONS
	JRST	ERR1
PAGE
.ERROR:
FOO	HRRZM	B,VERMSG
	PSAVE	A
FOO	SKIPN	ERRSW
	 JRST	.ERR1
	MOVE	A,B
	PCALL	ERRIO
	JUMPE	A,.ERRO
	PCALL	ERHED+1
	PCALL	PRINEL
.ERRO:
FOO	SKIPE	BACTRF
	 PCALL	BKTRC
	PCALL	TOURET
.ERR1:	JSR	CHKNIL
	PREST	A
	JRST	ERR2

PRINEL:	JSP	D,PATMTP
	 JRST	PRIN2
	PSAVE	A
	CARA	A,(A)
	PCALL	PRIN1
PRINE1:	CDRA	T,@(P)
	MOVEM	T,(P)
	JUMPE	T,POPAJ
	XCT	" ",CTY
	CARA	A,(T)
	PCALL	PRIN2
	JRST	PRINE1

;WARNING prints a warning message on the tty
WARNING:
FOO	SKIPN	%MSG
	 JRST	FALSE
	PCALL	WHEAD
	PCALL	PRINEL
	JRST	TOURET
PAGE
BKTRC:			;backtrace subroutine
FOO	CDRA	A,BACTRF	;Nil or non-Nil or 0 or +-n...
BKTRA:	SETZM	RVAL		;No stack-args printed, unless 0 or neg.
	CAIG	A,INUMIN
	 JRST	BKTR0A
	HRREI	B,-INUM0(A)
	SKIPG	B
	 SETOM	RVAL		;0 or neg also prints stack args.
	MOVM	B,B
	HRRZ	A,P
	SUB	A,B		;Just the top n items or
	JUMPN	B,BKTR0B	;0 == T otherwise.
BKTR0A:	SKIPN	A,ERRTN		;backtrace to previous errset
	 MOVE	A,C2		;or top level
BKTR0B:	HRRZM	A,BAKLEV#
	STRTIP	[SIXBIT /_BACKTRACE_!/]
FOO	MOVE	A,VBPORG
	PCALL	NUMVAL
	MOVEM	A,HVAL
	MOVEI	D,-1(P)
BKTR2:	CAMG	D,BAKLEV
	 JRST	FALSE		;done 
	HRRZ	A,(D)		;get pdl element
FOO	CAIGE	A,FS
	JUMPN	A,BKTR2B	;this is (hopefully) a true program address
  IFN HCBPS,<
	CAML	A,HVAL		;Check for High BPS subrs,
	 JRST	BKTR2A		;  else an INUM.
	CAILE	A,400000	;PCALL from location 377777 is illegal
	 JRST	BKTR1B		;Test it.
	    >
  IFE HCBPS,<
	CAILE	A,INUMIN	;Check for Excore BPS subrs,
	 JRST	BKTR2A		;  else an INUM.
	CAML	A,HVAL
	 SOJA	D,BKTR2
	CAMLE	A,JRELO
	 JRST	BKTR1B		;Test it.
	    >
	CAIGE	A,@GCP1		;Within FS or NIL?
BKTR2A:	SKIPN	RVAL		;Want to print args on stack?
	 SOJA	D,BKTR2		;  Unknown, neither prog nor sexpr, so skip.
	MOVEI	A,"="
	PCALL	TYO
	HRRZ	A,(D)
BKTR2C:	PCALL	PRIN2D
	JRST	BKTR1C
PAGE
BKTR2B:	CAIE	A,ILIST3	;evaluating arguments ?
	 JRST	BKTR1B		;no
	HRRZ	B,-1(D)		;maybe
	CAIE	B,EXP2
	CAIN	B,ESB1
	 JRST	BKTR1A		;yes
BKTR1B:	CAIN	A,CPOPJ
	 JRST	[HLRZ	A,(D)	;calling a function
		 PCALL	PRIN2D
		 STRTIP	[SIXBIT /-ENTER !/]
		 SOJA	D,BKTR2]
	HLRZ	B,-1(A)
	CAILE	B,(JCALLF 17,@(17))
	CAIN	B,(PCALL)	;tests for various types of calls
	CAIGE	B,(FCALL)
	 JRST	[CAIG	A,INUMIN
		  SOJA	D,BKTR2	;Not a proper function call.
		 JRST	BKTR2A ];This could print as a INUM.
	PSAVE	-1(A)		;save object of function call
	MOVEI	R,-1(A)		;location of function call
	PCALL	ERSUB3		;print closest oblist match
	XCT	"-",CTY
	PREST	R
	TLNE	R,17
	 HRRZ	R,ERSUB3	;qst -- cant handle indexed calls
	HRRZS	R
	CARA	B,(R)
	CAIN	B,ID
	 JRST	[CDRA A,R	;was calling an atomic function
		 JRST BKTR2C]	;print its name
	CAIL	B,CODMIN	;code pointer ?
	 CDRA	R,(R)		;yes
	PCALL	ERSUB3		;was calling a code location; print closest match
BKTR1C:	XCT	" ",CTY
BKTR1:	SOJA	D,BKTR2		;continue

BKTR1A:	HLRE	B,-1(D)
	ADD	B,D
	HLRZ	A,-3(B)
	JUMPE	A,BKTR1
	PCALL	PRIN2D
	STRTIP	[SIXBIT /-EVALARGS !/]
	SOJA	D,BKTR2

PRIN2D:	PSAVE	D
	PCALL	PRIN2
	PREST	D
	PRET
SUBTTL 	TYI  &  TYO				--- PAGE 7
			;Input routines...
BINI:	PCALL	TYID
	JRST	FIX1A

ITYI:	PCALL	TYI
FIXI:	ADDI	A,INUM0
	PRET

TYICC:	PCALL	COMIGN
TYI:	MOVEI	AR4,1
TYIC:	PCALL	TYID1
	JUMPE	A,.-1		;Ignore null
	CAIN	A,IGCRLF	;start of ignored cr-lf
	 JRST	TYICC		;read comment
	PRET

TYIA:	CAIN	A,LF		;If it is LF
	 JRST	RETCRLF		; then return CRLF
	CAIN	A,FORMF		; else if it is FORMF
	 JRST	RCRLFFF		; then return CRLF FF
	CAIE	A,CR
	 PRET
	PCALL	TYID		;Read next character
	CAIN	A,CRLF		;If it is CRLF
	 PRET			; then return it
	MOVEM	A,OLDCH		; else backup character
	MOVEI	A,CR		; and return CR
	PRET

RCRLFFF:MOVEM	A,OLDCH		;Backup FF
RETCRLF:MOVEI	A,CRLF
	PRET

TYID1:	SKIPE	A,OLDCH
	 JRST	TYI1
TYID:	JRST	TTYI+X		;<SOSG X> for other device input...
	 JRST	TYI2X
TYI3:	ILDB	A,X		;pointer
	SKIPGE	INCH		;IF BINARY-MODE INPUT,
	 PRET			;  SKIP LINUM &FECHO & RAISE CODE.
TYI3A:	TDNN	AR4,@X		;pointer
	 JRST	TYI4
	MOVE	A,@TYI3A
	CAMN	A,[<ASCII /     />+1]	;page mark for stopgap
	AOSA	PGNUM		;increment page number
	 MOVEM	A,LINUM
	MOVNI	A,5
	ADDM	A,@TYID		;adjust character count for line number
	AOS	@TYI3		;increment byte pointer over line number and tab
	JRST	TYID

PAGE
TYI4:	SKIPLE	LINUM
	 JRST	TYI4A
	CAIN	A,LF
	 JRST	TYI4L
	CAIE	A,FORMF
	 JRST	TYI4A
	SETZM	LINUM
	AOSA	PGNUM
TYI4L:	SOS	LINUM
TYI4A:
FOO	SKIPN	VFECHO
	 JRST	TYI4E
	CAIN	A,"D"-100	;On! File-input echoed to TTY.
	 JRST	TYI4W
	PCALL	XTYO
	JRST	TYI4E

TYI4W:
  IFN OPSYS,<
	PSAVE	2		;Unless ^D encountered in file...
	MOVEI	1,100		;  want to pause during echo,
	RFMOD			;  e.g., demo on a CRT.
	PSAVE	2
	TRZ	2,776000	;Clear wakeup,echo.
	TRO	2,020000	;Set just punctuation,
	SFMOD
WAITSP:	PBIN			;Wait til user types a space on KB.
	CAIE	1," "
	 JRST	WAITSP
	MOVEI	1,100
	PREST	2
	SFMOD			;Restore old TTYmodes.
	PREST	2
	JRST	TYID		;Get next file-character.
	    >
  IFE OPSYS,<
	SETSTS	TTCH,1+1B28	;OFF ECHO TO TTY, TO GET <sp>...
WAITSP:	INCHRW	A
	CAIE	A," "
	 JRST	WAITSP
	SETSTS	TTCH,1
	JRST	TYID
	    >
PAGE
TYI2X:	INPUT	X,0
TYI2Y:	STATZ	X,740000
	ERRL0	^D128,AIN.8	;input error
TYI2Z:	STATO	X,20000
	 JRST	TYI3		;continue with file
	PSAVE	T		;end of file
	PSAVE	C
	PSAVE	R
	PSAVE	AR4
	MOVE	A,INCH
	HLRZ	T,CHTAB(A)	;inlst	-- remaining files to input
	JUMPE	T,TYI2E		;none left -- stop
	HRRZ	C,CHTAB(A)	;get location of data for this channel
	MOVE	R,CHDEV(C)
	MOVEM	R,DEV
	MOVE	R,CHPPN(C)
	MOVEM	R,PPN
	PCALL	SETIN		;start next input
	PREST	AR4
	PREST	R
	PREST	C
	PREST	T
	JRST	TYI

TYI2E:	PCALL	INCNT		;(CLOSE (RDS NIL))
	TALK			;turn off control o
FOO	MOVE	A,V$EOF$	;we are done
	JRST	ERR

PGLINE:	MOVM	A,LINUM
	SKIPG	LINUM
	AOJA	A,.+3
	MOVE	C,[POINT 7,LINUM]
	PCALL	NUM10		;convert ascii line number to an integer
	PCALL	FIX1A		;(may be larger than INUM size - 99999).
	SKIPG	LINUM		;If not line numbered file
	 PCALL	NCONS		; then (pg line)
	MOVE	B,PGNUM
	HRLI	A,INUM0+1(B)
	JRST	DCONSA		; else (pg . line)

OLDCH:	0			;		*
PGNUM:	0			;		*
LINUM:	0			;		*
	0			;zero to terminate num10
PAGE
	;teletype input

TTYI:
FOO	SKIPE	DDTIFG
	 JRST	TTYID
	INCHSL	A		;single char if line has been typed
	 JRST	[TALK		;turn off control o.
		OUTSTR	PCHAR	;output THE PROMPT-CHAR(S).
		INCHWL	A	;wait for a line
		JRST	.+1]
TTYXIT:	CAIN	A,BELL
	 JRST	LSPRET		;bell returns to top level
	CAIN	A,33
	 MOVEI	A,ALTMOD	;<esc> becomes <alt> (DECUS tty input).
TYI4E:
FOO	SKIPE	VRAISE
	CAIGE	A,"A"+40
	 JRST	TYIA
	CAIG	A,"Z"+40
	 TRZ	A,40		;If flag on, make lowercase into upper.
	PRET

TTYID:	TALK			;turn off control o, remove this when ttyser works
	INCHRW	A		;single character input ddt submode style
	CAIE	A,RUBOUT
	 JRST	TTYXIT
	OUTCHR	["\"]		;echo backslash
	SKIPE	PSAV
	 JRST	RDRUB		;rubout in read resets to top level of read
	PRET

PCHAR:	ASCIZ	/*/		;INITIAL (DEFAULT) PROMPT-CHAR.


SETPCH:	PCALL	GT1PNM
	TRZ	A,377		;(INSURE NULL AT END OF STRING).
	EXCH	A,PCHAR		;1-4 CHARS.
	JRST	PNGNK2		;return previous promter as non-interned id

PAGE
				;output ROUTINES.
BINO:	PSAVE	A
	PCALL	NUMVAL
	PCALL	TYOD
	JRST	POPAJ

ITYO:	SUBI	A,INUM0
	PSAVE	CFIXI		;go to FIXI after TYO
XTYO:	CAIN	A,CRLF		;is it CRLF
	 JRST	TYO+2	;yes! output as is, do not convert to CR LF
TYO:	CAIG	A,CRLF
	 JRST	TYO3
	SOSGE	CHCT
	 JRST	TYO1
TYOD:	JRST	TTYO+X		;sosg x for other device
	 JRST	TYO2X
TYO5:	IDPB	A,X
	PRET

TYO2X:	OUT	X,0
	 JRST	TYO5
	ERRL0	^D129,[SIXBIT /OUTPUT ERROR!/]

TYO3:	CAIE	A,CRLF
	 JRST	TYO3X
	MOVEI	A,CR
	PCALL	TYO3XX
	MOVEI	A,LF
TYO3X:	CAIG	A,CR
	CAIGE	A,TAB
	 JUMPN	A,TYO+2	;everything between 0(null) and 11(tab) decrement chct
TYO3XX:	PSAVE	B
	MOVE	B,LINL
	CAIN	A,TAB
	 JRST	[SUB B,CHCT
		IORI B,7	;simulate tab effect on chct
		SUB B,LINL
		SETCAM B,CHCT
		JRST TYO4]
	CAIN	A,CR
	 MOVEM	B,CHCT		;reset chct after a cr
	CAIN	A,VT
	 JRST	[PSAVE	C
		MOVE	B,LNCT
		IDIVI	B,LNPRVT
		ADDI	B,1
		IMULI	B,LNPRVT
		MOVEM	B,LNCT
		PREST	C
		JRST	TYO6]
	CAIN	A,FORMF
TYO7:	 SETZM	LNCT
	CAIE	A,LF
	 JRST	TYO4
	AOS	LNCT
TYO6:	SKIPE	B,PAGL
	CAMLE	B,LNCT
	 JRST	TYO4
	MOVEI	A,FORMF
	JRST	TYO7
PAGE
TYO1:	SKIPN	OUTCH
	 JRST	TYO11		;don't print a IGCRLF to terminal
	PSAVE	A		;linelength exceeded
	MOVEI	A,IGCRLF	;ignored cr-lf
	PCALL	TYOD
	PREST	A
TYO11:	PCALL	TERPRI
	SOSA	CHCT
TYO4:	PREST	B
	JRST	TYOD

LINELENGTH:
	JUMPE	A,LINEL1
	CAIG	A,INUM0
	 ERRE2	^D36,[SIXBIT /ILLEGAL ARG TO LINELENGTH!/]
	SUBI	A,INUM0
	HRRM	A,LINL
	HRRM	A,CHCT
LINEL1:	HRRZ	A,LINL
CFIXI:	JRST	FIXI

PAGELENGTH:
	JUMPE	A,PAGEL1
	CAIGE	A,INUM0
	 ERRE2	^D37,[SIXBIT /ILLEGAL ARG TO PAGELENGTH!/]
	SUBI	A,INUM0
	HRRM	A,PAGL
	JUMPE	A,PAGEL1
	SKIPE	LNCT
	 PCALL	EJECT
PAGEL1:	HRRZ	A,PAGL
	JRST	FIXI

POSN:	SKIPA	A,LINL
LPOSN:	SKIPA	A,LNCT
	 SUB	A,CHCT
	JRST	FIX1A


LINL:	TTYLL				;*
CHCT:	TTYLL				;*
PAGL:	TTYPL
LNCT:	0




;teletype output

TTYO:				;Output 1 char from A...
IFG OPSYS,SKIPN	CTRLOF		;  unless ^O on.
	 OUTCHR	A
	PRET
PAGE
TTYRET:	PCALL	OUTCNT
	JRST	INCNT

TTYCLR:				;Turn off ^O, in a way such that msg
  IFLE OPSYS, <			;  or promptchar will print.
	SKPINC
	 PRET
	PRET	   >
  IFG OPSYS, <
	PSAVE	A
	MOVEI	1,101
	DOBE
	SETZM	CTRLOF
	JRST	POPAJ	   >

TTOCH:	0					;*
	0	;tty page number -- always zero
	0	;tty line number -- always zero

TTOLL:	TTYLL					;*
TTOHP:	TTYLL					;*
TTOPL:	TTYPL
TTOVP:	0
SUBTTL 	INPUT AND OUTPUT INITIALIZATION AND CONTROL --- PAGE 8
;convert ascii to sixbit for device initialization routines
SIXMAK:	SETZM	SIXMK2#
	MOVE	AR4,[POINT 6,SIXMK2]
	HRROI	R,SIXMK1
	PCALL	PRINTA		;use print to unpack ascii characters
	MOVE	A,SIXMK2
	PRET

SIXMK1:	ADDI	A,40
	TLNN	AR4,770000
	 PRET			;last character position -- ignore remaining chars
	CAIN	A,"."+40	
	 MOVEI	A,0		;ignore dots at end of numbers for decimal base
	CAIN	A,":"+40
	 HRLI	AR4,(POINT 6,0,29) ;deposit : in last char position
	IDPB	A,AR4
	PRET

;subroutine to process next item in file name list
INXTIO:	JUMPE	T,FALSE
	CDRA	T,(T)
NXTIO:	CARA	A,(T)
	PCALL	ATOM
	JUMPE	A,CPOPJ		;non-atomic
	CARA	A,(T)
	JRST	SIXMAK		;make sixbit if atomic

IFN OCTPPN,<IOPPNX==NUMVAL>
PAGE
IOSUB:	PCALL	NXTIO
	MOVEM	T,DEVDAT#
	LDB	B,[POINT 6,A,35]
	JUMPE	A,IOPPN		;non-atomic item, must be ppn or (file.ext)
	CAIE	B,":"-40
	 JRST	IOFIL		;not a device name -- must be file name
	TRZ	A,77		;clear out the :
 IFN OPSYS,PCALL CHKDIR
IODEV2:	MOVEM	A,DEV
	PCALL	INXTIO
	JUMPN	A,IOFIL2	;not ppn or (fil.ext)
IOPPN:	JUMPE	T,FIL
	PCALL	PPNEXT
	JUMPN	A,IOEXT		;(fil.ext)
	CARA	A,(T)
	CARA	A,(A)		;caar is project number
	PCALL	IOPPNX
	HRLM	A,PPN		;project number
	CARA	A,(T)
	PCALL	CADR		;cadar is programmer number
	PCALL	IOPPNX	
	HRRM	A,PPN		;programmer number
	MOVSI	A,(SIXBIT /DSK/)	;disk is assumed
	JRST	IODEV2

IOFIL:	JUMPN	A,IOFIL3	;was it an atom
	JUMPE	T,FIL		;no, was it nil (end)
	PCALL	PPNEXT
	JUMPE	A,CPOPJ		;see a ppn, no file named
IOEXT:	CARA	A,(T)		;(file.ext)
	CDRA	A,(A)		;get cdr == extension
	PCALL	SIXMAK
	HLLZM	A,EXT
	CARA	A,(T)
	CARA	A,(A)		;get car = file name
	PCALL	SIXMAK
FIL:	JUMPE	T,.+2
	 CDRA	T,(T)
	SKIPE	DEV
	 PRET
	PSAVE	A		;no device named
	MOVSI	A,(SIXBIT /DSK/)
	MOVEM	A,DEV
	JRST	POPAJ

IOFIL2:	LDB	B,[POINT 6,A,35]
	CAIN	B,":"-40
	 JRST	FALSE		;saw a :,not file name
IOFIL3:	SETZM	EXT		;file name -- clear extension
	JRST	FIL
PAGE
PPNEXT:	CARA	A,(T)
	CDRA	A,(A)		;cdar
	JRST	ATOM		;ppn iff (not(atom(cdar l)))

IFE OCTPPN,<
IOPPNX:	PCALL	SIXMAK
	TRNE	A,77
	PRET
	LSH	A,-6
	JRST	.-3 >

IFN OPSYS,<
CHKDIR:	CAME	A,[SIXBIT /DIR/]	;i.e., (... DIR: directory filename ...)
	 PRET
	PSAVE	T
	PCALL	INXTIO
	JUMPE	A,NIXDIR	;NON-ATOMIC.
	CARA	A,(T)
	PCALL	PNAMUK
	SETZM	1(C)
IFG OPSYS ,<
	MOVSI	A,400000
	HRROI	B,1(SP)
	STDIR
	 JRST	NIXDIR
	 JRST	NIXDIR
	HRRZM	A,PPN	>
IFL OPSYS, <
	HRLI	A,440700	; MAKE UP A
	HRRI 	A,1(SP)		; BYTE POINTER
	MOVE 	B,A
	MOVEI	C,"<"
LP1:	ILDB	4,A
	IDPB	C,B
	MOVE	C,4
	JUMPN	C,LP1
	MOVEI	C,">"		; PUT IN LEFT BRACKET
	IDPB	C,B
	IDPB	4,B
	MOVEI	A,0
	HRROI	B,1(SP)
	RCDIR
	 ERJMP	NIXDIR
SYSNU:	HRLI	C,X
	MOVEM	C,PPN	>
	P1DROP			;SLUFF.
USEDSK:	MOVSI	A,(SIXBIT /DSK/)
	PRET

NIXDIR:	PREST	T		;TRY AS FILENAME INSTEAD.
	JRST	USEDSK
	    >		;end of IFN OPSYS
PAGE
;subroutine to reset all i/o channels	-- used by excise and realloc
IOBRST:	X			;jsr location
	HRRZ	A,.JBREL
	HRLM	A,.JBSA
	MOVEM	A,CORUSE
	MOVEM	A,.JBSYM
	SETZM	CHTAB+FSTCH
	MOVE	A,[XWD CHTAB+FSTCH,CHTAB+FSTCH+1]
	BLT	A,CHTAB+NIOCH+FSTCH-1	;clear channel table
	JRST	@IOBRST

CHTAB=.-FSTCH			;GC'D BY GCMKL AS AN ARRAY, SINCE LH=LIST,
	BLOCK	NIOCH		;[1-17]  RH=ADDR OF .JBFF DATA BLK.	;*

;channel data
CHNAM==0	;name of channel
CHDEV==1	;name of device
CHPPN==2	;ppn for input channel
CHOCH==3	;oldch for input channels
CHPAGE==4	;page number for input
CHLINE==5	;line number for input
CHDAT==6	;device data
POINTR==7	;byte pointer for device buffer
COUNT==10	;character count for device buffer
CHLL==2		;linelength for output channel
CHHP==3		;hposit for output channels
CHPL==4		;pagelength for output channel
CHVP==5		;vposit for output channels

;flags in left half of CHNAM
BINM==400000	;binary I/O
OUTM==1		;output

PAGE
OPEN:	JUMPE	A,.+3
	JSP	D,ATMTYP
	 PCALL	NCONS
	MOVE	T,A
	SETZB	A,DEV
FOO	CAIE	B,INBIN
FOO	CAIN	B,OUTBIN
	 TLO	A,BINM		;binary I/O
FOO	CAIE	B,OUTPUT
FOO	CAIN	B,OUTBIN
	 TLO	A,OUTM		;output
FOO	CAIE	B,INPUT
	 JUMPE	A,[MOVE	A,B
		   ERRE1 ^D18,[SIXBIT /NOT A KEYWORD FOR OPEN!/]]
	MOVE	B,[-NIOCH,,FSTCH]
OPEN1:	SKIPN	C,CHTAB(B)
	 JRST	OPEN2		;found free channel without buffer
	SKIPN	CHNAM(C)
	 JRST	DEVCLR		;found free channel with buffer
	AOBJN	B,OPEN1		;try next channel
	ERRL0	^D130,[SIXBIT "NO I/O CHANNELS LEFT!"]

OPEN2:	PSAVE	A
	MOVEI	A,BLKSIZ
	PCALL	MORCOR		;expand core for buffer if necessary
	MOVE	C,A
	PREST	A
	HRRM	C,CHTAB(B)
DEVCLR:	HRRZ	C,CHTAB(B)
	HRR	A,B
	HLLOM	A,CHNAM(C)
	MOVEI	B,INUM0(B)
	PSAVE	B
	SETZM	PPN
	TLNE	A,OUTM
	 JRST	SETOUT
	PCALL	SETIN
	JRST	POPAJ
PAGE
SETIN:	PSAVE	A		;CHANNEL #.
	PCALL	IOSUB		;get device and file name
	MOVEM	A,LOOKIN	;file name
	MOVE	A,DEV
	CALLI	A,DEVCHR
	TLNN	A,INB
	 JRST	AIN.2		;not input device
	TLNN	A,AVLB
	 JRST	AIN.4		;not available
	PREST	A
	HLLZS	ININIT
	MOVEI	B,13
	SKIPGE	A
	 HRRM	B,ININIT	;BINARY-INBIN.
	DPB	A,[POINT 4,ININIT,ACFLD]	;set up channel numbers
	DPB	A,[POINT 4,INLOOK,ACFLD]
	DPB	A,[POINT 4,ININBF,ACFLD]
	HRRZ	B,CHTAB(A)
	HRLM	T,CHTAB(A)	;save remaining file name list
	MOVEI	A,CHDAT(B)
	MOVEM	A,DEV+1		;pointer to bufdat
IFN SYDEV,<PCALL SYSDEV>	;Check for SYS:
ININIT:	INIT	X,X		;INIT	CHN#,STATUS
DEV:	 X			;SIXBIT	/DEV/
	 X			;XWD	0,IBUF
	 JRST	AIN.7		;cant init
	PUSH	B,DEV
	PUSH	B,PPN
INLOOK:	LOOKUP	X,LOOKIN
	 JRST	AIN.7		;cant find file
	PUSH	B,[0]		;oldch
	PUSH	B,[0]		;line number
	PUSH	B,[0]		;page number
	ADDI	B,4
	HRRM	B,.JBFF
ININBF:	INBUF	X,NIOB
	JRST	TRUE
PAGE
IFN SYDEV, <			;shunt SYS: to <LISP>'s dir (or wherever).
SYSDEV:	MOVSI	A,(SIXBIT /SYS/)
	CAME	A,DEV
	 PRET
IFG OPSYS,<MOVSI A,(SIXBIT /DSK/)>
IFLE OPSYS,<MOVE A,SYSNUM>
	MOVEM	A,DEV
IFG OPSYS,<PSAVE SYSNUM
	PREST	PPN >
	PRET
>


ENTR:
LOOKIN:	BLOCK	4

EXT=LOOKIN+1
PPN=LOOKIN+3	

PAGE
SETOUT:	PSAVE	A
	PCALL	IOSUB		;get device and file name
	MOVEM	A,ENTR		;file name
	SETZM	ENTR+2		;zero creation date
	PREST	A
	DPB	A,[POINT 4,OUINIT,ACFLD]	;setup channel numbers
	DPB	A,[POINT 4,OUTENT,ACFLD]
	DPB	A,[POINT 4,OUTOBF,ACFLD]
	HRRZ	B,CHTAB(A)
	MOVEI	A,CHDAT(B)
	HRLM	A,DEVO+1
	MOVE	A,DEV
	MOVEM	A,DEVO
	CALLI	A,DEVCHR
	TLNN	A,OUTB
	 JRST	AOUT.2		;not output device
	TLNN	A,AVLB
	 JRST	AOUT.4		;not available
	HLLZS	OUINIT
	MOVEI	A,13
	SKIPGE	CHNAM(B)
	 HRRM	A,OUINIT	;BINARY-OUTBIN.
OUINIT:	INIT	X,X		;INIT	CHN#,STATUS
DEVO:	 X			;SIXBIT	/DEV/
	 X			;XWD	OBUF,0
	 JRST	AOUT.4		;cant init
	PUSH	B,DEV
OUTENT:	ENTER	X,ENTR
	 JRST	OUTERR		;cant enter
	PUSH	B,[LPTLL]	;linelength
	PUSH	B,[LPTLL]	;chrct
	PUSH	B,[LPTPL]	;pagelength
	PUSH	B,[0]		;linct
	ADDI	B,4
	HRRM	B,.JBFF
OUTOBF:	OUTBUF	X,NIOB
	JRST	POPAJ

OUTERR:	MOVE	A,DEVDAT
	LDB	B,[POINT 3,ENTR+1,35]
	CAIE	B,2
	 ERRE1	^D19,[SIXBIT /DIRECTORY FULL!/]
	ERRE1	^D20,[SIXBIT /FILE IS WRITE PROTECTED!/]
PAGE
INCNT:	MOVEI	A,NIL		;(CLOSE (RDS NIL))
	PSAVE	[JRST CLOSE]
RDS:	PSAVE	INCH#
	PCALL	IOSEL
	TLNE	A,OUTM		;test to see if it is an input channel
	 ERRL0	^D131,[SIXBIT/NO INPUT - RDS!/]
	SKIPN	TT
	 MOVEI	TT,TTOCH-CHOCH	;tty deselect
	MOVEI	D,CHOCH(TT)
	HRLI	D,OLDCH
	BLT	D,CHLINE(TT)	;save channel data
	JUMPE	A,ITTYRE	;select tty
	DPB	A,[POINT 4,TYI2X,ACFLD]	;set up channel numbers
	DPB	A,[POINT 4,TYI2Y,ACFLD]
	DPB	A,[POINT 4,TYI2Z,ACFLD]
	HRRM	B,TYI3		;set up tyi parameters
	HRRM	B,TYI3A
	MOVSI	B,CHOCH(C)
INC3:	HRRI	B,OLDCH
	BLT	B,LINUM		;restore channel data
	MOVEM	T,TYID
FOO	PREST	VINC
	EXCH	A,INCH		;flags,,channel#.
IOEND:	HRRZS	A
	JUMPN	A,FIXI
	PRET

ITTYRE:	MOVE	T,[JRST TTYI]	;reselect tty
	MOVSI	B,TTOCH
	JRST	INC3
PAGE
OUTCNT:	MOVEI	A,NIL		;(CLOSE (WRS NIL))
	PSAVE	[JRST CLOSE]
WRS:	PSAVE	OUTCH#
	PCALL	IOSEL
	TLNN	A,OUTM		;is it output channel
	 JUMPN	A,[ERRL0 ^D132,[SIXBIT /NO OUTPUT - WRS!/]]
	SKIPN	TT
	 MOVEI	TT,TTOLL-CHLL	;tty deselect
	MOVEI	D,CHLL(TT)
	HRLI	D,LINL
	BLT	D,CHVP(TT)	;save channel data
	JUMPE	A,OTTYRE	;return to tty
	DPB	A,[POINT 4,TYO2X,ACFLD]	;set up tyo2 channel numbers
	HRRM	B,TYO5		;set up tyo2 parameters
	MOVSI	B,CHLL(C)
OUTC3:	HRRI	B,LINL
	BLT	B,LNCT		;get channel data
	MOVEM	T,TYOD
FOO	PREST	VOUTC
	EXCH	A,OUTCH		;flags,,channel#.
	JRST	IOEND

OTTYRE:	MOVE	T,[JRST TTYO]
	MOVSI	B,TTOLL		;tty reselect
	JRST	OUTC3
PAGE
IOSEL:	PCALL	GCHNO		;convert into channel number
	SKIPE	TT,A
	 ADDI	TT,INUM0
	EXCH	TT,-1(P)
	SKIPE	TT
	 HRRZ	TT,CHTAB(TT)
	JUMPE	A,CPOPJ
	SKIPE	C,CHTAB(A)
	SKIPN	T,CHNAM(C)
	 JRST	CPOPJ1
	HLL	A,T
	MOVEI	B,POINTR(C)
	MOVEI	T,COUNT(C)
	HRLI	T,(SOSG)
	PRET

CLOSE:	PCALL	GCHNO		;convert into channel number
ICLOSE:	JUMPE	A,CPOPJ		;don't close terminal cannel
	SKIPE	D,CHTAB(A)
	 SETZM	CHNAM(D)	;blast channel name
	DPB	A,[POINT 4,.+1,ACFLD]
	RELEASE	X,		;release channel
	HRRZS	CHTAB(A)	;release channel table entry
	JRST	FIXI

;convert A into channel number
GCHNO:	SKIPE	A
	 SUBI	A,INUM0
	CAIG	A,NIOCH
	 JUMPGE	A,CPOPJ
	ADDI	A,INUM0
	ERRE1	^D21,[SIXBIT /IS NOT A CHANNEL NAME!/]


AOUT.2:
AIN.2:	MOVE	A,DEVDAT
	ERRE1	^D22,[SIXBIT /ILLEGAL DEVICE!/]
AOUT.4:
AIN.4:	MOVE	A,DEVDAT
	ERRE1	^D23,[SIXBIT /DEVICE NOT AVAILABLE!/]

AIN.7:	MOVE	A,DEVDAT
	ERRE1	^D24,[SIXBIT /CAN'T FIND FILE!/]
SUBTTL 	PRINT					--- PAGE 9

PRINT:	MOVEI	R,TYO
	PCALL	PRIN1
TERPRI:	PSAVE	A
	MOVEI	A,CRLF
TERPR1:	PCALL	TYO
CPOPAJ:	JRST	POPAJ

EJECT:	MOVEI	A,CR
	PCALL	TYO
	MOVEI	A,FORMF
	PCALL	TYO
	JRST	FALSE

PRINC:	PSAVE	A
	PCALL	GTFCH
	JRST	TERPR1

PRIN2:	SKIPA	R,.+1
PRIN1:	 HRRZI	R,TYO		;<HRRZI> = <551>, NEGATIVE FOR PRIN2.
	PSAVE	A
	PCALL	PRINTA
	JRST	POPAJ

PRINTA:	HLRZ	B,SLSH		;PRIN3 OR PRIN3C SET BY SCANSET
	SKIPGE	R
	 MOVEI	B,PRIN4
	HRRM	B,PRIN5
PRINT4:	PSAVE	A
	JSP	D,PATMTP
	 JRST	PRINT1
	XCT	"(",CTY
PRINT3:	MOVE	A,TT		;[if 0 --> NIL's 777777 --> ill mem ref].
	PCALL	PRINT4
	CDRA	A,@(P)
	JUMPE	A,PRINT2
	MOVEM	A,(P)
	XCT	" ",CTY
	JSP	D,PATMTP
	 JRST	.+2
	JRST	PRINT3
	XCT	".",CTY
	XCT	" ",CTY
	PCALL	PRIN1A
PRINT2:	XCT	")",CTY
	JRST	POPAJ
PAGE
PRINT1:	PSAVE	CPOPAJ
PRIN1A:	JUMPE	TT,PRINIC	;inum
	JUMPL	TT,PRINL	;not a Lisp expression
	CDRA	A,(A)
	CAIN	TT,ID
	 JUMPN	A,PRINN
	CAIL	TT,CODMIN
	 JRST	PCODE
	JUMPN	A,@PRITAB-ATMIN-1(TT)	;go to print routine for the given type
PRINL:	XCT	"#",CTY
	HLRZ	A,-1(P)
	JUMPE	A,.+3		;usually there is no left half
	 PCALL	PRINL1
	 XCT	",",CTY
	HRRZ	A,-1(P)
PRINL1:	MOVEI	C,8
PRINI3:	JUMPL	A,[MOVE	 B,0	;case of -2^35
		   MOVEI A,1
		   DIVI  A,(C)
		   JRST  .+2]
	IDIVI	A,0(C)
	HRLM	B,(P)
	SKIPE	A
	 PCALL	.-3
	JRST	FP7A1

PRITAB:		BPRI		;negative bignum
		BPRI+1		;positive bignum
		PRINI1		;integer
		PRINO		;floating point number
		PSTR		;string
		PVEC		;vector
PAGE
PRINL2:	MOVEI	R,TYO
	JRST	PRINL1

PRINI1:	SKIPA	A,(A)
PRINIC:	SUBI	A,INUM0
FOO	CDRA	C,VBASE
	SUBI	C,INUM0
	JUMPGE	A,PRINI2
	XCT	"-",CTY
	MOVNS	A
PRINI2:	PCALL	PRINI3
PRINI4:
IFN ROCT,<CAIN	C,10
	 JRST	POCTNM>
	CAIN	C,TEN
FOO	SKIPE	%NOPOINT
	PRET
	MOVEI	A,"."
	JRST	(R)

IFN ROCT,<
POCTNM:	JUMPL	R,CPOPJ
	MOVEI	A,"L"
	JRST	(R) >

PVEC:	PSAVE	-1(A)
	HRLI	A,(POINT 18)
	PSAVE	A
	MOVEI	A,"["
	PCALL	(R)
	JRST	PVECL+1

PVECL:	XCT	",",CTY
	ILDB	A,(P)
	PCALL	PRINT4
	SOSL	-1(P)
	JRST	PVECL
	MOVEI	A,"]"
	P2DROP
	JRST	(R)

PCODE:	XCT	"#",CTY
	XCT	"#",CTY
	JRST	PRINL1

CTY:	JSA	A,TYOI
TYOI:	X
	PSAVE	A
	LDB	A,[POINT 6,-1(A),ACFLD]
	PCALL	(R)
	PREST	A
	JRA	A,(A)
PAGE
PRINN:
FOO	MOVEI	B,PNAME
	PCALL	GET4
	JUMPE	A,PRINL
	CARA	A,D
	PCALL	PRIDST
	ILDB	A,C
	JUMPE	A,CPOPJ		;special case of null character
PRIN2X:	JUMPL	R,PRIN4		;never slash
	LDB	B,SL1FLD
	JRST	PRIN2N(B)	;1 for no slash

PRIN3:	SKIPL	CHRTAB(A)	;<0 for no slash
PRIN2N:	PCALL	SLSHPR		;slashify
PRIN4:	PCALL	(R)
	ILDB	A,C
PRIN5:	JUMPN	A,PRIN3+X	;prin4 for never slash
	PRET

PSTR:	PCALL	PRIDST
	MOVE	A,STRBEG
	JRST	PSTR3

PSTREC:	PCALL	(R)
	MOVE	A,STREND
PSTR3:	SKIPL	R		;dont print " if no slashify
PSTR2:	PCALL	(R)
	ILDB	A,C
	CAMN	A,STREND
	 JRST	PSTREC
	JUMPN	A,PSTR2
	MOVE	A,STREND
	JUMPGE	R,(R)
	PRET

PRIDST:	MOVEI	C,2(SP)
	PCALL	PNAMU3
	PUSH	C,[0]
	HRLI	C,(POINT 7,0,35)
	HRRI	C,2(SP)
	PRET

SLSHPR:	PSAVE	A
	HRRZ	A,SLSH
	PCALL	(R)
	JRST	POPAJ
PAGE
PRINO:	MOVE	A,(A)
	SETZB	B,C
	JUMPG	A,FP1
	JUMPE	A,FP3
	MOVNS	A
	XCT	"-",CTY
FP1:	CAMGE	A,FT01
	 JRST	FP4
	CAML	A,FT8
	 AOJA	B,FP4
FP3:	MULI	A,400
	ASHC	B,-243(A)
	MOVE	A,B
	SETZM	FPTEM#
	PCALL	FP7
	XCT	".",CTY
	MOVNI	T,8
	ADD	T,FPTEM
	MOVE	B,C
FP3A:	MOVE	A,B
	MULI	A,TEN
	PCALL	FP7B
	SKIPE	B
	 AOJL	T,FP3A
	PRET

FP4:	MOVNI	C,6
	MOVEI	TT,0
FP4A:	ADDI	TT,1(TT)
	XCT	FCP(B)
	TRZA	TT,1
	 FMPR	A,@FCP+1(B)
	AOJN	C,FP4A
	PSAVE	TT
	MOVNI	B,-2(B)
	DPB	B,[POINT 2,FP4C,11]
	PCALL	FP3
	MOVEI	A,"E"
	PCALL	(R)
FP4C:	XCT	"+"+X,CTY
	PREST	A
FP7:	JUMPE	A,FP7B
	IDIVI	A,TEN
	AOS	FPTEM
	HRLM	B,(P)
	JUMPE	A,FP7A1
	PCALL	FP7
FP7A1:	HLRE	A,(P)
FP7B:	ADDI	A,"0"
	JRST	(R)
PAGE
	353473426555	;1e32
	266434157116	;1e16
FT8:	1.0E8
	1.0E4
	1.0E2
	1.0E1
FT:	1.0E0
	026637304365	;1e-32
	113715126246	;1e-16
	146527461671	;1e-8
	163643334273	;1e-4
	172507534122	;1e-2
FT01:	175631463146	;1e-1
FT0:

FCP:	CAMLE	A,FT0(C)
	CAMGE	A,FT(C)
	XWD	C,FT0

SUBTTL 	SUPER FAST TABLE DRIVEN READ		--- PAGE 10

;magic scanner table bit definitions

;bit 0=0 iff slashified as nth id character
;bit 1=0 iff slashified as 1st id character
;bits 2-5	ratab index
;bits 6-8	dotab index
;bits 9-10	strtab index
;bits 11-13	idtab index
;bits 14-16	exptab index
;bits 17-19	rdtab index
;bits 20-25	ascii to radix 50 conversion

;bits used by the alternative SCANner

;bits 26-29	ratab index
;bits 30-31	strtab index
;bits 32-34	idtab	index
;bit 35=0 iff slashified as 1st id character
;bit 32=0 iff slashified as nth id character

;The following 8 words are modified by SCANSET and SCANRESET
IGEND:	CRLF
STRBEG:	DBLQT			;string start
STREND:	DBLQT			;string end
SLSH:	XWD	PRIN3,"!"	;slashtest,slashifier
SL1FLD:	POINT	1,CHRTAB(A),1
RATFLD:	POINT	4,CHRTAB(A),5
STRFLD:	POINT	2,CHRTAB(A),10
IDFLD:	POINT	3,CHRTAB(A),13

DOTFLD:
NUMFLD:	POINT	3,CHRTAB(A),8
EXPFLD:	POINT	3,CHRTAB(A),16
RDFLD:	POINT	3,CHRTAB(A),19
R50FLD:	POINT	6,CHRTAB(A),25

;magic state flags in t
EXP==1		;exponent 
NEXP==2		;negative exponent
SAWDOT==4	;saw a dot (.)
MINSGN==10	;negative number
IFN ROCT,<OCTNM==20	;octal number (saw a L)
	  RDIG==6 >
IFE ROCT,RDIG==5

;atom type in R for SCAN
IDCLS==0	;identifier
STRCLS==1	;string
NUMCLS==2	;number
DELCLS==3	;delimiter

PAGE
;macros for scanner table

DEFINE RAD50 (X)<
IFB <X>,<R50VAL=0>
IFLE <"X"-"9">,<IFGE <"X"-"0">,<R50VAL="X"-"0"+1>>
IFIDN <"X"><".">,<R50VAL=45>
IFIDN <"X"><"$">,<R50VAL=46>
IFIDN <"X"><"%">,<R50VAL=47>
IFGE <"X"-"A">,<R50VAL="X"-"A"+13>>

DEFINE TABIN (SN,S1,R,D,S,I,E,RD,R50,RE<2>,SE<3>,IE<2>,S1E<0>)<
XLIST
IRPC R50<	RAD50 (R50)
   BYTE  (1)SN,S1(4)R(3)D(2)S(3)I,E,RD(6)R50VAL(4)RE(2)SE(3)IE(1)S1E>
LIST>

DEFINE LET (X)<
TABIN (0,0,5,2,3,4,2,0,X)>

DEFINE SCNLET (X)<
TABIN (1,1,5,2,3,4,2,0,X,5,3,4,1)>

DEFINE DELIMIT (X,Y)<
TABIN (0,0,2,2,3,2,2,Y,X)>

DEFINE IGNORE (X)<
TABIN (0,0,3,2,3,2,2,0,X,3)>
PAGE
CHRTAB:
TABIN (0,0,1,1,1,1,1,0,< >,1,1,1)	
;null
LET (<        >)
IGNORE (<     >)		
;tab,lf,vtab,ff,cr
LET (<            >)	
;16 to 31
TABIN (0,0,0,0,0,0,0,0,< >,0,0,0)
;igmrk
LET (< >)
;33 -- <ESC> JUST A LETTER WHEN IN A FILE.
LET (<   >)
;34 to 36
IGNORE (<  >)			
;37 (EOL) and space
TABIN (0,0,4,2,3,3,2,0,< >,4,3,3)	
;!	the new slashifier
TABIN (0,0,9,2,2,2,2,0,< >,9,2)	
;"
LET (< $>)
;#$
TABIN (0,0,0,0,3,0,0,0,<%>,0,3,0)
;% is comment start
LET (< >)			
;&
TABIN (0,0,2,2,3,4,2,5,< >)	
;'	the new quote character
DELIMIT (< >,0)
DELIMIT (< >,1)
;()
LET (< >)			
;*
TABIN (0,0,3,2,3,4,2,0,< >)	
;+
TABIN (0,0,3,2,3,2,2,0,< >)
;,	ignored for READ, delimit for SCAN
TABIN (0,0,6,2,3,4,2,0,< >)	
;-
TABIN (0,0,7,3,3,2,2,4,<.>,7)
LET (< >)
;/	old slashifyer is just a letter now
TABIN (1,0,8,RDIG,3,4,3,0,<0123456789>,8,3,4)
LET (<  >)			
;:;
DELIMIT (< >,2)
;<	super paranthesis
LET (< >)
;=
DELIMIT (< >,3)
;>	super paranthesis
LET (< >)
;?
LET (< >)
;@	old quote character is just a letter now
SCNLET (<ABCD>)
TABIN (1,1,5,4,3,4,2,0,<E>,5,3,4,1)
;E exponent for floating point number
SCNLET (<FGHIJK>)
IFE ROCT,SCNLET(<L>)
IFN ROCT,<
TABIN (1,1,5,5,3,4,2,0,<L>,5,3,4,1)
;L ends an octal number >
SCNLET (<MNOPQRSTUVWXYZ>)
DELIMIT (< >,6)			
;[	vector start
LET (< >)			
;\
DELIMIT (< >,3)			
;]	vector end
LET (<   >)			
;^_`
SCNLET (<ABCDEFGHIJKLMNOPQRSTUVWXYZ>)	
;lower case
LET (<  >)			
;{
DELIMIT (< >,3)
;175 -- ALTMODE (ALSO DECUS' 33 CONVERTED DURING TTI INPUT).
LET (< >)
;~
DELIMIT (< >,6)			
;rubout
PAGE
IDCHTAB:BLOCK	"?"	;table of character ids. updated by INTERN and
FOO	XWD	0,QST
	BLOCK	100-"?"-1  ; REMOB.  refered to by READCH and EXPLODE.

READCH:	PCALL	TYI
RECH1:	TRNN	A,100
	 SKIPA	C,IDCHTAB(A)
	 HLRZ	C,IDCHTAB-100(A)
	TRNE	C,-1		;is it in character id table ?
	 JRST	RETC		;yes! return it
	PSAVE	TT		;save TT and 
	PSAVE	T		; T for EXPLODE
	LSH	A,35
	MOVE	C,SP
	PUSH	C,A
	PCALL	INTER0
	PREST	T
	PREST	TT
	PRET

READP1:	SETZM	NOINFG
READ0:	PSAVE	TYID
	PSAVE	OLDCH
	SETZM	OLDCH#
	HRLI	A,(JRST)
	MOVEM	A,TYID
	PCALL	READ+1
	PREST	OLDCH
	PREST	TYID
	PRET

RDRUB:	MOVEI	A,CR
	PCALL	TTYO
	MOVEI	A,LF
	PCALL	TTYO
	SKIPA	P,PSAV#
READ:	SETZM	NOINFG#		;0 means intern
	SKIPN	OLSCNV
	 JRST	READD
	SETZ	A,
	PCALL	SCANSET
	PSAVE	A
	PCALL	READD
	EXCH	A,(P)
	PCALL	SCANSET
	JRST	POPAJ

READD:	MOVEM	P,PSAV
	PCALL	READ1
	SETZM	PSAV
	PRET

READ1:	PCALL	RATOM
	PRET			;atom
	XCT	RDTAB2(B)
	JRST	READ1		;try again

RDTAB2:	JRST	READ2		;0	(
	JFCL			;1	)
	JRST	READ4		;2	<
	JFCL			;3	],>,$
	JFCL			;4	.
	JRST	RDQT		;5	'
	JRST	READVC		;6	[

READ2:	PCALL	RATOM
	JRST	READ2A		;atom
	XCT	RDTAB(B)
READ2A:	PSAVE	A
	PCALL	READ2
	PREST	B
	JRST	XCONS

RDTAB:	PCALL	READ2		;0	(
	JRST	FALSE		;1	)
	PCALL	READ4		;2	<
	JRST	READ5		;3	],>,$
	JRST	RDT		;4	.
	PCALL	RDQT		;5	'
	PCALL	READVC		;6	[

RDTX:	PCALL	RATOM
	PRET			;atom
	XCT	RDTAB2(B)
DOTERR:	SETZM	OLDCH
	ERRL0	^D133,[SIXBIT /DOT CONTEXT ERROR!/]

RDT:	PCALL	RDTX
	PSAVE	A
	PCALL	RATOM
	JRST	DOTERR
	CAIN	B,1
	 JRST	POPAJ
	CAIE	B,3
	 JRST	DOTERR
	MOVEM	A,OLDCH
	JRST	POPAJ


READ4:	PCALL	READ2
	MOVE	B,OLDCH
	CAIE	B,ALTMOD
TYI1:	 SETZM	OLDCH		;kill the > or ]
	PRET

READ5:	MOVEM	A,OLDCH		;save > or ] or $
	JRST	FALSE		;and return nil


RDQT:	PCALL	READ1
QTIFY:	PCALL	NCONS
FOO	HRLI	A,CQUOTE
	JRST	DCONSA

;skip a comment
COMENT:	CAIN	A,IGCRLF	;^Z ?
	 JRST	COMIGN		;yes. end on CRLF
	MOVE	A,IGEND		;no. end on IGEND
	HRRM	A,COMM+1	;set end char
COMM:	PCALL	TYIC		;AR4 must contain 1 here
	CAIE	A,CRLF+X
	 JRST	COMM
	PRET

;skip a super (^Z) comment
COMIGN:	PCALL	TYID1		;AR4 must contain 1 here
	CAIE	A,CRLF
	 JRST	COMIGN
	PRET

PAGE
READVC:	PCALL	READ2
	MOVE	B,OLDCH
ENDVC:	CAIN	B,"]"
	 SETZM	OLDCH
LTOVEC:	JUMPE	A,CPOPJ
	PSAVE	A		;save list
	CDRA	A,(A)
	PCALL	LENGTH
	PCALL	MKVECT		;make a vector
	CDRA	B,(A)
	EXCH	A,(P)
	MOVSI	C,(POINT 18,(B))
	MOVS	A,(A)
	IDPB	A,C
	CARA	A,A
	JUMPN	A,.-3
	JRST	POPAJ

PAGE
;atom parser

RATOM:	SETZB	T,R		;IDCLS in R
	HRLI	C,(POINT 7,0,35)
	HRRI	C,(SP)
	SETZM	1(C)		;clear first word
	MOVEI	AR4,1
RATOM2:	PCALL	TYID1
	LDB	B,RATFLD
	JRST	RATAB(B)

RATAB:	PCALL	COMENT		;0	comment
	JRST	RATOM2		;1	null
	JRST	RATOM3		;2	delimit
	JRST	RATOM2		;3	ignore
	PCALL	TYIC		;4	!
	JRST	RDID		;5	letter
	JRST	RDNMIN		;6	-
	JRST	RDOT		;7	.
	JRST	RDNUM		;8	digit
	JRST	RDSTR		;9	string

;a real dotted pair
RDOT2:	MOVEM	A,OLDCH
	MOVEI	A,"."
RATOM3:	LDB	B,RDFLD
	HRRI	R,DELCLS	;delimiter
CPOPJ1:	PSKPRT			;non-atom (ie a delimiter)
	PRET

;dot handler
RDOT:	PCALL	TYID1
	LDB	B,DOTFLD
	JRST	DOTAB(B)

DOTAB:	PCALL	COMENT		;0	comment
	JRST	RDOT		;1	null
	JRST	RDOT2		;2	delimit
	JRST	RDOT2		;3	dot
	JRST	RDOT2		;4	E
IFN ROCT,JRST	RDOT2		;5	L
	MOVEI	B,0		;6 (5)	digit
	IDPB	B,C
	TLO	T,SAWDOT
	JRST	RDNUM
PAGE
;string scanner
STRTAB:	PCALL	COMENT		;0	comment
	JRST	RDSTR		;1	null
	JRST	STR2		;2	delimit
	IDPB	A,C		;3	string element
RDSTR:	PCALL	TYID1
	LDB	B,STRFLD	;A huge string (e.g. missing close-quote)
	JRST	STRTAB(B)	;  will overflow SPDL and clobber I/O bufs.

STR2:	PCALL	TYID1
	LDB	B,STRFLD
	CAIN	B,2
	 JRST	RDSTR-1
	MOVEM	A,OLDCH
	HRRI	R,STRCLS	;string
LMKSTR:	PCALL	IDEND
MSTR1:	PCALL	IDSUB
	PCALL	PNAMAK
	HRLI	A,STRNG
	JRST	DCONSA


;identifier scanner
IDTAB:	PCALL	COMENT		;0	
	JRST	RDID+1		;1	null
	JRST	MAKID		;2	delimit
	PCALL	TYIC		;3	!
RDID:	IDPB	A,C		;4	letter or digit
	PCALL	TYID1
	LDB	B,IDFLD	
	JRST	IDTAB(B)

PAGE
;number scanner
NUMTAB:	PCALL	COMENT		;0	comment
	JRST	RDNUM+1		;1	null
	JRST	NUMAK		;2	delimit
	JRST	RDNDOT		;3	dot
	JRST	RDE		;4	e
IFN ROCT,JRST	OCTNUM		;5	L
RDNUM:	IDPB	A,C		;6 (5)	digit
	PCALL	TYID1
	LDB	B,NUMFLD
	JRST	NUMTAB(B)

RDNDOT:	TLOE	T,SAWDOT
	JRST	NUMAK		;two dots - delimit
	MOVEI	A,0
	JRST	RDNUM

RDNMIN:	TLO	T,MINSGN
	JRST	RDNUM+1

;exponent scanner
RDE:	TLO	T,EXP
	MOVEI	A,0
	IDPB	A,C
	PCALL	TYID1
	CAIN	A,"-"
	TLOA	T,NEXP
	CAIN	A,"+"
	JRST	RDE2+1
	JRST	RDE2+2

EXPTAB:	PCALL	COMENT		;0
	JRST	RDE2+1		;1	null
	JRST	NUMAK		;2	delimit
RDE2:	IDPB	A,C		;3	digit
	PCALL	TYID1
	LDB	B,EXPFLD
	JRST	EXPTAB(B)

IFN ROCT,<
OCTNUM:	TLO	T,OCTNM
	PCALL	TYID1
	LDB	B,NUMFLD
	SOJG	B,NUMAK
	JUMPL	B,OCTNUM+1
	PCALL	COMENT
	JRST	B,OCTNUM+1 >
PAGE
;semantic routines
;identifier interner and builder

IDEND:	TDZA	A,A
IDEND1:	IDPB	A,C
	TLNE	C,760000
	 JRST	IDEND1 
	PRET

MAKID:	MOVEM	A,OLDCH
	PCALL	IDEND
	SKIPE	NOINFG
	 JRST	NOINTR		;dont intern it
INTER0:	PCALL	INTER2		;is it in oblist
	 PRET			;found
	PCALL	PNAIMK		;not there
MAKID2:	SKIPGE	C,IDCHPO#	;character id ?
	 JRST	MKID2		;no!
	TRNN	C,100
	 JRST	.+3
	HRLM	A,IDCHTAB-100(C)
	JRST	MKID2
	HRRM	A,IDCHTAB(C)
MKID2:	MOVE	C,CURBUC
	HLRZ	B,@RHX2
	PCALL	CONS		;cons it into the oblist
	HRLM	A,@RHX2
	JRST	CAR
CURBUC:	0	

;pname unmaker
PNAMUK:	MOVE	C,SP
PNAMUD:	PCALL	GETPNM
PNAMU3:	CARA	B,(A)
	PUSH	C,(B)
	CDRA	A,(A)
	JUMPN	A,PNAMU3 
	PRET

;idsub constructs a iowd pointer for a print name
IDSUB:	HRRZS	C
	CAML	C,JRELO		;top of spec pdl
	 JRST	SPDLOV
	MOVNS	C
	ADDI	C,(SP)
	HRLZS	C
	HRRI	C,1(SP)
	MOVEM	C,IDPTR#
	MOVEI	B,1
	ANDCAM	B,(C)		;clear low bit
	AOBJN	C,.-1
	PRET

NOINTR:	PCALL	IDSUB
PNAIMK:	PCALL	PNAMAK
	JRST	PNGNK1
PAGE
	;identifier interner
INTERT:	PCALL	PNAMUK
INTER2:	PCALL	IDSUB
INTER1:	MOVE	B,1(SP)		;get first word of pname 
	LSH	B,-1		;right justify it 
	SETOM	IDCHPO		;indicate no character id
	TDNE	B,[1777,,777777]	;character id ?
	 JRST	INT1		;no!
	MOVE	T,B
	LSH	T,-12
	HLRZM	T,IDCHPO	;is a character id
INT1:	IDIVI	B,BCKETS+X	;compute hash code 
RHX2:
FOO	HLRZ	T,OBTBL(B+1)	;get bucket 
	MOVEM	B+1,CURBUC	;save bucket number 
	MOVE	C,T
	JRST	MAKID1

MAKID3:	MOVE	C,T		;save previous atom 
	CDRA	T,(T)		;get next atom 
MAKID1:	JUMPE	T,CPOPJ1	;not in oblist
	CARA	A,(T)		;next id in oblist
FOO	MOVEI	B,PNAME
	PCALL	IGET
	JUMPE	A,[ERRL2 ^D167,[SIXBIT \MISSING PRINT NAME IN OBLIST!\]]
	MOVE	D,IDPTR		;found pname
MAKID5:	JUMPE	A,MAKID3	;not the one
	MOVS	A,(A)
	MOVE	B,(A)
	CAME	B,(D)
	 JRST	MAKID3		;not the one
	CARA	A,A		;ok so far
	AOBJN	D,MAKID5
	JUMPN	A,MAKID3	;not the one
	CARA	A,(T)		;this is it
	CARA	B,(C) 
	RPLCA	A,(C) 
	RPLCA	B,(T) 
	PRET

;pname builder
PNAMAK:	MOVE	T,IDPTR
	MOVEI	TT,C
PNAMB:	MOVE	A,(T)
	PCALL	FWCONS
	PCALL	NCONS
	RPLCD	A,(TT)
	MOVE	TT,A
	AOBJN	T,PNAMB
RETC:	HRRZ	A,C
	PRET
PAGE
;number builder
NUMAK:	MOVEM	A,OLDCH
	HRRI	R,NUMCLS	;number
	MOVEI	A,0
	IDPB	A,C
	IDPB	A,C
	HRRZS	C
	CAML	C,JRELO		;top of spec pdl
	 JRST	SPDLOV
	MOVSI	C,(POINT 7,0,35)
	HRRI	C,(SP)
	TLNE	T,SAWDOT+EXP
	 JRST	NUMAK2		;decimal number or flt pt
FOO	MOVE	A,VIBASE	;ibase integrer
	SUBI	A,INUM0
IFN ROCT,<TLNE	T,OCTNM
	  MOVEI	A,10		;octal number >
	PCALL	NUM
NUMAK4:
	MOVEI	B,FIXNU
NUMAK6:	TLNE	T,MINSGN
	 MOVNS	A
	JRST	MAKNUM

NUMAK2:	PCALL	NUM10
	MOVEM	A,TT
	TLNN	T,SAWDOT
	 JRST	[PCALL	FLOAT1	;flt pt without fraction
		 MOVE	TT,A
		 JRST	NUMAK3]
	PCALL	NUM10		;fraction part
	EXCH	A,TT
	TLNN	T,EXP
	 JUMPE	AR5,NUMAK4	;no exponent and no fraction
	PCALL	FLOAT1
	EXCH	A,TT
	PCALL	FLOAT1
	MOVEI	AR4,FT01
	PCALL	FLOSUB
	FMPR	A,B
	FADRM	A,TT
NUMAK3:	PCALL	NUM10		;exponent part
	MOVE	AR5,A
	MOVEI	AR4,FT-1
	TLNE	T,NEXP
	 MOVEI	AR4,FT01	;-exponent
	PCALL	FLOSUB
	FMPR	TT,B		;positive exponent
	MOVEI	B,FLONU
	MOVE	A,TT
	JFCL	10,FLOOV
	JRST	NUMAK6
PAGE
FLOSUB:	MOVSI	B,(1.0)
	TRZE	AR5,1
	 FMPR	B,(AR4)
	JUMPE	AR5,CPOPJ
	LSH	AR5,-1
	SOJA	AR4,FLOSUB+1

;variable radix integer builder

NUM10:	MOVEI	A,TEN
NUM:	HRRM	A,NUM1
	JFCL	10,.+1		;clear carry0 flag 
	SETZB	A,AR5
NUM2:	ILDB	B,C
	JUMPE	B,CPOPJ	;done
NUM1:	IMULI	A,X
	ADDI	A,-"0"(B)
NUM3:	JFCL	10,RDBNM
	AOJA	AR5,NUM2
PAGE
INTERN:	MOVEM	A,AR5
	PCALL	INTERT		;is it in oblist
	 PRET			;found it
	MOVE	A,AR5		;not there
	CARA	B,(A)
	CAIE	B,STRNG
	 JRST	MAKID2		;put it there
	CDRA	A,(A)
	PCALL	PNGNK1		;make an id of it
	JRST	MAKID2

REMOB:	JUMPE	A,CPOPJ		;never remove NIL
	JSP	D,NILID		;return NIL if not an id
	PSAVE	A
	PCALL	INTERT
	SKIPA	B,CURBUC
	JRST	POPAJ		;not on oblist
RHX5:
FOO	HLRZ	C,OBTBL+X(B)
	CARA	T,(C)
	CAMN	T,A
	 JRST	[CDRA TT,(C)
		HRLM TT,@RHX5
		JRST POPAJ]
REMOB3:	MOVE	TT,C
	CDRA	C,(C)
	CARA	T,(C)
	CAME	T,A
	 JRST	REMOB3
	CDRA	T,(C)
	RPLCD	T,(TT)
	SKIPGE	C,IDCHPO	;character id ?
	 JRST	POPAJ		;no!
	TRNN	C,100
	 JRST	.+3
	HRRZM	IDCHTAB-100(C)
	JRST	POPAJ
	HLLZM	IDCHTAB(C)
POPAJ:	PREST	A
	PRET

;Get print name for identifier or string. Return with skip if sucessful.
GETPNM:	JSP	D,ATMTYP
	 JRST	.+2
NOPNAM:	ERRL0	^D134,[SIXBIT /NO PRINT NAME!/]
	CDRA	A,(A)
	CAIN	TT,STRNG	;is it a string?
	 JUMPN	A,CPOPJ		;yes
	CAIE	TT,ID
	 JRST	NOPNAM
FOO	MOVEI	B,PNAME
	PCALL	GET4
	JUMPE	A,NOPNAM	;didn't find it
	CARA	A,D
	PRET

PAGE
;return NIL if argument is not on the oblist
.INTERNP:JSP	D,NILID		;return NIL if not an id
	MOVE	AR5,A
	PCALL	GT1PNM		;get first word of pname
	MOVE	B,A
	LSH	B,-1
	XCT	INT1		;compute hash code
	XCT	INT1+1		;get bucket
	EXCH	A,T
	MOVE	B,AR5
	JRST	FLAGP1

;SKIPTO subr 1 arg. Skips reading until found character that matches
; first character in the argument
SKIPTO:	MOVEI	AR4,1
	PSAVE	A
	PCALL	GTFCH
	PCALL	COMM-1		;read as comment
	JRST	POPAJ

RDSLSH:	MOVE	D,[POINT 18,NQUOT]
	MOVE	R,[POINT 7,[ASCIZ "%'!@/<>["]]
	MOVEI	B,(5B3+2B6+3B8+4B11+2B14)	;Letter
	JUMPN	A,RDSL2
	MOVEI	B,(3B8)		;Comment
	 AOJA	D,RDSL2

RDSL1:	DPB	B,[POINT 18,CHRTAB(A),19]
	ILDB	B,D
RDSL2:	ILDB	A,R
	JUMPN	A,RDSL1
	JRST	SCANSET

NQUOT:	<5B3+2B6+3B8+4B11+2B14+0B17>+<5B21+2B24+3B26+4B29+2B32+0B35>
	<2B3+2B6+3B8+4B11+2B14+5B17>+<4B21+2B24+3B26+3B29+2B32+0B35>
	<5B3+2B6+3B8+4B11+2B14+0B17>+<5B21+2B24+3B26+4B29+2B32+0B35>
	<2B3+2B6+3B8+2B11+2B14+2B17>+<2B21+2B24+3B26+2B29+2B32+3B35>
	<2B3+2B6+3B8+2B11+2B14+6B17>
PAGE
; SCAN -- GENERAL PURPOSE ADAPTER FOR LISP SCANNER

OLDSCN:	CRLF			;IGEND
	DBLQT			;STRBEG
	DBLQT			;STREND
	XWD	PRIN3,"!"	;SLSH
	POINT	1,CHRTAB(A),1	;SL1FLD
	POINT	4,CHRTAB(A),5	;RATFLD
	POINT	2,CHRTAB(A),10	;STRFLD
	POINT	3,CHRTAB(A),13	;IDFLD

IGEND2:	CRLF+X			;IGEND
STRBE2:	DBLQT			;STRBEG
STREN2:	DBLQT			;STREND
SLSH2:	XWD	PRIN3C,"!"+X	;SLSH
SL1F2:	POINT	1,CHRTAB(A),35	;SL1FLD
RATF2:	POINT	4,CHRTAB(A),29	;RATFLD
STRF2:	POINT	2,CHRTAB(A),31	;STRFLD
IDF2:	POINT	3,CHRTAB(A),34	;IDFLD

LETFLD:	POINT	1,CHRTAB(A),32	;ON IF LETTER OR DIGIT
ALLFLD:	POINT	10,CHRTAB(A),35	;ALL NEW FIELDS

SCANSET:JUMPN	A,.+2
	 SKIPA	B,[XWD OLDSCN,IGEND]
	 MOVE	B,[XWD IGEND2,IGEND]
	BLT	B,IDFLD
	EXCH	A,OLSCNV#	;Get previous setting
	PRET

PRIN3C:	LDB 	B,LETFLD
	JRST	PRIN2N(B)
PAGE
SCAN:	SETOM	NOINFG
	PCALL	RATOM
	SKIPA
	PCALL	READCH+1
FOO	MOVEM	A,SCNV
	MOVEI	A,INUM0(R)
	PRET

UNREADCH:
	PSAVE	A
	PCALL	GTFCH
	MOVEM	A,OLDCH
	JRST	POPAJ

LETTER:	MOVEI	B,5B29+3B31+4B34+1B35
LET2:	SUBI	A,INUM0
	DPB	B,ALLFLD
	JRST	FALSE

DELIMITER:
	SKIPA	B,[2B29+3B31+2B34+0B35]	;A DELIMITER, NOT A LETTER.
IGNORE:	 MOVEI	B,3B29+3B31+2B34+0B35
	JRST	LET2
PAGE
SCANINIT: SUBI	A,INUM0
	SUBI	B,INUM0
	HRRM	A,IGST2		;IGSTRT
	MOVEM	B,IGEND2	;IGEND
	MOVEI	B,2B29+3B31+2B34+0B35	;DELIMITER
	MOVEI	A,177
	DPB	B,ALLFLD
	SOJG	A,.-1
	MOVE	A,[XWD	"A"-"Z"-1,"A"]
	MOVEI	B,5B29+3B31+4B34+1B35	;LETTER
	DPB	B,ALLFLD
	AOBJN	A,.-1
	MOVE	A,[XWD	"a"-"z"-1,"a"]
	DPB	B,ALLFLD
	AOBJN	A,.-1
	MOVE	A,[XWD	"0"-"9"-1,"0"]
	MOVEI	B,8B29+3B31+4B34+0B35	;DIGIT
	DPB	B,ALLFLD
	AOBJN	A,.-1
IGST2:	MOVEI	A,X
	MOVEI	B,0		;IGSTRT
	DPB	B,ALLFLD
	MOVEI	A,-INUM0(AR4)	;STREND
	MOVEM	A,STREN2
	MOVEI	B,2
	DPB	B,STRF2
	MOVEI	A,-INUM0(C)	;STRBEG
	MOVEM	A,STRBE2
	MOVEI	B,9
	DPB	B,RATF2
	MOVEI	A,-INUM0(AR5)
	HRRM	AR5,SLSH2	;SLASHIFIER
	MOVEI	B,4B29+3B31+3B34+0B35	;SLASHIFIER
	DPB	B,ALLFLD
	MOVEI	A,0		;NULL
	MOVEI	B,1B29+1B31+1B34+0B35	;NULL
	DPB	B,ALLFLD
	MOVEI	A,"."
	MOVEI	B,7
	DPB	B,RATF2
	SETZM	CHRTAB+IGCRLF	;^Z IS ALWAYS A COMMENT-CHAR.
	JRST	FALSE
SUBTTL 	LISP INTERPRETER SUBROUTINES		--- PAGE 11
IF1,PURGE CDR

CADDDR:	SKIPA	A,(A)
CADDAR:	CARA	A,(A)
CADDR:	SKIPA	A,(A)
CADAR:	CARA	A,(A)
CADR:	SKIPA	A,(A)
CAAR:	CARA	A,(A)
CAR:	CARA	A,(A)
	PRET

CDDDDR:	SKIPA	A,(A)
CDDDAR:	CARA	A,(A)
CDDDR:	SKIPA	A,(A)
CDDAR:	CARA	A,(A)
CDDR:	SKIPA	A,(A)
CDAR:	CARA	A,(A)
CDR:	CDRA	A,(A)
	PRET

CAADDR:	SKIPA	A,(A)
CAADAR:	CARA	A,(A)
CAADR:	SKIPA	A,(A)
CAAAR:	CARA	A,(A)
	JRST	CAAR

CDADDR:	SKIPA	A,(A)
CDADAR:	CARA	A,(A)
CDADR:	SKIPA	A,(A)
CDAAR:	CARA	A,(A)
	JRST	CDAR

CAAADR:	SKIPA	A,(A)
CAAAAR:	CARA	A,(A)
	JRST	CAAAR

CDDADR:	SKIPA	A,(A)
CDDAAR:	CARA	A,(A)
	JRST	CDDAR

CDAADR:	SKIPA	A,(A)
CDAAAR:	CARA	A,(A)
	JRST	CDAAR

CADADR:	SKIPA	A,(A)
CADAAR:	CARA	A,(A)
	JRST	CADAR

RPLACA:	RPLCA	B,(A)
	PRET

RPLACD:	RPLCD	B,(A)
	PRET
PAGE
QUOTE:	CARA	A,(A)	;car and quote duplicated for backtrace
	PRET

AASCII:	PCALL	NUMVAL
	LSH	A,^D29
PNGNK2:	PCALL	BNCONS
PNGNK1:
FOO	HRLI	A,PNAME
	PCALL	DCONSA
	PCALL	NCONS
IDCONS:	HRLI	A,ID
	JRST	DCONSA

NCONS:	HRLZS	A
	JRST	DCONSA

CONS:	EXCH	B,A
XCONS:	HRL	A,B
DCONSA:
IFN	CNSPRB,<
	CAIN	F,ILLAD
	PCALL	AGC>
	EXCH	A,(F)
	EXCH	A,F
	AOS	CONSVAL
	PRET

FW0CNS:	MOVEI	A,0
FWCONS:	JUMPN	FF,FWC1
	EXCH	A,FWC0#
	PCALL	AGC
	EXCH	A,FWC0
FWC1:	EXCH	A,(FF)
	EXCH	A,FF
	PRET

PAGE
IFE STL,<
SASSOC:	PCALL	SAS1
	 JCALLF	0,(C)
	PRET

SAS0:	CARA	B,T
SAS1:	JUMPE	B,CPOPJ
	MOVS	T,(B)
	MOVS	TT,(T)
	CAIE	A,(TT)
	 JRST	SAS0
	CDRA	A,T
	JRST	CPOPJ1

ATSOC:	PCALL	SAS1
	 JRST	FALSE >		;end of IFE STL
IFN STL,<
ATSOC:	EXCH	A,B
	PCALL	GET4
	SKIPE	A
	 CDRA	A,TT >
	PRET

REVERSE:SKIPN	T,A
	 PRET
	MOVEI	A,NIL
	HLL	A,(T)
	CDRA	T,(T)
	PCALL	DCONSA
	JUMPN	T,.-3
CPOPJ:	PRET

LENGTH:	MOVEI	B,0
LNGTH1:	JSP	D,ATMTYP
	 JRST	FIX1
	CDRA	A,(A)
	AOJA	B,LNGTH1

LAST:	MOVE	C,A
	CDRA	A,(A)
	JSP	D,NATMTYP
	 JRST	LAST
	JRST	RETC

NATMTYP:SETZ	TT,
	CAILE	A,INUMIN
	 JRST	1(D)
	CARA	TT,(A)
	CAILE	TT,ATMIN
	 JRST	1(D)
	JRST	(D)
PAGE
PATOM:	MOVEI	D,TRFA
PATMTP:	JUMPE	A,NILIN
	SETZ	TT,
	CAILE	A,INUMIN
	 JRST	(D)		;inum
	CAIGE	A,@GCP1		;Base of FWS
	CAIGE	A,@GCPP1	;Base of FS
	 SOJA	TT,(D)		;not a Lisp cell
NILIN:	CARA	TT,(A)
	CAILE	TT,ATMIN
	 JRST	(D)		;atom
	JRST	1(D)

ATOM:	MOVEI	D,TRFA
ATMTYP:	SETZ	TT,
	CAILE	A,INUMIN
	 JRST	(D)		;inum
	CARA	TT,(A)
	CAILE	TT,ATMIN
	 JRST	(D)		;atom
	JRST	1(D)

PAIRP:	JSP	D,ATMTYP
	 MOVEI	A,NIL
	PRET

CONSTANTP:JSP	D,ATMTYP
	 CAIN	TT,ID
	 MOVEI	A,NIL
	PRET

STRINGP:JSP	D,ATMTYP
	 CAIE	TT,STRNG
	 MOVEI	A,NIL
	PRET

NUMBERP:JSP	D,ATMTYP
	 CAILE	TT,FLONU
FALSE:	 MOVEI	A,NIL
	PRET

FIXP:	JSP	D,ATMTYP
	 CAILE	TT,FIXNU
	 MOVEI	A,NIL
	PRET

FLOATP:	JSP	D,ATMTYP
	 CAIE	TT,FLONU
	 MOVEI	A,NIL
	PRET

INUMP:	CAIG	A,INUMIN
	 MOVEI	A,NIL
	PRET
PAGE
BIGP:	JSP	D,ATMTYP
CPOSNU:	 CAILE	TT,POSNU
	 JRST	FALSE
	JUMPE	TT,FALSE
	PRET

IDP:	MOVEI	D,TRUE
NILID:	CAILE	A,INUMIN
	 JRST	FALSE
	HLLE	TT,(A)
	AOJE	TT,(D)
	JRST	FALSE		;return NIL if not an id

;give error if not id
CHKID:	CAILE	A,INUMIN
	 JRST	NOID
	HLLE	TT,(A)
	AOJE	TT,(D)
NOID:	ERRE1	^D25,[SIXBIT /IS NOT AN IDENTIFIER!/]

EQ:	CAMN	A,B
TRFA:	 JRST	TRUE
	JRST	FALSE


ZEROP:	JSP	D,ONUMV
	 JRST	FALSE		;BIGNUM CAN'T BE ZERO
NOT:
NULL:	JUMPN	A,FALSE
TRUE:
FOO	MOVEI	A,TRUTH
	PRET

LITER:	PCALL	.INTERNP
	JUMPE	A,CPOPJ
	ROT	T,7
	CAIL	T,"A"
	CAILE	T,"z"
	 JRST	FALSE
	CAILE	T,"Z"
	CAIL	T,"a"
	 JRST	RETB
	JRST	FALSE

DIGIT:	PCALL	.INTERNP
	JUMPE	A,CPOPJ
	ROT	T,7
	CAIL	T,"0"
	CAILE	T,"9"
	 JRST	FALSE
	JRST	RETB
PAGE
IF1,<PURGE GET>	;MONSYM has defined GET, so purge it.
GETD:
FOO	MOVEI	B,FUNCELL
GET:	JSP	D,NILID		;return NIL if not id
IGET:	PCALL	GET1
	SKIPE	A
GET2:	CARA	A,D
	PRET

GET1:	CDRA	A,(A)
GET4:	JUMPE	A,CPOPJ
GET0:	MOVS	TT,(A)
	MOVS	D,(TT)
	CAIN	B,(D)
	 PRET
	CARA	A,TT
	JUMPN	A,GET0
	PRET

IFE STL,<
GETL:	CDRA	A,(A)
GETL0:	CARA	T,(A)
	CARA	T,(T)
	MOVE	C,B
GETL1:	MOVS	TT,(C)
	CAIN	T,(TT)
	 JRST	CAR
	CARA	C,TT
	JUMPN	C,GETL1
	CDRA	A,(A)
	JUMPN	A,GETL0
	PRET >

REMD:
FOO	MOVEI	B,FUNCELL
REMPROP:JSP	D,NILID		;return NIL if not id
REMP1:	MOVE	T,A
	CDRA	A,(T)
	JUMPE	A,CPOPJ		;we are done if it is not there
	MOVS	TT,(A)
	MOVS	D,(TT)
	CAIE	B,(D)
	 JRST	REMP1
	HLRM	TT,(T)
	JUMPN	T,GET2
	HLROM	TT,CNIL3		;reset NIL
	JRST	GET2

PAGE
PUTD:	EXCH	A,C
IPUTD:	PCALL	XCONS
	EXCH	A,C
FOO	MOVEI	B,FUNCELL
PUT:	JSP	D,CHKID
	MOVE	T,A
	MOVE	A,B
	JSP	D,CHKID
	MOVE	A,T
	PCALL	GET1
	JUMPN	A,CSET1
	MOVE	A,C
	PCALL	XCONS
	CDRA	B,(T)
	PCALL	CONS
	RPLCD	A,(T)
	JUMPN	T,CDAR
	RPLCD	A,CNIL3		;set NIL
	JRST	CDAR

CSET1:
FOO	CAIN	B,VALUE
	 CARA	TT,D
	RPLCD	C,(TT)
	JRST	RETC

IFE STL,<
DEFPROP:	
	CDRA	C,(A)
	CDRA	B,(C)
	CARA	A,(A)
	CARA	B,(B)
	CARA	C,(C)
	PSAVE	A
	PCALL	PUT
	JRST	POPAJ >

MKCODE:	PCALL	NUMVAL
IMKCODE:HRLI	A,CODE
	JRST	DCONSA

CODEP:	JSP	D,ATMTYP
	 CAIGE	TT,CODMIN
	 JRST	FALSE
	CAIL	TT,ID
	 MOVEI	A,NIL
	PRET
PAGE
FLAGP:	JSP	D,NILID
	CDRA	A,(A)
FLAGP1:	PCALL	MEMQ+1
	JUMPN	A,TRUE
	PRET

FLAG:	MOVEI	D,FLAG1
FLAGO:	HRRM	D,FLAGX
	MOVE	T,A
	MOVE	A,B
	JSP	D,CHKID		;flag indicator must be id
FLAGL:	JUMPE	T,FALSE
	CARA	A,(T)
FLAGX:	PCALL	X
	CDRA	T,(T)
	JRST	FLAGL

FLAG1:	JSP	D,CHKID		;may only flag id
	CDRA	A,(A)
	PCALL	MEMQ+1
	JUMPN	A,CPOPJ
	CARA	C,(T)
	CDRA	A,(C)
	PCALL	XCONS
FLAG2:	RPLCD	A,(C)
	JUMPN	C,CPOPJ
	RPLCD	A,CNIL3
	PRET

REMFLAG:JSP	D,FLAGO
	JSP	D,NILID
FLAG3:	MOVE	C,A
	CDRA	A,(C)
	JUMPE	A,CPOPJ
	CARA	D,(A)
	CAIE	B,(D)		;B is preserved by XCONS
	 JRST	FLAG3
	CDRA	A,(A)
	JRST	FLAG2

PAGE
EQUAL:	MOVE	C,P		;Unfortunately, if BIGNUMs are involved here,
EQUAL1:	CAMN	A,B		;  potential AGC so save your variables.
	 JRST	TRUE
	JSP	D,PATMTP
	 SKIPA	T,TT		;ATOM
	HRROI	T,(TT)
	EXCH	A,B
	JSP	D,PATMTP
	 JRST	EQLATM		;ATOM
	AOJGE	T,NOEQL		;not atom but first arg was
	PSAVE	A
	PSAVE	B
	CDRA	A,TT
	CARA	B,(B)
	PCALL	EQUAL1
	PREST	B
	PREST	A
	CDRA	A,(A)
	CDRA	B,(B)
	JRST	EQUAL1

EQLATM:	CAME	T,TT		;same atom type ?
	 JRST	NOEQL		;no, try for floating point
	JUMPLE	TT,NOEQL	;Inum and non lisp cell adresses must be EQ
	CAILE	TT,POSNU	;Bignum
	CAIN	TT,STRNG
	 JRST	EQS
	CAIN	TT,VECT
	 JRST	EQV
	CDRA	A,(A)
	CDRA	B,(B)
	MOVE	A,(A)
	CAMN	A,(B)
	 JRST	TRUE
NOEQL:	MOVE	P,C
	JRST	FALSE

PAGE
EQS:	CDRA	D,(A)
	CDRA	TT,(B)
EQS2:	JUMPE	D,NOEQL
	MOVS	D,(D)
	MOVS	TT,(TT)
	MOVE	B,(TT)
	CAME	B,(D)
	 JRST	NOEQL
	HLRZS	D
	HLRZS	TT
	JUMPN	TT,EQS2
	JUMPN	D,NOEQL
	JRST	TRUE

EQV:	CDRA	TT,(A)
	CDRA	D,(B)
	MOVE	B,-1(TT)
	CAME	B,-1(D)
	 JRST	NOEQL		;different size
	PSAVE	B
	HRLI	TT,(POINT 18)
	PSAVE	TT
	HRLI	D,(POINT 18)
	PSAVE	D
EQV2:	ILDB	A,(P)
	ILDB	B,-1(P)
	PCALL	EQUAL1
	SOSL	-2(P)
	 JRST	EQV2
	P3DROP
	JRST	TRUE

PAGE
SUBAS==EXARG
SUBBS==EXARG+1

SUBST:	MOVEM	A,SUBAS#	;Recurse..find subportion in C =B, and
	MOVEM	B,SUBBS#	;  re-CONS with A instead.
SUBS0:	MOVE	A,SUBAS
	MOVE	B,SUBBS
	PSAVE	C
	MOVE	A,C
	PCALL	EQUAL
	PREST	C
	JUMPN	A,SUBS3
	CAILE	C,INUMIN
	 JRST	SUBS1
	CARA	T,(C)
	CAILE	T,ATMIN
	 JRST	SUBS1
	PSAVE	C
	CARA	C,(C)
	PCALL	SUBS0
	EXCH	A,(P)
	CDRA	C,(A)
	PCALL	SUBS0
	PREST	B
	JRST	XCONS

SUBS1:	SKIPA	A,C
SUBS3:	HRRZ	A,SUBAS
	PRET
PAGE
NCONC:	JUMPE	A,PROG2
	MOVE	TT,A
	MOVE	C,TT
	CDRA	TT,(C)
	JUMPN	TT,.-2
	RPLCD	B,(C)
	PRET

APPEND:	JUMPE	A,PROG2
	MOVEI	C,AR4
	MOVE	TT,A
APP1:	CARA	A,(TT)
	PSAVE	B
	PCALL	CONS		;saves b
	PREST	B
	RPLCD	A,(C)
	MOVE	C,A
	CDRA	TT,(TT)
	JUMPN	TT,APP1
	JRST	RETAR4

PROGN:	SKIPN	B,A
	 PRET
PROGN1:	PSAVE	B
	CARA	A,(B)
	PCALL	EVAL
	PREST	B
COND2:	SKIPL	C,PA4
	 JRST	RETC		;exit if a RETURN was found
	CDRA	B,(B)
	SKIPL	PA3		;exit if a GO was found
	 JUMPN	B,PROGN1
	PRET

PAGE
MEMBER:	MOVEM	A,SUBAS
MEMB1:	JUMPE	B,FALSE
	MOVE	A,SUBAS
	PSAVE	B
	CARA	B,(B)
	PCALL	EQUAL
AJMN:	JUMPN	A,POPAJ
	PREST	B
	CDRA	B,(B)
	JRST	MEMB1

MEMQ:	EXCH	A,B
	JUMPE	A,CPOPJ
	MOVS	C,(A)
	CAIN	B,(C)
	PRET
	CARA	A,C
	JUMPN	A,MEMQ+2
	PRET

AND:	JUMPE	A,TRUE
	SKIPA	C,AJMN
OR:	MOVSI	C,(JUMPE A,)
	JUMPE	A,CPOPJ
	HRRI	C,ANDOR
	PSAVE	A
	PSAVE	C
	JRST	ANDORI

ANDOR:	EXCH	A,-1(P)
	CDRA	A,(A)
	JUMPE	A,POP1AJ
	MOVEM	A,-1(P)
ANDORI:	CARA	A,(A)
	PCALL	EVAL
	XCT	(P)
POP2J:	P2DROP
	PRET

POP1AJ:	P1DROP
	JRST	POPAJ
PAGE
GENSYM:	MOVE	B,[POINT 7,GNUM,34]
	MOVNI	C,4
	MOVEI	TT,"0"

GENSY2:	LDB	T,B
	AOS	T
	DPB	T,B
	CAIG	T,"9"
	 JRST	GENSY1
	DPB	TT,B
	ADD	B,[XWD 70000,0]
	AOJN	C,GENSY2

GENSY1:	MOVE	A,GNUM
	PCALL	FWCONS
	PCALL	NCONS
	JRST	PNGNK1

GNUM:	ASCII	/G0000/			;*

IFE STL,<
CSYM:	CARA	A,(A)
	PSAVE	A
	PCALL	GT1PNM
	MOVEM	A,GNUM
	JRST	POPAJ >

GT1PNM:	PCALL	GETPNM
	CARA	A,(A)
	MOVE	A,(A)
	PRET

PAGE
LIST:
FOO	MOVEI	B,CEVAL
	JRST	MAPCAR

ILIST:	MOVEI	T,0
	JUMPE	A,ILIST2
ILIST1:	PSAVE	A		;Evals list, leaving on P, & neg # in T.
	CARA	A,(A)
	PSAVE	TT
	HRLM	T,(P)
	PCALL	EVAL
ILIST3:	PREST	TT
	HLRE	T,TT
	EXCH	A,(P)
	CDRA	A,(A)
	SOS	T
	JUMPN	A,ILIST1
ILIST2:	JRST	(TT)

MAPCAN:	TLO	B,400000
MAPCON:	TLOA	B,100000
MAPCAR:	TLO	B,400000
MAPLIST:TLOA	B,200000
MAPC:	TLO	B,400000
MAP:	JUMPE	A,FALSE
	PSAVE	A
	HLLM	B,(P)
	HRLI	B,(FCALL 1,)
	PSAVE	B
	PSAVE	A
	HRLZM	P,(P)
MAPL2:	SKIPGE	-2(P)
	 CARA	A,(A)		;MAPC or MAPCAR.
	XCT	-1(P)
	LDB	C,[POINT 2,-2(P),2]
	JUMPE	C,MAP1
	TRNN	C,1
	 PCALL	NCONS
	JUMPE	A,MAP1		;Case of NIL returned in MAPCAN, MAPCON
	HLR	B,(P)
	RPLCD	A,(B)
	TRNE	C,1
	 PCALL	LAST
	HRLM	A,(P)
MAP1:	CDRA	A,@-2(P)
	HRRM	A,-2(P)
	JUMPN	A,MAPL2
	PREST	AR4
	P2DROP
	JRST	RETAR4
PAGE
PA3:	0	;lh=0=>rh =next prog statement		*
		;lh - =>rh = tag to go to
PA4:	-1,,0	;lh=-1,rh=pntr to prog less bound var list	*
		;lh=+,rh return value

PROG:	PSAVE	PA3
	PSAVE	PA4
	CARA	T,(A)
	CDRA	A,(A)
	HRROM	A,PA4
	MOVEM	A,PA3
	PUSH	SP,[0]		;mark for unbind
	JUMPE	T,PG0
PG7A:	CARA	A,(T)
	MOVEI	AR4,NIL
	PCALL	BIND
	CDRA	T,(T)
	JUMPN	T,PG7A
PG0:	SKIPA	T,PA3
PG5A:	MOVE	T,A
PG1:	JUMPE	T,PG2
	CARA	A,(T)
	CDRA	T,(T)
	CARA	B,(A)
	CAILE	B,ATMIN
	 JRST	PG1
	MOVEM	T,PA3
	PCALL	EVAL
	SKIPL	A,PA4
	 JRST	PG4		;return
	SKIPL	T,PA3
	 JRST	PG1	
PG5:	JUMPE	A,EG1
	CARA	TT,(A)
	CDRA	A,(A)
	CAIN	TT,(T)
	 JRST	PG5A		;found tag
	JRST	PG5

PG2:	TDZA	A,A
PG4:	HRRZS	A
	PCALL	UNBIND
ERRP4:	PREST	PA4
	PREST	PA3
	PRET

GO:	CARA	A,(A)
	HRROM	A,PA3
IFE STL,<CARA	B,(A)
	CAILE	B,ATMIN>
	 JRST	FALSE
IFE STL,<PCALL	EVAL
	JRST	GO+1>
PAGE
RETURN:	HRRZM	A,PA4
	PRET

SETQ:	CARA	B,(A)
	PSAVE	B
	PCALL	CADR
	PCALL	EVAL
	MOVE	B,A
	PREST	A
SET:	MOVE	AR4,B
	PCALL	BIND
	SUB	SP,[XWD 1,1]
RETAR4:	CDRA	A,AR4
	PRET

CON2:	CDRA	A,(T)
COND:	JUMPE	A,CPOPJ	;entry
	PSAVE	A
	CARA	A,(A)
	CARA	A,(A)
	PCALL	EVAL
	PREST	T
	JUMPE	A,CON2
	CARA	B,(T)
	JRST	COND2

EG1:	HRRZ	A,T
	ERRE1	^D26,[SIXBIT /UNDEFINED PROG TAG-GO!/]
SUBTTL 	ARITHMETIC SUBROUTINES			--- PAGE 12

IFE STL,<
;macro expander -- (foo a b c) is expanded into (*foo (*foo a b) c)
EXPAND:	MOVE	C,B
	CDRA	A,(A)
	PCALL	REVERSE
	JRST	EXPA1

EXPN1:	MOVE	C,B
EXPA1:	CDRA	T,(A)
	CARA	A,(A)
	JUMPE	T,CPOPJ
	PSAVE	A
	MOVE	A,T
	PCALL	EXPA1
	EXCH	A,(P)
	PCALL	NCONS
	PREST	B
	PCALL	XCONS
	HRL	A,C
	JRST	DCONSA >

PAGE

ADD1:	CAILE	A,INUMIN
	CAILE	A,ATMIN-1
	SKIPA	B,[INUM0+1]
	 AOJA	A,CPOPJ
.PLUS:	JSP	C,OP
	 ADD	A,TT
	 FADR	A,TT
	 JRST	BPLUS

SUB1:	CAILE	A,INUMIN+1
	CAILE	A,ATMIN
	SKIPA	B,[INUM0+1]
	 SOJA	A,CPOPJ
.DIF:	JSP	C,OP
	 SUB	A,TT
	 FSBR	A,TT
	 JRST	BDIF

.TIMES:	JSP	C,OP
	 IMUL	A,TT
	 FMPR	A,TT
	 JRST	BTIMES

.QUO:	CAIN	B,INUM0
	 JRST	ZERODIV
	JSP	C,OP
	 IDIV	A,TT
	 FDVR	A,TT
	 JRST	BQUO

.GREAT:	EXCH	A,B
	JUMPE	B,FALSE
.LESS:	JUMPE	A,CPOPJ
	CAIN	B,INUM0
	 JRST	MINUSP
	JSP	C,OP
	 JRST	COMP2
	 JRST	COMP2
	 JRST	BCMPR

COMP2:	CAML	A,TT
	 JRST	FALSE
	JRST	TRUE
PAGE
MAKNUM:	CAIN	B,FIXNU
	 JRST	FIX1A
FLO1A:	MOVEI	B,FLONU
	JRST	FQCONS

FIX1B:	SUBI	A,INUM0
	MOVEI	B,FIXNU
FQCONS:	PCALL	FWCONS
	JRST	XCONS

IF1,PURGE NUMVAL		;To avoid confusion with NUMVAL in STENEX
NUMVLX:	JFCL	17,.+1
ONUMV:	MOVEI	B,FIXNU
	CAILE	A,INUMIN
	 JRST	ONUMV1
	CARA	B,(A)
	CAILE	B,ATMIN
	CAILE	B,FLONU
NUMV2:	 ERRE1	^D27,[SIXBIT /IS NOT A NUMBER!/]
	CDRA	A,(A)
	CAIG	B,POSNU
	 JRST	(D)		;Normal return if bignum
	SKIPA	A,(A)
ONUMV1:	 SUBI	A,INUM0
	JRST	1(D)		;Return with skip if fixnum or flonum

NUMVAL:	CAILE	A,INUMIN
	 JRST	FIXV1
	CARA	D,(A)
	CAIE	D,FIXNU
	 ERRE2	^D46,[SIXBIT /IS NOT A WORD SIZE INTEGER/]
	CDRA	A,(A)
FIXV2:	SKIPA	A,(A)
FIXV1:	 SUBI	A,INUM0
	PRET
PAGE
FLOAT:	PSAVE	A
	JSP	D,ONUMV
	 JRST	BFLOT
	CAIN	B,FLONU
	 JRST	POPAJ
	MOVEI	D,FLO1A
	MOVEM	D,(P)
FLOAT1:	IDIVI	A,400000
	SKIPE	A
	 TLC	A,254000
	TLC	B,233000
	FADR	A,B
	PRET

FIX:	PSAVE	A
	JSP	D,ONUMV
	 JRST	POPAJ			;BIGNUM
	CAIE	B,FLONU
	 JRST	POPAJ
	MOVEM	A,(P)
	MULI	A,400
	TSC	A,A
	JFCL	17,.+1
	ASH	B,-243(A)
FIX2:	JFCL	10,BFIX
	P1DROP
FIX1:	MOVE	A,B
	JRST	FIX1A

MINUSP:	JSP	D,ONUMV
	 JRST	MINSP2		;BIGNUM
	JUMPGE	A,FALSE
	JRST	TRUE

MINUS:	JSP	D,NUMVLX
	 JRST	MINS2		;BIGNUM
	MOVNS	A
ABS2IN:	JFCL	10,FIXOV3
	JRST	MAKNUM

ABS:	JSP	D,NUMVLX
	 JRST	ABS2
	MOVMS	A
	JRST	ABS2IN
PAGE
DIVIDE:	CAIN	B,INUM0
	 JRST	ZERODIV
	JSP	C,OP
	 JRST	RDIV
	 JRST	ILLNUM
	 JRST	BDIV

RDIV:	JFCL	17,.+1
	IDIV	A,TT
	JFCL	10,DIVMB	;FREAK CASE OF -2**35 IN A.
	PSAVE	B
	PCALL	FIX1A
	EXCH	A,(P)
	PCALL	FIX1A
	PREST	B
	JRST	XCONS

REMAINDER:
	PCALL	DIVIDE
	JRST	CDR

FIXOV:	ERRL0	^D135,[SIXBIT /INTEGER OVERFLOW!/]
ZERODIV:ERRL0	^D136,[SIXBIT /ZERO DIVISOR!/]
FLOOV:	ERRL0	^D137,[SIXBIT /FLOATING OVERFLOW!/]
ILLNUM:	ERRL0	^D138,[SIXBIT /NON-INTEGRAL OPERAND!/]

GCD:	JSP	C,OP
	 JRST	GCD2
	 JRST	ILLNUM
	 JRST	BGCD

GCD2:	JFCL	17,.+1
	MOVMS	A
	MOVMS	TT
	JFCL	10,DIVMB	;FREAK CASE OF -2**35 IN A OR TT.
;euclid's algorithm
GCD3:	CAMG	A,TT
	 EXCH	A,TT
	JUMPE	TT,FIX1A
	IDIV	A,TT
	MOVE	A,B
	JRST	GCD3


DIVMB:	MOVEI	B,FIXNU
	PCALL	BIGTSB
	JRST	@2(C)
PAGE
;general arithmetic op code routine for mixed types

OP:	CAIG	A,INUMIN
	 JRST	OPA1
	SUBI	A,INUM0
	CAIG	B,INUMIN
	 JRST	OPA2
	HRREI	TT,-INUM0(B)
	XCT	(C)		;inum op  (cannot cause overflow)
FIX1A:	ADDI	A,INUM0
	CAILE	A,INUMIN
	CAILE	A,ATMIN
	 JRST	FIX1B
	PRET

NONUM1:	MOVE	A,TT
OPA1:	CARA	T,(A)
	CAILE	T,ATMIN
	CAILE	T,FLONU
	 JRST	NUMV2		;A is not a number
	CDRA	A,(A)
	CAIE	T,FIXNU
	 JRST	OPA6
	SKIPA	A,(A)
OPA2:				;first arg is a FIXNUM
	 MOVEI	T,FIXNU
	CAILE	B,INUMIN
	 JRST	OPB2
	MOVE	TT,B
	CARA	B,(B)
	CAILE	B,ATMIN
	CAILE	B,FLONU
	 JRST	NONUM1		;TT is not a number
	CDRA	TT,(TT)
	CAIE	B,FIXNU
	 JRST	OPA5
	SKIPA	TT,(TT)
OPB2:	HRREI	TT,-INUM0(B)
	MOVE	AR4,A		;<MOVEI B,FIXNU> supplied by DIVMB.
	JFCL	17,.+1
	XCT	(C)		;fixed pt op
OPOV:	JFCL	10,FIXOVL
	JRST	FIX1A

OPA6:	CAILE	B,INUMIN	;first arg is not FIXNUM
	 JRST	OPB7
	CDRA	TT,(B)
	CARA	B,(B)
	CAIE	B,FLONU
	 JRST	OPB3		;second arg is not a FLONUM
	CAIN	T,FLONU		;second arg is FLONUM; test first arg
	SKIPA	A,(A)
	PCALL	BFLT		;not a FLONUM, must be BIGNUM; float it
	MOVE	TT,(TT)
OPR:	JFCL	17,.+1
	XCT	1(C)		;flt pt op
	JFCL	10,FLOOV
	JRST	FLO1A
PAGE
OPA5:				;first arg is FIXNUM but second arg is not
	CAIE	B,FLONU		;is second arg a FLONUM
	JRST	BIGOP		;no. it must be a bignum
	PCALL	FLOAT1
	JRST	OPR-1

OPB3:			;first arg is not fixnum, second arg is not flonum
	CAIE	B,FIXNU		;is second arg FIXNUM ?
	JRST	OPB9		;no. it must be bignum
	SKIPA	TT,(TT)
OPB7:	 HRREI	TT,-INUM0(B)
	MOVEI	B,FIXNU
	CAIE	T,FLONU
	JRST	BIGOP
	MOVE	A,(A)
	EXCH	A,TT
	PCALL	FLOAT1
OPB8:	EXCH	A,TT
	JRST	OPR

OPB9:				;second arg is bignum
	CAIE	T,FLONU		;is first arg a FLONUM ?
	JRST	BIGOP		;no
	MOVE	A,(A)
	EXCH	A,TT
	EXCH	B,T
	PCALL	BFLT
	JRST	OPB8

BIGOP:	PCALL	BIGTST
	JRST	@2(C)
SUBTTL	BIGNUM   ARITHMETIC ROUTINES		--- PAGE 13


;Power of ten
PWR10:	MOVEM	B,BASEX#
	MOVE	C,B
	IMUL	B,B		;BASE^2
	IMUL	B,B		;BASE^4
	IMUL	B,C		;BASE^5
	IMUL	B,B		;BASE^ten
	MOVEM	B,BASE10#
	PRET

B0CONS:	MOVEI	A,0
BNCONS:	MOVEI	B,0
BCONS:	PCALL	FWCONS
	JRST	CONS

;Bignum PRINT
BPRI:	XCT	"-",CTY
	PCALL	COPY
FOO	MOVE	B,VBASE
	SUBI	B,INUM0
	PCALL	PWR10
	PCALL	BPRJ
	MOVE	C,BASEX
	JRST	PRINI4

BPRJ:	MOVE	B,BASE10
	PCALL	Q1
	JUMPE	B,BPR2		;zero quotient
	PSAVE	A		;remainder
	MOVE	A,B		;quotient
	PCALL	BPRJ
	PREST	A		;remainder
BPR1:	MOVEI	C,TEN		;print ten digits
	SOJL	C,CPOPJ
	IDIV	A,BASEX
	HRLM	B,(P)
	PCALL	BPR1+1
	JRST	FP7A1		;particular TYO for digit

;Ignore leading zero digits for first word
BPR2:	JUMPE	A,CPOPJ
	IDIV	A,BASEX
	HRLM	B,(P)
	PCALL	BPR2
	JRST	FP7A1		;particular TYO for digit
PAGE
;Divides bignum in A by integer in B
;Destroys original bignum
;Returns remainder in A, quotient in B
.Q1:
Q1:	MOVEM	B,Y#
	PSAVE	A
	CDRA	A,(A)
	JUMPE	A,Q1A
	PCALL	Q1+1
	PREST	C
	RPLCD	B,(C)
	CARA	T,(C)
	MOVE	B,(T)
	DIV	A,Y
Q1B:	MOVEM	A,(T)		;replace old digit
	MOVE	A,B
	MOVE	B,C
	PRET

Q1A:	PREST	C
	CARA	T,(C)
	MOVE	A,(T)
	IDIV	A,Y
	JUMPN	A,Q1B		;non-zero quotient - keep it
	HRRZM	FF,(T)		;reclaim full word
	MOVE	FF,T
	HRRZM	F,(C)		;reclaim free word
	HRRZ	F,C
	MOVEI	C,0
	JRST	Q1B+1
PAGE
;Bignum READ
RDBNM:	PSAVE	[NIL]		;initial value of bignum
	MOVSI	C,700
	HRRI	C,(SP)		;byte pointer to spec pdl
	MOVEM	T,TSAV#
	MOVEM	C,RDPTR#
	HRRZ	B,NUM1		;base of number
	PCALL	PWR10

RDNM1:	MOVEI	C,TEN		;ten digits at a time
	MOVEI	A,0
	ILDB	B,RDPTR
	JUMPE	B,RDNM2		;end of bignum
	IMUL	A,BASEX
	ADDI	A,-"0"(B)
	SOJG	C,.-4
	MOVE	B,BASE10
	PCALL	RDSUB
	JRST	RDNM1

RDNM2:	CAIN	C,TEN		;no digits in last superdigit
	JRST	RDNM3
	HRREI	C,-TEN(C)	;number of digits in last
	MOVEI	B,1
	IMUL	B,BASEX
	AOJL	C,.-1		;compute basex^(number of digits)
	PCALL	RDSUB
RDNM3:	LDB	B,[POINT 1,TSAV,14]	;MINSGN
	TRC	B,POSNU		;sign of bignum
	PREST	A
	P1DROP
	JRST	XCONS

RDSUB:	MOVE	C,-1(P)
	PCALL	BTIME1		;bignum(C)*int(B)+int(A)
	MOVEM	A,-1(P)
	PRET

PAGE
BTIME0:	PSAVE	B
	PCALL	COPY
	MOVE	C,A
	PREST	B
	MOVEI	A,0

;big(C)*int(B)+int(A)	
BTIME1:	JUMPE	C,BNCONS	;end of bignum
	MOVEM	B,MULR#		;multiplier
	PSAVE	C		;bignum
BT1B:	MOVEM	A,CARRY#
	MOVS	T,(C)
	MOVE	A,(T)
	MUL	A,MULR
	ADD	B,CARRY
	TLZE	B,SIGN
	ADDI	A,1
BT1E:	MOVEM	B,(T)		;store low order product+carry in bignum
	HLRZS	T		;(CDR bignum)
	JUMPE	T,BT1C		;end of	bignum
	MOVE	C,T
	JRST	BT1B

BT1C:	JUMPE	A,POPAJ		;no high order part
	PCALL	BNCONS		;conses for remaining high order part
	RPLCD	A,(C)		;RPLACD end of bignum
	JRST	POPAJ
PAGE
;Bignum copy
.COPY:
COPY:	JUMPE	A,CPOPJ
	CARA	B,(A)
	PSAVE	(B)
	CDRA	A,(A)
	PCALL	COPY
	MOVE	B,A
	PREST	A
	JRST	BCONS


;Bignum reclaim
RECLAIM:CAILE	A,INUMIN
	PRET
	EXCH	A,F
	EXCH	A,(F)
	HLRZ	B,A		;type
	HRRZS	A
	CAIE	B,POSNU
	CAIN	B,NEGNU
	JRST	UNCONS
	PRET

;BIGNUM UNCONS
UNCONS:	JUMPE	A,CPOPJ
	CARA	B,(A)
	MOVEM	FF,(B)
	MOVE	FF,B
	EXCH	A,F
	EXCH	A,(F)
	HRRZS	A
	JRST	UNCONS

;BIGNUM MINUSP
MINSP2:	CAIN	B,POSNU
	JRST	FALSE
	JRST	TRUE

;BIGNUM MINUS
MINS2:	TRCA	B,1
ABS2:	MOVEI	B,POSNU		;BIGNUM ABS
	JRST	XCONS

;compare two bignums A<B
BCMPR:	PCALL	BDIF
	PSAVE	A
	PCALL	MINUSP
	EXCH	A,(P)
	PCALL	RECLAIM
	JRST	POPAJ
PAGE
;DIFFERENCE of two bignums
BDIF:	TRC	TT,1		;complement sign of bignum in B
;sum of two bignums
;bignums in A and B; sign(A) in T, sign(B) in TT
BPLUS:	PSAVE	B
	PCALL	COPY
	EXCH	A,(P)
	PCALL	COPY
	PREST	C
	MOVE	B,A
	MOVEI	A,0
	CAME	T,TT
	JRST	BDIF1		;signs different
	PSAVE	T		;sign of result
	PCALL	BADD
	PREST	B
	JRST	XCONS

BDIF1:
	CAIN	TT,POSNU
	EXCH	B,C
	PCALL	BSUB		;posnum in C, negnum in B
	JUMPL	B,BDIF3
	PCALL	SUPRSS
	JRST	MAKPOS

BDIF3:	PCALL	COMPLM
	MOVEI	B,NEGNU
	JRST	MAKBIG

BSUB:	MOVNI	TT,1
	MOVSI	T,(SUB TT,(B))
	JRST	BAS

BADD:	MOVEI	TT,1
	MOVSI	T,(ADD TT,(B))
PAGE
;cry(A)(+ or -) big(B) + big(C) into A, sign into B.
;destroys both bignums

BAS:	HRRM	TT,BCRY
	PSAVE	B
BP2A:	HRRM	B,BTMP
	MOVS	B,(B)
	CARA	TT,(C)
	EXCH	TT,FF
	EXCH	TT,(FF)		;reclaim full word
	EXCH	C,F
	EXCH	C,(F)		;reclaim free word
	ADD	TT,A
	XCT	T		;big(C) (+ or -) big (B)
	MOVEI	A,0
	TLZE	TT,SIGN		;turn off high bit
BCRY:	HRREI	A,.		;set carry if overflow or negative
BP2B:	MOVEM	TT,(B)
	HLRZS	B
	HRRZS	C
	JUMPE	B,BP2F		;end of B
	JUMPN	C,BP2A
	JRST	BP2D		;finish with carry (+ or -) big(B)

BP2F:	JUMPE	C,BP2H		;end of C also
	EXCH	B,C
	RPLCD	B,@BTMP		;RPLACD end of big(B) with rest of C
	MOVSI	T,(ADD TT,(B))	;finish with big(C) + carry
BP2D:	HRRM	B,BTMP
	MOVS	B,(B)
	MOVE	TT,A
	XCT	T		;carry (+ or -) integer
	JUMPL	TT,BP2K
	MOVEM	TT,(B)
	CAME	T,[SUB TT,(B)]
	JRST	POSXIT		;can quit now
	MOVEI	A,0		;turn off carry
	JRST	BP2L		;continue to negate

BP2K:	HRRE	A,BCRY
	TLZ	TT,SIGN		;make high bit zero
	MOVEM	TT,(B)
BP2L:	HLRZS	B
	JUMPN	B,BP2D
BP2H:	JUMPLE	A,XIT		;no carry
	PCALL	BNCONS
BTMP:	HRRM	A,.		;RPLACD end of bignum with carry
POSXIT:	MOVEI	B,0		;sign positive
	JRST	POPAJ

XIT:	MOVE	B,A		;sign in B
	JRST	POPAJ
PAGE
;suppress leading zeros from bignum
SUPRSS:	SKIPA	C,[JRST COMPL7]
;complement bignum  (2^35 complement)
COMPLM:	MOVSI	C,(SUBM T,(B))
	JUMPE	A,CPOPJ
	PSAVE	A
	HRLZI	T,SIGN
	MOVEI	TT,0
COMPL4:	MOVS	B,(A)
	SKIPN	(B)
	JUMPE	TT,COMPL3
	XCT	C
	HRLOI	T,SIGN-1
COMPL7:	SKIPE	(B)
	MOVEM	A,TT
COMPL3:	HLRZ	A,B
	JUMPN	A,COMPL4	;continue
	JUMPE	TT,COMPL5	;all zeros
	CDRA	A,(TT)
	HLLZS	(TT)		;RPLACD high order non-zero with NIL
COMPL6:	PCALL	UNCONS		;UNCONS leading zeros
	JRST	POPAJ

COMPL5:	EXCH	A,(P)
	JRST	COMPL6

;sign(TT)*sign(T) into TT
MQSIGN:	CAIE	T,POSNU
	 TRC	TT,1
	PRET
PAGE
;bignum multiply
;big (A) * big (B) into A, signs in T,TT
BTIMES:	PCALL	MQSIGN
	PSAVE	TT		;save sign of result
	PCALL	BMUL
	PREST	B
	JRST	MAKBIG

;0(P) is partial result
;-1(P) is remaining reversed multiplier
;-2(P) is multiplicand

BMUL:	PSAVE	B
	PCALL	REVERSE
	PSAVE	A
	MOVEI	A,0
	PSAVE	A
BTLOOP:	SKIPN	C,-1(P)
	JRST	BTEND		;end of multiplier
	JUMPE	A,BTLP2		;first time
	MOVE	B,A
	PCALL	FWCONS-1
	PCALL	CONS		;increase length of product
BTLP2:	MOVEM	A,(P)
	MOVE	A,-2(P)
	PCALL	COPY
	MOVS	B,(C)		;next multiplier digit
	MOVE	C,A
	HLRZM	B,-1(P)
	MOVE	B,(B)
	MOVEI	A,0
	PCALL	BTIME1
	MOVE	C,(P)
	JUMPE	C,BTLOOP	;no add needed on first time
	MOVE	B,A
	MOVEI	A,0
	PCALL	BADD
	JRST	BTLOOP

BTEND:	P3DROP
	JRST	SUPRSS

PAGE
;extensions of interpreter routines and tests

REPEAT 0,<
;ONUMVAL for bignums goes here
NUMVD2:	HRRZ	C,0(P)		;address of <PCALL ONUMVAL> +1
FOO	CAIL	C,FS		;LISP-system area of code?
	 PRET			;  No, user or BPS gets a BIGNUM-pntr back.
	P1DROP
	CAIN	C,ZEROP+1
	 JRST	FALSE
	CAIN	C,MINUSP+1
	 JRST	MINSP2
	CAIN	C,MINUS+1
	 JRST	MINS2
	CAIN	C,ABS+1
	 JRST	ABS2
	CAIN	C,FIX+2
	 JRST	POPAJ
	CAIN	C,FLOAT+2
	 JRST	BFLOT
IFN MOD,<CAIN	C,CMOD+1
	JRST	CMOD1 >
PAGE
	>
;number overflow, use bignums
FIXOVL:	MOVEI	C,(C)
	CAIN	C,.TIMES+1
	 JRST	REMUL		;TIMES overflowed. Recompute.
	JUMPE	A,FIXOV2	;PLUS(mbeta mbeta) overflows 2 bits.
FIXOV3:	TLC	A,SIGN		;all other cases just overflowed 1 bit
	MOVM	B,A
	MOVE	TT,A
	MOVEI	A,1
FIXOVX:	PCALL	MKBG
	JRST	XCONS

FIXOV2:	SETZ	B,
	SETO	TT,		;(NEGATIVE).
	MOVEI	A,2		;== -2*beta.
	JRST	FIXOVX

REMUL:	MOVE	A,AR4
	MOVEI	T,FIXNU
	PCALL	BIGTSB
	JRST	BTIMES		;use the bignum multiplication

MAKPOS:	MOVEI	B,POSNU
;Make a LISP number from bignum -- A is list, B is sign
MAKBIG:	JUMPE	A,FIX1A		;NULL list produces zero
	CDRA	C,(A)
	JUMPN	C,XCONS		;a real bignum
	CARA	C,(A)		;only one word of precision
	MOVE	C,(C)
	CAIE	B,POSNU
	MOVNS	C		;negative
	PCALL	UNCONS
	MOVE	A,C
	JRST	FIX1A
PAGE
BIGTSB:	MOVEI	B,FIXNU
;Transforms general numbers in (A,T),(TT,B)
;into bignums in (A,T),(B,TT), values in A,B; signs in T,TT.
BIGTST:	EXCH	B,T		;funny ac usage in lisp
	PSAVE	T
	PSAVE	TT
	PCALL	BIGSUB		;convert number originally in A,T
	EXCH	B,-1(P)
	EXCH	A,(P)
	PCALL	BIGSUB		;convert number originally in TT,B
	MOVE	TT,B
	MOVE	B,A
	PREST	A
	PREST	T
	PRET

BIGSUB:	CAIE	B,POSNU
	CAIN	B,NEGNU
	PRET			;no conversion necessary
	CAIE	B,FIXNU
	JRST	NUMV2		;already checked for flonum
	MOVEI	B,0
	MOVE	TT,A		;get value of number
	MOVM	A,TT
	JUMPGE	A,BIGSRT	
	MOVEI	A,1		;bastard case of -2^35
MKBG:	PCALL	MKBIG
	JRST	BIGSND

BIGSRT:	PCALL	BCONS
BIGSND:	SKIPGE	TT
	SKIPA	B,[NEGNU]
	MOVEI	B,POSNU
	PRET

MKBIG:	PSAVE	B
	PCALL	BNCONS
	MOVE	B,A
	PREST	A
	JRST	BCONS
PAGE
BFLOT:	MOVEI	T,FLO1A
	MOVEM	T,(P)
	MOVE	T,B
;Make a floating pt number out of a bignum
BFLT:	PSAVE	C
	PSAVE	T
	CAIE	T,POSNU
	CAIN	T,NEGNU
	SKIPA	T,[-200]
	JRST	NUMV2
BFLT2:	MOVE	C,B
	CARA	B,(A)
	CDRA	A,(A)
	ADDI	T,43
	JUMPN	A,BFLT2		;find last two words of bignum
	MOVE	B,(B)
	MOVE	C,(C)
BFLT3:	TLNE	B,SIGN/2
	JRST	BFLT4
	ASHC	B,1
	SOJA	T,BFLT3		;normalize B,C
BFLT4:	JUMPGE	T,FLOOV
	ASH	B,-10
	DPB	T,[POINT 8,B,8]
	MOVE	A,B
	PREST	T
	PREST	C
	CAIE	T,POSNU
	MOVNS	A
	PRET

;Make a bignum from a flt pt number
BFIX:	MOVM	A,(P)
	MULI	A,400
	MOVEI	C,-243(A)	;#left shifts needed
	IDIVI	C,43		;C_#extra words-1, D_#shifts
	MOVEI	A,0
	ASHC	A,(C+1)
	PSAVE	B
	PCALL	BNCONS
	MOVE	B,A
	PREST	A
	PCALL	BCONS
	SOJL	C,BFIX2
	MOVE	B,A
	MOVEI	A,0
	PCALL	BCONS
	SOJGE	C,.-3
BFIX2:	PREST	TT
	PCALL	BIGSND
	JRST	XCONS

PAGE

;Bignum divide
BDIV:	PCALL	MQSIGN		;complement sign of TT if T is negnum
	PSAVE	T		;sign of remainder
	PSAVE	TT		;sign of quotient
	PCALL	DIVSUB
BDIV2:	EXCH	B,(P)
	PCALL	MAKBIG		;quotient
	MOVE	B,-1(P)
	MOVEM	A,-1(P)
	PREST	A
	PCALL	MAKBIG		;remainder
	PREST	B
	JRST	XCONS

BQUO:	PCALL	MQSIGN
	PSAVE	TT
	PCALL	DIVSUB
	PSAVE	A
	MOVE	A,B
	PCALL	UNCONS
	PREST	A
	PREST	B
	JRST	MAKBIG

DIVSUB:	CDRA	C,(B)
	JUMPN	C,DIV1
;NULL(CDR B) means single length divisor
BQUO1:	PSAVE	B
	PCALL	COPY
	PREST	B
	CARA	B,(B)
	MOVE	B,(B)
	PCALL	Q1
	PSAVE	B		;quotient
	PCALL	BNCONS
	MOVE	B,A
	JRST	POPAJ

PAGE
;DIV1 does long division of X/Y 
;enter with x in A, Y in B.
DIV1:	PSAVE	A		;X
	PSAVE	B		;Y
	MOVE	A,B
	PCALL	HIDIG
	HRLOI	A,SIGN/2-1
	IDIV	A,(C)		;(beta/2-1)/Y[N-1]+1
	ADDI	A,1
	MOVEM	A,SCALE#
	MOVE	B,A
	MOVE	A,(P)		;Y - divisor
	PCALL	BTIME0		;SCALE*Y
	MOVEM	A,V		;scaled	divisor
	MOVEM	A,(P)		;protect V from GC
	PCALL	HIDIG
	POP	C,VH		;V[N-1]
	POP	C,VH1		;V[N-2]
	MOVE	A,-1(P)		;X - numerator
	PCALL	COPY
	PCALL	EXTND
	MOVE	B,SCALE
	MOVE	C,A
	PCALL	BTIME1-1	;SCALE*X  -- scaled numerator
	MOVEM	A,-1(P)		;U
	PSAVE	[NIL]	
	HRRZM	P,QUO#		;pointer to quotient list
	PCALL	LENGTH
	PSAVE	A
	MOVE	A,V#
	PCALL	LENGTH
	PREST	B
	SUB	B,A		;LENGTH(U)-LENGTH(V)
	MOVE	A,-2(P)		;U
	JUMPLE	B,DIV1X		;special case of U<V
	PCALL	DIV2		;carry out division with parameters
DIV1X:	PCALL	SUPRSS		;suppress leading zeros of remainder
	JUMPE	A,DIV1Y		;zero remainder
	MOVE	B,SCALE
	PCALL	Q1		;U/SCALE - final remainder in B
	MOVE	A,B
DIV1Y:	EXCH	A,(P)
	PCALL	SUPRSS		;suppress leading zeros in quotient
	PREST	B
	JRST	POP2J

PAGE
;Recursive function to position V properly with respect to U.
; on successive calls to DIV3 which calculates quotient digits.
;Enter DIV2 with U in A, N in B. N= LENGTH(U)-LENGTH(V)-1.

DIV2:	SOJLE	B,DIV3
	PSAVE	A		;U
	CDRA	A,(A)
	PCALL	DIV2
	RPLCD	A,@(P)		;(RPLACD U,(DIV3(CDR U)))
	PREST	A
	JRST	DIV3



;Enter with U[J] in A

DIV3:	PSAVE	A		;UJ
	PCALL	HIDIG
	POP	C,A		;UH
	CAML	A,VH#
	JRST	DIVCS1		;strange case when UH>=VH
	POP	C,B		;UH1
	DIV	A,VH		;(UH*beta+UH1)/VH
	PSAVE	A		;quotient digit
L1:	MOVEM	B,REM#		;remainder
	MUL	A,VH1#
	SUB	A,REM		;(VH1*QUO)-beta*REM
	CAMGE	B,(C)		;UH2
	SUBI	A,1
	JUMPG	A,DIVCS2	;quotient too big
L4:	MOVE	A,V
	MOVE	B,(P)		;quotient digit
	PCALL	BTIME0		;Q*V
	MOVE	C,-1(P)		;UJ
	MOVE	B,A
	MOVEI	A,0
	PCALL	BSUB		;UJ-Q*V
	JUMPL	B,DIVCS3	;quotient too big
L3:	MOVEM	A,-1(P)		;new UJ
	PREST	A		;quotient digit
	MOVE	B,@QUO
	PCALL	BCONS
	MOVEM	A,@QUO		;new quotient list
	MOVE	A,(P)
	PCALL	DIVSRT		;shorten UJ by one digit
	JRST	POPAJ
PAGE
;Special case of UH>=VH
DIVCS1:	HRLOI	A,SIGN-1	;BETA-1
	PSAVE	A
	POP	C,B		;UH1
	JRST	DIVC2A		;R_UH1+VH

;Special case correction for quotient
DIVCS2:	SOS	A,(P)		;quotient_quotient-1
	MOVE	B,REM
DIVC2A:	ADD	B,VH		;R_R+VH
	JUMPL	B,L4		;overflow ... R >= beta.
	JRST	L1

;Special case of quotient too large
DIVCS3:	SOS	(P)		;quotient_quotient-1
	PSAVE	A
	MOVE	A,V
	PCALL	COPY
	MOVE	C,A
	PREST	B
	MOVEI	A,0
	PCALL	BADD		;U_U+V
	MOVEM	A,-1(P)
	PCALL	DIVSRT		;shorten overflowed digit
	JRST	L3+1
PAGE
;Pushes successive digits of list in A onto pdl
;Returns C pointing to pdl location of last digit
HIDIG:	MOVE	C,P
	MOVS	B,(A)
	PSAVE	(B)
	HLRZ	A,B
	JUMPN	A,HIDIG+1
	EXCH	C,P
	PRET

;Shorten list by one
DIVSRT:	MOVE	C,A
	CDRA	A,(A)
	CDRA	B,(A)		;CDDR
	JUMPN	B,.-3
	HLLZS	(C)		;NULL (CDDR C) => RPLACD(C NIL)
	CARA	B,(A)
	JRST	UNCONS

;Lengthen list by one
EXTND:	PSAVE	A
	PCALL	LAST
	MOVE	T,A
	PCALL	B0CONS
	RPLCD	A,(T)
	JRST	POPAJ

PAGE

TA==4
TB==5
TC==6
TD==7
UP==10
VP==11
Q==12
;Bignum GCD
BGCD:	PSAVE	B
	PCALL	COPY
	EXCH	A,(P)		;V
	PCALL	COPY
	PSAVE	A		;U
	PCALL	COPY
	MOVE	C,A
	MOVE	A,-1(P)	
	PCALL	COPY
	MOVE	B,A		;U
	MOVEI	A,0
	PCALL	BSUB		;V-U
	PSAVE	B
	PCALL	BSUBND
	JUMPE	A,GCDSC1	;U=V
	PCALL	UNCONS
	PREST	B
	JUMPGE	B,BGCD2		;U>=V
	MOVE	A,(P)
	EXCH	A,-1(P)
	MOVEM	A,(P)
PAGE
;Now V<U   V in -1(P), U in (P)
BGCD2:	MOVE	A,-1(P)
	JUMPE	A,GCDEND	;V is zero
	CDRA	B,(A)
	JUMPE	B,GCDSING	;V is single precision
	PCALL	LENGTH		;LENGTH	(V)
	MOVE	T,A
	MOVE	A,(P)		;U
	PCALL	LENGTH
	SUB	A,T		;L(U)-L(V)
	JUMPE	A,GCD4
	SOJN	A,GCD7A		;>1
	MOVE	A,-1(P)		;V
	PCALL	EXTND		;lengthen V by one high order zero
GCD4:	MOVE	A,(P)		;U
	PCALL	HIDIG
	HRLOI	A,SIGN/2-1	;BETA/2-1
	IDIV	A,(C)		;(BETA/2-1)/U[N-1]+1
	ADDI	A,1
	MOVEM	A,SCALE
	PCALL	GCSB
	MOVE	UP,A		;SCALE*UH
	MOVE	A,-1(P)		;V
	PCALL	HIDIG
	PCALL	GCSB
	MOVE	VP,A		;SCALE*VH
	MOVEI	TA,1
	MOVEI	TD,1
	SETZB	TC,TB
PAGE
GCD5:	MOVE	A,UP
	ADD	A,TA
	MOVE	B,VP
	ADD	B,TC
	JUMPE	B,GCD7
	JUMPL	A,GCD5X		;overflow case
	IDIV	A,B		;(U'+A)/(V'+C)
GCD5A:	MOVE	Q,A
	MOVE	A,UP
	ADD	A,TB
	MOVE	B,VP
	ADD	B,TD
	JUMPE	B,GCD7
	SKIPG	B
	TDZA	A,A		;special case of V'+D = BETA
	IDIV	A,B		;(U'+B)/(V'+D)
	CAME	A,Q
	JRST	GCD7
	MOVE	A,TC
	EXCH	TA,TC		;A'_C
	IMUL	A,Q
	SUB	TC,A		;C'_A-Q*C
	MOVE	A,TD
	EXCH	TB,TD		;B'_D
	IMUL	A,Q	
	SUB	TD,A		;D'_B-Q*D
	MOVE	A,VP
	EXCH	UP,VP		;UP'_VP
	IMUL	A,Q
	SUB	VP,A		;VP'_UP-Q*VP
	JRST	GCD5
PAGE
;Special case when U'+A=BETA
GCD5X:	MOVEI	A,1
	MOVE	C,B
	MOVEI	B,0
	DIV	A,C
	JRST	GCD5A

GCD7:	JUMPE	TB,GCD7A
	MOVE	A,(P)		;U
	MOVE	B,-1(P)		;V
	PSAVE	TC
	PSAVE	TD
	PCALL	GCDSB		;A*U+B*V
	PREST	TB
	PREST	TA
	EXCH	A,(P)		;U
	MOVE	B,-1(P)
	PCALL	GCDSB		;C*U+D*V
	MOVEM	A,-1(P)		;V
	JRST	BGCD2

GCDSB:	PSAVE	TA
	PSAVE	TB
	PSAVE	B
	MOVM	B,TA
	PCALL	BTIME0
	EXCH	A,(P)		;B
	MOVM	B,-1(P)		;TB
	PCALL	BTIME0
	PREST	B		;A*TA
	PREST	TA
	PREST	TB
	XOR	TA,TB
	MOVE	C,A
	MOVEI	A,0
	JUMPGE	TA,BADD		;signs same
	PCALL	BSUB		;signs different
BSUBND:	JUMPGE	B,SUPRSS
	JRST	COMPLM

GCD7A:	MOVE	A,-1(P)
	PCALL	SUPRSS
	MOVE	B,A
	MOVE	A,(P)
	PCALL	DIV1		;U/V
	EXCH	B,-1(P)		;V_REMAINDER
	MOVEM	B,(P)		;U_V
	PCALL	UNCONS		;dont need quotient
	JRST	BGCD2
PAGE
GCDSING:	
	PREST	A		;U
	MOVE	B,(P)		;V - single precision
	CARA	B,(B)
	MOVE	B,(B)
	MOVEM	B,(P)
	PCALL	Q1		;U MOD V into A
	PREST	B		;A < B
	JUMPE	A,GCDS2
;Single precision GCD
	IDIV	B,A
	MOVE	B,A
	MOVE	A,C
	JUMPN	A,.-3
GCDS2:	MOVE	A,B
	JRST	FIX1A

GCSB:	MOVE	A,-1(C)
	MUL	A,SCALE
	MOVE	B,A
	MOVE	A,(C)
	IMUL	A,SCALE
	ADD	A,B
	PRET

GCDSC1:	P2DROP
	PREST	A
	JRST	MAKPOS

GCDEND:	PREST	A		;U is result
	P1DROP
	JRST	MAKPOS
SUBTTL	GENERALIZED GFPAK, FOR BIGNUMS		--- PAGE 14
IFN MOD,<	;THE REST OF THIS PAGE IS UNDER THIS SWITCH
;TITLE	GFPAK4	--  GALOIS FIELD PACKAGE


;	THE MODULUS CANNOT BE A BIGNUM, WITH THIS VERSION OF GFPAK;
;	    THE ARG TO CMOD CAN BE, THOUGH.
;	    Every other arg is assumed to be FIXNUM or INUM !!!

;	THE MODULUS SHOULD ALWAYS BE SET OR RESET BY THE FUNCTION SETMOD;
;	    IT SHOULD NOT BE SET BY A SETQ IN LISP/REDUCE.
;	THE MODULUS CAN BE INTERROGATED FOR ITS CURRENT VALUE BY:
;	    1)  THE VALUE RETURNED FROM THE FUNCTION (SETMOD 0),
;		WHICH DOESN'T ALTER THE CURRENT VALUE;  OR BY
;	    2)  THE VALUE OF THE EXTERNAL VARIABLE MOD*.
;		(SETMOD NIL) IS LEGITIMATE, AND IS == (SETQ MOD* NIL).



GFP:	0		;STRICTLY LOCAL: THE SINGLE-PRECISION MODULUS.
			;VBIGP IS THE VALUE-CELL OF THE VARIABLE MOD*,
			;  AND PERMITS EXTERNAL-INTERROGATION.
			;VBIGP IS ALSO USED IN CMOD, AS A FIXNUM,
			;  (TO AVOID RE-FIX1A-ING GFP EACH TIME).
			;  IT IS THUS PROTECTED DURING A GC.
PAGE

;(SETMOD A) SETS P, THE NUMBER OF ELEMENTS OF THE FIELD, TO A IF A.NE.0
;	AND RETURNS P AS A RESULT IN ANY CASE.
;	DOES NOT CHECK TO SEE IF P IS PRIME, WHICH IT SHOULD BE.

INTERNAL SETMOD

SETMOD:	MOVE	C,A		;Preserve pntr around NUMVAL.
	JUMPE	A,SETM2		;If NIL, just reset cells.
	PCALL	NUMVAL
	JUMPE	A,SETM3		;If "0", interrogate old value.
SETM2:	MOVMM	A,GFP		;Internal cell (for local use).
FOO	MOVEM	C,VBIGP		;External pntr (for users and CMOD).
SETM3:
FOO	MOVE	A,VBIGP		;Return current value.
	PRET





;(CMOD A) NORMALIZES A MOD P, REGARDLESS +/- SIZE

INTERNAL CMOD

CMOD:	JSP	D,ONUMV
	 JRST	CMOD1
	CAIN	B,FLONU
	 JRST	ILLNUM		;FLOATING POINT NUMBERS ARE ILLEGAL
	IDIV	A,GFP
	SKIPGE	A,B		;IF A WAS NEG, REMAINDER IS NEG
	 ADD	A,GFP
	JRST	FIX1A		;CONVERT & EXIT

CMOD1:	PSAVE	B
	PCALL	COPY
	MOVE	B,GFP
	PCALL	Q1
	PREST	B
	CAIE	B,POSNU
	 MOVNS	A
	JRST	CDIF1

PAGE

;(CPLUS A B) RETURNS THE SUM OF A AND B IN THE CURRENT GALOIS FIELD
;	ASSUMES A & B  ALREADY NORMALIZED.

INTERNAL CPLUS
CPLUS:	MOVEM	B,TMP		;SAVE B
	PCALL	NUMVAL		;CONVERT A
	EXCH	A,TMP		;SAVE A
	PCALL	NUMVAL		;CONVERT B
	ADD	A,TMP		;ADD
	CAML	A,GFP		;SKIP IF LESS, ELSE
	SUB	A,GFP		;  NORMALIZE
	JRST	FIX1A		;CONVERT AND EXIT

TMP:	0






;CDIF(A,B) RETURNS A-B MOD P, A,B ARE ELEMENTS OF GF(P)

INTERNAL CDIF
CDIF:	MOVEM	B,TMP   	;SAVE B
	PCALL	NUMVAL		;CONVERT A
	EXCH	A,TMP		;SAVE A
	PCALL	NUMVAL		;CONVERT B
	EXCH	A,TMP
	SUB	A,TMP		;SUBTRACT
CDIF1:	SKIPGE	A      		; SKIP IF GREATEQ 0,ELSE
	ADD	A,GFP		; NORMALIZE
	JRST	FIX1A		;CONVERT AND EXIT





;(CTIMES A B) RETURNS THE PRODUCT OF A AND B IN THE CURRENT GALOIS FIELD
;	ASSUMES A & B NON-NEG ... NORMALIZED.

INTERNAL CTIMES
CTIMES:	MOVEM	B,TMP		;SAVE B
	PCALL	NUMVAL		;CONVERT A
	EXCH	A,TMP		;SAVE A
	PCALL	NUMVAL		;CONVERT B
	MUL	A,TMP		;MULTIPLY
	DIV	A,GFP		;DIVIDE BY P TO GET IN RANGE
	MOVE	A,B		;MOVE REMAINDER
	JRST	FIX1A		;WHICH WE CONVERT AND EXIT
PAGE
;(CRECIP A) RETURNS THE INVERSE OF A IN THE CURRENT GALOIS FIELD.

;	COMPUTATION USES EXTENDED EUCLIDEAN ALGORITHM, WHEREBY
;	(GCD P A) IS COMPUTED, AND NUMBERS X AND Y ARE FOUND SUCH THAT
;	P*X + A*Y = (GCD P A) = 1 BECAUSE P IS PRIME (WE HOPE).
;	SINCE P*X  O (MOD P) WE DO NOT IN FACT COMPUTE X.
;	Y IS OF COURSE THE MULTIPLICATIVE INVERSE OF A.

;ALGORITHM:
;	A(I)=A(I+1)*Q(I)+A(I+2)
;	Y(I+2)=Y(I)-Q(I)*Y(I+1)
;	A(1)=P, A(2)=A, Y(1)=0, Y(2)=1
;	A(N+2)=0, Y(N+1)=Y

;STORAGE ALLOCATION:
;	A: A(I+1)
;	B: A(I)
;	C: A(I+2)   (BECAUSE OF THE WAY IDIV WORKS)
;	AR4: Y(I)
;	AR5: Y(I+1)

INTERNAL CRECIP
CRECIP:	PCALL	NUMVAL		;GET VALUE OF ARGUMENT IN A(2)
	SETZM	AR4		;Y(1)=0
	MOVEI	AR5,1		;Y(2)=1
	MOVE	B,GFP		;A(1)=P
LOOP:	IDIV	B,A		;C=A(I+2), B=Q(I)
	JUMPE	C,EXIT		;IF A(I+2)=0, WE ARE THROUGH
	IMUL	B,AR5		;Q(I)*Y(I+1)
	EXCH	AR4,AR5
	SUB	AR5,B		;Y(I+2)
	MOVE	B,A
	MOVE	A,C
	JRST	LOOP		;NEXT ITERATION
EXIT:	SKIPGE	A,AR5		;A_Y(N+1).  IF NEGATIVE
	ADD	A,GFP		;ADD P TO GET 0.LT.Y.LT.P
	JRST	FIX1A		;CONVERT TO LISP NUMBER AND EXIT

	>	;END OF IFN MOD
SUBTTL 	EXPLODE, COMPRESS AND FRIENDS		--- PAGE 15

IFE STL,<
FLATSIZE:HLLZS	FLAT1
	MOVEI	R,FLAT2
	PCALL	PRINTA
FLAT1:	MOVEI	A,X			;*
	JRST	FIX1A

FLAT2:	AOS	FLAT1
	PRET	>


%EXPLODE:SKIPA	R,.+1		;LIKE PRIN2 & PRIN1,
EXPLODE:  HRRZI	R,EXPL1		;  <HRRZI>=551, negative R trick.
	SKIPN	OLSCNV		;READ scanner?
	 JRST	EXPLO1		;Yes!
	PSAVE	A
	MOVEI	A,NIL
	PCALL	SCANSET
	EXCH	A,(P)
	PCALL	EXPLO1
	EXCH	A,(P)
	PCALL	SCANSET
	JRST	POPAJ

EXPLO1:	MOVSI	AR4,AR4
	PCALL	PRINTA
	JRST	RETAR4

EXPL1:	PSAVE	B
	PSAVE	C
	ANDI	A,177
	PCALL	RECH1
	PCALL	NCONS
	HLR	B,AR4
	RPLCD	A,(B)
	RPLCA	A,AR4
	PREST	C
	JRST	POPBJ
PAGE
IFE STL,<
READLIST:TDZA	T,T
COMPRESS:MOVNI	T,1
	MOVEM	T,NOINFG >
IFN STL,<
COMPRESS:SETOM	NOINFG >
	PSAVE	OLDCH
	SETZM	OLDCH
	JUMPE	A,[ERRL0 ^D141,[SIXBIT /NO LIST-COMPRESS!/]]
	HRRM	A,MKNAM3
	MOVEI	A,MKNAM2
	PCALL	READ0
	CDRA	T,MKNAM3
	CAIE	T,-1
	JUMPN	T,[ERRL0 ^D142,[SIXBIT /MORE THAN ONE S-EXPRESSION-COMPRESS!/]]
	PREST	OLDCH
	PRET

MKNAM2:	PSAVE	B
	PSAVE	TT
MKNAM3:	MOVEI	TT,X
	JUMPE	TT,MKNAM6
	CAIN	TT,-1
	 ERRL0	^D143,[SIXBIT /READ UNHAPPY-COMPRESS!/]
	CDRA	B,(TT)
	HRRM	B,MKNAM3
	CARA	A,(TT)
	PCALL	GTFCH
MKNAM4:	PREST	TT
	JRST	POPBJ

MKNAM6:	MOVEI	A," "
	HLLOS	MKNAM3
	JRST	MKNAM4

GTFCH:	CAILE	A,INUMIN
	 JRST	GTFINV
GTFCH2:	PCALL	GETPNM
	CARA	A,(A)
	LDB	A,[POINT 7,(A),6]
	PRET

GTFINV:	SUBI	A,INUM0-"0"
	CAIG	A,"9"
	CAIGE	A,"0"
	 ERRL1	^D144,[SIXBIT /NUMBER NOT DIGIT!/]
	PRET
SUBTTL 	EVAL APPLY  -- THE INTERPRETER		--- PAGE 16
EV3:	CARA	A,(AR4)
FOO	MOVEI	B,VALUE
	PCALL	GET+1		;don't need to check for id
	JUMPE	A,UNDFUN	;function object has no definition
	CDRA	A,(A)
	CARA	B,(AR4)
	CAIE	A,(B)		;Error if same id
UBDPTR:
FOO	CAIN	A,UNBOUND
	JRST	UNDFUN
	CDRA	B,(AR4)		;eval (cons a (cdr AR4))
	PCALL	CONS
EVAL:	HRRZM	A,AR4
	CAILE	A,INUMIN
	JRST	CPOPJ
	CARA	T,(A)
	CAILE	T,ATMIN
	JRST	EE1		;x is atomic
	CAILE	T,INUMIN
	JRST	UNDFUN
	CARA	TT,(T)
	CAIN	TT,ID
	 JRST	EE2		;car (x) is an id
	CAIL	TT,CODMIN
	 JRST	EVCOD
	CAIG	TT,ATMIN
	 JRST	EXP3
IFE APPL,<
UNDFUN:	CARA	A,(AR4)
	ERRE1	^D28,[SIXBIT /UNDEFINED FUNCTION - EVAL!/] >
IFN APPL,<
	JRST	RETAR4

 UNDFUN==RETAR4 >

EE1:	CAIE	T,ID
	 PRET			;constant
FOO	MOVEI	B,VALUE
	PCALL	IGET
	EXCH	A,AR4
	JUMPE	AR4,UNBVAR
	CDRA	AR4,(AR4)
IFE APPL,<
FOO	CAIN	AR4,UNBOUND
UNBVAR:	ERRE1	^D29,[SIXBIT /UNBOUND VARIABLE - EVAL!/] >
IFN APPL,<
FOO	CAIE	AR4,UNBOUND
 UNBVAR==CPOPJ >
	MOVEM	AR4,A
	PRET
PAGE
IFN FNRG,<
ALIST:	SKIPE	 A,-1(P)
	PCALL	NUMBERP
	PUSH	SP,[0]		;mark for unbind
	JUMPN	A,AEVAL7	;number
	MOVE	C,SC2		;bottom of spec pdl
	MOVEM	C,AEVAL5#
	SETOM	AEVAL2
AEVAL8:	MOVE	C,SP
AEVAL6:	CAMN	C,AEVAL5	;bottom spec pdl
	JRST	AEVAL1		;done
AEVAL4:	POP	C,AR4
	JUMPE	AR4,AEVAL6	;thru with block
	MOVSS	AR4
	PUSH	SP,(AR4)	;save value cell
	HLRZM	AR4,(AR4)	;store previous value in value cell
	HRLM	AR4,(SP)	;save pointer to spec pdl loc
	JRST	AEVAL4

FNGUBD:	EXCH	A,(P)		;spec pdl pointer
	PCALL	NUMVAL
	MOVE	D,A
FNGUB2:	POP	SP,T
	JUMPE	T,POPAJ		;done
	MOVSS	T		;pointer to value cell
	RPLCA	T,(T)
	SKIPN	1(D)
	AOBJN	D,.-1		;skip over spec pdl marker
	PUSH	D,(T)		;put value cell in spec pdl
	HLRZM	T,(T)		;restore value cell
	JRST	FNGUB2

%EVAL:	PSAVE	A
	PSAVE	B
	PCALL	ALIST
	PREST	A
	MOVEI	A,UNBIND
	EXCH	A,(P)
	JRST	EVAL
PAGE
AEVAL1:	SKIPGE	AEVAL2
	SKIPN	B,-1(P)
	 PRET			;done with binding
	MOVE	A,B		;ALIST binding...
	PCALL	REVERSE
	SKIPA
ABIND2:	MOVE	A,B
	CDRA	B,(A)
	CARA	A,(A)
	CDRA	AR4,(A)
	CARA	A,(A)
	PCALL	BIND
	JUMPN	B,ABIND2
	PRET

;spec pdl binding
AEVAL7:	MOVE	A,-1(P)
	PCALL	NUMVAL
	SETZM	AEVAL2
	MOVEM	A,AEVAL5	;point to unbind to
	JRST	AEVAL8

AEVAL2:	0	;0 for number, -1 for a-list		*
	>		;end of IFN FNRG
PAGE
EE2:	CDRA	T,(T)
FOO	MOVEI	D,FUNCELL
EE21:	JUMPE	T,EV3
	MOVS	TT,(T)
	MOVS	T,(TT)
	CAIN	D,(T)
	 JRA	T,EE3
	CARA	T,TT
	JRST	EE21

EE3:	CARA	TT,T
	CARA	D,(T)
;FOO	CAIN	TT,SUBR
;	JRST	EVCOD
FOO	CAIN	TT,EXPR
	JRST	AEXPQ
;FOO	CAIN	TT,FSUBR
;	JRST	EFS
FOO	CAIN	TT,MACRO
	JRST	EFM
FOO	CAIE	TT,FEXPR
	JRST	UNDFUN
	CAIE	D,ID
	CAIGE	D,CODMIN
	 JRST	AFEXP
EFS:	CDRA	T,(T)
	CDRA	A,(AR4)
	JRST	(T)

AFEXP:	HLL	T,(AR4)
	PSAVE	T
	CDRA	A,(A)
UUOS3I:	TLO	A,400000
	PSAVE	A
	MOVNI	T,1
	JRST	IAPPLY

AEXP:	HLL	T,(AR4)
EXP3:	CDRA	A,(AR4)
UUOS6:	PSAVE	T
CILIST:	JSP	TT,ILIST
EXP2:	JRST	IAPPLY

PAGE
AEXPQ:	CAIE	D,ID
	CAIGE	D,CODMIN
	 JRST	AEXP
EVCOD:	CDRA	A,(AR4)
	HLL	T,(AR4)
UUOS2:	CDRA	T,(T)
	PSAVE	T		;For POPJ below --> call this addr.
	JSP	TT,ILIST
ESB1:	MOVEI	TT,CPOPJ
PDLARG:	HRREI	R,NACS(T)
	JUMPGE	R,PDLA1(R)
	MOVMS	R
	CAILE	R,NSUA-NACS
	 ERRL1	^D145,[SIXBIT /TOO MANY ARGS FOR EXPR!/]
	HRLI	R,(R)
	PXDROP	R
	MOVEI	A,EXARG
	HRLI	A,1(P)
	BLT	A,EXARG-1(R)
PDLA1:	PREST	A+4
	PREST	A+3
	PREST	A+2
	PREST	A+1
	PREST	A
	JRST	(TT)

EFM:	CALLF	1,(T)
	JRST	EVAL
PAGE
IFN FNRG,<
%APPLY:	MOVEI	R,3
	JSP	TT,ARGP1
	MOVEM	T,APFNG1#
	PCALL	ALIST
	MOVE	T,APFNG1
	JSP	TT,PDLARG
	PSAVE	C		;spec pdl pointer
	PSAVE	[FNGUBD]  >
APPLY:	PSAVE	A
	MOVEI	T,0
AP3:	JUMPE	B,IAPPLY	;all args pushed; b has arg list
	CARA	C,(B)
	PSAVE	C		;push arg
	CDRA	B,(B)
	SOJA	T,AP3

IFN FNRG,<
IAP4:	JUMPGE	D,TOOFEW	;special case for fexprs
	AOJN	R,TOOFEW
	PSAVE	B
	MOVE	A,SP
	PCALL	FIX1A
	EXCH	A,(P)
	MOVE	B,A
	MOVNI	R,2
	SOJA	T,IAP5

FUNCT:	PSAVE	A
	MOVE	A,SP
	PCALL	FIX1A
	PREST	B
	HLL	A,(B)
	PCALL	DCONSA
FOO	HRLI	A,FUNARG
	JRST	DCONSA
PAGE
APFNG:	SOS	T
	MOVEM	T,APFNG1
	JSP	TT,PDLARG	;get args and funarg list
	CDRA	A,(A)
	CDRA	D,(A)		;a-list pointer
	CARA	A,(A)		;function
	MOVN	R,APFNG1	;Positive no. of args
	PSAVE	D
	PSAVE	[FNGUBD]
	JSP	TT,ARGP1	;replace args and fn name
	PSAVE	D		;a-list pointer
	PCALL	ALIST		;set up spec pdl
	PREST	D
	AOS	T,APFNG1
	>		;end of IFN FNRG
IAPPLY:	MOVE	C,T		;state of world at entrance
	ADDI	C,(P)		;t has - number of args on pdl
ILP1A:	CDRA	B,(C)	;next pdl slot has function- poss fun name in lh
	CAILE	B,INUMIN
	 JRST	UNDTAG
	CARA	TT,(B)
	CAILE	TT,ATMIN
	 JRST	IAP1		;fn is atomic
FOO	CAIN	TT,LAMBDA
	 JRST	IAPLMB
 IFN FNRG,<
FOO	CAIN	TT,FUNARG
	 JRST	APFNG	>
FOO	CAIN	TT,LABEL
	 JRST	APLBL
	PSAVE	T
	MOVE	A,B
	PCALL	EVAL
	PREST	T
	MOVE	C,T
	ADDI	C,(P)
ILP1B:	MOVEM	A,(C)
	JRST	ILP1A

UNDTAG:	MOVE	A,(C)		;FN NAME,,FN
	TLNE	A,-1		;Any function name ?
	 HLRZS	A		;Yes!
	ERRE1	^D30,[SIXBIT /UNDEFINED FUNCTION - APPLY!/]
PAGE
IAP1:	CAIGE	TT,CODMIN
	 JRST	UNDTAG
	CAIE	TT,ID
	 JRST	APCOD
FOO	MOVEI	D,FUNCELL
	CDRA	B,(B)
IAPL1:	JUMPE	B,IAP2
	MOVS	TT,(B)
	MOVS	B,(TT)
	CAIN	D,(B)
	 JRA	B,IAPL2
	CARA	B,TT
	JRST	IAPL1

IAPL2:	CARA	TT,B
;FOO	CAIN	TT,SUBR
;	 JRST	APCOD
FOO	CAIE	TT,EXPR
	 ERRE1	^D31,[SIXBIT /NOT EXPR - APPLY!/]
	CARA	D,(B)
	CAIE	D,ID
	CAIGE	D,CODMIN
	 JRST	IAPXPR
APCOD:	CDRA	B,(B)
	HRRZM	B,(C)
	JRST	ESB1

IAPXPR:	CDRA	A,B
	JRST	ILP1B

PAGE
IAPLMB:	CDRA	B,(B)
	CARA	TT,(B)
	CDRA	B,(B)
	CARA	D,(TT)
	CAIN	D,ID
	 JUMPN	TT,[ERRL1 ^D146,[SIXBIT /ILLEGAL LAMBDA FORMAT!/]]
	MOVE	R,T
IPLMB1:	JUMPE	T,IPLMB2	;no more args
	JUMPE	TT,TOMANY	;too many args supplied
IAP5:	CARA	A,(TT)
	MOVEI	AR4,1(T)
	ADD	AR4,P
	HLLZ	D,(AR4)		;tested in IAP4
	RPLCA	A,(AR4)
	CDRA	TT,(TT)
	AOJA	T,IPLMB1

IFE FNRG,IAP4==TOFEW
IPLMB2:	JUMPN	TT,IAP4		;too few args supplied
	PUSH	SP,[0]		;mark for unbind
	JUMPE	R,IAP69
IPLMB4:	PREST	AR4
	CARA	A,AR4
	PCALL	BIND
	AOJL	R,IPLMB4
IAP69:	PREST	AR4
	TLNE	AR4,-1
FOO	 SKIPN	BACTRF
	 JRST	.+3
	HRRI	AR4,CPOPJ 
	PSAVE	AR4
	PCALL	PROGN1
	JRST	UNBIND

TOMANY:	ERRL1	^D147,[SIXBIT /TOO MANY ARGUMENTS SUPPLIED - APPLY!/]
TOOFEW:	ERRL1	^D148,[SIXBIT /TOO FEW ARGUMENTS SUPPLIED - APPLY!/]
PAGE
APLBL:	PUSH	SP,[0]		;mark for unbind
	CDRA	B,(B)
	CARA	A,(B)
	CDRA	B,(B)
	CARA	AR4,(B)
	MOVEM	AR4,(C)
	PCALL	BIND
	MOVEI	A,APLBL1
	EXCH	A,-1(C)
	EXCH	A,LBLAD#
	HRLI	A,LBLAD
	PUSH	SP,A
	JRST	IAPPLY
APLBL1:	PSAVE	LBLAD
	JRST	SPECSTR

IAP2:	CDRA	A,(C)
FOO	MOVEI	B,VALUE
	PCALL	GET+1		;don't need to check for id
	JUMPE	A,UNDTAG
	CDRA	A,(A)
	CDRA	B,(C)
	CAIE	A,(B)
FOO	CAIN	A,UNBOUND
	JRST	UNDTAG
	JRST	ILP1B

RETB:
PROG2:	HRRZ	A,B
	PRET
PAGE
BIND:	JSP	D,CHKID
FOO	CAIE	A,TRUTH
	JUMPN	A,BIND4
	ERRE2	^D32,[SIXBIT /MAY NOT BE CHANGED!/]

BIND4:	PSAVE	B
	PCALL	BIND1		;get value cell
	PUSH	SP,(A)
	RPLCA	A,(SP)
	HRRZM	AR4,(A)
POPBJ:	PREST	B
	PRET

BIND1:	HRRZM	A,BIND3#
FOO	MOVEI	B,VALUE
	PCALL	GET+1
	JUMPN	A,CPOPJ
FOO	MOVEI	A,UNBOUND
	PCALL	DCONSA
	MOVE	TT,A
FOO	HRLI	A,VALUE
	PCALL	DCONSA
	CDRA	B,@BIND3
	PCALL	CONS
	RPLCD	A,@BIND3
	MOVE	A,TT
	PRET

TUNBIND:SETZM	SPSAV
	MOVE	B,SC2
UBD:	CAMN	SP,B
	PRET
	PCALL	UNBIND
	JRST	UBD

SPECSTR:			;LAP...<PCALL SPECSTR>
UNBIND:	POP	SP,T
	JUMPE	T,CPOPJ
	MOVSS	T
	HLRZM	T,(T)
	JRST	UNBIND
PAGE
PROGBIND:MOVEI	D,PROGB1	;LAP...<CALL 0,PROGBIND><0 0 (FLUID --)>
SPEC1:	PREST	T
	PUSH	SP,[0]		;mark for unbind
SPEC2:	LDB	R,[POINT 13,(T),ACFLD]
	CAIG	R,377
	 JRST	(D)		;prog- or lam-bind
	JRST	(T)		;next is opcode, so quit.

LAMBIND:JSP	D,SPEC1		;LAP...<CALL 0,LAMBIND><0 x (FLUID --)>
	JUMPE	R,SPEC3		;Init = NIL
	CAIG	R,NACS
	 JRST	LAMB1
	CAIG	R,NSUA		;Extended regs.
	 JRST	LAMB2		;Yes
	MOVNI	R,(R)		;From pdl
	ADDI	R,NSUA+1(P)
LAMB1:	SKIPA	R,(R)
PROGB1:	SETZ	R,
SPEC3:	EXCH	R,@(T)
	HRL	R,(T)
	PUSH	SP,R		;<address,,old-value>.
	AOJA	T,SPEC2

LAMB2:	MOVE	R,EXARG-NACS-1(R)
	JRST	SPEC3

;Miscellaneous special case compiler run time routines

%AMAKE:	PSAVE	A		;make alist for fsubr that requires it
	MOVE	A,SP
	PCALL	FIX1A
	MOVE	B,A
	JRST	POPAJ

IFE STL,<
%UDT:	PCALL	ERHED		;error print for undefined computed go tag
	PCALL	PRIN1
	STRTIP	[SIXBIT / UNDEFINED COMPUTED GO TAG IN !/]
	MOVEI	R,INUM0+17
	HRRM	R,ERRX
	CDRA	R,(P)
	PCALL	ERSUB3
	JRST	ERREND-1

%LCALL:	MOVN	A,T		;set up routine for compile lsubr
	ADDI	A,INUM0
	ADDI	T,(P)
	PSAVE	T
	PCALL	(3)
	PREST	T
	SUBI	T,(P)
	HRLI	T,-1(T)
	ADD	P,T
	PRET >
SUBTTL 	ARRAY SUBROUTINES			--- PAGE 17

IFN ASARY,<
ARRERR=-1

ARRAY:	PCALL	ARRAYS
	HRRI	AR5,1(R)
	MOVE	A,AR5
	PUSH	R,[0]
	AOBJN	A,.-1
ARREND:	MOVE	A,BPPNR#
	MOVEM	AR5,-1(A)
	MOVEI	A,1(R)
	PCALL	FIX1A		;MOVEI A,INUM0+1(R)
FOO	MOVEM	A,VBPORG
	PRET


ARRAYS:	PSAVE	A
FOO	MOVE	A,VBPORG
	PCALL	NUMVAL		;SUBI A,INUM0
	MOVEM	A,BPPNR
FOO	MOVE	A,VBPEND
	PCALL	NUMVAL		;MOVNI A,-INUM0-2(A)
	MOVN	A,A
	ADDI	A,2
	ADD	A,BPPNR		;bporg-bpend+2
	HRLM	A,BPPNR
	HRRZ	A,BPPNR
	ADDI	A,2
	PCALL	IMKCODE
FOO	MOVEI	B,EXPR
	PREST	A
	CDRA	AR4,(A)		;(cdr l)
	CARA	A,(A)		;(car l)name
	PCALL	IPUTD
	CARA	A,(AR4)		;(cadr l)mode
	PSAVE	AR4
	PCALL	EVAL		;eval mode
	PREST	AR4
	MOVEM	A,AMODE#
	MOVEI	C,44
	JUMPE	A,ARRY1
	MOVEI	C,-INUM0(A)
	CAILE	A,INUMIN
	JRST	ARRY1
	MOVEI	C,22
	MOVE	A,GCMKL
	HRL	A,BPPNR
	PCALL	DCONSA		;IFF Lisp-pntrs requested,
	MOVEM	A,GCMKL		;record for GC marking of arrays.
ARRY1:	MOVEM	C,BSIZE#
	MOVEI	A,44
	IDIV	A,C
	MOVEM	A,NBYTES#
	CDRA	A,(AR4)		;(cddr l)bound pair list
	JSP	TT,ILIST
	AOS	R,BPPNR
	MOVEI	AR4,1		;AR4 is array size
	MOVEI	AR5,0		;AR5 is cumulative residue
	AOJGE	T,ARRYS		;single dimension
	MOVEI	D,A-1
	SUB	D,T		;D is next ac for array code generation
ARRY2:	PCALL	ARRB0
	TLC	TT,(IMULI)
	DPB	D,[POINT 4,TT,ACFLD]
	PUSH	R,TT
	CAIN	D,A
	JRST	ARRY3
	MOVSI	TT,(ADD)
	ADDI	TT,1(D)
	DPB	D,[POINT 4,TT,ACFLD]
	PUSH	R,TT
	SOJA	D,ARRY2

ARRB0:	PREST	TT		;E.G., after ARRAY XX(5,6),
	EXCH	TT,(P)		;  extents= (0:5,0:6), =42, = 0:41,
	CAILE	TT,INUMIN	;  generates SUBR #22002, say, and
	JRST	ARRB1		;22000/	-25,,22016	;-N/2,,data
	CARA	A,(TT)		;  001/ 5,,-10		;INUM0*8
	CDRA	TT,(TT)		;  002/ IMULI	A,7
	SUBI	TT,(A)		;  003/ ADD	A,B
	ADDI	TT,1		;  004/ SUB	A,22001
	JRST	ARRB2		;  005/ JUMPL	A,ARRERR;indexing .LT.  (0,0)
				;  006/ CAIL	A,^D42
ARRB1:	MOVEI	A,INUM0		;  007/  JRST	ARRERR
	SUB	TT,A		;  010/	IDIVI	A,2	;half-word pntrs.
ARRB2:	IMUL	A,AR4		;  011/ IMULI	B,-^D18_12 ;bytesize.
	IMULB	AR4,TT		;  012/ HRLZI	C,(POINT 18,0(B),17)
	ADDM	A,AR5		;  013/ ADDI	C,22016(A)
	PRET			;  014/ LDB	A,C	;proper halfword.
				;  015/ PRET		;returning pntr, etc.
ARRY3:	PUSH	R,[ADD A,B]	;  016/ ...,,...	;INITIALLY 0 or NIL.
ARRYS:	PCALL	ARRB0
	HRRZ	TT,BPPNR
	MOVEM	AR5,(TT)	;SUBR-1, e.g. 22001.
	HRLI	TT,(SUB A,)
	PUSH	R,TT
	PUSH	R,[JUMPL A,ARRERR]
	MOVE	TT,AR4
	HRLI	TT,(CAIL A,)
	PUSH	R,TT
	PUSH	R,[JRST ARRERR]
	IDIV	AR4,NBYTES	;calc #words in array
	SKIPE	AR5		;correct for remainder non-zero
	ADDI	AR4,1
	MOVE	TT,NBYTES
	SOJE	TT,ARRY6
	ADDI	TT,1
	HRLI	TT,(IDIVI A,)
	PUSH	R,TT
	MOVN	TT,BSIZE
	LSH	TT,14
	HRLI	TT,(IMULI B,)
	PUSH	R,TT
	MOVEI	TT,44+200
	SUB	TT,BSIZE
	LSH	TT,6
ARRY6:	ADD	TT,BSIZE
	LSH	TT,6
	SKIPE	AR5,AMODE
	CAIL	AR5,INUMIN
	ADDI	TT,40		;mode not = T
	TLC	TT,(MOVSI C,)
	PUSH	R,TT
	MOVEI	TT,4(R)
	HRLI	TT,(ADDI C,(A))
	PUSH	R,TT
	PUSH	R,[LDB A,C]
	MOVSI	AR5,(PRET)
	SKIPN	TT,AMODE
	MOVE	AR5,[JRST FLO1A]
	CAIL	TT,INUMIN
	MOVE	AR5,[JRST FIX1A]
	PUSH	R,AR5
	MOVS	AR5,AR4
	MOVNS	AR5
	PRET

STORE:	PSAVE	A
	PCALL	CADR
	PCALL	EVAL		;value to store
	EXCH	A,(P)
	CARA	A,(A)
	PCALL	EVAL		;byte pointer returned in c
	PREST	A
NSTR:	PSAVE	A
	TLNE	C,40
	JSP	D,ONUMV		;numerical array
	 JRST	BIGNER		;BIGNUM IS ERROR
	DPB	A,C
	PREST	A
	PRET		>	;end of IFN ASARY from line 300
PAGE
IFN ALOD&ASARY,<
EXARRAY:PSAVE	A
	CARA	A,(A)
	PCALL	GETSYM
	JUMPE	A,POPAJ
	PCALL	NUMVAL
	EXCH	A,(P)
	PCALL	ARRAYS
	PREST	A
	HRRM	A,-2(R)
	HRR	AR5,A
	JRST	ARREND >	;end of IFN ALOD&ASARY

DLVECT:
IFN ASARY,SETZ	AR4,		;To reduce GC overhead, or GCing of
	JSP	D,ATMTYP
	 CAIE	TT,VECT
IFN ASARY,<
	 JRST	.+2
	JRST	ISVC		;  obsolete array in BPS overlays, e.g.
	MOVE	AR4,A
	PCALL	GETD
	JUMPE	A,FALSE		;Gone.
	CARA	D,(A)
FOO	CAIE	D,EXPR	>
	 JRST	FALSE
ISVC:	CDRA	A,(A)
	MOVEI	TT,GCMKL	;Delete a Lisp array from the GC list,
DLARRLP:CDRA	T,(TT)		;  If done with it, tho can't reclaim core yet.
	CARA	C,(T)
	CAIN	C,-2(A)
	 JRST	DLFOUND
	CDRA	TT,(TT)
	JUMPN	TT,DLARRLP
	JRST	FALSE		;Not found.
DLFOUND:CDRA	T,(T)
	RPLCD	T,(TT)		;Cut out of list.
IFN ASARY,<SKIPE A,AR4
	PCALL	REMD>		;Delete the SUBR pointer from the Lisp array
	JRST	TRUE

PAGE
MKVECT:	PCALL	NUMVAL
	JUMPL	A,VECOV+1
	PSAVE	A
	LSH	A,-1
	PSAVE	A
FOO	MOVE	A,VBPORG
	PCALL	NUMVAL
	EXCH	A,(P)
	ADD	A,(P)
	ADDI	A,3
	PCALL	FIX1A
	PSAVE	A
FOO	MOVE	B,VBPEND
	PCALL	.GREAT
	JUMPN	A,VECOV
FOO	PREST	VBPORG		;set new bporg
	MOVE	A,GCMKL
	HRL	A,(P)
	PCALL	DCONSA
	HRRM	A,GCMKL
	PREST	A		;old bporg, i.e. beginning of vector
	MOVE	B,(P)
	LSH	B,-1
	ADDI	B,1
	MOVNS	B
	HRLM	B,(A)
	ADDI	A,2
	HRRM	A,-2(A)
	MOVE	B,-2(A)
	SETZM	(B)		;fill vector with NIL
	AOBJN	B,.-1
	PREST	-1(A)		;Upper limit for vector
	HRLI	A,VECT
	JRST	DCONSA

PAGE
GETV:	JSP	T,OPV
	 CARA	A,(B)
	 CDRA	A,(B)

PUTV:	JSP	T,OPV
	 RPLCA	A,(B)
	 RPLCD	A,(B)

OPV:	JSP	D,ATMTYP
	 CAIE	TT,VECT
	 ERRE2	^D33,[SIXBIT /IS NOT A VECTOR!/]
	CDRA	TT,(A)
	MOVE	A,C
	SUBI	B,INUM0
	JUMPL	B,INXOV
	CAMLE	B,-1(TT)	;compare with upper limit
	 JRST	INXOV		;too big
	TRNE	B,1		;odd or eaven
	 ADDI	T,1		;odd
	LSH	B,-1
	ADDI	B,(TT)
	XCT	(T)
	PRET

VECTORP:
UPBV:	JSP	D,ATMTYP
	 CAIE	TT,VECT
	 JRST	FALSE
	CDRA	A,(A)
	MOVE	A,-1(A)
	JRST	FIX1A

INXOV:	MOVEI	A,INUM0(B)
	ERRE2	^D34,[SIXBIT /SUBSCRIPT IS OUT OF RANGE!/]

VECOV:	MOVE	A,-2(P)
	ADDI	A,INUM0
	ERRE2	^D35,[SIXBIT /TOO BIG VECTOR!/]
SUBTTL 	EXAMINE, DEPOSIT , ETC			--- PAGE 18

BOOLE:	SUBI	A,INUM0
	DPB	A,[POINT 4,BOOLI,OPFLD-2]
	MOVE	A,B
	PCALL	NUMVAL
	EXCH	C,A
BOOLL:	PCALL	NUMVAL
BOOLI:	SETZB	C,A
	JRST	FIX1A

EXAMINE:PCALL	NUMVAL		;<MOVE A,-INUM0(A)>
	MOVE	A,(A)
	JRST	FIX1A

DEPOSIT:MOVE	C,B
	PCALL	NUMVAL		;<MOVEI C,-INUM0(A)
	EXCH	A,C		; MOVE  A,B >
	JSP	D,ONUMV
BIGNER:	 ERRL0	^D139,[SIXBIT /BIGNUM UNSUITABLE AS ARG!/]   ;AASCII,BOOLE,etc.
	MOVEM	A,(C)
	JRST	MAKNUM

LSH:	MOVEI	C,-INUM0(B)
	PCALL	NUMVAL
	LSH	A,(C)
	JRST	FIX1A
SUBTTL 	GARBAGE COLLECTOR			--- PAGE 19

GC:	PCALL	AGC
	JRST	FALSE

AGC2:	SKIPE	GCFFLG		;did we just do a GC from top ?
	 PRET			;yes, don't do it again
	SETOM	GCFFLG		;indicate GC from top
AGC:	MOVEM	R,ACSAV+R
AGC1:	MOVEM	SP,SPSAV	;save in case of ^C
	MOVE	NIL,CNIL3	;set NIL
	PSAVE	.JBUUO
	PSAVE	UUOH
GCPK1:	PSAVE	PA3
	PSAVE	PA4
	PSAVE	UBDPTR		;special atom UNBOUND; not on OBLIST
	PSAVE	MKNAM3
	PSAVE	GCMKL		;i/o channel input lists and arrays
	PSAVE	BIND3
GCPK2:	PSAVE	[XWD 0,GCP6]	;this is a return address
	MOVEI	D,ACSAV
	BLT	D,ACSAV+11	;save ACs 0 through 11
GCP2:	SETZB	NIL,X		;gc indicator, init. for bit table zero
	MOVE	A,C3GC
GCP5:	BLT	A,X		;zero bit tables, .=top of bit tables
FOO	SKIPN	GCGAGV
	 JRST	GCP5A
	CAIN	F,ILLAD
	 STRTIP	[SIXBIT /_*** FREE STG EXHAUSTED_!/]
	SKIPN	FF
	 STRTIP	[SIXBIT /_*** FULL WORD SPACE EXHAUSTED_!/]
GCP5A:	MOVEI	TT,1
	MOVEI	A,0
	CALLI	A,STIME		;time
	MOVEM	A,GCTIMT#
GCP3:	MOVEI	C,X		;.=bottom of reg pdl
GCP6B:	MOVE	S,P
	HLL	C,P
	MOVEI	B,0
GC1:	CAMN	C,S
	 PRET
	HRRZ	A,(C)
GCP:	CAIGE	A,X		;.=bottom of bit tables
GCPP1:
FOO	CAIGE	A,FS
	JRST	GCEND
GCP1:	CAIL	A,X		;.=bottom of full word space (fws)
	JRST	GCMFWS
	MOVE	F,(A)
	LSHC	A,-5
	ROT	B,5
	MOVE	AR4,GCBT(B)
GCBTP2:	TDOE	AR4,X(A)	;bit tab- (fs_-5), .=magic number for sync
	 JRST	GCEND
GCBTP1:	MOVEM	AR4,X(A)	;bit tab- (fs_-5)
	PSAVE	F
	CARA	A,F
	JRST	GCP

GCMFWS:	MOVEI	AR4,X(A)	;.=- bottom of fws
	IDIVI	AR4,44
	MOVNS	AR5
	LSH	AR5,36
	ADD	AR5,C2GC
	DPB	TT,AR5
GCEND:	CAMN	P,S
	 AOJA	C,GC1
	PREST	A
	HRRZS	A
	JRST	GCP

CNIL3:
FOO	XWD	ID,CNIL2	;NIL header to refresh ac 0

GCMKL:	XWD	0,.+1+X		;Appended to, for each Lisp-pntr array.
	XWD	.+1,.+2
	XWD	-NSUA+NACS-1,EXARG
	XWD	.+1,.+2
	XWD	-11,ACSAV	;Reg 0 - 10 are saved from gc this way
	XWD	.+1,NIL
	XWD	-NIOCH,CHTAB+FSTCH
C2GC:	XWD	430100+AR4,X	;.=bottom of fws bit table
C3GC:	0			;<bottom bit table,,bottom bit table+1>
GCBT:	XWD	400000,0
ZZ==1B1
XLIST
REPEAT ^D31,<ZZ
ZZ==ZZ/2>
LIST
PAGE
GCP6:	HRRZ	R,SC2
GCP6C:	CAILE	R,(SP)		;mark sp
	 JRST	GCP6A
	PSAVE	(R)
	HRRZ	C,P
	PCALL	GCP6B
	P1DROP
	AOJA	R,GCP6C

GCP6A:	HRRZ	R,GCMKL		;mark arrays
GCP6D:	JUMPE	R,GCSWP
	CARA	A,(R)
	MOVE	D,(A)		;<-N,,ADDR>
GCP6E:	PSAVE	(D)
	CDRA	C,P
	PSAVE	(D)
	MOVSS	(P)
	PCALL	GCP6B
	P2DROP
	AOBJN	D,GCP6E
	CDRA	R,(R)
	JRST	GCP6D


GFSWPP:
PHASE 0
GFSP1==.
	JUMPL	S,.+3
	HRRZM	F,(R)
	HRRZ	F,R
	ROT	S,1
	AOBJN	R,.-4
	MOVE	S,(D)
	HRLI	R,-40
	AOBJN	D,GFSP1

LPROG==.
	JRST	GFSPR

DEPHASE
PAGE
;garbage collector sweep

GCSWP:	MOVSI	R,GFSWPP
	BLT	R,LPROG
	MOVEI	F,ILLAD
	MOVE	D,C3GCS
FOO	MOVEI	R,FS
GCBTL1:	HRLI	R,X		;-(32-<fs&37>
	MOVE	S,(D)
GCBTL2:	ROT	S,X		;fs&37
	AOBJN	D,GFSP1
GFSPR:	MOVE	A,C1GCS
	MOVE	B,C2GCS
	PCALL	GCS0
FOO	SKIPN	GCGAGV
	 JRST	GCSP1
	PCALL	WHEAD
	MOVE	A,F
	PCALL	GCPNT
	STRTIP	[SIXBIT / FREE STG,!/]
	MOVE	A,FF
	PCALL	GCPNT1
	STRTIP	[SIXBIT / FULL WORDS AVAILABLE!/]
	PCALL	TOURET
GCSP1:	PXDROP	[XWD GCPK2-GCPK1,GCPK2-GCPK1]	;restore p
	PREST	UUOH
	PREST	.JBUUO
	MOVE	NIL,ACSAV
	SETZM	SPSAV
	CAIN	F,ILLAD
	 ERRG	^D260,[SIXBIT /NO FREE STG LEFT!/]
	JUMPE	FF,[ERRG ^D261,[SIXBIT /NO FULL WORDS LEFT!/]]
	MOVEI	A,0
	CALLI	A,STIME		;time
	SUB	A,GCTIMT
	ADDM	A,GCTIM#
	MOVSI	D,ACSAV
	BLT	D,S		;reload ac's
	MOVE	R,ACSAV+R
  IFN OPSYS,<
	SKIPE	KBINTF		;Any user ^char interrupts from KB?
	 JRST	KBINTH >	;  Yes, process.
	PRET
PAGE
GCS0:	MOVEI	FF,0
GCS1:	ILDB	C,B
	JUMPN	C,GCS2
	HRRZM	FF,(A)
	HRRZ	FF,A
GCS2:	AOBJN	A,GCS1
	PRET

C1GCS:	0			;<- length of fws,,bottom of fws>
C2GCS:	POINT	1,X,35		;.=bottom of fws bit table
C3GCS:	0			;-n wds in bt,,bt


GCTIME:	MOVE	A,GCTIM
	JRST	FIX1A

TIME:	MOVEI	A,0
	CALLI	A,STIME
	JRST	FIX1A

SPEAK:	MOVE	A,CONSVAL#
	JRST	FIX1A

GCPNT1:	MOVEI	B,0
	JUMPE	A,LOOP0
	HRRZ	A,(A)
	AOJA	B,.-2			; B:=LENGTH(A)

GCPNT:	MOVEI	B,0
	JRST	.+2
	HRRZ	A,(A)
	CAIE	A,ILLAD
	 AOJA	B,.-2
LOOP0:	PCALL	FIX1
	JRST	PRIN1
SUBTTL 	GETSYM,PUTSYM				--- PAGE 20

IFN	ALOD,<		;this entire page
R50MAK:	PCALL	PNAMUK
	PUSH	C,[0]
	HRLI	C,700
	HRRI	C,(SP)
	MOVEI	B,0
MK3:	ILDB	A,C
	LDB	A,R50FLD
	CAMGE	B,[50*50*50*50*50]
	SKIPN	A
	 PRET
	IMULI	B,50
	ADD	B,A
	JRST	MK3

GETSYM:	PCALL	R50MAK
	TLO	B,040000	;04 for globals
	MOVE	C,.JBSYM
MK7:	CAMN	B,(C)
	JRST	MK10		;found
	AOBJP	C,.+2
	AOBJN	C,MK7
	TLC	B,140000	;10 for locals
	TLNN	B,100000
	TLON	B,400000	;Suppressed to DDT
	 JRST	MK7-1
	JRST	FALSE

MK10:	MOVE	A,1(C)		;value
	JRST	FIX1A

PUTSYM:	PSAVE	B
	PCALL	R50MAK
	MOVE	A,B
	TLO	A,040000	;make global
	SKIPL	.JBSYM
	 AOS	.JBSYM		;increment initial symbol table pointer
	PSAVE	A
	MOVEI	A,2
	PCALL	EXPND2
	MOVN	B,[XWD 2,2]
	ADDB	B,.JBSYM
	PREST	(B)		;Name
	PREST	1(B)		;value
	JRST	FALSE
	>			;end of IFN ALOD
SUBTTL	FASLOAD					--- PAGE 21
;From MIT-ML, converted to LISP 1.6 of Utah
;By KRK, Last edit: 09 Aug 76

IFN	OFLD,<

LDFNM2==137		;Address of Lisp version number (if any).
LDGPRO==0		;Address (relative to reg P) of internal QLIST
LDPRLS==-1		;         -  "  -                        P.URCLOBRL

LDAAOB:	0		;Currently highest index in Atomtable
LDAGCM:	0		;Address of GCMKL word for Atomtable
LDAPTR: 0(TT)		;Base address for Atomtable. Index in TT
LDBYTS: 0		;Holds word being unpacked into bytes
LDEOFJ: 0		;Error index
LDF2DP: 0		;XOR between current and file version number
LDGROW: 0		;For extended Atomtable. Not used
LDHLOC: 0		;Not used
LDOFST: 0(TT)		;Start of currently loaded routine. Relocation base
;LDPRDF: 0		;Internal !*PREDEF flag

;Error indices
LOOK==-1
EMPTYF==0
FORMAT==1
GCPROT==2
BPFULL==3
FTFULL==4

PAGE
;  FASLOD('ArrayForFisl);

FASLOD:	;MOVEM	B,LDPRDF	;"Print redefined funcs".
FOO	SKIPN	C,VPURIFY
	TLOA	C,(1B0)
FOO	 CDRA	C,VP.URCLOBRL
	PSAVE	C		;- to omit; 0 or old-addr to purify.
	PSAVE	C		;LDGPRO zeroed below.
	SETZM	LDEOFJ		;An EOF is erroneous until LDBEND byte.
	JSP	D,ATMTYP
	 CAIE	TT,VECT
	 JRST	LDFERR
	CDRA	A,(A)		;Lookup ATOMTABLE's access addr...
	MOVEI	B,-2(A)
	MOVEM	B,LDAGCM	;Addr of array's allocation-wd (GCMKL).
	MOVE	B,-2(A)
	HRRM	B,LDAPTR	;Addr of array's data base-wd.
	SETZ	TT,
	SETZM	@LDAPTR		;0th is NIL  [N.B. indirection-addr uses TT].
LDMORE:	JSP	T,LDGTWD	; ...except that can get empty file.
	JUMPE	TT,.-1		;Sluff leading/trailing 0 words.
	SETZM	LDEOFJ		;(Reset after a new file's LDMORE).
	AOS	LDEOFJ		;Now 1 for "Format error".
	CAME	TT,[ASCII /FASLP/]
	 JSP	D,LDFERR	;Improper format for FASL file.
	JSP	T,LDGTWD	;Get 2nd word of each file.
	XOR	TT,LDFNM2	;Compare to Lisp's version&flags.
	MOVEM	TT,LDF2DP	;Nonzero if different.
	SETZM	FFFSUB#
	SETZM	LDGPRO(P)	;Internal QLIST effectively.
	HLLZ	A,@LDAGCM	;[-length,,0]
	AOBJN	A,.+1
	MOVEM	A,LDAAOB	;Commence with 1th cell; NIL is 0th.
FOO	MOVE	A,VBPORG
	PCALL	NUMVAL
	HRRM	A,LDOFST	;Also a TT indirection pntr.
	HRRZM	A,R		;Form AOBJP wd in R for BPS storage...
	MOVE	B,LDAGCM	;  [Use this rather than BPEND1].
	SUBI	A,-1(B)
	JUMPL	A,USE.IT
FOO	MOVE	A,VBPEND
	PCALL	NUMVAL
	MOVE	B,A
	MOVE	A,R
	SUBI	A,(B)
	JUMPGE	A,FASLNC
USE.IT:	HRLI	R,(A)		;  [-<available BPS>,,<starting BPORG>]
	SETZM	LDHLOC		;Initialize for the BPS section.
	MOVE	AR4,[000400,,LDBYTS]	;Initialize for accessing each
	JRST	LDBIN			;  9*4 series of bytes.
PAGE
;;; FROM THIS POINT ON, UNTIL A FATAL ERROR OCCURS OR LOCATION LDFEND IS REACHED,
;;; THESE ACCUMULATORS ARE DEDICATED TO THE FOLLOWING PURPOSES:
;;;	AR4	BYTE POINTER FOR GETTING SUCCESSIVE RELOCATION TYPES
;;;	R	AOBJN POINTER FOR PUTTING WORDS INTO BINARY PROGRAM SPACE


LDREL:	HRRI	TT,@LDOFST	;[RELOCATABLE WORD]
LDABS:	MOVEM	TT,(R)		;[ABSOLUTE WORD]
LDABS1:	AOBJP	R,FASLNC	;EXCEEDED AVAILABLE BPS -- NO CORE.
LDBIN:	TLNN	AR4,770000
	 JRST	LDBIN2		;OUT OF RELOCATION BYTES - GET MORE.
LDBIN1:	JSP	T,LDGTWD	;GET WORD FROM INPUT FILE
	ILDB	T,AR4		;GET CORRESPONDING RELOCATION BYTE
	JSP	D,@LDTTBL(T)	; - IT TELLS US WHERE TO GO


LDTTBL:	LDABS		;  0  ABSOLUTE
	LDREL		;  1  RELOCATABLE
	LDSPC		;  2  SPECIAL
	LDPRC		;  3  PURIFIABLE CALL
	LDQAT		;  4  QUOTED ATOM
	LDQLS		;  5  QUOTED LIST
	LDGLB		;  6  GLOBALSYM PATCH
	LDGET		;  7  GET DDT SYMBOL PATCH
	LDAREF		; 10  ARRAY REFERENCE
	LDPEN		; 11  PUT ENTRY POINT
	LDATM		; 12  ATOMTABLE ENTRY
	LDENT		; 13  ENTRY POINT INFO
	LDLOC		; 14  LOC TO ANOTHER PLACE
	LDPUT		; 15  PUT DDT SYMBOL
	LDEVAL		; 16  EVALUATE MUNGEABLE
	LDBEND		; 17  END OF BINARY


LDBIN2:	JSP	T,LDGTWD	;GET WORD OF RELOCATION BYTES
	MOVEM	TT,LDBYTS
	SOJA	AR4,LDBIN1	;INIT BYTE POINTER AND GO GET DATA WORD

PAGE
LDSPC:	MOVE	T,TT		;[SPECIAL]
	MOVE	A,@LDAPTR
	HLR	TT,A		;GET ADDRESS OF SPECIAL CELL
	TRNE	TT,777000	;WAS SUCH AN ADDRESS REALLY THERE?
	 JRST	LDABS		;  YES, WIN
	TRNE	TT,6		;  NO, IS THIS ATOM A NUMBER?
	 JSP	D,LDFERR	;	YES - LOSE!!!
	TRZE	TT,20		;IS IT NON INTERNED ID ?
	 PCALL	%GCPRO		;YES. PROTECT IT
	MOVE	TT,T
	HRRZ	A,@LDAPTR
	SKIPN	A
	 JSP	D,LDFERR	;NO, LOSE IF NIL...ELSE
	PCALL	BIND1		;GET VALUE CELL
	MOVE	TT,T
	HRLM	A,@LDAPTR	;SAVE VC ADDR IN ATOMTABLE (LH).
	HRR	TT,A		;AT LAST WE WIN
	JRST	LDABS


LDQAT:	MOVE D,@LDAPTR		;[QUOTED ATOM]
	TLNN D,777001		;SKIP IF SPECIAL OR ALREADY USED
	 TLO D,1			;ELSE TURN ON REFERENCE BIT
	MOVEM D,@LDAPTR
	HRRI TT,(D)		;GET ADDRESS OF ATOM
	JRST LDABS


LDGLB:	JSP	D,LDFERR
  REPEAT 0,<
	SKIPL	TT		;[GLOBALSYM PATCH]
	SKIPA	TT,LSYMS(TT)	;GET VALUE OF GLOBAL SYMBOL
	 MOVN	TT,LSYMS(TT)	;OR MAYBE NEGATIVE THEREOF
	ADD	TT,-1(R)	;ADD TO ADDRESS FIELD OF
	HRRM	TT,-1(R)	; LAST WORD LOADED
	JRST	LDBIN
	   >

PAGE
LDQLS:	MOVSI	C,11		;[QUOTED LIST]
	PCALL	LDLIST		;GOBBLE UP A LIST
	JUMPE	C,.+2
	 MOVEM	TT,(R)		;PUT WORD IN BPS
	PSAVE	A
	JSP	T,LDGTWD	;GET HASH KEY FOR LIST
	PREST	A
	PCALL	%GCPRO		;PROTECT NEW LIST FROM GC.
	JUMPE	C,LDEVL7	;IF -2, THIS LIST GOES INTO ATOMTABLE.
	JRST	LDABS1		;OR -1, JUST INTO BPS.


LDLIS0:	JSP	T,LDGTWD
LDLIST:	LDB	T,[POINT 2,TT,2]	;[CONSTRUCT LIST]
	JRST	@LDLTBL(T)

LDLTBL:	LDLATM			;ATOM
	LDLLST			;LIST
	LDLDLS			;DOTTED LIST
	LDLEND			;END OF LIST

LDLATM:	MOVE	A,@LDAPTR
	TLNN	A,777011
	 IOR	A,C
	MOVEM	A,@LDAPTR
	PSAVE	A
	JRST	LDLIS0

LDLLST:	TDZA	A,A
LDLDLS:	PREST	A
	HRRZS	TT
	JUMPE	TT,LDLLS3
LDLLS1:	PREST	B
	PCALL	XCONS
	SOJG	TT,LDLLS1
LDLLS3:	PSAVE	A
	JRST	LDLIS0

LDLEND:	HLRZ	C,TT
	TRC	C,777776	;-1 to 1,  -2 to 0.
	TRNE	C,777776	;Any other?
	 JSP	D,LDFERR	;  is error.
	PREST	A
	MOVSS	TT
	HRRI	TT,(A)
	PRET

PAGE
LDPRC:	MOVE	D,@LDAPTR	;[PURIFIABLE CALL]
	TLNE	D,777000
	 JRST	LDPRC1		;JUMP IF ATOM HAS SPECIAL CELL
	TLNE	D,6
	 JSP	D,LDFERR	;LOSE IF NUMBER
	TLO	D,1		;ELSE TURN ON REFERENCE BIT
	MOVEM	D,@LDAPTR
LDPRC1:	TRNN	D,-1		;MUST HAVE NON-NIL ATOM TO CALL
	 JSP	D,LDFERR
	HRR	TT,D		;PUT ADDRESS OF ATOM IN CALL
	SKIPGE	T,LDPRLS(P)	;SKIP FOR PURIFYING HACKERY
	 JRST	LDABS		;  Not active...DONE.
	MOVEM	TT,(R)		;Store the call-word,
	HRRZ	C,R		;  and get its address...
	JSP	AR5,TRYSMSH	;NOW TRY TO SMASH IT
	 JRST	LDABS1		;SMASHED
	HRLI	A,(R)		;NOT SMASHED ...
	HRR	A,LDPRLS(P)	;  APPEND ADDR TO PURE LIST
	PCALL	DCONSA		;  TO RE-TRY AT LDFEND.
	MOVEM	A,LDPRLS(P)
	JRST	LDABS1

IFN 0,<
LDSMSH:	LDB	T,[POINT 9,(AR5),8]
	CAIL	T,34		;CALL
	CAILE	T,35		;JCALL
	 PRET
	HRRZ	A,(AR5)		;Pntr to atomhead.
	PCALL	GETD		;TRY TO GET EXPR, FEXPR PROP
	LDB	D,[POINT 4,(AR5),12]  ;Destroys A,B,C,T,TT
	JUMPE	A,CPOPJ1	;Can't be smashed since undefined yet.
	CARA	B,(A)
	MOVE	T,APOPJ1
FOO	CAIN	B,EXPR
	 MOVE	T,[CAILE D,NSUA]
FOO	CAIN	B,FEXPR
	 MOVE	T,[CAIE D,17]
	XCT	T
APOPJ1:	 JRST	CPOPJ1		;Don't smash if wrong # args wanted.
	CDRA	A,(A)		;ELSE WIN - SMASH THE CALL
	CARA	TT,(A)
	CAIE	TT,ID
	CAIGE	TT,CODMIN
	 JRST	CPOPJ1
	CDRA	A,(A)
	MOVE	TT,(AR5)
	MOVSI	T,(PCALL)	;FCALL BECOMES PCALL
	TLNE	TT,1000
	 MOVSI	T,(JRST)	;JCALL BECOMES JRST
	IOR	T,A
	MOVEM	T,(AR5)		;***SMASH!***
	PRET	>	;End of IFN 0

PAGE
LDGET:	JSP	D,LDFERR
  REPEAT 0,<
	CAMN	TT,XC-1
	JRST	LDLHRL
	MOVE	D,TT		;[GET DDT SYMBOL PATCH]
	TLNN	D,200000	;MAYBE THE ASSEMBLER LEFT US A VALUE?
	 JRST	LDGET2
	JSP	T,LDGTWD	;FETCH IT THEN
	SKIPE	LDF2DP
	 JRST	LDGET2		;CAN'T USE IT IF VERSIONS DIFFER
LDGET1:	TLNE	D,400000	;MAYBE NEGATE SYMBOL?
	 MOVNS	TT
	LDB	D,[400200,,D]	;GET FIELD NUMBER
	XCT	LDXCT(D)	;HASH UP VALUE FOR FIELD
	MOVE	T,LDMASK(D)	;ADD INTO FIELD
	ADD	TT,-1(R)	; MASKED APPROPRIATELY
	AND	TT,T
	ANDCAM	T,-1(R)
	IORM	TT,-1(R)
	JRST	LDBIN

LDGET2:	PSAVE	.		;RANDOM P SLOT
	PSAVE	AR4		;SAVE UP ACS
	PSAVE	D
	PSAVE	R
	PSAVE	F
	MOVEI	R,0
	TLZ	D,740000
	CAME	D,LAPFIV(R)	;IF DDTSYM REQUEST IS FOR A GLOBAL SYM
	 JRST	LDGT5A		;THEN FIND IT IN THE LAPFIV TABLE, AND GET ITS 
	LSHC	R,-2		;GLOBALSYM INDEX FROM THE PERMUTATION TABLE
	LSH	F,-42
	LDB	TT,LDGET6(F)
	MOVE	TT,LSYMS(TT)
	JRST	LDGT5B
LDGT5A:	MOVEI	TT,R70
	CAMN	D,[SQUOZE 0,R70]
	 JRST	LDGT5B
	PCALL	UNSQOZ		;CONVERT SQUOZE TO A LISP SYMBOL
	MOVEI	C,(A)
	MOVEI	B,QSYM		;TRY TO FIND SYM PROPERTY
	PCALL	GET
	JUMPN	A,LDGETJ		;WIN
	SKIPN	JOBSYM
	 JRST	LDGETX
	LDB	D,[004000,,-2(P)]
LDGET4:	MOVE	TT,D
	IDIVI	D,50
	JUMPE	R,LDGET4
	PCALL	GETDD0
	JRST	LDGETX
PAGE
LDGT5B:	MOVEM	TT,-4(P)	;WIN, WIN - USE RANDOM P SLOT
	MOVEI	A,-4(P)		; TO FAKE UP A FIXNUM
	JRST	LDGETJ


LDGETX:	MOVEI	A,(C)
	PCALL	NCONS
	MOVEI	B,QGETDDTSYM	;DO A FAIL-ACT
	PCALL	XCONS
	PCALL	LDGETQ
LDGETJ:	PREST	F		;RESTORE ACS
	PREST	R
	PREST	D
	PREST	AR4
	MOVE	TT,(A)
	PCALL	TYPEP		;FIGURE OUT WHAT WE GOT BACK
	PREST	-1(P)		;POP RANDOM SLOT (REMEMBER THE LOCKI!)
	CAIN	A,FIXNU
	 JRST	LDGET1
LDGETV:	CAIN	A,FLONU		;USE A FLONUM IF WE GET ONE
	 JRST	LDGET1
LDGETW:	SKIPE	TT,JOBSYM
	 MOVSI	TT,1
	MOVEM	TT,LDDDTP(P)
	JRST	LDGET2

LDGETQ:;	FAC [CAN'T GET DDT SYMBOL - FASLOAD!]

LDGET6: REPEAT 4,<<11_^D24>+<<<3-.RPCNT>*11>_^D30> LAP5P(R)
>

LDXCT:	MOVSS TT	;INDEX FIELD
	HRRZS TT	;ADDRESS FIELD
	LSH TT,^D23	;AC FIELD
	JFCL		;OPCODE FIELD

LDMASK:	-1		;INDEX FIELD
	0,,-1		;ADDRESS FIELD
	0 17,		;AC FIELD
	-1		;OPCODE FIELD

LDLHRL:	HRLZ	TT,LDOFST
	ADDM	TT,-1(R)
	JRST	LDBIN
	   >

PAGE
LDAREF:	JSP	D,LDFERR
  REPEAT 0,<
	PSAVE	TT		;[ARRAY	REFERENCE]
	MOVE	D,@LDAPTR
	TLNN	D,777001
	 TLO	D,11
	MOVEM	D,@LDAPTR
	MOVEI	A,(D)
	PCALL	TTSR+1		;NCALL TO TTSR
	HLL	TT,(P)
	PXDROP	R70+1
	JRST	LDABS
	   >



LDATM:	LDB	T,[POINT 3,TT,3]	;[ATOMTABLE ENTRY]
	JRST	@LDATBL(T)

LDATBL:	LDATPN			;INTERNED ID
	LDATPI			;NON INTERNED ID
	LDATPS			;STRING
	LDATFX			;FIXNUM
	LDATFL			;FLONUM
	LDATBP			;POSNUM (POSITIVE BIGNUM)
	LDATBN			;NEGNUM (NEGATIVE BIGNUM)
	LDAREF			;TO GET ERROR

LDATPB:	MOVSI	C,(TT)
	MOVN	C,C
	HRRI	C,0(SP)
	JSP	T,LDGTWD
	MOVEM	TT,1(C)
	AOBJN	C,LDGTWD	; T still has return address
	PRET

LDATPN:	PCALL	LDATPB		;[ATOMTABLE INTERNED ID ENTRY]
	PCALL	INTER0
LDATP8:	MOVE	TT,LDAAOB
	MOVEM	A,@LDAPTR
	AOBJP	TT,LDAEXT
	MOVEM	TT,LDAAOB
	JRST	LDBIN

LDATPI:	PCALL	LDATPB		;[ATOMTABLE NON INTERNED ID ENTRY]
	PCALL	NOINTR
	TLO	A,20		;Mark for saving
	JRST	LDATB2
PAGE
LDATPS:	PCALL	LDATPB		;[ATOMTABLE STRING ENTRY]
	PCALL	MSTR1
	JRST	LDATB2

LDATFX:	JSP	T,LDGTWD	;[ATOMTABLE FIXNUM ENTRY]
	PCALL	FIX1A
	CAILE	A,INUMIN
	 TLOA	A,12		;INUM -- doesn't need GC pro.
	TLO	A,2
	JRST	LDATP8


LDATFL:	JSP	T,LDGTWD	;[ATOMTABLE FLONUM ENTRY]
	PCALL	FLO1A
	TLO	A,4
	JRST	LDATP8


LDATBN:	SKIPA	C,[NEGNU]	;[ATOMTABLE NEGNUM ENTRY]
LDATBP:	MOVEI	C,POSNU		;[ATOMTABLE POSNUM ENTRY]
	PSAVE	C
	MOVEI	C,(TT)
	MOVEI	B,NIL
LDATB1:	JSP	T,LDGTWD
	PCALL	FWCONS
	PCALL	CONS
	MOVE	B,A
	SOJG	C,LDGTWD	;T STILL HAS RETURN ADDRESS
	PREST	B
	PCALL	XCONS
LDATB2:	TLO	A,6
	JRST	LDATP8


LDAEXT:	MOVEI	T,FTFULL
	JRST	LDERRT
  REPEAT 0,<
	MOVM	T,LDGROW	;[ATOMTABLE EXTEND]
	MOVNS	T
	HRL	TT,T
	MOVEM	TT,LDAAOB	;  Another page or so.
	MOVS	TT,@LDAGCM
	ADD	TT,T		;  and protect the extension.
	MOVSM	TT,@LDAGCM
	JRST	LDBIN
	   >

PAGE
LDENT:	PCALL	LDEPIN			;[ENTRY POINT INFO]
FOO	SKIPN	VPREDEF
	 JRST	LDNRDF
	MOVE	A,-1(P)
	PCALL	GETD
	JUMPE	A,LDNRDF
	MOVE	A,-1(P)
	PSAVE	R
	PSAVE	AR4
	PCALL	WHEAD
	PCALL	PRIN1
	STRTIP	[SIXBIT / REDEFINED!/]
	PCALL	TOURET
	PREST	AR4
	PREST	R
LDNRDF:	PREST	B
	PREST	C
	PREST	A
FOO	CAIE	B,SUBR
	 JRST	.+3
FOO	MOVEI	B,EXPR
	JRST	.+4
FOO	CAIE	B,FSUBR
	 JRST	.+3
FOO	MOVEI	B,FEXPR
	SETOM	FFFSUB
	PCALL	IPUTD		;USES T,TT
	JRST	LDBIN

LDPEN:	PCALL	LDEPIN			;[PUT ENTRY POINT]
	PREST	B
	PREST	A
	PREST	C
	PCALL	PUT
	JRST	LDBIN

LDEPIN:	HRRZ	C,@LDAPTR		;[ENTRY POINT INFO]
	MOVSS	TT
	HRRZ	A,@LDAPTR
	PSAVE	A		;ENTRY NAME.
	PSAVE	C		;SUBR TYPE.
	JSP	T,LDGTWD	;TT_<ARGS,,ENTRY-RELOC>...
	MOVEI	A,@LDOFST
	CAILE	A,(R)
	 JSP	D,LDFERR
	PCALL	IMKCODE
	EXCH	A,-2(P)
	JRST	(A)
PAGE

LDLOC:	JSP	D,LDFERR
  REPEAT 0,<
	MOVEI	TT,@LDOFST
	MOVEI	D,(R)
	CAMLE	D,LDHLOC
	 MOVEM	D,LDHLOC
	CAMG	TT,LDHLOC
	 JRST	LDLOC5
	MOVE	D,LDHLOC
	SUBI	D,(R)
	MOVSI	D,(D)
	ADD	R,D
	HRR	R,LDHLOC
	SETZ	TT,
	ADD	AR4,[040000,,]
	JRST	LDABS
LDLOC5:	HRRZ	D,LDOFST
	CAIGE	TT,(D)
	 JSP	D,LDFERR
	MOVEI	D,(TT)
	SUBI	D,(R)
	MOVSI	D,(D)
	ADD	R,D
	HRRI	R,(TT)
	JRST	LDBIN	   >
PAGE
LDPUT:	JSP	D,LDFERR
  REPEAT 0,<
	SKIPN	A,V$SYMBOLS	;[PUT DDT SYMBOLS]
	 JRST	LDPUT3
	CAIE	A,SYMBOLS
	 JRST	LDPUT7
	TLNN	TT,40000
	 JRST	LDPUT3
LDPUT7:	SKIPN	JOBSYM
	 JRST	LDPUT3
	PSAVE	AR4
	JUMPL	TT,LDPUT2
	MOVE	D,R
LDPUT0:	PSAVE	D
	PSAVE	F
	TLZ	TT,740000
LDPUT1:	MOVE	T,TT
	IDIVI	TT,50
	JUMPE	D,LDPUT1
	MOVEI	B,-1(P)
	MOVSI	R,400000
	PCALL	PUTDD0
	JRST	LDRSTX

LDPUT2:	MOVE	D,TT
	JSP	T,LDGTWD
	EXCH	TT,D
	TLNN	TT,100000
	 JRST	LDPT2A
	MOVE	T,LDOFST
	ADD	T,D
	HRRM	T,D
LDPT2A:	TLNN	TT,200000
	 JRST	LDPUT0
	HRLZ	T,LDOFST
	ADD	D,T
	JRST	LDPUT0

LDPUT3:	JUMPGE	TT,LDBIN	;DON'T WANT TO PUT DDT SYM, BUT
	JSP	T,LDGTWD	; MAYBE NEED TO FLUSH EXTRA WORD
	JRST	LDBIN
	 >
PAGE
LDEVAL:	SETZ	C,		;[EVALUATE MUNGEABLE]
	PCALL	LDLIST
	PSAVE	A
	PSAVE	C
	PSAVE	AR4
	PSAVE	R
	MOVEI	A,(R)
	PCALL	FIX1A
FOO	MOVEM	A,VBPORG	;Permit the mungeable to alter BPORG.
	SKIPL	A,LDPRLS-4(P)
FOO	 HRRZM	A,VP.URCLOBRL	;Save us in case of ERR.

	MOVE	A,-3(P)
	PCALL	EVAL
	EXCH	A,-3(P)		;Save value, retrieve S-expr.

	PSAVE	A
FOO	CDRA	A,VP.URCLOBRL
	HRRM	A,LDPRLS-5(P)
FOO	MOVE	A,VBPORG
	PCALL	NUMVAL
	PREST	B
	PREST	R
	SUBI	A,(R)		;If BPORG unchanged,
	JUMPE	A,LDEVL5	;  then leave R & FARRAY alone.
	JUMPLE	A,LDEVL4	;  If lowered, keep R, just fix FARRAY.
	ADDM	A,LDOFST	;Hence can't do future LDLOC **********
	HRLI	A,(A)
	ADD	R,A		;Else decrease space-avail left.
LDEVL4:	
FOO	MOVE	A,VFARRY	;Save S-exprs which change BPORG.
	PCALL	XCONS
FOO	HRRZM	A,VFARRY
LDEVL5:	PREST	AR4
	PREST	C
	PREST	A
	JUMPN	C,LDBIN		;IF -1, THROW AWAY VALUE;
	PCALL	%GCPRO		;OR -2, PROTECT & ENTER IN ATOMTABLE.
LDEVL7:	TLO	A,16		;FROM LDQLS, IS ALREADY PROTECTED
	JRST	LDATP8


%GCPRO:	HRRZ	B,LDGPRO-1(P)
	PCALL	CONS
	HRRM	A,LDGPRO-1(P)
	CARA	A,(A)		;RETURN WHAT WE JUST APPENDED.
	PRET

PAGE
LDBEND:	CAME	TT,[ASCII \FASLP\] ;[END OF BINARY]
	 JSP	D,LDFERR
	AOS	LDEOFJ		;Now have seen End-of-Data in a file...
				;  Update BPS bounds and protect atoms
				;  from GC, then try for next file.
LDFEND:				;[END OF FILE]
	HRRZ	A,R
	CAMGE	A,LDHLOC
	 MOVE	A,LDHLOC
	PCALL	FIX1A
FOO	MOVEM	A,VBPORG	;UPDATE BPORG
	HRRZ	R,LDAAOB
LDGCPR:	SOJLE	R,LDSDPL	;[GC PROTECT AS YET UNPROTECTED ATOMS]
	MOVEI	TT,(R)
	MOVE	AR5,@LDAPTR
	HRRZ	A,AR5
	TLNN	AR5,777010	;IF VALUE-CELL OR ALREADY PROTECTED,
	TLNN	AR5,1		;OR NO NEED (NEVER REF'D),
	 JRST	LDGCPR		;  PASS BY.
	TLNE	AR5,26
	 JRST	LDGCP1		;FIX,FLO,BIG,string or non-interned id
	JRST	LDGCPR
LDGCP1:	HRRZ	A,AR5
	PCALL	%GCPRO
	JRST	LDGCPR


LDSDPL:	SKIPGE	TT,LDPRLS(P)	;[RE-TRY SMASHING DOWN PURE LIST]
	 JRST	LDEOMM
FOO	MOVEM	TT,VP.URCLOBRL	;Following retains locs unsmashed.
FOO	MOVEI	R,VP.URCLOBRL
LDSDP1:	SKIPN	TT,LDPRLS(P)
	 JRST	LDEOMM
LDSDP2:	CDRA	T,(TT)
	MOVEM	T,LDPRLS(P)
	CARA	C,(TT)
	JSP	AR5,TRYSMSH
	 JRST	LDSDP3
	CDRA	R,(R)
	JRST	LDSDP1
LDSDP3:	MOVE	TT,LDPRLS(P)
	RPLCD	TT,(R)
	JRST	LDSDP1

PAGE
LDEOMM:	SKIPN	A,LDGPRO(P)	;Have processed a FASL file completely,
	 JRST	LDFNIL
FOO	MOVE	B,VF.LIST	;  and protected internal Lisp node refs
	PCALL	CONS		;  off the PDL with this final save.
FOO	MOVEM	A,VF.LIST
LDFNIL:	MOVE	A,LDAGCM
	MOVE	A,(A)		;Now clear array (so won't be SSAVEd),
	SETZM	0(A)		;  and read til true EOF does ERR $EOF$
	AOBJN	A,.-1		;  or see start of next FASL in series.
				;However, doesn't clear access routine.
	SETOM	LDEOFJ		;EOF will be okay, or start of next file.
	JRST	LDMORE		;Continue, with the extra PDL cells.



LDGTWD:	PCALL	TYID		;This is BINI w/o Lisp # conversion...
	MOVE	TT,A		;  so inputting a 36-bit word or $EOF$.
	JRST	0(T)


FASLNC:	MOVEI	T,BPFULL
	JRST	LDERRT

LDFERR:	SKIPGE	T,LDEOFJ	;Externally invoked after any ERRSET.
	 JRST	LDFSUB		;  OK - return after proper EOF.
	MOVE	T,LDEOFJ
LDERRT:	MOVEI	A,LDERRN	;Change...
	MOVEM	A,LDEOFJ	;  Avoid doubly-printed LERRs.
	CAILE	T,LDERRN
	 ERRL1	^D149,[SIXBIT \FASLOAD BUG!\]
	JRST	.+1(T)		;Else dispatch to the various errs...
LDERR0:	 ERRL1	^D150,[SIXBIT \FASLOAD EMPTY FILE!\]
	 ERRL1	^D151,[SIXBIT \FASLOAD FORMAT ERR!\]
	 ERRL1	^D152,[SIXBIT \FASLOAD GC-PRO ERR!\]
	 ERRL1	^D153,[SIXBIT \FASLOAD EXCEEDS BPS!\]
	 ERRL1	^D154,[SIXBIT \FISLTABLE FULL!\]
LDERRN==.-LDERR0
	 ERRL1	^D155,[SIXBIT \NOGO!\]

LDFSUB:	SKIPN	FFFSUB
	 PRET
	SETZM	FFFSUB
FOO	SKIPE	%MSG
	 STRTIP	[SIXBIT /_*** (F)SUBR CONVERTED TO (F)EXPR_!/]
	PRET
	>		;End of IFN OFLD

IFN	OFLD!NFLD,<
;Try convert slow link to fast link
TRYSMSH:HRRZ	A,(C)		;right half of instruction
	HLRZ	T,(C)		;left half
	CAIL	T,(FCALL)	;is it FCALL or
	CAILE	T,777(JCALL)	; JCALL
	 JRST	(AR5)		;No! Treat as sucessful, i.e. never smash
	PCALL	GETD		;get function definition
	 JUMPE	A,1(AR5)	; unsucessful if wasn't there
	MOVSI	TT,(PCALL)	; replacement FCALL - PCALL
	TRNE	T,1000
	 MOVSI	TT,(JRST)	; JCALL - JRST
	ANDI	T,740		;Now check EXPR - FEXPR
FOO	MOVEI	D,EXPR
	CAIN	T,740
FOO	 MOVEI	D,FEXPR		;argcount 17 means call a FEXPR
	CARA	B,(A)		;get function type
	CAIE	B,(D)		;is it right type for the call?
	 JRST	1(AR5)		;No! unsucessful
	CDRA	A,(A)		;code part
	CARA	D,(A)		;check tag
	CAIE	D,ID
	CAIGE	D,CODMIN
	 JRST	1(AR5)		;not a code pointer! unsucessful
	HRR	TT,(A)		;get code address into new instruction
	MOVEM	TT,(C)		;change instruction
	JRST	(AR5)		;sucessful
	>	;End of IFN OFLD!NFLD

IFN	NFLD,<
;New version of FASLOD
FASLOAD:PSAVE	[0]		;internal F.LIST
	HRRM	P,LDQLIS	;save its pointer
FOO	SKIPE	VPURIFY		;want to try converting slow links to fast?
	 TDZA	B,B		;yes
	SETO	B,		;no! make negative to indicate that
	PSAVE	B		;internal P.URCLOBRL
	HRRM	P,LDPURC	;save its pointer
	MOVEM	P,LDSTCK#	;save for stack check at end
	JSP	D,ATMTYP	;check F.ISLTABLE
	 CAIE	TT,VECT		;is it a vector?
	 ERRL2	^D168,[SIXBIT /NO TABLE FOR FASL!/]	;no! error
	CDRA	A,(A)		;get its base address
	SETZM	(A)		;first element is NIL
	HRRM	A,CTOPAT	;current top of table
	HRRM	A,LDATBAS	;base of table
	JSP	T,RSTBPO	;set internal BPORG and BPEND
	SETZM	CALHLF		;indicate need new word in half word buffer
	MOVEI	D,LDLOP+1	;return address for LDBYT
LDNWD:	PCALL	TYID		;byte buffer is empty. get new word
	MOVEM	A,LDBTWD	;save word in buffer
	MOVE	A,[POINT 6,LDBTWD]	;get byte pointer
	MOVEM	A,LDBTPO#	;save it
LDBYT:	ILDB	A,LDBTPO	;get a byte
	JUMPN	A,(D)		;not 0 means not empty buffer
	HRRZ	TT,LDBTPO	;buffer might be empty
	CAIN	TT,LDBTWD	;does pointer still point to buffer?
	 JRST	(D)		;yes! 0 byte
	JRST	LDNWD		;no! buffer empty

LDID:	JSP	D,LDHLF		;Get length of id
	PCALL	%FSLID+1	;make interned id
LDPUTA:	AOS	.+1		;update top of table
CTOPAT:	MOVEM	A,X		;move object into table
 ;this is the loader loop
LDLOP:	JSP	D,LDBYT		;get new loader code byte
	CAIG	A,LDBTMX	;is it a legal code
	 JRST	@LDJTAB(A)	;Yes! Dispatch
	ERRL2	^D169,[SIXBIT /FASL FORMAT ERROR!/]	;No! Error

LDJTAB:	LDEND
	LDID
	LDGENSYM
	LDSTRNG
	LDPOSN
	LDNEGN
	LDFIXN
	LDFLON
	LDQUO
	LDCAL
	LDRLO
	LDAXCON
	LDXCON
	LDOFFSET
	LDENTRY
	LDXPR
	LDLAPBLOCK
	LDNCON
	LDPUTV
	LDMKVCT
	.LDABS
	LDPUSH
	.LDEVAL
	LDFLUID
	LDSYM
	LDEVID
	LDSETQ
	LDIPUT
	.LDPUT
	LDIPTD
	LDPUTD
	LDNUMP
	LDXPRS
	LDPOP
	LDEVIX
	.LDLIST
	LDPOPN
	LDPROTECT
LDBTMX==.-LDJTAB-1
LDGENSYM:			;make non interned id
FOO	MOVEI	C,PNAME
	PCALL	MKFWLIS		;make print name list
	PCALL	IDCONS-1	;make into id
	JRST	LDPUTA		;put into table

LDPOSN:	SKIPA	C,CPOSNU	;positive bignum
LDNEGN:	MOVEI	C,NEGNU		;negative bignum
	JRST	LDSTRNG+1

LDSTRNG:MOVEI	C,STRNG		;string
	PCALL	MKFWLIS		;read and make full word list
	JRST	LDPUTA		;put into table

MKFWLIS:JSP	D,LDHLF		;read length of list
	MOVE	TT,A		;save count
	SKIPA	B,[0]		;start with NIL
	MOVE	B,A		;current list
	PCALL	TYID		;read a word
	PCALL	BCONS		;cons into list
	SOJG	TT,.-3		;go back for more
	HRL	A,C		;get tag
	JRST	DCONSA		;cons it

LDFIXN:	PCALL	BINI		;read a fixnum
	JRST	LDPUTA		;put into table

LDFLON:	PCALL	TYID		;read a word
	PCALL	FLO1A		;tag as floating point number
	JRST	LDPUTA		;put into table

LDMKVCT:JSP	T,SAVBPO	;allow BPORG to be changed
	JSP	D,LDHLF		;get uplim for vector
	PCALL	MKVECT+1	;make vector
	HRRZ	C,(A)		;vector address
	HRRM	C,CLIPTV	;update "current vector base"
	MOVE	C,A
	JSP	T,RSTBPO	;update internal BPORG
	MOVE	A,C
	JRST	LDPUTA		;put vector into table

LDPUSH:	MOVEI	T,LDPU1		;return address, push on stack
LGETVX:	JSP	D,LDHLF		;get table index
	HRRZ	A,@LDATBAS	;get element from table
	JRST	(T)

.LDABS:	MOVEI	D,LDPU1		;push on stack
LDHLF:	SETZ	A,
	EXCH	A,CALHLF#
	JUMPN	A,.+3	
	PCALL	TYID		;half word buffer empty. read new word
	HLROM	A,CALHLF	;save in buffer, -1 in lh make non-zero
	MOVEI	A,(A)		;get right half (get rid of -1)
	JRST	(D)		;return

LDAXCON:MOVEI	D,.+3		;make list ending with absolute
	JRST	LDHLF
LDXCON:	JSP	T,LGETVX	;make list ending with table element
	SKIPA	TT,A		;save table element in TT
LDNCON:	SETZ	TT,		;end with NIL (ordinary list)
	JSP	D,LDHLF		;length of list
	EXCH	A,TT		;get end into A
	PREST	B		;get element from stack
	PCALL	XCONS		;cons into list
	SOJG	TT,.-2		;maybee more
LDPU1:	PSAVE	A		;save on stack
	JRST	LDLOP		;return to loop

;execute EXPR, arguments are on stack. put result on stack
LDXPR:	JSP	T,LGETVX	;get function id from table
	PSAVE	A		;save it
LDXPRS:	JSP	T,SAVBPO	;function is on stack
	JSP	D,LDBYT		;number of args
	PREST	REL		;function
	DPB	A,[POINT 4,LDCALL,ACFLD] ;update call instruction
	MOVN	T,A
	JSP	TT,PDLARG	;put args into regs
LDCALL:	CALLF	X,(REL)		;call function
	PSAVE	A		;save result on stack
	MOVEI	T,LDLOP		;return address
RSTBPO: ;Update internal BPORG and BPEND as the might have been changed
FOO	HRRZ	A,VBPEND
	PCALL	NUMVAL
	HRRM	A,LDBPEN	;update internal BPEND
FOO	HRRZ	A,VBPORG
	PCALL	NUMVAL
	HRRM	A,LDBPOR	;update internal BPORG
	JRST	(T)
	
.LDEVAL:JSP	T,SAVBPO
	JSP	T,LGETVX	;get fexpr id
	PREST	B		;argument list
	PCALL	CONS
	PCALL	EVAL		;evaluate fexpr
	JRST	LDCALL+1

LDPOP:	P1DROP			;remove top of stack
	JRST	LDLOP

LDEVID:	JSP	T,LGETVX	;get id from table
	PCALL	EVAL		;get its value
	JRST	LDPU1		;push it on stack

LDSETQ: JSP	T,LGETVX	;get id from table
	PCALL	BIND1		;get its value cell
	PREST	(A)		;update value cell from stack
	JRST	LDLOP

LDIPUT:	JSP	T,LGETVX	;get id from table
	HRRM	A,CLIPUT	;update "current property indicator"
	JRST	LDLOP

LDIPTD:	JSP	T,LGETVX
	HRRM	A,CLIPTD	;update "current function type"
	JRST	LDLOP

.LDPUT:	JSP	T,LGETVX
	PREST	C		;property value
CLIPUT:	MOVEI	B,X		;property indicator
	PCALL	PUT
	JRST	LDLOP

LDPUTD:	JSP	T,LGETVX
	PSAVE	A		;save function id
FOO	MOVEI	B,TRACE		;remove TRACE property
	PCALL	REMP1
FOO	SKIPN	VPREDEF		;want to warn for redefined function
	 JRST	NOPRDF		;no!
	MOVE	A,(P)		;is function
	PCALL	GETD		; already defined
	JUMPE	A,NOPRDF
	MOVE	A,(P)		;yes!
	PCALL	WHEAD		;warning header
	PCALL	PRIN1		;print function name
	STRTIP	[SIXBIT / REDEFINED!/]
	PCALL	TOURET		;return to current output
NOPRDF: PREST	C		;function id
	PREST	A		;function body
CLIPTD:	MOVEI	B,X		;function type
	PCALL	IPUTD		;define it
	JRST	LDLOP

LDPUTV:	JSP	D,LDHLF		;get vector index
	PREST	C		;value to put into vector
	SETZ	B,
	LSHC	A,-1
	JUMPN	B,.+3		;B = 0 means even index
CLIPTV:	HRLM	C,X(A)		;X is current vector base. updated by LDMKVCT
	JRST	LDLOP
	HRRM	C,@CLIPTV	;odd index. value goes into right half
	JRST	LDLOP

LDLAPBLOCK:		;load a block of code
	JSP	D,LDHLF		;no of words to load
LDBPORG:MOVEI	R,X		;internal BPORG
	MOVEI	C,(R)
	ADDI	C,(A)		;new BPORG
LDBPEND:CAILE	C,X		;compare with internal BPEND
	 JRST	BINER2		;error if bigger
	HRRM	C,LDBPOR	;update BPORG
	HRRM	R,LDRLBAS	;set block base addres for relocation
	SOJ	R,
	HRRM	R,LDRSTRT	;set patch address base
	HLLZS	MPAFUN		;no patch function seen
	MOVNI	C,(A)		;make 
	HRL	R,C		; iowd
	PCALL	TYID		;read a word
	MOVEM	A,1(R)		;deposit in BPS
	AOBJN	R,.-2		;maybee more
	JRST	LDLOP

MAPAT:	MOVEI	C,X		;old patch address
	ADDI	C,77
	MOVEI	T,(T)		;patching function
	CAIE	T,@MPAFUN	;same as old
LDRSTRT: MOVEI	C,X		;no! use patch base address. set by LDLAPBLOCK
	HRRM	T,MPAFUN	;set current patch function
MPARET:	JSP	D,LDBYT	;Get relative patch address. Patch funs return here
	JUMPE	A,[HRRM	C,MAPAT		;0 byte means save patch address
		   JRST	LDLOP]		; and end patching
	ADDI	C,(A)			;update patch address
	HRRZ	A,(C)			;get index or address
MPAFUN:	JRST	X			;go patch

LDRLO:	JSP	T,MAPAT			;enter patch loop
LDRLBAS:ADDI	A,X		;relocation base
	HRRM	A,(C)			;put into instruction
	JRST	MPARET			;return to patch loop

LDQUO:	JSP	T,MAPAT			;enter patch loop
	HRRZ	A,@LDATBAS		;get element from table
	HRRM	A,(C)			;put in instruction
	JRST	MPARET

LDCAL:	JSP	T,MAPAT			;enter patch loop
	HRRZ	A,@LDATBAS		;get table element
	HRRM	A,(C)			;put in instruction
LDPURC:	SKIPL	REL,X			;If iternal PURIFY switch is on
	JSP	AR5,TRYSMSH+1		; try to convert slow link to fast
	 JRST	MPARET		;did it or no PURIFY! return to patch loop
	MOVE	A,REL		;couldn't do it. get internal P.URCLOBRL
	HRLI	A,(C)			;cons instruction address
	PCALL	DCONSA			; into list
	MOVEM	A,@LDPURC		; and move into P.URCLOBRL
	JRST	MPARET			;return to loop

LDFLUID:JSP	T,LGETVX		;get id from table
	PCALL	BIND1			;get its value cell
	JRST	LDPUTA			;put it into table

LDEVIX:	MOVE	A,(P)			;top of stack
	JSP	D,NATMTYP		;check if it needs to be gc-protected
	 JRST	LDEPRO			;not atom! needs protection
	JUMPE	TT,.LDLIST		;INUM doesn't need potection
	CAIE	TT,ID			;is an id?
	 JRST	LDEPRO			;no! protect
	PCALL	.INTERNP		;is it interned
	JUMPN	A,.LDLIST		;if yes, don't protect
	MOVE	A,(P)			;get top of stack
LDEPRO:	CDRA	B,@LDQLIS		;internal F.LIST
	PCALL	CONS
	HRRM	A,@LDQLIS		;update internal F.LIST
.LDLIST:PREST	A			;take top of stack
	JRST	LDPUTA			;put it into table

LDSYM:	JSP	T,LGETVX		;get id from table
	MOVE	T,A			;save in case of error
FOO	MOVEI	B,SYM			;get SYM
	PCALL	GET			; property
	JUMPE	A,[MOVE	A,T		;if none
		   ERRE2 ^D38,[SIXBIT / IS NOT A SYM!/]]	;error
	PCALL	NUMVAL			;get address
	JRST	LDPUTA			;put into table

LDOFFSET:
	JSP	T,LGETVX		;get address from table
	MOVE	T,A			;save it
	JSP	D,LDHLF			;get offset
	ADDI	A,(T)			;update address
	JRST	LDPUTA			;put it into table

LDNUMP:	JSP	T,LGETVX		;get object from table
	PCALL	FIX1A			;convert to number
	JRST	LDPU1			;put on stack

LDPOPN:	PREST	A			;get top of stack
	PCALL	NUMVAL			;convert to address
	JRST	LDPUTA			;put into table

LDPROTECT:		;protect objects by consing them into internal F.LIST
LDQLIS:	CDRA	B,X			;get internal F.LIST
	JRST	.+3			;enter loop
	PCALL	CONS			;cons object into list
	MOVE	B,A			;save list
	JSP	T,LGETVX		;get new object
	JUMPN	A,.-3			;if not NIL go back
	HRRM	B,@LDQLIS		;update internal F.LIST
	JRST	LDLOP

LDENTRY:HRRZ	C,LDRLBAS		;get start of lap block
	JSP	D,LDHLF			;get relative address
	ADDI	C,(A)			;get real address
	JSP	D,LDBYT			;no of args
	EXCH	A,C
	PCALL	IMKCODE			;make code pointer
	JRST	LDPU1			;push on stack

LDEND:	CAME	P,LDSTCK		;end of loading. check stack consistency
	 ERRL2	^D170,[SIXBIT /FASL STACK OUT OF SYNC!/]
	PREST	B			;internal P.URCLOBRL
	JUMPL	B,NOPURC		;negative if PURIFY is off
FOO	MOVEI	A,VP.URCLOB
	PCALL	NCONC			;concatenate to P.URCLOBRL
	MOVE	REL,A			;try smash instructions on list
	CDRA	AR4,(REL)
	JRST	SMSHLE			;enter loop

SMSHLP:	CARA	C,(AR4)			;get instruction address
	JSP	AR5,TRYSMSH		;try smash instruction
	 JRST	.+2			;Smashed!
	 MOVE	REL,AR4			;Not smashed! keep address in list
	CDRA	AR4,(AR4)		;next element
	HRRM	AR4,(REL)	;this will remove address of smashed instruction
SMSHLE:	JUMPN	AR4,SMSHLP		;if more go back
NOPURC:	PREST	B			;internal F.LIST
FOO	HRRZ	A,VF.LIST		;F.LIST
	PCALL	XCONS			;save internal F.LIST on F.LIST
FOO	HRRM	A,VF.LIST		;update F.LIST
	MOVEI	T,CPOPJ			;return address
SAVBPO:	HRRZ	A,LDBPEN
	PCALL	FIX1A
FOO	HRRZM	A,VBPEND
	HRRZ	A,LDBPOR
	PCALL	FIX1A
FOO	HRRZM	A,VBPORG	;Allow change of BPORG
	JRST	(T)

LDBTWD:	X
LDATBAS:Z	X(A)	;First six bits of this word must be 0 to make LDBYT correct
;%FSLID is an EXPR that reads an id from a FSL file, it is used by
; the PRELOAD device.
%FSLID:	PCALL	TYID		;Get length of id
	MOVN	C,A		;make
	HRLZI	C,(C)		;
	HRRI	C,(SP)		; iowd
	PCALL	TYID		;get a word
	MOVEM	A,1(C)		;put in buffer
	AOBJN	C,.-2		;get more if not finished
	JRST	INTER0		;intern it
	>	;End of IFN NFLD
SUBTTL 	ALVINE AND LOADER INTERFACES		--- PAGE 22

;interface to alvine

IFN  AED,<
ED:	MOVEI	REL,X		;Reset to EDP2 by: STRT, EXCISE, EXCORE.
	JRST	(REL)
EDP2:	PSAVE	A
	HRRZ	A,CORUSE
	HRRM	A,LST
	AOS	A
	HRRM	A,ED
	MOVSI	A,(SIXBIT /ED/)
	PCALL	SYSINI
	HRLM	A,LST	
	MOVNS	A
	PCALL	MORCOR
	PCALL	SYSINQ
	PREST	A
	JRST	ED

GRINDEF:PSAVE	A
	PCALL	ED
	PREST	A
	JRST	2(REL)
	>		;end of IFN AED

EXCISE:	MOVE	A,JRELO
IFN AED,<MOVEI	B,EDP2
	HRRM	B,ED>
IFN ALOD,SETZM LDFLG		;initial loader symbol table flag
	CALLI	A,CORE
	 JRST	.+1
	JSR	IOBRST
IFE HCBPS,PCALL	CHKVBP		;Ensure BPORG and BPEND in low BPS.
	JRST	TRUE

PAGE
VAR
LIT
PAGE
;	lisp loader interface
IFN	ALOD,<
LOAD:	AOS	B,CORUSE
	MOVEM	B,OLDCU#
	MOVEM	A,LDPAR#
	JUMPE	A,LOAD2		;If NIL, @.JBREL+1
FOO	MOVE	A,VBPORG	; else into BPS @BPORG.
	PCALL	NUMVAL
	MOVE	B,A
LOAD2:	MOVEM	B,RVAL		;final destination of loaded code
	MOVSI	A,(SIXBIT /LOD/)
	PCALL	SYSINI
	SUBI	A,150		;extra room for locations 0 to 137 and slop
	MOVNS	A		;length(loader) = 5400 approx.
	HRRZM	A,LODSIZ#
	ADDI	A,10		;Space for start of symbol table etc.
	PCALL	MORCOR		;expand core for loader
	MOVEM	A,LOWLSP#	;location of blt'ed low lisp
	MOVE	B,LODSIZ
	ADD	B,A
	MOVEM	B,HVAL		;temporary destination of loaded code
	HRLI	A,0		;<0,,LOWLSP> -- HVAL.
	BLT	A,(B)		;blt up low lisp
	HLL	A,NAME+3	;IOWD length(loader),137 .
	HRRI	A,137-1
	PCALL	SYSINP
	SKIPE	LDFLG#
	 JRST	LOAD3		;If already have them, skip SYMs.
	MOVSI	A,(SIXBIT /SYM/)
	PCALL	SYSINI
	MOVNS	A		;length symbols
	PCALL	MORCOR		;expand core for symbols
	SKIPGE	B,.JBSYM
	 SOS	B		;if no symbol table, use original jobsym.
	HLRZ	A,NAME+3	;-length(symbols)
	ADDB	A,B
	HLL	A,NAME+3	;symbol table iowd
	PCALL	SYSINP
	HRRM	B,.JBSYM
	HLLZ	A,NAME+3
	ADDM	A,.JBSYM
	SETOM	LDFLG		;Lisp symbols loaded, until next EXCISE.
	SKIPA
LOAD3:	SOS	.JBSYM		;want jobsym to point one below 1st symbol
	MOVE	3,HVAL		;h
	MOVE	5,RVAL		;r
	MOVE	2,3
	SUB	2,5		;x=h-r
	HRLI	5,12		;(w) --	LH index needed because
	HRLI	2,11		;(v)	  uses @X, etc.
	SETZB	1,4		;(N,S)
IFN SYDEV,<MOVE 4,SYSNUM>	;Tell Loader current SYS: used by Lisp.
	JSP	0,140		;call the loader
LOAD4:	HRRZM	5,RLAST#	;last location loaded(in final area)
	MOVE	T,OLDCU
	MOVE	A,.JBSYM
	MOVEM	A,.JBSYM(T)
	MOVE	A,.JBREL
	MOVEM	A,.JBREL(T)	;update jobrel
	HRLZ	0,LOWLSP
	SOS	LODSIZ
	AOBJN	0,.+1		;<LOWLSP+1,,A> -- LODSIZ.
	BLT	0,@LODSIZ	;blt down low lisp
	MOVE	0,@LOWLSP	;<LOWLSP,,NIL> -- all accs now restored.
	MOVE	B,RLAST
	MOVE	A,RVAL
	HRL	A,HVAL		;<HVAL,,RVAL> -- RLAST.
	SKIPE	LDPAR
	 JRST	BINLD		;If into BPS, check room first.
	MOVE	C,RLAST		;new coruse
LDRET2:	BLT	A,(B)		;blt down loaded code
	HRRZM	C,CORUSE	;top of code loaded
	MOVEI	B,1
	ANDCAM	B,.JBSYM
	SUB	C,.JBSYM	;length of free core
	ORCMI	C,776000
	AOJGE	C,START		;no contraction
	ADD	C,.JBREL	;new top of core
	MOVE	B,C
	PCALL	MOVDWN
	HRLM	C,.JBSA
	CALLI	C,CORE		;contract core
	JRST	.+1
	JRST	START


BINLD:	PSAVE	A		;Check for BPS exceeded...
	PSAVE	B		;<MOVEI	C,INUM0(B)
	CDRA	A,B		; CAML  C,VBPEND
	PCALL	FIX1A		;  JRST BPSERR
	PSAVE	A		; MOVEM C,VBPORG>
FOO	MOVE	B,VBPEND
	PCALL	.LESS
	JUMPE	A,[SETOM BPSFLG ;Flag "BPS exceeded" for LISP2 check.
		   JRST  START ]
FOO	PREST	VBPORG		;Update it; loading fits.
	PREST	B
	PREST	A
	SOS	C,OLDCU		;old top of core
	JRST	LDRET2
	>		;end of IFN ALOD
PAGE
IFN AED!ALOD,<
SYSINI:	MOVEM	A,NAME+1
IFLE <OPSYS+SYDEV-1>,<SETZM NAME+3 >
IFN SYDEV,<PSAVE SYSNUM
 IFLE OPSYS,<PREST .+2>
 IFG OPSYS,<PREST NAME+3> >
	INIT	17
IFE SYDEV,<SIXBIT /SYS/ >
IFN SYDEV,<
 IFLE OPSYS,< X >
 IFG OPSYS,<SIXBIT /DSK/ > >
	 0
	 JRST	AIN.4+1
	LOOKUP	NAME
	 JRST	SYSINER		;error
	INPUT	[IOWD 1,NAME+3	;input size of file
		0]
	HLRO	A,NAME+3
	PRET

SYSINER:RELEASE
IFE ALOD,<ERRL1	^D156,[SIXBIT /LISP.ED MISSING!/]>
IFN ALOD,<
	MOVSI	B,(SIXBIT /SYM/)
	CAME	A,B		;Are we in LOAD mode?
 IFN AED,ERRL1	^D156,[SIXBIT /LISP.ED OR LOD MISSING!/]	;No, safe to use
 IFE AED,ERRL1	^D156,[SIXBIT /LISP.LOD MISSING!/]	; low core routines.
	OUTSTR	[ASCIZ /
LISP.SYM not found!! No load.
/]				;  Yes -- Loader in low core, though,
	MOVE	5,RVAL		;	so have to fake the BLT
	JRST	LOAD4 		;	with original RVAL.
		>		;end of IFN ALOD 

NAME:	SIXBIT	/LISP/		;Filename of system,
	0			;  .* auxiliaries (e.g. SYM, LOD, ED).
	0
	0
	>		;end of IFN ALOD!AED
PAGE
IFN ALOD,<
SYSINP:	MOVEM	A,LST>		;LOAD
IFN ALOD!AED!RWB,<
SYSINQ:				;ED, RBLK
IFN OPSYS,<			;KLUDGE to circumvent bug in PA1050...
	MOVS	A,LST		;  to wit: uses SIN which plants a nul,
	SUB	A,LST		;    which clobbers wd after input-blk.
	HLRZ	A,A
  IFN HCBPS,<CAIGE A,400000>
	CAMGE	A,.JBREL
	 PSAVE	1(A)
	INPUT	LST
  IFN HCBPS,<CAIGE A,400000>
	CAMGE	A,.JBREL
	 PREST	1(A)	>
IFE OPSYS,<INPUT LST>		;ELSE just input it.
	STATZ	740000
	 ERRL1	^D157,AIN.8
	RELEASE
	PRET

LST:	0
	0
	>		;end of IFN ALOD!AED!RWB

AIN.8:	SIXBIT	/INPUT ERROR!/
PAGE
IFN ALOD,<
MOVDWN:	HLRZ	A,.JBSYM
	JUMPE	A,MOVS1
	ADDI	A,1(B)
	HRL	A,.JBSYM
	HRRM	A,.JBSYM
	BLT	A,(B)		;downward blt
	PRET

MOVSYM:	MOVE	B,.JBREL
	HRLM	B,.JBSA
	HLRE	A,.JBSYM
	JUMPE	A,MOVS1
	ADDI	B,1(A)		;new bottom of symbol table
	MOVNI	A,1(A)
	ADD	A,.JBSYM	;last loc of old symbol table
	HRRM	B,.JBSYM
	PSAVE	C
	MOVE	B,.JBREL	;last loc of new symbol table
	MOVE	C,(A)		;simulated upward blt
	MOVEM	C,(B)
	SUBI	B,1
	ADDI	A,-1		;lf+1,rt-1
	JUMPL	A,.-4
	PREST	C
	PRET

MOVS1:	HRRZM	B,.JBSYM
	PRET>		;end of IFN ALOD

;enter with size needed in a
;exit with pointer in a to core
MORCOR:	PSAVE	B
	PCALL	EXPND2
	MOVE	B,CORUSE#
	ADDM	A,CORUSE
	MOVE	A,B
	PREST	B
	PRET

EXPND2:	HRRZ	B,.JBSYM
	SUB	B,CORUSE
	SUBM	A,B
	JUMPL	B,EXPND3
	ADD	B,.JBREL	;new core size
	CALLI	B,CORE		;expand core
TCORE3:	 ERRL1	^D158,[SIXBIT /CAN'T EXPAND CORE!/]
IFN ALOD,<PSAVE	A
	PCALL	MOVSYM
	PREST	A>
IFE ALOD,<MOVE	B,.JBREL
	HRRZM	B,.JBSYM
	HRLM	B,.JBSA>
EXPND3:	PRET
SUBTTL 	SOSLINK INLINE WITH LISP MAIN		--- PAGE 23




%FPAGE:	SUBI	A,INUM0		;FIND-PAGE N, IN THE FILE.
	PSAVE	A
%FP.LP:	SOSG	A,0(P)
	 JRST	POPAJ		;Stop when get there, returning 0=NIL.
	PCALL	TYI		;(ERR $EOF$) if too few <ff>.
	CAIE	A,14
	 JRST	.-2
	JRST	%FP.LP

%NEXTTYI: PCALL	TYI		;Doing a PEEKC().
	MOVEM	A,OLDCH
	JRST	FIX1A


FILEP:	PCALL	FILEPX
	RELEASE	0,
	PRET

FILEPX:	PSAVE	A		;Test for a file's existence.
	MOVSI	B,(SIXBIT /DSK/);Clear any left over.
	MOVEM	B,DEV
	SETZM	PPN
	JUMPE	A,.+3
	JSP	D,ATMTYP
	 PCALL	NCONS
	MOVE	T,A		;Permit @((F.E)) or full @(DIR: D F.E)) .
	PCALL	IOSUB
	MOVEM	A,LOOKIN
IFN SYDEV,<PCALL SYSDEV >	;Change SYS: if necessary.
	MOVE	A,DEV
	MOVEM	A,DEV2
	INIT	0,17
DEV2:	 X
	 0
	 JRST	AIN.7
	PREST	A
	LOOKUP	0,LOOKIN	;Using chan 0 (no INC or INPUT needed).
	 MOVEI	A,NIL		;  file not found.
	PRET
PAGE
IFN SOSSW,<
%SOSSWAP:
	SUBI	2,INUM0		;(PAGE # .LT. 2^16, OF COURSE).
	SUBI	4,INUM0
	LSH	4,^D16		;ERGO, 2 BECOMES 400000
	PSAVE	4
	PSAVE	2
	PSAVE	1		;FILE SPECIFICATION
	MOVE	1,3
	PCALL	NUMVAL		;(LINE # .LT. 99999).
	MOVE	4,[POINT 7,T,34]
MKLIN1: IDIVI	1,^D10
	ADDI	2,60
	DPB	2,4
	ADD	4,[XWD 70000,0]
	TLNN	4,400000
	 JRST	MKLIN1
	TRO	T,1
	EXCH	T,(P)		;T WILL NOW CONTAIN FILE SPECIFICATION
	SETZM	DEV
	PCALL	IOSUB		;RETURNS FILENM IN A
	MOVEM	17,ACSAV+17
	MOVEI	17,ACSAV
	BLT	17,ACSAV+16	;SAVE ACCS 0-17 for return from subr.
	PREST	15
	PREST	16
	PREST	13		;00/01/02 == GET,R-O,CREATE.
	MOVEM	P,ACSAV+P
	MOVE	14,A
	HLL	13,EXT		;SET BY IOSUB
IFGE OPSYS,<CALLI 11,24		;GETPPN UUO
	 SETZ	11,
	HRRZS	11 >
IFL OPSYS,<GJINF
	MOVE	11,2 >
	SETZB	1,12

;HIGH ACCS FOR SOS ARE NOW SET ... TO WIT:
;
;ACC 11	= PPN
;    12	= (UNUSED).
;    13 = EXT,,FLAGS	;BITS 18-19 = 0 (GET FILE), 1 (READ-ONLY), 2 (CREATE IT)
;    14 = FILENM
;    15 = LINE #, IN ASCID FORM (BIT 35 ON);
;    16 = PAGE #.
PAGE

IFE OPSYS, <		;USE LABORIOUS METHOD OF MAKING CORE-IMAGE.
			;  == FOR 10/50 SYSTEMS...VESTIGIAL.

;SWAP IS NOT DECLARED INTERNAL/SUBR (THO IT COULD BE).

;FIRST SAVES ALL ACCUMULATORS AS FILE 'QQSVAC.TMP'
;SAV -- SWAPS OUT (EFFECTIVELY) 116 THRU MIN(LH(E+2),.JBREL)
;    -- MUST GO TO THE DISK (& WILL, REGARDLESS OF DEVICE).
;    -- USES 1;  DOES NOT SAVE ANY HIGH SEGMENT !!!
;    -- THE FORMAT IS A NON-ZERO-COMPRESS (75--END).
;    -- THE ACCS ARE RESTORED IF A RUN IS NOT DONE.
;RUN -- USES THE DEC RUN-UUO WHICH DESTROYS THE ACCUMULATORS
;    -- THEREFORE, IF YOU WISH TO PASS ARGUMENTS (IN THE ACCS)
;    --   TO THE NEW PROGRAM, PICK THEM UP FROM THE TMP FILE.


EXTERNAL .JBCOR,.JBS41,.JBDDT
SLOC==74
.JBSDD==114

SWAP:	MOVEI	1,ACBLK
	BLT	1,ACBLK+17   	;CAN'T OUTPUT FROM BELOW LOC 115
	MOVE	1,[XWD ACSAV,6]	;RESTORE UNCLOBBERED HI-ACCS
	BLT	1,17
	CALLI	1,30	;PJOB
	IDIVI	1,^D10
	LSH	1,6
	OR	1,2
	LSH	1,^D24
	OR	1,[SIXBIT/00SVAC/]
	MOVEM	1,ACHEAD
	ADDI	1,5460-4143	;'LP' - 'AC'

	INIT	17	;DUMP MODE
	 SIXBIT /DSK/
	 0		;NO BUFFERS
	 JRST	AOUT.4+1

	SETZM	ACHEAD+2
	SETZM	ACHEAD+3
	ENTER	ACHEAD
	 ERRL1	^D159,SWOUT2
	OUTPUT	[IOWD 20,ACBLK
		   0]
	STATZ	740000
	 ERRL2	^D160,SWOUT2
	CLOSE	
	STATZ	740000
	 ERRL2	^D161,SWOUT2

	MOVEM	1,IOFILE
	SETZM	IOFILE+2
	SETZM	IOFILE+3
	ENTER	IOFILE
	 ERRL2	^D162,SWOUT2

	HRRZ	2,.JBCOR
	MOVEM	2,OLDCOR
	MOVE	2,.JBREL
	HRRM	2,.JBCOR
	SUBI	2,SLOC		;NOT OUTPUTTING FIRST 0-SLOC LOCS
	MOVEM	2,1	;N WORDS OF DATA
	MOVN	2,2
	SUBI	2,1	;-(N+1) == DATA + NULL HEADER WORD
	HRLM	2,OLIST

	MOVE	2,.JBREL
	HRRM	2,MVX+^D9	;HIGHEST LOC BEFORE RELOC = DITTO BLT
	ADDI	2,2000
	CALLI	2,CORE	;SPACE TO RELOCATE INTO
	 ERRL2	^D163,SWOUT2

	MOVE	3,[XWD MVX,MV]
	BLT	3,MVE
	MOVE	3,[XWD 216,116]
	JRST	MV

MVX:	PHASE	4
MV:	MOVE	2,SLOC(1)
	MOVEM	2,SLOC+100(1)	;MOVE 100 UPWARD
	SOJG	1,MV
	SETZM	SLOC+100	;NULL HEADER WORD
	MOVE	2,.JBDDT
	MOVEM	2,.JBSDD+100
	MOVE	2,.JB41
	MOVEM	2,.JBS41+100
	OUTPUT	OLIST+100	;AT RELOCATED IOWD
	BLT	3,0-0		;MOVE BACK DOWN
MVE:	JRST	MVY
	DEPHASE

MVY:	MOVE	2,[XWD ACSAV,6]
	BLT	2,17	;RESTORE AGAIN OVER CODE
	HRRZ	2,MVX+^D10
	CALLI	2,CORE	;REDUCE CORE BY 1K TO PREVIOUS
	 STRTIP	[SIXBIT /_*** WOULDN'T REDUCE CORE_!/]

	STATZ	740000		;NOW CHECK FOR OUTPUT ERRORS
	 ERRL2	^D164,SWOUT2
	CLOSE	0,
	STATZ	740000
	 ERRL2	^D165,SWOUT2
	RELEAS	0,

	MOVE	2,OLDCOR
	HRRM	2,.JBCOR
	


RUNUUO:	SETZM	NEWCOR
	MOVSI	1,1		;SA INC
	HRRI	1,DEVC2
	CLRBFI		;DELETE CR,LF IF ANY...DISTURB SOS.

	CALLI	1,35	;RUN UUO
	HALT		;  POSSIBLY RECOVERABLE, BUT EXIT ANYWAY



ACBLK:	BLOCK	20
DEVC2:	SIXBIT/SYS/
	SIXBIT/SOS/
	SIXBIT/SAV/
	0
	0
NEWCOR:	
OLDCOR:	0-0
IOFILE:
ACHEAD:	SIXBIT/QQSVAC/
	SIXBIT/TMP/
	0
	0
OLIST:	XWD	0-0,SLOC+100-1
	0
SWOUT2:	SIXBIT	/COULDN'T SWAP SUCCESSFULLY_!/

	   >	;******** CLOSE OF  IFE OPSYS, FROM SWAP: ********.
PAGE

IFN OPSYS, <		;EASIER WITH TENEX

%SWAP:
	MOVSI	1,1		;SET B17
	MOVE	2,[POINT 7,FILSOS]
	GTJFN
	 JRST	SOSER1
	HRRZ	3,1		;AC1(RH) NOW HAS DESIRED JFN.

	MOVSI	1,(1B1+1B3)	;Spec. cap. & use AC2.
	MOVEI	2,0		;VIRTUAL ADDRESS OF ACCS.
	CFORK			;CREATE INFERIOR FORK.
	 JRST	SOSER2
	EXCH	1,3
	HRL	1,3		;SET UP (LH) WITH HANDLE
	JSYS	200		;GET JSYS

	HRRZ	1,3
	MOVEI	2,2		;INDEX INTO ENTRY-VEC
	SFRKV			;START THAT FORK
				;AC1 HAS INFERIOR-F HANDLE!
	WFORK			;CURRENT FORK WAITS UNTIL THE
				;  INFERIOR FORK TERMINATES.
	KFORK			;INF-FORK STILL EXISTS, SO!

SWAPEX:	MOVSI	17,ACSAV
	BLT	17,17		;Restore accs
	PRET			;  and return.

FILSOS:	ASCIZ	/<SUBSYS>SOS.SAV/

SOSER1:	OUTSTR	FILSOS
	OUTSTR	[ASCIZ / NOT FOUND
/]
SOSER2:	OUTSTR	[ASCIZ /COULDN'T SOSSWAP/]
	JRST	SWAPEX

	   >			;CLOSE OF IFN OPSYS.
		>	;******* Close of IFN SOSSW, from %SOSSWAP: ****

%ACSAV:
ACSAV:	BLOCK	20




PAGE
IFN JSYXEQ,<		;The rest of this page is under this switch
COMMENT 
The JSYS  function executes  a JSYS  and returns  the result.  It  is
called  as  JSYS(jsysno,arg1,arg2,arg3,retreg) where  jsysno  is  the
number of the JSYS, retreg is the number of the register in which the
executed JSYS will return its  value and argN is loaded into register
N as argument to the  JSYS.  The value of the global variable JSYSAR4
is taken as arg4 (initial value is 0).
If argN  is  a  number then  that  number  is converted  to  machine-
representation and loaded into reg N.
If  argN is not  the list (BUF)  then it must  be a string  or an id.
This  string or id  is written  in a buffer  as a ASCIZ  string and a
pointer to that string is loaded into reg N.
If argN is (BUF) then a  pointer to a stringbuffer is loaded into reg
N. Only one of the argN may be (BUF).
If there is a (BUF) this  indicates that the JSYS will write a string
into the  string buffer, using retreg as  updated string- pointer and
return as value the string converted into a LISP string.
If  there is no  (BUF) among the  arguments, then the  content of the
retreg register is converted into a LISP number and returned as value
of JSYS. 

%JSYS:	PSAVE	B			; A1 arg.
	PSAVE	C			; A2 arg.
	PSAVE	AR4			; A3 arg.
FOO	PSAVE	VJSYSAR4		; A4 arg.
	CAIG	A,INUM0+777		; JSYS number
	CAIGE	A,INUM0+1
	 ERRE2	^D39,[SIXBIT /NOT A JSYS!/]
	SUBI	A,INUM0
	HRRM	A,JSY			; Set which JSYS.
	MOVE	A,AR5
	CAIG	A,INUM0+4
	CAIGE	A,INUM0+1
	 ERRE2	^D40,[SIXBIT /NOT A RETURN REGISTER!/]
	SUBI	A,INUM0
	HRRM	A,RETREG	; Set which register contains the value
	MOVEI	AR5,1
	HRRM	AR5,RBUFAR		; No string returned.
	MOVEM	SP,STRST# ;Start of string buffer. Special stack is used
	HRREI	B,-3
JSARLP:	HRRM	B,NJSAR
NJSAR:	MOVE	A,X(P)			; Get arg.
	JSP	D,ATMTYP		; What type is it?
	 CAIE	TT,FIXNU		; If not a fixnum
	 JUMPN	TT,JSASTB	;  or an Inum must be string or buffer
	PCALL	NUMVAL		; A number. Convert to machine format
	MOVEM	A,@NJSAR		;  and set arg.
	JRST	JSARLE
JSASTB:	CAIE	TT,ID			; An id
	CAIN	TT,STRNG		;  or a string ?
	 JRST	JSASTR			; Yes!
FOO	CAIE	TT,BUF			; Return string buffer?
	 ERRE2	^D41,[SIXBIT /ILLEGAL JSYS ARG!/]	; No! Error.
	HRRM	B,RBUFAR	; Arg no for return string pointer.
	JRST	JSARLE
JSASTR:	MOVE	C,STRST			; String buffer position.
	MOVEI	B,1(C)
	HRROM	B,@NJSAR		; Set arg to string pointer.
	PCALL	PNAMUD			; Unpack into buffer
	PUSH	C,[0]			; Deposit zero at end of string.
	MOVEM	C,STRST			; Update string buffer.
JSARLE:	HRRE	B,NJSAR			; Next arg.
	AOJLE	B,JSARLP
	HRRZ	B,RBUFAR		; Return string?
	SOJE	B,NORST			; No!
	MOVE	B,STRST			; String buffer position.
	PUSH	B,[0]			; Zero first word.
RBUFAR:	HRROM	B,X(P)	; Set arg to string pointer for return string.
NORST:	HRRZM	B,STRST			; 0 or address of output string.
	PREST	4			; A4 arg.
	PREST	3			; A3 arg.
	PREST	2			; A2 arg.
	PREST	1			; A1 arg.
JSY:	JSYS	X
	 ERJMP	JSYERR
	 ERJMP	JSYERR
RETREG:	MOVE	A,X		; Load return value into register 1.
	SKIPE	B,STRST			; Return string?
	 JRST	MKSTR		; Yes! Convert to Lisp string.
	JRST	FIX1A		;No! Convert to LISP number and return

;JSYS error return
JSYERR:	PCALL	ERRSTR
	ERRE2	^D42,[SIXBIT /JSYS ERROR!/]

; ERRSTR returns the last system error message as a Lisp string;
ERRSTR:	HRROI	A,1(SP)			; Pointer to buffer for string.
	HRLOI	B,400000		; .FHSLF
	SETZ	3,
	ERSTR
	 ERJMP	EER
	 ERJMP	EER
MKSTR1:	MOVEI	B,1(SP)
MKSTR:	SKIPG	C,A	; Convert from ASCII string to LISP string.
	 JRST	FALSE			; Return NIL if no string.
	LDB	AR4,A			; Last character.
	JUMPN	AR4,NOBCKP		; O.k. if not null.
	CAIN	B,(A)			; Only one word?
	 JRST	NOBCKP			; Yes! Never step back pointer.
	HLRZ	AR4,A
	CAIN	AR4,350700		; Null in beginning of word?
	 MOVEI	C,-1(A)			; Yes! Step back pointer.
NOBCKP:	HRL	A,B			; Start of string.
	SUBI	B,1(SP)			;  - expected start of string.
	JUMPE	B,LMKSTR ; Don't need to move string if start is o.k..
	HRRI	A,1(SP)			; Expected start of string.
	SUBI	C,(B)			; Updated end of string.
	BLT	A,(C)			; Move string.
	JRST	LMKSTR			; Make into LISP string.

EER:
FOO	MOVEI	A,QST		;Couldn't get error string return ?
	PRET

GETAB$:	PCALL	NUMVAL
	HRRM	A,GETALO
	HLLZ	B,A
	MOVE	C,SP
GETALO:	MOVEI	A,X
	HRL	A,B
	GETAB
	 JRST	GERR
	PUSH	C,A
	AOBJN	B,GETALO
GERR:	MOVSI	A,700
	HRR	A,3
	JRST	MKSTR1

; !%XEQ generates inferior forks
%XEQ:	MOVEM	A,FORKH#	; FILENAME OR PREVIOUS FORK HANDLE #.
	MOVEM	B,STAD#		; T=START, NIL=RESUME, 0-N = EVEC POS.
	MOVEM	C,KILL#		; T=KFORK, NIL=KEEP FOR A RESUME-FORK.
	MOVEM	AR4,ACSADR#	; NIL=NONE, N=ADDR OF ACCBLK
	MOVEM	AR5,ARGSTR#	; NIL=NONE, RSCAN . TTYINP Tops20, TTYINP Tenex
 IFL	OPSYS,<		;RSCAN not defined in TENEX
	JUMPE	AR5,NORTYI
	CARA	A,(AR5)
	JUMPE	A,NRSCN		; NO RSCAN
	PCALL	PNAMUK
	PUSH	C,[0]			; Must end with 0
	HRROI	A,1(SP)
	RSCAN
	 JRST	FAIL6
NRSCN:	MOVE	A,FORKH	>	;END OF IFL OPSYS
NORTYI:	PCALL	NUMBERP			; IF NUMBERP FILE/FORKH
	JUMPN	A,OLDFORK		;  THEN GOTO OLDFORK;
	MOVE	A,FORKH
	PCALL	PNAMUK
	PUSH	C,[0]			; Must end with 0
	MOVSI	A,100001		; OLD FILES ONLY.
	HRROI	B,1(SP)
	GTJFN				; GTJFN OF STRING ON SP STACK.
	 JRST	FAIL1
	MOVEM	A,SAVJFN#
	MOVSI	A,200000		; 1B1
	SETZ	B,			; SETUP ACS BELOW, IF ANY.
	CFORK
	 JRST	FAIL2
	MOVEM	A,FORKH
	HRRZ	A,SAVJFN
	HRL	A,FORKH
	JSYS	200			; GET OF FORK,,JFN.
	SKIPN	A,STAD
FOO	 MOVEI	A,TRUTH			; START, NOT RESUME.
	MOVEM	A,STAD
	JRST	TRYIT

OLDFORK:MOVE	A,FORKH
	PCALL	NUMVAL
	CAIL	A,400001
	CAIL	A,400035
	 ERRE2	^D43,[SIXBIT /NOT A FORK HANDLE!/]
	MOVEM	A,FORKH
	RFSTS
	TLNN	A,777777
	 ERRL2	^D168,[SIXBIT /DEAD FORK IN XEQ!/]
	MOVEM	B,FORKPC#
TRYIT:	MOVEI	A,100			;PRIMARY INPUT
	CFIBF				;Flush buffer to be safe
	RFMOD
	MOVEM	B,OTTMOD#
	SKIPN	A,ACSADR
	 JRST	NOACS
	PCALL	NUMVAL
	MOVE	B,A
	MOVE	A,FORKH
	SFACS
NOACS:	MOVE	A,FORKH
	SKIPN	C,STAD
	 JRST	DOSFORK			; IF NULL STAD THEN START FORK
FOO	CAIN	C,TRUTH
	 TDZA	C,C			; IF STAD=T THEN START AT EVEC+0
	 SUBI	C,INUM0			; UNBOX NUMBER
	GEVEC
	ADD	B,C
	MOVEM	B,FORKPC
	HLRZ	AR4,B			; CHECK LH LENGTH VERSUS STAD
	CAIE	AR4,(JRST)
	 JRST	ITENEX
	CAIL	C,2
	 JRST	FAIL5			; 10/50 CAN ONLY ST/REE 0/1.
	JRST	DOSFORK

ITENEX:	CAIL	C,(AR4)
	 JRST	FAIL5
DOSFORK:HRRZ	B,FORKPC
	SFORK				; SFORK AT PC, RATHER THAN RFORK
IFG OPSYS,<SKIPN A,ARGSTR
	 JRST	NTAR>
IFL OPSYS,<SKIPN C,ARGSTR
	 JRST	DOWFORK
	CDRA	A,(C)
	JUMPE	A,NTAR>
	PCALL	PNAMUK
	HRRZ	C,SP
	HRLI	C,700
	MOVEI	A,100			;Primary output designator;
XL1:	MOVEI	AR4,127
XL2:	ILDB	B,C
	JUMPE	B,NTAR
	STI
	SOJG	AR4,XL2
	DIBE
	JRST	XL1

NTAR:	MOVE	A,FORKH
DOWFORK:WFORK

	MOVEI	A,100
	MOVE	B,OTTMOD
	SFMOD
	MOVE	A,FORKH
	SKIPN	B,KILL
	 JRST	FIX1A		; RETURN FORKH# FOR FUTURE RESUME.
	KFORK			; KFORK IF NON-NIL FLAG.
	JRST	FALSE


FAIL1:	PSAVE	FORKH
	PCALL	ERRSTR
	PCALL	NCONS
	PRET	B
	PCALL	XCONS
	MOVE	B,A
	MOVEI	A,INUM0
	JRST	.ERROR

FAIL6:	CARA	A,ARGSTR
	PSAVE	A
	JRST	FAIL1+1

FAIL2:	MOVE	A,SAVJFN
	RLJFN
	 JFCL
	PCALL	ERRSTR
	ERRE2	^D44,[SIXBIT /ERROR IN XEQ!/]

FAIL5:	MOVE	A,STAD
	ERRE2	^D45,[SIXBIT /BAD ENTRY VECTOR IN XEQ!/]
	>	;End of IFN JSYXEQ
SUBTTL 	BPS SWAPPING ROUTINES			--- PAGE 24

IFN RWB,<		;to end of page
INTERNAL RBLK, WBLK

RBLK:	PCALL	FILEPX		; (RBLK <FILE>)  no 2nd arg anymore.
	JUMPE	A,RBLK0		;  Not found.
	INPUT	[IOWD	1,LST
		 0]
	JRST	SYSINQ
RBLK0:	RELEASE	0,
	JRST	AIN.7


WBLK:	INIT	17		; (WBLK <file> <start-addr> <end-addr>)
	 SIXBIT	/DSK/
	 0
	 JRST	AOUT.4+1
	HRLZM	A,DEV
	MOVE	A,B		;IN CASE ADDRESSES OVER 64K.
	PCALL	NUMVAL
	EXCH	A,C
	PCALL	NUMVAL
	SUBI	C,1
	SUBM	C,A		;A_ -(A-(C-1)) == ARG1:ARG2 INCLUSIVE
	HRL	C,A
	MOVEM	C,LST
	MOVEI	T,DEV
	PCALL	IOSUB
	MOVEM	A,ENTR
	SETZM	ENTR+2		;CREATION DATE
	ENTER	ENTR
	 JRST	OUTERR+1
	OUTPUT	[IOWD	1,LST
		 0]
	OUTPUT	LST
	CLOSE
	STATZ	740000
	 JRST	TYO2X+2		;"OUTPUT ERROR".
	PRET
	>		;end of IFN RWB
SUBTTL 	CORE EXPANDING ROUTINES			--- PAGE 25





INTERNAL  TCORE


TCORE:	SUBI	A,INUM0		;== ^C, CORE N, START EXCEPT FOR N =<0
	JUMPL	A,TCORE0	;JUST RETURN CURRENT LISP-ALLOC SIZE
	JUMPE	A,TCORE0+1	;JUST RETURN CURRENT CORE SIZE
	CAILE	A,MAXCORE	;LIMIT .LT. 124K OR SO, ALLOWING FOR I/O BUFFS
	 JRST	TCORE3
	LSH	A,^D10
	SUBI	A,1
	CAMGE	A,JRELO
	 JRST	TCORE1		;Smaller than current Lisp area alloc.
	CAML	A,.JBREL
	 JRST	TCORE2		;LARGER THAN CURRENT CORE, SO EXPAND.
 IFE HCBPS,<
	SKIPN	VXCORE
	 JRST	TCORE4
	STRTIP	[SIXBIT /_*** CAN'T EXCISE_!/]
	JRST	TCORE0+1
	  >
TCORE4:	CAMG	A,JRELO
	 PCALL	TCORE5
TCORE2:	CALLI	A,CORE
	 JRST	TCORE3
	JRST	LISPGO		;GO ALLOCATE CORE

TCORE1:	STRTIP	[SIXBIT /_*** CAN'T CUT CORE INTO ALLOCATED SPACE_!/]
TCORE0:	SKIPA	A,JRELO		;-1 GIVES CURRENT LISP-ALLOC AREA
	HRRZ	A,.JBREL	; 0 GIVES CURRENT TOTAL CORE ASSIGNED
	ADDI	A,1777
	LSH	A,-^D10
	JRST	FIXI

TCORE5:	MOVE	B,JRELO
	CAME	B,CORUSE
FOO	SKIPN	%MSG
	 PRET
;	OUTSTR	[ASCIZ /
;*** EXCISED
;/]
	PRET
PAGE

; EXCORE( n )	permits arbitrary expansion of BPS above Lisp spaces,
;		by: 1)	flagging STRT allocator not to alloc extra core,
;		    2)	creating or extending a high BPS area of nK,
;		    3)  setting BPORG and BPEND up there appropriately,
;		    4)  doing an I/O reset, to get the buffers above BPS,
;			  permitting future LOADs, EDs, etc.
; EXCORE( 0 )	forces the BPORG and BPEND pntrs down to their last
;		  positions in low BPS, but doesn't clear the high...which
;		  is retained indefinitely or until an EXCISE.
; EXCORE(NIL)	permits ALLOC() or ST to allocate extra core as usual.
;		  Has also the effect of EXCORE(0).


IFN SZBPS,<			;Only defined when not maximal BPS.
EXCORE:
  IFE HCBPS,<			;Only when BPS in low core
	MOVEM	A,VXCORE#	;If NIL, flag for STRT allocation,
	JUMPE	A,CHKVBP
	HRREI	C,-INUM0(A)	;else
	JUMPL	C,EXCORT
	LSH	C,^D10		;  Convert nK to n*1024 words.
	JUMPE	C,CHKVBP	;  If arg=0, put BP pntrs back to low BPS.
FOO	MOVE	A,VBPEND
	PCALL	NUMVAL
	CAML	A,FSO		;Are the pntrs in low BPS still?
	 JRST	EXCOR2		;  No, extend from this BPEND.
	MOVEM	A,OBPEND#	;  Yes, save positions for a later CHKVBP.
FOO	MOVE	A,VBPORG
	PCALL	NUMVAL
	MOVEM	A,OBPORG#
	SKIPA	A,JRELO		;Start BPS.  [Could use CORUSE instead]
EXCOR2:	 SETZ	B,		;If 0, pntrs were already in high BPS.
	ADD	A,C		;Extend by amt of arg.
	IORI	A,777		;  End of page.
	CAIGE	A,MAXCORE*^D1024	;More than 124K requested,
	CALLI	A,CORE		;  or can't get it?
	 JRST	TCORE3		;    Say so.
	JUMPE	B,EXCOR3	;Got it -- set pntrs to it.
	MOVE	A,JRELO		;[or CORUSE]
	ADDI	A,1
	PCALL	FIX1A
FOO	MOVEM	A,VBPORG
EXCOR3:	MOVE	A,.JBREL
	PCALL	FIX1A
FOO	MOVEM	A,VBPEND
	JSR	IOBRST		;Set JOBSA and clear I/O pntrs.
	CALLI	RESET		;Set JOBFF.
	JSR	APRSET
	PCALL	TTYRET
EXCORT:	MOVE	A,VXCORE
	PRET
PAGE
CHKVBP:	
FOO	MOVE	A,VBPEND	;Ensure BP pntrs to low BPS.
	PCALL	NUMVAL
	CAMGE	A,FSO
	 JRST	EXCORT		;Already low, no change needed.
	MOVE	A,OBPEND
	PCALL	FIX1A
FOO	MOVEM	A,VBPEND
	MOVE	A,OBPORG
	PCALL	FIX1A
FOO	MOVEM	A,VBPORG
	JRST	EXCORT
	  >
  IFN HCBPS,<
	JUMPE	A,CPOPJ		;Do nothing if argument NIL.
	PCALL	NUMVAL
	JUMPLE	A,CPOPJ
	LSH	A,^D10
	MOVE	AR5,A
FOO	MOVE	A,VBPEND
	PCALL	NUMVAL
	ADD	AR5,A
	IORI	AR5,777
	HRLZ	A,AR5
	TLNN	AR5,-1
	CALLI	A,CORE
	 JRST	TCORE3
	MOVE	A,AR5
	PCALL	FIX1A
FOO	MOVEM	A,VBPEND
	PRET
	  >
		>		;End of IFN SZBPS
PAGE
FREEZE:	SKIPE	A		;If going to toplevel, then
	 PCALL	TUNBIND		; unbind to toplevel
	MOVEM	17,ACSAV+17	;This routine halts Lisp in a manner
	MOVEI	17,ACSAV	;  that can be later re-started.
	BLT	17,ACSAV+16
  IFL OPSYS,<
	MOVE	1,VBPORG
	PCALL	NUMVAL
	MOVEM	1,.JBHRL >
  IFN OPSYS,<
	MOVEI	1,400000
	MOVE	2,[2,,ENTFRZ]
	SEVEC		>	;Tell it where to start or continue.
	MOVEI	1,NEWST		;Unfortunately, need to do this 
	MOVEI	2,NEWREE	;  in order to thwart PA1050,
	HRRM	1,.JBSA		;  if ST or REE w/o clearing it.
	HRRM	2,.JBREN
  IFN OPSYS,< HALTF >
  IFE OPSYS,<EXIT 1,>
NEWST:	TDZA	NIL,NIL
NEWREE:	 SETO	NIL,
  IFN OPSYS,<
	MOVEI	1,400000	;Tell it the normal Lisp entries.
	MOVE	2,[2,,ENTVEC]
	SEVEC	>
   IFL OPSYS,<
	MOVE	1,.JBREL
	HRLI	1,676777
	CALLI	1,CORE
	 JRST	.+1 >
	MOVEI	1,LISPGO
	MOVEI	2,DEBUGO
	HRRM	1,.JBSA
	HRRM	2,.JBREN
	JSR	IOBRST		;Clear I/O bufs.
	JUMPN	NIL,[MOVE  NIL,ACSAV
		     SETZM RETFLG
		     JRST  START ] ;REE to get past INITFN.
	CALLI	RESET
	JSR	APRSET		;Reset 10/50 or Tenex interrupts.
	MOVSI	17,ACSAV
	BLT	17,17
	PCALL	TTYRET
	SKIPN	A,ACSAV+1	;Test arg of FREEZE...
	 PRET			;  NIL	   -- Return, no files open.
	MOVE	A,.JBREL	;  Non-NIL -- GOTO top-level INITFN.
	CAMN	A,JRELO		
	 JRST	LSPRET		;Unexpanded core. G.c. not necessary.
	JRST	LISPGO

IFN OPSYS,<
ENTVEC:	JRST	LISPGO
	JRST	DEBUGO

ENTFRZ:	JRST	NEWST
	JRST	NEWREE >
SUBTTL 	AUXILIARY ROUTINES			--- PAGE 26


IFN OPSYS,<

LSSAVE:	MOVEM	17,ACSAV+17	;This routine SSAVEs Lisp in a manner
	MOVEI	17,ACSAV	;  that can be later run, no files open.
	BLT	17,ACSAV+16
	MOVE	17,ACSAV+17	;Restore it.
	MOVEI	1,400000
	MOVE	2,[2,,ENTFRZ]
	SEVEC
	MOVSI	1,(1B0+1B17)
	HRROI	2,LSSFIL
	GTJFN
	 JRST	LSSER1
	HRLI	1,400000
	MOVEI	2,LSSTBL
	SETZ	3,
	SSAVE
	HRRZS	1
	RLJFN
	 JRST	LSSER1
	MOVEI	1,400000
	MOVE	2,[2,,ENTVEC]
	SEVEC
	JRST	TRUE		;Distinguish from a NEWST's NIL!

LSSER1:	MOVEI	1,400000
	MOVE	2,[2,,ENTVEC]
	SEVEC
	ERRL2	^D166,[SIXBIT /COULDN'T SSAVE/]

LSSFIL:
IFL OPSYS,ASCIZ	/LSSAVE.EXE/
IFG OPSYS,ASCIZ	/LSSAVE.SAV/
LSSTBL:	-700,,520B26+0		;Pages 0-677 below PA1050.
	0
	  >
PAGE
IFN SYDEV,<
SETSYS:
IFG OPSYS,<SUBI	A,INUM0		;CHANGE SYS: <DIR> NUMBER.
	CAIGE	A,0		;  Permit 0 ... user's dir.
	 SKIPA	A,SYSNUM#
	MOVEM	A,SYSNUM
	JRST	FIXI>
 IFLE OPSYS,<MOVE T,A
	PCALL	ATOM
	JUMPE	A,GVDV
	MOVE	A,T
	PCALL	SIXMAK
	TRC	A,":"-40
	TRNE	A,77
	JRST	GVDV
	HLLZM	A,SYSNUM#
	MOVE	A,T
	PRET

GVDV:	SETZB	A,B
	SKIPA	AR4,[POINT 6,SYSNUM]
	ADDI	A,40(B)
	LSH	A,7
	ILDB	B,AR4
	JUMPN	B,.-3
	ADDI	A,":"
	LSH	A,1
	SKIPA	AR4,[1]
	LSH	A,7
	TLNN	A,774000
	JRST	.-2
	MOVEM	A,1(SP)
	MOVEI	C,1(SP)
	JRST	MSTR1	>
	>
SUBTTL 	REALLOC CODE				--- PAGE 27

STRT:	MOVE	P,C2
	SKIPE	SP,SPSAV
	 PCALL	TUNBIND
	MOVE	A,.JBREL	;New top of core -- becomes JRELO below.
	HRLM	A,.JBSA
	SUB	A,JRELO#	;length of extra core
	JUMPE	A,RREL4		;no expansion
	SKIPG	A
	 HALT			;smaller core -- bitch.
IFN AED,<MOVEI	B,EDP2
	HRRM	B,ED>
IFE HCBPS,<SKIPE VXCORE		;If XCORE(Nil), go ahead and allocate,
	 JRST	RREL4	>	;  else retain as is...usually expanded BPS.
	MOVE	A,.JBREL
	TRO	A,1777
	CALLI	A,CORE
	 SKIPA	A,.JBREL
	MOVE	A,.JBREL
	HRLM	A,.JBSA
	SUB	A,JRELO
	PCALL	TCORE5
IFN ALOD,SETZM	LDFLG		;initial loader symbol table flag
	MOVE	F,EFWSO#
	SUB	F,FWSO#		;old length of fws
	HRRZS	B,A
ACHLOC:	ASH	A,-2+X		;1/4 of new core to fws		* User-patchable *
	ADD	A,F		;new length of fws
	MOVE	C,B
STKLOC:	ASH	C,-6		;1/64 of new core to each pdl
	MOVE	AR4,C
	HRL	AR4,C
	HLRZ	AR5,SC2		;-old length of spec pdl
	ADD	AR5,.JBREL	;new bottom of spec pdl
	HLL	AR5,SC2		;old length of spec pdl
	SUB	AR5,AR4		;new pointer for spec pdl
	MOVEM	AR5,SC2
 IFN EPDL,<
	HLRZ	EP,EC2		;-old length of exp pdl
	ADD	AR5,EP		;new bottom of exp pdl
	HLL	AR5,EC2		;old length of exp pdl
	SUB	AR5,AR4		;new pointer for exp pdl
	MOVEM	AR5,EC2	>
	MOVNS	C2		;old reg pdl pointer
	HLRZ	AR4,C2		;old length of reg pdl
	ADD	C,AR4		;new length of reg pdl
	HRRZ	B,AR5		;new bottom of reg pdl
	SUB	B,FSO#
	MOVEI	T,44		;1/36 space for fws bit tables
	IDIVM	A,T		;new length of fws bit tables
	AOS	T		
	SUB	B,T		;B:=SPL-FSO-(FWS/36+1)-FWS-PL, then
	SUB	B,A		;B:=B-(B/33+1)+FSO
	SUB	B,C
	MOVEI	TT,41		;1/33 space for fs bit table
	IDIVM	B,TT		;new length of fs bit table
	SUBI	B,1(TT)		;new length of fs
	ADD	B,FSO		;new bottom of fs
	HRRM	B,GCP1
	MOVN	SP,B		;- new bottom of fws
	HRRM	SP,GCMFWS
	HRLZM	A,C1GCS
	MOVNS	C1GCS		;- new length of fws
	HRRM	B,C1GCS
	ADDI	B,-1(A)		;new top of fws
	AOS	B
	MOVE	SP,FSO
	LSH	SP,-5
	SUBM	B,SP
	HRRM	SP,GCBTP2	;magic number for bit table references
	HRRM	SP,GCBTP1
	HRLM	B,C3GC		;bottom of bit tables --- for bit table zeroing
	HRRM	B,GCP2
	HRRM	B,GCP
	MOVNI	SP,-1(TT)
	HRLM	SP,C3GCS
	HRRM	B,C3GCS		;iowd for FS bit table sweep
	AOS	B
	MOVE	SP,FSO
	ANDI	SP,37
	HRRM	SP,GCBTL2	;magic number to position bit table word
	SUBI	SP,^D32
	HRRM	SP,GCBTL1
	HRRM	B,C3GC		;bottom of bit table
	ADDI	B,-1(TT)
	HRRM	B,C2GCS		;bottom of fws bit table
	AOS	B
	HRRM	B,C2GC
	ADDI	B,-1(T)
	HRRM	B,GCP5		;top of bit tables
	AOS	B		;bottom of reg pdl
	HRRZ	A,RHX2		;oblist pointer
	MOVEM	A,(B)
	HRRM	B,GCP3		;room for acs
	AOS	B
	HRRM	B,C2		;reg pdl bottom
	MOVNI	A,-10(C)
	HRLM	A,C2		;reg pdl size
	HRRZ	A,.JBREL
	HRRZM	A,JRELO		;new top of core
	MOVE	A,GCP1
	HRRM	A,.+4		;To...
	MOVE	A,FWSO
	HRRM	A,.+1		;From...
	MOVE	A,.(F)		;old bottom of fws	*
	MOVEM	A,.(F)		;new bottom of fws	*
	SOJGE	F,.-2		;f has length (old) of fws
	HRRZ	AR4,GCP1
	SUB	AR4,FWSO	;displacement for fws
	MOVE	AR5,FSO		;bottom of fs
RREL1:	CARA	A,(AR5)		;Adjust pntrs in new FS to new FWS...
	CAMG	A,EFWSO
	CAMGE	A,FWSO
	JRST	RREL2
	ADD	A,AR4
	RPLCA	A,(AR5)		;fix car pointer
RREL2:	CDRA	A,(AR5)
	CAMG	A,EFWSO
	CAMGE	A,FWSO
	JRST	RREL3
	ADD	A,AR4
	RPLCD	A,(AR5)		;fix cdr pointer
RREL3:	CAMGE	AR5,FWSO
	AOJA	AR5,RREL1
	MOVE	A,GCP1		;bottom of fws
	HRRZM	A,FWSO
	MOVE	A,C3GC		;bottom of bit table + 1
	HRRZM	A,EFWSO
RREL4:
FOO	SETZB	FF,DDTIFG	;Flag for AGC.
	JSR	IOBRST
	JRST	START

;--------------------------------------------------------------------

RLOCA:	MOVE	B,AR4		;= FS+BPS LENGTHS.
	HRLI	AR4,BFWS
	HRRI	AR4,FS(B)
	MOVEI	AR5,EFWS-BFWS(AR4)
	BLT	AR4,(AR5)
	MOVEI	AR4,FS-BFWS(B)
	MOVEI	AR5,BFWS-1

REL1:	CARA	A,(AR5)
	CAILE	A,EFWS
	JRST	REL2
	CAIGE	A,BFWS
	JSP	R,REL4
	ADD	A,AR4
REL2:	RPLCA	A,(F)
	CDRA	A,(AR5)
	CAILE	A,EFWS
	JRST	REL3
	CAIGE	A,BFWS
	JSP	R,REL4
	ADD	A,AR4
REL3:	RPLCD	A,(F)
	SOS	F
	CAILE	AR5,FS
	SOJA	AR5,REL1
	JRST	RREL4		;Now do the IOBRST and START.

REL4:	CAIL	A,FS
	ADD	A,FF
	JRST	1(R)

PAGE
REHASH:				;ONCE ONLY, per HASHFG.
FOO	MOVEI	A,BFWS
	PSAVE	A
	HRRM	A,RHX2
	HRRM	A,RHX5
RH4:	MOVSI	B,X				;*
FOO	MOVEI	A,BFWS+1(B)
FOO	MOVEM	A,BFWS(B)
	AOBJN	B,.-2
FOO	SETZM	BFWS(B)
	MOVSI	AR5,-BCKETS
RH1:
FOO	HLRZ	C,OBTBL(AR5)
RH3:	JUMPE	C,RH2
	CARA	A,(C)
	PSAVE	C
	PSAVE	AR5
	PCALL	INTERN
	PREST	AR5
	PREST	C
	CDRA	C,(C)
	JRST	RH3
RH2:	AOBJN	AR5,RH1
	SETZM	HASHFG
	PREST	A
	HRRM	A,@GCP3
FOO	MOVEM	A,OBLIST
	JRST	START
SUBTTL 	LISP ATOMS AND OBLIST			--- PAGE 28

RVAL:	0
HVAL:	0
VAR
LIT
PAGE
FS:

DEFINE MAKBUC (A,%B)
<DEFINE OBT'A <%B=.>
IFN <BCKETS-1-A>,<XWD %B,.+1>
IFE <BCKETS-1-A>,<XWD %B,NIL>
IF1 <%B=0>>

DEFINE ADDOB (A,C,%B)
<OBT'A
DEFINE OBT'A<%B=.>
IF1 <%B=0>
XWD C,%B>

DEFINE PUTOB (A,B)
<ZZ==<ASCII /A/>_<-1>
ZZ==-ZZ/BCKETS*BCKETS+ZZ
ADDOB \ZZ,B>

DEFINE PSTRCT (A)
<ZZ==[ASCII /A/]
LENGTH ZY,A
REPEAT <ZY-1>/5,<XWD ZZ,.+1
ZZ==ZZ+1>
XWD ZZ,0>

DEFINE MKAT (A,B,C,D)
<XLIST
IRP A< PUTOB A,.+1
D	XWD	ID,.+1
XX==<B-EXPR>*<B-FEXPR>
IFN XX,<XWD	.+1,.+2
	XWD	B,C'A>
IFE XX,<XWD	.+1,.+4
	XWD	FUNCELL,.+1
	XWD	B,.+1
	XWD	CODE,C'A>
	XWD	.+1,NIL
	XWD	PNAME,.+1
	PSTRCT	A>
LIST>
PAGE
DEFINE MKAT1 (A,B,C,D)
<XLIST
IRP C <PUTOB C,.+1
	XWD	ID,.+1
XX==<B-EXPR>*<B-FEXPR>
IFN XX,<XWD	.+1,.+2
	XWD	B,D'A>
IFE XX,<XWD	.+1,.+4
	XWD	FUNCELL,.+1
	XWD	B,.+1
	XWD	CODE,D'A>
	XWD	.+1,NIL
	XWD	PNAME,.+1
	PSTRCT	C>
LIST>

DEFINE LENGTH (A,B)
<A==0
IRPC B,<A==A+1>>

DEFINE ML1 (A)<XLIST
IRP A,<XLIST
INTERNAL A
V'A=	INUM0+A
	MKAT	A,SYM,V>
LIST>	;These SYMs are for direct access from LAP code (e.g. LISP.TNX)

DEFINE ML (A)<
XLIST
IRP A,<PUTOB A,.+1
A:	XWD	ID,.+1
	XWD	.+1,NIL
	XWD	PNAME,.+1
	PSTRCT	A>
LIST>

OBTBL:
OBLIST:	ZZ==0		;Base of array or linear-list of hash buckets.
XLIST	;REPEAT BCKETS,<MAKBUC \ZZ
REPEAT BCKETS,<MAKBUC \ZZ
ZZ==ZZ+1>
LIST	; ZZ==ZZ+1>

PAGE
ML <LAMBDA,EXPR,FEXPR,SYM,FUNCELL,VALUE,PNAME,TRACE>
ML <LABEL,MACRO,INPUT,OUTPUT,INBIN,OUTBIN>
ML <SUBR,FSUBR>

MKAT <RPLACA,RPLACD,MINUS,TERPRI,READ,CAR,CDR,CAAR>,EXPR
MKAT <CADR,CDAR,CDDR,CAAAR,CAADR,CADAR,CADDR,CDAAR,CDADR,CDDAR,CDDDR>,EXPR
MKAT <CAAAAR,CAAADR,CAADAR,CAADDR,CADAAR,CADADR,CADDAR,CADDDR,CDAAAR>,EXPR
MKAT <CDAADR,CDADAR,CDADDR,CDDAAR,CDDADR,CDDDAR,CDDDDR,CONS>,EXPR
MKAT <PROG2,ATOM,EQ,PRIN1,PRINT,RETURN,EXPLODE,ATSOC,PATOM>,EXPR
MKAT <POSN,LINELENGTH,NUMBERP,EQUAL,SUBST,GET,INTERN,MEMBER>,EXPR
MKAT <COMPRESS,READCH,NOT,NULL,GENSYM,ZEROP,DIVIDE,GCD>,EXPR
IFN AED,<MKAT <ED,GRINDEF>,EXPR>
MKAT <TIME,FIX,SET,LENGTH,ADD1,SUB1,LAST,WARNING>,EXPR
MKAT <GCTIME,REVERSE,SPEAK,MAPLIST,MEMQ>,EXPR
MKAT <PUT,PRIN2,ERR,MAPCAR,EXAMINE,DEPOSIT,LSH,MAPCAN,MAPCON>,EXPR
MKAT <NCONS,XCONS,REMPROP,MINUSP,MAP,MAPC>,EXPR
MKAT <WRS,RDS,OPEN,CLOSE,EXCISE,REMAINDER,ABS,BKTRA>,EXPR
MKAT <PGLINE>,EXPR
MKAT <%FSLID,%FPAGE,%NEXTTYI,SETPCHAR,DLVECT>,EXPR
IFN SOSSW,MKAT %SOSSWAP,EXPR
IFN RWB,<MKAT <RBLK,WBLK>,EXPR>
MKAT <FILEP,FREEZE>,EXPR
IFN SZBPS,MKAT <EXCORE>,EXPR
MKAT <CORE>,EXPR,T
MKAT <BINI,BINO,TYID,TYOD>,EXPR

MKAT1 VINC,VALUE,INC*
VINC:NIL
MKAT1 VOUTC,VALUE,OUTC*
VOUTC:NIL
IFN OPSYS,MKAT LSSAVE,EXPR
IFN JSYXEQ,<MKAT <%XEQ,GETAB$,ERRSTR>,EXPR
MKAT1 VJSYSAR4,VALUE,JSYSAR4
VJSYSAR4: INUM0
ML BUF
MKAT JSYS,EXPR,%>
IFN SYDEV,<MKAT SETSYS,EXPR>

MKAT EXPLODEC,EXPR,%
MKAT TYO,EXPR,I
MKAT TYI,EXPR,I
MKAT EVAL,EXPR,,CEVAL:
MKAT <LIST,COND,PROG,SETQ>,FEXPR
MKAT1 LIST,EXPR,EVLIS
MKAT <OR,AND,GO,PROGN>,FEXPR
IFN ASARY,<MKAT <ARRAY,STORE>,FEXPR
ML1 NSTR
 IFN ALOD,<MKAT EXARRAY,FEXPR> >
MKAT1 QUOTE,FEXPR,FUNCTION
IFN FNRG,<
ML FUNARG
MKAT1 FUNCT,FEXPR,*FUNCTION
MKAT <%EVAL,%APPLY>,EXPR   >
MKAT <APPEND,NCONC,APPLY,REMOB,ERRORSET,FIXP,FLOATP,INUMP,BIGP>,EXPR
MKAT <PUTD,GETD,REMD,PRINC,FLAG,FLAGP,REMFLAG,MKCODE,FLOAT,DIGIT>,EXPR
MKAT <BOOLE,LITER,IDP,PAIRP,CONSTANTP,STRINGP,VECTORP,CODEP>,EXPR
MKAT <MKVECT,UPBV,GETV,PUTV>,EXPR
MKAT INTERNP,EXPR,.
MKAT ASCII,EXPR,A
MKAT QUOTE,FEXPR,,CQUOTE:
MKAT1 FIX1A,EXPR,*BOX
ML1 <EXARG,ATMTYP,NATMTYP,INTER0,FWCONS,ACHLOC,CHRTAB>
MKAT INUM0,SYM,S
INTERN INUM0
SINUM0:	XWD	FIXNU,VINUM0
IFN OPSYS,ML1 <READP1,PNAMUK,%ACSAV,LMKSTR>
IFN OPSYS*SOSSW,ML1 %SWAP

	PUTOB	T,.+1
TRUTH:	XWD	ID,.+1
	XWD	.+1,.+2
	XWD	VALUE,VTRUTH
	XWD	.+1,NIL
	XWD	PNAME,.+1
	PSTRCT	T
VTRUTH:	TRUTH

	PUTOB	NIL,0
CNIL2:	XWD	.+1,.+2
	XWD	VALUE,VNIL
	XWD	.+1,NIL
	XWD	PNAME,.+1
	PSTRCT	NIL
VNIL:	NIL

IFE STL,<
MKAT <SASSOC,SETARG,GETL,ARG,READLIST,FLATSIZE>,EXPR
MKAT <CSYM,DEFPROP>,FEXPR
MKAT1 EXPN1,EXPR,*EXPAND1
MKAT1 EXPAND,EXPR,*EXPAND
MKAT1 LCALL,SYM,*LCALL,INUM0+%
MKAT1 UDT,SYM,*UDT,INUM0+%	>
MKAT1 AMAKE,SYM,*AMAKE,INUM0+%
MKAT1 %NOPOINT,VALUE,*NOPOINT
%NOPOINT: NIL
MKAT1 BACTRF,VALUE,*BAKGAG
BACTRF:NIL
MKAT1 ERRSW,VALUE,*ERRMSG
ERRSW:TRUTH
MKAT1 V$EOF$,VALUE,$EOF$
V$EOF$: $EOF$
$EOF$:	XWD	ID,.+1
	XWD	.+1,NIL
	XWD	PNAME,.+1
	PSTRCT	$EOF$

MKAT1 GCGAGV,VALUE,*GCGAG
GCGAGV:NIL
MKAT1 VFECHO,VALUE,*ECHO
VFECHO:NIL
MKAT1 VRAISE,VALUE,*RAISE
VRAISE:NIL
MKAT1 DDTIFG,VALUE,*DDTIN
DDTIFG:TRUTH
MKAT1 NOUUOF,VALUE,*NOUUO
NOUUOF:NIL
MKAT1 %MSG,VALUE,*MSG
%MSG: TRUTH
MKAT1 GC,EXPR,RECLAIM
MKAT1 INITF,VALUE,INITFN*
INITF:NIL
MKAT1 %SYSTM,VALUE,SYSTEM*
%SYSTM: OPSYS+INUM0
MKAT <SCANINIT,SCANSET,SCAN,UNREADCH>,EXPR
MKAT <LETTER,DELIMITER,IGNORE,RDSLSH>,EXPR
MKAT1 SCNV,VALUE,SCNVAL
SCNV: NIL
MKAT SKIPTO,EXPR
MKAT <LPOSN,PAGELENGTH,EJECT,NUMVAL>,EXPR
MKAT ERROR,EXPR,.

MKAT1 VERMSG,VALUE,EMSG*
VERMSG:	NIL
IFN OFLD!NFLD,<
MKAT1 VPURIFY,VALUE,*PURIFY
VPURIFY: NIL
MKAT1 VPREDEF,VALUE,*PREDEF
VPREDEF: NIL
MKAT1 VF.LIST,VALUE,F.LIST
VF.LIST: NIL
MKAT1 VP.URCLOBRL,VALUE,P.URCLOBRL
VP.URCLOBRL: NIL	>
IFN OFLD,<
MKAT <FASLOD,LDFERR>,EXPR
MKAT1 VFARRY,VALUE,FARRY
VFARRY: NIL	>
IFN NFLD,MKAT FASLOAD,EXPR

;UNBOUND is a non-interned identifier
UNBOUND:XWD	ID,.+1
	XWD	.+1,NIL
	XWD	PNAME,.+1
	PSTRCT	UNBOUND
IFN MOD,<
MKAT <SETMOD,CMOD,CPLUS,CDIF,CTIMES,CRECIP>,EXPR
MKAT1 VBIGP,VALUE,MOD*
VBIGP: NIL	>

MKAT1 LAMBIND,EXPR,*LAMBIND*
MKAT1 PROGBIND,EXPR,*PROGBIND*
MKAT1 SPECSTR,EXPR,*SPECRSTR*
MKAT1 PLUS,EXPR,PLUS2,.
MKAT1 DIF,EXPR,DIFFERENCE,.
MKAT1 QUO,EXPR,QUOTIENT,.
MKAT1 TIMES,EXPR,TIMES2,.
MKAT1 RSTSW,VALUE,*RSET
RSTSW:NIL
MKAT1 GREAT,EXPR,GREATERP,.
MKAT1 LESS,EXPR,LESSP,.
IFN ALOD,<MKAT LOAD,EXPR
MKAT1 PUTSYM,EXPR,*PUTSYM
MKAT1 GETSYM,EXPR,*GETSYM>

MKAT <OBLIST,BASE,IBASE,BPEND,BPORG>,VALUE,V

VOBLIST: OBLIST
VBASE:	8+INUM0
VIBASE:	8+INUM0
VBPORG:	XWD	0,.+1
	XWD	FIXNU,VBPORX
VBPEND:	XWD	0,.+1
	XWD	FIXNU,VBPENX

	PUTOB	?,.+1
QST:	XWD	ID,.+1
	XWD	.+1,NIL
	XWD	PNAME,.+1
	PSTRCT	?



BFWS:			;All the FWS LITerals from above atoms, etc.
XLIST			;  includes VBPORX,VBPENX datums.
LIT
VINUM0:	INUM0
VBPORX:	400000
VBPENX:	700000-1000-2	;676776 --> 1 for SYSINP and 1000 for slop.
LIST
EFWS:	0
SUBTTL 	LISP STORAGE ALLOCATOR (ONCE ONLY)	--- PAGE 29


ALLOC:!	CALLI	RESET		;Later IOBRST & another RESET.
	MOVEI	P,ALLPDL-1
IFN OPSYS, <			;LISP.EXE SIZE LT DESIRED STARTING SIZE.
	MOVEI	A,INITCORE
	PCALL	ALCORH	>
IFL OPSYS,<GETPPN A,
	HLRM	A,SYSNU>
IFN SYDEV, <
IFG OPSYS, <
	MOVEI	1,1		;MATCH EXACTLY
	HRROI	2,[ASCIZ /REDUCE/]
	STDIR
	 JFCL
	 GJINF			;IN DESPERATION, USE HIS LOGIN DIR #.
	HRRZM	1,SYSNUM >
IFLE OPSYS,<
	MOVEI	A,(SIXBIT /SYS/)
	HRLZM	A,SYSNUM	>
	   >			;End of IFN SYDEV
	OUTSTR	[ASCIZ /
Allocate? /]
	INCHRW	C
	CAIE	C,"n"
	CAIGE	C,"O"
	 JRST	ALLC00
IFN OPSYS,<
	OUTSTR	[ASCIZ /
Core (K): /]
	PCALL	ALLNUM
	JUMPLE	A,ALLTNX
	CAIG	A,MAXCORE	;Asking for too much core ?
	 JRST	.+3		;No
	OUTSTR	[ASCIZ /
Will give you maximum allowed/]
	MOVEI	A,MAXCORE
	LSH	A,^D10
	SUBI	A,1
	PCALL	ALCORE
ALLTNX:! MOVEI	A,^D8
	HRRM	A,ALLRDX	;Remaining inputs are octal.
	   >
IFN SYDEV, <
IFG OPSYS, <
	OUTSTR	[ASCIZ /
SYS: dir# /]
	PCALL	ALLNUM
	SKIPN	A
	 GJINF			;If user said "0", use his dir.
	SKIPL	A
	 HRRM	A,SYSNUM	>
 IFLE OPSYS,<
	OUTSTR	[ASCIZ /
SYS: /]
	SETZ	A,
SYLO:!	INCHRW	C
	CAILE	C,"z"
	 JRST	SYLE
	CAIL	C,"a"
	 TRZ	C,40		;Convert lower case to upper
	CAIL	C,"A"
	CAILE	C,"Z"
	JRST	SYLE
	LSH	A,6
	ADDI	A,-40(C)
	JRST	SYLO

	INCHRW	C
SYLE:!	CAIN	C,RUBOUT
	JRST	[OUTSTR [ASCIZ /XXX /]
		JRST SYLO-1]
	CAILE	C," "
	JRST	SYLE-1
	CAIN	C,15
	INCHRW	C		;<lf> assumed.
	JUMPE	A,.+2
	HRLZM	A,SYSNUM	>
	   >			;End of IFN SYDEV
	OUTSTR	[ASCIZ /
FWDS= /]
	PCALL	ALLNUM
	JUMPL	A,.+2
	HRRM	A,ALLC02
IFN SZBPS,<
	OUTSTR	[ASCIZ /
BPS.= /]
	PCALL	ALLNUM
	JUMPL	A,.+5		;USE DEFAULT ?
	CAIGE	A,MINFBPS
	 MOVEI	A,MINFBPS
	ADDI	A,BOTBPS
	HRRZM	A,SBPS	>
	OUTSTR	[ASCIZ /
SPDL= /]
	PCALL	ALLNUM
	JUMPL	A,.+4
	HRRM	A,ALLC20
	MOVNS	A
	HRRM	A,ALLC21
 IFN EPDL,<
	OUTSTR	[ASCIZ /
EPDL= /]
	PCALL	ALLNUM
	JUMPL	A,.+4
	HRRM	A,ALLC40
	MOVNS	A
	HRRM	A,ALLC41 >
	OUTSTR	[ASCIZ /
RPDL= /]
	PCALL	ALLNUM
	JUMPL	A,.+2
	HRRM	A,ALLC30
	OUTSTR	[ASCIZ /
HASH= /]
	PCALL	ALLNUM
	CAIG	A,BCKETS
	 JRST	ALLC00
	HRRM	A,INT1
	MOVNS	A
	HRRM	A,RH4
	SETOM	HASHFG		;ONCE ONLY.

ALLC00:!
	MOVE	A,.JBREL
	HRRZM	A,JRELO
	HRLM	A,.JBSA
	MOVEI	A,DEBUGO
	HRRM	A,.JBREN
	MOVEI	A,LISPGO
	HRRM	A,.JBSA
  IFN OPSYS,<
	MOVEI	1,400000
	MOVE	2,[2,,ENTVEC]
	SEVEC
	  >
	OUTSTR	[ASCIZ /
/]
  IFE HCBPS,<
	MOVEI	A,FS
	PCALL	FIX1A
	MOVEM	A,VBPORG
	MOVEI	A,FS
	ADD	A,SBPS
	HRRZM	A,FSO		;SET ONCE AND FOR EVER!!!
	SOS	A
	PCALL	FIX1A
	MOVEM	A,VBPEND
	    >
  IFN HCBPS,<
	MOVEI	A,FS
	MOVEM	A,FSO
IFN OPSYS,MOVEI	A,400000	;First loc of high-segment.
IFE OPSYS,<
	HRRZ	B,.JBREL	;highest address in low core
	TRNN	B,400000	;is low core higher than 128k
	 MOVEI	B,377777	;no, assume high core start at 400000
	MOVE	A,[XWD -2,.GTUPM]	;get high core orig. from monitor
	GETTAB	A,		;.GTUPM indexed by current high core number
	 HRLI	A,1(B)		;table or call not present, use assumed value
	LSH	A,-^D18		;convert to address of high segment
	ANDI	A,777000	;clear any low bits
	ADDI	A,.JBHDA>	;Add space for vestigial job data area
	MOVEM	A,VBPORX
IFE SZBPS,MOVEI	A,700000-1000-2	;PA1050 - 1 page.
IFN SZBPS,ADD	A,SBPS
	MOVEM	A,VBPENX
	MOVSS	A
	PCALL	ALCORH
	SETZ	A,
	CALLI	A,SETUWP
	 HALT
	    >
	MOVE	A,JRELO
ALLC20:! SUBI	A,1000+X
ALLC21:! HRLI	A,-1000+X
	MOVEM	A,SC2
 IFN EPDL,<
ALLC40:! SUBI	A,100+X
ALLC41:! HRLI	A,-100+X
	MOVEM	A,EC2	>
	SUB	A,FSO
	HRRZS	B,A
	ASH	A,-4
ALLC02:! ADDI	A,400+X
	MOVE	C,B
	ASH	C,-6
ALLC30:! ADDI	C,1000+X
			;Stg order= prgm bps fs fws bt btf pdl epdl sp 
	MOVEI	T,44
	IDIVM	A,T
	AOS	T		;size of btf
	SUB	B,T
	SUB	B,A
	SUB	B,C		;remaining storage
	MOVEI	TT,^D32+1
	IDIVM	B,TT		;bt size -1
	SUBI	B,1(TT)		;free storage size
  IFE HCBPS,<ADD B,SBPS>
	HRRZ	AR4,B
	ADDI	B,FS
	HRRZM	B,FWSO
	HRRM	B,GCP1		;b hac top of fs
	MOVN	SP,B
	HRRM	SP,GCMFWS
	HRLZM	A,C1GCS		;length of fws
	MOVNS	C1GCS
	HRRM	B,C1GCS
	ADDI	B,-1(A)		;bottom of bt-1
	AOS	B
	MOVE	SP,FSO
	LSH	SP,-5
	SUBM	B,SP
	HRRM	SP,GCBTP2
	HRRM	SP,GCBTP1
	HRLM	B,C3GC
	HRRM	B,GCP2
	HRRM	B,GCP
	HRRZM	B,EFWSO
	MOVNI	SP,-1(TT)
	HRLM	SP,C3GCS
	HRRM	B,C3GCS
	AOS	B
	MOVE	SP,FSO
	ANDI	SP,37
	HRRM	SP,GCBTL2
	SUBI	SP,^D32
	HRRM	SP,GCBTL1
	HRRM	B,C3GC
	ADDI	B,-1(TT)
	HRRM	B,C2GCS
	AOS	B
	HRRM	B,C2GC
	ADDI	B,-1(T)
	HRRM	B,GCP5
	AOS	B
	MOVEI	A,OBTBL
  IFE HCBPS,<ADD A,SBPS>
	MOVEM	A,(B)
	HRRM	B,GCP3
	AOS	B
	HRRM	B,C2
	MOVNI	A,-10(C)
	HRLM	A,C2
  IFE HCBPS,<MOVE FF,SBPS>
  IFN HCBPS,<SETZ FF,    >
	MOVEI	F,BFWS-1(FF)
	JUMPE	FF,RLOCA
	MOVEI	C,FOOLST
REL5:!	MOVE	B,(C)		;Relocate all FS refs w/i system code,
	CDRA	A,(B)		;  by length of alloc'd BPS, iff HCBPS=0.
	ADD	A,FF
	RPLCD	A,(B)
	HLR	B,B
	CDRA	A,(B)
	ADD	A,FF
	RPLCD	A,(B)
	CAIGE	C,EFOLST-1
	 AOJA	C,REL5
	MOVEI	A,TRUTH
	ADD	A,FF
	HRLM	A,IDCHTAB+"T"-100
	JRST	RLOCA		;Uses values in AR4,F,FF.


PAGE

ALLNUM:! MOVSI	A,400000	;high bit on for no-digits-seen.
	INCHRW	C
	CAIN	C,15
	 INCHRW	C		;<lf> assumed.
	CAIN	C,RUBOUT
	 JRST	[OUTSTR [ASCIZ /XXX /]
		JRST ALLNUM]
	CAIL	C,"0"
	CAILE	C,"9"
	 PRET
	TLZ	A,400000	;turn off hi bit on digit
ALLRDX:!
IFN OPSYS,IMULI	A,^D10+X	;first a decimal number
IFE OPSYS,IMULI	A,^D8		;only octal
	ADDI	A,-"0"(C)
	JRST	ALLNUM+1

ALCORE:! CAMG	A,.JBREL
	 PRET			;Already bigger.
ALCORH:! CALLI	A,CORE
	 HALT
	PRET

ALLPDL:! BLOCK	10
IFN SZBPS,<SBPS:! INITBPS+BOTBPS>

PAGE
I=0
DEFINE GARP (A,B)
<XWD FOO'A,FOO'B>

FOO	0
FOOLST:!
XLIST
REPEAT <FOOCNT/2>,<
GARP (\I,\<I+1>)
I=I+2>
LIST

EFOLST:!

DEFINE MKENT (A)<
INTERNAL A>

	;These are for BIGNUMs (in ARITH)...

MKENT <NUMV2,FLOOV,FS>
MKENT <LAST,FIX1A,NUMVAL,REVERSE,LENGTH,XCONS,CONS,CTY,MINUSP>
MKENT <NUM1,NUM3,FWCONS,FALSE,TRUE,NCONS,IDCONS>

	;These are for GFPAK 

MKENT <.PLUS,REMAINDER,.COPY,.Q1,MAKBIG,POPAJ>

	;These are for SCAN...

MKENT <CHRTAB,RATOM,OLDCH,NOINFG,TYI>

	;Most of the rest are for ALVINE...

MKENT <READ,READP1,MAKNUM,PRIN1,PRINT,EXPLODE,EQUAL,SUBST>
MKENT <LNCT,PAGL,CHCT,LINL,POSN,TYOD,TYID>
MKENT <GET,INTERN,REMOB,COMPRESS,GENSYM,FIX,LENGTH,PATOM>
MKENT <MAPLIST,GC,PUT,FIXP,FLOATP,ATMTYP,NATMTYP,IPUTD,IMKCODE>
MKENT <ERR,MAPCAR,REMPROP,LIST,SETQ,ERRORSET,%APPLY>
MKENT <SPECSTR,LAMBIND,PROGBIND,INTER0,ATOM,READCH,SET,PRIN2>
MKENT <FP7A1,TERPRI,LSPRET,BKTRC>
MKENT <TYO,ITYO,EVAL,APPLY,%EVAL,INPUT,OUTPUT>
IFE STL,MKENT <READLIST,GETL,SASSOC,SAS1,FLATSIZE>
IFN AED,MKENT PSAV1

	;SOME MORE FOR FRICK'S "SHEEP" SYSTEM...

IFN ASARY,MKENT <ARRAY,ARRAYS,ARREND>
MKENT <GCMKL,PRINT1,EJECT,OPEN,RDS,WRS,CLOSE,PRINC,GETD,PUTD,DCONSA>
MKENT <PCHAR,FIXOV,ZERODIV,ILLNUM,STKLOC,ATSOC,EXARG,MKVECT>

SUPPRESS FOOCNT,I

	END	ALLOC