home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Columbia Kermit
/
kermit.zip
/
ibmtsonih
/
tsnalp.pli
< prev
next >
Wrap
Text File
|
2020-01-01
|
249KB
|
3,081 lines
/* ALP -- ASSEMBLY LANGUAGE PREPROCESSOR -- VERSION 6.19 -- 04/02/88 */00001000
(SUBRG): /* CHECK SUBSCRIPTS */ /*RAF-3*/ 00001500
ALP: 00002000
PROCEDURE OPTIONS(MAIN) REORDER; 00003000
/*RAF-24*/ 00003100
DECLARE PLIXOPT CHAR(32) VARYING STATIC EXTERNAL /*RAF-24*/ 00003200
INIT('ISASIZE(70K)'); /*RAF-40*/ /*RAF-24*/ 00003300
/*RAF-24*/ 00003400
DEFAULT RANGE(*) ALIGNED; /*RAF-46*/ 00003500
/*RAF-46*/ 00003600
/* 00004000
INTERNAL PROCEDURES: 00005000
ALP (MAIN CONTROL PROGRAM) 00006000
STMNT 00007000
GROUP 00008000
CEND,CIF,CCASE,CWHILE,CDO,CFOR,CFOREVER,CGOTO,CEXIT,CNEXT, 00009000
CUSE,CASMIF,CMACRO,CBAL,CPCASE,ALCSTMT 00010000
PRED,GB 00011000
WLABEL,WFLUSH 00012000
GENSYM 00013000
00014000
INPUT (INPUT SCANNING PROCEDURES) 00015000
RWORD,ROPANDS 00016000
RCHECK,RCHAR 00017000
SKIP,INC,ALPHANUM 00018000
00019000
ERROR,OUTPUT 00020000
00021000
INPUT/OUTPUT CONVENTIONS: 00022000
00023000
INPUT FILE: 00024000
SYSIN -- CARDS IN ALP LANGUAGE 00025000
00026000
OUTPUT FILES: 00027000
SYSOUT -- CARD IMAGES FOR BAL ASSEMBLER 00028000
SYSPRINT -- INPUT IMAGES AND MESSAGES 00029000
SYSTERM -- MESSAGE DATA SET 00030000
*/ 00031000
1 00032000
%DECLARE (#TRUE,#FALSE,#DUMMY) CHARACTER; 00033000
%#TRUE='''1''B'; 00034000
%#FALSE='''0''B'; 00035000
%#DUMMY='''0''B'; 00036000
%DECLARE (@OUTER_PREDICATE,@INNER_PREDICATE) CHARACTER; 00037000
%@OUTER_PREDICATE='''1''B'; 00038000
%@INNER_PREDICATE='''0''B'; 00039000
%DECLARE (@USE_NEGATED,@USE_TRUTH) CHARACTER; 00040000
%@USE_NEGATED='''1''B'; 00041000
%@USE_TRUTH='''0''B'; 00042000
%DECLARE (@B,@BR) CHARACTER; 00043000
%@B='''0''B'; 00044000
%@BR='''1''B'; 00045000
00046000
%DECLARE CALLINC CHARACTER; 00047000
%CALLINC = ' DO; ' 00048000
|| ' IF COL>72 THEN CALL INC; ' 00049000
|| ' COL = COL+1; ' 00050000
|| ' IF COL=73 THEN ' 00051000
|| ' CHAR= '' '';' 00052000
|| ' ELSE ' 00053000
|| ' CHAR=SUBSTR(CARDIN,COL,1); ' 00054000
|| ' END '; 00055000
/*RAF-41*/ 00055100
% ALPHANUM: PROCEDURE(CHAR) RETURNS(CHARACTER); /*RAF-41*/ 00055200
DECLARE CHAR CHARACTER; /*RAF-41*/ 00055300
RETURN('(('||CHAR||')>=''A'' | ('||CHAR||')=''$'' | '|| /*RAF-41*/ 00055400
'('||CHAR||')=''#'' | ('||CHAR||')=''@'')'); /*RAF-41*/ 00055500
% END ALPHANUM; /*RAF-41*/ 00055600
% ACTIVATE ALPHANUM; /*RAF-41*/ 00055700
00056000
%GEN: PROCEDURE(OPERATION,OPERANDS) RETURNS(CHARACTER); 00057000
DECLARE (OPERATION,OPERANDS) CHARACTER; 00058000
DECLARE STRING CHARACTER; 00059000
STRING='DO; '; 00060000
IF OPERATION ^= '''''' THEN 00061000
STRING = STRING||'C_OPERATION = '||OPERATION||';'; 00062000
IF OPERANDS ^= '''''' THEN 00063000
STRING = STRING||' GEN_OPERANDS('||OPERANDS||');'; /*RAF-11*/ 00064000
ELSE STRING = STRING||' CALL WFLUSH;'; /*RAF-11*/ 00064500
RETURN(STRING||' END '); /*RAF-11*/ 00065000
%END GEN; 00066000
%ACTIVATE GEN; 00067000
00068000
%GEN_OPERANDS: PROCEDURE(OPERANDS) RETURNS(CHARACTER); /*RAF-11*/ 00069000
DECLARE OPERANDS CHARACTER; /*RAF-11*/ 00070000
RETURN(' DO; ' /*RAF-11*/ 00071000
|| ' OP_SAVE = '||OPERANDS||';' /*RAF-11*/ 00072000
|| ' C_OPERANDS = OP_SAVE;' /*RAF-11*/ 00073000
|| ' DO OP_COUNT=53 TO LENGTH(OP_SAVE) BY 56;' /*RAF-11*/ 00074000
|| ' C_CONTINUE = ''*'';' /*RAF-11*/ 00075000
|| ' CALL WFLUSH;' /*RAF-11*/ 00076000
|| ' C_DATA = '''';' /*RAF-11*/ 00077000
|| ' C_CONT_OPERANDS = SUBSTR(OP_SAVE,OP_COUNT);' /*RAF-11*/ 00078000
|| ' END;' /*RAF-11*/ 00079000
|| ' CALL WFLUSH;' /*RAF-11*/ 00080000
|| ' END'); /*RAF-11*/ 00081000
/*RAF-11*/ 00082000
/*RAF-11*/ 00083000
/*RAF-11*/ 00084000
/*RAF-11*/ 00085000
%END GEN_OPERANDS; 00086000
%ACTIVATE GEN_OPERANDS; 00087000
1 00088000
/* "ALP" "INPUT" INTERFACE */ 00089000
DECLARE 00090000
INAL FIXED BIN INIT(2), 00091000
ENDFLG BIT(1) INIT(#FALSE), ENDMARK CHAR(8) STATIC, 00092000
SYSIN FILE RECORD INPUT, 00093000
CHAR CHAR(1) INIT(' ') , /* ALWAYS CONTAINS THE CHARACTER 00094000
POINTED TO BY THE INPUT POINTER */ 00095000
WORD CHAR(8) VARYING, WORDAL BIT(1), /* SET BY RWORD*/ 00096000
OPANDS CHAR(2000) VARYING, /* SET BY ROPANDS */ /*RAF-44*/ 00097000
CARDIN CHAR(80) UNALIGNED, /* INPUT BUFFER*/ /*RAF-46*/ 00098000
CIN_DATA CHAR(72) POS(1) DEF CARDIN UNALIGNED, /*RAF-46*/ 00099000
CIN_ID CHAR(8) POS(73) DEF CARDIN UNALIGNED, /*RAF-46*/ 00100000
CIN_2COLS CHAR(2) POS(1) DEF CARDIN UNAL, /*RAF-46*/ /*RAF-9*/ 00100500
COL FIXED BIN INIT(80); /* INPUT COLUMN WITHIN CARDIN */ 00101000
00102000
/* "ALP" "OUTPUT" INTERFACE" */ 00103000
DECLARE 00104000
SYSPRINT FILE PRINT ENV(FB,RECSIZE(133)), /*RAF-19*/ 00105000
SYSTERM FILE OUTPUT ENV(FB,RECSIZE(121),BLKSIZE(121)), 00106000
SYSOUT FILE RECORD OUTPUT ENV(FB,RECSIZE(80),TOTAL),/*RAF-19*/ 00107000
CARDOUT CHAR(80) INIT(' ') UNAL, /*OUTPUT BUFFER*/ /*RAF-46*/ 00108000
C_LABEL CHAR(8) POS(1) DEF CARDOUT UNALIGNED, /*RAF-46*/ 00109000
COL_1 CHAR(1) POS(1) DEF CARDOUT UNALIGNED, /*RAF-46*/ 00110000
C_DATA CHAR(72) POS(1) DEF CARDOUT UNALIGNED, /*RAF-46*/ 00111000
COUT_ID CHAR(8) POS(73) DEF CARDOUT UNALIGNED, /*RAF-46*/ 00112000
C_OPERATION CHAR(8) POS(10) DEF CARDOUT UNALIGNED, /*RAF-46*/ 00113000
C_OPERANDS CHAR(52) POS(20) DEF CARDOUT UNALIGNED, /*RAF-46*/ 00114000
C_CONTINUE CHAR(1) POS(72) DEF CARDOUT UNALIGNED, /*RAF-46*/ 00115000
C_CONT_OPERANDS CHAR(56) POS(16) DEF CARDOUT UNAL, /*RAF-46*/ 00116000
OP_COUNT FIXED BIN, /*RAF-11*/ 00116100
OP_SAVE CHAR(2000) VARYING, /*RAF-44*/ /*RAF-11*/ 00116200
GENNUM FIXED DEC(5) INIT(10000) STATIC; 00117000
00118000
DECLARE 00119000
ERRCNT FIXED BIN INIT(0), 00120000
(BRANCH_LAST,IN_MACRO,SUBTITL,LABEL_WRITTEN) BIT(1) INIT(#FALSE), 00121000
NESTLEV FIXED BIN INIT(0),NESTID(75) CHAR(8), 00122000
DOLEV FIXED BIN INIT(0), 00123000
(EXID(75),DOID(75),DOLABEL(75)) CHAR(8) VARYING, 00124000
ASMDOLEV FIXED BIN INIT(0), /*RAF-9*/ 00124100
(ASMEXID(75),ASMDOID(75),ASMDOLABEL(75)) /*RAF-9*/ 00124200
CHAR(8) VARYING, /*RAF-9*/ 00124300
PREDLABLEV FIXED BIN INIT(0), /*RAF-6*/ 00125000
PREDLABSTK(100,2) CHAR(14) VARYING, /*RAF-49*/ /*RAF-6*/ 00125500
PREDBTYPE(50) CHAR(1), /*RAF-6*/ 00126000
SYMLEV FIXED BIN INIT(0),SYMSTK(3000) CHAR(8) VARYING,/*RAF-38*/ 00127000
LABLEV FIXED BIN INIT(0),LABSTK(50) CHAR(8) VARYING,/*RAF-42*/ 00128000
EQVLEV FIXED BIN INIT(0), /*RAF-37*/ 00129000
EQVSTK(100,2) CHAR(10) VARYING; /*RAF-37*/ 00129500
00130000
DECLARE 00131000
DTE CHAR(6),TIM CHAR(9),TIME_STAMP CHAR(20), 00132000
PAGECNT FIXED BIN INIT(0), 00133000
DECKNAME CHAR(8) INIT(' '), 00134000
TITLE CHAR(72) INIT( 00135000
'A L P : A S S E M B L E R P R E P R O C E S S O R .' 00136000
), 00137000
SUBTITLE CHAR(72) INIT(' '); 00138000
0 00139000
/* "ALP" RETURN CODE */ 00140000
DECLARE 00141000
RETCODE FIXED BINARY(31) INIT(0); 00142000
1 00143000
DECLARE 00144000
PREDICATES (18,2) CHAR(8) STATIC INIT( 00145000
'OPENP' , 'NZ' , /* TM */ 00146000
'TM' , 'NZ', /* ANY SELECTED BIT ON */ 00147000
'TS' , 'NZ', 00148000
'TF' , 'NZ', 00149000
'TRT' , 'NZ', 00150000
'RM' , 'M' , /* REGISTER TESTS */ 00151000
'RZ' , 'Z' , 00152000
'RP' , 'P' , 00153000
'RMZ' , 'NP', 00154000
'RMP' , 'NZ', 00155000
'RZP' , 'NM', 00156000
'RNM' , 'NM', 00157000
'RNZ' , 'NZ', 00158000
'RNP' , 'NP', 00159000
'RNMZ' , 'P' , 00160000
'RNMP' , 'Z' , 00161000
'RNZP' , 'M' , 00162000
'***' , 'E'), /* DEFAULT: TRUTH IS EQUAL */ 00163000
00164000
1 CCTAB STATIC, 00165000
2 IVAL(19) INIT((3)0, (5)8, (4)4, (4)2, (3)1), 00166000
2 LET CHAR(19) INIT(' N^ 0=EZ 1LM 2PH 3O'), 00167000
00168000
OPTAB (16) CHAR(10) STATIC INIT( 00169000
'BC 0,', 00170000
'BO', 00171000
'BH', 00172000
'BC 3,', 00173000
'BL', 00174000
'BC 5,', 00175000
'BC 6,', 00176000
'BNE', 00177000
'BE', 00178000
'BC 9,', 00179000
'BC 10,', 00180000
'BNL', 00181000
'BC 12,', 00182000
'BNH', 00183000
'BNO', 00184000
'BC 15,' ); 00185000
1 00186000
ON ENDFILE(SYSIN) GO TO MAIN_END ; 00187000
00188000
OPEN FILE(SYSPRINT) LINESIZE(132); /*RAF-19*/ 00188500
ON ENDPAGE(SYSPRINT) 00189000
BEGIN; 00190000
PAGECNT = PAGECNT+1; 00191000
PUT PAGE FILE(SYSPRINT) 00192000
EDIT(DECKNAME,TITLE,TIME_STAMP,'PAGE ',PAGECNT,SUBTITLE) 00193000
(A(8),A(72),X(9),A(20),X(3),A(5),P'ZZ9',SKIP,X(8),A(72)); 00194000
PUT SKIP(2) FILE(SYSPRINT); 00195000
SUBTITL = #FALSE; 00196000
END; 00197000
00198000
OPEN FILE(SYSTERM); PUT SKIP FILE(SYSTERM); CLOSE FILE(SYSTERM); 00199000
OPEN FILE(SYSOUT); /*RAF-19*/ 00200000
00201000
DTE = DATE() ; TIM = TIME() ; 00202000
TIME_STAMP = SUBSTR(DTE,3,2)||'/'|| 00203000
SUBSTR(DTE,5,2)||'/'|| 00204000
SUBSTR(DTE,1,2)||' '|| 00205000
SUBSTR(TIM,1,2)||':'|| 00206000
SUBSTR(TIM,3,2)||':'|| 00207000
SUBSTR(TIM,5,2) ; 00208000
00209000
PUT SKIP FILE(SYSTERM) EDIT('*ALP*',TIME_STAMP) (A,X(2),A); 00210000
SIGNAL ENDPAGE(SYSPRINT); 00211000
1 00212000
MAIN_LOOP: 00213000
DO WHILE(#TRUE); /* MAIN PROGRAM LOOP*/ 00214000
CALL STMNT ; 00215000
IF ^RCHAR(';') THEN 00216000
CALL ERROR ('MA10: MISSING SEMICOLON INSERTED.') ; 00217000
CALL EQVFLUSH(#FALSE,1); 00218000
END MAIN_LOOP ; 00219000
00220000
MAIN_END : 00221000
CALL EQVFLUSH(#TRUE,1); 00222000
IF ^ENDFLG THEN 00223000
CALL ERROR('MAIN: MISSING "END" AT END OF PROGRAM.'); 00224000
WORD = 'END'; 00225000
COL = 1; 00226000
SUBSTR(CARDIN,1,1),CHAR = ';'; 00227000
CALL ALCSTMT; 00228000
IF NESTLEV^=0 THEN 00229000
DO; 00230000
CALL OUTPUT(' '); 00231000
CALL OUTPUT('MISSING "END"/">" FOR "BEGIN"/"<" AT:'); 00232000
DO NESTLEV = NESTLEV TO 1 BY -1; 00233000
CALL OUTPUT(NESTID(NESTLEV)); 00234000
END; 00235000
RETCODE=8; 00236000
END; 00237000
CALL OUTPUT(' '); 00238000
IF ERRCNT = 0 THEN 00239000
CALL OUTPUT('NO ALP STATEMENTS FLAGGED.'); 00240000
ELSE 00241000
IF ERRCNT = 1 THEN 00242000
CALL OUTPUT('1 ALP STATEMENT FLAGGED.'); 00243000
ELSE 00244000
CALL OUTPUT(ERRCNT||' ALP STATEMENTS FLAGGED.'); 00245000
CALL OUTPUT(' '); 00246000
CLOSE FILE(SYSTERM),FILE(SYSPRINT),FILE(SYSOUT),FILE(SYSIN); 00247000
CALL PLIRETC(RETCODE); 00248000
RETURN ; 00249000
1 00250000
STMNT: /* PROCESS ONE STATEMENT (SIMPLE OR COMPOUND) */ 00251000
PROCEDURE RECURSIVE ; 00252000
DCL 00253000
SAVID CHAR(8); 00254000
00255000
ST: 00256000
CALL RLABEL ; 00257000
IF ENDFLG THEN 00258000
DO; 00259000
CALL ERROR('ST10: EXTRANEOUS OR LABELED "END" AT ' 00260000
||ENDMARK||' IGNORED.'); 00261000
ENDFLG = #FALSE; 00262000
END; 00263000
IF WORD = ';' THEN 00264000
RETURN; 00265000
SAVID = CIN_ID; 00266000
IF ^WORDAL THEN 00267000
IF WORD = '<' THEN 00268000
DO; 00269000
CALL GROUP(#FALSE,SAVID); 00270000
RETURN; 00271000
END; 00272000
ELSE 00273000
DO; 00274000
CALL ERROR('ST15: "'||WORD||'" OUT OF CONTEXT, IGNORED.');00275000
GO TO ST; 00276000
END; 00277000
00278000
/* WORD IS A SYMBOL */ 00279000
IF WORD = 'BEGIN' THEN 00280000
DO; 00281000
CALL GROUP(#TRUE,SAVID); 00282000
RETURN; 00283000
END; 00284000
ELSE 00285000
IF RCHAR(':') THEN 00286000
DO; 00287000
CALL WLABEL(WORD); 00288000
GO TO ST; 00289000
END; 00290000
1 00291000
/* IDENTIFY ALP INSTRUCTIONS */ 00292000
IF WORD = 'IF' THEN 00293000
CALL CIF ; 00294000
ELSE 00295000
IF WORD = 'CASE' THEN 00296000
CALL CCASE ; 00297000
ELSE 00298000
IF WORD = 'WHILE' THEN 00299000
CALL CWHILE(#FALSE) ; 00300000
ELSE 00301000
IF WORD = 'UNTIL' THEN 00302000
CALL CWHILE(#TRUE); 00303000
ELSE 00304000
IF WORD = 'DO' THEN 00305000
CALL CDO; 00306000
ELSE 00307000
IF WORD = 'FOR' THEN 00308000
CALL CFOR; 00309000
ELSE 00310000
IF WORD = 'FOREVER' THEN 00311000
CALL CFOREVER; 00312000
ELSE 00313000
IF WORD = 'GOTO' THEN 00314000
CALL CGOTO(#FALSE); 00315000
ELSE 00316000
IF WORD = 'RGOTO' THEN 00317000
CALL CGOTO(#TRUE); 00318000
ELSE 00319000
IF WORD = 'EXIT' THEN 00320000
CALL CEXIT; 00321000
ELSE 00322000
IF WORD = 'USE' THEN 00323000
CALL CUSE; 00324000
ELSE 00325000
IF WORD = 'BAL' THEN 00326000
DO; 00327000
IF RCHAR(';') THEN 00328000
CALL CBAL; 00329000
ELSE 00330000
CALL ALCSTMT; 00331000
END; 00332000
ELSE IF WORD = 'COMMENT' THEN /*RAF-10*/ 00332100
DO; /*RAF-10*/ 00332200
IF RCHAR(';') THEN /*RAF-10*/ 00332300
CALL CCOMMENT; /*RAF-10*/ 00332400
ELSE /*RAF-10*/ 00332500
CALL ALCSTMT; /*RAF-10*/ 00332600
END; /*RAF-10*/ 00332700
ELSE IF WORD='DATA' THEN /*RAF-36*/ 00332800
CALL CDATA; /*RAF-36*/ 00332900
ELSE 00333000
IF WORD = 'END' THEN 00334000
CALL CEND(SAVID); 00335000
ELSE 00336000
IF WORD = 'NEXT' THEN 00337000
CALL CNEXT; 00338000
ELSE 00339000
IF WORD='ASM' THEN /*RAF-9*/ 00339100
CALL CASM; /*RAF-9*/ 00339200
ELSE /*RAF-9*/ 00339300
IF WORD = 'ASMIF' THEN 00340000
CALL CASMIF; 00341000
ELSE 00342000
IF WORD = 'MACRO' THEN 00343000
CALL CMACRO; 00344000
ELSE 00345000
IF WORD = 'SELECT' THEN 00346000
CALL CSELECT; 00347000
1 00348000
ELSE 00349000
IF WORD='THEN' 00350000
| WORD='ELSE' 00351000
| WORD='MEND' /*RAF-8*/ 00352000
| WORD='ENDMACRO' /*RAF-8*/ 00352500
| WORD='ENDSEL' 00353000
| WORD='ENDCASE' THEN 00354000
DO; 00355000
CALL ERROR('ST25: INVALID "'||WORD||'" IGNORED.');00356000
GOTO ST; 00357000
END; 00358000
ELSE 00359000
CALL ALCSTMT; 00360000
RETURN ; 00361000
END STMNT ; 00362000
- 00363000
/* PROCESS STATEMENT "GROUP" */ 00364000
GROUP: 00365000
PROCEDURE(BEGTYPE,CARDID) RECURSIVE ; 00366000
DECLARE 00367000
BEGTYPE BIT(1), 00368000
CARDID CHAR(8); 00369000
00370000
NESTLEV=NESTLEV+1; 00371000
NESTID(NESTLEV)=CARDID; 00372000
GRLOOP: 00373000
DO WHILE(#TRUE) ; 00374000
IF ^BEGTYPE THEN DO; /*RAF-7*/ 00375000
IF RCHAR('>') THEN GO TO GROUT; /*RAF-7*/ 00375500
END; /*RAF-7*/ 00376000
ELSE IF RCHECK('END') THEN GO TO GROUT; /*RAF-7*/ 00376500
CALL STMNT ; 00377000
IF ENDFLG THEN /*RAF-7*/ 00377100
DO; /*RAF-7*/ 00377200
CALL ERROR('GR11: EXTRANEOUS OR LABELED "END"' /*RAF-7*/ 00377300
||' AT '||ENDMARK||' IGNORED.'); /*RAF-7*/ 00377400
ENDFLG = #FALSE; /*RAF-7*/ 00377500
END; /*RAF-7*/ 00377600
IF ^BEGTYPE THEN DO; /*RAF-7*/ 00378000
IF RCHAR('>') THEN GO TO GROUT; /*RAF-7*/ 00378500
END; /*RAF-7*/ 00379000
ELSE IF RCHECK('END') THEN GO TO GROUT; /*RAF-7*/ 00379500
IF ^RCHAR (';') THEN 00380000
CALL ERROR('GR10: MISSING SEMICOLON INSERTED.'); 00381000
END GRLOOP; 00382000
GROUT: 00383000
NESTLEV=NESTLEV-1; 00384000
IF NESTLEV=0 THEN PREDLABLEV=0; /*RAF-6*/ 00384500
RETURN; 00385000
END GROUP ; 00386000
1 00387000
/* END */ 00388000
00389000
CEND: 00390000
PROCEDURE(ENDID); 00391000
DCL 00392000
ENDID CHAR(8); 00393000
00394000
ENDFLG = #TRUE; 00395000
ENDMARK = ENDID; 00396000
RETURN; 00397000
END CEND; 00398000
1 00399000
/* IF <PREDICATE> THEN <STATEMENT> | 00400000
IF <PREDICATE> THEN <STATEMENT> ELSE <STATEMENT> */ 00401000
00402000
CIF: 00403000
PROCEDURE RECURSIVE ; 00404000
DECLARE 00405000
(THENPART,ELSEPART,SKIPLABEL) CHAR(8) VARYING; 00406000
00407000
THENPART = ''; 00408000
ELSEPART = GENSYM; 00409000
CALL PREDICATE(THENPART,ELSEPART,@OUTER_PREDICATE, 00410000
#DUMMY,@USE_TRUTH,#DUMMY,@B); 00411000
IF ^RCHECK('THEN') THEN 00412000
CALL ERROR('CIF: "THEN" INSERTED AFTER "'||WORD||'".'); 00413000
CALL STMNT; /* THEN CLAUSE */ 00414000
IF RCHECK('ELSE') THEN 00415000
DO ; /* ELSE CLAUSE */ 00416000
SKIPLABEL = GENSYM; 00417000
GEN('B',SKIPLABEL); 00418000
CALL WLABEL(ELSEPART) ; 00419000
CALL STMNT; /* ELSE CLAUSE */ 00420000
CALL WLABEL(SKIPLABEL) ; 00421000
END; 00422000
ELSE /* NO ELSE CLAUSE */ 00423000
CALL WLABEL(ELSEPART); 00424000
RETURN; 00425000
END CIF ; 00426000
1 00427000
/* CASE <REGISTER> MAX <MAXVAL>; 00428000
<CASE LIST> 00429000
ENDCASE */ 00430000
00431000
CCASE: 00432000
PROCEDURE RECURSIVE; 00433000
DECLARE 00434000
(REGID,CLABELB,CLABELI,CLABELE,TLABEL) CHAR(8) VARYING, 00435000
ELSEPART CHAR(8) VARYING INIT(''), /*RAF-32*/ 00435100
MINCASE CHAR(80) VARYING INIT('(0)'), /*RAF-32*/ 00435200
MAXCASE CHAR(80) VARYING INIT(''), /*RAF-32*/ 00435300
(CLOW,CHIGH) CHAR(80) VARYING, /*RAF-32*/ 00436000
(EMSG1 CHAR(72) INIT( /*RAF-32*/ 00437000
'* ERROR IF CASE RANGE NOT A MULTIPLE OF FOUR:'), /*RAF-32*/ 00438000
EMSG2 CHAR(72) INIT( /*RAF-32*/ 00439000
'* ERROR IF ORDER OF "THRU" CASES IS INVALID:'), 00440000
EMSG3 CHAR(72) INIT('* ERROR IF CASE OUT OF RANGE:'), /*RAF-32*/ 00441000
EMSG4 CHAR(72) INIT('* ERROR IF CASE NOT A MULTIPLE OF FOUR:'), 00442000
EMSG5 CHAR(72) INIT( /*RAF-32*/ 00442100
'* ERROR IF CASE RANGE NOT GREATER THAN ZERO:') /*RAF-32*/ 00442200
) STATIC; 00443000
00444000
CALL ROPANDS(#TRUE); /*RAF-32*/ 00445000
IF OPANDS='' THEN /*RAF-32*/ 00446000
DO; 00447000
CALL ERROR('CCASE: NO REGISTER ID FOR CASE STATEMENT.'); 00448000
OPANDS='0'; /*RAF-32*/ /*RAF-8*/ 00449000
END; 00450000
REGID = OPANDS; /*RAF-32*/ 00451000
/* IF ^RCHECK('MAX') THEN */ /*RAF-32*/ /* 00452000
CALL ERROR('CCASE: "MAX" INSERTED AFTER "'||REGID||'".'); 00453000
CALL RWORD; 00454000
IF ^WORDAL THEN 00455000
DO; 00456000
CALL ERROR('CCASE: MISSING MAXIMUM CASE INDICATION.'); 00457000
RETURN; 00458000
END; */ /*RAF-32*/ 00459000
DO WHILE('1'B); /*RAF-32*/ 00459020
IF RCHECK('MAX') THEN DO; /*RAF-32*/ 00459040
CALL ROPANDS(#TRUE); /*RAF-32*/ 00459060
MAXCASE='('||OPANDS||')'; /*RAF-32*/ 00459080
END; /*RAF-32*/ 00459100
ELSE IF RCHECK('MIN') THEN DO; /*RAF-32*/ 00459120
CALL ROPANDS(#TRUE); /*RAF-32*/ 00459140
MINCASE='('||OPANDS||')'; /*RAF-32*/ 00459160
END; /*RAF-32*/ 00459180
ELSE IF RCHECK('CHECK') THEN DO; /*RAF-32*/ 00459200
ELSEPART=GENSYM; /*RAF-32*/ 00459220
END; /*RAF-32*/ 00459240
ELSE DO; /*RAF-32*/ 00459260
IF ^RCHAR(';') THEN /*RAF-32*/ 00459280
CALL ERROR('CCASE: MISSING SEMICOLON INSERTED'); /*RAF-32*/ 00459300
GO TO CASEBODY; /*RAF-32*/ 00459320
END; /*RAF-32*/ 00459340
END; /*RAF-32*/ 00459360
CASEBODY: /*RAF-32*/ 00459380
IF MAXCASE='' THEN DO; /*RAF-32*/ 00459400
CALL ERROR('CCASE: MAX MUST BE SPECIFIED'); /*RAF-32*/ 00459420
MAXCASE=MINCASE; /*RAF-32*/ 00459440
END; /*RAF-32*/ 00459460
CLABELE = ''; /*RAF-32*/ 00460000
DOLEV = DOLEV+1; 00461000
EXID(DOLEV) = ''; /*RAF-8*/ 00462000
DOID(DOLEV) = GENSYM; /*RAF-15*/ 00463000
DOLABEL(DOLEV) = CURLAB; 00464000
/* MAXCASE = WORD; */ /*RAF-32*/ /* 00465000
DO WHILE(^RCHAR(';')); 00466000
CALL RWORD; 00467000
MAXCASE = MAXCASE||WORD; 00468000
END; 00469000
MAXCASE='('||MAXCASE||')'; */ /*RAF-32*/ 00470000
CLABELB = GENSYM; 00471000
CALL WLABEL(DOID(DOLEV)); /*RAF-15*/ 00471500
IF ELSEPART^='' THEN DO; /*RAF-32*/ 00471520
GEN('C',REGID||',=A'||MAXCASE); /*RAF-32*/ 00471540
GEN('BH',ELSEPART); /*RAF-32*/ 00471560
IF MINCASE='(0)' THEN DO; /*RAF-32*/ 00471580
GEN('LTR',REGID||','||REGID); /*RAF-32*/ 00471600
GEN('BM',ELSEPART); /*RAF-32*/ 00471620
END; /*RAF-32*/ 00471640
ELSE DO; /*RAF-32*/ 00471660
GEN('C',REGID||',=A'||MINCASE); /*RAF-32*/ 00471680
GEN('BL',ELSEPART); /*RAF-32*/ 00471700
END; /*RAF-32*/ 00471720
END; /*RAF-32*/ 00471740
GEN('B',CLABELB||'-'||MINCASE||'('||REGID||')'); /*RAF-32*/ 00472000
C_DATA=EMSG1; 00473000
CALL WFLUSH; 00474000
GEN('DS','0CL(1+('||MAXCASE||'-'||MINCASE||')/4*4-'|| /*RAF-32*/ 00475000
MAXCASE||'+'||MINCASE||')'); /*RAF-32*/ 00475100
C_DATA=EMSG5; /*RAF-32*/ 00475200
CALL WFLUSH; /*RAF-32*/ 00475300
GEN('DS','0CL('||MAXCASE||'-'||MINCASE||')'); /*RAF-32*/ 00475400
CALL WLABEL(CLABELB); 00476000
IF ELSEPART='' THEN DO; /*RAF-32*/ 00476500
GEN('DC','(('||MAXCASE||'-'||MINCASE||')/4+1)'|| /*RAF-32*/ 00477000
'H''0,0'''); /*RAF-32*/ 00477100
END; /*RAF-32*/ 00477200
ELSE DO; /*RAF-32*/ 00477300
GEN('DC','(('||MAXCASE||'-'||MINCASE||')/4+1)'|| /*RAF-32*/ 00477400
'S(X''7F0''(4),'||ELSEPART||')'); /*RAF-32*/ 00477500
END; /*RAF-32*/ 00477600
1 00478000
NESTLEV = NESTLEV+1; 00479000
NESTID(NESTLEV) = CIN_ID; 00480000
/* CALL RWORD; */ /*RAF-32*/ 00481000
DO WHILE(^RCHECK('ENDCASE')); /*RAF-32*/ 00482000
IF CLABELE='' /*RAF-32*/ 00482100
THEN CLABELE=GENSYM; /*RAF-32*/ 00482200
ELSE GEN('B',CLABELE); /*RAF-32*/ 00482300
TLABEL = GENSYM; 00483000
CLABELI = GENSYM; 00484000
CALL WLABEL(TLABEL); 00485000
GEN('DS','0H'); 00486000
DO WHILE('1'B); /*RAF-32*/ 00487000
/* CLOW,CHIGH = ''; */ /*RAF-32*/ /* 00488000
DO WHILE(WORD^='THRU' & WORD^=',' & WORD^=':' & WORD^=';'); 00489000
CLOW = CLOW||WORD; 00490000
CALL RWORD; 00491000
END; 00492000
CLOW='('||CLOW||')'; */ /*RAF-32*/ 00493000
CALL ROPANDS(#TRUE); /*RAF-32*/ 00493100
CLOW='('||OPANDS||')'; /*RAF-32*/ 00493200
CHIGH=''; /*RAF-32*/ 00493300
IF RCHECK('THRU') THEN /*RAF-32*/ 00494000
DO ; 00495000
/* CALL RWORD ; */ /*RAF-32*/ /* 00496000
DO 00497000
WHILE(WORD ^= ',' & WORD ^= ':' & WORD ^= ';'); 00498000
CHIGH = CHIGH||WORD; 00499000
CALL RWORD ; 00500000
END; */ /*RAF-32*/ 00501000
CALL ROPANDS(#TRUE); /*RAF-32*/ 00501100
CHIGH='('||OPANDS||')'; /*RAF-32*/ 00501200
END ; 00502000
/* IF CHIGH^='' THEN */ /*RAF-32*/ 00503000
/* CHIGH='('||CHIGH||')'; */ /*RAF-32*/ 00504000
IF RCHAR(';') THEN /*RAF-32*/ 00505000
DO; 00506000
CALL ERROR('CCASE: '|| 00507000
'MISSING CASE LABEL, CASE IGNORED.'); 00508000
GO TO NOCASE; /*RAF-32*/ 00509000
END; 00510000
1 00511000
ELSE 00512000
DO; 00513000
C_DATA=EMSG3; 00514000
CALL WFLUSH; 00515000
GEN('DS','0CL(1+'||MAXCASE||'-'||CLOW||'),' /*RAF-5*/ 00516000
||'0CL(1+'||CLOW||'-'||MINCASE||')'); /*RAF-32,RAF-5*/ 00516100
C_DATA=EMSG4; 00517000
CALL WFLUSH; 00518000
GEN('DS','0CL(1+('||CLOW||'-'||MINCASE|| /*RAF-32*/ 00519000
')/4*4-'||CLOW||'+'||MINCASE||')'); /*RAF-32*/ 00519100
IF CHIGH^='' THEN 00520000
DO; 00521000
C_DATA=EMSG2; 00522000
CALL WFLUSH; 00523000
GEN('DS','0CL(1+'||CHIGH||'-'||CLOW||')'); 00524000
C_DATA=EMSG3; 00525000
CALL WFLUSH; 00526000
GEN('DS','0CL(1+'||MAXCASE||'-'||CHIGH||')'); 00527000
C_DATA=EMSG4; 00528000
CALL WFLUSH; 00529000
GEN('DS','0CL(1+('||CHIGH||'-'||MINCASE /*RAF-32*/ 00530000
||')/4*4-'||CHIGH||'+'||MINCASE||')'); /*RAF-32*/ 00530100
END; 00531000
GEN('ORG',CLABELB||'+'||CLOW||'-'||MINCASE); /*RAF-32*/ 00532000
IF CHIGH = '' THEN 00533000
DO; 00534000
C_OPERATION = 'B'; 00535000
C_OPERANDS = CLABELI; 00536000
END; 00537000
ELSE 00538000
DO; 00539000
C_OPERATION = 'DC'; 00540000
C_OPERANDS = '(('||CHIGH||'-'||CLOW|| 00541000
')/4+1)S(X''7F0''(4),'||CLABELI||')'; 00542000
END; 00543000
CALL WFLUSH; 00544000
IF ^RCHAR(',') THEN /*RAF-32*/ 00545000
GO TO END_CASE_LIST; /*RAF-32*/ 00546000
END; 00547000
END; 00548000
END_CASE_LIST: /*RAF-32*/ 00548500
IF ^RCHAR(':') THEN /*RAF-32*/ 00548600
CALL ERROR('CCASE: MISSING COLON INSERTED'); /*RAF-32*/ 00548700
GEN('ORG',TLABEL); 00549000
IF ^RCHAR(';') THEN 00550000
DO; 00551000
CALL WLABEL(CLABELI); 00552000
BRANCH_LAST=#TRUE; /*RAF-32*/ 00552500
CALL STMNT; 00553000
IF ^RCHAR(';') THEN 00554000
CALL ERROR('CA10: MISSING SEMICOLON INSERTED.') ; 00555000
/* CALL RWORD; */ /*RAF-32*/ 00556000
/* IF WORD ^= 'ENDCASE' THEN */ /*RAF-32*/ 00557000
/* GEN('B',CLABELE); */ /*RAF-32*/ 00558000
END; 00559000
ELSE 00560000
DO; 00561000
CALL EQVADD((CLABELI),(CLABELE)); 00562000
/* CALL RWORD; */ /*RAF-32*/ 00563000
END; 00564000
NOCASE: /*RAF-32*/ 00564500
END ; 00565000
1 00566000
NESTLEV = NESTLEV-1; /*RAF-34*/ 00566020
00566030
IF ELSEPART='' THEN DO; /*RAF-32*/ 00566050
IF RCHECK('ELSE') THEN DO; /*RAF-32*/ 00566100
CALL ERROR('CCASE: CHECK REQUIRED WITH ELSE'); /*RAF-32*/ 00566150
CALL STMNT; /*RAF-32*/ 00566200
END; /*RAF-32*/ 00566250
END; /*RAF-32*/ 00566300
ELSE DO; /*RAF-32*/ 00566350
GEN('B',CLABELE); /*RAF-32*/ 00566400
CALL WLABEL(ELSEPART); /*RAF-32*/ 00566450
IF RCHECK('ELSE') /*RAF-32*/ 00566500
THEN CALL STMNT; /*RAF-32*/ 00566550
ELSE GEN('DC','H''0'''); /*RAF-32*/ 00566600
END; /*RAF-32*/ 00566650
/*RAF-32*/ 00566700
/* IF DOID(DOLEV)^='' THEN */ /*RAF-15*/ 00567000
/* CALL EQVADD((DOID(DOLEV)),(CLABELB||'-4')); */ /*RAF-15*/ 00568000
CALL WLABEL(CLABELE); 00569000
TLABEL = EXID(DOLEV); /*RAF-8*/ 00569500
DOLEV = DOLEV-1; 00570000
/* NESTLEV = NESTLEV-1; */ /*RAF-34*/ 00571000
IF NESTLEV=0 THEN PREDLABLEV=0; /*RAF-6*/ 00571500
IF RCHECK('THEN') THEN CALL STMNT; /*RAF-8*/ 00571600
CALL CWLABEL(TLABEL); /*RAF-9*/ 00571700
RETURN; 00572000
END CCASE; 00573000
1 00574000
/* WHILE <PRED> DO <STMNT> | UNTIL <PRED> DO <STMNT> */ 00575000
00576000
CWHILE: 00577000
PROCEDURE(UWB) RECURSIVE ; 00578000
DCL 00579000
UWB BIT(1), /* #FALSE => WHILE */ 00580000
(TOP,BODY,FAILURE,DO_LABEL,THENPART) CHAR(8) VARYING; 00581000
00582000
DO_LABEL = CURLAB; 00583000
CALL SWLABEL(TOP); 00584000
FAILURE = GENSYM; 00585000
BODY = ''; 00586000
CALL PREDICATE(BODY,FAILURE,@OUTER_PREDICATE,#DUMMY,UWB,#DUMMY, 00587000
@B); 00588000
IF ^RCHECK('DO') THEN 00589000
CALL ERROR('CWHILE/UNTIL: "DO" INSERTED AFTER "'||WORD||'".'); 00590000
DOLEV = DOLEV+1; 00591000
EXID(DOLEV) = ''; 00592000
DOLABEL(DOLEV) = DO_LABEL; 00593000
DOID(DOLEV) = TOP; 00594000
CALL STMNT; 00595000
GEN('B',TOP); 00596000
CALL WLABEL(FAILURE); 00597000
THENPART = EXID(DOLEV); 00598000
DOLEV = DOLEV-1; 00599000
IF RCHECK('THEN') THEN 00600000
CALL STMNT; 00601000
CALL CWLABEL(THENPART); 00602000
RETURN; 00603000
END CWHILE ; 00604000
1 00605000
/* DO <STMNT> UNTIL/WHILE <PRED> | FOR <REGISTER> | FOREVER */ 00606000
00607000
CDO: 00608000
PROCEDURE RECURSIVE; 00609000
DCL 00610000
FEVER BIT(1) INIT(#FALSE), 00611000
ELEV FIXED BIN, /*RAF-37*/ 00611500
(BODY,PREDFAIL,THENPART) CHAR(8) VARYING, /*RAF-13*/ /*RAF-8*/ 00612000
REG CHAR(64) VARYING; /*RAF-13*/ 00612500
00613000
CALL SWLABEL(BODY); 00614000
PREDFAIL = ''; 00615000
DOLEV = DOLEV+1; 00616000
EXID(DOLEV),DOID(DOLEV) = ''; 00617000
DOLABEL(DOLEV) = CURLAB; 00618000
CALL STMNT; 00619000
IF RCHECK('UNTIL') THEN 00620000
DO; 00621000
CALL CWLABEL(DOID(DOLEV)); 00622000
CALL PREDICATE(PREDFAIL,BODY,@OUTER_PREDICATE,#DUMMY, 00623000
@USE_TRUTH,#DUMMY,@B); 00624000
END; 00625000
ELSE 00626000
IF RCHECK('WHILE') THEN 00627000
DO; 00628000
CALL CWLABEL(DOID(DOLEV)); 00629000
CALL PREDICATE(PREDFAIL,BODY,@OUTER_PREDICATE,#DUMMY, 00630000
@USE_NEGATED,#DUMMY,@B); 00631000
END; 00632000
ELSE 00633000
IF RCHECK('FOR') THEN 00634000
DO; 00635000
CALL CWLABEL(DOID(DOLEV)); 00636000
CALL ROPANDS(#TRUE); /*RAF-13*/ 00637000
IF OPANDS^='' THEN /*RAF-13*/ 00638000
REG=OPANDS; /*RAF-13*/ 00639000
ELSE 00640000
DO; 00641000
REG='0'; 00642000
CALL ERROR('CDO: MISSING "FOR" REGISTER.'); 00643000
END; 00644000
GEN('BCT',REG||','||BODY); 00645000
END; 00646000
ELSE 00647000
IF RCHECK('FOREVER') THEN 00648000
DO; 00649000
FEVER = #TRUE; 00650000
CALL CWLABEL(DOID(DOLEV)); 00651000
GEN('B',BODY); 00652000
END; 00653000
ELSE 00654000
IF DOID(DOLEV) ^= '' THEN DO; /*RAF-37*/ 00655000
ELEV = EQVLEV+1; /*RAF-37*/ 00655500
CALL EQVADD((DOID(DOLEV)),(BODY)); 00656000
CALL EQVFLUSH(#FALSE,ELEV); /*RAF-37*/ 00656100
END; /*RAF-37*/ 00656200
1 00657000
THENPART = EXID(DOLEV); /*RAF-8*/ 00657100
DOLEV = DOLEV-1; /*RAF-8*/ 00657200
IF RCHECK('THEN') THEN 00658000
DO; 00659000
IF FEVER THEN 00660000
CALL ERROR('CDO: INAPPROPRIATE "THEN" IGNORED.'); 00661000
CALL STMNT; 00662000
END; 00663000
CALL CWLABEL(THENPART); /*RAF-8*/ 00664000
/* DOLEV = DOLEV-1; */ /*RAF-8*/ 00665000
RETURN; 00666000
END CDO; 00667000
1 00668000
/* UTILITY PROCEDURE FOR LOOP CONSTRUCTS */ 00669000
CURLAB: PROCEDURE RETURNS(CHAR(8) VARYING); 00670000
DCL CLABEL CHAR(8) VARYING, 00671000
I FIXED BIN; 00672000
00673000
IF C_LABEL = ' ' 00674000
| ((SUBSTR(C_LABEL,1,1)<'A' | SUBSTR(C_LABEL,1,1)>'Z') /*RAF-30*/ 00675000
& SUBSTR(C_LABEL,1,1)^='&') THEN /*RAF-30*/ 00676000
DO; 00677000
DO I=LABLEV TO 1 BY -1 00678000
WHILE(SUBSTR(LABSTK(I),1,1)<'A' 00679000
| SUBSTR(LABSTK(I),1,1)>'Z'); 00680000
END; 00681000
IF I>0 THEN 00682000
CLABEL = LABSTK(I); 00683000
ELSE 00684000
CLABEL = ''; 00685000
END; 00686000
ELSE 00687000
CLABEL = C_LABEL; 00688000
RETURN(CLABEL); 00689000
END CURLAB; 00690000
1 00691000
/* FOR <REGISTER> DO <STATEMENT> */ 00692000
00693000
CFOR: 00694000
PROCEDURE RECURSIVE; 00695000
DCL 00696000
(GEN1,GEN2,GEN3) CHAR(8) VARYING, /*RAF-13*/ 00697000
REG CHAR(64) VARYING; /*RAF-13*/ 00697500
00698000
GEN3 = CURLAB; 00699000
GEN1 = GENSYM; 00700000
GEN2 = GENSYM; 00701000
DOLEV = DOLEV+1; 00702000
EXID(DOLEV),DOID(DOLEV) = ''; 00703000
DOLABEL(DOLEV) = GEN3; 00704000
CALL ROPANDS(#TRUE); /*RAF-13*/ 00705000
IF OPANDS^='' THEN /*RAF-13*/ 00706000
REG = OPANDS; /*RAF-13*/ 00707000
ELSE 00708000
DO; 00709000
REG = '0'; 00710000
CALL ERROR('CFOR: MISSING "FOR" REGISTER.'); 00711000
END; 00712000
GEN('LTR',REG||','||REG); 00713000
GEN('BNP',GEN2); 00714000
CALL WLABEL(GEN1); 00715000
IF ^RCHECK('DO') THEN 00716000
CALL ERROR('CFOR: "DO" INSERTED AFTER "'||REG||'".'); 00717000
CALL STMNT; 00718000
CALL CWLABEL(DOID(DOLEV)); 00719000
GEN('BCT',REG||','||GEN1); 00720000
CALL WLABEL(GEN2); 00721000
GEN3 = EXID(DOLEV); 00722000
DOLEV = DOLEV-1; 00723000
IF RCHECK('THEN') THEN 00724000
CALL STMNT; 00725000
CALL CWLABEL(GEN3); 00726000
RETURN; 00727000
END CFOR; 00728000
1 00729000
/* FOREVER DO <STATEMENT> */ 00730000
00731000
CFOREVER: 00732000
PROCEDURE RECURSIVE ; 00733000
DCL 00734000
(GEN1,GEN2) CHAR(8) VARYING; 00735000
00736000
GEN1 = CURLAB; 00737000
CALL SWLABEL(GEN2) ; 00738000
DOLEV = DOLEV+1; 00739000
EXID(DOLEV),DOID(DOLEV) = ''; 00740000
DOLABEL(DOLEV) = GEN1; 00741000
IF ^RCHECK('DO') THEN 00742000
CALL ERROR('CFOREVER: "DO" ASSUMED AFTER "FOREVER".'); 00743000
CALL STMNT ; 00744000
CALL CWLABEL(DOID(DOLEV)); 00745000
GEN('B',GEN2); 00746000
CALL CWLABEL(EXID(DOLEV)); 00747000
DOLEV = DOLEV-1; 00748000
IF RCHECK('THEN') THEN 00749000
CALL ERROR('CFOREVER: INAPPROPRIATE "THEN" IGNORED.'); 00750000
RETURN; 00751000
END CFOREVER ; 00752000
1 00753000
/* GOTO <LABEL> | GOTO <LABEL> IF <PREDICATE> */ 00754000
/* RGOTO <LABEL> | RGOTO <LABEL> IF <PREDICATE> */ 00755000
00756000
CGOTO: 00757000
PROCEDURE(RTYPE) RECURSIVE; 00758000
DCL 00759000
RTYPE BIT(1); 00760000
DCL 00761000
IFF BIT(1), /* FOR RCHECK */ 00762000
TARGET CHAR(25) VARYING, 00763000
FAIL CHAR(8) VARYING; 00764000
00765000
CALL ROPANDS(#FALSE); /*RAF-39*/ /*RAF-9*/ 00766000
TARGET = OPANDS; 00767000
FAIL = ''; 00768000
IF RCHECK('IF') THEN 00769000
IF CHAR = ';' | CHAR = '>' THEN 00770000
CALL ERROR('CGOTO: EXTRANEOUS "IF" IGNORED.'); 00771000
ELSE 00772000
CALL PREDICATE(FAIL,TARGET,@OUTER_PREDICATE,#DUMMY, 00773000
@USE_NEGATED,#DUMMY,RTYPE); 00774000
ELSE 00775000
DO; 00776000
IF RTYPE THEN 00777000
C_OPERATION = 'BR'; 00778000
ELSE 00779000
C_OPERATION = 'B'; 00780000
GEN('',OPANDS); 00781000
END; 00782000
RETURN; 00783000
END CGOTO; 00784000
1 00785000
/* EXIT FROM <BLOCK LABEL> IF <PREDICATE> */ 00786000
00787000
CEXIT: PROCEDURE RECURSIVE; 00788000
DCL 00789000
I FIXED BIN, 00790000
(EXLABEL,FAIL) CHAR(8) VARYING; 00791000
00792000
IF DOLEV > 0 THEN 00793000
DO; 00794000
EXLABEL,FAIL = ''; I = 0; 00795000
IF RCHECK('FROM') THEN 00796000
IF CHAR = ';' | CHAR = '>' THEN 00797000
CALL ERROR('CEXIT: EXTRANEOUS "FROM" IGNORED.'); 00798000
ELSE 00799000
DO; 00800000
CALL RLABEL; /*RAF-16*/ 00801000
IF WORD^='' THEN /*RAF-16*/ 00802000
DO; 00803000
DO I=1 TO DOLEV WHILE(DOLABEL(I)^=WORD); 00804000
END; 00805000
IF I>DOLEV THEN 00806000
DO; 00807000
I = 0; 00808000
CALL ERROR('CEXIT: NO LABEL TO MATCH "'00809000
||WORD||'".'); 00810000
END; 00811000
ELSE 00812000
EXLABEL = EXID(I); 00813000
END; 00814000
ELSE 00815000
CALL ERROR('CEXIT: LABEL MISSING AFTER "FROM".');00816000
END; 00817000
IF I=0 THEN I=DOLEV; 00818000
IF EXLABEL = '' THEN 00819000
DO; 00820000
IF EXID(I) = '' THEN 00821000
EXID(I) = GENSYM; 00822000
EXLABEL = EXID(I); 00823000
END; 00824000
IF RCHECK('IF') THEN 00825000
IF CHAR = ';' | CHAR = '>' THEN 00826000
CALL ERROR('CEXIT: EXTRANEOUS "IF" IGNORED.'); 00827000
ELSE 00828000
CALL PREDICATE(FAIL,EXLABEL,@OUTER_PREDICATE,#DUMMY, 00829000
@USE_NEGATED,#DUMMY,@B); 00830000
ELSE 00831000
GEN('B',EXLABEL); 00832000
END; 00833000
ELSE 00834000
CALL ERROR('CEXIT: NO CONTAINING LOOP STRUCTURE FOR "EXIT".'); 00835000
RETURN; 00836000
END CEXIT ; 00837000
1 00838000
/* NEXT OF <BLOCK LABEL> IF <PREDICATE> */ 00839000
00840000
CNEXT: PROCEDURE RECURSIVE; 00841000
DCL 00842000
I FIXED BIN, 00843000
(NXLABEL,FAIL) CHAR(8) VARYING; 00844000
00845000
IF DOLEV > 0 THEN 00846000
DO; 00847000
NXLABEL,FAIL = ''; I = 0; 00848000
IF RCHECK('OF') THEN 00849000
IF CHAR = ';' | CHAR = '>' THEN 00850000
CALL ERROR('CNEXT: EXTRANEOUS "OF" IGNORED.'); 00851000
ELSE 00852000
DO; 00853000
CALL RLABEL; /*RAF-16*/ 00854000
IF WORD^='' THEN /*RAF-16*/ 00855000
DO; 00856000
DO I=1 TO DOLEV WHILE(DOLABEL(I)^=WORD); 00857000
END; 00858000
IF I>DOLEV THEN 00859000
DO; 00860000
I = 0; 00861000
CALL ERROR('CEXIT: NO LABEL TO MATCH "'00862000
||WORD||'".'); 00863000
END; 00864000
ELSE 00865000
NXLABEL = DOID(I); /*RAF-1*/ 00866000
END; 00867000
ELSE 00868000
CALL ERROR('CNEXT: LABEL MISSING AFTER "OF".'); 00869000
END; 00870000
IF I=0 THEN I=DOLEV; 00871000
IF NXLABEL = '' THEN 00872000
DO; 00873000
IF DOID(I) = '' THEN 00874000
DOID(I) = GENSYM; 00875000
NXLABEL = DOID(I); 00876000
END; 00877000
IF RCHECK('IF') THEN 00878000
IF CHAR = ';' | CHAR = '>' THEN 00879000
CALL ERROR('CNEXT: EXTRANEOUS "IF" IGNORED.'); 00880000
ELSE 00881000
CALL PREDICATE(FAIL,NXLABEL,@OUTER_PREDICATE,#DUMMY, 00882000
@USE_NEGATED,#DUMMY,@B); 00883000
ELSE 00884000
GEN('B',NXLABEL); 00885000
END; 00886000
ELSE 00887000
CALL ERROR('CNEXT: NO CONTAINING LOOP STRUCTURE FOR "NEXT".'); 00888000
RETURN; 00889000
END CNEXT ; 00890000
1 00891000
/* USE <REGISTER> AS <DSECT> IN <STATEMENT> */ 00892000
00893000
CUSE: 00894000
PROCEDURE RECURSIVE; 00895000
DCL 00896000
REGSTR CHAR(51) VAR INIT(''), 00897000
MULTUSE BIT(1) INIT(#TRUE), 00898000
(REG,CONBLK) CHAR(8) VARYING; 00899000
00900000
CALL LABPUSH; 00901000
DO WHILE(MULTUSE); 00902000
CALL RWORD; 00903000
IF WORDAL THEN 00904000
REG = WORD; 00905000
ELSE 00906000
DO; 00907000
REG = '?'; 00908000
CALL ERROR('CUSE: MISSING "USING" REGISTER, "'|| 00909000
WORD||'" IGNORED'); 00910000
END; 00911000
IF ^RCHECK('AS') THEN 00912000
CALL ERROR('CUSE: "AS" ASSUMED BEFORE "'||WORD||'".'); 00913000
CALL RWORD; 00914000
IF WORDAL | WORD = '*' THEN 00915000
CONBLK = WORD; 00916000
ELSE 00917000
DO; 00918000
CONBLK = '???'; 00919000
CALL ERROR('CUSE: MISSING DSECT IDENTIFIER, "'|| 00920000
WORD||'" IGNORED'); 00921000
END; 00922000
GEN('USING',CONBLK||','||REG); 00923000
REGSTR = REGSTR||','||REG; 00924000
MULTUSE = RCHAR(','); 00925000
END; 00926000
IF ^RCHECK('IN') THEN 00927000
CALL ERROR('CUSE: "IN" ASSUMED AFTER "'||CONBLK||'".'); 00928000
CALL STMNT; 00929000
CALL LABPUSH; 00930000
GEN('DROP',SUBSTR(REGSTR,2)); 00931000
RETURN; 00932000
END CUSE; 00933000
1 00933010
CASM: PROCEDURE RECURSIVE; /*RAF-9*/ 00933020
/*RAF-9*/ 00933030
CALL RWORD; /* GET SUBSTATEMENT NAME */ /*RAF-9*/ 00933040
/*RAF-9*/ 00933050
IF WORD='IF' THEN CALL CASMIF; /*RAF-9*/ 00933060
ELSE IF WORD='CASE' THEN CALL CASMCASE; /*RAF-9*/ 00933070
ELSE IF WORD='WHILE' THEN CALL CASMWHILE(#FALSE); /*RAF-9*/ 00933080
ELSE IF WORD='UNTIL' THEN CALL CASMWHILE(#TRUE); /*RAF-9*/ 00933090
ELSE IF WORD='FOREVER' THEN CALL CASMFOREVER; /*RAF-9*/ 00933100
ELSE IF WORD='FOR' THEN CALL CASMFOR; /*RAF-9*/ 00933110
ELSE IF WORD='DO' THEN CALL CASMDO; /*RAF-9*/ 00933120
ELSE IF WORD='SELECT' THEN CALL CASMSELECT; /*RAF-9*/ 00933130
ELSE IF WORD='EXIT' THEN CALL CASMEXIT; /*RAF-9*/ 00933140
ELSE IF WORD='NEXT' THEN CALL CASMNEXT; /*RAF-9*/ 00933150
ELSE IF WORD='GOTO' THEN CALL CASMGOTO; /*RAF-9*/ 00933160
ELSE CALL ERROR('CASM: '||WORD||' SHOULD NOT FOLLOW ASM');/*RAF-9*/ 00933170
/*RAF-9*/ 00933180
RETURN; /*RAF-9*/ 00933190
END; /*RAF-9*/ 00933200
1 00934000
/* ASMIF <CONDITION> THEN <STATEMENT> | 00935000
ASMIF <CONDITION> THEN <STATEMENT> ELSE <STATEMENT> */ 00936000
00937000
CASMIF: 00938000
PROCEDURE RECURSIVE ; 00939000
DECLARE 00940000
(GS1,GS2) CHAR(8) VARYING, 00941000
ELSEF BIT(1), 00942000
(L,ELEV) FIXED BIN, 00943000
CONDSTR CHAR(170) VARYING; 00944000
00945000
/* IF ^RCHAR('(') THEN */ /*RAF-9*/ 00946000
/* DO; */ /*RAF-9*/ 00947000
/* CALL ERROR('CASMIF: MISSING CONDITION CLAUSE.')*/ /*RAF-9*/ 00948000
/* RETURN; */ /*RAF-9*/ 00949000
/* END; */ /*RAF-9*/ 00950000
CONDSTR = CONDSCAN(#FALSE); /*RAF-9*/ 00951000
IF ^RCHECK('THEN') THEN 00952000
CALL ERROR('CASMIF: "THEN" INSERTED AFTER ")".'); 00953000
CALL LABPUSH; 00954000
CALL LABFLUSH; 00955000
GS1 = GENSEQSYM; 00956000
C_OPERATION = 'AIF'; 00957000
CONDSTR = '(NOT '||CONDSTR||')'||GS1; 00958000
GEN_OPERANDS(CONDSTR); 00959000
CALL ESQUISH; 00960000
ELEV = EQVLEV+1; 00961000
CALL STMNT; 00962000
CALL LABPUSH; 00963000
CALL LABFLUSH; 00964000
CALL EQVFLUSH(#FALSE,ELEV); 00965000
ELSEF = RCHECK('ELSE'); 00966000
IF ELSEF THEN 00967000
DO; 00968000
GS2 = GENSEQSYM; 00969000
GEN('AGO',GS2); 00970000
END; 00971000
CALL WLABEL(GS1); 00972000
IF ELSEF THEN 00973000
DO; 00974000
CALL ESQUISH; 00975000
ELEV = EQVLEV+1; 00976000
CALL STMNT; 00977000
CALL LABPUSH; 00978000
CALL LABFLUSH; 00979000
CALL EQVFLUSH(#FALSE,ELEV); 00980000
CALL WLABEL(GS2); 00981000
END; 00982000
GEN('ANOP',''); 00983000
RETURN; 00984000
/*RAF-8*/ 00984005
END CASMIF; /*RAF-8*/ 00984010
1 00984015
/* ASM CASE <SETA-VAR> ; */ /*RAF-9*/ 00984020
/* <ASM CASE-LIST> */ /*RAF-9*/ 00984025
/* ENDCASE */ /*RAF-9*/ 00984030
/*RAF-9*/ 00984035
CASMCASE: PROCEDURE RECURSIVE; /*RAF-9*/ 00984040
/*RAF-9*/ 00984045
DECLARE /*RAF-9*/ 00984050
(TCLABEL,NCLABEL,ECLABEL) CHAR(8) VARYING, /*RAF-25*/ /*RAF-9*/ 00984055
(SETVAR,CLOW) CHAR(170) VARYING; /*RAF-25*/ /*RAF-9*/ 00984060
/*RAF-9*/ 00984065
CALL ROPANDS(#FALSE); /* GET SET VARIABLE */ /*RAF-48*/ /*RAF-9*/ 00984070
IF OPANDS='' THEN DO; /*RAF-9*/ 00984075
CALL ERROR('CASMCASE-1: NO SET VARIABLE FOR ASM CASE');/*RAF-9*/ 00984080
OPANDS = '&X'; /*RAF-9*/ 00984085
END; /*RAF-9*/ 00984090
SETVAR = OPANDS; /*RAF-9*/ 00984095
/*RAF-9*/ 00984100
IF ^RCHAR(';') THEN /*RAF-9*/ 00984105
CALL ERROR('CASMCASE-2: MISSING SEMICOLON INSERTED'); /*RAF-9*/ 00984110
/*RAF-9*/ 00984115
ECLABEL = GENSEQSYM; /* END LABEL */ /*RAF-9*/ 00984120
TCLABEL = ''; /* THIS-CASE LABEL */ /*RAF-9*/ 00984125
NCLABEL = GENSEQSYM; /* NEXT-CASE LABEL */ /*RAF-9*/ 00984130
/*RAF-9*/ 00984135
ASMDOLEV = ASMDOLEV+1; /*RAF-9*/ 00984140
ASMDOID(ASMDOLEV) = NCLABEL; /* "NEXT" LABEL */ /*RAF-9*/ 00984145
ASMEXID(ASMDOLEV) = ''; /* "EXIT" LABEL */ /*RAF-9*/ 00984150
ASMDOLABEL(ASMDOLEV) = CURSEQSYM; /* "FROM/OF" LABEL */ /*RAF-9*/ 00984155
/*RAF-9*/ 00984160
NESTLEV = NESTLEV+1; /* INCREASE NESTING LEVEL */ /*RAF-9*/ 00984165
NESTID(NESTLEV) = CIN_ID; /*RAF-9*/ 00984170
/*RAF-9*/ 00984175
CALL LABPUSH; CALL LABFLUSH; /* CLEAR LABEL STACK */ /*RAF-9*/ 00984180
/*RAF-9*/ 00984185
CALL ROPANDS(#TRUE); /* SCAN FOR CASE LABEL */ /*RAF-9*/ 00984190
DO WHILE(OPANDS^='ENDCASE'); /* LOOP UNTIL ENDCASE */ /*RAF-9*/ 00984195
IF OPANDS='' THEN /*RAF-9*/ 00984200
CALL ERROR('CASMCASE-3: MISSING CASE LABEL'); /*RAF-9*/ 00984205
IF TCLABEL='' THEN DO; /*RAF-9*/ 00984210
TCLABEL = GENSEQSYM; /*RAF-9*/ 00984215
CALL CWLABEL(NCLABEL); /* LABEL THIS CASE */ /*RAF-9*/ 00984220
NCLABEL = GENSEQSYM; /* LABEL FOR NEXT CASE */ /*RAF-9*/ 00984225
END; /*RAF-9*/ 00984230
IF ^RCHECK('THRU') THEN DO; /* SINGLE CASE */ /*RAF-9*/ 00984235
GEN('AIF','('||SETVAR||' EQ '||OPANDS||')'|| /*RAF-9*/ 00984240
TCLABEL); /*RAF-9*/ 00984245
END; /*RAF-9*/ 00984250
ELSE DO; /*RAF-9*/ 00984255
CLOW = OPANDS; /*RAF-9*/ 00984260
CALL ROPANDS(#TRUE); /* GET HIGH VALUE */ /*RAF-9*/ 00984265
GEN('AIF','(('||SETVAR||' GE '||CLOW||') AND ('|| /*RAF-9*/ 00984270
SETVAR||' LE '||OPANDS||'))'||TCLABEL); /*RAF-9*/ 00984275
END; /*RAF-9*/ 00984280
IF RCHAR(',') THEN DO; /* MORE CASES */ /*RAF-9*/ 00984285
IF TCLABEL='' THEN /*RAF-9*/ 00984290
CALL ERROR('CASMCASE-4: EXTRANEOUS COMMA IGNORED'); /*RAF-9*/ 00984295
CALL ROPANDS(#TRUE); /* READ NEXT CASE VALUE */ /*RAF-9*/ 00984300
END; /*RAF-9*/ 00984305
ELSE IF RCHAR(':') THEN DO; /* BODY OF CASE */ /*RAF-9*/ 00984310
IF TCLABEL='' THEN DO; /*RAF-9*/ 00984315
CALL ERROR('CASMCASE-5: MISSING CASE LABEL'); /*RAF-9*/ 00984320
END; /*RAF-9*/ 00984325
GEN('AGO',NCLABEL); /* TRY NEXT CASE */ /*RAF-9*/ 00984330
CALL CWLABEL(TCLABEL); /* LABEL CASE BODY */ /*RAF-9*/ 00984335
CALL ASMSTMNT; /* GET A STATEMENT */ /*RAF-9*/ 00984340
GEN('AGO',ECLABEL); /* EXIT FROM CASE */ /*RAF-9*/ 00984345
TCLABEL = ''; /* INDICATE NO CASE */ /*RAF-9*/ 00984350
IF ^RCHAR(';') THEN /*RAF-9*/ 00984355
CALL ERROR('CASMCASE-6: MISSING SEMICOLON INSERTED' /*RAF-9*/ 00984360
); /*RAF-9*/ 00984365
CALL ROPANDS(#TRUE); /* READ NEXT CASE VALUE */ /*RAF-9*/ 00984370
END; /*RAF-9*/ 00984375
ELSE DO; /*RAF-9*/ 00984380
CALL RWORD; CALL RCHAR(';'); /*RAF-9*/ 00984385
CALL ERROR('CASMCASE-7: EXTRANEOUS '||WORD|| /*RAF-9*/ 00984390
' IGNORED'); /*RAF-9*/ 00984395
END; /*RAF-9*/ 00984400
END; /*RAF-9*/ 00984405
/*RAF-9*/ 00984410
NESTLEV = NESTLEV-1; /*RAF-25*/ 00984412
/*RAF-25*/ 00984413
CALL WLABEL(NCLABEL); /* NO MATCHING CASE */ /*RAF-9*/ 00984415
GEN('ANOP',''); /*RAF-23*/ 00984417
IF RCHECK('ELSE') THEN CALL ASMSTMNT; /*RAF-18*/ 00984418
ELSE GEN('MNOTE','4,''ASM CASE OUT OF RANGE''');/*RAF-9*//*RAF-18*/ 00984420
/*RAF-9*/ 00984425
CALL WLABEL(ECLABEL); /* ENDCASE LABEL */ /*RAF-9*/ 00984430
/*RAF-9*/ 00984435
ECLABEL = ASMEXID(ASMDOLEV); /*RAF-9*/ 00984440
ASMDOLEV = ASMDOLEV-1; /*RAF-9*/ 00984445
/* NESTLEV = NESTLEV-1; */ /*RAF-25*/ /*RAF-9*/ 00984450
IF NESTLEV=0 THEN PREDLABLEV=0; /*RAF-9*/ 00984455
IF RCHECK('THEN') THEN /*RAF-9*/ 00984460
CALL ASMSTMNT; /* GET A STATEMENT */ /*RAF-9*/ 00984465
/*RAF-9*/ 00984470
GEN('ANOP',''); /*RAF-22*/ 00984477
CALL CWLABEL(ECLABEL); /* "EXIT" LABEL */ /*RAF-9*/ 00984478
GEN('ANOP',''); /*RAF-35*/ 00984479
END CASMCASE; /*RAF-9*/ 00984480
1 00984485
/* ASM WHILE <COND> DO <STMNT> THEN <STMNT> */ /*RAF-9*/ 00984490
/* ASM UNTIL <COND> DO <STMNT> THEN <STMNT> */ /*RAF-9*/ 00984495
/*RAF-9*/ 00984500
CASMWHILE: PROCEDURE(UWB) RECURSIVE; /*RAF-9*/ 00984505
/*RAF-9*/ 00984510
DECLARE /*RAF-9*/ 00984515
UWB BIT(1), /* FALSE => WHILE */ /*RAF-9*/ 00984520
(TOP,FAILURE,THENPART) CHAR(8) VARYING; /*RAF-9*/ 00984525
/*RAF-9*/ 00984530
TOP = GENSEQSYM; /* TOP OF LOOP */ /*RAF-9*/ 00984535
FAILURE = GENSEQSYM; /* END LABEL */ /*RAF-9*/ 00984540
/*RAF-9*/ 00984545
ASMDOLEV = ASMDOLEV+1; /*RAF-9*/ 00984550
ASMDOID(ASMDOLEV) = TOP; /* "NEXT" LABEL */ /*RAF-9*/ 00984555
ASMEXID(ASMDOLEV) = ''; /* "EXIT" LABEL */ /*RAF-9*/ 00984560
ASMDOLABEL(ASMDOLEV) = CURSEQSYM; /* "FROM" LABEL */ /*RAF-9*/ 00984565
/*RAF-9*/ 00984570
CALL LABPUSH; CALL LABFLUSH; /* FLUSH LABEL STACK */ /*RAF-9*/ 00984575
/*RAF-9*/ 00984580
CALL WLABEL(TOP); /*RAF-9*/ 00984585
IF UWB /*RAF-9*/ 00984590
THEN GEN('AIF',CONDSCAN(#FALSE)||FAILURE); /* UNTIL */ /*RAF-9*/ 00984595
ELSE GEN('AIF','(NOT '||CONDSCAN(#FALSE)||')'||FAILURE); /*RAF-9*/ 00984600
/*RAF-9*/ 00984605
IF ^RCHECK('DO') THEN /*RAF-9*/ 00984610
CALL ERROR('CASMWHILE/UNTIL: MISSING "DO" INSERTED'); /*RAF-9*/ 00984615
/*RAF-9*/ 00984620
CALL ASMSTMNT; /* GET A STATEMENT */ /*RAF-9*/ 00984625
/*RAF-9*/ 00984630
GEN('AGO',TOP); /*RAF-9*/ 00984635
CALL WLABEL(FAILURE); /*RAF-9*/ 00984640
/*RAF-9*/ 00984645
THENPART = ASMEXID(ASMDOLEV); /*RAF-9*/ 00984650
ASMDOLEV = ASMDOLEV-1; /*RAF-9*/ 00984655
IF RCHECK('THEN') THEN CALL ASMSTMNT; /*RAF-9*/ 00984660
/*RAF-9*/ 00984665
CALL CWLABEL(THENPART); /*RAF-9*/ 00984670
GEN('ANOP',''); /*RAF-22*/ 00984672
/*RAF-9*/ 00984675
RETURN; /*RAF-9*/ 00984680
END CASMWHILE; /*RAF-9*/ 00984685
1 00984690
/* ASM FOR <SETA-VAR> FROM <SETA-EXPR> BY <SETA-EXPR> */ /*RAF-9*/ 00984695
/* TO <SETA-EXPR> DO <STMNT> THEN <STMNT> */ /*RAF-9*/ 00984700
/*RAF-9*/ 00984705
CASMFOR: PROCEDURE RECURSIVE; /*RAF-9*/ 00984710
/*RAF-9*/ 00984715
DECLARE /*RAF-9*/ 00984720
VAR CHAR(8) VARYING, /*RAF-9*/ 00984725
(FROMVAL,BYVAL,TOVAL) CHAR(170) VARYING, /*RAF-9*/ 00984730
(TOP,DONE,THENPART) CHAR(8) VARYING; /*RAF-9*/ 00984735
/*RAF-9*/ 00984740
TOP = GENSEQSYM; /*RAF-9*/ 00984745
DONE = GENSEQSYM; /*RAF-9*/ 00984750
ASMDOLEV = ASMDOLEV+1; /*RAF-9*/ 00984755
ASMDOID(ASMDOLEV) = ''; /*RAF-9*/ 00984760
ASMEXID(ASMDOLEV) = ''; /*RAF-9*/ 00984765
ASMDOLABEL(ASMDOLEV) = CURSEQSYM; /*RAF-9*/ 00984770
/*RAF-9*/ 00984775
CALL RLABEL; /* GET SETA VARIABLE */ /*RAF-9*/ 00984780
IF WORD^='' THEN DO; /*RAF-9*/ 00984785
IF SUBSTR(WORD,1,1)^='&' THEN /*RAF-9*/ 00984790
CALL ERROR('CASMFOR-1: ILLEGAL SETA VARIABLE'); /*RAF-9*/ 00984795
VAR = WORD; /*RAF-9*/ 00984800
END; /*RAF-9*/ 00984805
ELSE DO; /*RAF-9*/ 00984810
CALL ERROR('CASMFOR-2: MISSING SETA VARIABLE'); /*RAF-9*/ 00984815
VAR = '&X'; /*RAF-9*/ 00984820
END; /*RAF-9*/ 00984825
/*RAF-9*/ 00984830
FROMVAL = '0'; BYVAL = '1'; TOVAL = ''; /* DEFAULTS */ /*RAF-9*/ 00984835
DO WHILE(#TRUE); /*RAF-9*/ 00984840
IF RCHECK('DO') THEN GO TO DO_FOUND; /*RAF-9*/ 00984845
IF RCHECK('FROM') THEN DO; /*RAF-9*/ 00984850
CALL ROPANDS(#TRUE); /*RAF-9*/ 00984855
IF OPANDS='' THEN /*RAF-9*/ 00984860
CALL ERROR('CASMFOR-3: MISSING "FROM" VALUE'); /*RAF-9*/ 00984865
ELSE FROMVAL = OPANDS; /*RAF-9*/ 00984870
END; /*RAF-9*/ 00984875
ELSE IF RCHECK('BY') THEN DO; /*RAF-9*/ 00984880
CALL ROPANDS(#TRUE); /*RAF-9*/ 00984885
IF OPANDS='' THEN /*RAF-9*/ 00984890
CALL ERROR('CASMFOR-4: MISSING "BY" VALUE'); /*RAF-9*/ 00984895
ELSE BYVAL = OPANDS; /*RAF-9*/ 00984900
END; /*RAF-9*/ 00984905
ELSE IF RCHECK('TO') THEN DO; /*RAF-9*/ 00984910
CALL ROPANDS(#TRUE); /*RAF-9*/ 00984915
IF OPANDS='' THEN /*RAF-9*/ 00984920
CALL ERROR('CASMFOR-5: MISSING "TO" VALUE'); /*RAF-9*/ 00984925
ELSE TOVAL = OPANDS; /*RAF-9*/ 00984930
END; /*RAF-9*/ 00984935
ELSE DO; /*RAF-9*/ 00984940
CALL ERROR('CASMFOR: MISSING "DO" INSERTED'); /*RAF-9*/ 00984945
GO TO DO_FOUND; /*RAF-9*/ 00984950
END; /*RAF-9*/ 00984955
END; /*RAF-9*/ 00984960
DO_FOUND: /*RAF-9*/ 00984965
/*RAF-9*/ 00984970
CALL LABPUSH; CALL LABFLUSH; /*RAF-9*/ 00984975
CALL WLABEL(VAR); /*RAF-9*/ 00984980
GEN('SETA',FROMVAL); /*RAF-9*/ 00984985
CALL WLABEL(TOP); /*RAF-9*/ 00984990
IF TOVAL^='' THEN DO; /*RAF-9*/ 00984995
GEN('AIF','(('||BYVAL||' GT 0) AND ('||VAR||' GT '|| /*RAF-9*/ 00985000
TOVAL||'))'||DONE); /*RAF-9*/ 00985005
GEN('AIF','(('||BYVAL||' LT 0) AND ('||VAR||' LT '|| /*RAF-9*/ 00985010
TOVAL||'))'||DONE); /*RAF-9*/ 00985015
END; /*RAF-9*/ 00985020
CALL ASMSTMNT; /*RAF-9*/ 00985025
CALL CWLABEL(ASMDOID(ASMDOLEV)); /*RAF-9*/ 00985030
CALL WLABEL(VAR); /*RAF-9*/ 00985035
GEN('SETA',VAR||'+'||BYVAL); /*RAF-9*/ 00985040
GEN('AGO',TOP); /*RAF-9*/ 00985045
CALL WLABEL(DONE); /*RAF-9*/ 00985050
GEN('ANOP',''); /*RAF-35*/ 00985052
/*RAF-9*/ 00985055
THENPART = ASMEXID(ASMDOLEV); /*RAF-9*/ 00985060
ASMDOLEV = ASMDOLEV-1; /*RAF-9*/ 00985065
IF RCHECK('THEN') THEN CALL ASMSTMNT; /*RAF-9*/ 00985070
CALL CWLABEL(THENPART); /*RAF-9*/ 00985075
IF THENPART^='' THEN GEN('ANOP',''); /*RAF-27*/ /*RAF-22*/ 00985077
/*RAF-9*/ 00985080
RETURN; /*RAF-9*/ 00985085
END CASMFOR; /*RAF-9*/ 00985090
1 00985095
/* ASM FOREVER DO <STMNT> */ /*RAF-9*/ 00985100
/*RAF-9*/ 00985105
CASMFOREVER: PROCEDURE RECURSIVE; /*RAF-9*/ 00985110
/*RAF-9*/ 00985115
DECLARE TOP CHAR(8) VARYING; /*RAF-9*/ 00985120
/*RAF-9*/ 00985125
IF ^RCHECK('DO') THEN /*RAF-9*/ 00985130
CALL ERROR('CASMFOREVER-1: MISSING "DO" INSERTED'); /*RAF-9*/ 00985135
/*RAF-9*/ 00985140
TOP = GENSEQSYM; /*RAF-9*/ 00985145
/*RAF-9*/ 00985150
ASMDOLEV = ASMDOLEV+1; /*RAF-9*/ 00985155
ASMDOID(ASMDOLEV) = TOP; /*RAF-9*/ 00985160
ASMEXID(ASMDOLEV) = ''; /*RAF-9*/ 00985165
ASMDOLABEL(ASMDOLEV) = CURSEQSYM; /*RAF-9*/ 00985170
/*RAF-9*/ 00985175
CALL LABPUSH; CALL LABFLUSH; /*RAF-9*/ 00985180
/*RAF-9*/ 00985185
CALL WLABEL(TOP); /*RAF-9*/ 00985190
CALL ASMSTMNT; /*RAF-9*/ 00985195
GEN('AGO',TOP); /*RAF-9*/ 00985200
/*RAF-9*/ 00985205
IF RCHECK('THEN') THEN /*RAF-9*/ 00985210
CALL ERROR('CASMFOREVER-2: IAPPROPRIATE "THEN" IGNORED'); /*RAF-9*/ 00985215
/*RAF-9*/ 00985220
CALL CWLABEL(ASMEXID(ASMDOLEV)); /* "EXIT" LABEL */ /*RAF-9*/ 00985225
GEN('ANOP',''); /*RAF-22*/ 00985227
ASMDOLEV = ASMDOLEV-1; /*RAF-9*/ 00985230
RETURN; /*RAF-9*/ 00985235
END CASMFOREVER; /*RAF-9*/ 00985240
1 00985245
/* ASM DO <STMNT> THEN <STMNT> */ /*RAF-9*/ 00985250
/* ASM DO <STMNT> WHILE/UNTIL <COND> THEN <STMNT> */ /*RAF-9*/ 00985255
/* ASM DO <STMNT> FOR <SETA-VAR> BY <SETA-EXPR> */ /*RAF-9*/ 00985260
/* TO <SETA-EXPR> THEN <STMNT> */ /*RAF-9*/ 00985265
/* ASM DO <STMNT> FOREVER */ /*RAF-9*/ 00985270
/*RAF-9*/ 00985275
CASMDO: PROCEDURE RECURSIVE; /*RAF-9*/ 00985280
/*RAF-9*/ 00985285
DECLARE /*RAF-9*/ 00985290
(TOP,EXIT) CHAR(8) VARYING, /*RAF-9*/ 00985295
THENOK BIT(1) INIT(#TRUE); /*RAF-9*/ 00985300
/*RAF-9*/ 00985305
TOP = GENSEQSYM; /* TOP OF LOOP LABEL */ /*RAF-9*/ 00985310
/*RAF-9*/ 00985315
ASMDOLEV = ASMDOLEV+1; /*RAF-9*/ 00985320
ASMDOID(ASMDOLEV),ASMEXID(ASMDOLEV) = ''; /*RAF-9*/ 00985325
ASMDOLABEL(ASMDOLEV) = CURSEQSYM; /*RAF-9*/ 00985330
/*RAF-9*/ 00985335
CALL LABPUSH; CALL LABFLUSH; /*RAF-9*/ 00985340
CALL WLABEL(TOP); /* LABEL TOP OF LOOP */ /*RAF-9*/ 00985345
CALL ASMSTMNT; /* GET BODY OF LOOP */ /*RAF-9*/ 00985350
CALL CWLABEL(ASMDOID(ASMDOLEV)); /* "NEXT" LABEL */ /*RAF-9*/ 00985355
/*RAF-9*/ 00985360
IF RCHECK('WHILE') THEN DO; /*RAF-9*/ 00985365
GEN('AIF',CONDSCAN(#FALSE)||TOP); /*RAF-9*/ 00985370
END; /*RAF-9*/ 00985375
ELSE IF RCHECK('UNTIL') THEN DO; /*RAF-9*/ 00985380
GEN('AIF','(NOT '||CONDSCAN(#FALSE)||')'||TOP); /*RAF-9*/ 00985385
END; /*RAF-9*/ 00985390
ELSE IF RCHECK('FOREVER') THEN DO; /*RAF-9*/ 00985395
GEN('AGO',TOP); /*RAF-9*/ 00985400
THENOK = #FALSE; /*RAF-9*/ 00985405
END; /*RAF-9*/ 00985410
ELSE IF RCHECK('FOR') THEN BEGIN; /*RAF-9*/ 00985415
DECLARE /*RAF-9*/ 00985420
VAR CHAR(8) VARYING, /*RAF-9*/ 00985425
(BYVAL,TOVAL) CHAR(170) VARYING; /*RAF-9*/ 00985430
CALL RLABEL; /* GET SETA VARIABLE */ /*RAF-9*/ 00985435
IF WORD^='' THEN DO; /*RAF-9*/ 00985440
IF SUBSTR(WORD,1,1)^='&' THEN /*RAF-9*/ 00985445
CALL ERROR('CASMDO-1: ILLEGAL SETA VARIABLE'); /*RAF-9*/ 00985450
VAR = WORD; /*RAF-9*/ 00985455
END; /*RAF-9*/ 00985460
ELSE DO; /*RAF-9*/ 00985465
CALL ERROR('CASMDO-2: MISSING SETA VARIABLE'); /*RAF-9*/ 00985470
VAR = '&X'; /*RAF-9*/ 00985475
END; /*RAF-9*/ 00985480
BYVAL = '1'; TOVAL=''; /*RAF-9*/ 00985485
DO WHILE(#TRUE); /*RAF-9*/ 00985490
IF RCHECK('FROM') THEN DO; /*RAF-9*/ 00985495
CALL ERROR('CASMFOR-3: INAPPROPRIATE "FROM"'|| /*RAF-9*/ 00985500
' IGNORED'); /*RAF-9*/ 00985505
END; /*RAF-9*/ 00985510
ELSE IF RCHECK('BY') THEN DO; /*RAF-9*/ 00985515
CALL ROPANDS(#TRUE); /*RAF-9*/ 00985520
IF OPANDS='' THEN /*RAF-9*/ 00985525
CALL ERROR('CASMDO-4: MISSING "BY" VALUE'); /*RAF-9*/ 00985530
ELSE BYVAL = OPANDS; /*RAF-9*/ 00985535
END; /*RAF-9*/ 00985540
ELSE IF RCHECK('TO') THEN DO; /*RAF-9*/ 00985545
CALL ROPANDS(#TRUE); /*RAF-9*/ 00985550
IF OPANDS='' THEN /*RAF-9*/ 00985555
CALL ERROR('CASMDO-5: MISSING "TO" VALUE'); /*RAF-9*/ 00985560
ELSE TOVAL = OPANDS; /*RAF-9*/ 00985565
END; /*RAF-9*/ 00985570
ELSE DO; /*RAF-9*/ 00985575
GO TO NO_BY_OR_TO; /*RAF-9*/ 00985580
END; /*RAF-9*/ 00985585
END; /*RAF-9*/ 00985590
NO_BY_OR_TO: /*RAF-9*/ 00985595
/*RAF-9*/ 00985600
CALL WLABEL(VAR); /*RAF-9*/ 00985605
GEN('SETA',VAR||'+'||BYVAL); /*RAF-9*/ 00985610
IF TOVAL^='' THEN DO; /*RAF-9*/ 00985615
GEN('AIF','(('||BYVAL||' GT 0) AND ('||VAR|| /*RAF-9*/ 00985620
' LE '||TOVAL||'))'||TOP); /*RAF-9*/ 00985625
GEN('AIF','(('||BYVAL||' LT 0) AND ('||VAR|| /*RAF-9*/ 00985630
' GE '||TOVAL||'))'||TOP); /*RAF-9*/ 00985635
END; /*RAF-9*/ 00985640
ELSE GEN('AGO',TOP); /*RAF-9*/ 00985645
END; /*RAF-9*/ 00985650
/*RAF-9*/ 00985655
EXIT = ASMEXID(ASMDOLEV); /*RAF-9*/ 00985660
ASMDOLEV=ASMDOLEV-1; /*RAF-9*/ 00985665
IF RCHECK('THEN') THEN DO; /*RAF-9*/ 00985670
IF ^THENOK THEN /*RAF-9*/ 00985675
CALL ERROR('CASMDO-6: INAPPROPRIATE "THEN" IGNORED'); /*RAF-9*/ 00985680
CALL ASMSTMNT; /*RAF-9*/ 00985685
END; /*RAF-9*/ 00985690
CALL CWLABEL(EXIT); /*RAF-9*/ 00985695
GEN('ANOP',''); /*RAF-22*/ 00985697
/*RAF-9*/ 00985700
RETURN; /*RAF-9*/ 00985705
END CASMDO; /*RAF-9*/ 00985710
1 00985715
/* ASM SELECT (FIRST) */ /*RAF-9*/ 00985720
/* <COND>: STMNT; ... */ /*RAF-9*/ 00985725
/* ENDSEL (ELSE STMNT) (THEN STMNT) */ /*RAF-9*/ 00985730
/*RAF-9*/ 00985735
CASMSELECT: PROCEDURE RECURSIVE; /*RAF-9*/ 00985740
/*RAF-9*/ 00985745
DECLARE /*RAF-9*/ 00985750
(THENPART,NEXTCASE,EXIT) CHAR(8) VARYING, /*RAF-9*/ 00985755
FIRST BIT(1); /*RAF-9*/ 00985760
/*RAF-9*/ 00985765
NESTLEV = NESTLEV+1; /*RAF-9*/ 00985770
NESTID(NESTLEV) = CIN_ID; /*RAF-9*/ 00985775
/*RAF-9*/ 00985780
FIRST = RCHECK('FIRST'); /*RAF-9*/ 00985785
IF ^RCHAR(';') THEN /*RAF-9*/ 00985790
CALL ERROR('CASMSELECT-1: MISSING SEMICOLON INSERTED'); /*RAF-9*/ 00985795
/*RAF-9*/ 00985800
THENPART = GENSEQSYM; /*RAF-9*/ 00985805
NEXTCASE = GENSEQSYM; /*RAF-9*/ 00985810
EXIT = ''; /*RAF-9*/ 00985815
IF FIRST THEN EXIT = GENSEQSYM; /*RAF-9*/ 00985820
/*RAF-9*/ 00985825
ASMDOLEV = ASMDOLEV+1; /*RAF-9*/ 00985830
ASMDOID(ASMDOLEV) = NEXTCASE; /*RAF-9*/ 00985835
ASMEXID(ASMDOLEV) = EXIT; /*RAF-9*/ 00985840
ASMDOLABEL(ASMDOLEV) = CURSEQSYM; /*RAF-9*/ 00985845
/*RAF-9*/ 00985850
CALL LABPUSH; CALL LABFLUSH; /*RAF-9*/ 00985855
/*RAF-9*/ 00985860
DO WHILE(^RCHECK('ENDSEL')); /*RAF-9*/ 00985865
CALL WLABEL(NEXTCASE); /*RAF-9*/ 00985870
NEXTCASE = GENSEQSYM; /*RAF-9*/ 00985875
GEN('AIF','(NOT '||CONDSCAN(#FALSE)||')'||NEXTCASE); /*RAF-9*/ 00985880
IF ^RCHAR(':') THEN /*RAF-9*/ 00985885
CALL ERROR('CASMSELECT-2: MISSING COLON INSERTED'); /*RAF-9*/ 00985890
CALL ASMSTMNT; /*RAF-9*/ 00985895
IF ^RCHAR(';') THEN /*RAF-9*/ 00985900
CALL ERROR('CASMSELECT-4: MISSING SEMICOLON INSERTED');/*RAF-9*/ 00985905
IF FIRST THEN GEN('AGO',EXIT); /*RAF-9*/ 00985910
END; /*RAF-9*/ 00985915
/*RAF-9*/ 00985920
CALL WLABEL(NEXTCASE); /*RAF-9*/ 00985925
NESTLEV = NESTLEV - 1; /*RAF-9*/ 00985930
/*RAF-9*/ 00985935
IF RCHECK('ELSE') THEN DO; /*RAF-9*/ 00985940
IF ^FIRST THEN /*RAF-9*/ 00985945
CALL ERROR('CASMSELECT-3: ELSE USED WITHOUT FIRST'); /*RAF-9*/ 00985950
CALL ASMSTMNT; /*RAF-9*/ 00985955
END; /*RAF-9*/ 00985960
/*RAF-9*/ 00985965
EXIT = ASMEXID(ASMDOLEV); /*RAF-9*/ 00985970
ASMDOLEV = ASMDOLEV - 1; /*RAF-9*/ 00985975
CALL WLABEL(THENPART); /*RAF-9*/ 00985980
IF RCHECK('THEN') THEN CALL ASMSTMNT; /*RAF-9*/ 00985985
CALL CWLABEL(EXIT); /*RAF-9*/ 00985990
GEN('ANOP',''); /*RAF-22*/ 00985992
RETURN; /*RAF-9*/ 00985995
END CASMSELECT; /*RAF-9*/ 00986000
1 00986005
/* ASM EXIT FROM <SEQSYM> IF <COND> */ /*RAF-9*/ 00986010
/*RAF-9*/ 00986015
CASMEXIT: PROCEDURE; /*RAF-9*/ 00986020
/*RAF-9*/ 00986025
DECLARE /*RAF-9*/ 00986030
EXLABEL CHAR(8) VARYING, /*RAF-9*/ 00986035
I FIXED BIN; /*RAF-9*/ 00986040
/*RAF-9*/ 00986045
EXLABEL=''; /*RAF-9*/ 00986050
IF ASMDOLEV<=0 THEN /*RAF-9*/ 00986055
CALL ERROR('CASMEXIT-1: NO CONTAINING ASM LOOP'|| /*RAF-9*/ 00986060
' STRUCTURE FOR ASM EXIT'); /*RAF-9*/ 00986065
IF ^RCHECK('FROM') THEN I=ASMDOLEV; /*RAF-9*/ 00986070
ELSE DO; /*RAF-9*/ 00986075
CALL RLABEL; /*RAF-9*/ 00986080
IF WORD='' THEN /*RAF-9*/ 00986085
CALL ERROR('CASMEXIT-2: MISSING SEQUENCE SYMBOL'|| /*RAF-9*/ 00986090
' FOLLOWING "FROM"'); /*RAF-9*/ 00986095
ELSE IF SUBSTR(WORD,1,1)^='.' THEN /*RAF-9*/ 00986100
CALL ERROR('CASMEXIT-3: EXIT LABEL MUST BE '|| /*RAF-9*/ 00986105
'SEQUENCE SYMBOL'); /*RAF-9*/ 00986110
DO I=ASMDOLEV BY -1 TO 1 /*RAF-9*/ 00986115
WHILE(ASMDOLABEL(I)^=WORD); /*RAF-9*/ 00986120
END; /*RAF-9*/ 00986125
IF I<1 THEN DO; /*RAF-9*/ 00986130
CALL ERROR('CASMEXIT-4: EXIT LABEL NOT FOUND'); /*RAF-9*/ 00986135
I = ASMDOLEV; /*RAF-9*/ 00986140
END; /*RAF-9*/ 00986145
END; /*RAF-9*/ 00986150
IF I>=1 THEN DO; /*RAF-9*/ 00986155
IF ASMEXID(I)='' THEN ASMEXID(I) = GENSEQSYM; /*RAF-9*/ 00986160
EXLABEL = ASMEXID(I); /*RAF-9*/ 00986165
END; /*RAF-9*/ 00986170
/*RAF-9*/ 00986175
CALL LABPUSH; CALL LABFLUSH; /*RAF-31*/ 00986178
IF ^RCHECK('IF') THEN GEN('AGO',EXLABEL); /*RAF-9*/ 00986180
ELSE DO; /*RAF-9*/ 00986185
OPANDS=CONDSCAN(#FALSE); /*RAF-9*/ 00986190
GEN('AIF',OPANDS||EXLABEL); /*RAF-9*/ 00986195
END; /*RAF-9*/ 00986200
/*RAF-9*/ 00986205
RETURN; /*RAF-9*/ 00986210
END CASMEXIT; /*RAF-9*/ 00986215
1 00986220
/* ASM NEXT OF <SEQSYM> IF <COND> */ /*RAF-9*/ 00986225
/*RAF-9*/ 00986230
CASMNEXT: PROCEDURE; /*RAF-9*/ 00986235
/*RAF-9*/ 00986240
DECLARE /*RAF-9*/ 00986245
NXLABEL CHAR(8) VARYING, /*RAF-9*/ 00986250
I FIXED BIN; /*RAF-9*/ 00986255
/*RAF-9*/ 00986260
NXLABEL=''; /*RAF-9*/ 00986265
IF ASMDOLEV<=0 THEN /*RAF-9*/ 00986270
CALL ERROR('CASMNEXT-1: NO CONTAINING ASM LOOP'|| /*RAF-9*/ 00986275
' STRUCTURE FOR ASM NEXT'); /*RAF-9*/ 00986280
IF ^RCHECK('OF') THEN I=ASMDOLEV; /*RAF-9*/ 00986285
ELSE DO; /*RAF-9*/ 00986290
CALL RLABEL; /*RAF-9*/ 00986295
IF WORD='' THEN /*RAF-9*/ 00986300
CALL ERROR('CASMNEXT-2: MISSING SEQUENCE SYMBOL'|| /*RAF-9*/ 00986305
' FOLLOWING "OF"'); /*RAF-9*/ 00986310
ELSE IF SUBSTR(WORD,1,1)^='.' THEN /*RAF-9*/ 00986315
CALL ERROR('CASMNEXT-3: NEXT LABEL MUST BE '|| /*RAF-9*/ 00986320
'SEQUENCE SYMBOL'); /*RAF-9*/ 00986325
DO I=ASMDOLEV BY -1 TO 1 /*RAF-9*/ 00986330
WHILE(ASMDOLABEL(I)^=WORD); /*RAF-9*/ 00986335
END; /*RAF-9*/ 00986340
IF I<1 THEN DO; /*RAF-9*/ 00986345
CALL ERROR('CASMNEXT-4: NEXT LABEL NOT FOUND'); /*RAF-9*/ 00986350
I = ASMDOLEV; /*RAF-9*/ 00986355
END; /*RAF-9*/ 00986360
END; /*RAF-9*/ 00986365
IF I>=1 THEN DO; /*RAF-9*/ 00986370
IF ASMDOID(I)='' THEN ASMDOID(I) = GENSEQSYM; /*RAF-9*/ 00986375
NXLABEL = ASMDOID(I); /*RAF-9*/ 00986380
END; /*RAF-9*/ 00986385
/*RAF-9*/ 00986390
CALL LABPUSH; CALL LABFLUSH; /*RAF-31*/ 00986393
IF ^RCHECK('IF') THEN GEN('AGO',NXLABEL); /*RAF-9*/ 00986395
ELSE DO; /*RAF-9*/ 00986400
OPANDS=CONDSCAN(#FALSE); /*RAF-9*/ 00986405
GEN('AIF',OPANDS||NXLABEL); /*RAF-9*/ 00986410
END; /*RAF-9*/ 00986415
/*RAF-9*/ 00986420
RETURN; /*RAF-9*/ 00986425
END CASMNEXT; /*RAF-9*/ 00986430
1 00986435
/* ASM GOTO <SEQSYM> IF <COND> */ /*RAF-9*/ 00986440
/*RAF-9*/ 00986445
CASMGOTO: PROCEDURE; /*RAF-9*/ 00986450
/*RAF-9*/ 00986455
DECLARE LABEL CHAR(8) VARYING STATIC; /*RAF-9*/ 00986460
/*RAF-9*/ 00986465
CALL RLABEL; /*RAF-9*/ 00986470
LABEL = WORD; /*RAF-9*/ 00986475
IF LABEL = '' /*RAF-9*/ 00986480
THEN CALL ERROR('CASMGOTO-1: MISSING SEQUENCE SYMBOL'); /*RAF-9*/ 00986485
ELSE IF SUBSTR(LABEL,1,1)^='.' /*RAF-9*/ 00986490
THEN CALL ERROR('CASMGOTO-2: ILLEGAL SEQUENCE SYMBOL'); /*RAF-9*/ 00986495
/*RAF-9*/ 00986500
CALL LABPUSH; CALL LABFLUSH; /*RAF-9*/ 00986505
/*RAF-9*/ 00986510
IF RCHECK('IF') /*RAF-9*/ 00986515
THEN GEN('AIF',CONDSCAN(#FALSE)||LABEL); /*RAF-9*/ 00986520
ELSE GEN('AGO',LABEL); /*RAF-9*/ 00986525
/*RAF-9*/ 00986530
RETURN; /*RAF-9*/ 00986535
END CASMGOTO; /*RAF-9*/ 00986540
1 00986545
ESQUISH: /*RAF-9*/ 00986550
PROCEDURE; 00987000
DCL 00988000
(I,J) FIXED BIN; 00989000
00990000
J = 0; 00991000
DO I = 1 TO EQVLEV; 00992000
IF EQVSTK(I,1) ^= '' THEN 00993000
DO; 00994000
J = J+1; 00995000
EQVSTK(J,1) = EQVSTK(I,1); 00996000
EQVSTK(J,2) = EQVSTK(I,2); 00997000
END; 00998000
END; 00999000
EQVLEV = J; 01000000
RETURN; 01001000
END ESQUISH; 01002000
01003000
/* END CASMIF; */ /*RAF-8*/ 01004000
1 01004010
/* PROCEDURE TO FIND LABEL FOR ASM LOOP CONSTRUCT */ /*RAF-9*/ 01004020
/*RAF-9*/ 01004030
CURSEQSYM: PROCEDURE RETURNS(CHAR(8) VARYING); /*RAF-9*/ 01004040
/*RAF-9*/ 01004050
DECLARE CLABEL CHAR(8) VARYING; /*RAF-9*/ 01004060
/*RAF-9*/ 01004070
CLABEL = ''; /*RAF-9*/ 01004080
IF SUBSTR(C_LABEL,1,1)='.' & SUBSTR(C_LABEL,2,1)^='@' /*RAF-9*/ 01004090
THEN CLABEL = C_LABEL; /*RAF-9*/ 01004100
ELSE IF C_LABEL=' ' & LABLEV>0 THEN DO; /*RAF-9*/ 01004110
IF SUBSTR(LABSTK(LABLEV),1,1)='.' & /*RAF-9*/ 01004120
SUBSTR(LABSTK(LABLEV),2,1)^='@' /*RAF-9*/ 01004130
THEN CLABEL = LABSTK(LABLEV); /*RAF-9*/ 01004140
END; /*RAF-9*/ 01004150
/*RAF-9*/ 01004160
RETURN(CLABEL); /*RAF-9*/ 01004170
END CURSEQSYM; /*RAF-9*/ 01004180
1 01004190
/* PROCEDURE TO SCAN FOR STATEMENT IN ASM CONSTRUCT */ /*RAF-9*/ 01004200
/*RAF-9*/ 01004210
ASMSTMNT: PROCEDURE RECURSIVE; /*RAF-9*/ 01004220
/*RAF-9*/ 01004230
DCL ELEV FIXED BIN; /*RAF-9*/ 01004240
/*RAF-9*/ 01004250
CALL ESQUISH; /*RAF-9*/ 01004260
ELEV = EQVLEV+1; /*RAF-9*/ 01004270
CALL STMNT; /*RAF-9*/ 01004280
CALL LABPUSH; /*RAF-9*/ 01004290
CALL LABFLUSH; /*RAF-9*/ 01004300
CALL EQVFLUSH(#FALSE,ELEV); /*RAF-9*/ 01004310
END ASMSTMNT; /*RAF-9*/ 01004320
1 01005000
/* MACRO (&L:) <MACRO NAME> (<PARAMETER LIST>); 01006000
<BODY> 01007000
MEND */ 01008000
01009000
CMACRO: PROCEDURE; 01010000
DCL 01011000
(MLABEL,MNAME) CHAR(8) VARYING, 01012000
(I,L,ELEV) FIXED BIN, /*RAF-8*/ 01013000
DEFTYPE CHAR(8) VARYING, DEFS(7) CHAR(8) VAR 01014000
INIT('GBLA','GBLB','GBLC','LCLA','LCLB','LCLC','COPY'); 01015000
01016000
IN_MACRO = #TRUE; 01017000
MLABEL = ''; 01018000
IF RCHAR('&') THEN 01019000
DO; 01020000
IF ^RCHAR('&') THEN 01021000
CALL ERROR('CMACRO: "&" INSERTED.'); 01022000
CALL RWORD; 01023000
IF WORDAL THEN 01024000
MLABEL = '&'||WORD; 01025000
ELSE 01026000
CALL ERROR('CMACRO: INVALID MACRO LABEL.'); 01027000
IF ^RCHAR(':') THEN 01028000
CALL ERROR('CMACRO: ":" ASSUMED AFTER "'|| 01029000
MLABEL||'".'); 01030000
END; 01031000
CALL RWORD; 01032000
IF WORDAL THEN 01033000
MNAME = WORD; 01034000
ELSE 01035000
DO; 01036000
MNAME = '???'; 01037000
CALL ERROR('CMACRO: MISSING MACRO NAME.'); 01038000
END; 01039000
CALL ROPANDS(#FALSE); /*RAF-9*/ 01040000
IF ^RCHAR(';') THEN 01041000
CALL ERROR('CMACRO: MISSING SEMICOLON INSERTED.'); 01042000
CALL LABPUSH; 01043000
C_DATA = ' '; 01044000
GEN('MACRO',''); 01045000
C_LABEL = MLABEL; 01046000
C_OPERATION = MNAME; 01047000
GEN_OPERANDS(OPANDS); 01048000
1 01049000
NESTLEV = NESTLEV+1; 01050000
NESTID(NESTLEV) = CIN_ID; 01051000
DEFTYPE = '?'; 01052000
DO WHILE(DEFTYPE^=''); 01053000
DEFTYPE = ''; 01054000
DO I=1 TO 7 WHILE(^RCHECK(DEFS(I))); 01055000
END; 01056000
IF I<8 THEN 01057000
DO; 01058000
DEFTYPE,WORD = DEFS(I); 01059000
CALL ALCSTMT; 01060000
IF ^RCHAR(';') THEN 01061000
CALL ERROR('CMACRO: MISSING SEMICOLON INSERTED.'); 01062000
END; 01063000
END; 01064000
GEN('LCLC','&@'); 01065000
C_LABEL = '&@'; 01066000
GEN('SETC','''&SYSNDX'''); 01067000
CALL ESQUISH; /*RAF-8*/ 01067100
ELEV = EQVLEV+1; /*RAF-8*/ 01067200
DO WHILE(IN_MACRO); 01068000
IF RCHECK('MEND') THEN IN_MACRO = #FALSE; /*RAF-8*/ 01068100
ELSE IF RCHECK('ENDMACRO') THEN IN_MACRO = #FALSE; /*RAF-8*/ 01068200
ELSE DO; /*RAF-8*/ 01069000
CALL STMNT; /*RAF-8*/ 01070000
IF ^RCHAR(';') THEN 01071000
CALL ERROR('CMACRO: MISSING SEMICOLON INSERTED.'); 01072000
END; /*RAF-8*/ 01072500
END; 01073000
NESTLEV = NESTLEV-1; 01074000
IF NESTLEV=0 THEN PREDLABLEV=0; /*RAF-6*/ 01074500
CALL LABPUSH; /*RAF-8*/ 01074600
CALL LABFLUSH; /*RAF-8*/ 01074700
CALL EQVFLUSH(#FALSE,ELEV); /*RAF-8*/ 01074800
GEN('MEND',''); /*RAF-8*/ 01074900
RETURN; 01075000
END CMACRO; 01076000
1 01077000
/* BAL; 01078000
<BAL CODING> 01079000
ALP; */ 01080000
01081000
CBAL: 01082000
PROCEDURE; 01083000
DCL 01084000
1 BALCOM STATIC, 01085000
2 ASTR CHAR(3) INIT('* '), /*RAF-45*/ 01086000
2 COMFLD CHAR(69), /*RAF-45*/ 01087000
2 COMID CHAR(8); 01088000
01089000
CALL LABPUSH; 01090000
CALL LABFLUSH; 01091000
INAL = 0; 01092000
DO WHILE(#TRUE) ; 01093000
COL = 80; 01094000
CHAR = ' '; 01095000
CALL RWORD; 01096000
IF WORD = 'ALP' & CHAR = ';' THEN 01097000
DO ; 01098000
INAL = 1 ; 01099000
IF IN_MACRO THEN ASTR='.*'; ELSE ASTR='*'; /*RAF-45*/ 01099500
COMFLD = SUBSTR(CARDIN,1,69) ; /*RAF-45*/ 01100000
COMID = CIN_ID ; 01101000
WRITE FILE(SYSOUT) FROM(BALCOM) ; 01102000
RETURN ; 01103000
END ; 01104000
WRITE FILE(SYSOUT) FROM (CARDIN); 01105000
END; 01106000
END CBAL ; 01107000
1 01107010
/* COMMENT; */ /*RAF-10*/ 01107020
/* <TEXT OF COMMENT> */ /*RAF-10*/ 01107030
/* ALP; */ /*RAF-10*/ 01107040
/*RAF-10*/ 01107050
CCOMMENT: PROCEDURE; /*RAF-10*/ 01107060
/*RAF-10*/ 01107070
DCL /*RAF-10*/ 01107080
1 BALCOM STATIC, /*RAF-10*/ 01107090
2 ASTR CHAR(2) INIT('* '), /*RAF-10*/ 01107100
2 COMFLD CHAR(70), /*RAF-10*/ 01107110
2 COMID CHAR(8); /*RAF-10*/ 01107120
/*RAF-10*/ 01107130
CALL LABPUSH; CALL LABFLUSH; /*RAF-10*/ 01107140
INAL = 0; /*RAF-10*/ 01107150
DO WHILE(#TRUE); /*RAF-10*/ 01107160
COL = 80; CHAR = ' '; /*RAF-10*/ 01107170
CALL RWORD; /*RAF-10*/ 01107180
/*RAF-10*/ 01107190
COMFLD = SUBSTR(CARDIN,1,70); /*RAF-10*/ 01107200
COMID = CIN_ID; /*RAF-10*/ 01107210
WRITE FILE(SYSOUT) FROM(BALCOM); /*RAF-10*/ 01107220
/*RAF-10*/ 01107230
IF WORD='ALP' & CHAR=';' THEN DO; /*RAF-10*/ 01107240
INAL = 1; /*RAF-10*/ 01107250
RETURN; /*RAF-10*/ 01107260
END; /*RAF-10*/ 01107270
END; /*RAF-10*/ 01107280
/*RAF-10*/ 01107290
END CCOMMENT; /*RAF-10*/ 01107300
1 /*RAF-36*/ 01107310
/* DATA <STATEMENT> */ /*RAF-36*/ 01107320
/*RAF-36*/ 01107330
CDATA: PROCEDURE RECURSIVE; /*RAF-36*/ 01107340
DCL AROUND CHAR(8) VARYING; /*RAF-36*/ 01107350
/*RAF-36*/ 01107360
AROUND = GENSYM; /*RAF-36*/ 01107370
GEN('B',AROUND); /*RAF-36*/ 01107380
CALL STMNT; /*RAF-36*/ 01107390
CALL WLABEL(AROUND); /*RAF-36*/ 01107400
END CDATA; /*RAF-36*/ 01107410
1 01108000
/* SELECT; 01109000
<SELECT LIST> 01110000
ENDSEL */ 01111000
01112000
CSELECT: 01113000
PROCEDURE RECURSIVE; 01114000
DECLARE 01115000
(CASEBODY,NEXTCASE,CLABELB,CLABELE) CHAR(8) VARYING, 01116000
EXIT CHAR(8) VARYING, /*RAF-8*/ 01116500
(CHKFIRST,SELEND) BIT(1); 01117000
01118000
CALL SWLABEL(CLABELB); 01119000
DOLEV = DOLEV+1; 01120000
DOID(DOLEV) = CLABELB; 01121000
DOLABEL(DOLEV) = CURLAB; 01122000
NESTLEV = NESTLEV+1; 01123000
NESTID(NESTLEV) = CIN_ID; 01124000
01125000
CHKFIRST = RCHECK('FIRST'); 01126000
IF CHKFIRST THEN 01127000
CLABELE = GENSYM; 01128000
ELSE 01129000
CLABELE = ''; 01130000
EXID(DOLEV) = ''; /*RAF-8*/ 01131000
IF ^RCHAR(';') THEN 01132000
CALL ERROR('CSELECT: MISSING SEMICOLON INSERTED.'); 01133000
01134000
NEXTCASE = ''; /*RAF-4*/ 01134900
SELEND = RCHECK('ENDSEL'); 01135000
DO WHILE(^SELEND); 01136000
CASEBODY = ''; 01137000
NEXTCASE = GENSYM; 01138000
CALL PREDICATE(CASEBODY,NEXTCASE,@OUTER_PREDICATE,#DUMMY, 01139000
@USE_TRUTH,#DUMMY,@B); 01140000
IF ^RCHAR(':') THEN 01141000
CALL ERROR('CSELECT: MISSING COLON INSERTED.'); 01142000
CALL STMNT; 01143000
IF ^RCHAR(';') THEN 01144000
CALL ERROR('CSELECT: MISSING SEMICOLON INSERTED.'); 01145000
SELEND = RCHECK('ENDSEL'); 01146000
IF CHKFIRST & ^SELEND THEN 01147000
GEN('B',CLABELE); 01148000
IF ^SELEND THEN 01149000
CALL WLABEL(NEXTCASE); 01150000
END; /*RAF-4*/ 01151000
1 01152000
NESTLEV = NESTLEV-1; /*RAF-8*/ 01152500
IF RCHECK('ELSE') THEN 01153000
DO; 01154000
IF ^CHKFIRST THEN 01155000
CALL ERROR('CSELECT: "ELSE" ILLEGAL WITHOUT "FIRST"'|| 01156000
' OPTION ON "SELECT" STATEMENT'); 01157000
IF NEXTCASE^='' THEN DO; /*RAF-4*/ 01157500
IF CLABELE='' THEN /*RAF-8*/ /*RAF-4*/ 01158000
CLABELE = GENSYM; /*RAF-8*/ /*RAF-4*/ 01159000
GEN('B',CLABELE); /*RAF-8*/ /*RAF-4*/ 01160000
CALL WLABEL(NEXTCASE); /*RAF-4*/ 01161000
END; /*RAF-4*/ 01161500
CALL STMNT; 01162000
END; 01163000
ELSE 01164000
CALL CWLABEL(NEXTCASE); 01165000
01166000
EXIT = EXID(DOLEV); /*RAF-8*/ 01166100
DOLEV = DOLEV-1; /*RAF-8*/ 01166200
CALL CWLABEL(CLABELE); /*RAF-8*/ 01166300
IF RCHECK('THEN') THEN CALL STMNT; /*RAF-8*/ 01166400
CALL CWLABEL(EXIT); /*RAF-8*/ 01167000
/* DOLEV = DOLEV-1; */ /*RAF-8*/ 01168000
/* NESTLEV = NESTLEV-1; */ /*RAF-8*/ 01169000
IF NESTLEV=0 THEN PREDLABLEV=0; /*RAF-6*/ 01169500
RETURN; 01170000
END CSELECT; 01171000
1 01172000
ALCSTMT: PROCEDURE; 01173000
DCL 01174000
( BLANKS72 CHAR(72) INIT(' '), 01175000
L FIXED BIN, 01176000
TLABEL CHAR(8) ) STATIC; 01177000
DCL 01178000
SPECOPS(39) CHAR(8) VAR STATIC INIT( 01179000
'DC','DS','CSECT','DSECT','COM', 01180000
'TITLE','LTORG','CNOP', 01181000
'DROP','USING','ENTRY', 01182000
'SUBTITLE','PRINT','EJECT','SPACE', 01183000
'ICTL','ISEQ','PUNCH','REPRO', 01184000
'ORG','COPY','END', 01185000
'MACRO','MEND','MNOTE','AIF','ANOP','AGO','ACTR','MEXIT', 01186000
'GBLA','GBLB','GBLC','LCLA','LCLB','LCLC','SETA','SETB','SETC' 01187000
); 01188000
01189000
IF C_LABEL=' ' & LABLEV>0 THEN 01190000
DO; 01191000
C_LABEL = LABSTK(LABLEV); 01192000
LABLEV = LABLEV-1; 01193000
END; 01194000
IF C_LABEL^=' ' THEN 01195000
DO; 01196000
DO L=39 TO 1 BY -1 WHILE(WORD^=SPECOPS(L)); 01197000
END; 01198000
IF (L>0 & SUBSTR(C_LABEL,1,1)='@') | 01199000
(L>8 & SUBSTR(C_LABEL,1,1)^='&') THEN 01200000
CALL LABPUSH; 01201000
END; 01202000
TLABEL = C_LABEL; 01203000
CALL ROPANDS(#FALSE); /*RAF-9*/ 01204000
IF WORD ^= 'CC' THEN 01205000
DO ; 01206000
C_OPERATION = WORD ; 01207000
IF IN_MACRO THEN 01208000
/* IF C_OPERATION = 'MEND' THEN */ /*RAF-8*/ 01209000
/* IN_MACRO = #FALSE; */ /*RAF-8*/ 01210000
/* ELSE */ /*RAF-8*/ 01211000
IF C_OPERATION = 'SPACE' THEN 01212000
DO; 01213000
C_DATA = '.*'; 01214000
OPANDS = ''; 01215000
END; 01216000
01217000
IF WORD='SUBTITLE' THEN 01218000
DO; 01219000
C_OPERATION = 'TITLE' ; 01220000
SUBTITL = #TRUE; 01221000
SUBTITLE = SUBSTR(BLANKS72,1,(73-LENGTH(OPANDS)-2)/2) 01222000
||SUBSTR(OPANDS,2,LENGTH(OPANDS)-2); 01223000
END; 01224000
01225000
GEN_OPERANDS(OPANDS); 01226000
END ; 01227000
1 01228000
IF WORD = 'SPACE' THEN 01229000
PUT SKIP(2) FILE(SYSPRINT); 01230000
ELSE 01231000
IF WORD='TITLE' | WORD='EJECT' THEN 01232000
DO; 01233000
IF WORD='TITLE' THEN 01234000
DO; 01235000
DECKNAME = TLABEL; 01236000
TITLE = SUBSTR(BLANKS72,1,(73-LENGTH(OPANDS)-2)/2) 01237000
||SUBSTR(OPANDS,2,LENGTH(OPANDS)-2); 01238000
END; 01239000
SIGNAL ENDPAGE(SYSPRINT); 01240000
END; 01241000
INAL = 1 ; 01242000
RETURN; 01243000
END ALCSTMT; 01244000
1 01245000
/* GENERATE CODE FOR PREDICATES */ 01246000
PREDICATE: 01247000
PROCEDURE(THRULABEL,BRLABEL,OUTER,PREDFOUND,GLOBALNEG,HANGNOT,BTYPE) 01248000
RECURSIVE; 01249000
01250000
/* THRULABEL = FALL-THROUGH LABEL 01251000
BRLABEL = BRANCH LABEL 01252000
OUTER=#TRUE => PREDICATE IS AN OUTER ONE 01253000
PREDFOUND => SET IF WE FIND WE ARE IN A PREDICATE, ELSE FALSE 01254000
GLOBALNEG=#TRUE => GLOBAL NEGATION OF PREDICATE 01255000
BTYPE=#TRUE => BR FORM */ 01256000
01257000
DCL (THRULABEL,BRLABEL) CHAR(*) VARYING, 01258000
(OUTER,PREDFOUND,GLOBALNEG,HANGNOT,BTYPE) BIT(1); 01259000
DCL (BTRUTH,PREDNEST,ANDFLG,ORFLG) BIT(1), 01260000
(THRULAB,BRLAB) CHAR(8) VARYING, 01261000
PREDID CHAR(8); 01262000
01263000
PREDFOUND = #FALSE; 01264000
THRULAB,BRLAB = ''; 01265000
01266000
BTRUTH = ^GLOBALNEG; 01267000
DO WHILE(RCHAR('^')); 01268000
BTRUTH = ^BTRUTH; 01269000
PREDFOUND = #TRUE; 01270000
END; 01271000
01272000
IF ^RCHAR('<') THEN 01273000
CALL STMNT; 01274000
ELSE 01275000
DO; 01276000
NESTLEV = NESTLEV+1; NESTID(NESTLEV) = CIN_ID; /*RAF-28*/ 01276500
PREDID = CIN_ID; 01277000
CALL PREDICATE(THRULAB,BRLAB,@INNER_PREDICATE,PREDNEST, 01278000
^BTRUTH,HANGNOT,BTYPE); 01279000
IF ^PREDNEST THEN 01280000
DO; 01281000
IF RCHAR(';') THEN 01282000
DO; 01283000
NESTLEV = NESTLEV-1; /*RAF-28*/ 01283500
CALL GROUP(#FALSE,PREDID); 01284000
GOTO PREDTST; 01285000
END; 01286000
ELSE 01287000
IF ^RCHAR('>') THEN 01288000
DO; 01289000
CALL ERROR('CPRED: MISSING SEMICOLON INSERTED.');01290000
NESTLEV = NESTLEV-1; /*RAF-28*/ 01290500
CALL GROUP(#FALSE,PREDID); 01291000
GOTO PREDTST; 01292000
END; 01293000
ELSE DO; /*RAF-28*/ 01293100
NESTLEV = NESTLEV-1; /*RAF-28*/ 01293200
IF NESTLEV=0 THEN PREDLABLEV=0; /*RAF-28*/ 01293300
END; /*RAF-28*/ 01293400
END; 01294000
ELSE 01295000
DO; 01296000
PREDFOUND = #TRUE; 01297000
IF ^RCHAR('>') THEN 01298000
CALL ERROR('CPRED: MISSING ">" INSERTED.'); 01299000
ELSE DO; /*RAF-28*/ 01299100
NESTLEV = NESTLEV-1; /*RAF-28*/ 01299200
IF NESTLEV=0 THEN PREDLABLEV=0; /*RAF-28*/ 01299300
END; /*RAF-28*/ 01299400
END; 01300000
END; 01301000
1 01302000
PREDTST: 01303000
ANDFLG,ORFLG = #FALSE; 01304000
IF RCHAR('&') THEN 01305000
IF GLOBALNEG THEN ORFLG = #TRUE; 01306000
ELSE ANDFLG = #TRUE; 01307000
ELSE 01308000
IF RCHAR('|') THEN 01309000
IF GLOBALNEG THEN ANDFLG = #TRUE; 01310000
ELSE ORFLG = #TRUE; 01311000
IF ANDFLG THEN 01312000
DO; 01313000
PREDFOUND = #TRUE; 01314000
CALL GB(^XOR(BTRUTH,HANGNOT),BRLABEL,BTYPE); 01315000
HANGNOT = #FALSE; 01316000
CALL EQU(BRLAB,BRLABEL); 01317000
CALL CWLABEL(THRULAB); 01318000
CALL PREDICATE(THRULABEL,BRLABEL,OUTER,#DUMMY,GLOBALNEG,HANGNOT, 01319000
BTYPE); 01320000
END; 01321000
ELSE 01322000
IF ORFLG THEN 01323000
DO; 01324000
PREDFOUND = #TRUE; 01325000
CALL GB(XOR(BTRUTH,HANGNOT),THRULABEL,BTYPE); 01326000
HANGNOT = #FALSE; 01327000
CALL EQU(THRULAB,THRULABEL); 01328000
CALL CWLABEL(BRLAB); 01329000
CALL PREDICATE(THRULABEL,BRLABEL,OUTER,#DUMMY,GLOBALNEG, 01330000
HANGNOT,BTYPE); 01331000
END; 01332000
ELSE 01333000
DO; 01334000
IF THRULABEL='' & THRULAB^='' THEN 01335000
DO; 01336000
THRULABEL = THRULAB; 01337000
THRULAB = ''; 01338000
END; 01339000
IF BRLABEL='' & BRLAB^='' THEN 01340000
DO; 01341000
BRLABEL = BRLAB; 01342000
BRLAB = ''; 01343000
END; 01344000
CALL EQU(THRULAB,THRULABEL); 01345000
CALL EQU(BRLAB,BRLABEL); 01346000
IF OUTER THEN 01347000
DO; 01348000
CALL GB(^XOR(BTRUTH,HANGNOT),BRLABEL,BTYPE); 01349000
HANGNOT = #FALSE; 01350000
CALL CWLABEL(THRULABEL); 01351000
END; 01352000
ELSE 01353000
HANGNOT = HANGNOT | XOR(BTRUTH,^GLOBALNEG); 01354000
END; 01355000
01356000
RETURN; 01357000
1 01358000
EQU: PROCEDURE(L1,L2); 01359000
DCL (L1,L2) CHAR(*) VARYING; 01360000
DCL ( (I,PREVOP) FIXED BIN, 01361000
REG_DISP BIT(1) ) STATIC; 01362000
01363000
PREVOP = 0; 01364000
IF L2^='' THEN IF SUBSTR(L2,LENGTH(L2),1)=')' THEN /*RAF-3*/ 01365000
DO I=1 TO LENGTH(L2); 01366000
IF SUBSTR(L2,I,1)='(' & PREVOP=0 THEN 01367000
DO; 01368000
REG_DISP = #TRUE; 01369000
GOTO PREDLABCHK; 01370000
END; 01371000
PREVOP = INDEX('+-*/',SUBSTR(L2,I,1)); 01372000
END; 01373000
REG_DISP = #FALSE; 01374000
01375000
PREDLABCHK: 01376000
DO I=PREDLABLEV TO 1 BY -1 WHILE(L1^=PREDLABSTK(I,2)); 01377000
END; 01378000
IF I>0 THEN 01379000
REG_DISP = PREDBTYPE(I)='R'; 01380000
IF I=0 | ^REG_DISP THEN 01381000
DO; 01382000
IF L1^='' & L2^='' THEN 01383000
CALL EQVADD((L1),(L2)); 01384000
END; 01385000
ELSE 01386000
DO; 01387000
CALL WLABEL(L1); 01388000
GEN('DS','0H'); 01389000
GEN('ORG',PREDLABSTK(I,1)||'+2'); 01390000
IF PREDBTYPE(I)='R' THEN 01391000
GEN('DC','S(0('||L2||'))'); 01392000
ELSE 01393000
GEN('DC','S('||L2||')'); 01394000
GEN('ORG',L1); 01395000
END; 01396000
01397000
IF I>0 THEN 01398000
DO; 01399000
DO I=I+1 TO PREDLABLEV; 01400000
PREDLABSTK(I-1,1) = PREDLABSTK(I,1); 01401000
PREDLABSTK(I-1,2) = PREDLABSTK(I,2); 01402000
END; 01403000
PREDLABLEV = PREDLABLEV-1; 01404000
END; 01405000
RETURN; 01406000
END EQU; 01407000
01408000
XOR: PROCEDURE(B1,B2) RETURNS(BIT(1)); 01409000
DCL (B1,B2) BIT(1); 01410000
RETURN((B1 & ^B2) | (^B1 & B2)); 01411000
END XOR; 01412000
01413000
/* END PREDICATE; */ /*RAF-6*/ 01414000
1 01415000
GB: 01416000
PROCEDURE (B,LABLST,BRT); 01417000
/* GENERATE CONDITIONAL BRANCH (ON TRUTH IF B) TO LABLST */ 01418000
DCL 01419000
(B,BRT) BIT(1), 01420000
LABLST CHAR(*) VARYING; 01421000
DCL 01422000
LABLADDR CHAR(8) VARYING STATIC, /*RAF-41*/ 01423000
(I,J) FIXED BIN STATIC, /*RAF-41*/ 01424000
CCCODE CHAR(8) STATIC, /*RAF-41*/ 01425000
CCODE FIXED BIN STATIC; /*RAF-41*/ 01426000
/*RAF-41*/ 01426100
CCODE = 0; /*RAF-41*/ 01426200
01427000
IF LABLST='' THEN 01428000
DO; 01429000
CALL SWLABEL(LABLADDR); 01430000
PREDLABLEV = PREDLABLEV+1; 01431000
PREDLABSTK(PREDLABLEV,1) = LABLADDR; 01432000
LABLST = GENSYM; 01433000
PREDLABSTK(PREDLABLEV,2) = LABLST; 01434000
IF BRT THEN 01435000
PREDBTYPE(PREDLABLEV) = 'R'; 01436000
ELSE 01437000
PREDBTYPE(PREDLABLEV) = ''; 01438000
END; 01439000
01440000
IF WORD = 'CC' THEN 01441000
DO; 01442000
IF LENGTH(OPANDS)>8 THEN 01443000
CALL ERROR('GB: CONDITION CODE STRING TOO LONG.'); 01444000
CCCODE = OPANDS; 01445000
END; 01446000
ELSE 01447000
DO; 01448000
DO I = 1 TO 17 WHILE(PREDICATES(I,1) ^= WORD); 01449000
END; 01450000
CCCODE = PREDICATES(I,2); 01451000
END; 01452000
1 01453000
/* CCCODE IS NOW A SET OF MNEMONIC COND CODE CHARACTERS */ 01454000
DO I = 1 TO 8; /* FOR EACH CHAR .. */ 01455000
J = INDEX(CCTAB.LET, SUBSTR(CCCODE, I, 1)); 01456000
IF J = 0 THEN 01457000
CALL 01458000
ERROR('UNDEF COND CODE CHAR: ' || SUBSTR(CCCODE,I,1) ); 01459000
ELSE 01460000
CCODE = CCODE+CCTAB.IVAL(J); 01461000
END; 01462000
IF INDEX(CCCODE, 'N') | INDEX(CCCODE,'^') THEN 01463000
CCODE = 15-CCODE; 01464000
IF ^B THEN 01465000
CCODE = 15-CCODE; 01466000
SUBSTR(CARDOUT,10,10) = OPTAB(CCODE+1); 01467000
IF BRT & SUBSTR(LABLST,1,1)^='@' THEN 01468000
IF SUBSTR(C_OPERATION,3,1)=' ' THEN 01469000
SUBSTR(C_OPERATION,3,1)='R'; 01470000
ELSE 01471000
SUBSTR(C_OPERATION,4,1)='R'; 01472000
C_OPERANDS = LABLST; 01473000
CALL WFLUSH; 01474000
RETURN; 01475000
01476000
END GB; 01477000
END PREDICATE; /*RAF-6*/ 01477500
1 01478000
/* WRITE LABEL */ 01479000
WLABEL: 01480000
PROCEDURE (ALABL); 01481000
DCL 01482000
ALABL CHAR(*) VARYING; 01483000
DCL 01484000
I FIXED BIN STATIC; 01485000
01486000
GOTO WLABELX; 01487000
0 01488000
SWLABEL: 01489000
ENTRY(ALABL); 01490000
01491000
IF C_LABEL ^= ' ' THEN 01492000
ALABL = C_LABEL; 01493000
ELSE 01494000
IF LABLEV>0 THEN 01495000
ALABL = LABSTK(LABLEV); 01496000
ELSE 01497000
ALABL = ''; 01498000
IF ALABL^='' THEN IF SUBSTR(ALABL,1,1)^='.' THEN /*RAF-3*/ 01499000
RETURN; 01500000
/* ELSE */ /*RAF-3*/ 01501000
DO; 01502000
ALABL = GENSYM; 01503000
GOTO WLABELX; 01504000
END; 01505000
0 01506000
CWLABEL: 01507000
ENTRY(ALABL); 01508000
01509000
IF ALABL='' THEN RETURN; 01510000
0 01511000
WLABELX: IF C_LABEL ^= ' ' THEN 01512000
DO; /* LABEL ALREADY IN BUFFER */ 01513000
LABLEV = LABLEV+1; 01514000
LABSTK(LABLEV) = C_LABEL; 01515000
END; 01516000
DO I = 1 TO EQVLEV; 01517000
IF EQVSTK(I,2) = ALABL THEN 01518000
DO; 01519000
LABLEV = LABLEV+1; 01520000
LABSTK(LABLEV) = EQVSTK(I,1); 01521000
EQVSTK(I,*) = ''; 01522000
END; 01523000
END; 01524000
C_LABEL = ALABL ; 01525000
IF COL_1^='&' & COL_1^='.' THEN /*RAF-12*/ 01526000
DO; 01527000
SYMLEV = SYMLEV+1; 01528000
SYMSTK(SYMLEV) = ALABL; 01529000
END; 01530000
CALL PERPUSH; 01531000
RETURN; 01532000
END WLABEL ; 01533000
1 01534000
/* FLUSH OUTPUT LINE */ 01535000
WFLUSH: 01536000
PROCEDURE ; 01537000
DCL ( (I,J) FIXED BIN, 01538000
(FLUSH,LAST_WAS_BRANCH,NOWRITE) BIT(1), 01539000
TLABEL CHAR(8) VARYING, 01540000
CH CHAR(1) ) STATIC; 01541000
01542000
IF C_OPERATION='ANOP' & C_LABEL='' THEN RETURN; /*RAF-29*/ 01542100
/*RAF-29*/ 01542200
LAST_WAS_BRANCH = BRANCH_LAST; 01543000
BRANCH_LAST,NOWRITE = #FALSE; 01544000
IF REQFLUSH(C_OPERATION) THEN 01545000
DO; 01546000
FLUSH = #TRUE; 01547000
IF C_OPERATION = 'B' THEN 01548000
DO; 01549000
DO I = 1 TO 52 /*RAF-41*/ 01550000
WHILE(ALPHANUM(SUBSTR(C_OPERANDS,I,1))); /*RAF-41*/ 01550100
END; 01551000
CH = SUBSTR(C_OPERANDS,I,1); 01552000
IF (I>1 & I<=9) & 01553000
(CH = ' ' | CH = ';' | CH = '%' | CH = '>') THEN 01554000
DO; /* BRANCH TO SIMPLE LABEL */ 01555000
FLUSH = #FALSE; 01556000
BRANCH_LAST = #TRUE; 01557000
IF C_LABEL = ' ' & LABLEV>0 THEN DO; /*RAF-2*/ 01557100
C_LABEL = LABSTK(LABLEV); /*RAF-2*/ 01557200
LABLEV = LABLEV-1; /*RAF-2*/ 01557300
END; /*RAF-2*/ 01557400
IF C_LABEL ^= ' ' & (^IN_MACRO /*RAF-43*/ 01558000
| SUBSTR(C_OPERANDS,1,1)='@') /*RAF-43*/ 01558500
THEN DO; /*RAF-43*/ 01559000
LABLEV = LABLEV+1; 01560000
LABSTK(LABLEV) = C_LABEL; 01561000
TLABEL = SUBSTR(C_OPERANDS,1,I-1); 01562000
DO I=LABLEV TO 1 BY -1 01563000
WHILE(LABSTK(I)^=TLABEL); 01564000
END; 01565000
IF I>0 THEN 01566000
DO; 01567000
LABLEV = LABLEV-1; 01568000
CALL LABFLUSH; 01569000
END; 01570000
ELSE 01571000
DO; 01572000
C_LABEL = ' '; 01573000
DO J = 1 TO LABLEV; 01574000
CALL EQVADD((LABSTK(J)),(TLABEL)); 01575000
END; 01576000
LABLEV = 0; 01577000
END; 01578000
END; 01579000
NOWRITE = LAST_WAS_BRANCH & ^LABEL_WRITTEN ; 01580000
END; 01581000
END; 01582000
IF FLUSH THEN 01583000
CALL LABFLUSH; 01584000
END; 01585000
1 01586000
IF ^NOWRITE THEN 01587000
WRITE FILE(SYSOUT) FROM(CARDOUT) ; 01588000
LABEL_WRITTEN = #FALSE; 01589000
C_DATA = ' '; 01590000
IF INAL = 2 THEN 01591000
INAL = 1 ; 01592000
RETURN; 01593000
01594000
/* PROCEDURE TO SIGNAL WHEN STACK FLUSH IS REQUIRED */ 01595000
REQFLUSH: PROC(OPCODE) RETURNS(BIT(1)); 01596000
DCL OPCODE CHAR(8); 01597000
DCL I FIXED BIN STATIC, 01598000
NOFLUSH(26) CHAR(8) STATIC INIT( 01599000
' ','DROP','USING','EQU', 01600000
'TITLE','SUBTITLE','PRINT','EJECT','SPACE', 01601000
'ICTL','ISEQ','PUNCH', 01602000
'MNOTE','AIF','ANOP','AGO','ACTR', 01603000
'GBLA','GBLB','GBLC','LCLA','LCLB','LCLC','SETA','SETB','SETC' 01604000
); 01605000
01606000
DO I=1 TO 26; 01607000
IF OPCODE=NOFLUSH(I) THEN RETURN(#FALSE); 01608000
END; 01609000
RETURN(#TRUE); 01610000
END REQFLUSH; 01611000
END WFLUSH ; 01612000
1 01613000
/* FLUSH LABEL EQUIVALENCING STACK */ 01614000
EQVFLUSH: 01615000
PROCEDURE(LEVZ,ELEVL); 01616000
DCL 01617000
LEVZ BIT(1), 01618000
ELEVL FIXED BIN, 01619000
I FIXED BIN STATIC; /*RAF-41*/ 01619500
DCL 01620000
EQVBUF CHAR(80) STATIC INIT(' EQU') UNALIGNED, /*RAF-46*/ 01621000
E_LABEL CHAR(8) POS(1) DEF EQVBUF UNALIGNED, /*RAF-46*/ 01622000
E_OPERAND CHAR(61) POS(20) DEF EQVBUF UNALIGNED; /*RAF-46*/ 01623000
IF EQVLEV>0 THEN 01624000
DO; 01625000
DO I = ELEVL TO EQVLEV; 01626000
E_LABEL = EQVSTK(I,1); 01627000
IF E_LABEL ^= ' ' THEN 01628000
DO; 01629000
E_OPERAND = EQVSTK(I,2); 01630000
/* IF ((SUBSTR(E_OPERAND,1,1)='@') | */ /*RAF-12*/ 01631000
/* (SUBSTR(E_OPERAND,1,1)^='@' & */ /*RAF-12*/ 01632000
IF LEVZ | SYMDEF(EQVSTK(I,2)) THEN /*RAF-12*/ 01633000
DO; 01634000
EQVSTK(I,*) = ''; 01635000
WRITE FILE(SYSOUT) FROM(EQVBUF); 01636000
END; 01637000
END; 01638000
END; 01639000
IF LEVZ THEN 01640000
EQVLEV = 0; 01641000
END; 01642000
RETURN; 01643000
01644000
SYMDEF: PROCEDURE(SYMBOL) RETURNS(BIT(1)); 01645000
DCL SYMBOL CHAR(*) VARYING; 01646000
DCL I FIXED BIN STATIC; 01647000
01648000
DO I=SYMLEV TO 1 BY -1; 01649000
IF SYMSTK(I)=SYMBOL THEN RETURN(#TRUE); 01650000
END; 01651000
RETURN(#FALSE); 01652000
END SYMDEF; 01653000
01654000
END EQVFLUSH; 01655000
1 01656000
LABFLUSH: PROCEDURE; 01657000
DCL 01658000
I FIXED BIN STATIC, 01659000
FLUSHBUF CHAR(80) STATIC UNALIGNED /*RAF-46*/ 01660000
INIT(' DS 0H'), /*RAF-46*/ 01660100
F_LABEL CHAR(8) POS(1) DEF FLUSHBUF UNALIGNED, /*RAF-46*/ 01661000
F_ID CHAR(8) POS(73) DEF FLUSHBUF UNALIGNED; /*RAF-46*/ 01662000
01663000
F_ID = CIN_ID; 01664000
IF LABLEV>0 THEN 01665000
DO; 01666000
LABEL_WRITTEN = #TRUE; 01667000
DO I = 1 TO LABLEV; 01668000
F_LABEL = LABSTK(I); 01669000
WRITE FILE(SYSOUT) FROM(FLUSHBUF); 01670000
END; 01671000
LABLEV = 0; 01672000
END; 01673000
RETURN; 01674000
END LABFLUSH; 01675000
1 01676000
/* PUSH NON-SEQUENCE LABELS */ 01677000
LABPUSH: PROCEDURE; 01678000
DCL 01679000
(I,J) FIXED BIN STATIC, /*RAF-41*/ 01680000
SEQBUF CHAR(80) STATIC INIT(' ANOP') UNAL, /*RAF-46*/ 01681000
S_LABEL CHAR(8) POS(1) DEF SEQBUF UNALIGNED, /*RAF-46*/ 01682000
S_ID CHAR(8) POS(73) DEF SEQBUF UNALIGNED, /*RAF-46*/ 01683000
S_COL1 CHAR(1) POS(1) DEF SEQBUF UNALIGNED; /*RAF-46*/ 01684000
01685000
IF C_LABEL^=' ' & SUBSTR(C_LABEL,1,1)^='.' THEN 01686000
DO; 01687000
LABLEV = LABLEV+1; 01688000
LABSTK(LABLEV) = C_LABEL; 01689000
C_LABEL = ''; 01690000
END; 01691000
01692000
PERPUSH: ENTRY; 01693000
IF LABLEV>0 THEN 01694000
DO; 01695000
S_ID = CIN_ID; 01696000
J = 0; 01697000
DO I=1 TO LABLEV; 01698000
S_LABEL = LABSTK(I); 01699000
IF S_COL1='.' THEN 01700000
WRITE FILE(SYSOUT) FROM(SEQBUF); 01701000
ELSE 01702000
DO; 01703000
J = J+1; 01704000
LABSTK(J) = LABSTK(I); 01705000
END; 01706000
END; 01707000
IF LABLEV^=J THEN 01708000
DO; 01709000
LABLEV = J; 01710000
LABEL_WRITTEN = #TRUE; 01711000
END; 01712000
END; 01713000
RETURN; 01714000
END LABPUSH; 01715000
0 01716000
/* GENERATE A LABEL SYMBOL */ 01717000
GENSYM: PROCEDURE RETURNS(CHAR(8) VARYING); 01718000
GENNUM = GENNUM+1; 01719000
IF IN_MACRO THEN 01720000
RETURN('@&@.'||SUBSTR(GENNUM,6)); 01721000
ELSE 01722000
RETURN('@'||SUBSTR(GENNUM,5)); 01723000
01724000
/* GENERATE A SEQUENCE SYMBOL */ 01725000
GENSEQSYM: ENTRY RETURNS(CHAR(8) VARYING); 01726000
GENNUM = GENNUM+1; 01727000
RETURN('.@'||SUBSTR(GENNUM,5)); 01728000
01729000
END GENSYM; 01730000
1 01731000
/* PROCEDURE TO ADD A LABEL AND TARGET TO THE EQUIVALENCING STACK */ 01732000
EQVADD: PROCEDURE(EQLABEL,EQTARGET); 01733000
DCL (EQLABEL,EQTARGET) CHAR(*) VARYING; 01734000
DCL I FIXED BIN STATIC, /*RAF-41*/ 01735000
HIT BIT(1) STATIC; /*RAF-41*/ 01736000
01737000
HIT = #FALSE; /*RAF-41*/ 01737500
DO I=1 TO EQVLEV; 01738000
IF EQVSTK(I,1)='' THEN 01739000
DO; 01740000
IF ^HIT THEN 01741000
DO; 01742000
HIT = #TRUE; 01743000
EQVSTK(I,1) = EQLABEL; 01744000
EQVSTK(I,2) = EQTARGET; 01745000
END; 01746000
END; 01747000
ELSE 01748000
DO; 01749000
IF EQVSTK(I,2)=EQLABEL THEN 01750000
EQVSTK(I,2) = EQTARGET; 01751000
IF EQTARGET=EQVSTK(I,1) THEN 01752000
EQTARGET = EQVSTK(I,2); 01753000
END; 01754000
END; 01755000
IF ^HIT THEN 01756000
DO; 01757000
EQVLEV = EQVLEV+1; 01758000
EQVSTK(I,1) = EQLABEL; 01759000
EQVSTK(I,2) = EQTARGET; 01760000
END; 01761000
RETURN; 01762000
01763000
END EQVADD; 01764000
1 01765000
/* INPUT: */ /* ALP INPUT ROUTINES */ /*RAF-41*/ 01766000
/* PROCEDURE ; */ /*RAF-41*/ 01767000
01768000
/* 01769000
RWORD READ WORD INTO 'WORD' 01770000
SKIP,INC 01771000
ALPHANUM 01772000
RLABEL READ LABEL INTO 'WORD' 01773000
SKIP,INC 01774000
ALPHANUM 01775000
ROPANDS READ OPERANDS INTO 'OPANDS' 01776000
SKIP,INC 01777000
RCHAR('C') READ CHAR IF IT IS 'C' 01778000
SKIP,INC 01779000
RCHECK(CHKWORD) READ 'CHKWORD' IF PRESENT 01780000
SKIP,INC 01781000
ALPHANUM 01782000
*/ 01783000
01784000
/*DECLARE */ /*RAF-41*/ 01785000
/* STARTCOL FIXED BIN STATIC, */ /*RAF-41*/ 01786000
/* I FIXED BIN STATIC; */ /*RAF-41*/ 01787000
1 01788000
RWORD: PROCEDURE; /*RAF-41*/ 01789000
/* READ NEXT TOKEN INTO 'WORD'. A TOKEN IS A SINGLE 01790000
SPECIAL CHARACTER OR 1-8 ALPHANUMERICS. 'WORDAL' 01791000
IS SET TO #TRUE IFF 'WORD' IS ALPHANUMERIC. */ 01792000
DCL (STARTCOL,I) FIXED BIN STATIC; /*RAF-41*/ 01792500
CALL SKIP; 01793000
IF COL<71 & SUBSTR(CARDIN,COL,2)='&&' 01794000
& ALPHANUM(SUBSTR(CARDIN,COL+2,1)) THEN 01795000
DO; 01796000
COL = COL+1 ; 01797000
CHAR = 'A' ; 01798000
END; 01799000
IF ^ALPHANUM(CHAR) THEN 01800000
DO ; /* WORD IS NOT ALPHANUMERIC */ 01801000
WORD = CHAR ; 01802000
IF CHAR ^= ';' THEN 01803000
CALLINC; 01804000
WORDAL = #FALSE ; 01805000
END; 01806000
ELSE 01807000
DO ; 01808000
WORDAL = #TRUE ; /* WORD IS ALPHANUMERIC */ 01809000
STARTCOL = COL ; 01810000
DO I = 0 BY 1 WHILE(ALPHANUM(CHAR)) ; 01811000
CALLINC; 01812000
END; 01813000
WORD = SUBSTR(CARDIN,STARTCOL,I) ; 01814000
IF I>8 & INAL^=0 THEN /*RAF-10*/ 01815000
CALL ERROR('RW40: TOO MANY CHARACTERS IN WORD "'|| 01816000
SUBSTR(CARDIN,STARTCOL,I)||'".'); 01817000
END; 01818000
RETURN; 01819000
END RWORD; /*RAF-41*/ 01819500
1 01820000
RLABEL: PROCEDURE; /*RAF-41*/ 01821000
/* SCAN OFF A LABEL : BEGINS WITH 'A'-'Z','@','#','$',01822000
AND '.' OR '&' AS SPECIAL CASES. ENDS WITH BLANK OR 01823000
ANY NON-ALPHANUMERIC OTHER THAN '.' '&' '(' ')' */ 01824000
DCL LABEL CHAR(20) VARYING STATIC; /*RAF-41*/ 01825000
DCL STARTCOL FIXED BIN STATIC; /*RAF-41*/ 01825500
CALL SKIP; 01826000
IF ^ALPHANUM(CHAR) & CHAR^='.' & CHAR^='&' THEN 01827000
DO ; /* WORD IS NOT ALPHANUMERIC */ 01828000
WORDAL = #FALSE ; 01829000
WORD = CHAR ; 01830000
IF CHAR ^= ';' THEN 01831000
CALLINC; 01832000
RETURN ; 01833000
END; 01834000
01835000
WORDAL = #TRUE; 01836000
IF CHAR='.' THEN 01837000
DO; 01838000
LABEL = '.'; 01839000
CALLINC; 01840000
END; 01841000
ELSE 01842000
LABEL = ''; 01843000
STARTCOL = COL; 01844000
DO WHILE(ALPHANUM(CHAR) | CHAR='&' | CHAR='.' /*RAF-26*/ 01845000
| (CHAR='(' 01846000
/*RAF-3*/ /* & (SUBSTR(LABEL,1,1)='&' & SUBSTR(CARDIN,COL+1,1)='&')) */01847000
| (CHAR=')' 01848000
/*RAF-3*/ /* & (SUBSTR(LABEL,1,1)='&') */ ))); 01849000
IF CHAR='&' THEN 01850000
DO; 01851000
CALLINC; 01852000
LABEL = LABEL||SUBSTR(CARDIN,STARTCOL,COL-STARTCOL); 01853000
IF CHAR='&' THEN 01854000
CALLINC; 01855000
ELSE 01856000
CALL ERROR('LB40: "&" INSERTED.'); 01857000
STARTCOL = COL; 01858000
END; 01859000
ELSE 01860000
CALLINC; 01861000
END; 01862000
LABEL = LABEL||SUBSTR(CARDIN,STARTCOL,COL-STARTCOL) ; 01863000
IF LENGTH(LABEL)>8 THEN 01864000
CALL ERROR('LB60: TOO MANY CHARACTERS IN LABEL "'||LABEL||'".');01865000
WORD = LABEL; 01866000
IF CHAR^=' ' & CHAR^=':' & CHAR^=';' & CHAR^='>' THEN 01867000
CALL ERROR('LB50: BLANK INSERTED.'); 01868000
RETURN; 01869000
END RLABEL; /*RAF-41*/ 01869500
1 01870000
ROPANDS: 01871000
PROCEDURE(COMMASW); /*RAF-41*/ /*RAF-9*/ 01872000
/* BUILD OPERANDS OF A NON-ALP INSTRUCTION IN "OPANDS" */ 01873000
DCL COMMASW BIT(1), /*RAF-9*/ 01873100
TERMCHAR CHAR(8) VARYING STATIC; /*RAF-41*/ /*RAF-9*/ 01873200
DCL STARTCOL FIXED BIN STATIC; /*RAF-41*/ 01873250
IF COMMASW THEN TERMCHAR=' %;|&>:,'; /*RAF-9*/ 01873300
ELSE TERMCHAR = ' %;|&>'; /*RAF-9*/ 01873400
OPANDS = ''; 01874000
ROA: CALL SKIP; 01875000
STARTCOL = COL; 01876000
RO_CHARLOOP: 01877000
DO WHILE(#TRUE); 01878000
IF INDEX(TERMCHAR, CHAR) /* TERMINAL CHARS */ THEN /*RAF-9*/ 01879000
DO; 01880000
IF OPANDS = '' THEN 01881000
OPANDS = SUBSTR(CARDIN,STARTCOL,COL-STARTCOL); 01882000
ELSE 01883000
OPANDS = OPANDS||SUBSTR(CARDIN,STARTCOL,COL-STARTCOL);01884000
IF CHAR='&' & COL<72 & SUBSTR(CARDIN,COL+1,1)='&' THEN 01885000
DO; 01886000
STARTCOL,COL = COL+1; 01887000
CALLINC; 01888000
GO TO RO_CHARLOOP; 01889000
END; 01890000
GO TO OPTRUNC; 01891000
END; 01892000
IF CHAR = '_' /* INPUT CONTINUATION */ THEN 01893000
DO; 01894000
IF OPANDS = '' THEN 01895000
OPANDS = SUBSTR(CARDIN,STARTCOL,COL-STARTCOL); 01896000
ELSE 01897000
OPANDS = OPANDS||SUBSTR(CARDIN,STARTCOL,COL-STARTCOL);01898000
CALLINC; 01899000
GO TO ROA; 01900000
END; 01901000
IF CHAR = '''' THEN 01902000
DO; 01903000
IF COL>1 THEN 01904000
DO; 01905000
IF VERIFY(SUBSTR(CARDIN,COL-1,1), /*RAF-14*/ 01906000
'LKNTSI')^=0 THEN /*RAF-14*/ 01906500
GO TO RO_PRIMES; 01907000
END; 01908000
ELSE 01909000
DO; 01910000
IF SUBSTR(OPANDS,LENGTH(OPANDS),1) ^= 'L' THEN 01911000
GO TO RO_PRIMES; 01912000
END; 01913000
END; 01914000
CALLINC ; 01915000
END RO_CHARLOOP ; 01916000
01917000
OPTRUNC: 01918000
RETURN; 01919000
1 01920000
RO_PRIMES: 01921000
CALLINC; 01922000
RO_PRIMELOOP: 01923000
DO WHILE(CHAR ^= ''''); 01924000
IF COL > 72 THEN 01925000
DO ; 01926000
CALL ERROR('RO30: MISSING QUOTE IN "'||CARDIN||'".'); 01927000
RETURN; 01928000
END; 01929000
CALLINC; 01930000
END RO_PRIMELOOP; 01931000
CALLINC ; /* SKIP PRIME */ 01932000
01933000
/* IF NOT LITERAL CONTINUE */ 01934000
IF SUBSTR(CARDIN, COL ,1) ^= '_' THEN 01935000
GO TO RO_CHARLOOP; 01936000
/* CONTINUED LITERAL : */ 01937000
COL = COL - 1 ; 01938000
OPANDS = OPANDS||SUBSTR(CARDIN,STARTCOL,COL-STARTCOL); 01939000
CALLINC; 01940000
CALLINC; 01941000
CALL SKIP; 01942000
STARTCOL = COL + 1 ; 01943000
IF CHAR = '''' THEN 01944000
GO TO RO_PRIMES ; 01945000
CALL ERROR('RO50: IMPROPERLY CONTINUED LITERAL.'); 01946000
RETURN; 01947000
END ROPANDS; /*RAF-41*/ 01947500
1 01948000
/* ENTRY TO SCAN OFF CONDITION CLAUSE FOR CONDITIONAL ASM */ 01949000
CONDSCAN: PROCEDURE(PARSW) RETURNS(CHAR(170) VAR); /*RAF-41*//*RAF-9*/ 01950000
DCL 01951000
PARSW BIT(1), /*RAF-9*/ 01951500
PLEV FIXED BIN STATIC, 01952000
CONDSTR CHAR(170) VAR STATIC; 01953000
DCL 01954000
(CSTATE,INDX) FIXED BIN STATIC, 01955000
STATE(3,4) LABEL /* STATIC */ INIT 01956000
(S11,S12,S13,S14, 01957000
S21,S22,S23,S24, 01958000
S31,S32,S33,S34); 01959000
01960000
IF ^PARSW THEN DO; /*RAF-9*/ 01960100
IF ^RCHAR('(') THEN DO; /*RAF-9*/ 01960200
CALL ERROR('CONDSCAN: MISSING CONDITION CLAUSE');/*RAF-9*/ 01960300
RETURN(''); /*RAF-9*/ 01960400
END; /*RAF-9*/ 01960500
END; /*RAF-9*/ 01960600
/*RAF-9*/ 01960700
PLEV = 1; 01961000
CONDSTR = '('; 01962000
GO TO NXT2; 01963000
NXT1: CALLINC; 01964000
NXT2: IF CHAR = '(' THEN 01965000
PLEV = PLEV+1; 01966000
ELSE 01967000
IF CHAR = ')' THEN 01968000
DO; 01969000
PLEV = PLEV-1; 01970000
IF PLEV = 0 THEN 01971000
DO; 01972000
CONDSTR = CONDSTR||')'; 01973000
CALLINC; 01974000
RETURN(CONDSTR); 01975000
END; 01976000
END; 01977000
ELSE 01978000
IF CHAR = '_' | CHAR = '%' THEN 01979000
DO; 01980000
IF CHAR = '_' THEN 01981000
CALLINC; 01982000
CALL SKIP; 01983000
GO TO NXT2; 01984000
END; 01985000
ELSE 01986000
IF CHAR = '&' THEN 01987000
DO; 01988000
IF SUBSTR(CONDSTR,LENGTH(CONDSTR),1) = '&' THEN 01989000
GO TO NXT1; 01990000
END; 01991000
ELSE 01992000
IF CHAR = '''' THEN 01993000
IF VERIFY(SUBSTR(CONDSTR,LENGTH(CONDSTR),1), /*RAF-14*/ 01994000
'LKNTSI')^=0 THEN /*RAF-14*/ 01994500
DO; 01995000
CONDSTR = CONDSTR||CHAR; 01996000
CSTATE = 1; 01997000
NC: CALLINC; 01998000
NC2: IF COL = 73 THEN 01999000
INDX = 1; 02000000
ELSE 02001000
IF CHAR = '''' THEN 02002000
INDX = 2; 02003000
ELSE 02004000
IF CHAR = '_' THEN 02005000
INDX = 3; 02006000
ELSE 02007000
INDX = 4; 02008000
GO TO STATE(CSTATE,INDX); 02009000
S11: /* IN STRING == EOL */ 02010000
CALL ERROR('COND: MISSING TERMINATING QUOTE.'); 02011000
CONDSTR = CONDSTR||''''; 02012000
GO TO CONDX; 02013000
S12: /* IN STRING == QUOTE */ 02014000
CSTATE = 2; 02015000
S13: /* IN STRING == UNDERSCORE */ 02016000
S14: /* IN STRING == OTHER */ 02017000
ADC: CONDSTR = CONDSTR||CHAR; 02018000
GO TO NC; 02019000
S21: /* TERMINATE TEST == EOL */ 02020000
GO TO NXT1; 02021000
S22: /* TERMINATE TEST == QUOTE */ 02022000
CSTATE = 1; 02023000
GO TO ADC; 02024000
S23: /* TERMINATE TEST == UNDERSCORE */ 02025000
CSTATE = 3; 02026000
CALLINC; 02027000
CALL SKIP; 02028000
GO TO NC2; /*RAF-21*/ 02028500
S24: /* TERMINATE TEST == OTHER */ 02029000
GO TO CONDX; 02030000
S31: /* CONTINUATION TEST == EOL */ 02031000
GO TO CONDX; 02032000
S32: /* CONTINUATION TEST == QUOTE */ 02033000
CONDSTR = SUBSTR(CONDSTR,1,LENGTH(CONDSTR)-1); 02034000
CSTATE = 1; /*RAF-21*/ 02034500
GO TO NC; 02035000
S33: /* CONTINUATION TEST == UNDERSCORE */ 02036000
CALLINC; 02037000
CALL SKIP; 02038000
GO TO NC2; 02039000
S34: /* CONTINUATION TEST == OTHER */ 02040000
CONDX: GO TO NXT2; 02041000
END; 02042000
CONDSTR = CONDSTR||CHAR; 02043000
GO TO NXT1; 02044000
END CONDSCAN; /*RAF-41*/ 02044500
1 02045000
RCHAR: 02046000
PROCEDURE(CH) RETURNS(BIT(1)); /*RAF-41*/ 02047000
DCL 02048000
CH CHAR(1); 02049000
/* TEST INPUT FOR CHARACTER: ADVANCE INDEX IF PRESENT */ 02050000
CALL SKIP ; 02051000
IF CH = CHAR THEN 02052000
DO; 02053000
CALLINC; 02054000
RETURN(#TRUE); 02055000
END ; 02056000
ELSE 02057000
RETURN (#FALSE) ; 02058000
END RCHAR; /*RAF-41*/ 02058500
- 02059000
/* VALUE TRUE AND SKIP WORD IFF NEXT WORD IS 'CHKWORD' */ 02060000
RCHECK: 02061000
PROCEDURE(CHKWORD) RETURNS(BIT(1)); /*RAF-41*/ 02062000
DCL 02063000
CHKWORD CHAR(*) VARYING; 02064000
DCL 02065000
LEN FIXED BIN STATIC; 02066000
LEN=LENGTH(CHKWORD); 02067000
CALL SKIP ; 02068000
IF COL+LEN<=73 THEN /*RAF-41*/ 02068500
IF SUBSTR(CARDIN,COL,LEN) = CHKWORD & (COL+LEN=73 | /*RAF-41*/ 02069000
^ALPHANUM(SUBSTR(CARDIN,COL+LEN,1))) THEN /*RAF-41*/ 02070000
DO; 02071000
/* DO I = 1 TO LEN ; */ /*RAF-41*/ 02072000
COL = COL+LEN-1; /*RAF-41*/ 02072500
CALLINC; 02073000
/* END; */ /*RAF-41*/ 02074000
RETURN(#TRUE) ; 02075000
END; 02076000
/* ELSE */ /*RAF-47*/ 02077000
RETURN (#FALSE) ; 02078000
END RCHECK; /*RAF-41*/ 02078500
- 02079000
/*ALPHATST: */ /*RAF-41*/ 02080000
/*ENTRY(CHR) RETURNS(BIT(1)); */ /*RAF-41*/ 02081000
/*DCL */ /*RAF-41*/ 02082000
/* CHR CHAR(1); */ /*RAF-41*/ 02083000
/* RETURN(ALPHANUM(CHR)); */ /*RAF-41*/ 02084000
1 02085000
INC: PROCEDURE; 02086000
DCL ( (NSP,NTB) FIXED BIN, /*RAF-17*/ 02087000
FORMCON BIT(1), 02088000
SPLINE CHAR(80) INIT(' SPACE') ) STATIC, 02089000
1 MSPLINE STATIC, 02090000
2 PERSTAR CHAR(2) INIT('.*'), 02091000
2 MSP CHAR(70) INIT(' '), 02092000
2 MSPID CHAR(8), 02093000
1 BALCOM STATIC, 02094000
2 ASTR CHAR(3) INIT('* '), 02095000
2 COMFLD CHAR(68), 02096000
2 COMBLK CHAR(1) INIT(' '), 02097000
2 COMID CHAR(8); 02098000
DECLARE DOTSLSW BIT(1) STATIC; /*RAF-41*/ /*RAF-20*/ 02098500
02099000
COL = 0; 02100000
DOTSLSW = #FALSE; /*RAF-20*/ 02100500
READ FILE(SYSIN) INTO(CARDIN) ; 02101000
DO WHILE(CIN_2COLS='./'); /*RAF-9*/ 02101100
IF NESTLEV^=0 THEN /*RAF-9*/ 02101110
CALL ERROR('INC: ./ CONTROL CARD NOT AT LEVEL 0'); /*RAF-9*/ 02101120
CALL LABPUSH; CALL LABFLUSH; /*RAF-9*/ 02101200
CALL EQVFLUSH(#TRUE,1); /*RAF-9*/ 02101300
SPLINE = '*'; /*RAF-9*/ 02101350
IF ^DOTSLSW THEN SIGNAL ENDPAGE(SYSPRINT);/*RAF-20*//*RAF-9*/ 02101400
PUT FILE(SYSPRINT) EDIT (NESTLEV,CIN_ID,CIN_DATA) /*RAF-9*/ 02101500
(COL(1),X(2),P'Z9',X(2),A,X(1),A); /*RAF-9*/ 02101600
WRITE FILE(SYSOUT) FROM(CARDIN); /*RAF-9*/ 02101700
READ FILE(SYSIN) INTO(CARDIN); /*RAF-9*/ 02101800
DOTSLSW = #TRUE; /*RAF-20*/ 02101850
END; /*RAF-9*/ 02101900
IF CIN_DATA=' ' THEN DO; /*RAF-17*/ 02102000
FORMCON = #FALSE; 02103000
NSP = 1; /*RAF-17*/ 02103100
END; /*RAF-17*/ 02103200
ELSE 02104000
DO; 02105000
NSP = VERIFY(CIN_DATA,' '); 02106000
FORMCON = SUBSTR(CIN_DATA,NSP,5)='SPACE' | 02107000
SUBSTR(CIN_DATA,NSP,5)='EJECT' | 02108000
SUBSTR(CIN_DATA,NSP,5)='TITLE' | 02109000
SUBSTR(CIN_DATA,NSP,8)='SUBTITLE' ; 02110000
END; 02111000
IF SUBTITL THEN SIGNAL ENDPAGE(SYSPRINT); 02112000
IF ^FORMCON | INAL=0 THEN 02113000
DO; 02114000
IF INAL=0 THEN NSP = 1; /*RAF-17*/ 02114100
NTB = 0; /*RAF-17*/ 02114200
IF NESTLEV*3<117-(72-NSP) /*RAF-17*/ 02114300
THEN DO WHILE(SUBSTR(CIN_DATA,72-NTB,1)=' ' /*RAF-17*/ 02114400
& NTB<72); NTB = NTB+1; END; /*RAF-17*/ 02114500
PUT FILE(SYSPRINT) EDIT (NESTLEV,CIN_ID, /*RAF-17*/ 02115000
SUBSTR(CIN_DATA,NSP,73-NSP-NTB)) /*RAF-17*/ 02115100
(COL(1),X(2),P'Z9',X(2),A,X(1), /*RAF-17*/ 02116000
X(MIN(NESTLEV*3,117-(72-NSP-NTB))),A); /*RAF-17*/ 02116100
IF INAL > 0 THEN 02117000
DO; 02118000
COMFLD = SUBSTR(CARDIN,1,68); 02119000
COMID = CIN_ID; 02120000
IF INAL = 1 THEN 02121000
DO; 02122000
INAL = 2; 02123000
IF ^IN_MACRO THEN 02124000
DO; 02125000
WRITE FILE(SYSOUT) FROM(SPLINE); 02126000
ASTR = '* '; 02127000
END; 02128000
ELSE 02129000
DO; 02130000
MSPID = CIN_ID; 02131000
WRITE FILE(SYSOUT) FROM(MSPLINE); 02132000
ASTR = '.* '; 02133000
END; 02134000
END; 02135000
WRITE FILE(SYSOUT) FROM(BALCOM); 02136000
END; 02137000
END; 02138000
COUT_ID = CIN_ID; /* COPY SEQUENCE FIELD */ 02139000
RETURN; 02140000
END INC ; 02141000
1 02142000
/*ALPHANUM: */ /*RAF-41*/ 02143000
/*PROCEDURE(A) RETURNS(BIT(1)); */ /*RAF-41*/ 02144000
/*DCL */ /*RAF-41*/ 02145000
/* A CHAR(1); */ /*RAF-41*/ 02146000
/* VALUE IS TRUE IFF ARGUMENT CHARACTER IS "ALPHANUMERIC" */ 02147000
/* NOTE THAT $,# AND @ ARE ALPHABETIC IN BAL AND THEREFORE IN AL. */ 02148000
/* IF A >= 'A' | A = '$' | A = '@' | A = '#' THEN */ /*RAF-41*/ 02149000
/* RETURN(#TRUE); */ /*RAF-41*/ 02150000
/* ELSE */ /*RAF-41*/ 02151000
/* RETURN(#FALSE); */ /*RAF-41*/ 02152000
/*END ALPHANUM ; */ /*RAF-41*/ 02153000
- 02154000
SKIP: 02155000
PROCEDURE; /* SKIP TO NEXT DATUM (PAST BLANKS AND COMMENTS */ 02156000
/* DO WHILE(CHAR = ' ' | CHAR = '%'); */ /*RAF-41*/ 02157000
/* IF CHAR = ' ' THEN */ /*RAF-41*/ 02158000
/* CALLINC; */ /*RAF-41*/ 02159000
/* ELSE */ /*RAF-41*/ 02160000
/* DO; */ /* SKIP TO "EOL" */ /*RAF-41*/ 02161000
/* COL = 73; */ /*RAF-41*/ 02162000
/* CALLINC; */ /*RAF-41*/ 02163000
/* END; */ /*RAF-41*/ 02164000
/* END; */ /*RAF-41*/ 02165000
/* RETURN; */ /*RAF-41*/ 02166000
/*RAF-41*/ 02166010
DCL NBLANKS FIXED BIN(31) STATIC; /*RAF-41*/ 02166020
/*RAF-41*/ 02166030
DO WHILE('1'B); /*RAF-41*/ 02166040
DO WHILE(CHAR=' '); /*RAF-41*/ 02166050
IF COL>=72 THEN DO; /*RAF-41*/ 02166060
CALL INC; /*RAF-41*/ 02166070
COL = 1; /*RAF-41*/ 02166080
CHAR = SUBSTR(CARDIN,1,1); /*RAF-41*/ 02166090
END; /*RAF-41*/ 02166100
ELSE DO; /*RAF-41*/ 02166110
NBLANKS = VERIFY(SUBSTR(CIN_DATA,COL),' ')-1; /*RAF-41*/ 02166120
IF NBLANKS>0 THEN DO; /*RAF-41*/ 02166130
COL = COL+NBLANKS; /*RAF-41*/ 02166140
CHAR = SUBSTR(CARDIN,COL,1); /*RAF-41*/ 02166150
END; /*RAF-41*/ 02166160
ELSE DO; /*RAF-41*/ 02166170
CALL INC; /*RAF-41*/ 02166180
COL = 1; /*RAF-41*/ 02166190
CHAR = SUBSTR(CARDIN,1,1); /*RAF-41*/ 02166200
END; /*RAF-41*/ 02166210
END; /*RAF-41*/ 02166220
END; /*RAF-41*/ 02166230
IF CHAR='%' THEN DO; /*RAF-41*/ 02166240
CALL INC; /*RAF-41*/ 02166250
COL = 1; /*RAF-41*/ 02166260
CHAR = SUBSTR(CARDIN,1,1); /*RAF-41*/ 02166270
END; /*RAF-41*/ 02166280
ELSE RETURN; /*RAF-41*/ 02166290
END; /*RAF-41*/ 02166300
END SKIP; 02167000
- 02168000
/* END INPUT; */ /*RAF-41*/ 02169000
1 02170000
ERROR: /* ALP ERROR MESSAGE OUTPUT ROUTINES */ 02171000
PROCEDURE(MSG) ; 02172000
DCL 02173000
MSG CHAR(*) VAR ; 02174000
PUT SKIP(2) FILE(SYSTERM) EDIT(CIN_ID,CIN_DATA,MSG) (A,X(1),A,SKIP,A);02175000
PUT SKIP FILE(SYSTERM) EDIT('INPUT AT CHARACTER ''',CHAR,'''', 02176000
', COLUMN ',COL,' LINE ',CIN_ID, 02177000
', LAST WORD WAS ''',WORD,'''') (A,A,A,A,F(3),A,A,A,A,A); 02178000
PUT SKIP(2) FILE(SYSPRINT) EDIT('ERROR: ',MSG) (A,A); 02179000
PUT SKIP FILE(SYSPRINT) EDIT('INPUT AT CHARACTER ''',CHAR,'''', 02180000
', COLUMN ',COL,' LINE ',CIN_ID, 02181000
', LAST WORD WAS ''',WORD,'''') (A,A,A,A,F(3),A,A,A,A,A); 02182000
PUT SKIP(2) FILE(SYSPRINT) ; 02183000
ERRCNT=ERRCNT+1; 02184000
RETCODE=8; 02185000
RETURN ; 02186000
0OUTPUT: 02187000
ENTRY (MSG) ; 02188000
PUT SKIP FILE(SYSPRINT) EDIT(MSG) (A); 02189000
PUT SKIP FILE(SYSTERM) EDIT(MSG) (A); 02190000
RETURN; 02191000
END ERROR ; 02192000
- 02193000
END ALP; 02194000
