perm filename GOGOL.GG[S,AIL] blob
sn#072697 filedate 1973-11-20 generic text, type T, neo UTF8
COMMENT ⊗ VALID 00055 PAGES
RECORD PAGE DESCRIPTION
00001 00001
00011 00002 HISTORY
00018 00003 Command File Descriptions
00020 00004 Conditional Assembly Switches, Macros
00024 00005 Titles, Versions
00025 00006 AC Definitions
00026 00007 CDB, SIMIO Indices For IOSER, OTHER INDICES
00030 00008 Base (Low Segment) Data Descriptions -- Macros, Compil spec
00032 00009 Base (Low Segment) Data Descriptions - Params, Links, Size specs
00040 00010 Initialization Routines, Data
00042 00011 Sailor, Reent -- Allocation, Main Program Control
00046 00012 .SEG2. -- Get a second segment
00049 00013
00052 00014
00055 00015
00056 00016 Segment-Fetching Data
00059 00017
00060 00018 %ALLOC -- Main Allocation Routine
00066 00019
00073 00020
00077 00021
00080 00022 Utility Subroutines for allocation
00082 00023 %UUOLNK -- UUO Handler (Dispatch Vector Just Below)
00085 00024 DSCR OCTPNT, DECPNT UUO'S
00088 00025 DSCR PRINIT -- INTERFACE TO SYSTEM PRINTING FACILITIES
00091 00026 DSCR ERROR UUOS
00097 00027 DSCR CALLEDFROM -- PRINTS 'CALLED FROM' XXX 'LAST SAIL CALL AT'
00102 00028 Special Printing Routines For Error Handler
00106 00029 DSCR USERERR(VALUE,CODE,"MSG","RESPONSE")
00114 00030 Code to Handle Linkage to Editors
00117 00031
00122 00032 SAVE, RESTR, INSET -- General Utility Routines
00138 00033 Core Service Routines -- General Description
00142 00034 Special AC Declarations
00143 00035 Utility Routines
00148 00036
00152 00037 CORGET
00156 00038
00158 00039 CORINC, CANINC
00163 00040 CORREL
00168 00041 CORPRT, CORBIG
00171 00042 String Garbage Collector Routines
00176 00043
00179 00044
00184 00045
00188 00046
00192 00047
00194 00048
00196 00049
00198 00050 Some Runtime Routines Which Could Go Nowhere Else
00199 00051 Kounter Routines
00201 00052
00207 00053 DSCR POW, FPOW, LOGS, FLOGS. BOTH RETURN REALS.
00212 00054 DSCR EXP,ALOG -- FOR USE BY EXPONENTIATION ROUTINES & WORLD
00225 00055 DSCR VAL←CODE(OCTAL COMMAND, REFERENCE ARG)
00227 ENDMK
⊗;
COMMENT ⊗HISTORY
AUTHOR,FAIL,REASON
031 102100000003 ⊗;
DEFINE .VERSION <102100000003>
COMMENT ⊗
11/10/73 %AI% -- KVL PUTS IN NEW ERR UUO
10/29/73 %AH% -- REE W/O STARTING
10/23/73 %AG% -- LEAPIS SWITCH IN $GITNO, NOT $ITNO
10/6/73 %AD% -- ALLOW LOWER CASE ANSWER TO "ALLOC"
9/18/73 MAKE END OF SAIL EXECUTION MESSAGE DO A CRLF FIRST
8/6/73 #NN# 0.0↑X GIVING EXPONENT UNDERFLOW
VERSION 17-1(3) 7-27-73 BY KVL PUTS IN SOME XX'S FOR HOLDING .LOG FILE INFO
VERSION 17-1(2) 7-27-73 BY KVL DECLARE ERSCPD IN LOWER
VERSION 17-1(1) 7-26-73 BY RHT ****** VERSION 17 STRIKES HERE *******
VERSION 16-2(65) 7-13-73 BY JRL HERE CORGET AND FRIENDS
VERSION 16-2(64) 7-13-73
VERSION 16-2(63) 7-13-73
VERSION 16-2(62) 6-28-73 BY JRL BUG #MW# PPMAX NOT EXTERALED IN SAILUP(EXPORT ONLY)
VERSION 16-2(61) 5-3-73 BY RHT ADD EXTRA THREE XX CELLS FOR INTRPT SYS
VERSION 16-2(60) 2-27-73 BY JRL REMOVE ..RVAL FROM XX AREA
VERSION 16-2(59) 2-12-73 BY JRL ADD ..RVAL TO XX AREA
VERSION 16-2(58) 1-8-73 BY JRL BUG #KV# CHECK FOR NULL INILNK IN .UNIT
VERSION 16-2(57) 12-2-72 BY RHT ENLARGE HERE TABLE
VERSION 16-2(56) 12-1-72 BY RHT ADD DEFSSS,DEFPSS,DEFQNT,DEFPRI TO XX AREA
VERSION 16-2(55) 11-30-72 BY RHT ADD XX ENTRY FOR NOPOLL
VERSION 16-2(54) 11-22-72 BY JRL BUG #KL# STACSV SAVED TOO MANY AC'S IN TOO FEW LOCATIONS
VERSION 16-2(53) 11-22-72
VERSION 16-2(52) 11-22-72
VERSION 16-2(51) 11-17-72 BY RHT MAKE USER INITIALIZATION A SEPARATE PROCEDURE
VERSION 16-2(50) 11-10-72 BY JRL ADD PROPS TO XX AREA
VERSION 16-2(49) 10-12-72 BY RHT ADD PPMAX FOR EXPO VERSION (NEEDED BY ED LNKG)
VERSION 16-2(48) 10-5-72 BY JRL MAKE GLUSER INTERNAL
VERSION 16-2(47) 10-3-72 BY RHT MAKE USER INIT WORK RIGHT
VERSION 16-2(46) 9-24-72 BY JRL FIX LIB ENTRIES FOR PROC. STR GAR COL
VERSION 16-2(45) 9-21-72 BY RHT SCREW UP THE COMPIL MACRO
VERSION 16-2(44) 9-21-72 BY JRL ADD SPRPDA TO SGC COMPIL MACRO
VERSION 16-2(43) 9-11-72 BY JRL ADD GINFTB,GDATM TO LOWER WHEN NO GLOB
VERSION 16-2(42) 9-5-72 BY JRL BAD FIX TO SGLKBK PROBLEM
VERSION 16-2(41) 8-21-72 BY RHT PUT IN JRL'S STACSV &STACRS
VERSION 16-2(40) 8-7-72 BY RHT CHANGE INILNK STUFF
VERSION 16-2(39) 8-7-72 BY KVL PRINT MSG BEFORE CANT CONTINUE ANY FURTHER MSG (P24)
VERSION 16-2(38) 7-3-72 BY DCS BUG #IC# ADD NEW MEANING TO NOSHRK(USER)
VERSION 16-2(37) 7-3-72 BY DCS BUG #IB# MAKE DEFAULT SYSTEM STACK SIZE BIGGER
VERSION 16-2(36) 7-2-72 BY JRL HAVE %ALLOC CALL LPINI IF NEEDED
VERSION 16-2(35) 6-20-72 BY DCS BUG #HU# BETTER TTY PRINTOUT
VERSION 16-2(34) 5-16-72 BY DCS BUG #HI# %ARRSRT TESTS RIGHT BIT FOR STR ARRAY NOW
VERSION 16-2(33) 5-11-72 BY DCS BUG #HE# MODIFY VERSION CHECKING, INSTALL VERSION 16
VERSION 15-6(23-32) 5-3-72 VARIOUS FIXES
VERSION 15-6(14-22) 2-21-72 VARIOUS FIXES
VERSION 15-6(13) 2-19-72 BY RHT THE BRAVE NEW WORLD
VERSION 15-2(12) 2-5-72 BY DCS BUG #GI# REMOVE TOPSTR
VERSION 15-2(11) 2-2-72 BY DCS BUG #GI# LEAVE SOME SLOP IN REMCHR SO CAT'LL BE MORE EFFICIENT
VERSION 15-2(10) 2-1-72 BY DCS REPLACE (FIXED) %ALLOC BLOCK ACCESSES BY SYMBOLIC HEAD-DEFINED ONES
VERSION 15-2(9) 1-30-72 BY DCS REPLACE %ALLOC -- INITIAL ALLOCATION
VERSION 15-2(8) 1-14-72 BY DCS BUG #GA# SEGMENTS HAVE .SEG EXTENSIONS, NOT .REL
VERSION 15-2(7) 1-3-72 BY DCS BUG #FX# REMOVE NEED FOR COM2, REORGANIZE SEGMENT-GETTING STUFF
VERSION 15-2(6) 12-26-71 BY DCS BUG #FU# REENABLE ACCESS FROM ERR UUO TO FTDEBUGGER
VERSION 15-2(5) 12-24-71 BY DCS BUG #FT# DSPLIN BETTER, TV AS VALID EDITOR
VERSION 15-2(4) 12-22-71 BY DCS BUG #FF# SIXPRT(14-15) TO ERR, IOERR ROUTS
VERSION 15-2(3) 12-22-71 BY DCS BUG #FS# REMOVE SAILRUN, COM2, ASSUME COMPILER
VERSION 15-2(2) 12-2-71 BY DCS ADD VERSION SETUP CODE
VERSION 15-2(1) 12-2-71 BY DCS INSTALL VERSION NUMBER
⊗;
SUBTTL Command File Descriptions
LSTON (GOGOL)
COMMENT ⊗
The following command files make runtime routines:
1. RUN
One assembly, get a non-library, non-2d-segment runtime package
RUNTIM=CALLIS(LR)+HEAD+ORDER+GOGOL+TRIGS+STRSER+IOSER+NWORLD+LEPRUN+MESPRO+WRDGET
2. SGMNT
Makes the non-global UPPER.REL and SAILOW.REL, which when
loaded and run and stuff become SAISGn.SEG and SAILOW.REL,
the 2d segment runtime routines
TAILOR=HEAD+FILSPC+TAILOR/NOLO
LOWER=CALLIS+HEAD+LOW+FILSPC+GOGOL/NOLO
TAILOR.REL,UPPER=CALLIS+HEAD+UP.FAI+ORDER+GOGOL+STRSER+IOSER+
NWORLD+LEPRUN+MESPRO+WRDGET
5. GSGMNT
Makes the global model SAILOW AND UPPER, otherwise like
SGMNT
Same, but add GLB after HEAD in all three.
6. SCISS.SAI
This SAIL program, when run, uses the runtime files to
make a LIBSAI.REL file, the SAIL (lower-segment) library
⊗
SUBTTL Conditional Assembly Switches, Macros
DSCR ** CONDITIONAL ASSEMBLY SWITCHES **
⊗
STSW(UPPER,0) ;NOT UPPER OR LOWER IF NEITHER SET
STSW(LOWER,0)
STSW(GLOBSW,0) ;ONLY GLOBAL IF SOMEBODY ELSE SAID SO
STSW(SEGS,0)
STSW(RENSW,0) ;RE-ENTRANT LIBRARY (HISEG) IF ON
STSW(LEAPSW,1) ;ASSUME LEAP
EXPO <
STSW(APRISW,1) ;THE APR INTERRUPT PACKAGE IS TO BE USED
>;EXPO
NOEXPO <
STSW(APRISW,0) ;USUALLY USE THE MOORER PACKAGE
>;NOEXPO
DSCR COMPIL(NAM,ENTRIES,EXTERNALS,DESCRIPTION,INTERNALS,HINHB)
CAL MACRO
PAR NAM IS 3 CHAR NAME -- TITLE WILL BE SAINAM
ENTRIES ARE LIST OF ENTRIES CONTAINED IN THIS
LIBRARY ASSEMBLY (INTERNALS IF NOT LIBRARY SETUP)
EXTERNALS (OPTIONAL) ARE EXTERNALS NEEDED FOR THIS ENTRY.
DESCRIPTION IS OPTIONAL, AND IS USED IN THE SUBTTL
IF PRESENT.
INTERNALS (OPTIONAL) DESCRIBE INTERNALS WHICH ARE NEVER ENTRIES.
HINHB (OPTIONAL ANYTHING), IF NON-BLANK, INHIBITS THE HISEG)
DES IF MAKING A LIBRARY, AND IF THIS FILE IS DESIRED
(SEE SCISS PROGRAM), A FILE OF THE NAME SAINAM.FAI
WILL BE MADE CONTAINING ALL THE PROGRAM TEXT FROM THE
COMPIL MACRO TO THE ENDCOM MACRO WHICH SHOULD FOLLOW
THE CODE FOR THIS ENTRY. ENDCOM DOES AN END IF
IN LIBRARY COMPILE MODE.
RES THE MACRO EXPANDS TO PROVIDE A TITLE AND THE
APPROPRIATE ENTRIES AND EXTERNALS FOR THIS ASSEMBLY.
ALSO A SUBTTL CONTAINING THE TITLE AND OPTIONAL
DESCRIPTION IS PROVIDED.
⊗
DEFINE COMPIL ' (NAM,ENT,EXT,DSCRP,INT,HINHB,DUMMY) <
IFIDN <DUMMY>,<> <
SUBTTL SAI'NAM -- DSCRP
IFE ALWAYS,<
IFDIF <><ENT>,<ENTRY ENT>
TITLE SAI'NAM
REN <
IFIDN <><HINHB>,<HISEG ;LOAD TO UPPER IF POSSIBLE>
>;REN
IFDIF <><EXT>,<EXTERN EXT>
>;IFE ALWAYS
NOLOW <
IFDIF <><INT>,<INTERN INT>
IFN ALWAYS,<
IFDIF <NAM><LOR>,<
IFDIF <><ENT>,<INTERNAL ENT>
>>
>;NOLOW
>;IFIDN <DUMMY>
>
DEFINE COMPXX ' (NAM,ENT,EXT,DSCRP,INT,HINHB)
<COMPIL(<NAM>,<ENT>,<EXT>,<DSCRP>,<INT>,<HINHB>)>
DEFINE ENDCOM (NAM) <
IFE ALWAYS,<
END
>;IFE ALWAYS
>
; SWITCHES TO CONTROL LIBRARY COMPILATION
IFNDEF ALWAYS,<↓ALWAYS←←1>
IFN ALWAYS,<DEFINE ENTINT (X) <INTERNAL X>>
IFE ALWAYS,<DEFINE ENTINT (X) <ENTRY X>>
SUBTTL Titles, Versions
DSCR TITLES, VERSIONS
⊗
IFN ALWAYS,<
; "TITLE UPPER" IS FOUND IN UP.FAI FILE TO MAKE OUTER PROG TITLED
LOW <
TITLE LOWER
>;LOW
NOUP <
NOLOW <
TITLE RUNTIM -- SAIL RUNTIME ROUTINES
>;NOLOW
JOBVER←←137
LOC JOBVER
;;#HE# DCS 5-11-72 (1-2) MODIFY VERSION STUFF
.VERSION&777777000000 ;CURRENT VERSION NUMBER (LH ONLY)
;;#HE# (1-2)
RELOC
LOC 124 ;SET UP REENTER ADDRESS
REENT
RELOC
>;NOUP
>;ALWAYS≠0
SUBTTL AC Definitions
DSCR AC DEFINITIONS
⊗
; AC DEFINITIONS FOR SERVICE AND RUNTIME ROUTINES
; ALL UUO ROUTS, IOSER COMMENTS
; CORE ROUTS,
; STRING GC,
; ALLOCATION
↓FF←←0
↓A←1 ;TEMPS FOR ALLES
↓B←2 ; (SOMETIMES SAVED)
↓C←3
↓D←4
↓E←5 ↓X←5 ;MORE TEMPS
↓Q1←6 ↓Y←6
↓Q2←7 ↓Z←7
↓Q3←10 ↓Q←10
↓T←11 ↓CDB←11 ;CHANNEL DATA BLOCK PTR
↓T1←12 ↓CHNL←12 ;CHNL # FOR IOSER
↓LPSA←13 ;TEMP, PARAM AC
↓TEMP←14 ;TEMP ONLY
↓USER←15 ;→USER TABLE FOR RNTRNT ROUTS
↓SP←16 ;STRING STACK
↓P←17 ;SYSTEM STACK
SUBTTL CDB, SIMIO Indices For IOSER, OTHER INDICES
DSCR -- CDB, SIMIO INDICES FOR IOSER
DES The I/O routines obtain their information from the user via a
channel number -- the same kind used by the system. In order to
find byte pointers, counts, file names, etc., the channel number is
used to index into a block of core called a CDB (Channel Data Block).
This CDB is filled with good data during the OPEN operation.
The CDB, and all I/O buffers, are obtained from CORGET.
The CHANS table in the GOGTAB area is a 20 word block containing
pointers to the appropriate CDB's.
Since channel numbers must appear in the AC field of IO instructions,
one must construct IO insts. in impure places to retain re-entrancy.
XCT INDEX,SIMIO executes the appropriate IO instruction with the
channel number from AC CHNL, used by all routines. See SIMIO for
operational details.
⊗
; SIMIO INDICES FORMAT OF CDBs
DMODE ←← 0 ↔↓IOSTATUS ←← 0 ;DATA MODE ;RETURN STATUS
DNAME ←← 1 ↔↓IOIN ←← 1 ;DEVICE ;BUFFERED INPUT
BFHED ←← 2 ↔↓IODIN ←← 2 ;HEADER POINTERS ;DUMP INPUT
↓IOOUT ←← 3 ;BUFMODE OUT.
OBPNT ←← 3 ↔↓IODOUT ←← 4 ;OUTPUT BUF. PTR ;DUMP OUTPUT
OBP ←← 4 ↔↓IOCLOSE ←← 5 ;OUTPUT BYTE PTR ;CLOSE FILE
OCOWNT ←← 5 ↔↓IORELEASE←← 6 ;OUTPUT BYTE CNT ;RELEASE FILE
ONAME ←← 6 ↔↓IOINBUF ←← 7 ;OUTPUT FILE NAM ;INBUF
OBUF ←← 7 ↔↓IOOUTBUF ←←10 ;OUTPUT BUFFER LOC. ;OUTBUF
↔↓IOSETI ←←11 ;USETI
IBPNT ←←10 ↔↓IOSETO ←←12 ;SAME FOR INPUT ;USETO
IBP ←←11 ↔ ; 13 UNUSED
ICOWNT ←←12 ↔↓IOOPEN ←←14 ;OPEN CHANNEL
INAME ←←13 ↔↓IOLOOKUP ←←15 ;LOOKUP FILE
IBUF ←←14 ↔↓IOENTER ←←16 ;ENTER FILE
↔↓IORENAME ←←17 ;RENAME FILE
ICOUNT ←←15 ;INPUT DATA COUNT LIMIT ADDRESS
BRCHAR ←←16 ;XWD TTYDEV FLAG, INPUT BREAK CHAR ADDR
TTYDEV ←←16 ;LH -1 IF DEVICE IS A TTY -- USED BY OUT
ENDFL ←←17 ;INPUT END OF FILE FLAG ADDR
ERRTST ←←20 ;USER ERROR BITS SPECIFICATION WORD
PGNNO ←←20 ;PAGE NUMBER FOR DISPLAY FEATURE (IF FEATURE NOT INCLUDED)
NOEXPO <
PGNNO ←←21 ;SAME THING IF IT IS INCLUDED
>;NOEXPO
↑IOTLEN ←←PGNNO+1 ;LENGTH OF TABLE ENTRY
↓LUPDL←30 ;LENGTH OF UUO PDL
↓MINPDS←←=64 ;SMALLEST ALLOWABLE SYSTEM PDL SIZE
↓DEFPDS←←=192 ;DEFAULT PDL SIZE
SUBTTL Base (Low Segment) Data Descriptions -- Macros, Compil spec
DSCR DATA DESCRIPTIONS, TAILORED FOR TWO SEGMENT OPERATION
⊗
NOUP <
DEFINE SGLK (ROUT,NAM,INT) <
XX (NAM,ROUT,INT) ;NAME OF STRING DSCRPTR GENERATING ROUTINE
XX (,0,) ;PLACE TO PUT A LINK
LINK %SGROT,.-1 ;WHEREWITHAL TO GENERATE SAID LINK
>
>;NOUP
UP <
DEFINE SGLK (ROUT,NAM) <
XX (NAM,ROUT,)
XX (,0,)
>
>;UP
DEFINE XX (A,B,C,D) <
IFDIF <A><>,<↓ A :> B
IFDIF <C><>,< C A >
>
UP <
III←←140
DEFINE XX (A,B,C,D) <
IFDIF <A><>,<↓ A ← III >
III ←← III + 1
IFDIF <D><>,<III←III+D-1>
>
>;UP
COMPIL(LOR,<SAILOR,.SEG2.>
,<%UUOLNK,%ALLOC,%SPGC,%STRMRK,%ARRSRT,K.OUT,K.ZERO,$PDLOV>
,<BASE DATA, INITIALIZATION CONTROL>
,<X11,X22,X33,X44>,INHIBIT)
SUBTTL Base (Low Segment) Data Descriptions - Params, Links, Size specs
; UNIVERSAL VARIABLES -- BASES OF MAJOR DATA STRUCTURES, GLOBAL FLAGS
XX (GOGTAB,0,INTERNAL) ;→USER TABLE
XX (DATM,0,INTERNAL) ;XWD 3,→DATUM TABLE
XX (LKSTAT,0,INTERNAL) ;STATUS OF GLOBAL LEAP MODEL INTERLOCK (SHOULD BE IN GOGTAB
XX (INFTB,0,INTERNAL) ;XWD 2,→INFOTAB TABLE
XX (.SKIP.,0,INTERNAL) ;RECORD AUX RESULTS OF RUNTIMES
XX (RPGSW,0,INTERNAL) ;SET IF (JOBSA)+1 USED TO START
XX (%RENSW,0,INTERNAL) ;SET IF USER WANTS TO RENTER FOR ALLOC
XX (CONFIG,0,INTERNAL) ;0 FOR RUNTIME, <0 FOR COMPILER
XX (.ERRP.,0,INTERNAL) ;PLACE FOR USER TO PUT AN ERROR PROCEDURE
XX (.ERRJ.,0,INTERNAL) ;TRANSFER ADDRESS RETURNED BY USER PROC.
XX (%ERRC,0,INTERNAL) ;COMMUNICATION BETWEEN USERRR AND ERROR UUO.
XX (%RECOV,0,INTERNAL) ;HIGH ORDER BIT ON IF ERROR RECOVERABLE
XX (%ERGO,0,INTERNAL) ;SET IF IN CONTINUATION MODE.
XX (.ERSTP,0,INTERNAL) ;POINTER INTO ERROR STRING.
XX (.ERSTR,<BLOCK 20>,INTERNAL,20) ;ERROR MESSAGE STRING.
XX (RUNNER,0,INTERNAL) ;THE CURRENTLY RUNNING PROCESS(IF HAVE THEM)
XX (INTRPT,0,INTERNAL) ;MASK FOR INTERRUPT POLLING
XX (PROPS,0,INTERNAL) ;BYTE POINTER FOR ACCESSING PROPS(ITEM) ITEM IN 3
XX (NOPOLL,0,INTERNAL) ;≠0 →→ IGNORE CALL TO DDFINT
XX (DEFSSS,0,INTERNAL) ;DEFAULT S-STACK SIZE -- SET BY MAINPR
XX (DEFPSS,0,INTERNAL) ;DEFAULT P-STACK SIZE (FOR PROCESSES) -- DITTO
XX (DEFPRI,0,INTERNAL) ;DEFAULT PRIORITY -- DITTO
XX (DEFQNT,0,INTERNAL) ;DEFAULT QUANTUM -- DITTO
XX (OVPCWD,0,INTERNAL) ;SET BY APR INTERRUPT HANDLER (IF ANY)
NOEXPO <
IFE APRISW <
XX (XJBCNI,0,INTERNAL) ;JOBCNI TYPE THING FOR MOORER SYS (MOD BY F.WRIGHT)
XX (XJBTPC,0,INTERNAL) ;JOBTPC THING, ETC
XX (XJBAPR,0,INTERNAL) ;JOBAPR THING.
>;IFE APRISW
IFN APRISW <
XX (S10ARE,0)
XX (S11ARE,0)
XX (S12ARE,0)
>;IFN APRISW
>;NOEXPO
XX (S1PARE,0) ;SPARE LOWER LOCATIONS
XX (S2PARE,0)
XX (S3PARE,0)
XX (S4PARE,0)
XX (S5PARE,0)
XX (S6PARE,0)
XX (S7PARE,0)
XX (S8PARE,0)
XX (S9PARE,0)
GLOB <
XX (GSPARE,<BLOCK 2>,,2)
>;GLOB
NOGLOB <
XX (GDATM,0,INTERNAL) ;DUMMY GLOBAL DATUM TABLE SHOULD ALWAYS BE ZERO
GPROPS←GINFTB←GDATM ;DUMMY GLOBAL INFOTAB DITTO
INTERNAL GINFTB,GPROPS
>;NOGLOB
; STATIC LINKAGES -- FEATURE PROVIDED BY LOADER
; THESE ARE THE BASES OF ONE-WAY LINKED LISTS WHICH ALLOW ACCESS
; TO SELECTED DATA IN ALL LOADED MODULES
XX (STLNK,0,INTERNAL) ;1 ALL STRINGS TIED TOGETHER FOR STRNGC
XX (SPLNEK,0,INTERNAL) ;2 ALL SPACE REQUESTS (PDLS, ETC.)
XX (SETLET,0,INTERNAL) ;3 ALL SET VARIABLES TIED TOGETHER
XX (SGROT,0,INTERNAL) ;4 LIST OF STRNGC SORTER GENERATORS
XX (KTLNK,0,INTERNAL) ;5 ALL COUNTER BLOCKS
XX (INILNK,0,INTERNAL) ; INITIALIZATION ROUTINES (LPINI ONLY NOW)
SYSPHS←←2 ;TWO SYSTEM PHASES
USRPHS←←1 ;TWO USER PHASES (FOR NOW)
; THESE OPS INFORM THE LOADER OF THE ABOVE BASE LOCATIONS.
NOUP <
LINKEND %STLNK,STLNK
LINKEND %SPLNK,SPLNEK
LINKEND %SETLK,SETLET
LINKEND %SGROT,SGROT
LINKEND %KTLNK,KTLNK
LINKEND %INLNK,INILNK
>;NOUP
; SOME ROUTINES WHICH GO ON THE SGROT LIST (SEE SGLK)
;↑SGLKBK
SGLK (%ARRSRT,SGLKBK,INTERNAL);ROUTINE TO COLLECT STRING ARRAYS
SGLK (%STRMRK) ;ROUTINE TO COLLECT STRING VARIABLES
SGLK (%SPGC) ;ROUTINE TO COLLECT STRING STACK
;HERE IS THE LIST OF DEFAULT SPACE ALLOCATION ENTRIES
XX (%SPL,<BLOCK $SPREQ-2>,INTERNAL,$SPREQ-2);DUMMY FIXED ADDR STUFF
XX (%STDLST,<BLOCK 2>,INTERNAL,2) ;BASE OF BUILT-IN REQUESTS
XX (,<XWD WNTPDP!MINSZ!USRTB,DEFPDS>) ;SYSTEM_PDL (SPECIAL, SEE BELOW)
XX (,<XWD [ASCIZ /SYSTEM_PDL/],PDL>)
XX (,<XWD WNTPDP!USRTB!MINSZ,50>) ;STRING STACK
XX (,<XWD [ASCIZ /STRING_PDL/],SPDL>)
XX (,<XWD WNTADR!WNTEND!USRTB!MINSZ,2000>);STRING_SPACE
XX (,<XWD [ASCIZ /STRING_SPACE/],ST>)
XX (,0) ;THAT'S ALL
; LINK %SPLNK,%SPL ;%ALLOC DOES THIS EXPLICITLY SO THIS
;BLOCK WILL BE FIRST
;SOME RANDOM GLOBALLY USEFUL THINGS, WHICH UNFORTUNATELY HAVE TO
;BE IN FIXED LOCATIONS (FOR THE RUNTIMES TO FIND)
XX (ALLPDP,<IOWD 20,ALLPDL>,INTERNAL);USED FOR A WHILE DURING ALLOC
XX (ALLPDL,<BLOCK 20>,INTERNAL,20) ;AND IN PROCESS TERMINATION
XX (%ALLCHR,0,INTERNAL)
XX (%OCTRET,0,INTERNAL)
XX (DPYSW,0,INTERNAL) ;ON IF CONSOLE IS DPY
NOEXPO <
XX (PGDS,<PGDS0>,INTERNAL) ;PIECE OF GLASS FOR LINE BREAK ON INPUT
XX (,7,)
XX (PGDS0,0,)
XX (,<AIVECT (300,200)>,)
XX (,<ASCID /PAGE/>,)
XX (,<ASCID / />,)
XX (,<ASCID /LINE />,)
XX (,<ASCID / />,)
XX (,<DPYJMP PGDS0>,)
>;NOEXPO
;SOME WONDERFULLY USEFUL CONSTANTS
XX (X11,<XWD 1,1>,INTERNAL)
XX (X22,<XWD 2,2>,INTERNAL)
XX (X33,<XWD 3,3>,INTERNAL)
XX (X44,<XWD 4,4>,INTERNAL)
LOW <
EXTERNAL LPINI
LPLK: 0
LPINI
0
LINK %INLNK,LPLK
>;LOW
EXPO <
XX (PPMAX,<BLOCK 3>,INTERNAL,3) ;FOR SCREWY EDITOR LINKAGE
>;EXPO
XX (APRACS,<BLOCK 20>,INTERNAL) ;APR INTERRUPT AC STORAGE
SUBTTL Initialization Routines, Data
COMMENT ⊗ The Run-Time I/O handling routines are re-entrant. This
means that any modifiable words or parameters particular to a given
user must come from the user's core image. The pointer to this area
will be found in GOGTAB in the lower segment. The I/O routines use
some of the AC'S in standard ways, described above with AC definitions.
⊗
DSCR SAILOR -- ALLOCATION AND INITIALIZATION ROUTINES
CAL JSR
DES
Part of this is not yet reentrant. In particular,
it is called by a JSR SAILOR
The functions of this routine are:
1. Get a second segment, if this is a SAISEG-program
2. Process space requests, allow user-override if REENTER used
to start.
3. Use %ALLOC to allocate requested regions.
4. Clear Kounters
5. Change starting and re-entry addresses,
6. PUSHJ to user program
7. Record Kounters, RESET and quit.
⊗
SUBTTL Sailor, Reent -- Allocation, Main Program Control
NOUP <
;SAIL job calls SAILOR first time, with RPGSW set up already
INTERNAL SAILOR
↑SAILOR: 0 ;JSR to SAILOR
JRST FRSTRT ;GET A SEGMENT, START UP
; REENTER to manually change allocation, and to flush REQUIREd segments
↑REENT: SETOM %RENSW ;RE-ENTER -- ASK FOR NEW ALLOC
;;%AH% RHT (2 OF 2) 10-29-73 HORRID KLUGE TO DO REENTER WHEN HAVEN'T STARTED YET
SKIPE SAILOR ;IF SAILOR≠0, WE KNOW WHERE TO GO
JRST RESTRT ;
MOVEM TEMP,SAILOR ;HAIRY KLUGE TO USE NO ACS
HRRZ TEMP,JOBSA
EXCH TEMP,SAILOR ;TEMP MAY NOT MATTER, SO
JRST @SAILOR ;MAY NOT REALLY NEED ALL THIS
; ACTS LIKE A START WITH RENSW SET
;USUALLY THIS WINDS UP JSR'ING BACK TO SAILOR
;;%AH%
;SAIL STARTS HERE WHEN USER TYPES S<T<A<R<T>>>> AGAIN
↑RESTRT:TDZA TEMP,TEMP ;ESTABLISH OPERATING MODE
MOVNI TEMP,1 ;RPG MODE
MOVEM TEMP,RPGSW ;RECORD IT
FRSTRT: JSP P,.SEG2. ;GET SECOND SEGMENT
STRT: CALLI
SETZM GOGTAB ;FORCE CORSER RE-INITIALIZATION
SETNIT ;GET TEMP STACK, IF NECESSARY
JSP 16,%ALLOC ;ALLOCATE AREAS
MOVEI A,RESTRT ;CHANGE JOBSA AND JOBREN
HRRM A,JOBSA ;"S" USES OLD ALLOCATION
MOVEI A,REENT ;"REE" ASKS QUESTIONS AGAIN
MOVEM A,JOBREN
PUSHJ P,K.ZERO ;ZERO OUT THE COUNTERS
PUSHJ P,INILST ;GO DO ALL OTHER INITIALIZATIONS
PUSHJ P,@SAILOR ;CALL USER PROGRAM
PUSHJ P,K.OUT ;WRITE OUT THE COUNTERS
TERPRI <
End of SAIL execution>
CALL6 (0,RESET) ;CLEAR THE I/O WORLD
CALL6 (1,EXIT) ;QUIT QUIETLY
INILST:
SKIPN TEMP,INILNK
POPJ P,
MOVE USER,GOGTAB ;JUST TO BE SURE
SKIPA A,[XWD -SYSPHS,0] ;XWD #SYS PHASES,0
DOPHS: HRRZ TEMP,INILNK ;LIST OF THEM
NXLNK:
PUSH P,TEMP ;SAVE LINK
NXIN: ADDI TEMP,1 ;LOOK AT NNEXT ENTRY
SKIPN B,(TEMP) ;END OF LINK LIST
JRST NXIN.1 ;YES
HLRZ C,B ;PHASE NUMBER OF THIS
CAIE C,(A) ;THIS PHASE
JRST NXIN ;NO
PUSH P,A
PUSH P,TEMP
PUSH P,USER
PUSHJ P,(B)
POP P,USER
POP P,TEMP
POP P,A
JRST NXIN ;GO DO NEXT IN THIS
NXIN.1: POP P,TEMP
HRRZ TEMP,(TEMP)
JUMPN TEMP,NXLNK
NXPHS: AOBJN A,DOPHS ;GO ON TO NEXT PHASE
POPJ P, ;
INTERNAL .UINIT
.UINIT: MOVE A,[XWD -USRPHS,400000] ;DO USER PHASES
;; #KV# MAKE SURE LINK NON-NULL
SKIPN INILNK
POPJ P,
;; #KV#
JRST DOPHS
SUBTTL .SEG2. -- Get a second segment
COMMENT ⊗ Initialize the second segment, if there is none and if desired.
This occurs when the program is first started. This is a dummy routine
if not a SAISEG-program
⊗
INTERNAL .SEG2.
.SEG2.:
LOW <
SKIPE JOBHRL ;IS THERE A SEGMENT?
>;LOW
JRST (P) ; YES, GO AHEAD (OR ALWAYS, IF NOLOW)
>;NOUP
LOW <
COMMENT ⊗ Now, if global model, get segment specifications from space blocks
of compiled programs (via REQUIRE verbs in source code).
Segment name business is ignored in EXPO version, since segment and file
names are always equivalent (philosophical differences).
⊗
SEGTR: ;TRY AGAIN
GLOB <
SKIPN %RENSW ;IS LINK-TABLE AND/OR PREVIOUSLY COLLECTED
; INFORMATION INVALID??
JRST SEG3 ;NO
FOR II⊂(SEGDEV,SEGFIL,SEGPPN,NMSAV) <
SETZM II
>
JRST ASKEM ;CLEAR ALL NON-USER SPECIFIED INFO
SEG3: SKIPN B,SPLNEK ;A SPACE BLOCK AROUND??
JRST ASKEM ; NO
GSGLP: SKIPE A,$SGD(B) ;DEVICE REQUEST
MOVEM A,SEGDEV
SKIPE TEMP,$SGF(B) ;FILE NAME FOR UPPER SEGMENT
MOVEM TEMP,SEGFIL
SKIPE TEMP,$SGPP(B) ;PPN FOR SAME
MOVEM TEMP,SEGPPN
SKIPE TEMP,$SGNM(B) ;SEGMENT NAME (UNUSED IN EXPO VERSION)
MOVEM TEMP,NMSAV
SKIPE B,(B) ;GO DOWN LINKED LIST
JRST GSGLP ; UNTIL EMPTY
>;GLOB
COMMENT ⊗ If not enough information was supplied (global model only),
ask questions of user to obtain file names, etc. Also (NOEXPO only),
try to ATTSEG to a segment of the desired name. In the EXPO version,
all this is combined in the GETSEG below.
⊗
NOEXPO < ;SEGMENT NAME NOT USEFUL TO EXPO SYSTEM
GLOB <
SKIPE A,NMSAV ;DID WE GET A SEGMENT?
JRST GOTEM ; YES, TRY TO LINK TO IT
ASKEM: SPRINT <SEGMENT LOGICAL NAME?>
JSR GGNAM ;GET A SEGMENT NAME.
GOTEM: MOVEM A,NMSAV
>;GLOB
NOGLOB <
MOVE A,[FILXXX] ;TRY TO FIND IT.
>;NOGLOB
CALLI A,400016 ;ATTSEG.
SKIPA ;NO LUCK
JRST (P) ;OK, DONE
HRRZ B,A ;GET FAILURE CODE.
CAIE B,1 ;AMBIGUITY?
JRST GETSE ;NO -- GET THE SEGMENT.
HLRZS A
CALLI A,400016 ;ATTSEG.
JSP A,ERSEG
JRST (P) ;OK, GOT IT
>;NOEXPO
EXPO <
ASKEM: ;MISPLACED LABEL
>;EXPO
GETSE: CALLI
GLOB <
SKIPE A,SEGFIL ;WAS ONE "REQUIRE"D?
JRST THSFL ; YES, USE IT
SPRINT <SEGMENT FILE NAME?>
MOVE A,[FILXXX] ;DEFAULT
JSR GGNAM
THSFL: MOVEM A,SEGFIL ;NAME OF SEGMENT.
THSFL1: SKIPE A,SEGDEV ;WAS A DEVICE REQUESTED?
JRST THSDV ; YES
SPRINT <DEVICE?>
MOVE A,[SGDEVC] ;DEFAULT DEVICE
JSR GGNAM
MOVEM A,SEGDEV
CAMN A,['DSK '] ;ASK FOR PPN IF DISK
SKIPE SEGPPN ;AND PPN=0
JRST THSDV ;DON'T ASK, ALREADY THERE
SPRINT <PPN?>
MOVE A,[SGPPNN] ;DEFAULT PPN
JSR GGNAM
MOVEM A,SEGPPN
JRST THSFL1 ;NOW HAVE A DEVICE
THSDV: MOVEM A,INTT
MOVE A,[XWD SEGDEV,DEVSEG] ;MOVE LOOKUP SPEC IN
BLT A,SEGNAM+3
>;GLOB
NOGLOB <
SETZM SEGNAM+2
MOVE TEMP,[SGPPNN]
MOVEM TEMP,SEGNAM+3 ;SET UP PPN
HLLZS SEGNAM+1
>;NOGLOB
COMMENT ⊗ Now work is nearly done in EXPO system, but all sorts of hair
remains otherwise. In either case, now get segment in, get it into 2d
segment, name it right
⊗
NOEXPO <
INIT 1,17
INTT: SGDEVC ;GO GET THE RAW SEGMENT
0
JSP A,ERSEG
LOOKUP 1,SEGNAM
JSP A,ERSEG
MOVS A,SEGNAM+3 ;WORD COUNT
HRLM A,LIOD ;WORD COUNT FOR DUMP MODE.
MOVNS A
HRRO D,JOBREL ;FOR LATER
HRRM D,LIOD ;PLACE TO START DUMP MODE INPUT.
ADD A,JOBREL ;TO GET THE AMOUNT OF CORE NEEDED.
CALLI A,11 ;CORE UUO ----
JSP A,ERSEG
LOP22: INPUT 1,[LIOD: 0
0]
GLOB <
TLZ D,-1 ;NO, MAKE IT WRITEABLE IF GLOBAL MODEL.
>;GLOB
IFN NOPROT,<
TLZ D,-1 ;MAKE WRITEABLE IF REQUESTED TO
>;NOPROT≠0
CALL D,[SIXBIT/REMAP/] ;
JSP A,ERSEG
NOGLOB <
MOVE A,[FILXXX]
>;NOGLOB
GLOB <
MOVE A,NMSAV
>;GLOB
CALLI A,400036 ;SETNM2
JRST [MOVEI A,0
CALLI A,400015 ;CORE2
JSP A,ERSEG
GLOB <
SETOM %RENSW ;FORCE TTY RITUAL
>;GLOB
JRST SEGTR] ;TRY AGAIN.
CALLI
>;NOEXPO
EXPO <
SETZM SEGNAM+4 ;CLEAR LAST TWO WORDS OF GETSEG BLOCK
SETZM SEGNAM+5
MOVEI A,DEVSEG ;GET READY
MOVEM P,SAVPP
CALL6 (A,GETSEG) ;GET THE SEGMENT
JSP A,ERSEG ; COULDN'T
MOVE P,SAVPP
; NO WAY TO RENAME 2D SEGMENT, SO DON'T WORRY ABOUT IT
>;EXPO
JRST (P) ;RETURN
>;LOW
EXPO <
NOUP <
INTERNAL TYPER.,ERRMSG
;THESE ARE BECUSE OF LIB40 CHANGES
; MADE CAPRICIOUSLY BY DEC
TYPER.:
ERRMSG:
JFCL
ERR <SOME FORTRAN ROUTINE HAS SEEN FIT TO COMPLAIN
ABOUT YOUR STYLE. COMPLAIN TO DEC THAT THEIR ERROR MESSAGE
PROCEDURE IS NOT SUFFICIENTLY GENERAL TO ALLOW GRACEFUL INTERFACE
WITH SAIL.>
>;NOUP
>;EXPO
SUBTTL Segment-Fetching Data
LOW <
NMSAV: 0 ;SAVE LOGICAL SEGMENT NAME HERE
SEGDEV: 0 ;SAVE UPPER SEGMENT DEVICE NAME HERE
SEGFIL: 0 ;SAVE UPPER SEGMENT FILE NAME HERE
NOEXPO <
SIXBIT /SEG/ ;ALWAYS
>;NOEXPO
EXPO <
SIXBIT /SHR/ ;DIFFERENT STROKES FOR ....
>;EXPO
0
SEGPPN: 0 ;SAVE UPPER SEGMENT PPN HERE
DEVSEG: SGDEVC ;USED ONLY BY EXPO'S GETSEG
SEGNAM: FILXXX
NOEXPO <
SIXBIT/SEG/
>;NOEXPO
EXPO <
SIXBIT /SHR/
>;EXPO
0
SGPPNN ;SPECIFIED PPN DEFAULT
EXPO <
0 ↔0 ;SIX WORD BLOCK FOR GETSEG
SAVPP: 0 ;P SAVED HERE OVER GETSEG
>;EXPO
ERSEG: SPRINT <SAIL SEGMENT LOADING ERROR
>
GLOB<
SETOM %RENSW ;FORCE TTY RITUAL
>;GLOB
CALLI 12
GLOB <
GGNAM: 0
TTCALL 4,C ;INCHWL.
CAIE C,15 ;IF NOTHING SPECIFIED,
MOVEI A,0 ; USE THE DEFAULT
SKIPA B,[POINT 6,A]
GGGO: TTCALL C ;GET CHAR
CAIN C,15
JRST [TTCALL C ↔ JRST @GGNAM] ;RETURN ON CR.
CAILE C,140
SUBI C,40 ;CONVERT LOWER CASE.
SUBI C,40 ; → SIXBIT
IDPB C,B ;SAVE IT.
JRST GGGO
>;GLOB
>;LOW
ENDCOM(LOR)
LOW <
END
>;LOW
COMPIL(LUP,<%UUOLNK,%ALLOC,SAVE,RESTR,STACSV,STACRS,INSET,USERERR>
,<CORGET,STCLER,GOGTAB,CONFIG,%ALLCHR>
,<INITIALIZATION ROUTINES, UUO HANDLER, UTILITY ROUTINES>)
IFE ALWAYS,<
INTERNAL %ALLOC
; MORE EXTERNALS
EXTERNAL ALLPDP,ERRSPC,SETLET,DPYSW,INILNK
EXTERNAL SPLNEK,%OCTRET
EXTERNAL .ERSTR,.ERSTP,.ERRP.,.ERRJ.
EXTERNAL X11,X22,X44,CORINC,%STDLS,%SPL,KTLNK
EXPO <
EXTERNAL PPMAX
>;EXPO
>;IFE ALWAYS
NOLOW < ;PUT IN UPPER SEGMENT AND ALL THAT FOLLOWS....
UP <
;IF YOU CHANGE ANYTHING ABOVE THIS POINT, YOU WILL
;HAVE TO RELOAD. THIS IS THE UPPER SEGMENT DISPATCH TABLE FOR
;INTERNAL SYMBOLS.
USE DSPCH ;A PC FOR VECTOR JRSTS
USE
BLOCK =200 ;SPACE FOR THE JRSTS.
>;UP
SUBTTL %ALLOC -- Main Allocation Routine
DSCR %ALLOC
CAL JSP 16,%ALLOC
DES Processes space reqests, allocates the storage for stacks,
string space, etc. Sets certain universal environmental variables
The SPLNEK list, created by the LOADER from compiled requests, contains
REQUEST blocks. Space requests begin at location $SPREQ within each
block. The entries consist of two-word entries, viz:
-----------------------------
→- SPLNEK ptr -→ | | →next block | --→
-----------------------------
| |
| fixed LEAP allocation |
| data |
| |
| ... |
-----------------------------
$SPREQ: |OP1 |INDX | SIZe request |
|- - - - - - - - - - - - - - -|
| TEXt addr | RESult ADdRess| (if ¬STDSPC --
----------------------------- see below)
|OP2 ... | etc. |
-----------------------------
| ... more ops ... |
-----------------------------
| 0 terminates |
-----------------------------
OP is a 12-bit field (0:11), whose bits are interpreted as:
0 STDSPC if 1, get TEX,RESADR spec from standard entry
indexed by INDX field -- this is only a 1-word wntry.
1 WNTADR requests that the address of the allocated core be
returned in the specified RESADR field. RESADR is
then incremented.
2 WNTEND requests that the address of the first word not in the
allocated area be placed in RESADR field. RESADR bumped.
3 WNTPDP requests that a PDP computed from address and length be
returned in like manner.
4 USRTB indicates that the RESADRs are indices into the user
table -- (GOGTAB) should be added before use.
5 MINSZ indicates that the size specified here should be REPLACED
by the first subsequent non-zero request (not ADDED).
Default value for this area -- anything overrides.
INDX is a 6-bit field (12:17) used if STDSPC to cause the address to be
obtained from a spec (with its own OP and addr words) built into GOGOL.
This allows push-down list, string space, etc., sizes to be requested by
object modules without knowing the locations of their descriptors.
The indices represent:
1 SYSPD System push-down list (P)
2 SYSSPD String push-down list (SP)
3 STRSP String space size.
SIZ replaces any previous request with MINSZ on. Otherwise, its value is
added to an accumulated size for this address. The final result will
specify the size of the area.
SIZ<0 causes current entry to be disregarded.
TEX is the address of an ASCIZ string describing the use of the area.
It is used when the user REENTERs to ask him how much space he wants.
A non-zero value means that no overriding is possible for this area.
These requests are accumulated on the stack in two-word entries as:
-----------------------------
$SPREQ: |OP1 |INDX | RESult ADdRess|
|- - - - - - - - - - - - - - -|
| TEXt addr | accum size |
-----------------------------
Inconsistencies in request bits are not likely to be detected.
%ALLOC first processes the entire list, collecting cumulative information
about each RESADR requested, summing the size requests (with mods as
described for MINSZ above). Then it allocates space for each requested
area, allowing the user to override each if he REENTERed, and if there
is TEXt for that area. It finishes by performing some useful but
uninteresting bookkeeping.
⊗
; Get a Stack to hold requests in
HERE (%ALLOC)
MOVEI C,MINPDS ;ABOUT 64 WORDS
PUSHJ P,CORGET ;THIS USUALLY INITS THE USER TABLE
ERR <NO CORE FOR ALLOCATION>
PUSHJ P,PDPMAK ;A PUSH-DOWN POINTER
MOVE P,B ;DITCH THE ALLOC PDL
MOVEM B,PDL(USER) ;STORE TEMPORARILY
PUSH P,16 ;THE RETURN ADDRESS
ADD P,X22 ;ONE DUMMY ENTRY TO TERMINATE
SETZM -1(P) ;0 TERMINATES IT
; Loop to search the space request blocks
; Until further notice:
; T is →next allocation block.
; T1 is →next entry specification
; Q1 is modified T1 -- accounts for STDSPC specifications
; Q2 is incoming OP-size word
; A is →next candidate stack list element
; Q3 and TEMP used to do RESADR search in already-requested stack list
MOVE T,SPLNEK ;LIST OF BLOCKS
MOVEM T,%SPL ;LINK BUILT-IN BLOCK EXPLICITLY
MOVEI T,%SPL ;ALLOCATE IT FIRST
%AL1: MOVEI T1,$SPREQ(T) ;→FIRST REQUEST
%AL2: SKIPN Q2,(T1) ;OP WORD
JRST NXTELT ;NO MORE THIS BLOCK
MOVE Q1,T1 ;SAVE ADDRESS OF REQUEST
TLNN Q2,STDSPC ;A BUILT-IN RESADR/TEXT?
AOJA T1,DRCT ; NO, GET IT HERE
; T1 incremented because 2-word entry -- Q1 still → 1st word
; Here, there is only a 1-word entry -- the actual RESADR spec
; found by indexing into table.
LDB Q1,[POINT 6,Q2,17] ;THE INDEX
LSH Q1,1 ;2-WORD ENTRIES ALL
ADDI Q1,%STDLST ;HERE'S WHERE THEY LIVE
HLL Q2,(Q1) ;USE STANDARD BITS FROM HERE ON
TLZ Q2,MINSZ ;NEVER USED FOR MIN WHEN BY INDEX
; Now find the corresponding entry in the accumulated stack entries
; or add a new entry
DRCT: HRRZ Q3,1(Q1) ;ADDRESS OF RESULT
TLZE Q2,USRTB ;RESULT IN THE USER TABLE?
ADD Q3,GOGTAB ;YES
MOVEI A,-1(P) ;FOR SEARCH DOWN STACK
JRST %AL4 ;GO SEARCH
%AL3: CAIN Q3,(TEMP) ;SAME ADDR?
JRST %AL5 ;YES, UPDATE
SUBI A,2 ;BACK UP ONE
%AL4: SKIPE TEMP,(A) ;NEXT SAVED OP WORD
JRST %AL3 ;TRY THIS ONE
; First occurrence of this address, make a place for it
MOVEI A,1(P) ;BACK TO THE TOP
ADD P,X22 ;NEW ENTRY
SETZM (A)
SETZM 1(A) ;VIRGIN ENTRY
COMMENT ⊗
NMIN means MINSZ on in new spec, OMIN means it's on in stack spec
NSIZ mean that new size≠0, OSIZ etc. -- then
NMIN∧¬OSIZ ⊃⊃ OSIZ←NSIZ, OMIN←TRUE
NMIN∧ OSIZ ⊃⊃ no change
¬NMIN∧NSIZ∧OMIN ⊃⊃ OSIZ←NSIZ, OMIN←FALSE
¬NMIN∧¬NSIZ∧OMIN ⊃⊃ no change
¬NMIN∧¬OMIN ⊃⊃ OSIZ←NSIZ+OSIZ, OMIN←FALSE
In the sequel,
A→current stack entry, T,T1,Q1 unchanged,
Q2 is NEWSIZ, will be accum SIZ and TEXt addr.
Q3 is NEWBITS,,RESADR, will be accumulated same.
TEMP will be old TEX,,SIZ word, LPSA old BITS,,ADR
⊗
%AL5: HLL Q3,Q2 ;NEW BITS,,RESADR
HRRES Q2 ;NEW SIZE
MOVE TEMP,1(A) ;OLD TEX,,SIZ
MOVE LPSA,(A) ;OLD BITS,,ADR
JUMPL Q2,AOJBAK ;NO ACTION ON NEGATIVE SIZE
TLNE Q3,MINSZ ;BEGIN THE HAIRY CASE STUDY
JRST INMIN ;MIN ON IN NEW
; ¬NMIN
TLZN LPSA,MINSZ ;¬NMIN, OMIN? -- OMIN←FALSE
JRST ADDIT ;¬NMIN∧¬OMIN, ADD
JUMPN Q2,%AL6 ;¬NMIN∧ OMIN, NSIZ?
TLOA Q3,MINSZ ;¬NMIN∧ OMIN∧¬NSIZ, NMIN←TRUE, NSIZ+OSIZ=OSIZ
%AL6: HLLZS TEMP ;¬NMIN∧OMIN∧NSIZ, OSIZ←FALSE,NSIZ+OSIZ=NSIZ,NMIN←FALSE
JRST ADDIT ;¬NMIN∧ OMIN, EITHER NSIZ OR OSIZ
; NMIN
INMIN: TRNE TEMP,-1 ;OSIZ?
TLZA Q3,MINSZ ;NMIN∧OSIZ, OSIZ unchg, NMIN←FALSE
TLZA LPSA,MINSZ ;NMIN∧¬OSIZ, OSIZ←NSIZ, NMIN←TRUE
MOVEI Q2,0 ;NMIN∧OSIZ again, OSIZ unchg over add
ADDIT: OR Q3,LPSA ;COLLECT BITS
ADD Q2,TEMP ;AND SIZE
TLNN Q2,-1 ;ANY TEXT ADDR?
HLL Q2,1(Q1) ;NO, GET FROM OLD IF ANY
MOVEM Q3,(A) ;PUT NEW AWAY
MOVEM Q2,1(A)
AOJBAK: AOJA T1,%AL2 ;NEXT ELEMENT THIS BLOCK
NXTELT: SKIPN T,(T) ;NEXT BLOCK IN ALLOC LIST?
JRST NOELT ;NO MORE.
LEP <
;; %AG% ↓ LEAPIS USED TO BE STORED IN $ITNO
SKIPL $GITNO(T) ;LEAP REQUESTED?
JRST %AL1 ;NO.
MOVE B,GOGTAB ;WILL PLAY WITH USER TABLE
SETOM HASMSK(B) ;SOMEONE WANTS LEAP.
>;LEP
JRST %AL1 ;CONTINUE DOWN ALLOC BLOCKS.
NOELT:
; SINCE SYSTEM_PDL ALREADY ALLOCATED AND IN USE, INCREMENT IT IF THE
; REQUEST EXCEEDS THE DEFAULT
MOVE TEMP,PDL(USER)
PUSH P,4(TEMP)
PUSH P,5(TEMP) ;MAKE SURE P-REQUEST ON TOP
SETZM 4(TEMP) ;AND THAT IT DOESN'T HAPPEN TWICE
; NOW ALLOCATE THE SPACES, GET OVERRIDES
SETZM %ALLCHR ;NO QUESTIONS YET
SKIPN %RENSW ;WAS THERE A REENTER?
JRST NONTR ; NO
TERPRI
PRINT <ALLOC? >
PUUO 0,B ;ASK LEADING QUESTION AND GET ANSWER
TERPRI
;; %AD% RHT ALLOW LOWER CASE 10/4/73
TRZ B,40 ; SO CAN USE LOWER CASE
CAIN B,"Y" ;YES?
SETOM %ALLCHR ;YES
CAIN B,"N" ;NO, BUT LET ME SEE IT?
AOS %ALLCHR ;RIGHT
SETZM %OCTRET ;WHEN ON, NO MORE ASKING
NONTR:
ALOC: SKIPN T,-1(P) ;WERE THERE ANY ENTRIES?
JRST DONEE ; MAYBE, BUT NONE LEFT
MOVS A,(P) ;SIZE, TEXT
TRNE A,-1
SKIPL %ALLCHR ;IF TEXT ADDR AND WANTS TO DO IT,
JRST NOASK ; MUST ASK QUESTIONS
PUUO 3,(A) ;PRINT IT
PRINT <= >
PUSHJ P,DECIN
HRL A,C ;REPLACE REQUESTED SIZE BY OVERRIDE
NOASK: HLRZ C,A ;IN CASE NOBODY ELSE DID
JUMPE C,PRIN ;DON'T ALLOCATE 0 AREAS
HRRZ TEMP,T ;DEST ADDR
CAIE TEMP,PDL(USER) ;THE ONE AND ONLY?
JRST NOEXP ; NO
;THIS IS THE SYSTEM_PDL REQUEST -- IT MUST OVERLAY THE CURRENTLY
; ALLOCATED STACK
HRRZ B,PDL(USER) ;GET PREV INITIAL CORGET ADDRESS
CAIGE C,MINPDS ;MUST BE BIGGER
MOVEI C,MINPDS ; SO MAKE IT BIGGER
HRL A,C ;KEEP EVERYBODY UP TO DATE
ADDI B,1 ;CORGET ADDR
CAIG C,MINPDS
JRST PDPRET ;NO PROBLEM
SUBI C,MINPDS ;AMOUNT TO INCREASE BY
;;# # 4-28-72 DCS UPDATE P'S SIZE FIELD
HRLZ TEMP,C ;UPDATE P RIGHT NOW
SUB P,TEMP ;SIZE FIELD ONLY
;;# # 4-28
PUSHJ P,CORINC ;INCREMENT TO PROPER SIZE
ERR <DRYROT -- NO CORE FOR SYSTEM_PDL>
ADDI C,MINPDS ;TOTAL SIZE
JRST PDPRET
NOEXP: PUSHJ P,CORGET ;GET A BLOCK
ERR <NO CORE AT ALLOCATION>
PDPRET: TLNN T,WNTADR ;WANT THE ADDRESS STORED?
JRST .+3
MOVEM B,(T) ;YES, STORE IT
ADDI T,1
TLNN T,WNTEND
JRST NOND
MOVE D,C ;SIZE
ADD D,B ;END ADDR
MOVEM D,(T)
ADDI T,1
NOND: PUSHJ P,PDPMAK
TLNE T,WNTPDP
MOVEM B,(T) ;WANTS PDP
PRIN: SKIPN %ALLCHR ;ARE WE BLABBING?
JRST SUBJMP ;NOPE
PUUO 3,(A)
PRINT <: >
HLRZ C,A ;SIZE AGAIN
DECPNT C ;TOTAL ALLOC FOR THIS ONE
TERPRI
SUBJMP: SUB P,X22 ;SO MUCH FOR THAT ONE
JRST ALOC ;GET THE NEXT
DONEE: SKIPN %ALLCHR ;BLABBING?
JRST .+3 ; NO
TERPRI↔TERPRI
SUB P,X44 ;→RETURN ADDRESS (DUMMY AND SYSPDL ENTRIES)
; FINAL BOOKKEEPING
SETZM %RENSW ;DON'T ASK EACH TIME
MOVE SP,SPDL(USER) ;STRING STACK POINTER
MOVE B,ST(USER) ;STRING SPACE BEGINNING
MOVN C,-1(B) ;SIZE
SUBI C,3 ;MINUS OVERHEAD
MOVEM C,STMAX(USER) ;SIZE OF STRING SPACE DATA
HRLI B,(<POINT 7,0>)
MOVEM B,TOPBYTE(USER) ;NEXT FREE BYTE
IMUL C,[-5] ;NUMBER OF FREE CHARS
;;#GI# DCS 2-2-72 (1-3) MAKE CAT BETTER -- THIS LEAVES SOME ROOM
ADDI C,=15 ;LEAVE SOME SLOP FOR INSET, ETC.
;;#GI# (1-3)
MOVEM C,REMCHR(USER)
SKIPE CONFIG ;COMPILER?
SETOM SGLIGN(USER) ; YES, STRNGC AND FRIENDS MUST ALIGN STRINGS
HRROI TEMP,KTLNK
POP TEMP,KNTLNK(USER)
POP TEMP,SGROUT(USER)
POP TEMP,SETLNK(USER)
POP TEMP,SPLNK(USER)
POP TEMP,STRLNK(USER);TRANSFER LISTS TO USER TABLE
PUSHJ P,STCLER ;CLEAR OUT ALL STRINGS
MOVEI TEMP,7 ;INITIAL DIGS SETTING
MOVEM TEMP,DIGS(USER) ;FOR FLOATING POINT OUTPUT
MOVEI TEMP,CHANS(USER);IF CHNL HAS A VALID CHANNEL #,
HRLI TEMP,CHNL ; @CDBLOC(USER) REFERS TO ITS
MOVEM TEMP,CDBLOC(USER);CDB ADDR IN THE CHANS TABLE
NOEXPO <
MOVNI TEMP,1 ;FIND OUT IF ON A DPY
TTCALL 6,TEMP
MOVEM TEMP,DPYSW ;NEG IF DPY
>;NOEXPO
;;#HE# DCS 5-11-72 (2-2) MODIFY VERSION CHECKING, STORAGE METHODS
IFNDEF JOBVER,<EXTERNAL JOBVER>
MOVEI LPSA,SPLNEK ;For each element of the space
CHKVRS: SKIPN LPSA,(LPSA) ; list, if there is a non-zero
POPJ P, ; version request, use it (lh is
SKIPN TEMP,$VRNO(LPSA); SAIL version, rh is user version).
JRST CHKVRS ;But if there was a previous non-zero
HLL TEMP,JOBVER ; request, and if it is not the
EXCH TEMP,JOBVER ; same as this one, complain first.
TRNE TEMP,-1
CAMN TEMP,JOBVER
JRST CHKVRS
ERR <VERSION NUMBER MISMATCH>,1
JRST CHKVRS
;;#HE# (2-2)
PDPMAK: MOVNS C
SUBI B,1 ;PDP
HRL B,C
POPJ P,
>;NOLOW
COMMENT ⊗ Utility Subroutines for allocation
⊗
DECIN:
OCTIN: AOS (P)
SKIPE %OCTRET ;IMMEDIATE RETURN?
POPJ P, ; YES
SETZB C,D
OCTIN1: PUUO 0,B
CAIN B,177 ;RUBOUT?
JRST RUB ;AYE, THERE'S THE RUB
CAIN B,"U"-100 ;↑U?
JRST CTRLU ;INDEED
CAIN B,175 ;ALTMODE?
JRST SETRET
CAIN B,12 ;LINE FEED?
JRST EPOP ;YES
CAIL B,"0"
CAILE B,"9" ;I KNOW IT'S CALLED OCTIN,
JRST OCTIN1 ; BUT INPUT IS IN DECIMAL!!
SETOM D ;FOUND SOMETHING LIKE A NUMBER
IMULI C,=10 ;GOOD OLD NUMBER CONVERSION
ADDI C,-"0"(B)
JRST OCTIN1 ;THIS IS A LOOP
SETRET: SETOM %OCTRET ;WILL RETURN IMMEDIATELY HENCEFORTH
TERPRI
EPOP: SKIPE D ;FIND ANYTHING?
SOS (P) ;YES
CPOPJ: POPJ P,
RUB:
CTRLU: PUUO 3,[BYTE (7) "↑","U",15,12] ;WON'T THE USER BE
JRST OCTIN ;START OVER
SUBTTL %UUOLNK -- UUO Handler (Dispatch Vector Just Below)
NOLOW < ;INCLUDE IN UPPER SEGMENT.....
HERE(%UUOLNK)
UUOCON: PUSH P,FF ;SAVE REGISTER 0
PUSH P,A ;AND REGISTER 1
MOVE FF,@JOBUUO ;ARGUMENT BEFORE CLOBBERING AC'S
LDB A,[POINT 9,JOBUUO,8] ;GET OP CODE.
; TRNE A,777760 ;SEE IF IN RANGE
; JRST ILLUUO ;ILLEGAL
JRST @UUOTBL(A) ;DISPATCH TO CORRECT ROUTINE.
RETM: POP P,D ;RESTORE SAVED AC'S
POP P,C
POP P,B
USRXIT: POP P,A
POP P,FF ;RESTORED AC'S
POPJ P, ;AND RETURN!
SAVM: PUSH P,B ;SAVE AC'S -- CALLED WITH JSP 0
PUSH P,C
PUSH P,D ;ENUF
PUSH P,[RETM]
JRST @FF ;RETURN
; UUO TABLE
UUOTBL: JRST ILLUUO ;0
JRST ILLUUO ;1
JRST FLOAQ ;2 -- FLOAT A NUMBER
JRST FIXQ ;3 -- FIX A NUMBER
JRST IOERRR ;4 -- I/O ERROR
JRST ERRR ;5 -- STANDARD ERROR UUO
JRST PSIXQ ;6 -- SIXBIT PRINT
JRST ARERRR ;7 -- ARRAY ERROR
JRST ILLUUO ;10
JRST DECPNQ ;11 -- PRINT DECIMAL NUMBER
JRST OCTPNQ ;12 -- PRINT OCTAL NUMBER
JRST ILLUUO ;13
JRST ILLUUO ;14
JRST PRINIT ;15 -- HANDLE TERMINAL
HERE($PDLOV) ;PLACE TO COME WHEN A STACK
MOVEI TEMP,TEMP ;IS EXHAUSTED.
POP P,TEMP ;THIS WILL CAUSE PDLOV
JRST (USER) ;RETURN IF USER CAN.
DSCR OCTPNT, DECPNT UUO'S
PAR MOVE FF,ARG; JRST OCTPNQ -- RET VIA USRXIT
OR MOVE A,ARG; PUSHJ P,OCTO
RES DECPNT -- WORD TYPED IN DECIMAL
OCTPNT -- OCTAL
⊗
OCTPNQ: MOVE A,FF ;GET ARGUMENT
JSP FF,SAVM ;SAVE MORE AC'S
OCTO: SKIPA C,[PUUO 1,B]
OCTOB: MOVE C,[IDPB B,.ERSTP]
MOVEI FF,10 ;KEEP RADIX IN FF.
JRST PNT
DECPNQ: MOVE A,FF ;GET ARGUMENT
JSP FF,SAVM
DECO: SKIPA C,[PUUO 1,B]
DECOB: MOVE C,[IDPB B,.ERSTP]
MOVEI FF,=10
JUMPGE A,PNT ; GREATER 0.
MOVEI B,"-"
XCT C
MOVMS A ; FOO1 ← ABS(FOO1) ;
PNT: IDIV A,FF ;FAMOUS DEC RECURSIVE NUMBER PRINTER.
IORI B,"0"
HRLM B,(P)
SKIPE A
PUSHJ P,PNT
HLRZ B,(P)
XCT C ;EITHER PRINT IT OR STORE IT
POPJ P, ;RETURN TO RETM
DSCR FIX, FLOAT UUO'S (FIXQ,FLOAQ)
PAR MOVE FF,ARG ; JRST FIX/FLOA Q; RET VIA USRXIT
RES FIXED POINT EQUIVALENT IN AC SPECIFIED IN AC FIELD OF UUO
⊗
FIXQ: MULI FF,400 ;THIS ALGORITHM STOLEN FROM F4.
TSC FF,FF
EXCH FF,A
ASH FF,-243(A)
JRST FXFLT ;STORE IN RIGHT PLACE.
FLOAQ: IDIVI FF,400000
SKIPE FF
TLC FF,254000
TLC A,233000
FAD FF,A
FXFLT: LDB A,[POINT 4,JOBUUO,12] ;RESULT REGISTER
CAIG A,1 ;NUMBER OF AC'S SAVED
ADDI A,-1(P) ;ADJUST TO FIND STACK SPOT
MOVEM FF,(A) ;AND RETURN RESULT
JRST USRXIT ;AND RETURN TO USER
DSCR PRINIT -- INTERFACE TO SYSTEM PRINTING FACILITIES
INCLUDED HERE TO MAKE INTERCEPTION EASY FOR WHATEVER
PURPOSE AND TO MAKE CONVERSION TO TENEX EASY
⊗
IFN 0,<
PRINIT: MOVE A,FF ;SAVE ARGUMENT
JSP FF,SAVM ;GET MORE AC'S
LDB C,[POINT 4,JOBUUO,12]
JRST @PTBL(C)
PTBL: GCH ;0 -- GET A CHAR
PCH ;1 -- PRINT A CHAR
0
PST ;3 -- PRINT A STRING
PST: TTCALL 3,@JOBUUO ;CALL SYSTEM
POPJ P,
PCH: TTCALL 1,A ;PRINT CHAR
POPJ P,
GCH: HRRZ B,JOBUUO ;GET EFF ADDRESS
CAIG B,D
ADDI B,-5(P) ;RELOCATE INTO STACK.
TTCALL 0,(B) ;AND READ A CHAR
POPJ P,
;> PRINIT: ;FALL INTO ILLUUO
DSCR ERROR UUOS
PAR AC FIELD IS INDEX INTO ERROR ROUTINE
SID SAVES THE WORLD
DES THE ASCIZ STRING INDICATED BY THE EFFECTIVE ADDRESS IS TYPED. THEN
THE ERROR ROUTINE INDICATED BY THE AC FIELD IS EXECUTED.
IF `GO' IS NOT ON, THE USER IS ALLOWED TO RESPOND WITH ONE OF SEVERAL
ALTERNATIVES. ONE ALTERNATIVE IS CONTINUATION IF THE AC FIELD OF THE
UUO WAS ODD. OTHERWISE, NO CONTINUATION IS POSSIBLE. THE ACS AT THE
TIME OF CALL ARE RESTORED IF CONTINUATION OR `DDT' IS CHOSEN.
⊗
ILLUUO: MOVE A,[ERR <Illegal UUO>]
MOVEM A,JOBUUO
ERRR: JSP FF,SAVM ;SAVE MORE AC'S
LDB B,[POINT 4,JOBUUO,12] ;CODE IN AC FIELD
JRST ERRW
ARERRR: JSP FF,SAVM ;SAVE MORE AC'S
MOVSI D,4 ;PRINTING INSTRUCTIONS
MOVEI B,20 ;ERROR CODE -- FATAL
JRST ERRX
IOERRR: JSP FF,SAVM ;SAVE MORE AC'S
MOVEI B,16 ;ERROR CODE -- FATAL
ERRW: MOVEI D,0
ERRX: ROT B,-1 ;CONTINUE BIT TO SIGN BIT
MOVEM B,%RECOV ;AND SAVE FOR TESTING LATER
MOVE C,[POINT 7,.ERSTR] ;POINTER TO ERROR STRING.
MOVEM C,.ERSTP
MOVEI A,[BYTE(7) 15,12,0]
PUSHJ P,PRA ;BEGIN EACH ERROR MESSAGE WITH CRLF.
MOVE A,JOBUUO ;GET UUO BACK
TLZN D,4 ;DO NOT PRINT EFF ADDR OF ARRAY UUO
PUSHJ P,PRA ;PRINT ACSIZ STRING INTO ERSTR
MOVE A,JOBUUO
PUSHJ P,@URTBL(B) ;AND DO SPECIAL-CASE STUFF
MOVEI A,[BYTE(7) 15,12,0]
PUSHJ P,PRA ;TERMINATE WITH CRLF
IDPB FF,.ERSTP ;AND A ZERO.
SKIPN D,.ERRP. ;DOES USER HAVE A ROUTINE?
JRST NOUSRR ;NO
MOVEI FF,15
PUSH P,@FF ;SAVE AC'S SLOWLY
CAIE FF,D+1 ;AND CAUSE PDLOV IF NEEDED
SOJA FF,.-2
MOVE USER,GOGTAB
MOVE C,[XWD -13,RACS] ;ALSO SAVE RUNTIME AC'S
ADDI C,(USER) ;RELOCATE
PUSH P,(C)
AOBJN C,.-1
PUSH P,UUO1(USER) ;SAVE RUNTIME RETURN ADDRESS
SETZM .ERRJ. ;ASSUME NO USER TRANSFER ADDRESS
MOVE A,-33(P) ;UUO RETURN ADDRESS
SUBI A,1
PUSH P,SP ;SAVE STRING STACK POINTER (OR,
;IF COMPILER, MAYBE PARSER STACK)
SKIPL CONFIG ;IF IN COMPILER, GENERATE
JRST .+4
MOVEI SP,(P) ;A FAKE STACK BECAUSE OF CONFLICT
HRLI SP,-5 ;WITH PARSE STACK
ADD P,X44
PUSH P,A ;ADDR OF UUO = ARG TO PROC.
HRRZ A,.ERSTP ;NOW COMPUTE LENGTH OF STRING
SUBI A,.ERSTR ;SAVED AWAY
IMULI A,5
LDB B,[POINT 6,.ERSTP,5]
IDIVI B,7
MOVNS B
ADDI A,4(B) ;TOTAL NUMBER OF CHARACTERS (NOT INCL NULL)
PUSH SP,A ;TO STRING STACK.
PUSH SP,[POINT 7,.ERSTR]
SKIPN A,%ERRC ;TRACKS LEFT BY USERRR??
MOVEI A,[0 ↔ 0] ;NO
PUSH SP,(A)
PUSH SP,1(A)
PUSHJ P,@.ERRP.
SKIPGE CONFIG ;IF IN COMPILER, THEN
SUB P,X44 ;BACK UP THE STACK.
POP P,SP ;RESTORE STRING STACK.
MOVE USER,GOGTAB
POP P,UUO1(USER) ;RESTORE THINGS
MOVEI B,12
MOVEI C,RACS+12(USER)
POP P,(C)
SOS C
SOJGE B,.-2 ;TILL DONE
MOVEI FF,D+1
POP P,@FF
CAIE FF,15
AOJA FF,.-2 ;LOOP UNTIL ALL RESTORED.
MOVEM A,D ;SAVE PRINTING INSTRUCTIONS
SKIPE B,.ERRJ. ;IF USER SPECIFIED RETURN ADDRESS
MOVEM B,-6(P) ;REPLACE CURRENT ONE.
NOUSRR: SKIPE A,%ERRC ;IF USERRR LEFT A POINTER
ILDB D,1(A) ;THEN BY ALL MEANS USE CHAR!
SETZM %ERRC ;NO MORE USERRR SPEC.
TLZN D,1 ;IF NOT INHIBITED,
PUUO 3,.ERSTR ;PRINT ERROR STRING.
MOVE A,-6(P) ;RETURN ADDRESS
TLZN D,2 ;IF NOT INHIBITED,
PUSHJ P,CALLEDFROM ;PRINT SAIL MESSAGE
PUSHJ P,WATNOW ;GO GET A RESPONSE.
MOVEM A,-6(P) ;REPLACE RETURN ADDRESS
POPJ P,
DSCR CALLEDFROM -- PRINTS 'CALLED FROM' XXX 'LAST SAIL CALL AT'
PAR WHERE XXX+1 IS PRESENTED IN AC A.
RES -- ONLY TYPING
SID DESTROYS A,B,C
⊗
CALLEDFROM:
PRINT <Called from >
MOVEI A,-1(A)
PUSHJ P,OCTO ;PRINT IT IN OCTAL
SKIPGE CONFIG ;RUNTIMES
JRST NOLSCL
PRINT < Last SAIL call at >
MOVE A,GOGTAB
HRRZ A,UUO1(A)
SOS A
PUSHJ P,OCTO
NOLSCL: TERPRI
POPJ P, ;END OF CALLEDFROM ROUTINE.
DSCR WATNOW -- ROUTINE TO GET AND PROCESS USER RESPONSES.
PAR RECOV IS >0 IF RECOVERY IMPOSSIBLE, <0 IF RECOVERY POSSIBLE
D,IF NON ZERO, HAS A RESPONSE CHARACTER IN IT.
RES RETURNS TO CALLER+1 IF TO GO TO DDT OR EXIT. IN THIS
CASE, AC 'A' HAS A NEW RETURN ADDRESS
RETURNS TO CALLER+2 IF USER SAID 'CONTINUE'
SID CLOBBERS FF,A
⊗
WATNOW: MOVE A,GOGTAB ;ADDRESS OF USER TABLE
HRRZ FF,TOPBYTE(A) ;CURRENT STRING POINTER
CAMLE FF,STTOP(A) ;IN RANGE?
JRST [TERPRI <String space exhausted unexpectedly.
Will restart now.>
MOVEI FF,[JRST @JOBREN]
MOVEM FF,-7(P) ;NEW RETURN ADDRESS.
JRST .+1]
SKIPE %ERGO ;CONTINUOUS CONTINUE?
JRST GOTRY ;AUTOMATIC CONTINUE SET
SKIPE A,D ;IF A RESPONSE CHARACTER IS SPECIFIED,
JRST RESGOT ;GO USE IT.
QUES: MOVEI A,"?" ;PRINT ? FOR IRRECOVERABLE ERRORS,
SKIPGE %RECOV ; ↑ FOR RECOVERABLE ONES.
EXPO <
MOVEI A,"↑" ;SOMETHING PRINTABLE.
>;EXPO
NOEXPO <
MOVEI A,"→" ; → FOR RECOVERABLE ONES.
>;NOEXPO
PUUO 1,A ;PRINT IT
PUUO 0,A ;GET RESPONSE CHAR
RESGOT: CAIL A,"a" ;lower case?
SUBI A,40 ;YES, CONVERT TO UPPER
CAIN A,"E" ;RE-EDIT?
JRST EDIT ; YES
CAIN A,"T" ;TVEDIT?
JRST TVEDIT
TTCALL 11,0 ;FLUSH BUFFER
CAIN A,"S" ;START?
JRST STRTIT ;YES
CAIN A,"X" ;EXIT
JRST XIT
CAIN A,"D" ;DDT
JRST DDIT ;.
CAIN A,12 ;CONTINUE AUTOMATISCH?
SETOM %ERGO ;YES
CAILE A,15 ;TRY TO CONTINUE?
JRST BADRSP ;INCORRECT RESPONSE
CAIE A,"α" ;CONTINUE DAMMIT?
GOTRY: SKIPGE %RECOV ;CAN WE CONTINUE?
JRST EPOPJ ;YES -- SKIP RETURN
TERPRI <Can't continue>
JRST QUES
STRTIT: HRRZ A,JOBSA
JRST (A) ;AWAY WE GO!
DDIT: SKIPN JOBDDT
JRST [TERPRI <No DDT>
JRST QUES] ;NO SUCH ANIMAL
SKIPA A,[[JRST @JOBDDT]] ;PREPARE TO CALL DDT
XIT: MOVEI A,[CALL6 (EXIT)] ;PREPARE TO EXIT
POPJ P, ;NON SKIP RETURN.
EPOPJ: AOS (P) ;SKIP RETURN
POPJ P,
BADRSP: TERPRI <Reply [CR] to continue,
[LF] to continue automatically,
"D" for DDT, "E" to edit,
"X" to exit, "S" to restart>
JRST QUES ;GET ANOTHER RESPONSE.
SUBTTL Special Printing Routines For Error Handler
DSCR UUO ERROR MESSAGE ROUTINES AND THEIR INDICES (AC FIELD OF UUO)
SID CLOBBERS A,B,C,D
⊗
↑↑URTBL:UPOPJ ; 0- 1 -- NO ACTION
.PRSM ; 2- 3 -- PRINT SYMBOL PTD TO BY LPSA (SAIL)
PRASC ; 4- 5 -- PRINT SYMBOL PTD TO BY UUO INSTR
ACPRT ; 6- 7 -- PRNT VAL OF AC IN INSTR PRECDNG UUO
UUOPRT ;10-11 -- PRINT THE UUO
AC1PRT ;12-13 -- PRINT AC FIELD ASSUMING RETURN FROM
; CALL IS IN UUO1(GOGTAB)
SIXPRT ;14-15 --PRINT LPSA AS SIXBIT
IOER2 ;16-17 --SECOND HALF OF IOERR
ARER2 ;20-21 --SECOND HALF OF ARRERR
UUOPRT: PUSH P,A ;SAVE UUO
HLRZ A,A
PUSHJ P,OCTOB ;TYPE IT
POP P,A ;RESTORE
HRRZS A
JRST OCTOB ;TYPE IT TOO
DSCR PRSYM -- PRINT SYMBOL NAME
PAR SAIL SEMANTICS BLOCK ADDRESS IN LPSA
RES TYPES $PNAME STRING FROM BLOCK
SID DESTROYS A,B
⊗
$PNAME ←← 1
.PRSM: HRRI A,$PNAME(LPSA) ;→STRING DESCRIPTOR
PRASC: HRRZ B,(A) ;#CHARACTERS
MOVE A,1(A) ;STRING BP
MOVEI C,0 ;NO ADJUSTMENT
MOVE D,[IDPB FF,.ERSTP]
JRST PRSL1
IOER2: TLNN A,740 ;AC FIELD SPECIFIED?
POPJ P, ;NO -- DONE
;ELSE PRINT WHAT IS IN LPSA
SIXPRT: MOVE D,[IDPB FF,.ERSTP]
SKIPA A,[POINT 6,LPSA];GET FROM HERE
PSIX: HRLI A,(<POINT 6,0>) ;UUO ADDR IS ADDR OF SIXBIT
MOVEI C,40 ;ADJUSTMENT
MOVEI B,6 ;PRINT 6 CHARS
JRST PRSL1
PRSL: ILDB FF,A ;CHARACTER
ADDI FF,(C) ;ADJUSTMENT
XCT D ;PUSH TO ERROR STRING OR TYPE IT.
PRSL1: SOJGE B,PRSL
UPOPJ: POPJ P,
AC1PRT: MOVE A,GOGTAB ;GET USER TABLE PTR
SKIPA A,UUO1(A) ;SOMEONE STORED RIGHT THING HERE
ACPRT: HRRZ A,-7(P) ;RETURN ADDRESS
LDB A,[POINT 4,-2(A),12] ;AC # FROM PREV INSTR
CAIG A,D ;IF BIN SAVED AC'S
ADDI A,-6(P) ;RELOCATE
MOVE A,(A) ;PICK UP VALUE.
JRST DECOB ;PRINT IT IN DECIMAL
ARER2: PUSH P,A ;SAVE UUO
MOVEI A,[ASCIZ /Invalid index for array /]
PUSHJ P,PRA ;TO ERROR STRING.
MOVE A,(P) ;GET POINTER TO ARRAY NAME
PUSHJ P,PRASC ;PRINT ARRAY NAME
MOVEI A,[ASCIZ /. Index no. /]
PUSHJ P,PRA
POP P,A ;RESTORE UUO
LDB A,[POINT 4,A,12]
PUSHJ P,DECOB ;PRINT INDEX NUMBER
MOVEI A,[ASCIZ /. Value is /]
PUSHJ P,PRA
JRST ACPRT ;PRINT VALUE IN PRECEDING AC.
PSIXQ: MOVE A,JOBUUO ;UUO
JSP FF,SAVM ;GET STACK AND AC'S
MOVE D,[PUUO 1,FF] ;PRINT DIRECTLY
JRST PSIX ;TYPE IT.
PRA: HRLI A,(<POINT 7,0>) ;PUSH STRING TO ERROR BUFFER
ILDB FF,A
JUMPE FF,UPOPJ ;DONE AT ZZERO BYTE
IDPB FF,.ERSTP
JRST .-3 ;LOOP
DSCR USERERR(VALUE,CODE,"MSG","RESPONSE");
CAL SAIL
⊗
HERE (USERERR)
MOVE USER,GOGTAB
PUSHJ P,INSET ;ALIGN STRING SPACE TO FW BOUNDARY
PUSH SP,[1] ;CONCATENATE A NULL FOR TTCALL
PUSH SP,[POINT 7,[0]]
PUSHJ P,CAT
MOVE TEMP,-3(SP)
EXCH TEMP,-1(SP)
MOVEM TEMP,-3(SP)
MOVE TEMP,-2(SP)
EXCH TEMP,(SP)
MOVE TEMP,-2(SP)
EXCH TEMP,(SP)
MOVEM TEMP,-2(SP)
PUSHJ P,INSET ;ALIGN STRING SPACE TO FW BOUNDARY
PUSH SP,[1] ;CONCATENATE A NULL FOR TTCALL
PUSH SP,[POINT 7,[0]]
PUSHJ P,CAT
MOVEI TEMP,-3(SP) ;ADDRESS OF RESPONSE STRING.
MOVEM TEMP,%ERRC ;SAVE FOR ERROR UUO.
POP P,UUO1(USER)
SKIPG TEMP,(P) ;IS CODE 0?
ERR. @(SP) ;YES, NO CONTINUATION POSSIBLE
CAIN TEMP,1 ;IS CODE 1?
ERR. 1,@(SP) ;YES, JUST PRINT ERROR, ALLOW CONT
CAIGE TEMP,2 ;IS IT SOMETHING ELSE
JRST USERBAK ;NO
MOVE TEMP,-1(P) ;YES, SET UP SO ERR. GUY WILL PRINT VALUE
ERR. 7,@(SP) ; AND DO IT
USERBAK:
SUB SP,X44
SUB P,X22
JRST @UUO1(USER) ;RETURN FROM ROUTINE.
SUBTTL Code to Handle Linkage to Editors
TVEDIT: TDZA 13,13 ;FLAG AS TV
EDIT: MOVNI 13,1
PUSH P,13
SETZB 13,14 ;PREPARE FOR PROVIDING
SETZB 15,16 ;STOPGAP WITH FILE NAME,
SETZB 11,12 ; PAGE AND LINE NUMBERS, SEQUENTIAL LINE #
PUUO 0,B ;SEE IF FILE NAME SPECIFIED
CAIE B,15 ;CR?
JRST GTNAM ; NO, NAME SPECIFIED
PUUO 0,B ;SNARF UP LINE FEED AFTER CR
SKIPL CONFIG ;IF IN THE COMPILER,
JRST GTIT
PUSH P,[0] ;USE SPECIAL CALL TO SET UP AC'S
PUSHJ P,@.ERRP. ;...
JRST GTIT ;GO PROCESS.
GTNAM: CAIE B," " ;DELETE LEADING BLANKS
JRST MKNAMM
PUUO 0,B
JRST GTNAM
MKNAMM: CAIN B,15 ;GO BACK ON CR
JRST AUTO
MOVE C,[POINT 6,13] ;COLLECT FILE NAME HERE
MKNLP: CAIE B," " ;DONE?
CAIN B,15
JRST GTIT1 ; YES
SUBI B,40
CAIN B,"."-40
SKIPA C,[POINT 6,14] ;ADJUST TO GET EXTENSION
IDPB B,C ;CHAR OF FILENAME
PUUO 0,B
JRST MKNLP
GTIT1: CAIN B,15
PUUO 0,B
GTIT: POP P,A ;TV/SOS FLAG
EXCH 13,14 ;EXT IN REG PRECEDING NAME?
;HERE TO RUN ANY PROGRAM, EITHER SOS OR COMPIL.
; REGISTERS HAVE GOODIES IN THEM:
; 13 FILE EXTENSION IN SIXBIT
; 14 FILE NAME IN SIXBIT
; 15 LINE NUMBER IN ASCII.
; 16 PAGE NUMBER (BINARY)
;IF AC 14 IS ZERO, THIS MEANS NO FILE HAS BEEN
; SPECIFIED, AND WE WILL USE "COMPIL" TO REPEAT THE
; LAST EDIT COMMAND (THIS IS NOT A FEATURE ON MOST
; STANDARD DEC SYSTEMS -- SEE R SPROULL)
NOEXPO <
MOVEI P,2
LOAD6 (2,<SYS>) ;ASSUME GET TO EDITOR VIA RPG
LOAD6 (4,<DMP>)
MOVEI 6,0
MOVEI 5,777777 ;TELLS RPG: "EDIT"
LOAD6 (3,<RPG>)
JUMPE 14,SWAPIT
MOVEI 5,1 ;START AT RPG LOC IN EDITOR
LOAD6 (3,<SOS>) ;NOW ASSUME SOS
JUMPL A,SWAPIT ;YES
LOAD6 (3,<TV>) ;NO, TV
MOVE 15,12 ;GET SEQUENTIAL LINE NUMBER
SWAPIT: CALL6 (P,SWAP) ;SEE YOU AROUND
>;NOEXPO
; ELSE FALL INTO EXPO VERSION ....
COMMENT ⊗ EXPORT VERSION OF EDITOR-INTERFACE
PROVIDED BY R. SPROULL, 11-18-70
SEE HIM FOR DETAILS ON DIDDLES TO CCL AND EDIT10
⊗
EXPO <
JUMPN 14,EDITG ;IF FILE, FIRE UP SOS
MOVE P,[XWD -1,[SIXBIT /SYS/
SIXBIT /COMPIL/
0 ↔ 0 ↔ 0 ↔ 0 ]]
CALL6 (P,RUN) ;GO RUN IT.
JRST 4,0
EDITG: PUSHJ P,RPGDSK ;SET UP FOR FILE
MOVE 2,14 ;GET THE FILE
PUSHJ P,SXCON
MOVEI 1,"."
SKIPN 2,13 ;EXTENSION
JRST NOEXT
PUSHJ P,OUT1
HLLZS 2 ;EXTENSION.
PUSHJ P,SXCON
NOEXT: SKIPN 11 ;PROJ,PROG #
JRST NOPPN
MOVEI 1,"["
PUSHJ P,OUT1
HLRZ 1,11
PUSHJ P,OCTQ ;OUTPUT OCTAL
MOVEI 1,","
PUSHJ P,OUT1
HRRZ 1,11
PUSHJ P,OCTQ
MOVEI 1,"]"
PUSHJ P,OUT1
NOPPN: PUSHJ P,CRLF
JUMPE 15,GOED10 ;IF NO LINE NUMBER, DO NOT DO THIS.
MOVEI 1,"P"
PUSHJ P,OUT1
MOVE 2,15 ;LINE NUMBER
TRZ 2,1 ;FOR SURE?
ASCO: MOVEI 1,0
LSHC 1,7
PUSHJ P,OUT1
JUMPN 2,ASCO
MOVEI 1,"/"
PUSHJ P,OUT1
MOVE 1,16 ;PAGE NUMBER
PUSHJ P,OUTDEC
PUSHJ P,CRLF
GOED10: MOVE 1,PPMAX+2 ;SIZE
ADDI 1,4
IDIVI 1,5 ;TO WORDS
MOVNS 1
HRLS 1
HRR 1,PPMAX ;BUFFER START
ADDI 1,1
MOVEM 1,PPMAX+2
MOVSI 1,'EDT'
EXCH 1,PPMAX+1
MOVE 2,[XWD 3,PPMAX+1]
CALLI 2,44 ;WRITE IT
JRST DSKIT
EDT10R: MOVE P,[XWD 1,[SIXBIT /SYS/
SIXBIT /SOS/
0↔0↔0↔0]]
CALL6 (P,RUN)
JRST 4,.
DSKIT: SETSTS 1,16 ;DO NOT LOSE BUFFERS
MOVEM 1,PPMAX+1
CALLI 2,30 ;JOB NUMBER
MOVSI 1,'EDT' ;TO FILE NAME
MOVEI 4,3
DGLP: IDIVI 2,=10
IORI 1,20(3)
ROT 1,-6
SOJG 4,DGLP
MOVSI 2,'TMP'
SETZB 3,4
ENTER 1,1
CALLI 12 ;FATAL
SETSTS 1,0
CLOSE 1,0 ;FINISH
JRST EDT10R
RPGDSK: CALLI
INIT 1,0
SIXBIT /DSK/
XWD PPMAX,0
CALLI 12
OUTBUF 1,0
OUTPUT 1,0
SETZM PPMAX+2
MOVEI 1," "
OUT1: AOS PPMAX+2
IDPB 1,PPMAX+1
POPJ P,
SXCON: MOVEI 1,0
LSHC 1,6
ADDI 1,40
PUSHJ P,OUT1
JUMPN 2,SXCON
POPJ P,
OCTQ: IDIVI 1,10
HRLM 2,(P)
SKIPE 1
PUSHJ P,OCTQ
HLRZ 1,(P)
ADDI 1,"0"
JRST OUT1
OUTDEC: IDIVI 1,=10
HRLM 2,(P)
SKIPE 1
PUSHJ P,OUTDEC
HLRZ 1,(P)
ADDI 1,"0"
JRST OUT1
CRLF: MOVEI 1,15
PUSHJ P,OUT1
MOVEI 1,12
JRST OUT1
>;EXPO
SUBTTL SAVE, RESTR, INSET -- General Utility Routines
DSCR SAVE
CAL PUSHJ
DES This routine saves registers 0-CHNL (12) in the user
RACS area. It also saves the return
address (-1(P)) in UUO1(USER), for traditional reasons,
for the error message printout routines.
Register USER is loaded but not saved, as is register
TEMP
⊗
↑SAVE: MOVE USER,GOGTAB ;→USER RE-ENTRANT TABLE
HRRZI TEMP,RACS(USER) ;XWD FF,SAVEADDR
BLT TEMP,RACS+CHNL(USER) ;SAVE FF THRU CHNL
MOVE TEMP,-1(P) ;RETURN ADDR FROM I/O CALL
MOVEM TEMP,UUO1(USER) ;STORE RETURN
POPJ P,
DSCR RESTR
PAR LPSA -- XWD FOR ADJUSTING P-STACK (#PARAMS+RETURN ADDR)
CAL JRST
RES ACS are restored from RACS, stack is adjusted using LPSA,
return is made through UUO1(USER)
⊗
↑RESTR: MOVSI TEMP,RACS(USER) ;XWD SAVEADDR,FF
BLT TEMP,CHNL ;RESTORE
SUB P,LPSA ;ADJUST STACK
JRST @UUO1(USER) ;RETURN
DSCR STACSV
CAL PUSHJ
DES SAVES ACS 0-13 IN AREA STACS
SID DESTROYS 14,15
⊗
;; #KL# BY JRL (11-22-72) SAVE ONLY AC'S 0-13
↑STACSV:
MOVE 15,GOGTAB
HRRZI 14,STACS(15)
BLT 14,STACS+13(15)
POPJ P,
DSCR STACRS
CAL PUSHJ
DES RESTORES ACS 0-13 FROM AREA STACS
⊗
;; #KL# RESTORE ONLY 0-13
↑STACRS: MOVE 15,GOGTAB
HRLZI 14,STACS(15)
BLT 14,13
POPJ P,
DSCR INSET
CAL PUSHJ
RES String Space is adjusted so that next created string will start
on a full-word boundary.
SID USER→GOGTAB
DES REMCHR is first adjusted, and STRNGC called if necessary.
Then TOPBYTE is adjusted.
⊗
↑INSET: MOVE USER,GOGTAB ;MAKE SURE
;;#GI# DCS 2-5-72 REMOVE TOPSTR
HLL TEMP,TOPBYTE(USER)
HRRI TEMP,[BYTE (7) 0,4,3,2,1,0]
ILDB TEMP,TEMP ;ADJUSTMENT NEEDED.
ADDM TEMP,REMCHR(USER) ;UPDATE REMCHR.
SKIPL TEMP,TOPBYTE(USER)
ADDI TEMP,1
HRLI TEMP,440700 ;POINT 7, WORD
MOVEM TEMP,TOPBYTE(USER) ;AND SAVE
POPJ P,
>;NOLOW
ENDCOM(LUP)
COMPIL(COR,<CORREL,CORGET,CORINC,CANINC,CORBIG>
,<GOGTAB>
,<CORGET, CORREL, ... -- CORE ALLOCATION ROUTINES>)
SUBTTL Core Service Routines -- General Description
DSCR BEGIN CORSER
⊗
IFN ALWAYS,<BEGIN CORSER>
Comment ⊗ These are the core allocation routines for both the compiler
and the code it compiles. Core comes in "BLOCKs." A block may be any
(reasonable) length, and has the following format:
HEAD: →PREV,,→NEXT ;if block not in use, free storage list pointers
SIZE ;GREATER 0 if free, LESS0 if in use
<SIZE-3 data words> ;whatever is to go here
x00000,,→HEAD ;x=1 if in use, 0 if free
→PREV is zero if this block is first on free storage list. →NEXT is zero if last
In the beginning, the world starts out as one big block, occupying space from
the end of the (GOGTAB→) user table to @JOBREL. Once a MOVE USER,GOGTAB
has been done, LOWC(USER) and TOP(USER) indicate the total size of
available core. FRELST(USER) → the first (only) block in free storage.
If GOGTAB is 0, CORGET will create a user table and make the remaining space
look like a BLOCK. It will create a user table and point GOGTAB at it.
It also assures that DDT symbols are below JOBSA(lh). Then it sets
JOBFF to =76K out of pure spite. Now CORGET operations may be issued.
CORGET is called with the desired size in SIZ (C). The free storage list is
searched for the first free block (BLK) satisfying the request. The
required block is taken from lower addresses of BLK and BLK is adjusted.
If requested size is within a few words of the free size, all of BLK is
given to the user. The resultant address is returned in THIS (B).
If there is no block on FRELST(USER) big enough, or if ATTOP(USER) ≠ 0, CORGET
checks XPAND(USER) for permission (0) to expand core. If granted, a new
block is formed at the top after obtaining more core. It is merged with
the top block if it is free, then the requested block is allocated from
it. CORGET is simple.
CORGET skips if it is successful. It does not skip if it needs to expand and
either XPAND(USER) ≠ 0 or the CORE UUO fails.
The secret is CORREL. No compacting is done, but CORREL will merge a returning
block with any neighboring free block. It can do this because it can
tell the status of each neighbor by looking at the size (POS if free)
field or x-bit (off if free). This tends to reduce checkerboarding.
CORREL is called with a pointer to the block to be released in THIS (B).
It returns nothing, nor does it ever skip.
CORBIG returns in SIZ the size of the largest available block. ⊗
NOLOW < ;INCLUDE IN UPPER SEGMENT.
SUBTTL Special AC Declarations
DEBCOR ←←0 ;SWITCH FOR CORE DEBUGGING ROUTINES.
; ACS
SIZ ←← 3 ;SIZE OF BLOCK BEING OBTAINED OR RELEASED
THIS ←← 2 ;POINTER TO SAME
NEXT ←← 1 ;POINTER TO SUCCESSOR
PREV ←← 5 ;POINTER TO PREDECESSOR
LAST ←← 6 ;POINTER TO NEXT-HIGHER NEIGHBOR
TRIVIAL ←←=10 ;AMOUNT WE'RE WILLING TO WASTE
SUBTTL Utility Routines
DSCR UNLINK
CAL PUSHJ
PAR →Core block to be removed in AC THIS (2)
RES block is removed from CORSER free storage list
SID ACs NEXT (1) and PREV (5) are given appropriate values
⊗
UNLINK:
HRRZ NEXT,(THIS) ;→NEXT BLOCK
HLRZ PREV,(THIS) ;→PREVIOUS BLOCK
SKIPN PREV ;IF A PREV BLOCK DOES NOT EXIST,
MOVEI PREV,FRELST(USER) ; USE FRELST POINTER
HRRM NEXT,(PREV) ;CHANGE ITS NEXT FIELD
SKIPE NEXT ;IF A NEXT BLOCK EXISTS,
HRLM PREV,(NEXT) ; CHANGE ITS PREV FIELD
POPJ P, ;BLOCK IN "THIS" IS NO LONGER ON FRELST
DSCR RELINK
CAL PUSHJ
PAR AC THIS → core block to be placed on free storage list
AC LAST → last word of block +1
AC SIZ has size of this block
DES block is placed on CORSERs free storage list
SID AC NEXT (1) is given the appropriate value
⊗
RELINK:
HRRZM THIS,-1(LAST) ;X-BIT ← 0, RH ← PTR TO HEAD
MOVEM SIZ,1(THIS) ;GREATER 0 SIZE FIELD ⊃ FREE BLOCK
SKIPE NEXT,FRELST(USER) ;PLACE NEW BLOCK ON FRONT OF FRELST
HRLM THIS,(NEXT) ; IF THERE IS ONE
HRRZM NEXT,(THIS) ;POINT TO NEXT FROM THIS
HRRZM THIS,FRELST(USER) ;UPDATE FRELST POINTER
POPJ P, ;RETURN
DSCR CORE2I
CAL PUSHJ
DES Initializes second segment core if there is a global model
⊗
GLOB <
IFN 0,<
↑GLCOR:
SKIPE GLBPNT
POPJ P, ;ALREADY INITIALIZED.
MOVEM 16,GLUSER+LEABOT+16
MOVEI 16,GLUSER+LEABOT
BLT 16,GLUSER+LEABOT+15
;SHALL NOT CLOBBER ACCUMULATOR 1.
MOVEI 3,3(13) ;GET SIZE REQUIRED.PLUS SOME BECAUSE BLT LOSES.
PUSHJ P,CORE2 ;GET SECOND SEGMENT CORE.
JRST [TERPRI <NO CORE FOR GLOBAL MODEL>
CALLI 12]
SUBI 2,1
MOVEM 2,GLBPNT ;AND RECORD IT.
SETZM 1(2) ;FIRST WORD.
HRRI 2,2(2) ;SECOND WORD.
HRLI 2,-1(2) ;FIRST WORD.
ADDI 3,-2(2) ;LENGTH.
BLT 2,(3) ;ZERO IT.....
MOVSI 16,GLUSER+LEABOT
BLT 16,16 ;RESTORE ALL LOADER'S AC'S AGAIN.
POPJ P, ;AND GO AWAY.
>
↑CORE2I:
PUSH P,USER
MOVE USER,[XWD GLUSER+LEABOT+20,GLUSER+LEABOT+21]
SETZM GLUSER+LEABOT+20
BLT USER,GLUSER+ZAPEND
POP P,USER ;NOW DATA AREA IS ZERO.
MOVEI USER,GLUSER ;SET UP FOR CORE2.
PUSHJ P,JUSTSAVE ;AND SAVE AC'S
SETOM CORLOK ;THE LOCK ...
SETOM GLBPNT ;AND THE SWITCH SAYING INITED.
MOVE THIS,TOP2 ;LAST ADDRESS IN SEC. SEG USED.
ADDI THIS,1
MOVEM THIS,LOWC(USER) ;SAVE FOR LATER
PUSHJ P,NEWB2 ;AND LINK UP.
JRST BUFRST ;ALL DONE INITIALIZING.
DSCR 2d SEGMENT CORE CONTROL STORAGE
⊗
CORLOK: 0
CR2BEG: BLOCK ZAPEND-ZAPBEG+1 ;AREA FOR ALL OTHERS.
↑↑GLUSER←CR2BEG-ZAPBEG ;AND THE MAGIC INDEX.
INTERNAL GLUSER
>;GLOB
DSCR BUFRST
CAL PUSHJ or JRST
RES restores ACs from CORSER routines, and returns
⊗
BUFRST:
IFN DEBCOR,<
SKIPE PRTCOR ;SHOULD WE DEBUG?
JFCL
>
MOVSI TEMP,BUFACS(USER)
BLT TEMP,LAST
POPJ P,
DSCR BUFSAV
CAL PUSHJ
RES Saves ACs for CORSER routine
Initializes CORSER storage, obtains USER TABLE if GOGTAB is 0
⊗
BUFSAV:
GLOB <
SKIPN GLBPNT ;HAS GLOBAL MODEL BEEN INITIALIZED?
PUSHJ P,CORE2I ;NO --INITIALIZE IT.
>;GLOB
SKIPE USER,GOGTAB ;CAN WE GO AHEAD?
JRST JUSTSAVE ; YES
Comment ⊗ Use SALTAB and forget the rest if SALTAB is there. Otherwise
set up a user table. Don't use THIS or SIZ (B or C). ⊗
NOEXPO <
MOVEI TEMP,=76*=1024 ;ONE REALLY MUST KNOW WHAT HE
>;NOEXPO
EXPO <
MOVEI TEMP,-1 ;FOR MAX CORE
>;EXPO
MOVEM TEMP,JOBFF ; IS DOING
; SKIPE USER,SALTAB ;OTHERS CAN SPECIFY SAIL SPACE
; MOVEM USER,GOGTAB ;SET UP GOGTAB IF SALTAB NON-ZERO
; JUMPN USER,JUSTSAVE ;DON'T GO THRU SAIL's ALLOCATION
; ASSUME THAT THE WORLD IS NEW
HLRZ USER,JOBSA ;USER TABLE ADDRESS
MOVEM USER,GOGTAB ;THIS TIME FOR SURE
SKIPN JOBDDT ;IF DDT IS IN CORE,
JRST NODDT ; MAKE SURE ITS SYMBOLS ARE PROTECTED
HRRZ TEMP,JOBSYM ;IF JOBSYM IS BELOW JOBFF, THEN
CAML TEMP,USER ; ASSUME ALL SYMBOLS ARE BELOW.
TERPRI <YOUR SYMBOLS ARE SOON TO BE OBLITERATED>
NODDT: MOVEI TEMP,ENDREN-CLER+=2000(USER) ;MAKE SURE
CAMGE TEMP,JOBREL ; ENOUGH CORE EXISTS
JRST CORTHER ; FOR USER TABLE
CALL6 (TEMP,CORE) ;GET ENOUGH
CORERR <DRYROT -- NO ROOM FOR USER TABLE>
CORTHER:
SETZM (USER) ;CLEAR USER TABLE
HRL TEMP,USER
HRRI TEMP,1(USER)
BLT TEMP,ENDREN-CLER(USER)
MOVEI THIS,ENDREN-CLER(USER) ;SET UP LIMITS OF FREE SPACE
MOVEM THIS,LOWC(USER) ; BOTTOM
PUSHJ P,NEWBLK ;MAKE NEW AREA INTO A FREE BLOCK
JRST JUSTSAVE ;SAVE ACS
GLOB <
NEWB2: CALLI LAST,SEGSIZUUO ;FIND OUT HOW BIG.
TRO LAST,400000 ;SINCE ANDY DOES NOT GIVE ME THIS.
JRST NEWB1
>;GLOB
NEWBLK:
HRRZ LAST,JOBREL ;END OF BIG BLOCK
NEWB1: SETZM (THIS) ;POINTERS WORD IN BIG BLOCK
ADDI LAST,1 ;CONFORM TO "LAST" STANDARDS
MOVEM LAST,TOP(USER) ;TOP OF FREE SPACE
PUSH P,SIZ ;SAVE SIZE
MOVE SIZ,LAST ;COMPUTE SIZE OF NEW BLOCK
SUB SIZ,THIS ;SIZE OF BIG BLOCK
PUSHJ P,RELINK ;PUT ON FREE STORAGE LIST
POP P,SIZ ;GET SIZ BACK
POPJ P,
JUSTSAVE:
MOVEI TEMP,BUFACS(USER)
BLT TEMP,BUFACS+LAST(USER)
IFN DEBCOR,<
SKIPE PRTCOR ;SHOULD WE DEBUG?
PUSHJ P,CORPRT ; YES
>
POPJ P,
IFN DEBCOR,<
↑PRTCOR: 0
>
SUBTTL CORGET
DSCR CORGET
CAL PUSHJ
PAR size of desired block in AC C (3)
RES SUCCESS: addr of block in B, skip-return
FAILURE: no-skip
SID none, except when called with GOGTAB 0 -- should only be done by experts
DES a block of at least the required size is obtained using first-fit algorithm.
Up to 10 extra words may be returned, but this is not reflected in C.
⊗
HERE(CORGET)
IFN DEBCOR,<
SKIPE PRTCOR
TERPRI <CORGET: > ;TELL THE PEOPLE WHO YOU ARE
>
PUSHJ P,BUFSAV ;SAVE AC'S, INITIALIZE WORLD PERHAPS
GLOB <
SKIPN USCOR2(USER) ;ARE WE INSTRUCTED TO USE CORE2?
JRST COR21 ;NOPE -- GO AHEAD.
↑↑CORE2: SKIPN GLBPNT ;HAS IT BEEN INITIALIZED?
PUSHJ P,CORE2I ;NO -- BUT NOW.
AOSE CORLOK ;CAN WE GET THROUGH THE LOCK?
JRST [SOS CORLOK ;APPARENTLY NOT.
PUSHJ P,WAITQQ ;WAIT
JRST .-1]
MOVEI USER,GLUSER ;USE THIS VERSION OF USER.
PUSHJ P,JUSTSAVE ;JUST SAVE THE ACCUMULATORS.
>;GLOB
COR21: ADDI SIZ,3 ;3 WORDS FOR CONTROL INFO
SKIPE ATTOP(USER) ;IF USER REQUESTS IT, GET BLOCK
JRST EXPAND ; AT TOP OF CORE
MOVEI THIS,FRELST(USER) ;THIS WILL POINT TO THE FIRST GOOD BLOCK
GETLUP: HRRZ THIS,(THIS) ;→NEXT FREE BLOCK
JUMPE THIS,EXPAND ;TRY TO EXPAND CORE, NONE EXIST YET
CAMLE SIZ,1(THIS) ;WILL IT FIT?
JRST GETLUP ; NO, TRY NEXT
GETCOR: AOS (P) ;SUCCESS GUARANTEED
HRRZM THIS,BUFACS+THIS(USER) ;RESULT(ALMOST)
PUSHJ P,UNLINK ;UNLINK THIS BLOCK
MOVE LAST,1(THIS) ;REAL BLOCK SIZE
CAIGE LAST,TRIVIAL(SIZ) ;IS DIFFERENCE NEGLIGIBLE?
JRST [MOVSI TEMP,400000 ;YES, USE WHOLE THING --
ADD LAST,THIS ; MARK X-BIT TO INDICATE IN USE
HLLM TEMP,-1(LAST)
JRST GETOUT] ;AND GO FINISH OUT
MOVEM SIZ,1(THIS) ;NEW SIZE FOR RESULT
HRRZ TEMP,THIS ;SAVE START OF BLOCK (RESULT)
ADD THIS,SIZ ;NEW START FOR REMAINING FREE STUFF
SUB LAST,SIZ ;NEW SIZE FOR REMAINS
MOVE SIZ,LAST
ADD LAST,THIS ;NEW END FOR REMAINS
HRLI TEMP,400000 ;TURN X-BIT ON
MOVEM TEMP,-1(THIS) ;IN USER'S BRAND NEW BLOCK
PUSHJ P,RELINK ;RELINK REMAINS, RESTORE ACS
GETOUT: PUSHJ P,GETRST ;RESTORE ACS
SETZM (THIS) ;PTR RETRIEVED FROM STORAGE
MOVNS 1(THIS) ;SIZE NEG ⊃ IN USE
ADDI THIS,2 ;USER DOESN'T SEE THIS HEADER
IFN DEBCOR,<
SKIPE PRTCOR
PUSHJ P,CORPRT
>
POPJ P, ;HERE'S YOUR BLOCK!
EXPAND: SKIPE XPAND(USER) ;IS IT ALLOWED TO EXPAND?
JRST GETRST ; NO, ERROR RETURN
PUSH P,SIZ ;SAVE TOTAL SIZE
HRRZ THIS,TOP(USER) ;THIS→NEW BLOCK IF NEXT LOWER IS USED
SKIPGE -1(THIS) ;IS TOP BLOCK FREE?
JRST GETMOR ; NO, USE WHAT YOU HAVE
HRRZ THIS,-1(THIS) ;UNLINK THE
PUSHJ P,UNLINK ; TOP BLOCK
GETMOR: MOVE TEMP,THIS
ADDI TEMP,=1024(SIZ) ;GET MORE AND THEN SOME
POP P,SIZ ;GET THIS BACK BEFORE YOU FORGET
GLOB <
CAIN USER,GLUSER ;THIS IS HOW WE TELL
JRST [CALLI TEMP,CORE2UUO ;GET SOME CORE
JRST GETRST ;HE SPAT UPON OUR HUMBLE REQUEST.
PUSHJ P,NEWB2 ;LINK IT UP
JRST .+4]
>;GLOB
CALL6 (TEMP,CORE) ;ASK FOR MORE
JRST GETRST ;CAN'T GET IT
PUSHJ P,NEWBLK ;MAKE TOP LOOK LIKE FREE BLOCK
CAMLE SIZ,1(THIS) ;NOW SHOULD FIT
CORERR <DRYROT -- EXPAND CODE GLUBBED UP>
JRST GETCOR ;GO GET BLOCK
GETRST:
GLOB <
PUSHJ P,BUFRST ;RESTORE ACCUMULATORS.
CAIN USER,GLUSER ;WAS IT CORE2?
SOS CORLOK ;YES -- BACK UP COUNT.
MOVE USER,GOGTAB ;RESET IT TO USUAL.
POPJ P, ;
>;GLOB
JRST BUFRST
SUBTTL CORINC, CANINC
DSCR CORINC
CAL PUSHJ
PAR AC B -- Addr of block to be incremented
AC C -- amount if increase desired
RES SUCCESS: skip-return, extra core has been granted
FAILURE: no-skip
SID none
⊗
HERE(CORINC)
IFN DEBCOR,<
SKIPE PRTCOR
TERPRI <CORINC:>
>
PUSHJ P,JUSTSAVE ;SAVE ACS
MOVNI FF,1 ;WANT TO DO IT
JRST INCR
DSCR CANINC
CAL PUSHJ
PAR same as CORINC
RES No extra core is ever actually obtained
if entire request can be granted, skip-return
if some extra words available, no-skip, C contains possible increment
if no extra words available, no-skip, C contains 0
SID none except as described above
⊗
HERE(CANINC)
IFN DEBCOR,<
SKIPE PRTCOR
TERPRI <CANINC: >
>
PUSHJ P,BUFSAV
MOVEI FF,0 ;JUST WANT TO SEE IF IT'S POSSIBLE
; IF BLOCK IS AT TOP, CAN ALWAYS DO IT
INCR: SUBI THIS,2 ;POINT AT REAL BLOCK HEAD
GLOB <
TRNE THIS,400000 ;CHECK TO SEE IF CORE2
CORERR <NO CANINC SECOND SEGMENT SPACE>
>;GLOB
HRRZ LAST,THIS ;CHECK AT TOP
SUB LAST,1(THIS) ; ADDR OF END (SIZE IS NEG)
CAMGE LAST,TOP(USER) ;TOP BLOCK?
JRST MIDDLE ; NO
JUMPE FF,YESINC ;SUCCESS
MOVNS 1(THIS) ;MAKE IT LOOK FREE
ADD SIZ,1(THIS) ;TOTAL SIZE
HRRZS -1(LAST) ;MAKE END LOOK FREE
JRST EXPAND ;EXPAND AND RETURN
MIDDLE: SKIPGE TEMP,1(LAST) ;NEXT BLOCK FREE?
JRST NONEATALL ; NO, FAILURE
SUBI TEMP,3 ;AVAILABLE SIZE
CAMLE SIZ,TEMP ;IS THERE ENOUGH?
JRST MAYBE ; NO, FAILURE MAYBE
JUMPE FF,YESINC ;ALL OK, CAN DO, REPORT IT
CRXXB: MOVNS TEMP,1(THIS) ;MAKE IT LOOK FREE
PUSH P,(THIS) ;WILL RESTORE THIS IN CASE SOMEONE USED
PUSH P,THIS ;SAVE SIZE
PUSH P,SIZ ;AND POINTER
ADDM TEMP,(P) ;TOTAL SIZE DESIRED AFTER RETURN
MOVE SIZ,TEMP ;SIZE OF CURRENT "THIS"
HRRZ THIS,LAST ;MERGE "THIS" WITH "LAST"
PUSHJ P,UNLINK ;TAKE IT OFF FRELST
ADD LAST,1(THIS) ;AND INCREASE
ADD SIZ,1(THIS)
MOVE THIS,-1(P) ;RETRIEVE CURRENT BLOCK.
PUSHJ P,RELINK ;AND NOW RELINK ON FRELST.
POP P,SIZ
POP P,THIS
PUSHJ P,GETCOR ;GET THE BLOCK AGAIN, ONLY BIGGER
CORERR <DRYROT -- NEAR CRXXB> ;CAN'T HAPPEN
POP P,-2(THIS) ;GET POINTER WORD BACK
AOS (P) ;SUCCESS
POPJ P, ;BUFRST DONE BY GETCOR
YESINC: AOS (P) ;REPORT SUCCESS
IFN DEBCOR,<
SKIPE PRTCOR
PUSHJ P,CORPRT
>
JRST BUFRST
MAYBE: ADDI TEMP,3(LAST) ;GET TOP OF NEXT BLOCK AND SEE
CAMGE TEMP,TOP(USER) ;IF IT IS THE TOP ONE.
JRST NOTENUF ;NO -- FAIL UTTERLY.
JUMPE FF,YESINC ;GOT IT IF ONLY GOING TO HERE.
PUSH P,SIZ ;SAVE AMOUNT REQUESTED.
MOVEI SIZ,-3(TEMP) ;THIS IS THE SIZE OF THE BLOCK WE
SUB SIZ,LAST ;KNOW WE CAN GET.
MOVN TEMP,SIZ
ADDM TEMP,(P) ;(P) NOW HAS EXTRA REQUIRED.
PUSHJ P,CRXXB ;AND WE DO SOO
CORERR <DRYROT NEAR MAYBE> ; CAN'T HAPPEN.
POP P,SIZ ;RETRIEVE SIZE.
MOVNI FF,1 ;SINCE CRXXB DESTROYED IT.
JRST INCR ;AND GO THROUGH AGAIN
;THIS TIME IT WILL BE THE TOP BLOCK.
NOTENUF:
SUBI TEMP,3(LAST) ;UNDO WHAT WAS DONE ABOVE
SKIPA SIZ,TEMP ;CAN'T DO ALL, BUT CAN DO THIS MUCH
NONEATALL:
MOVEI SIZ,0 ;CAN'T DO ANYTHING
MOVEM SIZ,BUFACS+SIZ(USER)
JRST BUFRST
SUBTTL CORREL
DSCR CORREL
CAL PUSHJ
PAR addr of block to be released in B
RES block is released to free storage
SID none
DES the block is merged with any adjoining free blocks
⊗
HERE(CORREL)
IFN DEBCOR,<
SKIPE PRTCOR
TERPRI <CORREL: >
>
SKIPN USER,GOGTAB ;MUST BE SET UP HERE
CORERR <DRYROT -- CORREL CALLED WITH INITIALIZED WORLD>
GLOB <
TRNN THIS,400000 ;IS IT SECOND SEGMENT ADDRESS?
JRST NOSGR ;NO
MOVEI USER,GLUSER ;USE THIS ONE.
AOSE CORLOK ;SEE IF WE CAN GET IN.
JRST [SOS CORLOK
PUSHJ P,WAITQQ
JRST .-1]
NOSGR:
>;GLOB
PUSHJ P,JUSTSAVE ;SAVE ACS
; MERGE WITH LOWER NEIGHBOR (ADDRESS-WISE) IF POSSIBLE
SUBI THIS,2 ;USER THINKS IT STARTED 2 PAST
MOVN SIZ,1(THIS) ;SIZE OF THIS BLOCK
MOVE LAST,SIZ ;ADDRESS OF UPPER
ADD LAST,THIS ; NEIGHBOR
CAMGE THIS,LOWC(USER) ;IS ADDRESS IN RANGE?
CORERR <DRYROT -- ADDR TO CORREL TOO LOW>
CAME THIS,LOWC(USER) ;CAN THERE BE A LOWER BLOCK
SKIPGE -1(THIS) ; AND IF SO, IS IT FREE?
JRST UPPET ; NO, LOOK FOR UPPER BLOCK
HRRZ THIS,-1(THIS) ;→LOWER BLOCK
PUSHJ P,UNLINK ;UNLINK IT FROM LIST
ADD SIZ,1(THIS) ;INCREASE SIZE
; MERGE WITH UPPER NEIGHBOR IF POSSIBLE
UPPET: CAMLE LAST,TOP(USER)
CORERR <DRYROT -- ADDR TO CORREL TOO HIGH>
CAME LAST,TOP(USER) ;IS THERE AN UPPER BLOCK?
SKIPGE 1(LAST) ;AND IF SO, IS IT FREE?
JRST LNKRET ; NO, RELINK AND GO AWAY
UPPR: PUSH P,THIS
HRRZ THIS,LAST ;THIS → UPPER NEIGHBOR
PUSHJ P,UNLINK ;GET IT OUT
ADD LAST,1(THIS) ; INCREASE EXTENT
ADD SIZ,1(THIS) ; AND TOTAL SIZE
POP P,THIS ; GET HEADER POINTER BACK
LNKRET:
GLOB <
CAIN USER,GLUSER
JRST LNKRT ;IF SEC SEGMENT, NEVER SHRINK
>;GLOB
;;#IC# 7-3-72 DCS (1-1) ADD NEW MEANING TO NOSHRK(USER)
SKIPL TEMP,NOSHRK(USER) ;If NOSHRK(USER) is:
CAMG LAST,JOBREL ; <0, CORREL should not reduce core;
JRST LNKRT ; >0, its RH indicates the amount of
JUMPN TEMP,.+2 ; free space which should be
MOVEI TEMP,=2046 ; protected from release;
HRRZS TEMP ; =0, at least 2K should be protected.
CAIGE TEMP,4 ;Only the first and third alternatives
MOVEI TEMP,4 ; were previously available.
CAMGE SIZ,TEMP ;Don't bother if there is already
JRST LNKRT ; less free space available than
ADDI TEMP,(THIS) ; desired
;;#IC# (1-1)
CALL6 (TEMP,CORE)
ERR <DRYROT --CORSER&LNKRET>
MOVE LAST,JOBREL ; AND 2) ADJUST BLOCK TO INDICATE
ADDI LAST,1
MOVEM LAST,TOP(USER) ;AND RECORD NEW RESULTS.
MOVE SIZ,LAST ; THE CHANGE BEFORE RELINKING
SUB SIZ,THIS
LNKRT:
PUSHJ P,RELINK ;PUT IT BACK
IFN DEBCOR,<
SKIPE PRTCOR
PUSHJ P,CORPRT
>
JRST GETRST ;AND GO AWAY
SUBTTL CORPRT, CORBIG
IFN DEBCOR,<
↑CORPRT:
SETZM TOTFRE# ;TOTAL FREE STORAGE COUNT
TERPRI <FREE STORAGE: >
PUSH P,LPSA
MOVE USER,GOGTAB ;THIS STUFF IS DEBUGGING
MOVEI LPSA,FRELST(USER) ;JUNK FOR CORGET AND FRIENDS
CPLUP: HRRZ LPSA,(LPSA) ;IT SHOULD BE INTUITIVELY
JUMPE LPSA,DUNNN ;OBVIOUS
PRINT <START = >
OCTPNT LPSA
MOVE TEMP,1(LPSA)
ADDM TEMP,TOTFRE
PRINT < SIZE = >
OCTPNT TEMP
ADD TEMP,LPSA
PRINT < END = >
OCTPNT TEMP
TERPRI
JRST CPLUP
DUNNN:
PRINT <TOTAL FREE SIZE = >
OCTPNT TOTFRE
SETOM PRTCOR
TERPRI
CAMLE THIS,JOBREL
JRST DUNMOR
TERPRI <THIS BLOCK: >
PRINT <"THIS" = >
MOVE TEMP,THIS
OCTPNT TEMP
PRINT < C-SIZE = >
HRRZ TEMP,SIZ
OCTPNT TEMP
CAML THIS,JOBREL
JRST DUNMOR
HRREI LPSA,-2(THIS)
JUMPLE LPSA,DUNMOR
PRINT < BLOCK-SIZE = >
MOVN TEMP,1(LPSA)
OCTPNT TEMP
DUNMOR: TERPRI
POP P,LPSA
TTCALL 11,
TTCALL TEMP
TERPRI
POPJ P,
>
DSCR CORBIG
CAL PUSHJ
PAR NONE
RES LARGEST AVAILABLE BLOCK IN SIZ (3,C)
SID THIS (2,B) MUNGED
⊗
HERE(CORBIG) SKIPN USER,GOGTAB
CORERR <CORBIG: INITIALIZED WORLD>
MOVEI SIZ,0 ;"ZERO-LENGTH" BLOCK
MOVEI THIS,FRELST(USER)
BIGLUP: HRRZ THIS,(THIS)
JUMPE THIS,BIGDUN ;END OF FREELIST?
CAMGE SIZ,1(THIS)
MOVE SIZ,1(THIS) ;FIND MAX
JRST BIGLUP
BIGDUN: SUBI SIZ,3 ;WHAT HE SEES
POPJ P,
Comment ⊗ No other core routines should be necessary to provide
gross control over allocation. Programs obtaining
space from CORGET can carve the blocks up if necessary.
Please put your core back when you're done with it.
Thank You,
The Management
⊗
>;NOLOW
ENDCOM (COR)
IFN ALWAYS,<
BEND CORSER
>
COMPIL(SGC,<STRNGC,STRGC,STCLER,SGINS,SGREM,%SPGC1,%ARSR1>
,<GOGTAB,X11,CORGET,CORREL,CORINC,X22,CORBIG,SPRPDA>
,<STRING GARBAGE COLLECTOR ROUTINES>
,<%SPGC,%STRMRK,%ARRSRT>)
;String Garbage Collector Routines
NOLOW < ;INCLUDE IN UPPER SEGMENT.
BKSZ←←=25 BKOFF←←=23 MLT←←5
↑.CORERR:
CORERR <NO CORE FOR ALLOCATION>
DSCR STRGC(# chars desired);
CAL SAIL
RES calls string garbage collector with #chars in -1(p)..i.e.a formal param.
⊗
HERE (STRGC)
EXCH A,-1(P) ;THE DESIRED A IS HERE
MOVE USER,GOGTAB
MOVEM RF,RACS+RF(USER);SAVE F REGISTER WHERE GC CAN FIND.
PUSHJ P,STRNGC ;COLLECT TRASH
SUB P,X22 ;BACK UP STACK
MOVNS A
ADDM A,REMCHR(USER)
MOVE A,1(P) ;GET ORIGINAL "A" BACK
JRST 2,@2(P) ;RETURN
DSCR STRNGC
CAL PUSHJ
PAR A -- number of new characters needed
REMCHR(USER) -- has been updated by that number of chars
RES String space is compacted, new REMCHR is updated by C(A).
Restarts if not enough room left
SID none
DES STRNGC is a two-pass process. In the first, all string descriptors
are found and sorted into ascending sequence with respect to the locations
of their respective texts. String descriptors are found via the generating
routines, described in CALSG.
In the second pass, all string texts are moved down to fill any
unused space. All descriptors are adjusted to reflect the new locations.
⊗
↑STRNGC: MOVE USER,GOGTAB ;GET USER TABLE POINTER
MOVEM 12,SGACS+12(USER)
MOVEI 12,SGACS(USER)
BLT 12,SGACS+11(USER)
; →→→→→→ OBTAIN SPACE, INITIALIZE GARBAGE COLLECTOR ←←←←←←
HRRZ TEMP,TOPBYTE(USER) ;MAKE SURE DIDN'T OVERFLOW
; **** BUG TRAP
CAMG TEMP,STTOP(USER)
CAMGE TEMP,ST(USER)
ERR <DRYROT AT STRNGC>
; **** EBT
SUB TEMP,ST(USER) ;CREATE A DIVISOR FOR DISTRIBUTION
ADDI TEMP,5 ; OF DESCRIPTORS DURING SGSORT
MOVEM TEMP,INKY(USER)
SKIPE XPAND(USER) ;ALLOWED TO EXPAND?
JRST INSIDE ; NO
SETOM ATTOP(USER) ;WANT BLOCK OFF THE TOP FOR SAFETY
MOVEI C,=400 ;REASONABLE SIZE
PUSHJ P,CORGET ;IF CAN'T GET IT, TROUBLE
SKIPA ;TRY TO GET WHAT YOU CAN
JRST CORROK ;GOT IT
INSIDE: SETZM ATTOP(USER) ;CAN'T EXPAND
PUSHJ P,CORBIG ;HOW MUCH CAN WE HAVE?
PUSHJ P,CORGET ;GET THAT AMOUNT
ERR <DRYROT - STRNGC CAN'T GET CORE>
CORROK: SETZM ATTOP(USER) ;NOW CAN GET ANYWHERE
MOVEM B,STBUCK(USER) ;SAVE → TO BLOCK
SETZM (B)
HRLS B
ADDI B,1
MOVEI TEMP,BKOFF(B)
BLT B,(TEMP)
MOVE B,STBUCK(USER)
ADDI B,BKSZ ;FIRST BKSZ WORDS IS "BUCKET" LIST
MOVNI C,-BKSZ(C)
JUMPGE C,.CORERR ;BAD THING
HRL B,C
SUB B,X11 ;IOWD FOR WORD ALLOC IN STRNGC
MOVEM B,SGFRE(USER) ;FREE SPACE POINTER
HRRZ A,ST(USER)
HRLI A,(<POINT 7,0>)
MOVEM A,TOPBYTE(USER) ;FIRST(USER) NEW OK POSITION
SETZM NUMCHR(USER) ;TOTAL # CHARS PREVIOUSLY MOVED
; →→→→→→ SORT THE STRINGS ←←←←←←←←←
DSCR CALSG
PAR linked list of routine addresses based at SGROUT(USER)
RES each routine in list is called to provide string descriptors
to the sorting routine, SGSORT.
SID SGSORT uses B,C,D,E,TEMP, accepts input in A. Generating
routines may use A-T1 (12) and TEMP for their own devices.
Q1 through T1 will not be changed by calls on SGSORT.
DES Each generating routine should do the following:
1) Place a string descriptor in A
2) PUSHJ P,SGSORT or PUSHJ P,@-1(P) (addr provided on stack)
3) Repeat the process if it knows about more strings, else return
4) Return with a POPJ (and a flourish)
The `standard' generating routines are:
SPSG -- collects the string stack
STRMRK -- collects string variables linked through SGLINK(USER)
ARRMRK -- collects string arrays found in ARRPDL
RINGSORT -- collects PNAMES from semantic blocks in compiler
DEFSRT -- collects saved input strings during macro recursion in compiller
These routines should provide sufficient examples.
⊗
CALSG: MOVEI T,SGROUT(USER) ;GET LINKED LIST OF ROUTINE NAMES
PUSH P,T ;SAVE FIRST POINTER
PUSH P,[SGSORT] ;PROVIDE ACCESS TO SORTING ROUTINE
↑CALSGL:
SKIPN T,@-1(P) ;GO DOWN LIST UNTIL DONE
JRST ALLCOL ;DONE
HRRZM T,-1(P) ;SAVE NEW POINTER
PUSHJ P,@-1(T) ;CALL GENERATOR ROUTINE
JRST CALSGL ;DO MORE THAN ONCE
; →→→→→→ SORT THE SP STACK ←←←←←←
HERE(%SPGC) HRRZ A,SPDL(USER) ;START AT BASE OF STACK
↑%SPGC1:ADDI A,1
JRST SGTST ;AND WORK UP TO CURRENT POINTER
STRNGSTACKMARKLOOP:
PUSHJ P,SGSORT ;SORT IT INTO LIST
SGTST:
CAIGE A,(SP) ;DONE?
JRST STRNGSTACKMARKLOOP ;NO
GPOPJ: POPJ P, ;YES, GO ON TO NEXT TYPE
; →→→→→→ SAIL COMPILER SPECIAL SORTERS ARE IN COMSER ←←←←←
; →→→→→→ SORT THE VARIABLES ←←←←←←
HERE (%STRMRK)
SKIPN T,STRLNK(USER) ;GET LINK
POPJ P, ; NO STRINGS AT ALL
STMKL1: HRRZ A,-1(T) ;→1ST STRING
HLRZ Q2,-1(T) ;# STRINGS THIS PROC
JRST SOJLP ;GO LOOP
STMKLP:
; SKIPN -2(T) ;PROCEDURE ACTIVE?
; SETZM (A) ; NO, MAKE NULL STRINGS
Comment ⊗ Due to certain social pressures (WFW LIVES ON)
strings in inactive blocks remain over garbage collection ⊗
PUSHJ P,SGSORT ;SORT VARIABLES INTO LIST
SOJLP: SOJGE Q2,STMKLP ;SORT UNTIL DONE WITH THIS PROC (SGSORT INCRS A)
STRMK4: HRRZ T,(T) ;NEXT PROCEDURE
JUMPN T,STMKL1 ; IF THERE IS ONE
POPJ P, ;DONE
COMMENT ⊗
→→→→→→ SORT STRING ARRAYS ←←←←←←
THIS ROUTINE TRIPS DOWN THE DYNAMIC LINKS, LOOKING INTO
PROCEDURE DESCRIPTORS FOR STRING ARRAYS WHICH MIGHT HAVE BEEN ALLOCATED.
THEN IT LOOKS FOR ANY ARRAYS OWNED BY LEAP. THE FIRST
WORD OF EACH ARRAY BLOCK IS THE NUMBER OF DIMENSIONS IF THE
ARRAY IS A STRING ARRAY. THE WORD JUST PREVIOUS TO IT IS THE
(NEGATIVE) SIZE OF THE ARRAY.
⊗
INTERNAL %ARRSRT
HERE (%ARRSRT)
HRRZ RF,RACS+RF(USER);REAL RF WITH LH= 0
↑%ARSR1:
PROCDO: HLRZ Q1,1(RF) ;FETCH PDA
CAIN Q1,SPRPDA ;IS IT SPROUTER??
POPJ P, ;YES
MOVE Q1,PD.LLW(Q1) ;WE HAVE TO DO SOMETHING -- PT AT LVI
CHK: SKIPN T,(Q1) ;GET ENTRY
JRST GODOWN ;0 MEANS OF PROC DESCR
;;#HI#↓ 5-15-72 DCS WAS TESTING 200000 (TYPE 4?) BIT, WRONG BIT!
TLC T,100000 ;TYPE 2? (STRING ARRAY)
TLNE T,740000 ;
AOJA Q1,CHK ;NO
SKIPN A,@T ;THERE??
AOJA Q1,CHK ;NO
;;# # 5-3-72 DCS
SUBI A,1 ;A→2D WORD, FIRST ENTRY -- DCS 5-3-72
;;# #
SKIPL Q2,-1(A) ;BETTER BE THERE
ERR <DRYROT AT ARRSRT>
PUSHJ P,ARPUTX ;GO SORT IT
AOJA Q1,CHK
GODOWN: HRRZ RF,(RF) ;NOTE THAT RESTR WILL PUT RF BACK
CAIE RF,-1 ;
JRST PROCDO ;-1 WILL SAY END
LARR: SKIPN T1,ARYLS(USER) ;LEAPING LISTS
POPJ P, ;NONE
LAR1:
HLRZ Q2,(T1) ;GET ADDRESS
;;# # 5-3-72 DCS SET UP A
MOVEI A,-1(Q2) ;A→1ST WORD, FIRST ENTRY
;;# #
SKIPL Q2,-2(Q2) ;BE SURE
ERR <LEAPING DRYROT AT ARRSRT>
PUSHJ P,ARPUTX ;GO SORT IT
LAR2: HRRZ T1,(T1) ;MERRILY WE LINK ALONG
JUMPN T1,LAR1 ;
POPJ P, ;HOME AT LAST
ARPUTX:
HRRZS Q2 ;YES, GET TOTAL SIZE
LSH Q2,-1 ;NUMBER OF STRINGS
JRST ARSLP
ARS3:
PUSHJ P,SGSORT ; BUT COLLECT NON-CONSTANTS
ARSLP: SOJGE Q2,ARS3 ;A INCREMENTED IN SGSORT, LOOP UNTIL DONE
POPJ P, ;ALL DONE WITH THIS ARRAY.
; SUBROUTINE ENTERED WITH A → A STRING DESCRIPTOR. CONVERTS
; IT TO GARBAGE COLLECTOR FORMAT. USES B, C.D,E,TEMP
; START CONTAINS FIRST #CHARS FOR BEGINNING OF STRING SPACE.
; WARNING ***** CLOBBERS B,C,D,E,TEMX **********
SGSORT:
HLLZ B,(A) ;GET STRING NUMBER
JUMPE B,SGSRT ; DON'T COLLECT CONSTANTS OR NULL STRINGS
HRRZ D,1(A) ;MAKE SURE STRING IN RANGE
HRRE C,(A) ;CHECK LENGTH CONSISTENCY
; *** BUG TRAP
JUMPE C,DONBUG ;DON'T WORRY MUCH ABOUT NULL STRINGS
JUMPL C,BUGG
CAMG D,STTOP(USER)
CAMGE D,ST(USER)
BUGG: ERR <DRYROT AT SGSORT>,1
DONBUG:
; *** EBT
HLLZ B,1(A) ;GET POINTER AND SIZE FIELDS OF BP
HRRI B,[BYTE (7) 0,1,2,3,4,5]
ILDB B,B ;#CHARS REPRESENTED BY POINTER
;C HAS ADDR FILED OF BP (SEE ABOVE)
SUB D,ST(USER) ; - STRING SPACE BASE
IMULI D,5 ;#CHARS
ADD B,D ; + CHARS IN POINTER
MOVEM B,1(A) ; TO BP WORD
ADD C,B ; + #CHARS FIELD (D LOADED ABOVE)
HRRZM C,(A) ;TO #CHARS WORD
MOVE D,B ;NOW DISTRIBUTE STRING TO PROPER
IMULI D,MLT ; LIST TO SPEED SORT
IDIV D,INKY(USER) ; SEE ABOVE FOR INKY CALC
ADD D,STBUCK(USER) ;D→PROPER "BUCKET" ENTRY
; *** BUG TRAP
MOVE TEMP,STBUCK(USER)
CAML D,TEMP
CAIL D,BKSZ(TEMP)
ERR <DRYROT AT SGSLUP>,1
; *** EBT
; A→ STRING DESCRIPTOR (MARKED) -- D→BUCKET LIST THIS STRING
; B IS START COUNT [=1(A)] -- C IS END COUNT [=(A)]
SGSLUP: MOVE E,D ;E←CDR(E), IN FACT
HRRZ D,(E) ;D←CDR(E)
SKIPN D ;DONE?
JRST INSERT ; YES, INSERT AT END
HLRZ TEMP,(D) ;TEMP←CAR(D)
CAMGE B,1(TEMP) ;NEW START LESS?
JRST INSERT ;YES, INSERT THIS ONE IN FRONT OF IT
CAME B,1(TEMP) ;NEW START SAME?
JRST SGSLUP ;NO, GREATER
; EQUAL START COUNTS, ARRANGE BY END COUNT, DESCENDING SEQUENCE
CAMG C,(TEMP) ;NEW END GT OLD?
JRST SGSLUP ;NO, CONTINUE
; (JRST INSERT) ;YES
INSERT:
MOVE TEMP,SGFRE(USER)
AOBJN TEMP,STILMOR ;EXPAND LINK SPACE
SGXPND:
PUSH P,TEMP
MOVE B,STBUCK(USER) ;→CURRENT FWS BLOCK
MOVEI C,=100 ;GET 100 MORE
PUSHJ P,CORINC ;EXPAND THE BLOCK
ERR <NO CORE FOR ALLOCATION>
POP P,TEMP
SUB TEMP,[(100)] ;THERE IS MORE
STILMOR:
MOVEM TEMP,SGFRE(USER)
HRLM A,(TEMP)
HRRM D,(TEMP)
HRRM TEMP,(E)
SGSRT: ADDI A,2 ;AUTO-INDEXING
POPJ P,
; FIND A DISJOINT STRING GROUP, MOVE IT BACK.
; MARK POINTERS APPROPRIATELY.
ALLCOL: SUB P,X22 ;REMOVE JUNK PUT ON BY CALSG
SGSWEP:
SETZB T,T1 ;IN CASE NO STRINGS AT ALL
MOVEI Q2,1 ;INIT STRING NO.
MOVE Q3,STBUCK(USER) ;WORK UP BUCKET LIST, HANDLING
MOVEI FF,BKSZ(Q3) ;EVERYTHING IN THE PATH
SUBI Q3,1
PUSHJ P,FSTSTR ;A→FIRST LIST
HLRZ Q1,(A) ;Q1 → FIRST MARKED DESCRIPTOR
JRST SGFX1 ;JUMP INTO THINGS
SGFIX: PUSHJ P,NXTSTR ;A→NEXT LIST ELEMENT
HLRZ Q1,(A) ;Q1 → NEXT DESCRIPTOR
CAMG T1,1(Q1) ;INCLUDED IN OR OVERLAPPING THIS STRING
JRST SGBLT ; NO, MOVE OLD BEFORE HANDLING NEW
PUSHJ P,FIXPTR ;FIX UP DESCRIPTOR
CAMGE T1,TEMP ;OVERLAPPING STRING
MOVE T1,TEMP ; YES, USE BIGGER END POINT
JRST SGFIX ;CONTINUE
SGBLT: ADDI Q2,1 ;INCREMENT STRING NUMBER
MOVN B,T
ADD B,T1 ;TOTAL STRING SIZE
SKIPN SGLIGN(USER) ;HAVE TO ALIGN TO FW BDRY?
JRST NOLIGN ; NO
ADDI B,4 ;YES, DO IT
IDIVI B,5
IMULI B,5 ;NOW MULT OF 5 CHARS, BIG ENOUGH
NOLIGN:
ADDM B,NUMCHR(USER) ;NUMBER USED SO FAR
MOVE C,T ;STARTING COUNT FOR STRING
PUSHJ P,MKBPT ;PICK UP FROM HERE
MOVE T,TOPBYTE(USER) ;PUT DOWN HERE
JUMPE B,SGBLT1 ;DON'T DO IT IF NOT NECESSARY
BLTLUP: ILDB D,C
IDPB D,T ;WHEEE!
SOJG B,BLTLUP ;MOVE 'EM ON OUT
MOVEM T,TOPBYTE(USER) ;RESTORE IT
SGBLT1: JUMPE A,STSTAT ;LAST ONE
SGFX1: MOVE T,1(Q1) ;INITIALIZE START OF STRING,
MOVE T1,(Q1) ; END OF STRING,
MOVE E,T ; OFFSET FOR BP FIXUPS
SUB E,NUMCHR(USER) ; (THIS IS THE OFFSET)
PUSHJ P,FIXPTR ;FIX UP THIS DESCRIPTOR
JRST SGFIX ;CONTINUE
NXTSTR: HRRZ A,(A) ;A←CDR(A)
JUMPN A,APOPJ ; GOT ONE, DONE
FSTSTR: AOS A,Q3 ;END OF THAT LIST, LOOK AT NEXT
CAMGE A,FF ;OOOPS, THERE ARE NO MORE!
JRST NXTSTR ; YES THERE ARE
SUB P,X11 ;DON'T RETURN, BUT MARK DONE,
MOVEI A,0 ; AND GO OFF FOR LAST
JRST SGBLT ; NOSTALGIC MOVE
FIXPTR: MOVE TEMP,(Q1)
SUB TEMP,1(Q1) ;SIZE OF STRING FOR THIS DESCRIPTOR
HRL TEMP,Q2 ;ADD STRING NUMBER
EXCH TEMP,(Q1) ;PUT FIRST WORD AWAY
MOVE C,1(Q1) ;START COUNT
SUB C,E ;ADJUST TO NEW LOCATION
PUSHJ P,MKBPT ;MAKE A BYTE POINTER
MOVEM C,1(Q1) ;THIS BABY IS READY TO FLY!
APOPJ: POPJ P, ;ALL DONE
; MKBPT TAKES A #CHARS IN C, MAKES A BYTE POINTER RELATIVE TO ST
; OUT OF IT, LEAVES IT IN C -- DESTROYS D
MKBPT: IDIVI C,5 ;WORD # IN C, CHAR OFLOW IN D
ADD C,ST(USER) ;REAL WORD #
HLL C,[POINT 7,0
POINT 7,0,6
POINT 7,0,13
POINT 7,0,20
POINT 7,0,27](D) ;POINTER PART
POPJ P,
; FINISH UP
STSTAT:
SKIPN SGLIGN(USER) ;HAVE TO LINE UP TOPBYTE?
JRST NORCLR ;NO
MOVE C,T1 ;END CHAR # OF LAST STRING
SUB C,E ;ADJUST BY THE WINNING OFFSET
PUSHJ P,MKBPT ;MAKE A BP FOR TO BE TOPBYTE
MOVEM C,TOPBYTE(USER) ;FOR THE RIDICULOUS, DEMANDING SAIL
PUSHJ P,RESCLR ;CLEAR REST OF STRING SPACE
;;#GI# DCS 2-5-72 REMOVE TOPSTR
NORCLR: AOS SGCCNT(USER)
MOVN B,STMAX(USER)
IMULI B,5
ADD B,NUMCHR(USER)
;;#GI# DCS 2-2-72 (2-3) LEAVE SOME SLOP SO ONE NEEDN'T FEAR INSET
ADDI B,=15 ;SOME SLOP
ADD B,SGACS+A(USER) ;#CHARS WHICH CAUSED THIS MESS IN FIRST PLACE
MOVEM B,REMCHR(USER)
;;#GI (2-3)
JUMPGE B,[ERR (<STRING SPACE EXHAUSTED, WILL RESTART>,1)
JRST @JOBREN] ;RE-ALLOCATE
MOVE B,STBUCK(USER) ;RELEASE IT
PUSHJ P,CORREL
HRLZI 12,SGACS(USER)
BLT 12,12
POPJ P,
COMMENT ⊗Sgins, Sgrem ⊗
DSCR SGINS
CAL PUSHJ
PAR PUSH P,[routine name]
PUSH P,[addr of 2-word block]
RES block is used to place routine in the list of descriptor generators
for CALSG.
SID stack adjusted
⊗
↑↑SGINS:
PUSH P,-2(P) ;ADDR OF ROUTINE
PUSHJ P,SGREM ;NEVER LET IT BE IN TWICE
MOVE USER,GOGTAB
POP P,UUO1(USER)
POP P,LPSA ;→LINK BLOCK FOR NEW ROUTINE
POP P,-1(LPSA) ;PUT ROUTINE ADDRESS AWAY
HRL LPSA,SGROUT(USER);GET OLD LINK POINTER
HLRM LPSA,(LPSA) ;PUT IN NEW LINK POSITION
HRRM LPSA,SGROUT(USER);PUT NEW POINTER IN LINK HEAD
JRST @3(P) ;RETURN
DSCR SGREM
CAL PUSHJ
PAR PUSH P,[routine addr]
RES routine is removed from list of descriptor generators, if it was on it
⊗
↑↑SGREM:
MOVE USER,GOGTAB
POP P,UUO1(USER)
POP P,TEMP ;ADDR TO BE REMOVED
MOVEI LPSA,SGROUT(USER);HEAD OF LIST
SGRL: MOVE USER,LPSA ;PREV←THIS
SKIPN LPSA,(USER) ;THIS←(PREV)
JRST @2(P) ;DIDN'T FIND IT
CAME TEMP,-1(LPSA) ;IS THIS THE ROUTINE?
JRST SGRL ;NO, GET NEXT
HRRZ TEMP,(LPSA) ;YES, REMOVE IT FROM LIST
HRRM TEMP,(USER)
JRST @2(P)
DSCR STCLER
CAL PUSHJ
RES Clears all string variables on STRLNK(USER) to null strings
DES compiler only
⊗
↑STCLER:
SKIPE SGLIGN(USER) ;CLEAR REST?
PUSHJ P,RESCLR ;CLEAR REST OF STRING SPACE
SKIPN T,STRLNK(USER) ;PARALLELS STRNGC'S LOOP
POPJ P, ;CLOSELY
PUSH P,B ;JUST IN CASE
HRLZI B,-1 ;FOR TESTING STRING NO.
STC1: HRRZ A,-1(T)
HLRZ Q2,-1(T)
STCLLP: SOJL Q2,STCLD1
TDNE B,(A) ;DON'T COLLECT STRING CONSTANTS
SETZM (A)
ADDI A,2
JRST STCLLP
STCLD1: ;SETZM -2(T) ;***** CAN'T DO THIS UNLESS PATSW IS
; *** ON IN COMPILER!!!!!
HRRZ T,(T)
JUMPN T,STC1
POP P,B
POPJ P,
DSCR RESCLR
CAL PUSHJ
DES Used after STRNGC. Clears remaining string space to 0 (compiler only)
⊗
RESCLR: SKIPL A,TOPBYTE(USER) ;CAN ZERO FIRST WORD IF 440700
ADDI A,1 ;ELSE START AT NEXT
SETZM (A)
HRLS A
ADDI A,1 ;BLT WORD
MOVE B,STTOP(USER) ;END OF STRING SPACE
BLT A,-1(B) ;ZERO!!
POPJ P,
INTERNAL BRKMSK
↑BRKMSK: 0
FOR @& JJ←=17,0,-1 <
<1 ⊗ (JJ+=18)> + (1 ⊗ JJ)>
>;NOLOW
ENDCOM (SGC)
IFN ALWAYS,<
NOLOW <
↑CORGET←CORGET
>;NOLOW
>;IFN ALWAYS
SUBTTL GOGOL
SUBTTL Some Runtime Routines Which Could Go Nowhere Else
DSCR BEGIN GOGOL
DES RUN-TIME ROUTINES WILL BE DESCRIBED BY SAIL MANUAL CALLING SEQUENCES ONLY
⊗
NOLOW <
IFN ALWAYS,<BEGIN GOGOL>
>;NOLOW
COMPIL(KNT,<K.ZERO,K.OUT>,<GETCHAN,GOGTAB>
,<K.ZERO, K.OUT -- PERFORMANCE COUNTING ROUTINES>)
COMMENT ⊗ Kounter Routines⊗
DSCR K.ZERO -- Zero out counters
CAL PUSHJ P,K.ZERO
RES The counter arrays of the sail program loaded are set to zero.
K.ZERO determines the location of the counter blocks via the loader
link chain (5) whose head is in the location KNTLNK(USER). If there
are no counters, the routine is essentially a NO-OP. SID All
registers used by K.ZERO are saved on entry and restored on exit. SEE
K.OUT
⊗
HERE(K.ZERO)
PUSH P,2 ;SAVE REGISTER 2
MOVE USER,GOGTAB
SKIPN 2,KNTLNK(USER) ;GET LINK TO COUNTERSS
JRST K.ZR2 ;THERE ARE NONE
PUSH P,3 ;SAVE OTHER REGS NEEDED
PUSH P,4
PUSH P,5
K.Z1: MOVE 3,2(2) ;GET SECOND IOWD OF HEADER BLOCK
MOVEI 4,2(3) ;GET <.KOUNT+1>
HRLI 4,-1(4) ;GET READY FOR BLT
HLRO 5,3 ;GET -COUNT
MOVN 5,5 ;MAKE THAT +COUNT
HRLI 5,3 ;PUT AN INDEX FIELD OF 3
SETZM -1(4) ;ZERO THE FIRST COUNTER
BLT 4,@5 ;ZERO THE REST
SKIPE 2,(2) ;GET THE NEXT SET OF COUNTERS
JRST K.Z1 ;ZERO THEM
POP P,5 ;RESTORE THE REGISTERS
POP P,4
POP P,3
K.ZR2: POP P,2
POPJ P, ;RETURN
DSCR K.OUT -- Write out counters
CAL PUSHJ P,K.OUT
RES The values of the statement counters are written out to the
disk. The IOWDs used to write them are also written out in
order to be able to know how many to read back in. The filename
is obtained from the header block of the first program loaded.
The data blocks have the following form:
--------------------------
| SIXBIT /FILNAM/ |
--------------------------
| LINK to other blocks |
--------------------------
| IOWD 1,.+1 |
--------------------------
| IOWD n,.KOUNT |
--------------------------
| 0 |
--------------------------
.KOUNT: | 1st counter |
--------------------------
| . . . |
| . . . |
--------------------------
| nth counter |
--------------------------
SID No registers are permanently modified.
⊗
HERE(K.OUT)
MOVE USER,GOGTAB
SKIPN KNTLNK(USER) ;ARE THERE ANY COUNTERS
POPJ P, ;NO
COMMENT ⊗ First save registers 0-16
⊗
MOVEM 16,17(P) ;SAVE IN THE STACK
MOVEI 16,1(P) ;GET READY TO STORE 0-15
BLT 16,16(P) ;DO IT
ADD P,[XWD 17,17] ;ADJUST STACK POINTER
TLNN P,400000 ;CHECK FOR OVERFLOW
ERR <PDL overflow in K.OUT routine>
COMMENT ⊗ Before the counters can be written out, it
is necessary to chain the blocks together in the
proper direction. Recall that there will be multiple
blocks only if the core image is the result of loading
multiple compilatons.
⊗
MOVE 2,KNTLNK(USER) ;GET LINK TO LAST BLOCK
SKIPN 1,(2) ;GET LINK TO PREV.
JRST .+5 ;THAT'S ALL
MOVEI 0,1(2) ;GET ADDR OF 1st IOWD OF THIS BLOCK
MOVEM 0,3(1) ;STORE BELOW 2nd IOQS OF PREV BLOCK
MOVE 2,1 ;CONTINUE
JRST .-5
COMMENT ⊗ At this point, 1(2) contains the start of a dump
mode command chain that will write out all of the counters.
-1(2) contains the filename for the counter file.
⊗
PUSHJ P,GETCHAN ;GET AN AVAILABLE CHANNEL
JUMPL 1,K.OERR ;NONE AVAILABLE
MOVE 0,[XWD K.OD1,3] ;MOVE CODE TO REGISTERS
BLT 0,16 ;SO THAT IT CAN BE SAFELY MODIFIED
DPB 1,[POINT 4,3,12] ;STORE CHANNEL NUMBER IN OPEN INSTR
DPB 1,[POINT 4,5,12] ;STORE CHANNEL NUMBER IN ENTER INSTR
MOVE 10,-1(2) ;PICK UP FILE NAME
JRST 3 ;OPEN AND ENTER,HOPEFULLY RETURNING TO .+1
K.O1: MOVE 0,[XWD K.OD2,3] ;DO IT AGAIN
BLT 0,7
DPB 1,[POINT 4,3,12] ;OUT INSTRUCTION
DPB 1,[POINT 4,6,12] ;RELEAS INSTRUCTION
JRST 3
COMMENT ⊗ The counters have been written out to the disk. It's
time to restore the registers and go home.
⊗
K.O2: MOVSI 16,-16(P) ;PREPARE TO RESTORE REGS
BLT 16,16 ; FROM THE STACK
SUB P,[XWD 17,17] ;ADJUST STACK POINTER
POPJ P, ;RETURN
K.OERR: IOERR <I/O error in writing counter file>
COMMENT ⊗ The following instructions are moved into
registers before they are executed, since the "channel"
portion of them must be modified at run time.
⊗
K.OD1: OPEN 0,14 ;(3) OPEN DISK ON SPECIFIED CHANNEL
JRST K.OERR ;(4) TROUBLE
ENTER 0,10 ;(5)
JRST K.OERR ;(6) RIGHT HERE IN RIVER CITY
JRST K.O1 ;(7) READY TO WRITE 'EM OUT
0 ;(10) FILLED IN WITH FILE NAME
SIXBIT /KNT/ ;(11) EXTENSION
0 ;(12)
0 ;(13)
17 ;(14) DUMP MODE
SIXBIT /DSK/ ;(15) DEVICE DISK
0 ;(16) NO BUFFERS
K.OD2: OUT 0,1(2) ;(3) WRITE OUT COUNTERS
JRST 6 ;(4) ALL OK
JRST K.OERR ;(5) PROBLEMS
RELEAS 0 ;(6) CLOSE FILE
JRST K.O2 ;(7) GO BACK TO K.OUT
ENDCOM (KNT)
COMPIL(POW,<FPOW,POW,LOGS,FLOGS,EXP$,LOG$>
,<X11,X33,OVPCWD>,<POW, FPOW, LOGS, FLOGS -- EXPON. ROUTINES>)
DSCR POW, FPOW, LOGS, FLOGS. BOTH RETURN REALS.
SID CLOBBERS LPSA,TEMP,USER
CAL SAIL
DES CALLS GENERATED BY COMPILER FOR ↑ OPERATOR
FPOW: REAL←FPOW(INTEGER!EXPONENT,REAL!BASE)
POW: REAL← POW(INTEGER!EXPONENT,INTEGER!BASE)
LOGS: REAL← LOGS(REAL!EXPONENT,INTEGER!BASE)
FLOGS: REAL←FLOGS(REAL!EXPONENT,REAL!BASE)
SPECIAL CASES:
A↑0 = 1
0↑B = 0 IF B GEQ 0.
0↑B = INF. IF B<0 ; MESSAGE PRINTED
A↑B = (-1)↑B*|A|↑B IF A<0, B INTEGRAL
A↑B = REALPART(A↑B) IF A<0, B NOT INTEGRAL ; MESSAGE
MESSAGE IS PRINTED IF OVERFLOW OR UNDERFLOW HAPPENS.
IN THIS CASE, FIXUP IS MADE SO THAT ANSWER IS EITHER 0, +INF, OR
-INF.
⊗
IFN ALWAYS,< BEGIN UTILS>
HERE(FPOW)
SKIPA USER,-1(P) ;BASE
HERE(POW)
FLOAT USER,-1(P)
FPX: MOVM LPSA,-2(P) ;GET ABS(EXPONENT)
JUMPE LPSA,EXZERO ;0 EXPONENT
MOVSI A,(1.0) ;SET FOR FLOATING
JRST 2,@[FEXS] ;CLEAR AR FLAGS
FEXL: ASH LPSA,-1 ;PREPARE TO LOOK AT NEXT BIT.
FMPR USER,USER ;SQUARE BASE
JFOV FPOWOV ;OVERFLOW/UNDERFLOW
FEXS: TRZE LPSA,1 ;COLLECT PRODUCT?
FMPR A,USER ;YES
JFOV FPOWOV ;OVERFLOW?
JUMPN LPSA,FEXL ;LOOP UNTIL EXPONENT ZERO.
SKIPGE -2(P) ;POSITIVE EXPONENT?
JRST FEXDU1
POWRET: SUB P,X33
JRST @3(P)
FEXDU1: MOVM LPSA,A ;CHECK FOR OVERFLOW POSS.
CAMGE LPSA,[XWD 2400,1] ;SMALL NUMBER
JRST FPDOV ;CALL UNDERFLOW
MOVSI LPSA,(1.0) ;TAKE RECIPROCAL OF ANS.
FDVRM LPSA,A
JRST POWRET ;AND RETURN IT.
EXZERO: SKIPN USER ;0↑0
ZRET: TDZA A,A ;RETURN 0
MOVSI A,(1.0) ;RETURN FLOATING 1
JRST POWRET
FPOWOV: SKIPN TEMP,OVPCWD ;IF TRAPS ENABLED, USE EM
JSP TEMP,.+1 ;ELSE GET FLAGS THIS WAY
TLNE TEMP,100 ;SKIP IF NOT UNDERFLOW
FPDOV: MOVNS -2(P) ;UNDERFLOW -- CHANGE EXPONENT SIGN.
MOVE A,[XWD 400000,1] ;LARGE NEGATIVE NUMBER
SKIPG TEMP,-2(P) ;CHECK SIGN OF EXPONENT.
MOVEI A,0 ;NEGATIVE ==> RESULT 0.
SKIPGE -1(P) ;CHECK SIGN OF BASE.
TRNN TEMP,1 ;XOR SIGN OF EXPONENT.
MOVNS A ;MAKE +- LARGE NUMBER
ERR <Exponentiation under or overflow>,1
JRST POWRET ;RETURN.
HERE(FLOGS)
.FLOGS: SKIPA USER,-1(P) ;FLOATING BASE
HERE(LOGS)
.LOGS: FLOAT USER,-1(P) ;FLOAT THE BASE
SKIPN -2(P) ;IF ZERO EXPONENT,
JRST EXZERO ;GO TO COMMON CODE.
MOVM TEMP,-2(P) ;CHECK TO SEE IF 'FIX' WILL
CAMLE TEMP,C1 ;OVERFLOW
JRST USLGEP ;YES -- GO TO LOG-EXP
FIX TEMP,-2(P) ;CHECK TO SEE IF EXPONENT
FLOAT LPSA,TEMP ;HAPPENS TO BE AN INTEGER
CAMN LPSA,-2(P) ;IF SO, USE LOOPS TO
JRST [MOVEM TEMP,-2(P) ;BE SURE OF CORRECT SIGN
JRST FPX]
USLGEP: JUMPE USER,[SKIPGE -2(P) ;IF BASE ZERO, AND EXPT NEG.
JRST FPDOV ;RETURN LARGE NUMBER
JRST ZRET] ;ELSE RETURN ZERO.
PUSH P,USER ;ARGUMENT TO 'ALOG'
PUSHJ P,.LOG ;CALL IT.
FMPR A,-2(P) ;MULTIPLY BY EXPONENT
PUSH P,A ;ARGUMENT TO 'EXP'
PUSHJ P,.EXP ;CALCULATE
JRST POWRET ;AND RETURN.
C1: 243777777777 ;2↑35 - EPSILON
DSCR EXP,ALOG -- FOR USE BY EXPONENTIATION ROUTINES & WORLD
SID CLOBBERS LPSA,TEMP,USER
CAL SAIL
⊗
;FLOATING POINT SINGLE PRECISION EXPONENTIAL FUNCTION
;THE ARGUMENT IS RESTRICTED TO THE FOLLOWING RANGE
; -88.028<X<88.028
;IF X<-88.028, THE PROGRAM RETURNS ZERO AS THE ANSWER
;IF X<88.028, THE PROGRAM RETURNS X AS THE ANSWER
;THE RANGE OF THE ARGUMENT IS REDUCED AS FOLLOWS:
;EXP(X) = 2**(X*LOG(E)BASE2) = 2**(M+F)
;WHERE M IS AN INTEGER AND F IS A FRACTION
;2**M IS CALCULATED BY ALGEBRAICALLY ADDING M TO THE EXPONENT
;OF THE RESULT OF 2**F. 2**F IS CALCULATED AS
;2**F = 2(0.5+F(A+B*F↑2 - F-C(F↑2 + D)**-1)**-1
;THE ROUTINE HAS THE FOLLOWING CALLING SEQUENCE:
; PUSH P,ARG
; PUSHJ P,EXP
;THE ANSWER IS RETURNED IN ACCUMULATOR A
HERE(EXP$)
.EXP: PUSH P,[0] ;ONE WORKING CELL
PUSH P,B ;AND ONE SAVED AC
MOVE LPSA,-3(P) ;GET ARGUMENT
MOVM A,LPSA ;GET ABSF(X)
CAMG A, E7 ;IS ARGUMENT IN PROPER RANGE?
JRST EXP1 ;YES, GO TO ALGORITHM
ERR <EXP: under or overflow>,1
HRLOI A, 377777 ;GET LARGEST FLOATING NUMBER
SKIPG LPSA ;WAS THE ARGUMENT POSITIVE?
MOVEI A, 0 ;NO, RETURN 0
JRST EXPXIT ;AND RETURN
EXP1: MULI LPSA,400 ;SEPARATE FRACTION AND EXPONENT
TSC LPSA,LPSA ;GET A POSITIVE EXPONENT
MUL TEMP,E5 ;FIXED POINT MULTIPLY BY LOG2(E)
ASHC TEMP,-242(LPSA) ;SEPARATE FRACTION AND INTEGER
AOSG TEMP ;ALGORITHM CALLS FOR MULT. BY 2
AOS TEMP ;ADJUST IF FRACTION WAS NEGATIVE
HRRM TEMP,B ;SAVE FOR FUTURE SCALING
JUMPG USER,ASHH ;GO AHEAD IF ARG GREATER THAN 0
TRNN USER,377 ;ALL THESE BITS 0?
JRST ASHH ;YES -- GO AHEAD
ADDI USER,200 ;NO -- FIX UP
ASHH: ASH USER, -10 ;MAKE ROOM FOR EXPONENT
TLC USER, 200000 ;PUT 200 IN EXPONENT BITS
FADB USER, -1(P) ;NORMALIZE, RESULTS TO USER AND E
FMP USER,USER ;FORM X↑2
MOVE A, E2 ;GET FIRST CONSTANT
FMP A, USER ;E2*X↑2 IN A
FAD USER, E4 ;ADD E4 TO RESULTS IN USER
MOVE LPSA, E3 ;PICK UP E3
FDV LPSA,USER ;CALCULATE E3/(F↑2 + E4)
FSB A,LPSA ;E2*F↑2-E3(F↑2 + E4)**-1
MOVE TEMP,-1(P) ;GET F AGAIN
FSB A, TEMP ;SUBTRACT FROM PARTIAL SUM
FAD A, E1 ;ADD IN E1
FDVM TEMP, A ;DIVIDE BY F
FAD A, E6 ;ADD 0.5
FSC A, (B) ;SCALE THE RESULTS
EXPXIT: POP P,B ;RESTORE AC
SUB P,X33 ;ADJUST STACK
JRST @2(P) ;RETURN.
E1: 204476430062 ;9.95459578
E2: 174433723400 ;0.03465735903
E3: 212464770715 ;617.97226953
E4: 207535527022 ;87.417497202
E5: 270524354513 ;LOG(E), BASE 2
E6: 0.5
E7: 207540071260 ;88.028
;FLOATING POINT SINGLE PRECISION LOGARITHM FUNCTION
;LOG(ABSF(X)) IS CALCULATED BY THE SUBROUTINE, AND AN
;ARGUMENT OF ZERO IS RETURNED AS MINUS INFINITY. THE ALGORITHM IS
;LOGE(X) = (I + LOG2(F))*LOGE(2)
;WHERE X = (F/2)*2↑(I+1), AND LOG2(F) IS GIVEN BY
;LOG2(F) = C1*Z + C3*Z↑3 + C5*Z↑5 - 1/2
;AND Z = (F-SQRT(2))/(F+SQRT(2))
;THE CALLING SEQUENCE FOR THE ROUTINE IS AS FOLLOWS:
; PUSH P,ARG
; PUSHJ P, LOG
;THE ANSWER IS RETURNED IN ACCUMULATOR A
HERE(LOG$)
.LOG:
SKIPGE -1(P) ;CHECK SIGN OF ARGUMENT.
ERR <LOG: Negative argument -- real part returned>,1
MOVM LPSA,-1(P) ;GET ABSF(A)
JUMPE LPSA, LZERO ;CHECK FOR ZERO ARGUMENT
CAMN LPSA, ONE ;CHECK FOR 1.0 ARGUMENT
JRST ZERANS ;IT IS 1.0 RETURN ZERO ANS.
ASHC LPSA, -33 ;SEPARATE FRACTION FROM EXPONENT
ADDI LPSA, 211000 ;FLOAT THE EXPONENT AND MULT. BY 2
MOVSM LPSA,USER ;NUMBER NOW IN CORRECT FL. FORMAT
MOVSI LPSA, 567377 ;SET UP -401.0 IN LPSA
FADM LPSA,USER ;SUBTRACT 401 FROM EXP.*2
ASH TEMP, -10 ;SHIFT FRACTION FOR FLOATING
TLC TEMP, 200000 ;FLOAT THE FRACTION PART
FAD TEMP, L1 ;TEMP = TEMP-SQRT(2.0)/2.0
MOVE LPSA,TEMP ;PUT RESULTS IN LPSA
FAD LPSA, L2 ;LPSA = LPSA+SQRT(2.0)
FDV TEMP,LPSA ;TEMP = TEMP/LPSA
MOVEM TEMP,A ;STORE NEW VARIABLE IN A
FMP TEMP,TEMP ;CALCULATE Z↑2
MOVE LPSA, L3 ;PICK UP FIRST CONSTANT
FMP LPSA,TEMP ;MULTIPLY BY Z↑2
FAD LPSA, L4 ;ADD IN NEXT CONSTANT
FMP LPSA,TEMP ;MULTIPLY BY Z↑2
FAD LPSA, L5 ;ADD IN NEXT CONSTANT
FMP A,LPSA ;MULTIPLY BY Z
FAD A,USER ;ADD IN EXPONENT TO FORM LOG2(X)
FMP A, L7 ;MULTIPLY TO FORM LOGE(X)
LOGXIT: SUB P,X22
JRST @2(P)
LZERO: SKIPA A, MIFI ;PICK UP MINUS INFINITY
ZERANS: MOVEI A,0 ;MARG ANS ZERO
JRST LOGXIT ;AND RETURN
;CONSTANTS
ONE: 201400000000
L1: 577225754146 ;-0.707106781187
L2: 201552023632 ;1.414213562374
L3: 200462532521 ;0.5989786496
L4: 200754213604 ;0.9614706323
L5: 202561251002 ;2.8853912903
L7: 200542710300 ;0.69314718056
MIFI: 400000000001 ;LARGEST NEGATIVE FLOATING NUMBER
ENDCOM (POW)
COMPIL(COD,<CODE,CALL>,<.SKIP.,CVSIX,X22,GOGTAB,X33>,<CODE, CALL>)
DSCR VAL←CODE(OCTAL COMMAND, REFERENCE ARG);
⊗
Comment ⊗CODE
Reference arg is added to octal command. CODAC(USER)
is placed in AC 1. The constructed word is executed, and AC 1 resaved.
Isn't that clever? (AC1 is also returned as the value of the call)
⊗
HERE (CODE) MOVE USER,GOGTAB
SETOM .SKIP. ;ASSUME IT SKIPS
PUSH P,0
MOVE 1,CODAC(USER) ;GET USER'S AC
MOVE 0,-3(P)
ADDI 0,@-2(P) ;CALCULATE THE INSTR DO BE EXECUTED
XCT 0 ;DO IT
SETZM .SKIP. ;DIDN'T SKIP
MOVEM 1,CODAC(USER)
POP P,0
SUB P,X33
JRST @3(P)
DSCR VALUE←CALL(VAL,"FUNCTION");
CAL SAIL
⊗
↑↑.CALL:
HERE (CALL)
SETOM .SKIP. ;ASSUME A SKIP
PUSHJ P,CVSIX ;PARSE SIXBIT
MOVE TEMP,A ;SIXBIT FOR WHAT'S WANTED
MOVE A,-1(P) ;INPUT VALUE
CALL A,TEMP
SETZM .SKIP. ;NO SKIP, RECORD IT
SUB P,X22 ;RETURN VALUE IN 1, WANT IT OR NOT
JRST @2(P)
ENDCOM (COD)
IFN ALWAYS,<BEND UTILS>
SUBTTL STRING HANDLING ROUTINES