perm filename ULAP[NEW,LSP] blob sn#398848 filedate 1978-11-27 generic text, type C, neo UTF8
COMMENT ⊗   VALID 00025 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	   -*-MIDAS-*-
C00005 00003
C00008 00004
C00010 00005
C00012 00006
C00015 00007
C00019 00008
C00022 00009
C00024 00010
C00026 00011
C00029 00012
C00031 00013
C00032 00014
C00034 00015
C00037 00016
C00039 00017
C00041 00018
C00046 00019
C00047 00020
C00051 00021
C00053 00022
C00055 00023
C00057 00024
C00060 00025
C00061 ENDMK
C⊗;
;;;   -*-MIDAS-*-
;;;   **************************************************************
;;;   ***** MACLISP ****** UTAPE, LAP, AND AGGLOMERATED SUBRS ******
;;;   **************************************************************
;;;   ** (C) COPYRIGHT 1978 MASSACHUSETTS INSTITUTE OF TECHNOLOGY **
;;;   ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) *******
;;;   **************************************************************



	PGBOT [UIO]


IFN QIO,[

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

;;;	IFN QIO

;;;	(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

;;;	IFN QIO

;;;	(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

;;;	IFN QIO

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

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
	MOVEI T,-L.6EXT-L.6VRS+1(FXP)
	HRLI T,[ASCII \MACLISP\]
	BLT T,-L.6EXT-L.6VRS+2(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

]		;END OF IFN QIO

IFE QIO,[

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

CRUNIT:	JUMPN A,UINIT0		;GET (MAYBE AFTER SETTING) CRUNIT
SCRUNIT:	MOVE A,IUNIT	;GET CRUNIT
	JRST UINIT1
UINIT0:	HLRZ C,(A)		;CAR IS DEVICE
	HRRZ A,(A)		;CADR IS DIRECTORY
	SKIPN A
	HRRZ A,@IUNIT		;IF NOT GIVEN, USE PRESENT ONE
	HLRZ A,(A)
	PUSHJ P,NCONS		;MAKE UP NEW CRUNIT
	MOVE B,C
	PUSHJ P,XCONS
UINIT1:	MOVEM A,IUNIT		;SAVE NEW CRUNIT
	HLRZ A,@IUNIT
	PUSHJ P,SIXMAK		;GET SIXBIT FOR DEVICE
IT$	HLRM TT,UTIN
10$	MOVEM TT,UTIN
	HRRZ A,@IUNIT
	HLRZ A,(A)
IFN ITS,[
	PUSHJ P,SIXMAK		;GET SIXBIT FOR DIRECTORY
	CAME TT,USN
	.SUSET [.SSNAM,,TT]
]		;END OF IFN ITS
IFN D10,[
IFE SAIL,[
	JSP T,SPATOM
	JRST .+3
	PUSHJ P,SIXMAK	;SIXBIT PPN
	JRST UINIT2
	HLRZ B,(A)
	JSP T,FXNV2	;PROJ # IN D
	HRRZ A,(A)
	HLRZ A,(A)
	JSP T,FXNV1	;PROG # IN TT
	HRLI TT,(D)
UINIT2: 
]		;END OF IFE SAIL
IFN SAIL,[
	HLRZ B,(A)	;PROJ# IN B
	HRRZ A,(A)	
	HLRZ A,(A)	;PROG# IN A
	PUSH P,B	;LH PART ON PDL
	PUSHJ P,SIXMAK	;GET SIXBIT FOR RH PART
	PUSHJ P,SARGT	;RIGHT JUSTIFY BOX
	PUSH FXP,TT	;ON ANOTHER STACK
	POP P,A		;LH IN A
	PUSHJ P,SIXMAK	;GET SIXBIT FOR LH
	PUSHJ P,SARGT	;R.J.
	POP FXP,D
	HLR TT,D	;INSTALL RH PART
]		;END OF IFN SAIL
]		;END OF IFN D10
	MOVEM TT,USN
	MOVE A,IUNIT
	POPJ P,


IFN SAIL,[
SARGT:	TLNE TT,77 	;IS RIGHTMOST CHAR ZERO?
	POPJ P,		;WIN
	LSH TT,-6	;SLYDE RIGHT
	JRST SARGT	;ONE MORE TIME, NOW.
]		;END OF IFN SAIL


IFE D10,[
UGREAT:	AOJN T,CPOPJ		;HACK FOR UREAD AND UFILE
	HLRZ A,(A)		; TO DEFAULT SECOND FILE NAME TO >
	MOVEI B,QGRTL
	JRST CONS
]		;END OF IFE D10

;;;	IFE QIO

SUBTTL	OLD I/O UFILE

UFILE:	JSP TT,FWNACK
IT$	FA01234,,QUFILE
10$	FA0234,,QUFILE
	SKIPN UTOOPD
	JRST UFILE0
IT$	PUSHJ P,UGREAT
	PUSHJ P,UFNAME
UFILE1: LOCKI
	SETZM TAPWRT
IFN ITS,[
	MOVEM T,UTIN+3
	MOVEM TT,UTIN+4
	MOVE T,UWRT
	MOVEM T,UTIN
	SETZM UTIN+1
	MOVEI T,UTOC
	MOVEM T,UTIN+2
	MOVEI A,↑C
	PUSHJ P,UTTYO
	.FDELE UTIN
UFRL:	LERR [SIXBITCH \FILE RENAME LOST!\]
	MOVE T,UTOBP
	CAMN T,UTOIBP
	JRST UFRL1
	SKIPA TT,[↑C]		;PAD OUT WITH CONTROL-C'S
	IDPB TT,T
	TLNE T,740000
	JRST .-2
	HRLZS T
	MOVSI TT,UTOB-1
	SUB TT,T
	HRRI TT,UTOB
	.IOT UTOC,TT
UFRL1:	.CLOSE UTOC,
]		;END OF IFN ITS
IFN D10,[
	MOVEM T,D10REN		;MOVE FILENAME TO RENAME BLOCK
	MOVEM T+1,D10REN+1
	SETZB T,T+2
	MOVE T+1,UWRT
	OPEN DELC,T
	JRST NODEV
	MOVE T,D10REN
	MOVE T+1,D10REN+1
	SETZ T+2,
	MOVE T+3,UWUSN
	LOOKUP DELC,T		;FIND OLD FILE IF ANY
	JRST D10NDL
	SETZ T,
	RENAME DELC,T		;DELETE ...
	JRST D10DL1		;ARG!
	RELEASE DELC,
D10NDL:	MOVE T,D10REN		;GET OLD NAME AGAIN
	SETZ T+2,
	MOVE T+3,UWUSN
	TRZ T+1,-1
SA$	CLOSE UTOC,		;LOSING SAIL WON'T FORCE OUTPUT WITHOUT THIS
	RENAME UTOC,T
	LERR [SIXBIT \FILE RENAME LOST!\]
	RELEASE UTOC,
]		;END OF IFN D10
	MOVE A,UWUNIT
	MOVEM A,IUNIT
	SETZM UTOOPD
	UNLKPOPJ

UFILE0:	MOVEI A,QUFILE
	PUSHJ P,NCONS
	%FAC [SIXBIT \NO UWRITE FILE OPEN - UFILE!\]

IFN D10,[
D10DL1: MOVEI B,QUFILE
	JRST UFLER
]		;END OF IFN D10

UKILL:	JSP TT,FWNACK
	FA0234,,QUKILL
	MOVEI T,0
	PUSH P,IUNIT
	PUSHJ P,UINITA		;DOES A LOCKI
IFE D10,[
	SETZM UTIN+3
	.FDELE UTIN
	JRST UKLER
]		;END OF IFE D10
IFN D10,[
	MOVE T+1,UTIN		;PICK UP DEVICE NAME
	SETZB T,T+2
	OPEN DELC,T		;GET THE DEVICE
	JRST UKLER
	HLLZ T+1,UFN2		;GET EXTENSION
	MOVE T,UFN1
	SETZ T+2,
	MOVE T+3,USN
	LOOKUP DELC,T
	JRST UKLER
	SETZB T,T+1		;ZAP THE FILE NAME
	RENAME DELC,T		;BYE
	JRST UKLER
	RELEASE DELC,
]		;END OF IFN D10
	SUB P,R70+1
	UNLKPOPJ

;;;	IFE QIO

SUBTTL	OLD I/O UWRITE

UWRITE:	JSP TT,FWNACK
	FA012,,QUWRITE
IT$	SKIPE UTOOPD
IT$	PUSHJ P,UWRT2
	PUSHJ P,CRUNIT
	LOCKI
	SETOM UAPOS
IFE D10,[
	MOVE T,[SIXBIT \.LISP.\]
	MOVE TT,[SIXBIT \OUTPUT\]
	MOVEM T,UTIN+1
	MOVEM TT,UTIN+2
	PUSHJ P,UTOINT
	MOVEI T,3
UWRT0:	HRLM T,UTIN		;UAPPEND JOINS IN HERE
	MOVEM A,UWUNIT
	TSOPEN UTOC,UTIN
	MOVE T,UTIN
	MOVEM T,UWRT
	SKIPGE UAPOS
	JRST UWRT3
	.ACCESS UTOC,UAPOS
	SETZM UTIN+1
	MOVEI T,UTOC
	MOVEM T,UTIN+2
	MOVE T,[SIXBIT \.LISP.\]
	MOVE TT,[SIXBIT \APPEND\]
	MOVEM T,UTIN+3
	MOVEM TT,UTIN+4
	.FDELE UTIN
	JRST UFRL
UWRT3:
]		;END OF IFE D10
IFN D10,[
	MOVEM A,UWUNIT
	SETZ T,
	MOVE T+1,UTIN			;GET DEVICE
	MOVEM T+1,UWRT
	MOVSI T+2,UTOHED
	OPEN UTOC,T
NODEV:	LERR [SIXBIT \DEVICE NOT AVAILABLE!\]
UWRT0:	MOVEI T,UTOB-3
	EXCH T,.JBFF"
	OUTBUF UTOC,NIOBFS
	EXCH T,.JBFF"
IFN SAIL,[ 
	SKIPN D10NAM
	PUSHJ P, SIXJBN
]	;END OF IFN SAIL
	MOVE T,D10NAM
	MOVSI T+1,(SIXBIT \OUT\)
	SKIPL UAPOS
	MOVSI T+1,(SIXBIT \APP\)
	SETZ T+2,
	MOVE T+3,USN
	MOVEM T+3,UWUSN
	ENTER UTOC,T			;MAKE THE FILE
NOENT:	LERR [SIXBIT \CANNOT ENTER FILE!\]
	SKIPL UAPOS
SA%	USETI UTOC,-1		;NON-SAIL MOVE ACCESS POINTER TO END OF FILE
SA$	UGETF UTOC,T		;SAIL MOVE ACCESS POINTER TO END OF FILE
]		;END OF IFN D10
	AOS UTOOPD
	JRST UEXIT

IFE D10,[
UWRT2:	PUSH P,A
	JSP T,SPECBIND
	   TAPWRT
	MOVE T,[SIXBIT \.LISP.\]
	MOVE TT,[SIXBIT \OUTPUT\]
	PUSHJ P,UFILE1
	PUSHJ P,UNBIND
	JRST POPAJ
]		;END OF IFE D10

;;;	IFE QIO

SUBTTL	OLD I/O UAPPEND

UAPPEND:	JSP TT,FWNACK
IT$	FA01234,,QUAPPEND
10$	FA0234,,QUAPPEND
IT$	PUSHJ P,UGREAT
IT$	SKIPE UTOOPD
IT$	PUSHJ P,UWRT2
	PUSH P,IUNIT
IT$	MOVEI T,2
	PUSHJ P,UINITA
IFE D10,[
	.OPEN UTOC,UTIN
	JRST UAPPER
	.CALL UAFLEN
	.VALUE
UAPP1:	SUBI TT,1
	.ACCESS UTOC,TT
	MOVE T,[-1,,UTOB]
	.IOT UTOC,T
	MOVSI T,-5
	MOVE D,UTOB
	LSH D,-1
UAPP2:	LSHC D,-7
	LSH R,-35
	JUMPE R,UAPP3
	CAIE R,↑L
	CAIN R,↑C
	JRST UAPP3
	PUSHJ P,UTOINT
	HLRE D,T
	ADDM D,UTOBYT
	IMULI T,7
	ADDI T,1
	DPB T,[360600,,UTOBP]
	MOVEM TT,UAPOS
	MOVE A,IUNIT
	SUB P,R70+1
	MOVEI T,100003
	JRST UWRT0

UAPP3:	AOBJN T,UAPP2
	JRST UAPP1

UAFLEN:	SETZ
	SIXBIT \FILLEN\
	1000,,UTOC
	402000,,TT
]		;END OF IFE D10

;;;	IFE QIO

IFN D10,[				;DROPS IN
	SETZ D,
	MOVE D+1,UTIN
	MOVEM D+1,UWRT
	MOVSI D+2,UTOHED
	OPEN UTOC,D
	JRST NODEV
	TRZ T+1,-1
	SETZ T+2,
	MOVE T+3,USN
	LOOKUP UTOC,T
	JRST UAPPER
	SETZB T,T+2
	MOVE T+1,UWRT
	OPEN DELC,T
	JRST NODEV
	MOVE T,D10NAM
	MOVSI T+1,(SIXBIT \APP\)
	SETZ T+2,
	MOVE T+3,USN
	LOOKUP DELC,T
	JRST D10UAN
	SETZ T,
	RENAME DELC,T
	JRST D10UAN
	RELEASE DELC,
D10UAN:	MOVE T,D10NAM
	MOVSI T+1,(SIXBIT \APP\)
	SETZ T+2,
	MOVE T+3,USN
	RENAME UTOC,T
	JRST UAPPER
	TRZ T+1,-1
	SETZ T+2,
	MOVE T+3,USN
	LOOKUP UTOC,T
	JRST UAPPER
	MOVE A,IUNIT
	SUB P,R70+1
	MOVEM A,UWUNIT
	SETZM UAPOS
	JRST UWRT0
]		;END OF IFN D10

;;;	IFE QIO

SUBTTL	OLD I/O UREAD

UREAD:	JSP TT,FWNACK
IT$	FA01234,,QUREAD
10$	FA0234,,QUREAD
IT$	PUSHJ P,UGREAT
	PUSH P,IUNIT
IFE D10,[
	MOVEI T,2			;ORDINARY READ USES BLOCK ASCII INPUT
	PUSHJ P,UINITA			;LOCKI DONE BY UINITA
	.OPEN UTIC,UTIN
	JRST UROER
]		;END OF IFE D10
IFN D10,[
	PUSHJ P,UINITA
	SETZ D,
	MOVE D+1,UTIN			;GET DEVICE
	MOVEI D+2,UTIHED
	OPEN UTIC,D
	JRST UROER
	TRZ T+1,-1			;FLUSH JUNK
	SETZ T+2,
	MOVE T+3,USN
	LOOKUP UTIC,T			;IS THE FILE THERE?
	JRST UROER
	TRZ T+1,-1			;FLUSH LOOKUP JUNK
	MOVEM T,URFN1
	MOVEM TT,URFN2
	MOVE T,IUNIT
	MOVEM T,URUNIT
	MOVEI T,UTIB-3
	EXCH T,.JBFF"
	INBUF UTIC,NIOBFS
	EXCH T,.JBFF"
]		;END OF IFN D10
	SUB P,R70+1
UREAD2:
IT$	MOVE T,[440700,,UTIB+UTBSIZ]
IT$	MOVEM T,UTIBP
	MOVEI T,<↑C>←13
	HRLZM T,UTIB+UTBSIZ
	AOS UTIOPD
	SKIPE ALGCF		;MUST AVOID CONSING WHILE IN ALLOC
	JRST UEXIT
IFE D10,[
	MOVE T,[UTIC,,URCHST]	;GET STATUS OF UREAD CHANNEL
	.RCHST T,
	MOVSI T,(SIXBIT \@\)	;IF DIDN'T GET FILE NAMES BACK,
	SKIPN TT,URCHST+2	; WANT TO USE @'S
	SKIPA TT,T
	MOVE T,URCHST+1
	MOVEM T,URFN1		;SAVE AS FILE NAMES FOR
	MOVEM TT,URFN2		; (STATUS UREAD)
	HRRZ A,IUNIT
	MOVE TT,URCHST+3	;COMPARE DEV AND SNAME TO IUNIT
	CAME TT,USN
	JRST UREAD4
	LDB T,[140600,,URCHST]
	CAIE T,(SIXBIT \ UT\)
	SKIPA T,URCHST
	HRRZ T,URCHST
	TLNE T,-1
	HLRZS T
	SUB T,UTIN
	TRNN T,-1
	JRST UREAD6
UREAD4:	HRRZ A,(A)		;IF THEY DIFFER, MUST CONS UP URUNIT
	JUMPE TT,UREAD5		;IF NO SNAME, MUST BE FUNNY DEV - USE IUNIT'S SNAME
	MOVE A,[440600,,URCHST+3]	;CONS UP SNAME
	SETZM URCHST+4
	PUSHJ P,READ6C
	PUSHJ P,NCONS
UREAD5:	PUSH P,A
	MOVE A,[220600,,URCHST]	;CONS UP DEVICE NAME
	SETZM URCHST+1
	PUSHJ P,READ6C
	POP P,B
	PUSHJ P,CONS
UREAD6:	MOVEM A,URUNIT		;SAVE UREAD UNIT
]		;END OF IFE D10
UEXIT:	MOVE A,IUNIT
	UNLKPOPJ

;;;	IFE QIO

SUBTTL	OLD I/O UCLOSE AND UPROBE

UCLOSE:	SETZ T,
	MOVEI D,QUCLOSE
	JUMPN A,WNAFOSE
	SKIPN A,UTIOPD
	POPJ P,
	JSP A,.UEOF
	JRST TRUE


UPROBE:	JSP TT,FWNACK
IT$	FA01234,,QUPROBE
10$	FA0234,,QUPROBE
IT$	PUSHJ P,UGREAT
	HRRZ B,IUNIT
	JSP T,SPECBIND
	   0 B,IUNIT
	SAVEFX UFN1 UFN2
IT$	MOVEI T,2
	PUSHJ P,UINITA
IT$	.OPEN ERRC,UTIN
IFN D10,[
	SETZB D,D+2
	MOVE D+1,UTIN
	OPEN DELC,D
	JRST UPROB3
	TRZ T+1,-1
	SETZ T+2,
	MOVE T+3,USN
	LOOKUP DELC,T
UPROB3:
]		;END OF IFN D10
	TDZA A,A
	MOVEI A,TRUTH
IT$	.CLOSE ERRC,
10$	RELEASE DELC,
	JUMPE A,UPROB7
	PUSH P,[440600,,UFN1]
	MOVE A,[440600,,UFN2]
	PUSHJ P,READ6C
	HRRZ B,IUNIT
	PUSHJ P,CONS
	EXCH A,(P)
	PUSHJ P,READ6C
	POP P,B
	PUSHJ P,CONS
UPROB7:	UNLOCKI
	RSTRFX UFN2 UFN1
	JRST UNBIND

;;;	IFE QIO

UINITA:	PUSH P,A
IT$	HRLM T,(P)
UNTA1:	MOVEI T,.
	JUMPE A,UNTA2
	HRRZ A,(A)
	JUMPE A,UNTAER
	HRRZ A,(A)
UNTA2:	PUSHJ P,CRUNIT
	LOCKI
	MOVE A,(P)
IT$	HLLM A,UTIN
	HRRZS A,(P)
	PUSHJ P,UFNAME
IT$	MOVEM T,UTIN+1
IT$	MOVEM TT,UTIN+2
	JRST POPAJ


UFNAME:	JUMPE A,UFNM
	PUSH P,A
UFNA1:	HLRZ A,(A)
	PUSHJ P,SIXMAK
	HRRZ A,@(P)
	MOVEI T,UFNA1
	JUMPE A,UNTAER
	MOVEM TT,UFN1
	HLRZ A,(A)
	SUB P,R70+1
	PUSHJ P,SIXMAK
	MOVEM TT,UFN2
UFNM:	MOVE T,UFN1
	MOVE TT,UFN2
	POPJ P,

]		;END OF IFE QIO

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,

RSQUEEZE:			;CANONICAL SQUOZE CONVERSION
IFN D10+D20, 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
IFN D10+D20,[
	MOVE TT,SQSQOZ
	POP P,F
	TLNE F,1
	 JRST (F)
SQUEZ2:	SOJL AR1,(F)
	IMULI TT,50
	JRST SQUEZ2
]		;END OF IFN D10+D20
IFE D10+D20,[
	SKIPA TT,SQSQOZ
	IMULI TT,50		;IF FEWER THAN 6 CHARS, MUST
	SOJGE AR1,.-1		; MULTIPLY ITS SQUOZE UP TO SIZE
	POPJ P,
]		;END OF IFE D10+D20

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



IFN D10,[
GETDD0:	SKIPA D,.JBSYM"		;FIND SYMBOL IN JOB SYMBOL TABLE
GETDD1:	ADD D,R70+2
	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 IFN D10

IFN ITS+D10,[
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
10$	SKIPN .JBSYM"
	 JRST FALSE
	PUSH FXP,R
	PUSH P,B
10$	SKIPL R			;SEE LDPUT1
	 PUSHJ P,RSQUEEZE	;SQUEEZE ATOM'S PNAME DOWN TO SQOUZE CODE
	POP P,B
IT$	.BREAK 12,[3,,D]
	POP FXP,R
IT$	JUMPE D,FALSE
IFN D10,[
	PUSHJ P,GETDD0
	 JRST PUTDD4
	MOVEI F,(D)
]		;END OF IFN D10
PUTDD2:	JSP T,FXNV2		;GET VALUE OF SECOND ARG
	ADDI D,(R)			;ADD IN OFFSET
IT$	.BREAK 12,[400004,,TT]
10$	MOVEM D,(F)
	JRST TRUE

IFN D10,[
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 IFN D10
]		;END IFN ITS+D10

IFN D20,[
PUTDDTSYM:
	MOVEI R,0
PUTDD0:	PUSH P,B
	PUSHJ P,RSQUEEZE	;REDUCE TO SQUOZE (RADIX-50)
	POP P,B
	PUSHJ P,GETDDI		;SEARCH THE INTERNAL TABLE
	 JRST PUTDD1		;NO FOUND, ADD IT
]		;END IFN D20

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

IFE QIO,[
FSLSTP:
	JUMPE A,FSLST1			;ARG = NIL => INITIALIZING FASLAP
	MOVE F,[-LFLSYMS,,FLSYMS]	;ARG=T => LOADING IN A FASLAP
	SKIPA A,[440600,,FLAPSIX]
LSUP3A:	MOVE A,CORBP			;CLOBBER IN SOME SYM PUTPROPS
LSUP3:	PUSHJ P,READ6C
	HRRZ TT,(F)
	MOVEI C,QGSYM
	PUSHJ P,LSYMPUT
	AOBJN F,LSUP3A
	JRST TRUE
]		;END OF IFE QIO

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

Q% FSLST1:
Q$ 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,QGSYM
	JRST PUTPROP



IFE QIO,[

DEFINE FLSYM B
IRP A,,[DSIC]
	B
TERMIN
IFN D10,[
IFN USELESS,[
	IRP A,,[IOO]
		B
	TERMIN
]		;END OF IFN USELESS
	IRP A,,[READ6C,UTIB,UTIHED,D10NAM,UFN1,UFN2,USN,TYIMAN]
		B
	TERMIN

]		;END OF IFN D10
TERMIN

FLSYMS:	FLSYM A
LFLSYMS==.-FLSYMS

FLAPSIX: .BYTE 6
	FLSYM [IRPC Q,,[A]
		'Q
	       TERMIN
		 0 ]
.BYTE

]		;END OF IFE QIO


	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

IFN ITS+D10,[
GETDDTSYM:
	PUSHJ P,RSQUEEZE
$GETDDTSYM:		;SQUOZE IN TT - USED BY NON-DEC-10 FASLAP
	MOVEI R,0
	TLZ TT,740000
REPEAT LOG2LL5,[
	CAML TT,LAPFIV+<1←<LOG2LL5-.RPCNT-1>>(R)
	 ADDI R,1←<LOG2LL5-.RPCNT-1>
]		;END OF REPEAT LOG2LL5
	CAME TT,LAPFIV(R)	;IF DDTSYM REQUEST IS FOR A GLOBAL SYM
	 JRST GDDTS2		;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)
	JRST FIX1
GDDTS2:	MOVEI TT+1,R70
	CAMN D,[SQUOZE 0,R70]
	 JRST FIX1
IT$	MOVE D,TT		;SAVE SQUOZE OVER CALL TO SIDDTP
IT$	JSP T,SIDDTP		;LOSE IF NO DDT FROM WHICH TO GET SYMBOL
10$	SKIPN .JBSYM"		;LOSE IF NO JOB SYMBOL TABLE
	 JRST FALSE
IT$	MOVE TT,D
IT$	.BREAK 12,[4,,TT]
IT$	JUMPE TT,FALSE
IT$	MOVE TT,TT+1
10$	PUSHJ P,GETDD0
10$	JRST FALSE
	JRST FIX1
]		;END OF IFN ITS+D10

20$	WARN [DEC20 GETDDTSYM?]

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	MULTIPLEXOR I/O FUNCTIONS

IFN MOBIOF,[
MPX:	JUMPE A,MPX1	;FIRST ARG FOR IMXC
	SOJE A,CIMX	;SECOND FOR OMXC
	SOSE A		;	NIL - DO NOTHING
	MOVSI A,4	;		0 - CLOSE CHANNEL
	HRRI A,(SIXBIT \IMX\)	;	1 - OPEN IN NORMAL MODE
	TSOPEN IMXC,A	;		2 - OPEN IN FAST MODE (ASCII)
	AOS IMXOPD
MPX1:	JUMPE B,TRUE
	SOJE B,COMX
	SOSE B
	MOVEI B,4
	HRLZI B,1(B)
	HRRI B,(SIXBIT \OMX\)
	TSOPEN OMXC,B
	AOS OMXOPD
	JRST TRUE

CIMX:	.CLOSE IMXC,
	SETZM IMXOPD
	JRST MPX1
COMX:	.CLOSE OMXC,
	SETZM OMXOPD
	JRST TRUE

OMPX:	SKIPN OMXOPD
	LERR [SIXBIT \OMX NOT OPENED!\]
	JSP T,FXNV1
	DPB TT,[360600,,R]
	JSP T,FXNV2
	DPB D,[221400,,R]
	.IOT OMXC,R
	POPJ P,

IMPX:	SKIPN IMXOPD
	LERR [SIXBIT \IMX NOT OPENED!\]
	JSP T,FXNV1
	.IOT IMXC,TT
	JRST FIX1

	OPNGEN IMX,0
	OPNGEN OMX,1
]		;END OF IFN MOBIOF


IFN USELESS,[

SUBTTL	PURIFICATION RITES

$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
.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,FPURF2
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

FPURF3:	JSP R,IP0
	POPJ P,

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

IP0:				;PURIFY/DEPURIFY SOME PAGES
IFN D10, JRST (R)
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
]		;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
]		;END OF IFN D20
IT$	IMULI TT,1001
IT$	TRO TT,400000		;SET UP ARG FOR .CBLK
20$	MOVSI 1,.FHSLF
20$	HRRI 1,(TT)
20$	MOVE 2,1
20$	MOVSI 3,(PM%RD+PM%EX)
	SKIPN C
IT$	 TLOA TT,400
20$	 TLOA 3,(PM%CPY)
IT$	  SKIPA C,R70+2		;IN PURTBL, 1=IMPURE, 2=PURE
20$	  SKIPA F,R70+2
IT$	   MOVEI C,1
20$	   MOVEI F,1
IP7:
IT$	.CBLK TT,		;HACK PAGE
IT$	 JSP F,IP1		;IP1 HANDLES LOSSES
IT$	ADDI TT,1001
20$	PMAP
20$	ADDI 1,1
20$	ADDI 2,1
	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
IFE QIO,[
IFN D10,[
	PUSHJ P,SIXJBN
	MOVE TT,D10NAM
	MOVEM TT,UFN1
	MOVSI TT,(SIXBIT \TMP\)
	MOVEM TT,UFN2
]		;END OF IFN D10
IFE D10,[
	MOVSI TT,(SIXBIT \@\)
	MOVEM TT,UFN1
	MOVEM TT,UFN2
	MOVE TT,[[STTYW1 ? STTYW2],,STTYS1]
	BLT TT,STTYS2
]		;END OF IFE