Trailing-Edge
-
PDP-10 Archives
-
decuslib20-02
-
decus/20-0057/sddutl.mac
There are 2 other files named sddutl.mac in the archive. Click here to see a list.
TITLE S$$UTL SYSTEM UTILITY ROUTINES
SUBTTL S$$EFI 'ENTRY.FUNCTION' INITIALIZATION ROUTINE
ENTRY S$$EFI
EXTERN S$$MFB,S$$KWD,S$$PBP,S$$FLP,S$$IPR,S$$CPF,S$$FLR
RADIX 10
SEARCH S$$NDF
COMMENT/
XWD STNO,PARBLK ; WHERE STNO IS THE STATEMENT # OF THE
CALL: JSP R11,S$$EFI ; 'ENTRY.FUNCTION' DECLARATION, PARBLK
PROT DESCR ; IS THE PARAMETER BLOCK, AND PROT DESCR AND
LABL DESCR ; LABL DESCR THE PROTOTYPE AND LABEL DESCRIP-
TORS. THE PROGRAM IS INITIALIZED IF NECESSARY, THE FUNCTION DEFINED AND
CALLING SEQUENCE MODIFIED TO APPEAR LIKE A NORMAL FUNCTION DEFINITION,
AND THE FUNCTION IS CALLED USING THE NEW DEFINITION/
S$$EFI: PUSH ES,1(R11) ; SAVE LABEL DESCR ON ES
PUSH ES,(R11) ; SAVE PROTOTYPE DESCR ON ES
PUSH SS,R3 ; SAVE # OF ARGS
PUSH SS,S$$PBP ; SAVE PARBLK+1
PUSH SS,S$$KWD+2 ; SAVE &STNO
PUSH SS,S$$FLP ; SAVE FAILPOINT
PUSH SS,R11 ; SAVE LINK
MOVE R10,-2(R11) ; GET NEW &STNO,PARBLK
HLRZM R10,S$$KWD+2 ; SET &STNO
MOVEI R9,1(R10) ; GET PARBLK+1
MOVEM R9,S$$PBP ; SET
HRLI R9,1B18+4 ; FORM NEW WORD FOR CALLING SEQUENCE
MOVEM R9,-2(R11) ; AND STORE IT THERE
SKIPL (R10) ; HAS PROGRAM BEEN INITIALIZED?
JSP R11,S$$IPR ; NO, INITIALIZE IT
HRROI R10,EFIFAL ; SET UP DUMMY FAILPOINT
MOVEM R10,S$$FLP
SETZ R0, ; MAKE FUNCTION BLOCK, LOCAL VARS POSSIBLE,
JSP R11,S$$MFB ; BUT NO FUNCTION WORD
POP SS,R11 ; RESTORE LINK
MOVEM R10,1(R11) ; SAVE FUNCTION DEFINITION
MOVEM R9,(R11) ; PARAMETERS IN CALLING SEQUENCE
MOVEI R10,S$$CPF ; GET 'CALL PROGRAMMER-DEFINED FUN'
POP SS,S$$FLP ; RESTORE FAILPOINT
POP SS,S$$KWD+2 ; AND &STNO
POP SS,S$$PBP ; AND PARBLK+1
POP SS,R3 ; AND # OF ARGS
HRRM R10,-1(R11) ; CHANGE CALLING SEQUENCE
JRST (R10) ; AND GO THERE
; FAILURE DURING FUNCTION DEFINITION
EFIFAL: SUB SS,[XWD 1,1] ; POP SS
POP SS,S$$FLP ; RESTORE FAILPOINT
POP SS,S$$KWD+2 ; RESTORE &STNO
POP SS,S$$PBP ; RESTORE PARBLK+1
JRST S$$FLR ; AND FAIL
PRGEND
SUBTTL S$$MFB MAKE FUNCTION BLOCK ROUTINE
ENTRY S$$MFB
EXTERN S$$GFP,S$$PGL,S$$LKV,S$$LKL,S$$LKF,S$$GNS,S$$SRT,S$$NRT
EXTERN S$$FRT,S$$MKS
RADIX 10
SEARCH S$$NDF
COMMENT/
CALL: JSP R11,S$$MFB ; WITH LABEL, THEN FUNCTION PROTOTYPE
PUSHED ONTO ES, AND FLAG IN R0 INDICATING FUNCTION TYPE (-1='ENTRY.FOR-
TRAN.FUNCTION',0='ENTRY.FUNCTION',1='DEFINE' FUNCTION). RETURNS XWD
-(NARG+NLV+1),ARGBLK IN R10, XWD STARTL,NLV+1 IN R9, AND, IF REQUIRED,
A FUNCTION WORD POINTER IN R8/
S$$MFB: MOVEM R0,FTPFLG ; SAVE FLAG
JUMPLE R0,.+2 ; IS IT 'DEFINE'?
SETZ R0, ; YES, WANT LOCAL VARS ALSO
HRRM R11,MFBRET ; SAVE LINK
MOVE R1,(ES) ; GET PROTOTYPE
TLNN R1,^O770000 ; IS IT STRING?
JSP R11,S$$GFP ; YES, GET FUNCTION PARAMETERS
CFERR 6,S$$PGL ; NO, BAD PROTOTYPE
MOVEM R9,SAVNLV ; SAVE # OF LOCAL VARS
MOVEI R0,1(R10) ; GET NARG+NLV+2
JSP R6,S$$GNS ; GET ARGUMENT BLOCK
MOVNI R2,(R10) ; GET -(NARG+NLV+1)
HRLI R1,(R2) ; INTO LH OF R1
MOVEM R1,SAVABP ; SAVE XWD -(NARG+NLV+1),ARGBLK
HRLZI R11,-1(R10) ; NARG+NLV,0
ADDI R10,(R1) ; ARGBLK+NARG+NLV+1
HRRM R10,(R1) ; SAVE IN ARGBLK
HRRI R11,(R10) ; AND AS POINTER TO LAST ARG BLOCK ENTRY
VARLOP: POP ES,R1 ; GET NEXT PREVIOUS SYMBOL
JSP R10,S$$LKV ; DO VARIABLE LOOKUP
HRLZI R3,3B23 ; DEDICATED TYPE MASK
AND R3,(R2) ; GET DEDICATED TYPE
LSH R3,-12 ; FORM XWD NAMPTR,DEDTYP
LSHC R2,-18
MOVEM R3,(R11) ; SAVE IN ARG BLOCK
SUB R11,[XWD 1,1] ; DECREMENT POINTER
JUMPGE R11,VARLOP ; LOOP IF ANY SYMBOLS LEFT
ADD ES,[XWD 1,1] ; PRESERVE FUNCTION SYMBOL
MOVE R1,(ES) ; GET IT
SKIPLE FTPFLG ; IS FUNCTION WORD WANTED?
JSP R10,S$$LKF ; YES, DO FUNCTION LOOKUP
HRRM R2,RSTFPT ; SAVE PTR TO FUNCTION WORD
MOVE R1,-2(ES) ; GET LABEL DESCR
SETO R0, ; MUST BE STRING
JSP R7,S$$MKS
CFERR 6,S$$PGL
SETZ R0, ; GET CHAR COUNT OF LABEL
HRRZ R0,(R1)
JUMPN R0,.+2 ; SKIP IF NON-NULL, OR
MOVE R1,(ES) ; USE FUNCTION SYMBOL
JSP R10,S$$LKL ; DO LABEL LOOKUP
MOVE R10,SAVABP ; GET XWD -(NARG+NLV+1),ARGBLK
AOS R9,SAVNLV ; GET XWD STARTL,NLV+1
HRLI R9,(R2)
SUB ES,[XWD 3,3] ; POP FUNC SYM, PROTOTYPE, LABEL OFF ES
RSTFPT: MOVEI R8,.-. ; GET FUNCTION WORD POINTER
MFBRET: JRST .-. ; RETURN
; STORAGE
FTPFLG: S$$SRT ; TO FORCE LOADING OF NON-DUMMY 'RETURN', 'FRETURN',
SAVNLV: S$$FRT ; AND 'NRETURN' IN CASE ONLY INDIRECT REFERENCES TO
SAVABP: S$$NRT ; THEM ARE MADE
PRGEND
SUBTTL S$$CPF CALL PROGRAMMER-DEFINED FUNCTION ROUTINE
ENTRY S$$CPF
EXTERN S$$PGL,S$$STP,S$$STB,S$$TMS,S$$KWD,S$$PBP,S$$FLP,S$$CPS
EXTERN S$$MKS,S$$MKI,S$$MKR,S$$TAC,S$$FLR
RADIX 10
SEARCH S$$NDF
COMMENT/
XWD ,PARBLK+1 ; WHERE PARBLK IS THE PARAMETER BLOCK
CALL: JSP R11,S$$CPF ; NLV IS THE # OF LOCAL VARIABLES, STARTL
XWD STARTL,NLV+1 ; IS THE LOCATION OF THE STARTING LABEL
XWD -(NARG+NLV+1),ARGBLK ; WORD, NARG IS THE # OF FORMAL
ARGUMENTS, AND ARGBLK IS THE ARGUMENT BLOCK POINTER. EXPECTS RETURN
LINK IN S$$PGL, CALL MODE LINK IN R12, AND # OF ARGS IN R3, WITH ARGS
PUSHED ONTO ES/
S$$CPF: HRL R12,S$$PGL ; GET PROGRAM LINK
PUSH SS,R12 ; SAVE , WITH R12, ON SS
MOVN R12,S$$STB ; SAVE CURRENT ES - BASE
ADD R12,ES ; IN CASE STACK OVERFLOWS AND CHANGES BASE
MOVE R10,(R11) ; GET STARTL,NLV+1
HLRM R10,STLABL ; SAVE PTR IN XCT INSTR
MOVEI R10,(R10) ; GET NLV+1
SETZ R0, ; NULL VALUES
PUSH ES,R0 ; PUSH EXTRA VALUES ONTO ES
SOJG R10,.-1 ; LOOP
ADD R12,S$$STB ; ADD BASE AND POINT TO FIRST
MOVEI R12,1(R12) ; VALUE ON ES BY SUTRACTING
SUBI R12,(R3) ; # OF ARGUMENTS
MOVE R8,-2(R11) ; SAVE NEW PARBLK+1
MOVE R11,1(R11) ; GET -(NARG+NLV+1),ARGBLK
PUSH SS,S$$FLP ; SAVE FAILPOINT
PUSH SS,S$$TMS ; SAVE STATEMENT START TIME ON SS
MOVE R1,S$$PBP ; GET OLD PARBLK+1
HRL R1,S$$KWD+2 ; GET OLD &STNO
PUSH SS,R1 ; SAVE THEM ON SS
PUSH SS,S$$STP-1 ; SAVE SS PREVIOUS
PUSH SS,S$$STP ; SAVE ES PREVIOUS
MOVEI R1,CPFRET ; GET FUNCTION CALL RETURN LOC
HRLI R1,(R11) ; AND ARG BLOCK POINTER
PUSH SS,R1 ; SAVE ON SS
SETZ R1, ; NULL VALUE FOR FUNCTION VAR
SAVLOP: MOVE R10,1(R11) ; GET NAMLOC,VARTYP OF NEXT VAR
JRA R10,.+1(R10) ; GET NAME DESCR, GO TO:
JRST SAVUND ; UNDEDICATED VAR
JRST SAVSTR ; DEDICATED STRING
JRST SAVINT ; DEDICATED INTEGER
JRST SAVREL ; OR DEDICATED REAL
SAVUND: SETM R2,(R10) ; GET OLD VALUE, WITHOUT INPUT
MOVEM R1,(R10) ; REPLACE WITH NEW VALUE, POSSIBLE OUTPUT
MOVE R1,R2
SAVCOM: EXCH R1,(R12) ; SAVE OLD VALUE ON ES AND GET NEXT VALUE
AOBJP R11,SAVFIN ; JUMP OUT IF NO MORE VARS
AOJA R12,SAVLOP ; OR BUMP ES POINTER AND LOOP
SAVSTR: MOVE R9,R1 ; SAVE NEW VALUE
MOVE R1,(R10) ; GET OLD VALUE
JSP R7,S$$CPS ; MAKE A COPY
EXCH R1,R9 ; EXCHANGE WITH NEW VALUE
MOVE R2,(R10) ; SET UP FOR STORING NEW VALUE
HLRZ R0,(R2) ; IN DEDICATED STRING, COMPUTE MAX CHARS AVAILA-
SUBI R0,1 ; BLE
IMULI R0,5
JSP R7,S$$MKS ; STORE NEW VALUE
CFERR 1,S$$PGL
HRRM R3,@(R10) ; SAVE CHAR COUNT
MOVE R1,R9 ; GET COPY OF OLD VALUE
JRST SAVCOM ; GO SAVE ON ES
SAVINT: JSP R7,S$$MKI ; MAKE INTEGER FROM NEW VALUE
CFERR 1,S$$PGL
EXCH R1,(R10) ; EXCHANGE WITH OLD VALUE
TLO R1,1B18 ; MAKE DESCRIPTOR FROM OLD VALUE
TLZ R1,1B19
JRST SAVCOM ; GO SAVE ON ES
SAVREL: JSP R7,S$$MKR ; DITTO FOR REALS
CFERR 1,S$$PGL
EXCH R1,(R10)
LSH R1,-2
TLO R1,3B19
JRST SAVCOM
SAVFIN: MOVN R1,S$$STB ; COMPUTE NEW ES PREVIOUS
ADD R1,ES ; FROM CURRENT ES
MOVEM R1,S$$STP ; SAVE
MOVN R1,S$$STB-1 ; DITTO FOR SS
ADD R1,SS
MOVEM R1,S$$STP-1
AOS S$$KWD+3 ; INCREMENT &FNCLEVEL
HRRZM R8,S$$PBP ; SAVE NEW PARBLK+1
SETZM S$$KWD+2 ; ZERO &STNO
STLABL: XCT .-. ; EXECUTE LABEL WORD (JUMP TO STARTING LABEL)
; RETURN, FRETURN, AND NRETURN OF A PROGRAMMER-DEFINED FUNCTION
; EXPECTS 0, -1, OR 1 IN RH(R12) , RESPECTIVELY
CPFRET: HLRZ R11,1(SS) ; GET ARGBLK POINTER
POP SS,S$$STP ; RESTORE ES PREVIOUS
POP SS,S$$STP-1 ; RESTORE SS PREVIOUS
POP SS,R1
HLRZM R1,S$$KWD+2 ; RESTORE OLD &STNO
HRRZM R1,S$$PBP ; RESTORE OLD PARBLK+1
POP SS,S$$TMS ; RESTORE START TIME FOR OLD STNO
POP SS,S$$FLP ; RESTORE FAILPOINT POINTER
POP SS,R1 ; GET OLD LINK,R12
MOVEI R12,(R12) ; CLEAR LH OF RETURN INDEX
ADDI R12,(R1) ; ADD OLD R12
HLRZM R1,S$$PGL ; RESTORE OLD PROGRAM LINK
MOVE R10,1(R11) ; GET NAMPTR,TYPE FOR FUNCTION VARIABLE
JRA R10,.+1(R10) ; GET NAME DESCR, AND SAVE VALUE FOR:
JRST FVLUND ; UNDEDICATED VARIABLE
JRST FVLSTR ; DEDICATED STRING
JRST FVLINT ; DEDICATED INTEGER
JRST FVLREL ; OR DEDICATED REAL
FVLSTR: MOVE R1,(R10) ; GET DESCRIPTOR
JSP R7,S$$CPS ; MAKE A COPY
JRST FVLCOM ; GO SAVE
FVLINT: MOVE R1,(R10) ; GET INTEGER
TLO R1,1B18 ; MAKE DESCRIPTOR
TLZ R1,1B19
JRST FVLCOM ; GO SAVE
FVLREL: MOVE R1,(R10) ; DITTO FOR REAL
LSH R1,-2
TLO R1,3B19
JRST FVLCOM
FVLUND: SETM R1,(R10) ; GET DESCR (WITHOUT INPUT)
FVLCOM: MOVEM R1,S$$TAC ; SAVE IN TEMP AC
HRRZ R9,(R11) ; COMPUTE NARG+NLV+1
SUBI R9,(R11)
MOVE R11,(R11) ; POINTER TO BOTTOM OF ARGBLOCK
RSTLOP: MOVE R10,(R11) ; GET NEXT NAMPTR,TYPE
POP ES,R1 ; POP CORRESPONDING SAVED VALUE OFF ES
JRA R10,.+1(R10) ; GET NAME DESCR AND RESTORE:
JRST RSTUND ; UNDEDICATED VARIABLE
JRST RSTSTR ; DEDICATED STRING
JRST RSTINT ; DEDICATED INTEGER
JRST RSTREL ; OR DEDICATED REAL
RSTSTR: MOVE R2,(R10) ; MOVE OLD STRING COPY INTO DEDICATED
HRRZ R0,(R1) ; STRING LOC
JSP R7,S$$MKS
JFCL
HRRM R3,@(R10) ; SAVE CHAR COUNT
JRST RSTCOM ; GO LOOP
RSTINT: LSH R1,2 ; GET INTEGER FROM DESCR
ASH R1,-2
MOVEM R1,(R10) ; SAVE IN DED LOC
JRST RSTCOM ; GO LOOP
RSTREL: LSH R1,2 ; DITTO FOR REAL
MOVEM R1,(R10)
JRST RSTCOM
RSTUND: SETAM R1,(R10) ; SAVE DESCR IN LOC (BUT NO OUTPUT)
RSTCOM: SOJLE R9,RSTFIN ; JUMP OUT IF NO MORE VARS
SOJA R11,RSTLOP ; OR DECREMENT ARGBLK POINTER AND LOOP
RSTFIN: SETZ R1,
EXCH R1,S$$TAC ; GET FUNCTION VALUE
TLNN R12,-1 ; SKIP IF INDEX WAS -1 (FRETURN)
JRST (R12) ; 'RETURN' OR 'NRETURN'
JRST S$$FLR ; 'FRETURN', FAIL
PRGEND
SUBTTL S$$GFP GET FUNCTION PARAMETERS ROUTINE
ENTRY S$$GFP
EXTERN S$$BKT,S$$GRS
RADIX 10
SEARCH S$$NDF
COMMENT/
CALL: JSP R11,S$$GFP ; WITH PROTOTYPE ON ES, AND LOCAL VAR-
RIABLE FLAG (-1=NONE, 0=POSSIBLY) IN R0. RETURNS TO 0(R11) IF PROTOTYPE
IS BAD, OR TO 1(R11) WITH SYMBOLS PUSHED ONTO ES, SYMBOL COUNT IN R10,
AND, IF REQUIRED, LOCAL VARIABLE COUNT IN R9/
S$$GFP: JRST INIBKT ; INITIALIZE BREAK TABLES, THEN MODIFY THIS LOC
SETZM PROTCT ; INITIALIZE SYMBOL COUNT
MOVE R10,(ES) ; INITIALIZE CURSOR
SETZ R0, ; GET TOTAL CHAR COUNT
HRRZ R9,(R10)
JSP R8,GETSYM ; GET FIRST SYMBOL
JRST (R11) ; ERROR IF NO MORE CHARS
CAIE R7,"(" ; IS NEXT CHAR OPEN PAREN?
JRST (R11) ; NO, ERROR
JSP R8,SPNBLN ; SPAN BLANKS
JRST (R11) ; ERROR IF NO MORE CHARS
CAIN R7,")" ; IS NEXT CHAR CLOSE PAREN?
JRST CLSPRN ; YES
VARLOP: JSP R8,GETSYM ; GET NEXT SYMBOL
JRST (R11) ; ERROR IF NO MORE CHARS
MOVE R8,PROTCT ; GET # OF SYMBOLS
CAILE R8,16 ; < OR = 15 ARGS + FUNCTION?
JRST (R11) ; NO, BAD PROTOTYPE
CAIE R7," " ; IS NEXT CHAR BLANK OR TAB?
CAIN R7,^O11
JSP R8,SPNBLN ; YES, SPAN BLANKS
JUMPL R9,(R11) ; NO, OR IF OUT OF CHARS, ERROR
CAIE R7,"," ; IS NEXT CHAR A COMMA?
JRST CLSCHK ; NO, CHECK FOR CLOSE PAREN
JSP R8,SPNBLN ; YES, SPAN BLANKS
JRST (R11) ; ERROR IF NO MORE CHARS
JRST VARLOP ; LOOP
CLSCHK: CAIE R7,")" ; IS NEXT CHAR CLOSE PAREN?
JRST (R11) ; NO, ERROR
CLSPRN: JSP R8,SPNBLN ; SPAN BLANKS AFTER ")"
JRST GFPEND ; FINISH UP IF NO MORE CHARS
SKIPE PROTFL ; WERE LOCAL VARS EXPECTED?
JRST (R11) ; NO, ERROR
LVRLOP: AOS PROTFL ; ADD 1 TO LOCAL VAR COUNT
JSP R8,GETSYM ; GET NEXT SYMBOL
JRST GFPEND ; FINISH UP IF NO MORE CHARS
CAIE R7," " ; IS NEXT CHAR BLANK OR TAB?
CAIN R7,^O11
JSP R8,SPNBLN ; YES, SPAN BLANKS
JUMPL R9,GFPEND ; NO, OR IF OUT OF CHARS, FINISH UP
CAIE R7,"," ; IS NEXT CHAR A COMMA?
JRST (R11) ; NO, ERROR
JSP R8,SPNBLN ; YES, SPAN BLANKS
JRST (R11) ; ERROR IF NO MORE CHARS
JRST LVRLOP ; LOOP
GFPEND: MOVE R9,PROTFL ; GET LOCAL VAR COUNT
MOVE R10,PROTCT ; GET SYMBOL COUNT
JRST 1(R11) ; RETURN
; INITIALIZE BREAK TABLES
INIBKT: MOVE R1,.+2 ; GET 'MOVEM R0,PROTFL'
PROTFL: MOVEM R1,S$$GFP ; PLUG CALLING SEQUENCE
PROTCT: MOVEM R0,PROTFL ; SAVE R0
FRSTBL: MOVEI R0,1 ; BIT MARK
MOVEI R1,R3 ; PTR TO DUMMY FRSTBL IN R3-R6
MOVE R2,[XWD -26,"A"] ; UPPER CASE LETTERS
SETZB R3,R4 ; CLEAR TABLE
RESTBL: SETZB R5,R6
DPB R0,S$$BKT(R2) ; MARK UPPER CASE BITS
AOBJN R2,.-1
MOVE R2,[XWD -26,^O141] ; LOWER CASE LETTERS
DPB R0,S$$BKT(R2) ; MARK LOWER CASE BITS
AOBJN R2,.-1
MOVEI R1,R7 ; COPY INTO DUMMY RESTBL
MOVE R10,[XWD R3,R7] ; IN R7-R10
BLT R10,R10
MOVE R2,[XWD -10,"0"] ; DIGITS
DPB R0,S$$BKT(R2) ; MARK DIGIT BITS
AOBJN R2,.-1
DPB R0,S$$BKT+"." ; MARK DOT
DPB R0,S$$BKT+"-" ; MARK DASH
MOVE R0,[XWD R3,FRSTBL] ; MOVE TABLES INTO CORE
BLT R0,RESTBL+3
JRST S$$GFP+1 ; CONTINUE
; SPAN BLANKS ROUTINE: JSP R8,SPNBLN ; AUTOMATICALLY SKIPS THE FIRST
; CHARACTER, AND THEN SKIPS OVER SUCCEEDING BLANKS AND TABS. RETURNS
; TO 0(R8) IF IT RUNS OUT OF CHARACTERS, OR TO 1(R8) WITH THE NEXT CHAR
; IN R7, AND THE CURSOR BACKED UP TO JUST IN FRONT OF IT
SPNBLN: IBP R10 ; MOVE CURSOR 1 CHAR
SUBI R9,1 ; FORWARD AUTOMATICALLY
SPNLOP: MOVE R6,R10 ; SAVE CURSOR IN CASE OF BACKUP
SOJL R9,(R8) ; DECREMENT CHAR COUNT, LEAVE IF <0
ILDB R7,R10 ; GET NEXT CHAR
CAIE R7," " ; IS IT BALNK OR TAB?
CAIN R7,^O11
JRST SPNLOP ; YES, LOOP
MOVE R10,R6 ; NO, BACKUP CURSOR
AOJA R9,1(R8) ; AND RETURN
; GET SYMBOL ROUTINE: JSP R8,GETSYM ; PARSES SYMBOL, CREATES NEW STRING
; , PUSHES IT ONTO ES AND INCREMENTS PROTCT, AND RETURNS TO 0(R8) IF
; NO MORE CHARS, OR TO 1(R8) WITH NEXT CHAR IN R7, WITH CURSOR BACKED
; UP TO JUST IN FRONT OF IT. FAILS TO (R11) IF CAN'T FIND SYMBOL
GETSYM: MOVEI R0,1 ; AT LEAST 1 CHAR
MOVEI R1,FRSTBL ; GET BREAK TABLE FOR LETTERS
SOJL R9,(R11) ; FAIL IF NO MORE CHARS
ILDB R7,R10 ; GET CHAR
LDB R2,S$$BKT(R7) ; GET BREAK BIT
JUMPE R2,(R11) ; FAIL IF NOT LETTER
PUSH SS,R7 ; PUSH CHAR ONTO SS
MOVEI R1,RESTBL ; GET BREAK TABLE FOR LETTERS, DIGITS,.,-
SYMLOP: MOVE R6,R10 ; SAVE CURSOR IN CASE OF BACKUP
SOJL R9,SYMEND+2 ; DECREMENT CHAR COUNT, QUIT IF <0
ILDB R7,R10 ; GET CHAR
LDB R2,S$$BKT(R7) ; GET BREAK BIT
JUMPE R2,SYMEND ; QUIT IF NOT ON
PUSH SS,R7 ; PUSH CHAR ONTO SS
AOJA R0,SYMLOP ; INCREMENT SYMBOL CHAR COUNT AND LOOP
SYMEND: ADDI R8,1 ; RETURN TO 1(R8)
MOVE R10,R6 ; BACKUP CURSOR
ADDI R9,1
HRRM R0,SAVCNT ; SAVE SYMBOL CHAR COUNT
MUL R0,[^F0.2B0] ; COMPUTE # WORDS NEEDED
ADDI R0,2
JSP R6,S$$GRS ; GET BLOCK FOR SYMBOL
HRLI R1,^O700 ; FORM STRING DESCR
PUSH ES,R1 ; SAVE ON ES
AOS PROTCT ; INCREMENT SYMBOL COUNT
SAVCNT: MOVEI R2,.-. ; GET SYMBOL CHAR COUNT
HRRM R2,(R1) ; SAVE IN STRING BLOCK
HRLI R2,(R2) ; FORM XWD NCHAR,NCHAR
SUB SS,R2 ; RESTORE SS TO INITIAL VALUE
MOVN R2,R2 ; FORM XWD -NCHAR,FIRST CHAR PTR
HRRI R2,(SS)
AOBJN R2,.+1
SYMCHR: MOVE R0,(R2) ; GET NEXT CHAR OFF SS
IDPB R0,R1 ; PUT IN STRING
AOBJN R2,SYMCHR ; LOOP FOR EACH CHAR
JRST (R8) ; RETURN
PRGEND
SUBTTL S$$NGS,S$$NGF STRING NEGATION ROUTINES
ENTRY S$$NGS,S$$NGF
EXTERN S$$STB,S$$STP,S$$FLR,S$$FLP
RADIX 10
SEARCH S$$NDF
COMMENT/
CALL: JSP R12,S$$NGS ; START NEGATION, FAILPT IS LOC TO GO TO
FAILPT ; IF NEGATION ARG FAILS (AND NEGATION THUS SUCCEEDS)
CALL: JRST S$$NGF ; NEGATION FAILS (BECAUSE ARG SUCCEEDED)/
S$$NGS: PUSH SS,S$$FLP ; SAVE OLD FAILPOINT
PUSH SS,S$$STP-1 ; SAVE SS PREVIOUS
MOVN R1,S$$STB ; COMPUTE NEW ES PREVIOUS
ADD R1,ES
EXCH R1,S$$STP ; EXCHANGE WITH OLD ES PREVIOUS
PUSH SS,R1 ; SAVE OLD ES PREVIOUS
PUSH SS,(R12) ; SAVE FAILPOINT
MOVN R1,S$$STB-1 ; COMPUTE NEW SS PREVIOUS
ADD R1,SS
MOVEM R1,S$$STP-1 ; AND SAVE
HRROI R1,NEGFAL ; COMPUTE NEW FAILPOINT
MOVEM R1,S$$FLP ; SAVE
JRST 1(R12) ; CONTINUE WITH ARGUMENT
NEGFAL: MOVE SS,S$$STB-1 ; RESTORE SS
ADD SS,S$$STP-1
POP SS,R12 ; GET FAILPOINT
POP SS,ES ; GET OLD ES PREVIOUS
EXCH ES,S$$STP ; EXCHANGE WITH CURRENT ES PREVIOUS
ADD ES,S$$STB ; UPDATE ES
POP SS,S$$STP-1 ; RESTORE OLD SS PREVIOUS
POP SS,S$$FLP ; GET OLD FAILPOINT
SETZ R1, ; RESULT IS NULL
JRST (R12) ; SUCCEED TO FAILPOINT
S$$NGF: SUB SS,[XWD 1,1] ; THROW AWAY FAILPOINT
POP SS,S$$STP ; RESTORE ES PREVIOUS
POP SS,S$$STP-1 ; RESTORE SS PREVIOUS
POP SS,S$$FLP ; RESTORE OLD FAILPOINT
JRST S$$FLR ; FAIL
PRGEND
SUBTTL S$$ADD,S$$SUB,S$$MUL,S$$DIV DESCRIPTOR ARITHMETIC ROUTINES
ENTRY S$$ADD,S$$SUB,S$$MUL,S$$DIV
EXTERN S$$PGL,S$$STN,S$$ITR
RADIX 10
SEARCH S$$NDF
COMMENT/
CALL: JSP R12,S$$XXX ; WITH SECOND (RIGHT) ARG IN R1 AND
FIRST (LEFT) ARG ON ES, RETURNS RESULT IN R1 WITH ES POPED/
S$$ADD: JSP R11,ARITH ; ADD, INDEX=0
S$$SUB: JSP R11,ARITH ; SUBTRACT, INDEX=1
S$$MUL: JSP R11,ARITH ; MULTIPLY, INDEX=2
S$$DIV: JSP R11,ARITH ; DIVIDE, INDEX=3
ARITH: SUBI R11,S$$ADD+1
MOVEM R12,S$$PGL ; SAVE LINK
SETZ R2, ; GET DESCR TYPE
ROTC R1,2
JRST .+1(R2) ; CONVERT TO VALUE
JSP R7,S$$STN-1 ; STRING, CONVERT TO INTEGER OR REAL
CFERR 1,S$$PGL ; OTHER, OR FAILED STRING CONVERSION
ASH R1,-2 ; INTEGER, RESTORE VALUE
MOVEI R10,(R2) ; REAL, OR SUCEEDED STRING CONV, SAVE TYPE
MOVE R9,R1 ; SAVE VALUE
POP ES,R1 ; GET LEFT HAND SIDE
SETZ R2, ; SIMILAR CONVERSION
ROTC R1,2
JRST .+1(R2)
JSP R7,S$$STN-1
CFERR 1,S$$PGL
ASH R1,-2
CAIE R2,(R10) ; TYPES THE SAME?
JRST MIXMOD ; NO, MIXED MODE
XCT OPERAT(R11) ; YES, PERFORM OPERATION
MAKDSC: JRST .-1(R2) ; FORM DESCRIPTOR
LSH R1,2 ; FOR INTEGER
ROTC R1,-2 ; AND REAL
JRST (R12) ; RETURN
; OPERATION TABLE
OPERAT: XCT ADDOP-2(R2)
XCT SUBOP-2(R2)
XCT MULOP-2(R2)
XCT DIVOP-2(R2)
; MODE TABLES
ADDOP: ADD R1,R9
FAD R1,R9
SUBOP: SUB R1,R9
FSB R1,R9
MULOP: IMUL R1,R9
FMP R1,R9
DIVOP: JSP R4,[MOVEI R3,(R2)
IDIV R1,R9
MOVEI R2,(R3)
JRST (R4)]
FDV R1,R9
MIXMOD: CAIE R10,3 ; IS RIGHT HAND SIDE REAL?
EXCH R1,R9 ; NO, IS INTEGER, EXCHANGE WITH LHS
JSP R3,S$$ITR ; CONVERT ARG THAT IS INTEGER TO REAL
CAIE R10,3 ; WERE SIDES EXCHANGED?
EXCH R1,R9 ; YES, RE-EXCHANGE
MOVEI R2,3 ; NOW BITH SIDES ARE REAL
XCT OPERAT(R11) ; PERFORM OPERATION
ROTC R1,-2 ; FORM REAL DESCR
JRST (R12) ; RETURN
PRGEND
SUBTTL S$$EXP DESCRIPTOR MODE EXPONENTIATION ROUTINE
ENTRY S$$EXP
EXTERN S$$PGL,S$$STN,S$$ITR,EXP1.0,EXP2.0,EXP3.0
RADIX 10
SEARCH S$$NDF
COMMENT/
CALL: JSP R12,S$$EXP ; WITH SECOND (RIGHT) ARG IN R1 AND
FIRST (LEFT) ARG ON ES, RETURNS RESULT IN R1 WITH ES POPPED/
S$$EXP: MOVEM R12,S$$PGL ; SAVE LINK
SETZ R2, ; GET DESCR TYPE
ROTC R1,2
JRST .+1(R2) ; CONVERT TO INTEGER OR REAL VALUE
JSP R7,S$$STN-1
CFERR 1,S$$PGL
ASH R1,-2
MOVEI R10,(R2) ; SAVE TYPE AND VALUE OF RHS
MOVE R9,R1
POP ES,R1 ; GET LHS
SETZ R2, ; LIKEWISE CONVERT
ROTC R1,2
JRST .+1(R2)
JSP R7,S$$STN-1
CFERR 1,S$$PGL
ASH R1,-2
CAIL R2,(R10) ; IS IT INTEGER ** REAL?
JRST .+3 ; NO
JSP R3,S$$ITR ; YES, MAKE IT REAL ** REAL
MOVEI R2,3
MOVE R0,R1 ; GET ARGS INTO POSITION FOR FORTRAN LIBRARY
MOVE R1,R9 ; CALL
PUSHJ SS,@EXPTBL-2(R2) ; EXECUTE PROPER EXPONENTIATION
IORI R2,(R10) ; FORM DOMINANT TYPE
MOVE R1,R0 ; GET VAL INTO POSITION
JRST .-1(R2) ; AND MAKE DESCR
LSH R1,2 ; INTEGER
ROTC R1,-2 ; REAL
JRST (R12) ; RETURN
EXPTBL: JRST EXP1.0 ; I ** I
JRST @EXPTB1-2(R10) ; R ** ?
EXPTB1: JRST EXP2.0 ; R ** I
JRST EXP3.0 ; R ** R
PRGEND
SUBTTL S$$NEG DESCRIPTOR UNARY - ROUTINE
ENTRY S$$NEG
EXTERN S$$PGL,S$$STN
RADIX 10
SEARCH S$$NDF
COMMENT/
CALL: JSP R12,S$$NEG ; WITH DESCRIPTOR IN R1/
S$$NEG: MOVEM R12,S$$PGL ; SAVE LINK
SETZ R2, ; GET TYPE
ROTC R1,2
JRST .+1(R2) ; CONVERT TO INTEGER OR REAL VALUE
JSP R7,S$$STN-1 ; STRING
CFERR 1,S$$PGL ; OTHER, OR STRING CONV FAILED
ASH R1,-2 ; INTEGER
MOVN R1,R1 ; REAL, AND NEGATE
JRST .-1(R2) ; MAKE DESCR AGAIN
LSH R1,2 ; INTEGER
ROTC R1,-2 ; REAL
JRST (R12) ; RETURN
PRGEND
SUBTTL S$$CNC CONCATENATION ROUTINE
ENTRY S$$CNC
EXTERN S$$PGL,S$$GRS,S$$MKS,S$$TAC,S$$MST,S$$PTS,S$$PTX
RADIX 10
SEARCH S$$NDF
COMMENT/
CALL: JSP R12,S$$CNC ; WHERE NCONC IS THE NUMBER OF ELEMENTS
NCONC ; IN THE CONCATENATION, ALL BUT THE LAST PUSHED ONTO ES
AND THE LAST IN R1. IF ALL BUT ONE ELEMENT IS NULL-VALUED, THE RESULT
IS THAT ELEMENT. IF ALL NON-NULL ELEMENTS ARE EITHER STRINGS, INTEGERS,
OR REALS, THE RESULT IS THEIR CONCATENATED STRING. IF ALL NON-NULL
ELEMENTS ARE EITHER STRINGS, INTEGERS, REALS, OR PATTERNS, THE RESULT IS
THEIR CONCATENATED PATTERN. IF ANY ELEMENT IS NONE OF THESE, AND ANOTHER
NON-NULL ELEMENT EXISTS, IT IS A TYPE ERROR. THE RESULT DESCRIPTOR IS RE-
TURNED IN R1, WITH ES RESTORED TO ITS INITIAL STATE (NCONC-1 ELEMENTS
POPPED OFF)/
S$$CNC: MOVEM R12,S$$PGL ; SAVE PROG LINK
PUSH ES,R1 ; SAVE LAST ELT
MOVN R11,(R12) ; FORM -(NCONC,NCONC)
HRLI R11,-1(R11)
MOVE R10,ES ; FORM RESET ES
ADD R10,R11
MOVEM R10,SAVNES ; AND SAVE
HRRI R11,(R10) ; FORM XWD -NCONC,PTR TO FIRST ELEMENT
AOBJN R11,.+1
MOVEM R11,SAVELP ; AND SAVE
SETZ R10, ; INITIALIZE ELEMENT COUNT=0
SETZB R9,R8 ; INITIALIZE CHAR COUNT, SAVED ELT =0
; SEARCH LOOP, CHECK EACH ELEMENT ON ES
SRCHLP: MOVE R1,(R11) ; GET NEXT ELEMENT
JUMPE R1,GTNXTS ; SKIP OUT IF NULL
JUMPL R1,SRCNUM ; JUMP IF INTEGER OR REAL
TLNE R1,^O770000 ; IS IT STRING?
JRST SRCPAT ; NO, TRY PATTERN
HRRZ R3,(R1) ; GET CHAR COUNT
JUMPN R3,SRCSTR ; JUMP IF NONZERO
SETZM (R11) ; OR MAKE ELEMENT NULL
JRST GTNXTS ; AND SKIP OUT
CNVNUM: SETO R0, ; MAKE STRING FROM INTEGER OR REAL
JSP R7,S$$MKS ; WILL ALLWAYS SKIP OVER NEXT INSTR
SRCSTR: SKIPN R8,R1 ; SAVE DESCR IN R8 AND SKIP
MOVEM R1,(R11) ; SAVE NEW STRING AS ELT
ADDI R9,(R3) ; ADD CHARS TO TOTAL
AOJA R10,GTNXTS ; INCREMENT ELT COUNT AND LOOP
SRCNUM: JUMPN R10,CNVNUM ; IF ELT COUNT > 0, GO CONVERT TO STRING
HRRM R11,SAVNPT ; OR SAVE PTR TO ELT
NUMLOP: AOBJP R11,RETSAV+1 ; POINT TO NEXT ELT OR FINISH
MOVE R8,(R11) ; GET NEXT ELT
JUMPE R8,NUMLOP ; LOOP IF NULL
TLNE R8,^O770000 ; IS IT STRING?
JRST NUMCNV ; NO
HRRZ R3,(R8) ; YES, GET CHAR COUNT
JUMPN R3,NUMCNV ; DON'T JUMP IF 0
SETZM (R11) ; SET ELT TO NULL
JRST NUMLOP ; AND KEEP LOOPING
NUMCNV: SETO R0, ; CONVERT SAVED NUMBER TO STRING
JSP R7,S$$MKS
SAVNES: BLOCK 1 ; NEVER EXECUTED, USE FOR STORAGE
SAVNPT: MOVEM R1,.-. ; SAVE NEW STRING DESCR IN ELT LOC
MOVEI R9,(R3) ; INITIALIZE CHAR COUNT
MOVE R1,R8 ; GET CURRENT DESCR
AOJA R10,SRCHLP+2 ; INCREMENT ELT COUNT AND PROCEED
SRCPAT: TLC R1,1B20 ; IS IT PATTERN?
TLNN R1,3B21
AOBJP R10,SAVELT ; YES, INCREMENT ELT COUNT, MARK AS PAT
JUMPN R10,SPCERR ; NO, ERROR IF ANOTHER NON-NULL ELEMENT
TLC R1,1B20 ; RESTORE DESCR
SPCLOP: AOBJP R11,RETSAV+1 ; POINT TO NEXT ELT OR FINISH
MOVE R8,(R11) ; GET NEXT ELT
JUMPE R8,SPCLOP ; LOOP IF NULL
TLNE R8,^O770000 ; IS IT STRING?
SPCERR: CFERR 1,S$$PGL ; NO, ERROR
HRRZ R3,(R8) ; GET # OF CHARS
JUMPE R3,SPCLOP ; LOOP IF 0
CFERR 1,S$$PGL ; OR ERROR
SAVELT: TLC R1,1B20 ; RESTORE DESCR
MOVE R8,R1 ; SAVE LATEST ELEMENT
GTNXTS: AOBJN R11,SRCHLP ; POINT TO NEXT ELEMENT AND LOOP
; ELEMENT SEARCH IS OVER, FORM NEW STRING OR PATTERN
CAIG R10,1 ; IS # ELTS >1 ?
JRST RETSAV ; NO, FINISH
MOVE R11,SAVELP ; YES, GET FIRST ELT POINTER
CAIL R10,^O777777 ; IS PATTERN FLAG ON?
JRST MAKPAT ; YES, GO MAKE PATTERN
MOVEI R0,(R9) ; NO, STRING, COMPUTE # OF WORDS NEEDED
MUL R0,[^F0.2B0]
ADDI R0,2
JSP R6,S$$GRS ; GET BLOCK
HRLI R1,^O700 ; FORM DESCR
MOVE R8,R1 ; SAVE
HRRM R9,(R1) ; AND SAVE # OF CHARS IN STRING BLOCK
MOVE R7,[XWD STRCHR,CHRLOP] ; MOVE CHAR LOOP INTO R4-R7
BLT R7,CHRBOT
STRLOP: MOVE R2,(R11) ; GET NEXT ELT
JUMPE R2, STRBOT ; SKIP OUT IF NULL
HRRZ R3,(R2) ; GET CHAR COUNT
JRST CHRLOP ; START LOOP
STRCHR: PHASE 4
CHRLOP: ILDB R0,R2 ; R4: GET CHAR FROM ELT
IDPB R0,R1 ; R5: PUT CHAR IN NEW STRING
SOJG R3,CHRLOP ; R6: LOOP
CHRBOT: JRST STRBOT ; R7: OR EXIT
DEPHASE
STRBOT: AOBJN R11,STRLOP ; LOOP FOR EACH ELEMENT
RETSAV: MOVE R1,R8 ; RESTORE RESULT DESCR
MOVE ES,SAVNES ; RESTORE POPPED ES
JRST 1(R12) ; RETURN
; AT LEAST ONE ELEMENT IS A PATTERN, CREATE PATTERN ROUTINE AND DATA BLOCK
MAKPAT: MOVEI R0,1(R10) ; GET # ELTS + 1
CAIG R0,2 ; IS # ELTS > 1?
JRST RETSAV ; NO, FINISH
JSP R6,S$$GRS ; GET DATA BLOCK
HRLI R1,3B20 ; MAKE PATTERN DESCR
MOVE R8,R1 ; SAVE
HRLI R1,^O700 ; FAKE STRING DESCR AND SAVE
MOVEM R1,S$$TAC ; IN CASE OF GARBAGE COLLECTION
LSH R0,1 ; GET 2*(#ELTS+1)
JSP R6,S$$GRS ; GET BLOCK FOR PATTERN ROUTINE
ADDI R1,1 ; PTR TO FIRST INST
HRRM R1,(R8) ; SAVE POINTER TO ROUTINE IN DATA BLOCK
MOVE R9,[MOVE R1,1(DT)] ; INSTR. TO FETCH ELT FROM DATBLK
MOVE R7,[JSP R9,S$$MST] ; INSTR. IF STRING
MOVE R6,[JSP R9,S$$PTX] ; ISTR. IF PATTERN
MOVEI R10,1(R8) ; FIRST ELT PTR IN DATA BLOCK
PATLOP: MOVE R2,(R11) ; GET NEXT ELT
JUMPE R2,PATBOT ; SKIP OUT IF NULL
TLNE R2,^O770000 ; IS IT STRING?
JRST PATELT ; NO, PATTERN
MOVEM R7,1(R1) ; YES, SAVE STRING MATCH INSTR
PATRET: MOVEM R2,(R10) ; SAVE ELT IN DATA BLOCK
MOVEM R9,(R1) ; SAVE ELT FETCH INSTR
ADDI R1,2 ; NEXT INSTR LOC IN PATTERN ROUTINE
ADDI R9,1 ; NEXT ELT FETCH INSTR
ADDI R10,1 ; NEXT DATA BLOCK LOC
PATBOT: AOBJN R11,PATLOP ; LOOP FOR EACH ELT
MOVE R6,[JRST S$$PTS] ; LAST INSTR OF PATTERN ROUTINE
MOVEM R6,(R1)
SETZM S$$TAC ; CLEAR DUMMY STRING DESCR
JRST RETSAV ; FINISH
PATELT: TLNE R2,1B22 ; IS SUBPAT RESTARTEABLE?
TLO R8,1B22 ; YES, SET RESTARTEABLE BIT OF WHOLE PAT
MOVEM R6,1(R1) ; SAVE PAT MATCH INST
JRST PATRET ; REJOIN LOOP
; STORAGE
SAVELP: BLOCK 1
PRGEND
SUBTTL S$$IVN,S$$IVV INDIRECT VARIABLE NAME AND VALUE ROUTINES
ENTRY S$$IVN,S$$IVV
EXTERN S$$PGL,S$$LKV,S$$CPS
RADIX 10
SEARCH S$$NDF
COMMENT/
CALL: JSP R12,S$$IVN ; WITH KEY DESCRIPTOR IN R1, RETURNS
NAME DESCRIPTOR IN R1 (SAME AS KEY IF KEY IS NAME)
CALL: JSP R12,S$$IVV ; WITH KEY DESCRIPTOR IN R1, RETURNS
VALUE DESCRIPTOR IN R1 (DOES NO LOOKUP IF KEY IS NAME)/
S$$IVN: JSP R11,S$$IVV+1 ; NAME, INDEX=0
S$$IVV: JSP R11,S$$IVV+1 ; VALUE, INDEX=1
SUBI R11,S$$IVN+1
SETZ R2, ; GET DESCR TYPE
ROTC R1,4
CAIE R2,4 ; IS IT NAME?
JRST INDLKP ; NO, DO LOOKUP
ROTC R1,-4 ; RESTORE DESCR
INDCOM: XCT [JRST (R12)
MOVE R2,R1](R11) ; RETURN FOR NAME CALL
MOVE R1,(R2) ; GET VALUE
TLNE R2,1B22 ; IS IT DEDICATED INTEGER OR REAL?
JRST DEDVAR ; YES
TLNE R2,1B23 ; IS IT DEDICATED STRING?
JSP R7,S$$CPS ; YES, COPY
JRST (R12) ; RETURN VALUE
DEDVAR: TLNN R2,1B23 ; IS IT DEDICATED REAL?
JRST MKIDSC ; NO, MAKE INT DESCR
LSH R1,-2 ; MAKE REAL DESCR
TLO R1,3B19
JRST (R12) ; RETURN
MKIDSC: TLZ R1,1B19 ; MAKE INTEGER DESCR
TLO R1,1B18
JRST (R12) ; RETURN
INDLKP: MOVEM R12,S$$PGL ; SAVE LINK
ROTC R1,-4 ; RESTORE DESCR
JSP R10,S$$LKV ; DO LOOKUP
MOVE R1,(R2) ; GET NAME
JRST INDCOM ; RETURN OR GET VALUE
PRGEND
SUBTTL S$$ILB INDIRECT LABEL FUNCTION
ENTRY S$$ILB
EXTERN S$$PGL,S$$LKL
RADIX 10
SEARCH S$$NDF
COMMENT/
CALL: JSP R12,S$$ILB ; WITH KEY DESCRIPTOR IN R1, EXECUTES
VALUE LOCATION/
S$$ILB: MOVEM R12,S$$PGL ; SAVE PROG LINK
JSP R10,S$$LKL ; DO LOOKUP
XCT (R2) ; PERFORM GOTO
PRGEND
SUBTTL S$$LKV,S$$LKL,S$$LKF VARIABLE, LABEL, AND FUNCTION LOOKUP
ENTRY S$$LKV,S$$LKL,S$$LKF
EXTERN S$$LKS,S$$PGL,S$$GLP,S$$GNS,S$$UDF
RADIX 10
SEARCH S$$NDF
COMMENT/
CALL: JSP R10,S$$LKV[S$$LKL,S$$LKF] ; WITH KEY DESCRIPTOR IN
R1, RETURNS POINTER TO VALUE LOCATION IN R2/
S$$LKV: JSP R9,S$$LKF+1 ; VARIABLE, INDEX = 0
S$$LKL: JSP R9,S$$LKF+1 ; LABEL, INDEX = 1
S$$LKF: JSP R9,S$$LKF+1 ; FUNCTION, INDEX = 2
SUBI R9,S$$LKL
MOVEI R0,(R9) ; GET TYPE
TLO R0,1B18 ; FORM TYPE*2+1
ROT R0,-4 ; IN BITS 0-4
JSP R8,S$$LKS ; DO LOOKUP
JRST (R10) ; FOUND
XCT NEWLKV(R9) ; NEW ENTRY, GET APPROPRIATE VALUE
NEWLKC: MOVEM R5,(R2) ; SAVE
JRST (R10) ; RETURN
NEWLKV: JRST .+3 ; VARIABLE
MOVE R5,[UFERR 8,S$$PGL] ; LABEL
MOVE R5,[XWD 1B19,S$$UDF] ; FUNCTION
HRRZ R5,S$$GLP+1 ; GET GLOBAL VARIABLE BLOCK
HLRZ R6,(R5) ; GET SIZE
ANDI R6,^O177777
CAMG R6,S$$GLP+2 ; ROOM LEFT?
JRST NEWVBL ; NO, MAKE NEW BLOCK
ADD R5,S$$GLP+2 ; YES, POINT TO NEXT AVAILABLE LOC
AOS S$$GLP+2 ; INCREMENT LOC INDEX
NEWVBC: TLO R5,1B19 ; FORM NAME DESCR
JRST NEWLKC ; GO BACK TO SEQUENCE
NEWVBL: HRRM R2,NEWVR2 ; SAVE VALUE POINTER
MOVEI R0,P$GVXT ; GET GLOBAL VARIABLE BLOCK EXTENSION SIZE
JSP R6,S$$GNS ; GET NONRETURNABLE BLOCK
MOVE R2,S$$GLP+1 ; GET VAR BLOCK LIST
HRRM R1,(R2) ; APPEND NEW BLOCK
HRRI R2,(R1)
MOVEM R2,S$$GLP+1
MOVEI R2,2 ; NEW AVAIL INDEX
MOVEM R2,S$$GLP+2
NEWVR2: MOVEI R2,.-. ; RESTORE VALUE POINTER
MOVEI R5,1(R1) ; FORM POINTER TO VARIABLE LOC
HRLI R1,1(R1) ; SET INITIAL VALUES
MOVEI R3,P$GVXT-1(R1) ; OF VARIABLES IN NEW VAR BLOCK
SETZM 1(R1) ; TO NULL
HRRI R1,2(R1)
BLT R1,(R3)
JRST NEWVBC ; FORM NAME AND GO BACK TO SEQUENCE
PRGEND
SUBTTL S$$LKS INDIRECTION SYMBOL LOOKUP ROUTINE
ENTRY S$$LKS
EXTERN S$$MKS,S$$PGL,S$$PBP,S$$SY1,S$$SY2,S$$GLP,S$$TBM,S$$MNS
RADIX 10
SEARCH S$$NDF
COMMENT"
CALL: JSP R8,S$$LKS ; WITH TYPE/0,0 IN R0, KEY DESCRIPTOR
IN R1. RETURNS TO 0(R8) IF FOUND, WITH POINTER TO VALUE LOC
IN R2. RETURNS TO 1(R8) IF NEW ENTRY, WITH POINTER TO VALUE LOC
IN R2, AND STRING VALUE OF KEY MADE NONRETURNABLE"
S$$LKS: TLNN R1,^O770000 ; IS IT A STRING?
JRST .+5 ; YES
MOVN R0,R0 ; NO, TRY TO CREATE ONE
JSP R7,S$$MKS
CFERR 1,S$$PGL ; NO GO
MOVN R0,R0 ; RESTORE TYPE
CAML R0,[7B4] ; IS IT < TYPE 7?
JRST SPCLKS ; NO, SPECIAL
ADD R0,@S$$PBP ; ADD TABLE NUMBER TO LH
HLRI R0, ; AND ZERO RH
JSP R7,S$$SY1 ; LOOKUP SYMBOL
JRST (R8) ; FOUND
ADD R0,[1B4] ; MAKE TYPE GLOBAL
TLZ R0,^O17777 ; WITH TABLE # = 0
JSP R7,S$$SY2 ; AND RETRY LOOKUP
JRST (R8) ; FOUND
MNELKS: MOVE R4,S$$GLP ; NOT FOUND, GET GLOBAL TABLE DESCR
JSP R7,S$$TBM ; MAKE NEW ENTRY
HRRM R2,RR2LKS ; SAVE VALUE POINTER
JSP R6,S$$MNS ; MAKE STRING BLOCK NONRETURNABLE
RR2LKS: MOVEI R2,.-. ; RESTORE VALUE POINTER
JRST 1(R8) ; RETURN NEW ENTRY
SPCLKS: JSP R7,S$$SY1 ; LOOKUP SYMBOL
JRST (R8) ; FOUND
JRST MNELKS ; NOT FOUND, MAKE NEW ENTRY
PRGEND
SUBTTL S$$TBM NEW TABLE ENTRY FUNCTION
ENTRY S$$TBM
EXTERN S$$GNS,S$$GRS,S$$TA1,S$$GLP
RADIX 10
SEARCH S$$NDF
COMMENT"
CALL: JSP R7,S$$TBM ; WITH TYPE/NO.,MAJORKEY IN R0, KEY
DESCRIPTOR IN R1, NEXT ENTRY POINTER IN R2, AND TABLE DESCRIPTOR
IN R4. RETURNS POINTER TO VALUE LOC OF NEW ENTRY IN R2, WITH
R0 AND R1 UNCHANGED"
S$$TBM: MOVE R3,1(R4) ; GET CURRENT SIZE AND POINTER
CAML R3,-1(R3) ; WITHIN CURRENT BLOCK?
JRST NEWEXT ; NO, GET NEW EXTENSION BLOCK
NEWEXR: HLRZ R5,R3 ; GET CURRENT SIZE
HRLI R3,4(R5) ; ADD 4 LOCS
MOVEM R3,1(R4) ; UPDATE CURRENT SIZE, POINTER
ADDI R3,(R5) ; PTR TO NEW ENTRY
MOVEM R0,1(R3) ; SAVE TYPE/NO.,MAJORKEY
MOVEM R1,2(R3) ; SAVE KEY DESCR
HLL R2,(R2) ; FORM CHAIN WORD
MOVEM R2,(R3) ; AND SAVE
HRLM R3,(R2) ; SPLICE ENTRY INTO CHAIN
MOVS R2,R2
HRRM R3,(R2)
MOVEI R2,3(R3) ; FORM POINTER TO VALUE LOC
JRST (R7) ; AND RETURN
NEWEXT: MOVEM R0,SAVTMP ; SAVE R0,R2,R4, AND KEY DESCR
MOVEM R2,SAVTMP+1
MOVEM R4,SAVTMP+2
MOVEM R1,S$$TA1
HRRZ R0,(R4) ; GET EXTENSION BLOCK SIZE
CAMN R4,S$$GLP ; IS TABLE GLOBAL SYMBOL TABLE?
JRST TBMGNS ; YES, GET NONRETURNABLE BLOCK
JSP R6,S$$GRS ; NO, GET RETURNABLE BLOCK
TBMGNR: MOVE R4,SAVTMP+2 ; RESTORE R4
MOVE R3,1(R4) ; GET LAST EXT POINTER
HRRM R1,-1(R3) ; SAVE EXTENSION POINTER TO NEW ONE
SUBI R0,2 ; EXTENSION SIZE MAX
HRLZM R0,1(R1) ; SAVE IN NEW EXTENSION BLOCK
MOVEI R3,2(R1) ; FORM NEW EXTENSION POINTER
SETZ R1,
EXCH R1,S$$TA1 ; RESTORE KEY DESCR
MOVE R2,SAVTMP+1 ; RESTORE R2 AND R0
MOVE R0,SAVTMP
JRST NEWEXR ; RETURN TO SEQUENCE
TBMGNS: JSP R6,S$$GNS ; GET NONRETURNABLE BLOCK
JRST TBMGNR
; STORAGE
SAVTMP: BLOCK 3
PRGEND
SUBTTL S$$TMR 'TIMER' OPTION ROUTINES
ENTRY S$$STT,S$$TMF,S$$TMX,S$$TMO
EXTERN S$$STE,S$$KWD,S$$PBP,S$$TMS,S$$OUC,S$$OUT,S$$ITS
RADIX 10
SEARCH S$$NDF
COMMENT/
STATEMENT TIMING
CALL: JSP R12,S$$STT ; FINISH TIMING ON LAST STATEMENT, START
XWD STNO,FAILPT ; TIMING ON NEW ONE, AND THEN GO TO
S$$STE. DOES NOTHING IF TIMING IS NOT ACTIVE FOR CURRENT ROUTINE,
OR DOES NOT FINISH TIMING ON LAST STATEMENT IF &STNO IS 0.
FUNCTION RETURN TIMING
CALL: JSP R5,S$$TMF ; SIMILAR TO S$$STT, BUT CALLED FROM
FUNCTION RETURN OR SYSTEM EXIT TO CLOSE OUT TIMING ON LAST &STNO.
TIMER EXIT STATISTICS
CALL: JSP R7,S$$TMX ; WITH PROGRAM LIST IN R6, OUTPUTS TIMING
STATISTICS FOR EACH PROGRAM BEING TIMED.
PROGRAM TIMER STATISTICS
CALL: JSP R7,S$$TMO ; WITH PARBLK POINTER IN R6, TIMING
BLOCK POINTER IN R5, OUTPUTS TIMING STATISTICS FOR PROGRAM
SPECIFIED BY PARBLK POINTER, LEAVES R6 UNCHANGED/
; STATEMENT AND FUNCTION RETURN TIMING
S$$STT: JSP R4,TMRCOM ; STATEMENT TIMING, INDEX = 0
S$$TMF: JSP R4,TMRCOM ; RETURN TIMING, INDEX = 1
TMRCOM: SUBI R4,S$$STT+1
HRRZ R3,@S$$PBP ; GET TIMING BLOCK POINTER
JUMPE R3,TMRFIN(R4) ; SKIP OUT IF NO TIMING
SETZ R0,
RUNTIM R0, ; GET CURRENT RUNTIME
MOVE R1,S$$TMS ; GET PREVIOUS RUNTIME
MOVEM R0,S$$TMS ; SAVE CURRENT RUNTIME
MOVE R2,S$$KWD+2 ; GET &STNO
JUMPE R2,TMRFIN(R4) ; SKIP OUT IF 0 (NO TIMING YET)
SUB R0,R1 ; COMPUTE ELAPSED TIME FOR STATEMENT
ADDM R0,(R3) ; ADD TO TOTAL TIME
HRLI R0,1 ; 1 MORE STATEMENT FOR COUNT
ADDI R3,(R2) ; TIMING BLOCK ENTRY FOR STATEMENT
ADDM R0,(R3) ; ADD 1,TIME TO TOTAL EXECUTION FOR STATEMENT
JRST TMRFIN(R4) ; EXIT
TMRFIN: JRST S$$STE ; STATEMENT TIMING EXIT
JRST (R5) ; RETURN TIMING EXIT
; TIMER EXIT STATISTICS
S$$TMX: HRRM R7,TMXFIN ; SAVE RETURN LINK
HLRZ R6,R6 ; GET FIRST PROGRAM PARBLK
TMXLOP: HRRZ R5,1(R6) ; GET TIMING BLOCK POINTER
JUMPE R5,.+2 ; SKIP IF 0
JSP R7,S$$TMO ; OTHERWISE OUTPUT STATISTICS
HRRZ R6,(R6) ; GET NEXT PARBLK POINTER
JUMPN R6,TMXLOP ; AND LOOP IF NONZERO
TMXFIN: JRST .-. ; OR RETURN
; PROGRAM TIMER STATISTICS
S$$TMO: MOVE R1,MSG1 ; "////TIMING STATISTICS FOR "
MOVEM R1,@S$$OUC ; OUTPUT
MOVE R1,-1(R6) ; GET PROGRAM NAME STRING DESCR
MOVEM R1,@S$$OUT ; OUTPUT
MOVE R1,[POINT 7,MSG2S+5,27] ; INSERT IN TOTAL TIME MESSAGE
HRRZ R2,(R5) ; GET TOTAL TIME
HRRM R2,PERCNT ; SAVE IN PERCENT CALCULATION
SETZM MSG2S+6 ; CLEAR CONVERSION AREA
JSP R4,S$$ITS ; CONVERT TO STRING
MOVE R1,MSG2 ; "// TOTAL TIME FOR PROGRAM = XXX MS."
MOVEM R1,@S$$OUT ; OUTPUT
MOVE R1,MSG3 ; TIMING STATISTICS COLLUMN HEADER
MOVEM R1,@S$$OUT ; OUTPUT
SETZM STSTAT+3 ; INITIALIZE STATEMENT #
HLRZ R1,(R5) ; SET UP LOOP POINTER FOR STATEMENT BLOCK
ANDI R1,^O177777
MOVNI R1,(R1)
HRLI R5,(R1)
AOBJP R5,(R7) ; START AT FIRST STATEMENT ENTRY
HRLI R7,(R6) ; SAVE PARBLK POINTER
TMOLP1: AOS STSTAT+3 ; INCREMENT STATEMENT NUMBER
MOVE R1,(R5) ; GET COUNT,TIME
HLRZM R1,STSTAT+2 ; SAVE COUNT
HRRZM R1,STSTAT+1 ; SAVE TIME
MOVEI R2,100 ; COMPUTE % OF TOTAL
IMULI R2,(R1)
PERCNT: IDIVI R2,.-.
HRRZM R2,STSTAT ; SAVE
MOVE R3,MSG4S ; BLANK OUT NUMERIC FIELDS
MOVEM R3,MSG4S+1
MOVEM R3,MSG4S+4
MOVEM R3,MSG4S+7
MOVEM R3,MSG4S+10
MOVEI R6,3 ; 4 STATISTICS LOOP
TMOLP2: MOVE R1,STPOIN(R6) ; GET BYTE POINTER FOR STATISTIC
MOVE R2,STSTAT(R6) ; GET STATISTIC
JSP R4,S$$ITS ; CONVERT TO STRING IN MESSAGE
SOJGE R6,TMOLP2 ; LOOP FOR EACH STATISTIC
MOVE R1,MSG4 ; GET STATISTICS LINE
MOVEM R1,@S$$OUT ; OUTPUT
AOBJN R5,TMOLP1 ; LOOP FOR EACH STATEMENT
HLRZ R6,R7 ; RESTORE PARBLK POINTER
JRST (R7) ; RETURN
; STORAGE
MSG1: POINT 7,.+1,35
BYTE (2)2(16)7(18)27
BYTE (7)^O12,^O12,^O12,^O12,"*"
ASCII/TIMING STATISTICS FOR /
MSG2: POINT 7,.+1,35
BYTE (2)2(16)9(18)39
MSG2S: BYTE (7)^O12,^O12," "," ","T"
ASCII/OTAL TIME FOR PROGRAM = MS./
MSG3: POINT 7,.+1,35
BYTE (2)2(16)13(18)62
BYTE (7)^O12,^O12," ","S","T"
ASCII/ATEMENT # OF EXECUTIONS TIME IN MS. /
ASCII/ % OF TOTAL TIME/
MSG4: POINT 7,.+1,35
BYTE (2)2(16)12(18)55
MSG4S: REPEAT 11,< ASCII/ />
STPOIN: POINT 7,MSG4S+10
POINT 7,MSG4S+7
POINT 7,MSG4S+4
POINT 7,MSG4S+1
STSTAT: BLOCK 4
PRGEND
SUBTTL S$$STE STATEMENT ENTRY ROUTINE
ENTRY S$$STE
EXTERN S$$KWD,S$$FLP,S$$ITS,S$$SST,S$$PBP,S$$OUT
RADIX 10
SEARCH S$$NDF
COMMENT/
CALL: JSP R12,S$$STE ; WHERE STNO IS THE STATEMENT NUMBER
XWD STNO,FAILPT ; AND FAILPT IS THE STATEMENT FAILPOINT
&LASTNO IS SET TO &STNO,&STNO IS SET TO STNO, &STCOUNT IS INCRE-
MENTED AND TESTED AGAINST &STLIMIT, AND THE FAILPOINT POINTER IS SET.
IF &STNTRACE IS NOT 0, A STATEMENT TRACE MESSAGE IS OUTPUT/
S$$STE: MOVE R1,(R12) ; GET STNO, FAILPT
HRRZM R1,S$$FLP ; SET FAILPOINT
HLRZ R1,R1 ; GET STNO
EXCH R1,S$$KWD+2 ; UPDATE &STNO, GET OLD &STNO
MOVEM R1,S$$KWD+1 ; SAVE AS NEW &LASTNO
AOS R1,S$$KWD+4 ; INCREMENT &STCOUNT
CAML R1,S$$KWD+13 ; IS IT < &STLIMIT
UFERR 6,R12 ; NO, ERROR
SKIPN S$$KWD+11 ; IS &STNTRACE ON?
JRST 1(R12) ; NO, RETURN
SETZM TRCMSG+5 ; INITIALIZE TRACE MESSAGE
SETZM TRCMSG+7
SETZM TRCMSG+8
SETZM TRCMSG+11
SETZM TRCMSG+12
MOVE R1,[POINT 7,TRCMSG+5] ; EDIT IN &STNO
MOVE R2,S$$KWD+2
JSP R4,S$$ITS
MOVE R1,S$$PBP ; EDIT IN PROGRAM NAME
MOVE R1,-2(R1)
HRRZ R2,(R1)
CAILE R2,10
MOVEI R2,10
MOVE R3,[POINT 7,TRCMSG+7]
ILDB R0,R1
IDPB R0,R3
SOJG R2,.-2
MOVE R1,[POINT 7,TRCMSG+11] ; EDIT IN TIME
SETZ R2,
RUNTIM R2,
SUB R2,S$$SST
JSP R4,S$$ITS
MOVE R1,MSGDSC ; OUTPUT TRACE MESSAGE
MOVEM R1,@S$$OUT
JRST 1(R12) ; RETURN
; STORAGE
MSGDSC: POINT 7,.+1,35
BYTE (2)2(16)14(18)65
TRCMSG: ASCII/*STNTRACE* OF STATEMENT /
BLOCK 1
ASCII/ IN /
BLOCK 2
ASCII/ AT TIME= /
BLOCK 2
PRGEND
SUBTTL S$$CPS COPY STRING ROUTINE
ENTRY S$$CPS
EXTERN S$$GRS,S$$TA1
RADIX 10
SEARCH S$$NDF
COMMENT/
CALL: JSP R7,S$$CPS ; WITH STRING DESCRIPTOR IN R1, RETURNS
NEW STRING DESCRIPTOR IN R1/
S$$CPS: JUMPE R1,(R7) ; RETURN IF NULL
HRRZ R2,(R1) ; GET CHAR COUNT
JUMPN R2,.+3 ; IS IT 0?
SETZ R1, ; YES, SET TO NULL VALUE
JRST (R7) ; AND RETURN
MUL R2,[^F0.2B0] ; COMPUTE NUMBER OF WORDS NEEDED
MOVEI R0,2(R2)
MOVEM R1,S$$TA1 ; SAVE OLD DESCR
JSP R6,S$$GRS ; GET BLOCK FOR NEW STRING
HRLI R1,^O700 ; FORM STRING DESCR
MOVE R2,R1 ; FORM BLT WORD
HRL R2,S$$TA1
HRRZ R3,@S$$TA1 ; TRANSFER CHAR COUNT
HRRM R3,(R2)
MOVE R3,R0 ; FORM END ADDR FOR BLT
ADDI R3,-1(R2)
AOBJP R2,.+1 ; START BLT ON SECOND WORD OF BLOCKS
BLT R2,(R3)
SETZM S$$TA1
JRST (R7) ; RETURN
PRGEND
SUBTTL S$$GNP GET NEXT NUMERICAL PARAMETER ROUTINE
ENTRY S$$GNP
RADIX 10
SEARCH S$$NDF
COMMENT/
CALL: JSP R4,S$$GNP ; WITH BYTE POINTER IN R1, BYTE COUNT
IN R3. PROCESSES SIGNED INTEGER INCLUDING DELIMITER AND RETURNS
TO 1(R4) WITH INTEGER VALUE IN R2 AND DELIMITER IN R0, OR RE-
TURNS TO 0(R4) IF DELIMITER IS NOT FOUND, WITH INTEGER IN R2/
S$$GNP: SETZ R2, ; INITIAL INTEGER VALUE
SOJL R3,(R4) ; RETURN IF NO MORE CHARS
HLLI R4, ; INITIAL SIGN IS +
ILDB R0,R1 ; GET FIRST CHAR
CAIE R0,"-" ; IS IT A - SIGN?
JRST TRYPLS ; NO, TRY PLUS
HRLI R4,-1 ; SET SIGN TO -
JRST NXTDIG ; GO INTO LOOP
TRYPLS: CAIN R0,"+" ; IS IT A + SIGN
JRST NXTDIG ; YES, GO INTO LOOP
DIGLOP: CAIL R0,"0" ; IS IT A DIGIT?
CAILE R0,"9"
AOJA R4,GNPFIN ; NO, DELIMITER FOUND
SUBI R0,"0" ; GET INTEGER DIGIT
IMULI R2,10 ; TOT = TOT*10+DIGIT
ADD R2,R0
NXTDIG: SOJL R3,GNPFIN ; QUIT IF NO MORE CHARS
ILDB R0,R1 ; GET NEXT CHAR
JRST DIGLOP ; AND LOOP
GNPFIN: JUMPGE R4,(R4) ; RETURN IF + VALUE
MOVN R2,R2 ; OR NEGATE
JRST (R4) ; AND RETURN
PRGEND
SUBTTL S$$ASG ASSIGNMENT ROUTINE
ENTRY S$$ASG
EXTERN S$$DSG,S$$PGL
RADIX 10
SEARCH S$$NDF
COMMENT/
CALL: JSP R9,S$$ASG ; WITH VALUE IN R1 AND NAME DESCRIPTOR
ON ES, DOES NORMAL OR DEDICATED ASSIGNMENT/
S$$ASG: MOVEM R9,S$$PGL ; SAVE PROGRAM LINK
POP ES,R8 ; GET NAME OFF ES
TLNE R8,3B23 ; ARE DEDICATED BITS ON?
JRST S$$DSG ; YES, DEDICATED ASSIGNMENT
MOVEM R1,(R8) ; NO, NORMAL ASSIGNMENT (POSSIBLE OUTPUT)
JRST (R9) ; RETURN
PRGEND
SUBTTL S$$MVS MOVE STRING ROUTINE
ENTRY S$$MVS
RADIX 10
SEARCH S$$NDF
P$BRKE=8 ; BREAK EVEN POINT OF REGISTER LOOP
COMMENT/
CALL: JSP R7,S$$MVS ; WITH OBJECT BYTE POINTER IN R1, SOURCE
BYTE POINTER IN R2, AND CHARACTER COUNT (>0) IN R3/
S$$MVS: CAIL R3,P$BRKE ; FEWER CHARS THAN BREAK EVEN POINT?
JRST MOVLOP ; NO, MOVE LOOP INTO FAST REGISTERS
CHRLP1: ILDB R0,R2 ; GET CHAR FROM SOURCE
IDPB R0,R1 ; PUT CHAR IN OBJECT
SOJG R3,CHRLP1 ; LOOP
JRST (R7) ; OR RETURN
MOVLOP: HLL R7,S$$MVS+1 ; INSERT JRST IN LH OF R7
MOVE R6,[XWD CHRLOP,CHRLP2] ; MOVE LOOP INTO R4-R6
BLT R6,CHRLPE
JRST CHRLP2 ; START LOOP
CHRLOP: PHASE 4
CHRLP2: ILDB R0,R2 ; R4: GET CHAR
IDPB R0,R1 ; R5: PUT CHAR
CHRLPE: SOJG R3,CHRLP2 ; R6: LOOP
DEPHASE
PRGEND
SUBTTL S$$EQS STRING EQUALITY TEST ROUTINE
ENTRY S$$EQS
RADIX 10
SEARCH S$$NDF
COMMENT/
CALL: JSP R5,S$$EQS ; WITH STRING DESCRIPTORS IN R1 AND R2,
RETURNS TO 0(R5) IF EQUAL AND 1(R5) IF NOT EQUAL/
S$$EQS: CAMN R1,R2 ; ARE DESCRIPTORS EQUAL?
JRST (R5) ; YES, STRINGS MUST BE EQUAL
SETZ R0, ; ZERO R0 INCASE DESCR IS 0 (POINTS TO R0)
HRRZ R3,(R2) ; GET FIRST CHAR COUNT, INCLUDING NULL OR ZERO
HRRZ R0,(R1) ; GET SECOND CHAR COUNT, INCLUDING NULL OR ZERO
CAIE R0,(R3) ; ARE COUNTS EQUAL?
JRST 1(R5) ; NO, STRINGS UNEQUAL
JUMPE R0,(R5) ; STRINGS EQUAL IF 0 CHAR
CAIG R0,5 ; <6 CHARS?
JRST CHRLOP ; YES, DO CHAR LOOP
MUL R3,POINT2 ; NO, COMPUTE # WORDS
ROT R4,4 ; AND # OF REM CHARS
MOVE R4,REMTBL(R4)
HRRM R4,GETREM ; SAVE REM CHARS
TLC R1,^B1001B27 ; SET BYTE PTRS
TLC R2,^B1001B27 ; FOR 35-BIT BYTES
WRDLOP: ILDB R0,R1 ; GET WORD FROM FIRST
ILDB R4,R2 ; GET WORD FROM SECOND
CAME R0,R4 ; EQUAL?
JRST 1(R5) ; NO, STRINGS UNEQUAL
SOJG R3,WRDLOP ; LOOP FOR EACH WORD
TLC R1,^B1001B27 ; SET BYTE PTRS
TLC R2,^B1001B27 ; BACK TO 7-BIT BYTES
GETREM: MOVEI R3,.-. ; GET REM CHARS
CHRLOP: ILDB R0,R1 ; GET CHAR FROM FIRST
ILDB R4,R2 ; GET CHAR FROM SECOND
CAIE R0,(R4) ; EQUAL?
JRST 1(R5) ; NO, STRINGS UNEQUAL
SOJG R3,CHRLOP ; LOOP FOR EACH CHAR
JRST (R5) ; STRINGS EQUAL IF ALL CHARS MATCH
; STORAGE
REMTBL=.-1 ; REM=0, IMPOSSIBLE
1 ; REM=1, 1 CHAR REM
POINT2: ^O63146300000 ; REM=2, IMPOSSIBLE, USE SPACE
2 ; REM=3, 2 CHAR REM
3 ; REM=4, 3 CHAR REM
0 ; REM=5, IMPOSSIBLE
4 ; REM=6, 4 CHAR REM
5 ; REM=7, 5 CHAR REM
PRGEND
SUBTTL S$$SRT,S$$NRT,S$$FRT 'RETURN','NRETURN','FRETURN' LABELS
ENTRY S$$SRT,S$$NRT,S$$FRT
EXTERN S$$KWD,S$$RTP,S$$TMF,S$$PGL
RADIX 10
SEARCH S$$NDF
COMMENT/
CALL: JRST S$$SRT[S$$NRT,S$$FRT] ; RESULT OF JUMP TO 'RETURN',
'NRETURN', OR 'FRETURN' LABELS/
S$$FRT: JSP R12,S$$NRT+1 ; 'FRETURN', INDEX=-1
S$$SRT: JSP R12,S$$NRT+1 ; 'RETURN', INDEX=0
S$$NRT: JSP R12,S$$NRT+1 ; 'NRETURN', INDEX=1
SUBI R12,S$$NRT
SOSGE S$$KWD+3 ; DECREMENT &FNCLEVEL
UFERR 2,S$$PGL ; RETURN FROM 0 LEVEL
MOVE R1,@RTNTYP(R12) ; GET RETURN TYPE
MOVEM R1,S$$KWD+6 ; SAVE IN &RTNTYPE
JSP R5,S$$TMF ; FINISH TIMING ON LAST STATEMENT
POPJ SS, ; GO TO APPROPRIATE FUNCTION RETURN ROUTINE
; STORAGE
S$$RTP+4 ; POINTS TO 'FRETURN' DESCRIPTOR
RTNTYP: S$$RTP ; POINTS TO 'RETURN' DESCRIPTOR
S$$RTP+8 ; POINTS TO 'NRETURN' DESCRIPTOR
PRGEND
SUBTTL S$$BGT BAD GOTO ERROR EXIT
ENTRY S$$BGT
EXTERN S$$PGL
RADIX 10
SEARCH S$$NDF
COMMENT/
CALL: JRST S$$BGT ; CALLED BY FAILPOINT ROUTINE DURING GOTO EVA
LUATION/
S$$BGT: UFERR 3,S$$PGL ; FAILURE DURING GOTO EVALUATION
PRGEND
SUBTTL S$$NFE FAILURE UNDER 'NOFAIL' ERROR EXIT
ENTRY S$$NFE
EXTERN S$$PGL
RADIX 10
SEARCH S$$NDF
COMMENT/
CALL: JRST S$$NFE ; CALLED BY FAILPOINT ROUTINE/
S$$NFE: UFERR 13,S$$PGL ; FAILURE UNDER 'NOFAIL'
PRGEND
SUBTTL S$$UDF UNDEFINED FUNCTION ERROR EXIT
ENTRY S$$UDF
EXTERN S$$PGL
RADIX 10
SEARCH S$$NDF
COMMENT/
CALL: JRST S$$UDF ; CALLED BY FCALV OR FCALN/
S$$UDF: CFERR 5,S$$PGL ; UNDEFINED FUNCTION CALL
PRGEND
SUBTTL S$$CPE COMPILATION ERROR EXIT
ENTRY S$$CPE
RADIX 10
SEARCH S$$NDF
COMMENT/
CALL: JSP R12,S$$CPE ; EXECUTION OF STATEMENT WITH COMPI-
LATION ERROR/
S$$CPE: UFERR 12,R12
END