.TITLE IDENT / / 5 AUG 74 (JAS) IMPLEMENT VARIABLE RETURN / 1 AUG 74 (PDH, JAS) CHANGE 'SV' ERRORS TO 'DM' ERRORS / 31 JUL 74 (PDH) ISSUE '.IODEV TRDV' FOR '$TRACEON' / 14 JUN 74 (JAF) FIX UP DATA IN SPECS AGAIN AFTER BLOCK DATA CHANGES / 12 JUN 74 (JAF, JAS) BLOCK DATA IMPLEMENTATION; REMOVE '.EBREL' / 17 APR 74 (JAF, JAS) NO EQUIVALENCE OF FORMAL PARAMETERS / 27 MAR 74 (JAS) REMOVE EXTRA WORD FROM CHARACTER DOPE VECTOR / 6 MAR 74 (PDH) ADD LOGICAL, COMPLEX, CHARACTER FUNCTION / (JAF) FIX OUTPUT OF NEGATIVE CONSTANTS AND VARIABLES / 5 MAR 74 (JAS) FIX UP NEGATIVE DIMENSIONS [ (-2/3) ] / 27 FEB 74 (JAF, JAS) UPDATE 'CPOINT' IN CLEAN-UP / 22 FEB 74 (JAS,JAF) CORE-TO-CORE I/O FIX / 20 FEB 74 (JAF, JAS) FIX UP CHARACTERS IN DATA STATEMENTS / 14 FEB 74 (JAF) CHANGE 'TEMPAC' TO 'TEMPA2' FOR STATEMENT FUNCTION REASONS / 7 FEB 74 (PDH) BEGIN IMPLEMENTATION OF BLOCK DATA / 17 SEP 73 (PDH) CHANGE DEVICE NUMBER REFERENCES TO SYMBOLIC / 11 SEP 73 (PDH) .WAIT BEFORE .EXIT; .EBREL / 6 SEP 73 (JAS) FIX DATA FOR CHARACTER VARIABLES / 1 AUG 73 (JAS) MAKE SYMBOL TABLE COME OUT IN CORRECT SEQUENCE / 25 JUL 73 (JAS) FIX COUNT DOPE VECTORS FOR SIMPLE CHARACTER VARIABLES / 4 JUL 73 (JAS) FIX DATA IN SPECIFICATION / 3 JUL 73 (PDH) $TRACEON & $TRACEOFF / 17 APR 73 (JAS) FIX UP ' IF (LOG) IF (ARITH) . . .' / / / THE FOLLOWING ARE THE GLOBL VARIABLES: / / IN WATRAN - / ADDRESSES: .GLOBL BOX,CHI,CHIEND,LIST,LIST1,NXTSPC,RETRN .GLOBL BASE2,BASE3,TESOUT,SETPT2,JOINCK,.START / SUBROUTINES: .GLOBL INSERT,ERROR,ERRORS,WARN,HIERAR,STLINE,PROCES,HOOK / SWITCHES: .GLOBL EQSWT,EQSWL,MODESW,STATSW,EQUVSW,LST / / IN IDENT - / ADDRESSES: .GLOBL BASE1,DTSTAT,DTSTOR,IFSTAT,ERSW,OVERS .GLOBL SYMPRT,EXITSW,KIND,FORMBX .GLOBL ARITH,ASSGN,CALLS,CHARAC,.CONT,COMMN,COMPLX .GLOBL DATA,DBCPLX,DBLINT,DBLREL,DIMEN,DO,END,EQUIV .GLOBL EXTRNL,FORMAT,FUNCT,.GOTO,IFBRAC .GLOBL INTGR,LOGIC,.PAUSE,PRINT.,PUNCH.,READBR,READ. .GLOBL REAL,RETR,STOP,SUBR,TRACON,TRACOFF,WRITEB .GLOBL LOGICF,INTF,DINTF,REALF,DREALF,CMPLXF,CHARF .GLOBL ENDFIL,BLDATA .GLOBL STSIZE,MODPTR,BITPTR,CPOINT / SUBROUTINES: .GLOBL SHOVE,PULL,CLENUP,EQUCLN,WDSIZE,ARYSIZ,ENDDO,REPACK / SWITCHES: .GLOBL COMSW,TYPESW,CMNSWH,ENDSW,IFSW,IFSTOR,DEVICE,DIMCNT .GLOBL HEADER,CHRCNT / / IN SEARCH - / ADDRESSES: .GLOBL FLTFLG,CHINXT,VANTED,VANT1,VANT2,INDEX,IND / SUBROUTINES: .GLOBL SEARCH,GETCHI,RECORD,REGAIN,REPLCE / / IN CALCP - / ADDRESSES: .GLOBL SAVCMN,TBPOSN,TBADDR,OPT2,DTNEXT,OTNEXT .GLOBL DTABLE,PTABLE,OTABLE,OPLACE,INTAB / SUBROUTINES: .GLOBL CALCP,GETOTB,GETADR,DLOTAB / / IN GEARS - / ADDRESSES: .GLOBL NUMS,CHARCT / SUBROUTINES: .GLOBL G.MOVE,G.SCAN,G.INIT,G.STPC,G.PACK,G.CVRT / / IN SYMBOL - / SUBROUTINES: .GLOBL SYMBOL / / IN EXPRES - / ADDRESSES: .GLOBL SPOT2,AD2,CLEW2,ACCSW,TEMPA2,HIDCON / / SUBROUTINES: .GLOBL EXPRES .GLOBL PLXPIK / IN ASCOM - / ADDRESSES: .GLOBL VARAA,VARAC / SUBROUTINES: .GLOBL ASCOM / / IN BIN1 - / ADDRESSES: .GLOBL OPCODE,DRESS,CLUES,LOCCNT,ITEM / SUBROUTINES: .GLOBL PUNCH .GLOBL CLOSER,NAMEIT,ITEMIN,ITEM4,ITEM5,INSRT / / IN APPEND - / ADDRESSES: .GLOBL START,CNAME,COMPNT,NXTADR / SUBROUTINES: .GLOBL APPEND,CHKNAM / / / / MACRO FOR EXIT .DEFIN EXIT JMP* RETRN .ENDM .EJECT / THIS SECTION PROCESSES ALL ARITHMETIC STATEMENTS ARITH LAW H5!.EXC JMS* HIERAR DZM* EQSWL LAC* CHI TAD (1 DAC* INDEX CLC DAC* IND JMS* GETCHI JMS* ASCOM EXIT .EJECT / ASSGN LAW H5!.EXC JMS* HIERAR EXIT .EJECT / CALLS LAW H5!.EXC JMS* HIERAR JMS* GETCHI LAW EXPILL!CALLSW JMS* EXPRES WRNSXA WRNSXA .DSA OUTCAL WRNSXA / WRNSXA JMS* WARN /WARNING: CHARACTERS ENCOUNTERED AFTER ')' .SIXBT 'SXA' OUTCAL EXIT .EJECT / .CONT LAW H5!.EXC JMS* HIERAR EXIT .EJECT / / COMMON STATEMENTS / COMMN LAW H3!NON.EX!BDLEGL JMS* HIERAR ISZ COMSW / INDICATES WE ARE IN COMMON STATEMENT ISZ CMNSWH / INDICATES A COMMON STAT HAS OCCURRED JMS* GETCHI /SET UP NEXT CHARACTER SAD (SLASH SKP JMP BNKCMN /NO. IT IS BLANK COMMON CMNSL1 JMS* GETCHI /YES. LOOKS LIKE NAMED COMMON LAC* CHINXT / LOAD NEXT CHAR SAD (SLASH / IS IT SLASH ? JMP BNKCMN /YES. CHANGED MINDS, // = BLANK COMMON NAMCMN LAC (NAME / WANT NAME NOW JMS* SEARCH / GET NAME LAC (COMNAM / INDICATES NAMED COMMON FOR CALCP JMS* CALCP LAC* CHINXT SAD (SLASH / LAST DELIMITER SHOULD BE " / " JMP .+3 / OKAY IT IS ERRCM3 JMS* ERRORS .SIXBT 'CM3' JMS* GETCHI / GET NEXT CHARACTER JMP SAVPTR / BNKCMN LAC BNKNAM DAC* VANTED DZM* VANT1 LAC (COMNAM JMS* CALCP SAVPTR LAC* TBPOSN / GET LAST POINTER TO COMMON NAME DAC SAVCMN / SAVE ADDRESS OF COMMON NAME LAC* CHINXT / RETREIVE CHARACTER SAD (ENDST / ARE THERE ANY VARIABLES EXIT / NO JMP SPECST / YES. ENTER GENERAL SECTION NOW / / THE FOLLOWING IS THE NAME UNDER WHICH UN-NAMED COMMONS / STORED INTERNALLY. IT IS ' .XX ' BNKNAM POINT*100+XXX*100+XXX / .EJECT / BLOCK DATA COMES HERE / BLDATA LAC (BLOCKD DAC KIND / MARK AS BLOCK DATA LAC BL1 DAC* VANTED / DUMMY UP A PROGRAM NAME LAC BL2 / FOR LOADER IN CASE OF DAC* VANT1 / MULTIPLE PROGRAMS BEING COMPILED. DZM* CNAME / BLANK OUT COMMON NAME FOR DATA PUNCHING LAW H1!NON.EX!BDLEGL JMS* HIERAR DZM HEADER / NO START CODE SPACE REQUIRED FOR BLOCK DATA EXIT / BL1 BB*100+POINT*100+DD / DUMMY FILE NAME FOR BLOCK DATA BL2 AA*100+TT*100+AA / ERRBD0 JMS* ERRORS / ERROR - ATTEMPT TO INITIALIZE NON-COMMON .SIXBT 'BD0' / VARIABLE IN BLOCK DATA .EJECT / / / / SPACE FOR DATA VARIABLES IS ABOUT TO BE ASSIGNED SO / THIS SUBROUTINE TESTS IF ANY CODE HAS BEEN COMPILED YET OR / IF THE LAST STATEMENT WAS A DATA STATEMENT. IF NOT, A GO TO / IS COMPILED AROUND THE DATA INFORMATION / USED ALSO BY FORMAT STATEMENTS!!!!!!! TESTGO XX LAC NA / GET LOCATION CNTR AT START OF DATA STAT TAD (-1 SAD* START / IF NA-1=START, THEN NO CODE COMPILED YET JMP* TESTGO / NO CODE EXIT / / THERE HAS BEEN CODE COMPILED, CHECK IS A 'GO TO' IS NEEDED LAC DTSTOR / CONTAINS ADDRESS IN OTABLE FOR UPDATING SZA / DOES A GOTO EXIST THAT WE CAN USE? JMP* TESTGO / YES. NO EXECUTABLE STATEMENTS SINCE / / LAST INTERNAL 'GOTO' / THERE IS NO INTERNAL 'GO TO' THAT WE CAN USE, CHECK IF ONE IS NEEDED TRYUNC LAC* STATSW SZA / WAS LAST STATEMENT A UNCONDITIONAL TRANSFER JMP* TESTGO / YES. DO NOT NEED A INTERNAL GOTO! / /COMPILE AN INTERNAL 'GO TO' AND SAVE ITS OTABLE ADDRESS COMPGO LAC DTSTAT / GET INTERNAL STATEMENT NUMBER ISZ DTSTAT / INCREMENT FOR NEXT TIME DAC* VANTED LAC (STNUM JMS* CALCP / ENTER IN SYMBOL TABLE LAC* OPLACE DAC DTSTOR / SAVE OTABLE ADDRESS FOR UPDATING LAC (GOTO*M XOR* TBADDR / ADD IN RELATIVE OTABLE ADDRESS JMS* ITEM4 / PUNCH OUT 'GOTO' ISZ NA / STEP PAST 'GOTO' JMP* TESTGO / / / DATA STATEMENTS START HERE. SCAN EACH VARIABLE LIST UNTIL THE '/' IS / FOUND AND REPLACE IT WITH A ';' SO EXPRES WON'T GET UNHAPPY. THEN / PROCESS THE VARIABLE LIST BUILDING UP A TABLE (ON TOP OF THE CHI TABLE) / CONTAINING THE OTABLE ADDRESSES IN THE FOLLOWING FORM: / 0NNNNN - SIMPLE VARIABLES / 2NNNNN - ARRAY ELEMENT / 4NNNNN - ARRAY / ONLY SIMPLE VARIABLES NEED SPACE ASSIGNED TO THEM AND THIS MEANS A / 'GO TO' MIGHT HAVE TO BE COMPILED. THE SPACE REQUIRED IS TOTALED / AND A CODE 06 IS ISSUED FOR IT. DATA LAW H5!ILGIF!NON.EX!BDLEGL JMS* HIERAR LAC* LOCCNT DAC NA / SAVE VALUE OF LOC CNTR AT START OF DATA STATEMENT AGDA JMS* GETCHI / GET NEXT CHARACTER IN STRING JMS* RECORD / RECORD POSITION IN CHI, LEAVES CHAR IN AC SKP AGDA0 JMS* GETCHI SAD (ENDST / IS IT ';' JMP ERRDA5 SAD (SLASH SKP!CLL JMP AGDA0 / NOT '/', TRY NEXT CHARACTER JMS* REPLCE / IT IS '/' , REPLACE WITH ';' / / RESET TO THE START OF THIS VARIABLE LIST AND PROCESS EACH VARIABLE LAC* CHI DAC* (AUTO14 / SET AUTO-INDEX FOR LIST JMS* REGAIN / REGAIN POSITION IN CHI, CHAR LEFT IN AC. ISZ EQUVSW / LIE TO EXPRES, MARK AS BEING EQUIVALENCE AGDA1 LAW EXPILL!DFNSW!CONILL JMS* EXPRES .DSA CMMAS .DSA ERRDA5 .DSA SEMCLN .DSA ERRDA5 / SEMCLN LAW -1 DAC ENDNST / MARK '/' AS OCCURRING / CMMAS JMS VARSUB LAC KIND / CHECK IF IN SAD (BLOCKD / BLOCK DATA PROGRAM JMP REJOIN LAC* BITPTR / GET CONTROL BITS RETEST AND (DIMENS!FUNBIT!FORMAL!COMSET!EQUSET SNA JMP SIMPL / SIMPLE VARIABLE SAD (EQUSET / IS IT SIMPLE VARIABLE IN EQUIVALENCE JMP TOSS / YES. AND (DIMENS!FUNBIT!FORMAL!COMSET SAD (DIMENS JMP DIMION / DIMENSIONED VARIABLE AND (FUNBIT!FORMAL!COMSET SAD (COMSET JMP ERRDA9 ERRDA3 JMS* ERRORS .SIXBT 'DA3' ERRDA9 JMS* ERRORS .SIXBT 'DA9' / REJOIN JMS INBLKD LAC* BITPTR XOR (COMSET JMP RETEST / INBLKD XX LAC* BITPTR AND (COMSET / CHECK IF BLOCK DATA ITEM IS IN COMMON SNA JMP ERRBD0 / NO. ERROR! LAC* CNAME / DO WE HAVE A COMMON NAME? SNA JMP PUTCNM / NOT ON 1ST TIME LAC* OPT2 JMS* CHKNAM / DO WE HAVE ANOTHER COMMON NAME? SZA JMP* INBLKD / NO. THIS NAME AGAIN. ERRBD1 JMS* ERRORS / ERROR - MAY ONLY INITIALIZE ONE BLOCK .SIXBT 'BD1' / COMMON AREA PER BLOCK DATA SUBPROGRAM / PUTCNM LAC* OPT2 JMS* CHKNAM LAC* COMPNT DAC* NXTADR JMP* INBLKD / / CHECK IF VARIABLE ALREADY HAS DATA. ONLY SINGLE VARIABLES AND ARRAYS / CAN BE CHECKED, ELEMENTS OF ARRAYS CAN NOT CHKDT XX LAC* BITPTR AND (DATSET SNA JMP* CHKDT WRNDA8 JMS* WARN .SIXBT 'DA8' JMP* CHKDT / / VARIABLES HAS DIMENSIONS. THUS IT ALREADY HAS ITS STORAGE ASSIGNED DIMION LAC* CLEW2 / GET CLUE BITS FROM EXPRES AND (DIMMEN SNA / IS VARIABLE ARRAY NAME OR ELEMENT JMP ELEMNT / ELEMENT JMS CHKDT LAC (400000 / ARRAY NAME, MARK AS SUCH TAD MODPTR JMP TOSS1 ELEMNT LAC (200000 / MARK AS ELEMENT TAD MODPTR DAC* AUTO14 LAC* SPOT2 / GET OFFSET OF ELEMENT WRT THE BASE ADDRESS JMP TOSS1 / / SIMPLE VARIABLES DO NOT HAVE AN ADDRESS YET UNLESS IN COMMON!!! SIMPL LAC* BITPTR AND (COMSET SZA JMP TOSS LAC BITPTR / SAVE VARIABLE BECAUSE TESTGO WILL BOMB IT DAC COUNT / IF IT PUNCHES OUT AN INTERNAL STATEMENT NUMBER JMS TESTGO / NO. COMPILE A 'GO TO' IF REQUIRED LAC COUNT / RESTORE VARIABLE NOW DAC BITPTR JMS CHKDT / CHECK IF VARIABLE ALREADY HAS DATA / NOW INSERT VARIABLE'S ADDRESS IN OTABLE LAC* LOCCNT DAC* OPT1 / PUT ADDRESS IN OTABLE LAC* MODPTR JMS WDSIZE TAD* LOCCNT DAC* LOCCNT / RESET TO ADDRESS FOR NEXT VARIABLE / / IF VARIABLE IS CHARACTER, INCREMENT 'CHRCNT' FOR DOPE VECTORS / LAC* MODPTR AND (17 SAD (CHARM /IS IT CHARACTER VARIABLE? SKP JMP TOSS /NO ISZ CHRCNT ISZ CHRCNT / / TOSS THE VARIABLE'S OTABLE ADDRESS IN THE STACK. IF THIS WAS THE LAST / VARIABLE, GO PROCESS THE CONSTANTS. TOSS LAC MODPTR TOSS1 DAC* AUTO14 LAC (DATSET JMS SHOVE / MARK AS HAVING DATA ISZ ENDNST / IS THIS LAST VARIABLE JMP AGDA1 / NO. GO GET NEXT VARIABLE LAW -1 / YES. DAC* AUTO14 / MARK END OF VARIABLES IN STACK .EJECT / / END OF VARIABLE LIST IS REACHED, GET CONSTANTS DZM COUNT / RSET REPLICATION COUNT LAC* CHI DAC* (AUTO14 / SET UP TO START OF LIST DZM EQUVSW / REMOVE EQUIVALENCE INDICATOR JMS PICCON / END OF CONSTANT LIST LAC COUNT / IF COUNT = 0 TAD* AUTO14 / AND TABLE END = -1 SAD (-1 / THEN VARIABLES ARE FINISHED JMP VCEVEN ERRDA7 JMS* ERRORS / MORE CONSTANTS THAN VARIABLES .SIXBT 'DA7' / / THE VARIABLE AND CONSTANT LISTS CAME OUT EVEN. CHECK IF THE IS / ANOTHER VARIABLE LIST VCEVEN JMS* GETCHI SAD (COMMA JMP AGDA / FORM /, GO GET NEXT LIXT SAD (ENDST JMP DTENTR / END OF STATEMENT ERRDAA JMS* ERRORS / MISSING ',' OR ILLEGAL CONSTRUCTION .SIXBT 'DAA' / / THIS CODE DECIDES WHAT UPDATING SHOULD BE DONE AFTER NON-EXECUTABLE / INFORMATION HAS BEEN PUNCHED OUT. IT IS USED AT THE END OF DATA / STATEMENTS AND FORMAT STATEMENTS. / DATA COMES HERE DTENTR LAC NA SAD* LOCCNT / HAS ANY SPACE BEEN RESERVED? EXIT / NO. CMA / YES. ISSUE A CODE 06 TAD (1 TAD* LOCCNT DAC* ITEM LAC (06 JMS* INSRT / PUNCH OUT THE CODE / FORMAT COMES HERE. NON-EXECUTABLE SPACE HAS BEEN RESERVED FMENTR LAC DTSTOR SNA / WAS AN INTERNAL 'GOTO' COMPILED JMP NOGOTO / NO. LAC* LOCCNT / YES. MUST UPDATE OR SET ADDRESS DAC* DTSTOR EXIT / NO 'GOTO' WAS COMPILED. EITHER STATEMENT WAS PRECEDED BY AN / UNCONDITIONAL 'GOTO' OR NO CODE HAS BEEN COMPILED. NOGOTO LAC* STATSW SZA / WAS PRECEDING STATEMENT UNCOND TRANSFER EXIT / YES. LAW -1 / NO. THUS NO CODE WAS COMPILED. TAD* LOCCNT DAC* START / RESET START OF CODE ADDRESS EXIT .EJECT / / THE VARIABLE LIST IS EXHAUSTED AND THE TABLE HAS BEEN BUILT UP / NOW GET EACH CONSTANT AND PUNCH OUT THE DATA CODES AND INFORMATION GETCON JMS* GETCHI SKP PICCON XX LAW -1 JMS FNDCON LAC* CHINXT SAD (STAR SKP JMP NOREP / NO CONSTANT REPLICATION FACTOR LAC* FLTFLG SAD (CONBIT!SINTGM / IS IT SINGLE INTEGER JMP .+3 / YES. ERRDA0 JMS* ERRORS / NO. ERROR, MODES DISAGREE .SIXBT 'DA0' JMS* GETCHI LAW -1 TAD* VANTED CMA!SPA JMP ERRDA0 / NEGATIVE REPLICATION FACTOR JMS FNDCON / / DO WE NEED A VARIABLE NOREP LAC COUNT SZA / IS VARIABLE FULL JMP CHMD / NO. / / YES. GET THE NEXT VARIABLE ANEWV LAC* AUTO14 / GET NEXT VARIABLE SAD (-1 / IS IT END OF TABLE JMP ERRDA7 / YES. DAC MODPTR / SET UP DTABLE & OTABLE POINTERS TAD (3 DAC BITPTR TAD (1 DAC CPOINT / IN CASE CHARACTER VARIABLE LAC* MODPTR JMS* GETADR DAC OPT1 TAD (-1 DAC OPT2 LAC MODPTR / REGAIN INDICATOR BITS RTL LAC* OPT1 / GET ADDRESS OF VARIABLE AND (077777 / REMOVE COMMON INDICATOR BIT, IF SET SZL / LINK =1, IF VARIABLE IS AN ELEMENT TAD* AUTO14 / NEXT WORD IS OFFSET WRT THE BASE DAC BOX1 / CONTAINS ADDRESS OF VARIABLE LAC* MODPTR JMS WDSIZE DAC WDS LAC MODPTR / MODPTR STILL CONTAINS INDICATOR BITS SMA!CLC / IS VARIABLE AN ARRAY NAME.(AC_777777) JMP REPV / NOT ARRAY, REPLICATION FACTOR = 1. JMS ARYSIZ / GET ARRAY SIZE CLL IDIV WDS XX /VARIABLE REPLICATION FACTOR=ARRAY SIZE/WORD SIZE LACQ CMA TAD (1 REPV DAC COUNT / NEG VARAIBLE REPLICATION FACTOR / / CHECK IF MODE OF VARIABLE AND CONSTANT MATCH CHMD LAC* FLTFLG / GET MODE OF CONSTANT SAD (CHARM!CONBIT JMP HOLRTH SAD (CONBIT!SINTGM JMP SINCON / SINGLE INTEGER CONSTANT XOR* MODPTR AND (17 SNA JMP DATOUT ERRDA6 JMS* ERRORS .SIXBT 'DA6' / / A SINGLE INTEGER CONSTANT MAY GO INTO A SINGLE OR DOUBLE / INTEGER VARIABLE. SINCON LAC* MODPTR / GET VARIABLE MODE AND (7 SAD (SINTGM JMP DATOUT / ITS SINGLE INTEGER ALSO SAD (DINTGM SKP JMP ERRDA6 / NEITHER SINGLE OR DOUBLE LAC* VANTED / VARIABLE IS DOUBLE INTEGER. MAKE CONSTANT DOUBLE DAC* VANT1 SPA!CLA / EXTEND SIGN BIT CMA DAC* VANTED JMP DATOUT / / / / PICK UP CONSTANTS, CHECK FOR COMPLEX FNDCON XX DAC NUMBER LAC* CHINXT SAD (OPEN JMP CPLX / LOOKS LIKE COMPLEX LAC (SIGNER!CONSTN JMS* SEARCH / GET CONSTANT JMP* FNDCON CPLX JMS* GETCHI / TOSS AWAY '(' LAC (SIGNER!CONSTN JMS* SEARCH LAC* CHINXT SAD (COMMA JMP .+3 ERRDAB JMS* ERRORS .SIXBT 'DAB' JMS* PLXPIK / GET REMAINDER OF CONSTANT JMS* GETCHI / TOSS AWAY ) JMP NOREP / / / HOLRTH LAC* VANTED / GET -SIZE OF CONSTANT DAC MOVCNT / ALWAYS MOVE THIS MANY WORDS TAD WDS / ADD WORD SIZE OF VARIABLE TAD (2 /(ITS 2 HIGH FROM FILLING 2 SPACES IN LAST WORD) SMA / IS CONSTANT TOO LARGE JMP MOVCNT / NO. WRNDAC JMS* WARN / YES. ISSUE TRUNCATION WARNING .SIXBT 'DAC' / MOVCNT LAW -10 JMS* G.MOVE / SHIFT THE CONSTANT IN VANTED FOR TRANSFER TAD VANT2 TAD VANTED / LAW -1 TAD WDS SZA JMP DATOUT LAC* VANTED AND (777760 DAC* VANTED / CLEAR RIGHT MOST BITS FOR LOGICAL AND INTEGER / / PUNCH OUT THE CONSTANT FOR ONE VARIABLE OR ELEMENT / DATOUT JMS DATPCH / PUNCH OUT DATA FOR ONE VARIABLE OR ELEMENT LAC BOX1 TAD INCRES DAC BOX1 / ADVANCE ARRAY POINTER ADDRESS ISZ NUMBER / IS CONSTANT DONE JMP STILLC ISZ COUNT / COUNT THE VARIABLE NOP LAC* CHINXT SAD (COMMA JMP GETCON SAD (SLASH JMP* PICCON ERRDA4 JMS* ERRORS .SIXBT 'DA4' / / ERRDA5 JMS* ERRORS .SIXBT 'DA5' / / END OF CURRENT CONSTANT IS REACHED. TEST FOR END OF VARIABLE STILLC ISZ COUNT JMP DATOUT JMP ANEWV / / / DATPCH XX LAW -1 TAD VANTED DAC* (AUTO10 /SUBTRACT 1 FOR AUTO-INDEX LAC WDS DAC INCRES / SET UP FOR INCREMENTING ADDRESS CMA TAD (1 DAC S / NEWDAT LAC* AUTO10 DAC* ITEM LAC (17 /LOADER CODE FOR 1ST 'DATA' ELEMENT JMS* INSRT CLA ISZ S SKP JMP DONE / LAC* AUTO10 / GET NEXT WORD OF CONSTANT DAC* ITEM LAC (20 /LOADER CODE FOR 2ND 'DATA' ELEMENT JMS* INSRT LAC (100000 ISZ S SKP JMP DONE / LAC* AUTO10 DAC* ITEM LAC (21 /LOADER CODE FOR 3RD 'DATA' ELEMENT JMS* INSRT LAC (200000 ISZ S NOP DONE TAD BOX1 DAC* ITEM LAC (22 /LOADER CODE 'DATA INITIALIZATION JMS* INSRT / CONSTANT DEFINITION' / LAC S SNA JMP* DATPCH LAC (3 TAD BOX1 DAC BOX1 LAW -3 TAD INCRES DAC INCRES JMP NEWDAT / / .EJECT / / / ERRDO0 JMS* ERRORS .SIXBT 'DO0' / DO LAW H5!ILGIF!.EXC JMS* HIERAR LAC* CHI TAD (2 / STEP PAST THE 1ST TWO CHARS (DO) DAC* INDEX CLC DAC* IND JMS* GETCHI / SET UP TO NEXT CHARACTER LAC (INTGRS JMS* SEARCH / PICK UP STATEMENT NUMBER LAC (STNUM JMS* CALCP / PUT IN SYMBOL TABLE LAC* BITPTR / GET CONTROL BITS AND (000077\DO.S / EVERYTHING ELSE ILLEGAL SZA JMP ERRDO0 LAC* BITPTR AND (DO.S SNA ISZ* DTNEXT / FIRST TIME IN DO STATEMENT, ALLOW FOR DO COUNT LAC BITPTR TAD (2 DAC TEMP ISZ* TEMP / COUNT THIS 'DO' STATEMENT / LAC (DO.S JMS SHOVE / MARK AS OCCURRING IN 'DO' STATEMENT JMS PRODOS / PROCESS DO PARAMETERS EXIT / / IMPLIED DOS ARE ALSO PROCESSED BY THIS SECTION PRODOS XX JMS* RECORD / RECORD CURRENT POSITION IN CHI TABLE DZM CNT AGDO1 LAC CNT SZA!CLL STL LAC* CHINXT / GET NEXT CHARACTER AGDO2 SAD (OPEN / IS IT '(' JMP ITSOPN / YES. SAD (CLOSE / IS IT ')' JMP ITSCLS / YES. SZL / ARE WE INSIDE (.......) JMP GET2 / YES. IGNORE CHARACTER SAD (COMMA / IS IT ',' JMP GETK / ITS ',' SAD (ENDST JMP ERRDO0 / END OF STATEMENT - ERROR. GET1 JMS* GETCHI / NONE OF ABOVE SET UP NEXT CHAR JMP AGDO2 / ITSCLS LAW -1 TAD CNT DAC CNT / UNCOUNT CLOSING BRACKETS SKP ITSOPN ISZ CNT / COUNT OPENING BRACKETS GET2 JMS* GETCHI JMP AGDO1 / MIGHT HAVE ENTERED OR EXITED FORM (...) / / / GET K / GETK JMS* GETCHI / STEP PAST COMMA LAW NOSTEP JMS* EXPRES .DSA KOMLN .DSA ERRDO0 .DSA KOMLN .DSA ERRDO0 / KOMLN JMS FIDDLE SNA!CLA / XCT'D FROM FIDDLE DAC ADDRSK / RETURNS HERE FROM FIDDLE / / GET L / GETL LAC* CHINXT SAD (ENDST JMP LMISSG / NO L, USE +1 JMS* GETCHI LAW 0 JMS* EXPRES .DSA ERRDO0 .DSA ERRDO0 .DSA .+2 .DSA ERRDO0 / JMS FIDDLE SZA!CLA / XCT'D FROM FIDDLE LJOIN DAC ADDRSL / RETURNS HERE JMP GETI / / THERE IS NO L PARAMETER, DEFAULT IS +1 . LMISSG LAC (1 DAC* VANTED DZM* VANT1 / ZERO FOR HASH ENTRANCE TO SYMBOL TABLE LAC (CONBIT!SINTGM DAC* FLTFLG LAC (CONST JMS* CALCP / ENTER '1' IN SYMBOL TABLE LAC* TBADDR JMP LJOIN / / GET I GETI JMS* REGAIN LAW LHSSW!CONILL!EXPILL!DFNSW JMS* EXPRES .DSA ERRDO0 .DSA .+3 .DSA ERRDO0 .DSA ERRDO0 LAC* AD2 DAC ADDRSI / SAVE IMPORTANT INFO LAC* CLEW2 / / CHECK MODE, MUST BE INTEGER. / AND (17 SAD (SINTGM JMP GETJ SAD (DINTGM JMP GETJ ERRDO1 JMS* ERRORS .SIXBT 'DO1' / / GET RIGHT HAND SIDE WHICH IS J GETJ LAW 0 JMS* EXPRES .DSA .+4 .DSA ERRDO0 .DSA ERRDO0 .DSA ERRDO0 / / ONLY INTEGER AND REAL MODES LEGAL JMS MDCHK LAC* CLEW2 AND (INACC SZA JMP PUTDO / J IS AN EXPRESSION LAC* AD2 DAC* DRESS LAC* CLEW2 DAC* CLUES LAC (LOAD*M / LOAD DAC* OPCODE JMS* PUNCH / PUNCH OUT LOAD J / / NOW PUNCH OUT THE 'DO' OPCODE PUTDO LAC* CLEW2 AND (INVERT SZA LAC (400000 / DO MARK A STOREN IS NEEDED DAC CNT LAC (DOS*M DAC* OPCODE DZM* CLUES LAC ADDRSI DAC* DRESS JMS* PUNCH / / NOW GET A TEMPORARY ACCUMULATOR FOR EXECUTATION STORAGE LAC (INACC!REALM DAC* CLEW2 LAC CLEW2 DAC* ACCSW CLL LAC CNT / EITHER 0 OR 400000 JMS* TEMPA2 LAC* BASE3 DAC ADDRSI LAC* DRESS / GET ADDRESS OF TEMP ACC DAC* ADDRSI ISZ* BASE3 / STEP PAST ENTRY / / PUNCH OUT ADDRESS OF L DZM* OPCODE LAC (TEMPER DAC* CLUES / LET PUNCH SORT OUT IF IS A TEMP ACC LAC ADDRSL DAC* DRESS JMS* PUNCH / / PUNCH OUT ADDRESS OF K LAC ADDRSK / OPCODE & CLUES ARE STILL SET DAC* DRESS JMS* PUNCH JMP* PRODOS / / / THIS ROUTINE SORTS OUT THE EXPRESSIONS, VARIABLES, AND CONSTANTS / OF THE DO STATEMENT / FIDDLE XX JMS MDCHK / CHECK MODES LAC* CLEW2 AND (INACC SNA JMP VARCON / IT IS VARIABLE OR CONSTANT / / ITS AN EXPRESSION, STORE IN A SMASHED TEMP ACC EXPRS LAC CLEW2 DAC* ACCSW LAC* CLEW2 AND (INVERT XCT* FIDDLE JMP .+3 LAC (STORE*M SKP!CLL LAC (STOREN*M JMS* TEMPA2 FJOIN LAC* DRESS FJOIN1 ISZ FIDDLE / BUMP RETURN ADDRESS JMP* FIDDLE / / ITS A VARIABLE OR CONSTANT VARCON LAC* CLEW2 AND (INVERT XCT* FIDDLE LAC (400000 / MARK THAT INVERT WAS SET XOR* AD2 JMP FJOIN1 / / / THIS SUBROUTINE CHECKS THE MODES, ONLY INTEGER AND REAL PASS MDCHK XX LAC* CLEW2 AND (000017 SAD (LOGICM JMP ERRDO2 AND (000010 SNA JMP* MDCHK ERRDO2 JMS* ERRORS .SIXBT 'DO2' / / / / THIS SECTION CLEANS UP AFTER THE END OF THE DO LOOP IS ENCOUNTERED / THE AC CONTAINS THE 2'S COMPLIMENT OF THE NUMBER OF DO LOOPS / THAT TERMINATE ON THIS STATEMENT / ENDDO XX DAC ADDRSL / SAVE COUNT DOMORE LAW -1 / NOW UNWIND A DO LOOP TAD* BASE3 DAC* BASE3 / RESET TO LAST ENTRY IN DO TABLE DAC ADDRSI / POINT TO LAST ENTRY LAC* ADDRSI / GET LAST ENTRY DAC* DRESS LAC (TEMPER / MARK AS TEMP ACC TO FREE IT DAC* CLUES LAC (UNDO*M DAC* OPCODE JMS* PUNCH ISZ ADDRSL / ARE ALL DO LOOPS UNWOUND? JMP DOMORE / NO. DO ANOTHER JMP* ENDDO / YES. RETURN / .EJECT / / THE 'END' SECTION FOLLOWS. THE TAG END IS BRANCHED TO WHEN AN / END STATEMENT IS ENCOUNTERED. IT PERFORMS A CHECK AND THEN / GOES TO CLEAN UP THE SYMBOL TABLE . IF A LISTING OF THE SYMBOL TABLE / IS NEEDED IT DOES THIS BEFORE RETURNING TO CHECK IF A SUBROUTINE / FOLLOWS. / END LAC* STATSW SZA / WAS LAST STATEMENT A TRANSFER STATEMENT JMP ENDOK / YES. LAC KIND SAD (BLOCKD JMP ENDOK / END STATEMENT OK ANY TIME IN BLOCK DATA / ERREN3 JMS* ERROR / NO. END STATEMENT NOT PRECEDED BY A TRANSFER STATEMENT .SIXBT 'EN3' ENDOK DZM* STATSW / TURN OFF STATSW LAW H5!ILGIF!NON.EX!BDLEGL JMS* HIERAR ISZ ENDSW / INDICATE AN END STATEMENT WAS FOUND JMS* APPEND / GO CLEAN UP SYMBOL TABLE JMS* HOOK /ALLOW PRINTING (IF ANY) TO CATCH UP LAC* LST SNA JMP NOLIST /NO LISTING - NO FORM FEED!! .WRITE LP,2,FORMFD,0 NOLIST LAC SYMPRT / IS A SYMBOL TABLE LISTING REQUIRED SZA JMS* SYMBOL / YES, GO PRINT OUT SYMBOL TABLE JMS* SETPT2 / RELEASE LAST LINE FOR PRINTING JMP* JOINCK / / WHEN THE OUTPUT ROUTINE REACHES AN EOM OR EOF THE FILE IS / FINISHED BEING PROCESSED. CLOSE FILE. ENDFIL JMS* CLOSER / CLOSE THE BINARY FILE .CLOSE DKI ISZ EXITSW / WAS A CARRIAGE RETURN OR ALTMODE TYPED JMP* .START / WAS ALTMODE, RETURN TO COMPILER .WAIT TTO /WAIT FOR ERROR COUNT ANNOUNCEMENT TO FINISH .EXIT / RETURN TO MONITOR / ENDSW 0 / INDICATES WHETHER A END STATEMENT HAS BEEN PROCESSED EXITSW 0 / IF -1, ALTMODE WAS ENCOUNTERED, RETURN TO MONITOR SYMPRT 0 / IF 1, THEN A SYMBOL TABLE LISTING IS DESIRED / FORMFD 2002; 0; .ASCII <14><15> /FORM FEED ON END STATEMENT .EJECT / / / THE FOLLOWING STORAGE LOCATIONS FOR THE EQUIVALENCE SECTION / ARE SHARED WITH OTHER, NON-CONFLICTING SECTIONS NESTPT / POINTS TO THE NEXT LOCATION FOR THE NEXT EQUIV ROW NESTJ / NEST NUMBER INDICATOR FOR EQUIVALENCE CLEANUP D / WORD OR ARRAY SIZE REQUIRED FOR ELEMENT N / STORAGE FOR NEST NUMBERS WHILE THREADING THRO TIE INS. L SMALLS SMALLT SMALLI / / THE FOLLOWING LOCATIONS ARE NEST PARAMETERS AND MUST REMAIN / TOGETHER IN THIS ORDER FOR TRANSFERAL INTO THE TABLE. I / NEST NUMBER THIS NEST IS TIED TO A / ADDRESS OF NEST IF IT HAS BEEN ASSIGNED F / OFFSET OF NEST RELATIVE TO THE ONE POINTED AT DTBLE / POINTER TO COMMON NAME DTABLE ADDRESS NEST IS EQUIV'D TO MINJ / MAX DISTANCE TO 1ST ELEMENT OF ANY ARRAY IN NEST MAXJ / " " " LAST " " " " " " . / IL;AL;FL;DTPTL;MINL;MAXL / POINTERS TO NEST PARAMETERS IN;AN;FN;DTPTN;MINN;MAXN / POINTERS TO NEST PARAMETERS AO;AOP FO;FOP NA NC / / / THIS ROUTINE TESTS ARRAY ELEMENTS FOR VARIABLE SUBSCRIPTS / WHICH ARE ILLEGAL IN DATA, AND EQUIVALENCE STATEMENTS VARSUB XX LAC* MODPTR JMS* GETADR / GET OTABLE ADDRESS DAC OPT1 TAD (-1 DAC OPT2 CMA / GIVES 2' COMP OF OPT1 TAD* OTABLE / GIVES COMPILE TIME RELATIVE ADDRESS RCR / GIVES EXECUTION TIME RELATIVE ADDRESS SAD* AD2 / COMPARE WITH RELATIVE ADDRESS IN EXPRESS JMP* VARSUB / THEY MATCH. ERREC8 JMS* ERRORS .SIXBT 'EC8' / / / ENTER HERE FOR EQUIVALENCE STATEMENTS EQUIV LAW H4!NON.EX!BDLEGL JMS* HIERAR ISZ EQUVSW / INDICATES WE ARE IN EQUIVALENCE LAC* BASE3 / GET START ADDRESS OF EQUIVALENCE TABLE DAC NESTPT / NXTNST ISZ SMALLJ / INCREMENT NEST COUNTER / LAW -26 / INITIALIZE 22 LOCATIONS JMS* G.INIT / INITIALIZE LOCATIONS LAC (D CLA / JMS* GETCHI / GET NEXT CHAR,SHOULD BE ( SAD (OPEN SKP JMP ERREV0 JMS* GETCHI / GET NEXT CHAR NXTELM DZM* SPOT2 LAW EXPILL!DFNSW!CONILL JMS* EXPRES .DSA CMMA .DSA ERREV0 .DSA ERREV0 .DSA CLOSP / CLOSING PARENTHESES / ERREV0 JMS* ERRORS / ILLEGAL NEST CONSTRUCTION .SIXBT 'EV0' ERREV2 JMS* ERRORS / FEWER THAN 2 MEMBERS IN EQUIVALENCE LIST .SIXBT 'EV2' ERREV4 JMS* ERRORS / CAN'T EQUIVALENCE FORMAL PARAMETERS .SIXBT 'EV4' ERREV5 JMS* ERRORS / ILLEGAL NEST DELIMITER .SIXBT 'EV5' / CLOSP CLC DAC ENDNST / INDICATES CLOSING PARENTHESES CMMA LAC* BITPTR AND (FORMAL / CAN'T EQUIVALENCE FORMAL PARAMETERS SZA JMP ERREV4 LAC (EQUSET / MARK AS BEING IN EQUIVALENCE JMS SHOVE JMS VARSUB / TEST IF VARIABLE SUBSCRIPTS, WHICH ARE ILLEGAL / JMS ARYSIZ / GET SIZE OF STORAGE REQ'D DAC D LAC* SPOT2 CMA TAD (1 DAC SMALLS LAC MINJ JMS MINIM / GET MINJ=MIMIN(MINJ,-S)) TAD SMALLS DAC MINJ / LAC D TAD SMALLS JMS MAXIM / GET MAXJ=MAXIM(MAXJ,D-S) TAD MAXJ DAC MAXJ / / LAC* BITPTR AND (COMSET SZA / IS VARIABLE IN COMMON JMP H / YES LAC* OPT1 / NO SZA / IS VARIABLE IN ANOTHER EQUIV NEST JMP H /YES / / LAC SMALLJ / NO GET NEST NUMBER DAC* OPT1 / STORE IN OTABLE LAC SMALLS DAC* OPT2 / ATAG ISZ SMALLI / INCREMENT ELEMENT # ISZ ENDNST /!HAS END OF NEST BEEN REACHED JMP NXTELM / NO. / LAC (1 / YES SAD SMALLI JMP ERREV2 / THERE WAS ONLY ONE ELEMENT IN NEST / LAW -6 / NO. OKAY JMS* G.MOVE / TRANSFER DATA TO NEST TAD (I TAD NESTPT / LAC NESTPT TAD (6 DAC NESTPT /RESET FOR A NEW ROW LAC* CHINXT SAD (COMMA / IS IT ',' JMP NXTNST SAD (ENDST / NO, THEN IT SHOULD BE END OF STATEMENT SKP JMP ERREV5 / IT IS NEITHER-ERROR! DZM EQUVSW / TURN OFF 'EQUVSW' LAC NESTPT DAC* BASE3 / RESET TO END OF EQUIVALENCE TABLES EXIT / / / THIS SECTION IS REACHED WHEN AN ELEMENT IS EITHER IN COMMON OR / ANOTHER EQUIVALENCE NEST. H LAC SMALLS DAC FO / STORE OFFSET LAC SMALLJ DAC L / STORE CURRENT NEST NUMBER / LAC (I NOTHER JMS SETPTL LAC* IL / IS THIS NEST TIED TO ANOTHER SNA / YES, SKIP JMP BASES / NO DAC L LAC* FL / COMPOUND OFFSET TAD FO DAC FO LAC L JMS NEWROW / SET UP POINTERS TO NEST POINTED AT JMP NOTHER / BASES LAC* AL SNA / HAS NEST BEEN ASSIGNED AN ADDRESS JMP K / NO LAC FO / YES TAD* AL DAC AO / K LAC* BITPTR AND (COMSET SZA / IS VARIABLE IN COMMON JMP MTAG / YES. LAC* OPT2 / NO. THEN IT IS IN ANOTHER NEST DAC FOP LAC* OPT1 / GET PREVIOUS NEST NUMBER DAC N / SAVE IT / NEWLVL JMS NEWROW JMS SETPTN / POINT TO PREV NEST WITH VARIABLE LAC* IN SNA / IS THIS NEST TIED TO ANOTHER NEST JMP NTAG / NO. DAC N / YES. LAC* FN / COMPOUND OFFSET TAD FOP DAC FOP LAC N / GET NEST THIS ONE IS CONNECTED TO JMP NEWLVL / / ELEMENT IS IN COMMON AND THUS ITS ADDRESS FIXES THE NEST MTAG LAC* OPT1 / GET COMMON ADDRESS DAC AOP / STORE IN AO PRIME LAC* OPT2 LMQ / STORE FOR LATER P LAC* AL SNA / DOES NEST HAVE AN ADDRESS JMP Q / NO. LAC* OPT2 / YES. NEST FIXED TO COMMON SAD* DTPTL / IS IT THE SAME COMMON SKP JMP ERREC0 / NO. ERROR LAC AO / YES. SAD AOP JMP ATAG / YES. REDUNDANT ERREC1 JMS* ERRORS / NO. ERROR .SIXBT 'EC1' ERREC0 JMS* ERRORS .SIXBT 'EC0' / / Q LAC FO / FIX EQUIVALENCE NEST TO COMMONN CMA TAD (1 TAD AOP DAC* AL LACQ DAC* DTPTL / STORE POINTER TO COMMON BLOCK JMP ATAG / / ELLEMENT WAS IN ANOTHER NEST AND WE HAVE CHAINED THROUGH / TO THIS ONES BASE NEST. NTAG LAC* AN SNA / DOES BASE NEST HAVE AN ADDRESS? JMP R / NO. TAD FOP / YES. CALCULATE NEW BASE ADDRESS DAC AOP LAC* DTPTN / HAS ADDRESS, THEN HAS DTABLE POINTER LMQ / PREPARE TO INSERT FOR CURRENT NEST JMP P / R LAC* AL SNA / DOES CURRENT NEST HAVE AN ADDRESS JMP T / NO. LAC FOP / YES. GET OFFSET OF ELEMENT TAD AO / ADD ADDRESS OF CURRENT NEST DAC* AN / TO GET NEST ADDRESS FOR BASE NEST LAC* DTPTL / GET DTABLE POINTER DAC* DTPTN / INSERT IN BASE NEST JMP ATAG / T LAC N SAD L / ARE THESE NESTS THE SAME SKP JMP SSS / NO. LAC FO / YES SAD FOP JMP ATAG ERREV3 JMS* ERRORS .SIXBT 'EV3' / / / SSS DAC* IL / MARK CURRENT NEST AS TIED TO PREV ONE / CALCULATE NEW OFFSET. LAC FO CMA TAD (1 TAD FOP DAC* FL JMP ATAG / / / / THIS SUBROUTINE USES THE ROW NUMBER TO GET THE START ADDRESS / OF THAT ROW IN THE TABLE, RETURNS WITH ADDRESS IN AC / LAC (ROW NUMBER / JMS NEWROW / NEWROW XX TAD (-1 CLL MUL .DSA 6 LACQ TAD* BASE2 / ADD START ADDRESS OF TABLE DAC TEMP JMP* NEWROW / / THIS SUBROUTINE SETS UP THE 'L' POINTERS SETPTL XX DAC IL TAD (1 DAC AL TAD (1 DAC FL TAD (1 DAC DTPTL JMP* SETPTL / MXMNL XX TAD (1 DAC MINL TAD (1 DAC MAXL JMP* MXMNL / / / THIS SUBROUTINE SETS UP THE 'N' POINTERS TO I,A,F VALUES FOR PREVIOUS / NESTS WHICH ARE STORED IN THE TABLE SETPTN XX DAC IN TAD (1 DAC AN TAD (1 DAC FN TAD (1 DAC DTPTN JMP* SETPTN / MXMNN XX TAD (1 DAC MINN TAD (1 DAC MAXN JMP* MXMNN / / / /THIS SUBROUTINE TAKES THE MINIMUM OF X & Y AND LEAVES THE RESULT / IN THE AC / LAC (X / JMS MINIM / TAD (Y / MINIM XX LMQ / MQ_X CMA / AC_-X XCT* MINIM / AC_Y-X SPA!CLA JMP* MINIM / AC_0+Y ISZ MINIM LACQ / AC_X JMP* MINIM / / / / THIS SUBROUTINE TAKES THE MAXIMUM OF X & Y AND LEAVES THE RESULT / IN THE AC. / LAC (X / JMS MINIM / TAD (Y / MAXIM XX LMQ / MQ_X CMA / AC_-X XCT* MAXIM / AC_Y-X SMA!CLA JMP* MAXIM / AC_O+Y ISZ MAXIM LACQ / AC_X JMP* MAXIM / / / THIS SECTION CLEANS UP THE EQUIVALENCE TABLES IF ANY EXIST AND / ASSIGN ADDRESS TO THOSE NESTS AND THEN TO ALL VARIABLES. / EQUCLN XX LAC HEADER DAC NA / GET SPACE FOR START SECTION LAC SMALLJ SNA / IS THERE AN EQUIV TABLE JMP ASSALL / NO GO ASSIGN ADDRESSES TO ALL VAR. ISZ SMALLJ DZM NESTJ / NEW NEST COUNTER / NSTNXT ISZ NESTJ / INCREMENT NEST NUMBER LAC NESTJ SAD SMALLJ / HAVE ALL NESTS BEEN DONE JMP ASSFRE / YES. GO ASSIGN ALL FREE NESTS JMS NEWROW / NO. JMS SETPTL / SET UP POINTERS TO NEST. JMS MXMNL / BEING WORKED ON. LAC* IL SNA / IS NEST TIED TO ANOTHER ? JMP NOTIED / NO TIED JMS NEWROW / YES. SET UP 'N' POIINTERS TO THIS NEST JMS SETPTN JMS MXMNN LAC* IN SNA / IS THIS ONE TIED TO ANOTHER JMP NOMORE / NO LAC* FL / YES. COMPOUND OFFSET TO TAD* FN / REDUCE ALL NEST TO ONLY ONE LEVEL DAC* FL LAC* IN DAC* IL / MARK NEST AS TIED TO THE NEW ONE JMP TIED / NOMORE LAC* MINL / GET MAX OF CURRENT NEST TAD* FL / ADD COMPOUNDED OFFSET JMS MINIM TAD* MINN DAC* MINN / RETURN NEW MINIINUM / LAC* MAXL TAD* FL JMS MAXIM TAD* MAXN DAC* MAXN JMP CKADR / NOTIED LAC NESTJ JMS NEWROW / SET UP 'N' POINTERS TO THE JMS SETPTN / CURRENT ROW ALSO SO WE CAN JMS MXMNN / USE COMMON CODING HERE ON / / / WHEN WE GET HERE WE HAVE THE 'N' POINTERS POINTING TO A BASE / NEST. ALL NESTS HAVE BEEN REDUCED TO A BASE NEST. / CKADR LAC* AN SNA / DOES THIS BASE NEST HAVE AN ADDRESS JMP NSTNXT / NO. GO DO NEXT NEST AND (077777 / REMOVE ANY STRAY BITS TAD* MAXN / YES. ADD ADDRESS+MAXIMUM JMS MAXIM TAD NC DAC NC / LAC* AN / GET ADDRESS AND (077777 / REMOVE ANY STRAY BITS TAD* MINN SMA / DOES IT EXTEND COMMON BACKWARDS JMP NSTNXT / GO DO NEXT NEST ERREC3 JMS* ERROR .SIXBT 'EC3' JMP* EQUCLN / RETURN TO RESET HIERARCHY NUMBERS / / / ASSIGN ADDRESSES TO ALL FREE EQUIVALENCE GROUPS, IE. ALL BASE NESTS / ASSFRE DZM NESTJ / NEWNST ISZ NESTJ LAC NESTJ SAD SMALLJ / HAVE ALL NESTS BEEN DONE JMP ASSREL / YES. GO ASSIGN ALL RELATIVE GROUPS JMS NEWROW JMS SETPTL JMS MXMNL LAC* IL SZA / IS THIS NEST TIED TO ANOTHER JMP NEWNST / YES. GO TRY NEXT ONE LAC* AL / GET NEST ADDRESS SZA / DOES NEST HAVE AN ADDRESS JMP NEWNST / YES. GO TRY NEXT ONE LAC* MINL / NO. CMA TAD (1 TAD NA DAC* AL / ASSIGN IT AN ADDRESS TAD* MAXL DAC NA / CALCULATE NEXT FREE ADDRESS JMP NEWNST / / / ASSIGN ADDRESS TO ALL RELATIVE EQUIVALENCE GROUPS / ASSREL DZM NESTJ / NSTNEW ISZ NESTJ LAC NESTJ SAD SMALLJ / HAVE ALL NESTS BEEN DONE JMP ASSALL / YES. GO ASSIGN ALL ADDRESSES JMS NEWROW / YES JMS SETPTL / SET 'L' POINTERS TO THIS NEST LAC* IL SNA / IS THIS NEST TIED DOWN JMP NSTNEW / NO. GO GET NEW NEST JMS NEWROW / YES. JMS SETPTN / SET 'N' POINTERS TO BASE NEST LAC* AN / GET BASE ADDRESS ( ONLY ONE LEVEL) TAD* FL DAC* AL / INSERT THE NESTS ADDRESS LAC* DTPTN / GET DTABLE ADDRESS IF ANY DAC* DTPTL / INSERT IN CURRENT NEST JMP NSTNEW / GO GET NEW NEST / / / NOW ASSIGN ADDRESSES TO ALL VARIABLES IN THE WHOLE SYMBOL TABLE / ASSALL LAW -1 TAD* PTABLE DAC* (AUTO12 / SET AUTO-INDEX FOR PTABLE SCAN / VARNEW LAC (VARIAB / WANT VARIABLE JMS* G.SCAN / GO SCAN PTABLE JMP FOUND / RETURN HERE WHEN VARIABLE FOUND LAC NA / GET STORAGE REQUIRED SNA JMP NOSPACE / ONLY IN BLOCK DATA WILL THHS BE ZERO DAC* ITEM LAC (06 / CODE 06 RESERVES NON-COMMON STORAGE JMS* INSRT / PUNCH IT OUT LAC NA / GET NEXT FREE ADDRESS NOSPACE DAC* LOCCNT / IS STARTING VALUE FOR LOCATION COUNTER TAD (-1 DAC* START / MARK AS START-1 OF INTERPRETIVE CODE / NOW CHECK IF THERE WAS ANY DATA IN SPEC STATEMENTS AND CLEAN IT UP JMS* RECORD / SAVE PLACE IN CHI LAW -1 DAC ERSW LAC BASE1 / GET START ADDRESS OF DATA LOPS SAD* BASE2 / WAS THERE ANY DATA? JMP OVERS / NO DAC NC LAC KIND SAD (BLOCKD / CHECK FOR BLOCK DATA JMP DONAME LAC* NC / GET MODPTR DAC DSPECS CTIE LAW -1 DAC DSPECS+1 DAC* IND / START ON LEFT LAC NC TAD (1 DAC* INDEX LAC (DSPECS-1 DAC* (AUTO14 DZM COUNT JMS* GETCHI / GET 1ST CHARACTER JMS PICCON LAC* INDEX TAD* IND TAD (1 JMP LOPS OVERS JMS* REGAIN LAC BASE1 / GET START ADDRESS OF DATA STORAGE DAC* BASE2 / RESET EQUIVALENCE POINTER DAC* BASE3 / RESET START OF WORK AREA POINTER DZM ERSW JMP* EQUCLN / RETURN / / CHECK COMMON NAME FOR BLOCK DATA / DONAME LAC* NC DAC DSPECS TAD (3 DAC BITPTR LAC* DSPECS JMS* GETADR TAD (-1 DAC OPT2 JMS INBLKD JMP CTIE / / BRANCH TO HERE WITH A NEW VARIABLE FOUND DAC MODPTR / SET UP POINTERS TO DTABLE TAD (3 DAC BITPTR TAD (1 DAC CPOINT / FOR CHARACTER VARIABLES LAC* BITPTR / GET CONTROL BITS AND (FORMAL!FUNBIT!NOHERE!FUNNAM / DO NOT ASSIGN SZA / SPACE TO FUNCTION NAMES JMP VARNEW / / IF THE VARIABLE IS CHARACTER, COUNT THE SPACE NEEDED FOR ITS DOPE / VECTOR. (THIS WILL ASSIGN A 2 WORD DOPE VECTOR FOR SINGLE / VARIABLES WHICH HAVE DATA. MAYBE NOT NECESSARY, BUT NOT GOING / TO CHANGE NOW!) / LAC* MODPTR AND (17 / GET MODE SAD (CHARM SKP JMP NOCHR / NOT CHARACTER ISZ CHRCNT ISZ CHRCNT / / NOW DO NOT ASSIGN SPACE TO COMMON VARIABLES EITHER NOCHR LAC* BITPTR AND (COMSET SZA JMP VARNEW / / NOW DO SOME HONEST WORK. LAC* MODPTR JMS* GETADR DAC OPT1 TAD (-1 DAC OPT2 NONEOF LAC* OPT1 / GET 1ST WORD OF OF OTABLE SZA / DOES VARIABLE HAVE A NEST #. JMP NSTNUM / YES. LAC NA / NO. ASSIGN AN ADDRESS DAC* OPT1 / NO. ASSIGN STARTING AFTER EQUIV ADDRESS JMS ARYSIZ / GET STORAGE REQUIRED TAD NA DAC NA / RESET FOR NEXT ADDRESS JMP VARNEW / / IF EQUIVALENCE NEST CONTAINED A COMMON ENTRY THEN THE ADDRESS / USED FOR THE NEST IS THAT COMMON ADDRESS AND THE INDICATOR / BIT 200000 IS RETAINED WITH IT. THUS WHEN WE ASSIGN THIS ADDRESS / TO ANY NON-COMMON VARIABLES THAT WERE IN THE NEST THEN WE / AUTOMATICALLY MARK THEM AS BEING COMMON ENTRIES, WHICH IS WHAT / WE WANT. NSTNUM JMS NEWROW JMS SETPTL LAC* AL / GET NEST ADDRESS TAD* OPT2 / ADD VARIABLE OFFSET FROM EQUIV PT DAC* OPT1 / TO GET START ADDRESS OF VARIABLE / IF NEST IS TIED TO COMMON THEN MUST MARK VARIABLE IN THE DTABLE / AS BEING IN COMMON AND SET THE OTABLE POINTER TO THE DTABLE ENTRY / FOR THE COMMON NAME. MUST ALSO UPDATE THE COMMON SIZE IF THE / VARIABLE EXTENDS IT. / SIZE = MAX(START ADDRESS OF VAR + VAR. SIZE, COMMON SIZE) LAC* DTPTL / ADDRESS OF COMMON NAME IF NOT ZERO DAC NESTJ SNA / IS NEST TIED TO COMMON JMP NOCOMN / NO. DAC* OPT2 / YES. STORE ADDRESS LAC (COMSET JMS SHOVE / MARK AS IN COMMON IN DTABLE JMS ARYSIZ / GET SIZE OF VARIABLE TAD* OPT1 / GET START ADDRESS AND (077777 / REMOVE COMMON INDICATOR BITS JMS MAXIM / TAKE MAXIMUM TAD* NESTJ / SIZE OF COMMON FOR 'MAXIM' DAC* NESTJ / RESTORE SIZE JMP VARNEW / / VARIABLE NOT IN COMMON, JUST INSERT POINTER TO ITS DTABLE ENTRY NOCOMN LAC MODPTR DAC* OPT2 / INSERT DTABLE ADDRESS IN OTABLE JMP VARNEW / .EJECT / / / EXTRNL LAW H3!NON.EX!BDLEGL JMS* HIERAR AGEXT JMS* GETCHI LAC (NAME JMS* SEARCH LAC (VARIAB JMS* CALCP / ENTER IN SYMBOL TABLE LAC (FUNBIT!XTERNL!NOHERE JMS SHOVE JMS* DLOTAB / DELETE THE OTABLE ENTRY JUST ASSIGNED LAC* CHINXT SAD (COMMA / IS IT ',' JMP AGEXT / YES. GO GET NEXT VARIABLE SAD (ENDST / IS IT END-OF-STATEMENT EXIT / YES. RETURN JMP . / NO. ILLEGAL CHARACTER, ERROR / .EJECT / TABLE FOR CONVERSION FROM INTERNAL CODE TO ASCII / ATABLE .ASCII <0> .ASCII '(!&'<0>'<' .ASCII '>'<0><0><0><0> .ASCII '-+*/^' .ASCII <0>',='<0>')' .ASCII 'ABCDEFGHIJKLMNO' .ASCII 'PQRSTUVWXY' .ASCII 'Z$01234567' .ASCII '89.'<0><0> .ASCII ' ' / / THIS SUBROUTINE CONVERTS AN INTERNAL CODE CHARACTER INTO 5/7 ASCII / AND PACKS IT WITH G.PACK REPACK XX IDIV!660000 / CLEAR LINK ! IDIVIDE 5 DAC SHIFT RCL RTL CMA TAD (LRS 36 TAD SHIFT DAC SHIFT LACQ RCL TAD (ATABLE DAC TEMP DAC* (AUTO10 LAC* AUTO10 LMQ LAC* TEMP SHIFT XX LACQ AND (177 SNA JMP ERRFM0 JMS* G.PACK JMP* REPACK / / FORMAT ROUTINES / A FORMAT STATEMENT WAS PREVIOUSLY CONVERTED TO '......' TYPE / HOLLERITH CONSTANTS, NOW CONVERT ALL SUCH HOLLERITHS TO NNH..... / TYPE HOLLERITHS FORMAT LAW H5!ILGIF!FORM / THIS MUST BE DONE AT THE 1ST IN CASE A JMS* HIERAR / DO LOOP MUST BE UNWOUND LAC* LOCCNT / GET LOCATION COUNTER FOR SET UP AND TO DAC NA / DETERMINE IF TESTGO COMPILES A GOTO JMS TESTGO / CHECK IF A GOTO MUST BE COMPILED AROUND LAC* LOCCNT DAC* FORMBX / RESET IN CASE A GOTO WAS COMPILED LAC* CHI / SET UP 5/7 ASCII BUFFER JMS* G.STPC SKP FPACK JMS REPACK / CONVERT THE CODE TO ASCII AND STORE IT P1 JMS* GETCHI / PICK UP INTERNAL CODE CHARACTER SAD (ENDST / IS IT END OF STATEMENT ? JMP P3 SAD (APOST / IS IT APOSTROPHE SKP / YES. JMP FPACK / NO. / / HAVE FOUND AN APOSTROPHE. IT CONTAINS ASCII ALREADY BUT CONVERT / IT TO A NNH........ TYPE HOLLERITH P4 JMS* RECORD / RECORD POSITION IN CHI TABLE DZM COUNT JMS* GETCHI SAD (APOST / IS IT APOSTROPHE JMP P8 ISZ COUNT / COUNT CHARACTERS UNTIL NEXT APOSTROPHE JMP .-4 / / HAVE FOUND 2ND APOSTROPHE P8 JMS* REGAIN / REGAIN PLACE IN CHI TABLE AT 1ST ' DZM* NUMS LAC COUNT SNA!STL JMP ERRFM0 / HAVE FOUND A ZERO LENGTH HOLLERITH JMS* G.CVRT LAC (110 /ASCII H JMS* G.PACK / JUST PICK UP ASCII CHARS INSIDE '..' JMS* GETCHI / AND TRANSFER THEM AS IS. SAD (APOST JMP P1 JMP .-4 / ERRFM0 JMS* ERRORS .SIXBT 'FM0' / / END OF STATEMENT FOUND. DUMMY UP AS A CHARACTER CONSTANT P3 LAC* CHARCT TAD (400002 RCL / MULT BY 2, SET L_1 IDIVS 5 / DIVIDE BY 5 LACQ / RESULT IS NEGATIVE DAC COUNT / NUMBER OF WORDS TO TRANSFER LAW -1 TAD* CHI DAC* (AUTO10 LAC* CHARCT / GET NUMBER OF CHARACTERS TAD (600000 P5 JMS* ITEM4 / PUNCH OUT THE CONSTANT LAC* AUTO10 ISZ COUNT JMP P5 JMP FMENTR / GO UPDATE INTERNAL GOTO IF NECESSARY .EJECT / GO TO AND GO TO ( .GOTO LAW H5!.EXC JMS* HIERAR JMS* GETCHI SAD (OPEN / IS STATEMENT 'GO TO (.....),N' JMP GOTOBR / YES LAC IFSW /FOR 'IF(LOGICAL)GOTO', DON'T NEED STATEMENT # SMA ISZ* STATSW / DEMAND NEXT STATEMENT HAS A STATEMENT NUMBER LAC (INTGRS JMS* SEARCH LAC (STNUM JMS* CALCP LAC* BITPTR AND (000077\TRAN.\.EXC\DO.S SZA JMP ERRGO0 LAC (TRAN. JMS SHOVE LAC (GOTO*M XOR* TBADDR JMS* ITEM4 / CODE 04 LAC* CHINXT SAD (ENDST EXIT ERRGO1 JMS* ERRORS / INVALID SYNTAX IN COMPUTED GO TO .SIXBT 'GO1' / ERRGO0 JMS* ERRORS / STATEMENT TRANSFERS TO A .SIXBT 'GO0' / NON-EXECUTABLE STATEMENT / / / COMPUTED GO TO GOTOBR DZM CNT JMS* RECORD / RECORD POSITION IN CHI TABLE AGSTN1 JMS* GETCHI SAD (CLOSE JMP ENDBR SAD (COMMA ISZ CNT SAD (ENDST JMP ERRGO1 JMP AGSTN1 / ENDBR JMS* GETCHI / GET NEXT CHARACTER SAD (COMMA / IS IT COMMA ? SKP JMP ERRGO1 / ERROR, NO COMMA AFTER BRACKETS JMS* GETCHI LAC (NAME JMS* SEARCH LAC (VARIAB JMS* CALCP LAC* CHINXT SAD (ENDST JMP GOOKAY ERRGO2 JMS* ERRORS / INDEX NOT SIMPLE VARIABLE .SIXBT 'GO2' / / PUNCH OUT 'LOAD N' / GOOKAY LAC (LOAD*M TAD* TBADDR / ADD RELATIVE OTABLE COUNTER JMS* ITEM4 / CODE 04 / PUNCH OUT 'GO TO M'.(M = THE NUMBER OF STATEMENT NUMBERS) LAC CNT TAD (1 JMS* HIDCON / HIDE THE CONSTANT AWAY IN SYMBOL TABLE DAC* DRESS / STORE ITS ADDRESS LAC (GOTOB*M DAC* OPCODE DZM* CLUES JMS* PUNCH / JMS* REGAIN / REGAIN POSITION IN CHI TABLE AGSTN2 JMS* GETCHI LAC (INTGRS JMS* SEARCH LAC (STNUM JMS* CALCP LAC (TRAN. JMS SHOVE / INSERT CONTROL BITS LAC* TBADDR / GET RELATIVE OTABLE ADDRESS JMS* ITEM4 / CODE 04 LAC* CHINXT SAD (COMMA JMP AGSTN2 SAD (CLOSE EXIT JMP ERRGO1 / .EJECT / ERRIF0 JMS* ERRORS .SIXBT 'IF0' ERRIF1 JMS* ERRORS .SIXBT 'IF1' / IF STATEMENTS IFBRAC LAW H5!.EXC JMS* HIERAR JMS* GETCHI LAW CONILL JMS* EXPRES / PROCESS CONTENTS IF 'IF' STATEMENT .DSA ERRIF0 .DSA ERRIF0 .DSA ERRIF0 .DSA .+1 / LAC* AD2 DAC* DRESS LAC* CLEW2 / GET CLUES ABOUT CONDITIONAL STATEMENT DAC* CLUES AND (INVERT SZA!CLA CLC DAC IFTEMP LAC* CLUES AND (INACC / IF INACC=1, CONTENTS ARE AN EXPRESSION SZA / AC=0, IF INACC = 0 JMP EXPION / ITS AN EXPRESSION LAC (LOAD*M DAC* OPCODE JMS* PUNCH / EXPION LAC* CLEW2 AND (17 SAD (LOGICM JMP LOGICL /MUST BE LOGICAL 'IF' AND (10 / MUST BE ARITHMETIC 'IF SZA / ONLY INTEGER AND REAL ARE LEGAL JMP ERRIF1 / / ITS AN ARITHMETIC 'IF' STATEMENT LAC IFSW / FOR ' IF(LOGICAL) IF(ARITH)', SMA / DON'T NEED STATEMENT # ISZ* STATSW / NEXT STATEMENT MUST HAVE A STATEMENT NUMBER JMS NEWSTN DAC IFBOX / SAVE NEGATIVE CONDITION STATEMENT NUMBER JMS NEWSTN XOR (IFA*M JMS* ITEM4 / PUNCH OUT ZERO CONDITION ST. NUMBER ISZ IFTEMP / CHECK IF CONTENTS HAD INVERT BIT SET JMP IFOKAY / NO / / YES. INVERT BIT WAS SET SWAP NEG AND POS STATEMENT NUMBERS LAC IFBOX JMS* ITEM4 / PUNCH OUT NEG CONDITION ST. NUMBER JMS NEWSTN IFFIN JMS* ITEM4 / PUNCH OUT POS CONDITION ST. NUMBER EXIT / IFOKAY JMS NEWSTN JMS* ITEM4 / PUNCH OUT POS LAC IFBOX JMP IFFIN / / NEWSTN XX LAC (INTGRS / GET AN INTEGER JMS* SEARCH LAC (STNUM JMS* CALCP LAC* BITPTR / GET CONTROL BITS AND (NON.EX!FORM!.IOPUT SAD (NON.EX JMP ERRST7 / STATEMENT NUMBER IS NON-EXECUTABLE SZA JMP ERRST9 / STATEMENT NUMBER IS A FORMAT STATEMENT LAC (TRAN. JMS SHOVE / INSERT CONTROL BITS JMS* GETCHI / STEP PAST DELIMITER LAC* TBADDR JMP* NEWSTN / ERRST7 JMS* ERRORS / ERROR - NON-EXECUTABLE STATEMENT NUMBER .SIXBT 'ST7' ERRST9 JMS* ERRORS / ERROR - FORMAT STATEMENT NUMBER, EITHER OCCURRED .SIXBT 'ST9' / ON A FORMAT OR IN A I/O STATEMENT / / / WE HAVE A LOGICAL 'IF' STATEMENT / CHECK IF WE HAVE ' IF(LOG) IF(LOG) . . .' LOGICL LAC IFSW SPA JMP ERRIF0 LAC IFSTAT / GET INTERNAL STATEMENT NUMBER DAC* VANTED ISZ IFSTAT LAC (STNUM JMS* CALCP / ENTER IN SYMBOL TABLE LAC* OPLACE / GET ABSOLUTE ADDRESS OF ENTRY DAC IFSTOR / STORE IT UNTIL CONDITIONAL CODE IS PROCESSED LAC (IFLN*M ISZ IFTEMP LAC (IFL*M / LOGICAL 'IF' CODE XOR* TBADDR / INSERT RELATIVE OTABLE ADDRESS JMS* ITEM4 / CODE 04 / LAW -1 DAC IFSW LAC* EQSWL DAC* EQSWT JMS* STLINE / SET UP FOR A NEW STATEMENT LAC* CHINXT / GET CHARACTER AFTER ')' AGCH SAD (ENDST JMP* PROCES DAC* BOX JMS* INSERT JMS* GETCHI JMP AGCH .EJECT / / THE FOLLOWING SECTION HANDLES THE READ AND WRITE STATEMENTS OF FORTRAN / IT ALLOWS FREE FORMAT / ENTRANCE FOR PRINT, PRINTN PRINTN, PUNCH, PUNCHN PUNCHN, / AND READ, READN READN, READ. LAC (READS*M+5 / DEFAULT DEVICE NUMBER = 5 JMP PUNCH.+1 PRINT. LAC (WRITES*M+6 / DEFAULT DEVICE NUMBER = 6 JMP PUNCH.+1 PUNCH. LAC (WRITES*M+7 / DEFAULT DEVICE NUMBER = 7 JMS STRAIT / SETS UP OPCODE, SAVES AC IN STARTP LAC OLDCHR AND (7 JMS* HIDCON / HIDE THE CONSTANT AWAY DAC* AD2 / GET UNIT # BACK, STORE FOR CDEV JMS CDEV / ISSUE DEVICE REQUEST DZM* CLUES JMS* PUNCH / PUNCH OUT OPCODE+ UNIT # / NOW SORT OUT PRINT, PRINTN AND PRINTN, LAC* CHINXT SAD (COMMA JMP FRFORM / WAS FREE FORMAT / WAS FORM PRINTN OR PRINTN, JMS PROFRM / PROCESS FORMAT NUMBER JMS* ITEM4 / PUNCH OUT STATEMENT # ADDRESS LAC* CHINXT / GET TERMINATING CHARACTER SAD (COMMA JMP FRFOR1 / ITS FORM PRINTN, SAD (ENDST JMP PROLS0 / ITS FORM PRINTN; JMP ERRIOF / ANY OTHER DELIMITER IS ILLEGAL / WAS FREE FORMAT PRINT, FRFORM CLA JMS* ITEM4 FRFOR1 JMS* GETCHI / STEP PAST COMMA (COMES HERE FROM UNWIND ALSO) JMP PROLS1 / GO PROCESS I/O LIST / / ENTRANCE FOR READ(N,M) , WRITE(N,M) , READ (N,*) , WRITE(N,*) READBR LAC (READS*M SKP WRITEB LAC (WRITES*M JMS STRAIT / PROCESS THE DEVICE NUMBER LAW EXPILL!NOSTEP JMS* EXPRES .DSA DODEV / , .DSA ERRIOF / = .DSA ERRIOF / ; .DSA DODEV / ) / / NOW CHECK DEVICE NUMBER. IT MAY BE INTEGER CONSTANT, SINGLE / OR DOUBLE INTEGER VARIABLE, OR A CHARACTER VARIABLE OR ARRAY. / DODEV LAC OLDCHR /SET UP 'READ' ETC. OP CODE AND (770000 DAC* OPCODE DZM OLDCHR DZM* CLUES LAC* CLEW2 / GET CLUE BITS ABOUT DEVICE NUMBER AND (37 SAD (CONBIT!SINTGM JMP CONDEV / SINGLE INTEGER CONSTANT SAD (CHARM JMP CHRDEV / CHARACTER DEVICE (NO DEVICE REQUESTS) SAD (SINTGM JMP ALLDEV / SINGLE INTEGER VARIABLE, REQUEST ALL DEVICES SAD (DINTGM JMP ALLDEV / DOUBLE INTEGER VARIABLE, REQUEST ALL DEVICES ERRIOD JMS* ERRORS / ERROR - ILLEGAL UNIT NUMBER .SIXBT 'IOD' / DEVICE NUMBER WAS INTEGER VARIABLE, REQUEST ALL DEVICES ALLDEV LAW -1 DAC DEVICE CHRDEV LAC* AD2 / ADDRESS OF VARIABLE DAC* DRESS SKP / DEVICE NUMBER WAS CONSTANT CONDEV JMS CDEV / CHECK IF CONSTANT WITHIN RANGE JMS* PUNCH / PUNCH OUT OPCODE + UNIT # / / HAVE PROCESSED DEVICE NUMBER AND PUNCHED OUT OPCODE / NOW HAVE THE CONDITIONS: BINARY- (N) OR (N,END=...,ERR=..) / FREE FORMAT- (N,*) OR (N,*,END=..,ERR=..) / FORMAT I/O- (N,M) OR (N,M,END=..,ERR=..) / THE ONLY DELIMITERS ALLOWED WHERE ')' OR ',' . LAC* CHINXT / GET LAST DELIMITER SAD (CLOSE / WAS IS ')' JMP IOLST0 / YES. OUT GOES (N) BINARY. JMS* GETCHI / MUST HAVE BEEN ',' , STEP PAST IT. SAD (STAR / IS CHAR '*' JMP DITCH / YES. MUST BE (N,*), OUT IT GOES FOR NOW. / / NOW HAVE LEFT (N,M) OR (N,M,END=..,ERR=..) / OR (N,END=..,ERR=..) JMS GETENT / GET NEXT ELEMENT (RETURNS .+1 OR .+2) JMP FORMTD / RETURNS HERE ON DELIMITERS ',' OR ')' OR ILLEGAL / / MUST BE (N,END=..,ERR=..) TYPE. (RETURNS HERE ON DELIMITER '=') JMS PROSEE / GO PROCESS END= AND/OR ERR= JMP IOLST0 / CARRY ON. / / MUST BE (N,M) OR (N,M,END=..,ERR=..) TYPE FORMTD JMS PREFMT / SNEAK IN TO PROFRM SUBROUTINE AND PROCESS FORMAT # JOIN1 LAC* CHINXT / GET DELIMITER, (N*) REENTERS HERE SAD (CLOSE JMP JOIN2 / IT WAS (N,M) OR (N,*) SAD (COMMA SKP JMP ERRIOF / ILLEGAL TERMINATOR / / MUST HAVE (N,M,END=..,ERR=..) OR (N,*,END=..,ERR=..) JMS* GETCHI / STEP PAST ',' JMS GETENT / GET NEXT ELEMENT JMP ERRIOF / SHOULD HAVE BEEN A '=' DELIMITER JMS PROSEE / ENDED ON '='. GO PROCESS END= AND/OR ERR= . JOIN2 LAC OLDPLC / GET ADDRESS OF FORMAT SAVED BY PREFMT JMS* ITEM4 / PUNCH OUT FORMAT ADDRESS JMP PROLST / CARRY ON / / THIS SUBROUTINE PICKS UP THE NEXT ELEMENT. IF THE TERMINATING / CHARACTER WAS A '=' IT INCREMENTS THE RETURN ADDRESS. GETENT XX CLA / ACCEPT ANYTHING JMS* SEARCH LAC* CHINXT SAD (REPLAC / IS CHAR '=' ISZ GETENT JMP* GETENT / / THIS SUBROUTINE PROCESSES EXPECTED END= AND/OR ERR= . ONLY ONE / OCCURRENCE OF EACH IS ALLOWED AND TERMINATING CONDITIONS ARE CHECKED. / THE ERR= CONDITION IS PROCESSED AND IGNORED. THE END= CONDITION IS / PROCESSED AND THE CORRECT ITEM PUNCHED OUT. PROSEE XX DZM LEVEL DZM OLDCHR PRO1 LAC* VANTED SAD (EE*100+NN*100+DD / HAVE WE END JMP LOKEND SAD (EE*100+RR*100+RR / HAVE WE ERR JMP LOKERR ERRIOH JMS* ERRORS / EXPECTING 'ERR=' OR 'END='; FOUND .SIXBT 'IOH' / OTHER CHARACTERS INSTEAD. / LOOKS LIKE WE HAVE 'ERR=' LOKERR LAC OLDCHR JMS CHKRST ISZ OLDCHR JMP JOIN3 / LOOKS LIKE 'END=' LOKEND LAC LEVEL JMS CHKRST ISZ LEVEL LAC* TBADDR / GET OTABLE ADDRESS XOR (400000 JMS* ITEM4 / THE ONLY VALID TERMINATORS NOW ARE ')' AND ',' JOIN3 LAC* CHINXT SAD (CLOSE JMP* PROSEE / ALL DONE, WAS ')' SAD (COMMA SKP JMP ERRIOH JMS* GETCHI / STEP PAST ',' JMS GETENT / GET NEXT ELEMENT JMP ERRIOH / SHOULD BE '=' JMP PRO1 / WAS '=' / / THIS SUBROUTINE PERFORMS SOME CHECKS AND PROCESSES THE STATEMENT / NUMBER CHKRST XX SZA JMP ERRIOI / ATTEMPT AT TWO END= OR ERR= LAC* VANT1 SZA JMP ERRIOH JMS* GETCHI / STEP PAST '=' LAC (INTGRS JMS* SEARCH LAC (STNUM JMS* CALCP LAC (TRAN. JMS SHOVE JMP* CHKRST / / IT WAS A SNEAKY FREE FORMAT DITCH JMS* GETCHI / STEP PAST * DZM OLDPLC / MARK AS FREE FORMAT JMP JOIN1 / / THIS SUBROUTINE PERFORMS THE HIERARCHY CHECK, SETS UP THE OPCODE / AND CHECKS FOR NO I/O LIST. STRAIT XX DAC OLDCHR / SAVE AC INFO LAW H5!.EXC JMS* HIERAR LAC OLDCHR / REGAIN INFO AND (770000 DAC* OPCODE / SET UP OPCODE JMS* GETCHI SAD (ENDST SKP JMP* STRAIT ERRIO7 JMS* ERRORS / ERROR - NO FORMAT # OR I/O LIST .SIXBT 'IO7' / / CHECK IF UNIT # IS VALID AND RECORD DEVICE REQUESTS CDEV XX LAC* VANTED / GET CONSTANT TAD (LRS!CLQ 0 / BUILD UP SHIFT TO RECORD DEVICE REQUEST DAC MAKE LAC* VANTED / GET & CHECK CONSTANT SPA!SNA!STL JMP ERRIOD / ERROR - ILLEGAL DEVICE NUMBER TAD (-11 SMA!CLA!RAL / AC=1 JMP ERRIOD / ERROR - ILLEGAL DEVICE NUMBER MAKE XX LAC DEVICE OMQ / 'OR' IN NEW DEVICE REQUEST DAC DEVICE LAC* AD2 DAC* DRESS / SET UP FOR PUNCH JMP* CDEV / / / THIS SUBROUTINE PROCESSES THE FORMAT NUMBER. IT MAY BE A FORMAT / STATEMENT OR AN ARRAY. / THE ROUTINE IS ENTERED AT PREFMT IF THE CALL TO SEARCH HAS ALREADY / BEEN DONE. PREFMT XX LAC PREFMT DAC PROFRM JMP SNEAK PROFRM XX CLA JMS* SEARCH / ACCEPT ANYTHING FROM SEARCH SNEAK LAC* FLTFLG SAD (CONBIT!SINTGM JMP STATE / ITS A STATEMENT NUMBER AND (CONBIT SZA JMP ERRIO6 / ANY OTHER TYPE OF CONSTANT IS ILLEGAL / LAC (VARIAB JMS* CALCP / ENTER VARIABLE IN SYMBOL TABLE LAC* BITPTR / GET CONTROL BITS AND (DIMENS SZA / MUST BE AN ARRAY JMP PROJN / IT IS AN ARRAY ERRIO6 JMS* ERRORS / ERROR - ILLEGAL FORMAT TYPE .SIXBT 'IO6' / / ITS A STATEMENT NUMBER, PROCESS IT. STATE LAC (STNUM JMS* CALCP / ENTER IN SYMBOL TABLE LAC* BITPTR AND (000077\FORM\.IOPUT SZA JMP ERRIO2 LAC (.IOPUT / MARK AS OCCURRING IN A I/O STATEMENT JMS SHOVE PROJN LAC* TBADDR / GET OTABLE ADDRESS OF STATEMENT NUMBER DAC OLDPLC / SAVE IT JMP* PROFRM / / / THIS SECTION PROCESSES THE I/O LIST FOR ALL THE I/O STATEMENTS IOLST0 LAC* CLEW2 AND (37 SAD (CHARM JMP ERRIOK / ERROR - BINARY INTO CHARACTER LAC (400000 / MARK AS BINARY I/O IOLST JMS* ITEM4 / PUNCH OUT 2ND WORD PROLST JMS* GETCHI PROLS0 SAD (ENDST JMP CFINSH PROLS1 DZM LEVEL LAW -4 TAD* CHIEND DAC IMPTAB DAC OLDPLC LAC* CHINXT IENTER SAD (OPEN JMP IMPLDO / LOOKS LIKE AN IMPLIED DO COMING UP JMS PRVARB LAC* CHINXT / GET TERMINATING CHAR SAD (ENDST JMP CFINSH / END OF STATEMENT JMS* GETCHI / STEP PAST LAST CHAR JMP IENTER / END OF LIST IS ENCOUNTERED. COMPILE FINISH OPCODE AND EXIT CFINSH LAC (IODONE*M JMS* ITEM4 R13 EXIT / ERRIO2 JMS* ERRORS .SIXBT 'IO2' ERRIO3 JMS* ERRORS .SIXBT 'IO3' ERRIOJ JMS* ERRORS .SIXBT 'IOJ' ERRIOF JMS* ERRORS .SIXBT 'IOF' ERRIOI JMS* ERRORS / ERROR - ATTEMPT AT TWO END= OR ERR= .SIXBT 'IOI' ERRIOK JMS* ERRORS .SIXBT 'IOK' / / / / HAVE FOUND A '(' , IT MUST BEGIN A DO LOOP. BUILD UP IMPLIED DO / LOOP TABLES. IMPLDO LAC OLDPLC TAD (4 DAC OLDPLC JMS CENTRY TAD (1 DAC* CHIEND / RESET UP CHIEND TO PROTECT TABLE ENTRY ISZ LEVEL / STEP UP A LEVEL LAC LEVEL DAC* LEVELP / STORE IN TABLE JMS GETPLC / GET CURRENT POSITION DAC* OPENP / STORE POSITION OF '(' DZM* COMMAP DZM* SEMIPT / / SEARCH THE INPUT STRING FOR THE FOLLOWING CHARACTERS. A '(' MAY / BEGIN AN IMPLIED DO ONLY IF IT IS PRECEDED BY A '(' OR ',' SVCHAR LAC* CHINXT SVCHR1 DAC OLDCHR / SAVE LAST CHAR JMS* GETCHI / GET NEXT ONE SAD (OPEN JMP CHKIMD / CHAR IS '(' SAD (APOST JMP QUOTE / CHAR IS "'" SAD (COMMA JMP ITCOM / CHAR IS ',' SAD (CLOSE JMP ERRIO3 / CHAR IS ')' SAD (REPLAC SKP / CHAR IS '=' JMP SVCHAR / NONE OF THE ABOVE / / HAVE FOUND A '=' . SCAN THROUGH TO ')' LAC* COMMAP SNA / HAVE WE HAD A ',' JMP ERRIO3 / ERROR - NO ',' ENCOUNTERED BEFORE '=' GETCLS JMS* GETCHI / GET NEXT CHAR SAD (CLOSE SKP JMP GETCLS JMS GETPLC / GET POSITION OF ')' DAC* SEMIPT JMS* REPLCE / REPLACE WITH ';' LAC* LEVELP SAD (1 JMP PROIMD / GO PROCESS IMPLIED DO LAW -1 / NOT LEVEL 1 TAD LEVEL DAC LEVEL / DECREMENT LEVEL JMS BACKS / BACK DOWN THE TABLE TO ENTRY AT THIS LEVEL JMP SVCHAR / / HAVE FOUND A '(' . IF NOT AN IMPLIED DO, SCAN FOR THE CLOSING ')' . CHKIMD LAC OLDCHR SAD (OPEN JMP IMPLDO / MUST BEGIN AN IMPLIED DO SAD (COMMA JMP IMPLDO / MUST BEGIN AN IMPLIED DO GETCL1 JMS* GETCHI / SCAN FOR ')' SAD (CLOSE JMP SVCHR1 / FOUND ')' JMP GETCL1 / NOT ')' , TRY AGAIN / / HAVE FOUND A "'" . SKIP TO THE END OF IT QUOTE JMS* GETCHI SAD (APOST JMP SVCHAR JMP QUOTE / / HAVE FOUND A ',' ITCOM JMS GETPLC DAC* COMMAP / STORE POSITION OF COMMA JMP SVCHAR / / PROCESS THE IMPLIES DO LOOP AND PUNCH OUT THE CODE PROIMD LAC IMPTAB / SET UP TO 1ST ENTRY SKP NEWNTY LAC NXPLC TAD (4 DAC NXPLC JMS CENTRY / SET POINTERS TO NEW ENTRY / / PROCESS THE DO SECTION LAC* COMMAP JMS RETPLC / SET UP TO POSITION OF ',' JMS PRODOS / PROCESS THE DO LOOP LAC* OPENP JMS RETPLC / RESET TO '('+1 CHKOP SAD (OPEN / IS NEXT CHAR '(' JMP NEWNTY / A NEW IMPLIED DO / / WE DO NOT HAVE A '(' . THUS PROCESS THE EXPRESSION LAC* LEVELP / SET TO CURRENT LEVEL DAC LEVEL PROV JMS PRVARB LAC* CHINXT / GET TERMINATING CHAR SAD (COMMA SKP JMP ERRIO3 / ERROR - NOT COMMA / / CHECK IF COMMA PRECEDES DO PARAMETERS ,I=J,K,L CPRECD JMS GETPLC / GET POSITION OF THIS ',' SAD* COMMAP JMP UNWIND / IT DOES JMS* GETCHI / NO. STEP PAST ',' JMP CHKOP / GO CHECK IF NEXT CHAR BEGINS A IMPLIED DO / / THE ',' PRECEDES THE DO PARAMETERS UNWIND LAW -1 JMS ENDDO / UNWIND ONE DO LOOP LAC* SEMIPT JMS RETPLC / SKIP OVER PARAMETERS TO )+1 SAD (ENDST / IS IT END OF STATEMENT JMP CFINSH / YES SAD (COMMA / NO. IS IT COMMA SKP JMP ERRIO3 / ILLEGAL TERMINATOR AFTER ')' LAC* LEVELP / GET LEVEL SAD (1 / HAVE WE UNWOUND THE LAST IMPLIED DO? JMP FRFOR1 / YES. END OF THIS IMPLIED DO SET TAD (-1 DAC LEVEL / GO DOWN A LEVEL JMS BACKS / THIS DO LOOP SET NOT FINISHED / POSSIBLE CONDITIONS ARE ((A(I,J),I=1,K),J=1,L) AND / ((A(I,J),I=1,K),.........,J=1,L) JMS GETPLC SAD* COMMAP JMP UNWIND / IT IS ((AI,J),I=1,K),J=1,L) / MUST BE THE FORM ((A(I,J),I=1,K),.....,J=1,L) JMS* GETCHI / STEP PAST ',' JMP CHKOP / / / / THIS SUBROUTINE ADVANCES THE POINTERS EITHER UP OR DOWN / THE TABLE CENTRY XX DAC LEVELP TAD (1 DAC OPENP TAD (1 DAC COMMAP TAD (1 DAC SEMIPT JMP* CENTRY ERRIOL JMS* ERRORS .SIXBT 'IOL' / / THIS SUBROUTINE BACKS DOWN THE TABLE LOOKING FOR AN ENTRY / AT A CERTAIN LEVEL BACKS XX BACK1 LAW -4 TAD LEVELP JMS CENTRY LAC* LEVELP SAD LEVEL JMP* BACKS / ENTRY FOUND JMP BACK1 / TRY NEXT ONE DOWN / / / THIS SUBROUTINE CRUNCHES THE ADDRESS OF A CHARACTER IN / THE CHI TABLE INTO ONE WORD FOR THE IMPLIED DO TABLE GETPLC XX LAC* IND SZA LAC (400000 TAD* INDEX JMP* GETPLC / / / THIS SUBROUTINE RESETS THE CHI POINTERS RETPLC XX SPA!CLL STL / SET LINK IF AC0=1 AND (077777 DAC* INDEX SZL!CLA CLC DAC* IND JMS* GETCHI / GET CHARACTER AFTER THE CURRENT ONE JMP* RETPLC / / / THIS SUBROUTINE PROCESSES VARIABLES IN THE INPUT OR OUTPUT LISTS PRVARB XX LAW NOSTEP JMS* EXPRES .DSA TAIL .DSA ERRIOJ .DSA TAIL .DSA TAIL TAIL LAC* CLEW2 DAC* CLUES AND (INACC!INVERT SNA /DID WE HAVE AN EXPRESSION? JMP NOTEXP /NO SAD (INVERT /IS ITEM NOT IN AC BUT REQUIRES INVERSION? SKP JMP STREXP /HAVE EXPRESSION LAC (INACC XOR* CLEW2 /MARK RESULT AS BEING IN ACCUMULATOR DAC* CLEW2 LAC* AD2 /MUST LOAD AND STORE NEGATIVE DAC* DRESS /BECAUSE WE HAVE -(CONSTANT) OR LAC (LOAD*M / -(VARIABLE) DAC* OPCODE JMS* PUNCH /PUNCH OUT LOAD / / HAD AN EXPRESSION, STORE IT / STREXP LAC CLEW2 DAC* ACCSW LAC* CLEW2 AND (INVERT SZA!STL /DO WE REQUIRE INVERSION? JMP .+3 LAC (STORE*M /YES. COMPILE STORE NEGATIVE SKP LAC (STOREN*M /YES. JMS* TEMPA2 / GET A TEMPORARY ACCUMULATOR, CLEAR ACC LAC (TEMPER / TO FREE TEMPORARY ACC DAC* CLUES / ON NEXT OPCODE JMP SINGL / GO MARK AS A SINGLE VARIABLE / IT WAS NOT AN EXPRESSION NOTEXP LAC* AD2 DAC* DRESS LAC* CLEW2 AND (DIMMEN SNA JMP .+3 LAC (GROUPS*M / GET ARRAY OPCODE SKP SINGL LAC (SINVAR*M / GET SINGLE VARIABLE OPCODE DAC* OPCODE JMS* PUNCH / GO PUNCH OPCODE OUT JMP* PRVARB .EJECT ERRRT0 JMS* ERRORS / TOO FEW RETURN POINTS FOR VARIABLE RETURN .SIXBT 'RT0' ERRRT1 JMS* ERRORS / ILLEGAL SYNTAX ON RETURN CODE .SIXBT 'RT1' / RETR LAW H5!.EXC JMS* HIERAR LAC IFSW / IF(...)RETURN,IS NOT UNCONDITIONAL TRANSFER SMA ISZ* STATSW / ORDINARY RETURN LAC KIND SAD (MAINK / IF A MAINLINE PROGRAM, COMPILE AS 'STOP' JMP STOP2 SAD (FUNK / OR IS IT A FUNCTION SUBPROGRAM ? JMP RFUNK / YES. / / WE MUST BE PROCESSING A SUBROUTINE SUBPROGRAM JMS* GETCHI SAD (ENDST JMP RETURN / IT IS FORM 'RETURN' / / IT MUST BE OF THE FORM 'RETURN I' / PROCESS THE CONSTANT OR VARIABLE / LAW EXPILL JMS* EXPRES ERRRT1 ERRRT1 ROKAY ERRRT1 / / MUST BE POSITIVE SINGLE INTEGER CONSTANT, OR / SINGLE OR DOUBLE INTEGER VARIABLE / ROKAY LAC* CLEW2 AND (37!INVERT SAD (SINTGM / IS IT SINGLE VARIABLE? JMP RETRNV / YES. LEGAL. SAD (DINTGM / DOUBLE INTEGER VARIABLE? JMP RETRNV / YES. ALSO LEGAL. SAD (CONBIT!SINTGM / SINGLE INTEGER CONSTANT? JMP RETRNC / ERRRT2 JMS* ERRORS / RETURN CODE MUST BE CORRECT MODE .SIXBT 'RT2' / / PUNCH OUT OPCODE AND ADDRESS / RETRNV LAC* AD2 DAC* DRESS LAC* CLEW2 DAC* CLUES LAC (RTRNX*M DAC* OPCODE JMS* PUNCH LAC RPCNT / GET # OF RETURN POINTS TAD (6 / ADD # OF STATIC ELEMENTS IN OTABLE JMS* ITEM4 EXIT / / IT IS A SINGLE INTEGER CONSTANT. CHECK IF IT IS WITHIN RANGE. / RETRNC LAC* VANTED CMA TAD (1 TAD RPCNT SPA JMP ERRRT0 / ERROR # > # OF RETURN POINTS LAC* VANTED TAD (5 / ADD (# OF STATIC ELEMENTS - 1) IN TABLE JMP RETUR1 / / WE ARE PROCESSING A FUNCTION SUBPROGRAM / COMPILE 'LOAD 0006' RFUNK LAC (LOAD*M+0006 / THERE ARE 6 SPECIAL ENTRIES AHEAD OF IT JMS* ITEM4 / CODE 04 / / COMPILE 'RTRN 0001' RETURN LAC (0001 RETUR1 XOR (RTRN*M JMS* ITEM4 / CODE 04 EXIT / / STOP LAW H5!.EXC JMS* HIERAR LAC IFSW / IF(...) STOP ,IS NOT UNCONDITIONAL TRANSFER SMA ISZ* STATSW / ORDINARY STOP STOP2 LAC (LEAVE*M JMP PAUSE1 / / PAUSE STATEMENT .PAUSE LAW H5!.EXC JMS* HIERAR LAC (PAUSE*M PAUSE1 DAC COUNT DZM* VANTED / ZERO VANTED IN CASE OF NO NUMBER, IE PAUSE; JMS* GETCHI SAD (ENDST / IS IT SIMPLE FORM, PAUSE; OR STOP; JMP GOT / YES. LAC (INTGRS / NO. MUST BE FORM, PAUSE N; OR STOP N; JMS* SEARCH LAC* VANTED / GET OCTAL NUMBER TAD (-303237 / 99999 DECIMAL = 303237 OCTAL SMA!SZA / IS NUMBER LARGER THAN 99999 DECIMAL JMP ERRPA0 / GOT LAC VANTED / GET VANTED'S ADDRESS JMS* G.STPC / SET UP VANTED AS BUFFER FOR ASCII LAC (1 DAC* NUMS / CONVERT 5 DIGITS TO ASCII CLL / STORE LEADING ZEROS LAC* VANTED / GET INTEGER NUMBER JMS* G.CVRT / CONVERT TO ASCII & PLACE IN VANTED LAC (REALM DAC* FLTFLG / INSERT ASCII AS REAL NUMBER LAC (CONSTN JMS* CALCP / ENTER IN SYMBOL TABLE LAC* TBADDR / GET RELATIVE OTABLE ADDRESS XOR COUNT / GET EITHER 'STOP' OR 'PAUSE' CODE JMS* ITEM4 / CODE 04 LAC* CHINXT SAD (ENDST EXIT ERRPA0 JMS* ERRORS .SIXBT 'PA0' / / WE ARE COMPILING '$TRACEON' (OP CODE 63) OR '$TRACEOFF' (OP CODE 64) / TRACON LAW H5!.EXC JMS* HIERAR LAC (TRCON*M JMS* ITEM4 LAC (TRDV&777 / I/O DEVICE FOR '$TRACEON' DAC* ITEM LAC (26 JMS* INSRT / GENERATE ' .IODEV TRDV' EXIT / TRACOFF LAW H5!.EXC JMS* HIERAR LAC (TRCOF*M JMS* ITEM4 EXIT .EJECT /******************************************** / / THE FOLLOWING CODE HANDLES FUNCTION AND SUBROUTINE STATEMENTS / LOGICF LAC (LOGICM /LOGICAL FUNCTION JMP SETMDE INTF LAC (SINTGM /INTEGER FUNCTION JMP SETMDE DINTF LAC (DINTGM /DOUBLE INTEGER FUNCTION JMP SETMDE REALF LAC (REALM /REAL FUNCTION JMP SETMDE DREALF LAC (DBLEM /DOUBLE PRECISION FUNCTION JMP SETMDE CMPLXF LAC (CMPLXM /COMPLEX FUNCTION JMP SETMDE CHARF LAC (CHARM /CHARACTER FUNCTION / SETMDE DAC MODE / MODE DEFINITION OVERRIDES IMPLICIT MODE / REGULAR FUNCTION ENTER HERE FUNCT LAC (FUNK / MARK SUBPROGRAM AS A FUNCTION JMP PROCS / / SUBROUTINES ENTER HERE SUBR LAC (SUBK PROCS DAC KIND JMS* GETCHI LAC (NAME JMS* SEARCH / GET SUBPROGRAM NAME / DO HIERARCHY CHECK AND SAVE THE SUBPROGRAM AS ASCII IN OTABLE / AND IN INTERNAL CODE FOR INTERNAL GLOBLING LATER LAW H1!NON.EX JMS* HIERAR / / THE SUBPROGRAM NAME HAS NOW BEEN SAVED. IF IT IS A FUNCTION / ENTER THE FUNCTION NAME IN THE SYMBOL TABLE AS A VARIABLE DZM RPCNT / MARK AS NO STATEMENT NUMBER ARGUMENTS YET LAC KIND SAD (SUBK / IS IT A SUBROUTINE JMP ITSASB / YES. / SUBPROGRAM IS A FUNCTION LAC MODE SZA / IF MODE IS SET IT OVERRIDES IMPLICIT MODE DAC* FLTFLG LAC (VARIAB JMS* CALCP / ENTER NAME IN SYMBOL TABLE LAC MODE SZA / WAS IT A TYPE FUNCTION LAC (MODEST / YES. MARK MODE AS BEING SET XOR (FUNNAM / MARK AS PROGRAM NAME JMS SHOVE LAC* CHINXT / GET NEXT CHARACTER SJOIN SAD (STAR / IS IT '*' JMP FUNTST / PROCESS THE MODE CHANGE CHKOPN SAD (OPEN / IS IT '(' JMP PROARG / YES. GO PROCESS ARGUMENT STRING SAD (ENDST / IS IT ';' JMP ERRFN0 / ERROR - MISSING ARGUMENT STRING ERRFN1 JMS* ERRORS / ERROR - ILLEGAL CHARACTER AFTER NAME .SIXBT 'FN1' / THE CHARACTER IS '*'. THIS IS ILLEGAL IN A SUBROUTINE AND NON-TYPE / FUNCTION SUBPROGRAM FUNTST LAC MODE / IF MODE=0 THEN STATEMENT IS EITHER SNA / NON-TYPE FUNCTION OR SUBROUTINE JMP ERRFN2 / MODE CHANGE IS ILLEGAL IN BOTH JMS* GETCHI / GET CHAR AFTER '*' LAC (SIGNER!INTGRS / PICK UP WORD SIZE JMS* SEARCH LAC FN6 / ERROR IN CASE MODE CHANGE ILLEGAL JMS MODCHK / IS IT A LEGAL LENGTH LAC* MODPTR / MUST BE, IT RETURNED AND (777760 / REMOVE OLD MODE XOR MODE / INSERT NEW MODE DAC* MODPTR LAC* CHINXT JMP CHKOPN / / SUBPROGRAM IS A SUBROUTINE ITSASB ISZ HEADER / SET HEADER FOR NO ARG SUBROUTINE LAC* CHINXT SAD (ENDST EXIT / ITS A NO ARGUMENT SUBROUTINE JMP SJOIN / EITHER HAS ARGUMENTS OR ITS AN ERROR. / / THE SUBPROGRAM HAS AN ARGUMENT LIST, PROCESS IT PROARG LAC (10 DAC HEADER / SET HEADER TO BASIC SUB WITH ARG SIZE PROAR1 JMS* GETCHI / GET NEXT CHARACTER SAD (STAR / IS IT THE '*' FOR A STATEMENT NUMBER? JMP PROSTA / YES. PROCESS STATEMENT NUMBER LAC (NAME / NOT STATEMENT NUMBER, GET NAME JMS* SEARCH LAC (VARIAB JMS* CALCP LAC* BITPTR / GET CONTROL BITS AND (FORMAL!FUNNAM SAD (FORMAL / WAS ARGUMENT IN STRING ALREADY JMP ERRFN3 / YES. SAD (FUNNAM / IS ARGUMENT SAME AS PROGRAM NAME JMP ERRFN8 / YES. LAC (FORMAL!NOHERE / IST TIME FOR ARGUMENT JMS SHOVE / ENTER CONTROL BITS JMS* DLOTAB / RESCIND OTABLE ENTRY FOR ARGUMENT ISZ* DTNEXT / GET EXTRA WORD FOR A FORMAL PARAMETER IN / CASE IT'S A CHARACTER VARIABLE. AGSUB2 LAC MODPTR DAC* BASE1 ISZ BASE1 / ADVANCE TO NEXT WORD ISZ HEADER / COUNT THE ARGUMENTS LAC* CHINXT / RETRIEVE LAST CHARACTER SAD (COMMA / WAS IT ',' JMP PROAR1 / YES. GO AFTER NEXT ARGUMENT / SAD (CLOSE / IS IT ')' SKP JMP ERRFN1 JMS* GETCHI SAD (ENDST / IS IT END OF STATEMENT SKP JMP ERRFN1 LAW -1 DAC* BASE1 / INSERT END OF FORMAL PARAMETER LIST INDICATOR ISZ BASE1 LAC RPCNT SNA / WERE THERE '*' STATEMENT # ARGUMENTS JMP REINCR LAC KIND / YES. SAD (SUBK / ARE WE PROCESSING A SUBROUTINE? JMP REINCR ERRFN5 JMS* ERRORS / MULTIPLE RETURNS ILLEGAL IN FUNCTIONS .SIXBT 'FN0' REINCR LAC BASE1 DAC* BASE2 / PROTECT FORMAL PARAMETERS BY ADVANCING POINTER DAC* BASE3 EXIT / / PROSTA ISZ RPCNT / COUNT STATEMENT NUMBERS LAC IFSTAT / GET AN INTERNAL STATEMENT NUMBER DAC* VANTED / TO PREVENT CLASH WITH 00000 ISZ IFSTAT / INCREMENT INTERNAL NUMBER LAC (STNUM JMS* CALCP JMS* GETCHI / STEP PAST * LAC BITPTR TAD (STOTB*100000 JMP AGSUB2+1 / FN6 .SIXBT 'FN6' / ERRFN0 JMS* ERRORS / ERROR- NO ARGUMENT LIST FOR FUNCTION .SIXBT 'FN0' ERRFN2 JMS* ERRORS / ERROR- TYPE CHANGE ILLEGAL HERE .SIXBT 'FN2' ERRFN3 JMS* ERRORS / ERROR- REPEATED ARGUMENT IN PARAMETER LIST .SIXBT 'FN3' ERRFN8 JMS* ERRORS / ERROR- ARGUMENT NAME SAME AS SUBPROGRAMS .SIXBT 'FN8' .EJECT / / / TABLE TO ALLOW CHECKING OF MODE CHANGES WITHIN SPECIFICATION / STATEMENTS. GENERAL FORM IS : 'MODE + WORD SIZE' / L.2.4 LOGICM*10000+2 LOGICM*10000+4 I.2 SINTGM*10000+2 I.4 DINTGM*10000+4 SINTGM*10000+2 W1 .DSA 0 .DSA 0 R.4 REALM*10000+4 DBLEM*10000+10 R.8 DBLEM*10000+10 REALM*10000+4 W2 .DSA 0 .DSA 0 W3 .DSA 0 .DSA 0 C.8 CMPLXM*10000+10 DCMPXM*10000+20 W4 .DSA 0 .DSA 0 C.16 DCMPXM*10000+20 CMPLXM*10000+10 / / THIS SUBROUTINE CHECKS FOR LEGAL CHANGES OF WORD LENGTHS MODCHK XX DAC ERRSP+1 LAC MODE SAD (CHARM JMP MODCHM TAD (-1 / USE TABLE TO CHECK MODE. RCL / -1 * 2 TAD (L.2.4 / ADD START ADDRESS OF TABLE DAC TEMP / TO GET CORRECT ENTRY LAC* TEMP / GET CONTENTS AND (000077 / REMOVE MODE BITS SAD* VANTED / IS IT THE SAME AS THE NUMBER IN VANTED JMP* MODCHK / MODES ARE THE SAME, RETURN. / ISZ TEMP / TRY 2ND WORD LAC* TEMP AND (000077 / REMOVE MODE BITS SAD* VANTED SKP JMP ERRSP / NO MATCH , COMBINATION ILLEGAL LAC* TEMP CLL LRS 14 DAC MODE JMP* MODCHK / CHECK IF CHARACTER SIZE IS WITHIN RANGE MODCHM JMS CHKRNG / GO CHECK THE RANGE OF THE INTEGER LAC* VANTED DAC* CPOINT / SIZE VALID, OVERRIDE STATEMENT CHAR SIZE IN DTABLE JMP* MODCHK ERRSP JMS* ERRORS XX / THE SIXBIT CODE IS PLACED HERE / SP1 .SIXBT 'SP1' / / THIS SUBROUTINE CHECKS THE RANGE OF CHARACTER DECLARACTIONS CHKRNG XX LAC* VANT1 SZA / 2ND WORD MUST BE ZERO JMP ERRSP6 / SIZE TOO LARGE LAC* VANTED SNA JMP ERRSP6 / SIZE IS ZERO TAD (-400 / 256 SMA!SZA JMP ERRSP6 / ERROR - SIZE > 256 JMP* CHKRNG / / / TABLE CONTAINS THE # OF WORDS STORAGE REQUIRED FOR DIFFERENT / TYPES OF VARIABLES.THIS TABLE IS ACCESSED WHEN WE ARE BUILDING / UP DIMENSION TABLES AND ASSIGNING ADDRESS & SIZES SIZETB .DSA 1 / LOGIC .DSA 1 / SINGLE INTEGER .DSA 2 / DOUBLE INTEGER .DSA 15 / UNKOWN - TEMPORARY ACCUMULATOR .DSA 2 / REAL .DSA 4 / DOUBLE REAL .DSA 0 / BLANK .DSA 0 / BLANK .DSA 4 / COMPLEX .DSA 0 / BLANK .DSA 10 / DOUBLE COMPLEX / / / THIS SUBROUTINE GETS THE WORD SIZE FORM THE ABOVE TABLE / TAKING THE MODE FROM THE DTABLE AND LEAVES THE / WORD SIZE IN AC. WDSIZE XX AND (17 / GET MODE SAD (CHARM JMP WDCHAR TAD (SIZETB-1 DAC TEMP / POINTS TO WORD SIZE LAC* TEMP / GET WORD SIZE IN AC JMP* WDSIZE / NOW GET THE NUMBER OF WORDS FOR A CHARACTER ELEMENT WDCHAR LAC* CPOINT TAD (2 RCL IDIV 5 LACQ JMP* WDSIZE / / / THIS SUBROUTINE INSERTS CONTROL BITS FROM THE AC INTO WHERE-EVER / BITPTR POINTS. SHOVE XX LMQ / SAVE BITS IN MQ LAC* BITPTR / LOAD CONTROL BITS OMQ / OR NEW BITS IN DAC* BITPTR JMP* SHOVE / / THIS SUBROUTINE REMOVES THE CONTROL BITS CORRESPONDING TO / THOSE IN THE AC FORM WHERE-EVER BITPTR POINTS PULL XX CMA AND* BITPTR / REMOVE THAT BIT DAC* BITPTR / REPLACE CONTENTS JMP* PULL / BASE1 / CONTAINS START ADDRESS FOR DATA STORAGE SAVCMN / SAVES POINTER TO START OF COMMON ENTRY / / / LOGIC LOGIC LAC (LOGICM JMP SPECS3 / INTEGER INTGR LAC (SINTGM JMP SPECS3 / DOUBLE INTEGER DBLINT LAC (DINTGM JMP SPECS3 / REAL REAL LAC (REALM JMP SPECS3 / DOUBLE REAL DBLREL LAC (DBLEM JMP SPECS3 / COMPLEX COMPLX LAC (CMPLXM JMP SPECS3 / DOUBLE COMPLEX DBCPLX LAC (DCMPXM JMP SPECS3 /CHARACTER. A SPECIAL CASE DUE TO THE LARGER DTABLE ENTRY. IF A DTABLE / ENTRY HAS BEEN ASSIGNED WITH OTHER THAN CHAR MODE, IT IS TOO SMALL. / THUS IF A CHAR VARIABLE APPEARS IN BOTH DIMENSION AND CHARACTER / STATEMENTS, THE CHARACTER STATEMENT MUST BE 1ST. CHARAC JMS* GETCHI SAD (STAR JMP REPLCC LAC (1 / DEFAULT OF 1 JMP DEFLTC REPLCC JMS* GETCHI LAC (INTGRS JMS* SEARCH / GET CHAR SIZE JMS CHKRNG / CHECK SIZE OF INTEGER LAC* VANTED DEFLTC DAC STSIZE / STORE STATEMENT CHARACTER SIZE ISZ TYPESW LAW H3!NON.EX!BDLEGL JMS* HIERAR LAC (CHARM DAC MODESW JMP SPECST / SETFFG DAC* FLTFLG / SET TO TRUE MODE DAC MODE LAC (VARIAB JMS* CALCP LAC* FLTFLG / IF FLTFLG IS CHANGED THEN ENTRY ALREADY EXISTS SAD (CHARM / WITH ANOTHER MODE. JMP CHKSTR LAC* BITPTR AND (FORMAL SNA JMP ERRSP7 LAC STSIZE DAC* CPOINT / INSERT CHARACTER SIZE IN DTABLE JMP CHKSTR ERRSP7 JMS* ERRORS / ERROR - 1ST ENCOUNTER OF VARIABLE WAS NOT CHARACTER .SIXBT 'SP7' / ERRSP6 JMS* ERRORS / ERROR - ILLEGAL CHARACTER SIZE, 0 OR >256 .SIXBT 'SP6' / DIMENSION DIMEN ISZ DIMSW JMP SPECS4 / THIS SECTION LOOKS AFTER THE SPECIFICATION STATEMENTS ANALYSING / THEM AND SETTING UP THE PROPER SYMBOL TABLE ENTRIES. SPECS3 ISZ TYPESW DAC MODESW SPECS4 LAW H3!NON.EX!BDLEGL JMS* HIERAR SPECS1 JMS* GETCHI SPECST LAC (NAME / WE WANT A NAME JMS* SEARCH / GET VARIABLE / LAC MODESW / IF MODESW IS SET WE ARE IN SPEC STAT SAD (CHARM / IF CHARACTER ST. DO SPECIAL ENTRY JMP SETFFG SNA / AND MODESW CONTAINS THE MODE NOTSPC LAC* FLTFLG / NOT IN SPEC STATEMENT, USE FLTFLG DAC MODE / OTHERWISE USE MODE OF MODESW / LAC (VARIAB / SIGNIFIES WE ARE PASSING A VARIABLE JMS* CALCP / STORE IN SYMBOL TABLE CHKSTR LAC* CHINXT / GET CHAR AFTER NAME SAD (STAR / IS IT "*" SKP JMP MODSET / NO / / REDEFINITION OF MODE ATTEMPTED, VALID ONLY IN SPEC STATEMENT LAC COMSW TAD DIMSW SZA JMP ERRDM1 / MODE CHANGE ILLEGAL IN COMMON OR DIMENSION / JMS* GETCHI / YES. SET UP NEXT CHAR LAC (INTGRS / BETTER BE A INTEGER CONSTANT JMS* SEARCH LAC SP1 / LOAD ERROR IN CASE OF NO MATCH JMS MODCHK / GO CHECK MODES / / WAS MODE SET PREVIOUSLY IN A SPECIFICATION STATEMENT ? MODSET LAC* BITPTR / GET CONTROL BITS FROM DTABLE AND (MODEST / WAS MODE PREVIOUSLY SET IN A SPEC SNA / STATEMENT ? JMP SETMOD / NO. / ARE WE TRYING TO REDEFINE MODE ILLEGALLY IN ANOTHER SPEC STATEMENT LAC TYPESW / MODE SET PRVIOUSLY IN SPEC STATEMENT SNA / ARE WE IN A SPEC STATEMENT NOW? JMP OKAY / NO, OKAY CONTINUE LAC* FLTFLG / YES, GET SEARCH MODE SAD MODE / IS IT THE SAME AS MODE OF SPEC STATEMENT SKP JMP ERRSP2 / NO ERROR WRNSP9 JMS* WARN / YES ISSUE WARNING .SIXBT 'SP9' JMP OKAY / CONTINUE / / / SET MODE IN DTABLE SETMOD LAC* MODPTR / NO. THEN INSERT MODE AND (777760 / SAVE DTABLE POINTER, REMOVE MODE TAD MODE / INSERT MODE DAC* MODPTR / RESTORE WORD LAC TYPESW SNA / ARE WE IN A SPEC STATEMENT JMP OKAY / NO CONTINUE / / MARK MODE AS HAVING BEEN SET IN A SPEC STATEMENT (CAN'T BE CHANGED) LAC (MODEST / YES JMS SHOVE / / CHECK NOW TO SEE IF ANY DIMENSIONS FOLLOW. OKAY LAC* CHINXT / GET NEXT CHAR SAD (OPEN / IS IT " ( " JMP INFO / YES. DIMENSION INFO, PROCESS IT. LAC DIMSW / NO SZA / ARE WE IN A DIMENSION STATEMENT ? JMP ERRDM0 / YES. ERROR NO DIMENSIONS JMP FURTHR / NO. OKAY THEN / / ARGSW;VARSW;BOX1;COUNT;FILLPT;LOW;NUMBER;SLSHSW;SUBPT;SUM TEMP;PTRBIT;OTSAVE;S / / DIMENSIONING INFORMATION FOLLOWS, CHECK IF IT IS LEGAL SUBTAB / START ADDRESS FOR SUBSCRIPT TABLE INFO LAC* BASE3 DAC SUBTAB LAC* INTAB SNA / WAS VARIABLE ALREADY IN TABLE JMP NOTIN / NO IT WAS NOT. LAC* BITPTR / YES IT WAS, GET CONTROL BITS AND (DIMENS!DATSET!FUNBIT!FUNNAM SNA JMP ONLY1 / NONE OF ABOVE SAD (FUNBIT JMP ERRDM5 / IT IS A FUNCTION NAME SAD (FUNNAM JMP ERRDM5 / ITS THE SUBPROGRAM NAME SAD (DIMENS JMP ERRDM3 / IT ALREADY HAS DIMENSIONS JMP ERRDM4 / IT HAS DATA AND MAYBE DIMENSIONS ALREADY / / IF WE REACH HERE THEN THE VARIABLE WAS ALREADY IN THE TABLE / WITH NO DIMENSIONS OR DATA SUPPLIED. IT NOW HAS DIMENSIONS THUS / WE DISCARD THE PREVIOUS OTABLE ENTRY ( IT MIGHT BE REUSED LATER) / AND ASSIGN A NEW OTABLE ENTRY WHERE THE TWO OTABLE ENTRIES FOR / A DIMENSIONED VARIABLE MAY BE CONSECUTIVE! ONLY1 LAC* MODPTR JMS* GETADR / GET OLD OTABLE ADDRESS DAC TEMP / SAVE IT LAC* TEMP / GET 1ST WORD LMQ / SAVE IT LAW -1 TAD TEMP DAC TEMP LAC* TEMP / GET SECOND WORD JMS* GETOTB / ASSIGN NEW OTABLE ENTRY CLQ!LLS+6 DAC TEMP / SAVE RELATIVE OTABLE POINTER LAC* MODPTR / GET DTABLE POINTER AND (000077 / REMOVE OLD ADDRESS TAD TEMP / ADD IN NEW ADDRESS DAC* MODPTR / RESTORE THE WORD / / ENTER HERE IF VARIABLE WAS NOT IN SYMBOL TABLE AND HAS DIMENSIONS NOTIN LAC SUBTAB DAC SUBPT DZM COUNT DZM ARGSW DZM VARSW LAC BITPTR DAC PTRBIT / SAVE POINTER CAUSE VARIABLE SUBSCRIPTS CLOBBER BITPTR LAC (DIMENS / MARK AS HAVING DIMENSION INFO JMS SHOVE LAC* OTNEXT / SAVE POINTER TO OTABLE DAC OTSAVE CLQ!001000 / CLEAR AC AND MQ JMS* GETOTB / MAKE OTABLE ENTRY FOR DIM TABLE SO ITS CONSECUTIVE LAC* BITPTR AND (FORMAL SZA / IS VARIABLE A FORMAL PARAMETER ? ISZ ARGSW / YES. SET SWITCH / / NOW PROCEED TO PROCESS THE DIMENSION INFORMATION DOWN DZM SLSHSW LAC (2 DAC LOW / DEFAULT LOWER LIMIT = 1 , (RCL'D) GAMMA JMS* GETCHI LAC ARGSW SZA / IF IN ARGUMENT STRING, ARGSW=1 JMP ALPHA / / VARIABLE NOT A FORMAL PARAMETER. ONLY INTEGER CONSTANTS ALLOWED. INTEG LAC (INTGRS!SIGNER / NO. THUS WANT AN INTEGER JMS* SEARCH INTEG1 LAC* VANTED RCL DAC BOX1 JMP BETA / / VARIABLE WAS FORMAL PARAMETER. INTEGER CONSTANT OR INTEGER VARIABLES ALLOWED ALPHA LAW SIGNER JMS* SEARCH / ACCEPT ANY THING LAC* FLTFLG SAD (CONBIT!SINTGM / IS IT INTEGER CONSTANT ? JMP INTEG1 / YES SAD (SINTGM / IS IT SINGLE INTEGER VARIABLE JMP MODOK SAD (DINTGM / IS IT DOUBLE INTEGER VARIABLE JMP MODOK ERRDM9 JMS* ERRORS / VARIABLE DIMENSION NOT .SIXBT 'DM9' / SINGLE OR DOUBLE INTEGER / / HAVE A LEGAL MODE FOR THE VARIABLE MODOK LAC COMSW / HAVE FOUND VARIABLE SZA / ARE WE IN COMMON JMP ERREC8 / YES. VARIABLE DIMENSIONS IN COMMON ILLEGAL LAC (VARDIM DAC VARSW LMQ LAC* PTRBIT / GET CONTROL BITS OMQ / MARK AS HAVING VARIABLE DIMENSIONS DAC* PTRBIT LAC (VARIAB / PASS VARIABLE TO SYMBOL TABLE ROUTINE JMS* CALCP LAC* BITPTR / GET CONTROL BITS AND (FORMAL!COMSET / ONLY THESE TWO BITS ARE LEGAL SNA!CLL JMP ERRDM6 / ERROR - ILLEGAL TYPE OF VARIABLE LAC* MODPTR / GET 1ST WORD OF DTABLE LRS 6 / GET RELATIVE OTABLE POINTER STL RAL DAC BOX1 / STORE IT. AC17=1 INDICATES VARIABLE LAC (USED / MARK VARIABLE DIMENSION AS USED JMS SHOVE / / HAVE GOT AN INTEGER VARIABLE ADDRESS IN BOX1 BETA LAC* CHINXT SAD (SLASH JMP ITSLSH SAD (COMMA JMP ITSCMA SAD (CLOSE SKP JMP ERRSP3 / ILLEGAL DELIMITER IN SPEC ST JMS PUT / END OF DIMENSION INFO. PUT LAST LIMITS IN TABLE / / SET UP TO PROCESS LIMITS TABLE LAC COUNT / GET # OF SUBSCRIPTS CMA DAC NUMBER / -(N+1) TAD (1 DAC CNT / SET UP COUNTER WITH -N LAC VARSW SZA / DOES THIS VARIABLE HAVE VARIABLE DIMENSIONS JMP ENTRVD / YES. CAN'T PROCESS THEM. / / COMPUTE THE ADJUSTMENT FACTOR AND THE BASE ADDRESSES FOR THE / COLUMNS. CONSUB DZM SUM / INITIALIZE ADJUST FACTOR LAC (1 DAC PROD / INITIALIZE PRODUCTS LAC SUBTAB / START ADDRESS OF SUBSCRIPT TABLE DAC SUBPT / SET UP A POINTER TO SCAN TABLE TAD (1 DAC FILLPT / SET UP POINTER TO REFILL TABLE TOP LAC* SUBPT / GET LOW VALUE DAC LOW / STORE IT CMA / NEGATE IT TAD (1 / 2'S COMPLIMENT ISZ SUBPT / NOW POINTS TO HIGH VALUE TAD* SUBPT / ADD HIGH VALUE SPA!RCR / SHIFT TO GET PROPER NUMBER JMP ERRDM7 /UPPER LIMIT .LT. LOWER LIMIT TAD (1 / STRAIGHTEN UP ARITHMETIC DAC LENGTH ISZ SUBPT / POINTS AT NEXT LOW VALUE / / CALCULATE ADJUSTMENT FACTOR LAC LOW SPA!CLL!RAR /EXTEND SIGN & MAKE 1'S COMPLEMENT TAD (400000-1 MULS / LOW * PRODUCT PROD XX LACQ ADD SUM DAC SUM / / CALCULATE COLUMN ADDRESSES. LAC PROD CLL MUL / LENGTH * PRODUCT LENGTH XX LACQ DAC PROD DAC* FILLPT / PLACE IN TABLE ISZ FILLPT ISZ CNT / ARE WE FINISHED ? JMP TOP / LAC SUM / GET ADJUSTMENT FACTOR SMA!CMA TAD (1 DAC* SUBTAB CLA / / MAKE OTABLE ENTRY FOR DIMENSION TABLE AND DUMP / THE DIMENSION TABLE INTO THE DTABLE. ENTER TAD COUNT / N OR 3N TAD (1 / N+1 OR 3N+1 TAD DIMCNT DAC DIMCNT / ACCUMULATE SPACE NEEDED FOR DOMEMSION TABLES LAC* PTRBIT / GET CONTROL BITS AND (FORMAL SZA ISZ DIMCNT / NEED AN EXTRA WORD FOR FORMAL PARAMETERS LAC* DTNEXT / 2ND WORD POINTS TO DTABLE LOCATION XOR (DMOTB*100000 / MARK AS DIMENSION TABLE DAC* OTSAVE / DEPOSIT IN 2ND WORD ISZ OTSAVE / STEP TO 1ST WORD LAC COUNT / DEPOSIT NUMBER OF SUBSCRIPTS DAC* OTSAVE / IN 1ST WORD LAC NUMBER / GET NEG WORD COUNT FOR MOVING JMS* G.MOVE TAD SUBTAB TAD* DTNEXT LAC* (AUTO11 / CONTAINS LAST DTABLE ADDRESS TAD (1 DAC* DTNEXT / RESET TO NEXT FREE LOCATION JMS* GETCHI LAC PTRBIT / RESET BITPTR FOR SUBSEQUENT CHECKING DAC BITPTR JMP FURTHR / / SET UP THE COUNTER TO TRANSFER THE LIMITS TABLE AS IS. IE. 2N WORDS ENTRVD LAC NUMBER / -(N+1) TAD (1 / -N RCL / -2N DAC NUMBER LAC COUNT / N RCL / 2N JMP ENTER / / CHECK IF THERE ARE TWO SLASHES (IE. A(5/5/...) ) ERROR IF SO. ITSLSH LAC SLSHSW SZA / IS IT SECOND SLASH JMP ERRDMA / TWO SLASHES ILLEGAL LAC BOX1 DAC LOW ISZ SLSHSW / MARK FIRST SLASH AS HAVING OCCURRED JMP GAMMA / ITSCMA JMS PUT JMP DOWN / / PUT LOW AND HIGH LIMITS IN THE TABLE PUT XX ISZ COUNT LAC COUNT SAD (15 JMP ERRDM8 / TOO MANY SUBSCRIPTS LAC LOW DAC* SUBPT ISZ SUBPT LAC BOX1 DAC* SUBPT ISZ SUBPT JMP* PUT / .EJECT / / WE HAVE FINISHED PROCESSING DIMENSIONS FOR THIS VARIABLE IF / THERE WERE ANY. FURTHR LAC COMSW SZA / ARE WE IN A COMMON STATEMENT ? JMP CHAIN / YES LAC* CHINXT / NO. LOAD NEXT CHAR SAD (SLASH / IS IT " / " SKP JMP TRYCMA / NOT SLASH LAC DIMSW SZA / ARE WE IN A DIMENSION STATEMENT JMP ERRDM2 / YES. BUT " / " IS ILLEGAL / / PROCESS DATA INFORMATION, EVERYTHING AFTER THE FIRST SLASH- UP TO / AND INCLUDING THE LAST SLASH IS CONTAINED IN THE TEMPORARY STORAGE LAC* BASE2 DAC TEMP LAC* BITPTR AND (DIMENS / DO WE HAVE AN ARRAY OR SIMPLE VARIABLE? SZA LAC (400000 / SET UP ARRAY MARKER FOR 'PICCON' XOR MODPTR DAC* TEMP / STORE IN TEMP STORAGE LAC TEMP DAC* LIST / SET UP INSERTING ROUTINE CLA!CMA DAC* LIST1 LOOP JMS* GETCHI / GET NEXT CHAR DAC* BOX / STORE FOR INSERTION JMS* INSERT LAC* BOX / GET LAST CHAR SAD (SLASH / WAS IT " / " JMP YEP / YES SAD (ENDST / IS IT END OF LINE ? JMP ERRSP3 / NO FINAL SLASH JMP LOOP / YEP LAC* LIST / REGAIN POINTER TAD (1 / POINTS AT NEXT FREE LOCATION DAC* BASE2 DAC* BASE3 JMS* GETCHI / GET NEXT CHAR LAC (DATSET JMS SHOVE / MARK AS HAVING DATA JMP TRYCMA / / CHAIN THE COMMON VARIABLES INTO THE COMMON FILES CHAIN LAC* BITPTR / GET CONTROL BITS AND (FORMAL!FUNBIT!FUNNAM!COMSET SNA / NONE OF THE ABOVE JMP NOCERR SAD (COMSET / WAS VARIABLE ALREADY IN COMMON JMP ERRCM0 / YES. SAD (FORMAL / WAS VARIABLE A SUBPROGRAMME PARAMETER JMP ERRCM2 / YES. JMP ERRCM1 / EITHER FUNCTION OR SUBPROGRAMME NAME / / VARIABLE MAY BE IN COMMON NOCERR LAC (COMSET JMS SHOVE / OCCURRED IN COMMON LAC* SAVCMN / GET 1ST WORD OF COMMON NAME ENTRY SNA / IF=0, THEN FIRST ENTRY IS HAPPENING JMP FIRST DAC TEMP / NOT=0,CONTAINS POINTER TO FIRST ENTRY THREAD LAC* TEMP / GET DTABLE INFORMATION JMS* GETADR DAC TEMP / STORE ADDRESS LAC* TEMP / GET CONTENTS SAD (200000 / IF=0, THEN END OF CHAIN JMP ENDCHN DAC TEMP / NOT=0,CONTAINS DTABLE POINTER JMP THREAD / OF NEXT ITEM IN CHAIN / ENDCHN LAC MODPTR / GET LAST DTABLE ENTRY POSITION XOR* TEMP / STORE IN OTABLE TO EXTEND CHAIN DAC* TEMP / REPLACE IT JMP FIRST2 / FIRST LAC MODPTR / GET DTABLE POINTER DAC* SAVCMN / START COMMON CHAIN FIRST2 LAC* MODPTR / GET 1ST WORD OF LAST VARIABLE JMS* GETADR / GET ITS OTABLE ENTRY. POINTS TO 1ST WORD TAD (-1 / NOW POINTS TO 2ND WORD DAC TEMP LAC SAVCMN / COMMON NAME ADDRESS DAC* TEMP / GOES IN 2ND WORD OF OTABLE ENTRY / DELTA LAC* CHINXT SAD (SLASH JMP CMNSL1 / TRYCMA LAC* BITPTR / GET CONTROL BITS AND (DIMSET!DATSET!DIMENS!COMSET SZA / IF ABOVE BITS NOT SET, WE ARE NOT SURE JMP .+4 / OF VARIABLE, SO SET NOHERE BIT LAC (NOHERE JMS SHOVE JMS* DLOTAB / RESCIND OTABLE ENTRY FOR VARIABLE / LAC* CHINXT SAD (COMMA / IS IT " , " JMP SPECS1 SAD (ENDST EXIT / YES. RETURN ERRSP3 JMS* ERRORS / 'MISSING SLASH IN SPECIFICATION .SIXBT 'SP3' / STATEMENT DATA' OR 'ILLEGAL DELIMITER' / / THIS SECTION IS ENTERED WHEN THE FIRST NON-SPECIFICATION / STATEMENT IS FOUND. THE PTABLE IS SEARCHED FOR / COMMON NAMES AND WHEN FOUND IT CHAINS THROUGH THE / COMMON VARIABLES AND ASSIGNS THEM LOCATIONS RELATIVE TO THE / START OF THAT COMMON BLOCK. / / STORAGE LOCATIONS ADRES;DPOINT;DPTR;OPT1;OPT2;OPTR1;OPTR2 / CLENUP XX LAC CMNSWH SNA / WAS THERE ANY COMMON STATEMENTS ? JMP* CLENUP / NO. RETURN LAC* PTABLE / YES. TAD (-1 DAC* (AUTO12 / LOAD AUTO-INDEX REGISTER FOR G.SCAN NEXT LAC (COMNAM / WE ARE SEARCHING FOR COMMON NAMES JMS* G.SCAN / GO SCAN PTABLE SKP / EXIT HERE WHEN COMMON NAME FOUND JMP* CLENUP / EXIT HERE ON END OF PTABLE DAC DPOINT / STORE DTABLE ADDRESS DAC* (AUTO10 / / THIS SECTION CHAINS THROUGH COMMON ENTRIES & ASSIGNS LOCATIONS DZM ADRES / NEW COMMON BLOCK. INITIALIZE ADDRESS LAC* DPOINT / GET IST WORD OF DTABLE COMMON NAME ENTRY / NEWVAR AND (077777 SNA / IF=0, ITS END OF COMMON CHAIN JMP FIX / SET UP TOTAL COMMON SIZE DAC MODPTR / FINALLY POINTS TO 1ST WORD OF VARIABLE TAD (3 DAC BITPTR / POINTS TO CONTROL BITS OF VARIABLE TAD (1 DAC CPOINT /POINT TO CHARACTER VARIABLE SIZE / LAC* MODPTR / GET 1ST DTABLE WORD OF VARIABLE JMS* GETADR / SUBROUTINE RETURNS ABSOLUTE OTABLE LOC DAC OPT1 / POINTS TO 1ST WORD OF VARIABLE TAD (-1 DAC OPT2 / POINTS TO 2ND WORD LAC* OPT1 / GET ADDRESS OF NEXT VARIABLE DAC DPTR / IN DAISY CHAIN,IF ANY. SAVE IT. LAC ADRES / ASSIGN LOCATION XOR (200000 / ADD INDICATOR BITS DAC* OPT1 / PUT ADDRESS IN OTABLE. JMS ARYSIZ / GO GET ARRAY OR WORD SIZE TAD ADRES / ADD 'ADRES' TO GET NEW DAC ADRES / START ADDRESS FOR NEXT VARIABLE LAC DPTR / CONTINUE DAISY CHAIN JMP NEWVAR / / FIX LAC ADRES / THE VALUE OF ADRES IS ALSO THE TOTAL DAC* DPOINT / SIZE OF THE COMMON BLOCK. STORE IN JMP NEXT / DTABLE. / / / THIS SUBROUTINE DETERMINES THE SIZE OF STORAGE NEEDED FOR THE / VARIABLE. IF VARIABLE IS DIMENSIONED IT GETS THE ARRAY SIZE; IF NOT / IT RETURNS THE WORD SIZE. ARYSIZ XX LAC* MODPTR JMS WDSIZE / GET WORD SIZE DAC ARSQ LAC* BITPTR / GET CONTROL BITS AND (DIMENS SZA / ARE THERE ANY DIMENSIONS JMP ARRAY / YES IT IS AN ARRAY LAC ARSQ / NOT AN ARRAY, RETRIEVE WORD SIZE JMP* ARYSIZ / / SECTION TO DECIPHER DIMENSION INFORMATION TO GET ARRAY SIZE ARRAY LAC OPT2 / SINCE ITS AN ARRAY, NEXT OTABLE ENTRY TAD (-1 OENTRY DAC OPTR1 / CONTAINS EITHER: # OF SUBSCRIPTS TAD (-1 DAC OPTR2 / & POINTER TO DTABLE DIMENSION INFO LAC* OPTR1 / BUT IF FOLLOWING BIT IS SET 2ND WORD SMA!CLL / POINTS TO THE CORRECT OTABLE ENTRY JMP GETDIM / BIT NOT SET! THIS IS THE REAL THING. LAC* OPTR2 / BIT SET! IS ONLY ADDRESS JMP OENTRY / TEST THIS NEW OTABLE ENTRY / GETDIM TAD* OPTR2 / # OF SUBSCRIPTS.ADD ADDRESS OF DIMEN- DAC OPTR2 / TO GET ENTRY TO TABLE LAC* OPTR2 / GET # OF ELEMENTS MUL / MULT BY WORD SIZE ARSQ XX LACQ / GET ARRAY SIZE JMP* ARYSIZ / / ERRCM0 JMS* ERRORS / 'VARIABLE PREVIOUSLY PLACED IN COMMON' .SIXBT 'CM0' ERRCM1 JMS* ERRORS / 'NAME IN COMMON LIST PREVIOUSLY .SIXBT 'CM1' / USED AS OTHER THAN VARIABLE' ERRCM2 JMS* ERRORS / 'SUBPROGRAM PARAMETER APPEARS IN .SIXBT 'CM2' / COMMON STATEMENT' ERRDM0 JMS* ERRORS / 'NO DIMENSION SPECIFIED FOR A .SIXBT 'DM0' / VARIABLE IN A DIMENSION STATEMENT' ERRDM1 JMS* ERRORS / 'OPTIONAL LENGTH SPECIFICATION IN .SIXBT 'DM1' / DIMENSION OR COMMON STATEMENT IS ILLEGAL' ERRDM2 JMS* ERRORS / 'INITIALIZATION IN DIMENSION STATEMENT .SIXBT 'DM2' / IS ILLEGAL' ERRDM3 JMS* ERRORS / 'ATTEMPT TO RE-DIMENSION A VARIABLE' .SIXBT 'DM3' ERRDM4 JMS* ERRORS / 'ATTEMPT TO DIMENSION AN .SIXBT 'DM4' / INITIALIZED VARIABLE' ERRDM5 JMS* ERRORS / 'ATTEMPT TO DIMENSION A FUNCTION OR .SIXBT 'DM5' / SUBPROGRAM NAME' ERRDM6 JMS* ERRORS / 'VARIABLE SUBSCRIPT IS NOT A .SIXBT 'DM6' / FORMAL PARAMETER' ERRDM7 JMS* ERRORS / 'UPPER LIMIT LESS THAN LOWER LIMIT' .SIXBT 'DM7' ERRDM8 JMS* ERRORS / 'MORE THAN 13 SUBSCRIPTS NOT ALLOWED' .SIXBT 'DM8' ERRDMA JMS* ERRORS / 'ILLEGAL SYNTAX IN DECLARATION OF .SIXBT 'DMA' / LOWER/UPPER BOUNDS FOR DIMENSION' ERRSP2 JMS* ERRORS / 'ILLEGAL RE-DEFINITION OF PRECISION .SIXBT 'SP2' / WITHIN A SPECIFICATION STATEMENT' / / / PROGRAM STORAGE LOCATIONS. / THE FOLLOWING MUST BE INITIALIZED AT START OF EACH JOB / AND MUST NOT BE USED AS GENERAL REGISTERS / DTSTAT .DSA 440000 / INTERNAL STATEMENT NUMBERS FOR DATA STATEMENTS IFSTAT .DSA 400000 / INTERNAL STATEMENT NUMBERS FOR LOGICAL 'IF' / / CMNSWH 0 / SIGNIFIES THERE WAS A COMMON STATEMENT CHRCNT 0 / COUNTS THE NUMBER OF CHARACTER VARIABLE ASSIGNED SPACE DIMCNT 0 / COUNTS TOTAL SIZE REQUIRED FOR THE DIMENSION TABLES DTSTOR 0 / STORAGE IN CASE OF MULTIPLE DATA STATEMENTS ENDNST ERSW 0 / IF SET, ERROR ROUTINE RETURNS TO PROCESS SPECIAL LINE IFSW IFSTOR KIND 0 / DESCRIBES PROGRAM TYPE-1=MAINLINE,2=SUB,3=FUNCTION, / 4=BLOCK DATA RPCNT 0 / A COUNT OF STATEMENT NUMBERS IN SUBROUTINE LIST SMALLJ 0 / NEST NUMBER DEVICE 0 / CONTAINS THE DEVICE REQUESTS / / THE FOLLOWING MUST BE INITIALIZED AT THE START OF EACH LINE / AND MUST NOT BE USED AS GENERAL REGISTERS TYPESW;DIMSW;COMSW;EQUVSW;MODE;MODESW;STSIZE / / THE FOLLOWING ARE NOT GENERAL REGISTERS BUT DO NOT HAVE / TO BE INITIALIZED MODPTR;BITPTR;CPOINT;HEADER / / / / / THE FOLLOWING LOCATIONS ARE GENERAL STORAGE VARIABLES WHICH / SHOULD BE USED ONLY WHILE IN A CERTAIN STATEMENT PROCESSOR / THE STORAGE IS OVER LAPPED TO SAVE SPACE. / / GENERAL CNT;INCRES / DON'T OVERLAP THE ABOVE WORK REGISTERS / IF PROCESSOR IFBOX IFTEMP / /FORMAT PROCESSOR / FORMBX /POINTER TO FORMAT STATEMENT NO. OTABLE / / DATA IN SPECIFICATION PROCESSOR / DSPECS .BLOCK 2 / / DO PROCESSOR ADDRSK ADDRSL ADDRSI / / I/O PROCESSOR OLDCHR LEVEL OLDPLC NXPLC LEVELP OPENP COMMAP SEMIPT IMPTAB .END