;;;   -*-MIDAS-*-
;;;   **************************************************************
;;;   ***** MACLISP ****** LISP INTERPRETER AND SYSTEM *************
;;;   **************************************************************
;;;   ** (C) COPYRIGHT 1981 MASSACHUSETTS INSTITUTE OF TECHNOLOGY **
;;;   ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) *******
;;;   **************************************************************

IFE .OSMIDAS-SIXBIT \TWENEX\,.SYMTAB 17393. 	;2001.st prime	 
.ELSE 			     .SYMTAB 16001. 	;1863.rd prime

TITLE ***** MACLISP ****** LISP INTERPRETER AND SYSTEM *************

.NSTGWD			;NO STORAGE WORDS PLEASE UNTIL FIRSTLOC
.XCREF A,B,C,AR1,AR2A,T,TT,D,R,F,P,FXP,%
.MLLIT==1


SUBTTL	ASSEMBLY PARAMETERS

IF1,[		;***** CONDITIONAL ASSEMBLY FLAGS AND PARAMETERS *****

;" FOR ASSLIS - DO NOT PUT ANY OTHER DOUBLE QUOTES ON THIS PAGE

ITS==0		;1 FOR RUNNING UNDER THE ITS MONITOR
TOPS10==0	;1 FOR RUNNING UNDER DEC TOPS-10 MONITOR
TOPS20==0	;1 FOR RUNNING UNDER DEC TOPS-20 MONITOR
SAIL==0		;1 FOR RUNNING UNDER SAIL MONITOR
TENEX==0	;1 FOR RUNNING UNDER THE TENEX MONITOR
CMU==0		;1 FOR RUNNING UNDER THE CMU MONITOR
;LATER WE WILL DEFINE  D10==TOPS10\SAIL\CMU  AND  D20==TENEX\TOPS20

ML==1		;0 SAYS THIS LISP IS FOR THE OLD AI KA (ONLY IF ITS==1)
BIGNUM==1	;MULTIPLE PRECISION ROUTINES FLAG
OBTSIZ==777	;LENGTH OF OBLIST
PTCSIZ==20.	;MINIMUM SIZE FOR PATCH AREA
NEWRD==0	;NEW READER FORMAT ETC
JOBQIO==1	;SUPPORT FOR INFERIOR PROCEDURES
HNKLOG==9	;LOG2 OF SIZE (IN WORDS) OF LARGEST HUNK (0 => NO HUNKS)
PDLBUG==SAIL	;PROCESSOR/OPSYS HAS PROBLEMS WITH PDL OVERFLOWS
SFA==1		;1 FOR SFA I/O
NIOBFS==1	;NUMBER OF I/O BUFFERS FOR D10 SYSTEMS
USELESS==1	;NOT PARTICULARLY IMPORTANT FEATURES, LIKE:
		;  1) ROMAN NUMERAL READER AND PRINTER
		;  2) PRINLEVEL AND PRINLENGTH
		;  3) DOUBLE-PRECISION INPUT OF SINGLE-PRECISION FLONUMS
		;  4) CURSORPOS
		;  5) GCD
		;  6) DUMPARRAYS, LOADARRAYS [AUTOLOADED IN NEWIO]
		;  7) RECLAIM, AND RETSP FEATURE WHICH RETURNS BPS CORE TO TS SYSTEM
		;  8) PURIFY, AND PURE-INITIAL-READ-TABLE
		;  9) CLI INTERRUPT SUPPORT
		; 10) MAR-BREAK SUPPORT
		; 11) AUTOLOAD PROPERTIES FOR ALLFILES ETC.
		; 13) CLEVER TERPRI-BEFORE-THE-PARENS HACK
		; 14) HUGE TABLE FOR RANDOM NUMBER GENERATOR
		; 15) Exchange A and CONSed hunk

DBFLAG==0	;1 FOR DOUBLE-PRECISION FLOATING-POINT NUMBERS
CXFLAG==0	;1 FOR COMPLEX ARITHMETIC
;; IF EITHER THE DBFLAG OR CXFLAG ARE SET, THE THE FLAGS KA, KI, AND KL MUST BE
;;   SET.  OR ELSE, MAYBE, GO THRU AND REMOVE THEIR USAGE.  JONL - 10/16/80

NARITH==0	;1 FOR NEW ARITHMETIC PACKAGE

;" FOR ASSLIS - DOUBLE QUOTES ARE OKAY NOW

;;;	IF1

SUBTTL	STORAGE LAYOUTS

;;; STORAGE LAYOUT FOR ITS
;;;
;;; BZERSG	0 - -   LOW PAGES
;;;			ACCUMULATORS, TEMPORARY VARIABLES,
;;;			INITIAL READTABLE AND OBARRAY
;;; BSTSG	ST: - - SEGMENT TABLES
;;; BSYSSG	FIRSTL: INITIAL SYSTEM CODE (PURE)
;;; BSARSG		INITIAL SAR SPACE
;;; BVCSG		INITIAL VALUE CELL SPACE
;;; BXVCSG		[EXTRA VALUE-CELL SEGMENTS - - POSSIBLY NONE]
;;; BIS2SG		SYMBOL-BLOCKS
;;; BSYMSG		SYMBOL-HEADERS
;;; BSY2SG		**SYMBOL-BLOCKS
;;; BPFXSG		**FIXNUMS
;;; BPFSSG		**LIST-STRUCTURE
;;; BPFLSG		[**FLONUMS - - POSSIBLY NONE]
;;; BIFSSG		LIST-STRUCTURE
;;; BIFXSG		FIXNUMS
;;; BIFLSG		FLONUMS
;;; BBNSG		BIGNUMS
;;; BBITSG		BIT BLOCKS FOR GC
;;; BBPSSG		START OF BINARY PROGRAM SPACE
;;;	C(BPSL)		(ALLOC IS IN THIS AREA)
;;; 	V(BPORG)	START OF BPS UNUSED FOR PROGRAMS
;;; 	V(BPEND)	ARRAYS START NO LOWER THAN THIS
;;; 	C(BPSH)		LAST WORD OF BPS
;;;	... BINARY PROGRAM SPACE GROWS UPWARD ...
;;; C(HINXM)	LAST WORD OF GROSS HOLE IN MEMORY
;;;	... LIST STRUCTURE GROWS DOWNWARD ...
;;; PUSHDOWN LISTS WITH HOLES BETWEEN:
;;;	FXP, FLP, P, SP
;;;
;;; C(NPDLL)	LOW WORD OF NUMBER PDL (LOW OF FXP)
;;; C(NPDLH)	HIGH WORD OF NUMBER PDL + 1 (HIGH+1 OF FLP)
;;;


;;; STORAGE LAYOUT FOR DEC10
;;;
;;; ***** LOW SEGMENT *****
;;; BZERSG	0 - -   LOW PAGES
;;;			ACCUMULATORS, TEMPORARY VARIABLES,
;;;			INITIAL READTABLE AND OBARRAY
;;; BSTSG	ST: - - SEGMENT TABLES
;;; BSARSG		INITIAL SAR SPACE
;;; BVCSG		INITIAL VALUE CELL SPACE
;;; BXVCSG		[EXTRA VALUE-CELL SEGMENTS - - POSSIBLY NONE]
;;; BIS2SG		SYMBOL-BLOCKS
;;; BSYMSG		SYMBOL-HEADERS
;;; BIFSSG		LIST-STRUCTURE
;;; BIFXSG		FIXNUMS
;;; BIFLSG		FLONUMS
;;; BBNSG		BIGNUMS
;;; BBITSG		BIT BLOCKS FOR GC
;;; PUSHDOWN LISTS:
;;;	FXP, FLP, P, SP
;;; C(NPDLL)	LOW WORD OF NUMBER PDL (LOW OF FXP)
;;; C(NPDLH)	HIGH WORD OF NUMBER PDL + 1 (HIGH+1 OF FLP)
;;; BBPSSG	START OF BINARY PROGRAM SPACE
;;;		(ALLOC IS IN THIS AREA)
;;; V(BPORG)	START OF BPS UNUSED FOR PROGRAMS
;;; V(BPEND)	ARRAYS START NO LOWER THAN THIS
;;; C(BPSH)	LAST WORD OF BPS (FIXED, SET BY ALLOC)
;;; C(HIXM)	HIGH WORD OF EXISTING MEMORY
;;; C(MAXNXM)	HIGHEST WORD OF NXM THAT MAY BE USED
;;;
;;; ***** HIGH SEGMENT *****
;;; BSYSSG	INITIAL SYSTEM CODE (PURE)
;;; BSY2SG		**SYMBOL-BLOCKS
;;; BPFXSG		**FIXNUMS
;;; BPFSSG		**LIST-STRUCTURE
;;; BPFLSG		[**FLONUMS - - POSSIBLY NONE]
;;; BPFSSG	INITIAL PURE LIST STRUCTURE

;;;	IF1

SUBTTL	VARIOUS PARAMETER CALCULATIONS


IFE <.OSMIDAS-<SIXBIT /SAIL/>>, OSD10P==1
IFE <.OSMIDAS-<SIXBIT /CMU/>>, OSD10P==1
IFE <.OSMIDAS-<SIXBIT /TOPS10/>>, OSD10P==1
IFNDEF OSD10P, OSD10P==0

;;; HACK FLAGS AND PARAMETERS

DEFINE ZZZZZZ X,SYM,VAL
IFSE [X]-, PRINTX \* \
.ELSE	PRINTX \  \
PRINTX \SYM=VAL
\
TERMIN

PRINTX \ASSEMBLING MACLISP -- INITIAL SWITCH VALUES (*=EXPERIMENTAL):
\

;X=- => EXPERIMENTAL SWITCH
IRPS S,X,[ITS,TOPS10,TOPS20,SAIL,TENEX-CMU-
ML,BIGNUM,OBTSIZ,JOBQIO,HNKLOG,USELESS,
PDLBUG,DBFLAG-CXFLAG-NARITH-SFA-]
ZZZZZZ [X]S,\S
TERMIN
EXPUNGE ZZZZZZ

PRINTC \REDEFINITIONS:
\
.INSRT TTY:
PRINTC \
\

IFNDEF HSGORG,HSGORG==400000

IFN SAIL,[PDLBUG==1]	;SET PDLBUG FLAG
;;; ALL FLAGS WHICH ARE NON-ZERO MUST BE ONES: MUCH CONDITIONAL
;;; ASSEMBLY DOES ARITHMETIC WITH THEM.

IRP FOO,,[ITS,TOPS10,TOPS20,SAIL,TENEX,CMU
ML,BIGNUM,NEWRD,JOBQIO,USELESS
DBFLAG,CXFLAG,NARITH,SFA]
IFN FOO, FOO==:1
.ELSE	 FOO==:0
TERMIN			;USE OF ==: PREVENTS CHANGING THEM RANDOMLY

;;; CHECK MUTUALLY EXCLUSIVE FLAGS OF WHICH ONE MUST BE SET

DEFINE MUTXOR FLAGS,DEFAULT
ZZZ==0
IRP X,Y,[FLAGS]
ZZZ==ZZZ+X
IRP Z,,[Y]
IFN X*Z, .FATAL BOTH X AND Z SPECIFIED AMONG {FLAGS}
TERMIN
TERMIN
IFE ZZZ,[
PRINTX \NONE OF {FLAGS} SPECIFIED - ASSUMING DEFAULT==:1
\
EXPUNGE DEFAULT
DEFAULT==:1
]		;END OF IFE ZZZ

EXPUNGE ZZZ
TERMIN

ZZZ==
IRP OS,,[ITS,DEC,TWENEX,SAIL,TENEX,CMU]FLAG,,[ITS,TOPS10,TOPS20,SAIL,TENEX,CMU]
IFN FLAG,ZZZ==1
IFE .OSMIDAS-<SIXBIT \OS\>, MUTXOR [ITS,TOPS10,TOPS20,SAIL,TENEX,CMU]FLAG
TERMIN

IFSE ZZZ,,[
IRP OS,,[ITS,DEC,TWENEX,SAIL,TENEX,CMU]FLAG,,[ITS,TOPS10,TOPS20,SAIL,TENEX,CMU]
IFE .OSMIDAS-<SIXBIT \OS\>, FLAG==:1
TERMIN
]


;;;	IF1


D10==:TOPS10\SAIL\CMU		;SWITCH FOR DEC-10-LIKE SYSTEMS
D20==:TOPS20\TENEX		;SWITCH FOR DEC-20-LIKE SYSTEMS
IFNDEF PAGING, PAGING==:D20\ITS		;SWITCH FOR PAGING SYSTEMS
IFNDEF HISEGMENT, HISEGMENT==:D10*<1-PAGING>	;ASSUME HISEGMENT FOR DEC-10
;;; INSIST FORCIBLY ALTERS A PARAMETER IF NECESSARY.

DEFINE INSIST COND,SET
COND,[
IRPS X,,[SET]
ZZZ==X
EXPUNGE X
SET
IFN X-ZZZ,[
PRINTX \	COND =>SET
\
]
EXPUNGE ZZZ
.ISTOP
TERMIN
]		;END OF COND
TERMIN

;;; CANONICALIZE BITS


INSIST IFE ITS, JOBQIO==:0
INSIST IFG SAIL*<6-NIOBFS>, NIOBFS==:6


SEGLOG==:11	;LOG2 OF # OF WORDS PER SEGMENT (WARNING! BUILT INTO NCOMPLR!)
INSIST IFG HNKLOG-SEGLOG, HNKLOG==:SEGLOG-1

OBTSIZ==:OBTSIZ\1		;MUST BE ODD
DXFLAG==:DBFLAG*CXFLAG



IFE .OSMIDAS-<SIXBIT \ITS\>,[
DEFINE $INSRT $%$%$%
	.INSRT $%$%$% >
	PRINTX \    ==> INSERTED:  \
	.TYO6 .IFNM1
	PRINTX \ \
	.TYO6 .IFNM2
PRINTX \
\
TERMIN
]		;END OF IFE .OSMIDAS-<SIXBIT \ITS\>,
.ELSE,[
DEFINE $INSRT $%$%$%
	.INSRT $%$%$%!.MID
	PRINTX \INSERTED:  \
	.TYO6 .IFNM1
	PRINTX \.\
	.TYO6 .IFNM2
PRINTX \
\
TERMIN
]		;END OF .ELSE




COMMENT |	MAKE @ PROGRAM UNDERSTAND POTENTIAL FILE INSERTIONS
	;TABS IN FRONT OF $INSRT'S ARE NECESSARY TO FAKE OUT UNIFY PROGRAM
	$INSRT ITSDFS
	$INSRT DECDFS
	$INSRT TNXDFS
	$INSRT SAIDFS
	$INSRT ITSBTS
	$INSRT DECBTS
	$INSRT TWXBTS
|		;END OF COMMENT


IFE OSD10P,[
DEFINE A67IFY A,B,C
A=SIXBIT \C\
B=C
TERMIN	
RADIX 10.
ZZ==.FVERS
 ;; Remember, somday cross over to 3000.
IFE .OSMIDAS-<SIXBIT \ITS\>, ZZ==2000.+ZZ
A67IFY LVRNO,LVRNON,\ZZ
RADIX 8
]	;END OF IFE OSD10P

IFN OSD10P,[
IFNDEF LVRNO,LVRNO=.FNAM2
IFE LVRNO-SIXBIT \MID\,[
PRINTX /What is LISP's version number (type four octal digits) ?/
.TTYMAC VRS
LVRNO=SIXBIT \VRS\
LVRNON=VRS
TERMIN
]
.ELSE,[
LVRNO==<LVRNO_-6>+<SIXBIT \1\>			;HACK FOR CROSSING 1000'S
IFN <<LVRNO_-30>&77>-'9, LVRNO==LVRNO+<1_36>	;HACK FOR CROSSING 2000'S
;;; REMEMBER! SOMEDAY WE MAY HAVE TO CROSS TO 3000'S  - JONL, 9 JUL 1980
LVRNO==0
]		;END OF IFGE LVRNO
]	;END OF IFN OSD10P


PRINTX \MACLISP VERSION \	;PRINT OUT VERSION OF THIS LISP
.TYO6 LVRNO
PRINTX \ ASSEMBLED ON \
.TYO6 .OSMIDAS
PRINTX \ AT \
IFE <.SITE 0>, PRINTX \UNKNOWN SITE\
.ELSE REPEAT 20, IFE <.SITE .RPCNT>,[.ISTOP] .TYO6 <.SITE .RPCNT>
PRINTX \
\				;TERPRI TO FINISH VERSION MESSAGE





;;;	IF1

;;; MAKE SURE THE SYMBOLS WE WILL NEED ARE DEFINED.
;;; THEY MAY NOT BE IF ASSEMBLING FOR A DIFFERENT OPERATING SYSTEM

DEFINE FLUSHER DEF/
IRPS SYM,,[DEF]
EXPUNGE SYM
.ISTOP
TERMIN
TERMIN

DEFINE SYMFLS TARGETSYS,OS,.DEFS.,DEFFER,CHKSYM,.BITS.,CHKBIT
IFE <.OSMIDAS-SIXBIT\OS\>,[
IFE TARGETSYS,[
PRINTX \FLUSHING OS SYMBOL DEFINITIONS
\
	$INSRT .DEFS.
	DEFFER FLUSHER
IFSN .BITS.,,[
PRINTX \FLUSHING OS BIT DEFINITIONS
\
	EQUALS DEFSYM,FLUSHER
	$INSRT .BITS.
	EXPUNGE DEFSYM
]		;END OF IFSN .BITS.
]		;END OF IFE TARGETSYS
]		;END OF IFE <.OSMIDAS-SIXBIT\OS\>
TERMIN

DEFINE SYMDEF TARGETSYS,OS,.DEFS.,DEFFER,CHKSYM,.BITS.,CHKBIT
IFN TARGETSYS,[
IFN <.OSMIDAS-SIXBIT\OS\>,[
PRINTX \MAKING OS SYMBOL DEFINITIONS
\
	$INSRT .DEFS.
	DEFFER
IFSN .BITS.,,[
PRINTX \MAKING OS BIT DEFINITIONS
\
	$INSRT .BITS.
]		;END OF IFSN .BITS.,,
]		;END OF IFN <.OSMIDAS-SIXBIT\OS\>
.ELSE,[
IFNDEF CHKSYM,[
PRINTX \FUNNY - RUNNING ON OS, BUT CHKSYM UNDEFINED; MAKING OS SYMBOL DEFINITIONS
\
	$INSRT .DEFS.
	DEFFER
]		;END OF IFNDEF CHKSYM
IFSN .BITS.,,[
IFNDEF CHKBIT,[
PRINTX \FUNNY - RUNNING ON OS, BUT CHKBIT UNDEFINED; MAKING OS BIT DEFINITIONS
\
	$INSRT .BITS.
]		;END OF IFNDEF CHKBIT
]		;END OF IFSN .BITS.,,
]		;END OF .ELSE
]		;END OF IFN TARGETSYS
TERMIN


;;;	IF1

IFN D20, EXPUNGE RESET

IRP HACK,,[SYMFLS,SYMDEF]
	HACK ITS,ITS,ITSDFS,.ITSDF,.IOT,ITSBTS,%PIC.Z
	HACK TOPS10,DEC,DECDFS,.DECDF,LOOKUP,DECBTS,.GTSTS
	HACK TOPS20,TENEX,TNXDFS,.TNXDF,JSYS,TWXBTS,GJ%FOU
	HACK TENEX,TENEX,TNXDFS,.TNXDF,JSYS,TWXBTS,GJ%FOU
	HACK SAIL,SAIL,SAIDFS,.DECDF,SPCWAR,DECBTS,.GTSTS
TERMIN

;;; CONFLICTS WITH UNLOCKI MACRO AND SEGSIZ VARIABLE
IFN D10,[
IFE SAIL,[
IFN <.OSMIDAS-SIXBIT\CMU\>,[
    ;THE FOLLOWING ARE THE SPECIAL CMU UUOs:
    DEFINE .CMUCL DEF
    DEF SRUN=:47000777756
    DEF USRDEF=:47000777757
    DEF JENAPX=:47000777760
    DEF IMPUUO=:47000777761
    DEF PRIOR=:47000777762
    DEF LNKRDY=:47000777763
    DEF INT11=:47000777764
    DEF RSTUUO=:47000777765
    DEF UNTIME=:47000777766
    DEF TIME=:47000777767
    DEF STOP=:47000777770
    DEF UNLOCK=:47000777771
    DEF JENAPR=:47000777772
    DEF MSGPOL=:47000777773
    DEF MSGSND=:47000777774
    DEF DECCMU=:47000777775
    DEF CMUDEC=:47000777776
TERMIN 
PRINTX \MAKING CMU-SPECIFIC "CALL" DEFINITIONS
\
	.CMUCL FLUSHER
	.CMUCL
]	;END OF IFN <.OSMIDAS-SIXBIT\CMU\>
]	;END OF IFE SAIL
IFN SAIL, 	EXPUNGE SEGSIZ
		EXPUNGE UNLOCK
]	;END OF IFN D10


IFN D10,[
DEFINE HALT
JRST 4,.!TERMIN

EXPUNGE .VALUE
EQUALS .VALUE HALT

DEFINE .LOSE <A>
JRST 4,.-1!TERMIN

]		;END OF IFN D10


;;; IF1

IFN D20,[

GETTAB==:47_33 41

%TOCID==:1
%TOLID==:2
%TOMVU==:400
%TOMVB==:10000
%TOERS==:40000
%TOOVR==:0

DEFINE HALT
HALTF!TERMIN

EXPUNGE .VALUE
EQUALS .VALUE HALTF

DEFINE .LOSE <A>
HALTF!TERMIN

]		;END OF IFN D20	


;;; CALL IS A DEC UUO, BUT WE USE THAT NAME FOR A LISP UUO
EXPUNGE CALL

;;; DON'T HACK THIS $INSRT - UNIFY DEPENDS ON IT
$INSRT FASDFS		;STANDARD AC, UUO, AND MACRO DEFINITIONS


;;; DON'T HACK THIS $INSRT - UNIFY DEPENDS ON IT
$INSRT MACS		;LOTSA MOBY MACROS


SA% LRCT==:NASCII+10	;SPACE SUFFICIENT FOR CHARS AND SWITCHES
SA$ LRCT==:1010
10$ LIOBUF==:200		;LENGTH OF STANDARD VANILLA I/O BUFFER


LONUM==400	;MINIMUM MAGNITUDE OF LOWEST NEGATIVE INUM
HINUM==1000	;MINIMUM MAGNITUDE OF LARGEST POSITIVE INUM
		;SOME CODE ASSUMES HINUM IS AT LEAST 777
		;MUCH CODE ASSUMES HINUM IS AT LEAST 177 (FOR ASCII CHARS)


IFN ITS, PAGLOG==:12		;LOG2 OF PAGE SIZE
				; (DAMN WELL BETTER BE 12 FOR ITS!!!
IFN D10, PAGLOG==:11		; SOME CODE ASSUMES IT WILL BE 11 OR 12)
IFN D20, PAGLOG==:11

IFE D10*PAGING, MEMORY==:<1,,0>	;SIZE OF MEMORY!!!
IFN D10*PAGING, MEMORY==:776000	;ON D10 SYSTEMS, CAN'T USE ALL OF MEMORY
PAGSIZ==:1_PAGLOG		;PAGE SIZE
PAGMSK==:<777777_PAGLOG>&777777	;MASKS ADDRESSES TO PAGE BOUNDARY
PAGKSM==:PAGMSK#777777		;MASKS WORD ADDRESS WITHIN PAGE
NPAGS==:MEMORY/PAGSIZ		;NUMBER OF PAGES IN MEMORY

NNUMTP==:2+BIGNUM+DBFLAG+CXFLAG+DBFLAG*CXFLAG	;NUMBER OF NUMBER TYPES
NTYPES==:3+HNKLOG+1+NNUMTP+1	;NUMBER OF DATA TYPES, COUNTING RANDOM


;;;	IF1

SEGSIZ==:1_SEGLOG		;SEGMENT SIZE
SEGMSK==:<777777_SEGLOG>&777777	;MASKS ADDRESSES TO SEGMENT BOUNDARY
SEGKSM==:SEGMSK#777777		;MASKS WORD ADDRESS WITHIN SEGMENT
NSEGS==:MEMORY/SEGSIZ		;NUMBER OF SEGMENTS IN MEMORY
BTBSIZ==:SEGSIZ/40		;SIZE OF BIT BLOCKS
				;(ENOUGH BITS FOR A SEGMENT, 40 PER WORD)
SGS%PG==:NSEGS/NPAGS		;NUMBER OF SEGMENTS PER PAGE

BTSGGS==1			;GUESS AT THE NUMBER OF INITIAL BIT SEGMENTS

IFN PAGING,[
ALPDL==4096.			;DEFAULT TOTAL PDL SIZES
ALFXP==2048.
ALFLP==1*PAGSIZ
ALSPDL==2048.
]		;END OF IFN ITS+D20
IFE PAGING,[
ALFXP==SEGSIZ		;DEFAULT TOTAL PDL SIZES
ALFLP==SEGSIZ
ALPDL==3000
ALSPDL==1400
]		;END OF IFN D10


;;; GROSSLY DETERMINE MIN AND MAX PARAMETERS FOR EACH SPACE AND PDL


FUMBLE FFS,,[[1,[0.25,40000]]]
FUMBLE FFX,,[[PAGING,[0.2,14000]],[PAGING-1,[0.25,3000]]]
FUMBLE FFL,,[[PAGING,[0.15,2*SEGSIZ]],[PAGING-1,[0.25,SEGSIZ]]]
FUMBLE FFD,IFN DBFLAG,[[1,[0,SEGSIZ]]]
FUMBLE FFC,IFN CXFLAG,[[1,[0,SEGSIZ]]]
FUMBLE FFZ,IFN DXFLAG,[[1,[0,SEGSIZ]]]
FUMBLE FFB,IFN BIGNUM,[[PAGING,[3*SEGSIZ/4,2*SEGSIZ]],[PAGING-1,[0.2,SEGSIZ]]]
FUMBLE FFY,,[[PAGING,[SEGSIZ/2,6000]],[PAGING-1,[SEGSIZ/2,3*SEGSIZ]]]
FUMBLE FFH,IFN HNKLOG,[[1,[0,2*SEGSIZ]]]
FUMBLE FFA,,[[1,[40,SEGSIZ]]]
GRUMBLE PDL,,[[1,[200,1400]]]
GRUMBLE SPDL,,[[1,[100,1400]]]
GRUMBLE FXP,,[[1,[200,1000]]]
GRUMBLE FLP,,[[1,[20,200]]]

;;;	IF1


;;; ********** INTERRUPT BITS **********

IFN ITS,[

;;; THESE NAMES SHOULD BE PHASED OUT IN FAVOR OF THE ITS-STANDARD %PI SERIES.

;;; LISP SETS ITS INTERRUPT MASK (.MASK USET VARIABLE) ONLY FROM
;;; THE CONTENTS OF LOCATION IMASK, WHICH INITIALLY CONTAINS STDMSK.
;;; DEPOSITING DBGMSK THERE BEFORE STARTUP DISABLES ALL INTERRUPTS
;;; EXCEPT TTY AND PDL OVERFLOW, SO THAT DDT WILL TRAP ILOP, MPV, ETC.

IB.ALARM==200000,,	;  REAL TIME CLOCK (ALARM CLOCK)
IB.TIMER==100000,,	;  RUN TIME CLOCK
IB.PARITY==1000,,	;+ PARITY ERROR
IB.FLOV==400,,		;  FLOATING OVERFLOW
IB.PURE==200,,		;+ PURE PAGE TRAP (WRITE INTO READ-ONLY)
IB.PCPURE==100,,	;+ PURE INSTRUCTION FETCH FROM IMPURE
IB.SYSUUO==40,,		;+ SYS UUO TRAP
IB.AT3==20,,		;  ARM TIP BREAK 3
IB.AT2==10,,		;  ARM TIP BREAK 2
IB.AT1==4,,		;  ARM TIP BREAK 1
IB.DEBUG==2,,		;  SYSTEM BEING DEBUGGED
IB.RVIOL==1,,		;+ RESTRICTION VIOLATION (?)
IB.CLI==400000		;  CORE LINK INTERRUPT
IB.PDLOV==200000	;  PDL OVERFLOW
IB.LTPEN==100000	;  LIGHT PEN INTERRUPT
IB.MAR==40000		;+ MAR INTERRUPT
IB.MPV==20000		;+ MEMORY PROTECTION VIOLATION
IB.SCLK==10000		;  SLOW CLOCK TICK (.5 SEC)
IB.1PROC==4000		;* SINGLE INSTRUCTION PROCEED
IB.BREAK==2000		;* .BREAK EXECUTED
IB.ILAD==1000		;+ ILLEGAL USER ADDRESS
IB.IOC==400		;+ I/O CHANNEL ERROR
IB.VALUE==200		;* .VALUE EXECUTED
IB.DOWN==100		;  SYSTEM GOING DOWN OR BEING REVIVED
IB.ILOP==40		;+ ILLEGAL INSTRUCTION OPERATION
IB.DMPV==20		;+ DISPLAY MEMORY PROTECTION VIOLATION
IB.AROV==10		;  ARITHMETIC OVERFLOW
IB.42BAD==4		;* BAD LOCATION 42
IB.C.Z==2		;* ^Z TYPED WHEN THIS JOB HAD TTY
IB.TTY==1		;  INTERRUPT CHAR TYPED ON TTY

]		;END OF IFN ITS
IFN D10,[
IB.PDLOV==AP.POV	;  PDL OVERFLOW
IB.MPV==AP.ILM		;+ MEMORY PROTECTION VIOLATION

SA% STDMSK==AP.REN+AP.POV+AP.ILM+AP.NXM+AP.PAR
SA$ STDMSK==<4404,,230000>
]		;END OF IFN D10

;;; ********** I/O CHANNEL ASSIGNMENTS **********


;;; PAGE 376 IS RESERVED FOR COPYING (SEE IP1), AND 377 FOR DISUSE.
;;; (THE DISUSE AS TO DO WITH AN OLD HARDWARE BUG IN BLT.)
;;; ON AI, PAGE 375 IS FOR MAPPING PAGE 0 OF THE DISPLAY SLAVE.

IT$	P6=MEMORY-3*PAGSIZ	;PAGE 0 OF PDP6 SLAVE IS MAPPED INTO PDP-10 MEMORY

]		;END OF IF1


;IFE <ITS+TENEX>*USELESS,	NPGTPS==0
IFE 0,	NPGTPS==0
TOPN==0
BOTN==0
.XCREF TOPN BOTN
	NPURTR==0
	NIOCTR==0
	.XCREF PURTR1 NPURTR NIOCTR

N2DIF==0
NPRO==0+1		;NUMBER OF INTERRUPT PROTECTION REGIONS
			;NOTE DEFN OF PRO0 IN MACS FILE
.XCREF NPRO


IFN D10,[
HS$	.DECTWO HSGORG	;DEC TWO-SEGMENT RELOC OUTPUT
HS%	.DECREL		;ONE SEGMENT ASSEMBLY
IFN PAGING, LOC 140	;FOR PAGING ASSEMBLY NEED ABSOLUTE ADDRESSING
%LOSEG==-1		;INITIALLY START IN LOW SEGMENT
%HISEG==0		;START AT 0 RELATIVE TO HIGH SEG ORIGIN
]		;END OF IFN D10

IFN ITS, IFDEF .SBLK, .SBLK	;EVENTUALLY FLUSH "IFDEF .SBLK"
20$	.DECSAV 		;FOR TOPS-20, JUST GET .EXE FILE
20$	LOC 140			;BUT FORCE ABSOLUTE ADDRESSING
.YSTGWD				;STORAGE WORDS ARE OKAY NOW



FIRSTLOC:

IFN D10,[
HS$ HILOC==.+HSGORG			;HISEG GENERALLY STARTS AT 400000
HS% HILOC==.
;;; FOR DEC-10, FIRSTLOC AS LOADED WITH RELOCATION MUST BE
;;;		STDLO+M*SEGSIZ
;;; AND SIMILARLY HILOC WHEN LOADED MUST BE
;;;		STDHI+N*SEGSIZ
;;; FOR INTEGRAL M AND N.  INIT WILL ENFORCE THIS IN ORDER
;;; TO PRESERVE SEGMENT BOUNDARIES CORRECTLY.
;;; CURSTD IS THE STDXX FOR WHICHEVER IS THE CURRENT SEGMENT.
STDLO==140		;SIZE OF JOB DATA AREA
STDHI==10		;VESTIGIAL JOB DATA AREA
CURSTD==STDLO		.SEE $LOSEG
]		;END OF IFN D10
IFN PAGING,[
STDLO==0
STDHI==0
CURSTD==0
]		;END OF IFN PAGING

IFN PAGING, BZERSG==0		;BEGINNING OF "ZERO" SEGMENT(S)
IFE PAGING, BZERSG==FIRSTLOC-STDLO



SUBTTL	FIRST LOCATIONS (41, GOINIT, LISPGO); UUO AND INTERRUPT VECTORS

LOC 41
	JSR UUOH		;UUO HANDLER
10X	WARN [TENEX INTERRUPT VECTOR?]

LOC FIRSTLOC
GOINIT:
IFN ITS,[
	.SUSET [.S40ADDR,,[TWENTY,,FORTY]]	;SET .40ADDR
IFN USELESS,[
	MOVEI T,IB<MAR>		;RESET THE MAR BREAK FEATURE
	ANDCAM T,IMASK
	.SUSET [.SAMASK,,T]
	.SUSET [.SMARA,,R70]
]		;END OF IFN USELESS
]		;END OF IFN ITS
	JSR STINIT
GOINI7:	SETZB A,VERRLI		;NULLIFY ERRLIST
	PUSHJ P,INTERN
	JUMPE A,LISPGO
	PUSHJ P,REMOB2		;GET STANDARD COPY OF NIL ON OBLIST
	JRST GOINI7

STINIT:	0			;COME HERE BY JSR
	MOVEI A,READTABLE	;INITIALIZATIONS AT START-UP TIME
	MOVEM A,VREADTABLE
	MOVE A,[RCT0,,RCT]
	BLT A,RCT+LRCT-1	;RESTORE READ CHARACTER SYNTAX TABLE
	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
	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
IFN SAIL,[
	MOVE P,C2
	MOVE FXP,FXC2
]	;END OF IFN SAIL
IFN ITS,[
	MOVE TT,[4400,,400000+<<PDLORG_-PAGLOG>_11>]
	.CBLK TT,
	.VALUE
	MOVE TT,[4400,,400000+<<SPDLORG_-PAGLOG>_11>]
	.CBLK TT,
	.VALUE
	MOVE TT,[4400,,400000+<<FXPORG_-PAGLOG>_11>]
	.CBLK TT,
	.VALUE
	MOVE TT,[4400,,400000+<<FLPORG_-PAGLOG>_11>]
	.CBLK TT,
	.VALUE
]		;END OF IFN ITS
IFN D20,[
;; DECIDE BETWEEN TENEX AND TOPS20 AND SET PAGE ACCESSIBILITYS
	JSP R,TNXSET
	SKIPN TENEXP
	 SKIPN VTS20P
	  JRST .+7
	MOVEI 1,.PRIIN
	RTMOD 
	IOR 2,[STDTMW]		;CURRENTLY FORCES DISPLAY MODE, WRAP-AROUND
	MOVEM 2,TTYIF2+TI.ST6
	MOVEM 2,TTYOF2+TI.ST6
	STMOD
]	;END OF IFN D20
IFN D10*<1-SAIL>, JSP T,D10SET
	PISTOP
	JSP A,ERINIX
	JRST 2,@STINIT

;;; HERE IF NOT STOPPING AFTER A SUSPEND
SUSCON:	MOVEI A,TRUTH		;RETURN T RATHER THAN NIL
	MOVEM A,-1(FLP)
	;;; FALL INTO LISPGO

IFN SAIL*PAGING,[
	JRST LISPGO		;INTENSE CROCK FOR E/MACLISP INTERFACE!
	JSP 10,E.START
]	;END OF IFN SAIL*PAGING

LISPGO:	
IFN SAIL*PAGING,[
	SETZM VECALLEDP
]	;END OF IFN SAIL*PAGING
	SETOM AFILRD		;START HERE ON G'ING
IT$	.SUSET GOL1		;SET .40ADDR
IT$	.SUSET GOL2		;GET INITIAL SNAME
	JRST 2,@LISPSW		;ZEROS OUT PC FLAGS, AND TRANSFERS TO LISP

IT$ GOL2:	.RSNAM,,IUSN 	;KEEP THESE ON SAME PHYSICAL PAGE
IT$ GOL1: 	.S40ADDR,,.+1
IT$ 		TWENTY,,FORTY		


LISPSW:	%ALLOC		;ALLOC CLOBBERS TO BE "LISP"
SUSFLS:	TRUTH		;NON-NIL MEANS FLUSH SHARABLE PAGES BEFORE SUSPENDING
KA10P:	0		;NON-ZERO ==> KA PROCESSOR (AS OPPOSED TO KL OR KI)



IFN ITS,[
TWENTY==:20		;VARIOUS PLACES OFFSET FROM TWENTY ARE USED BY DDT
THIRTY==:TWENTY+10	;RECALL THAT THE LEFT HALF OF .40ADDR IS THE ".20ADDR"
;;;	ADDRESSES IN THE 20 BLOCK, SWIPED FROM DDT ORDER
;;;	25	HOLDS "." DURING A USER TYPEOUT INSTRUCTION
;;;	26	CONDITIONAL BREAKPOINT INSTRUCTION
;;;	27-30	.BREAK 16,'S FOR RETURNING FROM 26
;;;	31	INSTRUCTION FOR BREAKPOINT WHICH DIDN'T BREAK
;;;	32-33	JRST'S TO PROGRAM FROM 31, OR DATA FOR INSTRUCTION IN 31
;;;	34	INSTRUCTION BEING X'D
.SEE MEMERR
.SEE UUOGL2
;;;	35-36	.BREAK 16,'S FOR RETURNING FROM 34
.SEE $XLOST
.SEE UUOGL2
;;;	37	HOLDS Q DURING A USER TYPEOUT INSTRUCTION
.SEE PSYM1


FORTY:	0			;.40ADDR USER VARIABLE POINTS HERE
	JSR UUOGLEEP		;SYSTEMIC UUO HANDLER
	-LINTVEC,,INTVEC	;SYSTEMIC INTERRUPT HANDLER
	0			; Let the user hack ITS locks if
	0			; he is so adventurous.  -Alan 10/2/83

;;; THAT'S SYSTEMIC, NOT NECESSARILY SYSTEMATIC!!!

;;; ITS PASSES THE BUCK TO THE USER ON UUO'S 0 AND 50-77.
;;; THEY TRAP THROUGH THE .40ADDR, NOT NECESSARILY 40;
;;; SINCE LISP TREATS THESE AS ERRORS, WE CAN AFFORD TO SAVE
;;; THE JPC AND OTHER GOODIES HERE.

UUOGLEEP:	0
	.SUSET [.RJPC,,JPCSAV]
	JRST UUOGL1

]		;END OF IFN ITS
JPCSAV:	0

SUBTTL	SFX HACKERY

;;; SFX MACRO TELLS WHERE A LONG PIECE OF SEMI-CRITICAL (MAY BE QUIT
;;; OUT OF, BUT MUST NOT PERMIT USER INTERRUPTS IN) CODE MAY BE MUNGED
;;; IF INTERRUPTED IN THE MIDDLE SO THAT WHEN DONE IT WILL RETURN TO
;;; THE INTERRUPT HANDLER. SUCH CODE INCLUDES ARRAY SUBSCRIPT
;;; COMPUTATIONS (SINCE AN INTERRUPT COULD DISPLACE THE ARRAY)
;;; AND ALL CODE WHICH MODIFIES THE SPECIAL PDL.

NSFC==0		;COUNTER FOR MACRO SFX
.XCREF NSFC

IFE PAGING,[

DEFINE SFX A/
SFSTO \.-FIRSTLOC,\NSFC,[A]
NSFC==NSFC+1
	A
TERMIN

DEFINE SFSTO PT,NM,IN
DEFINE ZZM!NM
FIRSTLOC+PT
TERMIN
DEFINE ZZN!NM
IN
TERMIN
TERMIN

]		;END OF IFN PAGING


IFN PAGING,[

DEFINE SFX A/
SFSTO \.,\NSFC,[A]
NSFC==NSFC+1
	A
TERMIN

DEFINE SFSTO PT,NM,IN
DEFINE ZZM!NM
PT
TERMIN
DEFINE ZZN!NM
IN
TERMIN
TERMIN

]		;END OF IFN PAGING


;;; THE ZZM AND ZZN MACROS ARE EXPANDED AT SFXTBL (Q.V.)

;;; **** ALL USES OF THE SFX MACRO MUST APPEAR ON THIS PAGE ****

   SFXPRO
10$ UNBD2A:
10$	POP FXP,R		   ;Restore R
UNBND2:	MOVE TT,(SP)
	MOVEM TT,SPSV	;ABOUT LOADING TT WITH SPSV, SEE UNBIND
	MOVE TT,UNBND3
SFX	POPJ P,

ABIND3:	PUSH SP,SPSV
SFX	POPJ P,

SETXIT:	SUB SP,R70+1
SFX	JRST (T)

SPECX:	PUSH SP,SPSV
SFX	JRST (T)


AYNVSFX:			;XCT'ED BY AYNVER
SFX	%WTA (D)

1DIMS:	JSP T,AYNV1		;1-DIM S-EXP ARRAYS COME HERE
ARYGET:	ROT R,-1		;COMMON S-EXP ARRAY ACCESS ROUTINE
	ADDI TT,(R)
ARYGT4:	JUMPL R,ARYGT8
	HLRZ A,(TT)
SFX	POPJ P,

ARYGT8:	HRRZ A,(TT)
SFX	POPJ P,


1DIMF:	JSP T,AYNV1		;1-DIM FULLWORD ARRAYS COME HERE
ANYGET:	ADDI TT,(R)		;COMMON FULLWORD ARRAY ACCESS ROUTINE
	MOVE TT,(TT)
SFX	POPJ P,


IFN DBFLAG+CXFLAG,[
1DIMD:	JSP T,AYNV1		;1-DIM DOUBLEWORD ARRAYS COME HERE
ADYGET:	LSH R,1			;COMMON DOUBLEWORD ARRAY ACCESS ROUTINE
	ADDI TT,(R)
KA	MOVE D,1(TT)
KA	MOVE TT,(TT)
KIKL	DMOVE TT,(TT)
SFX	POPJ P,
]		;END OF IFN DBFLAG+CXFLAG


IFN DXFLAG,[
1DIMZ:	JSP T,AYNV1		;1-DIM FOUR-WORD ARRAYS COME HERE
AZYGET:	LSH R,2			;COMMON FOUR-WORD ARRAY ACCESS ROUTINE
	ADDI TT,(R)
KA	MOVE R,(TT)
KA	MOVE F,1(TT)
KA	MOVE D,3(TT)
KA	MOVE TT,2(TT)
KIKL	DMOVE R,(TT)
KIKL	DMOVE TT,2(TT)
SFX	POPJ P,
]		;END OF IFN DXFLAG

   NOPRO

SPSV:	0	;IMPORTANT TO SPECPDL BINDINGS
			.SEE $IWAIT

;;; **** THERE MUST BE NO MORE USES OF THE MACRO SFX BEYOND HERE ****
EXPUNGE SFX SFSTO

SUBTTL	INTERRUPT FLAGS AND VARIABLES

;;; INTFLG INDICATES WHETHER IN INTERRUPT IS PENDING:
;;;	 0 => NO INTERRUPT
;;;	-1 => USER INTERRUPT PENDING (STACKED IN INTAR)
;;;	-2 => ^X QUIT PENDING, DON'T RESET TTY
;;;	-3 => ^G QUIT PENDING, DON'T RESET TTY
;;;	-6 => ^X QUIT PENDING, DO RESET TTY
;;;	-7 => ^G QUIT PENDING, DO RESET TTY

INTFLG:	0

;;; MAY NOT ^G/^X QUIT OR ALLOW USER INTERRUPTS IF NOQUIT NON-ZERO
;;; NON-ZERO IN LH MEANS GC IN PROGRESS; IMPLIES
;;;	PDL POINTERS AND NIL MAY BE CLOBBERED
;;; NON-ZERO ONLY IN RH MEANS PDL POINTERS AND NIL ARE OK

NOQUIT:	0

;;; MAY NOT ALLOW "REAL TIME" INTERRUPTS (CLOCK AND TTY) WHEN
;;; UNREAL IS NON-ZERO. MUNGED BY THE FUNCTION NOINTERRUPT.
;;;	0 => ALL INTERRUPTS OKAY
;;;	-1 => NO INTERRUPTS OKAY
;;;	'TTY => ALARMCLOCK OKAY, TTY NOT OKAY

UNREAL:	0

REALLY:	0	        ;IF NON-ZERO, THE ADDRESS OF A PDL SLOT FOR THE
			;UNBINDER TO UNBIND A SAVED UNREAL INTO.
			;SO THAT UNWPR1 CAN KEEP UNREAL SET WHILE BINDING IT.

.SEE WIOUNB
.SEE UNWPR1

ERRSVD:	0	.SEE ERRBAD

;;; INTERRUPT MASK IS ALWAYS INITIALIZED FROM THIS WORD.
;;; FOR ITS, THIS IS THE .MASK (AND .MSK2) WORDS.
;;; FOR TOPS10 AND CMU, THIS IS THE APRENB WORD.
;;; FOR D20, THIS IS THE CHANNEL ENABLE WORD
;;; DEPOSITING DBGMSK INTO IT BEFORE STARTUP CAN AID DEBUGGING.
;;; FOR ITS AND D20, IMPURE LISPS WILL HAVE DEBUG MASKS IN THESE
;;; LOCATIONS; THE PURIFY ROUTINE INSTALLS THE STANDARD MASKS.
.SEE PURIFY
.SEE DBGMSK

IFN D10\D20, OIMASK:	0 ;HOLDS OLD INT MASK WHEN INTS ARE DISABLED
10% INTMSK:
IMASK:	STDMSK			;INTERRUPT MASK WORD
IT$ IMASK2:	STDMS2		;ITS HAS TWO INTERRUPT MASKS


LFAKP==5			;MUST BE LONG ENOUGH FOR USES BY
LFAKFXP==6			; PDLOV, ERINIT, AND PURIFY
FAKP:	BLOCK LFAKP		;FAKE REGPDL, FOR USE BY PDLOV AND ERINIT
FAKFXP:	BLOCK LFAKFXP		;FAKE FIXPDL, FOR USE BY PDLOV AND ERINIT

IT$ VALFIX: 0			;-1 --> VALRET 'STRING' IS REALLY A FIXNUM
IT$				.SEE VALSTR

IFN D10,[
CMUP:	0		;CMU MONITOR?
IFE SAIL,[
MONL6P:	0	;6-LEVEL MONITOR OR BETTERP?
]	;END OF IFE SAIL
]	;END OF IFN D10

;;; IF NON-ZERO, THIS CONTAINS THE ADDRESS OF A USER-SUPPLIED
;;; INTERRUPT PROCESSOR.  THE LISP SYSTEM INTERRUPT HANDLER
;;; WILL GIVE IT ANY INTERRUPT LISP DOESN'T PROCESS ITSELF. SEE INT0.

UPIINT:	0

IFN D20,[
;;; TOPS-20 INTERRUPT VARIABLES

;;; FLAGS SETUP BY ALLOC AND SUSPEND
CCOCW1:	CCOC1	;This words may be "remodeled" at allocation time, and at
CCOCW2:	CCOC2	; start-up from suspension, to account for 10X/20X differences
TENEXP:	0	;Also set up as above
VTS20P: 0 	;Non-0 if system has the Virtual Terminal Support

;;; BLOCK OF THREE LOCATIONS IN WHICH THE PC IS STORED ON AN INTERRUPT.
;;; ONE LOCATION FOR EACH OF TOPS-20'S THREE LEVELS
INTPC1:	0
INTPC2:	0
INTPC3:	0

;;; TEMPORARY LOCATIONS USED BY INTERRUPT HANDLERS
PDLSVT:	0	;USED BY $PDLOV TO SAVE AC T WHILE MUNGING THE INTPDL
SUPSAV: 0			;USED BY INTSUP
LV2SVT:	0			;LEVEL 2 PARAMETERS: SAVE T
LV2SVF:	0			;		     SAVE F
LV2ST2:	0			;		     SECOND SAVE T
LV3SVT:	0			;LEVEL 3 PARAMETERS: SAVE T
LV3SVF:	0			;		     SAVE F
LV3ST2:	0			;		     SECOND SAVE T
DSMSAV:	.			;POINTER INTO SMALL STACK USED BY DSMINT
	BLOCK 10		;TO BE SAFE, BUT 4 SHOULD BE MAXIMUM DEPTH
IT% CN.ZX:	0			;WHERE TO EXIT AFTER ^Z

;;; AS TTY INTERRUPT CHANNEL MUST BE DYNAMICALLY ALLOCATED, AND THERE ARE
;;; FEWER CHANNELS THAN THE TOTAL POSSIBLE NUMBER OF INTERRUPT CHARACTERS,
;;; A TABLE IS USED TO STORE THE INFORMATION.  THE TABLE IS 18. WORDS LONG.
;;; A ZERO ENTRY IS UNUSED, NONZERO HAS INTERRUPT CHARACTER.  IF THE TABLE
;;; ENTRY IS NEGATIVE, THEN THE CHANNEL IS ASSIGNED FOR SOME OTHER USE.

;CHANNEL ASSIGNMENTS FOR NON-STANDARD(?) INTERRUPTS

CINTAB:
TICMAP .TIC!CODE
REPEAT 18.-<.-CINTAB>, 0			;INITIALLY UNUSED
CINTSZ==.-CINTAB
]		;END IFN D20	



SUBTTL  DEFINITIONS OF TTY STATUS WORDS

IFN ITS,[
;;; INITIAL TTY STATUS IS AS FOLLOWS:
;;;	ACTIVATION CHARS:
;;;		^@-^L, ^N-^Z, ^\-^_, SPACE, < > ( )  { } RUBOUT  CR
;;;		LBRACKET  RBRACKET
;;;	INTERRUPT CHARS:
;;;		^@-^H, ^K, ^L, ^N-^Z, ^\-^_, SPACE
;;;		^H AND SPACE DO NOT INTERRUPT
;;;	SPACE AND BACKSPACE OUTPUT IN IMAGE MODE, ALL OTHERS IN ASCII.
;;;	ALL CHARS ECHO IN PI MODE (ECHO WHEN TYPED), EXCEPT RUBOUT DOESN'T ECHO.
;;;
;;; RECALL THAT THE TWELVE CHARACTER GROUPS ARE:
;;;	^@ ^A-^F ^K-^L ^N-^R ^T-^Z ^RBRACKET ^\ ^^ ^_
;;;	A-Z (UPPER CASE), a-z (LOWER CASE)
;;;	0-9
;;;	! " # $ % & ' , . : ; ? @ \ ` | ~
;;;	* + - / = ^ _
;;;	< > ( ) { } LBRACKET RBRACKET
;;;	^G ^S
;;;	^J ^I
;;;	ALTMODE
;;;	^M
;;;	RUBOUT
;;;	SPACE ^H
.SEE %TG
	STTYW1==:232020,,202022		;STATUS WORDS FOR NORMAL MODE
	STTYW2==:232220,,220232
	STTYL1==:232020,,202020		;STATUS WORDS FOR LINE MODE
	STTYL2==:212020,,220222
	STTYA1==:022222,,222222		;STATUS WORDS FOR ALLOC
	STTYA2==:320222,,020222
]		;END OF IFN ITS

IFN D20,[
;;; Control-Character-Output-Control - two bits for each control character
;;;  0 - ignore, 
;;;  1 - print ^X,  
;;;  2 - output unmodified,  
;;;  3 - simulate format action
RADIX 4
	CCOC1==:111111123321131111
  	CCOC2==:111111111311110000
RADIX 8
; SEE CCOCW1 AND CCOCW1

;;; Four classes of wake-up control
XACTW==:TT%WKF+TT%WKN+TT%WKP+TT%WKA	;FULL WAKE UPS
XACTL==:TT%WKF				;WAKE UPS FOR "LINEMODE"
STDJMW==XACTW+TT%ECO+<.TTASC_6>	.SEE TT%DAM

			;STANDARD JFN MODE WORD FOR TERMINAL
STDTMW==TM%DPY		;STANDARD TERMINAL MODE WORD, FOR VTS STUFF
STDTIW==0		;STANDARD TERMINAL INTERRUPT WORD - not really used!
TICMAP {STDTIW==STDTIW+<1_<35-.TIC!CODE>>}
]		;END OF IFN D20

IFN SAIL,[
SACTW1==:777777777370
SACTW2==:030000005000
SACTW3==:000000240000
SACTW4==:000005200000

SACTL1==:775177577370
SACTL2==:000000000000
SACTL3==:000000000000
SACTL4==:000000200000
]		;END OF IFN SAIL



SUBTTL	ENTRIES TO VARIOUS ROUTINES CALLED BY JSR

UISTAK:	0		;STACK UP (ACTUALLY, QUEUE) A USER INTTERRUPT
	JRST UISTK1

GCRSR:	0		;GC RESTORE. CLEANS UP JUST BEFORE AN
	JRST GCRSR0	; ABNORMAL EXIT (GCEND IS NORMAL EXIT).

IFN PAGING,[
PDLSTH:	0		;"PDL ST HACK". GETS A NEW PAGE FOR A PDL,
	JRST PDLST0	; AND UPDATES ST AND GCST APPROPRIATELY.

IFN D20,[
PDLSTA:	0		;TEMPS FOR SAVING ACS
PDLSTB:	0
PDLSTC:	0
]		;END OF IFN D20
]		;END OF IFN PAGING



SUBTTL	NEWIO I/O CHANNEL ALLOCATION TABLE

;;; ENTRIES:
;;;	4.9 => CHANNEL IS LOCKED FOR A PARTICULAR PURPOSE
;;;	1.1-2.9 => ADDRESS OF FILE ARRAY SAR
;;; IF AN ENTRY IS NON-ZERO BUT ITS FILE ARRAY SAR'S
;;; TTS.CL BIT IS SET, THE CHANNEL MAY BE DE-ALLOCATED.
;;; THIS ORDINARILY HAPPENS ONLY ON A QUIT OUT OF $OPEN.
;;; CHANNEL 0 (TMPC) IS PERMANENTLY LOCKED FOR USE OF THE ERR
;;; DEVICE, FOR UPROBE, ETC.  NOTE THAT ITS PUTS .OPEN
;;; AND .CALL FAILURE CODES ON CHANNEL 0 ARBITRARILY.

IFN ITS+D10, LCHNTB==:20	;NUMBER FIXED BY OPERATING SYSTEM
IFN D20, MAYBE LCHNTB==:40	;THIS NUMBER IS BASICALLY ARBITRARY

CHNTB:
OFFSET -.
TMPC::	400000,,NIL	;FIXED TEMPORARY CHANNEL
IFGE LCHNTB-.,	BLOCK LCHNTB-.
.ELSE	WARN [TOO MANY FIXED I/O CHANNELS]
OFFSET 0


;;; DEC-10 I/O BUFFER HEADERS (MUST REMAIN FIXED IN CORE)
;;; THEY ARE NAMED BFHD0, BFHD1, ..., BFHD17.

IFN D10,  REPEAT LCHNTB,  CONC BFHD,\.RPCNT,:  BLOCK 3



DPAGEL:	60.		;INITIAL DEFAULT PAGEL
DLINEL:	70.		;INITIAL DEFAULT LINEL

IFN JOBQIO,[
LJOBTB==10		;EIGHT INFERIOR PROCEDURES
JOBTB:	BLOCK LJOBTB
]		;END OF IFN JOBQIO


SUBTTL	INITIAL TTY INPUT FILE ARRAY

	-F.GC,,TTYIF2		;GC AOBJN POINTER
TTYIF1:	JSP TT,1DIMS
		TTYIFA		;POINTER BACK TO SAR
		0		;ILLEGAL FOR USER TO ACCESS - DIMENSION IS ZERO
TTYIF2:
OFFSET -.
	FI.EOF::	NIL		;EOF FUNCTION (??)
	FI.BBC::	0,,NIL		;BUFFERED BACK CHARS
	FI.BBF::	NIL		;BUFFERED BACK FORMS
	TI.BFN::	QTTYBUF		;PRE-SCAN FUNCTION
	FT.CNS::	TTYOFA		;ASSOCIATED TTY OUTPUT FILE
	REPEAT 3, 0				;UNUSED SLOTS
	F.MODE:: SA%	FBT.CM,,2	;MODE (ASCII TTY IN SINGLE)
		 SA$	FBT.CM\FBT.LN,,2
	F.CHAN::	-1		;CHANNEL # (INITIALLY ILLEGAL)
20$	F.JFN::		.PRIIN		;JFN (FOR D20 ONLY)
20%			0
	F.FLEN::	-1		;WE EXPECT RANDOM ACCESS TO BE ILLEGAL
	F.FPOS::	0		;FILE POSITION
	REPEAT 3, 0				;UNUSED SLOTS
IFN ITS+D10,[
	F.DEV::		SIXBIT \TTY\	;DEVICE
IT$	F.SNM::		0		;SNAME (FILLED IN)
10$	F.PPN::		0		;PPN (FILLED IN)
	F.FN1::
IT$			SIXBIT \.LISP.\	;FILE NAME 1
10$			SIXBIT \LISP\
	F.FN2::
IT$			SIXBIT \INPUT\	;FILE NAME 2
10$			SIXBIT \IN\
	F.RDEV::	BLOCK 4		;TRUE FILE NAMES
]		;END OF IFN ITS+D10
IFN D20,[
	F.DEV::		ASCII \TTY\
]		;END OF IFN D20
LOC TTYIF2+LOPOFA
NTI.WDS==6				;HOW MANY OF THESE TTY-INPUT WDS?
IFN ITS+D20+SAIL,[
    TI.ST1::
	IT$		STTYW1		;TTY STATUS WORDS
	20$		CCOC1		;"REMODELED" AT TXNSET time
	SA$		SACTW1
    TI.ST2::
	IT$		STTYW2
	20$		CCOC2		;"REMODELED" AT TXNSET time
	SA$		SACTW2
    TI.ST3:: 
	IT$		0 		;TTY ACTIVATION-CHARACTER WORDS
	20$		STDJMW		; (EXCEPT ON ITS -- USUSED THERE)
	SA$		SACTW3		; TWENEX JFN-MODE WORD FOR TTY
    TI.ST4:: 
	IT$		0
	20$		STDTIW
	SA$		SACTW4
    TI.ST5:: 		0 		;TTYOPT WORD (STORED IN ITS FORMAT,
					;  ALTHOUGH READ FROM D20 BY RTCHR
    TI.ST6:: 
	20$ 		STDTMW		;TERMINAL MODE WORD (D20 ONLY)
	20% 		0
TBLCHK TI.ST1,NTI.WDS
]		;END OF IFN ITS+D20+SAIL
.ELSE		BLOCK NTI.WDS

LOC TTYIF2+FB.BUF
    FB.BUF::			;INTERRUPT FUNCTIONS
IFE SAIL,[
		NIL,,IN0+^A	;^@			^A  "SIGNAL" ON
IT%		QCN.BB,,NIL	;^B  ^B-BREAK		^C  
IT$		QCN.BB,,IN0+^C	;^B  ^B-BREAK		^C  GC STAT OFF
		IN0+^D,,NIL	;^D  GC STAT ON		^E
		NIL,,IN0+^G	;^F             	^G  HARD QUIT
REPEAT 3,	NIL,,NIL	;^H-^M (FORMAT EFFECTORS)
		NIL,,NIL	;^N			^O
		NIL,,NIL	;^P			^Q
IFE D20,[
IT$		IN0+^R,,IN0+^W	;^R  UWRITE ON?		^S  ^W INT, ^V MACRO
IT%		IN0+^R,,NIL	;^R  UWRITE ON?		^S  
		IN0+^T,,NIL	;^T  UWRITE OFF?	^U
]		;END OF IFE D20
IFN D20,[
		NIL,,NIL	;^R  			^S  
		NIL,,NIL	;^T  			^U
]		;END OF IFE D20
		IN0+^V,,IN0+^W	;^V  TTY ON		^W  TTY OFF
		IN0+^X,,NIL	;^X  SOFT QUIT		^Y
		IN0+^Z,,NIL	;^Z  GO TO DDT		   <ALTMODE>
		NIL,,NIL	;^\			CONTROL RIGHT-BRACKET
		NIL,,NIL	;^^			^_
REPEAT <NASCII/2>-<.-FB.BUF>,	NIL,,NIL	;ALL OTHERS INITIALLY UNUSED
]	;END IFE SAIL

IFN SAIL,[
REPEAT 100,	NIL,,NIL	;ALPHABETIC (ASCII 0 THROUGH ASCII 177)
REPEAT 40,	NIL,,NIL	;LOW CONTROL ^<NULL> UP TO ^@ (200-277)
		NIL,,IN0+^A	;   ^A
		QCN.BB,,IN0+^C	;^B ^C
		IN0+^D,,NIL	;^D
		NIL,,IN0+^G	;^F ^G
REPEAT 3,	NIL,,NIL
		NIL,,NIL	;^N ^O
		NIL,,NIL	;^P ^Q
		IN0+^R,,IN0+^W	;^R ^S
		IN0+^T,,NIL	;^T
		IN0+^V,,IN0+^W	;^V ^W
		IN0+^X,,NIL	;^X ^Y
		IN0+^Z,,NIL	;^Z
REPEAT 3,	NIL,,NIL
		QCN.BB,,NIL
		NIL,,NIL
		NIL,,IN0+^G	;LOWERCASE ^G
REPEAT 11,	NIL,,NIL
		IN0+^Z,,NIL
REPEAT <NASCII/2>-<.-FB.BUF>, NIL,,NIL
]	;END IFN SAIL
OFFSET 0


SUBTTL	INITIAL TTY OUTPUT FILE ARRAY

	-F.GC,,TTYOF2		;GC AOBJN POINTER
TTYOF1:	JSP TT,1DIMS
		TTYOFA		;POINTER BACK TO SAR
		0		;USER MAY NOT ACCESS, SO SAY DIMENSION IS ZERO
TTYOF2:
OFFSET -.
	FO.EOP::	QTTYMOR		;END OF PAGE FUNCTION
	REPEAT 3, 0
	FT.CNS::	TTYIFA		;STATUS TTYCONS
	REPEAT 3, 0
	F.MODE::	FBT.CM,,3	;MODE (ASCII TTY OUT SINGLE)
	F.CHAN::	-1		;CHANNEL # (INITIALLY ILLEGAL)
20$	F.JFN::		.PRIOU		;JFN
20%			0
	F.FLEN::	-1		;NOT RANDOMLY ACCESSIBLE
	F.FPOS::	0		;FILE POSITION
	REPEAT 3, 0
IFN ITS+D10,[
	F.DEV::		SIXBIT \TTY\	;DEVICE
IT$	F.SNM::		0		;SNAME (FILLED IN)
10$	F.PPN::		0		;PPN (FILLED IN)
	F.FN1::
IT$			SIXBIT \.LISP.\	;FILE NAME 1
10$			SIXBIT \LISP\
	F.FN2::
IT$			SIXBIT \OUTPUT\	;FILE NAME 2
10$			SIXBIT \OUT\
	F.RDEV::	BLOCK 4		;TRUE FILE NAMES
]		;END OF IFN ITS+D10
IFN D20,[
	F.DEV::		ASCII \TTY\
]		;END OF IFN D20
LOC TTYOF2+LOPOFA
		BLOCK 6
    ATO.LC::	0		;LINEFEED/SLASH FLAG
    AT.CHS::	0		;CHARPOS
    AT.LNN::	0		;LINENUM
    AT.PGN::	0		;PAGENUM
    FO.LNL::	71.		;LINEL
    FO.PGL::	200000,,	;PAGEL
    FO.RPL::	24.		;"REAL" PAGEL
OFFSET 0
			BLOCK <LOPOFA+LONBFA>-<.-TTYOF2>


SUBTTL	SUPER-WRITABLE STUFF - MUST BE SAVED UPON USER INTERRUPT

;;;	DONT ALLOW USER INTERRUPTS WHILE:
;;;		(1) NOQUIT IS NON-ZERO - THIS PROTECTS GC,
;;;			RETSP, SUBLIS, AND OTHERS.
;;;		(2) INHIBIT IS NON-ZERO - THIS PROTECTS
;;;			MANY AREAS OF SEMI-CRITICAL CODE.
;;;			(CF. LOCKI AND UNLOCKI MACROS)
;;;		(3) UNREAL IS NON-ZERO (DEPENDS ON EXACT VALUE)
;;;			- THIS IS FOR THE NOINTERRUPT FUNCTION

SWS::

;;; THE FOLLOWING STUFF IS SAVED WHEN AN "ERRSET FRAME" IS CREATED.
;;; NOT ONLY ERRSET, BUT ALSO CATCH AND READ NEED TO DO THIS.
;;; INTERPRETED PROGS CREATE A SORT OF HALF-ASSED FRAME.
;;; BEWARE! THE COMPILER DEPENDS ON KNOWING THE LENGTH OF
;;; THE ERRSET FRAME AS A CONSTANT PARAMETER.

ERRTN:	0	;PDL RESTORATION FOR ERRSET
CATRTN:	0	;PDL RESTORATION FOR CATCH OF A THROW
EOFRTN:	0	;PDL RESTORATION ON E-O-F TRAPOUT
PA4:	0	;PDL RESTORATION ON GO OR RETURN
INHIBIT:  0	;NON-ZERO => INHIBIT (DELAY) ALL USER INTERRUPTS
		;  -1,,0  => INHIBIT ALL EXCEPT TTY INTERRUPTS
ERRSW:	-1	;0 MEANS NO PRINT ON ERROR DURING ERRSET
		; ACTUALLY, "UNREAL" IS STORED IN THE LH OF THIS WORD
		; WHEN AND "ERRSET-PUSHED" BLOCK IS PUSHED.
BFPRDP:	0	;LH: FUNCTION WHICH WANTS TTY PRE-SCAN
			;	(READ, READLINE)
			;	TYI FOR ACTIVATION AND CURSORPOS
			;	  CLEVERNESS, BUT NO PRE-SCAN
			;	NIL FOR NO CLEVERNESS AT ALL
			;RH: -1 IF WITHIN READ
CATID:	NIL		;RH: CATCH IDENTIFICATION TAG
			;LH: FLAGS INDICATING SUBTYPE OF FRAME
	CATSPC==400000	;    SPECIAL PROCESSING NEED BE DONE (OTHER BITS HAVE
			;    MEANING)
	CATLIS==200000	;    C(RH) IS POINTER TO A LIST OF CATCH TAGS
	CATUWP==100000	;    UNWIND-PROTECT, C(RH) IS FUNCTION
	CATCAB==040000	;    CATCH-BARRIER: RH POINTER TO (CONS FUN CATCH-TAGS)
	CATALL==020000	;    CATCH-ALL: RH IS FUNCTION OF TWO ARGS
	CATCOM==010000	;    FROM COMPILED CODE, DO CALLF, NOT IPROGN

LEP1==.-ERRTN	;***** LENGTH OF SOME OF ERRSET PUSH 
KMPLOSES==-<.-ERRSW-1>
		.SEE ERSTP

UIRTN:	0	;NON-ZERO => PDL LOC OF MOST RECENT USER INT FRAME
		.SEE UINT0

RSXTB:	(A)		;POINTER TO READ SYNTAX TABLE, INDEXED BY A

PNMK1:	0		.SEE PDLNMK	;SAVE TT

GCD.A:			.SEE GCDBB
UNBND3:			.SEE UNBIND	;SAVE TT
SIXMK2:	0		.SEE SIXMAK

SAVMAR:			.SEE SUSP14	;NEEDN'T BE IN SWS, BUT WHO CARES?
GCD.B:			.SEE GCDBB
AUNBD:			.SEE AUNBIND	;SAVES D FOR AUNBIND
EXP.S:			.SEE EXP	;REMEMBERS SIGN OF ARG
ATAN.S:			.SEE ATAN	;SAVES SIGNS OF ARGS <X,,Y>
UNMTMP:			;UNAME TEMP
FPTEM:			;PSYM WANTS THIS TO BE SAME AS PCNT!!!
IFLT9:			.SEE IFLOAT	;D SAVED HERE
EQLP:	0		;PDL POINTER UPON ENTRY TO EQUAL
			.SEE EQUAL

GCD.C:			.SEE GCDBB
ATAN.X:			.SEE ATAN	;TEMPORARY X VALUE
GWDCNT:	0

GCD.D:			.SEE GCDBB
ATAN.Y:			.SEE ATAN	;TEMPORARY Y VALUE
GWDORG:	0	;ORIGIN OF LAPPIFICATION - GWDRG1 IS GWDORG-1

GWDRG1:	0

EXPL5:	0		;TEMP FOR EXPLODE

GCD.UH:			.SEE GCDBB
BKTRP:			.SEE BAKTRACE
EV0B:			.SEE EVAL
FLAT1:			.SEE FLATSIZE
MEMV:	0		.SEE MEMBER

UAPOS:			;-1=> UWRITE, >=0 => UAPPEND .ACCESS POS
GCD.VH:			.SEE GCDBB
LPNF:			;-1 MEANS NOT A LONG PNAME (FITS IN PNBUF)
			.SEE RINTERN
AUNBR:	0		;SAVES R FOR AUNBIND
DLTC:	0		;# OF TIMES DELETE/DELQ SHOULD REMOVE ITEM
			.SEE DELQ

RINF:
APFNG1:
TABLU1:	0

AUNBF:		;SAVES F FOR AUNBIND
IFE BIGNUM,[
MNMX0:		;"MIN" INSTRUCTION
GRESS0:	0	;"GREATERP" INSTRUCTION
]		;END OF IFE BIGNUM
IFN BIGNUM,[
GRESS0:	0	;"MIN" AND"GREATERP" INSTRUCTION
CFAIL:	JRST .	;TRANSFER ON FAILURE
CSUCE:	JRST .	;TRANSFER ON SUCCEED
]		;END OF IFN BIGNUM

IT$	IOST:	.STATUS 00,A
IFN ITS, SYSCL8:
BACTYF:	0	;ZERO ON FIRST LOOP THROUGH BACTRACE.
BOOLI:	SETZB D,TT	;BOOLEAN INSTRUCTION FOR BOOLE

TOPAST:	-1		;IF -1 THEN TOP-LEVEL ASTERISK NOT PRINTED IF VINFILE
			; IS INIIFA
IFN USELESS, PRINLV:	;<CURRENT PRINT LEVEL>-1
PLUS0:	0		;TYPE - QFIXNUM OR QFLONUM

IFE BIGNUM,[
PLUS3:	ADD D,TT
PLUS6:	FAD D,TT	;FLOAT-POINT INSTRUCTION FOR ARITH GENERATOR
]		;END OF IFE BIGNUM


IFN USELESS, ABBRSW:	;KIND OF STUFF DESIRED FROM PRINT0:
			; - => ONLY ABBREV STUFF
			; 0 => ONLY NON-ABBREV STUFF
			; + => BOTH (DISTINGUISHED BY TYOSW)
PLUS8:	0		;<N,,N> WHERE THERE ARE N ARGS
RM4:	0
IFN USELESS, PRPRCT:	;PRINT'S PARENS COUNTS (LEFT,,RIGHT)
SWNACK:	0		;USED FOR WNA CHECKING IN STATUS
	JRST STAT1
IFN USELESS, TYOSW: 0	;NORMALLY ZERO - TELLS TYO TYPE OF CHAR
			; + => CHAR IS FOR FILES ONLY
			; - => CHAR IS FOR TTY ONLY
			; 0 => CHAR IS FOR BOTH FILES AND TTY
RDBKC:	0		;SAVED BREAK CHARACTER, ON EXIT FROM RDCHAR
RDNSV:	0		;SAVED NUMBER (BEFORE DECIMAL-OR-NOT IS DECIDED)
RDDSV:	0		;SAVED VALUE OF # OF DIGITS TO RIGHT OF DECIMAL POINT
RDIBS:	0		;NUMERIC IBASE DURING READING
IFN USELESS,	RDROMP:	0	;ROMANP - ARE ROMAN NUMERALS OK?
RDINCH:	0		;SOURCE OF CHARACTERS FOR READ
CORBP:	0	;BYTE-POINTER FOR READ-SOURCE WHEN SOURCE IS BLOCK OF
		;ASCII OR SIXBIT STUFF IN CORE
MKNCH:	0	;INSTRUCTIION FOR MAKNAM TO GET NEXT BYTE

;;; THE PNAME BUFFER IS USED FOR VARIOUS AND SUNDRY PURPOSES.
;;; THE PRIMARY PURPOSE IS ACCUMULATING PRINT NAMES OF ATOMS.
.SEE RINTERN
;;; IT IS ALSO USED FOR VALRET AND SUSPEND STRINGS,
.SEE VALRET
.SEE SUSPEND
;;; JCL, NAMESTRINGS OF FILES (ESPECIALLY FOR D20 GTJFN JSYS),
.SEE 6BTNS
;;; ERROR MESSAGE STRING PROCESSING,
.SEE ERRIOJ
;;; AND SO ON.  FOR SOME PURPOSES THIS BUFFER OVERLAPS THE BIGNUM TEMPS.
20%	MAYBE LPNBUF==:10
20$	MAYBE LPNBUF==:50

PNBP:	440700,,PNBUF	;BYTE POINTER FOR PNAME BUFFER

PNBUF:	BLOCK LPNBUF
	0		;EXTRA WORD USED TO GUARANTEE THAT A STRING CAN BE MADE ASCIZ
JCLBF==:PNBUF+1	;SINCE STATUS JCL MAY CALL INTERN ON A SCO
ATMBF==:PNBUF+1	;DITTO INTERACTION BETWEEN PRINTA AND EXPLODE

IFN BIGNUM,[
REMFL:	0	;REMAINDER FLAG
VETBL0:	0	;DIVISION STUFF
DVS1:	0
DVS2:	0
DVSL:	0
DD1:	0
DD2:	0
DD3:	0
DDL:	0
NORMF:	0
QHAT:	0
BNMSV:  0
FACF:	0
FACD:	0
AGDBT:	0
YAGDBT:	0
TSAVE:	0
DSAVE:	0
RSAVE:	0
FSAVE:	0
NRD10FL:	0	;NOT READING IN BASE 10. FLAG
]		;END OF IFN BIGNUM
IFG JCLBF+24-.,	BLOCK JCLBF+24-.	;MUST HAVE AT LEAST 24 WDS
LJCLBF==:.-JCLBF


UUOH:				;KEEP THIS UUO STUFF CONTIGIOUS SO THAT GC CAN SAVE IT.
ERROR:	0
	JRST UUOH0
ERBDF:				;SOME RANDOM TEMP FOR UUO HANDLER
UUOFN:	0			;POINTER TO FUNCTION DURING THE UUOH1 LOOP
UUTSV:	0
UUTTSV:	0
UURSV:	0
UUALT9:		.SEE UUALT	;DOESN'T CONFLICT WITH UUPSV
UUPSV:	0
UUOBKG:	0			;IF IN *RSET MODE, PUT STUFF ON PDL
LUUSV==:.-UUOH			;STUFF THAT NEEDS SAVING FOR THE UUO HANDLER
LSWS==:.-SWS		;TOTAL LENGTH OF SUPER-WRITABLE STUFF
	JRST UUBKG1

;;; ******** STUFF SAVED UPON USER INTERRUPT ENDS HERE ********

SUBTTL	FREE STORAGE LISTS, AND GC AND ALLOC PARAMETERS

;;; ********** FREE STORAGE LISTS **********

;;; THESE ARE USED BY THE VARIOUS CONSERS TO ALLOCATE CELLS OF
;;; THE VARIOUS FREE STORAGE SPACES.  NEVER PUT ONE OF THESE IN
;;; A MARKABLE AC (EXCEPT WITHIN A PROPERLY PROTECTED CONSER)!

;;; CAUTION! MUST PRESERVE RELATIVE ORDERING OF
;;;		FFS,FFX,FFL,FFD,FFC,FFZ,FFB,FFY,FFH,FFA,FFY2
.SEE GC			;GARBAGE COLLECTOR

	FFS:	0			;LIST FREE STORAGE LIST
	FFX:	0			;FIXNUMS (AND PNAME AND BIGNUM WORDS)
	FFL:	0			;FLONUM WORDS LIST
DB$	FFD:	SETZ			;DOUBLE-PRECISION FLONUMS
CX$	FFC:	SETZ			;COMPLEX NUMBERS
DX$	FFZ:	SETZ			;DOUBLE-PRECISION COMPLEX (DUPLEX)
BG$	FFB:	0			;BIGNUM HEADERS
	FFY:	0			;SYMBOL (PNAME-TYPE ATOM) HEADERS
HN$	FFH: REPEAT HNKLOG+1, SETZ	;HUNKS
	FFA:	0			;SARS (ARRAY POINTERS)
NFF==:.-FFS				;NUMBER OF FF FROBS
	FFY2:	SY2ALC			;SYMBOL BLOCKS (EXPLICIT RETURN USED)
;;; SIGN BIT IN FF- MEANS EXEMPT FROM 40-WORD MINIMUM RECLAIMED.
	.SEE GCSWH1
	.SEE AGC1Q
	.SEE GCE0C5
	.SEE GCE0C9
	.SEE HUNK

;;; PURE FREE STORAGE COUNTERS (NON-POSITIVE, RELATIVE TO EPFF- BELOW)
;;; MUST PRESERVE RELATIVE ORDERING THROUGH NPFFY2
	NPFFS:	0			;LIST
	NPFFX:	0			;FIXNUM
	NPFFL:	0			;FLONUM
DB$	NPFFD:	0			;DOUBLE
CX$	NPFFC:	0			;COMPLEX
DX$	NPFFZ:	0			;DUPLEX
BG$	NPFFB:	0			;BIGNUM
		0			;NO PURE SYMBOLS
HN$	NPFFH: REPEAT HNKLOG+1, 0	;HUNKS
		0			;NO PURE SARS
NFFTBCK NPFFS
	NPFFY2:	0			;SYMBOL BLOCKS

;;; ADDRESS OF WORD ABOVE CURRENT PURE SEGMENT FOR EACH SPACE
;;; MUST PRESERVE RELATIVE ORDERING THROUGH EPFFY2
	EPFFS:	0			;LIST
	EPFFX:	0			;FIXNUM
	EPFFL:	0			;FLONUM
DB$	EPFFD:	0			;DOUBLE
CX$	EPFFC:	0			;COMPLEX
DX$	EPFFZ:	0			;DUPLEX
BG$	EPFFB:	0			;BIGNUM
		0			;NO PURE SYMBOLS
HN$	EPFFH: REPEAT HNKLOG+1, 0	;HUNKS
		0			;NO PURE SARS
NFFTBCK EPFFS
	EPFFY2:	0			;SYMBOL BLOCKS

	EFVCS:	BVCSG+NVCSG*SEGSIZ	;END OF CURRENT VC REGION (EFVCS+NFVCS=LAST USED VC)
	NFVCP:	NXVCSG/SGS%PG		;NUMBER OF EXTRA VC PAGES
	FFVC:	BFVCS			;VALUE CELL FREELIST (EXPLICIT RETURN USED)
	ETVCFLSP: 0	.SEE GCMARK	;EVER-TOOK-VALUE-CELL-FROM-LIST-SPACE-P

;;; GCMKL IS ARRANGED LIKE A PROPERTY LIST: THE "PROPERTY NAMES"
;;; ARE SARS, IN DECREASING ORDER OF POSITION IN ARRAY SPACE,
;;; AND THE "PROPERTY VALUES" ARE FIXNUMS DENOTING THE LENGTHS
;;; OF THE ARRAYS. USED BY GC, RETSP, GRELAR, *ARRAY, AND OTHERS
;;; TO KEEP TRACK OF ARRAYS. NOTE: THE INITIAL OBARRAY AND
;;; READTABLE ARE NOT IN GCMKL SINCE THEY ARE NOT IN BPS.
GCMKL:	IGCMKL

;;; PROLIS IS AN ALIST USED TO PROTECT NON-ATOMIC READ-MACRO
;;; FUNCTIONS FROM BEING GC'ED. EACH ITEM ON THE
;;; ALIST IS OF THE FORM  (FUN RDT . NUM)  WHERE:
;;;	FUN IS THE FUNCTION TO BE PROTECTED
;;;	RDT IS THE SAR OF THE READTABLE CONCERNED
;;;	NUM IS A LISP NUMBER (GUARANTEED NLISP INUM)
;;;		<ASCII CHAR VALUE> FOR READ-MACRO FUNCTION
;;; PROLIS IS UPDATED BY SSGCPRO AND SSGCREL.
PROLIS:	NIL

;;; VARIOUS RANDOM PARAMETERS FOR GARBAGE COLLECTOR.
;;; MUST PRESERVE RELATIVE ORDER WITHIN GROUPS.

;;; GCMIN PARAMETERS FOR EACH SPACE (FLONUM IFF LH NON-ZERO)
.SEE GCE0C0
	MFFS:	MINFFS			;LIST
	MFFX:	MINFFX			;FIXNUM
	MFFL:	MINFFL			;FLONUM
DB$	MFFD:	MINFFD			;DOUBLE
CX$	MFFC:	MINFFC			;COMPLEX
DX$	MFFZ:	MINFFZ			;DUPLEX
BG$	MFFB:	MINFFB			;BIGNUM
	MFFY:	MINFFY			;SYMBOL
HN$	MFFH: REPEAT HNKLOG+1, MINFFH	;HUNKS
	MFFA:	MINFFA			;SARS
NFFTBCK MFFS

;;; LENGTH OF FREELISTS <BEFORE,,AFTER>
.SEE GCP4B
	NFFS:	0			;LIST
	NFFX:	0			;FIXNUM
	NFFL:	0			;FLONUM
DB$	NFFD:	0			;DOUBLE
CX$	NFFC:	0			;COMPLEX
DX$	NFFZ:	0			;DUPLEX
BG$	NFFB:	0			;BIGNUM
	NFFY:	0			;SYMBOL
HN$	NFFH: REPEAT HNKLOG+1, 0	;HUNKS
	NFFA:	0			;SARS
NFFTBCK NFFS

IFN USELESS*ITS,[
GCWHO:	0		;VALUE OF (STATUS GCWHO)
			;1.1 => DISPLAY MESSAGE DURING GC
			;1.2 => CLOBBER .WHO2 WITH GC STATISTICS
GCWHO1:	0		;SAVED VALUES OF WHO-LINE VARIABLES DURING GC
GCWHO2:	0
GCWHO3:	0
]		;IFN USELESS*ITS

GCACSAV:	BLOCK NACS+1		;MARKED ACS SAVED HERE
GCNASV:	BLOCK 20-<NACS+1>		;UNMARKED ACS SAVED HERE
GCP=:GCACSAV+P
GCFLP=:GCACSAV+FLP
GCFXP=:GCACSAV+FXP	;TEST GCFXP FOR NON-ZERO TO DECIDE IF
GCSP=:GCACSAV+SP	; INSIDE GC (IMPLYING REAL PDL POINTERS ARE HERE)

PANICP:	0	;-1 SAYS WE'RE CLOSE TO RUNNING OUT OF CELLS
GCMRKV:	0	;NON-NIL MEANS MARK PHASE ONLY
GCTIM:	0	;GC TIME
GCTM1:	0
GCUUSV:	BLOCK LUUSV
IRMVF:	0	;GCTWA REMOVAL OVERRIDE SWITCH
GCRMV:	0	;WHETHER TO DO GCTWA REMOVAL
ARPGCT:	4	;# OF PAGES TO GRAB FREELY FOR ARRAYS BEFORE GC

;;; PARAMETERS RELEVANT TO MEMORY ALLOCATION.
;;; MUST PRESERVE RELATIVE ORDERING OF MOST OF THIS STUFF.

;USED BY GC TO HOLD EXACT CALCULATED INTEGRAL GCMINS
	ZFFS:	0			;LIST
	ZFFX:	0			;FIXNUM
	ZFFL:	0			;FLONUM
DB$	ZFFD:	0			;DOUBLE
CX$	ZFFC:	0			;COMPLEX
DX$	ZFFZ:	0			;DUPLEX
BG$	ZFFB:	0			;BIGNUM
	ZFFY:	0			;SYMBOL
HN$	ZFFH: REPEAT HNKLOG+1, 0	;HUNK
	ZFFA:	0			;SARS
NFFTBCK ZFFS

.SEE SSPCSIZE	;SIZE OF EACH SWEEPABLE SPACE.  USED TO CALCULATE PERCENTAGE RECLAIMED.
	SFSSIZ:	NIFSSG*SEGSIZ		;LIST
	SFXSIZ:	NIFXSG*SEGSIZ		;FIXNUM
	SFLSIZ:	NIFLSG*SEGSIZ		;FLONUM
DB$	SDBSIZ:	0			;DOUBLE
CX$	SCXSIZ:	0			;COMPLEX
DX$	SDXSIZ:	0			;DUPLEX
BG$	SBNSIZ:	NBNSG*SEGSIZ		;BIGNUM
	SSYSIZ:	NSYMSG*SEGSIZ		;SYMBOL
HN$	SHNSIZ: REPEAT HNKLOG+1, 0	;HUNKS
	SSASIZ:	NSARSG*SEGSIZ		;SARS
NFFTBCK SFSSIZ

;SIZES OF SPACES BEFORE START OF GC.  COPIED FROM SFSSIZ ET AL. AT START OF GC.
	OFSSIZ:	0			;LIST
	OFXSIZ:	0			;FIXNUM
	OFLSIZ:	0			;FLONUM
DB$	ODBSIZ:	0			;DOUBLE
CX$	OCXSIZ:	0			;COMPLEX
DX$	ODXSIZ:	0			;DUPLEX
BG$	OBNSIZ:	0			;BIGNUM
	OSYSIZ:	0			;SYMBOL
HN$	OHNSIZ: REPEAT HNKLOG+1, 0	;HUNKS
	OSASIZ:	0			;SARS
NFFTBCK OFSSIZ

;SIZE FOR EACH SPACE BELOW WHICH TO GRAB NEW SEGMENTS FASTLY
.SEE SGCSIZE	; (I.E. WITHOUT DOING A WHOLE GARBAGE COLLECTION FIRST)
	GFSSIZ:	MAXFFS			;LIST
	GFXSIZ:	MAXFFX			;FIXNUM
	GFLSIZ:	MAXFFL			;FLONUM
DB$	GDBSIZ:	MAXFFD			;DOUBLE
CX$	GCXSIZ:	MAXFFC			;COMPLEX
DX$	GDXSIZ:	MAXFFZ			;DUPLEX
BG$	GBNSIZ:	MAXFFB			;BIGNUM
	GSYSIZ:	MAXFFY			;SYMBOL
HN$	GHNSIZ: REPEAT HNKLOG+1, MAXFFH	;HUNKS
	GSASIZ:	MAXFFA			;SARS
NFFTBCK GFSSIZ

;;; ROOTS OF THE CHAINS LINKING LIKE PAGES IN THE GARBAGE COLLECTOR 
;;; SEGMENT TABLE (GCST).  FILLED IN AT INIT TIME.
	FSSGLK:	0			;LIST
	FXSGLK:	0			;FIXNUM
	FLSGLK:	0			;FLONUM
DB$	DBSGLK:	0			;DOUBLE
CX$	CXSGLK:	0			;COMPLEX
DX$	DXSGLK:	0			;DUPLEX
BG$	BNSGLK:	0			;BIGNUM
	SYSGLK:	0			;SYMBOL
HN$	HNSGLK: REPEAT HNKLOG+1, 0	;HUNKS
	SASGLK:	0			;SARS
NFFTBCK FSSGLK

	S2SGLK:	0	;THIS MUST FOLLOW THOSE ABOVE! (SYMBOL BLOCKS)

BTSGLK:	0	;LINKED LIST OF BIT BLOCKS
IMSGLK:	0	;LINKED LIST OF UNALLOCATED IMPURE SEGMENTS (INIT SETS UP)
PRSGLK:	0	;LINKED LIST OF UNALLOCATED PURE SEGMENTS
10$ SVPRLK:	0	;SAVED PRSGLK WHEN HISEG GETS PURIFIED
PG$ LHSGLK:	0	;LINKED LIST OF BLOCKS FOR LH HACK


BTBAOB:
PG$	-<NBITSG*SEGSIZ/BTBSIZ>+NBITB,,BFBTBS_<5-SEGLOG>
PG%	-<NBITSG*SEGSIZ/BTBSIZ>+NBITB,,		.SEE IN10S5
MAINBITBLT:	BFBTBS-1	;END ADDRESS FOR BLT OF MAIN BIT BLOCK AREA
GC98:	0	;RANDOM TEMP FOR GC
GC99:	0	;RANDOMER TEMP FOR GC


.SEE SPURSIZE	;SIZE OF PURE FREE STORAGE AREAS - USED MAINLY BY STATUS,
.SEE LDXQQ2	; BUT ALSO RANDOMLY USED BY DEC-10 FASLOAD INTO HISEG
	PFSSIZ:	NPFSSG*SEGSIZ		;LIST
	PFXSIZ:	NPFXSG*SEGSIZ		;FIXNUM
	PFLSIZ:	NPFLSG*SEGSIZ		;FLONUM
DB$	PDBSIZ:	0			;AIN'T NO INITIAL PURE DOUBLES, SONNY!
CX$	PCXSIZ:	0			;AIN'T NO INITIAL PURE COMPLICES, MAMA!
DX$	PDXSIZ:	0			;AIN'T NO INITIAL PURE DUPLICES, DADDY!
BG$	PBNSIZ:	0			;AIN'T NO INITIAL PURE BIGNUMS, BABY!
	0				;AIN'T NEVER NO PURE SYMBOLS!
HN$	PHNSIZ: REPEAT HNKLOG+1, 0	;HUNKS (YOU GOTTA BE KIDDING!)
	0				;AIN'T NEVER NO PURE SARS NEITHER!
NFFTBCK PFSSIZ

	PS2SIZ:	NSY2SG*SEGSIZ		;SYMBOL BLOCKS

;;; ********** HAIRY PARAMETERS HACKED BY ALLOC **********

BPSH:					;BINARY PROG SPACE HIGH
PG%	0			;FILLED IN BY ALLOC
PG$	<<ENDLISP+PAGSIZ-1>&PAGMSK>-1

BPSL:	BBPSSG				;BINARY PROG SPACE LOW

IFN PAGING,[
HINXM:	0		;ADDRESS OF LAST WORD OF NXM HOLE
]		;END OF IFN PAGING
IFE PAGING,[
HIXM:	0		;ADDRESS OF LAST WORD OF LOW SEGMENT
MAXNXM:	0		;HIGHEST USABLE WORD OF NXM ABOVE LOW SEGMENT
HBPORG:	ENDHI		;FIRST AVAILABLE WORD OF HISEG FOR LOADING BINARY PROGRAMS
HBPEND:	IF1,[0] IF2,[HILOC+<<ENDHI-HILOC-STDHI+PAGSIZ-1>&PAGMSK>-1]
]		;END OF IFE PAGING

;;; THESE TWO VALUES ARE USED FOR A QUICK-AND-DIRTY PDL NUMBER CHECK.
.SEE PDLNMK
.SEE SPECBIND	;AND OTHERS
NPDLL:	0		;LOW END OF NUMBER PDL AREA
NPDLH:	0		;HIGH END OF NUMBER PDL AREA


IFN PAGING,[
PDLFL1:	0		;FOR FLUSHING PDL PAGES - SEE ERINIT
PDLFL2:	0		;FOR UPDATING ST - SEE ERINIT
]		;END OF IFN PAGING

;;; THE NEXT FEW THINGS MUST BE IN THIS ORDER

.SEE SSGCMAX	;MAXIMUM SIZES FOR STORAGE SPACES
	XFFS:	0		;LIST
	XFFX:	0		;FIXNUM
	XFFL:	0		;FLONUM
DB$	XFFD:	0		;DOUBLE
CX$	XFFC:	0		;COMPLEX
DX$	XFFZ:	0		;DUPLEX
BG$	XFFB:	0		;BIGNUM
	XFFY:	0		;SYMBOL
HN$	XFFH: REPEAT HNKLOG+1, MAXFFH	;HUNKS
	XFFA:	0		;SARS
NFFTBCK XFFS

IFN PAGING,[
;;; THE NEXT FOUR THINGS MUST BE IN THIS ORDER
XPDL:	MAXPDL		;MASTER PDL POSITIONS TO GIVE
XFLP:	MAXFLP		; PDL-LOSSAGE INTERRUPTS AT
XFXP:	MAXFXP
XSPDL:	MAXSPDL
;;; THE NEXT FOUR THINGS MUST BE IN THIS ORDER
ZPDL:	MAXPDL		;ACTUAL PDL POSITIONS FOR LOSING
ZFLP:	MAXFLP		;INITIALIZED AT ERINIT FROM XPDL ET AL.
ZFXP:	MAXFXP		; AND DIDDLED BY PDLOV AT OVERFLOW TIME
ZSPDL:	MAXSPDL
]		;END OF IFN PAGING

;;; THE NEXT FOUR THINGS MUST BE IN THIS ORDER
C2:	-PAGSIZ+NACS+1+2,,PDLORG-1	;STANDARD REG PDL PTR
FLC2:	-PAGSIZ+2,,FLPORG-1		;STANDARD FLO PDL PTR
FXC2:	-PAGSIZ+2,,FXPORG-1		;STANDARD FIX PDL PTR
SC2:	-PAGSIZ+1+2,,SPDLORG		;STANDARD SPEC PDL PTR
;SC2 IS INITIALIZED TO ONE SLOT HIGHER THAN MIGHT BE EXPECTED
; IN ORDER TO ACCOMMODATE A ONE-SLOT OVERPOP IN SOME PLACES.
.SEE ERRPOP
ZSC2:	SPDLORG				;SC2 WITH ZERO LEFT HALF

;;; THE NEXT FOUR THINGS MUST BE IN THIS ORDER
OC2:	0	;ABS LIMITS FOR PDLS
OFLC2:	0
OFXC2:	0
OSC2:	0

SUBTTL	RANDOM VARIABLES IN LOW CORE

;; Fast XCT'd cells for UUOLINK snapping

USRHNK:	0		;Either 0 or CALL instruction: is this a special hunk?
SENDI:	0		;Either 0 or CALL instruction: send msg to user's hunk
ICALLI:	0		;Either 0 or CALL instruction: Apply user's hunk

;;; I GUESS THIS STUFF NEED NOT BE CONSIDERED SACRED

;;; SPACE FOR ALL CHANNELS AND INFERIORS AND USELESS INTS AND GC OVERFLOWS
MAYBE LINTAR==20+10*JOBQIO+5*USELESS+NFF

INTAR:	0			;INDEX INTO INTERRUPT ARRAY (FIFO QUEUE)
	BLOCK LINTAR		;ENTRIES OF FORM <INT #,,ARG FOR INT FN>
				; RIGHT HALVES ARE PROTECTED BY GC


;;; ENOUGH FOR ALL CHANNELS AND INFERIORS AND USELESS INTS AND GC OVERFLOWS
MAYBE LUNREAR==20+10*JOBQIO+5*USELESS+NFF

UNRC.G:	0		;-2/-3 FOR DELAYED ^X/^G INTERRUPT
IFN USELESS, UNRCLI:	0	;ENTRY FOR DELAYED CLI INTERRUPT
IFN USELESS, UNRMAR:	0	;ENTRY FOR DELAYED MAR INTERRUPT
UNRRUN:	0		;ENTRY FOR DELAYED RUNTIME ALARMCLOCK
UNRTIM:	0		;ENTRY FOR DELAYED REAL TIME ALARMCLOCK
UNREAR:	0		;INDEX INTO "REAL TIME" INTERRUPT QUEUE
	BLOCK LUNREAR	;ENTRIES OF FORM <ARG FOR INT FN,,INT #>
			;ARGS IN UNREAR NEED NO GC PROTECTION
			.SEE NOINTERRUPT

;;; INTERRUPT PDL

LIPSAV==:10		;LENGTH OF CRUD PUSHED BY INTERRUPT
IPSWD1==:-7		;WORD ONE (.PIRQC) INTERRUPTS TAKEN
IPSWD2==:-6		;WORD TWO (.IFPIR) INTERRUPTS TAKEN
IPSDF1==:-5		;SAVED .DF1
IPSDF2==:-4		;SAVED .DF2
IPSPC==:-3		;SAVED PC
IPSD==:-2		;SAVED ACCUMULATOR D
IPSR==:-1		;SAVED ACCUMULATOR R
IPSF==:0		;SAVED ACCUMULATOR F


SA% MXIPDL==4		;MAX SIMULTANEOUS INTERRUPTS
SA$ MXIPDL==10.		; (CALCULATED FROM THE DEFER WORDS
			; IN THE INTERRUPT VECTOR):
			;	1 MISCELLANEOUS
			;	2 PDL OVERFLOW
			;	1 MEMORY ERROR/ILLEGAL OP
LINTPDL==LIPSAV*MXIPDL+1	.SEE PDLOV
INTPDL:	-LINTPDL,,INTPDL	.SEE INTVEC
;EXTRA ROOM FOR ONE INTPDL OVERFLOW AND RESULTING EXTRA INTERRUPT
	BLOCK LINTPDL+2*LIPSAV	.SEE PDLOV
IT$ IOCINS:	0	;USER IOC ERROR ADDRESS
IT$			.SEE IOCER8
IFN D10,[
IFN SAIL,[
;SAIL ONLY DEFINITIONS
ACBASE==:20			;WHERE SAIL MONITOR SAVES USER ACS UPON INT
INTMAI==:004000,,000000		;MAIL INTERRUPT
INTPAR==:000400,,000000		;PARITY ERROR
INTCLK==:000200,,000000		;CLOCK INTERRUPT
INTTTI==:000004,,000000		;<ESCAPE>I INTERRUPT
INTPOV==:000000,,200000		;PDL OV
INTILM==:000000,,020000		;ILL MEMORY REF
INTNXM==:000000,,010000		;NON EXISTANT MEMORY
]	;END IFN SAIL

REEINT:	BLOCK 1
REENOP:	BLOCK 1
APRSVT:	BLOCK 1
REESVT:	BLOCK 1

]	;END IFN D10

IFN D10+D20,[
INTALL:	BLOCK 1

;FUDGE BIT DEFINITIONS FOR VARIOUS ITS PI BITS
;LEFT HALF BITS
SA$ %PIMAI==:4000,,
%PIPAR==:1000,,
%PIWRO==:200,,
;RH BITS
%PIMPV==:20000
%PIILO==:40
]		;END IFN D10+D20

;;; LH OF MUNGP => GC IS IN PROCESS OF USING MARK BITS
;;;			IN SARS OR SYMBOLS
;;; RH OF MUNGP => ALIST IS IN PROCESS OF USING LH'S OF
;;;			VALUE CELLS FOR SPECPDL HACKERY
;;; ERINIT CHECKS MUNGP AND ATTEMPTS TO RESTORE THINGS IF
;;; NECESSARY. THIS SHOULD HAPPEN ONLY IN THE CASE OF SOME
;;; GROSS BUG LIKE A MEMORY VIOLATION.
MUNGP:	0

;;; VARIABLES NEEDED FOR ERRPOP
ERRPAD:	0		;SAVE RETURN ADDRESS
ERRPST:	0		;SAVE T OVER UNWPRO
;;; TEMPORARIES FOR FASLOAD

BFTMPS::
SQ6BIT:	0	;TEMPORARIES FOR SQUEEZE
SQSQOZ:	0
LDBYTS:	0	;WORD OF RELOCATION BYTES
LDOFST:	0(TT)	;LOAD OFFSET (RELOCATION FACTOR = VALUE OF BPORG BEFORE LOAD)
LDAAOB:	0	;AOBJN INDEX FOR ATOMTABLE ARRAY
LDTEMP:		;RANDOM TEMPORARY
LD6BIT:	0	;PLACE TO ACCUMULATE SIXBIT WHILE CONVERTING FROM SQUOZE
		; - FIRST 6 BITS OF NEXT WORD MUST BE ZERO
LDAPTR:	0(TT)	;WILL BE AN INDIRECT POINTER FOR ACCESSING THE ATOMTABLE
LDBPTR:	0(F)	;WILL BE AN INDIRECT POINTER FOR ACCESSING THE I/O BUFFER
LDF2DP:	0	;.FNAM2-DIFFERENT-P
		; (NON-ZERO --> FASLAP'S LDFNM2 DIFFERS FROM CURRENT FASLOAD'S)
LDASAR:	0	;ADDRESS OF SAR FOR FASLOAD'S ATOMTABLE ARRAY
LDBSAR:	0	;ADDRESS OF SAR FOR FASLOAD'S I/O BUFFER ARRAY

IFE PAGING,[
LDXBLT:	0	;BLT POINTER FOR ZAPPING CALLS FOR XCTS IN BPS
LDXSIZ:	0	;0=XCT HACKERY NEVER DONE, -1=DONE AND PURIFIED,
		; N>0=LENGTH (IN WORDS) OF AREA FOR XCTED CALLS
LDXSM1:	0	;CONTAINS 1 LESS THAN LDXSIZ, AND RETAINS VALUE AFTER
		; LDXSIZ BECOMES -1
LDXDIF:	0(D)	.SEE LDPRC6
		;RH WILL CONTAIN DIFFERENCE BETWEEN RH AND LH OF LDXBLT
]	;END IFE PAGING

LDHLOC:	0	;HIGHEST LOC ASSEMBLED INTO + 1
LDEOFJ:	0	;JUMP ADDRESS FOR END OF FASLOAD INPUT FILE
10$ LDEOFP:	0	;USED FOR EOF HANDLING IN FASLOAD FOR D10
LFTMPS==:.-BFTMPS		;NUMBER OF FASLOAD TEMPORARIES

IFN PAGING,[
;MULTIPLE XCT SEGMENTS ASSEMBLY TIME PARAMETERS
;DESCRIPTION OF SEGMENT FORMAT:
;LDXPNT POINTS TO FIRST IMPURE SEGMENT IN THE CHAIN.  THE RH OF LDXPSP
; WORD IN EACH SEGMENT IS THE POINTER TO THE PURIFIABLE SEGMENT ATTACHED
; TO THE IMPURE SEGMENT, AND THE LH OF LDXPSP IS THE POINTER TO THE NEXT
; SEGMENT OR 0 IF NO MORE SEGMENTS IN CHAIN.  LDXLPC IS THE -COUNT OF THE
; NUMBER OF SLOTS FREE IN THE CURRENT SEGMENT.  THE CURRENT SEGMENT IS THE
; ONE POINTED TO BY LDXLPL.  IF LDXLPC IS >= 0, IT IS POSSIBLE THAT THE PURE
; SEGMENT ATTACHED TO C(LDXLPL) IS ACTUALLY PURE, AND THUS MAY NOT BE WRITTEN
; INTO.  IF LDXPNT IS 0, THE DATABASE IS COMPLETELY INVALID.
; THE SEGMENT SIZE USED IS THE DEFAULT SEGMENT SIZE DEFINED BY SEGLOG AND
; SEGSIZ.  IF LDXPFG IS -1, THEN A PURIFICATION HAS BEEN DONE.  THIS FLAG IS
; USED SOLELY FOR (STATUS UUOLINKS).  AN EMPTY SLOT IS ZERO IN BOTH THE PURE
; AND IMPURE SEGMENT.  THE FIRST WORD THAT IS USED FOR DATA IN EACH SEGMENT
; IS LDXOFS.  THIS IS COMPUTED SUCH THAT THE LAST WORD OF DATA IS ACTUALLY THE
; LAST WORD OF THE SEGMENT.

;HASHING VALUES
IFE SEGLOG-8.,[LDHSH1==:251.
	       LDHSH2==:241.]
IFE SEGLOG-9.,[LDHSH1==:509.
	       LDHSH2==:503.]
IFE SEGLOG-10.,[LDHSH1==:1019.
		LDHSH2==:1021.]
LDX%FU==:90.	;WHAT PERCENTAGE FULL ANY PAGE IS ALLOWED TO GET
;THIS MUST BE LOCATION ZERO!
LDXPSP==:0	;NEXT SEGMENT IN CHAIN,,PURE SEGMENT POINTER
LDXOFS==:SEGSIZ-LDHSH1-1 ;OFFSET OF FIRST WORD OF UUOLINKS
LDXPNT:	0	;POINTER TO XCT PAGES
LDXLPC:	0	;COUNT OF WORDS REMAINING ON LAST PAGE USED
LDXLPL:	0	;STARTING LOCATION OF LAST PAGE USED
LDXHS1:	0	;FIRST HASH VALUE
LDXHS2:	0	;SECOND HASH VALUE
LDXPFG:	0	;-1 WHEN PURIFIED
]	;END IFN PAGING

IT$ IUSN:	0	;INITIAL USER SNAME - SET BY LISPGO
USN:	BLOCK 2		;USER SYSTEM NAME
EVPUNT:	TRUTH		;DON'T EVAL FUNCTION ATOM
IFN D10,[
UWUSN:	0		;UWRITE SNAME (I.E. PPN)
D10PTR:	0		;AOBJN POINTER FOR DEC BUFFERS..
D10ARD:	-200,,.		;I/O WORD FOR ARRAY DUMP AND FASL
	0
D10NAM:	0		;THIS WORD ;WILL BE ###LSP WHERE ###=JOB NR
D10REN:	BLOCK 2		;FILE NAME TO
]	;END OF IFN D10

IT% SYMLO:	0		;LOW BOUNDARY FOR DDT'S SYMBOL TABLE

IFN SAIL,[
;DEFINE SOME EXTRA TTY RELATED BITS
%TXTOP==:4000	;"TOP" KEY.
%TXSFL==:2000	;"SHIFT-LOCK" KEY.
%TXSFT==:1000	;"SHIFT" KEY.
%TXMTA==:400	;"META" KEY.
%TXCTL==:200	;"CONTROL" KEY.
%TXASC==:177	;THE ASCII PART OF THE CHARACTER.
]	;END IFN SAIL
IT$ %TXSFL==:0  ;"SHIFT-LOCK" KEY DOESN'T EXIST ON ITS

RDOBJ8:	RD8N	;OR RD8W FOR WHITE'S + HAC
ALGCF:	0	;FLAG TO STOP THE GC WHILE IN ALLOC
AFILRD:	-1	;-1 => NO INIT FILE, >0 => CDR OF ALLOC COMMENT

GNUM:	ASCII \G0000\	;INITIAL GENSYM


;;; RANDOM STUFF FOR RANDOM NUMBER GENERATOR
;;; RNOWS, RBACK, AND RBLOCK MUST BE IN THAT ORDER.

IFN USELESS,[
MAYBE LRBLOCK==:71.		; 71  35
MAYBE ROFSET==:35.		;X  +X  +1 IS IRREDUCIBLE MOD 2 (ASK MACSYMA!)
]		;END OF IFN USELESS
IFE USELESS,[
MAYBE LRBLOCK==:7		;            7  3
MAYBE ROFSET==:3		;SO ALSO IS X +X +1 IRREDUCIBLE MOD 2
]		;END OF IFE USELESS

RNOWS:	0	.SEE INIRND	;INITIALIZED AT INIT TIME
RBACK:	0	.SEE SSRANDOM	;CAN BE RESTORED BY (SSTATUS RANDOM ...)
RBLOCK: BLOCK LRBLOCK	.SEE RANDOM	;71. WORDS OF "RANDOM"NESS



RNTN2:	.(T)	;CURRENT PNBUF WORD FOR COMPARE ON INTERN

;;; VARIABLES FOR ARRAY ALLOCATOR
BPPNR:	0	;<SIZE OF ARRAY HEADER>,,-<SIZE OF ARRAY DATA>
GAMNT:	0	;NUMBER OF WORDS REQUIRED, ON A CALL TO GETSP
GSBPN:	0	;USED AS TEMPORARY BPEND WHILE BLT'ING DOWN ARRAYS
ADDSAR:	0	;ADDRESS OF SPECIAL ARRAY CELL WHEN MAKIN ARRAY
TOTSPC:	0	;<# OF ARRAY DIMS>,,<TOTAL SPACE NEEDED FOR ARRAY>
LLIP1:	0	;<LARGEST LEGAL INDEX OF ARRAY>+1
INSP:	0	;PSEUDO-PDL POINTER FOR ARRAY-ING


RTSP1:	0
RTSP3:	0
LOSEF:	77	;LAP OBJECT STORAGE - EFFICIENCY FACTOR.  FOR (STATUS LOSEF) = N, 
		;THERE WILL BE <1_N>-1 STORED HERE.  SIZE OF GC PROTECTION ARRAY
OLDSXHASHP:	TRUTH 	;IF = (), THEN USE NEW STYLE SXHASH, 
RWG:	0	;IF = 0, THEN CREATE ERROR ON DIVIDE BY ZERO, 
			 ;OR FLOATING OVFLO ON CONVERSION OF BIGNUM
FLOV9A:	0	;RANDOM TEMPS FOR FLOATING POINT
FLOV9B:	0	; OVERFLOW INTERRUPT HANDLER
CPJSW:	0	;IF NOT ZERO, THEN *RSET WAS ON, AND BAKTRACE WILL FIND MUCH 
		;INFORMATION FROM THE  [FUN,,CPOPJ]  TYPE STUFF ON THE PDL
PSYMF:	0	;NON-ZERO DURING EXECUTION OF PSYM.
POFF:	0	;VARIOUS ROUTINES INVOLVING $X'S FROM DDT DO JSR'S HERE
	JRST PSYM1
PSMS:	BLOCK 20	;THIS SHOULD BE ENOUGH FOR LPSMTB
	BLOCK 3
PSMTS:	0
PSMRS:	0
IT$	SQUOZE 0,.	;FOR A  .BREAK 12,[4,,PS.S-1]
PS.S:	0		.SEE PSYM1

STQLUZ:	0	;FOR SETQING NIL OR T - REMEMBER WHICH ONE OVER INTWAIT

NOPFLS:	0	;NON-ZERO => PURIFY$G SHOULDN'T FLUSH PDLS

SAWSP:	-1	;SCREW-AROUND-WITH-SHARING-P:  -1 SAYS WE MUS READ 
		; OUR CORE IMAGE IN FROM A "PURQIO" FILE
20$ PSYSP:	-1 	;PURIFY-SYSTEM-PAGES  -1 SAYS YES

ALVRNO: ASCIZ \0\	;ASCII string with LISP version number -- set up
			;  at INITIALIZE time.

IFN ITS,[
PURDEV:	0	;PDUMP FILE DEVICE NAME
PURFN1:	0	;PDUMP FILE FN1
PURFN2:	0	;PDUMP FILE FN2
PURSNM:	0	;PDUMP FILE SNAME

SYSDEV:	SIXBIT \SYS\
SYSFN1:	SIXBIT \PURQIO\
SYSFN2:	LVRNO
SYSSNM:	SIXBIT \SYS\
]		;IFN ITS

SA$ FAKDDT:	HALT		;FOR FAKING OUT THE WORLD

MAYBE LSJCLBUF==10		;ENOUGH FOR 40. CHARS
SJCLBUF:	0		;FIRST WORD HOLD NUMBER OF CHARS BUFFERED
	BLOCK LSJCLBUF
		0		;INSURES THAT ILDBS WILL FINALLY SEE A ZERO

SUBTTL	INITIAL READTABLE, OBARRAY (IN LOW CORE)

;;; INITIAL READ SYNTAX TABLE IN FORM OF AN ARRAY

	-1,,0		;IN NEWIO, WILL POINT TO MACRO CHAR LIST
RSXTB1:	PUSH P,CFIX1
	JSP TT,1DIMF
	   READTABLE
	   0
RCT:	BLOCK LRCT-2	;WHICH IS BLT'D IN FROM RCT0
	TRUTH,,0	;(STATUS TTYREAD),,(STATUS ABBREVIATE)
	NIL,,TRUTH	;(STATUS TERPRI),,(STATUS _)   



;;; INITIAL OBLIST IN FORM OF ARRAY
	-<OBTSIZ+1>/2,,IOBAR2
IOBAR1:	JSP TT,1DIMS
	   OBARRAY
	   OBTSIZ+1+200
IOBAR2:	BLOCK <OBTSIZ+1>/2
	BLOCK 200/2	;SINGLE CHAR OBJS TABLE (CREATED AS NEEDED)



SUBTTL	 PURTBL AND IPURIFIY

;;; PURE PAGE TABLE
;;; CONTAINS TWO BITS FOR EACH PAGE, 16 PAGES PER TABLE WORD
;;; MEANING OF BITS:	00=NXM		01=IMPURE
;;;			10=PURE		11=SPECIAL HACKERY NEEDED

IFN PAGING,[

PURTBL:
IF1,[
 	BLOCK NPAGS/20
IFN NPAGS&17, BLOCK 1
]	;END IF1
IF2,[
ZZW==.	;DARN WELL BETTER BE SAFE OVER THE FOLLOWING MESS!
.BYTE 2
ZZZ==0
$==3	;FOR HAIRY PRINTOUT TO WORK
PRINTX \
INITIAL PURTBL MEMORY LAYOUT
[0=NXM, 1=IMPURE, 2=PURE, $=BPS/PDL/SCRATCH]
\

NLBTSG==0
NHBTSG==0
IFN LOBITSG,	NLBTSG==NBITSG
.ELSE,		NHBTSG==NBITSG

;;; IN THE IRP BELOW, COMMAS AND CR'S MARK GUARANTEED PAGE BOUNDARIES

IRP SPCS,,[ZER+LBT,ST,SYS,SAR+VC,XVC,IS2+SYM+XXA,XXZ,SY2+PFX+PFS+PFL+XXP
IFS+IFX+IFL+BN+XXB,HBT,BPS,NXM,FXP,XFXP,FLP,XFLP,P,XP
SP,XSP,SCR]BITS,,[1,1,2,1,0,1,0,2,1,1,$,0,$,0,$,0,$,0,$,0,$]
ZZX==0
IRPS SPC,,[SPCS]
ZZX==ZZX+N!SPC!SG
TERMIN
REPEAT ZZX/SGS%PG,[
	BITS
ZZZ==ZZZ+1
IFE ZZZ&17,[
	0
	0
]
PRINTX \BITS\
IFE <ZZZ#10>&17, PRINTX \ \
IFE <ZZZ#20>&37, PRINTX \   \
IFE ZZZ&37,[
PRINTX \
\
]
]		;END OF REPEAT
TERMIN
.BYTE
IFN ZZZ-NPAGS,[
	WARN \ZZZ,[=WRONG LENGTH FOR PURTBL (SHOULD BE ]\NPAGS,[)]
	LOC ZZW
 		BLOCK NPAGS/20
	IFN NPAGS&17, BLOCK 1

]	;END OF IFN ZZZ-NPAGS

 PRINTX \
\
]		;END IF 2
]		;END OF IFN PAGING


.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,[

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	START-UP CODE, AFTER A FLUSHING SUSPEND

;NOTHING ON THIS PAGE IS FLUSHED WHEN/IF LISP'S PURE PAGES ARE CLEARED FROM
; CORE DURING A SUSPEND

IFN PAGING,[

NFLSS::

FLSTBL:
IF1, BLOCK <<777777_-SEGLOG>+1>/36.
IF2,[
.BYTE 1
IRP SPCS,,[ZER+LBT,ST,SYS,SAR+VC,XVC,IS2+SYM+XXA,XXZ,SY2+PFX+PFS+PFL+XXP
IFS+IFX+IFL+BN+XXB,HBT,BPS,NXM,FXP,XFXP,FLP,XFLP,P,XP
SP,XSP,SCR]BITS,,[1,1,2,1,0,1,0,2,1,1,$,0,$,0,$,0,$,0,$,0,$]
ZZX==0
IRPS SPC,,[SPCS]
ZZX==ZZX+N!SPC!SG
TERMIN
REPEAT ZZX/SGS%PG,[
IFE BITS-2, 1			;GENERATE A FLUSH ENTRY IF PURE
.ELSE,	0			; ELSE PAGE SHOULD NOT BE FLUSHED
]
TERMIN
.BYTE
BLOCK <<777777_-SEGLOG>+1>/36.-<.-FLSTBL>
]		;END OF IF2
]		;END OF IFN PAGING


IFN D20,[
ENTVEC: JRST LISPGO		;TOPS-20 ENTRY VECTOR
	JRST CTRLG
	0 			;TO BE FILLED IN WITH VERSION NUMBER IN 
				;   BITS 4.6 - 3.7
]	;END OF IFN D20


IFN ITS\D20,[
FLSPA1:	ASCIZ \:Job Suspended
\
FLSPA3:	ASCIZ \:LISP pure pages flushed, and job Suspended
\
FLSDIE:
DEFINE FLDIMSG A
ASCIZ \:LOSE!!  Cannot find file with pure pages for the LISP which this job was dumped from (version !A!).
\
TERMIN

FLDIMSG \LVRNON


SUSP4:
IFN ITS,[
	.CALL PURCHK
	 .VALUE FLSDIE		; DIE, DIE, DIE IF NO SYSTEM PAGES
	JUMPE TT,.-1
	JRST SUSP3A

]	;END OF IFN ITS
IFN D20,[
	MOVEI A,BSYSSG_-<SEGLOG+SGS%PG-1>
	HRLI A,.FHSLF
	RPACS
	TLNE B,(PA%PEX)
	 JRST SUSP3A
	HRROI 1,FLSDIE
	PSOUT
	JRST .-2
]	;END OF IFN D20

FLSSTARTUP:
	JSP TT,SHARP1		;BEFORE STARTING MUST HAVE A REAL CORE IMAGE
	 JRST SUSP4
SUSP3A:	SETZM SAWSP		;WE HAVE ALREADY MAPPED OURSELVES IN

]	;END OF IFN ITS\D20


;;; HERE ON STARTUP AGAIN AFTER SUSPENSION
IFN SAIL*PAGING,[
	JSP 10,E.START
]	;END OF IFN SAIL*PAGING
SUSP3:	
20$	RESET			;RESET OURSELVES ON STARTUP
IFN SAIL*PAGING,[
	SETZM VECALLEDP
]	;END OF IFN SAIL*PAGING
IFN D10\D20    	JSP F,JCLSET	;GOBBLE DOWN ANY JCL
	MOVE NIL,GCNASV+1	;RESTORE IMPORTANT AC'S
	MOVE T,[GCNASV+2,,FREEAC]
	BLT T,17
	SETZB A,B		;CLEAR OUT GARBAGE
	SETZB C,AR1
	SETZ AR2A,
	SKIPN (FLP)		;RESTORE FXP UNLESS JCL WAS NIL
	 MOVE FXP,(FXP)
	MOVNI T,1		;AOBJN ON -1 LEAVES [1,,0] ON A KA10
	AOBJN T,.+1		; BUT [0] ON A  KL OR KI
	MOVEM T,KA10P
IFN ITS\D20,[
	MOVE T,GCNASV
	MOVEM T,LISPSW
	JSP T,SHAREP		;RE-READ PURE PAGES IF EVERYTHING IS IN ORDER
]	;END OF IFN ITS\D20
IFN ITS,[
	.SUSET [.ROPTION,,TT]
	TLO TT,OPTINT+OPTOPC		;NEW-STYLE INTERRUPTS AND NO PC SCREWAGE
	.SUSET [.SOPTION,,TT]
	.SUSET [.SDF1,,R70]
	.SUSET [.SDF2,,R70]
	.SUSET [.SMASK,,IMASK]
	.SUSET [.SMSK2,,IMASK2]
IFN USELESS,[
	MOVE T,IMASK
	TRNE T,%PIMAR
	 .SUSET [.SMARA,,SAVMAR]
]		;END OF IFN USELESS
]		;END OF IFN ITS
IFN D20,[
	MOVEI T,CTRLG		;RESTORE "CONTINUE" ADDRESS
	HRRM T,ENTVEC+1
	JSP R,TNXSET		;MUST BE DONE BEFORE PION
]	;END OF IFN D20
IFN D10,[
	MOVE T,GCNASV
	HRRM T,.JBSA"
	HLRM T,.JBREN
SA%	JSP T,D10SET
]		;END OF IFN D10
	PION
	JSP T,PPNUSNSET
	SETZM NOPFLS
	HRRZS NOQUIT
	PUSHJ P,OPNTTY		;*** TEMP CROCK?
	 JFCL
	PUSHJ P,UDIRSET
	POPI FLP,1		;REMOVE NIL VALRET FLAG
	POP FLP,A		;RESTORE RETURN VALUE
	POPJ P,






NOSHARE==JRST (T)		;DEPOSIT INTO SHAREP TO INHIBIT SHAREING
SHAREP:	SKIPN SAWSP
	 JRST (T)
	SETZM SAWSP
IFN ITS,[
	.CALL PURCHK
	 .VALUE
	JUMPL TT,(T)		;NEGATIVE IF FIRST SYSTEM PAGE IS WRITEABLE
]		;END OF IFN ITS
	JSP TT,SHARP1
	 JFCL 			;IGNORE CASE OF LOST PURQIO FILE
	JRST (T)


SHARP1:
IT% 	JRST (TT)
IT% 	WARN [HOW TO SHARE WITH "PURQIO" FILE?]
IFN ITS,[
	.CALL SYSFIL		;GET SYSTEM FILE AND SHARES - SKIP IF WIN
	 JRST (TT)
	.CALL SHRLOD		;LOAD ALL PURE PAGES FROM THE FILE
	 .LOSE 1400
	.CLOSE TMPC,
	JRST 1(TT)
SHRLOD:	SETZ
	SIXBIT \LOAD\
	MOVEI %JSELF		;MYSELF
	MOVEI TMPC		;CHANNEL ON WHICH PURQIO/PURBIB IS OPEN'ED
	SETZI 0			;LOAD ONLY PURE PAGES
]		;END OF IFN ITS

FLSLSP: 
20$ 	JRST FLSNOT
IFN ITS,[
	.CALL SYSFIL		;IN ORDER TO FLUSH PAGES, WE MUST BE CERTAIN
	 JRST FLSNOT		; THAT WE CAN GET OURSELVES BACK!
	.CLOSE TMPC,
	.CALL PURCHK		;ONLY FLUSH IF LISP IS PURE
	 .VALUE
	JUMPLE TT,FLSNOT
	SETOM SAWSP		;FLAG THAT WE MUST READ OURSELVES FROM THE FILE
	MOVE T,[440100,,FLSTBL]	;POINTER INTO TABLE OF WHICH PAGES TO FLUSH
	SETZI TT,		;KEEP PAGE NUMBER IN TT
FLSPA4:	ILDB R,T		;GET INFO ON THIS PAGE
	JUMPE R,FLSPA5		;SKIP IF NOT FLUSHABLE
	CAIE TT,NFLSS/PAGSIZ	;NEVER FLUSH THE PAGES WE ARE ON
	 CAIN TT,NFLSE/PAGSIZ
	  JRST FLSPA5
	.CALL FLSPA6		;ELSE FLUSH THE PAGE FROM OUR PAGE MAP
	 .LOSE 1400
FLSPA5:	CAIGE TT,777777/PAGSIZ	;LOOP UNTIL HIGHEST PAGE NUMBER
	 AOJA TT,FLSPA4
	.SUSET FLSMSK		;MAKE SURE NO INTERRUPTS TRY TO HAPPEN
	PUSHJ P,PDUMPL		;PURE DUMP LISP IF SO DESIRED
	SKIPE (FLP)		;NIL JCL?
	 JRST SUSCON		;NOPE, RETURN T AND PROCEED
	SKIPE TT,(FXP)		;CHECK IF VALRET STRING
	 JRST FLSVAL		;YES, MUST VALRET IT THEN
	MOVE T,FXP
	SUB T,FLSADJ
	MOVEM T,(FXP)
	.VALUE FLSPA3		;PRINT SUSPENSION MESSAGE
	JRST SUSCON		;CONTINUING AFTER A SUSPEND

FLSVAL:	SKIPN VALFIX		;IS VALRET STRING REALLY A FIXNUM?
	 JRST FLSVA1		;NO, USE NORMAL VALRET
	HRRZ T,1(TT)		;PICKUP THE VALUE
	.BREAK 16,(T)		;DO THE .BREAK
	JRST SUSCON		;CONTINUE WHEN IT RETURNS, BUT RETURN T

FLSVA1:	.VALUE 1(TT)
	JRST SUSCON		;ON PROCEED, RETURN T

FLSADJ:	1,,1
FLSMSK:	.SMASK,,.+1
	0,,0

FLSPA6:	SETZ
	SIXBIT \CORBLK\
	MOVEI 0			;FLUSH THE PAGE
	MOVEI %JSELF		;FROM OURSELVES
	SETZ TT			;PAGE NUMBER IN TT

PURCHK:	SETZ
	SIXBIT \CORTYP\		;GET TYPE FOR CORE BLOCK
	  1000,,BSYSSG/PAGSIZ	;THAT FIRST SYSTEM PAGE IS ON
	402000,,TT		;>0 READ-ONLY, < 0 WRITABLE, = 0 NON-EXISTENT

SYSFIL:	SETZ			;FOR OPENING UP FILE TO SHARE
	SIXBIT \OPEN\
	     SYSCHN
	     SYSDEV
	     SYSFN1
	     SYSFN2
	SETZ SYSSNM

SYSCHN:	.UII,,TMPC

]	;END OF IFN ITS


;ROUTINE TO PDUMP A FILE WITH INDIRECT SYMBOL TABLE POINTER INCLUDED

IT% PDUMPL:	POPJ P,
IFN ITS,[
PDUMPL:	SKIPN PURDEV		;DID THE GUY WANT PURE DUMPING?
	 POPJ P,		;NOPE, RETURN RIGHT AWAY
	.CALL PUROPN		;OPEN THE FILE FOR PDUMP'ING
	 .LOSE 1400		;THE GUY LOST, OH WELL, WE ARE PROBABLY IN
				; A SUSPEND ANYWAY
	SETZ T,			;PDUMP REQUIRES AN INITALLY ZERO STATE WORD
	.CALL PDUMP		;DO THE ACTUAL PDUMP
	 .LOSE 1400
	.IOT TMPC,PURSTI	;OUTPUT START INSTRUCTION
	.IOT TMPC,PURISP	;INDIRECT SYMBOL TABLE POINTER INDICATOR
	MOVE TT,PURPTR		;POINTER TO FILENAMES
	MOVE T,PURISP		;START CHECKSUM
PURCKS:	ROT T,1
	ADD T,(TT)		;AND CHECKSUM FOR DDT
	.IOT TMPC,(TT)		;ALSO OUTPUT THE WORD TO THE FILE
	AOBJN TT,PURCKS
	.IOT TMPC,T		;OUTPUT THE CHECKSUM
	.IOT TMPC,PURSTI	;THEN AGAIN THE START ADR
	.CALL PURRWO		;RENAME TO CORRECT FILENAME
	 .LOSE 1400
	.CLOSE TMPC,		;FINISH UP WITH THE FILE
	POPJ P,

PUROPN:	SETZ
	SIXBIT \OPEN\
	     PURCHN
	     PURDEV
	     PUROP1
	     PUROP2
	SETZ PURSNM
	
PUROP1:	SIXBIT \.LISP.\
PUROP2:	SIXBIT \OUTPUT\

PURRWO:	SETZ
	SIXBIT \RENMWO\
	MOVEI TMPC
	     PURFN1
	SETZ PURFN2

PDUMP:	SETZ
	SIXBIT \PDUMP\
	MOVEI %JSELF
	MOVEI TMPC
	SETZ T

PURCHN:	.UIO,,TMPC
PURSTI:	JRST LISPGO
PURISP:	-4,,2
PURPTR:	-4,,SYSDEV

]		;END OF IFN ITS

PG$ NFLSE:



SUBTTL KILHGH AND GETHGH
IFN SAIL,[
E.START:	
	SETOM E.PHANTOM
	MOVEM 7,VEJOBNUM
	MOVEM 0,E.FIL
	MOVEM 1,E.EXT
	MOVEM 3,E.PPN
	MOVEM 6,E.DEV
	MOVE A,VT.ITY
	MOVEM A,VECALLEDP
	JRST  1(10)			;RETURN + 1

E.PHANTOM:	0
E.FIL:		SIXBIT \ EINIT\
E.EXT:		SIXBIT \INI\
E.PPN:		0
E.DEV:		SIXBIT \DSK\

]	;END OF IFN SAIL

IFN HISEGMENT,[
IFE SAIL,[
KILHG4:	OUTSTR [ASCIZ \
;Not flushing high segment - can't find .SHR file
\]
KILHG2:	MOVEI A,KILHG3		;THIS SHOULD BE START ADR IF NOT KILLING HS
	HRRM A,.JBSA
	MOVE 0,SGANAM		;IMPORTANT INFO INTO ACS IN CASE OF CONTINUE
	MOVE 11,SGADEV
	MOVE 7,SGAPPN
	EXIT 1,			;SUSPEND FOR A WHILE
KILHG3:	MOVEM 0,SGANAM
	MOVEM 11,SGADEV
	MOVEM 7,SGAPPN
	JRST RETHGH
]		;END IFE SAIL

KILHGH:	MOVEI A,GETHGH		;KILL HIGH SEGMENT
	HRRM A,.JBSA"		;SET START ADDRESS
IFE SAIL,[
	SKIPN SUSFLS
	 JRST KILHG2
	SKIPE SGANAM		;CAN'T FLUSH HIGH SEGMENT IF WE
	 SKIPN SGADEV		; DON'T KNOW WHEREFROM TO RETRIEVE IT
	  JRST KILHG4
	MOVSI A,1
	CORE A,			;FLUSH HIGH SEGMENT
	 JFCL
KILHG1:
]		;END OF IFE SAIL
IFN SAIL,[
	SKIPE SUSFLS
	SKIPN SGANAM
	 JRST KILHG1
	MOVEI A,FAKDDT		;FOO, HOW MANY WAYS CAN SAIL LOSE?
	SKIPN .JBDDT		; JOBDDT MUST BE NON-ZERO TO SAVE!
	 SETDDT A,		; OTHERWISE MAY FAIL TO SAVE ENTIRE LOSEG
	SETZ A,
	CORE2 A,		;FLUSH HIGH SEGMENT
	 HALT			;HOW CAN WE POSSIBLY LOSE? (HA HA)
	JRST KILHG2

KILHG1:	SKIPL .JBHRL
	 JRST KILHG2
	MOVEI A,1
	SETUWP A,
	 HALT
KILHG2:
]		;END OF IFN SAIL
	EXIT 1,			;"CONTINUE" WILL FALL INTO GETHGH
IFN SAIL,[
	JSP 10,E.START
]	;END OF IFN SAIL
GETHGH:
IFE SAIL,[
	MOVEI A,A+1		;SET UP TO GET HIGH SEG BACK
	MOVE A+1,SGADEV
	MOVE A+2,SGANAM
	MOVE A+3,SGAEXT
	MOVEI A+4,0
	MOVE A+5,SGAPPN
	SKIPE SGANAM
	 SKIPN SGADEV
	  JRST GETHG1
	GETSEG A,		;GET HIGH SEGMENT
	 JRST GLSLUA
GETHG1:
]		;END OF IFE SAIL
IFN SAIL,[
	JRST .+5		;DAMN RPG STARTUP ON SAIL
	RESET
	CLRBFI
	JRST .+2
	RESET
	SKIPE .JBHRL
	 JRST GETHG1
	MOVE T,SGANAM
	ATTSEG T,
	 SKIPA TT,SGADEV
	  JSP FREEAC,CHKHGH
	MOVEI T,.IODMP		;ON FAILURE, LOCK THE SHR FILE, THEN TRY AGAIN,
	SETZ D,			; AND ON FAILING MAKE THE HISEG OURSELVES
	OPEN TMPC,T		;OPEN UP .SHR FILE DEVICE IN DUMP MODE
	 HALT			;SOME MORON GAVE LOSING SECOND ARG TO SUSPEND?
	MOVE T,SGANAM
	MOVE TT,SGAEXT
	SETZ D,
	GETSTS TMPC,R		;GET CHANNEL STATUS WORD
	TRO R,1000		;FAST READ-ALTER
	SETSTS TMPC,(R)		;DO IT
	MOVE R,SGAPPN
	LOOKUP TMPC,T
	 JRST GLSLUA		;LOOK UP .SHR FILE
	MOVS F,R
	TRZ TT,-1		;WE NOW OPEN IT FOR READ-ALTER MODE FOR
	SETZ D,			; THE SOLE PURPOSE OF PREVENTING OTHER
	MOVE R,SGAPPN		; JOBS FROM READING IT TOO, THEREBY
	ENTER TMPC,T		; CAUSING WEIRD RACE CONDITIONS
	 JRST GLSLUA
	MOVE T,SGANAM
	ATTSEG T,		;SEE IF SOMEONE ELSE HAS SAME HISEG; THIS CAN
	 SKIPA T,F		; HAPPEN IF SOME OTHER JOB GETS THROUGH THIS
	  JSP FREEAC,CHKHGH	; CODE BETWEEN OUR FIRST ATTSEG AND THE ENTER
	MOVNS T			;T GETS LENGTH OF .SHR FILE
	ADD T,.JBREL
	HRR R,.JBREL		;MUST GOBBLE SOME COPIES OF .JBREL
	HRRZ TT,.JBREL		; BEFORE THE CORE UUO CHANGES IT
	CORE T,			;EXTEND LOSEG BY THIS AMOUNT
	 JRST GLSLZ1
	SETZ F,
	IN TMPC,R		;READ IN HISEG
	 SKIPA T,SGANAM
	  JRST LDSCRU
	TLO TT,HSGORG		;WRITE PROTECT HISEG
GETHG2:	REMAP TT,		;LET'S SPLIT
	 JRST GLSLZ3
GETHG1:
	MOVE T,SGANAM
       	SETNM2 T,
	 HALT
	RELEASE TMPC,		;FLUSH TEMP CHANNEL *AFTER* CREATING THE HISEG
]		;END OF IFN SAIL
RETHGH:	JRST .			;RETURN ADDR CLOBBERED IN HERE

GLSLUY:	SIXBIT \CANNOT GET HIGH SEGMENT!\
GLSLUA:	MOVEI C,GLSLUY
IFN SAIL,[
	RELEASE TMPC,
	TLZ TT,-1
	CAIE TT,ERFBM%		;COLLISION DUE TO LOCKOUT?
	 JRST GLSLZ0		;NO, GENUWINE LOSSAGE
	PJOB TT,		;THIS IS ALL PRETTY RANDOM - WE'RE
	IDIVI TT,7		; TRYING JUST A LITTLE BIT TO SOLVE
	SLEEP D,		; THE HAIRY RACE CONDITIONS (ALOHA!)
	JRST GETHGH

CHKHGH:	MOVE D,SGAPPN
   	CAME D,PSGPPN
	 JRST GLSLZ4
   	MOVE D,SGADEV
	CAME D,PSGDEV
	 JRST GLSLZ4
	MOVE D,SGAEXT
	CAME D,PSGEXT
	 JRST GLSLZ4
	MOVE D,SGANAM		;CHECK HISEG VALIDATION WORDS
	CAME D,PSGNAM
 	 JRST GLSLZ4
	JRST GETHG1
	
GLSLZ4:	SETZ T,			;WRONG HISEG, SO ZERO IT OUT AND START AGAIN
	CORE2 T,
	 JRST GLSLZ1
	MOVE TT,SGADEV
	MOVE T,F
	JRST (FREEAC)

GLSLZ0:
]		;END OF IFN SAIL
	HRLI C,440600		;WILL READ A SIXBIT STRING
GLSLZA:	ILDB T,C		;READ STRING AND TYPE IT
	ADDI T," "		;CONVERT TO ASCII
	OUTCHR T
	CAIE T,"!"		;STOP AFTER EXCLAMATION-POINT
	 JRST GLSLZA
	EXIT			;FOO

IFN SAIL,[

GLSLZ1:	OUTSTR GLSLM1
	EXIT
GLSLM1:	ASCIZ \?CORE UUO LOST
\

GLSLZ2:	OUTSTR GLSLM2
	EXIT
GLSLM2:	ASCIZ \?IN UUO LOST
\

GLSLZ3:	OUTSTR GLSLM3
	JRST GETHG2
GLSLM3:	ASCIZ \?REMAP lost -- no job slots available, retrying
\
]		;END OF IFN SAIL


SGANAM:
SA%	0			;THESE ARE THE SAVED NAMES FOR GETTING
SA$	SIXBIT \MACLSP\
SGADEV:
SA%	0			; THE HIGH SEGMENT BACK AFTER SUSPENSION
SA$	SIXBIT \SYS\
SGAPPN:	0			.SEE SUSPEND
SGAEXT:	SIXBIT \SHR\		;SOME LOSER MIGHT WANT TO CHANGE THIS


;;; CODE FOR FASLOAD TO READ IN A NEW HIGH SEGMENT.
;;; THIS CODE MUST BE IN THE LOW SEGMENT!
;;; T HAS LENGTH OF THE .SHR FILE; LH(R) HAS NEGATIVE OF THIS.

LDRIHS:
IFE SAIL,[
	MOVSI TT,1
	CORE TT,		;FLUSH OLD HIGH SEGMENT
	 JRST LDSCRU
	HRRZ TT,.JBREL		;CURRENT HIGHEST ADDRESS IN LOSEG
	HRRZ D,.JBREL
	HRR R,.JBREL
	ADD TT,T
	CORE TT,		;EXPAND LOSEG SO CAN HOLD COPY OF HISEG
	 JRST LDSCRU		; (REMEMBER, CAN'T DO I/O INTO HISEG!)
	SETZ F,
	IN TMPC,R		;READ IN .SHR FILE
	 CAIA
	  JRST LDSCRU
	REMAP D,		;NOW MAKE A HISEG FROM THE READ-IN CODE
	 JRST LDSCRU
	SETUWP F,		;TOPS-10 PROTECTS US FROM OURSELVES,
	 JRST LDSCRU		; SO WE MUST MAKE HISEG WRITABLE (F IS ZERO)
	SETZM SGANAM		;WE NO LONGER KNOW THE HIGHSEG NAME!
				;IF THIS IS NON-ZERO, HIGH-SEG GETS FLUSHED
				; DURING (SUSPEND) AND ALL THE STUFF WE'VE
				; DONE TO IT GOES BYEBYE! (ARG!)
	POPJ P,
]		;END OF IFE SAIL
IFN SAIL,[
	SETZ TT,
	CORE2 TT,		;FLUSH OLD HIGH SEGMENT
	 JRST LDSCRU
LDRHS1:	CORE2 T,		;MAKE A NEW (WRITABLE) HISEG THAT BIG
	 JRST LDSCRU
	MOVE T,D10NAM		;USE D10NAM AS HISEG NAME TO MAKE HISEG UNIQUE
	LSH T,-6		;AS LONG AS WE'RE BEING RANDOM...
	SETNM2 T,		;TRY TO SET NAME FOR HIGH SEGMENT
	 JFCL
	HLRE T,R		;GET WORD COUNT SING EXTENDED
	MOVMS T			;AND MUST GET A HI-SEG THAT BIG
	HRRI R,HSGORG-1
	SETZ F,
	IN TMPC,R		;READ IN HISEG
	 POPJ P,		;RETURN TO CODE IN HISEG
]		;END OF IFN SAIL
LDSCRU:	OUTSTR [ASCIZ \DEPURIFYING HISEG LOST - YOU ARE STRANDED!
\]
SA%	EXIT
SA$	JRST LDRHS1

]		;END OF IFN HISEGMENT


SUBTTL	LOBITSG TEST

CONSTANTS

;;; NO MORE CONSTANTS PERMITTED AFTER THIS IN THE LOSEG (WRITEABLE FIRST PAGE)


IF1,[
    ZZ==.
    LOBITSG==0		;NON-ZERO ==> BITSGS ARE LOW
    PAGEUP
    TOP.PG==.
    IFGE TOP.PG-ZZ-SEGSIZ,[	;SEE IF THERE IS ANOTHER SEGMENT LEFT ON THIS PAGE
	SEGUP ZZ
	SPCTOP ZER,SYS,["ZERO" (LOW IMPURE)]
	SPCBOT BIT
	BTBLKS:	BLOCK BTSGGS*SEGSIZ-1
	SEGUP .
	SPCTOP BIT,ST,[BIT BLOCK]
	IFE TOP.PG-., LOBITSG==1
	.ELSE,[
		WARN [LOBITSG STUFF DIDN'T WORK]
		EXPUNGE NZERSG NBITSG BBITSG
		EXPUNGE BTBLKS
		LOBITSG==0
	]	    ;END OF .ELSE
    ]	;END OF	IFGE TOP.PG-ZZ-SEGSIZ
]	;END OF IF1
IF2,[
IFN PAGING, PAGEUP
IFE PAGING, SEGUP .
]	;END OF IF2

IFE LOBITSG,	SPCTOP ZER,SYS,["ZERO" (LOW IMPURE)]
PG%	EXPUNGE BZERSG
	EXPUNGE TOP.PG


SUBTTL SEGMENT TABLES

;;; FORMAT OF SEGMENT TABLE (<NSEGS> WORDS, ONE FOR EACH SEGMENT)
;;;	4.9	LS	1=LIST STRUCTURE, 0=ATOMIC 
;;;	4.8	$FS	FREE STORAGE (BIT 4.9 SHOULD BE ON ALSO)
;;;	4.7	FX	FIXNUM STORAGE
;;;	4.6	FL	FLONUM STORAGE
;;;	4.5	BN	BIGNUM HEADER STORAGE
;;;	4.4	SY	SYMBOL HEADER STORAGE
;;;	4.3	SA	SAR STORAGE (BIT 3.8 SHOULD BE ON ALSO)
;;;	4.2	VC	VALUE CELL STORAGE (BIT 4.9 SHOULD BE ON ALSO)
;;;	4.1	$PDLNM	NUMBER PDL AREA
;;;			(ONE OF THE NUMBER TYPE BITS SHOULD BE ON ALSO)
;;;	3.9		RESERVED - AVOID USING (FORMERLY $FLP)
;;;	3.8	$XM	EXISTENT (RANDOM) AREA
;;;	3.7	$NXM	NONEXISTENT (RANDOM) AREA
;;;	3.6	PUR	PURE SPACE (ONE OF BITS 4.8-4.5 OR 3.8 SHOULD BE ON)
;;;	3.5	HNK	HUNK OF ONE KIND OR ANOTHER (BIT 4.9 ON ALSO)
;;;	3.4	DB	DOUBLE-PRECISION FLONUMS		;THESE ARE
;;;	3.3	CX	COMPLEX NUMBERS				; NOT YET
;;;	3.2	DX	DOUBLE-PRECISION COMPLEX NUMBERS	; IMPLEMENTED
;;;	3.1		UNUSED
;;;	2.9-1.1	ADDRESS OF A DATA TYPE, ATOM:
;;;		    QLIST, QFIXNUM, QFLONUM, QBIGNUM,
;;;			 QSYMBOL, QRANDOM, QARRAY, QHUNK<N>
;;;		NOTE THAT THESE ATOMS OCCUPY CONSECUTIVE MEMORY
;;;		LOCATIONS AND THUS NUMERICALLY ENCODE THE PAGE TYPE.

;;; THIS COMMENT SHOULD BE KEPT CONSISTENT WITH THE DEFINITIONS (IN THE
;;;  DEFNS FILE) FOR THE ABOVE SYMBOLS, AND WITH LOCATION PSYMTT.
.SEE LS
.SEE PSYMTT

SPCBOT ST

ST:				;SEGMENT TABLE
    IFE PAGING,	BLOCK NSEGS	;FOR PAGING SYSTEM, CODE IN INIT SETS UP
				; THESE TABLES AT RUN TIME.
    IFN PAGING,[
	IF1, 	BLOCK NSEGS
	IF2,[	
	STDISP:	EXPUNGE STDISP		;FOR .SEE
		$ST ZER,$XM		;"ZERO" (LOW IMPURE) SEGMENTS
	IFN LOBITSG, $ST BIT,$XM	;BIT BLOCKS
		$ST ST,$XM		;SEGMENT TABLES
		$ST SYS,$XM+PUR		;SYSTEM CODE
		$ST SAR,SA		;SARS (ARRAY POINTERS)
		$ST VC,LS+VC		;VALUE CELLS
		$ST XVC,$NXM		;RESERVED FOR EXTRA VALUE CELLS
		$ST IS2,$XM		;IMPURE SYMBOL BLOCKS
		$ST SYM,SY		;SYMBOL HEADERS
		$ST XXA,$XM		;SLACK SEGMENTS (IMPURE!)
		$ST XXZ,$NXM		;SLACK SEGMENTS (INITIALLY NXM)
		$ST SY2,$XM+PUR		;PURE SYMBOL BLOCKS
		$ST PFX,FX+PUR		;PURE FIXNUMS
		$ST PFS,LS+$FS+PUR	;PURE FREE STORAGE (LIST)
		$ST PFL,FL+PUR		;PURE FLONUMS
		$ST XXP,$XM+PUR		;SLACK PURE SEGMENT (FOOEY!)
		$ST IFS,LS+$FS		;IMPURE FREE STORAGE (LIST)
		$ST IFX,FX		;IMPURE FIXNUMS
		$ST IFL,FL		;IMPURE FLONUMS
	IFN BIGNUM, $ST BN,BN		;BIGNUMS
		$ST XXB,$XM		;SLACK SEGMENTS (IMPURE!)
	IFE LOBITSG, $ST BIT,$XM	;BIT BLOCKS
		$ST BPS,$XM		;BINARY PROGRAM SPACE
		$ST NXM,$NXM		;(INITIALLY) NON-EXISTENT MEMORY
		$ST FXP,FX+$PDLNM	;FIXNUM PDL
		$ST XFXP,$NXM		;FOR FXP EXPANSION
		$ST FLP,FL+$PDLNM	;FLONUM PDL
		$ST XFLP,$NXM		;FOR FLP EXPANSION
		$ST P,$XM		;REGULAR PDL
		$ST XP,$NXM		;FOR P EXPANSION
		$ST SP,$XM		;SPECIAL PDL
		$ST XSP,$NXM		;FOR SP EXPANSION
		$ST SCR,$NXM		;SCRATCH SEGMENTS
	.HKILL ST.ZER
	IFN ST+NSEGS-., WARN \.-ST,[=WRONG SEGMENT TABLE LENGTH (SHOULD BE ]\NSEGS,[)]
	]	;END IF2
    ]		;END IFN PAGING






;;; THE FORMAT OF THE GARBAGE COLLECTOR SEGMENT TABLE IS RATHER HAIRY, SINCE
;;; THE SIZES AND POSITIONS OF ALL FIELDS IN EACH WORD ARE DEPENDENT ON THE
;;; SEGMENT SIZE. THE LOW ORDER <22-<SEGLOG-5>> BITS OF EACH ENTRY CONTAIN
;;; THE HIGH BITS OF THE ADDRESS OF THE BLOCK OF BITS TO BE USED IN MARKING
;;; THAT SEGMENT. (NOTE THAT THE OMITTED LOW-ORDER BITS OF THIS ADDRESS ARE
;;; ZERO ANYWAY.) THESE ADR BITS ARE IN THIS STRANGE RIGHT-ADJUSTED POSITION
;;; FOR THE CONVENIENCE OF THE GCMARK ROUTINE (Q.V.). NOT ALL SEGMENTS HAVE
;;; BIT BLOCKS; THOSE WHICH DO NOT HAVE A BIT BLOCK HAVE ZERO IN THIS FIELD.
;;; TO THE LEFT OF THIS BIT BLOCK ADDRESS FIELD IS A FIELD OF <22-SEGLOG> BITS;
;;; THIS CONTAINS THE NUMBER OF THE NEXT SEGMENT IN THE TABLE OF THE SAME TYPE.
;;; (NOT ALL SEGMENTS ARE LINKED IN THIS WAY; THOSE SEGMENTS WHICH ARE NOT
;;; LINKED TO ANOTHER ONE HAVE THIS FIELD ZERO.) THE HIGH-ORDER BIT (BIT 4.9)
;;; IS ONE IFF GCMARK SHOULD MARK (PERHAPS NOT WITH A BIT BLOCK) THE CONTENTS
;;; OF THE SEGMENT. THE BIT 22 BIT POSITIONS TO THE LEFT OF THE HIGH-ORDER
;;; BIT OF THE BIT BLOCK ADDRESS FIELD IS ONE IFF GCMARK SHOULD MARK FROM THE
;;; CDR OF AN OBJECT IN THE SEGMENT; THIS BIT IS MEANINGFUL ONLY IF BIT 4.9
;;; IS ONE. THE BIT TO THE RIGHT OF THE CDR BIT IS ONE IFF GCMARK SHOULD ALSO
;;; MARK FROM THE CAR OF AN OBJECT IN THE SEGMENT; THIS BIT IS MEANINGFUL ONLY
;;; IF THE CDR BIT IS ONE.  THESE THREE BITS MUST BE IN THESE EXACT POSITIONS,
;;; AGAIN FOR THE CONVENIENCE OF GCMARK (Q.V.). THE OTHER BITS IN EACH WORD
;;; ARE ARRANGED AS TO USE UP FREE BITS FROM THE LEFT END OF THE WORD, PACKED
;;; IN AROUND THE THREE BITS ALREADY DESCRIBED. THESE BITS INDICATE WHETHER
;;; OR NOT THE SEGMENT CONTAINS VALUE CELLS, SYMBOLS, OR SARS.


GCBMRK==400000		;THESE ARE ALL LEFT HALF FLAGS
GCBCDR==1_<22-<SEGLOG-5>-1>
GCBCAR==GCBCDR_-1

GCB==1,,525252			;FOR BIT TYPEOUT MODE
ZZZ==400000
GCBFOO==0
IRPS NAM,X,[VC+SYM+SAR+HNK ]
ZZZ==ZZZ_-1
IFN ZZZ&GCBCDR, ZZZ==ZZZ_-2
GCB!NAM==ZZZ
IFSE X,+, GCBFOO==GCBFOO\ZZZ
TERMIN

IFG GCBHNK-GCBCAR, WARN [GCMARK WILL LOSE ON HUNKS]





GCST:				;GC SEGMENT TABLE
    IFE PAGING, BLOCK NSEGS	;FOR PAGING SYSTEM,
				; THE GCST TABLE IS SET UP AT RUN TIME BY INIT.
    IFN PAGING,[
	IF1, BLOCK NSEGS
	IF2,[
	BTB.==BTBLKS		;LOCATION COUNTER FOR ASSIGNING BIT BLOCKS
		$GCST ZER,,,0
	IFN LOBITSG, $GCST BIT,,,0
		$GCST ST,,,0
		$GCST SYS,,,0
		$GCST SAR,L,,GCBMRK+GCBSAR
		$GCST VC,,,GCBMRK+GCBVC
		$GCST XVC,,,0
		$GCST IS2,L,,0
		$GCST SYM,L,,GCBMRK+GCBSYM
		$GCST XXA,L,,0
		$GCST XXZ,,,0
		$GCST SY2,,,0
		$GCST PFX,,,0
		$GCST PFS,,,0
		$GCST PFL,,,0
		$GCST XXP,,,0
		$GCST IFS,L,B,GCBMRK+GCBCDR+GCBCAR
		$GCST IFX,L,B,GCBMRK
		$GCST IFL,L,B,GCBMRK
	IFN BIGNUM, $GCST BN,L,B,GCBMRK+GCBCDR
	LXXBSG==LXXASG
		$GCST1 NXXBSG,XXB,L,,0
	IFE LOBITSG, $GCST BIT,,,0
		$GCST BPS,,,0
		$GCST NXM,,,0
		$GCST FXP,,,0
		$GCST XFXP,,,0
		$GCST FLP,,,0
		$GCST XFLP,,,0
		$GCST P,,,0
		$GCST XP,,,0
		$GCST SP,,,0
		$GCST XSP,,,0
		$GCST SCR,,,0
	.HKILL GS.ZER
	IFN GCST+NSEGS-., WARN \.-GCST,[=WRONG GC SEGMENT TABLE LENGTH (SHOULD BE ]\NSEGS,[)]
	]	;END IF2
    ]	;END OF IFN PAGING

PAGEUP

SPCTOP ST,,[SEGMENT TABLE]






IFN PAGING, SPCBOT SYS
10$	$HISEG
10$	HILOC==.		;ORIGIN OF HIGH SEGMENT

SA$ PSGNAM: 0			;THESE LOCATIONS FOR SAIL HISEG VALIDATION
SA$ PSGDEV: 0
SA$ PSGEXT: 0
SA$ PSGPPN: 0

SUBTTL	BEGINNING OF PURE LISP SYSTEM CODE

	PGBOT ERR

;;; THESE CONSTANTS ARE BUILT INTO THE COMPILER.
;;; THEY MUST BE DEFINED HERE FOR THE BENEFIT OF THE PUSHN MACRO.
.SEE PUSHN

NNPUSH==:20		.SEE NPUSH
N0PUSH==:10		.SEE 0PUSH
N0.0PUSH==:10		.SEE 0.0PUSH


BPURPG==:.	;BEGINNING OF PURE PAGES FOR INSERT FILE PAGE AND PURIFY
	$$$NIL:	777300,,VNIL		;SYMBOL BLOCK FOR NIL
		0,,$$NIL		;ALWAYS KEEP ON FIRST PURE SYSTEM PAGE

$INSRT ERROR		;ERROR MSGS AND HANDLERS

;;; ERROR FILE HAS DEFINITION FOR BEGFUN

	PGTOP ERR,[ERROR HANDLERS AND MESSAGES]

	PGBOT TOP
;;; LISPGO HAS BEEN MOVED SO IT WILL STAY IN CORE WHEN PURE PAGES ARE FLUSHED
;;;  AT SUSPEND TIME AS CONTROLLED BY THE SUSFLS FLAG.

SUBTTL	BASIC TOP LEVEL LOOP

;;;	(DEFUN STANDARD-TOP-LEVEL ()
;;;	  (PROG (^Q ^W ^R EVALHOOK BASE IBASE ...)
;;;	   ERROR		;ERRORS, UNCAUGHT THROWS, ETC. COME HERE
;;;	   ^G		;^G QUITS COME HERE
;;;	        (RESET-BOUND-VARIABLES-AND-RESTORE-PDLS)
;;;		(SETQ ^Q NIL)
;;;		(SETQ ^W NIL)
;;;		(SETQ EVALHOOK NIL)
;;;		(NOINTERRUPT NIL)
;;;		(DO-DELAYED-TTY-AND-ALARMCLOCK-INTERRUPTS)
;;;		 ;RECALL THAT ERRORS DO (SETQ // ERRLIST)
;;;		(MAPC (FUNCTION EVAL) //)
;;;		(OR (TOP-LEVEL-LINMODE) (TERPRI))
;;;		(DO ((PRT '* *))
;;;		    (NIL)		;DO FOREVER (UNTIL ERROR OR ^G QUIT)
;;;		  (SETQ * (COND ((STATUS TOPLEVEL)
;;;				 (EVAL (STATUS TOPLEVEL)))
;;;			        ((PROG () 
;;; 				    (READ-EVAL-*-PRINT PRT)		;print
;;;				    (READ-EVAL-PRINT-*)			;terpri
;;; 				  A (SETQ TEM (*-READ-EVAL-PRINT))	;read
;;; 				    (AND (EQ TEM <INTERNAL-EOF-MARKER>)
;;; 			 		 (PROG2 (TERPRI) (GO A))) 
;;;				    (RETURN (READ-*-EVAL-PRINT TEM)))))) ;eval
;;; 		)))


LSPRET:	PUSHJ FXP,ERRPOP
	MOVE P,C2		;RETURN TO TOP LEVEL BY ERR, THROW, AND ERRORS
LSPRT1:	JSP T,TLVRSS		;RETURN TO TOP BY ^G
	JSP A,ERINIT
	SETZ A,			;NEED A NIL IN A FOR CHECKU
	PUSHJ P,CHECKU		;CHECK FOR DELAYED "REAL TIME" INTS
	MOVEI A,QOEVAL
	SKIPE B,VIQUOTIENT	;SHADES OF ERRLIST!!!
	CALLF 2,QMAPC
HACENT:	PUSH P,FLP		.SEE PDLCHK
	PUSH P,FXP
	PUSH P,SP
	PUSH P,LISP1		;ENTRY FROM LIHAC
	HRRZ F,VINFILE		;ONLY PRINT FIRST ASTERISK IF NO INIT FILE
	AOSN TOPAST		;IS THIS THE FIRST TIME?
	 CAIE F,INIIFA
	  SKIPA			;NOT (INIT-FILE AND FIRST-TIME)
	   JRST LISP2B
	PUSH P,[Q.]
	JSP F,LINMDP
	 PUSHJ P,ITERPRI
	JRST LISP2		;KLUDGE SO AS NOT TO MUNG *

LISP1:	PUSH P,LISP1		;******* BASIC TOP LEVEL LOOP *******
	HRRZM A,V.		;THE SYMBOL * GETS AS ITS VALUE THE
	PUSH P,A
LISP2:	JSP T,TLVRSS		; RESULT OF THE LAST TOP-LEVEL EVAL
	POP P,B
	SKIPN A,TLF
	 JRST LISP2A
	HRRZ TT,-3(P)
	HRRZ D,-2(P)
	HRRZ R,-1(P)
	PUSHJ P,PDLCHK		;CHECK PDL LEVELS FOR ERRORS
	JRST EVAL

LISP2A:	MOVEI A,(B)
	PUSHJ P,TLPRINT		;PRINT THE LAST OUTPUT FORM
	HRRZ TT,-3(P)
	HRRZ D,-2(P)
	HRRZ R,-1(P)
	PUSHJ P,PDLCHK		;CHECK PDL LEVELS FOR ERRORS
	PUSHJ P,TLTERPRI	;OUTPUT A TERPRI
LISP2B:	PUSHJ P,TLREAD		;READ AN INPUT FORM
	 JRST TLEVAL		;EVALUATE IT, RETURNING TO LISP1 IF NO EOF
	SETZ AR1,
	PUSHJ P,TERP1
	JRST LISP2B		; LOOP BACK AFTER EOF-PROCESSED EXIT


;;;	(DEFUN STANDARD-IFILE ()
;;;	       (COND ((OR (NULL ^Q) (EQ INFILE 'T)) TYI)
;;;		     ('T INFILE)))

STDIFL:	HRRZ A,VINFILE
	SKIPE TAPRED
	 CAIN A,TRUTH
	  HRRZ A,V%TYI
	POPJ P,


;;; 	(DEFUN READ-EVAL-PRINT-* ()		;TOP-LEVEL-TERPRI
;;; 	   (AND READ-EVAL-PRINT-* 
;;; 		(FUNCALL READ-EVAL-PRINT-*))
;;;	   ((LAMBDA (IFILE)
;;;		    (AND (TTYP IFILE)
;;;			 (TOP-LEVEL-TERPRI-X (STATUS LINMODE IFILE)
;;;					     (STATUS TTYCONS IFILE))))
;;; 		(STANDARD-IFILE)))
;;;
;;;	(DEFUN TOP-LEVEL-TERPRI-X (LM OFILE)
;;;	       (AND OFILE
;;;		    (COND ((EQ OFILE TYO)
;;;			   (TERPRI (CONS T (AND ^R OUTFILES))))
;;;			  (T (OR LM ^W (TERPRI OFILE))))))


TLTERPRI:
	SKIPE B,VTLTERPRI	;CHECK FOR USER'S INTERCEPT FUNCTION
	 CALLF 0,(B)	
	PUSHJ P,STDIFL		;GET STANDARD INPUT FILE
	MOVE C,A
	JSP F,STBIDP		;IF INPUT FILE IS BI-DIRECTIONAL
	 POPJ P,		; THEN WE WANT TO TERPRI IT
	MOVEI TT,F.MODE		;HAS LEFT INPUT'S TTYCONS IN C
	MOVE F,@TTSAR(A)

;TOP-LEVEL-TERPRI-X; TTYCONS IN C, F.MODE IN F,
TLTERX:	CAME C,V%TYO
	 JRST TLTER1
	SKIPE AR1,TAPWRT	;IF SAME AS TYO, TERPRI TO
	 HRRZ AR1,VOUTFILES	; STANDARD OUTPUT FILES
	JRST TERP1

TLTER1:	TLNN F,FBT.LN		;IF INPUT FILE NOT IN LINMODE,
	 SKIPE TTYOFF		; AND ^W IS NOT SET,
	  POPJ P,		; TERPRI TO JUST THE TTYCONS FILE
	TLO AR1,-1
	JRST TERP1



;;; 	(DEFUN *-READ-EVAL-PRINT ()		;TOP-LEVEL-READ
;;;	       (AND *-READ-EVAL-PRINT 
;;; 		    (FUNCALL *-READ-EVAL-PRINT))
;;;	       (DO ((EOF (LIST 'TLRED1)) (IFILE) (FORM))
;;;		   (NIL)				     ;DO UNTIL RETURN
;;;		   (SETQ IFILE (STANDARD-IFILE IFILE))
;;;		   (SETQ FORM (COND (READ (FUNCALL READ EOF)) 
;;; 				    ('T   (READ EOF))))
;;;		   (COND ((NOT (EQ FORM EOF))
;;;			  (AND (NULL READ)
;;;			       (ATOM FORM)
;;;			       (IS-A-SPACE (TYIPEEK))
;;;			       (TYI))
;;;			  (RETURN FORM)))
;;;		   (COND ((TTYP IFILE)
;;;			  (TOP-LEVEL-TERPRI-X () (STATUS TTYCONS IFILE)))
;;; 			 ('T (RETURN <INTERNAL-EOF-MARKER>)))))


$TLREAD: PUSHJ P,TLREAD
	  POPJ P,
	SETZ AR1,
	PUSHJ P,TERP1	
	JRST $TLREAD

TLREAD:	SKIPE B,V$TLREAD	;CHECK FOR USER'S INTERCEPT FUNCTION,
	 CALLF 0,(B)		; AND RUN IT.
	PUSHJ P,STDIFL		;GET STANDARD INPUT FILE AS OF
	PUSH P,A		; *BEFORE* THE READ, AND SAVE IT
	PUSHJ P,[PUSH P,(P)	;ARGUMENT FOR RANDOM EOF VALUE
		 MOVNI T,1	;READ THE FORM (POSSIBLY USING USER'S READ)
		 SKIPE VOREAD	; AND POSSIBLY POPPING INSTACK INTO INFILE
		  JCALLF 16,@VOREAD
		 JRST OREAD]

TLRED1:	POP P,C
	CAIE A,TLRED1
	 JRST TLREDF
	JSP F,STBIDP		;GET BI-DIRECTIONAL ASSOCIATE, IF IT EXISTS,
	 JRST POPJ1		; OF STREAM IN B INTO AR1
	SETZ F,			;EOF ON TTY MEANS OVER-RUBOUT, SO
	PUSHJ P,TLTERX		; TERPRI ON ASSOCIATED OUTPUT TTY
	JRST TLREAD		; AND TRY AGAIN

TLREDF:	SKOTT A,LS		;SPCFLS - FLUSH A <SPACE> TERMINATING AN ATOM
	 SKIPE VOREAD
	  POPJ P,		;NORMAL EXIT - NO EOF, NO SKIP
	PUSH P,A
	MOVEI T,0			;PEEL OFF A SPACE, IF THAT
	PUSHJ P,TYIPEEK+1		;WAS WHAT TERMINATED THE ATOM
	MOVE T,VREADTABLE
	MOVE TT,@TTSAR(T)
	MOVEI T,0
	TLNE TT,100000			;WORTHLESS CHAR, OR SPACE ETC.
	 PUSHJ P,%TYI
	JRST POPAJ

;;; 	(DEFUN READ-*-EVAL-PRINT (FORM)		;TOP-LEVEL-EVAL
;;; 	       (AND READ-*-EVAL-PRINT 
;;; 		    (FUNCALL READ-*-EVAL-PRINT  FORM))
;;;	       (SETQ - FORM)
;;;	       ((LAMBDA (+)
;;;			(PROG2 NIL
;;;			       (EVAL +)
;;;			       (AND (OR (CAR NIL) (CDR NIL))
;;;				    (ERROR '|NIL CLOBBERED|
;;;					   (PROG2 NIL
;;;						  (CONS (CAR NIL) (CDR NIL))
;;;						  (RPLACA NIL NIL)
;;;						  (RPLACD NIL NIL))
;;;					   'FAIL-ACT))))
;;;		(PROG2 NIL + (SETQ + (COND ((EQ - '+) +) ('T -))))))

TLEVAL:	SKIPE B,VTLEVAL		;CHECK FOR USER'S INTERCEPT FUNCTION
	 CALLF 1,(B)
	MOVEM A,VIDIFFERENCE	;THE SYMBOL - GETS THE TYPED-IN
	CAIN A,QIPLUS
	 SKIPA B,VIPLUS
	  MOVEI B,(A)		; EXPRESSION AS ITS VALUE AND KEEPS IT
	EXCH B,VIPLUS		;THE SYMBOL + GETS THE THE TYPED-IN
	JSP T,SPECBIND		; EXPRESSION AS ITS VALUE, BUT NOT
	0 B,VIPLUS		; UNTIL AFTER IT HAS BEEN EVALUATED.
CEVAL:	PUSHJ P,EVAL		;SPECBINDING IT ENSURES THAT IT WILL
	JUMPE UNBIND		; GET THIS VALUE IN SPITE OF ERRORS.
	PUSH P,CUNBIND
NILBAD:	PUSH P,A		;FOO!  WELL, ERROR HANDLING SAVES
	PUSH P,CPOPAJ		;ALL ACS IN CASE YOU WANT TO CONTINUE
	MOVS A,NIL
CSETZ:	SETZ NIL,		;NIL=0!  CAN USE THIS AS A CONSTANT WORD
	PUSHJ P,ACONS
	%FAC [SIXBIT \NIL CLOBBERED!\]


;;; PUSHJ HERE WITH PROPER VALUES FOR THE RIGHT HALVES
;;; OF <FLP, FXP, SP> IN <TT, D, R>.  WILL ERROR OUT
;;; IF THEY DON'T MATCH UP.  USED FOR TRAPPING GROSS
;;; ERRORS IN THE SYSTEM.

PDLCHK:	SETZ T,
	CAIE TT,(FLP)
	 MOVEI T,QFLPDL
	CAIE D,(FXP)
	 MOVEI T,QFXPDL
	CAIE R,(SP)
	 MOVEI T,QSPECPDL
	JUMPE T,CPOPJ		;EVERYBODY HAPPY?
PDLCRP:	MOVEI A,(T)		;NO, PDL CRAP-OUT
	LER3 [SIXBIT \OUT OF PHASE (SYSTEM ERROR)!\]


;;;	(DEFUN TOP-LEVEL-LINMODE ()
;;;	   ((LAMBDA (FL)
;;; 		    (COND ((AND (TTYP FL) (STATUS LINMODE FL))
;;; 			   FL)))
;;; 	      (STANDARD-IFILE INFILE)))

;;; SKIP IF  INFILE  IS IN LINE MODE.
;;; ALSO LEAVE OUTFILES IN AR1 AND READTABLE IN AR2A.
;;; FURTHERMORE LEAVE INPUT FILE IN C (SEE TLPRINT).
;;; ALSO LEAVE TTSAR OF INPUT FILE IN T.

LINMDP:	JSP T,GTRDTB
	HRRZ C,VINFILE
	SKIPE TAPRED
	 CAIN C,TRUTH
	  HRRZ C,V%TYI
	SKIPE AR1,TAPWRT
	 HRRZ AR1,VOUTFILES
SFA$	HRLZI TT,AS.SFA		;SFAS ARE NEVER IN LINE MODE
SFA$	TDNE TT,ASAR(C)
SFA$	 JRST (F)		;RETURN NON-LINEMODE
XCTPRO
	MOVE T,TTSAR(C)
	MOVE TT,F.MODE(T)
NOPRO
	TLNE T,TTS.TY
	 TLNN TT,FBT.LN		;ONLY A TTY CAN HAVE LINMODE SET
	  JRST (F)		;TYPICALLY RETURN TO AN ITERPRI
	 JRST 1(F)		; OR SKIP OVER IT

;;; 	(DEFUN READ-EVAL-*-PRINT (OBJ)		;TOP-LEVEL-PRINT
;;; 	   (AND READ-EVAL-*-PRINT 
;;; 		(FUNCALL READ-EVAL-*-PRINT  OBJ))
;;; 	   ((LAMBDA (FL)
;;;		    (COND ((OR (NULL FL) (NOT (EQ (STATUS TTYCONS FL) TYO)))
;;;			   (TERPRI IFILE)))
;;;		    (COND (PRIN1 (FUNCALL PRIN1 OBJ)) ('T (PRIN1 OBJ)))
;;;		    (TYO 32.))		;<SPACE>
;;; 		(TOP-LEVEL-LINMODE)))


TLPRINT:
	SKIPE C,VTLPRINT	;CHECK FOR USER'S INTERCEPT FUNCTION
	 CALLF 1,(C)
	PUSH P,A		;TOP-LEVEL PRINT
	JSP F,LINMDP		;LEAVES INPUT FILE IN C, VOUTFILES in AR1
	 JRST TLPR1
	JSP F,STBIDP		;BI-DIRECTIONAL?
	 JRST TLPR1		;NO, SO GO AHEAD AND TERPRI
	CAME C,V%TYO		;IF ASSOCIATED CHANNEL  IS TYO, THEN DON'T
				; OUTPUT THE <CR> SINCE ECHOING WILL DO
TLPR1:	  PUSHJ P,ITERPRI
TLPR1A:	MOVE A,(P)
	PUSHJ P,IPRIN1
	MOVEI A,40
	PUSHJ P,TYO
	JRST POPAJ

IPRIN1:	SKIPN V%PR1
	 JRST PRIN1
	JCALLF 1,@V%PR1


;; FOR A "BI-DIRECTIONAL" STREAM, GET THE "ASSOCIATE" STREAM INTO C
;;  FOR TTYS, THIS IS JUST (STATUS TTYCONS)
STBIDP:	HRLZI TT,AS.SFA		
	TDNE TT,ASAR(C)		;ENTER WITH STREAM IN C
	 JRST [	MOVEI TT,SR.CNS		;IF SFA, THEN GET THE TTYCONS SLOT 
		HLRZ C,@TTSAR(C)
		JRST STBD1 ]
	MOVE T,TTSAR(C)		;PICK UP THE TTSAR
	TLNN T,TTS.TY
	 JRST (F)		;PLAIN EXIT, NO SKIP, FOR NON-BI
	MOVEI TT,FT.CNS
	HRRZ C,@T		;PICK UP FT.CNS FROM TTY FILE ARRAY
STBD1:	JUMPN C,1(F)		; AND EXIT BY SKIPPING 1, IF TTYCONS EXISTS
	JRST (F)


;;; TOP LEVEL VARIABLE SETTINGS

TLVRSS:	MOVE A,[PNBUF,,PNBUF+1]
	SETZM PNBUF
	BLT A,PNBUF+LPNBUF-1
TLVRS1:	PUSH P,EOFRTN
	MOVE A,[ERRTN,,ERRTN+1]
	SETZM ERRTN
	BLT A,ERRTN+LEP1-1
	SETOM ERRSW
	POP P,EOFRTN
	SETZB NIL,PANICP
	SETZB A,PSYMF
	SETZB B,EXPL5
	SETZB C,PA3
	SETZB AR1,RDLARG
	SETZB AR2A,QF1SB
	SETZM ARGLOC
	SETZM ARGNUM
	JRST (T)


IFN D10,[
SIXJBN:	PJOB TT,
	IDIVI TT,100.
	IDIVI D,10.
	LSH TT,14
	LSH D,6
	ADDI TT,(D)
	ADDI TT,202020(R)
	HRLI TT,(SIXBIT /LSP/)
	MOVSM TT,D10NAM		;SAVE ###LSP AS TEMP FILE NAME
	POPJ P,
]		;END OF IFN D10

SUBTTL	INITIALIZATION ON ^G QUIT AND ERRORS
;;;	ERINIT RESETS PDL POINTERS, THEN FALLS INTO ERINI0.
;;;	ERINI0 RESETS VARIOUS VARIABLES AND PERFORMS CLEANUP.

ERINIT:
;DISABLE INTERRUPT SYSTEM
10$ SA%	MOVE P,C2
10$ SA%	MOVE FXP,FXC2
	PIPAUSE			;DISABLE ALL INTERRUPTS
ERINIX:				;ENTER HERE IF INTERRUPTS ALREADY DISABLED
IFE PAGING*<1-SAIL>,[
	MOVE P,C2		;SET UP PDL POINTERS
	MOVE FXP,FXC2
	MOVE FLP,FLC2
	MOVE SP,SC2
]		;END OF IFE PAGING*<1-SAIL>
IFN PAGING,[
	HRRZ T,LISPSW
	CAIE T,LISP
	 JRST ERINI9
IFE SAIL,[
	MOVE T,[$NXM,,QRANDOM]
	MOVE TT,PDLFL2		;CONTAINS <- # OF PDL SEGS,,# OF 1ST PDL SEG>
	MOVEM T,ST(TT)		;UPDATE SEGMENT TABLE TO REFLECT
	AOBJN TT,.-1		; LOSS OF PDL PAGES
	HRRZ T,PDLFL1
	ROT T,-4
	ADDI T,(T)
	ROT T,-1
	TLC T,770000
	ADD T,[450200,,PURTBL]
	SETZ D,
	HLRE TT,PDLFL1
ERINI8:	TLNN T,730000
	 TLZ T,770000
	IDPB D,T
	AOJL TT,ERINI8
IT$	MOVE T,PDLFL1		;CONTAINS <- # OF PDL PAGES,,# OF 1ST PDL PAGE>
IT$	.CALL PDLFLS		;FLUSH ALL PDL PAGES
IT$	 .VALUE
20$	WARN [SHOULD TWENEX FLUSH PDL PAGES??]
10$ 	WARN [SHOULD TOPS-10 FLUSH PDL PAGES??]
]	;END OF IFE SAIL
ERINI9:
IRP Z,,[P,FLP,FXP,SP]
	MOVEI F,Z
	MOVE Z,C2-P+Z		;CAUSE ONE PDL PAGE
	MOVEI D,1(Z)		; FOR Z TO EXIST
	ANDI D,PAGMSK		;BUT FOR SAIL, MAKE ALL EXIST
SA$	MOVE TT,D
	JSR PDLSTH		.SEE PDLST0
SA$	MOVEI D,PAGSIZ(TT)
SA$	CAMGE D,XPDL-P+Z
SA$	 JRST .-4
TERMIN
ERIN8G:	MOVE T,[XPDL,,ZPDL]
	BLT T,ZSPDL
]		;END OF IFN PAGING
ERINI0:	SETZB NIL,TAPRED	;INITIALIZATION AFTER PDL SETUP
	SETZM NOQUIT
	SETZM REALLY
	SETZM FASLP
IFN USELESS,	SETZM TYOSW
	SETZM INTFLG
	SETZM INTAR
	SETZM VEVALHOOK
	SETZM GCFXP		;NON-ZERO WOULD MEAN INSIDE GC
	SETZM BFPRDP
	MOVE T,[-LINTPDL,,INTPDL]
	MOVEM T,INTPDL
	MOVEI T,$DEVICE		;RESTORE READER'S LITTLE MEN
	MOVEM T,TYIMAN
	MOVEI T,IUNTYI		;INTERNAL UNTYI'ER
	MOVEM T,UNTYIMAN

;FALLS THROUGH

;FALLS IN

ERINI2:	SKIPL MUNGP		;MAYBE NEED TO UNMUNG SYMBOLS AND SARS
	 JRST ERINI6
	MOVE D,SYSGLK
ERINI5:	JUMPE D,ERIN5A
	MOVEI F,(D)
	LSH F,SEGLOG
	HRLI F,-SEGSIZ
	LDB D,[SEGBYT,,GCST(D)]
ERIN5C:	MOVSI R,1
	ANDCAB R,(F)		;UNMUNGS THE SYMBOL HEADER, IF NECESSARY
	HLRZS R
	HRRZ R,(R)		;GET ADDR OF VALUE CELL
	CAIL R,BVCSG
	CAIL R,BVCSG+<NXVCSG+1>*SEGSIZ
	JRST .+2
	JRST ERIN5D
	CAIL R,BPURFS
	CAIL R,PFSLAST
	JRST .+2
	JRST ERIN5D
	HRRZS (R)		;UNMUNGS THE VALUE CELL, IF STORED IN LIST SPACE
ERIN5D:	AOBJN F,ERIN5C
	JRST ERINI5

ERIN5A:	MOVE F,[SARTOB,,B]
	BLT F,LPROGZ
	MOVE D,SASGLK
ERIN5B:	JUMPE D,ERINI6
	MOVEI F,(D)
	LSH F,SEGLOG
	HRLI F,-SEGSIZ/2
	LDB D,[SEGBYT,,GCST(D)]
	JRST SATOB1
ERINI6:	HRRZS MUNGP
	SKIPN MUNGP		;UNMUNG VALUE CELLS (SEE ALIST)
	 JRST ERIN6A
	MOVEI F,BVCSG
	SUB F,EFVCS
	HRLI F,(F)
	HRRI F,BVCSG
	HRRZS (F)
	AOBJN F,.-1
	SETZM MUNGP
ERIN6A:	MOVE B,[ERRTN,,ERRTN+1]
	SETZM ERRTN
	BLT B,UIRTN
	SETOM ERRSW
	MOVSI B,-NSFC
ERINI3:	MOVE C,SFXTBI(B)	;RESTORE CLOBBERED LOCATIONS
	MOVEM C,@SFXTBL(B)
	AOBJN B,ERINI3
	TLZ A,-1
;ENABLE THE INTERRUPT SYSTEM
IFN ITS,[
	.SUSET [.SMASK,,IMASK]	;RESTORE INTERRUPT ENABLE MASKS
	.SUSET [.SMSK2,,IMASK2]
	.SUSET [.SDF1,,R70]	;RESET DEFER WORDS
	.SUSET [.SDF2,,R70]
]		;END OF IFN ITS
	PIONAGAIN
	JRST (A)		;RETURN TO CALLER


SARTOB:				;TURN OFF MARK BITS IN SARS
OFFSET B-.
SATOB1:	ANDCAM SATOB7,TTSAR(F)
	AOBJP F,ERIN5B
	AOJA F,SATOB1
SATOB7:
	TTS<GC>,,
LPROGZ==.-1
OFFSET 0
.HKILL SATOB1 SATOB7

PDLFLS:	SETZ
	SIXBIT \CORBLK\
	1000,,0		;DELETE PAGES...
	1000,,-1	; FROM MYSELF...
	SETZ T		;  AND HERE'S HOW MANY AND WHERE!

SUBTTL	SPECIAL VARIABLE BINDING AND UNBINDING ROUTINES

	JFCL			;HISTORICAL LOSS -- EVENTUALLY FLUSH
SPECBIND:	MOVEM SP,SPSV	;0 0,FOO   MEANS FOO IS ADDR OF SVC TO BE BOUND TO NIL, SAVES D
SPEC1:	LDB R,[271500,,(T)]	;0 N,FOO   MEANS SVC FOO TO BE BOUND TO CONTENTS OF ACC N
	JUMPE R,SPEC4
	CAILE R,17		;7_41 M,FOO   MEANS BIND FOO TO -M(P)
	 JRST SPEC3		;OTHERWISE, IS PDP10 INSTRUCTION, SO EXIT
SPEC2:	HRRZ R,(R)		;NOTE WELL! NCOMPLR DEPENDS ON THE FACT
	CAML R,NPDLL		; THAT R = TT+2 = NUMVALAC+2
	 CAMLE R,NPDLH
	  JRST SPEC4
	PUSH FXP,T
	MOVEI T,(R)
	LSH T,-SEGLOG
	SKIPL T,ST(T)		;NMK1 WILL WANT TYPE BITS IN T
	 TLNN T,$PDLNM		;SKIP IF PDL NUMBER
	  JRST SPEC5
	HRR T,(FXP)
	LDB R,[271500,,(T)]	;RECOMPUTE ADDRESS OF FROB
	CAIG R,17
	 JRST SPEC6
	TRC R,16000#-1
	ADDI R,1(P)
SPEC6:	PUSHJ P,ABIND3	;TEMPORARILY CLOSE THE BIND BLOCK
	PUSH P,A
	HRRZ A,(R)
	PUSHJ P,NMK1
	MOVEM A,(R)	;CLOBBER LOC OF FROB WITH NEW NUMBER
	CAIN R,A	;GRUMBLE
	 MOVEM A,(P)
	SUB SP,R70+1	;SO RE-OPEN THE BIND-BLOCK
	MOVEI R,(A)	;THEREBY INHIBITING INTERRUPTS
	POP P,A
SPEC5:	POP FXP,T
IFN D10,[
SPEC4:	PUSH FXP,T
	MOVEI T,@(T)
	CAIN T,PWIOINT
	 JRST [ POP FXP,T
		JRST WIOSPC]
	EXCH R,(T)
	POP FXP,T
]	;END IFN D10
10%	BNDTRAP SPEC4,WIOSPC,T, EXCH R,@(T)
SPEC4A:	HRL R,(T)
	PUSH SP,R
	AOJA T,SPEC1

SPEC3:	CAIGE R,16000
	JRST SPECX
	TRC R,16000#-1		;RH OF R NOW HAS N
	ADDI R,1(P)		;SPECBINDING OFF PDL
	JRST SPEC2



ERRPOP:	POP FXP,ERRPAD		;POP RETURN ADR OFF FXP
	MOVE TT,C2		;RUN ALL OF THE UNWIND HANDLERS
	MOVEM T,ERRPST		;SAVE T
	PUSHJ FXP,UNWPRO
	MOVE T,ERRPST		;RESTORE SAVED T
	PUSH P,ERRPAD		;SAVE ERR RETURN ADR
;ENTRY POINT IF NO UNWIND-PROTECT FUNCTIONS SHOULD BE RUN
ERRPNU:	SKIPA TT,ZSC2		;TOTALLY POP OFF SPECPDL FOR ERRORS
UBD0:	 TLZA TT,-1		;POP SPECPDL TO PLACE SPECIFIED IN TT
	  SETOM (TT)		;ERRPOP MUST SETOM - SEE UBD4
UBD:	CAIL TT,(SP)		;RESTORE THE SPDL BY RESTORING VALUES
	 JRST UNBND2		; UNTIL (SP) MATCHES (TT)
	POP SP,R
	HLRZ D,R
	TLZ R,-1
	CAMGE R,ZSC2
	 JRST UBD3
	CAIG R,(SP)
	 JRST UBD4
	SKIPN D
	 .LOSE			   ;Somebody screwed the SPECPDL - HELP!!!
	BNDTRAP UBD3,UBDP,D, HRRZM R,(D)
UBD1:	JRST UBD

UBDP:	PUSH FXP,T		   ;Figure out if WITHOUT-INTERRUPTS
	HRRZI T,(D)
	CAIN D,PWIOINT		   ;WITHOUT-INTERRUPTS, handle specially
	 JRST UBDWIO
	POP FXP,T		   ;Restore state
	HRRZM R,(D)		   ;Recause error, will trap this time
	JRST UBD		   ;Continue if continued

UBDWIO:	PUSH P,[WIOUNB]		   ;Make sure without-interrupt'er gets called
	POP FXP,T
	PUSH FLP,R		   ;With old value to store
	MOVSS (FLP)		   ;WIOUNB expects it in left half
	JRST UBD


UBD4:	HLRZ D,(SP)
	JUMPN D,UBD	    ;AMONG OTHER THINGS, ERRPOP'S SETOM MAKES THIS JUMP
	PUSH FLP,T		;MUST SAVE T
	MOVEI T,(R)
	PUSHJ P,AUNBN0		;FOUND A FUNARG BINDING BLOCK
	POP FLP,T		; - USE SPECIAL ROUTINE TO UNBIND IT
	JRST UBD


UNBIND:	POP SP,T
	MOVEM TT,UNBND3	;HORRIBLE HACK TO SAVE AC TT. THINK ABOUT THIS SOME DAY
UNBND0:	TLZ T,-1	;AUNBIND ENTERS HERE

IFE D10,[
UNBND1:	CAIN T,(SP)
	 JRST UNBND2
	POP SP,TT
	MOVSS TT
	BNDTRAP ,UNBNDP,TT, HLRZM TT,(TT)
	JRST UNBND1
]; END IFE D10,

IFN D10,[
	PUSH FXP,R		   ;Save R for comparison (Can't use FLP -- used to pass
				   ; an argument to WIOUNB)
	MOVEI R,PWIOINT		   ;For comparison, factored out of the loop
UNBND1:	CAIN T,(SP)		   ;End of looop?
	  JRST UNBD2A
	POP SP,TT
	MOVSS TT
	CAIN R,(TT)		   ;Is this the special case PWIOINT?
	  JRST UNBNDP		   ;  Yes, hack it
	HLRZM TT,(TT)
	JRST UNBND1
]; END IFN D10,

UNBNDP:	PUSH FXP,T		   ;FIGURE OUT IF WITHOUT-INTERRUPTS
	HRRZI T,(TT)
	CAIN T,PWIOINT		   ;WITHOUT-INTERRUPTS, HANDLE SPECIALLY
	 JRST UNBWIO
	POP FXP,T		   ;RESTORE STATE
	HLRZM TT,(TT)		   ;RECAUSE ERROR, WILL TRAP THIS TIME
	JRST UNBND1		   ;CONTINUE IF CONTINUED

UNBWIO:	PUSH P,[WIOUNB]		   ;MAKE SURE WITHOUT-INTERRUPT'ER GETS CALLED
	POP FXP,T
	PUSH FLP,TT		   ;WITH OLD VALUE
	JRST UNBND1

;;; BIND, AND MAKE-VALUE-CELL ROUTINES.  
;;; PUSHJ P,BIND   WITH SYMBOL IN A, VALUE IN AR1.  
;;;     USES ONLY A, TT;  MUST SAVE T
;;; JSP TT,MAKVC  WITH AN ATOMIC SYMBOL ON THE PDL (WHICH IS POPPED)
;;;     AND THE VALUE IN B. RETURNS ADDRESS OF NEW VALUE CELL IN A.
;;;     (LATTER CROCK FOR BIND1 ONLY).  USES ONLY A,B,TT.

BIND:	SKIPN TT,A
	 JRST BIND5
	HLRZ A,(A)
   XCTPRO
	HRRZ A,(A)
   NOPRO
	CAIN A,SUNBOUND
	 JRST BIND1
BIND4:	PUSH SP,(A)
	HRLM A,(SP)
	BNDTRAP STQPUR,WIOBND,A, HRRZM AR1,(A)
	POPJ P,

BIND5:	MOVEI A,VNIL		;ALLOW PURPGI TRAP TO WORK JUST 
CBIND4:	JRST BIND4		;LIKE FOR SETQING T

BIND1:	PUSH P,CBIND4		;SET UP FOR CALL TO MAKVC
	PUSH P,B
	PUSH P,TT
	MOVEI B,QUNBOUND
	JSP TT,MAKVC
POPBJ:	POP P,B
CPOPBJ:	POPJ P,POPBJ

MAKVC:	PUSH FXP,TT		;SAVE RETURN ADDR
   SPECPRO INTZAX
MAKVC0:	SKIPN A,FFVC
	JRST MAKVC3
	EXCH B,@FFVC
   XCTPRO
	HRRZM B,FFVC
   NOPRO
MAKVC1:	HLRZ B,@(P)		;POINTER TO SYMBOL HEADER IS ON STACK
PURTRAP MAKVC9,B,	HRRM A,(B)
MAKVCX:	SUB P,R70+1		;POP POINTER, RETURN ADDRESS OF VALUE CELL
	POPJ FXP,		; IN A, ADDR OF SY2 BLOCK IN B

IFE PAGING,[
MAKVC3:	PUSHJ P,CONS1
	SETOM ETVCFLSP
	JRST MAKVC1
]		;END OF IFE PAGING


SUBTTL	VARIOUS ODDBALL CONSERS

IFN BIGNUM,[
C1CONS:	EXCH T,YAGDBT
	JSP T,FWCONS
	EXCH T,YAGDBT
	JRST ACONS
]		;END OF IFN BIGNUM

%NCONS:	PUSH P,T
NCONS:	TLZ A,-1	
   BAKPRO
ACONS:	SKIPN FFS		;THIS IS A CONS LIKE XCONS
	PUSHJ P,AGC		;BUT USES ONLY ACCUMULATOR A
	MOVSS A			;SWAP HALVES OF A, THEN
   SPECPRO INTACX
	EXCH A,@FFS		;CONS WHOLE WORD FROM A
   XCTPRO
	EXCH A,FFS
   NOPRO
	POPJ P,

IFN BIGNUM,[

   BAKPRO
BGNMAK:			;MAKE A POSITIVE BIGNUM (SAME AS BNCONS)
BNCONS:	SKIPN FFB	;BIGNUM CONSER
	PUSHJ P,AGC
	EXCH A,@FFB
   XCTPRO
	EXCH A,FFB
   NOPRO
	POPJ P,
]		;END OF IFN BIGNUM

;;; EXPLODEC ARGUMENT IN A (WITH BASE=10., *NOPOINT=T),
;;; AND RETURN A SIXBIT WORD IN TT.  CLOBBERS ALL ACS.

SIXMAK:	MOVEI B,IN0+10.
	JSP T,SPECBIND
	  0 B,VBASE
	  0 B,V.NOPOINT
	SETZM SIXMK2
	MOVE AR1,[440600,,SIXMK2]
	HRROI R,SIXMK1		.SEE PR.PRC
	PUSHJ P,PRINTA		;CALL PRINTA TO EXPLODEC THE ARGUMENT
	MOVE TT,SIXMK2
	JRST UNBIND

SIXMK1:	CAIGE A,140	;THIS SAYS CONVERT LOWER CASE TO UPPER
	TRC A,40	;CONVERT CHAR TO SIXBIT
	TLNE AR1,770000
.UDT4:	 IDPB A,AR1	;MAYBE SAVE IT, UNLESS ALREADY HAVE SIX
	POPJ P,

;;; TAKE SIXBIT IN TT, RETURN AN ATOMIC SYMBOL IN A.
;;; EMBEDDED BLANKS COUNT, BUT TRALING ONES DON'T.
;;; A ZERO WORD BECOMES THE ATOM "*".  SAVES F.

SIXATM:	SETOM LPNF
	MOVE C,PNBP
	MOVSI T,(ASCII \*\)
	MOVEM T,PNBUF
	SETZM PNBUF+1
SIXAT1:	JUMPE TT,RINTERN	;RINTERN SAVES F
	SETZ T,
	LSHC T,6
	ADDI T,40		;CONVERT SIXBIT TO ASCII
	IDPB T,C		;STICK CHARACTERS IN PNBUF
	JRST SIXAT1

;;; A STRING IS IN PNBUF, TERMINATED BY A NULL.
;;; LOCATE ITS END, AND CALL RINTERN TO MAKE AN ATOM.

PNBFAT:	MOVE T,PNBP
PNBFA1:	MOVE C,T
	ILDB TT,T
	JUMPN TT,PNBFA1
	SETOM LPNF
	JRST RINTERN

;;; TAKE AN S-EXPRESSION IN A, AND EXPLODEC IT INTO PNBUF.
;;; AR2A WILL CONTAIN THE COUNT OF UNUSED CHARACTER POSITIONS IN PNBUF.
;;; PRESERVES ITS ARGUMENT.

PNBFMK:	PUSH P,A
	PUSH P,CPOPAJ
	SETZM PNBUF
	MOVE T,[PNBUF,,PNBUF+1]
	BLT T,PNBUF+LPNBUF-1
	MOVE AR1,PNBP
	MOVEI AR2A,LPNBUF*BYTSWD
	HRROI R,PNBFM6		.SEE PR.PRC
	JRST PRINTA

PNBFM6:	JUMPLE AR2A,CPOPJ	;GIVE UP IF NO MORE ROOM IN PNBUF
	IDPB A,AR1		;ELSE STICK CHARACTER IN
	SOJA AR2A,CPOPJ





IFN D10,[
;;; CONVERT A PPN IN TT TO AN "ATOM", I.E. AN S-EXPR OF APPROPRIATE FORM.  SAVES F.

PPNATM:
IFE SAIL,[
	SKIPN CMUP
	 JRST PPNAT2
	HLRZ T,TT
	CAME TT,[-1]
	 CAIG T,10		;PPN'S WITH PROJECT BETWEEN 1 AND 10
	  JRST PPNAT2		; MUST BE EXPRESSED IN DEC FORM
	MOVE T,[TT,,PNBUF]
	SETZM PNBUF+1		;NEED THIS BECAUSE OF CMU BUG
	DECCMU T,		;TRY CONVERTING PPN TO CMU STRING
	 JRST PPNAT2		;ON FAILURE, JUST REVERT TO DEC FORMAT
	JRST PNBFAT		;ON SUCCESS, CONS UP ATOM FROM STRING
]	;END OF IFE SAIL
PPNAT2:	JUMPN TT,.+3
	 MOVEI A,Q.
	 POPJ P,
	PUSHN P,1
	PUSH FXP,TT
	TLZ TT,-1
	PUSHJ P,PPNAT4		;CONVERT PROGRAMMER
	POP FXP,TT
	HLRZS TT
	PUSHJ P,PPNAT4		;CONVERT PROJECT
	JRST POPAJ

PPNAT4:
IFE SAIL,[
	CAIN TT,-1		;777777 => OMITTED HALF OF PPN
	 SKIPA A,[Q.]		;REPLACE IT WITH *
	  JSP T,FXCONS		;OTHERWISE USE A FIXNUM
	MOVE B,-1(P)
	PUSHJ P,CONS
	MOVEM A,-1(P)
	POPJ P,
]		;END OF IFE SAIL
IFN SAIL,[
	CAIN TT,-1		;777777 => OMITTED HALF OF PPN
	 JRST PPNAT9		;REPLACE IT WITH *
	JUMPE TT,PPNAT9		;? MIGHT AS WELL TREAT 0 AS OMITTED
PPNAT6:	TLNE TT,770000		;LEFT JUSTIFY THE SIXBIT CHARACTERS
	 JRST PPNAT3		;WHEN DONE, CREATE AN ATOM AND CONS ONTO LIST
	LSH TT,6
	JRST PPNAT6
]		;END OF IFN SAIL

SA$ PPNAT9:	SKIPA A,[Q.]
PPNAT3:
20%	PUSHJ P,SIXATM
20$	PUSHJ P,PNBFAT
PPNAT5:	MOVE B,-1(P)
	PUSHJ P,CONS
	MOVEM A,-1(P)
	POPJ P,
]		;END OF IFN D10

SUBTTL	CATCH, THROW, ERRSET, .SET, AND BREAK ROUTINES

;NORMAL CATCH
CATPUS:	PUSH P,B		;COMPILED CODE FOR *CATCH ENTERS HERE
	MOVEI A,(A)		; COMPLR TURNS "CATCH" TO "*CATCH"
	MOVEI T,(A)
	LSH T,-SEGLOG
	SKIPGE ST(T)		;SEE IF TAG OR TAGLIST
	  HRLI A,CATSPC\CATLIS
CATPS1:	MOVEM A,CATID		;SET UP A CATCH FRAME
	JSP T,ERSTP
	MOVEM P,CATRTN
	JRST (TT)

;CATCH-BARRIER
CATBAR:	PUSH P,B		;ADR TO JUMP TO WHEN THROW IS DONE
	HRLI A,CATSPC\CATLIS\CATCAB ;FLAG AS CATCH-BARRIER
	MOVEM A,CATID		;THIS IS THE CATCH ID
	JSP T,ERSTP		;SETUP A NEW CATCH FRAME
	MOVEM P,CATRTN
	JRST (TT)

;CATCHALL
; UPON ENTRY: TT HAS ADR-1 OF CATCHALL FUN, T HAS ADR AFTER OTHER FUNS
CTCALL:	PUSH P,T
	AOS TT			;POINT TO FIRST LOCATION OF CATCHALL FUN
	HRLI TT,CATSPC\CATALL\CATCOM ;FLAG AS A COMPILED CATCHALL
	MOVEM TT,CATID		;THIS IS THE CATCH ID
	JSP T,ERSTP		;SETUP A NEW CATCH FRAME
	MOVEM P,CATRTN
	JRST -1(TT)

;BREAKUP A CATCHALL
THRALL:	SETZM (P)		;TURN INTO A NORMAL CATCH
	JRST THROW1		;THEN BREAK UP LIKE A NORMAL THROW

THROW5:	SKIPE D,UIRTN		;IF NO USER INTERRUPT FRAME STACKED,
	 CAIG D,(TT)		; OR IF IT IS BELOW THE CATCH FRAME,
	  JRST THROW3		; THEN JUST EXIT THE CATCH FRAME
	JSP TT,UIBRK		;OTHERWISE BREAK OUT OF THE INTERRUPT
THROW1:	SKIPN TT,CATRTN		;SKIP IF CATCH FRAME BELOW US
	 JRST THROW4
	MOVSI T,CATUWP
	TDNE T,(TT)		;UNWIND-PROTECT FRAME?
	 JRST THRNXT		;YES, SKIP IT COMPLETELY
	JUMPE B,THROW5
THROW6:	SKIPN T,(TT)		;(CATCH FOO NIL) = (CATCH FOO)
	 JRST THROW5		;CATCH ID MATCHES THROW ID
	TLNE T,CATSPC		;SPECIAL PROCESSING NEEDED?
	 JRST THRSPC		;YES, DO SO
	CAIN B,(T)		;CATCH ID MATCHES?
	 JRST THROW5		;YES
THRNXT:	MOVE TT,<-LEP1+1>+<CATRTN-ERRTN>(TT)	;GO BACK ONE CATCH
	JUMPN TT,THROW6		;FALL THROUGH IF NO MORE
THROW4: JUMPE B,LSPRET		;IF TAG IS (), THEN JUST THROW TO
THROW7:	EXCH A,B		;TOPLEVEL; OTHERWISE, ERROR
	%UGT EMS29
	EXCH A,B
	JRST THROW1


THROW3:	PUSHJ FXP,UNWPRO	;UNWIND PROTECT CHECKER
	MOVE P,TT
THRXIT:	SETZM PANICP
	MOVSI D,-LEP1+1(P)
	HRRI D,ERRTN
	BLT D,ERRTN+LEP1-1
	MOVE C,CATID		;GET CURRENT CATCH ID
	SUB P,EPC1
	POP P,FXP
	POP P,FLP
	POP P,TT
	POP P,PA3
	PUSHJ P,UBD0		;RESTORE CONDITIONS AND PROCEED
	TLNN C,CATALL		;A CATCHALL?
	 POPJ P,		;NOPE, RETURN THROWN VALUE
	EXCH A,B		;TAG AS FIRST ARG, VAL AS SECOND
	TLNE C,CATCOM		;COMPILED?
	 JRST (C)		;YES, RUN COMPILED CODE
	CALLF 2,(C)		;ELSE CALL THE USER'S FUNCTION
	POPJ P,			;RETURN NEW VAL IF THE CATCHALL FUN RETURNS

THRSPC:	TLNE T,CATALL		;CATCHALL?
	 JRST THROW5		;YES, WE HAVE FOUND A GOOD FRAME TO STOP AT
	TLNE T,CATUWP		;UNWIND-PROTECT?
	 JRST THRNXT		;YES, IGNORE THE FRAME
	TLNE T,CATCAB		;CATCH-BARRIER?
	 JRST THRCAB
	TLNN T,CATLIS		;A LIST OF TAGS?
	 LERR [SIXBIT\SPECIAL CATCH FRAME, BUT NO VALID TYPE BITS EXIST!\]
	PUSH P,A
	PUSH P,B		;SAVE NEEDED ACS
	MOVEI A,(B)		;CATCH TAG
	MOVEI B,(T)		;LIST OF TAGS
	PUSHJ P,MEMQ1		;CHECK FOR MEMBERSHIP (DOES NOT DESTROY TT)
	MOVE T,A		;SAVE THE RESULTS
	POP P,B
	POP P,A
	JUMPE T,THRNXT		;UPWARD TO NEXT CATCH FRAME
	JRST THROW5		;ELSE FOUND A MATCH, SO DO THE ACTUAL THROW

THRCAB:	PUSH P,A
	PUSH P,B		;SAVE NEEDED ACS
	MOVEI A,(B)		;CATCH TAG
	MOVEI B,(T)		;LIST OF TAGS
	PUSHJ P,MEMQ1		;CHECK FOR MEMBERSHIP (DOES NOT DESTROY TT)
	MOVE T,A		;SAVE THE RESULTS
	POP P,B
	POP P,A
	JUMPE T,THROW7		;CATCH-BARRIER, NOT IN LIST OF TAGS, ERROR
	JRST THROW5		;ELSE FOUND A MATCH, SO DO THE ACTUAL THROW

	JRST THRALL		;COMPILED REMOVAL OF A CATCHALL
	JRST THROW1		;COMPILED THROWS COME HERE
ERUNDO:	SKIPN ERRTN		;COMPILED ERR, AND NORMAL ERRSET EXIT COME HERE
	 JRST LSPRET		;RETURN TO TOPLEVEL
ERR0:
IFN USELESS,	SETZM TYOSW
	JUMPN A,ERUN0		;ELSE, BREAK UP AN ERRSET
	SKIPE V.RSET
	 SKIPN VERRSET		;ERRSET BEING BROKEN BY AN ERROR
	  JRST ERUN0
	PUSH P,A
	MOVEI D,1001		;ERRSET USER INTERRUPT
	PUSHJ P,UINT
	POP P,A
	JRST ERUN0

	SKIPA TT,CATRTN		;PHOOEY, COMPILED CODE COMES HERE WHEN A 
GOBRK:	 MOVE TT,ERRTN		;GO OR RETURN OCCURS WITHIN AN ERRSET OR CATCH
	JUMPE TT,ER4
	EXCH T,-LERSTP(TT)
	JRST ERR1


IOGBND:	JSP T,SPECBIND		;BIND ALL I/O CONTROL VARIABLES TO NIL:
	TTYOFF			;	^W
	TAPRED			;	^Q
	TAPWRT			;	^R
EPOPJ:	POPJ P,			.SEE $ERRFRAME

;;;	MOVEI D,LOOP		;ROUTINE TO LOOP
;;;	PUSHJ P,BRGEN
;;; GENERATES A BREAK LOOP SURROUNDED BY A CATCH AND AN
;;; ERRSET.  ERRORS CAUSE THE LOOP TO BE RE-ENTERED.
;;; BRGEN RETURNS WHEN THE LOOP ROUTINE PERFORMS A
;;; THROW TO THE TAG BREAK.
.SEE BREAK
.SEE $BREAK

BRGEN:	MOVEI A,QBREAK		;CATCH ID = BREAK
	JSP TT,CATPS1		;SET UP CATCH FRAME
	PUSH P,D
	PUSH P,.		;RETURN POINT FOR ERROR
	JSP T,ERSTP		;SET UP ERRSET FRAME
	SETOM ERRSW
	MOVEM P,ERRTN
	JRST @-LERSTP-1(P)	;CALL RANDOM ROUTINE

;;; BREAK LOOP USED BY *BREAK

BRLP1:	PUSH P,FLP
	PUSH P,FXP
	PUSH P,SP
	PUSHJ P,TLEVAL		;EVALUATE FORM READ
	MOVEM A,V.		;STICK VALUE IN *
	PUSHJ P,TLPRINT		;PRINT VALUE
	HRRZ TT,-2(P)
	HRRZ D,-1(P)
	HRRZ R,(P)
	POPI P,3
	PUSHJ P,PDLCHK		;CHECK PDL LEVELS
	JRST TLTERPRI		;TERPRI IF APPROPRIATE

BRLP:	PUSH P,BRLP		;***** BASIC BREAK LOOP *****
	SKIPE A,BLF		;IF USER SUPPLIED A BREAK LOOP FORM,
	 JRST EVAL		; EVALUATE IT (RETURNS TO BRLP)
	PUSHJ P,TLREAD		;OTHERWISE READ A FORM
	 JRST .+4
	  SETZ AR1,		;ON EOF, LOOP BACK AFTER TERPRING
	  PUSHJ P,TERP1
	  JRST .-4
	SKIPE VDOLLRP		;IF THE FORM IS EQ TO THE
	 CAME A,VDOLLRP		; NON-NIL VALUE OF THE VARIABLE P,
	  JRST BRLP4		; THEN THAT MEANS RETURN NIL
	MOVEI A,NIL
BRLP2:	MOVEI B,QBREAK
	JRST THROW1		;ESCAPE FROM BRGEN LOOP

BRLP4:	HLRZ B,(A)		;(RETURN <FOO>) MEANS RETURN THE
	CAIE B,QRETURN		; VALUE OF FOO
	 JRST BRLP1		;OTHERWISE EVAL AND PRINT THE FORM
	JSP T,%CADR
BRLP3:	PUSHJ P,EVAL
	JRST BRLP2

;;;	JSP T,.STORE	;USED BY COMPILED CODE
;;; ON CALLING .STORE WE MUST HAVE JUST COMPLETED AN "INTERPRETED"
;;; ARRAY REFERENCE OF SOME KIND, BY PUSHJ'ING INTO THE ARRAY HEADER
;;; AND GOING TO ONE OF THE NDIMX ROUTINES.  THIS LEAVES THE SAR
;;; OF THE ARRAY REFERENCED IN LISAR, AND THE INDEX WORD IN R.
;;; A CONTAINS THE VALUE TO STORE INTO THE ARRAY.

.STORE:	SKIPN D,LISAR
	 JRST .STOLZ		;ERROR IF NO ARRAY REFERENCED LATELY
	HLL D,ASAR(D)
	TLNN D,AS.SX		;WAS IT AN S-EXPRESSION ARRAY?
	 JRST .STOR2
.STOR0:	MOVEI TT,(R)		;YEP, STORE A HALF-WORD QUANTITY
	JUMPL R,.STOR1
	HRLM A,@TTSAR(D)
	JRST (T)

.STOR1:	HRRM A,@TTSAR(D)
	JRST (T)

.STOR2:	TLNN D,AS.FX+AS.FL	;SKIP IF FIXNUM OR FLONUM
IFN DBFLAG+CXFLAG, JRST .STOR4
.ELSE	 .VALUE
	MOVEI F,(T)
	TLNN D,AS.FX
	 JSP T,FLNV1X		;GET FLONUM QUANTITY, WITH SKIP RETURN
	  JSP T,FXNV1		;OR MAYBE GET FIXNUM QUANTITY
	EXCH TT,R
	MOVEM R,@TTSAR(D)	;STORE QUANTITY INTO ARRAY
	JRST (F)

IFN DBFLAG+CXFLAG,[
.STOR4:	TLNN D,AS.DB+AS.CX	;SKIP IF DOUBLE OR COMPLEX
IFN DXFLAG, JRST .STOR6
.ELSE	 .VALUE
	MOVEI F,(T)
DB$ CX$	TLNN D,AS.DB
DB$ CX$	 JSP T,CXNV1X		;GET COMPLEX QUANTITY, WITH SKIP RETURN
DB$	  JSP T,DBNV1		;OR MAYBE GET DOUBLE QUANTITY
DB%	JSP T,CXNV1
	MOVE T,LISAR
	EXCH TT,R
	MOVEM R,@TTSAR(T)	;STORE QUANTITY INTO ARRAY
	ADDI TT,1
	MOVEM D,@TTSAR(T)
	JRST (F)
]		;END OF IFN DBFLAG+CXFLAG

IFN DXFLAG,[
.STOR4:	TLNN D,AS.DX		;SKIP IF DUPLEX
	 .VALUE			;IF NOT THAT, THEN ERROR (UNKNOWN ARRAY TYPE)
	PUSH P,F
	PUSH FXP,R
	JSP T,DXNV1
	MOVE T,LISAR
	EXCH TT,(FXP)
KA	MOVEM R,@TTSAR(T)	;STORE QUANTITY INTO ARRAY
KA	ADDI TT,1
KA	MOVEM F,@TTSAR(T)
KA	ADDI TT,1
KIKL	DMOVEM R,@TTSAR(T)
KIKL	ADDI TT,2
	POP FXP,@TTSAR(T)
	ADDI TT,1
	MOVEM D,@TTSAR(T)
	POPJ P,
]		;END OF IFN DXFLAG

;;;	JSP T,.SET	;USED BY COMPILED CODE
;;; ATOM TO SET IN AR1, AND VALUE TO SET TO IN A.
;;; THE VALUE MUST NOT BE A PDL QUANTITY.

.SET:	EXCH A,AR1
.SET1:	PUSH P,A
	PUSHJ P,BIND		;BIND TAKES SYMBOL IN A, VALUE IN AR1
	POP P,A			;THIS CROCKISH IMPLEEMNTATION
	EXCH A,AR1		; PERFORMS A SET BY DOING A SPECBIND,
	JRST SETXIT		; THEN DISCARDING THE BINDING FROM SP


;;;	JSP TT,FWNACK		;OR LWNACK
;;;	  FAXXXX,,QFOO		;OR LAXXXX,,QFOO
;;; CHECKS FOR AN FSUBR (LSUBR) THAT THE RIGHT NUMBER OF ARGUMENTS
;;; WERE PROVIDED, AND GENERATES AN APPROPRIATE WNA ERROR IF NOT.
;;; THE FAXXXX (LAXXXX) HAS THE LOW BIT 0 FOR LSUBR, 1 FOR FSUBR.
;;; BIT 2_N IS SET IFF GETTING EXACTLY N ARGUMENTS IS ACCEPTABLE.

FWNACK:	SETZ T,			;COUNT UP ACTUAL NUMBER OF ARGS
	MOVEI D,(A)		;LEAVES NEGATIVE OF NUMBER OF ARGS IN T,
FWNAC1:	JUMPE D,LWNACK		; SO CAN FALL INTO LSUBR CHECKER
	HRRZ D,(D)
	SOJA T,FWNAC1

LWNACK:	MOVE D,(TT)		;GET WORD OF BITS
	ASH D,(T)
	TLNE D,2		;SKIP UNLESS WNA
	 JRST 1(TT)
	JRST WNAL0		;GO PRODUCE A WRNG-NO-ARGS ERROR


;;; PUSH CRUFT FOR AN ERRSET/CATCH/READEOF FRAME
;;; BEWARE! THE COMPILER DEPENDS ON THE LENGTH OF THE
;;; ERRSET FRAME BEING A CONSTANT.

ERSTP:	PUSH P,PA3		;"ERRSET" PUSH
	PUSH P,SP		;MUST SAVE TT - SEE $TYI
	PUSH P,FLP
	PUSH P,FXP
REPEAT LEP1,	PUSH P,ERRTN+.RPCNT
LERSTP==.-ERSTP			;LENGTH OF ERRSET PUSH
	HLL T,UNREAL		;SO WE DECIDED TO PACK BOTH OF "UNREAL"
	HLLM T,KMPLOSES(P)	; AND "ERRSW" INTO ONE PDL SLOT
	JRST (T)

ERUN0:	HRRZ TT,ERRTN		;GENERAL BREAK OUT OF AN ERRSET
	SKIPE D,UIRTN
	 CAIL TT,(D)
	  JRST ERR1A
	JSP TT,UIBRK		;MAYBE BREAK UP A USER INTERRUPT FIRST
	JRST ERUN0
ERR1A:	HRRZ TT,ERRTN		;WHERE WE ARE UNWINDING TO
	PUSHJ FXP,UNWPRO	;HANDLE UNWIND-PROTECT
	MOVE P,ERRTN
ERR1:	SETZM PANICP
	HLL D,KMPLOSES(P)	;SO WE DECIDED TO PACK BOTH OF "UNREAL"
	HLLEM D,UNREAL		; AND "ERRSW" INTO ONE PDL SLOT
	HRRES KMPLOSES(P)
	MOVSI D,-LEP1+1(P)
	HRRI D,ERRTN
	BLT D,ERRTN+LEP1-1
	SUB P,EPC1
	POP P,FXP
	POP P,FLP
	POP P,TT
	POP P,PA3
	JRST UBD0	;RESTORE CONDITIONS AND PROCEED

EPC1:	LEP1,,LEP1


UIBRK:	EXCH D,TT		;UNWIND-PROTECT NEEDS STACK POINTER IN AC TT
	PUSHJ FXP,UNWPRO	;HANDLE UNWIND PROTECTION
	EXCH D,TT
	HRRM TT,-1(D)
	HRRO FXP,1(D)		;JUST SET LEFT HALF OF PDL POINTERS
	HLRO FLP,1(D)		; TO -1 FOR BIBOP, AND LET PDLOV
	HRROI P,-UIFRM(D)
IFN PDLBUG,[
	FXPFIXPDL AR1
	FLPFIXPDL AR1
	PFIXPDL AR1
]	;END OF IFN PDLBUG
	MOVEM F,UISAVT-T+F(FXP)	;LET F BE SAFE OVER RESTORATION
	MOVEM T,UISAVT(FXP)	;T TOO
	MOVEM C,UISAVA-A+C(P)	;C TOO
	MOVEM B,UISAVA-A+B(P)	;B TOO
	MOVEM A,UISAVA(P)	;A TOO
	JRST UINT0X

;THIS ROUTINE FINDS ALL UNWIND-PROTECTS BETWEEN THE CURRENT STACK POSITION
; AND THE DESIRED STACK POSITION (AS FOUND IN TT).  IF AN UNWIND-PROTECT IS
; FOUND, THEN:
;   A) THE UNWIND-PROTECT STACK FRAME IS POP'ED *WITHOUT UPDATING FXP OR FLP*
;   B) SP IS UNWOUND TO THE CURRENT BINDING LEVEL
;   C) THE FUNCTION IS CALLED WITH EVERYTHING SAVED
;   D) WHEN THE FUNCTION RETURNS, ACS ARE RESTORED AND THE ROUTINE CONTINUES
;      SEARCHING FOR THE NEXT UNWIND PROTECT
; WHEN NO MORE UNWIND PROTECTS EXIST IN THE SPECIFIED RANGE OF THE PDL,
; THIS ROUTINE RETURNS TO ITS CALLER, WHICH IS EXPECTED TO RESTORE
; FXP AND FLP (AND POSSIBLY OTHERS) FROM THE STACK FRAME THAT WAS USED TO STOP
; THE UNWIND-PROTECT SEARCH
; CALLED WITH PUSHJ FXP,
; TT CONTAINS LOWEST ADR TO SEARCH
; PRESERVES ALL AC'S
UNWPRO:
;;; AMOUNT OF STUFF THAT GETS PUSHED MUST BE WELL DEFINED, CHANGE UNWPUS
;;; IF IT CHANGES
.SEE UNWPUS
	PUSH FXP,D
	PUSH FXP,T
	PUSH FXP,R
	PUSH FXP,TT
;;;
	HRRZS TT		;ONLY PDL PART
	MOVEI R,(SP)		;CURRENT VALUE OF SP IN CASE NO FRAMES FOUND
UNWPR2:	SKIPE D,CATRTN
UNWPR1:	 CAILE TT,(D)		;HAVE WE GONE TOO FAR?
	  JRST UNWPRT		;NO MORE FRAMES POSSIBLE, SO RETURN
	HRLZI T,CATUWP		;IS THIS AN UNWIND-PROTECT FRAME?
	TDNN T,(D)
	 JRST UNWNXT		;NOT UNWIND-PROTECT, SO SKIP THIS FRAME
	HRRO P,D		;RESET PDL, WILL WORK BY PDL OV NEXT PUSH
IFN PDLBUG,[
	PFIXPDL T
]	;END IFN PDLBUG

;;; PUSH NOTE
.SEE UNWPUS
	PUSH FXP,UNREAL		;FROM THIS POINT ON ALLOW NO USER INT'S

	SETOM UNREAL
	HRRZM FXP,REALLY

	MOVE T,(P)		;GET POINTER TO UNWIND HANDLER
	MOVSI D,-LEP1+1(P)	;RESTORE HAS FRAME (SNARFED FROM ERR1)
	HRRI D,ERRTN
	BLT D,ERRTN+LEP1-1
	SUB P,EPC1
	POP P,D			;GET OLD FXP
	POP P,FLP		;RESTORE FLP
	POP P,R			;SAVE LEVEL TO SP UNWIND TO
	POP P,PA3
	PUSHJ FXP,SAV5		;SAVE ALL PROTECTED ACS
	MOVEI B,(T)		;POINTER TO COMPILED FUNCTION OR LIST

;;; PUSH NOTE
.SEE UNWPUS
	PUSHJ P,SAVX5		;AND UNPROTECTED ONES

	HRRI T,(D)
	MOVEI TT,(R)
	PUSHJ P,UBD0		;Unwind SP
	PUSH FLP,T
	SETOI A,
	JSP T,SPECBIND
	   0 A,PWIOINT
	SETZM REALLY
	POP FLP,T

	TLNN T,CATCOM		;COMPILED CODE?
	 JRST UNWNCM		;NOPE, USE PROGN
UNWPUS==:13			;NUMBER OF PUSHES DONE ON FXP
	MOVEI TT,(T)
	HRLI TT,-<UNWPUS-1>(FXP);BLT POINTER TO DATA THAT MUST BE MOVED
	AOS TT
	MOVEI D,UNWPUS-1(TT)	;BLT END POINTER
	BLT TT,(D)		;BLT ALL IMPORTANT FXP DATA
	HRROI FXP,(D)		;NEW FXP
IFN PDLBUG,[
	PUSH P,TT
	FXPFIXPDL TT
	POP P,TT
]	;END OF IFN PDLBUG

	PUSHJ P,(B)		;INVOKE THE UNWINDPROTECTION CODE
	SKIPA
UNWNCM:	 PUSHJ P,IPROGN
	PUSHJ P,UNBIND		;UNDO THE NOINTERRUPT PROTECTION
	PUSHJ P,RSTX5		;RESTORE ACS
	PUSHJ FXP,RST5
	POPI FXP,1		;FLUSH SAVED UNREAL FROM STACK
	JRST UNWPR2		
UNWNXT:	MOVE D,<-LEP1+1>+<CATRTN-ERRTN>(D) ;GO BACK ONE CATCH
	JUMPN D,UNWPR1		;IF MORE FRAMES TO CHECK THEN GO ON
UNWPRT:	POP FXP,TT
	POP FXP,R
	POP FXP,T
	POP FXP,D
	POPJ FXP,

SUBTTL	VARIOUS COMMON EXITS

CIN0:	IN0	;SURPRISE!

;;; THESE ROUTINES ARE USEFUL FOR CONSING UP LISTS OF NUMBERS
;;; (AS STATUS FUNCTIONS OFTEN DO, FOR INSTANCE).
;;; A CALL TO CONS1FX WILL TAKE A NUMBER IN TT AND MAKE A SINGLETON
;;; LIST OF IT.  SUCCESSIVE CALLS TO CONSFX WILL THEN TACK NEW NUMBERS
;;; ONTO THE FRONT OF THE LIST.  CONS1PFX AND CONSPFX ARE SIMILAR,
;;; BUT POP THE NUMBER FROM FXP.  IN THIS WAY ONE CAN PRODUCE NUMBERS
;;; IN FORWARDS ORDER, PUSHING THEM ON FXP, THEN USE THESE ROUTINES
;;; TO CONS THEM UP IN REVERSE ORDER, PRODUCING A FORWARDS LIST OF THEM.

CONS1PFX:	TDZA B,B
CONS1FX:	 TDZA B,B
CONSPFX:	  POP FXP,TT
CONSFX:	JSP T,FXCONS
CONSIT:	PUSHJ P,CONS
BAPOPJ:	MOVEI B,(A)
	POPJ P,

;;; OTHER COMMON EXITS

ZPOPJ:	TDZA TT,TT	;ZERO TT, THEN POPJ
POPNVJ:	 JSP T,FXNV1	;FXNV1, THEN POPJ
CCPOPJ:	POPJ P,CCPOPJ	;NOT CPOPJ! WILL SCREW BAKTRACE

0POPJ:	SKIPA A,CIN0	;PUT A LISP FIXNUM 0 IN A AND POPJ
POP2J:	 POPI P,2	;POP 2 PDL SLOTS AND POPJ
CPOPJ:	POPJ P,CPOPJ	.SEE BAKTRACE	;SACRED TO BAKTRACE
POP3J:	POPI P,3
	POPJ P,

POPAJ1:	AOSA -1(P)	;POP INTO A, THEN SKIP RETURN
S1PAJ:	POPI P,1	;POP 1 PDL SLOT, POP INTO A, AND POPJ
POPAJ:	POP P,A		;POP A, THEN POPJ
CPOPAJ:	POPJ P,POPAJ

POP1J1:	AOSA -1(P)	;POP 1 PDL SLOT, THEN SKIP RETURN
POPJ1:	 AOSA (P)	;SKIPPING POPJ RETURN
POP1J:	  POPI P,1	;POP 1 PDL SLOT AND POPJ
CPOP1J:	POPJ P,POP1J

M1TTPJ:	SKIPA TT,XC-1	;-1 IN TT, THEN POPJ
POPCJ:	 POP P,C		;POP C, THEN POPJ
CPOPCJ:	POPJ P,POPCJ

UNLKFALSE:	TDZA A,A	;UNLOCK INTERRUPTS, RETURNING FALSE (NIL)
UNLKTRUE:	 MOVE A,VT.ITY	;UNLOCK INTERRUPTS, RETURNING TRUTH (T)
		UNLKPOPJ

PX1J:	POPI FXP,1		;FLUSH 1 FXP SLOT, THEN POPJ P,
CPXDFLJ:	POPJ P,PXDFLJ

PXDFLJ:	HLLZ D,(P)		;POP FXP INTO D, THEN POPJ P,
	JRST 2,POPXDJ(D)	; AND RESTORE FLAGS FROM THE P SLOT

POPXDJ:	POP FXP,D		;POP FXP SLOT INTO D, THEN POPJ P,
CPXDJ:	POPJ P,POPXDJ

SUBTTL	VARIOUS COMMON SAVE AND RESTORE ROUTINES

SAV5:	PUSH P,A
SAV5M1:	PUSH P,B
SAV5M2:	PUSH P,C
SAV5M3:	PUSH P,AR1
	PUSH P,AR2A
CPOPXJ:	POPJ FXP,

SAV3:	PUSH P,C
SAV2:	PUSH P,B
SAV1:	PUSH P,A
	POPJ FXP,

RST3:	POP P,A
	POP P,B
	POP P,C
	POPJ FXP,
RST2:	POP P,A
	POP P,B
	POPJ FXP,
RST1:	POP P,A
	POPJ FXP,

RST5:	POP P,AR2A
	POP P,AR1
	POP P,C
	POP P,B
	POP P,A
	POPJ FXP,

R5M1PJ:	PUSH FXP,CCPOPJ
RST5M1:	POP P,AR2A
	POP P,AR1
	POP P,C
	POP P,B
CR5M1PJ: POPJ FXP,R5M1PJ

RST5M2:	POP P,AR2A
	POP P,AR1
	POP P,C
	POPJ FXP,

RST5M3:	POP P,AR2A
	POP P,AR1
	POPJ FXP,

SAVX5:	PUSH FXP,T
	PUSHJ P,SAVX3
	PUSH FXP,F
	POPJ P,

SAVX3:	PUSH FXP,TT
	PUSH FXP,D
	PUSH FXP,R
	POPJ P,

RSTX5:	POP FXP,F
	POP FXP,R
	POP FXP,D
PXTTTJ:	POP FXP,TT
POPXTJ:	POP FXP,T
	POPJ P,

RSTX3:	POP FXP,R
RSTX2:	POP FXP,D
RSTX1:	POP FXP,TT
CPOPNVJ:	POPJ P,POPNVJ





SUBTTL	VARIOUS KINDS OF FRAME MARKERS

$ERRFRAME=525252,,EPOPJ		;ERROR FRAME
$EVALFRAME=525252,,POP2J	;EVAL FRAME
;; $APPLYFRAME=525252,,AFPOPJ	;APPLY FRAME DEFINED BELOW
$UIFRAME=525252,,CPOPAJ		;USER INTERRUPT FRAME

;;; FORMAT OF EVALFRAME:
;;;	<FLP>,,<FXP>
;;;	<SP>,,<FORM>
;;;	$EVALFRAME
L$EVALFRAME==3			;LENGTH OF EVALFRAME

;;; FORMAT OF APPLYFRAME:
;;;	-- ARGS --
;;;	<FLP>,,<FXP>
;;;	<SP>,,<FUNCTION>
;;;	$APPLYFRAME
	.SEE L$EVALFRAME
;;; WHERE -- ARGS -- MAY BE ONE OF THREE THINGS, DEPENDING
;;; ON ITS LEFT HALF:
;;;	LH=0	RH=LIST OF ARGS
;;;	LH<0	LH,,RH=AOBJN POINTER TO ARGS VECTOR (E.G. FOR LSUBR)
;;;	LH>0	RH=LAST ARG; OTHER ARGS ARE BELOW THIS ON THE
;;;		STACK. IN THIS CASE THE APPLYFRAME MAY BE MORE
;;;		THAN FOUR WORDS LONG.
;;; EXAMPLE:		MOVEI A,QFOO
;;;			MOVEI B,QBAR
;;;			CALL 2,QUUX
;;;	CAUSES THIS APPLYFRAME TO APPEAR ON THE STACK:
;;;			0,,QFOO
;;;			2,,QBAR
;;;			<FLP>,,<FXP>
;;;			<SP>,,QUUX
;;;			$APPLYFRAME

AFPOPJ:	HLRE T,-2(P)		;APPLYFRAME POPJ
	SKIPG T			;FIGURE OUT LENGTH OF
	MOVEI T,1		; APPLY FRAME
	ADDI T,2
	HRLI T,(T)
	SUB P,T			;POP CRUFT FROM PDL
	POPJ P,			;RETURN

$APPLYFRAME=525252,,AFPOPJ	;APPLY FRAME






SUBTTL	NUMERIC TYPE-TESTING, CONVERSION, AND VALUE ROUTINES

IFN BIGNUM+DBFLAG+CXFLAG,[
FLTSK1:	%WTA NMV5		;UNACCEPTABLE NUMERIC VALUE
IFE NARITH,	JRST 2,@[FLTSKP]	;CLEAR PC FLAGS
]		;END OF IFN BIGNUM+DBFLAG+CXFLAG
FLTSK2:	%WTA NMV3		;NON-NUMERIC VALUE
IFE NARITH,	JRST 2,@[FLTSKP]	;CLEAR PC FLAGS
FLTSKP:	MOVEI TT,(A)		;"FLOAT SKIP" ROUTINE
	LSH TT,-SEGLOG		;  SKIPS 0 FOR FIXNUMS, 1 FOR FLONUMS (OR DOUBLES)
	HRRZ TT,ST(TT)		;LEAVES NUMERIC VALUE IN TT
IFE NARITH,   2DIF JRST @(TT),FLTSTB,QLIST
IFN NARITH,   2DIF [JRST 2,@(TT)]FLTSTB,QLIST	;DISPATCH AND CLEAR PC FLAGS

FLTSTB:	FLTSK2		;LIST	;ERROR
	FLTSFX		;FIXNUM	;SKIPS 0
	FLTSFL		;FLONUM	;SKIPS 1
DB$	FLTSFL		;DOUBLE	;SKIPS 1
CX$	FLTSK1		;COMPLEX;ERROR
DX$	FLTSK1		;DUPLEX	;ERROR
BG$	FLTSK1		;BIGNUM	;ERROR
	FLTSK2		;SYMBOL	;ERROR
HN$  REPEAT HNKLOG+1, FLTSK2	;HUNKS	;ERROR
	FLTSK2		;RANDOM	;ERROR
	FLTSK2		;ARRAY	;ERROR
IFN .-FLTSTB-NTYPES, WARN [WRONG LENGTH TABLE]

IFN BIGNUM*<1-NARITH>, NVSKBG:
IFN BIGNUM*NARITH, NMSKBG:
FLTSFX:	MOVE TT,(A)
	JRST (T)

IFN BIGNUM*<1-NARITH>, NVSKFX:
FLTSFL:	MOVE TT,(A)
	JRST 1(T)


IFN BIGNUM*<1-NARITH>,[
NVSKP2:	%WTA NMV3		;NON-NUMERIC VALUE
NVSKIP:	MOVEI TT,(A)		;"NUMERIC VALUE SKIP"
	LSH TT,-SEGLOG		;SKIPS: 0 = BIGNUM, 1 = FIXNUM, 2 = FLONUM, ELSE ERROR
	HRRZ TT,ST(TT)		;LEAVES NUMERIC VALUE IN TT
   2DIF JRST @(TT),NVSKTB,QLIST		.SEE STDISP

NVSKTB:	NVSKP2		;LIST	;ERROR
	NVSKFX		;FIXNUM	;SKIPS 1
	NVSKFL		;FLONUM	;SKIPS 2
DB$	NVSKP2		;DOUBLE
CX$	NVSKP2		;COMPLEX
DX$	NVSKP2		;DUPLEX
BG$	NVSKBG		;BIGNUM	;SKIPS 0, LEAVES BIGNUM HEADER IN TT
	NVSKP2		;SYMBOL	;ERROR
HN$  REPEAT HNKLOG+1, NVSKP2	;HUNKS	;ERROR
	NVSKP2		;RANDOM	;ERROR
	NVSKP2		;ARRAY	;ERROR
IFN .-NVSKTB-NTYPES, WARN [WRONG LENGTH TABLE]

NVSKFL:	MOVE TT,(A)
	JRST 2(T)
]		;END OF IFN BIGNUM*<1-NARITH>





IFN NARITH,[

;;; NUMERIC SKIP ROUTINE
;;;		JSP T,NMSKIP
;;;	BG$	 ...		;HERE FOR BIGNUMS; LEAVES HEADER IN TT
;;;	DX$	 ...		;HERE FOR DUPLEX
;;;	CX$	 ...		;HERE FOR COMPLEX
;;;	DB$	 ...		;HERE FOR DOUBLE; LEAVES FIRST WORD IN TT
;;;		 ...		;HERE FOR FLONUM; LEAVES VALUE IN TT
;;;		...		;HERE FOR FIXNUM; LEAVES VALUE IN TT
;;; ALSO CLEARS THE PC FLAGS

NMSKP2:	%WTA NMV3		;NON-NUMERIC VALUE
NMSKIP:	MOVEI TT,(A)
	LSH TT,-SEGLOG
	HRRZ TT,ST(TT)
   2DIF [JRST 2,@(TT)]NMSKTB,QLIST

;PC FLAGS IN THIS TABLE MUST BE ZERO
NMSKTB:	NMSKP2			;LIST
	NMSKFX			;FIXNUM
	NMSKFL			;FLONUM
DB$	NMSKDB			;DOUBLE
CX$	NMSKCX			;COMPLEX
DX$	NMSKDX			;DUPLEX
BG$	NMSKBG			;BIGNUM
	NVSKP2			;SYMBOL
HN$  REPEAT HNKLOG+1, NVSKP2	;HUNKS
	NVSKP2			;RANDOM
	NVSKP2			;ARRAY
IFN .-NVSKTB-NTYPES, WARN [WRONG LENGTH TABLE]

NMSKFX:	MOVE TT,(A)
	JRST BIGNUM+DXFLAG+CXFLAG+DBFLAG+1(T)

NMSKFL:	MOVE TT,(A)
	JRST BIGNUM+DXFLAG+CXFLAG+DBFLAG(T)

DB$	NMSKDB:	MOVE TT,(A)
DB$		JRST BIGNUM+DXFLAG+CXFLAG(T)

CX$	NMSKCX:	JRST BIGNUM+DXFLAG(T)

DX$	NMSKDB:	JRST BIGNUM(T)

]		;END OF IFN NARITH



LR70==:20			;LAP AND FASLAP HAVE THIS QUANTITY BUILT IN

D10.0:	10.0 
	   0
D1.0E8:	1.0^8
	  0

CDUPL1:	DUPL1				;FOR (% 0 0 DUPL1)
CCMPL1:	CMPL1				;FOR (% 0 0 CMPL1)
CDBL1:	DBL1				;FOR (% 0 0 DBL1)
CFIX1:	FIX1				;FOR (% 0 0 FIX1)
CFLOAT1: FLOAT1				;FOR (% 0 0 FLOAT1)
R70:	REPEAT LR70, .RPCNT,,.RPCNT	;COMMON LAP CONSTANTS ALSO USED BY LISP CODE

ZZZ==5
IFL ZZZ-NACS, ZZZ==NACS		;NEED AT LEAST <NACS> OF THESE
REPEAT ZZZ, .RPCNT-ZZZ
XC::			;WRITE "XC-N" TO GET THE CONSTANT -N FOR SMALL N


;;; INTERNAL FLONUM-TO-FIXNUM CONVERSION; DOES NO ERROR CHECKS.
;;; CONVERTS NUMBER IN TT TO BE A FIXNUM, CLOBBERING D.
;;; THE CONVERSION IS A "FLOOR" OR "ENTIER" FUNCTION.
;;; THAT IS, 3.5 => 3, BUT -3.5 => -4.

IFIX:	MULI TT,400		;EXPONENT IN TT, MANTISSA IN D
	TSC TT,TT		;THIS HACK GETS MAGNITUDE OF EXPONENT
	ASH D,-243(TT)		;SHIFT THE MANTISSA
	MOVE TT,D		;RESULT IN TT
	JRST (T)


;;; INTERNAL FIXNUM-TO-FLONUM CONVERSION.  SAVES D.

IFLOAT:	TLNE TT,777000		;FOR POSITIVE INTEGERS 27. BITS OR LESS,
	 JRST IFLT1		; CAN JUST USE FSC TO SCALE
IFLT5:	FSC TT,233		;FSC NORMALIZES RESULT
	JRST (T)

IFLT1:	TLC TT,777000		;THE SAME HACK WORKS FOR NEGATIVE NUMBERS
	TLCN TT,777000		; WITH NO MORE THAN 27. SIGNIFICANT BITS
	 JRST IFLT5
IFLT2:	MOVEM D,IFLT9		;FOR 28. TO 35. BITS OF SIGNIFICANCE,
	JUMPL TT,IFLT3		; WE CONVERT THE LEFT AND RIGHT HALVES
	HLRZ D,TT		; SEPARATELY, AND THEN ADD THEM, TRUNCATING
	MOVEI TT,(TT)
IFLT4:	FSC D,255		;SCALE RIGHT HALF
	FSC TT,233		;SCALE LEFT HALF
	FAD TT,D		;ADD TOGETHER
	MOVE D,IFLT9		;RESTORE D
	JRST (T)

IFLT3:	HLRO D,TT		;FOR NEGATIVE NUMBERS, WE MUST
	HRROI TT,(TT)		; PRODUCE THE CORRECT SIGN
	AOJA D,IFLT4

;;; NUMERIC VALUE ROUTINES.  THESE CHECK AN S-EXPRESSION
;;; FOR BEING THE DESIRED NUMERIC TYPE, AND PRODUCE A
;;; WRNG-TYPE-ARG ERROR IF APPROPRIATE.  OTHERWISE
;;; THE VALUE OF THE NUMBER IS LIFTED INTO TT (D,R,F).

COMMENT |FXNV1: FXNV2: FXNV3: FXNV4:|

;;; FXNV1 (2,3,4) TAKES S-EXP IN A (B,C,AR1) AND PUTS VALUE IN TT (D,R,F).

IRPC AC,,[1234]
EFXNV!AC:
IFN AC-A,	EXCH A,AC
		%WTA FXNMER
IFN AC-A,	EXCH A,AC
FXNV!AC:	MOVEI TT-1+AC,(AC)	;CHECK DATA TYPE
	ROT TT-1+AC,-SEGLOG
	SKIPL TT-1+AC,ST(TT-1+AC)
	 TLNN TT-1+AC,FX		;SKIP IFF FIXNUM
	  JRST EFXNV!AC			;LOSE
	MOVE TT-1+AC,(AC)		;GET VALUE IN NUMERIC AC
	JRST (T)
TERMIN


FLNV1X:	AOJA T,FLNV1		;FLNV1 WITH SKIP RETURN

EFLNV1:	%WTA FLNMER
FLNV1:	SKOTT A,FL		;GET FLONUM VALUE IN TT FROM A
	 JRST EFLNV1
	MOVE TT,(A)
	JRST (T)

IFN DBFLAG,[
EDBNV1:	%WTA DBNMER
DBNV1:	SKOTT A,DB		;GET DOUBLE VALUE IN (TT,D) FROM A
	 JRST EDBNV1		;HIGH ORDER WORD IN TT, LOW ORDER IN D
KA	MOVE TT,(A)
KA	MOVE D,1(A)
KIKL	DMOVE TT,(A)
	JRST (T)
]		;END OF IFN DBFLAG

IFN CXFLAG,[
CXNV1X:	AOJA T,CXNV1		;CXNV1 WITH SKIP RETURN

ECXNV1:	%WTA CXNMER
CXNV1:	SKOTT A,CX		;GET COMPLEX VALUE IN (TT,D) FROM A
	 JRST ECXNV1		;REAL PART IN TT, IMAGINARY IN D
KA	MOVE TT,(A)
KA	MOVE D,1(A)
KIKL	DMOVE TT,(A)
	JRST (T)
]		;END OF IFN CXFLAG

IFN DXFLAG,[
EDXNV1:	%WTA DXNMER
DXNV1:	SKOTT A,DX		;GET DUPLEX VALUE IN (R,F,TT,D) FROM A
	 JRST EFLNV1		;REAL PART IN (R,F), IMAGINARY IN (TT,D)
KA	REPEAT 4, MOVE TT+<2#.RPCNT>,.RPCNT(A)
KIKL	DMOVE R,2(A)
KIKL	DMOVE TT,(A)
	JRST (T)
]		;END OF IFN DXFLAG

   BAKPRO
RSXST:	HRRZ TT,VREADTABLE	;READ CHARACTER SYNTAX
	HRRZ TT,TTSAR(TT)	; TABLE SETUP
	HRLI TT,((A))		;USED AS INDIRECT ADDRESS WITH
	MOVEM TT,RSXTB		;INDEX FIELD A
   NOPRO
	JRST (T)





SUBTTL	SUPPORT FOR LAP/FASLAP CODE

;;; USE THE PUSHN MACRO TO PUSH N NIL'S (0'S, 0.0'S) ONTO P (FXP, FLP).
;;; IT WILL GENERATE  JSP T,NPUSH-N  (0PUSH, 0.0PUSH) AS APPROPRIATE.
;;; COMPILED CODE USES THESE ROUTINES VERY FREQUENTLY.

REPEAT NNPUSH,	CONC \NNPUSH-.RPCNT,NPUSH,:	PUSH P,R70
NPUSH:	JRST (T)

REPEAT N0PUSH,	CONC \N0PUSH-.RPCNT,PUSH,:	PUSH FXP,R70
0PUSH:	JRST (T)

REPEAT N0.0PUSH,	CONC \N0.0PUSH-.RPCNT,.PUSH,:	PUSH FLP,R70
0.0PUSH: JRST (T)

40PUSH:	PUSH FLP,T
REPEAT 40/N0PUSH,	JSP T,0PUSH-N0PUSH
ZZZ==40-N0PUSH*<40/N0PUSH>
IFN ZZZ, JSP T,0PUSH-ZZZ
	POPJ FLP,


CINTREL:	INTREL		;RANDOM USEFUL RETURN ADDRESS

INTREL:	POP FXP,INHIBIT	.SEE UNLOCKI	;COME HERE TO PERFORM AN UNLOCKI
CHECKI:	SKIPN NOQUIT		;CHECK FOR DELAYED INTRRUPTS
	 SKIPN INTFLG
	  POPJ P,		;EXIT IF NONE
	JRST CKI0		;ELSE GO PROCESS
.SEE INTXIT


	JRST CTCALL		;CATCHALL IN COMPILED CODE
	JRST CATBAR		;CATCH-BARRIER IN COMPILED CODE
	JRST CATPUS		;COMPILED CODE CALLS CATCH
ERSETUP:
	PUSH P,B	;COMPILED CODE CALLS ERRSET
	JSP T,ERSTP
	MOVEM P,ERRTN
	SETZM ERRSW
	SKIPE A			;VALUE IN A DESCRIBES WHETHER ERRORS PRINT
	 SETOM ERRSW
	JRST (TT)

SUBTTL	SUPPORT FOR COMPILED LSUBRS

;;; ORDINARY TYPE COMPILED LSUBRS BEGIN THEIR CODE WITH
;;;	JSP D,.LCALL
;;; NUMERIC TYPE COMPILED LSUBRS BEGIN THEIR CODE WITH
;;;	JSP D,.LCALL-N		;N IS A FUNCTION OF THE TYPE
;;;	 JSP D,.LCALL
;;; THIS ROUTINE TAKES CARE OF BINDING ARGLOC AND ARGNUM FOR THE
;;; BENEFIT OF THE ARG, SETARG, AND LISTIFY FUNCTIONS,
;;; AND TAKE CARE OF FLUSHING THE ARGUMENTS FROM THE STACK.

;;; THE ORDER OF THESE ENTRY POINTS IS BUILT INTO THE COMPILER
	JRST .LCADX	;SETUP FOR DUPLEX TYPE COMPILED LSUBRS
	JRST .LCACX	;SETUP FOR COMPLEX TYPE COMPILED LSUBRS
	JRST .LCADB	;SETUP FOR DOUBLE TYPE COMPILED LSUBRS
	JRST .LCAFL	;SETUP FOR FLONUM TYPE COMPILED LSUBRS
	JRST .LCAFX	;SETUP FOR FIXNUM TYPE COMPILED LSUBRS
.LCALL:	PUSH P,R70	;SETUP FOR REGULAR COMPILED LSUBRS, OR NCALL ENTRY
.LCAF5:	MOVN TT,T		;NUMBER OF ARGS
	ADDI T,-1(P)		;ADDR OF BEGINNING OF ARG VECTOR
	CAIL TT,XHINUM		;XHINUM IS TYPICALLY >777, SO THERE'S LITTLE
	 JRST LXPRLZ		; CHANCE OF THIS SCREW, BUT BETTER BE SAFE
	MOVEI A,IN0(TT)
	MOVEI TT,(T)
	JSP T,SPECBIND
	   0 TT,ARGLOC		;ARGLOC HOLDS PDL POSITION FOR VECTOR OF LSUBR ARGS
	   0 A,ARGNUM		;ARGNUM IS NUMBER OF ARGS, AS A LISP FIXNUM
	PUSHJ P,(D)		;CALL THE USER FUNCTION, NUMBER OF ARGS IN A
	POP P,D
	SKIPN T,@ARGNUM
	 JRST .LCAF7		;MIGHT AS WELL BUM FOR NO ARGUMENTS
	HRLS T			;GOT TO GET RID OF THE ARGUMENTS
	SUB P,T
.LCAF7:	JUMPE D,UNBIND		;THIS EXIT SIGNALS CALL TO NOTYPE LSUBR, OR NCALL TO NUMERIC
	PUSH P,D		;ELSE EXIT THROUGH FIX1 OR EQUIVALENT,
	JRST UNBIND		; MEANING REGULAR CALL TO NUMERIC LSUBR

.LCAFX:	PUSH P,CFIX1		;PUSH ADDRESS FOR CONVERTINGMACHINE NUMBER TO FIXNUM
	AOJA D,.LCAF5		;INCREMENT D PAST THE CALL TO .LCALL-0 WHICH FOLLOWS

.LCAFL:	PUSH P,CFLOAT1
	AOJA D,.LCAF5

.LCADB:
DB$	PUSH P,CDBL1
DB$	AOJA D,.LCAF5
DB%	LERR [SIXBIT \CALL TO DOUBLE-TYPE USER LSUBR!\]

.LCACX:
CX$	PUSH P,CCMPL1
CX$	AOJA D,.LCAF5
CX%	LERR [SIXBIT \CALL TO COMPLEX-TYPE USER LSUBR!\]

.LCADX:
DX$	PUSH P,CDUPL1
DX$	AOJA D,.LCAF5
DX%	LERR [SIXBIT \CALL TO DUPLEX-TYPE USER LSUBR!\]

;;; THESE THREE FUNCTIONS MERELY SAVE THE LOSER THE TROUBLE OF TYPING "SETQ ".

NORET:	PUSHJ P,NOTNOT		;SUBR 1
	HRRZM A,VNORET
	POPJ P,

.RSET:	PUSHJ P,NOTNOT		;SUBR 1
	MOVEM A,V.RSET
	POPJ P,

NOUUO:	PUSHJ P,NOTNOT		;SUBR 1
	HRRZM A,VNOUUO
	POPJ P,


SUBTTL	VARIOUS LISTING AND DE-LISTING ROUTINES

LIST:	PUSH FXP,CCPOPJ		;LSUBR
LISTX:	MOVEI A,NIL		;BASICALLY, THE FUNCTION "LIST"
	SKIPN R,T		; CALLED WITH A PUSHJ FXP,
LISTX3:	 JUMPE R,CPOPXJ
	MOVEI B,(A)		;CLOBBERS A,B,T,TT,R
	POP P,A
	JSP T,PDLNMK
	JSP T,%CONS
	AOJA R,LISTX3

MAKLST:	JSP T,FXNV1
	TDZA A,A
	 PUSHJ P,NXCONS
	SOJGE TT,.-1
	POPJ P,

;;; INTERNAL LISTING FUNCTION; EVALUATES A LIST OF ARGS, 
;;; STACKING THEIR VALUES ON THE PDL

KLIST:	HLRZ B,(A)		;SUPER-HACKISH VERSION
	PUSH P,B
	HRRZ A,(A)
JLIST:	HLRZ B,(A)		;HACKISH VERSION WHICH DOESN'T
	PUSH P,B		; EVAL FIRST ARG OR COUNT IT
	HRRZ A,(A)
ILIST:	MOVEI T,0		;CALLED BY JSP TT,ILIST
	JUMPE A,(TT)
	PUSH FXP,TT
	PUSH FXP,T		;CONTAINS 0 - USED AS COUNTER
	PUSH FXP,R		;MUST SAVE R!
ILIST1:	PUSH P,A		;OTHERWISE, THIS EVAL LOOP
	HLRZ A,(A)		; MAY CLOBBER ANYTHING
	PUSHJ P,EVAL
ILIST3:	EXCH A,(P)		;SAVE VALUE ON STACK
	HRRZ A,(A)
	SOS -1(FXP)		;COUNT VALUES
	JUMPN A,ILIST1
	POP FXP,R		;RESTORE R
	POP FXP,T		;T HAS -<# OF VALUES ON PDL>
	POPJ FXP,


;;; 	JSP T,GTRDTB	;GETS READTABLE IN AR2A, AND MAYBE CHECKS FOR ERRORS.

GTRDTB:	HRRZ AR2A,VREADTABLE
	SKIPN V.RSET		;ERROR CHECKS IFF *RSET NON-NIL
	 JRST (T)
	SKOTT AR2A,SA
	 JRST GTRDT8		;ERROR IF NOT ARRAY
	MOVE TT,ASAR(AR2A)
	TLNE TT,AS<RDT>		;ERROR IF NOT READTABLE TYPE ARRAY
	 JRST (T)
GTRDT8:	PUSH P,B
	MOVEI A,QREADTABLE
	MOVEI B,READTABLE	;ON ERROR, RESTORE TO STANDARD READTABLE
	PUSHJ P,BDGLBV		;GIVE OUT A FAIL-ACT
	POP P,B
	JRST GTRDTB		;TRY AGAIN IF LOSER RETURNS TO US


SUBTTL	NOINTERRUPT FUNCTION

NOINTERRUPT:	JUMPE A,CHECKU	;SUBR 1 - ENABLE/DISABLE
	CAIN A,QTTY
	 JRST CHECKU
	SETO A,			; RANDOM ASYNCHRONOUS
NOINT0:	EXCH A,UNREAL		; "REAL TIME" INTERRUPTS
	SKIPGE A		; (CLOCKS AND TTY)
	 MOVEI A,TRUTH
	POPJ P,

;;; CHECK FOR ANY DELAYED "REAL TIME" INTERRUPTS, AND RUN THEM
;;; IF ANY. MUST DO THEM IN THE ORDER ^G/^X, CLOCKS, AND OTHER.
;;; NOTE THAT AFTER A ^G OR ^X, CHECKU GETS CALLED AGAIN.
;;; DESTROYS D AND F

CHECKU:	SKIPN UNREAL	;NONE CAN BE PENDING IF NOT DELAYING
	 JRST NOINT0

CHECKQ:	PUSH P,A
	PUSHJ P,UINTPU
NOINT1:	SKIPE (P)
	 JRST NOINT5
	SKIPE D,UNRC.G	;PROCESS ^G/^X FIRST
	 JRST CKI2A	;TOP LEVEL OR ERRRTN WILL DO A CHECKU
NOINT5:	PUSHJ P,NOINTA	;NOW PROCESS ALARMCLOCK INTERRUPTS
	 JRST NOINT1
NOINT3:	SKIPG F,UNREAR	;NOW ANY OTHER INTERRUPTS
	 JRST NOINT4
	SOS UNREAR
	MOVE D,UNREAR(F)
	TRNE D,400000	;IF (NOINTERRUPT 'TTY), SUPPRESS
	 SKIPN (P)	; TTY INTERRUPTS AT THIS TIME
	  PUSHJ P,YESINT	;MAY CLOBBER R (SEE UISTAK)
	JRST NOINT1

NOINT4:	SKIPG A,UNREAL
	 MOVEI A,TRUTH
	POP P,UNREAL
	JRST UINTEX

;;; DO NOT TRANSFORM THE "PUSHJ, POPJ" SEQUENCES INTO "JRST".
;;; YESINT DEPENDS ON LOOKING AT THE PUSHJ ADDRESS TO SEE WHETHER
;;; WE CAME FROM NOINTERRUPT OR ELSEWHERE!

NOINTA:	SKIPN D,UNRRUN
	 JRST NOINT2
	SETZM UNRRUN
	PUSHJ P,YESINT
	POPJ P,
NOINT2:	SKIPN D,UNRTIM
	 JRST POPJ1
	SETZM UNRTIM
	PUSHJ P,YESINT
	POPJ P,

ENOINT::.			.SEE UINT0N

	
	
SUBTTL	CAR/CDR ROUTINES AND FUNCTIONS

;;; HERE BELOW FOLLOW THE "FAST" CAR-CDR ROUTINES, 
;;; USED WHEN *RSET=NIL, AND BY COMPILED CODE.
;;; NOTE THAT THE RELATIVE DISPLACEMENT OF THE FUNCTION ENTRY POINTS
;;; IS VERRRRRY IMPORTANT TO THE POOOR COMPLR. 
;;; DONT EVER CHANGE THEM!!

CARCDR:				;INDEX NUMBER FOR CALL BY COMPILED CODE
%CADDDR:	SKIPA A,(A)	; 0
%CADDAR:	HLRZ A,(A)	; 1
%CADDR:	SKIPA A,(A)		; 2
%CADAR:	HLRZ A,(A)		; 3
%CADR:	SKIPA A,(A)		; 4
%CAAR:	HLRZ A,(A)		; 5
%CAR:	HLRZ A,(A)		; 6
	JRST (T)
%CDDDDR:	SKIPA A,(A)	; 8
%CDDDAR:	HLRZ A,(A)	; 9
%CDDDR:	SKIPA A,(A)		;10.
%CDDAR:	HLRZ A,(A)		;11.
%CDDR:	SKIPA A,(A)		;12.
%CDAR:	HLRZ A,(A)		;13.
%CDR:	HRRZ A,(A)		;14.
	JRST (T)
%CAADDR:	SKIPA A,(A)	;16.
%CAADAR:	HLRZ A,(A)	;17.
%CAADR:	SKIPA A,(A)		;18.
%CAAAR:	HLRZ A,(A)		;19.
	JRST %CAAR
%CDADDR:	SKIPA A,(A)	;21.
%CDADAR:	HLRZ A,(A)	;22.
%CDADR:	SKIPA A,(A)		;23.
%CDAAR:	HLRZ A,(A)		;24.
	JRST %CDAR
%CAAADR:	SKIPA A,(A)	;26.
%CAAAAR:	HLRZ A,(A)	;27.
	JRST %CAAAR
%CDDADR:	SKIPA A,(A)	;29.
%CDDAAR:	HLRZ A,(A)	;30.
	JRST %CDDAR
%CDAADR:	SKIPA A,(A)	;32.
%CDAAAR:	HLRZ A,(A)	;33.
	JRST %CDAAR
%CADADR:	SKIPA A,(A)	;35.
%CADAAR:	HLRZ A,(A)	;36.
	JRST %CADAR




;;; THE FOLLOWING TABLE IS A TRANSFER VECTOR: GIVEN THE INFO-NUMBER
;;;  OF A CAR-CDR OPERATION, SAY N, THEN CARCDR[N-2] IS THE
;;;  ADDRESS OF THE FAST ROUTINE FOR THAT OPERATION.  NOTE THAT THE
;;;  INFO-NUMBER IS NOT THE SAME AS THE INDEX-NUMBER-FOR-COMPILED-CODE
;;; ALSO, THE TOP 13. BITS ENCODE A DECOMPOSITON OF THE A-D STRING INTO
;;;  1) THE LEFT-MOST OPERATION  - 1 BIT (1 FOR "D" AND 0 FOR "A"), 
;;;  2) THE INFO NUMBER OF THE "TAIL" - 6 BITS ("TAIL" IS REMAINDER OF 
;;; 	A-D STRING,  E.G., "TAIL" OF "ADDAD" IS "DDAD")
;;;  3) THE "BOY ARE THESE NUMBERS RANDOM" NUMBER WHICH THE COMPILER
;;; 	USES WHEN OUTPUTTING FAST JSP CALLS THE THE %CARCDR ROUTINES.

%CARCDR:	
IRP X,,[A,D
AA,AD,DA,DD
AAA,AAD,ADA,ADD,DAA,DAD,DDA,DDD
AAAA,AAAD,AADA,AADD,ADAA,ADAD,ADDA,ADDD
DAAA,DAAD,DADA,DADD,DDAA,DDAD,DDDA,DDDD]AD,,[0,1
0,0,1,1
0,0,0,0,1,1,1,1
0,0,0,0,0,0,0,0
1,1,1,1,1,1,1,1]TL,,[0,0
2,3,2,3
4,5,6,7,4,5,6,7
10,11,12,13,14,15,16,17
10,11,12,13,14,15,16,17]
	zz==%C!X!R
	AD_35.+TL_29.+<zz-carcdr>_23.+zz
TERMIN

ICADRP:	PUSH P,CFIX1		;+INTERNAL-CARCDRP
	JSP T,IC.RP
	 SETO TT,
	POPJ P,

;;; SKIPE IF CARCDR FUNCTION, WITH CODE WORD IN TT
IC.RP:	CAIL A,QCAR		   ;First
	 CAILE A,QCDDDDR	   ;Last CARCDR sym
	  JRST (T)
2DIF [HLRZ TT,(A)]%CARCDR,QCAR
	LSH TT,-5
	JRST 1(T)



;;; STANDARD INTERPRETER SUBRS FOR THE VARIOUS CAR-CDR
;;; OPERATIONS. THESE CALL A CENTRAL DECODER WHICH IN *RSET
;;; MODE PERFORMS TYPE CHECKING ON THE OPERAND AT EACH STEP.


CRSUBRS:
IRP X,,[A,D,AA,AD,DA,DD
AAA,AAD,ADA,ADD,DAA,DAD,DDA,DDD
AAAA,AAAD,AADA,AADD,ADAA,ADAD,ADDA,ADDD
DAAA,DAAD,DADA,DADD,DDAA,DDAD,DDDA,DDDD]
C!X!R:	JSP F,CR0
TERMIN

;;; LET A=0, D=1, AND LET CWXYZR BE A CAR-CDR OPERATION, WITH
;;; THE VARIABLES W,X,Y,Z RANGING OVER {,A,D}. LET A NUMBER N
;;; BE COMPUTED CORRESPONDING TO CXYZWR AS FOLLOWS:  
;;; N =			   Z + 2     IF W,X,Y ARE NULL
;;; N =		     Y*2 + Z + 4     IF W,X ARE NULL
;;; N =        X*4 + Y*2 + Z + 10    IF W IS NULL
;;; N = W*10 + X*4 + Y*2 + Z + 20    IF NONE OF W,X,Y,Z ARE NULL
;;; NOTE TWO THINGS:
;;; [1] THIS REPRESENTATION OF A CAR-CDR OPERATION IS EASILY
;;; BITWISE DECODABLE. THE POSITION OF THE FIRST 1 BIT
;;; INDICATES THE START OF THE REST OF THE ENCODING, WHICH HAS
;;; 0 FOR CAR, 1 FOR CDR AT EACH POSITION.
;;; [2] FOR ANY SET OF OPERATIONS COMPLETE FROM CAR AND CDR,
;;; THROUGH CAAR, CADR, ... TO "LEVEL M" CAR-CDR'S (THOSE WITH
;;; M A'S AND D'S), THIS ENCODING PRODUCES A COMPACT ENCODING,
;;;			      M+1
;;; WITH N RANGING FROM 2 TO 2   -1 INCLUSIVE.
;;;
;;;  NAME	 N (OCTAL)	N (BINARY)
;;;   CAR	   2		   10
;;;   CDR	   3		   11
;;;   CAAR	   4		  100
;;;   CADR	   5		  101
;;;   . . .
;;;   CDDADR	  35		11101
;;;   CDDDAR	  36		11110
;;;   CDDDDR	  37		11111




CR0:	SKIPE V.RSET
	 JRST CR1
	POP P,T
	JRST @%CARCDR-<CRSUBRS+1>(F)	;QUICK VERSION FOR *RSET = NIL

CR1:	PUSHJ P,SAVX3		;COMPILED CODE ASSUMES NUMACS SAFE
CR1A:	MOVEI D,(A)
   2DIF [MOVEI T,(F)]400002,CRSUBRS+1	;400000 IS FOR CA.DER
CR2:	SKOTT D,LS		;CHECK FOR LIST TYPE
	 JRST CR4
CR3:	TRNN T,1		;SKIP IF CDR OPERATION
	 JRST CR3B
	HRRZ D,(D)
CR3A:	ROT T,-1
	TRNE T,776		;SKIP IF ALL DONE
	 JRST CR2
CR7:	MOVEI A,(D)
	JRST RSTX3		;COMPILED CODE ASSUMES NUMACS SAFE

CR3B:	TLNE TT,HNK		;IF ITS A HUNK, THEN CAR HAD BETTER
	 JRST CR3C
	HLRZ D,(D)		;TAKE THE CAR
	JRST CR3A
CR3C:	HLRZ TT,(D)
	CAIN D,-1		;NOT BE A UNUSED SLOT
	 JRST .+3
	  MOVE D,TT
	  JRST CR3A
	MOVEI A,(D)
	PUSHJ P,WLHERR
	MOVEI D,(A)
	JRST CR2

CR4:	TRNE T,1		;IF NEXT ARG ISN'T A LIST
	 SKIPA R,VCDR		;THEN CHECK OUT AGAINST PERMISSIBLITIES
	  MOVE R,VCAR
	JUMPN R,CR5
	TRNN D,-1		;IF ONLY NIL AND LISTS PERMISSIBLE
	 JRST CR7		;THEN LET NIL BECOME NIL (CAR NIL) = (CDR NIL) = NIL
	JRST CA.DER		;ELSE, BOMB OUT

CR5:	CAIE R,QSYMBOL
	 JRST CR6
	TRNE D,-1
	 TLNE TT,SY
	  JRST CR3
	JRST CA.DER		;LOSE IF NEITHER NIL NOR SYMBOL

CR6:	CAIN R,QLIST
	 JRST CA.DER		;LIST TEST ON ARG HAS ALREADY FAILED, SO FAIL
	JRST CR3		;IF CAR,CDR NOT "LIST", "SYMBOL", OR "NIL",
				; THEN OK FOR ANYTHING


;;; NTH and NTHCDR - if *RSET is off, try to do fastly 

; (NTH N FOO) RETURNS THE NTH CAR [WHERE (NTH 0 FOO) IS (CAR FOO)]
; 	      EQUIVALENT TO (CAR (NTHCDR N FOO))
; (NTHCDR N FOO) RETURNS THE RESULT OF 'N' CDR'S


NTH:	TDZA R,R
NTHCDR:	MOVEI R,TRUTH		;R IS "NTHCDR"P FLAG - () ==> "NTH"
NTHCD5:	SKIPN D,V.RSET
	 JRST NTHCD6
	  SKOTT A,FX
	   JRST NTHIEN
NTHCD6:	MOVE TT,(A)
	JUMPLE TT,NTHCD0	;MUST BE NON-NEGATIVE
	EXCH A,B		;RESULT TO BE RETURNED IN A
	JUMPN D,NTHCD2		;*RSET ==> DO ERROR CHECK ON EACH ELEMENT
NTHCD1:	HRRZ A,(A)		;DO A CDR
	SOJG TT,NTHCD1		;LOOP UNTIL APPROPRIATE NUMBER OF CDR'S DONE
	JUMPE R,$CAR
	POPJ P,			;THEN RETURN

NTHCD0:	JUMPN TT,NTHIEN		;INDEX "0"
	EXCH A,B
	JUMPN R,CPOPJ		;JUST EXIT FOR NTHCDR
	JUMPE D,$CAR		;BECOME "CAR" FOR (NTH 0 X)
	JRST CAR


NTHCD2:	MOVE F,(B)
	SOS F
	PUSHJ P,LASTCK		;TAKE "(F)" CDRS, SKIP IF SUCCESSFUL
	 JRST NTHER		; ERROR IF ARG-1 CDRS IS ATOMIC
	JUMPN R,NTHCD4
	HRRZ D,(D)
	SKOTT D,LS
	 JUMPN D,NTHER
	HLRZ A,(D)		;FOR "NTH"
	POPJ P,

NTHCD4:	HRRZ A,(D)		;FOR "NTHCDR", TAKE FINAL CDR
	POPJ P,


SUBTTL	SYMBOL CONSER

PNGNK:	ADDI C,PNBUF-1		;ONLY BY INTERN - PURIFIES PNAME IF RELEVANT
	SKIPGE LPNF		;IF LPNF IS NEGATIVE, THE PNAME IS IN PNBUF,
	 PUSHJ P,PNCONS		; SO WE CONS IT UP NOW
	SKIPE B,V.PURE
	 CAIN B,QSYMBOL
	  JRST SYCONS		;NO PURE COPY NEEDED, JUST CONS UP SYMBOL
	PUSHJ P,PURCOPY		;ELSE GET PURE COPY OF PNAME
	JRST PSYCONS		;AND USE PURE CONSER

PNGNK1:	SKIPGE LPNF		;CONS UP PNAME IF NECESSARY
PNGNK2:	 PUSHJ P,PNCONS
SYCONS:				;CONS UP A SYMBOL - PNAME LIST IS IN A
   BAKPRO
	SKIPN FFY		;IF SYMBOL FREELIST EMPTY, GO DO A GC
	 JRST SYCON1
	SKIPN B,FFY2		;IF SYMBOL BLOCK FREELIST EMPTY, MUST GC
	 JRST SYCON1
	MOVEM A,SYMPNAME(B)	;PUT PNAME IN SYMBOL BLOCK
	MOVE A,[SY.ONE,,SUNBOUND] ;INITIAL VALUE CELL IS SUNBOUND
   XCTPRO
	EXCH A,SYMVC(B)		;PUT IN SYMBOL BLOCK
	MOVEM A,FFY2		;CDR SYMBOL BLOCK FREELIST
SYCON2:	MOVSI A,(B)		;INITIAL PROPERTY LIST IS NIL
	EXCH A,@FFY		;CONS UP SYMBOL HEADER
	EXCH A,FFY	
   NOPRO
	POPJ P,

   SPECPRO INTSYX
SYCON1:	PUSHJ P,AGC
	JRST SYCONS

;PURE SYMBOL CONSER
PSYCONS:
BAKPRO
	AOSL B,NPFFY2		;CONS UP A PURE SYMBOL BLOCK
NOPRO
   SPECPRO INTSYQ
	 PUSHJ P,GTNPSG
	ADD B,EPFFY2
	AOS NPFFY2
   SPECPRO INTSYP
	MOVEM A,SYMPNAME(B)
	MOVE A,[SY.ONE+SY.PUR,,SUNBOUND] ;SY.PUR BIT SAYS MAYBE READ-ONLY
	MOVEM A,SYMVC(B)
BAKPRO
	SKIPE FFY		;IF SYMBOL FREELIST EMPTY, GO DO A GC
	 JRST SYCON2
	PUSHJ P,AGC
	JRST SYCON2
   NOPRO


PNCONS:	PUSH FXP,T		;CONS A PNAME LIST OUT OF PNBUF
	MOVEI A,NIL
   2DIF [MOVEI C,(C)]1,PNBUF
PNG2:	MOVE B,A
	MOVE TT,PNBUF-1(C)
	JSP T,FWCONS
	PUSHJ P,CONS
	SOJG C,PNG2
CPXTJ:	JRST POPXTJ

SUBTTL	LIST SPACE CONSERS

;;; THIS SET OF CONSERS IS USED WITHIN THE LISP SYSTEM.
;;; ONLY A AND B ARE CLOBBERED, AND THE ARGUMENTS MUST NOT
;;; BE PDL QUANTITIES.

;;; FOR NCONS, SEE JUST BEFORE "ACONS"
;NCONS:	TRZA B,-1		;(NCONS A) = (CONS A NIL)

NXCONS:	MOVEI B,NIL		;WILL "PUSH" A () ONTO A LIST IN A
XCONS:	 EXCH B,A		;(XCONS A B) = (CONS B A)
CONS:	HRL B,A
   SPECPRO INTC2X
CONS1:	SKIPN A,FFS		;SKIP UNLESS FREELIST EMPTY
	 JRST CONS3
	EXCH B,(A)		;PUT POINTERS IN CELL, GET CDR OF FREELIST
   XCTPRO
	EXCH B,FFS		;CDR FREELIST, COPY OF CELL POINTER TO B
   NOPRO			; (BUT NO ONE CURRENTLY TAKES ADVANTAGE OF IT)
	POPJ P,

   SPECPRO INTC2X
CONS3:	HLR A,B			;DO THIS TO PROTECT POINTERS FROM GC
	PUSHJ P,AGC		;PERFORM A GARBAGE COLLECTION
   NOPRO
	JRST CONS1		;GO TRY AGAIN

;;; THIS SET OF CONSERS IS THE SET AVAILABLE TO INTERPRETED CODE.
;;; THEY MAKE SURE THAT PDL QUANTITIES DO NOT GET INTO LIST STRUCTURE.

$NCONS:	MOVEI B,NIL		;SUBR 1
	EXCH A,B
$XCONS:	JSP T,PDLNMK		;SUBR 2
	EXCH A,B
	JSP T,PDLNMK
	JRST CONS

LIST.:	AOJG T,LIST.9		;LSUBR (1 . N)
	POP P,A			;(CONS A B C D) = (CONS A (CONS B (CONS C D)))
	PUSH FXP,R		;THIS ROUTINE MUST SAVE R AS COMPILED CODE COUNTS ON IT
	MOVE R,T		;LISTX3 WILL WANT COUNT IN R - ALSO SAVE OVER PDLNMK
	JSP T,PDLNMK
	PUSHJ FXP,LISTX3	;LISTIFY ALL BUT LAST ARG,
	POP FXP,R
	POPJ P,			; WITH LAST ARG AS FINAL CDR

;;; THIS SET OF CONSERS IS CALLED FROM COMPILED CODE.
;;; THE "CDR" MUST NOT BE A PDL QUANTITY; THE "CAR" IS PDLNMK'D.

%PDLNC:	TRZA B,-1
%PDLXC:	 EXCH B,A
%PDLC:	CAML A,NPDLL		;VERY FAST CHECK FOR A PDL NUMBER
	 CAMLE A,NPDLH
	  JRST %CONS
	PUSH P,T		;IF PROBABLY A PDL NUMBER,
	JSP T,PDLNM0		; IT'S SO SLOW THAT THIS PART
				; DOESN'T MATTER SO MUCH,
	JRST CONS		; BLETCHEROUS IS IT IS

;;; THIS SET OF CONSERS IS CALLED FROM COMPILED CODE.
;;; ARGUMENTS MUST NOT BE PDL QUANTITIES.
;;; THESE ARE SLIGHTLY FASTER, SINCE T IS USED FOR JSP.

;;; FOR %NCONS, SEE JUST BEFORE "ACONS"
;%NCONS: TRZA B,-1		;(NCONS A) = (CONS A NIL)
%XCONS:	 EXCH B,A		;(XCONS A B) = (CONS B A)
%CONS:	HRLI B,(A)
   SPECPRO INTC2Y
%CONS1:	SKIPN A,FFS		;SKIP UNLESS FREELIST EMPTY
	 JRST %CONS3
	EXCH B,(A)		;PUT POINTERS IN CELL, GET CDR OF FREELIST
   XCTPRO
	EXCH B,FFS		;CDR FREELIST, COPY OF CELL POINTER TO B
   NOPRO			; (BUT NO ONE CURRENTLY TAKES ADVANTAGE OF IT)
	JRST (T)

   SPECPRO INTC2Y
%CONS3:	HLR A,B			;DO THIS TO PROTECT POINTERS FROM GC
	PUSHJ P,AGC		;PERFORM A GARBAGE COLLECTION
   NOPRO
	JRST %CONS1		;GO TRY AGAIN

;THIS ROUTINE IS FOR COMPILED CODE.  IT DOES A PDLNMK CHECK ON BOTH ARGS
%C2NS:	PUSH P,T		;ALLOW RETURN VIA PUSHJ
$C2NS:	EXCH A,B		;WE CAN USE $XCONS, BUT IT WILL ALSO DO AN EXCH
	JRST $XCONS





SUBTTL	NUMBER CONSERS


FIX2:	JSP T,IFIX		;FLONUM TO FIXNUM CONVERSION, FXCONS, POPJ
FIX1:	POP P,T			;FXCONS, THEN POPJ
FXCONS:				;FIXNUM CONS - MAY UNIQUIZE
FIX1A:	CAIGE TT,XHINUM		;IF WITHIN THE RANGE OF THE
	 CAMGE TT,[-XLONUM]	; BUILT-IN TABLE OF UNIQUE FIXNUMS,
	  JRST FWCONS		; THEN NEEDN'T DO A REAL CONS
	MOVEI A,IN0(TT)		;JUST PROVIDE A POINTER INTO THE TABLE
	JRST (T)

   SPECPRO INTZAX
FWCONS:	SKIPN A,FFX		;FULL WORD CONS - ALWAYS CONSES
	 JSP A,AGC4
	EXCH TT,(A)
   XCTPRO
	EXCH TT,FFX
   NOPRO
	JRST (T)



FLCONX:	AOJA T,FLCONS		;FLCONS WITH SKIP RETURN

FLOAT2:	JSP T,IFLOAT		;FIXNUM TO FLONUM, FLCONS, POPJ
FLOAT1:	POP P,T			;FLCONS, THEN POPJ
   SPECPRO INTZAX
FLCONS:				;FLONUM CONS
FPCONS:	SKIPN A,FFL
	 JSP A,AGC4
	EXCH TT,(A)
   XCTPRO
	EXCH TT,FFL
   NOPRO
	JRST (T)

IFN DBFLAG,[
DBL1:	POP P,T
   SPECPRO INTZAX
DBCONS:	HRRZS FFD		;DOUBLE PRECISION CONSER
	SKIPN A,FFD
	 JSP A,AGC4
	EXCH TT,(A)
   XCTPRO
	EXCH TT,FFD
   NOPRO
	MOVEM D,1(A)
	JRST (T)
]		;END OF IFN DBFLAG
IFE DBFLAG,[
DBCONS:	PUSH P,T
DBL1:	MOVEI A,QDOUBLE		;ERROR IF DOUBLES NOT IMPLEMENTED
	%FAC NUM1MS
]		;END OF IFE DBFLAG


IFN CXFLAG,[
CXCONX:	AOJA T,CXCONS		;CXCONS WITH SKIP RETURN

CMPL1:	POP P,T
   SPECPRO INTZAX
CXCONS:	HRRZS FFC		;COMPLEX NUMBER CONSER
	SKIPN A,FFC
	 JSP A,AGC4
	EXCH TT,(A)
   XCTPRO
	EXCH TT,FFC
   NOPRO
	MOVEM D,1(A)
	JRST (T)
]		;END OF IFN CXFLAG
IFE CXFLAG,[
CXCONS:	PUSH P,T
CMPL1:	MOVEI A,QCOMPLEX	;ERROR IS COMPLEX NUMBERS NOT IMPLEMENTED
	%FAC NUM1MS
]		;END OF IFE CXFLAG


IFN DXFLAG,[
DUPL1:	POP P,T
   SPECPRO INTZAX
DXCONS:	HRRZS FFZ		;DOUBLE-PRECISION COMPLEX NUMBER CONSER
	SKIPN A,FFZ
	 JSP A,AGC4
	EXCH R,(A)
   XCTPRO
	EXCH R,FFZ
   NOPRO
	MOVEM F,1(A)
KA	MOVEM TT,2(A)
KA	MOVEM D,3(A)
KIKL	DMOVEM TT,2(A)
	JRST (T)
]		;END OF IFN DXFLAG
IFE DXFLAG,[
DXCONS:	PUSH P,T
DUPL1:	MOVEI A,QDUPLEX		;ERROR IF DUPLICES NOT IMPLEMENTED
	%FAC NUM1MS
]		;END OF IFE DXFLAG

SUBTTL	HUNK PRIMITIVES - CXR, RPLACX, HUNK<N>, HUNK, HUNKIFY


IFE HNKLOG,[
%HUNK1:
%HUNK2:
%HUNK3:
%HUNK4:
%CXR:
%RPX:	LERR [SIXBIT \NO HUNKS IN THIS LISP - HUNK/CXR/RPLACX!\]
]		;END OF IFE HNKLOG


IFN HNKLOG,[

CXR:	JSP T,FXNV1		;SUBR 2
	SKIPE V.RSET
	 JSP F,CXR3		;CHECK ARGS
	ROT TT,-1
	ADDI TT,(B)
	JUMPGE TT,CXR2
	HLRZ A,(TT)		;ODD-NUMBERED COMPONENTS IN LEFT HALVES
	POPJ P,

CXR2:	HRRZ A,(TT)		;EVEN-NUMBERED COMPONENTS IN RIGHT HALVES
	POPJ P,


RPLACX:	JSP T,FXNV1		;SUBR 3
	SKIPE V.RSET
	 JSP F,CXR3		;CHECK ARGS
	CAML C,NPDLL
	CAMLE C,NPDLH
	 JRST .+4
	   EXCH A,C
	   JSP T,PDLNMK		;SIGH - MUST PDLNMK THE DATUM
	   EXCH A,C
	ROT TT,-1
	ADDI TT,(B)
	JUMPGE TT,RPLX2
	HRLM C,(TT)
	JRST BRETJ		;RETURN SECOND ARG

RPLX2:	HRRM C,(TT)
	JRST BRETJ


CXR30:	TLNN T,$FS+VC		;A LIST CELL OR VALUE CELL IS OKAY
	 JRST CXR31		; IF THE INDEX IS 0 OR 1
	JUMPL TT,CXR33
	CAIG TT,1
	 JRST (F)
CXR31:	EXCH A,B
	PUSHJ P,WLHERR
	EXCH A,B
CXR3:	MOVEI T,(B)		;CHECKING ROUTINE FOR CXR/RPLACX
	LSH T,-SEGLOG
	MOVE T,ST(T)
	TLNN T,HNK		;SECOND ARG MUST BE HUNK
	 JRST CXR30
	MOVEI D,2
   2DIF [LSH D,(T)]0,QHUNK0
	CAMLE D,TT		;FIRST ARG MUST BE SMALLER THAN
	 JUMPGE TT,CXR34	; LENGTH OF SECOND, YET NON-NEGATIVE
CXR33:	WTA [BAD HUNK INDEX!]
	JRST -3(F)

CXR34:	MOVE D,TT		;EVERYTHING IS APPARENTLY OKAY
	ROT D,-1
	ADDI D,(B)
	HRRZ T,(D)		;FETCH COMPONENT IN QUESTION
	SKIPGE D
	 HLRZ T,(D)
	CAIN T,-1		;ERROR IF AN UNUSED COMPONENT
	 JRST CXR33
	JRST (F)

WLHERR:	WTA [INVALID OR WRONG LENGTH HUNK!]
	POPJ P,

;;;	IFN HNKLOG

;;; CXR ROUTINE FOR COMPILED CODE.  HUNK IN A, INDEX IN TT.

%CXR:	ROT TT,-1		;QUICK ENTRY FOR COMPILED CALLS
	ADDI TT,(A)
	JUMPGE TT,%CXR2
	HLRZ A,(TT)
	JRST (T)

%CXR2:	HRRZ A,(TT)
	JRST (T)

;;; RPLACX ROUTINE FOR COMPILED CODE.
;;; HUNK IN A, DATUM IN B, INDEX IN TT.
;;; THE DATUM IS GUARANTEED NOT TO BE A PDL QUANTITY.

%RPX:	ROT TT,-1		;HUNK SUBSCRIPT IS PASSED IN TT
	ADDI TT,(A)
	JUMPGE TT,%RPX2
	HRLM B,(TT)
	JRST (T)

%RPX2:	HRRM B,(TT)
	JRST (T)

;;; %HUNK1, %HUNK2, %HUNK3, AND %HUNK4 ROUTINES FOR COMPILED CODE.
;;; THESE ALLOCATE HUNKS OF SIZE 1, 2, 3, OR 4 SUPER-QUICKLY.
;;; ARGUMENTS IN A, B, C, AR1, GUARANTEED NOT TO BE PDL QUANTITIES.

%HUNK1:	SKIPN VMAKHUNK
	 JRST %NCONS
	MOVEI B,(A)		;%HUNK1 IS %HUNK2, WITH ONE UNUSED COMPONENT,
	MOVEI A,-1		; BUT UNFORTUNATELY MUST SHUFFLE ARGS
	JRST %HUNK2

%HNK2A:	HRRZS FFH		;HUNK4 IS THE IMPORTANT CASE
	PUSHJ P,AGC
   BAKPRO
%HUNK2:	SKIPN VMAKHUNK	
	 JRST %CONS
	SKIPG FFH
	 JRST %HNK2A
	HRL B,A
	EXCH B,@FFH
   XCTPRO
	EXCH B,FFH
	EXCH A,B
   NOPRO
	JRST (T)


%HUNK3:	MOVEI AR1,(C)		;HUNK3 IS JUST HUNK4, WITH ONE UNUSED COMPONENT
	MOVEI C,-1		; BUT UNFORTUNATELY MUST SHUFFLE ARGS
	JRST %HUNK4


%HNK4A:	HRRZS FFH+1		;HUNK4 IS THE IMPORTANT CASE
	PUSHJ P,AGC
   BAKPRO
%HUNK4:	SKIPG FFH+1
	 JRST %HNK4A
	HRL AR1,A
	EXCH AR1,@FFH+1
   XCTPRO
	EXCH AR1,FFH+1
	EXCH A,AR1
	HRRZM B,1(A)
	HRLM C,1(A)
   NOPRO
	JRST (T)

;; For various misc hacks of REES and RWK.  Exchange hunk and A.
;; Only makes sense in very strange hand-code.
IFN USELESS,[

%HNKRA:	HRRZS FFH+1		   ;Be sure sign bit is off
	PUSHJ P,AGC
   BAKPRO
%HNK4R:	SKIPG FFH+1
	  JRST %HNKRA
	EXCH A,@FFH+1		   ;Pick up sticks
   XCTPRO
	EXCH A,FFH+1		   ;A -> Hunk with old contents of A
   NOPRO
	JRST (T)
]

;;;	IFN HNKLOG

HNKSZ0:	WTA [NOT A HUNK - HUNKSIZE!]
	JRST HNKSZ1
HUNKSIZE:			;SUBR 1 - NCALLABLE
	PUSH P,CFIX1
HNKSZ1:	MOVEI T,(A)
	LSH T,-SEGLOG
	SKIPL T,ST(T)
	 JRST HNKSZ0
	MOVEI TT,2
	TLNE T,HNK
	 JRST .+4
	   SKIPN VMAKHUNK
	    POPJ P,		;RANDOM CONSES ARE OF SIZE 2
	   JRST HNKSZ0
	MOVEI D,1
   2DIF [LSHC TT,(T)]0,QHUNK0
	ADDI D,-1(A)
HNKSZ3:	SETCM R,(D)		;OTHERWISE CALCULATE LENGTH
	TLNE R,-1
	 POPJ P,
	TRNE R,-1
	 SOJA TT,CPOPJ
	SUBI D,1
	SUBI TT,2
	JUMPG TT,HNKSZ3
	PUSHJ P,WLHERR
	JRST HNKSZ1

HUNKP:	LSH A,-SEGLOG		;SUBR 1
	SKIPGE A,ST(A)
	 TLNN A,HNK
	  JRST FALSE
	JRST TRUE


MHUNKE:	WTA [MUST BE LIST OR FIXNUM - MAKHUNK!]
MAKHUNK:	SKOTT A,FX		;SUBR 1
	 JRST MHUNK5
	SKIPN TT,(A)
	 JRST FALSE
	MOVE T,TT
	PUSHJ P,ALHUNK		;INITIALIZED TO NIL
MHUNK7:	LSHC T,-1		;LEAVES THE "ODDP" BIT IN SIGN OF TT
	HRLOI T,-1(T)		;SEE HAKMEM FOR THIS EQVI HAK
	EQVI T,(A)
	TLNN T,-1
	 JRST MHUNK6
	SETZM (T)
	AOBJN T,.-1
MHUNK6:	SKIPGE TT
	 HLLZS (T)
	POPJ P,



MHUNK5:	JUMPGE TT,MHUNKE	.SEE LS
	JSP TT,AP2		;STACK LIST ON PDL, -COUNT IN T
HUNK:	MOVN TT,T		;LSUBR
	AOJG T,FALSE		;CREATE HUNK BIG ENOUGH TO
	MOVEI D,QHUNK		; HOLD ALL GIVEN ARGUMENTS,
	CAILE TT,2_HNKLOG
	 SOJA T,WNALOSE
	PUSHJ FXP,ALHNKL	; AND INSTALL THEM
	POPJ P,

;;;	IFN HNKLOG

;;; HUNK ALLOCATION ROUTINES



;;; MAKE A HUNK - (TT) HAS NUMBER OF ITEMS WANTED.
;;;  THEN INSTALL THESE ITEMS FROM PDL BY POPPING OFF
ALHNKL:	PUSH FXP,TT
	PUSHJ P,ALHUNK		;CREATE A FRESH HUNK, AND INSTALL ARGS FROM PDL
	MOVEI B,(A)		;SAVES C - ALSO USED BY FASLOAD
	POP P,A			.SEE LDLHNK 
	JSP T,PDLNMK		;CAN'T PUT PDL QUANTITY INTO A HUNK
	HRROM A,(B)		;LAST ELEMENT GOES IN POSITION 0
	SOSN TT,(FXP)
	 JRST ALHNLY
	LSHC TT,-1		;IN D, SIGN BIT ON ==> EVEN NUMBER OF ELEMENTS
	MOVEI T,(B)
	ADDI T,(TT)
	EXCH D,T		;NOW IN D - LAST WORD INTO WHICH TO POP
	JUMPGE T,ALHNLD
ALHNLA:	POP P,A			;LOOP TO INSTALL ARGS IN HUNK
	JSP T,PDLNMK
	HRLM A,(D)
ALHNLD:	SOJL TT,ALHNLX
	POP P,A
	JSP T,PDLNMK
	HRRM A,(D)
	SOJA D,ALHNLA

ALHNLY: SKIPN VMAKHUNK
	 HRLZS (B)
ALHNLX:	POPI FXP,1
	EXCH A,B
	POPJ FXP,


;;; ALLOCATE A HUNK OF SIZE INDICATED IN (TT)
;;;  AND INITIALIZE TO THE "UNUSED" POINTER (#777777)
ALHUNK:	JUMPLE TT,ALHNKE	;PRESERVES AR1,AR2A - SEE SUBST
	CAILE TT,2_HNKLOG	;MUST PRESERVE T
	 JRST ALHNKE
	SUBI TT,1
	JFFO TT,ALHNKD		;SELECT CONSER FOR CORRECT SIZE HUNK
	 JRST ALHNKF
ALHNKD:	JRST ALHNKF-35.(D)	;DISPATCH TO INDIVIDUAL HUNK CONSERS BELOW
  RADIX 10.
	REPEAT HNKLOG, JRST CONC ALHNK,\<HNKLOG-.RPCNT>
  RADIX 8
ALHNKF:	SKIPE VMAKHUNK		;1 OR 2 THINGS - TEST FOR USE OF CONS
	 JRST ALHNK0
	JRA A,ACONS

;;; HUNK<index> IS THE CONSER FOR HUNKS OF SIZE 2^<index> WORDS.
;;; index no.:  0  1  2  3   4   5   6    7    8    9 
;;; no. words:  1  2  4  8   16  32  64   128  256  512
;;; no. items:  2  4  8  16  32  64  128  256  512  1024

;;; WARNING!  THESE CONSERS MUST PRESERVE T 
.SEE MHUNK7

REPEAT HNKLOG+1,[
   SPECPRO INTZAX
RADIX 10.
CONC GHNK,\.RPCNT,:
	 HRRZS FFH+.RPCNT	;FLUSH SIGN BIT - NEED A HUNK NOW
	 SKIPN A,FFH+.RPCNT	;INITIATE GC DUE TO HUNKS
	  JSP A,AGC4
CONC ALHNK,\.RPCNT,:		;VARIOUS HUNK CONSERS:  HUNK0, HUNK1, ...
	SKIPG A,FFH+.RPCNT
	 JRST CONC GHNK,\.RPCNT
	HRRZ TT,(A)
RADIX 8
   XCTPRO
	MOVEM TT,FFH+.RPCNT
	SETOM (A) 		;MUST FILL IN COMPONENTS WITH THE "UNUSED" POINTER
IFLE .RPCNT-2, REPEAT <1_.RPCNT>-1, SETOM .RPCNT+1(A)
IFG .RPCNT-2,[
	MOVEI D,1(A)
	HRLI D,(A)
	BLT D,<1_.RPCNT>-1(A)
]
  NOPRO
	POPJ P,
]		;END OF REPEAT HNKLOG

]		;END OF IFN HNKLOG

SUBTTL	ATOM, PLIST, SETPLIST, ASSOC AND FRIENDS


ATOM:	LSH A,-SEGLOG		;CAN DO LSH HERE BECAUSE DON'T NEED ARG
	SKIPGE ST(A)		;FALSE ONLY FOR NON-ATOMIC
	 TDZA A,A		; FREE-STORAGE POINTERS
	  MOVE A,VT.ITY		;NORMALLY, T, BUT FOR NIL #T
	POPJ P,


LATOM:				;SKIP IF EQ TEST IS SUFFICIENT FOR EQUALITY
SPATOM:	JUMPE A,1(T)		;SKIP IF NIL (WHICH IS SYMBOL)
SPAT1:	SKOTT A,SY		;LEAVES TYPE BITS IN TT
	 JRST (T)
	JRST 1(T)


PRPLSE:	JUMPE A,PRPNIL
	JRST FALSE
PLIST:	SKOTT A,SY+LS		;SUBR 1 - FETCH PROPERTY LIST
	 JRST PRPLSE
	HRRZ A,(A)
	POPJ P,

PRPNIL:	HRRZ A,NILPROPS		;SPECIAL HACK FOR NIL
	POPJ P,


RPLIZ:	JUMPE A,RPSNIL
	%WTA NASER
SETPLIST:
	SKOTT A,SY+LS	;SUBR 2 - SET PROPERTY LIST
	 JRST RPLIZ
	HRRM B,(A)
	MOVE A,B
	POPJ P,

RPSNIL:	HRRM B,NILPROPS		;SPECIAL HACK FOR NIL
	POPJ P,


STENT:	MOVEI TT,(A)		;GET ST ENTRY FOR A IN TT
	LSH TT,-SEGLOG		;FOR USE WHERE SPACE MORE IMPORTANT THAN TIME
	MOVE TT,ST(TT)
	JRST (T)

VALLCE:	WTA [NON-SYMBOL - VALUE-CELL-LOCATION!]
	JRST VALLC1
VALLOC:	PUSH P,CFIX1
VALLC1:	JUMPE A,VLCNIL
	JSP T,SPATOM
	 JRST VALLCE
	HLRZ TT,(A)
	HRRZ TT,(TT)
	CAIN TT,SUNBOUND
	 SETZ TT,
	POPJ P,

VLCNIL:	MOVEI TT,VNIL
	POPJ P,



SASSQ:	SKIPA T,ASSQ		;[IASSQ]
SASSOC:	MOVEI T,IASSOC
	PUSHJ P,(T)
	CALLF 0,(C)
	POPJ P,

ASSOC:	SKIPA T,SASSOC		;[IASSOC]
ASSQ:	MOVEI T,IASSQ
	PUSHJ P,(T)		;.SEE SSGCP1 - MUST PRESERVE R
FALSE:	MOVEI A,NIL
	POPJ P,


IASSOC:	MOVEI F,TRUTH		;INTERNAL "ASSOC"
	SETZM MEMV 		.SEE DELASSQ
	JSP T,LATOM
	 JRST IASSC0
IASSQ:	SETZB F,MEMV		.SEE DELASSQ
	SKIPN V.RSET
	 JRST IASSQF		;FAST VERSION OF ASSQ WITH NO CHECKING
IASSC0:	SOVE B F A B		;ASSOC LOOP WITH CHECKING
	MOVE TT,B
	JRST IASSC7
IASSC3:	HLRZ T,T
	EXCH T,(P)		;(P) HOLDS SUCCESSIVE TAILS OF LIST
	MOVEM T,MEMV
	MOVE TT,T
IASSC7:	SKOTT TT,LS
	 JRST IASSC4
	MOVS T,@(P)
	SKOTT T,LS
	 JRST IASSC3		;    "NIL" ENTRIES GET BYPASSED HERE
	HLRZ B,(T)
	CAMN B,-1(P)		;-1(P) HOLDS ITEM BEING SOUGHT
	 JRST IASSCX
	SKIPN -2(P)		;-2(P) FLAG = () FOR ASSQ, NON-() FOR ASSOC
	 JRST IASSC3
	MOVE A,-1(P)
	PUSHJ P,EQUAL
	MOVS T,@(P)
	JUMPE A,IASSC3
IASSCX:	POP P,B
	POPI P,3
	JRST IASWIN

IASSC4:	SKIPN (P)
	 JRST IASLOS
	JSP T,MEMQER
	 JRST IASSC3
IASLOS:	POPI P,4
	POPJ P,


IASSQ0:	MOVEM B,MEMV
	HLRZ B,T
IASSQF:	JUMPE B,CPOPJ		;FAST VERSION OF ASSQ WITH NO CHECKING
	MOVS T,(B)		;   MUST PRESERVE AR2A - SEE FASLAP
	HLRZ TT,(T)		;   NOTE - MUST NOT USE OTHER THAN A, B, T, TT
	CAIE A,(TT)		;   BECAUSE OF ASSQ'S FOR READ CHAR MACROS
	 JRST IASSQ0
	TRNN T,-1		;SPURIOUS MATCH OF "()" WITH NULL SLOT
	 JRST IASSQ0		; E.G.  ((A . 1) () (() . 5))
IASWIN:	POP P,T	
	HLRZ A,(B)		;BUT EXIT BY SKIPPING IF WIN, LEAVING FINAL
	JRST 1(T)		;  TAIL IN (B)  -  .SEE SSGCP1
	




;(DEFUN DISPLACE (X Y)
;       (AND (ATOM X) (ERROR '|NOT A LIST - DISPLACE| X))
;       (COND ((ATOM Y)
;	       (RPLACA X 'PROGN)
;	       (RPLACD X (NCONS Y)))
;	     ('T (RPLACA X (CAR Y))
;		 (RPLACD X (CDR Y)))))
DISPL0:	WTA [NOT A LIST - DISPLACE!]
DISPLACE:
	MOVEI TT,(A)		;INSURE FIRST ARG IS A LIST
	LSH TT,-SEGLOG
	SKIPL ST(TT)		;IS IT?
	 JRST DISPL0
	MOVEI TT,(B)		;CHECK WHETHER SECOND ARG IS LIST OR NOT
	LSH TT,-SEGLOG
	SKIPL ST(TT)		;LIST?
	 JRST DISPL1		;NOPE, SPECIAL TREATMENT
DISPL2:	HLRZ AR1,(B)		;CAR Y
	HRLM AR1,(A)		;RPLACA X
	HRRZ AR1,(B)		;CDR Y
	HRRM AR1,(A)		;RPLACD X
	POPJ P,			;RETURN X
DISPL1:	MOVEI C,QPROGN
	HRLM C,(A)		;(RPLACA <1ST-ARG> 'PROGN)
	PUSH P,A		;NOW (NCONS <2ND ARG>)
	MOVEI A,(B)
	PUSHJ P,$NCONS
	HRRM A,@(P)		;(RPLACD <1ST-ARG> (NCONS <2ND-ARG>))
	POP P,A			;RETURN FIRST ARG
	POPJ P,

;; IN FOLLOWING TW FUNS, CAN PUT A "PAGE NUMBER" INTO ACC A WITH 'IMPUNITY'

PUREP:	LSH A,-SEGLOG		   ;find the entry in the segment table
	MOVE TT,ST(A)		   ;(we want the left half too)
	TLNE TT,ST.PUR
	  JRST TRUE
	JRST FALSE

WRITEABLEP:
	LSH A,-<SEGLOG+SGS%PG-1>
IFN ITS,[
	.CALL [SETZ ? SIXBIT /CORTYP/ ? A ? %CLOUT,,A ((SETZ)) ]
	  CAIA
	JUMPL A,TRUE
]	;END OF IFN ITS
IFN D20,[
	HRLI A,.FHSLF
	RPACS
	TLNE B,(PA%WT)
	 JRST TRUE
]	;END OF IFN D20
IFN D10,[
IFN SAIL,[
	SETZ TT,
	CALLI TT,400021		;SEGNUM ON SAIL (TEST FOR HISEG)
	JUMPE TT,TRUE
]	;END OF IFN SAIL
	CAIGE A,HILOC
	 JRST TRUE
]	;END OF IFN D10
	JRST FALSE



SUBTTL	GET, FBOUNDP, GETL, PUTPROP, REMPROP FUNCTIONS

$GET:	JSP TT,GETCHK
	 JRST FALSE
	 JFCL 		;LET ORDINARY HUNKS GO THRU
GET1:	HRRZ TT,(A)	;MUST PRESERVE B, C, AR1, T, D
			;(SEE EVAL AT EV3, MKNAM3, SETF1B, .REARRAY, AND ARRY1)
	HLRZ A,(TT)	;ALSO PRESERVE R, SEE UUOH1 AND SEE PRNN2
	CAIN A,(B)	;ALSO AR2A AND F, SEE FASLOAD
	 JUMPN TT,GET2
	HRRZ A,(TT)	;USES ONLY A,B,TT
	JUMPN A,GET1
	POPJ P,

GET2:	HRRZ TT,(TT)
	HLRZ A,(TT)
	POPJ P,


SARGET:	MOVEI TT,(A)
	LSH TT,-SEGLOG
	MOVE TT,ST(TT)
	TLNE TT,SA
	POPJ P,
ARGET:	JSP T,SPATOM	;GET ARRAY PROPERTY FROM ATOM
	JSP T,PNGE1
ARGET1:	MOVEI B,QARRAY
	JRST GET1

PNGET:	JSP T,SPATOM	;INTERNAL SUBROUTINE -GET PNAME PROP FROM ATOM
PNGT1:	JSP T,PNGE
PNGT0:	SKIPN A		;SAVES B
	 SKIPA TT,[$$$NIL]
	  HLRZ TT,(A)	;MUST DO IT INTO TT SO AS TO HAVE
	HRRZ A,1(TT)	; CONTINUOUS GC PROTECTION
	POPJ P,
	.SEE CRSR40


GETCHK:	ROT A,-SEGLOG		;CHECK FIRST ARG FOR GET, GETL, AND PUTPROP
	HLL TT,ST(A)		;SKIP 2 IF OK, 1 IF NON-USER HUNK,  
	ROT A,SEGLOG		; ELSE NO SKIP
	TLNE TT,SY		;SYMBOL IS SUPER-WIN
	 JRST 2(TT)
	TLNN TT,LS	
	 JRST GTCK1 
	TLNN TT,HNK	
	 JRST 2(TT)		;REGULAR LIST IS FINE TOO
	PUSH FXP,T
	PUSHJ P,USRHNP
	JUMPE T,[ POP FXP,T
		  JRST 1(TT) ]	;SKIP 1 FOR NON-USER HUNK
	POP FXP,T
GTCK1:	JUMPN A,(TT)		;NO SKIP -- RANDOM FROB
	MOVEI A,NILPROPS	;SIGH, SPECIAL CASE FOR () 
	JRST 2(TT)




FBOUNDP: MOVEI B,FBDPL

GETL:	SKOTT B,LS
	 JUMPN B,GETLE
GETLA:	JSP TT,GETCHK
	 JRST FALSE
	 JFCL 
GETL1:	JUMPE B,FALSE		;FLUSH DEGENERATE CASE OF NO PROPS
	JRST GETL1A
GETL0:	HRRZ A,(A)		;USES A,B,C,T,TT
	JUMPE A,CPOPJ
GETL1A:	HRRZ A,(A)		;GET NEXT OFF PROPERTY LIST
	JUMPE A,CPOPJ
	HLRZ T,(A)
	MOVE C,B
GETL4:	HLRZ TT,(C)		;MEMQ IT DOWN LIST OF PROPS
	CAIN T,(TT)
	 POPJ P,
	HRRZ C,(C)
	JUMPN C,GETL4
	JRST GETL0

;;; ARGUMENTS ARE A SYMBOL, A VALUE, AND AN INDICATOR.
;;; THE INDICATOR MUST NOT BE A PDL QUANTITY (RECALL THAT THE
;;; EQNESS OF SUCH QUANTITIES IS UNDEFINED IN THE LANGUAGE ANYWAY).
;;; THE VALUE IS PDLNMK'D IF NECESSARY.  THE SYMBOL MAY BE A LIST
;;; (KNOWN AS A "DISEMBODIED PROPERTY LIST"; THE CDR IS THE PLIST).
;;; IF THE PROPERTY ALREADY EXISTS, THE NEW VALUE IS INSTALLED THERE.
;;; OTHERWISE A NEW PROPERTY IS INSTALLED AT THE FRONT OF THE
;;; PROPERTY LIST.  IF THE PROPERTY ALREADY EXISTS IN A PORTION
;;; OF THE PROPERTY LIST THAT IS PURE, ENOUGH OF THE PURE PART
;;; IS COPIED AS IMPURE LIST STRUCTURE TO PERMIT THE PUTPROP.
;;; IF THE VALUE OF *PURE IS NON-NIL, THEN THE VALUE IS PURCOPY'D
;;; AND THE NEW PROPERTY LIST CELLS, IF ANY, ARE PURE-CONSED.

PUTPROP:
	JSP TT,GETCHK		;NORMALIZE FIRST ARG
	 JRST PROPER		;DONT TRY "PUT"TING ON RANDOM FROBS
	 JFCL			; LET NON-USER HUNKS GO THRU
	CAML B,NPDLL		;MAKE A QUICK TEST ON THE SECOND ARGUMENT
	 CAML B,NPDLH		;SHIP-OF-THE-DESERT TEST (TWO CAML'S)
	  JRST CSET0Q
	EXCH B,A		;LOSE - MUST PDLNMK THE VALUE
	JSP T,PDLNMK
	EXCH B,A
CSET0Q:	MOVEI T,(A)
CSET0:	HRRZ T,(T)		;MUST SAVE AR1,R,F FOR FASLOAD - SEE LDENT
	JUMPE T,CSET2		;SEARCH FOR AN EXISTING PROPERTY
	HLRZ TT,(T)
	HRRZ T,(T)
	CAIE TT,(C)
	 JRST CSET0
	JSP D,CSET8 		;SKIPS, UNLESS HAD TO PURCOPY THE PROPERTY
	 JRST CSET5
	SKOTTN T,PUR
	 JRST CSET4
CSET0A:			;IF PROPERTY EXISTS ALREADY (IN IMPURE CELL)
PURTRAP CSET4,T,HRLM B,(T)
BRETJ:
SPROG2:	MOVEI A,(B)		;RETURN VALUE
	POPJ P,

;; DOESN'T HAVE SUCH A PROPERTY, SO CONS ONE UP
CSET2:	PUSH P,A
	JSP D,CSET8 		;SKIPS, UNLESS HAD TO PURCOPY THE THING
	 JRST CSETP1		; SO, IF IT MUST BE A 'PURE' PROPERTY ...
CSET2A:	HRRZ A,(A)		;PLAIN VANILLA CONSES
	PUSHJ P,XCONS
	HRRZ B,C
	JSP T,%PDLXC		;IN CASE SOMEONE TRIES TO USE A PDLNUM
	POP P,C			;ORIGINAL ATOM WAS SAVED ON P
	HRRM A,(C)		;SETPLIST TO NEW THING
$CADR:	HRRZ A,(A)		;RETURN VALUE (I.E. GET IT BACK)
$CAR:	HLRZ A,(A)
C$CAR:	POPJ P,$CAR

;; A HAS BEEN PUSHED ONTO P WHEN WE GET HERE
CSETP1:	MOVE A,B
	SKIPA T,(P)		;GET PLIST OF OBJECT
CSETP2:	HRRZ T,(B)		;LOOP UNTIL PURE PART FOUND (OR END OF PLIST)
	HRRZ B,(T)
	JUMPE B,CSETP3
	SKOTT B,PUR
	 JRST CSETP2
CSETP3:	PUSHJ P,PCONS		;pure-cons the words of the PLIST
	MOVEI B,(A)
	MOVEI A,(C)
	PUSHJ P,PCONS
	HRRM A,(T)
	POPI P,1
	JRST $CADR


CSET8:	SKIPN V.PURE		;PURCOPY THE PROPERTY IF IT IS OF
	 JRST 1(D)		; THE KIND FOUND ON 'PUTPROP'
	SKIPA TT,VPUTPROP	;SKIP IF NO PURCOPYING ACTUALLY HAPPENS
CSET8A:	HLRZS TT
	JUMPE TT,1(D)		;FAST, OPEN-CODED MEMQ LOOP
	MOVS TT,(TT)
	CAIE C,(TT)
	 JRST CSET8A
	PUSH FXP,D		;RET ADDR!
	PUSH FXP,T
	PUSHJ FXP,SAV2		;SAVES B,A ON TOP OF 'P'
	MOVE A,B	
	PUSHJ P,PURCOPY		;PURCOPY THE PROP VALUE
	MOVEM A,-1(P)
	SKOTT C,SY		;IS THE FLAG A SYMBOL?
	 JRST CSET8B
	HLRZ T,(C)		;POINTER TO THE SY2 BLOCK
	MOVE T,SYMVC(T)		;GET THE FLAG BITS
	TLNE T,SY.PUR		;IS IT ALREADY PURE?
	 JRST CSET8B
	MOVE A,C
	PUSHJ P,PURCOPY		;NO, PURCOPY IT
	MOVE C,A
CSET8B:	POP FXP,T
	JRST RST2



CSET5:	SKOTTN T,PUR	;SO, PROPERTY IS TO BE PURIFIED!
	 JRST CSET0A	;BUT EXISTING PROP IS PURE, SO TRY TO CLOBBER
	SOVE A B	;BUT IF EXISTING PROP WAS IMPURE, THEN REMPROP
	MOVE B,C
	PUSHJ P,REMPROP	; IT AND TRY THE "FRESH PROPERTY" ROUTE
	POP P,B
	JRST CSETP1

;; COME HERE BY PURTRAP WHEN TRYING TO CLOBBER INTO AN UNWRITEABLE PAGE.
CSET4:	PUSHJ FXP,SAV2
	MOVEI T,(A)		;FOOL PROPERTY IS IN A PURE PAGE
CSET4A:	HRRZ TT,(T)		;COPY ENOUGH OF THE PROPERTY LIST
	PUSHJ P,CSET4C		; TO PERMIT THE PUTPROP
	HLRZ A,(TT)
	CAIE A,(C)
	 JRST CSET4A
	PUSHJ FXP,RST2
	JRST CSET0A



REMPROP:		;SUBR 2 - REMOVE PROPERTY FROM ATOMIC SYMBOL
	SKOTT A,LS+SY
	 JRST REMP7	;MUST SAVE AR1,R,F FOR FASLOAD - SEE LDENT
REMP0:	SKIPA D,A	;SAVE C, AR2A - SEE DEFPROP AND DEFUN
REMP1:	 HRRZ D,(T)
	HRRZ T,(D)
	JUMPE T,FALSE
	MOVS TT,(T)
	CAIE B,(TT)
	 JRST REMP1
	HLRZ T,TT
REMP20:	HRRZ TT,(T)		;A IS GC-PROTECTING THE ATOM
PURTRAP REMP3,D,	HRRM TT,(D)
	MOVEI A,(T)
	POPJ P,

REMP7:	JUMPN A,RMPER0
	MOVEI A,NILPROPS
	JRST REMP0


CSET4C:	PUSHJ P,.+1	;HAIRY WAY TO DO A DOUBLE COPY!
	HRRZ A,(T)
	MOVE B,(A)
	PUSHJ P,CONS1
	HRRM A,(T)
	MOVEI T,(A)
	POPJ P,


REMP3:	PUSH P,A		;COME HERE ON PURE PAGE TRAP
	PUSH P,B		;A ON PDL GC PROTECTS ATOM
	MOVEI T,(A)
REMP3A:	PUSHJ P,CSET4C		;COPY ENOUGH OF PROPERTY LIST
	HRRZ TT,(T)		; TO DO REMPROP
	HLRZ A,(TT)
	CAME A,(P)
	 JRST REMP3A
	HRRZ A,(TT)
	HRRZ TT,(A)
	HRRM TT,(T)
	JRST POP2J


SUBTTL	NOT, NULL, BOUNDP, PAIRP


NOTNOT:	JUMPE A,CPOPJ		;REPLACES A NON-NIL VALUE BY T
	JRST TRUE

NOT:
$NULL:	JUMPN A,FALSE
TRUE:	MOVE A,VT.ITY
CNOT:	POPJ P,NOT



BOUNDP:	JUMPE A,TRUE		;SUBR 1
	JSP T,SPATOM		;TRUE IFF THE SYMBOL ARGUMENT IS BOUND
	 JSP T,PNGE1		;ERROR FOR NON-SYMBOLS
	HLRZ T,(A)		;GET VALUE CELL
	HRRZ A,(T)		;DO IT INTO T TO PROTECT FROM GC
	HRRZ T,(A)
	CAIN T,QUNBOUND
	 TDZA A,A
	  MOVE A,VT.ITY
	POPJ P,

PAIRP:	PUSHJ P,TYPEP
	CAIE A,QLIST
	 TDZA A,A
	MOVE A,VT.ITY
	POPJ P,



;;;; LAST, RUNTIME

LAST:	PUSHJ P,LLASTCK		;SUBR 1 - GET LAST CONS OF A LIST
	 JRST LAST4
LAST5:	MOVE A,D
	POPJ P,
	
LAST4:	CAIE F,-1
	 JRST LAST5		;  (A B C ...  .  Z)  CASE
	SKOTTN A,LS		;SO WE TOOK NO CDRS!
	 JRST LAST5		;  (A . Z)  CASE
	HRRZ TT,C2		;FOO! ALLOW RANDOM PTS TO PDL, FOR SAKE
	CAILE A,(TT)		;  OF THAT KLUDGEY CODE OUTPUT BY THE
	CAILE A,(P)		;  COMPLR FOR MAPCAN ETC.
	JRST LASTER 
	SKIPN TT,(A)
	POPJ P,
	MOVEI A,(TT)
	JRST LAST

LLASTCK:	MOVEI F,-1	;"LONG" LAST CHECK
				; RETURNS <262143.-<NO. OF CDRS TAKEN>> IN F
; MUST PRESERVE T,R.  SEE APPEND, REVERSE, NTHCDR
LASTCK:		SKIPN D,A	;SKIP RETURN ON NORMAL-FORM LIST
	JRST POPJ1		;  LEAVES PTR TO LAST NODE IN D, 
	SKOTT D,LS		;() IS OK, AND IS ITS OWN "LASTNODE"
	 POPJ P,		;  BUT OTHER ATOMS LOSE
	JUMPLE F,POPJ1		; LIMITED TO (F) CDRS
LAST1:	HRRZ TT,(D)
	SKOTT TT,LS
	 JRST LAST2
	HRRZ D,(D)
	SOJG F,LAST1
	JRST POPJ1

LAST2:	HRRZ TT,(D)
	JUMPE TT,POPJ1
	POPJ P,			;ENDED WITH NON-NULL ATOM


;;; RETURN RUNTIME AS A FIXNUM IN MICROSECOND
;;; UNITS (NOT NECESSARILY THAT ACCURATE THOUGH).

$RUNTIME:
	PUSH P,CFIX1	;SUBR 0 NCALLABLE
IT$	.SUSET [.RRUNT,,TT]	;RUNTIME IN 4-MICROSECOND UNITS
10$	SETZ TT,
10$	RUNTIM TT,		;RUNTIME IN MILLISECONDS
IFN D20,[
	LOCKI			;MUST LOCKI OVER ALL JSYS'S
	MOVEI 1,.FHSLF		;GET RUNTIME FOR SELF
	RUNTM
	MOVE TT,1		;RUNTIME IN MILLISECONDS
	SETZB 1,3		;1 AND 3 HAVE DANGEROUS CRUD
	UNLOCKI
]		;END OF IFN D20
RNTM1:			;CONVERT NUMBER FROM INTERNAL UNITS TO USECS
IT$	LSH TT,2
IT%	IMULI TT,1000.
	POPJ P,			;ANSWER IN MICROSECONDS

SUBTTL	TIME FUNCTION

;;; RETURN A TIME STANDARD AS A FLONUM IN SECONDS.
;;; WE ENDEAVOR TO MAKE THIS INCREASE MONOTONICALLY AND TO MEASURE
;;; THE PASSAGE OF REAL TIME.  IN PRACTICE, WE MAY NOT MEASURE
;;; REAL TIME WHILE THE TIME-SHARING SYSTEM IS TEMPORARILY STOPPED,
;;; AND WE PERMIT A GLITCH (RESET TO 0) AT MIDNIGHT OF EACH DECEMBER 31.

;; DECIDE ON THE "TIMER CONSTANT" INTERVAL -- 1/30 SEC FOR ITS, 1/1000 FOR D20

IFN ITS,[
DEFINE TMCNST 
30.0!TERMIN
DEFINE TMXCNST 
30.!TERMIN
]

IFN D20,[
DEFINE TMCNST 
1000.0!TERMIN
DEFINE TMXCNST 
1000.!TERMIN
]

$TIME:	PUSH P,CFLOAT1		;SUBR 0 NCALLABLE
IFN ITS\D20,[
IT$	.RDTIME TT,		;GET AMOUNT OF TIME SYSTEM HAS BEEN UP
IFN D20,[
	LOCKI			;MUST LOCKI AROUND THE JSYS
	TIME			;GET TIME SINCE SYSTEM LAST RESTARTED IN MSECS
	MOVE TT,1
	SETZ 1,			;ZERO CRUD
	UNLOCKI
]
;	CAMGE TT,[30.*3600.*24.*28.]	;FOUR WEEKS OF 1/30 SEC TICS
;	 JRST .+3
;	SUB TT,[30.*3600.*24.*28.]
;	 JRST .-3
	JSP T,IFLOAT
	FDVRI TT,(TMCNST)
]		;END OF IFN ITS\D20
IFN D10,[
IFE SAIL,[
	MOVE T,[%CNDTM]		;INTERNAL DATE/TIME STANDARD,
	GETTAB T,		; AS DATE,,FRACTION OF DAY
	 JRST TIME3		; 1-ORIGINED ON NOVEMBER 18, 1858
	ADD T,[2*365.+1-43.,,]	;ALTER TO 0-ORIGIN ON JANUARY 1,1856
	IDIV T,[365.*4+1,,]	;GET THIS MOD A FOUR-YEAR INTERVAL
	JSP T,IFLOAT
	FMPR T,[.OP <FSC -22>,86400.0,0]	;CONVERT TO SECONDS
	POPJ P,

TIME3:	MSTIME TT,		;THIS PRODUCES GLITCHES AT MIDNIGHT
	JSP T,IFLOAT
	FDVRI TT,(1000.0)
]		;END OF IFE SAIL
IFN SAIL,[
	ACCTIM TT,
	HLRZ D,TT
	IDIVI D,12.*31.		;YEAR-1964 IN D
	IDIVI R,31.		;MONTH-1 IN R, DAY-1 IN F
	ADD F,TIME8(R)		;ADD IN NUMBER OF DAYS PRECEDING CURRENT MONTH
	TLNN D,3		;SKIP IF NOT LEAP YEAR
	 CAIL R,2		;SKIP IF JANUARY OR FEBRUARY
	  SUBI F,1		;ADJUST FOR CRETINOUS LEAP YEARS
	IMULI F,24.*3600.	;CONVERT TO SECONDS FROM LAST MIDNIGHT TO MIDNIGHT LAST DEC 31
	TLZ TT,-1
	ADD TT,F		;ADD IN SECONDS SINCE MIDNIGHT LAST
	JSP T,IFLOAT
]		;END OF IFN SAIL
]		;END OF IFN D10
	POPJ P,

IFN SAIL,[
TIME8:
ZZZ==1				;WILL SUBTRACT THIS 1 BACK EXCEPT FOR AFTER FEB 29'S
IRP X,,[31.,28.,31.,30.,31.,30.,31.,31.,30.,31.,30.,31.]
	ZZZ
ZZZ==ZZZ+X
TERMIN
IFN ZZZ-366., WARN [TABLE OF CUMULATIVE DAYS IN MONTHS LOSES]
EXPUNGE ZZZ
]		;END OF IFN SAIL

SUBTTL	EQUAL FUNCTION

EQUAL:	CAIN A,(B)		;EQ THINGS ARE EQUAL
	 JRST TRUE		;  .SEE ASSOC -  MUST PRESERVE F
	MOVEM P,EQLP
	PUSHJ P,EQUAL1		;EQUAL1 ACTUALLY RETURNS ONLY IF EQUAL
	JRST TRUE

EQUAL0:	CAIN A,(B)		;EQ THINGS ARE EQUAL
	 POPJ P,
EQUAL1:	MOVEI T,(A)
	MOVEI TT,(B)
	ROTC T,-SEGLOG		;GET TYPES OF ARGS
	HRRZ T,ST(T)
	MOVE TT,ST(TT)
	CAIN T,(TT)		;MUST HAVE SAME TYPE TO BE EQUAL
    2DIF JRST @(T),EQLTBL,QLIST		.SEE STDISP
IFE HNKLOG,	JRST EQLOSE
IFN HNKLOG,[
	SKIPE VHUNKP
	 JRST EQL1A
	TLNN TT,LS		;IF VHUNKP CONTAINS NIL, THEN WANT TO
	  JRST EQLOSE		; TREAT ALL HUNKS AS IF THEY WERE LIST CELLS
	SKOTT A,LS
	 JRST EQLOSE
	JRST EQLLST
EQL1A:	SKIPN USRHNK		;IS THE USRHUNK/SENDI FEATURE ENABLED?
	  JRST EQLOSE
	TLNE TT,HNK		;IF VHUNKP CONTAINS T, THEN WANT TO SEND
	 JRST EQL1B		; THE "EQUAL" MESSAGE IF EITHER ARG IS HUNK
	SKOTT A,HNK
	 JRST EQLOSE
	SKIPA
EQL1B:	EXCH A,B		;MUST ALWAYS SEND TO FIRST ARG
	JRST EQLH4A

]		;END OF IFN HNKLOG
EQLLST:	PUSH P,(A)
	PUSH P,(B)
	HLRZ A,(A)
	HLRZ B,(B)
	PUSHJ P,EQUAL0		;COMPARE CARS
	HRRZ A,-1(P)
	HRRZ B,0(P)
	SUB P,R70+2
	JRST EQUAL0		;COMPARE CDRS

EQLTBL:	EQLLST		;LIST
	EQLNUM		;FIXNUM
	EQLNUM		;FLONUM
DB$	EQLNM2		;DOUBLE
CX$	EQLNM2		;COMPLEX
DX$	EQLNM4		;DUPLEX
BG$	EQLBIG		;BIGNUM
	EQLOSE		;PNAME ATOMS MUST BE EQ TO BE EQUAL
HN$ REPEAT HNKLOG+1, EQLHNK	;HUNKS REQUIRE RECURSION LIKE LISTS
	EQLOSE		;RANDOMS AND NIL MUST BE EQ TO BE EQUAL
	EQLOSE		;ARRAY POINTERS MUST BE EQ TO BE EQUAL
IFN .-EQLTBL-NTYPES, WARN [WRONG LENGTH TABLE]

IFN DXFLAG,[
EQLNM4:
KA	MOVE T,2(A)
KA	MOVE TT,3(A)
KIKL	DMOVE T,2(A)
	CAMN T,2(B)
	 CAME TT,3(B)
	  JRST EQLOSE
]		;END OF IFN DXFLAG
IFN DBFLAG+CXFLAG,[
EQLNM2:	MOVE T,1(A)
	 CAME T,1(B)
	  JRST EQLOSE
]		;END OF IFN DBFLAG+CXFLAG
EQLNUM:	MOVE T,(A)
	CAMN T,(B)		;COMPARE VALUES OF NUMBERS
	 POPJ P,
EQLOSE:	MOVE P,EQLP		;THE ULTIMATE FALSITY - ESCAPE BACK
	JRST FALSE		; TO TOP LEVEL OF ENTRY TO EQUAL WITH FALSE

IFN BIGNUM,[
EQLBIG:	HLRZ T,(A)
	HLRZ TT,(B)
	CAIE T,(TT)		;EQUAL BIGNUMS HAVE EQ SIGNS
	 JRST EQLOSE		; AND CDRS ARE EQUAL LISTS OF FIXNUMS
	HRRZ A,(A)		;CHECK ONLY EQUAL CDRS
	HRRZ B,(B)
	JRST EQUAL0
]		;END OF IFN BIGNUM

IFN HNKLOG,[
EQLHNK:	SKIPN VHUNKP
	 JRST EQLLST
	SKIPE USRHNK
	 JRST EQLHN4
EQLHN3:	PUSH P,A
	PUSH P,B
	MOVNI T,1
   2DIF [LSH T,(TT)]0,QHUNK0	;REALLY SHOULD BE ASH, BUT LSH IS FASTER ON KL10
	HRLI B,(T)
	PUSH P,A
	PUSH P,B
EQLHN1:	HLRZ A,@-1(P)
	HRRZ B,(P)
	HLRZ B,(B)
	PUSHJ P,EQUAL0
	HRRZ A,@-1(P)
	HRRZ B,(P)
	HRRZ B,(B)
	PUSHJ P,EQUAL0
	MOVE T,(P)
	AOBJP T,EQLHN2
	MOVEM T,(P)
	AOS -1(P)
	JRST EQLHN1

EQLHN2:	SUB P,R70+4
	POPJ P,

EQLHN4:	SKIPN USRHNK		   ;Is the USRHUNK/SENDI feature enabled?
	  JRST EQLHN3		   ;  no, check the parts
EQLH4A:	PUSH FXP,EQLP		   ;Gotta ask the user predicate
	PUSH FXP,TT
	PUSHJ FXP,SAV5
	PUSHJ P,USRHNP		   ;Check for user-hunkness
	JUMPE T,EQLHN5		   ;If not, go hack it normally
	PUSHJ P,[PUSH P,A
		 PUSH P,[QEQUAL]
		 PUSH P,B
		 MOVNI T,3
		 XCT SENDI		   ;Send the object a message
		 ]
EQLH4X:	PUSHJ FXP,RST5M1
	POP FXP,TT
	POP FXP,EQLP
	JUMPE A,EQLOSE
	JRST POPBJ

EQLHN5:	PUSHJ FXP,RST5
	POP FXP,TT
	POP FXP,EQLP
	JRST EQLHN3

;; Send a message to a hunk with object in A and message in B
USRSAB:	PUSHJ FXP,SAV5M2	   ;Save AC's
	PUSH P,[RST5M2]
USRAB:	PUSH P,A		   ;Don't save AC's if called here
	PUSH P,B
	XCT SENDI
	
;; Check A for being a HUNK and a USRHUNK, return answer in T

USRHPP:	MOVEI T,(A)
	LSH T,-SEGLOG
	MOVE T,ST(T)	;Get segment table entry
	TLNE T,HNK	;Is it a hunk at all?
	  JRST USRHNP	;  Yes, call user's hook.
TFALSE:	SETZ T,		;Nope....
	POPJ P,

;; If we are using the USRHNK, assuming we already know it's a hunk.

USRHNP:	SKIPE USRHNK		   ;Must have both a USRHUNK and a SENDI
	  SKIPN SENDI		   ;  in order to make use of either
	    JRST TFALSE
	PUSHJ FXP,SAV5
	PUSHJ P,SAVX5
	XCT USRHNK		   ;Check it out
	PUSHJ P,RSTX5
	MOVE T,A		   ;Return value in T, not A
	PUSHJ FXP,RST5
	POPJ P,

]		;END OF IFN HNKLOG

SUBTTL	NCONC, *NCONC, APPEND, *APPEND, REVERSE, NREVERSE, NRECONC

NCONC:	TDZA R,R		;LSUBR - DESTRUCTIVELY CATENATE LISTS
APPEND:	MOVEI R,.APPEND-.NCONC	;LSUBR - CATENATE BY COPYING
	JUMPE T,FALSE
	POP P,B
APP2:	AOJE T,BRETJ
	POP P,A
	JUMPE A,APP2
	SKIPE V.RSET
	 PUSHJ P,APRVCK		
APP3:	PUSHJ P,.NCONC+1(R)	;FIRST INST OF .NCONC IS "JUMPE A,BRETJ"
	MOVE B,A
	JRST APP2


.NCONC:	JUMPE A,BRETJ		.SEE APP3
.NCNC1:	MOVEI TT,(A)		;SUBR 2 (*NCONC)
.NCNC2:	HRRZ D,(TT)
	JUMPE D,.NCNC3
	HRRZ TT,(D)
	JUMPN TT,.NCNC2
	HRRM B,(D)
	POPJ P,

.NCNC3:	HRRM B,(TT)
	POPJ P,


.APPEND:	JUMPE A,BRETJ	;SUBR 2 (*APPEND)
	MOVEI C,AR1		;FIRST INST MUST BE JUMPE A,BRETJ
	MOVE AR2A,A		;MUST SAVE T,D - SEE MAKOBLIST
APP1:	HLRZ A,(AR2A)
	PUSHJ P,CONS
	HRRZ B,(A)
	HRRM A,(C)
	MOVE C,A
	HRRZ AR2A,(AR2A)
	JUMPN AR2A,APP1
AR1RETJ:
SUBS4:	MOVEI A,(AR1)
	POPJ P,


REVERSE:	SKIPE V.RSET	;SUBR 1 - USES A,B,C,T,F
	 PUSHJ P,APRVCK
	MOVEI C,(A)
	MOVEI A,NIL		;REVERSES A LIST BY CONSING UP A COPY
REV1:	JUMPE C,CPOPJ		; OF THE TOP LEVEL IN REVERSE ORDER
	HLRZ B,(C)
	PUSHJ P,XCONS
	HRRZ C,(C)
	JRST REV1

APRVCK:	PUSHJ P,SAVX3		;APPEND/REVERSE ARGUMENT CHECKING
REV4:	PUSHJ P,LLASTCK		;MUST SAVE TT,D,R FOR MANY PLACES WHICH
	 JRST REVER		; CALL REVERSE/NREVERSE
	JRST RSTX3

NREVERSE:	MOVEI B,NIL	;SUBR 1 - REVERSE A LIST USING RPLACD'S
NRECONC:	JUMPE A,BRETJ	;SUBR 2 - (NRECONC X Y)=(NCONC (NREVERSE X) Y)
	 SKIPE V.RSET		;   - USES A,B,C,T,F
	  PUSHJ P,APRVCK
NREV1:	HRRZ C,(A)		;ONLY 3 INSTRUCTIONS PER CELL! ZOOM!
	HRRM B,(A)
	JUMPE C,CPOPJ
	HRRZ B,(C)
	HRRM A,(C)
	JUMPE B,CRETJ
	HRRZ A,(B)
	HRRM C,(B)
	JUMPN A,NREV1
	JRST BRETJ


SUBTTL	GENSYM FUNCTION

GENSYM:	JUMPN T,GENSY1
GENSY0:	MOVE TT,[010700,,GNUM]	;STANDARD GENSYMER
	MOVEI B,"0		;WILL INCREMENT NUMERICAL PART
GENSY2:	LDB T,TT		; AND GIVE OUT GENSYMED ATOM
	AOS T
	DPB T,TT
	CAIG T,"9
	JRST GENSY3
	DPB B,TT
	ADD TT,[070000,,0]
	CAMGE TT,[350000,,]
	JRST GENSY2
GENSY3:	PUSH FXP,PNBUF
	MOVE TT,GNUM
	MOVEM TT,PNBUF
	MOVEI C,PNBUF
	PUSHJ P,PNGNK2
	POP FXP,PNBUF
	POPJ P,

GENSY1:	MOVEI D,QGENSYM
	AOJN T,S1WNALOSE
GENSY7:	POP P,A
	SKOTT A,FX
	JRST GENSY5
	MOVE TT,(A)
	JUMPL TT,GENSY8
	MOVE T,[010700,,GNUM]
GENSY6:	IDIVI TT,10.		;INSTALL 4 DECIMAL DIGITS
	ADDI D,"0		; IN GENSYM COUNTER
	DPB D,T
	ADD T,[070000,,0]
	CAMGE T,[350000,,]
	JRST GENSY6
	JRST GENSY3

GENSY5:	TLNN TT,SY
	JUMPN A,GENSY8
	JSP T,CHNV1D
	DPB TT,[350700,,GNUM]
	JRST GENSY0

SUBTTL	MEMBER, MEMQ, SUBST

MEMBER:				;USES A,B,AR1,AR2A,T,TT
SMEMBER::	MOVEI AR1,(A)		; FOR BENEFIT OF DELETE 
	MOVEI AR2A,(B)
	JSP T,LATOM
	 JRST MEMBR
SMEMQ:	SETZM MEMV		;USES A,B,T,MUST PRESERVE AR1,AR2A;SEE GTSPC3
	PUSH P,B
MEMQ2:	SKOTT B,LS
	 JRST MEMQ4
	HLRZ T,(B)
	CAMN A,T
	 JRST MEMQ3
	HRRM B,MEMV		.SEE DELQ ;;used as a "previous-cell" ptr
	HRRZ B,(B)
	JRST MEMQ2
MEMQ3:	POPI P,1
	JRST SPROG2
MEMQ4:	JUMPE B,MEMQ3
	JSP T,MEMQER
	JRST MEMQ2

MEMBR:	SETZM MEMV
	PUSH P,B
MEMB2:	SKOTT AR2A,LS
	 JRST MEMB4
	MOVE A,AR1
	HLRZ B,(AR2A)
	PUSHJ P,EQUAL
	JUMPN A,MEMB3
	HRRM AR2A,MEMV
	HRRZ AR2A,(AR2A)
	JRST MEMB2
MEMB3:	POPI P,1
AR2ARETJ:
	MOVEI A,(AR2A)
	POPJ P,
MEMB4:	JUMPE AR2A,MEMB3
	JSP T,MEMQER
	MOVE AR2A,B
	JRST MEMB2


MEMQ:	SKIPE V.RSET
	 JRST SMEMQ
MEMQ1:	JUMPE B,FALSE     .SEE THRCAB	;REQUIRES MEMQ1 PRESERVES TT
	HLRZ T,(B)
	CAIN T,(A)
	 JRST BRETJ
	HRRZ B,(B)
	JRST MEMQ1


;;; SUBSTITUTE A FOR EQUAL OCCURRENCES OF B IN C.

SUBST:	JSP T,PDLNMK		;SUBR 3
	EXCH A,C
	JSP T,PDLNMK
	EXCH A,C
	SKIPA AR1,A
SUBS0A:	 SKIPA A,AR1
	  SKIPA AR2A,B
	   MOVE B,AR2A
	PUSH P,C
	MOVE A,C
	PUSHJ P,EQUAL
	POP P,C
	JUMPN A,AR1RETJ
SUBS1:	SKOTT C,LS		;FOO, THIS INCLUDES HUNKS!
	 JRST SPROG3
	PUSH P,C
IFN HNKLOG,[
	TLNE TT,HNK
	 JRST SUBSTH
]; END of IFN HNKLOG,
	HLRZ C,(C)		;A "PAIR" CELL
	PUSHJ P,SUBS0A
	EXCH A,(P)
	HRRZ C,(A)
	PUSHJ P,SUBS0A
	POP P,B
	JRST XCONS

IFN HNKLOG,[

SUBSTH:	MOVEI A,(C)
	PUSH FXP,TT
	PUSHJ P,USRHNP		   ;Check for being a USER extended hunk
	POP FXP,TT
	JUMPE T,SUBST8
	POP P,A
	SOVE AR1 AR2A
	PUSHJ P,[PUSH P,A
		 PUSH P,[QSUBST]
		 PUSH P,AR1
		 PUSH P,AR2A
		 MOVNI T,4
		 XCT SENDI	;Send the frob a SUBST message
		 ]
SUBSH0:	RSTR AR2A AR1
	POPJ P,

SUBST8:	MOVEI R,1		;R GETS MAX SIZE IN WORDS
   2DIF [LSH R,(TT)]0,QHUNK0
	PUSH FXP,R		;CNTR WHILE COPYING
	PUSH P,R70		;TEMP PTR WHILE COPYING
	MOVE TT,R
	LSH TT,1
	PUSHJ P,ALHUNK		;SAVES AR1,AR2A
	PUSH P,A
SUBST5:	SOSGE R,(FXP)
	 JRST SUBST6
	ADD R,-2(P)
	MOVE R,(R)		;GET WORD OF ORIGINAL HUNK
	HRRZM R,-1(P)		; AND REMEMBER RH OF IT
	HLRZ C,R
	CAIN C,-1
	 JRST SUBS5A
	PUSHJ P,SUBS0A		;COPY LH
	MOVE C,A
SUBS5A:	EXCH C,-1(P)
	CAIN C,-1
	 JRST SUBS5B
	PUSHJ P,SUBS0A		;COPY RH
	MOVE C,A
SUBS5B:	MOVE R,(FXP)
	ADD R,(P)		;POINTER TO NEW COPY
	HRRM C,(R)		;INSTALL RH
	MOVE B,-1(P)
	HRLM B,(R)		;INSTALL LH
	JRST SUBST5


SUBST6:	POP P,C
	POPI P,2
	POPI FXP,1
]; End of IFN HNKLOG,

CRETJ:
SPROG3:	MOVE A,C
	POPJ P,


SUBTTL DELQ, DELASSQ, DELETE, *DELQ, *DELETE

DELASSQ:	MOVEI B,DASSQ
	JRST DLT0
DELQ:	MOVEI B,SMEMQ	;USES A,B,C,T,TT. MUST SAVE AR2A - SSMACRO
	JRST DLT0
DELETE:	MOVEI B,SMEMBER	;USES A,B,C,AR1,AR2A,T,TT
DLT0:	MOVEI TT,-1	;MUST SAVE R, SEE GCP6H1
	CAMN T,XC-2
	 JRST DLT3
	CAME T,XC-3
	 JRST DLTER
	POP P,A
	JSP T,FLTSKP
	 JRST DLT3
	JSP T,IFIX
DLT3:	MOVEM TT,DLTC
	MOVEI TT,(P)
	MOVE D,B
	SKIPA B,(P)
DLT2:	HRRM B,(TT)
	MOVEM TT,TABLU1
	MOVE A,-1(P)
	SOSGE DLTC
	JRST DLT1
	PUSHJ P,(D)	;MEMBER or MEMQ or DASSQ
	JUMPE A,DLT1
	HRRZ B,(A)
	SKIPN TT,MEMV
	 MOVE TT,TABLU1
	JRST DLT2

DLT1:	POP P,A
	JRST POP1J

DASSQ:	PUSHJ P,IASSQ	;SKIPS ON SUCCESS, WITH TAIL OF LIST FOUND IN B
	 MOVEI B,NIL
	MOVE A,B
	POPJ P,

.DELQ:	SKIPA D,[SMEMQ]
.DELETE:
	 MOVEI D,MEMBER
	PUSH P,A
	PUSH P,B
	MOVEI TT,-1
	MOVE B,D
	JRST DLT3



SUBTTL	FLOATP, FIXP, NUMBERP, TYPEP, AND PDLNMK ROUTINE

IRP NUMP,,[FIXP,FLOATP,NUMBERP]BITS,,[FX+BN,FL,FX+FL+BN]
NUMP:	SKOTT A,BITS
	JRST FALSE	;RETURN NIL IF NOT OF DESIRED TYPE
	MOVE TT,(A)	;RETURN T IF WHAT WE WANT. ALSO, TT GETS THE NUMBER.
	JRST TRUE	;IF NUMBERP GETS A BIGNUM, TT GETS THE CORRECT SIGN, ANYWAY
TERMIN

TYPEP:	JUMPE A,TYPNIL		;SUBR 1 - USES ONLY A
	ROT A,-SEGLOG
	HRRZ A,ST(A)
	POPJ P,
TYPNIL:	MOVEI A,QSYMBOL
	POPJ P,

%SYMBOLP:			;SUBR 1
	JSP T,SPATOM
	 JRST FALSE
	JRST TRUE





NMCK0:	POP P,A
NUMCHK:			;CHECK TO SEE THAT WE HAVE A NUMBER, THEN EXIT
IFE NARITH,[
BG%	JSP T,FLTSKP
BG$	JSP T,NVSKIP
BG$	 POPJ P,
	 JFCL			;FALLS INTO PDLNKJ
]		;END OF IFE NARITH
IFN NARITH, WARN [NUMCHK? PDLNMK?]
PDLNKJ:	CAML A,NPDLL		;PDLNKJ = PDLNMK, THEN POPJ P,
	 CAMLE A,NPDLH
	  POPJ P,
	MOVEI T,CPOPJ
PDLNMK:	CAML A,NPDLL		;FIRST A QUICK AND DIRTY CHECK
	 CAMLE A,NPDLH
	  JRST (T)
PDLNM0:	ROT A,-SEGLOG		;NOW TO CHECK THE ST ENTRY
   SPECPRO INTROT
	HLL T,ST(A)
	ROT A,SEGLOG
   NOPRO
	TLNN T,$PDLNM		;SKIP IFF PDL NUMBER
	 JRST (T)
	PUSH P,T
NMK1:	MOVEM TT,PNMK1		;EXPECTS TYPE BITS IN T
	MOVE TT,(A)
	HRRI T,PNMK2		;MUST SAVE TT
	TLNN T,FL		;FIGURE OUT WHICH KIND OF CONS TO DO
	 JRST FXCONS		; - FIXNUM
	JRST FLCONS		; - FLONUM

PNMK2:	MOVE TT,PNMK1		;RESTORE TT FOR PDLNMK
CPDLNKJ:	POPJ P,PDLNKJ

SUBTTL	GCPRO AND SXHASH

GCPRO:	JUMPE B,GCREL
	CAIN B,QM		;SECOND ARG = ? MEANS ONLY GCLOOK
	JRST GCLOOK
%GCPRO:	MOVEI AR1,1		;MUST SAVE R,F - FOR FASLOAD
GCPR1:	CAIL A,IN0-XLONUM
	 CAILE A,IN0+XHINUM-1
	  SKIPA
	   POPJ P,
	SKOTT A,SY
	 JRST GCPR2
	JUMPLE AR1,CPOPJ
	HLRZ T,(A)
	MOVSI TT,SY.CCN\SY.OTC	;COMPILED CODE NEEDS ME BIT
	MOVSI D,SY.PUR		;PURE SYMBOL BLOCK BIT
	TDNN D,(T)
	 IORM TT,(T)
	POPJ P,
GCPR2:	MOVE AR2A,A		;SAVE ARG
	PUSHJ P,SXHSH0		;LEAVES HASHKEY IN D
	MOVE A,AR2A
	MOVE T,AR1		;T=0 => RELEASE, ELSE PROTECT
.GCPRO:	JUMPE A,CPOPJ
	LOCKI
	PUSH P,A	;PLACES ORIG ARG ON PDL
	PUSHJ P,SAVX5	;SAVES NUM ACS
	SKIPE B,GCPSAR
	 JRST .GCPR5
	MOVEI A,NIL
	MOVE TT,LOSEF
	ADDI TT,1
	LSH TT,-1
	PUSHJ P,MKLSAR
	MOVE D,-2(FXP)		;RESTORE HASHKEY IN D
	MOVEM B,GCPSAR
.GCPR5:	MOVE T,D		;ARG ON P, AND SAVES NUM ACS ON FXP
	LSH T,-1
	IDIV T,LOSEF
	PUSH FXP,TT
	MOVEI A,(FXP)
	PUSHJ P,@ASAR(B)
	SUB FXP,R70+1
	MOVEM R,-3(FXP)
	MOVE B,A
	MOVE A,(P)		;ORIG ARG ON P
	PUSH P,B		;SAVE PROLIST BUCKET
	SKIPN -4(FXP)
	 JRST GCRL1		;GO RELEASE IF FLAG SO SET.
	PUSHJ P,MEMBER
	JUMPN A,GCPR3		;ITEM ALREADY IN PROTECTIVE BUCKET
	 SKIPG -4(FXP)
	JRST GCPR4
	MOVE A,-1(P)		;ORIGINAL ARG
	MOVE B,(P)		;CONSED ONTO PROLIST BUKET
	PUSHJ P,CONS
	MOVE R,-3(FXP)
	HRRZ D,GCPSAR
	JSP T,.STOR0
GCPR3:	HLRZ A,(A)
GCPR4:	PUSHJ P,RSTX5
	SUB P,R70+2
	UNLKPOPJ




	
GCRL1:	CALLF 2,QDELETE		;GCRELEASE
	MOVE R,-3(FXP)
	HRRZ D,GCPSAR
	JSP T,.STOR0
	JRST GCPR4

GCREL:	TDZA AR1,AR1
GCLOOK:	MOVNI AR1,1
	SKIPN GCPSAR
	JRST FALSE
	JRST GCPR1




SXHASH:	PUSH P,CFIX1	;SUBR 1 - NCALLABLE
	PUSH P,F	;SAVE F - SEE DEFUN
	PUSHJ P,SXHSH0
	MOVE TT,D
	POP P,F
	POPJ P,

ATMHSH:			;HASH A PRINT NAME
BNHSH:	SETZ T,		;HASH A BIGNUM (SAME ALGORITHM)
	SKIPA B,A
AHSH1:	 HRRZ B,(B)
	JUMPE B,AHSH2
	HLRZ C,(B)
	XOR T,(C)
	JRST AHSH1
AHSH2:	LSH T,-1	;FOR ATOMS, THIS INSURES THAT THE HASHKEY IS POSITIVE
	JRST (TT)

NILHSH:	MOVE D,[<ASCII \NIL\>_-1]	;HASH NIL FASTLY
	POPJ P,

SXHSH0:	JUMPE A,NILHSH		;RETURNS S-EXPR'S HASHKEY IN D
	HRRZ TT,A
	LSH TT,-SEGLOG
	MOVE TT,ST(TT)
2DIF JRST @(TT),SXHSH9,QLIST	.SEE STDISP
SXHSLS:	HRRZ B,(A)
	PUSH P,B
	HLRZ A,(A)
	PUSHJ P,SXHSH0
	SKIPE OLDSXHASHP
	 ROT D,-1
	SKIPN OLDSXHASHP
	 ROT D,11.
	PUSH FXP,D
	POP P,A
	PUSHJ P,SXHSH0
	POP FXP,T
	SKIPN OLDSXHASHP
	 ROT D,7
	ADD D,T
	POPJ P,


SXHSH8:	MOVM D,(A)	;FLONUM
	POPJ P,

SXHSH7:	MOVE D,(A)	;FIXNUM
	POPJ P,

IFN BIGNUM,[
SXHSH4:	HRRZ A,(A)	;BIGNUM
	JSP TT,BNHSH
	MOVE D,T
	POPJ P,
]		;END OF IFN BIGNUM


SYMHSH:
SXHSH5:	HLRZ T,(A)	;SYMBOL
	HRRZ A,1(T)
	JSP TT,ATMHSH
	SKIPA D,T
SXHSH6:	MOVEI D,(A)
	POPJ P,		;RANDOM, ARRAY


SXHSH9:	SXHSLS		;LIST
	SXHSH7		;FIXNUM
	SXHSH8		;FLONUM
DB$	SXHSD1		;DOUBLE
CX$	SXHSC1		;COMPLEX
DX$	SXHSZ1		;DUPLEX
BG$	SXHSH4		;BIGNUM
	SXHSH5		;SYMBOL
HN$  REPEAT HNKLOG+1, SXHS1A	;HUNKS
	SXHSH6		;RANDOM
	SXHSH6		;ARRAY
IFN .-SXHSH9-NTYPES, WARN [WRONG LENGTH TABLE]


IFN DBFLAG,[
SXHSD1:	MOVE D,1(A)
KA	ASH D,10
]		;END OF IFN DBFLAG
IFN DBFLAG+CXFLAG,[
SXHSD2:	ADD D,(A)
	POPJ P,
]		;END OF IFN DBFLAG+CXFLAG

IFN CXFLAG,[
SXHSC1:	MOVS D,1(A)
	JRST SXHSD2
]		;END OF IFN CXFLAG

IFN DXFLAG,[
SXHSZ1:	MOVE D,3(A)
KA	ASH D,10
	SUB D,2(A)
KA	MOVE T,1(A)
KA	ASH T,10
KA	XOR D,T
KIKL	XOR D,1(A)
	JRST SXHSD2
]		;END OF IFN DXFLAG

IFN HNKLOG,[
SXHS1A:	PUSH P,A
	PUSHJ P,USRHPP		   ;Is this a USERHUNK?
	JUMPE T,SXHS1
	PUSHJ P,[PUSH P,A
		 PUSH P,[QSXHASH]
		 MOVNI T,2
		 XCT SENDI]
SXHHS0:	MOVE D,(A)
	JRST POPAJ

SXHS1:	MOVSI T,-1
   2DIF [LSH T,(TT)]0,QHUNK0
	HRRI T,(A)
	PUSH P,T
	PUSH FXP,R70
SXHS1B:	HLRZ A,(T)
	PUSHJ P,SXHSH0
	ROT D,1
	ADDM D,(FXP)
	MOVE T,(P)
	HRRZ A,(T)
	PUSHJ P,SXHSH0
	ADD D,(FXP)
	ROT D,2
	MOVEM D,(FXP)
	MOVE T,(P)
	AOBJP T,SXHS1F
	MOVEM T,(P)
	JRST SXHS1B

SXHS1F:	SUB P,R70+2
	JRST POPXDJ
]		;END OF IFN HNKLOG


SUBTTL	MAPPING FUNCTIONS

;;; MAPATOMS FUNCTION
;;; (MAPATOMS FN) CALLS FN REPEATEDLY, FEEDING IT SUCCESSIVE
;;; ATOMS FROM THE CURRENT OBARRAY.  OPTIONAL SECOND ARG
;;; SPECIFIES OBARRAY (MUST BE A SAR!).  RETURNS NIL.

MAPATOMS:
	MOVEI D,QMAPATOMS
	AOJG T,S1WNALOSE
	AOJL T,S2WNALOSE
	SKIPE T			;SECOND ARG DEFAULTS TO
	 PUSH P,VOBARRAY	; CURRENT OBARRAY
	MOVEI TT,(CALL 1,)
	HRLM TT,-1(P)
	PUSH P,R70
	PUSH FXP,[OBTSIZ]	;NUMBER OF BUCKETS
MAPAT1:	SOSGE TT,(FXP)		;TT GETS BUCKET NUMBER
	 JRST MAPAT9
	HRRZ AR1,-1(P)
	ROT TT,-1
	HLRZ A,@TTSAR(AR1)	;FETCH BUCKET
	SKIPGE TT
	 HRRZ A,@TTSAR(AR1)
	MOVEM A,(P)		;SAVE BUCKET
MAPAT2:	SKIPN B,(P)		;MAPCAR DOWN BUCKET
	 JRST MAPAT1
	HLRZ A,(B)
	HRRZ B,(B)
	MOVEM B,(P)
	XCT -2(P)		;CALL SUPPLIED FUNCTION
	JRST MAPAT2

MAPAT9:	SUB FXP,R70+1		;EXIT, RETURNING NIL
	SUB P,R70+3
	JRST FALSE

;;; PDL STRUCTURE FOR MAP SERIES
;;;	,,RETURN		;LEFT HALF MAY HAVE BAKTRACE INFO
;;;	,,EVENTUAL VALUE	;LEFT HALF HAS LAST OF VALUE LIST
;;;	LIST1		;SECOND ARG
;;;	LIST2		;THIRD ARG
;;;	LIST3		;FOURTH ARG
;;;	 ...
;;;	LISTN		;LAST ARG
;;;	-N,,<ADDRESS OF LIST1 ON STACK>
;;;	CODE,,MODE	;CODE TELLS WHAT KIND OF MAP, MODE TELLS HOW TO CALL FN
;;;			; (MODE IS ADDRESS OF PLACE WHICH SETS UP ARGS FOR FN)
;;;	MAPL6		;OR MAYBE MAPL3 - THIS IS WHERE FN CALL RETURNS TO
;;;	JCALL K,FN	;FN=FIRST ARG - K=1,2,3,4,5, OR 16
;;;			;UUO HANDLER MAY CLOBBER THIS WITH A JRST
;;;			;IF NEVER GOING TO BE XCT'ED, JCALL NEED NOT BE THERE

MAPLIST:	JSP TT,MAPL0	;CODE 0
MAPCAR:	JSP TT,MAPL0		;CODE 1
$MAP:	JSP TT,MAPL0		;CODE 2
MAPC:	JSP TT,MAPL0		;CODE 3
MAPCON:	JSP TT,MAPL0		;CODE 4
$MAPCAN:	JSP TT,MAPL0		;CODE 5
MAPL0:	AOJGE T,MAPWNA		;LOSE IF ONLY ONE ARG
	MOVE D,T
	ADDI D,1(P)		;D HAS ADDRESS OF LIST1 ON STACK
	HRLI D,(T)
	PUSH P,D
   2DIF [MOVSI TT,(TT)]-1,MAPLIST
	PUSH P,TT		;SAVE CODE - FIGURE OUT MODE LATER
	TLNE TT,2		;SKIP IF WE'LL BE SAVING UP RESULTS
	 SKIPA A,(D)		;ELSE WE'LL JUST RETURN FIRST LIST AS VALUE
	  MOVSI A,-1(D)
	EXCH A,-1(D)		;INIT EVENTUAL VALUE SLOT - A NOW HAS FIRST ARG (FN)
	JSP T,SPATOM
	 JRST MAPL5		;FOOEY, IT'S NOT A SYMBOL
	HRRZ C,(A)
MAPL1:	JUMPE C,MAPL5		;FOOEY, IT'S A SYMBOL WITH NO FUNCTION PROPERTY
	HLRZ B,(C)
	HRRZ C,(C)
	HRRZ C,(C)
	CAIL B,QARRAY		;REMEMBER, SYMBOLS DENOTING FUNCTION PROPS
	 CAILE B,QFEXPR		; ARE CONSECUTIVE IN SYMBOL SPACE
	  JRST MAPL1
	CAIE B,QARRAY
	 CAIN B,QSUBR
	  JRST MAPL5A		;GO FIGURE OUT JCALL FOR A SUBR OR ARRAY
	CAIE B,QLSUBR
	 JRST MAPL5		;FOOEY, IT'S SOMETHING WE CAN'T LINK TO WELL
	PUSH P,CMAPL3
	HRLI A,(JCALL 16,)
	MOVEI B,MAPL23
MAPL1B:	HRRM B,-1(P)		;B HAS MODE - SAVE IT
	PUSH P,A		;SAVE FN (MAYBE WITH JCALL K, IN LEFT HALF)
	JRST MAPL2

MAPL3:	MOVE D,(P)		;GET FUNCTION CALL FROM STACK
	TLNE D,700000		;SKIP IF IT DIDN'T GET CLOBBERED
	 JRST MAPL3A
	MOVEI D,MAPL24		;OH, WELL! MIGHT AS WELL USE MODE
	HRRM D,-2(P)		; FOR UNCLOBBERABLE FNS
CMAPL6:
MAPL3A:	MOVEI D,MAPL6
	MOVEM D,-1(P)		;WE ONLY NEED TO DO A MAPL3 CHECK ONCE
MAPL6:	MOVE D,-3(P)		;D POINTS TO LIST1 ON STACK
	HLRZ C,-1(D)		;C GETS POINTER TO LAST OF VALUE
	JUMPE C,MAPL7		;THIS IS REALLY A MAP OR MAPC
	HLLZ B,-2(P)		;GET CODE IN LEFT HALF OF B
	TLNE B,4
	 JRST MAPL8		;MAPCAN OR MAPCON
	PUSHJ P,CONS		;MAPCAR OR MAPLIST - NOTE THAT B IS NIL
	HRRM A,(C)		;CLOBBER INTO END OF LIST
MAPL6A:	HRLM A,-1(D)		;SAVE NEW LAST POINTER
MAPL7:	MOVE TT,(D)
MAPL7A:	HRRZ A,(TT)		;TAKE CDR OF ALL LISTS
	MOVEM A,(D)
	SKIPL TT,1(D)
	 AOJA D,MAPL7A
	MOVE D,TT		;NOW D POINTS TO LIST1 ON STACK AGAIN
MAPL2:	MOVE B,-2(P)
	MOVE C,P		;SAVE C FOR A QUICK GETAWAY
	PUSH P,-1(P)		;WHERE CALL TO FN SHOULD RETURN
MAPL21:	SKIPG A,(D)		;D POINTS TO VECTOR OF LISTS
	 JRST MAPL22		;REMEMBER, <-N,,XXX> IS JUST AFTER <LISTN>
	MOVEI TT,(A)
	LSH TT,-SEGLOG
	SKIPL ST(TT)		;END-OF-LIST TEST
	 JRST MAPL40
	TLNE B,1		;SKIP UNLESS THIS IS A "CAR" KIND OF MAP
	 HLRZ A,(A)
	PUSH P,A		;PUSH ARG
	AOJA D,MAPL21		;IF NOT END, GO CHECK OUT NEXT LIST

MAPL40:	JUMPE A,MAPL4
	LER3 [SIXBIT \NON-NULL TERMINATION OF LIST - MAP!\]
MAPL4:	MOVE P,C		;THIS POPS OFF FASTLY ANY UNNEEDED STUFF
	HLRZ T,-3(P)		;GET -N IN T
	SUBI T,4
	HRLI T,-1(T)
	ADD P,T			;FASTLY POP OFF FN, MODE, ALL LISTS, ETC.
	POP P,A			;FINAL VALUE GOES IN A
	TLZ A,-1		;ZERO ANY LEFT HALF GARBAGE
CMAPL3:	POPJ P,MAPL3		;HOORAY!


MAPL22:	JUMPE A,MAPL4		;NIL IS NORMAL END-OF-LIST
	SETZB A,B		;MAY HAVE GARBAGE IN LEFT HALVES
	HLRE T,(D)		;T GETS -N IN CASE OF LSUBR CALL
	MOVE TT,1(D)		;GET MODE (D POINTS TO <-N,,XXX> ON STACK)
	JSP R,(TT)		;FOR SUBRS, GOES TO PDLA2-N
MAPL23:	XCT 3(D)		;GO HERE FOR LSUBRS

MAPL24:	MOVEM T,UUTSV		;GO HERE FOR UNCLOBBERABLE CALL
	MOVE T,3(D)		;SAVE SOME OF THE UUOH TROUBLE BY
	HRLI T,(JCALLF 16,)	; ENTERING THE UUO MESS MORE DIRECTLY
	MOVEM T,40
	TLZ T,-1
	MOVEI R,1		;R=1 MEANS LSUBR CALL
	SETZM UUOH
	JRST UUOH0A

MAPL5:	PUSH P,CMAPL6		;SET UP FOR UNCLOBBERABLE FN CALL
	MOVEI B,MAPL24
	JRST MAPL1B

MAPL5A:	HLRE T,-1(P)
	CAMGE T,XC-5		;CHECK NUMBER OF ARGS FOR FN
	 JRST MAPL5		;FOOEY, TOO MANY ARGS FOR SUBR CALL
	PUSH P,CMAPL3
	MOVM TT,T
	LSH TT,5
	TLO A,(JCALL)(TT)	;MAKE UP JCALL OF RIGHT # OF ARGS
	MOVEI B,PDLA2(T)	;MODE = PDLA2-<# OF ARGS>
	JRST MAPL1B

MAPL8:	JUMPE A,MAPL7		;NCONC'ING NIL DOES VERY LITTLE
	HRRM A,(C)		;CLOBBER INTO LAST OF PREVIOUS THING
	SKIPE V.RSET
	JRST MAPL8A
	MOVE T,A
MAPL8B:	HRRZ TT,(T)		;AN OPEN-CODING OF THE SUPER-FAST "LAST"
	JUMPE TT,MAPL8C
	HRRZ T,(TT)
	JUMPN T,MAPL8B
	SKIPA A,TT
MAPL8C:	 MOVEI A,(T)
	JRST MAPL6A

MAPL8A:	MOVE T,D
	PUSHJ P,LAST		;FIND LAST OF THIS NEW FROB
	MOVE D,T
	JRST MAPL6A

.MAP:	JSP TT,.MAP1	;MAPCAN
	JSP TT,.MAP1	;MAPCON
	JSP TT,.MAP1	;MAPC
	JSP TT,.MAP1	;MAP
	JSP TT,.MAP1	;MAPCAR
	JSP TT,.MAP1	;MAPLIST
.MAP1:	JUMPE A,CPOPJ
	TLNE A,-1	;RIDICULOUS CHECK FOR HORRIBLE
	 .VALUE		; COMPILER LOSSES
	PUSH P,B	;LIST IN A, FUNCTION IN B,
	PUSH P,A	;NUMBER IN TT IS INDEX
	MOVNI T,2
10$	SUBI TT,.MAP+A	;LOSING D10!!!
10$	MOVNS TT	;NO NEGATIVE RELOC ALLOWED!
.ELSE	MOVNI TT,-.MAP-A(TT)
	JRST $MAPCAN(TT)


SET:	JSP D,SETCK		;SUBR 2
	EXCH B,A		;FORTUNATELY, NOT USED BY COMPILED CODE
	JSP T,PDLNMK
	EXCH B,A
	EXCH B,AR1
	JSP T,.SET1
	EXCH B,AR1
	POPJ P,

SETCK:	JSP T,SPATOM
	 JSP T,PNGE1
	JRST (D)

SUBTTL	VARIOUS BREAK ROUTINES

$BREAK:	JUMPE A,CPOPJ		;*BREAK - SUBR 2
$BRK0:	MOVEI A,(B)		;A = BREAKP, B = BREAKID
	HRRZ B,V.
	HRRZ AR1,VIPLUS
	HRRZ AR2A,VIDIFF
	JSP T,SPECBIND		;DO *NOT* BIND ^R
		TAPRED		;^Q
		TTYOFF		;^W
		VEVALHOOK	;EVALHOOK
	    0 B,V.		;*
	    0 AR1,VIPLUS	;+
	    0 AR2A,VIDIFF	;-
	MOVEI B,$DEVICE
	MOVEI C,IUNTYI		;INTERNAL UNTYI'ER
	MOVEI AR2A,TRUTH
	JSP T,SPECBIND
	   0 B,TYIMAN
	   0 C,UNTYIMAN
	   0 AR2A,V%TERPRI
	STRT 17,[SIXBIT \^M;BKPT !\]
	HRRZ AR1,VMSGFILES
	TLO AR1,200000
	PUSHJ P,$PRINC
	STRT 17,STRTCR
	MOVE A,VIDIFFERENCE
	MOVEM A,VIPLUS
	MOVEI D,BRLP	;FUNCTION TO EXECUTE
	PUSHJ P,BRGEN	;CATCH AND ERRSET AROUND A READ-EVAL-PRINT LOOP 
	JSP F,LINMDP
	 PUSHJ P,ITERPRI
	PUSHJ P,UNBIND
	JRST UNBIND

CB:	SKIPN V.RSET	;CALL BREAK - *RSET ERROR
	POPJ P,
	SKIPA B,[Q.R.TP]
CN.BB:	MOVEI B,QCN.B	;CONTROL-B BREAK
	PUSHJ P,IOGBND
	JRST BKCOM2

UDFB:	MOVEI B,QUDF	;UNDEFINED FUNCTION BREAK
	JRST BKCOM

UBVB:	MOVEI B,QUBV	;UNBOUND VARIABLE BREAK
	JRST BKCOM

WTAB:	MOVEI B,QWTA	;WRONG TYPE OF ARGUMENT BREAK
	JRST BKCOM

UGTB:	MOVEI B,QUGT	;UNSEEN GO TAG BREAK
	JRST BKCOM

WNAB:	MOVEI B,QWNA	;WRONG # ARGS BREAK
	JRST BKCOM

GCLB:	MOVEI B,QGCL	;FAILED TO GARBAGE-COLLECT ENOUGH SPACE BREAK
	JRST BKCOM

PDLB:	MOVEI B,QPDL	;PDL OVERFLOW BREAK
	JRST BKCOM

GCOB:	MOVEI B,QGCO	;GC OVERFLOW BREAK
	JRST BKCOM

IOLB:	MOVEI B,QIOL	;I/O LOSSAGE BREAK
	JRST BKCOM

FACB:	MOVEI B,QFAC	;FAILED ACTION REQUEST BREAK
BKCOM:
	PUSHJ P,IOGBND
	SOVE A B
	PUSH P,CBKCM0
	PUSH P,R70
	PUSH P,VMSGFILES
	MOVNI T,2
	JRST ERRPRINT
BKCOM0:
	JSP R,RSTR2
BKCOM2: MOVE AR2A,VE.B.E		;ERROR-BREAK-ENVIRONMENT
	SKOTT AR2A,LS
	 JRST BKCOM3
	HRRZ AR1,(AR2A)			;(OBARRAY . READTABLE)
	HLRZ AR2A,(AR2A)	
	SKOTT AR1,SA
	 JRST BKCOM3
	SKOTT AR2A,SA
	 JRST BKCOM3
BKCOM4:	JSP T,SPECBIND
	0 A,VARGS		;SPECIAL VALUE CELL OF ARGS
	0 AR1,VREADTABLE
	0 AR2A,VOBARRAY
CBKCM0:	SETZ A,BKCOM0
	PUSHJ P,NOINTERRUPT
	MOVEI A,TRUTH
	PUSHJ P,$BREAK
BKCOM1:	PUSHJ P,UNBIND
	JRST UNBIND

BKCOM3:	PUSH P,[BKCOM2]
	PUSH P,A
	PUSH P,CPOPAJ
	MOVEI A,IGSBV
	EXCH A,VE.B.E
	FAC [LOSING VALUE FOR ERROR-BREAK-ENVIRONMENT!]


SUBTTL	INTERN FUNCTION AND RELATED ROUTINES

INTERN:	PUSH P,A		;ONLY INIT ENTERS INTERN AT INTRN0
INTRN3:	PUSHJ P,PNGET		;MUST SAVE F - SEE FASLOAD
	SETOM LPNF
INTRN1:	SETZM RINF
	JSP TT,ATMHSH		;LEAVES ATOM'S HASHKEY IN T
	MOVEI AR2A,(A)
	HLRZ C,(A)
INTRN:	TLZ T,400000
	IDIVI T,OBTSIZ
	HRLM TT,(P)
INTRN4:	LOCKI			;SO THAT NO INTERRUPT SNEAKS SOMETHING ON THE
	SKIPN D,VOBARRAY	; OBLIST JUST AFTER WE DECIDE IT ISNT THERE 
	 JRST INTNCO
 	MOVEI C,(D)
	LSH C,-SEGLOG
	MOVE C,ST(C)
	TLNN C,SA
	 JRST INTNCO
	MOVE T,ASAR(D)
	TLNN T,AS<OBA>
	 JRST INTNCO
	ROT TT,-1		;GET BUCKET
	JUMPL TT,.+3
	HLRZ A,@TTSAR(D)
	SKIPA
	 HRRZ A,@TTSAR(D)
	PUSH FXP,TT
	JUMPE A,MAKA0
	MOVEI C,A
MAKF:	MOVE AR1,C
	HRRZ C,(C)
	JUMPE C,MAKA
	HLRZ AR1,(C)
	SKIPN AR1
	 TROA AR1,$$$NIL		;BEWARE THE SKIP!
MAKF1:	  HLRZ AR1,(AR1)
	HRRZ AR1,1(AR1)
	SKIPN T,RINF		;RINF HAS ZERO WHEN IN REGULAR INTERN
	 MOVEI T,(AR2A)
MAK2:	JUMPE AR1,MAK1
	JUMPE T,MAKF
	HLRZ B,(AR1)
	MOVE B,(B)
	SKIPN RINF
	 JRST MAK4
	CAME B,@RNTN2	;<END OF PNAME>(T)
	 JRST MAKF	;COMPARE FOR RINTERN
	AOJA T,MAK3
MAK4:	HLRZ D,(T)	;COMPARE FOR REGULAR INTERN
	CAME B,(D)
	 JRST MAKF
	HRRZ T,(T)
MAK3:	HRRZ AR1,(AR1)
	JRST MAK2


MAKA3:	HRRZ A,(P)	    ;MAKE NEW ENTRY INTO OBARRAY FROM CALL TO INTERN
	MOVEI B,Q%ISM	    ; AS OPPOSED TO RINTERN
	PUSHJ P,GET1
	JUMPE A,MAKA3B
	HRRZ A,(P)
	MOVEI B,NIL
	PUSHJ P,COPYSYMBOL
	HRRM A,(P)
MAKA3B: HRRZ A,(P)
	SKIPGE LPNF
	 JRST MAKA2
	SKIPE B,V.PURE	    ;INTERN MAKES PURE SY2 IF *PURE=T AND NOT SYMBOL
	 CAIN B,QSYMBOL
	  JRST MAKA3A
	PUSHJ P,PSYCONS
	JRST MAKA2
MAKA3A:	PUSHJ P,SYCONS
	JRST MAKA2

MAKA0:	TDZA D,D	;D=0 => BUCKET WAS EMPTY BEFORE THIS CALL
MAKA:	 MOVEI D,1
	MOVN C,RINF	;MAKE-UP NEW ATOM
	JUMPE C,MAKA3
	PUSHJ P,PNGNK
MAKA2:	PUSHJ P,NCONS
	MOVE TT,(FXP)
	JUMPE D,MAKA5
	HRRM A,(AR1)	;NCONC ONTO END OF BUCKET
	JRST MAKA4
MAKA5:	HRRZ D,VOBARRAY
	JUMPL TT,.+3
	HRLM A,@TTSAR(D)
	SKIPA
	 HRRM A,@TTSAR(D)
MAKA4:	SKIPA C,A
MAK1:	 JUMPN T,MAKF	;ATOM FOUND ON OBLIST
	HLRZ A,(C)
	POP FXP,TT	;SHOULD EXIT WITH OBTBL BUCKET # IN TT
	SUB P,R70+1
	UNLKPOPJ


;;; COME HERE TO INTERN AN ATOM WHOSE PRINT NAME IS IN PNBUF.

RINTERN:
	CAMN C,[350700,,PNBUF]	;SAVES F
	 JRST RINTN1
RINTN0:	PUSH FXP,T
	PUSH P,CPXTJ
	PUSH P,A	;ENTERING INTERN AFTER THE "PUSH P A", SO MUST DO HERE
	SKIPL LPNF
	 JRST INTRN1
	ADDI C,1
	HRRM C,RNTN2
   2DIF [MOVEI C,(C)]0,PNBUF
	MOVNM C,RINF
INTRN2:	MOVEI C,PNBUF		;DUPLICATE PNAME HASHING ALGORITHM
	MOVE T,PNBUF		; AS USED IN SXHASH
	MOVN D,RINF
	SOJLE D,.+3
	XOR T,PNBUF(D)
	JRST .-2
	LSH T,-1
	JRST INTRN

RINTN1:	SKIPL LPNF
	 JRST RINTN0
	MOVE TT,PNBUF
	ROT TT,6
	ADDI TT,<OBTSIZ+1>/2	;### OBTSIZ MUST BE ODD
	MOVE D,VOBARRAY
	JUMPL TT,.+3
	HLRZ A,@1(D)
	SKIPA
	 HRRZ A,@1(D)
	JUMPN A,CPOPJ
	PUSH FXP,TT
	PUSHJ P,RINTN0
	POP FXP,TT
	MOVE D,VOBARRAY
	JUMPL TT,.+3
	HRLM A,@1(D)
	POPJ P,
	HRRM A,@1(D)
	POPJ P,



IMPLODE:
	SKIPA T,CRINTERN	;SUBR 1
MAKNAM:	MOVEI T,PNGNK1		;SUBR 1
	JUMPE A,MKNM4
	PUSH P,T
	PUSH P,RDLARG
	HRRZM A,RDLARG
	MOVEI T,MKNM1
	PUSHJ FXP,MKNR6C
	POP P,RDLARG
CRINTERN:
	POPJ P,RINTERN

MKNM1:	SKIPN A,RDLARG
	POPJ P,
	HRRZ B,(A)
	MOVEM B,RDLARG
	HLRZ A,(A)
MKNM2:	JSP T,CHNV1
	JRST POPJ1


RDL12:	MOVEI T,RINTERN
MKNM4:	SETZM PNBUF
	JSP TT,IRDA
	JRST (T)	;PNGNK1 OR RINTERN, THEN POPJ P,



;;; GET CHARACTER NUMERIC VALUE

CHNV1X:	TLO T,1
CHNV1:	SKOTT A,SY+FX
	 JRST CHNV1C
	TLNN TT,SY
	 JRST CHNV1A
CHNV1D:	HLRZ TT,(A)
	HRRZ TT,1(TT)
	HLRZ TT,(TT)
	LDB TT,[350700,,(TT)]
	JRST CHNV1B

CHNV1A:	MOVE TT,(A)
	TLNN T,1
CHNV1B:
SA%	TDNN TT,[-200]
SA$	TDNN TT,[-1000]
	 JRST (T)
CHNV1C:	WTA [NOT ASCII CHARACTER!]
	JRST CHNV1


SUBTTL	DEFPROP AND DEFUN

;;; THE BASIC IDEA OF DEFPROP IS:
;;;	(DEFUN DEFPROP FEXPR (X)
;;;	       (DO () ((NULL (REMPROP (CAR X) (CADDR X)))))
;;;	       (PUTPROP (CAR X) (CADR X) (CADDR X)))
;;; THAT IS, REMOVE *ALL* OCCURRENCES OF THE PROPERTY BEFORE
;;; PUTTING ON THE NEW VALUE.

DEFPROP:			;FEXPR
REPEAT 2,	PUSH P,A
	JSP T,DFPR2
	 JSP T,DFPR1
	  JRST DFPER
	HRRZ TT,(C)
	JUMPN TT,DFPER
	HLRZ A,(A)
	HLRZ AR1,(B)
	HLRZ B,(C)
	MOVEI C,(B)
;SYMBOL IN A; PROPERTY NAME IN B *AND* C; PROPERTY VALUE IN AR1.
DEF1:	MOVEI AR2A,(A)		;DEFUN COMES IN HERE
DEF1B:	PUSHJ P,REMPROP		;REMPROP SAVES C, AR1, AR2A
	MOVEI B,(AR1)
	JUMPN A,DEF1B		;REMOVE ALL OCCURRENCES OF THE PROPERTY
	MOVEI A,(AR2A)
	PUSHJ P,PUTPROP
DEF9:	POP P,A			;PUT NEW VALUE FOR PROPERTY
	POPI P,1
	JRST $CAR

DFPR2:	HLRZ B,(A)		;SOME HAIRY CHECKS FOR DEFPROP AND DEFUN
	SKOTT B,SY		;SKIPS ON *FAILURE* TO GET A VALID SYMBOL
	JUMPN B,1(T)
	JRST (T)

DFPR1:	JUMPE A,(T)		;MORE HAIRY CHECKS FOR DEFPROP AND DEFUN
	HRRZ B,(A)		;SKIPS ON *SUCCESS*
	JUMPE B,(T)		;LEAVES STUFF SPREAD OUT IN A, B, C
	HRRZ C,(B)
	JUMPE C,(T)
	JRST 1(T)

;;; (DEFUN <SPEC> <FLAG> <ARGS> . <BODY>) DEFINES A FUNCTION.
;;;   <FLAG> MAY BE OMITTED, OR MAY BE "EXPR", "FEXPR", OR "MACRO".
;;;   <SPEC> MAY BE A SYMBOL (THE NAME OF THE FUNCTION), OR A LIST OF
;;; 	TWO TO FOUR SYMBOLS (IN WHICH CASE THE FLAG "MACRO" IS ILLEGAL).
;;;   <ARGS> IS A NON-NIL SYMBOL OR A LIST OF SYMBOLS; THE FORMER INDICATES 
;;;	AN LEXPR (INCOMPATIBLE WITH THE "MACRO" AND "FEXPR" FLAGS).
;;;	OTHER FORMATS FOR <ARGS>, INCLUDING APPEARANCE OF & KEYWORDS,
;;;	CAUSES THE MACRO "DEFUN&" TO BE RUN INSTEAD.
;;;
;;; IF THE VALUE OF THE SWITCH DEFUN IS T, THEN THE EXPR-HASH HACK
;;; IS ENABLED.  IN THIS CASE, DEFUN AVOIDS MAKING THE INTERPRETIVE
;;; DEFINITION IF HASHING THE DEFINITION INDICATES THAT IT IS
;;; THE SAME AS THE CURRENT, PRESUMABLY COMPILED, DEFINITION.
;;; THE VARIOUS CASES ARE:
;;; FORM OF <SPEC>:
;;;	FOO		(FOO BAR)	(FOO BAR BAZ)	(FOO BAR BAZ QUUX)
;;; EXPR-HASH PROPERTY IS ON THE ATOM:
;;;	FOO		(GET 'FOO 'BAR)	  - NONE -	FOO
;;;			[IF THIS IS A SYMBOL]
;;; EXPR-HASH PROPERTY INDICATOR IS:
;;;	EXPR-HASH	EXPR-HASH	  - NONE -	QUUX
;;; DEFUN PUTS THE FUNCTION DEFINITION ON FOO UNDER THE PROPERTY:
;;;	EXPR/FEXPR/MACRO   BAR		BAR		BAR
;;; COMPILER PUTS THE FUNCTION DEFINITION ON FOO UNDER THE PROPERTY:
;;;	SUBR/FSUBR/LSUBR   BAR *	BAZ		BAZ
;;; * THE PROPERTY WILL BE A SYMBOL |FOO BAR| WHICH IN TURN
;;; WILL HAVE THE APPROPRIATE SUBR/FSUBR/LSUBR PROPERTY.

DEFUN:
REPEAT 2, PUSH P,A
DEF7:	HRRZ A,(A)
	HLRZ AR1,(A)
	CAIN AR1,QEXPR
	 JRST DEF3
	CAIE AR1,QFEXPR
	 CAIN AR1,QMACRO
	  JRST DEF3		;(DEFUN <SPEC> <FLAG> ...)
	MOVEI AR1,QEXPR		;(DEFUN <SPEC> ...); <FLAG> DEFAULTS TO EXPR
	MOVE A,(P)
;<FLAG> IS IN AR1; THE CDR OF A IS (<ARGS> ...); THE CAR OF (P) IS <SPEC>.
DEF3:	JSP T,DFPR1		;MAKE SURE WE HAVE AT LEAST TWO THINGS
	 JRST DEFNER
	HLRZ TT,(B)
	SKOTT TT,LS
	 JRST DEF3L
	HLRZ AR2A,(B)		;MAYBE HAS & KEY WORDS?
DEF3B:	HLRZ T,(AR2A)
	JUMPE T,DEF3X		;NIL doesn't require DEFUN& !!
	SKOTT T,SY
	 JRST DEF4		;PATTERN MATCHINGS REQUIRE DEFUN&
	CAIL T,Q%OPTIONAL	;KEYWORDS REQUIRE DEFUN&
	  CAILE T,Q%RSTV	;&OPTIONAL, &REST, &AUX, &RESTV, &RESTL
	    CAIA
	      JRST DEF4
DEF3X:	HRRZ AR2A,(AR2A)
	JUMPN AR2A,DEF3B
DEF3L:	MOVEI A,QLAMBDA		;CREATE AN APPROPRIATE LAMBDA-EXPRESSION
	PUSHJ P,CONS
	MOVEI C,(A)
	HRRZ A,(P)		;THE CAR OF THIS IS <SPEC>
	MOVEI AR2A,QXPRHSH
	JSP T,DFPR2		;CHECK TO SEE IF ATOM (SKIPS UNLESS SYMBOL)
	 JRST DEF3A
	MOVEM B,(P)		;SAVE THIS FUNNY LIST
	CAIN AR1,QMACRO
	 JRST DEFNER		;FUNNY FORMAT AND MACRO FLAG DON'T MIX
	HRRZ B,(B)		;PECULIAR FORMAT: (NAME EXPRNAME ...)
	HLRZ AR1,(B)
	JUMPE AR1,DEFNER
	HRRZ B,(B)
	SETO AR2A,		;FOR A 2-LIST, USE "EXPR-HASH" FOR EXPR-HASH PROPERTY,
	JUMPE B,DEF3A		; BUT MUST ALSO LOOK IN A DIFFERENT PLACE
	HRRZ B,(B)
	JUMPE B,DEF5		;3-LISTS DON'T USE EXPR-HASH FEATURE
	HLRZ AR2A,(B)		;4-LISTS USE THE FOURTH ITEM
;EXPR-HASH PROP NAME IN AR2A, OR -1;
; DEFINITION IN C; PROPERTY NAME IN AR1; NAME IN CAR OF (P).
DEF3A:	SKIPN VDEFUN		;THE VALUE OF DEFUN CONTROLS
	 JRST DEF5		; THE EXPR-HASH HACK
	HLRZ A,@(P)
	JUMPGE AR2A,DEF6	;JUMP UNLESS 2-LIST FORMAT
	MOVEI B,(AR1)		;MUST GET VALUE OF EXISTING PROPERTY
	PUSHJ P,GET1		; AND SEARCH IT FOR THE EXPR-HASH PROPERTY
	JUMPE A,DEF5		;IF NONE, LOSE
	JSP T,STENT
	TLNN TT,SY		;NO EXPR-HASH IF NOT A SYMBOL
	 JRST DEF5
	MOVEI AR2A,QXPRHSH
;A HAS THE ATOM CONTAINING THE EXPR-HASH PROPERTY, IF ANY.
;AR2A HAS AN ACTUAL EXPR-HASH PROPERTY NAME.
DEF6:	MOVEI B,(AR2A)
	MOVEI AR2A,(A)		;SAVE ATOM INVOLVED
	PUSHJ P,GET1		;GET EXPR-HASH PROPERTY
	JUMPE A,DEF5		;DO DEFUN IF NONE
	MOVE F,(A)		;EXPR-HASH PROPERTY VALUE BETTER BE FIXNUM!
	PUSHJ FXP,SAV5M1
	MOVEI A,(C)		;CANONICAL LAMBDA FORM
	PUSHJ P,SXHASH+1	;NCALL 1,.FUNCTION SXHASH
	PUSHJ FXP,RST5M1
	CAMN TT,F
	 JRST DEF9		;AHA! HASHES MATCH! FORGET IT.
	MOVEI A,(AR2A)		;HASHES MATCH, SO FLUSH THE EXPR-HASH PROPERTY
	PUSHJ P,REMPROP		; AND THEN PERFORM THE DEFINITION
;THE CAR OF (P) IS THE ATOM TO PUTPROP ONTO; AR1 IS THE PROPERTY NAME; C IS THE VALUE.
DEF5:	HLRZ A,@(P)
	EXCH C,AR1
	MOVEI B,(C)
	JRST DEF1		;GO DO THE PUTPROP

DEF4:	POPI P,1
	POP P,B
	MOVEI A,Q%DEFUN		;"DEFUN&"
	PUSHJ P,CONS		;TRY AGAIN WITH (DEFUN FOO ...) REPLACED BY
	JRST EV0		;  (DEFUN& FOO ...)


SUBTTL	TYIPEEK FUNCTION


TYIPEEK:			;LSUBR (0 . 3) NCALLABLE
	SKIPA F,CFIX1
	 MOVEI F,CPOPJ
	MOVEI D,QTYIPEEK
	CAMGE T,XC-3
	 JRST WNALOSE
	SKIPE T			;NO ARGS <=> ONE ARG OF NIL
	 AOSA T			;ELSE DECREMENT ARG COUNT FOR INCALL
	  PUSH P,R70
	MOVEI D,(P)
	ADDI D,(T)
	MOVEI AR2A,CPOPJ
	EXCH AR2A,(D)
	JSP D,XINCALL		;PROCESS ARGS 2 AND 3
SFA%	   QTYIPEEK		; (ALSO PUSHES F ONTO P)
SFA$	[SO.TIP,,],,QTYIPEEK
	PUSH FXP,BFPRDP
	MOVSI A,Q%TYI
	MOVEM A,BFPRDP
	MOVEI A,(AR2A)		;GET ARG 1 IN A
	JSP T,GTRDTB		;GET READTABLE IN AR2A
	JUMPN A,TYPK1		;NIL => ACCEPT ANY CHAR
	 PUSHJ P,$PEEK
	 JRST TYPKX
TYPK1:	CAIE A,TRUTH		;T => SEARCH FOR READER START
	 JRST TYPK3		; CHARACTER (E.G. PAREN, MACRO)
TYPK1C:	PUSHJ P,$$PEEK		;PEEK AT A CHAR
	JUMPL TT,TYPK9A		;HIT EOF - TAKE A "SOFT" EOF, RETURN -1
	MOVE T,@TTSAR(AR2A)	;PEEK SETS UP AR2A
	TLC T,4040	.SEE SYNTAX
	TLCE T,4040
	 JRST TYPK1F
	PUSH P,T
	PUSHJ P,@TYIMAN
	POP P,T
	CALLF 0,(T)		;HIT A HORRIBLE SPLICING MACRO
	JSP T,GTRDTB		;Refetch the read table.  User code clobbers
				;AR2A, and may have SETQed READTABLE
	JRST TYPK1C		;GO BACK AND TRY AGAIN


$$PEEK:	HRRZ TT,TYIMAN		;CALL TYIMAN ONE EARLY TO
	JRST -1(TT)		; SPECIFY PEEKING

TYPK1F:	TLNE T,266217	.SEE SYNTAX	;READER START CHARS
	 JRST TYPKX
TYPK1H:	PUSHJ P,@TYIMAN		;CHAR NOT ACCEPTABLE - GOBBLE IT
	JRST TYPK1C		;NOW GO TRY AGAIN

TYPK3:	JSP T,FXNV1		;ARG MUST BE FIXNUM
	JUMPL TT,TYPK3C		;ARG BETWEEN 0 AND 777 =>
	CAIG TT,777		; SCAN FOR THAT CHARACTER;
	 TLOA TT,400000		; OTHERWISE IS A SYNTAX, LSH'ED
TYPK3C:	  LSH TT,-11		; LEFT BY 11, TO SERVE AS MASK
	PUSH FXP,TT
TYPK4:	PUSHJ P,$$PEEK		;PEEK AT A CHAR
	JUMPL TT,TYPK9		;SOFT EOF - GO RETURN -1 OR WHATEVER
	SKIPL D,(FXP)		;SKIP IF SPECIFIC CHARACTER
	 JRST TYPK6
	CAIN TT,(D)		;COMPARE TO ONE WE GOT
	 JRST TYPKXT		;SUPER WIN
TYPK5:	PUSHJ P,@TYIMAN		;NOT THE ONE - GOBBLE AND RETRY
	JRST TYPK4

TYPK6:	HLRZ T,@TTSAR(AR2A)	.SEE SYNTAX
	TDNN T,D		;CHECK SYNTAX AGAINST MASK
	 JRST TYPK5
TYPKXT:	POP FXP,T
TYPKX:	POP FXP,BFPRDP		;EXIT
	POPJ P,


TYPK9:	POPI FXP,2		;FLUSH "BFPRDP" AND "T"
TYPK9A:	SKIPN EOFRTN		;"SOFT" EOF.  DOES NOT INVOKE
	 JRST M1TTPJ		; THE EOFFN, BUT WILL PICK UP
	JRST EOF9		; THE EOFVAL IF NECESSARY.


SUBTTL	QUIT, VALRET, AND SUSPEND FUNCTIONS

QUIT:	MOVEI D,QQUIT		;LSUBR (0 . 1)
	AOJL T,S1WNALOSE
	SKIPE T
	 TDZA A,A		;NO ARG => USE NIL
	  POP P,A
IT% 	JRST VLRT3
IFN ITS,[
	CAIN A,TRUTH		;T MEANS KILL AS QUIETLY AS POSSIBLE
	 JRST VLRT3
	MOVEI D,160000		;VANILLA-FLAVORED KILL
	CAIN A,Q$ERROR		;ERROR MEANS WE SHOULD KILL INPUT BUFFER
	 TRZ D,100000
	MOVEI TT,(A)
	LSH TT,-SEGLOG
	MOVE TT,ST(TT)
	TLNE TT,FX
	 MOVE D,(A)		;FIXNUM ARG => USE FOR .BREAK 16, ARG
	JRST VLRT3A
]	;END OF IFN ITS


VALRET:	JUMPE T,VLRT9		;LSUBR (0 . 1)
	JSP TT,LWNACK
	   LA01,,QVALRET
	POP P,A
	PUSHJ P,VALSTR
10%	SETOM SAWSP
	PUSHJ P,RETVAL		;VALRET STRING ON FXP IN APPROPRIATE MANNER
10%	SETZM SAWSP
	POPJ P,


;;; TAKE SYMBOL OR FIXNUM IN A, PUSH PNAME STRING OR VALUE ONTO FXP.
;;; ON TOP OF THAT, AS LAST FXP SLOT, PUSH ORIGINAL VALUE OF FXP.

VALSTR:	JSP T,LATOM		;STRING A SYMBOL?
	 JRST VALS1
IT$	SETZM VALFIX		;FLAG THAT VALRET 'STRING' IS NOT A FIXNUM
	PUSHJ P,PNGET
	MOVE R,FXP
VLRT2:	HLRZ B,(A)
	PUSH FXP,(B)
	HRRZ A,(A)
	JUMPN A,VLRT2
	PUSHN FXP,1		;PUSH A ZERO WORD FOR GOOD MEASURE
	PUSH FXP,R
	POPJ P,
VALS1:
IFN ITS,[
	SKOTT A,FX		;ALLOW A FIXNUM
	 JRST VALERR		;ERROR -- WTA
	SETOM VALFIX		;REALLY A FIXNUM
	MOVE R,FXP		;SAVE A COPY OF FXP
	PUSH FXP,(A)		;PUSH THE FIXNUM
	PUSH FXP,R		;THEN PUSH THE OLD FXP
	POPJ P,
]		;END IFN ITS
VALERR:
IT$	WTA [- ARG TO BE VALRET'ED MUST BE A FIXNUM OR A SYMBOL!]
IT%	WTA [- ARG TO BE VALRET'ED MUST BE A SYMBOL!] 
	JRST VALSTR

;;; ASSUME VALSTR HAS PUSHED A VALRET STRING ONTO FXP.
;;; VALRET THAT STRING IN THE APPROPRIATE MACHINE-DEPENDENT WAY,
;;; EXCEPT THAT CERTAIN "ITS" STRINGS ARE INTERPRETED IN ANY
;;; IMPLEMENTATION (AN ANACHRONISM FOR COMPATIBILITY ONLY).
;;; AFTER DOING WHATEVER, THE STRING IS FLUSHED FROM FXP.

RETVAL:
IFN ITS,[
	SKIPN VALFIX		;WAS VALRET STRING REALLY A FIXNUM?
	 JRST RETSTR		;NO, NORMAL HANDLING
	HRRZ TT,-1(FXP)		;YES, PICK UP THE FIXNUM
	.BREAK 16,(TT)
	MOVE FXP,(FXP)		;RESET FXP
	POPJ P,			;IF CONTINUING RETURN AND GO ON
RETSTR:	]	;END IFN ITS
	MOVE R,(FXP)
	MOVE D,1(R)
	CAME D,[ASCII \:KILL\]
	 CAMN D,[ASCII \:kill\]
	  CAIA
	   JRST VLRT1
	MOVE D,2(R)
	CAME D,[ASCII \ \]
	 CAMN D,[ASCII \î\]
	  JRST VLRT3
	JRST VLRT5

VLRT1:	CAMN D,[ASCII \.\]
	 JRST VLRT3
	CAME D,[ASCII \U\]
	 CAMN D,[ASCII \u\]
	  JRST VLRT9

;HERE IS THE MACHINE-DEPENDENT THING TO DO TO RET THE VAL STRING
VLRT5:
IT$	.VALUE 1(R)
IFN D10,[
SA%	OUTSTR 1(R)
IFN SAIL,[
	SETZ D,			;D IS ZERO FOR TWO DIFFERENT REASONS!
	MOVEI TT,1(R)		;THIS PIECE OF CRAP LOOKS LIKE
	HRLI TT,440700		; SOMETHING RPG WOULD WRITE (BUT GLS DID)
	ILDB T,TT
	JUMPN T,.-1
	MOVEI T,^M		;CRUFTY STRAY ^M MAKES PTLOAD HAPPIER
	DPB T,TT
	IDPB D,TT		;THEN TERMINATE WITH A NULL
	HRLI R,440700
	HRRI R,1(R)
	PTLOAD D		;LOAD THE STRING INTO THE LINE EDITOR
]		;END OF IFN SAIL
]		;END OF IFN D10
IFN D20,[
	PUSH P,A
	HRRI 1,1(R)
	TLO 1,440700
	SKIPE TENEXP
	 JRST [	MOVE T,1
		MOVEI 1,.PRIIN 
		CFIBF
		ILDB 2,T
		JUMPE 2,VLRT6X
		STI
		JRST .-3 ]
	RSCAN			;stuff some chars into the RSCAN buff
	 JFCL
	MOVEI 1,.RSINI		;move buff ptr back to origin
	RSCAN
	 JFCL
VLRT6X:	HALTF
	POP P,A
]		;END OF IFN D20
	MOVE FXP,(FXP)
	POPJ P,


VLRT3:
IFE ITS,[
VLRT9:	
10$ 	EXIT 1,
20$	HALTF
	POPJ P,
]	;END IFE ITS
IFN ITS,[
	MOVEI D,120000		;"SILENT KILL"
VLRT3A:	.LOGOUT 1,		;TRY TO LOG OUT
	JSP T,SIDDTP
	.VALUE
	.BREAK 16,(D)

VLRT9:	 .LOGOUT 0,		;TRY TO LOG OUT IF NO DDT AVAILABLE 
	.VALUE [ASCIZ \:VK \]	;OH, WELL...
	POPJ P,			;IN CASE LOSER DOES $P FROM IT

SIDDTP:	.SUSET [.ROPTION,,TT]
	TLNN TT,OPTBRK		;SKIP IF JOB INFERIOR TO DDT
	 JRST (T)		; (ACTUALLY, IF SUPERIOR HANDLES .BREAK)
	JRST 1(T)
]		;END OF IFN ITS


SUSPEND:			;LSUBR (0 . 2)
	JSP TT,LWNACK
	   LA012,,QSUSPEND
IT$	SETZM PURDEV		;ASSUME NO DUMPING
	PUSH FLP,R70		;ASSUME WE ARE RETURNING FROM A RESTART
	PUSH FLP,R70		;ALSO ASSUME FIRST ARG IS NON-NIL
	JUMPE T,SUSP0
	AOJE T,SUSP0C		;JUMP IF ONE ARG
	POP P,A			;2ND ARG, IF ANY, IS SAVE FILE NAME FOR HISEG
				; FOR ITS, IS NAME OF PDUMP FILE 
IFN HISEGMENT,[
	SKIPN SUSFLS
	JRST SUSP0C
	PUSHJ P,FIL6BT		;CONVERT FILESPEC IN A TO SIXBIT ON FXP
	PUSHJ P,DMRGF		;MERGE WITH DEFAULTS
	POP FXP,SGAEXT		;UNSTACK ARGS INTO PROPER SPOT
	POP FXP,SGANAM
	POP FXP,SGAPPN
	POP FXP,SGADEV
	PUSHJ P,SAVHGH		;SAVE HIGH SEGMENT
	 FAC [FAILED TO SAVE HIGH SEGMENT - SUSPEND!]
]		;END OF IFN HISEGMENT
IFN ITS,[
	PUSHJ P,FIL6BT		;CONVERT FILESPEC IN A TO SIXBIT ON FXP
	PUSHJ P,DMRGF		;MERGE WITH DEFAULTS
	POP FXP,PURFN2		;UNSTACK ARGS INTO PROPER SPOT
	POP FXP,PURFN1
	POP FXP,PURSNM
	POP FXP,PURDEV
]	;END IFN ITS
SUSP0C:	POP P,A			;POP FIRST ARGUMENT
	SKIPN A			;FIRST ARG NIL?
	 AOSA (FLP)		;YES, NO VALRET STRING
	  PUSHJ P,VALSTR	;NO, PROCESS IT ONTO FXP
	SKIPA
SUSP0:	 PUSH FXP,R70		;ZERO WORD MEANS VALRET STRING
	SETZ A,
	MOVEI T,LCHNTB
SUSP11:	SOJE T,SUSP12
	SKIPE B,CHNTB(T)
	 CAMN B,V%TYI
	  JRST SUSP11
	CAMN B,V%TYO
	 JRST SUSP11
	MOVE TT,TTSAR(B)	;IF FILE IS CLOSED THEN IGNORE IT
	TLNN TT,TTS.CL
	 PUSHJ P,XCONS
	JRST SUSP11
SUSP12:	JUMPN A,SUSPE
	HRRZ A,V%TYI		;CLOSE THE TTYS LAST, SO THEY WONT CAUSE
	MOVE TT,TTSAR(A)	;SPURIOUS "CANT SUSPEND -I/O IN PROGRESS"
	TLNN TT,TTS.CL
	 PUSHJ P,$CLOSE
	HRRZ A,V%TYO
	MOVE TT,TTSAR(A)
	TLNN TT,TTS.CL
	 PUSHJ P,$CLOSE
SUSP1:	HRROS NOQUIT
	MOVEM NIL,GCNASV+1
	MOVE T,[FREEAC,,GCNASV+2]
	BLT T,GCNASV+2+17-FREEAC
	SETOM NOPFLS
IFN ITS*USELESS,[
	MOVE T,IMASK
	TRNN T,%PIMAR
	 JRST SUSP14
	.SUSET [.RMARA,,SAVMAR]
	.SUSET [.SMARA,,R70]
SUSP14:
]		;END OF IFN ITS*USELESS


IFN ITS\D20,[
IT$	SETOM SAWSP		;ITS ALWAYS WANTS TO DO A PMAP FROM FILE
	MOVEI T,FLSSTARTUP
	EXCH T,LISPSW
	MOVEM T,GCNASV
20$	HRRZ T,ENTVEC		;SET THE "CONTINUE" ADDRESS TO START-UP
20$	HRRM T,ENTVEC+1
	SKIPE SUSFLS		;IF FLUSHING PURE PAGES PROCESS VALRET THEN
	 JRST FLSLSP
FLSNOT:	MOVEI T,SUSP3		;FROM HERE ON IN START AT SUSP3 DIRECTLY
	MOVEM T,LISPSW
	PUSHJ P,PDUMPL		;PURE DUMP LISP IF APPROPRIATE
	SKIPE (FLP)		;NIL JCL?
	 JRST SUSCON		;YES, CONTINUE ON AND RETURN T
	SKIPN 1,(FXP)		;ZERO WORD MEANS NO VALRET STRING
	 JRST SUSP24
IT$	PUSHJ P,RETVAL
20$	HRROI 1,1(1)
	JRST SUSP25
]	;END OF IFN ITS\D20

IFN D10,[
	HRRZ T,.JBSA"
	HRL T,.JBREN"
	MOVEM T,GCNASV
	MOVE T,.JBREL		;GET HIGHEST ADR WE NEED TO SAVE
	HRLM T,.JBSA		;AND STORE IN CORRECT PLACES SO MONITOR KNOWS
	MOVEM T,.JBFF
	MOVEI T,SUSP3
HS%	HRRM T,.JBSA
HS$	HRRM T,RETHGH
	SKIPE (FLP)		;NIL JCL?
	 JRST SUSCON		;YES, CONTINUE AND RETURN T
	SKIPN (FXP)
	 JRST SUSP24
SA$	PUSHJ P,RETVAL		;PTLOAD VALRET STRING FOR SAIL
SA$	SETZM VEJOBNUM
	JRST SUSP25
]		;END OF IFN D10

SUSP24: MOVE T,FXP
	POPI T,1
	MOVEM T,(FXP)
10$	MOVEI TT,
20$	HRROI 1,FLSPA1
IT$	MOVEI TT,FLSPA1
SUSP25:
IFN ITS,[
	.VALUE (TT)		;PRINT SUSPENSION MESSAGE 
	JRST SUSCON
]	;END OF IFN ITS
IFN D20,[
	PSOUT
	HALTF
]	;END OF IFN D20
IFN D10,[
	OUTSTR (TT)
    HS$	JRST KILHGH
    IFE HISEGMENT,[
	IFN SAIL,[
		MOVEI A,FAKDDT		;FOO, HOW MANY WAYS CAN SAIL LOSE?
		SKIPN .JBDDT		; JOBDDT MUST BE NON-ZERO TO SAVE!
		 SETDDT A,		; ELSE MAY FAIL TO SAVE ENTIRE LOSEG
	]	    ;END IFN SAIL
	EXIT 1,
    ]	    ;END IFE HISEGMENT
]	;END OF IFN D10


SUBTTL	HIGH SEGMENT SAVE ROUTINE

IFN D10,[

;;; THE RELEVANT FILE NAMES ARE IN SGADEV, SGAPPN, SGAEXT.
;;; THE MAIN FILE NAME IS PASSED THROUGH T, AND STORED INTO
;;; SGANAM ON SUCCESS.  SKIP RETURN ON SUCCESS.

IFN HISEGMENT,[
SAVHGH:	LOCKI			;LOCK OUT INTERRUPTS AROUND USE OF TEMP CHANNEL
	MOVE F,SGANAM
IFN SAIL,[
	SKIPL .JBHRL		;IS HISEG CURRENTLY WRITE-PROTECTED?
	 JRST SAPWIN		;NO, MUST PREVIOUSLY HAVE UNPURIFIED IT
	SKIPN PSGNAM
	 JRST FASLUH
	MOVEI T,.IODMP
	MOVE TT,PSGDEV
	SETZ D,
	OPEN TMPC,T		;OPEN UP .SHR FILE DEVICE IN DUMP MODE
	 JRST FASLUH
	MOVE T,PSGNAM
	MOVE TT,PSGEXT
	SETZ D,
	MOVE R,PSGPPN
	LOOKUP TMPC,T
	 JRST FASLUR
	MOVS T,R
	MOVNS T			;T GETS LENGTH OF .SHR FILE
	ADDI T,HSGORG-1
	PUSHJ P,LDRIHS		;GO READ IN HIGH SEGMENT (FROM WITHIN LOSEG!)
	RELEASE TMPC,		;FLUSH TEMP CHANNEL
	MOVE T,D10NAM		;USE D10NAM AS HISEG NAME TO FOIL SHARING
	LSH T,-6		;AS LONG AS WE'RE BEING RANDOM...
	SETNM2 T,
	JFCL
	MOVE F,SGANAM	;RESTORE MAIN FILE NAME
SAPWIN: 
]	;END OF IFN SAIL
	SETZM SGANAM
	MOVE R,SGADEV
IFN SAIL,[
;;;SAVE VALIDATION WORDS IN HISEG, HOPE THAT HISEG WRITEABLE
	MOVEM R,PSGDEV
	MOVE D,SGAEXT
	MOVEM D,PSGEXT
	MOVE D,SGAPPN
	MOVEM D,PSGPPN
]	;END OF IFN SAIL
	MOVEI D,.IODMP
	MOVE T,F		;SGANAM WAS SAVED IN F
	SETZ F,
	OPEN TMPC,D
	 UNLKPOPJ
	MOVE TT,SGAEXT
	SETZ D,
	MOVE R,SGAPPN
SA$	MOVEM T,PSGNAM
	ENTER TMPC,T
	 UNLKPOPJ
	MOVEI TT,HSGORG-1	;MAKE UP IOWD
	SUB TT,.JBHRL
	MOVSS TT
	HRRI TT,HSGORG-1
	SETZ D,
	OUT TMPC,TT		;OUTPUT THE HISEG
	 CAIA
	  UNLKPOPJ
	CLOSE TMPC,		;FLUSH TEMP CHANNEL
	RELEASE TMPC,
	MOVEM T,SGANAM		;WE CAREFULLY DO NOT STORE SGANAM UNTIL
	UNLOCKI			; WE HAVE CLEARLY WON (MORE OR LESS)
	JRST POPJ1

]	;END IFN HISEGMENT
]		;END OF IFN D10


SUBTTL	ARGS FUNCTION

ARGS:	JSP TT,LWNACK		;LSUBR (1 . 2) - USES A,B,C,T,TT,D,R,F
	LA12,,QARGS
	JSP R,PDLA2(T)		;SPREAD ARGS
ARGS1:	SKOTT A,SY
	JRST ARGS0		;FIRST ARG MUST BE SYMBOL
	HLRZ F,(A)
ARGS1A:	AOJL T,ARGS3		;TWO ARGS
	HLRZ R,1(F)		;JUST WANT TO GET PRESENT ARGS PROP
ARGSCU:	JUMPE R,FALSE		;ARGS CONS-UP
	IDIVI R,1000
	SKIPN B,F
	JRST ARGSC1
	MOVEI TT,-1(F)
	JSP T,FIX1A
	MOVEI B,(A)
ARGSC1:	SKIPN A,R
	JRST CONS
	MOVEI TT,(R)
	CAIE TT,777
	SUBI TT,1
	JSP T,FIX1A
	JRST CONS

ARGS3:	JUMPE A,CPOPJ
	JUMPN B,ARGS5
	HLRZ R,1(F)		;JUST WANT TO FLUSH ARGS PROP
	JUMPE R,FALSE
	SETZ R,
	PUSH P,A
	JSP D,ARGCLB
	SUB P,R70+1
	JRST TRUE

ARGS5:	PUSH P,A
	SETZB TT,R
	HLRZ C,(B)		;MUMBLE MUMBLE - MUST FIGURE
	JUMPE C,ARGS6		; OUT WHATEVER WE WERE HANDED
	JSP T,FXNV3
	CAIE R,777
	ADDI R,1
	LSH R,11
ARGS6:	HRRZ A,(B)
	JSP T,FXNV1
	CAIE TT,777
	ADDI TT,1
	ADDI R,(TT)
	HLRZ TT,1(F)		;LOOK AT ARGS PROP ALREADY THERE
	CAIN TT,(R)		;IF ALREADY WHAT WE WANT, JUST EXIT,
	JRST POPAJ		; THEREBY AVOIDING A PURE PAGE TRAP
	MOVEI D,POPAJ		;FAKE OUT A JSP D,
ARGCLB:	MOVEI B,(F)		;CLOBBER IN AN ARGS PROPERTY
ARGCL3:
PURTRAP ARGCL7,B,	HRLM R,1(B)		;MAY HAVE TO FUSS ABOUT PURE PAGE TRAP
	JRST (D)

ARGS0:	MOVEI F,$$$NIL
	JUMPE A,ARGS1A
	WTA [ NON-SYMBOL - ARGS!]
	JRST ARGS1

SUBTTL	EVALFRAME FUNCTION, GTPDLP, AND FRETURN

EVALFRAME:
	SKIPA R,[GTPDLP]	;THIS ENTRY CAUSES INTERPRETATION OF ARG AS PDLPOINTER
FRM2A:	MOVEI R,GTPDL2	;THIS ENTRY, TO ALLOW CONTINUING FROM WHERE D CURRENTLY IS
	JSP R,(R)
	   $EVALFRAME	;GET EVALFRAME OR APPLYFRAME JUST PRIOR TO
	   $APPLYFRAME	; POINT ON PDL MARKED BY ARG
	JRST FALSE
FRM3:	SUB D,R70+1	;DEFINE A FRAME POINTER TO BE JUST BELOW THE EVALFRAME MARKER
	HRRZ TT,(D)
	JUMPN F,FRM3A		;F IS INDEX OF WHICH KIND OF FRAME
	MOVEI T,(TT)
	LSH T,-SEGLOG
	SKIPL ST(T)
	JRST FRM4A
	HLRZ TT,(TT)
FRM3A:	CAIN TT,QEVALFRAME	;DONT ALLOW THE CALL TO EVALFRAME
	JRST FRM2B		; ITSELF TO BE OUTPUT
FRM4A:	PUSH P,(D)
FRM4:			;ERRFRAME COMES HERE
	HLRO TT,(D)	;ONE LEFT HALF'S AS GOOD AS ANOTHER...
	JSP T,FIX1A	;MAKE UP PREVIOUS SPECIAL PDL POINTER
	PUSHJ P,ACONS
	EXCH B,(P)
	MOVE TT,1(D)
	CAME TT,[$APPLYFRAME]
	JRST FRM8
	PUSH P,A
	PUSH P,B
	MOVE T,-2(D)  .SEE $APPLYFRAME 	;BECAUSE THERE IS A DISCUSSION
	JUMPL T,FRM5			;  OF THE FRAME FORMAT THERE
	MOVEI A,(T)
	TLCN T,-1			;THINK ABOUT THIS WHEN YOU LOOK!
	JRST FRM7
	HLRS T				;SUBTLE WAY TO GET NEGATION
	ADDI T,(D)
FRM5:	SETZ A,
FRM5A:	HRRZ B,(T)
	PUSHJ P,XCONS
	AOBJN T,FRM5A
	PUSHJ P,NREVERSE
FRM7:	PUSHJ P,ACONS
	POP P,B
	PUSHJ P,XCONS
	MOVEI B,(A)
	POP P,A
FRM8:	PUSHJ P,XCONS
	MOVE B,A	;OUTPUT 4-LIST:   "EVAL" OR "APPLY" OR "ERR" [A SYMBOL]
	HRROI TT,(D)	;  FRAME (REGPDL) POINTER [A FIXNUM]
	JSP T,FIX1A	;  <FORM> [EVAL] OR (<FN> <ARGS>) [APPLY]
	PUSHJ P,CONS	;	OR <MSG-FORM> [ERR]
	MOVE TT,1(D)	;  ALIST (SPECPDL) POINTER [A FIXNUM]
	MOVEI B,QOEVAL
	CAMN TT,[$APPLYFRAME]
	MOVEI B,QAPPLY
	CAMN TT,[$ERRFRAME]
	MOVEI B,QERR
	PUSHJ P,XCONS
	JRST POPBJ

FRM2B:	TLNE R,1
	ADD D,R70+2	;WHEN SEARCHING FORWARD, SKIP OVER CALL
	JRST FRM2A	;TO EVALFRAME





GTPDLP:			;CALLED BY JSP R,GTPDLP; RETURNS PDL PTR IN D
	MOVEI D,(P)
	JUMPE A,GTPDL2	;ARG=NIL => START SEARCH FROM CURRENT PDL POS
	JSP T,FXNV1	;NOTE: EVALFRAME LOOKS AT BIT 3.1 OF R
	JUMPL TT,GTPDL5	;BIT 3.1 OF R = 0 WHEN SEARCHING BACK THE PDL
	TLO R,1		;BIT 3.1 OF R = 1 WHEN SEARCHING FORWARD
	MOVNS TT	;WANT TO SKIP OVER THE FRAME MARKER WHEN
	SKIPN TT	; SEARCHING FORWARD (SINCE A PDLPOINTER WILL
	SKIPA TT,C2	; BE POINTING TO ONE BELOW A FRAME MARKER)
	ADD TT,R70+2
GTPDL5:	TLZ TT,-1
	HRRZ T,C2
	CAIGE TT,(T)
	JRST GTPDL1
	MOVEI T,(P)
	SUBI T,(TT)
	JUMPLE T,GTPDL1
	MOVEI T,(TT)
	CAIL T,(P)
	MOVE TT,P
	HRROI D,(TT)
GTPDL2:	MOVE TT,(R)	;KEY ON WHICH TO SEARCH
	JUMPE TT,2(R)	;MATCH 0 => NO SEARCH, JUST GIVE OUT PDL PTR
	MOVE F,1(R)	;WELL, IT'S POSSIBLE TO SEARCH FOR TWO THINGS
	TLNE R,1
	JRST GTPDL4
	HRRZ T,C2
GTPDL3:	CAIL T,(D)	;A BACK SEARCH
	JRST 2(R)	;SEARCHED-AND-FAILED EXIT
	CAMN TT,(D)
	JRST GTPX0
	CAMN F,(D)
	JRST GTPX1
	SOJA D,GTPDL3

GTPDL4:	MOVEI T,(P)
GTP4A:	CAMN TT,(D)
	JRST GTPX0
	CAMN F,(D)
	JRST GTPX1
	CAIG T,(D)
	JRST 2(R)	;FAILURE
	AOJA D,GTP4A


GTPX0:	TDZA F,F
GTPX1:	MOVEI F,1
	JRST 3(R)

FRETURN:  TDZA C,C		;LH OF C REMEMBERS WHICH ENTRY
FRETRY:	 MOVSI C,TRUTH
	HRR C,B
	JSP R,GTPDLP
	 0
	 JFCL
	MOVEI F,(D)
	MOVE TT,[$EVALFRAME]
	CAMN TT,1(F)
	 JRST FRETR1
	MOVE TT,[$APPLYFRAME]
	CAME TT,1(F)
	 JRST FRERR
FRETR1:	MOVEI D,(F)
	SUBI D,(P)
	HRLI D,(D)
	HRRI D,(F)
	MOVE TT,[$UIFRAME]
	CAME TT,(D)	;SEARCH FOR A USER INTERRUPT FRAME
	 AOBJN D,.-1
	CAMN TT,(D)
	 JSP TT,UIBRK
FRP1:	SKIPE T,PA4	;BREAK UP A DOMINEERING PROG
	 CAIL F,(T)		;[WHICH BREAKS UP INTERIOR ERRSETS AND CATCHES]
	  JRST FRP2
	MOVEI TT,FRP1-1		;FAKE OUT RETURN BY INSERTING A RETURN-ADDRESS
	MOVEM TT,-LPRP+1(T)	;OF FRP1 ON THE PDL
	JRST RETURN

FRP2:	SKIPE B,ERRTN		;BREAK UP A DOMINEERING ERRSET
FRP2A:   CAIL F,(B)
	  JRST FRP4
	MOVEI T,FRP1
	MOVEI TT,FRP1
	JRST BKRST0

FRP4:	SKIPE B,CATRTN		;BREAK UP A CATCH
	 CAIL F,(B)
	  JRST FRP3
	MOVEI T,FRP1		;IN CASE OF UNWIND-PROTECT
	MOVEI TT,FRP1
	JRST BKRST0

FRP3:	SKIPN B,EOFRTN	;BREAK OUT OF ANY E-O-F SET READS
	 JRST FRP3QA
	CAIGE F,(B)
	 JRST FRP2A
FRP3QA:	MOVEI A,(C)
IFE PAGING,[
	ADDI F,1		;FIX UP PDL POINTERS
	SUB F,C2
	HRLS F
	ADD F,C2
	MOVE P,F
	HRRZ F,-2(P)
	SUB F,FXC2
	HRLS F
	ADD F,FXC2
	MOVE FXP,F
	HLRZ F,-2(P)
	SUB F,FLC2
	HRLS F
	ADD F,FLC2
	MOVE FLP,F
]		;END OF IFE PAGING
IFN PAGING,[			;IN A PAGED SYSTEM, THE PDLOV HANDLER
	HRROI P,1(F)		; WILL FIX UP THE LHS OF THE PDL PTRS
	HLRO FLP,-2(P)
	HRRO FXP,-2(P)
IFN PDLBUG,[
	PFIXPDL TT
	FLPFIXPDL TT
	FXPFIXPDL TT
]	;END OF IFN PDLBUG
]		;END OF IFN PAGING
	HLRZ TT,-1(P)
	TLNN C,-1		;FOR "FRETURN" JUST UNBIND TO MARKED
	 JRST UBD		;  POINT, AND POP FRAME
	PUSHJ P,UBD
	HLRZ TT,(A)		;BUT DO MORE FOR "FRETRY", AFTER UBD
	JSP T,%CADDR
	POPI P,L$EVALFRAME	;GET RID OF BASIC EVALFRAME
	CAIE TT,QAPPLY
	  JRST EVAL
	HRRZ B,(A)
	HLRZ B,(B)
	HLRZ A,(A)
	HLRE T,(P)		;GET RID OF ARGS ON APPLYFRAME 
	SKIPG T			;FIGURE OUT LENGTH OF ARGS PART
	MOVEI T,1
	HRLI T,(T)
	SUB P,T
	JRST .APPLY

SUBTTL	GETCHAR, GETCHARN, AND INTERNAL STRING FUNCTIONS

$GETCHARN:	PUSH P,CFIX1		;SUBR 2 - NCALLABLE
	SKIPA F,[ZPOPJ,,CPOPJ]
GETCHAR:	MOVE F,[FALSE,,RDCH2]	;SUBR 2
	SKIPE V.RSET
	 JRST GETCH8
	SKIPG D,(B)
	 JRST GETCH4
	PUSHJ P,PNGT0
GETCH1:	SOJL D,(F)
	IDIVI D,BYTSWD	;(Q,R) QUOTIENT,REMAINDER IN D,R
	SOJL D,GETCH3
GETCH2:	HRRZ A,(A)	;CDR BY Q WORDS
	SOJGE D,GETCH2	;RECALL THAT (CDR NIL) = NIL
	JUMPE A,GETCH4
GETCH3:	HLRZ TT,(A)
	LDB TT,BPARS(R)
	JUMPN TT,(F)
GETCH4:	MOVS F,F
	JRST (F)

GETCH8:	JSP T,FXNV2
	PUSHJ P,PNGET
	JUMPG D,GETCH1
	JRST GETCH4

;Table of byte-ptrs, into "array" by indirecting thru sar of STR/:ARRAY 
BPAR:	REPEAT 5, @<<35-7*.RPCNT>_36>+07_30 TTSAR+STR%AR
;Table of byte-ptrs for absolute address, index'd by TT
BPARS:	REPEAT 5, <<35-7*.RPCNT>_36>+07_30 (TT)


%ISC.N:	PUSH P,CFIX1			;+INTERNAL-CHAR-N
   BAKPRO
	MOVE D,(B)			;INDEX OF DESIGNATED CH
	IDIVI D,5
	STRWDNO TT,A			;WORD-INDEX-IN-ARRAY OF STRING BASE
	 ADDI R,BPARS-BPAR 		;USE OTHER BP TABLE IF PURE STRING
	ADDI TT,(D)			;WORD-INDEX-IN-STRING OF REQUESTED CHAR
	LDB TT,BPAR(R)			;IMPURE STRINGS HAVE WORD-INDEX INTO
    NOPRO
	POPJ P,				; STR/:STRING-ARRAY

%ISR.N:	MOVE F,(C)			;+INTERNAL-RPLACHAR-N
   BAKPRO
	MOVE D,(B)			;INDEX OF DESIGNATED CH
	IDIVI D,5
	STRWDNO TT,A			;WORD-INDEX-IN-ARRAY OF STRING BASE
	 ADDI R,BPARS-BPAR 		;USE OTHER BP TABLE IF PURE STRING
	ADDI TT,(D)			;WORD-INDEX-IN-STRING OF DESIGNATED CH
	DPB F,BPAR(R)
    NOPRO
	POPJ P,

%ISW.N:	PUSH P,CFIX1			;+INTERNAL-STRING-WORD-N
   BAKPRO
	STRWDNO TT,A			;WORD-INDEX-IN-ARRAY OF STRING BASE
	 JRST .+4
	  ADD TT,(B)			;WORD-INDEX-IN-STRING OF REQUESTED WORD
	  MOVE TT,@TTSAR+STR%AR
	  POPJ P,
	ADD TT,(B)
	MOVE TT,(TT)
    NOPRO
	POPJ P,	

%ISSW.N:	MOVE R,(C)		;+INTERNAL-SET-STRING-WORD-N
   BAKPRO
	STRWDNO TT,A			;WORD-INDEX-IN-ARRAY OF STRING BASE
	 JRST .+4
	  ADD TT,(B)			;WORD-INDEX-IN-STRING OF REQUESTED WORD
	  MOVEM R,@TTSAR+STR%AR
	  POPJ P,
	ADD TT,(B)
	MOVEM R,(TT)
    NOPRO
	POPJ P,



SUBTTL SUBLIS

SUBLIS:	JUMPN A,SUBLSA		;NULL SUBSTITUTION LIST?
	MOVE A,B		;YES, RETURN SECOND ARG
	POPJ P,
SUBLSA:	PUSH P,A		;USES ONLY A,B,T,TT,D,R
	PUSH P,B
	MOVE D,A
	HLLOS NOQUIT		;MOBY DELAYED QUIT FEATURE
SUBL1:	JUMPE D,SUBL2
	HLRZ T,(D)		;A SUBSTITUTION LIST IS LIKE
	HLRZ B,(T)		;((U1 . S1) (U2 . S2) . . .)
	SKOTT B,SY
	JRST SUBLOSE
SUBL1B:	HRRZ A,(B)		;SEXPRESSION S IS SUBSTITUTED FOR ATOM U
	HLRZ A,(A)
	CAIN A,QSUBLIS
	JRST SUBL1A
	HRRZ A,(T)
	MOVEM B,T
	HRRZ B,(B)
	PUSHJ P,CONS
	MOVEI B,QSUBLIS		;PUT "SUBLIS" PROPERTY ON THOSE ATOMS U IN THE
	PUSHJ P,XCONS		;SUBSTITUTION LIST ((U1 . V1) . . . (UN . VN))
	HRRM A,(T)
SUBL1A:	HRRZ D,(D)
	MOVE T,INTFLG
	AOJGE T,SUBL1	;0=> NO INT, -1=> USER INT, -2,-3=> QUIT
	MOVE R,D
	JRST SUBL3Q

SUBLOSE:	JUMPE B,SUBL3Z
	MOVEI A,(B)
	MOVEI R,(D)
	MOVEI T,[LER3 [SIXBIT \NON-ATOMIC ITEM - SUBLIS!\]]
	MOVEM T,-2(P)
SUBL3Q:	SUB P,R70+1
	JRST SUBL3A
SUBL3Z:	MOVEI B,NILPROPS
	JRST SUBL1B

SUBL2:	POP P,A
	PUSHJ P,SBL1
	JFCL
	MOVEI R,0	;REMOVE ALL "SUBLIS" PROPERTIES
SUBL3A:	MOVE TT,(P)
SUBL3:	CAIN R,(TT)	;REMOVE "SUBLIS" PROPERTY
	JRST SUBL4
	HLRZ T,(TT)
	HLRZ T,(T)
	JUMPN T,.+2
	MOVEI T,NILPROPS
	HRRZ B,(T)
	MOVE B,(B)
	HLRZ D,B
	HRRZ B,(B)
	CAIN D,QSUBLIS
	HRRM B,(T)
	HRRZ TT,(TT)
	JRST SUBL3
SUBL4:	SUB P,R70+1
	JRST CZECHI

SBL1:	SKOTT A,LS	;TRACE THROUGH STRUCTURE IN (A) SUBSTITUTING
	JRST SBL2	;(GET 'U 'SUBLIS) FOR U WHEREVER IT IS NON-NIL
	PUSH P,A
	HLRZ A,(A)
	PUSHJ P,SBL1
	JRST SBL4
	EXCH A,(P)
	HRRZ A,(A)
	PUSHJ P,SBL1
	JFCL
	HRRZ B,(P)
SBL5:	SUB P,R70+1
	PUSHJ P,XCONS
	JRST POPJ1
SBL4:	HRRZ A,@(P)
	PUSHJ P,SBL1
	JRST POPAJ
	HLRZ B,@(P)
	JRST SBL5
SBL2:	TLNN TT,SY
	JRST SBL2B
	HRRZ B,(A)
SBL2A:	HLRZ T,(B)
	CAIE T,QSUBLIS
	POPJ P,
	HRRZ A,(B)
	HLRZ A,(A)
	JRST POPJ1

SBL2B:	JUMPN A,CPOPJ
	HRRZ B,NILPROPS
	JRST SBL2A

SUBTTL	SAMEPNAMEP AND ALPHALESSP

SAMEPNAMEP:	TDZA D,D	;USES ONLY A,B,T,TT,D 
ALPHALESSP:	MOVE D,VT.ITY	;MUST PRESERVE C,AR1,AR2A,R,F  (see SORT)
	SKOTT A,SY
	 JUMPN A,ALPL4
	SKOTT B,SY
	 JUMPN B,ALPL5
ALPL0:	PUSH P,B
	PUSHJ P,PNGET
	EXCH A,(P)
	PUSHJ P,PNGET
	POP P,B			;FROM NOW ON, A HAS PNAME OF 2ND ARG, B OF 1ST
	JRST ALPLP1
ALPL3:	HRRZ A,(A)
	HRRZ B,(B)
ALPLP1:	JUMPE B,ALPL2
	JUMPE A,FALSE		;ON SAMEPN, LOSE IF 2ND ARG RUNS OUT BEFORE 1ST
	HLRZ T,(A)		;ON ALPHAL, LOSE IF 2ND ARG IS SHORTER THAN 1ST
	MOVE T,(T)
	HLRZ TT,(B)		;FOR SAMEPN, WILL RETURN NIL IF
				;TWO ARE UNEQUAL IN SOME PLACE
	CAMN T,(TT)		;NO INFO IF CORRESPONDING PLACES ARE EQUAL
	 JRST ALPL3
	JUMPE D,FALSE		;BUT NOT EQUAL IN SAMENAMEP MEANS LOSE
	MOVE TT,(TT)		;MUST DO SOME HAIR FOR THE ALPHALESSP
	LSHC T,-1		; COMPARE TO WIN, SINCE PNAME WORDS ARE
	CAMG T,TT		; LOGICAL DATA, NOT ARITHMETIC
	 JRST FALSE		;2ND ARG STRICTLY LESS THAN FIRST
	JRST TRUE		;2ND ARG STRICTLY GREATER THAN FIRST

ALPL2:	EXCH A,D
	JUMPE D,NOT		;IF ALPHAL, WIN WHEN A NON-NUL
				;[FOR 1ST ARG IS PROPER SUBSTRING OF 2ND]
	POPJ P,			;IF SAMEPN, WIN WHEN A NUL
				;[FOR CORRESPONDENTS HAVE BEEN EQUAL ALL ALONG]


ALPL5:	EXCH A,B		;FIRST ARG SYMBOL, SECOND ARG ISN'T.
	PUSHJ P,ALPL6
	 JRST [EXCH A,B
	      JRST ALPL0]
	SKIPE D
	 MOVEI D,QGREATERP
	JRST ALPL7

ALPL4:	PUSHJ P,ALPL6
	 JRST ALPL0
ALPL7:	PUSHJ P,[PUSH P,A
		 SKIPN D
		  MOVEI D,QSAMEPNAMEP
		 PUSH P,D
		 PUSH P,B
		 MOVNI T,3
		 XCT SENDI		   ;Send the object a message
		 ]
ALPL5X:	PUSHJ FXP,RST5M1
	JRST POP1J

;; CHECKS TO SEE IF ACC A HOLDS A USER HUNK.  SKIPS IF SO.
ALPL6:	SKIPE USRHNK		;IF USERHUNKS NOT ENABLED, OR IF THIS NON-SYM
	 TLNN TT,HNK		; ARGUMENT ISN'T A HUNK, THEN LET PNGET BARF
	  POPJ P,		; ABOUT NOT GETTING A SYMBOL
	PUSHJ P,USRHNP		;IS IT A USER-HUNK?
	JUMPE T,CPOPJ		;NOPE, SO EXIT WITH NO SKIP
	POP P,T
	PUSHJ FXP,SAV5		;YES, SO SKIP AND LEAVE ACC'S STACKD UP
	JRST 1(T)



SYSP:	MOVEI B,TRUTH		;SUBR 1 - DETERMINE WHETHER SYMBOL HAS
SYSP3:
10%	CAIGE A,BEGFUN		; A "SYSTEM" SUBR PROPERTY
10$	CAIL A,ENDFUN
	 JRST FALSE
10%	CAIG A,ENDFUN
10$	CAIL A,BEGFUN
	 JRST BRETJ
	CAIGE A,BSYSAR		; ... OR MAYBE A SYSTEM ARRAY PROPERTY
	 JRST SYSP6
	CAIGE A,ESYSAR
	 JRST BRETJ		;RETURNS T FOR SUBR/SAR POINTERS
	CAIE B,QAUTOLOAD
	 JRST SYSP6
	CAIL A,BSYSAP
	 CAIL A,ESYSAP
	  JRST FALSE
	JRST BRETJ

SYSP6:	JSP T,SPATOM		;RETURNS FALSE FOR NON-SYMBOLS
	 JRST FALSE
	PUSH P,A		;TRY THE AUTOLOAD PROPERTY FIRST
	MOVEI B,QAUTOLOAD
	PUSHJ P,$GET
	JUMPN A,SYSPZ
SYSPZ1:	POP P,A
	MOVEI B,ASBRL
	PUSHJ P,GETL1
	JUMPE A,CPOPJ		;RETURNS FALSE FOR SYMBOLS WITH NO FN PROPS
	HLRZ B,(A)		;RETURNS NAME OF PROPERTY OF ONE IS FOUND,
	JSP T,%CADR
	JRST SYSP3		; AND THE PROPERTY VALUE PASSES THE SYSP TEST

SYSPZ:	CAIL A,BSYSAP
	 CAIL A,ESYSAP
	  JRST SYSPZ1		;AUTOLOAD PROPERTY NOT SYSTEM'S - GO ON
	POP P,A			;ELSE FLUSH STACK OF A
	MOVEI A,QAUTOLOAD	;AND RETURN AUTOLOAD
	POPJ P,


GCTWA:	JUMPE A,GCTWI
	HLRZ A,(A)
	PUSHJ P,NOTNOT
	MOVEM A,VGCTWA
	JRST GCTWX
GCTWI:	SETOM IRMVF
GCTWX:	MOVEI A,IN0
	SKIPGE IRMVF
	ADDI A,1
	SKIPE VGCTWA
	ADDI A,10
	POPJ P,

SUBTTL	COPYSYMBOL FUNCTION

COPYSYMBOL:
	JSP T,SPATOM
	 JSP T,PNGE	
CPSY3:	JUMPN B,CPSY0		;IF NON-NIL SECOND ARG COPY PLIST, VC AND ARGS
CPSY:	PUSHJ P,PNGT0		;COPY THE SYMBOL
	JRST SYCONS

CPSY0:	PUSH P,A		;SAVE OLD SYMBOL
	PUSHJ P,CPSY		;GET A NEW COPY
	EXCH A,(P)		;SAVE NEW COPY, GET OLD
	PUSH P,A		;SAVE OLD ON TOP OF STACK
	HRRZ A,(A)		;GET PLIST
	JUMPE A,CPSY1		;IF NO PLIST THEN TRY VALUE CELL
	MOVEI B,NIL		;NOW GET A NEW COPY OF THE PLIST
	PUSHJ FXP,SAV5M3
	PUSHJ P,.APPEND
	PUSHJ FXP,RST5M3
	HRRM A,@-1(P)		;STORE IN NEW SYMBOL
CPSY1:	SKIPN A,(P)
	 JRST CPSY4
	HLRZ A,(A)		;POINTER TO OLD SYMBOL BLOCK
	HLRZ T,1(A)		;ARGS PROPERTY
	JUMPE T,.+3		;IF NONE THEN DON'T HACK
	 HLRZ TT,@-1(P)		; ELSE COPY THE ARGS PROPERTY
	 HRLM T,1(TT)
	HRRZ A,@(A)		;GET CONTENTS OF VALUE CELL
	CAIN A,QUNBOUND		; IF UNBOUND DON'T BOTHER COPYING
	 JRST S1PAJ
CPSY4:	EXCH AR1,-1(P)		;ELSE COPY VC BY DOING A (SET NEW OLD)
	JSP T,.SET
	EXCH AR1,-1(P)
	JRST S1PAJ

SUBTTL	SETSYNTAX AND OTHER READER SYNTAX FUNCTIONS

;ARGS ARE CHAR (AS NUMBER OR ATOM), SYNTAX-CODE, MACRO-OR-TRANSLATION

SETSYNTAX:	SETZ AR1,	;SUBR 3
	MOVEI AR2A,(B)
	JSP T,SPATOM
	JRST RSSYN1
	JSP T,CHNV1
	JSP T,FIX1A
RSSYN1:	CAIN AR2A,QMACRO
	JRST RSSYN2
	CAIE AR2A,QSPLICING
	JRST RSSYN3
	MOVEI AR1,[QSPLICING,,NIL]
RSSYN2:	MOVE B,A
	PUSH P,CTRUE
	PUSH P,AR1
	JRST SSMC43

RSSYN3:	MOVSI AR1,40000		;WAY TO FAKE OUT SSYN0
	MOVEI B,(A)
	JUMPE C,RSSYN5		;SKIP IF NO CHTRAN STUFF
	PUSHJ P,RSSYN4
	HRRZM A,(FXP)
	MOVEI A,(B)		;LOSING RETROFIT FOR NSTST
	MOVEI B,(C)
	PUSHJ P,SSCHTRAN
	SUB FXP,R70+1
RSSYN5:	JUMPE AR2A,TRUE	;XIT IF NO SYNTAX STUFF
	CAIE AR2A,QSINGLE
	JRST RSSYN7
NW%	PUSH FXP,[600500]
NW$	PUSH FXP,[RS.SCS]
	MOVEI C,(FXP)
	JRST RSSYN8
RSSYN7:	MOVE C,AR2A
	PUSHJ P,RSSYN4
	HLRZS (FXP)
RSSYN8:
	MOVEI A,(B)		;LOSING RETROFIT FOR NSTAT
	MOVEI B,(C)
	PUSHJ P,SSSYNTAX
	SUB FXP,R70+1
CTRUE:	JRST TRUE

RSSYN4:	PUSH FXP,R70
	MOVEI A,(C)
	JSP T,SPATOM
	POPJ P,
	MOVEI C,(B)	;SAVE B
	JSP T,CHNV1
	MOVEI A,(TT)
	MOVEI B,(C)	;RESTORE B
	MOVEI C,(FXP)	;SET C TO BE FIXNUM ON TOP OF PDL
	JSP T,RSXST
	MOVE TT,@RSXTB
	MOVEM TT,(FXP)
	POPJ P,

SSCHTRAN:
NW%	SKIPA F,[HRRM R,(TT)]
NW$	SKIPA F,[DPB R,[001100+TT,,]]
SSSYNTAX:
NW%	MOVSI F,(HRLM R,(TT))
NW$	MOVE F,[LDB R,[113300+TT,,]]
	PUSH P,[SPROG3]
	MOVSI AR1,40000		;LOSING CROCK
SSSYN1:
	MOVEI C,(B)	;LOSING CROCK
	MOVEI B,(A)
	PUSHJ P,GRCTI		;GET INDEX FOR RCT INTO D
	TLNE AR1,40000		;40000 BIT SAYS EVAL 3RD ARG
	JSP T,FXNV3
	JSP T,SMCR2		;LOCK AND SETUP RCT ARRAY PTR INTO TT
	ADDI TT,(D)
	XCT F		;MAY SKIP (FOR (STATUS CHTRAN))
	UNLKPOPJ	;MUST BE ONLY ONE INSTRUCTION.
NW%	TLNE TT,4000	;SKIP UNLESS MACRO CHAR
NW$	TLNE TT,(RS.MAC);SKIP UNLESS MACRO CHAR
	MOVEI TT,(D)	;USE CHARACTER AS ITS OWN CHTRAN
	TLZ TT,-1
	UNLKPOPJ

GRCTI:	JSP T,FXNV2	;GET READTABLE INDEX
SA%	CAIGE D,NASCII
SA$	CAIGE D,1010
	JUMPGE D,CPOPJ
	JRST GRCTIE

SMACRO:
	MOVEI B,(A)
	PUSHJ P,GRCTI
	JSP T,SMCR2
	ADD TT,D
SMCR1:	MOVEI A,NIL
	MOVE C,(TT)
	UNLOCKI
NW%	TLNN C,4000
NW$	TLNN C,(RS.MAC)
	POPJ P,			;EXIT WITH NIL IF NO MACRO CHAR
NW%	TLNE C,40
NW$	TRNE C,RS.ALT
	MOVEI A,QSPLICING	;SPLICING TYPE
	PUSHJ P,NCONS
NW%	MOVEI B,(C)
NW$	PUSH P, A
NW$	PUSHJ P, GETMAC
NW$	HRRZ B, (A)		;CDR OF ASSQ IS FUNCTION
NW$	POP P, A
	PUSHJ P,XCONS
	POPJ P,

IFN NEWRD,[
;;;ROUTINE TO GET MACRO ENTRY. CHAR IN D.
;;;	CLOBBERS A, B, TT, RETURNS (CHAR . FCN) IN A
;;;	RSXST MUST HAVE BEEN DONE
GETMAC:	MOVEI A, 206		;GET FCN LIST FROM READTABLE
	HRRZ B, @RSXTB		;..
	MOVE A, D		;CHARACTER
	PUSHJ P, IASSQF		;DEPENDS ON D,R,F BEING PRESERVED
	JUMPE A, [LERR [SIXBIT/MACRO CHARACTER VANISHED#!!/]]
	POPJ P,
]		;END OF IFN NEWRD

SSMACRO:
	CAME T,XC-3		;CROCK TO GET NSTAT UP FAST
	 PUSH P,R70
	POP P,A
	POP P,C
	POP P,B
	SKIPE A
	 PUSHJ P,ACONS
	PUSH P,A
SSMC43:	PUSHJ P,GRCTI
	JSP T,SMCR2
	ADD TT,D
	HRRZM TT,RM4
	JUMPE C,SSM1
NW%	HRLI C,404500
NW$	MOVE C,[RS.CMS]
	SKIPE A,(P)
	JRST SSM3
SSM4:
	EXCH C,@RM4
NW%	HRRZ A,C
NW%	TLNE C,4000
NW%	PUSHJ P,SSGCREL	;CLOBBERS C
IFN NEWRD,[
	TLNN C,(RS.MAC)
	JRST SSM4AA
	PUSHJ P, GETMAC
;REMOVE PREVIOUS MACRO FUNCTION FROM ASSQ LIST.
;****	(SETQ MAC-LIST (DELQ A MAC-LIST)) ****
SSM4AA:		;AND NO GCREL CRUFT NECC.
	]
	MOVE C,@RM4
NW%	HRRZ A,C
NW%	TLNE C,4000
NW%	PUSHJ P,SSGCPRO
NW%	HRRM A,@RM4
NW$	DPB D, [001100,,@RM4]	;MACROS MUST HAVE SELF AS CHTRAN
NW$	MOVE B, D	;***SURELY THIS COULD BE A LOT LESS KLUDGEY***
NW$	PUSHJ P, XCONS
NW$	MOVE B, A
NW$	MOVEI A, 206
NW$	MOVE A, @RSXTB
NW$	PUSHJ P, XCONS
NW$	MOVE B, A
NW$	MOVEI A, 206
NW$	MOVEM B, @RSXTB
	SUB P,R70+1
	MOVE TT,RM4
	JRST SMCR1

SSM3:	MOVEI AR1,(B)
	HLRZ A,(A)
	JSP T,CHNV1
	CAIN TT,"S		;SPLICINGP
NW%	TLO C,40
NW$	TRO C,RS.ALT
	MOVEI B,(AR1)
	JRST SSM4

SMCR2:	LOCKI
	JRST RSXST

SSM1:	HRLI D,2
	MOVE C,RCT0(D)
NW%	TLNE C,4000	;WAS IT ORIGINALLY A MACRO CHAR?
NW$	TLNE C,(RS.MAC)
	MOVE C,D
	JRST SSM4





SSGCREL:	TDZA D,D	;MUST HAVE USER INTERRUPTS OFF
SSGCPRO:	MOVEI D,1
	JSP T,SPATOM
	 JRST SSGCP1
	HLRZ T,(A)		;GET SYMBOL BLOCK, FIRST WORD
	MOVE T,(T)
	TLNE T,SY.CCN		;IF SYM NOT PROTECTED BECAUSE OF BEING
	 POPJ P,		; "NEEDED" BY COMPILED CODE, THEN PROLIS-IFY
SSGCP1:	SOVE A B
	HRRZ R,(B)
	CAIGE R,200
	HRL R,VREADTABLE
	HRRI R,IN0(R)
	MOVE B,PROLIS
	JUMPE D,SSGRL1
	PUSHJ P,ASSOC
	JUMPE A,SSPROQ
	HLRZ A,(A)
	MOVEM A,-1(P)
SSPROQ:	MOVE B,R
	PUSHJ P,CONS1
	MOVE B,-1(P)
	PUSHJ P,XCONS
	MOVE B,PROLIS
	PUSHJ P,CONS
	MOVEM A,PROLIS
	MOVE A,-1(P)
SSPROX:	POP P,B
	JRST POP1J

SSGRL2:	MOVE A,-1(P)
SSGRL1:	PUSHJ P,IASSQF		;INTERNAL ASSQ WITH NO CHECKING
	 JRST SSPROX		;  NO SKIP ON FAILURE TO FIND
	HRRZ B,(B)		;  SKIP ON SUCCESS
	HRRZ T,(A)
	CAME R,(T)		;COMPARES READTABLE AND NUMBER
	JRST SSGRL2
	MOVE B,PROLIS
	PUSHJ P,.DELETE
	MOVEM A,PROLIS
	MOVEI A,NIL
	JRST SSPROX


AUTOLOAD:		;T SHOULD CONTAIN THE SYMBOL NAME, A SHOULD
	HRL A,T		;  CONTAIN THE AUTOLOAD PROPERTY
	PUSHJ P,ACONS
	MOVSS (A)
	PUSH P,A	;FOR GC PROTECTION
	PUSH FXP,D
	MOVSI D,(A)
	HRRI D,1000	;AUTOLOAD USER INTERRUPT
	PUSHJ P,UINT
	POP FXP,D
	JRST POP1J

IFN ITS,[

SUBTTL	SYSCALL FUNCTION

SYSCALL:
	MOVEI D,QSYSCALL
	CAML T,[-10.]
	CAMLE T,XC-2
	 JRST WNALOSE
	MOVEI D,2(P)
	ADD D,T			;D POINTS TO ARG WITH .CALL NAME IN IT
	MOVNM T,SYSCL8		;#ARGS+2
	JSP T,0PUSH+2(T)	;PUSH SLOTS FOR COPYING FIXNUM ARGS
SCSL0:	MOVE A,-1(D)
	JSP T,FXNV1		;<CONTROL-BITS>,,<NUMBER-OF-OUTPUTS-DESIRED>
	HLL D,TT
	HRRZS TT
	CAILE TT,20
	 JRST SCSTMA
	HRLM TT,SYSCL8		;#ANSWERS,,#ARGS+2
	MOVE A,(D)
	PUSH FXP,D
	PUSHJ P,SIXMAK
	MOVSI D,(SETZ)
	EXCH D,(FXP)		;THE SETZ GETS PUT OUT HERE
	MOVEI R,-1(FXP)
	MOVEI F,(FXP)
	PUSH FXP,TT		;THE SIXBIT FOR THE NAME OF THE .CALL
	HLRZ T,D
	TLZ D,-1
	TLO T,5000		;THE CONTROL BITS ARG
	JRST SCSL1A

SCSL1:	 HRRZ T,(D)
	SKOTT T,FX
	 JRST SCSL1A
	MOVE TT,(T)
	MOVEM TT,(R)
	MOVEI T,(R)
	SUBI R,1
SCSL1A:	PUSH FXP,T
	MOVEI AR1,(T)
	CAIN AR1,TRUTH
	 MOVEI AR1,TTYIFA
	MOVEI T,(AR1)		;THIS IS AN INLINE CODED XFILEP
	LSH T,-SEGLOG
	MOVE T,ST(T)
	TLNN T,SA
	 JRST SCSL6
	MOVE T,ASAR(AR1)	;MUST ALSO HAVE FILE BIT SET
	TLNN T,AS.FIL\AS.JOB	;ALLOW EITHER JOB OR FILE
	 JRST SCSL6
	MOVE TT,[@TTSAR]
	ADDM TT,(FXP)
SCSL6:
	CAIGE D,(P)		;LOOP TO INSTALL REMAINING INPUT ARGS
	 AOJA D,SCSL1
	HLRZ D,SYSCL8
	SOJL D,SCSL4
	MOVEI T,1(FXP)
	HRLI T,2000
SCSL3:	PUSH FXP,T		;LOOP TO INSTALL ANSWER REQUESTS
	ADDI T,1
	SOJGE D,SCSL3
SCSL4:	MOVSI T,(SETZ)		;FINAL SETZ SIGNALS END OF PARAMETERS
	IORM T,(FXP)		;[THERE WILL ALWAYS BE AT LEAST ONE, I.E. THE CONTROL]
	MOVEI TT,F.CHAN
	.CALL (F)
	 JRST SCSFAI
	SETZB A,B
	HLRZ D,SYSCL8
SCSL5:	JUMPE D,SCSXIT		;LOOP TO LISTIFY UP NUMERIC ANSWERS
	POP FXP,TT
	PUSHJ P,CONSFX
	SOJA D,SCSL5

SCSTMA:	MOVEI TT,15
	JRST SCSXT1

SCSFAI:	.SUSET [.RBCHN,,R]
	.CALL SCSTAT
	 .VALUE
	LDB TT,[220600,,D]
	MOVE D,SYSCL8
	HLRS D
	SUB FXP,D		;TAKE OFF THE SLOTS FOR ANSWERS
	JSP T,FXCONS		;LISP NUMBER FOR ERROR CODE
SCSXIT:	MOVE D,SYSCL8		;SYSCL8 HAS 2+#ARGS
	ADDI D,-1(D)		;PUSHED WAS 3+2*#ARGS
	HRLS D			; WHICH IS 2*SYSCL8-1
	SUB FXP,D
SCSXT1:	MOVE D,SYSCL8
	HRLS D
	SUB P,D			;STRAIGHTEN UP P
	POPJ P,

SCSTAT:	SETZ
	SIXBIT \STATUS\		;GET CHANNEL STATUS
	      ,,R		;CHANNEL #
	402000,,D		;STATUS WORD
		.SEE IOCERR
		.SEE CHNI1

]		;END OF IFN ITS



$INSRT STATUS		;HAIRY STATUS FUNCTIONS

SUBTTL	CURSORPOS FUNCTION

IFN USELESS,[

CURSORPOS:
	MOVEI D,QCURSORPOS	;LSUBR (0 . 3)
	CAMGE T,XC-3		;MORE THAN THREE ARGS LOSES
	 JRST WNALOSE
	JUMPE T,CRSRP0		;IF NO ARGS, IS FOR DEFAULT TTY
CRSRPS:	SKIPN AR1,(P)		;ELSE LAST ARG MAY BE TTY FILE ARRAY
	 JRST CRSRN
	MOVEI TT,(AR1)
	LSH TT,-SEGLOG
	SKIPGE ST(TT)
	 JRST CRSRMP
	CAIN AR1,TRUTH		;LAST ARG = T
	 HRRZ AR1,V%TYO		; MEANS THE DEFAULT TTY
CRSR10:	CAMN T,XC-3		;FOR THREE ARGS MUST HAVE A FILE ARRAY
	 JRST CRSRP8
	JSP TT,XFOSP		;FOR ONE OR TWO ARGS MAY OR MAY
	 JRST CRSRP0		; NOT HAVE A FILE ARRAY
IFN SFA,[
	 JRST CRSFA1		;FILE
CRSFA5:	SUB P,R70+1		;SFA
CRSFAY:	SETZ C,
	AOJE T,CRSFA2		;ONE LESS ARG; ONLY 1 ARG, ARG TO SFA IS NIL
	POP P,A			;LISTIFY THE ARGS
	PUSHJ P,NCONS		;GENERATE THE INITIAL LIST
	AOSN T			;TWO ARGS?
	 JRST CRSFA4
	POP P,B
	JSP T,%XCONS		;NOW THE LIST IS IN A
CRSFA4:	MOVEI C,(A)
CRSFA2:	MOVEI B,QCURSORPOS	;CURSORPOS OPERATION
	MOVEI A,(AR1)		;THE SFA ITSELF
	JRST ISTCSH

CRSFAZ:	HRRO AR1,V%TYO		;GET FILE AS SPECIFIED BY 'T'
	JSP TT,XFOSP		;CHECK FOR IT BEING A SFA
	 JRST (F)		;NOPE
	 JRST (F)
	SOJA T,CRSFAY		;A SFA, HANDLE SPECIALLY
]		;END IFN SFA
CRSRP8:
IFN SFA,[
	JSP TT,XFOSP		;CHECK IF FILE OR SFA
	 JFCL
	 SKIPA			;NOT SFA
	 JRST CRSFA5		;SFA
CRSFA1:	]	;END IFN SFA
	SUB P,R70+1		;IF WE HAVE ONE, IT MUST
	PUSH FXP,T		; BE A BONA FIDE TTY OUTPUT FILE
	PUSHJ P,TOFLOK
	UNLOCKI
	POP FXP,T
	AOSA T
CRSRP0:
SFA%	 HRRO AR1,V%TYO
SFA$	 JSP F,CRSFAZ		;TRAP OUT IF A SFA
	JSP R,PDLA2(T)
	MOVEI TT,F.MODE
	MOVE D,@TTSAR(AR1)
	SKIPGE AR1		;IF FILE NOT EXPLICITLY GIVEN
	 SKIPN TTYOFF		; THEN ^W NON-NIL => RETURN NIL
	  SKIPA
	   JRST FALSE
	JUMPE T,CRSRP1		;0 ARGS - GET POSITION
	AOJE T,CRSRP3		;1 ARG - SPECIAL HACKS (^P CODES)
	SKOTT A,FX
	 JRST CRSR11

;2 ARGS
	MOVEI D,"V		;SET VERTICAL POSITION
	PUSHJ P,CRSRP5
CRSR20:	MOVEI D,"H		;SET HORIZONTAL POSITION
	MOVEI A,(B)
CRSRP5:	JUMPE A,TRUE		;NIL MEANS NO CHANGE
	JSP T,FXNV1
	SKIPGE TT
	 SETZ TT,		;NEGATIVE ARG NOT ALLOWED
	CAILE TT,167		;NOR ARG ABOVE 167
	 MOVEI TT,167
IFN ITS\D20,	HRLI D,10(TT)		;ADD MAGIC 10 TO AMOUNT FOR ^P
.ELSE 	JRST FALSE


CRSRP7:	PUSHJ FLP,CNPCHK		;CHECK TO SEE IF CAPABILITY EXISTS?
	 JRST CRSR71
IFN ITS\D20,	MOVEI A,TRUTH		;RETURN TRUTH IF WE GOT THIS FAR
.ELSE	MOVEI A,NIL			;RIGHT NOW, D10 SYSTEMS CANT "DO IT"
	JRST CNPCUR			; THEN DO ACTION, AND EXIT WITH CZECHI

CRSR71: MOVEI A,NIL		;NO CAPABILITY, SO RETURN NIL
	JRST CZECHI

;1 ARG CASE
CRSRP3:	JSP T,SPATOM
	 JRST CRSRP4		;IF NO A SYMBOL, THEN BETTER BE FIXNUM
	PUSHJ P,CRSR40		;GET NUMERIC VALUE OF FIRST CHAR OF SYMBOL
CRSRP6:	MOVEI D,(TT)
	TRC TT,100
	TDNE TT,[-40]
	 JRST CRSRP2
	MOVE TT,GCBT(TT)	;Get a "1" bit in the position specified by TT
	TDNN TT,CRSRP9
	 JRST CRSRP2
	JRST CRSRP7

CRSRP4:	JSP T,FXNV1
	JRST CRSRP6

CRSR40:	JSP T,CHNV1
	CAIL TT,140
	 SUBI TT,40		;CONVERT TO UPPER CASE
	POPJ P,

CRSRP9:
ZZZ==0
IRPC X,,[ABCDEFKLMNPQRSTUXZ[\]^_]
ZZZ==ZZZ\<SETZ_-<"X&37>>
TERMIN
	ZZZ		;BITS SPECIFYING VALID ^P CODES
EXPUNGE ZZZ		;NOTE: H, I, AND V NOT VALID HERE!

;2 ARG CASE WITH NON-FIXNUM AS FIRST ARG
CRSR11:	JUMPE A,CRSR20
	JSP T,SPATOM
	 JRST CRSR12
	PUSHJ P,CRSR40
	JSP T,FXNV2
	SKIPGE D
	SETZ D,
	CAIE TT,"H
	 CAIN TT,"V
	  JRST CRSR13
	CAIN TT,"I
	 JRST CRSR14
CRSR12:	WTA [BAD CURSOR CODE - CURSORPOS!]
	JRST CRSR11


CRSR13:	CAILE D,167
	MOVEI D,167
	ADDI D,10		;H AND V RANDOMLY WANT 10 ADDED
CRSR14:	MOVSI D,400000(D)	.SEE CNPCD1	;KEEP LH FROM BEING ZERO
	HRRI D,(TT)
	JRST CRSRP7

;0 ARGS CASE
CRSRP1: PUSHJ P,FORCE1
	MOVEI TT,F.MODE
	MOVE F,@TTSAR(AR1)
IFE ITS\D20, 	JRST FALSE
IFN ITS\D20,[
	PUSHJ FLP,RCPOS
	TLNE F,FBT<EC>		;GET ECHO MODE POSITION
	 MOVE D,R		; IF FILE IS FOR ECHO AREA
	MOVEI TT,(D)		;CONS THEM UP FOR LOSER
	JSP T,FIX1A
	MOVEI B,(A)
	HLRZ TT,D
	JSP T,FIX1A
	JRST CONS
]	;END OF IFN ITS\D20

CRSRMP:	PUSH FXP,T
CRSRM1:	HLRZ A,@(P)
	MOVE T,(FXP)
	MOVEI TT,(T)
	ADDI TT,(P)
	PUSH P,1(TT)
	TRNE T,1
	 PUSH P,2(TT)
	PUSH P,A
	PUSHJ P,CRSRPS
	HRRZ A,@(P)
	MOVEM A,(P)
	JUMPN A,CRSRM1
	POP FXP,T
CRSRN:	MOVEI A,TRUTH
	JRST PROGN1

]		;END OF IFN USELESS


SUBTTL	RANDOM ROUTINES TO HANDLE A PSEUDO ALIST

%%FUNCTION:	MOVEI D,Q%%FUNCTION
	JUMPE A,WNAFOSE
	HRRZ C,(A)
	JUMPN C,WNAFOSE
	HLRZ B,(A)		;HALF-ASSED FUNARG BINDING
	HRROI TT,(SP)		;ONE LH AS GOOD AS ANOTHER
	JSP T,FIX1A
.FUNC4:	PUSHJ P,XCONS
	MOVEI B,QFUNARG
	JRST XCONS

AEVAL:	SKIPE A,(P)		;PURPOSELY CRIPPLING POWER OF ALIST
	 JSP T,FXNV1		; ROUTINE: FOOEY! - GLS
	PUSHJ P,ALIST		;EVAL WITH AN ALIST
	SUB P,R70+1
	POP P,A
	SKIPE T			;ALIST RETURNING NON-ZERO IN T =>
	 PUSH P,CAUNBIND	; TWO BIND BLOCKS WERE PUSHED
	PUSH P,CAUNBIND
	POPJ FXP,


;;; ALIST CREATES AN ENVIRONMENT AS SPECIFIED BY A GIVEN A-LIST.
;;; AN A-LIST MAY BE:
;;;	[1] NIL, MEANING THE TOP-LEVEL ENVIRONMENT.
;;;	[2] T, MEANING THE CURRENT ENVIRONMENT (SEE [4]).
;;;	[3] A FIXNUM REPRESENTING A SPECPDL POINTER, AS
;;;	    RETURNED BY THE EVALFRAME FUNCTION AS THE FOURTH
;;;	    ITEM. THIS INDICATES THE ENVIRONMENT AS OF
;;;	    THE SPECIFIED FRAME.
;;;	[4] ((<SYMBOL> . <VALUE>) . <A-LIST>)
;;;	    THAT IS, ONTO ONE OF THE OTHER THREE KINDS OF A-LIST
;;;	    ONE MAY CONS ADDITIONAL VARIABLE-VALUE PAIRS IN
;;;	    THE USUAL MANNER. THIS IS A "TRUE A-LIST".
;;; THIS ENVIRONMENT IS CREATED BY REBINDING ALL VARIABLES
;;; WHICH HAVE BEEN BOUND SINCE THEN BACK TO THEIR OLD VALUES,
;;; OR TO THE VALUES SPECIFIED BY THE TRUE A-LIST. IF A GIVEN
;;; VARIABLE WAS BOUND SEVERAL TIMES, ONLY ONE REBINDING IS DONE
;;; TO RECREATE THE OLD ENVIRONMENT. THIS IS DONE BY USING THE
;;; LEFT HALF OF A VALUE CELL TO INDICATE WHETHER OR NOT IT
;;; HAS ALREADY BEEN REBOUND. THIS HAS THE CONSEQUENCE THAT
;;; NOQUIT MUST BE TURNED ON DURING THIS OPERATION.
;;; EITHER ONE OR TWO SPECPDL BLOCKS ARE PUSHED, THE SECOND ONE
;;; BEING NECESSARY IF ANY TRUE A-LIST IS GIVEN. THERE ARE FOUR
;;; STEPS TO THE PROCESS:
;;;	[1] CHECK ARGUMENT THOROUGHLY FOR ERRORS. IF A TRUE
;;;	    A-LIST IS GIVEN, ALL SYMBOLS ON THE A-LIST ARE GIVEN
;;;	    VALUE CELLS IF THEY DON'T HAVE ANY ALREADY.
;;;	[2] TURN ON NOQUIT. IF A TRUE A-LIST IS GIVEN, BIND ALL
;;;	    THE SYMBOLS AS SPECIFIED, MARKING THE VALUE CELLS
;;;	    AS THEY ARE BOUND, AND NEVER BINDING A SYMBOL TWICE.
;;;	    WHEN DONE, PUSH THE TRUE A-LIST ONTO THE SPECPDL
;;;	    SO THAT AUNBIND CAN RESTORE THINGS CORRECTLY.
;;;	[3] SCAN THE SPECPDL FROM THE POINT SPECIFIED BY THE
;;;	    SPECPDL POINTER (FROM THE BOTTOM IF NIL), AND BIND
;;;	    ALL VALUES CELLS SEEN BACK TO THEIR OLD VALUES,
;;;	    MARKING THEM AS THEY ARE BOUND, NEVER BINDING ONE
;;;	    TWICE. WHEN DONE, PUSH A POINTER ON THE SPECPDL
;;;	    SO THAT AUNBIND CAN RESTORE THINGS CORRECTLY.
;;;	[4] SCAN BACK OVER ALL THE ITEMS PUSHED IN STEPS 2
;;;	    AND 3, RESTORING THE LEFT HALVES OF ALL THE VALUE
;;;	    CELLS. TURN OFF NOQUIT AND CHECK FOR INTERRUPTS.
;;; ON RETURN, A-LIST LEAVES T NON-ZERO IFF TWO BIND BLOCKS
;;; WERE PUSHED. IT IS UP TO THE CALLER TO MAKE SURE THAT THE
;;; BLOCK(S) ARE UNBOUND CORRECTLY WITH AUNBIND.
;;; NOTE THAT ERRPOP CAN RECOGNIZE THESE SPECIAL BIND BLOCKS AND
;;; CALL AUNBIND TO UNBIND THEM. THIS IS BECAUSE THE LAST WORD
;;; PUSHED HAS ZERO IN THE LEFT HALF.


ALIST:	SKIPN C,-1(P)		;MAKE COPY OF ENVIRONMENT GIVEN A-LIST
ALST1:	JUMPE C,ALST3		;STEP 1 - ERROR CHECKING
	CAIN C,TRUTH
	JRST ALST3		;T AND NIL ARE VALID A-LISTS
	SKOTT C,LS
	JRST ALST2		;NOPE - GO CHECK IT OUT
	HLRZ AR1,(C)		;YUP - CHECK ITS CAR
	HRRZ C,(C)
	SKOTT AR1,LS
	JRST ALST0
	HLRZ A,(AR1)
	SKOTT A,SY
	JRST ALST0
	CAIN A,TRUTH
	JRST ALST0
	HLRZ AR1,(A)
	HRRZ B,(AR1)
	MOVEI AR1,QUNBOUND
	CAIN B,SUNBOUND
	JSP T,.SET1
	JRST ALST1


ALST2:	TLNN TT,FX		; - DARN WELL BETTER BE A FIXNUM
	JRST ALST0
	HRRZ TT,(C)		;MUST BE A VALID SPECPDL POINTER
	CAML TT,ZSC2
	CAILE TT,(SP)
	JRST ALST0
ALST3:	HLLOS NOQUIT		;TURN ON NOQUIT - MUSTN'T INTERRUPT
	HLLOS MUNGP		;ABOUT TO MUNG VALUE CELLS!
	MOVEM SP,SPSV		;STEP 2 - PUSH BLOCK FOR TRUE A-LIST
	SETZ T,			;T WILL BECOME NON-ZERO IF TRUE
	SKIPN C,-1(P)		; A-LIST IS PRESENT AT ALL
ALST3A:	JUMPE C,ALST4		;NIL FOUND
	CAIN C,TRUTH
	JRST ALST7		;T FOUND
	SKOTT C,LS
	JRST ALST4A		;FIXNUM FOUND
	HLRZ B,(C)
	HRRZ C,(C)
	HLRZ A,(B)		;A HAS ATOMIC SYMBOL
	HRRZ AR1,(B)		;AR1 HAS ASSOCIATED VALUE
	HLRZ B,(A)
	HRRZ A,(B)
	SKIPGE AR2A,(A)		;SKIP UNLESS VALUE CELL MARKED
	 JRST ALST3A		;VALUE CELL ALREADY REBOUND
	HRLI AR2A,(A)		;PUSH <VALUE CELL,,CURRENT VALUE>
	PUSH SP,AR2A		; ONTO SPECPDL; THEN INSTALL
	HRROM AR1,(A)		; VALUE FROM ENVIRONMENT, MARKING CELL
	AOJA T,ALST3A		;T NON-ZERO => WE PUSHED SOMETHING

ALST4:	MOVEI C,SC2		;NIL => TOP LEVEL ENVIRONMENT
ALST4A:	HRRZ C,(C)		;FIXNUM => SPECIFIED ENVIRONMENT
	HRRZ B,SPSV
	JUMPE T,ALST4C		;IF ANYTHING PUSHED, START NEW BLOCK
	PUSH SP,-1(P)		;LEFT HALF BETTER BE ZERO!
	PUSH SP,SPSV		;FINISH OFF BLOCK FOR TRUE A-LIST
	MOVEM SP,SPSV		;START NEW BLOCK FOR FUNARG POINTER
ALST4C:	MOVEI TT,(C)		;STEP 3 - SCAN SPECPDL FROM ENVIRONMENT
ALST5:	CAIN TT,(B)		; BACK UP TO POINT WHEN ALIST CALLED
	JRST ALST6
	HRRZ AR1,(TT)		;GET VALUE FROM SPECPDL
	CAMGE AR1,ZSC2		;IGNORE SPECPDL POINTERS
	JRST ALST5A
	CAIGE AR1,(SP)
	AOJA TT,ALST5
ALST5A:	HLRZ A,(TT)		;GET VALUE CELL FROM SLOT
	JUMPE A,AL5AB		;IGNORE FROBS ALIST PUSHES!
	CAIE A,PWIOINT		;WHAT A LOSER -- DON'T MESS WITH THIS!
	 SKIPGE AR2A,(A)	;IGNORE MARKED VALUE CELLS
AL5AB:	 AOJA TT,ALST5
	HRLI AR2A,(A)		;ELSE PUSH AS BEFORE
	PUSH SP,AR2A
	HRROM AR1,(A)
	AOJA TT,ALST5


ALST7:	HRRZ C,-1(P)		;T => CURRENT ENVIRONMENT
	SETZ T,			;ONLY ONE BLOCK PUSHED
	HRRZ B,SPSV
ALST6:	PUSH SP,C		;STEP 4 - RESTORE VALUE CELLS
ALST6A:	CAIN B,(SP)
	 JRST ALST7A
	HLRZ A,(B)
	JUMPE A,ALST6B
	CAMGE A,ZSC2
	 HRRZS (A)
ALST6B:	AOJA B,ALST6A

ALST7A:	PUSH SP,SPSV		;CLOSE BIND BLOCK
	HLLZS MUNGP		;VALUE CELLS UNMUNGED
	JRST CZECHI		;ALL DONE - CHECK INTERRUPTS

;;; AUNBIND UNDOES A FUNARG BIND BLOCK PUSHED BY ALIST.
;;; IT DOES SO BY SCANNING UP THE SPECPDL FROM THE POINT OF
;;; THE FUNARG ENVIRONMENT, OR BY SCANNING DOWN THE TRUE A-LIST,
;;; CLOBBERING CURRENT VALUNBIND UNDOES A FUNARG BIND BLOCK PUSHED BY ALIST.
;;; IT DOES SO BY SCANNING UP THE SPECPDL FROM THE POINT OF
;;; THE FUNARG ENVIRONMENT, OR BY SCANNING DOWN THE TRUE A-LIST,
;;; CLOBBERING CURRENT VALUES FROM VALUE CELLS INTO SPECPDL
;;; SLOTS OR A-LIST SLOTS AS APPROPRIATE, SO THAT ANY SETQ'S
;;; DONE IN THE CREATED COPY OF THE ENVIRONMENT WILL BE
;;; REFLECTED IN THE ORIGINAL ENVIRONMENT.

AUNBIND:
	POP SP,T
AUNBN0:	MOVEM TT,UNBND3
	MOVEM D,AUNBD
	MOVEM R,AUNBR
	MOVEM F,AUNBF
	MOVEI F,1(T)
	HRRZ R,(SP)
	CAMGE R,ZSC2
	 JRST AUNBN4
AUNBN1:	CAIN F,(SP)		;CLOBBER SETQ'S BACK INTO SPECPDL
	 JRST AUNBN3
	HLRZ D,(F)
AUNBN2:	HLRZ TT,(R)
	CAIE TT,(D)
	 AOJA R,AUNBN2
	HRRZ TT,(TT)
	HRRM TT,(R)
	AOJA F,AUNBN1

AUNBN3:	MOVE F,AUNBF
	MOVE R,AUNBR
	MOVE D,AUNBD
	SUB SP,R70+1
	JRST UNBND0

AUNBN4:				;CLOBBER SETQ'S BACK INTO TRUE A-LIST
AUNBN5:	CAIN F,(SP)
	 JRST AUNBN3
	HLRZ D,(F)
	JRST AUNBN7

AUNBN6:	HRRZ R,(R)
AUNBN7:	HLRZ TT,(R)
	HLRZ TT,(TT)
	HLRZ TT,(TT)
	HRRZ TT,(TT)
	CAIE TT,(D)
	 JRST AUNBN6
	HLRZ TT,(R)
	HRRZ D,(D)
	HRRM D,(TT)
	AOJA F,AUNBN5







IAP4A:	MOVEM TT,R	;AT THIS POINT, WE MAKE UP AN
	HRROI TT,(SP)
	JSP T,FIX1A
	PUSH P,A
	MOVE TT,R
	MOVNI R,2
	MOVNI T,1
	JRST IAP5

APFNG:	HRRZ A,(B)		;APPLY FUNARG
	HLRZ B,(B)
	HRRM B,(C)
	PUSH P,A
	MOVEM T,APFNG1
	PUSHJ P,ALIST
	PUSH P,.
	HRROI TT,-2(P)
	MOVE D,APFNG1
	POP TT,2(TT)
	AOJLE D,.-1
CAUNBIND:
	MOVEI D,AUNBIND
	MOVEM D,2(TT)
	SKIPN T
	 MOVEI D,CPOPJ
	MOVEM D,1(TT)
	MOVE T,APFNG1
	JRST IAPPLY


APLBL:	HLRZ A,(B)
	HRRZ B,(B)
	HLRZ AR1,(B)
	MOVEM AR1,(C)
	MOVEM SP,SPSV	;APPLY LABEL EXPRESSION
	PUSHJ P,BIND
	PUSHJ P,ABIND3
	MOVEI A,APLBL1
	EXCH A,-1(C)
	HLLM A,-1(C)
	PUSH FXP,A
	JRST IAPPLY
APLBL1:	PUSHJ P,UNBIND
	POPJ FXP,


SUBTTL	LISTIFY, PNPUT, AND PNGET

LISTIFY:
	SKIPN R,ARGLOC
	 JRST LFYER
	JSP T,FXNV1	;LISTIFY UP N ARGS FOR AN LSUBR
	MOVM D,TT
	CAMLE D,@ARGNUM
	 JRST LFY0
	JUMPGE TT,LFY3
	ADD R,@ARGNUM
	SUBI R,(D)
LFY3:	HRLOI TT,(D)		;SEE HAKMEM (A.I. MEMO 239) ITEM 156
	EQVI TT,(R)		;TT GETS <-N-1>,,<CONTENTS OF ARGLOC>
	AOBJP TT,FALSE		;ZERO ARGS
	PUSH P,R70
	MOVEI R,(P)		;T HOLDS LAST POINTER
LFY1:	MOVE A,(TT)		;GET ARG
	JSP T,PDLNMK
	PUSHJ P,NCONS
	HRRM A,(R)		;CLOBBER ONTO END OF LIST
	MOVEI R,(A)		;ADVANCE LAST POINTER
	AOBJN TT,LFY1
	JRST POPAJ


PNPUT:	JUMPE B,SYCONS
	PUSH P,A
	SETZM LPNF
	JRST INTRN1

$PNGET:	PUSHJ P,PNGET
	MOVE C,A
	JSP T,FXNV2
	MOVEI B,0
	CAIN TT+1,7
	POPJ P,
	CAIE TT+1,6
	LERR [SIXBIT \FEATURE NOT YET IMPLEMENTED - PNGET!\]
	TDZA D,D
$PNG.R:	PUSHJ P,CONSFX
	SETZ TT,
	MOVE R,[440600,,TT]
$PNG3:	TLNN D,760000
	JRST $PNG.D
$PNG3A:	TLNN R,740000
	JRST $PNG.R
$PNG4:	ILDB T,D		;GET NEXT ASCII BYTE
	JUMPE T,$PNGX
	CAIGE T,140		;CHECK FOR LOWER-CASE
	ADDI T,40		;CONVERT, AND STORE
	IDPB T,R
	JRST $PNG3
$PNG.D:	JUMPE C,$PNGX
	HLRZ F,(C)		;CONSTRUCT WORD OF ASCII, AND BPTR THERETO
	MOVE F,(F)
	HRRZ C,(C)
	MOVE D,[440700,,F]
	JRST $PNG3A
$PNGX:	JUMPE TT,.+2
	PUSHJ P,CONSFX
	JRST NREVERSE






SUBTTL	EXAMINE, DEPOSIT, MAKNUM, MUNKAM


DEPOSIT:			;FIRST ARG IS FIXNUM ADDRESS, 2ND IS VALUE
	EXCH A,B
	JSP T,FXNV2		;GET ADR INTO TT+1
	JSP T,FLTSKP		;GET DATA INTO TT
	JFCL
	MOVEM TT,(TT+1)		;PERFORM DEPOSIT
	JRST TRUE

EXAMINE:
	PUSH P,CFIX1
	JSP T,FXNV1
	MOVE TT,(TT)
	POPJ P,

MAKNUM:	MOVEI TT,(A)
	JRST FIX1

MUNKAM:	JSP T,FXNV1
	MOVEI A,(TT)
	POPJ P,

SUBTTL	SLEEP, ALARMCLOCK

;;; (SLEEP <N>) SLEEPS FOR <N> SECONDS.  <N> MAY BE A FIXNUM OR FLONUM.

$SLEEP:	JSP T,FLTSKP		;SUBR 1

IFN ITS\D20,[
	 JSP T,M30.
	  FMPR TT,[TMCNST]
	  JSP T,IFIX
IT$	.SLEEP TT,		;ITS -- SLEEP FOR <TT> 30TH'S OF A SECOND
IFN D20,[
SPECPRO INTSLP			;D20 -- SLEEP FOR <TT> MILLISECSONDS
	MOVE 1,TT		; (A) WE WANT TO ALLOW INTERRUPTS TO GO THROUGH
	DISMS			; (B) WE MUST BEWARE OF CRUD IN AC 1
XCTPRO
	SETZ 1,
NOPRO
]		;END OF IFN D20
]	;END IFN ITS\D20

IFN D10,[
	CAIA
	  JSP T,IFIX
	SLEEP TT,		;SLEEP FOR <TT> SECONDS
]	;END IFN D10

	JRST TRUE

IFN ITS,[
ALARMCLOCK:
	EXCH A,B
	SETO TT,
	CAIE B,Q$RUNTIME
	 JRST ALCK1
	JUMPE A,ALCK3		;NIL => TURN OFF CLOCK
	JSP T,FLTSKP		;RUN TIME IN MICROSECONDS,
	 JRST .+2		; ACCURATE TO 4. USEC JIFFIES
	JSP T,IFIX
	ASH TT,-2
ALCK3:	.SUSET [.SRTMR,,TT]
ALCK4:	JUMPL TT,FALSE
	JRST TRUE

ALCK1:	CAIE B,Q$TIME
	 JRST ALCK0
	JUMPE A,ALCK5		;NIL => TURN OFF CLOCK
	JSP T,FLTSKP		;REAL TIME IN SECONDS,
	 JSP T,M30.		; ACCURATE TO 30TH'S
	  FMPRI TT,(TMCNST)
	  JSP T,IFIX
	ASH TT,1
ALCK5:	MOVSI R,400000
	JUMPL TT,ALCK2
	JUMPN TT,ALCK7
	MOVEI TT,1		;IF 0 SPECIFIED, USE 1/30 SECOND
ALCK7:	MOVE R,[600000,,TT]
ALCK2:	.REALT R,
	JRST ALCK4

]		;END OF IFN ITS

IFN ITS\D20,[
M30.:	IMULI TT,TMXCNST	;NOTE: DOUBLE SKIP RETURN
	JRST 2(T)
]	;END IFN ITS\D20


SUBTTL	REMOB, ARG, SETARG

REMOB:	JSP T,SPATOM		;SUBR 1 - REMOVE ATOMIC SYMBOL FROM OBARRAY
	 JSP T,PNGE		;ERROR IF ARG NOT A SYMBOL
	LOCKI
	PUSHJ P,INTERN
	JRST REMOB7

REMOB2:	LOCKI
REMOB7:	EXCH A,B	;OBTBL BUCKET # SHOULD BE IN TT
	MOVE R,TT
	HRRZ D,VOBARRAY
	HRRI TT,@TTSAR(D)
	PUSHJ P,ARYGT4
	HLRZ T,(A)
	CAIN T,(B)
	 JRST REMOB1
REMOB3:	MOVE D,A
	HRRZ A,(A)
	HLRZ T,(A)
	CAIE T,(B)
	 JRST REMOB3
	HRRZ T,(A)
	HRRM T,(D)
REMOB4:	HLRZ TT,(B)	;LEAVE ATOM HEADER IN T
	HRRZ TT,1(TT)	;LEAVE PNAME LINK IN TT
	JSP T,GCP8L	;CHECK TO SEE THAT SCOS ARE REMOVED FROM SCO TABLE.
	SETZB A,B
	UNLKPOPJ

REMOB1:	HRRZ A,(A)
	JSP T,.STOR0
	JRST REMOB4


ARG:	JUMPE A,ARG3		;SUBR 1 - FETCH LSUBR ARGUMENT
ARGXX:	JSP R,ARGCOM
	HRRZ A,(D)
	JRST PDLNKJ

ARG3:	SKIPN ARGLOC		;(ARG NIL) RETURNS NUMBER OF LSUBR ARGUMENTS
	 JRST ARGCM1
	HRRZ A,ARGNUM
	JRST PDLNKJ

SETARG:	JSP R,ARGCOM		;SUBR 2 - SET LSUBR ARGUMENT
	MOVE A,B
	JSP T,PDLNMK
	HRRM A,(D)
	POPJ P,

ARGCOM:	SKIPN D,ARGLOC
	 JRST ARGCM0
	JSP T,FXNV1
	JUMPLE TT,ARGCM8
	CAMLE TT,@ARGNUM
	 JRST ARGCM8
	ADD D,TT
	JRST (R)


SUBTTL	P.$X AND FRIENDS

	SBSYM:	JSR POFF	;FIND SUBR NAME (ADR IN RH OF .)
	VCLSYM:	JSR POFF	;FIND ATOM FOR VC (ADR IN LH OF .)
	VCSYM:	JSR POFF	;FIND ATOM FOR VALUE CELL
	TLSYM:	JSR POFF	;PRINT ST ENTRY OF LEFT HALF OF A CELL
	TSYM:	JSR POFF	;ST ENTRY OF RIGHT HALF
	PLSYM:	JSR POFF	;PRINT LEFT HALF OF A CELL
	PSYM:	JSR POFF	;PRINT RIGHT HALF OF A CELL
	POF:	JSR POFF	;PRINT ARG (POINTER AT LOC 40)
	TOF:	JSR POFF	;ST ENTRY OF ARG (POINTER IN 40)
IT$	P%OFF:	JSR POFF	;FOR % TYPEOUT MODE IN DDT
;POFF:	0
PSYM1:	SETOM PSYMF
	MOVEM T,PSMTS		;P.$X, DONE IN DDT,
	MOVEM R,PSMRS		; WILL PRINT CONTENTS
	MOVEI T,LPSMTB		; OF CURRENT OPEN CELL
	MOVE R,@PSMTB-1(T)	; IN LISP FORMAT.
	MOVEM R,PSMS-1(T)
	SOJN T,.-2
IFE ITS,[
10$	HRRZ T,.JBDDT"
10$	HRRZ T,@6(T)		;WHAT A KLUDGE!  6?!!
20$	MOVEI T,60		;TERRIBLE KLUDGE! 60
10$	CAIG R,POF
	 MOVEM T,PS.S
]		;END OF IFE ITS
	HRRZ T,POFF
	PUSH P,CPSYMX
	JSP T,ERSTP
	MOVEM P,ERRTN
	HRRZ R,POFF
IFN ITS,[
	MOVEI T,40
	MOVEM T,PS.S
	MOVEI T,THIRTY+7
	CAIN R,P%OFF+1
	 MOVEM T,PS.S
	CAIG R,POF
	 .BREAK 12,PSMST
]		;END OF IFN ITS
	JSP T,SPECBIND
		TTYOFF
		TAPWRT
		V.RSET
IFN USELESS,	SETZM TYOSW
	HRRZ AR1,V%TYO		;UPDATE OUR NOTION OF THE
	MOVE T,ASAR(AR1)
	MOVE TT,TTSAR(AR1)
	TLNE T,AS.SFA+AS.FIL
	 TLNN TT,TTS.TY
	  JRST PSYM2
	PUSHJ P,TTYBR1		; LINENUM AND CHARPOS OF THE TTY,
	MOVEI TT,AT.LNN		; SINCE DDT HAS SCREWED IT ALL UP.
	HLRZM D,@TTSAR(AR1)
	MOVEI TT,AT.CHS
	HRRZM D,@TTSAR(AR1)

;;; 	FALLS THRU


;;;	FALLS IN

PSYM2:	MOVE T,PSMTS	;AT THIS POINT ALL ACS WILL HAVE BEEN
	MOVE R,PSMRS	; RESTORED SO THAT MOVE A,@ WILL WORK.
	MOVE A,PSMS
	MOVE AR1,PSMS+AR1-A
	MOVE A,@PS.S	;THUS THIS STUFF WORKS IF . IS AN AC.
	HRRZ T,POFF
IT$	CAIN T,P%OFF+1
IT$	 JRST PSYMP1
	CAIN T,POF+1
	 MOVEI T,PSYM+1
	CAIN T,TOF+1
	 MOVEI T,TSYM+1
	SUBI T,SBSYM
	TRNE T,1
	 TLZA A,-1
	  HLRZS A
	LSH T,-1
	JRST .+1(T)
	JRST PSYMSB	;SB.$X
	JRST PSYMVC	;VC.$X  AND  VCL.$X
	JRST PSYMT	;T.$X  AND  TL.$X  AND  TP FOO$X
PSYMP:	PUSHJ P,PRIN1	;P.$X  AND  PL.$X  AND  PP FOO$X
PSYMQ:	MOVEI A,TRUTH	;RETURN POINT TO GET OUT OF PSYM1
	JRST ERR2
PSYMX:	MOVEI T,LPSMTB
	MOVE R,PSMS-1(T)
	MOVEM R,@PSMTB-1(T)
	SOJN T,.-2
	MOVE T,PSMTS
	MOVE R,PSMRS
	SETZM PSYMF
CPSYMX:	POPJ P,PSYMX

IFN ITS,[
PSYMP1:	TLNN A,-1		;LISP MODE TYPEOUT - HACK TWO HALVES
	 JRST PSYMP
	PUSH P,A
	HLRZ A,A
	PUSHJ P,PRIN1
	MOVEI A,",		;SEPARATE HALVES WITH ",,"
REPEAT 2, PUSHJ P,TYO
	POP P,A
	TLZ A,-1
	JRST PSYMP
]		;END OF IFN ITS

PSYMSB:	MOVEI B,(A)
	PUSHJ P,ERRADR	;ERRADR DOES ALL THE DIRTY WORK!
	JRST PSYMQ

FCN.B:	SKIPE NOQUIT	;FAKE CONTROL-B INTERRUPT FROM DDT
	  POPJ P,
	SKIPGE INTFLG
	 POPJ P,

;;;	FALLS THRU

;;; 	FALLS IN

	PUSH FXP,D
	MOVE D,INHIBIT		;CROCK SO THAT A .5LOCKI
	AOJE D,POPXDJ		; WON'T STOP US
	PUSH FXP,INHIBIT
	SETZM INHIBIT
	MOVE D,[TTYIFA,,400000+^B]
	PUSHJ P,UINT
	POP FXP,INHIBIT
	POP FXP,D
	POPJ P,

TOF1:	SKIPA T,[TOF]
POF1:	MOVEI T,POF
	PUSH P,UUOH
	EXCH T,UUTSV
	JRST @UUTSV



PSYMVC:	MOVEI T,(A)
	MOVEI A,QUNBOUND
	CAIN T,SUNBOUND
	JRST PSYMP
	SKOTT T,LS
	JRST PSVC1
	JSP R,GCGEN
	   PSVC2
PSVC1:	MOVEI A,QM
	JRST PSYMP

PSVC2:	HLRZ A,(D)
	HLRZ B,(A)
	HRRZ A,(B)
	CAIN A,(T)
	JRST PSVC3
	HRRZ D,(D)
	JUMPN D,PSVC2
	JRST GCP8A

PSVC3:	HLRZ A,(D)
	JRST PSYMP



;;; TABLE OF CELLS TO SAVE OVER THE PSYM FUNCTIONS

ZZ==.		;BE SURE TO SEE PSMS IF YOU CHANGE THIS TABLE
PSMTB:		;ACCUMULATOR A MUST BE THE FIRST ITEM, AND AR1 THE FOURTH
IRP FOO,,[A,B,C,AR1,AR2A,TT,D,F,40,UUOH,UUTSV,UUTTSV,UURSV,ERBDF,FPTEM]
	FOO
	TERMIN
IFN USELESS,[
	PRINLV
	TYOSW
	ABBRSW
]		;END OF IFN USELESS
LPSMTB==.-ZZ	;FPTEM AND PCNT ARE SAME LOCATION

IT$ PSMST:	4,,PS.S-1	;READ VALUE OF . FROM DDT WITH .BREAK 12,

; PP - A UUO	;PP IS FOR PRINTING OUT AN ADDRESS AS AN S-EXPRESSION:
		;PP 34722$X IN DDT WILL PRINT OUT 34722 AS A
		;	POINTER IN LIST FORMAT.
; TP - A UUO	;TP IS LIKE PP BUT NICELY PRINTS ST ENTRY FOR
		;	THAT CELL
	P.=PUSHJ P,PSYM		;P.$X IS LIKE PP FOO$X WHERE FOO IS RH OF.
	PL.=PUSHJ P,PLSYM	;LIKE P., BUT FOR LH OF CURRENT CELL
IT$	P%=PUSHJ P,P%OFF	;LIKE P., BUT AS A DDT TYPEOUT MODE
	VC.=PUSHJ P,VCSYM	;FIND NAME OF VALUE CELL RH OF . ADDRESSES
	VCL.=PUSHJ P,VCLSYM	;A CROSS BETWEEN VC. AND PL.
	T.=PUSHJ P,TSYM	;A CROSS BETWEEN P. AND TP
	TL.=PUSHJ P,TLSYM	;A CROSS BETWEEN PL. AND TP
	SB.=PUSHJ P,SBSYM	;FIND NAME OF SUBR ADDRESSED BY RH OF .
	BB=PUSHJ P,FCN.B	;FAKE CONTROL-B INTERRUPT FROM DDT



SUBTTL	T.$X AND TBLPUR$X STUFF

PSYMT:	PUSHJ P,ITERPRI		;T.$X TYPEOUT, ETC.
	MOVEI TT,(A)
	ROT TT,-SEGLOG
	MOVE TT,ST(TT)
	SETZB T,C
	MOVNI R,22
PSYMT1:	LSHC T,1
	TRZN T,1
	 JRST PSYMT3
	MOVEI A,"+
	TROE C,1
	 PUSHJ P,TYO
	MOVEI B,PSYMTT+22(R)
	CAIL B,PSYMTT+PSYMTL
	 MOVEI B,[ASCII \??\]
	HRLI B,440700
PSYMT2:	ILDB A,B
	JUMPE A,PSYMT3
	PUSHJ P,TYO
	JRST PSYMT2
PSYMT3:	AOJL R,PSYMT1
	MOVEI A,",
REPEAT 2, PUSHJ P,TYO
	HLRZ A,TT
	PUSHJ P,PRINC
	JRST PSYMQ

.SEE LS		;THIS TABLE SHOULD BE KEPT CONSISTENT
.SEE ST		; WITH TWO OTHER PLACES
PSYMTT:
IRP TP,,[LS,$FS,FX,FL,BN,SY,SA,VC,$PDLNM,??,$XM,$NXM,PUR,HNK,DB,CX,DX]
	ASCII \TP\
TERMIN
PSYMTL==.-PSYMTT


SUBTTL	PURIFYG ROUTINE

IFN ITS,[
XPURIFY:			;ENTRY POINT TO SETUP A PURQIX
	MOVE T,[SIXBIT \PURQIX\];CHANGE SYSFN1 TO BE A PURQIX
	MOVEM T,SYSFN1
	MOVE T,[SIXBIT \DSK\]	;NEW DEVICE NAME
	MOVEM T,SYSDEV
	MOVE T,[SIXBIT \LSPDMP\]   ;AND FINALLY, NEW SNAME
	MOVEM T,SYSSNM
	MOVEI T,FEATEX		;SPLICE 'EXPERIMENTAL' INTO FEATURES LIST
	MOVEM T,FEATURES
]		;END IFN ITS


IFN ITS+D20,[
PURIFY:
IFN ITS,[			;DOESN'T REALLY WORK FOR D10 YET
 	JRST NOTINIT		;CLOBBERED BY INIT TO "SETO AR1,"
	;SETO AR1,		;FOR PURIFY$G FROM DDT
	MOVE P,[-LFAKP-1,,FAKP-1]
	PUSHJ P,FPURF7
	PUSHJ P,FPURF2
	.VALUE [ASCIZ \:PURIFIED
\]
	JRST .-1
]		;END OF IFN ITS
FPURF2:	SETZB TT,PRSGLK		;ZERO PURE SEGMENT AOBJN PTR
	MOVE R,[NPFFS,,NPFFS+1]	;ZERO PURE FREE STORAGE COUNTERS
	SETZM NPFFS
	BLT R,NPFFY2
	SETZM LDXLPC		;CLEAR # WORDS FREE SO ALWAYS GRAB NEW SET
				; OF SEGMENTS THE FIRST TIME A LINK IS NEEDED
				; START NEW LIST OF SEGMENTS
	SETOM LDXPFG		;SET PURE FLAG
20$	HRLI TT,.FHSLF
	MOVNI R,NPAGS		;SO STEP THROUGH LOSING PURTBL
	MOVE D,[440200,,PURTBL]	; TO DECIDE HOW TO MUNG PAGES
IPUR1:	ILDB T,D		;GET BYTE FOR NEXT PAGE
	JRST .+1(T)
	 JRST IPUR3		;0 - DELETE
	 JRST IPUR4		;1 - IMPURIFY
	 JRST IPUR6		;2 - PURIFY
	MOVEI T,NPAGS(R)	;3 - HAIRY STUFF - DECODE FURTHER
	LSH T,PAGLOG
	CAMGE T,BPSL		;CODE 3 SHOULD NEVER APPEAR
	 .VALUE			; BELOW BINARY PROGRAM SPACE
	MOVE F,@VBPORG		;PAGIFY CURRENT VALUE OF
	ANDI F,PAGMSK		; BPORG DOWNWARD
	CAIGE T,(F)		;ANY CODE 3 PAGE BELOW THAT CAN
	 JRST IPUR6A		; BE PURIFIED
	CAMG T,BPSH		;ANY CODE 3 PAGE BETWEEN BPORG
	 JRST IPUR2		; AND BPSH IS LEFT AS IS
	CAMG T,HINXM		;ANY PAGE BETWEEN BPSH AND HINXM
	 .VALUE			; DAMN WELL BETTER BE 0!!!
	HRRZ F,PDLFL1		;ANYTHING BETWEEN HINXM AND
	LSH F,PAGLOG		; PDLS MUST BE PURE FREE STORAGE
	CAIGE T,(F)
	 JRST IPUR6A
	CAIGE T,BSCRSG		;SCRATCH PAGES ARE IGNORED
	 JUMPL AR1,IPUR3A	;PDL PAGES MAY OR MAY NOT BE FLUSHED, DEPENDING ON AR1
IPUR2:
IT$	ADDI TT,1001
20$	ADDI TT,1
	TLNN D,730000		;ONLY 20 2-BIT BYTES PER WORD, NOT 22
	 TLZ D,770000
	AOJL R,IPUR1
20$	SETZB B,C		;ZERO OUT CRUD
	MOVEI A,TRUTH
	JUMPGE AR1,CPOPJ
	MOVE T,[STDMSK]
	MOVEM T,IMASK
IT$	MOVE T,[STDMS2]
IT$	MOVEM T,IMASK2
	POPJ P,



;;;	IFN ITS+D20

;;; VARIOUS PAGE FLUSHING AND PURIFYING ROUTINES FOR PURIFY


IPUR4:				;MAKE PAGE WRITABLE

IFN ITS,[
	.CALL IPUR9		;CHECK TYPE OF PAGE
	 .VALUE
	JUMPL T,IPUR2		;ALREADY IMPURE
	IOR TT,[4400,,400000]
	JUMPG T,IPUR5
	.CBLK TT,		;NON-EXISTENT - GET A FRESH PAGE
	 .VALUE
	JRST IPUR2
IPUR5:	TLZ TT,4000		;PURE - TRY TO DEPURIFY
	.CBLK TT,
	 JSP F,IP1		;IF WE LOSE, TRY COPYING
	JRST IPUR2

IPUR9:	SETZ
	SIXBIT \CORTYP\
	1000,,400(R)
	402000,,T
]		;END OF IFN ITS

IFN D20,[
	MOVE 1,TT
	JSP T,IPURE$			;MAKE SURE PAGE EXISTS
	TLZ 2,-1#(PA%RD+PA%WT+PA%EX+PA%CPY)
	TLNE 2,(PA%WT)			;SKIP IF NOT ALREADY WRITEABLE
	 JRST IPUR2
	TLON 2,(PA%CPY)			;SKIP IF ALREADY COPYABLE
	  SPACS
	JRST IPUR2

;ARG IN A IS PAGE NUMBER.  PRESERVE  A,TT,D,R
;MAKE SURE PAGE EXISTS.  IF NOT, CREATE SOME 0'S 
;LEAVE RESULT OF RPACS IN B, AND PUT .FHSLF IN LH OF A
IPURE$:	HRLI A,.FHSLF
	RPACS
	TLNE B,(PA%PEX)
	 JRST (T)
	HRL T,A				;SAVE PAGE NUMBER IN LH OF T
	MOVE F,B			;SAVE RPACS CALL IN F
	MOVSI B,.FHSLF			;SOURCE PAGE IS 0, WHICH MUST EXIST
	EXCH A,B
	MOVSI C,(PM%RD+PM%CPY)
	PMAP				;MAKE FOOOLISH PAGE EXIST
	LSH B,9				; [WHICH PROBABLY GOT LOST BY
	HRLI B,1(B)			; THE "SAVE" COMMAND] BY COPYING
	MOVEI C,777(B)			; THE FIRST PAGE OF THE JOB
	SETZM (B)
	MOVSS B
	BLT B,(C)			;FOO! A PAGE OF 0'S
	MOVE B,F
	HLR A,T
	HRLI 1,.FHSLF
	JRST (T)

]		;END OF IFN D20







;MAKE PAGE READ-ONLY

IPUR6A:	MOVEI T,2		;CHANGE PURTBL ENTRY TO 2
	DPB T,D
IPUR6:
IFN ITS,[
	.CALL IPUR9		;CHECK TYPE OF PAGE
	 .VALUE
	JUMPG T,IPUR2		;ALREADY PURE
	JUMPE T,IPUR7		;CAN'T PURIFY A NON-EXISTENT PAGE
	TLZ TT,4400		;PURIFY AN IMPURE PAGE
	TRO TT,400000
	.CBLK TT,
IPUR7:	 .VALUE
	JRST IPUR2
]		;END OF IFN ITS
IFN D20,[
	MOVE 1,TT
	JSP T,IPURE$			;MAKE SURE PAGE EXISTS
	TLZ 2,-1#(PA%RD+PA%WT+PA%EX+PA%CPY)
	TLZE 2,(PA%WT+PA%CPY)		;ALREADY READ-ONLY?
	 SPACS
	JRST IPUR2

]		;END OF IFN D20

;DELETE A PAGE

IPUR3A:	SKIPE NOPFLS		;NOPFLS NON-ZERO => DON'T FLUSH PAGES
	 JRST IPUR2
	DPB NIL,D		;ZERO OUT PURTBL ENTRY
IPUR3:
IFN ITS,[
	TRZ TT,400000
	.CBLK TT,
	 .VALUE
]		;END OF IFN ITS
IFN D20,[
	SETO 1,
	MOVE 2,TT
	HRLI 2,.FHSLF
	SETZ 3,
	PMAP
]		;END OF IFN D20
	JRST IPUR2

]		;END OF IFN ITS+D20


SUBTTL	PURE COPY OF THE READ SYNTAX TABLE


	-1,,0	;FOR NEWRD WILL POINT TO MACRO CHAR LIST
RSXTB2:	PUSH P,CFIX1
	JSP TT,1DIMF
	   NIL		;SHOULD NEVER ACTUALLY CALL
	   0
RCT0:
IFE NEWRD,[		;OLD VERSION OF PURE READTABLE
IFN SAIL,[
		400500,,0	;NULL IS IGNORED
REPEAT 10,	2,,1+.RPCNT	;SAIL CHARS
		500500,,^I	;TAB
		500500,,^J
		400500,,^K
		400500,,^L
		500500,,^M	;CR
REPEAT 22,	2,,^N+.RPCNT	;SAIL CHARS
]		;END IFN SAIL
.ELSE,[
REPEAT 10,	400500,,.RPCNT		;^@ ^A ^B ^C ^D ^E ^F ^G
		2,,^H			;^H
		500500,,^I		;TAB
		400500,,^J		;LINE-FEED
		400500,,^K
		400500,,^L
		500500,,^M		;CARRIAGE-RETURN
REPEAT 3,	400500,,^N+.RPCNT	;^N ^O ^P
IT$		405540,,QCTRLQ		;^Q	watch out for XON/XOFF
IT%		400500,,^Q 		;^Q	protocol under TOPS systems
		400500,,^R		;^R
IT$		405540,,QCTRLS		;^S	watch out for XON/XOFF
IT%		400500,,^S		;^S	protocol under TOPS systemTs
REPEAT 7,	400500,,^T+.RPCNT	;WORTHLESS
		2,,33			;ALT MODE
REPEAT 4,	400500,,^\+.RPCNT	;WORTHLESS
]		;END IFE SAIL
		500500,,40		;SPACE
		2,,41 			;!
		404500,,QRDDBL		;"
		404540,,QRDSHP		;#
REPEAT 3,	2,,"$+.RPCNT		;$ % &
		404500,,QRDQTE		;'
		440500,,"(		;(
		410500,,")		;)
		2,,"*			;*
		10,,"+			;+
		404500,,QI%C%F		;, (INTERNAL-COMMA-FUN)
		50,,"-			;-
		420700,,".		;.
		402500,,"/		;/
REPEAT 10.,	4,,"0+.RPCNT		;DECIMAL DIGITS
		2,,":			;:
		404540,,QRDSEMI		;;
REPEAT 5,	2,,"<+.RPCNT		;< = > ? @
REPEAT 26.,	1,,"A+.RPCNT		;ALPHABETIC
REPEAT 3,	2,,133+.RPCNT		;SQUARE BRACKTES
		22,,"^			;CARET
		62,,"_			;UNDERSCORE
		404500,,QI%B%F		;GRAVE (INTERNAL-BACKQUOTE-FUN)
REPEAT 26.,	501,,"A+.RPCNT		;SMALL LETTERS
		2,,173			;LEFT BRACE
		404500,,QRDVBAR		;VERTICAL BAR
REPEAT 2,	2,,175+.RPCNT		;RIGHT BRACE, TILDE
		401500,,177		;RUBOUT
IFN .-RCT0-200,	WARN [READTABLE LOSSAGE]
		402500,,57		;PSEUDO SLASHIFIER CHARACTER
		440500,,50		;PSEUDO OPEN PARENS
		410500,,51		;PSEUDO CLOSE PARENS
		500540,,40		;PSEUDO SPACE
IFN SAIL,[
	 REPEAT 74, 400500,,204+.RPCNT	;SAIL CONTROLIFIED FUNNY CHARACTERS

REPEAT 2,	400500,,300+.RPCNT	;^@ ^A
		400500,,302		;^B
REPEAT 5,	400500,,300+.RPCNT	;^C ^D ^E ^F ^G
		2,,300+^H		;^H

		500500,,300+^I		;TAB
		500500,,300+^J		;LINE-FEED
		400500,,300+^K
		400500,,300+^L
		500500,,300+^M		;CARRIAGE-RETURN
REPEAT 3,	400500,,300+^N+.RPCNT	;^N ^O ^P
		405540,,QCTRLQ		;^Q
		400500,,300+^R		;^R
		405540,,QCTRLS		;^S
REPEAT 7,	400500,,300+^T+.RPCNT	;WORTHLESS
		2,,33			;ALT MODE
REPEAT 444,	400500,,300+^\+.RPCNT	;WORTHLESS
IFN .-RCT0-1000, WARN [SAIL RCT0 LOSSAGE -- WRONG LENGTH TABLE]
]	;END IFN SAIL
]	;END OF IFE NEWRD

;;; MORE ON NEXT PAGE

IFN NEWRD,[		;NEW VERSION OF PURE READTABLE

REPEAT 11,	RS.BRK+RS.SL1+RS.SL9 + .RPCNT		;WORTHLESS CONTROL CHARS
		RS.BRK+RS.SL1+RS.SL9+RS.WSP + ^I	;TAB
		RS.BRK+RS.SL1+RS.SL9+RS.WSP+RS.VMO + ^J	;LINE-FEED
		RS.BRK+RS.SL1+RS.SL9 + ^K 		;^K (WORTHLESS)
		RS.BRK+RS.SL1+RS.SL9+RS.VMO + ^L	;^L (WORTHLESS)
		RS.BRK+RS.SL1+RS.SL9+RS.WSP + ^M	;CARRIAGE-RETURN
REPEAT 3,	RS.BRK+RS.SL1+RS.SL9 + ^N+.RPCNT	;WORTHLESS
		RS.BRK+RS.SL1+RS.SL9+RS.MAC+RS.FF + ^Q	;^Q (fun is QCTRLQ)
		RS.BRK+RS.SL1+RS.SL9 + ^R 		;^R (WORTHLESS)
		RS.BRK+RS.SL1+RS.SL9+RS.MAC+RS.FF + ^S	;^S (fun is QCTRLS)
REPEAT 7,	RS.BRK+RS.SL1+RS.SL9 + ^T+.RPCNT	;WORTHLESS
		RS.XLT + 33				;ALTMODE
REPEAT 4,	RS.BRK+RS.SL1+RS.SL9 + 34+.RPCNT	;WORTHLESS
		RS.BRK+RS.SL1+RS.SL9+RS.WSP + 40	;SPACE
REPEAT 6,	RS.XLT + "!+.RPCNT			;! " # $ % &
		RS.BRK+RS.SL1+RS.SL9+RS.MAC + "'	;SINGLE-QUOTE
		RS.BRK+RS.SL1+RS.SL9+RS.LP + "(		;LEFT PAREN
		RS.BRK+RS.SL1+RS.SL9+RS.RP + ")		;RIGHT PAREN
		RS.XLT + "*				;ASTERISK
		RS.SL1+RS.SGN + "+			;PLUS
		RS.BRK+RS.SL1+RS.SL9+RS.WSP + ",	;COMMA
		RS.SL1+RS.SGN+RS.ALT + "-		;MINUS
		RS.BRK+RS.SL1+RS.SL9+RS.DOT+RS.PNT + ". ;DOT
		RS.BRK+RS.SL1+RS.SL9+RS.SLS + "/	;SLASH
REPEAT 10.,	RS.SL1+RS.DIG + "0+.RPCNT		;0 - 9
		RS.XLT + ":				;COLON
		RS.BRK+RS.SL1+RS.SL9+RS.MAC+RS.ALT + ";	;SEMI-COLON
REPEAT 5,	RS.XLT + "< + .RPCNT			;< = > ? @
REPEAT 4,	RS.LTR + "A+.RPCNT			;A-D
		RS.LTR + RS.SQX + "E			;E
REPEAT 21.,	RS.LTR + "F+.RPCNT			;F-Z
REPEAT 3,	RS.XLT + 133+.RPCNT			;LBRACK BSLASH RBRACK
		RS.ARR+RS.XLT + "^			;UP-ARROW
		RS.ARR+RS.ALT+RS.XLT + #_		;UNDERSCORE
		RS.BRK+RS.SL1+RS.SL9+RS.MAC + "`	;BACK-QUOTE
REPEAT 4,	RS.LTR + "A+.RPCNT			;A-D L.C.
		RS.LTR+RS.SQX + "E			;E L.C.
REPEAT 21.,	RS.LTR + "F+.RPCNT			;F-Z L.C.
REPEAT 4,	RS.XLT + "{+.RPCNT			;LBRACE VBAR RBRACE TILDE
		RS.BRK+RS.SL1+RS.SL9+RS.RBO + 177	;RUBOUT
		RS.BRK+RS.SL1+RS.SL9+RS.SLS + "/	;PSEUDO SLASH
		RS.BRK+RS.SL1+RS.SL9+RS.LP + "(		;PSEUDO (
		RS.BRK+RS.SL1+RS.SL9+RS.RP + ")		;PSEUDO )
		RS.BRK+RS.SL1+RS.SL9+RS.WSP + 40	;PSEUDO SPACE
]		;END OF IFN NEWRD


TLRCT==<.-RCT0>
SA$ INFORM [READTABLE LENGTH = ]\LRCT
ZZ==LRCT-TLRCT
IFE NEWRD,[
IFL ZZ-1-2, INFORM READER-TABLE-DEFICIENCY,\<3-ZZ>
.ELSE	BLOCK ZZ-3
]		;END OF IFE NEWRD

		NIL,,NIL	;UNUSED
		TRUTH,,0	;(STATUS TTYREAD),,(STATUS ABBREVIATE)
		NIL,,TRUTH	;(STATUS TERPRI),,(STATUS _)   

;;; TTYREAD=NIL => ONLY FORCE FEED CHARS LET READ SEE THE TTY BUFFER
;;; ABBREVIATE: 1.1 => ABBREV FILES, 1.2 => ABBREV FLATSIZE/EXPLODE
   ;;; THE FOLLOWING, "TERPRI",  MAY NO LONGER BE ACTIVE:  (11/01/79 - JONL)
   ;;; TERPRI=T => DO NOT OUTPUT AUTOMATIC NEWLINES
;;; _=T => ALLOW PRIN1/PRINC TO OUTPUT FIXNUMS IN FORM M_N






SUBTTL TOP PAGE PGTOP, AND SOME INSRTS

	MOVEI 1,[.]		;THIS WASTEFUL HAC IS MERELY TO INSURE THAT THE LAST
	MOVEI 2,[.]		;FEW CONSTANTS ON THIS PART ARE WORTHLESS
	MOVEI 3,[.]		;IN CASE THERE ARE  MORE ON PASS2 THAN PASS1

PGTOP TOP,[TOPLEVEL, COMMON, AND RANDOM STUFF]


;;; HERE IS A SUNDER HAC - IT MUST BE ABLE TO FIND 
;;; <LF>$INSRT<SP>NAME<TABS-OR-SPACES>;COMMENTS ON FILE

$INSRT PRINT		;PRINT AND FILE-HANDLING FUNCTIONS

$INSRT ULAP		;UTAPE, LAP, AND AGGLOMERATED SUBRS


$INSRT ARITH		;STANDARD ARITHMETIC FUNCTIONS

;;; REMEMBER THE SUNDER HACK, AND DONT HACK THIS $INSRT
IFN BIGNUM,[
$INSRT BIGNUM		;BIGNUM ARITHMETIC PACKAGE
]


SUBTTL	EVAL, EVALHOOK, AND EVAL-WHEN

	PGBOT EVL

POP3UB:	POPI P,1
POP2UB: POPI P,2
	JRST UNBIND

EVALHOOK:
	JSP TT,LWNACK
	   LA23,,QEVALHOOK
	MOVE D,T
	JSP T,SPECBIND		;BIND "EVALHOOK" TO LAST ARG
	 -1_33. 0,VEVALHOOK
	CAME D,XC-2
	 JRST EVNH3
	PUSH P,[POP2UB]
	MOVE A,-2(P)
	JRST EVNH0		
EVNH3:	PUSH P,[POP3UB]
	PUSH P,-3(P)
	PUSH P,-3(P)
	PUSHJ FXP,AEVAL
EVNH0:	SKIPN V.RSET		;EVALUATE, BYPASSING HOOK CHECK
	 JRST EV0		.SEE STORE
	JRST EVAL0


OEVAL:	JSP TT,LWNACK		;"EXTERNAL" EVAL - LSUBR (1 . 2)
	   LA12,,QOEVAL		;MAY TAKE ALIST AS SECOND ARG
	AOJE T,OEVL1
	PUSH P,[POP2J]		;PHOO! HAVE TO KEEP THE SAME EVALFRAME
	PUSH P,-2(P)		;
	PUSH P,-2(P)
	PUSHJ FXP,AEVAL		;MAKE UP ALIST, POP OFF 2, AND LEAVE ARG IN A
	JRST EVAL

OEVL1:	POP P,A
EVAL:	SKIPN V.RSET		;"INTERNAL" EVAL - ARG IN A
	 JRST EV0
	SKIPN B,VEVALHOOK
	 JRST EVAL0
	JSP T,SPECBIND		;SUPER-RANDOM HACK SO THAT MM
	   VEVALHOOK		; CAN INVENT A ^N FOR LISP
	CALLF 1,(B)
	JRST UNBIND

EVAL0:	SKIPE NIL		;RANDOM PLACE TO CHECK FOR NIL CLOBBERED
	 PUSHJ P,NILBAD
	PUSH P,FXP		;EVAL FRAME FORMAT:
	HRLM FLP,(P)		;	FLP,,FXP
	PUSH P,A		;	SP,,<FORM>
	HRLM SP,(P)		;	$EVALFRAME
	PUSH P,[$EVALFRAME]	;SEE APPLY FOR FORMAT OF APPLY FRAMES
.SEE L$EVALFRAME

;FALLS THROUGH

;FALLS IN

;;; EVALUATE A FORM IN A

EV0:	JUMPE A,CPOPJ		;NIL => NIL, ALWAYS!!!
	MOVEI C,ILIST
	SKOTT A,LS
2DIF JRST (TT),EVTB1-1,QLIST		.SEE STDISP

IFN HNKLOG,[
	TLNE TT,HNK
	 JRST EV0H		;HUNK?
]; End of IFN HNKLOG,

EV0A:	MOVE AR1,(A)		;FUNCTION ON 0(P), place to exit in C
	HLRZ T,AR1		; this routine should put into TT the address
	SKOTT T,LS		; of the place to jump for running the code.
2DIF JRST (TT),EVTB2-1,QLIST		.SEE STDISP
IFN HNKLOG,[
	TLNE TT,HNK		;Hunk?
	  JRST EVAPH		;  Go apply it
EV0ALS:
]; END of IFN HNKLOG,

	HLRZ TT,(T)
	CAIN TT,QLAMBDA
	 JRST EXP3
	CAIE TT,QFUNARG
	 CAIN TT,QLABEL
	  JRST EXP3
	JUMPL C,EV3B
	SKIPE B,VOEVAL
	 JCALLF 1,(B)		;EVALSHUNT
	HLRZ A,AR1
	TLNN C,777740		;MAYBE SAVE FUNCTION NAME IN EV0B
	 MOVEM A,EV0B
	PUSH P,EV0B		;NON-ATOMIC FUNCTION, NOT LAMBDA,
	PUSH P,C		; LABEL, OR FUNARG
	PUSH P,AR1
	PUSHJ P,EV0		;SO EVALUATE THE FORM
	POP P,AR1
	POP P,C
	POP P,EV0B
	JRST EV4		;NOW TRY USING THE RESULT AS A FUNCTION

IFN HNKLOG,[
;; Apply a hunk
EVAPH:	PUSH P,T
	PUSH P,A
	MOVE A,T
	PUSHJ P,USRHNP		;Maybe this is a user-extended hunk?
	MOVE TT,T
	POP P,T
	POP P,A
	JUMPE TT,EV0ALS		;Not ours, just like a list
	JRST EXP3

;; Evaluate a hunk

EV0H:	PUSHJ P,USRHNP		;Maybe this is a user-extended hunk
	JUMPE T,EV0A		;No, go pretend it's a list
	PUSH P,A
	PUSH P,[QOEVAL]
	MOVNI T,2
	XCT SENDI		;Let's send it an EVAL message
				;tail-recursively.
]; END of IFN HNKLOG,

EVTB1:	JRST PDLNKJ		;FIXNUMS EVALUATE TO THEMSELVES
	JRST PDLNKJ		;DITTO FLONUMS
DB$	JRST PDLNKJ		;DITTO DOUBLES
CX$	JRST PDLNKJ		;DITTO COMPLEXES
DX$	JRST PDLNKJ		;DITTO DUPLEXES
BG$	POPJ P,			;GUESS WHAT, FELLAHS
	JRST EE1		;SOME HAIR FOR SYMBOLS
HN$  REPEAT HNKLOG+1, .VALUE	;HUNKS (SHOULD BE CAUGHT BEFORE THIS TABLE)
	JRST EV2		;RANDOMS LOSE
	POPJ P,			;ARRAYS EVAL TO SELVES
IFN .-EVTB1-NTYPES+1, WARN [WRONG LENGTH TABLE]

EV2:	%WTA EMS25		;UNEVALUABLE DATUM (RANDOMNESS)
	JRST EV0

EVTB2:	JRST EV3A		;FIXNUM AS A FUNCTION IS AN ERROR
	JRST EV3A		;DITTO FLONUM
DB$	JRST EV3A		;DITTO DOUBLE
CX$	JRST EV3A		;DITTO COMPLEX
DX$	JRST EV3A		;DITTO DUPLEX
BG$	JRST EV3A		;DITTO BIGNUM
	JRST EE2		;SYMBOLS - THE GOOD CASE
HN$  REPEAT HNKLOG+1, .VALUE	;HUNKS
	JRST EV3A		;IT'S A TRULY RANDOM FUNCTION!
	JRST ESAR		;IT'S AN ARRAY
IFN .-EVTB2-NTYPES+1, WARN [WRONG LENGTH TABLE]




EE1:	PUSHJ P,EVSYM		;EVALUATE SYMBOL
	 POPJ P,			;WIN
	JRST EV0		;LOSE - RETRY


EE2:	SETZ R,			;ZERO R FOR HACK TO TRAP AUTOLOAD LOSS
EE2A:	HRRZ T,(T)		;CAR (X) IS ATOMIC
	JUMPE T,EAL2		;GET FUNCTION DEFINITION OFF ATOM
	HLRZ TT,(T)
	HRRZ T,(T)
	CAIL TT,QARRAY		;SYMBOL HEADERS FOR FUNCTION MARKERS
	 CAILE TT,QAUTOLOAD	; ARE LINEAR IN MEMORY
	  JRST EE2A
   2DIF JRST @(TT),ETT,QARRAY

ETT:	EAR		;ARRAY
	ESB		;SUBR
	EFS		;FSUBR
	ELSB		;LSUBR
	AEXP		;EXPR
	EFX		;FEXPR
	EFM		;MACRO
	EAL		;AUTOLOAD

EAL:	HRRI R,(T)	;NOTE THAT WE SAW AUTOLOAD PROPERTY
	JRST EE2A

EAL2:	JUMPL R,EV3J		;FN UNDEF AFTER AUTOLOAD
	JUMPE R,EV3		;NO AUTOLOAD PROP - TRY EVALING ATOM
	TLNE C,040000		;IS THIS A CASE OF 'APPLYING A MACRO'?
	 JRST EFMER
	MOVEI B,(R)
	HLRZ T,(A)
	PUSHJ P,IIAL
	HLRZ T,(A)
	SETO R,
	JRST EE2A

EFM:	CAIE C,ILIST		;FOUND MACRO FOR EVAL CASE
	 JRST [ TLO C,440000	;BIT 040000 DESIGNATES 'SAW A MACRO'
		JRST EE2A ]	; BUT IGNORE MACROS FOR APPLY
	MOVE B,AR1
	HLRZ AR1,(T)		;COMMENT THIS CROCK
	CAIN A,AR1
	PUSHJ P,CONS1
	CALLF 1,(AR1)		;SO HAND THE FORM TO THE MACRO
	JRST EVAL		; AND RE-EVALUATE THE RESULT

EFX:	HLRZ T,(T)		;FOUND FEXPR
	HLL T,AR1		;SO A FEXPR BEHAVES LIKE AN EXPR
	PUSH P,T		; WHOSE ONE ARG IS CDR OF THE FORM
	HRLI AR1,400000		.SEE IAP4 ;FOR EXPLANATION OF THIS HACK
	PUSH P,AR1		; WHICH ALLOWS FEXPRS AN ALIST ARG, SEE
	MOVNI T,1		; THE CODE AT IAPPLY
	JRST IAPPLY

AEXP:	HLRZ T,(T)		;FOUND EXPR
	HLL T,AR1
EXP3:	PUSH P,T		;FOUND LAMBDA, LABEL, FUNARG
	MOVEI A,(AR1)
CIAPPLY:
	MOVEI TT,IAPPLY
	JRST (C)

EFS:	HLRZ T,(T)		;FOUND FSUBR
	MOVEI C,ESB3		;THIS IS SO WE DON'T EVAL THE ARGS!
	JRST ESB2

ELSB:	PUSH P,CPOPJ		;FOUND LSUBR
	HLLM AR1,(P)
	MOVE R,T
	HLL R,AR1
	MOVEI TT,ELSB1
	HRRZ A,AR1
	JRST (C)

ELSB1:	MOVEI A,NIL		;A HAS NIL WHEN ENTERING AN LSUBR
	HLRZ D,(R)
	SKIPN V.RSET
	 JRST (D)
	HLRZ R,R
	PUSHJ P,ARGCK0		;CHECK OUT NUMBER OF ARGS
	 JRST ESB6
	JRST (D)


ESAR:	SKIPA TT,T		;FOUND SAR
EAR:	 HLRZ TT,(T)		;FOUND ARRAY
	MOVEI R,(TT)
	SKOTT TT,SA
	 JRST EV3A
EAR3:	HRRZ T,ASAR(R)
	CAIN T,ADEAD
	 JRST EV3A		;AHA! THIS ARRAY IS DEAD!
	PUSH P,R
	MOVEI T,EAR1		;MUST DO SOME HAIR SO THAT
	JRST ESB4		; INTERRUPTS WON'T SCREW US

EAR1:	MOVE T,LISAR		;DO NOT MERGE THIS WITH IAPAR1
	JRST @ASAR(T)		.SEE ESB3

ESB:	HLRZ R,AR1		;FOUND SUBR
	HLRZ T,(T)
ESB4:	MOVEI TT,ESB1
ESB2:	MOVEI A,(AR1)		;A GETS LIST OF ARGS
	HLL T,AR1
	PUSH P,T		;STORE ADDRESS OF SUBROUTINE FOR FN
	JRST (C)		;GO SOMEWHERE OR OTHER

ESB1:	PUSHJ P,ARGCHK
	 JRST ESB6
	MOVE TT,[A,,A+1]
	MOVEI A,Q..MIS
	BLT TT,A+NACS-1
	JSP R,PDLA2(T)
ESB3:	HRRZ TT,(P)
	CAIN TT,EAR1		;HACK TO HELP EAR1 WIN
	JRST ESB3C
ESB3A:	SKIPN V.RSET
	POPJ P,			;ADDRESS OF SUBR IS ON STACK
	MOVEI TT,CPOPJ		;WELL, MAYBE DO SOME *RSET HAIR
	HLL TT,(P)
	EXCH TT,(P)
	JRST (TT)

ESB3C:	HRRZ TT,-1(P)
	MOVEM TT,LISAR		;SAR PROTECTED BY BEING IN LISAR
	POP P,-1(P)
	JRST ESB3A


EV3:	SKIPE EVPUNT		;PUNT EVALUATION OF SYMBOL?
	 JRST EV3C
	JUMPL C,EV3B		;C<0 => TOO MANY RE-EVALS OF A FN
	HLRZ A,AR1
	HLRZ A,(A)
	HRRZ A,@(A)		;GET VALUE OF ATOMIC FUNCTION
	CAIN A,QUNBOUND		;IT'S UNBOUND. LOSE, LOSE, LOSE...
	JRST EV3A
	TLNN C,777740		;SAVE FN NAME IN EV0B, MAYBE
	HLRZM AR1,EV0B
EV4:	ADD C,[1_34.]		;THIS SIZE OF THIS QUANTITY CONSTRAINS
EV4B:	HRL AR1,A		; THE # OF TIMES WE MAY RE-EVAL THE FN
	MOVEI A,AR1
	JRST EV0A

EV3C:	CAIE C,ILIST		;RUN OUT OF THINGS TO TRY WHEN LOOKING FOR
	 TLNN C,040000		;'MACRO' BIT -- SET BY EFM 
	  JRST EV3A		; FUNCTION DEF ON A SYMBOL.  DID "APPLY" 
EFMER:	LERR EMS21		;IMPROPER USE OF MACRO


;;; (EVAL-WHEN (. . . EVAL . . .)   e1 e2 . . . en)   does a progn on
;;;	the ei, and returns non-null only if the evaluations were done.
;;;  	The context combined with the first arg list determines if any
;;; 	thing is done -  if there is EVAL in this list, then the progn
;;; 	is done.
EWHEN:	HRRZ C,(A)
	SKOTT C,LS
	 JRST FALSE
	PUSH P,C
	HLRZ B,(A)
	MOVEI A,QOEVAL
	PUSHJ P,MEMQ1
	POP P,B
	JUMPE A,CPOPJ
	JRST IPROGN


SUBTTL SYMEVAL

SYMEV0:	%WTA NASER
SYMEVAL:	JUMPE A,CPOPJ	;SUBR 1
	JSP T,SPATOM
	JRST SYMEV0
	PUSHJ P,EVSYM
	 POPJ P,		;WON
	JRST SYMEVAL		;LOST

;;; EVALUATE ATOMIC SYMBOL. SKIPS ON FAILURE (AFTER DOING ERROR).

EVSYM:	HLRZ T,(A)		;T GETS POINTER TO SYMBOL BLOCK
	HRRZ T,@(T)		;AR1 GETS VALUE FROM VALUE CELL!!!
	CAIN T,QUNBOUND
	 JRST EE1A		;FOOBAR! VALUE CELL CONTAINS UNBOUND
	MOVEI A,(T)		;SO THE VALUE IS THE RESULT OF EVAL
	POPJ P,

EE1A:	%UBV MES6		;UNBOUND VAR
	JRST POPJ1

;;; END OF EVSYM ROUTINE

SUBTTL	APPLY, *APPLY, SUBRCALL, LSUBRCALL, ARRAYCALL, FUNCALL

APPLY:	CAME T,XC-2		;"EXTERNAL" APPLY - SUBR (2 . 3)
	 JRST AP4		;MAY TAKE A THIRD ALIST ARG
	JSP R,PDLA2(T)
APPWT1:	JUMPE B,AP3		;ALLOW NIL AS SECOND ARG
	SKOTT B,LS		;SECOND ARG TO APPLY MUST BE A LIST
	 JRST APPWTA
.APPLY:				;SUBR 2 (*APPLY)
AP3:	SKIPN V.RSET
	 JRST AP3A
	PUSH P,B
	PUSH P,FXP
	HRLM FLP,(P)
	PUSH P,A
	HRLM SP,(P)
	PUSH P,[$APPLYFRAME]
AP3A:	MOVEI AR1,(B)		;"INTERNAL" APPLY -
	HRL AR1,A		; FUNCTION IN A, LIST OF ARGS IN B
	MOVEI A,AR1
	MOVEI C,AP2		;THIS CROCK LETS US SHARE CODE WITH
	JRST EV0A		; EVAL BY PREVENTING EVAL'ING OF ARGS

APPWTA:	EXCH A,B
	WTA [MUST BE A LIST -- APPLY!]
	EXCH A,B
	JRST APPWT1

AP2:	MOVEI T,0		;DE-LISTIFY THE ARGS AND STACK THEM
	JUMPE A,(TT)		; ON THE PDL, AND ALSO COUNT THEM
	PUSH P,(A)		;DOING THINGS THIS WAY AVOIDS
	HLRZS (P)		; DESTROYING ANY OTHER ACS
	HRRZ A,(A)
	SOJA T,.-4

AP4:	JSP TT,LWNACK		;APPLY WITH AN ALIST (GOOD GRIEF!)
	   LA23,,QAPPLY
	MOVEM T,APFNG1
	SKIPE A,(P)		;PURPOSELY CRIPPLING THE POWER OF
	 JSP T,FXNV1		; THE ALIST ROUTINE: FOOEY! - GLS
	PUSHJ P,ALIST		;SO CREATE MORONIC ALIST ENVIRONMENT
	EXCH T,APFNG1
	JSP R,PDLA2(T)
	SKIPE APFNG1		;ALIST RETURNING NON-ZERO IN T =>
	 PUSH P,CAUNBIND	; TWO BIND BLOCKS WERE PUSHED
	PUSH P,CAUNBIND
	JRST AP3

SUBRCALL:
	JSP TT,FWNACK		;LSUBR (2 . 7)
	FA234567,,QSUBRCALL
	JSP TT,JLIST
	ADDI T,1
	JSP R,PDLARG
	POP P,TT
	JSP D,PTRCHK
	PUSHJ P,(TT)
RETTYP:	POP P,D			;PURELY FOR TYPE CHECKING
	CAIN D,QFIXNUM
	JSP T,FXNV1
	CAIN D,QFLONUM
	JSP T,FLNV1
	POPJ P,


%LSUBRCALL:
	JSP TT,FWNACK		;FSUBR
	FA2N,,Q%LSUBRCALL
	JSP TT,JLIST
	MOVEI D,(P)
	ADDI D,(T)
	MOVEI TT,RETTYP
	EXCH TT,1(D)
	JSP D,PTRCHK
	AOJA T,(TT)

PTRCHK:	CAIL TT,BEGFUN
	 CAIL TT,ENDFUN
	  JRST .+2
	   JRST (D)
	CAML TT,BPSL
	 CAML TT,@VBPORG
IFN HISEGMENT,[
	  JRST .+2
	   JRST (D)
	CAIL TT,ENDHI
	 CAML TT,HBPORG
	] 	;END OF IFN hisegment
	  JRST PTRCKE
	   JRST (D)



%ARRAYCALL:
	JSP TT,FWNACK		;FSUBR
	FA76543,,Q%ARRAYCALL
	JSP TT,JLIST
	MOVEI D,(T)
	ADDI D,(P)		;FALLS INTO FUNCALL
%ARR7:	HRRZ A,1(D)
	SKOTT A,SA
	SOJA T,%ARR0
	MOVEI B,CPOPJ
	EXCH B,(D)
	HLRZ TT,@1(D)		.SEE ASAR
	MOVEI F,AS<SX>
	CAIN B,QFIXNUM
	MOVEI F,AS<FX>
	CAIN B,QFLONUM
	MOVEI F,AS<FL>
	TRNN TT,(F)
	JRST %ARR0A
FUNCALL:	MOVEI D,QFUNCALL	;LSUBR (1 . 777)
	JUMPE T,WNALOSE		;(FUNCALL F X1 X2 ... XN) IS LIKE
FUNCA1:	SKIPN V.RSET		; (APPLY F (LIST X1 X2 ... XN))
	AOJA T,IAPPLY		;IN *RSET MODE, WE FAKE
	ADDI T,1		; OUT THE UUO STUFF
	MOVEI TT,(P)		; INTO DOING THE APPLY
	ADDI TT,(T)		; FRAME HACKERY FOR US
	MOVEI B,CPOPJ
	EXCH B,(TT)
	JCALLF 16,(B)



; "VCTRS" is either (), or else a list of the subr address for, in order,
;   (VECTORP  VECTOR-LENGTH  VREF)

;LEXPR-FUNCALL
	%WNA MES20
%LXFC:	aojge t,.-1		   ;Count the function arg
	skipn vctrs
	  jrst liap0
	move a,(p)		   ;get &rest arg to spread
	push fxp,t		   ;Save T from the ferocious compiled fn
	hlrz t,@vctrs
	pushj p,(t)		   ;calls the VECTORP function
	jumpn a,liavec		   ;Bleh, kludgy vectors, do it slow
	pop fxp,t		   ;recover T
liap0:	pop p,a			   ;Get &rest arg to spread, again
	aoja t,liap0b		   ;account for 1 arg being "popped off"

liap0a:	wta [LAST ARG NOT A LIST OR VECTOR - LEXPR-FUNCALL!]
liap0b:	movei tt,(a)
	lsh tt,-seglog
	hrrz tt,st(tt)
	caie tt,QLIST
	 jumpn a,liap0a
liap1:	jumpe a,iapply		   ;on null, exit
	hlrz b,(a)		   ;get CAR
	push p,b		   ;push it on the stack as next arg
	hrrz a,(a)		   ;Next!
	soja t,liap1		   ;and loop, counting

liavec:	hrrz t,@vctrs
	hlrz tt,(t)		   ;address of VECTOR-LENGTH function
	hrrz t,(t)
	hlrz t,(t)
	push fxp,t		   ;address of VREF function
	push fxp,[-1]		   ;"index" to cycle over the vector
	move a,(p)		   ;Get vector
	pushj p,(tt)		   ;calls the VECTOR-LENGTH function
	push fxp,(a)		   ;Save it on FXP
	movn tt,(a)		   ;Get - the length
	addm tt,-3(fxp)		   ;update the argument count
liavc0:	aos tt,-1(fxp)		   ;increment our count
	caml tt,(fxp)		   ;Have we reached the end?
	  jrst liavc9		   ;  Yep, let's get out of here
	move a,(p)		   ;Get vector
	movei b,-1(fxp)		   ;Get index 
	hrrz t,@vctrs
	hrrz t,(t)
	hlrz t,(t)
	pushj p,(t)		   ;calls the VREF function
	exch a,(p)		   ;put it on the stack
	push p,a		   ;Save our vector again
	jrst liavc0		   ;loop the loop

liavc9:	popi p,1		   ;Throw away the vector, we're all through
	popi fxp,3		   ;toss off "length", "index" and "vref-addr"
	pop fxp,t		   ;At last, our argument count
	aoja t,iapply		   ;Don't count function as arg, go apply it


;;;  VERY INTERNAL APPLY, FOR USE PARTICULARLY WITH "CALL" UUO'S
;;;
;;;	STATE OF WORLD AT ENTRANCE TO IAPPLY:
;;;		T HAS -<NUMBER OF ARGS ON PDL>.
;;;		PDL HAS ARGS ON IT; BELOW THEM IS A SLOT
;;;		  WITH THE FUNCTION IN THE RIGHT HALF.
;;;		  THE FUNCTION'S NAME IS MAYBE IN THE LEFT HALF.
;;;	C IS USED PRIMARILY TO POINT TO THIS LATTER SLOT; AND, AS
;;;	  USUAL, THE LEFT HALF HELPS TO LIMIT FUNCTION RE-EVALS.
;;;	IF THERE IS ONLY ONE ARG ON THE STACK, 400000 IN THE LEFT
;;;	  HALF OF THE PDL SLOT MEANS FUNCTION IS A FEXPR, AND MAY
;;;	  THEREFORE TAKE AN EXTRA (A-LIST) ARGUMENT.

IAPPLY:	MOVE C,T		;STATE OF WORLD AT ENTRANCE:
	ADDI C,(P)		; T HAS -<NUMBER OF ARGS ON PDL>
ILP1:	MOVE A,(C)		; NEXT PDL SLOT HAS FUNCTION IN RH, 
	TLZN A,-1
	 HRLM A,(C)		; Save FN in left half in case it's not there
	SKOTT A,LS
2DIF JRST (TT),APTB1-1,QLIST	;FN IS NOT LIST STRUCTURE
IFN HNKLOG,[
	TLNE TT,HNK
	  JRST IAHNK
IALIS:
] ; END IFN HNKLOG,

	HRRZ B,(A)
	HLRZ A,(A)
	CAIN A,QLAMBDA
	 JRST IAPLMB		;IT'S A LAMBDA
	CAIN A,QFUNARG
	 JRST APFNG		;IT'S A FUNARG (MORE GOOD GRIEF!)
	CAIN A,QLABEL
	 JRST APLBL		;IT'S A LABEL (SUPER GOOD GRIEF!)
	PUSH P,C
	PUSH FXP,T
	HRRZ A,(C)
	JUMPL C,IAP2A		;JUMP IF WE'VE RE-EVAL'ED TOO MUCH
	PUSHJ P,EV0		;ELSE EVAL THE FUNCTIONAL FORM
	POP P,C			; AND TRY IT AGAIN...
	POP FXP,T
ILP1B:	MOVE B,(C)
	HRRM A,(C)
	TLO C,400000
	JRST ILP1

APTB1:	JRST IAP2A		;FIXNUMS ARE NOT FUNCTIONS!
	JRST IAP2A		;NOR FLONUMS
DB$	JRST IAP2A		;NOR DOUBLES
CX$	JRST IAP2A		;NOR COMPLEXES
DX$	JRST IAP2A		;NOR DUPLEXES
BG$	JRST IAP2A		;NOR BIGNUMS ALREADY
	JRST IAPATM		;SYMBOLS ARE OKAY, BUT JUST BARELY
HN$  REPEAT HNKLOG+1,	.VALUE	;HUNKS
	JRST IAP2A		;TRUE RANDOMS ARE OUT!
	JRST IAPSAR		;IT'S AN ARRAY - OKAY, I GUESS

IAPATM:	HRRZ B,(A)		;APPLY GOT ATOMIC FUNCTION
	HRRZS 1(C)		;KILL POSSIBLE 400000 BIT DUE TO FEXPR
	TDZA R,R
IAPAT2:	 HRRZ B,(B)
IAPAT3:	JUMPE B,IAPIA1		;GRAB FUNCTION FROM PROP LIST
	HLRZ TT,(B)
	HRRZ B,(B)
	CAIL TT,QARRAY		;REMEMBER, FUNCTION PROPS ARE
	 CAILE TT,QAUTOLOAD	; LINEAR IN MEMORY
	  JRST IAPAT2
   2DIF JRST @(TT),IATT,QARRAY

IATT:	IAPARR		;ARRAY
	IAPSBR		;SUBR
	IAPSBR		;FSUBR
	IAPLSB		;LSUBR
	IAPXPR		;EXPR
	IAPXPR		;FEXPR
	IAPAT2 		;JUST IGNORE MACROS
	IAPIAL		;AUTOLOAD

IAPIAL:	HRRI R,(B)
	JRST IAPAT2

IAPIA1:	JUMPL R,IAP2J
	JUMPE R,IAP2
	MOVEI B,(R)
	PUSH FXP,T
	MOVEI T,(A)
	PUSHJ P,IIAL
	POP FXP,T
	HRRZ B,(A)
	SETO R,
	JRST IAPAT3

IIAL:	PUSH P,A
	HLRZ A,(B)
	PUSHJ P,AUTOLOAD
	JRST POPAJ

IAPSAR:	SKIPA TT,A	;APPLY A SAR
IAPARR:	HLRZ TT,(B)		;APPLY AN ARRAY
	MOVEM TT,LISAR		;FOR INTERRUPT PROTECTION ONLY
	MOVEI R,(TT)
	MOVEI TT,IAPAR1
	JRST IAPSB1

IAPSBR:	HLRZ TT,(B)		;APPLY A SUBR
	HRRZ R,(C)
IAPSB1:	HRRM TT,(C)
	JRST ESB1

IAPAR1:	MOVE TT,LISAR
	JRST @ASAR(TT)


IFN HNKLOG,[
IAHNK:	SKIPN ICALLI		   ;Do we have a CALL interpreter?
	  JRST IALIS
	PUSH P,T
	PUSHJ P,USRHNP		   ;Is this a user hunk?
	EXCH T,TT
	POP P,T
	JUMPE TT,IALIS		   ;Nope, just pretend it's a list
	XCT ICALLI		   ;Otherwise run user's hook
]; -- End IFN HNKLOG,

IAPXPR:	HLRZ A,(B)
	JRST ILP1B

IAPLSB:	MOVEI TT,CPOPJ
	HRRM TT,(C)
	MOVE R,B
	JRST ELSB1

IAP2:	SKIPE EVPUNT		;DON'T EVALUATE FUNCTIONAL VARIABLE?
	 JRST IAP2A
	JUMPL C,IAP2A
	HRRZ A,(C)		;APPLY FUNCTIONAL FROM VALUE CELL
	HLRZ A,(A)
	HRRZ A,@(A)
	CAIE A,QUNBOUND		;FOOBAR! IT'S UNBOUND
	JRST ILP1B
	JRST IAP2A

IAPLMB:	HLRZ TT,(B)	;APPLY A LAMBDA EXPRESSION
	MOVEI D,(TT)
	LSH D,-SEGLOG
	MOVE D,ST(D)
	TLNE D,SY
	 JUMPN TT,IAP3
	SETZ D,		;IMPORTANT THAT D BE NON-NEG - SEE IAP4
	MOVEI C,(TT)
	HRRZ B,(B)
	MOVE R,T
IPLMB1:	JUMPE T,IPLMB2	;NO MORE ARGS
	JUMPE TT,QF2A	;TOO MANY ARGS SUPPLIED
IAP5:	HLRZ A,(TT)
	SKIPE V.RSET
	 JUMPN A,IAP5C
IAP5C:	MOVEI AR1,1(T)
	ADD AR1,P
	HLLZ D,(AR1)	;SEE COMMENT AT EFX - ALLOWS
	HRLM A,(AR1)	; A FEXPR TO TAKE AN A-LIST ARG
	HRRZ TT,(TT)
	AOJA T,IPLMB1

IAP5B:	MOVEI D,(A)
	LSH D,-SEGLOG
	MOVE D,ST(D)
	TLNN D,SY
	 JRST LMBERR
	JRST IAP5C

IPLMB2:	JUMPN TT,IAP4	;TOO FEW ARGS SUPPLIED
	JUMPN R,IPLMB4	;NO LAMBDA LIST IN FUN
	POP P,TT
	HRRI TT,CPOPJ	;LAMBDA LIST IS NULL
	SKIPE V.RSET
	 PUSH P,TT
	HRRZ A,(B)
	JUMPN A,LMBLP
	HLRZ A,(B)
	JRST EVAL

IPLMB4:	MOVEM SP,SPSV
	SKIPA
IPLM4A:	 PUSHJ P,BIND		;BIND VALUES TO LAMBDA VARS
IPLM4B:	POP P,AR1		;FUN HAS A NON-NL LAMBDA LIST
	HLRZ A,AR1
	SKIPE A			;IF NIL AS VARIABLE, DON'T BIND THIS ARG
	 AOJLE R,IPLM4A		;TO BIND A NON-NIL VARIABLE
	AOJLE R,IPLM4B		;THIS WINS EVEN IF PREVIOUS INS DOESN'T JUMP
	SKIPN V.RSET
	 JRST IPLMB5
	HRRI AR1,CPOPJ 
	TLNE AR1,-1
	 PUSH P,AR1
IPLMB5:	JSP T,SPECX
	HRRZ AR1,(B)
	PUSH P,CUNBIND
	HLRZ A,(B)
	JUMPE AR1,EVAL		;A GENERALIZED LAMBDA:  NON-NULL LAMBDA LIST
LMBLP:	PUSH P,B		;FOR GENERAL LAMBDAS, EVALS SEQUENCE OF EXP'S
	HLRZ A,(B)
	PUSHJ P,EVAL
LMBLP1:	POP P,B
	HRRZ B,(B)
LMBLP2:	JUMPN B,LMBLP
	POPJ P,

IPROGN:	MOVEI A,NIL		;INTERNAL PROGN
	JRST LMBLP2


IAP3:	MOVEI A,(TT)	;APPLY LEXPR
	MOVN TT,T
	CAIL TT,XHINUM
	JRST LXPRLZ
	MOVEI AR1,CPOPJ
	HRRM AR1,(C)
	MOVEI AR1,IN0(TT)
	MOVEM SP,SPSV
	PUSHJ P,BIND
	MOVEI C,(C)
	EXCH C,ARGLOC
	HRLI C,ARGLOC
	PUSH SP,C		;BIND ARGLOC TO LOC OF ARGS ON PDL
	EXCH AR1,ARGNUM
	HRLI AR1,ARGNUM
	PUSH SP,AR1		;BIND ARGNUM TO NUMBER OF ARGS
	JSP T,SPECX
	HRRZ B,(B)
	PUSHJ P,LMBLP
	SKIPN T,@ARGNUM
	JRST UNBIND
	HRLS T
	SUB P,T
	JRST UNBIND
CUNBIN:	JRST UNBIND


IAP4:	JUMPGE D,QF3A	
	AOJN R,QF3A
	JRST IAP4A	;FEXPR OF TWO ARGS


SUBTTL	FUNCTION, QUOTE, DECLARE, COMMENT, SETQ, AND, OR

FUNCTION:	SKIPA D,CQFUNCTION	;FEXPR 1
QUOTE:	MOVEI D,QQUOTE			;FEXPR 1
	JUMPE A,WNAFOSE
	HRRZ TT,(A)
	JUMPE TT,$CAR
	JRST WNAFOSE

DECLARE:	MOVEI A,QDECLARE	;FSUBR (IGNORES ARG)
	POPJ P,

$COMMENT:	MOVEI A,Q$COMMENT	;FSUBR (IGNORES ARG)
	POPJ P,


SETQ:	PUSH P,A
SET1:	PUSHJ FXP,SET0	;DO ONE STEP OF A "MULTIPLE" SETQ.
	SKIPE (P)
	 JRST SET1
	JRST POP1J

SET0:	HLRZ A,@(P)	;ASSUMES ARGLIST PTR STORED IN 0(P)
	JSP D,SETCK	;ENTERED BY PUSHJ FXP,SET0
	HRRZ B,@(P)
	JUMPE B,SETWNA
	PUSH P,A	;ATOM TO BE SETQ'D
	HLRZ A,(B)
	HRRZ B,(B)
	MOVEM B,-1(P)	;CDR THE ARGLIST
	PUSHJ P,EVAL
	POP P,AR1
	JSP T,.SET
	POPJ FXP,


$AND:	HRLI A,TRUTH
$OR:	HLRZ C,A
	PUSH P,C
ANDOR:	HRRZ C,A
	JUMPE C,POPAJ
	MOVSI C,(SKIPE (P))
	TLNE A,-1
	MOVSI C,(SKIPN (P))
	XCT C
	JRST POPAJ
	MOVEM A,(P)
	HLRZ A,(A)
	PUSHJ P,EVAL
	EXCH A,(P)
	HRR A,(A)
	JRST ANDOR



SUBTTL	PROG, PROGV, RETURN, GO

PROG:	HLRZ AR2A,(A)		;FSUBR
	HRRZ A,(A)
PRG1:	JUMPE AR2A,PRG1Z	;EITHER THEY ARE NIL OR
	SKOTT AR2A,LS		; MUST HAVE A LIST FOR PROG VARS
	 JRST PRGER1
PRG1Z:	PUSH P,A
	SETZ C,
	JSP T,PBIND		;BIND PROG VARIABLES TO NIL
	POP P,A
	PUSHJ P,PG0		;EVALUATE PROG BODY
	 MOVEI A,NIL
	JRST UNBIND		;UNBIND VARIABLES

PG0:	PUSH P,PA3
	PUSH P,PA4
	PUSH P,SP
	PUSH P,FXP
	PUSH P,FLP
LPRP==.-PG0+1	;LENGTH OF PROG PDL, IE HOW MUCH PROG HAS
	MOVEM P,PA4	;CAUSED TO BE PUSHED
	HRLS A
	MOVEM A,PA3
PG1:	HLRZ T,PA3
PG1A:	JUMPE T,PRXIT	;NORMAL EXIT 
	HLRZ A,(T)
	HRRZ T,(T)
	HRLM T,PA3
	SKOTT A,LS
	JRST PG1
	PUSHJ P,EVAL
PG0A:	JRST PG1

;;; JSP T,VBIND		;LIST OF SYMBOLS IN AR2A, VALUES IN A
;;; BINDS EACH SPECIAL VARIABLE IN THE LIST TO CORRESPODNING VALUES.
;;; IF VALUES LIST TOO SHORT, "UNBOUND" GETS USED FOR PROGV, AND
;;; NIL OTHERWISE.

VBIND:	MOVEI C,(A)		;INTERPRETED AND COMPILED PROGV COME HERE
	SKIPA R,[QUNBOUND]	;USE UNBOUND AS VALUE OF EXTRA VARIABLES
PBIND:	 MOVEI R,NIL		;USE NIL AS VALUE OF EXTRA VARS
	MOVEM SP,SPSV		;BIND PROG VARIABLES
	JUMPE AR2A,SPECX
	MOVEI AR1,NIL
PBIND1:	HLRZ A,(AR2A)		;NEXT VARIABLE
	HLRZ AR1,(C)		;NEXT VALUE
	SKIPN C			;HAVE WE RUN OFF THE END OF THE LIST?
	 MOVEI AR1,(R)		;YES, USE DEFAULT VALUE
	SKOTT A,SY
	 JRST PBIND2
	CAIE A,TRUTH		;DONT BIND NON-SYMBOLS, NOR "T"
	PUSHJ P,BIND
PBIND2:	HRRZ C,(C)
	HRRZ AR2A,(AR2A)
	JUMPN AR2A,PBIND1
	JRST SPECX

PROGV:	HRRZ B,(A)		;FSUBR
	HRRZ C,(B)
	HLRZ A,(A)
	HLRZ B,(B)
	PUSH P,C
	PUSH P,B
	PUSHJ P,EVAL		;GET LIST OF VARIABLES
	EXCH A,(P)
	PUSHJ P,EVAL		;GET LIST OF VALUES
	POP P,AR2A
	JSP T,VBIND		;BIND VARIABLES
	POP P,B
	PUSHJ P,LMBLP		;EVAL REST LIKE LAMBDA BODY
	JRST UNBIND

RETURN:	JSP T,BKERST	;SUBR 1
	MOVE P,PA4
	AOS -LPRP+1(P)	;RETURN CAUSES SKIP
PRXIT:	POP P,FLP	;PROG EXIT
	POP P,FXP
	POP P,TT
	PUSHJ P,UBD0
	POP P,PA4
ERRP4:	POP P,PA3
RHAPJ:	MOVEI A,(A)
CQFUNCTION:	POPJ P,QFUNCTION

GO:	JSP TT,FWNACK
	FA1,,QGO
	HLRZ A,(A)
GO2:	JSP T,SPATOM	;LEAVES TYPE BITS IN TT
	JRST GO3
GO1:	JSP T,BKERST
	HRRZ T,PA3
PG5:	JUMPE T,EG1
	HLRZ TT,(T)
	HRRZ T,(T)
	CAIN TT,(A)
	JRST PG5A
	TLNN A,400000		;4.9 BIT => GO TAG IS NUMERIC
	JRST PG5
	MOVEI D,(TT)
	LSH D,-SEGLOG
	SKIPL D,ST(D)
	TLNN D,FX+FL
	JRST PG5
	MOVE TT,(TT)
	CAME TT,(A)
	JRST PG5
PG5A:	MOVE P,PA4
	MOVE FLP,(P)
	MOVE FXP,-1(P)
	HRRZ TT,-2(P)
	PUSHJ P,UBD
	JRST PG1A

GO3:	TLNN TT,FX+FL
	JRST GO3A
GO3B:	MOVE TT,(A)		;SET 4.9 BIT OF A IF TAG IS NUMERIC
	CAML TT,[-XLONUM]
	CAIL TT,XHINUM		; BUT NOT INUM
	TLO A,400000
	JRST GO1

GO3A:	PUSHJ P,EVAL		;IF ARG TO GO ISN'T ATOMIC, DO ONE EVAL AND TRY AGAIN
	MOVEI TT,(A)
	LSH TT,-SEGLOG
	MOVE TT,ST(TT)
	TLNE TT,FX+FL
	JRST GO3B
	TLNE TT,SY
	JRST GO1
	JRST EG1

SUBTTL	DO FUNCTION

DO:	PUSH P,PA4
	SETZM PA4
	PUSH FXP,R70		;A "DO SWITCH" TO MARK EXPANDED FORMAT
	PUSH P,A
	HLRZ A,(A)
	SKOTT A,LS		;HUNKS WIN AS WELL AS LISTS
	 JUMPN A,DO4A
	HRROM A,(FXP)
	HLRZ A,@(P)		;SETUP FOR MULTIPLE INDICES
	HRRZ C,@(P)
	HLRZ B,(C)
	JRST DO4

DO4A:	MOVE A,(P)		;SINGLE INDEX DO
	HRRZ B,(A)
	HRRZ B,(B)
	HRRZ B,(B)
	MOVE C,B
DO4:	HRRZ C,(C)
	MOVEM A,(P)		;	(P)   PROG BODY
DO4C:	SKOTT B,LS
	 JUMPN B,DOERRE
	PUSH P,B		;	-1(P)    ENDTEST
	PUSH P,C		;	-2(P)	DO VARS LIST
	MOVE A,-2(P)
	MOVSI R,600000		;EVALUATE AND SETUP INITIAL VALUES
	SKIPN -1(P)
	 MOVSI R,400000		;200000 BIT SAYS STEPPERS ARE OKAY
	PUSHJ FXP,DO5
	SKIPN -1(P)
	 JRST DO4D
DO7:	HLRZ A,@-1(P)
	PUSHJ P,EVAL
	JUMPN A,DO8
DO7A:	MOVE A,(P)
	PUSHJ P,PG0		;DO PROG BODY (MAY SKIP ON RETURN STATEMENT)
	 JRST DO2
DO9:	MOVE B,-2(P)
	SUB P,R70+3		;BREAK OUT OF BODY BY RETURN STATEMENT
	POP P,PA4
	SUB FXP,R70+1
	JUMPN B,UNBIND
	POPJ P,

DO8:	SKIPN A,(FXP)
	 JRST DO9		;SIMPLE DO FORMAT
	HRRZ B,@-1(P)		;DO PASSED ENDTEST, AND RETURNS A VALUE
	PUSHJ P,IPROGN
	JRST DO9

DO2:	MOVE A,-2(P)
	MOVEI R,0		;DO STEPPING FUNCTIONS
	PUSHJ FXP,DO5
	JRST DO7

DO4D:	MOVE A,(P)
	PUSHJ P,PG0
	SETZ A,			;DEFAULT VALUE OF ONCE-THROUGH DO IS NIL
	JRST DO9

DO5:	JUMPE A,DO6		;DOES PARALLEL SETQS  - ON LISTS LIKE (I V1 V2)
	PUSH P,A		;WILL DO (SETQ I V1) IF R < 0
	SKIPE -1(FXP)		;WILL DO (SETQ I V2) IF R > 0
	 HLRZ A,(A)		;IF DOSW SAYS SINGLE INDEX, THEN ONLY ONE LIST
DO5Q:	MOVEI B,(A)
	SKOTTN A,SY		;A SINGLETON SYMBOL
	 JRST DO5Q1		;TREAT AS (<SYMBOL> NIL)
	JUMPGE R,DO5F		;Not first time through?
				;First time through:
	SKOTT A,LS		;Does various checks on the variable specs.
	 JRST DOERR		;BAD VAR LIST
	HLRZ A,(B)
	JSP T,SPATOM
	 JRST DOERR
	TLNE R,200000
	 JRST DO5F
	HRRZ A,(B)		;Check for steppers in wierd case of DO
	JUMPE A,DO5F
	HRRZ A,(A)
	JUMPN A,DO5ER		;EXTRANEOUS STEPPER
DO5F:	HLRZ A,(B)
	HRLM A,(P)
	HRRZ A,(B)
	JUMPL R,DO5E		;First time through?
	JUMPE A,DO5B
	HRRZ A,(A)
	JUMPN A,DO5D
DO5B:	POP P,A
	SOJA R,DO5C

DO5Q1:	JUMPGE R,DO5B
	HRLZS A
	EXCH A,(P)
	JRST DO5C

DO5E:	JUMPE A,DO5G		;(I) IS SAME AS (I NIL) ON INITIAL VALUE
DO5D:	HLRZ A,(A)
	PUSH FXP,R
	PUSHJ P,EVAL
	POP FXP,R
DO5G:	HLL A,(P)
	EXCH A,(P)		;NOW (P) HAS  ATOM,,VALUE
DO5C:	HRRZ A,(A)
	SKIPN -1(FXP)
	 MOVEI A,0		;SO THAT SINGLE FORMAT DO WILL DROP OUT
	AOJA R,DO5

DO6:	TRNN R,-1		;[(SETQ I V1) FROM ABOVE]
	POPJ FXP,		;FIRST TIME THROUGH, WE ALLOW OLD BINDINGS
	JUMPGE R,DO6C		;TO BE REMEMBERED ON THE SPDL FOR UNBINDING
	HRRZS R
	MOVEM SP,SPSV
DO6A:	POP P,AR1
	HLRZ A,AR1
	PUSHJ P,BIND
	SOJG R,DO6A
	JSP T,SPECX
	POPJ FXP,

DO6C:	POP P,AR1	;DURING THE STEPPING PHASE, AS OPPOSED TO
	HLRZ A,AR1	;THE INITIALIZATION PHASE, WE LET NO BINDINGS
	PUSHJ P,BIND	;ACCUMULATE ON THE SPDL
	JSP T,SETXIT
	SOJG R,DO6C
	POPJ FXP,

SUBTTL	COND, ERRSET, ERR, CATCH, THROW, CASE, IF, *CATCH, *THROW,
;	UNWIND-PROTECT, CATCHALL, CATCH-BARRIER
COND1:	HRRZ A,(B)
COND:	JUMPE A,CPOPJ	;ENTRY
	PUSH P,A
	HLRZ A,(A)
	HLRZ A,(A)
	CAIN A,TRUTH
	 JRST CON3
	CAME A,VT.ITY
	 PUSHJ P,EVAL
CON3:	POP P,B
	JUMPE A,COND1	;IF FIRST OF COND PAIR IS TRUE
	HLRZ B,(B)
	SKIPA
COND2:	POP P,B
	HRRZ B,(B)
	JUMPE B,CPOPJ	;LOOP FOR GENERALIZED COND PAIR
	PUSH P,B
	HLRZ A,(B)
	PUSHJ P,EVAL
CON2:	JRST COND2


BKERST:	SKIPN TT,PA4
	 JRST BKRST1
	TLZ TT,-1
	SKIPE B,CATRTN
	 JRST BKRST2
BKRST3:	SKIPE B,ERRTN
	 CAILE TT,(B)
	  JRST (T)		;NO TROUBLESOME CATCHS OR ERRSETS
BKRST4:	MOVEI TT,BKERST
BKRST0:	MOVEM TT,-LERSTP(B)	;BREAK UP A TROUBLESOME CATCH OR ERRSET, E.G.
	HRRZI TT,(B)		;WE WAN'T TO GET RID OF THIS FRAME, HANDLE ALL UNWIND-PROTECTS
				; INCLUDING THE FRAME WE WANT TO FLUSH
	PUSHJ FXP,UNWPRO
	CAILE TT,(P)		;IF P LESS THAN FRAME OF INTEREST, THEN IT WAS AN
				; UNWIND-PROTECT FRAME AND UNWPRO THREW IT AWAY.  JUST
				; RETURN TO OUR CALLER.
	 JRST (T)
				;ELSE THROW THE FRAME AWAY BY HAND
	MOVE P,B		;(PROG (A)  (ERRSET (RETURN (FOO A))))
	JRST ERR1		;AND THEN TRY BKERST AGAIN

BKRST2:	CAILE TT,(B)
	 JRST BKRST3		;CATCH ISN'T TROUBLESOME, SO TEST FOR ERRSETS
	JRST BKRST4		;AH, CATCH IS TROUBLESOME!

BKRST1:	MOVEI A,LGOR
	%FAC EMS22

ERRSET:	JSP TT,FWNACK
	FA12,,QERRSET
	MOVEI C,TRUTH
	HRRZ B,(A)
	JUMPE B,ERRST3
	PUSH P,A
	HLRZ A,(B)
	PUSHJ P,EVAL
	MOVEI C,(A)
	POP P,A
ERRST3:	JSP T,ERSTP
	MOVEM P,ERRTN
	MOVEM C,ERRSW
	HLRZ A,(A)
	PUSHJ P,EVAL
ERRNX:	PUSHJ P,NCONS	;NORMAL EXIT
	JRST ERUN0

ERR:	JSP TT,FWNACK
	FA012,,QERR
	JUMPE A,ERR2
	HRRZ B,(A)
	JUMPE B,.+3
	 HLRZ B,(B)
	 JUMPE B,ERR3A
	HLRZ A,(A)	;EVAL BEFORE UNBLOCKING
	PUSHJ P,EVAL
	JRST ERR2

ERR3A:	SKIPN ERRTN
	 JRST LSPRET
	MOVEI T,ERR3
	EXCH T,-LERSTP(P)
	JRST ERR0	;UNBLOCK THE ERRSET, THEN
ERR3:	SKIPE A		;EVAL THE ARG TO ERR
	 HLRZ A,(A)
	PUSH P,T
	JRST EVAL


;(*CATCH <tag-or-list-of-tags> e1 . . . en)
; TAG OR TAG-LIST IS EVALUATED.  THEN E1 THROUGH EN ARE EVALED.  IF A THROW
; OR *THROW IS DONE THEN IS LIKE A REGULAR CATCH.
.CATCH:	PUSH P,A		;SAVE POINTER TO ARGS
	HLRZ A,(A)		;EVAL TAG/TAG-LIST
	PUSHJ P,EVAL
	HRLI A,CATSPC\CATLIS	;FLAG IT AS TAG-LIST
	SKOTT A,LS		;IS IT A LIST?
	 HRRZS A		; NO IT ISN'T LIST
.CATC1:	POP P,B			;RESTORE POINTER TO ARGS
	JSP TT,CATPS1
	HRRZ B,(B)		;CDR THE LIST OF ARGS
	PUSHJ P,IPROGN		;IMPLICIT PROGN AROUND THEM
	JRST THRALL		;THEN BREAK-UP CURRENT CATCH FRAME


; (CATCH-BARRIER <list-of-tags> E1 . . . En)
; LIST-OF-TAGS IS EVALUATED.  THEN E1 THROUGH EN ARE EVALED.  IF A THROW
; OR *THROW IS DONE THEN IF TAG IS IN LIST-OF-TAGS, THE CATCH-BARRIER RETURNS,
; ELSE AN UNSEEN-CATCH-TAG ERROR IS GENERATED
CATCHB:	PUSH P,A		;SAVE POINTER TO ARGS
	HLRZ A,(A)		;EVAL TAG/TAG-LIST
	PUSHJ P,EVAL
CATCB2:	SKOTT A,LS		;IS IT A LIST?
	 JRST CATCB1		;NOPE, ERROR
	HRLI A,CATSPC\CATLIS\CATCAB ;YES, FLAG CATCH FRAME CORRECTLY
	JRST .CATC1		;REST IS JUST LIKE *CATCH

CATCB1:	WTA [MUST BE A LIST OF TAGS - CATCH-BARRIER!]
	JRST CATCB2


;(CATCHALL function e1 . . . en)
; FUNCTION IS A FUNCTION OF TWO ARGS.  E1 THROUGH EN ARE EVALED, AND IF NO
; THROW IS DONE THE VALUE OF EN IS RETURNED.  IF ANY THROW IS DONE, FUNCTION
; IS INVOKED WITH THE FIRST ARG BEING THE THROW TAG AND THE SECOND BEING THE
; THROWN VALUE.  THE VALUE OF THE FUNCTION IS THEN RETURNED AS THE VALUE
; OF THE CATCHALL.
CATCHALL:
	PUSH P,A		;SAVE POINTER TO ARGS
	HLRZ A,(A)		;EVAL FUNCTION
	PUSHJ P,EVAL
	HRLI A,CATSPC\CATALL	;FLAG AS A CATCHALL
	JRST .CATC1		;REST IS LIKE *CATCH

;(UNWIND-PROTECT e u1 u2 . . . un)
; EXECUTES U1 THRU Un WHEN THE "CONTOUR" OF THE UNWIND-PROTECT IS EXITED.
; IF e TERMINATES NORMALLY, THEN U1 THRU UN ARE EVALUATED AND THE VALUE
; RETURNED BY e IS RETURNED.  IF A NON-LOCAL EXIT OCCURS THRU AN UNWIND-PRO
; FRAME, THEN U1 THRU UN ARE EVALED AND THE EXIT CONTINUES.
UNWINP:	HRRZ B,(A)		;GET CDR OF ARG LIST
	HRLI B,CATUWP\CATSPC	;AN UNWIND-PROTECT FRAME
	MOVEM B,CATID
	PUSH FXP,P		;SAVE CURRENT STATE OF STACK
	JSP T,ERSTP
	MOVEM P,CATRTN
	HLRZ A,(A)		;CAR OF ARG LIST
	PUSHJ P,EVAL		;EVALUATE IT
	HRRZ TT,(FXP)		;NOW MUST RUN THE UNWIND PROTECT FUNCTIONS
	PUSHJ FXP,UNWPRO	;UNDO THE UNWIND-PROTECT FRAME
	POPI FXP,1		;REMOVE THE SAVED PDL POINTER FROM FXP
	POPJ P,			;THEN RETURN THE VALUE OF e

;ERROR TRAP FOR UNWIND-PROTECT, SHOULD NEVER GET HERE!
UNWERR:	LERR [SIXBIT \UNWIND-PROTECT LEFT DUMMY RETURN ADR ON STACK!\]

;COMPILED UNWIND-PROTECT, ENTER WITH JSP TT, CONTINUATION IS AT PC C(TT)+1
PTNTRY::
UNWINC:	PUSH P,[UNWERR]		;IF GETS HERE, HMM...
	AOS TT			;POINT TO START OF CONTINUATION
	HRLI TT,CATUWP\CATCOM\CATSPC ;AN UNWIND-PROTECT FRAME
	MOVEM TT,CATID
	JSP T,ERSTP
	MOVEM P,CATRTN
	JRST -1(TT)		;RETURN TO COMPILED CODE

;COME HERE TO CLOSE UP AN UNWIND PROTECT.  CALLED WITH JSP TT,
PTEXIT::
UNWINE:	MOVEM TT,-LEP1-4(P)	;SAVE RETURN ADR (AN EXTRA SLOT IS ON P)
	MOVEI TT,-LEP1(P)	;ADR TO UNWIND TO
	PUSHJ FXP,UNWPRO	;UNDO THE UNWIND-PROTECT FRAME
	POPJ P,			;THEN RETURN THE VALUE OF e

;(*THROW TAG VAL) SUBR
.THROW:	EXCH A,B		;THROW1 WANTS TAG IN B, VAL IN A
	JRST THROW1		;THEN DO A THROW


;;; WITHOUT-INTERRUPTS:  ROUTINES WHEN PWIOINT GETS BOUND AND UNBOUND

;;; CALLED from SPECBIND, new value in
;;; R has new value, T has address of word with address in right half.

WIOSPC:	PUSH P,TT
	HRRZ TT,(T)		   ;Get address we were trying to clobber
	CAIN TT,PWIOINT		   ;Our special hack location?
	  JRST WIOSP0		   ;  yes, hack it
	POP P,TT
	EXCH R,@(T)		   ;Otherwise redo instruction to get real int
	JRST SPEC4A		   ;And continue with the SPECBIND if continued


WIOSP0:	MOVEI TT,(R)		   ;New value to TT
	SKIPE REALLY		   ;If UNWPR1 has it living on the stack
	 SKIPA R,@REALLY	   ; Get old value for SPEC4A from there
	  MOVE R,UNREAL		   ;  Else normal.
	JUMPE TT,WIOSP1		   ;NIL, use as is
	CAIE TT,QTTY		   ;TTY, that's meaningful
	 MOVNI TT,1		   ;Else use -1
WIOSP1:	PUSHJ P,WIOBN0		   ;Store into UNREAL, maybe run CHECKU
	POP P,TT
	JRST SPEC4A

;;;CALLED FROM BIND, NEW VALUE IN AR1
WIOBND:	HRRZ TT,UNREAL		   ;CURRENT VALUE
	HRRM TT,(SP)		   ;REMEMBER INSTEAD OF MEANINGLESS VALUE
	MOVEI TT,(AR1)
	JUMPE TT,WIOBN0		   ;NIL, USE AS IS
	CAIE TT,QTTY		   ;TTY, THAT'S MEANINGFUL
	 MOVNI TT,1		   ;ELSE USE -1
WIOBN0:	JUMPL TT,WIOBN1
	PUSH P,A
	PUSH FLP,D		;Can't use FXP because of the SFX hack
	PUSH FLP,F
	MOVE A,TT
	PUSHJ P,ABIND3
	PUSHJ P,CHECKU
	POP SP,SPSV		   ;SO RE-OPEN THE BIND-BLOCK
	POP FLP,F
	POP FLP,D
	POP P,A
	POPJ P,			   ;RETURN FROM BIND

WIOBN1:	MOVEM TT,UNREAL
	POPJ P,

;;; CALLED FROM AFTER UNBIND -- (FLP) HAS OLD VALUE IN LH.  CAN ONLY DESTROY T.
WIOUNB:	EXCH D,(FLP)		   ;GET OLD VALUE, SAVE D
	PUSH FLP,F		   ;SAVE F ALSO -- CHECKU MAY CLOBBER
	PUSH P,A		   ;A WILL GET NEW (OLD) VALUE OF UNREAL
	HLRZ A,D		   ;FIGURE OUT REAL OLD VALUE
	CAIN A,-1		   ;IF HALFWORD -1, THEN TURN INTO FULLWORD
	 MOVNI A,1
	SKIPE REALLY
	  JRST WIOUN1
	PUSHJ P,CHECKU		   ;RUN INTERRUPTS AS APPROPRIATE
WIOUN0:	POP P,A			   ;RESTORE AC'S AND RETURN
	POP FLP,F
	POP FLP,D
	POPJ P,

WIOUN1:	MOVEM A,@REALLY		   ;Store it in the saved slot
	JRST WIOUN0

CASEQ:;	TDZA R,R		;FLAG IN R WHETHER CASE/Q
;CASE:	SETOI R,
	JUMPE A,CPOPJ		;ENTRY, RETURN NIL IF NO ARGS
	PUSH P,A		;SAVE POINTER TO ARG LIST
	HLRZ A,(A)		;GET EXPRESSION TO MATCH AGAINST
CASEE:;	PUSH FXP,R
	CAIE A,TRUTH		;FOR SPEED, CHECK FOR SPECIAL KIND
	 PUSHJ P,EVAL
;	POP FXP,R
	JUMPE A,CASES		;NIL IS A SYMBOL
	MOVE T,A
	LSH T,-SEGLOG
	MOVE T,ST(T)
	TLNE T,FX		;FIXNUM EXPRESSION?
	 JRST CASEF
	TLNE T,SY		;SYMBOL AS EXPRESSION?
	 JRST CASES
	WTA [ -- ARGUMENT TO CASEQ IS NEITHER A FIXNUM NOR A SYMBOL!]
	JRST CASEE		;WIN IF USER TRIES AGAIN

CASEF:	MOVSI T,FX		;TEST AGAINST FIXNUMS ONLY
	JRST CASE1

CASES:	MOVSI T,SY		;TEST AGAINST SYMBOLS ONLY
CASE1:	POP P,B			;POINTER TO CASE'S ARGUMENTS
	PUSH P,A		;EQ TEST AGAINST SYMBOL RETURNED
	HRRZ A,(B)		;THE LIST OF MATCHING SETS AND EXPRS
CASE1E:	PUSH P,A
	HLRZ A,(A)		;THE POINTER TO THE NEXT SET/EXPRS PAIR
	HLRZ A,(A)		;THE LIST OF MATCHES OR THE SINGLE MATCH
CASE1H:	CAIE A,TRUTH		;IF T THEN AN 'OTHERWISE' CLAUSE
	 CAMN A,VT.ITY 		; Maybe a NIL 'truthity', i.e., #T ?
	  JRST CASEM
	MOVEI TT,(A)
	LSH TT,-SEGLOG
	MOVE TT,ST(TT)
	TLNN TT,LS		;IS THE MATCHING SET A LIST?
	 JRST CASE1Q		;NO, HANDLE SPECIALLY
CASE1D:	PUSH P,A
	HLRZ A,(A)		;GET NEXT ELEMENT
CASE1B:;JUMPE R,CASE1A		;DON'T EVALUATE EXPR IF CASEQ
;	CAIN A,TRUTH
;	 JRST CASE1A
;	PUSH P,T		;SAVE FLAGS OVER EVAL
;	PUSHJ P,EVAL
;	POP P,T
;	SETO R,			;MAKE SURE FLAG IS STILL CORRECT
CASE1A:	TLNE T,SY		;IF TESTING FOR SYMBOLS
	 JUMPE A,CASE1Z		;THEN NIL IS A VALID ONE
	MOVEI TT,(A)
	LSH TT,-SEGLOG
	TDNN T,ST(TT)		;MATCHING TYPE?
	 JRST CASE1C
CASE1Z:	POP P,B
	JSP TT,CASECK		;NON SKIP IF MATCH
	 JRST CASEM		;MATCH FOUND, PROCESS EXPRESSIONS
	HRRZ A,(B)		;GET THE CDR
	JUMPN A,CASE1D		;IF MORE MATCHING IN THIS LIST THEN PROCEED
CASE1G:	POP P,A			;RESTORE THE LIST OF PAIRS POINTER
	HRRZ A,(A)		;THE CDR POINTS TO NEXT CONS
	JUMPN A,CASE1E		;IF NOT END OF LIST THEN PROCEED
	POPI P,1		;GET RID OF MATCHING POINTER
	POPJ P,

CASE1Q:;JUMPE R,CASEBQ		;IF CASEQ LEAVE UNEVALUATED
;	PUSH P,T		;SAVE FLAG
;	CAIE A,TRUTH
;	 PUSHJ P,EVAL
;	POP P,T
;	SETO R,			;FLAG MUST BE SET IF DID EVAL
CASEBQ:	TLNE T,SY		;IF TESTING FOR SYMBOLS
	 JUMPE A,CASEBZ		;THEN NIL IS A VALID ONE
	MOVEI TT,(A)		;TYPE CHECK UNEVALUATED MATCHING ARG
	LSH TT,-SEGLOG
	TDNN T,ST(TT)
	 JRST CASEAQ		;NOT MATCH
CASEBZ:	JSP TT,CASECK		;NON-SKIP IF MATCH
	 SKIPA
	  JRST CASE1G		;MATCH NOT FOUND
CASEM:	POP P,A			;GET BACK POINTER TO CONS WITH MATCH
	HLRZ A,(A)
	MOVEM A,(P)		;CLOBBER MATCHING ARG WITH EXPR LIST
	SETZ A,			;MAKE SURE RETURN NIL IF NOTHING TO DO
	JRST COND2

CASECK:	TLNN T,FX		;USE EQ FOR ATOMS, = FOR FIXNUMS
	 JRST CASEEQ
	MOVE D,(A)		;GET THE FIXNUM
	CAME D,@-1(P)		;CHECK USING =
	 JRST 1(TT)		;SKIP FOR FAILURE
	JRST (TT)
CASEEQ:	CAME A,-1(P)		;EQ CHECK
	 JRST 1(TT)		;SKIP FOR FAILURE
	JRST (TT)

CASEAQ:	WTA [DOES NOT MATCH MATCHING EXPRESSION TYPE!]
	JRST CASE1H

CASE1C:	POP P,A
	WTA [DOES NOT MATCH MATCHING EXPRESSION TYPE!]
	JRST CASE1D

IFN 0,[				;TEMPORARILY(?) REMOVED
IF:	PUSH P,A
	HLRZ A,(A)		;TEST EXPRESSION
	CAIE A,TRUTH
	 PUSHJ P,EVAL
	POP P,B
	HRRZ B,(B)
	SKIPN A
	 JRST IF1A		;FOR FAILURE EVALUATE ALL REMAINING FORMS
	HLRZ A,(B)
	CAIE A,TRUTH
	 PUSHJ P,EVAL
	POPJ P,

IF1A:	PUSH P,B		;COND REQUIRES POINTER TO LIST ON STACK
	JRST COND2
];END IFN 0

SUBTTL "SYSTEM" MACROS - SMALL FSUBR'S TO PARALLEL COMPILER MACROS
;;; CURRENTLY:  PUSH, POP,

COMMENT | FOO! SOMETHING HAS TO GO!

SETF:	PUSH P,A
	JRST SETF1

SETF2S:	PUSHJ FXP,SET0		;Handle a symbol case as if it were SETQ
SETF5:	HRRZ B,@(P)		;BASIC LOOP DOWN ARGLIST
	HRRZ B,(B)
	JUMPE B,POP1J
	MOVEM B,(P)
SETF1:	HLRZ A,@(P)
	SKOTT A,LS
	 JRST SETF2S		;setting a symbol?
	HLRZ A,(A)
	SKOTT A,SY
	 JRST SETF3		;Random format?
	MOVEI B,QSTF.X		;or has SETF-X property?
	PUSHJ P,GET1		; then go slow route thru SETF3
	JUMPN A,SETF3
	MOVE B,@(P)
	HLRZ A,B		;Else check if it is one of the simple 
	HLRZ A,(A)
	JSP T,IC.RP		; forms that we can un-do by hand
	 JRST SETF1B
SETF2C:	PUSH FXP,TT		;A "CARCDR"ING, with "icarcdrp" code in TT
	PUSH P,B		;  or else TT has -1 for PLIST
	HLRZ A,B
	HRRZ A,(A)
	PUSHJ P,EVALCAR		;Compute <arg>  in  "(CARCDR <arg>)"
	EXCH A,(P)
	PUSHJ P,EVALCAR		;Compute <val> in "(SETF (CARCDR <arg>) <val>)"
	MOVE B,A
	POP P,A
	POP FXP,TT
	JUMPL TT,STF2C2
	LDB D,[0606_30 TT]		;Code for the "tail" operation and
	JUMPE D,STF2C1
	LDB D,[2706_30 %CARCDR-2(D)]	;  find the "boy" number for it
	JSP T,CARCDR(D)			;Execute the "tail" operation
STF2C1:	TRNN TT,1_12.			;Bit 2.3 of code number is 1 iff 
	 TDZA D,D			;  "head" operation is RPLACD
	  MOVEI D,RPLACD-RPLACA
	PUSHJ P,RPLACA(D)
	JRST SETF5
STF2C2:	PUSHJ P,SETPLIST
	JRST SETF5

SETF1B:	CAIE A,Q$GET		;Continue discerning for known operation
	 CAIN A,QCXR
	  JRST SETF2G		;GET, CXR
	CAIN A,Q%ARRAYCALL
	 JRST SETF2A		;ARRAYCALL
	SETO TT,
	CAIN A,QPLIST
	 JRST SETF2C		;PLIST (A BIT LIKE CARCDR)
	MOVE C,A
	MOVEI B,QMACRO
	PUSHJ P,GET1
	JUMPN A,SETF1C
	MOVE A,C
	MOVEI B,QAUTOLOAD
	PUSHJ P,GET1
	JUMPE A,SETF3
	PUSH P,A
	MOVE A,C
	MOVEI B,QLSTF.X
	PUSHJ P,GETL5		; BUT MAYBE WE'VE ALREADY TRIED TO AUTOLOAD?
	POP P,T
	JUMPE A,SETF3
	MOVE A,T		;IF AUTOLOADABLE, MAY PUT A MACRO ON
	PUSHJ P,AUTOLOAD	; SO LOAD IN THE AUTOLOADABLE FILE
	MOVE A,C		; AND TRY AGAIN TO FIND MACRO PROP
	MOVEI B,QMACRO
	PUSHJ P,GET1
	JUMPN A,SETF1C
	MOVE A,C
	MOVEI B,NIL
	MOVEI C,QSTF.X
	PUSHJ P,PUTPROP
	JRST SETF3
SETF1C:	HLRZ A,@(P)
	CALLF 1,Q%MCX.		;MACROs (or STRUCTURE-selector ings)
	JUMPE A,SETF3		; - then merely MACROEXPAND-1* and go 
	HLRZ A,(A)		;   around loop again
	HRRZ B,@(P)
	JSP T,%CONS
	MOVEM A,(P)
	JRST SETF1


SETF2A:	HLRZ A,B
	HLRZ B,(B)
	PUSH P,A
	PUSH P,B
	JRST STF2A7
STF2A5:	PUSHJ P,STOREE
STF2A7:	SETZM LISAR
	PUSHJ P,EVNH0		;EVALUATE ARRAY REFERENCE WITHOUT HOOKING IT
	SKIPN A,LISAR		;ALWAYS CHECK FOR THIS GROSS LOSS
	 JRST STF2A5
	SKIPN V.RSET
	 JRST STF2A9
	JSP T,ARYSIZ		;GET SIZE OF ARRAY IN WORDS IN TT
	TLNN R,200000		;=> NEGATIVE INDEX
	 CAIG TT,(R)		;THERE'S PROBABLY A FENCE-POST FOR SX ARRAYS HERE
	  JRST STF2A5
STF2A9:	PUSH FXP,R
	EXCH A,(P)
	PUSHJ P,EVAL		;EVALUATE THE NEW VALUE
	POP P,LISAR
	POP FXP,R
	JSP T,.STORE
	POPI P,1
	SETZM LISAR
CSETF5:	JRST SETF5

SETF2G:	PUSH P,CSETF5		;"GET" OR "CXR"
	HLRZ A,B
	HRRZ A,(A)		;  "(SETF (GET <arg1> <arg2>) <val>)
	HRRZ B,(A)
	PUSH P,B
	PUSHJ P,EVALCAR		;Eval <arg1>
	EXCH A,(P)
	PUSHJ P,EVALCAR		;Eval <arg2>
	PUSH P,A
	HRRZ A,@-3(P)
	PUSHJ P,EVALCAR		;Eval <val>
	HLRZ T,@-3(P)
	HLRZ T,(T)
	CAIN T,Q$GET
	 JRST STF2G2
	MOVE C,A
	POP P,B
	POP P,A
	PUSHJ P,RPLACX		;REMEMBER return addr was pushed above
	MOVE A,C
	POPJ P,
STF2G2:	MOVE B,A		; at SETF2G
	POP P,C
	POP P,A
	JRST PUTPROP

EVALCAR:  HLRZ A,(A)		;save a couple of instructons! by coming here
	  JRST EVAL


SETF3:	POP P,A			;Can't hack it, so give up and let the
	SETZ B,			; B=() ==> For Value
	CALLF 2,QISTFX		; +INTERNAL-SETF-X expander expand it.
	JRST EVAL		; and then do it.

| 	;END OF DAMNABLE CUT-OUT OF SETF FSUBR


;;; Standard simple PUSH case (for symbols) is as follows:
  ;     (DEFUN PUSH FEXPR (L) 
  ;	      (DO ((X L (CDDR X)) (SYM) (VAL))
  ;		  ((NULL X) VAL)
  ; 		(SETQ SYM (CADR X) VAL (EVAL (CAR X)))
  ; 		(SET SYM (CONS VAL (SYMEVAL SYM)))))
;;; Standard simple POP case (for symbols) is as follows:
  ;(DEFUN POP FEXPR (X)
  ;	(PROG2
  ; 	   () 
  ;        (COND ((NULL (CDR X)) (CAR (SYMEVAL (CAR X))))
  ;		 ('T (SET (CADR X) (CAR (SYMEVAL (CAR X))))))
  ;	   (SET (CAR X) (CDR (SYMEVAL (CAR X))))))
;;;  Otherwise, we try substituting +INTERNAL-PUSH-X (or +INTERNAL-POP-X) 
;;;   for the "PUSH" (or "POP"),  and let the (autoloadable) macro
;;;   expander handle it.


$PUSHER: POP P,A
	%WTA TNILER
$PUSH:	JSP TT,FWNACK
	 FA2,,Q$PUSH
	PUSH P,A		;SAVE THE ARGUMENT POINTER
	PUSHJ P,CADR
	JUMPE A,$PUSHER		;SPECIAL-CASE CHECK FOR NIL AND T
	CAIN A,TRUTH
	 JRST $PUSHER
	JSP T,SPATOM		;CHECK FOR STANDARD CASE
	 JRST $PUSH1
	HLRZ A,@(P)		;GET THE "VALUE" TO BE PUSHED
	PUSHJ P,EVAL		; AND EVALUATE IT
	EXCH A,(P)		;SAVE THE RESULT, AND GET THE ARG POINTER
	JSP T,%CADR		;GET THE SECOND "ARGUMENT"
	PUSH P,A		;SAVE POINTER TO SYMBOL
	PUSHJ P,EVSYM		;GET SYMBOL'S VALUE
	 JFCL			;IF SKIP RETURN USE NEW USER VALUE
	MOVE B,-1(P)		;GET THE THING TO BE PUSHED
	JSP T,%XCONS		;PUSH ON THE "STACK"
	POP P,AR1		;GET BACK POINTER TO SYMBOL
	JSP T,.SET		;STORE BACK THE NEW "STACK" POINTER
	POPI P,1
	POPJ P,


$POPER: POP P,A
	%WTA TNILER
$POP:	JSP TT,FWNACK
	 FA12,,Q$POP
	PUSH P,A
	PUSHJ P,CDR
	JUMPE A,$POP4
	PUSHJ P,CAR
	JUMPE A,$POPER
	CAIN A,TRUTH
	 JRST $POPER	
	JSP T,SPATOM
	 JRST $POP1
$POP4:	HLRZ A,@(P)		;GET THE "STACK" POINTER
	JUMPE A,$POPER
	CAIN A,TRUTH
	 JRST $POPER	
	JSP T,SPATOM
	 JRST $POP1
	PUSHJ P,EVAL		;AND GET THE "STACK"
	PUSH P,(A)		;SAVE THE 1ST CONS OF THE "STACK" ON P
	HRRZ A,@-1(P)		;GET THE PLACE TO POP INTO
	JUMPE A,$POP2		;NOT SPECIFIED, JUST RETURN THE TOP OF "STACK"
	HLRZ A,(A)
	HLRZ AR1,(P)		;CAR OF STACK IS VALUE BEING POPPED
	JSP T,.SET1		;SET THE SYMBOL INTO WHICH IT IS POPPING
$POP2:	HRRZ AR1,(P)		;NOW CDR THE "STACK" AND RE-SET INTO STK-PTR
	HLRZ A,-1@(P)
	JSP T,.SET1
	HLRZ A,(P)		;RETURN THE CAR OF THE NEW "STACK"
	POPI P,2
	POPJ P,


$POP1:	SKIPA C,[QIPOX]		;"PUSH" AND "POP" CANT BE HANDLED
$PUSH1:	  MOVEI C,QIPUX		; So invoke the LISP-coded +INTERNAL-foo-X
	POP P,A			; which expands it for us
	SETZ B,			; B=() means "For Value"
	CALLF 2,(C)
	JRST EVAL		;and EVAL the result

TNILER: SIXBIT \CANT "PUSH" OR "POP" TO T AND NIL!\



SUBTTL	STORE, BREAK, SIGNP

STORE:	JSP TT,FWNACK
	   FA2,,QSTORE
	HLRZ B,(A)
	PUSH P,B
	HRRZ A,(A)
	HLRZ A,(A)
	PUSHJ P,EVAL		;EVALUATE SECOND ARGUMENT FIRST!
	PUSH P,A
STORE7:	HRRZ A,-1(P)
	SETZM LISAR
	PUSHJ P,EVNH0		;EVALUATE ARRAY REFERENCE WITHOUT HOOKING IT
	SKIPN A,LISAR		;ALWAYS CHECK FOR THIS GROSS LOSS
	 JRST STORE5
	SKIPN V.RSET
	 JRST STORE9
	JSP T,ARYSIZ		;GET SIZE OF ARRAY IN WORDS IN TT
	TLNN R,200000		;=> NEGATIVE INDEX
	 CAIG TT,(R)		;THERE'S PROBABLY A FENCE-POST FOR SX ARRAYS HERE
	  JRST STORE5
STORE9:	POP P,A
	SUB P,R70+1
	JSP T,.STORE
	SETZM LISAR
	POPJ P,


BREAK:	JSP TT,FWNACK		;FSUBR (1 . 2)
	   FA12,,QBREAK
	HLRZ B,(A)		;BKPT NAME
	HRRZ A,(A)
	JUMPE A,$BRK0		;NO SECOND ARG => ALWAYS BREAK
	HLRZ A,(A)		;TO-BREAK-OR-NOT SWITCH
	PUSH P,B
	PUSHJ P,EVAL		;THIS IS A CROCK!!!
	POP P,B
	JRST $BREAK		;A = BREAKP, B = BREAKID


SIGNP:	JSP TT,FWNACK		;FSUBR 2
	   FA2,,QSIGNP
	PUSH P,(A)
	HLRZ A,(A)
	PUSH P,A
SIGNP0:	PUSHJ P,PNGET
	HLRZ A,(A)
	MOVS T,(A)
	HRRZ A,(A)
	JUMPN A,SIGNPE
	MOVNI A,6
	CAIE T,@SPTB+6(A)
	 AOJL A,.-1
	JUMPGE A,SIGNPE
	HLLZ A,SPTB+6(A)
	SUB P,R70+1
	EXCH A,(P)
	HLRZ A,(A)
	PUSHJ P,EVAL
	PUSHJ P,NUMBERP
	JUMPE A,POP1J
	POP P,T
	HRRI T,TRUE
	XCT T
	JRST FALSE

SPTB:
IRP Q,,[L,E,LE,G,GE,N]
	JUMP!Q TT,(ASCII \Q\)
TERMIN

SUBTTL	PROG2, PROGN, EQ, RPLACA, RPLACD


PROG1:	SKIPA R,XC-1
PROG2:	MOVNI R,2
	CAMLE T,R
	 JRST PRG12Z
	HRLI T,-1(T)
	ADD T,P
	SUBM T,R
	MOVE A,(R)
	MOVEM T,P
	POPJ P,

PRG12Z:	MOVEI D,QPROG2
	CAIE R,2
	 MOVEI D,QPROG1
	JRST WNALOSE

PROGN:	AOJG T,FALSE
	POP P,A
PROGN1:	JUMPE T,CPOPJ
	HRLI T,-1(T)
	ADD P,T
	POPJ P,

EQ:	CAMN A,B	;SUBR 2 - POINTER IDENTITY PREDICATE
	JRST TRUE
	JRST FALSE

RPLACA:	SKOTT A,LS
	 JRST RPLCA0
	TLNE TT,PUR+VC
	 JRST RPLCA1
	HRLM B,(A)
	POPJ P,

RPLACD:				;SUBR 2 - CLOBBER CDR OF FIRST ARG WITH SECOND
	SKOTT A,LS
	 JRST RPLCD2
	TLNE TT,PUR
	 JRST RPLCD1
RPLCD3:	HRRM B,(A)
	POPJ P,

RPLCD2:	JUMPE A,RPLCD0		;(RPLACD NIL FOO) IS ALWAYS A LOSS
	SKIPE T,VCDR
	 CAIN T,QLIST		;IF CDR = NIL OR LIST, THEN BOMBOUT
	  JRST RPLCD0		;SINCE ARG IS NOT LIST OR NIL
	CAIN T,QSYMBOL
	 TLNE TT,SY
	  JRST RPLCD3		;IF NOT CDR = SYMBOL, THEN ANYTHING GOES
	JRST RPLCD0

	PGTOP EVL,[EVAL, APPLY, STUFF OPEN-CODED BY COMPLR]



$INSRT GCBIB		;GARBAGE COLLECTOR AND ALLOCATION STUFF

$INSRT READER		;READ AND RELATED FUNCTIONS

$INSRT ARRAY		;ARRAY PACKAGE

$INSRT FASLOA		;FASLOAD 

$INSRT QIO		;NEW MULTIPLE FILE I/O FUNCTIONS


SUBTTL	INTERRUPT HANDLERS

	PGBOT INT

IFN ITS,[

PIHOLD:	.SPICLR,,R70 		;WORD TO ".SUSET" TO TURN OFF INTERRUPT SYSTEM
PINBL:	.SPICLR,,XC-1 		;WORD TO ".SUSET" TO TURN ON INTERRUPT SYSTEM

;;; NEW-STYLE INTERRUPT TRANSFER VECTOR

.SEE IMASK
;;; STANDARD VALUES TO PUT IN .MASK AND .MSK2 USER VARIABLES.
;;; INTERRUPTS NORMALLY ENABLED ARE:
;;;	PARITY ERROR
;;;	WRITE INTO READ-ONLY MEMORY
;;;	MEMORY PROTECTION VIOLATION
;;;	ILLEGAL OPERATION
;;;	PDL OVERFLOW
;;;	I/O CHANNEL ERROR
;;;	RUN TIME CLOCK
;;;	REAL TIME CLOCK
;;; ALSO, FOR THE USELESS SWITCH:
;;;	CLI DEVICE INTERRUPT
;;;	SYSTEM GOING DOWN/REVIVED
;;;	SYSTEM BEING DEBUGGED
;;;	CONTROL OF TTY JUST GIVEN BACK TO LISP
;;; (SSTATUS MAR) MAY ALSO ENABLE THE MAR INTERRUPT
.SEE SSMAR

SA% STDMSK=%PIPAR+%PIWRO+%PIMPV+%PIILO+%PIPDL+%PIIOC+%PIRUN+%PIRLT
SA$ STDMSK=%PIMAI+%PIPAR+%PIWRO+%PIMPV+%PIILO+%PIPDL+%PIIOC+%PIRUN+%PIRLT
IFN USELESS, STDMSK=STDMSK+%PIDWN+%PIDBG+%PIATY
DBGMSK=STDMSK-<%PIPAR+%PIMPV+%PIILO+%PIATY>

;;; ALL I/O CHANNELS ARE ENABLED, AND ALL JOB CHANNELS FOR USELESS SWITCH.

STDMS2==177777
IFN JOBQIO, STDMS2==STDMS2+<377,,>
DBGMS2==STDMS2


DEFINE INTGRP HANDLER+PIRQC=0,IFPIR=0,DF1=STDMSK+%PIMAR-<%PIPDL+%PIPAR+%PIWRO+%PIMPV+%PIILO>,DF2=STDMS2
	PIRQC
	IFPIR
	DF1
	DF2
	HANDLER
TERMIN


INTVEC:	D_6+3,,INTPDL		;PDL FOR PUSHING INTERRUPT STUFF
				;ACS D, R, F ARE SAVED ALONG WITH OTHER CRUD


SA$		INTGRP MEMERR,PIRQC=%PIMAI+%PIPAR+%PIWRO+%PIMPV+%PIILO,DF1=STDMSK+%PIMAR-%PIPDL	;MEMORY AND OPCODE ERRORS
SA%		INTGRP MEMERR,PIRQC=%PIPAR+%PIWRO+%PIMPV+%PIILO,DF1=STDMSK+%PIMAR-%PIPDL	;MEMORY AND OPCODE ERRORS

SA$		INTGRP MAIINT,PIRQC=%PIPDL		;SAIL MAIL INTERRUPT
		INTGRP PDLOV,PIRQC=%PIPDL		;PDL OVERFLOW
		INTGRP IOCERR,PIRQC=%PIIOC		;I/O CHANNEL ERROR
IFN USELESS,	INTGRP CLIINT,PIRQC=%PICLI		;CLI INTERRUPT
IFN USELESS,	INTGRP TTRINT,PIRQC=%PIATY		;TTY RETURNED TO JOB
IFN USELESS,	INTGRP SYSINT,PIRQC=%PIDWN+%PIDBG	;SYS DOWN OR BEING DEBUGGED
IFN JOBQIO,	INTGRP JOBINT,IFPIR=[377,,]		;INFERIOR PROCEDURES
		INTGRP CHNINT,IFPIR=177777		;I/O CHANNEL INTERRUPTS
TTYDF1==:.-3		.SEE UINT0
TTYDF2==:.-2
IFN USELESS,	INTGRP MARINT,PIRQC=%PIMAR		;MAR BREAK
		INTGRP RUNCLOCK,PIRQC=%PIRUN		;RUNTIME ALARMCLOCK
		INTGRP REALCLOCK,PIRQC=%PIRLT		;REAL TIME ALARMCLOCK

LINTVEC==:.-INTVEC	;LENGTH OF INTERRUPT VECTOR

;;; NOTE THE EFFECT OF HAVING THE ALARMCLOCKS LAST:
;;;	IOC AND CHANNEL INTERRUPT HAPPEN FIRST, BUT WHEN
;;;	THE PION HAPPENS INSIDE UINT0 THE ALARMCLOCK GETS
;;;	ITS TURN IMMEDIATELY.  FURTHERMORE, THE REAL TIME
;;;	CLOCK GETS SLIGHTLY HIGHER PRECEDENCE.
]		;END OF IFN ITS


IFN D20,[
;;; TOPS-20 INTERRUPT HANDLER
;;; INTERRUPTS NOMRALLY ENABLED ARE:
;;;	PDL OVERFLOW
;;;	ILLEGAL INSTRUCTION
;;;	ILLEGAL MEMORY READ
;;;	ILLEGAL MEMORY WRITE
;;;	NONEXISTANT PAGE REFERENCE
;;;	VARIOUS CHARACTERS ENABLED FOR INTERRUPTS:
;;;		^A, ^B, ^D, ^E, ^F, ^G, ^V, ^W, ^X, ^Z


;;; CHANNEL ASSIGNMENTS:
;;;	1) PDL OV
;;;	2) ILLEGAL INSTRUCTION, ILL MEM R & W, OTHER SYNC INTERRUPTS
;;;	3) ASYNCHRONOUS INTERRUPTS

DISMSK==0			;GENERATE IMPORTANT INTERRUPTS MASK
IRP FOO,,[.ICPOV,.ICILI,.ICIRD,.ICIWR,.ICNXP]
    DISMSK==DISMSK+<1_<35.-FOO>>
TERMIN

STDMSK==DISMSK			;GENERATE STANDARD INTERRUPT MASK
IRP FOO,,[.ICDAE]
    STDMSK==STDMSK+<1_<35.-FOO>>
TERMIN
STDMSK==STDMSK+<770000,,007777>	;ALSO INCLUDE ALL USER ASSIGNABLE CHANNELS
DBGMSK==STDMSK			;FOR NOW, MASKS ARE EQUIVALENT

;CHANNEL TABLE (ASSIGNS A PRIORITY LEVEL AND HANDLER ADR TO EACH CHANNEL)
CHNTAB:
REPEAT 6, 3,,INTASS+<.RPCNT*3> 	;FIRST 6 ASSIGNABLE INTERRUPTS
	0 ? 0 ? 0		;ARITHMETIC OVERFLOWS
	1,,$PDLOV		;PLDOV
	0 ? 0 			;E-O-F AND DATA-ERROR
	0 ? 0 ? 0		;RESERVED TO DEC
	2,,INTILO		;ILLEGAL INSTRUCTION
	2,,INTIRD		;ILLEGAL MEMORY READ
	2,,INTIWR		;ILLEGAL MEMORY WRITE
	0 ? 0 ? 0 ? 0		;RESERVED, AND ?
	2,,INTNXP 		;NON-EXISTANT PAGE
	0			; CHANNEL 23. LOSES!
REPEAT CINTSZ-6, 3,,INTASS+<6+.RPCNT>*3 ;REMAINING ASSIGNABLE INTERRUPTS
IFN .-CHNTAB-36., WARN [WRONG NUMBER ENTRIES IN CHNTAB?]

;LEVEL TABLE - WHERE TO STORE PC FOR INTERRUPT AT EACH PI LEVEL
LEVTAB:	0,,INTPC1
	0,,INTPC2
	0,,INTPC3


;;; TOPS-20 INTERRUPT HANDLING ROUTINES

;;; CALLED AT STARTUP TO REINITIALIZE THE INTERRUPT SYSTEM
ENBINT:	MOVEI 1,.FHSLF		;MANIPULATE OURSELVES
	MOVE 2,[LEVTAB,,CHNTAB]	;INTERRUPT PC STORAGE TAB,,CHANNEL LOC TAB
	SIR			;SPECIFY THE TABLES
	SETZ T,			;LOOP OVER AND ASSIGN TTY INTERRUPT CHANNELS
ENBIN2:	SKIPG 1,CINTAB(T)	;THIS ENTRY USED FOR TTY INTERRUPT?
	 JRST ENBIN1		;NOPE, GO ON
	MOVSS 1			;CHARACTER GOES IN LEFT HALF
	HRRI 1,(T)		;CHANNEL IN RIGHT HALF
	CAIL T,6		;RELOCTAION NECESSARY?
	 ADDI 1,24.-6		;YES, MAKE REAL CHANNEL NUMBER
	ATI			;ASSIGN TERMINAL INTERRUPT CHANNEL
ENBIN1:	CAIGE T,CINTSZ-1	;DONE?
	 AOJA T,ENBIN2
	MOVEI 1,.FHSLF		;ENABLE APPROPRIATE CHANNELS
	MOVE 2,[STDMSK]		;ENABLE STANDARD INTERRUPTS
	MOVEM 2,IMASK		;THIS IS CURRENT INTERRUPT MASK
	MOVEM 2,OIMASK		;THIS IS ALSO THE OLD-MASK
	AIC
	MOVEI 1,.FHSLF		;ENABLE OUR INTERRUPT SYSTEM
XCTPRO
	EIR
	SETZB 1,2		;DON'T LEAVE RANDOMNESS IN PROTECTED ACS
NOPRO
	POPJ P,

;REENABLES INTERRUPTS AFTER THEY HAVE BEEN DISABLED BY DALINT OR DISINT
REAINT:	PUSH P,1
	PUSH P,2
XCTPRO
	AOSE INTALL		;DISABLED ALL INTS?
	 SKIPA 2,OIMASK		;NO, USE OLD INTERRUPT MASK
	  SKIPA 2,IMASK		;ELSE USE CURRENT MASK
	   MOVEM 2,IMASK	;THIS IS NOW THE CURRENT MASK
	MOVEI 1,.FHSLF		;REENABLE INTERRUPTS FOR OURSELF
	AIC
	POP P,2
	POP P,1
NOPRO
	POPJ P,

;THIS ROUTINE DISABLES ALL INTERRUPTS FROM OCCURING
;THE FLAG INTALL IS SET SAYING TO TELL THE RE-ENABLE ROUTINE TO RESTORE
; INTERRUPTS FROM IMASK RATHER THAN OIMASK
WARN [THINK ABOUT USING 'DIR' FOR DALINT]
DALINT:	PUSH P,1
	PUSH P,2
XCTPRO
	PISTOP
	POP P,2
	POP P,1
NOPRO
	POPJ P,

;DISABLE ALL BUT IMPORTANT INTERRUPTS
;IMASK IS MOVED TO OIMASK, AND IMASK IS SETUP TO NEW CURRENT MASK VALUE
DISINT:	PUSH P,1		;WE WILL NEED TWO WORKING ACS
	PUSH P,2
XCTPRO
	MOVE 2,IMASK		;GET CURRENT INTERRUPT MASK
	MOVEM 2,OIMASK		;UPDATE OLD MASK
	AND 2,[DISMSK]		;ONLY ALLOW IMPORTANT INTERRUPTS
	MOVEM 2,IMASK		;NEW MASK
	MOVEI 1,.FHSLF
	AIC			;MAKE SURE THE IMPORTANT INTERRUPTS ARE ON
	SETCA 2,
	DIC			;BUT ONLY THE IMPORTANT INTERRUPTS
	POP P,2
	POP P,1
NOPRO
	POPJ P,

;;; DISMISS AN INTERRUPT
DSMINT:
XCTPRO
	AOS DSMSAV		;POINT TO NEXT FREE LOCATION (A SMALL STACK)
	MOVEM 1,@DSMSAV		;SAVE AC 1
	MOVEI 1,.FHSLF		;TURN OFF SYSTEM INTS WHILE MUNGING INTPDL
	DIR
	MOVE 1,INTPDL		;NOW UNDO INTPDL
	POP 1,F
	POP 1,R
	POP 1,D	
	POP 1,@-1(1)		;RESTORE RETURN PC
	SUB 1,R70+1		;THROW AWAY RETURN PC POINTER
	POP 1,IMASK		;RESTORE OLD IMASK
	SUB 1,R70+2
	MOVEM 1,INTPDL
	MOVEI 1,.FHSLF
	EIR			;NOW ALLOW INTERRUPTS
	MOVEI 1,.FHSLF
	AOS DSMSAV		;SAVE AC 2 ON TOP OF STACK
	MOVEM 2,@DSMSAV
	MOVE 2,IMASK		;TELL TOPS-20 ABOUT OLD IMASK
	AIC
	MOVE 2,@DSMSAV		;RESTORE AC'S
	SOS DSMSAV
	MOVE 1,@DSMSAV
	SOS DSMSAV
NOPRO
	DEBRK			;THEN DISMISS THE CURRENT INTERRUPT

;;; INTPDL BUILDER: RETURNS INTPDL IN F, ACCEPTS PC POINTER ON FLP
INTSUP:
XCTPRO				;NEED PROTECTION AS WE WILL USE MARKED ACS
	MOVEM 1,SUPSAV		;SAVE NEEDED REGISTER
	MOVEI 1,.FHSLF		;TURN OFF THE INTERRUPT SYSTEM WHILE TOUCHING
	DIR			; INTPDL
	MOVE 1,INTPDL
	PUSH 1,NIL		;IPSWD1 AND IPSWD2
	PUSH 1,NIL
	PUSH 1,IMASK		;IMASK UPON ENTRY
	PUSH 1,F		;SAVE THE PC POINTER
	HRRZS (1)		;BUT ONLY RH
	PUSH 1,(F)		;AND SAVE THE PC
	PUSH 1,D		;SAVE PRESERVED ACS
	PUSH 1,R
	HLRZS F			;RH NOW HAS ADR OF F
	PUSH 1,(F)		;SAVES F
	MOVE F,1		;COPY OF INTPDL TO F
	MOVEM F,INTPDL		;SAVE INTPDL
	MOVEI 1,.FHSLF		;REEANBLE INTERRUPTS
	EIR
	MOVE 1,SUPSAV
NOPRO
	JRST (T)		;RETURN TO CALLER


;;; THE ACTUAL INTERRUPT HANDLERS

;PDL OVERFLOW
$PDLOV:	MOVEM T,PDLSVT		;SAVE T SO THAT WE HAVE AN AC TO USE
	MOVE T,INTPDL		;FUDGE INTPDL STACK FRAME
	PUSH T,NIL		;IPSWD1 AND IPSWD2 UNUSED
	PUSH T,NIL
	PUSH T,IMASK		;SAVE IMASK UPON ENTRY
	PUSH T,LEVTAB		;RH IS INTERRUPT PC ADR, @ AND () FIELDS OFF
	PUSH T,@LEVTAB		;SAVE PC
	PUSH T,D
	PUSH T,R
	PUSH T,F
	MOVEM T,INTPDL		;STORE NEW INTPDL POINTER
	MOVE T,PDLSVT		;RESTORE AC T
	JRST PDLOV		;THEN PROCESS PDL OV

;;; PRIORITY LEVEL 2 INTERRUPT HANDLERS

;INTERRUPT AFTER NEWLY CREATED PAGE
INTNXP:	MOVEM T,LV2SVT
	MOVE T,@LEVTAB+1
	HLRZ T,(T)		;GET THE INSTRUCTION THAT CAUSED THE GRIEF
	TRZ T,000037		;ANY INDEX OR INDIRECTION IS OK
	CAIE T,(SETMM)		;SPECIAL WAY TO CREATE A PAGE, SO ALL IS OK
	 JRST INTMPV		;OTHERWISE IS BAD NEWS
	MOVE T,LV2SVT		;ELSE RESTORE T
	DEBRK			;AND RETURN INSTANTLY

;ILLEGAL MEMORY READ
INTIRD:	MOVEM T,LV2SVT		;TREAT ILLEGAL MEMORY READ AS MPV

;HERE ON MEMORY PROTECTION VIOLATION, T SAVED ON FXP
INTMPV:	MOVEI T,%PIMPV		;TURN INTO AN MPV
	JRST INTMER		;AND TREAT LIKE OTHER MEMORY ERRORS

;ILLEGAL MEMORY WRITE
INTIWR:	MOVEM T,LV2SVT
	MOVSI T,(%PIWRO)	;WRITE INTO READ-ONLY MEMORY
	JRST INTMER

;ILLEGAL OP
INTILO:	MOVEM T,LV2SVT
;;; SPECIAL CHECK FOR DELCH SYSTEM CALL FOR TENECIES THAT DON'T HAVE IT
;;; CAUSE SKIP RETURN
.SEE RUB1C1
	SKIPN TENEXP		;A TENEX?
	 JRST INILO1		;NOPE, NO SPECIAL CASE
	HRRZ T,INTPC2		;PC+1 OF INTERRUPT
	MOVE T,-1(T)		;GET ACTUAL ILLEGAL INSTRUCTION
	CAME T,[DELCH]		;THE DELCH JSYS?
	 JRST INILO1		;NOPE, A LEGITIMATE ERROR THEN
	MOVEI T,3		;CAUSE A RETURN TO JSYS+4 (NON-DISPLAY TTY)
	AOS INTPC2		;ELSE CAUSE A 
	MOVE T,LV2SVT		;RESTORE T
	DEBRK			;THEN RETURN TO MAINLINE

INILO1:	MOVEI T,%PIILO		;ILLEGAL OPERATION

;COMMON MEMORY ERROR HANDLER, T IS PUSHED ON FXP AND CONTAINS THE ERROR BIT
;FUDGE INTPDL AND JRST OFF TO MEMERR
INTMER:	MOVEM F,LV2SVF		;SAVE F IN KNOWN PLACE
	MOVEM T,LV2ST2		;ALSO SAVE FLAGS
	MOVE F,[LV2SVF,,INTPC2]	;WHERE F IS,,WHERE PC IS
	JSP T,INTSUP		;SETUP INTPDL, RETURN INTPDL IN F
	MOVE T,LV2ST2		;GET BACK FLAG BITS
	MOVEM T,IPSWD1(F)	;STORE MEMORY ERROR BITS
	MOVE T,LV2SVT		;RESTORE ACTUAL CONTENTS OF T
	JRST MEMERR		;THEN PROCESS THE MEMORY ERROR

;;; ASSIGNABLE INTERRUPT HANDLER
INTASS:
REPEAT CINTSZ,[
	MOVEM T,LV3SVT		;SAVE AC T
	MOVEI T,.RPCNT		;INDEX INTO CINTAB
	JRST ASSIN1		;THEN USE COMMON CODE
]
ASSIN1:	SKIPN CINTAB(T)		;ASSIGNED CHANNEL?
	 JRST ASSRET		;NOPE, RANDOM INTERRUPT; JUST RETURN
	SKIPG CINTAB(T)		;'CHANNEL' INTERRUPT (A CHARACTER?)
	 HALT			;NO, SOME OTHER TYPE, BUT NONE SUPPORTED YET...
	MOVEM F,LV3SVF
	MOVE F,[LV3SVF,,INTPC3]
	MOVEM T,LV3ST2		;SAVE INTERRUPT TABLE INDEX
	JSP T,INTSUP		;SETUP INTPDL
	MOVE T,LV3ST2
	HRRZ T,CINTAB(T)	;GET THE INTERRUPT CHARACTER
	TRO T,400000		;FLAG AS INTERNAL
	MOVEM T,IPSWD2(F)	;STORE ON INTPDL
	MOVE T,LV3SVT		;RESTORE ORIGIONAL CONTENTS OF T
	JRST CHNINT		;THEN PROCESS THE CHANNEL INTERRUPT

ASSRET:	MOVE T,LV3SVT		;RESTORE ORIGIONAL CONTENTS OF T
	DEBRK			;THEN RETURN TO MAIN PROGRAM
]		;END IFN D20


IFN SAIL,[
;SAIL NEWIO INTERRUPT CODE

;CALLED TO REINITIALIZE THE INTERRUPT SYSTEM
ENBINT:	MOVEI T,INTRPT		;FLAGS,,INTERRUPT LOCATION
	MOVEM T,.JBAPR		;LOCATION SO MONITOR KNOWS
	SETZM INTALL		;DID A 'DALINT' LAST (ALL INTS ARE MASKED)
	SETOB T,REEINT		;ALL INTERRUPTS INCLUDING REENTER
	SETOM REENOP		;BUT MUST SET BOTH FLAGS
	IWKMSK T		;ALL GET US OUT OF IWAIT
	INTMSK T		;ALL ARE MASKED ON
	MOVE T,[STDMSK]		;ENABLE STANDARD INTERRUPTS
	MOVEM T,IMASK		;THIS IS CURRENT INTERRUPT MASK
	MOVEM T,OIMASK		;THIS IS ALSO THE OLD-MASK
	INTENB T,		;TELL OPERATING SYSTEM WHICH INTS TO GENERATE
	MOVEI T,REETRP		;REENTER TRAP ADR
	MOVEM T,.JBREN		;ALLOW REENTER AS MEANS OF IOC INTERRUPT
	POPJ P,

;REENABLES INTERRUPTS AFTER THEY HAVE BEEN DISABLED BY DALINT OR DISINT
REAINT:	PUSH FXP,T
	AOSE INTALL		;DISABLED ALL INTS?
	 SKIPA T,OIMASK		;NO, USE OLD INTERRUPT MASK
	  SKIPA T,IMASK		;ELSE USE CURRENT MASK
	   MOVEM T,IMASK	;THIS IS NOW THE CURRENT MASK
	INTMSK T		;THEN UNMASK CORRECT SET OF INTERRUPTS
	SKIPG REEINT
	 JRST REAIN1
	MOVEI T,CPOPJ
	MOVEM T,.JBOPC
	POP FXP,T
	JRST REETR1		;FUDGE A REENTER IF ONE WAS REQUESTED
REAIN1:	POP FXP,T
	SETOM REEINT
	POPJ P,

;DISABLE ALL BUT IMPORTANT INTERRUPTS
;IMASK IS MOVED TO OIMASK, AND IMASK IS SETUP TO NEW CURRENT MASK VALUE
DISINT:	PUSH FXP,T		;WE WILL NEED A WORKING AC
	MOVE T,IMASK		;GET CURRENT INTERRUPT MASK
	MOVEM T,OIMASK		;UPDATE OLD MASK
	ANDCM T,[INTPAR\INTPOV\INTILM\INTNXM] ;ONLY ALLOW THESE INTERRUPTS
	MOVEM T,IMASK		;NEW MASK
	INTMSK T		;TELL OPERATING SYSTEM
	SETZM REEINT		;ALSO DISALLOW REENTERS
	POP FXP,T
	POPJ P,

;THIS ROUTINE DISABLES ALL INTERRUPTS FROM OCCURING
;THE FLAG INTALL IS SET SAYING TO TELL THE RE-ENABLE ROUTINE TO RESTORE
; INTERRUPTS FROM IMASK RATHER THAN OIMASK
DALINT:	PISTOP
	POPJ P,

;HERE TO PROCESS AN INTERRUPT
;OPERATING SYSTEM JUMPS TO HERE WITH ALL ACS SAVED AND SET UP WITH INTERRUPT
;STATUS;  THE OBJECT IS TO SAVE INTERRUPT DEPENDANT DATA AND THEN REENABLE
;THE INTERRUPT SYSTEM AS SOON AS POSSIBLE....NOTE THAT THIS MUST DISABLE
;INTERRUPTS DEPENDING UPON WHICH ONE WAS GENERATED.

;--INTERRUPT--		  --DISABLES--
;MEMORY ERROR		ALL EXCEPT PDL OV
;<ESC>I			<ESC>I AND REENTER
;PDL OV			ALL EXCEPT MEMORY ERROR AND PDL OV
;CLOCK			CLOCK

INTRPT:	MOVE A,INTPDL		;DON'T WORRY ABOUT SPACEWAR BUTTONS
	SETZM REENOP		;NO ^C/REENTER TRAPS NOW
	MOVE B,.JBCNI		;GET INTERRUPT 
	PUSH A,B		;SAVE INTERRUPT CONDITIONS
	PUSH A,10		;SAVE ARGUMENT TO INTERRUPT (FOR <ESC>I)
	PUSH A,IMASK		;DEFERRED INTERRUPT MASK CURRENTLY ACTIVE
	JFFO B,.+1		;GET INTERRUPT NUMBER INTO AC B+1
	PUSH A,B+1		;STORE THIS ON INTPDL
	MOVE B+1,SAIIMS(B+1)
	MOVEM B+1,IMASK
	INTMSK B+1
	PUSH A,.JBTPC		;SAVE ADR INTERRUPT EMANATES FROM
	PUSH A,NIL		;SAVE DUMMY WORDS TO HOLD ACS D, R, F
	PUSH A,NIL
	PUSH A,NIL
	MOVEM A,INTPDL		;THIS IS NEW INTERRUPT PDL POINTER
	UWAIT			;UWAIT WILL RESTORE USER AC'S
	EXCH F,INTPDL		;SAVE F, GET POINTER TO INTPDL
	MOVEM D,IPSD(F)		;SAVE D
	MOVEM R,IPSR(F)		;SAVE R
	MOVE R,.JBTPC
	MOVEM R,IPSPC(F)	;THE REAL RETURN PC
	MOVEI R,(F)		;COPY INTPDL INTO R
	EXCH F,INTPDL		;RESTORE STATE OF F AND INTPDL
	MOVEM F,IPSF(R)		;THEN SAVE F
	MOVE F,IPSDF2(R)	;GET BIT NUMBER
	MOVE R,SAIIMS(F)	;THIS WILL BE NEW IMASK (F HAS INT NUMBER)
	MOVEM R,IMASK
	INTMSK R
	DEBREAK			;NOW GO TO USER LEVEL BUT NOT TO USER PROGRAM
	JRST @SAIDSP(F)		;DISPATCH ON INTERRUPT INDEX

;MAIL INTERRUPT
MAIINT:	MAIL 3,
	JRST DSMINT		;NO MAIL, SO DISMISS
	JSP R,FNYINT
	UIFSMI,,V.SMS

;DISMISS AN INTERRUPT
DSMINT:	PUSH FXP,T
	MOVE T,INTPDL
	MOVE F,IPSDF1(T)	;RESTORE APR FLAGS TO THOSE AT INTERRUPT TIME
	MOVEM F,IMASK
	INTMSK F
	POP T,F
	POP T,R
	POP T,D
	PUSH P,(T)		;RETURN PC
	POPI T,5
	MOVEM T,INTPDL		;RESTORE INTPDL
	POP FXP,T
	SKIPL REEINT
	 HALT			;FOR DEBUGGING, THIS SHOULD NOT HAPPEN UNLESS
				;CODE IS NOT PAIRED CORRECTLY
				; (DISINT[DALINT]/REAINT)
	SKIPG REENOP
	 POPJ P,
	MOVEM T,REESVT		;WE NEED AT LEAST ONE AC
	MOVE T,INTPDL		;USE T AS THE INTPDL
	ADD T,R70+10		;WE MUST RESERVE THE SPACE WE WILL NEED
	MOVEM T,INTPDL
	SUB T,R70+5		;BUT LEAVE 4 DUMMY WORDS + 1 FOR PC
	POP P,(T)		;PC IS THAT WHICH WE WILL POPJ TO
	JRST REETR1

;INTERRUPT HANDLING ROUTINES (DISPATCHED TO VIA SAIDSP)
INTERR:	OUTSTR [ASCIZ\AN ILLEGAL INTERRUPT HAS BEEN RECIEVED. THIS IS AN
INTERNAL LISP ERROR\]
	HALT

PARINT:	MOVSI R,(%PIPAR)	;FLAG THAT IS PARITY ERROR
	JRST SAIMER

NXMINT:	SKIPA R,[%PIMPV]
ILMINT:	MOVSI R,(%PIWRO)
SAIMER:	MOVE F,INTPDL		;INT PDL POINTER INTO F
	MOVEM R,IPSWD1(F)	;STORE WHERE MEMERR CAN FIND BITS
	JRST MEMERR		;PROCESS MEMORY ERROR

;HERE FOR <ESC>I INTERRUPT
EYEINT:	MOVE F,INTPDL		;INT PDL POINTER INTO F
	SETZB R,IPSWD2(F)	;FORCE EXTERNAL CALL
;	MOVM R,IPSWD2(F)	;GET <ESC>I ARG (POSITIVE FORM ONLY)
;	CAILE R,177		;ONLY CHARACTERS UP TO 177 HAVE MEANING
;	 TDZA R,R		;FORCE R TO ZERO
;	  TLO R,400000		;FLAG THAT THIS IS AN INTERNAL CALL
;	MOVEM R,IPSWD2(F)	;RESTORE ARGUMENT TO CHNINT
	CLRBFI
	JRST CHNINT		;FUDGE THE CHANNEL INTERRUPT

;NEW INTERRUPT MASK BITS, INDEXED BY CURRENT INTERRUPT NUMBER
SAIIMS:	0 ? 0 ? 0 ? 0 
	INTPOV			;MAIL INTERRUPT
	0 ? 0
	INTPOV			;PAR ERROR: ONLY ALLOW PDL OV
	-INTCLK-1		;CLOCK INT: ALLOW ALL OTHERS
	0 ? 0 ? 0 ? 0		;NOT USED, IMP INTERRUPTS
	-<INTCLK\INTTTI>-1	;<ESC>I: ALL EXCEPT <ESC>I AND CLOCK
	0			;CHANGING QUEUES, NOT USED
	INTPOV\INTILM\INTNXM\INTPAR\INTPOV ;PDL OV: ALL MEMORY ERRS AND PDL OV
	0			;PDP-11 INT, NOT USED
	INTPOV			;ILM: ONLY PDL OV
	INTPOV			;NXM: ONLY PDL OV
	0 ? 0 ? 0		;OVERFLOW AND OLD CLOCK TICK

;DISPATCH TABLE, INDEXED BY INTERRUPT NUMBER
SAIDSP:
REPEAT 6,INTERR		;INTERRUPT ERROR, THIS CANNOT HAPPEN
	MAIINT
REPEAT 2,INTERR
	PARINT			;PARITY ERROR
	INTERR			;CLOCK INTERRUPT
	INTERR ? INTERR ? INTERR ? INTERR ;VARIOUS IMP INTERRUPTS
	EYEINT			;<ESC>I INTERRUPT
	INTERR ? INTERR ? INTERR ;CHANGING QUEUES, UNUSED, UNUSED
	PDLOV			;PDL OV
	INTERR ? INTERR		;PDP-11 INTERRUPT, UNUSED
	ILMINT			;ILL MEM REF
	NXMINT			;NON-EXISTANT MEMORY
	INTERR ? INTERR ? INTERR ;UNUSED, UNUSED, OLD CLOCK INT
	INTERR ? INTERR		;UNUSED
	INTERR			;FLOATING OVERFLOW
	INTERR ? INTERR		;UNUSED
	INTERR			;INTEGER OVERFLOW
REPEAT 4, INTERR		;UNUSED
]	;END IFN SAIL

IFN D10*<SAIL-1>,[
SUBTTL DEC-10 ONLY NEWIO INTERRUPT CODE
;***A NOTE OF CAUTION
;WHENEVER THE INTPDL IS TOUCHED, IT IS DONE SO IN A CERTAIN ORDER OF
;INSTRUCTIONS.  THIS IS NECESSARY TO PREVENT TIMING ERRORS FROM SCREWING
;UP THE PDL SLOT ALLOCATION (THIS PREVENTS SAVED AC'S, FOR EXAMPLE, TO
;BE OVERWRITTEN BY NESTED INTERRUPTS).  DO NOT CHANGE ANY ORDERING OF
;THIS CODE WITHOUT METICULOUS CHECKING TO SEE THAT RANDOM, ASYNCHRONOUS
;INTERRUPTS WILL NOT CAUSE TOTAL LOSSAGE.

;INTERRUPT ENABLING/DISABLING
;ENABLE NORMAL INTERRUPTS, CALLED AT STARTUP
ENBINT:	MOVEI T,REETRP		;REENTER TRAP ADR
	MOVEM T,.JBREN
	MOVEI T,APRTRP		;THIS LOCATION FOR ALL APR TRAPS
	MOVEM T,.JBAPR		;INFORM TOPS-10 VIA JOBDAT
	MOVEI T,STDMSK
	MOVEM T,IMASK		;THIS IS CURRENT INTERRUPT MASK
	MOVEM T,OIMASK		;ALSO IS OLD INTERRUPT MASK
	SETOM REEINT		;REENTER INTERRUPTS ARE OK
	SETOM REENOP		;BUT MUST SET BOTH FLAGS
	SETZM INTALL		;WE HAVEN'T DISABLED ALL INTERRUPTS
	APRENB T,
	POPJ P,			;NO OTHER TRAPS VIA THIS MECHANISM

;RE-ENABLE AFTER DISABLE INTERRUPTS
REAINT:	PUSH FXP,T
	AOSE INTALL		;DISABLED ALL INTS?
	 SKIPA T,OIMASK		;NO, USE OLD INTERRUPT MASK
	  SKIPA T,IMASK		;ELSE USE CURRENT MASK
	   MOVEM T,IMASK	;THIS IS NOW THE CURRENT MASK
	APRENB T,
	SKIPLE REENOP
	 JRST REAIN2
	SKIPG REEINT
	 JRST REAIN1
REAIN2:	MOVEI T,CPOPJ
	MOVEM T,.JBOPC
	POP FXP,T
	JRST REETR1		;FUDGE A REENTER IF ONE WAS REQUESTED
REAIN1:	SETOM REEINT
	SETOM REENOP
	POP FXP,T
	POPJ P,

;DISABLE ALL BUT IMPORTANT INTERRUPTS
DISINT:	PUSH FXP,T
	MOVE T,IMASK		;GET CURRENT MASK
	MOVEM T,OIMASK		;REMEMBER IT FOR RESETING PURPOSES
	ANDI T,AP.POV		;ONLY ALLOW IMPORTANT INTERRUPTS
	MOVEM T,IMASK		;THIS IS CURRENT STATE OF SYSTEM
	SETZM REEINT		;NO REENTER'S NOW
	APRENB T,
	POP FXP,T
	POPJ P,

;DISABLE ALL INTERRUPTS
DALINT:	PUSH FXP,T
	SETOM INTALL		;HAVE DISABLED ALL INTERRUPTS
	SETZB T,REEINT
	APRENB T,
	POP FXP,T
	POPJ P,

;APR TRAP HANDLING
APRTRP:	SETZM REENOP		;ABSOLUTLY NO ^C/REENTER INTERRUPTS NOW!
	MOVEM T,APRSVT
	SETZ T,
	APRENB T,		;NO INTERRUPTS DURING TRAP SETUP
	MOVE T,INTPDL		;USE T AS THE INTPDL
REPEAT 4, PUSH T,		;2 INTERRUPT WORDS AND 2 DEFFERED WORDS
	PUSH T,.JBTPC		;INTERRUPT PC
	PUSH T,D		;SAVE AC'S AS ITS INTERRUPT WOULD DO
	PUSH T,R
	PUSH T,F
	MOVEM T,INTPDL
	MOVE D,IMASK		;THIS IS GOING TO GO IN INT MASK1 WORD
	MOVEM D,IPSDF1(T)
	SETZ D,
	MOVE F,.JBCNI		;GET ACTUAL PROCESSOR BITS
	TRNE F,AP.PAR
	 TLO D,(%PIPAR)		;PARITY ERROR
	TRNE F,AP.POV		;PDL OV?
	 JRST $PDLOV
	TRNE F,AP.ILM		;PURE PAGE ERROR? (SHOULD THIS BE MPV?)
	 TLO D,(%PIWRO)
	TRNE F,AP.NXM		;NON-EXISTANT MEMORY
	 TRO D,%PIMPV
	MOVEM D,IPSWD1(T)
	MOVE T,APRSVT
	JUMPN D,MEMERR
	OUTSTR [ASCIZ \UNRECOGNIZED APR INTERRUPT\]
	HALT

$PDLOV:	MOVE T,APRSVT
	JRST PDLOV

;DISMISS AN INTERRUPT
DSMINT:	PUSH FXP,T
	MOVE T,INTPDL
	MOVE F,IPSDF1(T)	;RESTORE APR FLAGS TO THOSE AT INTERRUPT TIME
	MOVEM F,IMASK
	APRENB F,
	POP T,F
	POP T,R
	POP T,D
	PUSH P,(T)		;RETURN PC
	POPI T,5
	MOVEM T,INTPDL		;RESTORE INTPDL
	POP FXP,T
	SKIPL REEINT
	 HALT			;FOR DEBUGGING, THIS SHOULD NOT HAPPEN UNLESS
				;CODE IS NOT PAIRED CORRECTLY (DISINT[DALINT]/REAINT)
	SKIPG REENOP
	 POPJ P,
	MOVEM T,REESVT		;WE NEED AT LEAST ONE AC
	MOVE T,INTPDL		;USE T AS THE INTPDL
	ADD T,R70+10		;WE MUST RESERVE THE SPACE WE WILL NEED
	MOVEM T,INTPDL
	SUB T,R70+5		;BUT LEAVE 4 DUMMY WORDS + 1 FOR PC
	POP P,(T)		;PC IS THAT WHICH WE WILL POPJ TO
	JRST REETR1
];END IFN D10*<SAIL-1>

;THE FOLLOWING CODE IS FOR TOPS-10 AND SAIL
IFN D10,[
;HERE FOR A USER CHARACTER INTERRUPT, MAKE AN INTSTACK FRAME AND CALL CHNINT
UCHINT:	SETZM REEINT		;DON'T ALLOW ^C/REENTERS TO GO THROUGH
	MOVEM T,REESVT		;WE NEED AT LEAST ONE AC
	MOVE T,INTPDL		;USE T AS THE INTPDL
	ADD T,R70+10		;MUST SET INTPDL TO AFTER ITS REAL USE SO THAT
				;RECURSIVE INTERRUPTS USE DIFFERENT STACK AREAS
	MOVEM T,INTPDL
	SUB T,R70+4		;WE WILL KEEP A DUMMY FOUR WORDS
	PUSH T,[0,,CPOPJ]	;PC FLAGS 0 AS THEY MAY GET RESTORED BY JRST 2,
	PUSH T,D		;SAVE AC'S AS ITS INTERRUPT WOULD DO
	PUSH T,R
	PUSH T,F
	MOVEM D,IPSWD2(T)
	MOVE D,IMASK		;PUT OLD IMASK IN WORD 1 MASK
	MOVEM D,IPSDF1(T)
	MOVE T,REESVT
	SETOM REENOP
	SETOM REEINT
	JRST CHNINT


;REENTER TRAP ADR
REETRP:	AOSG REENOP
	 AOSLE REEINT		;REENTER ALLOWED?
	  JRSTF @.JBOPC		;NOPE, FLAG AND GO ON
	MOVEM T,REESVT		;WE NEED AT LEAST ONE AC
	MOVE T,INTPDL		;USE T AS THE INTPDL
	ADD T,R70+10		;MUST SET INTPDL TO AFTER ITS REAL USE SO THAT
				;RECURSIVE INTERRUPTS USE DIFFERENT STACK AREAS
	MOVEM T,INTPDL
	SUB T,R70+4		;WE WILL KEEP A DUMMY FOUR WORDS
	PUSH T,.JBOPC		;INTERRUPT PC
REETR1:	PUSH T,D		;SAVE AC'S AS ITS INTERRUPT WOULD DO
	PUSH T,R
	PUSH T,F
	SETZM IPSWD2(T)		;FORCE MASK TO ZERO AS IS USED SPECIALLY
	MOVE D,IMASK		;STORE IMASK AS WORD1 MASK
	MOVEM D,IPSDF1(T)
	MOVE T,REESVT
	SETOM REENOP
	SETOM REEINT
	JRST CHNINT
]	;END IFN D10


;;; WHEN THE INTERRUPT OCCURS, ACS D, R, AND F HAVE BEEN SAVED.
;;; BY CONVENTION AN INTERRUPT HANDLER MOVES THE INTPDL POINTER
;;; INTO F, GETS A VALID FXP POINTER INTO FXP, AND PUSHES THE OLD
;;; CONTENTS OF FXP ONTO THAT PDL.

;;; STANDARD INTERRUPT EXIT
;;; WILL RESTORE FXP AND D+R+F, AND DISMISS THE INTERRUPT.

INTXIT:	MOVE FXP,(FXP)		;POP FXP,FXP
	SKIPN NOQUIT		;CHECK FOR USER INTS STACKED BY INT HANDLER
	 SKIPN INTFLG		.SEE CHECKI
	  JRST INTXT2
	SKIPE GCFXP		;HOW CAN GCFXP BE NON-ZERO WITH NOQUIT ZERO?
	 .LOSE
	PUSH FXP,IPSD(F)	;ARRANGE TO RESTORE D AND THE PC
	PUSH P,IPSPC(F)		; (INCLUDING FLAGS!) AFTER CHECKING
	PUSH P,CPXDFLJ		; FOR STACKED INTERRUPTS
	MOVEI R,CKI0
	MOVEM R,IPSPC(F)
INTXT2:
IFN D20+D10, JRST DSMINT	;DISMISS THE INTERRUPT
IFN ITS,[.CALL INTXT9		;RETURN PC IS ON TOP OF INTPDL,
	 .LOSE 1000		; AND ALSO THE OLD DEFER WORDS

INTXT9:	SETZ
	SIXBIT \DISMIS\		;DISMISS INTERRUPT
	  5000,,D_6+3		;POP ACS D, R, AND F FIRST
	400000,,INTPDL		;INTERRUPT STACK POINTER
]		;END IFN ITS

;;; STANDARD LOSING INTERRUPT EXIT
;;; RESTORES FXP, AND D+R+F AS INTXIT DOES.
;;; ALSO EXPECTS A .LOSE ERROR CODE IN R.

INTLOS:	MOVE FXP,(FXP)		;POP FXP,FXP
INTLS1:
IFN D10+D20, JRST DSMINT	;DISMISS THE INTERRUPT
IFN ITS,[.CALL INTLS9
	 .LOSE 1000

INTLS9:	SETZ
	SIXBIT \DISMIS\		;DISMISS INTERRUPT
	  5000,,D_6+3		;POP ACS D, R, AND F FIRST
	      ,,INTPDL		;INTERRUPT STACK POINTER
	      ,,IPSPC(F)	;NEW PC		;IN ORDER TO SPECIFY
	      ,,IPSDF1(F)	;NEW .DF1	; THE .LOSE CODE, ONE
	      ,,IPSDF2(F)	;NEW .DF2	; MUST MENTION ALL THIS TOO
	400000,,R		;.LOSE ERROR CODE
]		;END IFN ITS

;;; EXIT INTERRUPT, GOING TO USER INTERRUPT HANDLER.
;;; ARGUMENT FOR THE UINT ROUTINE IS IN D.
;;; PDLS ARE IN GOOD SHAPE BY NOW, OF COURSE.

XUINT:	SKIPE GCFXP		;BE EXTRA SURE ABOUT THE
IT$	 .LOSE			; GOODNESS OF THE PDLS!
IFN <D10+D20>, HALT
;;;;	POP FXP,FXP		;AT THIS POINT SHOULD BE SAME AS  SUB FXP,R70+1
	MOVE FXP,(FXP)
	PUSH P,IPSPC(F)		;PUSH INTERRUPT PC ON STACK FOR UINT
	PUSH P,CPXDFLJ		;ARRANGE FOR AC D AND FLAGS TO BE RESTORED
	PUSH FXP,IPSD(F)	;PUSH AC D (BEFORE INTERRUPT) ON FXP
	MOVEM D,IPSD(F)		;CAUSE D TO SURVIVE THE DISMIS
IFN D10+D20,[
	MOVEI D,UINT		;NEW PC
	MOVEM D,IPSPC(F)	;STORE WHERE OLD PC WENT
	JRST DSMINT		;THEN DISMISS THE INTERRUPT
]		;END IFN D10+D20

IFN ITS,[.CALL XUINT9
	 .LOSE 1000

XUINT9:	SETZ
	SIXBIT \DISMIS\		;DISMISS INTERRUPT
	  5000,,D_6+3		;POP ACS D, R, AND F FIRST
	      ,,INTPDL		;INTERRUPT STACK POINTER
	  1000,,UINT		;NEW PC
	      ,,TTYDF1		;NEW .DF1
	400000,,TTYDF2		;NEW .DF2
]		;END IFN ITS


;;; MEMORY AND OPCODE ERRORS: PARITY, PURE, MPV, ILOP.
;;; ASSUME NO MORE THAN ONE HAPPENS AT A TIME.

MEMERR:
IT$	.SUSET [.RJPC,,JPCSAV]
	MOVE F,INTPDL
	MOVE D,FXP
	SKIPE GCFXP
	 MOVE FXP,GCFXP
	PUSH FXP,D
	MOVN R,IPSWD1(F)	;THIS SEQUENCE KILLS THE LOW-ORDER
	ANDCA R,IPSWD1(F)	; BIT FROM THE INTERRUPT WORD
				; FOR D10, WILL CONTAIN APR FLAGS OF MERIT
	SKIPE R			;LOSE IF MORE THAN ONE BIT WAS SET
IT$	 .LOSE
IFN D10+D20, HALT
	MOVE R,IPSWD1(F)
	HRRZ D,IPSPC(F)
IT$	CAIN D,THIRTY+5		;DDT DOES X IN LOCATION 34
IT$	 JRST $XLOSE
	TLNE R,(%PI<PAR>)	;WAS IT A PARITY ERROR?
	 JRST PARERR
	TLNE R,(%PI<WRO>)	;WRITE INTO READ-ONLY?
	 JRST PURPGI
	TRNE R,%PI<ILO>		;ILLEGAL OPERATION?
	 JRST ILOPER
	TRNN R,%PI<MPV>		;MEMORY PROTECT VIOLATION?
	 .VALUE			;NO??? WHAT HAPPENED???
	CAIE D,UBD1		;LET SPECPDL RESTORATION HAPPEN
	 JRST MPVERR		; EVEN IF ONE SLOT GOT CLOBBERED
	AOS IPSPC(F)		;BUMP PC PAST OFFENDING INSTRUCTION
	JRST INTXIT

MPVERR:	SKIPA D,[UIMMPV]
PURERR:	 MOVEI D,UIMWRO
	JRST MEMER5

ILOPER:	
IFN D20,[
	SKIPN TENEXP
	 JRST ILOPR1
; THIS A CRUFTY BUT ADEQUATE THEORY OF ERJMP'S
	HLRZ R,0(D)
	CAIE R,320700		;ERJUMP?
	 JRST ILOPR1
	HLRZ R,-1(D)
	CAIE R,104000		;JSYS?
	 JRST ILOPR1
	HRRZ R,0(D)
	HRRM R,IPSPC(F)		;CLOBBER RESTART ADDRESS
	JRST INTXIT
ILOPR1:
]		;END IFN D20
	SKIPA D,[UIMILO]
PARERR:	 MOVEI D,UIMPAR
MEMER5:	HRRZ R,INTPDL		;MACHINE ERROR! WHAT TO DO?
	CAIN R,INTPDL+LIPSAV	;IF THE ERROR HAPPENED WITHIN AN INTERRUPT SERVER,
	 SKIPN VMERR		; OR IF USER SUPPLIED NO ERROR FUNCTION,
	  JRST MEMER7		; CRAP OUT BACK TO DDT
	MOVEI D,100000(D)
	HRL D,IPSPC(F)
	PUSHJ FXP,$IWAIT
	 JRST XUINT		;CALL USER INTERRUPT HANDLER
;	JRST INTXIT		;MAY RE-DO LOSING INSTR, BUT SO WHAT?
				; THAT'S A FEATURE, NOT A BUG.
	ANDI D,777
MEMER7:
IFN ITS,[
	HRRZ R,MEMER8(D)
	JRST INTLOS

MEMER8:
OFFSET -.
UIMPAR::	1+.LZ %PIPAR
UIMILO::	1+.LZ %PIILO
UIMWRO::	1+.LZ %PIWRO
UIMMPV::	1+.LZ %PIMPV
OFFSET 0

$XLOST:	.VALUE [ASCIZ \: YOUR X LOST PROCEED \]
	JRST THIRTY+5		;LET THE X RETURN CORRECTLY

$XLOSE:	MOVEI R,$XLOST		;CAUSE INTERRUPT DURING AN X
	MOVEM R,IPSPC(F)	; TO GO TO $XLOST (CROCK)
	JRST INTXIT
]		;END IFN ITS

IFE ITS,[
	MOVEI A,MEMER8(D)	;TRANSFER TO ONE OF THE LER3'S BELOW
	EXCH A,IPSPC(F)
	ANDI A,-1
	JRST INTXIT

MEMER8:
OFFSET -.
UIMPAR:: LER3 [SIXBIT \PC AT WHICH MEMORY PARITY ERROR OCCURRED!\]
UIMILO:: LER3 [SIXBIT \PC WITH ILLEGAL INSTRUCTION CODE!\]
UIMWRO:: LER3 [SIXBIT \PC AT WHICH ATTEMPT TO WRITE INTO PURE PAGE!\]
UIMMPV:: LER3 [SIXBIT \PC WITH MEMORY PROTECTION VIOLATION!\]
OFFSET 0
]	;END OF IFE ITS

;;; IFN D10,[
;;; 	OUTSTR @MEMER8(D)	;GIVE ERROR IF USER DOESN'T WANT IT
;;; 	EXIT 1,
;;; 	JRST .-2
;;; ]		;END IFN D10
;;; 
;;; IFN D20,[
;;; 	HRRO 1,MEMER8(D)	;GIVE ERROR
;;; 	PSOUT
;;; 	HALTF			;THEN STOP EXECUTION NICELY
;;; ]		;END IFN D20
;;; 
;;; IFN D10+D20,[
;;; MEMER8:
;;; OFFSET -.
;;; UIMPAR::[ASCIZ \?Parity error in job
;;; \]
;;; UIMILO::[ASCIZ \?Illegal op executed
;;; \]
;;; UIMWRO::[ASCIZ \?Write into read-only memory
;;; \]
;;; UIMMPV::[ASCIZ \?Memory protection violation
;;; \]
;;; OFFSET 0
;;; ]		;END IFN D10+D20






;;; I/O CHANNEL ERROR HANDLER


IFN ITS,[

IOCERR:	MOVE F,INTPDL
	MOVE R,FXP
	SKIPE GCFXP
	 MOVE FXP,GCFXP
	PUSH FXP,R
	.SUSET [.RBCHN,,R]
	.CALL SCSTAT
	 .LOSE 1400
	LSH D,-33
	HRRZ R,IPSPC(F)
MACROLOOP NIOCTR,ZZI,*		;ZZI MACROS DEFINE IOC TRAPS
	SKIPL R
	 JRST IOCER8
IOCERA:	HRRM R,IPSPC(F)		;CLOBBER RETURN PC
	HLRZ R,R
	CAIN R,400000+D		;WANT TO STICK IOC ERROR
	 MOVEI R,400000+IPSD(F)	; CODE INTO SPECIFIED AC,
	CAIN R,400000+R		; BUT MUST BEWARE OF D AND R
	 MOVEI R,400000+IPSR(F)
	MOVEM D,-400000(R)
	JRST INTXIT

IOCER8:	SKIPN IOCINS		;ANY USER IOC ERROR HANDLER?
	 JRST IOCER9		;NOPE, LET DUPERIOR HAVE THE ERROR
	MOVE R,IPSPC(F)		;PC IN R
				;ERROR CODE IN D (SEE ABOVE)
;CALL USER WITH PC IN R AND ERROR CODE IN D.
;THE USER'S ROUTINE MUST NOT MUNG ANY AC'S OTHER THAN R AND D, THOUGH THE
;STACKS MAY BE USED.  IF THE USER'S INSTRUCTION SKIPS, THE RIGHT
;HALF OF R CONTAINS THE PC TO DISPATCH TO AFTER THE DISMIS, AND THE LEFT HALF
;OF R CONTAINS 400000+<ADR IN WHICH TO STORE ERROR CODE>
	PUSHJ FLP,@IOCINS
	 SKIPA
	  JRST IOCERA
IOCER9:	MOVEI R,1+.LZ %PIIOC
	JRST INTLOS
]		;END IFN ITS



;;; INTERRUPT FROM I/O CHANNEL.
;;; PRESENTLY ONLY TWO KINDS ARE HANDLED:
;;;	TTY INPUT:	INTERRUPT CHAR TYPED.
;;;	TTY OUTPUT:	**MORE**.

CHNINT:	MOVE F,INTPDL
	MOVE D,IPSWD2(F)	;GET WORD TWO INTERRUPT BITS
CHNIN2:	MOVE R,FXP		;FXP MAY BE IN A BAD STATE IF
	SKIPE GCFXP		; WITHIN GC, SO RESTORE IT AND
	 MOVE FXP,GCFXP		; THEN PUSH ITS OLD VALUE
	PUSH FXP,R		;REMEMBER, PDL OVERFLOW ISN'T DEFERRED NOW
IFN ITS,[
	MOVN R,D
	AND R,D			;R GETS LaOWEST SET BIT
	ANDCM D,R		;D GETS ALL OTHER BITS
	SKIPE D
	 .SUSET [.SIIFPIR,,D]	;PUT ANY OTHER BITS BACK (THEY'RE DEFERRED)
	MOVE D,R
	JFFO D,.+1		;FIND CHANNEL NUMBER
	MOVNS R			; FOR SOME PENDING
	ADDI R,43		; INTERRUPT BIT
	PUSH FXP,R		;SAVE CHANNEL NUMBER
	SKIPN R			;CHANNEL 0 ??
	 JRST CHNI2		;YES, THIS CAN HAPPEN IN STRANGE CASES
	SKIPN CHNTB(R)		;UNOPEN DEVICE ??
	  .VALUE		;BUT DON'T ALLOW INTERRUPTS FROM CLOSED CHAN
CHNI1H:	.CALL SCSTAT		;GET STATUS FOR THE CHANNEL
	 .VALUE
	ANDI D,77		;GET ITS INTERNAL PHYSICAL DEVICE TYPE
	SKIPE D
	 CAILE D,2
	   JRST CHNI5
];END IFN ITS

IFN D10+D20,[
	MOVE R,D
	MOVE D,V%TYI
	HLL D,ASAR(D)		;DOES "TYI" CONTAIN A TTY FILE ARRAY?
	TLNN D,AS<FIL>		;IF NOT, THEN USE INITIAL TTY FILE ARRAY
	 JRST .+3
	  HLL D,TTSAR(D)
	  TLNN D,TTS<TY>
	   MOVEI D,TTYIFA	
	PUSH FXP,D		;SAR ADR ON STACK
]		;END IFN D10+D20
IFN ITS,[
	HRRZ D,CHNTB(R)
	MOVE D,TTSAR(D)
	TLNE D,TTS<TY>		;IF IT'S NOT A TTY INPUT ARRAY, WE DON'T
	 TLNE D,TTS<IO>		;HAVE INTERRUPT CHAR DISPATCH TABLE
	  JRST CHNI5		; SO JUST TREAT AS ENDPGFUN (I.E. RANDOM CHANL)
	.ITYIC R,		;TYPE 0 IS TTY INPUT
	 JRST CHNI8		;TIMING ERROR OR SOMETHING - IGNORE
]	;END IFN ITS

IFN D10,[
	TRNE R,400000		;IF NOT INTERNAL GET FROM USE
	 JRST CHNIZ		;ELSE WE HAVE ALREADY
	OUTCHR ["?]
	INCHRW R
SA$	TRO R,%TXCTL		;CONTROLLIFY THE CHARACTER
CHNIZ:
]	;END IFN D10
SA% IFN D10+D20, ANDI R,37	;MAP ALL CHARS INTO CTRL CHARACTERS
SA$	ANDI R,777
	PUSH FXP,R		;SAVE INTERRUPT CHARACTER
	PUSH FXP,TT		; AND ALSO TT
	HRRZ TT,-2(FXP)		;FETCH CHANNEL NUMBER
				;FOR D-10, THIS IS ADR OF SAR
TTYI1:
IT$	HRRZ TT,CHNTB(TT)
	HRRZ TT,TTSAR(TT)
IFN D10+D20,[
	HRL TT,F.CHAN(TT)	;NOW GET CHANNEL #
	HLRZM TT,-2(FXP)	;MAKE THE CHANNEL NUMBER CORRECT ON THE STACK
]		;END IFN D10+D20
	JSP D,TTYICH		;GET BACK INTERRUPT FN IN R
	POP FXP,TT
	JUMPE R,CHNI2		;NULL FUNCTION - IGNORE
	MOVEI D,(R)
	LSH D,-SEGLOG
	MOVE D,ST(D)
	TLNN D,FX
	 JRST CHNI4
	MOVE R,(R)		;"FUNCTION" IS A FIXNUM
IFN ITS+SAIL,[
	MOVEI D,(R)		;IF ANY OF THE SUPRA-ASCII
	ANDCM D,(FXP)		; MODIFIER BITS ARE SET IN THE
	MOVSS (FXP)		; "FUNCTION", INSIST THAT THE
	ANDM R,(FXP)		; CORRESPONDING BITS APPEAR IN
	MOVSS (FXP)		; THE CHARACTER TYPED.  SIMILARLY,
	IOR D,(FXP)		; THE SAME BITS SET IN THE LEFT HALF
    	TRNE D,%TX<MTA+CTL+TOP+SFT+SFL>	; MEAN THAT THOSE BITS MUST BE OFF.
	 JRST CHNI2
]		;END IFN ITS+SAIL
	ANDI R,177
	MOVEI D,TRUTH		;MOOOOBY SKIP CHAIN OF SYSTEM INTS
	CAIN R,^A		;^A 	(SETQ ^A T)
	 HRRZM D,SIGNAL
IT$	CAIN R,^C		;^C	(SETQ ^D NIL)
IT$	 SETZM GCGAGV
	CAIN R,^D		;^D	(SETQ ^D T)
	 HRRZM D,GCGAGV
	CAIN R,^G		;^G	(^G)	;QUIT
	 JRST CN.G
IFE D20,[
	CAIN R,^R		;^R	(SETQ ^R T)
	 HRRZM D,TAPWRT
	CAIN R,^T		;^T	(SETQ ^R NIL)
	 SETZM TAPWRT
]	;END OF IFE D20
	CAIN R,^V		;^V	(SETQ ^W NIL)
	 SETZM TTYOFF
	CAIN R,^W		;^W	(PROG2 (SETQ ^W T)
	 JRST CN.W		;	       (CLEAR-OUTPUT T))
	CAIN R,^X		;^X	(ERROR 'QUIT)	;^X QUIT
	 JRST CN.X
	CAIN R,^Z		;^Z	CRAP OUT TO DDT
	 JRST CN.Z
CHNI2:	SUB FXP,R70+2
	JRST INTXIT


CHNI4:	POP FXP,D		;REAL LIVE USER INTERRUPT FUNCTION
	TRO D,400000		;2.9 => TTY INPUT INTERRUPT CHAR
CHNI4A:	POP FXP,R
	HRL D,CHNTB(R)
	SKIPE UNREAL
	 JSP R,CHNI4C		;BARF! (NOINTERRUPT 'TTY) OR (NOINTERRUPT T)
	    PUSHJ FXP,$IWAIT	;CALLS UISTAK AND SKIPS IF IN GC
	     JRST XUINT		;RUNS USER INTERRUPT
	JRST INTXIT

IFN ITS,[
CHNI5:	HRRZ D,CHNTB(R)		;CHECK OUT FILE ARRAY
	HRRZ D,TTSAR(D)
	SKIPN FO.EOP(D)		;SKIP IF ENDPAGEFN
	 JRST CHNI8
	MOVEI D,200000+<2*FO.EOP+1>	;2.8 => RANDOM FILE INTERRUPT
	JRST CHNI4A		;**MORE** => ENDPAGEFN GETS RUN

CHNI8:	SUB FXP,R70+1
	JRST INTXIT
];END IFN ITS


;;; ROUTINE TO STACK UP INTERRUPT IN INTAR -- USED BY CHNINT, JOBINT, AND FNYITN

CHNI4C:	MOVE F,UNREAR		;STACK UP INTERRUPT IN THE
	CAIL F,LUNREAR		; NOINTERRUPT QUEUE
	 JRST TMDAMI		;OOPS! TOO MANY DAMN INTERRUPTS!
	MOVE F,[400000+LUNREAR-1,,UNREAR+LUNREAR-2]
CHNI4H:	POP F,1(F)
	TLNE F,377777
	 JRST CHNI4H
	MOVEM D,UNREAR+1
	AOS UNREAR
	HRRZ F,INTPDL
	JRST 2(R)


; COMMENT FOR @ CHANGE

IFN JOBQIO,[

;;; INTERRUPT FROM INFERIOR PROCEDURE(S)

JOBINT:	MOVE F,INTPDL
	MOVE D,IPSWD2(F)
	MOVE R,FXP
	SKIPE GCFXP		;IF IN GC, FXP MAY BE
	 MOVE FXP,GCFXP		; SCREWED UP
	PUSH FXP,R
	MOVN R,D
	AND R,D			;R GETS LOWEST SET BIT
	ANDCM D,R		;D GETS ALL OTHER BITS
	SKIPE D
	 .SUSET [.SIIFPIR,,D]	;PUT ANY OTHER BITS BACK (THEY'RE DEFERRED)
	MOVE D,R
	JFFO D,.+1
	MOVNS R			;-22 < R < -11
	SKIPN D,JOBTB+21(R)
	 .VALUE			;NO JOB ARRAY???
	HRRZ R,TTSAR(D)
	SKIPN J.INTF(R)
	 JRST INTXIT		;NO INTERRUPT FUNCTION - IGNORE INTERRUPT
	MOVSI D,(D)
	TRO D,200000+<2*J.INTF+1>
	SKIPGE UNREAL
	 JSP R,CHNI4C		;GORP! (NOINTERRUPT T)
	    PUSHJ FXP,$IWAIT
	     JRST XUINT
	JRST INTXIT

]		;END OF IFN JOBINT






;;; TTSAR OF TTY INPUT FILE ARRAY IN TT.
;;; INPUT INTERRUPT CHARACTER IN R.
;;; RETURN ADDRESS IN D.
;;; RETURNS INTERRUPT FUNCTION IN R.

TTYICH:
IT$	TRZ R,%TX<TOP+SFL+SFT+MTA>	;FOLD 12.-BIT CHAR
SA$	ANDI R,777
SA%	TRZN R,%TX<CTL>		; DOWN TO 7 IF NECESSARY
SA%	 JRST TTYIC1
SA%	CAIE R,177
SA%	 TRZ R,140
TTYIC1:	ROT R,-1		;CLEVER ARRAY ACCESS
	ADDI TT,FB.BUF(R)	;INTERRUPT FNS ARE IN "BUFFER"
	HLR R,(TT)
	SKIPGE R
	HRRZ R,(TT)		;SIGN BIT OF R GETS CLEARED
	JRST (D)

SUBTTL VARIOUS SYSTEM TTY INPUT CHAR INTERRUPT HANDLERS.

CN.W:	HRRZM D,TTYOFF		;IMMEDIATE TTYOFF (^W)
	PUSH FXP,T
	PUSH FXP,TT
	HRRZ TT,V%TYO
	MOVE T,ASAR(TT)
	TLNN T,AS.FIL		 ;Is "TYI" a File Array?
	 MOVEI TT,TTYIFA	 ; If not, substitute initial TTY file array 
	MOVE TT,TTSAR(TT)
	TLNE TT,TTS<TY>		 ;IFF it's a TTY
	  PUSHJ FXP,CLRO3	 ;  ALSO DO (CLEAR-OUTPUT T)
CN.W0:	POP FXP,TT
	POP FXP,T
	JRST CHNI2

IFN D20,[
CN.Z:	PUSH FXP,T
	PUSH FXP,TT
	MOVEI T,CN.Z0		;RETURN TO SUPERIOR (MAY BE IDDT)
	MOVE TT,INTPDL
	EXCH T,IPSPC(TT)
	MOVEM T,CN.ZX
	POP FXP,TT
	POP FXP,T
	JRST CHNI2		;ALPT$G PROCEEDS

CN.Z0:	HALTF
ALTP:	JRST 2,@CN.ZX
]	;END IFN D20

IFN D10,[
CN.Z:	SKIPE R,.JBDDT		;ANY DDT IN CORE?
	 JRST (R)
	EXIT 1,			;RETURN TO MONITOR IF NO DDT, CONT CONTINUES
ALTP:	JRST CHNI2		;PROCEED ON ALTP$G
]	;END IFN D10

IFN ITS,[
CN.Z:	PUSH FXP,TT		;WE NEED ONE AC TO HOLD CHANNEL NUMBER
	HRRZ TT,-2(FXP)
	.CALL CKI2I
	 .VALUE
	POP FXP,TT
	.VALUE [ASCIZ \:DDTî\]
	JRST CHNI2

CKI2I:	SETZ
	SIXBIT \RESET\
	400000,,TT
]		;END IFN ITS

CTRLG:	HRROI D,-3		;^G - SUBR 0
	PIPAUSE			;DISABLE THE INTERRUPT SYSTEM FOR NOW
	SETZM UNREAR		;CLEAR OUT ALL STACKED INTERRUPTS
	SETZM INTAR
	HRREM D,INTFLG
	SKIPE NOQUIT		;HOW CAN NOQUIT BE NON-ZERO?
IT$	 .LOSE			; MAYBE THE USER SCREWED UP
IFN D10+D20, HALT
	JRST CKI0		;PROCESS THE FORCED QUIT

CN.X:	SKIPA D,[-6]		;ERRSETABLE (^X) QUIT
CN.G:	HRROI D,-7		;IMMEDIATE (^G) QUIT
	SKIPE UNREAL
	 JRST CN.G1
	SETZM INTAR		;KILL ALL INTERRUPTS STACKED UP
	HRREM D,INTFLG
	PUSHJ FXP,$IWAIT
	 SKIPA D,[CKI0]
	  JRST CHNI2		;CAN'T PROCESS QUIT NOW
	MOVEM D,IPSPC(F)	;IF CAN QUIT NOW, ARRANGE FOR SERVER
	JRST CHNI2		; TO RETURN TO INTERRUPT CHECKER

CN.G1:	SETZM UNREAR		;KILL STACKED UNREAL INTERRUPTS
	EXCH D,UNRC.G		;ELSE STACK UP AN UNREAL
	TRNE D,1		; ^G OR ^X INTERRUPT
	 MOVEM D,UNRC.G		;DON'T LET A ^X DISPLACE A ^G
	JRST CHNI2



IFN ITS\SAIL,[

IFN USELESS,[
FNYINT:	MOVE F,INTPDL		;COMMON HANDLER FOR FUNNY INTERRUPTS
	MOVE D,FXP
	SKIPE GCFXP
	 MOVE FXP,GCFXP
	PUSH FXP,D
	MOVE R,(R)
	SKIPN (R)
	 JRST INTXIT		;EXIT IF NO USER HANDLER
	HLRZ D,R
	CAIE D,UIFTTR		;SPECIAL HACK FOR TTY-RETURN
	 JRST FNYIN0
	HRRZ R,IPSPC(F)		;GET PC OF INTERRUPT
IFN ITS,[
	CAIE R,TYICAL		;INTERRUPTED FROM CANONICAL INPUT WAIT?
	 CAIN R,TYICA1
	  HRLI D,Q$IN		;YES, ARG TO INT FUN IS 'IN
]	;END OF IFN ITS
	CAIN R,TYIXCT		;ANOTHER CANNONICAL PLACE
	 HRLI D,Q$IN
FNYIN0:	SKIPGE UNREAL
	 JSP R,CHNI4C		;MUST STACK UP IF UNREAL
]		;END OF IFN USELESS
RCLOK2:	PUSHJ FXP,$IWAIT	;WILL STACK AND SKIP IF GC
	 JRST XUINT		;GIVE USER CLOCK INTERRUPT
	JRST INTXIT

]	;END OF IFN ITS\SAIL


IFN ITS,[
;;; REAL TIME ALARMCLOCK

REALCLOCK:
	MOVSI R,400000		;SHUT CLOCK BACK OFF
	.REALT R,
	MOVEI R,Q$TIME
	JRST RCLOK1

;;; RUNTIME ALARMCLOCK

RUNCLOCK:
	MOVEI R,Q$RUNTIME
RCLOK1:	MOVE F,INTPDL
	MOVE D,FXP
	SKIPE GCFXP
	 MOVE FXP,GCFXP
	PUSH FXP,D
	SKIPN VALARMCLOCK	;IGNORE IF THERE IS NO
	 JRST INTXIT		; ALARMCLOCK FUNCTION
	MOVSI D,(R)		;TYPE 0, SUBTYPE 0 IS ALARMCLOCK
	SKIPL UNREAL		;SKIP IF (NOINTERRUPT T)
	 JRST RCLOK2
	MOVEM D,UNRRUN-Q$RUNTIME(R)	;STACK UP INTERRUPT
	JRST INTXIT


IFN USELESS,[

;;; CLI INTERRUPT HANDLER

CLIINT:	JSP R,FNYINT
	UIFCLI,,VCLI

;;; RETURN OF TTY TO THE JOB

TTRINT:	JSP R,FNYINT
	UIFTTR,,VTTR

;;; SYSTEM GOING DOWN OR BEING DEBUGGED

SYSINT:	JSP R,FNYINT
	UIFSYS,,VSYSD

;;; MAR BREAK

MARINT:	MOVEI R,%PIMAR
	ANDCAM R,IMASK
	.SUSET [.SMASK,,IMASK]
	.SUSET [.SMARA,,R70]
	MOVEI R,1+.LZ %PIMAR
	SKIPN VMAR
	 JRST INTLS1		;IN CASE (STATUS MAR) GETS LOUSED UP
	JSP R,FNYINT
	UIFMAR,,VMAR

]		;END OF IFN USELESS
]	;END IFN ITS


;;; STACK UP A USER INTERRUPT WHICH MUST BE DELAYED.
;;; ARGUMENT IS IN D AS FOR UINT; IT IS SAVED IN THE INTAR QUEUE.
;;; ASSUMES FREE USE OF ACCUMULATOR R.
;;; PI INTERRUPTS MUST BE DISABLED!!!!
	.SEE PIOF

YESIN1:	POP P,UISTAK		;THIS IS A HORRIBLE CROCK
;UISTAK: 0
UISTK1:	MOVE R,INTFLG		;IF WE ARE ABOUT TO QUIT ANYWAY,
	AOJL R,@UISTAK		; THEN FORGET THE WHOLE THING
	AOS R,INTAR
	CAILE R,LINTAR
	 JRST TMDAMI		;TOO MANY DAMN INTERRUPTS
	MOVE R,[400000+LINTAR-1,,INTAR+LINTAR-2]
UISTK2:	POP R,1(R)
	TLNE R,377777
	 JRST UISTK2
	MOVSM D,INTAR+1
	SETOM INTFLG
	JRST @UISTAK

TMDAMI:	SKIPN GCFXP		;TOO MANY DAMN INTERRUPTS
	 JRST TMDAM2
IRP X,,[P,FLP,FXP,SP]
	MOVE X,GC!X
TERMIN
TMDAM2:
;	LERR [SIXBIT \TOO MANY DEFERRED INTERRUPTS!\]
IFN ITS,[
	.VALUE [ASCIZ \:TOO MANY DEFERRED INTERRUPTSCONTINî\]
	.LOSE
]		;END OF IFN ITS
10$	OUTSTR [ASCIZ \TOO MANY DEFERRED INTERRUPTS\]
10$	EXIT 1,
10$	JRST .-1

IFN D20,[
	HRROI 1,[ASCIZ \
?Too many deffered interrupts
\]
	HALTF
]		;END IFN D20

;QMARK -- THIS IS HERE SO BAKTRACE WILL FIND IT AS LAST SUBR (ARGG!!)
QMARK:	MOVEI A,QM
	POPJ P,



;;; PURE PAGE TRAP HANDLER
;;; COMES HERE WITH LOSING PC IN D.
	.SEE MEMERR

PURPGI:
IFN D10*<1-SAIL>,[
	SKIPE KA10P
	 SOSA D,IPSPC(F)	   ;MAKE PC POINT TO OFFENDING INSTRUCTION
	  SKIPA
	   ANDI D,-1
]	;END OF IFN D10*<1-SAIL>
IFN D20,[
	SKIPN TENEXP		   ;IF TENEX, PC MIGHT NOT BE RIGHT
	 JRST PURPGA
	PUSH FXP,1
	PUSH FXP,2
	MOVEI 1,.FHSLF
	GTRPW			   ;GET TRAP STATUS INTO 1, WRITE DATA INTO 2
	TLNN 1,000010		   ;BIT 14 - READ REQUEST
	 TLNN 1,000004		   ;BIT 15 - WRITE REQUEST
	  SKIPA			   ;READ RQ, OR NO WRITE RQ -- PC IS OK
	   SOS D,IPSPC(F)	   ;ONLY WRITE RQ, POINT TO ACTUAL INSTRUCTION
	HRRZS D			   ;CLEAR GARBAGE FROM LEFT HALF
	POP FXP,2		   ;RESTORE AC'S
	POP FXP,1
PURPGA:
]	;END IFN D20
	CAIN D,STQPUR
	 JRST PPGI5
PPGI5A:
IFN PAGING,[
MACROLOOP NPURTR,ZZP,*,		   ;ZZP MACROS DEFINE WHAT PLACES HAVE HANDLERS
]		;END IFN PAGING
	JUMPGE D,PURERR
PPGI3:
	HRRM D,IPSPC(F)
	JRST INTXIT

PPGI5:	HRRZS A			   ;FORGET LEFT HALF
	CAIN A,PWIOINT		   ;BINDING INTERRUPT INHIBITS: NORMAL PURTRAP
	 JRST PPGI5A
        MOVEM A,STQLUZ		   ;REMEMBER WHICH VALUE CELL WE TRIED TO GRONK
	MOVE D,[TIRPATE,,NIL]
	MOVEM D,(SP)
	SKIPE GCFXP
	 .VALUE
	AOS IPSPC(F)		;DON'T RETRY THE LOSING INSTRUCTION!
	PUSHJ FXP,$IWAIT	;LET SPDL GET CAUGHT UP
	 SKIPA T,STQLUZ		;ERROR HANDLER WANTS LOCATION IN T
	  JRST PURERR		;INTWAIT MAY SKIP
PPGI6:	HRRZI D,NILSETQ		;TRIED TO PUT A VALUE PROPERTY ON NIL
	JRST PPGI3


SUBTTL	USER INTERRUPT ROUTINES

;;; USER INTERRUPT TYPES FOR NEWIO
;;;
;;; FORM OF ARGUMENT TO UINT (ALSO STORED IN THIS FORM
;;; IN INTAR, ONLY WITH HALVES SWAPPED; WHY, I DON'T KNOW):
;;;
;;;	4.9-3.1	ARGUMENT FOR INTERRUPT FUNCTION
;;;	2.9	IF 1, SPECIFIES A TTY INPUT CHARACTER INTERRUPT.
;;;		ARGUMENT IS TTY INPUT FILE ARRAY.
;;;		2.8-2.4	MUST BE ZERO.
;;;		2.3-1.1	CHARACTER WHICH CAUSED INTERRUPT, AS
;;;			READ BY .ITYIC.  THIS MAY BE A 12.-BIT
;;;			CHARACTER, AND SO MAY HAVE TO BE FOLDED
;;;			BEFORE SELECTING THE INTERRUPT FUNCTION.
;;;			THIS IS PASSED AS THE SECOND ARGUMENT.
;;;	2.8	IF 1, SPECIFIES AN INTERRUPT RELATED TO A FILE
;;;		ARRAY OR SIMILAR OBJECT, E.G. THE **MORE**
;;;		INTERRUPT FOR TTY OUTPUT.
;;;		ARGUMENT IS THE FILE ARRAY.
;;;		2.7-1.1 IS THE INDEX OF THE INTERRUPT FUNCTION
;;;		WITHIN THE ARRAY, WHERE THE LOW BIT SPECIFIES
;;;		LEFT OR RIGHT HALF AS USUAL.
;;;	2.7	IF 1, SPECIFIES A MACHINE ERROR.
;;;		THE ARGUMENT IS THE LOCATION OF THE LOSS.
;;;		BITS 1.9-1.1 SPECIFY THE NATURE OF THE ERROR.
	UIMPAR==:0	;ODDP		;PARITY ERROR
	UIMILO==:1	;EVAL		;ILLEGAL OPERATION
	UIMWRO==:2	;DEPOSIT	;WRITE INTO READ-ONLY MEMORY
	UIMMPV==:3	;EXAMINE	;MEMORY PROTECT VIOLATION
;;;	IF 2.9-2.7 ARE ZERO, THEN:
;;;	2.2-2.1	TYPE OF INTERRUPT
;;;	1.9-1.1	SPECIFIC INTERRUPT
;;;	CURRENT TYPES AND SPECIFIC INTERRUPTS ARE:
;;;	0	RANDOM ASYNCHRONOUS (DELAYED BY (NOINTERRUPT T))
;;;		0	ALARMCLOCK
	UIFCLI==:1	;CLI-MESSAGE		;USELESS
	UIFMAR==:2	;MAR-BREAK		;USELESS
	UIFTTR==:3	;TTY-RETURN		;USELESS
	UIFSYS==:4	;SYS-DEATH		;USELESS
	UIFSMI==:5	;SAIL-MAIL-INT		;USELESS
IFE USELESS, NUINT0==:1			.SEE GCP6Q6
IFN USELESS,[
SA% 	NUINT0==:5			.SEE GCP6Q6
SA$	NUINT0==:6			;ALLOW FOR SAIL-MAIL INTERRUPT
]	;END OF IFN USELESS

;;;	1	RANDOM SYNCHRONOUS
;;;		0	AUTOLOAD
;;;		1	ERRSET FN
;;;		2	*RSET-TRAP
;;;		3	GC-DAEMON
;;;		4	GC-OVERFLOW
;;;		5	PDL-OVERFLOW
NUINT1==:6			.SEE GCP6Q6
;;;	2	ERINT (SYNCHRONOUS)
;;;		0	UNDF-FNCTN
;;;		1	UNBND-VRBL
;;;		2	WRNG-TYPE-ARG
;;;		3	UNSEEN-GO-TAG
;;;		4	WRNG-NO-ARGS
;;;		5	GC-LOSSAGE
;;;		6	FAIL-ACT
;;;		7	IO-LOSSAGE
NUINT2==:10			.SEE GCP6Q6

;;; WE NORMALLY DON'T PUSHJ HERE AT ALL FROM PI LEVEL!
;; (THINK ABOUT HOW TO SIMPLIFY THE CODE HERE.)

UINT:	PUSHJ P,UINTPU
	SKIPN NOQUIT
	 SKIPE INHIBIT
	  JRST UINT2
	SKIPGE INTFLG
	 JRST UINT3
	PUSHJ P,UINT0

.SEE UINTPU	;PEOPLE COME HERE TO UNDO UINTPU
		;NOTE: THE PUSH'S OF UINTPU MUST SYNC WITH THE POP'S HERE
UINTEX:
IFN <D10+D20>,[
	POP FXP,OIMASK
	POP FXP,IMASK
]		;END IFN <D10+D20>
	SKIPL (FXP)
	 JRST UINTX1
	PIONAGAIN
IT$ 	.SUSET [.SDF1,,R70]
IT$ 	.SUSET [.SDF2,,R70]

UINTX1:	SUB FXP,R70+1	;GET RID OF REENABLE INTERRUPTS FLAG
	POP FXP,R		.SEE UINTPU
	JRST CHECKI		;PDL-OVERFLOW MAY HAVE BEEN STACKED
				.SEE PDLOV


UINT2:	JSR UISTAK	;DELAY A USER INTERRUPT, SINCE INHIBIT SWITCH IS ON
	JRST UINTEX

UINT3:	HRRZ D,INTFLG		;CHECK INTERRUPT FLAG TO SEE THAT IS SAYS "QUIT"
	CAIE D,-1		;AND NOT SOME INCONGRUOUS USER PI
	 JRST CKI2
HHCTB:	.VALUE
;	LERR EMS11		;HOW THE HELL CAN THIS BE?



UINTPU:				;PUSH PI STATE, THEN DISABLE
	PUSH FXP,R		;SAVE R FOR UISTAK, ETC.
	PUSH FXP,T
IFE ITS,[
	PUSH FXP,IMASK		;SAVE APRENB MASKS
	PUSH FXP,OIMASK
	MOVN T,INTALL		;GET PI STATE FROM INTERNAL WORD
	EXCH T,-2(FXP)
	SKIPGE -2(FXP)
	 PIPAUSE
]		;END IFE ITS
IFN ITS,[
	.SUSET [.RPICLR,,T]
	EXCH T,(FXP)
	SKIPGE (FXP)
	PIPAUSE
]	;END OF IFN ITS

	POPJ P,



;;; SAVE THE WORLD FOR A USER INTERRUPT, INVOKE IT, AND RESTORE.
;;;
;;; SAVED QUANTITIES INCLUDE ALL ACCUMULATORS, THE PDL POINTERS
;;; (FOR FRETURN), AND THE SUPER-WRITABLE STUFF (TEMPORARIES IN
;;; LOW CORE USED BY INTERRUPTABLE FUNCTIONS).
;;; MANY GLOBAL SWITCHES ARE BOUND AND RESET.
;;; FOR ASYNCHRONOUS USER INTERRUPTS, THE (NOINTERRUPT T) STATE
;;; MAY BE ENTERED; THE PREVIOUS NOINTERRUPT STATE IS SAVED.
;;; MUST NOT COME HERE WITHOUT FIRST USING THE $IWAIT
;;; ROUTINE TO DECIDE WHETHER OR NOT WE ARE IN GC.
;;; ALSO MUST CHECK THE NOINTERRUPT SWITCH BEFORE COMING HERE
;;; IF THAT IS RELEVANT TO THE PARTICULAR USER INTERRUPT.
;;; INTERRUPTS MUST BE TURNED OFF WITH PIOF BEFORE COMING HERE.
;;; THE WORD DESCRIBING THE USER INTERRUPT MUST BE IN D.


YESINT:	SKIPN NOQUIT
	 SKIPE INHIBIT
	  JRST YESIN1
UINT0:
IT$	.SUSET [.SDF1,,TTYDF1]	;MUST ALLOW PDL OVERFLOW AND MEMORY
IT$	.SUSET [.SDF2,,TTYDF2]	; ERRORS TO GO THROUGH, BUT NO OTHERS
IT$	PION 
IFN D10+D20,[
	SETZM INTALL		;UNDO THE 'DALINT'
	PUSHJ P,DISINT		;DISABLE APPROPRIATE INTERRUPTS
]		;END IFN D10+D20
	HRRZS (P)		;WILL HRROS IF ASYNCHRONOUS
	PUSHJ P,SAVX5		;SAVE NUMERIC ACS
	PUSH FXP,UNREAL
	PUSH FXP,SPSV
BG$	PUSH FXP,BNV1
	MOVSI R,-LSWS
	PUSH FXP,SWS(R)
	AOBJN R,.-1
	PUSHJ FXP,SAV5	
	MOVEM SP,SPSV		;START BINDING VARIABLES
	MOVEI AR1,NIL
	MOVEI A,LISAR
	PUSHJ P,BIND4
	HRRZ AR2A,V%IBVL	;GET THE +INTERNAL-INTERRUPT-BOUND-VARIABLES
	MOVNI C,512.		;DON'T TRY TO BIND TOO MANY THINGS
UINT0A:	SKOTT AR2A,LS
	 JRST UINT0B
	HLRZ A,(AR2A)		;BIND ALL USER-SPECIFIED VARS TO () 
	PUSHJ P,BIND
	HRRZ AR2A,(AR2A)
	AOJL C,UINT0A
UINT0B:	JSP T,SPECX
	PUSHJ FXP,RST5
	SETZM PA4			;PA4 MUST BE IN THE "SWS" AREA
IFN USELESS,	SETZM TYOSW
	SETZM INHIBIT
	SETZM EOFRTN			;DO NOT SETZM CATRTN! GJS WANTS
	SETZM BFPRDP			; TO THROW OUT OF USER INTERRUPTS
	SETOM ERRSW
	MOVE T,[-LINTPDL,,INTPDL]	;MUSTN'T CALL UINT0 FROM
	CAME T,INTPDL			; WITHIN A PI SERVER
	 .LOSE
REPEAT 3,	PUSH FXP,R70	;RANDOM SLOTS FOR NUMERIC ARGS;
;				; ALSO 4.9 OF TOP ONE => RETURN VALUE MATTERS
UIXPUSH==:6+1+BIGNUM+LSWS+3		;AMOUNT OF STUFF PUSHED ON FXP
UISWS==:-<LSWS+3>+1			;WHERE SWS STARTS WHEN SAVED ON FXP
UISAVT==:UISWS-7-BIGNUM			;WHERE ACCUMULATOR T GETS SAVED
	PUSH P,[$UIFRAME]	;FRAME MARKER AND PDLS SAVED
	PUSH P,FXP		; SO THAT THROW AND FRETURN WIN
	HRLM FLP,(P)		.SEE UIBRK
	PUSHJ FXP,SAV5		;SAVE ARGUMENT ACS AND 40 ON
	PUSH P,40		; REGPDL FOR GC PROTECTION
	PUSH P,PA3
UIFRM==-3-NACS			;LOCATION OF FRAME ON REGPDL
UISAVA==UIFRM+2			;LOCATION OF AC A ON REGPDL
	MOVEI A,UIFRM(P)
	MOVEM A,UIRTN
	MOVSI AR2A,(CALLF 1,)
	HLRZ A,D		;GET FIRST ARG FOR INTERRUPT FN
	TRZN D,400000		;DECODE INTERRUPT TYPE
	 JRST UINT30
	HRRZM D,(FXP)		;TTY INPUT INTERRUPT CHAR
	MOVEI R,(D)
	MOVE TT,TTSAR(A)
	JSP D,TTYICH		;FETCH INTERRUPT FN
	MOVSI AR2A,(CALLF 2,)
	HRRI AR2A,(R)
	MOVEI B,(FXP)		;SECOND ARG IS CHARACTER
	JRST UINT31


UINT30:	TRZN D,200000
	 JRST UINT32
	MOVEI TT,(D)		;RANDOM FILE INTERRRUPT
	ROT TT,-1
	HRR AR2A,@TTSAR(A)	;FETCH INTERRUPT FUNCTION
	SKIPL TT
	 HLR AR2A,@TTSAR(A)
UINT31:	HRROS UIFRM-1(P)	;ASYNCHRONOUS INTERRUPT
	JRST UINT40

UINT32:	TRZN D,100000
	 JRST UINT33
	HRRZM A,-1(FXP)
	MOVEI A,QODDP(D)	;MACHINE ERROR
	MOVEI B,(FXP)
	MOVEI C,-1(FXP)
	MOVEI AR1,-2(FXP)
	MOVSI AR2A,(CALLF 4,)
	HRR AR2A,VMERR
	JRST UINT40

UINT33:	LDB TT,[110200,,D]	;BITS 2.2-2.1 ARE CLASS
	ANDI D,777		;1.9-1.1 ARE SUBTYPE
	XCT UINT90(TT)		;FETCH INTERRUPT FUNCTION
	XCT UINT91(TT)		;SPECIAL HACKS
UINT40:	SKIPGE UIFRM-1(P)
	 SETOM UNREAL
	PIONAGAIN		;***** RE-ENABLE INTERRUPTS *****
IT$	.SUSET [.SDF1,,R70]
IT$	.SUSET [.SDF2,,R70]
	TRNN AR2A,-1		;ONLY PROCESS INTERRUPT IF INT FUNCTION NON-NIL
	 TDZA A,A		;FORCE A RETURNED VALUE OF NIL IF IT MATTERS
	  XCT AR2A		;APPLY INTERRUPT FUNCTION
	HRRZ T,UIFRM+1(P)
	CAIE T,(FXP)
	 PUSHJ P,UINT45
	HLRZ T,UIFRM+1(P)
	CAIE T,(FLP)
	 PUSHJ P,UINT46
	PIPAUSE
	SKIPGE (FXP)		;IF RETURN VALUE MATTERS
	 MOVEM A,UISAVA(P)	; SAVE IT FOR RETURN
	PUSHJ P,UNBIND		;RESTORE LISAR, ETC.
UINT0X:	HRLI R,UISWS(FXP)
	HRRI R,SWS
	BLT R,SWS+LSWS-1	;RESTORE SUPER-WRITABLE STUFF
	SUB FXP,[-UISWS+1,,-UISWS+1]
BG$	POP FXP,BNV1
	POP P,PA3
	POP P,40
	PUSHJ FXP,RST5M1
	POP P,-2(P)	;KNOCK OFF PDLS AND UIFRAME, SAVING
	SUB P,R70+1	; SAVED CONTENTS OF A FOR POPAJ BELOW
	POP FXP,SPSV	;Restore state of SPECBINDing
	POP FXP,D	;OLD STATE OF UNREAL
	SKIPL -1(P)	;IF INTERRUPT WASN'T ASYNCHRONOUS,
	 JRST UINT88	; MUSTN'T ATTEMPT TO RESTORE UNREAL
	EXCH D,UNREAL	;WELL, WE WANT TO RESTORE IT. WAS IT ON
	JUMPE D,UINT88	; JUST NOW? IF NOT, RETURN.
	SKIPE A,UNREAL	;DID WE JUST TURN IT OFF BY RESTORING IT?
	 JRST UINT0Z	;NO, IT'S STILL ON - RETURN.
UINT0N:	HRRZ T,-1(P)	;IS THE CHECKU ROUTINE ITSELF CALLING ME?
	CAIGE T,ENOINT	; DON'T WANT TO GET STUCK IN INFINITELY
	 CAIGE T,NOINTERRUPT	; RECURSIVE CALLS
	  PUSHJ P,CHECKQ	;HACKISH ENTRY INTO CHECKU
	JRST UINT88

UINT0Z:	SKIPLE UNREAL
	 JUMPLE D,UINT0N
UINT88:	PUSHJ P,RSTX5
	PIONAGAIN		;RE-ENABLE INTERRUPTS
	JRST POPAJ
EUINT0::		.SEE PDLOV	;END OF UINT0

UINT45:	SKIPA B,[QFIXNUM]
UINT46:	 MOVEI B,QFLONUM
	EXCH A,B
	PUSHJ P,UINT49
	EXCH A,B
	POPJ P,

UINT49:	FAC [PDL OUT OF PHASE IN USER INTERRUPT (SYSTEM ERROR)!]
	
UINT90:	HRR AR2A,VALARMCLOCK(D)		;ALARMCLOCK SERIES
	HRR AR2A,VAUTFN(D)		;RANDOM SYNCHRONOUS
	HRR AR2A,VUDF(D)		;ERINT SERIES
	.VALUE				;??

UINT91:	HRROS UIFRM-1(P)	;ALARMCLOCK (ASYNCHRONOUS)
	JFCL			;RANDOM SYNCHRONOUS
	SETOM (FXP)		;ERINT (VALUE MATTERS)
	.VALUE			;??


CKI0:	PUSH FXP,D
	HRRZ D,INTFLG
	CAIN D,-1
	 JRST CKI1		;DELAYED USER INTERRUPT
	PIPAUSE
CKI2:	SETZM UNREAR
CKI2A:	SETZM UNRC.G		;CHECKU JOINS IN AT THIS POINT
	SETZM INTFLG		;	RESET TTY	NO RESET
	TRNE D,4		;^X	   -6		   -2
	 JRST CKI3		;^G	   -7		   -3
IFN ITS+D20,[
	PUSH FXP,D
	MOVEI F,LCHNTB-1	;RESET ALL TTY FILES
CKI2F:	SKIPN AR1,CHNTB(F)
	 JRST CKI2F1
	MOVE TT,TTSAR(AR1)
	TLNN TT,TTS.CL		;DON'T RESET THE FILE IF IT IS CLOSED
	 TLNN TT,TTS.TY
	  JRST CKI2F1
	MOVEI T,CLRI3
	TLNE TT,TTS.IO
	 MOVEI T,CLRO3
	PUSHJ FXP,(T)
CKI2F1:	SOJG F,CKI2F
	POP FXP,D
]		;END OF IFN ITS+D20
10$	CLRBFO
10$	CLRBFI
CKI3:
CKI3B:	TRNN D,2
	 SKIPE PSYMF
RQITR:	  LERR [SIXBIT \QUIT!\]	;SO ERROR OUT FOR ^X
IFN USELESS*ITS,[
	MOVE T,IMASK
	TRNN T,%PIMAR
	 JRST CKI4A
	.SUSET [.RMARA,,SAVMAR]
	.SUSET [.SMARA,,R70]	;AVOID TRIPPING THE MAR DURING THE ERRPOP
CKI4A:
]		;END OF IFN USELESS*ITS
	PIONAGAIN
	PUSHJ FXP,ERRPOP
	PIPAUSE
IFN USELESS*ITS,[
	TRNE T,%PIMAR		;ERRPOP PRESERVES T
	 .SUSET [.SMARA,,SAVMAR]	
]		;END OF IFN USELESS*ITS
	MOVE A,VERRLIST
	MOVEM A,VIQUOTIENT
	JSP A,ERINI0
	MOVE P,C2		;DRASTIC ACTION FOR ^G
	SETZM TTYOFF
	STRT 17,@RQITR
	JRST LSPRT1		;WILL PION WITHIN ERINIT

CKI1:	SKIPE INHIBIT		;RETURN TO SERVICE THE DELAYED INTERRUPT
	 JRST POPXDJ		;BUT NO SERVICE WHEN INHIBIT = -1
	PUSHJ P,UINTPU
	SETZM INTFLG
	PUSH P,A
	PUSH P,A
	HLLOS INHIBIT
	SKIPG A,INTAR
	 LERR EMS13		;LOST USER INTERRUPT
CKI1A:	MOVS D,INTAR(A)		;FOR GC PROTECTION
	MOVSM D,(P)
	SOSG INTAR		;CYCLE THROUGH THE DELAYED INTERRUPTS
	 SETZM INTFLG		;TO PREVENT TIMING SCREWS, CLEAR INTFLG IF
				; NO MORE INTERRUPTS PENDING
	PUSHJ P,UINT0
	SKIPLE A,INTAR
	 JRST CKI1A
	SUB P,R70+1
	POP P,A
	SETZM INHIBIT
	PUSHJ P,UINTEX
	JRST POPXDJ

SUBTTL UUOH HANDLER (INCLUDING STRT)

;UUOH:	0			;UUO HANDLER
UUOH0:	MOVEM T,UUTSV
	LDB T,[331100,,40]
	CAIL T,CALL_-33
	 JRST UUOH0B		;PROBABLY A LISP "CALL" UUO
UUOH2:	CAILE T,UUOMAX
	 SETZ T,
	JRST @UUOH2A(T)
UUOH2A:	ERRBAD		;0 IS ILGL, ILGL, ILGL
	ERROR1		;LERR	;UNCORRECTABLE LISP ERROR
	UUOACL		;ACALL	;KLUDGE FOR NCALLING ARRAYS
	UUOAJC		;AJCALL	;JRST VERSION OF ACALL
	ERROR1		;LER3	;LERR, BUT ALSO PRINT ACCUMULATOR A
	ERROR5		;ERINT	;CORRECTABLE ERROR WITH SIXBIT MSG
	POF1		;PP Z$X	;PRINT OUT Z FROM DDT
	STRTOUT		;STRT	;SIXBIT STRING TYPE OUT
	ERROR5		;SERINT	;CORRECTABLE ERROR WITH S-EXP MSG
	TOF1		;TP Z$X	;TYPEP PRINTOUT OF Z FROM DDT
	ERRIOJ		;IOJRST	;HAIRY FROB TO GET I/O ERROR MSGS
	STRTOUT		;STRT7	;ASCII STRING TYPE OUT

IFN .-UUOH2A-1-UUOMAX, WARN [UUOH2A OUT OF PHASE]


UUOACL:	PUSH P,UUOH
   BAKPRO
UUOAJC:	MOVE T,@40		.SEE ASAR
	TLNE T,AS<FX+FL>
	AOJA T,.+2	;FOR NUMBER ARRAYS, ENTER AT HEADER+1
	PUSH P,[UUONVL]	;FOR OTHER ARRAYS, USE NUMVAL CHECK ROUTINE
   XCTPRO
	EXCH T,UUTSV
   SPECPRO INTACT
	JRST @UUTSV
   NOPRO





;;; DISPATCH ON "CALL" TYPE UUO, TRAPPING TO INTERPRETER IF NECESSARY

UUOH0B:	CAILE T,NJCALF_-33
	 JRST UUOH2
	MOVEM TT,UUTTSV
	MOVEM R,UURSV
	LDB TT,[270400,,40]
	CAIG TT,15		;LISP "CALL" TYPE UUOS
	 TDZA R,R
	  MOVEI R,-15(TT)
	HRRZ T,40
UUOH0A:	MOVEM T,UUOFN
	TLZ T,-1
	MOVEI TT,(T)
	LSH TT,-SEGLOG
	SKIPGE TT,ST(TT)
	 JRST @UUNAF(R)
	TLNN TT,SY
	 JRST UUOH0C
	TLZ R,700000		;400000 => AUTOLOAD, 200000 => MACRO,
				; 100000 => ALREADY DID AUTOLOAD
;;;  FALLS THRU


;;;  FALLS THRU

UUOH1:	HRRZ T,(T)
	JUMPE T,UUOH1A
	HLRZ TT,(T)
	HRRZ T,(T)
	CAIL TT,QARRAY
	 CAILE TT,QAUTOLOAD
	  JRST UUOH1
   2DIF JRST @(TT),UUOTRT,QARRAY

UUOH0C:	TLNN TT,SA
	JRST UUOH3A
	HRRZ TT,ASAR(T)		;HANDLE CASE OF A SAR EFFICIENTLY
	CAIN TT,ADEAD
	JRST UUOH3A
	MOVSI T,(T)
	HRRI T,T
	JRST @UUAT(R)

UUOH1A:	JUMPL R,UUALT1
	TLNE R,200000
	 JRST UUOMER
	PUSH P,A
	PUSH P,B
	SKIPGE A,UUOFN
	 JRST UUOUER
	HLRZ T,(A)		;OPENCODED SYMEVAL
	HRRO T,@(T)
UUOH3B:	POP P,B
	POP P,A
	SKIPN EVPUNT		;SHOULD WE ALLOW FUNCTIONAL VARIABLES?
	CAIN T,QUNBOUND		;YES, IS IT BOUND?
	 JRST UUOH3A		;NO TO EITHER QUESTION, SO ERROR
	JRST UUOH0A





;;UUO TRANSFER TABLE, ONCE FUNCTION TYPE IS KNOWN

UUOTRT:
IRPS LL,X,[A+S+FS+L+E+FE+MC-AL-]
IFSE X,+, @UU!LL!T(R)
IFSE X,-, UU!LL!T
TERMIN

;;; MOBY DISPATCH TABLE FOR DECODING UUO CALL TYPES!
;;;	R=0 => COMPILED ROUTINE CALLING A SUBR TYPE
;;;	R=1 => COMPILED ROUTINE CALLING A LSUBR TYPE
;;;	R=2 => COMPILED ROUTINE CALLING A FSUBR TYPE

UUAT:	UUOARR	;CALLING SUBR - IT'S AN ARRAY		**WIN**
	UUOS1A	;CALLING LSUBR - IT'S AN ARRAY
	UUOS2A	;CALLING FSUBR - IT'S AN ARRAY
UUST:	UUOS0	;CALLING SUBR - IT'S A SUBR		**WIN**
	UUOS1	;CALLING LSUBR - IT'S A SUBR
	UUOS2	;CALLING FSUBR - IT'S A SUBR
UUFST:	UUOS10	;CALLING SUBR - IT'S AN FSUBR
	UUOS11	;CALLING LSUBR - IT'S AN FSUBR
	UUOSBR	;CALLING FSUBR - IT'S AN FSUBR		**WIN**
UULT:	UUOS7	;CALLING SUBR - IT'S AN LSUBR
	UUOLSB	;CALLING LSUBR - IT'S AN LSUBR		**WIN**
	UUOS9	;CALLING FSUBR - IT'S AN LSUBR
UUET:	UUOEXP	;CALLING SUBR - IT'S AN EXPR
	UUOS5	;CALLING LSUBR - IT'S AN EXPR
	UUOS6	;CALLING FSUBR - IT'S AN EXPR
UUFET:	UUOS3	;CALLING SUBR - IT'S A FEXPR
	UUOS4	;CALLING LSUBR - IT'S A FEXPR
	UUOEX2	;CALLING FSUBR - IT'S A FEXPR
UUNAF:	UUOS	;CALLING SUBR - IT'S A NONATOMICFUN
	UUL2N	;CALLING LSUBR - IT'S A NONATOMICFUN
	UUF2N	;CALLING FSUBR - IT'S A NONATOMICFUN


UUALT:	HRRZM T,UUALT9		;FOUND AN AUTOLOAD PROPERTY
	TLOA R,400000
UUMCT:	 TLO R,200000		;MACROS ARE IGNORED, SORT OF
	JRST UUOH1

UUALT1:	TLOE R,100000		;CALLING ANYTHING - IT'S AN AUTOLOAD
	 JRST UUOH3C		;LOSE IF JUST DID AN AUTOLOAD ALREADY
	PUSH P,A
	HLRZ A,@UUALT9		;OTHERWISE AUTOLOAD THE FUNCTION
	MOVE T,UUOFN
	PUSHJ P,AUTOLOAD	;BETTER SAVE R, BY GEORGE!
	POP P,A
	MOVE T,UUOFN
	JRST UUOH1		;NOW TRY IT AGAIN


;;; MAY CALL UUOBNC AND UUOBAK ONLY WHEN *RSET IS KNOWN
;;; TO BE NON-NIL - AVOIDS CERTAIN TIMING ERRORS.

UUOBNC:	POP P,UUOBKG	;UUOBKG WITH NO CPOPJ
	HRROS UUOBKG	;FOR UUO GUYS THAT CALL IAPPLY,
	JRST UUOBK0	; WHICH ITSELF SETS UP A CPOPJ

UUOBAK:	POP P,UUOBKG	;WATCH THIS CROCK!
	JRST UUOBK7

;;;UUOBKG:	0
UUBKG1:	SKIPN V.RSET	;CHECK TO SEE WHETHER IN *RSET MODE
	JRST @UUOBKG	;SAVES ALL ACS; T HAS -<# OF ARGS>
UUOBK7:	HRRZS UUOBKG
UUOBK0:	SKIPE NIL
	PUSHJ P,NILBAD
	PUSH FXP,TT	;PDLS MUST BE AS FRETURN WOULD WANT
	PUSH FXP,R	; TO RESTORE THEM TO
	JUMPGE T,UUOBK1	;IF T>0, THEN ASSUME 0, AND THE
	JSP TT,ARGP0	; ARGS WILL BE FILLED IN LATER
	MOVNI TT,(T)
	SKIPGE A
	SETZ TT,
	HRLM TT,(P)
	JRST UUOBK8
UUOBK1:	PUSH P,R70
UUOBK8:	MOVEI TT,-2(FXP)
	HRLI TT,(FLP)
	PUSH P,TT
	HRRZ TT,40
	HRLI TT,(SP)
	PUSH P,TT
	JUMPLE T,UUOBK5
	PUSH P,R70
	JRST UUOBK6
UUOBK5:	PUSH P,[$APPLYFRAME]
UUOBK6:	MOVS R,40
	HRRI R,CPOPJ
	SKIPL UUOBKG		;MAYBE DON'T WANT THE CPOPJ
	PUSH P,R
	HRRZS UUOBKG
	POP FXP,R
	POP FXP,TT
	JRST @UUOBKG



UUOSBR:	HLRZ T,(T)		;*** FSUBR CALLED LIKE FSUBR
	MOVEM P,UUPSV
	MOVNI R,1
	TLOA A,400000
UUOSB2:	MOVEI R,1		;R>0 SAYS DON'T DO FRAME HACKERY
UUOSB3:	MOVE TT,40		;OTHERWISE R HAS -<# OF ARGS>
UUOSB5:	TLO T,(PUSHJ P,)
	TLNE TT,(1_33)		;THE NO-PUSH, OR JRST, BIT.  SEE DEFINITION OF JCALL
	TLCA T,(JRST#<PUSHJ P,>)
	PUSH P,UUOH
UUOSB6:	JUMPG R,UUOSB7
	EXCH T,R
	JSR UUOBKG
	EXCH T,R
UUOSB7:	TLZ A,-1
	TLNE TT,(20_33)		;THE NUMERIC CALL BIT.  SEE DEFINITION OF NCALL
	AOS T			;FOR NCALL, ENTER AT ENTRY+1
	SKIPN VNOUUO
	TLNE TT,(2_33)		;THE NO-CLOBBER BIT.  SEE DEFINITION OF CALLF
	JRST UUOXT0
	SOS TT,UUOH
UUOSB4:	LDB R,[331100,,(TT)]
	CAIN R,XCT_-33
	JRST UUOXCT		;MAKE XCT OF UUO WORK
	MOVEM T,(TT)
UUOXT0:	TLNN T,(34_33)		;CAUSE EXIT TO INDIRECT THRU ACALL
	TLO T,(@)
UUOXIT:	EXCH T,UUTSV
UUOXT1:	MOVE TT,UUTTSV
	MOVE R,UURSV
	JRST @UUTSV

UUOXCT:	LDB R,[220400,,(TT)]	;GET INDEX FIELD OF XCT
	JUMPE R,.+2
	HRRZ R,@UUOACS-1(R)	;IF NON-ZERO, GET CONTENTS OF THAT AC
	ADD R,(TT)		;ADD IN ADDRESS FIELD
	HLL R,(TT)
	MOVEI TT,(R)
	TLNE R,(@)
	JRST UUOXCT		;MAKE INDIRECTION WIN
	JRST UUOSB4		;MAKE XCT OF XCT ... OF XCT OF UUO WIN

;;; TABLE OF WHERE TO FIND THE ACS AS THEY WERE ON UUO ENTRY
UUOACS:
IRPS X,,[A B C AR1 AR2A UUTSV UUTTSV D UURSV F FREEAC UUPSV FLP FXP SP]
	X
TERMIN

UUOARR:	HLRZ R,(T)		;*** ARRAY CALLED LIKE SUBR
	MOVSI TT,(@)
	JRST UUOS03

UUOS0:	SETZ TT,		;*** SUBR CALLED LIKE SUBR
	HRRZ R,UUOFN
UUOS03:	MOVEM P,UUPSV		;THIS IS TO HELP UUOXCT
	HLR TT,(T)
	PUSH P,TT
	LDB T,[270400,,40]
	MOVNS T
	PUSH FXP,T
	PUSHJ P,ARGCHK	;SKIPS IF OK
	 JRST UUOS0E
	POP FXP,R	;R NOW HAS -<# OF ARGS>
	POP P,T
	TLNN T,(@)	;FURTHER WORK NEEDED FOR CALLING AN ARRAY
	 JRST UUOSB3
	MOVSI TT,TTS<CN>
	HLL A,40		;UUOSB7 WILL CLEAR LEFT HALF OF A
	TLNN A,2000		;DO NOT SET THE COMPILED-CODE-
	 IORM TT,TTSAR(T)	; NEEDS-ME BIT FOR A CALLF!
	MOVE TT,40
	TLZN TT,(20_33)
	 JRST UUOSB3
	TLNN TT,(2_33)
	 JRST UUOAR2	;NCALL'ING AN ARRAY MEANS CLOBBER, 
	PUSH P,[UUONVL]	; IF ANY, SHOULD BE TO ACALL
	JRST UUOSB5


UUOAR2:	TLNN TT,1000
	 TLOA T,(ACALL)	;NCALL, BUT NOT NCALLF => ACALL
	  TLOA T,(AJCALL)	;NJCALL, BUT NOT NJCALF => AJCALL
	   PUSH P,UUOH
	TLZ TT,777000
	TLZ T,(@)
	JRST UUOSB6

UUONVL:	SKOTT A,FX+FL
	JRST UUONVE
FIX7:	MOVE TT,(A)	;OF COURSE, THE ROUTINE HAD BETTER COME UP 
	POPJ P,		;WITH SOME LISP NUMBER AS VALUE

UUOS1E:	PUSH FXP,D
	MOVEI D,1
	JRST UUOE3
UUOS2E:	MOVEM D,(FXP)	;TAKE THE SPOT ALREADY PUSHED ON FXP
	MOVEI D,3
UUOE3:	PUSHJ P,SAVX3	;ARGS WERE ALREADY ON PDL, HENCE MUST BE POPPED OFF
	MOVEM B,QF1SB	;SO WE MIGHT AS WELL LIST THEM UP WHILE WE'RE AT IT
	PUSH FXP,T
	PUSHJ FXP,LISTX
	POP FXP,T
	MOVE B,QF1SB
	JRST UUOE2

UUOS0E:	SUB P,R70+1
UUOS0F:	PUSH FXP,D
	PUSHJ P,SAVX3
	MOVEI D,0
UUOE2:	TLNE D,2	;D 1.2 => EXIT ADDRESS ALREADY BEEN HACKED
	  JRST .+4
	MOVE R,40
	TLNN R,1000
	  PUSH P,UUOH
	PUSHJ FXP,SAV5M1
	PUSHJ P,[MOVE TT,40
		 HRLS TT
		 PUSH P,TT	;NAME OF FUNCTION IN LH
		 TRNN D,1	;1.1 => LISTING HAS ALREADY BEEN DONE
		   JSP TT,ARGP0	;ARGS TO FUNCTION NOW ON PDL
		 MOVEM D,-1(FXP)
		 PUSHJ P,RSTX3	;RECUPERATE - IF POSSIBLE, DO NEW EVALUATION
		 JRST WNAERR	;OR ELSE CRAP OUT ON WRONG NUMBER ARGS
		 ]
UUOSE1:	PUSHJ FXP,RST5M1
	POP FXP,D
	POPJ P,

UUOS1:	HRRZ TT,(T)		;*** SUBR CALLED LIKE LSUBR
	HLRZ T,(T)
	EXCH T,UUTSV
	JSP R,PDLARG
	HRRZ R,UUOFN
	PUSHJ P,ARGCK0		;FORCE CHECKING OF NUMBER OF ARGS
	JRST UUOS0F
	MOVE TT,40
	TLNE TT,(20_33)	;THE NCALL BIT
	AOS UUTSV
	TLNN TT,(1_33)		;THE NO-PUSH, OR JRST, BIT.  SEE DEFINITION OF JCALL
	PUSH P,UUOH
	JSR UUOBKG
	JRST UUOXT1

UUOX4B:	SKIPN UUOH	;=0 MEANS ENTRY FROM MAP SERIES
	JRST (R)
	PUSHJ FXP,SAV5M1
	PUSH P,CR5M1PJ
	JRST (R)

UUOLSB:	MOVEM P,UUPSV	;*** LSUBR CALLED LIKE LSUBR
	MOVEI A,NIL
	HLRZ T,(T)
	SKIPN V.RSET
	JRST UUOSB2
	PUSH FXP,T	;SAVE T (ADDRESS OF LSUBR)
	MOVE T,UUTSV
	PUSH FXP,T	;SAVE -<# OF ARGS> FOR UUOFUL
	HRRZ R,UUOFN	;FOR ARGCK0
	PUSHJ P,ARGCK0
	JRST UUOS1E
	MOVE R,T	;WATCH THIS SHUFFLING OF R, T, AND UUTSV!
	JSP T,NPUSH-6	;SIX SLOTS FOR "APPLY FRAME", ETC.
	MOVE T,UUTSV
	MOVEM R,UUTSV
	MOVEI T,(P)
UUOLB3:	AOJG R,UUOLB4	;SO SLIDE STUFF SIX SLOTS UP THE PDL
	MOVE TT,-6(T)	;AT END, T POINTS TO LAST OF THE FIVE
	MOVEM TT,(T)	; FRAME SLOTS FOR UUOFUL
	SOJA T,UUOLB3
UUOLB4:	MOVE TT,40	;FIGURE OUT IF CALL OR CALLF TYPE
	MOVEI R,CPOPJ	; (MAY BE CALL TYPE IF 0 ARGS)
	TLO R,(PUSHJ P,)	;FIGURE IT OUT
	TLNE TT,1000			;IT MAY LOOK LIKE WE'RE CONSTRUCTING A PUSHJ
	TLCA R,(JRST#<PUSHJ P,>)	; TO THE WRONG PLACE, BUT READ THIS CAREFULLY!
	HRR R,UUOH		;RETURN ADDRESS MUST GO UNDER
	HRRZM R,-5(T)		; THE FRAME, NOT OVER!!!
	HLLM R,-1(FXP)	;SAVE INSTRUCTION TO CLOBBER WITH
	MOVEI TT,(T)
	PUSHJ P,UUOFUL	;SO STICK AN APPLY FRAME UNDER ARGS, IF ANY
			;REMEMBER, UUOFUL EXPECTS TWO FROBS
			; ON FXP, AND POPS ONE OF THEM
	POP FXP,T	;RESTORE T (ADDRESS OF LSUBR)
	MOVE TT,40
	JRST UUOSB7


UUOFUL:	MOVS R,40		;PUT FRAME UNDER LSUBR CALL
	HRRI R,CPOPJ		;TT POINTS TO LAST OF 5 PDL SLOTS
	MOVEM R,(TT)		;USES T,TT,R
	MOVEI R,-2(FXP)		;FXP HAS -<# OF ARGS> AND ONE
	HRRM R,-3(TT)		; OTHER SLOT AS WELL
	HRLM FLP,-3(TT)
	HRLM SP,-2(TT)
	HRRZ R,40
	HRRM R,-2(TT)
	POP FXP,T
	MOVEI R,(T)
	HRLI R,-1(T)
	ADDI R,(P)
	SKIPN T
	SETZ R,
	MOVEM R,-4(TT)
	MOVE R,[$APPLYFRAME]
	MOVEM R,-1(TT)
	POPJ P,


UUOS9:	SKIPA TT,CILIST	;*** LSUBR CALLED LIKE FSUBR
UUOS7:	MOVEI TT,ARGPDL	;*** LSUBR CALLED LIKE SUBR
	MOVE R,40
	TLNN R,1000
	PUSH P,UUOH
	HLRZ T,(T)
	TLNE R,(20_33)		;THE NCALL BIT
	ADDI T,1
	PUSH FXP,T
	PUSH FXP,XC-1
	SKIPN V.RSET
	JRST UUOS7A
	MOVEI T,1
	PUSHJ P,UUOBAK
REPEAT 2,	SOS -3(P)	;ALLOW FOR TWO FROBS ON FXP
	HRRZM P,(FXP)
UUOS7A:	JSP TT,(TT)	;ARGPDL OR ILIST
	POP FXP,R
	JUMPL R,UUOS7K
	SKIPN TT,T
	JRST UUOS7H
	HRLI TT,-1(TT)
	ADDI TT,1(P)
UUOS7H:	MOVEM TT,-4(R)
	MOVE TT,[$APPLYFRAME]
	MOVEM TT,-1(R)		;APPLYFRAME DONE
UUOS7K:	MOVEM T,UUTSV
	HRRZ R,UUOFN
	PUSHJ P,ARGLCK
	JRST UUOS2E
	POP FXP,T
	MOVEI A,0
	JRST UUOXIT



UUOS2A:	HLRZ TT,(T)	;*** ARRAY CALLED LIKE FSUBR
	MOVEM TT,LISAR
	MOVEI R,(TT)
	MOVEI TT,IAPAR1
	JRST UUOS2Q

UUOS2:	HLRZ TT,(T)	;*** SUBR CALLED LIKE FSUBR
	HRRZ R,UUOFN
UUOS2Q:	MOVE T,40
	TLNN T,1000
	PUSH P,UUOH
	TLNE T,(NCALL)
	PUSH P,[UUONVL]
	CAIN T,IAPAR1
	PUSH P,LISAR
	PUSH FXP,TT	;SUBR ADDR
CILIST:	JSP TT,ILIST	;ILIST FORTUNATELY SAVES R
	PUSHJ P,ARGCHK
	JRST UUOS2E
	JSP R,PDLARG
	POP FXP,TT	;PRESERVE T FOR UUOBKG
	CAIN TT,IAPAR1
	POP P,LISAR
	JSR UUOBKG
	MOVEI T,(TT)	;BEWARE! LOOSE SUBR POINTER
	JRST UUOXIT

UUOS1A:	HLRZ TT,(T)	;*** ARRAY CALLED LIKE LSUBR
	MOVEM TT,LISAR
	MOVEI T,IAPAR1	;HAIR SO INTERRUPTS WON'T SCREW US
	EXCH T,UUTSV
	JSP R,PDLARG	;SAVES TT
	JSR UUOBKG	;ALSO SAVES TT, AND WANTS NOTHING ON PDLS
	LDB R,[TTSDIM,,TTSAR(TT)]
	MOVE TT,40
	TLNN TT,1000
	PUSH P,UUOH
	TLNE TT,(NCALL)
	PUSH P,[UUONVL]
	MOVNI TT,(R)		   ;WNAERR will look at TT if error
	CAMN TT,T
	  JRST UUOXT1
	AOS R			   ;Fake an ARGS property from # of dims
	PUSH FXP,D
	PUSHJ P,SAVX3
	JRST UUOE2



;;;	PUTCODE [EXPR _ FSUBR]40

UUOS4:	POP P,A			;*** FEXPR CALLED LIKE LSUBR
	MOVN TT,UUTSV
	JRST UUOS4A

UUF2N:	SKIPA TT,40		;*** NONATOMICFUN CALLED LIKE FSUBR
UUOS6:	HLRZ TT,(T)		;*** EXPR CALLED LIKE FSUBR
	MOVE R,40
	TLZN TT,-1		;UUF2N LEAVES LH OF T ^= 0
	HRL TT,R		;OTHERWISE GET SUBR EXPR NAME IN LH 
	TLNN R,1000
	PUSH P,UUOH
	TLNE R,(20_33)		;THE NCALL BIT
	PUSH P,[UUONVL]
	JSP R,UUOX4B
	SKIPN V.RSET
	JRST UUOS6Q
	PUSH P,FXP		;IF IN *RSET MODE, MAKE
	HRLM FLP,(P)		; UP AN EVAL FRAME (SEE EVAL
	MOVEI C,(A)		; FOR FORMAT THEREOF)
	HRRZ B,40
	PUSHJ P,XCONS		;MUST CONS UP FAKE ARG TO EVAL
	PUSH P,A
	HRLM SP,(P)
	PUSH P,[$EVALFRAME]
	MOVEI A,(C)
UUOS6Q:	PUSH P,TT		;PUSH OF FUNCTION
	MOVEI TT,IAPPLY
	JRST ILIST

UUOS11:	MOVEM T,UUOFN		;*** FSUBR CALLED LIKE LSUBR
	MOVE T,UUTSV
	JRST UUS10A

;;;	ENDCODE [EXPR _ FSUBR]


UUOS3:	LDB TT,[270400,,40]	;*** FEXPR CALLED LIKE SUBR
UUOS4A:	SOJN TT,UUOFER
UUOEX2:	MOVEI TT,1		;*** FEXPR CALLED LIKE FSUBR
	DPB TT,[270400,,40]
	TLOA A,400000
UUOS:	SKIPA TT,40		;*** NONATOMICFUN CALLED LIKE SUBR
UUOEXP:	HLRZ TT,(T)		;*** EXPR CALLED LIKE SUBR
	LDB T,[270400,,40]
UUOEX4:	MOVE R,40		;ALL OF T,TT,R WILL BE LOST!
	TLZN TT,-1		;INSERT EXPR NAME IF WAS EXPR
	HRL TT,R
	TLNN R,1000
	PUSH P,UUOH
	MOVN T,T
	SKIPE V.RSET
	PUSHJ P,UUOBNC
	TLNE R,(NCALL)
	PUSH P,[UUONVL]
	JSP R,UUOX4B
	PUSH P,TT		;PUSH FUNCTION
	JUMPE T,IAPPLY
	MOVEM T,UUTSV
	HRLZ R,UUTSV
	MOVE A,1(R)
	JSP T,PDLNMK
	PUSH P,A		;PUSH ARGUMENT
	AOBJN R,.-3
	MOVE T,UUTSV
	JRST IAPPLY		;APPLY FUN TO ARGS

UUOS10:	MOVEM T,UUOFN	;*** FSUBR CALLED LIKE SUBR
	JSP TT,ARGPDL
UUS10A:	AOJN T,UUOFER
	POP P,A
	MOVSI T,2000
	IORM T,40
	MOVE T,UUOFN
	JRST UUOSBR


UUL2N:	SKIPA TT,40		;*** NONATOMICFUN CALLED LIKE LSUBR
UUOS5:	HLRZ TT,(T)		;*** EXPR CALLED LIKE LSUBR
	MOVE T,UUTSV
	CAMGE T,XC-NACS
	JRST UUOS5A
	JSP R,PDLARG
	MOVNS T
	JRST UUOEX4

UUOS5A:	PUSH FXP,T		;DAMN CASE WHERE WE MUST
	PUSH FXP,V.RSET		; SLIDE STUFF UP THE PDL,
	MOVEI R,(P)		; DOING PDLNMK'S AS WE GO
	JSP T,NPUSH-3-NACS+1	;ROOM FOR ALL ACS BUT A, PLUS 3
	SKIPE (FXP)
	JSP T,NPUSH-5		;EXTRA SLOTS FOR *RSET
	MOVEI D,(P)
	MOVE F,-1(FXP)
UUOS5B:	MOVE A,(R)		;SO DO ALL THE PDLNMK'S
	JSP T,PDLNMK
	MOVEM A,(D)
	SUBI R,1
	SUBI D,1
	AOJL F,UUOS5B
	HRL TT,40		;TT HAS BEEN SAVED - HAS FN
	MOVEM TT,(D)		;SAVE FUNCTION BELOW ARGS FOR IAPPLY
	SKIPE (FXP)		;D SHOULD POINT TO WHERE ACS ARE SAVED
	SUBI D,5		;FOR *RSET, MUST SAVE THE ACS UNDER THE FRAME!
REPEAT NACS-1,	MOVEM B+.RPCNT,.RPCNT-NACS(D)	;SAVE ALL MARKED ACS BUT A
	MOVEI TT,R5M1PJ		;PROVIDE FOR RESTORING THEM
	MOVEM TT,-1(D)		;ACS WERE SAVED UNDER, NOT OVER, THE
	MOVE TT,40		; FRAME IN CASE OF AN FRETURN
	MOVE F,UUOH		;MAYBE NEED RETURN ADDRESS UNDER
	TLNE TT,1000		; THE ARGS (IF NOT, USE A CPOPJ)
	MOVEI F,CPOPJ
	MOVEM F,-NACS-1(D)
	POP FXP,F
	JUMPE F,UUOS5C		;MAYBE MORE *RSET HAIR?
	PUSH FXP,(FXP)		;DUPLICATE NUMBER OF ARGS ON FXP
	MOVEI TT,4(D)		;TT POINTS TO THE FIVE *RSET SLOTS
	MOVEM TT,-1(FXP)		;PLOP POINTER INTO PDL SLOT
	PUSHJ P,UUOFUL		;SET UP APPLYFRAME (POPS FXP)
	POP FXP,TT
	HRRZS (TT)		;FLUSH CPOPJ - IAPPLY WILL CREATE ONE
	JRST IAPPLY

UUOS5C:	POP FXP,T		;NOW FOR THE IAPPLY
	JRST IAPPLY		;UUOFUL WANTS TWO THINGS ON FXP, WILL POP ONE


ARGCHK:	CAMGE T,XC-NACS	;CHECK NUMBER OF ARGS SUPPLIED
	JRST PAERR		;R HAS ATOM PROPERTY LIST POINTER
ARGLCK:	SKIPE V.RSET
	JRST ARGCK2
ARGCK1:	POP P,TT		;FOR SPEED, DO THIS RATHER THAN
	JRST 1(TT)		;AOS (P)  POPJ P,

ARGCK2:	SKOTT R,SY		;R HAS SYMBOL OR SAR
	JRST ARGCK5		;MUST BE A SAR
ARGCK0:	HLRZ R,(R)
	HLRZ R,1(R)
	JUMPE R,ARGCK1
	LDB TT,[111100,,R]
	JUMPN TT,ARGCK3
ARGCK4:	LDB TT,[001100,,R]
	MOVNI TT,-1(TT)
	CAMN T,TT
	AOS (P)
	POPJ P,

ARGCK3:	MOVNI TT,-1(TT)
	CAMLE T,TT
	POPJ P,
	LDB TT,[001100,,R]
	CAIN TT,777		;777 IS EFFECTIVELY INFINITY
	JRST POPJ1
	MOVNI TT,-1(TT)
	CAML T,TT
	AOS (P)
	POPJ P,

ARGCK5:	LDB R,[TTSDIM,,TTSAR(R)]
	AOJA R,ARGCK4


ARGPDL:	LDB T,[270400,,40]	;ARGS => PDL  -CNT=> T
	MOVNS T
ARGP0:	HRLZ R,T
ARGP1:	JUMPE R,(TT)
	PUSH P,A(R)
	AOBJN R,.-1
	JRST (TT)

PDLARG:	CAMGE T,XC-NACS
PAERR:	LERR EMS16	;MORE THAN 5 ARGS
	JRST .+1+NACS(T)
REPEAT NACS,[CONC RSTR,\<A-1+NACS-.RPCNT>,:	POP P,A-1+NACS-.RPCNT
]
PDLA2:	JRST (R)
	MOVEI D,QSUBRCALL	;COME HERE IF SUBRCALL (Q.V.) GOT 0 ARGS
	SOJA T,WNALOSE


STRTOUT:
	SUBI T,STRT_-33		;FLAG NON-ZERO IF STRT7 CALL
	EXCH T,UUTSV
	PUSH P,UUOH		;PUSH RETURN ADDR FOR FINAL EXIT
	PUSH P,A
	PUSHJ P,SAVX5
	PUSH FXP,UUTSV
	PUSH FXP,40
	PUSH P,AR1
	PUSH P,AR2A
	LDB D,[270400,,(FXP)]	;AC=17 MEANS USE MSGFILES.
	CAIN D,17
	 JRST ERP0D
	SKIPN AR1,(D)		;NIL MEANS USE DEFAULT ^R AND ^W
	 JRST ERP0C
	CAIN AR1,QUNBOUND	;GIVEN UNBOUND VARIABLE?
	 LERR [SIXBIT \UNBOUND VARIABLE IN PRINC FROM COMPILED CODE  --GSB!\]
ERP0E:	TLO AR1,200000
ERP0F:	MOVEI A,(AR1)
	LSH A,-SEGLOG
	SKIPL ST(A)		;MAYBE SHOULD ERRR-CHECK BETTER?
	 TLO AR1,400000		;NOTE WHETHER LIST OR NOT
ERP0A:	JSP T,GTRDTB
	.5LOCKI
ERBPLOC==-1			;LOCATION OF BYTE PTR ON FXPDL
ER7PLOC==-2			;LOCATION OF STRT7-P ON FXPDL
	SKIPE ER7PLOC(FXP)		;STRT7-P?
	 JRST ERP7A
	MOVSI D,440600
	HLLM D,ERBPLOC(FXP)
ERP1:	ILDB TT,ERBPLOC(FXP)	;STRING BYTE POINTER IS STORED ON FXP
	CAIN TT,'#	;THE .5LOCKI SAVED INHIBIT ON TOP OF FXP
	 JRST ERP3
	CAIN TT,'!
	 JRST ERP6
	CAIN TT,'^
	 JRST ERP4
ERP5:	ADDI TT,40
ERP5A:	PUSHJ P,STRTYO
	JRST ERP1

ERP7A:	MOVSI D,440700
	HLLM D,ERBPLOC(FXP)
ERP7:	ILDB TT,ERBPLOC(FXP)	;STRING BYTE POINTER IS STORED ON FXP
	JUMPE TT,ERP6
	PUSHJ P,STRTYO
	JRST ERP7


ERP0D:	SKIPN AR1,VMSGFILES
	JRST ERP6A
	JRST ERP0E

ERP0C:	SKIPE AR1,TAPWRT
	HRRZ AR1,VOUTFILES
	JUMPN AR1,ERP0F
	SKIPE TTYOFF
	JRST ERP6A
	JRST ERP0A

ERP3:	ILDB TT,ERBPLOC(FXP)	;QUOTE A CHAR
	JRST ERP5

ERP4:	ILDB TT,ERBPLOC(FXP)	;CONTROLLIFY A CHAR
	ADDI TT,40
	TRC TT,100
	CAIE TT,^M
	 JRST ERP5A
	PUSHJ P,STRTYO
	MOVEI TT,^J
	JRST ERP5A

ERP6:	UNLOCKI		;DONE!
ERP6A:	POP P,AR2A
	POP P,AR1
	SUB FXP,R70+2	;FLUSH BYTE PTR AND STRT7P SWITCH
	POP P,A		;RESTORE A
	JRST RSTX5	;RESTORE NUMACS AND POPJ

ENDFUN==.-1	.SEE SSYSTEM	;NO MORE FUNCTIONS BEYOND HERE

SUBTTL	INITIAL STARTUP CODE

;;; NORMAL G STARTUP CODE.  ON FIRST RUN, THE ALLOC PHASE COMES HERE;
;;; THEREAFTER, LISPGO COMES HERE DIRECTLY.
;;; WE DO NOT HAVE THE USE OF THE PDLS UNTIL THE CALL TO ERINIX.
;;; WE DO NOT HAVE THE USE OF CONSING OF ANY SORT UNTIL THE CALL TO GCNRT.

LISP:	MOVNI TT,1		;AOBJN ON -1 LEAVES [1,,0] ON A KA10
	AOBJN TT,.+1		; BUT [0] ON A  KL OR KI
	MOVEM TT,KA10P
;CLEAR AND DISABLE INTERRUPT SYSTEM
IFN ITS,[
	PION
	.SUSET [.SPIRQC,,R70]
	.SUSET [.SIFPIR,,R70]
	.SUSET [.ROPTION,,TT]
	TLO TT,OPTINT+OPTOPC	;NEW-STYLE INTERRUPTS AND NO PC SCREWAGE
	.SUSET [.SOPTION,,TT]
	TLNN TT,OPTBRK		;IF OUR SUPERIOR CLAIMS TO HANDLE BREAKS,
	 JRST LISP17		;  AND IF IT CLAIMS TO HAVE LISP'S SYMBOL TABLE
	.BREAK 12,[..RSTP,,TT]	; VALRET A STRING TO CAUSE & TYPEOUT MODE
	SKIPGE TT		; TO BE S-EXP TYPEOUT (AND % TO BE SQUOZE)
	 .VALUE [ASCIZ /:IF N :SYMTYP P%î(..TAMP\î..TPER\1Qî..TAMP\P%î):VP /]
LISP17:
]		;END OF IFN ITS

IFN D10*<1-SAIL>,	JSP T,D10SET
20$ 	JSP R,TNXSET		    ;DECIDE WHICH OPSYS - TENEX OR TOPS20
				    ; AND FIX UP PAGE ACCESSIBILITYS
IFN USELESS*<ITS\D20>, JSP T,SHAREP ;CONSIDER SHARING PAGES WITH OTHER JOBS

	PION	;ENABLE INTERRUPTS

;RESET I/O SWITCHES
	SETZM TAPWRT		;UWRITE FLAG (^R)
	SETZM TTYOFF		;TTY OUTPUT FLAG (^W)
IFN JOBQIO,[
IT$	.DTTY			;SAY THIS JOB WANTS THE TTY, RATHER
IT$	 JFCL			; THAN LETTING AN INFERIOR HAVE IT
IT%	WARN [RETRIEVE TTY FROM INFERIOR?]
]		;END OF IFN JOBQIO

;RESET FREELISTS TO FORCE A CLEAN GARBAGE COLLECTION
REPEAT NFF,	SETZM FFS+.RPCNT	;SET FREELISTS TO NIL
IFN HNKLOG+DBFLAG+CXFLAG, MOVSI A,(SETZ)
IFN HNKLOG,[
	REPEAT HNKLOG+1,[
		SKIPN HNSGLK+.RPCNT		;HACK TO AVOID CREATING
		 MOVEM A,FFH+.RPCNT		; UNNEEDED HUNK SEGMENTS
	]		;END OF REPEAT HNKLOG+1
]	;END OF IFN HNKLOG
DB$	SKIPN DBSGLK		;DITTO FOR WEIRD NUMERIC TYPES
DB$	 MOVEM A,FFD		;THE SETZ BIT IN THE FREELIST
CX$	SKIPN CXSGLK		; POINTER MEANS IT IS OKAY TO
CX$	 MOVEM A,FFC		; HAVE NO FREE CELLS AS LONG AS
DX$	SKIPN DXSGLK		; NO ONE TRIES TO CONS ONE
DX$	 MOVEM A,FFZ
	SETZM GCTIM		;RESET GC TIME (SINCE RUNTIME PROBABLY GOT RESET?)
	SETZM ALGCF		;RESET ALLOC FLAG - OKAY TO GC NOW

	JSP T,TLVRSS		;RESET VARIOUS "TOP LEVEL VARIABLES"
	JSP A,ERINIX		;SET UP PDLS, RESTORE MUNGED DATA, ENABLE INTERRUPTS

;INITIALIZE DEFAULT DIRECTORY NAMES
 	JSP T,PPNUSNSET

;TRY TO OPEN THE TERMINAL AS AN I/O DEVICE
	PUSHJ P,OPNTTY
	 JFCL

;PERFORM INITIAL GARBAGE COLLECTION (BUT DON'T BOTHER TO COMPACT ARRAYS)
	MOVSI T,111111
	PUSHJ P,GCNRT
	PUSHJ P,UDIRSET
;INITIALIZE CURRENT UNIT
;INITIALIZE VARIOUS BIZARRE TOP-LEVEL VARIABLES
	MOVEI T,INR70
	MOVEM T,VTTSR
	MOVEI A,Q.		;INITIAL VALUE OF * IS *
	MOVEM A,V.
	MOVE A,VERRLIST		;SET UP FOR EVAL'ING ERRLIST
	MOVEM A,VIQUOTIENT
	SKIPGE AFILRD
	 JRST LSPRET
LIHAC:	SETOM AFILRD		;HAIRY HAC TO READ, THE FIRST TIME
	MOVEI A,TRUTH		; AROUND, FROM THE .LISP. (INIT) FILE
	MOVEM A,TAPRED		;(SETQ ^Q T)
	JRST HACENT

IFN ITS,[

LISP43:	SETZ
	SIXBIT \SSTATU\
REPEAT 5, 2000,,TT		;IGNORE USELESS GARBAGE
	402000,,TT		;MACHINE NAME

]		;END OF IFN ITS

10$ WAKTTY: JRST (T)



SUBTTL PPNUSNSET UDIRSET TNXSET D10SET 


PPNUSNSET: 
IFN D10,[
SA%	GETPPN TT,		;FOR TOPS10/CMU, USE GETPPN
SA%	 JFCL			; (GETS PPN OF CURRENT JOB)
SA$	SETZ TT,		;FOR SAIL, WE PREFER DSKPPN
SA$	DSKPPN TT,		; (AS SET BY THE ALIAS COMMAND)
	MOVEM TT,USN
	MOVEM TT,TTYIF2+F.PPN
	MOVEM TT,TTYOF2+F.PPN
]		;END OF IFN D10
IFN ITS,[
	MOVE TT,IUSN
	MOVEM TT,TTYIF2+F.SNM
	MOVEM TT,TTYOF2+F.SNM
]		;END OF IFN ITS
	JRST (T)


;INITIALIZE THE NAME OF THE MACHINE IN THE FEATURES LIST
;INITIALIZE (STATUS UDIR)

UDIRSET:
	MOVE TT,BPSH		;IF BPEND SOMEHOW
	CAMGE TT,@VBPEND	; IS LARGER THAN BPSH,
	 PUSHJ P,BPNDST		; SET IT EQUAL TO BPSH
IFN D10,[
	PUSHJ P,SIXJBN		;INITIALIZE TEMP FILE NAME D10NAM
IFE SAIL,[
	MOVEI A,QTOPS10
	SKIPE CMUP
	 MOVEI A,QCMU
]	;END OF IFE SAIL
]	;END OF IFN D10
IFN ITS,[
	.CALL LISP43		;GETS NAME OF ITS (AI, MC, ML, MD, MX, ES) IN TT
	 .VALUE
	SETZ A,			;CONVERT TO ATOMIC SYMBOL
	HLRZS TT
    IRP X,,[AI,ML,MC,MD,MX,DB]
	CAIN TT,(SIXBIT \X\)
	 MOVEI A,Q!X
    TERMIN 
	SKIPN A
	 .VALUE
]		;END OF IFN ITS
SA% 20%	HRLM A,SITEFT		;SET UP (STATUS FEATURES) FOR SITE NAME

IFN D10,[
IFE SAIL,[
	CAIN A,QCMU
	 JRST .+3
	  HRRZ A,SITEFT		;Can't figure out a specific site name, so just
	  HRRM A,OPSYFT 	; splice it out, and let the generic name do.
	MOVNI T,1		;FOR NON-SAIL, TRY TO GET
	SETZB TT,D		; DEFAULT SNAME BY USING PATH.
	MOVEI R,0
	MOVE F,[4,,T]
	PATH. F,
]		;END OF IFE SAIL
	 MOVE D,USN		;ON FAILURE, JUST USE USN
	MOVE TT,D		;PPNATM EXPECTS PPN TO BE IN AC TT
	PUSHJ P,PPNATM
]		;END OF IFN D10
IFN ITS,[
	MOVEI A,0
;;; Following will be done by (STATUS UDIR)
;;;	MOVE TT,IUSN		;TAKE INITIAL SNAME
;;;	PUSHJ P,SIXATM		;CONVERT TO ATOMIC SYMBOL
]		;END OF IFN ITS
IFN ITS\D10,[
	MOVEM A,SUDIR
	POPJ P,
]	;END OF IFN ITS\D10

IFN D20,[
	SKIPE TENEXP
	 SKIPA 3,[440700,,[ASCIZ \DSK:<MACLISP>SITE.TXT\]]
	HRROI 3,[ASCIZ \PS:<MACLISP>SITE.TXT\]
	HRROI 1,[ASCIZ \LISP:\]
	STDEV			;IS THERE A LISP: DEVICE?
	 SKIPA 2,3
	HRROI 2,[ASCIZ \LISP:SITE.TXT\]
UDRS5:	HRLZI 1,(GJ%SHT+GJ%OLD)
	GTJFN	
	 JRST UDRS2A
	MOVE 3,1
	MOVE 2,[<07_36>+OF%RD]		;ASCII BYTES
	OPENF
	 JRST UDRS1A			;WILL HAVE SOMETHING IN 2
	MOVNI T,<LPNBUF-1>*BYTSWD
	MOVE TT,PNBP
UDRS4:	BIN
	JUMPE 2,UDRS1			;HAS 0 IN 2 WHEN JUMPING
	IDPB 2,TT
	AOJL T,UDRS4
	HALTF
UDRS1:	MOVE 1,3
	CLOSF
	 JFCL
	JRST UDRS1B
UDRS1A:	MOVE 1,3
	RLJFN
	 JFCL
UDRS1B:	MOVNI T,BYTSWD
	IDPB 2,TT		;PADD OUT WITH 0'S
	AOJL T,.-1	
	PUSHJ P,PNBFAT
	HRLM A,SITEFT
UDRS2:	SETZB 1,2
	SETZ 3,
	MOVEI A,QLISP
	MOVEI B,QPPN
	PUSHJ P,REMPROP
	HRROI 1,[ASCIZ /LISP:/]
	SKIPN TENEXP
	 STDEV			;IS THERE A LISP: DEVICE?
	  JRST UDIRSX
	MOVEI 1,.LNSJB		;IF SO, GET THE LOGICAL TRANSLATION
	HRROI 2,[ASCIZ /LISP/]
	MOVE 3,PNBP
	LNMST
	 JRST .+2
	JRST UDIRS6
	MOVEI 1,.LNSSY
	HRROI 2,[ASCIZ /LISP/]
	MOVE 3,PNBP
	LNMST
	 JRST UDIRSX
UDIRS6:	MOVE D,PNBP
	MOVE F,[440700,,T]
	SETZ T,
	MOVNI R,5			;PICK UP ASCII FOR REAL DEVICE IN T
UDIRS7:	ILDB TT,D
	JUMPE TT,UDIRSX
	CAIN TT,":
	 JRST UDIRS8
	IDPB TT,F
	AOJL R,UDIRS7
	JRST UDIRSX
UDIRS8:	ILDB TT,D
	CAIE TT,"<
	 JRST UDIRSX
	MOVE R,PNBP		;SHUFFLE DOWN THE "<MACLISP>" PART
UDRS8A:	ILDB TT,D
	JUMPE TT,UDIRSX
	CAIN TT,">
	 JRST .+3
	  IDPB TT,R
	  JRST UDRS8A
	PUSH FXP,T
	MOVNI T,5
	SETZ TT,
	IDPB TT,R		;FILL OUT WITH  A WORD OF NULLS
	AOJLE T,.-1
	PUSHJ P,PNBFAT
	PUSHJ P,NCONS
	PUSH P,A
	POP FXP,PNBUF
	SETZM PNBUF+1
	PUSHJ P,PNBFAT
	POP P,B
	PUSHJ P,CONS
	SKIPA B,A
UDIRSX:	MOVEI B,Q%ALD		;HAS (PS MACLISP) in it, for default case
	SKIPE TENEXP		;OR (DSK MACLISP) for tenex systems
	 MOVEI B,Q%XALD
	MOVEI A,QLISP
	MOVEI C,QPPN
	JRST PUTPROP

UDRS2A:	HRRZ A,SITEFT		;Since we can't figure out a specific site
	HRRM A,OPSYFT 		; name, just splice it out, and let the generic
	JRST UDRS2		; name from OPSYSTEM-TYPE do.

]	;END OF IFN D20


IFN D20,[
;;;CALLED WITH JSP D, TO SET UP TENEXP.  RETURNS WITH FLAG IN A AS WELL
;;; Must save R -- see JCLSET 
TNXP:	MOVE A,[112,,11]		;MUST BE CALLED WHEN INTERRUPTS ARE OFF
	GETTAB A,
 	 JRST TNXST9			;LOSE IF WE CANT DECIDE!
	LDB A,[141400,,A]		;3 FOR TENEX, 4 FOR TOPS-10
	SUBI A,2
	CAIE A,1
	 MOVEI A,NIL
	MOVEM A,TENEXP
	JRST (D)
	
TNXSET:	JSP D,TNXP			;SETUP TENEXP FLAG, RETURN IN A
	MOVEI D,1			;REMODEL CCOC2 BITS FOR ^_
	MOVEI B,QTOPS20
	JUMPE A,.+3
	 MOVEI D,3
	 MOVEI B,QTENEX
	DPB D,[100200,,CCOCW2]
	MOVE D,CCOCW2
	MOVEM D,TTYIF2+TI.ST2
	HRLM B,OPSYFT
	HRLM B,SITEFT			;UDIRSET SHOULD MODIFY THIS
;	MOVEI TT,1_17.-SEGSIZE+1
	MOVEI TT,1_18.-SEGSIZE		;Do ALL pages! -- Gumby
	SETZM LDXLPC		;Then we better force a new uuolink pure
				;page.  -Alan
	SETZM TTYIF2+TI.ST5
	SETZM VTS20P
	JUMPN A,TNXST3 			;A STILL HAS TENEXP
	MOVEI 1,.PRIIN
	RTCHR
	 ERJMP TNXST3
	SETOM VTS20P			;GET TERMINAL-CAPABILITIES-WORD
	MOVEM 2,TTYIF2+TI.ST5		;IF ON A TWENEX
TNXST3:	MOVEI D,(TT)
	LSH D,-SEGLOG			;GET SEGMENT NUMBER
	HLL D,ST(D)
	TLNE D,ST.$NX
	 JRST TNXST1
	MOVSI A,.FHSLF
	HRRI A,(D)			;GET PAGE NUMBER
	JSP T,IPURE$			;MAKE SURE PAGE EXISTS
	AND B,[PA%RD+PA%WR+PA%EX+PA%CPY]
	TLO B,(PA%RD)			;LET IT BE READABLE
	TLNE D,ST.LS+ST.FX+ST.FL+ST.BGN
	 TLZA B,(PA%EX)			;DONT EXECUTE FROM DATA AREAS
	  TLO B,(PA%EX)
	TLNE D,ST.PUR
	 JRST TNXST2
	TLNE B,(PA%CPY)			;WHY WOULD BOTH PA%CPY AND PA%WR
	 TLZA B,(PA%WR)			; BOTH BE ON???
	  TLNN B,(PA%WR)		;IF ALREADY WRITEABLE, DONT MAKE
	   TLO B,(PA%CPY)		; COPYABLE
	JRST TNXST4
TNXST2:	TLZ B,(PA%CPY+PA%WR)		;NOT WRITEABLE, IF A "PURE" PAGE
	SKIPN PSYSP			; PSYSP is override
	 TLO B,(PA%CPY)
TNXST4:	SPACS
TNXST1:	SUBI TT,SEGSIZE
	JUMPG TT,TNXST3
	JRST (R)
]	;END OF IFN D20

IFN D10*<1-SAIL>,[
D10SET:

;	MOVE TT,[%CCTYP]	;KA 10 VS KL/KI 10 ?
;	GETTAB TT,
;	 JRST .+4		;DO RUNTIME TEST IF ENTRY NOT THERE
;	  CAIE TT,.CCKAX
;	   MOVEI TT,0
;	  JRST .+3
;	   MOVNI TT,1		;AOBJN ON -1 LEAVES [1,,0] ON A KA10
;	   AOBJN TT,.+1		; BUT [0] ON A  KL OR KI
;	MOVEM TT,KA10P

	SETZM MONL6P
	SETZM CMUP
	MOVEI A,QTOPS10
	HRLM A,OPSYFT
;MAYBE SOMEDAY WE COULD FIGURE OUT THE ARPA HOST NAME HERE???
	HRLM A,SITEFT
	MOVE A,[%CNMNT]		;GET MONITOR TYPE WORD
	GETTAB A,
	 MOVEI A,010000		;ASSUME TOPS-10 IF GETTAB ENTRY NOT THERE
	LDB A,[.BP CN%MNT,A]	;1 = TOPS-10, 2 = ITS, 3 = TENEX, 6 = TOPS-20
	SOJE A,.+3		;REAL TOPS-10 SYSTEM, RATHER THAN SIMULATOR?
	 SETZB A,SGANAM		; ON VARIOUS SIMULATIONS, DONT KILL HISEG
	 JRST (T)
	MOVE A,[%CNVER]
	GETTAB A,		;GET MONITOR LEVEL NUMBER
	 MOVSI A,5		
	LDB A,[140600,,A]
	CAIN A,6
	 SETOM MONL6P
	MOVE A,[%CNFG0]
	GETTAB A,
	 MOVE A,[ASCIZ \CMUCS\]
	CAME A,[ASCIZ \CMUCS\]
	 JRST (T)
	SETOM CMUP
	MOVEI A,QCMU
	HRLM A,OPSYFT
;MAYBE SOMEDAY WE COULD FIGURE OUT THE ARPA HOST NAME HERE???
	HRLM A,SITEFT
	JRST (T)
]	;END OF D10*<1-SAIL>


SUBTTL	JCL INITIALIZATION ROUTINE

;;CALLED WITH RETURN ADDR IN ACC F
;; JCLSET imagines that the job was started with some commmand line, and
;;    tries to strip off the subsystem name from the TOPS-20 version
;; SJCLSET gets the entire RSCAN line

JCLSET:
IFN D20,[
	TDZA R,R
SJCLSET: MOVEI R,1
]	;END OF IFN D20,
	SETZM SJCLBUF		;FIRST WORD OF BUFFER IS COUNT
	MOVE 1,[SJCLBUF,,SJCLBUF+1]
	BLT 1,SJCLBUF+LSJCLBUF-1
IFN D10,[
	MOVE R,[440700,,SJCLBUF+1]
SA%	RESCAN
SA$	RESCAN A
SA%	 CAIA
SA$	 SKIPN A
	  JRST JCST3
JCST4:	INCHRS B
	 JRST JCST3
	CAIE B,^M		;IF <CR> OR <ALT> OCCURS ON COMMAND 
SA%	 CAIN B,33
SA$	 CAIN B,175
	  JRST JCST3		;BEFORE A ";", THEN NO JCL
	CAIE B,";
	 CAIN B,"(
	  CAIA
	   JRST JCST4		;LOOP UNTIL WE FIND A ; OR (
	MOVNI D,BYTSWD*LSJCLBUF
JCST2:	INCHRS A
	 JRST JCST1
	CAIN B,"(		;IF JCL STARTED WITH A (,
	 CAIE A,")		; ONLY UP TO THE ) IS JCL,
	  CAIA			; BUT WE MUST GOBBLE THE WHOLE LINE
	   SETO B,
	JUMPL B,JCST5
	AOSG D
	 IDPB A,R
JCST5:	CAIN A,^M		;<CR> OR <ALT> TERMINATES
	 JRST JCST1		;THE COMMAND LINE
SA%	CAIE A,33
SA$	CAIE A,175
	 JRST JCST2
JCST1:	SKIPLE D
	 TDZA D,D		;TOO MUCH JCL => NONE AT ALL
	  ADDI D,BYTSWD*LSJCLBUF
JCST3:	INCHRS A		;MAKE SURE NO SUPERFLUOUS CHAR 
	 JFCL
	MOVEM D,SJCLBUF
	SETZ A,
	IDPB A,R	;INSURE AT LEAST ONE NULL BYTE FOLLOWING THE LINE
	JRST (F)
]		;END OF IFN D10
IFN D20,[
	JSP D,TNXP
	MOVEI 1,.RSINI		;ACTIVATE THE COMMAND LINE AS INPUT
	SKIPN TENEXP
	 RSCAN
	  JRST (F)
	MOVEI 1,.RSCNT		;ANYTHING THERE?
	RSCAN
	 JRST (F)
	JUMPE 1,(F)
	MOVEM 1,5		;# OF CHARS KEPT IN AC 5
	MOVEM 1,4
	JUMPN R,[ MOVE 3,[440700,,SJCLBUF+1]
		  JRST JCL1C ]
	MOVEI 3,NIL 		; IF NON-(), SAYS ALREADY PASSED ONE "WORD" 
	MOVE T,[440700,,PNBUF]
JCL1A:	SOSGE 5
	 JRST (F)
	PBIN
	JUMPE 1,(F)
	CAIN 1,^M		;LOOK FOR SPACE OR CR TERMINATING SUBSYSTEM 
	 JRST (F)		; NAME. 
	CAIN 1,"  		; LOOP, TO FLUSH THIS WORD
	 JRST [ JUMPN 3,JCL1B
		MOVEI 3,TRUTH
		SUB 4,5
		CAIE 4,4		;LOOK FOR "RUN ", AND IF FOUND
		 JRST JCL1B		; THEN FLUSH IT AND TAKE ONE
		IDPB 1,T		; MORE WORD, WHICH SHOULD BE
		IDPB 1,T		; THE SUBSYSTEM NAME.
		MOVE T,[ASCII \RUN  \]
		CAMN T,PNBUF
		 JRST JCL1A
		JRST JCL1B ]
	CAIN 1,";
	 JRST JCL1B
	IDPB 1,T
	JRST JCL1A
JCL1B:	SETZM SJCLBUF
	MOVEI 1,"  
	MOVE 3,[440700,,SJCLBUF+1] ;AH!  PUT IN AN INITIAL SPACE
	IDPB 1,3
	AOS SJCLBUF
JCL1C:	SOSGE 5
	 JRST (F)		;LOOP, UNTIL RUN OUT OF RSCAN CHARS
	PBIN			;MOVE RSCAN BUFFER TO OUR ADDRESS SPACE
	CAIL 1," 		; CHECK FOR #\SPACE
	 JRST [	CAIN 1,";
		 JRST JCL1B
		IDPB 1,3
		AOS SJCLBUF
		JRST JCL1C ]
	MOVEI 2,0
	CAIE 1,^V	;CONVERT CONTROL-CHARS, EXCEPT ^V, TAB, CR, AND LF
	 CAIN 1,^I	; TO NULLS
	  MOVE 2,1
	CAIE 1,^M
	 CAIN 1,^J
	  MOVE 2,1
	IDPB 2,3
	JUMPE 1,(F)	;TERMINATE ON A TRUE NULL BYTE
	AOS SJCLBUF
	JRST JCL1C

]	;END OF IFN D20


SUBTTL	INTERNAL PCLSR'ING ROUTINES

SFXTBL:		;TABLE OF LOCATIONS FOR SFX HACK
	MACROLOOP NSFC,ZZM,*

SFXTBI:		;TABLE OF INSTRUCTIONS NORMALLY IN THOSE LOCATIONS
	MACROLOOP NSFC,ZZN,*

PROTB:		;TABLE OF INTERRUPT PROTECTION INTERVALS
	MACROLOOP NPRO,PRO,*


;;; TABLE MUST BE AN EXACT POWER OF TWO IN LENGTH SO WE CAN
;;; USE SUPER-WINNING BINARY SEARCH METHOD.
HAOLNG LOG2NPRO,<.-PROTB-1>

REPEAT <1_LOG2NPRO>-NPRO,[ INTOK,,777777
]		;END OF REPEAT <1_LOG2NPRO>-NPRO

;;; IT IS OBVIOUSLY USELESS TO USE PROTECT MACROS BEYOND THIS POINT.
;;; EXPUNGING NPRO WILL CAUSE AN ERROR IF THE PROTECT MACROS ARE USED
EXPUNGE NPRO


;;;	PUSHJ FXP,$IWAIT
;;; CALLED FROM WITHIN A NORMAL INTERRUPT HANDLER TO DECIDE
;;; WHETHER IT IS SAFE TO ISSUE A USER INTERRUPT.
;;; ON FAILURE, STACKS UP THE INTERRUPT AND SKIPS.
;;; AS FOR UINT0, D CONTAINS THE INTERRUPT DESCRIPTOR WORD.
;;; INTERRUPTS MUST BE DEFERRED; PDL OVERFLOW MUST BE
;;; ENABLED.  THE CONTENTS OF INTPDL POINTS TO THE INTPDL ENTRY
;;; FOR THE CURRENT INTERRUPT, WHICH CONTAINS THE SAVED
;;; CONTENTS OF D AND R.  FXP MUST BE IN A USABLE STATE.


$IWAIT:	HLRZ R,NOQUIT		;IF IN GC, WE ARE IN A BAD STATE
	JUMPN R,IWSTAK		; AND SO MUST STACK THE INTERRUPT
	HRRZ R,INTPDL
	CAIE R,INTPDL+LIPSAV	;FOR NESTED PI LEVEL (E.G. PDL OVERFLOW),
	 JRST IWSTAK		.SEE INTXIT	; ALSO STACK THE INTERRUPT
	MOVEI R,(SP)		;IF THE SPECPDL IS IN SOME
	MOVE F,(SP)		; KIND OF STRANGE STATE (E.G.
	CAME R,ZSC2		; INTERRUPTED OUT OF SPECBIND)
	 CAMN F,SPSV		; THEN MUST DO THE INTSFX HACK
	  JRST IWLOOK
INTSFX:	MOVE F,[PUSHJ FXP,SPWIN]
	MOVSI R,-NSFC		.SEE SFX
	MOVEM F,@SFXTBL(R)	;CLOBBER LOCATIONS MARKED BY SFX SO
	AOBJN R,.-1		; SFXPRO'ED ROUTINE WILL RETURN TO SPWIN
	HRRZ F,INTPDL		;RESTORE AC'S, AND SAVE
	EXCH D,IPSD(F)		; INTERRUPT DESCRIPTOR
	MOVE R,IPSR(F)
	PUSH FXP,IPSPC(F)	;GET PC AND FLAGS
	MOVEI F,IPSF(F)
	PUSH FXP,F
	MOVE F,(F)
	JRST 2,@-1(FXP)		;CONTINUE WHATEVER WE WERE DOING

;;; RETURN FROM SFX HACK.  ROUTINE HAS DONE  PUSHJ FXP,SPWIN.

SPWIN:	MOVEM F,@-1(FXP)	;PRESERVE F
	HRRZ F,INTPDL
	POP FXP,IPSPC(F)	;PUT PC BACK INTO INTPDL FRAME,
	SOS IPSPC(F)		; BACKED UP TO THE CLOBBERED INSTRUCTION
	SUB FXP,R70+2
	MOVEM R,IPSR(F)		;SAVE ACS D AND R
	EXCH D,IPSD(F)
	MOVSI R,-NSFC
SPWIN1:	MOVE F,SFXTBI(R)	;RESTORE THE LOCATIONS THAT WE
	MOVEM F,@SFXTBL(R)	; CLOBBERED WITH  PUSHJ FXP,SPWIN
	AOBJN R,SPWIN1
	JRST IWWIN		;WE HAVE WON


IWLOOK:	HRRZ F,INTPDL		;FAST BINARY SEARCH OF PROTECT
	HRRZ R,IPSPC(F)		; TABLE ON PC INTERRUPTED FROM
	PUSH FXP,D
	MOVEI D,0
REPEAT LOG2NPRO,[
	MOVE F,PROTB+<1_<LOG2NPRO-.RPCNT-1>>(D)
	CAIL R,(F)
	 ADDI D,1_<LOG2NPRO-.RPCNT-1>
]		;END OF REPEAT LOG2NPRO
	MOVS R,PROTB(D)
	POP FXP,D
	HRRZ F,INTPDL		;A USEFUL VALUE FOR F
	JRST (R)		;GO TO PLACE WHICH HANDLES THIS INTERVAL

;;; COME HERE TO MOVE THE PC FORWARD OUT OF A PROTECTED INTERVAL
;;; BY EXECUTING INTERVENING INSTRUCTIONS.  THE ACS ARE CORRECTLY
;;; AVAILABLE DURING THIS EXECUTION, EXCEPT FXP.  THE PC FLAGS ARE
;;; NOT PRESERVED.  THUS, CODE IN SUCH A PROTECTED INTERVAL SHOULD
;;; NOT USE FXP OR THE PC FLAGS.  NO JUMP INSTRUCTIONS MAY BE USED;
;;; HOWEVER, SKIPS ARE HANDLED CORRECTLY.
.SEE XCTPRO

INTXCT:	PUSH FXP,IPSPC(F)
	EXCH D,IPSD(F)		;RESTORE ACS D, R, AND F
	MOVE R,IPSR(F)		;FLAGS ARE *NOT* RESTORED
	MOVEI F,IPSF(F)		;ALSO, FXP IS OUT OF WHACK (BEWARE!)
	PUSH FXP,F
	MOVE F,(F)
	XCT @-1(FXP)		;EXECUTE AN INSTRUCTION
	 CAIA
	  AOS -1(FXP)		;HANDLE SKIPS CORRECTLY
	AOS -1(FXP)
	MOVEM F,@(FXP)
	SUB FXP,R70+1
	HRRZ F,INTPDL
	MOVEM R,IPSR(F)
	EXCH D,IPSD(F)
	POP FXP,IPSPC(F)
	JRST IWLOOK		;MAY NEED TO XCT SOME MORE


INTSYP:	SOS NPFFY2		.SEE SYCONS
INTSYQ:	SOS NPFFY2
INTSYX:	MOVEI R,PSYCONS
	JRST INTBK1

INTROT:	HLRZ R,R		;PROTECT CODE OF THE FORM
	SUBI R,1		;	ROT A,-SEGLOG
	ROT A,SEGLOG		;	   ... MUNCH ...
	JRST INTBK1		;	ROT A,SEGLOG

INTPPC:	HLRZ R,R		;PROTECT PURE CONSER
	SUBI R,1		;BACK UP TO THE AOSL OR WHATEVER
	HRRM R,IPSPC(F)
	SOS @(R)		;RESTORE THE COUNTER
	JRST INTOK

INTC2X:	HLRM B,A		;MUST PROTECT LEFT HALF OF B FOR CONS
	MOVEI R,CONS1		;HAIRY KIND OF BACKUP FOR CONS
	JRST INTBK1

INTC2Y:	HLRM B,A		;MUST PROTECT LEFT HALF OF B FOR CONS
	MOVEI R,%CONS1		;HAIRY KIND OF BACKUP FOR CONS
	JRST INTBK1

INTACT:	HRRZ R,UUTSV		.SEE UUOACL
	JRST IWLOOK

INTTYX:	HLRZ R,R		;ARRANGE TO GO TO INTTYR, WHICH WILL
	PUSH P,R		; GET THE TTSAR BACK INTO T, THEN POPJ
	MOVEI R,INTTYR		.SEE TYOXCT TYIXCT TYICAL
	HRRZS INHIBIT		.SEE .5LKTOPOPJ
	JRST INTBK1

INTACX:	MOVSS A		.SEE ACONS	;(RESTORES A FOR BACKUP)
	MOVEI R,ACONS		;MAKE THIS THE NEW PC
	JRST INTBK1
20$ INTSLP:			;FOR INTERRUPT FROM D20 SLEEP, MUST FLUSH "A"
INTZAX:	SETZ A,			;CONSERS WHICH DON'T PROTECT THEIR FREELIST!
INTBAK:	 HLRZ R,R		;BACK UP PC TO BEGINNING
INTBK1:	HRRM R,IPSPC(F)		; OF INTERVAL
INTOK:	TLZ R,-1
HS$ 10$	CAIL R,HSGORG		;NO ARRAYS IN HIGH SEGMENT!
HS$ 10$	 JRST IWWIN
	CAML R,@VBPEND
	 JRST INTSFX
IWWIN:	HRRZ F,INTPDL		;WE HAVE WON!
	POPJ FXP,

;;; NEED WE PIOF AROUND THIS  JSR UISTAK  ??  E.G. WHAT ABOUT MEMERR?

IWSTAK:	JSR UISTAK		;WE ARE IN A BAD STATE --
	AOS (FXP)		; STACK UP THE INTERRUPT
	JRST IWWIN


	PGTOP INT,[INTERRUPT AND UUO HANDLERS]


SUBTTL	PATCH AREA, STRUCT INSERT, BIT TABLES, AND SPACE CALCULATIONS


PATCH:  PAT:  XPATCH:	
	BLOCK PTCSIZ

PAGEUP
	EPATCH==.-1
INFORM [LENGTH OF PATCH AREA = ]\EPATCH-PATCH

PG%	BSYSSG==HILOC-STDHI	;CROCK - BEWARE RELOCATION!
SPCTOP SYS,,[SYSTEM]
PG%	EXPUNGE BSYSSG
NPURPG==<.-BPURPG>/PAGSIZ

10$	$LOSEG

INUM==.


$INSRT STRUCT		;INITIAL LIST STRUCTURE

;;; 10$	NOW IN ** LOW SEGMENT **



NBITB==NIFSSG+NIFXSG+NIFLSG+NBNSG
    ZZ==<<NBITB+1>*BTBSIZ+SEGSIZ-1>/SEGSIZ
IFN ZZ-BTSGGS,[
    WARN [NEEDED NUMBER OF INITIAL BIT TABLE SEGMENTS (]\ZZ,[) DOESN'T 
	MATCH GUESS. (BTSGGS=]\BTSGGS,[)
]
]		;END OF IFN ZZ-BTSGGS

.ALSO .ERR

IFN LOBITSG,	BFBTBS=BTBLKS+NBITB*BTBSIZ
.ELSE,[						;;; NOTE WELL! FIRST FS SEGMENT GETS FIRST 
						;;; BIT BLOCK! (SEE NUNMRK, GCP6)
		SPCBOT BIT
		BTBLKS:	-1			;THIS WILL BE RESET BY GCINBT
			BLOCK NBITB*BTBSIZ-1
		BFBTBS:				;BEGINNING OF FREE BIT BLOCKS
		PAGEUP
		SPCTOP BIT,ST,[BIT BLOCK]
]	;END OF .ELSE


NBPSSG==1*SGS%PG	;INIT WILL MUNG ST AND PURTBL ANYWAY TO PRESERVE ALLOC
NFXPSG==1*SGS%PG	;PDL AREAS FOR INIT AND ALLOC
NFLPSG==1*SGS%PG
NPSG==1*SGS%PG
NSPSG==1*SGS%PG		;ALLOC ALTERS ALL PDL PARAMETERS!!!

IFN PAGING,[
NXFXPSG==1*SGS%PG
NXFLPSG==1*SGS%PG
NXPSG==2*SGS%PG
NXSPSG==2*SGS%PG

IFE SFA,[
IFN ML,	NSCRSG==2*SGS%PG
.ELSE	NSCRSG==3*SGS%PG	;ALLOW FOR PDP6 PAGE (P6)
]		;END IFE SFA
IFN SFA,[
IFN ML,	NSCRSG==1*SGS%PG
.ELSE	NSCRSG==2*SGS%PG	;ALLOW FOR PDP6 PAGE (P6)
]		;END IFN SFA

;;; NUMBER OF NON-EXISTENT MEMORY SEGMENTS
;;; (TAKE ALL OF CORE AND SUBTRACT OUT EVERYTHING USEFUL!!!)
NNXMSG==NSEGS
IRP SPC,,[ZER,ST,SYS,SAR,VC,XVC,IS2,SYM,XXA,XXZ,SY2,PFX,PFS,PFL,XXP
IFS,IFX,IFL,BN,XXB,BIT,BPS,FXP,XFXP,FLP,XFLP,P,XP,SP,XSP,SCR]
NNXMSG==NNXMSG-N!SPC!SG
TERMIN

;;; DETERMINE ORIGINS FOR ALL SPACES ABOVE THIS POINT
ZZX==.
IRP SPC,,[BPS,NXM,FXP,XFXP,FLP,XFLP,P,XP,SP,XSP,SCR]
B!SPC!SG==ZZX
ZZX==ZZX+N!SPC!SG*SEGSIZ
TERMIN

SPDLORG==MEMORY-<NSCRSG+NSPSG+NXSPSG>*SEGSIZ
PDLORG==SPDLORG-<NPSG+NXPSG>*SEGSIZ
FLPORG==PDLORG-<NFLPSG+NXFLPSG>*SEGSIZ
FXPORG==FLPORG-<NFXPSG+NXFXPSG>*SEGSIZ

]		;END OF IFN PAGING

IFE PAGING,[
ZZX==.
IRP SPC,,[FXP,FLP,P,SP,BPS]
B!SPC!SG==ZZX
ZZX==ZZX+N!SPC!SG*SEGSIZ
TERMIN

SPDLORG==BSPSG
PDLORG==BPSG
FLPORG==BFLPSG
FXPORG==BFXPSG

]		;END OF IFE PAGING

SUBTTL	APOCALYPSE (END OF THE WORLD)


;FOR REL ASSEMBLIES, INIT AND ALLOC CODE OVERLAP INITIAL BPS

10$	LOC BBPSSG

$INSRT ALLOC		;INITIALIZATION AND ALLOCATION ROUTINES

PRINTX \
\		;JUST TO MAKE LSPTTY LOOK NICER

EXPUNGE ZZ ZY ZX ZZX ZZY ZZZ ZZW

HS$ 10$  IF2, BSYSSG==HSGORG	;ANTI-RELOCATION CROCK

IF2,	MACROLOOP NBITMACS,BTMC,*	;FOR BIT TYPEOUT MODE


ENDLISP::		;END OF LISP, BY GEORGE!

VARIABLES		;NO ONE SHOULD USE VARIABLES!

IFN .-ENDLISP, WARN [OKAY, WHO'S THE WISE GUY USING VARIABLES?]

IFN D10,[
	$HISEG
ENDHI::				;END OF HIGH SEGMENT
]		;END OF IFN D10

IF2, ERRCNT==:.ERRCNT		;NUMBER OF ASSEMBLY ERRORS

END INITIALIZE
