Trailing-Edge
-
PDP-10 Archives
-
BB-H506D-SM_1983
-
cobol/source/cobddt.mac
There are 20 other files named cobddt.mac in the archive. Click here to see a list.
; UPD ID= 3562 on 6/3/81 at 2:16 PM by NIXON
TITLE COBDDT VERSION 12B
SUBTTL COBOL DEBUG PACKAGE
;COPYRIGHT (C) 1974, 1981 BY
;DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
;
;
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED
;ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH THE
;INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE OR ANY OTHER
;COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
;OTHER PERSON. NO TITLE TO AND OWNERSHIP OF THE SOFTWARE IS HEREBY
;TRANSFERRED.
;
;
;THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT NOTICE
;AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL EQUIPMENT
;CORPORATION.
;
;DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS
;SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.
EDIT==33
VERSION==1202
SALL
SEARCH P,COMUNI,FTDEFS
IFN TOPS20,<SEARCH MONSYM,MACSYM> ;[26]
IFE TOPS20,<SEARCH UUOSYM,MACTEN>
DEFINE $DIE,<
JRST CBDABT
>
IF1,<
INFIX% ;DEFINE %FILES INDICES
IFN ANS68,<
%%DB.==:FIXNUM ;NOT DEFINED IN COBOL-68
FIXNUM==FIXNUM+1 ;MAKE DEFINITION CONSISTENT WITH COBOL-74
FIXNMA==FIXNUM-1 ;DEFINE COBOL-74 V12A VALUE ALSO
>>
PURGE ANS74,ANS68 ;REMOVE DEFINITIONS
SUBTTL REVISION HISTORY
; EDITS 31-33 NOT REQUIRED AS CODE WAS REWRITTEN.
; EDIT ** ADD SUPPORT FOR COBOL-74 DEBUG MODULE.
; MAKE COBDDT INDEPENDENT OF COBOL-68 AND COBOL-74.
; EDIT ** CREATED SEPARATE COMMAND SCANNERS FOR TOPS10 AND TOPS20 VERSIONS
; MAJOR ENHANCEMENTS TO OPERATION OF EACH.
; MADE TOPS20 VERSION USE COMND JSYS AND BE NATIVIZED.
; TOTALLY SEPARATE PARSING FROM PROCESSING
; OF THE COMMANDS. RESHUFFLED CODE ALL AROUND SO THINGS ARE
; IN A LOGICAL ORDER. NEW AC ASSIGNMENTS.
; IMPLEMENTED "SHOW" COMMAND
; EDIT 30 MAKE "STEP" WORK LIKE $X IN DDT
; BREAKPOINTS ARE IGNORED WHILE STEP IS IN EFFECT.
; EDIT 27 FIX PROBLEM WITH STEP WHEN BREAKPOINTS ARE CLEARED.
; EDIT 26 FIXED BUG IN 'ACCEPT TALLY'. (DIDN'T WORK)
; FIXED BUG IN 'BREAK TALLY'. (DID AN ACCEPT!)
; IMPLEMENTED 'DDT' COMMAND.
; IMPLEMENTED 'LOCATE' COMMAND.
; IMPLEMENTED 'STEP' COMMAND.
; IMPLEMENTED 'GO' COMMAND.
; IMPLEMENTED 'TRACE BACK' COMMAND.
; ALLOWED BREAKPOINTS AT SECTION NAMES.
; ALLOWED MODULES COMPILED WITH /P TO BE LINKED IN.
; MOVED SOME CODE AROUND SO IT IS A LITTLE MORE UNDERSTANDABLE.
; SUBSTITUTED MNEMONIC LABELS FOR IMPLEMENTORS'S INITIALS!!!!
; EDIT 25 ADDED BETTER COMMENTS, MINOR BUG FIXES.
; ADDED REQUIREMENT THAT STOP COMMAND BE TYPED IN FULL.
; ONLY THE CODE CHANGES ARE IDENTIFIED WITH ;[25] COMMENTS.
; EDIT 24 ADDED "NEXT <INTEGER>" COMMAND.
; EDIT 23 FIX BREAKPOINT INSERTION AFTER .REENTER.
; EDIT 22 FIX "? ITEM TOO LARGE FOR TEMP" ERROR TO DISPLAY CORRECTLY
; EDIT 21 IMPLEMENT REENTER COMMAND
; EDIT 20 ALLOW COBDDT TO UNDERSTAND LOWER CASE.
; EDIT 17 FIX SYMBOL TABLE SEARCH FOR QUALIFIED VARIABLES.
; EDIT 16 FIX MEMORY PROTECTION FAILURE FOR QUALIFIED ITEMS.
; EDITS 14 & 15 INADVERTANTLY FIXED IN V10.
; EDIT 13 FIX SO THAT MODULE COMMAND DOES NOT INTERFERE WITH RUNNING (TRACING)
; EDIT 12 SKIP OVER FOUR START UP INSTRUCTIONS (DBMS) TO AVOID ILL MEM REF.
SUBTTL Entry and exit documentation for COBDDT.
;COBDDT can be invoked in various ways and at various entry points.
;Some invocations cause an action to take place followed by a return to
;the caller. Other invocations cause an action to take place followed by
;entry to COBDDT's dialogue mode, in which it converses with the user at the
;terminal. The user has various options for getting out of dialogue
;mode, and that gives COBDDT various ways of exiting.
ENTRY CBDDT. ;Initialization code - user prog does JSP 16,CBDDT.
;goes into dialogue mode.
ENTRY C.TRCE ;Tracing code - user prog does PUSHJ 17,C.TRCE
;If REEBRK switch is set, a simulated break is done
; and dialogue mode is entered.
;Issues trace message if tracing is on.
;Remembers procedure names for possible abort message.
;Returns with POPJ 17, if not in dialogue mode.
ENTRY BTRAC. ;Error abort code - entered from LIBOL by JRST BTRAC.
;prints last seen sect/par names.
;enters dialogue mode.
ENTRY TRPD. ;PERFORM push code - entered from prog by PUSHJ 17,TRPD.
;Remembers current sect/par names before executing PERFORM.
;returns with POPJ 17,
ENTRY TRPOP. ;PERFORM pop code - entered from prog by PUSHJ 17,TRPOP
;Restores saved sect/par names after return from PERFORM range.
;returns with POPJ 17,
;COBOL user code may not be resident either because it uses
;the COBOL program segmentation feature, or because it was linked
;into overlays. In either case, breakpoints cannot be set if the
;code is not in memory at the time that the breakpoint is requested.
;LINK overlay code requires various bookkeeping functions so that
;the histogram feature and the breakpoint features will work.
ENTRY SFOV. ;LINK overlay initialization - entered with PUSHJ 17,SFOV.
;Does the bookkeeping each time a new LINK overlay is loaded.
;If the user has turned on the OVERLAY break feature,
; dialogue mode is entered. Otherwise, returns with POPJ.
;Entered from the PUTF. routine in LIBOL, which is called
;from the inline code at every ENTRY in a module.
ENTRY SBPSG. ;Segmentation initialization - entered by PUSHJ 17,SBPSG.
;Does the bookkeeping for non-resident segments each time
; they are loaded.
;Returns with POPJ 17,
ENTRY CNTRC. ;CANCEL bookkeeping - entered by PUSHJ 17,CNTRC.
;When a module is CANCELled, all LINK overlays 'below it',
;as well as the LINK overlay containing it are 'forgotten'.
;This code does the necessary bookkeeping.
;returns with a POPJ 17,
ENTRY HSRPT. ;HISTORY report check - entered by PUSHJ 17,HSPRT.
;If a STOP RUN is entered before terminating a histogram,
;LIBOL guarantees the report is written by entering
;COBDDT here.
;returns by POPJ 17,
;The following are locations in COBDDT that are not defined as ENTRYs.
; CBREE. ;REENTER code - entered from monitor on REENTER command.
;(address is supplied to monitor by COBDDT's init code.)
;asks the user whether he wants to enter COBDDT, or just
;take a RERUN dump. If user indicates he wants to enter
;COBDDT a switch is set so that a simulated break will
;occur at the NEXT tracepoint.
;returns by JRST @.JBOPC or by taking rerun dump (LIBOL).
; BCOM ;break code - entered from user program by the sequence:
; JSR bptabl ;(in user's prog)
;bptabl:JSA T2,BCOM ;(in breakpoint table)
;Prints breakpoint information
;enters dialogue mode.
; DECOD ;dialogue code - entered by JRST DECOD from all over COBDDT.
;prompts for COBDDT command,
;reads and decodes the command, calls for command execution.
;Stays in a loop until an 'exiting command' is read.
;Exits by:
;STOP - goes to LIBOL's STOP RUN code.
;STEP or PROCEED - returns to the user program in various
; ways depending on how COBDDT got entered.
; IF entered at C.TRCE, or SFOV.,returns by POPJ.
; If entered at CBDDT., returns by JRST @PROGST.
; If entered at BCOM, returns by executing the
; user instruction at point of break,
; then a JRST.
;GO - JRST to the location named.
SUBTTL ASSEMBLY PARAMETERS AND DEFINITIONS
IFE TOPS20,<
EXTERNAL .JBREL,.JBSA,.JBDDT ;[26]
>
TXTLEN==^D200 ;LENGTH OF A COMMAND LINE
;AC DEFINITIONS
SW=0 ;SWITCH REGISTER
T0==0 ;USED IN EXTEND INST
T1=1 ;TEMP. ACS
T2=2
T3=3
T4=4
T5=5
LIT=6 ;STACK POINTER FOR LITERAL POOL
COD=7 ;STACK POINTER FOR CODE ROLL
DT=10 ;PNTR TO DATAB OR PROTAB
W1=11 ;HOLDS XWD IN CODE GENERATION
W2=12 ;EXTRA WORD FOR CODE GENERATORS
NM==13 ;NMTAB INDEX
CH==14 ;MOST RECENTLY RETRIEVED CHARACTER
;FROM THE COMMAND LINE.
P1=15 ;USED BY HISTOGRAM ROUTINES
P2=16 ;USED BY HISTOGRAM ROUTINES
AP==16 ;USER ARG POINTER
PP=17 ;PUSH-DOWN POINTER
;SWITCH DEFINITIONS FOR 'SW'
FASIGN==1B18 ;"A" OPERAND IS SIGNED
FBSIGN==1B19 ;"B" OPERAND IS SIGNED
FANUM==1B20 ;"A" OPERAND IS NUMERIC
FBNUM==1B21 ;"B" OPERAND IS NUMERIC
;FLAGS COMMON TO TOPS10 AND TOPS20
PNFLG==1B1 ;LOOK FOR PROCEDURE NAME
DNFLG==1B2 ;LOOKING FOR DATANAME
PRNMFG==1B3 ;GOT PROCEDURE NAME
FLNMOK==1B4 ;FILENAMES OK AS SYMBOL NAMES, TOO.
NUIFLG==1B6 ;TWO PROPER INITIAL SEGMENTS OF SYMBOLS HAVE BEEN FOUND
CRFLG==1B7 ;SAW CRLF AT END OF PARSED DATANAME
MINFLG==1B8 ;(TOPS-10 ONLY) SAW MINUS SIGN
FILGVN==1B9 ;(TOPS-10 ONLY) SAW A FILESPEC
SAWDOT==1B10 ;(TOPS-10 ONLY) SAW A "." IN FILESPEC
SAWPPN==1B11 ;(TOPS-10 ONLY) SAW A [PPN] IN FILESPEC
;USEFUL TABLES AND DEFINITIONS FOR CODE GENERATORS
CODE9==1 ;PICTURE CODE FOR "9"
CODEM==3 ;FOR FLOATING "-"
CODES==10 ;FOR INSERTED "-"
CODEP==11 ;FOR "."
; THESE CODES ARE BASED UPON USAGE CODE -1
; INDEX IS CHANGED TO COMP-1 AND ITS # IS USED BY EDITED
D6MODE==0 ;SIXBIT
D7MODE==1 ;ASCII
D9MODE==2 ;EBCDIC
DSMODE==2 ;HIGHEST DISPLAY MODE
D1MODE==3 ;1-WORD DECIMAL
D2MODE==4 ;2-WORD DECIMAL
FPMODE==5 ;FLOATING POINT
EDMODE==6 ;EDITED -USES INDEX SLOT
C3MODE==7 ;COMP-3
%US.IN==7 ;ACTUAL USAGE CODE FOR INDEX TYPE
CHAC: POINT 4,CH,12 ;AC-FIELD IN "CH"
BYTE.S: OCT 6 ;SIXBIT BYTE SIZE
OCT 7 ;ASCII BYTE SIZE
OCT 9 ;EBCDIC BYTE SIZE
BYTE.W: OCT 6 ;SIXBIT BYTES PER WORD
OCT 5 ;ASCII BYTES PER WORD
OCT 4 ;EBCDIC BYTES PER WORD
;BYTE POINTERS BASED UPON MODE
BYPTRS: POINT 6,0
POINT 7,0
POINT 9,0
POINT 6,0
POINT 6,0
POINT 6,0
0
POINT 9,0 ;COMP-3
;MULTIPLE-PRECISION ARITHMETIC OP-CODES
EXTERNAL EDIT.S,EDIT.U
;NOTE COBDDT WILL USE EDIT.S AND EDIT.U EVEN WHEN RUNNING ON A KL-10
EXTERNAL DSPLY.,ACEPT.,MOVE.,C.D6D7,C.D6D9,C.D7D6,C.D7D9
EXTERNAL C.D9D6,C.D9D7,PD6.,PD7.,PD9.,PC3.,GD6.,GD7.,GD9.,GC3.
EXTERNAL FLOT.2,DSP.FP,GETNM.,PPOT4.,ISBPS.
IFE BIS,<
EXTERNAL MAG.
>
;HISTOGRAM DEFINITIONS:
EOL==12 ;END OF LINE CHARACTER.
HTTLSZ==^D70 ;MAXIMUM SIZE FOR TITLE.
IFNDEF HPSPLN,<HPSPLN==^D20> ;MAXIMUM NUMBER OF ENTRY POINTS
; AND PERFORMS TO KEEP TRACK OF.
;DATAB DEFINITIONS
DTNAM==0 ;WORD # OF NAMTAB LINK
DTLKP==1 ;WORD # OF LINKAGE PTR
DTSON==2 ;WORD # OF FATHER/BROTHER/SON LINKS
DTLVL==3 ;WORD # OF WORD CONTAINING THE LEVEL NUMBER
DTFLAG==4 ;WORD # OF FLAGS
DTSUBW==6 ;WORD # OF SUBSCRIPT INFO
DTBP==^D9 ;WORD # OF EDIT MASK
DTOCCL==000004 ;OCCURS AT THIS LEVEL
CL.NUM==2 ;CLASS NUMERIC
;BYTE POINTERS
DTCLAS: POINT 2,DTFLAG(DT),1 ;CLASS FIELD
DTDPL: POINT 6,DTFLAG(DT),35 ;DECIMAL PLACES FIELD
DTESIZ: POINT 18,5(DT),17 ;EXTERNAL SIZE
DTISIZ: POINT 18,5(DT),35 ;INTERNAL SIZE
DTNOCC: POINT 15,DTSUBW(DT),14 ;NUMBER OF OCCURANCES
DTRESD: POINT 6,3(DT),11 ;RESIDUE FIELD
DTUSAG: POINT 4,3(DT),17 ;USAGE FIELD
;BITS SET IN FIFTH WORD OF DATAB ENTRY
;LEFT HALF
DTNUM==1B0 ;NUMERIC
DTSYNL==1B2 ;SYNCHRONIZED LEFT
DTSYNR==1B3 ;SYNCHRONIZED RIGHT
DTSIGN==1B4 ;SIGNED
DTBWZ==1B5 ;BLANK WHEN ZERO
DTSUBS==1B6 ;MUST BE SUBSCRIPTED
DTEDIT==1B7 ;EDITED
DTLINK==1B8 ;FATHER (1) OR BROTHER (0) LINK
DTDEF==1B9 ;DEFINED
;RIGHT HALF
DTLKS==000100 ;LINKAGE SECTION FLAG
DTPLOC==1B30 ;DECIMAL POINT IS TO RIGHT OF WORD
DTSYLL==1B25 ;SYNCS AT LOWER LEVELS
;CODE ROLL ALLOCATIONS
N.TMP==^D100 ;MAX TEMP STORAGE
N.COD==^D30 ;MAX CODE ROLL SIZE
N.LIT==^D30 ;MAX LIT POOL SIZE
;PROTAB ENTRY
;BYTE POINTERS
NMLINK: POINT 15,(T4),17 ;LINK UP TO NAMTAB
SECNAM: POINT 15,1(T4),17 ;LINK UP TO SECTION-NAME
PR.FLG==2 ;WORD # OF FLAGS
;BITS SET IN THIRD WORD OF PRTAB ENTRY
PR%SEC==1B25 ;PARAGRAPH-NAME (1) OR SECTION-NAME (0)
PR.LN==3 ;LINE NUMBER FOR DEBUGGING IN COBOL-74
;TABLE TYPE PARAMETERS
DTTYPE==100000 ;DATAB TYPE
PRTYPE==400000 ;PRTAB TYPE
TYPMSK==700000 ;MASK FOR TYPE FIELD
;TRACE CODE FLAGS
TC.DB==(1B3) ;DEBUGGING REQUIRED
TC.EP==(1B4) ;EXIT PROGRAM
TC.GB==(1B5) ;GOBACK
TC.PE==(1B7) ;PROGRAM ENTRY
TC.AE==(1B8) ;ALTERNATE ENTRY
;DEFINITION OF FIELDS IN COBDDT'S LINK-10 OVERLAY BLOCKS.
OVLTN==0 ;LINK TO NEXT.
OVNAM==1 ;SIXBIT MODULE NAME.
OVSMD==2 ;FIRST LOCATION IN MODULE (LH)
OVEPA==2 ;MAIN ENTRY POINT ADDRESS (RH)
OV%NM==3 ;%NM.
OV%DT==4 ;%DT.
OV%PR==5 ;%PR.
OVSLK==6 ;FIRST LOCATION IN THE LINK (LH).
OVLKN==6 ;LINK NUMBER (RH).
OVBKSZ==7 ;SIZE OF THE BLOCK.
;DEFINITIONS OF FIELDS AND FLAGS IN LINK'S TABLES.
F.LIC==1B0 ;LINK IN CORE
F.MDL==1B1 ;ROUTINE IN MULTIPLE LINKS.
F.RLC==1B2 ;LINK IS RELOCATED.
CS.NUM==2 ;LINK NUMBER
CS.PTR==4 ;PREVIOUS CONTROL SECTION,,NEXT CONTROL SECTION.
CS.COR==7 ;LENGTH OF LINK,,FIRST LOC IN LINK.
CS.EXT==10 ;AOBJN PTR TO EXTERNAL TRANSFER TABLES.
CS.INT==11 ;AOBJN PTR TO INTERNAL TRANSFER TABLES.
JT.FLG==0 ;FLAGS (BITS 0-8)
JT.ADR==0 ;ADDRESS IF IN CORE (RH)
JT.CST==1 ;ADDRESS OF THIS CONTROL SECTION (RH)
JT.MDL==1 ;POINTER TO MULTIPLY DEFINED TABLE.
;FUNCT. FUNCTION CODES
F.GCH==4 ;GET CHANNEL NO.
F.RCH==5 ;RETURN CHANNEL NO.
F.GOT==6 ;GET CORE FROM OTS FREE LIST
F.ROT==7 ;RETURN CORE TO OTS FREE LIST
F.PAG==15 ;GET CORE AT PAGE BOUNDARY
;MESSAGE TYPED BY COBDDT WHEN STARTING UP
STRTUP==[ASCIZ/
[Starting COBOL DDT]
/]
;SOME USEFUL MACROS:
DEFINE TYPE(MESSAGE)<
IFE TOPS20,<
OUTSTR MESSAGE
>
IFN TOPS20,<
HRROI T1,MESSAGE
PSOUT%
>
>
DEFINE PTYPE(MESSAGE)<
IFE TOPS20,<
OUTSTR MESSAGE
>
IFN TOPS20,<
PUSH PP,T1
HRROI T1,MESSAGE
PSOUT%
POP PP,T1
>
>
DEFINE JTYPE(MESSAGE)<
IFE TOPS20,<
OUTSTR MESSAGE
>
IFN TOPS20,<
PUSHJ PP,[PUSH PP,T1
HRROI T1,MESSAGE
PSOUT%
POP PP,T1
POPJ PP,]
>
>
DEFINE TYPEAC(ACC)<
IFE TOPS20,<
OUTCHR ACC
>
IFN TOPS20,<
IFN T1-ACC,<
PUSH PP,T1
MOVE T1,ACC
>
PBOUT%
IFN T1-ACC,<
POP PP,T1
>>
>
DEFINE TYPEC(X)<
IFE TOPS20,<
OUTCHR [X]
>
IFN TOPS20,<
PUSH PP,T1
MOVEI T1,X
PBOUT%
POP PP,T1
>
>
DEFINE JTYPEC(X)<
IFE TOPS20,<
OUTCHR [X]
>
IFN TOPS20,<
JRST [ PUSH PP,T1
MOVEI T1,X
PBOUT%
POP PP,T1
JRST .+1]
>
>
DEFINE WARN% (X)<
PTYPE [ASCIZ \
%'X'\]
>
DEFINE SAVACS,<
MOVEM 0,RACS
MOVE 0,[1,,RACS+1]
BLT 0,RACS+17
>
DEFINE RSTACS,<
MOVE 0,[RACS+1,,1]
BLT 0,17
MOVE 0,RACS
>
DEFINE HLPTXT(A),<
MOVEI T1,[ASCIZ \A\]
MOVEM T1,HLPMSG
>
;SUBTTL IMPURE AREA
INTERNAL PTFLG.
PTFLG.: BLOCK 1 ;NON-ZERO IF WE ARE TRACING
DNRSTT: BLOCK 1 ;Done RESET. if -1
BRKONO: BLOCK 1 ;IF NON ZERO BREAK WHEN WE BRING AN OVERLAY IN.
EBRKOV: BLOCK 1 ;ENTRY POINT ADDRESS OF THE OVERLAY WE ARE
; BREAKING ON.
SUBSPR: BLOCK 1 ;IF NON ZERO THERE ARE SUBROUTINES PRESENT.
CUREPA: BLOCK 1 ;CURRENT ENTRY POINT'S ADDRESS.
CBLIO.: BLOCK 1 ;ADDRESS OF 'RESET.' ROUTINE
PROGST: BLOCK 1 ;STARTING ADDRESS OF COBOL PROGRAM
NSUBS: BLOCK 1 ;NUMBER OF SUBSCRIPTS TYPED
SUB0.: BLOCK 3 ;PLACE FOR SUBS
SAV.T2: ;PLACE TO SAVE "T2" IN BCOM
SAVDT: BLOCK 1 ;PLACE TO SAVE "DT"
FLGS.: BLOCK 1 ;PLACE TO SAVE PROCESSOR FLAGS
TEMP1: ;TEMP STORAGE FOR BP CODE
EAC: BLOCK 1 ;AC NUMBER FOR ASSEMBLY
TEMP2: ;TEMP STORAGE FOR BP CODE
REMAN: BLOCK 1 ;TEMP STORAGE USED IN SUBSCR CALC
SIGNSW: Z ;[24]REMEMBERS LEADING SIGN ON INTEGER
BASEA: BLOCK 1 ;ADDR OF "A" OPERAND (RH)
RESA==BASEA ;BYTE RESIDUE FOR "A" (LH)
INCRA: BLOCK 1 ;OFFSET FOR "A"
SIZEA: BLOCK 1 ;SIZE OF "A"
MODEA: BLOCK 1 ;USAGE OF "A"
DPLA: BLOCK 1 ;DECIMAL PLACES IN "A"
BASEB: BLOCK 1 ;ADDR OF "B" OPERAND (RH)
RESB==BASEB ;BYTE RESIDUE FOR "B" (LH)
INCRB: BLOCK 1 ;OFFSET FOR "B"
SIZEB: BLOCK 1 ;SIZE OF "B"
MODEB: BLOCK 1 ;USAGE OF "B"
DPLB: BLOCK 1 ;DECIMAL PLACES IN "B"
BASEX==0 ;OFFSET OF BASE
RESX==0 ;OFFSET OF RESIDUE
INCRX==1 ;OFFSET OF OFFSET
SIZEX==2 ;OFFSET OF SIZE
MODEX==3 ;OFFSET OF USAGE
DPLX==4 ;OFFSET OF DECIMAL PLACES
SAVEA: BLOCK DPLX+1 ;PLACE TO SAVE "A" PARAMETERS
SAVEB: BLOCK DPLX+1 ;PLACE TO SAVE "B" PARAMETERS
SAVMA: BLOCK 2*DPLX+2 ;PLACE TO SAVE PARAMETERS DURING MOVES
SAVMB=SAVMA+DPLX+1
SAVAX==SAVEA+DPLX
SAVBX==SAVEB+DPLX
BASAX==BASEA+DPLX
BASBX==BASEB+DPLX
SVMAX==SAVMA+DPLX
SVMBX==SAVMB+DPLX
;BREAK POINT IMPURE AREA
BCOM2: BLOCK 1 ;USED INDIRECT FOR PROCEED CNTR
BCOM3: BLOCK 1 ;USED INDIRECT FOR SECTION NAME
LEAV1: XWD Z,LEAV ;USED JRST @ TO DISMISS
LEAV: Z ;HOLDS USER OR OTHER DISMISS INSTR
JRST @BCOM ;IF INSTR HOPS
AOS BCOM ;IF INSTR SKIPS
JRST @BCOM
CUR.BP: BLOCK 1 ;HOLDS CURRENT BP (0 IF VIRGIN)
LAST.: BLOCK 1 ;HOLDS LAST DATA ITEM IN ACCEPT ETC.
SAVSUB: BLOCK 4 ;HOLDS SUBSCRIPT INFO AS ABOVE
DEFINE BP (D) <
IRP (D),<
BP'D: Z ; JSR ENTRY FOR BREAKPOINT D
JSA T2,BCOM ; INVOKE BP LOGIC
B'D'INS: Z ; ORIGINAL INSTR AT BP D
>>
DEFINE BA (D) <
IRP (D),<
B'D'ADR: Z ; PNTR TOP PROTAB FOR BP'D
B'D'SEC: Z ; CURRENT ENTRY POINT ADDRESS (LH) AND
; SECTION NAME PNTR (RH) FOR BP'D
B'D'CNT: Z ; PROCEED COUNT FOR BP'D
>>
;BREAK POIN CONSTANTS
LBP==3
LBA==3
NBP==^D20
BP (<1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20>)
BPN==.-LBP ;ADDR OF LAST BP ENTRY
PAGE
BA (<1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20>)
BNADR==.-LBA
CBPADS: BLOCK 2 ;PNTR TOP PROTAB AND SECTION NAME FOR CURRENT BP.
;CODE GENERATION IMPURE AREAS
CODFST==. ;FIRST LOC TO CLEAR
CODROL: BLOCK N.COD ;CODE ROLL
LITROL: BLOCK N.LIT ;LITERAL POOL
TEMPC: BLOCK 1 ;OFFSET IN TEMP
TEMROL: BLOCK N.TMP ;TEMP STORAGE
CODLST==.-1 ;LAST LOC TO CLEAR
C74FLG: Z ;-1 IF COBOL-74 MAIN PROGRAM
IFE TOPS20,<
M7FLG: BLOCK 1 ;-1 IF 7 SERIES MONITOR
DEFPTH: BLOCK 2 ;FIRST PART OF DEFAULT PATH
DEFPPN: BLOCK 1 ;LOGGED IN PPN
DEFSFD: BLOCK 6 ;REST OF DEFAULT PATH
>
REEBRK: Z ; [21] -1 SAYS BREAK TO C.TRCE
;USED BY ^C/REENTER AND STEP CODE.
REEFLG: BLOCK 1 ; [21] STACK ADDRESS FOR PROCEED
STPCTR: BLOCK 1 ;[26] NO. OF STEPS TO BYPASS
;BEFORE NEXT BREAK, WHEN STEPPING.
RRDMP: BLOCK 1 ; [21] SAVE RERUN DUMP REENTER ADDRESS
AC0: BLOCK 20
PDL.: BLOCK 1 ;PUSH DOWN POINTER
DIED.: BLOCK 1 ;FLAG FOR EX DEATH
L.PARA: BLOCK 1 ;PLACE TO SAVE LAST PARA
L.SECT: BLOCK 1 ;PLACE TO SAVE LAST SECTION
ETYPTS: BLOCK 1 ;POINTER INTO THE TABLE BELOW.
ETYTAB: BLOCK ^D100 ;ADDRESSES OF MAIN ENTRY POINTS FOR ALL MODULES.
NMSVD: Z ;PLACE TO SAVE THE ADDRESS OF AN ENTRY POINT IN ETYTAB.
OVRLHD: Z ;POINTER TO LIST OF OVERLAY BLOCKS.
OVLCHS: Z ;ADDRESS OF CONTROL HEADER SECTION FOR
; THE ROOT LINK.
;COMMAND SCANNER THINGS
DNAME6: BLOCK 6 ;HOLDS SIXBIT DATANAME READ IN
DNAME7: BLOCK 7 ;HOLDS ASCII DATANAME (TO TYPE OUT)
TXTBUF: BLOCK TXTLEN/5+1 ;COMMAND LINE
TXTBBP: BLOCK 1 ;CURRENT BP TO TXTBUF
PRSCHR: BLOCK 1 ;FIRST PARSED CHARACTER
PRSBBP: BLOCK 1 ;BP AT START OF A PARSE
ATMBUF: BLOCK TXTLEN/5+1 ;BUFFER FOR ATOM BUFFER
ILINE: BLOCK TXTLEN/5+1 ;ITTLIN BUFFER
IFN TOPS20,<
;TEXTI BLOCK FOR READING TTY LINES
TXTIBL: .RDRTY ;LAST WORD GIVEN
0 ;FLAGS
.PRIIN,,.PRIOU ;INPUT,,OUTPUT JFNS
0 ;DESTINATION PTR (FILLED IN)
0 ;BYTES AVAILABLE (FILLED IN)
0 ;USE START OF BUFFER AS ABOVE
0 ;CONTROL-R TEXT (FILLED IN)
>;END IFN TOPS20
;THE FOLLOWING THREE ITEMS CONTAIN THE ADDRESSES OF %NM., %DT., %PR.
; IN THAT ORDER
%NM: BLOCK 1 ;ADDR OF %NM.
%DT: BLOCK 1 ;ADDR OF %DT.
%PR: BLOCK 1 ;ADDR OF %PR.
%DB: BLOCK 1 ;ADDR OF %DB.
COBVR: BLOCK 1 ;COBOL VERSION
COBSW: BLOCK 1 ;COMPILER ASSEMBLY SWITCHES
PNM: BLOCK 1 ; [13] RUN-TIME NM
PDT: BLOCK 1 ; [13] RUN-TIME DT
PPR: BLOCK 1 ; [13] RUN-TIME PR
BNM: BLOCK 1 ; [13] BREAK NM
BDT: BLOCK 1 ; [13] BREAK DT
BPR: BLOCK 1 ; [13] BREAK PR
FUN.C0: BLOCK 1 ;FOR GETTING CORE
FUN.C1: BLOCK 1
FUN.C2: BLOCK 1
FUN.CS: BLOCK 1 ;STATUS RETURNED FROM FUNCT.
IFE TOPS20,<
;DO NOT SPLIT THESE WORDS
INPDEV: BLOCK 1 ;INPUT DEVICE
INPFSP: BLOCK ^D10 ;INPUT FILESPEC
;WORDS ARE: 0=NAME, 1=EXT, 3=PPN, 4=1ST SFD, ..10=5TH SFD
>
HSTTTL: BLOCK <HTTLSZ+5>/5 ;PLACE FOR TITLE.
HFINIT: Z ;NON ZERO IF AN INITIALIZATION OR BEGIN WAS DONE.
HFGTHR: Z ;NON ZERO IF WE ARE GATHERING STATISTICS.
HFTBST: Z ;NON ZERO IF WE HAVE SET UP THE TABLES.
HFGTST: Z ;-1 ==> SET UP INITIAL ITEMS.
HSTRPN: Z ;REPORT NUMBER.
HSTACS: BLOCK 20 ;PLACE TO SAVE AC'S.
HSTSJF: Z ;START OF NEXT HISTOGRAM BLOCK
MYJFF: Z ;USE AS ".JBFF" FOR OVERLAY BLOCK STORAGE
MYJBRL: Z ;USE AS ".JBREL" FOR OVERLAY BLOCK STRUCTURE
IFE TOPS20,<
XWD -5,0 ;ARG BLOCK FOR FUNCT. CALLS.
HSTFFC: Z 2,HSTFFN
Z 2,HSTFEC
Z 2,HSTFST
Z 2,HSTADR
Z 2,HSTSIZ
>;END IFE TOPS20
XWD -4,0 ;ARG BLOCK FOR FUNCT. CALLS.
HSTFFB: Z 2,HSTFFN
Z 2,HSTFEC
Z 2,HSTFST
Z 2,HSTFCH
HSTFFN: BLOCK 0 ;FUNCTION.
HSTFEC: BLOCK 0 ;ERROR CODE.
HSTFST: BLOCK 0 ;STATUS.
HSTFCH: BLOCK 0 ;CHANNEL.
HSTSIZ: EXP 0 ;REQUIRED SIZE
HSTADR: EXP 0 ;ADDRESS
IFE TOPS20,<
HISOUT: OUT .-., ;OUT UUO
HISGST: GETSTS .-.,T2 ;GETSTS UUO
HSTFB.: ;HISTOGRAM FILOP. BLOCK
HSTFNC: BLOCK 1 ;FUNCTION CODE
HSTIOS: EXP .IOASC ;I/O MODE
HSTDEV: EXP 0
XWD HSTOBF,0 ;ADDR. OF BUFFER HEADERS
XWD 2,0 ;NO. OF BUFFERS
XWD 0,HSTNAM ;ADDR. OF LOOKUP/ENTER BLOCK
HSTOBF: BLOCK 3
HSTNAM: BLOCK 1 ;FILE NAME
HSTEXT: BLOCK 1 ;EXTENSION
HSTPRT: BLOCK 1 ;PROTECTION CODE
HSTPP: BLOCK 1 ;PPN OR PATH POINTER
HSTPTH: BLOCK 2
HSTPPN: BLOCK 1 ;PPN
HSTSFD: BLOCK 5 ;SFD
EXP 0 ;MAKE SURE ZERO AT END
>;END IFE TOPS20
IFN TOPS20,<
HSTBUF: BLOCK 200 ;FIXED SIZE BUFFER
>
HCURPS: Z ;CURRENT PARAGRAPH/SECTION.
HSTCPU: Z ;HOLDS THE RUNTIME.
HSTELP: Z ;HOLDS THE ELAPSED TIME.
HPSPDL: Z ;HOLDS THE PUSH DOWN POINTER.
HPSPLO: BLOCK HPSPLN ;PUSHDOWN LIST FOR SAVING OLD PARAGRAPH/SECTION
; WHEN WE START A PERFORM OR ENTER A SUBROUTINE.
HOVRHD=.-1 ;PLACE TO ACCUMULATE OVERHEAD TIME.
HOVCPU: Z
HOVELP: Z
HUNATD=.-1 ;PLACE TO SAVE UNACCOUNTABLE TIME.
HUNCPU: Z
HUNELP: Z
HSTPDL: Z ;PLACE TO SAVE THE PUSHDOWN POINTER.
SVT3: BLOCK 1 ;SAVE T3
SAV16: BLOCK 1 ;16 WHEN OVERLAY HANDLER CALLED
SVMPT: BLOCK 1 ;SAVED MODULE POINTER FOR OVERLAYS
RACS: BLOCK ^D16 ;SAVED ACS FROM USER PROG
HLPMSG: BLOCK 1 ;ADDRESS OF HELP MESSAGE TEXT
PRMTXT==[ASCIZ/COBDDT>/]
IFN TOPS20,<
JSSSV1: BLOCK 1 ;SAVE T1
JSSSV2: BLOCK 1 ;SAVE T2
HSTJFN: BLOCK 1 ;JFN OF HISTORY FILE
CMDBKK: CM%RAI+NEWPAR ;ADDRESS OF REPARSE ROUTINE
.PRIIN,,.PRIOU ;INPUT,,OUTPUT JFNS
-1,,PRMTXT ;CONTROL-R BUFFER (NOTE NEW COBDDT PROMPT!)
-1,,TXTBUF ;POINTER TO TEXT BUFFER
-1,,TXTBUF ;POINTER TO CURRENT POSITION
TXTLEN ;NUMBER OF CHARACTERS IN BUFFER
0 ;NUMBER OF UNPARSED CHARACTERS
-1,,ATMBUF ;POINTER TO ATOM BUFFER
TXTLEN ;NUMBER OF CHARACTERS IN BUFFER
EXP JFNBLK ;POINTER TO JFN BLOCK
CBTLEN==.-CMDBKK ;# LOCATIONS TO BLT
CMDBLK: BLOCK CBTLEN ;COMMAND BLOCK, COPIED FROM ABOVE
JFNBLK: 0 ;FLAGS,,GENERATION NUMBER
.PRIIN,,.PRIOU ;INPUT,,OUTPUT JFNS
BLOCK 20 ;NO DEFAULTS
PRSJFN: BLOCK 1 ;PARSED JFN
>;END IFN TOPS20
DEBUG.:: 0
DBITEM: BLOCK 1 ;ADDRESS OF CURRENT DEBUG-ITEM
SUBTTL START-UP
;HERE IS START ADDR OF COBDDT, FOR USER PROGRAM
;CALLED BY "JSP 16,CBDDT."
CBDDT.:
;;ONCE-ONLY INITIALIZATION
MOVEM 16,PROGST ; SAVE ADDR OF BEGINNING OF USER PROG
AOS PROGST ;SKIP XWD PARAMETER
HRRZ 16,(16) ;GET ADDR OF MAIN PROGRAM
PUSHJ PP,SETETY ;SET UP TABLE OF ENTRY POINT ADDRESSES
SUBI NM,ETYTAB ;FORM AN AOBJN TYPE POINTER FOR
MOVNI NM,(NM) ; THE TABLE.
HRLI NM,ETYTAB
MOVSM NM,ETYPTS ;SAVE IT.
SETZM SUBSPR ;Assume no subroutines present
CAME NM,[XWD ETYTAB,-1] ;Check that.
SETOM SUBSPR ;More than 1 module in this program
MOVEI 16,%NM ;GET ADDRESSES OF %NM, %DT., %PR.
PUSHJ PP,GETNM.
MOVE T1,%NM ;GET ADDRESS OF %NM
MOVE T2,%COBVR-%%NM.(T1)
MOVEM T2,COBVR ;COPY VERSION NUMBER
MOVE T2,%COBSW-%%NM.(T1)
MOVEM T2,COBSW ;COPY COMPILER SWITCHES
TRNE T2,1 ;COBOL-74?
SETOM C74FLG ;YES-SET FLAG
LDB T2,[POINT 12,COBVR,17]
SKIPE C74FLG ;NO %DB IN COBOL-68
CAIGE T2,1202 ;OR IN COBOL-74 PRIOR TO 12B
TDZA T2,T2
MOVE T2,%%DB.-%%NM.(T1)
MOVEM T2,%DB ;STORE POINTER TO DEBUG-ITEM
IFE TOPS20,<
MOVE T1,[%CNVER] ;CONFIG TABLE
GETTAB T1,
SETZ T1, ;MUST BE VERY OLD
LDB T1,[POINT 5,T1,23] ;GET MONITOR VERSION #
CAIN T1,7 ;TEST FOR 7 SERIES
SETOM M7FLG ;IT IS, SET FLAG
SETOM DEFPTH ;MY JOB,,GET PATH FUNCTION
MOVE T1,[11,,DEFPTH]
PATH. T1, ;GET DEFAULT PATH
SETZM DEFPPN ;FAILED
>
MOVEM PP,PDL. ;WE'LL USE THAT WHEN WE GET CONFUSED
MOVE T1,ETYTAB ;FIRST ENTRY POINT IS THE ONE WE START AT
MOVEM T1,CUREPA ;"CURRENT ENTRY POINT ADDRESS"
SETZM LAST. ;LAST DATA ITEM FOR "ACCEPT", "DISPLAY", ETC.
SETZM CUR.BP ;CURRENT BREAKPOINT (SET TO 0 FOR "VIRGIN")
SETZM DIED. ;PROG DIDN'T "DIE" YET
SETZM L.SECT ;NO LAST SECTION
SETZM PTFLG. ;NOT TRACING
SETZM BRKONO ;DON'T BREAK FOR AN OVERLAY
SETZM HFINIT ;HISTORY NOT INIT'D OR BEGUN YET
SETZM HFGTHR ;NOT GATHERING STATS YET
SETZM HFTBST ;HAVEN'T SETUP THE HIST TABLES YET
SETOM HFGTST ;-1 TO SAY "SETUP INITIAL ITEMS"
MOVE T1,.JBREN## ;GET RERUN DUMP ADDRESS
MOVEM T1,RRDMP ;SAVE IT
MOVEI T1,CBREE. ; SET NEW REENTER ADDRESS
MOVEM T1,.JBREN ; SO ^C REENTER CAN GET YOU TO COBDDT
MOVE T1,[XWD B1ADR,B1ADR+1] ;ZERO THE BREAKPOINTS
SETZM B1ADR
BLT T1,BNADR+LBA-1
;TYPE STARTUP
SKIPN DEBUG. ;SKIP IF WE WANT DEBUG MODULE
JRST CBDT1. ;NO
TYPE [ASCIZ/
[COBOL-74 Debug module - type P to start program]/]
CBDT1.: TYPE STRTUP ;TYPE STARTUP MESSAGE
;PREVENT DOING A START AGAIN, EXCEPT TO GET INTO COBDDT.
MOVEI T1,[ SETOM DIED.
PTYPE STRTUP
JRST XECUTX]
HRRM T1,.JBSA##
MOVE T1,@%NM ;ADDR OF %NM
MOVEM T1,PNM ;STORE INTO PROCEED
MOVEM T1,BNM ;STORE INTO BREAK
MOVE T1,@%DT ;ADDR OF %DT
MOVEM T1,PDT ;STORE INTO PROCEED
MOVEM T1,BDT ;STORE INTO BREAK
MOVE T1,@%PR ;ADDR OF %PR
MOVEM T1,PPR ;STORE INTO PROCEED
MOVEM T1,BPR ;STORE INTO BREAK
SETOM DNRSTT ;Set "Done RESET."
IFN TOPS20,<
MOVE T1,[CMDBKK,,CMDBLK] ;SETUP COMMAND BLOCK
BLT T1,CMDBLK+CBTLEN-1
>
JRST XECUTX ;GO TO COMMAND SCANNER
;SET UP TABLE OF MAIN ENTRY POINT ADDRESSES FOR ALL RESIDENT SUBROUTINES.
; ENTER WITH ADDRESS OF MAIN PROGRAM'S ENTRY POINT IN TA.
SETETY: MOVEI NM,ETYTAB ;POINT AT THE TABLE.
SETETD: HRRZ T1,(16) ;IF THE INSTRUCTION AT THE
JUMPE T1,SETETH ; ENTRY POINT ISN'T "SKIPA 0,0",
SKIPE OVLCHS ; THE MODULE IS PROBABLY IN A
POPJ PP, ; LINK-10 OVERLAY.
ADDI 16,1 ;IF WE ALREADY HAVE THE ADDRESS
MOVE T1,JT.FLG(16) ; OF THE CONTROL HEADER SECTION
TXNE T1,F.MDL ; FOR THE ROOT SEGMENT, LEAVE.
HRRZ 16,JT.MDL(16) ;OTHERWISE PICK IT UP.
HRRZ 16,JT.CST(16)
MOVEM 16,OVLCHS
POPJ PP,
SETETH: HRRZ T1,-2(16) ;GET LINK TO MAIN ENTRY POINT.
TRNE T1,-1 ;WERE WE AT THE MAIN ENTRY POINT?
HRRZI 16,(T1) ;NO, BUT WE ARE NOW.
MOVE T1,1(16) ;GET THE ADDR OF %FILES.
SKIPGE %%NM.(T1) ;IF WE HAVE ALREADY DONE THIS
POPJ PP, ; MODULE LEAVE.
CAILE NM,ETYTAB+^D100 ;IF THERE ISN'T ANY MORE ROOM, COMPLAIN.
JRST [PTYPE [ASCIZ /
?Too many subroutines for COBDDT to cope with. Please combine
some of them so that there are less than 100 modules./]
$DIE]
HRROS %%NM.(T1) ;MARK THIS MODULE AS DONE.
HRRZM 16,(NM) ;STASH THE ENTRY POINT'S ADDRESS.
ADDI NM,1 ;MOVE UP TO NEXT LOC IN THE TABLE.
HLRZ T1,1(16) ;GET THE ADDRESS OF THE LIST
; OF PROGRAMS CALLED BY THIS MODULE.
SETETP: SKIPN 16,(T1) ;DOES THIS MODULE CALL ANYONE?
POPJ PP, ;NO, RETURN.
PUSH PP,T1 ;SAVE POINTER TO LIST.
PUSHJ PP,SETETD ;CURSE AND RECURSE.
POP PP,T1 ;GET THE POINTER BACK.
AOJA T1,SETETP ;GO SEE IF THERE ARE MORE.
SUBTTL REENTER CODE
;HERE IS THE REENTER ADDRESS FOR COBDDT
CBREE.: SAVACS ;SAVE THE ACS
HRRZ T1,.JBOPC ;SEE IF WE ARE A COBDDT COMMAND WAIT
IFN TOPS20,<
CAIE T1,COMMND+1 ;ARE WE?
>
IFE TOPS20,<
CAIE T1,DECOD0 ;ARE WE?
>
SKIPE DIED. ;OR REENTERING A TERMINATED PROGRAM
JRST CBREED ;YES, JUST REENTER COBDDT
CBREEA: TYPE [ASCIZ/Do you want to enter COBDDT? (Y or N) /]
PUSHJ PP,GYESNO ;GET "YES" OR "NO"
JRST CBREEA ;NEITHER
JRST CBREEC ;"YES"
;"NO" TYPED
RSTACS ;RESTORE ACS
JRST @RRDMP ;ASSUME HE WANTED RERUN DUMP
;"YES" -- HE WANTS TO ENTER COBDDT
CBREEC: SETZM STPCTR ;CLEAR STEP COUNTER ON REENTER
SETOM REEBRK ;SAY WE WANT TO BREAK ON NEXT ENTER
RSTACS ;RESTORE ACS
JRST @.JBOPC## ;AND CONTINUE AS PLANNED
;JUST REENTER COBDDT
CBREED: RSTACS ;RESTORE ACS
IFN TOPS20,<
JRST ERESET ;GIVE COBDDT PROMPT AGAIN
>
IFE TOPS20,<
JRST DECOD ;GIVE COBDDT PROMPT AGAIN
>
SUBTTL GYESNO ROUTINE
;ROUTINE TO GET "YES" OR "NO" RESPONSE FROM TERMINAL
; RETURNS .+1 IF NEITHER, .+2 IF "YES", .+3 IF "NO"
IFE TOPS20,<
GYESNO: INCHWL CH ;GET 1ST CHAR IN LINE
MOVE T1,CH
GYSNOC: CAIE T1,7 ;CHECK FOR EOL CHARACTERS
CAIN T1,12
JRST GYNCHK ;WHEN FOUND, CHECK 1ST CHAR ON LINE
CAIE T1,13
CAIN T1,14
JRST GYNCHK
CAIN T1,32
JRST GYNCHK
INCHWL T1 ;NOT EOL, GET NEXT CHAR ON LINE
JRST GYSNOC ;LOOP
>;END IFE TOPS20
IFN TOPS20,<
GYESNO: PUSHJ PP,ITTLIN ;GET INPUT LINE FROM TTY
JRST GYESNO ;ERROR, GO GET ANOTHER LINE
LDB CH,[POINT 7,ILINE,6] ;GET 1ST CHARACTER OF THE LINE
JRST GYNCHK
;TOPS20 ROUTINE TO JUST READ A LINE FROM TTY INTO "ILINE"
ITTLIN: MOVEI T1,TXTIBL ;USE TEXTI BLOCK
MOVE T2,[POINT 7,ILINE] ;BUFFER POINTER
MOVEM T2,.RDDBP(T1) ;STORE IT
MOVEI T2,TXTLEN ;SIZE
MOVEM T2,.RDDBC(T1) ;STORE THAT
MOVX T2,RD%JFN!RD%BEL ;BREAK ON END OF TTY LINE
MOVEM T2,.RDFLG(T1) ;STORE FLAGS
TEXTI% ;DO TEXTI
ERJMP .+2 ;RETURN .+1 IF ERROR
AOS (PP) ;SKIP RETURN
POPJ PP, ;LINE IN "ILINE"
>;END IFN TOPS20
;HERE WITH CH= FIRST CHARACTER IN LINE, WHEN WE HAVE A REAL EOL CHARACTER
GYNCHK: CAIE CH,"Y" ;CHECK "Y"
CAIN CH,"y"
JRST GYNYES
CAIE CH,"N"
CAIN CH,"n"
GYNNO: AOSA (PP) ;NO RETURN
POPJ PP, ;NEITHER YES OR NO
GYNYES: AOS (PP) ;YES RETURN
POPJ PP,
SUBTTL RETURN TO COMMAND SCANNER
IFE TOPS20,<
;RETURN TO COMMAND SCANNER AFTER TYPING A FINAL CRLF
XECUTC: TYPE CRLF
; JRST XECUTX
>;END IFE TOPS20
IFN TOPS20,<
XECUTC=XECUTX ;TOPS20 COMND JSYS IS SMART ENOUGH TO KNOW IT MUST TYPE
; A CRLF FIRST, DON'T BOTHER DOING IT SEPARATELY
>
;HERE IS A LOC THAT IS "JRST"'D TO FROM ANYWHERE AT ALL.
; THE PUSHDOWN STACK IS ASSUMED TO HAVE BEEN CLOBBERED
; AND IS RESTORED FROM "PDL."
XECUTX: SETZB SW,NSUBS ;CLEAR FLAGS AND INIT PARSE
MOVE PP,PDL. ;RESTORE PUSH-DOWN-LIST
JRST DECOD ;***PARSE
SUBTTL TOPS10 COMMAND SCANNER FOR COBDDT
; THE COMMAND LINE IS READ INTO "TXTBUF", THEN PARSED
IFE TOPS20,<
DECOD: OUTSTR PRMTXT ;TYPE PROMPT
SETZM HLPMSG ;CLEAR ANY HELP TEXT FROM ERROR
MOVEI T3,TXTLEN ;GET MAX SIZE OF BUFFER
MOVE T2,[POINT 7,TXTBUF] ;POINT TO IT
MOVEM T2,TXTBBP ;SET INITIAL BP TO IT
DECOD0: INCHWL T1 ;GET A CHAR
CAIE T1,33 ;ALTMODES
CAIN T1,175
JRST DECALT ;YES, HANDLE THEM
CAIN T1,15 ;CR--IGNORE
JRST DECOD0
CAIE T1,32 ;CONTROL-Z
CAIN T1,7 ;CONTROL-G
JRST DECALT ;ALTERNATE FORM OF CRLF
CAIE T1,13 ;VT?
CAIN T1,14 ;FORM-FEED
MOVEI T1,12 ;PRETEND IT'S A LF
CAIN T1,12 ;GOT A LF NOW?
JRST DECEOL ;YES
IDPB T1,T2 ;STORE CHAR IN COMMAND LINE
SOJG T3,DECOD0 ;IF STILL ROOM, GO GET SOME MORE
TYPE [ASCIZ/?Command line too long/]
JRST XECUTC ;TRY AGAIN
;HERE FOR ALTERNATE FORMS OF CRLF, WHEN THE EOL DOESN'T DO A CRLF
DECALT: TYPE CRLF ;ALTMODE--TYPE CRLF
MOVEI T1,12 ;PRETEND IT'S A LF
; JRST DECEOL ;AND GO STORE IT
;HERE WHEN LINE IS DONE
DECEOL: IDPB T1,T2 ;STORE EOL CHAR
MOVEI T1,0 ;STORE NULL
IDPB T1,T2
;COMMAND LINE IS NOW IN "TXTBUF"
PUSHJ PP,GETUCH ;GET FIRST UPPERCASE CHAR
PUSHJ PP,NONSP ;GET FIRST NON-SPACE
CAIN CH,12 ;JUST A CR ON LINE?
JRST XECUTX ;YES, GO TYPE PROMPT AGAIN
MOVSI T1,-NMCMDS ;GET -# OF COMMANDS,,ADDR OF TABLE
HRRI T1,CMDTBL
PUSHJ PP,KEYWRD ;PARSE THE KEYWORD
JRST XECUTX ;UNKNOWN KEYWORD
;KEYWORD MATCHED -- GO DO IT
JRST (T2) ;GO DO IT NOW
SUBTTL TOPS10 COMMANDS
;COMMANDS MUST BE IN ALPHABETICAL ORDER. THEY MAY CONTAIN "-", "A" THRU "Z",
; AND "0" THRU "9"
DEFINE COMMANDS,<
CMDM ACCEPT,ACC.
CMDM BREAK,BRK.
CMDM CLEAR,CLR.
CMDM D,DIS. ;ABBREV. FOR "DISPLAY"
CMDM DDT,GODDT.
CMDM DISPLAY,DIS.
CMDM GO,GO%.
CMDM HELP,HLP.
CMDM HISTORY,HIS.
CMDM LOCATE,LOC.
CMDM MODULE,MOD.
CMDM NEXT,NEX.
CMDM OVERLAY,OVR.
CMDM PROCEED,PRO.
CMDM S,STP.
CMDM SHOW,SHO.
CMDM ST,STP.
CMDM STEP,STP.
CMDM STOP,STOP.
CMDM TRACE,TRC.
CMDM UNPROTECT,UNPRO.
CMDM WHERE,WHER.
>
DEFINE CMDM(A,B),<
XWD [ASCIZ/A/],B
>
CMDTBL: COMMANDS
NMCMDS==.-CMDTBL ;# OF COMMANDS
SUBTTL KEYWORD DISPATCHES FOR TOPS10
;"ACCEPT" COMMAND
ACC.: PUSHJ PP,PRSDNM ;PARSE DATANAME
MOVEI W1,ACCGEN ;PARSED CORRECTLY, GO HERE
JRST CODGNR
;"BREAK" COMMAND
BRK.: PUSHJ PP,PRSPNM ;PARSE PROCEDURE NAME
JUMPN W2,SETBRK ;A NAME GIVE, GO HERE
NOPNAM: TYPE [ASCIZ/?Procedure name must be given
/]
JRST XECUTX
;"CLEAR" COMMAND
CLR.: PUSHJ PP,PRSPNM ;PARSE PARAGRAPH NAME
JRST CLRBRK ;GO HERE
;"DISPLAY" COMMAND
DIS.: PUSHJ PP,PRSDNM ;PARSE A DATANAME
MOVEI W1,DISPGN ;GET GOOD DISPATCH ADDRESS
JRST CODGNR ;GEN CODE THEN DISPATCH
;"DDT" COMMAND
GODDT.: PUSHJ PP,CONFRM ;CONFIRM COMMAND
JRST GODDT ;GO DO IT
;"HELP" COMMAND
HLP.: TYPE [ASCIZ/% Please read COBDDT.HLP
/]
JRST XECUTX
;"GO" COMMAND
GO%.: PUSHJ PP,PRSPNM ;PARSE A PROCEDURE NAME
JUMPE W2,NOPNAM
JRST GOXXX ;GO AHEAD
;"HISTORY" COMMAND
HIS.: PUSHJ PP,NONSP ;GET 1ST NON-SPACE
CAIN CH,12 ;CR?
JRST HIS.E1 ;YES
HIS.1: HLPTXT <History commands are BEGIN, INITIALIZE, REPORT and END>
MOVE T1,[-NMHCDS,,HISTAB]
PUSHJ PP,KEYWRD ;PARSE THE KEYWORD
JRST XECUTX ;FAILED
JRST (T2) ;GO TO ROUTINE
HIS.E1: TYPE [ASCIZ/?History commands are BEGIN, INITIALIZE, REPORT and END
/]
JRST XECUTX
;HISTORY BEGIN
HIS.1A: PUSHJ PP,FILSTT ;GET FILESPEC, TITLE
PUSHJ PP,STICKF ;STORE APPROPRIATE THINGS
JRST HISBEG ;DO 'HISTORY BEGIN'
;HISTORY END
HIS.2: PUSHJ PP,CONFRM ;EOL NEXT
JRST HISSTO ;DO IT
;HISTORY INITIALIZE
HIS.3: PUSHJ PP,FILSTT ;PARSE [FILESPEC] 'TITLE'
PUSHJ PP,STICKF ;STORE APPROPRIATE THINGS
JRST HISINI ;GO DO IT
;HISTORY REPORT
HIS.4: PUSHJ PP,FILSTT ;PARSE [FILESPEC] 'TITLE'
PUSHJ PP,STICKF ;STORE APPROPRIATE THINGS
JRST HISREP ;DO IT
HISTAB: [ASCIZ/BEGIN/],,HIS.1A
[ASCIZ/END/],,HIS.2
[ASCIZ/INITIALIZE/],,HIS.3
[ASCIZ/REPORT/],,HIS.4
NMHCDS==.-HISTAB ;NUMBER OF HISTORY COMMANDS
;ROUTINE TO PARSE [FILESPEC] 'TITLE'
;STORES TITLE IN HSTTTL, FILESPEC IN INPDEV AND INPFSP
FILSTT: TXZ SW,FILGVN!SAWDOT!SAWPPN ;CLEAR FILESPEC FLAGS
SETZM INPDEV ;CLEAR INPUT FILESPEC STUFF
MOVE T1,[INPDEV,,INPFSP]
BLT T1,INPFSP+10 ;CLEAR ALL WORDS
CAIN CH,12 ;CRLF NEXT ON LINE?
POPJ PP, ;YES, JUST RETURN
;LOOK FOR BEGINNING QUOTE OF TITLE
MOVE T4,TXTBBP
ILDB T1,T4
CAIE T1," "
CAIN T1,11
JRST .-3 ;SKIP LEADING BLANKS
CAIN T1,"'" ;'TITLE'?
JRST GOTQT ;YES, GO GET IT
;NO TITLE, TRY TO PARSE THE FILESPEC
TXO SW,FILGVN ;OBVIOUSLY: A FILESPEC GIVEN
PUSHJ PP,PRSSIX ;GET SOMETHING
JUMPE T5,NULWD ;NULL WORD, CHECK FOR "["
CAIN CH,":" ;COLON TO END DEVICE NAME?
JRST [MOVEM T5,INPDEV ;YES, STORE DEVICE NAME
JRST SAWDEV] ;GO GET THE REST
JRST CHKNAM ;SEE IF A NAME, ETC.
SAWDEV: PUSHJ PP,PRSSIX ;GET NAME
JUMPE T5,NULWD ;?NULL WORD, GO SEE
CHKNAM: MOVEM T5,INPFSP ;STORE NAME
CAIN CH,"." ;DOT?
JRST GETEXT ;YES, GO GET EXT
CAIN CH,"[" ;START OF PPN?
JRST GETPPN ;YES, GO GET THE PPN
PUSHJ PP,NONSP ;SPACE COULD BE END OF FILENAME
CAIN CH,"'" ;START OF TITLE?
JRST GOTQT ; YES, GO GET IT
CAIN CH,12 ;EOL?
POPJ PP, ;YES, RETURN
TYPE [ASCIZ/?Invalid character in filename: /]
TYPEAC CH ;TYPE OFFENDING CHARACTER
JRST XECUTC ;TYPE CRLF AND EXIT
;DOT SEEN.. PARSE EXTENSION
GETEXT: TXO SW,SAWDOT ;SET FLAG SO WE KNOW HE TYPED ONE
PUSHJ PP,PRSSIX ;GET EXTENSION
JUMPE T5,NULWD ;NULL WORD
HLLZM T5,INPFSP+1 ;STORE EXTENSION
PUSHJ PP,NONSP ;GET TO 1ST NON-SPACE
CAIN CH,"[" ;START OF PPN
JRST GETPPN ;YES
CAIN CH,12 ;EOL?
POPJ PP, ;YES, RETURN NOW
CAIN CH,"'" ;START OF TITLE?
JRST GOTQT ;YES
;GIVE ERROR
GARBAG: PUSH PP,TXTBBP
POP PP,PRSBBP
MOVEM CH,PRSCHR
TYPE [ASCIZ/?Garbage after filespec/]
PUSHJ PP,BUTGOT
JRST XECUTX ;ERROR, AND GIVE UP
;NULL WORD
NULWD: CAIN CH,"[" ;START OF PPN?
JRST GETPPN
CAIN CH,12 ;EOL?
POPJ PP, ;YES, JUST RETURN
CAIN CH,"'" ;START OF TITLE?
JRST GOTQT ;YES
PUSH PP,TXTBBP ;COMPLAIN
POP PP,PRSBBP
MOVEM CH,PRSCHR
TYPE [ASCIZ/?Error in filespec/]
PUSHJ PP,BUTGOT
JRST XECUTX
;[ SEEN TO START PPN
GETPPN: TXO SW,SAWPPN ;SET PPN FLAG SO WE CAN DEFAULT CORRECTLY
PUSHJ PP,PRSOCT ;GET AN OCTAL NUMBER
HRLM T1,INPFSP+3 ;STORE PROJ NUMBER
CAIN CH,"," ;COMMA
JRST GETPRG ;YES
CAIN CH,"-" ;[-] MEANS DON'T DEFAULT [PPN]
JRST GETEPN ;YES IT IS
TYPE [ASCIZ/?Comma expected in PPN/]
PUSH PP,TXTBBP
POP PP,PRSBBP ;START HERE WITH TYPING OUT THE PROBLEM
MOVEM CH,PRSCHR
PUSHJ PP,BUTGOT ;TYPE WHAT WE ACTUALLY GOT
JRST XECUTX ;TYPE CRLF, THEN LEAVE
GETPRG: PUSHJ PP,PRSOCT ;GET PROGRAMMER NUMBER
HRRM T1,INPFSP+3 ;STORE IT
CAIN CH,"," ;ANOTHER COMMA
JRST GETSFD ;GET SFD'S
CAIN CH,12 ;EOL
POPJ PP, ;YES, RETURN
CAIN CH,"]" ;END OF PPN
JRST GOTEPN ;YES
PUSH PP,TXTBBP
POP PP,PRSBBP ;MAKE ERROR ROUTINE POINT TO INVALID TERMINATOR
MOVEM CH,PRSCHR
TYPE <[ASCIZ/?Expected "]" to end PPN/]>
PUSHJ PP,BUTGOT
JRST XECUTX ;GIVE UP
;HERE TO PARSE SFD'S
GETSFD: MOVEI P1,5 ;MAX NUMBER OF SFD'S
MOVEI P2,INPFSP+4 ;POINTER TO PLACE TO STORE IT
GETNFD: PUSHJ PP,PRSSIX ;GET AN SFD NAME
MOVEM T5,(P2) ;STORE IT
AOJ P2, ;UPDATE POINTER
CAIN CH,"]" ;END OF PPN
JRST GOTEPN ;YES
CAIN CH,12 ;EOL
POPJ PP, ;YES, RETURN
CAIN CH,"," ;MORE SFD'S?
JRST [SOJG P1,GETNFD ;YES, GO GET MORE IF WE CAN
TYPE [ASCIZ/?Too many SFD's specified
/]
JRST XECUTX]
PUSH PP,TXTBBP
POP PP,PRSBBP ;MAKE ERROR ROUTINE POINT TO INVALID TERMINATOR
MOVEM CH,PRSCHR
TYPE <[ASCIZ/?Expected "," or "]" to end SFD/]>
PUSHJ PP,BUTGOT
JRST XECUTX ;GIVE UP
;HER TO END [-] CORRECTLY
GETEPN: TXZ SW,SAWPPN ;CLEAR FLAG SO WE DON'T DEFAULT
PUSHJ PP,GETUCH ;GET "]"
;HERE WHEN GOT A "]" TO END PPN
GOTEPN: PUSHJ PP,GETUCH ;NEXT CHAR AFTER PPN
PUSHJ PP,NONSP ;FIRST NON-SPACE, PLEASE
CAIN CH,12 ;JUST A CRLF?
POPJ PP, ;YES, RETURN
;CHECK FOR A "'" TO START TITLE
CAIE CH,"'" ;START OF TITLE?
JRST GARBAG ;NO, GARBAGE AFTER FILESPEC
;HERE WHEN SAW LEADING "'" FOR TITLE
GOTQT: MOVE T3,[POINT 7,HSTTTL] ;SET UP TO READ TITLE INTO HERE
GOTQT0: ILDB CH,TXTBBP ;GET NEXT CHAR
CAIN CH,"'" ;ENDING QUOTE
JRST GOTQTE ;YES
CAIN CH,12 ;OR JUST A CRLF
JRST ENDTTL ;IS END
IDPB CH,T3 ;STORE CHAR IN TITLE STRING
JRST GOTQT0 ;LOOP
;GOT ENDING QUOTE FOR TITLE STRING
GOTQTE: ILDB CH,TXTBBP
PUSHJ PP,NONSP ;GET FIRST NON-SPACE AFTER TITLE ENDING QUOTE
CAIN CH,12 ;EOL
JRST ENDTTL ;IS OK
TYPE [ASCIZ/?Junk after 'TITLE' string/]
PUSH PP,TXTBBP
POP PP,PRSBBP
MOVEM CH,PRSCHR
PUSHJ PP,BUTGOT
SETZ T1,
IDPB T1,T3 ;STORE NULL TO END TITLE
JRST XECUTX ;BUT DON'T RETURN FROM PARSE CORRECTLY
;GOT CRLF TO END TITLE
ENDTTL: SETZ T1,
IDPB T1,T3 ;STORE NULL TO END TITLE
POPJ PP, ;RETURN FROM PARSE
;ROUTINE TO STORE THE INPUT FILESPEC IN THE APPROPRIATE PLACES, AND FILL
; IN DEFAULTS, ETC.
;CALL:
; FILDEV/ SIXBIT DEVICE NAME (0 IF NONE SPECIFIED)
; INPFSP/ FILENAME (0 IF NONE SPECIFIED)
; +1/ EXTENSION (0 IF NONE SPECIFIED, OR NULL)
; NOTE: FLAG "SAWDOT" TELLS YOU WHICH CASE
; +2/ NOT USED
; +3/ P,PN (P AND/OR PN MAY BE 0)
; +4/ SFD1 (0 FOR NOT SPECIFIED)
; +5/ SFD2 (" ")
; ... +10/ SFD5
;RETURNS:
; .+1 WITH ENTER BLOCKS, ETC, ALL SET UP
STICKF: TXNN SW,FILGVN ;WAS FILESPEC GIVEN?
POPJ PP, ;NO, RETURN
SKIPN T1,INPDEV ;GET DEVICE
MOVSI T1,'DSK' ;DEFAULT IS DSK
MOVEM T1,HSTDEV ;STORE IN FILOP. BLOCK
MOVE T1,INPFSP ;GET FILENAME
MOVEM T1,HSTNAM
SKIPN T1,INPFSP+1 ;GET EXTENSION
MOVSI T1,'HIS' ;DEFAULT IT
MOVEM T1,HSTEXT
SETZM HSTEXT+1 ;CLEAR PROTECTION CODE
SETZM HSTPP ;AND PATH POINTER
TXNN SW,SAWPPN ;DID WE SEE A PPN?
POPJ PP, ;NO, DON'T DEFAULT ONE
MOVE T1,INPFSP+3 ;NO, GET PPN (OR ZERO)
TLNN T1,-1 ;NEED TO DEFAULT?
HLL T1,DEFPPN ;YES
TRNN T1,-1 ;DEFAULT?
HRR T1,DEFPPN
SKIPE INPFSP+4 ;ANY SFD'S?
JRST STCKF1 ;YES
MOVEM T1,HSTPP
POPJ PP,
STCKF1: MOVEM T1,HSTPPN
MOVEI T1,HSTPTH
HRRZM T1,HSTPP ;FORM PATH POINTER
MOVE T1,[INPFSP+4,,HSTSFD]
BLT T1,HSTSFD+4 ;COPY FULL SFD
POPJ PP, ;DONE, RETURN
;"LOCATE" COMMAND
LOC.: PUSHJ PP,PRSDPN ;PARSE DATANAME OR PROCEDURE NAME
JRST LOCTYP ;DO 'LOCATE'
;"MODULE" COMMAND
MOD.: PUSH PP,TXTBBP ;CHECK FOR CRLF FOLLOWING THIS
PUSHJ PP,NONSP ;(INCASE OF TRAILING SPACES)
POP PP,TXTBBP
CAIN CH,12 ;JUST CRLF?
JRST MODH ;YES, TYPE MODULES IN CORE
PUSHJ PP,PRSMOD ;GET SIXBIT WORD INTO T5
JUMPE T5,MODNEX ;?MODULE NAME EXPECTED
JRST MOD.1 ;GO DO IT
MODNEX: TYPE [ASCIZ/?Module name expected
/]
JRST XECUTX
;"NEXT" COMMAND
;GET OPTIONAL NUMBER AFTER COMMAND (DEFAULT IS 1)
; AND GO TO NEXT1
NEX.: PUSH PP,TXTBBP ;CRLF OR NUMBER ALLOWED
PUSHJ PP,NONSP ;GET ONE
POP PP,TXTBBP
CAIN CH,12 ;JUST CRLF?
JRST NEXCR ;YES, DEFAULT TO 1
PUSHJ PP,PRSDEC ;ELSE GET DECIMAL NUMBER
JUMPE T2,DNMEX ;?DECIMAL NUMBER EXPECTED
MOVE W2,T2 ;SAVE INTEGER (CAN BE NEGATIVE)
PUSHJ PP,CONFRM ;CONFIRM
JRST NEXT1 ;GO DO IT
NEXCR: MOVEI W2,1 ;DEFAULT TO 1
JRST NEXT1
;"OVERLAY" COMMAND
OVR.: PUSHJ PP,ONOFF ;GET "ON" OR "OFF"
TDZA W2,W2 ;"OFF"
SETO W2, ;"ON"
PUSHJ PP,CONFRM ;CONFIRM THE COMMAND
JRST SETOVR
;"PROCEED" COMMAND
PRO.: PUSH PP,TXTBBP ;CHECK FOR CRLF NEXT
PUSHJ PP,NONSP
POP PP,TXTBBP
CAIE CH,12 ;CRLF NEXT?
JRST PRO.1 ;NO, LOOK FOR NUMBER
MOVEI W2,1 ;YES, GET VALUE OF 1
JRST PROCED ;GO DO IT
PRO.1: PUSHJ PP,PRSDEC ;PARSE A DECIMAL NUMBER
JUMPE T2,NOTPIN ;"POSITIVE INTEGER REQUIRED"
JUMPLE T1,NOTPIN ;NEG OR ZERO IS NO GOOD
MOVE W2,T1 ;SAVE COUNT IN W2
PUSHJ PP,CONFRM ;CONFIRM IT
JRST PROCED ;OK, GO TO PROCEED CODE
;GIVE ERROR "POSITIVE INTEGER REQUIRED"
NOTPIN: TYPE [ASCIZ/?Positive integer required/]
PUSHJ PP,BUTGOT
JRST XECUTX
;"SHOW" COMMAND
SHO.: PUSHJ PP,NONSP ;GET TO FIRST NON-SPACE
HLPTXT <SHOW command syntax is "SHOW SYMBOLS symbol-name-mask">
CAIN CH,12 ;CR?
JRST [PUSHJ PP,KEWERR ;GIVE KEYWORD ERROR (WILL TYPE HELP MESSAGE)
JRST XECUTX] ;AND RETURN
MOVE T1,[-NMSCDS,,SHOTAB]
PUSHJ PP,KEYWRD ;PARSE THE KEYWORD
JRST XECUTX ;FAILED
JRST (T2) ;GO TO ROUTINE
SHOTAB: [ASCIZ/SYMBOLS/],,SHO.S
NMSCDS==.-SHOTAB ;NUMBER OF "SHOW" COMMANDS
;"SHOW SYMBOLS"
SHO.S: CAIN CH,12 ;CR?
JRST MSKEXP ;YES, SAY MASK MUST BE TYPED
PUSHJ PP,PRSMSK ;PARSE SYMBOL MASK
PUSHJ PP,CONFRM ;CONFIRM
JRST DOSHOS ;GO EXECUTE COMMAND
;"STEP" COMMAND
STP.: PUSH PP,TXTBBP
PUSHJ PP,NONSP
POP PP,TXTBBP
CAIE CH,12 ;GOT CR NEXT?
JRST STP.1 ;NO, LOOK FOR NUMBER
MOVEI W2,1 ;YES, GET VALUE OF 1
JRST STEP
STP.1: PUSHJ PP,PRSDEC ;PARSE DECIMAL NUMBER
JUMPE T2,NOTPIN ;"POSITIVE INTEGER REQUIRED"
JUMPLE T1,NOTPIN
MOVE W2,T1 ;SAVE COUNT
PUSHJ PP,CONFRM ;CONFIRM
JRST STEP ;ALL OK, GO TO COMMON CODE
;"STOP" COMMAND
STOP.: PUSHJ PP,CONFRM ;CONFIRM IT
JRST STOPR ;GO DO IT
;"TRACE" COMMAND
TRC.: HLPTXT <ON/OFF/BACK required>
PUSHJ PP,NONSP ;GET TO FIRST NON-SPACE.
MOVE T1,[-NMTCMS,,TRCCMD]
PUSHJ PP,KEYWRD ;LOOK FOR KEYWORD
JRST XECUTX ;CAN'T FIND IT
PUSH PP,T2 ;SAVE DISPATCH ADDRESS
PUSHJ PP,CONFRM ;CONFIRM COMMAND
POP PP,T2 ;OK, RESTORE DISPATCH ADDRESS
JRST (T2) ;FOUND.. DISPATCH
TRCCMD: [ASCIZ/BACK/],,TRCB
[ASCIZ/OFF/],,TRCOFF
[ASCIZ/ON/],,TRCON
NMTCMS==.-TRCCMD ;NUMBER OF 'TRACE' COMMANDS
TRCOFF: TDZA W2,W2 ;"OFF"
TRCON: SETO W2, ;"ON"
JRST TRCONF ;SET TRACE ON/OFF
;"UNPROTECT" HI-SEG COMMAND
UNPRO.: PUSHJ PP,CONFRM ;CONFIRM
JRST UNPROT ;AND GO DO IT
;"WHERE" COMMAND
WHER.: PUSHJ PP,CONFRM ;CONFIRM
JRST WHERE ;AND GO DO IT
;SUBTTL TOPS10 KEYWORD PARSER
;ROUTINE TO PARSE AT KEYWORD. READS AND UPDATES BYTE POINTER TO COMMAND
; LINE (TXTBBP).
;CALL: T1/ -# OF KEYWORDS IN TABLE,,ADDR OF TABLE
; CH/ FIRST CHAR OF KEYWORD
; TABLE FORMAT IS [ASCIZ/KEYWORD/],,ADDR OF ROUTINE TO CALL
;
;RETURNS .+1 IF KEYWORD DOESN'T MATCH, OR IS NOT A UNIQUE ABBREVIATION
;RETURNS .+2 IF KEYWORD DOES MATCH, WITH ADDRESS OF ROUTINE IN T2
;
;UPPER AND LOWERCASE ARE TREATED AS EQUIVALENT
KEYWRD: MOVEM CH,PRSCHR ;SAVE 1ST PARSED CHARACTER
MOVE T4,[POINT 7,ATMBUF] ;PUT KEYWORD IN ATOM BUFFER FIRST
PUSH PP,TXTBBP ;REMEMBER BP AT START OF KEYWORD
POP PP,PRSBBP
KEYWR2: CAIL CH,"A"
CAILE CH,"Z" ;BETWEEN "A" AND "Z"?
JRST NOTLTR ;NO
OKLTR: IDPB CH,T4 ;OK, STORE CHARACTER
PUSHJ PP,GETUCH ;GET NEXT CHARACTER OF KEYWORD
JRST KEYWR2 ;GO CHECK IT OUT
NOTLTR: CAIL CH,"0"
CAILE CH,"9" ;ALLOW 0 THRU 9 IN KEYWORD
CAIA
JRST OKLTR
CAIN CH,"-" ;ALLOW DASH IN KEYWORD
JRST OKLTR
;HMM THIS CHARACTER IS INVALID. MUST BE END OF KEYWORD.
;NOW WE TRY TO MATCH IT WITH TABLE ENTRIES.
KEYWD2: MOVEI T2,0 ;STORE NULL TO END KEYWORD ATOM
IDPB T2,T4
MOVE T4,[POINT 7,ATMBUF] ;GET POINTER TO ATOM BUFFER
ILDB T5,T4 ;GET FIRST CHARACTER OF KEYWORD
JUMPE T5,[MOVEI T1,[ASCIZ/Keyword expected/]
JRST KEWERR]
KEYWD3: HLR T3,(T1) ;GET PTR TO AN ASCII STRING
HRLI T3,(POINT 7,)
ILDB T2,T3 ;GET FIRST CHAR OF THIS STRING
CAMN T2,T5 ;DOES IT MATCH SO FAR?
JRST KEYWD4 ;YES!
CAML T2,T5 ;GONE TOO FAR?
JRST NOMTCH ;YES, SAY "NO MATCH"
AOBJN T1,KEYWD3 ;NO, GET DOWN TO A COMMAND THAT STARTS WITH
;THIS CHARACTER
NOMTCH: MOVEI T1,[ASCIZ/Invalid keyword/] ;DEFAULT MESSAGE
JRST KEWERR
;HERE WHEN WE GET A KEYWORD ERROR.. TYPE THE STANDARD MESSAGE
; UNLESS HE HAS SETUP "HLPMSG"
KEWERR: OUTCHR ["?"] ;START MESSAGE
SKIPE HLPMSG ;ANY HELP MESSAGE?
JRST [ OUTSTR @HLPMSG ;YES, PRINT IT
SETZM HLPMSG ;CLEAR MESSAGE
JRST KEWER1] ;AND GO FINISH MESSAGE
OUTSTR (T1) ;PRINT STANDARD MESSAGE
KEWER1: OUTSTR CRLF ;CRLF TO END MESSAGE
SETZM PRSCHR ;CLEAR 1ST PARSED CHAR
POPJ PP, ;ERROR RETURN
;HERE IF FIRST CHARACTER OF KEYWORD MATCHES
KEYWD4: ILDB T5,T4 ;GET NEXT CHARACTER
ILDB T2,T3
JUMPE T5,[JUMPE T2,KWDMTC ;GOT A MATCH
JRST TRYUNI] ;ELSE TRY FOR A UNIQUE ABBREVIATION
CAMN T2,T5 ;STILL MATCH?
JRST KEYWD4 ;YES, CONTINUE TRYING TO MATCH
;STOPPED MATCHING. LOOK AT NEXT COMMAND FOR POSSIBLE MATCH.
CAML T2,T5 ;SKIP IF MAYBE NEXT COMMAND IS OK
JRST NOMTCH ;NO, INVALID KEYWORD
MOVE T4,[POINT 7,ATMBUF] ;POINT TO ATOM BUFFER AGAIN
ILDB T5,T4 ;GET 1ST CHAR AGAIN
AOBJN T1,KEYWD3 ;IF MORE COMMANDS, TRY NEXT ONE
JRST NOMTCH ;REACHED END OF TABLE, NO MATCH
;HERE TO TRY FOR A UNIQUE ABBREVIATION
TRYUNI: AOBJP T1,OKUNI ;NO MORE COMMANDS = IT MATCHES!
HLR T3,(T1) ;POINT TO NEXT COMMAND
HRLI T3,(POINT 7,)
MOVE T4,[POINT 7,ATMBUF] ;BETTER NOT MATCH TO UNIQUE ABBREV..
TRYUN1: ILDB T5,T4 ;GET CHAR TYPED
ILDB T2,T3 ;GET CHAR OF NEXT COMMAND
CAMN T5,T2 ;SAME SO FAR?
JRST TRYUN1 ;YES, KEEP LOOKING
JUMPN T5,OKUNI ;IT IS UNIQUE IF REAL CHAR TYPED AND NO MATCH
NOTUNI: MOVEI T1,[ASCIZ/Not unique/] ;GET DEFAULT MESSAGE
JRST KEWERR ;GO PRINT ERROR
OKUNI: SUBI T1,1 ;MAKE T1 POINT TO THE COMMAND THAT IS UNIQUE
;HERE WHEN WE GOT A MATCH. RETURN T2=ADDRESS OF ROUTINE TO CALL
KWDMTC: HRRZ T2,(T1) ;RH OF TABLE ENTRY = ADDRESS OF ROUTINE
SETZM HLPMSG ;CLEAR HELP TEXT IF GIVEN
SETZM PRSCHR ;CLEAR 1ST PARSED CHAR
JRST CPOPJ1 ;GIVE GOOD RETURN
;ROUTINE TO TYPE ", GOT: ", 'REST OF LINE'
; CALL AFTER TYPING "?BLAH EXPECTED"
;RETURNS WITH POPJ
BUTGOT: TYPE [ASCIZ/, got: /]
SKIPE T1,PRSCHR ;A PARSED CHAR TO TYPE?
TYPEAC T1 ;YES
SETZM PRSCHR ;CLEAR PARSED CHARACTER
BUTGT1: ILDB T1,PRSBBP
JUMPE T1,BGERR ;?INTERNAL COBDDT ERROR
CAIN T1,12 ;EOL
JRST TEOL
TYPEAC T1 ;TYPE THE CHARACTER
JRST BUTGT1 ;LOOP
TEOL: TYPE [ASCIZ/<EOL>
/]
POPJ PP, ;RETURN
BGERR: TYPE [ASCIZ/
?Internal COBDDT error - a bug!
/]
POPJ PP,
;ROUTINE TO PARSE "ON/OFF"
;DOESN'T RETURN IF NEXT THING IS NOT "ON" OR "OFF"
;RETURNS .+1 IF "OFF", .+2 IF "ON"
ONOFF: HLPTXT <ON/OFF required>
PUSHJ PP,NONSP ;GET FIRST NON-SPACE
MOVE T1,[-2,,ONOFTB]
PUSHJ PP,KEYWRD ;PARSE KEYWORD
JRST XECUTX ;DIDN'T GET EITHER ONE
JRST (T2) ;PARSED, GO TO ROUTINE
ONOFTB: [ASCIZ/OFF/],,CPOPJ
[ASCIZ/ON/],,CPOPJ1
;ROUTINE TO PARSE "OF/IN"
; THIS IS CALLED FROM THE "PRSNAM" ROUTINE WHEN THERE IS SOMETHING
; ON THE LINE, WHICH CAN ONLY BE "OF" OR "IN"
;RETURNS .+1 IF "OF" OR "IN" PARSED, WITH TXTBBP POINTING TO NEXT CHAR.
; ELSE GOES TO XECUTX
OFIN: PUSHJ PP,NONSP ;GET FIRST NON-BLANK, COULD BE THIS CHAR.
MOVE T2,TXTBBP
MOVEM T2,PRSBBP ;SAVE START OF THIS THING (?WHATEVER IT IS)
MOVEM CH,PRSCHR
CAIN CH,"O" ;COULD IT BE "OF"?
JRST OFOF ;YES, TRY IT
CAIN CH,"I" ;COULD IT BE "IN"?
JRST OFINN ;YES, TRY IT
NOTOFI: TYPE [ASCIZ/?Only "OF" or "IN" legal/]
PUSHJ PP,BUTGOT
JRST XECUTX ;SCREW THIS PARSE
OFOF: PUSHJ PP,GETUCH ;GET NEXT CHAR
CAIE CH,"F"
JRST NOTOFI
OFININ: SETZM PRSCHR ;"OF", "IN" SEEN
PUSHJ PP,GETUCH ;GET NEXT CHAR
PUSH PP,CH ;SAVE REAL CHAR FOLLOWING OF/IN
PUSH PP,TXTBBP ;PEEK AHEAD TO SEE WHAT FOLLOWS
PUSHJ PP,NONSP
POP PP,TXTBBP
CAIN CH,12 ;EOL
JRST OFINCR ;BAD
POP PP,CH ;RESTORE REAL CHAR FOLLOWING OF/IN
POPJ PP, ;RETURN OK
OFINCR: TYPE [ASCIZ/?Qualifier expected, got: <EOL>
/]
SETZM PRSCHR
JRST XECUTX
OFINN: PUSHJ PP,GETUCH ;GET NEXT CHAR OF "IN"
CAIE CH,"N"
JRST NOTOFI ;NOPE
JRST OFININ
;ROUTINE TO CONFIRM A COMMAND
; IT POPJ'S IF NEXT THING ON THE LINE IS A CRLF, WHICH CONFIRMS THE
;COMMAND. IF THE NEXT THING ISN'T A CRLF, IT TYPES AN ERROR MESSAGE
; AND GOES TO XECUTX TO PARSE ANOTHER COMMAND.
CONFRM: PUSHJ PP,NONSP ;GET TO FIRST NON-BLANK
CAIN CH,12 ;CR?
POPJ PP, ;YES, POPJ
NOTCFM: TYPE [ASCIZ/?Not confirmed/]
PUSH PP,TXTBBP
POP PP,PRSBBP
MOVEM CH,PRSCHR ;ALSO TYPE THIS CHAR
PUSHJ PP,BUTGOT
JRST XECUTX
;GET FIRST CHAR WHICH IS A NON-SPACE
NONSP: CAIE CH,11
CAIN CH,40
CAIA
POPJ PP,
PUSHJ PP,GETUCH ;GET UPPERCASE CHAR
JRST NONSP
;ROUTINE TO PARSE A NUMBER
;RETURNS NUMBER PARSED IN T1
;RETURNS NUMBER OF DIGITS IN T2
PRSDEC: SKIPA T3,[^D10] ;PARSE A DECIMAL NUMBER
PRSOCT: MOVEI T3,^D8 ;PARSE AN OCTAL NUMBER
SETZB T1,T2 ;CLEAR RESULT ,T2=0 MEANS NO NUMBERS SEEN YET
MOVE T4,TXTBBP
MOVEM T4,PRSBBP
SETZM PRSCHR ;CHAR IN CH IS NOT USED
PRSRD1: ILDB CH,TXTBBP
CAIE CH,11
CAIN CH," "
JRST PRSRD1
CAIN CH,"-" ;MINUS SIGN
JRST [TXO SW,MINFLG ;YES, SET FLAG
ILDB CH,TXTBBP ;GET NEXT CHAR
JRST PRSRD2] ;GO LOOK AT NUMBER
TXZ SW,MINFLG ;NO, CLEAR FLAG
PRSRD2: CAIL CH,"0"
CAILE CH,"0"-1(T3) ;IS NUMBER IN RANGE?
JRST [TXNE SW,MINFLG ;STOP PARSING, IF NUMBER NEGATIVE?
MOVN T1,T1 ;YES, NEGATE
POPJ PP,] ;RETURN
IMUL T1,T3 ;MAKE ROOM FOR NEXT DIGIT
ADDI T1,-"0"(CH) ;ADD IT IN
ADDI T2,1 ;COUNT DIGITS SEEN
ILDB CH,TXTBBP ;GET NEXT CHARACTER
JRST PRSRD2 ;AND KEEP GOING...
;ROUTINE TO PARSE A SIXBIT WORD AND RETURN IT IN T5.
;CHAR IN CH IS NOT USED
PRSSIX: MOVE T3,[POINT 6,T5] ;GET A BYTE POINTER TO THE WORD.
SETZ T5, ;CLEAR IT TO START.
PRSSX1: PUSHJ PP,GETUCH ;GET NEXT UPPERCASE CHAR.
PUSHJ PP,NONSP ;SKIP LEADING SPACES AND TABS
PRSSX0: CAIL CH,"A" ;ALPHANUMERIC ONLY ALLOWED
CAILE CH,"Z"
JRST PRSSX2
PRSSXO: SUBI CH,40 ;CHAR OK, STASH IT
TLNE T3,770000 ;IF ROOM
IDPB CH,T3 ;STORE CHAR
PUSHJ PP,GETUCH ;GET NEXT CHAR
JRST PRSSX0 ;GO ADD IT TO STRING
PRSSX2: CAIL CH,"0"
CAILE CH,"9" ;0 THRU 9 OK
POPJ PP, ;HERE IF NON-SIXBIT CHAR, RETURN
JRST PRSSXO ;JUMP -- CHAR OK
;ROUTINE TO PARSE A MODULE WORD AND RETURN IT IN T5.
;CHAR IN CH IS NOT USED
;SAME AS PRSSIX EXCEPT THAT IT ALLOWS "-" IN MODULE NAME.
PRSMOD: PUSHJ PP,PRSSIX ;USE COMMON CODE TO PARSE SIXBIT
PRSMD1: CAIE CH,"-" ;STOPPED ON HYPHEN?
POPJ PP, ;NO, RETURN
PUSHJ PP,PRSSXO ;YES, STORE IT
JRST PRSMD1 ;ALLOW MULTIPLE HYPHENS
;ROUTINE TO PARSE A PROCEDURE NAME
PRSPNM: TXZ SW,DNFLG ;DATANAMES NOT ALLOWED
TXO SW,PNFLG ;LOOK FOR PROCEDURE NAMES
JRST PRSNAM
;ROUTINE TO PARSE A DATANAME
PRSDNM: TXZ SW,PNFLG ;PROCEDURE NAMES NOT ALLOWED
TXO SW,DNFLG ;LOOK FOR DATANAMES
JRST PRSNAM
;ROUTINE TO PARSE A DATANAME OR PROCEDURE NAME
PRSDPN: TXO SW,PNFLG!DNFLG ;SET BOTH FLAGS
PRSNAM: TXZ SW,PRNMFG ;DIDN'T SEE A PROCEDURE NAME
SETZM NSUBS ;CLEAR SUBSCRIPT COUNT
CAIN CH,12 ;CR NOW?
JRST RETZRO ;YES, RETURN NO SYMBOL
;PEEK AHEAD TO SEE IF NEXT THING WILL BE A <CRLF>
PUSH PP,TXTBBP
PUSHJ PP,NONSP
POP PP,TXTBBP
CAIN CH,12
JRST RETZRO ;YES, RETURN 0
PRSNM0: PUSHJ PP,PRSCNM ;PARSE A COBOL NAME (RETURNS IF SYNTAX OK)
SKIPN C74FLG ;ANS68?
TXNN SW,DNFLG ;AND PARSING A DATANAME?
JRST PRSNTY ;NO
MOVE T1,DNAME6 ;GET 1ST 6 CHARS
CAMN T1,[SIXBIT /TALLY/] ;CHECK FOR "TALLY"
JRST PRSTLY ;GOT IT-- GO FINISH PARSING IT
PRSNTY: TXZ SW,FLNMOK ;FILENAMES ARE NOT ALLOWED HERE
PUSHJ PP,LOOKNM ;LOOKUP NAME
JRST XECUTX ;ERROR
JUMPE DT,UNDEFD ;?NOT FOUND
;IF DATANAME, LOOK FOR SUBSCRIPTS
PUSHJ PP,NONSP ;GET TO FIRST NON-SPACE IN ANY CASE.
TXNN SW,DNFLG
JRST PRSNM5 ;NO SUBSCRIPTS ALLOWED ON PROCEDURE NAMES
CAIN CH,12 ;IS NEXT THING CRLF?
JRST PRSNM5 ;YES, GO TO "SUBSCRIPTS TAKEN CARE OF"
CAIN CH,"(" ;LPAREN, START OF SUBSCRIPTS?
JRST NXTSBS ;YES, GET "NEXT" SUBSCRIPT
;NOT PAREN.. ONLY "OF/IN" MAY HAPPEN NOW.
PUSHJ PP,OFIN
JRST PRSNM3 ;OK, GO PARSE QUALIFIER
;HERE TO PARSE NEXT SUBSCRIPT
NXTSBS: PUSHJ PP,PRSDEC ;GO GET A NUMBER
JUMPE T2,DNMEX ;NO DIGITS--?DECIMAL NUMBER EXPECTED
MOVE T2,T1 ;GET NUMBER PARSED
SUBIOK: AOS T1,NSUBS
CAILE T1,3 ;CHECK MAX ALLOWED
JRST STOOMN ;?TOO MANY SUBSCRIPTS
MOVEM T2,SUB0.-1(T1) ;STASH AWAY
;FIND TERMINATOR FOR SUBSCRIPT.
SUBIK1: CAIE CH," " ;SPACE?
CAIN CH,"," ;OR COMMA?
JRST NXTSBS ;YES, GO PARSE MORE SUBSCRIPTS
CAIN CH,11
JRST NXTSBS ;TAB, TOO.
CAIN CH,")" ;END OF SUBSCRIPTS?
JRST SUBIK3 ;YES
TYPE [ASCIZ/?Invalid terminator for subscript: /]
CAIN CH,12 ;CRLF?
JRST SUBIEC ;YES
TYPEAC CH
JRST XECUTC
SUBIEC: TYPE [ASCIZ/<EOL>
/]
JRST XECUTX
;HERE IF WE WANTED TO GET A SUBSCRIPT, BUT THE THING WASN'T A DECIMAL NUMBER
DNMEX: TYPE [ASCIZ/? Decimal number expected/]
PUSHJ PP,BUTGOT
JRST XECUTX
;RPAREN AFTER SUBSCRIPT
SUBIK3: PUSHJ PP,GETUCH ;GET CHAR AFTER ")"
PUSHJ PP,NONSP ;START AT FIRST NON-SPACE
;REVERSE ORDER OF SUBSCRIPTS
MOVE T2,NSUBS ;# SUBSCRIPTS SEEN
MOVE T1,SUB0. ;GET FIRST SUBSCRIPT
EXCH T1,SUB0.-1(T2) ;EXCHANGE WITH LAST SUBSCRIPT
MOVEM T1,SUB0. ;STORE LAST AS FIRST
JRST PRSNM5 ;SUBSCRIPTS TAKEN CARE OF
;HERE IF WE PARSED "OF/IN" AFTER NAME
PRSNM3: PUSH PP,[-1] ;SAVE TOP OF STACK
PUSH PP,DT ;SAVE FIRST STE
PRSN3A: PUSHJ PP,PRSCNM ;PARSE COBOL NAME
TXO SW,FLNMOK ;FILENAMES ARE ALLOWED AS QUALIFIERS
PUSHJ PP,LOOKNM ;LOOK FOR IT
JRST XECUTX ;CAN'T FIND IT
JUMPE DT,UNDEFD ;JUMP IF UNDEFINED
PUSH PP,DT ;SAVE PTR ON STACK
PUSHJ PP,NONSP ;GET TO FIRST NON-SPACE
CAIN CH,12 ;CRLF NOW?
JRST PRSN10 ;YES, GO DO FINAL LOOKUP
PUSHJ PP,OFIN ;MUST BE OF/IN THEN
JRST PRSN3A ;LOOP FOR MORE QUALIFIERS
;HERE WHEN SUBSCRIPTS TAKEN CARE OF
PRSNM5: PUSH PP,[-1] ;MARK BOTTOM OF STACK
PUSH PP,DT ;SAVE STE FOR THIS SYMBOL
CAIN CH,12 ;SAW <EOL>?
JRST PRSN10 ;YES, GO SEARCH FOR THIS
;SAW A NAME, AND HAVE FIRST NON-BLANK AFTER NAME IN CH.
;IT IS NOT A CRLF... IT CAN ONLY LEGALLY BE "OF" OR "IN"
PUSHJ PP,OFIN ;GET "OF" OR "IN"
JRST PRSN3A ;GO GET QUALIFIER
;HERE TO PARSE "TALLY"
PRSTLY: PUSHJ PP,CONFRM ;CONFIRM
SETOB DT,W2 ;SET -1 FOR "TALLY"
POPJ PP, ;AND RETURN
RETZRO: SETZB W2,DT ;RETURN NO SYMBOL
POPJ PP,
PRSN10: PUSHJ PP,QUAL ;SEARCH FOR QUALFIED NAME
JRST XECUTX ;ERROR
PRSN11: POP PP,T1 ;GET -1
CAME T1,[-1]
JRST .-2
MOVE DT,W2 ;COPY TO "DT" ALSO
POPJ PP, ;OK, RETURN
UNDEFD: TYPE [ASCIZ/?Undefined: /]
MOVE T3,[POINT 6,DNAME6]
UNDEF0: ILDB T1,T3
JUMPE T1,UNDEF1 ;DONE TYPING NAME IF WE GOT A SPACE
ADDI T1,40
CAIN T1,":" ;CONVERT BACK TO DASHES
MOVEI T1,"-"
CAIN T1,";" ; and dots.
MOVEI T1,"."
TYPEAC T1
JRST UNDEF0
UNDEF1: TYPE CRLF
JRST XECUTX
STOOMN: TYPE [ASCIZ/?Too many subscripts
/]
JRST XECUTX
;ROUTINE TO PARSE A COBOL NAME, AND PUT IN "DNAME6"
;DOESN'T RETURN IF NAME IS BAD SYNTAX
;LEAVES TXTBBP POINTING TO JUST AFTER THE NAME, AND NAME IN "DNAME6"
PRSCNM: SETZM DNAME6 ;CLEAR OUT ANY OLD NAME
MOVE T1,[DNAME6,,DNAME6+1]
BLT T1,DNAME6+5
MOVE T4,[POINT 6,DNAME6]
MOVEI T5,^D30 ;MAX # CHARS WE CAN STORE IN IT
PRSCN1: PUSHJ PP,GETUCH ;GET FIRST NON-BLANK CHAR
CAIE CH,11
CAIN CH," "
JRST PRSCN1
CAIN CH,12
JRST SNMEXP ;?SYMBOL NAME EXPECTED
PRSCN2: CAIL CH,"A"
CAILE CH,"Z" ;A LETTER?
JRST PRSCN3 ;NO
;HERE IF CHAR IS OK
PRSCN5: SOJL T5,NMTOOL ;?NAME TOO LONG
SUBI CH,40 ;MAKE SIXBIT
IDPB CH,T4 ;STORE IN DNAME6
PUSHJ PP,GETUCH ;GET ANOTHER CHARACTER
JRST PRSCN2 ;GO CHECK IT OUT
PRSCN3: CAIL CH,"0"
CAILE CH,"9"
CAIA ;NOT A NUMBER
JRST PRSCN5 ;CHAR IS OK
CAIE CH,"-" ;DASH IS OK
JRST PRSC3A ;Not dash
MOVEI CH,":" ;CONVERT TO COLON
JRST PRSCN5 ;CHAR IS OK
PRSC3A: CAIE CH,"." ;DOT IS OK
POPJ PP, ;INVALID CHAR-- RETURN FROM PARSE
MOVEI CH,";" ;Convert to semi-colon
JRST PRSCN5 ;Char is ok.
;NO NAME GIVEN, JUST CRLF
SNMEXP: TYPE [ASCIZ/?Symbol name expected, got: <EOL>
/]
JRST XECUTX
;NAME IS TOO LONG -- TRUNCATE
NMTOOL: TYPE [ASCIZ/% Name too long, truncated: /]
TYPEAC CH ;TYPE THIS CHARACTER
TRUNC: PUSHJ PP,GETUCH ;NEXT CHAR
CAIE CH,11
CAIN CH," "
JRST TRUNC1
CAIN CH,12
JRST TRUNC1
TYPEAC CH
JRST TRUNC
TRUNC1: TYPE CRLF
POPJ PP,
;ROUTINE TO PARSE A SYMBOL TABLE MASK (FOR "SHOW")
; PUTS NAME IN DNAME6
;DOESN'T RETURN IF BAD SYNTAX
;LEAVES TXTBBP POINTING TO JUST AFTER THE MASK, AND MASK IN "DNAME6"
PRSMSK: SETZM DNAME6 ;CLEAR OUT ANY OLD NAME
MOVE T1,[DNAME6,,DNAME6+1]
BLT T1,DNAME6+4
MOVE T4,[POINT 6,DNAME6]
MOVEI T5,^D30 ;MAX # CHARS ALLOWED IN MASK
PRSMS1: PUSHJ PP,GETUCH ;GET FIRST NON-BLANK CHAR
CAIE CH,.CHTAB
CAIN CH," "
JRST PRSMS1
CAIN CH,12
JRST MSKEXP ;SYMBOL NAME MASK EXPECTED
PRSMS2: CAIL CH,"A"
CAILE CH,"Z"
CAIA ;NOT A LETTER
JRST PRSMS5 ;GOOD CHAR
CAIL CH,"0" ;A NUMBER?
CAILE CH,"9"
CAIA ;NO
JRST PRSMS5
CAIN CH,"-" ;DASH?
JRST [MOVEI CH,":" ;YES, CONVERT TO COLON
JRST PRSMS5]
CAIN CH,"." ;Dot?
JRST [MOVEI CH,";" ;Yes, convert to semi-colon
JRST PRSMS5]
CAIE CH,"*" ;WILD CHARS OK
CAIN CH,"?"
JRST PRSMS5
CAIN CH,12
POPJ PP, ;RETURN FROM PARSE
CAIE CH,.CHTAB ;IF TABS OR SPACES,
CAIN CH," "
POPJ PP, ;RETURN FROM PARSE
TYPE [ASCIZ/?Invalid character in symbol name mask: /]
TYPEAC CH ;TYPE IT
JRST XECUTC ;GIVE UP PARSE
PRSMS5: SOJL T5,MSTOOL ;?MASK TOO LONG
SUBI CH,40 ;MAKE SIXBIT
IDPB CH,T4 ;STORE IN DNAME6
PUSHJ PP,GETUCH ;GET ANOTHER CHARACTER
JRST PRSMS2 ;GO CHECK IT OUT
MSKEXP: TYPE [ASCIZ/?Symbol name mask expected, got: <EOL>
/]
JRST XECUTX
;MASK TOO LONG, TRUNCATE
MSTOOL: TYPE [ASCIZ/% Symbol name mask too long, truncated: /]
TYPEAC CH ;TYPE THIS CHARACTER
JRST TRUNC ;TRUNCATE TILL SPACE OR TAB
;ROUTINE TO RETURN NEXT CHARACTER OF COMMAND LINE AND MAKE IT UPPERCASE.
GETUCH: ILDB CH,TXTBBP ;GET NEXT CHAR
CAIL CH,"A"+40 ;CONVERT LOWERCASE
CAILE CH,"Z"+40
POPJ PP,
SUBI CH,40 ;TO UPPERCASE
POPJ PP, ;AND RETURN
>;END OF TOPS10 COMMAND SCANNER CODE
SUBTTL TOPS20 COMMAND SCANNER FOR COBDDT
IFN TOPS20,<
DECOD: MOVEI T1,CMDBLK ;POINT TO COMMAND BLOCK
MOVEI T2,[FLDDB. (.CMINI)] ;INITIALIZATION FUNCTION
PUSHJ PP,COMMND ;GO DO IT
NEWPAR: MOVE PP,PDL. ;RESTORE THE STACK
SKIPN T1,PRSJFN ;ANY JFN?
JRST NEWPR1 ;NO
RLJFN% ;RELEASE IT
TRN
SETZM PRSJFN ;CLEAR PARSED JFN
NEWPR1: MOVEI T1,CMDBLK ;POINT TO THE COMMAND BLOCK
MOVEI T2,[FLDDB. (.CMKEY,,CMDTBL)] ;POINT TO COMMAND TABLE
PUSHJ PP,COMMND ;READ THE COMMAND
MOVE T3,(T2) ;GET ADDRESS OF ROUTINE
JRST (T3) ;DISPATCH
SUBTTL TOPS20 COMMANDS
;SAME RULES APPLY AS FOR TOPS10 COMMANDS. THEY ARE SEPARATE
; COMMAND TABLES SO DIFFERENT COMMANDS MAY BE IN TOPS10 AND TOPS20
; VERSIONS (ALTHOUGH THIS IS NOT RECOMMENDED FOR COMPATIBILITY!)
DEFINE COMMANDS,<
CMDM ACCEPT,ACC.
CMDM BREAK,BRK.
CMDM CLEAR,CLR.
CMDM D,DISABR,CM%ABR+CM%INV
CMDM DDT,GODDT.
DISABR: CMDM DISPLAY,DIS.
CMDM GO,GO%.
CMDM HISTORY,HIS.
CMDM LOCATE,LOC.
CMDM MODULE,MOD.
CMDM NEXT,NEX.
CMDM OVERLAY,OVR.
CMDM PROCEED,PRO.
CMDM S,STPABR,CM%ABR+CM%INV ;ABBR. FOR "STEP"
CMDM SHOW,SHO.
CMDM ST,STPABR,CM%ABR+CM%INV ;ABBR. FOR "STEP"
STPABR: CMDM STEP,STP.
CMDM STOP,STOP.
CMDM TRACE,TRC.
CMDM WHERE,WHER.
>
DEFINE CMDM(A,B,FLAGS),<
XWD [IFNB <FLAGS>,<EXP CM%FW!<FLAGS>>
ASCIZ/A/],B
>
CMDTBL: XWD NMCMDS,NMCMDS
COMMANDS
NMCMDS==.-CMDTBL-1
;PARSE "ACCEPT"
ACC.: PUSHJ PP,PRSDNM ;PARSE DATANAME
MOVEI W1,ACCGEN ;PARSED CORRECTLY, GO HERE
JRST CODGNR ;GENERATE CODE AND DO IT
;PARSE "BREAK"
BRK.: PUSHJ PP,PRSPNM ;PARSE PROCEDURE NAME
JUMPN W2,SETBRK ;A NAME GIVEN, GO HERE
NOPNAM: TYPE [ASCIZ/?Procedure name must be given
/]
JRST XECUTX
;PARSE "CLEAR"
CLR.: MOVEI T2,[ASCIZ/breakpoint at procedure-name/]
PUSHJ PP,NOISE
PUSHJ PP,PRSPNM ;PARSE PARAGRAPH NAME
JRST CLRBRK ;A NAME GIVEN, GO HERE
;PARSE "DISPLAY"
DIS.: MOVEI T2,[ASCIZ/dataname/]
PUSHJ PP,NOISE
PUSHJ PP,PRSDNM ;GO PARSE A DATANAME
MOVEI W1,DISPGN ;GET GOOD DISPATCH ADDRESS
JRST CODGNR ;GEN CODE THEN DISPATCH
;PARSE "DDT"
GODDT.: PUSHJ PP,CONFRM ;GO CONFIRM IT
JRST GODDT ;GO DO IT
;PARSE "GO"
GO%.: MOVEI T2,[ASCIZ/to procedure-name/]
PUSHJ PP,NOISE
PUSHJ PP,PRSPNM ;PARSE A PROCEDURE NAME
JUMPE W2,NOPNAM ;?PROCEDURE NAME MUST BE GIVEN
JRST GOXXX ;DO THE "GO" COMMAND
;PARSE "HISTORY"
HIS.: MOVEI T2,[FLDDB. (.CMKEY,,HISTAB)]
PUSHJ PP,COMMND ;PARSE THE NEXT WORD
MOVE T2,(T2) ;GET ADDRESS OF ROUTINE
JRST (T2) ;DISPATCH
;HISTORY BEGIN
HIS.1: PUSHJ PP,FILSTT ;PARSE [FILESPEC] 'TITLE'
PUSHJ PP,PJFN ;STORE JFN IF ANY
JRST HISBEG ;DO 'HISTORY BEGIN'
;HISTORY END
HIS.2: PUSHJ PP,CONFRM ;EOL NEXT
JRST HISSTO ;DO IT
;HISTORY INITIALIZE
HIS.3: PUSHJ PP,FILSTT ;PARSE [FILESPEC] 'TITLE'
PUSHJ PP,PJFN ;STORE JFN IF ANY
JRST HISINI ;GO DO IT
;HISTORY REPORT
HIS.4: PUSHJ PP,FILSTT ;PARSE [FILESPEC] 'TITLE'
PUSHJ PP,PJFN ;STORE JFN IF ANY
JRST HISREP
HISTAB: HISLEN,,HISLEN ;HEADER
[ASCIZ/BEGIN/],,HIS.1
[ASCIZ/END/],,HIS.2
[ASCIZ/INITIALIZE/],,HIS.3
[ASCIZ/REPORT/],,HIS.4
HISLEN==.-HISTAB-1 ;NUMBER OF 'HISTORY' COMMANDS
;ROUTINE TO PARSE [FILESPEC] 'TITLE'
; STORES JFN IN PRSJFN, 'TITLE' IN HSTTTL
;RETURNS WITH POPJ, IF ERROR PARSING IT DOESN'T RETURN
FILSTT: SETZM PRSJFN ;CLEAR PARSED JFN
HRROI T2,[ASCIZ/HIS/] ;DEFAULT EXTENSION
MOVEM T2,JFNBLK+.GJEXT
MOVX T2,GJ%FOU ;FLAGS
MOVEM T2,JFNBLK+.GJGEN
MOVEI T2,FLFLTL ;FLDDB'S FOR FILESPEC AND "'"
PUSHJ PP,COMMND ;LOOK FOR ONE
HRRZ T3,T3 ;GET PARSE BLOCK USED
CAIN T3,FLFLQT ; WAS IT A QUOTE?
JRST FILST1 ;YES, GO GET TITLE
CAIN T3,FLNTCM ;JUST <CRLF>?
POPJ PP, ;YES, RETURN
HRRZM T2,PRSJFN ;SAVE PARSED JFN
MOVEI T2,FLTLEN ;GET 'TITLE' OR END
PUSHJ PP,COMMND
HRRZ T3,T3 ;GET PARSE BLOCK USED
CAIN T3,FLNTCM ;NO TITLE, CONFIRMED
POPJ PP, ;YES RETURN OK
;GOT FIRST QUOTE FOR TITLE
FILST1: MOVEI T2,FLTTL
PUSHJ PP,COMMND ;PARSE FIELD TO CRLF
DMOVE T1,[POINT 7,HSTTTL ;TO HERE
POINT 7,ATMBUF] ;FROM HERE
MOVEI T3,HTTLSZ ;MAX SIZE OF TITLE
FILST2: SOJL T3,FILST3 ;TRUNCATE
ILDB T4,T2 ;GET A CHAR
JUMPE T4,FILST4 ;NULL ENDS STRING
CAIN T4,"'" ;SINGLE QUOTE ENDS STRING
JRST FILS3A
IDPB T4,T1 ;STORE THIS CHAR
JRST FILST2 ;LOOP
FILST3: PTYPE [ASCIZ/% Title too long, truncated
/]
FILS3A: SETZ T4, ;GET A NULL
FILST4: IDPB T4,T1 ;STRING ENDS WITH NULL
POPJ PP, ;RETURN
FLTTL: FLDDB. (.CMTXT,CM%SDH,,<TITLE string, ending with "'" or CRLF>)
FLFLTL: FLDDB. (.CMFIL,,,,,FLFLQT)
FLFLQT: FLDDB. (.CMTOK,CM%SDH,<POINT 7,ASCQTE>,<'TITLE'>,,FLNTCM)
FLTLEN: FLDDB. (.CMTOK,CM%SDH,<POINT 7,ASCQTE>,<'TITLE'>,,FLNTCM)
FLNTCM: FLDDB. (.CMCFM)
ASCQTE: ASCIZ/'/
;ROUTINE TO STORE JFN IN HSTJFN
; IF THERE WAS ONE THERE ALREADY, IT IS RELEASED
PJFN: SKIPN T4,PRSJFN ;DID WE PARSE A FILESPEC?
POPJ PP, ;NO, RETURN
SETZM PRSJFN ;CLEAR PARSED JFN SO IT DOESN'T GET RELEASED
SKIPN T1,HSTJFN ;YES, DID WE ALREADY DO THAT BEFORE?
JRST PJFN1 ;NO
RLJFN% ;YES, RELEASE IT
ERJMP .+1 ;IGNORE ERROR
PJFN1: MOVEM T4,HSTJFN ;STORE NEW JFN
POPJ PP, ;AND RETURN
;PARSE "LOCATE"
LOC.: PUSHJ PP,PRSDPN ;PARSE DATANAME OR PROCEDURE NAME
JRST LOCTYP ;DO 'LOCATE'
;PARSE "MODULE"
MOD.: MOVEI T2,FLMODC
PUSHJ PP,COMMND ;PARSE <CRLF> OR NAME
HRRZ T3,T3 ;GET PARSE BLOCK USED
CAIN T3,FLMODC ;CRLF?
JRST MODH ;GO TYPE MODULES IN CORE & POPJ
;PARSE AN ARBITRARY FIELD
PUSHJ PP,CONFRM ;CONFIRM IT
SETZ T5, ;PUT NAME INTO T5
DMOVE T1,[POINT 7,ATMBUF
POINT 6,T5] ;PUT NAME IN T5
MOD.0: ILDB T3,T1 ;GET A CHAR
JUMPE T3,MOD.1 ;GOT MODULE NAME
CAIL T3,"A"+40
CAILE T3,"Z"+40
CAIA
SUBI T3,40 ;MAKE UPPERCASE
SUBI T3,40 ;MAKE SIXBIT
CAIL T3,0
CAILE T3,77 ;LEGAL SIXBIT?
JRST MOD.3 ;NO, COMPLAIN
TLNE T2,770000 ;IF THERE'S ANY ROOM
IDPB T3,T2 ;STORE CHARACTER
JRST MOD.0 ;LOOP
;HERE IF BAD CHAR IN MODULE NAME
MOD.3: ADDI T3,40 ;GET CHAR THAT FAILED
HRROI T1,[ASCIZ/?Not a legal sixbit character: /]
PSOUT%
HRRZ T1,T3
PBOUT%
HRROI T1,[ASCIZ/
/]
PSOUT%
JRST ERESET ;FINISH ERROR
FLMODC: FLDDB. (.CMCFM,CM%SDH,,<CRLF to list modules in core>,,FLMODU)
FLMODU: FLDDB. (.CMFLD,CM%SDH,,<Sixbit name of module>)
;PARSE "NEXT"
NEX.: MOVEI T2,FLNEX
PUSHJ PP,COMMND ;PARSE ARG TO "NEXT"
HRRZ T3,T3 ;WHICH PARSE BLOCK USED?
CAIN T3,FLNEX1 ;<CR>?
JRST NEX1 ;YES
MOVE W2,T2 ;SAVE INTEGER
PUSHJ PP,CONFRM ;CONFIRM IT
JRST NEXT1 ;GO WHEN PARSED
NEX1: MOVEI W2,1 ;GET DEFAULT VALUE IF BLANK TYPED
JRST NEXT1 ;GO DO 'NEXT'
FLNEX: FLDDB. (.CMNUM,,^D10,,,FLNEX1)
FLNEX1: FLDDB. (.CMCFM,CM%SDH,0,<<CRLF> for 1>)
;PARSE "OVERLAY"
OVR.: MOVEI T2,[ASCIZ/break mode is/]
PUSHJ PP,NOISE
MOVEI T2,[FLDDB. (.CMKEY,,OVLYTB)]
PUSHJ PP,COMMND ;PARSE ON/OFF
MOVE T2,(T2)
JRST (T2)
OVR.2: TDZA W2,W2 ;OFF
OVR.1: SETO W2, ;ON
PUSHJ PP,CONFRM ;CONFIRM "ON" OR "OFF"
JRST SETOVR ;SET "ON" OR "OFF"
OVLYTB: OVLYLN,,OVLYLN ;HEADER
[ASCIZ/OFF/],,OVR.2
[ASCIZ/ON/],,OVR.1
OVLYLN==.-OVLYTB-1 ;NUMBER OF 'OVERLAY' COMMANDS
;PARSE "PROCEED"
PRO.: MOVEI T2,PROFL
PUSHJ PP,COMMND ;PARSE THE THING
HRRZ T3,T3 ;WHICH PARSE BLOCK WAS USED?
CAIN T3,PROFL1 ;BLANK?
JRST PRO1 ;YES
MOVE W2,T2 ;SAVE THE #
PUSHJ PP,CONFRM ;MUST HAVE BEEN AN INTEGER THEN
JUMPG W2,PROCED ;JUMP IF INTEGER IS OK
POSIRQ: TYPE [ASCIZ/? Number must be a positive integer
/]
JRST XECUTX ;FAIL TO PARSE
;PROCEED <BLANK>
PRO1: MOVEI W2,1 ;PROCEED COUNT OF 1
JRST PROCED ;GO HERE
PROFL: FLDDB. (.CMNUM,CM%SDH,^D10,<Decimal number>,,PROFL1)
PROFL1: FLDDB. (.CMCFM,CM%SDH,0,<CRLF to proceed to next breakpoint>)
;PARSE "SHOW"
SHO.: MOVEI T2,[FLDDB. (.CMKEY,CM%SDH,SHOTAB,<SYMBOLS>)]
PUSHJ PP,COMMND
MOVE T2,(T2) ;GET ADDRESS OF ROUTINE
JRST (T2) ;DISPATCH
SHOTAB: SHOLEN,,SHOLEN ;HEADER
[ASCIZ/SYMBOLS/],,SHO.S
SHOLEN==.-SHOTAB-1 ;NUMBER OF "SHOW" COMMANDS
;SHOW SYMBOLS
SHO.S: MOVEI T2,[ASCIZ/that match the mask/]
PUSHJ PP,NOISE
MOVEI T2,[FLDDB. (.CMTXT,CM%SDH,,<Symbol name mask>)]
PUSHJ PP,COMMND
LDB T1,[POINT 7,ATMBUF,6] ;SEE IF ANYTHING TYPED
JUMPE T1,SHOER1 ;?SYMBOL NAME MUST BE GIVEN
SETZM DNAME6 ;CLEAR IT OUT
MOVE T2,[DNAME6,,DNAME6+1]
BLT T2,DNAME6+4
MOVE T2,[POINT 6,DNAME6] ;COPY MASK TO HERE
MOVE T3,[POINT 7,ATMBUF,6] ;FROM HERE
SHOC0: CAIE T1,.CHTAB ;SKIP LEADING BLANKS, TABS
CAIN T1," "
JRST [ILDB T1,T3
JRST SHOC0]
MOVEI T4,^D30 ;MAX # CHARS WE CAN TRANSFER
SHOC1: CAIL T1,"A"+40
CAILE T1,"Z"+40 ;CONVERT TO UPPER CASE
CAIA
SUBI T1,40
CAIL T1,"A"
CAILE T1,"Z" ;A-Z IS OK
CAIA
JRST SHOC2
CAIL T1,"0" ;0-9 IS OK
CAILE T1,"9"
CAIA
JRST SHOC2
CAIN T1,"-" ;DASH IS OK
JRST [MOVEI T1,":" ;CONVERT IT TO COLON
JRST SHOC2]
CAIN T1,"." ;Dot is ok
JRST [MOVEI T1,";" ;Convert it to semicolon
JRST SHOC2]
CAIN T1,"%" ;WILD CHAR IS OK
JRST [MOVEI T1,"?" ;CONVERT TO "?"
JRST SHOC2]
CAIN T1,"*"
JRST SHOC2
JUMPE T1,SHOC3 ;NULL ENDS STRING, IS OK
CAIE T1,.CHTAB ;TABS OR SPACES?
CAIN T1," "
JRST SHOER2 ;YES, COMPLAIN
TYPE [ASCIZ/?Invalid character in symbol name mask: /]
LDB T1,T3 ;RE-FETCH CHARACTER
TYPEAC T1 ;TYPE IT
JRST XECUTX ;FORGET COMMAND
SHOC2: SOJL T4,SHTOLN ;JUMP IF MASK WAS TOO LONG
SUBI T1,40 ;MAKE SIXBIT CHARACTER
IDPB T1,T2 ;STORE
ILDB T1,T3 ;GET NEXT CHARACTER
JRST SHOC1 ;LOOP FOR ALL OF EM
SHOC3: JRST DOSHOS ;GO DO IT
SHOER1: TYPE [ASCIZ/?Symbol name mask must be given
/]
JRST XECUTX
SHOER2: ILDB T1,T3 ;TRAILING BLANKS ARE OK, IF NOTHING ELSE
CAIE T1,.CHTAB
CAIN T1," "
JRST SHOER2
JUMPE T1,SHOC3 ;DONE
PUSH PP,T1 ;SAVE CHAR
TYPE [ASCIZ/?Junk following symbol name mask: /]
POP PP,T1 ;TYPE FIRST CHAR OF JUNK
TYPEAC T1
MOVE T1,T3 ;GET BP TO REST OF FIELD
PSOUT% ;TYPE IT
JRST XECUTX ;RETURN
SHTOLN: TYPE [ASCIZ/?Symbol name mask too long
/]
JRST XECUTX
;PARSE "STEP"
STP.: MOVEI T2,STPFL
PUSHJ PP,COMMND ;PARSE NUMBER OR CRLF
HRRZ T3,T3 ;GET WHICH PARSE BLOCK USED
CAIN T3,STPFL1 ;CRLF?
JRST STP1 ;YES
MOVE W2,T2 ;SAVE NUMBER
MOVEI T2,[FLDDB. (.CMCFM)] ;CRLF TO CONFIRM
PUSHJ PP,CONFRM
JUMPLE W2,POSIRQ ;COMPLAIN IF NEG OR ZERO
JRST STEP ;GOOD NUMBER--GO DO IT
STP1: MOVEI W2,1 ;STEP COUNT OF 1
JRST STEP ;GO HERE
STPFL: FLDDB. (.CMNUM,CM%SDH,^D10,<Decimal number>,,STPFL1)
STPFL1: FLDDB. (.CMCFM,CM%SDH,0,<CRLF to proceed to next paragraph>)
NOTPIN: TYPE [ASCIZ/?Number must be a positive integer
/]
JRST XECUTX
;PARSE "STOP"
STOP.: MOVEI T2,[ASCIZ/the program and exit to monitor/]
PUSHJ PP,NOISE ;EXPLAIN WHAT THIS COMMAND DOES
PUSHJ PP,CONFRM ;CONFIRM "STOP"
JRST STOPR
;PARSE "TRACE"
TRC.: MOVEI T2,[FLDDB. (.CMKEY,,TRCTAB)]
PUSHJ PP,COMMND ;GET ARGUMENT FOR TRACE
MOVE T2,(T2) ;GET WHICH ONE
JRST (T2) ;GO TO ON/OFF ROUTINE
TRC.2: TDZA W2,W2 ;TRACE OFF
TRC.1: SETO W2, ;TRACE ON
PUSHJ PP,CONFRM ;CONFIRM 'TRACE' COMMAND
JRST TRCONF ;SAVE ON/OFF VALUE
;"TRACE BACK"
TRC.B: PUSHJ PP,CONFRM ;CONFIRM "TRACE BACK"
JRST TRCB ;GO DO IT
TRCTAB: TRCNUM,,TRCNUM ;HEADER
[ASCIZ/BACK/],,TRC.B
[ASCIZ/OFF/],,TRC.2
[ASCIZ/ON/],,TRC.1
TRCNUM==.-TRCTAB-1 ;NUMBER OF "TRACE" COMMANDS
;PARSE "WHERE"
WHER.: MOVEI T2,[ASCIZ/are the breakpoints/]
PUSHJ PP,NOISE
PUSHJ PP,CONFRM ;GO CONFIRM IT
JRST WHERE ;DISPATCH TO COMMON CODE
;ROUTINE TO PARSE A PROCEDURE NAME
PRSPNM: TXZ SW,DNFLG ;DATANAMES NOT ALLOWED
TXO SW,PNFLG ;LOOK FOR PROCEDURE NAMES
JRST PRSNAM
;ROUTINE TO PARSE A DATANAME
PRSDNM: TXZ SW,PNFLG ;PROCEDURE NAMES NOT ALLOWED
TXO SW,DNFLG ;LOOK FOR DATANAMES
JRST PRSNAM
;ROUTINE TO PARSE A DATANAME OR PROCEDURE NAME
PRSDPN: TXO SW,PNFLG!DNFLG ;SET BOTH FLAGS
PRSNAM: TXZ SW,PRNMFG!CRFLG ;DIDN'T SEE A PROCEDURE NAME OR A CRLF YET (CHECKED AT PRSNM5)
SETZM NSUBS ;CLEAR SUBSCRIPT COUNT
MOVEI T2,FLSYML ;SYMBOL NAME OR CRLF
TXNN SW,DNFLG ;SKIP IF DATANAMES ARE ALLOWED
MOVEI T2,FLPRN ;NO, JUST ASK FOR PROCEDURE NAMES
PUSHJ PP,COMMND
TXNN SW,DNFLG ;SKIP IF DATANAMES ALLOWED
JRST [LDB T1,[POINT 7,ATMBUF,6] ;SEE IF SOMETHING THERE
JUMPN T1,PRSNM0 ;YES
PUSHJ PP,CONFRM ;NO, THEN CONFIRM NO SYMBOL
JRST RETZRO] ;AND RETURN 0
HRRZ T3,T3 ;WHICH PARSE BLOCK WAS USED?
CAIN T3,FLSYML ;CRLF?
JRST RETZRO ;YES, RETURN NO SYMBOL
PRSNM0: PUSHJ PP,COPDN6 ;COPY NAME TO DNAME6
SKIPN C74FLG ;ANS68?
TXNN SW,DNFLG ;AND PARSING A DATANAME?
JRST PRSNTY ;NO
MOVE T1,DNAME6 ;GET 1ST 6 CHARS, TO CHECK FOR "TALLY"
CAMN T1,[SIXBIT /TALLY/]
JRST PRSTLY ;GOT IT-- GO FINISH PARSING IT
PRSNTY: TXZ SW,FLNMOK ;FILENAMES ARE NOT ALLOWED HERE
PUSHJ PP,LOOKNM ;LOOKUP NAME
JRST ERESET ;ERROR
JUMPE DT,UNDEFD ;?NOT FOUND
;IF DATANAME, LOOK FOR SUBSCRIPTS
TXNN SW,DNFLG
JRST PRSNM5 ;NO SUBSCRIPTS ALLOWED ON PROCEDURE NAMES
MOVEI T1,CMDBLK
MOVEI T2,FLNAM1 ;LOOK FOR "(", CRLF, OR "OF/IN"
PUSHJ PP,COMMND
HRRZ T3,T3 ;GET PARSE BLOCK USED
CAIN T3,FLNAM2 ;CRLF?
JRST [TXO SW,CRFLG ;YES, SET FLAG
JRST PRSNM5] ;AND GO TO SUBSC. TAKEN CARE OF
CAIN T3,FLNAM3 ;"OF/IN"?
JRST PRSNM3 ;YES, GO GET QUALIFIERS
;( SEEN - PARSE SUBSCRIPTS
NXTSBS: MOVEI T1,CMDBLK
MOVEI T2,[FLDDB. (.CMNUM,,^D10)]
;SIMULATE COMMND, SO WE CAN GIVE A BETTER ERROR MESSAGE
; IF WE GET THE TOPS20 ERROR: "First non-space character is not a digit"
COMND% ;PARSE THE FUNCTION
ERJMP LOSE ;ERROR, GO COMPLAIN
TXNN T1,CM%NOP ;DID IT PARSE?
JRST SUBIOK ;YES, THIS SUBSCRIPT IS OK
CAIE T2,IFIXX2 ;"FIRST NON-SPACE CHARACTER IS NOT A DIGIT"
JRST LOSE ;NO, USE USUAL MESSAGE
TYPE [ASCIZ/
? Decimal number expected
/]
JRST ERESET ;RETURN AFTER TYPING REASONABLE ERROR MESSAGE
SUBIOK: AOS T1,NSUBS
CAILE T1,3 ;CHECK MAX ALLOWABLE
JRST STOOMN ;?TOO MANY SUBSCRIPTS
MOVEM T2,SUB0.-1(T1) ;STASH AWAY
;FIND TERMINATOR FOR SUBSCRIPT.
MOVEI T1,CMDBLK
MOVEI T2,FLSUTR ;LOOK FOR SUBSCRIPT TERM.
PUSHJ PP,COMMND ;PARSE, PARSE
;GIVE ERROR IF NOT , OR )
HRRZ T3,T3 ;GET PARSE BLOCK USED
CAIE T3,FLSUTR ; TERMINATED WITH PAREN?
JRST NXTSBS ;NO, GO GET MORE
;REVERSE ORDER OF SUBSCRIPTS TO EASE COMPUTATION
MOVE T2,NSUBS ;# SUBSCRIPTS SEEN
MOVE T1,SUB0. ;GET FIRST SUBSCRIPT
EXCH T1,SUB0.-1(T2) ;EXCHANGE WITH LAST SUBSCRIPT
MOVEM T1,SUB0. ;STORE LAST AS FIRST
JRST PRSNM5 ;SUBSCRIPTS TAKEN CARE OF
;HERE IF "<CRLF>" TYPED INSTEAD OF SYMBOL--RETURN 0
RETZRO: SETZB W2,DT ;RETURN NO SYMBOL
POPJ PP,
FLSUTR: FLDDB. (.CMTOK,,<POINT 7,ASCRPN>,,,FLSUTC)
FLSUTC: FLDDB. (.CMCMA) ;COMMA
FLPRN: FLDDB. (.CMFLD,CM%SDH,BRMKSS,<Procedure name>)
FLSYML: FLDDB. (.CMCFM,CM%SDH,,<CRLF for previously typed dataname>,,FLSYMB)
FLSYMB: FLDBK. (.CMFLD,CM%SDH,0,<Symbol name>,,BRMKSS)
;HERE IF "OF/IN" SEEN AFTER NAME
PRSNM3: PUSH PP,[-1] ;MARK BOTTOM OF STACK
PUSH PP,DT ;SAVE PTR TO FIRST STE
PRSN3A: MOVEI T1,CMDBLK
MOVEI T2,[FLDDB. (.CMFLD,CM%SDH,BRMKSS,<Symbol name>)]
PUSHJ PP,COMMND
PUSHJ PP,COPDN6 ;COPY TO DNAME6
TXO SW,FLNMOK ;FILE NAMES ARE ALLOWED AS QUALIFIERS
PUSHJ PP,LOOKNM ;GET DT FOR IT
JRST ERESET ;ERROR
JUMPE DT,UNDEFD ;JUMP IF UNDEFINED
PUSH PP,DT ;SAVE ON STACK
MOVEI T1,CMDBLK
MOVEI T2,FLNAM2 ;LOOK FOR "OF/IN" OR CRLF
PUSHJ PP,COMMND
HRRZ T3,T3
CAIN T3,FLNAM3 ;OF/IN?
JRST PRSN3A ;YES, GO GET ANOTHER DATANAME
JRST PRSN10 ;CRLF, GO DO LOOKUP
;HERE IF SUBSCRIPTS TAKEN CARE OF
PRSNM5: PUSH PP,[-1] ;MARK BOTTOM OF STACK
PUSH PP,DT ;SAVE STE FOR THIS SYMBOL
TXNE SW,CRFLG ;SAW <CR>?
JRST PRSN10 ;YES, GO SEARCH FOR THIS
MOVEI T1,CMDBLK
MOVEI T2,FLNAM2 ;LOOK FOR CRLF OR OF/IN
PUSHJ PP,COMMND
HRRZ T3,T3 ;GET PARSE BLOCK
CAIN T3,FLNAM3 ;OF/IN?
JRST PRSN3A ;YES, GO GET QUALIFIER
JRST PRSN10 ;GO DO FINAL LOOKUP
PRSTLY: MOVEI T1,CMDBLK
MOVEI T2,[FLDDB. (.CMCFM)] ;CONFIRM "TALLY"
PUSHJ PP,COMMND
SETOB DT,W2 ;SET -1 FOR "TALLY"
POPJ PP,
;HERE WHEN GOT TO CRLF
;LOOKUP NAME IN TABLE, IF FOUND RETURN "W2"
PRSN10: PUSHJ PP,QUAL ;LOOKUP NAME IN TABLE
JRST ERESET ;NOT FOUND--DON'T RETURN
PRSN11: POP PP,T1 ;GET -1
CAME T1,[-1]
JRST .-2
MOVE DT,W2 ;COPY TO "DT" ALSO
POPJ PP, ;OK, RETURN
FLNAM1: FLDDB. (.CMTOK,CM%SDH,<POINT 7,ASCLPN>,<Subscripts>,,FLNAM2)
FLNAM2: FLDDB. (.CMCFM,,,,,FLNAM3) ;CRLF
FLNAM3: FLDDB. (.CMKEY,CM%SDH,OFINTB,<Further Qualification>)
OFINTB: 2,,2
[ASCIZ/IN/],,0
[ASCIZ/OF/],,0
ASCLPN: ASCIZ/(/
ASCRPN: ASCIZ/)/
;ROUTINE TO COPY NAME FROM ATMBUF TO DNAME6
COPDN6: SETZM DNAME6 ;CLEAR IT OUT FIRST
MOVE T1,[DNAME6,,DNAME6+1]
BLT T1,DNAME6+5
DMOVE T1,[POINT 7,ATMBUF ;WHERE IT IS
POINT 6,DNAME6] ;WHERE IT SHALL BE
MOVEI T3,^D30 ;MAX # CHARS IN A DATANAME
PRSNM1: SOJL T3,PRSNM2 ;NAME TOO LONG , TRUNCATE
ILDB T4,T1 ;GET A CHAR FROM DATANAME
CAIN T4,"-" ;TRANSFORM
MOVEI T4,":"
CAIN T4,"."
MOVEI T4,";"
JUMPE T4,PRSNM2 ;NULL, SOMETHING ENDED THE STRING
CAIL T4,"A"+40 ;MAKE LOWERCASE...
CAILE T4,"Z"+40
CAIA
SUBI T4,40 ;...INTO UPPERCASE
SUBI T4,40 ;LEGAL SIXBIT GETS TRANSFORMED
CAIL T4,0
CAILE T4,77
JRST PRSN1A ;NOT LEGAL SIXBIT.. END OF DATANAME
IDPB T4,T2 ;STORE IN WORD
JRST PRSNM1 ;LOOP FOR MORE CHARS
PRSN1A: LDB T4,T1 ;GET CHAR AGAIN
HRROI T1,[ASCIZ/? Invalid character in COBOL name: /]
PSOUT%
HRRZ T1,T4
PBOUT% ;TYPE IT
JRST PRSNME ;FINISH ERROR AND EXIT
PRSNM2: MOVEI T4,0
IDPB T4,T2 ;STORE NULL TO END STRING
POPJ PP, ;RETURN WHEN DONE
UNDEFD: HRROI T1,[ASCIZ/?Undefined: /]
PSOUT%
HRROI T1,ATMBUF
PSOUT%
JRST PRSNME
STOOMN: HRROI T1,[ASCIZ/? Too many subscripts/]
PSOUT%
JRST PRSNME
;HERE ON A PARSE ERROR.. TYPE <CRLF> TO END ERROR MESSAGE
; AND GO TO TOP LEVEL OF COMMAND SCANNER.
PRSNME: TYPE CRLF
JRST ERESET ;PARSE ERROR, GO TRY AGAIN
;BREAK MASK FOR COBOL SYMBOLS
BRMKSS:
1B<.CHCRT>!1B<.CHLFD>
0
0
0
;ROUTINES FOR COMND JSYS
NOISE: HRROM T2,NOIBLK+.CMDAT ;SAVE AS DATA
MOVEI T2,NOIBLK ;POINT TO BLOCK
JRST COMMND ;AND GO TO COMND JSYS
CONFRM: MOVEI T1,CMDBLK ;POINT TO COMMAND BLOCK
MOVEI T2,[FLDDB. (.CMCFM)] ;GET CONFIRM FUNCTION
COMMND: COMND% ;PARSE THE FUNCTION
ERJMP LOSE ;ERROR, GO COMPLAIN
TXNE T1,CM%NOP ;DID IT PARSE?
JRST LOSE ;NO, COMPLAIN
POPJ PP, ;YES, RETURN SUCESSFULLY
NOIBLK: FLDDB. (.CMNOI) ;BLOCK FOR NOISE FUNCTION
LOSE: HRROI T1,[ASCIZ/
? /]
PSOUT%
PUSHJ PP,LSTFRC ;TYPE LAST ERROR IN THIS FORK, THEN CRLF
ERESET: MOVEI T1,.PRIIN ;GET READY
CFIBF% ;CLEAR INPUT STRING
MOVE PP,PDL. ;GET PUSHDOWN STACK WE STARTED WITH
JRST DECOD ;GO TRY AGAIN
;TYPE LAST ERROR IN THIS FORK
LSTFER: MOVEI T1,.PRIOU ;OUTPUT TO TTY
HRLOI T2,.FHSLF ;LAST ERROR IN THIS FORK
SETZ T3, ;ALL OF THE TEXT
ERSTR%
TRNA
TRN
POPJ PP,
;DO LSTFER THEN CRLF
LSTFRC: PUSHJ PP,LSTFER ;TYPE LAST ERROR IN THIS FORK
TYPE CRLF ;TYPE CRLF
POPJ PP, ;THEN RETURN
>;END IFN TOPS20 3
; **** END OF TOPS20 COMMAND SCANNER ****
;*** END OF ALL COMMAND SCANNER ROUTINES ***
SUBTTL COMMAND PROCESSORS -- WHERE
;HERE WHEN "WHERE<CRLF>" SEEN
;PRINT SUMMARY OF BREAK POINTS
WHERE: TYPE CRLF
SKIPE T2,EBRKOV ;IF WE'RE STOPED AT AN ENTRY,
; TYPE A SPECIAL MSG.
JRST [TYPE [ASCIZ "Program stopped upon entry to module "]
PUSHJ PP, PRTMNM
JRST WHERE1]
SKIPE REEFLG ;[26] SPECIAL BREAK?
JRST WHER1A ;[26] YES, DON'T TRY TO REPEAT MESSAGE.
SKIPN CUR.BP ;[26] ARE WE AT NORMAL BREAK?
JRST WHER1A ;[26] SKIP BREAK MESSAGE
TYPE [ASCIZ "Program stopped at "]
MOVEI T4,CBPADS ;PICK UP ADDRESS OF THE CURRENT
; BREAK POINT'S PROTAB POINTERS.
PUSHJ PP,PRTBP ;PRINT BREAK MESSAGE
WHERE1: TYPE CRLF
WHER1A: TYPE [ASCIZ " Break-points:
"]
MOVEI T5,0 ;INIT COUNTER OF FREE BPS
MOVEI T4,B1ADR ;INIT LOOP
WHERE2: SKIPN 0(T4) ;IN USE?
AOJA T5,WHERE3 ;NO: INCREMENT CNTR
TYPEC " " ;TYPE A SPACE
PUSHJ PP,PRTBP ;YES: PRINT IT
TYPE CRLF
WHERE3: ADDI T4,LBA
CAIG T4,BNADR ;DONE?
JRST WHERE2
CAIL T5,NBP ;WAS THERE ANY?
JTYPE [ASCIZ " **NONE**
"]
TYPEC " " ;TYPE A SPACE
PUSHJ PP,PRNUM ;PRINT # OF FREE
PTYPE [ASCIZ " unused break-points"]
JRST XECUTC
CRLF: BYTE (7)15,12
;PRINT BREAK POINT INFOR POINTED AT BY 'T4'
ANGLIN: BYTE (7)74,74
ANGLOU: BYTE (7)76,76
PRTBP: PUSH PP,T5
TYPE ANGLIN
HLRZ T5,1(T4)
HRRZ T5,1(T5)
HRRZ T2,0(T4)
LDB DT,[POINT 15,0(T2),17]
ADD DT,%%NM.(T5)
PUSHJ PP,PRNAM
HRRZ T2,1(T4) ;CHECK ON SECTION NAME
JUMPN T2,PRTBP1 ;[26] NO SECTION NAME ADDRESS MEANS
;THE NAME ITSELF IS A SECTION NAME
TYPE [ASCIZ " SECTION"] ;[26]
JRST PRTBP2 ;[26]
PRTBP1: LDB DT,[POINT 15,0(T2),17] ;[26] GET NAMTAB POINTER
ADD DT,%%NM.(T5)
MOVE T2,1(DT)
CAME T2,[SIXBIT /:GENER/] ;DON'T PRINT IF IT ISN'T USER NAME
PUSHJ PP,[TYPE [ASCIZ " in "]
JRST PRNAM]
PRTBP2: HLRZ T2,1(T4) ;[26]
SKIPE SUBSPR ;SKIP IF NO MODULES BESIDES THE MAIN ONE
PUSHJ PP, [ TYPE [ASCIZ " in module "]
JRST PRTMNM]
TYPE ANGLOU
POP PP,T5
POPJ PP,
;YE OLDE RECURSIVE NUMBER PRINTER C(T5)
PRNUM: MOVE T4,T5 ;COPY TO T4
IFN TOPS20,<
PUSH PP,T1 ;SAVE T1
PUSHJ PP,PRNUM0 ;CALL ROUTINE
POP PP,T1 ;RESTORE T1
POPJ PP, ;RETURN
>
PRNUM0: IDIVI T4,^D10
HRLM T5,0(PP)
JUMPE T4,PRNUM1
PUSHJ PP,PRNUM0
PRNUM1: HLRZ T3,0(PP)
ADDI T3,"0"
TYPEAC T3
POPJ PP,
SUBTTL COMMAND PROCESSORS -- TRACE
;HERE TO SET TRACE ON/OFF
; IF ON, W2=-1, IF "OFF", W2=0
TRCONF: MOVEM W2,PTFLG. ;SAVE ON/OFF VALUE
JRST XECUTX
;HERE IF "TRACE BACK" TYPED
TRCB: PUSHJ PP,PPOT4. ;CALL LIBOL ROUTINE
JRST XECUTX ;RETURN
SUBTTL COMMAND PROCESSORS -- BREAK
;BREAK POINT LOGIC
;COME HERE TO EXECUTE A "BREAK" COMMAND. NOTE THAT EXECUTING A
;BREAK COMMAND JUST MEANS SETTING UP THE PARAMETERS FOR THE BREAKPOINT.
;THE ACTUAL 'INSTALLATION' OF THE BREAK CODE (JSR) IS DONE LATER.
;AND THE 'BREAK' ITSELF OCCURS ONLY WHEN CONTROL PASSES THRU THE
;NAMED PROCEDURE NAME WHERE THE JSR HAS BEEN 'INSTALLED'.
;LOOK FOR FREE SLOT IN THE TABLE THAT CONTAINS THE 20 BREAKPOINT PARAMETERS.
SETBRK: MOVEI T5,B1ADR ;GET BASE ADDRESS
STBRK0: HRRZ T4,0(T5)
CAIN T4,0(DT) ;CHECK IF WE HAVE THIS BREAK ALREADY
JRST [TYPE [ASCIZ/% Breakpoint was there already
/]
JRST STBRK1] ;GO INSTALL AGAIN ANYWAY
SKIPN 0(T5) ;NO, IS THIS SLOT EMPTY?
JRST STBRK1 ;USE THIS ONE
ADDI T5,LBA ;NEXT ENTRY
CAIG T5,BNADR ;LAST?
JRST STBRK0
TYPE [ASCIZ "?Out of break-points"]
JRST XECUTC
;GET ADDRESS OF PROTAB ENTRY FOR FATHER (SECTION)
STBRK1: HRRZ T2,PR.FLG(DT) ;[26] IS THIS NAME A SECTION NAME?
ANDI T2,PR%SEC ;[26]
JUMPE T2,STBRK2 ;[26]
LDB T2,[POINT 15,1(DT),17] ;[26] NO, GET FATHER'S ADDRESS
ADD T2,@%PR
STBRK2: HRRZ T4,1(DT) ;[26] GET ADDRESS OF THE BREAK
;PROHIBIT THE BREAK IF THE ADDRESS IS IN A WRITE-PROTECTED HIGH SEGMENT.
IFE TOPS20,<
CAMG T4,.JBREL ;IS ADDRESS IN HIGH-SEG?
JRST STBRK3 ;NO
SETZ T3, ;YES, SEE IF WRITE-PROTECT OFF
SETUWP T3, ;BY TURNING IT OFF AGAIN
JRST HIPART ;ERROR, MUST BE ON
JUMPE T3,STBRK3 ;WAS OFF BEFORE - IT STILL IS
SETUWP T3, ;WAS ON BEFORE - SET IT BACK ON
JFCL
JRST HIPART ; AND FAIL
STBRK3:>
MOVEM DT,0(T5) ;PROTAB ADDR OF PAR NAME.
MOVEM T2,1(T5) ;PROTAB ADDR OF SECT NAME.
MOVE T2,CUREPA ;SAVE THE CURRENT ENTRY POINT'S
HRLM T2,1(T5) ; ADDRESS TOO.
SETZM 2(T5) ;CLR PROCEED COUNTER
JRST XECUTX
SUBTTL COMMAND PROCESSORS -- CLEAR
;COME HERE TO EXECUTE A CLEAR COMMAND. NOTE THAT EXECUTING A CLEAR
;COMMAND MEANS ZEROING THE BREAK PARAMETERS. THE ACTUAL 'REMOVAL'
;OF THE BREAK CODE (JSR) HAS ALREADY BEEN DONE. THOSE THAT ARE STILL
;'SET' WHEN A 'PROCEED' OR 'GO' IS EXECUTED ARE AUTOMATICALLY REINSTALLED.
;CLEAR ALL BREAK PARAMETERS IF NO PROC NAME WAS GIVEN ON THE COMMAND.
CLRBRK: JUMPN DT,CLBRK0
MOVE T5,[XWD B1ADR,B1ADR+1] ;CLEAR ALL
SETZM B1ADR
BLT T5,BNADR+LBA-1
JRST XECUTX
;CLEAR ONLY THE ONE THAT WAS NAMED IN COMMAND.
CLBRK0: MOVEI T5,B1ADR ;GET TABLE BASE
CLBRK1: HRRZ T4,0(T5)
CAIN T4,0(DT)
JRST CLBRK2 ;FOUND
ADDI T5,LBA ;NEXT ENTRY
CAIG T5,BNADR ;LAST ENTRY?
JRST CLBRK1 ;LOOP UNTIL NO MORE
TYPE [ASCIZ/% Breakpoint was not set
/]
JRST XECUTX ;JUST QUIT
CLBRK2: SETZM 0(T5) ;CLEAR 3 PARAMETER WORDS
SETZM 1(T5)
SETZM 2(T5)
JRST XECUTX
SUBTTL COMMAND PROCESSORS -- UNPROTECT
;COME HERE TO EXECUTE A TOPS-10 UNPROTECT HI-SEG COMMAND.
IFE TOPS20,<
UNPROT: SETZ T5, ;SET FUNCTION TO CLEAR WRITE PROTECT
SETUWP T5, ;DO IT
JRST UNPERR ;FAILED
HRRZ T5,.JBSA ;OK, GET START ADDRESS
MOVS T4,(T5) ;GET FIRST WORD
CAIE T4,(JFCL) ;INITIAL FIRST INSTRUCTION?
JRST XECUTX ;NO, WE HAVE DONE RESET ALREADY
MOVE T5,2(T5) ;GET JSP 16,C.RSET
MOVS T5,2(T5) ;THIS SHOULD BE THE RESET UUO
CAIE T5,(RESET) ;IS IT?
JRST XECUTX ;NO, GIVE UP
MOVE T4,[JSP 1,UNPST.] ;WHERE WE WANT START TO GO TO
HRRM T4,(T5) ;CHANGE JRST .+2
JRST XECUTX ;ALL DONE
UNPERR: OUTSTR [ASCIZ /?SETUWP UUO failed
/]
JRST XECUTX
;ENTER HERE FROM RESET CODE IN LIBOL TO TURN OFF USER WRITE PROTECTION
;AFTER THE RESET HAS BEEN DONE
;CALLED BY JSP 1,UNPST.
UNPST.: RESET ;DO THE RESET NOW
SETZ T2,
SETUWP T2, ;TURN OFF WRITE-PROTECT AGAIN
JFCL ;TOO BAD
JRST (T1) ;RETURN
>
SUBTTL COMMAND PROCESSORS -- STOP
;COME HERE TO EXECUTE A STOP RUN COMMAND.
;JUST USE THE LIBOL CODE. THE LIBOL CODE WILL REENTER COBDDT
;IF THERE IS A HISTORY THAT NEEDS TO BE TERMINATED. IT HAS TO BE
;PREPARED TO DO THAT IF THE USER DID THE STOP RUN FROM HIS CODE
;INSTEAD OF FROM THE TERMINAL.
STOPR: PUSHJ PP,STOPR.##
SUBTTL COMMON ROUTINE TO HANDLE BREAK
;ENTERED BY THE JSA T2,BCOM THAT IS IN THE BP TABLE.
;THE JSA GOT CONTROL FROM A JSR THAT WAS INSTALLED IN THE GENERATED CODE.
;AC'S ARE ALL IN USER PROGRAM STATE. ONLY TA CAN BE USED.
;THIS COMMON CODE SETS UP INDIRECT POINTERS TO BE USED BY
;THE REST OF THE BREAK HANDLER CODE, SO THE REST OF THE BREAK HANDLER
;CODE GOES INDIRECT TO THE PARAMETERS FOR THIS BREAK.
BCOM: Z ;JSA T2,BCOM
SETZM EBRKOV ;[26] IN CASE AN OVERLAY
;[26] MODULE HAD NO SYMBOLS
POP T2,LEAV ;GET EXIT INSTRUCTION
MOVEI T2,B1SEC-B1INS+1(T2) ;GET ADDRESS OF SECTION'S
;PROTAB ENTRY
HRRZM T2,BCOM3
MOVEI T2,B1CNT-B1SEC(T2) ;GET ADDRESS OF PROCEED COUNT
HRRZM T2,BCOM2
MOVE T2,BP1-B1CNT(T2) ;GET RETURN ADDRESS
HLLM T2,LEAV1 ;SAVE FLAGS
EXCH T2,BCOM
SKIPLE STPCTR ;[30] IS "STEP" IN EFFECT?
JRST BCOM0 ;[30] YES, DON'T BREAK
SOSG @BCOM2 ;TEST PROCEED COUNTER
JRST BREAK ;BREAK - ALL AC'S IN PLACE
;NOT TIME TO BREAK YET, RETURN TO USER'S CODE.
BCOM0: MOVEM T2,SAV.T2 ;[30] STASH 'T2'
LDB T2,[POINT 9,LEAV,8] ;GET SWAPPED INSTRUCTION'S OPCODE
;TO SEE OF WE CAN JUST EXECUTE IT,
;OR WHETHER IT MUST BE INTERPRETED.
CAIL T2,(<JSR>/1000)
CAILE T2,(<JSA>/1000) ;JSA,JSP
TRNN T2,700 ;UUO?
JRST PRCED1 ;YES: USE PROCEED CODE
CAIE T2,(<PUSHJ>/1000)
CAIN T2,(<XCT>/1000) ;PUSHJ,XCT?
JRST PRCED1 ;MUST ALSO BE INTERPRETED
MOVE T2,SAV.T2 ;OK TO JUST EXIT
JRSTF @LEAV1 ;EXIT
;HERE TO BREAK - SAVE WORLD AND SET UP PDL
BREAK: JSR SAVE ;...
SKIPE HFGTHR ;IF WE'RE DOING A HISTOGRAM, GO
PUSHJ PP,HABP ; ACCUMULATE STATISTICS.
PUSHJ PP,REMOVB ;REMOVE BREAK-POINTS
TYPE [ASCII "Break at "]
TYPE ANGLIN
MOVE T2,BCOM2
SUBI T2,2 ;GET ADDR OF BP
MOVEM T2,CUR.BP ;SAVE IT
MOVE DT,1(T2) ;POINTER TO SECTION NAME.
MOVEM DT,CBPADS+1
HRRZ T2,0(T2) ;PNTR TO PROTAB
MOVEM T2,CBPADS ;SAVE IT IN CASE HE CLEARS
; THE BREAK POINT.
LDB DT,[POINT 15,0(T2),17]
HRRZ T2,1(T2) ;ADDR IN USER'S PROGRAM
HRRM T2,PRCED0
ADD DT,@%NM ;NAMTAB ENTRY
PUSHJ PP,PRNAM ;PRINT BP NAME
HRRZ T2,@BCOM3 ;GET SECTION NAME
JUMPN T2,BREAK1 ;[26] NO SECTION NAME?
TYPE [ASCIZ " SECTION"] ;[26] MUST BE A SECTION NAME
JRST BREAK2 ;[26]
BREAK1: LDB DT,[POINT 15,0(T2),17] ;[26] GET NAMTAB ENTRY FOR SECTION NAME
ADD DT,@%NM
MOVE T2,1(DT) ;GET FIRST WORD OF NAME
CAME T2,[SIXBIT /:GENER/] ;SKIP IF IT'S COMPILER GENERATED
PUSHJ PP,[PTYPE [ASCIZ " in "]
JRST PRNAM]
BREAK2: HLRZ T2,@BCOM3 ;GET ENTRY POINT
SKIPE SUBSPR ;ARE THERE OTHER MODULES?
PUSHJ PP, [ TYPE [ASCIZ " in module "]
JRST PRTMNM]
TYPE ANGLOU
;BREAK COMMAND -- CONTINUED
; SET UP FOR BREAKING- SO THAT LIBOL PARAMS HAVE MODULE PROG
; FIRST MOVE LIBOL TO RUN TIME PARAMS
MOVE T2,@%NM ; [13] ADDR OF %NM
MOVEM T2,PNM ; [13] STORE INTO PROCEED
MOVE T2,@%DT ; [13] ADDR OF %DT
MOVEM T2,PDT ; [13] STORE INTO PROCEED
MOVE T2,@%PR ; [13] ADDR OF %PR
MOVEM T2,PPR ; [13] STORE INTO PROCEED
; NOW PUT BREAK PARAMS INTO LIBOL
MOVE T2,BNM ; [13] GET BREAK NM
MOVEM T2,@%NM ; [13] STORE INTO LIBOL NM
MOVE T2,BDT ; [13] GET BREAK DT
MOVEM T2,@%DT ; [13] STORE INTO LIBOL DT
MOVE T2,BPR ; [13] GET BREAK PR
MOVEM T2,@%PR ; [13] STORE INTO LIBOL PR
JRST XECUTC ;INTO MAIN LOOP
SUBTTL COMMAND PROCESSORS -- STEP / PROCEED
;COME HERE TO EXECUTE A 'STEP' COMMAND.
;COUNT IN W2
STEP: SKIPE CUR.BP ;[30] STEPPING FROM A BREAKPOINT?
ADDI W2,1 ;[30] YES, IGNORE THIS TRACE CALL
MOVEM W2,STPCTR ;[26] SAVE COUNTER, USE 'PROCEED' CODE.
MOVEI W2,1 ;PROCEED COUNT = 1
;COME HERE TO EXECUTE A PROCEED COMMAND.
PROCED: SKIPE HFGTHR ;IF WE WERE DOING A HISTOGRAM
JRST HISSTE ; GO DO A BEGIN SO THAT WE DON'T
; ADD THE TIME WE SPENT IN COBDDT
; TO THE CURRENT PARAGRAPH.
;COME HERE TO 'AUTOMATICALLY PROCEED'
PRCEDD: SKIPE DIED. ;ARE WE ALIVE?
JRST [TYPE [ASCIZ "?Cannot PROCEED!"]
JRST XECUTC] ;NO
;IF THIS IS ONLY A SIMULATED BREAKPOINT (STEP OR ^C/REENTER),
;REEFLG WILL BE ON, MEANING WE ENTERED COBDDT WITH A PUSHJ AND CAN
;RETURN WITH A POPJ.
SKIPE REEFLG ; [21] TIME TO REENTER?
JRST REERTN ; [21] YES
; SET UP TO PROCEED-SO THAT LIBOL HAS RUN-TIME PARAMS
; FIRST MOVE LIBOL INTO BREAK
MOVE T1,@%NM ; [13] ADDR OF %NM
MOVEM T1,BNM ; [13] STORE INTO BREAK
MOVE T1,@%DT ; [13] ADDR OF %DT
MOVEM T1,BDT ; [13] STORE INTO BREAK
MOVE T1,@%PR ; [13] ADDR OF %PR
MOVEM T1,BPR ; [13] STORE INTO BREAK
; NOW PUT PROCEED PARAMS INTO LIBOL
MOVE T1,PNM ; [13] GET PROCEED NM
MOVEM T1,@%NM ; [13] STORE INTO LIBOL NM
MOVE T1,PDT ; [13] GET PROCEED DT
MOVEM T1,@%DT ; [13] STORE INTO LIBOL DT
MOVE T1,PPR ; [13] GET PROCEED PR
MOVEM T1,@%PR ; [13] STORE INTO LIBOL PR
SKIPE EBRKOV ;ENTRY POINT BREAK?
JRST PROV ;YES, GO CONTINUE WITHOUT
; RESTORING EVERYTHING.
SKIPN T1,CUR.BP ;CURRENT?
JRST START ;NO: START USERS PROG
SKIPN W2 ;NUMBER GIVEN
MOVEI W2,1 ;NO: ASSUME ONE
MOVEM W2,2(T1) ;SAVE COUNT
PRCED0: HRRZI T1,0 ;ADDR MODIFIED !!!
PUSHJ PP,FETCH ;GET INSTRUCTION
MOVEM T2,LEAV
PUSHJ PP,INSRTB ;INSERT BREAK-POINTS
JRST PRCED2
;COME HERE FROM BREAK WHICH DID NOT ACTUALLY BREAK BECAUSE
;ITS PROCEED COUNT HAS NOT GONE TO 0 YET.
PRCED1: MOVE T2,SAV.T2 ;GET SAVED AC
JSR SAVE ;SAVE WORLD
PRCED2: MOVEI T3,100 ;SET MAX LOOP COUNT
MOVEM T3,TEMP1
JRST IXCT5
IXCT4: CAIL T2,40 ;SYSTEM UUO?
JRST IXCT6 ;YES: DON'T INTERPRET
MOVEM T1,40 ;SAVE UUO
MOVEI T1,41
IXCT: SOSG TEMP1 ;LOOPING
JRST BPLUP
PUSHJ PP,FETCH
MOVEM T2,LEAV ;STASH INSTR
IXCT5: HRLZI 17,AC0 ;TEMP FETCH OF ACS
BLT 17,17
MOVEI T2,@LEAV ;GET EFFECTIVE ADDRS
DPB T2,[POINT 23,LEAV,35]
LDB T3,[POINT 4,LEAV,12]
LDB T2,[POINT 9,LEAV,8]
CAIN T2,(<PUSHJ>/1000)
JRST IPUSHJ ;INTERPRET PUSHJ
CAIN T2,(<JSR>/1000)
JRST IJSR ;INTERPRET JSR
CAIN T2,(<JSP>/1000)
JRST IJSP ;INTERPRET JSP
CAIN T2,(<JSA>/1000)
JRST IJSA ;INTERPRET JSA
MOVE T1,LEAV
TRNN T2,700
JRST IXCT4 ;INTERPRET UUO
CAIN T2,(<XCT>/1000)
JRST IXCT ;INTERPRET XCT
IXCT6: MOVEI T2,LEAV
IXCT7: SETOM TEMP2
IXCT8: JRST RESTOR
;VARIOUS INTERPRETERS
IPUSHJ: DPB T3,[POINT 4,CPUSHP,12]
SETZM TEMP2 ;STORE AC FIELD INTO A PUSH
MOVE T2,LEAV
JRST IXCT8
IJSA: MOVE T2,BCOM
HRL T2,LEAV
EXCH T2,AC0(T3)
JRST IJSR2
IJSR: MOVE T2,BCOM
HLL T2,FLGS.
IJSR2: MOVE T1,LEAV
PUSHJ PP,DEP
AOSA T2,LEAV
ISR3: MOVE T2,LEAV
JRST IXCT7
IJSP: MOVE T4,BCOM
HLL T4,FLGS.
MOVEM T4,AC0(T3)
JRST ISR3
;COME HERE IF BREAK POINT LOOPING
BPLUP: PUSHJ PP,REMOVB
JSR SAVE
PTYPE [ASCIZ "?Fatal break-point error!"]
JRST XECUTC
;SAVE AND RESTORE WORLD CODE
SAVE: Z ;JSR ENTRY
MOVEM 17,PDL. ;CURRENT PDL
MOVEM 17,AC0+17
HRRZI 17,AC0
BLT 17,AC0+16 ;SAVE AC'S
MOVE T2,SAVE ;SAVE PROCESSOR FLAGS
HLLM T2,FLGS.
MOVE PP,PDL. ;RESTORE STACK POINTER
JRST @SAVE
;PROCEED CODE FOR PROCEEDING FROM ^C/REENTER OR STEP COMMAND.
REERTN: PUSHJ PP,INSRTB ; [26] INSERT ANY BREAKPOINTS
MOVE T2,REEFLG ; [21] GET ORIGINAL PDL
SETZM REEFLG ; [21] CLEAR
MOVE T1,0(T2) ; [21] GET DATA + FLAGS
CAME T2,AC0+PP ; [21] SAME ?
HALT . ; [21] NO
POP T2,0(T2) ; [21] CORRECT FOR JUMP
MOVEM T2,AC0+PP ; [21]
HLLZM T1,FLGS. ; [21] SET FLAGS AND FALL THROUGH
MOVEI T2,0(T1) ; [21]
SETOM TEMP2 ; [21] NO PUSH 0 NECESSARY
RESTOR: HLL T2,FLGS.
MOVEM T2,SAVE ;SAVE EXIT ADDR. AND FLAGS
HRLZI 17,AC0
BLT 17,17 ;RESTORE AC'S
SKIPL TEMP2
CPUSHP: PUSH .-.,BCOM ;AC MODIFIED AT IPUSHJ
JRSTF @SAVE ;EXIT
;COME HERE TO START USER'S PROGRAM
START: PUSHJ PP,INSRTB ;INSERT BREAK-POINTS
MOVE PP,PDL.
JRST @PROGST
;CODE TO FETCH THE USER'S INSTRUCTION AT POINT OF BREAK.
FETCH: TRNN T1,-20 ;IS IT IN AN AC?
SKIPA T2,AC0(T1) ;YES: FETCH FROM SAVED AC'S
MOVE T2,0(T1) ;NO
POPJ PP,
;CODE TO DEPOSIT AN INSTRUCTION AT THE POINT OF BREAK.
DEP: TRNN T1,-20 ;IS IT IN AN AC?
JRST DEP1 ;YES
MOVEM T2,0(T1) ;NO
POPJ PP,
DEP1: MOVEM T2,AC0(T1) ;STORE INTO THE SAVED AC
POPJ PP,
;CODE TO REMOVE OR INSERT BREAKPOINTS
INSRTB: MOVE T5,[JSR BP1]
MOVEI T4,B1ADR
INSRT1: SKIPE T1,(T4) ;IF THE BP ISN'T ACTIVE OR IS
PUSHJ PP,CHKBP ; IN A NON RESIDENT SEGMENT,
JRST INSRT2 ; DON'T INSERT IT.
HRRZ T1,1(T1) ;YES: GET ADDR OF BP
PUSHJ PP,FETCH ;GET USER'S INSTRUCTION
CAME T2,T5 ;[26] DON'T STORE IT IF A BREAK
;IS ALREADY THERE (^C/REENTER PROBLEM)
MOVEM T2,2(T5) ;SAVE IT
MOVE T2,T5
PUSHJ PP,DEP ;DEPOSIT "JSR"
INSRT2: ADDI T5,LBP
ADDI T4,LBA
CAIG T4,BNADR ;DONE??
JRST INSRT1
SETZM CUR.BP ;[26] FORGET CURRENT BREAK
POPJ PP, ;YES:
REMOVB: MOVEI T5,BP1
MOVEI T4,B1ADR
REMOV1: SKIPE T1,(T4) ;IF THE BP ISN'T ACTIVE OR IS
PUSHJ PP,CHKBP ; IN A NON RESIDENT SEGMENT,
JRST REMOV2 ; DON'T REMOVE IT.
HRRZ T1,1(T1) ;GET ADDR OF USER'S INSTRUCTION
MOVE T2,2(T5) ;GET USER'S INSTRUCTION
PUSHJ PP,DEP ;PUT IT BACK
REMOV2: ADDI T5,LBP
ADDI T4,LBA
CAIG T4,BNADR
JRST REMOV1
POPJ PP,
;COME HERE FROM LIBOL'S SEGMENT HANDLER TO PUT ANY BREAKPOINTS IN THE
; SEGMENT WHICH IT HAS JUST READ IN.
SBPSG.: MOVE T5, [JSR BP1]
MOVEI T4, B1ADR
SBPSGD: SKIPE T1, (T4) ;IF THERE ISN'T A BP SET OR
PUSHJ PP, CHKBP ; IT ISN'T IN THIS SEGMENT OR
JRST SBPSGH ; IT'S IN THE RESIDENT SEGMENT,
JUMPE T3, SBPSGH ; DON'T MESS WITH IT.
HRRZ T1, 1(T1) ;GET THE ADDRESS AT WHICH TO SET IT.
PUSHJ PP, FETCH ;GO GET THE INSTR WHICH IS THERE.
MOVEM T2, 2(T5) ;SAVE IT AND REPLACE IT
MOVE T2, T5 ; WITH A JSR TO THE APPROPRIATE
PUSHJ PP, DEP ; BREAK POINT.
SBPSGH: ADDI T5, LBP ;BUMP UP TO THE NEXT BREAK
ADDI T4, LBA ; POINT.
CAIG T4, BNADR ;IF THERE ARE MORE,
JRST SBPSGD ; LOOP.
POPJ PP, ;OTHERWISE RETURN.
;CHECK TO SEE IF A BREAKPOINT IS IN A NON-RESIDENT SEGMENT WHICH IS
; NOT CURRENTLY IN CORE. IF IT IS RESIDENT OR IS CURRENTLY IN CORE
; TAKE THE SKIP RETURN. ENTER WITH (T1) = BREAKPOINT'S ADDRESS.
; LEAVE WITH (T3) = THE SEGMENT PRIORITY FOR THIS PARAGRAPH/SECTION.
CHKBP: LDB T3, [POINT 7,2(T1),24] ;GET THE PRIORITY.
TRNE T3, -1 ;IF IT'S RESIDENT OR IT'S
CAMN T3, SEGNO.## ; PRIORITY IS THE SAME AS THE
AOS (PP) ; CURRENT SEGMENT'S, TAKE
POPJ PP, ; THE SKIP RETURN.
;PRINT NAME FOUND POINTED AT IN DT
PRNAM: HLRZ T2,0(DT) ;GET # OF WORDS
HRRZI T1,1(DT) ;GET ADDR OF FIRST
HRLI T1,(<POINT 6,,>);MAKE BP
PRNAM1: ILDB T3,T1
JUMPE T3,PRNAM2 ;DONE IF ZERO
ADDI T3,40 ;CONVERT TO ASCII
CAIN T3,":"
MOVEI T3,"-"
CAIN T3,";"
MOVEI T3,"."
TYPEAC T3
TLNE T1,770000 ;WORD FINISHED
JRST PRNAM1 ;NO: LOOP
SOJG T2,PRNAM1 ;YES: CHECK IF THAT'S ALL
PRNAM2: POPJ PP, ;ALL DONE - EXIT
;PRINT THE MODULE'S NAME. ENTRY POINT ADDR IS IN T2.
PRTMNM: MOVE T2,-1(T2) ;Get sixbit name from addr-1.
JRST SIXSIX ;Go type it
;PRINT THE OCTAL NUMBER IN T2.
PROCT: PUSHJ PP,PROCTD ;Type first six digits
TYPEC <",">
PROCTD: SETOI T1,
PROCTH: HRRI T1,6 ;This will get octal 60
LSHC T1,3 ;Add in digit, make octal 6x.
TYPEAC T1 ;Type 0 thru 7.
JUMPL T1,PROCTH ;Loop for six digits
POPJ PP,
SUBTTL C.TRCE CODE -- PERFORM "TRACE" FOR COBOL PROGRAM
;ENTER COBDDT HERE FROM ALL TRACEABLE POINTS IN THE USER PROGRAM.
; PUSHJ PP,C.TRCE
; XWD ;ARGUMENT WORD
;THE ARGUMENT WORD CONTAINS:
;BITS 0-8 FLAGS
; BIT 3 DEBUGGING MODE REQUIRED
; BIT 4 EXIT PROGRAM
; BIT 5 GOBACK
; BIT 7 PROGRAM ENTRY
; BIT 8 ALTERNATE ENTRY
;BITS 9-17 ARGUMENT WORD COUNT (1 OR 2)
;BITS 18-35 POINTER TO PROTAB ENTRY FOR THIS PROCEDURE NAME.
;
;NAMES PRINTED BY THE TRACE ARE PRECEDED BY A STRING OF *'S AND !'S.
;A * INDICATES A PERFORM THAT IS ACTIVE, AND A ! INDICATES A CALL.
;TRACE KEEPS TRACK OF UP TO 35 OF THESE CHARACTERS.
;IS THIS THE FIRST TRACE CALL FOLLOWING A REENTER FROM MONITOR LEVEL?
C.TRCE: SKIPE REEBRK ;[26] REENTER BREAK?
JRST [PTYPE [ASCIZ /
Program interrupted at /]
SETZM STPCTR
JRST .+1] ;[26] YES
HRRZ T2,(PP) ;[26] GET ARG PTR
HRRZ T1,(T2) ;GET PROTAB LINK IF ANY
HLRZ T2,(T2) ;GET ARG COUNT AND FLAGS
LDB T5,[POINT 9,T2,35] ;GET ARG COUNT
TRNE T2,TC.GB ;GOBACK?
JRST TRACE0 ;YES
TRNE T2,TC.EP ;EXIT PROGRAM?
JRST TRACE1 ;YES
TRNE T2,TC.PE!TC.AE ;PROGRAM-ENTRY OR OTHER ENTRY?
JRST TRACE2 ;YES
SKIPE HFGTHR ;IF WE'RE DOING A HISTOGRAM GO
PUSHJ PP,HAPS ; ACCUMULATE STATISTICS.
; SAVE THIS PROTAB ADDRESS AS NAME TO BE PRINTED IF PROGRAM GETS
; AN ABORT ERROR.
SKIPN @%NM ;DO WE HAVE SYMBOLS?
JRST [SETZM L.SECT
SETZM L.PARA
JRST CTRCE1] ;NO
ADD T1,@%PR ;MAKE REAL ADDR
MOVEM T1,L.PARA ;[26] ASSUME PARAGRAPH
MOVE T3,PR.FLG(T1) ;[26] GET PAR/SECT FLAG
TRNN T3,PR%SEC ;[26] IS IT PARA?
JRST [MOVEM T1,L.SECT
SETZM L.PARA
JRST CTRCE1] ;[26] NO, NEW SECTION
CTRCE1: PUSHJ PP,STPCHK ;[26] ARE WE STEPPING?
SKIPE REEBRK ;[26] TIME TO BREAK?
JRST CTRCE3 ;[26] YES
SKIPN PTFLG. ;ARE WE PRINTING?
JRST DEBCHK ;NO, SEE IF DEBUGGING THIS PROCEDURE
; WE ARE TRACING SO WE MUST PRINT
CTRCE3: PUSHJ PP,PTDPTH ;PRINT STRING OF !/*
TYPE ANGLIN
SKIPN T1,L.PARA ;[26] IS THERE A CURRENT PARAGRAPH?
JRST [SKIPN T1,L.SECT
JRST [PTYPE [ASCIZ /(no name)/]
JRST CTRCE6]
PUSHJ PP,PRTPNM
PTYPE [ASCIZ / SECTION/]
JRST CTRCE6] ;[26] NO, PRINT SECTION NAME ONLY.
PUSHJ PP,PRTPNM ;[26] YES, PRINT PARA NAME
SKIPN T1,L.SECT ;[26] SECT NAME TOO?
JRST CTRCE6 ;[26] NO
PTYPE [ASCIZ / in /] ;[26] YES
PUSHJ PP,PRTPNM ;[26] PRINT SECT NAME
CTRCE6: TYPE ANGLOU
TYPE CRLF
SKIPN REEBRK ; [21] FROM A REENTER OR STEP?
JRST DEBCHK ;NO, RETURN...
; [21] YES, SETUP A BREAK
DEB: MOVEM PP,REEFLG ; [21] SET FLAGS FOR OTHERS AND SAVE STACK POINTER.
HRRZ T2,0(PP) ; [21] FIND RETURN ADDRESS BY
ADD T2,T5 ; [21] ADDING ARGUMENT COUNT
HRRM T2,0(PP) ; [21]
JSR SAVE ; [21] GO SAVE THE STATE OF ALL
SETZM REEBRK ; [21] NEVER DO THIS TWICE
PUSHJ PP,REMOVB ;[27] REMOVE FOR STEP COMMAND
;;; SETZM PTFLG. ; [26] OR THIS NUMBER OF TIMES
JRST XECUTX ; [21]
;CHECKS WHETHER STEPPING IS BEING DONE AND PRINTS IF SO.
STPCHK: SOSE STPCTR ;[26] ARE WE STEPPING?
POPJ PP, ;[26] NO
SETOM REEBRK ;[26] YES. SET TO BREAK.
PTYPE [ASCIZ /STEP at /] ;[26]
POPJ PP, ;[26]
;COMMON ENTRANCE TO PRNAM
PRTPNM: LDB DT,[POINT 15,0(T1),17] ;[26] GET NAMTAB ADDR
ADD DT,@%NM
JRST PRNAM
;TRACE A 'GOBACK' OR 'EXIT PROGRAM'
TRACE0: PUSHJ PP, TRAC1D
ASCIZ /<<GOBACK>>
/
TRACE1: PUSHJ PP, TRAC1D
ASCIZ /<<EXIT PROGRAM>>
/
TRAC1D: SKIPE HFGTHR ;IF WE'RE DOING A HISTOGRAM GO
PUSHJ PP,HAGBS ; ACCUMULATE STATISTICS.
PUSHJ PP,STPCHK ;[26] SEE IF WE ARE STEPPING
SKIPE REEBRK ;[26] SHOULD WE PRINT THE MESSAGE?
JRST TRAC1F ;[26] YES
SKIPN PTFLG. ;ARE WE TRACING?
JRST TRAC1H ;NO
TRAC1F: PUSHJ PP,PTDPTH ;PRINT STRING OF */!
TYPE @(PP) ;PRINT MESSAGE
TRAC1H: AOS DEPTH ;SHORTEN STRING
POP PP,0(PP) ;DISCARD POINTER TO TYPEOUT
POP PP,T2 ;[26] SAVE TRACE EXIT
POP PP,CUREPA ;[26] UNSTACK ENTRY POINT
POP PP,T3 ;[26] UNSTACK SECT AND PARA PRTAB ADDRS.
HRRZM T3,L.SECT ;[26] RESTORE SECTION NAME
HLRZM T3,L.PARA ;[26] RESTORE PARA NAME
PUSH PP,T2 ;[26] RESTACK TRACE EXIT
SKIPE REEBRK ;[26] SIMULATE BREAK?
JRST DEB ;[26] YES
JRST CNPOPJ
;TRACE ENTRY OR PROGRAM-ENTRY
;CAUTION: DO NOT TAMPER WITH NEXT THREE LINES.
XWD 0,"!"
TRACE2: SOSL DEPTH
JSA T2,TPDCHR ;ADD ! TO STRING
SKIPE HFGTHR ;IF WE'RE DOING A HISTOGRAM GO
PUSHJ PP,HAEPS ; ACCUMULATE STATISTICS.
POP PP,T2 ;[26] SAVE TRACE EXIT
POP PP,T1 ;[26] SAVE PTR TO PREVIOUS STACK FRAME
PUSH PP,L.SECT ;[26] STACK OLD SECTION NAME
MOVE T3,L.PARA ;[26] GET OLD PARA NAME
HRLM T3,0(PP) ;[26] STACK OLD PARA NAME
PUSH PP,CUREPA ;[26] STACK OLD ENTRY POINT
PUSH PP,T1 ;[26] RESTACK PREV STACK FRAME'S PTR
PUSH PP,T2 ;[26] RESTACK TRACE EXIT
;HAVE TO ADJUST THE VALUE OF THE STACK POINTER THAT PUTF. (IN LIBOL)
;SAVED IN SBPSA. THIS ROUTINE JUST ADDS 2 TO IT.
PUSHJ PP,ISBPS. ;[26]
SETZM L.SECT ;[26] FORGET OLD
SETZM L.PARA ;[26] PROCED NAMES
;NOW FIND THE ENTRY POINT BY SEARCHING BACKWARDS FROM CALL ON C.TRCE.
MOVSI T1,(SKIPA) ;[26] ENTRY PT HAS SKIPA 0
CAME T1,(T2) ;[26] THIS IT?
SOJA T2,.-1 ;[26] NO
HRRZM T2,CUREPA ;[26] YES, SAVE IT
PUSHJ PP,STPCHK ;[26] ARE WE STEPPING?
SKIPE REEBRK ;[26] SIMULATE BREAK?
JRST TRACE3 ;[26] YES, SO PRINT
SKIPE PTFLG. ;TRACING?
JRST TRACE3 ;YES
SKIPN T2,EBRKOV ;[26] BREAK ON OVERLAY?
JRST CNPOPJ ;[26] NO
;(IF MODULE IN OVERLAY HAD NO SYMBOLS, WE MISSED THAT BREAK)
CAMN T2,CUREPA ;[26] RIGHT ENTRY POINT?
JRST BROV ;[26] YES
SETZM EBRKOV ;[26] NO,FORGET IT
CNPOPJ: ADDM T5,(PP) ;NO, SKIP RETURN
POPJ PP,
;PRINT THE PROGRAM OR ENTRY NAMES
TRACE3: PUSHJ PP,PTDPTH
AOS (PP) ;AIM AT NAME ARG
PTYPE ANGLIN
TRNE T2,TC.PE ;PROGRAM ENTRY?
JTYPE [ASCIZ "PROGRAM "]
TRNE T2,TC.AE ;OR OTHER ENTRY?
JTYPE [ASCIZ "ENTRY "]
TRACE5: SOJLE T5,TRACE4 ;CHK COUNT OF NAME TO PRINT
AOS T2,(PP) ;BUMP ARG PTR
MOVE T2,-1(T2) ;GET ARG WORD
PUSHJ PP,SIXSIX
JRST TRACE5
TRACE4: PTYPE [BYTE (7)76,76,15,12]
SKIPN T2,EBRKOV ;[26] BREAK ON OVERLAY?
JRST TRACE6 ;[26] NO
;(IF MODULE IN OVERLAY HAD NO SYMBOLS, WE MISSED THAT BREAK)
CAMN T2,CUREPA ;[26] RIGHT ENTRY POINT?
JRST BROVA ;[26] YES
TRACE6: SETZM EBRKOV ;[26] NO,FORGET IT
SKIPE REEBRK ;[26] SIMULATE BREAK?
JRST DEB ;[26] YES
POPJ PP,
;GETS NAMTAB, DATAB AND PRTAB ADDRESSES FOR CURRENT ENTRY POINT.
;CUREPA MUST HAVE ENTRY POINT ADDRESS.
GTTABS: HRRZ T2,CUREPA ;[26] GET ENTRY ADDRESS
HRRZ T2,1(T2) ;[26] ADDR OF %FILES
HRLI T2,%%NM.(T2) ;[26] NAMTAB ADDR
HRR T2,%NM ;[26]
HRRZ T1,%NM ;[26]
BLT T2,2(T1) ;[26] GET ALL 3
POPJ PP, ;[26]
;SEE IF DEBUGGING MODE REQUIRED
DEBCHK: SKIPE DIED. ;IF PROGRAM IS DEAD
JRST CNPOPJ ;JUST GIVE UP
HRRZ T2,(PP) ;GET FLAGS AGAIN
HLRZ T2,(T2)
TRNN T2,TC.DB ;DEBUGGING?
JRST CNPOPJ ;NO, JUST EXIT
JRST DBPRO. ;YES
SUBTTL BTRAC. ENTRY POINT
;ENTER HERE FROM KILL.
BTRAC.: SKIPN DNRSTT ;Are we done RESET.?
POPJ PP, ;No, error in RESET. code, don't
; bother getting to DIALOG mode
SETOM DIED. ;WE ARE NOW DEAD
SETZM STPCTR ;[26] DON'T BREAK DURING PRINT
SETZB T5,REEBRK ;[26] ZERO ARG COUNT; NO BREAK
PTYPE [ASCIZ "Entering COBDDT from: "]
SKIPN @%DT ;[26] ANY SYMBOLS?
JRST [PTYPE [ASCIZ / (module with no symbols)/]
JRST BTRAC1] ;[26] NO...
PUSHJ PP,CTRCE3 ;[26] PRINT WHERE WE ARE.
BTRAC1: PUSHJ PP,PPOT4. ;[26] AUTOMATIC TRACE BACK
MOVEM PP,PDL. ;[26] DON'T WIPE OUT ANY STACK
JRST XECUTX ;GO...
;ROUTINES TO KEEP TRACE CORRECT FOR PERFORMS.
;IN ORDER TO REMEMBER THE LAST-SEEN SECTION AND PARAGRAPH NAMES AT
;THE PERFORM STATEMENT, WE SAVE THEM ON THE STACK, THEN RESTORE THEM
;AT THE EXIT FROM THE PERFORM RANGE.
; USE SAME REGISTERS THAT PERF. USES.
PERFTA==10 ;HOLDS ADDR OF START OF PERF RANGE.
PERFTB==11 ;HOLDS COPY OF RETURN ADDR ON STACK
;COME HERE FROM OBJECT PROGRAM DURING A PERFORM SETUP.
;SAVE PAR AND SECT NAMES AND ADD * TO STRING THAT GETS PRINTED
;IN FRONT OF ANY NAME THAT IS BEING TRACED.
;CAUTION: DO NOT TAMPER WITH THE NEXT THREE INSTRUCTIONS.
XWD 0,"*"
TRPD.: SOSL DEPTH
JSA T2,TPDCHR ;ADD A * TO THE STRING
SKIPE HFGTHR ;IF WE'RE DOING A HISTOGRAM GO
PUSHJ PP,HAPFS ; ACCUMULATE STATISTICS.
;LEAVE PERFORM EXIT ADDRESS ON TOP OF STACK, BUT SLIP SECTION AND
;PARAGRAPH NAME PRTAB ADDRESSES JUST BELOW IT.
POP PP,PERFTB ;SAVE EXIT WORD.
PUSH PP,L.SECT ;STACK SECTION
MOVE T2,L.PARA ;[26] AND PARAGRAPH
HRLM T2,0(PP) ;[26] PRTAB ADDRESSES
PUSH PP,PERFTB ;RESTACK EXIT WORD.
JRST -1(PERFTA) ;RETURN
;COME HERE FROM OBJECT PROGRAM WHEN EXITING A PERFORM RANGE.
;REMOVES A CHAR FROM STRING AND RESTORES SECT AND PAR NAMES.
TRPOP.: SKIPE HFGTHR ;IF WE'RE DOING A HISTOGRAM GO
PUSHJ PP,HAEXS ; ACCUMULATE STATISTICS.
AOS DEPTH ;SHORTEN STRING
POP PP,T2 ;UNSTACK RETURN ADDR
POP PP,PERFTA ;[26] UNSTACK SECTION
HRRZM PERFTA,L.SECT ;[26] AND PARAGRAPH
HLRZM PERFTA,L.PARA ;[26] PRTAB ADDRESSES
JRST (T2) ;RETURN
IFNDEF MXDPTH,<MXDPTH==^D35> ;MAXIMUM DEPTH WE WILL KEEP TRACK OF.
;SUBROUTINE TO ADD A CHARACTER TO THE STRING. ENTERED WITH THE WORLD'S
;WORST CALLING SEQUENCE:
;
; XWD 0, "Z" ;THE CHARACTER TO BE ADDED.
; SOSL ... ;ANY RANDOM INSTRUCTION.
; JSA T2,TPDCHR
TPDCHR: Z ;CALLED VIA JSA.
PUSH PP, T1 ;DON'T MESS UP ANY AC'S.
PUSH PP, T3
MOVE T1, DEPTH
SUBI T1, MXDPTH
MOVE T3, TRSPTR
AOJGE T1, TPDCHD
IBP T3
AOJL T1, .-1
TPDCHD: MOVE T1, -3(T2)
IDPB T1, T3
POP PP, T3
POP PP, T1
JRA T2, (T2)
;SUBROUTINE TO PRINT THE STRING OF *'S AND !'S.
PTDPTH: PUSH PP, T2 ;DON'T MESS UP ANY AC'S.
MOVE T2, DEPTH
SUBI T2, MXDPTH
JUMPE T2, PTDPTP
CAMG T2, [EXP -MXDPTH]
HRREI T2, -MXDPTH
PUSH PP, T1
PUSH PP, T3
MOVE T3, TRSPTR
PTDPTL: ILDB T1, T3
TYPEAC T1
AOJL T2, PTDPTL
POP PP, T3
POP PP, T1
PTDPTP: POP PP, T2
POPJ PP,
TRSPTR: POINT 7,.+1
BLOCK <MXDPTH+4>/5
DEPTH: EXP MXDPTH
;ROUTINE TO DO INITIALIZATION ON THE FLY FOR LINK-10 OVERLAYS.
; CALLED BY PUTF. BEFORE IT SWAPS THE TABLES (EVERY ENTRY).
; ENTER WITH (16) = ENTRY POINT ADDRESS.
; ALL AC'S ARE PRESERVED.
SFOV.: MOVEM 16,SAV16 ;SAVE ENTRY POINT ADDRESS
SKIPE HFGTHR ;IF WE'RE DOING A HISTOGRAM GO
PUSHJ PP,HAOVL ; ACCUMULATE STATISTICS.
JSR SVALL ;GO SAVE THE AC'S.
MOVE T2,SAV16
MOVE T1,-2(T2) ;MAKE SURE WE ARE AT THE
TRNE T1,-1 ; MAIN ENTRY POINT.
MOVEI T2,(T1)
MOVE T1,1(T2) ;IF WE HAVE ALREADY
SKIPGE T3,%%NM.(T1) ; INITIALIZED THIS MODULE
JRST SFOVI ; LEAVE.
;WE HAVE TO INITIALIZE ANY NEW MODULES THAT WERE BROUGHT IN.
; BUT FIRST REMOVE ANY BREAK POINTS AND ENTRY POINTS FOR MODULES THAT
; WERE OVERLAYED.
MOVE NM,ETYPTS ;GET POINTER TO THE ENTRY POINT TABLE.
SKIPN T2,(NM) ;IS THERE ONE THERE?
SFOVB: AOBJN NM,.-1 ;NO, LOOP.
JUMPGE NM,SFOVE ;IF THERE AREN'T ANY MORE, THERE
; ARE NO ENTRY POINTS TO BE REMOVED,
; GO ON.
HLRZ T2,T2 ;GET PONTER TO THE OVERLAY BLOCK.
JUMPE T2,SFOVB ;IF IT'S RESIDENT, IGNORE IT.
MOVE T2,OVLKN(T2) ;GET THE MODULE'S LINK NUMBER.
SKIPE P1,OVLCHS ;GET THE ADDR OF THE ROOT'S
; CONTROL SECTION.
SFOVC: HRRZ P1,CS.PTR(P1) ;GET THE NEXT CONTROL SECTION.
JUMPE P1,SFOVD ;NO MORE CONTROL SECTIONS,
; GO REMOVE THE LINK.
HRRZ T1,CS.NUM(P1) ;GET THE LINK NUMBER.
CAIE T1,(T2) ;IS THIS THE ONE?
JRST SFOVC ;NO, GO LOOK AT THE NEXT ONE.
JRST SFOVB ;YES, DON'T REMOVE IT.
SFOVD: HLRZ T3,T2 ;GET THE LOWEST ADDRESS IN THE
; LINK THAT WENT AWAY.
MOVEI T5,[ASCIZ /
[Overlayed /]
PUSHJ PP,SFOVS ;GO REMOVE ANY ENTRY POINTS
; AND BREAK POINTS THAT HAVE
; BEEN OVERLAYED.
SKIPE PTFLG.
JTYPE [ASCIZ /with /]
JRST .+3
SFOVE: SKIPE PTFLG.
MSG01==[ASCIZ "
[Brought in modules "]
JTYPE MSG01
;NOW GO THROUGH ALL THE CONTROL SECTIONS AND INITIALIZE ANY MODULES
; WHICH HAVEN'T BEEN INTIALIZED YET.
SETOM SUBSPR ;NOTE THAT THERE ARE SUBROUTINES
; PRESENT.
SKIPE T1,OVLCHS ;GET THE ADDR OF THE ROOT'S CS.
SFOVF: HRRZ T1,CS.PTR(T1) ;GET THE ADDR OF THE NEXT CS.
JUMPE T1,SFOVH ;IF THAT'S ALL, WE'RE DONE.
SKIPN T4,CS.INT(T1) ;GET POINTER TO THE INTERNAL
; TRANSFER TABLES.
JRST SFOVF ;IF IT DOESN'T EXIST, GO LOOK
; AT THE NEXT CS.
PUSH PP,T1 ;SAVE CS PTR.
SFOVG: HRRZ T2,(T4) ;GET THE ADDR (OF AN ENTRY PT?)
PUSH PP,T4 ;SAVE THE POINTER.
PUSHJ PP,SFOVK ;GO SEE IF WE HAVE TO LINK ANYTHING.
POP PP,T4 ;RESTORE THE POINTER.
ADDI T4,1 ;SKIP OVER A WORD.
AOBJN T4,SFOVG ;IF THERE ARE MORE (ENTRY PTS.), LOOP.
POP PP,T1 ;RESTORE CS PTR.
JRST SFOVF ;GO LOOK FOR MORE CONTROL SECTIONS.
SFOVH: SKIPE PTFLG.
MSG02==[ASCIZ /]
/]
JTYPE MSG02
MOVE T2,AC0+T2
SKIPE BRKONO ;IF HE WANT'S TO BREAK,
MOVEM T2,EBRKOV ; REMEMBER TO DO SO LATER.
SFOVI: HRLZI 17,AC0 ;RESTORE THE AC'S.
BLT 17,17
POPJ PP, ;RETURN.
;ROUTINE TO SET UP THE OVERLAY BLOCKS AND INITIALIZE
; MODULES IN A LINK-10 OVERLAY.
; ENTER WITH (T2) = ENTRY POINT ADDRESS.
SFOVK: MOVE NM, ETYPTS ;GET THE POINTER TO THE ENTRY POINTS.
SFOVL: MOVS T1, (T2) ;GET THE INSTRUCTION AT THE EP.
CAIE T1, (<SKIPA 0,0>) ;IF IT ISN'T "SKIPA 0,0",
POPJ PP, ; LEAVE.
HRRZ T1, -2(T2) ;MAKE SURE THAT WE ARE AT
TRNE T1, -1 ; THE MAIN ENTRY POINT.
HRRZI T2, (T1)
MOVE T1, 1(T2) ;GET THE ADDR OF %FILES.
SKIPGE %%NM.(T1) ;IF THE MODULE HAS ALREADY BEEN
POPJ PP, ; INITIALIZED, LEAVE.
MOVE NM, ETYPTS ;PUT THE MODULE'S MAIN ENTRY
SKIPE (NM) ; POINT IN THE ENTRY POINT
AOBJN NM, .-1 ; TABLE.
JUMPGE NM, [CAIN NM, ETYTAB+^D100
JRST [PTYPE [ASCIZ /
?Too many subroutines for COBDDT to cope with. Please combine
some of them so that there are less than 100 modules./]
$DIE]
MOVS T3, ETYPTS
SUBI T3, 1
MOVSM T3, ETYPTS
JRST .+1]
HRRZM T2,(NM) ;PUT THE EP ADDR IN THE TABLE.
HRRZM NM,NMSVD ;REMEMBER WHERE WE PUT IT.
HRROS %%NM.(T1) ;MARK THE MODULE.
MOVEM T1,SVMPT ;SAVE MODULE POINTER
SKIPN PTFLG. ;IF WE'RE TRACING, PRINT IT'S NAME.
JRST SFOVM
MOVE T4,-1(T2)
PUSHJ PP,SFOVU
TYPEC " "
;BUILD AN OVERLAY BLOCK FOR THE MODULE.
; FIRST FIND OUT WHICH LINK IT'S IN.
SFOVM: MOVE T1, OVLCHS ;GET THE ADDR OF THE ROOT LINK'S
; CONTROL SECTION.
SFOVN: HRRZ T1, CS.PTR(T1) ;GET THE ADDR OF THE NEXT CS.
MOVE T4, CS.COR(T1) ;GET BASE ADDR AND LENGTH OF
HLRZ T3, T4 ; THE LINK.
ADDI T3, (T4) ;LAST ADDR IN THE LINK.
CAIGE T3, (T2) ;IF THIS ISN'T THE ONE,
JRST SFOVN ; GO LOOK AT THE NEXT ONE.
; NOW SEE IF IT WAS IN CORE BEFORE.
MOVE T5, -1(T2) ;GET THE MODULE'S NAME.
MOVE P2, CS.NUM(T1) ;AND LINK NUMBER.
SKIPA T4, OVRLHD ;GET THE POINTER TO THE OVERLAY BLOCKS.
SFOVO: SKIPN T4, OVLTN(T4) ;GET THE NEXT OVERLAY BLOCK.
JUMPE T4, SFOVP ;NO MORE OVERLAY BLOCKS, IT WAS
; NEVER IN CORE BEFORE.
HRRZ T3, OVLKN(T4) ;GET THE LINK NUMBER.
CAMN T5, OVNAM(T4) ;NAMES MATCH?
CAIE P2, (T3) ;YES, LINK NO'S MATCH?
JRST SFOVO ;NO, NOT A MATCH.
JRST SFOVQ ;MATCH, GO ON.
; DIDN'T FIND A MATCH, BUILD A BLOCK FOR IT.
SFOVP: PUSH PP,T1 ;SAVE PTR TO OVERLAY
MOVEI T1,OVBKSZ ;# WORDS WE NEED
PUSHJ PP,GWORDS ;GET THE WORDS, RETURNS ADDR IN T3
POP PP,T1 ;T1:= PTR TO OVERLAY
; LINK THE BLOCK IN AS THE LAST BLOCK IN THE LIST.
SKIPN T4,OVRLHD
HRLZI T4,OVRLHD
HLRZS T4
HRRZM T3,(T4) ;STORE ADDRESS OF THIS BLOCK
HRLM T3,OVRLHD
MOVE T4,MYJFF ;GET NEW JBFF
HRLI T3,(T3) ;ZERO OUT THE BLOCK.
SETZM (T3)
ADDI T3,1
BLT T3,-1(T4)
MOVEI T4,-OVBKSZ(T4) ;POINT AT THE FIRST LOCATION OF
; THE BLOCK.
;NOTE: T2 MUST NOT BE SMASHED BY THE ABOVE.. IT IS USED AGAIN HERE
MOVE T5,-1(T2) ;GET THE MODULE'S NAME
MOVEM T5,OVNAM(T4) ; AND PUT IT IN THE BLOCK.
HRL T3,CS.COR(T1) ;COMBINE THE LOWEST ADDR IN THE
HRR T3,P2 ; LINK WITH THE LINK NUMBER AND
MOVEM T3,OVLKN(T4) ; PUT THEM IN THE BLOCK.
; PUT THE REST OF THE JUNK IN THE BLOCK.
MOVE T1,SVMPT ;GET MODULE POINTER
HLL T2,-2(T2) ;GET THE MODULE'S START ADDR.
MOVEM T2,OVEPA(T4) ;SAVE FIRST LOC,,EP ADDR.
HRRZ T3,%%NM.(T1)
MOVEM T3,OV%NM(T4)
MOVE T3,%%DT.(T1)
MOVEM T3,OV%DT(T4)
SFOVQ: HLLZ T3,OV%PR(T4)
IORB T3,%%PR.(T1)
MOVEM T3,OV%PR(T4)
HRLM T4,@NMSVD ;PUT THE OVERLAY BLOCK'S ADDR
; IN THE ENTRY POINT TABLE.
; IF THE HISTOGRAM IS ACTIVE AND WE HAVEN'T SET UP A TABLE FOR THIS
; MODULE, DO SO NOW.
SKIPE HFINIT
TLNE T3, -1
JRST SFOVR
; SET UP A HISTOGRAM TABLE.
MOVEI T2,(T1) ;GET THE SIZE OF PROTAB.
MOVE T1,%%PR.(T2)
HLRZ T3,%%DT.(T2)
SUBI T3,(T1)
MOVEI T1,(T3) ;GET # WORDS WE NEED
PUSH PP,T2 ;DON'T SMASH T2 IN GWORDS
PUSHJ PP,GWORDS ;RETURNS START ADDR IN T3
POP PP,T2 ;GET BACK T2
HLRZ T4,(NM) ;GET THE OVERLAY BLOCK'S ADDR.
HRLM T3,OV%PR(T4) ;PUT THE HISTAB ADDR IN IT.
HRLM T3,%%PR.(T2) ; AND IN %PR.
PUSHJ PP,HISIRP ;GO CLEAN THE TABLE UP.
SFOVR: HRRZ T2, @NMSVD ;GET THE ENTRY POINT ADDR BACK.
HLRZ T1, 1(T2) ;GET THE LIST OF PROGRAMS CALLED.
SFOVRH: SKIPN T2, (T1) ;IF THIS MODULE DOESN'T
POPJ PP, ; CALL ANYONE, RETURN.
PUSH PP, T1 ;OTHERWISE, SAVE THE PTR.
PUSHJ PP, SFOVL ;GO DO THIS PROGRAM.
POP PP, T1 ;RESTORE THE PTR.
AOJA T1, SFOVRH ;AND GO SEE IF ANYONE ELSE IS CALLED.
;ROUTINE TO REMOVE ENTRY POINTS AND BREAK POINTS FOR ROUTINES THAT
; HAVE BEEN OVERLAYED OR CANCELED. ENTER WITH (T3) = HIGHEST ADDRESS
; KNOWN TO STILL BE PRESENT.
SFOVS: CAML T3, CUREPA ;SEE IF THE CURRENT MODULE
JRST SFOVSB ; WENT AWAY.
HRRZ T4, ETYTAB ;IT DID, MAKE THE MAIN PROGRAM
MOVEM T4, CUREPA ; THE CURRENT MODULE.
HRRZ T4, 1(T4)
HRLI T4, %%NM.(T4)
HRRI T4, BNM
BLT T4, BPR
SFOVSB: MOVE NM, ETYPTS ;GET THE POINTER TO THE ENTRY POINTS.
SKIPN T4, (NM) ;IS THERE ONE THERE?
SFOVSD: AOBJN NM, .-1 ;NO, IF THERE ARE MORE, LOOP.
JUMPGE NM, SFOVSL ;IF THERE ARE NO MORE, GO ON.
CAIL T3, (T4) ;IF THE ENTRY POINT IS ABOVE
JRST SFOVSD ; THE STARTING ADDRESS, DO NOTHING.
SKIPN PTFLG. ;IF WE AREN'T TRACING, GO ON.
JRST SFOVSH
TRNE T5, -1 ;IF THERE IS SOMETHING TO TYPE,
JTYPE ((T5)) ; TYPE IT.
SETZ T5,
HLRZ T4,T4 ;POINT AT THE OVERLAY BLOCK.
MOVE T4,OVNAM(T4) ;GET THE NAME.
PUSH PP,T3 ;SAVE CURRENT T3
PUSHJ PP,SFOVU ;GO TYPE IT OUT.
POP PP,T3 ;RESTORE T3
TYPEC " " ;FOLLOWED BY A SPACE.
SFOVSH: SETZM (NM) ;REMOVE THE ENTRY POINT FROM THE TABLE.
JRST SFOVSD ;GO LOOK FOR MORE.
SFOVSL: MOVEI T4, B1ADR ;POINT AT THE FIRST BREAK POINT.
SFOVSP: SKIPE T1, 0(T4) ;IF THERE ISN'T ANYTHING THERE
CAIL T3, (T1) ; OR IT'S BELOW THE ADDRESS,
JRST SFOVST ; GO LOOK AT THE NEXT ONE.
SETZM (T4) ;OTHERWISE CLEAR THE BP.
SETZM 1(T4)
SETZM 2(T4)
SFOVST: ADDI T4, LBA ;MOVE UP TO THE NEXT ONE.
CAIG T1, BNADR ;IF THERE ARE MOVE,
JRST SFOVSP ; LOOP.
POPJ PP, ;OTHERWISE, RETURN.
;PRINT A SIXBIT WORD. WORD IS IN T4, USES T3.
SFOVU: SETZI T3,
LSHC T3,6
ADDI T3,40
TYPEAC T3
JUMPN T4, SFOVU
POPJ PP,
;ROUTINE TO GET A FEW WORDS OF CORE
;CALL: T1/ # WORDS WE NEED
; PUSHJ PP,GWORDS
; <RETURN .+1> (UNLESS ERROR, THEN IT HALTS THE PROGRAM)
;RETURNS: T3/ ADDR OF START
GWORDS: SKIPN T1 ;IF 0,
MOVEI T1,1 ;MAKE REQUEST FOR 1
SKIPN T3,MYJFF ;SET-UP YET?
JRST GWRD1 ;NO, GO GET PAGES
ADD T3,T1 ;# WORDS WE NEED
CAMLE T3,MYJBRL ;HAVE ENOUGH SPACE?
JRST GWRD1 ;NO, GO GET NEW PAGES
EXCH T3,MYJFF ;RETURN OLD ADDR, SAVE JBFF FOR NEXT TIME
POPJ PP, ;RETURN
;HAVE TO GET SOME WORDS
GWRD1: PUSH PP,T1 ;SAVE # WORDS WE ARE GETTING
IORI T1,777 ;ROUND UP TO NEAREST PAGE
ADDI T1,1
MOVEM T1,FUN.C2 ;STORE ARG2
PUSH PP,16 ;SAVE AC16
MOVEI 16,1+[5,,0
XWD 0,FUN.C0
XWD 0,[ASCIZ/CDB/]
XWD 0,FUN.CS
XWD 0,FUN.C1
XWD 0,FUN.C2]
MOVEI T1,F.PAG ;FUNCTION TO GET CORE AT PAGE BOUNDARY
MOVEM T1,FUN.C0 ;STORE FUNCTION
SETZM FUN.CS ;CLEAR STATUS
SETZM FUN.C1 ;AND ADDRESS RETURNED
PUSHJ PP,FUNCT.## ;CALL FUNCT. ROUTINE..
POP PP,16 ;RESTORE AC16
POP PP,T1 ;RESTORE # WORDS WE GOT
SKIPE FUN.CS ;STATUS MUST BE ZERO
JRST GNXPG1 ;?ERROR
HRRZ T3,FUN.C1 ;GOT IT--GET ADDRESS OF START
MOVEM T3,MYJFF ;COMPUTE NEXT JBFF = START ADDR
ADDM T1,MYJFF ;+ LENGTH OF THIS ENTRY
IORI T1,777 ;STORE A FAKE .JBREL
ADD T1,T3
MOVEM T1,MYJBRL
POPJ PP,
GNXPG1: TYPE [ASCIZ/?Can't get memory for overlay tables
/]
$DIE ;Abort COBDDT
;COME HERE WHEN BREAKING AFTER HAVING BROUGHT A LINK-10 OVERLAY IN.
BROV: ADDM T5,(PP) ;ADJUST THE RETURN ADDRESS.
BROVA: JSR SAVE ;GO SAVE THE WORLD.
SKIPE HFGTHR ;IF WE'RE DOING A HISTOGRAM, GO
PUSHJ PP,HAOVL ; ACCUMULATE STATISTICS.
PUSHJ PP,REMOVB ;REMOVE BREAK POINTS.
TYPE [ASCIZ "Break upon overlay load "] ;[26]
HRL T2,%NM ;SAVE POINTERS
HRRI T2,PNM
BLT T2,PPR
PUSHJ PP,GTTABS ;[26] GET NEW TABLE POINTERS
JRST MODH ;TELL WHAT MODS ARE IN MEMORY (JRSTS TO XECUTX)
;COME HERE TO PROCEED FROM THE ABOVE BREAK.
PROV: SETZM EBRKOV ;DON'T BREAK AGAIN.
PUSHJ PP,INSRTB ;GO INSERT BREAK POINTS.
HRLZI 17,AC0 ;RESTORE THE AC'S.
BLT 17,17
POPJ PP, ;RETURN.
;ROUTINE TO REMOVE ANY BREAKPOINTS FROM LINK-10 OVERLAYS BEFORE THEY
; ARE CANCELED.
;CALLED BY CANCEL JUST BEFORE IT CALLS OVRLAY TO REMOVE THE LINK.
;ENTER WITH (T2) = PTR TO ARG WHCH POINTS TO LINK NUMBER OF LINK TO CANCEL.
;ALL AC'S ARE PRESERVED.
CNTRC.: JSR SVALL ;GO SAVE THE AC'S.
MOVE T2,@(T2) ;GET THE LINK NUMBER.
SKIPE T4,OVLCHS ;POINT AT THE ROOT'S CONTROL SECTION.
CNTRCB: HRRZ T4,CS.PTR(T4) ;POINT AT THE NEXT CONTROL SECTION.
JUMPE T4,CNTRCC ;IF THERE ARE NO MORE LINKS, LEAVE.
HRRZ T5,CS.NUM(T4) ;GET THE LINK'S NUMBER.
CAIE T5,(T2) ;IF THIS ISN'T THE ONE,
JRST CNTRCB ; GO LOOK AT THE NEXT ONE.
PUSH PP,T4 ;SAVE LINK INFO
HRRZ T3,CS.COR(T4) ;GET THE LOWEST ADDRESS IN THE LINK.
MOVEI T5,[ASCIZ / ;PRINT THIS IF TRACING
[Canceled /]
PUSHJ PP,SFOVS ;GO REMOVE ANY BREAK POINTS AND
; ENTRY POINTS IN THE CANCELED
; ROUTINES.
POP PP,T4 ;RESTORE LINK INFO
SKIPE PTFLG. ;IF WE'RE TRACING,
JTYPEC "]" ; TERMINATE THE STRING
SETZM SUBSPR ;ASSUME THAT THERE ARE NO
; SUBROUTINES LEFT.
MOVE NM,ETYPTS ;GET POINTER TO ENTRY POINT TABLE.
AOBJP NM,CNTRCC ;IF THE MAIN ROUTINE IS THE ONLY
; THING THERE, GO ON.
SKIPN (NM) ;LOOK FOR A NON ZERO ENTRY IN
AOBJN NM,.-1 ; THE TABLE.
JUMPGE NM,CNTRCC ;IF WE FOUND ONE, NOTE THAT
SETOM SUBSPR ; THERE ARE SUBROUTINES PRESENT.
CNTRCC: HRLZI 17,AC0 ;RESTORE THE AC'S.
BLT 17,17
POPJ PP, ;RETURN.
;ROUTINE TO SAVE THE AC'S - JSR SVALL -
SVALL: Z
MOVEM 17, AC0+17
HRRZI 17, AC0
BLT 17, AC0+16
MOVE 17, AC0+17
JRST @SVALL
SUBTTL HISTOGRAM FEATURE
;INITIATE A HISTOGRAM.
;HERE WHEN "HISTORY BEGIN" SEEN
HISBEG: SKIPL HFINIT ;IF WE HAVEN'T DONE THE
PUSHJ PP,HISIND ; INITIALIZATION YET, GO DO IT
;START GATHERING STATISITICS.
HISSTE: SETOM HFGTHR ;TURN ON THE GATHER FLAG.
SETOM HFGTST ;TURN ON THE INITIALIZE FLAG.
MOVE T1,[IOWD HPSPLN,HPSPLO] ;SET UP THE PDL.
MOVEM T1,HPSPDL
JRST PRCEDD ;AUTOMATICALY PROCEED.
;HERE WHEN "HISTORY INITIALIZE" SEEN
HISINI: PUSHJ PP,HISIND ;CALL ROUTINE TO SETUP TABLES
JRST XECUTX ;BACK FOR MORE COMMANDS
;SET UP THE TABLES.
HISIND: SKIPE HFTBST ;IF WE HAVE ALREADY SET THEM
JRST HISIRD ; UP, GO CLEAN THEM UP.
;FIGURE OUT HOW MUCH CORE WE NEED, AND GO ASK FOR IT
SETZ T1, ;T1= HOW MANY WORDS WE NEED
MOVE NM,ETYPTS ;SET UP PTR TO ENTRY POINTS
SKIPN T2,(NM) ;IS THERE AN ENTRY POINT THERE?
HISIN2: AOBJN NM,.-1 ;NO, IF THERE ARE MORE, LOOP
JUMPGE NM,HISIN3 ;IF WE ARE DONE, TRY TO GET THE CORE
HRRZ T2,1(T2) ;GET ADDRESS OF %FILES
MOVE T3,%%PR.(T2) ;PROTAB ADDRESS
TLNE T3,-1 ;IF THIS ONE WAS SET UP BEFORE
JRST HISIN2 ; SKIP IT
HLRZ T4,%%DT.(T2) ;LAST LOCATION IN PROTAB.
SUBI T4,(T3) ;SIZE OF PROTAB.
ADD T1,T4 ;THIS IS HOW MANY WORDS WE'LL NEED
AOJA T1,HISIN2 ;+1 AND LOOP
;HERE WITH # WORDS WE NEED FOR THE HISTOGRAM TABLES IN T1
HISIN3: PUSHJ PP,GWORDS ;GET THE WORDS
MOVEM T3,HSTSJF ;STORE ".JBFF"
MOVEI T5,HSTSJF ;T5:= ADDRESS OF ".JBFF"
HISINF: MOVE NM,ETYPTS ;SET UP THE POINTER TO THE ENTRY POINTS.
SKIPN T2,(NM) ;IS THERE AN ENTRY POINT THERE?
HISINH: AOBJN NM,.-1 ;NO, IF THERE ARE MORE, LOOP.
JUMPGE NM,HISINX ;IF WE'RE DONE, GO CLEAR THE TABLES.
HRRZ T2,1(T2) ;ADDRESS OF %FILES.
MOVE T1,%%PR.(T2) ;PROTAB ADDR.
TLNE T1,-1 ;IF THIS ONE WAS SET UP BEFORE
JRST HISINH ; GO DO THE NEXT ONE.
HLRZ T3,%%DT.(T2) ;LAST LOCATION IN PROTAB.
SUBI T3,(T1) ;SIZE OF PROTAB.
HRRZ T1,HSTSJF ;HISTAB ADDRESS.
ADDI T3,(T1) ;LAST LOCATION IN HISTAB.
JRST HISINV ;GO ON
HISINV: HRLM T1,%%PR.(T2) ;SAVE HISTAB ADDR.
HRRI T3,1(T3) ;FORM NEW .JBFF.
HRRM T3,HSTSJF ;SAVE IT.
JRST HISINH ;GO DO THE NEXT TABLE.
;HERE WHEN ALL THE TABLES HAVE BEEN ALLOCATED.
HISINX: HRRZ T1,%PR ;GET CURRENT PR AND GO PUT THE
PUSHJ PP,HISIT ; HISTOGRAM TABLE IN IT.
HRRZI T1,PPR ;DITTO FOR THE RUN PR.
PUSHJ PP,HISIT
HRRZI T1,BPR ;AND THE BREAK PR.
PUSHJ PP,HISIT
;NOW GO PUT THE HISTAB ADDRESSES IN ANY SAVED %PR'S.
MOVE NM,ETYPTS ;GET THE POINTER TO THE ENTRY POINTS.
SKIPN T2,(NM) ;IS THERE AN ENTRY POINT THERE?
HISIPD: AOBJN NM,.-1 ;NO, IF THERE ARE MORE LOOP.
JUMPGE NM,HISIPE ;IF THAT'S ALL GO ON.
PUSH PP,NM ;SAVE THE POINTER.
MOVE T2,1(T2) ;ADDRESS OF %FILES.
LDB T1,[POINT 12,%COBVR(T2),17]
SKIPE C74FLG ;IN COBOL-68
CAIGE T1,1202 ;OR IN COBOL-74 PRIOR TO 12B
JRST [MOVEI T1,FIXNMA+%%PR.(T2) ;ADDRESS OF SAVED PROTAB POINTER.
JRST .+2] ;FIXNUM IS REALLY ONE LESS (NO %DB.)
MOVEI T1,FIXNUM+%%PR.(T2) ;ADDRESS OF SAVED PROTAB POINTER.
PUSHJ PP,HISIT ;GO CHECK IT OUT.
POP PP,NM ;RESTORE THE ENTRY POINT POINTER.
JRST HISIPD ;AND LOOP.
;NOW PUT THE HISTOGRAM TABLE ADDRESSES IN ANY LINK-10 OVERLAY BLOCKS.
HISIPE: MOVEI T4,OVRLHD ;GET THE ADDR OF THE LIST HEADER.
HISIPF: SKIPN T4,(T4) ;ARE THERE MORE?
JRST HISIPH ;NO, GO ON.
MOVEI T1,OV%PR(T4) ;POINT AT THE PROTAB WORD.
PUSHJ PP,HISIT ;GO PUT THE HISTAB ADDR IN IT.
JRST HISIPF ;GO LOOK FOR MORE.
;PUT HISTOGRAM TABLE ADDRESS IN THE LOCATION WHOSE ADDRESS IS IN T1.
HISIT: MOVE T3,(T1) ;GET THE PROTAB ADDR.
TRNE T3,-1 ;IF THERE IS NO PROTAB ADDR
TLNE T3,-1 ; OR HISTAB IS ALREADY SET UP,
POPJ PP, ; FORGET IT.
MOVE NM,ETYPTS ;SET UP THE POINTER TO THE ENTRY POINTS.
SKIPN T2,(NM) ;IS THERE AN ENTRY POINT THERE.
HISITD: AOBJN NM,.-1 ;NO, IF THERE ARE MORE LOOP.
JUMPGE NM,CPOPJ ;MUST BE A LINK-10 OVERLAY THAT
; WENT AWAY.
HRRZ T2,1(T2) ;ADDRESS OF %FILES.
MOVE T2,%%PR.(T2) ;HISTAB ADDR,,PROTAB ADDR
CAIE T3,(T2) ;IS THIS THE ONE?
JRST HISITD ;NO, GO LOOK AT THE NEXT ONE.
HLLM T2,(T1) ;YES, STASH THE HISTAB ADDR.
POPJ PP, ;RETURN.
HISIPH: SETOM HFTBST ;REMEMBER THAT WE HAVE SET UP
; THE TABLES.
;ZERO OUT ALL OF THE TABLES.
HISIRD: MOVE NM,ETYPTS ;SET UP THE POINTER TO THE ENTRY POINTS.
SKIPN T2,(NM) ;IS THERE AN ENTRY POINT THERE?
HISIRH: AOBJN NM,.-1 ;NO, IF THERE ARE MORE LOOP.
JUMPGE NM,HISIRI ;IF WE'RE DONE, GO ON.
HRRZ T2,1(T2) ;ADDRESS OF %FILES.
PUSHJ PP,HISIRP ;GO ZAP THE TABLE.
JRST HISIRH ;GO DO THE NEXT TABLE.
;CLEAR LINK-10 OVERLAY MODULE'S TABLES IN CASE THE MODULE ITSELF ISN'T
; CURRENTLY IN CORE.
HISIRI: SKIPN T4,OVRLHD ;IF THERE AREN'T ANY LINK-10
JRST HISIRL ; OVERLAYS GO ON.
HISIRJ: MOVEI T2,OV%PR-%%PR.(T4) ;POINT AT WHERE %FILES WOULD BE.
PUSHJ PP,HISIRP ;GO ZAP THE TABLE.
SKIPE T4,(T4) ;IF THERE ARE MORE,
JRST HISIRJ ; LOOP.
HISIRL: SETZM HOVCPU ;CLEAR THE OVERHEAD AND
MOVE T2,[XWD HOVCPU,HOVCPU+1] ;ELAPSED TIMES.
BLT T2,HUNELP
SETOM HFINIT ;REMEMBER THAT AN INITIALIZATION
; WAS DONE.
POPJ PP, ;RETURN.
;ROUTINE TO ZAP A HISTAB TABLE.
; ENTER WITH THE ADDR OF %FILES IN T2.
HISIRP: MOVE T1,%%PR.(T2) ;HISTOGRAM TABLE ADDRESS,,PROTAB ADDRESS.
TLNN T1,-1 ;IS THERE A TABLE THERE?
POPJ PP, ;NO, LEAVE.
HLRZ T2,%%DT.(T2) ;LAST LOCATION IN PROTAB.
SUBI T2,(T1) ;GET SIZE OF PROTAB.
HLR T1,T1 ;FORM WORD FOR BLT.
ADDI T1,1
SETZM -1(T1) ;ZERO THE FIRST WORD.
ADDI T2,-1(T1) ;LAST LOCATION IN HISTAB.
BLT T1,(T2) ;ZAP.
POPJ PP, ;RETURN.
;STOP GATHERING STATISTICS.
;HERE WHEN "HISTORY END" SEEN
HISSTO: SETZM HFGTHR ;TURN OFF THE GATHER FLAG.
JRST XECUTX
;COME HERE WHEN THE PROGRAM TERMINATES TO PRINT THE REPORT, IF NECESSARY.
HSRPT.: AOSN HFGTST ;DO WE HAVE STATISTICS THAT
; WANT TO BE PRINTED.
JRST HSRPTX ;NO, RETURN.
;Wait a second. Consider the following:
; Pgm gets error in RESET. code. HFGTST was 0, so the AOSN above skips.
SKIPN DNRSTT ;Are we done RESET.?
POPJ PP, ;No, error in RESET. code, don't
; do a report.
PUSHJ PP,HISREB ;GO PRINT THE REPORT
IFN TOPS20,<
MOVE T1,HSTJFN ;RELEASE THE JFN
RLJFN%
ERJMP .+1 ;IGNORE ERRORS
SETZM HSTJFN ;CLEAR JFN
>;END IFN TOPS20
HSRPTX: SETOM DIED. ;SO ^C^C REENTER WILL WORK
SETOM HFGTST ;NOTE THAT WE HAVE PRINTED THE REPORT
; (INCASE HE REENTERS AND DOES "STOP")
POPJ PP, ;RETURN
;PRINT THE REPORT.
;HERE FOR "HISTORY REPORT" COMMAND EXECUTION
HISREP: SKIPN HFINIT ;IF AN INITIALIZATION OR A BEGIN
; WASN'T DONE, COMPLAIN.
JRST [ TYPE [ASCIZ /
?History not initialized./]
JRST XECUTC]
PUSHJ PP,HISREB ;GO PRINT THE REPORT.
SETOM HFGTST ;NOTE THAT WE HAVE PRINTED THE
; REPORT.
JRST XECUTX ;GO SEE IF THERE ARE MORE COMMANDS.
;CALLED BY A PUSHJ SO WE CAN CALL IT IF THE PROGRAM TERMINATES WITHOUT
; PRINTING THE REPORT.
HISREB: MOVEM PP,HSTPDL ;SAVE THE PDL IN CASE WE HAVE
; AN ERROR.
PUSHJ PP,HISSIO ;GO SET UP THE I/O ROUTINES.
AOS T5,HSTRPN ;BUMP THE REPORT NUMBER.
TYPE ([ASCIZ /
[REPORT: /]) ;AND TYPE IT OUT.
PUSHJ PP, PRNUM
TYPEC "]"
TYPE CRLF
MOVEM 17,HSTACS+17 ;SAVE THE AC'S.
HRRZI 17,HSTACS
BLT 17,HSTACS+16
MOVE 17,HSTACS+17
MOVE NM,ETYPTS ;SET UP THE POINTER TO THE
; ENTRY POINTS.
HISRED: SKIPE P1,(NM) ;IS THERE ONE THERE?
PUSHJ PP,HISPRP ;YES, GO PRINT A PAGE.
AOBJN NM,HISRED ;IF THERE ARE MORE MODULES, LOOP.
;PRINT OUT THE OVERHEAD FOR PERFORMS AND SUBROUTINE CALLS.
SKIPN T1,HOVELP ;IF THERE WASN'T ANY FORGET IT.
JRST HISREF
PUSH PP,T1 ;SAVE VALUE
MOVEI T1,[ASCIZ /
OVERHEAD: ELAPSED: /]
PUSHJ PP,HISPST
POP PP,T1 ;GET TIME TO PRINT
PUSHJ PP,HSPRTM
MOVEI T1,[ASCIZ / CPU: /]
PUSHJ PP,HISPST
MOVE T1,HOVCPU
PUSHJ PP,HSPRTM
;PRINT OUT THE UNACCOUNTABLE TIME.
HISREF: SKIPN HUNELP ;IF THERE WASN'T ANY FORGET IT.
JRST HISREG
MOVEI T1,[ASCIZ /
UNACCOUNTED: ELAPSED: /]
PUSHJ PP,HISPST
MOVE T1,HUNELP
PUSHJ PP,HSPRTM
MOVEI T1,[ASCIZ / CPU: /]
PUSHJ PP,HISPST
MOVE T1,HUNCPU
PUSHJ PP,HSPRTM
HISREG: PUSHJ PP,HISPEL ;PRINT A CRLF
HISREH: HRLZI 17,HSTACS ;RESTORE THE AC'S.
BLT 17,17
HISREL: PUSHJ PP,HISCLO ;GO CLOSE THE CHANNEL, RETURN IT
; AND RETURN THE CORE.
MOVE PP,HSTPDL ;RESTORE THE PDL.
POPJ PP, ;RETURN.
;ROUTINE TO PRINT THE STATISTICS FOR ONE MODULE.
HISPRP: MOVEI T1,[ASCIZ /
COBDDT histogram for /]
PUSHJ PP,HISPST
MOVE T4,-1(P1) ;PRINT THE MODULE'S NAME.
HSPRPD: SETZI T3,
LSHC T3,6
JUMPE T3,HSPRPH
MOVEI CH,40(T3)
PUSHJ PP,HISPCH
JRST HSPRPD
HSPRPH: MOVEI CH,.CHTAB
MOVEI T5,4 ;OUTPUT FOUR TABS
PUSHJ PP,HISPCH
SOJG T5,.-1
MOVEI T1,[ASCIZ /REPORT: /]
PUSHJ PP,HISPST
MOVE T2,HSTRPN
PUSHJ PP,HISPDC ;PRINT THE NUMBER IN T2
PUSHJ PP,HISPEL ;PRINT CRLF
LDB T5,[POINT 7,HSTTTL,6]
JUMPE T5,HSPRPJ ;JUMP IF NO TITLE
MOVEI T1,HSTTTL ;POINT TO ADDRESS OF ASCIZ TITLE
PUSHJ PP,HISPST
PUSHJ PP,HISPEL ;CRLF
HSPRPJ: MOVEI T1,[ASCIZ /
PROCEDURE ENTRIES CPU ELAPSED
/]
PUSHJ PP,HISPST
SETZI CH, ;REMEMBER THAT WE HAVE JUST PRINTED THE HEADING.
HRRZ P1,1(P1) ;ADDRESS OF %FILES
MOVE T1,%%PR.(P1) ;HISTOGRAM TABLE ADDR,,PROTAB ADDR.
TRNE T1,-1 ;[26] IS PROTAB ADDRESS 0?
JRST HSPRPK ;[26]
MOVEI T1,[ASCIZ /(no symbols for this module)
/] ;[26]
JRST HISPST ;[26]
;HERE WITH RH(T1) = PROTAB ADDRESS
HSPRPK: AOBJN T1,.+1 ;SKIP THE ZERO WORDS.
HLLZ T3,%%DT.(P1) ;LAST LOCATION IN PROTAB.
HRRZ P1,%%NM.(P1) ;NAMTAB ADDR.
ADD P1,[POINT 6,1] ;POINTER TO TEXT.
MOVSS T1 ;PROTAB ADDR,,HISTOGRAM TABLE ADDR.
HSPRPL: SKIPN P2,(T1) ;IF THERE IS NO TIME FOR THIS
SKIPE 2(T1) ; PROCEDURE AND IT WAS NEVER
TRNA ; ENTERED, GO ON TO THE
JRST HSPRPX ; NEXT ONE.
MOVEM T3,SVT3 ;SAVE T3
MOVSS T1 ;POINT AT PROTAB
LDB T2,[POINT 15,(T1),17] ;GET THE NAMTAB LINK.
ADD T2,P1 ;POINT AT THE NAME.
HRREI T3,-^D32 ;SET THE POSITION COUNT.
MOVE T4,PR.FLG(T1) ;IF THIS IS A PARAGRAPH,
TRNE T4,PR%SEC ; INDENT A SPACE. IF IT'S
JRST [MOVEI CH," " ; A SECTION AND WE HAVE
JRST HSPRPR] ; NOT JUST PRINTED THE HEADING
PUSHJ PP,HISPCH ; SKIP A LINE.
HSPRPP: ILDB CH,T2 ;GET A CHAR.
TRNN CH,60 ;IS THIS THE END?
JRST HSPRPT ;YES, GO ON.
CAIN CH,':' ;REPLACE COLONS BY HYPHENS.
MOVEI CH,'-'
CAIN CH,';' ; AND SEMICOLONS BY PERIODS.
MOVEI CH,'.'
ADDI CH,40 ;MAKE IT ASCII.
HSPRPR: PUSHJ PP,HISPCH ;PRINT IT.
AOJA T3,HSPRPP ;BUMP POSITION AND LOOP.
HSPRPT: MOVEI CH," " ;PADD WITH BLANKS UNTIL
PUSHJ PP,HISPCH ; WE ARE AT COLUMN 33.
AOJL T3,.-1
MOVE T4,P2 ;# OF TIMES ROUTINE WAS ENTERED
HSPRTV: IDIVI T4,^D10 ;PRINT THE NUMBER OF TIMES
PUSH PP,T5 ; THIS ROUTINE WAS ENTERED
SKIPE T4 ;RIGHT JUSTIFIED IN AN
SOJA T3,HSPRTV ; 11 CHAR FIELD.
HRREI T4,^D10(T3)
PUSHJ PP,HISPCH
SOJG T4,.-1
HSPRTW: POP PP,CH
TRO CH,60
PUSHJ PP,HISPCH
AOJLE T3,HSPRTW
MOVSS T1 ;POINT AT THE HISTOGRAM TABLE AGAIN.
PUSH PP,T1
MOVE T1,1(T1) ;GET THE CPU TIME FOR THE
PUSHJ PP,HSPRTM ; PARAGRAPH AND GO PRINT IT.
MOVE T1,(PP)
MOVE T1,2(T1) ;GET THE ELAPSED TIME FOR THE
PUSHJ PP,HSPRTM ; PARAGRAPH AND GO PRINT IT.
PUSHJ PP,HISPEL ;PRINT A <CR><LF>
POP PP,T1
MOVE T3,SVT3 ;RESTORE SAVED T3
HSPRPX: ADD T1,[SZ.PR6,,SZ.PR6] ;BUMP UP TO THE NEXT ENTRY.
CAMLE T3,T1 ;ARE WE PAST THE END?
JRST HSPRPL ;NO, GO LOOK AT THIS ENTRY.
POPJ PP, ;DONE WITH THIS TABLE, RETURN.
;ROUTINE TO PRINT A TIME AS HH:MM:SS.TTT, WITH LEADING ZEROS SUPPRESSED.
HSPRTM: MOVEI CH," " ;THROW OUT A COUPLE SPACES.
PUSHJ PP,HISPCH
PUSHJ PP,HISPCH
IDIVI T1,^D1000 ;GET FRACTIONAL SECONDS.
PUSH PP,T2 ;SAVE THEM.
IDIVI T1,^D60 ;GET SECONDS.
PUSH PP,T2
IDIVI T1,^D60 ;MINUTES AND HOURS.
PUSH PP,T2
SETZI T5, ;SET THE NO SIGINFICANCE FLAG.
PUSHJ PP,HSPRTU ;GO PRINT HOURS.
POP PP,T1 ;GET MINUTES BACK.
PUSHJ PP,HSPRTU ;GO PRINT THEM.
POP PP,T1 ;GET SECONDS BACK.
IDIVI T1,^D10
TRON T5,-1 ;TURN ON SIGNIFICANCE AND GO
TRNE T1,-1 ; PRINT A DIGIT OR A SPACE.
MOVEI CH,60(T1)
PUSHJ PP,HISPCH
PUSHJ PP,HSPRTR ;GO PRINT DIGITS POSITION.
MOVEI CH,"." ;PRINT THE DECIMAL POINT.
PUSHJ PP,HISPCH
POP PP,T1 ;GET FRACTIONAL SECONDS.
IDIVI T1,^D100
PUSHJ PP,HSPRTT
MOVEI T1,(T2)
HSPRTO: IDIVI T1,^D10
PUSHJ PP,HSPRTS
HSPRTR: MOVEI T1,(T2)
HSPRTS: TRNE T1,-1
TROA T5,-1
TRNE T5,-1
HSPRTT: MOVEI CH,60(T1)
JRST HISPCH
HSPRTU: PUSHJ PP,HSPRTO
TRNE T5,-1
MOVEI CH,":"
JRST HISPCH
;PRINT A <CR><LF>
HISPEL: MOVEI CH,15
PUSHJ PP,HISPCH
MOVEI CH,12
JRST HISPCH
;PRINT THE ASCIZ STRING WHOSE ADDRESS IS IN RH T1.
HISPST: HRLI T1,(<POINT 7,0>)
HPSTRD: ILDB CH,T1
JUMPE CH,CPOPJ
PUSHJ PP,HISPCH
JRST HPSTRD
;PRINT THE DECIMAL NUMBER IN T2.
HISPDC: IDIVI T2,^D10
HRLM T3,(PP)
SKIPE T2
PUSHJ PP,HISPDC
HLR CH,(PP)
TRO CH,60
JRST HISPCH
SUBTTL HISTOGRAM I/O ROUTINES.
;SET UP FOR OUTPUT.
IFE TOPS20,<
HISSIO: SKIPN T2,HSTDEV ;MAKE SURE WE HAVE A DEVICE
MOVSI T2,'TTY' ;NO, DEFAULT TO TTY
MOVEM T2,HSTDEV
SKIPE M7FLG ;7 SERIES MONITOR?
JRST [MOVE T2,[%CNHXC] ;GETTAB FOR NO. OF EXTENDED CHANS
GETTAB T2, ;DO WE ACTUALLY HAVE ANY?
JRST .+1 ;NONE IF NOT IMPLEMENTED
JUMPE T2,.+1 ;NO, USE OLD METHOD
MOVX T2,FO.ASC ;YES, USE EXTENDED CHANNEL
JRST HISEXC]
MOVEI T2,F.GCH ;CALL FUNCT. TO GET
MOVEM T2,HSTFFN ; A CHANNEL.
MOVEI P2,HSTFFB
PUSHJ PP,FUNCT.##
SKIPE HSTFST ;IF WE DIDN'T GET ONE, COMPLAIN.
HISNCH: JRST [TYPE [ASCIZ /
?Can't find a free channel for history report./]
JRST XECUTC]
HRLZ T2,HSTFCH ;GET THE CHANNEL NUMBER.
HISEXC: TXO T2,FO.PRV ;ALLOW EXTRA PRIVS IF [1,2] OR JACCT
MOVEM T2,HSTFB. ;STORE IN FILOP. BLOCK
MOVS T2,T2
DPB T2,[POINT 4,HISOUT,12] ;PUT IT IN OUTPUT IN CASE PRE-7 SERIES
DPB T2,[POINT 4,HISGST,12] ;SAME FOR GETSTS
;GET SPACE FOR DOUBLE BUFFER FOR HISTOGRAM DEVICE
MOVEI T2,HSTIOS
DEVSIZ T2,
JRST HISER0 ;FAILED
HRRZ T2,T2 ;SIZE ONLY
LSH T2,1 ;DOUBLE BUFFERS
MOVEM T2,HSTSIZ ;SAVE SIZE
MOVEI T2,F.GOT
MOVEM T2,HSTFFN
MOVEI P2,HSTFFC ;ARG FOR FUNCT.
PUSHJ PP,FUNCT.
SKIPE HSTFST ;CHECK STATUS
JRST HISER0 ;NOT ENUF CORE
;DO FILOP. TO APPEND TO FILE, WILL CREATE A NEW ONE IF NO OLD.
PUSH PP,.JBFF ;SAVE OTS VALUE
MOVE T2,HSTADR ;GET WHERE BUFFER WILL GO
MOVEM T2,.JBFF ;IF FILOP. SUCCEEDS
MOVEI T2,.FOAPP ;APPEND FUNCTION
HRRM T2,HSTFNC
MOVE T2,[6,,HSTFB.]
FILOP. T2,
JRST HISER1 ;FAILED, COMPLAIN.
POP PP,.JBFF ;GIVE IT BACK TO OTS
JRST HISOPT ;DO AN OUT TO ESTABLISH THE BUFFERS.
HISER0: PTYPE [ASCIZ /
?Not enough memory for history report buffers./]
JRST XECUTC
HISER1: PTYPE [ASCIZ /
?FILOP. append failure for /]
PUSHJ PP,HISPFN
JRST HISREL
>;END TOPS-10 CODE
IFN TOPS20,<
HISSIO: SKIPE HSTJFN ;GOT A JFN?
JRST GOTHJF ;YES, USE IT
MOVX T1,GJ%SHT
HRROI T2,[ASCIZ /TTY:/]
GTJFN%
HALT ;?CAN'T OPEN TTY:!
MOVEM T1,HSTJFN ;SAVE THE JFN
GOTHJF: MOVE T1,HSTJFN ;GET JFN TO OPEN
MOVX T2,7B5+OF%APP ;READY TO APPEND TO FILE
OPENF% ;OPEN FOR APPEND..
ERJMP HSTNFF ;?CAN'T OPEN FOR APPEND!
POPJ PP,
HSTNFF: TYPE [ASCIZ/?Can't open histogram file for append: /]
JRST LSTFRC ;TYPE WHY & RETURN
>;END TOPS20 CODE
;OUTPUT THE CHARACTER IN CH.
IFN TOPS20,<
HISPCH: DMOVEM T1,JSSSV1 ;SAVE T1,T2
MOVE T1,HSTJFN ;GET JFN
MOVE T2,CH ;GET BYTE
BOUT% ;WRITE TO FILE
ERJMP HISPER ;OUTPUT ERROR
DMOVE T1,JSSSV1 ;RESTORE ACS
POPJ PP, ;RETURN
HISPER: TYPE [ASCIZ/?Output failed for histogram file: /]
PUSHJ PP,LSTFRC ;TYPE WHY
JRST HISREH ;RESTORE ACS AND POPJ
>;END IFN TOPS20
IFE TOPS20,<
HISPCH: SOSG HSTOBF+2
JRST HISOPT
HISPCM: IDPB CH,HSTOBF+1
POPJ PP,
HISOPT: SKIPE M7FLG ;7 SERIES?
JRST HISOPF ;YES, USE FILOP.
XCT HISOUT ;OUT UUO
JRST HISPCM
XCT HISGST ;GETSTS
HISER2: PUSH PP,T2 ;SAVE STATUS
TYPE [ASCIZ /
?Output error on /]
PUSHJ PP,HISPFN
TYPE [ASCIZ / status (/]
HRLZI T2,(T2)
PUSHJ PP,PROCTD
TYPEC ")"
JRST HISREH ;GO RESTORE EVERYTHING AND
; RETURN TO COMMAND INTREPRETER.
HISOPF: PUSH PP,T2 ;NEED A FREE ACC
MOVEI T2,.FOOUT ;OUTPUT FUNCTION
HRRM T2,HSTFNC
MOVE T2,[1,,HSTFB.]
FILOP. T2,
JRST HISER2 ;FAILED, COMPLAIN.
POP PP,T2
JRST HISPCM
>
;ROUTINE TO CLEAN UP AFTER THE REPORT.
IFE TOPS20,<
HISCLO: MOVEI T2,.FOCLS ;CLOSE FUNCTION
HRRM T2,HSTFNC
MOVE T2,[6,,HSTFB.]
FILOP. T2,
JRST HISER3 ;FAILED, COMPLAIN.
MOVEI T2,F.ROT ;CALL FUNCT. TO RETURN
MOVEM T2,HSTFFN ; THE BUFFER AREA
MOVEI P2,HSTFFC
PUSHJ PP,FUNCT.
SKIPE M7FLG ;IF 7 SERIES
POPJ PP, ;WE'RE DONE
MOVEI T2,F.RCH ;CALL FUNCT. TO RETURN
MOVEM T2,HSTFFN ; THE CHANNEL
MOVEI P2,HSTFFB
JRST FUNCT.##
HISER3: PTYPE [ASCIZ /
?CLOSE failed for /]
PUSHJ PP,HISPFN
JRST HISREL
>
IFN TOPS20,<
HISCLO: HRRZ T1,HSTJFN
TXO T1,CO%NRJ ;DON'T RELEASE THE JFN
CLOSF%
ERJMP .+2 ;SKIP IF CLOSF FAILED
POPJ PP,
TYPE [ASCIZ/?Can't close histogram file: /]
JRST LSTFRC ;TYPE WHY AND RETURN
>
;ROUTINE TO TYPE OUT THE FILE SPEC.
IFE TOPS20,<
HISPFN: MOVE T2,HSTDEV
PUSHJ PP,SIXSIX
SKIPN T2,HSTNAM
POPJ PP,
TYPEC ":"
PUSHJ PP,SIXSIX
TYPEC "."
SKIPE T2,HSTEXT
PUSHJ PP,SIXSIX
SKIPN T2,HSTPP
POPJ PP,
TYPEC "["
HLRZ T2,HSTPP ;SEE IF SFD
JUMPE T2,HISPSF
PUSHJ PP,PROCT
TYPEC ","
HRRZ T2,HSTPP
PUSHJ PP,PROCT
TYPEC "]"
POPJ PP,
HISPSF: HLRZ T2,HSTPPN
PUSHJ PP,PROCT
TYPEC ","
HRRZ T2,HSTPPN
PUSHJ PP,PROCT
MOVSI T3,-5 ;MAX SFD
HISPSL: SKIPN T2,HSTSFD(T3)
JRST HISPSE ;FINISH
TYPEC ","
PUSHJ PP,SIXSIX
AOBJN T3,HISPSL ;LOOP
HISPSE: TYPEC "]"
POPJ PP,
>;END IFE TOPS20
;PARAGRAPHS AND SECTIONS COME HERE.
; ENTER WITH T1 CONTAINING THE PROTAB LINK.
HAPS: PUSHJ PP,HACAPS ;GO INITIALIZE.
HRLI T1,(T1) ;FORM HISTAB ADDR,, PROTAB ADDR.
ADD T1,@%PR
HLRZ T3,T1 ;GET THE HISTAB ADDR.
AOS (T3) ;BUMP NUMBER OF TIMES ENTERED.
MOVE T3,PR.FLG(T1) ;GET THE PROTAB FLAGS.
TRNN T3,PR%SEC ;IF IT'S A SECTION,
JRST HAPSD ; GO ON.
; IT'S A PARAGRAPH.
LDB T3,[POINT 15,1(T1),17] ;GET THE SECTION LINK.
HLR T1,@%PR ;GET HISTAB ADDR.
ADDI T1,(T3) ;FORM NEW SECTION'S HISTAB ADDR.
MOVEM T1,HCURPS ;SAVE PARAGRAPH/SECTION.
TRNA
; IT'S A SECTION.
HAPSD: HLRZM T1,HCURPS ;SAVE NEW SECTION AND CLEAR OLD PARAGRAPH.
; REINITIALIZE THE TIMES.
HARAR:
IFE TOPS20,<
MSTIME T1,
MOVEM T1,HSTELP
SETZI T2,
RUNTIM T2,
MOVEM T2,HSTCPU
>
IFN TOPS20,<
MOVEI T1,-5 ;TIMES FOR ENTIRE JOB
RUNTM%
MOVEM T1,HSTCPU
MOVEM T3,HSTELP
>
; RESTORE AC'S AND RETURN.
HARAV: MOVE T4,[XWD HSTACS,T1]
BLT T4,T4
POPJ PP,
;COME HERE ON A BREAKPOINT TO UPDATE THE CURRENT PARAGRAPH/SECTION.
HABP: PUSHJ PP, HACAPS ;GO INITIALIZE.
JRST HARAV ;GO RESTORE AC'S AND RETURN.
;PERFORMS COME HERE.
HAPFS: PUSHJ PP, HACAPS ;GO INITIALIZE.
JSR HPFEP ;GO SAVE CURRENT PARAGRAPH/SECTION.
MOVEI T2, HOVRHD ;CHARGE TIME TO OVERHEAD UNTIL
MOVEM T2, HCURPS ; WE SEE A PARAGRAPH OR SECTION.
JRST HARAR ;GO RESTORE AC'S AND RETURN.
;ENTRY POINTS COME HERE.
HAEPS: PUSHJ PP, HACAPS ;GO INITIALIZE.
JSR HPFEP ;GO SAVE CURRENT PARAGRAPH/SECTION.
JRST HAEXSD ;GO CHARGE TIME TO UNACCOUNTABLE
; UNTIL WE SEE A PARAGRAPH OR
; SECTION.
HPFEP: Z
MOVE T1, HCURPS ;GET CURRENT PARAGRAPH/SECTION.
CAIN T1, HOVRHD ;IF WE'RE CHARGING THIS TIME TO
JRST HARAR ; OVERHEAD, DON'T SAVE ANYTHING.
MOVE T2, HPSPDL ;GET THE PUSH DOWN POINTER.
AOBJP T2, .+2 ;IF THERE IS ROOM FOR THIS
MOVEM T1, (T2) ; PARAGRAPH/SECTION, SAVE IT.
MOVEM T2, HPSPDL ;SAVE PUSH DOWN POINTER.
JRST @HPFEP ;RETURN.
;EXITS, EXIT PROGRAMS AND GOBACKS COME HERE.
HAGBS:
HAEXS: PUSHJ PP, HACAPS ;GO INITIALIZE.
MOVE T2, HPSPDL ;GET PUSH DOWN POINTER.
JUMPL T2, HAEXSH ;IF WE SAVED SOMETHING, GO ON.
SUB T2, [XWD 1,1] ;DECREMENT THE POINTER, BUT DON'T
HAEXSB: MOVEM T2, HPSPDL ; TRY TO RESTORE ANYTHING.
HAEXSD: MOVEI T2, HUNATD ;CHARGE TIME TO UNACCOUNTABLE
MOVEM T2, HCURPS ; UNTIL WE SEE A PARAGRAPH OR
; SECTION.
JRST HARAR ;GO RESTORE AC'S AND RETURN.
HAEXSH: CAMN T2, [IOWD HPSPLN,HPSPLO] ;IF WE HAVE NOTHING
JRST HAEXSD ; TO RESTORE GO CHARGE
; THIS TIME TO UNACCOUNTABLE.
HAEXSL: POP T2, HCURPS ;RESTORE OLD PARAGRAPH/SECTION.
MOVEM T2, HPSPDL ;SAVE THE POINTER.
JRST HARAR ;GO RESTORE THE AC'S AND RETURN.
;COME HERE BEFORE PROCESSING OVERLAYS.
HAOVL: PUSHJ PP,HACAPS ;GO INITIALIZE.
MOVEI T2,HOVRHD ; CHARGE TIME TO OVERHEAD UNTIL
MOVEM T2,HCURPS ; WE SEE A PARAGRAPH OR SECTION.
JRST HARAR ;GO RESTORE AC'S AND RETURN.
;INITIALIZATION ROUTINE.
; SAVE SOME AC'S AND IF THIS IS THE FIRST TIME WE HAVE BEEN
; CALLED SINCE THE BEGIN WAS DONE SET UP THE INITIAL TIMES OTHERWISE
; INCREMENT THE TIMES FOR THE CURRENT PARAGRAPH/SECTION.
HACAPS:
IFE BIS,<
MOVEM T1,HSTACS
MOVEM T2,HSTACS+1
MOVEM T3,HSTACS+2
MOVEM T4,HSTACS+3
>
IFN BIS,<
DMOVEM T1,HSTACS
DMOVEM T3,HSTACS+2
>
IFE TOPS20,<
MSTIME T1,
SETZI T2,
RUNTIM T2,
>
IFN TOPS20,<
MOVEI T1,-5 ;TIMES FOR ENTIRE JOB
RUNTM%
MOVE T2,T1 ;RUNTIME IN T2
MOVE T1,T3 ;ELAPSED IN T1
>
AOSN HFGTST ;IF THIS IS THE FIRST TIME WE
JRST HACAPU ; HAVE BEEN CALLED, GO SET UP
; THE INITIAL TIMES.
;INCREMENT THE CURRENT PARAGRAPH/SECTION'S TIMES.
MOVE T3,HCURPS ;GET THE HISTAB ADDRESSES.
HLRZ T4,T3 ;T3 HAS THE SECTION.
;T4 HAS THE PARAGRAPH.
SUB T2,HSTCPU
ADDM T2,HSTCPU
ADDM T2,1(T3)
TRNE T4,-1
ADDM T2,1(T4)
SUB T1,HSTELP
ADDM T1,HSTELP
CAMGE T1,T2 ;IF THE ELAPSED TIME IS LESS
MOVE T1,T2 ; THAN THE CPU TIME, USE THE
; CPU TIME AS ELAPSED TIME.
; THIS HACK IS NECESSARY
; BECAUSE SYSTEMS WITH REAL
; TIME CLOCKS GET CPU TIME IN
; MS BUT ROUND MSTIME OFF TO
; THE NEAREST 16 MS.
ADDM T1,2(T3)
TRNE T4,-1
ADDM T1,2(T4)
HACAPT: MOVE T1,HSTACS
POPJ PP,
;THIS IS THE FIRST TIME WE HAVE BEEN CALLED SINCE THE BEGIN WAS DONE.
HACAPU: MOVEM T2,HSTCPU
MOVEM T1,HSTELP
MOVEI T2,HOVRHD ;CHARGE TIME TO OVERHEAD UNTIL
MOVEM T2,HCURPS ; WE SEE A PARAGRAPH OR SECTION.
JRST HACAPT ;GO RESTORE T1 AND RETURN.
;PRINT A SIXBIT WORD
;WORD IS IN T2, USES T1.
;ENTERED WITH PUSHJ PP,SIXSIX
SIXSIX: MOVEI T1,0
LSHC T1,6
ADDI T1,40
TYPEAC T1
JUMPN T2,SIXSIX
POPJ PP,
;ROUTINE TO SETUP DT AND W2 AFTER A NAME HAS BEEN PARSED.
; IF THE PARSE ROUTINES RETURNED 0 BECAUSE CRLF WAS TYPED,
; THE SAVED DATANAME (IF ANY) IS USED. IF A REAL DATANAME
; WAS STORED, IT IS USED FOR THIS COMMAND TOO (WITH IT'S
; SUBSCRIPTS, TOO!).
;THIS COMMAND RETURNS .+1 IF SUCCESS, ELSE JUST GOES BACK
;TO COMMAND SCANNER AND TYPES "?No last dataname"
GDTW2: JUMPE DT,[MOVE DT,LAST. ;GET LAST NAME
JUMPE DT,NOLAST ;WAS THERE ONE?
MOVE T5,[XWD SAVSUB,NSUBS] ;YES, GET SUBS TOO
BLT T5,NSUBS+3
JRST .+1]
TXNE SW,PRNMFG ;IS THIS A PROCEDURE NAME?
POPJ PP, ;YES, DON'T STORE "LAST"
MOVEM DT,LAST. ;SAVE FOR NEXT TIME
MOVS T5,[XWD SAVSUB,NSUBS] ;SAVE SUBS TOO
BLT T5,SAVSUB+3
MOVE W2,DT ;COPY DT POINTER
POPJ PP, ;RETURN, OK
SUBTTL COMMAND PROCESSORS -- LOCATE
LOCTYP: PUSHJ PP,GDTW2 ;GET A VALID DT AND W2
TXNN SW,PRNMFG ;[26] WERE WE GIVEN A PROC NAME?
JRST LCTYP0 ;[26] NO, DATA NAME.
HRRZ T2,1(W2) ;[26] YES, GET OBJECT ADDRESS OUT OF PROTAB.
JRST LCTYP1 ;[26] PRINT IT
LCTYP0: CAMN W2,[-1] ;TALLY?
JRST LOCTLY ;YES
MOVEI W1,BASEA ;[26] SET UP 'A' OPERAND
PUSHJ PP,SETOPN ;[26] RESOLVE ADDRESSING.
HRRZ T2,BASEA ;[26] GET BASE ADDRESS
ADD T2,INCRA ;[26] ADD ANY SUBSCRIPT INCREMENT
HLRZ T1,RESA ;[26] GET BIT RESIDUE
SKIPN T1 ;[26] BIT 0?
AOJA T2,LCTYP1 ;[26] YES, NEXT WORD ADDRESS
CAIN T1,^D36 ;[26] IS IT 0?
JRST LCTYP1 ;[26] YES
MOVEI T5,^D36 ;[26] CONVERT RESIDUE TO BIT NUMBER
SUB T5,T1 ;[26]
PUSH PP,T5 ;SAVE DISPLACEMENT
PUSHJ PP,LCTYP2 ;TYPE ADDRESS
POP PP,T5
PTYPE [ASCIZ / Starting at bit /]
PUSHJ PP,PRNUM ;[26] PRINT IT
JRST XECUTC ;RETURN TO SCANNER
;LOCATE TALLY
LOCTLY: MOVEI T2,TALLY.## ;GET ADDRESS OF TALLY.
LCTYP1: PUSHJ PP,LCTYP2 ;TYPE WORD
JRST XECUTC ;RETURN TO SCANNER
LCTYP2: MOVEI T3,6 ;[26] ALWAYS 6 OCTAL DIGITS
LSH T2,^D18 ;[26]
LCTYP3: SETZ T1, ;[26]
LSHC T1,3 ;[26] ISOLATE OCTAL DIGIT
ADDI T1,60 ;[26] MAKE ASCII
TYPEAC T1 ;[26]
SOJG T3,LCTYP3 ;[26] MORE?
POPJ PP,
SUBTTL COMMAND PROCESSORS -- GO
;DESTINATION'S PROTAB ADDRESS IS IN W2.
GOXXX: SKIPE DIED. ;[26] ARE WE ALIVE?
JRST [TYPE [ASCIZ /?Cannot GO!/]
JRST XECUTC] ;[26] DEAD
SKIPE REEFLG ;[26] NEED TO RESET STACK?
JRST [MOVE PP,REEFLG
POP PP,0(PP)
SETZM REEFLG
JRST GOXXX4] ;[26] YES
SKIPE EBRKOV ;[26] OVERLAY BREAK?
JRST [TYPE [ASCIZ /?Module/]
JRST GOXXX2] ;[26] YES
SKIPE CUR.BP ;[26] PROGRAM STARTED?
JRST GOXXX4 ;[26] YES
TYPE [ASCIZ /?Program/] ;[26] NO
GOXXX2: TYPE [ASCIZ / not Started, do STEP, then GO/]
JRST XECUTC ;[26]
GOXXX4: HRRZ T2,1(W2) ;[26]GET DESTINATION
MOVE T5,0(T2) ;[26] GET INSTRUCTION
CAME T5,[PUSHJ PP,C.TRCE] ;[26] IS IT TRACE INSTRUCTION?
JRST GOXXX6 ;[26] NO
HRRZ T5,1(T2) ;[26] GET PROTAB LINK
ADD T5,@%PR ;[26] MAKE ADDRESS
CAME T5,W2 ;[26] SAME ADDRESS?
JRST GOXXX6 ;[26] NO
PUSHJ PP,INSRTB ;[26] SET ANY BREAKPOINTS THAT NEED IT.
HRRZ T2,1(W2) ;[26] REFETCH DESTINATION
JRST 0(T2) ;[26] GO
GOXXX6: TYPE [ASCIZ /?Location is not resident/]
JRST XECUTC ;[26]
SUBTTL COMMAND PROCESSORS -- DDT
;HERE WHEN "DDT <CRLF>" SEEN
IFE TOPS20,<
GODDT: SKIPE .JBDDT ;IS DDT LOADED?
JRST GODDT1 ;YES
;TRY TO MERGE VMDDT
SAVACS ;MERGE. WIPES OUT ALL ACCS
MOVEI T2,VMDDT
MERGE. T2,
JRST GODDT0 ;FAILED
RSTACS
MOVEI T2,700000 ;ASSUME DDT IS HERE
SETDDT T2,
GODDT1: OUTSTR [ASCIZ /[Return from DDT by typing "POPJ 17,$X"]
/] ;[26]
PUSH PP,.JBSA ;SAVE START ADDR.
MOVEI T1,BADDG ; HE SHOULDN'T TRY TO RESTART NOW!
HRRM T1,.JBSA ;OTHERWISE HE "CANNOT PROCEED!"
HRRZ T2,.JBDDT ;[26] GET DDT ENTRY POINT
PUSHJ PP,(T2) ;[26]
POP PP,.JBSA ;RESTORE .JBSA
JRST XECUTX ;[26]
GODDT0: RSTACS
OUTSTR [ASCIZ/?DDT not accessible
/]
JRST XECUTX
;HERE IF HE DOES A $G AFTER GOING TO DDT.
; THIS IS A COMMON ERROR.
BADDG: OUTSTR <[ASCIZ/?CBDCNR Cannot restart program now.
[Assuming you meant to type "POPJ 17,$X" - returning to COBDDT]
/]>
POPJ PP, ;RETURN TO COBDDT.
VMDDT: SIXBIT /SYS/
SIXBIT /VMDDT/
SIXBIT /EXE/
EXP 0,0,0
>
;TOPS20 CODE FOR "DDT" COMMAND ON NEXT PAGE
IFN TOPS20,<
;HERE WHEN "DDT <CRLF>" TYPED
GODDT: TDZA W2,W2 ;HAVEN'T BEEN HERE BEFORE
GODDT0: SETO W2, ;BEEN HERE BEFORE
MOVE 1,[.FHSLF,,770] ;[26] IS PAGE ACCESSIBLE?
RPACS%
AND 2,[EXP PA%RD!PA%EX!PA%PEX] ;[26]
CAME 2,[EXP PA%RD!PA%EX!PA%PEX] ;[26]
JRST GETDD ;NO, BUT TRY TO READ DDT IN
MOVE 1,770000 ;[26] DOES IT CONTAIN DDT?
CAME 1,[JRST 770002] ;[26] PROBABLY, IF EQUAL.
JRST NODDT ;GIVE ERROR
;DON'T LET HIM RESTART PROGRAM... HE MUST TYPE "POPJ 17,$X"
;*** NOTE: THE FOLLOWING CODE IS FOR 12B ONLY. IT MUST BE
; REWRITTEN WHEN LIBOL IS MADE NATIVE ON THE -20 ***
PUSH PP,.JBSA ;SAVE START ADDR.
MOVEI T1,BADDG ;PLACE TO GO IF HE TYPES $G
HRRM T1,.JBSA ; (PREVENT A COMMON ERROR)
HRROI T1,[ASCIZ/[Return from DDT by typing "POPJ 17,$X"]
/]
PSOUT%
PUSHJ PP,770000 ;CALL DDT
POP PP,.JBSA ;RESTORE .JBSA
JRST XECUTX ;RETURN TO COMMAND SCANNER
NODDT: HRROI T1,[ASCIZ/?DDT not accessible
/]
PSOUT%
JRST XECUTX ;RETURN TO COMMAND SCANNER
BADDG: TYPE <[ASCIZ/?CBDCNR Cannot restart program now.
[Assuming you meant to type "POPJ 17,$X" - returning to COBDDT]
/]>
POPJ PP, ;DO IT.
;HERE IF PAGE IS NOT EVEN ACCESSIBLE. TRY TO READ DDT IN (BUT
; BE CAREFUL TO NOT ALLOW IT TO WIPE OUT EXISTING DATA!)
GETDD: JUMPN W2,NODDT ;IF BEEN HERE BEFORE, GIVE UP
MOVX T1,GJ%OLD!GJ%SHT ;GET DDT
HRROI T2,[ASCIZ/SYS:UDDT.EXE/]
GTJFN%
ERJMP NODDT ;NOT THERE--SAY "NOT ACCESSIBLE"
PUSH PP,T1 ;SAVE THE JFN
MOVEI T1,.FHSLF ;SAVE ENTRY VECTOR INFO
GEVEC% ; (GET% SMASHES IT)
PUSH PP,T2 ;SAVE THE INFO
HRR T1,-1(PP) ;RH(T1)= JFN
HRLI T1,.FHSLF ;READ INTO SAME FORK
TXO T1,GT%NOV ;DON'T OVERLAY EXISTING PAGES!!
GET% ;READ IN DDT
ERJMP GETFAI ;FAILED
POP PP,T2 ;ENTRY VECTOR INFO
MOVEI T1,.FHSLF
SEVEC% ;RESTORE ENTRY VECTOR
POP PP,(PP) ;FORGET JFN, DON'T CARE ANYMORE
DMOVE T1,116 ;GET SYMBOL TABLE INFO
MOVEM T1,@770001 ;STORE IN DDT
MOVEM T2,@770002 ;. .
JRST GODDT0 ;GO TRY AGAIN
GETFAI: POP PP,(PP) ;FORGET ENTRY VECTOR INFO
TYPE [ASCIZ/?GET failed-- can't read in DDT: /]
PUSHJ PP,LSTFRC ;TYPE LAST ERROR IN THIS FORK
POP PP,T1 ;RECOVER JFN
RLJFN%
ERJMP .+2 ;CAN'T RELEASE JFN
JRST XECUTX ;GIVE UP
TYPE [ASCIZ/?Can't release JFN for SYS:UDDT.EXE: /]
PUSHJ PP,LSTFRC ;TYPE WHY!
JRST XECUTX
>;END IFN TOPS20
SUBTTL COMMAND PROCESSORS -- OVERLAY
;HERE WITH W2= 0 IF "OVERLAY OFF", W2= -1 IF "OVERLAY ON"
;JUST SET SWITCH ON OR OFF.
SETOVR: MOVEM W2,BRKONO ;SAVE ON/OFF VALUE.
JRST XECUTX ;CONTINUE.
SUBTTL COMMAND PROCESSORS -- ACCEPT + DISPLAY
;HERE WITH W1= ACCGEN OR DISPGN
;JRSTS TO XECUTX WHEN DONE
;ACCEPT/DISPLAY CODE INIT AND EXECUTION
CODGNR: MOVE T5,[XWD CODFST,CODFST+1]
BLT T5,CODLST
SETZM TEMPC
SETZM EAC
SETZM TEMROL
IFE BIS,<
MOVE LIT,[IOWD N.LIT,LITROL]
MOVE COD,[IOWD N.COD,CODROL]
>
IFN BIS,<
DMOVE LIT,[IOWD N.LIT,LITROL
IOWD N.COD,CODROL]
>
;IF DT = 0, NO NAME WAS GIVEN WITH COMMAND, USE SAVED NAME.
PUSHJ PP,GDTW2 ;GET VALID DT AND W2
CAMN DT,[-1] ;CHECK FOR TALLY
JRST DOTAL ;YES, GO HANDLE IT
PUSH PP,W1 ;SAVE ADDRESS OF ROUTINE CALLED
PUSHJ PP,0(W1) ;DISPATCH TO ACCEPT OR DISPLAY
;THE ACCEPT OR DISPLAY CODE GENERATORS LOAD EXECUTABLE INSRUCTIONS
;INTO THE CODROL BLOCK AND THEN RETURN HERE.
PUSH COD,CPOPJ ;ADD A POPJ RETURN TO THE EXECUTABLE INSTRUCS
PUSHJ PP,CODROL ;CALL CODE
POP PP,W1 ;GET BACK ADDRESS OF ROUTINE CALLED
CAIN W1,DISPGN ;WAS THAT A DISPLAY?
JRST XECUTC ;YES, TYPE A CRLF BEFORE NEXT PROMPT
JRST XECUTX ;GO TO NEXT COMMAND
;SPECIAL TREATMENT FOR TALLY IN COBOL-68
DOTAL: CAIN W1,ACCGEN ;ACCEPT TALLY?
JRST DOTALA ;YES
;DISPLAY TALLY
MOVE T5,TALLY.## ;GET CONTENTS OF TALLY
JUMPGE T5,DOTAL0 ;NEGATIVE?
MOVEI T1,"-" ;PRINT MINUS SIGN
TYPEAC T1
MOVM T5,T5 ;MAGNITUDE
DOTAL0: PUSHJ PP,PRNUM ;PRINT NUMBER
JRST XECUTC
;ACCEPT TALLY
DOTALA: MOVSI T5,6005 ;GET PARAMETERS FOR LIBOL ACCEPT
MOVEI 16,T5 ;GET VALUE FROM USER
PUSHJ PP,ACEPT. ;CALL LIBOL ACCEPT ROUTINE
MOVEM 1,TALLY.## ;SAVE VALUE
JRST XECUTX
;GENERATES CODE FOR A "MOVE A TO B" WHERE "A" IS THE LITERAL TYPED
;ON THE TERMINAL AND "B" IS THE IDENTIFIER TYPED IN ACCEPT COMMAND.
ACCGEN: MOVEI W1,BASEB ;SET UP 'B' OPERAND
PUSHJ PP,SETOPN
MOVE T5,[XWD BASEB,BASEA]
BLT T5,BASAX ;MAKE 'A' = 'B'
MOVE T5,DTFLAG(DT) ;GET FLAGS
MOVEI T4,EDMODE
TXNE T5,DTEDIT ;EDITED?
HRRM T4,MODEB ;YES: SET MODE
HRLZ W1,SIZEB ;SET UP SIZE IN PARAM
TLO W1,(<1B7>) ;SKIP TO CRLF
LDB T5,DTCLAS ;CHECK ON CLASS
CAIN T5,CL.NUM ;NUMERIC?
JRST ACEP15 ;YES:
;FIELD IS ALPHANUMERIC
HRRZ T5,MODEB
CAIN T5,D7MODE ;ASCII?
JRST ACEP20 ;OK TO USE DIRECTLY
;FIELD IS EITHER ASCII-EDITED OR NON-ASCII ALPHANUMERIC
; SO ACCEPT INTO ASCII TEMP AND MOVE AFTER
ACEP10: MOVE T1,SIZEA ;GET SIZE FOR TEMP CALC
ADDI T1,4
IDIVI T1,5 ;NUMBER OF WORDS
PUSHJ PP,GETEMP ;ALLOCATE AND RETURN ADDR
MOVEM T1,INCRA
MOVE T1,[XWD ^D36,TEMROL]
MOVEM T1,BASEA
MOVEI T1,D7MODE ;'A' IS ASCII
MOVEM T1,MODEA
PUSHJ PP,ACEP20
TXZ SW,FASIGN!FANUM
JRST MXX. ;STASH AWAY
;FIELD IS NUMERIC OR NUMERIC EDITED
; SO ACCEPT INTO AC 0,1 AND THEN MOVE TO DESTINATION
ACEP15: PUSHJ PP,ACEP25
SETZM EAC ;AC := 0
TXO SW,FASIGN!FANUM
MOVEI T5,D2MODE ;USE 2-WORD COMP
MOVEM T5,MODEA
JRST MACX. ;STASH AWAY
;CREATE LITERAL AND CALL FOR ALPHANUMERIC
ACEP20: LSH W1,6
HLR W1,RESA ;BYTE RESIDUE
ROT W1,-6
HRR W1,BASEA ;ADDRESS
ADD W1,INCRA ;INCREMENT
ACEP21: PUSH LIT,W1 ;STORE LITERAL
MOVSI CH,(MOVEI 16,)
HRR CH,LIT ;LITERAL ADDR
PUSH COD,CH ;STASH CODE
PUSH COD,[PUSHJ PP,ACEPT.] ;CALL ACCEPT
POPJ PP,
;CREATE LITERAL AND CALL FOR NUMERIC
ACEP25: TLO W1,(<1B6>) ;NUMERIC
MOVE T2,DPLA
JUMPGE T2,ACEP26 ;OK IF POSITIVE
MOVNS T2
TRO T2,40 ;SET SIGN
ACEP26: HRR W1,T2 ;DECIMAL PLACES
JRST ACEP21
;COME HERE FOR "DISPLAY" COMMAND EXECUTION.
;GENERATES CODE FOR A "MOVE A TO B" WHERE "A" IS THE IDENTIFIER TYPED IN
;THE DISPLAY COMMAND AND "B" IS THE TERMINAL.
DISPGN: LDB T3,DTUSAG ;GET USAGE
JRST @DISPDO(T3)
;DISPLAY DISPATCH TABLE
DISPDO: EXP DISERR ;0 - NO SUCH
EXP DISPD6 ;[22] 1 - DISPLAY 6
EXP DISPD7 ;2 - DISPLAY 7
EXP STNDRD ;3 - DISPLAY 9
EXP STNDRD ;4 - 1 WORD COMP
EXP STNDRD ;5 - 2 WORD COMP
EXP DISPFP ;6 - COMP-1
EXP STNDRD ;7 - INDEX
EXP STNDRD ;10 - COMP-3
;CALL MOVE GENERATOR FOR A LITTLE HELP
; MOVE TO AN ASCII TEMP - POSSIBLY EDITED
STNDRD: PUSHJ PP,MXTMP.
STND2: TLZ W1,(<1B7>) ;CRLF AT END OF LINE
PUSH LIT,W1
MOVSI CH,(MOVEI 16,)
HRR CH,LIT
PUSH COD,CH
PUSH COD,[PUSHJ PP,DSPLY.] ;DISPLAY IT
POPJ PP,
;DISPLAY ASCII
DISPD7: MOVEI W1,BASEA ;SET UP 'A' OPERAND
PUSHJ PP,SETOPN
TXNE SW,FANUM ;NUMERIC?
JRST STNDRD ;YES: USE STANDARD
MOVE T5,DTFLAG(DT)
HRRZ W1,SIZEA ;GET CORRECT SIZE
TXNE T5,DTEDIT ;IF EDITED
LDB W1,DTESIZ ;USE EXTERNAL SIZE
CAILE W1,1777 ;[22] WILL IT FIT IN ONE OPERATION?
JRST [SUBI W1,^D1020 ;[22] NO
PUSH PP,W1 ;[22] SAVE REMAINDER
MOVEI W1,^D1020 ;[22] SAVE THE FIRST PART
PUSHJ PP,.+1 ;[22] DO THE FIRST PART
MOVEI W1,^D1020/5 ;[22]
ADDM W1,INCRA ;[22] POINT TO SECOND PART
POP PP,W1 ;[22] GET BACK REMAINDER
JRST .+1] ;[22] CONTINUE
ROT W1,-^D12
HLR W1,RESA
ROT W1,-6
HRR W1,BASEA
ADD W1,INCRA
JRST STND2
;DISPLAY SIXBIT
DISPD6: MOVEI W1,BASEA ;[22] SET UP 'A' OPERAND
PUSHJ PP,SETOPN ;[22]
TXNE SW,FANUM ;[22] NUMERIC?
JRST STNDRD ;[22] YES, USE STANDARD
MOVE T5,DTFLAG(DT) ;[22]
HRRZ W1,SIZEA ;[22] GET CORRECT SIZE
TXNE T5,DTEDIT ;[22] IF EDITED
LDB W1,DTESIZ ;[22] USE EXTERNAL SIZE
CAILE W1,1777 ;[22] WILL IT FIT IN ONE OPERATION?
JRST [SUBI W1,^D1020 ;[22] NO
PUSH PP,W1 ;[22] SAVE REMAINDER
MOVEI W1,^D1020 ;[22] SIZE OF FIRST PART
PUSHJ PP,.+1 ;[22] DO THE FIRST PART
MOVEI W1,^D1020/6 ;[22]
ADDM W1,INCRA ;[22] POINT TO SECOND PART
POP PP,W1 ;[22] GET BACK REMAINDER
JRST .+1] ;[22] CONTINUE
ROT W1,-^D12 ;[22]
HLR W1,RESA ;[22]
ROT W1,-6 ;[22]
HRR W1,BASEA ;[22]
ADD W1,INCRA ;[22]
TLZ W1,(<1B7>) ;[22] CRLF AT END OF LINE
PUSH LIT,W1 ;[22]
MOVSI CH,(MOVEI 16,) ;[22]
HRR CH,LIT ;[22]
PUSH COD,CH ;[22]
PUSH COD,[PUSHJ PP,DSPL.6##] ;[22] DISPLAY IT
POPJ PP, ;[22]
;DISPLAY A COMP-1 FIELD
DISPFP: MOVEI W1,BASEA ;SET UP 'A' OPERAND
PUSHJ PP,SETOPN
MOVEI T5,4
MOVEM T5,EAC ;USE AC(5)
MOVSI CH,(MOVE)
TXNN SW,FASIGN ;SIGNED?
MOVSI CH,(MOVM) ;NO: USE MAGNITUDE ONLY
PUSHJ PP,GENOPA
PUSH COD,[PUSHJ PP,DSP.FP]
POPJ PP,
;SET UP OPERAND PARAMETERS
;ENTER WITH EITHER BASEA OR BASEB IN W1 & PNTR TO 'DATAB'
;ENTRY IN DT. SUBSCRIPTING IS DONE IF NECESSARY AND 'INCRX'
;AND 'RESX' ARE UPDATED.
SETOPN: HRRZ T2,1(DT) ;GET ADDR OF ELEMENT
HRRZM T2,BASEX(W1)
SETZM INCRX(W1) ;CLR INCREMENT
LDB T5,DTUSAG ;GET USAGE
SUBI T5,1
CAIN T5,%US.IN-1 ;INDEX
MOVEI T5,D1MODE ;YES: USE 1-WORD COMP
MOVEM T5,MODEX(W1)
LDB T5,DTRESD ;GET BYTE RESIDUE
HRLM T5,RESX(W1) ;AND STASH
LDB T5,DTDPL ;GET DECIMAL PLACES
TRZE T5,DTPLOC ;NEGATIVE?
MOVNS T5 ;YES: NEGATE
MOVEM T5,DPLX(W1) ;AND STASH IT
LDB T5,DTISIZ ;USE INTERNAL SIZE
MOVEM T5,SIZEX(W1)
MOVE T4,DTFLAG(DT) ;FLAGS
TXNN T4,DTDEF ;MAKE SURE DEFINED
JRST UNDEF
TRNN T4,DTLKS ;LINKAGE SECTION?
TXNE T4,DTSUBS ;NEED SUBSCRIPTS?
JRST SETOP1 ;YES
SKIPE NSUBS
JRST NOSUB
JRST .+2
SETOP1: PUSHJ PP,SUBSCR ;YES: DO CHECK
MOVE T4,DTFLAG(DT) ;GET FLAGS BACK
CAIN W1,BASEA ;DOING 'A'?
JRST SETOP2 ;YES:
;'B' OPERAND
TXNE T4,DTSIGN ;SIGNED?
TXOA SW,FBSIGN
TXZ SW,FBSIGN
TXNN T4,DTEDIT ;EDITED
TXNN T4,DTNUM ;NO: NUMERIC
TXZA SW,FBNUM
TXO SW,FBNUM
POPJ PP, ;RETURN
;'A' OPERAND
SETOP2: TXNE T4,DTSIGN ;SIGNED?
TXOA SW,FASIGN
TXZ SW,FASIGN
TXNN T4,DTEDIT ;EDITED
TXNN T4,DTNUM ;NO: NUMERIC
TXZA SW,FANUM
TXO SW,FANUM
POPJ PP, ;RETURN
;DO SUBSCRIPTING
SUBSCR: SKIPE NSUBS ;DO WE HAVE ANY?
JRST SUBSC0 ;YES
TRNN T4,DTLKS ;IN LINKAGE SECTION?
JRST NEDSUB ;NO: TOUGH
SUBSC0: MOVEM DT,SAVDT ;SAVE DATAB PNTR
SETZB CH,REMAN
HLRZ W2,RESX(W1) ;CALC B.P. TO 1ST ELEMENT
ROT W2,-6 ;SET UP RESIDUE
HRR W2,INCRX(W1)
MOVE T4,DTFLAG(DT) ;LINKAGE SECTION?
TRNN T4,DTLKS
JRST SUBSC2 ;NO
HLRZ T4,DTLKP(DT) ;YES, GET LINKAGE PTR
ADD W2,(T4)
SKIPE NSUBS ;0 SUBSCRIPTS?
JRST SUBSC2 ;NO
MOVE T5,W2 ;YES, GET TO THE END
JRST SUBSC8
SUBSC2: MOVE T5,DTSUBW(DT) ;OCCURS AT THIS LEVEL?
TLNE T5,DTOCCL
JRST SUBSCA
LDB DT,[POINT 15,DTSUBW+1(DT),17]
ADD DT,@%DT
SUBSCA: ;GET PROPER BYTE SIZE FOR RECORD
LDB T3,DTUSAG ;GET USAGE
CAIN T3,%US.IN ;INDEX?
MOVEI T3,D1MODE+1 ;USE COMP
HLRZ T2,BYPTRS-1(T3) ;SKELETON BYTE POINTER
TRZ T2,770077 ;JUST LEAVE BYTE SIZE
TLO W2,(T2) ;PUT BYTE SIZE IN
SUBSC1: LDB T2,DTNOCC ;NUMBER OF OCCURRANCES
SKIPG T3,SUB0.(CH) ;[24]SUBSCRIPT POSITIVE?
JRST SMLSUB ;[24]NO, ERROR
CAMLE T3,T2 ;IN BOUNDS?
JRST LRGSUB
SOS T3 ;OK, DECR
LDB T5,DTUSAG ;GET USAGE
XCT SUBSIZ(T5) ;GET # OF BYTES
IMUL T2,T3
ADDM T2,REMAN ;ACCUMULATE SUM
SUBSC3: AOS T5,CH ;NEXT SUBSCRIPT
LDB T2,[POINT 15,DTSUBW+1(DT),17]
CAML T5,NSUBS
JRST SUBSC4 ;NO MORE TYPED
JUMPE T2,TOOFEW ;TOO MANY
HRRZ DT,T2 ;PNTR TO NEXT LEVEL
ADD DT,@%DT
JRST SUBSC1 ;LOOP
SUBSC4: JUMPE T2,SUBSC6 ;ALL EVEN?
JRST NOTNUF ;NOT ENUF
SUBSC6: MOVE T4,REMAN ;GET COMPUTED OFFSET
LDB T5,[POINT 6,W2,11]
MOVEI T1,^D36
IDIV T1,T5 ;BYTES/WORD
IDIV T4,T1 ;NUMBER OF WORDS
MOVE T3,T5 ;SAVE REMAINDER
MOVE T5,W2
ADD T5,T4 ;CALC NEW OFS
SUBSC7: SOJL T3,SUBSC8 ;ANY BYTES LEFT OVER?
IBP T5 ;YES: BUMP BYTE PNTR
JRST SUBSC7 ;LOOP
SUBSC8: HRRZM T5,INCRX(W1) ;STORE OFFSET
LDB T5,[POINT 6,T5,5]
HRLM T5,RESX(W1) ;AND RESIDUE
MOVE DT,SAVDT ;GET BACK DT PTR
POPJ PP, ;RETURN
;A TABLE WHICH DETERMINES SIZE OF ITEM (ALWAYS IN BYTES)
SUBSIZ: JRST BADBAD ;0
PUSHJ PP,SUBSZX ;1 SIXBIT
PUSHJ PP,SUBSZX ;2 ASCII
PUSHJ PP,SUBSZX ;3 EBCDIC
MOVEI T2,6 ;4 1-WORD COMP
MOVEI T2,^D12 ;5 2-WORD COMP
MOVEI T2,6 ;6 COMP-1
MOVEI T2,6 ;7 INDEX
PUSHJ PP,SUBSZC ;10 COMP-3
SUBSZX: LDB T2,DTESIZ ;EXTERNAL SIZE
SUBSZ1: MOVE T4,DTFLAG(DT)
TXNN T4,DTSYNL!DTSYNR!DTSYLL
POPJ PP, ;NO SYNCS - OK
EXCH T5,T2
MOVE T4,T5
IDIV T4,BYTE.W-1(T2)
SKIPE T5
ADDI T4,1
IMUL T4,BYTE.W-1(T2)
EXCH T4,T2
MOVE T5,T4
POPJ PP,
SUBSZC: ;COMP - 3
LDB T2,DTESIZ ;EXTERNAL SIZE
ADDI T2,2 ;FOR SIGN AND ROUND OUT BYTE
LSH T2,-1 ;DIVIDE BY 2
JRST SUBSZ1
;MOVE AN ITEM TO TEMPORARY FOR USE BY "DISPLAY"
;ENTER WITH 'DT' POINTING TO AN OPERAND.
;EXIT WITH DISPLAY LITERAL IN 'W1'
MXTMP.: SETZM EAC ;START AN AC(0)
MOVEI W1,BASEA ;SET UP 'A' OPERAND
PUSHJ PP,SETOPN
MOVE T5,[XWD BASEA,BASEB]
BLT T5,BASBX ;MAKE 'B' = 'A'
MOVEI T5,D7MODE
MOVEM T5,MODEB ;ASCII
TXNE SW,FANUM ;IS 'A' NUMERIC
JRST MXTMP4 ;YES: TREAT SPECIAL
MOVE T5,DTFLAG(DT)
TXNN T5,DTEDIT ;EDITED FIELD?
JRST MXTMP1 ;NO:
LDB T5,DTESIZ ;YES: USE EXTERNAL SIZE
MOVEM T5,SIZEA
MOVEM T5,SIZEB
;INPUT FIELD IS NON-ASCII, NON-NUMERIC
MXTMP1: HRLZ W2,SIZEA ;CONSTRUCT LIT IN W2
MOVE T1,SIZEB
ADDI T1,4 ;GET SIZE OF 'B' IN WORDS
IDIVI T1,5
PUSHJ PP,GETEMP ;GET SOME TEMP LOCS
MOVEM T1,INCRB
MOVE T1,[XWD ^D36,TEMROL]
MOVEM T1,BASEB
HRR W2,BASEB
ADD W2,INCRB
PUSHJ PP,MXX. ;GENERATE MOVE
TLO W2,(<^D36B5>) ;BYTE RESIDUE
MOVE W1,W2 ;RETURN LITERAL
POPJ PP,
;ITEM IS NUMERIC, AND THEREFORE MUST BE EDITED.
MXTMP4: TXO SW,FBSIGN!FBNUM ;'B' IS ALWAYS SIGNED ETC.
SKIPL DPLA ;NEGATIVE DECIMAL PLACES?
JRST MXTMP5 ;NO:
MOVM T5,DPLA ;YES: 'B' IS SIZE - DEC. PL.
ADD T5,SIZEA
MOVEM T5,SIZEB
SETZM DPLB
JRST MXTMP9
MXTMP5: MOVE T5,SIZEA ;NEGATIVE INTEGRAL PLACES?
SUB T5,DPLA
JUMPGE T5,MXTMP6 ;NO: OK
MOVE T5,DPLA ;YES: SIZE IS # DECIMAL PLACES
MOVEM T5,SIZEB
JRST MXTMP9
MXTMP6: ;MOVE EVERYTHING TO A TEMP TO BE SURE NUMBER IS IN CORRECT FORM
; HRRZ T5,MODEA ;IS ITEM DISPLAY USAGE?
; CAIG T5,DSMODE
; JRST MXTM10 ;YES: DON'T MOVE TO TEMP
MXTMP9: MOVEI T1,D6MODE ;NO: MOVE TO TEMP
MOVEM T1,MODEB
MOVE T1,SIZEB ;CALC # OF WORDS
ADDI T1,5
IDIVI T1,6
PUSHJ PP,GETEMP ;GET SOME SPACE
MOVEM T1,INCRB
MOVE T1,[XWD ^D36,TEMROL]
MOVEM T1,BASEB
MOVE T1,[XWD BASEB,SAVEA]
BLT T1,SAVAX ;SAVE 'B' PARAMETERS
PUSHJ PP,MXX. ;MOVE TO TEMP
MOVE T1,[XWD SAVEA,BASEA]
BLT T1,BASAX
MOVE T1,[XWD SAVEA,BASEB]
BLT T1,BASBX
;IT IS (OR HAS BEEN CONVERTED TO) DISPLAY USAGE.
HRRZI W1,1(LIT) ;ADDR OF LITERAL
HRLI W1,(<^D36B5>)
SETZM BASEB ;BYTE COUNTER
MOVEI T2,0
MOVE T1,[POINT 4,T2] ;INITIALIZE
MOVE T3,SIZEB
SUB T3,DPLB
JUMPE T3,MXT11B ;ALL TO RIGHT IF DECIMAL
MOVEI CH,CODES ;PRETEND THERE IS ONE INTEGER
CAIE T3,1 ;IS THAT TRUE?
AOSA BASEB ;NO: LEAVE ROOM FOR SIGN
PUSHJ PP,MXTM20 ;YES: JAM INSERT SIGN
MOVEI CH,CODEM ;SET UP FOR "FLOAT SIGN"
MXTM11: SOJLE T3,MXT11A ;ONLY ONE LEFT?
PUSHJ PP,MXTM20 ;NO:
JRST MXTM11
MXT11A: MOVEI CH,CODE9 ;USE "9" FOR LAST INTEGRAL PLACE.
PUSHJ PP,MXTM20
JRST MXTM12
MXT11B: MOVEI CH,CODES ;USE INSERT SIGN
PUSHJ PP,MXTM20
MXTM12: SKIPN T3,DPLB
JRST MXTM13
MOVEI CH,CODEP ;INSERT POINT
PUSHJ PP,MXTM20
MOVEI CH,CODE9 ;FINISH OFF WITH "9"'S
PUSHJ PP,MXTM20
SOJG T3,.-1
;MASK HAS BEEN CREATED FOR NUMERIC ITEM--FINISH UP.
MXTM13: MOVEI CH,17
IDPB CH,T1
PUSH LIT,T2
HRLZ W2,BASEB ;FIELD SIZE TO LITERAL
TLO W2,(<^D36B5+1B6>)
MOVE T1,BASEB
ADDI T1,4
IDIVI T1,5 ;SIZE IN WORDS
PUSHJ PP,GETEMP ;GET SOME PLACE TO PUT IT
MOVEM T1,INCRB
MOVE T1,[XWD ^D36,TEMROL]
MOVEM T1,BASEB
HRR W2,T1 ;ADDR TO LIT ALSO
ADD W2,INCRB
MOVEI T1,D7MODE ;ASCII
MOVEM T1,MODEB
MOVEI T1,MDES. ;ASSUME SIGNED
TXNN SW,FASIGN ;IS IT?
MOVEI T1,MDEU. ;NO: USE UNSIGNED ROUTINE
PUSHJ PP,(T1)
MOVE W1,W2 ;RETURN LIT
POPJ PP,
;ROUTINE TO PUT NEXT EDIT CHAR IN WORD AND STASH LIT IF
;NECESSARY. CLEAR 'T2' AND PUT B.P. IN 'T1'.
MXTM20: IDPB CH,T1 ;STORE AWAY
AOS BASEB ;KEEP COUNT
TLNE T1,770000 ;FULL WORD?
POPJ PP, ;NO: JUST EXIT
PUSH LIT,T2 ;YES: STASH LIT
MOVEI T2,0
MOVE T1,[POINT 4,T2]
POPJ PP, ;RE-INIT AND EXIT
;DISPATCH ROUTINES FOR MOVE GENERATORS
;MOVE THE AC'S TO SOMETHING
MACX.: HRRZ T5,MODEA ;CHECK MODES
CAIE T5,D2MODE ;ONLY LEGAL
JRST BADCOD
HRRZ T5,MODEB
JRST @MACX.T(T5) ;DO ROUTINE
MACX.T: EXP MACD. ; SIXBIT
EXP MACD. ; ASCII
EXP MACD. ; EBCDIC
EXP MAC1C. ; 1-WORD COMP
EXP MAC2C. ; 2-WORD COMP
EXP MACFP. ; COMP-1
EXP MACE. ; EDITED
EXP MACD.1 ;COMP-3
;MOVE SOMETHING TO SOMETHING
MXX.: HRRZ T2,MODEA
HRRZ T1,MODEB ;CHECK LEGAL MODES
CAILE T1,EDMODE
JRST BADCOD
CAILE T2,D2MODE
JRST [ CAIN T2,C3MODE
JRST MDD.1 ;COMP-3
JRST BADCOD ]
LSH T2,2 ;MOVT.(4*MODEA+MOBEB/2)
ROT T1,-1
ADDI T2,(T1)
TLNE T1,1B18 ;LEFT HALT DISPATCH
SKIPA T3,MOVT.(T2) ;NO:
MOVS T3,MOVT.(T2) ;YES:
JRST (T3) ;GO DO ROUTINE
;TABLE OF ENTRANCE POINTS TO "MOVE" ROUTINES.
MOVT.: XWD MDD.,MDD. ;S-S,S-A
XWD MDD.,BADCOD ;S-E,S-1C
XWD BADCOD,BADCOD ;S-2C,S-F
XWD MDED.,BADCOD ;S-EDIT
XWD MDD.,MDD. ;A-S,A-A
XWD MDD.,BADCOD ;A-E,A-1C
XWD BADCOD,BADCOD ;A-2C,A-F
XWD MDED.,BADCOD ;A-EDIT
XWD MDD.,MDD. ;E-S,E-A
XWD MDD.,BADCOD ;E-E,
XWD BADCOD,BADCOD
XWD MDED.,BADCOD ;E-EDIT
XWD M1CD.,M1CD. ;1C-S,1C-A
XWD M1CD.,BADCOD ;1C-E,1C-1C
XWD BADCOD,BADCOD ;1C-2C,1C-FP
XWD BADCOD,BADCOD ;-,1C-EDIT
XWD M2CD.,M2CD. ;2C-S,2C-A
XWD M2CD.,BADCOD ;2C-E,2C-1C
XWD BADCOD,BADCOD ;2C-2C,2C-FP
XWD BADCOD,BADCOD ;-,2C-EDIT
BADCOD: PTYPE [ASCIZ "?Illegal MOVE args"]
JRST XECUTC
;GENERATE CODE TO MOVE FROM DISPLAY TO DISPLAY
;FOR UNEDITED FIELDS OF SAME SIZE
; NUMERIC DISPLAYS ALWAYS GO TO SIXBIT - TEMP FOR EDIT
MDD.: MOVE T5,SIZEB ;CHECK ARGS
CAMN T5,SIZEA ;FOR SAME SIZE AND
TXNE SW,FBNUM ;NON-NUMERIC RECIEVER
JRST MDD.E
PUSHJ PP,BYTE.A ;GET 'A' PARAMETER
PUSH LIT,T2
PUSH COD,LIT ;ADDR OF LITERALS
PUSHJ PP,BYTE.C ;GET 'B' PARAMETER
PUSH LIT,T2
MOVEI CH,(MOVEI 16,)
HRLM CH,0(COD) ;MOVEI 16,PARAMS
HRRZ T3,MODEA ;GET CORRECT ROUTINE
HRRZ T5,MODEB
PUSH COD,@GMOVET(T3) ;GET ROUTINE
POPJ PP,
GMOVET: GM6(T5) ;C.D6XX
GM7(T5) ;C.D7XX
GM9(T5) ;C.D9XX
GM6: PUSHJ PP,MOVE. ;SIXBIT TO SIXBIT
PUSHJ PP,C.D6D7
PUSHJ PP,C.D6D9
GM7: PUSHJ PP,C.D7D6
PUSHJ PP,MOVE.
PUSHJ PP,C.D7D9
GM9: PUSHJ PP,C.D9D6
PUSHJ PP,C.D9D7
PUSHJ PP,MOVE.
MDD.E: ;MOVING SAME TO SAME NOW
; CAME T5, SIZEA ; SAME SIZE NUMERIC FIELDS?
; JRST MDD.1 ; NO - ITEM MUST BE SCALED
; PTYPE [ASCIZ "? Error at MDD."]
; JRST XECUTC
MDD.1: PUSHJ PP, BYTE.A ; SAME SEQUENCE AS MDD.
PUSH LIT, T2
PUSH COD, LIT
PUSHJ PP, BYTE.C
PUSH LIT, T2
MOVSI CH, (MOVEI 16,) ; GET PARAMETER POINTER
HLLM CH, (COD)
HRRZ T5, (COD) ; SAVE POS IN LIT POOL
HRRZ T4,MODEA ;SOURCE MODE
XCT GDXTB(T4) ;GET PROPER ROUTINE
HRLI CH,(PUSHJ PP,)
PUSH COD,CH ;STORE CODE
SKIPL T4, DPLA ; NUMBER SCALED ON LEFT OF DECIMAL POINT?
JRST MDD.2
PUSH PP, T5 ;YES, SAVE POINTER TO LITERAL POOL.
SETZI T5, ;THE NUMBER IS IN AC 0.
PUSHJ PP, SCLE ;GO MULTIPLY THE NUMBER BY SOMETHING.
POP PP, T5 ;RESTORE LITERAL POOL POSITION
; OF GD?. PARAMETERS.
MDD.2: MOVSI CH, (MOVEI 16,) ; NOW PUT CALL TO PD6.
HRRI CH, (T5) ; POINT TO ARG
AOJ CH,
PUSH COD, CH ; ADD THAT
PUSH COD,[PUSHJ PP,PD6.] ;ALWAYS TO 6 BIT
MOVE CH, SIZEA
TXNE SW,FASIGN
TRO CH,(1B6)
DPB CH, [POINT 12, (T5), 17] ; FIX ARG IN LITROL
MOVE CH, SIZEB
TRO CH, 4000 ; FORCE LEAD BIT
DPB CH, [POINT 12, 1(T5), 17] ; FIX SECOND ARG
POPJ PP,
GDXTB: ;ROUTINE TO GET DISPLAY OR COMP-3
MOVEI CH,GD6.
MOVEI CH,GD7.
MOVEI CH,GD9.
PUSHJ PP,CBDGDX
PUSHJ PP,CBDGDX
PUSHJ PP,CBDGDX
PUSHJ PP,CBDGDX
MOVEI CH,GC3.
CBDGDX: PTYPE [ASCIZ/?CDBINT GDXTB error
/]
POPJ PP,
;MOVE A 1-WORD COMP TO A DISPLAY FIELD.
M1CD.: MOVSI CH,(MOVE) ;MOVE TO AN AC
TXNN SW,FASIGN!FBSIGN ;SIGNED?
MOVSI CH,(MOVM) ;NOPE!
PUSHJ PP,GENOPA
SKIPL T4, DPLA
JRST MACD. ;CONVERT AND RETURN
MOVE T5, EAC ;FIND OUT WHERE THE NUMBER IS.
ADDI T5, 1
MOVE CH, SIZEB ;GET THE SIZE OF THE RESULT.
CAIG CH, ^D10 ;IF IT'S ONE WORD, ALL IS
JRST M2CD.3 ; WELL, GO SCALE THE NUMBER.
SOS CH, T5 ;ALL IS NOT WELL, THE NUMBER
DPB CH, CHAC ; IS IN THE WRONG AC, MOVE
ADD CH, [MOVE 1] ; IT UP ONE AC.
PUSH COD, CH
JRST M2CD.3
;MOVE A 2-WORD COMP TO A DISPLAY FILED.
M2CD.: TXNN SW,FASIGN!FBSIGN ;SIGNED?
JRST M2CD.1 ;NO: USE SPECIAL ROUTINE
IFN BIS,<
MOVSI CH,(DMOVE)
PUSHJ PP,GENOPB
>
IFE BIS,<
MOVSI CH,(MOVE) ;MOVE TO AC'S
PUSHJ PP,GENOPB
AOS INCRA
MOVSI CH,(MOVE)
PUSHJ PP,GENOPA
>
JRST M2CD.2 ;GO SEE IF THE NUMBER IS SCALED.
M2CD.1:
IFN BIS,<
MOVSI CH,(DMOVE)
PUSHJ PP,GENOPB
MOVSI CH,(SKIPGE)
PUSHJ PP,GENOPB
MOVSI CH,(DMOVN)
PUSHJ PP,GENOPB
>
IFE BIS,<
MOVE CH,[PUSHJ PP,MAG.] ;DOUBLE-PRECISION MOVE
PUSHJ PP,GENPUB ;OF MAGNITUDE
>
M2CD.2: SKIPL T4, DPLA ;IS THE NUMBER SCALED?
JRST MACD. ;NO, GO CONVERT IT.
MOVE T5, EAC ;FIND OUT WHERE IT WILL BE.
M2CD.3: PUSHJ PP, SCLE ;GO GENERATE CODE TO SCALE IT.
JRST MACD. ;GO CONVERT IT.
;GENERATE CODE TO SCALE THE NUMBER IN THE AC WHOSE NUMBER IS IN T5 BY
; THE POWER OF 10 WHOSE NEGATIVE IS IN T4.
SCLE: MOVMS T4 ;MAKE THE POWER POSITIVE.
CAILE T4, ^D10 ;IF IT'S TWO WORDS,
JRST SCLEH ; GO ON.
MOVEI CH, STENS(T4) ;SELECT THE APPROPRIATE NUMBER.
DPB T5, CHAC ;SET UP THE AC FIELD.
MOVE T5, SIZEA ;SEE WHAT THE SIZE OF THE NUMBER
; BEFORE THE MULTIPLICATION IS.
CAILE T5, ^D10 ;IF IT'S TWO WORDS,
JRST SCLED ; GO ON.
MOVE T5, SIZEB ;SEE WHAT THE SIZE OF THE NUMBER
; WILL BE AFTER THE MULTIPLICATION.
CAILE T5, ^D10 ;IF IT'S GOING TO BE TWO WORDS
TLOA CH, (MUL) ; USE MUL, OTHERWISE USE IMUL SO
TLO CH, (IMUL) ; THAT WE KEEP THE RESULT IN THE
; SAME AC.
PUSH COD, CH ;STASH THE INSTRUCTION.
POPJ PP, ;AND RETURN.
;THE NUMBER IS DOUBLE PRECISION.
SCLED: PUSHJ PP, SCLEL ;GO SAVE THE PARAMETER.
PUSH COD, [PUSHJ PP, MUL.21##]
POPJ PP,
;THE POWER IS DOUBLE PRECISION.
SCLEH: MOVEI CH, -^D11(T4) ;CONSTRUCT THE PARAMETER.
LSH CH, 1
MOVEI CH, DTENS(CH)
DPB T5, CHAC
PUSHJ PP, SCLEL ;GOSAVE IT.
PUSH COD, [PUSHJ PP, MUL.12##]
POPJ PP,
SCLEL: PUSH LIT, CH
HRRI CH, (LIT)
HRLI CH, (<MOVE 16,0>)
PUSH COD, CH
POPJ PP,
STENS: DEC 1
DEC 10
DEC 100
DEC 1000
DEC 10000
DEC 100000
DEC 1000000
DEC 10000000
DEC 100000000
DEC 1000000000
DEC 10000000000
DTENS: OCT 2 ;11
OCT 351035564000
OCT 35 ;12
OCT 032451210000
OCT 443 ;13
OCT 011634520000
OCT 5536 ;14
OCT 142036440000
OCT 70657 ;15
OCT 324461500000
OCT 1070336 ;16
OCT 115760200000
OCT 13064257 ;17
OCT 013542400000
OCT 157013326 ;18
OCT 164731000000
;GENERATE CODE TO MOVE ACCUMULATORS TO A DISPLAY FIELD.
MACD.: MOVE T5,DTFLAG(DT) ;FLAGS
TXNE T5,DTBWZ ;BLANK WHEN ZERO?
JRST MACE. ;YES: USE EDIT
MACD.1: HLRZ T2,RESB ;GENERATE 'B' PARAMETER
LSH T2,^D12
ADD T2,SIZEB
TXNE SW,FBSIGN ;SIGNED
TRO T2,(<1B6>) ;YES:
HRLZS T2
HRR T2,BASEB ;EFFECTIVE ADDR
ADD T2,INCRB
PUSH LIT,T2
MOVEI CH,(LIT) ;ADDR OF LIT
MOVE T5,SIZEB ;1 OR 2 WORD COMP
MOVE T4,EAC
CAIG T5,^D10 ;?
ADDI T4,1
DPB T4,CHAC ;PLAC AC FIELD
PUSH LIT,CH ;SAVE PARAMETER WORD
MOVEI CH,(LIT) ;GET ITS ADDRESS
HRLI CH,(MOVE 16,) ;ADD IN MOVE 16,
PUSH COD,CH ;SAVE CODE
HRRZ T5,MODEB ;GET OUTPUT MODE
XCT MACDRU(T5) ;GET PROPER ROUTINE
HRLI CH,(PUSHJ PP,) ;CHANGE TO PUSHJ
PUSH COD,CH ;STASH CODE
POPJ PP,
MACDRU: ;AC'S TO DISPLAY OR COMP-3 ROUTINES
MOVEI CH,PD6.
MOVEI CH,PD7.
MOVEI CH,PD9.
PUSHJ PP,CDTMAC
PUSHJ PP,CDTMAC
PUSHJ PP,CDTMAC
PUSHJ PP,CDTMAC
MOVEI CH,PC3. ;COMP-3
CDTMAC: PTYPE [ASCIZ "?CBDINT MACD.1 error
"]
POPJ PP,
;GENERATE CODE TO MOVE AC'S TO A 1-WORD COMP OR INDEX.
MAC1C.: MOVSI CH,(MOVEM)
TXNN SW,FBSIGN ;SIGNED?
MOVSI CH,(MOVMM) ;NO:
JRST GENOPD
;GENERATE CODE TO MOVE AC'S TO A 2-WORD COMP.
MAC2C.: TXNN SW,FBSIGN ;SIGNED?
JRST MAC2C3 ;NO: USE MAGNITUDE
MAC2C2:
IFN BIS,<
MOVSI CH,(DMOVEM)
JRST GENOPE
>
IFE BIS,<
MOVSI CH,(MOVEM)
PUSHJ PP,GENOPE
MOVSI CH,(MOVEM)
AOS INCRB
JRST GENOPD
>
;HERE FOR POSSIBLE UNSIGNED MOVE
MAC2C3: TXNN SW,FASIGN ;'A' SIGNED?
JRST MAC2C2 ;NO - OK TO USE MOVE(S)
IFN BIS,<
MOVSI CH,(SKIPGE)
HRR CH,EAC
PUSH COD,CH
MOVSI CH,(DMOVN)
HRR CH,EAC
DPB CH,CHAC
PUSH COD,CH
>
IFE BIS,<
HRRZ CH,EAC
DPB CH,CHAC
PUSH LIT,CH
MOVEI CH,(LIT)
HRLI CH,(MOVE 16,)
PUSH COD,CH
PUSH COD,[PUSHJ PP,MAG.]
>
SETZM EAC
JRST MAC2C2
;GENERATE CODE TO MOVE AC'S TO COMP-1
MACFP.: ;CONVERT TO COMP-1
HRRZ CH,EAC
DPB CH,CHAC
PUSH LIT,CH
MOVEI CH,(LIT) ;GET ADDRESS
HRLI CH,(MOVE 16,)
PUSH COD,CH
PUSH COD,[PUSHJ PP,FLOT.2]
SOS EAC ;RESULT IN C(EAC)
MOVEI T5,FPMODE
MOVEM T5,MODEA
JRST MAC1C.
;GENERATE CODE TO MOVE AC'S TO EDITED FIELD.
MACE.: MOVE T1,[XWD BASEB,SAVMB]
BLT T1,SVMBX ;SAVE 'B' PARAMETERS
MOVEI T1,D6MODE ;SET MODE TO SIXBIT
MOVEM T1,MODEB
MOVE T1,SIZEB ;GET A TEMP LOC
ADDI T1,5
IDIVI T1,6
PUSHJ PP,GETEMP
MOVEM T1,INCRB
MOVE T1,[XWD ^D36,TEMROL]
MOVEM T1,BASEB
MOVE T1,[XWD BASEB,SAVMA]
BLT T1,SVMAX ;SAVE AS 'A' PARAMETER
PUSHJ PP,MACD.1 ;MOVE TO DISPLAY FIELD
MOVE T1,[XWD SAVMA,BASEA]
BLT T1,BASBX ;GET BACK 'A' AND 'B'
JRST MDED. ;DO EDIT AND RETURN
;GENERATE CODE TO MOVE A DISPLAY FIELD TO AN EDITED FIELD.
MDED.: ;FIX UP MODEB IF NECESSARY
MOVE T5,MODEB
CAIE T5,EDMODE
JRST MDED.0 ;OK
LDB T5,DTUSAG ;GET REAL USAGE
SUBI T5,1 ;NORMALIZE
CAIN T5,%US.IN-1 ;INDEX??
MOVEI T5,D1MODE ;USE COMP
MOVEM T5,MODEB ;AND STORE IT
MDED.0: PUSHJ PP,BMASK ;GET EDIT MASK
TXNE SW,FASIGN ;ANY SIGNS
TXNN SW,FBSIGN
JRST MDEU. ;NO: USE UNSIGNED ROUTINE
;BOTH FILEDS ARE SIGNED
MDES.: MOVE T5,[XWD BASEA,SAVMA]
BLT T5,SVMAX ;SAVE 'A'
MOVE T5,SIZEA
SUBI T5,1
PUSHJ PP,M.IA ;FIND SIGN
HRRZ T5,MODEA
HRLZ T5,BYTE.S(T5)
MOVNS T5
ADDM T5,RESA ;MESS PARAM
PUSHJ PP,MBYTEA ;GET FIRST LITERAL
PUSH COD,LIT
MOVE T5,[XWD SAVMA,BASEA]
BLT T5,BASAX ;GET 'A' BACK
MOVE CH,[PUSHJ PP,EDIT.S##]
JRST MDEU.2 ;STASH CODE AND EXIT
;GENERATE CODE FOR AN UNSIGNED EDITED FIELD.
MDEU.: MOVE CH,[PUSHJ PP,EDIT.U##]
MOVEI T5,1(LIT) ;ADDR OF LIT
PUSH COD,T5
MDEU.2: MOVEI T5,(MOVEI 16,)
HRLM T5,0(COD)
PUSH COD,CH ;AND PUSHJ
PUSHJ PP,MBYTEA ;GET A BYTE POINTER
HRRZ T5,MODEB
MOVE T2,BYTE.S(T5)
LSH T2,6
MOVE T5,DTFLAG(DT) ;GET FLAGS
TXNE T5,DTBWZ ;BLANK WHEN ZERO?
IORI T2,40 ;YES: SET BIT 12
ROT T2,-^D12
HLR T2,RESB
ROT T2,-6 ;FORM B.P.
HRR T2,BASEB
ADD T2,INCRB
PUSH LIT,T2 ;SASH AWAY
PUSH COD,W1 ;ALSO XWD LITERAL
POPJ PP, ;AND EXIT
;CREATE THE MASK FOR THE "B" FIELD.
BMASK: HRRZI W1,1(LIT) ;LOC OF LITERAL
HRLI W1,(<^D36B5>)
MOVE T3,DTFLAG(DT) ;GET FLAGS
TXNN T3,DTEDIT ;EDITED
JRST BMASK4 ;NO: BWZ THEN
HRRZ T3,DT ;FORM BYTEPNTRS
ADD T3,[POINT 4,DTBP,11]
LDB T4,[POINT 12,DTBP(DT),11]
DPB T4,[POINT 12,W1,17] ;SIGN CHARS
MOVEI T4,0 ;INIT REPEAT COUNT
BMASK1: MOVEI T2,0
MOVE T1,[POINT 4,T2]
BMASK2: ILDB T5,T3
CAIN T5,16 ;REPEAT??
JRST BMSK2B ;YES
BMSK2A: IDPB T5,T1 ;STORE BYTE
CAIN T5,17 ;END?
JRST BMASK3 ;YES:
TLNN T1,770000 ;WORD FULL?
JRST BMSK2C ;YES - SAVE LITERAL
BMSK2D: SOJLE T4,BMASK2 ;GO TO TOP IF NOTHING TO REPEAT
JRST BMSK2A ;USE BYTE AGAIN
BMSK2C: PUSH LIT,T2 ;YES: STASH
MOVEI T2,0 ;INIT LITERAL BUFFER
MOVE T1,[POINT 4,T2] ;AND POINTER
JRST BMSK2D ;AND CONTINUE
; REPEAT
; THE CODE IS FOLLOWED BY A COUNT OF THE NUMBER
; OF 4 BIT BYTES WHICH FOLLOW THE COUNT AND CONTAIN THE
; NUMBER OF REPEATS IN BINARY. THE BYTE FOLLOWING THE
; NUMBER OF REPEATS IS THE CHARACTER TO BE REPEATED.
BMSK2B:
PUSH PP,T2 ;SAVE A FEW REGS
PUSH PP,T1
ILDB T4,T3 ;GET NUMBER OF BYTES HOLDING FACTOR
LSH T4,2 ;COMPUTE BITS RIGHT
MOVE T5,[POINT 4,T4] ;RESULT POINTER
DPB T4,[POINT 6,T5,5] ;STORE BITS RIGHT
MOVEI T4,0 ;INITIALIZE REPEAT COUNT
LDB T2,T3 ;GET BYTE COUNT BACK
BMSK2F: ILDB T1,T3 ;GET BYTE OF COUNT
IDPB T1,T5 ;SAVE IN REPEAT REGISTER
SOJG T2,BMSK2F ;MOVE??
POP PP,T1 ;NO - DONE
POP PP,T2
JRST BMASK2 ;GO BACK TO TOP
BMASK3: PUSH LIT,T2 ;STASH LAST OP
POPJ PP, ;AND EXIT
;ITEM IS NOT EDITED SO IT MUST BE "BLANK WHEN ZERO".
BMASK4: MOVE T1,SIZEB
BMASK5: CAIGE T1,^D9
JRST BMASK6
PUSH LIT,[0]
SUBI T1,^D9
JUMPG T1,BMASK5 ;LUP UNTIL DONE
BMASK6: MOVEI T2,0
MOVE T3,[POINT 4,T2]
JUMPE T1,BMASK7 ;NO RESIDUE
IBP T3
SOJG T1,.-1
BMASK7: MOVEI T5,17
IDPB T5,T3
JRST BMASK3
;RANDOM BYTE POINTER DIDLERS
;GET A BYTE POINTER TO "A"
BYTE.A: MOVEI T5,BASEA
BYTE.X: HRRZ T3,MODEX(T5)
HLRZ T2,RESX(T5)
LSH T2,6
ADD T2,BYTE.S(T3)
ROT T2,-^D12
BYTE.Y: HRR T2,BASEX(T5)
ADD T2,INCRX(T5) ;ADDR OR WORD
POPJ PP,
;SIMILAR TO BYTE.A, EXCEPT FOR "B"
BYTE.B: MOVEI T5,BASEB
JRST BYTE.X
;SIMILAR TO BYTE.B, EXCEPT SIZE PUT IN BITS 6-17
BYTE.C: MOVEI T5,BASEB
HLRZ T2,RESB
LSH T2,^D12
ADD T2,SIZEB
HRLZS T2
JRST BYTE.Y
;CREATE BYTE POINTER TO 'A' AND PUT IN LITROL
MBYTEA: HLRZ T2,RESA
ROT T2,-6
HRRZ T3,MODEA
MOVE T3,BYTE.S(T3)
DPB T3,[POINT 6,T2,11]
HRR T2,BASEA
ADD T2,INCRA
PUSH LIT,T2
POPJ PP,
;INCREMENT PARAMETERS OF "A" OPERAND BY THE NUMBER
;OF BYTES WHOSE VALUE IS IN "T5".
M.IA: MOVE T3,MODEA
MOVE T4,T5
IDIV T4,BYTE.W(T3) ;ADJUST INCREMENT
ADDM T4,INCRA
HLRZ T4,RESA
IMUL T5,BYTE.S(T3)
SUB T4,T5
CAML T4,BYTE.S(T3)
JRST M.IA1
CAIN T3,D7MODE
SUBI T4,1
M.IA1: JUMPG T4,M.IA2 ;TO BIT 35 OR BEYOND
AOS INCRA ;YES:
ADDI T4,^D36
M.IA2: HRLM T4,RESA ;NEW RESIDUE
POPJ PP,
;SOME RANDOM GENERATORS
;GEN <OP AC+1,"A">
GENOPA: MOVE T5,EAC
AOSA T5
;GEN <OP AC,"A">
GENOPB: MOVE T5,EAC
DPB T5,CHAC
;GEN <OP "A">
GENOPC: HRR CH,BASEA
ADD CH,INCRA
PUSH COD,CH
POPJ PP,
;GEN <OP AC+1,"B">
GENOPD: MOVE T5,EAC
AOSA T5
;GEN <OP AC,"B">
GENOPE: MOVE T5,EAC
DPB T5,CHAC
;GEN <OP "B">
GENOPF: HRR CH,BASEB
ADD CH,INCRB
PUSH COD,CH
POPJ PP,
;GEN <MOVE 16,LIT
; PUSHJ 17,"B">
;
; PUSHJ PP,"B" IS IN CH
GENPUA: MOVE T5,EAC
AOSA T5
GENPUB: MOVE T5,EAC
LSH T5,22 ;MOVE TO AC FIELD
SKIPA
GENPUC: SKIPA T5,BASEA
HRR T5,BASEA
ADD T5,INCRA
PUSH LIT,T5
MOVSI T5,(MOVE 16,)
HRR T5,LIT
PUSH COD,T5
PUSH COD,CH ;PUSHJ PP,ROUTINE
POPJ PP,
;ERROR ROUTINES
BADBAD: TYPE [ASCIZ "?Illegal subscript usage"]
JRST XECUTC
DISERR: TYPE [ASCIZ "?DISPLAY internal error"]
JRST XECUTC
SMLSUB: TYPE [ASCIZ "?Subscript not positive"] ;[24]
JRST XECUTC ;[24]
LRGSUB: TYPE [ASCIZ "?Subscript too large"]
JRST XECUTC
NEDSUB: TYPE [ASCIZ "?Item must be subscripted"]
JRST XECUTC
NOSUB: TYPE [ASCIZ "?No subscripts allowed"]
JRST XECUTC
NOTNUF: TYPE [ASCIZ "?Not enough subscripts"]
JRST XECUTC
TOOFEW: TYPE [ASCIZ "?Too many subscripts"]
JRST XECUTC
UNDEF: TYPE [ASCIZ "?Symbol not defined"]
JRST XECUTC
IFE TOPS20,<
HIPART: TYPE [ASCIZ '?Not allowed for write-protected hi-segment procedures']
JRST XECUTC
>
;ROUTINE TO GET SOME TEMP STORAGE
GETEMP: ADD T1,TEMPC ;GET NEW TOP
CAIL T1,N.TMP ;OVER?
JRST NOTEMP
EXCH T1,TEMPC ;RETURN BASE
POPJ PP,
NOTEMP: TYPE [ASCIZ "?Not enough temp storage"]
JRST XECUTC
NOLAST: TYPE [ASCIZ "?No previous data-name"]
JRST XECUTC
;ROUTINE TO TYPE SYMBOL NAME FROM DNAME6
TYPSNM:
IFE BIS,<
MOVE T1,[POINT 6,DNAME6] ;COPY TO ASCII NAME
MOVE T2,[POINT 7,DNAME7]
>
IFN BIS,<
DMOVE T1,[POINT 6,DNAME6 ;COPY TO ASCII NAME
POINT 7,DNAME7]
>
TYPSN0: ILDB T3,T1 ;GET A CHAR
JUMPE T3,TYPSN1 ;JUMP IF BLANK
ADDI T3,40 ;MAKE IT ASCII
CAIN T3,":" ;MAKE COLONS INTO
MOVEI T3,"-" ;DASHES
CAIN T3,";" ;Make semicolon
MOVEI T3,"." ;Into dot
IDPB T3,T2
JRST TYPSN0 ;LOOP
POPJ PP,
TYPSN1: IDPB T3,T2 ;STORE NULL AT END
TYPE DNAME7 ;TYPE IT OUT
POPJ PP, ;RETURN
SUBTTL COMMAND PROCESSORS -- SHOW SYMBOLS
;SHOW SYMBOLS <SYMBOL-NAME-MASK> SHOWS ALL SYMBOLS FOR WHICH THE USER
; HAS TYPED A MATCHING MASK
DOSHOS: SKIPN @%DT ;ARE SYMBOLS AVAILABLE?
JRST [TYPE [ASCIZ/?No symbols available
/]
JRST XECUTX]
TXZ SW,NUIFLG ;SET FLAG IF AT LEAST ONE FOUND
HRRZ DT,@%NM ;MAKE DT POINT AT HDR OF NAMTAB ENTRIES
AOSA DT
DOSHO1: ADDI DT,1(W1) ;GET NEXT ENTRY
HLRZ W1,(DT) ;W1= LH(HDR) = # WORDS IN SYMBOL
JUMPE W1,DONSHO ;JUMP IF THRU TABLE
MOVE T1,1(DT) ;GET FIRST WORD OF SYMBOL NAME
CAMN T1,[SIXBIT /:GENER/] ;DON'T CHECK THESE
JRST DOSHO1
;DT POINTS TO A SYMBOL, W1 TELLS US HOW MANY WORDS IT IS.
; SEE IF THE MASK MATCHES.. IF SO, PRINT OUT THE SYMBOL.
; (SPEED IS NOT A CONSIDERATION IN THIS ALGORITHM)
MOVE W2,[POINT 6,DNAME6] ;PTR TO MASK
HRRZI T5,1(DT) ;PTR TO SYMBOL NAME
HRLI T5,(POINT 6,)
HRRZ T4,W1 ;GET # WORDS IN SYMBOL
IMULI T4,6 ;MAX # CHARS IN THE SYMBOL
DOSHO2: ILDB T1,W2 ;T1= CHAR FROM MASK
ILDB T2,T5 ;T5= CHAR FROM SYMBOL
PUSHJ PP,SHRMTC ;CALL RECURSIVE MATCH ROUTINE
JRST DOSHO1 ;NO MATCH, TRY NEXT SYMBOL
;HERE IF MASK MATCHES.. TYPE OUT SYMBOL
DOSHOY: MOVEI T1," " ;TYPE A SPACE
TYPEAC T1
PUSHJ PP,TYPNDT ;TYPE THE NAME
TYPE CRLF ;AND A CRLF
TXO SW,NUIFLG ;AT LEAST ONE MATCHED.. SET FLAG
JRST DOSHO1 ;LOOP FOR ALL SYMBOLS
;HERE WHEN DONE TABLE
DONSHO: TXNN SW,NUIFLG ;SKIP IF WE TYPED ANY
JRST [TYPE [ASCIZ/% No symbol names match input mask
/]
JRST .+1]
JRST XECUTX ;RETURN
;RECURSIVE ROUTINE TO MATCH REST OF SYMBOL NAME.
;W2/ PTR TO MASK
;T5/ PTR TO SYMBOL NAME
;T2/ CURRENT CHAR IN SYMBOL NAME
;T1/ CURRENT CHAR IN MASK
; PUSHJ PP,SHRMTC
; RETURN HERE IF NO MATCH
; RETURN HERE IF MATCH
SHRMTC: CAIN T1,"*"-40 ;STAR?
JRST DOSHST ;YES
CAIN T1,"?"-40 ;QUEST?
JRST DOSHQ1 ;YES
CAIE T1,(T2) ;EXACT MATCH?
POPJ PP, ;NO, RETURN
JUMPE T1,CPOPJ1 ;IF BOTH NULLS, EXACT MATCH
DOCMT: SOJGE T4,[ILDB T1,W2
ILDB T2,T5
JRST SHRMTC] ;GO TRY NEXT SET OF CHARS
ILDB T1,W2 ;IF A MATCH, MASK WILL HAVE RUN OUT
CAIN T1,"*"-40
JRST .-2 ;MORE STARS ARE OK
JUMPN T1,CPOPJ ;ELSE NO MATCH
JRST CPOPJ1
;HERE IF "?" SEEN. MATCH ANY CHAR.
DOSHQ1: JUMPN T2,DOCMT ;OK IF T2 NOT NULL
POPJ PP, ;ELSE NO MATCH
;HERE IF "*" SEEN. MATCH 0 OR MORE CHARACTERS.
; CALL OURSELF RECURSIVELY TO CHECK ALL POSSIBLE MATCHES.
DOSHST: ILDB T1,W2 ;GET NEXT CHAR OF MASK
CAIN T1,"*"-40 ;STAR AGAIN?
JRST .-2 ;YES, EAT EXTRAS
JUMPE T1,CPOPJ1 ;NO MORE MASK, MATCHES
DOSHS0: PUSH PP,W2 ;SAVE PTR
PUSH PP,T5 ;SAVE PTR
PUSH PP,T4 ;SAVE CHAR COUNT
PUSHJ PP,SHRMTC ;DOES THE REST MATCH?
JRST DOSHS1 ;NO
POP PP,T4 ;YES
POP PP,T5
POP PP,W2
JRST CPOPJ1 ;GOOD RETURN
;STUFF AFTER * DIDN'T MATCH
DOSHS1: POP PP,T4
POP PP,T5
POP PP,W2
SOJLE T4,CPOPJ ;NO MATCH IF NO MORE CHARS IN SYMBOL NAME
ILDB T2,T5 ;SKIP A CHAR IN SYMBOL NAME
JUMPE T2,CPOPJ ;NO MORE.. NO MATCH
LDB T1,W2 ;REGET THIS CHAR IN MASK
JRST DOSHS0 ;TRY NOW
;ROUTINE TO TYPE SYMBOL NAME FROM "DT"
;DT POINTS TO NAMTAB ENTRY
TYPNDT: HLRZ T4,(DT) ;LENGTH OF SYMBOL IN WORDS
MOVEI T2,(DT)
TYPND1: MOVE T5,[POINT 6,T3] ;PTR TO SIXBIT WORD
ADDI T2,1
MOVE T3,(T2) ;GET NEXT SIXBIT WORD FROM ENTRY
TYPND2: TLNN T5,760000 ;PTR DONE?
JRST TYPND3 ;YES
ILDB T1,T5 ;NO, GET A CHAR
JUMPE T1,TYPND4 ;SPACE-- SYMBOL NAME DONE
ADDI T1," " ;MAKE ASCII
CAIN T1,":" ;Convert colon to dash,
MOVEI T1,"-"
CAIN T1,";" ;Convert semi-colon to "."
MOVEI T1,"."
TYPEAC (T1) ;TYPE IT
JRST TYPND2 ;LOOP
TYPND3: SOJG T4,TYPND1 ;LOOP IF MORE WORDS TO DO
TYPND4: POPJ PP, ;RETURN
SUBTTL LOOKNM -- SEARCH FOR A COBOL NAME IN THE SYMBOL TABLE.
; RETURNS DT AND SKIPS IF FOUND.
;ABBREVIATIONS ARE ALLOWED IF UNIQUE.
;FILENAMES ARE ALLOWED AS SYMBOL NAMES IF FLAG "FLNMOK" IS SET.
LOOKNM: SKIPN @%DT ;ARE SYMBOLS AVAILABLE?
JRST NOSYMS ;NO, GIVE ERROR
TXZ SW,NUIFLG ;CLEAR NOT UNIQUE INITIAL SEGMENT FLAG
MOVEI W2,5 ;MAKE (T3)= # FULL WORDS IN DNAME6
SKIPN T1,DNAME6-1(W2)
SOJA W2,.-1 ;CONTINUE UNTIL W2 HAS LENGTH OF SYMBOL TYPED
SETO W1, ;MAKE W1 A MASK FOR TRAILING BLANKS
LSH W1,-6 ; OF PARTIAL WORD
TDNE T1,W1
JRST .-2
HRRZ DT,@%NM ;MAKE DT POINT AT HDR OF NAMTAB ENTRIES
AOSA DT ;LH (DT) IS PTR TO FIRST MATCHING PROPER INI. SEG.
;(=0, IF NONE YET)
LOOKN1: ADDI DT,1(T4) ;GET NEXT ENTRY
HLRZ T4,(DT) ;T4=LH(HDR)
JUMPE T4,LOOKN5 ;JUMP IF THRU TABLE
CAMLE W2,T4 ;DON'T BOTHER IF USER SYMBOL LARGER
JRST LOOKN1
HRRZI T2,(DT) ;INIT LOOP TO COMPARE DNAME6 WITH ENTRY
SETZI T3,
LOOKN3: ADDI T2,1
MOVE T1,(T2) ;GET NEXT SIXBIT WORD FROM ENTRY
CAME T1,DNAME6(T3)
JRST LOOKN4 ;SYMBOL DOESN'T MATCH
CAIGE T3,-1(T4)
AOJA T3,LOOKN3
CAIE T4,5
SKIPN DNAME6+1(T3)
JRST CPOPJ1 ;SUCCESS
JRST LOOKN1 ;C(DNAM6) LONGER THAN CURRENT ENTRY
LOOKN4: MOVE T2,DNAME6(T3) ;TRY MASK ONLY IF C(TE(TH)) IS PARTIAL WORD
JUMPE T2,LOOKN6
TRNE T2,77
JRST LOOKN1 ;FAILED ON FULL WORD FROM DNAME6
ANDCM T1,W1 ;MASK OUT TRAILING CHARS.
CAME T1,DNAME6(T3)
JRST LOOKN1 ;NOT INITIAL SEGMENT.
LOOKN6: TLNE DT,-1 ;YES
TXOA SW,NUIFLG ;WE HAVE SEEN AT LEAST 2 INIT SEG.
HRLS DT ;SAVE PTR TO MATCHING INITIAL SEGMENT
JRST LOOKN1
LOOKN5: TXNE SW,FLNMOK ;FILENAMES OK TOO?
JRST LOOKNF ;YES, CHECK THEM TOO
TXNE SW,NUIFLG ;THRU TABLE
JRST NOTUNQ ;NOT UNIQUE
HLRZS DT
JRST CPOPJ1 ;RETURN, GOOD SYMBOL FOUND
;LOOK AT FILENAMES TO SEE IF ANY MATCH
; THE WHOLE THING IS MADE TO WORK AS IF FILENAMES WERE JUST MORE
; SYMBOL NAMES
LOOKNF: MOVEI T1,^D30 ;UP TO 30 CHARS IN DNAME6
MOVE T2,[POINT 6,DNAME6] ;POINT TO INPUT NAME.
;WE HAD TRANSLATED "-" TO ":". FILE NAMES ARE STORED WITH DASHES,
; SO MAKE THEM "-" AGAIN!
LOOKF0: SOJL T1,LOOKF1 ;JUMP WHEN DONE
ILDB T3,T2 ;GET CHARACTER
CAIE T3,":"-40 ;SKIP IF IT NEEDS TRANSLATING BACK..
JRST LOOKF0 ;NO, CONTINUE
MOVEI T3,"-"-40 ;YES, MAKE IT A "-" AGAIN
DPB T3,T2
JRST LOOKF0 ;LOOP
LOOKF1: PUSH PP,DT ;SAVE WHAT WE GOT SO FAR
TXNE SW,NUIFLG ;ALREADY NOT UNIQUE?
JRST LOKNFU ;YEAH, SEE IF THIS CLEARS IT UP
PUSHJ PP,LOKNF1 ;LOOK FOR MATCHING FILENAMES
TXNE SW,NUIFLG ;NOT UNIQUE?
JRST LOKFE1 ;NOT UNIQUE BECAUSE OF FILENAMES
SKIPE DT ;ANY FILENAME MATCH?
JRST LOKRTF ;YES, RETURN IT
POP PP,DT ;NO, RESTORE OLD DT
HLRZS DT ;JUST A PLAIN SYMBOL, OR NOTHING MATCHED
JRST CPOPJ1 ;RETURN OK
;LOOK FOR MATCHING FILENAMES, ALREADY HAVE TWO POSSIBLE MATCHES
LOKNFU: PUSHJ PP,LOKNF1 ;LOOK FOR MATCHING FILENAMES
TXNE SW,NUIFLG ;STILL NOT UNIQUE?
JRST [POP PP,(PP) ;YES, THROW AWAY OLD DT.
JRST NOTUNQ] ;GO GIVE ERROR.
;RETURN FILENAME
LOKRTF: POP PP,(PP) ;THROW AWAY OLD DT.
HLRZS DT ;GET GOOD FILENAME
TXO DT,1B1 ;SET BIT 1 FOR "FILENAME"
JRST CPOPJ1 ;RETURN OK
;SUBROUTINE TO LOOK AT FILENAMES AND CONTINUE PLAYING WITH NUIFLG, ETC.
;-1(PP) IS DT SO FAR.
LOKNF1: SETZ DT, ;START WITH FRESH "DT".
MOVE T1,CUREPA ;GET CURRENT ENTRY POINT ADDRESS
HRRZ T1,1(T1) ;RH(ENTRY-POINT) + 1 = %FILES
MOVE T1,(T1) ;GET ADDRESS OF FIRST FILE TABLE.
MOVEI T2,1 ;T2= FILE NUMBER
;W2 HAS NUMBER OF WORDS OF SYMBOL TYPED
;W1 HAS MASK OF LAST WORD TYPED.
;HERE WITH NEXT FILE TABLE ADDRESS IN T1.
;** WARNING: THE FOLLOWING CODE IS DEPENDENT ON LIBOL FILE-TABLE STRUCTURE **
LOKNF2: PUSH PP,T1 ;SAVE FT ADDRESS
SETZ T3, ;INDEX
LOKNF3: MOVE T4,(T1) ;GET NEXT WORD OF F.T. NAME
CAME T4,DNAME6(T3) ;DOES IT MATCH?
JRST LOKNF4 ;NO
ADDI T3,1 ;YES, COUNT ANOTHER WORD MATCHED
CAIE T3,(W2) ;DID WE LOOK AT ALL FULL WORDS?
AOJA T1,LOKNF3 ;NO, LOOK AT MORE WORDS.
CAIE T3,5 ;MATCHED 5 WORDS?
SKIPN 1(T1) ;OR NO MORE FILENAME?
JRST LOKNFG ;YES, EXACT MATCH.
JRST LOKNFA ;ABBREV. MATCH.
LOKNF4: MOVE T3,DNAME6(T3) ;TRY MASK ONLY IF LAST IS PARTIAL WORD
JUMPE T3,LOKNFA ;ABBREV. MATCH
TRNE T3,77
JRST LOKNFN ;NO MATCH FOR THIS FULL WORD
ANDCM T4,W1 ;MASK OUT TRAILING CHARS.
CAME T4,T3 ;DOES IT MATCH AS FAR AS WE TYPED?
JRST LOKNFN ;NO, GO ON TO NEXT F.T.
;AN ABBREVIATED MATCH FOR THIS NAME.
LOKNFA: POP PP,T1 ;RESTORE F.T. ADDRESS
MOVE T3,-1(PP) ;T3= DT FROM THE SYMBOL SEARCH
TLNE T3,-1 ;ALREADY SEEN A MATCHING SYMBOL?
TXO SW,NUIFLG ;YES, SET "NOT UNIQUE"
TLNE DT,-1 ;ALREADY SEEN A MATCHING FILENAME?
TXOA SW,NUIFLG ;YES, SET "NOT UNIQUE"
HRLZ DT,T2 ;SAVE MATCHING FILE NUMBER
JRST LOKNXF ;GO LOOK AT MORE FILENAMES
;GOT AN EXACT MATCH
LOKNFG: POP PP,(PP) ;STOP SEARCH NOW..FIXUP STACK
TXZ SW,NUIFLG ;TURN OFF "NOT UNIQUE" FLAG
HRLZ DT,T2 ;REMEMBER FILE NUMBER THAT MATCHED.
POPJ PP, ;RETURN
;NO MATCH FOR THIS FILE NAME
LOKNFN: POP PP,T1 ;RESTORE F.T. ADDRESS
;CHECK FOR MORE FILES
LOKNXF: HRRZ T1,F.RNFT(T1) ;GET ADDRESS OF NEXT FILE TABLE
SKIPN T1 ;IS THERE ANY?
POPJ PP, ;NO, DONE, RETURN.
AOJA T2,LOKNF2 ;GO LOOK AT THE NEXT ONE
;NOT UNIQUE SYMBOL, BECAUSE AT LEAST ONE FILENAME MATCHED.
LOKFE1: TYPE [ASCIZ/? "/]
PUSHJ PP,TYPSNM ;TYPE SYMBOL NAME
TYPE [ASCIZ/" matches initial segments of more than one symbol,
including at least one of the file names defined in the module.
/]
POPJ PP, ;ERROR RETURN
;NOT UNIQUE SYMBOL ERROR.
NOTUNQ: TYPE [ASCIZ/? "/]
PUSHJ PP,TYPSNM ;TYPE SYMBOL NAME
TYPE [ASCIZ/" matches initial segments of more than one symbol
(Type "SHOW SYMBOLS /]
PUSHJ PP,TYPSNM ;TYPE IT AGAIN
TYPE [ASCIZ/*" to get a list of matching symbols)
/]
POPJ PP, ;ERROR RETURN
NOSYMS: TYPE [ASCIZ/? No symbols
/]
POPJ PP,
CPOPJ2: AOS (PP)
CPOPJ1: AOS (PP)
CPOPJ: POPJ PP,
SUBTTL QUAL--SEARCH FOR (QUALIFIED) NAME.
;PP LOCATES STACK OF POINTERS TO NAMES IN NAMTAB,
;WITH HIGHEST LEVEL QUALIFIER ON TOP OF STACK, AND -1 MARKING BOTTOM.
;CALL: (FLAGS: PNFLG SET IF PROCEDURE NAME IS ALLOWED
; DNFLG SET IF DATANAME IS ALLOWED)
; PUSHJ PP,QUAL
; ** WARNING: ALWAYS CALL WITH "PUSHJ PP,QUAL" , NOT PJRST! **
;RETURNS:
; .+1 IF ERROR, ERROR MESSAGE TYPED
; .+2 IF A UNIQUE ENTRY WAS FOUND, ABS ADDRESS OF ENTRY IN W2.
; ALSO FLAG "PRNMFG" IS SET IF ENTRY IS A PROTAB ENTRY.
QUAL: SETZI W2, ;CLEAR W2 INDICATING NO SUCCES YET
;GO DOWN THE STACK TO LOWEST LEVEL ENTRY.
HRRZ T1,PP
SUBI T1,1 ;ACCOUNT FOR PUSHJ TO QUAL
SKIPL -1(T1)
SOJA T1,.-1
;RH(T1) POINTS AT FIRST NAMPTR ON STACK
;ERROR CHECK: Check the first symbol he mentioned.
; If it is a dataname, make sure we are looking for one.
; If it is a procedure name, set "PRNMFG" and make sure we want one.
MOVE T2,(T1) ;GET NAMTAB ITEM
HRRZ T2,(T2) ;GET LINK TO FIRST DATAB OR PROTAB OF THAT NAME
TRC T2,DTTYPE ;IS IT A DATANAME?
TRNE T2,TYPMSK
JRST QUALP ;PROCEDURE NAME
TXNN SW,DNFLG ;LOOKING FOR DATAB ENTRY?
JRST QUALE1 ;NO, GIVE ERROR
TRO T2,DTTYPE ;SET DATANAME BITS AGAIN
;FALL THRU TO NEXT PAGE
;SEARCH FOR QUALIFIED DATANAME
;RH (T2) WILL POINT TO THE NEXT DATAB ITEM OF THAT NAME
;LH (T1) WILL HAVE THE ADDRESS OF A MATCHING ENTRY IF FOUND
;T4= ITEM IN TREE WHERE QUALIFIERS HAVE TAKEN US
;HERE TO CHECK NEXT ITEM OF SAME NAME (ITEM IN T2)
QUAL2: MOVEI T3,(T1) ;START AT BOTTOM OF STACK
HRRZ T4,T2 ;GET DATAB LINK
QUAL2A: CAIGE T3,-1(PP) ;ALL QUALIFIERS MATCHED?
JRST QUAL3 ;NO
;WE'VE FOUND A MATCHING DATA TABLE ENTRY
TLNE T1,-1 ;DID WE ALREADY FIND ONE?
JRST QUALE3 ;YES, "Not uniquely qualified"
HRL T1,T2 ;COPY LINK
;CHECK OTHER ITEMS OF THE SAME NAME
QUAL2B: TRZ T2,DTTYPE ;GET NEXT ITEM OF SAME NAME
ADD T2,@%DT
HRRZ T2,(T2)
JUMPN T2,QUAL2 ;GO SEE IF IT MATCHES
;DONE CHECKING ALL ITEMS OF THE SAME NAME
TLNN T1,-1 ;ANY MATCH FOUND?
JRST QUALE2 ;NO, "Improper qualfication"
;FOUND EXACTLY ONE ITEM THAT MATCHED
HLRZ T1,T1 ;GET MATCHING ITEM
TRZ T1,DTTYPE ;CLEAR TYPE BITS
ADD T1,@%DT ;GET ABS. ADDRESS OF ENTRY
HRRZ W2,T1 ;GET MATCHING ITEM (JUST RH)
JRST CPOPJ1 ;AND RETURN
;MORE QUALIFIERS WERE GIVEN, TRY TO MATCH THEM FOR THIS ITEM
QUAL3: ADDI T3,1 ;LOOK AT NEXT QUALIFIER GIVEN
MOVE T5,(T3) ;T5 IS NAME OF QUALIFIER
;LOOK AT NEXT FATHER
QUAL30: TXNE T4,1B1 ;ARE WE AT FILENAME ALREADY?
JRST QUAL2B ;YES, NO MATCH FOR THIS ITEM
TRZ T4,DTTYPE
ADD T4,@%DT ;T4=FATHER(T4)
HLRZ T4,DTSON(T4)
JUMPE T4,QUAL2B ;NO MATCH
TRNE T4,DTTYPE ;IS FATHER A DATANAME?
JRST QUAL3A ;YES
TXO T4,1B1 ;NO, A FILENAME, SET BIT
CAMN T5,T4 ;DOES QUALIFIER MATCH FILENAME?
JRST QUAL2A ;YES, GO ON TO CHECK FOR MORE QUALIFIERS
; (IT WILL BE ERROR IF MORE WERE TYPED)
JRST QUAL2B ;NO, NO MATCH FOR THIS ITEM
;CHECK FATHER (DATANAME) NAME AGAINST THIS QUALIFIER.
; IF NO MATCH, GO BACK TO QUAL30 TO GO UP THE TREE AND CHECK NEXT FATHER, ETC.
QUAL3A: HRL T3,T4 ;SAVE DATAB LINK OF FATHER
TRZ T4,DTTYPE ;FIND NAMTAB LINK
ADD T4,@%DT
LDB T4,NMLINK
ADD T4,@%NM ;ADD NAMTAB OFFSET
CAMN T5,T4 ;QUALIFIER MATCH?
JRST [HLRZ T4,T3 ;YES, GET DATAB LINK AGAIN
TLZ T3,-1 ;CLEAR LH(T3)
JRST QUAL2A] ;GO ON IF MORE QUALFIERS
HLRZ T4,T3 ;GET READY TO CHECK ITS FATHER
TLZ T3,-1 ;CLEAR LH(T3)
JRST QUAL30
;PROCEDURE NAME QUALIFICATION
; THIS HAS THE SAME LOGIC AS QUAL2 THRU QUAL3A, EXCEPT
; THE METHOD OF GETTING FATHER AND NAMTAB LINKS IS DIFFERENT
QUALP: TRC T2,DTTYPE ;TOGGLE BITS AGAIN
TXNN SW,PNFLG ; PROCEDURE NAME OK?
JRST QUALE4 ;NO, GIVE ERROR
TXO SW,PRNMFG ;SET "GOT PROCEDURE NAME"
;HERE TO CHECK NEXT ITEM OF SAME NAME
QULP2: MOVEI T3,(T1) ;START AT BOTTOM OF STACK
CAIGE T3,-1(PP) ;ANY QUALIFIERS?
JRST QULP3 ;YES, GO CHECK THEM
;WE'VE FOUND A MATCHING PROTAB ENTRY
QULP2A: TLNE T1,-1 ;DID WE ALREADY FIND ONE?
JRST QUALE3 ;YES, "Not uniquely defined"
HRL T1,T2 ;COPY LINK
;CHECK OTHER ITEMS OF THE SAME NAME
QULP2B: TRZ T2,PRTYPE ;GET NEXT ITEM OF SAME NAME
ADD T2,@%PR
HRRZ T2,(T2) ;GET NEXT ITEM OF THE SAME NAME
JUMPN T2,QULP2 ;GO SEE IF IT MATCHES
;DONE CHECKING ALL ITEMS OF THE SAME NAME
TLNN T1,-1 ;ANY MATCH FOUND?
JRST QUALE2 ;NO, "Improper qualfication"
;FOUND EXACTLY ONE ITEM THAT MATCHED
HLRZ T1,T1 ;GET MATCHING ITEM
TRZ T1,PRTYPE ;CLEAR TYPE BITS
ADD T1,@%PR ;POINT TO ENTRY
HRRZ W2,T1 ;GET ITEM, JUST SAVE RIGHT HALF
JRST CPOPJ1 ;AND RETURN SUCCESSFUL MATCH
;MORE PROCEDURE NAME QUALIFICATION CODE ON NEXT PAGE..
;A QUALIFIER WAS GIVEN, TRY TO MATCH IT FOR THIS ITEM
QULP3: ADDI T3,1 ;LOOK AT NEXT QUALIFIER GIVEN
CAIGE T3,-1(PP) ;BY THE WAY, ONLY ONE ALLOWED
JRST QUALE2 ;ELSE "Improper qualification"
MOVE T5,(T3) ;T5 IS NAME OF QUALIFIER
TXNE T5,1B1 ;FILENAMES NOT ALLOWED
JRST QUALE2 ;"improper qualification"
;ITEM MUST BE A PARAGRAPH NAME IN A SECTION, AND THE SECTION NAME
; MUST MATCH
MOVE T4,T2 ;GET PROTAB LINK
TRZ T4,PRTYPE ;CLEAR TYPE BITS
ADD T4,@%PR ;LOOK AT THE PROTAB ENTRY
HRRZ T5,PR.FLG(T4) ;LOOK AT PAR/SECT FLAG
ANDI T5,PR%SEC ;T5=0 IF SECTION NAME
JUMPE T5,QUALE2 ;"Improper qualification"
;SECTION NAME MUST MATCH
LDB T4,SECNAM ;GET SECTION NAME FROM ENTRY IN T4
ADD T4,@%PR
LDB T4,NMLINK
ADD T4,@%NM ;ADD NAMTAB OFFSET
MOVE T5,(T3) ;GET NAME OF QUALIFIER
CAMN T5,T4 ;SAME NAME?
JRST QULP2A ;YES, A MATCH
JRST QULP2B ;NO MATCH, GO TRY OTHERS OF SAME NAME
;QUAL ERRORS
;SAW A DATANAME, BUT WE WEREN'T LOOKING FOR ONE.
QUALE1: MOVE DT,(T1) ;POINT TO NAMTAB ITEM
TYPE [ASCIZ/?Not a procedure name: /]
PUSHJ PP,TYPNDT ;TYPE SYMBOL NAME
TYPE CRLF ;TYPE A CRLF
POPJ PP, ;RETURN
;IMPROPER QUALIFICATION
QUALE2: TYPE [ASCIZ/?Improper qualification
/]
POPJ PP, ;RETURN
;NOT UNIQUELY QUALIFIED
QUALE3: TYPE [ASCIZ/?Not uniquely defined, use more qualification
/]
POPJ PP, ;RETURN
;SAW A PROCEDURE NAME, BUT WE WEREN'T LOOKING FOR ONE
QUALE4: MOVE DT,(T1) ;POINT TO SYMBOL'S NAMTAB ENTRY
TYPE [ASCIZ/?Not a dataname: /]
PUSHJ PP,TYPNDT ;TYPE SYMBOL NAME
TYPE CRLF
POPJ PP, ;RETURN
SUBTTL COMMAND PROCESSORS -- NEXT
NEXT1: SKIPN LAST. ;ANY SAVED NAME?
JRST NOLAST ;NO, COMPLAIN
SKIPN SAVSUB ;[24]ANY SUBSCRIPTS ON LAST REFERENCE?
JRST [ TYPE [ASCIZ/?Previous name not subscripted
/]
JRST XECUTX]
;CAREFUL!! SUBSCRIPTS HAVE BEEN
;STORED IN REVERSE ORDER
SKIPN @%NM ;[26] DO WE HAVE A NAMTAB?
JRST [ TYPE [ASCIZ/?No symbols for this module
/]
JRST XECUTX]
ADDM W2,SAVSUB+1 ;[24] INCR/DECR LEAST SUBSCRIPT
SETZB W2,DT ;[24] SHOW NO NEW NAME TO DISPLAY, USE LAST PARSED NAME
MOVEI W1,DISPGN ;DISPLAY..
JRST CODGNR ;GO GENERATE CODE AND DO IT
SUBTTL COMMAND PROCESSORS -- MODULE
;HERE WHEN "MODULE <CRLF>" TYPED
; SHOW WHAT MODULES ARE IN MEMORY
MODH: TYPE [ASCIZ /
Current module: /]
MOVE T2,CUREPA ;GET ENTRY POINT ADDRESS
PUSHJ PP,PRTMNM
SKIPE SUBSPR ;[26] ANY OTHERS?
JRST MODJ ;[26] YES
MOVE T2,CUREPA ;[27]RELOAD T2
HRRZ T2,1(T2) ;[26] GET ADDR OF %FILES
HRRZ T2,%%NM.(T2) ;[26] GET NAMTAB BASE
JUMPN T2,MODX ;[26] DO WE HAVE ONE?
TYPE [ASCIZ / (No symbols)/] ;[26] NO
JRST MODX ;[26]
MODJ: TYPE [ASCIZ /
Modules currently in core:/]
MOVE NM,ETYPTS ;[26] GET ENTRY PTS TABLE
MODL: SKIPN T2,(NM) ;IS IT THERE?
AOBJN NM,MODL ;NO, ARE THERE MORE?
JUMPGE NM,MODX ;[26] ALL DONE?
TYPE CRLF
TYPEC " " ;TYPE A SPACE
PUSHJ PP,PRTMNM
HRRZ T2,(NM) ;[26] GET ENTRY PT AGAIN
HRRZ T2,1(T2) ;[26] GET ADDR OF %FILES
HRRZ T2,%%NM.(T2) ;[26] GET ADDR OF NAMTAB
JUMPN T2,MODM ;[26] IS IT THERE?
TYPE [ASCIZ / (No symbols)/] ;[26]
MODM: AOBJN NM,MODL ;ANY MORE?
MODX: JRST XECUTC ;NO, RETURN TO COMMAND SCANNER
;HERE FOR "MODULE <NAME>" THE NAME IS IN SIXBIT IN T5
MOD.1: MOVE NM,ETYPTS ;GET POINTER TO TABLE OF MAIN ADDRESSES
MOD.11: SKIPE T3,(NM) ;IS THERE ONE THERE? (THEY MAY
;DISAPPEAR, IF THEY ARE IN
;LINK-10 OVERLAYS.)
CAME T5,-1(T3) ;YES, IS THIS THE ONE?
AOBJN NM,MOD.11 ;NO, IF THERE ARE MORE, GO LOOK AT THEM
JUMPGE NM,NOTLDD ;"PROGRAM NOT LOADED"
HRRZM T3,CUREPA ;SAVE AS CURRENT ENTRY POINT
HRRZ T4,1(T3) ;GET ADDRESS OF %FILES FOR THE
; SPECIFIED MODULE
HRRZ T2,%%NM.(T4) ;GET ADDR OF SYMBOL TABLE ADDRESSES
JUMPE T2,NOSYMM ;"NO SYMBOLS FOR THAT MODULE"
PUSHJ PP,GTTABS ;GET TABLE ADDRESSES
JRST XECUTX ;BACK TO COMMAND SCANNER
NOTLDD: TYPE [ASCIZ/? Program not loaded
/]
JRST XECUTX ;BACK TO COMMAND SCANNER
NOSYMM: TYPE [ASCIZ/ No symbols for that module
/]
JRST XECUTX ;BACK TO COMMAND SCANNER
SUBTTL COBDDT DEATH (FATAL ERROR, CAN'T CONTINUE)
;$DIE macro translates to JRST CBDABT.
CBDABT:
IFN TOPS20,<
HALTF% ;Stop program the TOPS-20 way
>
IFE TOPS20,<
CALLI 1,12 ;Stop program the TOPS-10 way.
>
JRST CBDABT ;CONTINUE immediately aborts again.
SUBTTL COBOL-74 DEBUG MODULE
ENTRY DEBST.
ENTRY DBPRO.
ENTRY DBALT.
ENTRY DBIO. ;DEBUG ON OPEN, CLOSE, START FILE-NAME
ENTRY DBRD.
ENTRY DBCD. ;DEBUG ON CD-NAME
ENTRY DBDA. ;DEBUG ON DATA-NAME
SUBTTL INITIALIZATION
;CALLED FROM USER PROGRAM BEFORE CALL TO COBDDT
;CALLED BY
;
; JSP 16,DEBST.
DEBST.: SETZM DEBUG. ;ASSUME WE DON'T WANT DEBUG MODULE
IFN TOPS20,<
MOVEI T1,.LNSJB ;JOB-WIDE LOGICAL NAMES
HRROI T2,[ASCIZ /DEBUG-MODE/]
MOVE T3,[POINT 7,TEMP1]
LNMST%
JRST NODEB ;NO LOGICAL NAME
MOVE T3,TEMP1 ;GET NAME
>
IFE TOPS20,<
MOVE T1,[.TCRRF,,['DEB',,0
IOWD 1,T3]]
TMPCOR T1,
JRST NODEB ;NO TMPCOR FILE
>
AND T3,[BYTE (7) 177,177] ;CLEAR JUNK AFTER "ON"
CAMN T3,[ASCIZ /ON/]
SETOM DEBUG. ;USE DEBUG MODULE
NODEB: JRST 0(16)
SUBTTL DEBUGGING ON PROCEDURE-NAME
;CALLED FROM COBDDT, USE CODE IS
; PUSHJ 17,C.TRCE
; FLAGS ,, %PR
; <OPTIONAL EXTRA WORDS>
; %PARAM ,, USE-PROCEDURE
;
;WHERE %PARAM CONTAINS
; FLAGS ,, LINE#
;ON ENTRY T5 CONTAINS NO. OF DATA WORDS FOLLOWING TRACE CALL
DBPRO.: SKIPN DEBUG. ;DO WE NEED IT?
JRST CNPOPJ ;NO, RETURN TO USER
PUSHJ PP,ZDEB ;ZERO DEBUG-ITEM
HRRZ AP,(PP) ;GET USER'S ARG
HRRZ T1,(AP) ;OFFSET TO PROTAB
PUSHJ PP,PRONAM ;PUT IN PROCEDURE-NAME
ADDI AP,-1(T5) ;BYPASS EXTRA WORDS
HLRZ T2,(AP) ;GET %PARAM+N
HRRZ T2,(T2) ;GET LINE NUMBER
SKIPN T2 ;ZERO IS NOT LEGAL
HALT .+1
PUSHJ PP,LINENO ;PUT IN LINE NUMBER
HLRZ T1,(AP) ;GET %PARAM+N AGAIN
HLRZ T1,(T1) ;GET INDEX TO DEBUG-CONTENTS
JUMPE T1,XCTPRO ;NOTHING SPECIAL
MOVE T1,DBPTB-1(T1) ;GET MESSAGE
PUSHJ PP,CNFILL ;COPY TO DEBUG-CONTENTS
;EXECUTE THE USERS DEBUGGING ROUTINE
XCTPRO: ADDM T5,0(PP) ;FIXUP THE RETURN
HRRZ T1,(AP) ;GET USE PROCEDURE
JRST UPOPJ ;GO TO USER
;FILL IN DEBUG-CONTENTS
CNFILL: MOVE T2,DP.CON
FILL: HLRZ T3,T1 ;GET COUNT
HRLI T1,(POINT 6,) ;INPUT BYTE POINTER
ADD T2,DBITEM ;OUTPUT BYTE POINTER
FILL1: ILDB T4,T1
IDPB T4,T2
SOJG T3,FILL1
POPJ PP,
SUBTTL DUBUGGING ON ALTER STATEMENT
;CALLED FROM USER CODE BY
; PUSHJ 17,DBALT.
; TO ,,FROM
; LINE# ,,USE PROCEDURE
DBALT.: SKIPN DEBUG. ;DO WE NEED IT
JRST CPOPJ2 ;NO
PUSHJ PP,ZDEB ;ZERO DEBUG-ITEM
HRRZ AP,(PP) ;GET USER'S ARG
HLRZ T2,1(AP) ;GET LINE NUMBER
PUSHJ PP,LINENO ;PUT IN LINE NUMBER
HRRZ T1,(AP) ;OFFSET TO PROTAB
PUSHJ PP,PRONAM ;PUT IN PROCEDURE-NAME
HLRZ T1,(AP) ;OFFSET TO PROTAB
MOVE T2,DP.CON ;COPY "FROM" NAME TO DEBUG-CONTENTS
PUSHJ PP,PRNM1 ;PUT IN PROCEDURE-NAME
MOVEI T5,2 ;NO. OF INST TO SKIP
AOJA AP,XCTPRO ;GO TO USER'S ROUTINE
SUBTTL DEBUGGING ON FILE-NAME
;CALLED FROM USER PROGRAM BY
; PUSHJ 17,DBIO.
; LINE# ,,FILE-TABLE
DBIO.: SKIPN DEBUG. ;DO WE NEED IT
JRST CPOPJ1 ;NO
PUSHJ PP,ZDEB ;ZERO DEBUG-ITEM
HRRZ AP,(PP) ;GET USER'S ARG
HLRZ T2,(AP) ;GET LINE NUMBER
PUSHJ PP,LINENO ;PUT IN LINE NUMBER
HRRZ AP,(AP) ;FILE TABLE ADDRESS
MOVE T1,AP
HRLI T1,^D30 ;COPY 30 CHARACTERS
MOVE T2,DP.NAM ;TO DEBUG-NAME
PUSHJ PP,FILL ;PUT IN PROCEDURE-NAME
HLRZ T1,F.DEB(AP) ;USE PROCEDURE
JRST UPOPJ1 ;GO TO USER
;DEBUGGING ON READ OF RECORD FROM FILE-NAME
;CALLED FROM USER PROGRAM BY
; PUSHJ 17,DBRD.
; LINE# ,,FILE-TABLE
DBRD.: SKIPN DEBUG. ;DO WE NEED IT
JRST CPOPJ1 ;NO
PUSHJ PP,ZDEB ;ZERO DEBUG-ITEM
HRRZ AP,(PP) ;GET USER'S ARG
HLRZ T2,(AP) ;GET LINE NUMBER
PUSHJ PP,LINENO ;PUT IN LINE NUMBER
HRRZ AP,(AP) ;FILE TABLE ADDRESS
MOVE T1,AP
HRLI T1,DPN.SZ ;COPY 30 CHARACTERS
MOVE T2,DP.NAM ;TO DEBUG-NAME
PUSHJ PP,FILL ;PUT IN PROCEDURE-NAME
HLLZ T1,F.WMRS(AP) ;GET RECORD SIZE
HRR T1,F.RREC(AP) ;RECORD ADDRESS
PUSHJ PP,CNFILL ;COPY TO DEBUG-CONTENTS
HLRZ T1,F.DEB(AP) ;USE PROCEDURE
JRST UPOPJ1 ;GO TO USER
SUBTTL DUBUGGING ON CD-NAME
;CALLED FROM USER PROGRAM BY
; PUSHJ 17,DBCD.
; LINE# ,,CD-NAME
; 0 ,,USE-PROCEDURE
DBCD.: SKIPN DEBUG. ;DO WE NEED IT
JRST CPOPJ2 ;NO
PUSHJ PP,ZDEB ;ZERO DEBUG-ITEM
HRRZ AP,(PP) ;GET USER'S ARG
HLRZ T2,(AP) ;GET LINE NUMBER
PUSHJ PP,LINENO ;PUT IN LINE NUMBER
HRRZ T1,(AP) ;CD TABLE ADDRESS
PUSHJ PP,DATNAM ;COPY CD-NAME TO DEBUG-NAME
PUSH PP,DT ;BETTER SAVE THIS ONE
SETZ T1, ;NO BYTE POINTER SET
PUSHJ PP,DBDACN ;COPY DATA TO DEBUG-CONTENTS
POP PP,DT
UPOPJ2: HRRZ T1,1(AP) ;USE PROCEDURE
AOS (PP)
UPOPJ1: AOS (PP)
UPOPJ: JUMPN T1,(T1) ;GO TO USER
POPJ PP, ;GIVE UP IF ZERO
SUBTTL DEBUGGING ON DATA-NAME
;CALLED FROM USER PROGRAM BY
; PUSHJ 17,DBDA.
; LINE# ,,DATA-NAME
; %PARAM,,<USE-PROCEDURE>
;WHERE %PARAM IS A BLOCK OF 4 CONTIGUOUS PARAMS CONTAINING
;%PARAM+0 FIRST SUBSCRIPT
;%PARAM+1 SECOND SUBSCRIPT OR ZERO IF NONE
;%PARAM+2 THIRD SUBSCRIPT OR ZERO IF NONE
;%PARAM+3 BYTE POINTER TO DATA OR ADDRESS IF WORD ALIGNED
DBDA.: SKIPN DEBUG. ;DO WE NEED IT
JRST CPOPJ2 ;NO
JSR SAVE ;SAVE ALL THE USER ACCS
PUSHJ PP,ZDEB ;ZERO DEBUG-ITEM
HRRZ AP,(PP) ;GET USER'S ARG
HLRZ T2,(AP) ;GET LINE NUMBER
PUSHJ PP,LINENO ;PUT IN LINE NUMBER
HRRZ T1,(AP) ;GET DATNAM OFFSET
PUSHJ PP,DATNAM ;COPY IT TO DEBUG-NAME
HLRZ T1,1(AP) ;ANY SUBSCRIPTS?
JUMPE T1,DBDA2 ;NO, GO FILL IN DEBUG-CONTENTS
HLRZ T1,1(AP) ;GET %PARAM
MOVE T2,(T1) ;GET CONTENTS
PUSHJ PP,PRSUB1 ;FILL IN DEBUG-SUB-1
HLRZ T1,1(AP) ;GET %PARAM
SKIPN T2,1(T1) ;GET CONTENTS
JRST DBDA1 ;DONE WITH SUBSCRIPTS
PUSHJ PP,PRSUB2 ;FILL IN DEBUG-SUB-2
HLRZ T1,1(AP) ;GET %PARAM
SKIPE T2,2(T1) ;GET CONTENTS
PUSHJ PP,PRSUB3 ;FILL IN DEBUG-SUB-3
DBDA1: HLRZ T1,1(AP) ;GET %PARAM
MOVE T1,3(T1) ;GET BYTE POINTER TO DATA
TLZ T1,(POINT 63,,35) ;CLEAR BYTE SIZE INCASE MULTIPLE BYTES
DBDA2: PUSHJ PP,DBDACN ;FILL IN DEBUG-CONTENTS
HRRZ T2,1(AP) ;USE PROCEDURE
SKIPN T2
MOVEI T2,CPOPJ ;INCASE NO USER ROUTINE
AOS (PP)
AOS (PP)
SETOM TEMP2 ;NO PUSH 0 NECESSARY
JRST RESTOR ;RESTORE ACCS, FLAGS, AND GO TO USER
;FILL IN DEBUG-CONTENTS
;ENTER WITH T1 = INPUT BYTE POINTER OR ZERO
DBDACN: HRRZ DT,(AP) ;GET DATA-NAME
ADD DT,@%DT ;RELOCATE IT
LDB T0,DTISIZ ;GET INTERNAL SIZE (INCASE EDITED)
LDB T2,DTUSAG ;GET USAGE
MOVE T4,DBITEM ;GET BASE ADDRESS
MOVEM T2,DP.IDX(T4) ;STORE INDEX
JRST @.+1(T2) ;DISPATCH ON USAGE
CPOPJ ;NO SUCH USAGE - ERROR
DBDAD6 ;DISPLAY-6
DBDAD7 ;DISPLAY-7
DBDAD9 ;DISPLAY-9
DBDAD1 ;1-WORD COMP
DBDAD2 ;2-WORD COMP
DBDAD1 ;FLOATING POINT
DBDAD1 ;INDEX
DBDAC3 ;COMP-3
DBDAD1: JUMPN T1,.+2 ;ALREADY SUPPLIED?
HRRZ T1,1(DT) ;GET RUN TIME LOCATION
ADD T4,DP.CON ;ADDRESS OF DEBUG-CONTENTS
MOVE T2,(T1) ;GET DATA
MOVEM T2,(T4)
POPJ PP,
DBDAD2: JUMPN T1,.+2 ;ALREADY SUPPLIED?
HRRZ T1,1(DT) ;GET RUN TIME LOCATION
ADD T4,DP.CON ;ADDRESS OF DEBUG-CONTENTS
DMOVE T2,(T1) ;GET DATA
DMOVEM T2,(T4)
POPJ PP,
DBDAC3: ADDI T0,2 ;ROUND UP (SIGN PLUS SLACK)
LSH T0,-1 ;CONVERT TO EBCDIC
DBDAD9: MOVE T3,T0 ;SET OUTPUT SIZE = INPUT SIZE
ADD T4,DP.CN9 ;9-BIT BYTE POINTER TO DEBUG-CONTENTS
JUMPN T1,[TLO T1,(POINT 9,,35) ;RESET BYTE SIZE
JRST DBDAEX] ;ALREADY SUPPLIED?
LDB T1,DTRESD ;NO, GET RESIDUE
LSH T1,^D30 ;SHIFT INTO PLACE
TLO T1,(POINT 9,,35) ;FORM BYTE POINTER
HRR T1,1(DT) ;GET RUN TIME LOCATION
JRST DBDAEX
DBDAD7: MOVE T3,T0 ;SET OUTPUT SIZE = INPUT SIZE
ADD T4,DP.CN7 ;7-BIT BYTE POINTER TO DEBUG-CONTENTS
JUMPN T1,[TLO T1,(POINT 7,,35) ;RESET BYTE SIZE
JRST DBDAEX] ;ALREADY SUPPLIED?
LDB T1,DTRESD ;NO, GET RESIDUE
LSH T1,^D30 ;SHIFT INTO PLACE
TLO T1,(POINT 7,,35) ;FORM BYTE POINTER
HRR T1,1(DT) ;GET RUN TIME LOCATION
JRST DBDAEX
DBDAD6: MOVE T3,T0 ;SET OUTPUT SIZE = INPUT SIZE
ADD T4,DP.CON
JUMPN T1,[TLO T1,(POINT 6,,35) ;RESET BYTE SIZE
JRST DBDAEX] ;ALREADY SUPPLIED?
LDB T1,DTRESD ;NO, GET RESIDUE
LSH T1,^D30 ;SHIFT INTO PLACE
TLO T1,(POINT 6,,35) ;FORM BYTE POINTER
HRR T1,1(DT) ;GET RUN TIME LOCATION
DBDAEX:
IFN BIS,<
EXTEND T0,[MOVSLJ
0]
JFCL ;TOO BAD IF IT FAILS
>
IFE BIS,<
ILDB T2,T1
IDPB T2,T4
SOJG T0,DBDAEX
>
POPJ PP,
;ZERO THE DEBUG-ITEM & SETUP VARIOUS ITEMS FOR LATER
ZDEB: MOVE T2,%DB ;GET TABLE ADDRESS OF DEBUG-ITEM
ADD T2,@%DT ;ADD IN DATAB BASE
HRRZ T1,1(T2) ;GET RUN-TIME ADDRESS
MOVEM T1,DBITEM ;SAVE IT FOR REST OF CALLS
HRRZ T2,5(T2) ;GET SIZE
ADDI T2,5 ;ROUND UP
IDIVI T2,6 ;GET NO. OF WORDS
ADDI T2,-1(T1) ;END OF IT
HRL T1,T1
SETZM (T1) ;CLEAR FIRST WORD
ADDI T1,1 ;FORM BLT POINTER
BLT T1,(T2) ;CLEAR ALL
POPJ PP,
;COPY LINE NUMBER TO DEBUG-LINE
;
;ENTER WITH LINE# IN T2
;USES T1, T2, T3
LINENO: MOVE T1,DBITEM ;GET BASE
HRLI T1,DP.LIN ;BYTE PTR TO DEBUG-LINE
CAIGE T2,^D10
IBP T1
CAIGE T2,^D100
IBP T1
CAIGE T2,^D1000
IBP T1
CAIGE T2,^D10000
IBP T1
CAIGE T2,^D100000
IBP T1
LINEN1: IDIVI T2,^D10
HRLM T3,(PP) ;OLDE RECURSIVE NUMBER PRINTER
SKIPE T2 ;DONE
PUSHJ PP,LINEN1
HLRZ T2,(PP)
ADDI T2,'0'
IDPB T2,T1
POPJ PP,
;COPY DATAB NAME TO DEBUG-NAME
;
;ENTER WITH %DT OFFSET IN T1
;USES T1, T2, T3, T4, AND T5
DATNAM: MOVE T2,DP.NAM
ADD T2,DBITEM
MOVEI T5,DPN.SZ ;SIZE OF DEBUG-NAME
DATNM1: TRZ T1,TYPMSK ;CLEAR TYPE BITS
ADD T1,@%DT ;GET DATAB LINK TO NAMTAB
PUSH PP,T1 ;SAVE DATAB LINK
HLRZ T1,DTNAM(T1) ;GET NAMTAB LINK
PUSHJ PP,DATNM3 ;COPY IT TO DEBUG-NAME
POP PP,T1 ;GET BACK DATAB LINK
HRRZ T3,DTNAM(T1) ;GET LINK TO DATAB WITH SAME NAME
JUMPN T3,DATNM2 ;NOT UNIQUE FOR SURE
HLRZ T3,DTNAM(T1) ;GET LINK TO NAMTAB
ADD T3,@%NM ;GET ADDRESS
HRRZ T3,(T3) ;GET DATAB LINK
TRZ T3,TYPMSK ;REMOVE TYPE BITS
ADD T3,@%DT ;GET ADDRESS
CAMN T1,T3 ;IS IT UNIQUE?
POPJ PP, ;YES, ALL DONE
DATNM2: MOVE T3,DTFLAG(T1) ;GET VARIOUS FLAGS
TXNN T3,DTLINK ;IS THIS THE FATHER LINK?
JRST [HLRZ T1,DTSON(T1) ;NO, GET BROTHER LINK
TRZ T1,TYPMSK ;REMOVE TYPE BITS
ADD T1,@%DT ;RELOCATE IT
JRST DATNM2] ;AND TRY THIS ONE
HLRZ T1,DTSON(T1) ;YES, GET IT
JUMPE T1,CPOPJ ;SHOULD NEVER HAPPEN
SUBI T5,4 ;ACCOUNT FOR THE ' OF '
JUMPL T5,CPOPJ ;NOT ENOUGH ROOM FOR IT, GIVE UP
IBP T2 ;SPACE
MOVEI T4,'O'
IDPB T4,T2
MOVEI T4,'F'
IDPB T4,T2
IBP T2
JRST DATNM1 ;DO QUALIFICATION
DATNM3: ADD T1,@%NM ;ADD IN BASE
HLRZ T3,(T1) ;GET NO OF WORDS
IMULI T3,6 ;MAX. NO. OF CHARACTERS
HRLI T1,(POINT 6,)
ADDI T1,1 ;BYTE POINTER TO NAME
DATNM4: ILDB T4,T1
JUMPE T4,CPOPJ
CAIN T4,':'
MOVEI T4,'-' ;CONVERT ":" BACK TO "-"
CAIN T4,';'
MOVEI T4,'.' ;Convert ";" back to "."
SOJL T5,CPOPJ ;DON'T STORE IF TOO MANY CHARACTERS
IDPB T4,T2
SOJG T3,DATNM4
POPJ PP,
;COPY PROCEDURE NAME TO DEBUG-NAME
;
;ENTER WITH %PR OFFSET IN T1
;USES T1, T2, T3, T4
;MUST NOT USE T5
PRONAM: MOVE T2,DP.NAM
PRNM1: ADD T2,DBITEM
ADD T1,@%PR ;ADD IN BASE
LDB T1,[POINT 15,0(T1),17] ;GET NAMTAB ADDRESS
PRNM2: ADD T1,@%NM ;ADD IN BASE
HLRZ T3,(T1) ;GET NO OF WORDS
IMULI T3,6 ;MAX. NO. OF CHARACTERS
HRLI T1,(POINT 6,)
ADDI T1,1 ;BYTE POINTER TO NAME
PRNM3: ILDB T4,T1
JUMPE T4,CPOPJ
CAIN T4,':'
MOVEI T4,'-' ;CONVERT ":" BACK TO "-"
CAIN T4,';'
MOVEI T4,'.' ;CONVERT ";" BACK TO "."
IDPB T4,T2
SOJG T3,PRNM3
POPJ PP,
;COPY %PARAM TO DEBUG-SUB
;ENTER WITH SUBSCRIPT VALUE IN T2
;USES T1, T2, T3
PRSUB1: MOVE T1,DP.SB1 ;GET BYTE POINTER
JRST .+3
PRSUB2: SKIPA T1,DP.SB2
PRSUB3: MOVE T1,DP.SB3
ADD T1,DBITEM ;ADD IN BASE
MOVEI T3,'+'
IDPB T3,T1 ;DEPOSIT SIGN
IDIVI T2,^D10000 ;ONLY SPACE FOR +9999
MOVE T2,T3 ;SO TRUNCATE
IDIVI T2,^D1000 ;GET THOUSANDS
ADDI T2,'0'
IDPB T2,T1
MOVE T2,T3
IDIVI T2,^D100
ADDI T2,'0'
IDPB T2,T1
MOVE T2,T3
IDIVI T2,^D10
ADDI T2,'0'
IDPB T2,T1
ADDI T3,'0'
IDPB T3,T1
POPJ PP,
SUBTTL CONSTANTS
;BYTE POINTERS TO DEBUG-ITEM
DP.LIN==(POINT 6,0) ;DEBUG-LINE
DP.NAM: POINT 6,1,5 ;DEBUG-NAME
DP.SB1: POINT 6,6,11 ;DEBUG-SUB-1
DP.SB2: POINT 6,7,11 ;DEBUG-SUB-2
DP.SB3: POINT 6,8,11 ;DEBUG-SUB-3
DP.CON: POINT 6,^D10 ;DEBUG-CONTENTS
DP.CN7: POINT 7,^D10 ;...
DP.CN9: POINT 9,^D10 ;...
DP.IDX==-1 ;ADDRESS OF DEBUG-CONTENTS-INDEX
DPN.SZ==^D30 ;SIZE OF DEBUG-NAME
;STANDARD DEBUG-CONTENTS DATA
DBPTB: ^D13,,[SIXBIT /START PROGRAM/]
^D12,,[SIXBIT /FALL THROUGH/]
^D13,,[SIXBIT /USE PROCEDURE/]
^D12,,[SIXBIT /PERFORM LOOP/]
^D10,,[SIXBIT /SORT INPUT/]
^D11,,[SIXBIT /SORT OUTPUT/]
^D12,,[SIXBIT /MERGE OUTPUT/]
END