diff --git a/Makefile b/Makefile
index 1b2712a8..cc4cb2a6 100644
--- a/Makefile
+++ b/Makefile
@@ -1,6 +1,6 @@
EMULATOR ?= simh
-SRC = system syseng sysen1 sysen2 sysnet kshack dragon channa midas _teco_ emacs rms klh syshst sra mrc ksc cstacy gren bawden emacs1 _mail_
+SRC = system syseng sysen1 sysen2 sysnet kshack dragon channa midas _teco_ emacs rms klh syshst sra mrc ksc cstacy gren bawden emacs1 _mail_ l lisp liblsp
DOC = info _info_ sysdoc kshack _teco_ emacs emacs1
MINSYS = _ sys sys2 sys3 device emacs _teco_ sysbin inquir
diff --git a/README.md b/README.md
index 50cca566..a422f09d 100644
--- a/README.md
+++ b/README.md
@@ -99,6 +99,7 @@ from scratch.
- RMAIL, Mail reading client
- DQ Device, for doing hostname resolutions. Used by COMSAT.
- DSKUSE, disk usage information.
+ - LISP, lisp interpreter and runtime library (autoloads only)
6. A brand new host table is built from the host table source and
installed into SYSBIN; HOSTS3 > using H3MAKE.
diff --git a/build/build.tcl b/build/build.tcl
index a52a4802..6bbd86d5 100644
--- a/build/build.tcl
+++ b/build/build.tcl
@@ -479,6 +479,27 @@ respond "*" ":link sys;ts m,sys;ts mail\r"
respond "*" ":link sys2;ts featur,sys;ts qmail\r"
respond "*" ":link .info.;mail info,.info.;qmail info\r"
+# lisp
+respond "*" ":link l;fasdfs 1,lisp;.fasl defs\r"
+respond "*" ":link l;grind fasl,lisp;gfile fasl\r"
+respond "*" ":link l;grinde fasl,lisp;gfn fasl\r"
+respond "*" ":link l;loop fasl,liblsp;loop fasl\r"
+
+respond "*" ":midas .temp.;_l;*lisp\r"
+respond "end input with ^C" "\003"
+expect ":KILL"
+respond "*" ":job lisp\r"
+respond "*" ":load .temp.;*lisp bin\r"
+respond "*" "\033g"
+respond "*" "purify\033g"
+respond "*" ":pdump sys;purqio >\r"
+
+respond "*" ":link sys;ts lisp,sys:purqio >\r"
+respond "*" ":link sys;ts q,sys;purqio >\r"
+respond "*" ":link sys;atsign lisp,sys;purqio >\r"
+
+# ndskdmp tape
+
respond "*" ":link kshack;good ram,.;ram ram\r"
respond "*" ":link kshack;ddt bin,.;@ ddt\r"
respond "*" $emulator_escape
@@ -490,6 +511,8 @@ respond "Include DDT?" "y"
respond "Input file" ".;dskdmp bin\r"
expect ":KILL"
+# make nnsalv.tape
+
respond "*" $emulator_escape
create_tape "out/nnsalv.tape"
type ":kshack;mtboot\r"
@@ -499,6 +522,8 @@ respond "Include DDT?" "y"
respond "Input file" ".;nsalv bin\r"
expect ":KILL"
+# make output.tape
+
respond "*" $emulator_escape
create_tape "out/output.tape"
type ":dump\r"
diff --git a/src/l/*lisp.154 b/src/l/*lisp.154
new file mode 100644
index 00000000..39643eac
--- /dev/null
+++ b/src/l/*lisp.154
@@ -0,0 +1,16176 @@
+;;; -*-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->, OSD10P==1
+IFE <.OSMIDAS->, OSD10P==1
+IFE <.OSMIDAS->, 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-, 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-, 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-,[
+DEFINE $INSRT $%$%$%
+ .INSRT $%$%$% >
+ PRINTX \ ==> INSERTED: \
+ .TYO6 .IFNM1
+ PRINTX \ \
+ .TYO6 .IFNM2
+PRINTX \
+\
+TERMIN
+] ;END OF IFE .OSMIDAS-,
+.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-, 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==+ ;HACK FOR CROSSING 1000'S
+IFN <&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
+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
+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 *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 ;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+<_11>]
+ .CBLK TT,
+ .VALUE
+ MOVE TT,[4400,,400000+<_11>]
+ .CBLK TT,
+ .VALUE
+ MOVE TT,[4400,,400000+<_11>]
+ .CBLK TT,
+ .VALUE
+ MOVE TT,[4400,,400000+<_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
+ NIL,,NIL ;^\ CONTROL RIGHT-BRACKET
+ NIL,,NIL ;^^ ^_
+REPEAT -<.-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 ^ 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 -<.-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 -<.-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
+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: ;-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 ; 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)
+;;; 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
+.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- ;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$ -+NBITB,,BFBTBS_<5-SEGLOG>
+PG% -+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$ <&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+<&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
+ ; 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
+ ;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 ;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 ;,,-
+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>,,
+LLIP1: 0 ;+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
+ -/2,,IOBAR2
+IOBAR1: JSP TT,1DIMS
+ OBARRAY
+ OBTSIZ+1+200
+IOBAR2: BLOCK /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 &17, PRINTX \ \
+IFE &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+>];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+
+ .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_-
+ 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 ( 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
+;;; 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-> 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--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 )
+;;; (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 )))))
+
+
+$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 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 IN . 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.)) ;
+;;; (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 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+*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,,
+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>+(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 ) 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,-(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>+(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:
+;;; ,,
+;;; ,,