perm filename GOGOL.TNX[IMS,AIL] blob
sn#051736 filedate 1973-07-03 generic text, type T, neo UTF8
00100 COMMENT ⊗ VALID 00054 PAGES VERSION 16-2(60)
00200 RECORD PAGE DESCRIPTION
00300 00001 00001
00400 00005 00002 HISTORY
00500 00010 00003 Command File Descriptions
00600 00012 00004 Conditional Assembly Switches, Macros
00700 00016 00005 Titles, Versions
00800 00017 00006 AC Definitions
00900 00018 00007 CDB, SIMIO Indices For IOSER, OTHER INDICES
01000 00022 00008 Base (Low Segment) Data Descriptions -- Macros, Compil spec
01100 00024 00009 Base (Low Segment) Data Descriptions - Params, Links, Size specs
01200 00032 00010 Initialization Routines, Data
01300 00034 00011 Sailor, Reent -- Allocation, Main Program Control
01400 00037 00012 .SEG2. -- Get a second segment
01500 00040 00013
01600 00043 00014
01700 00046 00015
01800 00047 00016 Segment-Fetching Data
01900 00050 00017
02000 00051 00018 %ALLOC -- Main Allocation Routine
02100 00057 00019
02200 00064 00020
02300 00068 00021
02400 00071 00022 Utility Subroutines for allocation
02500 00073 00023 %UUOLNK -- UUO Handler (Dispatch Vector Just Below)
02600 00075 00024 ILLUUO, PDLOV, ERR UUO Handlers
02700 00080 00025
02800 00083 00026 Special Printing Routines For Error Handler
02900 00086 00027 Code to Handle Linkage to Editors
03000 00089 00028
03100 00093 00029 DECPNT, OCTPNT, FIX, FLOAT UUOs
03200 00095 00030 DSPLIN, etc.for Disp. Text Line on Error (Compiler)
03300 00096 00031 SAVE, RESTR, INSET -- General Utility Routines
03400 00100 00032 Core Service Routines -- General Description
03500 00104 00033 Special AC Declarations
03600 00105 00034 Utility Routines
03700 00110 00035
03800 00114 00036 CORGET
03900 00118 00037
04000 00120 00038 CORINC, CANINC
04100 00125 00039 CORREL
04200 00130 00040 CORPRT, CORBIG
04300 00133 00041 String Garbage Collector Routines
04400 00138 00042
04500 00141 00043
04600 00146 00044
04700 00150 00045
04800 00154 00046
04900 00156 00047
05000 00158 00048
05100 00160 00049 Some Runtime Routines Which Could Go Nowhere Else
05200 00161 00050 Kounter Routines
05300 00163 00051
05400 00169 00052
05500 00171 00053
05600 00172 00054
05700 00174 ENDMK
05800 ⊗;
00100 COMMENT ⊗HISTORY
00200 AUTHOR,FAIL,REASON
00300 031 202000000074 ⊗;
00400 DEFINE .VERSION <202000000074>
00500
00600 COMMENT ⊗
00700 VERSION 16-2(60) 2-27-73 BY JRL REMOVE ..RVAL FROM XX AREA
00800 VERSION 16-2(59) 2-12-73 BY JRL ADD ..RVAL TO XX AREA
00900 VERSION 16-2(58) 1-8-73 BY JRL BUG #KV# CHECK FOR NULL INILNK IN .UNIT
01000 VERSION 16-2(57) 12-2-72 BY RHT ENLARGE HERE TABLE
01100 VERSION 16-2(56) 12-1-72 BY RHT ADD DEFSSS,DEFPSS,DEFQNT,DEFPRI TO XX AREA
01200 VERSION 16-2(55) 11-30-72 BY RHT ADD XX ENTRY FOR NOPOLL
01300 VERSION 16-2(54) 11-22-72 BY JRL BUG #KL# STACSV SAVED TOO MANY AC'S IN TOO FEW LOCATIONS
01400 VERSION 16-2(53) 11-22-72
01500 VERSION 16-2(52) 11-22-72
01600 VERSION 16-2(51) 11-17-72 BY RHT MAKE USER INITIALIZATION A SEPARATE PROCEDURE
01700 VERSION 16-2(50) 11-10-72 BY JRL ADD PROPS TO XX AREA
01800 VERSION 16-2(49) 10-12-72 BY RHT ADD PPMAX FOR EXPO VERSION (NEEDED BY ED LNKG)
01900 VERSION 16-2(48) 10-5-72 BY JRL MAKE GLUSER INTERNAL
02000 VERSION 16-2(47) 10-3-72 BY RHT MAKE USER INIT WORK RIGHT
02100 VERSION 16-2(46) 9-24-72 BY JRL FIX LIB ENTRIES FOR PROC. STR GAR COL
02200 VERSION 16-2(45) 9-21-72 BY RHT SCREW UP THE COMPIL MACRO
02300 VERSION 16-2(44) 9-21-72 BY JRL ADD SPRPDA TO SGC COMPIL MACRO
02400 VERSION 16-2(43) 9-11-72 BY JRL ADD GINFTB,GDATM TO LOWER WHEN NO GLOB
02500 VERSION 16-2(42) 9-5-72 BY JRL BAD FIX TO SGLKBK PROBLEM
02600 VERSION 16-2(41) 8-21-72 BY RHT PUT IN JRL'S STACSV &STACRS
02700 VERSION 16-2(40) 8-7-72 BY RHT CHANGE INILNK STUFF
02800 VERSION 16-2(39) 8-7-72 BY KVL PRINT MSG BEFORE CANT CONTINUE ANY FURTHER MSG (P24)
02900 VERSION 16-2(38) 7-3-72 BY DCS BUG #IC# ADD NEW MEANING TO NOSHRK(USER)
03000 VERSION 16-2(37) 7-3-72 BY DCS BUG #IB# MAKE DEFAULT SYSTEM STACK SIZE BIGGER
03100 VERSION 16-2(36) 7-2-72 BY JRL HAVE %ALLOC CALL LPINI IF NEEDED
03200 VERSION 16-2(35) 6-20-72 BY DCS BUG #HU# BETTER TTY PRINTOUT
03300 VERSION 16-2(34) 5-16-72 BY DCS BUG #HI# %ARRSRT TESTS RIGHT BIT FOR STR ARRAY NOW
03400 VERSION 16-2(33) 5-11-72 BY DCS BUG #HE# MODIFY VERSION CHECKING, INSTALL VERSION 16
03500 VERSION 15-6(23-32) 5-3-72 VARIOUS FIXES
03600 VERSION 15-6(14-22) 2-21-72 VARIOUS FIXES
03700 VERSION 15-6(13) 2-19-72 BY RHT THE BRAVE NEW WORLD
03800 VERSION 15-2(12) 2-5-72 BY DCS BUG #GI# REMOVE TOPSTR
03900 VERSION 15-2(11) 2-2-72 BY DCS BUG #GI# LEAVE SOME SLOP IN REMCHR SO CAT'LL BE MORE EFFICIENT
04000 VERSION 15-2(10) 2-1-72 BY DCS REPLACE (FIXED) %ALLOC BLOCK ACCESSES BY SYMBOLIC HEAD-DEFINED ONES
04100 VERSION 15-2(9) 1-30-72 BY DCS REPLACE %ALLOC -- INITIAL ALLOCATION
04200 VERSION 15-2(8) 1-14-72 BY DCS BUG #GA# SEGMENTS HAVE .SEG EXTENSIONS, NOT .REL
04300 VERSION 15-2(7) 1-3-72 BY DCS BUG #FX# REMOVE NEED FOR COM2, REORGANIZE SEGMENT-GETTING STUFF
04400 VERSION 15-2(6) 12-26-71 BY DCS BUG #FU# REENABLE ACCESS FROM ERR UUO TO FTDEBUGGER
04500 VERSION 15-2(5) 12-24-71 BY DCS BUG #FT# DSPLIN BETTER, TV AS VALID EDITOR
04600 VERSION 15-2(4) 12-22-71 BY DCS BUG #FF# SIXPRT(14-15) TO ERR, IOERR ROUTS
04700 VERSION 15-2(3) 12-22-71 BY DCS BUG #FS# REMOVE SAILRUN, COM2, ASSUME COMPILER
04800 VERSION 15-2(2) 12-2-71 BY DCS ADD VERSION SETUP CODE
04900 VERSION 15-2(1) 12-2-71 BY DCS INSTALL VERSION NUMBER
05000
05100 ⊗;
00100 SUBTTL Command File Descriptions
00200 LSTON (GOGOL)
00300 COMMENT ⊗
00400
00500 The following command files make runtime routines:
00600
00700 1. RUN
00800 One assembly, get a non-library, non-2d-segment runtime package
00900
01000 RUNTIM=CALLIS(LR)+HEAD+ORDER+GOGOL+STRSER+IOSER+NWORLD+LEPRUN+MESPRO+WRDGET
01100
01200 2. SGMNT
01300 Makes the non-global UPPER.REL and SAILOW.REL, which when
01400 loaded and run and stuff become SAISGn.SEG and SAILOW.REL,
01500 the 2d segment runtime routines
01600
01700 TAILOR=HEAD+FILSPC+TAILOR/NOLO
01800 LOWER=CALLIS+HEAD+LOW+FILSPC+GOGOL/NOLO
01900 TAILOR.REL,UPPER=CALLIS+HEAD+UP.FAI+ORDER+GOGOL+STRSER+IOSER+
02000 NWORLD+LEPRUN+MESPRO+WRDGET
02100
02200 5. GSGMNT
02300 Makes the global model SAILOW AND UPPER, otherwise like
02400 SGMNT
02500
02600 Same, but add GLB after HEAD in all three.
02700
02800 6. SCISS.SAI
02900 This SAIL program, when run, uses the runtime files to
03000 make a LIBSAI.REL file, the SAIL (lower-segment) library
03100 ⊗
00100 SUBTTL Conditional Assembly Switches, Macros
00200 DSCR ** CONDITIONAL ASSEMBLY SWITCHES **
00300 ⊗
00400
00500 STSW(UPPER,0) ;NOT UPPER OR LOWER IF NEITHER SET
00600 STSW(LOWER,0)
00700 STSW(GLOBSW,0) ;ONLY GLOBAL IF SOMEBODY ELSE SAID SO
00800 STSW(SEGS,0)
00900 STSW(RENSW,0) ;RE-ENTRANT LIBRARY (HISEG) IF ON
01000 STSW(LEAPSW,1) ;ASSUME LEAP
01100
01200 DSCR COMPIL(NAM,ENTRIES,EXTERNALS,DESCRIPTION,INTERNALS,HINHB)
01300 CAL MACRO
01400 PAR NAM IS 3 CHAR NAME -- TITLE WILL BE SAINAM
01500 ENTRIES ARE LIST OF ENTRIES CONTAINED IN THIS
01600 LIBRARY ASSEMBLY (INTERNALS IF NOT LIBRARY SETUP)
01700 EXTERNALS (OPTIONAL) ARE EXTERNALS NEEDED FOR THIS ENTRY.
01800 DESCRIPTION IS OPTIONAL, AND IS USED IN THE SUBTTL
01900 IF PRESENT.
02000 INTERNALS (OPTIONAL) DESCRIBE INTERNALS WHICH ARE NEVER ENTRIES.
02100 HINHB (OPTIONAL ANYTHING), IF NON-BLANK, INHIBITS THE HISEG)
02200 DES IF MAKING A LIBRARY, AND IF THIS FILE IS DESIRED
02300 (SEE SCISS PROGRAM), A FILE OF THE NAME SAINAM.FAI
02400 WILL BE MADE CONTAINING ALL THE PROGRAM TEXT FROM THE
02500 COMPIL MACRO TO THE ENDCOM MACRO WHICH SHOULD FOLLOW
02600 THE CODE FOR THIS ENTRY. ENDCOM DOES AN END IF
02700 IN LIBRARY COMPILE MODE.
02800 RES THE MACRO EXPANDS TO PROVIDE A TITLE AND THE
02900 APPROPRIATE ENTRIES AND EXTERNALS FOR THIS ASSEMBLY.
03000 ALSO A SUBTTL CONTAINING THE TITLE AND OPTIONAL
03100 DESCRIPTION IS PROVIDED.
03200 ⊗
03300 DEFINE COMPIL ' (NAM,ENT,EXT,DSCRP,INT,HINHB,DUMMY) <
03400 IFIDN <DUMMY>,<> <
03500 SUBTTL SAI'NAM -- DSCRP
03600
03700 IFE ALWAYS,<
03800 IFDIF <><ENT>,<ENTRY ENT>
03900 TITLE SAI'NAM
04000 REN <
04100 IFIDN <><HINHB>,<HISEG ;LOAD TO UPPER IF POSSIBLE>
04200 >;REN
04300 IFDIF <><EXT>,<EXTERN EXT>
04400 >;IFE ALWAYS
04500 NOLOW <
04600 IFDIF <><INT>,<INTERN INT>
04700 IFN ALWAYS,<
04800 IFDIF <NAM><LOR>,<
04900 IFDIF <><ENT>,<INTERNAL ENT>
05000 >>
05100 >;NOLOW
05200 >;IFIDN <DUMMY>
05300 >
05400
05500 DEFINE COMPXX ' (NAM,ENT,EXT,DSCRP,INT,HINHB)
05600 <COMPIL(<NAM>,<ENT>,<EXT>,<DSCRP>,<INT>,<HINHB>)>
05700
05800 DEFINE ENDCOM (NAM) <
05900 IFE ALWAYS,<
06000 END
06100 >;IFE ALWAYS
06200 >
06300 ; SWITCHES TO CONTROL LIBRARY COMPILATION
06400
06500 IFNDEF ALWAYS,<↓ALWAYS←←1>
06600
06700 IFN ALWAYS,<DEFINE ENTINT (X) <INTERNAL X>>
06800 IFE ALWAYS,<DEFINE ENTINT (X) <ENTRY X>>
06900
00100 SUBTTL Titles, Versions
00200 DSCR TITLES, VERSIONS
00300 ⊗
00400 IFN ALWAYS,<
00500 ; "TITLE UPPER" IS FOUND IN UP.FAI FILE TO MAKE OUTER PROG TITLED
00600 LOW <
00700 TITLE LOWER
00800 >;LOW
00900 NOUP <
01000 NOLOW <
01100 TITLE RUNTIM -- SAIL RUNTIME ROUTINES
01200 >;NOLOW
01300
01400 JOBVER←←137
01500 LOC JOBVER
01600 ;;#HE# DCS 5-11-72 (1-2) MODIFY VERSION STUFF
01700 .VERSION&777777000000 ;CURRENT VERSION NUMBER (LH ONLY)
01800 ;;#HE# (1-2)
01900 RELOC
02000 LOC 124 ;SET UP REENTER ADDRESS
02100 REENT
02200 RELOC
02300 >;NOUP
02400 >;ALWAYS≠0
02500 EXTERNAL JOBHRL
00100 SUBTTL AC Definitions
00200 DSCR AC DEFINITIONS
00300 ⊗
00400
00500 ; AC DEFINITIONS FOR SERVICE AND RUNTIME ROUTINES
00600
00700 ; ALL UUO ROUTS, IOSER COMMENTS
00800 ; CORE ROUTS,
00900 ; STRING GC,
01000 ; ALLOCATION
01100
01200 ↓FF←←0
01300 ↓A←1 ;TEMPS FOR ALLES
01400 ↓B←2 ; (SOMETIMES SAVED)
01500 ↓C←3
01600 ↓D←4
01700 ↓E←5 ↓X←5 ;MORE TEMPS
01800 ↓Q1←6 ↓Y←6
01900 ↓Q2←7 ↓Z←7
02000 ↓Q3←10 ↓Q←10
02100 ↓T←11 ↓CDB←11 ;CHANNEL DATA BLOCK PTR
02200 ↓T1←12 ↓CHNL←12 ;CHNL # FOR IOSER
02300 ↓LPSA←13 ;TEMP, PARAM AC
02400 ↓TEMP←14 ;TEMP ONLY
02500 ↓USER←15 ;→USER TABLE FOR RNTRNT ROUTS
02600 ↓SP←16 ;STRING STACK
02700 ↓P←17 ;SYSTEM STACK
00100 SUBTTL CDB, SIMIO Indices For IOSER, OTHER INDICES
00200
00300 DSCR -- CDB, SIMIO INDICES FOR IOSER
00400 DES The I/O routines obtain their information from the user via a
00500 channel number -- the same kind used by the system. In order to
00600 find byte pointers, counts, file names, etc., the channel number is
00700 used to index into a block of core called a CDB (Channel Data Block).
00800 This CDB is filled with good data during the OPEN operation.
00900 The CDB, and all I/O buffers, are obtained from CORGET.
01000 The CHANS table in the GOGTAB area is a 20 word block containing
01100 pointers to the appropriate CDB's.
01200 Since channel numbers must appear in the AC field of IO instructions,
01300 one must construct IO insts. in impure places to retain re-entrancy.
01400 XCT INDEX,SIMIO executes the appropriate IO instruction with the
01500 channel number from AC CHNL, used by all routines. See SIMIO for
01600 operational details.
01700 ⊗
01800
01900 ; SIMIO INDICES FORMAT OF CDBs
02000
02100 DMODE ←← 0 ↔↓IOSTATUS ←← 0 ;DATA MODE ;RETURN STATUS
02200 DNAME ←← 1 ↔↓IOIN ←← 1 ;DEVICE ;BUFFERED INPUT
02300 BFHED ←← 2 ↔↓IODIN ←← 2 ;HEADER POINTERS ;DUMP INPUT
02400 ↓IOOUT ←← 3 ;BUFMODE OUT.
02500 OBPNT ←← 3 ↔↓IODOUT ←← 4 ;OUTPUT BUF. PTR ;DUMP OUTPUT
02600 OBP ←← 4 ↔↓IOCLOSE ←← 5 ;OUTPUT BYTE PTR ;CLOSE FILE
02700 OCOWNT ←← 5 ↔↓IORELEASE←← 6 ;OUTPUT BYTE CNT ;RELEASE FILE
02800 ONAME ←← 6 ↔↓IOINBUF ←← 7 ;OUTPUT FILE NAM ;INBUF
02900 OBUF ←← 7 ↔↓IOOUTBUF ←←10 ;OUTPUT BUFFER LOC. ;OUTBUF
03000 ↔↓IOSETI ←←11 ;USETI
03100 IBPNT ←←10 ↔↓IOSETO ←←12 ;SAME FOR INPUT ;USETO
03200 IBP ←←11 ↔ ; 13 UNUSED
03300 ICOWNT ←←12 ↔↓IOOPEN ←←14 ;OPEN CHANNEL
03400 INAME ←←13 ↔↓IOLOOKUP ←←15 ;LOOKUP FILE
03500 IBUF ←←14 ↔↓IOENTER ←←16 ;ENTER FILE
03600 ↔↓IORENAME ←←17 ;RENAME FILE
03700
03800 ICOUNT ←←15 ;INPUT DATA COUNT LIMIT ADDRESS
03900 BRCHAR ←←16 ;XWD TTYDEV FLAG, INPUT BREAK CHAR ADDR
04000 TTYDEV ←←16 ;LH -1 IF DEVICE IS A TTY -- USED BY OUT
04100 ENDFL ←←17 ;INPUT END OF FILE FLAG ADDR
04200 ERRTST ←←20 ;USER ERROR BITS SPECIFICATION WORD
04300 PGNNO ←←20 ;PAGE NUMBER FOR DISPLAY FEATURE (IF FEATURE NOT INCLUDED)
04400 NOEXPO <
04500 PGNNO ←←21 ;SAME THING IF IT IS INCLUDED
04600 >;NOEXPO
04700 ↑IOTLEN ←←PGNNO+1 ;LENGTH OF TABLE ENTRY
04800
04900 ↓LUPDL←30 ;LENGTH OF UUO PDL
05000 ↓MINPDS←←=64 ;SMALLEST ALLOWABLE SYSTEM PDL SIZE
05100 ↓DEFPDS←←=192 ;DEFAULT PDL SIZE
00100 SUBTTL Base (Low Segment) Data Descriptions -- Macros, Compil spec
00200
00300 DSCR DATA DESCRIPTIONS, TAILORED FOR TWO SEGMENT OPERATION
00400 ⊗
00500
00600 NOUP <
00700 DEFINE SGLK (ROUT,NAM,INT) <
00800 XX (NAM,ROUT,INT) ;NAME OF STRING DSCRPTR GENERATING ROUTINE
00900 XX (,0,) ;PLACE TO PUT A LINK
01000 LINK %SGROT,.-1 ;WHEREWITHAL TO GENERATE SAID LINK
01100 >
01200 >;NOUP
01300 UP <
01400 DEFINE SGLK (ROUT,NAM) <
01500 XX (NAM,ROUT,)
01600 XX (,0,)
01700 >
01800 >;UP
01900
02000 DEFINE XX (A,B,C,D) <
02100 IFDIF <A><>,<↓ A :> B
02200 IFDIF <C><>,< C A >>>
02300 UP <
02400 III←←140
02500 DEFINE XX (A,B,C,D) <
02600 IFDIF <A><>,<↓ A ← III >
02700 III ←← III + 1
02800 IFDIF <D><>,<III←III+D-1>
02900 >
03000 >;UP
03100
03200
03300 COMPIL(LOR,<SAILOR,.SEG2.>
03400 ,<%UUOLNK,%ALLOC,%SPGC,%STRMRK,%ARRSRT,K.OUT,K.ZERO>
03500 ,<BASE DATA, INITIALIZATION CONTROL>
03600 ,<X11,X22,X33,X44>,INHIBIT)
00100 SUBTTL Base (Low Segment) Data Descriptions - Params, Links, Size specs
00200
00300 ; UNIVERSAL VARIABLES -- BASES OF MAJOR DATA STRUCTURES, GLOBAL FLAGS
00400
00500 XX (GOGTAB,0,INTERNAL) ;→USER TABLE
00600 XX (DATM,0,INTERNAL) ;XWD 3,→DATUM TABLE
00700 XX (LKSTAT,0,INTERNAL) ;STATUS OF GLOBAL LEAP MODEL INTERLOCK (SHOULD BE IN GOGTAB
00800 XX (INFTB,0,INTERNAL) ;XWD 2,→INFOTAB TABLE
00900 XX (.SKIP.,0,INTERNAL) ;RECORD AUX RESULTS OF RUNTIMES
01000 XX (RPGSW,0,INTERNAL) ;SET IF (JOBSA)+1 USED TO START
01100 XX (%RENSW,0,INTERNAL) ;SET IF USER REENTERS TO SPECIFY ALLOC
01200 XX (CONFIG,0,INTERNAL) ;0 FOR RUNTIME, <0 FOR COMPILER
01300 XX (ERRSPC,0,INTERNAL) ;ADDR OF COMPILER'S ERROR AUGMENTOR
01400 XX (RUNNER,0,INTERNAL) ;THE CURRENTLY RUNNING PROCESS(IF HAVE THEM)
01500 XX (INTRPT,0,INTERNAL) ;MASK FOR INTERRUPT POLLING
01600 XX (PROPS,0,INTERNAL) ;BYTE POINTER FOR ACCESSING PROPS(ITEM) ITEM IN 3
01700 XX (NOPOLL,0,INTERNAL) ;≠0 →→ IGNORE CALL TO DDFINT
01800 XX (DEFSSS,0,INTERNAL) ;DEFAULT S-STACK SIZE -- SET BY MAINPR
01900 XX (DEFPSS,0,INTERNAL) ;DEFAULT P-STACK SIZE (FOR PROCESSES) -- DITTO
02000 XX (DEFPRI,0,INTERNAL) ;DEFAULT PRIORITY -- DITTO
02100 XX (DEFQNT,0,INTERNAL) ;DEFAULT QUANTUM -- DITTO
02200 XX (S1PARE,0) ;SPARE LOWER LOCATIONS
02300 XX (S2PARE,0) ;SPARE LOWER LOCATIONS
02400 XX (S3PARE,0)
02500 XX (S4PARE,0)
02600 XX (S5PARE,0)
02700 GLOB <
02800 XX (GSPARE,<BLOCK 2>,,2)
02900 >;GLOB
03000 NOGLOB <
03100 XX (GDATM,0,INTERNAL) ;DUMMY GLOBAL DATUM TABLE SHOULD ALWAYS BE ZERO
03200 GPROPS←GINFTB←GDATM ;DUMMY GLOBAL INFOTAB DITTO
03300 INTERNAL GINFTB,GPROPS
03400 >;NOGLOB
03500
03600 ; STATIC LINKAGES -- FEATURE PROVIDED BY LOADER
03700 ; THESE ARE THE BASES OF ONE-WAY LINKED LISTS WHICH ALLOW ACCESS
03800 ; TO SELECTED DATA IN ALL LOADED MODULES
03900
04000 XX (STLNK,0,INTERNAL) ;1 ALL STRINGS TIED TOGETHER FOR STRNGC
04100 XX (SPLNEK,0,INTERNAL) ;2 ALL SPACE REQUESTS (PDLS, ETC.)
04200 XX (SETLET,0,INTERNAL) ;3 ALL SET VARIABLES TIED TOGETHER
04300 XX (SGROT,0,INTERNAL) ;4 LIST OF STRNGC SORTER GENERATORS
04400 XX (KTLNK,0,INTERNAL) ;5 ALL COUNTER BLOCKS
04500 XX (INILNK,0,INTERNAL) ; INITIALIZATION ROUTINES (LPINI ONLY NOW)
04600
04700 SYSPHS←←2 ;TWO SYSTEM PHASES
04800 USRPHS←←1 ;TWO USER PHASES (FOR NOW)
04900
05000 ; THESE OPS INFORM THE LOADER OF THE ABOVE BASE LOCATIONS.
05100
05200 NOUP <
05300 LINKEND %STLNK,STLNK
05400 LINKEND %SPLNK,SPLNEK
05500 LINKEND %SETLK,SETLET
05600 LINKEND %SGROT,SGROT
05700 LINKEND %KTLNK,KTLNK
05800 LINKEND %INLNK,INILNK
05900 >;NOUP
06000
06100 ; SOME ROUTINES WHICH GO ON THE SGROT LIST (SEE SGLK)
06200 ;↑SGLKBK
06300 SGLK (%ARRSRT,SGLKBK,INTERNAL);ROUTINE TO COLLECT STRING ARRAYS
06400 SGLK (%STRMRK) ;ROUTINE TO COLLECT STRING VARIABLES
06500 SGLK (%SPGC) ;ROUTINE TO COLLECT STRING STACK
06600
06700
06800 ;HERE IS THE LIST OF DEFAULT SPACE ALLOCATION ENTRIES
06900 XX (%SPL,<BLOCK $SPREQ-2>,INTERNAL,$SPREQ-2);DUMMY FIXED ADDR STUFF
07000 XX (%STDLST,<BLOCK 2>,INTERNAL,2) ;BASE OF BUILT-IN REQUESTS
07100 XX (,<XWD WNTPDP!MINSZ!USRTB,DEFPDS>) ;SYSTEM_PDL (SPECIAL, SEE BELOW)
07200 XX (,<XWD [ASCIZ /SYSTEM_PDL/],PDL>)
07300 XX (,<XWD WNTPDP!USRTB!MINSZ,50>) ;STRING STACK
07400 XX (,<XWD [ASCIZ /STRING_PDL/],SPDL>)
07500 XX (,<XWD WNTADR!WNTEND!USRTB!MINSZ,2000>);STRING_SPACE
07600 XX (,<XWD [ASCIZ /STRING_SPACE/],ST>)
07700 XX (,0) ;THAT'S ALL
07800 ; LINK %SPLNK,%SPL ;%ALLOC DOES THIS EXPLICITLY SO THIS
07900 ;BLOCK WILL BE FIRST
08000
08100 ;SOME RANDOM GLOBALLY USEFUL THINGS, WHICH UNFORTUNATELY HAVE TO
08200 ;BE IN FIXED LOCATIONS (FOR THE RUNTIMES TO FIND)
08300
08400 XX (ALLPDP,<IOWD 20,ALLPDL>,INTERNAL);USED FOR A WHILE DURING ALLOC
08500 XX (ALLPDL,<BLOCK 20>,INTERNAL,20) ;AND IN PROCESS TERMINATION
08600 XX (%ALLCHR,0,INTERNAL)
08700 XX (%OCTRET,0,INTERNAL)
08800 XX (%ERGO,0,INTERNAL) ;ON IF LF TYPED TO ERR. GUY
08900 XX (%RECOV,0,INTERNAL) ;ON IF RECOVERY FROM ERR. IS POSSIBLE
09000 XX (DPYSW,0,INTERNAL) ;ON IF CONSOLE IS DPY
09100 XX (%UACS,<BLOCK 20>,INTERNAL,20) ;UUOCON ACS
09200 XX (%UPDL,<BLOCK LUPDL+1>,INTERNAL,LUPDL+1) ;UUOCON PDL
09300 NOEXPO <
09400 XX (PGDS,<PGDS0>,INTERNAL) ;PIECE OF GLASS FOR LINE BREAK ON INPUT
09500 XX (,7,)
09600 XX (PGDS0,0,)
09700 XX (,<AIVECT (300,200)>,)
09800 XX (,<ASCID /PAGE/>,)
09900 XX (,<ASCID / />,)
10000 XX (,<ASCID /LINE />,)
10100 XX (,<ASCID / />,)
10200 XX (,<DPYJMP PGDS0>,)
10300 >;NOEXPO
10400
10500 ;SOME WONDERFULLY USEFUL CONSTANTS
10600
10700 XX (X11,<XWD 1,1>,INTERNAL)
10800 XX (X22,<XWD 2,2>,INTERNAL)
10900 XX (X33,<XWD 3,3>,INTERNAL)
11000 XX (X44,<XWD 4,4>,INTERNAL)
11100
00100
00200 EXPO <
00300 NOTENX<
00400 XX (PPMAX,<BLOCK 3>,INTERNAL,3) ;FOR SCREWY EDITOR LINKAGE
00500 >;NOTENX
00600 >;EXPO
00700 TENX<
00800 ;TENEX will in general be much freer about using XX variables
00900 XX (CHNTAB,<BLOCK =36>,INTERNAL,=36)
01000 XX (LEVTAB,LPC1,INTERNAL)
01100 XX (,LPC2,)
01200 XX (,LPC3,)
01300 XX (LPC1,0,)
01400 XX (LPC2,0,)
01500 XX (LPC3,0,)
01600 XX (DFIBP,0,INTERNAL) ;Ptr for stepping thru DFI buffer
01700 ;DFI=Deferred Interrupt Buffer
01800 XX (DFIBT,0,INTERNAL) ;Ptr to top of it
01900 XX (LSTDFI,0,INTERNAL) ;Trailing ptr for stepthru - Last DFI
02000 XX (DFIBUF,0,INTERNAL) ;Ptr to DFI buffer
02100 XX (JFNTBL,<BLOCK JFNSIZE>,INTERNAL,JFNSIZE)
02200 XX (CDBTBL,<BLOCK JFNSIZE>,INTERNAL,JFNSIZE) ;Addr. of chnl data buffer for each chnl
02300 XX (PRTMP,0,INTERNAL)
02400 XX (CTLOSW,0,INTERNAL) ;CTRL-O SWITCH
02500 >;TENX
02600
02700
02800
00100 ;SINCE UUO TRIGGERING IS NON-RE-ENTRANT, THIS IS THE PLACE WHERE IT HAPPENS
00200
00300 XX (UUO0,0,INTERNAL) ;JSR RETURN STORED HERE
00400 ↓UUCOR←UUO0
00500 NOUP <
00600 JRST %UUOLNK ;GO HANDLE UUO
00700 >;NOUP
00800
00900 LOW <
01000 EXTERNAL LPINI
01100 LPLK: 0
01200 LPINI
01300 0
01400 LINK %INLNK,LPLK
01500 >;LOW
01600
00100 SUBTTL Initialization Routines, Data
00200
00300 COMMENT ⊗ The Run-Time I/O handling routines are re-entrant. This
00400 means that any modifiable words or parameters particular to a given
00500 user must come from the user's core image. The pointer to this area
00600 will be found in GOGTAB in the lower segment. The I/O routines use
00700 some of the AC'S in standard ways, described above with AC definitions.
00800 ⊗
00900
01000 DSCR SAILOR -- ALLOCATION AND INITIALIZATION ROUTINES
01100 CAL JSR
01200 DES
01300
01400 Part of this is not yet reentrant. In particular,
01500 it is called by a JSR SAILOR
01600 The functions of this routine are:
01700
01800 1. Get a second segment, if this is a SAISEG-program
01900 2. Process space requests, allow user-override if REENTER used
02000 to start.
02100 3. Use %ALLOC to allocate requested regions.
02200 4. Clear Kounters
02300 5. Change starting and re-entry addresses,
02400 6. PUSHJ to user program
02500 7. Record Kounters, RESET and quit.
02600 ⊗
00100 SUBTTL Sailor, Reent -- Allocation, Main Program Control
00200
00300 NOUP <
00400 ;SAIL job calls SAILOR first time, with RPGSW set up already
00500
00600 INTERNAL SAILOR
00700
00800 TENX <
00900 EXTERNAL .RESET,CORGET,INDFIB
01000 >; TENX
01100 ↑SAILOR: 0 ;JSR to SAILOR
01200 JRST FRSTRT ;GET A SEGMENT, START UP
01300
01400 ; REENTER to manually change allocation, and to flush REQUIREd segments
01500
01600 ↑REENT: SETOM %RENSW ;RE-ENTER -- ASK FOR NEW ALLOC
01700
01800 ;SAIL STARTS HERE WHEN USER TYPES S<T<A<R<T>>>> AGAIN
01900
02000 ↑RESTRT:TDZA TEMP,TEMP ;ESTABLISH OPERATING MODE
02100 MOVNI TEMP,1 ;RPG MODE
02200 MOVEM TEMP,RPGSW ;RECORD IT
02300 FRSTRT: JSP P,.SEG2. ;GET SECOND SEGMENT
02400
02500 STRT:
02600 NOTENX<
02700 CALL6 (0,RESET)
02800 >;NOTENX
02900 SETZM GOGTAB ;FORCE CORSER RE-INITIALIZATION
03000 SETNIT ;GET TEMP STACK, IF NECESSARY
03100 JSP 16,%ALLOC ;ALLOCATE AREAS
03200
03300 TENX<
03400 PUSHJ P,.RESET ;RESET TENEX IO, CLEAR SAIL FILE BOOK-KEEPING
03500 HRRZI A,400000
03600 MOVE B,[XWD LEVTAB,CHNTAB]
03700 JSYS SIR
03800 ;This is where to put any code to init. any interrupts that we
03900 ;decide to keep always on, e.g. if we try to do anything about
04000 ;general PDLOV or whatever
04100
04200
04300 ;This allocates the space for the DFI buffer. Should probably
04400 ;be done by ALLOC for uniformity but I'm too lazy now.
04500 HRRZI C,=128 ;Initial size, resettable
04600 PUSHJ P,CORGET
04700 ERR <Can't allocate DFIBUF -- SAILOR>
04800 MOVEM B,DFIBUF
04900 ADDI B,=124 ;Leave a few holes for luck
05000 MOVEM B,DFIBT
05100 PUSHJ P,INDFIB ;Routine to init. buff.
05200
05300 >;TENX
05400
05500 MOVEI A,RESTRT ;CHANGE JOBSA AND JOBREN
05600 HRRM A,JOBSA ;"S" USES OLD ALLOCATION
05700 MOVEI A,REENT ;"REE" ASKS QUESTIONS AGAIN
05800 MOVEM A,JOBREN
05900 PUSHJ P,K.ZERO ;ZERO OUT THE COUNTERS
06000 PUSHJ P,INILST ;GO DO ALL OTHER INITIALIZATIONS
06100 PUSHJ P,@SAILOR ;CALL USER PROGRAM
06200 PUSHJ P,K.OUT ;WRITE OUT THE COUNTERS
06300 TERPRI <END OF SAIL EXECUTION>
06400 NOTENX<
06500 CALL6 (0,RESET) ;CLEAR THE I/O WORLD
06600 CALL6 (1,EXIT) ;QUIT QUIETLY
06700 >;NOTENX
06800 TENX<
06900 PUSHJ P,.RESET
07000 JSYS HALTF
07100 JRST .-1 ;No continuation
07200 >;TENX
07300
07400 INILST:
07500 SKIPN TEMP,INILNK
07600 POPJ P,
07700 MOVE USER,GOGTAB ;JUST TO BE SURE
07800 SKIPA A,[XWD -SYSPHS,0] ;XWD #SYS PHASES,0
07900 DOPHS: HRRZ TEMP,INILNK ;LIST OF THEM
08000 NXLNK:
08100 PUSH P,TEMP ;SAVE LINK
08200 NXIN: ADDI TEMP,1 ;LOOK AT NNEXT ENTRY
08300 SKIPN B,(TEMP) ;END OF LINK LIST
08400 JRST NXIN.1 ;YES
08500 HLRZ C,B ;PHASE NUMBER OF THIS
08600 CAIE C,(A) ;THIS PHASE
08700 JRST NXIN ;NO
08800 PUSH P,A
08900 PUSH P,TEMP
09000 PUSH P,USER
09100 PUSHJ P,(B)
09200 POP P,USER
09300 POP P,TEMP
09400 POP P,A
09500 JRST NXIN ;GO DO NEXT IN THIS
09600 NXIN.1: POP P,TEMP
09700 HRRZ TEMP,(TEMP)
09800 JUMPN TEMP,NXLNK
09900 NXPHS: AOBJN A,DOPHS ;GO ON TO NEXT PHASE
10000 POPJ P, ;
10100
10200 INTERNAL .UINIT
10300 .UINIT: MOVE A,[XWD -USRPHS,400000] ;DO USER PHASES
10400 ;; #KV# MAKE SURE LINK NON-NULL
10500 SKIPN INILNK
10600 POPJ P,
10700 ;; #KV#
10800 JRST DOPHS
00100 SUBTTL .SEG2. -- Get a second segment
00200
00300 COMMENT ⊗ Initialize the second segment, if there is none and if desired.
00400 This occurs when the program is first started. This is a dummy routine
00500 if not a SAISEG-program
00600 ⊗
00700
00800 INTERNAL .SEG2.
00900 .SEG2.:
01000 LOW <
01100 NOTENX<
01200 SKIPE JOBHRL ;IS THERE A SEGMENT?
01300 >;NOTENX
01400 TENX<
01500 MOVE 1,[XWD 400000,650] ;THIS FORK, PAGE 650
01600 JSYS RPACS
01700 TLNE 2,(1B5) ;DOES PAGE 650 EXIST??
01800 >;TENX
01900 >;LOW
02000 JRST (P) ; YES, GO AHEAD (OR ALWAYS, IF NOLOW)
02100 >;NOUP
02200
02300 LOW <
02400 NOTENX<
02500 ;This isn't closed for about 4 pages
02600
02700 COMMENT ⊗ Now, if global model, get segment specifications from space blocks
02800 of compiled programs (via REQUIRE verbs in source code).
02900 Segment name business is ignored in EXPO version, since segment and file
03000 names are always equivalent (philosophical differences).
03100 ⊗
03200
03300 SEGTR: ;TRY AGAIN
03400 GLOB <
03500
03600 SKIPN %RENSW ;IS LINK-TABLE AND/OR PREVIOUSLY COLLECTED
03700 ; INFORMATION INVALID??
03800 JRST SEG3 ;NO
03900 FOR II⊂(SEGDEV,SEGFIL,SEGPPN,NMSAV) <
04000 SETZM II
04100 >
04200 JRST ASKEM ;CLEAR ALL NON-USER SPECIFIED INFO
04300
04400 SEG3: SKIPN B,SPLNEK ;A SPACE BLOCK AROUND??
04500 JRST ASKEM ; NO
04600 GSGLP: SKIPE A,$SGD(B) ;DEVICE REQUEST
04700 MOVEM A,SEGDEV
04800 SKIPE TEMP,$SGF(B) ;FILE NAME FOR UPPER SEGMENT
04900 MOVEM TEMP,SEGFIL
05000 SKIPE TEMP,$SGPP(B) ;PPN FOR SAME
05100 MOVEM TEMP,SEGPPN
05200 SKIPE TEMP,$SGNM(B) ;SEGMENT NAME (UNUSED IN EXPO VERSION)
05300 MOVEM TEMP,NMSAV
05400 SKIPE B,(B) ;GO DOWN LINKED LIST
05500 JRST GSGLP ; UNTIL EMPTY
05600 >;GLOB
00100
00200 COMMENT ⊗ If not enough information was supplied (global model only),
00300 ask questions of user to obtain file names, etc. Also (NOEXPO only),
00400 try to ATTSEG to a segment of the desired name. In the EXPO version,
00500 all this is combined in the GETSEG below.
00600 ⊗
00700 NOEXPO < ;SEGMENT NAME NOT USEFUL TO EXPO SYSTEM
00800 GLOB <
00900 SKIPE A,NMSAV ;DID WE GET A SEGMENT?
01000 JRST GOTEM ; YES, TRY TO LINK TO IT
01100
01200 ASKEM: TERPRI <SEGMENT LOGICAL NAME?>
01300 JSR GGNAM ;GET A SEGMENT NAME.
01400 GOTEM: MOVEM A,NMSAV
01500 >;GLOB
01600 NOGLOB <
01700 MOVE A,[FILXXX] ;TRY TO FIND IT.
01800 >;NOGLOB
01900 CALLI A,400016 ;ATTSEG.
02000 SKIPA ;NO LUCK
02100 JRST (P) ;OK, DONE
02200 HRRZ B,A ;GET FAILURE CODE.
02300 CAIE B,1 ;AMBIGUITY?
02400 JRST GETSE ;NO -- GET THE SEGMENT.
02500 HLRZS A
02600 CALLI A,400016 ;ATTSEG.
02700 JSP A,ERSEG
02800 JRST (P) ;OK, GOT IT
02900 >;NOEXPO
03000 EXPO <
03100 ASKEM: ;MISPLACED LABEL
03200 >;EXPO
03300 GETSE: CALL6 (0,RESET)
03400 GLOB <
03500 SKIPE A,SEGFIL ;WAS ONE "REQUIRE"D?
03600 JRST THSFL ; YES, USE IT
03700 TERPRI <SEGMENT FILE NAME?>
03800 MOVE A,[FILXXX] ;DEFAULT
03900 JSR GGNAM
04000 THSFL: MOVEM A,SEGFIL ;NAME OF SEGMENT.
04100 THSFL1: SKIPE A,SEGDEV ;WAS A DEVICE REQUESTED?
04200 JRST THSDV ; YES
04300 TERPRI <DEVICE?>
04400 MOVE A,[SGDEVC] ;DEFAULT DEVICE
04500 JSR GGNAM
04600 MOVEM A,SEGDEV
04700 CAMN A,['DSK '] ;ASK FOR PPN IF DISK
04800 SKIPE SEGPPN ;AND PPN=0
04900 JRST THSDV ;DON'T ASK, ALREADY THERE
05000 TERPRI <PPN?>
05100 MOVE A,[SGPPNN] ;DEFAULT PPN
05200 JSR GGNAM
05300 MOVEM A,SEGPPN
05400 JRST THSFL1 ;NOW HAVE A DEVICE
05500 THSDV: MOVEM A,INTT
05600 MOVE A,[XWD SEGDEV,DEVSEG] ;MOVE LOOKUP SPEC IN
05700 BLT A,SEGNAM+3
05800 >;GLOB
05900 NOGLOB <
06000 SETZM SEGNAM+2
06100 MOVE TEMP,[SGPPNN]
06200 MOVEM TEMP,SEGNAM+3 ;SET UP PPN
06300 HLLZS SEGNAM+1
06400 >;NOGLOB
00100
00200 COMMENT ⊗ Now work is nearly done in EXPO system, but all sorts of hair
00300 remains otherwise. In either case, now get segment in, get it into 2d
00400 segment, name it right
00500
00600 ⊗
00700 NOEXPO <
00800 INIT 1,17
00900 INTT: SGDEVC ;GO GET THE RAW SEGMENT
01000 0
01100 JSP A,ERSEG
01200 LOOKUP 1,SEGNAM
01300 JSP A,ERSEG
01400 MOVS A,SEGNAM+3 ;WORD COUNT
01500 HRLM A,LIOD ;WORD COUNT FOR DUMP MODE.
01600 MOVNS A
01700 HRRO D,JOBREL ;FOR LATER
01800 HRRM D,LIOD ;PLACE TO START DUMP MODE INPUT.
01900 ADD A,JOBREL ;TO GET THE AMOUNT OF CORE NEEDED.
02000 CALLI A,11 ;CORE UUO ----
02100 JSP A,ERSEG
02200 LOP22: INPUT 1,[LIOD: IOWD 200,%UPDL
02300 0]
02400 GLOB <
02500 TLZ D,-1 ;NO, MAKE IT WRITEABLE IF GLOBAL MODEL.
02600 >;GLOB
02700 IFN NOPROT,<
02800 TLZ D,-1 ;MAKE WRITEABLE IF REQUESTED TO
02900 >;NOPROT≠0
03000 CALL D,[SIXBIT/REMAP/] ;
03100 JSP A,ERSEG
03200 NOGLOB <
03300 MOVE A,[FILXXX]
03400 >;NOGLOB
03500 GLOB <
03600 MOVE A,NMSAV
03700 >;GLOB
03800 CALLI A,400036 ;SETNM2
03900 JRST [MOVEI A,0
04000 CALLI A,400015 ;CORE2
04100 JSP A,ERSEG
04200 GLOB <
04300 SETOM %RENSW ;FORCE TTY RITUAL
04400 >;GLOB
04500 JRST SEGTR] ;TRY AGAIN.
04600 CALLI
04700 >;NOEXPO
04800
04900 EXPO <
05000 SETZM SEGNAM+4 ;CLEAR LAST TWO WORDS OF GETSEG BLOCK
05100 SETZM SEGNAM+5
05200 MOVEI A,DEVSEG ;GET READY
05300 MOVEM P,SAVPP
05400 CALL A,[SIXBIT /GETSEG/] ;GET THE SEGMENT
05500 JSP A,ERSEG ; COULDN'T
05600 MOVE P,SAVPP
05700 ; NO WAY TO RENAME 2D SEGMENT, SO DON'T WORRY ABOUT IT
05800 >;EXPO
05900
06000 JRST (P) ;RETURN
06100
06200
06300 >;NOTENX
06400 ;Closing from about 4 pp back
06500 ;Now the TENEX stuff to find and attach to the segment.
06600 TENX<
06700 HRLZI 1,100001
06800 HRROI 2,[FILTNX] ;FILSPC defines to be ASCIZ /<SAIL>SAISGn.SAV/
06900 JSYS GTJFN
07000 ERR <CAN'T FIND SEGMENT>
07100 HRLI 1,400000 ;should be made parameter set in TENEXSW
07200 JSYS GET
07300 SETOM JOBHRL
07400 JRST (P)
07500 >;TENX
07600 >;LOW
00100
00200 EXPO <
00300 NOUP <
00400 INTERNAL TYPER.,OVPCWD,ERRMSG
00500 ;THESE ARE BECUSE OF LIB40 CHANGES
00600 ; MADE CAPRICIOUSLY BY DEC
00700 TYPER.:
00800 ERRMSG:
00900 OVPCWD: JFCL
01000 ERR <SOME FORTRAN ROUTINE HAS SEEN FIT TO COMPLAIN
01100 ABOUT YOUR STYLE. COMPLAIN TO DEC THAT THEIR ERROR MESSAGE
01200 PROCEDURE IS NOT SUFFICIENTLY GENERAL TO ALLOW GRACEFUL INTERFACE
01300 WITH SAIL.>
01400 >;NOUP
01500 >;EXPO
00100 SUBTTL Segment-Fetching Data
00200
00300 LOW <
00400 NOTENX<
00500
00600 NMSAV: 0 ;SAVE LOGICAL SEGMENT NAME HERE
00700 SEGDEV: 0 ;SAVE UPPER SEGMENT DEVICE NAME HERE
00800 SEGFIL: 0 ;SAVE UPPER SEGMENT FILE NAME HERE
00900 NOEXPO <
01000 SIXBIT /SEG/ ;ALWAYS
01100 >;NOEXPO
01200 EXPO <
01300 SIXBIT /SHR/ ;DIFFERENT STROKES FOR ....
01400 >;EXPO
01500 0
01600 SEGPPN: 0 ;SAVE UPPER SEGMENT PPN HERE
01700
01800 DEVSEG: SGDEVC ;USED ONLY BY EXPO'S GETSEG
01900 SEGNAM: FILXXX
02000 NOEXPO <
02100 SIXBIT/SEG/
02200 >;NOEXPO
02300 EXPO <
02400 SIXBIT /SHR/
02500 >;EXPO
02600 0
02700 SGPPNN ;SPECIFIED PPN DEFAULT
02800 EXPO <
02900 0 ↔0 ;SIX WORD BLOCK FOR GETSEG
03000 SAVPP: 0 ;P SAVED HERE OVER GETSEG
03100 >;EXPO
03200 ERSEG: TERPRI <SAIL SEGMENT LOADING ERROR>
03300 GLOB<
03400 SETOM %RENSW ;FORCE TTY RITUAL
03500 >;GLOB
03600
03700 CALLI 12
03800
03900 GLOB <
04000 GGNAM: 0
04100 TTCALL 4,C ;INCHWL.
04200 CAIE C,15 ;IF NOTHING SPECIFIED,
04300 MOVEI A,0 ; USE THE DEFAULT
04400 SKIPA B,[POINT 6,A]
04500 GGGO: TTCALL C ;GET CHAR
04600 CAIN C,15
04700 JRST [TTCALL C ↔ JRST @GGNAM] ;RETURN ON CR.
04800 CAILE C,140
04900 SUBI C,40 ;CONVERT LOWER CASE.
05000 SUBI C,40 ; → SIXBIT
05100 IDPB C,B ;SAVE IT.
05200 JRST GGGO
05300 >;GLOB
05400 >;NOTENX
05500 >;LOW
05600 ENDCOM(LOR)
05700 LOW <
05800 END
05900 >;LOW
06000 COMPIL(LUP,<%UUOLNK,%ALLOC,SAVE,RESTR,STACSV,STACRS,INSET>
06100 ,<CORGET,STCLER,%RECOV,%UACS,GOGTAB,%UPDL,CONFIG,%ALLCHR>
06200 ,<INITIALIZATION ROUTINES, UUO HANDLER, UTILITY ROUTINES>)
06300 IFE ALWAYS,<
06400 INTERNAL %ALLOC
06500 ; MORE EXTERNALS
06600 EXTERNAL ALLPDP,ERRSPC,SETLET,DPYSW,INILNK
06700 EXTERNAL %ERGO,SPLNEK,UUO0,%OCTRET
06800 EXTERNAL X11,X22,X44,CORINC,%STDLS,%RENSW,%SPL,KTLNK
06900 >;IFE ALWAYS
00100
00200 NOLOW < ;PUT IN UPPER SEGMENT AND ALL THAT FOLLOWS....
00300 UP <
00400
00500 ;IF YOU CHANGE ANYTHING ABOVE THIS POINT, YOU WILL
00600 ;HAVE TO RELOAD. THIS IS THE UPPER SEGMENT DISPATCH TABLE FOR
00700 ;INTERNAL SYMBOLS.
00800
00900 USE DSPCH ;A PC FOR VECTOR JRSTS
01000 USE
01100 BLOCK =250 ;SPACE FOR THE JRSTS.
01200 >;UP
01300
00100 SUBTTL %ALLOC -- Main Allocation Routine
00200
00300 DSCR %ALLOC
00400 CAL JSP 16,%ALLOC
00500 DES Processes space reqests, allocates the storage for stacks,
00600 string space, etc. Sets certain universal environmental variables
00700
00800 The SPLNEK list, created by the LOADER from compiled requests, contains
00900 REQUEST blocks. Space requests begin at location $SPREQ within each
01000 block. The entries consist of two-word entries, viz:
01100
01200 -----------------------------
01300 →- SPLNEK ptr -→ | | →next block | --→
01400 -----------------------------
01500 | |
01600 | fixed LEAP allocation |
01700 | data |
01800 | |
01900 | ... |
02000 -----------------------------
02100 $SPREQ: |OP1 |INDX | SIZe request |
02200 |- - - - - - - - - - - - - - -|
02300 | TEXt addr | RESult ADdRess| (if ¬STDSPC --
02400 ----------------------------- see below)
02500 |OP2 ... | etc. |
02600 -----------------------------
02700 | ... more ops ... |
02800 -----------------------------
02900 | 0 terminates |
03000 -----------------------------
03100
03200 OP is a 12-bit field (0:11), whose bits are interpreted as:
03300 0 STDSPC if 1, get TEX,RESADR spec from standard entry
03400 indexed by INDX field -- this is only a 1-word wntry.
03500 1 WNTADR requests that the address of the allocated core be
03600 returned in the specified RESADR field. RESADR is
03700 then incremented.
03800 2 WNTEND requests that the address of the first word not in the
03900 allocated area be placed in RESADR field. RESADR bumped.
04000 3 WNTPDP requests that a PDP computed from address and length be
04100 returned in like manner.
04200 4 USRTB indicates that the RESADRs are indices into the user
04300 table -- (GOGTAB) should be added before use.
04400 5 MINSZ indicates that the size specified here should be REPLACED
04500 by the first subsequent non-zero request (not ADDED).
04600 Default value for this area -- anything overrides.
04700
04800 INDX is a 6-bit field (12:17) used if STDSPC to cause the address to be
04900 obtained from a spec (with its own OP and addr words) built into GOGOL.
05000 This allows push-down list, string space, etc., sizes to be requested by
05100 object modules without knowing the locations of their descriptors.
05200 The indices represent:
05300 1 SYSPD System push-down list (P)
05400 2 SYSSPD String push-down list (SP)
05500 3 STRSP String space size.
05600
05700 SIZ replaces any previous request with MINSZ on. Otherwise, its value is
05800 added to an accumulated size for this address. The final result will
05900 specify the size of the area.
06000 SIZ<0 causes current entry to be disregarded.
06100
06200 TEX is the address of an ASCIZ string describing the use of the area.
06300 It is used when the user REENTERs to ask him how much space he wants.
06400 A non-zero value means that no overriding is possible for this area.
06500
06600 These requests are accumulated on the stack in two-word entries as:
06700 -----------------------------
06800 $SPREQ: |OP1 |INDX | RESult ADdRess|
06900 |- - - - - - - - - - - - - - -|
07000 | TEXt addr | accum size |
07100 -----------------------------
07200 Inconsistencies in request bits are not likely to be detected.
07300
07400 %ALLOC first processes the entire list, collecting cumulative information
07500 about each RESADR requested, summing the size requests (with mods as
07600 described for MINSZ above). Then it allocates space for each requested
07700 area, allowing the user to override each if he REENTERed, and if there
07800 is TEXt for that area. It finishes by performing some useful but
07900 uninteresting bookkeeping.
08000 ⊗
00100
00200 ; Get a Stack to hold requests in
00300
00400 HERE (%ALLOC)
00500 MOVEI C,MINPDS ;ABOUT 64 WORDS
00600 PUSHJ P,CORGET ;THIS USUALLY INITS THE USER TABLE
00700 ERR <NO CORE FOR ALLOCATION>
00800 PUSHJ P,PDPMAK ;A PUSH-DOWN POINTER
00900 MOVE P,B ;DITCH THE ALLOC PDL
01000 MOVEM B,PDL(USER) ;STORE TEMPORARILY
01100 PUSH P,16 ;THE RETURN ADDRESS
01200 ADD P,X22 ;ONE DUMMY ENTRY TO TERMINATE
01300 SETZM -1(P) ;0 TERMINATES IT
01400
01500 ; Loop to search the space request blocks
01600 ; Until further notice:
01700 ; T is →next allocation block.
01800 ; T1 is →next entry specification
01900 ; Q1 is modified T1 -- accounts for STDSPC specifications
02000 ; Q2 is incoming OP-size word
02100 ; A is →next candidate stack list element
02200 ; Q3 and TEMP used to do RESADR search in already-requested stack list
02300
02400
02500 MOVE T,SPLNEK ;LIST OF BLOCKS
02600 MOVEM T,%SPL ;LINK BUILT-IN BLOCK EXPLICITLY
02700 MOVEI T,%SPL ;ALLOCATE IT FIRST
02800 %AL1: MOVEI T1,$SPREQ(T) ;→FIRST REQUEST
02900 %AL2: SKIPN Q2,(T1) ;OP WORD
03000 JRST NXTELT ;NO MORE THIS BLOCK
03100 MOVE Q1,T1 ;SAVE ADDRESS OF REQUEST
03200 TLNN Q2,STDSPC ;A BUILT-IN RESADR/TEXT?
03300 AOJA T1,DRCT ; NO, GET IT HERE
03400
03500 ; T1 incremented because 2-word entry -- Q1 still → 1st word
03600 ; Here, there is only a 1-word entry -- the actual RESADR spec
03700 ; found by indexing into table.
03800
03900 LDB Q1,[POINT 6,Q2,17] ;THE INDEX
04000 LSH Q1,1 ;2-WORD ENTRIES ALL
04100 ADDI Q1,%STDLST ;HERE'S WHERE THEY LIVE
04200 HLL Q2,(Q1) ;USE STANDARD BITS FROM HERE ON
04300 TLZ Q2,MINSZ ;NEVER USED FOR MIN WHEN BY INDEX
04400
04500 ; Now find the corresponding entry in the accumulated stack entries
04600 ; or add a new entry
04700
04800 DRCT: HRRZ Q3,1(Q1) ;ADDRESS OF RESULT
04900 TLZE Q2,USRTB ;RESULT IN THE USER TABLE?
05000 ADD Q3,GOGTAB ;YES
05100 MOVEI A,-1(P) ;FOR SEARCH DOWN STACK
05200 JRST %AL4 ;GO SEARCH
05300
05400 %AL3: CAIN Q3,(TEMP) ;SAME ADDR?
05500 JRST %AL5 ;YES, UPDATE
05600 SUBI A,2 ;BACK UP ONE
05700 %AL4: SKIPE TEMP,(A) ;NEXT SAVED OP WORD
05800 JRST %AL3 ;TRY THIS ONE
05900
06000 ; First occurrence of this address, make a place for it
06100
06200 MOVEI A,1(P) ;BACK TO THE TOP
06300 ADD P,X22 ;NEW ENTRY
06400 SETZM (A)
06500 SETZM 1(A) ;VIRGIN ENTRY
06600
06700 COMMENT ⊗
06800 NMIN means MINSZ on in new spec, OMIN means it's on in stack spec
06900 NSIZ mean that new size≠0, OSIZ etc. -- then
07000 NMIN∧¬OSIZ ⊃⊃ OSIZ←NSIZ, OMIN←TRUE
07100 NMIN∧ OSIZ ⊃⊃ no change
07200
07300 ¬NMIN∧NSIZ∧OMIN ⊃⊃ OSIZ←NSIZ, OMIN←FALSE
07400 ¬NMIN∧¬NSIZ∧OMIN ⊃⊃ no change
07500 ¬NMIN∧¬OMIN ⊃⊃ OSIZ←NSIZ+OSIZ, OMIN←FALSE
07600
07700 In the sequel,
07800 A→current stack entry, T,T1,Q1 unchanged,
07900 Q2 is NEWSIZ, will be accum SIZ and TEXt addr.
08000 Q3 is NEWBITS,,RESADR, will be accumulated same.
08100 TEMP will be old TEX,,SIZ word, LPSA old BITS,,ADR
08200 ⊗
08300
08400 %AL5: HLL Q3,Q2 ;NEW BITS,,RESADR
08500 HRRES Q2 ;NEW SIZE
08600 MOVE TEMP,1(A) ;OLD TEX,,SIZ
08700 MOVE LPSA,(A) ;OLD BITS,,ADR
08800 JUMPL Q2,AOJBAK ;NO ACTION ON NEGATIVE SIZE
08900 TLNE Q3,MINSZ ;BEGIN THE HAIRY CASE STUDY
09000 JRST INMIN ;MIN ON IN NEW
09100
09200 ; ¬NMIN
09300 TLZN LPSA,MINSZ ;¬NMIN, OMIN? -- OMIN←FALSE
09400 JRST ADDIT ;¬NMIN∧¬OMIN, ADD
09500 JUMPN Q2,%AL6 ;¬NMIN∧ OMIN, NSIZ?
09600 TLOA Q3,MINSZ ;¬NMIN∧ OMIN∧¬NSIZ, NMIN←TRUE, NSIZ+OSIZ=OSIZ
09700 %AL6: HLLZS TEMP ;¬NMIN∧OMIN∧NSIZ, OSIZ←FALSE,NSIZ+OSIZ=NSIZ,NMIN←FALSE
09800 JRST ADDIT ;¬NMIN∧ OMIN, EITHER NSIZ OR OSIZ
09900
10000 ; NMIN
10100 INMIN: TRNE TEMP,-1 ;OSIZ?
10200 TLZA Q3,MINSZ ;NMIN∧OSIZ, OSIZ unchg, NMIN←FALSE
10300 TLZA LPSA,MINSZ ;NMIN∧¬OSIZ, OSIZ←NSIZ, NMIN←TRUE
10400 MOVEI Q2,0 ;NMIN∧OSIZ again, OSIZ unchg over add
10500
10600 ADDIT: OR Q3,LPSA ;COLLECT BITS
10700 ADD Q2,TEMP ;AND SIZE
10800 TLNN Q2,-1 ;ANY TEXT ADDR?
10900 HLL Q2,1(Q1) ;NO, GET FROM OLD IF ANY
11000 MOVEM Q3,(A) ;PUT NEW AWAY
11100 MOVEM Q2,1(A)
11200 AOJBAK: AOJA T1,%AL2 ;NEXT ELEMENT THIS BLOCK
11300
11400 NXTELT: SKIPN T,(T) ;NEXT BLOCK IN ALLOC LIST?
11500 JRST NOELT ;NO MORE.
11600 LEP <
11700 SKIPL $ITNO(T) ;LEAP REQUESTED?
11800 JRST %AL1 ;NO.
11900 MOVE B,GOGTAB ;WILL PLAY WITH USER TABLE
12000 SETOM HASMSK(B) ;SOMEONE WANTS LEAP.
12100 >;LEP
12200 JRST %AL1 ;CONTINUE DOWN ALLOC BLOCKS.
12300 NOELT:
00100
00200 ; SINCE SYSTEM_PDL ALREADY ALLOCATED AND IN USE, INCREMENT IT IF THE
00300 ; REQUEST EXCEEDS THE DEFAULT
00400 MOVE TEMP,PDL(USER)
00500 PUSH P,4(TEMP)
00600 PUSH P,5(TEMP) ;MAKE SURE P-REQUEST ON TOP
00700 SETZM 4(TEMP) ;AND THAT IT DOESN'T HAPPEN TWICE
00800
00900 ; NOW ALLOCATE THE SPACES, GET OVERRIDES
01000 SETZM %ALLCHR ;NO QUESTIONS YET
01100 SKIPN %RENSW ;WAS THERE A REENTER?
01200 JRST NONTR ; NO
01300 TERPRI
01400 PRINT <ALLOC? >
01500 NOTENX<
01600 TTCALL 0,B ;ASK LEADING QUESTION AND GET ANSWER
01700 >;NOTENX
01800 TENX<
01900 EXCH A,B
02000 JSYS PBIN
02100 EXCH A,B ;GET ANSWER IN B, RESTORE A
02200 >;TENX
02300 TERPRI
02400 CAIN B,"Y" ;YES?
02500 SETOM %ALLCHR ;YES
02600 CAIN B,"N" ;NO, BUT LET ME SEE IT?
02700 AOS %ALLCHR ;RIGHT
02800 SETZM %OCTRET ;WHEN ON, NO MORE ASKING
02900 NONTR:
03000 ALOC: SKIPN T,-1(P) ;WERE THERE ANY ENTRIES?
03100 JRST DONEE ; MAYBE, BUT NONE LEFT
03200 MOVS A,(P) ;SIZE, TEXT
03300 TRNE A,-1
03400 SKIPL %ALLCHR ;IF TEXT ADDR AND WANTS TO DO IT,
03500 JRST NOASK ; MUST ASK QUESTIONS
03600
03700 NOTENX<
03800 OUTSTR (A) ;PRINT IT
03900 >;NOTENX
04000 TENX<
04100 PUSH P,A
04200 HRROI A,(A)
04300 JSYS PSOUT
04400 POP P,A
04500 >;TENX
04600 PRINT <= >
04700 PUSHJ P,DECIN
04800 HRL A,C ;REPLACE REQUESTED SIZE BY OVERRIDE
04900 NOASK: HLRZ C,A ;IN CASE NOBODY ELSE DID
05000 JUMPE C,PRIN ;DON'T ALLOCATE 0 AREAS
05100 HRRZ TEMP,T ;DEST ADDR
05200 CAIE TEMP,PDL(USER) ;THE ONE AND ONLY?
05300 JRST NOEXP ; NO
05400
05500 ;THIS IS THE SYSTEM_PDL REQUEST -- IT MUST OVERLAY THE CURRENTLY
05600 ; ALLOCATED STACK
05700 HRRZ B,PDL(USER) ;GET PREV INITIAL CORGET ADDRESS
05800 CAIGE C,MINPDS ;MUST BE BIGGER
05900 MOVEI C,MINPDS ; SO MAKE IT BIGGER
06000 HRL A,C ;KEEP EVERYBODY UP TO DATE
06100 ADDI B,1 ;CORGET ADDR
06200 CAIG C,MINPDS
06300 JRST PDPRET ;NO PROBLEM
06400 SUBI C,MINPDS ;AMOUNT TO INCREASE BY
06500 ;;# # 4-28-72 DCS UPDATE P'S SIZE FIELD
06600 HRLZ TEMP,C ;UPDATE P RIGHT NOW
06700 SUB P,TEMP ;SIZE FIELD ONLY
06800 ;;# # 4-28
06900 PUSHJ P,CORINC ;INCREMENT TO PROPER SIZE
07000 ERR <DRYROT -- NO CORE FOR SYSTEM_PDL>
07100 ADDI C,MINPDS ;TOTAL SIZE
07200 JRST PDPRET
07300 NOEXP: PUSHJ P,CORGET ;GET A BLOCK
07400 ERR <NO CORE AT ALLOCATION>
07500 PDPRET: TLNN T,WNTADR ;WANT THE ADDRESS STORED?
07600 JRST .+3
07700 MOVEM B,(T) ;YES, STORE IT
07800 ADDI T,1
07900 TLNN T,WNTEND
08000 JRST NOND
08100 MOVE D,C ;SIZE
08200 ADD D,B ;END ADDR
08300 MOVEM D,(T)
08400 ADDI T,1
08500 NOND: PUSHJ P,PDPMAK
08600 TLNE T,WNTPDP
08700 MOVEM B,(T) ;WANTS PDP
08800 PRIN: SKIPN %ALLCHR ;ARE WE BLABBING?
08900 JRST SUBJMP ;NOPE
09000 NOTENX<
09100 OUTSTR (A)
09200 >;NOTENX
09300 TENX<
09400 PUSH P,A
09500 HRROI A,(A)
09600 JSYS PSOUT
09700 POP P,A
09800 >;TENX
09900 PRINT <: >
10000 HLRZ C,A ;SIZE AGAIN
10100 DECPNT C ;TOTAL ALLOC FOR THIS ONE
10200 TERPRI
10300 SUBJMP: SUB P,X22 ;SO MUCH FOR THAT ONE
10400 JRST ALOC ;GET THE NEXT
10500
10600 DONEE: SKIPN %ALLCHR ;BLABBING?
10700 JRST DONEZ
10800 TERPRI↔TERPRI
10900 DONEZ: SUB P,X44 ;→RETURN ADDRESS (DUMMY AND SYSPDL ENTRIES)
00100
00200 ; FINAL BOOKKEEPING
00300
00400 SETZM %RENSW ;DON'T ASK EACH TIME
00500 MOVE SP,SPDL(USER) ;STRING STACK POINTER
00600 MOVE B,ST(USER) ;STRING SPACE BEGINNING
00700 MOVN C,-1(B) ;SIZE
00800 SUBI C,3 ;MINUS OVERHEAD
00900 MOVEM C,STMAX(USER) ;SIZE OF STRING SPACE DATA
01000 HRLI B,(<POINT 7,0>)
01100 MOVEM B,TOPBYTE(USER) ;NEXT FREE BYTE
01200 IMUL C,[-5] ;NUMBER OF FREE CHARS
01300 ;;#GI# DCS 2-2-72 (1-3) MAKE CAT BETTER -- THIS LEAVES SOME ROOM
01400 ADDI C,=15 ;LEAVE SOME SLOP FOR INSET, ETC.
01500 ;;#GI# (1-3)
01600 MOVEM C,REMCHR(USER)
01700 SKIPE CONFIG ;COMPILER?
01800 SETOM SGLIGN(USER) ; YES, STRNGC AND FRIENDS MUST ALIGN STRINGS
01900 HRROI TEMP,KTLNK
02000 POP TEMP,KNTLNK(USER)
02100 POP TEMP,SGROUT(USER)
02200 POP TEMP,SETLNK(USER)
02300 POP TEMP,SPLNK(USER)
02400 POP TEMP,STRLNK(USER);TRANSFER LISTS TO USER TABLE
02500 PUSHJ P,STCLER ;CLEAR OUT ALL STRINGS
02600 MOVEI TEMP,7 ;INITIAL DIGS SETTING
02700 MOVEM TEMP,DIGS(USER) ;FOR FLOATING POINT OUTPUT
02800 MOVEI TEMP,CHANS(USER);IF CHNL HAS A VALID CHANNEL #,
02900 HRLI TEMP,CHNL ; @CDBLOC(USER) REFERS TO ITS
03000 MOVEM TEMP,CDBLOC(USER);CDB ADDR IN THE CHANS TABLE
03100 SETZM %ERGO ;NO AUTOMATIC CONTINUE FROM ERR.
03200 NOEXPO <
03300 MOVNI TEMP,1 ;FIND OUT IF ON A DPY
03400 TTCALL 6,TEMP
03500 MOVEM TEMP,DPYSW ;NEG IF DPY
03600 >;NOEXPO
03700 ;;#HE# DCS 5-11-72 (2-2) MODIFY VERSION CHECKING, STORAGE METHODS
03800 IFNDEF JOBVER,<EXTERNAL JOBVER>
03900 MOVEI LPSA,SPLNEK ;For each element of the space
04000 CHKVRS: SKIPN LPSA,(LPSA) ; list, if there is a non-zero
04100 POPJ P, ; version request, use it (lh is
04200 SKIPN TEMP,$VRNO(LPSA); SAIL version, rh is user version).
04300 JRST CHKVRS ;But if there was a previous non-zero
04400 HLL TEMP,JOBVER ; request, and if it is not the
04500 EXCH TEMP,JOBVER ; same as this one, complain first.
04600 TRNE TEMP,-1
04700 CAMN TEMP,JOBVER
04800 JRST CHKVRS
04900 ERR <VERSION NUMBER MISMATCH>,1
05000 JRST CHKVRS
05100 ;;#HE# (2-2)
05200
05300
05400 PDPMAK: MOVNS C
05500 SUBI B,1 ;PDP
05600 HRL B,C
05700 POPJ P,
05800 >;NOLOW
00100 COMMENT ⊗ Utility Subroutines for allocation
00200 ⊗
00300 DECIN: AOS (P)
00400 SKIPE %OCTRET ;IMMEDIATE RETURN?
00500 POPJ P, ; YES
00600
00700 SETZB C,D
00800 NOTENX<
00900 DECIN1: TTCALL 0,B
01000 >;NOTENX
01100 TENX<
01200 DECIN1: EXCH A,B
01300 JSYS PBIN
01400 EXCH A,B
01500 >;TENX
01600 CAIN B,177 ;RUBOUT?
01700 JRST RUB ;AYE, THERE'S THE RUB
01800 CAIN B,"U"-100 ;↑U?
01900 JRST CTRLU ;INDEED
02000 CAIN B,175 ;ALTMODE?
02100 JRST SETRET
02200 CAIN B,12 ;LINE FEED?
02300 JRST EPOP ;YES
02400 CAIL B,"0"
02500 CAILE B,"9"
02600 JRST DECIN1
02700 SETOM D ;FOUND SOMETHING LIKE A NUMBER
02800 IMULI C,=10 ;GOOD OLD NUMBER CONVERSION
02900 ADDI C,-"0"(B)
03000 JRST DECIN1 ;THIS IS A LOOP
03100
03200 SETRET: SETOM %OCTRET ;WILL RETURN IMMEDIATELY HENCEFORTH
03300 TERPRI
03400
03500 EPOP: SKIPE D ;FIND ANYTHING?
03600 SOS (P) ;YES
03700 CPOPJ: POPJ P,
03800
03900 RUB:
04000 CTRLU: TERPRI <XXX>
04100 JRST DECIN ;START OVER
00100 SUBTTL %UUOLNK -- UUO Handler (Dispatch Vector Just Below)
00200
00300 NOLOW < ;INCLUDE IN UPPER SEGMENT.....
00400 ↑%UUOLNK:
00500 ↑UUOCON:MOVEM 17,%UACS+17 ;NOTICE UUO0 IS ABOVE HERE
00600 MOVEI 17,%UACS
00700 BLT 17,%UACS+16
00800 MOVE P,[XWD -LUPDL,%UPDL] ;SET UP SPECIAL UUO PDL
00900 MOVE A,JOBUUO ;GET THE INSTRUCTION
01000 LDB B,[POINT 9,A,8] ;GET UUO NUMBER.
01100 TRNE B,-1≠17 ;CHECK IN RANGE
01200 JRST UUOTBL ;ILLUUO
01300 XCT UUOTBL(B) ;GO DO RIGHT THING.
01400 MOVSI 17,%UACS
01500 BLT 17,17 ;RELOAD ACCUMULATORS.
01600 JRST 2,@UUO0
01700
01800 ; UUO TABLE
01900
02000 ↑↑UUOTBL:PUSHJ P,ILLUUO ;0
02100 PUSHJ P,PDLOQ ;1
02200 PUSHJ P,FLOAQ ;2
02300 PUSHJ P,FIXQ ;3
02400 PUSHJ P,IOERRR ;4
02500 PUSHJ P,ERRR ;5
02600 PUSHJ P,PSIX ;6 -- SIXBIT PRINT.
02700 PUSHJ P,ARERRR ;7 -- ARRAY ERROR
02800 PUSHJ P,ILLUUO ;10
02900 PUSHJ P,DECPNQ ;11
03000 PUSHJ P,OCTPNQ ;12
03100 PUSHJ P,FLTPNQ ;13
03200 PUSHJ P,ILLUUO ;14
03300 PUSHJ P,ILLUUO ;15
03400
03500 NOTENX<
03600 FLTPNQ: TERPRI (<WELL ONE FLOATING PT NUMBER IS 1.0>)
03700 JRST GODD
03800 >;NOTENX
03900 TENX<
04000 FLTPNQ: MOVE B,(A)
04100 HRRZI A,101
04200 SETZ C,
04300 JSYS FLOUT
04400 ERR <FLOATING OUTPUT FAILURE>
04500 POPJ P,
04600 >;TENX
00100 SUBTTL ILLUUO, PDLOV, ERR UUO Handlers
00200
00300 DSCR ERROR UUOS
00400 PAR AC FIELD IS INDEX INTO ERROR ROUTINE
00500 SID SAVES THE WORLD
00600 DES THE ASCIZ STRING INDICATED BY THE EFFECTIVE ADDRESS IS TYPED. THEN
00700 THE ERROR ROUTINE INDICATED BY THE AC FIELD IS EXECUTED.
00800 IF `GO' IS NOT ON, THE USER IS ALLOWED TO RESPOND WITH ONE OF SEVERAL
00900 ALTERNATIVES. ONE ALTERNATIVE IS CONTINUATION IF THE AC FIELD OF THE
01000 UUO WAS ODD. OTHERWISE, NO CONTINUATION IS POSSIBLE. THE ACS AT THE
01100 TIME OF CALL ARE RESTORED IF CONTINUATION OR `DDT' IS CHOSEN.
01200 ⊗
01300
01400 ILLUUO: SKIPA A,[10B12+[ASCIZ /ILLEGAL UUO /]]
01500 PDLOQ: MOVEI A,[ASCIZ /PDL OVERFLOW/]
01600 ERRR: ERSEEN←←10000
01700 ;##LN##KVL - MAKE SEMANTIC ERRORS VISIBLE AFTER SYNTAX ERRORS (THERE
01800 ; USED TO BE SOME 9 LINES OF JUNK HERE.
01900 NOCOM:
02000 NOEXPO <
02100 PUSHJ P,PPRESET ;TURN ON PP 0, RESET POSITION
02200 >;NOEXPO
02300
02400 NOTENX<
02500 TTCALL 3,(A) ;PRINT MESSAGE
02600 >;NOTENX
02700 TENX<
02800 PUSH P,A
02900 HRROI A,(A)
03000 JSYS PSOUT
03100 POP P,A
03200 >;TENX
03300 LDB B,[POINT 4,A,12] ;DISPATCH INDEX
03400 ROT B,-1 ;LOW ORDER BIT TO SIGN BIT
03500 MOVEM B,%RECOV ;MARK %RECOVERABLE (OR NOT)
03600 PUSHJ P,@URTBL(B) ;CALL ERROR ROUTINE
03700 MOVEI A,0 ;INFO FOR MYERR
03800 SKIPE ERRSPC ;SPECIAL ERROR ROUTINE??
03900 PUSHJ P,@ERRSPC ;YES -- GO DO IT.
04000
04100 LINDUN:
04200 TENX<
04300 ;Stuff to notice if ERR call was .+1 after a JSYS
04400 ;Prints the TENEX diagnostic if so
04500 HRRZ A,UUO0
04600 HLRZ TEMP,-2(A)
04700 CAIE TEMP,104000 ;is opcode JSYS?
04800 JRST LINDN1
04900 PRINT <FAIL RETURN FROM JSYS >
05000 OCTPNT -2(A) ;Append the octal JSYS code to above
05100 TERPRI <
05200 TENEX says: >
05300 HRRZI A,101
05400 HRLOI B,400000
05500 SETZ 3,
05600 JSYS ERSTR
05700 JFCL
05800 ERR <ERSTR Jsys failed in Jsys error routine>
05900 ;ERSTR double-skips for normal return
06000
06100 LINDN1:
06200 >;TENX
06300 TERPRI
06400 PRINT <CALLED FROM >
06500 HRRZ A,UUO0
06600 SUBI A,1
06700 PUSHJ P,OCTPNI
06800 SKIPGE CONFIG ;RUNTIMES OR GAG
06900 JRST NOLSCL
07000 PRINT < LAST SAIL CALL AT >
07100 MOVE A,GOGTAB
07200 HRRZ A,UUO1(A)
07300 SOS A
07400 PUSHJ P,OCTPNI
07500
07600 NOLSCL: TERPRI
07700 MOVE A,GOGTAB
07800 HRRZ B,TOPBYTE(A)
07900 CAML B,STTOP(A);HAVE WE GONE OFF THE DEEP END?
08000 JRST [PRINT <ALL BETS ARE OFF, FOLKS!
08100 STRING SPACE EXHAUSTED UNEXPECTEDLY. WILL RESTART NOW>
08200 JRST @JOBREN]
08300
08400 SKIPE %ERGO
08500 JRST GOTRY ;AUTOMATIC CONTINUE SET
08600 WATNOW:
08700 IFN IMSSS, <
08800 COMMENT !
08900 IF WE HAVE A KIDDY JOB, THEN LOG OUT GRACEFULLY.
09000 WE FIND OUT THAT WE HAVE A KIDDY JOB BY THE CNTSZ JSYS.
09100 !
09200 OPDEF CNTSZ [104000000607] ;NO. OF FORKS
09300 OPDEF GJINF [104000000013] ;JOB INFO( E.G., THE #)
09400 OPDEF KLGOT [104000000613] ;KIDDY LOGOUT
09500 PUSH P,A ;SAVE ACS
09600 PUSH P,B
09700 PUSH P,C
09800 PUSH P,D
09900 GJINF ;GET JOB INFORMATION
10000 MOVE A,C ;GET THE JOB NO. IN 1
10100 CNTSZ
10200 HLRZ A,B ;# OF FORKS (LH OF 2)
10300 CAIG A,1 ;MORE THAN 1?
10400 JRST [HRROI 1,[ASCIZ/
10500 SORRY, SYSTEM ERROR.
10600
10700 GOODBYE.
10800 /]
10900 JSYS PSOUT
11000 SETO 1,
11100 KLGOT ;LOGOUT
11200 ] ;END OF LITERAL
11300
11400 POP P,D ;RESTORE
11500 POP P,C
11600 POP P,B
11700 POP P,A
11800 >;IFN IMSSS
11900
12000 MOVEI A,"?" ;PRINT ? FOR IRRECOVERABLE ERRORS,
12100 SKIPGE %RECOV ; → FOR %RECOVERABLE ONES.
12200 EXPO <
12300 MOVEI A,"↑" ;SOMETHING PRINTABLE
12400 >;EXPO
12500 NOEXPO <
12600 MOVEI A,"→" ;FOR %RECOVERABLE ONES
12700 >;NOEXPO
12800 NOTENX<
12900 TTCALL 1,A ;PRINT IT
13000 >;NOTENX
13100 TENX<
13200 JSYS PBOUT
13300 >;TENX
13400 NOEXPO <
13500 SKIPGE DPYSW ;ON A DPY?
13600 DPYOUT 7,DPYMBK ; FLASHING INSTRUCTIONS
13700 >;NOEXPO
13800 NOTENX<
13900 TTCALL 0,B ;GET RESPONSE CHAR
14000 >;NOTENX
14100 TENX<
14200 EXCH A,B
14300 JSYS PBIN
14400 EXCH A,B
14500 CAIN B,37 ;PHONEY TENEX EOL?
14600 MOVEI B,15 ;MAKE CR
14700 >;TENX
14800 CAIL B,"a" ;lower case?
14900 SUBI B,40 ;YES, CONVERT TO UPPER
15000 NOEXPO <
15100 SKIPGE DPYSW
15200 DPYOUT 7,[0↔0] ;TURN OFF ALL THAT FLASHING
15300 >;NOEXPO
15400 CAIN B,"E" ;RE-EDIT?
15500 JRST EDIT ; YES
15600 CAIN B,"T" ;USE TV?
15700 JRST TVEDIT ; YES
15800 NOTENX<
15900 TTCALL 11, ;CLEAR INPUT BUFFER
16000 >;NOTENX
16100 TENX< PUSH P,A
16200 MOVEI A,100
16300 JSYS CFIBF
16400 POP P,A
16500 >;TENX
16600 CAIN B,12 ;CONTINUE AUTOMATISCH?
16700 SETOM %ERGO ;YES
16800
16900 CAILE B,15 ;TRY TO CONTINUE?
17000 JRST NOCR
17100
17200 CAIE B,"α" ;CONTINUE ANYWAY OR
17300 GOTRY: SKIPGE %RECOV ;CAN WE CONTINUE?
17400 POPJ P, ;YES
17500
17600 TERPRI <CAN'T CONTINUE>
17700 JRST WATNOW
17800
17900 NOCR: CAIN B,"S"
18000 JRST STRTIT ;RESTART
18100 CAIN B,"X" ;EXIT?
18200 JRST [
18300 MOVSI 17,%UACS
18400 BLT 17,17
18500 NOTENX<
18600 CALL6 EXIT]
18700 >;NOTENX
18800 TENX<
18900 JSYS HALTF]
19000 >;TENX
19100
19200 NOXIT: CAIE B,"D"
19300 JRST BADRSP ;DOESN'T KNOW WHAT HE WANTS
19400 GODD: SKIPN JOBDDT ;IS DDT IN CORE
19500 JRST NODDT ;NOPE
19600 MOVSI 17,%UACS
19700 BLT 17,17
19800 JRST @JOBDDT
19900
20000 NODDT: TERPRI <NO DDT>
20100 JRST WATNOW
00100
00200 BADRSP: SKIPE A,ERRSPC ;IS THERE A COMPILER ROUTINE?
00300 SKIPN A,-1(A) ;YES, IS THERE AN FTDEBUGGER?
00400 JRST RELYBD ;NO OR NO
00500 CAIE B,"L" ;WANT TO LOOK AT STACK?
00600 JRST RELYBD ;NO, ALL THAT WORK FOR LITTLE
00700 TERPRI <YOU ARE IN THE COMPILER DEBUGGER>
00800 PUSHJ P,(A) ;GO DEBUG
00900 JRST WATNOW
01000
01100 RELYBD: PRINT <REPLY [CR] TO CONTINUE,
01200 [LF] TO CONTINUE AUTOMATICALLY,
01300 "D" FOR DDT, "E" TO EDIT,
01400 "X" TO EXIT, "S" TO RESTART>
01500 JUMPE A,CRL
01600 PRINT <,
01700 "L" TO LOOK AT THE STACK>
01800 CRL: TERPRI
01900 JRST WATNOW
02000
02100
02200 IOERRR: TERPRI
02300 NOTENX<
02400 TTCALL 3,(A)
02500 >;NOTENX
02600 TENX<
02700 PUSH P,A
02800 HRROI A,(A)
02900 JSYS PSOUT
03000 POP P,A
03100 >;TENX
03200 TLNE A,740 ;ANY AC AT ALL?
03300 PUSHJ P,SIXPRT ;YES, ASSUME 14-15, SIXBIT IN LPSA
03400 TERPRI
03500 NOTENX<
03600 CALLI ;AVOID CLOSING FILES
03700 CALL [SIXBIT/EXIT/] ;FAIL WON'T LET ME USE CALL6
03800 >;NOTENX
03900 TENX<
04000 JSYS HALTF
04100 JRST .-1
04200 >;TENX
04300 STRTIT: HRRZ A,JOBSA
04400 JRST (A)
04500
04600
04700 DSCR ARRAY ERROR UUO
04800 PAR ARRAY NAME STRING DESCRIPTOR ADDRESS IS EFFECTIVE ADDR
04900 INDEX NUMBER IS AC FIELD.
05000 DES ARRAY NAME, INDEX NUMBER ARE PRINTED. THEN ERROR UUO CODE
05100 IS ENTERED AS ABOVE.
05200 ⊗
05300
05400 ARERRR:
05500 NOEXPO <
05600 PUSH P,PPRETR ;IN LINE CALL
05700 PPRESET:
05800 SKIPL DPYSW ;ON A DPY?
05900 POPJ P, ;NO, DON'T BOTHER
06000 OPDEF PPIOT [702B8]
06100 PPIOT 1,400000
06200 DPYPOS (-200) ;RESET X POS
06300 DPYSIZ (3,5) ;RESET GLITCHES
06400 PPRETR: POPJ P,.+1
06500 >;NOEXPO
06600 PRINT <INVALID INDEX NO. >
06700 LDB A,[POINT 4,JOBUUO,12]
06800 PUSHJ P,DECPNQ+1
06900 PRINT < FOR ARRAY >
07000 SETZM %RECOV ;NON-RECOVERABLE ERROR!
07100 PUSHJ P,PRASC
07200 JRST LINDUN
00100 SUBTTL Special Printing Routines For Error Handler
00200
00300 DSCR UUO ERROR MESSAGE ROUTINES AND THEIR INDICES (AC FIELD OF UUO)
00400 ⊗
00500
00600 ↑↑URTBL:UPOPJ ; 0- 1 -- NO ACTION
00700 .PRSM ; 2- 3 -- PRINT SYMBOL PTD TO BY LPSA (SAIL)
00800 PRASC ; 4- 5 -- PRINT SYMBOL PTD TO BY UUO INSTR
00900 ACPRT ; 6- 7 -- PRNT VAL OF AC IN INSTR PRECDNG UUO
01000 UUOPRT ;10-11 -- PRINT THE UUO
01100 AC1PRT ;12-13 -- PRINT AC FIELD ASSUMING RETURN FROM
01200 ; CALL IS IN UUO1(GOGTAB)
01300 SIXPRT ;14-15 --PRINT LPSA AS SIXBIT
01400
01500 UUOPRT: HLRZ A,40 ;LH
01600 PUSHJ P,OCTPNI ;TYPE IT
01700 HRRZ A,40 ;RH
01800 JRST OCTPNI ;IT TOO
01900
02000 DSCR PRSYM -- PRINT SYMBOL NAME
02100 PAR SAIL SEMANTICS BLOCK ADDRESS IN LPSA
02200 RES TYPES $PNAME STRING FROM BLOCK
02300 SID DESTROYS A,B
02400 ⊗
02500
02600
02700 $PNAME ←← 1
02800
02900 PRASC: SKIPA A,JOBUUO ;→STRING DESCRITPOR
03000 .PRSM: HRRI A,$PNAME(LPSA) ;→STRING DESCRIPTOR
03100 HRRZ B,(A) ;#CHARACTERS
03200 MOVE A,1(A) ;STRING BP
03300 MOVEI D,0 ;NO ADJUSTMENT
03400 JRST PRSL1 ;WON'T WORK FOR ZERO LENGTH STRINS
03500
03600 PRSL: ILDB C,A ;CHARACTER
03700 ADDI C,(D) ;ADJUSTMENT
03800 TTCALL 1,C ;TYPE IT
03900 PRSL1: SOJGE B,PRSL
04000 UPOPJ: POPJ P,
04100
04200
04300 AC1PRT: MOVE A,GOGTAB ;GET USER TABLE PTR
04400 SKIPA A,UUO1(A) ;SOMEONE STORED RIGHT THING HERE
04500
04600 ACPRT: HRRZ A,UUO0
04700 LDB A,[POINT 4,-2(A),12] ;AC # FROM PREV INSTR
04800 ADDI A,%UACS
04900 JRST DECPNQ ;PRINT IT IN DECIMAL
05000
05100 SIXPRT: SKIPA A,[POINT 6,LPSA];GET FROM HERE
05200 PSIX: HRLI A,(<POINT 6,0>) ;UUO ADDR IS ADDR OF SIXBIT
05300 MOVEI D,40 ;ADJUSTMENT
05400 MOVEI B,6 ;PRINT 6 CHARS
05500 JRST PRSL1
05600
00100 SUBTTL Code to Handle Linkage to Editors
00200
00300 TENX<
00400 TVEDIT:
00500 EDIT: TERPRI <Editor linkages not implemented yet>
00600 JRST WATNOW
00700 >;TENX
00800 NOTENX<
00900 TVEDIT: TDZA 13,13 ;FLAG AS TV
01000 EDIT: MOVNI 13,1
01100 PUSH P,13
01200 SETZB 13,14 ;PREPARE FOR PROVIDING
01300 SETZB 15,16 ;STOPGAP WITH FILE NAME,
01400 SETZB 11,12 ; PAGE AND LINE NUMBERS, SEQUENTIAL LINE #
01500 IFN IMSSS, <
01600 MOVEI A,1 ;INDICATE EDITING
01700 SKIPE ERRSPC ;ERROR ROUTINE SPECIFIED?
01800 PUSHJ P,@ERRSPC ;YES
01900
02000 >;IFN IMSSS
02100 TTCALL 0,B ;SEE IF FILE NAME SPECIFIED
02200 CAIE B,15 ;CR?
02300 JRST GTNAM ; NO, NAME SPECIFIED
02400
02500 AUTO: TTCALL 0,B ;SNARF UP LINE FEED AFTER CR
02600 MOVEI A,1
02700 SKIPE ERRSPC
02800 PUSHJ P,@ERRSPC ;SPECIAL FOR COMPILER....
02900 JRST GTIT ;GET QQSVED.RPG
03000
03100 GTNAM: CAIE B," " ;DELETE LEADING BLANKS
03200 JRST MKNAMM
03300 TTCALL 0,B
03400 JRST GTNAM
03500
03600 MKNAMM: CAIN B,15 ;GO BACK ON CR
03700 JRST AUTO
03800 MOVE C,[POINT 6,13] ;COLLECT FILE NAME HERE
03900 MKNLP: CAIE B," " ;DONE?
04000 CAIN B,15
04100 JRST GTIT1 ; YES
04200 SUBI B,40
04300 CAIN B,"."-40
04400 SKIPA C,[POINT 6,14] ;ADJUST TO GET EXTENSION
04500 IDPB B,C ;CHAR OF FILENAME
04600 TTCALL 0,B
04700 JRST MKNLP
04800
04900
05000 GTIT1: CAIN B,15
05100 TTCALL 0,B
05200
05300 GTIT: POP P,A ;TV/SOS FLAG
05400 EXCH 13,14 ;EXT IN REG PRECEDING NAME?
05500 ;HERE TO RUN ANY PROGRAM, EITHER SOS OR COMPIL.
05600 ; REGISTERS HAVE GOODIES IN THEM:
05700 ; 13 FILE EXTENSION IN SIXBIT
05800 ; 14 FILE NAME IN SIXBIT
05900 ; 15 LINE NUMBER IN ASCII.
06000 ; 16 PAGE NUMBER (BINARY)
06100 ;IF AC 14 IS ZERO, THIS MEANS NO FILE HAS BEEN
06200 ; SPECIFIED, AND WE WILL USE "COMPIL" TO REPEAT THE
06300 ; LAST EDIT COMMAND (THIS IS NOT A FEATURE ON MOST
06400 ; STANDARD DEC SYSTEMS -- SEE R SPROULL)
06500 NOEXPO <
06600 MOVEI P,2
06700 LOAD6 (2,<SYS>) ;ASSUME GET TO EDITOR VIA RPG
06800 LOAD6 (4,<DMP>)
06900 MOVEI 6,0
07000 MOVEI 5,777777 ;TELLS RPG: "EDIT"
07100 LOAD6 (3,<RPG>)
07200 JUMPE 14,SWAPIT
07300 MOVEI 5,1 ;START AT RPG LOC IN EDITOR
07400 LOAD6 (3,<SOS>) ;NOW ASSUME SOS
07500 JUMPL A,SWAPIT ;YES
07600 LOAD6 (3,<TV>) ;NO, TV
07700 MOVE 15,12 ;GET SEQUENTIAL LINE NUMBER
07800 SWAPIT: CALL6 (P,SWAP) ;SEE YOU AROUND
07900 >;NOEXPO
08000 ; ELSE FALL INTO EXPO VERSION ....
00100
00200 COMMENT ⊗ EXPORT VERSION OF EDITOR-INTERFACE
00300 PROVIDED BY R. SPROULL, 11-18-70
00400 SEE HIM FOR DETAILS ON DIDDLES TO CCL AND EDIT10
00500 ⊗
00600 EXPO <
00700 JUMPN 14,EDITG ;IF FILE, FIRE UP SOS
00800 MOVE P,[XWD -1,[SIXBIT /SYS/
00900 SIXBIT /COMPIL/
01000 0 ↔ 0 ↔ 0 ↔ 0 ]]
01100 CALL6 (P,RUN) ;GO RUN IT.
01200 JRST 4,0
01300 EDITG: PUSHJ P,RPGDSK ;SET UP FOR FILE
01400 MOVE 2,14 ;GET THE FILE
01500 PUSHJ P,SXCON
01600 MOVEI 1,"."
01700 SKIPN 2,13 ;EXTENSION
01800 JRST NOEXT
01900 PUSHJ P,OUT1
02000 HLLZS 2 ;EXTENSION.
02100 PUSHJ P,SXCON
02200 NOEXT: SKIPN 11 ;PROJ,PROG #
02300 JRST NOPPN
02400 MOVEI 1,"["
02500 PUSHJ P,OUT1
02600 HLRZ 1,11
02700 PUSHJ P,OCTO ;OUTPUT OCTAL
02800 MOVEI 1,","
02900 PUSHJ P,OUT1
03000 HRRZ 1,11
03100 PUSHJ P,OCTO
03200 MOVEI 1,"]"
03300 PUSHJ P,OUT1
03400 NOPPN: PUSHJ P,CRLF
03500 JUMPE 15,GOED10 ;IF NO LINE NUMBER, DO NOT DO THIS.
03600 MOVEI 1,"P"
03700 PUSHJ P,OUT1
03800 MOVE 2,15 ;LINE NUMBER
03900 TRZ 2,1 ;FOR SURE?
04000 ASCO: MOVEI 1,0
04100 LSHC 1,7
04200 PUSHJ P,OUT1
04300 JUMPN 2,ASCO
04400 MOVEI 1,"/"
04500 PUSHJ P,OUT1
04600 MOVE 1,16 ;PAGE NUMBER
04700 PUSHJ P,OUTDEC
04800 PUSHJ P,CRLF
04900 GOED10: MOVE 1,PPMAX+2 ;SIZE
05000 ADDI 1,4
05100 IDIVI 1,5 ;TO WORDS
05200 MOVNS 1
05300 HRLS 1
05400 HRR 1,PPMAX ;BUFFER START
05500 ADDI 1,1
05600 MOVEM 1,PPMAX+2
05700 MOVSI 1,'EDT'
05800 EXCH 1,PPMAX+1
05900 MOVE 2,[XWD 3,PPMAX+1]
06000 CALLI 2,44 ;WRITE IT
06100 JRST DSKIT
06200 EDT10R: MOVE P,[XWD 1,[SIXBIT /SYS/
06300 SIXBIT /SOS/
06400 0↔0↔0↔0]]
06500 CALL6 (P,RUN)
06600 JRST 4,.
06700 DSKIT: SETSTS 1,16 ;DO NOT LOSE BUFFERS
06800 MOVEM 1,PPMAX+1
06900 CALLI 2,30 ;JOB NUMBER
07000 MOVSI 1,'EDT' ;TO FILE NAME
07100 MOVEI 4,3
07200 DGLP: IDIVI 2,=10
07300 IORI 1,20(3)
07400 ROT 1,-6
07500 SOJG 4,DGLP
07600 MOVSI 2,'TMP'
07700 SETZB 3,4
07800 ENTER 1,1
07900 CALLI 12 ;FATAL
08000 SETSTS 1,0
08100 CLOSE 1,0 ;FINISH
08200 JRST EDT10R
08300 RPGDSK: CALLI
08400 INIT 1,0
08500 SIXBIT /DSK/
08600 XWD PPMAX,0
08700 CALLI 12
08800 OUTBUF 1,0
08900 OUTPUT 1,0
09000 SETZM PPMAX+2
09100 MOVEI 1," "
09200 OUT1: AOS PPMAX+2
09300 IDPB 1,PPMAX+1
09400 POPJ P,
09500 SXCON: MOVEI 1,0
09600 LSHC 1,6
09700 ADDI 1,40
09800 PUSHJ P,OUT1
09900 JUMPN 2,SXCON
10000 POPJ P,
10100 OCTO: IDIVI 1,10
10200 HRLM 2,(P)
10300 SKIPE 1
10400 PUSHJ P,OCTO
10500 HLRZ 1,(P)
10600 ADDI 1,"0"
10700 JRST OUT1
10800 OUTDEC: IDIVI 1,=10
10900 HRLM 2,(P)
11000 SKIPE 1
11100 PUSHJ P,OUTDEC
11200 HLRZ 1,(P)
11300 ADDI 1,"0"
11400 JRST OUT1
11500 CRLF: MOVEI 1,15
11600 PUSHJ P,OUT1
11700 MOVEI 1,12
11800 JRST OUT1
11900 >;EXPO
12000 >;NOTENX
00100 SUBTTL DECPNT, OCTPNT, FIX, FLOAT UUOs
00200
00300 DSCR OCTPNT, DECPNT UUO'S
00400 PAR ADDR OF WORD TO BE PROCESSED IS EFFECTIVE ADDR
00500 RES DECPNT -- WORD TYPED IN DECIMAL
00600 OCTPNT -- OCTAL
00700 ⊗
00800
00900
01000
01100 NOTENX<
01200 OCTPNQ: HRRZ A,(A)
01300 OCTPNI: MOVEI C,10 ;KEEP RADIX IN C.
01400 JRST PNT
01500
01600 DECPNQ: MOVE A,(A)
01700 DECPNI: MOVEI C,=10
01800 JUMPGE A,PNT ; GREATER 0.
01900 PRINT <->
02000 MOVMS A ; FOO1 ← ABS(FOO1);
02100 PNT: IDIV A,C ;FAMOUS DEC RECURSIVE NUMBER PRINTER.
02200 IORI B,"0"
02300 HRLM B,(P)
02400 SKIPE A
02500 PUSHJ P,PNT
02600 HLRZ B,(P)
02700 TTCALL 1,B
02800 POPJ P,
02900 >;NOTENX
03000 TENX<
03100 OCTPNI: SKIPA B,A
03200 OCTPNQ: HRRZ B,(A)
03300 HRRZI C,10
03400 PNT: HRRZI A,101
03500 JSYS NOUT
03600 ERR <OCTPNQ - number printer lost>
03700 POPJ P,
03800 DECPNI: SKIPA B,A
03900 DECPNQ: MOVE B,(A)
04000 HRRZI C,=10
04100 JRST PNT
04200 >;TENX
04300
04400 DSCR FIX UUO (FIXQ)
04500 PAR EFFECTIVE ADDR → WORD TO BE CONVERTED
04600 RES FIXED POINT EQUIVALENT IN AC SPECIFIED IN AC FIELD OF UUO
04700 ⊗
04800 FIXQ: TRNN A,777760 ;IN AC?
04900 ADDI A,%UACS ;YES
05000 MOVE B,(A) ;GET ARGUMENT
05100 MULI B,400 ;THIS ALGORITHM STOLEN FROM F4.
05200 TSC B,B
05300 EXCH B,C
05400 ASH B,-243(C)
05500 JRST FXFLT ;STORE IN RIGHT PLACE.
05600 POPJ P,
05700
05800 DSCR FLOAT UUO (FLOAQ)
05900 RES LIKE FIX, BUT RETURNS FLOATING POINT EQUIVALENT OF ITS ARGUMENT
06000 ⊗
06100 FLOAQ: TRNN A,777760 ;IN AC?
06200 ADDI A,%UACS ;YES
06300 MOVE B,(A) ;GET ARGUMENT
06400 IDIVI B,1B18
06500 SKIPE B
06600 TLC B,254000
06700 TLC C,233000
06800 FAD B,C
06900 FXFLT:
07000 LDB A,[POINT 4,A,12] ;RESULT REGISTER
07100 MOVEM B,%UACS(A) ;STORE RESULT
07200 POPJ P,
00100 SUBTTL DSPLIN, etc.for Disp. Text Line on Error (Compiler)
00200
00300 DSCR DPYCLR
00400 CAL PUSHJ
00500 RES RESETS III DPY STATE IF A III DPY IS AROUND
00600 ⊗
00700
00800 NOEXPO <
00900 ↑DSPCLR:
01000 SKIPGE DPYSW
01100 DPYCLR
01200 POPJ P,
01300
01400 >;NOEXPO
01500
01600
01700 NOEXPO <
01800 ↑↑DPYMBK: DPYMSG
01900 DPYSVV-DPYMSG+1 ;DPYOUT HEADER BLOCK
02000
02100 DPYMSG: 0
02200 AIVECT (=100,=400) ;MOVE TO RIGHTOF RAID SCREEN
02300 ASCID /REPLY [CR] TO CONTINUE,
02400 /
02500 RIVECT (=612,0) ;GET OUT THERE AGAIN
02600 ASCID ([LF] TO CONTINUE AUTOMATICALLY,
02700 (
02800 RIVECT (=612,0)
02900 ASCID ("D" FOR DDT, "E" TO EDIT, "T" TO TVEDIT,
03000 (
03100 RIVECT (=612,0)
03200 ASCID ("X" TO EXIT, "S" TO RESTART,
03300 (
03400 DPYSVV: DPYJMP DPYMSG
03500
03600 >;NOEXPO
00100 SUBTTL SAVE, RESTR, INSET -- General Utility Routines
00200
00300 DSCR SAVE
00400 CAL PUSHJ
00500 DES This routine saves registers 0-CHNL (12) in the user
00600 RACS area. It also saves the return
00700 address (-1(P)) in UUO1(USER), for traditional reasons,
00800 for the error message printout routines.
00900 Register USER is loaded but not saved, as is register
01000 TEMP
01100 ⊗
01200 ↑SAVE: MOVE USER,GOGTAB ;→USER RE-ENTRANT TABLE
01300 HRRZI TEMP,RACS(USER) ;XWD FF,SAVEADDR
01400 BLT TEMP,RACS+CHNL(USER) ;SAVE FF THRU CHNL
01500 MOVE TEMP,-1(P) ;RETURN ADDR FROM I/O CALL
01600 MOVEM TEMP,UUO1(USER) ;STORE RETURN
01700 POPJ P,
01800
01900 DSCR RESTR
02000 PAR LPSA -- XWD FOR ADJUSTING P-STACK (#PARAMS+RETURN ADDR)
02100 CAL JRST
02200 RES ACS are restored from RACS, stack is adjusted using LPSA,
02300 return is made through UUO1(USER)
02400 ⊗
02500
02600 ↑RESTR: MOVSI TEMP,RACS(USER) ;XWD SAVEADDR,FF
02700 BLT TEMP,CHNL ;RESTORE
02800 SUB P,LPSA ;ADJUST STACK
02900 JRST @UUO1(USER) ;RETURN
03000
03100 DSCR STACSV
03200 CAL PUSHJ
03300 DES SAVES ACS 0-13 IN AREA STACS
03400 SID DESTROYS 14,15
03500 ⊗
03600 ;; #KL# BY JRL (11-22-72) SAVE ONLY AC'S 0-13
03700 ↑STACSV:
03800 MOVE 15,GOGTAB
03900 HRRZI 14,STACS(15)
04000 BLT 14,STACS+13(15)
04100 POPJ P,
04200
04300 DSCR STACRS
04400 CAL PUSHJ
04500 DES RESTORES ACS 0-13 FROM AREA STACS
04600 ⊗
04700
04800 ;; #KL# RESTORE ONLY 0-13
04900 ↑STACRS: MOVE 15,GOGTAB
05000 HRLZI 14,STACS(15)
05100 BLT 14,13
05200 POPJ P,
05300
05400
05500
05600 DSCR INSET
05700 CAL PUSHJ
05800 RES String Space is adjusted so that next created string will start
05900 on a full-word boundary.
06000 SID USER→GOGTAB
06100 DES REMCHR is first adjusted, and STRNGC called if necessary.
06200 Then TOPBYTE is adjusted.
06300 ⊗
06400
06500
06600 ↑INSET: MOVE USER,GOGTAB ;MAKE SURE
06700 ;;#GI# DCS 2-5-72 REMOVE TOPSTR
06800 HLL TEMP,TOPBYTE(USER)
06900 HRRI TEMP,[BYTE (7) 0,4,3,2,1,0]
07000 ILDB TEMP,TEMP ;ADJUSTMENT NEEDED.
07100 ADDM TEMP,REMCHR(USER) ;UPDATE REMCHR.
07200 SKIPL TEMP,TOPBYTE(USER)
07300 ADDI TEMP,1
07400 HRLI TEMP,440700 ;POINT 7, WORD
07500 MOVEM TEMP,TOPBYTE(USER) ;AND SAVE
07600 POPJ P,
07700 >;NOLOW
07800 ENDCOM(LUP)
07900 COMPIL(COR,<CORREL,CORGET,CORINC,CANINC,CORBIG>
08000 ,<GOGTAB>
08100 ,<CORGET, CORREL, ... -- CORE ALLOCATION ROUTINES>)
00100 SUBTTL Core Service Routines -- General Description
00200
00300 DSCR BEGIN CORSER
00400 ⊗
00500 IFN ALWAYS,<BEGIN CORSER>
00600 Comment ⊗ These are the core allocation routines for both the compiler
00700 and the code it compiles. Core comes in "BLOCKs." A block may be any
00800 (reasonable) length, and has the following format:
00900
01000 HEAD: →PREV,,→NEXT ;if block not in use, free storage list pointers
01100 SIZE ;GREATER 0 if free, LESS0 if in use
01200 <SIZE-3 data words> ;whatever is to go here
01300 x00000,,→HEAD ;x=1 if in use, 0 if free
01400
01500 →PREV is zero if this block is first on free storage list. →NEXT is zero if last
01600
01700 In the beginning, the world starts out as one big block, occupying space from
01800 the end of the (GOGTAB→) user table to @JOBREL. Once a MOVE USER,GOGTAB
01900 has been done, LOWC(USER) and TOP(USER) indicate the total size of
02000 available core. FRELST(USER) → the first (only) block in free storage.
02100
02200 If GOGTAB is 0, CORGET will create a user table and make the remaining space
02300 look like a BLOCK. It will create a user table and point GOGTAB at it.
02400 It also assures that DDT symbols are below JOBSA(lh). Then it sets
02500 JOBFF to =76K out of pure spite. Now CORGET operations may be issued.
02600
02700 CORGET is called with the desired size in SIZ (C). The free storage list is
02800 searched for the first free block (BLK) satisfying the request. The
02900 required block is taken from lower addresses of BLK and BLK is adjusted.
03000 If requested size is within a few words of the free size, all of BLK is
03100 given to the user. The resultant address is returned in THIS (B).
03200
03300 If there is no block on FRELST(USER) big enough, or if ATTOP(USER) ≠ 0, CORGET
03400 checks XPAND(USER) for permission (0) to expand core. If granted, a new
03500 block is formed at the top after obtaining more core. It is merged with
03600 the top block if it is free, then the requested block is allocated from
03700 it. CORGET is simple.
03800
03900 CORGET skips if it is successful. It does not skip if it needs to expand and
04000 either XPAND(USER) ≠ 0 or the CORE UUO fails.
04100
04200 The secret is CORREL. No compacting is done, but CORREL will merge a returning
04300 block with any neighboring free block. It can do this because it can
04400 tell the status of each neighbor by looking at the size (POS if free)
04500 field or x-bit (off if free). This tends to reduce checkerboarding.
04600
04700 CORREL is called with a pointer to the block to be released in THIS (B).
04800 It returns nothing, nor does it ever skip.
04900
05000 CORBIG returns in SIZ the size of the largest available block. ⊗
05100 NOLOW < ;INCLUDE IN UPPER SEGMENT.
00100 SUBTTL Special AC Declarations
00200
00300 DEBCOR ←←0 ;SWITCH FOR CORE DEBUGGING ROUTINES.
00400 ; ACS
00500
00600 SIZ ←← 3 ;SIZE OF BLOCK BEING OBTAINED OR RELEASED
00700 THIS ←← 2 ;POINTER TO SAME
00800 NEXT ←← 1 ;POINTER TO SUCCESSOR
00900 PREV ←← 5 ;POINTER TO PREDECESSOR
01000 LAST ←← 6 ;POINTER TO NEXT-HIGHER NEIGHBOR
01100
01200 TRIVIAL ←←=10 ;AMOUNT WE'RE WILLING TO WASTE
00100 SUBTTL Utility Routines
00200
00300 DSCR UNLINK
00400 CAL PUSHJ
00500 PAR →Core block to be removed in AC THIS (2)
00600 RES block is removed from CORSER free storage list
00700 SID ACs NEXT (1) and PREV (5) are given appropriate values
00800 ⊗
00900
01000 UNLINK:
01100 HRRZ NEXT,(THIS) ;→NEXT BLOCK
01200 HLRZ PREV,(THIS) ;→PREVIOUS BLOCK
01300 SKIPN PREV ;IF A PREV BLOCK DOES NOT EXIST,
01400 MOVEI PREV,FRELST(USER) ; USE FRELST POINTER
01500 HRRM NEXT,(PREV) ;CHANGE ITS NEXT FIELD
01600 SKIPE NEXT ;IF A NEXT BLOCK EXISTS,
01700 HRLM PREV,(NEXT) ; CHANGE ITS PREV FIELD
01800 POPJ P, ;BLOCK IN "THIS" IS NO LONGER ON FRELST
01900
02000 DSCR RELINK
02100 CAL PUSHJ
02200 PAR AC THIS → core block to be placed on free storage list
02300 AC LAST → last word of block +1
02400 AC SIZ has size of this block
02500 DES block is placed on CORSERs free storage list
02600 SID AC NEXT (1) is given the appropriate value
02700 ⊗
02800
02900 RELINK:
03000 HRRZM THIS,-1(LAST) ;X-BIT ← 0, RH ← PTR TO HEAD
03100 MOVEM SIZ,1(THIS) ;GREATER 0 SIZE FIELD ⊃ FREE BLOCK
03200 SKIPE NEXT,FRELST(USER) ;PLACE NEW BLOCK ON FRONT OF FRELST
03300 HRLM THIS,(NEXT) ; IF THERE IS ONE
03400 HRRZM NEXT,(THIS) ;POINT TO NEXT FROM THIS
03500 HRRZM THIS,FRELST(USER) ;UPDATE FRELST POINTER
03600 POPJ P, ;RETURN
03700
03800 DSCR CORE2I
03900 CAL PUSHJ
04000 DES Initializes second segment core if there is a global model
04100 ⊗
04200
04300 GLOB <
04400 IFN 0,<
04500 ↑GLCOR:
04600 SKIPE GLBPNT
04700 POPJ P, ;ALREADY INITIALIZED.
04800 MOVEM 16,GLUSER+LEABOT+16
04900 MOVEI 16,GLUSER+LEABOT
05000 BLT 16,GLUSER+LEABOT+15
05100 ;SHALL NOT CLOBBER ACCUMULATOR 1.
05200 MOVEI 3,3(13) ;GET SIZE REQUIRED.PLUS SOME BECAUSE BLT LOSES.
05300 PUSHJ P,CORE2 ;GET SECOND SEGMENT CORE.
05400 JRST [TERPRI <NO CORE FOR GLOBAL MODEL>
05500 CALLI 12]
05600 SUBI 2,1
05700 MOVEM 2,GLBPNT ;AND RECORD IT.
05800 SETZM 1(2) ;FIRST WORD.
05900 HRRI 2,2(2) ;SECOND WORD.
06000 HRLI 2,-1(2) ;FIRST WORD.
06100 ADDI 3,-2(2) ;LENGTH.
06200 BLT 2,(3) ;ZERO IT.....
06300 MOVSI 16,GLUSER+LEABOT
06400 BLT 16,16 ;RESTORE ALL LOADER'S AC'S AGAIN.
06500 POPJ P, ;AND GO AWAY.
06600 >
06700 ↑CORE2I:
06800 PUSH P,USER
06900 MOVE USER,[XWD GLUSER+LEABOT+20,GLUSER+LEABOT+21]
07000 SETZM GLUSER+LEABOT+20
07100 BLT USER,GLUSER+ZAPEND
07200 POP P,USER ;NOW DATA AREA IS ZERO.
07300 MOVEI USER,GLUSER ;SET UP FOR CORE2.
07400 PUSHJ P,JUSTSAVE ;AND SAVE AC'S
07500 SETOM CORLOK ;THE LOCK ...
07600 SETOM GLBPNT ;AND THE SWITCH SAYING INITED.
07700 MOVE THIS,TOP2 ;LAST ADDRESS IN SEC. SEG USED.
07800 ADDI THIS,1
07900 MOVEM THIS,LOWC(USER) ;SAVE FOR LATER
08000 PUSHJ P,NEWB2 ;AND LINK UP.
08100 JRST BUFRST ;ALL DONE INITIALIZING.
08200
08300 DSCR 2d SEGMENT CORE CONTROL STORAGE
08400 ⊗
08500
08600 CORLOK: 0
08700
08800 CR2BEG: BLOCK ZAPEND-ZAPBEG+1 ;AREA FOR ALL OTHERS.
08900
09000 ↑↑GLUSER←CR2BEG-ZAPBEG ;AND THE MAGIC INDEX.
09100 INTERNAL GLUSER
09200
09300 >;GLOB
09400
00100
00200 DSCR BUFRST
00300 CAL PUSHJ or JRST
00400 RES restores ACs from CORSER routines, and returns
00500 ⊗
00600
00700 BUFRST:
00800 IFN DEBCOR,<
00900 SKIPE PRTCOR ;SHOULD WE DEBUG?
01000 JFCL
01100 >
01200 MOVSI TEMP,BUFACS(USER)
01300 BLT TEMP,LAST
01400 POPJ P,
01500
01600 DSCR BUFSAV
01700 CAL PUSHJ
01800 RES Saves ACs for CORSER routine
01900 Initializes CORSER storage, obtains USER TABLE if GOGTAB is 0
02000 ⊗
02100
02200 BUFSAV:
02300 GLOB <
02400 SKIPN GLBPNT ;HAS GLOBAL MODEL BEEN INITIALIZED?
02500 PUSHJ P,CORE2I ;NO --INITIALIZE IT.
02600 >;GLOB
02700 SKIPE USER,GOGTAB ;CAN WE GO AHEAD?
02800 JRST JUSTSAVE ; YES
02900
03000 Comment ⊗ Use SALTAB and forget the rest if SALTAB is there. Otherwise
03100 set up a user table. Don't use THIS or SIZ (B or C). ⊗
03200
03300 NOEXPO <
03400 MOVEI TEMP,=76*=1024 ;ONE REALLY MUST KNOW WHAT HE
03500 >;NOEXPO
03600 EXPO <
03700 MOVEI TEMP,-1 ;FOR MAX CORE
03800 >;EXPO
03900 MOVEM TEMP,JOBFF ; IS DOING
04000
04100 ; SKIPE USER,SALTAB ;OTHERS CAN SPECIFY SAIL SPACE
04200 ; MOVEM USER,GOGTAB ;SET UP GOGTAB IF SALTAB NON-ZERO
04300 ; JUMPN USER,JUSTSAVE ;DON'T GO THRU SAIL's ALLOCATION
04400
04500 ; ASSUME THAT THE WORLD IS NEW
04600
04700 HLRZ USER,JOBSA ;USER TABLE ADDRESS
04800 MOVEM USER,GOGTAB ;THIS TIME FOR SURE
04900 SKIPN JOBDDT ;IF DDT IS IN CORE,
05000 JRST NODDT ; MAKE SURE ITS SYMBOLS ARE PROTECTED
05100 HRRZ TEMP,JOBSYM ;IF JOBSYM IS BELOW JOBFF, THEN
05200 CAML TEMP,USER ; ASSUME ALL SYMBOLS ARE BELOW.
05300 JRST [ TERPRI <YOUR SYMBOLS ARE SOON TO BE OBLITERATED>
05400 JRST .+1]
05500
05600
05700 NODDT: MOVEI TEMP,ENDREN-CLER+=2000(USER) ;MAKE SURE
05800 CAMGE TEMP,JOBREL ; ENOUGH CORE EXISTS
05900 JRST CORTHER ; FOR USER TABLE
06000
06100 NOTENX<
06200 CALL6 (TEMP,CORE) ;GET ENOUGH
06300 ERR <DRYROT -- NO ROOM FOR USER TABLE>
06400 >;NOTENX
06500 TENX<
06600 HRRZM TEMP,JOBREL ;Simulate CORE UUO. Perhaps someday
06700 ;protect pages not released by CORGET
06800 ;to provide ILL MEM REF's for diagn.
06900 >;TENX
07000
07100 CORTHER:
07200 SETZM (USER) ;CLEAR USER TABLE
07300 HRL TEMP,USER
07400 HRRI TEMP,1(USER)
07500 BLT TEMP,ENDREN-CLER(USER)
07600 MOVEI THIS,ENDREN-CLER(USER) ;SET UP LIMITS OF FREE SPACE
07700 MOVEM THIS,LOWC(USER) ; BOTTOM
07800 PUSHJ P,NEWBLK ;MAKE NEW AREA INTO A FREE BLOCK
07900 JRST JUSTSAVE ;SAVE ACS
08000
08100 GLOB <
08200 NEWB2: CALLI LAST,SEGSIZUUO ;FIND OUT HOW BIG.
08300 TRO LAST,400000 ;SINCE ANDY DOES NOT GIVE ME THIS.
08400 JRST NEWB1
08500 >;GLOB
08600 NEWBLK:
08700 HRRZ LAST,JOBREL ;END OF BIG BLOCK
08800 NEWB1: SETZM (THIS) ;POINTERS WORD IN BIG BLOCK
08900 ADDI LAST,1 ;CONFORM TO "LAST" STANDARDS
09000 MOVEM LAST,TOP(USER) ;TOP OF FREE SPACE
09100 PUSH P,SIZ ;SAVE SIZE
09200 MOVE SIZ,LAST ;COMPUTE SIZE OF NEW BLOCK
09300 SUB SIZ,THIS ;SIZE OF BIG BLOCK
09400 PUSHJ P,RELINK ;PUT ON FREE STORAGE LIST
09500 POP P,SIZ ;GET SIZ BACK
09600 POPJ P,
09700
09800
09900 JUSTSAVE:
10000 MOVEI TEMP,BUFACS(USER)
10100 BLT TEMP,BUFACS+LAST(USER)
10200 IFN DEBCOR,<
10300 SKIPE PRTCOR ;SHOULD WE DEBUG?
10400 PUSHJ P,CORPRT ; YES
10500 >
10600 POPJ P,
10700
10800
10900 IFN DEBCOR,<
11000 ↑PRTCOR: 0
11100 >
00100 SUBTTL CORGET
00200
00300 DSCR CORGET
00400 CAL PUSHJ
00500 PAR size of desired block in AC C (3)
00600 RES SUCCESS: addr of block in B, skip-return
00700 FAILURE: no-skip
00800 SID none, except when called with GOGTAB 0 -- should only be done by experts
00900 DES a block of at least the required size is obtained using first-fit algorithm.
01000 Up to 10 extra words may be returned, but this is not reflected in C.
01100 ⊗
01200
01300 ↑CORGET:
01400 IFN DEBCOR,<
01500 SKIPE PRTCOR
01600 TERPRI <CORGET: > ;TELL THE PEOPLE WHO YOU ARE
01700 >
01800 PUSHJ P,BUFSAV ;SAVE AC'S, INITIALIZE WORLD PERHAPS
01900 GLOB <
02000 SKIPN USCOR2(USER) ;ARE WE INSTRUCTED TO USE CORE2?
02100 JRST COR21 ;NOPE -- GO AHEAD.
02200 ↑↑CORE2: SKIPN GLBPNT ;HAS IT BEEN INITIALIZED?
02300 PUSHJ P,CORE2I ;NO -- BUT NOW.
02400 AOSE CORLOK ;CAN WE GET THROUGH THE LOCK?
02500 JRST [SOS CORLOK ;APPARENTLY NOT.
02600 PUSHJ P,WAITQQ ;WAIT
02700 JRST .-1]
02800 MOVEI USER,GLUSER ;USE THIS VERSION OF USER.
02900 PUSHJ P,JUSTSAVE ;JUST SAVE THE ACCUMULATORS.
03000 >;GLOB
03100
03200
03300 COR21: ADDI SIZ,3 ;3 WORDS FOR CONTROL INFO
03400 SKIPE ATTOP(USER) ;IF USER REQUESTS IT, GET BLOCK
03500 JRST EXPAND ; AT TOP OF CORE
03600
03700 MOVEI THIS,FRELST(USER) ;THIS WILL POINT TO THE FIRST GOOD BLOCK
03800
03900 GETLUP: HRRZ THIS,(THIS) ;→NEXT FREE BLOCK
04000 JUMPE THIS,EXPAND ;TRY TO EXPAND CORE, NONE EXIST YET
04100 CAMLE SIZ,1(THIS) ;WILL IT FIT?
04200 JRST GETLUP ; NO, TRY NEXT
04300
04400 GETCOR: AOS (P) ;SUCCESS GUARANTEED
04500 HRRZM THIS,BUFACS+THIS(USER) ;RESULT(ALMOST)
04600 PUSHJ P,UNLINK ;UNLINK THIS BLOCK
04700 MOVE LAST,1(THIS) ;REAL BLOCK SIZE
04800 CAIGE LAST,TRIVIAL(SIZ) ;IS DIFFERENCE NEGLIGIBLE?
04900 JRST [MOVSI TEMP,400000 ;YES, USE WHOLE THING --
05000 ADD LAST,THIS ; MARK X-BIT TO INDICATE IN USE
05100 HLLM TEMP,-1(LAST)
05200 JRST GETOUT] ;AND GO FINISH OUT
05300
05400 MOVEM SIZ,1(THIS) ;NEW SIZE FOR RESULT
05500 HRRZ TEMP,THIS ;SAVE START OF BLOCK (RESULT)
05600 ADD THIS,SIZ ;NEW START FOR REMAINING FREE STUFF
05700 SUB LAST,SIZ ;NEW SIZE FOR REMAINS
05800 MOVE SIZ,LAST
05900 ADD LAST,THIS ;NEW END FOR REMAINS
06000 HRLI TEMP,400000 ;TURN X-BIT ON
06100 MOVEM TEMP,-1(THIS) ;IN USER'S BRAND NEW BLOCK
06200 PUSHJ P,RELINK ;RELINK REMAINS, RESTORE ACS
06300
06400
06500 GETOUT: PUSHJ P,GETRST ;RESTORE ACS
06600 SETZM (THIS) ;PTR RETRIEVED FROM STORAGE
06700 MOVNS 1(THIS) ;SIZE NEG ⊃ IN USE
06800 ADDI THIS,2 ;USER DOESN'T SEE THIS HEADER
06900 IFN DEBCOR,<
07000 SKIPE PRTCOR
07100 PUSHJ P,CORPRT
07200 >
07300 POPJ P, ;HERE'S YOUR BLOCK!
00100
00200 EXPAND: SKIPE XPAND(USER) ;IS IT ALLOWED TO EXPAND?
00300 JRST GETRST ; NO, ERROR RETURN
00400 PUSH P,SIZ ;SAVE TOTAL SIZE
00500 HRRZ THIS,TOP(USER) ;THIS→NEW BLOCK IF NEXT LOWER IS USED
00600 SKIPGE -1(THIS) ;IS TOP BLOCK FREE?
00700 JRST GETMOR ; NO, USE WHAT YOU HAVE
00800 HRRZ THIS,-1(THIS) ;UNLINK THE
00900 PUSHJ P,UNLINK ; TOP BLOCK
01000
01100 GETMOR: MOVE TEMP,THIS
01200 ADDI TEMP,=1024(SIZ) ;GET MORE AND THEN SOME
01300 POP P,SIZ ;GET THIS BACK BEFORE YOU FORGET
01400 GLOB <
01500 CAIN USER,GLUSER ;THIS IS HOW WE TELL
01600 JRST [CALLI TEMP,CORE2UUO ;GET SOME CORE
01700 JRST GETRST ;HE SPAT UPON OUR HUMBLE REQUEST.
01800 PUSHJ P,NEWB2 ;LINK IT UP
01900 JRST .+4]
02000 >;GLOB
02100 NOTENX<
02200 CALL6 (TEMP,CORE) ;ASK FOR MORE
02300 JRST GETRST ;CAN'T GET IT
02400 >;NOTENX
02500 TENX<
02600 HRRZM TEMP,JOBREL
02700 >;TENX
02800 PUSHJ P,NEWBLK ;MAKE TOP LOOK LIKE FREE BLOCK
02900 CAMLE SIZ,1(THIS) ;NOW SHOULD FIT
03000 ERR <DRYROT -- EXPAND CODE GLUBBED UP>
03100 JRST GETCOR ;GO GET BLOCK
03200
03300 GETRST:
03400 GLOB <
03500 PUSHJ P,BUFRST ;RESTORE ACCUMULATORS.
03600 CAIN USER,GLUSER ;WAS IT CORE2?
03700 SOS CORLOK ;YES -- BACK UP COUNT.
03800 MOVE USER,GOGTAB ;RESET IT TO USUAL.
03900 POPJ P, ;
04000 >;GLOB
04100 JRST BUFRST
00100 SUBTTL CORINC, CANINC
00200
00300 DSCR CORINC
00400 CAL PUSHJ
00500 PAR AC B -- Addr of block to be incremented
00600 AC C -- amount if increase desired
00700 RES SUCCESS: skip-return, extra core has been granted
00800 FAILURE: no-skip
00900 SID none
01000 ⊗
01100
01200 ↑↑CORINC:
01300 IFN DEBCOR,<
01400 SKIPE PRTCOR
01500 TERPRI <CORINC:>
01600 >
01700 PUSHJ P,JUSTSAVE ;SAVE ACS
01800 MOVNI FF,1 ;WANT TO DO IT
01900 JRST INCR
02000
02100 DSCR CANINC
02200 CAL PUSHJ
02300 PAR same as CORINC
02400 RES No extra core is ever actually obtained
02500 if entire request can be granted, skip-return
02600 if some extra words available, no-skip, C contains possible increment
02700 if no extra words available, no-skip, C contains 0
02800 SID none except as described above
02900 ⊗
03000
03100 ↑↑CANINC:
03200 IFN DEBCOR,<
03300 SKIPE PRTCOR
03400 TERPRI <CANINC: >
03500 >
03600 PUSHJ P,BUFSAV
03700 MOVEI FF,0 ;JUST WANT TO SEE IF IT'S POSSIBLE
03800
03900 ; IF BLOCK IS AT TOP, CAN ALWAYS DO IT
04000
04100 INCR: SUBI THIS,2 ;POINT AT REAL BLOCK HEAD
04200 GLOB <
04300 TRNE THIS,400000 ;CHECK TO SEE IF CORE2
04400 ERR <NO CANINC SECOND SEGMENT SPACE>
04500 >;GLOB
04600 HRRZ LAST,THIS ;CHECK AT TOP
04700 SUB LAST,1(THIS) ; ADDR OF END (SIZE IS NEG)
04800 CAMGE LAST,TOP(USER) ;TOP BLOCK?
04900 JRST MIDDLE ; NO
05000 JUMPE FF,YESINC ;SUCCESS
05100 MOVNS 1(THIS) ;MAKE IT LOOK FREE
05200 ADD SIZ,1(THIS) ;TOTAL SIZE
05300 HRRZS -1(LAST) ;MAKE END LOOK FREE
05400 JRST EXPAND ;EXPAND AND RETURN
05500
05600 MIDDLE: SKIPGE TEMP,1(LAST) ;NEXT BLOCK FREE?
05700 JRST NONEATALL ; NO, FAILURE
05800 SUBI TEMP,3 ;AVAILABLE SIZE
05900 CAMLE SIZ,TEMP ;IS THERE ENOUGH?
06000 JRST MAYBE ; NO, FAILURE MAYBE
06100
06200 JUMPE FF,YESINC ;ALL OK, CAN DO, REPORT IT
06300 CRXXB: MOVNS TEMP,1(THIS) ;MAKE IT LOOK FREE
06400 PUSH P,(THIS) ;WILL RESTORE THIS IN CASE SOMEONE USED
06500 PUSH P,THIS ;SAVE SIZE
06600 PUSH P,SIZ ;AND POINTER
06700 ADDM TEMP,(P) ;TOTAL SIZE DESIRED AFTER RETURN
06800 MOVE SIZ,TEMP ;SIZE OF CURRENT "THIS"
06900 HRRZ THIS,LAST ;MERGE "THIS" WITH "LAST"
07000 PUSHJ P,UNLINK ;TAKE IT OFF FRELST
07100 ADD LAST,1(THIS) ;AND INCREASE
07200 ADD SIZ,1(THIS)
07300 MOVE THIS,-1(P) ;RETRIEVE CURRENT BLOCK.
07400 PUSHJ P,RELINK ;AND NOW RELINK ON FRELST.
07500 POP P,SIZ
07600 POP P,THIS
07700 PUSHJ P,GETCOR ;GET THE BLOCK AGAIN, ONLY BIGGER
07800 ERR <DRYROT> ;CAN'T HAPPEN
07900 POP P,-2(THIS) ;GET POINTER WORD BACK
08000 AOS (P) ;SUCCESS
08100 POPJ P, ;BUFRST DONE BY GETCOR
08200
08300 YESINC: AOS (P) ;REPORT SUCCESS
08400 IFN DEBCOR,<
08500 SKIPE PRTCOR
08600 PUSHJ P,CORPRT
08700 >
08800 JRST BUFRST
08900
09000 MAYBE: ADDI TEMP,3(LAST) ;GET TOP OF NEXT BLOCK AND SEE
09100 CAMGE TEMP,TOP(USER) ;IF IT IS THE TOP ONE.
09200 JRST NOTENUF ;NO -- FAIL UTTERLY.
09300 JUMPE FF,YESINC ;GOT IT IF ONLY GOING TO HERE.
09400 PUSH P,SIZ ;SAVE AMOUNT REQUESTED.
09500 MOVEI SIZ,-3(TEMP) ;THIS IS THE SIZE OF THE BLOCK WE
09600 SUB SIZ,LAST ;KNOW WE CAN GET.
09700 MOVN TEMP,SIZ
09800 ADDM TEMP,(P) ;(P) NOW HAS EXTRA REQUIRED.
09900 PUSHJ P,CRXXB ;AND WE DO SOO
10000 ERR <DRYROT> ; CAN'T HAPPEN.
10100 POP P,SIZ ;RETRIEVE SIZE.
10200 MOVNI FF,1 ;SINCE CRXXB DESTROYED IT.
10300 JRST INCR ;AND GO THROUGH AGAIN
10400 ;THIS TIME IT WILL BE THE TOP BLOCK.
10500
10600
10700 NOTENUF:
10800 SUBI TEMP,3(LAST) ;UNDO WHAT WAS DONE ABOVE
10900 SKIPA SIZ,TEMP ;CAN'T DO ALL, BUT CAN DO THIS MUCH
11000
11100 NONEATALL:
11200 MOVEI SIZ,0 ;CAN'T DO ANYTHING
11300 MOVEM SIZ,BUFACS+SIZ(USER)
11400 JRST BUFRST
11500
00100 SUBTTL CORREL
00200
00300 DSCR CORREL
00400 CAL PUSHJ
00500 PAR addr of block to be released in B
00600 RES block is released to free storage
00700 SID none
00800 DES the block is merged with any adjoining free blocks
00900 ⊗
01000
01100 ↑↑CORREL:
01200 IFN DEBCOR,<
01300 SKIPE PRTCOR
01400 TERPRI <CORREL: >
01500 >
01600 SKIPN USER,GOGTAB ;MUST BE SET UP HERE
01700 ERR <DRYROT -- CORREL CALLED WITH INITIALIZED WORLD>
01800 GLOB <
01900 TRNN THIS,400000 ;IS IT SECOND SEGMENT ADDRESS?
02000 JRST NOSGR ;NO
02100 MOVEI USER,GLUSER ;USE THIS ONE.
02200 AOSE CORLOK ;SEE IF WE CAN GET IN.
02300 JRST [SOS CORLOK
02400 PUSHJ P,WAITQQ
02500 JRST .-1]
02600 NOSGR:
02700 >;GLOB
02800 PUSHJ P,JUSTSAVE ;SAVE ACS
02900
03000 ; MERGE WITH LOWER NEIGHBOR (ADDRESS-WISE) IF POSSIBLE
03100
03200 SUBI THIS,2 ;USER THINKS IT STARTED 2 PAST
03300 MOVN SIZ,1(THIS) ;SIZE OF THIS BLOCK
03400 MOVE LAST,SIZ ;ADDRESS OF UPPER
03500 ADD LAST,THIS ; NEIGHBOR
03600
03700 CAMGE THIS,LOWC(USER) ;IS ADDRESS IN RANGE?
03800 ERR <DRYROT -- BAD ADDRESS TO CORREL>
03900 CAME THIS,LOWC(USER) ;CAN THERE BE A LOWER BLOCK
04000 SKIPGE -1(THIS) ; AND IF SO, IS IT FREE?
04100 JRST UPPET ; NO, LOOK FOR UPPER BLOCK
04200
04300 HRRZ THIS,-1(THIS) ;→LOWER BLOCK
04400 PUSHJ P,UNLINK ;UNLINK IT FROM LIST
04500 ADD SIZ,1(THIS) ;INCREASE SIZE
04600
04700 ; MERGE WITH UPPER NEIGHBOR IF POSSIBLE
04800
04900 UPPET: CAMLE LAST,TOP(USER)
05000 ERR <YOU ARE ABOUT TO GET AN ILL MEM-REF>,1
05100
05200 CAME LAST,TOP(USER) ;IS THERE AN UPPER BLOCK?
05300 SKIPGE 1(LAST) ;AND IF SO, IS IT FREE?
05400 JRST LNKRET ; NO, RELINK AND GO AWAY
05500
05600 UPPR: PUSH P,THIS
05700 HRRZ THIS,LAST ;THIS → UPPER NEIGHBOR
05800 PUSHJ P,UNLINK ;GET IT OUT
05900 ADD LAST,1(THIS) ; INCREASE EXTENT
06000 ADD SIZ,1(THIS) ; AND TOTAL SIZE
06100 POP P,THIS ; GET HEADER POINTER BACK
06200 LNKRET:
06300 GLOB <
06400 CAIN USER,GLUSER
06500 JRST LNKRT ;IF SEC SEGMENT, NEVER SHRINK
06600 >;GLOB
06700 ;;#IC# 7-3-72 DCS (1-1) ADD NEW MEANING TO NOSHRK(USER)
06800 SKIPL TEMP,NOSHRK(USER) ;If NOSHRK(USER) is:
06900 CAMG LAST,JOBREL ; <0, CORREL should not reduce core;
07000 JRST LNKRT ; >0, its RH indicates the amount of
07100 JUMPN TEMP,.+2 ; free space which should be
07200 MOVEI TEMP,=2046 ; protected from release;
07300 HRRZS TEMP ; =0, at least 2K should be protected.
07400 CAIGE TEMP,4 ;Only the first and third alternatives
07500 MOVEI TEMP,4 ; were previously available.
07600 CAMGE SIZ,TEMP ;Don't bother if there is already
07700 JRST LNKRT ; less free space available than
07800 ADDI TEMP,(THIS) ; desired
07900 ;;#IC# (1-1)
08000 NOTENX<
08100 CALL6 (TEMP,CORE)
08200 ERR <DRYROT --CORSER&LNKRET>
08300 >;NOTENX
08400 TENX< HRRZM TEMP,JOBREL
08500 >;TENX
08600 MOVE LAST,JOBREL ; AND 2) ADJUST BLOCK TO INDICATE
08700 ADDI LAST,1
08800 MOVEM LAST,TOP(USER) ;AND RECORD NEW RESULTS.
08900 MOVE SIZ,LAST ; THE CHANGE BEFORE RELINKING
09000 SUB SIZ,THIS
09100 LNKRT:
09200 PUSHJ P,RELINK ;PUT IT BACK
09300 IFN DEBCOR,<
09400 SKIPE PRTCOR
09500 PUSHJ P,CORPRT
09600 >
09700 JRST GETRST ;AND GO AWAY
09800
00100 SUBTTL CORPRT, CORBIG
00200
00300 IFN DEBCOR,<
00400 ↑CORPRT:
00500 SETZM TOTFRE# ;TOTAL FREE STORAGE COUNT
00600 TERPRI <FREE STORAGE: >
00700 PUSH P,LPSA
00800 MOVE USER,GOGTAB ;THIS STUFF IS DEBUGGING
00900 MOVEI LPSA,FRELST(USER) ;JUNK FOR CORGET AND FRIENDS
01000
01100 CPLUP: HRRZ LPSA,(LPSA) ;IT SHOULD BE INTUITIVELY
01200 JUMPE LPSA,DUNNN ;OBVIOUS
01300 PRINT <START = >
01400 OCTPNT LPSA
01500 MOVE TEMP,1(LPSA)
01600 ADDM TEMP,TOTFRE
01700 PRINT < SIZE = >
01800 OCTPNT TEMP
01900 ADD TEMP,LPSA
02000 PRINT < END = >
02100 OCTPNT TEMP
02200 TERPRI
02300 JRST CPLUP
02400
02500 DUNNN:
02600 PRINT <TOTAL FREE SIZE = >
02700 OCTPNT TOTFRE
02800 SETOM PRTCOR
02900 TERPRI
03000 CAMLE THIS,JOBREL
03100 JRST DUNMOR
03200 TERPRI <THIS BLOCK: >
03300 PRINT <"THIS" = >
03400 MOVE TEMP,THIS
03500 OCTPNT TEMP
03600 PRINT < C-SIZE = >
03700 HRRZ TEMP,SIZ
03800 OCTPNT TEMP
03900 CAML THIS,JOBREL
04000 JRST DUNMOR
04100 HRREI LPSA,-2(THIS)
04200 JUMPLE LPSA,DUNMOR
04300 PRINT < BLOCK-SIZE = >
04400 MOVN TEMP,1(LPSA)
04500 OCTPNT TEMP
04600
04700 DUNMOR: TERPRI
04800 POP P,LPSA
04900 NOTENX<
05000 TTCALL 11,
05100 TTCALL TEMP
05200 >;NOTENX
05300 TENX<
05400 MOVEM A,TEMP
05500 HRRZI A,100
05600 JSYS CFIBF
05700 JSYS PBIN
05800 EXCH A,TEMP
05900 >;TENX
06000 TERPRI
06100 POPJ P,
06200
06300 >
06400
06500 DSCR CORBIG
06600 CAL PUSHJ
06700 PAR NONE
06800 RES LARGEST AVAILABLE BLOCK IN SIZ (3,C)
06900 SID THIS (2,B) MUNGED
07000 ⊗
07100
07200 ↑↑CORBIG: SKIPN USER,GOGTAB
07300 ERR <CORBIG: INITIALIZED WORLD>
07400 MOVEI SIZ,0 ;"ZERO-LENGTH" BLOCK
07500 MOVEI THIS,FRELST(USER)
07600 BIGLUP: HRRZ THIS,(THIS)
07700 JUMPE THIS,BIGDUN ;END OF FREELIST?
07800 CAMGE SIZ,1(THIS)
07900 MOVE SIZ,1(THIS) ;FIND MAX
08000 JRST BIGLUP
08100 BIGDUN: SUBI SIZ,3 ;WHAT HE SEES
08200 POPJ P,
08300
08400
08500
08600 Comment ⊗ No other core routines should be necessary to provide
08700 gross control over allocation. Programs obtaining
08800 space from CORGET can carve the blocks up if necessary.
08900 Please put your core back when you're done with it.
09000
09100 Thank You,
09200 The Management
09300
09400 ⊗
09500 >;NOLOW
09600 ENDCOM (COR)
09700 IFN ALWAYS,<
09800 BEND CORSER
09900 >
10000
10100 COMPIL(SGC,<STRNGC,STRGC,STCLER,SGINS,SGREM,%SPGC1,%ARSR1>
10200 ,<GOGTAB,X11,CORGET,CORREL,CORINC,X22,CORBIG,SPRPDA>
10300 ,<STRING GARBAGE COLLECTOR ROUTINES>
10400 ,<%SPGC,%STRMRK,%ARRSRT>)
00100 ;String Garbage Collector Routines
00200
00300 NOLOW < ;INCLUDE IN UPPER SEGMENT.
00400
00500 BKSZ←←=25 BKOFF←←=23 MLT←←5
00600
00700
00800 ↑.CORERR:
00900 ↑CORERR:
01000 ERR <NO CORE FOR ALLOCATION>
01100
01200 DSCR STRGC(# chars desired);
01300 CAL SAIL
01400 RES calls string garbage collector with #chars in -1(p)..i.e.a formal param.
01500 ⊗
01600
01700 HERE (STRGC)
01800 EXCH A,-1(P) ;THE DESIRED A IS HERE
01900 MOVE USER,GOGTAB
02000 MOVEM RF,RACS+RF(USER);SAVE F REGISTER WHERE GC CAN FIND.
02100 PUSHJ P,STRNGC ;COLLECT TRASH
02200 SUB P,X22 ;BACK UP STACK
02300 MOVNS A
02400 ADDM A,REMCHR(USER)
02500 MOVE A,1(P) ;GET ORIGINAL "A" BACK
02600 JRST 2,@2(P) ;RETURN
02700
02800
02900
03000 DSCR STRNGC
03100 CAL PUSHJ
03200 PAR A -- number of new characters needed
03300 REMCHR(USER) -- has been updated by that number of chars
03400 RES String space is compacted, new REMCHR is updated by C(A).
03500 Restarts if not enough room left
03600 SID none
03700 DES STRNGC is a two-pass process. In the first, all string descriptors
03800 are found and sorted into ascending sequence with respect to the locations
03900 of their respective texts. String descriptors are found via the generating
04000 routines, described in CALSG.
04100 In the second pass, all string texts are moved down to fill any
04200 unused space. All descriptors are adjusted to reflect the new locations.
04300 ⊗
04400
04500 ↑STRNGC: MOVE USER,GOGTAB ;GET USER TABLE POINTER
04600
04700 MOVEM 12,SGACS+12(USER)
04800 MOVEI 12,SGACS(USER)
04900 BLT 12,SGACS+11(USER)
05000
05100 ; →→→→→→ OBTAIN SPACE, INITIALIZE GARBAGE COLLECTOR ←←←←←←
05200
05300 HRRZ TEMP,TOPBYTE(USER) ;MAKE SURE DIDN'T OVERFLOW
05400
05500 ; **** BUG TRAP
05600 CAMG TEMP,STTOP(USER)
05700 CAMGE TEMP,ST(USER)
05800 ERR <DRYROT AT STRNGC>
05900 ; **** EBT
06000
06100 SUB TEMP,ST(USER) ;CREATE A DIVISOR FOR DISTRIBUTION
06200 ADDI TEMP,5 ; OF DESCRIPTORS DURING SGSORT
06300 MOVEM TEMP,INKY(USER)
06400 SKIPE XPAND(USER) ;ALLOWED TO EXPAND?
06500 JRST INSIDE ; NO
06600 SETOM ATTOP(USER) ;WANT BLOCK OFF THE TOP FOR SAFETY
06700 MOVEI C,=400 ;REASONABLE SIZE
06800 PUSHJ P,CORGET ;IF CAN'T GET IT, TROUBLE
06900 SKIPA ;TRY TO GET WHAT YOU CAN
07000 JRST CORROK ;GOT IT
07100 INSIDE: SETZM ATTOP(USER) ;CAN'T EXPAND
07200 PUSHJ P,CORBIG ;HOW MUCH CAN WE HAVE?
07300 PUSHJ P,CORGET ;GET THAT AMOUNT
07400 ERR <DRYROT - STRNGC CAN'T GET CORE>
07500 CORROK: SETZM ATTOP(USER) ;NOW CAN GET ANYWHERE
07600 MOVEM B,STBUCK(USER) ;SAVE → TO BLOCK
07700 SETZM (B)
07800 HRLS B
07900 ADDI B,1
08000 MOVEI TEMP,BKOFF(B)
08100 BLT B,(TEMP)
08200 MOVE B,STBUCK(USER)
08300 ADDI B,BKSZ ;FIRST BKSZ WORDS IS "BUCKET" LIST
08400 MOVNI C,-BKSZ(C)
08500 JUMPGE C,CORERR ;BAD THING
08600 HRL B,C
08700 SUB B,X11 ;IOWD FOR WORD ALLOC IN STRNGC
08800 MOVEM B,SGFRE(USER) ;FREE SPACE POINTER
08900
09000 HRRZ A,ST(USER)
09100 HRLI A,(<POINT 7,0>)
09200 MOVEM A,TOPBYTE(USER) ;FIRST(USER) NEW OK POSITION
09300 SETZM NUMCHR(USER) ;TOTAL # CHARS PREVIOUSLY MOVED
00100
00200 ; →→→→→→ SORT THE STRINGS ←←←←←←←←←
00300 DSCR CALSG
00400 PAR linked list of routine addresses based at SGROUT(USER)
00500 RES each routine in list is called to provide string descriptors
00600 to the sorting routine, SGSORT.
00700 SID SGSORT uses B,C,D,E,TEMP, accepts input in A. Generating
00800 routines may use A-T1 (12) and TEMP for their own devices.
00900 Q1 through T1 will not be changed by calls on SGSORT.
01000 DES Each generating routine should do the following:
01100 1) Place a string descriptor in A
01200 2) PUSHJ P,SGSORT or PUSHJ P,@-1(P) (addr provided on stack)
01300 3) Repeat the process if it knows about more strings, else return
01400 4) Return with a POPJ (and a flourish)
01500
01600 The `standard' generating routines are:
01700 SPSG -- collects the string stack
01800 STRMRK -- collects string variables linked through SGLINK(USER)
01900 ARRMRK -- collects string arrays found in ARRPDL
02000 RINGSORT -- collects PNAMES from semantic blocks in compiler
02100 DEFSRT -- collects saved input strings during macro recursion in compiller
02200 These routines should provide sufficient examples.
02300
02400 ⊗
02500
02600
02700 CALSG: MOVEI T,SGROUT(USER) ;GET LINKED LIST OF ROUTINE NAMES
02800 PUSH P,T ;SAVE FIRST POINTER
02900 PUSH P,[SGSORT] ;PROVIDE ACCESS TO SORTING ROUTINE
03000 ↑CALSGL:
03100 SKIPN T,@-1(P) ;GO DOWN LIST UNTIL DONE
03200 JRST ALLCOL ;DONE
03300 HRRZM T,-1(P) ;SAVE NEW POINTER
03400 PUSHJ P,@-1(T) ;CALL GENERATOR ROUTINE
03500 JRST CALSGL ;DO MORE THAN ONCE
03600
00100
00200 ; →→→→→→ SORT THE SP STACK ←←←←←←
00300
00400 HERE(%SPGC) HRRZ A,SPDL(USER) ;START AT BASE OF STACK
00500 ↑%SPGC1:ADDI A,1
00600 JRST SGTST ;AND WORK UP TO CURRENT POINTER
00700 STRNGSTACKMARKLOOP:
00800 PUSHJ P,SGSORT ;SORT IT INTO LIST
00900 SGTST:
01000 CAIGE A,(SP) ;DONE?
01100 JRST STRNGSTACKMARKLOOP ;NO
01200 GPOPJ: POPJ P, ;YES, GO ON TO NEXT TYPE
01300
01400 ; →→→→→→ SAIL COMPILER SPECIAL SORTERS ARE IN COMSER ←←←←←
01500
01600 ; →→→→→→ SORT THE VARIABLES ←←←←←←
01700
01800 HERE (%STRMRK)
01900 SKIPN T,STRLNK(USER) ;GET LINK
02000 POPJ P, ; NO STRINGS AT ALL
02100 STMKL1: HRRZ A,-1(T) ;→1ST STRING
02200 HLRZ Q2,-1(T) ;# STRINGS THIS PROC
02300 JRST SOJLP ;GO LOOP
02400 STMKLP:
02500 ; SKIPN -2(T) ;PROCEDURE ACTIVE?
02600 ; SETZM (A) ; NO, MAKE NULL STRINGS
02700
02800 Comment ⊗ Due to certain social pressures (WFW LIVES ON)
02900 strings in inactive blocks remain over garbage collection ⊗
03000
03100 PUSHJ P,SGSORT ;SORT VARIABLES INTO LIST
03200 SOJLP: SOJGE Q2,STMKLP ;SORT UNTIL DONE WITH THIS PROC (SGSORT INCRS A)
03300
03400 STRMK4: HRRZ T,(T) ;NEXT PROCEDURE
03500 JUMPN T,STMKL1 ; IF THERE IS ONE
03600 POPJ P, ;DONE
03700
03800
03900 COMMENT ⊗
04000 →→→→→→ SORT STRING ARRAYS ←←←←←←
04100
04200
04300 THIS ROUTINE TRIPS DOWN THE DYNAMIC LINKS, LOOKING INTO
04400 PROCEDURE DESCRIPTORS FOR STRING ARRAYS WHICH MIGHT HAVE BEEN ALLOCATED.
04500 THEN IT LOOKS FOR ANY ARRAYS OWNED BY LEAP. THE FIRST
04600 WORD OF EACH ARRAY BLOCK IS THE NUMBER OF DIMENSIONS IF THE
04700 ARRAY IS A STRING ARRAY. THE WORD JUST PREVIOUS TO IT IS THE
04800 (NEGATIVE) SIZE OF THE ARRAY.
04900 ⊗
05000
05100 INTERNAL %ARRSRT
05200 HERE (%ARRSRT)
05300 HRRZ RF,RACS+RF(USER);REAL RF WITH LH= 0
05400 ↑%ARSR1:
05500 PROCDO: HLRZ Q1,1(RF) ;FETCH PDA
05600 CAIN Q1,SPRPDA ;IS IT SPROUTER??
05700 POPJ P, ;YES
05800 MOVE Q1,PD.LLW(Q1) ;WE HAVE TO DO SOMETHING -- PT AT LVI
05900 CHK: SKIPN T,(Q1) ;GET ENTRY
06000 JRST GODOWN ;0 MEANS OF PROC DESCR
06100 ;;#HI#↓ 5-15-72 DCS WAS TESTING 200000 (TYPE 4?) BIT, WRONG BIT!
06200 TLC T,100000 ;TYPE 2? (STRING ARRAY)
06300 TLNE T,740000 ;
06400 AOJA Q1,CHK ;NO
06500 SKIPN A,@T ;THERE??
06600 AOJA Q1,CHK ;NO
06700 ;;# # 5-3-72 DCS
06800 SUBI A,1 ;A→2D WORD, FIRST ENTRY -- DCS 5-3-72
06900 ;;# #
07000 SKIPL Q2,-1(A) ;BETTER BE THERE
07100 ERR <DRYROT AT ARRSRT>
07200 PUSHJ P,ARPUTX ;GO SORT IT
07300 AOJA Q1,CHK
07400
07500 GODOWN: HRRZ RF,(RF) ;NOTE THAT RESTR WILL PUT RF BACK
07600 CAIE RF,-1 ;
07700 JRST PROCDO ;-1 WILL SAY END
07800
07900
08000 LARR: SKIPN T1,ARYLS(USER) ;LEAPING LISTS
08100 POPJ P, ;NONE
08200 LAR1:
08300 HLRZ Q2,(T1) ;GET ADDRESS
08400 ;;# # 5-3-72 DCS SET UP A
08500 MOVEI A,-1(Q2) ;A→1ST WORD, FIRST ENTRY
08600 ;;# #
08700 SKIPL Q2,-2(Q2) ;BE SURE
08800 ERR <LEAPING DRYROT AT ARRSRT>
08900 PUSHJ P,ARPUTX ;GO SORT IT
09000
09100 LAR2: HRRZ T1,(T1) ;MERRILY WE LINK ALONG
09200 JUMPN T1,LAR1 ;
09300 POPJ P, ;HOME AT LAST
09400
09500 ARPUTX:
09600 HRRZS Q2 ;YES, GET TOTAL SIZE
09700 LSH Q2,-1 ;NUMBER OF STRINGS
09800
09900 JRST ARSLP
10000
10100
10200 ARS3:
10300 PUSHJ P,SGSORT ; BUT COLLECT NON-CONSTANTS
10400 ARSLP: SOJGE Q2,ARS3 ;A INCREMENTED IN SGSORT, LOOP UNTIL DONE
10500 POPJ P, ;ALL DONE WITH THIS ARRAY.
00100
00200 ; SUBROUTINE ENTERED WITH A → A STRING DESCRIPTOR. CONVERTS
00300 ; IT TO GARBAGE COLLECTOR FORMAT. USES B, C.D,E,TEMP
00400 ; START CONTAINS FIRST #CHARS FOR BEGINNING OF STRING SPACE.
00500 ; WARNING ***** CLOBBERS B,C,D,E,TEMX **********
00600
00700 SGSORT:
00800
00900 HLLZ B,(A) ;GET STRING NUMBER
01000 JUMPE B,SGSRT ; DON'T COLLECT CONSTANTS OR NULL STRINGS
01100
01200 HRRZ D,1(A) ;MAKE SURE STRING IN RANGE
01300 HRRE C,(A) ;CHECK LENGTH CONSISTENCY
01400
01500 ; *** BUG TRAP
01600 JUMPE C,DONBUG ;DON'T WORRY MUCH ABOUT NULL STRINGS
01700 JUMPL C,BUGG
01800 CAMG D,STTOP(USER)
01900 CAMGE D,ST(USER)
02000 BUGG: ERR <DRYROT AT SGSORT>,1
02100 DONBUG:
02200 ; *** EBT
02300
02400 HLLZ B,1(A) ;GET POINTER AND SIZE FIELDS OF BP
02500 HRRI B,[BYTE (7) 0,1,2,3,4,5]
02600 ILDB B,B ;#CHARS REPRESENTED BY POINTER
02700 ;C HAS ADDR FILED OF BP (SEE ABOVE)
02800 SUB D,ST(USER) ; - STRING SPACE BASE
02900 IMULI D,5 ;#CHARS
03000 ADD B,D ; + CHARS IN POINTER
03100 MOVEM B,1(A) ; TO BP WORD
03200 ADD C,B ; + #CHARS FIELD (D LOADED ABOVE)
03300 ;RLS patch - allow > 52000 wrds stringspace on TENEX
03400 ; HRRZM C,(A) ;TO #CHARS WORD
03500 MOVEM C,(A) ;to #CHARS word
03600 MOVE D,B ;NOW DISTRIBUTE STRING TO PROPER
03700 IMULI D,MLT ; LIST TO SPEED SORT
03800 IDIV D,INKY(USER) ; SEE ABOVE FOR INKY CALC
03900 ADD D,STBUCK(USER) ;D→PROPER "BUCKET" ENTRY
04000
04100 ; *** BUG TRAP
04200 MOVE TEMP,STBUCK(USER)
04300 CAML D,TEMP
04400 CAIL D,BKSZ(TEMP)
04500 ERR <DRYROT AT SGSLUP>,1
04600 ; *** EBT
04700
04800
04900 ; A→ STRING DESCRIPTOR (MARKED) -- D→BUCKET LIST THIS STRING
05000 ; B IS START COUNT [=1(A)] -- C IS END COUNT [=(A)]
05100
05200 SGSLUP: MOVE E,D ;E←CDR(E), IN FACT
05300 HRRZ D,(E) ;D←CDR(E)
05400 SKIPN D ;DONE?
05500 JRST INSERT ; YES, INSERT AT END
05600 HLRZ TEMP,(D) ;TEMP←CAR(D)
05700 CAMGE B,1(TEMP) ;NEW START LESS?
05800 JRST INSERT ;YES, INSERT THIS ONE IN FRONT OF IT
05900 CAME B,1(TEMP) ;NEW START SAME?
06000 JRST SGSLUP ;NO, GREATER
06100
06200 ; EQUAL START COUNTS, ARRANGE BY END COUNT, DESCENDING SEQUENCE
06300
06400 CAMG C,(TEMP) ;NEW END GT OLD?
06500 JRST SGSLUP ;NO, CONTINUE
06600 ; (JRST INSERT) ;YES
06700
06800 INSERT:
06900 MOVE TEMP,SGFRE(USER)
07000 AOBJN TEMP,STILMOR ;EXPAND LINK SPACE
07100 SGXPND:
07200 PUSH P,TEMP
07300 MOVE B,STBUCK(USER) ;→CURRENT FWS BLOCK
07400 MOVEI C,=100 ;GET 100 MORE
07500 PUSHJ P,CORINC ;EXPAND THE BLOCK
07600 ERR <NO CORE FOR ALLOCATION>
07700 POP P,TEMP
07800 SUB TEMP,[(100)] ;THERE IS MORE
07900
08000 STILMOR:
08100 MOVEM TEMP,SGFRE(USER)
08200 HRLM A,(TEMP)
08300 HRRM D,(TEMP)
08400 HRRM TEMP,(E)
08500 SGSRT: ADDI A,2 ;AUTO-INDEXING
08600 POPJ P,
00100
00200 ; FIND A DISJOINT STRING GROUP, MOVE IT BACK.
00300 ; MARK POINTERS APPROPRIATELY.
00400
00500 ALLCOL: SUB P,X22 ;REMOVE JUNK PUT ON BY CALSG
00600
00700 SGSWEP:
00800 SETZB T,T1 ;IN CASE NO STRINGS AT ALL
00900 MOVEI Q2,1 ;INIT STRING NO.
01000 MOVE Q3,STBUCK(USER) ;WORK UP BUCKET LIST, HANDLING
01100 MOVEI FF,BKSZ(Q3) ;EVERYTHING IN THE PATH
01200 SUBI Q3,1
01300 PUSHJ P,FSTSTR ;A→FIRST LIST
01400 HLRZ Q1,(A) ;Q1 → FIRST MARKED DESCRIPTOR
01500 JRST SGFX1 ;JUMP INTO THINGS
01600
01700 SGFIX: PUSHJ P,NXTSTR ;A→NEXT LIST ELEMENT
01800 HLRZ Q1,(A) ;Q1 → NEXT DESCRIPTOR
01900 CAMG T1,1(Q1) ;INCLUDED IN OR OVERLAPPING THIS STRING
02000 JRST SGBLT ; NO, MOVE OLD BEFORE HANDLING NEW
02100 PUSHJ P,FIXPTR ;FIX UP DESCRIPTOR
02200 CAMGE T1,TEMP ;OVERLAPPING STRING
02300 MOVE T1,TEMP ; YES, USE BIGGER END POINT
02400 JRST SGFIX ;CONTINUE
02500
02600 SGBLT: ADDI Q2,1 ;INCREMENT STRING NUMBER
02700 MOVN B,T
02800 ADD B,T1 ;TOTAL STRING SIZE
02900 SKIPN SGLIGN(USER) ;HAVE TO ALIGN TO FW BDRY?
03000 JRST NOLIGN ; NO
03100 ADDI B,4 ;YES, DO IT
03200 IDIVI B,5
03300 IMULI B,5 ;NOW MULT OF 5 CHARS, BIG ENOUGH
03400 NOLIGN:
03500 ADDM B,NUMCHR(USER) ;NUMBER USED SO FAR
03600 MOVE C,T ;STARTING COUNT FOR STRING
03700 PUSHJ P,MKBPT ;PICK UP FROM HERE
03800 MOVE T,TOPBYTE(USER) ;PUT DOWN HERE
03900 JUMPE B,SGBLT1 ;DON'T DO IT IF NOT NECESSARY
04000 BLTLUP: ILDB D,C
04100 IDPB D,T ;WHEEE!
04200 SOJG B,BLTLUP ;MOVE 'EM ON OUT
04300 MOVEM T,TOPBYTE(USER) ;RESTORE IT
04400
04500 SGBLT1: JUMPE A,STSTAT ;LAST ONE
04600 SGFX1: MOVE T,1(Q1) ;INITIALIZE START OF STRING,
04700 MOVE T1,(Q1) ; END OF STRING,
04800 MOVE E,T ; OFFSET FOR BP FIXUPS
04900 SUB E,NUMCHR(USER) ; (THIS IS THE OFFSET)
05000 PUSHJ P,FIXPTR ;FIX UP THIS DESCRIPTOR
05100 JRST SGFIX ;CONTINUE
05200
05300 NXTSTR: HRRZ A,(A) ;A←CDR(A)
05400 JUMPN A,APOPJ ; GOT ONE, DONE
05500 FSTSTR: AOS A,Q3 ;END OF THAT LIST, LOOK AT NEXT
05600 CAMGE A,FF ;OOOPS, THERE ARE NO MORE!
05700 JRST NXTSTR ; YES THERE ARE
05800 SUB P,X11 ;DON'T RETURN, BUT MARK DONE,
05900 MOVEI A,0 ; AND GO OFF FOR LAST
06000 JRST SGBLT ; NOSTALGIC MOVE
06100
06200 FIXPTR: MOVE TEMP,(Q1)
06300 SUB TEMP,1(Q1) ;SIZE OF STRING FOR THIS DESCRIPTOR
06400 HRL TEMP,Q2 ;ADD STRING NUMBER
06500 EXCH TEMP,(Q1) ;PUT FIRST WORD AWAY
06600 MOVE C,1(Q1) ;START COUNT
06700 SUB C,E ;ADJUST TO NEW LOCATION
06800 PUSHJ P,MKBPT ;MAKE A BYTE POINTER
06900 MOVEM C,1(Q1) ;THIS BABY IS READY TO FLY!
07000 APOPJ: POPJ P, ;ALL DONE
07100
07200 ; MKBPT TAKES A #CHARS IN C, MAKES A BYTE POINTER RELATIVE TO ST
07300 ; OUT OF IT, LEAVES IT IN C -- DESTROYS D
07400
07500 MKBPT: IDIVI C,5 ;WORD # IN C, CHAR OFLOW IN D
07600 ADD C,ST(USER) ;REAL WORD #
07700 HLL C,[POINT 7,0
07800 POINT 7,0,6
07900 POINT 7,0,13
08000 POINT 7,0,20
08100 POINT 7,0,27](D) ;POINTER PART
08200 POPJ P,
00100
00200 ; FINISH UP
00300
00400 STSTAT:
00500 SKIPN SGLIGN(USER) ;HAVE TO LINE UP TOPBYTE?
00600 JRST NORCLR ;NO
00700 MOVE C,T1 ;END CHAR # OF LAST STRING
00800 SUB C,E ;ADJUST BY THE WINNING OFFSET
00900 PUSHJ P,MKBPT ;MAKE A BP FOR TO BE TOPBYTE
01000 MOVEM C,TOPBYTE(USER) ;FOR THE RIDICULOUS, DEMANDING SAIL
01100 PUSHJ P,RESCLR ;CLEAR REST OF STRING SPACE
01200 ;;#GI# DCS 2-5-72 REMOVE TOPSTR
01300 NORCLR: AOS SGCCNT(USER)
01400 MOVN B,STMAX(USER)
01500 IMULI B,5
01600 ADD B,NUMCHR(USER)
01700 ;;#GI# DCS 2-2-72 (2-3) LEAVE SOME SLOP SO ONE NEEDN'T FEAR INSET
01800 ADDI B,=15 ;SOME SLOP
01900 ADD B,SGACS+A(USER) ;#CHARS WHICH CAUSED THIS MESS IN FIRST PLACE
02000 MOVEM B,REMCHR(USER)
02100 ;;#GI (2-3)
02200 JUMPGE B,[ERR (<STRING SPACE EXHAUSTED, WILL RESTART>,1)
02300 JRST @JOBREN] ;RE-ALLOCATE
02400 MOVE B,STBUCK(USER) ;RELEASE IT
02500 PUSHJ P,CORREL
02600 HRLZI 12,SGACS(USER)
02700 BLT 12,12
02800 POPJ P,
02900
00100
00200 COMMENT ⊗Sgins, Sgrem ⊗
00300
00400 DSCR SGINS
00500 CAL PUSHJ
00600 PAR PUSH P,[routine name]
00700 PUSH P,[addr of 2-word block]
00800 RES block is used to place routine in the list of descriptor generators
00900 for CALSG.
01000 SID stack adjusted
01100 ⊗
01200
01300 ↑↑SGINS:
01400 PUSH P,-2(P) ;ADDR OF ROUTINE
01500 PUSHJ P,SGREM ;NEVER LET IT BE IN TWICE
01600 MOVE USER,GOGTAB
01700 POP P,UUO1(USER)
01800 POP P,LPSA ;→LINK BLOCK FOR NEW ROUTINE
01900 POP P,-1(LPSA) ;PUT ROUTINE ADDRESS AWAY
02000 HRL LPSA,SGROUT(USER);GET OLD LINK POINTER
02100 HLRM LPSA,(LPSA) ;PUT IN NEW LINK POSITION
02200 HRRM LPSA,SGROUT(USER);PUT NEW POINTER IN LINK HEAD
02300 JRST @3(P) ;RETURN
02400
02500 DSCR SGREM
02600 CAL PUSHJ
02700 PAR PUSH P,[routine addr]
02800 RES routine is removed from list of descriptor generators, if it was on it
02900 ⊗
03000
03100 ↑↑SGREM:
03200 MOVE USER,GOGTAB
03300 POP P,UUO1(USER)
03400 POP P,TEMP ;ADDR TO BE REMOVED
03500 MOVEI LPSA,SGROUT(USER);HEAD OF LIST
03600 SGRL: MOVE USER,LPSA ;PREV←THIS
03700 SKIPN LPSA,(USER) ;THIS←(PREV)
03800 JRST @2(P) ;DIDN'T FIND IT
03900 CAME TEMP,-1(LPSA) ;IS THIS THE ROUTINE?
04000 JRST SGRL ;NO, GET NEXT
04100 HRRZ TEMP,(LPSA) ;YES, REMOVE IT FROM LIST
04200 HRRM TEMP,(USER)
04300 JRST @2(P)
04400
00100
00200 DSCR STCLER
00300 CAL PUSHJ
00400 RES Clears all string variables on STRLNK(USER) to null strings
00500 DES compiler only
00600 ⊗
00700
00800 ↑STCLER:
00900 SKIPE SGLIGN(USER) ;CLEAR REST?
01000 PUSHJ P,RESCLR ;CLEAR REST OF STRING SPACE
01100 SKIPN T,STRLNK(USER) ;PARALLELS STRNGC'S LOOP
01200 POPJ P, ;CLOSELY
01300 PUSH P,B ;JUST IN CASE
01400 HRLZI B,-1 ;FOR TESTING STRING NO.
01500 STC1: HRRZ A,-1(T)
01600 HLRZ Q2,-1(T)
01700 STCLLP: SOJL Q2,STCLD1
01800 TDNE B,(A) ;DON'T COLLECT STRING CONSTANTS
01900 SETZM (A)
02000 ADDI A,2
02100 JRST STCLLP
02200 STCLD1: ;SETZM -2(T) ;***** CAN'T DO THIS UNLESS PATSW IS
02300 ; *** ON IN COMPILER!!!!!
02400 HRRZ T,(T)
02500 JUMPN T,STC1
02600 POP P,B
02700 POPJ P,
02800
02900 DSCR RESCLR
03000 CAL PUSHJ
03100 DES Used after STRNGC. Clears remaining string space to 0 (compiler only)
03200 ⊗
03300 RESCLR: SKIPL A,TOPBYTE(USER) ;CAN ZERO FIRST WORD IF 440700
03400 ADDI A,1 ;ELSE START AT NEXT
03500 SETZM (A)
03600 HRLS A
03700 ADDI A,1 ;BLT WORD
03800 MOVE B,STTOP(USER) ;END OF STRING SPACE
03900 BLT A,-1(B) ;ZERO!!
04000 POPJ P,
04100
04200 INTERNAL BRKMSK
04300 ↑BRKMSK: 0
04400 FOR @& JJ←=17,0,-1 <
04500 <1 ⊗ (JJ+=18)> + (1 ⊗ JJ)>
04600 >;NOLOW
04700 ENDCOM (SGC)
04800 IFN ALWAYS,<
04900 NOLOW <
05000 ↑CORGET←CORGET
05100 >;NOLOW
05200 >;IFN ALWAYS
05300 SUBTTL GOGOL
00100 SUBTTL Some Runtime Routines Which Could Go Nowhere Else
00200
00300 DSCR BEGIN GOGOL
00400 DES RUN-TIME ROUTINES WILL BE DESCRIBED BY SAIL MANUAL CALLING SEQUENCES ONLY
00500 ⊗
00600 NOLOW <
00700 IFN ALWAYS,<BEGIN GOGOL>
00800 >;NOLOW
00900 COMPIL(KNT,<K.ZERO,K.OUT>,<GETCHAN,GOGTAB>
01000 ,<K.ZERO, K.OUT -- PERFORMANCE COUNTING ROUTINES>)
00100 COMMENT ⊗ Kounter Routines⊗
00200 DSCR K.ZERO -- Zero out counters
00300 CAL PUSHJ P,K.ZERO
00400 RES The counter arrays of the sail program loaded are set to zero.
00500 K.ZERO determines the location of the counter blocks via the loader
00600 link chain (5) whose head is in the location KNTLNK(USER). If there
00700 are no counters, the routine is essentially a NO-OP. SID All
00800 registers used by K.ZERO are saved on entry and restored on exit. SEE
00900 K.OUT
01000 ⊗
01100
01200 HERE(K.ZERO)
01300 PUSH P,2 ;SAVE REGISTER 2
01400 MOVE USER,GOGTAB
01500 SKIPN 2,KNTLNK(USER) ;GET LINK TO COUNTERSS
01600 JRST K.ZR2 ;THERE ARE NONE
01700 PUSH P,3 ;SAVE OTHER REGS NEEDED
01800 PUSH P,4
01900 PUSH P,5
02000 K.Z1: MOVE 3,2(2) ;GET SECOND IOWD OF HEADER BLOCK
02100 MOVEI 4,2(3) ;GET <.KOUNT+1>
02200 HRLI 4,-1(4) ;GET READY FOR BLT
02300 HLRO 5,3 ;GET -COUNT
02400 MOVN 5,5 ;MAKE THAT +COUNT
02500 HRLI 5,3 ;PUT AN INDEX FIELD OF 3
02600 SETZM -1(4) ;ZERO THE FIRST COUNTER
02700 BLT 4,@5 ;ZERO THE REST
02800 SKIPE 2,(2) ;GET THE NEXT SET OF COUNTERS
02900 JRST K.Z1 ;ZERO THEM
03000 POP P,5 ;RESTORE THE REGISTERS
03100 POP P,4
03200 POP P,3
03300 K.ZR2: POP P,2
03400 POPJ P, ;RETURN
00100
00200 DSCR K.OUT -- Write out counters
00300 CAL PUSHJ P,K.OUT
00400 RES The values of the statement counters are written out to the
00500 disk. The IOWDs used to write them are also written out in
00600 order to be able to know how many to read back in. The filename
00700 is obtained from the header block of the first program loaded.
00800 The data blocks have the following form:
00900
01000 --------------------------
01100 | SIXBIT /FILNAM/ |
01200 --------------------------
01300 | LINK to other blocks |
01400 --------------------------
01500 | IOWD 1,.+1 |
01600 --------------------------
01700 | IOWD n,.KOUNT |
01800 --------------------------
01900 | 0 |
02000 --------------------------
02100 .KOUNT: | 1st counter |
02200 --------------------------
02300 | . . . |
02400
02500 | . . . |
02600 --------------------------
02700 | nth counter |
02800 --------------------------
02900
03000 SID No registers are permanently modified.
03100 ⊗
03200 HERE(K.OUT)
03300 MOVE USER,GOGTAB
03400 SKIPN KNTLNK(USER) ;ARE THERE ANY COUNTERS
03500 POPJ P, ;NO
03600
03700
03800 COMMENT ⊗ First save registers 0-16
03900 ⊗
04000
04100 MOVEM 16,17(P) ;SAVE IN THE STACK
04200 MOVEI 16,1(P) ;GET READY TO STORE 0-15
04300 BLT 16,16(P) ;DO IT
04400 ADD P,[XWD 17,17] ;ADJUST STACK POINTER
04500 TLNN P,400000 ;CHECK FOR OVERFLOW
04600 ERR <PDL overflow in K.OUT routine>
04700
04800
04900 COMMENT ⊗ Before the counters can be written out, it
05000 is necessary to chain the blocks together in the
05100 proper direction. Recall that there will be multiple
05200 blocks only if the core image is the result of loading
05300 multiple compilatons.
05400 ⊗
05500
05600 MOVE 2,KNTLNK(USER) ;GET LINK TO LAST BLOCK
05700 SKIPN 1,(2) ;GET LINK TO PREV.
05800 JRST .+5 ;THAT'S ALL
05900 MOVEI 0,1(2) ;GET ADDR OF 1st IOWD OF THIS BLOCK
06000 MOVEM 0,3(1) ;STORE BELOW 2nd IOQS OF PREV BLOCK
06100 MOVE 2,1 ;CONTINUE
06200 JRST .-5
06300
06400
06500 COMMENT ⊗ At this point, 1(2) contains the start of a dump
06600 mode command chain that will write out all of the counters.
06700 -1(2) contains the filename for the counter file.
06800 ⊗
06900
07000 PUSHJ P,GETCHAN ;GET AN AVAILABLE CHANNEL
07100 JUMPL 1,K.OERR ;NONE AVAILABLE
07200 MOVE 0,[XWD K.OD1,3] ;MOVE CODE TO REGISTERS
07300 BLT 0,16 ;SO THAT IT CAN BE SAFELY MODIFIED
07400 DPB 1,[POINT 4,3,12] ;STORE CHANNEL NUMBER IN OPEN INSTR
07500 DPB 1,[POINT 4,5,12] ;STORE CHANNEL NUMBER IN ENTER INSTR
07600 MOVE 10,-1(2) ;PICK UP FILE NAME
07700 JRST 3 ;OPEN AND ENTER,HOPEFULLY RETURNING TO .+1
07800 K.O1: MOVE 0,[XWD K.OD2,3] ;DO IT AGAIN
07900 BLT 0,7
08000 DPB 1,[POINT 4,3,12] ;OUT INSTRUCTION
08100 DPB 1,[POINT 4,6,12] ;RELEAS INSTRUCTION
08200 JRST 3
08300
08400
08500 COMMENT ⊗ The counters have been written out to the disk. It's
08600 time to restore the registers and go home.
08700 ⊗
08800
08900 K.O2: MOVSI 16,-16(P) ;PREPARE TO RESTORE REGS
09000 BLT 16,16 ; FROM THE STACK
09100 SUB P,[XWD 17,17] ;ADJUST STACK POINTER
09200 POPJ P, ;RETURN
09300
09400 K.OERR: IOERR <I/O error in writing counter file>
09500
09600
09700 COMMENT ⊗ The following instructions are moved into
09800 registers before they are executed, since the "channel"
09900 portion of them must be modified at run time.
10000 ⊗
10100
10200 K.OD1: OPEN 0,14 ;(3) OPEN DISK ON SPECIFIED CHANNEL
10300 JRST K.OERR ;(4) TROUBLE
10400 ENTER 0,10 ;(5)
10500 JRST K.OERR ;(6) RIGHT HERE IN RIVER CITY
10600 JRST K.O1 ;(7) READY TO WRITE 'EM OUT
10700 0 ;(10) FILLED IN WITH FILE NAME
10800 SIXBIT /KNT/ ;(11) EXTENSION
10900 0 ;(12)
11000 0 ;(13)
11100 17 ;(14) DUMP MODE
11200 SIXBIT /DSK/ ;(15) DEVICE DISK
11300 0 ;(16) NO BUFFERS
11400
11500 K.OD2: OUT 0,1(2) ;(3) WRITE OUT COUNTERS
11600 JRST 6 ;(4) ALL OK
11700 JRST K.OERR ;(5) PROBLEMS
11800 RELEAS 0 ;(6) CLOSE FILE
11900 JRST K.O2 ;(7) GO BACK TO K.OUT
12000
12100 ENDCOM (KNT)
12200 COMPIL(POW,<FPOW,POW,LOGS,FLOGS>,<X11,X33>,<POW, FPOW, LOGS, FLOGS -- EXPON. ROUTINES>)
00100
00200 DSCR BEGIN UTILS
00300 ⊗
00400 IFN ALWAYS,< BEGIN UTILS>
00500 COMMENT % EXPONENTIATION CODE
00600 FPOW COMPUTES
00700 REAL←FPOW(REAL!BASE,INTEGER!EXPONENT)
00800
00900 POW COMPUTES
01000 REAL←POW(INTEGER!BASE,INTEGER!EXPONENT)
01100
01200 %
01300
01400 DSCR POW, FPOW, LOGS, FLOGS(EXPONENT,ARGUMENT). BOTH RETURN REALS.
01500 SID CLOBBERS LPSA,TEMP,USER
01600 CAL SAIL
01700 DES CALLS GENERATED BY COMPILER FOR ↑ OPERATOR
01800 ⊗
01900
02000 COMMENT !
02100 USER HAS THE BASE
02200 LPSA HAS THE EXPONENT
02300 TEMP HAS THE RESULT
02400
02500 !
02600
02700 HERE(FPOW)
02800 MOVE USER,-1(P) ;BASE
02900 SKIPGE LPSA,-2(P) ;EXPONENT -- IS IT NEGATIVE
03000 MOVN LPSA,LPSA ;NEGATE IT
03100 JUMPE LPSA,EXZERO ;0 EXPONENT
03200 MOVSI TEMP,(1.0) ;SET FOR FLOATING
03300 JRST 2,.+1 ;CLEAR AR FLAGS
03400
03500 FEXLUP:
03600 TRNE LPSA,1 ;COLLECT PRODUCT?
03700 FMPR TEMP,USER ;YES
03800 JOV FPOWOV ;OVERFLOW?
03900 ASH LPSA,-1 ;PREPARE TO LOOK AT NEXT BIT
04000 JUMPE LPSA,FEXDUN ;ALL DONE IF ZERO
04100 FMPR USER,USER ;SQUARE BASE
04200 JOV FPOWOV ;OVERFLOW?
04300 JRST FEXLUP
04400
04500 FEXDUN:
04600 SKIPGE -2(P) ;POSITIVE EXPONENT?
04700 JRST FEXDU1
04800 EXDUN: MOVE A,TEMP
04900 POWRET: SUB P,X33
05000 JRST @3(P)
05100
05200 EXZERO:
05300 SKIPN USER ;0↑0
05400 ERR <0↑0 NOT DEFINED>,1
05500 MOVSI A,(1.0) ;RETURN FLOATING 1
05600 JRST POWRET
05700
05800
05900 FEXDU1:
06000 ;MUST TAKE RECIPROCAL OF TEMP
06100 MOVSI A,(1.0)
06200 FDVR A,TEMP ;TAKE RECIPROCAL
06300 JRST POWRET ;RETURN
06400
06500 FPOWOV:
06600 ;ON AN OVERFLOW, WE FLOAT THE ARGUMENTS AND ATTEMPT
06700 ;TO USE THE FLOATING ROUTINES
06800 PUSH P, B ;SAVE B
06900 MOVE A,-2(P) ;BASE (ALREADY REAL)
07000 FLOAT B,-3(P) ;EXPONENT
07100 PUSH P,C ;SAVE C AND D
07200 PUSH P,D
07300 JRST TRYFL ;TRY THE FLOATING ARITHMETIC
07400
07500
07600 HERE(POW)
07700 MOVE USER,-1(P) ;BASE
07800 SKIPGE LPSA,-2(P) ;EXPONENT -- IS IT NEGATIVE
07900 MOVN LPSA,LPSA ;NEGATE IT
08000 JUMPE LPSA,EXZERO ;ZERO EXPONENT
08100 MOVEI TEMP,1
08200 JRST 2,.+1 ;CLEAR AR FLAGS
08300 EXPLUP:
08400 TRNE LPSA,1
08500 IMUL TEMP,USER
08600 JOV POWOV ;OVER (UNDER) FLOW
08700 ASH LPSA,-1
08800 JUMPE LPSA,FLORET ;ARE WE DONE?
08900 IMUL USER,USER
09000 JOV POWOV ;OVER (UNDER) FLOW
09100 JRST EXPLUP
09200
09300
09400 FLORET:
09500 IDIVI TEMP,1B18
09600 SKIPE TEMP
09700 TLC TEMP,254000
09800 TLC USER,233000
09900 FAD TEMP,USER ;FLOATED RESULT IN TEMP
10000 SKIPGE -2(P) ;POSITIVE EXPONENT?
10100 JRST FEXDU1 ;NO
10200 JRST EXDUN ;YES -- RETURN
10300
10400 POWOV:
10500 PUSH P,B ;SAVE B
10600 FLOAT A,-2(P) ;BASE
10700 FLOAT B,-3(P) ;EXPONENT
10800 PUSH P,C ;SAVE C AND D
10900 PUSH P,D
11000 JRST TRYFL
11100
00100 ;REAL←LOGS(INTEGER_BASE,REAL_EXPONENT)
00200 HERE(LOGS)
00300 PUSH P, B ;SAVE B
00400 MOVE A,-2(P) ;BASE
00500 ;DO FLOAT INLINE
00600 IDIVI A,1B18
00700 SKIPE A
00800 TLC A,254000
00900 TLC B,233000
01000 FAD A,B
01100
01200 MOVE B,-3(P) ;EXPONENT
01300 JRST FLOGS1 ;DO IT
01400
01500 ;REAL←FLOGS(REAL_BASE,REAL_EXPONENT)
01600
01700 HERE(FLOGS)
01800 PUSH P, B
01900 MOVE A,-2(P) ;BASE
02000 MOVE B,-3(P) ;EXPONENT
02100 JUMPE B, FLZERO ;EXIT IF EXPONENT IS ZERO
02200 FLOGS1: PUSH P, C ;SAVE MORE ACS
02300 PUSH P, D
02400
02500
02600 ;;; JUMPE A, FLZERO ;EXIT IMMEDIATELY IF BASE IS ZERO
02700
02800 SKIPGE D,B ;IS EXPONENT NEG. ?
02900 MOVNS D ;YES,MAKE IT POSITIVE
03000 MOVEI C,0 ;CLEAR AC C TO ZERO
03100 LSHC C,11 ;SHIFT 9 PLACES LEFT
03200 SUBI C,200 ;TO OBTAIN SHIFTING FACTOR
03300 JUMPLE C,EXP3GO ;IS C > 0
03400
03500 PUSH P,E ;SAVE E
03600 HRR E,C ;SET UP E AS AN INDEX REG.
03700 MOVEI C,0 ;CLEAR OUT AC C
03800 LSHC C,(E) ;SHIFT LFT BY CONTENTS OF E
03900 POP P,E ;RESTORE E
04000
04100 JUMPN D,EXP3GO ;IS EXPONENT AN INTEGER ?
04200 SKIPGE B ;YES, WAS IT NEG. ?
04300 MOVNS C ;YES, NEGATE IT
04400 PUSH P, B ;SAVE IT IN CASE WE NEED IT LATER
04500 MOVE B,C ;MOVE INTEGER INTO B
04600 PUSHJ P,EXP2.0 ;OBTAIN RESULT USING EXP2.0
04700 SUB P, X11 ;REMOVE B FROM STACK
04800 JRST EXP3A ;
04900 EXP3GO:
05000 ;ARGUMENT IS IN A
05100 TRYFL: PUSHJ P,ALOG ;CALCULATE LOG OF A
05200 FMPR A, B ;CALCULATE B*LOG(A)
05300 ;ARGUMENT IS IN A
05400 PUSHJ P,EXP ;CALCULATE EXP(B*LOG(A))
05500
05600 ;RESULT IS IN A
05700 EXP3A: POP P, D
05800 POP P, C
05900 POP P, B
06000 SUB P, X33
06100 JRST @3(P)
06200
06300 FLZERO:
06400 SKIPN A ;0↑0?
06500 ERR <0↑0 NOT DEFINED>,1
06600 POP P,B ;RESTORE B
06700 MOVSI A,(1.0) ;
06800 JRST POWRET ;RETURN
06900
07000
07100 COMMENT !
07200 EXP2.0 TAKES AS ARGUMENTS:
07300 A REAL
07400 B INTEGER
07500
07600 A↑B IS RETURNED IN A AS A REAL
07700 !
07800 OPDEF JRSTF [JRST 2,] ;IS THIS REALLY UNDEFINED IN FAIL?
07900
08000 EXP2.0: JUMPE A, BASEZ ;TREAT CASE OF A ZERO BASE
08100 PUSH P, C ;SAVE AC C
08200 MOVSI C, 201400 ;GET 1.0 IN ACCUMULATOR C
08300
08400 JRSTF @[XWD 0,.+1] ;CLEAR AR FLAGS
08500 JUMPGE B, GFEXP2 ;IS EXPONENT POSITIVE?
08600 MOVMS B ;NO, MAKE IT POSITIVE
08700 PUSHJ P, FEXP2 ;CALL MAIN PART OF PROGRAM
08800 MOVSI B, 201400 ;GET 1.0 IN B
08900 FDVM B, A ;FORM 1/(A**B) FOR NEG. EXPONENT
09000 RETEX2:
09100 POP P, C ;RESTORE C
09200 POPJ P, ;EXIT
09300
09400 GFEXP2: PUSHJ P,FEXP2 ;CALL FEXP2
09500 JRST RETEX2 ;RETURN
09600
09700 FEXP1: FMP A, A ;FORM A**N, FLOATING POINT
09800 LSH B, -1 ;SHIFT EXPONENT FOR NEXT BIT
09900 FEXP2: TRZE B, 1 ;IS THE BIT ON?
10000 FMP C, A ;YES, MULTIPLY ANSWER BY A**N
10100 JOV OVERF ;TRANSFER ON OVER (UNDER) FLOW
10200 JUMPN B, FEXP1 ;UPDATE A**N UNLESS ALL THROUGH
10300 FEXP3: MOVE A, C ;PICK UP RESULT FROM C
10400 FEXP4: POPJ P, ;EXIT
10500
10600 BASEZ: SKIPN B ;IS THE EXPONENT ALSO ZERO?
10700 ERR <0↑0 NOT DEFINED>
10800 MOVSI A,(1.0) ;1.0
10900 POPJ P,
11000
11100 COMMENT ! ROUTINE FOR OVERFLOW.
11200 This overflow trap occurs when we have tried to
11300 use EXP2.0. Instead, we will try to compute using logarithms.
11400
11500
11600 !
11700
11800 OVERF:
11900 SUB P, X11 ;REMOVE RETURN ADDRESS
12000 POP P, C ;RESTORE C
12100 SUB P, X11 ;REMOVE RETURN FROM EXP2.0
12200 POP P, B ;GET BACK REAL EXPONENT
12300 JRST TRYFL ;GO TRY FLOATING
12400
12500
12600
12700
12800 ;FLOATING POINT SINGLE PRECISION EXPONENTIAL FUNCTION
12900 ;THE ARGUMENT IS RESTRICTED TO THE FOLLOWING RANGE
13000 ; -88.028<X<88.028
13100 ;IF X<-88.028, THE PROGRAM RETURNS ZERO AS THE ANSWER
13200 ;IF X<88.028, THE PROGRAM RETURNS X AS THE ANSWER
13300 ;THE RANGE OF THE ARGUMENT IS REDUCED AS FOLLOWS:
13400 ;EXP(X) = 2**(X*LOG(E)BASE2) = 2**(M+F)
13500 ;WHERE M IS AN INTEGER AND F IS A FRACTION
13600 ;2**M IS CALCULATED BY ALGEBRAICALLY ADDING M TO THE EXPONENT
13700 ;OF THE RESULT OF 2**F. 2**F IS CALCULATED AS
13800
13900 ;2**F = 2(0.5+F(A+B*F↑2 - F-C(F↑2 + D)**-1)**-1
14000
14100 ;THE ROUTINE HAS THE FOLLOWING CALLING SEQUENCE:
14200 ; ARG IS IN ACCUMULATOR A
14300 ; PUSHJ P,EXP
14400 ;THE ANSWER IS RETURNED IN ACCUMULATOR A
14500
14600 EXP:
14700 PUSH P, B ;SAVE B
14800 MOVE B, A ;PICK UP THE ARGUMENT IN B
14900 MOVM A, B ;GET ABSF(X)
15000 CAMG A, E7 ;IS ARGUMENT IN PROPER RANGE?
15100 JRST EXP1 ;YES, GO TO ALGORITHM
15200 ;NON-FATAL MESSAGE
15300 ERR <EXPONENTIATION UNDER OR OVERFLOW>,1
15400 HRLOI A, 377777 ;GET LARGEST FLOATING NUMBER
15500 SKIPG B ;WAS THE ARGUMENT POSITIVE?
15600 MOVEI A, 0 ;NO, RETURN 0
15700 POP P, B ;RESTORE B
15800 POPJ P, ;RETURN
00100
00200 EXP1: PUSH P, C ;SAVE ACCUMULATOR C
00300 PUSH P, D ;SAVE ACCUMULATOR D
00400 PUSH P, E ;SAVE E
00500 PUSH P, LPSA ;SAVE LPSA
00600 SETZB E, LPSA ;INITIALIZE E, TBITS
00700 MULI B, 400 ;SEPARATE FRACTION AND EXPONENT
00800 TSC B, B ;GET A POSITIVE EXPONENT
00900 MUL C, E5 ;FIXED POINT MULTIPLY BY LOG2(E)
01000 ASHC C, -242(B) ;SEPARATE FRACTION AND INTEGER
01100 AOSG C ;ALGORITHM CALLS FOR MULT. BY 2
01200 AOS C ;ADJUST IF FRACTION WAS NEGATIVE
01300 HRRM C, LPSA ;SAVE FOR FUTURE SCALING
01400 ASH D, -10 ;MAKE ROOM FOR EXPONENT
01500 TLC D, 200000 ;PUT 200 IN EXPONENT BITS
01600 FADB D, E ;NORMALIZE, RESULTS TO D AND E
01700 FMP D, D ;FORM X↑2
01800 MOVE A, E2 ;GET FIRST CONSTANT
01900 FMP A, D ;E2*X↑2 IN A
02000 FAD D, E4 ;ADD E4 TO RESULTS IN D
02100 MOVE B, E3 ;PICK UP E3
02200 FDV B, D ;CALCULATE E3/(F↑2 + E4)
02300 FSB A, B ;E2*F↑2-E3(F↑2 + E4)**-1
02400 MOVE C, E ;GET F AGAIN
02500 FSB A, C ;SUBTRACT FROM PARTIAL SUM
02600 FAD A, E1 ;ADD IN E1
02700 FDVM C, A ;DIVIDE BY F
02800 FAD A, E6 ;ADD 0.5
02900 EX1: FSC A, (LPSA) ;SCALE THE RESULTS
03000 POP P, LPSA ;RESTORE ACS
03100 POP P, E
03200 POP P, D
03300 POP P, C
03400 POP P, B ;SAVED EARLIER
03500 POPJ P,
03600
03700
03800 E1: 204476430062 ;9.95459578
03900 E2: 174433723400 ;0.03465735903
04000 E3: 212464770715 ;617.97226953
04100 E4: 207535527022 ;87.417497202
04200 E5: 270524354513 ;LOG(E), BASE 2
04300 E6: 0.5
04400 E7: 207540071260 ;88.028
04500
04600
04700 ;ALOG
04800 ;FLOATING POINT SINGLE PRECISION LOGARITHM FUNCTION
04900 ;LOG(ABSF(X)) IS CALCULATED BY THE SUBROUTINE, AND AN
05000 ;ARGUMENT OF ZERO IS RETURNED AS MINUS INFINITY. THE ALGORITHM IS
05100
05200 ;LOGE(X) = (I + LOG2(F))*LOGE(2)
05300 ;WHERE X = (F/2)*2↑(I+1), AND LOG2(F) IS GIVEN BY
05400 ;LOG2(F) = C1*Z + C3*Z↑3 + C5*Z↑5 - 1/2
05500 ;AND Z = (F-SQRT(2))/(F+SQRT(2))
05600
05700 ;THE CALLING SEQUENCE FOR THE ROUTINE IS AS FOLLOWS:
05800 ;THE ARGUMENT IS IN ACCUMULATOR A
05900 ; PUSHJ P, ALOG
06000 ;THE ANSWER IS RETURNED IN ACCUMULATOR A
06100
06200
06300 ALOG:
06400 MOVM A, A ;GET ABSF(A)
06500 JUMPE A, LZERO ;CHECK FOR ZERO ARGUMENT
06600 CAMN A, ONE ;CHECK FOR 1.0 ARGUMENT
06700 JRST ZERANS ;IT IS 1.0 RETURN ZERO ANS.
06800 PUSH P, B ;SAVE AC B
06900 PUSH P, C ;SAVE AC C
07000 PUSH P, D ;SAVE AC D
07100 ASHC A, -33 ;SEPARATE FRACTION FROM EXPONENT
07200 ADDI A, 211000 ;FLOAT THE EXPONENT AND MULT. BY 2
07300 MOVSM A, C ;NUMBER NOW IN CORRECT FL. FORMAT
07400 MOVSI A, 567377 ;SET UP -401.0 IN A
07500 FADM A, C ;SUBTRACT 401 FROM EXP.*2
07600 ASH B, -10 ;SHIFT FRACTION FOR FLOATING
07700 TLC B, 200000 ;FLOAT THE FRACTION PART
07800 FAD B, L1 ;B = B-SQRT(2.0)/2.0
07900 MOVE A, B ;PUT RESULTS IN A
08000 FAD A, L2 ;A = A+SQRT(2.0)
08100 FDV B, A ;B = B/A
08200 MOVEM B, D ;STORE NEW VARIABLE IN D
08300 FMP B, B ;CALCULATE Z↑2
08400 MOVE A, L3 ;PICK UP FIRST CONSTANT
08500 FMP A, B ;MULTIPLY BY Z↑2
08600 FAD A, L4 ;ADD IN NEXT CONSTANT
08700 FMP A, B ;MULTIPLY BY Z↑2
08800 FAD A, L5 ;ADD IN NEXT CONSTANT
08900 FMP A, D ;MULTIPLY BY Z
09000 FAD A, C ;ADD IN EXPONENT TO FORM LOG2(X)
09100 FMP A, L7 ;MULTIPLY TO FORM LOGE(X)
09200 POP P, D ;RESTORE
09300 POP P, C
09400 POP P, B
09500 POPJ P, ;EXIT
09600
09700 LZERO: MOVE A, MIFI ;PICK UP MINUS INFINITY
09800 L: POPJ P, ;EXIT
09900
10000 ZERANS: MOVEI A, 0 ;MAKE ARG. ZERO
10100 POPJ P, ;EXIT
10200
10300 ;CONSTANTS
10400
10500 ONE: 201400000000
10600 L1: 577225754146 ;-0.707106781187
10700 L2: 201552023632 ;1.414213562374
10800 L3: 200462532521 ;0.5989786496
10900 L4: 200754213604 ;0.9614706323
11000 L5: 202561251002 ;2.8853912903
11100 L7: 200542710300 ;0.69314718056
11200 MIFI: 400000000001 ;LARGEST NEGATIVE FLOATING NUMBER
11300
11400 ENDCOM (POW)
11500
11600
11700 COMPIL(COD,<CODE,CALL>,<.SKIP.,CVSIX,X22,GOGTAB,X33>,<CODE, CALL>)
00100
00200 DSCR VAL←CODE(OCTAL COMMAND, REFERENCE ARG);
00300 ⊗
00400 Comment ⊗CODE
00500 Reference arg is added to octal command. CODAC(USER)
00600 is placed in AC 1. The constructed word is executed, and AC 1 resaved.
00700 Isn't that clever? (AC1 is also returned as the value of the call)
00800 ⊗
00900
01000 HERE (CODE) MOVE USER,GOGTAB
01100 SETOM .SKIP. ;ASSUME IT SKIPS
01200 PUSH P,0
01300 MOVE 1,CODAC(USER) ;GET USER'S AC
01400 MOVE 0,-3(P)
01500 ADDI 0,@-2(P) ;CALCULATE THE INSTR DO BE EXECUTED
01600 XCT 0 ;DO IT
01700 SETZM .SKIP. ;DIDN'T SKIP
01800 MOVEM 1,CODAC(USER)
01900 POP P,0
02000 SUB P,X33
02100 JRST @3(P)
02200
02300
02400
02500 NOTENX <
02600 DSCR VALUE←CALL(VAL,"FUNCTION");
02700 CAL SAIL
02800 ⊗
02900
03000 ↑↑.CALL:
03100 HERE (CALL)
03200 SETOM .SKIP. ;ASSUME A SKIP
03300 PUSHJ P,CVSIX ;PARSE SIXBIT
03400 MOVE TEMP,A ;SIXBIT FOR WHAT'S WANTED
03500 MOVE A,-1(P) ;INPUT VALUE
03600 CALL A,TEMP
03700 SETZM .SKIP. ;NO SKIP, RECORD IT
03800 SUB P,X22 ;RETURN VALUE IN 1, WANT IT OR NOT
03900 JRST @2(P)
04000
04100 ENDCOM (COD)
04200
04300 IFN ALWAYS,<BEND UTILS>
04400 SUBTTL STRING HANDLING ROUTINES
04500 >;NOTENX
00100
00200
00300
00400
00100