Trailing-Edge
-
PDP-10 Archives
-
-
There are no other files named in the archive.
COMMENT VALID 00065 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00006 00002 HISTORY
C00019 00003 Command File Descriptions
C00021 00004 Conditional Assembly Switches, Macros
C00025 00005 Titles, Versions
C00026 00006 AC Definitions
C00027 00007 CDB, SIMIO Indices For IOSER, OTHER INDICES
C00032 00008 Base (Low Segment) Data Descriptions -- Macros, Compil spec
C00034 00009 Base (Low Segment) Data Descriptions - Params, Links, Size specs
C00049 00010 Initialization Routines, Data
C00051 00011 Sailor, Reent -- Allocation, Main Program Control
C00055 00012 .SEG2. -- Get a second segment
C00058 00013
C00061 00014
C00066 00015
C00067 00016 Segment-Fetching Data
C00073 00017
C00074 00018 %ALLOC -- Main Allocation Routine
C00080 00019
C00088 00020
C00093 00021
C00100 00022 Utility Subroutines for allocation
C00102 00023 %UUOLNK -- UUO Handler (Dispatch Vector Just Below)
C00106 00024 SUBTTL SPLICE -- A FANCY STRING MAKER
C00110 00025 SPL.D: JUMPGE A,SPL.D1 FRNP only works for positive values
C00112 00026 SPL.G: JUMPE A,SPL.1 0 PPN is null string
C00116 00027 RUUO -- RECORD HANDLER UUO ROUTINE
C00119 00028 DSCR FIX, FLOAT UUO'S (FIXQ,FLOAQ,SNGLQ)
C00123 00029 DSCR PRINIT -- INTERFACE TO SYSTEM PRINTING FACILITIES
C00128 00030 DSCR ERROR UUOS
C00136 00031 DSCR WATNOW -- ROUTINE TO GET AND PROCESS USER RESPONSES.
C00145 00032 Special Printing Routines For Error Handler
C00149 00033 DSCR USERERR(VALUE,CODE,"MSG","RESPONSE")
C00154 00034 Code to Handle Linkage to Editors
C00161 00035 EXPORT VERSION OF EDITOR-INTERFACE
C00169 00036 SAVE, RESTR, INSET -- General Utility Routines
C00173 00037 Core Service Routines -- General Description
C00178 00038 Special AC Declarations
C00179 00039 Utility Routines
C00186 00040
C00192 00041 CORGET
C00198 00042
C00202 00043 CORINC, CANINC
C00208 00044 CORREL
C00215 00045 CORPRT, CORBIG
C00226 00046 DSCR STRGC (REQUEST)
C00232 00047 STRGC, Definitions
C00236 00048 STRNGC -- Init, CALSGL, SGSWEP -- main loop through space sorting
C00241 00049 STRNGC -- SWPLUP -- main sweep (string moving) loop
C00243 00050 STRNGC -- SWPDUN -- expansion/contraction, parameter update
C00248 00051 STRNGC -- STSTAT -- Finish Up, collect statistics
C00251 00052 STRNGC Service routines -- SGSORT
C00255 00053 STRNGC Service routines -- SPGC,STRMRK, etc. -- Descriptor providing routines
C00260 00054 STRNGC Service routines -- SRTSPC -- space sorter
C00264 00055 STRNGC Service routines -- SOURCE and DEST
C00268 00056
C00275 00057 STRNGC Service routines -- SGINS and SGREM
C00277 00058 STRNGC Service routines -- STCLER and RESCLR
C00279 00059 Some Runtime Routines Which Could Go Nowhere Else
C00280 00060 Kounter Routines
C00282 00061
C00291 00062 DSCR POW, FPOW, LOGS, FLOGS. BOTH RETURN REALS.
C00296 00063 DSCR EXP,ALOG -- FOR USE BY EXPONENTIATION ROUTINES & WORLD
C00304 00064 Usercon
C00307 00065 DSCR VAL_CODE(OCTAL COMMAND, REFERENCE ARG)
C00310 ENDMK
C;
COMMENT HISTORY
AUTHOR,FAIL,REASON
031 102300000016 ;
DEFINE .VERSION <102300000021>
COMMENT
VERSION 18-1(14) 3-4-75 BY RHT SOME MINOR CHANGES FOR NEW-STYLE RECORDS
VERSION 18-1(13) 2-15-75 BY RLS BUG #UA# CHECK FOR 010700,,BUF-1 KIND OF BP IN STRING GC
VERSION 18-1(12) 2-1-75 BY RLS ADD TENEX PSI SYSTEM
VERSION 18-1(11) 11-24-74 BY JFR X33 AN EXTERNAL TO SAILUP P.16
VERSION 18-1(10) 11-24-74 BY JFR BAIL/USERERR PATCH, P.30
VERSION 18-1(9) 11-24-74 BY JFR BAIL ERROR HANDLER
VERSION 18-1(8) 11-19-74 BY JFR MORE BAIL ERROR HANDLING
VERSION 18-1(7) 11-17-74 BY JFR MORE OF SAME
VERSION 18-1(6) 11-17-74 BY JFR BYE
VERSION 18-1(5) 11-17-74 BY JFR P.28 COMMUNICATION BETWEEN ERROR HANDLER AND BAIL
VERSION 18-1(4) 10-18-74 BY RLS FEAT BV CALLI -22 FOR CMU
VERSION 18-1(3) 10-18-74 BY RLS ADD .LEPIN FOR LDE
VERSION 18-1(2) 10-18-74 BY RHT VERSION 18
VERSION 17-1(74) 10-10-74 BY RLS RANDOR TENX MODS
VERSION 17-1(73) 10-10-74 BY RHT FEAT %BR% REMOVE HACKS, HEREFK TO HERE
VERSION 17-1(72) 9-20-74 BY JFR INSTALL BAIL
VERSION 17-1(71) 8-31-74 BY RHT BUG #tc# sgsort did not like funny null strings
VERSION 17-1(70) 7-31-74 BY JRL BUG #SX# HEREFK INSET
VERSION 17-1(69) 7-7-74 BY RHT ADD EDITS FOR RGC & UUO HACK
VERSION 17-1(68) 7-7-74
VERSION 17-1(67) 7-7-74
VERSION 17-1(66) 6-16-74 BY JRL %AO% SETPR2 LOSSAGE(STANFORD ONLY)
VERSION 17-1(65) 5-30-74 BY RLS BUG #SM# TEST FOR OVERFLOW OF DISPATCH TABLE
VERSION 17-1(64) 5-25-74 BY RLS EDIT
VERSION 17-1(63) 5-25-74 BY RLS EDIT
VERSION 17-1(62) 5-25-74 BY RLS PARAMETERIZE JRST TABLE LENGTH
VERSION 17-1(61) 5-25-74 BY RLS P.FIN FOR TENEX
VERSION 17-1(60) 5-25-74 BY RLS EDIT
VERSION 17-1(59) 5-24-74 BY RHT MOVE USERCON OVER FROM IOSER
VERSION 17-1(58) 5-24-74
VERSION 17-1(57) 5-20-74 BY RHT ZERO ALLOCATED QUANTS. ALSO, ADD PD LINKEND
VERSION 17-1(56) 5-19-74 BY rht %bj% -- had to add a call to p.fin
VERSION 17-1(55) 4-8-74 BY RHT FEAT %BI% ADDED RECORD UUOS
VERSION 17-1(54) 4-8-74
VERSION 17-1(53) 4-6-74 BY RLS TENEX FIX TO UDDT INTERFACE CODE
VERSION 17-1(52) 3-19-74 BY RHT GO OVER FILE WITH RLS
VERSION 17-1(51) 3-19-74
VERSION 17-1(50) 3-19-74
VERSION 17-1(49) 3-19-74
VERSION 17-1(47) 3-5-74 BY RHT BUG #RL# STRINGC WAS ACCESSING .NEXT OF A SPACE AFTER CORREL
VERSION 17-1(46) 2-20-74 BY RHT BUG #RI# NEEDED AN INSET IN .SONTP
VERSION 17-1(45) 2-16-74 BY RHT FEAT %BF% WAY TO EXPAND ERROR BUFFER
VERSION 17-1(44) 1-26-74 BY RHT BUG #QQ# INSTRUCTION LEFT OUT OF .SONTP
VERSION 17-1(43) 1-26-74 BY RHT BUG #QP# .SONTP STRING DESCR CANON USED WRONG
VERSION 17-1(42) 1-12-74 BY RHT FIX COMPIL FOR SGC
VERSION 17-1(41) 1-11-74
VERSION 17-1(40) 1-11-74 BY RHT ADD .SONTP ROUTINE
VERSION 17-1(39) 1-11-74
VERSION 17-1(38) 1-11-74
VERSION 17-1(37) 1-11-74 BY RHT MERGE IN CMU CHANGES
VERSION 17-1(36) 1-11-74
VERSION 17-1(35) 1-11-74
VERSION 17-1(34) 1-11-74
VERSION 17-1(33) 1-11-74
VERSION 17-1(32) 12-14-73 BY RHT BUG #QA# PARAM COUNT TO GC TRAP WRONG
VERSION 17-1(31) 12-14-73
VERSION 17-1(30) 12-12-73 BY RHT MOVE LPLK OUT OF MIDDLE OF XX AREA
VERSION 17-1(29) 12-11-73 BY rht make rfs happy
VERSION 17-1(28) 12-10-73 BY RFS BUG PU, PAGE 26
VERSION 17-1(27) 12-10-73
VERSION 17-1(26) 12-10-73
VERSION 17-1(25) 12-8-73 BY JRL REMOVE SPECIAL STANFORD CHARACTERS(WHERE POSSIBLE)
VERSION 17-1(24) 12-3-73
VERSION 17-1(23) 12-3-73
VERSION 17-1(22) 12-3-73
VERSION 17-1(21) 12-3-73
VERSION 17-1(20) 12-3-73 BY RFS ELIMINATE ALL III DISPLAY STUFF
VERSION 17-1(19) 12-2-73 BY KVL MAKE ERR DISPATCH TO ETV INSTEAD OF TV
VERSION 17-1(18) 12-2-73 BY RHT ALLOW MORE ROOM FOR HERES
VERSION 17-1(17) 12-1-73 BY RLS ADD CDB INDICES FOR SETPL FUNCTION
VERSION 17-1(16) 11-30-73 BY RHT FLUSH ERRSPC DECL IN SAILOR
VERSION 17-1(15) 11-30-73 BY RHT ADD A FEW MORE XX SPARES
VERSION 17-1(14) 11-28-73 BY RHT FIX USERERR RIGHT
VERSION 17-1(13) 11-26-73 BY RHT TRIVIAL IMPROVEMENT TO AC PUSH LOOP IN ERR HANDLER
VERSION 17-1(12) 11-25-73 BY RHT FEAT %AO% DO SETPR2 IF REMAP LOSES.
VERSION 17-1(11) 11-25-73 BY KVL ADD "A" AND "C" OPTIONS TO WATNOW LOOP OF ERR
VERSION 17-1(10) 11-24-73 BY RHT FEAT %AL% SET UP RF FOR OUTER BLOCK
VERSION 17-1(9) 11-24-73 BY RHT MOVE PHASE COUNTS TO HEAD
VERSION 17-1(8) 11-24-73
VERSION 17-1(7) 11-21-73 BY RHT MINOR FIXUP TO (NEW) USERERR
VERSION 17-1(6) 11-20-73 BY RFS CHANGE CHNL TO REG 10 TO FREE RF.
VERSION 17-1(4) 11-20-73 BY RFS ADD NEW EXPONENTIATION CODE; REENTRANT ERROR HANDLER
10/29/73 %AH% -- REE W/O STARTING
10/23/73 %AG% -- LEAPIS SWITCH IN $GITNO, NOT $ITNO
10/6/73 %AD% -- ALLOW LOWER CASE ANSWER TO "ALLOC"
9/18/73 MAKE END OF SAIL EXECUTION MESSAGE DO A CRLF FIRST
VERSION 17-1(3) 7-27-73 BY KVL PUTS IN SOME XX'S FOR HOLDING .LOG FILE INFO
VERSION 17-1(2) 7-27-73 BY KVL DECLARE ERSCPD IN LOWER
VERSION 17-1(1) 7-26-73 BY RHT ****** VERSION 17 STRIKES HERE *******
VERSION 16-2(65) 7-13-73 BY JRL HERE CORGET AND FRIENDS
VERSION 16-2(64) 7-13-73
VERSION 16-2(63) 7-13-73
VERSION 16-2(62) 6-28-73 BY JRL BUG #MW# PPMAX NOT EXTERALED IN SAILUP(EXPORT ONLY)
VERSION 16-2(61) 5-3-73 BY RHT ADD EXTRA THREE XX CELLS FOR INTRPT SYS
VERSION 16-2(60) 2-27-73 BY JRL REMOVE ..RVAL FROM XX AREA
VERSION 16-2(59) 2-12-73 BY JRL ADD ..RVAL TO XX AREA
VERSION 16-2(58) 1-8-73 BY JRL BUG #KV# CHECK FOR NULL INILNK IN .UNIT
VERSION 16-2(57) 12-2-72 BY RHT ENLARGE HERE TABLE
VERSION 16-2(56) 12-1-72 BY RHT ADD DEFSSS,DEFPSS,DEFQNT,DEFPRI TO XX AREA
VERSION 16-2(55) 11-30-72 BY RHT ADD XX ENTRY FOR NOPOLL
VERSION 16-2(54) 11-22-72 BY JRL BUG #KL# STACSV SAVED TOO MANY AC'S IN TOO FEW LOCATIONS
VERSION 16-2(53) 11-22-72
VERSION 16-2(52) 11-22-72
VERSION 16-2(51) 11-17-72 BY RHT MAKE USER INITIALIZATION A SEPARATE PROCEDURE
VERSION 16-2(50) 11-10-72 BY JRL ADD PROPS TO XX AREA
VERSION 16-2(49) 10-12-72 BY RHT ADD PPMAX FOR EXPO VERSION (NEEDED BY ED LNKG)
VERSION 16-2(48) 10-5-72 BY JRL MAKE GLUSER INTERNAL
VERSION 16-2(47) 10-3-72 BY RHT MAKE USER INIT WORK RIGHT
VERSION 16-2(46) 9-24-72 BY JRL FIX LIB ENTRIES FOR PROC. STR GAR COL
VERSION 16-2(45) 9-21-72 BY RHT SCREW UP THE COMPIL MACRO
VERSION 16-2(44) 9-21-72 BY JRL ADD SPRPDA TO SGC COMPIL MACRO
VERSION 16-2(43) 9-11-72 BY JRL ADD GINFTB,GDATM TO LOWER WHEN NO GLOB
VERSION 16-2(42) 9-5-72 BY JRL BAD FIX TO SGLKBK PROBLEM
VERSION 16-2(41) 8-21-72 BY RHT PUT IN JRL'S STACSV &STACRS
VERSION 16-2(40) 8-7-72 BY RHT CHANGE INILNK STUFF
VERSION 16-2(39) 8-7-72 BY KVL PRINT MSG BEFORE CANT CONTINUE ANY FURTHER MSG (P24)
VERSION 16-2(38) 7-3-72 BY DCS BUG #IC# ADD NEW MEANING TO NOSHRK(USER)
VERSION 16-2(37) 7-3-72 BY DCS BUG #IB# MAKE DEFAULT SYSTEM STACK SIZE BIGGER
VERSION 16-2(36) 7-2-72 BY JRL HAVE %ALLOC CALL LPINI IF NEEDED
VERSION 16-2(35) 6-20-72 BY DCS BUG #HU# BETTER TTY PRINTOUT
VERSION 16-2(34) 5-16-72 BY DCS BUG #HI# %ARRSRT TESTS RIGHT BIT FOR STR ARRAY NOW
VERSION 16-2(33) 5-11-72 BY DCS BUG #HE# MODIFY VERSION CHECKING, INSTALL VERSION 16
VERSION 15-6(23-32) 5-3-72 VARIOUS FIXES
VERSION 15-6(14-22) 2-21-72 VARIOUS FIXES
VERSION 15-6(13) 2-19-72 BY RHT THE BRAVE NEW WORLD
VERSION 15-2(12) 2-5-72 BY DCS BUG #GI# REMOVE TOPSTR
VERSION 15-2(11) 2-2-72 BY DCS BUG #GI# LEAVE SOME SLOP IN REMCHR SO CAT'LL BE MORE EFFICIENT
VERSION 15-2(10) 2-1-72 BY DCS REPLACE (FIXED) %ALLOC BLOCK ACCESSES BY SYMBOLIC HEAD-DEFINED ONES
VERSION 15-2(9) 1-30-72 BY DCS REPLACE %ALLOC -- INITIAL ALLOCATION
VERSION 15-2(8) 1-14-72 BY DCS BUG #GA# SEGMENTS HAVE .SEG EXTENSIONS, NOT .REL
VERSION 15-2(7) 1-3-72 BY DCS BUG #FX# REMOVE NEED FOR COM2, REORGANIZE SEGMENT-GETTING STUFF
VERSION 15-2(6) 12-26-71 BY DCS BUG #FU# REENABLE ACCESS FROM ERR UUO TO FTDEBUGGER
VERSION 15-2(5) 12-24-71 BY DCS BUG #FT# DSPLIN BETTER, TV AS VALID EDITOR
VERSION 15-2(4) 12-22-71 BY DCS BUG #FF# SIXPRT(14-15) TO ERR, IOERR ROUTS
VERSION 15-2(3) 12-22-71 BY DCS BUG #FS# REMOVE SAILRUN, COM2, ASSUME COMPILER
VERSION 15-2(2) 12-2-71 BY DCS ADD VERSION SETUP CODE
VERSION 15-2(1) 12-2-71 BY DCS INSTALL VERSION NUMBER
;
SUBTTL Command File Descriptions
LSTON (GOGOL)
COMMENT
The following command files make runtime routines:
1. RUN
One assembly, get a non-library, non-2d-segment runtime package
RUNTIM=HEAD+ORDER+GOGOL+TRIGS+STRSER+IOSER+NWORLD+LEPRUN+MESPRO+WRDGET
2. SGMNT
Makes the non-global UPPER.REL and SAILOW.REL, which when
loaded and run and stuff become SAISGn.SEG and SAILOW.REL,
the 2d segment runtime routines
TAILOR=HEAD+FILSPC+TAILOR/NOLO
LOWER=HEAD+LOW+FILSPC+GOGOL/NOLO
TAILOR.REL,UPPER=HEAD+UP.FAI+ORDER+GOGOL+STRSER+IOSER+
NWORLD+LEPRUN+MESPRO+WRDGET
5. GSGMNT
Makes the global model SAILOW AND UPPER, otherwise like
SGMNT
Same, but add GLB after HEAD in all three.
6. SCISS.SAI
This SAIL program, when run, uses the runtime files to
make a LIBSAI.REL file, the SAIL (lower-segment) library
SUBTTL Conditional Assembly Switches, Macros
DSCR ** CONDITIONAL ASSEMBLY SWITCHES **
STSW(UPPER,0) ;NOT UPPER OR LOWER IF NEITHER SET
STSW(LOWER,0)
STSW(GLOBSW,0) ;ONLY GLOBAL IF SOMEBODY ELSE SAID SO
STSW(SEGS,0)
STSW(RENSW,0) ;RE-ENTRANT LIBRARY (HISEG) IF ON
STSW(LEAPSW,1) ;ASSUME LEAP
EXPO <
STSW(APRISW,1) ;THE APR INTERRUPT PACKAGE IS TO BE USED
>;EXPO
NOEXPO <
STSW(APRISW,0) ;USUALLY USE THE MOORER PACKAGE
>;NOEXPO
DSCR COMPIL(NAM,ENTRIES,EXTERNALS,DESCRIPTION,INTERNALS,HINHB)
CAL MACRO
PAR NAM IS 3 CHAR NAME -- TITLE WILL BE SAINAM
ENTRIES ARE LIST OF ENTRIES CONTAINED IN THIS
LIBRARY ASSEMBLY (INTERNALS IF NOT LIBRARY SETUP)
EXTERNALS (OPTIONAL) ARE EXTERNALS NEEDED FOR THIS ENTRY.
DESCRIPTION IS OPTIONAL, AND IS USED IN THE SUBTTL
IF PRESENT.
INTERNALS (OPTIONAL) DESCRIBE INTERNALS WHICH ARE NEVER ENTRIES.
HINHB (OPTIONAL ANYTHING), IF NON-BLANK, INHIBITS THE HISEG)
DES IF MAKING A LIBRARY, AND IF THIS FILE IS DESIRED
(SEE SCISS PROGRAM), A FILE OF THE NAME SAINAM.FAI
WILL BE MADE CONTAINING ALL THE PROGRAM TEXT FROM THE
COMPIL MACRO TO THE ENDCOM MACRO WHICH SHOULD FOLLOW
THE CODE FOR THIS ENTRY. ENDCOM DOES AN END IF
IN LIBRARY COMPILE MODE.
RES THE MACRO EXPANDS TO PROVIDE A TITLE AND THE
APPROPRIATE ENTRIES AND EXTERNALS FOR THIS ASSEMBLY.
ALSO A SUBTTL CONTAINING THE TITLE AND OPTIONAL
DESCRIPTION IS PROVIDED.
DEFINE COMPIL ' (NAM,ENT,EXT,DSCRP,INT,HINHB,DUMMY) <
IFIDN <DUMMY>,<> <
SUBTTL SAI'NAM -- DSCRP
IFE ALWAYS,<
IFDIF <><ENT>,<ENTRY ENT>
TITLE SAI'NAM
REN <
IFIDN <><HINHB>,<HISEG ;LOAD TO UPPER IF POSSIBLE>
>;REN
IFDIF <><EXT>,<EXTERN EXT>
>;IFE ALWAYS
NOLOW <
IFDIF <><INT>,<INTERN INT>
IFN ALWAYS,<
IFDIF <NAM><LOR>,<
IFDIF <><ENT>,<INTERNAL ENT>
>>
>;NOLOW
>;IFIDN <DUMMY>
>
DEFINE COMPXX ' (NAM,ENT,EXT,DSCRP,INT,HINHB)
<COMPIL(<NAM>,<ENT>,<EXT>,<DSCRP>,<INT>,<HINHB>)>
DEFINE ENDCOM (NAM) <
IFE ALWAYS,<
END
>;IFE ALWAYS
>
; SWITCHES TO CONTROL LIBRARY COMPILATION
IFNDEF ALWAYS,<?ALWAYS__1>
IFN ALWAYS,<DEFINE ENTINT (X) <INTERNAL X>>
IFE ALWAYS,<DEFINE ENTINT (X) <ENTRY X>>
SUBTTL Titles, Versions
DSCR TITLES, VERSIONS
IFN ALWAYS,<
; "TITLE UPPER" IS FOUND IN UP.FAI FILE TO MAKE OUTER PROG TITLED
LOW <
TITLE LOWER
>;LOW
NOUP <
NOLOW <
TITLE RUNTIM -- SAIL RUNTIME ROUTINES
>;NOLOW
;;%BB% DCS (1-many) 12-3-73 Move REENT setup to within SAILOW, for library.
JOBVER__137
LOC JOBVER
;;#HE# DCS 5-11-72 (1-2) MODIFY VERSION STUFF
.VERSION&777777000000 ;CURRENT VERSION NUMBER (LH ONLY)
RELOC
;;#HE# (1-2)
>;NOUP
>;ALWAYS NEQ 0
SUBTTL AC Definitions
DSCR AC DEFINITIONS
; AC DEFINITIONS FOR SERVICE AND RUNTIME ROUTINES
; ALL UUO ROUTS, IOSER COMMENTS
; CORE ROUTS,
; STRING GC,
; ALLOCATION
?FF__0
?A_1 ;TEMPS FOR ALLES
?B_2 ; (SOMETIMES SAVED)
?C_3
?D_4
?E_5 ?X_5 ;MORE TEMPS
?Q1_6 ?Y_6
?Q2_7 ?Z_7
?Q3_10 ?CHNL_10 ;CHNL # FOR IOSER
?T_11 ?CDB_11 ;CHANNEL DATA BLOCK PTR
?T1_12 ;TRY TO KEEP 12(RF) VALID.
?LPSA_13 ;TEMP, PARAM AC
?TEMP_14 ;TEMP ONLY
?USER_15 ;PTR USER TABLE FOR RNTRNT ROUTS
?SP_16 ;STRING STACK
?P_17 ;SYSTEM STACK
SUBTTL CDB, SIMIO Indices For IOSER, OTHER INDICES
DSCR -- CDB, SIMIO INDICES FOR IOSER
DES The I/O routines obtain their information from the user via a
channel number -- the same kind used by the system. In order to
find byte pointers, counts, file names, etc., the channel number is
used to index into a block of core called a CDB (Channel Data Block).
This CDB is filled with good data during the OPEN operation.
The CDB, and all I/O buffers, are obtained from CORGET.
The CHANS table in the GOGTAB area is a 20 word block containing
pointers to the appropriate CDB's.
Since channel numbers must appear in the AC field of IO instructions,
one must construct IO insts. in impure places to retain re-entrancy.
XCT INDEX,SIMIO executes the appropriate IO instruction with the
channel number from AC CHNL, used by all routines. See SIMIO for
operational details.
; SIMIO INDICES
;;=I26= RENAME IOSTATUS TO BE IOERRPROC TO BETTER REPRESENT ITS FN
?IOERRPROC __ 0 ;RETURN STATUS
?IOIN __ 1 ;BUFFERED INPUT
?IODIN __ 2 ;DUMP INPUT
?IOOUT __ 3 ;BUFMODE OUT.
?IODOUT __ 4 ;DUMP OUTPUT
?IOCLOSE __ 5 ;CLOSE FILE
?IORELEASE__ 6 ;RELEASE FILE
?IOINBUF __ 7 ;INBUF
?IOOUTBUF __10 ;OUTBUF
?IOSETI __11 ;USETI
?IOSETO __12 ;USETO
;;%##% RHT ! ADD A PRIMITIVE
?SETIOSTS __13 ;SET IO STATUS
?IOOPEN __14 ;OPEN CHANNEL
?IOLOOKUP __15 ;LOOKUP FILE
?IOENTER __16 ;ENTER FILE
?IORENAME __17 ;RENAME FILE
TYMSHR <;CHANIO INDICES
?CIOIN__14
?CIOOUT__15
?CIOCLS__1
?CIORLS__0
?CIOIBF__22
?CIOOBF__23
?CIOUSI__6
?CIOUSO__7
?CIOSTS__16
?CIOOPN__13
?CIOLUK__4
?CIOENT__5
?CIOREN__11
?CIOGST__17
>;TYMSHR
; FORMAT OF CDBs
DMODE __ 0 ;DATA MODE
DNAME __ 1 ;DEVICE
BFHED __ 2 ;HEADER POINTERS
OBPNT __ 3 ;OUTPUT BUF. PTR
OBP __ 4 ;OUTPUT BYTE PTR
OCOWNT __ 5 ;OUTPUT BYTE CNT
ONAME __ 6 ;OUTPUT FILE NAM
OBUF __ 7 ;OUTPUT BUFFER LOC.
IBPNT __10 ;SAME FOR INPUT
IBP __11
ICOWNT __12
INAME __13
IBUF __14
ICOUNT __15 ;INPUT DATA COUNT LIMIT ADDRESS
BRCHAR __16 ;XWD TTYDEV FLAG, INPUT BREAK CHAR ADDR
TTYDEV __16 ;LH -1 IF DEVICE IS A TTY -- USED BY OUT
ENDFL __17 ;INPUT END OF FILE FLAG ADDR
ERRTST __20 ;USER ERROR BITS SPECIFICATION WORD
LINNUM __21 ;ADDR OF LINE NUMBER WORD (SETPL FUNCTION)
PAGNUM __22 ;ADDR OF PAGE NUMBER WORD (SETPL FUNCTION)
SOSNUM __23 ;ADDR OF SOS NUMBER WORD (SETPL FUNCTION)
?IOTLEN __SOSNUM+1 ;LENGTH OF TABLE ENTRY
?LUPDL_30 ;LENGTH OF UUO PDL
?MINPDS__=64 ;SMALLEST ALLOWABLE SYSTEM PDL SIZE
?DEFPDS__=192 ;DEFAULT PDL SIZE
?.ERSWC __ 20 ;SIZE OF BUILT IN .ERSTR BUFFER
GLOB <
;;ALSO SET IN LEPRUN
?GBRK __ 6000 ;MIN GLOBAL ITEM NUMBER
>;GLOB
;;%BA% DCS (1-many) new STRNGC
; String space header indices -- one header per String Space
;; \UR#29\ JRL (8-7-78) (1 of 5) new entry for .TOPBYTE
?.HDRSIZ__5 ;Header allocated in each string space
?.NEXT__-1 ;Next string space
?.LIST__-2 ;Used to link descriptors during GC
?.SIZE__-3 ;Size of this space
?.STTOP__-4;< ;=> 1 past last word this space (redundant)
?.TOPBYTE __ -5; ; Byte pointer when this space abandoned
;; \UR#28\ (end 1 of 5)
SUBTTL Base (Low Segment) Data Descriptions -- Macros, Compil spec
DSCR DATA DESCRIPTIONS, TAILORED FOR TWO SEGMENT OPERATION
NOUP <
DEFINE SGLK (ROUT,NAM,INT) <
XX (NAM,ROUT,INT) ;NAME OF STRING DSCRPTR GENERATING ROUTINE
XX (,0,) ;PLACE TO PUT A LINK
LINK %SGROT,.-1 ;WHEREWITHAL TO GENERATE SAID LINK
>
>;NOUP
UP <
DEFINE SGLK (ROUT,NAM) <
XX (NAM,ROUT,)
XX (,0,)
>
>;UP
DEFINE XX (A,B,C,D) <
IFDIF <A><>,<? A :> B
IFDIF <C><>,< C A >
>
UP <
III__140
DEFINE XX (A,B,C,D) <
IFDIF <A><>,<? A _ III >
III __ III + 1
IFDIF <D><>,<III_III+D-1>
>
>;UP
COMPIL(LOR,<SAILOR,.SEG2.>
,<%UUOLNK,%ALLOC,%SPGC,%STRMRK,%ARRSRT,K.OUT,$PDLOV,P.FIN>
,<BASE DATA, INITIALIZATION CONTROL>
,<X11,X22,X33,X44>,INHIBIT)
SUBTTL Base (Low Segment) Data Descriptions - Params, Links, Size specs
; UNIVERSAL VARIABLES -- BASES OF MAJOR DATA STRUCTURES, GLOBAL FLAGS
XX (GOGTAB,0,INTERNAL) ;PTR TO USER TABLE
XX (DATM,0,INTERNAL) ;XWD 3,ADDR OF DATUM TABLE
XX (LKSTAT,0,INTERNAL) ;STATUS OF GLOBAL LEAP MODEL INTERLOCK (SHOULD BE IN GOGTAB
XX (INFTB,0,INTERNAL) ;POINT 9,ADDRESS INFOTAB TABLE(3)
XX (.SKIP.,0,INTERNAL) ;RECORD AUX RESULTS OF RUNTIMES
XX (RPGSW,0,INTERNAL) ;SET IF (JOBSA)+1 USED TO START
XX (%RENSW,0,INTERNAL) ;SET IF USER WANTS TO RENTER FOR ALLOC
XX (CONFIG,0,INTERNAL) ;0 FOR RUNTIME, <0 FOR COMPILER
XX (.ERRP.,0,INTERNAL) ;PLACE FOR USER TO PUT AN ERROR PROCEDURE
XX (.ERRJ.,0,INTERNAL) ;TRANSFER ADDRESS RETURNED BY USER PROC.
XX (%ERRC,0,INTERNAL) ;COMMUNICATION BETWEEN USERRR AND ERROR UUO.
XX (%RECOV,0,INTERNAL) ;HIGH ORDER BIT ON IF ERROR RECOVERABLE
XX (%ERGO,0,INTERNAL) ;SET IF IN CONTINUATION MODE.
XX (.ERSTP,0,INTERNAL) ;POINTER INTO ERROR STRING.
;;?.ERSWC __ 20 ; ERROR STRING BUILT IN BUFFER'S WD CNT (ACTUALLY DEFINED EARLIER)
XX (.ERSTR,<BLOCK 20>,INTERNAL,20) ;ERROR MESSAGE STRING.
XX (.DTRT.,0,INTERNAL) ;DDT RETURN ADDRESS
;;%BB% DCS 12-3-73 (1-many) cmu style pre/post traps
XX (.EXPINT,0,INTERNAL) ;CORE UUO TRAP ROUTINE ADDRESS (CMU-STYLE)
XX (.SGCINT,0,INTERNAL) ;STRING GC TRAP ROUTINE ADDRESS (")
XX (.TRACS,<BLOCK 12>,INTERNAL,12) ;CORE, STRNGC TRAP ROUTINE SAVE ACS
XX (RUNNER,0,INTERNAL) ;THE CURRENTLY RUNNING PROCESS(IF HAVE THEM)
XX (INTRPT,0,INTERNAL) ;MASK FOR INTERRUPT POLLING
XX (PROPS,0,INTERNAL) ;BYTE POINTER FOR ACCESSING PROPS(ITEM) ITEM IN 3
XX (NOPOLL,0,INTERNAL) ;NEQ 0 MEANS IGNORE CALL TO DDFINT
XX (DEFSSS,0,INTERNAL) ;DEFAULT S-STACK SIZE -- SET BY MAINPR
XX (DEFPSS,0,INTERNAL) ;DEFAULT P-STACK SIZE (FOR PROCESSES) -- DITTO
XX (DEFPRI,0,INTERNAL) ;DEFAULT PRIORITY -- DITTO
XX (DEFQNT,0,INTERNAL) ;DEFAULT QUANTUM -- DITTO
XX (OVPCWD,0,INTERNAL) ;SET BY APR INTERRUPT HANDLER (IF ANY)
NOEXPO <
IFE APRISW <
XX (XJBCNI,0,INTERNAL) ;JOBCNI TYPE THING FOR MOORER SYS (MOD BY F.WRIGHT)
XX (XJBTPC,0,INTERNAL) ;JOBTPC THING, ETC
XX (XJBAPR,0,INTERNAL) ;JOBAPR THING.
>;IFE APRISW
IFN APRISW <
XX (S15ARE,0)
XX (S16ARE,0)
XX (S17ARE,0)
>;IFN APRISW
>;NOEXPO
XX (XJBENB,0,INTERNAL) ;USED BY APR ENABLER FOR EXPORT SYSTEM
;SPARE LOWER LOCATIONS
XX (.ERSTC,0,INTERNAL) ; COUNT OF CHARS LEFT IN .ERSTR
;;%BF% -- ERR BUFFER LENGTH KLUGE (1 OF MANY)
XX (.ERBWD,0,INTERNAL) ; BYRE(13)CHAR COUNT(23)BUFFER
XX (RECCHN,0,INTERNAL) ;EVERY RECORD IN THE WORLD GOES ON THIS
XX (RGCLST,0,INTERNAL) ;LIST OF RECORD MARK ROUTINES
;;%BL% -- UUO KLUGE
XX (.UUOCN,0,INTERNAL) ;LOCATION OF ALTERNATE UUO DISPATCH
;;%BT% !
XX (.CORIN,0,INTERNAL) ;SOME SORT OF CORGET TRAP
;;%BU% !
XX (.LEPIN,0,INTERNAL) ;LEAP TRAP FOR TIMING TESTS
;;%BR% ADD SOME MORE SPARES
NRC <
XX (CLSLNK,0,INTERNAL) ;CLASS LINK HOMED HERE
XX ($CLS.R,0) ;CLASS RING
XX ($CLASS,0,INTERNAL) ;THE "CLASS" CLASS
XX ($CLS.1,0) ;THE "RECRNG" WORD
XX ($CLS.2,0) ;THE "HANDLER" WORD -- SET UP IN INIT
XX ($CLS.3,5) ;"WRDCNT"
XX ($CLS.4,0) ;POINTER TO "TYPARR" -- SET UP IN INIT
XX ($CLS.5,0) ;POINTER TO "TXTARR" -- SET UP IN INIT
XX (STRCHN,0,INTERNAL) ;USED FOR STRING SUBFIELD CHAIN
>;NRC
NONRC <
XX (S1PARE,0)
XX (S2PARE,0)
XX (S3PARE,0)
XX (S4PARE,0)
XX (S5PARE,0)
XX (S6PARE,0)
XX (S7PARE,0)
XX (S8PARE,0)
XX (S9PARE,0)
>;NONRC
;;%BR% ^
;;%DA% !
XX ($SPCAR,0,INTERNAL) ;AN ARRAY OF SMALL SPACE DESCRIPTORS USED BY RECS
XX ($OS,0,INTERNAL) ;[clh] CODE INDICATING WHICH OPERATING SYSTEM
TENX<
XX ($OSTYP,0,INTERNAL) ;[clh] 0 for Tenex, 2 for Tops-20
>;TENX
NOTENX<
XX (S12ARE,0)
>;NOTENX
XX (S13ARE,0)
XX (S14ARE,0)
GLOB <
XX (GSPARE,<BLOCK 2>,,2)
>;GLOB
NOGLOB <
XX (GDATM,0,INTERNAL) ;DUMMY GLOBAL DATUM TABLE SHOULD ALWAYS BE ZERO
GPROPS_GINFTB_GDATM ;DUMMY GLOBAL INFOTAB DITTO
INTERNAL GINFTB,GPROPS
>;NOGLOB
; STATIC LINKAGES -- FEATURE PROVIDED BY LOADER
; THESE ARE THE BASES OF ONE-WAY LINKED LISTS WHICH ALLOW ACCESS
; TO SELECTED DATA IN ALL LOADED MODULES
XX (STLNK,0,INTERNAL) ;1 ALL STRINGS TIED TOGETHER FOR STRNGC
XX (SPLNEK,0,INTERNAL) ;2 ALL SPACE REQUESTS (PDLS, ETC.)
XX (SETLET,0,INTERNAL) ;3 ALL SET VARIABLES TIED TOGETHER
XX (SGROT,0,INTERNAL) ;4 LIST OF STRNGC SORTER GENERATORS
XX (KTLNK,0,INTERNAL) ;5 ALL COUNTER BLOCKS
XX (INILNK,0,INTERNAL) ;7 INITIALIZATION ROUTINES (LPINI ONLY NOW)
;;%BR% MOVED THESE DOWN FROM SPARES
XX (PDLNK,0,INTERNAL) ;LINKED LIST OF ALL PDS
;;%BM% -- RECORD GARBAGE COLLECTION
XX (RBLIST,0,INTERNAL) ;LIST OF RECORD BLOCKS
XX (BALNK,0,INTERNAL) ;LOADER LINK FOR DEBUGGER INFO
;;%BR% ^
;; \UR#3\ BIG LEAP ALLOCATES ITEMS IN DESCENDING ORDER
URLEAP <
;; %% JES (@UOR) VARIABLES FOR DESCENDING ITEM ALLOCATION
XX (TPALLC,0,INTERNAL) ;THE MAXIMUM DECLARED ITEM
XX (ITMBOT,0,INTERNAL) ;THE MINIMUM DYNAMICALLY ALLOCATED ITEM
>;URLEAP
;; \UR#3\
URLEAP<
;; \UR#7\ SUPPRESS OVERLAP MESSAGE
XX ($$LNOWARN,0,INTERNAL) ; NON-ZERO
; SUPPRES ITEM OVERLAP MSG
;; \UR#7\
>;URLEAP
URSTAT <
;; \UR#7\ GATHER STATISTICS
;; %% JES VARIABLES FOR COUNTS OF LEAP INNER LOOPS
XX (RCNT1,0,INTERNAL)
XX (RCNT2,0,INTERNAL)
XX (RCNT3,0,INTERNAL)
XX (RCNT4,0,INTERNAL)
XX (RCNT5,0,INTERNAL)
XX (RCNT6,0,INTERNAL)
XX (RCNT7,0,INTERNAL)
XX (RSUC1,0,INTERNAL)
XX (RSUC2,0,INTERNAL)
XX (RSUC3,0,INTERNAL)
XX (RSUC4,0,INTERNAL)
XX (RSUC5,0,INTERNAL)
XX (RSUC6,0,INTERNAL)
XX (RSUC7,0,INTERNAL)
>;URSTAT
;; \UR#7\
; THESE OPS INFORM THE LOADER OF THE ABOVE BASE LOCATIONS.
NOUP <
LINKEND %STLNK,STLNK
LINKEND %SPLNK,SPLNEK
LINKEND %SETLK,SETLET
LINKEND %SGROT,SGROT
LINKEND %KTLNK,KTLNK
LINKEND %INLNK,INILNK
LINKEND %PDLNK,PDLNK
LINKEND %RBLNK,RBLIST
BAIL<
LINKEND %BALNK,BALNK
>;BAIL
NRC <
LINKEND %RCLNK,CLSLNK
>;NRC
>;NOUP
; SOME ROUTINES WHICH GO ON THE SGROT LIST (SEE SGLK)
;^SGLKBK
SGLK (%ARRSRT,SGLKBK,INTERNAL);ROUTINE TO COLLECT STRING ARRAYS
SGLK (%STRMRK) ;ROUTINE TO COLLECT STRING VARIABLES
SGLK (%SPGC) ;ROUTINE TO COLLECT STRING STACK
;HERE IS THE LIST OF DEFAULT SPACE ALLOCATION ENTRIES
XX (%SPL,<BLOCK $SPREQ-2>,INTERNAL,$SPREQ-2);DUMMY FIXED ADDR STUFF
XX (%STDLST,<BLOCK 2>,INTERNAL,2) ;BASE OF BUILT-IN REQUESTS
XX (,<XWD WNTPDP!MINSZ!USRTB,DEFPDS>) ;SYSTEM!PDL (SPECIAL, SEE BELOW)
XX (,<XWD [ASCIZ /SYSTEM PDL/],PDL>)
XX (,<XWD WNTPDP!USRTB!MINSZ,50>) ;STRING STACK
XX (,<XWD [ASCIZ /STRING PDL/],SPDL>)
XX (,<XWD WNTADR!WNTEND!USRTB!MINSZ,2000>);STRING!SPACE
XX (,<XWD [ASCIZ /STRING SPACE/],ST>)
XX (,0) ;THAT'S ALL
; LINK %SPLNK,%SPL ;%ALLOC DOES THIS EXPLICITLY SO THIS
;BLOCK WILL BE FIRST
;SOME RANDOM GLOBALLY USEFUL THINGS, WHICH UNFORTUNATELY HAVE TO
;BE IN FIXED LOCATIONS (FOR THE RUNTIMES TO FIND)
; MADE ALLPDL BIGGER (FROM 20) BECAUSE OF NEW UUO HANDLER
XX (ALLPDP,<IOWD 40,ALLPDL>,INTERNAL);USED FOR A WHILE DURING ALLOC
XX (ALLPDL,<BLOCK 40>,INTERNAL,40) ;AND IN PROCESS TERMINATION
XX (%ALLCHR,0,INTERNAL)
XX (%OCTRET,0,INTERNAL)
;SOME WONDERFULLY USEFUL CONSTANTS
XX (X11,<XWD 1,1>,INTERNAL)
XX (X22,<XWD 2,2>,INTERNAL)
XX (X33,<XWD 3,3>,INTERNAL)
XX (X44,<XWD 4,4>,INTERNAL)
TYMSHR <IFE ALWAYS <XX (DDFINA,<JFCL>,INTERNAL)>
IFN ALWAYS <XX (DDFINA,<PUSHJ P,DDFINT>)
LOW <EXTERNAL DDFINT>>>;TYMSHR
EXPO <
XX (PPMAX,<BLOCK 3>,INTERNAL,3) ;FOR SCREWY EDITOR LINKAGE
>;EXPO
XX (APRACS,<BLOCK 20>,INTERNAL,20) ;APR INTERRUPT AC STORAGE
;;%##% EXPORT OUTSTR BUFFER (USED TO USE SGACS, BUT ...)
NOTENX<
EXPO <
XX (OTSTRBF,<BLOCK 20>,INTERNAL,20) ;OUTSTR BUFFER
>;EXPO
>;NOTENX
CMU < ;THIS STUFF USED FOR GAS
XX (GASCMD,0,INTERNAL) ;IF 0 THEN VIRGIN, SO
;SET NEG & SET LH(JOBHRL) TO -1 & EXIT
XX (THIS.MOD,0,INTERNAL) ;
>;CMU
;TENEX XX VARIABLES - MOSTLY FOR INTERRUPTS
TENX <
XX (CHNTAB,<BLOCK =36>,INTERNAL,=36);SHOULD BE REFERENCED
XX (LEVTAB,LPC1,INTERNAL) ;ONLY FROM CODE AT STRT IN SAILOR, Q.V.
XX (,LPC2,)
XX (,LPC3,)
XX (LPC1,0,INTERNAL)
XX (LPC2,0,INTERNAL)
XX (LPC3,0,INTERNAL)
XX (JMPCHN,<BLOCK =36>,INTERNAL,=36)
LOW <
EXTERNAL PSIL1,PSIL2,PSIL3
>;LOW
XX (PS1ACS,<BLOCK 20>,INTERNAL,20)
XX (,<JRST PSIL1>,)
XX (PS2ACS,<BLOCK 20>,INTERNAL,20)
XX (,<JRST PSIL2>,)
XX (PS3ACS,<BLOCK 20>,INTERNAL,20)
XX (,<JRST PSIL3>,)
;XX VARIABLES FOR IO
XX (JFNTBL,<BLOCK JFNSIZE>,INTERNAL,JFNSIZE) ;JFNs for each channel
XX (CDBTBL,<BLOCK JFNSIZE>,INTERNAL,JFNSIZE) ;Addr. of chnl data buffer for each chnl
XX (PRTMP,0,INTERNAL)
XX (CTLOSW,0,INTERNAL) ;CTRL-O SWITCH
XX (TTCSVB,0,INTERNAL) ;TENEX emulation of TTCALL
>;TENX
;;%CN% ! (1/2) JFR 7-25-75 CONTENTS OF ACS AT INITIAL ENTRY
XX (INIACS,<BLOCK 20>,INTERNAL,20)
DEC<
;;=I02= Added variable for batch check -- CH05 31-May-75
XX (%BATCH,0,INTERNAL) ;1 IF BATCH, -1 IF NOT, 0 IF HAVEN'T CHECKED
;;=I02= RUN block to allow TECO -- CLH 31-May-75
XX (EDTBLK,<SIXBIT /SYS/>,INTERNAL)
XX (EDTNAM,<SIXBIT /SOS/>,INTERNAL)
XX (EDTBL1,<BLOCK 4>,INTERNAL,4)
;;=I09= NEED PPN FOR SFD DECODING
XX (MYPPN,0,INTERNAL)
> ;DEC
;PUT NO XX VARIABLES IN AFTER THIS POINT
LOW<
IFNDEF XTCKLG,<
EXTERNAL LPINI
LPLK: 0
LPINI
0
LINK %INLNK,LPLK
NRC<
EXTERNAL $RCINI
RCLK: 0
$RCINI
0
>;NRC
>;IFNDEF XTCKLG
>;LOW
SUBTTL Initialization Routines, Data
COMMENT The Run-Time I/O handling routines are re-entrant. This
means that any modifiable words or parameters particular to a given
user must come from the user's core image. The pointer to this area
will be found in GOGTAB in the lower segment. The I/O routines use
some of the AC'S in standard ways, described above with AC definitions.
DSCR SAILOR -- ALLOCATION AND INITIALIZATION ROUTINES
CAL JSR
DES
Part of this is not yet reentrant. In particular,
it is called by a JSR SAILOR
The functions of this routine are:
1. Get a second segment, if this is a SAISEG-program
2. Process space requests, allow user-override if REENTER used
to start.
3. Use %ALLOC to allocate requested regions.
4. Clear Kounters
5. Change starting and re-entry addresses,
6. PUSHJ to user program
7. Record Kounters, RESET and quit.
SUBTTL Sailor, Reent -- Allocation, Main Program Control
NOUP <
;SAIL job calls SAILOR first time, with RPGSW set up already
INTERNAL SAILOR
^SAILOR: 0 ;JSR to SAILOR
;;%CN% (2/2)
MOVEM 17,INIACS+17
MOVEI 17,INIACS
BLT 17,INIACS+17-1
;;%CN% ^
JRST FRSTRT ;GET A SEGMENT, START UP
; REENTER to manually change allocation, and to flush REQUIREd segments
;;%AZ% DCS 12-3-73 (1-many) Improved ALLOC, Reenter sqncs, here and following
; Set Re-entry address
LOC 124 ;SET UP REENTER ADDRESS
REENT
RELOC
^REENT: SETOM %RENSW ;RE-ENTER -- ASK FOR NEW ALLOC
;;% %2.! DCS 12-3-73 SIMPLE REENTER SEQUENCE
HRRZ TEMP,JOBSA ;SAME AS START, OTHERWISE
JRST (TEMP)
;SAIL STARTS HERE WHEN USER TYPES S<T<A<R<T>>>> AGAIN
^RESTRT:TDZA TEMP,TEMP ;ESTABLISH OPERATING MODE
MOVNI TEMP,1 ;RPG MODE
MOVEM TEMP,RPGSW ;RECORD IT
FRSTRT:
;[clh] Now find what monitor we are running under, put in $OS
;[clh] If no response, assume most likely thing given assembly switches
MOVE TEMP,[XWD 112,11] ;[clh] monitor type
CALLI TEMP,41 ;[clh] GETTAB (CALL6 not defined in Tenex)
TENX < MOVEI TEMP,3B23> ;[clh] Tenex, since Tops-20 will always respond
NOTENX <
NOSTANFO<MOVEI TEMP,1B23> ;[clh] Tops-10
STANFO < MOVEI TEMP,5B23> ;[clh] Stanford
> ;NOTENX
MOVEM TEMP,$OS ;[clh]
TENX<
LDB TEMP,[POINT 6,TEMP,23] ;[clh] get type field
SETZM $OSTYP ;[clh] assume Tenex
CAIN TEMP,3 ;[clh] see if right (3=Tenex)
JRST .+3 ;[clh] yes
AOS $OSTYP ;[clh] wrong, it is TOPS-20
AOS $OSTYP ;[clh] use 2
JSYS RESET
>;TENX
JSP P,.SEG2. ;GET SECOND SEGMENT
;; %AO% ;WILL SKIP RETURN IF DOES A SETPR2
;INSTEAD OF SEGMENT FETCHING
;[clh] STRT: ;this label seems not to be used, and is misleading
NOTENX <
CALL6(RESET)
>;NOTENX
TENX <
EXTERNAL .RESET
EXTERNAL P.FIN
JSP P,.RESET ;JSYS RESET, PSI SYSTEM, TTY MODES, FILE BUFFERS
>;TENX
CMU <
GGAS <
MOVEI TEMP,0 ;
CALL6 (TEMP,SETUWP) ;
JRST [PUUO 3,[ASCIZ /CANNOT CLEAR WRITE PROTECTION/]
CALL6(EXIT) ];
>;GGAS
>;CMU
SETZM GOGTAB ;FORCE CORSER RE-INITIALIZATION
SETNIT ;GET TEMP STACK, IF NECESSARY
;;%AZ% DCS 12-3-73 K.ZERO, INILST calls moved to ALLOC
JSP 16,%ALLOC ;ALLOCATE AREAS
MOVEI A,RESTRT ;CHANGE JOBSA AND JOBREN
HRRM A,JOBSA ;"S" USES OLD ALLOCATION
;;%AL% .! THE OUTER BLOCK IS JUST A PROCEDURE
HRLOI RF,1 ;THE VERY OUTER BLOCK
PUSHJ P,@SAILOR ;CALL USER PROGRAM
PUSHJ P,K.OUT ;WRITE OUT THE COUNTERS
;;%BF% !
PUSHJ P,P.FIN ;CLOSE OUTPUT $PRINT FILE, IF ANY
TERPRI <
End of SAIL execution>
NOTENX <
CALL6 (0,RESET) ;CLEAR THE I/O WORLD
CALL6 (1,EXIT) ;QUIT QUIETLY
>;NOTENX
TENX <
JSYS HALTF
JRST .-1 ;NO CONTINUATION
>;TENX
SUBTTL .SEG2. -- Get a second segment
COMMENT Initialize the second segment, if there is none and if desired.
This occurs when the program is first started. This is a dummy routine
if not a SAISEG-program
NOTENX <
INTERNAL .SEG2.
.SEG2.:
NOCMU <
LOW <
SKIPE JOBHRL ;IS THERE A SEGMENT?
>;LOW
>;NOCMU
CMU <
IFN LOWER!GASSW ,<
GGAS <
SKIPL GASCMD ;VIRGIN??
JRST GASSET ;YES, DO SOMETHING ABOUT THAT
>;GGAS
SKIPN A,JOBHRL ;ALSO CHECK FOR -1,,0
JRST .+3
CAME A,[XWD -1,0] ;
>;IFN LOWER!GASSW
>;CMU
JRST (P) ; YES, GO AHEAD (OR ALWAYS, IF NOLOW)
>;NOTENX
>;NOUP
NOTENX <
NOCMU <
LOW <
COMMENT Now, if global model, get segment specifications from space blocks
of compiled programs (via REQUIRE verbs in source code).
Segment name business is ignored in EXPO version, since segment and file
names are always equivalent (philosophical differences).
SEGTR: ;TRY AGAIN
GLOB <
SKIPN %RENSW ;IS LINK-TABLE AND/OR PREVIOUSLY COLLECTED
; INFORMATION INVALID??
JRST SEG3 ;NO
FOR II IN (SEGDEV,SEGFIL,SEGPPN,NMSAV) <
SETZM II
>
JRST ASKEM ;CLEAR ALL NON-USER SPECIFIED INFO
SEG3: SKIPN B,SPLNEK ;A SPACE BLOCK AROUND??
JRST ASKEM ; NO
GSGLP: SKIPE A,$SGD(B) ;DEVICE REQUEST
MOVEM A,SEGDEV
SKIPE TEMP,$SGF(B) ;FILE NAME FOR UPPER SEGMENT
MOVEM TEMP,SEGFIL
SKIPE TEMP,$SGPP(B) ;PPN FOR SAME
MOVEM TEMP,SEGPPN
SKIPE TEMP,$SGNM(B) ;SEGMENT NAME (UNUSED IN EXPO VERSION)
MOVEM TEMP,NMSAV
SKIPE B,(B) ;GO DOWN LINKED LIST
JRST GSGLP ; UNTIL EMPTY
>;GLOB
COMMENT If not enough information was supplied (global model only),
ask questions of user to obtain file names, etc. Also (NOEXPO only),
try to ATTSEG to a segment of the desired name. In the EXPO version,
all this is combined in the GETSEG below.
NOEXPO <
;SEGMENT NAME NOT USEFUL TO EXPO SYSTEM
GLOB <
SKIPE A,NMSAV ;DID WE GET A SEGMENT?
JRST GOTEM ; YES, TRY TO LINK TO IT
ASKEM: SPRINT <SEGMENT LOGICAL NAME?>
JSR GGNAM ;GET A SEGMENT NAME.
GOTEM: MOVEM A,NMSAV
>;GLOB
NOGLOB <
MOVE A,[FILXXX] ;TRY TO FIND IT.
>;NOGLOB
CALL6(A,ATTSEG) ;
SKIPA ;NO LUCK
JRST (P) ;OK, DONE
HRRZ B,A ;GET FAILURE CODE.
CAIE B,1 ;AMBIGUITY?
JRST GETSE ;NO -- GET THE SEGMENT.
HLRZS A
CALL6(A,ATTSEG) ;
JSP A,ERSEG
JRST (P) ;OK, GOT IT
>;NOEXPO
EXPO <
ASKEM: ;MISPLACED LABEL
>;EXPO
GETSE: CALL6(RESET)
GLOB <
SKIPE A,SEGFIL ;WAS ONE "REQUIRE"D?
JRST THSFL ; YES, USE IT
SPRINT <SEGMENT FILE NAME?>
MOVE A,[FILXXX] ;DEFAULT
JSR GGNAM
THSFL: MOVEM A,SEGFIL ;NAME OF SEGMENT.
THSFL1: SKIPE A,SEGDEV ;WAS A DEVICE REQUESTED?
JRST THSDV ; YES
SPRINT <DEVICE?>
MOVE A,[SGDEVC] ;DEFAULT DEVICE
JSR GGNAM
MOVEM A,SEGDEV
CAMN A,['DSK '] ;ASK FOR PPN IF DISK
SKIPE SEGPPN ;AND PPN=0
JRST THSDV ;DON'T ASK, ALREADY THERE
SPRINT <PPN?>
MOVE A,[SGPPNN] ;DEFAULT PPN
JSR GGNAM
MOVEM A,SEGPPN
JRST THSFL1 ;NOW HAVE A DEVICE
THSDV: MOVEM A,INTT
MOVE A,[XWD SEGDEV,DEVSEG] ;MOVE LOOKUP SPEC IN
BLT A,SEGNAM+3
>;GLOB
NOGLOB <
SETZM SEGNAM+2
MOVE TEMP,[SGPPNN]
MOVEM TEMP,SEGNAM+3 ;SET UP PPN
HLLZS SEGNAM+1
>;NOGLOB
COMMENT Now work is nearly done in EXPO system, but all sorts of hair
remains otherwise. In either case, now get segment in, get it into 2d
segment, name it right
NOEXPO <
INIT 1,17
INTT: SGDEVC ;GO GET THE RAW SEGMENT
0
JSP A,ERSEG
LOOKUP 1,SEGNAM
JSP A,ERSEG
MOVS A,SEGNAM+3 ;WORD COUNT
HRLM A,LIOD ;WORD COUNT FOR DUMP MODE.
MOVNS A
HRRO D,JOBREL ;FOR LATER
HRRM D,LIOD ;PLACE TO START DUMP MODE INPUT.
ADD A,JOBREL ;TO GET THE AMOUNT OF CORE NEEDED.
CALL6 (A,CORE) ;CORE UUO ----
JSP A,ERSEG
LOP22: INPUT 1,[LIOD: 0
0]
GLOB <
TLZ D,-1 ;NO, MAKE IT WRITEABLE IF GLOBAL MODEL.
>;GLOB
IFN NOPROT,<
TLZ D,-1 ;MAKE WRITEABLE IF REQUESTED TO
>;NOPROT NEQ 0
CALL6 (D,REMAP) ;
;;%AO% DO SETPR2 TO AVOID LOSSAGE WHEN NO JOB SLOTS LEFT
NOGLOB <
JRST [ ;
CALL6(RESET) ;SINCE A RESET LATER MEANS DISASTER
PUUO 3,[ ASCIZ/
COULD NOT DO REMAP TO GET A SAIL SEGMENT!
SETPR2 DONE INSTEAD. YOUR JOB SHOULD BE HAPPY SO LONG AS
IT DOES NOT DO A RESET OR OTHER BADNESS. GOOD LUCK.
ALSO, IF YOU WANT TO RUN THIS WAY, BEWARE OF RESTARTING.
/] ;BETTER WARN THE POOR PEOPLE
ADDI D,2 ;MAKE EVEN K & MAKE IT REL MODE
MOVS A,SEGNAM+3;
MOVN A,A ;SIZE
ORI A,1777 ;PUTS TO K BNDRY & WRITE PROT
HRLI D,(A) ;
SETPR2 D, ;FAKE THE SEGMENT
JRST [ PUUO 3,[ASCIZ/
SETPR2 LOST, TOO!
/]
JRST 4,1(P)]
MOVE A,JOBREL; SINCE SAIL COMPILER IS DUMB
HRRM A,JOBFF ; SAFE NOW???
HRLM A,JOBSA ; BOTH PLACES (BUFSAV REFERS TO JOBSA)
JRST 1(P) ;HURRAH -- RETURN
;DO 1(P) TO AVOID THE RESET
]
>;NOGLOB
GLOB <
JSP A,ERSEG ;GLOBAL CANNOT GET AWAY WITH SETPR2
>;GLOB
;;%AO%
NOGLOB <
MOVE A,[FILXXX]
>;NOGLOB
GLOB <
MOVE A,NMSAV
>;GLOB
CALL6 (A,SETNM2)
JRST [MOVEI A,0
CALL6 (A,CORE2) ;CORE2
JSP A,ERSEG
GLOB <
SETOM %RENSW ;FORCE TTY RITUAL
>;GLOB
JRST SEGTR] ;TRY AGAIN.
CALL6(RESET)
>;NOEXPO
EXPO <
SETZM SEGNAM+4 ;CLEAR LAST TWO WORDS OF GETSEG BLOCK
SETZM SEGNAM+5
MOVEI A,DEVSEG ;GET READY
MOVEM P,SAVPP
CALL6 (A,GETSEG) ;GET THE SEGMENT
JSP A,ERSEG ; COULDN'T
MOVE P,SAVPP
; NO WAY TO RENAME 2D SEGMENT, SO DON'T WORRY ABOUT IT
>;EXPO
JRST (P) ;RETURN
;NOTE: ALSO HAVE A JRST (P) IN
; THE CODE FOR FEAT %AL%
>;LOW
>;NOCMU
;;*************************
CMU <
IFN LOWER!GASSW,<
INTERNAL DEVSEG
SEGTR: ;TRY AGAIN
ASKEM: ;RANDOM LABEL
GETSE: CALL6(RESET) ;
SETZM SEGNAM+2
MOVE TEMP,[SGPPNN]
MOVEM TEMP,SEGNAM+3 ;SET UP PPN
HLLZS SEGNAM+1
SETZM SEGNAM+4 ;CLEAR LAST TWO WORDS OF GETSEG BLOCK
SETZM SEGNAM+5
MOVEI A,DEVSEG ;GET READY
MOVEM P,SAVPP
CALL6 (A,GETSEG) ;GET THE SEGMENT
JSP A,ERSEG ; COULDN'T
MOVE P,SAVPP
; NO WAY TO RENAME 2D SEGMENT, SO DON'T WORRY ABOUT IT
HRROS JOBHRL
JRST (P) ;RETURN
;NOTE: ALSO HAVE A JRST (P) IN
; THE CODE FOR FEAT %AL%
>;LOW
>;IFN LOWER!GASSW
>;CMU
>;NOTENX
EXPO <
NOUP <
INTERNAL TYPER.,ERRMSG
;THESE ARE BECUSE OF LIB40 CHANGES
; MADE CAPRICIOUSLY BY DEC
TYPER.:
ERRMSG:
JFCL
ERR <SOME FORTRAN ROUTINE HAS SEEN FIT TO COMPLAIN
ABOUT YOUR STYLE. COMPLAIN TO DEC THAT THEIR ERROR MESSAGE
PROCEDURE IS NOT SUFFICIENTLY GENERAL TO ALLOW GRACEFUL INTERFACE
WITH SAIL.>
>;NOUP
>;EXPO
SUBTTL Segment-Fetching Data
NOTENX <
NOCMU < ;THESE GUYS HAVE TO BE EXTRA SPECIAL
LOW <
NMSAV: 0 ;SAVE LOGICAL SEGMENT NAME HERE
SEGDEV: 0 ;SAVE UPPER SEGMENT DEVICE NAME HERE
SEGFIL: 0 ;SAVE UPPER SEGMENT FILE NAME HERE
NOEXPO <
SIXBIT /SEG/ ;ALWAYS
>;NOEXPO
EXPO <
0 ;DIFFERENT STROKES FOR ....
>;EXPO
0
SEGPPN: 0 ;SAVE UPPER SEGMENT PPN HERE
DEVSEG: SGDEVC ;USED ONLY BY EXPO'S GETSEG
SEGNAM: FILXXX
NOEXPO <
SIXBIT/SEG/
>;NOEXPO
EXPO <
0
>;EXPO
0
SGPPNN ;SPECIFIED PPN DEFAULT
EXPO <
0
0 ;SIX WORD BLOCK FOR GETSEG
SAVPP: 0 ;P SAVED HERE OVER GETSEG
>;EXPO
ERSEG: SPRINT <SAIL SEGMENT LOADING ERROR
>
GLOB<
SETOM %RENSW ;FORCE TTY RITUAL
>;GLOB
CALL6 (EXIT)
GLOB <
GGNAM: 0
TTCALL 4,C ;INCHWL.
CAIE C,15 ;IF NOTHING SPECIFIED,
MOVEI A,0 ; USE THE DEFAULT
SKIPA B,[POINT 6,A]
GGGO: TTCALL C ;GET CHAR
CAIN C,15
JRST [TTCALL C
JRST @GGNAM] ;RETURN ON CR.
CAILE C,140
SUBI C,40 ;CONVERT LOWER CASE.
SUBI C,40 ; CNVRT TO SIXBIT
IDPB C,B ;SAVE IT.
JRST GGGO
>;GLOB
>;LOW
>;NOCMU
;;****************************
CMU <
IFN LOWER!GASSW,<
NMSAV: 0 ;SAVE LOGICAL SEGMENT NAME HERE
SEGDEV: 0 ;SAVE UPPER SEGMENT DEVICE NAME HERE
SEGFIL: 0 ;SAVE UPPER SEGMENT FILE NAME HERE
0 ;DIFFERENT STROKES FOR ....
0
SEGPPN: 0 ;SAVE UPPER SEGMENT PPN HERE
DEVSEG: SGDEVC ;USED ONLY BY EXPO'S GETSEG
SEGNAM: FILXXX
0
0
SGPPNN ;SPECIFIED PPN DEFAULT
0
0 ;SIX WORD BLOCK FOR GETSEG
SAVPP: 0 ;P SAVED HERE OVER GETSEG
ERSEG: SPRINT <SAIL SEGMENT LOADING ERROR
>
CALL6 (EXIT)
GGAS < ;COME HERE WHEN STARTING VIRGINALLY
EXTERNAL %FIRLOC,TOP2
GASSET: SKIPE GASCMD ;NORMAL?
JRST GASPEC ;NO
HRROS JOBHRL ;SO THE HISEG WON'T BE SAVED
SETOM GASCMD ;SO WE WON'T DO THIS SILLINESS AGAIN
TERPRI <SAVE me>
CALL6 (0,EXIT)
GASPEC: SKIPE TOP2 ;HAVE WE BEEN HERE BEFORE?
JRST (P) ;YES
MOVEI A,0
CALLI A,36 ;CLEAR WRITE PROTECT
JRST [TERPRI <CAN'T WRITE ENABLE 2D SEG>
CALLI 1,12]
SETZM %FIRLOC+11 ;NO 2D SEGMENT SYMBOL TABLE
HLRZ A,JOBHRL
MOVEI A,-%FIRLOC-1(A)
TRO A,400000 ;TURN IT OFF.
HRRZM A,TOP2
JRST (P)
>;GGAS
>;IFN LOWER!GASSW
>;CMU
>;NOTENX
TENX <
NOUP <
INTERNAL .SEG2.
.SEG2.: MOVE 1,[XWD 400000,SEGPAG] ;THIS FORK__400000
JSYS RPACS
TLNE 2,10000 ;DOES THE PAGE FOR THE SEGMENT EXIST?
JRST (P) ;YES
MOVEI 1,400000 ;THIS FORK
JSYS GEVEC ;GET ENTRY VECTOR
MOVEM 2,3 ;SAVE IT
HRLZI 1,100001
GSYSIN ;[clh]
MOVE 2,[FILXXX]+1(SYSIND) ;[clh]
JSYS GTJFN
JRST [HRROI 1,[ASCIZ/SAIL segment loading error on segment:
/]
JSYS PSOUT
GSYSIN ;[clh]
MOVE 1,[FILXXX]+1(SYSIND) ;[clh]
JSYS PSOUT
HRROI 1,[ASCIZ/
/]
JSYS PSOUT
HLTAGN: JSYS HALTF
JRST HLTAGN ;NO CONTINUATION
]
HRLI 1,400000
JSYS GET
MOVEI 1,400000 ;THIS FORK
MOVEM 3,2
JSYS SEVEC
JRST (P)
>;NOUP
>;TENX
ENDCOM(LOR)
LOW <
END
>;LOW
COMPIL(LUP,,,,,,DUMMYFORSCISS)
TYMSHR <DEFINE IENT1 <SAVETY,SAVE>>;TYMSHR
NOTYMSHR <DEFINE IENT1 <SAVE>>;NOTYMSHR
COMPXX(LUP,<IENT1,%UUOLNK,%ALLOC,RESTR,STACSV,STACRS,INSET,USERERR,$PDLOV,.UINIT,ERMSBF,EDFILE,SPLICE,SPLPRT>
,<CORGET,STCLER,GOGTAB,CONFIG,%ALLCHR,CAT,STRNGC,K.ZERO,INIACS>
,<INITIALIZATION ROUTINES, UUO HANDLER, UTILITY ROUTINES>
,DT.RET)
IFE ALWAYS,<
INTERNAL %ALLOC,DT.RET
; MORE EXTERNALS
;;%BL%
EXTERNAL ALLPDP,SETLET,INILNK,XJBENB,.UUOCN
TENX<
EXTERNAL $OSTYP
> ;TENX
DEC<
;;=I02=
EXTERNAL %BATCH
EXTERNAL EDTBLK,EDTNAM
;;=I09=
EXTERNAL MYPPN
> ;DEC
EXTERNAL SPLNEK,%OCTRET,%RECOV,%ERRC,%RENSW,%ERGO
;;%##% .ERSTC ADDED
;;%BF% ALSO .ERBWD,CORREL
EXTERNAL .DTRT.,.ERSTR,.ERSTP,.ERRP.,.ERRJ.,.ERSTC,.ERBWD,CORREL
;; X33 11-24-74 JFR
EXTERNAL X11,X22,X33,X44,CORINC,%STDLS,%SPL,KTLNK,PDLNK
EXPO <
EXTERNAL PPMAX
>;EXPO
RGC <
EXTERNAL RECCHN,RGCLST
>;RGC
>;IFE ALWAYS
NOLOW < ;PUT IN UPPER SEGMENT AND ALL THAT FOLLOWS....
UP <
;IF YOU CHANGE ANYTHING ABOVE THIS POINT, YOU WILL
;HAVE TO RELOAD. THIS IS THE UPPER SEGMENT DISPATCH TABLE FOR
;INTERNAL SYMBOLS.
;;#SM# 5-30-74 RLS CHECK FOR OVERFLOW OF DISPATCH TABLE
USE DSPCH ;A PC FOR VECTOR JRSTS
USE
?DSPBAS: BLOCK DSPLEN ;SPACE FOR THE JRSTS.
>;UP
SUBTTL %ALLOC -- Main Allocation Routine
DSCR %ALLOC
CAL JSP 16,%ALLOC
DES Processes space reqests, allocates the storage for stacks,
string space, etc. Sets certain universal environmental variables
The SPLNEK list, created by the LOADER from compiled requests, contains
REQUEST blocks. Space requests begin at location $SPREQ within each
block. The entries consist of two-word entries, viz:
-----------------------------
-- SPLNEK ptr -- | | next block | ---
-----------------------------
| |
| fixed LEAP allocation |
| data |
| |
| ... |
-----------------------------
$SPREQ: |OP1 |INDX | SIZe request |
|- - - - - - - - - - - - - - -|
| TEXt addr | RESult ADdRess| (if STDSPC --
----------------------------- see below)
|OP2 ... | etc. |
-----------------------------
| ... more ops ... |
-----------------------------
| 0 terminates |
-----------------------------
OP is a 12-bit field (0:11), whose bits are interpreted as:
0 STDSPC if 1, get TEX,RESADR spec from standard entry
indexed by INDX field -- this is only a 1-word wntry.
1 WNTADR requests that the address of the allocated core be
returned in the specified RESADR field. RESADR is
then incremented.
2 WNTEND requests that the address of the first word not in the
allocated area be placed in RESADR field. RESADR bumped.
3 WNTPDP requests that a PDP computed from address and length be
returned in like manner.
4 USRTB indicates that the RESADRs are indices into the user
table -- (GOGTAB) should be added before use.
5 MINSZ indicates that the size specified here should be REPLACED
by the first subsequent non-zero request (not ADDED).
Default value for this area -- anything overrides.
INDX is a 6-bit field (12:17) used if STDSPC to cause the address to be
obtained from a spec (with its own OP and addr words) built into GOGOL.
This allows push-down list, string space, etc., sizes to be requested by
object modules without knowing the locations of their descriptors.
The indices represent:
1 SYSPD System push-down list (P)
2 SYSSPD String push-down list (SP)
3 STRSP String space size.
SIZ replaces any previous request with MINSZ on. Otherwise, its value is
added to an accumulated size for this address. The final result will
specify the size of the area.
SIZ<0 causes current entry to be disregarded.
TEX is the address of an ASCIZ string describing the use of the area.
It is used when the user REENTERs to ask him how much space he wants.
A non-zero value means that no overriding is possible for this area.
These requests are accumulated on the stack in two-word entries as:
-----------------------------
$SPREQ: |OP1 |INDX | RESult ADdRess|
|- - - - - - - - - - - - - - -|
| TEXt addr | accum size |
-----------------------------
Inconsistencies in request bits are not likely to be detected.
%ALLOC first processes the entire list, collecting cumulative information
about each RESADR requested, summing the size requests (with mods as
described for MINSZ above). Then it allocates space for each requested
area, allowing the user to override each if he REENTERed, and if there
is TEXt for that area. It finishes by performing some useful but
uninteresting bookkeeping.
; Get a Stack to hold requests in
HERE (%ALLOC)
IMSSS<;HACK FOR MISERABLE IMSSS LOADER -- REMOVE WITH NEW LOADER
SETO 1, ;SET TO REMOVE PAGE
HRRZ 2,JOBREL ;THAT THE LOADER LEAVES
LSH 2,-11 ;WRITE PROTECTED
ADDI 2,1
HRLI 2,400000 ;THIS FORK
JSYS PMAP ;REMOVE
>;IMSSS
;;%BF% be sure the ERR below will work
SETZM .ERBWD ;INITIALIZE ERROR MESSAGES
MOVEI C,MINPDS ;ABOUT 64 WORDS
PUSHJ P,CORGET ;THIS USUALLY INITS THE USER TABLE
ERR <NO CORE FOR ALLOCATION>
PUSHJ P,PDPMAK ;A PUSH-DOWN POINTER
MOVE P,B ;DITCH THE ALLOC PDL
MOVEM B,PDL(USER) ;STORE TEMPORARILY
PUSH P,16 ;THE RETURN ADDRESS
ADD P,X22 ;ONE DUMMY ENTRY TO TERMINATE
SETZM -1(P) ;0 TERMINATES IT
; Loop to search the space request blocks
; Until further notice:
; T is ptr to next allocation block.
; T1 is ptr to next entry specification
; Q1 is modified T1 -- accounts for STDSPC specifications
; Q2 is incoming OP-size word
; A is ptr to next candidate stack list element
; Q3 and TEMP used to do RESADR search in already-requested stack list
MOVE T,SPLNEK ;LIST OF BLOCKS
MOVEM T,%SPL ;LINK BUILT-IN BLOCK EXPLICITLY
MOVEI T,%SPL ;ALLOCATE IT FIRST
;;%BR% ALLOW VERSIONS NOW
;;%AL1: MOVEI T1,$SPREQ(T) ;PTR TO FIRST REQUEST
;;%##% OUGHT TO INCLUDE THIS IN NEXT STANFORD COMPILER
JRST VEROK ;FORGET THE BUILTIN BLOCK
%AL1:
HLRZ TEMP,$CMVER(T) ;RUNTIME VERSION NUMBER
CAIE TEMP,(.VERSION & 777777000000)
SKIPE CONFIG ;DON'T DO FOR COMPILER
JRST VEROK
ERR <POSSIBLE COMPILED CODE-RUNTIME INCOMPATIBILITY.
CONTINUE IF YOU DARE>,1
VEROK:
MOVEI T1,$SPREQ(T)
;;%BR% ^
%AL2: SKIPN Q2,(T1) ;OP WORD
JRST NXTELT ;NO MORE THIS BLOCK
MOVE Q1,T1 ;SAVE ADDRESS OF REQUEST
TLNN Q2,STDSPC ;A BUILT-IN RESADR/TEXT?
AOJA T1,DRCT ; NO, GET IT HERE
; T1 incremented because 2-word entry -- Q1 still pnts to 1st word
; Here, there is only a 1-word entry -- the actual RESADR spec
; found by indexing into table.
LDB Q1,[POINT 6,Q2,17] ;THE INDEX
LSH Q1,1 ;2-WORD ENTRIES ALL
ADDI Q1,%STDLST ;HERE'S WHERE THEY LIVE
HLL Q2,(Q1) ;USE STANDARD BITS FROM HERE ON
TLZ Q2,MINSZ ;NEVER USED FOR MIN WHEN BY INDEX
; Now find the corresponding entry in the accumulated stack entries
; or add a new entry
DRCT: HRRZ Q3,1(Q1) ;ADDRESS OF RESULT
TLZE Q2,USRTB ;RESULT IN THE USER TABLE?
ADD Q3,GOGTAB ;YES
MOVEI A,-1(P) ;FOR SEARCH DOWN STACK
JRST %AL4 ;GO SEARCH
%AL3: CAIN Q3,(TEMP) ;SAME ADDR?
JRST %AL5 ;YES, UPDATE
SUBI A,2 ;BACK UP ONE
%AL4: SKIPE TEMP,(A) ;NEXT SAVED OP WORD
JRST %AL3 ;TRY THIS ONE
; First occurrence of this address, make a place for it
MOVEI A,1(P) ;BACK TO THE TOP
ADD P,X22 ;NEW ENTRY
SETZM (A)
SETZM 1(A) ;VIRGIN ENTRY
COMMENT
NMIN means MINSZ on in new spec, OMIN means it's on in stack spec
NSIZ mean that new size NEQ 0, OSIZ etc. -- then
NMIN and not OSIZ then OSIZ_NSIZ, OMIN_TRUE
NMIN and OSIZ then no change
not NMIN and NSIZ and OMIN then OSIZ_NSIZ, OMIN_FALSE
not NMIN and not NSIZ and OMIN then no change
not NMIN and not OMIN then OSIZ_NSIZ+OSIZ, OMIN_FALSE
In the sequel,
A pnts to current stack entry, T,T1,Q1 unchanged,
Q2 is NEWSIZ, will be accum SIZ and TEXt addr.
Q3 is NEWBITS,,RESADR, will be accumulated same.
TEMP will be old TEX,,SIZ word, LPSA old BITS,,ADR
%AL5: HLL Q3,Q2 ;NEW BITS,,RESADR
HRRES Q2 ;NEW SIZE
MOVE TEMP,1(A) ;OLD TEX,,SIZ
MOVE LPSA,(A) ;OLD BITS,,ADR
JUMPL Q2,AOJBAK ;NO ACTION ON NEGATIVE SIZE
TLNE Q3,MINSZ ;BEGIN THE HAIRY CASE STUDY
JRST INMIN ;MIN ON IN NEW
; NMIN
TLZN LPSA,MINSZ ;NMIN, OMIN? -- OMIN_FALSE
JRST ADDIT ;not NMIN and not OMIN, ADD
JUMPN Q2,%AL6 ;not NMIN and OMIN, NSIZ?
TLOA Q3,MINSZ ;not NMIN and OMIN and not NSIZ,
; NMIN_TRUE, NSIZ+OSIZ=OSIZ
%AL6: HLLZS TEMP ;not NMIN and OMIN and NSIZ,
; OSIZ_FALSE,NSIZ+OSIZ=NSIZ,NMIN_FALSE
JRST ADDIT ;not NMIN and OMIN, EITHER NSIZ OR OSIZ
; NMIN
INMIN: TRNE TEMP,-1 ;OSIZ?
TLZA Q3,MINSZ ;NMIN and OSIZ, OSIZ unchg, NMIN_FALSE
TLZA LPSA,MINSZ ;NMIN and not OSIZ, OSIZ_NSIZ, NMIN_TRUE
MOVEI Q2,0 ;NMIN and OSIZ again, OSIZ unchg over add
ADDIT: OR Q3,LPSA ;COLLECT BITS
ADD Q2,TEMP ;AND SIZE
TLNN Q2,-1 ;ANY TEXT ADDR?
HLL Q2,1(Q1) ;NO, GET FROM OLD IF ANY
MOVEM Q3,(A) ;PUT NEW AWAY
MOVEM Q2,1(A)
AOJBAK: AOJA T1,%AL2 ;NEXT ELEMENT THIS BLOCK
NXTELT: SKIPN T,(T) ;NEXT BLOCK IN ALLOC LIST?
JRST NOELT ;NO MORE.
LEP <
;; %AG% .! LEAPIS USED TO BE STORED IN $ITNO
SKIPL $GITNO(T) ;LEAP REQUESTED?
JRST %AL1 ;NO.
MOVE B,GOGTAB ;WILL PLAY WITH USER TABLE
SETOM HASMSK(B) ;SOMEONE WANTS LEAP.
>;LEP
JRST %AL1 ;CONTINUE DOWN ALLOC BLOCKS.
NOELT:
; SINCE SYSTEM!PDL ALREADY ALLOCATED AND IN USE, INCREMENT IT IF THE
; REQUEST EXCEEDS THE DEFAULT
MOVE TEMP,PDL(USER)
PUSH P,4(TEMP)
PUSH P,5(TEMP) ;MAKE SURE P-REQUEST ON TOP
SETZM 4(TEMP) ;AND THAT IT DOESN'T HAPPEN TWICE
; NOW ALLOCATE THE SPACES, GET OVERRIDES
SETZM %ALLCHR ;NO QUESTIONS YET
SKIPN %RENSW ;WAS THERE A REENTER?
JRST NONTR ; NO
TERPRI
PRINT <ALLOC? >
PUUO 0,B ;ASK LEADING QUESTION AND GET ANSWER
TERPRI
;; %AD% RHT ALLOW LOWER CASE 10/4/73
TRZ B,40 ; SO CAN USE LOWER CASE
CAIN B,"Y" ;YES?
SETOM %ALLCHR ;YES
CAIN B,"N" ;NO, BUT LET ME SEE IT?
AOS %ALLCHR ;RIGHT
SETZM %OCTRET ;WHEN ON, NO MORE ASKING
NONTR:
ALOC: SKIPN T,-1(P) ;WERE THERE ANY ENTRIES?
JRST DONEE ; MAYBE, BUT NONE LEFT
MOVS A,(P) ;SIZE, TEXT
TRNE A,-1
SKIPL %ALLCHR ;IF TEXT ADDR AND WANTS TO DO IT,
JRST NOASK ; MUST ASK QUESTIONS
PUUO 3,(A) ;PRINT IT
;;%AZ% DCS 12-1-73 (2-many) Enhance behavior of ALLOC sequence.
PRINT < (>
HLRZ C,A ;DEFAULT (+"REQUIRE"d) VALUE
DECPNT C ; "SYSTEM PDL (64) = "
PRINT <) = >
;;%AZ% (2-many)
PUSHJ P,DECIN
HRL A,C ;REPLACE REQUESTED SIZE BY OVERRIDE
NOASK: HLRZ C,A ;IN CASE NOBODY ELSE DID
JUMPE C,PRIN ;DON'T ALLOCATE 0 AREAS
HRRZ TEMP,T ;DEST ADDR
CAIE TEMP,PDL(USER) ;THE ONE AND ONLY?
JRST NOEXP ; NO
;THIS IS THE SYSTEM!PDL REQUEST -- IT MUST OVERLAY THE CURRENTLY
; ALLOCATED STACK
HRRZ B,PDL(USER) ;GET PREV INITIAL CORGET ADDRESS
CAIGE C,MINPDS ;MUST BE BIGGER
MOVEI C,MINPDS ; SO MAKE IT BIGGER
HRL A,C ;KEEP EVERYBODY UP TO DATE
ADDI B,1 ;CORGET ADDR
CAIG C,MINPDS
JRST PDPRET ;NO PROBLEM
SUBI C,MINPDS ;AMOUNT TO INCREASE BY
;;# # 4-28-72 DCS UPDATE P'S SIZE FIELD
HRLZ TEMP,C ;UPDATE P RIGHT NOW
SUB P,TEMP ;SIZE FIELD ONLY
;;# # 4-28
PUSHJ P,CORINC ;INCREMENT TO PROPER SIZE
ERR <DRYROT -- NO CORE FOR SYSTEM!PDL>
ADDI C,MINPDS ;TOTAL SIZE
JRST PDPRET
NOEXP: PUSHJ P,CORGET ;GET A BLOCK
ERR <NO CORE AT ALLOCATION>
PDPRET: TLNN T,WNTADR ;WANT THE ADDRESS STORED?
JRST .+3
MOVEM B,(T) ;YES, STORE IT
ADDI T,1
TLNN T,WNTEND
JRST NOND
MOVE D,C ;SIZE
ADD D,B ;END ADDR
MOVEM D,(T)
ADDI T,1
NOND: PUSHJ P,PDPMAK
TLNE T,WNTPDP
MOVEM B,(T) ;WANTS PDP
PRIN:
;;%AZ%.! DCS 12-1-73 (2-3) Enhance behavior of ALLOC Sequence.
;; Removed size printing code from here, moved it to (1-3) above
SUBJMP: SUB P,X22 ;SO MUCH FOR THAT ONE
JRST ALOC ;GET THE NEXT
DONEE: SKIPN %ALLCHR ;BLABBING?
JRST .+3 ; NO
TERPRI
TERPRI
SUB P,X44 ;PNT TO RETURN ADDRESS (DUMMY AND SYSPDL ENTRIES)
; FINAL BOOKKEEPING
SETZM %RENSW ;DON'T ASK EACH TIME
MOVE SP,SPDL(USER) ;STRING STACK POINTER
;;%BA% DCS 12-1-73 (1-1) New String Garbage Collector -- New initialization
;; \UR#30\ JRL (8-7-78) FOLLOWING USED TO BE MOVEI A,4 USE SYMBOLIC'S
MOVEI A,.HDRSIZ ;Update ST(USER) to include a .HDRSIZ-word
ADDB A,ST(USER) ; header, preceding ST(USER). Call new addr. "SPC".
HRLI A,(<POINT 7,0>) ;USER TABLE ENTRIES:
MOVEM A,TOPBYTE(USER) ; TOPBYTE _ POINT 7,SPC
HRRZM A,STLIST(USER) ; STLIST _ SPC
MOVE B,STTOP(USER) ; STINCR _ size(SPC)*5,,size(SPC)+.HDRSIZ
MOVEM B,.STTOP(A) ; STREQD _ size(SPC)/8*5,,size(SPC)/8
SUBI B,(A) ; REMCHR _ -(size(SPC)*5)+=15
MOVEM B,.SIZE(A) ;SPC's header entries:
SETZM .LIST(A) ; .LIST _ .NEXT _ 0
SETZM .NEXT(A) ; .SIZE _ size(SPC) (STTOP-new ST)
MOVEI TEMP,.HDRSIZ(B) ; .STTOP _ STTOP(USER)
HRRM TEMP,STINCR(USER)
LSH TEMP,-3
HRRM TEMP,STREQD(USER)
IMULI TEMP,5
HRLM TEMP,STREQD(USER)
IMULI B,5
HRLM B,STINCR(USER)
SUBI B,=15
MOVNM B,REMCHR(USER)
;;%BA% (1-1)
SKIPE CONFIG ;COMPILER?
SETOM SGLIGN(USER) ; YES, STRNGC AND FRIENDS MUST ALIGN STRINGS
HRROI TEMP,KTLNK
POP TEMP,KNTLNK(USER)
POP TEMP,SGROUT(USER)
POP TEMP,SETLNK(USER)
POP TEMP,SPLNK(USER)
POP TEMP,STRLNK(USER);TRANSFER LISTS TO USER TABLE
PUSHJ P,STCLER ;CLEAR OUT ALL STRINGS
MOVEI TEMP,7 ;INITIAL DIGS SETTING
MOVEM TEMP,DIGS(USER) ;FOR FLOATING POINT OUTPUT
MOVEI TEMP,CHANS(USER);IF CHNL HAS A VALID CHANNEL #,
HRLI TEMP,CHNL ; @CDBLOC(USER) REFERS TO ITS
MOVEM TEMP,CDBLOC(USER);CDB ADDR IN THE CHANS TABLE
SETZM XJBENB ; WHERE APR INTERRUPT ENABLINGS ARE REMEMBERED
SETZM %ERGO ;REINITIALIZE ERROR PRINTER
;;#HE# DCS 5-11-72 (2-2) MODIFY VERSION CHECKING, STORAGE METHODS
;;%BF% RHT ASK FOR BIGGER ERROR BUFFER
PUSH P,[=256]
PUSHJ P,ERMSBF
DEC<
;;=I09= NEED PPN FOR SFD DECODING
CALLI TEMP,24 ;GETPPN
MOVEM TEMP,MYPPN ;SAVE IN MAIN TABLE AREA
>;DEC
;;% % rht be sure small space guy is initialized if segment
REC <
UP <
SKIPN $FSLIS(USER) ;IF NOTHING ON $FSLIS THEN GET SOMETHING
PUSHJ P,$FSINI ;THERE
NRC <
PUSHJ P,$RCINI ;ALSO, INTIALIZE ALL RECORDS IN WORLD
>;NRC
>;UP
RGC <
;;**** QUAM, CHECK THIS ****
SETZM RECCHN ;CHAIN OF ALL RECORDS IN THE WORLD
SETZM RGCLST ;CHAIN OF USER-ADDED GC ROUTINES
>;RGC
>;REC
IFNDEF JOBVER,<EXTERNAL JOBVER>
MOVEI LPSA,SPLNEK ;For each element of the space
;;%AZ% DCS see just below
CHKVRS: SKIPN LPSA,(LPSA) ; list, if there is a non-zero
JRST ENDINT ; version request, use it (lh is
SKIPN TEMP,$VRNO(LPSA); SAIL version, rh is user version).
JRST CHKVRS ;But if there was a previous non-zero
HLL TEMP,JOBVER ; request, and if it is not the
EXCH TEMP,JOBVER ; same as this one, complain first.
TRNE TEMP,-1
CAMN TEMP,JOBVER
JRST CHKVRS
ERR <VERSION NUMBER MISMATCH>,1
JRST CHKVRS
;;#HE# (2-2)
;;%AZ% DCS moved this from SAILOR sequence
ENDINT: PUSHJ P,K.ZERO ;NZERO OUT THE COUNTERS
;;% % RHT ZERO OUT INCORE ALLOCATED VARIABLES & AVOID RESTART HASSLES
INIPDS: HRRZ A,PDLNK ;PD LINK
INI1PD: JUMPE A,INILST ;IF ANY PROCEDURES
HRRZ TEMP,PD.LLW+1(A);POINT AT LVI
HRRZ A,(A) ;NEXT ONE
JUMPE TEMP,INI1PD
PDLLL: MOVE LPSA,(TEMP) ;GET AN ENTRY
TLNN LPSA,740000 ;A 0 MEANS DONE
JRST INI1PD
TLNE LPSA,37 ;INDEX MEANS DO NOTHING
AOJA TEMP,PDLLL
LSH LPSA,-=32 ;ALL HAVE LEFT IS TYPE CODE
CAIE LPSA,10 ;A CLEANUP IS EXEMPT
CAIN LPSA,17 ;AS IS A BLOCK END
AOJA TEMP,PDLLL
SETZM @(TEMP) ;MAKE IT VIRGIN
AOJA TEMP,PDLLL ;
;;% %
INILST:
SKIPN TEMP,INILNK
POPJ P,
MOVE USER,GOGTAB ;JUST TO BE SURE
SKIPA A,[XWD -SYSPHS,0] ;XWD #SYS PHASES,0
DOPHS: HRRZ TEMP,INILNK ;LIST OF THEM
NXLNK:
PUSH P,TEMP ;SAVE LINK
NXIN: ADDI TEMP,1 ;LOOK AT NNEXT ENTRY
SKIPN B,(TEMP) ;END OF LINK LIST
JRST NXIN.1 ;YES
HLRZ C,B ;PHASE NUMBER OF THIS
CAIE C,(A) ;THIS PHASE
JRST NXIN ;NO
PUSH P,A
PUSH P,TEMP
PUSH P,USER
PUSHJ P,(B)
POP P,USER
POP P,TEMP
POP P,A
JRST NXIN ;GO DO NEXT IN THIS
NXIN.1: POP P,TEMP
HRRZ TEMP,(TEMP)
JUMPN TEMP,NXLNK
NXPHS: AOBJN A,DOPHS ;GO ON TO NEXT PHASE
POPJ P, ;
HERE(.UINIT)
MOVE A,[XWD -USRPHS,400000] ;DO USER PHASES
;; #KV# MAKE SURE LINK NON-NULL
SKIPN INILNK
POPJ P,
;; #KV#
JRST DOPHS
PDPMAK: MOVNS C
SUBI B,1 ;PDP
HRL B,C
POPJ P,
>;NOLOW
COMMENT Utility Subroutines for allocation
DECIN:
OCTIN: AOS (P)
SKIPE %OCTRET ;IMMEDIATE RETURN?
POPJ P, ; YES
SETZB C,D
;;%AZ% DCS 12-1-73 (3-3) Enhance behavior of ALLOC sequence
;; Use line mode input, remove inferior line-editing code.
OCTIN1: PUUO 4,B ; ;; INCHWL, was 0,B (INCHRW)
;; Removed rubout, ctrlo check
;;!HOOK! May need to put some back in for TENEX
CAIN B,175 ;ALTMODE?
JRST SETRET
CAIN B,12 ;LINE FEED?
JRST EPOP ;YES
CAIL B,"0"
CAILE B,"9" ;I KNOW IT'S CALLED OCTIN,
JRST OCTIN1 ; BUT INPUT IS IN DECIMAL!!
SETOM D ;FOUND SOMETHING LIKE A NUMBER
IMULI C,=10 ;GOOD OLD NUMBER CONVERSION
ADDI C,-"0"(B)
JRST OCTIN1 ;THIS IS A LOOP
SETRET: SETOM %OCTRET ;WILL RETURN IMMEDIATELY HENCEFORTH
TERPRI
EPOP: SKIPE D ;FIND ANYTHING?
SOS (P) ;YES
CPOPJ: POPJ P,
;; Removed rubout, ctrlo code from here
;;%AZ% (3-3)
SUBTTL %UUOLNK -- UUO Handler (Dispatch Vector Just Below)
NOLOW < ;INCLUDE IN UPPER SEGMENT.....
HERE(%UUOLNK)
UUOCON: PUSH P,FF ;SAVE REGISTER 0
PUSH P,A ;AND REGISTER 1
MOVE FF,@JOBUUO ;ARGUMENT BEFORE CLOBBERING AC'S
LDB A,[POINT 9,JOBUUO,8] ;GET OP CODE.
; TRNE A,777760 ;SEE IF IN RANGE
; JRST ILLUUO ;ILLEGAL
JRST @UUOTBL(A) ;DISPATCH TO CORRECT ROUTINE.
RETM: POP P,D ;RESTORE SAVED AC'S
POP P,C
POP P,B
USRXIT: POP P,A
POP P,FF ;RESTORED AC'S
POPJ P, ;AND RETURN!
SAVM: PUSH P,B ;SAVE AC'S -- CALLED WITH JSP 0
PUSH P,C
PUSH P,D ;ENUF
PUSH P,[RETM]
JRST @FF ;RETURN
;;%BI% THESE TWO GENERALLY USEFUL ROUTINES ADDED WHEN RUUO ADDED
SAVALL: PUSH P,2 ;SAVES ACS 2-15 (ASSUMES 0,1 TOP 2 ELTS)
HRLZI 2,-13 ;NUMBER LEFT TO SAVE
PUSH P,3(2) ;SAVE AN AC
AOBJN 2,.-1 ;COUNT DOWN
PUSH P,[RSTALL] ;POPJ WILL FALL INTO RSTALL
JRST @FF ;RETURN
RSTALL: HRLZI 15,-15(P) ;ASSUMES STACK HAS (RETADR, ACS 0-15)
BLT 15,15 ;RESTORE THE ACS
SUB P,[XWD 16,16] ;GIVE BACK THE SPACE
POPJ P, ;RETURN
;;%BI%
; UUO TABLE
UUOTBL: JRST ILLUUO ;0
JRST ILLUUO ;1
JRST FLOAQ ;2 -- FLOAT A NUMBER
JRST FIXQ ;3 -- FIX A NUMBER
JRST IOERRR ;4 -- I/O ERROR
JRST ERRR ;5 -- STANDARD ERROR UUO
;;%CJ% (1/MANY) JFR 7-18-75
JRST PNQSPL ;6 -- SIXBIT PRINT
JRST ARERRR ;7 -- ARRAY ERROR
;;%BI% ! ADDED A UUO
JRST RUUO ;10 -- RECUUO
JRST PNQSPL ;11 -- PRINT DECIMAL NUMBER
JRST PNQSPL ;12 -- PRINT OCTAL NUMBER
JRST SPLERR ;13 -- ERROR UUO WITH SPLICE PARAM LIST
;;%CJ% ^
;;%DU% ! JFR 11-26-76
JRST SNGLQ ;14 -- ROUND LONG REAL TO REAL
JRST PRINIT ;15 -- HANDLE TERMINAL
;;%DV% 2! JFR 11-26-76
FOR III_16,37,1<
JRST ILLUUO > ;THE REST OF THE LUUO'S
HERE($PDLOV) ;PLACE TO COME WHEN A STACK
MOVEI TEMP,TEMP ;IS EXHAUSTED.
POP TEMP,TEMP ;THIS WILL CAUSE PDLOV
JRST (USER) ;RETURN IF USER CAN.
;;%CJ%
PNQSPL: JSP FF,SAVM ;B,C,D
;;#XD# 1! JFR 6-17-76 USED TO BE -6(P) TYPO
MOVEI B,-5(P)
HRRZ A,JOBUUO ;EFFECTIVE ADDR
CAIG A,D ;MUST RELOCATE IF SMALL
ADDM B,JOBUUO
LDB A,[POINT 9,JOBUUO,8] ;OP CODE FIELD
MOVEI A,-6+[ ASCIZ/@F/ ;SIXBIT
0 ;HOLE FOR ARERR
0 ;HOLE FOR RUUO
ASCIZ/@D/ ;DECIMAL
ASCIZ/@B/](A) ;OCTAL
MOVEI B,-1+URTBL2+2 ;WHAT TO PRINT (PWORD @JOBUUO)
JRST SPLPRT
SUBTTL SPLICE -- A FANCY STRING MAKER
;calling sequence
;
; MOVEI A,[ASCIZ /control string/]
; MOVEI B,-1+[ POINT first arg
; :
; POINT last arg]
; MOVSI C,-1-max chars allowed
; MOVE D,output byte pointer
; PUSHJ P,SPLICE
; ;if A is a complete byte pointer, PUSHJ P,SPLICE+1
;
;returns
;
; C has been AOBJ'ed once per character that would have been
; written (and has, if C<0)
; D is updated byte pointer
;
;uses only A,B,C,D,P. recursive number printer saves + restores FF
;
;control string:
;
; all characters except "@" are copied to output string;
; when a "@" is seen, the next character is interpreted as
; a control code, and the corresponding argument is converted to
; string and appended to the output.
;
; char interpretation of argument
; @ "@"
; A ASCIZ
; B Binary (octal) value
; C Character
; D Decimal value
; E 5 char ASCII word (E=5), trailing nulls ignored
; F SIXBIT (F=6), leading and trailing blanks ignored
; G PPN; null string for arg=0, else includes []
; H ASCII string until break char; break char is
; specified as next arg, also breaks on null char
; I SAIL string; arg pointer is to word 2 of string descr
; J address of call corresponding to a PUSHJ return word
; other copy char to output and proceed
;
; Byte pointers for arguments point to values, except for codes
; H,I which point to byte pointers, and A which points to
; an address.
;
;Space (size of code, AC usage) is more important than time
HEREFK(SPLICE,SPLIC.)
HRLI A,440700 ;make byte pointer
PUSH P,A ;input byte pointer
PUSH P,B ;addr of argument pointers
SPL.1: ILDB A,-1(P) ;char
JUMPE A,SPLDON ;ASCIZ control
CAIN A,"@"
JRST SPLPRM ;a parameter
SPL.C: PUSHJ P,SPLDPB ;deposit and count
JRST SPL.1
SPLPRM: ILDB A,-1(P) ;type code
CAIL A,"A" ;check bounds
CAILE A,"J"
JRST SPL.C ;out of bounds or second @
MOVEI B,(A)
AOS A,(P) ;addr of next arg pointer
LDB A,(A) ;arg value
JRST @.-"@"(B) ;select proper routine
FOR @& TYP E <ABCDEFGHIJ> <
SPL.&TYP >
SPLDON: SUB P,[2,,2] ;pushes done at start
POPJ P,
SPL.A: SETZ B, ;break only on null
HRLI A,440700 ;supply left half of byte pointer
JRST SPL.HA
SPL.B: TLNN A,-1 ;anything in left half?
JRST SPL.B1 ;no
MOVEM A,%ALLCHAR ;yes, save value
MOVEI A,[ASCIZ /@B,,@B/] ; and recurse!
SPLREC: MOVEI B,-1+[ PLEFT %ALLCHAR
PRIGHT %ALLCHAR]
SPLRC1: PUSHJ P,SPLICE
JRST SPL.1
SPL.D: JUMPGE A,SPL.D1 ;FRNP only works for positive values
MOVM B,A ;get absolute value
MOVEI A,"-"
PUSHJ P,SPLDPB
MOVE A,B ;value in A
SPL.D1: PUSH P,[=10]
JRST .+2
SPL.B1: PUSH P,[10]
EXCH FF,(P) ;stack old FF, radix into new FF
PUSHJ P,SPLFRN
POP P,FF ;retrieve FF
JRST SPL.1
SPLFRN: IDIV A,FF ;recursive number printer
HRLM B,(P)
JUMPE A,.+2
PUSHJ P,SPLFRN
HLRZ A,(P)
ADDI A,"0"
SPLDPB:
NOSTANFO<
CAIN A,30 ;Stanford underbar
MOVEI A,"!" ;into exclamation
CAIN A,33 ;not equal [ASCII escape]
MOVEI A,"#" ;into hash
>;NOSTANFO
AOBJP C,.+2 ;no room left
IDPB A,D ;unload char
POPJ P,
SPL.E: LSHC A,-=36 ;5 char ASCII in B, 0 in A
ANDCMI B,1 ;clear line number bit
JUMPE B,SPL.1 ;ignore trailing blanks
LSHC A,7 ;char from B into A
PUSHJ P,SPLDPB
JRST .-3
SPL.F: LSHC A,-=36 ;SIXBIT into B, 0 into A
JUMPE B,SPL.1 ;ignore trailing blanks
LSHC A,6 ;char from B into A
JUMPE A,.-1 ;ignore leading blanks
ANDI A,77
ADDI A,40 ;convert to ASCII
PUSHJ P,SPLDPB
JRST SPL.F+1
SPL.G: JUMPE A,SPL.1 ;0 PPN is null string
TYMSHR <TLNN A,-1
JRST TYSPPN ;SPECIAL USER NAME
>;TYMSHR
SFDS<
;;=I10= PRINT THE PATH IF PPN IS A POINTER
TLNN A,777777 ;IF LH NON-ZERO, REAL PPN
JRST SPL.G1 ;ELSE PATH POINTER, PRINT PATH
> ;SFDS
MOVEM A,%ALLCHAR ;recurse
NOCMU<
IFN SIXSW,<
MOVEI A,[ASCIZ /[@F,@F]/] ;sixbit ppn
>;IFN SIXSW
IFE SIXSW,<
MOVEI A,[ASCIZ /[@B,@B]/] ;octal ppn
>;IFE SIXSW
JRST SPLREC
>;NOCMU
CMU<
MOVE A,[%ALLCHAR,,%ALLCHAR]
DECCMU A,
JRST SPL.1 ;error in converting ppn
MOVEI A,[ASCIZ /[@A]/]
MOVEI B,-1+[ PWORD <[IPCHAR %ALLCHAR]>]
JRST SPLRC1
>;CMU wierdos
SFDS<
;;=I10= CODE TO PRINT PATHS. MAY CONTAIN TYPOS
SPL.G1: MOVEI A,2(A) ;GET ADDRESS OF PPN PART
PUSH P,A ;AND SAVE IT FOR REST OF PATH
MOVE A,(A) ;GET ACTUAL PPN
MOVEM A,%ALLCHAR ;AND PRINT IT
MOVEI A,[ASCIZ /[@B,@B/] ;NOTE NO CLOSE BRACKET YET
MOVEI B,-1+[PLEFT %ALLCHAR
PRIGHT %ALLCHAR]
PUSHJ P,SPLICE ;RECURSE
SPL.G2: AOS A,0(P) ;MOVE ON TO NEXT SFD NAME
MOVE A,(A) ;GET THE NAME ITSELF
JUMPE A,SPL.G3 ;IF NONE, PATH DONE - PATH HAS TO END IN ZERO
MOVEM A,%ALLCHAR ;AND PRINT IT
MOVEI A,[ASCIZ /,@F/] ;SIXBIT
MOVEI B,-1+[PWORD %ALLCHAR]
PUSHJ P,SPLICE ;RECURSE
JRST SPL.G2 ;SEE IF MORE SFD'S
SPL.G3: MOVEI A,[ASCIZ /]/] ;HERE AFTER ALL SFD'S DONE, PRINT CLOSE BRAK.
PUSHJ P,SPLICE ;RECURSE
POP P,A ;RESTORE STACK (RESULT NOT NEEDED - "A" IS JUST BIT BUCKET HERE)
JRST SPL.1 ;DONE WITH PATH, GO ON
> ;SFDS
;;=I10= ^^
SPL.H: AOS B,(P) ;addr of b.p. to break char
LDB B,(B) ;break char
SPL.HA: PUSH P,A ;b.p. to input
SPL.H2: ILDB A,(P) ;char
JUMPE A,SPL.H1 ;break on nulls
CAIN A,(B) ;or break chars
JRST SPL.H1 ;broken
PUSHJ P,SPLDPB
JRST SPL.H2
SPL.H1: POP P,A
JRST SPL.1
SPL.I: MOVE B,@(P) ;POINT 36,word2
MOVEI B,@B ;addr of word2; POINT could use indexing
HRRZ B,-1(B) ;char count
PUSH P,A ;SAIL b.p.
JUMPE B,SPL.H1 ;done
ILDB A,(P)
PUSHJ P,SPLDPB
SOJGE B,.-3
SPL.J: MOVEI A,-1(A) ;called from addr of PUSHJ return word
JRST SPL.B
TYMSHR <
TYSPPN: HRLI A,(<POINT 6,0>)
MOVEM A,%ALLCHAR
MOVEI A,"("
PUSHJ P,SPLDPB
MOVEI B,=12
PUSH P,[0]
TYSPPL: ILDB A,%ALLCHAR
JUMPE A,[AOS (P)
JRST TYSPP2]
SKIPG (P)
JRST TYSPP3
TYSPP4: MOVEI A," "
PUSHJ P,SPLDPB
SOSLE (P)
JRST TYSPP4
LDB A,%ALLCHAR
TYSPP3: ADDI A,40
PUSHJ P,SPLDPB
TYSPP2: SOJG B,TYSPPL
POP P,A
MOVEI A,")"
PUSHJ P,SPLDPB
JRST SPL.1
>;TYMSHR
;; RUUO -- RECORD HANDLER UUO ROUTINE
;;%BI%
^RUUO:
NONRC <
LDB A,[POINT 4,JOBUUO,=12] ;AC FIELD IS THE MINOR OPCODE
NORGC <
CAILE A,RDLAST ;
JRST USRUUO ;DEFAULT CASE IS USRUUO
JUMPN A,@RDISP(A) ;DISPATCH
RDREF: SKIPE A,FF ; DE-REFERENCE -- DO WE HAVE A RECD?
SOSLE -1(A) ; DROP COUNT BY ONE
JRST USRXIT ; GO EXIT FROM UUO LEVEL
UINCUU: AOS -1(A) ; SINCE WILL DO DEREFERENCING SOS AGAIN
; OTHERWISE, FALL INTO USRUUO
; (ACTUAL DELETION WILL BE SLOWED UP A BIT, SINCE WILL DO
; YET ANOTHER SOSLE & WILL WASTE SOME EFFORT WITH EXTRANEOUS PUSHES
; BUT THIS DOES MAKE THE CODE A BIT MORE MODULAR)
>;NORGC
RGC <
CAIG A,RDLAST ;ONE WE CAN DISPATCH ON ??
JRST @RDISP(A) ;YES
;NO, CALL THE HANDLER
>;RGC
USRUUO: MOVE A,FF ;A GETS THE RECORD ADDRESS
JSP FF,SAVALL ;SAVE ALL THOSE ACS
USRUUX: LDB FF,[POINT 4,JOBUUO,=12] ;GET MINOR OP AGAIN
UCALL0: PUSH P,FF ; OP CODE
PUSH P,A ; RECORD ID
PUSH P,[0] ; A PLACE HOLDER
PUSHJ P,@(A) ; CALL THE USER ROUTINE (POSSIBLY $REC$)
POPJ P,
USRUU1: MOVE A,FF ;LIKE USRUUO BUT RETURNS AC1
JSP FF,SAVALL ;SAVE SOME ACS
PUSHJ P,USRUUX ;DO THE REST
MOVEM A,-15(P) ;WHERE AC1 IS STORED ON THE STACK
POPJ P, ;RETURN WILL FALL INTO RSTALL
;;DISPATCH TABLE FOR RECUUO OP,ADR
;;
RDISP:
NORGC <
JRST RDREF ;0 -- DEREFERENCE E.G RECUUO 0,RECVAR
JRST USRUU1 ;1 -- ALLOCATE: E.G RECUUO 1,[CLASSID]
JRST UINCUU ;2
>;NORGC
RGC <
JRST USRUUO ;0 -- DEREFERENCE (ACTUALLY AN ERROR)
JRST USRUU1 ;1 -- ALLOCATE: E.G RECUUO 1,[CLASSID]
>;RGC
RDLAST __ (.-RDISP)-1
;;%BI%
>;NONRC
NRC <
ERR <RECUUO CALLED IN NEW RECORD SYSTEM. RECOMPILE.>,1
POPJ P,
>;NRC
DSCR FIX, FLOAT UUO'S (FIXQ,FLOAQ,SNGLQ)
PAR MOVE FF,ARG ; JRST FIX/FLOA Q; RET VIA USRXIT
RES FIXED POINT EQUIVALENT IN AC SPECIFIED IN AC FIELD OF UUO
FIXQ: MULI FF,400 ;THIS ALGORITHM STOLEN FROM F4.
TSC FF,FF
EXCH FF,A
ASH FF,-243(A)
JRST FXFLT ;STORE IN RIGHT PLACE.
FLOAQ: IDIVI FF,400000
SKIPE FF
TLC FF,254000
TLC A,233000
FAD FF,A
FXFLT: LDB A,[POINT 4,JOBUUO,12] ;RESULT REGISTER
CAIG A,1 ;NUMBER OF AC'S SAVED
ADDI A,-1(P) ;ADJUST TO FIND STACK SPOT
MOVEM FF,(A) ;AND RETURN RESULT
JRST USRXIT ;AND RETURN TO USER
;;%ZA% PMF 2-27-77 Rewrote this damn thing. Problem with returning overnormalized
;;numbers.
;Double to single floating pt. conversion routine.
SNGLQ: PUSH P,B
HRRZ A,JOBUUO ;E
JUMPN A,.+2
MOVEI A,-2(P) ;E=0, BOTH WORDS HAVE BEEN PUSHED
MOVE A,1(A) ;FETCH 2ND WORD
TLZ A,400000 ;REMOVE IT'S SIGN BIT JUST IN CASE
MOVSI B,777000 ;GET THE EXPONENT
AND B,FF
TLNE B,400000 ;NEGATIVE?
TLC B,777000 ;YES - COMPLEMENT THE EXPONENT
ADD B,[745000,,0] ;GET EXPONENT - =27
TLNE B,400000 ;UNDERFLOW?
JRST [ ASH B,-33 ;YES
LSH A,-10(B) ;UNNORMALIZE A (WITH EXPONENT = -200)
JRST SNGLQ1]
LSH A,-10 ;GET THE FRACTION RIGHT
IOR A,B ;AND PUT IN THE EXPONENT
SNGLQ1: FADR FF,A ;AND ADD TO ROUND AND NORMALIZE
POP P,B
JRST FXFLT
;;%ZA% ^
DSCR PRINIT -- INTERFACE TO SYSTEM PRINTING FACILITIES
INCLUDED HERE TO MAKE INTERCEPTION EASY FOR WHATEVER
PURPOSE AND TO MAKE CONVERSION TO TENEX EASY
PRINIT: ;IF NOT ASSEMBLED, FALL INTO ILLUUO
TENX <
LDB A,[POINT 4,JOBUUO,12]
HRRZ FF,JOBUUO
TRNN FF,777776 ;IF ADDR. IS FF OR A GET ARG AND/OR
ADDI FF,-1(P) ;PUT ANSWER ON STACK WORD FOR FF OR A
JRST @.+1(A)
;TTCALL DISPATCH TABLE
JRST TTC0 ;get a character (wait)
JRST TTC1 ;output a character
JRST TTC2 ;if character pending, get it and skip
;else noskip
JRST TTC3 ;output an asciz string
JRST TTC4 ;same as 0
JRST TTC5 ;same as 2
JRST ILLUUO
JRST ILLUUO
JRST ILLUUO
JRST TTC11 ;flush input buffer
JRST TTC12 ;flush output buffer
JRST TTC13 ;skip if characters pending
JRST TTC14 ;same as 13
JRST ILLUUO
JRST ILLUUO
JRST ILLUUO
TTC4: ;EFFECTIVELY SAME AS TTC0 GIVEN 10X WAKEUP BEHAVIOR
TTC0: MOVEM B,TTCSVB ;SAVE B.
TTC01: HRRZI 1,100 ;B34 of RFMOD word returned in 2 says
JSYS RFMOD ;that BKJFN has been done since last char was
JSYS PBIN ;read, i.e. this PBIN will get a re-run. This is
CAIN 1,37 ;best EOL-to-CRLF conversion hack I can devise.
JRST TTCEOL ;It's impossible to stick a linefeed back in
TTC0RT: MOVE B,TTCSVB ;tty input buffer IN FRONT OF extant type-ahead.
MOVEM A,@FF
JRST USRXIT ;Returning just CR causes SAIL to look for non-
TTCEOL: TRNE 2,2 ;existent LF following. And setting a flag loses
JRST TTC0BK ;when some random other code does a PBIN. This
HRRZI 1,100 ;way, random other code gets a 37 too (Oh well).
JSYS BKJFN ;but at least the pending LF is cleared (since
JFCL ;the BKJFN bit is cleared). This code returns a
HRRZI A,15 ;CR on first reading of EOL and a LF on second.
JRST TTC0RT
TTC0BK: HRRZI A,12 ;Second reading of eol here.
JRST TTC0RT ;"flag" is effectively cleared by PBIN.
TTC1: HRRZ 1,@FF
JSYS PBOUT
JRST USRXIT
TTC2: ;Effectively same as TTC 5.
TTC5: HRRZI A,100
MOVEM B,TTCSVB ;SAVE B - NEW SIBE: B_CNT OF CHRS WAITING IF ANY
JSYS SIBE
AOSA -2(P) ;Get char and skip return
JRST USRXIT ;NOSKIP, NO CHAR, B UNCHANGED
JRST TTC01
TTC3: HRRO 1,FF
JSYS PSOUT
JRST USRXIT
TTC11: HRRZI 1,100
JSYS CFIBF
JRST USRXIT
TTC12: HRRZI 1,101
JSYS CFOBF
JRST USRXIT
TTC13:
TTC14: HRRZI A,100
JSYS SIBE
AOS -2(P) ;CHAR HAS BEEN TYPED, SKIP RET (BUT
;DON'T READ ANYTHING IN)
JRST USRXIT ;NOTHING, NOSKIP.
;This emulates DECUS's SKPINC & SKPINL. Stanford's TTCALL 14,
;is different. I have found one instance of its use (at PARSE&LINSTOP)
;which as far as I could tell wouldn't work on EXPORT systems,
;so I put that under a STANFO switch.
>;TENX
NOTENX <
IFN 0,<
MOVE A,FF ;SAVE ARGUMENT
JSP FF,SAVM ;GET MORE AC'S
LDB C,[POINT 4,JOBUUO,12]
JRST @PTBL(C)
PTBL: GCH ;0 -- GET A CHAR
PCH ;1 -- PRINT A CHAR
0
PST ;3 -- PRINT A STRING
PST: TTCALL 3,@JOBUUO ;CALL SYSTEM
POPJ P,
PCH: TTCALL 1,A ;PRINT CHAR
POPJ P,
GCH: HRRZ B,JOBUUO ;GET EFF ADDRESS
CAIG B,D
ADDI B,-5(P) ;RELOCATE INTO STACK.
TTCALL 0,(B) ;AND READ A CHAR
POPJ P,
>;0
>;NOTENX
DSCR ERROR UUOS
PAR AC FIELD IS INDEX INTO ERROR ROUTINE
SID SAVES THE WORLD
DES THE ASCIZ STRING INDICATED BY THE EFFECTIVE ADDRESS IS TYPED. THEN
THE ERROR ROUTINE INDICATED BY THE AC FIELD IS EXECUTED.
IF `GO' IS NOT ON, THE USER IS ALLOWED TO RESPOND WITH ONE OF SEVERAL
ALTERNATIVES. ONE ALTERNATIVE IS CONTINUATION IF THE AC FIELD OF THE
UUO WAS ODD. OTHERWISE, NO CONTINUATION IS POSSIBLE. THE ACS AT THE
TIME OF CALL ARE RESTORED IF CONTINUATION OR `DDT' IS CHOSEN.
ILLUUO:
;;%BL%
SKIPN .UUOCN ;DID THE USER GIVE US SOMETHING ELSE TO TRY
JRST .ILL. ;NOPE, MUST BE AN ERROR
POP P,A ;GET BACK TO A MORE VIRGINAL STATE
POP P,FF ;NOW ALL ACS ARE BACK (P IS ONE TOO DEEP, BUT...)
XCT .UUOCN ;
POPJ P,
.ILL.: MOVE A,[ERR <Illegal UUO>]
MOVEM A,JOBUUO
ERRR: JSP FF,SAVM ;SAVE MORE AC'S
LDB D,[POINT 4,JOBUUO,12] ;CODE IN AC FIELD
JRST ERRW
ARERRR: JSP FF,SAVM ;SAVE MORE AC'S
;;%CK% JFR 7-19-75 ALLOW THE EFFECTIVE ADDR OF ARERR TO BE EITHER WD1 OR WD2
;;OF A STRING CONSTANT. THE COMPILER SEEMS TO PREFER WD1, BUT WD2 IS BETTER
;;FOR ARERR 1,["ARRNAM"] USE FROM START!CODE
LDB A,[POINT 6,@JOBUUO,11] ;SIZE FIELD OF A BYTE POINTER
CAIE A,07 ;THE NORMAL VALUE FOR STRINGS?
AOS JOBUUO ;NO, POINT TO WD2
MOVSI B,4 ;PRINTING INSTRUCTIONS
MOVEI D,20 ;ERROR CODE -- FATAL
JRST ERRX
IOERRR: JSP FF,SAVM ;SAVE MORE AC'S
MOVEI D,16 ;ERROR CODE -- FATAL
ERRW: MOVEI B,0
ERRX:
MOVEI A,[BYTE (7) 15, 12, "@", "A"] ;BEGIN WITH CRLF
HRRI B,-1+[PRIGHT JOBUUO] ;JOBUUO HAS ADDR OF ASCIZ
ERRY: ROT D,-1 ;CONTINUE BIT TO SIGN BIT
MOVEM D,%RECOV ;AND SAVE FOR TESTING LATER
MOVE C,-6(P) ;RETURN ADDRESS
MOVEM C,.DTRT. ;SAVE AS DDT RETURN ADDRESS
;;%DW% JFR 12-8-76 MAKE P WORK IN RAID
IFN STANSW!UORSW,< IFNDEF JOBOPC,<EXTERNAL JOBOPC>
MOVEM C,JOBOPC
>;IFN STANSW!UORSW
;;%CJ% JFR 7-18-75
LDB C,[POINT 4,-2(C),12] ;AC FIELD OF PRECEDING INSTR
CAIG C,D ;IF IN SAVED ACS,
ADDI C,-5(P) ; RELOCATE
MOVEM C,%ALLCHAR ;SAVE ADDRESS
MOVE C,GOGTAB ;NOW DO SAME THING FOR ADDR IN UUO1
HRRZ C,UUO1(C) ;ADDR+1 OF LAST CALL
CAIL C,2 ;TRY TO PREVENT ILL MEM REFS
LDB C,[POINT 4,-2(C),12]
CAIG C,D
ADDI C,-5(P)
MOVEM C,%OCTRET
PUSHJ P,.ERSWD ;SETUP ERROR COUNT AND OUTPUT B.P.
TLZN B,4 ;DON'T PRINT NOW FOR ARERR
PUSHJ P,SPLICE ;DO FIRST PART
MOVE B,%RECOV ;WHAT TO DO NOW
MOVEI A,URTBL1(B) ;WHAT TO PRINT NEXT
MOVEI B,URTBL2-1(B) ;WITH WHAT PARAMS
PUSHJ P,SPLICE
MOVEI A,[BYTE (7) 15,12] ;END MESSAGE WITH CRLF
PUSHJ P,SPLICE
JUMPL C,.+3 ;IF RH(C) HAS CORRECT COUNT
LDB C,[POINT 13,.ERBWD,12] ;ELSE USE MAX
MOVEI C,-1(C) ;MINUS 1 FOR ZERO BYTE
HRRZM C,.ERSTC ;CHAR COUNT
SETZ B,
IDPB B,D ;ASCIZ
MOVEM D,.ERSTP ;UPDATED BYTE POINTER
;#PU# ACCUMULATOR D WAS NOT ZERO FOR ORDINARY ERRORS.
SKIPE D,%ERRC ;IF USERRR LEFT A POINTER
JRST [MOVE D,1(D) ;GET BYTE POINTER
ILDB D,D ;GET FIRST RESPONSE CHARACTER
JRST .+1]
SKIPN .ERRP. ;DOES USER HAVE A ROUTINE?
JRST NOUSRR ;NO
MOVE C,[XWD D-15,D+1] ;AOBJN POINTER TO DO PUSHES
PUSH P,(C) ;PUSHES WILL CAUSE PDLOV
AOBJN C,.-1 ;COUNT DOWN
;CAN BLT OFF
MOVE USER,GOGTAB
MOVE C,[XWD -13,RACS] ;ALSO SAVE RUNTIME AC'S
ADDI C,(USER) ;RELOCATE
PUSH P,(C)
AOBJN C,.-1
PUSH P,UUO1(USER) ;SAVE RUNTIME RETURN ADDRESS
SETZM .ERRJ. ;ASSUME NO USER TRANSFER ADDRESS
MOVE A,-33(P) ;UUO RETURN ADDRESS
SUBI A,1
PUSH P,SP ;SAVE STRING STACK POINTER (OR,
;IF COMPILER, MAYBE PARSER STACK)
SKIPL CONFIG ;IF IN COMPILER, GENERATE
JRST .+4
MOVEI SP,(P) ;A FAKE STACK BECAUSE OF CONFLICT
HRLI SP,-5 ;WITH PARSE STACK
ADD P,X44
PUSH P,A ;ADDR OF UUO = ARG TO PROC.
PUSH SP,.ERSTC ;CHAR COUNT
;;%BF% -- also not too sure strngc likes indirects, so ...
MOVEI A,@.ERBWD
HRLI A,(<POINT 7,0>) ;MAKE UP THE BYTE PTR
PUSH SP,A
;;%BF%
SKIPN A,%ERRC ;TRACKS LEFT BY USERRR??
MOVEI A,[0
0] ;NO
PUSH SP,(A)
PUSH SP,1(A)
PUSHJ P,@.ERRP.
SKIPGE CONFIG ;IF IN COMPILER, THEN
SUB P,X44 ;BACK UP THE STACK.
POP P,SP ;RESTORE STRING STACK.
MOVE USER,GOGTAB
POP P,UUO1(USER) ;RESTORE THINGS
MOVSI C,-12(P) ;FROM
HRRI C,RACS(USER) ;TO
BLT C,RACS+12 ;RESTORE RACS
SUB P,[XWD 13,13] ;ADJUST STACK
HRLZI FF,D+1-15(P) ;FROM HERE ON STACK
HRRI FF,D+1 ;FIRST AC TO RESTORE
BLT FF,15 ;GET THEM BACK
SUB P,[XWD 15-D,15-D] ;ADJUST
MOVEM A,D ;SAVE PRINTING INSTRUCTIONS
SKIPE B,.ERRJ. ;IF USER SPECIFIED RETURN ADDRESS
MOVEM B,-6(P) ;REPLACE CURRENT ONE.
NOUSRR:
TLZN D,1 ;IF INHIBITED,
;;%BF%
PUUO 3,@.ERBWD ;PRINT ERROR STRING.
MOVE A,-6(P) ;RETURN ADDRESS
PUSH P,D
TLZN D,2 ;IF NOT INHIBITED,
PUSHJ P,CALLEDFROM ;PRINT SAIL MESSAGE
POP P,D
MOVEI D,(D) ;ONLY THE CHAR, PLEASE
SETZM %ERRC ;NO MORE USERRR SPEC.
PUSHJ P,WATNOW ;GO GET A RESPONSE.
MOVEM A,-6(P) ;REPLACE RETURN ADDRESS
POPJ P,
HERE(DT.RET) ;JRST HERE TO GET BACK FROM DDT
JRST @.DTRT. ;GONE.
DSCR WATNOW -- ROUTINE TO GET AND PROCESS USER RESPONSES.
PAR RECOV IS >0 IF RECOVERY IMPOSSIBLE, <0 IF RECOVERY POSSIBLE
D,IF NON ZERO, HAS A RESPONSE CHARACTER IN IT.
RES RETURNS TO CALLER+1 IF TO GO TO DDT OR EXIT. IN THIS
CASE, AC 'A' HAS A NEW RETURN ADDRESS
RETURNS TO CALLER+2 IF USER SAID 'CONTINUE'
SID CLOBBERS FF,A
WATNOW:
IMSSS<;IMSSS KLUDGE FOR STUDENT SYSTEM
PUSHJ P,KIDCHK
>;IMSSS
MOVE A,GOGTAB ;ADDRESS OF USER TABLE
HRRZ FF,TOPBYTE(A) ;CURRENT STRING POINTER
CAMLE FF,STTOP(A) ;IN RANGE?
JRST [TERPRI <String space exhausted unexpectedly.
Any attempt to continue will cause a restart.>
MOVEI FF,[JRST @JOBREN]
MOVEM FF,-7(P) ;NEW RETURN ADDRESS.
;;%##% RHT MAKE IT SO THE GUY HAS TO AGREE TO RESTARTING
SETZB D,%ERGO
JRST .+1]
DEC<
;;=I02= Code to do continue if batch -- CH05 31-May-75
SKIPN %BATCH ;DO WE KNOW IF BATCH?
JRST [AOS %BATCH ;NO - ASSUME IT IS
MOVE A,[XWD -1,40] ;NOW CHECK
CALLI A,41 ;GETTAB
JFCL
TLNN A,200 ;BATCH?
SETOM %BATCH ;NO - SET TO -1
JRST .+1]
SKIPL %BATCH ;BATCH?
JRST GOTRY ;YES - AUTO CONTINUE
;;=I02= ^
> ;DEC
SKIPE %ERGO ;CONTINUOUS CONTINUE?
JRST GOTRY ;AUTOMATIC CONTINUE SET
SKIPE A,D ;IF A RESPONSE CHARACTER IS SPECIFIED,
JRST RESGOT ;GO USE IT.
;;=I20= CLH MAKE ALL ERRORS FATAL IN RUNTIMES FOR BATCH
DEC<
SKIPL %BATCH ;IF BATCH, SPECIAL DEFAULT ACTION
JRST [ SKIPGE CONFIG
JRST GOTRY ;COMPILER - CONTINUE
TERPRI <? NO ERROR RECOVERY IN BATCH>
JRST XIT] ;RUNTIMES - FATAL
> ;DEC
QUES: PUUO 2,A ;INCHRS
JRST PRMPT ;NO CHARACTER -- PROMPT
PUUO 11,0 ;CLEAR INPUT BUFFER
CAIN A,12 ;IF FEED, USE IT
JRST RESGOT ;CAN ONLY TYPE AHEAD LF.
PRMPT: MOVEI A,"?" ;PRINT ? FOR IRRECOVERABLE ERRORS,
SKIPGE %RECOV ; ^ FOR RECOVERABLE ONES.
MOVEI A,"^" ;SOMETHING PRINTABLE.
PUUO 1,A ;PRINT IT
PUUO 0,A ;GET RESPONSE CHAR
CAIN A,15 ;IF RESPONSE CR, THEN
PUUO 2,FF ; INCHRS
JFCL ; DON'T DO INCHRW HERE BECAUSE OF PTY'S
RESGOT:
CAIL A,"a" ;lower case?
SUBI A,40 ;YES, CONVERT TO UPPER
CAIN A,"E" ;RE-EDIT?
JRST EDIT ; YES
CAIN A,"T" ;TVEDIT?
JRST TVEDIT
CAIN A,"S" ;START?
JRST STRTIT ;YES
CAIN A,"X" ;EXIT
JRST XIT
CAIN A,"D" ;DDT
JRST DDIT ;.
;;%##% BY JFR 11-17-74
BAIL<
CAIN A,"B" ;BAIL?
JRST BAILIT
>;BAIL
;;%##% ^
CAIE A,"A"
CAIN A,12 ;CONTINUE AUTOMATISCH?
SETOM %ERGO ;YES
CAIN A,"C" ;CONTINUE AT ALL COSTS?
JRST EPOPJ ;YES -- SKIP RETURN.
CAILE A,15 ;TRY TO CONTINUE?
JRST BADRSP ;INCORRECT RESPONSE
GOTRY: SKIPGE %RECOV ;CAN WE CONTINUE?
JRST EPOPJ ;YES -- SKIP RETURN
TERPRI <Can't continue>
JRST QUES
STRTIT: HRRZ A,JOBSA
JRST (A) ;AWAY WE GO!
IMSSS<;KLUDGE FOR STUDENT SYSTEM
KIDCHK: PUSH P,A
PUSH P,B
MOVEI A,101 ;PRIMARY INPUT
JSYS RFMOD
TRNE B,1B33 ;A STUDENT JOB?
JRST ISKIDY ;YES
POP P,B
POP P,A
POPJ P,
ISKIDY: HRROI A,[ASCIZ/
Sorry, system error.
/]
JSYS PSOUT
SETO A,
JSYS KLGOT ;LOG HIM OUT
>;IMSSS
;;%##% BY JFR 11-17-74
BAIL<
BAILIT:
;;#WI# ! JFR 2-18-76 USER NOT SET UP SOMETIMES
MOVE USER,GOGTAB
SKIPN BAILOC(USER)
JRST [TERPRI <No BAIL>
JRST QUES]
MOVEI A,[PUSH P,.DTRT. ;ADDR+1 OF UUO
JRST @BAILOC(USER)] ;HEAVE-HO!
POPJ P, ;NON-SKIP RETURN.
>;BAIL
;;%##% ^
NOTENX <
;;=I03= (MOD BY JFR)
DDIT: SKIPN A,JOBDDT
JRST [TERPRI <No DDT>
JRST QUES] ;NO SUCH ANIMAL
;;%##%
EXPO <
;; \UR#2\ UOR USES RAID
NOUOR <
TERPRI <
TYPE DT.RET$G TO CONTINUE
>
>;NOUOR
>;EXPO
POPJ P, ;NON SKIP RETURN, A HAS 'GOTO' ADDRESS
XIT: MOVEI A,[CALL6 (EXIT)] ;PREPARE TO EXIT
POPJ P, ;NON SKIP RETURN.
EPOPJ: AOS (P) ;SKIP RETURN
POPJ P,
>;NOTENX
TENX < ;TENEX CODE TO GET UDDT (DEFINED IN THE FILSPC SECTION OF HEAD)
;IF NO DDT ALREADY HERE
DDTORG__770000
DDTPAG__770
UDTSYM__DDTORG+1 ;UDDT KEEPS A SYMBOL TABLE POINTER HERE
DDIT: SKIPE JOBDDT
JRST [HRROI 1,[ASCIZ/
Type DT.RET$G to continue.
/]
JSYS PSOUT
MOVEI A,[JRST @JOBDDT]
POPJ P,]
PUSH P,1
PUSH P,2
MOVE 1,[XWD 400000,DDTPAG] ;XWD THIS FORK, PAGE 770
JSYS RPACS ;TEST FOR PAGE 770
TLNN 2,10000 ;DOES PAGE 770 EXIST?
JRST GTUDDT ;NOPE
MOVE 1,DDTORG
CAME 1,[JRST DDTORG+2] ;DOES IT LOOK LIKE UDDT?
JRST GTUDDT ;NOPE
GOTUDT: HRROI 1,[ASCIZ/
Type DT.RET$G to continue.
/]
JSYS PSOUT
POP P,2
POP P,1
MOVEI 1,[JRST DDTORG] ;SET UP FOR CALL
POPJ P,
GTUDDT: MOVSI 1,100001 ;[clh] must exist!
GSYSIN ;[clh] SYSIND _ 0 for tenx, 2 for t20
MOVE 2,[UDTFIL]+1(SYSIND) ;[clh]
JSYS GTJFN
JRST [HRROI 1,[ASCIZ/
Cannot GTJFN file:
/]
JSYS PSOUT
GSYSIN ;[clh]
MOVE 1,[UDTFIL]+1(SYSIND) ;[clh]
JSYS PSOUT
JRST DOHLTF
]
PUSH P,1 ;SAVE JFN
MOVEI 1,400000 ;THIS FORK
JSYS GEVEC ;GET ENTRY VECTOR INTO 2
POP P,1 ;JFN FOR UDDT FILE
HRLI 1,400000 ;THIS FORK
JSYS GET
MOVEI 1,400000 ;THIS FORK
JSYS SEVEC ;PUT BACK THE ENTRY VECTOR
MOVE 1,JOBSYM ;SET UP SYMBOL TABLE POINTER
MOVEM 1,@UDTSYM ;SAVE FOR USER
JRST GOTUDT ;AND RETURN
XIT: MOVEI A,[JRST DOHLTF] ;TENEX VERSION OF EXIT CODE
POPJ P,
EPOPJ: AOS (P) ;SKIP RETURN
POPJ P,
DOHLTF: HRROI A,-1
JSYS CLOSF ;CLOSING ALL FILES
JFCL ;IS PROBABLY DONE
JSYS HALTF ;AUTOMATICALLY ON
JRST .-1 ;THE DEC SYSTEM
>;TENX
;;=I02= CH05 31-May-75
DEC<
BADRSP: TERPRI <Reply [CR] to continue,
[LF] to continue automatically,
"D" for DDT, "E" to edit, "T" to TECO, "B" for BAIL,
"X" to exit, "S" to restart>
> ;DEC
NODEC<
BADRSP: TERPRI <Reply [CR] to continue,
[LF] to continue automatically,
"D" for DDT, "E" to edit, "B" for BAIL,
"X" to exit, "S" to restart>
> ;NODEC
JRST QUES ;GET ANOTHER RESPONSE.
SUBTTL Special Printing Routines For Error Handler
URTBL1: ASCIZ // ; 0- 1 -- NO ACTION
ASCIZ /@I/ ; 2- 3 -- SYMBOL PTD TO BY LPSA
ASCIZ /@I/ ; 4- 5 -- SYMBOL PTD TO BY UUO
ASCIZ /@D/ ; 6- 7 -- VAL OF AC IN INSTR BEFORE UUO
ASCIZ /@B/ ;10-11 -- THE UUO ITSELF
ASCIZ /@D/ ;12-12 -- VAL OF AC IN INSTR BEFORE CALL FROM UUO1(GOGTAB)
ASCIZ /@F/ ;14-15 -- LPSA IN SIXBIT
ASCIZ // ;16-17 -- IOERR SECOND HALF
ASCIZ /
Invalid index for array @I. Index no. @D, value is @D/
;20-21 -- ARERR SECOND HALF
$PNAME__1
URTBL2: 0 ;NO ACTION
PWORD $PNAME+1(LPSA) ; 2- 3 -- SYMBOL PTD TO BY LPSA
PWORD @JOBUUO ; 4- 5 -- SYMBOL PTD TO BY UUO
PWORD @%ALLCHAR ; 6- 7 -- VAL OF AC IN INSTR BEFORE UUO
PWORD JOBUUO ;10-11 -- THE UUO ITSELF
PWORD @%OCTRET ;12-13 -- VAL OF AC IN INSTR BEFORE CALL FROM UUO1(GOGTAB)
PWORD LPSA ;14-15 -- LPSA IN SIXBIT
PWORD 0 ;16-17 -- IOERR PASS2 (NO-OP)
PWORD @JOBUUO ;START OF ARERR
POINT 4,JOBUUO,12 ; INDEX
PWORD @%ALLCHAR ; VALUE
;;%BF% ALLOW LARGER BUFFERS. DO THINGS IN THIS WAY TO MAKE
;; OLD PROGRAMS WORK (SORT OF)
;;SET UP C AND D FOR CALLS TO SPLICE
.ERSWD: SKIPN C,.ERBWD ;INITIALIZED?
MOVE C,[XWD .ERSWC*5*40,.ERSTR] ;.ERSWC*5 CHARS IN .ERSTR
MOVEM C,.ERBWD ;BE SURE PUT AWAY OK
LSH C,-5 ;THE COUNT FIELD
HLRZM C,.ERSTC ;REMEMBER THE COUNT
MOVN C,.ERSTC ;NEGATE
MOVSI C,(C) ;AOBJN POINTER
MOVEI D,@.ERBWD
HRLI D,(<POINT 7,0>) ;MAKE UP THE BYTE PTR
MOVEM D,.ERSTP
POPJ P,
DSCR CALLEDFROM -- PRINTS 'CALLED FROM' XXX 'LAST SAIL CALL AT'
PAR WHERE XXX+1 IS PRESENTED IN AC A
RES -- ONLY TYPING
SID DESTROYS A,B,C,D
CALLEDFROM:
MOVEM A,%ALLCHAR
MOVE A,GOGTAB
HRRZ A,UUO1(A)
MOVEM A,%OCTRET
MOVEI A,[ASCIZ/Called from @J Last SAIL call at @J
/]
SKIPGE CONFIG
MOVEI A,[ASCIZ/Called from @J
/]
MOVEI B,-1+[PWORD %ALLCHAR
PWORD %OCTRET]
HEREFK(SPLPRT,SPLPR.) ;CALL SPLICE AND PRINT THE RESULT TO TTY; ENTER WITH A,B SETUP
PUSHJ P,.ERSWD ;SET UP C AND D
PUSHJ P,SPLICE
SETZ B,
IDPB B,D ;AT LEAST ONE CHAR REMAINS DUE TO WAY C IS SET UP
PUUO 3,@.ERBWD
POPJ P,
SPLERR: JSP FF,SAVM ;JUST LIKE ERR UUO
LDB D,[POINT 4,JOBUUO,12] ;CODE IN AC FIELD
MOVE B,JOBUUO ;ADDR-1 OF POINT BLOCK
MOVE A,(B) ;ADDR OF ASCIZ CONTROL STRING
JRST ERRY ;SICK 'EM
DSCR USERERR(VALUE,CODE,"MSG","RESPONSE");
CAL SAIL
HERE (USERERR)
;; WE REALLY OUGHT TO HAVE ANOTHER UUO THAT CAN TAKE SOMETHING
;; OTHER THAN ASCIZ.
MOVE USER,GOGTAB
;;#YG# JFR 1-11-77 THIS ROUTINE IS BILTIN, MUST NOT DESTROY AC 0-11
MOVEM A,RACS+A(USER)
MOVEI A,1 ;BE SURE THAT DONT GC AT BAD TIME
AOSL REMCHR(USER) ;
PUSHJ P,STRNGC ;
MOVE A,RACS+A(USER)
IBP TOPBYTE(USER) ;BE SURE THAT HAVE NEITHER STRING AT TOP
PUSHJ P,INSET ;GET TO FW BNDRY
PUSH SP,[1] ;CONCATENATE A NULL TO END OF RSP STRING
PUSH SP,[POINT 7,[0]]
PUSHJ P,CAT
MOVE TEMP,-3(SP) ;EXCHANGE RESPONSE AND MSG STRINGS ON STACK
EXCH TEMP,-1(SP)
MOVEM TEMP,-3(SP)
MOVE TEMP,-2(SP)
EXCH TEMP,(SP)
MOVEM TEMP,-2(SP)
PUSHJ P,INSET ;
PUSH SP,[1] ;CONCATENATE A NULL FOR TTCALL
PUSH SP,[POINT 7,[0]]
PUSHJ P,CAT
MOVEI TEMP,-3(SP) ;ADDRESS OF RESPONSE STRING.
MOVEM TEMP,%ERRC ;SAVE FOR ERROR UUO.
;;%##% BY JFR 11-19-74
NOBAIL<
POP P,UUO1(USER)
SKIPG TEMP,(P) ;IS CODE 0?
>;NOBAIL
BAIL<
POP P,UUO1(USER) ;ADDR+1 OF CALL
PUSH P,UUO1(USER) ;MUST NO FIDDLE WITH STACK, OR BAIL WON'T WORK
SKIPG TEMP,-1(P) ;IS CODE 0?
>;BAIL
;;%##% ^
ERR. @(SP) ;YES, NO CONTINUATION POSSIBLE
CAIN TEMP,1 ;IS CODE 1?
ERR. 1,@(SP) ;YES, JUST PRINT ERROR, ALLOW CONT
CAIGE TEMP,2 ;IS IT SOMETHING ELSE
JRST USERBAK ;NO
;;%##% BY JFR 11-19-74
NOBAIL<
MOVE TEMP,-1(P) ;YES, SET UP SO ERR. GUY WILL PRINT VALUE
>;NOBAIL
BAIL<
MOVE TEMP,-2(P) ;YES, SET UP SO ERR. GUY WILL PRINT VALUE
>;BAIL
;;%##% ^
ERR. 7,@(SP) ; AND DO IT
USERBAK:
SUB SP,X44
;;%##%
NOBAIL<
SUB P,X22
>;NOBAIL
BAIL<
SUB P,X33
>;BAIL
;;%##% ^
NOBAIL<
JRST @UUO1(USER) ;RETURN FROM ROUTINE.
>;NOBAIL
BAIL<
JRST @3(P) ;RETURN--UUO1 MAY HAVE BEEN CLOBBERED BY BAIL
>;BAIL
DSCR ERMSBF
CAL SAIL -- ERMSBF(#CHARS)
DES WILL CALL CORGET, IF NEED BE TO ENSURE THAT YOU CAN HAVE AT LEAST
THE SPECIFIED NUMBER OF CHARS-1 IN YOUR ERROR MESSAGES.
SETS UP .ERBWD TO BYTE (13)CHARCNT(23)BUFADR
;;%BR% WAS A HEREFK
HERE(ERMSBF)
PUSHJ P,SAVE
MOVE A,-1(P) ;GET NEW BUFFER, IF NEED IT
MOVEI B,0 ;
CAIGE A,.ERSWC*5 ;WILL .ERSTR WORK ??
JRST FROLD ;YES THE 0 WILL FORCE ITS USE BY NEXT ERR UUO
MOVE C,A ;HOW MANY WORDS??
IDIVI C,5 ;
ADDI C,1 ;FOR SAFETY'S SAKE
PUSHJ P,CORGET ;TRY & GET A BLOCK
ERR <CORGET OUT OF ROOM>
DPB A,[POINT =13,B,12] ; COUNT INTO B
FROLD: EXCH B,.ERBWD ;
JUMPE B,ERSXT ;WAS NULL BEFORE ??
MOVEI B,@B ;GET ADDRESS
CAIE B,.ERSTR ;WAS .ERSTR BEFORE ??
PUSHJ P,CORREL ;NO, MUST BE A CORGET BLOCK
ERSXT: MOVE LPSA,X22
JRST RESTR ;GO QUIT
SUBTTL Code to Handle Linkage to Editors
;;%CM% JFR 7-22-75 CHANGE ALL PUUO 0, TO PUUO 4,.
;;LET THE USER CORRECT TYPING MISTAKES
NOTENX <
TVEDIT: TDZA 13,13 ;FLAG AS TV
EDIT: MOVNI 13,1
PUSH P,13
SETZB 13,14 ;PREPARE FOR PROVIDING
SETZB 15,16 ;STOPGAP WITH FILE NAME,
SETZB 11,12 ; PAGE AND LINE NUMBERS, SEQUENTIAL LINE #
NONAME: PUUO 4,B ;SEE IF FILE NAME SPECIFIED
CAIE B,15 ;CR?
JRST GTNAM ; NO, NAME SPECIFIED
PUUO 4,B ;SNARF UP LINE FEED AFTER CR
SKIPL CONFIG ;IF IN THE COMPILER,
JRST GTIT
PUSH P,[0] ;USE SPECIAL CALL TO SET UP AC'S
PUSHJ P,@.ERRP. ;...
JRST GTIT ;GO PROCESS.
;;#YP# JFR 1-31-77 PREVIOUS CODE TO DELETE LEADING BLANKS WAS REALLY GROSS
GTNAM: CAIN B," "
JRST NONAME ;DELETE LEADING BLANKS
MOVE C,[POINT 6,13] ;COLLECT FILE NAME HERE
MKNLP: CAIE B," " ;DONE?
CAIN B,15
JRST GTIT1 ; YES
;;%CM% also let altmode be an escape back to response loop
STANFO<
CAIN B,175>;STANFORD
NOSTANFO<
CAIN B,33>;NOSTANFORD
JRST [POP P,13 ;RESTORE STACK DEPTH
JRST QUES]
TRZN B,100 ;MAKE SIXBIT
TRZA B,40
TRO B,40
CAIN B,'.'
SKIPA C,[POINT 6,14] ;ADJUST TO GET EXTENSION
IDPB B,C ;CHAR OF FILENAME
PUUO 4,B
JRST MKNLP
;;%CP% JFR 7-25-75 HOW DID WE EVER GET ALONG WITHOUT THIS??
DSCR EDFILE("file name",line no.,page no.,bits[0])
CAL SAIL
PAR line no.is either ASCID or attach count,,line no.
page no. is binary.
bits=0, edit; =4 create, =2 readonly, =1 no directory.
RES The editor is run, pointed at the file in question.
If top 2 bits of line number are not zero, it is assumed to
be ASCID and you get SOS. If top 2 bits of line number are zero,
it is assumed to be binary and you get E.
IFNDEF FILNAM,<EXTERNAL FILNAM>
HEREFK(EDFILE,EDFIL.)
MOVE USER,GOGTAB
PUSHJ P,FILNAM ;TURN STRING INTO FNAME,EXT,PRPN(USER)
JFCL ;SOME ERROR IN FILE NAME
MOVE 14,FNAME(USER)
MOVE 13,EXT(USER)
MOVE 11,PRPN(USER)
POP P,16 ;JUNK THE RETURN ADDRESS
POP P,16 ;CREATE/READONLY BITS
LSH 16,=15 ;INTO TOP 3 BITS OF RIGHT HALF
HRRI 13,(16) ;OVER INTO EXT WORD
POP P,16 ;PAGE NUMBER
POP P,15 ;LINE NUMBER
MOVE 12,15 ;HERE, TOO
TLNN 15,600000 ;CHECK TOP 2 BITS OF LINE NUMBER
TDZA 7,7 ;NO BITS THERE, USE E
SETO 7, ;SOME BITS ON, ASSUME ASCID, USE SOS
STANFORD< ;SWAP BACK ACS
MOVE 0,INIACS+0 ;FILE NAME
HLLZ 1,INIACS+1 ;EXT -- avoid garbage in rh
MOVE 2,INIACS+2 ;NOTHING IMPORTANT
MOVE 3,INIACS+3 ;PPN
MOVE 6,INIACS+6 ;DEVICE
>;STANFORD
NOSTANFORD<
MOVE 0,INIACS+0 ;FILE
MOVE 7,INIACS+7 ;PPN
MOVE 11,INIACS+11 ;DEVICE
MOVE 17,INIACS+17 ;EXT
>;NOSTANFORD
;;%CP% ^
;;%ZB% Part 1 of 2. KS 21-Mar-77 Fix so swap back from editor works right
JRST GTIT+2 ;OFF TO THE RACES ... This line moved so INIACS restored
;;%ZB% Part 1 of 2. ^
GTIT1: CAIN B,15
PUUO 4,B
GTIT: POP P,7 ;TV/SOS FLAG
EXCH 13,14 ;EXT IN REG PRECEDING NAME?
;HERE TO RUN ANY PROGRAM, EITHER SOS OR COMPIL.
; REGISTERS HAVE GOODIES IN THEM:
; 13 FILE EXTENSION IN SIXBIT
; 14 FILE NAME IN SIXBIT
; 15 LINE NUMBER IN ASCII.
; 16 PAGE NUMBER (BINARY)
;IF AC 14 IS ZERO, THIS MEANS NO FILE HAS BEEN
; SPECIFIED, AND WE WILL USE "COMPIL" TO REPEAT THE
; LAST EDIT COMMAND (THIS IS NOT A FEATURE ON MOST
; STANDARD DEC SYSTEMS -- SEE R SPROULL)
NOEXPO <
;;%ZB% Part 2 of 2.
MOVEI P,[ 'SYS',,0 ;Assume no file name, edit previous file
'SNAIL '
'DMP',,0
0,,-1 ;tells SNAIL to "EDIT"
0
0]
JUMPE 14,SWAPIT
MOVEI P,[ 'SYS',,0 ;File name not null. Assume SOS intended
'SOS '
'DMP',,0
0,,1 ;Start at RPG location in editor
0
0]
JUMPL 7,SWAPIT
MOVEI P,[ 'SYS',,0 ;Wrong again. Will use E editor
'E '
'DMP',,0
0,,1 ;Still use RPG start
0
0]
MOVE 15,12 ;ATT CNT,,SEQ LIN NO. Info to E
SWAPIT: CALL6 (P,SWAP) ;P says which one we finally chose
;;%ZB% Part 2 of 2. ^
>;NOEXPO
; ELSE FALL INTO EXPO VERSION ....
COMMENT EXPORT VERSION OF EDITOR-INTERFACE
PROVIDED BY R. SPROULL, 11-18-70
SEE HIM FOR DETAILS ON DIDDLES TO CCL AND EDIT10
###### ??????? THIS PAGE CONTAINS CALLIs STILL ???????? ########
NOCMU <
EXPO <
;;=I02= Modified by C. Hedrick, 31-May-75 to link to TECO on T response.
DEC<
CAIL 7, ;TECO?
JRST [ MOVE 1,[SIXBIT /TECO/]
MOVEM 1,EDTNAM
JRST .+1]
JUMPN 14,EDITG ;FOLLOWING CODE FOR NO FILE NAME CASE:
CAME 1,EDTNAM ;TECO?
JRST EDT10R ;NO - USE SOS AT CCL ENTRY
MOVE P,[XWD 0,EDTBLK] ;YES - USE TECO AT NORM ENTRY
> ;DEC
NODEC< ;NOT SURE WHO THIS APPLIES TO - TENEX POSSIBLY?
JUMPN 14,EDITG ;IF FILE, FIRE UP SOS
MOVE P,[XWD -1,[SIXBIT /SYS/
NOTYMSHR< SIXBIT /COMPIL/>;NOTYMSHR
TYMSHR< SIXBIT /RPG/>;TYMSHR
0
0
0
0 ]]
> ;NODEC
CALL6 (P,RUN) ;GO RUN IT.
JRST 4,.
NOTYMSHR <
EDITG:
;;=I09= MODIFIED TO SAVE PATH IN A PLACE SAFE FROM THE RESET
SFDS<
JUMPE 11,NOSFD ;IF PPN=0, NO PATH TO BOTHER US
TLNE 11,777777 ;IF LH(11) IS SET, A REAL PPN
JRST NOSFD ;SO NO PROBLEM
HRL 1,11 ;OTHERWISE 11 POINTS TO PATH
HRRI 1,INIACS ;SAVE IT SOMEWHERE SAFE
BLT 1,INIACS+3+SFDLVL
MOVEI 11,INIACS ;AND USE PTR TO NEW PLACE
NOSFD:
> ;SFDS
PUSHJ P,RPGDSK ;SET UP FOR FILE
MOVE 2,14 ;GET THE FILE
PUSHJ P,SXCON
MOVEI 1,"."
SKIPN 2,13 ;EXTENSION
JRST NOEXT
PUSHJ P,OUT1
HLLZS 2 ;EXTENSION.
PUSHJ P,SXCON
NOEXT: SKIPN 11 ;PROJ,PROG #
JRST NOPPN
MOVEI 1,"["
PUSHJ P,OUT1
;;=I09= RESULT CAN ALSO BE PATH POINTER
SFDS<
TLNN 11,777777 ;REAL PPN?
JRST EDSFD ;LH = 0, MUST BE PATH POINTER
> ;SFDS
HLRZ 1,11
PUSHJ P,OCTQ ;OUTPUT OCTAL
MOVEI 1,","
PUSHJ P,OUT1
HRRZ 1,11
PUSHJ P,OCTQ
SFDEND: MOVEI 1,"]"
PUSHJ P,OUT1
NOPPN: PUSHJ P,CRLF
JUMPE 15,GOED10 ;IF NO LINE NUMBER, DO NOT DO THIS.
DEC<
MOVE 1,[SIXBIT /TECO/] ;TECO?
CAMN 1,EDTNAM
JRST GOED10 ;YES - DON'T PUT LN/PG FOR TECO
> ;DEC
MOVEI 1,"P"
PUSHJ P,OUT1
MOVE 2,15 ;LINE NUMBER
TRZ 2,1 ;FOR SURE?
ASCO: MOVEI 1,0
LSHC 1,7
PUSHJ P,OUT1
JUMPN 2,ASCO
MOVEI 1,"/"
PUSHJ P,OUT1
MOVE 1,16 ;PAGE NUMBER
PUSHJ P,OUTDEC
PUSHJ P,CRLF
GOED10: MOVE 1,PPMAX+2 ;SIZE
ADDI 1,4
IDIVI 1,5 ;TO WORDS
MOVNS 1
HRLS 1
HRR 1,PPMAX ;BUFFER START
ADDI 1,1
MOVEM 1,PPMAX+2
MOVSI 1,'EDT'
EXCH 1,PPMAX+1
MOVE 2,[XWD 3,PPMAX+1]
CALLI 2,44 ;WRITE IT
JRST DSKIT
>;NOTYMSHR
TYMSHR <EDITG: MOVEI 17,525252
>;TYMSHR
DEC<
EDT10R: MOVE P,[XWD 1,EDTBLK]
CALL6 (P,RUN)
JRST 4,.
> ;DEC
NODEC<
EDT10R: MOVE 1,[XWD 1,[SIXBIT /SYS/
TYMSHR < SIXBIT /EDIT10/>;TYMSHR
NOTYMSHR < SIXBIT /SOS/>;NOTYMSHR
0
0
0
0]]
CALL6 (1,RUN)
JRST 4,.
>;NODEC
NOTYMSHR <
DSKIT: SETSTS 1,16 ;DO NOT LOSE BUFFERS
MOVEM 1,PPMAX+1
CALLI 2,30 ;JOB NUMBER
MOVSI 1,'EDT' ;TO FILE NAME
MOVEI 4,3
DGLP: IDIVI 2,=10
IORI 1,20(3)
ROT 1,-6
SOJG 4,DGLP
MOVSI 2,'TMP'
SETZB 3,4
ENTER 1,1
CALLI 12 ;FATAL
SETSTS 1,0
CLOSE 1,0 ;FINISH
JRST EDT10R
;;=I09= HERE IS PPN OUTPUT IF A PATH POINTER
SFDS<
EDSFD: HLRZ 1,2(11) ;GET LH OF PPN
PUSHJ P,OCTQ ;OUTPUT AS OCTAL
MOVEI 1,"," ;COMMA
PUSHJ P,OUT1
HRRZ 1,2(11) ;GET RH OF PPN FROM PATH BLOCK
PUSHJ P,OCTQ ;OCTAL
MOVEI 11,3(11) ;ADVANCE 11 TO POINT TO FIRST SFD
EDSFD0: SKIPN (11) ;ANYTHING THERE?
JRST SFDEND ;NO - CLOSING BRACKET
MOVEI 1,"," ;YES - GIVE COMMA BEFORE IT
PUSHJ P,OUT1
MOVE 2,(11) ;AND PUT OUT SFD NAME, SIXBIT
PUSHJ P,SXCON
AOJA 11,EDSFD0
> ;SFDS
RPGDSK: CALLI
INIT 1,0
SIXBIT /DSK/
XWD PPMAX,0
CALLI 12
OUTBUF 1,0
OUTPUT 1,0
SETZM PPMAX+2
MOVEI 1," "
OUT1: AOS PPMAX+2
IDPB 1,PPMAX+1
POPJ P,
SXCON: MOVEI 1,0
LSHC 1,6
ADDI 1,40
PUSHJ P,OUT1
JUMPN 2,SXCON
POPJ P,
OCTQ: IDIVI 1,10
HRLM 2,(P)
SKIPE 1
PUSHJ P,OCTQ
HLRZ 1,(P)
ADDI 1,"0"
JRST OUT1
OUTDEC: IDIVI 1,=10
HRLM 2,(P)
SKIPE 1
PUSHJ P,OUTDEC
HLRZ 1,(P)
ADDI 1,"0"
JRST OUT1
CRLF: MOVEI 1,15
PUSHJ P,OUT1
MOVEI 1,12
JRST OUT1
> ;NOTYMSHR
>;EXPO
>;NOCMU
;;*****************
CMU < ;;
EDITG: MOVEI P,[SIXBIT /SYS/
SIXBIT /LINED/
0 0 0 0 ]
;; SKIPE 14 ;DID HE TYPE "E FILE"?
HRLI P,1 ;YES
;%BV% CHANGE RUN CALL TO CALLI -22 FOR CMU
RNNIT: CALLI P,-22 ;RUN IT
JRST 4,0 ;HALT
>;CMU
>;NOTENX
TENX <
HEREFK(EDFILE,EDFIL.)
ERR <EDFILE not available on TENEX>,1
SUB SP,X22
SUB P,X44
JRST @4(P)
EDIT: TDOA A,[-1] ;INDICATE STOPGAP
TVEDIT: SETZ A, ;INDICATE TERMINAL-DEPENDENT EDITOR
IMSSS< SKIPE $OSTYP> ;[clh] at IMSSS, only Tenex edits
NOIMSSS< SKIPN $OSTYP> ;[clh] elsewhere, only Tops-20
SKIPE .ERRP. ;ANYTHING THERE?
JRST TVEDI1 ;YES
SETZB D,%ERGO ;[clh] Clear "E" or "T", force response from terminal
TERPRI <You cannot edit from here.>
JRST WATNOW
TVEDI1:
PUSH P,A ;INFORMATION ABOUT WHICH EDITOR TO THE STACK
MOVEI A,1 ;INDICATE THAT WE WANT AN EDIT
PUSHJ P,@.ERRP. ;FOR COMPILER, TO MYERR
JRST WATNOW ;WHAT -- IT CONTINUED?
>;TENX
SUBTTL SAVE, RESTR, INSET -- General Utility Routines
DSCR SAVE
CAL PUSHJ
DES This routine saves registers 0-RF (12) in the user
RACS area. It also saves the return
address (-1(P)) in UUO1(USER), for traditional reasons,
for the error message printout routines.
Register USER is loaded but not saved, as is register
TEMP
^SAVE: MOVE USER,GOGTAB ; LOAD PTR TO USER RE-ENTRANT TABLE
HRRZI TEMP,RACS(USER) ;XWD FF,SAVEADDR
BLT TEMP,RACS+RF(USER) ;SAVE FF THRU RF
MOVE TEMP,-1(P) ;RETURN ADDR FROM I/O CALL
MOVEM TEMP,UUO1(USER) ;STORE RETURN
POPJ P,
TYMSHR <
^SAVETY: MOVE USER,GOGTAB
EXCH TEMP,(P) ;WE NEED TO SAVE TEMP
PUSH P,TEMP
MOVEI TEMP,RACS(USER)
BLT TEMP,RACS+RF(USER)
MOVE TEMP,-3(P)
MOVEM TEMP,UUO1(USER) ;SAVE PC OF CALLER
POPJ P,>;TYMSHR
DSCR RESTR
PAR LPSA -- XWD FOR ADJUSTING P-STACK (#PARAMS+RETURN ADDR)
CAL JRST
RES ACS are restored from RACS, stack is adjusted using LPSA,
return is made through UUO1(USER)
^RESTR: MOVSI TEMP,RACS(USER) ;XWD SAVEADDR,FF
CAME RF,RACS+RF(USER) ;TEMPORARY CHECK TO MAKE SURE NOT CLOBBERED.
ERR <DRYROT: RF CLOBBERED AT RESTR>,1
BLT TEMP,RF ;RESTORE
SUB P,LPSA ;ADJUST STACK
JRST @UUO1(USER) ;RETURN
DSCR STACSV
CAL PUSHJ
DES SAVES ACS 0-13 IN AREA STACS
SID DESTROYS 14,15
;; #KL# BY JRL (11-22-72) SAVE ONLY AC'S 0-13
^STACSV:
MOVE 15,GOGTAB
HRRZI 14,STACS(15)
BLT 14,STACS+13(15)
POPJ P,
DSCR STACRS
CAL PUSHJ
DES RESTORES ACS 0-13 FROM AREA STACS
;; #KL# RESTORE ONLY 0-13
^STACRS: MOVE 15,GOGTAB
HRLZI 14,STACS(15)
BLT 14,13
POPJ P,
DSCR INSET
CAL PUSHJ
RES String Space is adjusted so that next created string will start
on a full-word boundary.
SID USER PNTS TO GOGTAB
DES REMCHR is first adjusted, and STRNGC called if necessary.
Then TOPBYTE is adjusted.
;; #SX# INSET SHOULD REALLY BE HERE'D
HERE(INSET)
;; #SX#
MOVE USER,GOGTAB ;MAKE SURE
;;#GI# DCS 2-5-72 REMOVE TOPSTR
HLL TEMP,TOPBYTE(USER)
HRRI TEMP,[BYTE (7) 0,4,3,2,1,0]
ILDB TEMP,TEMP ;ADJUSTMENT NEEDED.
ADDM TEMP,REMCHR(USER) ;UPDATE REMCHR.
SKIPL TEMP,TOPBYTE(USER)
ADDI TEMP,1
HRLI TEMP,440700 ;POINT 7, WORD
MOVEM TEMP,TOPBYTE(USER) ;AND SAVE
POPJ P,
>;NOLOW
ENDCOM(LUP)
;; ! JFR 8-12-75 add .ERBWD
COMPIL(COR,<CORREL,CORGET,CORINC,CANINC,CORBIG>
,<.EXPIN,.TRACS,X11,GOGTAB,.ERBWD>
,<CORGET, CORREL, ... -- CORE ALLOCATION ROUTINES>)
SUBTTL Core Service Routines -- General Description
DSCR BEGIN CORSER
IFN ALWAYS,<BEGIN CORSER>
CMU <
GGAS <
IFE ALWAYS,<EXTERNAL TOP2,GLBPNT,GAS>
>;GGAS
>;CMU
Comment These are the core allocation routines for both the compiler
and the code it compiles. Core comes in "BLOCKs." A block may be any
(reasonable) length, and has the following format:
HEAD: ptr to PREV,, ptr to NEXT ;if block not in use, free storage list pointers
SIZE ;GREATER 0 if free, LESS0 if in use
<SIZE-3 data words> ;whatever is to go here
x00000,, ptr to HEAD ;x=1 if in use, 0 if free
ptr to PREV is zero if this block is first on free storage list.
ptr to NEXT is zero if last
In the beginning, the world starts out as one big block, occupying space from
the end of the (GOGTAB) user table to @JOBREL. Once a MOVE USER,GOGTAB
has been done, LOWC(USER) and TOP(USER) indicate the total size of
available core. FRELST(USER) pnts at the first (only) block in free storage.
If GOGTAB is 0, CORGET will create a user table and make the remaining space
look like a BLOCK. It will create a user table and point GOGTAB at it.
It also assures that DDT symbols are below JOBSA(lh). Then it sets
JOBFF to =76K out of pure spite. Now CORGET operations may be issued.
CORGET is called with the desired size in SIZ (C). The free storage list is
searched for the first free block (BLK) satisfying the request. The
required block is taken from lower addresses of BLK and BLK is adjusted.
If requested size is within a few words of the free size, all of BLK is
given to the user. The resultant address is returned in THIS (B).
If there is no block on FRELST(USER) big enough, or if ATTOP(USER) NEQ 0, CORGET
checks XPAND(USER) for permission (0) to expand core. If granted, a new
block is formed at the top after obtaining more core. It is merged with
the top block if it is free, then the requested block is allocated from
it. CORGET is simple.
CORGET skips if it is successful. It does not skip if it needs to expand and
either XPAND(USER) NEQ 0 or the CORE UUO fails.
The secret is CORREL. No compacting is done, but CORREL will merge a returning
block with any neighboring free block. It can do this because it can
tell the status of each neighbor by looking at the size (POS if free)
field or x-bit (off if free). This tends to reduce checkerboarding.
CORREL is called with a pointer to the block to be released in THIS (B).
It returns nothing, nor does it ever skip.
CORBIG returns in SIZ the size of the largest available block.
NOLOW < ;INCLUDE IN UPPER SEGMENT.
SUBTTL Special AC Declarations
DEBCOR __0 ;SWITCH FOR CORE DEBUGGING ROUTINES.
CMU <
DEBGAS __ 0 ;FOR GAS CORE STUFF
>;CMU
; ACS
SIZ __ 3 ;SIZE OF BLOCK BEING OBTAINED OR RELEASED
THIS __ 2 ;POINTER TO SAME
NEXT __ 1 ;POINTER TO SUCCESSOR
PREV __ 5 ;POINTER TO PREDECESSOR
LAST __ 6 ;POINTER TO NEXT-HIGHER NEIGHBOR
TRIVIAL __=10 ;AMOUNT WE'RE WILLING TO WASTE
CMU <
GGAS <
TM __ 7 ;MODULE NUMBER
GASAD __ 4 ;ADDRESS OF GAS
>;GGAS
>;CMU
SUBTTL Utility Routines
DSCR UNLINK
CAL PUSHJ
PAR ptr to Core block to be removed in AC THIS (2)
RES block is removed from CORSER free storage list
SID ACs NEXT (1) and PREV (5) are given appropriate values
UNLINK:
HRRZ NEXT,(THIS) ;PTR TO NEXT BLOCK
HLRZ PREV,(THIS) ;PTR TO PREVIOUS BLOCK
SKIPN PREV ;IF A PREV BLOCK DOES NOT EXIST,
MOVEI PREV,FRELST(USER) ; USE FRELST POINTER
HRRM NEXT,(PREV) ;CHANGE ITS NEXT FIELD
SKIPE NEXT ;IF A NEXT BLOCK EXISTS,
HRLM PREV,(NEXT) ; CHANGE ITS PREV FIELD
POPJ P, ;BLOCK IN "THIS" IS NO LONGER ON FRELST
DSCR RELINK
CAL PUSHJ
PAR AC THIS ptr to core block to be placed on free storage list
AC LAST ptr to last word of block +1
AC SIZ has size of this block
DES block is placed on CORSERs free storage list
SID AC NEXT (1) is given the appropriate value
RELINK:
HRRZM THIS,-1(LAST) ;X-BIT _ 0, RH _ PTR TO HEAD
MOVEM SIZ,1(THIS) ;GREATER 0 SIZE FIELD then FREE BLOCK
;;=E6= CMU FEATURE -- LDE 28-MAR-75 TRY TO KEEP FRELST IN ADDRESS-ORDER
; SKIPE NEXT,FRELST(USER) ;PLACE NEW BLOCK ON FRONT OF FRELST
; HRLM THIS,(NEXT) ; IF THERE IS ONE
; HRRZM NEXT,(THIS) ;POINT TO NEXT FROM THIS
; HRRZM THIS,FRELST(USER) ;UPDATE FRELST POINTER
PUSH P,PREV ;NEED ANOTHER AC (FOR PREV)
MOVEI NEXT,FRELST(USER) ;ADDRESS OF THE ANCHOR
JRST RELKIN
RELKNX: CAIG THIS,(NEXT)
JRST RELKDN ;THIS IS WHERE IT GOES
RELKIN: MOVEI PREV,(NEXT) ;COPY NEXT INTO PREV
HRRZ NEXT,(NEXT) ; AND GET THE NEXT NEXT
JUMPN NEXT,RELKNX ;IF NOT END-OF-LIST, TRY AGAIN
SKIPA ;END OF LIST, SO DON'T
RELKDN: HRLM THIS,(NEXT) ;PT TO THIS FROM NEXT
HRRM THIS,(PREV) ;PT TO THIS FROM PREV (OR FRELST(USER))
HRRZM NEXT,(THIS) ;PT TO NEXT FROM THIS
CAIE PREV,FRELST(USER) ;THIS IS PROBABLY SUPERFLUOUS....
HRLM PREV,(THIS) ;PT TO PREV FROM THIS
POP P,PREV ;AND RESTORE THE AC
;; =E6= ^
POPJ P, ;RETURN
DSCR CORE2I
CAL PUSHJ
DES Initializes second segment core if there is a global model
CMU < GGGON
>;CMU
GLOB <
IFN 0,<
^GLCOR:
SKIPE GLBPNT
POPJ P, ;ALREADY INITIALIZED.
MOVEM 16,GLUSER+LEABOT+16
MOVEI 16,GLUSER+LEABOT
BLT 16,GLUSER+LEABOT+15
;SHALL NOT CLOBBER ACCUMULATOR 1.
MOVEI 3,3(13) ;GET SIZE REQUIRED.PLUS SOME BECAUSE BLT LOSES.
PUSHJ P,CORE2 ;GET SECOND SEGMENT CORE.
JRST [TERPRI <NO CORE FOR GLOBAL MODEL>
CALL6 (EXIT)]
SUBI 2,1
MOVEM 2,GLBPNT ;AND RECORD IT.
SETZM 1(2) ;FIRST WORD.
HRRI 2,2(2) ;SECOND WORD.
HRLI 2,-1(2) ;FIRST WORD.
ADDI 3,-2(2) ;LENGTH.
BLT 2,(3) ;ZERO IT.....
MOVSI 16,GLUSER+LEABOT
BLT 16,16 ;RESTORE ALL LOADER'S AC'S AGAIN.
POPJ P, ;AND GO AWAY.
>
^CORE2I:
PUSH P,USER
NOCMU <
MOVE USER,[XWD GLUSER+LEABOT+20,GLUSER+LEABOT+21]
SETZM GLUSER+LEABOT+20
>;NOCMU
CMU <
NOGGAS <
MOVE USER,[XWD GLUSER+LEABOT+20,GLUSER+LEABOT+21]
SETZM GLUSER+LEABOT+20
>;NOGGAS
GGAS <
MOVE USER,[XWD GLUSER+ZAPBEG,GLUSER+ZAPBEG+1]
SETZM GLUSER+ZAPBEG
>;GGAS
>;CMU
BLT USER,GLUSER+ZAPEND
POP P,USER ;NOW DATA AREA IS ZERO.
MOVEI USER,GLUSER ;SET UP FOR CORE2.
PUSHJ P,JUSTSAVE ;AND SAVE AC'S
SETOM CORLOK ;THE LOCK ...
SETOM GLBPNT ;AND THE SWITCH SAYING INITED.
MOVE THIS,TOP2 ;LAST ADDRESS IN SEC. SEG USED.
ADDI THIS,1
MOVEM THIS,LOWC(USER) ;SAVE FOR LATER
CMU <
GGAS < ;LET'S GET SOME CORE TO USE
HRRZ USER,GLUSXX ; ****** KLUGE TO GET AROUND LOADER FUCKUP
MOVEI TEMP,(THIS)
ADDI TEMP,2000
HRLZS TEMP
CALLI TEMP,11 ;CORE UUO
ERR <CORE2I: CAN'T GET CORE FOR GAS>
HRROS JOBHRL ;SO MONITOR WON'T SAVE HISEG
SETZM GAS ;WE HAVE NO GGAS YET
>;GGAS
>;CMU
PUSHJ P,NEWB2 ;AND LINK UP.
JRST BUFRST ;ALL DONE INITIALIZING.
DSCR 2d SEGMENT CORE CONTROL STORAGE
CORLOK: 0
CR2BEG: BLOCK ZAPEND-ZAPBEG+1 ;AREA FOR ALL OTHERS.
^^GLUSER_CR2BEG-ZAPBEG ;AND THE MAGIC INDEX.
INTERNAL GLUSER
CMU <
GLUSXX: GLUSER ;KLUGE TO GET AROUND FAIL OR LOADER LOSSAGE AT CMU
>;CMU
>;GLOB
CMU < GGGOFF
>;CMU
DSCR BUFRST
CAL PUSHJ or JRST
RES restores ACs from CORSER routines, and returns
BUFRST:
IFN DEBCOR,<
SKIPE PRTCOR ;SHOULD WE DEBUG?
JFCL
>
MOVSI TEMP,BUFACS(USER)
BLT TEMP,LAST
POPJ P,
DSCR BUFSAV
CAL PUSHJ
RES Saves ACs for CORSER routine
Initializes CORSER storage, obtains USER TABLE if GOGTAB is 0
BUFSAV:
CMU < GGGON
>;CMU
GLOB <
SKIPN GLBPNT ;HAS GLOBAL MODEL BEEN INITIALIZED?
PUSHJ P,CORE2I ;NO --INITIALIZE IT.
>;GLOB
CMU < GGGOFF
>;CMU
SKIPE USER,GOGTAB ;CAN WE GO AHEAD?
JRST JUSTSAVE ; YES
Comment Use SALTAB and forget the rest if SALTAB is there. Otherwise
set up a user table. Don't use THIS or SIZ (B or C).
NOEXPO <
MOVEI TEMP,=76*=1024 ;ONE REALLY MUST KNOW WHAT HE
>;NOEXPO
EXPO <
MOVEI TEMP,-1 ;FOR MAX CORE
>;EXPO
MOVEM TEMP,JOBFF ; IS DOING
; SKIPE USER,SALTAB ;OTHERS CAN SPECIFY SAIL SPACE
; MOVEM USER,GOGTAB ;SET UP GOGTAB IF SALTAB NON-ZERO
; JUMPN USER,JUSTSAVE ;DON'T GO THRU SAIL's ALLOCATION
; ASSUME THAT THE WORLD IS NEW
HLRZ USER,JOBSA ;USER TABLE ADDRESS
;;%CO% ! (1/2)
MOVEI USER,5(USER) ;ROOM FOR GOGTAB ARRAY DESCRIPTOR
SKIPN JOBDDT ;IF DDT IS IN CORE,
JRST NODDT ; MAKE SURE ITS SYMBOLS ARE PROTECTED
HRRZ TEMP,JOBSYM ;IF JOBSYM IS BELOW JOBFF, THEN
;;#UM# JFR 7-25-75 SYMBOLS ABOVE 400000 ARE ALSO SAFE
CAIGE TEMP,400000
CAMGE TEMP,USER ; ASSUME ALL SYMBOLS ARE BELOW.
JRST .+2
TERPRI <YOUR SYMBOLS ARE SOON TO BE OBLITERATED>
;;#UM# ^
NODDT: MOVEI TEMP,ENDREN-CLER+=2000(USER) ;MAKE SURE
CAMGE TEMP,JOBREL ; ENOUGH CORE EXISTS
JRST CORTHER ; FOR USER TABLE
NOTENX <
CALL6 (TEMP,CORE) ;GET ENOUGH
CORERR <DRYROT -- NO ROOM FOR USER TABLE>
>;NOTENX
TENX <
HRRZM TEMP,JOBREL
>;TENX
CORTHER:
;;%CO% JFR 7-25-75 MAKE GOGTAB INTO AN EXTERNAL ARRAY, LATER GET RID OF USERCON
MOVEM USER,-5(USER) ;BASE WORD
MOVEM USER,GOGTAB ;THIS TIME FOR SURE
SETZM -4(USER) ;LOWER BOUND
MOVE TEMP,[XWD 1,ENDREN] ;SOME CONSTANTS
HRRZM TEMP,-3(USER) ;UPPER BOUND
HLRZM TEMP,-2(USER) ;MULTIPLIER
ADDI TEMP,1
MOVEM TEMP,-1(USER) ;NUM DIMS,,TOT SIZ
;;%CO% ^
;;#UR# ! JFR 8-6-75 this beast points to a CORGET block
SETZM .ERBWD
SETZM (USER) ;CLEAR USER TABLE
HRL TEMP,USER
HRRI TEMP,1(USER)
BLT TEMP,ENDREN-CLER(USER)
MOVEI THIS,ENDREN-CLER(USER) ;SET UP LIMITS OF FREE SPACE
MOVEM THIS,LOWC(USER) ; BOTTOM
PUSHJ P,NEWBLK ;MAKE NEW AREA INTO A FREE BLOCK
JRST JUSTSAVE ;SAVE ACS
GLOB <
NEWB2: CALL6 (LAST,SEGSIZ) ;FIND OUT HOW BIG.
TRO LAST,400000 ;SINCE ANDY DOES NOT GIVE ME THIS.
JRST NEWB1
>;GLOB
CMU <
GGAS <
NEWB2: HRRZ LAST,JOBHRL ;FIND HOW BIG
JRST NEWB1
>;GGAS
>;CMU
NEWBLK:
HRRZ LAST,JOBREL ;END OF BIG BLOCK
NEWB1: SETZM (THIS) ;POINTERS WORD IN BIG BLOCK
ADDI LAST,1 ;CONFORM TO "LAST" STANDARDS
MOVEM LAST,TOP(USER) ;TOP OF FREE SPACE
PUSH P,SIZ ;SAVE SIZE
MOVE SIZ,LAST ;COMPUTE SIZE OF NEW BLOCK
SUB SIZ,THIS ;SIZE OF BIG BLOCK
PUSHJ P,RELINK ;PUT ON FREE STORAGE LIST
POP P,SIZ ;GET SIZ BACK
POPJ P,
JUSTSAVE:
MOVEI TEMP,BUFACS(USER)
BLT TEMP,BUFACS+LAST(USER)
IFN DEBCOR,<
SKIPE PRTCOR ;SHOULD WE DEBUG?
PUSHJ P,CORPRT ; YES
>
POPJ P,
IFN DEBCOR,<
^PRTCOR: 0
>
SUBTTL CORGET
DSCR CORGET
CAL PUSHJ
PAR size of desired block in AC C (3)
RES SUCCESS: addr of block in B, skip-return
FAILURE: no-skip
SID none, except when called with GOGTAB 0 -- should only be done by experts
DES a block of at least the required size is obtained using first-fit algorithm.
Up to 10 extra words may be returned, but this is not reflected in C.
HERE(CORGET)
IFN DEBCOR,<
SKIPE PRTCOR
TERPRI <CORGET: > ;TELL THE PEOPLE WHO YOU ARE
>
PUSHJ P,BUFSAV ;SAVE AC'S, INITIALIZE WORLD PERHAPS
GLOB <
SKIPN USCOR2(USER) ;ARE WE INSTRUCTED TO USE CORE2?
JRST COR21 ;NOPE -- GO AHEAD.
^^CORE2: SKIPN GLBPNT ;HAS IT BEEN INITIALIZED?
PUSHJ P,CORE2I ;NO -- BUT NOW.
AOSE CORLOK ;CAN WE GET THROUGH THE LOCK?
JRST [SOS CORLOK ;APPARENTLY NOT.
PUSHJ P,WAITQQ ;WAIT
JRST .-1]
MOVEI USER,GLUSER ;USE THIS VERSION OF USER.
PUSHJ P,JUSTSAVE ;JUST SAVE THE ACCUMULATORS.
>;GLOB
NOCMU <
COR21: ADDI SIZ,3 ;3 WORDS FOR CONTROL INFO
>;NOCMU
CMU <
GGAS <
SKIPN USCOR2(USER) ;ARE WE INSTRUCTED TO USE CORE2?
JRST COR21 ;NOPE -- GO AHEAD.
^^CORE2:
IFN DEBGAS,<
SKIPE PRTCOR
TERPRI <CORE2:> ;FOR GAS
>;DEBGAS
SKIPN GLBPNT ;HAS IT BEEN INITIALIZED?
PUSHJ P,CORE2I ;NO -- BUT NOW.
AOSE CORLOK ;CAN WE GET THROUGH THE LOCK?
JRST [SOS CORLOK ;APPARENTLY NOT.
MOVEI TEMP,0
CALLI TEMP,31 ;SLEEP 0 SECONDS
JRST .-1]
MOVEI USER,GLUSER ;USE THIS VERSION OF USER.
PUSHJ P,JUSTSAVE ;JUST SAVE THE ACCUMULATORS.
>;GGAS
COR21: ADDI SIZ,3 ;3 WORDS FOR CONTROL INFO
IFN DEBGAS,<
CAIN USER,GLUSER
SKIPN PRTGAS
JRST GETPRT
PRINT < MODULE=>
OCTPNT TM
PRINT < SIZE=>
OCTPNT SIZ
GETPRT:
>;IFN DEBGAS
>;CMU
SKIPE ATTOP(USER) ;IF USER REQUESTS IT, GET BLOCK
JRST EXPAND ; AT TOP OF CORE
MOVEI THIS,FRELST(USER) ;THIS WILL POINT TO THE FIRST GOOD BLOCK
GETLUP: HRRZ THIS,(THIS) ;PTR TO NEXT FREE BLOCK
JUMPE THIS,EXPAND ;TRY TO EXPAND CORE, NONE EXIST YET
CAMLE SIZ,1(THIS) ;WILL IT FIT?
JRST GETLUP ; NO, TRY NEXT
GETCOR: AOS (P) ;SUCCESS GUARANTEED
HRRZM THIS,BUFACS+THIS(USER) ;RESULT(ALMOST)
PUSHJ P,UNLINK ;UNLINK THIS BLOCK
MOVE LAST,1(THIS) ;REAL BLOCK SIZE
CAIGE LAST,TRIVIAL(SIZ) ;IS DIFFERENCE NEGLIGIBLE?
JRST [MOVSI TEMP,400000 ;YES, USE WHOLE THING --
ADD LAST,THIS ; MARK X-BIT TO INDICATE IN USE
HLLM TEMP,-1(LAST)
JRST GETOUT] ;AND GO FINISH OUT
MOVEM SIZ,1(THIS) ;NEW SIZE FOR RESULT
HRRZ TEMP,THIS ;SAVE START OF BLOCK (RESULT)
ADD THIS,SIZ ;NEW START FOR REMAINING FREE STUFF
SUB LAST,SIZ ;NEW SIZE FOR REMAINS
MOVE SIZ,LAST
ADD LAST,THIS ;NEW END FOR REMAINS
HRLI TEMP,400000 ;TURN X-BIT ON
MOVEM TEMP,-1(THIS) ;IN USER'S BRAND NEW BLOCK
PUSHJ P,RELINK ;RELINK REMAINS, RESTORE ACS
GETOUT: PUSHJ P,GETRST ;RESTORE ACS
SETZM (THIS) ;PTR RETRIEVED FROM STORAGE
MOVNS 1(THIS) ;SIZE NEG MEANS IN USE
CMU <
IFN GASSW,<TRNN THIS,400000
JRST COR2GT
MOVEM TM,(THIS) ;STORE MODULE #
IFN DEBGAS,<
SKIPN PRTGAS
JRST COR2GT
PRINT < LOC=>
MOVE TEMP,THIS
OCTPNT TEMP
TERPRI
>;IFN DEBGAS
COR2GT:
>;IFN GASSW
>;CMU
ADDI THIS,2 ;USER DOESN'T SEE THIS HEADER
IFN DEBCOR,<
SKIPE PRTCOR
PUSHJ P,CORPRT
>
POPJ P, ;HERE'S YOUR BLOCK!
EXPAND: SKIPE XPAND(USER) ;IS IT ALLOWED TO EXPAND?
JRST GETRST ; NO, ERROR RETURN
PUSH P,SIZ ;SAVE TOTAL SIZE
HRRZ THIS,TOP(USER) ;THIS PNTS TO NEW BLOCK IF NEXT LOWER IS USED
SKIPGE -1(THIS) ;IS TOP BLOCK FREE?
JRST GETMOR ; NO, USE WHAT YOU HAVE
HRRZ THIS,-1(THIS) ;UNLINK THE
PUSHJ P,UNLINK ; TOP BLOCK
GETMOR: MOVE TEMP,THIS
ADDI TEMP,=1024(SIZ) ;GET MORE AND THEN SOME
POP P,SIZ ;GET THIS BACK BEFORE YOU FORGET
;;%BB% dcs cmu-style pre/post trap calls
CMU < GGGON ;SO TRPCAL WORKS ?
>;CMU
TRPCAL (SIZ,TEMP,X11,X11,.EXPINT) ;TRAP TO USER IF DESIRED
CMU < GGGOFF ;
>;CMU
GLOB <
CAIN USER,GLUSER ;THIS IS HOW WE TELL
JRST [CALL6 (TEMP,CORE2) ;GET SOME CORE
;;%##% GO AHEAD & TRAP A LOSSAGE
JRST BLEWIT ;HE SPAT UPON OUR HUMBLE REQUEST.
PUSHJ P,NEWB2 ;LINK IT UP
JRST GETM.1]
>;GLOB
CMU <
GGAS <
CAIN USER,GLUSER
JRST [ HRLZ TEMP,TEMP ;
TLO TEMP,400000 ;
CALL6 (TEMP,CORE) ; DO THE CORE UUO
JRST BLEWIT ; NO JOY
MOVNS TEMP
GGGON
TRPCAL(SIZ,TEMP,X11,X11,.EXPINT) ;TRAP TO LOSER
GGGOFF
HRROS JOBHRL ;SO DONT SAVE HISEG
PUSHJ P,NEWB2 ;LINK IT UP
JRST GETM.1 ] ;
>;GGAS
>;CMU
;;%##% TWO SEGS OVER 400000 IS A LOSER
UP <
TENX <
;;ON TENEX, SEGLOC MAY BE ALMOST ANYWHERE
IFNDEF SEGLOC, <SEGLOC__400000>
;;%DZ% GJA/JFR 1-13-77 ALLOW USER TO SPECIFY SEGLOC
;;;; CAIL TEMP,SEGLOC ;WELL??
SKIPN A,SEGBOT(USER)
MOVEI A,SEGLOC ;NOT SPECIFIED, USE DEFAULT
CAIL TEMP,(A)
;;%DZ% ^
JRST BLEWIT ;GREAT EROR
>;TENX
NOTENX <
CAIL TEMP,400000 ;
JRST BLEWIT ;
>;NOTENX
>;UP
NOTENX <
CALL6 (TEMP,CORE) ;ASK FOR MORE
;;%##% USED TO BE GETRST
JRST BLEWIT ;CAN'T GET IT
>;NOTENX
TENX <
HRRZM TEMP,JOBREL ;SEE COMMENT @ NODDT ABOVE
>;TENX
;;%BB% dcs ! for 2
MOVNS TEMP
TRPCAL (SIZ,TEMP,X11,X11,.EXPINT) ;TRAP TO USER NOW THAT HAVE CORE
PUSHJ P,NEWBLK ;MAKE TOP LOOK LIKE FREE BLOCK
GETM.1: CAMLE SIZ,1(THIS) ;NOW SHOULD FIT
CORERR <DRYROT -- EXPAND CODE GLUBBED UP>
JRST GETCOR ;GO GET BLOCK
;;%##% HERE IF BLOWN IT
BLEWIT: MOVNS SIZ
MOVNS TEMP
;;%BB% !
TRPCAL(SIZ,TEMP,X11,X11,.EXPINT)
GETRST:
CMU < GGGON
>;CMU
GLOB <
PUSHJ P,BUFRST ;RESTORE ACCUMULATORS.
CAIN USER,GLUSER ;WAS IT CORE2?
SOS CORLOK ;YES -- BACK UP COUNT.
MOVE USER,GOGTAB ;RESET IT TO USUAL.
POPJ P, ;
>;GLOB
JRST BUFRST
CMU < GGGOFF
>;CMU
SUBTTL CORINC, CANINC
DSCR CORINC
CAL PUSHJ
PAR AC B -- Addr of block to be incremented
AC C -- amount if increase desired
RES SUCCESS: skip-return, extra core has been granted
FAILURE: no-skip
SID none
HERE(CORINC)
IFN DEBCOR,<
SKIPE PRTCOR
TERPRI <CORINC:>
>
PUSHJ P,JUSTSAVE ;SAVE ACS
MOVNI FF,1 ;WANT TO DO IT
JRST INCR
DSCR CANINC
CAL PUSHJ
PAR same as CORINC
RES No extra core is ever actually obtained
if entire request can be granted, skip-return
if some extra words available, no-skip, C contains possible increment
if no extra words available, no-skip, C contains 0
SID none except as described above
HERE(CANINC)
IFN DEBCOR,<
SKIPE PRTCOR
TERPRI <CANINC: >
>
PUSHJ P,BUFSAV
MOVEI FF,0 ;JUST WANT TO SEE IF IT'S POSSIBLE
; IF BLOCK IS AT TOP, CAN ALWAYS DO IT
INCR: SUBI THIS,2 ;POINT AT REAL BLOCK HEAD
CMU < GGGON
>;GGGOFF
GLOB <
TRNE THIS,400000 ;CHECK TO SEE IF CORE2
CORERR <NO CANINC SECOND SEGMENT SPACE>
>;GLOB
CMU < GGGOFF
>;CMU
HRRZ LAST,THIS ;CHECK AT TOP
SUB LAST,1(THIS) ; ADDR OF END (SIZE IS NEG)
CAMGE LAST,TOP(USER) ;TOP BLOCK?
JRST MIDDLE ; NO
JUMPE FF,YESINC ;SUCCESS
MOVNS 1(THIS) ;MAKE IT LOOK FREE
ADD SIZ,1(THIS) ;TOTAL SIZE
HRRZS -1(LAST) ;MAKE END LOOK FREE
JRST EXPAND ;EXPAND AND RETURN
MIDDLE: SKIPGE TEMP,1(LAST) ;NEXT BLOCK FREE?
JRST NONEATALL ; NO, FAILURE
SUBI TEMP,3 ;AVAILABLE SIZE
CAMLE SIZ,TEMP ;IS THERE ENOUGH?
JRST MAYBE ; NO, FAILURE MAYBE
JUMPE FF,YESINC ;ALL OK, CAN DO, REPORT IT
CRXXB: MOVNS TEMP,1(THIS) ;MAKE IT LOOK FREE
PUSH P,(THIS) ;WILL RESTORE THIS IN CASE SOMEONE USED
PUSH P,THIS ;SAVE SIZE
PUSH P,SIZ ;AND POINTER
ADDM TEMP,(P) ;TOTAL SIZE DESIRED AFTER RETURN
MOVE SIZ,TEMP ;SIZE OF CURRENT "THIS"
HRRZ THIS,LAST ;MERGE "THIS" WITH "LAST"
PUSHJ P,UNLINK ;TAKE IT OFF FRELST
ADD LAST,1(THIS) ;AND INCREASE
ADD SIZ,1(THIS)
MOVE THIS,-1(P) ;RETRIEVE CURRENT BLOCK.
PUSHJ P,RELINK ;AND NOW RELINK ON FRELST.
POP P,SIZ
POP P,THIS
PUSHJ P,GETCOR ;GET THE BLOCK AGAIN, ONLY BIGGER
CORERR <DRYROT -- NEAR CRXXB> ;CAN'T HAPPEN
POP P,-2(THIS) ;GET POINTER WORD BACK
AOS (P) ;SUCCESS
POPJ P, ;BUFRST DONE BY GETCOR
YESINC: AOS (P) ;REPORT SUCCESS
IFN DEBCOR,<
SKIPE PRTCOR
PUSHJ P,CORPRT
>
JRST BUFRST
MAYBE: ADDI TEMP,3(LAST) ;GET TOP OF NEXT BLOCK AND SEE
CAMGE TEMP,TOP(USER) ;IF IT IS THE TOP ONE.
JRST NOTENUF ;NO -- FAIL UTTERLY.
JUMPE FF,YESINC ;GOT IT IF ONLY GOING TO HERE.
PUSH P,SIZ ;SAVE AMOUNT REQUESTED.
MOVEI SIZ,-3(TEMP) ;THIS IS THE SIZE OF THE BLOCK WE
SUB SIZ,LAST ;KNOW WE CAN GET.
MOVN TEMP,SIZ
ADDM TEMP,(P) ;(P) NOW HAS EXTRA REQUIRED.
PUSHJ P,CRXXB ;AND WE DO SOO
CORERR <DRYROT NEAR MAYBE> ; CAN'T HAPPEN.
POP P,SIZ ;RETRIEVE SIZE.
MOVNI FF,1 ;SINCE CRXXB DESTROYED IT.
JRST INCR ;AND GO THROUGH AGAIN
;THIS TIME IT WILL BE THE TOP BLOCK.
NOTENUF:
SUBI TEMP,3(LAST) ;UNDO WHAT WAS DONE ABOVE
SKIPA SIZ,TEMP ;CAN'T DO ALL, BUT CAN DO THIS MUCH
NONEATALL:
MOVEI SIZ,0 ;CAN'T DO ANYTHING
MOVEM SIZ,BUFACS+SIZ(USER)
JRST BUFRST
SUBTTL CORREL
DSCR CORREL
CAL PUSHJ
PAR addr of block to be released in B
RES block is released to free storage
SID none
DES the block is merged with any adjoining free blocks
HERE(CORREL)
IFN DEBCOR,<
SKIPE PRTCOR
TERPRI <CORREL: >
>
SKIPN USER,GOGTAB ;MUST BE SET UP HERE
CORERR <DRYROT -- CORREL CALLED WITH INITIALIZED WORLD>
GLOB <
TRNN THIS,400000 ;IS IT SECOND SEGMENT ADDRESS?
JRST NOSGR ;NO
MOVEI USER,GLUSER ;USE THIS ONE.
AOSE CORLOK ;SEE IF WE CAN GET IN.
JRST [SOS CORLOK
PUSHJ P,WAITQQ
JRST .-1]
NOSGR:
>;GLOB
CMU <
GGAS <
TRNN THIS,400000 ;IS IT SECOND SEGMENT ADDRESS?
JRST NOSGR ;NO
^^CORE2R:
IFN DEBGAS,<SKIPE PRTGAS
TERPRI <CORREL: >
>
MOVEI USER,GLUSER ;USE THIS ONE.
AOSE CORLOK ;SEE IF WE CAN GET IN.
JRST [SOS CORLOK
MOVEI TEMP,0
CALLI TEMP,31
JRST .-1]
NOSGR:
>;GGAS
>;CMU
PUSHJ P,JUSTSAVE ;SAVE ACS
; MERGE WITH LOWER NEIGHBOR (ADDRESS-WISE) IF POSSIBLE
SUBI THIS,2 ;USER THINKS IT STARTED 2 PAST
MOVN SIZ,1(THIS) ;SIZE OF THIS BLOCK
CMU <
IFN DEBGAS,<
TRNE THIS,400000
SKIPN PRTGAS
JRST RELPRT
PRINT < LOC=>
MOVE TEMP,THIS
OCTPNT TEMP
PRINT < SIZ=>
OCTPNT SIZ
PRINT < MODULE=>
OCTPNT (TEMP)
RELPRT:
>;IFN DEBGAS
>;CMU
MOVE LAST,SIZ ;ADDRESS OF UPPER
ADD LAST,THIS ; NEIGHBOR
CAMGE THIS,LOWC(USER) ;IS ADDRESS IN RANGE?
CORERR <DRYROT -- ADDR TO CORREL TOO LOW>
CAME THIS,LOWC(USER) ;CAN THERE BE A LOWER BLOCK
SKIPGE -1(THIS) ; AND IF SO, IS IT FREE?
JRST UPPET ; NO, LOOK FOR UPPER BLOCK
HRRZ THIS,-1(THIS) ;PTR TO LOWER BLOCK
PUSHJ P,UNLINK ;UNLINK IT FROM LIST
ADD SIZ,1(THIS) ;INCREASE SIZE
; MERGE WITH UPPER NEIGHBOR IF POSSIBLE
UPPET: CAMLE LAST,TOP(USER)
CORERR <DRYROT -- ADDR TO CORREL TOO HIGH>
CAME LAST,TOP(USER) ;IS THERE AN UPPER BLOCK?
SKIPGE 1(LAST) ;AND IF SO, IS IT FREE?
JRST LNKRET ; NO, RELINK AND GO AWAY
UPPR: PUSH P,THIS
HRRZ THIS,LAST ;THIS PTR TO UPPER NEIGHBOR
PUSHJ P,UNLINK ;GET IT OUT
ADD LAST,1(THIS) ; INCREASE EXTENT
ADD SIZ,1(THIS) ; AND TOTAL SIZE
POP P,THIS ; GET HEADER POINTER BACK
LNKRET:
GLOB <
CAIN USER,GLUSER
JRST LNKRT ;IF SEC SEGMENT, NEVER SHRINK
>;GLOB
;;#IC# 7-3-72 DCS (1-1) ADD NEW MEANING TO NOSHRK(USER)
SKIPL TEMP,NOSHRK(USER) ;If NOSHRK(USER) is:
CAMG LAST,JOBREL ; <0, CORREL should not reduce core;
JRST LNKRT ; >0, its RH indicates the amount of
CMU <
GGAS <
CAIN USER,GLUSER ;HI GUY?
JRST [HRRZ TEMP,JOBHRL ;YES
CAIG LAST,(TEMP) ;HIEST BLOCK?
JRST LNKRT ;NOPE
HRLZI TEMP,=1023(THIS) ;STICK IN HI SEG HALF
TRPCAL (SIZ,TEMP,X11,X11,.EXPINT)
CALL6 (TEMP,CORE)
ERR <DRYROT --CORSER&LNKRET>
MOVNS TEMP
TRPCAL (SIZ,TEMP,X11,X11,.EXPINT)
HRROS JOBHRL ;HACK SO SAVE WON'T A HI SEG
HRRZ LAST,JOBHRL
JRST CORCUT]
>;GGAS
>;CMU
JUMPN TEMP,.+2 ; free space which should be
MOVEI TEMP,=2046 ; protected from release;
HRRZS TEMP ; =0, at least 2K should be protected.
CAIGE TEMP,4 ;Only the first and third alternatives
MOVEI TEMP,4 ; were previously available.
CAMGE SIZ,TEMP ;Don't bother if there is already
JRST LNKRT ; less free space available than
ADDI TEMP,(THIS) ; desired
;;%BB%
TRPCAL (SIZ,TEMP,X11,X11,.EXPINT)
;;#IC# (1-1)
NOTENX <
CALL6 (TEMP,CORE)
ERR <DRYROT --CORSER&LNKRET>
>;NOTENX
TENX <
HRRZM TEMP,JOBREL ;SEE COMMENT @ NODDT ABOVE
>;TENX
;;%BB%
MOVNS TEMP
TRPCAL (SIZ,TEMP,X11,X11,.EXPINT)
MOVE LAST,JOBREL ; AND 2) ADJUST BLOCK TO INDICATE
CMU <
GGAS <
CORCUT:
>;GGAS
>;CMU
ADDI LAST,1
MOVEM LAST,TOP(USER) ;AND RECORD NEW RESULTS.
MOVE SIZ,LAST ; THE CHANGE BEFORE RELINKING
SUB SIZ,THIS
LNKRT:
PUSHJ P,RELINK ;PUT IT BACK
IFN DEBCOR,<
SKIPE PRTCOR
PUSHJ P,CORPRT
>
JRST GETRST ;AND GO AWAY
SUBTTL CORPRT, CORBIG
IFN DEBCOR,<
^CORPRT:
SETZM TOTFRE# ;TOTAL FREE STORAGE COUNT
TERPRI <FREE STORAGE: >
PUSH P,LPSA
MOVE USER,GOGTAB ;THIS STUFF IS DEBUGGING
CMU <
GGAS <
MOVEI USER,GLUSER
>;GGAS
>;CMU
MOVEI LPSA,FRELST(USER) ;JUNK FOR CORGET AND FRIENDS
CPLUP: HRRZ LPSA,(LPSA) ;IT SHOULD BE INTUITIVELY
JUMPE LPSA,DUNNN ;OBVIOUS
PRINT <START = >
OCTPNT LPSA
MOVE TEMP,1(LPSA)
ADDM TEMP,TOTFRE
PRINT < SIZE = >
OCTPNT TEMP
ADD TEMP,LPSA
PRINT < END = >
OCTPNT TEMP
TERPRI
JRST CPLUP
DUNNN:
PRINT <TOTAL FREE SIZE = >
OCTPNT TOTFRE
CMU <
GGAS <
JRST GG.DBP ;HACK TO MAKE COND ASSY EASIER (UGH)
>;GGAS
>;CMU
SETOM PRTCOR
TERPRI
CAMLE THIS,JOBREL
JRST DUNMOR
TERPRI <THIS BLOCK: >
PRINT <"THIS" = >
MOVE TEMP,THIS
OCTPNT TEMP
PRINT < C-SIZE = >
HRRZ TEMP,SIZ
OCTPNT TEMP
CAML THIS,JOBREL
JRST DUNMOR
HRREI LPSA,-2(THIS)
JUMPLE LPSA,DUNMOR
PRINT < BLOCK-SIZE = >
MOVN TEMP,1(LPSA)
OCTPNT TEMP
CMU <
GGAS <
GG.DBP:
TERPRI
PRINT <LASTAL = >
OCTPNT LASTAL
PRINT < HI BND = >
MOVE TEMP,GAS
JUMPE TEMP,.+3
OCTPNT -1(TEMP)
TERPRI
>;GGAS
>;CMU
DUNMOR: TERPRI
POP P,LPSA
TTCALL 11,
TTCALL TEMP
TERPRI
POPJ P,
>
CMU <
IFN GASSW,<
INTERNAL GASINI,MAKEGA,GASTAT
TEMP2__13
GASLOK:-1 ;CRITICAL SECTION LOCK, ONE CUSTOMER AT A TIME
LASTAL: 0 ;INDEX OF FIRST WORD OF HIEST ALLOCATED BLOK
IFN DEBGAS,<PRTGAS: 0 ;SWITCH TO ENABLE DEBUGGING
INTERNAL PRTGAS
>;IFN DEBGAS
HERE(GASINI)
SETZM GAS
SETZM GLBPNT
SETOM CORLOK
SETOM GASLOK
IFN DEBGAS,<
SKIPE PRTGAS
TERPRI <GASINIT:>
>;IFN DEBGAS
POPJ P,
HERE(MAKEGA)
SKIPG TM,-3(P)
ERR <MAKEGAS: NEGATIVE MODULE #>,1
AOSE GASLOK ;ONE AT A TIME.
JRST [
MOVEI A,0
CALLI A,31
JRST .-1] ;COME BACK LATER.
IFN DEBGAS,< SKIPE PRTGAS
TERPRI <MAKEGAS:>
>
;MOVE USER,GOGTAB ;GET USER TABLE ADDRESS.
;SETOM USCOR2(USER) ;TERN ON FLAG ABOUT HIGH SEG.
SKIPN GASAD,GAS ;GET ADDRESS OF ARRAY IS IT ZERO.
JRST INITGS ;ZERO. GO INITIALIZE IT.
TKGS01: SKIPG SIZ,-2(P) ;GET SIZE REQUEST.
JRST GASRTN ;NOT POSITIVE, &O RETURNING.
PUSHJ P,CORE2 ;GO ALLOCATE CORE.
ERR <MAKEGAS: NO CORE>
SUBI THIS,(GASAD) ;COMPUTE INDEX.
MOVEM THIS,@-1(P) ;SET IT TO RETURN TO CALLER.
CAML THIS,LASTAL ;HAVE WE EXTENDED THE ARRAY
JRST [MOVEM THIS,LASTAL ;YUP--REMEMBER IT
ADDI THIS,-1(SIZ) ;NEW UPPER BOUND
MOVEM THIS,-3(GASAD) ;SAVE UPR BND IN HEADER
HRRM THIS,-1(GASAD) ; " TOTL SIZ " "
JRST .+1 ]
TKGS03:
IFN DEBGAS,<SKIPE PRTGAS
PUSHJ P,CORPRT
>;IFN DEBGAS
;SETZM USCOR2(USER) ;TURN OFF FLAG.
SETOM GASLOK ;RESET LOCK.
SUB P,[XWD 4,4] ;STEP BACK IN STACK.
;NOTE THAT HERE WE USED A LITERAL INSTEAD
; OF "X44" SO THAT THIS CAN BE CALLED FROM
; A NON-SAIL LOW SEGMENT.
JRST @4(P) ;AND LEAVE.
;CODE THAT FOLLOWS SETS UP ORIGINAL ARRAY DESCRIPTOR.
INITGS: MOVEI SIZ,5 ;NEED 5 WORDS FOR DESCRIPTOR.
PUSHJ P,CORE2 ;GET THEM.
ERR <MAKEGAS: NO CORE>
SETZM 1(THIS) ;LOWER BOUNDS = 0.
SETZM 2(THIS) ;UPPER BOUNDS = 0.
MOVEI TEMP,1
MOVEM TEMP,3(THIS) ;MULT = 1.
HRLI TEMP,1
MOVEM TEMP,4(THIS) ;#DIMS,,SIZE
MOVEI GASAD,5(THIS) ;ADDRESS OF START OF ARRAY.
MOVEM GASAD,(THIS) ;SET AS BASE WORD.
MOVEM GASAD,GAS ;SET AS GAS.
SETZM LASTAL ;ZERO LAST-ALLOC. WORD.
JRST TKGS01 ;CONTINUE.
;THIS IS THE PART THAT FREES UP SPACE.
GASRTN: MOVE THIS,@-1(P) ;GET INDEX.
CAMN THIS,LASTAL ;END OF ARRAY?
JRST [MOVEI TEMP,-3(THIS) ;YES
ADDI TEMP,(GASAD) ;ADDR OF LAST WORD OF PREV
TGAS8: MOVEI TEMP2,-1(TEMP) ;SAVE
SKIPL TEMP,(TEMP)
JRST [MOVEI TEMP,-1(TEMP)
JRST TGAS8] ;THIS IS FREE, TOO.
SUBI TEMP2,(GASAD) ;CALC HIEST INDEX
MOVEM TEMP2,-3(GASAD) ;SAVE UPR BND
HRRM TEMP2,-1(GASAD) ;SAVE TOTAL SIZE
HRRZS TEMP ;CLEAR OUT SIGN BIT
SUBI TEMP,-2(GASAD) ;INDEX OF 1ST WRD OF BLOK
MOVEM TEMP,LASTAL ;REMEMBER IT
JRST .+1]
TKGS06: ADDI THIS,(GASAD) ;MAKE IT AN INDEX
PUSHJ P,CORE2R ;RELEASE CORE.
JRST TKGS03 ;GO LEAVE.
HERE(GASTAT)
TERPRI <GAS PROFILE:>
MOVEI USER,GLUSER ;HI SEG
AOSE GASLOK ;CRITICAL SECTION
JRST [MOVEI TEMP,0
CALLI TEMP,31 ;DISMISS
JRST .-1]
SKIPN TM,GAS ;WHERE IT IS
JRST NOGAS
PRINT <GAS[0] IS AT '>
OCTPNT TM
PRINT < JOBHRL='>
OCTPNT JOBHRL
PRINT < LASTAL=>
DECPNT LASTAL
PRINT < HIEST=>
DECPNT -3(TM)
TERPRI <
START LENGTH MODULE PREV NEXT>
MOVEI PREV,0 ;TO ACCUMULATE AMOUNT FREE
MOVEI NEXT,0 ;" " " IN USE
HRRZ LAST,JOBHRL ;THE STOPPING ADDRESS
AOS TM ;ADDRESS OF FIRST BLOCK IN GAS
STLP: MOVE TEMP,TM
SUB TEMP,GAS
DECPNT TEMP ;STARTING INDEX
PRINT < >
MOVM SIZ,1(TM) ;ABSOLUTE LENGTH
DECPNT SIZ
PRINT < >
SKIPL 1(TM) ;FREE?
JRST STFREE ; YES
DECPNT (TM) ;MODULE NUMBER
ADD NEXT,SIZ ;ACCUMULATE AMOUNT IN USE
JRST STNEXT ;GO GET ANOTHER
STFREE: ADD PREV,SIZ ;ACCUMULATE AMOUNT FREE
PRINT < >
HLRZ TEMP,(TM) ;PREV
SKIPE TEMP
SUB TEMP,GAS ;COMPUTE THE INDEX
DECPNT TEMP
PRINT < >
HRRZ TEMP,(TM) ;NEXT
SKIPE TEMP
SUB TEMP,GAS ;ITS INDEX
DECPNT TEMP
STNEXT: TERPRI
ADD TM,SIZ ;ADDR OF NEXT BLOCK
CAMG TM,LAST ;DONE?
JRST STLP ; NO
PRINT <
AMOUNT IN USE=>
MOVE TEMP,NEXT
DECPNT TEMP
PRINT < FREE=>
DECPNT PREV
STATOU: TERPRI
SETOM GASLOK ;LEAVE CRIT SECTION
POPJ P,
NOGAS: TERPRI <THE TANK IS DRY!>
JRST STATOU
>;IFN GASSW
>;CMU
DSCR CORBIG
CAL PUSHJ
PAR NONE
RES LARGEST AVAILABLE BLOCK IN SIZ (3,C)
SID THIS (2,B) MUNGED
HERE(CORBIG) SKIPN USER,GOGTAB
CORERR <CORBIG: INITIALIZED WORLD>
MOVEI SIZ,0 ;"ZERO-LENGTH" BLOCK
MOVEI THIS,FRELST(USER)
BIGLUP: HRRZ THIS,(THIS)
JUMPE THIS,BIGDUN ;END OF FREELIST?
CAMGE SIZ,1(THIS)
MOVE SIZ,1(THIS) ;FIND MAX
JRST BIGLUP
BIGDUN: SUBI SIZ,3 ;WHAT HE SEES
POPJ P,
Comment No other core routines should be necessary to provide
gross control over allocation. Programs obtaining
space from CORGET can carve the blocks up if necessary.
Please put your core back when you're done with it.
Thank You,
The Management
>;NOLOW
ENDCOM (COR)
IFN ALWAYS,<
BEND CORSER
>
;;%BA% DCS New high class expanding string garbage collector. Entire compil
COMPIL(SGC,<STRNGC,STRGC,STCLER,SGINS,SGREM,%SPGC1,%ARSR1,.SONTP>
,<.SGCIN,GOGTAB,X11,CORGET,CORREL,CORINC,X22,CORBIG,SPRPDA,INSET>
,<STRING GARBAGE COLLECTOR ROUTINES>
,<%SPGC,%STRMRK,%ARRSRT>)
DSCR STRGC (REQUEST)
CAL SAIL
PAR REQUEST -- length of string which must fit after STRNGC
RES Calls STRNGC, using REQUEST as A-argument
REMCHR not updated by REQUEST size after return
DSCR STRNGC
CAL PUSHJ
PAR A -- number of new characters needed
REMCHR(USER) -- has been updated by that number of chars
STREQD(USER) -- Additional characters required (see below).
STINCR(USER) -- Size (in words) of string space increments (see below).
Statistics:
SGCTIME -- Time of last garbage collect, in ms.
User must activate timing, by setting this cell to -1.
SGCTOTAL-- Total gc time, in ms., if timing active.
SGCNUM -- Number of strings collected, last gc.
SGCWASTE -- Number of unused but unavailable wds detected, last gc.
RES REMCHR (updated by request) and TOPBYTE are correct, there is room
to insert a string of the requested size, + STREQD additional chars.
SID none
DES STRNGC is two-pass. In the first, all string descriptors are found
and sorted into ascending sequence with respect to the locations of their
respective texts. Descriptors are found via the generating routines,
described in CALSG description below.
In the second pass, all string texts are moved down to fill any
unused space. All descriptors are adjusted to reflect the new locations.
If there is still not room to satisfy the request+REQD, a new block
(space), STINCR long, is allocated for strings, and TOPBYTE set to
point to it. Alternatively, if the compaction yielded some empty spaces,
they may be deleted, depending on the value of REQD, and the request.
String space thus dynamically expands and contracts to satisfy demand.
DSCR CALSG
PAR linked list of routine addresses based at SGROUT(USER)
RES each routine in list is called to provide string descriptors
to the linking routine, SGSORT.
SID SGSORT uses B,C, and TEMP, accepts input in A. Generating
routines may use A-T (11) and TEMP for their own devices.
D through T will not be changed by calls on SGSORT.
DES
Active strings are identified by the two-word descriptors which
are scattered throughout memory, some in variables, some in arrays,
some in stacks, some in LEAP storage, etc. STRNGC must look at
each descriptor during collection. It does it by calling, in sequence,
each of the routines on SGROUT, providing each with the address of a
routine which will add the descriptor to those STRNGC knows about. The
user (clever) can add or remove routines on the SGROUT list (see SGINS,
SGREM).
Each generating routine should do the following:
1) Place a string descriptor address in A
2) PUSHJ P,SGSORT or PUSHJ P,@-1(P) (addr provided on stack)
3) Repeat the process if it knows about more strings, else
4) Return with a POPJ (and a flourish)
The `standard' generating routines are:
SPSG -- collects the string stack
STRMRK -- collects string variables linked through SGLINK(USER)
ARRMRK -- collects string arrays found in ARRPDL
RINGSORT -- collects PNAMES from semantic blocks in compiler
DEFSRT -- collects saved input strings during macro recursion in compiler.
These routines should provide sufficient examples.
;STRGC, Definitions
NOLOW <
MLT__=16 BKSZ__5*MLT+1 ;BKSZ must always be so related to MLT
^.CORERR:
CORERR <NO CORE FOR ALLOCATON>
HERE (STRGC)
EXCH A,-1(P) ;THE DESIRED A IS HERE
MOVE USER,GOGTAB
MOVEM RF,RACS+RF(USER);SAVE F REGISTER WHERE GC CAN FIND.
PUSHJ P,STRNGC ;COLLECT TRASH
SUB P,X22 ;BACK UP STACK
MOVNS A
ADDM A,REMCHR(USER)
MOVE A,1(P) ;GET ORIGINAL "A" BACK
JRST 2,@2(P) ;RETURN
DSCR .SONTP(STRING S;INTEGER CNT)
DES This routine returns (on sp) a string EQU to S (may be S)
which is aligned with TOPBYT & ensures that there are at least
an additional CNT chars left in the current string space.
SID updates REMCHR. Sets USER to GOGTAB, mangles TEMP
may call STRNGC
HERE(.SONTP)
BEGIN SONTP
;; THE CANON STUFF IS COPIED FROM CAT
DEFINE CANON (ADR,AC)<
LDB TEMP,[POINT 3,ADR,5] ;4,5,6,7,0,1 FROM POSITION
IMULI AC,5 ;ADDR IN CHARS
ADD AC,BPTBL(TEMP) ;0,1,2,3,4,5 EXTRA CHARS
>
MOVE USER,GOGTAB
PUSH P,A
PUSH P,B
PUSH P,C
PUSH P,D
MOVE A,-5(P) ;CNT
ADDM A,REMCHR(USER) ;TEST GCING LATER
;;#QQ# RHT ! BOY, WAS I ASLEEP WHEN I WROTE THIS CODE
HRRZ D,-1(SP) ;LOAD LENGTH
;;#QP# RHT ! (1 OF 4)
HRRZ B,(SP)
CANON <(SP)>,B ;STANDARD FORM
ADD B,D ;ADD LENGTH
;;#QP# RHT ! (2 OF 4)
HRRZ C,TOPBYT(USER)
CANON <TOPBYT(USER)>,C
CAMN B,C ;SAME??
ISONTP: SKIPLE REMCHR(USER) ;GC NEEDED??
JRST NOTONT ;MAY WIND UP COPYING
XIT: POP P,D ;FINISH
POP P,C
POP P,B
POP P,A
SUB P,X22
JRST @2(P)
NOTONT: ;ALWAYS GET ENOUGH TO COPY STRING
;IF ARE GOING TO GC
HRRZ D,-1(SP) ;GET LENGTH OF STRING
ADD A,D
ADDM D,REMCHR(USER)
SKIPG REMCHR(USER) ;REALLY GC ??
JRST CPYSTR ;NO REAL NEED
PUSHJ P,STRNGC ;GARBAGE IS COLLECTED
;;#QP# ! RHT (3 OF 4)
HRRZ B,(SP)
CANON <(SP)>,B ;ON TOP NOW ??
ADD B,D
;;#QP# ! RHT (HAD MISREAD CANON) 4 OF 4
HRRZ C,TOPBYT(USER)
CANON <TOPBYT(USER)>,C
CAME B,C ;WELL
JRST CPYSTR ;NO, MUST COPY
MOVN D,D ;GIVE BACK CHARS GET FROM NOT COPYING
ADDM D,REMCHR(USER) ;
JRST XIT ;DONE
CPYSTR:
;;#RI# RHT SOMETIMES NEED A FW BNDRY
SKIPE SGLIGN(USER) ;NEED FW BNDRY??
PUSHJ P,INSET ;YES
;;#RI#
MOVE B,TOPBYT(USER) ;NEW STRING BP
EXCH B,(SP)
JUMPE D,XIT ;DONE ??
ILDB C,B ;COPY CHARS
IDPB C,TOPBYT(USER)
SOJG D,.-2 ;
JRST XIT ;DONE
;CAT'S MAP TABLE
BPTBL: 4
5
0
0
0
1
2
3 ;MAP
BEND SONTP
;STRNGC -- Init, CALSGL, SGSWEP -- main loop through space sorting
HERE(STRNGC)
MOVE USER,GOGTAB
;!BUG TRAP! remove after reverence for F is established
CAME RF,RACS+RF(USER) ;ALL RUNTIMES SHOULD BOTH
ERR <DRYROT -- RF (R12) not saved in RACS at STRNGC>
;!END BUG TRAP! -- LATER THE NECESSITY TO SAVE WILL BE PHASED OUT.
MOVEM RF,RACS+RF(USER) ;WILL RESTORE AFTER SORTING ROUTINES
SKIPN SGCTIME(USER) ;User can
JRST SGC1
MOVEI TEMP,0 ;TIME SG STARTS
;!HOOK! Conditional assembly for CMU, TENEX system timing goes here.
NOTENX <
CALL6 (TEMP,MSTIME)
MOVNM TEMP,SGCTIME(USER)
>;NOTENX
TENX <
MOVEM 1,SGCTIME(USER) ;SAVE 1 & 2
MOVE TEMP,2 ;"TIME" GIVES TIME IN 1, DIVISOR
JSYS TIME ;TO GET SECONDS IN 2 (ALWAYS
MOVNS 1 ;1000 SO FAR)
EXCH 1,SGCTIME(USER) ;BUT SHOULD THIS REALLY BE TIME
MOVE 2,TEMP ;OF DAY, NOT BILLABLE RUNTIME?
>;TENX
SGC1: MOVEM 11,SGACS+11(USER)
MOVEI 11,SGACS(USER)
BLT 11,SGACS+10(USER)
AOS TEMP,SGCCNT(USER) ;COUNT TIMES THROUGH GC
MOVNM TEMP,SGCCNT(USER) ;INDICATE THAT GC IS IN PROGRESS
;;%BB% CMU-TYPE TRAP CALL
SKIPN .SGCINT
JRST NOTRP
;;#QA# RHT & DCS THE ARGS TO THIS WERE WRONG
PUSH P,A ;SIZE OF REQUEST
PUSH P,0 ;CONVENTION IS 4 PARAMS
PUSH P,SGCCNT(USER)
PUSH P,0 ;SO PUSH SOME [CENSORED] UP
PUSHJ P,@.SGCINT
NOTRP:
;;%BB%
HRRZ TEMP,TOPBYTE(USER) ;MAKE SURE DIDN'T OVERFLOW
CAMG TEMP,STTOP(USER)
CAMGE TEMP,ST(USER)
ERR <TOPBYTE out of range at STRNGC -- will continue>,1
; List the String Descriptors
CALSG: MOVEI T,SGROUT(USER) ;GET LINKED LIST OF ROUTINE NAMES
PUSH P,T ;SAVE FIRST POINTER
PUSH P,[SGSORT] ;PROVIDE ACCESS TO SORTING ROUTINE
^CALSGL:
SKIPN T,@-1(P) ;GO DOWN LIST UNTIL DONE
JRST ALLCOL ;DONE
HRRZM T,-1(P) ;SAVE NEW POINTER
PUSHJ P,@-1(T) ;CALL GENERATOR ROUTINE
MOVE RF,RACS+RF(USER) ;GET GOOD F BACK, ASSUMING GOOD USER
JRST CALSGL ;DO MORE THAN ONCE
ALLCOL: SUB P,X22 ;Remove temp, SGSORT address
; Sort all spaces
; Allocate a BKSZ-word bucket. Then, for each space, look at each
; descriptor, partition it (by starting location within the space)
; into one of the buckets, then sort it into the list of strings
; so partitioned, in an order specified in the SRTSPC comments.
; Finally, for each space, create a single linked list of sorted
; descriptors.
SGSWEP: MOVEI C,BKSZ
PUSHJ P,CORGET
STCORERR: ERR <String garbage collector can't get core>
MOVEM B,STBUCK(USER)
; Space Sorting Loop
MOVE B,STLIST(USER) ;Loop through all string spaces,
SETZM SGCNUM(USER) ;Strings handled count (not incl. const.)
;<** B => current space throughout
SPCLUP: PUSHJ P,SRTSPC ; sorting. When through, .LIST
SKIPE B,.NEXT(B) ; in the header of each space
JRST SPCLUP ; will be the sorted dscrptr lst.
;STRNGC -- SWPLUP -- main sweep (string moving) loop
; Move the strings, and update the descriptors. Two routines,
; SOURCE and DEST, maintain information about old and new string
; locations, respectively, and other state info needed to move the
; strings. Each is responsible for switching from space to space
; when necessary.
MOVE B,STBUCK(USER) ;Release the buckets (STBUCK=OFFSET, see blow).
PUSHJ P,CORREL
;Initialize source, destination space pointers.
MOVE B,STLIST(USER)
MOVE C,B
PUSHJ P,DSTSET
;**B is Source Space Pointer throughout
;**C is Destination Space pointer throughout
SWPLUP: PUSHJ P,SOURCE ;Identify a source "nest", return params
JRST SWPDUN ; and adjust descriptors, no-skip when done
PUSHJ P,DEST ;Identify a destination location, move the
JRST SWPLUP ; source nest there, and re-create all
; descriptors, adjusted for destination.
;STRNGC -- SWPDUN -- expansion/contraction, parameter update
SWPDUN:
;<** C => last dest. space
;** TOPBYTE, REMCHR correct for C's dest. space
; 1. Get room for request + desired free space (see ALLOC), either
; from a new space block, or from empty spaces between C's and
; A's, if there are any
; 2. Release from "C+1" to and including the last space (shrink string space)
; 3. Clean up, zero remaining free space, quit.
;!HOOK! Here, if you made a decision to move the last destination
; space, you should do it -- see below for more about this.
HLRZ D,STREQD(USER) ;Requested char count +
ADD D,SGACS+A(USER) ; STREQD (see p. 2) char count.
MOVE E,D
;**E is total required empty space -- valid until GRANTED, below.
GRANT: ADD D,REMCHR(USER) ;Granted, if total required
JUMPL D,GRANTED ; space exists in last DEST
PUSHJ P,WASTE ;Add up wasted space in DEST being left.
;; \UR#29\ JRL (8/7/78) (2 of 5) save .topbyte
MOVE TEMP,TOPBYTE(USER)
MOVEM TEMP,.TOPBYTE(C) ;SAVE TOPBYTE
;; \UR#29\
MOVE A,C ;Save space being abondoned
SKIPN C,.NEXT(C) ; space. Otherwise, move
JRST EXPSTR ; to next space, if any, and
GRTSET: PUSHJ P,DSTSET ; continue to try to grant
MOVE D,E ; request
JRST GRANT
;<** A => previous DEST Space, get another
EXPSTR: HLRZ C,STINCR(USER) ;STINCR (see p. 2) char count.
CAML E,C ;Is there going to be room?
;;\UR#28\ JRL (8-3-78) ALLOW STRINGS BIGGER THAN STINCR
; ERR <String space expansion: request too big>
JRST [MOVE C,E
PUSH P,D ; SAVE D OVER DIVIDE
IDIVI C,5
POP P,D ; RESTORE D
ADDI C,1+.HDRSIZ ; SIZE OF BLOCK NEEDED
JRST EXPST2]
HRRZ C,STINCR(USER) ;STINCR word count, + .HDRSIZ
EXPST2:
;;\UR#28\
PUSHJ P,CORGET
JRST [PUSHJ P,CORBIG ;If for some reason we can't get
MOVEI B,.HDRSIZ+1(C) ; STINCR words, make sure that
IMULI B,5 ; a new block can at least satisfy
CAMGE B,E ; the request + STREQD.
ERR <String GC: no core to expand string space>
PUSHJ P,CORGET ;Will do, get it
ERR <DRYROT -- unexpected STRNGC core problem>
JRST .+1]
MOVEI B,.HDRSIZ(B) ;Adjust pointer to leave header,
SUBI C,.HDRSIZ ; set up header area parameters,
MOVEM C,.STTOP(B) ; link to previous area
MOVEM C,.SIZE(B)
ADDM B,.STTOP(B)
SETZM .NEXT(B)
SETZM .LIST(B)
MOVEM B,.NEXT(A)
MOVE C,B ;This becomes last destination
JRST GRTSET ;Go satisfy request, now guaranteed.
GRANTED:HRRZM C,ST(USER) ;Update ST, STTOP, release any
MOVE TEMP,.STTOP(C) ; spaces made unnecessary by diminished
MOVEM TEMP,STTOP(USER) ; active strings
SKIPN A,.NEXT(C) ;Get next space past last DEST, if any,
JRST STSTAT ; then clear any next space pointers.
SETZM .NEXT(C)
RELLUP: MOVEI B,-.HDRSIZ(A) ;Release any spaces which are
;;#RL# (CMU =B2=) USED TO ACCESS .NEXT AFTER THE CORREL
MOVE A,.NEXT(A)
PUSHJ P,CORREL ; apparently no longer necessary.
JUMPN A,RELLUP
;; \UR#29\ JRL (8-7-78) (4 OF 5) ROUTINE TO COLLECT EMPTY STRING BLOCKS
JRST STSTAT ; USED TO JUST FALL THROUGH
FRESTB:
MOVEI A,STLIST-.NEXT(USER)
LPFRB:
MOVE B,.NEXT(A) ; PTR TO STRING BLOCK
SKIPN C,.NEXT(B) ; IS THIS THE LAST ONE?
POPJ P, ; YES, RETURN
HRLI B,(<POINT 7,0>) ; BYTE POINTER TO FIRST BYTE IN BLOCK
CAME B,.TOPBYTE(B) ; SAME AS NEXT BYTE TO BE USED?
JRST [ MOVE A,B ; NO. KEEP BLOCK
JRST LPFRB] ; LOOP
HRRZM C,.NEXT(A) ; REMOVE THIS BLOCK FROM STLIST
MOVN C,.SIZE(B) ; RECOMPUTE SGCWASTE
ADDM C,SGCWASTE(USER)
HRRZI B,-.HDRSIZ(B) ; CALCULATE BEGINNING OF CORGET BLOCK
PUSHJ P,CORREL ; RELEASE THE BLOCK
JRST LPFRB ; LOOP
;; \UR#29\ (END 4 OF 5)
;;#RL#
;STRNGC -- STSTAT -- Finish Up, collect statistics
STSTAT: ;Check that Full-word alignment produced
SKIPE SGLIGN(USER) ;Alignment also implies clearing
PUSHJ P,RESCLR ;Free space
MOVEI B,=15 ;Update REMCHR by initial request, plus a
ADD B,SGACS+A(USER) ; bit of slop (NOT by STREQD, which specifies
ADDB B,REMCHR(USER) ; free space -- slop is unfree, for safety.)
JUMPGE B,[ERR <DRYROT -- String GC Surprised at Untoward Occurrence>]
MOVMS SGCCNT(USER) ;Now indicate done with GC
SKIPN SGCTIME(USER) ;Timing active?
JRST NOTIME ;No
MOVEI TEMP,
;!HOOK! Insert, conditionally, other system timing calls
NOTENX <
CALL6 (TEMP,MSTIME) ;Collect GC times
>;NOTENX
TENX <
EXCH 1,TEMP
PUSH P,2
JSYS TIME
POP P,2
EXCH 1,TEMP
>;TENX
ADDB TEMP,SGCTIME(USER)
ADDM TEMP,SGCTOTAL(USER)
NOTIME:
;;%BB% CMU-STYLE TRAP -- I DON'T SUPPLY ALL THE SAME INFO AS LDE DID AT CMU
SKIPN .SGCINT
JRST QUITGC
MOVN TEMP,REMCHR(USER);SIZE OF GRANT, LESS ORIGINAL REQUEST
PUSH P,TEMP
PUSH P,SGACS+1(USER) ;ORIGINAL REQUEST
PUSH P,SGCCNT(USER) ;AS FAR AS I CAN TELL, JUST USING UP CELLS
PUSH P,SGCNUM(USER) ; IN THE CALL STACK
PUSHJ P,@.SGCINT
;;%BB%
QUITGC: MOVE USER,GOGTAB ;PARANOID
;; \UR#29\ JRL (8-7-78) (5 OF 5) FREE EMPTY STRING BLOCKS
PUSHJ P,FRESTB
;; \UR#29\
HRLZI 11,SGACS(USER) ;Restore and return
BLT 11,11
POPJ P,
;STRNGC Service routines -- SGSORT
;Sgsort
;<A is => descriptor
;1. Ignore constants
;2. Check legality, go easy on null strings
; issues: Recover gracefully from bad strings
; Report complete info about bad strings
; Try to supply name of descriptor source for
; bad strings (stack, vbl, array, other)
;3. In // with above, find proper string space for each str.
;4. Link in string # field (lh word 1) -- separate list for each space
SGSORT: HLLZ B,(A) ;don't collect constants
JUMPE B,SGRST
; Loop on string spaces, find the one containing this string
;;#UA# (1 OF 2) CHECK BP FOR 010700,,BUF-1
SGRTY:
HRRZ TEMP,1(A)
MOVEI B,STLIST-.NEXT(USER)
SGLUP1: SKIPN B,.NEXT(B)
JRST NORANGE ;Range exhausted, bad string
CAML TEMP,B ;Address check of string bp
CAML TEMP,.STTOP(B) ; against both ends of each
JRST SGLUP1 ; space determines if string in range
INRANGE:SUB TEMP,B ;Convert bp to space-relative
IMULI TEMP,5 ; character count
HLLZ C,1(A)
TLNN C,777770 ;Make sure there are still byte ptr. bits
;Max possible start count is 4,,777777
JRST [MOVE A,A ;ERR type 7 gets AC # from here
ERR <SGSORT-- string encountered twice, descriptor addr = >,7
JRST SGRST] ;Don't handle again.
HRRI C,[BYTE(7) 0,1,2,3,4,5]
ILDB C,C ;Space-relative count fits in
ADD C,TEMP ; rh, lh 0 signals
MOVEM C,1(A) ; re-encounter (above)
MOVE C,.LIST(B) ;Insert descriptor, linked by
HRLM C,(A) ; string number field, into
HRRZM A,.LIST(B) ; list for this space
JRST SGRST
NORANGE:
;;#tc# rht (cmu =a7=) dont barf at null strings
HRRZ B,(A) ;test for null
JUMPE B,SGZAP ;& do the right thing
;;#tc#
;;#UA# (2 OF 2) RLS CHECK FOR 010700,BUF-1 BP-- LABEL SGZAP ADDED ABOVE & BELOW
HLRZ B,1(A) ;Get lh of the byte-pointer
CAIE B,010700 ;does the address field point to previous word
JRST NORNG1 ;no, really is out of bounds
HRRZI B,440700 ;make other kind of bp
HRLM B,1(A)
AOS 1(A)
JRST SGRTY ;AND TRY AGAIN
NORNG1:
;;#UA# (2 OF 2)
MOVE A,A ;String not in range, complain, NULL it,
ERR <String GC: Descriptor byte ptr. out of bounds, Addr. is >,7
SGZAP: SETZM (A) ; and go on.
SGRST: ADDI A,2 ;Auto-increment descriptor index
POPJ P,
;STRNGC Service routines -- SPGC,STRMRK, etc. -- Descriptor providing routines
; ------ SORT THE SP STACK ------
HERE(%SPGC) HRRZ A,SPDL(USER) ;START AT BASE OF STACK
^%SPGC1:ADDI A,1
JRST SGTST ;AND WORK UP TO CURRENT POINTER
STRNGSTACKMARKLOOP:
PUSHJ P,SGSORT ;SORT IT INTO LIST
SGTST:
CAIGE A,(SP) ;DONE?
JRST STRNGSTACKMARKLOOP ;NO
GPOPJ: POPJ P, ;YES, GO ON TO NEXT TYPE
; ------ SAIL COMPILER SPECIAL SORTERS ARE IN COMSER ------
; ------ SORT THE VARIABLES ------
HERE (%STRMRK)
SKIPN T,STRLNK(USER) ;GET LINK
POPJ P, ; NO STRINGS AT ALL
STMKL1: HRRZ A,-1(T);< ;=>1ST STRING
HLRZ Q2,-1(T) ;# STRINGS THIS PROC
JRST SOJLP ;GO LOOP
STMKLP: PUSHJ P,SGSORT ;SORT VARIABLES INTO LIST
SOJLP: SOJGE Q2,STMKLP ;SORT UNTIL DONE WITH THIS PROC (SGSORT INCRS A)
STRMK4: HRRZ T,(T) ;NEXT PROCEDURE
JUMPN T,STMKL1 ; IF THERE IS ONE
POPJ P, ;DONE
COMMENT *
------ SORT STRING ARRAYS ------
THIS ROUTINE TRIPS DOWN THE DYNAMIC LINKS, LOOKING INTO
PROCEDURE DESCRIPTORS FOR STRING ARRAYS WHICH MIGHT HAVE BEEN ALLOCATED.
THEN IT LOOKS FOR ANY ARRAYS OWNED BY LEAP. THE FIRST
WORD OF EACH ARRAY BLOCK IS THE NUMBER OF DIMENSIONS IF THE
ARRAY IS A STRING ARRAY. THE WORD JUST PREVIOUS TO IT IS THE
(NEGATIVE) SIZE OF THE ARRAY.
*
INTERNAL %ARRSRT
HERE (%ARRSRT)
; HRRZ RF,RACS+RF(USER);REAL RF WITH LH= 0 (ASSUME SET UP 12-3-73)
^%ARSR1:
PROCDO: HLRZ Q1,1(RF) ;FETCH PDA
CAIN Q1,SPRPDA ;IS IT SPROUTER??
POPJ P, ;YES
MOVE Q1,PD.LLW(Q1) ;WE HAVE TO DO SOMETHING -- PT AT LVI
CHK: SKIPN T,(Q1) ;GET ENTRY
JRST GODOWN ;0 MEANS OF PROC DESCR
;;#HI#.! 5-15-72 DCS WAS TESTING 200000 (TYPE 4?) BIT, WRONG BIT!
TLC T,100000 ;TYPE 2? (STRING ARRAY)
TLNE T,740000 ;
AOJA Q1,CHK ;NO
SKIPN A,@T ;THERE??
AOJA Q1,CHK ;NO
;;# # 5-3-72 DCS
SUBI A,1;< ;A=>2D WORD, FIRST ENTRY -- DCS 5-3-72
;;# #
SKIPL Q2,-1(A) ;BETTER BE THERE
ERR <DRYROT at Arrsrt>
PUSHJ P,ARPUTX ;GO SORT IT
AOJA Q1,CHK
GODOWN: HRRZ RF,(RF) ;NOTE THAT RESTR WILL PUT RF BACK
CAIE RF,-1 ;
JRST PROCDO ;-1 WILL SAY END
LARR: SKIPN E,ARYLS(USER) ;LEAPING LISTS
POPJ P, ;NONE
LAR1:
HLRZ Q2,(E) ;GET ADDRESS
;;# # 5-3-72 DCS SET UP A
MOVEI A,-1(Q2);< ;A=>1ST WORD, FIRST ENTRY
;;# #
SKIPL Q2,-2(Q2) ;BE SURE
ERR <DRYROT -- LEAPing error at ARRSRT>
PUSHJ P,ARPUTX ;GO SORT IT
LAR2: HRRZ E,(E) ;MERRILY WE LINK ALONG
JUMPN E,LAR1 ;
POPJ P, ;HOME AT LAST
ARPUTX:
HRRZS Q2 ;YES, GET TOTAL SIZE
LSH Q2,-1 ;NUMBER OF STRINGS
JRST ARSLP
ARS3: PUSHJ P,SGSORT ; BUT COLLECT NON-CONSTANTS
ARSLP: SOJGE Q2,ARS3 ;A INCREMENTED IN SGSORT, LOOP UNTIL DONE
POPJ P, ;ALL DONE WITH THIS ARRAY.
;STRNGC Service routines -- SRTSPC -- space sorter
;Space Sorter
;<** B => A string space, descriptor list is .list(b)
SRTSPC: MOVE A,STBUCK(USER) ;Clear bucket list
SETZM (A)
ADDI A,1
HRLI A,-1(A)
MOVEI C,BKSZ-2(A)
BLT A,(C)
SKIPN A,.LIST(B)
JRST SORTED
;<** A => word 1 of NEW descriptor
DSCLUP: AOS SGCNUM(USER) ;Count strings handled.
HLRZ FF,(A)
MOVE C,1(A)
MOVE E,C ;For later (below)
IMULI C,MLT
IDIV C,.SIZE(B) ;Compute bucket entry
ADD C,STBUCK(USER) ; (partition space among bckts)
MOVE Q1,C
HRRZ T,(A)
SGSLUP: MOVE D,C
HLRZ C,(C)
;<** Q1 => bucket entry, for end-pointer maintenance (just below)
;<** D => PREV descriptor, which has been seen
;<** C => NEXT descriptor, to be examined
;** E is starting count of NEW rel. to this space
;** T is length(NEW)
;Sort NEW into this bucket list such that its starting count is >=
; all which precede it, <= all which follow it. Where starting
; counts are equal, sort by descending length. This creates nests
; of strings to be handled by the sweep phase.
JUMPE C,[HRRM A,(Q1) ;** NEW will be end string,
JRST INSERT] ; keep track of it for linkage
CAMGE E,1(C)
JRST INSERT ;NEW begins before NEXT, insert
CAME E,1(C)
JRST SGSLUP ;NEW begins after NEXT, keep looking
HRRZ TEMP,(C)
CAMG T,TEMP ;Insert by descending length
JRST SGSLUP
; (JRST INSERT)
;<** A => NEW, 1st word
;<** C => NEXT, 1st word, or is 0
;<** D => PREV, 1st word, or bucket
;** E is start count from descriptor
;Standard one-way linked list insertion
INSERT: HRLM A,(D)
HRLM C,(A) ;Link is in lh of word 2 of descriptor
;Sort next descriptor from this space
MOVE A,FF
JUMPN A,DSCLUP
;Now use list pointers in buckets
; (each is <first,,last>)
; to create one sorted list -- store in .LIST(this space)
SORTED: MOVE C,STBUCK(USER) ;Starting at the end of the bucket
HRLI C,D ; array, look only at non-zero
MOVEI D,BKSZ-1 ; entries. Each iteration, retain
MOVEI A,0 ; the newest <first> pointer, having
LNKLUP: SKIPN E,@C ; placed the previous <first> pointer
JRST AOCHK ; into the list identified by the
HRLM A,(E) ; newest <last> pointer. The first
HLRZ A,E ; <first> pointer is 0
AOCHK: SOJGE D,LNKLUP
MOVEM A,.LIST(B)
POPJ P,
;STRNGC Service routines -- SOURCE and DEST
;SOURCE:
;<** B => source space
;<** .LIST(B) => first descriptor of next nest to move, or 0 (space done)
;
; 1. Move to next space, if necessary -- this one done. No-skip if no more.
; 2. Create BP to start of nest, save. Save first space-relative count.
; 3. Move down list, identify end of nest -- convert all descriptor
; counts to nest-relative counts
; 4. Update .LIST
; 5. Skip (found a nest) Return:
; A -- BP to source string (nest)
; D -- total # chars in nest
;< E -- =>first in nest -- last link in nest zeroed
; 6. Non-skip (no more nests) Return.
; 7. Don't change C!!!
SOURCE: MOVE E,.LIST(B)
JUMPE E,[SKIPN B,.NEXT(B)
POPJ P, ;no-skip, return
JRST SOURCE]
MOVE Q1,1(E)
IDIVI Q1,5
ADD Q1,B
HLL Q1,[PTBL1: POINT 7,0 ;!HOOK! IF PTBL OF SUBSTR AVAIL,
POINT 7,0,6 ; declare it external and use it
POINT 7,0,13 ; here -- tables are the same
POINT 7,0,20
POINT 7,0,27
POINT 7,0,35](Q2)
PUSH P,Q1
HRLS E
MOVN A,1(E)
HRRZ D,(E)
SUB D,A
ADDM A,1(E) ;Adjust 1st descr. location count to nest-rel.
;** A is -(nest start char)
;** D is Nest end char +1
;<<** E is => first elt of nest,, => current elt.
;** First nest descriptor already count-relative adjusted
;Loop until a descriptor is not in the nest
SRCLUP: HLRZ Q1,(E) ;Next elt.
JUMPE Q1,NONEST ;If end-loc in D does not reach the next
CAMG D,1(Q1) ; descriptor's location, nest is done
JRST NONEST ;(Adjoining, non-overlapping nests must be
HRRZ TEMP,(Q1)
ADD TEMP,1(Q1) ; moved separately because of full-word reqmt.
CAMGE D,TEMP ;Adjust nest-end location, if new string
MOVE D,TEMP ; extends beyond old nest
ADDM A,1(Q1) ;Adjust location count to nest-relative.
HRR E,Q1 ;Will be last descriptor in nest at NONEST
JRST SRCLUP
NONEST: HRRZM Q1,.LIST(B) ;Update list, retrieve BP, compute length,
HRRZS (E) ;Clear last elt in nest
HLRZS E ;Return ptr. to 1st, as advertised
ADD D,A ; skip-return as advertised
POP P,A
AOS (P)
POPJ P,
;DEST:
;** B inviolate
;<** C => dest space
;** TOPBYTE(USER) is free in current dest space
;** REMCHR(USER) is -(number remaining) in current dest space
;<** E is =>first in nest -- last elt. is zeroed
;** D is nest size in chars
;** A is nest source byte pointer
; 1. Adjust to FW bdry if SGLIGN
; 2. Find room, this dest space or next -- error if out of spaces.
; 3. Adjust REMCHR
; 4. Move nest, adjust TOPBYTE
; 5. Recreate BP for each descriptor
;[clh] This routine originally distinguished between Q1, the real length,
; and D, the length rounded to a multiple of 5 if SGLIGN was on.
; They copied D characters and adjusted REMCHR by D, but adjusted
; TOPBYTE by Q1. Then they called INSET, to adjust TOPBYTE up to
; a word boundary (and incidentally overadjust REMCHR, since it had
; already used the adjusted D). By using only the rounded
; quantity, the need to call INSET is eliminated. And the problem
; of overadjusting REMCHR goes away.
DEST: ;[clh] MOVE Q1,D ;SAVE LENGTH
;** Q1 is original nest length, will remain so until FIXLP 1st pass
DEST1: SKIPN SGLIGN(USER)
JRST NOLIGN
;[clh] PUSHJ P,INSET ;Inset aligns TOPBYTE to full word,
PUSH P,D+1 ; but it should already be there really.
ADDI D,4 ;Move smallest multiple of 5 characters
IDIVI D,5 ; which hold nest.
IMULI D,5
POP P,D+1
;** D is nest length, possibly adjusted for sglign
NOLIGN: MOVE Q1,D ;[clh] save for later accounting
ADDM D,REMCHR(USER) ;Standard room test
SKIPGE REMCHR(USER)
JRST ISROOM
;!HOOK! If you decided to move the DEST being left (in DSTSET, see below),
; Do it now. Move it to (C)+OFFSET(USER).
NOROOM: PUSHJ P,WASTE ;Count waste in space being left
;; \UR#29\ JRL (8-7-78) (3 OF 5) SAVE TOPBYTE IN STRING BLOCK BEFORE
;; ABANDONING IT.
MOVE TEMP,TOPBYTE(USER)
MOVEM TEMP,.TOPBYTE(C)
;; \UR#29\
HRRZ C,.NEXT(C) ;Since we are moving strings "down",
JUMPE C,[ERR <DRYROT -- No more room for strings -- very strange>]
; running out of already existent
PUSHJ P,DSTSET ; space is a fatal error.
JRST DEST1 ;Try again, C, REMCHR, TOPBYTE are adjusted.
ISROOM: MOVE FF,TOPBYTE(USER)
CAME A,FF ;Avoid moving the nest to its previous
JRST MVTST ; location (expensive NO-OP).
JRST MVDON
MVLP: ILDB TEMP,A
IDPB TEMP,FF
MVTST: SOJGE D,MVLP
MOVE FF,TOPBYTE(USER) ;FF_BP of first char
MVDON: MOVSI A,40 ; in destination nest
MOVE D,E ;First, adjust TOPBYTE, then
MOVEI E,TOPBYTE-1(USER) ; the strings of the nest
LDB TEMP,[POINT 3,FF,5]
;<**E => current descriptor in nest or topbyte, starting with latter
;**A's LH is non-zero "string number" value -- strings aren't constants
;**FF is BP to 1st nest destination character.
;For each descriptor, Store string number, create a new byte pointer
; (algorithm stolen from SUBSTR routine)
TRC TEMP,4
JRST FIXTOP ;Start in middle to get topbyte
FIXLP: HLRZ D,(E)
;<**D => next descriptor
;**TEMP is character offset of FF-pointer in its word (for computing BP's)
HLLM A,(E) ;Update string number
MOVE Q1,1(E) ;Compute new BP -- see SUBSTR in STRSER
FIXTOP: MOVE T,FF
ADD Q1,TEMP
CAILE Q1,4
JRST [CAILE Q1,9
JRST [IDIVI Q1,5
ADD T,Q1
HLL T,PTBL1(Q2)
JRST PTWY]
SUBI Q1,5
AOJA T,.+1]
HLL T,PTBL1(Q1)
PTWY:
;!HOOK! ADD T,OFFSET(USER) ;activate when space-moving becomes reality.
;; !! But topbyte fix is messed up some by this, watch it.
MOVEM T,1(E) ;Store new BP, to descriptor or topbyte
MOVE E,D ;loop
JUMPN E,FIXLP
POPJ P,
;DSTSET:
;<** C => destination space
;Result: TOPBYTE(USER) is destination byte pointer -- to beginning of space
; REMCHR(USER) is -(size of space in characters)
DSTSET: HRLI C,(<POINT 7,0>)
MOVEM C,TOPBYTE(USER)
MOVN TEMP,.SIZE(C)
IMULI TEMP,5
MOVEM TEMP,REMCHR(USER)
;!HOOK! This is probably the best place to decide, perhaps to minimize
; checkerboarding or memory use, that the DEST just prepared should be
; moved to a new location. This move will not happen until the space
; has been filled, and all descriptors for it adjusted. Decide where
; to move the block, then put the difference between its future location
; and its current one into OFFSET(USER). The DEST routine will use this
; to adjust all descriptor byte pointers.
POPJ P,
;When leaving a DEST for a new one, keep track of the unfilled space
; within that space.
WASTE: PUSH P,TEMP+1
MOVN TEMP,REMCHR(USER) ;Unused characters this space
IDIVI TEMP,5 ;Just rough estimate.
POP P,TEMP+1
ADDM TEMP,SGCWASTE(USER)
POPJ P,
;STRNGC Service routines -- SGINS and SGREM
;Sgins, Sgrem
DSCR SGINS
CAL PUSHJ
PAR PUSH P,[routine name]
PUSH P,[addr of 2-word block]
RES block is used to place routine in the list of descriptor generators
for CALSG.
SID stack adjusted
HERE(SGINS)
PUSH P,-2(P) ;ADDR OF ROUTINE
PUSHJ P,SGREM ;NEVER LET IT BE IN TWICE
MOVE USER,GOGTAB
POP P,UUO1(USER)
POP P,LPSA;< ;=>LINK BLOCK FOR NEW ROUTINE
POP P,-1(LPSA) ;PUT ROUTINE ADDRESS AWAY
HRL LPSA,SGROUT(USER);GET OLD LINK POINTER
HLRM LPSA,(LPSA) ;PUT IN NEW LINK POSITION
HRRM LPSA,SGROUT(USER);PUT NEW POINTER IN LINK HEAD
JRST @3(P) ;RETURN
DSCR SGREM
CAL PUSHJ
PAR PUSH P,[routine addr]
RES routine is removed from list of descriptor generators, if it was on it
HERE(SGREM)
MOVE USER,GOGTAB
POP P,UUO1(USER)
POP P,TEMP ;ADDR TO BE REMOVED
MOVEI LPSA,SGROUT(USER);HEAD OF LIST
SGRL: MOVE USER,LPSA ;PREV_THIS
SKIPN LPSA,(USER) ;THIS_(PREV)
JRST @2(P) ;DIDN'T FIND IT
CAME TEMP,-1(LPSA) ;IS THIS THE ROUTINE?
JRST SGRL ;NO, GET NEXT
HRRZ TEMP,(LPSA) ;YES, REMOVE IT FROM LIST
HRRM TEMP,(USER)
JRST @2(P)
;STRNGC Service routines -- STCLER and RESCLR
DSCR STCLER
CAL PUSHJ
RES Clears all string variables on STRLNK(USER) to null strings
DES compiler only
HERE(STCLER) ;
SKIPE SGLIGN(USER) ;CLEAR REST?
PUSHJ P,RESCLR ;CLEAR REST OF STRING SPACE
SKIPN T,STRLNK(USER) ;PARALLELS STRNGC'S LOOP
POPJ P, ;CLOSELY
PUSH P,B ;JUST IN CASE
HRLZI B,-1 ;FOR TESTING STRING NO.
STC1: HRRZ A,-1(T)
HLRZ Q2,-1(T)
STCLLP: SOJL Q2,STCLD1
TDNE B,(A) ;DON'T COLLECT STRING CONSTANTS
SETZM (A)
ADDI A,2
JRST STCLLP
STCLD1: HRRZ T,(T)
JUMPN T,STC1
POP P,B
POPJ P,
DSCR RESCLR
CAL PUSHJ
DES Used after STRNGC. Clears remaining string space to 0 (compiler only)
RESCLR: SKIPL A,TOPBYTE(USER) ;CAN ZERO FIRST WORD IF 440700
ADDI A,1 ;ELSE START AT NEXT
SETZM (A)
HRLS A
ADDI A,1 ;BLT WORD
MOVE B,STTOP(USER) ;END OF STRING SPACE
BLT A,-1(B) ;ZERO!!
POPJ P,
INTERNAL BRKMSK
^BRKMSK: 0
FOR @& JJ_=17,0,-1 <
<1 (JJ+=18)> + (1 JJ)>
>;NOLOW
ENDCOM (SGC)
IFN ALWAYS,<
NOLOW <
^CORGET_CORGET
>;NOLOW
>;IFN ALWAYS
SUBTTL GOGOL
SUBTTL Some Runtime Routines Which Could Go Nowhere Else
DSCR BEGIN GOGOL
DES RUN-TIME ROUTINES WILL BE DESCRIBED BY SAIL MANUAL CALLING SEQUENCES ONLY
NOLOW <
IFN ALWAYS,<BEGIN GOGOL>
>;NOLOW
COMPIL(KNT,<K.ZERO,K.OUT>,<GETCHAN,GOGTAB>
,<K.ZERO, K.OUT -- PERFORMANCE COUNTING ROUTINES>)
COMMENT Kounter Routines
DSCR K.ZERO -- Zero out counters
CAL PUSHJ P,K.ZERO
RES The counter arrays of the sail program loaded are set to zero.
K.ZERO determines the location of the counter blocks via the loader
link chain (5) whose head is in the location KNTLNK(USER). If there
are no counters, the routine is essentially a NO-OP. SID All
registers used by K.ZERO are saved on entry and restored on exit. SEE
K.OUT
HERE(K.ZERO)
PUSH P,2 ;SAVE REGISTER 2
MOVE USER,GOGTAB
SKIPN 2,KNTLNK(USER) ;GET LINK TO COUNTERSS
JRST K.ZR2 ;THERE ARE NONE
PUSH P,3 ;SAVE OTHER REGS NEEDED
PUSH P,4
PUSH P,5
K.Z1: MOVE 3,2(2) ;GET SECOND IOWD OF HEADER BLOCK
MOVEI 4,2(3) ;GET <.KOUNT+1>
HRLI 4,-1(4) ;GET READY FOR BLT
HLRO 5,3 ;GET -COUNT
MOVN 5,5 ;MAKE THAT +COUNT
HRLI 5,3 ;PUT AN INDEX FIELD OF 3
SETZM -1(4) ;ZERO THE FIRST COUNTER
BLT 4,@5 ;ZERO THE REST
SKIPE 2,(2) ;GET THE NEXT SET OF COUNTERS
JRST K.Z1 ;ZERO THEM
POP P,5 ;RESTORE THE REGISTERS
POP P,4
POP P,3
K.ZR2: POP P,2
POPJ P, ;RETURN
DSCR K.OUT -- Write out counters
CAL PUSHJ P,K.OUT
RES The values of the statement counters are written out to the
disk. The IOWDs used to write them are also written out in
order to be able to know how many to read back in. The filename
is obtained from the header block of the first program loaded.
The data blocks have the following form:
--------------------------
| SIXBIT /FILNAM/ |
--------------------------
| LINK to other blocks |
--------------------------
| IOWD 1,.+1 |
--------------------------
| IOWD n,.KOUNT |
--------------------------
| 0 |
--------------------------
.KOUNT: | 1st counter |
--------------------------
| . . . |
| . . . |
--------------------------
| nth counter |
--------------------------
SID No registers are permanently modified.
HERE(K.OUT)
NOTENX<
MOVE USER,GOGTAB
SKIPN KNTLNK(USER) ;ARE THERE ANY COUNTERS
POPJ P, ;NO
COMMENT First save registers 0-16
MOVEM 16,17(P) ;SAVE IN THE STACK
MOVEI 16,1(P) ;GET READY TO STORE 0-15
BLT 16,16(P) ;DO IT
ADD P,[XWD 17,17] ;ADJUST STACK POINTER
TLNN P,400000 ;CHECK FOR OVERFLOW
ERR <PDL overflow in K.OUT routine>
COMMENT Before the counters can be written out, it
is necessary to chain the blocks together in the
proper direction. Recall that there will be multiple
blocks only if the core image is the result of loading
multiple compilatons.
MOVE 2,KNTLNK(USER) ;GET LINK TO LAST BLOCK
SKIPN 1,(2) ;GET LINK TO PREV.
JRST .+5 ;THAT'S ALL
MOVEI 0,1(2) ;GET ADDR OF 1st IOWD OF THIS BLOCK
MOVEM 0,3(1) ;STORE BELOW 2nd IOQS OF PREV BLOCK
MOVE 2,1 ;CONTINUE
JRST .-5
COMMENT At this point, 1(2) contains the start of a dump
mode command chain that will write out all of the counters.
-1(2) contains the filename for the counter file.
PUSHJ P,GETCHAN ;GET AN AVAILABLE CHANNEL
JUMPL 1,K.OERR ;NONE AVAILABLE
MOVE 0,[XWD K.OD1,3] ;MOVE CODE TO REGISTERS
BLT 0,16 ;SO THAT IT CAN BE SAFELY MODIFIED
DPB 1,[POINT 4,3,12] ;STORE CHANNEL NUMBER IN OPEN INSTR
DPB 1,[POINT 4,5,12] ;STORE CHANNEL NUMBER IN ENTER INSTR
MOVE 10,-1(2) ;PICK UP FILE NAME
JRST 3 ;OPEN AND ENTER,HOPEFULLY RETURNING TO .+1
K.O1: MOVE 0,[XWD K.OD2,3] ;DO IT AGAIN
BLT 0,7
DPB 1,[POINT 4,3,12] ;OUT INSTRUCTION
DPB 1,[POINT 4,6,12] ;RELEAS INSTRUCTION
JRST 3
COMMENT The counters have been written out to the disk. It's
time to restore the registers and go home.
K.O2: MOVSI 16,-16(P) ;PREPARE TO RESTORE REGS
BLT 16,16 ; FROM THE STACK
SUB P,[XWD 17,17] ;ADJUST STACK POINTER
POPJ P, ;RETURN
K.OERR: IOERR <I/O error in writing counter file>
COMMENT The following instructions are moved into
registers before they are executed, since the "channel"
portion of them must be modified at run time.
K.OD1: OPEN 0,14 ;(3) OPEN DISK ON SPECIFIED CHANNEL
JRST K.OERR ;(4) TROUBLE
ENTER 0,10 ;(5)
JRST K.OERR ;(6) RIGHT HERE IN RIVER CITY
JRST K.O1 ;(7) READY TO WRITE 'EM OUT
0 ;(10) FILLED IN WITH FILE NAME
SIXBIT /KNT/ ;(11) EXTENSION
0 ;(12)
0 ;(13)
17 ;(14) DUMP MODE
SIXBIT /DSK/ ;(15) DEVICE DISK
0 ;(16) NO BUFFERS
K.OD2: OUT 0,1(2) ;(3) WRITE OUT COUNTERS
JRST 6 ;(4) ALL OK
JRST K.OERR ;(5) PROBLEMS
RELEAS 0 ;(6) CLOSE FILE
JRST K.O2 ;(7) GO BACK TO K.OUT
>;NOTENX
TENX<;TENEX VERSION OF K.OUT
MOVE USER,GOGTAB
SKIPN KNTLNK(USER) ;ANY KOUNTERS?
POPJ P,
COMMENT SAVE ACS 0-14
;
MOVEM 14,15(P)
MOVEI 14,1(P)
BLT 14,14(P)
ADD P,[XWD 15,15]
TLNN P,400000 ;OVERFLOW?
ERR <PDL overflow in K.OUT routine>
COMMENT Chain the counters together as above.
;
MOVE 2,KNTLNK(USER)
SKIPN 1,(2)
JRST .+5
MOVEI 0,1(2)
MOVEM 0,3(1)
MOVE 2,1
JRST .-5
COMMENT
At this point, 1(2) contains the start of a DEC-style
dump mode command chain that will be used to write out the
counters. -1(2) contains the sixbit for the file name.
;
MOVE 5,2 ;SAVE POINTER TO THE CHAIN
PUSH P,-1(5) ;SIXBIT/FILENAME/
PUSHJ P,CVXSTR ;GET ASCII
PUSH P,[0]
PUSHJ P,CATCHR ;PUT A NULL BYTE ON THE END
POP SP,2 ;BP TO 2 FOR GTJFN
SUB SP,X11 ;CLEAR SP STACK
MOVEI 1,EKNT ;LONG FORM
JSYS GTJFN
JRST KNTERR ;GTJFN ERROR
MOVE 2,[XWD 440000,100000] ;36 BIT WRITE
JSYS OPENF ;JFN REMAINS IN 1
JRST KNTERR ;OPENF ERROR
;5 HAS THE START OF A DUMP-MODE COMMAND CHAIN, WHICH WE MUST
;INTERPRET INTO SOUT'S
MOVEI 4,1(5) ;START OF COMMAND LIST
KNTLUP: MOVE 3,(4)
JUMPE 3,KNTDUN ;0 COMMAND MEANS TO STOP
TLNE 3,-1 ;0 LEFT HALF MEANS GOTO
JRST KNTOUT ;REAL IO WORD
MOVE 4,3 ;OK DO THE GOTO
JRST KNTLUP
KNTOUT: HRRI 2,1(3) ;FIRST LOCATION
HRLI 2,444400 ;MAKE A BP
HLRO 3,3 ;WORD COUNT
JSYS SOUT
AOJA 4,KNTLUP
KNTDUN: JSYS CLOSF ;CLOSE OUT THE FILE
JFCL ;ERROR RETURN
KNTRET: MOVSI 14,-14(P) ;RESTORE ACS
BLT 14,14
SUB P,[XWD 15,15]
POPJ P, ;AND RETURN
KNTERR: ERR <K.OUT: Cannot GTJFN or OPENF file>,1
JRST KNTRET
EKNT: XWD 400000,0 ;NEW VERSION
XWD 377777,377777 ;NO EXTRA JFNS
BLOCK 3
XWD -1,[ASCIZ/KNT/] ;DEFAULT VERSION IS .KNT
BLOCK 3
>;TENX
ENDCOM (KNT)
COMPIL(POW,<FPOW,POW,LOGS,FLOGS,EXP$,LOG$>
,<X11,X22,X33,OVPCWD>,<POW, FPOW, LOGS, FLOGS -- EXPON. ROUTINES>)
DSCR POW, FPOW, LOGS, FLOGS. BOTH RETURN REALS.
SID CLOBBERS LPSA,TEMP,USER
CAL SAIL
DES CALLS GENERATED BY COMPILER FOR ^ OPERATOR
FPOW: REAL_FPOW(INTEGER!EXPONENT,REAL!BASE)
POW: REAL_ POW(INTEGER!EXPONENT,INTEGER!BASE)
LOGS: REAL_ LOGS(REAL!EXPONENT,INTEGER!BASE)
FLOGS: REAL_FLOGS(REAL!EXPONENT,REAL!BASE)
SPECIAL CASES:
A^0 = 1
0^B = 0 IF B GEQ 0.
0^B = INF. IF B<0 ; MESSAGE PRINTED
A^B = (-1)^B*|A|^B IF A<0, B INTEGRAL
A^B = REALPART(A^B) IF A<0, B NOT INTEGRAL ; MESSAGE
MESSAGE IS PRINTED IF OVERFLOW OR UNDERFLOW HAPPENS.
IN THIS CASE, FIXUP IS MADE SO THAT ANSWER IS EITHER 0, +INF, OR
-INF.
IFN ALWAYS,< BEGIN UTILS>
HERE(FPOW)
SKIPA USER,-1(P) ;BASE
HERE(POW)
FLOAT USER,-1(P)
FPX: MOVM LPSA,-2(P) ;GET ABS(EXPONENT)
JUMPE LPSA,EXZERO ;0 EXPONENT
MOVSI A,(1.0) ;SET FOR FLOATING
JRST 2,@[FEXS] ;CLEAR AR FLAGS
FEXL: ASH LPSA,-1 ;PREPARE TO LOOK AT NEXT BIT.
FMPR USER,USER ;SQUARE BASE
JFOV FPOWOV ;OVERFLOW/UNDERFLOW
FEXS: TRZE LPSA,1 ;COLLECT PRODUCT?
FMPR A,USER ;YES
JFOV FPOWOV ;OVERFLOW?
JUMPN LPSA,FEXL ;LOOP UNTIL EXPONENT ZERO.
SKIPGE -2(P) ;POSITIVE EXPONENT?
JRST FEXDU1
POWRET: SUB P,X33
JRST @3(P)
FEXDU1: MOVM LPSA,A ;CHECK FOR OVERFLOW POSS.
CAMGE LPSA,[XWD 2400,1] ;SMALL NUMBER
JRST FPDOV ;CALL UNDERFLOW
MOVSI LPSA,(1.0) ;TAKE RECIPROCAL OF ANS.
FDVRM LPSA,A
JRST POWRET ;AND RETURN IT.
EXZERO: SKIPN USER ;0^0
ZRET: TDZA A,A ;RETURN 0
MOVSI A,(1.0) ;RETURN FLOATING 1
JRST POWRET
FPOWOV: SKIPN TEMP,OVPCWD ;IF TRAPS ENABLED, USE EM
JSP TEMP,.+1 ;ELSE GET FLAGS THIS WAY
TLNE TEMP,100 ;SKIP IF NOT UNDERFLOW
FPDOV: MOVNS -2(P) ;UNDERFLOW -- CHANGE EXPONENT SIGN.
MOVE A,[XWD 400000,1] ;LARGE NEGATIVE NUMBER
SKIPG TEMP,-2(P) ;CHECK SIGN OF EXPONENT.
MOVEI A,0 ;NEGATIVE ==> RESULT 0.
SKIPGE -1(P) ;CHECK SIGN OF BASE.
TRNN TEMP,1 ;XOR SIGN OF EXPONENT.
MOVNS A ;MAKE +- LARGE NUMBER
ERR <Exponentiation under or overflow>,1
JRST POWRET ;RETURN.
HERE(FLOGS)
.FLOGS: SKIPA USER,-1(P) ;FLOATING BASE
HERE(LOGS)
.LOGS: FLOAT USER,-1(P) ;FLOAT THE BASE
SKIPN -2(P) ;IF ZERO EXPONENT,
JRST EXZERO ;GO TO COMMON CODE.
MOVM TEMP,-2(P) ;CHECK TO SEE IF 'FIX' WILL
CAMLE TEMP,C1 ;OVERFLOW
JRST USLGEP ;YES -- GO TO LOG-EXP
FIX TEMP,-2(P) ;CHECK TO SEE IF EXPONENT
FLOAT LPSA,TEMP ;HAPPENS TO BE AN INTEGER
CAMN LPSA,-2(P) ;IF SO, USE LOOPS TO
JRST [MOVEM TEMP,-2(P) ;BE SURE OF CORRECT SIGN
JRST FPX]
USLGEP: JUMPE USER,[SKIPGE -2(P) ;IF BASE ZERO, AND EXPT NEG.
JRST FPDOV ;RETURN LARGE NUMBER
JRST ZRET] ;ELSE RETURN ZERO.
PUSH P,USER ;ARGUMENT TO 'ALOG'
PUSHJ P,.LOG ;CALL IT.
FMPR A,-2(P) ;MULTIPLY BY EXPONENT
PUSH P,A ;ARGUMENT TO 'EXP'
PUSHJ P,.EXP ;CALCULATE
JRST POWRET ;AND RETURN.
C1: 243777777777 ;2^35 - EPSILON
PRINTX INSTALL DPOW,DLOGS HERE
DSCR EXP,ALOG -- FOR USE BY EXPONENTIATION ROUTINES & WORLD
SID CLOBBERS LPSA,TEMP,USER
CAL SAIL
;FLOATING POINT SINGLE PRECISION EXPONENTIAL FUNCTION
;THE ARGUMENT IS RESTRICTED TO THE FOLLOWING RANGE
; -88.028<X<88.028
;IF X<-88.028, THE PROGRAM RETURNS ZERO AS THE ANSWER
;IF X<88.028, THE PROGRAM RETURNS X AS THE ANSWER
;THE RANGE OF THE ARGUMENT IS REDUCED AS FOLLOWS:
;EXP(X) = 2**(X*LOG(E)BASE2) = 2**(M+F)
;WHERE M IS AN INTEGER AND F IS A FRACTION
;2**M IS CALCULATED BY ALGEBRAICALLY ADDING M TO THE EXPONENT
;OF THE RESULT OF 2**F. 2**F IS CALCULATED AS
;2**F = 2(0.5+F(A+B*F^2 - F-C(F^2 + D)**-1)**-1
;THE ROUTINE HAS THE FOLLOWING CALLING SEQUENCE:
; PUSH P,ARG
; PUSHJ P,EXP
;THE ANSWER IS RETURNED IN ACCUMULATOR A
HERE(EXP$)
.EXP: PUSH P,[0] ;ONE WORKING CELL
PUSH P,B ;AND ONE SAVED AC
MOVE LPSA,-3(P) ;GET ARGUMENT
MOVM A,LPSA ;GET ABSF(X)
CAMG A, E7 ;IS ARGUMENT IN PROPER RANGE?
JRST EXP1 ;YES, GO TO ALGORITHM
ERR <EXP: under or overflow>,1
HRLOI A, 377777 ;GET LARGEST FLOATING NUMBER
SKIPG LPSA ;WAS THE ARGUMENT POSITIVE?
MOVEI A, 0 ;NO, RETURN 0
JRST EXPXIT ;AND RETURN
EXP1: MULI LPSA,400 ;SEPARATE FRACTION AND EXPONENT
TSC LPSA,LPSA ;GET A POSITIVE EXPONENT
MUL TEMP,E5 ;FIXED POINT MULTIPLY BY LOG2(E)
ASHC TEMP,-242(LPSA) ;SEPARATE FRACTION AND INTEGER
AOSG TEMP ;ALGORITHM CALLS FOR MULT. BY 2
AOS TEMP ;ADJUST IF FRACTION WAS NEGATIVE
HRRM TEMP,B ;SAVE FOR FUTURE SCALING
JUMPG USER,ASHH ;GO AHEAD IF ARG GREATER THAN 0
TRNN USER,377 ;ALL THESE BITS 0?
JRST ASHH ;YES -- GO AHEAD
ADDI USER,200 ;NO -- FIX UP
ASHH: ASH USER, -10 ;MAKE ROOM FOR EXPONENT
TLC USER, 200000 ;PUT 200 IN EXPONENT BITS
FADB USER, -1(P) ;NORMALIZE, RESULTS TO USER AND E
FMP USER,USER ;FORM X^2
MOVE A, E2 ;GET FIRST CONSTANT
FMP A, USER ;E2*X^2 IN A
FAD USER, E4 ;ADD E4 TO RESULTS IN USER
MOVE LPSA, E3 ;PICK UP E3
FDV LPSA,USER ;CALCULATE E3/(F^2 + E4)
FSB A,LPSA ;E2*F^2-E3(F^2 + E4)**-1
MOVE TEMP,-1(P) ;GET F AGAIN
FSB A, TEMP ;SUBTRACT FROM PARTIAL SUM
FAD A, E1 ;ADD IN E1
FDVM TEMP, A ;DIVIDE BY F
FAD A, E6 ;ADD 0.5
FSC A, (B) ;SCALE THE RESULTS
EXPXIT: POP P,B ;RESTORE AC
SUB P,X33 ;ADJUST STACK
JRST @2(P) ;RETURN.
E1: 204476430062 ;9.95459578
E2: 174433723400 ;0.03465735903
E3: 212464770715 ;617.97226953
E4: 207535527022 ;87.417497202
E5: 270524354513 ;LOG(E), BASE 2
E6: 0.5
E7: 207540071260 ;88.028
;FLOATING POINT SINGLE PRECISION LOGARITHM FUNCTION
;LOG(ABSF(X)) IS CALCULATED BY THE SUBROUTINE, AND AN
;ARGUMENT OF ZERO IS RETURNED AS MINUS INFINITY. THE ALGORITHM IS
;LOGE(X) = (I + LOG2(F))*LOGE(2)
;WHERE X = (F/2)*2^(I+1), AND LOG2(F) IS GIVEN BY
;LOG2(F) = C1*Z + C3*Z^3 + C5*Z^5 - 1/2
;AND Z = (F-SQRT(2))/(F+SQRT(2))
;THE CALLING SEQUENCE FOR THE ROUTINE IS AS FOLLOWS:
; PUSH P,ARG
; PUSHJ P, LOG
;THE ANSWER IS RETURNED IN ACCUMULATOR A
HERE(LOG$)
.LOG:
SKIPGE -1(P) ;CHECK SIGN OF ARGUMENT.
ERR <LOG: Negative argument -- real part returned>,1
MOVM LPSA,-1(P) ;GET ABSF(A)
JUMPE LPSA, LZERO ;CHECK FOR ZERO ARGUMENT
CAMN LPSA, ONE ;CHECK FOR 1.0 ARGUMENT
JRST ZERANS ;IT IS 1.0 RETURN ZERO ANS.
ASHC LPSA, -33 ;SEPARATE FRACTION FROM EXPONENT
ADDI LPSA, 211000 ;FLOAT THE EXPONENT AND MULT. BY 2
MOVSM LPSA,USER ;NUMBER NOW IN CORRECT FL. FORMAT
MOVSI LPSA, 567377 ;SET UP -401.0 IN LPSA
FADM LPSA,USER ;SUBTRACT 401 FROM EXP.*2
ASH TEMP, -10 ;SHIFT FRACTION FOR FLOATING
TLC TEMP, 200000 ;FLOAT THE FRACTION PART
FAD TEMP, L1 ;TEMP = TEMP-SQRT(2.0)/2.0
MOVE LPSA,TEMP ;PUT RESULTS IN LPSA
FAD LPSA, L2 ;LPSA = LPSA+SQRT(2.0)
FDV TEMP,LPSA ;TEMP = TEMP/LPSA
MOVEM TEMP,A ;STORE NEW VARIABLE IN A
FMP TEMP,TEMP ;CALCULATE Z^2
MOVE LPSA, L3 ;PICK UP FIRST CONSTANT
FMP LPSA,TEMP ;MULTIPLY BY Z^2
FAD LPSA, L4 ;ADD IN NEXT CONSTANT
FMP LPSA,TEMP ;MULTIPLY BY Z^2
FAD LPSA, L5 ;ADD IN NEXT CONSTANT
FMP A,LPSA ;MULTIPLY BY Z
FAD A,USER ;ADD IN EXPONENT TO FORM LOG2(X)
FMP A, L7 ;MULTIPLY TO FORM LOGE(X)
LOGXIT: SUB P,X22
JRST @2(P)
LZERO: ERR <LOG: Argument 0; minus infinity returned>,1
SKIPA A, MIFI ;PICK UP MINUS INFINITY
ZERANS: MOVEI A,0 ;MARG ANS ZERO
JRST LOGXIT ;AND RETURN
;CONSTANTS
ONE: 201400000000
L1: 577225754146 ;-0.707106781187
L2: 201552023632 ;1.414213562374
L3: 200462532521 ;0.5989786496
L4: 200754213604 ;0.9614706323
L5: 202561251002 ;2.8853912903
L7: 200542710300 ;0.69314718056
MIFI: 400000000001 ;LARGEST NEGATIVE FLOATING NUMBER
ENDCOM (POW)
COMPIL(USC,<USERCON>,<SAVE,RESTR,GOGTAB>,<USERCON ROUTINE>)
COMMENT Usercon
DSCR USERCON(@INDEX,@SETGET,FLAG);
CAL SAIL
PAR INDEX is USER-table displacement (usually obtained from HEAD.REL)
SETGET is used to communicate USER table values
FLAG is "OPCODE" input to USERCON
RES The INDEXth USER table entry is accessed (GLUSER table if FLAG negative).
On exit, SETGET contains old value of this entry.
If FLAG is odd, the original SETGET value replaces this entry.
CMU <
GGAS <
IFE ALWAYS, <EXTERNAL GLUSER>
>;GGAS
>;CMU
;;%BR% ! USED TO HEREFK TO HERE
HERE(USERCON)
PUSHJ P,SAVE
MOVE LPSA,[XWD 4,4]
MOVE A,-1(P) ;THE FLAG
CMU < GGGON
>;CMU
GLOB <
MOVEI B,ENDREN
JUMPL A,[MOVEI USER,GLUSER
MOVEI B,ZAPEND ;USE GLOBAL TABLE
JRST .+1]
SKIPL C,-3(P) ;THE INDEX
CAML C,B
>;GLOB
NOGLOB <
SKIPL C,-3(P) ;THE INDEX
CAIL C,ENDREN ;CHECK BOUNDS
>;NOGLOB
ERR <USERCON: index out of bounds >,7,RESTR
ADD C,USER ;POINT AT CORRECT ENTRY
MOVE B,(C) ;GET OLD VALUE
MOVE D,@-2(P) ;(PERHAPS) NEW VALUE
TRNE A,1 ;STORE NEW VALUE?
MOVEM D,(C) ;YES
MOVEM B,@-2(P) ;RETURN OLD VALUE
GLOB <
MOVE USER,GOGTAB ;RESET
>;GLOB
JRST RESTR
CMU < GGGOFF
>;CMU
ENDCOM(USC)
COMPIL(COD,,,,,,DUMMYFORSCISS)
TYMSHR <DEFINE IENT1 <CODE,CALL,CALLI>>;TYMSHR
NOTYMSHR <DEFINE IENT1 <CODE,CALL>>;NOTYMSHR
COMPXX(COD,IENT1,<.SKIP.,CVSIX,X22,GOGTAB,X33>,<CODE, CALL>)
DSCR VAL_CODE(OCTAL COMMAND, REFERENCE ARG);
Comment CODE
Reference arg is added to octal command. CODAC(USER)
is placed in AC 1. The constructed word is executed, and AC 1 resaved.
Isn't that clever? (AC1 is also returned as the value of the call)
HERE (CODE) MOVE USER,GOGTAB
SETOM .SKIP. ;ASSUME IT SKIPS
PUSH P,0
MOVE 1,CODAC(USER) ;GET USER'S AC
MOVE 0,-3(P)
ADDI 0,@-2(P) ;CALCULATE THE INSTR DO BE EXECUTED
XCT 0 ;DO IT
SETZM .SKIP. ;DIDN'T SKIP
MOVEM 1,CODAC(USER)
POP P,0
SUB P,X33
JRST @3(P)
NOTENX <;CALL FUNCTION EMULATED IN FILE CALL.TNX
DSCR VALUE_CALL(VAL,"FUNCTION");
CAL SAIL
^^.CALL:
HERE (CALL)
SETOM .SKIP. ;ASSUME A SKIP
PUSHJ P,CVSIX ;PARSE SIXBIT
MOVE TEMP,A ;SIXBIT FOR WHAT'S WANTED
MOVE A,-1(P) ;INPUT VALUE
CALL A,TEMP
SETZM .SKIP. ;NO SKIP, RECORD IT
SUB P,X22 ;RETURN VALUE IN 1, WANT IT OR NOT
JRST @2(P)
TYMSHR <
DSCR VALUE_CALLI(VAL,CALLI NUMBER);
HEREFK(CALLI,CALLI.)
SETOM .SKIP. ;SIMILAR TO CALL ABOVE
MOVE TEMP,-1(P) ;THE CALLI NUMBER. SINCE NEW CALLS HAVE
MOVE A,-2(P) ;NO CALL SIXBIT IN DEC SYSTEM
CALLI A,(TEMP)
SETZM .SKIP.
SUB P,X33
JRST @3(P) ;FINISHED
>;TYMSHR
ENDCOM (COD)
IFN ALWAYS,<BEND UTILS>
SUBTTL STRING HANDLING ROUTINES
>;NOTENX