;;; -*-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:
;;; ,,
;;; ,,