;;;   -*-MIDAS-*-
;;;   **************************************************************
;;;   ***** MACLISP ****** UTAPE, LAP, AND AGGLOMERATED SUBRS ******
;;;   **************************************************************
;;;   ** (C) COPYRIGHT 1979 MASSACHUSETTS INSTITUTE OF TECHNOLOGY **
;;;   ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) *******
;;;   **************************************************************



	PGBOT [UIO]



SUBTTL	OLD I/O FUNCTIONS IN TERMS OF NEW I/O PRIMITIVES

;;;	(DEFUN UREAD FEXPR (FILENAME)
;;;	       (UCLOSE)
;;;	       ((LAMBDA (FILE)
;;;			(EOFFN UREAD
;;;			       (FUNCTION
;;;				  (LAMBDA (EOFFILE EOFVAL)
;;;					  (UCLOSE)
;;;					  EOFVAL)))
;;;			(INPUSH (SETQ UREAD FILE))
;;;			(DEFAULTF FILE))
;;;		(OPEN (*UGREAT FILENAME) 'IN)))

UREAD:	PUSH P,A		;FEXPR
	PUSHJ P,UCLOSE
	POP P,A
	PUSHJ P,UGREAT
	PUSH P,[UREAD2]
	PUSH P,A
	MOVNI T,1
	JRST $EOPEN
UREAD2:	MOVEM A,VUREAD
	PUSH P,[UREAD1]
	PUSH P,A
	PUSH P,[QUREOF]
	MOVNI T,2
	JRST EOFFN
UREAD1:	HRRZ A,VUREAD
	PUSHJ P,INPUSH
	PUSHJ P,DEFAULTF
	HRRZ A,VUREAD
	JRST TRUENAME		;RETURN TRUENAME OF FILE TO USER

UREOF:	PUSH P,B		;+INTERNAL-UREAD-EOFFN - SUBR 2
	PUSHJ P,UCLOSE
	JRST POPAJ


;;;	(DEFUN UCLOSE FEXPR (X)
;;;	       (COND (UREAD
;;;		      ((LAMBDA (OUREAD)
;;;				(AND (EQ OUREAD INFILE) (INPUSH -1))
;;;				(SETQ UREAD NIL)
;;;				(CLOSE OUREAD))
;;;			   UREAD))
;;;		     (T NIL)))

UCLOSE:	SKIPN A,VUREAD		;FEXPR
	 POPJ P,
	CAMN A,VINFILE
	 PUSHJ P,INPOP		;SAVES A
	SETZM VUREAD
	JRST $CLOSE


;;;	(DEFUN UWRITE FEXPR (DEVDIR)
;;;	       (OR DEVDIR (SETQ DEVDIR (CAR (DEFAULTF NIL))))
;;;	       (*UWRITE (CONS DEVDIR
;;;			      (COND ((STATUS FEATURE DEC10)
;;;				     (CONS (STATUS JNAME) '(OUT)))
;;;				    ((STATUS FEATURE DEC20)
;;;				     '(MACLISP OUTPUT))
;;;				    ((STATUS FEATURE ITS)
;;;				     '(.LISP. OUTPUT))))
;;;			'OUT
;;;			(LIST DEVDIR)))
;;;
;;;	(DEFUN UAPPEND FEXPR (FILENAME)
;;;	       (SETQ FILENAME (*UGREAT FILENAME))
;;;	       (*UWRITE FILENAME 'APPEND FILENAME))
;;;
;;;	(DEFUN *UWRITE (NAME MODE NEWDEFAULT)	;INTERNAL ROUTINE
;;;	       (COND (UWRITE
;;;		      (SETQ OUTFILES (DELQ UWRITE OUTFILES))
;;;		      (CLOSE UWRITE)
;;;		      (SETQ UWRITE NIL)))
;;;	       ((LAMBDA (FILE)
;;;			(SETQ OUTFILES
;;;			      (CONS (SETQ UWRITE FILE)
;;;				    OUTFILES))
;;;			(CAR (DEFAULTF NEWDEFAULT)))
;;;		(OPEN NAME MODE)))

UAPPEND:	PUSHJ P,UGREAT	;FEXPR
	MOVEI C,(A)
	MOVEI B,QAPPEND
	JRST UWRT1

UWRITE:	JUMPN A,UWRT0		;FEXPR
	PUSHJ P,DEFAULTF
	HLRZ A,(A)
UWRT0:	PUSHJ P,NCONS
IFN ITS+D20,[
	MOVEI C,(A)
	HLRZ A,(C)
	MOVEI B,QLSPOUT
	PUSHJ P,CONS
]		;END OF IFN ITS+D20
IFN D10,[
	PUSH P,A
	PUSHJ P,SJNAME
	MOVEI B,Q$OUT
	PUSHJ P,CONS
	POP P,C
	HLRZ B,(C)
	PUSHJ P,XCONS
]		;END OF IFN D10
	MOVEI B,Q$OUT
UWRT1:	PUSH P,C		;*UWRITE BEGINS HERE
	PUSH P,[UWRT2]
	PUSH P,A
	PUSH P,B
	SKIPE VUWRITE
	 PUSHJ P,UFILE5
	MOVNI T,2
	JRST $OPEN
UWRT2:	MOVEM A,VUWRITE
	HRRZ B,VOUTFILES
	PUSHJ P,CONS
	MOVEM A,VOUTFILES
	POP P,A
	PUSHJ P,DEFAULTF
	JRST $CAR


;;;	(DEFUN UFILE FEXPR (SHORTNAME)
;;;	       (COND ((NULL UWRITE)
;;;		         (ERROR 'NO/ UWRITE/ FILE
;;;				(CONS 'UFILE SHORTNAME)
;;;				'IO-LOSSAGE))
;;;		     (T (PROG2 NIL
;;;			       (DEFAULTF (RENAMEF UWRITE (*UGREAT SHORTNAME)))
;;;			       (SETQ OUTFILES (DELQ UWRITE OUTFILES))
;;;			       (SETQ UWRITE NIL)
;;;			       (OR OUTFILES (SETQ ^R NIL))))))

UFILE0:	MOVEI B,QUFILE
	PUSHJ P,XCONS
	IOL [NO UWRITE FILE!]

UFILE:	SKIPN VUWRITE		;FEXPR
	 JRST UFILE0
	PUSHJ P,UGREAT
	MOVEI B,(A)
	SETZ A,
	EXCH A,VUWRITE
	PUSH P,A
	PUSH P,B
	HRRZ B,VOUTFILES
	PUSHJ P,.DELQ
	MOVEM A,VOUTFILES
	SKIPN VOUTFILES
	 SETZM TAPWRT
	POP P,B
	POP P,A
	PUSHJ P,$RENAME		;CLOSES THE FILE AS WELL AS RENAMES IT
	PUSHJ P,DEFAULTF
	POPJ P,

UFILE5:	HRRZ A,VUWRITE
	HRRZ B,VOUTFILES
	PUSHJ P,.DELQ
	MOVEM A,VOUTFILES
	HRRZ A,VUWRITE
	PUSHJ P,$CLOSE
	SETZM VUWRITE
	SKIPN VOUTFILES
	 SETZM TAPWRT
	POPJ P,


;;;	(DEFUN CRUNIT FEXPR (DEVDIR)
;;;	       (CAR (DEFAULTF (AND DEVDIR (LIST DEVDIR)))))

SCRUNIT:	SETZ A,
CRUNIT:	SKIPE A			;FEXPR
	PUSHJ P,NCONS
	PUSHJ P,DEFAULTF
	JRST $CAR


;;;	(DEFUN *UGREAT (NAME)		;INTERNAL ROUTINE
;;;	       (MERGEF NAME
;;;		       (COND ((STATUS FEATURE ITS) '(* . >))
;;;			     ('(* . LSP)))))



UGREAT:	PUSH P,[6BTNML]
UGRT1:	PUSHJ P,FIL6BT
IFN ITS+D10,[
REPEAT 3,	PUSH FXP,[SIXBIT \*\]
IT$	PUSH FXP,[SIXBIT \>\]
SA$	PUSH FXP,[SIXBIT \___\]
SA% 10$	PUSH FXP,[SIXBIT \LSP\]
10$	SETOM -2(FXP)		;FOR D10 DEFAULT PPN IS -1
]		;END OF IFN ITS+D10
IFN D20,[
	PUSHN FXP,L.F6BT
	MOVE T,[ASCII \LSP\]
	MOVEM T,-L.6EXT-L.6VRS+1(FXP)
]		;END OF IFN D20
	JRST IMRGF


;;;	(DEFUN UPROBE FEXPR (FILENAME)
;;;	       (SETQ FILENAME (MERGEF (*UGREAT FILENAME) NIL))
;;;	       (PROBEF FILENAME))

UPROBE:	PUSHJ P,UGRT1		;FEXPR
	JRST PROBF0


;;;	(DEFUN UKILL FEXPR (FILENAME)
;;;		    (DEFAULTF (DELETEF FILENAME))))

UKILL:	PUSHJ P,$DELETEF
	JRST DEFAULTF



SUBTTL	SYMBOL MANIPULATION AND SQUOZE FUNCTIONS

;;; (TTSR| <SYMBOL>) GETS THE ARRAY PROPERTY OF <SYMBOL>,
;;; OR GIVES IT AN ARRAY PROPERTY WITH A DEAD SAR;
;;; IT MARKS THE SAR AS BEING NEEDED BY COMPILED CODE,
;;; AND THEN RETURNS THE ADDRESS OF THE TTSAR AS A FIXNUM.
;;; THIS IS USED PRIMARILY BY LAP.

TTSR:	PUSH P,CFIX1	;SUBR 1 - NCALLABLE (TTSR|)
	MOVEI C,(A)	;SAVES AR1,R,F - SEE FASLOAD
	PUSHJ P,ARGET
	JUMPN A,TTSR1
	JSP T,SACONS
	MOVEI T,ADEAD
	MOVEM T,ASAR(A)
	MOVE T,[TTDEAD]
	MOVEM T,TTSAR(A)
	MOVEI B,(A)
	MOVEI A,(C)
	MOVEI C,QARRAY
	PUSHJ P,PUTPROP
TTSR1:	MOVSI T,TTS.CN
	IORM T,TTSAR(A)
	MOVEI TT,1(A)
	POPJ P,

;;; BOTH ROUTINES ALWAYS RETURN THE LEFT-JUSTIFIED SQUOZE IN T
;;;   RSQUEEZE MAY LEAVE RIGHT-JUSTIFIED SQUOZE IN TT
RSQUEEZE:			;CANONICAL SQUOZE CONVERSION
IT%	HRROS (P)		;FOR DEC-10, GIVES DEC-10 SQUOZE
SQUEEZE:			;THIS ALWAYS GIVES LEFT-JUSTIFIED SQUOZE
	MOVEI AR1,6		;CONVERT PNAME-ATOM TO SQUOZE AND SIXBIT
	MOVE AR2A,[440600,,SQ6BIT] ;RETURNS SQUOZE IN TT, SIXBIT IN SQ6BIT
	SETZM SQ6BIT		;CLEAR LOCS USED TO ACCUMULATE
	SETZM SQSQOZ		; SIXBIT AND SQUOZE
	HRROI R,SQZCHR
	PUSHJ P,PRINTA		;"PRINT" OUT CHARS OR PNAME
IT%	MOVE TT,SQSQOZ
	SKIPA T,SQSQOZ
	IMULI T,50
	SOJGE AR1,.-1		; MULTIPLY ITS SQUOZE UP TO SIZE
IT%	MOVE R,(P)
IT%	TLNN R,1
	MOVE TT,T
	POPJ P,

SQZCHR:	TLNN AR2A,770000	;IGNORE MORE THAN 6 CHARS
	 POPJ P,
	SUBI A,40		;CONVERT TO SIXBIT
	CAIL A,1		;LOSSAGE IF NOT SIXBIT CHAR
	 CAILE A,77		; - ALSO, SPACE IS A LOSS
	  MOVEI A,'.		;LOSING NON-SQUOZE CHAR
	IDPB A,AR2A		;DEPOSIT SIXBIT CHAR
	CAIL A,'A		;CHECK FOR LETTER
	 CAILE A,'Z
	  JRST SQNOTL
	SUBI A,'A-13		;CONVERT TO SQUOZE VALUE
SQOK:	EXCH T,SQSQOZ
	IMULI T,50
	ADDI T,(A)
	EXCH T,SQSQOZ
	SOJA AR1,CPOPJ		;DECR COUNT AND RETURN TO PRINTA

SQNOTL:	CAIL A,'0		;CHECK FOR DIGIT
	 CAILE A,'9
	  JRST SQNOTD
	SUBI A,'0-1		;CONVERT TO SQUOZE VALUE
	JRST SQOK

SQNOTD:	CAIE A,'$		;CHECK FOR $ OR %
	 CAIN A,'%
	  JRST SQ%$
	MOVEI A,'.		;ANY CHAR OTHER THAN A-Z, 0-9, $, OR %
	DPB A,AR2A		; DEFAULTS TO . (E.G. *FOOBAR -> .FOOBA)
	MOVEI A,45-42
SQ%$:	ADDI A,42		;SQUOZE VALUE FOR $,%,.
	JRST SQOK

5BTWD:	PUSH P,CFIX1
$5BTWD:	PUSH FXP,R70
5BTWD0:	MOVEI C,(A)
	HRRZ B,(A)
	JUMPE B,5BTWD1
	HLRZ A,(A)
	JSP T,FXNV1
	LSH TT,-2
	MOVEM TT,(FXP)
	MOVEI A,(B)
5BTWD1:	HLRZ A,(A)
	JSP T,SPATOM
	JRST 5BTWD9
	PUSHJ P,SQUEEZE
	MOVE R,SQ6BIT
	POP FXP,D
	DPB D,[400400,,TT]
	POPJ P,

5BTWD9:	SETZM (FXP)
	MOVEI A,(C)
	WTA [BAD ARG - SQUOZE!]
	JRST 5BTWD0



UNSQOZ:	LDB T,[004000,,D]	;HAIRY MESS TO CONVERT
	SETZM LD6BIT		; SQUOZE TO SIXBIT
UNSQZ1:	IDIVI T,50		;(THIS IS SEPARATE ROUTINE SO
	JUMPE TT,UNSQZ2		; LAP LOSERS CAN USE IT)
	CAIL TT,45		;<1SQUOZE .>
	JRST UNSQZ3
	CAIL TT,13		;<1SQUOZ A> IS 13
	ADDI TT,'A-13		;CONVERT RANGE  A - Z , 
	CAIGE TT,13		;<1SQUOZ 1>   IS 1
	ADDI TT,'0-1		;CONVERT RANGE  0 - 9
UNSQZ2:	IOR TT,LD6BIT
	ROT TT,-6
	MOVEM TT,LD6BIT
	JUMPN T,UNSQZ1
	MOVE A,[440600,,LD6BIT]	;MAKE SIXBIT INTO AN ATOM
	JRST READ6C

UNSQZ3:	SUBI TT,46-'$		;[1SQUOZ $] IS 46, [1SQOZ .] IS 45
	CAIN TT,45-<46-'$>	;CONVERT RANGE $ - % 
	MOVEI TT,'*		;BUT  .  IS EXCEPTIONAL
	JRST UNSQZ2




PUTDDTSYM:
	MOVEI R,0	;PUTDDTSYM| IS FOR LAP - OFFSETS VALUE BY LOAD OFFSET
PUTDD0:
IT$	JSP T,SIDDTP		;LOSE IF NO DDT TO GIVE SYMBOL TO
IT% 20%	SKIPN .JBSYM"
	 JRST FALSE
	PUSH FXP,R
	PUSH P,B
10$	SKIPL R			;SEE LDPUT1
	 PUSHJ P,RSQUEEZE	;SQUEEZE ATOM'S PNAME DOWN TO SQUOZ CODE
	POP P,B
	PUSHJ P,GETDDG		;L-JUST SQUOZ IN T, CANONICAL-JUST IN TT
	 JRST PUTDX		;DONT REDEFINE GLOBALSYMS
IFE ITS,[
	PUSHJ P,GETDDJ
	 JRST PUTDD4
	MOVEI F,(D)
]		;END OF IFE ITS
PUTDD2:	JSP T,FXNV2			;GET VALUE OF SECOND ARG
	POP FXP,R
	ADDI D,(R)			;ADD IN OFFSET
IT$	.BREAK 12,[..SSYM,,TT]
10$	MOVEM D,(F)			;NON-ITS LEAVES IN F A PTR TO SYMTAB 
	JRST TRUE			; SLOT WHERE ENTRY IS TO BE MADE

IFE ITS,[
PUTDD4:	SOSGE SYMLO
	 JRST FALSE
	MOVE F,R70+2
	SUBB F,.JBSYM"
	TLO TT,100000		;LOCAL SYMBOL
	MOVEM TT,(F)
	AOJA F,PUTDD2
]		;END OF IFE ITS

PUTDX:	POPI FXP,1
	JRST FALSE


SUBTTL	LAPSETUP AND FASLAPSETUP

LAPSETUP:
	JUMPN A,LAPSMH		;ARG = NIL => SETUP SOME SYM PROPERTIES
	MOVEI T,LAPST2
LAP5HAK:
	PUSH P,T		;APPLIES THE ROUTINE FOUND IN T
				; TO ALL THE GLOBALSYMS
	PUSH P,[441100,,LAP5P]	;ATOMIC SYMBOL PLACED IN A,
				; GLOBALSYM INDEX IN TT
	MOVSI F,-LLSYMS
L5H1:	ILDB TT,(P)		;HAFTA GET THE GLOBALSYM INDEX FROM
				; PERMUTATION TABLE
	CAIL TT,LGSYMS		;IF NOT A GLOBALSYM [BUT AN XTRASYM], SKIP IT
	JRST L5XIT
	CAIN TT,3		;****NEVER CHANGE THE GLOBALSYM INDICES FOR:
	JRST L5SPBND		;  SPECBIND	 3
	CAIN TT,25		;  ERSETUP	25
	JRST L5ERSTP		;  MAKUNBOUND	34
	CAIN TT,34		;  INHIBIT	47
	JRST L5MKUNBD		;  0*0PUSH	53
	CAIN TT,47		;  NILPROPS	54
	JRST L5INHIBI		;THOSE HAVE MORE THAN 6 CHARS IN THEIR PNAME
	CAIN TT,53		;AND CANT BE RECONSTRUCTED BY UNSQOZ'ING FROM
	JRST L50.0P		;FROM THE LAPFIV TABLE
	CAIN TT,54
	JRST L5NILP
	MOVE D,LAPFIV(F)
	PUSHJ P,UNSQOZ
L5H2:	LDB TT,(P)
	PUSHJ P,@-1(P)
L5XIT:	AOBJN F,L5H1
	JRST POP2J

L5ERSTP:
	MOVEI A,[SIXBIT \ERSETUP \]
	JRST L5H3
L5SPBND:
	MOVEI A,[SIXBIT \SPECBIND \]
L5H3:	HRLI A,440600
	PUSHJ P,READ6C
	JRST L5H2

L5MKUNBD:
	MOVEI A,[SIXBIT \MAKUNBOUND \]
	JRST L5H3
L5INHIBIT:
	MOVEI A,[SIXBIT \INHIBIT \]
	JRST L5H3
L50.0P:	MOVEI A,[SIXBIT \0*0PUSH \]
	JRST L5H3
L5NILP:	MOVEI A,[SIXBIT \NILPROPS\]
	JRST L5H3


LAPSMH:	CAIE A,TRUTH		;(LAPSETUP| T 2) MEANS
	 JRST LAPSM1		; SET UP THE XCT HACK AREAS
10$	JSP T,FXNV2		; WITH 2 XCT PAGES
10$	MOVE TT,D
10$	JRST LDXHAK
10%	POPJ P,			;FOR NON TOPS-10, NO NEED TO DO ANY SETUP

LAPSM1:	MOVEI T,(B)		;OTHERWISE, FIRST ARG IS ADDRESS
	MOVEI R,(A)		; TO HACK, SECOND NON-NIL =>
	MOVE TT,(R)		;	TRY THE XCT-PAGE HAK
	PUSHJ P,PRCHAK		;TRY TO SMASH (SKIP ON FAILURE)
	 JRST TRUE
	MOVEI A,(AR2A)
	MOVE B,VPURCLOBRL
	PUSHJ P,CONS
	MOVEM A,VPURCLOBRL
	JRST TRUE

LAPST2:	MOVE TT,LSYMS(TT)	;GET ACTUAL VALUE FROM GLOBALSYM INDEX
	MOVEI C,QSYM
LSYMPUT:			;EXPECTS SYMBOL IN A, "SYM" OR "GLOBALSYM"
	MOVEI B,(A)		; IN C, AND VALUE IN TT
	JSP T,FXCONS
	EXCH A,B
	JRST PUTPROP

FSLSTP:
	MOVEI T,FSLST2
	PUSHJ P,LAP5HAK
	MOVE TT,LDFNM2
	JRST FIX1

FSLST2:	MOVEI C,(A)	;MAKE UP ATOMIC SYMBOLS AND GIVE THEM SYM PROPERTIES
	JSP T,FXCONS	; OF THE FORM (0 (NIL <N>))
	PUSHJ P,NCONS	; WHERE <N> IS THE INDEX OF THE SYMBOL
	SETZ B,		; (THESE ARE THE "GLOBALSYMS")
	PUSHJ P,XCONS
	PUSHJ P,NCONS
	MOVE B,CIN0
	PUSHJ P,XCONS
	MOVEI B,(A)
	MOVEI A,(C)
	MOVEI C,Q%GLOBALSYM
	JRST PUTPROP



	R70		;GLOBALSYM NUMBER -1
LSYMS:	GLBSYM A
LGSYMS==.-LSYMS		;END OF GLOBALSYMS HACKED BY FASLAP
	XTRSYM A
LLSYMS==.-LSYMS		;END OF ALL GLOBAL SYMBOLS

;;; SIXBIT FOR LAP SYMBOL NAMES; MUST MATCH IRP LIST OF GLBSYM
ZZ==0
LAPSIX:	.BYTE 6
SIXSYM [
	IRPC Q,,[A]
		'Q
	TERMIN
		0
	ZZ==ZZ+1
]		;END OF SIXSYM ARGUMENT
	.BYTE
IFN ZZ-LGSYMS, WARN [LAPSIX OUT OF PHASE]
EXPUNGE ZZ

LAPFIV:
GLBSYM [SQUOZE 0,A]
XTRSYM [SQUOZE 0,A]

	HAOLNG LOG2LL5,<LLSYMS-1>	;CROCK FOR BINARY SEARCH
	REPEAT <1_LOG2LL5>-LLSYMS, 377777,,777777

LAP5P:	BLOCK <LLSYMS+3>/4	;PERMUTATION, STORED 4/WD, TO GET GLOBALSYMINDEX FROM LAPFIV INDEX


GETDDTSYM:
	PUSHJ P,RSQUEEZE
	PUSHJ P,GETDDG		;GET GLOBALSYM INDEX, AND NO-SKIP IF WIN
	 JRST FIX1
IFN ITS,[
	MOVE D,TT		;SAVE SQUOZE OVER CALL TO SIDDTP
	JSP T,SIDDTP		;LOSE IF NO DDT FROM WHICH TO GET SYMBOL
	 JRST FALSE
	MOVE TT,D
	.BREAK 12,[..RSYM,,TT]
	JUMPE TT,FALSE
	MOVE TT,TT+1
	JRST FIX1
]	;END OF IFN ITS
IFE ITS,[
	PUSHJ P,GETDDJ
	 JRST FALSE
	JRST FIX1

GETDDJ:	SKIPA D,.JBSYM"		;SQUOZ IN TT - FIND SYMBOL IN JOB SYMBOL TABLE
GETDD1:	ADD D,R70+2		; SKIP IF FOUND
	JUMPGE D,CPOPJ
	MOVE T,(D)
	TLZ T,540000
	TLZN T,200000		;SYMBOL MUSTN'T BE KILLED
	 CAME T,TT		;MUST BE THE ONE WE WANT
	  JRST GETDD1
	MOVE TT,1(D)
	AOJA D,POPJ1
]	;END OF IFE ITS


GETDDG:	MOVEI R,0		;SQUOZ IN T, SEARCH "GLOBALSYM" TABLE, 
	TLZ T,740000		;  SKIP IF LOSE, LEAVE VALUE IN TT IF WIN
REPEAT LOG2LL5,[
	CAML T,LAPFIV+<1_<LOG2LL5-.RPCNT-1>>(R)
	 ADDI R,1_<LOG2LL5-.RPCNT-1>
]		;END OF REPEAT LOG2LL5
	CAME T,LAPFIV(R)	;IF DDTSYM REQUEST IS FOR A GLOBAL SYM
	 JRST POPJ1		;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)	;USE TABLE FROM FASLOAD
	MOVE TT,LSYMS(TT)
	POPJ P,


LGTSPC:	MOVEM TT,GAMNT
	ADD TT,@VBPORG		;INSURE THAT BPEND-BPORG > (TT)
	SUB TT,@VBPEND
	JUMPGE TT,GTSPC1	;MUST RELOCATE, OR GET MORE CORE.
	MOVE A,VBPEND		;ALREADY OK
	MOVE TT,(A)
	POPJ P,

PAGEBPORG:	MOVE A,VBPORG	;MAKE SURE BPORG IS ON PAGE BOUNDRY
	MOVE TT,(A)		;NUMERIC VALUE OF BPORG
	TRNN TT,PAGKSM
	POPJ P,
	ADDI TT,PAGSIZ-1
	ANDCMI TT,PAGKSM
	CAMGE TT,@VBPEND
	JRST PGBP4
	PUSH FXP,TT		;NEW VALUE FOR BPORG
	JSP T,SPECBIND
	0 VNORET
	AOS VNORET
	PUSH P,CUNBIND
	SUB TT,(A)
	PUSHJ P,LGTSPC
	JUMPE TT,[LERR [SIXBIT \NO CORE - PAGEBPORG!\]]
	POP FXP,TT
PGBP4:	JSP T,FIX1A
	MOVEM A,VBPORG		;GIVE BPORG NEW PAGIFIED VALUE
	POPJ P,

SUBTTL	MAKUNBOUND

;NEVER FLUSHES VALUE CELL
MAKUBE:	%WTA [SIXBIT \UNCHANGEABLE VALUE - MAKUNBOUND!\]
MAKUNBOUND:			;SUBR 1 - FLUSH VALUE OF ATOMIC SYMBOL
   BAKPRO
	JSP D,SETCK		;MAKE SURE IT'S A SYMBOL
	JUMPE A,MAKUBE
	CAIN A,TRUTH
	 JRST MAKUBE
	HLRZ T,(A)
	MOVE B,(T)
IFE 0, NOPRO
IFN 0,[
	TLNE B,300		;CAN'T RECLAIM VALUE CELL IF PURE
	 JRST MAKUN1		; OR IF COMPILED CODE NEEDS IT
	TLZ B,-1
	CAIN B,SUNBOUND		;CAN'T RECLAIM SUNBOUND!!!
	 POPJ P,
	CAIL B,BXVCSG+NXVCSG*SEGSIZ
	 JRST MAKUN1		;CAN'T RECLAIM CELL NOT IN VALUE CELL AREA
	EXCH B,FFVC		;SO RECLAIM THE VALUE CELL ALREADY
   XCTPRO
	MOVEM B,@FFVC
	MOVEI B,SUNBOUND	;USE SUNBOUND FOR A VALUE CELL
	HRRM B,(T)
   NOPRO
	POPJ P,			;THAT'S ALL
]		;END IFN 0

MAKUN1:	PUSH P,A		;MAKE SURE WE RETURN THE ARGUMENT
	PUSH P,CPOPAJ
	MOVEI B,QUNBOUND	;FALL INTO SET WITH "UNBOUND" VALUE
	JRST SET+1


SUBTTL	PURIFICATION RITES

.SEE PURIFY			;PURIFY ENTERS HERE
FPURF7:	MOVSI F,2000		;THIS BIT CONVERTS CALL TO CALLF, JCALL TO JCALLF
	MOVEI T,VPURCL
	PUSH P,T
FPURF1:	HRRZ T,(T)		;CDR DOWN THE PURLIST
FPUR1Q:	JUMPE T,POP1J
FPUR1A:	HLRZ AR2A,(T)
	PUSHJ P,LDSMSH		;TRY TO SMASH
	 JRST FPURF4		;WIN
	IORM F,(AR2A)		;LOSE - MAKE IT A CALLF/JCALLF
FPURF4:	HRRZ T,@(P)		;WIN, SO CUT IT OUT OF PURCLOBRL
	HRRZ T,(T)
	HRRM T,@(P)
	JRST FPUR1Q

IFN USELESS,[

$PURIFY:
IFN D10, POPJ P,
IFN ITS+D20,[
	LOCKTOPOPJ
	SETZ AR1,
	JSP T,FXNV1		;GET TWO MACHINE NUMBERS
	JSP T,FXNV2
	ANDCMI TT,1777		;PAGIFY FIRST DOWNWARD
	IORI D,1777		;PAGIFY SECOND UPWARD
	CAMLE TT,D
	 LERR [SIXBIT \ARG 2 < ARG 1 - PURIFY!\]
	JUMPE C,FPURF3		;NULL THIRD ARG MEANS DEPURE
	MOVE T,LDXLPL
	HRRZ T,LDXPSP(T)	;GET ADR OF POSSIBLY PURE PAGE
	CAIG TT,(T)
	 CAIGE D,(T)
	  SKIPA
	   SETZM LDXLPC		;FOR PURE PAGE JUST FORCE FREE COUNT TO ZERO
FPURF0:	CAIE C,QBPORG
	 JRST FPURF3
	PUSHJ P,FPURF7
	JRST FPURF2

FPURF3:	JSP R,IP0
	POPJ P,

]		;END OF IFN ITS+D20

;;;	IFN USELESS

IP0:				;PURIFY/DEPURIFY SOME PAGES
IFN D10, JRST (R)		;C HAS FLAG, NON-NULL MEANS PURIFY
IFN D20+ITS,[
	LSH D,-PAGLOG		;CALLED BY JSP R,IP0
	LSH TT,-PAGLOG		;USES B,C,T,TT,D,F
	CAIGE TT,1
	 LERR [SIXBIT \1ST PAGE NOT PURE!\]
	MOVEI B,(TT)		;FIGURE OUT PURTBL BYTE POINTER
IFN ITS,[
	ROT B,-4
	ADDI B,(B)
	ROT B,-1
	TLC B,770000
	ADD B,[450200,,PURTBL]
	SUBI D,-1(TT)		;CALCULATE NUMBER OF PAGES
	IMULI TT,1001
	TRO TT,400000		;SET UP ARG FOR .CBLK20$	MOVSI 1,.FHSLF
	SKIPN C
	 TLOA TT,400
	  SKIPA C,R70+2		;IN PURTBL, 1=IMPURE, 2=PURE
	   MOVEI C,1
IP7:	.CBLK TT,		;HACK PAGE
	 JSP F,IP1		;IP1 HANDLES LOSSES
	ADDI TT,1001
]		;END OF IFN ITS
IFN D20,[
	ROT TT,-4
	ADDI TT,(TT)
	ROT TT,-1
	TLC TT,770000
	ADD TT,[450200,,PURTBL]
	SUBI D,-1(B)		;CALCULATE NUMBER OF PAGES
	HRRI 1,(TT)
	HRLI 1,.FHSLF
	MOVSI 2,(PA%RD+PA%EX)
	SKIPN C
	 TLOA 3,(PA%CPY)
	  SKIPA F,R70+2
	   MOVEI F,1
IP7:	SPACS
	ADDI 1,1
	ADDI 2,1
]		;END OF IFN D20
	TLNN B,730000		;FOR BIBOP, DEPOSIT BYTE IN PURTBL
	 TLZ B,770000
IT$	IDPB C,B
20$	IDPB F,TT
	SOJN D,IP7
	JRST (R)

IFN ITS,[
IP1:	MOVE T,[4400,,<776000+<SFA*1000>>];ASSUME FAILURE WAS DUE TO SHARING
	.CBLK T,		;USES ONLY T,TT
	 .LOSE 1000+%ENACR	;NO CORE AVAILABLE
	LDB T,[111000,,TT]
	LSH T,PAGLOG+22
	HRRI T,<376+SFA>*PAGSIZ ;SO COPY PAGE INTO SOME FAKE PAGE
	BLT T,<376+SFA>*PAGSIZ+1777 ;LIKE PAGE NUMBER 376
	MOVE T,TT
	ANDCMI T,377
	IORI T,376+SFA
	.CBLK T,		;MOVE PAGE MAP FOR 376 INTO LOSING PAGE POSITION
	 .LOSE
	MOVEI T,376000+<SFA*1000>
	.CBLK T,		;FLUSH ENTRY FOR PAGE 376
	 .LOSE
	JRST (F)
]		;END OF IFN ITS
]		;END OF IFN ITS+D20
]		;END OF IFN USELESS

SUBTTL	100$G RESETS THE WORLD!

GOINIT:
IT$	.SUSET [.S40ADDR,,[TWENTY,,FORTY]]	;SET .40ADDR
	MOVEI A,READTABLE
	MOVEM A,VREADTABLE
IFN USELESS,[
	MOVE A,[RCT0,,RCT]
	BLT A,RCT+LRCT-1	;RESTORE READ CHARACTER SYNTAX TABLE
]		;END OF IFN USELESS
	MOVEI A,TTYIFA
	MOVEM A,V%TYI
	MOVEI A,TTYOFA
	MOVEM A,V%TYO
	MOVEI A,TRUTH
	MOVEM A,VINFILE
	SETZM VINSTACK
	SETZM VOUTFILES
	SETZM VECHOFILES
	MOVEI A,QTLIST
	MOVEM A,VMSGFILES
IFN USELESS&ITS,[
	MOVEI T,IB<MAR>		;RESET THE MAR BREAK FEATURE
	ANDCAM T,IMASK
	.SUSET [.SAMASK,,T]
	.SUSET [.SMARA,,R70]
]		;END OF IFN USELESS
	MOVEI A,OBARRAY
	MOVEM A,VOBARRAY	;GET BACK TOPLEVEL OBARRAY
	SETZM V%PR1
	SETZM VOREAD
	SETZM TLF
	SETZM BLF		;??
	SETZM UNRC.G		;CLEAR STACKED NOINTERRUPT STUFF
	SETZM UNRRUN
	SETZM UNRTIM
	SETZM UNREAR
	SETZM TTYOFF
	JSP A,ERINIT
GOINI7:	SETZB A,VERRLI		;NULLIFY ERRLIST
	PUSHJ P,INTERN
	JUMPE A,LISPGO
	PUSHJ P,REMOB2		;GET STANDARD COPY OF NIL ON OBLIST
	JRST GOINI7

	PGTOP UIO,[UTAPE, LAP, AND AGGLOMERATED SUBRS]