Trailing-Edge
-
PDP-10 Archives
-
decuslib10-07
-
43,50443/ulxcom.xpl
There are 2 other files named ulxcom.xpl in the archive. Click here to see a list.
/*
P D P - 1 0 X P L
V E R S I O N 1
A COMPILER-COMPILER FOR PROGRAMMING LANGUAGE 1.
RICHARD L. BISBEY II
JULY 1971
VERSION 4.0 NOVEMBER 1975.
VERION 4 OF THE COMPILER PROCESSES THE ENTIRE XPL GRAMMAR.
VERSION 3.0 NOVEMBER, 1975.
VERSION 3.0 CONTAINS THE FOLLOWING DIFFERENCES FROM VERSION 2.0:
RELOCATABLE BINARY CODE OUTPUT,
CALL INLINE FACILITY IMPLEMENTED,
UUOS USED TO CALL THE RUN-TIME ROUTINES,
SOME SWITCHES CAN BE SPECIFIED FROM THE TERMINAL,
"COMPACTIFY" IS COMPILED FROM A SOURCE LIBRARY,
REDUNDANT SAVES OF PROCEDURE RESULTS IN OTHER REGISTERS IS
AVOIDED IN MOST INSTANCES.
VERSION 2.0
HASH-CODED SYMBOL TABLE,
LEFT-TO-RIGHT GENERATION OF STRINGS FROM NUMBERS,
SPECIAL CASE CHECKS IN STRING CATENATION ROUTINE,
FASTER, MORE EFFICIENT PROCEDURE CALLS,
GENERAL INPUT/OUTPUT, FILE, FILENAME PROCEDURES,
BETTER LISTING, SYMBOL DUMP FORMAT, ETC.
R. W. HAY,
COMPUTER GROUP,
DEPT. OF ELECTRICAL ENG.,
UNIVERSITY OF TORONTO,
TORONTO, ONTARIO, CANADA.
THE MAIN STRUCTURE OF THE PROGRAM IS AS FOLLOWS:
CONTENTS.
RECOGNITION TABLES FOR THE SYNTAX ANALYZER.
DECLARATION OF SCANNER/COMPILER VARIABLES.
STORAGE COMPACTIFICATION PROCEDURE.
SCANNER PROCEDURES.
PARSER PROCEDURES.
CODE/DATA EMITTER PROCEDURES.
SYMBOL TABLE PROCEDURES.
CODE GENERATION PROCEDURES.
INITIALIZATION PROCEDURE.
ANALYSIS ALGORITHM.
PRODUCTION RULES.
*/
DECLARE VERSION LITERALLY '''4.0''';
/* THESE ARE LALR PARSING TABLES */
DECLARE MAXR# LITERALLY '99'; /* MAX READ # */
DECLARE MAXL# LITERALLY '125'; /* MAX LOOK # */
DECLARE MAXP# LITERALLY '125'; /* MAX PUSH # */
DECLARE MAXS# LITERALLY '234'; /* MAX STATE # */
DECLARE START_STATE LITERALLY '1';
DECLARE TERMINAL# LITERALLY '42'; /* # OF TERMINALS */
DECLARE VOCAB# LITERALLY '91';
DECLARE VOCAB(VOCAB#) CHARACTER INITIAL ('','<','(','+','^','&','*',')'
,';','\','-','/',',','>',':','=','^^','BY','DO','GO','IF','TO','BIT'
,'END','EOF','MOD','CALL','CASE','ELSE','GOTO','THEN','FIXED','LABEL'
,'WHILE','RETURN','DECLARE','INITIAL','<NUMBER>','<STRING>','CHARACTER'
,'LITERALLY','PROCEDURE','<IDENTIFIER>','<TERM>','<TYPE>','<GO TO>'
,'<GROUP>','<ENDING>','<PRIMARY>','<PROGRAM>','<REPLACE>','<BIT HEAD>'
,'<CONSTANT>','<RELATION>','<VARIABLE>','<IF CLAUSE>','<LEFT PART>'
,'<STATEMENT>','<TRUE PART>','<ASSIGNMENT>','<BOUND HEAD>'
,'<EXPRESSION>','<GROUP HEAD>','<IF STATEMENT>','<INITIAL HEAD>'
,'<INITIAL LIST>','<WHILE CLAUSE>','<CASE SELECTOR>','<CALL STATEMENT>'
,'<LOGICAL FACTOR>','<PARAMETER HEAD>','<PARAMETER LIST>'
,'<PROCEDURE HEAD>','<PROCEDURE NAME>','<STATEMENT LIST>'
,'<SUBSCRIPT HEAD>','<BASIC STATEMENT>','<GO TO STATEMENT>'
,'<IDENTIFIER LIST>','<LOGICAL PRIMARY>','<STEP DEFINITION>'
,'<LABEL DEFINITION>','<RETURN STATEMENT>','<TYPE DECLARATION>'
,'<ITERATION CONTROL>','<LOGICAL SECONDARY>','<STRING EXPRESSION>'
,'<DECLARATION ELEMENT>','<PROCEDURE DEFINITION>'
,'<ARITHMETIC EXPRESSION>','<DECLARATION STATEMENT>'
,'<IDENTIFIER SPECIFICATION>');
DECLARE P# LITERALLY '109'; /* # OF PRODUCTIONS */
DECLARE STATE_NAME(MAXR#) BIT(8) INITIAL (0,0,1,2,3,3,4,5,6,7,9,9,10,10
,11,12,13,16,17,18,19,20,21,22,23,25,26,27,33,34,35,36,37,37,40,42,42
,42,42,42,43,43,43,43,43,44,44,45,46,50,50,51,52,53,54,54,55,56,58,59
,60,61,61,61,61,61,61,61,61,61,61,62,64,66,67,68,69,69,70,71,72,73,74
,74,75,76,77,78,80,81,81,82,83,86,86,88,89,89,90,91);
DECLARE RSIZE LITERALLY '337'; /* READ STATES INFO */
DECLARE LSIZE LITERALLY '69'; /* LOOK AHEAD STATES INFO */
DECLARE ASIZE LITERALLY '105'; /* APPLY PRODUCTION STATES INFO */
DECLARE READ1(RSIZE) BIT(8) INITIAL (0,8,18,19,20,26,29,34,35,42,15,2,3
,9,10,37,38,42,2,37,38,42,2,37,38,42,2,3,9,10,37,38,42,2,3,9,10,37,38
,42,2,37,38,42,22,31,32,39,2,3,10,37,38,42,1,13,15,2,37,38,42,2,37,38
,42,2,37,38,42,2,42,15,2,3,10,37,38,42,2,3,9,10,37,38,42,8,27,33,42,21
,2,3,9,10,37,38,42,2,3,9,10,37,38,42,2,42,2,37,38,42,42,2,3,9,10,37,38
,42,2,3,9,10,37,38,42,2,3,9,10,37,38,42,2,42,2,7,7,38,2,14,2,40,7,12,7
,12,6,11,25,6,11,25,6,11,25,6,11,25,6,11,25,8,8,42,8,2,3,9,10,37,38,42
,2,3,9,10,37,38,42,37,7,12,2,3,10,37,38,42,12,15,15,8,18,19,20,26,29,34
,35,42,42,8,18,19,20,26,29,34,35,42,8,37,4,30,4,4,7,12,4,4,4,7,4,4,21,4
,17,4,8,18,19,20,23,26,29,34,35,42,37,38,8,8,8,5,5,42,8,22,31,32,39,8
,18,19,20,26,29,34,35,42,2,8,22,31,32,39,8,18,19,20,24,26,29,34,35,42,8
,18,19,20,23,26,29,34,35,42,2,3,9,10,37,38,42,28,8,42,8,8,18,19,20,26
,29,34,35,41,42,8,18,19,20,23,26,29,34,35,41,42,8,36,1,9,13,15,16,16,8
,3,10,3,10,8,12,2,22,31,32,39);
DECLARE LOOK1(LSIZE) BIT(8) INITIAL (0,15,0,15,0,42,0,8,0,2,14,0,2,0,40
,0,6,11,25,0,6,11,25,0,6,11,25,0,6,11,25,0,6,11,25,0,4,0,4,0,4,0,4,0,8
,0,4,0,5,0,5,0,28,0,36,0,1,9,13,15,16,0,16,0,3,10,0,3,10,0);
/* PUSH STATES ARE BUILT-IN TO THE INDEX TABLES */
DECLARE APPLY1(ASIZE) BIT(8) INITIAL (0,0,80,0,56,58,71,82,83,0,56,89
,90,0,89,90,0,0,0,0,0,0,0,0,0,0,0,0,0,0,83,90,0,71,83,90,0,0,0,0,0,0,15
,0,0,9,79,99,0,0,0,0,0,0,0,57,0,55,0,0,3,18,22,27,28,29,49,50,84,0,6,0
,7,0,10,0,0,53,0,17,0,4,5,12,13,0,8,14,25,0,1,19,26,56,57,58,71,80,82
,83,89,90,0,0,72,0);
DECLARE READ2(RSIZE) BIT(8) INITIAL (0,138,19,20,21,26,174,103,30,104
,213,3,4,10,12,234,233,105,3,234,233,105,3,234,233,105,3,4,10,12,234
,233,105,3,4,10,12,234,233,105,3,234,233,105,23,182,184,183,3,4,12,234
,233,105,211,212,210,3,234,233,105,3,234,233,105,3,234,233,105,190,106
,214,3,4,12,234,233,105,3,4,10,12,234,233,105,146,27,28,105,173,3,4,10
,12,234,233,105,3,4,10,12,234,233,105,186,166,3,234,233,105,105,3,4,10
,12,234,233,105,3,4,10,12,234,233,105,3,4,10,12,234,233,105,190,106,193
,9,185,178,231,168,231,34,189,191,162,164,8,14,25,8,14,25,8,14,25,8,14
,25,8,14,25,158,160,172,132,3,4,10,12,234,233,105,3,4,10,12,234,233,105
,33,192,194,3,4,12,234,233,105,198,197,197,138,19,20,21,26,174,103,30
,104,105,138,19,20,21,26,174,103,30,104,131,32,6,143,6,6,230,232,6,6,6
,228,6,6,22,6,18,6,138,19,20,21,102,26,174,103,30,104,234,233,148,149
,135,7,7,39,159,23,182,184,183,138,19,20,21,26,174,103,30,104,163,157
,23,182,184,183,138,19,20,21,126,26,174,103,30,104,138,19,20,21,102,26
,174,103,30,104,3,4,10,12,234,233,105,144,136,38,147,138,19,20,21,26
,174,103,30,161,104,138,19,20,21,102,26,174,103,30,161,104,134,31,100
,11,101,207,17,17,133,5,13,5,13,137,15,187,23,182,184,183);
DECLARE LOOK2(LSIZE) BIT(8) INITIAL (0,2,208,16,209,24,165,169,29,35,35
,229,36,229,37,188,40,40,40,217,41,41,41,220,42,42,42,221,43,43,43,218
,44,44,44,219,62,170,64,155,65,154,67,195,152,69,70,153,76,199,77,200
,85,129,92,177,93,93,93,93,93,205,94,206,96,96,215,97,97,216);
DECLARE APPLY2(ASIZE) BIT(8) INITIAL (0,0,83,82,140,141,150,128,128,127
,120,139,139,129,142,142,130,56,58,48,71,88,151,73,74,95,80,81,79,78
,156,167,145,90,90,90,89,91,75,86,47,98,176,175,121,180,46,179,45,51,60
,99,87,181,72,196,59,50,49,57,66,117,116,113,114,112,115,68,63,61,119
,118,202,201,204,203,53,123,122,125,124,108,110,109,111,107,223,224,225
,222,54,55,171,54,54,54,54,54,54,54,54,54,227,84,52,226);
DECLARE INDEX1(MAXS#) BIT(16) INITIAL (0,1,10,11,18,22,26,33,40,44,48
,54,57,61,65,69,71,72,78,85,89,90,97,104,105,106,110,111,118,125,132
,134,135,136,137,138,140,141,142,144,146,149,152,155,158,161,162,163
,164,165,172,179,180,182,188,190,191,200,201,210,211,212,214,215,218
,219,220,222,223,225,227,228,238,240,241,242,243,244,245,246,251,260
,266,276,286,293,294,295,296,297,307,318,319,320,325,326,327,329,331
,333,1,3,5,7,9,12,14,16,20,24,28,32,36,38,40,42,44,46,48,50,52,54,56,62
,64,67,1,2,2,4,4,10,10,10,10,10,10,10,10,10,14,14,14,17,18,19,20,20,20
,20,20,21,22,22,23,24,25,26,26,26,26,27,28,29,29,30,30,30,33,37,37,38
,39,40,40,41,41,42,42,44,44,44,45,45,45,45,49,50,51,51,52,52,53,54,54
,55,55,57,59,60,60,70,70,72,72,74,74,76,76,76,76,76,76,76,76,77,77,79
,79,79,79,79,81,81,81,81,86,86,86,90,90,103,103,104,104);
DECLARE INDEX2(MAXS#) BIT(8) INITIAL (0,9,1,7,4,4,7,7,4,4,6,3,4,4,4,2,1
,6,7,4,1,7,7,1,1,4,1,7,7,7,2,1,1,1,1,2,1,1,2,2,3,3,3,3,3,1,1,1,1,7,7,1
,2,6,2,1,9,1,9,1,1,2,1,3,1,1,2,1,2,2,1,10,2,1,1,1,1,1,1,5,9,6,10,10,7,1
,1,1,1,10,11,1,1,5,1,1,2,2,2,5,2,2,2,2,3,2,2,4,4,4,4,4,2,2,2,2,2,2,2,2
,2,2,6,2,3,3,1,0,1,0,0,1,1,1,1,1,1,1,0,1,1,2,1,2,1,1,1,2,2,2,1,3,1,3,1
,1,2,1,2,2,3,1,2,0,2,0,1,1,1,0,1,1,1,1,0,1,2,0,2,1,3,1,0,0,0,2,1,1,0,2
,0,2,2,1,2,2,1,0,1,0,2,0,2,0,1,0,2,0,0,0,1,1,1,1,1,0,2,0,2,2,1,1,0,2,2
,2,0,0,2,0,2,1,2,0,0);
/* DECLARATIONS FOR THE SCANNER */
/* TOKEN IS THE INDEX INTO THE VOCABULARY V() OF THE LAST SYMBOL SCANNED,
CP IS THE POINTER TO THE LAST CHARACTER SCANNED IN THE CARDIMAGE,
BCD IS THE LAST SYMBOL SCANNED (LITERAL CHARACTER STRING). */
DECLARE TOKEN FIXED, BCD CHARACTER, CH FIXED, CP FIXED;
/* SET UP SOME CONVENIENT ABBREVIATIONS FOR PRINTER CONTROL */
DECLARE TRUE LITERALLY '"1"', FALSE LITERALLY '"0"',
FOREVER LITERALLY 'WHILE TRUE',
X70 CHARACTER INITIAL ('
');
DECLARE POINTER CHARACTER INITIAL ('
^');
/* LENGTH OF LONGEST SYMBOL IN V */
DECLARE RESERVED_LIMIT FIXED;
/* CHARTYPE() IS USED TO DISTINGUISH CLASSES OF SYMBOLS IN THE SCANNER.
TX() IS A TABLE USED FOR TRANSLATING FROM ONE CHARACTER SET TO ANOTHER.
CONTROL() HOLDS THE VALUE OF THE COMPILER CONTROL TOGGLES SET IN $ CARDS.
NOT_LETTER_OR_DIGIT() IS SIMILIAR TO CHARTYPE() BUT USED IN SCANNING
IDENTIFIERS ONLY.
ALL ARE USED BY THE SCANNER AND CONTROL() IS SET THERE.
*/
DECLARE CHARTYPE(255) BIT(8), TX(255) BIT(8), CONTROL(255) BIT(1),
NOT_LETTER_OR_DIGIT(255) BIT(1);
/* BUFFER HOLDS THE LATEST CARDIMAGE,
TEXT HOLDS THE PRESENT STATE OF THE INPUT TEXT
(NOT INCLUDING THE PORTIONS DELETED BY THE SCANNER),
TEXT_LIMIT IS A CONVENIENT PLACE TO STORE THE POINTER TO THE END OF TEXT,
CARD_COUNT IS INCREMENTED BY ONE FOR EVERY SOURCE CARD READ,
ERROR_COUNT TABULATES THE ERRORS AS THEY ARE DETECTED,
SEVERE_ERRORS TABULATES THOSE ERRORS OF FATAL SIGNIFICANCE.
CURRENT_PROCEDURE CONTAINS THE NAME OF THE PROCEDURE BEING PROCESSED.
PROCEDURE_DEPTH CONTAINS THE CURRENT NUMBER OF PROCEDURES NESTED.
ALPHABET CONTAINS THE ABC'S IN UPPER CASE
*/
DECLARE ALPHABET CHARACTER INITIAL ('ABCDEFGHIJKLMNOPQRSTUVWXYZ');
DECLARE BUFFER CHARACTER, TEXT CHARACTER, TEXT_LIMIT FIXED,
CARD_COUNT FIXED, ERROR_COUNT FIXED,
SEVERE_ERRORS FIXED, PREVIOUS_ERROR FIXED,
LINE_LENGTH FIXED, /* LENGTH OF SOURCE STATEMENT */
CURRENT_PROCEDURE CHARACTER,
PROCEDURE_DEPTH FIXED;
/* NUMBER_VALUE CONTAINS THE NUMERIC VALUE OF THE LAST CONSTANT SCANNED,
*/
DECLARE NUMBER_VALUE FIXED, JBASE FIXED, BASE FIXED;
/* EACH OF THE FOLLOWING CONTAINS THE INDEX INTO V() OF THE CORRESPONDING
SYMBOL. WE ASK: IF TOKEN = IDENT ETC. */
DECLARE IDENT FIXED, STRING FIXED, NUMBER FIXED, DIVIDE FIXED, EOFILE FIXED,
LABELSET FIXED;
DECLARE ORSYMBOL FIXED, CONCATENATE FIXED;
DECLARE BALANCE CHARACTER, LB FIXED ;
DECLARE MACRO_LIMIT LITERALLY '60', MACRO_NAME (MACRO_LIMIT) CHARACTER,
MACRO_TEXT(MACRO_LIMIT) CHARACTER, MACRO_INDEX (255) BIT (8),
MACRO_COUNT (MACRO_LIMIT) FIXED, MACRO_DECLARE (MACRO_LIMIT) FIXED,
TOP_MACRO FIXED;
DECLARE EXPANSION_COUNT FIXED, EXPANSION_LIMIT LITERALLY '300';
/* STOPIT() IS A TABLE OF SYMBOLS WHICH ARE ALLOWED TO TERMINATE THE ERROR
FLUSH PROCESS. IN GENERAL THEY ARE SYMBOLS OF SUFFICIENT SYNTACTIC
HIERARCHY THAT WE EXPECT TO AVOID ATTEMPTING TO START CHECKING AGAIN
RIGHT INTO ANOTHER ERROR PRODUCING SITUATION. THE TOKEN STACK IS ALSO
FLUSHED DOWN TO SOMETHING ACCEPTABLE TO A STOPIT() SYMBOL.
FAILSOFT IS A BIT WHICH ALLOWS THE COMPILER ONE ATTEMPT AT A GENTLE
RECOVERY. THEN IT TAKES A STRONG HAND. WHEN THERE IS REAL TROUBLE
COMPILING IS SET TO FALSE, THEREBY TERMINATING THE COMPILATION.
*/
DECLARE STOPIT(TERMINAL#) BIT(1), FAILSOFT FIXED, COMPILING FIXED;
/* THE FOLLOWING SWITCH IS USED BY THE LALR PARSER */
DECLARE NO_LOOK_AHEAD_DONE BIT(1);
DECLARE TARGET_REGISTER FIXED; /* FOR FINDAR */
DECLARE TRUELOC FIXED; /* LOCATION OF CONSTANT 1 */
DECLARE FALSELOC FIXED; /* LOCATION OF CONSTANT 0 */
DECLARE BYTEPTRS FIXED, /* LOCATION OF 4 PTRS FOR LDB & DPB */
PSBITS FIXED; /* BYTE PTRS FORE MOVE */
DECLARE STRING_CHECK FIXED, /* COMPACTIFY CALLER */
CATENTRY FIXED, /* CATENATION SUBROUTINE */
NMBRENTRY FIXED, /* NUMBER TO STRING SUBROUTINE */
STRCOMP FIXED, /* STRING COMPARE SUBROUTINE */
CALLTYPE FIXED INITIAL (1), /* DIST BETWEEN SUB & FUNCTION */
MOVER FIXED, /* STRING MOVE SUBROUTINE */
STRING_RECOVER FIXED, /* SYT LOCATION OF COMPACTIFY */
COREBYTELOC FIXED, /* SYT LOCATION OF COREBYTE */
LIMITWORD FIXED, /* ADDRESS OF FREELIMIT */
TSA FIXED; /* ADDRESS OF FREEPOINT */
DECLARE NDESC FIXED; /* ADDRESS OF NDESCRIPT */
DECLARE LIBRARY FIXED, /* ADDRESS OF RUNTIME LIBRARY */
LIBRARY_SAVE FIXED, /* PLACE TO STORE R11 ON LIB CALLS */
STR FIXED; /* DESCRIPTOR OF LAST STRING */
DECLARE STEPK FIXED; /* USED FOR DO LOOPS */
DECLARE A FIXED, B FIXED, C FIXED; /* FOR CATENATION & CONVERSION */
DECLARE LENGTHMASK FIXED; /* ADDR OF DV LENGTH MASK */
DECLARE ADDRMASK FIXED; /* ADDRESS OF "FFFFF" */
DECLARE LABEL_SINK FIXED INITIAL(0); /* FOR LABEL GENERATOR */
DECLARE LABEL_GEN CHARACTER; /* CONTAINS LABEL FOR NEXT INST*/
DECLARE ACC(15) FIXED; /* KEEPS TRACK OF ACCUMULATORS */
DECLARE AVAIL LITERALLY '0', BUSY LITERALLY '1';
/* CALL COUNTS OF IMPORTANT PROCEDURES */
DECLARE COUNT_SCAN FIXED, /* SCAN */
COUNT_INST FIXED, /* EMITINST */
COUNT_FORCE FIXED, /* FORCEACCUMULATOR */
COUNT_ARITH FIXED, /* ARITHEMIT */
COUNT_STORE FIXED; /* GENSTORE */
DECLARE TITLE CHARACTER, /*TITLE LINE FOR LISTING */
SUBTITLE CHARACTER, /*SUBTITLE FOR LISTING */
PAGE_COUNT FIXED, /*CURRENT PAGE NUMBER FOR LISTING*/
LINE_COUNT FIXED, /*NUMBER OF LINES PRINTED */
PAGE_MAX LITERALLY '54', /*MAX NO OF LINES ON PAGE*/
EJECT_PAGE LITERALLY 'LINE_COUNT = PAGE_MAX+1';
DECLARE SOURCE CHARACTER; /*FILE NAME BEING COMPILED*/
DECLARE DATAFILE LITERALLY '2'; /* SCRATCH FILE FOR DATA */
DECLARE CODEFILE LITERALLY '3'; /* SCRATCH FILE FOR CODE */
DECLARE RELFILE LITERALLY '4'; /* BINARY OUTPUT FILE */
DECLARE LIBFILE LITERALLY '5'; /* SOURCE LIBRARY FILE */
DECLARE READING BIT(1); /* 0 IFF READING LIBFILE */
DECLARE DATACARD CHARACTER; /* DATA BUFFER */
DECLARE PP FIXED, /* CURRENT PROGRAM POINTER */
CODE(3) CHARACTER, /* THE CODE BUFFER */
CODE_FULL(3) BIT(1), /* FULLNESS FLAG */
CODE_HEAD FIXED, /* FRONT OF BUFFER */
CODE_TAIL FIXED, /* END OF BUFFER */
DP FIXED, /* CURRENT DATA POINTER */
DPOFFSET FIXED; /* CURRENT DP BYTE OFFSET */
DECLARE CODESTRING CHARACTER; /*FOR COPYING CODE INTO DATA FILE*/
/* THE FOLLOWING ARE FOR RELOCATABLE BINARY CODE EMISSION */
DECLARE BUFFERSIZE LITERALLY '18'; /* SIZE OF BINARY BUFFERS */
DECLARE CODE_BUFFER (BUFFERSIZE) FIXED; /*CODE (HIGH) BUFFER */
DECLARE DATA_BUFFER (BUFFERSIZE) FIXED; /* DATA (LOW) BUFFER */
DECLARE LABEL_BUFFER (BUFFERSIZE) FIXED; /* LABELS DEFINED BUFFER */
DECLARE CODE_REL(3) FIXED, /* BINARY CODE BUFFER (SEE CODE) */
CODE_PP(3) FIXED,
CODE_RBITS(3) FIXED;
DECLARE RPTR FIXED, /* POINTER TO CODE_BUFFER */
RCTR FIXED, /* COUNTER FOR CODE_BUFFER */
DPTR FIXED, /* POINTER TO DATA_BUFFER */
DCTR FIXED, /* COUNTER FOR DATA_BUFFER */
DLOC FIXED; /* LOCATION OF NEXT WORD IN DATA BUFFER */
DECLARE LABEL_COUNT FIXED; /*NO OF LABELS IN LABEL_BUFFER */
DECLARE FOR_MAX LITERALLY '50'; /* MAXIMUM FORWARD REFERENCES */
DECLARE FOR_REF (FOR_MAX) FIXED, /* FORWARD REFERENCED LABELS */
FOR_LABEL (FOR_MAX) FIXED, /* LABEL REFERENCED */
FOR_COUNT FIXED; /* COUNT OF CURRENT FORWARD REFS */
DECLARE PWORD FIXED; /* PART-WORD ACC. FOR BYTES*/
DECLARE STARTLOC FIXED; /* FIRST INSTRUCTION TO BE EXECUTED */
DECLARE CODE_TYPE LITERALLY '"(3)1000000"'; /* CODE & DATA TYPE BLOCK */
DECLARE SYMB_TYPE LITERALLY '"(3)2000000"'; /* SYMBOL DEFN TYPE BLOCK */
DECLARE HISEG_TYPE LITERALLY '"(3)3000000"'; /* HIGH SEGMENT TYPE BLOCK */
DECLARE END_TYPE LITERALLY '"(3)5000000"'; /* END TYPE BLOCK */
DECLARE NAME_TYPE LITERALLY '"(3)6000000"'; /* NAME TYPE BLOCK */
DECLARE START_TYPE LITERALLY '"(3)7000000"'; /* START ADDRESS TYPE BLOCK */
DECLARE INTREQ_TYPE LITERALLY '"(3)10000000"'; /* INTERNAL REQUEST TYPE BLOCK */
/* END OF DEFINITIONS FOR RELOCATABLE BINARY FILES */
DECLARE ADR FIXED;
DECLARE ITYPE FIXED;
DECLARE NEWDP FIXED, NEWDSP FIXED, NEWDPOFFSET FIXED; /* FOR ALLOCATION */
DECLARE OLDDP FIXED, OLDDSP FIXED, OLDDPOFFSET FIXED; /* FOR ALLOCATION */
DECLARE DESCLIMIT LITERALLY '1000', /* NUMBER OF STRING DESCRIPTORS */
DESCA (DESCLIMIT) FIXED, /* STRING DESCRIPTOR ADDRESS */
DESCL (DESCLIMIT) FIXED, /* STRING DESCRIPTOR LENGTH */
DESCREF (DESCLIMIT) FIXED, /* LAST REFERENCE TO STRING */
DSP FIXED; /* DESCRIPTOR POINTER */
DECLARE S CHARACTER;
DECLARE OPNAME (15) CHARACTER INITIAL (
' .INIT..INPT..OUTP..EXIT. .FILI..FILO..NAME.',
'CALL INIT UUO042UUO043UUO044UUO045UUO046CALLI OPEN TTCALLUUO052UUO053UUO054
RENAMEIN OUT SETSTSSTATO GETSTSSTATZ INBUF OUTBUFINPUT OUTPUTCLOSE
RELEASMTAPE UGETF USETI USETO LOOKUPENTER ',
'UUO100UUO101UUO102UUO103UUO104UUO105UUO106UUO107UUO110UUO111UUO112UUO113UUO114U
UO115UUO116UUO117UUO120UUO121UUO122UUO123UUO124UUO125UUO126UUO127UFA DFN FSC
IBP ILDB LDB IDPB DPB ',
'',
'MOVE MOVEI MOVEM MOVES MOVS MOVSI MOVSM MOVSS MOVN MOVNI MOVNM MOVNS MOVM M
OVMI MOVMM MOVMS IMUL IMULI IMULM IMULB MUL MULI MULM MULB IDIV IDIVI IDI
VM IDIVB DIV DIVI DIVM DIVB ',
'ASH ROT LSH JFFO ASHC ROTC LSHC ......EXCH BLT AOBJP AOBJN JRST J
FCL XCT ......PUSHJ PUSH POP POPJ JSR JSP JSA JRA ADD ADDI ADD
M ADDB SUB SUBI SUBM SUBB ',
'CAI CAIL CAIE CAILE CAIA CAIGE CAIN CAIG CAM CAML CAME CAMLE CAMA C
AMGE CAMN CAMG JUMP JUMPL JUMPE JUMPLEJUMPA JUMPGEJUMPN JUMPG SKIP SKIPL SKI
PE SKIPLESKIPA SKIPGESKIPN SKIPG ',
'AOJ AOJL AOJE AOJLE AOJA AOJGE AOJN AOJG AOS AOSL AOSE AOSLE AOSA A
OSGE AOSN AOSG SOJ SOJL SOJE SOJLE SOJA SOJGE SOJN SOJG SOS SOSL SOS
E SOSLE SOSA SOSGE SOSN SOSG ',
'SETZ SETZI SETZM SETZB AND ANDI ANMD ANDB ANDCA ANDCAIANDCAMANDCABSETM S
ETMI SETMM SETMB ANDCM ANDCMIANDCMMANDCMBSETA SETAI SETAM SETAB XOR XORI XOR
M XORB IOR IORI IORM IORB ',
'ANDCB ANDCBIANDCBMANDCBBEQV EQVI EQVM EQVB SETCA SETCAISETCAMSETCABORCA O
RCAI ORCAM ORCAB SETCM SETCMISETCMMSETCMBORCM ORCMI ORCMM ORCMB ORCB ORCBI ORC
BM ORCBB SETO SETOI SETOM SETOB ',
'HLL HLLI HLLM HLLS HRL HRLI HRLM HRLS HLLZ HLLZI HLLZM HLLZS HRLZ H
RLZI HRLZM HRLZS HLLO HLLOI HLLOM HLLOS HRLO HRLOI HRLOM HRLOS HLLE HLLEI HLL
EM HLLES HRLE HRLEI HRLEM HRLES ',
'HRR HRRI HRRM HRRS HLR HLRI HLRM HLRS HRRZ HRRZI HRRZM HRRZS HLRZ H
LRZI HLRZM HLRZS HRRO HRROI HRROM HRROS HLRO HLROI HLROM HLROS HRRE HRREI HRR
EM HRRES HLRE HLREI HLREM HLRES ',
'TRN TLN TRNE TLNE TRNA TLNA TRNN TLNN TDN TSN TDNE TSNE TDNA T
SNA TDNN TSNN TRZ TLZ TRZE TLZE TRZA TLZA TRZN TLZN TDZ TSZ TDZ
E TSZE TDZA TSZA TDZN TSZN ',
'TRC TLC TRCE TLCE TRCA TLCA TRCN TLCN TDC TSC TDCE TSCE TDCA T
SCA TDCN TSCN TRO TLO TROE TLOE TROA TLOA TRON TLON TDO TSO TDO
E TSOE TDOA TSOA TDON TSON ',
'',
'');
DECLARE INSTRUCT(511) FIXED; /* COUNT OF THE INSTRUCTIONS ISSUED */
/* COMMONLY USED OPCODES */
DECLARE ADD FIXED INITIAL ("(3)270"),
ADDI FIXED INITIAL ("(3)271"),
ADDM FIXED INITIAL ("(3)272"),
AND FIXED INITIAL ("(3)404"),
ANDI FIXED INITIAL ("(3)405"),
AOSA FIXED INITIAL ("(3)354"),
BLT FIXED INITIAL ("(3)251"),
CALLI FIXED INITIAL ("(3)047"),
CAM FIXED INITIAL ("(3)310"),
CAMGE FIXED INITIAL ("(3)315"),
CAML FIXED INITIAL ("(3)311"),
CAMLE FIXED INITIAL ("(3)313"),
CAMN FIXED INITIAL ("(3)316"),
CMPRHI FIXED INITIAL ("(3)317"),
DPB FIXED INITIAL ("(3)137"),
HLL FIXED INITIAL ("(3)500"),
HLRZ FIXED INITIAL ("(3)554"),
HRLI FIXED INITIAL ("(3)505"),
HRLM FIXED INITIAL ("(3)506"),
HRREI FIXED INITIAL ("(3)571"),
IDIV FIXED INITIAL ("(3)230"),
IDIVI FIXED INITIAL ("(3)231"),
IDPB FIXED INITIAL ("(3)136"),
ILDB FIXED INITIAL ("(3)134"),
IMUL FIXED INITIAL ("(3)220"),
IOR FIXED INITIAL ("(3)434"),
JRST FIXED INITIAL ("(3)254"),
JUMP FIXED INITIAL ("(3)320"),
JUMPE FIXED INITIAL ("(3)322"),
JUMPGE FIXED INITIAL ("(3)325"),
JUMPN FIXED INITIAL ("(3)326"),
LDB FIXED INITIAL ("(3)135"),
LSH FIXED INITIAL ("(3)242"),
LSHC FIXED INITIAL ("(3)246"),
MOVE FIXED INITIAL ("(3)200"),
MOVEI FIXED INITIAL ("(3)201"),
MOVEM FIXED INITIAL ("(3)202"),
MOVM FIXED INITIAL ("(3)214"),
MOVN FIXED INITIAL ("(3)210"),
POP FIXED INITIAL ("(3)262"),
POPJ FIXED INITIAL ("(3)263"),
PUSH FIXED INITIAL ("(3)261"),
PUSHJ FIXED INITIAL ("(3)260"),
ROT FIXED INITIAL ("(3)241"),
SETCA FIXED INITIAL ("(3)450"),
SETZM FIXED INITIAL ("(3)402"),
SKIP FIXED INITIAL ("(3)330"),
SKIPE FIXED INITIAL ("(3)332"),
SOJG FIXED INITIAL ("(3)367"),
SUB FIXED INITIAL ("(3)274"),
SUBI FIXED INITIAL ("(3)275");
DECLARE COMPARESWAP (7) FIXED INITIAL (0,7,2,5,0,3,6,1);
DECLARE STILLCOND FIXED, /* PEEP HOLE FOR BOOL BRANCHING */
STILLINZERO FIXED; /* PEEPHOLE FOR REDUNDANT MOVES */
DECLARE STATEMENT_COUNT FIXED; /* A COUNT OF THE XPL STATEMENTS */
DECLARE IDCOMPARES FIXED;
DECLARE X1 CHARACTER INITIAL (' ');
DECLARE X2 CHARACTER INITIAL (' ');
DECLARE X3 CHARACTER INITIAL (' ');
DECLARE X4 CHARACTER INITIAL (' ');
DECLARE X7 CHARACTER INITIAL (' ');
DECLARE INFO CHARACTER; /* FOR LISTING INFORMATION*/
DECLARE CHAR_TEMP CHARACTER;
DECLARE I_STRING CHARACTER; /* FOR I_FORMAT */
DECLARE I FIXED, J FIXED, K FIXED, L FIXED;
DECLARE PROCMARK FIXED, NDECSY FIXED, MAXNDECSY FIXED, PARCT FIXED;
DECLARE RETURNED_TYPE FIXED;
DECLARE LABELTYPE LITERALLY '1',
ACCUMULATOR LITERALLY '2',
VARIABLE LITERALLY '3',
CONSTANT LITERALLY '4',
CHRTYPE LITERALLY '6',
FIXEDTYPE LITERALLY '7',
BYTETYPE LITERALLY '8',
FORWARDTYPE LITERALLY '9',
DESCRIPT LITERALLY '10',
SPECIAL LITERALLY '11',
FORWARDCALL LITERALLY '12',
PROCTYPE LITERALLY '13',
CHARPROCTYPE LITERALLY '14';
DECLARE TYPENAME (14) CHARACTER INITIAL ('', 'LABEL ', '', '', '', '',
'CHARACTER', 'FIXED ', 'BIT (9) ' , '', '', '', '',
'PROCEDURE','CHARACTER PROCEDURE');
/* THE SYMBOL TABLE IS INITIALIZED WITH THE NAMES OF ALL
BUILTIN FUNCTIONS AND PSEUDO VARIABLES. THE PROCEDURE
INITIALIZE DEPENDS ON THE ORDER AND PLACEMENT OF THESE
NAMES. CHANGES SHOULD BE MADE OBSERVING DUE CAUTION TO
AVOID MESSING THINGS UP.
*/
DECLARE SYTSIZE LITERALLY '420'; /* THE SYMBOL TABLE SIZE */
DECLARE SYT (SYTSIZE) CHARACTER /* THE VARIABLE NAME */
INITIAL ('COREWORD', 'COREBYTE', 'FREEPOINT', 'DESCRIPTOR',
'NDESCRIPT', 'LENGTH', 'SUBSTR', 'BYTE', 'SHL', 'SHR',
'INPUT', 'OUTPUT', 'FILE', 'INLINE', 'TRACE', 'UNTRACE',
'EXIT', 'TIME', 'DATE', 'CLOCK_TRAP', 'INTERRUPT_TRAP',
'MONITOR', 'ADDR', 'RUNTIME', 'FILENAME',
'COMPACTIFY', 'FREELIMIT', 'FREEBASE');
DECLARE SYTYPE (SYTSIZE) BIT (8) /* TYPE OF VARIABLE */
INITIAL (FIXEDTYPE, BYTETYPE, FIXEDTYPE, FIXEDTYPE,
FIXEDTYPE, SPECIAL, SPECIAL, SPECIAL, SPECIAL, SPECIAL,
SPECIAL, SPECIAL, SPECIAL, SPECIAL, SPECIAL, SPECIAL,
SPECIAL, SPECIAL, SPECIAL, SPECIAL, SPECIAL,
SPECIAL, SPECIAL, SPECIAL, SPECIAL,
FORWARDCALL, FIXEDTYPE, FIXEDTYPE);
DECLARE SYTLOC (SYTSIZE) FIXED /* LOCATION OF VARIABLE */
INITIAL (0,0,0,0,0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,
0,0,0);
DECLARE SYTSEG (SYTSIZE) BIT(8) /* SEGMENT OF VARIABLE */
INITIAL (0,0,1,3,5,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,4,1,1);
DECLARE SYTCO (SYTSIZE) FIXED; /* A COUNT OF REFERENCES */
DECLARE SYTCARD (SYTSIZE) FIXED; /* WHERE SYMBOL IS DEFINED */
DECLARE HASH (255) FIXED, /* HASH TABLE INTO SYMBOL TABLE*/
PTR (SYTSIZE) FIXED, /* POINTS TO NEXT SYMBOL IN HASH*/
IDX FIXED; /* INDEX WHILE USING HASH*/
/* THE COMPILER STACKS DECLARED BELOW ARE USED TO DRIVE THE SYNTACTIC
ANALYSIS ALGORITHM AND STORE INFORMATION RELEVANT TO THE INTERPRETATION
OF THE TEXT. THE STACKS ARE ALL POINTED TO BY THE STACK POINTER SP. */
DECLARE STACKSIZE LITERALLY '50'; /* SIZE OF STACK */
DECLARE STATE_STACK (STACKSIZE) BIT (8);
DECLARE TYPE (STACKSIZE) FIXED;
DECLARE REG (STACKSIZE) FIXED;
DECLARE INX (STACKSIZE) FIXED;
DECLARE CNT (STACKSIZE) FIXED;
DECLARE VAR (STACKSIZE) CHARACTER;
DECLARE FIXV (STACKSIZE) FIXED;
DECLARE PPSAVE (STACKSIZE) FIXED;
DECLARE FIXL (STACKSIZE) FIXED;
DECLARE SP FIXED, MP FIXED, MPP1 FIXED;
DECLARE CASELIMIT LITERALLY '175',
CASESTACK (CASELIMIT) FIXED, /* CONTAINS ADDR OF STMTS OF CASE */
CASEP FIXED; /* POINTS TO CURRENT CASESTACK ENTRY */
DECLARE CODEMSG CHARACTER INITIAL ('CODE = '),
DATAMSG CHARACTER INITIAL ('DATA = '),
BACKMSG CHARACTER INITIAL ('BACK UP CODE EMITTER'),
FILEMSG CHARACTER INITIAL ('MISSING NUMBER FOR FILE');
/*
G L O B A L P R O C E D U R E S
*/
I_FORMAT:
PROCEDURE (NUMBER, WIDTH);
DECLARE NUMBER FIXED,
WIDTH FIXED;
DECLARE L FIXED;
I_STRING = NUMBER;
L = LENGTH (I_STRING);
IF L < WIDTH THEN
I_STRING = SUBSTR(X70,0,WIDTH-L) ^^ I_STRING;
END I_FORMAT;
PRINTLINE:
PROCEDURE (LINE, IND);
DECLARE LINE CHARACTER, /*LINE TO BE PRINTED */
IND FIXED; /*FORMAT INDICATOR*/
DECLARE CTL(5) CHARACTER INITIAL ('0','1','','','','');
DECLARE SKIPS (5) FIXED INITIAL (2,99,0,0,0,0);
IF LINE_COUNT > PAGE_MAX THEN
DO;
PAGE_COUNT = PAGE_COUNT + 1;
OUTPUT(1) = TITLE ^^ PAGE_COUNT;
OUTPUT = SUBTITLE;
OUTPUT = ' ';
LINE_COUNT = 0;
END;
IF IND < 0 ^ IND > 5 THEN
DO;
OUTPUT = LINE;
LINE_COUNT = LINE_COUNT + 1;
END;
ELSE
DO;
OUTPUT(1) = CTL(IND) ^^ LINE;
LINE_COUNT = LINE_COUNT + SKIPS(IND);
END;
END PRINTLINE;
ERROR:
PROCEDURE (MSG, SEVERITY);
/* PRINT THE ERROR MESSAGE WITH A POINTER POINTING TO THE CURRENT TOKEN
BEING SCANNED. IF SOURCE LISTING IS DISABLED, ALSO PRINT THE CURRENT
SOURCE IMAGE.
*/
DECLARE MSG CHARACTER, SEVERITY FIXED;
DECLARE I FIXED;
ERROR_COUNT = ERROR_COUNT + 1;
IF CONTROL(BYTE('L')) = 0 THEN
DO;
I = 5 - LENGTH(CARD_COUNT);
CALL PRINTLINE (SUBSTR (X70, 0, I) ^^ CARD_COUNT ^^ X4 ^^ BUFFER,-1);
END;
CALL PRINTLINE (SUBSTR(POINTER,LENGTH(POINTER)-7-
(LINE_LENGTH+CP-TEXT_LIMIT-LB-1)),-1);
OUTPUT(-1) = CARD_COUNT ^^ X4 ^^ BUFFER;
OUTPUT(-1) = X7 ^^ MSG;
IF PREVIOUS_ERROR > 0 THEN
MSG = MSG ^^ '. LAST PREVIOUS ERROR WAS ON LINE ' ^^ PREVIOUS_ERROR;
CALL PRINTLINE ('*** ERROR. ' ^^ MSG,-1);
PREVIOUS_ERROR = CARD_COUNT;
IF SEVERITY > 0 THEN
IF SEVERE_ERRORS > 25 THEN
DO;
CALL PRINTLINE ('*** TOO MANY SEVERE ERRORS, COMPILATION ABORTED ***',0);
COMPILING = FALSE;
END;
ELSE SEVERE_ERRORS = SEVERE_ERRORS + 1;
END ERROR;
/* THE SCANNER PROCEDURES */
BUILD_BCD:
PROCEDURE (C);
DECLARE C BIT(9);
IF LENGTH(BCD) > 0 THEN BCD = BCD ^^ X1;
ELSE BCD = SUBSTR(X1 ^^ X1, 1);
COREBYTE(FREEPOINT-1) = C;
END BUILD_BCD;
GET_CARD:
PROCEDURE;
/* DOES ALL CARD READING AND LISTING */
DECLARE I FIXED, TEMPO CHARACTER, TEMP2 CHARACTER;
IF LB \= 0 THEN
DO;
IF CP >= 255 THEN
DO;
TEXT = SUBSTR(TEXT, LB);
CP = CP - LB;
CALL ERROR ('IDENTIFIER TOO LONG', 0);
END;
IF LB > 255 - CP THEN I = 255 - CP;
ELSE I = LB;
LB = LB - I;
TEXT = TEXT ^^ SUBSTR(BALANCE, 0, I);
BALANCE = SUBSTR(BALANCE, I);
TEXT_LIMIT = LENGTH(TEXT) - 1;
RETURN;
END;
EXPANSION_COUNT = 0; /* CHECKED IN SCANNER */
IF READING THEN /* READING IS FALSE INITIALLY, TO READ LIBRARY */
DO;
BUFFER = INPUT;
IF LENGTH(BUFFER) = 0 THEN
DO;
CALL ERROR ('EOF MISSING', 0);
BUFFER = ' /* '' /* */ EOF; END; EOF; END; EOF';
END;
ELSE CARD_COUNT = CARD_COUNT + 1;
END;
ELSE
DO;
BUFFER = INPUT(LIBFILE);
IF LENGTH(BUFFER) = 0 THEN
DO;
READING = TRUE;
BUFFER = INPUT;
CARD_COUNT = CARD_COUNT + 1;
STATEMENT_COUNT = 0;
CONTROL(BYTE('L')) = TRUE & \ CONTROL(BYTE('K'));
END;
END;
LINE_LENGTH = LENGTH (BUFFER);
IF CP + LENGTH(BUFFER) > 255 THEN
DO;
I = 255 - CP;
TEXT = TEXT ^^ SUBSTR(BUFFER, 0, I);
BALANCE = SUBSTR(BUFFER, I);
LB = LENGTH(BALANCE);
END;
ELSE TEXT = TEXT ^^ BUFFER;
TEXT_LIMIT = LENGTH(TEXT) - 1;
IF CONTROL(BYTE('M')) THEN CALL PRINTLINE(BUFFER,-1);
ELSE IF CONTROL(BYTE('L')) THEN
DO;
TEMPO = CARD_COUNT;
I = 5 - LENGTH (TEMPO);
TEMPO = SUBSTR(X70, 0, I) ^^ TEMPO ^^ X2 ^^ BUFFER;
I = 0;
DO WHILE I <= LENGTH(TEMPO);
IF BYTE(TEMPO,I) = 9 THEN /* EXPAND TAB CHAR */
DO;
TEMPO = SUBSTR(TEMPO,0,I) ^^ SUBSTR(X70,0,9-(I MOD 8))
^^ SUBSTR(TEMPO,I+1);
I = I + 9-(I MOD 8);
END;
ELSE
I = I + 1;
END;
I = 88 - LENGTH(TEMPO);
IF I >= 70 THEN
DO;
I = I - 70;
TEMPO = TEMPO ^^ X70;
END;
IF I > 0 THEN TEMPO = TEMPO ^^ SUBSTR(X70, 0, I);
TEMP2 = CURRENT_PROCEDURE ^^ INFO;
IF CONTROL(BYTE('F')) THEN
TEMP2 = X2 ^^ PP ^^ X1 ^^ DP ^^ X1 ^^ DSP ^^ TEMP2;
IF LENGTH (TEMP2) > 44 THEN TEMP2 = SUBSTR (TEMP2,0,44);
CALL PRINTLINE (TEMPO ^^ TEMP2,-1);
END;
INFO = ''; /* CLEAR INFORMATION BUFFER */
END GET_CARD;
CHAR:
PROCEDURE;
CP = CP + 1;
IF CP <= TEXT_LIMIT THEN RETURN;
CP = 0;
TEXT = '';
CALL GET_CARD;
END CHAR;
DEBLANK:
PROCEDURE;
CALL CHAR;
DO WHILE BYTE (TEXT, CP) = BYTE (' ');
CALL CHAR;
END;
END DEBLANK;
BCHAR:
PROCEDURE;
DO FOREVER;
CALL DEBLANK;
CH = BYTE(TEXT, CP);
IF CH \= BYTE ('(') THEN RETURN;
/* (BASE WIDTH) */
CALL DEBLANK;
JBASE = BYTE (TEXT, CP) - BYTE ('0'); /* WIDTH */
IF JBASE < 1 ^ JBASE > 4 THEN
DO;
CALL ERROR ('ILLEGAL BIT STRING WIDTH: ' ^^ SUBSTR(TEXT,CP,1),0);
JBASE = 4; /* DEFAULT WIDTH FOR ERROR */
END;
BASE = SHL(1, JBASE);
CALL DEBLANK;
IF BYTE(TEXT,CP)\=BYTE(')')THEN CALL ERROR('MISSING ) IN BIT STRING',0);
END;
END BCHAR;
LOWUP: /* CONVERT S TO UPPER CASE */
PROCEDURE (S) CHARACTER;
DECLARE (S,T) CHARACTER;
T = '';
DO I = 0 TO LENGTH(S)-1;
IF BYTE(S,I) > 96 THEN
T = T ^^ SUBSTR(ALPHABET,BYTE(S,I)-97,1);
ELSE
T = T ^^ SUBSTR(S,I,1);
END;
RETURN T;
END LOWUP;
SCAN:
PROCEDURE; /* GET THE NEXT TOKEN FROM THE TEXT */
DECLARE S1 FIXED, S2 FIXED;
DECLARE LSTRNGM CHARACTER INITIAL ('STRING TOO LONG');
DECLARE LBITM CHARACTER INITIAL ('BIT STRING TOO LONG');
COUNT_SCAN = COUNT_SCAN + 1;
FAILSOFT = TRUE;
BCD = ''; NUMBER_VALUE = 0;
RESCAN:
IF CP > TEXT_LIMIT THEN
DO;
TEXT = '';
CALL GET_CARD;
END;
ELSE
DO;
TEXT_LIMIT = TEXT_LIMIT - CP;
TEXT = SUBSTR(TEXT, CP);
END;
CP = 0;
/* BRANCH ON NEXT CHARACTER IN TEXT */
DO CASE CHARTYPE(BYTE(TEXT));
/* CASE 0 */
/* ILLEGAL CHARACTERS FALL HERE */
CALL ERROR ('ILLEGAL CHARACTER: ' ^^ SUBSTR (TEXT, 0, 1) ^^
' (' ^^ BYTE(TEXT) ^^ ')', 0);
/* CASE 1 */
/* BLANK */
DO CP = 1 TO TEXT_LIMIT;
IF BYTE (TEXT, CP) \= BYTE (' ') THEN GOTO RESCAN;
END;
/* CASE 2 */
DO FOREVER; /* STRING QUOTE ('): CHARACTER STRING */
TOKEN = STRING;
DO CP = CP + 1 TO TEXT_LIMIT;
IF BYTE (TEXT, CP) = BYTE ('''') THEN
DO;
IF LENGTH(BCD) + CP > 257 THEN
DO;
CALL ERROR (LSTRNGM, 0);
RETURN;
END;
IF CP > 1 THEN
BCD = BCD ^^ SUBSTR(TEXT, 1, CP-1);
CALL CHAR;
IF BYTE (TEXT, CP) = BYTE ('''') THEN
IF LENGTH(BCD) = 255 THEN
DO;
CALL ERROR (LSTRNGM, 0);
RETURN;
END;
ELSE
DO;
BCD = BCD ^^ SUBSTR(TEXT, CP, 1);
GO TO RESCAN;
END;
RETURN;
END;
END;
/* WE HAVE RUN OFF A CARD */
IF LENGTH(BCD) + CP > 257 THEN
DO;
CALL ERROR (LSTRNGM, 0);
RETURN;
END;
IF CP > 1 THEN BCD = BCD ^^ SUBSTR(TEXT, 1, CP-1);
TEXT = X1;
CP = 0;
CALL GET_CARD;
END;
/* CASE 3 */
DO; /* BIT QUOTE("): BIT STRING */
JBASE = 4; BASE = 16; /* DEFAULT WIDTH */
TOKEN = NUMBER;
S1 = 0;
CALL BCHAR;
DO WHILE CH \= BYTE ('"');
S1 = S1 + JBASE;
IF CH >= BYTE ('0') & CH <= BYTE ('9') THEN S2 = CH - BYTE ('0');
ELSE S2 = CH + 10 - BYTE ('A');
IF S2 >= BASE ^ S2 < 0 THEN
CALL ERROR ('ILLEGAL CHARACTER IN BIT STRING: '
^^ SUBSTR(TEXT, CP, 1), 0);
IF S1 > 36 THEN TOKEN = STRING;
IF TOKEN = STRING THEN
DO WHILE S1 - JBASE >= 9;
IF LENGTH(BCD) >= 255 THEN
DO;
CALL ERROR ( LBITM, 0);
RETURN;
END;
S1 = S1 - 9;
CALL BUILD_BCD (SHR(NUMBER_VALUE, S1-JBASE));
END;
NUMBER_VALUE = SHL(NUMBER_VALUE, JBASE) + S2;
CALL BCHAR;
END; /* OF DO WHILE CH... */
CP = CP + 1;
IF TOKEN = STRING THEN
IF LENGTH(BCD) >= 255 THEN CALL ERROR (LBITM,0);
ELSE CALL BUILD_BCD (SHL(NUMBER_VALUE, 9 - S1));
RETURN;
END;
/* CASE 4 */
DO FOREVER; /* A LETTER: IDENTIFIERS AND RESERVED WORDS */
DO CP = CP + 1 TO TEXT_LIMIT;
IF NOT_LETTER_OR_DIGIT(BYTE(TEXT, CP)) THEN
DO; /* END OF IDENTIFIER */
BCD = LOWUP(SUBSTR(TEXT, 0, CP));
IF CP > 1 THEN IF CP <= RESERVED_LIMIT THEN
/* CHECK FOR RESERVED WORDS */
DO I = 1 TO TERMINAL#;
IF BCD = VOCAB(I) THEN
DO;
TOKEN = I;
RETURN;
END;
END;
DO I = MACRO_INDEX(CP-1) TO MACRO_INDEX(CP) - 1;
IF BCD = MACRO_NAME(I) THEN
DO;
MACRO_COUNT(I) = MACRO_COUNT(I) + 1;
BCD = MACRO_TEXT(I);
IF EXPANSION_COUNT < EXPANSION_LIMIT THEN
EXPANSION_COUNT = EXPANSION_COUNT + 1;
ELSE CALL PRINTLINE ('** WARNING, TOO MANY EXPANSIONS FOR
THE MACRO: ' ^^ BCD,-1);
TEXT = SUBSTR(TEXT, CP);
TEXT_LIMIT = TEXT_LIMIT - CP;
IF LENGTH(BCD) + TEXT_LIMIT > 255 THEN
DO;
IF LB + TEXT_LIMIT > 255 THEN
CALL ERROR('MACRO EXPANSION TOO LONG',0);
ELSE
DO;
BALANCE = TEXT ^^ BALANCE;
LB = LENGTH(BALANCE);
TEXT = BCD;
END;
END;
ELSE TEXT = BCD ^^ TEXT;
BCD = '';
TEXT_LIMIT = LENGTH(TEXT) - 1;
CP = 0;
GO TO RESCAN;
END;
END;
/* RESERVED WORDS EXIT HIGHER: THEREFORE <IDENTIFIER> */
TOKEN = IDENT;
RETURN;
END;
END;
/* END OF CARD */
CALL GET_CARD;
CP = CP - 1;
END;
/* CASE 5 */
DO FOREVER; /* DIGIT: A NUMBER */
TOKEN = NUMBER;
DO CP = CP TO TEXT_LIMIT;
S1 = BYTE(TEXT, CP);
IF S1 < BYTE ('0') ^ S1 > BYTE ('9') THEN RETURN;
NUMBER_VALUE = 10 * NUMBER_VALUE + S1 - BYTE ('0');
END;
CALL GET_CARD;
END;
/* CASE 6 */
DO; /* A /: MAY BE DIVIDE OR START OF COMMENT */
CALL CHAR;
IF BYTE (TEXT, CP) \= BYTE ('*') THEN
DO;
TOKEN = DIVIDE;
RETURN;
END;
/* WE HAVE A COMMENT */
S1, S2 = BYTE (' ');
DO WHILE S1 \= BYTE ('*') ^ S2 \= BYTE ('/');
IF S1 = BYTE ('$') THEN /* A CONTROL CHAR */
CONTROL(S2) = \CONTROL(S2) & 1;
S1 = S2;
CALL CHAR;
S2 = BYTE(TEXT, CP);
END;
END;
/* CASE 7 */
DO; /* SPECIAL CHARACTERS */
TOKEN = TX(BYTE(TEXT));
CP = 1;
RETURN;
END;
/* CASE 8 */
DO; /* A ^: MAY BE ^ OR ^^ */
CALL CHAR;
IF BYTE(TEXT, CP) = BYTE('^') THEN
DO;
CALL CHAR;
TOKEN = CONCATENATE;
END;
ELSE TOKEN = ORSYMBOL;
RETURN;
END;
END; /* OF CASE ON CHARTYPE */
CP = CP + 1; /* ADVANCE SCANNER AND RESUME SEARCH FOR TOKEN */
GO TO RESCAN;
END SCAN;
/*
C O D E E M I S S I O N P R O C E D U R E S
*/
FLUSH_DATA_BUFFER:
PROCEDURE;
/* CLEAN OUT THE DATA BUFFER AND STICK ALL CURRENT CONTENTS
INTO THE REL FILE */
DECLARE I FIXED, J FIXED;
IF (DPTR+DCTR) > 1 THEN
DO;
J = (DPTR/19)*18 + DCTR -1;
FILE(RELFILE) = CODE_TYPE + J;
I = DPTR+DCTR-1;
DO J = 0 TO I;
FILE(RELFILE) = DATA_BUFFER(J);
END;
END;
DPTR = 0;
DCTR = 1;
END FLUSH_DATA_BUFFER;
FLUSH_CODE_BUFFER:
PROCEDURE;
/* CLEAN OUT THE CODE BUFFER AND STICK ALL CURRENT CONTENTS
INTO THE REL FILE */
DECLARE I FIXED, J FIXED;
IF (RPTR+RCTR) > 1 THEN
DO;
I = (RPTR/19)*18 + RCTR -1;
J = RPTR+RCTR-1;
FILE (RELFILE) = CODE_TYPE+I;
DO I = 0 TO J;
FILE(RELFILE) = CODE_BUFFER(I);
END;
END;
RPTR = 0;
RCTR = 1;
END FLUSH_CODE_BUFFER;
RADIX50:
PROCEDURE (SYMBOL);
/* PROCEDURE TO RETURN THE RADIX-50 REPRESENTATION OF A SYMBOL.
ONLY THE FIRST 6 CHARACTERS ARE USED. */
DECLARE SYMBOL CHARACTER;
DECLARE (I,J,K,L) FIXED;
J = 0;
IF LENGTH(SYMBOL) < 6 THEN SYMBOL = SYMBOL ^^ X7;
DO L = 0 TO 5;
I = BYTE(SYMBOL,L);
IF I = BYTE(' ') THEN K = 0;
ELSE IF I = BYTE ('.') THEN K = "(3)45";
ELSE IF I = BYTE ('$') THEN K = "(3)46";
ELSE IF I = BYTE ('%') THEN K = "(3)47";
ELSE IF I >= BYTE ('0') & I <= BYTE ('9') THEN
K = I-BYTE('0') + "(3)1";
ELSE IF I >= BYTE ('A') & I <= BYTE ('Z') THEN
K = I - BYTE ('A') + "(3)13";
ELSE RETURN J;
J = J * "(3)50" + K;
END;
RETURN J;
END RADIX50;
OUTPUT_CODEWORD:
PROCEDURE;
/* SPIT OUT THE INSTRUCTION AT CODEXXX(CODE_TAIL) */
IF CODE_FULL(CODE_TAIL) THEN
DO;
IF CONTROL(BYTE('A')) THEN OUTPUT (CODEFILE) = CODE (CODE_TAIL);
IF RCTR+RPTR = 1 THEN
DO;
CODE_BUFFER(0) =SHL(1,34);
CODE_BUFFER(1) = CODE_PP(CODE_TAIL) + "(3)400000";
RCTR = RCTR +1;
END;
CODE_BUFFER(RPTR) = SHL(CODE_RBITS(CODE_TAIL),36-RCTR*2)^CODE_BUFFER(RPTR);
CODE_BUFFER(RPTR+RCTR) = CODE_REL(CODE_TAIL);
RCTR = RCTR +1;
IF RPTR+RCTR > BUFFERSIZE THEN CALL FLUSH_CODE_BUFFER;
IF RCTR > 18 THEN
DO;
RPTR = RPTR +19;
RCTR = 1;
CODE_BUFFER(RPTR) = 0;
END;
END;
CODE_FULL(CODE_TAIL) = FALSE;
CODE_TAIL = (CODE_TAIL+1) & 3;
END OUTPUT_CODEWORD;
FLUSH_LABELS:
PROCEDURE;
/* CLEAN OUT LABEL BUFFER BY GENERATING INTERNAL REQUEST
TYPE BLOCK AND DEFINING ALL LABELS NOW KNOWN */
DECLARE I FIXED;
IF LABEL_COUNT = 0 THEN RETURN;
DO WHILE CODE_TAIL \= CODE_HEAD;
CALL OUTPUT_CODEWORD;
END;
CALL OUTPUT_CODEWORD;
CODE_TAIL = CODE_HEAD; /* RESET POINTERS, SINCE BUFFERS NOW EMPTY */
STILLCOND, STILLINZERO = 0; /* MAKE SURE PEEPHOLE WORKS */
CALL FLUSH_CODE_BUFFER;
FILE (RELFILE) = INTREQ_TYPE+LABEL_COUNT;
DO I = 0 TO LABEL_COUNT;
FILE (RELFILE) = LABEL_BUFFER(I);
END;
LABEL_COUNT = 0;
LABEL_BUFFER(0) = 0;
END FLUSH_LABELS;
OUTPUT_DATAWORD:
PROCEDURE (W,LOC);
/* OUTPUT A WORD TO THE LOW SEGMENT */
DECLARE W FIXED, LOC FIXED;
IF (DPTR+DCTR)>BUFFERSIZE ^ DLOC \= LOC THEN CALL FLUSH_DATA_BUFFER;
IF DPTR+DCTR = 1 THEN
DO;
DATA_BUFFER(0) = "(3)200000000000";
DATA_BUFFER(1) = LOC;
DATA_BUFFER(2) = W;
DLOC = LOC + 1;
DCTR = DCTR + 2;
RETURN;
END;
DATA_BUFFER (DPTR+DCTR) = W;
DCTR = DCTR +1;
DLOC = DLOC + 1;
IF DPTR+DCTR > BUFFERSIZE THEN CALL FLUSH_DATA_BUFFER;
IF DCTR > 18 THEN
DO;
DCTR = 1;
DPTR = DPTR + 19;
DATA_BUFFER(DPTR) = 0;
END;
END OUTPUT_DATAWORD;
FLUSH_DATACARD:PROCEDURE;
IF CONTROL(BYTE('A')) ^ CONTROL(BYTE('B')) THEN
DO;
DATACARD = DATACARD ^^ '; D' ^^ DP;
IF CONTROL(BYTE('A')) THEN OUTPUT (DATAFILE) = DATACARD;
IF CONTROL(BYTE('B')) THEN CALL PRINTLINE (DATAMSG ^^ DATACARD,-1);
END;
CALL OUTPUT_DATAWORD (PWORD,DP);
PWORD = 0;
DPOFFSET = 0;
DP = DP + 1;
END FLUSH_DATACARD;
EMITBLOCK:
PROCEDURE (I);
/* RESERVE A BLOCK OF I WORDS */
DECLARE I FIXED;
IF CONTROL(BYTE('A')) ^ CONTROL(BYTE('B')) THEN
DO;
DATACARD = ' REPEAT ' ^^ I ^^ ',<0>; D' ^^ DP;
IF CONTROL(BYTE('A')) THEN OUTPUT (DATAFILE) = DATACARD;
IF CONTROL(BYTE('B')) THEN CALL PRINTLINE (DATAMSG ^^ DATACARD,-1);
END;
DP = DP + I;
END EMITBLOCK;
EMITDATAWORD:
PROCEDURE (W);
DECLARE W FIXED;
/* SEND AN 80 CHARACTER CARD TO THE DATA FILE */
IF DPOFFSET > 0 THEN CALL FLUSH_DATACARD;
IF CONTROL(BYTE('A')) ^ CONTROL(BYTE('B')) THEN
DO;
DATACARD = X7 ^^ W ^^ '; D' ^^ DP;
IF CONTROL(BYTE('A')) THEN OUTPUT (DATAFILE) = DATACARD;
IF CONTROL(BYTE('B')) THEN CALL PRINTLINE (DATAMSG ^^ DATACARD,-1);
END;
CALL OUTPUT_DATAWORD(W,DP);
DP = DP + 1;
END EMITDATAWORD;
EMITBYTE:
PROCEDURE (C);
DECLARE C FIXED;
/* SEND ONE 9-BIT BYTE TO THE DATA AREA */
IF CONTROL(BYTE('A')) ^ CONTROL(BYTE('B')) THEN
IF DPOFFSET = 0 THEN DATACARD = ' BYTE (9)'^^ C;
ELSE DATACARD = DATACARD ^^ ',' ^^ C;
PWORD = PWORD + SHL(C&"(3)777",9*(3-DPOFFSET));
DPOFFSET = DPOFFSET + 1;
IF DPOFFSET = 4 THEN CALL FLUSH_DATACARD;
END EMITBYTE;
EMITCONSTANT:
PROCEDURE (C);
DECLARE C FIXED;
DECLARE CTAB (100) FIXED, CADD (100) FIXED, NC FIXED, I FIXED;
/* SEE IF C HAS ALREADY BEEN EMITED, AND IF NOT, EMIT IT. SET UP ADR. */
DO I = 1 TO NC; /* STEP THRU THE CONSTANTS */
IF CTAB (I) = C THEN
DO;
ADR = CADD (I);
RETURN;
END;
END;
CTAB (I) = C;
CALL EMITDATAWORD (C);
ADR, CADD (I) = DP - 1;
IF I < 100 THEN NC = I;
IF CONTROL(BYTE('C')) THEN CALL PRINTLINE ('* CONSTANT ' ^^ NC ^^ ' = ' ^^ C,-1);
ELSE IF CONTROL(BYTE('L')) THEN INFO=INFO^^ ' C'^^ NC ^^' = ' ^^ C;
END EMITCONSTANT;
EMITCODEWORD:PROCEDURE (W,WORD,RBITS);
DECLARE W CHARACTER;
DECLARE WORD FIXED;
DECLARE RBITS FIXED;
/* SEND AN 80 CHARACTER CODE CARD TO THE BUFFER AREA */
CODE_HEAD = (CODE_HEAD+1) & 3;
IF CODE_HEAD = CODE_TAIL THEN CALL OUTPUT_CODEWORD;
IF CONTROL(BYTE('A')) ^ CONTROL(BYTE('E')) THEN
CODE(CODE_HEAD) = LABEL_GEN ^^ W;
IF CONTROL(BYTE('E')) THEN
CALL PRINTLINE (CODEMSG ^^ CODE(CODE_HEAD),-1);
CODE_REL(CODE_HEAD) = WORD;
CODE_PP(CODE_HEAD) = PP;
CODE_RBITS(CODE_HEAD) = RBITS;
CODE_FULL(CODE_HEAD) = TRUE;
LABEL_GEN = '';
STILLCOND, STILLINZERO = 0;
PP = PP + 1;
END EMITCODEWORD;
OUTPUTLABEL:
PROCEDURE (J);
DECLARE J FIXED;
LABEL_COUNT = LABEL_COUNT+1;
LABEL_BUFFER(0) = SHL(3,36-LABEL_COUNT*2)^LABEL_BUFFER(0);
LABEL_BUFFER(LABEL_COUNT) = J;
IF(LABEL_COUNT >= BUFFERSIZE) THEN CALL FLUSH_LABELS;
END OUTPUTLABEL;
EMITLABEL:PROCEDURE(L,R);
DECLARE L FIXED;
DECLARE R FIXED;
DECLARE I FIXED;
DECLARE J FIXED;
IF R = 3 THEN
DO;
IF DESCREF(L) = 0 THEN RETURN;
J = SHL(DESCREF(L),18) + DP;
CALL OUTPUTLABEL(J);
DESCREF(L) = 0;
RETURN;
END;
STILLINZERO = 0; /* DON'T TRY OPTIMIZING OVER LABEL */
J = SHL(R,18) + L;
DO I = 1 TO FOR_COUNT;
IF J = FOR_LABEL(I) THEN
DO;
J = SHL(FOR_REF(I)+"(3)400000",18);
IF R = 4 THEN J = J + PP + "(3)400000";
ELSE J = J + DP;
CALL OUTPUTLABEL(J);
J = I;
DO WHILE J < FOR_COUNT;
FOR_LABEL(J) = FOR_LABEL(J+1);
FOR_REF(J) = FOR_REF(J+1);
J = J + 1;
END;
FOR_LABEL(FOR_COUNT) = 0;
FOR_REF(FOR_COUNT) = 0;
FOR_COUNT = FOR_COUNT -1;
/* PUT A LABEL ON THE NEXT INSTRUCTION GENERATED */
IF R = 4 & (CONTROL(BYTE('A')) ^ CONTROL(BYTE('E'))) THEN
LABEL_GEN = LABEL_GEN ^^ '$' ^^ L ^^ ':';
RETURN;
END;
END;
IF R = 4 & (CONTROL(BYTE('A')) ^ CONTROL(BYTE('E'))) THEN
LABEL_GEN = LABEL_GEN ^^ '$' ^^ L ^^ ':';
RETURN;
END EMITLABEL;
REFCHECK:
PROCEDURE (I);
/* CHECK TO SEE IF THIS SATISFIES ANY FORWARD REFERENCES.
IF SO, SET UP LABEL BUFFER. IF NOT, CHECK IF THIS
SHOULD BE CHAINED. */
DECLARE I FIXED;
DECLARE J FIXED;
IF SHR(I,18) = 3 THEN
DO;
I = I & "(3)777777";
J = DESCREF(I);
DESCREF(I) = PP + "(3)400000";
RETURN J;
END;
J = 1;
DO WHILE J <= FOR_COUNT;
IF FOR_LABEL(J) = I THEN
DO;
I = FOR_REF(J) + "(3)400000";
FOR_REF(J) = PP;
RETURN I;
END;
J=J+1;
END;
FOR_COUNT = FOR_COUNT +1;
IF FOR_COUNT > FOR_MAX THEN CALL ERROR ('TOO MANY FORWARD REFERENCES',3);
FOR_REF(FOR_COUNT) = PP;
FOR_LABEL(FOR_COUNT) = I;
RETURN 0;
END REFCHECK;
EMITINST:PROCEDURE (OPCODE,TREG,INDIRECT,OPERAND,IREG,RELOCATION);
DECLARE OPCODE FIXED,
TREG FIXED,
INDIRECT FIXED,
OPERAND FIXED,
IREG FIXED,
RELOCATION FIXED;
DECLARE RBITS FIXED,
WORD FIXED;
/* EMIT A 80 CHARACTER INSTRUCTION IMAGE */
DECLARE RELOC (5) CHARACTER
INITIAL ('', 'D+', 'P+', 'S+', '$', '$');
DECLARE I FIXED,
J FIXED,
CARD CHARACTER,
INDIR (1) CHARACTER INITIAL ('', '@');
COUNT_INST = COUNT_INST + 1;
WORD = SHL(OPCODE,27) + SHL(TREG&"F",23) + SHL(INDIRECT&1,22)
+ SHL(IREG&"F",18);
DO CASE RELOCATION;
/* CASE 0 : ABSOLUTE ADDRESS - NO RELOCATION */
DO;
WORD = WORD + (OPERAND&"(3)777777");
RBITS = 0;
END;
/* CASE 1 : RELATIVE TO THE BEGINNING OF DATA SEGMENT */
DO;
WORD = WORD + (OPERAND&"(3)777777");
RBITS = 1;
END;
/* CASE 2 : RELATIVE TO BEGINNING OF CODE SEGMENT */
DO;
WORD = WORD + (OPERAND&"(3)777777") + "(3)400000";
RBITS = 1;
END;
/* CASE 3 : RELATIVE TO BEGINNING OF STRINGS */
DO;
I = SHL(RELOCATION,18) + (OPERAND&"(3)777777");
J = REFCHECK(I);
WORD = WORD + J;
IF J = 0 THEN RBITS = 0;
ELSE RBITS = 1;
END;
/* CASE 4 : FORWARD LABEL REFERENCE IN CODE AREA */
DO;
J = REFCHECK("(3)4000000" + (OPERAND&"(3)777777"));
WORD = WORD + J;
IF J = 0 THEN RBITS = 0;
ELSE RBITS = 1;
END;
/* CASE 5 : FORWARD LABEL REFERENCE IN DATA AREA */
DO;
J = REFCHECK("(3)5000000" + (OPERAND&"(3)777777"));
WORD = WORD + J;
IF J = 0 THEN RBITS = 0;
ELSE RBITS = 1;
END;
END; /* END OF DO CASE RELOCATION */
IF CONTROL(BYTE('A')) ^ CONTROL(BYTE('E')) THEN
DO;
I = SHR(OPCODE,5);
CARD = X7 ^^ SUBSTR(OPNAME(I),(OPCODE-I*32)*6,6) ^^ X1 ^^TREG ^^ ','
^^ INDIR(INDIRECT) ^^ RELOC(RELOCATION) ^^ OPERAND;
IF IREG > 0 THEN CARD = CARD ^^ '(' ^^ IREG ^^ ')';
CARD = CARD ^^ '; P' ^^ PP;
END;
INSTRUCT(OPCODE) = INSTRUCT(OPCODE) + 1;
CALL EMITCODEWORD (CARD,WORD,RBITS);
END EMITINST;
EMITDESC:PROCEDURE (L,A);
DECLARE L FIXED,
A FIXED;
/* SEND A LENGTH AND STRING ADDRESS TO THE DESCRIPTOR AREA */
IF DSP > DESCLIMIT THEN
DO;
CALL ERROR ('TOO MANY STRINGS',1);
DSP = 0;
END;
IF CONTROL(BYTE('B')) THEN
CALL PRINTLINE (X70 ^^ 'DESC = ' ^^ L ^^ ',' ^^ A ^^ '; S' ^^ DSP,-1);
DESCL(DSP) = L;
DESCA(DSP) = A;
DSP = DSP + 1;
END EMITDESC;
FINDLABEL:PROCEDURE;
LABEL_SINK = LABEL_SINK + 1;
RETURN (LABEL_SINK);
END FINDLABEL;
/*
S Y M B O L T A B L E P R O C E D U R E S
*/
HASHER:
PROCEDURE (ID); /* CALCULATE HASH INDEX INTO HASH TABLE*/
DECLARE ID CHARACTER;
DECLARE L FIXED;
L = LENGTH (ID);
RETURN (BYTE (ID) + BYTE (ID, L-1) + SHL (L,4)) & "FF";
END HASHER;
ENTER:PROCEDURE (N, T, L, S);
DECLARE T FIXED, L FIXED, S FIXED;
DECLARE N CHARACTER;
/* ENTER THE NAME N IN THE SYMBOL TABLE WITH TYPE T AT LOCATION L SEGMENT S */
DECLARE I FIXED, K FIXED;
IDX = HASHER (N);
I = HASH (IDX);
DO WHILE I >= PROCMARK;
IDCOMPARES = IDCOMPARES + 1;
IF N = SYT (I) THEN
DO;
K = SYTYPE (I);
IF T = LABELTYPE & (K = FORWARDTYPE ^ K = FORWARDCALL) THEN
DO;
IF CONTROL (BYTE ('E')) THEN
CALL PRINTLINE (X70 ^^ 'FIXED REFERENCES TO: ' ^^ N,-1);
IF K = FORWARDTYPE THEN
DO;
CALL EMITLABEL(SYTLOC(I),4);
SYTLOC(I) = L;
SYTSEG(I) = S;
END;
SYTYPE (I) = T;
END;
ELSE IF PROCMARK + PARCT < I THEN
CALL ERROR ('DUPLICATE DECLARATION FOR: ' ^^ N, 0);
RETURN I;
END;
I = PTR (I);
END;
NDECSY = NDECSY + 1;
IF NDECSY > MAXNDECSY THEN
IF NDECSY > SYTSIZE THEN
DO;
CALL ERROR ('SYMBOL TABLE OVERFLOW', 1);
NDECSY = NDECSY - 1;
END;
ELSE MAXNDECSY = NDECSY;
SYT (NDECSY) = N;
SYTYPE (NDECSY) = T;
SYTLOC (NDECSY) = L;
SYTSEG (NDECSY) = S;
SYTCO (NDECSY) = 0;
SYTCARD (NDECSY) = CARD_COUNT;
PTR (NDECSY) = HASH (IDX);
HASH (IDX) = NDECSY;
RETURN (NDECSY);
END ENTER;
ID_LOOKUP:
PROCEDURE (P);
/* LOOKS UP THE IDENTIFIER AT P IN THE ANALYSIS STACK IN THE
SYMBOL TABLE AND INITIALIZES FIXL, CNT, TYPE, AND INX
APPROPRIATELY. IF THE IDENTIFIER IS NOT FOUND, FIXL IS
SET TO -1
*/
DECLARE P FIXED, I FIXED;
CHAR_TEMP = VAR (P);
I = HASH (HASHER (CHAR_TEMP));
DO WHILE I \= -1;
IDCOMPARES = IDCOMPARES + 1;
IF SYT(I) = CHAR_TEMP THEN
DO;
FIXL (P) = I;
CNT (P) = 0; /* INITIALIZE SUBSCRIPT COUNT */
TYPE (P) = VARIABLE;
IF SYTYPE (I) = SPECIAL THEN
FIXV (P) = SYTLOC (I); /* BUILTIN FUNCTION */
ELSE
FIXV (P) = 0;
INX (P) = 0; /* LOCATION OF INDEX */
REG(P) = 0;
SYTCO (I) = SYTCO (I) + 1;
RETURN;
END;
I = PTR (I);
END;
FIXL (P) = -1; /* IDENTIFIER NOT FOUND */
END ID_LOOKUP;
UNDECLARED_ID:
PROCEDURE (P);
/* ISSUES AN ERROR MESSAGE FOR UNDECLARED IDENTIFIERS AND
ENTERS THEM WITH DEFAULT TYPE IN THE SYMBOL TABLE
*/
DECLARE P FIXED;
CALL ERROR ('UNDECLARED IDENTIFIER: ' ^^ VAR (P), 0);
CALL EMITDATAWORD (0);
FIXL (P) = ENTER (VAR (P), FIXEDTYPE, DP-1, 1);
CNT (P) = 0;
FIXV (P) = 0;
INX (P) = 0;
SYTCO (NDECSY) = 1; /* COUNT FIRST REFERENCE */
SYTCARD (NDECSY) = -1; /* FLAG UNDECLARED IDENTIFIER */
TYPE (P) = VARIABLE;
END UNDECLARED_ID;
/*
A R I T H E M E T I C P R O C E D U R E S
*/
CLEARARS:
PROCEDURE;
/* FREE ALL THE TEMPROARY ARITHEMETIC REGISTERS */
DO I = 0 TO 11;
ACC(I) = AVAIL;
END;
END CLEARARS;
FINDAR:
PROCEDURE;
DECLARE I FIXED;
/* GET A TEMPORARY ARITHEMETIC REGISTER */
IF TARGET_REGISTER > -1 THEN
IF ACC (TARGET_REGISTER) = AVAIL THEN
DO;
ACC (TARGET_REGISTER) = BUSY;
RETURN TARGET_REGISTER;
END;
DO I = 1 TO 11;
IF ACC(I) = AVAIL THEN
DO;
ACC(I) = BUSY;
RETURN (I);
END;
END;
CALL ERROR ('USED ALL ACCUMULATORS', 0);
RETURN (0);
END FINDAR;
MOVESTACKS:
PROCEDURE (F, T);
DECLARE F FIXED, T FIXED;
/* MOVE ALL COMPILER STACKS DOWN FROM F TO T */
TYPE (T) = TYPE (F);
REG (T) = REG (F);
CNT (T) = CNT (F);
VAR (T) = VAR (F);
FIXL (T) = FIXL (F);
FIXV (T) = FIXV (F);
INX (T) = INX (F);
PPSAVE (T) = PPSAVE (F);
END MOVESTACKS;
FORCEADDRESS:
PROCEDURE(SP);
/* GENERATES THE ADDRESS OF <VARIABLE> IN THE ANALYSIS STACK
AT SP.
*/
DECLARE SP FIXED, J FIXED, R FIXED;
R = FINDAR;
J = FIXL(SP);
CALL EMITINST (MOVEI,R,0,SYTLOC(J),0,SYTSEG(J));
REG(J) = R;
END FORCEADDRESS;
SETINIT:
PROCEDURE;
/* PLACES INITIAL VALUES INTO DATA AREA */
DECLARE TMIIIL CHARACTER INITIAL ('TOO MANY ITEMS IN INITIAL LIST');
IF ITYPE = CHRTYPE THEN
DO;
IF DSP < NEWDSP THEN
DO;
IF TYPE (MPP1) \= CHRTYPE THEN S = FIXV (MPP1);
ELSE S = VAR (MPP1); /* THE STRING */
I = LENGTH (S);
IF I = 0 THEN
CALL EMITDESC (0,0);
ELSE
DO;
CALL EMITDESC (I, DPOFFSET+SHL(DP,2));
DO J = 0 TO I - 1;
CALL EMITBYTE (BYTE (S, J));
END;
END;
END;
ELSE CALL ERROR (TMIIIL,0);
END;
ELSE
IF TYPE (MPP1) \= CONSTANT THEN
CALL ERROR ('ILLEGAL CONSTANT IN INITIAL LIST',0);
ELSE
IF ITYPE = FIXEDTYPE THEN
DO;
IF DP < NEWDP THEN CALL EMITDATAWORD (FIXV(MPP1));
ELSE CALL ERROR (TMIIIL,0);
END;
ELSE /* MUST BE BYTETYPE */
IF DP < NEWDP ^ (DP = NEWDP & DPOFFSET < NEWDPOFFSET) THEN
CALL EMITBYTE(FIXV(MPP1));
ELSE CALL ERROR (TMIIIL,0);
END SETINIT;
SAVE_ACS:
PROCEDURE (N);
/* GENERATE CODE TO SAVE BUSY ACS, UP TO AC-N */
DECLARE N FIXED;
DECLARE I FIXED;
DO I = 1 TO N;
IF (ACC(I) = BUSY) THEN CALL EMITINST (PUSH,15,0,I,0,0);
END;
END SAVE_ACS;
RESTORE_ACS:
PROCEDURE (N);
/* GENERATE CODE TO RESTORE BUSY ACS, UP TO AC-N */
DECLARE N FIXED;
DECLARE I FIXED, J FIXED;
DO I = 1 TO N;
J = N - I + 1;
IF (ACC(J) = BUSY) THEN CALL EMITINST (POP,15,0,J,0,0);
END;
END RESTORE_ACS;
PROC_START:
PROCEDURE;
/* GENERATES CODE FOR THE HEAD OF A PROCEDURE */
PPSAVE(MP) = FINDLABEL; /* SOMETHING TO GOTO */
CALL EMITINST (JRST,0,0,PPSAVE(MP),0,4); /* GO AROUND PROC */
IF SYTSEG(FIXL(MP)) = 4 THEN CALL EMITLABEL(SYTLOC(FIXL(MP)),4);
SYTSEG(FIXL(MP)) = 2;
SYTLOC(FIXL(MP)) = PP; /* ADDR OF PROC */
END PROC_START;
TDECLARE:
PROCEDURE (DIM);
/* ALLOCATES STORAGE FOR IDENTIFIERS IN DECLARATION */
DECLARE DIM FIXED;
DECLARE I FIXED;
ALLOCATE:
PROCEDURE (P, DIM);
/* ALLOCATES STORAGE FOR THE IDENTIFIER AT P IN THE ANALYSIS
STACK WITH DIMENSION DIM
*/
DECLARE P FIXED, DIM FIXED, J FIXED, K FIXED;
DIM = DIM + 1; /* ACTUAL NUMBER OF ITEMS */
DO CASE TYPE (P);
; /* CASE 0 -- DUMMY */
; /* CASE 1 -- LABEL TYPE */
; /* CASE 2 -- ACCUMULATOR */
; /* CASE 3 -- VARIABLE */
; /* CASE 4 -- CONSTANT */
; /* CASE 5 -- CONDITION */
DO; /* CASE 6 -- CHRTYPE */
J = DSP; K = 3;
NEWDSP = DSP + DIM;
END;
DO; /* CASE 7 -- FIXEDTYPE */
IF DPOFFSET > 0 THEN
DO;
CALL FLUSH_DATACARD;
OLDDP = DP;
OLDDPOFFSET = 0;
END;
J = DP; K = 1;
NEWDP = DP + DIM; NEWDPOFFSET = 0;
END;
DO; /* CASE 8 -- BYTETYPE */
IF DPOFFSET > 0 THEN
IF I = 1 THEN
DO;
CALL FLUSH_DATACARD;
OLDDP = DP; OLDDPOFFSET = 0;
END;
ELSE
DO;
DP = DP + 1; DPOFFSET = 0;
END;
NEWDPOFFSET = DIM MOD 4;
NEWDP = DP + DIM/4;
J = DP; K = 1;
END;
DO; /* CASE 9 -- FORWARDTYPE */
J = FINDLABEL; K = 4;
NEWDP = DP; NEWDPOFFSET = DPOFFSET; /* COPY OLD POINTERS */
END;
; /* CASE 10 -- DESCRIPT */
; /* CASE 11 -- SPECIAL */
; /* CASE 12 -- FORWARDCALL */
; /* CASE 13 -- PROCTYPE */
; /* CASE 14 -- CHARPROCTYPE */
END; /* CASE ON TYPE (P) */
SYTYPE (FIXL(P)) = TYPE (P);
SYTLOC (FIXL (P)) = J;
SYTSEG (FIXL (P)) = K;
END ALLOCATE;
OLDDP = DP;
OLDDSP = DSP;
OLDDPOFFSET = DPOFFSET;
TYPE(MP) = TYPE(SP);
CASEP = FIXL(MP);
DO I = 1 TO INX(MP);
FIXL(MP) = CASESTACK(CASEP+I); /* SYMBOL TABLE POINTER */
CALL ALLOCATE (MP,DIM);
DP = NEWDP;
DSP = NEWDSP;
DPOFFSET = NEWDPOFFSET;
END;
DP = OLDDP;
DSP = OLDDSP;
DPOFFSET = OLDDPOFFSET;
END TDECLARE;
CHECK_STRING_OVERFLOW:
PROCEDURE;
/* GENERATE A CHECK TO SEE IF COMPACTIFY NEEDS TO BE CALLED */
CALL EMITINST (PUSHJ,15,0,STRING_CHECK,0,2);
END CHECK_STRING_OVERFLOW;
CALLSUB:PROCEDURE (SL,F,P);
/* GENERATES CODE TO CALL A FUNCTION OR PROCEDURE AT SL
ALSO DOES HOUSEKEEPING FOR RETURN VALUES
*/
DECLARE SL FIXED, F FIXED, P FIXED;
CALL SAVE_ACS (11);
CALL EMITINST (PUSHJ,15,0,SL,0,SYTSEG(FIXL(P)));
CALL RESTORE_ACS (11);
IF F = 1 THEN
DO; /* MOVE RETURNED VALUE FROM REGISTER ZERO */
I = FINDAR;
IF I \= 0 THEN CALL EMITINST (MOVE,I,0,0,0,0);
TYPE(P) = ACCUMULATOR;
REG(P) = I;
ACC(I) = BUSY;
STILLINZERO = I;
END;
END CALLSUB;
BACKUP:
PROCEDURE;
CODE_FULL(CODE_HEAD) = FALSE;
CODE_HEAD = (CODE_HEAD-1) & 3;
INSTRUCT(MOVE) = INSTRUCT(MOVE) -1;
PP = PP - 1;
STILLINZERO = 0;
IF CONTROL(BYTE('E')) THEN
CALL PRINTLINE (BACKMSG,-1);
END BACKUP;
DELETE_MOVE:
PROCEDURE (P,OP,AC,IND,OPERAND,INDEX,RELOC);
/* CHECK STILLINZERO FLAG TO SEE IF THE DATUM ABOUT TO
BE MOVED IS STILL IN REGISTER ZERO. IF SO, THEN DELETE
THE LAST INSTRUCTION GENERATED (IF A "MOVE"),
AND MOVE IT DIRECTLY FROM 0 TO THE DESRIED DEST.
THIS IS DESIGNED TO ELIMINATE MOST EXTRA MOVES
OF FUNCTION RESULTS. */
DECLARE P FIXED;
DECLARE OP FIXED, AC FIXED, IND FIXED, OPERAND FIXED,
INDEX FIXED, RELOC FIXED;
IF STILLINZERO \= 0 THEN
DO;
IF OP = MOVEM & STILLINZERO = AC THEN
DO;
CALL BACKUP;
ACC(REG(P)) = AVAIL;
REG(P) = 0;
AC = 0;
END;
ELSE IF OP = MOVE & STILLINZERO = OPERAND
& (IND + INDEX + RELOC) = 0 THEN
DO;
CALL BACKUP;
ACC(REG(P)) = AVAIL;
REG(P) = 0;
OPERAND = 0;
END;
END;
CALL EMITINST (OP,AC,IND,OPERAND,INDEX,RELOC);
END DELETE_MOVE;
EMIT_INLINE:
PROCEDURE (FLAG);
/* GENERATE AN ARBITRARY INSTRUCTION SPECIFIED BY PROGRAMMER */
DECLARE FLAG BIT(1);
DECLARE FL FIXED;
DECLARE INST(5) FIXED;
DECLARE BINLM CHARACTER INITIAL ('IMPROPER ARGUMENT TO INLINE');
IF CNT(MP) < 5 THEN
DO;
IF TYPE(MPP1) = CONSTANT THEN INST(CNT(MP)-1) = FIXV(MPP1);
ELSE CALL ERROR (BINLM,1);
IF FLAG THEN CALL ERROR (BINLM,1);
END;
ELSE IF CNT(MP) = 5 THEN
DO;
IF TYPE(MPP1) = CONSTANT THEN
DO;
INST(4) = FIXV(MPP1);
INST(5) = 0;
END;
ELSE IF TYPE(MPP1) = VARIABLE THEN
DO;
FL = FIXL(MPP1);
INST(4) = SYTLOC(FL);
INST(5) = SYTSEG(FL);
END;
ELSE CALL ERROR (BINLM,1);
CALL EMITINST (INST(0),INST(1),INST(2),INST(4),INST(3),INST(5));
REG(MP) = INST(1);
TYPE(MP) = ACCUMULATOR;
END;
ELSE CALL ERROR (BINLM,1); /* TOO MANY ARGS TO INLINE */
END EMIT_INLINE;
LIBRARY_CALL: PROCEDURE (RESULT, CODE, MP, SP);
/*
GENERATE THE CODE FOR A CALL TO THE RUN-TIME ROUTINES.
*/
DECLARE RESULT FIXED, /* 0 = L.H.S. OF = */
CODE FIXED, /* CODE FOR RUN-TIME ROUTINE*/
MP FIXED, /* STACK POINTER */
SP FIXED; /* TOP OF STACK POINTER */
DECLARE R FIXED;
IF RESULT = 0 THEN
DO;
IF STILLINZERO = REG(SP) THEN
DO;
CALL BACKUP;
ACC(REG(SP)) = AVAIL;
REG(SP) = 0;
END;
R = REG(SP);
END;
ELSE
R = FINDAR;
IF CNT(MP) > 0 THEN CALL EMITINST (CODE+1,R,0,0,REG(MP),0);
ELSE CALL EMITINST (CODE+1,R,0,0,0,0);
IF RESULT \= 0 THEN
DO;
REG(MP) = R;
TYPE(MP) = RESULT;
END;
END LIBRARY_CALL;
MONITOR_CALL: PROCEDURE (CODE, P, JOBFLG);
/*
ROUTINE TO GENERATE CODE FOR PDP-10 CALLI UUO.
*/
DECLARE CODE FIXED, /* CALLI NUMBER */
JOBFLG FIXED, /* CLEAR AC FLAG */
P FIXED; /* STACK POINTER*/
DECLARE R FIXED; /* CONTAINS REGISTER TO USE */
R = FINDAR;
IF JOBFLG THEN CALL EMITINST (MOVEI,R,0,0,0,0);
CALL EMITINST (CALLI,R,0,CODE,0,0);
REG(P) = R;
TYPE(P) = ACCUMULATOR;
END MONITOR_CALL;
FORCEACCUMULATOR:PROCEDURE (P);
DECLARE P FIXED;
/* FORCE THE OPERAND AT P INTO AN ACCUMULATOR */
DECLARE SL FIXED, TP FIXED, SFP FIXED, SS FIXED;
DECLARE T1 CHARACTER;
DECLARE R FIXED;
COUNT_FORCE = COUNT_FORCE + 1;
TP = TYPE(P);
IF TP = VARIABLE THEN
DO;
SL = SYTLOC(FIXL(P));
SS = SYTSEG(FIXL(P));
SFP = SYTYPE(FIXL(P));
IF SFP = PROCTYPE ^ SFP = FORWARDCALL ^ SFP = CHARPROCTYPE THEN
DO;
CALL CALLSUB (SL,CALLTYPE,P);
R = FIXL(P)+CNT(P)+1;
IF LENGTH(SYT(R)) = 0 THEN
IF R <= NDECSY THEN
CALL PRINTLINE ('** WARNING--NOT ALL PARAMETERS SUPPLIED.',-1);
IF SFP = CHARPROCTYPE THEN TYPE(P) = DESCRIPT;
END;
ELSE IF SFP = SPECIAL THEN
DO;
IF SL = 6 THEN
DO; /* BUILTIN FUNCTION INPUT */
CALL CHECK_STRING_OVERFLOW;
CALL EMITINST (MOVE,13,0,TSA,0,1);
CALL LIBRARY_CALL (DESCRIPT,1,P,0);
CALL EMITINST (MOVEM,13,0,TSA,0,1);
CALL EMITINST (MOVEM,12,0,STR,0,3);
END;
ELSE IF SL = 8 THEN
DO; /* BUILT-IN FUNCTION FILE */
IF CNT(P) \= 1 THEN CALL ERROR (FILEMSG,0);
ELSE CALL LIBRARY_CALL (ACCUMULATOR,5,P,0);
END;
ELSE IF SL = 12 THEN
DO; /* EXIT */
CALL EMITINST (4,0,0,0,0,0);
END;
ELSE IF SL = 13 THEN CALL MONITOR_CALL (19,P,0);
ELSE IF SL = 14 THEN CALL MONITOR_CALL (12,P,0);
ELSE IF SL = 19 THEN CALL MONITOR_CALL (23,P,1);
ELSE CALL ERROR ('ILLEGAL USE OF ' ^^ SYT(FIXL(P)),0);
END;
ELSE
DO; /* FETCH THE VARIABLE (ALL ELSE HAS FAILED) */
IF SFP \= BYTETYPE THEN
DO; /* WE DON'T HAVE TO DO CRAZY ADDRESSING */
R = FINDAR; /* GET REG FOR RESULT */
CALL EMITINST (MOVE,R,0,SL,INX(P),SS);
END;
ELSE
DO; /* BYTE ADDRESSING */
IF INX(P) \= 0 THEN
DO; /* GOOD GRIEF, SUBSCRIPTING OF BYTES */
R = FINDAR;
CALL EMITINST (MOVE,12,0,INX(P),0,0);
CALL EMITINST (LSH,12,0, -2,0,0);
CALL EMITINST (ANDI,INX(P),0,3,0,0);
IF (SL ^ SS) \= 0 THEN CALL EMITINST (ADDI,12,0,SL,0,SS);
CALL EMITINST (LDB,R,0,BYTEPTRS,INX(P),1);
END;
ELSE
DO; /* NON-SUBSCRIPTED BYTE */
R = FINDAR;
CALL EMITINST (MOVEI,12,0,SL,0,SS);
CALL EMITINST (LDB,R,0,BYTEPTRS,0,1);
END;
END;
IF SFP = CHRTYPE THEN TYPE(P) = DESCRIPT;
ELSE TYPE(P) = ACCUMULATOR;
REG(P) = R;
IF INX(P) \= 0 THEN ACC(INX(P)) = AVAIL;
END;
END;
ELSE IF TP = CONSTANT THEN
DO; /* FETCH A CONSTANT INTO AN ACCUMULATOR */
R = FINDAR;
IF FIXV(P) < "20000" & FIXV(P) > - "20000" THEN
CALL EMITINST (HRREI,R,0,FIXV(P),0,0);
ELSE
DO; /* PUT DOWN A CONSTANT AND PICK IT UP */
CALL EMITCONSTANT (FIXV(P));
CALL EMITINST (MOVE,R,0,ADR,0,1);
END;
REG(P) = R;
TYPE(P) = ACCUMULATOR;
END;
ELSE IF TP = CHRTYPE THEN
DO; /* FETCH A DESCRIPTOR INTO AN ACCUMULATOR */
R = FINDAR;
TYPE(P) = DESCRIPT;
REG(P) = R;
T1 = VAR(P);
SL = LENGTH(T1);
IF SL = 0 THEN CALL EMITINST (MOVEI,R,0,0,0,0);
ELSE
DO; /* GENERATE DESCRIPTOR AND STRING, THEN PICK IT UP */
CALL EMITINST (MOVE,R,0,DSP,0,3);
CALL EMITDESC (SL,SHL(DP,2)+DPOFFSET);
DO SL = 0 TO SL-1;
CALL EMITBYTE (BYTE(T1,SL));
END;
END;
END;
ELSE IF TP \= ACCUMULATOR THEN IF TP \= DESCRIPT THEN
CALL ERROR ('FORCEACCUMULATOR FAILED ***',1);
END FORCEACCUMULATOR;
FORCEDESCRIPTOR:
PROCEDURE (P);
/* GET A DESCRIPTOR FOR THE OPERAND P */
DECLARE P FIXED;
CALL FORCEACCUMULATOR (P);
IF TYPE (P) \= DESCRIPT THEN
DO; /* USE THE NUMBER TO DECIMAL STRING CONVERSION ROUTINE */
CALL DELETE_MOVE (P,MOVEM,REG(P),0,C,0,1); /* SAVE AS C */
ACC(REG(P)) = AVAIL;
CALL SAVE_ACS (1);
CALL EMITINST (PUSHJ,15,0,NMBRENTRY,0,2);
CALL RESTORE_ACS (1);
ACC(REG(P)) = BUSY;
IF REG(P) \= 0 THEN CALL EMITINST (MOVE,REG(P),0,0,0,0);
TYPE (P) = DESCRIPT; /* IT IS NOW A STRING */
STILLINZERO = REG(P);
END;
END FORCEDESCRIPTOR;
GENSTORE:PROCEDURE (MP, SP);
DECLARE MP FIXED, SP FIXED;
/* GENERATE TYPE CONVERSION (IF NECESSARY) & STORAGE CODE --
ALSO HANDLES OUTPUT ON THE LEFT OF THE REPLACEMENT OPERATOR
*/
DECLARE SL FIXED, SFP FIXED, SS FIXED;
COUNT_STORE = COUNT_STORE + 1;
SL = SYTLOC(FIXL(MP));
SS = SYTSEG(FIXL(MP));
SFP = SYTYPE(FIXL(MP));
IF SFP = SPECIAL THEN
DO;
IF SL = 7 THEN
DO; /* BUILTIN FUNCTION OUTPUT */
CALL FORCEDESCRIPTOR(SP);
CALL LIBRARY_CALL (0,2,MP,SP);
END;
ELSE IF SL = 8 THEN
DO; /* BUILTIN FUNCTION FILE */
IF CNT(MP) \= 1 THEN
CALL ERROR (FILEMSG,0);
CALL FORCEACCUMULATOR (SP);
CALL LIBRARY_CALL (0,6,MP,SP);
END;
ELSE IF SL = 20 THEN
DO; /* BUILT-IN FUNCTION FILENAME */
CALL FORCEDESCRIPTOR(SP);
CALL LIBRARY_CALL (0,7,MP,SP);
END;
ELSE CALL ERROR ('ILLEGAL USE OF ' ^^ SYT(FIXL(MP)),0);
END;
ELSE
DO;
IF SFP = CHRTYPE THEN
DO;
CALL FORCEDESCRIPTOR(SP);
CALL DELETE_MOVE (SP,MOVEM,REG(SP),0,SL,INX(MP),SS);
END;
ELSE IF TYPE(SP) = DESCRIPT ^ TYPE(SP) = CHRTYPE THEN
CALL ERROR ('ASSIGNMENT REQUIRES ILLEGAL TYPE CONVERSION.',0);
ELSE
DO; /* FIXEDTYPE OR BYTETYPE */
IF SFP = FIXEDTYPE THEN
DO;
IF TYPE(SP) = CONSTANT & FIXV(SP) = 0 THEN
CALL EMITINST(SETZM,0,0,SL,INX(MP),SS);
ELSE
DO;
CALL FORCEACCUMULATOR(SP);
CALL DELETE_MOVE (SP,MOVEM,REG(SP),0,SL,INX(MP),SS);
END;
END;
ELSE
DO; /* MUST BE BYTETYPE */
CALL FORCEACCUMULATOR(SP);
IF INX(MP) \= 0 THEN
DO; /* GOOD GRIEF, SUBSCRIPTING */
CALL EMITINST (MOVE,12,0,INX(MP),0,0);
CALL EMITINST (LSH,12,0, -2,0,0);
CALL EMITINST (ANDI,INX(MP),0,3,0,0);
IF (SL ^ SS) \= 0 THEN CALL EMITINST (ADDI,12,0,SL,0,SS);
CALL EMITINST (DPB,REG(SP),0,BYTEPTRS,INX(MP),1);
END;
ELSE
DO;
CALL EMITINST (MOVEI,12,0,SL,0,SS);
CALL EMITINST (DPB,REG(SP),0,BYTEPTRS,0,1);
END;
END;
END;
END;
ACC(INX(MP)) = AVAIL;
CALL MOVESTACKS (SP,MP);
END GENSTORE;
SHOULDCOMMUTE:PROCEDURE;
IF TYPE(SP) = CONSTANT THEN RETURN (FALSE);
IF TYPE(MP) = CONSTANT THEN RETURN (TRUE);
IF TYPE(SP) = VARIABLE & SYTYPE(FIXL(SP)) = FIXEDTYPE THEN RETURN (FALSE);
IF TYPE(MP) = VARIABLE & SYTYPE(FIXL(MP)) = FIXEDTYPE THEN RETURN (TRUE);
RETURN FALSE;
END SHOULDCOMMUTE;
ARITHEMIT:PROCEDURE(OP,COMMUTATIVE);
DECLARE OP FIXED, COMMUTATIVE FIXED, TP FIXED;
DECLARE AWASD CHARACTER INITIAL ('ARITHMETIC WITH A STRING DESCRIPTOR');
/* EMIT AN INSTRUCTION FOR AN INFIX OPERATOR -- CONNECT MP & SP */
COUNT_ARITH = COUNT_ARITH + 1;
TP = 0;
IF COMMUTATIVE THEN
IF SHOULDCOMMUTE THEN
DO;
TP = MP; MP = SP; SP = TP;
IF OP >= CAM & OP <= CMPRHI THEN OP = COMPARESWAP(OP-CAM)+CAM;
END;
CALL FORCEACCUMULATOR(MP); /* GET THE LEFT ONE INTO AN ACCUMULATOR */
IF TYPE(MP) = DESCRIPT THEN CALL ERROR (AWASD,0);
ELSE IF TYPE(SP) = VARIABLE & SYTYPE(FIXL(SP)) = FIXEDTYPE THEN
DO; /* OPERATE FROM STORAGE */
CALL EMITINST (OP,REG(MP),0,SYTLOC(FIXL(SP)),INX(SP),SYTSEG(FIXL(SP)));
ACC(INX(SP)) = AVAIL;
END;
ELSE IF TYPE(SP) = CONSTANT THEN
DO;
IF FIXV(SP) < "40000" & FIXV(SP) >= 0 THEN /* USE IMMEDIATE */
DO;
IF OP >= CAM & OP <= CMPRHI THEN OP=OP-9; /* SOB CODE ORDER */
CALL EMITINST(OP+1,REG(MP),0,FIXV(SP),0,0);
END;
ELSE
DO;
CALL EMITCONSTANT (FIXV(SP));
CALL EMITINST (OP,REG(MP),0,ADR,0,1);
END;
END;
ELSE
DO;
CALL FORCEACCUMULATOR(SP);
IF TYPE(SP) \= ACCUMULATOR THEN CALL ERROR (AWASD,0);
ELSE CALL EMITINST (OP,REG(MP),0,REG(SP),0,0);
ACC(REG(SP)) = AVAIL;
END;
IF TP \= 0 THEN
DO;
SP = MP; MP = TP;
CALL MOVESTACKS (SP,MP);
END;
END ARITHEMIT;
BOOLBRANCH:PROCEDURE (SP,MP);
DECLARE SP FIXED, MP FIXED, R FIXED;
/* GENERATE A CONDITIONAL BRANCH FOR DO WHILE OR AN IF STATEMENT
PLACE THE ADDRESS OF THIS BRANCH IN FIXL(MP)
*/
IF STILLCOND \= 0 THEN
DO; /* WE HAVE NOT GENERATED CODE SINCE SETTING THE CONDITION */
/* REMOVE THE MOVEI =1 AND MOVEI =0 AROUND THE CAM? */
CODE_HEAD = (CODE_HEAD-2) &3; /* BACK UP PTR */
R = (CODE_HEAD + 1) & 3;
CODE(CODE_HEAD) = CODE(R);
CODE_REL(CODE_HEAD) = CODE_REL(R);
CODE_PP(CODE_HEAD) = CODE_PP(R) -1;
CODE_RBITS(CODE_HEAD) = CODE_RBITS(R);
CODE_FULL(R) = FALSE;
CODE_FULL(R+1&3) = FALSE;
PP = PP - 2;
CODE(CODE_HEAD) = CODE(CODE_HEAD) ^^ ' P' ^^ PP-1;
IF CONTROL(BYTE('E')) THEN
DO;
CALL PRINTLINE (BACKMSG,-1);
CALL PRINTLINE (CODEMSG ^^ CODE(CODE_HEAD),-1);
END;
INSTRUCT(MOVEI) = INSTRUCT(MOVEI) - 2;
ACC(REG(SP)) = AVAIL; /* FREE CONDITION REGISTER */
R = 4; /* JUMP ALWAYS */
END;
ELSE
DO;
CALL FORCEACCUMULATOR(SP);
CALL EMITINST (ANDI,REG(SP),0,1,0,0); /* TEST ONLY LOW ORDER BIT */
ACC(REG(SP)) = AVAIL; /* FREE UP VARIABLE REGISTER */
R = 2; /* JUMP IF REGISTER ZERO */
END;
FIXL(MP) = FINDLABEL; /* GET A NEW LABEL */
CALL EMITINST (JUMP+R,REG(SP),0,FIXL(MP),0,4);
END BOOLBRANCH;
SETLIMIT:
PROCEDURE;
/* SETS DO LOOP LIMIT FOR <ITERATION CONTROL> */
IF TYPE (MPP1) = CONSTANT THEN
CALL EMITCONSTANT (FIXV(MPP1));
ELSE
DO;
CALL FORCEACCUMULATOR (MPP1); /* GET LOOP LIMIT */
CALL EMITDATAWORD (0);
ADR = DP - 1;
CALL EMITINST(MOVEM,REG(MPP1),0,ADR,0,1); /* SAVE IT */
ACC(REG(MPP1)) = AVAIL;
END;
FIXV (MP) = ADR;
END SETLIMIT;
STUFF_PARAMETER:
PROCEDURE;
/* GENERATE CODE TO SEND AN ACTUAL PARAMETER TO A PROCEDURE */
DECLARE (I,J) FIXED;
I = FIXL (MP) + CNT (MP); J = SYTLOC (I);
IF LENGTH (SYT(I)) = 0 THEN
DO;
SYTCO (I) = SYTCO (I) + 1; /* COUNT THE REFERENCE */
DO;
IF SYTYPE(I) = BYTETYPE THEN
DO;
CALL FORCEACCUMULATOR(MPP1);
CALL EMITINST (MOVEI,12,0,J,0,SYTSEG(I));
CALL EMITINST (DPB,REG(MPP1),0,BYTEPTRS,0,1);
END;
ELSE
DO;
IF TYPE(MPP1) = CONSTANT & FIXV(MPP1) = 0 THEN
DO;
CALL EMITINST (SETZM,0,0,J,0,SYTSEG(I));
RETURN;
END;
CALL FORCEACCUMULATOR (MPP1);
CALL DELETE_MOVE (MPP1,MOVEM,REG(MPP1),0,J,0,SYTSEG(I));
END;
ACC(REG(MPP1)) = AVAIL;
END;
END;
ELSE
CALL ERROR ('TOO MANY ACTUAL PARAMETERS', 1);
END STUFF_PARAMETER;
DIVIDE_CODE:PROCEDURE(T);
DECLARE T FIXED, I FIXED;
/* EMIT CODE TO PERFORM A DIVIDE (T=1) OR MOD (T=0) */
/* FIND A FREE REGISTER PAIR FOR THE DIVIDEND */
IF TYPE(MP) = ACCUMULATOR THEN
DO; /* WE MAY BE ABLE TO USE THE REGISTER TO THE RIGHT */
I = REG(MP);
IF ACC(I+1) = AVAIL THEN GOTO FITS;
END;
DO I = T TO 11;
IF ACC(I) = AVAIL THEN IF ACC(I+1) = AVAIL THEN GOTO FIT;
END;
CALL ERROR ('NO FREE REGISTERS FOR DIVISION OR MOD.',0);
RETURN;
FIT:
TARGET_REGISTER = I;
CALL FORCEACCUMULATOR(MP);
TARGET_REGISTER = -1;
IF REG(MP) \= I THEN
DO;
CALL EMITINST (MOVE,I,0,REG(MP),0,0);
ACC(REG(MP)) = AVAIL;
REG(MP) = I;
END;
ACC(I) = BUSY;
FITS:
ACC(I+1) = BUSY;
CALL ARITHEMIT (IDIV,0);
IF T = 0 THEN
DO; /* MOD, SWITCH REGISTER TO POINT TO REMAINDER */
ACC(I) = AVAIL; /* FREE QUOTIENT */
REG(MP) = I+1; /* POINT TO REMAINDER */
END;
ELSE ACC(I+1) = AVAIL; /* FREE REMAINDER */
IF REG(MP) =12 THEN
DO; /* TRANSFER THE MOD REMAINDER FROM A SCRATCH REGISTER */
I = FINDAR;
CALL EMITINST (MOVE,I,0,REG(MP),0,0);
ACC(REG(MP)) = AVAIL;
REG(MP) = I;
END;
END DIVIDE_CODE;
SHIFT_CODE:
PROCEDURE (OP);
DECLARE OP FIXED;
/* GENERATE CODE FOR THE BUILTIN FUNCTIONS SHL AND SHR */
/* OP: LEFT = 0, RIGHT = 1 */
SP = MPP1;
IF CNT (MP) \= 2 THEN
CALL ERROR ('SHIFT REQUIRES TWO ARGUMENTS', 0);
ELSE
IF TYPE (MPP1) = CONSTANT THEN
DO;
IF OP = 1 THEN FIXV(MPP1) = -FIXV(MPP1);
CALL EMITINST(LSH,REG(MP),0,FIXV(MPP1),0,0);
END;
ELSE
DO;
/* DO SHIFT WITH VARIABLE */
CALL FORCEACCUMULATOR(MPP1);
IF OP = 1 THEN
CALL EMITINST (MOVN,REG(MPP1),0,REG(MPP1),0,0);
CALL EMITINST (LSH,REG(MP),0,0,REG(MPP1),0);
ACC(REG(MPP1)) = AVAIL;
END;
TYPE(MP) = ACCUMULATOR;
END SHIFT_CODE;
STRINGCOMPARE:
PROCEDURE;
/* GENERATES CODE TO COMPARE THE STRINGS AT SP AND MP.
COMPARISONS ARE DONE FIRST ON LENGTH, AND SECOND ON A
CHARACTER BY CHARACTER COMPARISON USING THE PDP-10 COLLATING
SEQUENCE.
*/
CALL FORCEDESCRIPTOR (SP);
CALL DELETE_MOVE (SP,MOVEM,REG(SP),0,B,0,3);
ACC(REG(SP)) = AVAIL;
CALL FORCEDESCRIPTOR (MP);
CALL DELETE_MOVE (MP,MOVEM,REG(MP),0,A,0,3);
CALL SAVE_ACS (5);
CALL EMITINST (PUSHJ,15,0,STRCOMP,0,2); /* CALL STRING COMPARE */
CALL RESTORE_ACS (5);
CALL EMITINST (MOVEI,REG(MP),0,1,0,0);
CALL EMITINST (SKIP+INX(MPP1),0,0,0,0,0);
CALL EMITINST (MOVEI,REG(MP),0,0,0,0);
TYPE(MP) = ACCUMULATOR;
STILLCOND = INX(MPP1);
END STRINGCOMPARE;
SYMBOLDUMP:
PROCEDURE;
/* LIST THE SYMBOLS IN THE PROCEDURE THAT HAS JUST BEEN
COMPILED IF TOGGLE S IS ENABLED AND L IS ENABLED.
*/
DECLARE SUBTITLE_SAVE CHARACTER;
DECLARE HEADING CHARACTER INITIAL ('TYPE LOC SEGMENT DEFINED REF COUNT');
DECLARE SEG(4) CHARACTER INITIAL ('ABSOLUTE',' DATA',' PROGRAM',
' STRING',' LABEL');
DECLARE EXCHANGES FIXED, I FIXED, LMAX FIXED,
J FIXED, K FIXED, L FIXED, M FIXED, SYTSORT (SYTSIZE) FIXED;
DECLARE BLANKS CHARACTER,
TAG CHARACTER;
STRING_GT:
PROCEDURE (A,B);
/* DO AN HONEST STRING COMPARISON:
XPL CAN BE TRUSTED ONLY IF STRINGS ARE OF THE SAME LENGTH.
IF LENGTHS DIFFER, LET XPL SEE ONLY THE SHORTER, AND THE
MATCHING PART OF THE LONGER, AND ARRANGE COMPARISONS SO
THAT RESULT IS RIGHT. */
DECLARE A CHARACTER,
B CHARACTER;
DECLARE LA FIXED, LB FIXED;
LA = LENGTH (A);
LB = LENGTH (B);
IF LA = LB THEN RETURN (A > B);
ELSE IF LA > LB THEN RETURN (SUBSTR (A,0,LB) >= B);
ELSE RETURN (A > SUBSTR(B,0,LA));
END STRING_GT;
IF CONTROL(BYTE('L')) = 0 THEN RETURN; /* DON'T DUMP IF NOT LISTING */
IF PROCMARK <= NDECSY THEN
DO;
CALL PRINTLINE ('SYMBOL TABLE DUMP',0);
LMAX = 15;
DO I = PROCMARK TO NDECSY; /* PAD ALL NAMES TO THE SAME LENGTH */
IF LENGTH (SYT (I)) > LMAX THEN
LMAX = LENGTH (SYT (I));
SYTSORT (I) = I;
END;
IF LMAX > 70 THEN LMAX = 70;
BLANKS = SUBSTR (X70,0,LMAX);
EXCHANGES = TRUE;
K = NDECSY - PROCMARK;
DO WHILE EXCHANGES;
EXCHANGES = FALSE;
DO J = 0 TO K - 1;
I = NDECSY - J;
L = I - 1;
IF STRING_GT(SYT (SYTSORT(L)),SYT(SYTSORT(I))) THEN
DO;
M = SYTSORT (I);
SYTSORT (I) = SYTSORT (L);
SYTSORT (L) = M;
EXCHANGES = TRUE;
K = J; /* RECORD THE LAST SWAP */
END;
END;
END;
I = PROCMARK;
DO WHILE LENGTH (SYT (SYTSORT (I))) = 0;
I = I + 1; /* IGNORE NULL NAMES */
END;
SUBTITLE_SAVE = SUBTITLE;
SUBTITLE = 'SYMBOL' ^^ SUBSTR(BLANKS,0,LMAX-5) ^^ HEADING;
CALL PRINTLINE (SUBTITLE,0);
DO I = I TO NDECSY;
K = SYTSORT (I);
TAG = SYT(K) ^^ SUBSTR(X70,0,LMAX-LENGTH(SYT(K)));
CALL I_FORMAT (SYTLOC(K),5);
TAG = TAG ^^ X1 ^^ TYPENAME(SYTYPE(K)) ^^ X1 ^^ I_STRING;
CALL I_FORMAT (SYTCARD(K),5);
TAG = TAG ^^ X1 ^^ SEG(SYTSEG(K)) ^^ X2 ^^ I_STRING;
CALL I_FORMAT (SYTCO(K),5);
IF SYTCO(K) = 0 THEN I_STRING = I_STRING ^^ ' *';
CALL PRINTLINE (TAG ^^ X3 ^^ I_STRING,-1);
K = K + 1;
DO WHILE (LENGTH (SYT (K)) = 0) & (K <= NDECSY);
J = K - SYTSORT (I);
TAG = ' PARAMETER ' ^^ J ^^ SUBSTR(BLANKS,13) ^^
TYPENAME(SYTYPE(K));
CALL I_FORMAT (SYTLOC(K),5);
TAG = TAG ^^ X1 ^^ I_STRING;
CALL I_FORMAT (SYTCARD(K),5);
TAG = TAG ^^ X1 ^^ SEG(SYTSEG(K)) ^^ X2 ^^ I_STRING;
CALL I_FORMAT (SYTCO(K),5);
CALL PRINTLINE (TAG ^^ X3 ^^ I_STRING,-1);
K = K + 1;
END;
END;
SUBTITLE = SUBTITLE_SAVE;
END;
EJECT_PAGE;
END SYMBOLDUMP;
DUMPIT:
PROCEDURE;
DECLARE CHAR360 CHARACTER;
DECLARE T1 CHARACTER, T2 CHARACTER, L FIXED, LL FIXED;
/* PUT OUT STATISTICS KEPT WITHIN THE COMPILER */
IF TOP_MACRO >= 0 THEN
DO; /* DUMP MACRO DICTIONARY */
CALL PRINTLINE ( 'MACRO DEFINITIONS:',0);
CALL PRINTLINE (X1,-1);
L = LENGTH (MACRO_NAME(TOP_MACRO));
IF L > 70 THEN L = 70;
SUBTITLE = 'NAME' ^^ SUBSTR (X70,0,L-2) ^^
'AT LINE REF COUNT LITERAL VALUE';
CALL PRINTLINE (SUBTITLE,-1);
DO I = 0 TO TOP_MACRO;
K = LENGTH (MACRO_NAME(I));
IF K < L THEN
DO;
CHAR360 = SUBSTR (X70,0,L-K);
MACRO_NAME (I) = MACRO_NAME (I) ^^ CHAR360;
END;
ELSE
MACRO_NAME(I) = SUBSTR(MACRO_NAME(I),0,L);
T1 = MACRO_DECLARE(I);
T2 = MACRO_COUNT(I);
LL = LENGTH (T1);
IF LL < 8 THEN T1 = SUBSTR(X70,0,8-LL) ^^ T1;
LL = LENGTH (T2);
IF LL < 9 THEN T2 = SUBSTR(X70,0,9-LL) ^^ T2;
CALL PRINTLINE (MACRO_NAME(I) ^^ T1 ^^ T2 ^^ X4 ^^ MACRO_TEXT(I),-1);
END;
END;
SUBTITLE = '';
CALL PRINTLINE (X1,-1);
CALL PRINTLINE ('ID COMPARES = ' ^^ IDCOMPARES,-1);
CALL PRINTLINE ('SYMBOL TABLE SIZE = ' ^^ MAXNDECSY,-1);
CALL PRINTLINE ('MACRO DEFINITIONS = ' ^^ TOP_MACRO + 1,-1);
CALL PRINTLINE ('SCAN = ' ^^ COUNT_SCAN,-1);
CALL PRINTLINE ('EMITINST = ' ^^ COUNT_INST,-1);
CALL PRINTLINE ('FORCE ACCUMULATOR = ' ^^ COUNT_FORCE,-1);
CALL PRINTLINE ('ARITHEMIT = ' ^^ COUNT_ARITH,-1);
CALL PRINTLINE ('GENERATE STORE = ' ^^ COUNT_STORE,-1);
CALL PRINTLINE ('FREE STRING AREA = ' ^^ FREELIMIT - FREEBASE,-1);
CALL PRINTLINE ('COMPACTIFICATIONS = ' ^^ COUNT_COMPACT,-1);
SUBTITLE = 'INSTRUCTION FREQUENCIES';
EJECT_PAGE;
DO I = 0 TO 15;
J = I * 32;
DO K = 0 TO 31;
IF INSTRUCT(J+K) > 0 THEN
CALL PRINTLINE (SUBSTR(OPNAME(I),K*6,6) ^^ X4 ^^ INSTRUCT(J+K),-1);
END;
END;
END DUMPIT;
INITIALIZE:
PROCEDURE;
DECLARE CH CHARACTER;
DECLARE TIME1 FIXED, HOURS FIXED, MINUTES FIXED, SECS FIXED;
DECLARE DATE1 FIXED, DAY FIXED, YEAR FIXED, L FIXED;
DECLARE MONTH CHARACTER;
DECLARE MONTHS (11)CHARACTER INITIAL ('-JAN-',
'-FEB-','-MAR-','-APR-','-MAY-','-JUN-','-JUL-','-AUG-',
'-SEP-','-OCT-','-NOV-','-DEC-');
OUTPUT(-2) = 'FILENAME TO BE COMPILED: ';
CHAR_TEMP = INPUT(-1);
SOURCE = '';
CONTROL(BYTE('A')) = FALSE;
CONTROL(BYTE('D')) = TRUE;
CONTROL(BYTE('S')) = TRUE;
DO I = 0 TO LENGTH(CHAR_TEMP)-1;
CH = SUBSTR(CHAR_TEMP,I,1);
IF BYTE(CH) = BYTE('/') THEN
DO;
CH = SUBSTR(CHAR_TEMP,I+1,1);
CONTROL(BYTE(CH)) = \ CONTROL(BYTE(CH));
I = I + 1;
END;
ELSE
SOURCE = SOURCE ^^ CH;
END;
J = 0;
DO I = 0 TO LENGTH(SOURCE)-1;
CH = SUBSTR(SOURCE,I,1);
IF (BYTE(CH) = BYTE('.')) & (J = 0) THEN
J = I;
END;
IF J = 0 THEN
J = LENGTH(SOURCE);
IF J = LENGTH(SOURCE) THEN
FILENAME(0) = 'SYSIN:' ^^ SOURCE ^^ '.XPL';
ELSE
FILENAME(0) = 'SYSIN:' ^^ SOURCE;
SOURCE = SUBSTR(SOURCE,0,J);
FILENAME (1) = 'SYSOUT:' ^^ SOURCE ^^ '.LST';
IF CONTROL(BYTE('A')) THEN
DO;
FILENAME (DATAFILE) = SOURCE ^^ '.MAC';
FILENAME(CODEFILE) = SOURCE ^^ '.TMP';
END;
FILENAME(RELFILE) = SOURCE ^^ '.REL';
TIME1 = (TIME+500)/ 1000;
HOURS = TIME1 /3600;
MINUTES = (TIME1 MOD 3600) / 60;
SECS = TIME1 MOD 60;
DATE1 = DATE;
DAY = DATE1 MOD 31 + 1;
DATE1 = DATE1 / 31;
MONTH = MONTHS(DATE1 MOD 12);
YEAR = DATE1 / 12 + 1964;
TITLE = '1' ^^ SOURCE ^^ '.XPL COMPILED ' ^^ DAY ^^ MONTH ^^
YEAR ^^ ' AT ' ^^HOURS ^^ ':' ^^ MINUTES ^^ ':' ^^ SECS
^^ ' BY VERSION ' ^^ VERSION;
L = LENGTH (TITLE);
TITLE = TITLE ^^ SUBSTR(X70,0,90-L) ^^ 'PAGE ';
SUBTITLE = ' LINE SOURCE STATEMENT' ^^ SUBSTR(X70,7)
^^ 'PROCEDURE AND COMPILER INFORMATION';
PAGE_COUNT = 0;
LINE_COUNT = 99;
DO I = 1 TO TERMINAL#;
S = VOCAB(I);
IF S = '<NUMBER>' THEN NUMBER = I; ELSE
IF S = '<IDENTIFIER>' THEN IDENT = I; ELSE
IF S = '<STRING>' THEN STRING = I; ELSE
IF S = '/' THEN DIVIDE = I; ELSE
IF S = 'EOF' THEN EOFILE = I; ELSE
IF S = 'DECLARE' THEN STOPIT(I) = TRUE; ELSE
IF S = 'PROCEDURE' THEN STOPIT(I) = TRUE; ELSE
IF S = 'END' THEN STOPIT(I) = TRUE; ELSE
IF S = 'DO' THEN STOPIT(I) = TRUE; ELSE
IF S = ';' THEN STOPIT(I) = TRUE; ELSE
IF S = '^' THEN ORSYMBOL = I; ELSE
IF S = '^^' THEN CONCATENATE = I;
END;
IF IDENT = TERMINAL# THEN RESERVED_LIMIT = LENGTH(VOCAB(TERMINAL#-1));
ELSE RESERVED_LIMIT = LENGTH(VOCAB(TERMINAL#));
STOPIT(EOFILE) = TRUE;
DO I = TERMINAL# TO VOCAB#;
S = VOCAB(I);
IF S = '<LABEL DEFINITION>' THEN LABELSET = I;
END;
CHARTYPE (BYTE(' ')) = 1;
CHARTYPE (BYTE(' ')) = 1; /* MAKE A TAB CHARACTER A BLANK */
CHARTYPE (BYTE('''')) = 2;
CHARTYPE (BYTE('"')) = 3;
DO I = 0 TO 255;
NOT_LETTER_OR_DIGIT(I) = TRUE;
END;
DO I = 0 TO 29;
J = BYTE('ABCDEFGHIJKLMNOPQRSTUVWXYZ_$@#', I);
NOT_LETTER_OR_DIGIT(J) = FALSE;
IF I < 27 THEN
DO;
NOT_LETTER_OR_DIGIT(J+32) = FALSE; /* INCLUDE LOWER CASE */
CHARTYPE(J+32) = 4;
END;
CHARTYPE(J) = 4;
END;
DO I = 0 TO 9;
J = BYTE('0123456789', I);
NOT_LETTER_OR_DIGIT(J) = FALSE;
CHARTYPE(J) = 5;
END;
I = 1;
DO WHILE (LENGTH(VOCAB(I))= 1);
J = BYTE(VOCAB(I));
TX(J) = I;
CHARTYPE(J) = 7;
I = I + 1;
END;
CHARTYPE(BYTE('^')) = 8;
CHARTYPE (BYTE('/')) = 6;
PP = 0; /* PROGRAM ORIGIN */
DP = 0; /* DATA ORIGIN */
DPOFFSET = 0;
DSP = 0; /* DESCRIPTOR ORIGIN */
RETURNED_TYPE = FIXEDTYPE; /* INITIAL DEFAULT TYPE */
TOP_MACRO = -1;
TARGET_REGISTER = -1;
CODEMSG = X70 ^^ CODEMSG;
DATAMSG = X70 ^^ DATAMSG;
BACKMSG = X70 ^^ BACKMSG;
/* INITIALIZE THE SYMBOL TABLE AND ITS HASH TABLE */
PROCMARK = 25; NDECSY = 27; PARCT = 0;
DO I = 0 TO SYTSIZE;
PTR (I) = -1;
END;
DO I = 0 TO "FF";
HASH (I) = -1;
END;
DO I = 0 TO NDECSY;
IDX = HASHER (SYT(I));
PTR (I) = HASH (IDX);
HASH (IDX) = I;
END;
RPTR, DPTR, DLOC,FOR_COUNT, LABEL_COUNT = 0;
RCTR, DCTR = 1;
FILE(RELFILE) = NAME_TYPE + 2;
FILE(RELFILE) = 0;
FILE(RELFILE) = RADIX50(SOURCE);
FILE(RELFILE) = "(3)17000000" + 0;
FILE(RELFILE) = HISEG_TYPE + 1;
FILE(RELFILE) = "(3)200000000000" ;
FILE(RELFILE) = "(3)400000400000";
CODE_HEAD, CODE_TAIL = 0;
CODE_FULL(0) = FALSE;
IF CONTROL(BYTE('A')) THEN
DO;
LABEL_GEN = 'P:'; /* ORG THE CODE SEGMENT */
OUTPUT (DATAFILE) = ' TITLE ' ^^ SOURCE ;
OUTPUT (DATAFILE) = ' TWOSEG 400000;';
OUTPUT (DATAFILE) = ' RELOC 0;';
OUTPUT (DATAFILE) = ' RADIX 10;';
OUTPUT (CODEFILE) = ' RELOC ^O400000;';
OUTPUT (DATAFILE) = ' OPDEF .INIT. [1B8];';
OUTPUT (DATAFILE) = ' OPDEF .INPT. [2B8];';
OUTPUT (DATAFILE) = ' OPDEF .OUTP. [3B8];';
OUTPUT (DATAFILE) = ' OPDEF .EXIT. [4B8];';
OUTPUT (DATAFILE) = ' OPDEF .FILI. [6B8];';
OUTPUT (DATAFILE) = ' OPDEF .FILO. [7B8];';
OUTPUT (DATAFILE) = ' OPDEF .NAME. [8B8];';
OUTPUT (DATAFILE) = 'D:';
END;
BYTEPTRS = DP;
CALL EMITDATAWORD ("(3)331114000000"); /* POINT 9,0(12),8 */
CALL EMITDATAWORD ("(3)221114000000"); /* POINT 9,0(12),17 */
CALL EMITDATAWORD ("(3)111114000000"); /* POINT 9,0(12),26 */
CALL EMITDATAWORD ("(3)001114000000"); /* POINT 9,0(12),35 */
PSBITS = DP;
CALL EMITDATAWORD ("(3)331100000000"); /* POINT 9,0,8 */
CALL EMITDATAWORD ("(3)221100000000"); /* POINT 9,0,17 */
CALL EMITDATAWORD ("(3)111100000000"); /* POINT 9,0,26 */
CALL EMITDATAWORD ("(3)001100000000"); /* POINT 9,0,35 */
CALL EMITCONSTANT (1); /* ENTER A 1 */
TRUELOC = ADR; /* SAVE ITS ADDRESS */
CALL EMITCONSTANT (0); /* ENTER A 0 */
FALSELOC = ADR; /* SAVE ITS ADDRESS */
TSA = DP; SYTLOC(2) = DP; /* FREEPOINT */
CALL EMITDATAWORD (0);
NDESC, SYTLOC(4) = FINDLABEL; /* NDESCRIPT */
COREBYTELOC = 1; /* SYT LOCATION OF COREBYTE */
STRING_RECOVER = 25; /* SYT LOCATION OF COMPACTIFY */
SYTLOC(25) = FINDLABEL; /* LABEL FOR COMPACTIFY */
LIMITWORD = DP; SYTLOC(26) = DP; /* FREELIMIT */
CALL EMITDATAWORD (0);
STR = DSP; /* PLACE TO SAVE LAST STRING GENERATED */
CALL EMITDESC (0,0);
LIBRARY_SAVE = DP; /* PLACE TO SAVE R11 ON LIB CALLS */
CALL EMITDATAWORD (0);
LIBRARY = DP; /* ADDRESS OF LIBRARY GOES HERE */
IF CONTROL(BYTE('A')) THEN
DO;
OUTPUT (DATAFILE) = ' XPLLIB;';
OUTPUT (DATAFILE) = ' EXTERN XPLLIB;';
END;
DP = DP + 1;
CALL EMITCONSTANT ("FFFFF"); /* MASK FOR ADDRESSES ONLY */
ADDRMASK = ADR; /* SAVE IT */
CALL EMITCONSTANT(-134217728); /* DV LENGTH FIELD */
LENGTHMASK = ADR;
/* CHECK-STRING-OVERFLOW SEE IF COMPACTIFY NEEDS TO BE CALLED */
CALL EMITBLOCK (15);
I = DP - 15;
STRING_CHECK = PP;
CALL EMITINST (MOVE,0,0,TSA,0,1); /* PICK UP TOP OF STRINGS */
CALL EMITINST (CAMGE,0,0,LIMITWORD,0,1); /* COMPARE WITH LIMIT WORD */
CALL EMITINST (POPJ,15,0,0,0,0);
CALL EMITINST (MOVEI,0,0,I,0,1);
CALL EMITINST (HRLI,0,0,1,0,0);
CALL EMITINST (BLT,0,0,I+14,0,1);
CALL EMITINST (PUSHJ,15,0,SYTLOC(STRING_RECOVER),0,SYTSEG(STRING_RECOVER));
CALL EMITINST (MOVEI,0,0,1,0,0);
CALL EMITINST (HRLI,0,0,I,0,1);
CALL EMITINST (BLT,0,0,14,0,0);
CALL EMITINST (POPJ,15,0,0,0,0);
SYTCO (STRING_RECOVER) = SYTCO (STRING_RECOVER) + 1;
/* STRING COMPARISON */
A = DSP;
CALL EMITDESC (0,0);
B = DSP;
CALL EMITDESC (0,0);
STRCOMP = PP;
CALL EMITINST (MOVE,0,0,A,0,3); /* FETCH LEFT DESCRIPTOR */
CALL EMITINST (LSH,0,0, -27,0,0);
CALL EMITINST (MOVE,1,0,B,0,3); /* FETCH RIGHT DESCRIPTOR */
CALL EMITINST (LSH,1,0, -27,0,0);
CALL EMITINST (SUB,0,0,1,0,0); /* SUBTRACT THE LENGTHS */
CALL EMITINST (JUMPE,0,0,PP+2,0,2);
CALL EMITINST (POPJ,15,0,0,0,0); /* RETURN W/ -, 0, OR + IF LENGTH \= */
CALL EMITINST (MOVEI,2,0,0,0,0); /* CLEAR A LENGTH REGISTER */
CALL EMITINST (MOVE,3,0,A,0,3);
CALL EMITINST (SUBI,3,0,1,0,0);
CALL EMITINST (LSHC,2,0, 9,0,0); /* ISOLATE THE LENGTH */
CALL EMITINST (LSHC,3,0,-11,0,0); /* ISOLATE BYTE INDEX IN R4 */
CALL EMITINST (LSH,4,0, -34,0,0);
CALL EMITINST (HLL,3,0,PSBITS,4,1); /* BUILD BYTE PTR IN R3 */
CALL EMITINST (MOVE,4,0,B,0,3);
CALL EMITINST (SUBI,4,0,1,0,0);
CALL EMITINST (LSHC,4,0, -2,0,0);
CALL EMITINST (LSH,5,0, -34,0,0);
CALL EMITINST (HLL,4,0,PSBITS,5,1); /* BUILD BYTE PTR IN R4 */
/* ONE CHARACTER GOES INTO R0 WHILE THE OTHER GOES INTO R1. LENGTH IS
CONTROLLED IN R2 AND THE BYTE PTRS ARE IN R3 & R4 FOR SPEED.
*/
CALL EMITINST (ILDB,0,0,3,0,0); /* FETCH 1ST BYTE */
CALL EMITINST (ILDB,1,0,4,0,0); /* FETCH 2ND BYTE */
CALL EMITINST (CAMN,0,0,1,0,0); /* SKIP IF \= */
CALL EMITINST (SOJG,2,0,PP-3,0,2);/* LOOP FOR ALL BYTES */
CALL EMITINST (SUB,0,0,1,0,0); /* SUB DIFF BYTES OR LAST TWO EQUAL */
CALL EMITINST (POPJ,15,0,0,0,0);
/* MOVE CHARACTER SUBROUTINE */
MOVER = PP;
/* USES REGISTERS 1, 2, 11, 12, & 13 */
CALL EMITINST (SUBI,12,0,1,0,0); /* DECR ADDR OF SOURCE */
CALL EMITINST (MOVEI,11,0,0,0,0); /* CLEAR LENGTH REG */
CALL EMITINST (LSHC,11,0, 9,0,0);/* ISOLATE LENGTH */
CALL EMITINST (LSHC,12,0,-11,0,0);/* ISOLATE BYTE INDEX */
CALL EMITINST (LSH,13,0, -34,0,0);
CALL EMITINST (HLL,12,0,PSBITS,13,1); /* MAKE FROM BYTEPTR */
CALL EMITINST (MOVE,13,0,11,0,0); /* COPY LENGTH */
CALL EMITINST (ADD,13,0,1,0,0); /* CREATE NEW TSA */
CALL EMITINST (SUBI,1,0,1,0,0); /* DECR TO ADDR */
CALL EMITINST (LSHC,1,0, -2,0,0); /* ISOLATE BYTE INDEX */
CALL EMITINST (LSH,2,0, -34,0,0);
CALL EMITINST (HLL,1,0,PSBITS,2,1); /* TO BYTEPTR */
/* CHARACTER GOES INTO R2, LENGTH IS IN R11, AND THE NEW TSA IS IN R13.
BYTEPTRS ARE IN R1 & R12 FOR SPEED.
*/
CALL EMITINST (ILDB,2,0,12,0,0); /* FETCH A BYTE */
CALL EMITINST (IDPB,2,0,1,0,0); /* STORE A BYTE */
CALL EMITINST (SOJG,11,0,PP-2,0,2); /* LOOP FOR ALL BYTES */
CALL EMITINST (MOVE,1,0,13,0,0); /* RETURN WITH NEW TSA */
CALL EMITINST (POPJ,15,0,0,0,0);
/* CATENATION SUBROUTINE */
CATENTRY = PP;
CALL CHECK_STRING_OVERFLOW; /* SQUEEZE CORE IF NECESSARY */
CALL EMITINST (MOVE,0,0,B,0,3); /* SEE IF LENGTH (B) = 0 */
CALL EMITINST (AND,0,0,LENGTHMASK,0,1);
CALL EMITINST (JUMPN,0,0,PP+3,0,2);
CALL EMITINST (MOVE,0,0,A,0,3); /* YES, RETURN WITH A */
CALL EMITINST (POPJ,15,0,0,0,0);
CALL EMITINST (MOVE,1,0,A,0,3); /* SEE IF LENGTH(A) = 0 */
CALL EMITINST (AND,1,0,LENGTHMASK,0,1);
CALL EMITINST (JUMPN,1,0,PP+3,0,2);
CALL EMITINST (MOVE,0,0,B,0,3); /* YES, RETURN WITH B */
CALL EMITINST (POPJ,15,0,0,0,0);
/* WE HAVE TO CONSTRUCT A NEW STRING. CHECK TO SEE IF STRING 'A'
IS ADJACENT TO THE FIRST AVAILABLE BYTE. IF IT IS, WE NEED
ONLY ACTUALLY MOVE STRING 'B' AND DUMMY UP A NEW DESCRIPTOR. */
CALL EMITINST (ROT,1,0,9,0,0); /* PUT L(A) IN LOW END */
CALL EMITINST (ADD,1,0,A,0,3); /* ADD A DESC. */
CALL EMITINST (AND,1,0,ADDRMASK,0,1); /* KEEP ONLY BYTE ADDRESS */
CALL EMITINST (ADD,0,0,A,0,3); /* ADD L(B) TO DESC. A */
CALL EMITINST (MOVE,12,0,B,0,3); /* GE DESC. B */
CALL EMITINST (AND,12,0,ADDRMASK,0,1);/* KEEP BYTE ADDRESS */
CALL EMITINST (CAMN,12,0,1,0,0); /* IS THIS SAME AS END(A)+1? */
CALL EMITINST (JRST,0,0,PP+11,0,2); /*YES. THEN DONE */
CALL EMITINST (CAML,1,0,TSA,0,1); /* IS 'A' LAST STRING ? */
CALL EMITINST (JRST,0,0,PP+6,0,2); /* YES. JUMP TO JUST MOVE B */
CALL EMITINST (AND,0,0,LENGTHMASK,0,1); /* NO. MAKE NEW DESC. */
CALL EMITINST (IOR,0,0,TSA,0,1); /* NEW DOPE VECTOR */
CALL EMITINST (MOVE,1,0,TSA,0,1); /* TARGET OF MOVE */
CALL EMITINST (MOVE,12,0,A,0,3); /* SOURCE OF MOVE & LENGTH */
CALL EMITINST (PUSHJ,15,0,MOVER,0,2); /* CALL MOVE SUBROUTINE */
CALL EMITINST (MOVE,12,0,B,0,3); /* SOURCE OF MOVE */
CALL EMITINST (PUSHJ,15,0,MOVER,0,2); /* CALL MOVE SUBROUTINE*/
CALL EMITINST (MOVEM,1,0,TSA,0,1);/* SAVE NEW TSA */
CALL EMITINST (MOVEM,0,0,STR,0,3); /* SAVE LAST STRING DESCRIPTOR */
CALL EMITINST (POPJ,15,0,0,0,0);
/* NUMBER TO STRING CONVERSION */
NMBRENTRY = PP;
/* USES REGISTERS 0,1,12,13 */
CALL EMITBLOCK (1);
C = DP - 1;
CALL CHECK_STRING_OVERFLOW;
CALL EMITINST (MOVE,12,0,TSA,0,1); /* GET LOC'N FIRST FREE BYTE*/
CALL EMITINST (SUBI,12,0,1,0,0); /* ADJUST FOR IDBP */
CALL EMITINST (MOVEI,13,0,0,0,0); /* CLEAR 13 FOR SHIFT */
CALL EMITINST (LSHC,12,0,-2,0,0); /* WORD ADDRESS TO 12 */
CALL EMITINST (ROT,13,0,2,0,0); /* DISPL. TO 13 */
CALL EMITINST (HLL,12,0,PSBITS,13,1);/* MAKE BYTE POINTER IN 12 */
CALL EMITINST (MOVE,0,0,C,0,1); /* LOAD NUMBER TO BE CONVERTED */
CALL EMITINST (MOVEI,13,0,0,0,0); /* CLEAR COUNT OF BYTES */
CALL EMITINST (JUMPGE,0,0,PP+5,0,2); /* JUMP AROUND SIGN IF >= 0 */
CALL EMITINST (MOVEI,1,0,BYTE('-'),0,0);/* PUT - INTO REG. */
CALL EMITINST (IDPB,1,0,12,0,0); /* PUT BYTE AWAY */
CALL EMITINST (MOVEI,13,0,1,0,0); /* SET BYTE COUNT TO 1 */
CALL EMITINST (MOVM,0,0,0,0,0); /* MAKE NUMBER POSITIVE */
CALL EMITINST (PUSHJ,15,0,PP+8,0,2); /* GENERATE BYTE STRING */
CALL EMITINST (ROT,13,0,-9,0,0); /* PUT BYTE COUNT IN LENGTH */
CALL EMITINST (MOVE,0,0,TSA,0,1); /* PICK STARTING ADDRESS OF STRING */
CALL EMITINST (ADD,0,0,13,0,0); /* ADD LENGTH TO MAKE DESC. */
CALL EMITINST (ROT,13,0,9,0,0); /* PUT COUNT BACK */
CALL EMITINST (ADDM,13,0,TSA,0,1); /* ADJUST TSA FOR NEXT TIME */
CALL EMITINST (MOVEM,0,0,STR,0,3); /* SAVE NEW DESCRIPTOR */
CALL EMITINST (POPJ,15,0,0,0,0); /* RETURN */
/* SUBROUTINE TO CONVERT NUMBER TO CHAR STRING BY REPETITIVE
DIVISION. PUTS OUT DIGITS FROM HIGH-TO-LOW ORDER. */
CALL EMITINST (IDIVI,0,0,10,0,0); /* QUOTIENT TO 0, REMAINDER TO 1 */
CALL EMITINST (HRLM,1,0,0,15,0); /* SAVE REMAINDER ON STACK */
CALL EMITINST (JUMPE,0,0,PP+2,0,2); /* IF QUOTIENT = 0, ALL DIGITS */
CALL EMITINST (PUSHJ,15,0,PP-3,0,2); /* LOOP BACK FOR NEXT DIGIT */
CALL EMITINST (HLRZ,1,0,0,15,0); /* RETRIEVE DIGIT FROM STACK */
CALL EMITINST (ADDI,1,0,BYTE('0'),0,0); /* CONVERT TO ASCII CHARACTER */
CALL EMITINST (IDPB,1,0,12,0,0); /* STUFF BYTE OUT */
CALL EMITINST (ADDI,13,0,1,0,0); /* INCREMENT BYTE COUNTER */
CALL EMITINST (POPJ,15,0,0,0,0); /* RETURN (FOR MORE OR TO CALLER */
/* THE COMPILED PROGRAM WILL BEGIN EXECUTION HERE. MAKE THE FIRST JUMP
POINT HERE, INITIALIZE THE LIBRARY, AND FALL INTO COMPILE CODE.
*/
STARTLOC = PP; /* START LOCATION */
CALL EMITLABEL (0,4); /* ORG PROGRAM HERE */
/* INITIALIZE LIBRARY ROUTINE, FREEBASE, FREELIMIT, & FREEPOINT */
CALL EMITINST (JUMP,0,0,0,0,0); /* PATCH NOP */
CALL EMITINST (1,0,0,0,0,0); /* INIT LIB CODE */
CALL EMITINST (MOVEM,12,0,TSA,0,1); /* SAVE AS FREEPOINT */
CALL EMITINST (MOVEM,12,0,DP,0,1); /* SAVE AS FREEBASE */
SYTLOC (27) = DP;
CALL EMITDATAWORD (0);
CALL EMITINST (SUBI,13,0,256,0,0);
CALL EMITINST (MOVEM,13,0,LIMITWORD,0,1); /* SAVE AS FREELIMIT */
/* ROUTINE TO RELOCATE STRING DESCRIPTORS */
CALL EMITINST (MOVEI,12,0,0,0,1); /* GET ADDRESS OF DATA SEGMENT */
CALL EMITINST (LSH,12,0, 2,0,0); /* MULTIPLY BY 4 FOR BYTE ADDRESS*/
CALL EMITINST (MOVE,13,0,NDESC,0,5); /* GET # DESCRIPTORS AS INDEX */
CALL EMITINST (SKIPE,0,0,0,13,3); /* DON'T CHANGE NULL DESC.S */
CALL EMITINST (ADDM,12,0,0,13,3); /* ADD RELOC TO A DESCRIPTOR */
CALL EMITINST (SOJG,13,0,PP-2,0,2); /* LOOP THRU ALL DESCRIPTORS */
CP = 0; TEXT = ''; TEXT_LIMIT = -1;
COMPILING = TRUE;
READING = CONTROL(BYTE('X'));
IF READING THEN
CONTROL(BYTE('L')) = \ (CONTROL(BYTE('K')) ^ CONTROL(BYTE('M'))) & 1;
FILENAME(LIBFILE) = 'LIB:XPL.LIB';
CURRENT_PROCEDURE = '*';
PROCEDURE_DEPTH = 0;
CALL SCAN;
NO_LOOK_AHEAD_DONE = FALSE;
END INITIALIZE;
STACK_DUMP:
PROCEDURE;
DECLARE LINE CHARACTER;
IF \ CONTROL(BYTE('R')) THEN RETURN; /* 'R' IS BARF SWITCH */
LINE = 'PARTIAL PARSE TO THIS POINT IS: ';
DO I = 0 TO SP;
IF LENGTH(LINE) > 105 THEN
DO;
CALL PRINTLINE (LINE,-1);
LINE = X4;
END;
LINE = LINE ^^ X1 ^^ VOCAB(STATE_NAME(STATE_STACK(I)));
END;
CALL PRINTLINE (LINE,-1);
END STACK_DUMP;
/* THE SYNTHESIS ALGORITHM FOR XPL */
SYNTHESIZE:
PROCEDURE(PRODUCTION_NUMBER);
DECLARE PRODUCTION_NUMBER FIXED;
DECLARE TOOMSG CHARACTER INITIAL ('TOO MANY ARGUMENTS FOR ');
STACK_CASE:
PROCEDURE (DATUM);
DECLARE DATUM FIXED;
DECLARE DCLRM CHARACTER
INITIAL ('TOO MANY CASES OR FACTORED DECLARATIONS');
IF CASEP >= CASELIMIT THEN CALL ERROR (DCLRM,1);
ELSE CASEP = CASEP + 1;
CASESTACK(CASEP) = DATUM;
END STACK_CASE;
DO CASE (PRODUCTION_NUMBER);
/* ONE STATEMENT FOR EACH PRODUCTION OF THE GRAMMAR*/
; /* CASE 0 IS A DUMMY, BECAUSE WE NUMBER PRODUCTIONS FROM 1 */
/* 1 <PROGRAM> ::= <STATEMENT LIST> EOF */
DO; /* END OF COMPILING */
COMPILING = FALSE;
IF MP \= 0 THEN
DO;
CALL ERROR ('INPUT DID NOT PARSE TO <PROGRAM>.', 1);
CALL STACK_DUMP;
END;
DO I = PROCMARK TO NDECSY;
IF SYTYPE (I) = FORWARDTYPE ^ SYTYPE (I) = FORWARDCALL THEN
IF SYTCO (I) > 0 THEN
CALL ERROR ('UNDEFINED LABEL OR PROCEDURE: ' ^^ SYT(I),1);
END;
IF DPOFFSET > 0 THEN CALL FLUSH_DATACARD;
END;
/* 2 <STATEMENT LIST> ::= <STATEMENT> */
;
/* 3 ^ <STATEMENT LIST> <STATEMENT> */
;
/* 4 <STATEMENT> ::= <BASIC STATEMENT> */
DO;
STATEMENT_COUNT = STATEMENT_COUNT + 1;
CALL CLEARARS;
END;
/* 5 ^ <IF STATEMENT> */
CALL CLEARARS;
/* 6 <BASIC STATEMENT> ::= <ASSIGNMENT> ; */
;
/* 7 ^ <GROUP> ; */
;
/* 8 ^ <PROCEDURE DEFINITION> ; */
;
/* 9 ^ <RETURN STATEMENT> ; */
;
/* 10 ^ <CALL STATEMENT> ; */
;
/* 11 ^ <GO TO STATEMENT> ; */
;
/* 12 ^ <DECLARATION STATEMENT> ; */
;
/* 13 ^ ; */
;
/* 14 ^ <LABEL DEFINITION> */
/* 14 <BASIC STATEMENT> */
;
/* 15 <IF STATEMENT> ::= <IF CLAUSE> <STATEMENT> */
CALL EMITLABEL(FIXL(MP),4); /* FIX ESCAPE BRANCH */
/* 16 ^ <IF CLAUSE> <TRUE PART> <STATEMENT> */
CALL EMITLABEL (FIXL(MPP1),4); /* FIX ESCAPE BRANCH */
/* 17 ^ <LABEL DEFINITION> <IF STATEMENT> */
;
/* 18 <IF CLAUSE> ::= IF <EXPRESSION> THEN */
CALL BOOLBRANCH(MPP1,MP); /* BRANCH ON FALSE OVER TRUE PART */
/* 19 <TRUE PART> ::= <BASIC STATEMENT> ELSE */
DO; /* SAVE THE PROGRAM POINTER AND EMIT THE CONDITIONAL BRANCH */
FIXL(MP) = FINDLABEL;
CALL EMITINST(JRST ,0,0,FIXL(MP),0,4);
CALL EMITLABEL (FIXL(MP-1),4); /* COMPLETE HOP AROUND TRUE */
CALL CLEARARS;
END;
/* 20 <GROUP> ::= <GROUP HEAD> <ENDING> */
/* BRANCH BACK TO LOOP AND FIX ESCAPE BRANCH */
IF INX (MP) = 1 ^ INX (MP) = 2 THEN
DO; /* STEP OR WHILE LOOP FIXUP */
CALL EMITINST (JRST ,0,0,PPSAVE(MP),0,2);
CALL EMITLABEL(FIXL(MP),4);
END;
ELSE IF INX (MP) = 3 THEN
DO; /* CASE GROUP */
CALL EMITLABEL(FIXL(MP),4); /* FIX BRANCH INTO JUMP LIST */
DO I = PPSAVE (MP) TO CASEP - 1;
CALL EMITINST (JRST ,0,0,CASESTACK(I),0,2); /* JUMP LIST */
END;
CASEP = PPSAVE (MP) - 1;
CALL EMITLABEL(FIXV(MP),4); /* FIX ESCAPE BRANCH */
END;
/* 21 <GROUP HEAD> ::= DO ; */
INX (MP) = 0; /* ZERO DENOTES ORDINARY GROUP */
/* 22 ^ DO <STEP DEFINITION> ; */
DO;
CALL MOVESTACKS (MPP1, MP);
INX (MP) = 1; /* ONE DENOTES STEP */
CALL CLEARARS;
END;
/* 23 ^ DO <WHILE CLAUSE> ; */
DO;
CALL MOVESTACKS (MPP1,MP);
INX (MP) = 2; /* TWO DENOTES WHILE */
CALL CLEARARS;
END;
/* 24 ^ DO <CASE SELECTOR> ; */
DO;
CALL MOVESTACKS (MPP1, MP);
INX (MP) = 3; /* THREE DENOTES CASE */
CALL CLEARARS;
INFO = INFO ^^ ' CASE 0.';
END;
/* 25 ^ <GROUP HEAD> <STATEMENT> */
IF INX (MP) = 3 THEN
DO; /* CASE GROUP, MUST RECORD STATEMENT ADDRESSES */
CALL EMITINST (JRST ,0,0,FIXV(MP),0,4);
CALL STACK_CASE (PP);
INFO = INFO ^^ ' CASE ' ^^ CASEP - PPSAVE(MP) ^^ '.';
END;
/* 26 <STEP DEFINITION> ::= <VARIABLE> <REPLACE> */
/* 26 <EXPRESSION> <ITERATION CONTROL> */
DO; /* EMIT CODE FOR STEPPING DO LOOPS */
CALL FORCEACCUMULATOR (MP+2); /* GET INITIAL VALUE */
STEPK = FINDLABEL;
CALL EMITINST (JRST ,0,0,STEPK,0,4);/* BRANCH AROUND INCR CODE */
PPSAVE(MP) = PP; /* SAVE ADDRESS FOR LATER FIX */
IF CNT (MP) > 0 THEN CALL ERROR ('DO INDEX MAY NOT BE SUBSCRIPTED',0);
/* INCREMENT INDUCTION VARIABLE */
IF SYTYPE(FIXL(MP)) = FIXEDTYPE & FIXL(SP) = TRUELOC THEN
DO; /* USE AOS IF INCREMENTING BY 1 */
REG(MP) = REG(MP+2);
CALL EMITINST (AOSA,REG(MP),0,SYTLOC(FIXL(MP)),0,1);
TYPE(MP) = ACCUMULATOR;
END;
ELSE
DO; /* CAN'T USE AOS INST. */
ACC(REG(MP+2)) = AVAIL; /* MAKE SURE SAME REGISTER IS USED */
TARGET_REGISTER = REG(MP+2);
CALL FORCEACCUMULATOR (MP); /* FETCH THE INDEX */
TARGET_REGISTER = -1;
CALL EMITINST(ADD,REG(MP),0,FIXL(MP+3),0,1);
END;
/* UPDATE INDUCTION VARIABLE AND TEST FOR END */
CALL EMITLABEL(STEPK,4);
CALL GENSTORE (MP,MP);
CALL EMITINST (CAMLE,REG(MP),0,FIXV(SP),0,1);
FIXL (MP) = FINDLABEL;
CALL EMITINST (JRST ,0,0,FIXL(MP),0,4);
ACC(REG(MP)) = AVAIL;
END;
/* 27 <ITERATION CONTROL> ::= TO <EXPRESSION> */
DO;
FIXL(MP) = TRUELOC; /* POINT AT THE CONSTANT ONE FOR STEP */
CALL SETLIMIT;
END;
/* 28 ^ TO <EXPRESSION> BY */
/* 28 <EXPRESSION> */
DO;
IF TYPE (SP) = CONSTANT THEN CALL EMITCONSTANT (FIXV(SP));
ELSE
DO;
CALL FORCEACCUMULATOR (SP);
CALL EMITDATAWORD (0);
ADR = DP - 1;
CALL EMITINST (MOVEM,REG(SP),0,ADR,0,1);
ACC(REG(SP)) = AVAIL;
END;
FIXL (MP) =ADR;
CALL SETLIMIT;
END;
/* 29 <WHILE CLAUSE> ::= WHILE <EXPRESSION> */
CALL BOOLBRANCH (SP,MP);
/* 30 <CASE SELECTOR> ::= CASE <EXPRESSION> */
/* THE FOLLOWING USE IS MADE OF THE PARALLEL STACKS BELOW <CASE SELECTOR>
PPSAVE PREVIOUS MAXIMUM CASE STACK POINTER
FIXL ADDRESS OF INDEXED GOTO INTO LIST
FIXV ADDRESS OF ESCAPE GOTO FOR CASES
*/
DO;
CALL FORCEACCUMULATOR (SP); /* GET THE INDEX IN TO AR */
ACC(REG(SP)) = AVAIL;
FIXL(MP) = FINDLABEL;
CALL EMITINST (JRST ,0,1,FIXL(MP),REG(SP),4);/* INDIRECT INDEXED BRANCH */
FIXV(MP) = FINDLABEL; /* ADDRESS OF ESCAPE BRANCH */
CALL STACK_CASE (PP);
PPSAVE (MP) = CASEP;
END;
/* 31 <PROCEDURE DEFINITION> ::= <PROCEDURE HEAD> */
/* 31 <STATEMENT LIST> <ENDING> */
/* THE FOLLOWING USE IS MADE OF THE PARALLEL STACKS BELOW
<PROCEDURE HEAD>
PPSAVE ADDRESS OF PREVIOUS PROC RETURN
FIXL ADDRESS OF PREVIOUS PROC ACCUMULATOR AREA
FIXV POINTER TO SYMBOL TABLE FOR THIS BLOCK
CNT COUNT OF THE PARAMETERS OF PREVIOUS PROC
*/
DO; /* PROCEDURE IS DEFINED, RESTORE SYMBOL TABLE */
IF LENGTH (VAR(SP)) > 0 THEN
IF SUBSTR (CURRENT_PROCEDURE,1) \= VAR(SP) THEN
CALL ERROR ('PROCEDURE' ^^ CURRENT_PROCEDURE ^^ ' CLOSED BY END '
^^ VAR(SP), 0);
IF CONTROL(BYTE('S')) THEN CALL SYMBOLDUMP;
DO I = PROCMARK TO NDECSY;
IF SYTYPE (I) = FORWARDTYPE ^ SYTYPE (I) = FORWARDCALL THEN
IF SYTCO (I) > 0 THEN
CALL ERROR ('UNDEFINED LABEL OR PROCEDURE: ' ^^ SYT (I), 1);
END;
DO I = 0 TO (NDECSY + 1) - (PROCMARK + PARCT);
J = NDECSY - I;
IF (J >= (PROCMARK + PARCT)) & (LENGTH(SYT(J)) > 0) THEN
DO;
HASH (HASHER(SYT(J))) = PTR (J);
PTR (J) = -1;
END;
END;
DO I = PROCMARK + PARCT TO NDECSY;
SYT (I) = X1;
END;
NDECSY = PROCMARK + PARCT - 1;
/* PARAMETER ADDRESSES MUST BE SAVED BUT NAMES DISCARDED */
IF PARCT > 0 THEN
DO J = 0 TO NDECSY - PROCMARK;
I = NDECSY - J;
IF SYTYPE (I) = 0 THEN
DO;
CALL ERROR ('UNDECLARED PARAMETER: ' ^^ SYT (I), 0);
SYTYPE (I) = FIXEDTYPE;
CALL EMITDATAWORD (0);
SYTLOC(I) = DP -1;
END;
HASH (HASHER(SYT(I))) = PTR (I);
PTR (I) = -1;
SYT (I) = '';
END;
PROCMARK = FIXV (MP);
PARCT = CNT (MP);
CURRENT_PROCEDURE = VAR (MP);
PROCEDURE_DEPTH = PROCEDURE_DEPTH - 1;
/* EMIT A GRATUITOUS RETURN */
CALL EMITINST (POPJ,15,0,0,0,0);
/* COMPLETE JUMP AROUND THE PROCEDURE DEFINITION */
CALL EMITLABEL(PPSAVE(MP),4);
RETURNED_TYPE = TYPE(MP);
END;
/* 32 <PROCEDURE HEAD> ::= <PROCEDURE NAME> ; */
DO; /* MUST POINT AT FIRST PARAMETER EVEN IF NON EXISTANT */
/* SAVE OLD PARAMETER COUNT */
CNT (MP) = PARCT;
PARCT = 0;
/* SAVE OLD PROCEDURE MARK IN SYMBOL TABLE */
FIXV(MP) = PROCMARK;
PROCMARK = NDECSY + 1;
TYPE(MP) = RETURNED_TYPE;
RETURNED_TYPE = 0;
CALL PROC_START;
END;
/* 33 ^ <PROCEDURE NAME> <TYPE> ; */
DO;
CNT (MP) = PARCT; /* SAVE OLD PARAMETER COUNT */
PARCT = 0;
FIXV(MP) = PROCMARK; /* SAVE OLD PROCEDURE MARK IN SYMBOL TABLE */
PROCMARK = NDECSY + 1;
TYPE(MP) = RETURNED_TYPE;
RETURNED_TYPE = TYPE(SP-1);
IF RETURNED_TYPE = CHRTYPE THEN SYTYPE(FIXL(MP)) = CHARPROCTYPE;
CALL PROC_START;
END;
/* 34 ^ <PROCEDURE NAME> <PARAMETER LIST> */
/* 34 ; */
DO;
CNT(MP) = CNT(MPP1); /* SAVE PARAMETER COUNT */
FIXV(MP) = FIXV (MPP1);
TYPE(MP) = RETURNED_TYPE;
RETURNED_TYPE = 0;
CALL PROC_START;
END;
/* 35 ^ <PROCEDURE NAME> <PARAMETER LIST> */
/* 35 <TYPE> ; */
DO;
CNT(MP) = CNT(MPP1); /* SAVE PARAMETER COUNT */
FIXV(MP) = FIXV (MPP1);
TYPE(MP) = RETURNED_TYPE;
RETURNED_TYPE = TYPE(SP-1);
IF RETURNED_TYPE = CHRTYPE THEN SYTYPE(FIXL(MP)) = CHARPROCTYPE;
CALL PROC_START;
END;
/* 36 <PROCEDURE NAME> ::= <LABEL DEFINITION> PROCEDURE */
DO;
SYTYPE (FIXL (MP)) = PROCTYPE;
S = CURRENT_PROCEDURE;
CURRENT_PROCEDURE = X1 ^^ VAR (MP);
VAR (MP) = S;
PROCEDURE_DEPTH = PROCEDURE_DEPTH + 1;
OUTPUT(-1) = SUBSTR(X70,0,PROCEDURE_DEPTH) ^^ CURRENT_PROCEDURE;
END;
/* 37 <PARAMETER LIST> ::= <PARAMETER HEAD> <IDENTIFIER> ) */
DO;
PARCT = PARCT + 1; /* BUMP THE PARAMETER COUNT */
CALL ENTER (VAR(MPP1), 0, 0, 0);
END;
/* 38 <PARAMETER HEAD> ::= ( */
DO; /* POINT AT THE FIRST PARAMETER FOR SYMBOL TABLE */
FIXV(MP) = PROCMARK;
PROCMARK = NDECSY + 1;
CNT (MP) = PARCT; /* SAVE OLD PARAMETER COUNT */
PARCT = 0;
END;
/* 39 ^ <PARAMETER HEAD> <IDENTIFIER> , */
DO;
PARCT = PARCT + 1; /* BUMP THE PARAMETER COUNT */
CALL ENTER (VAR(MPP1), 0, 0, 0);
END;
/* 40 <ENDING> ::= END */
;
/* 41 ^ END <IDENTIFIER> */
VAR (MP) = VAR (SP);
/* 42 ^ <LABEL DEFINITION> <ENDING> */
;
/* 43 <LABEL DEFINITION> ::= <IDENTIFIER> : */
FIXL(MP) = ENTER (VAR(MP), LABELTYPE, PP, 2);
/* 44 <RETURN STATEMENT> ::= RETURN */
DO;
CALL EMITINST (POPJ,15,0,0,0,0);
END;
/* 45 ^ RETURN <EXPRESSION> */
DO; /* EMIT A RETURN AND PASS A VALUE */
TARGET_REGISTER = 0;
IF RETURNED_TYPE = CHRTYPE THEN
CALL FORCEDESCRIPTOR(SP);
ELSE
CALL FORCEACCUMULATOR (SP);
TARGET_REGISTER = -1;
IF REG(SP) \= 0 THEN CALL EMITINST(MOVE,0,0,REG(SP),0,0);
CALL EMITINST (POPJ,15,0,0,0,0);
END;
/* 46 <CALL STATEMENT> ::= CALL <VARIABLE> */
DO;
I = SYTYPE(FIXL(SP));
IF I=PROCTYPE ^ I=FORWARDCALL ^ I = CHARPROCTYPE
^ (I=SPECIAL & SYTLOC(FIXL(SP))=12)
^ (I=SPECIAL & SYTLOC(FIXL(SP))=9) THEN
DO;
CALLTYPE = 0; /* NO RETURN VALUE */
CALL FORCEACCUMULATOR(SP);
CALLTYPE = 1;
END;
ELSE CALL ERROR ('UNDEFINED PROCEDURE: ' ^^ SYT(FIXL(SP)),0);
END;
/* 47 <GO TO STATEMENT> ::= <GO TO> <IDENTIFIER> */
DO;
CALL ID_LOOKUP(SP);
J = FIXL (SP);
IF J < 0 THEN
DO; /* FIRST OCURRANCE OF THE LABEL */
I = FINDLABEL;
CALL EMITINST (JRST ,0,0,I,0,4);
J = ENTER (VAR(SP),FORWARDTYPE,I,4);
SYTCO (J) = 1;
END;
ELSE IF SYTYPE(J) = LABELTYPE ^ SYTYPE(J) = FORWARDTYPE THEN
CALL EMITINST (JRST ,0,0,SYTLOC(J),0,SYTSEG(J));
ELSE
CALL ERROR ('TARGET OF GOTO IS NOT A LABEL', 0);
END;
/* 48 <GO TO> ::= GO TO */
;
/* 49 ^ GOTO */
;
/* 50 <DECLARATION STATEMENT> ::= DECLARE */
/* 50 <DECLARATION ELEMENT> */
;
/* 51 ^ <DECLARATION STATEMENT> , */
/* 51 <DECLARATION ELEMENT> */
;
/* 52 <DECLARATION ELEMENT> ::= <TYPE DECLARATION> */
IF TYPE (MP) = CHRTYPE THEN
DO WHILE (DSP < NEWDSP);
CALL EMITDESC (0,0);
END;
ELSE
DO;
IF DP < NEWDP THEN
DO;
IF DPOFFSET > 0 THEN CALL FLUSH_DATACARD;
IF DP < NEWDP THEN CALL EMITBLOCK (NEWDP-DP);
END;
DO WHILE (DPOFFSET < NEWDPOFFSET);
CALL EMITBYTE(0);
END;
END;
/* 53 ^ <IDENTIFIER> LITERALLY */
/* 53 <STRING> */
IF TOP_MACRO >= MACRO_LIMIT THEN
CALL ERROR ('MACRO TABLE OVERFLOW', 1);
ELSE DO;
TOP_MACRO = TOP_MACRO + 1;
I = LENGTH(VAR(MP));
J = MACRO_INDEX(I);
DO L = 1 TO TOP_MACRO - J;
K = TOP_MACRO - L;
MACRO_NAME(K+1) = MACRO_NAME(K);
MACRO_TEXT(K+1) = MACRO_TEXT(K);
MACRO_COUNT(K+1) = MACRO_COUNT(K);
MACRO_DECLARE(K+1) = MACRO_DECLARE(K);
END;
MACRO_NAME(J) = VAR(MP);
MACRO_TEXT(J) = VAR(SP);
MACRO_COUNT(J) = 0;
MACRO_DECLARE(J) = CARD_COUNT;
DO J = I TO 255;
MACRO_INDEX(J) = MACRO_INDEX(J) + 1;
END;
END;
/* 54 <TYPE DECLARATION> ::= <IDENTIFIER SPECIFICATION> */
/* 54 <TYPE> */
CALL TDECLARE (0);
/* 55 ^ <BOUND HEAD> <NUMBER> ) <TYPE> */
CALL TDECLARE (FIXV(MPP1));
/* 56 ^ <TYPE DECLARATION> */
/* 56 <INITIAL LIST> */
;
/* 57 <TYPE> ::= FIXED */
TYPE (MP) = FIXEDTYPE;
/* 58 ^ CHARACTER */
TYPE (MP) = CHRTYPE;
/* 59 ^ LABEL */
TYPE (MP) = FORWARDTYPE;
/* 60 ^ <BIT HEAD> <NUMBER> ) */
IF FIXV(MPP1) <= 9 THEN TYPE (MP) = BYTETYPE; ELSE
IF FIXV (MPP1) <= 36 THEN TYPE (MP) = FIXEDTYPE; ELSE
TYPE (MP) = CHRTYPE;
/* 61 <BIT HEAD> ::= BIT ( */
;
/* 62 <BOUND HEAD> ::= <IDENTIFIER SPECIFICATION> ( */
;
/* 63 <IDENTIFIER SPECIFICATION> ::= <IDENTIFIER> */
DO;
INX(MP) = 1;
FIXL(MP) = CASEP;
CALL STACK_CASE (ENTER(VAR(MP),0,0,0));
END;
/* 64 ^ <IDENTIFIER LIST> */
/* 64 <IDENTIFIER> ) */
DO;
INX(MP) = INX(MP) + 1;
CALL STACK_CASE (ENTER(VAR(MPP1),0,0,0));
END;
/* 65 <IDENTIFIER LIST> ::= ( */
DO;
INX(MP) = 0;
FIXL(MP) = CASEP;
END;
/* 66 ^ <IDENTIFIER LIST> <IDENTIFIER> , */
DO;
INX(MP) = INX(MP) + 1;
CALL STACK_CASE (ENTER(VAR(MPP1),0,0,0));
END;
/* 67 <INITIAL LIST> ::= <INITIAL HEAD> <CONSTANT> ) */
CALL SETINIT;
/* 68 <INITIAL HEAD> ::= INITIAL ( */
IF INX(MP-1) = 1 THEN
ITYPE = TYPE (MP-1); /* COPY INFORMATION FROM <TYPE DECLARATION> */
ELSE
DO;
CALL ERROR ('INITIAL MAY NOT BE USED WITH IDENTIFIER LIST',0);
ITYPE = 0;
END;
/* 69 ^ <INITIAL HEAD> <CONSTANT> , */
CALL SETINIT;
/* 70 <ASSIGNMENT> ::= <VARIABLE> <REPLACE> <EXPRESSION> */
CALL GENSTORE(MP,SP);
/* 71 ^ <LEFT PART> <ASSIGNMENT> */
CALL GENSTORE(MP,SP);
/* 72 <REPLACE> ::= = */
;
/* 73 <LEFT PART> ::= <VARIABLE> , */
;
/* 74 <EXPRESSION> ::= <LOGICAL FACTOR> */
;
/* 75 ^ <EXPRESSION> ^ <LOGICAL FACTOR> */
CALL ARITHEMIT (IOR,1);
/* 76 <LOGICAL FACTOR> ::= <LOGICAL SECONDARY> */
;
/* 77 ^ <LOGICAL FACTOR> & */
/* 77 <LOGICAL SECONDARY> */
CALL ARITHEMIT (AND,1);
/* 78 <LOGICAL SECONDARY> ::= <LOGICAL PRIMARY> */
;
/* 79 ^ \ <LOGICAL PRIMARY> */
DO;
CALL MOVESTACKS (SP, MP);
/* GET 1'S COMPLEMENT */
CALL FORCEACCUMULATOR(MP);
CALL EMITINST (SETCA,REG(MP),0,0,0,0);
END;
/* 80 <LOGICAL PRIMARY> ::= <STRING EXPRESSION> */
;
/* 81 ^ <STRING EXPRESSION> <RELATION> */
/* 81 <STRING EXPRESSION> */
/* RELATIONS ARE ENCODED AS TO THEIR CAM? INSTRICTION CODE */
/*
< 1
> 7
\= 6
= 2
<= 3
\> 3
>= 5
\< 5
*/
DO;
I = TYPE (MP);
J = TYPE (SP);
IF I = DESCRIPT ^ I = CHRTYPE THEN CALL STRINGCOMPARE; ELSE
IF I = VARIABLE & SYTYPE(FIXL(MP)) = CHRTYPE THEN CALL STRINGCOMPARE; ELSE
IF J = DESCRIPT ^ J = CHRTYPE THEN CALL STRINGCOMPARE; ELSE
IF J = VARIABLE & SYTYPE(FIXL(SP)) = CHRTYPE THEN CALL STRINGCOMPARE; ELSE
DO;
IF I = VARIABLE & SYTYPE(FIXL(MP)) = BYTETYPE THEN
CALL FORCEACCUMULATOR(MP);
IF J = VARIABLE & SYTYPE(FIXL(SP)) = BYTETYPE THEN
CALL FORCEACCUMULATOR(SP);
IF SHOULDCOMMUTE THEN CALL FORCEACCUMULATOR(SP);
ELSE CALL FORCEACCUMULATOR(MP);
I = FINDAR;
CALL EMITINST(MOVEI,I,0,1,0,0);
CALL ARITHEMIT (CAM+INX(MPP1),1);
CALL EMITINST (MOVEI,I,0,0,0,0);
STILLCOND = INX(MPP1);
ACC(REG(MP))=AVAIL;
REG(MP) = I;
TYPE(MP) = ACCUMULATOR;
END;
END;
/* 82 <RELATION> ::= = */
INX(MP) = 2;
/* 83 ^ < */
INX(MP) = 1;
/* 84 ^ > */
INX(MP) = 7;
/* 85 ^ \ = */
INX(MP) = 6;
/* 86 ^ \ < */
INX (MP) = 5;
/* 87 ^ \ > */
INX(MP) = 3;
/* 88 ^ < = */
INX(MP) = 3;
/* 89 ^ > = */
INX (MP) = 5;
/* 90 <STRING EXPRESSION> ::= <ARITHMETIC EXPRESSION> */
;
/* 91 ^ <STRING EXPRESSION> ^^ */
/* 91 <ARITHMETIC EXPRESSION> */
DO; /* CATENATE TWO STRINGS */
CALL FORCEDESCRIPTOR (MP);
CALL DELETE_MOVE (MP,MOVEM,REG(MP),0,A,0,3);
ACC(REG(MP)) = AVAIL;
CALL FORCEDESCRIPTOR (SP);
CALL DELETE_MOVE (SP,MOVEM,REG(SP),0,B,0,3);
ACC(REG(SP)) = AVAIL;
CALL SAVE_ACS (2);
IF ACC(11) \= AVAIL THEN CALL EMITINST (PUSH,15,0,11,0,0);
CALL EMITINST (PUSHJ,15,0,CATENTRY,0,2);
IF ACC(11) \= AVAIL THEN CALL EMITINST (POP,15,0,11,0,0);
CALL RESTORE_ACS (2);
I = FINDAR;
CALL EMITINST (MOVE,I,0,0,0,0);
STILLINZERO = I;
REG(MP) = I;
END;
/* 92 <ARITHMETIC EXPRESSION> ::= <TERM> */
;
/* 93 ^ <ARITHMETIC EXPRESSION> + */
/* 93 <TERM> */
CALL ARITHEMIT (ADD,1);
/* 94 ^ <ARITHMETIC EXPRESSION> - */
/* 94 <TERM> */
CALL ARITHEMIT (SUB,0);
/* 95 ^ + <TERM> */
CALL MOVESTACKS (MPP1, MP);
/* 96 ^ - <TERM> */
DO;
CALL MOVESTACKS (MPP1, MP);
IF TYPE (MP) = CONSTANT THEN FIXV (MP) = - FIXV (MP);
ELSE
DO;
CALL FORCEACCUMULATOR (MP);
CALL EMITINST (MOVN,REG(MP),0,REG(MP),0,0);
END;
END;
/* 97 <TERM> ::= <PRIMARY> */
;
/* 98 ^ <TERM> * <PRIMARY> */
CALL ARITHEMIT (IMUL,1);
/* 99 ^ <TERM> / <PRIMARY> */
CALL DIVIDE_CODE(1);
/* 100 ^ <TERM> MOD <PRIMARY> */
CALL DIVIDE_CODE(0);
/* 101 <PRIMARY> ::= <CONSTANT> */
;
/* 102 ^ <VARIABLE> */
;
/* 103 ^ ( <EXPRESSION> ) */
CALL MOVESTACKS (MPP1, MP);
/* 104 <VARIABLE> ::= <IDENTIFIER> */
/* THE FOLLOWING USE IS MADE OF THE PARALLEL STACKS BELOW <VARIABLE>
CNT THE NUMBER OF SUBSCRIPTS
FIXL THE SYMBOL TABLE POINTER
FIXV BUILTIN CODE IF SPECIAL
TYPE VARIABLE
INX ZERO OR ACCUMULATOR OF SUBSCRIPT
AFTER THE VARIABLE IS FORCED INTO AN ACCUMULATOR
TYPE ACCUMULATOR OR DESCRIPT
REG CURRENT ACCUMULATOR
*/
DO; /* FIND THE IDENTIFIER IN THE SYMBOL TABLE */
CALL ID_LOOKUP (MP);
IF FIXL (MP) = -1 THEN CALL UNDECLARED_ID (MP);
END;
/* 105 ^ <SUBSCRIPT HEAD> <EXPRESSION> ) */
DO; /* EITHER A PROCEDURE CALL, ARRAY, OR BUILTIN FUNCTION */
CNT (MP) = CNT (MP) + 1; /* COUNT SUBSCRIPTS */
I = FIXV (MP); /* ZERO OR BUILTIN FUNCTION NUMBER */
IF I < 6 THEN DO CASE I;
/* CASE 0 -- ARRAY OR CALL */
DO;
IF SYTYPE (FIXL (MP)) = PROCTYPE
^ SYTYPE (FIXL (MP)) = CHARPROCTYPE THEN CALL STUFF_PARAMETER;
ELSE
IF CNT (MP) > 1 THEN
CALL ERROR ('MULTIPLE SUBSCRIPTS NOT ALLOWED', 0);
ELSE
DO;
CALL FORCEACCUMULATOR (MPP1);
INX (MP) = REG(MPP1);
END;
END;
/* CASE 1 -- BUILTIN FUNCTION LENGTH */
DO;
CALL FORCEDESCRIPTOR (MPP1);
CALL EMITINST(LSH,REG(MPP1),0, -27,0,0);/* SHIFT OUT ADDRESS */
TYPE (MP) = ACCUMULATOR;
REG(MP) = REG(MPP1);
END;
/* CASE 2 -- BUILTIN FUNCTION SUBSTR */
DO; /* BUILTIN FUNCTION SUBSTR */
IF CNT(MP) = 2 THEN
DO;
IF TYPE(MPP1) = CONSTANT THEN
DO; /* EMIT A COMPLEX CONSTANT */
CALL EMITCONSTANT (SHL(FIXV(MPP1),27)-FIXV(MPP1));
CALL EMITINST (SUB,REG(MP),0,ADR,0,1);
END;
ELSE
DO;
CALL FORCEACCUMULATOR (MPP1);
CALL EMITINST (ADD,REG(MP),0,REG(MPP1),0,0);
CALL EMITINST (LSH,REG(MPP1),0, 27,0,0);
CALL EMITINST (SUB,REG(MP),0,REG(MPP1),0,0);
ACC(REG(MPP1)) = AVAIL;
END;
END;
ELSE
DO; /* THREE ARGUMENTS */
IF TYPE(MPP1) = CONSTANT THEN
DO; /* MAKE A CONSTANT LENGTH TO OR IN */
CALL EMITCONSTANT (SHL(FIXV(MPP1),27));
CALL EMITINST (IOR,REG(MP),0,ADR,0,1);
END;
ELSE
DO;
CALL FORCEACCUMULATOR (MPP1);
CALL EMITINST (LSH,REG(MPP1),0, 27,0,0);
CALL EMITINST(IOR,REG(MP),0,REG(MPP1),0,0);
ACC(REG(MPP1)) = AVAIL;
END;
END;
TYPE (MP) = DESCRIPT;
END;
/* CASE 3 -- BUILTIN FUNCTION BYTE */
DO; /* BUILTIN FUNCTION BYTE */
IF CNT(MP) = 1 THEN
DO;
IF TYPE (MPP1) = CHRTYPE THEN
DO;
FIXV(MP) = BYTE(VAR(MPP1));
TYPE (MP) = CONSTANT;
END;
ELSE
DO;
CALL FORCEDESCRIPTOR (MPP1);
CALL EMITINST (AND,REG(MPP1),0,ADDRMASK,0,1);
/* FAKE A COREBYTE */
TYPE(MPP1) = VARIABLE;
FIXL(MPP1) = COREBYTELOC;
INX(MPP1) = REG(MPP1);
CNT(MPP1) = 1;
CALL FORCEACCUMULATOR (MPP1);
TYPE(MP) = TYPE(MPP1);
REG(MP) = REG(MPP1);
END;
END;
ELSE IF CNT (MP) = 2 THEN
DO;
SP = MPP1; /* SO WE CAN USE ARITHEMIT */
CALL ARITHEMIT (ADD,1);
/* FAKE A COREBYTE */
TYPE(MPP1) = VARIABLE;
FIXL(MPP1) = COREBYTELOC;
CNT(MPP1) = 1;
INX(MPP1) = REG(MP);
CALL FORCEACCUMULATOR(MPP1);
TYPE(MP) = TYPE(MPP1);
REG(MP) = REG(MPP1);
END;
ELSE CALL ERROR (TOOMSG ^^ SYT(FIXL(MP)),0);
END;
/* CASE 4 -- BUILTIN FUNCTION SHL */
CALL SHIFT_CODE (0); /* <- */
/* CASE 5 -- BUILTIN FUNCTION SHR */
CALL SHIFT_CODE (1); /* -> */
END; /* CASE ON I */
ELSE IF I = 9 THEN CALL EMIT_INLINE(1); /*BUILT-IN FUNCTION INLINE */
ELSE IF I = 18 THEN
DO; /* BUILTIN FUNCTION ADDR */
CALL FORCEADDRESS (MPP1);
TYPE (MP) = ACCUMULATOR;
END;
ELSE DO; /* SOME SORT OF BUILTIN FUNCTION */
CALL FORCEACCUMULATOR(MPP1);
IF CNT(MP) = 1 THEN REG(MP) = REG(MPP1);
ELSE INX(MP) = REG(MPP1);
END;
END;
/* 106 <SUBSCRIPT HEAD> ::= <IDENTIFIER> ( */
DO;
CALL ID_LOOKUP(MP);
IF FIXL(MP) = -1 THEN CALL UNDECLARED_ID (MP);
END;
/* 107 ^ <SUBSCRIPT HEAD> <EXPRESSION> , */
DO; /* BUILTIN FUNCTION OR PROCEDURE CALL */
CNT (MP) = CNT (MP) + 1;
IF FIXV (MP) = 0 THEN
DO; /* NOT A BUILTIN FUNCTION */
IF SYTYPE(FIXL(MP)) = PROCTYPE
^ SYTYPE(FIXL(MP)) = CHARPROCTYPE THEN CALL STUFF_PARAMETER;
ELSE CALL FORCEACCUMULATOR (MPP1);
END;
ELSE IF FIXV(MP) = 2 ^ FIXV (MP) = 3 THEN
DO; /* SUBSTR OR BYTE */
IF CNT(MP) = 1 THEN
DO;
CALL FORCEDESCRIPTOR (MPP1);
TYPE (MP) = ACCUMULATOR;
REG(MP) = REG(MPP1);
END;
ELSE IF CNT (MP) = 2 & FIXV (MP) = 2 THEN
DO; /* JUST SUBSTR, WE'LL NOTE ERROR ON BYTE LATER */
IF TYPE(MPP1) \= CONSTANT ^ FIXV(MPP1) \= 0 THEN
DO;
SP = MPP1; /* SO WE CAN USE ARITHEMIT */
CALL ARITHEMIT (ADD,1);
FIXV(MP) = 2; /* IF IT COMMUTES, ARITHMIT CHANGES IT */
END;
CALL EMITINST(AND,REG(MP),0,ADDRMASK,0,1);/* AND OUT LENGTH */
END;
ELSE CALL ERROR (TOOMSG ^^ SYT(FIXL(MP)),0);
END;
ELSE IF FIXV(MP) = 4 ^ FIXV (MP) = 5 THEN
DO; /* SHR OR SHL */
CALL FORCEACCUMULATOR (MPP1);
REG(MP) = REG(MPP1);
END;
ELSE IF FIXV(MP) = 9 THEN CALL EMIT_INLINE(0); /* INLINE */
ELSE DO; /* SOME SORT OF BUILTIN FUNCTION */
IF CNT (MP) = 1 THEN
DO;
CALL FORCEACCUMULATOR (MPP1); /* PICK UP THE VARIABLE */
REG(MP) = REG(MPP1);
END;
ELSE CALL ERROR (TOOMSG ^^ SYT(FIXL(MP)),0);
END;
END;
/* 108 <CONSTANT> ::= <STRING> */
TYPE (MP) = CHRTYPE;
/* 109 ^ <NUMBER> */
TYPE (MP) = CONSTANT;
END; /* OF CASE ON PRODUCTION NUMBER */
END SYNTHESIZE;
/* SYNTACTIC PARSING FUNCTIONS */
CONFLICT: PROCEDURE (CURRENT_STATE);
DECLARE I FIXED, CURRENT_STATE FIXED;
/* THIS PROC IS TRUE IF THE CURRENT TOKEN IS NOT */
/* A TRANSITION SYMBOL FROM THE CURRENT STATE */
/* (A CONFLICT THEREFORE EXISTS BETWEEN THE */
/* CURRENT STATE AND THE NEXT TOKEN) */
I = INDEX1(CURRENT_STATE); /* STARTING POINT FOR STATE */
/* TRANSITION SYMBOLS */
DO I = I TO I+INDEX2(CURRENT_STATE)-1; /* COMPARE WITH EACH */
IF READ1(I) = TOKEN THEN RETURN (FALSE); /* FOUND IT */
END;
RETURN (TRUE); /* NOT THERE */
END CONFLICT;
RECOVER: PROCEDURE;
DECLARE ANSWER BIT(1);
/* THIS IS A VERY CRUDE ERROR RECOVERY PROCEDURE */
/* IT RETURNS TRUE IF THE PARSE MUST BE RESUMED IN */
/* A NEW STATE (THE ONE IN THE CURRENT POSITION OF THE STATE */
/* STACK) */
/* IT RETURNS FALSE IF THE PARSE IS RESUMED WITH THE SAME */
/* STATE AS WAS INTENDED BEFORE RECOVER WAS CALLED */
ANSWER = FALSE;
/* IF THIS IS THE SECOND SUCCESSIVE CALL TO RECOVER, DISCARD */
/* ONE SYMBOL (FAILSOFT IS SET TRUE BY SCAN) */
IF \ FAILSOFT & 1 THEN CALL SCAN;
FAILSOFT = FALSE;
/* FIND SOMETHING SOLID IN THE TEXT */
DO WHILE (\STOPIT(TOKEN) & 1);
CALL SCAN;
END;
NO_LOOK_AHEAD_DONE = FALSE;
/* DELETE PARSE STACK UNTIL THE HARD TOKEN IS */
/* LEGAL AS A TRANSITION SYMBOL */
DO WHILE CONFLICT (STATE_STACK(SP));
IF SP > 0
THEN DO;
/* DELETE ONE ITEM FROM THE STACK */
SP = SP - 1;
ANSWER = TRUE; /* PARSE TO BE RESUMED IN NEW STATE */
END;
ELSE DO; /* STACK IS EMPTY */
/* TRY TO FIND A LEGAL TOKEN (FOR START STATE) */
CALL SCAN;
IF TOKEN = EOFILE
THEN DO;
/* MUST STOP COMPILING */
/* RESUME PARSE IN AN ILLEGAL STATE */
ANSWER = TRUE;
STATE_STACK(SP) = 0;
RETURN (ANSWER);
END;
END;
END;
/* FOUND AN ACCEPTABLE TOKEN FROM WHICH TO RESUME THE PARSE */
CALL PRINTLINE ('RESUME:' ^^ SUBSTR(POINTER,LENGTH(POINTER)-
(LINE_LENGTH+CP-TEXT_LIMIT-LB-1)+LENGTH(BCD)),-1);
RETURN (ANSWER);
END RECOVER;
COMPILATION_LOOP:
PROCEDURE;
DECLARE OVERFLOW CHARACTER INITIAL (
'STACK OVERFLOW *** COMPILATION ABORTED ***');
DECLARE I FIXED, J FIXED, STATE FIXED;
DECLARE END_OF_FILE CHARACTER INITIAL (
'END OF FILE FOUND UNEXPECTEDLY *** COMPILATION ABORTED ***');
/* THIS PROC PARSES THE INPUT STRING (BY CALLING THE SCANNER) */
/* AND CALLS THE CODE EMISSION PROC (SYNTHESIZE) WHENEVER A */
/* PRODUCTION CAN BE APPLIED */
/* INITIALIZE */
COMPILING = TRUE;
STATE = START_STATE;
SP = -1;
/* STOP COMPILING IF FINISHED */
COMP: DO WHILE (COMPILING);
/* FIND WHICH OF THE FOUR KINDS OF STATES WE ARE DEALING WITH: */
/* READ,APPLY PRODUCTION,LOOKAHEAD, OR PUSH STATE */
IF STATE <= MAXR#
THEN DO; /* READ STATE */
SP = SP+1; /* ADD AN ELEMENT TO THE STACK */
IF SP = STACKSIZE
THEN DO;
CALL ERROR (OVERFLOW,2);
RETURN;
END;
STATE_STACK(SP) = STATE; /* PUSH PRESENT STATE */
I = INDEX1(STATE); /* GET STARTING POINT */
IF NO_LOOK_AHEAD_DONE
THEN DO; /* READ IF NECESSARY */
CALL SCAN;
NO_LOOK_AHEAD_DONE = FALSE;
END;
/* COMPARE TOKEN WITH EACH TRANSITION SYMBOL IN */
/* READ STATE */
DO I = I TO I+INDEX2(STATE)-1;
IF READ1(I) = TOKEN
THEN DO; /* FOUND IT */
VAR(SP) = BCD;
FIXV(SP) = NUMBER_VALUE;
FIXL(SP) = CARD_COUNT;
PPSAVE(SP) = PP;
STATE = READ2(I);
NO_LOOK_AHEAD_DONE = TRUE;
GO TO COMP;
END;
END;
/* FOUND AN ERROR */
CALL ERROR ('ILLEGAL SYMBOL PAIR: ' ^^
VOCAB(STATE_NAME(STATE)) ^^ X1 ^^
VOCAB(TOKEN),1);
CALL STACK_DUMP; /* DISPLAY THE STACK */
/* TRY TO RECOVER */
IF RECOVER
THEN DO;
STATE = STATE_STACK(SP); /* NEW STARTING PT */
IF STATE = 0
THEN DO; /* UNEXPECTED EOFILE */
CALL ERROR (END_OF_FILE,2);
RETURN;
END;
END;
SP = SP-1; /* STACK AT SP CONTAINS JUNK */
END;
ELSE
IF STATE > MAXP#
THEN DO; /* APPLY PRODUCTION STATE */
/* SP POINTS AT RIGHT END OF PRODUCTION */
/* MP POINTS AT LEST END OF PRODUCTION */
MP = SP-INDEX2(STATE);
MPP1 = MP+1;
CALL SYNTHESIZE (STATE-MAXP#); /* APPLY PRODUCTION */
SP = MP; /* RESET STACK POINTER */
I = INDEX1(STATE);
/* COMPARE TOP OF STATE STACK WITH TABLES */
J = STATE_STACK(SP);
DO WHILE APPLY1(I) \= 0;
IF J = APPLY1(I) THEN GO TO TOP_MATCH;
I = I+1;
END;
/* HAS THE PROGRAM GOAL BEEN REACHED */
TOP_MATCH: IF APPLY2(I) =0
THEN DO; /* YES IT HAS */
COMPILING = FALSE;
RETURN;
END;
STATE = APPLY2(I); /* PICK UP THE NEXT STATE */
END;
ELSE
IF STATE <= MAXL#
THEN DO; /* LOOKAHEAD STATE */
I = INDEX1(STATE); /* INDEX INTO THE TABLE */
IF NO_LOOK_AHEAD_DONE
THEN DO; /* GET A TOKEN */
CALL SCAN;
NO_LOOK_AHEAD_DONE = FALSE;
END;
/* CHECK TOKEN AGAINST LEGAL LOOKAHEAD TRANSITION SYMBOLS*/
DO WHILE LOOK1(I) \= 0;
IF LOOK1(I) = TOKEN
THEN GO TO LOOK_MATCH; /* FOUND ONE */
I = I+1;
END;
LOOK_MATCH: STATE = LOOK2(I);
END;
ELSE DO; /* PUSH STATE */
SP = SP+1; /* PUSH A NON-TERMINAL ONTO THE STACK */
IF SP = STACKSIZE
THEN DO;
CALL ERROR (OVERFLOW,2);
RETURN;
END;
/* PUSH A STATE # INTO THE STATE_STACK */
STATE_STACK(SP) = INDEX2(STATE);
/* GET NEXT STATE */
STATE = INDEX1(STATE);
END;
END; /* OF COMPILE LOOP */
END COMPILATION_LOOP;
PRINT_TIME:
PROCEDURE (TEXT, TIME);
/* PRINT TEXT FOLLOWED BY TIME, WHICH IS IN MILLISECONDS */
DECLARE TEXT CHARACTER, TIME FIXED;
K = TIME;
I = K / 60000;
J = K MOD 60000 / 1000;
K = K MOD 1000;
CALL PRINTLINE (TEXT ^^ I ^^ ':' ^^ J ^^ '.' ^^ K,-1);
END PRINT_TIME;
/* E X E C U T I O N S T A R T S H E R E */
DECLARE TIME_START FIXED,
TIME_INIT FIXED,
TIME_COMPILE FIXED,
TIME_FINISH FIXED;
TIME_START = RUNTIME; /* GET TIME(CPU) STARTED*/
CALL INITIALIZE;
TIME_INIT = RUNTIME; /* TIME TO INITIALIZE */
CALL COMPILATION_LOOP;
TIME_COMPILE = RUNTIME; /* TIME TO COMPILE THE PROGRAM*/
CONTROL(BYTE('E')) = FALSE;
CONTROL(BYTE('B')) = FALSE;
SUBTITLE = '';
IF CONTROL(BYTE('S')) THEN CALL SYMBOLDUMP;
ELSE EJECT_PAGE;
/* NOW ENTER THE VALUE OF NDESCRIPT */
CALL EMITLABEL (NDESC,5); /* GENERATE LABEL */
IF CONTROL(BYTE('A')) THEN
OUTPUT(DATAFILE) = '$' ^^ NDESC ^^ ':'; /* LABEL FOR ASSEMBLER */
CALL EMITDATAWORD (DSP-1); /* PUT DOWN NUMBER OF DESC'S */
IF CONTROL(BYTE('A')) THEN
OUTPUT(DATAFILE) = 'S=.;'; /* START STRING SEGMENT */
/* ADD THE DESCRIPTORS TO THE DATA SEGMENT */
DO I = 0 TO DSP-1;
IF CONTROL(BYTE('A')) THEN
OUTPUT(DATAFILE)=' BYTE (9)'^^DESCL(I)^^ '(27)' ^^DESCA(I)^^ ';';
CALL OUTPUT_DATAWORD (SHL(DESCL(I),27) + DESCA(I), DP);
CALL EMITLABEL (I,3);
DP = DP + 1;
END;
/* FINAL CODE FOR SYSTEM INTERFACE */
CALL EMITINST (4,0,0,0,0,0);
CALL FLUSH_DATA_BUFFER;
CALL FLUSH_LABELS;
DO WHILE CODE_TAIL \= CODE_HEAD;
CALL OUTPUT_CODEWORD;
END;
CALL OUTPUT_CODEWORD;
CALL FLUSH_CODE_BUFFER;
IF CONTROL(BYTE('A')) THEN
DO;
OUTPUT (CODEFILE) = ' END $0;';
/* COPY CODE FILE TO END OF DATA FILE */
CODESTRING = INPUT(CODEFILE);
DO WHILE LENGTH(CODESTRING) > 0;
OUTPUT(DATAFILE) = CODESTRING;
CODESTRING = INPUT(CODEFILE);
END;
OUTPUT (CODEFILE) = ' ';
END;
FILE(RELFILE) = SYMB_TYPE + 2; /* GENERATE EXTERNAL REFS */
FILE(RELFILE) = "(3)040000000000";
FILE(RELFILE) = "(3)600000000000" + RADIX50 ('XPLLIB');
FILE(RELFILE) = LIBRARY;
FILE(RELFILE) = START_TYPE + 1;
FILE(RELFILE) = "(3)200000000000";
FILE(RELFILE) = "(3)400000" + STARTLOC;
FILE(RELFILE) = END_TYPE + 2;
FILE(RELFILE) = "(3)240000000000";
FILE(RELFILE) = "(3)400000" + PP;
FILE(RELFILE) = DP;
TIME_FINISH = RUNTIME; /* TIME TO DO ALL BUT FINAL STATS */
CALL PRINTLINE (SUBSTR(X70, 0, 40) ^^ 'C O M P I L E R S T A T I S T I C S',-1);
CALL PRINTLINE (CARD_COUNT ^^ ' LINES CONTAINING ' ^^ STATEMENT_COUNT ^^
' STATEMENTS WERE COMPILED.',0);
IF ERROR_COUNT = 0 THEN CALL PRINTLINE ('NO ERRORS WERE DETECTED.',-1);
ELSE IF ERROR_COUNT > 1 THEN
CALL PRINTLINE (ERROR_COUNT ^^ ' ERRORS (' ^^ SEVERE_ERRORS
^^ ' SEVERE) WERE DETECTED.',-1);
ELSE IF SEVERE_ERRORS = 1 THEN CALL PRINTLINE ('ONE SEVERE ERROR WAS DETECTED.',-1);
ELSE CALL PRINTLINE ('ONE ERROR WAS DETECTED.',-1);
IF PREVIOUS_ERROR > 0 THEN
CALL PRINTLINE ('LAST ERROR WAS ON LINE ' ^^ PREVIOUS_ERROR ,-1);
CALL PRINTLINE (PP ^^ ' WORDS OF PROGRAM, ' ^^ DP-DSP ^^ ' WORDS OF DATA, AND ' ^^
DSP ^^ ' WORDS OF DESCRIPTORS. TOTAL CORE REQUIREMENT ' ^^ PP+DP ^^
' WORDS.',-1);
/* NOW COMPUTE TIMES AND PRINT THEM */
TIME_INIT = TIME_INIT - TIME_START;
TIME_COMPILE = TIME_COMPILE - TIME_START;
TIME_FINISH = TIME_FINISH - TIME_START;
CALL PRINT_TIME ('TOTAL TIME IN COMPILER = ',TIME_FINISH);
CALL PRINT_TIME ('INITIALIZATION TIME = ',TIME_INIT);
CALL PRINT_TIME ('ACTUAL COMPILATION TIME = ',TIME_COMPILE - TIME_INIT);
CALL PRINT_TIME ('POST-COMPILATION CLEAN-UP = ',TIME_FINISH-TIME_COMPILE);
IF CONTROL(BYTE('D')) THEN CALL DUMPIT;
EOF EOF EOF EOF EOF EOF EOF EOF EOF EOF EOF EOF EOF EOF EOF EOF EOF EOF EOF EOF