!* MODIFIED 25/06/82 !{2900C}%CONSTINTEGER W1=2;! 1 PERQ 2 EMAS !{2900C}%CONSTINTEGER W2=4 !{2900C}%CONSTINTEGER W3=6 !{2900C}%CONSTINTEGER W4=8 !{2900C}%CONSTINTEGER W6=12 !{2900C}%CONSTINTEGER W8=16 !{2900C}%CONSTINTEGER W66=132 {PERQC}%CONSTINTEGER W1=1 {PERQC}%CONSTINTEGER W2=2 {PERQC}%CONSTINTEGER W3=3 {PERQC}%CONSTINTEGER W4=4 {PERQC}%CONSTINTEGER W6=6 {PERQC}%CONSTINTEGER W8=8 {PERQC}%CONSTINTEGER W66=66 %OWNINTEGER TRACETEMP !************* IMP80 version ****************** !* !*********************************************************************** !%INCLUDE "ERCS06.PERQ_TRIADOPS" ; !*********************************************************************** !* !* !*********************** TRIAD operator values ************************* !* %CONSTINTEGER ADD = X'02' %CONSTINTEGER SUB = X'03' %CONSTINTEGER MULT = X'04' %CONSTINTEGER DIV = X'05' %CONSTINTEGER NEG = X'06' %CONSTINTEGER ASMT = X'07' %CONSTINTEGER CVT = X'08' %CONSTINTEGER ARR = X'09' %CONSTINTEGER ARR1 = X'0A' %CONSTINTEGER BOP = X'0B' %CONSTINTEGER ASGN = X'0C' %CONSTINTEGER DMULT = X'0D' %CONSTINTEGER EXP = X'0E' %CONSTINTEGER AND = X'10' %CONSTINTEGER OR = X'11' %CONSTINTEGER NOT = X'12' %CONSTINTEGER EQUIV = X'13' %CONSTINTEGER NEQ = X'14' %CONSTINTEGER GT = X'15' %CONSTINTEGER LT = X'16' %CONSTINTEGER NE = X'17' %CONSTINTEGER EQ = X'18' %CONSTINTEGER GE = X'19' %CONSTINTEGER LE = X'1A' %CONSTINTEGER SUBSTR = X'1B' %CONSTINTEGER CHAR = X'1C' %CONSTINTEGER CONCAT = X'1D' %CONSTINTEGER CHHEAD = X'1E' %CONSTINTEGER STOD1 = X'20' %CONSTINTEGER STOD2 = X'21' %CONSTINTEGER STODA = X'22' %CONSTINTEGER EOD1 = X'24' %CONSTINTEGER EOD2 = X'25' %CONSTINTEGER EODA = X'26' %CONSTINTEGER EODB = X'27' %CONSTINTEGER STRTIO = X'30' %CONSTINTEGER IOITEM = X'31' %CONSTINTEGER IODO = X'32' %CONSTINTEGER IOSPEC = X'33' %CONSTINTEGER IO = X'34' %CONSTINTEGER NOOP = X'40' %CONSTINTEGER FUN = X'41' %CONSTINTEGER SUBR = X'42' %CONSTINTEGER ARG = X'43' %CONSTINTEGER STRTSF = X'44' %CONSTINTEGER ENDSF = X'45' %CONSTINTEGER CALLSF = X'46' %CONSTINTEGER JIT = X'50' %CONSTINTEGER JIF = X'51' %CONSTINTEGER JINN = X'52' %CONSTINTEGER JINP = X'53' %CONSTINTEGER JINZ = X'54' %CONSTINTEGER JIN = X'55' %CONSTINTEGER JIP = X'56' %CONSTINTEGER JIZ = X'57' %CONSTINTEGER CGT = X'58' %CONSTINTEGER GOTO = X'59' %CONSTINTEGER RET = X'5A' %CONSTINTEGER STOP = X'5B' %CONSTINTEGER PAUSE = X'5C' %CONSTINTEGER EOT = X'5D' %CONSTINTEGER STMT = X'60' %CONSTINTEGER ITS = X'61' %CONSTINTEGER PA = X'62' !* !* !* !*********************************************************************** !%INCLUDE "ERCS06.PERQ_QCONSTS" ; !*********************************************************************** !* !* !********************* TRIAD QUALIFIERS ******************************** !* %CONSTINTEGER NULL = 0 %CONSTINTEGER LIT = 1 %CONSTINTEGER CNSTID = 2 %CONSTINTEGER TRIAD = 3 %CONSTINTEGER LSCALID = 4 %CONSTINTEGER OSCALID = 5 %CONSTINTEGER CSCALID = 6 %CONSTINTEGER PSCALID = 7 %CONSTINTEGER TMPID = 8 %CONSTINTEGER ARRID = 9 %CONSTINTEGER LABID =10 %CONSTINTEGER PLABID =11 %CONSTINTEGER PROCID =12 %CONSTINTEGER ARREL =13 %CONSTINTEGER CHVAL =15 %CONSTINTEGER STKLIT =16 %CONSTINTEGER GLALIT =17 %CONSTINTEGER NEGLIT =18 %CONSTINTEGER ASCALID =19 %CONSTINTEGER PERMID = 20 !* !********************* MODES **************************************** !* %CONSTINTEGER INT2 = 0, INT4 = 1, INT8 = 2 %CONSTINTEGER REAL4 = 3, REAL8 = 4, REAL16 = 5 %CONSTINTEGER CMPLX8 = 6, CMPLX16 = 7, CMPLX32 = 8 %CONSTINTEGER LOG1 =13, LOG4 = 9, LOG8 =14 %CONSTINTEGER CHARMODE=10, HOLMODE =11 !* !********************* TYPES ************************************** !* %CONSTINTEGER INTTYPE = 1 %CONSTINTEGER REALTYPE = 2 %CONSTINTEGER CMPLXTYPE = 3 %CONSTINTEGER LOGTYPE = 4 %CONSTINTEGER CHARTYPE = 5 !* !********************* DICT INDEX SCALING FACTOR ****************** !* %CONSTINTEGER DSCALE = 0 !* !********************* REGISTER HOLDING INTERMEDIATE VALUE ******** !* %CONSTINTEGER INACC = 1 !* !*********************** length of maximum source statement *********** !* %CONSTINTEGER INPUT LIMIT = 1340 !* !*********************** fixed locations in global ******************** !* %CONSTINTEGER CONST REF = 6;! word displacement of 32 bit @ of const area !* !*********************************************************************** !*********************************************************************** !* !* !* !*********************************************************************** !%INCLUDE "ERCS06.PERQ_PDICTFMTS" ; !*********************************************************************** !* !* !*********************************************************************** !* Formats for accessing dictionary records * !*********************************************************************** !* %RECORDFORMAT PRECF( %C %BYTEINTEGER CLASS,TYPE,X0,X1, %C %INTEGER LINK1, LINK2, LINK3, ADDR4, %C %HALFINTEGER DISP,LEN,IDEN,IIN, %C %INTEGER LINE,XREF,CMNLENGTH, CMNREFAD) !* %RECORDFORMAT SRECF(%INTEGER INF0, LINK1, INF2, INF3, INF4) !* %RECORDFORMAT RESF((%INTEGER W %OR %HALFINTEGER H0, (%HALFINTEGER H1 %OR %BYTEINTEGER FORM,MODE))) !* %RECORDFORMAT BFMT(%INTEGER L,U,M) !* %RECORDFORMAT ARRAYDVF(%HALFINTEGER DIMS, ADDRDV, %C %INTEGER ZEROTOFIRST, ADFIRST, NUMELS, ELLENGTH, %C %RECORD(BFMT) %ARRAY B(1 : 7)) !* !* %RECORDFORMAT LABRECF(%BYTEINTEGER CLASS,TYPE,X0,X1, %C %INTEGER LINK1,LINK2,LINK3,ADDR4,LINK5,LAB,LINE, %C %HALFINTEGER DOSTART,DOEND,IFSTART,IFEND) !* %RECORDFORMAT PLABF(%INTEGER INDEX,CODEAD,REF,REFCHAIN) !* %RECORDFORMAT CONRECF(%INTEGER MODE,LINK1,DADDR,CADDR) !* %RECORDFORMAT TMPF(%BYTEINTEGER REG,MODE,%HALFINTEGER INDEX, %C %INTEGER LINK1,ADDR) !* %RECORDFORMAT CHARF(%INTEGER ADESC,LINK,LEN) !* %RECORDFORMAT FNRECF(%INTEGER FPTR,LINK1,HEAD,PCT) !* !* !*********************************************************************** !* Constants defining the size of DICT records * !*********************************************************************** !* %CONSTINTEGER IDRECSIZE = 14;! size of dict entry reserved for a new identifier %CONSTINTEGER CONRECSIZE = 8 %CONSTINTEGER CNSTRECMIN = 2 %CONSTINTEGER IMPDORECSIZE = 6;! size of DATA-implied-DO list item %CONSTINTEGER LABRECSIZE = 20 %CONSTINTEGER PLABRECSIZE = 8 %CONSTINTEGER XREFSIZE = 4 %CONSTINTEGER CMNRECEXT = 8;! extra space on iden record for common block name %CONSTINTEGER TMPRECSIZE = 6 %CONSTINTEGER DVRECSIZE = 10 !* !*********************************************************************** !* TRIAD record format * !*********************************************************************** !* %RECORDFORMAT TRIADF( %C %BYTEINTEGER OP, (%BYTEINTEGER USE %OR %BYTEINTEGER VAL2), %HALFINTEGER CHAIN, (%RECORD(RESF) RES1 %OR %C (%HALFINTEGER OPD1,%BYTEINTEGER QOPD1,MODE %OR %C (%INTEGER SLN %OR %INTEGER VAL1))), (%RECORD(RESF) RES2 %OR %C %HALFINTEGER OPD2,%BYTEINTEGER QOPD2,MODE2)) !* !* !*********************************************************************** !*********************************************************************** !* !*********************************************************************** !%INCLUDE "ERCS06.PERQ_QOPCODES" ; !*********************************************************************** !* ! ! OPCODES AND CONSTINTEGER FOR PERQ IMP ! P REFS ARE TO PERQ Q-CODE MANAUAL ! %CONSTINTEGER LDC0=0; ! P21 LOAD WORD CONSTANTS 0-15 %CONSTINTEGER LDC1=1 %CONSTINTEGER LDC2=2 %CONSTINTEGER LDC3=3 %CONSTINTEGER LDC4=4 %CONSTINTEGER LDC6=6 %CONSTINTEGER LDCN=22; ! P21 LOAD CONSTANT NIL %CONSTINTEGER LDCMO=16; ! P21 LOAD CONSTANT -1 %CONSTINTEGER LDCB=17; ! P21 LOAD CONSTANT (SIGNED)BYTE %CONSTINTEGER LDCW=18; ! P21 LOAD CONSTANT (SIGNED)WORD %CONSTINTEGER LDL0=109; ! P22 LOAD LOCAL WORD(0-15) %CONSTINTEGER LDL1=110 %CONSTINTEGER LDL2=111 %CONSTINTEGER LDL3=112 %CONSTINTEGER LDL4=113 %CONSTINTEGER LDL5=114 %CONSTINTEGER LDL6=115 %CONSTINTEGER LDLB=107; ! P22 LOAD LOCAL UNSIGNED BYTE OFFSET %CONSTINTEGER LDLW=108; ! P22 LOAD LOCAL WORD OFFSET %CONSTINTEGER LLAB=125; ! P22 LOAD LOCAL ADDRESS UBYTE OFFSET %CONSTINTEGER LLAW=126; ! P22 LOAD LOCAL ADDRESS WORD OFFSET %CONSTINTEGER STL0=129; ! P22 STORE LOCAL WORD (0-7 ONLY!) %CONSTINTEGER STLB=127; ! P22 STORE LOCAL WORD UBYTE OFFSET %CONSTINTEGER STLW=128; ! P22 STORE LOCAL WORD WORD OFFSET %CONSTINTEGER LDO0=139; ! P23 SHORT LOAD OWN WORD %CONSTINTEGER LDOB=137; ! P23 LOAD OWN WORD UBYTE OFFSET %CONSTINTEGER LDOW=138; ! P23 LOAD OWN WORD WORD OFFSET %CONSTINTEGER LOAB=155; ! P23 LOAD OWN ADDRESS UBYTE OFFSET %CONSTINTEGER LOAW=156; ! P23 LOAD OWN ADDRESS WORD OFFSET %CONSTINTEGER STO0=159; ! P23 STORE SHORT OWN WORD(0-7!!) %CONSTINTEGER STOB=157; ! P23 STORE OWN UBYTE OFFSET %CONSTINTEGER STOW=158; ! P23 STORE OWN WORD WORD OFFSET %CONSTINTEGER LDIB=215; ! P25 LOAD INTERMEDIATE-UBYTE OFFSET %CONSTINTEGER LDIW=216; ! P25 LOAD INTERMEDIATE WORD OFFSET %CONSTINTEGER LIAB=217; ! P25 LOAD INTERMEDIATE ADDR-UBYTE OFFSET %CONSTINTEGER LIAW=218; ! P25 LOAD INTERMEDIATE ADDR WORD OFFSET %CONSTINTEGER STIB=219; ! P25 STORE INTERMEDIATE-UBYTE OFFSET %CONSTINTEGER STIW=220; ! P25 STORE INTERMEDIATE WORD OFFSET %CONSTINTEGER STIND=21; ! P26 STORE INDIRECT ETOS TO ETOS-1 %CONSTINTEGER LDIND=173; ! P26 LOAD INDIRECT ETOS %CONSTINTEGER LDDC=237; ! P27 LAOD DOUBLE CONSTANT %CONSTINTEGER LDDW=239; ! P27 LOAD DOUBLE WORD %CONSTINTEGER STDW=183; ! P27 STORE DOUBLE WORD %CONSTINTEGER LDMC=236; ! P27 LOAD MULTIPLE WORD CONSTANT (TO MSTACK) %CONSTINTEGER LDMW=238; ! P27 LOAD MULTIPLE WORDS (TO MSTACK) %CONSTINTEGER STMW=182; ! P27 STORE MULTIPLE WORDS (FROM MSTACK) ! ! ARRAY STRING AND RECORD ACCESSING SECTION ! %CONSTINTEGER LDB=23; ! P28 LOAD BYTE (VIA POINTER) %CONSTINTEGER STB=24; ! P28 STORE BYTE (VIA POINTER) %CONSTINTEGER MVBB=167; ! P28 MOVE BYTES (VIA 2 POINTERS&FIXED LENGTH) %CONSTINTEGER MVBW=168; ! P28 MOVE BYTES (VIA 2 POINTERS&VARAIBLE LENGTH) %CONSTINTEGER LSA=19; ! P29 LOAD STRING ADDRESS(OF CONSTANT) %CONSTINTEGER SAS=184; ! P29 STRING ASSIGN %CONSTINTEGER LDCH=25; ! P29 LOAD CHARACTER (FROM STRING) %CONSTINTEGER STCH=28; ! P29 STORE CHARACTER (INTO STRING) %CONSTINTEGER MOVB=169; ! P30 MOVE WORDS BYTE COUNTER %CONSTINTEGER MOVW=170; ! P30 MOVE WORDS WORD COUNTER %CONSTINTEGER SIND0=173; ! P30 SHORT INDEX&LOAD WORD(0-7) %CONSTINTEGER INDB=171; ! P30 STATIC INDEX&LOAD(UBYTE OFFSET) %CONSTINTEGER INDW=172; ! P30 STATIC INDEX&LOAD(WORD OFFSET) %CONSTINTEGER INCB=232; ! P30 INCREMENT POINTER(UBYTE INDEX) %CONSTINTEGER INCW=233; ! P30 INCREMENT POINTER(WORD INDEX) %CONSTINTEGER IXAB=221; ! P30 INDEX ARRAY UBYTE ARRAY SIZE %CONSTINTEGER IXAW=222; ! P30 INDEX ARRAY WORD ARRAY SIZE %CONSTINTEGER IXA1=223; ! P31 INDEX ARRAY SHORT ARRAY SIZE(1-4) %CONSTINTEGER IXA2=224 %CONSTINTEGER IXA4=226 %CONSTINTEGER IXP=214; ! P31 INDEXED PACKED ARRAY %CONSTINTEGER LDP=26; ! P31 LOAD PACKED ARRAY %CONSTINTEGER STP=27; ! P31 STORE PACKED ARRAY %CONSTINTEGER ROTSHI=20; ! P31 ROTATE OR SHIFT 16BIT FIELD ! ! 16 BIT ARITHMETIC ! %CONSTINTEGER LAND=30; ! P32 LOGICAL AND %CONSTINTEGER LOR=31; ! P32 LOGICAL OR %CONSTINTEGER LNOT=32; ! P32 LOGICAL NOT %CONSTINTEGER NEQBOOL=34; ! P32 DOES AN EXCLUSIVE OR ! %CONSTINTEGER ABI=71; ! P33 INTEGER ABS %CONSTINTEGER ADI=72; ! P33 INTEGER ADD %CONSTINTEGER NGI=73; ! P33 INTEGER UNARY NEGATE %CONSTINTEGER SBI=74; ! P33 INTEGER SUBTRACT %CONSTINTEGER MPI=75; ! P33 INTEGER MULTIPLY %CONSTINTEGER DVI=76; ! P33 INTEGER DIVIDE %CONSTINTEGER MODI=77; ! P33 INTEGER MODULO %CONSTINTEGER CHK=78; ! P33 CHECK SUBSCRIPT RANGE %CONSTINTEGER EQUI=39; ! P33 INTEGER = %CONSTINTEGER NEQI=40; ! P33 INTEGER # %CONSTINTEGER LEQI=41; ! P33 INTEGER <= %CONSTINTEGER LESI=42; ! P33 INTEGER < %CONSTINTEGER GEQI=43; ! P33 INTEGER >= %CONSTINTEGER GTRI=44; ! P33 INTEGER > ! ! 32BIT REAL OPERATIONS ALL ON TOP 4 CELLS OF ETOS ! %CONSTINTEGER ROPS=250;! 32 BIT REAL OPERATIONS ! ! OPERATIONS ON SETS ! %CONSTINTEGER ADJ=185; ! P35 ADJUST SET SIZE %CONSTINTEGER SGS=66; ! P35 BUILD SINGLETON SET %CONSTINTEGER SRS=68; ! P35 BUILD SUBRANGE SET %CONSTINTEGER INN=88; ! P35 SET MEMBERSHIP %CONSTINTEGER UNI=89; ! P35 SET UNION %CONSTINTEGER SETINT=90; ! P35 SET INTERSECTION(RENAMED) %CONSTINTEGER DIF=91; ! P35 SET DIFFERENCE %CONSTINTEGER EQUPOWR=63; ! P35 SET = %CONSTINTEGER NEQPOWR=64; ! P35 SET # %CONSTINTEGER LEQPOWR=65; ! P36 SET <= (SUBSET OF) %CONSTINTEGER GEQPOWR=67; ! P36 >= SET >= (SUPERSET OF) ! ! STRING ARRAY AND RECORD COMPARISONS ! %CONSTINTEGER EQUSTR=51; ! P37 STRING COMPARISON = %CONSTINTEGER NEQSTR=52; ! P37 STRING COMPARISON # %CONSTINTEGER LEQSTR=53; ! P37 STRING COMPARISON <= %CONSTINTEGER LESSTR=54; ! P37 STRING COMPARISON < %CONSTINTEGER GEQSTR=55; ! P37 STRING COMPARISON >= %CONSTINTEGER GTRSTR=56; ! P37 STRING COMPARISON >= %CONSTINTEGER EQUBYT=57; ! P38 BYTE ARRAY COMPARISON = %CONSTINTEGER NEQBYT=58; ! P38 BYTE ARRAY COMPARISON # %CONSTINTEGER LEQBYT=59; ! P38 BYTE ARRAY COMPARISON <= %CONSTINTEGER LESBYT=60; ! P38 BYTE ARRAY COMPARISON < %CONSTINTEGER GEQBYT=61; ! P38 BYTE ARRAY COMPARISON >= %CONSTINTEGER GTRBYT=62; ! P38 BYTE ARRAY COMPARISON > %CONSTINTEGER EQUWORD=69; ! P39 MULTIWORD COMPARISON # %CONSTINTEGER NEQWORD=70; ! P39 MULTIWORD COMPARISON # %CONSTINTEGER LOPS=252; ! LONG OPERATIONS(32 BIT INTEGERS) ! ! JUMPS CALLS AND EXITS ETC ! %CONSTINTEGER JMPB=204; ! P41 UNCONDIONAL JUMP (BYTE OFFSET) %CONSTINTEGER JMPW=205; ! P41 UNCONDIONAL JUMP (WORD OFFSET) %CONSTINTEGER JFB=206; ! P41 FALSE JUMP (BYTE OFFSET) %CONSTINTEGER JFW=207; ! P41 FALSE JUMP (WORD OFFSET) %CONSTINTEGER JTB=208; ! P41 TRUE JUMP (BYTE OFFSET) %CONSTINTEGER JTW=209; ! P41 TRUE JUMP (WORD OFFSET) %CONSTINTEGER JEQB=210; ! P41 EQUAL JUMP (BYTE OFFSET) %CONSTINTEGER JEQW=211; ! P41 EQUAL JUMP (WORD OFFSET) %CONSTINTEGER JNEB=212; ! P41 NOT EQUAL JUMP (BYTE OFFSET) %CONSTINTEGER JNEW=213; ! P41 NOT EQUAL JUMP (WORD OFFSET) %CONSTINTEGER XJP=100; ! P41 CASE JUMP %CONSTINTEGER CALL=186; ! P43 CALL INTERNAL ROUTINE %CONSTINTEGER CALLXB=234; ! P43 CALL EXTERNAL ROUTINE(BYTE OFFSET) %CONSTINTEGER CALLXW=235; ! P43 CALL EXTERNAL ROUTINE(WORD OFFSET) %CONSTINTEGER LVRD=98; ! P43 LOAD VARIABLE ROUTINE DESCRIPTOR %CONSTINTEGER CALLV=187; ! P43 CALL VARIABLE ROUTINE DESCRIPTOR %CONSTINTEGER RETURN=200; ! P43 RETURN FROM ROUTINE ! ! ODDS & ENDS OF CONTROL INSTRUCTIONS ! %CONSTINTEGER QNOOP=93; ! P45 NO OPERATION %CONSTINTEGER REPL=94; ! P45 REPLICATE ETOS %CONSTINTEGER REPL2=95; ! P45 REPLICATE ETOS & ETOS-1 %CONSTINTEGER MMS=96; ! P45 MOVE 16BITS TO MEMORY STACK %CONSTINTEGER MES=97; ! P45 MOVE 16BITS FROM MEMORY STACK %CONSTINTEGER MMS2=201; ! P45 MOVE 32 BITS TO MEMORY STACK %CONSTINTEGER MES2=202; ! P45 MOVE 32 BITS FROM MEMORY STACK %CONSTINTEGER RASTER=102; ! P45 RASTER OPERATION %CONSTINTEGER EXCH=230; ! P48 EXCHANGE TOS&TOS-1 %CONSTINTEGER EXCH2=231; ! P48 EXCHANGE TOS&TOS-1 WITH TOS-2&TOS-3 %CONSTINTEGER TLATE1=227; ! P48 TRANSLATE SEE DOCMTN %CONSTINTEGER TLATE2=228; ! P48 TRANSLATE SEE DOCMTN %CONSTINTEGER TLATE3=229; ! P48 TRANSLATE SEE DOCMTN %CONSTINTEGER STLATE=240; ! P48 TRANSLATE SEE DOCMTN %CONSTINTEGER LSSN=99; ! P49 LOAD STACK SEGMENT NO %CONSTINTEGER LDTP=203; ! P49 LOAD TOP POINTER %CONSTINTEGER LDAP=244; ! P49 LOAD ACTIVATION POINTER %CONSTINTEGER ATPB=188; ! P49 ! ADD SIGNED BYTE TO TOP POINTER %CONSTINTEGER ATPW=189; ! P49 ADD ETOS TO TOP POINTER %CONSTINTEGER WCS=190; ! P49 WRITE CONTROL STORE %CONSTINTEGER JCS=191; ! P49 JUMP TO CONTROL STORE %CONSTINTEGER REFILL=255; ! P45 REFILL OP FILE %CONSTINTEGER INCDDS=251; ! P50 INCREMENT DIAGNOSTICS ! ! SECOND BYTE FOR 32 BIT OPERATIONS ! %CONSTINTEGER I4TOI2=0 %CONSTINTEGER I2TOI4=1 %CONSTINTEGER ADDOP=2 %CONSTINTEGER NEGOP=3 %CONSTINTEGER SUBOP=4 %CONSTINTEGER MULTOP=5 %CONSTINTEGER DIVOP=6 %CONSTINTEGER MODOP=7 %CONSTINTEGER ABSOP=8 %CONSTINTEGER EQUOP=9 %CONSTINTEGER NEQOP=10 %CONSTINTEGER LEQOP=11 %CONSTINTEGER LESOP=12 %CONSTINTEGER GEQOP=13 %CONSTINTEGER GTROP=14 %CONSTINTEGER TNC=0 %CONSTINTEGER FLT=1 %CONSTINTEGER RND=7 !* !* !%INCLUDE "ERCS06.PERQ_COMFMT" !* %RECORDFORMAT COMFMT(%INTEGER CONTROL,OPTIONS,OPTIONS1,OPTIONS2,PTRACE, ADICT,ANAMES,ADOUTPUT,ADBLKDTAID,DICLEN,DPTR, MAXTRIADS,NEXTPLAB,ALABH,ADLHEAD, SUBPROGTYPE,SFPTR,EXTERNALS,CBNPTR,SCPTR,CHECKLIST, RESCOM1,RESCOM2,GLACA,FNO,FAULTY,LINEST,CMNIIN,SFMK, LISTL,LISTSTREAM,DIAGSTREAM,LISTPOINT,XREF, PACKCMN,ITSMODE,PATHANAL,CHARACTER CODE,SPACE CHAR, HEADINGS,ARRAYCHECKS,JBRMODE,MESSLEN,NAMESLEN, NEXTCH,FUNRESDISP,WARNCOUNT,INP,MAXINP,MESSCOUNT, UNASSPATTERN,LISTCODE,PI21INT,DOPTR,SUBPROGPTR, FNLST,LAB,NAMESFREE,ALGOLREF,FIRSTSTATNUM,CEXPDICT, COMMONBASE,FASTPROLOGUE,STATEMENT,IFPTR, CNSTCA,COMMENTCNT,ADIDENT,ADERRIDEN, ADEXT,MAXDICT,MAXNAMES,MAXOUTPUT,MAXEXT, ACOMP,ASUBNAMES,MAXPSTACK, ATRIADS,TRFILEID,TRBLOCK,CMNCNT,SCANONLY,NOISY, MAXANAL,MAXGEN,SAVEANAL,SAVEGEN) !* %RECORDFORMAT RTFMT(%HALFINTEGER PS,RPS,LTS,ENTRY,EXIT,LL,SP1,SP2, DIAG,SP3,%INTEGER ATEMPLATE) !* !******************************** EXPORTS *************************** !* %ROUTINESPEC CODEGEN(%INTEGER CGENEP,%RECORD(TRIADF)%ARRAYNAME TRIADS, %INTEGER COMAD) !* !********************************************************************* !%SYSTEMROUTINESPEC DUMP(%INTEGER AD,LEN) !* %EXTERNALROUTINESPEC LFAULT(%INTEGER ER) %EXTERNALROUTINESPEC TFAULT(%INTEGER ER,TA,TB) %EXTERNALROUTINESPEC FAULT(%INTEGER ER) %EXTERNALINTEGERFNSPEC ALLOCCHAR(%INTEGER L,AD,%HALFINTEGERNAME IIN, %INTEGERNAME DISP) %EXTERNALINTEGERFNSPEC GLA SPACE(%INTEGER LEN) %EXTERNALROUTINESPEC DICFUL %EXTERNALROUTINESPEC EXTFUL {PERQC}%EXTERNALROUTINESPEC READBLOCK(%HALFINTEGER FILEID, BLOCK,%INTEGER AD) {PERQC} %externalhalfintegerfnspec RoutLookup(%string(14) Name, {PERQC} %halfintegername Segnum, {PERQC} Rtnum, {PERQC} Language) !* !* !* {PERQC} %ownhalfinteger zeropdesc=x'FF01' !{2900C} %ownhalfinteger zeropdesc=x'01FF' !* %OWNINTEGER LINEST %OWNINTEGER CODESTART %OWNINTEGER LISTCODE %OWNINTEGER CGEN INITIALISED=0 %OWNINTEGER ACCUSE,ACCDESC %OWNINTEGER CHECKS %OWNRECORD(RESF) RES %OWNINTEGER EXPWORK %OWNINTEGER STATMAPHEAD,CURSTATMAP,STATMAPINDEX,STATCOUNT %OWNINTEGER STACKFRAME;! NO. OF WORDS ALLOCATED TO DATE IN PROC CALL STACK %OWNINTEGER LOCALDLIST %OWNINTEGER INARRAYSUBSCRIPT %OWNINTEGER RCOMPLEX;! #0 IF PROC. REAL PART OF COMPLEX ITEM %OWNINTEGER ICOMPLEX;! #0 %IF PROC. COMPLEX PART OF COMPLEX ITEM ! SIZE OF REAL PART OF CURRENT COMPLEX OPERAND %OWNINTEGER CWORK,CDIV2,COMPLEXTEMP %OWNINTEGER UNASSCHECKS %OWNINTEGER ARGCHECKS %OWNINTEGER CHARCHECKS %OWNINTEGER CALLSPEC %OWNINTEGER PROC PARLIST %OWNINTEGER ADDRCOM !* %OWNINTEGERARRAY TEMPST(0:9) !* !* !*********************** following declarations used only by SUBPROGEND actions ********************** !* !* !{2900C}%SYSTEMINTEGERMAPSPEC COMREG(%INTEGER I) %EXTERNALROUTINESPEC ALLOC(%INTEGER PTR) %EXTERNALINTEGERFNSPEC TIDY GLA(%HALFINTEGER EP,IIN,%INTEGER LEN) %EXTERNALROUTINESPEC MAP(%INTEGER ATTR,XREF,MAPS,AREA5 OFFSET, %C COMAD) !* !* !* !* %EXTERNALINTEGER PARCHECKS !* %OWNINTEGER VARIABLE RETURN %OWNINTEGER TOTAL FAULTS %OWNINTEGER ADJ FIXUPS %OWNINTEGER ASSUMED SIZE %OWNINTEGER CODELISTED %OWNHALFINTEGER FLIP,NEXT RTNO !* %OWNINTEGERARRAY TTYPE7(0:10) %OWNINTEGERARRAY TYPE7(0:10) %OWNINTEGERARRAY TYPE6(0 : 10) !* !* !***************************************************************************** !* !* %CONSTINTEGER UNASSFAULT=401 %CONSTINTEGER CHARFAULT=411 %CONSTINTEGER INCRFAULT=415 %CONSTINTEGER FMTLABFAULT=405 %CONSTINTEGER NEGUNITFAULT=424 %CONSTINTEGER BOUNDFAULT=407 %CONSTINTEGER ASIZEFAULT=408 %CONSTINTEGER CSIZEFAULT=412 %CONSTINTEGER RECURSEFAULT=418 %CONSTINTEGER ASSLABELFAULT=404 %CONSTINTEGER IDENDISP=24 %CONSTINTEGER DVAREA=7 %CONSTINTEGER FULL=2 %CONSTINTEGER YES=1 %CONSTINTEGER NO=0 !* %CONSTINTEGER FIOLNB=24 %CONSTINTEGER BLANKCREC=96 %CONSTINTEGER LNBSTACKBASE=4;! STACK ADDRESS TO HOLD CURRENT LNB VALUE %CONSTINTEGER MAXCHARSIZE=X'7FFF' !* %CONSTINTEGER TCTINDEX=4 %CONSTINTEGER TCTPP=18 %CONSTINTEGER ENTRYNO WORD=10 %CONSTINTEGER VRETURN WORD=11 !* %CONSTBYTEINTEGERARRAY MODETOWORDS(0:15)= %C 1,2,0,2,4,0,4,8,0,2,0,0,0,0,0,0 !* %CONSTBYTEINTEGERARRAY MODETOBYTES(0:14)= %C 4,4,8,4,8,16,8,16,32,4,0,0,0,4,8 !* %CONSTBYTEINTEGERARRAY CSIZE(0:9)=0,4,8,4,8,16,8,16,32,4 !* %CONSTBYTEINTEGERARRAY MODETOST(0:14)= %C X'41',X'51',X'61',X'52',X'62',X'72',X'53',X'63',X'73',X'54',X'05', 0, 0,X'34',X'64' !* %CONSTSTRING(5)%ARRAY GEN NAME(1:24)= %C "SQRT" ,"EXP" ,"LOG" ,"LOG10" , "SIN" ,"COS" ,"TAN" ,"COT" , "ASIN" ,"ACOS" ,"ATAN" ,"ATAN2" , "SINH" ,"COSH" ,"TANH" ,"" , "" ,"" ,"", "ABS", "LGE" ,"LGT", "LLE", "LLT" !* %CONSTSTRING(1)%ARRAY VARIANT(0:10) = %C "","","","","D","","C","","","","" !* !* !* !*********************************************************************** !* * !* OBJECT FILE INTERFACE ROUTINES * !* * !*********************************************************************** !* !* %OWNBYTEINTEGERARRAY CODE(0 : 268) %OWNHALFINTEGERARRAY DIAGBUFF(0 : 135) !* %OWNINTEGER CODECURR %EXTERNALINTEGER CODECA %OWNINTEGER CODEBASE %EXTERNALINTEGER STACKCA %OWNINTEGER STACKBASE %EXTERNALINTEGER DIAGCA %OWNINTEGER DIAGCURR,DIAGBASE !* !* !* !*********************************************************************** !%INCLUDE "ERCS06.PERQ_QOBJPROCS" !*********************************************************************** !* !* %EXTERNALROUTINESPEC QCODE(%INTEGER A,B,C,MODE) %EXTERNALROUTINESPEC QPUT(%INTEGER A,B,C,D) ! !*********************************************************************** !* IMP CODE PLANTING ROUTINES * !* CODE AND GLAP ARE PUT INTO THE BUFFERS 'CODE,GLABUF(0:268)' * !* BY A NUMBER OF TRIVIAL ROUTINES.QPUT IS CALLED TO ADD THE * !* BUFFER TO THE OUTPUT FILE. THE BUFFERS ARE BASICALLY 0:255 * !* WITH A 12-BYTE MARGIN TO MINIMISE THE NUMBER OF TESTS FOR * !* THE BUFFER FULL CONDITION * !* * !* CODECURR(GLACURR) IS THE BUFFER POINTER * !* CA(GLACA) IS THE RELATIVE ADDRESS OF THE NEXT BYTE * !* CODEBASE(GLACABUF) IS CA(GLACA) FOR START OF BUFFER * !*********************************************************************** %ROUTINE RECODE(%INTEGER S,F,AD) %IF S#F %START PRINTSTRING(" CODE FOR LINE"); WRITE(LINEST,5) QCODE(S,F,AD,16) NEWLINE %FINISH %END %ROUTINE CODEOUT %IF CODECURR>0 %THEN %START %IF LISTCODE#0 %THEN %C RECODE(ADDR(CODE(0)),CODECURR, CODEBASE) QPUT(41,CODECURR,CODEBASE,ADDR(CODE(0))) CODECURR=0; CODEBASE=CODECA %FINISH %END !* %ROUTINE PWORD(%INTEGER WORD) !*********************************************************************** !* ADD A WORD(16 BITS) TO CODE FLIPPING HALFS AS NEEDED * !*********************************************************************** CODE(CODECURR)<-WORD CODE(CODECURR+1)<-WORD>>8 CODECURR=CODECURR+2 CODECA=CODECA+2 CODEOUT %IF CODECURR>=256 %END !* %ROUTINE OP1(%INTEGER OPCODE) !*********************************************************************** !* ADD A SINGLE BYTE INSTRUCTION TO THE CODE * !*********************************************************************** CODE(CODECURR)=OPCODE CODECURR=CODECURR+1 CODECA=CODECA+1 CODEOUT %IF CODECURR>=256 %END !* %ROUTINE OP2(%INTEGER OPCODE1, OPCODE2) !*********************************************************************** !* ADD TWO SINGLE BYTE INSTRUCTIONS TO THE BUFFER * !*********************************************************************** CODE(CODECURR)=OPCODE1 CODE(CODECURR+1)=OPCODE2 CODECURR=CODECURR+2 CODECA=CODECA+2 CODEOUT %IF CODECURR>=256 %END;! OP2 !* %ROUTINE OP3(%INTEGER OPCODE1,OPCODE2,OPCODE3) !*********************************************************************** !* ADD THREE SINGLE BYTE INSTRUCTIONS TO THE BUFFER * !*********************************************************************** CODE(CODECURR)=OPCODE1 CODE(CODECURR+1)=OPCODE2 CODE(CODECURR+2)=OPCODE3 CODECURR=CODECURR+3 CODECA=CODECA+3 CODEOUT %IF CODECURR>=256 %END;! OP3 !* %ROUTINE OPB(%INTEGER OPCODE,BYTE) !*********************************************************************** !* ADD AN INSTRUCTION WITH ONE BYTE OPERAND TO THE CODE * !*********************************************************************** CODE(CODECURR)=OPCODE CODE(CODECURR+1)<-BYTE CODECURR=CODECURR+2 CODECA=CODECA+2 CODEOUT %IF CODECURR>=256 %END;! OPB !* %ROUTINE OPBB(%INTEGER OPCODE,BYTE1,BYTE2) !*********************************************************************** !* ADD AN INSTRUCTION WITH TWO ONE BYTE OPERANDS TO THE CODE * !*********************************************************************** CODE(CODECURR)=OPCODE CODE(CODECURR+1)<-BYTE1 CODE(CODECURR+2)<-BYTE2 CODECURR=CODECURR+3 CODECA=CODECA+3 CODEOUT %IF CODECURR>=256 %END;! OPBB !* %ROUTINE OPBBB(%INTEGER OPCODE,BYTE1,BYTE2,BYTE3) !*********************************************************************** !* PLANTS 4 BYTES INTO CODE WITHOUT CHECKING ANYTHING * !*********************************************************************** CODE(CODECURR)=OPCODE CODE(CODECURR+1)<-BYTE1 CODE(CODECURR+2)<-BYTE2 CODE(CODECURR+3)<-BYTE3 CODECURR=CODECURR+4 CODECA=CODECA+4 CODEOUT %IF CODECURR>=256 %END;! OPBBB !* %ROUTINE OPW(%INTEGER OPCODE,WORD) !*********************************************************************** !* PUT AN INSTRUCTION WITH ONE (FLIPPED) WORD OPERAND INTO THE CODE * !*********************************************************************** CODE(CODECURR)=OPCODE CODE(CODECURR+1)<-WORD CODE(CODECURR+2)<-WORD>>8 CODECURR=CODECURR+3 CODECA=CODECA+3 CODEOUT %IF CODECURR>=256 %END;! OPW !* !%ROUTINE OPBW(%INTEGER OPCODE,BYTE1,WORD) !!*********************************************************************** !!* PUT AN INSTRUCTION WITH BYTE&WORD PARAMETERS IN THE CODE * !!*********************************************************************** ! CODE(CODECURR)=OPCODE ! CODE(CODECURR+1)<-BYTE1 ! CODE(CODECURR+2)<-WORD ! CODE(CODECURR+3)<-WORD>>8 ! CODECURR=CODECURR+4 ! CODECA=CODECA+4 ! CODEOUT %IF CODECURR>=256 !%END;! OPBW !* %ROUTINE LOA(%INTEGER WORD) !*********************************************************************** !* load own address using best instruction * !*********************************************************************** %IF WORD<=255 %THENSTART OPB(LOAB,WORD) %FINISHELSESTART OPW(LOAW,WORD) %FINISH %END;! LOA !* %ROUTINE LDO(%INTEGER WORD) !*********************************************************************** !* load own * !*********************************************************************** %IF WORD<=255 %THENSTART %IF WORD<=15 %THENSTART OP1(LDO0+WORD) %FINISHELSESTART OPB(LDOB,WORD) %FINISH %FINISHELSE OPW(LDOW,WORD) %END;! LDO !* %ROUTINE STO(%INTEGER WORD) !*********************************************************************** !* store own * !*********************************************************************** %IF WORD<=255 %THENSTART %IF WORD<=7 %THENSTART OP1(STO0+WORD) %FINISHELSESTART OPB(STOB,WORD) %FINISH %FINISHELSE OPW(STOW,WORD) %END;! STO !* %ROUTINE LDOD(%INTEGER WORD) !*********************************************************************** !* load own double * !*********************************************************************** LDO(WORD+1) LDO(WORD) %END;! LDOD !* %ROUTINE STOD(%INTEGER WORD) !*********************************************************************** !* store own double * !*********************************************************************** STO(WORD) STO(WORD+1) %END;! STOD !* %ROUTINE LLA(%INTEGER WORD) !*********************************************************************** !* load local address * !*********************************************************************** %IF WORD<=255 %THENSTART OPB(LLAB,WORD) %FINISHELSESTART OPW(LLAW,WORD) %FINISH %END;! LLA !* %ROUTINE LDL(%INTEGER WORD) !*********************************************************************** !* load local * !*********************************************************************** %IF WORD<=255 %THENSTART %IF WORD<=15 %THENSTART OP1(LDL0+WORD) %FINISHELSESTART OPB(LDLB,WORD) %FINISH %FINISHELSE OPW(LDLW,WORD) %END;! LDL !* %ROUTINE STL(%INTEGER WORD) !*********************************************************************** !* store local * !*********************************************************************** %IF WORD<=255 %THENSTART %IF WORD<=7 %THENSTART OP1(STL0+WORD) %FINISHELSESTART OPB(STLB,WORD) %FINISH %FINISHELSE OPW(STLW,WORD) %END;! STL !* %ROUTINE LDLD(%INTEGER WORD) !*********************************************************************** !* load local double * !*********************************************************************** LDL(WORD+1) LDL(WORD) %END;! LDLD !* %ROUTINE STLD(%INTEGER WORD) !*********************************************************************** !* store local double * !*********************************************************************** STL(WORD) STL(WORD+1) %END;! STLD !* %ROUTINE LDC(%INTEGER WORD) !*********************************************************************** !* load constant * !*********************************************************************** %IF 0<=WORD<=15 %THENSTART OP1(LDC0+WORD) %FINISHELSESTART %IF WORD=-1 %THENSTART OP1(LDCMO) %FINISHELSESTART %IF -128<=WORD<=127 %THENSTART OPB(LDCB,WORD) %FINISHELSESTART OPW(LDCW,WORD) %FINISH %FINISH %FINISH %END;! LDC !* %ROUTINE LDCD(%INTEGER I) !*********************************************************************** !* load double constant * !*********************************************************************** %IF 0<=I<=X'7FFF' %THENSTART OP1(LDC0) LDC(I) %FINISHELSESTART OPW(LDDC,I>>16) PWORD(I&X'FFFF') %FINISH %END;! LDCD !* %ROUTINE MOVE TO MS(%HALFINTEGER WORDS) {address of source is assumed to be in Estack } {assumes that MOVB copies the words in the same order } OP3(LDTP,ATPB,WORDS) OP2(EXCH,MMS) OP2(EXCH,MES) OP3(TLATE1,MOVB,WORDS) %END;! MOVE TO MS !* !%ROUTINE PERM !!*********************************************************************** !!* EX KDF9 ROUTINE REARRANGE ESTACK FROM ABC TO BCA * !!*********************************************************************** ! OP1(EXCH); ! BAC ! OP1(MMS); ! AC ! OP1(EXCH); ! CA ! OP1(MES); ! BCA !%END;! PERM !!* !%ROUTINE CAB !!*********************************************************************** !!* EX KDF9 ROUTINE REARRANGE ESTACK FROM ABC TO CAB !!*********************************************************************** ! OP1(MMS); ! BC ! OP1(EXCH); ! CB ! OP1(MES); ! ACB ! OP1(EXCH); ! CAB !%END;! CAB !!* !%ROUTINE CNOP(%INTEGER I, J) ! OP1(QNOOP) %WHILE CODECA&(J-1)#I !%END !* !%ROUTINE GLAOUT ! %IF GLACURR=0 %THEN %RETURN ! QPUT(42,GLACURR<<1,GLABASE,ADDR(GLABUFF(0))) ! GLABASE=GLABASE+GLACURR ! GLACURR=0 !%END;! GLAOUT !!* !%ROUTINE PUTGLA(%HALFINTEGER H) ! GLABUFF(GLACURR)<-H ! GLACURR=GLACURR+1 ! GLACA=GLACA+1 ! GLAOUT %IF GLACURR>=128 !%END;! PUTGLA !!* !%ROUTINE PUTGLA2(%HALFINTEGER H1,H2) ! GLABUFF(GLACURR)<-H1 ! GLABUFF(GLACURR+1)<-H2 ! GLACURR=GLACURR+2 ! GLACA=GLACA+2 ! GLAOUT %IF GLACURR>=128 !%END;! PUTGLA2 !!* !%ROUTINE PUTGLAW(%INTEGER W) ! GLABUFF(GLACURR)<-W>>16 ! GLABUFF(GLACURR+1)<-W&X'FFFF' ! GLACURR=GLACURR+2 ! GLACA=GLACA+2 ! GLAOUT %IF GLACURR>=128 !%END;! PUTGLAW !!* !%ROUTINE PLUGGLA(%HALFINTEGER AT,WITH) ! GLAOUT ! QPUT(42,2,AT<<1,ADDR(WITH)) !%END;! PLUGGLA !* %ROUTINE DIAGOUT %IF DIAGCURR=0 %THEN %RETURN QPUT(44,DIAGCURR<<1,DIAGBASE,ADDR(DIAGBUFF(0))) DIAGBASE=DIAGBASE+DIAGCURR<<1 DIAGCURR=0 %END;! DIAGOUT !* %ROUTINE PUTDIAG(%HALFINTEGER H) DIAGBUFF(DIAGCURR)<-H DIAGCURR=DIAGCURR+1 DIAGCA=DIAGCA+1 DIAGOUT %IF DIAGCURR>=128 %END;! PUTDIAG !* %ROUTINE PUTDIAG2(%HALFINTEGER H1,H2) DIAGBUFF(DIAGCURR)<-H1 DIAGBUFF(DIAGCURR+1)<-H2 DIAGCURR=DIAGCURR+2 DIAGCA=DIAGCA+2 DIAGOUT %IF DIAGCURR>=128 %END;! PUTDIAG2 !* %ROUTINE PUTDIAGW(%INTEGER W) DIAGBUFF(DIAGCURR)<-W>>16 DIAGBUFF(DIAGCURR+1)<-W&X'FFFF' DIAGCURR=DIAGCURR+2 DIAGCA=DIAGCA+2 DIAGOUT %IF DIAGCURR>=128 %END;! PUTDIAGW !* %ROUTINE PLUGDIAG(%HALFINTEGER AT,WITH) DIAGOUT QPUT(44,2,AT<<1,ADDR(WITH)) %END;! PLUGDIAG !* %ROUTINE DIAGBYTES(%INTEGER START,%HALFINTEGER LEN) %INTEGER AD %INTEGER I AD=2*DIAGCA %CYCLE I=1,1,LEN PUTDIAG(HALFINTEGER(START)) START=START+W1 %REPEAT %IF FLIP=YES %THEN QPUT(9,4,AD,2*LEN);! flip bytes on 2900 %END;! DIAGBYTES !* %ROUTINE USER REF(%INTEGER ANAME,APDESC,PDESC WORDS,REF) !* SET A REF TO A USER PROC !* REF = 0 variable call desc for param !* 1 direct call { note and check reference and param descriptors} %IF REF=0 %THENSTART OPBBB(LVRD,0,0,0) OP1(0) %FINISHELSESTART OPBBB(CALLXW,0,0,0);! word segno, byte rno %FINISH %END;! USER REF !* %ROUTINE USER CALL(%INTEGER AT) !* CALL USER PROC WITH REFERENCE IN GLA LOA(AT+2) OP1(LDDW) LOA(AT) OP2(LDDW,CALLV) %END;! USER CALL !* %ROUTINE SYSCALL(%STRING(15) NAME) !* PLANT A CALL TO A SYSTEM PROC, REQUESTING QPUT TO FILL IN !* ISN AND ROUTINE NUMBER QPUT(12,0,CODECA,ADDR(NAME)) OPBB(CALLXB,1,0) %END;! SYSCALL !* %ROUTINE ERASE(%INTEGER WORDS) !*********************************************************************** !* REMOVES 1 OR 2 WORDS FROM THE ESTACK * !*********************************************************************** %IF WORDS=1 %THEN OPBB(MMS,ATPB,-1) %ELSE OPBB(MMS2,ATPB,-2) %END !* %ROUTINE FILL JUMP(%INTEGER INST ADDR) %INTEGER J %HALFINTEGER I J=CODECA-INST ADDR-3 %IF J>=X'8000' %THEN %RETURN I=J QPUT(18,0,INST ADDR+1,I) %END;! FILL JUMP !* !* !* !*************************************************************************************************************** !*************************************************************************************************************** !* !* !* !{2900C}%OWNINTEGERARRAY EXTAREA(0:8192) %OWNINTEGER AREFDATA,CUR REFDATA %OWNINTEGER ENTRIES,REFS !* %RECORDFORMAT EXTF(%INTEGER LINK,(%INTEGER RTNO %OR %INTEGER REFCHAIN), %HALFINTEGER LINENO,FL,%INTEGER PDESC AD, %STRING(8) NAME) %RECORDFORMAT CHAINF(%INTEGER LINK,AD,FL) !* !{2900C}%CONSTINTEGER EXTFLEN=28 !{2900C}%CONSTINTEGER REFCHAINLEN=12 {PERQC}%CONSTINTEGER EXTFLEN=14 {PERQC}%CONSTINTEGER REFCHAINLEN=6 !* %INTEGERFN EXT SPACE(%HALFINTEGER LEN) %RECORD(COMFMT)%NAME COM %INTEGER I COM==RECORD(ADDRCOM) I=CUR REFDATA CUR REFDATA=CUR REFDATA+LEN %IF CUR REFDATA>COM_MAXEXT %THEN EXTFUL %RESULT=AREFDATA+I %END !* %ROUTINE INIT EXT %RECORD(COMFMT)%NAME COM COM==RECORD(ADDRCOM) CUR REFDATA=0 !{2900C} COM_MAXEXT=16000 ENTRIES=0 REFS=0 %END !* %EXTERNALHALFINTEGERFN NOTE ENTRY(%STRING(32) NAME,%INTEGER RTNO,LINENO, PDESC LEN,PDESC AD,%INTEGERNAME OLDLINE) %RECORD(EXTF)%NAME EXT %INTEGER I,J,SIZE !{2900C} SIZE=((PDESC LEN+4)>>2)<<2 {PERQC} SIZE=(PDESC LEN+2)//2 %IF LENGTH(NAME)>8 %THEN LENGTH(NAME)=8 I=ENTRIES %WHILE I#0 %CYCLE EXT==RECORD(I) %IF EXT_NAME=NAME %THENSTART OLDLINE=EXT_LINENO %RESULT=1;! duplicate definition %FINISH I=EXT_LINK %REPEAT I=EXT SPACE(EXTFLEN+SIZE) EXT==RECORD(I) EXT_NAME=NAME EXT_LINK=ENTRIES ENTRIES=I EXT_RTNO=RTNO EXT_LINENO=LINENO !**************************************** note pdesc for subs checking I=I+EXTFLEN EXT_PDESC AD=I STRING(I)=STRING(PDESC AD) !{TR} NEWLINE !{TR} PRINTSTRING("entry ") !{TR} PRINTSTRING(NAME) !{TR} %CYCLE J=0,1,PDESC LEN !{TR} WRITE(BYTEINTEGER(I+J),3) !{TR} %REPEAT !{TR} NEWLINE %RESULT=0 %END;! NOTE ENTRY !* %EXTERNALHALFINTEGERFN NOTE REF(%STRING(32) NAME,%INTEGER ADREF, LINENO,TYPE,PDESC LEN,PDESC AD) !* TYPE = 0 call !* 1 lvrd !* 2 Pascal %RECORD(EXTF)%NAME EXT %RECORD(CHAINF)%NAME CHAIN %INTEGER I,J,SIZE !{2900C} SIZE=((PDESC LEN+4)>>2)<<2 {PERQC} SIZE=(PDESC LEN+2)//2 %IF LENGTH(NAME)>8 %THEN LENGTH(NAME)=8 I=REFS %WHILE I#0 %CYCLE EXT==RECORD(I) %IF EXT_NAME=NAME %THENSTART !************************* check param desc correspondence ADD REF: J=EXT SPACE(REFCHAINLEN) CHAIN==RECORD(J) CHAIN_LINK=EXT_REFCHAIN CHAIN_FL=TYPE EXT_REFCHAIN=J CHAIN_AD=ADREF %RESULT=0 %FINISH I=EXT_LINK %REPEAT I=EXT SPACE(EXTFLEN+SIZE) EXT==RECORD(I) EXT_NAME=NAME EXT_LINENO=LINENO EXT_LINK=REFS EXT_FL=TYPE REFS=I EXT_REFCHAIN=0 !****************************** check param desc correspondence I=I+EXTFLEN EXT_PDESC AD=I STRING(I)=STRING(PDESCAD) !{TR} NEWLINE !{TR} PRINTSTRING("ref ") !{TR} PRINTSTRING(NAME) !{TR} %CYCLE J=0,1,PDESC LEN !{TR} WRITE(BYTEINTEGER(I+J),3) !{TR} %REPEAT !{TR} NEWLINE ->ADD REF %END;! NOTE REF !* %EXTERNALROUTINE SAT REFS %ROUTINESPEC CHECK %INTEGER I,J,K,pdescad %halfinteger Segnum,Rtnum,Language,Found %BYTEINTEGER B0,B1,B2,B3 %RECORD(EXTF)%NAME REF %RECORD(EXTF)%NAME ENT %RECORD(CHAINF)%NAME CHAIN %RECORD(COMFMT)%NAME COM COM==RECORD(ADDRCOM) I=REFS %WHILE I#0 %CYCLE REF==RECORD(I) J=ENTRIES %WHILE J#0 %CYCLE ENT==RECORD(J) %IF REF_NAME=ENT_NAME %THENSTART CHECK K=REF_REFCHAIN %WHILE K#0 %CYCLE CHAIN==RECORD(K) %IF CHAIN_FL&1#0 %THENSTART;! lvrd B1=98;! LVRD B0=0 B3=0 B2=ENT_RTNO %FINISHELSESTART !{2900C} B0=186 !{2900C} B1=ENT_RTNO {PERQC} B1=186;! call {PERQC} B0=ENT_RTNO B2=93;! no-op B3=93;! no-op %FINISH QPUT(41,4,CHAIN_AD,ADDR(B0)) K=CHAIN_LINK %REPEAT ->NEXT REF %FINISH J=ENT_LINK %REPEAT pdescad = ref_pdescad %if pdescad=0 %then pdescad=addr(zeropdesc) Found=1 %IF REF_FL=2 %THENSTART;! in EXTERNAL/PASCAL/ !{2900C} Found=0 {PERQC} Found = RoutLookup(Ref_name,Segnum,Rtnum,Language) %IF Found#0 %THENSTART TFAULT(326,ADDR(REF_NAME),0) %FINISH %FINISHELSESTART %IF COM_LISTSTREAM>0 %THENSTART NEWLINE PRINTSTRING("Unsatisfied reference: ") PRINTSTRING(REF_NAME) NEWLINE %FINISH %FINISH k=ref_refchain %while k#0 %cycle chain == record(k) {PERQC} %if found#0 %start qput(5,pdescad,chain_ad,addr(ref_name)) {PERQC} %finishelsestart {PERQC} b1 = 235 {callxw} {PERQC} b3 = SEGNUM>>8 {PERQC} b2 = RTNUM {PERQC} b0 = SEGNUM&255 {PERQC} QPUT(41,4,CHAIN_AD,addr(b0)) {PERQC} %Finish k=chain_link %repeat ! NEWLINE ! PRINTSTRING("Unsatisfied reference ") ! PRINTSTRING(REF_NAME) ! NEWLINE NEXT REF:I=REF_LINK %REPEAT !* !********************************* define entries to QPUT !* %RETURN !* %ROUTINE CHECK %INTEGER ER,I,J %BYTEINTEGERARRAYFORMAT BF(0:255) %BYTEINTEGERARRAYNAME R %BYTEINTEGERARRAYNAME E %IF STRING(REF_PDESCAD)=STRING(ENT_PDESCAD) %THEN %RETURN R==ARRAY(REF_PDESCAD,BF) E==ARRAY(ENT_PDESCAD,BF) %IF R(1)=255 %OR E(1)=255 %THEN %RETURN;! no check %UNLESS R(0)=E(0) %THENSTART ER=323;! wrong no of args BAD: COM_PI21INT=REF_LINENO TFAULT(ER,ADDR(REF_NAME),0) %RETURN %FINISH %UNLESS R(1)=E(1) %THENSTART ER=324;! inconsistent subprog type ->BAD %FINISH I=R(0) %IF I>1 %THENSTART %CYCLE J=2,1,I %UNLESS R(J)=E(J) %OR (R(J)=6 %AND E(J)#5) %THENSTART ER=325;! non- correspondence of args ->BAD %FINISH %REPEAT %FINISH %END;! CHECK !* %END;! SAT REFS !* !* %EXTERNALROUTINE CODEGEN(%INTEGER CGENEP, %RECORD(TRIADF) %ARRAYNAME TRIADS, %INTEGER COMAD) %ROUTINESPEC RTERROR(%INTEGER ERR) %ROUTINESPEC SUBPROGEND %ROUTINESPEC IO PROC SWITCH %ROUTINESPEC DECLARE PLAB(%HALFINTEGER PTR) %INTEGERFNSPEC GET LABEL ADDRESS(%INTEGER LABTYPE,LABREC) %ROUTINESPEC ARR ACCESS(%HALFINTEGER INDEX,LHS) !* %INTEGER ADICT,ANAMES,CONTROL,OPTIONS1,OPTIONS2 %INTEGER I,J,K,M, OP, NEXT TRIAD, SAVE TRIAD %INTEGER GLAIOTABLE,NEXTPP,IOSTARTED %OWNINTEGER ATRIADS,RESULT WORDS,PARAM WORDS %OWNINTEGER LINENO WORD %HALFINTEGER EPILOGUE %INTEGER SPTR,ERRLAB,ENDLAB,IOSTATVAR %HALFINTEGER TCTBASE,IOMARKERS,IOKEY,IOINDEX,IIN,IORTNO %HALFINTEGER MODE,CONDMASK,EL LEN %INTEGER IODSNUM,PROCEP,PCUNASS %INTEGER ASSIGNED GOTOS,ASSIGNED LABS,NEXT ASS LAB %INTEGER STATFN ENTRY,STATFN REC,PCHARLIST %HALFINTEGERARRAY BLOCKIN(0:3) %RECORD(TMPF)%NAME TMP %RECORD(COMFMT)%NAME COM %RECORD(TRIADF)%NAME TR %RECORD(TRIADF)%NAME OLDTR %RECORD(LABRECF)%NAME LABREC %RECORD(PLABF)%NAME PLAB %RECORD(RESF) RES1 %RECORD(RESF) RES2 %RECORD(SRECF)%NAME SS %RECORD(PRECF)%NAME PP %RECORD(PRECF)%NAME STATFN %STRING(8) ID !* %INTEGERARRAY IOSTEPS(0:255),IOSTATS(0:255) %BYTEINTEGERARRAY TPLATE(0:257) !* !* %ROUTINESPEC ASSIGNED LIST %ROUTINESPEC COPYPARS(%INTEGER AREC,MODE) %ROUTINESPEC LOADDATA !* %OWNINTEGER ASL3 !* %INTEGERFN FREESP3 !*********************************************************************** !* OBTAIN 3-WORD(32 BIT) LIST ITEM * !*********************************************************************** %INTEGER PTR %RECORD(SRECF) %NAME SS PTR=ASL3 %IF PTR = 0 %THENSTART PTR = COM_DPTR SS == RECORD(COM_ADICT+PTR) !{2900C} COM_DPTR = COM_DPTR+12 {PERQC} COM_DPTR=COM_DPTR+6 DICFUL %IF COM_DPTR >= COM_DICLEN %FINISHELSESTART SS == RECORD(COM_ADICT+PTR) ASL3 = SS_LINK1 %FINISH SS_LINK1 = 0 %RESULT=PTR %END; ! FREESP3 !* %ROUTINE FREE LIST CELL3(%INTEGERNAME LISTHEAD) %INTEGER J %RECORD(SRECF) %NAME SS SS==RECORD(COM_ADICT+LISTHEAD) J=SS_LINK1;! NEW LISTHEAD SS_LINK1=ASL3 ASL3=LISTHEAD LISTHEAD=J %END;! FREE LIST CELL3 !* %INTEGERFN NEW LIST CELL3(%INTEGERNAME LISTHEAD) %INTEGER PTR %RECORD(SRECF) %NAME SS PTR=FREESP3 SS==RECORD(COM_ADICT+PTR) SS_LINK1=LISTHEAD LISTHEAD=PTR %RESULT=PTR %END;! NEW LIST CELL3 !* !* %ROUTINE DICT SPACE(%INTEGER LEN) %IF COM_DPTR+LEN>COM_DICLEN %THEN DICFUL %END;! DICT SPACE !* %INTEGERFN ADDR TRIAD(%INTEGER INDEX) %HALFINTEGER I,J,K %INTEGER AD {PERQC} I=40 {PERQC} J=INDEX//I {PERQC} K=J-(J//4)*4 {PERQC} AD=ATRIADS+K*256 {PERQC} %IF BLOCKIN(K)#J %THENSTART {PERQC}READ: READBLOCK(COM_TRFILEID,J,AD) {PERQC} %IF HALFINTEGER(AD+255)#J %THENSTART {PERQC} NEWLINE {PERQC} PRINTSTRING("Block ") {PERQC} WRITE(J,3) {PERQC} PRINTSTRING(" has not arrived. Current blocks: ") {PERQC} %CYCLE I=0,1,3 {PERQC} WRITE(HALFINTEGER(ATRIADS+I*256+255),4) {PERQC} %REPEAT {PERQC} NEWLINE {PERQC} ->READ {PERQC} %FINISH {PERQC} BLOCKIN(K)=J {PERQC} %FINISH {PERQC} %RESULT=AD+(INDEX-40*J)*6 !{2900C} %RESULT=ADDR(TRIADS(INDEX)) %END;! ADDR TRIAD !* !****************************************************************************** !* * !* EXPESSION EVALUATION * !* * !****************************************************************************** !* !* !* !* !* !* !*********************************************************************** !* Routines to process TMPID records - claim * !* release * !* alloc temp stack locations * !*********************************************************************** !* %ROUTINE ALLOC TEMP(%INTEGER AREC) !*********************************************************************** !* Allocate storage for a temporary if not set * !*********************************************************************** %RECORD(TMPF)%NAME TMP TMP==RECORD(ADICT+AREC) %IF TMP_ADDR=0 %THENSTART;! not yet allocated storage TMP_ADDR=STACKCA STACKCA=STACKCA+MODETOWORDS(TMP_MODE) %FINISH %IF TRACETEMP=YES %THENSTART PRINTSTRING(" Alloc temp:");WRITE(AREC,4);!DUMP(ADICT+AREC,12) %FINISH %END;! ALLOC TEMP !* %ROUTINE FREE TEMP(%INTEGER AREC) !*********************************************************************** !* release temporary scalar record * !*********************************************************************** !* %INTEGER MODE %RECORD(TMPF)%NAME TMP TMP==RECORD(ADICT+AREC) MODE=TMP_MODE TMP_LINK1=TEMPST(MODE) TEMPST(MODE)=AREC %IF TRACETEMP=YES %THENSTART PRINTSTRING(" Free temp:");WRITE(AREC,4);!DUMP(ADICT+AREC,12) %FINISH %END;! FREE TEMP !* %INTEGERFN GET TEMP(%INTEGER REG,MODE) !*********************************************************************** !* Get temp scalar DICT record * !* if use is to describe ACC (REG=1) or BREG (REG=2) then set REG and * !* MODE else (REG=0) alloc temp * !*********************************************************************** %INTEGER I,J %RECORD(TMPF)%NAME TMP J=TEMPST(MODE) %IF J#0 %THENSTART TMP==RECORD(ADICT+J) TEMPST(MODE)=TMP_LINK1 %FINISHELSESTART DICT SPACE(TMPRECSIZE) J=COM_DPTR COM_DPTR=COM_DPTR+TMPRECSIZE TMP==RECORD(ADICT+J) TMP_MODE=MODE TMP_ADDR=0 %FINISH TMP_REG=REG %IF REG=0 %THENSTART %IF TMP_ADDR=0 %THEN ALLOC TEMP(J) %FINISHELSESTART %IF REG=INACC %THENSTART ACCUSE=-1 ACCDESC=J %FINISH %FINISH %IF TRACETEMP=YES %THENSTART PRINTSTRING(" Get temp:");WRITE(REG,2);WRITE(MODE,2);WRITE(J,4);!DUMP(ADICT+J,12) %FINISH %RESULT=J %END;! GET TEMP !* !* !* !*********************************************************************** !* Routines to save and extract 'result descriptors' from triads * !*********************************************************************** !* %ROUTINE SAVE RES(%INTEGER FORM,OPD) !*********************************************************************** !* save r.d. in the current triad * !*********************************************************************** %RECORD(TRIADF)%NAME TR TR==RECORD(ADDR TRIAD(SAVETRIAD)) TR_QOPD1=FORM TR_OPD1=OPD TR_OP=NULL;! to indicate triad use to diagnostic utilities %END;! SAVE RES !* %INTEGERFN EXTRIAD(%HALFINTEGERNAME OPD,MODE,%HALFINTEGER LHS) !*********************************************************************** !* called when referenced item is a triad containing an r.d. * !*********************************************************************** %RECORD(TRIADF)%NAME TR TR==RECORD(ADDR TRIAD(OPD)) MODE=TR_MODE ! %IF TR_OP=ARR %OR TR_OP=ARR1 %THENSTART;! array element ! %RESULT=ARREL ! %FINISH OPD=TR_OPD1 %RESULT=TR_QOPD1 %END;! EXTRIAD !* !*********************************************************************** !* !* %ROUTINE LOAD ADDRESS(%RECORD(RESF) R) %RECORD(CONRECF)%NAME CON %RECORD(TMPF)%NAME TMP %RECORD(PRECF)%NAME PP %RECORD(PRECF)%NAME CMNBLK %RECORD(ARRAYDVF)%NAME DVREC %RECORD(SRECF)%NAME SS !* %HALFINTEGER D,MODE,LEN %INTEGER DISP,AD %SWITCH F(0:21) D=R_H0 PP==RECORD(ADICT+D) LOOP: ->F(R_FORM&X'FF') !* F(LIT): OP1(LDC0) LDC(D) LITAD:AD=GLA SPACE(4) STOD(AD) ->GLAAD !* F(NEGLIT): OP1(LDCMO) LDC(-D) ->LITAD !* F(CNSTID): CON==RECORD(ADICT+D) AD=ADICT+CON_DADDR OPW(LDDC,HALFINTEGER(AD+W1)) PWORD(HALFINTEGER(AD)) %IF CON_MODE=CMPLX8 %THENSTART OPW(LDDC,HALFINTEGER(AD+W3)) PWORD(HALFINTEGER(AD+W2)) LEN=8 %FINISHELSE LEN=4;! bytes needed AD=GLA SPACE(LEN) %IF LEN=8 %THEN STOD(AD+2) STOD(AD) ->GLAAD !* F(TRIAD): R_FORM=EXTRIAD(D,MODE,0) ->LOOP !* F(TMPID): !* F(PERMID): TMP==RECORD(ADICT+D) AD=TMP_ADDR LOCAD:OP1(LSSN) LLA(AD) %RETURN !* F(STKLIT): AD=D ->LOCAD !* F(LSCALID): AD=PP_ADDR4 ->LOCAD !* F(OSCALID): AD=PP_ADDR4 GLAAD:OP1(LSSN) LOA(AD) %RETURN !* F(GLALIT): AD=D ->GLAAD !* F(CSCALID): CMNBLK==RECORD(ADICT+PP_LINK3) DISP=PP_ADDR4 LOA(CMNBLK_CMNREFAD) OP1(LDDW) %IF DISP#0 %THENSTART %IF DISP<=X'FFFF' %THENSTART LDC(DISP) OP1(ADI) %FINISHELSESTART OPW(LDDC,DISP&X'FFFF') PWORD(DISP>>16) OP2(LOPS,ADDOP) %FINISH %FINISH %RETURN !* F(ASCALID): LOA(PP_DISP) OP1(LDDW) %RETURN !* F(ARRID): DVREC==RECORD(ADICT+PP_ADDR4) AD=DVREC_ADDRDV;! address of dope vector required ->GLAAD !* F(PROCID): AD=0 ->LOCAD !* F(ARREL): ARR ACCESS(D,1);! index to triad describing array element %RETURN %END;! LOAD ADDRESS !* %ROUTINE TEST UNASS OP3(REPL2,LDDC,X'80') OP3(X'80',X'80',X'80') OP2(LOPS,EQUOP) OPW(JTW,PCUNASS-CODECA-3) %END;! TEST UNASS !* %ROUTINE LOAD VAL(%RECORD(RESF) R) %RECORD(PRECF)%NAME PP %RECORD(PRECF)%NAME CMNBLK %RECORD(TMPF)%NAME TMP %RECORD(LABRECF)%NAME LAB %RECORD(CONRECF)%NAME CON %INTEGER AD %HALFINTEGER WORDS,P,D,OP,FORM,MODE %SWITCH F(0:20) D=R_H0 WORDS=MODETOWORDS(R_MODE);! 1, 2 or 4 FORM=R_FORM&X'FF';! for diagnostics LOOP: ->F(FORM) !* F(LIT): %IF WORDS=2 %THEN OP1(LDC0) LDC(D) %RETURN !* F(NEGLIT): %IF WORDS=2 %THEN OP1(LDCMO) LDC(-D) %RETURN !* F(CNSTID): CON==RECORD(ADICT+D) AD=ADICT+CON_DADDR %IF WORDS=2 %THENSTART OPW(LDDC,HALFINTEGER(AD+W1)) PWORD(HALFINTEGER(AD)) %RETURN %FINISH OPW(LDCW,HALFINTEGER(AD)) %RETURN !* F(TRIAD): FORM=EXTRIAD(D,MODE,0) ->LOOP !* F(TMPID): TMP==RECORD(ADICT+D) %UNLESS TMP_REG=2 %THEN FREETEMP(D);! unless temp is locked %IF TMP_REG=INACC %THEN %RETURN D=TMP_ADDR ->LOCAL !* F(PERMID): TMP==RECORD(ADICT+D) D=TMP_ADDR ->LOCAL !* F(LSCALID): PP==RECORD(ADICT+D) D=PP_ADDR4 F(STKLIT): LOCAL:%IF WORDS=2 %THEN LDL(D+1) LDL(D) %RETURN !* F(GLALIT): %IF WORDS=2 %THEN LDO(D+1) LDO(D) %RETURN !* F(OSCALID): PP==RECORD(ADICT+D) D=PP_ADDR4 %IF WORDS=2 %THEN LDO(D+1) LDO(D) TEST: %IF WORDS=2 %AND UNASSCHECKS=YES %THEN TEST UNASS %RETURN !* F(CSCALID): PP==RECORD(ADICT+D) CMNBLK==RECORD(ADICT+PP_LINK3) P=CMNBLK_CMNREFAD D=PP_ADDR4 CMNEL:LOA(P) OP1(LDDW) %IF D#0 %THENSTART LDC(D) OP1(ADI) %FINISH ->LD F(ARREL): ARR ACCESS(D,0) LD: %IF WORDS=2 %THEN OP=LDDW %ELSE OP=LDIND OP2(TLATE1,OP) ->TEST !* F(ASCALID): PP==RECORD(ADICT+D) P=PP_DISP D=0 ->CMNEL !* F(LABID): LAB==RECORD(ADICT+D) %RETURN !* F(PROCID): ! fn value D=0 ->LOCAL %END;! LOAD VAL !* %ROUTINE STORE VAL(%RECORD(RESF) R) %RECORD(PRECF)%NAME PP %RECORD(TMPF)%NAME TMP %RECORD(PRECF)%NAME CMNBLK %HALFINTEGER WORDS,D,P,OP %SWITCH F(0:20) D=R_H0 WORDS=MODETOWORDS(R_MODE) ->F(R_FORM&X'FF') !* F(TMPID): !* F(PERMID): TMP==RECORD(ADICT+D) %IF TMP_ADDR=0 %THEN ALLOC TEMP(D) TMP_REG=0 D=TMP_ADDR F(STKLIT): LOCAL:STL(D) %IF WORDS=2 %THEN STL(D+1) %RETURN !* F(LSCALID): PP==RECORD(ADICT+D) D=PP_ADDR4 ->LOCAL !* F(OSCALID): PP==RECORD(ADICT+D) D=PP_ADDR4 F(GLALIT): STO(D) %IF WORDS=2 %THEN STO(D+1) %RETURN !* F(CSCALID): PP==RECORD(ADICT+D) CMNBLK==RECORD(ADICT+PP_LINK3) P=CMNBLK_CMNREFAD D=PP_ADDR4 CMNEL:%IF WORDS#2 %THEN OP1(MMS) LOA(P) OP1(LDDW) %IF D#0 %THENSTART LDC(D) OP1(ADI) %FINISH %IF WORDS=2 %THENSTART OP3(EXCH2,TLATE3,STDW) %FINISHELSESTART;! 1 word OP3(MES,TLATE2,STIND) %FINISH %RETURN !* F(ARREL): %IF WORDS=2 %THENSTART OP2(TLATE3,STDW) %FINISHELSESTART OP2(TLATE2,STIND) %FINISH %RETURN !* F(ASCALID): PP==RECORD(ADICT+D) P=PP_DISP D=0 ->CMNEL !* F(PROCID): ! fn value D=0 ->LOCAL %END;! STORE VAL !* !* %ROUTINE FREEACC %RECORD(TMPF)%NAME TMP %HALFINTEGER WORDS,AD %IF ACCUSE<0 %THENSTART TMP==RECORD(ADICT+ACCDESC) ALLOC TEMP(ACCDESC);! ensure storage location is allocated TMP_REG=0;! value no longer in a reg WORDS=MODETOWORDS(TMP_MODE) AD=TMP_ADDR STL(AD) %IF WORDS=2 %THEN STL(AD+1) %FINISH ACCUSE=0 %END;! FREEACC !* !* %ROUTINE COERCE(%INTEGER OLDMODE, NEWMODE) !*********************************************************************** !* VALUE IN ACC IN OLDMODE * !* CONVERT TO VALUE OF FORM NEWMODE IN ACC * !* OLDMODE,NEWMODE 0 I*2 1 I*4 3 R*4 4 R*8 * !*********************************************************************** %INTEGER ACT %SWITCH A(0 : 25) ACT = OLDMODE*5+NEWMODE %UNLESS 0<=ACT<=25 %THEN %RETURN;! PREVIOUS (REPORTED) ERROR SWITCH: -> A(ACT) !* A(*): %RETURN !* A(1): ! I2 -> I4 OPB(LOPS,I2TOI4) %RETURN !* A(3): ! I2 -> R4 OPB(ROPS,FLT) %RETURN !* A(4): ! I2 -> R8 %RETURN !* A(5): ! I4 -> I2 OPB(LOPS,I4TOI2) %RETURN !* A(8): ! I4 -> R4 OPB(ATPB,2) OP1(MMS2) SYSCALL("FLOATLONG") OP1(MES2) %RETURN !* A(9): ! I4 -> R8 %RETURN !* A(15):! R4 -> I2 OPB(ROPS,TNC) %RETURN !* A(16):! R4 -> I4 OPB(ATPB,2) OP1(MMS2) SYSCALL("TRUNCLONG") OP1(MES2) %RETURN !* A(19):! R4 -> R8 %RETURN !* A(20):! R8 -> I2 %RETURN !* A(21):! R8 -> I4 %RETURN !* A(23):! R8 -> R4 %RETURN %END; ! COERCE !* %ROUTINESPEC COMPLEXOP(%HALFINTEGER OP,%RECORD(RESF) RESL,RESR) %ROUTINESPEC CHAROP(%RECORD(RESF) RESL,%INTEGER OP, %RECORD(RESF) RESR) !* %CONSTBYTEINTEGERARRAY SETMODE(0:63)= %C 0(5),10,0(11),1,3,6,1,0(12),2,4,7,2,0(13),5,8,1,0(11) !* %ROUTINE ASSIGN(%RECORD(RESF) RESL,RESR) !*********************************************************************** !* LHS = RHS (not complex) * !*********************************************************************** %HALFINTEGER I %RECORD(TMPF)%NAME TMP %IF RESL_MODE=CHARMODE %THENSTART CHAROP(RESL,7,RESR) %RETURN %FINISH %IF RESL_MODE=CMPLX8 %OR RESR_MODE=CMPLX8 %THENSTART COMPLEXOP(7,RESL,RESR) %RETURN %FINISH %IF RESL_FORM&X'FF'=ARREL %THENSTART ARR ACCESS(RESL_H0,1);! if array el then fetch address to stack %FINISHELSESTART %IF (RESL_FORM=CSCALID %OR RESL_FORM=ASCALID) %C %AND ACCUSE=0 %THENSTART LOAD ADDRESS(RESL) RESL_FORM=ARREL;! will indicate that LHS @ is in Estack %FINISH %FINISH %IF RESR_FORM&X'FF'=TRIAD %THEN RESR_FORM=EXTRIAD(RESR_H0,I,0) %IF ACCUSE#0 %THENSTART %IF RESR_FORM=TMPID %THENSTART TMP==RECORD(ADICT+RESR_H0) %UNLESS TMP_REG=INACC %THEN FREEACC %FINISHELSE FREEACC %FINISH LOAD VAL(RESR) %IF RESR_MODE#RESL_MODE %THEN COERCE(RESR_MODE,RESL_MODE) !* %IF RESL_FORM&X'FF'=NULL %THENSTART;! convert only SAVE RES(TMPID,GET TEMP(INACC,RESL_MODE)) %FINISHELSESTART STORE VAL(RESL) ACCUSE=0 %FINISH %RETURN !* %END;! ASSIGN !* %ROUTINE ARITHOPS(%HALFINTEGER OP,%RECORD(RESF) RESL,RESR) !*********************************************************************** !* OP 1 COMPARE * !* 2 + * !* 3 - * !* 4 * * !* 5 / * !* 6 UNARY - * !*********************************************************************** %CONSTBYTEINTEGERARRAY I2OP(0:12) = %C 0, 0, ADI, SBI, MPI, DVI, NGI, GTRI, LESI, NEQI, EQUI, GEQI, LEQI %CONSTBYTEINTEGERARRAY IR4OP(0:12) = %C 0,0,ADDOP,SUBOP,MULTOP,DIVOP,NEGOP, GTROP,LESOP,NEQOP,EQUOP,GEQOP,LEQOP %CONSTBYTEINTEGERARRAY REVCMP(0:5) = 1, 0, 2, 3, 5, 4 !* %ROUTINESPEC QOP(%HALFINTEGER OP,MODE) !* %HALFINTEGER LF,RF,MODE,I !* %IF RESL_FORM&X'FF'=TRIAD %THEN RESL_FORM=EXTRIAD(RESL_H0,I,0) %IF RESR_FORM&X'FF'=TRIAD %THEN RESR_FORM=EXTRIAD(RESR_H0,I,0) %IF RESL_MODE=CMPLX8 %OR (RESR_MODE=CMPLX8 %AND OP#6) %THENSTART COMPLEXOP(OP,RESL,RESR) %RETURN %FINISH LF=RESL_FORM&X'FF' RF=RESR_FORM&X'FF' MODE=RESL_MODE !* %IF ACCUSE=-1 %THENSTART;! some value in ESTACK %IF LF=TMPID %AND ACCDESC=RESL_H0 %AND RF#ARREL %THENSTART %IF OP=6 %THENSTART;! neg QOP(OP,MODE) ->SAVE %FINISH LOAD VAL(RESR) QOP(OP,MODE) %IF OP=1 %THEN ACCUSE=0 %AND FREETEMP(RESL_H0) SAVE: SAVERES(TMPID,ACCDESC) %RETURN;! with ACCDESC still locating the result %FINISH %IF RF=TMPID %AND ACCDESC=RESR_H0 %AND LF#ARREL %THENSTART LOAD VAL(RESL) %UNLESS OP=2 %OR OP=4 %THENSTART;! unless commutative %IF OP=1 %THENSTART;! for compare reverse the condition CONDMASK=REVCMP(CONDMASK) %FINISHELSESTART %IF MODE=INT2 %THEN I=EXCH %ELSE I=EXCH2 OP1(I);! to swap operands %FINISH %FINISH QOP(OP,MODE) %IF OP=1 %THENSTART ACCUSE=0 FREETEMP(RESR_H0) %RETURN %FINISHELSE ->SAVE %FINISH FREEACC %FINISH !* LOAD VAL(RESL) LOAD VAL(RESR) %UNLESS OP=6;! unless neg QOP(OP,MODE) %UNLESS OP=1 %THENSTART;! unless compare SAVERES(TMPID,GETTEMP(INACC,MODE)) %FINISH %RETURN !* %ROUTINE QOP(%HALFINTEGER OP,MODE) %HALFINTEGER I %IF OP=1 %THENSTART OP=CONDMASK+7 %FINISH %IF MODE=INT2 %THENSTART OP1(I2OP(OP)) %FINISHELSESTART %IF MODE=INT4 %THEN I=LOPS %ELSE I=ROPS OPB(I,IR4OP(OP)) %FINISH %END;! QOP !* %END;! ARITHOPS !* %ROUTINE EXPFN(%RECORD(RESF) RESL,RESR) !*********************************************************************** !* LHS ** RHS * !*********************************************************************** %HALFINTEGER OP,LF,RF,LMODE,RMODE,POWER,BASE,ABSPOWER,I %IF ACCUSE=-1 %THEN FREEACC %IF RESL_FORM&X'FF'=TRIAD %THEN RESL_FORM=EXTRIAD(RESL_H0,I,0) %IF RESR_FORM&X'FF'=TRIAD %THEN RESR_FORM=EXTRIAD(RESR_H0,I,0) %IF RESL_MODE>=CMPLX8 %THENSTART COMPLEXOP(8,RESL,RESR) %RETURN %FINISH LF=RESL_FORM&X'FF' RF=RESR_FORM&X'FF' LMODE=RESL_MODE RMODE=RESR_MODE %IF LMODE=REAL4 %THEN OP=ROPS %ELSE OP=LOPS LOAD VAL(RESL) %IF RF=LIT %AND RESR_H0=2 %THENSTART;! special case %IF LMODE=INT2 %THENSTART OP2(REPL,MPI) %FINISHELSESTART OP1(REPL2) OPB(OP,MULTOP) %FINISH SETRES: SAVE RES(TMPID,GETTEMP(INACC,LMODE)) %RETURN %FINISH %IF RMODE<=INT4 %THENSTART;! ** LOAD VAL(RESR) %IF RMODE=INT2 %THEN OPB(LOPS,I2TOI4) POWER=STACKCA ABSPOWER=STACKCA+2 BASE=STACKCA+4 STACKCA=STACKCA+6 OP1(REPL2) OPB(LOPS,ABSOP) STLD(ABSPOWER);! store local double STLD(POWER) STLD(BASE) %IF LMODE<=INT4 %THENSTART OP2(LDC0,LDC1);! int value 1 %FINISHELSESTART OPW(LDDC,X'3F80') PWORD(0);! real value 1.0 %FINISH LDLD(ABSPOWER) OP2(LDC0,LDC0) OPB(LOPS,EQUOP) OPB(JTB,27);! ** 0 ? OPW(LLAW,BASE); OP1(LDDW) OPB(OP,MULTOP) OPW(LLAW,ABSPOWER) OP3(LDDW,LDC0,LDC1) OP2(LOPS,SUBOP);! count=count-1 OP1(REPL2) OPW(STLW,ABSPOWER) OPW(STLW,ABSPOWER+1) OP2(LDC0,LDC0) OPB(LOPS,GTROP);! count>0 ? OPB(JTB,-27) OPW(LLAW,POWER) OP3(LDDW,LDC0,LDC0) OPB(LOPS,GEQOP);! power>=0 ? %IF LMODE<=INT4 %THENSTART OPB(JTB,6) OP3(MMS2,LDC0,LDC1) OP3(MES2,LOPS,DIVOP);! invert integer result %FINISHELSESTART OPB(JTB,9) OP1(MMS2) OPW(LDDC,X'3F80') PWORD(0) OP3(MES2,ROPS,DIVOP);! invert real result %FINISH ->SETRES %FINISHELSESTART;! ** OPB(ATPB,2);! reserve space for result OP1(MMS2) LOAD VAL(RESR) OP1(MMS2) SYSCALL("F77POWER") OP1(MES2) ->SETRES %FINISH %END;! EXPFN !* %ROUTINE ARR ACCESS(%HALFINTEGER INDEX,LHS) !*********************************************************************** !* load array element address to Estack (or @ desc for char) * !* LHS = 1 left hand side of assignment * !* 0 in expression * !* 2 store array element desc on Mstack (will not apply to char) * !* set EL LEN = element length or 0 (for *(*) ) if char * !*********************************************************************** %ROUTINESPEC CHECK SUB(%RECORD(RESF) R,%HALFINTEGER INDEX) %RECORD(TRIADF)%NAME TR %RECORD(ARRAYDVF)%NAME DVREC %RECORD(PRECF)%NAME ARRAYREC %RECORD(RESF)%ARRAY SUBSCRIPT(0:7) %RECORD(RESF) R %INTEGER PCT,I,J,K,L,PTR,CHAD %HALFINTEGER ADV,H,ADJ,TYPE %IF ACCUSE#0 %THEN FREEACC TR==RECORD(ADDR TRIAD(INDEX)) %IF TR_QOPD2=TRIAD %THEN TR_QOPD2=EXTRIAD(TR_OPD2,H,0) %IF TR_QOPD2=TMPID %AND ACCUSE#0 %THENSTART %IF ACCDESC=TR_OPD2 %THEN FREEACC %FINISH ARRAYREC==RECORD(ADICT+TR_OPD1) DVREC==RECORD(ADICT+ARRAYREC_ADDR4) ADJ=ARRAYREC_CLASS&X'C0';! non-zero if adjustable TYPE=ARRAYREC_TYPE %IF TYPE=5 %THENSTART K=2 CHAD=GLA SPACE(12);! for modified char desc %FINISHELSE K=-2 PCT=DVREC_DIMS ADV=DVREC_ADDRDV %IF LHS=2 %THENSTART;! param required OP3(LDTP,ATPB,2) %FINISH %IF TYPE=5 %THENSTART LOA(CHAD) LOA(ADV) OPB(MOVB,6) %FINISHELSESTART LOA(ADV);! @ of dv in global OP1(LDDW);! array base @ %FINISH %IF TR_OP=ARR %AND TR_QOPD2=LIT %AND ADJ=0 %THENSTART;! must be short I=TR_OPD2-DVREC_ZEROTOFIRST %IF I=0 %THENSTART %IF LHS=2 %THENSTART;! cannot apply to char LOA(ADV+2) OP3(LDDW,MMS2,STDW) %FINISH %IF TYPE=5 %THEN LOA(CHAD) %RETURN %FINISHELSE LDC(I) %FINISHELSESTART %IF TR_OP=ARR %THENSTART LOAD VAL(TR_RES2) OP2(LOPS,I4TOI2) %FINISHELSESTART J=ADICT+TR_OPD2 %CYCLE I=1,1,PCT SUBSCRIPT(I)_W=INTEGER(J) J=J+W2 %REPEAT %IF ARRAYREC_TYPE=5 %THEN K=2 %ELSE K=-2 CHECK SUB(SUBSCRIPT(1),1) %IF PCT>1 %THENSTART %CYCLE I=2,1,PCT CHECK SUB(SUBSCRIPT(I),I) J=DVREC_B(I-1)_M %IF 0 len %FINISH %FINISH OP1(STIND) %FINISH !* %IF RESL_FORM#NULL %THENSTART;! unless (: OP2(REPL,REPL2);! 3 words to be updated OP2(LDC3,ADI);! @ len %IF RESL_FORM=LIT %THENSTART LDC(RESL_H0-1) %FINISHELSESTART LOAD VAL(RESL) COERCE(RESL_MODE,INT2) OP2(LDC1,SBI) %FINISH %IF (RESL_FORM#LIT %OR RESR_FORM#LIT %OR MAXLEN=0) %C %AND CHARCHECKS=YES %THENSTART %IF RESL_FORM#LIT %THENSTART;! check lower OP2(REPL,LDC0) OP1(LESI) RTERROR(CHARFAULT);! if lhs <= 0 %FINISH OP3(REPL2,EXCH,LDIND) OP1(GEQI) RTERROR(CHARFAULT);! lhs > len %FINISH OP3(REPL,REPL,MMS2) OP3(MMS,REPL,LDIND) OP3(MES,SBI,STIND);! len = len - lhs OP3(LDC2,ADI,REPL) OP1(LDIND) OP3(MES,ADI,STIND);! disp = disp + lhs OP3(LDC4,ADI,REPL) OP1(LDIND) OP3(MES,SBI,STIND);! balance = balance - lhs %FINISH !* %RESULT=0;! provide actual length if known !* %END;! CHAR SUBSTRING !* %HALFINTEGERFNSPEC LOCATE CHAR DESC(%RECORD(RESF) R,%HALFINTEGER INDEX) !* %INTEGERFN CONCAT CHARS(%HALFINTEGER LINK,%RECORD(RESF) CHRES, %HALFINTEGER MODE) %INTEGER AD,ADESCS,I,J,LEN,STARLEN,RDESC,NUM %RECORD(TRIADF)%NAME TR STARLEN=0 LEN=0 NUM=1 I=LINK %WHILE I#0 %CYCLE TR==RECORD(ADDR TRIAD(I)) NUM=NUM+1 I=TR_OPD1 %REPEAT AD=GLA SPACE(NUM*4+8);! claim space for descriptors ADESCS=AD+4 LDCD(NUM) STOD(AD) OP1(LSSN) LOA(ADESCS) STOD(AD+2) OP1(LSSN) J=LOCATE CHAR DESC(CHRES,0) %IF EL LEN>0 %THEN LEN=LEN+EL LEN %ELSE STARLEN=1 STOD(ADESCS) I=LINK %WHILE I#0 %CYCLE TR==RECORD(ADDR TRIAD(I)) ADESCS=ADESCS+2 OP1(LSSN) J=LOCATE CHAR DESC(TR_RES2,0) %IF EL LEN>0 %THEN LEN=LEN+EL LEN %ELSE STARLEN=1 STOD(ADESCS) I=TR_OPD1 %REPEAT %IF MODE#0 %THENSTART LOA(AD);! @ of count and desc @s %RESULT=1 %FINISH !* %IF STARLEN#0 %THEN LEN=MAXCHARSIZE RDESC=ALLOC CHAR(LEN,0,IIN,J) OPB(ATPB,1);! for actual length OP3(LDTP,ATPB,4) LOA(RDESC) OPB(MOVB,4) OP3(LDTP,ATPB,4) LOA(AD);! count, @ descs OPB(MOVB,4) OP2(LDC0,MMS) SYSCALL("F77CONCAT") LOA(RDESC) LOA(RDESC+3) OP3(MES,REPL,MMS) OP1(STIND) LOA(RDESC+4) OP2(MES,STIND);! modify length to actual %RESULT=0 %END;! CONCAT CHARS !* %HALFINTEGERFN LOCATE CHAR DESC(%RECORD(RESF) R,%HALFINTEGER MODE) !*********************************************************************** !* MODE = 0 Estack to hold a pointer to desc of char * !* 1 Estack to hold a pointer to desc or concat list * !* result = 0 pointer is to desc of result * !* 1 pointer is to a concat list * !*********************************************************************** %RECORD(TRIADF)%NAME TR,TR2 %HALFINTEGER LEN %IF R_FORM=TRIAD %THENSTART TR==RECORD(ADDR TRIAD(R_H0)) %IF TR_OP=CHHEAD %THENSTART;! concat list LEN=CONCAT CHARS(TR_OPD1,TR_RES2,MODE) %RESULT=MODE %FINISHELSESTART %IF TR_OP=CHAR %AND TR_QOPD2#NULL %THENSTART;! substring TR2==RECORD(ADDR TRIAD(TR_OPD2)) LEN=CHAR SUBSTRING(TR_RES1,TR2_RES1,TR2_RES2) %RESULT=0 %FINISH %FINISH %IF TR_OP=NULL %THEN R=TR_RES1;! fn result %FINISH LEN=SET CHAR DESC(R,0) %RESULT=0 %END;! LOCATE CHAR DESC !* %ROUTINE CHAROP(%RECORD(RESF) RESL,%INTEGER OP,%RECORD(RESF) RESR) %HALFINTEGER I,MODE,LEN %IF ACCUSE#0 %THEN FREEACC %IF OP=1 %THENSTART OPB(ATPB,2) LDC(CONDMASK) OP1(MMS) %FINISHELSE OPB(ATPB,1) OP3(LDTP,ATPB,4) %IF OP=7 %AND RESL_FORM=PROCID %THENSTART;! lhs procid desc is at local 0 LLA(0) %FINISHELSE I=LOCATE CHAR DESC(RESL,0) OP2(MOVB,4);! lhs to stack OP3(LDTP,ATPB,4) %IF OP=1 %THEN MODE=0 %ELSE MODE=1 I=LOCATE CHAR DESC(RESR,MODE);! result is 1 if concat OP2(MOVB,4) %IF OP=1 %THENSTART;! comparison SYSCALL("F77CHREL") OP2(MES2,NEQI);! will set appropriate result condition %FINISHELSESTART %IF I=0 %THENSTART;! simple assign SYSCALL("F77COPY") %FINISHELSESTART OP2(LDC1,MMS);! request space filling SYSCALL("F77CONCAT") %FINISH OPB(ATPB,-1) %FINISH %END;! CHAROP !* !* %ROUTINESPEC INLINE1(%INTEGER FNTYPE,INDEX,PCT,%RECORD(RESF) PARAMRES) !* !* !* %ROUTINE SET PARAM(%INTEGER FNPTR,%RECORD(RESF) RD,%HALFINTEGER FNTYPE) !*********************************************************************** !* FOLLOWING EVALUATION OF A PARAMETER PLANT AN APPROPRIATE DESCRIPTOR* !* ON THE STACK, STORING ACC OR MOVING CONSTS IF NECESSARY * !*********************************************************************** %ROUTINESPEC ADD PAR(%INTEGER PDESC,PREC) %HALFINTEGER A, FORM, SIZE, TYPE, MODE %INTEGER OP, BYTES, DESC INDEX, FN %HALFINTEGER I,J,K,LOOP,PASCALPROC,PARAMDESC,IIN %INTEGER NUMELS,AD,II;! allow 32 bit value %BYTEINTEGERARRAY PDESC(0:1) %RECORD(PRECF)%NAME PP %RECORD(SRECF)%NAME SS %RECORD(PRECF)%NAME CMNEL %RECORD(PRECF)%NAME CMNBLK %RECORD(ARRAYDVF)%NAME DVREC %RECORD(TMPF)%NAME TMP %RECORD(CONRECF)%NAME CON %RECORD(CHARF)%NAME CH %SWITCH F(0 : 22) !* FORM = RD_FORM&X'FF'; ! RD FORMAT A = RD_H0; ! INFO FIELD MODE = RD_MODE RESET:TYPE = MODETOST(MODE)&X'F' SIZE = MODETOST(MODE)>>4 BYTES = MODETOBYTES(MODE) PP==RECORD(ADICT+FNPTR);! RECORD FOR FN %IF PP_X0&X'80'#0 %THEN PASCALPROC=YES %ELSE PASCALPROC=NO MODE=0;! to avoid unass check prior to exit PARAMDESC=MODETOST(RD_MODE) %IF RD_MODE=CHARMODE %THENSTART %IF PASCALPROC=NO %THEN OP3(LDTP,ATPB,6) I=LOCATE CHAR DESC(RD,0);! desc to char item now in Estack %IF PASCALPROC=YES %THENSTART K=FREESP3 SS==RECORD(ADICT+K) SS_LINK1=PCHARLIST PCHARLIST=K J=GLA SPACE(8);! for @ of char desc SS_INF0=J;! gla loc of @ of source char desc OP3(REPL,LSSN,EXCH) STOD(J) I=ALLOC CHAR(256,0,IIN,AD) SS_INF2=I;! @ of Pascal char desc LDC(256) STO(I+3);! refresh to ensure correct F77PCHAR action LOA(I) OP2(LDDW,MMS2);! param to Pascal proc OP1(LSSN) LOA(I) OP1(MMS2) OP3(LSSN,EXCH,MMS2) SYSCALL("F77PCHAR") STACKFRAME=STACKFRAME+2 ->ADPAR %FINISH OPB(MOVB,6) STACKFRAME=STACKFRAME+6 ->ADPAR %FINISH NUMELS=1 -> F(FORM) !* !****** CONST RECORD F(CNSTID): CON == RECORD(ADICT+A) MODE=CON_MODE BYTES=MODETOBYTES(MODE) %IF MODE=HOLMODE %THENSTART;! char or Holerith I=INTEGER(ADICT+CON_DADDR) K=CON_DADDR+W2 PARAMDESC=6 I=ALLOC CHAR(I,K,IIN,AD) LOA(I);! @ of char descriptor OP1(LDDW) ->SET SC %FINISH !* !****** SHORT LITERAL F(LIT): !****** negative literal F(NEGLIT): !****** local F(LSCALID): !****** scalar in global area F(OSCALID): !****** DICT RECORD FOR SCALAR IN COMMON F(CSCALID): !****** SCALAR IN ARRAY AREA F(ASCALID): !****** explicit stack location F(STKLIT): !****** explicit gla location F(GLALIT): SCALAD:LOAD ADDRESS(RD) SETSC:OP1(MMS2) %IF FNTYPE<=1 %AND PASCALPROC=NO %THENSTART;! USER OR OUT OF LINE FN OP3(LDC0,LDC1,MMS2);! single element STACKFRAME=STACKFRAME+4 %FINISHELSE STACKFRAME=STACKFRAME+2 ADPAR:%IF FNTYPE=0 %THEN ADD PAR(PARAMDESC,FNPTR);! for user subprogs only %RETURN !* !****** in temporary F(TMPID): FREETEMP(A);! this call only modifies _LINK ->SCALAD !* !* !****** triad F(TRIAD):FORM=EXTRIAD(A,MODE,0) ->RESET !* !* !****** SPECIAL IDENS F(ARRID): PP == RECORD(ADICT+A<1 %THENSTART OPB(ATPB,-2) STACKFRAME=STACKFRAME-2 %FINISH ->ADPAR !* !****** Subprogram identifier F(PROCID): PP==RECORD(ADICT+A) I=PP_CLASS&X'1F' PARAMDESC=X'80';! must be a subprog %IF I = 8 %THENSTART; ! EXTERNAL SUBPROG %IF PP_X0&7=6 %THENSTART;! intrinsic fn II=PP_LINK2;! fn details J=(II>>20)&X'F';! parameter mode FN=II>>24 %IF FN<=24 %THENSTART ID=VARIANT(J).GEN NAME(FN) %FINISHELSESTART ID=STRING(ANAMES+PP_IDEN) %FINISH ID="F77".ID QPUT(12,1,CODECA,ADDR(ID)) OPW(LVRD,1) OP2(0,0) %FINISHELSESTART;! load variable routine descriptor PDESC(0)=1 PDESC(1)=255 I=NOTE REF(STRING(ANAMES+PP_IDEN),CODECA,LINEST, 1,1,ADDR(PDESC(0))) OPBBB(LVRD,1,0,0) OP1(0) %FINISH OP2(MMS2,MMS2) %FINISHELSESTART; ! PARAM SUBPROG OP1(LSSN) LOA(PP_ADDR4);! address of variable routine desc (param) MOVE TO MS(4) %FINISH STACKFRAME=STACKFRAME+4 ->ADPAR !* !****** ARRAY ELEMENT F(ARREL): ARR ACCESS(RD_H0,2);! compute address of array element and store ! on Mstack with balance of number of els STACKFRAME=STACKFRAME+4 ->TESTP !* !* %ROUTINE ADD PAR(%INTEGER PDESC,PREC) %INTEGER I %RECORD(SRECF)%NAME HEAD %RECORD(SRECF)%NAME TAIL %RECORD(SRECF)%NAME CUR %IF CALLSPEC=NO %THEN %RETURN I=FREESP3 HEAD==RECORD(ADICT+PROC PARLIST) %IF HEAD_INF2=0 %THENSTART;! first param HEAD_INF0=I %FINISHELSESTART TAIL==RECORD(ADICT+HEAD_INF2) TAIL_LINK1=I %FINISH HEAD_INF2=I CUR==RECORD(ADICT+I) CUR_INF0=PDESC CUR_INF2=PREC %END;! ADD PAR %END; ! SET PARAM !* !* %ROUTINE START PAR %RECORD(SRECF)%NAME SS %IF CALLSPEC=NO %THEN %RETURN SS==RECORD(ADICT+NEWLISTCELL3(PROCPARLIST)) SS_INF0=0 SS_INF2=0 %END;! START PAR !* %ROUTINE CALL SUBPROG(%HALFINTEGER SUB,FPTR,PCT,PLINK) %INTEGERFNSPEC SET CALL TEMPLATE(%INTEGER AREC,FN,STDFN) %RECORD(PRECF)%NAME FN %BYTEINTEGERARRAY T(0:257) %RECORD(RESF) R %RECORD(TRIADF)%NAME TR %RECORD(CHARF)%NAME CH %RECORD(SRECF)%NAME SS %HALFINTEGER I,J,K,P2,PTR,RESLOC,RESWORDS,PCOUNT,IIN %INTEGER II %INTEGER AD %SWITCH C(0:3) !* PCHARLIST=0;! list of char params to a Pascal proc FREE ACC;! to ensure all temps stored FN == RECORD(ADICT+FPTR) %IF SUB=YES %OR FN_CLASS = 9 %THEN P2 = 0 %ELSE P2 = FN_X0&3 %IF P2<2 %THENSTART %IF SUB=NO %THENSTART;! reserve fn result space RESWORDS=0 I=FN_TYPE&15 %IF I=CHARTYPE %THENSTART;! alloc space and set 4-word desc RESLOC=ALLOC CHAR(FN_LEN,0,IIN,AD) OP3(LDTP,ATPB,4) LOA(RESLOC) OPB(MOVB,4);! copy desc as first(extra) param %FINISHELSESTART %IF I=CMPLXTYPE %THENSTART;! alloc space on local stack RESLOC=STACKCA STACKCA=STACKCA+4 RESWORDS=4 %FINISHELSESTART I=FN_TYPE RESWORDS=1<<(I>>4-4);! 1,2, or 4 words %FINISH OPB(ATPB,RESWORDS);! reserve result space %FINISH %FINISH %IF P2=0 %THEN START PAR %FINISH STACKFRAME=0 !* I=PCT %UNLESS P2=3 %AND PCT=1 %THENSTART %WHILE PLINK#NULL %CYCLE %IF P2=2 %AND I=1 %THEN %EXIT TR==RECORD(ADDR TRIAD(PLINK)) SET PARAM(FPTR,TR_RES1,P2) PLINK=TR_OPD2 I=I-1 %REPEAT %FINISH !* %IF P2#2 %THEN FREE ACC ->C(P2) !* C(2): ! in-line fn C(3): ! MAX/MIN TR==RECORD(ADDR TRIAD(PLINK)) %IF FN_LINK2>>16&X'FFF0'=X'8C60' %THENSTART;! ABS( ) OPB(ATPB,2) SET PARAM(FPTR,TR_RES1,P2) SYSCALL("F77CABS") RESWORDS=2 K=REALTYPE ->SETRES %FINISH INLINE1(2,FN_LINK2,PCT,TR_RES1) %RETURN !* C(1): ! INTRINSIC FNS REQUIRING A CALL II=FN_LINK2;! FN DETAILS K=FN_TYPE&15 J=II>>20&X'F';! PARAMETER MODE SYSCALL("F77".VARIANT(J).GEN NAME(II>>24)) ->SET RES !* C(0): ! user or intrinsic procedure call required K = FN_TYPE&15 J=SET CALL TEMPLATE(FPTR,SUB,0);! P1 = @ proc record P4 = 0 if fn else #0 result is YES (1) if param desc set %IF FN_CLASS = 8 %THENSTART;! STANDARD CALL %IF FN_X0&X'80'#0 %THEN I=2 %ELSE I=0 I=NOTE REF(STRING(ANAMES+FN_IDEN),CODECA,LINEST, I,PCOUNT,ADDR(T(0))) OPBBB(CALLXW,1,0,0) %FINISHELSESTART; ! SUBPROG IS A PARAM USER CALL(FN_ADDR4);! call variable routine %FINISH SETRES: %IF SUB=NO %THENSTART;! SET RESULT DESCRIPTOR FOR FUNCTION RESULT %IF K=CHARTYPE %THENSTART OPB(ATPB,-4) SAVE RES(GLALIT,RESLOC) %FINISHELSESTART %IF K#CMPLXTYPE %THENSTART; ! NOT COMPLEX %IF K=INTTYPE %THEN I=INT4 %ELSESTART %IF K=REALTYPE %THEN I=REAL4 %ELSE I=LOG4 %FINISH SAVE RES(TMPID,GET TEMP(INACC,I)>>DSCALE) %IF RESWORDS=1 %THEN OP=MES %ELSE OP=MES2 OP1(OP) %IF RESWORDS=4 %THEN OP1(MES2);! R*8 %FINISHELSESTART;! copy back to temp location reserved on stack LLA(RESLOC) OP3(REPL,LDC2,ADI);! @ complex part OP2(MES2,STDW);! copy back complex part OP2(MES2,STDW);! copy back real part SAVE RES(STKLIT,RESLOC) %FINISH %FINISH %FINISH %WHILE PCHARLIST#0 %CYCLE;! through list of char params to a Pascal prc SS==RECORD(ADICT+PCHARLIST) LDOD(SS_INF0);! @ of char desc OP1(MMS2) J=SS_INF2;! @ of Pascal string desc OP1(LSSN) LOA(J) OP1(MMS2) OP1(LDCMO) STO(J+3);! length in source desc is treated as a flag (len in first byte) SYSCALL("F77PCHAR") PCHARLIST=SS_LINK1 %REPEAT %RETURN !* %INTEGERFN SET CALL TEMPLATE(%INTEGER AREC,FN,STDFN) %INTEGER I,J,NEXT %INTEGERARRAY CREC(0:10) %RECORD(PRECF)%NAME PROC %RECORD(PRECF)%NAME PP %RECORD(SRECF)%NAME HEAD %RECORD(SRECF)%NAME SS %IF CALLSPEC=NO %THEN %RESULT=NO PROC==RECORD(ADICT+AREC) %IF FN=0 %THEN I=PROC_TYPE %ELSE I=0 T(1)=I HEAD==RECORD(ADICT+PROC PARLIST) NEXT=HEAD_INF0 FREE LIST CELL3(PROC PARLIST) PCOUNT=1 %WHILE NEXT#0 %CYCLE SS==RECORD(ADICT+NEXT) PCOUNT=PCOUNT+1 %IF PCOUNT<256 %THEN T(PCOUNT)=SS_INF0 FREE LIST CELL3(NEXT) %REPEAT %IF PCOUNT>255 %THEN PCOUNT=255 %IF STDFN=YES %THEN %RESULT=NO;! has served to free list cells T(0)=PCOUNT !***************************** RECORD PARAM DESC LIST SUBS CHECKING %RESULT=YES %END;! SET TEMPLATE !* %END;! CALL SUBPROG !* !* !* %ROUTINE SETCA(%INTEGER I) !*********************************************************************** !* FILL IN ADDRESSES FOR CONDITIONAL BRANCHES * !*********************************************************************** %RECORD(SRECF)%NAME SSS %WHILE I#0 %CYCLE SSS==RECORD(ADICT+I) FILL JUMP(SSS_INF0);! SET FORWARD BRANCH I=SSS_LINK1 %REPEAT %END;! SETCA !* !* %INTEGERFN SIMPLE INT(%RECORD(RESF) R) !*********************************************************************** !* Ensure that any integer expressions requiring DR are loaded and * !* that the result is a simple integer value * !*********************************************************************** %IF R_W=0 %THEN %RESULT=0 %IF R_MODE # INT4 %OR R_FORM&X'FF' = ARREL %THENSTART !! FORCED LOAD(INACC,R_FORM,R_H0,R_MODE,INT4);! load to acc as simple int %RESULT=RES_W %FINISHELSE %RESULT=R_W %END;! SIMPLE INT !* %ROUTINE RTERROR(%INTEGER ER) !* if ETOS is true then report run-time error OPB(JFB,7) {jump if false 7 bytes} OPW(LDCW,ER) {3 bytes} OP1(MMS) {1 byte} SYSCALL("F77RTERR") {3 bytes} %END;! RTERROR !* !* %ROUTINE SET LINE NO(%INTEGER STAT) %HALFINTEGER I %INTEGER AD ! %IF CHECKS=NO %THENSTART ! %IF STATMAPINDEX=32 %THENSTART ! %IF CURSTATMAP#0 %THENSTART ! INTEGER(ADICT+CURSTATMAP)=COM_DPTR ! %FINISHELSE STATMAPHEAD=COM_DPTR ! CURSTATMAP=COM_DPTR ! COM_DPTR=COM_DPTR+W66 ! INTEGER(ADICT+CURSTATMAP)=0 ! STATMAPINDEX=0 ! %FINISH ! STATMAPINDEX=STATMAPINDEX+1 ! AD=ADICT+CURSTATMAP+STATMAPINDEX*W2 ! HALFINTEGER(AD)=CODECA ! HALFINTEGER(AD+W1)=STAT-COM_FIRSTSTATNUM;! STATEMENT NOS NOW RECORDED RELATIVE TO FIRST ! STATCOUNT=STATCOUNT+1 ! %FINISHELSESTART;! UPDATE DYNAMICALLY %IF COM_SFMK=0 %THENSTART LDC(STAT) STL(LINENO WORD) %FINISH ! %FINISH %END;! SET LINE NO !* !* !* %ROUTINE INLINE1(%INTEGER FNTYPE,FNDETAILS,PCT,%RECORD(RESF) PARAMRES) %INTEGER I,J,K,L,M %HALFINTEGER OP,FNCODE,PMODE,FMODE %INTEGER PTR %RECORD(PRECF)%NAME PP %RECORD(SRECF)%NAME SS %RECORD(TMPF)%NAME TMP %RECORD(CHARF)%NAME CH %SWITCH FN(0:28) FN CODE=FN DETAILS>>24&X'7F' PMODE=FN DETAILS>>20&X'F' FMODE=FN DETAILS>>16&X'F' %UNLESS PARAMRES_MODE>=6 %OR 17<=FNCODE<=22 %THENSTART %IF FNTYPE=2 %OR (FNCODE<6 %AND PMODE<6) %THENSTART;! EXCEPT FOR MAX,MIN LOAD VAL(PARAMRES) %FINISH %FINISH ->FN(FN CODE) !* FN(1): ! INT + IFIX,IDINT !* FN(2): ! HFIX !* FN(4): ! DBLE + DFLOAT !* FN(5): ! QEXT !* FN(3): ! REAL + FLOAT,SNGL %IF PMODE<6 %THENSTART;! EXCEPT COMPLEX SIMPLE: COERCE(PMODE,FMODE) ->SETRES1 %FINISH !* FN(26): ! CONJG + DCONJG LOAD ADDRESS(PARAMRES) %IF FN CODE<6 %THENSTART OP2(TLATE1,LDDW) COERCE(PMODE-3,FMODE) ->SETRES2 %FINISH I=GET TEMP(0,CMPLX8) TMP==RECORD(ADICT+I) OP3(REPL2,TLATE1,LDDW) STLD(TMP_ADDR);! store R part OP2(LDC2,ADI);! address I part OP2(TLATE1,LDDW) OPB(ROPS,NEGOP) STLD(TMP_ADDR+2);! store I part CRES: SAVERES(TMPID,I) %RETURN !* FN(25): ! IMAG + AIMAG LOAD ADDRESS(PARAMRES) OP2(LDC2,ADI) OP2(TLATE1,LDDW) FMODE=REAL4 ->SETRES2 !* FN(6): ! CMPLX + DCMPLX FMODE=CMPLX8 I=GET TEMP(0,CMPLX8) TMP==RECORD(ADICT+I) COERCE(PMODE,REAL4) %IF PCT=1 %THENSTART;! special case STLD(TMP_ADDR) OP2(LDC0,LDC0) STLD(TMP_ADDR+2) ->CRES %FINISH STLD(TMP_ADDR+2) OP3(MES2,TLATE1,LDDW) COERCE(PMODE,REAL4) STLD(TMP_ADDR) ->CRES !* FN(10): ! ANINT !* FN(11): ! NINT OP3(ATPB,2,MMS2) SYSCALL("ROUNDLONG") OP1(MES2) %IF FNCODE=10 %THENSTART OP3(ATPB,2,MMS2) SYSCALL("FLOATLONG");! ANINT OP1(MES2) %FINISH ->SETRES1 !* FN(9): ! AINIT + DINT OP3(ATPB,4,MMS2) SYSCALL("TRUNCLONG") SYSCALL("FLOATLONG") OP1(MES2) ->SETRES1 !* FN(12): ! ABS + IABS,DABS %IF PMODE=INT2 %THENSTART OP1(ABI) %RETURN %FINISH %IF PMODE<3 %THEN OP=LOPS %ELSE OP=ROPS OPB(OP,ABSOP) ->SETRES1 !* FN(13): ! MOD + AMOD,DMOD OP2(MES2,TLATE1) %IF PMODE<3 %THENSTART;! int %IF PMODE=INT2 %THENSTART OP3(LDIND,EXCH,MODI) %FINISHELSESTART OP2(LDDW,EXCH2) OPB(LOPS,MODOP) %FINISH %FINISHELSESTART OP3(LDDW,EXCH2,REPL2);! a1,a2,a2 OP3(MMS2,MMS2,REPL2);! a1,a1 ... a2,a2 OP3(MES2,ROPS,DIVOP);! a1/a2 OP3(ATPB,4,MMS2) SYSCALL("TRUNCLONG") SYSCALL("FLOATLONG") OP1(MES2) OP3(MES2,ROPS,MULTOP);! int(a1/a2)*a2 OPB(ROPS,SUBOP);! a1-int(a1/a2)*a2 %FINISH -> SETRES2 !* FN(14): ! SIGN + ISIGN,DSIGN OP2(MES2,TLATE1) %IF PMODE=INT2 %THENSTART OP3(LDIND,ABI,EXCH);! abs(a1),a2 OP2(LDC0,LESI);! a2<0 ? OP3(JFB,1,NGI);! if true -abs(a1) %FINISHELSESTART %IF PMODE=INT4 %THEN OP=LOPS %ELSE OP=ROPS OP3(LDDW,OP,ABSOP);! a2,abs(a1) OP3(EXCH2,LDC0,LDC0);! abs(a1),a2,0 OPB(OP,LESOP) OPB(JFB,2) OPB(OP,NEGOP) %FINISH -> SETRES2 !* FN(15): ! DIM + IDIM,DDIM OP2(MES2,TLATE1) %IF PMODE=INT2 %THENSTART OP3(LDIND,EXCH,SBI);! a1-a2 OP3(REPL,LDC0,LESI);! a1-a2,(a1-a2)<0 ? OPB(JFB,2) OP2(REPL,SBI);! 0 if a1-a2<0 %FINISHELSESTART %IF PMODE=INT4 %THEN OP=LOPS %ELSE OP=ROPS OP2(LDDW,EXCH2) OP3(OP,SUBOP,REPL2);! a1-a2,a1-a2 OP2(LDC0,LDC0) OP2(OP,LESOP);! a1-a2,(a1-a2)<0 ? OP2(JFB,3) OP3(REPL2,OP,SUBOP);! 0 if a1-a2<0 %FINISH ->SETRES2 !* FN(16): ! DPROD !******************************* R * R **************** ->SETRES1 !* FN(17): ! MAX + MAX0,AMAX1,DMAX1 !* FN(18): ! AMAX0 !* FN(19): ! MAX1 !* L=GTROP ->MAXMIN !* FN(20): ! MIN + MIN0,AMIN1,DMIN1 !* FN(21): ! AMIN0 !* FN(22): ! MIN1 !* L=LESOP MAXMIN:J=PCT-1;! NO. OF PARAMS - 1 %IF PMODE<3 %THEN OP=LOPS %ELSE OP=ROPS;! int or real OP3(MES2,TLATE1,LDDW);! first value %WHILE J>0 %CYCLE OP3(REPL2,MES2,TLATE1) OP3(LDDW,REPL2,MMS2);! copy of latest value OP2(OP,L);! lops/rops gtrop/lesop OP2(JTB,6);! old value is best OP1(MMS2) OPB(ATPB,-2);! lose old value OP1(MES2);! and use new value OP2(JMPB,2);! to process next OPB(ATPB,-2);! lose new value J=J-1 %REPEAT COERCE(PMODE,FMODE) SETRES1: SETRES2: ACCDESC=GET TEMP(INACC,FMODE) ACCUSE=-1 SAVERES(TMPID,ACCDESC) %RETURN !* FN(7): ! ICHAR OP1(LDC0) I=LOCATE CHAR DESC(PARAMRES,0) OP3(REPL,LDC2,IXA1) OP3(LDIND,MMS,LDDW) OP3(MES,TLATE2,LDB);! load first char ->SETRES2 !* FN(8): !CHAR I=STACKCA OP1(LSSN) LLA(I+6) STLD(I);! @ of char base OP2(LDC1,LDC0) STLD(I+2);! disp, num chars OP2(LDC0,LDC1) STLD(I+4);! num chars OPB(LOPS,I4TOI2) STL(I+6);! the char (giving effect since least sig byte) STACKCA=STACKCA+7 SAVERES(STKLIT,I) %RETURN !* FN(23): ! LEN OP1(LDC0) I=LOCATE CHAR DESC(PARAMRES,0) OP3(LDC3,IXA1,LDIND);! load length word ->SETRES2 !* FN(24): ! INDEX OPB(ATPB,-2) OP2(MES2,MES2);! retrieve first param OPB(ATPB,2);! for result OP2(MMS2,MMS2) OP3(LDTP,ATPB,4);! prepare space I=LOCATE CHAR DESC(PARAMRES,0);! key string OP2(MOVB,4);! to move descriptor SYSCALL("F77INDEX") OP1(MES2) ->SETRES2 !* %END;! INLINE1 !* %ROUTINE CMPLX TO MS(%RECORD(RESF) R) %IF R_MODE>=CMPLX8 %THENSTART OP3(LDTP,ATPB,4) LOAD ADDRESS(R) OP3(TLATE1,MOVB,4) %FINISHELSESTART LOAD ADDRESS(R) OP3(TLATE1,LDDW,MMS2) OP3(LDC0,LDC0,MMS2) %FINISH %END;! COMPLX TO MS !* %ROUTINE COMPLEXOP(%HALFINTEGER OP,%RECORD(RESF) RESL,RESR) %HALFINTEGER T,LF,RF,QOP %RECORD(TMPF)%NAME TMP %RECORD(RESF) NEWRES !* %SWITCH S(1:8) %IF RESL_FORM=TRIAD %THEN RESL_FORM=EXTRIAD(RESL_H0,T,0) %IF RESR_FORM=TRIAD %THEN RESR_FORM=EXTRIAD(RESR_H0,T,0) %IF ACCUSE#0 %THEN FREEACC LF=RESL_MODE RF=RESR_MODE %UNLESS OP=7 %THENSTART T=GET TEMP(0,CMPLX8);! 8 BYTE TEMP LOCATION ON STACK TMP==RECORD(ADICT+T) SAVE RES(TMPID,T) %IF OP<8 %THENSTART %IF OP>3 %THEN OP1(LSSN) LLA(TMP_ADDR) %IF OP>3 %THEN OP1(MMS2) %ELSE OP1(REPL) %FINISH %FINISH ->S(OP) !* S(1): !COMPARISON CMPLX TO MS(RESL) CMPLX TO MS(RESR) SYSCALL("F77CXREL") %IF CONDMASK=2 %THEN QOP=EQUI %ELSE QOP=NEQI OP1(QOP) %RETURN !* S(2): !+ QOP=ADDOP PLUSMINUS: OP3(LDC2,ADI,EXCH);! modify c result @ LOAD ADDRESS(RESR) %IF RF>=CMPLX8 %THENSTART OP3(REPL2,LDC2,ADI);! @ complex part OP3(TLATE1,LDDW,MMS2);! c2 -> MS %FINISH OP3(TLATE1,LDDW,MMS2);! r2 -> MS LOAD ADDRESS(RESL) %IF LF>=CMPLX8 %THEN OP1(REPL2) OP2(TLATE1,LDDW);! r1 -> ES OP3(MES2,ROPS,QOP);! r1 op r2 %IF LF>= CMPLX8 %THENSTART OP3(MMS2,MMS,EXCH) OP3(MES,EXCH,MES2);! result @ <-> LHS @ %FINISH OP1(STDW);! r result %IF LF>=CMPLX8 %THENSTART OP2(LDC2,ADI);! @ complex part OP2(TLATE1,LDDW);! c1 -> ES %FINISHELSESTART OP2(LDC0,LDC0);! 0 -> ES %FINISH %IF RF>=CMPLX8 %THENSTART OP3(MES2,ROPS,QOP);! c1 op c2 %FINISH OP1(STDW);! c result %IF RESL_FORM=TMPID %THEN FREE TEMP(RESL_H0) %IF RESR_FORM=TMPID %THEN FREE TEMP(RESR_H0) %RETURN !* S(3):!- QOP=SUBOP ->PLUSMINUS !* S(4):!* S(5):!/ CMPLX TO MS(RESL) CMPLX TO MS(RESR) %IF OP=4 %THENSTART SYSCALL("F77CMULTC") %FINISHELSESTART SYSCALL("F77CDIVC") %FINISH %RETURN !* S(6):! UNARY - LOAD ADDRESS(RESL) OP2(REPL2,MMS2) OP2(TLATE1,LDDW) OP3(ROPS,NEGOP,STDW);! store real part OP2(LDC2,ADI);! @ complex part OP3(MES2,LDC2,ADI) OP2(TLATE1,LDDW) OP3(ROPS,NEGOP,STDW);! store complex part %RETURN !* S(7):!= LOAD ADDRESS(RESL) %IF LF>=CMPLX8 %THEN OP1(REPL2) LOAD ADDRESS(RESR) %IF RF>=CMPLX8 %AND LF>=CMPLX8 %THENSTART OP3(REPL2,LDC2,ADI);! @ complex part OP3(TLATE1,LDDW,MMS2);! stack complex part %FINISH OP2(TLATE1,LDDW);! load real part OP2(TLATE3,STDW);! store %IF LF>=CMPLX8 %THENSTART OP2(LDC2,ADI);! @ complex result %IF RF>=CMPLX8 %THENSTART OP1(MES2);! unstack complex part %FINISHELSESTART OP2(LDC0,LDC0);! or zero %FINISH OP2(TLATE3,STDW);! store %FINISH %RETURN !* S(8):!** OPB(ATPB,4) LOAD ADDRESS(RESL) OP1(MMS2) OP3(LDC0,LDC1,MMS2) LOAD ADDRESS(RESR) %IF RESR_MODENEXTCMN2 PUTDIAG2(M'**',M'**') PUTDIAG(QQ_CMNREFAD) I=PUTNAME(QQ_IDEN) CNTLOC=DIAGCA PUTDIAG(0);! FOR COMMON BLOCK IDEN COUNT PPTR = QQ_LINK2; ! LINK TO FIRST ITEM %WHILE PPTR # 0 %CYCLE; ! UNTIL LAST ITEM PP==RECORD(ADICT+PPTR) I=PP_TYPE<<8 %IF PP_X1&1#0 %THENSTART %IF PP_CLASS&4 # 0 %THENSTART; ! ARRAY DVREC==RECORD(ADICT+PP_ADDR4) I= I!X'0060';! array, desc in GLA J=DVREC_ADDRDV %FINISHELSESTART; !SCALAR %IF PP_TYPE=5 %THENSTART I=X'0540' J=PP_DISP %FINISHELSESTART %IF PP_ADDR4&X'FFFF8000'#0 %THENSTART;! USE FULL WORD ENTRY DEFER(I,PP_ADDR4) I=0; J=0 %FINISHELSE J=PP_ADDR4 %FINISH %FINISH PUTDIAG2(I,J) I=PUTNAME(PP_IDEN) CNT=CNT+1 %FINISH PPTR = PP_LINK2; ! LINK TO NEXT ITEM IN COMMON %REPEAT PLUGDIAG(CNTLOC,CNT) TOTCNT=TOTCNT+CNT CNT=0 NEXTCMN2: QPTR = QQ_ADDR4; ! LINK TO NEXT COMMON BLOCK %REPEAT %FINISH PLUGDIAG(TOTCNTLOC,TOTCNT) !{2900C} PUTDIAG2(X'FFFF',X'FFFF');! TERMINATE SYMBOL TABLES WITH 'FFFFFFFF' {PERQC} PUTDIAG2(-1,-1) !* I=DEFLIST %WHILE I#0 %CYCLE SS==RECORD(ADICT+I) I=SS_LINK1 PLUGDIAG(SS_INF0,DIAGCA-TOTCNTLOC-W4) PUTDIAG(SS_INF2) PUTDIAGW(SS_INF3) %REPEAT !* %IF CHECKS=NO %AND CONTROL&X'800000'=0 %THENSTART;! NOCHECK,LINE PUTDIAGW(COM_FIRSTSTATNUM) PCTABLE=DIAGCA PLUGDIAG(STARTST,PCTABLE-STARTST) PUTDIAGW(STATCOUNT) I=STATMAPHEAD %WHILE I#0 %CYCLE J=INTEGER(ADICT+I) %IF J=0 %THEN K=STATMAPINDEX %ELSE K=32 AD=ADICT+I %CYCLE II=1,1,K PUTDIAGW(INTEGER(AD+II*W2)) %REPEAT I=J %REPEAT PUTDIAG2(CODECA,0);! PC AT END OF CODE %FINISH DIAGOUT %FINISH TYPE6(4)=DIAGCA<<1-TYPE7(4) TYPE7(4) = DIAGCA<<1 %RETURN !* %INTEGERFN PUTNAME(%INTEGER AD) %STRINGNAME S %HALFINTEGER I AD=ANAMES+AD S==STRING(AD) I=LENGTH(S) I=(I+2)>>1 DIAGBYTES(AD,I) %RESULT=I %END;! PUTNAME !* %ROUTINE DEFER(%INTEGER FLAGS,AD) %RECORD(SRECF)%NAME SS DICT SPACE(W8) SS==RECORD(ADICT+COM_DPTR) SS_INF0=DIAGCA SS_LINK1=DEFLIST DEFLIST=COM_DPTR COM_DPTR=COM_DPTR+W8 SS_INF2=FLAGS SS_INF3=AD %END;! DEFER %END; ! LOADDATA !* !* %ROUTINE TOTALS(%INTEGERARRAYNAME TYPE7) PRINTSTRING(" Code ") WRITE(TYPE7(1),1) PRINTSTRING(" bytes Global ") WRITE(TYPE7(2),1) PRINTSTRING(" bytes Diag tables ") ; WRITE(TYPE7(4),1) PRINTSTRING(" bytes Total ") ; WRITE(TYPE7(8),1) PRINTSTRING(" bytes ") %END;! TOTALS !* %ROUTINE REPORT(%INTEGER I) NEWLINE %IF COM_FAULTY#0 %THENSTART WRITE(COM_FAULTY,3) PRINTSTRING(" error") %IF COM_FAULTY>1 %THEN PRINTSYMBOL('s') NEWLINE %FINISHELSESTART %IF I=1 %THENSTART;! listing file PRINTSTRING(" No errors") NEWLINE %FINISH %FINISH %IF COM_WARNCOUNT#0 %THENSTART WRITE(COM_WARNCOUNT,3) PRINTSTRING(" warning") %IF COM_WARNCOUNT>1 %THEN PRINTSYMBOL('s') NEWLINE %FINISH %IF COM_COMMENTCNT#0 %THENSTART WRITE(COM_COMMENTCNT,3) PRINTSTRING(" comment") %IF COM_COMMENTCNT>1 %THEN PRINTSYMBOL('s') NEWLINE %FINISH NEWLINE %IF COM_SCANONLY=YES %THENSTART PRINTSTRING("Syntax check ") %IF COM_FAULTY = 0 %THENSTART PRINTSTRING("successful ") %FINISHELSESTART PRINTSTRING("failed ") %FINISH %FINISHELSESTART %IF COM_FAULTY=0 %THENSTART !{2900C} COMREG(24)=0 !{2900C} COMREG(47)=LINEST %FINISHELSESTART !{2900C} COMREG(47)=COM_FAULTY PRINTSTRING("Compilation failed ") %FINISH %FINISH %END;! REPORT !* %ROUTINE FINISH(%INTEGER MODE) !*********************************************************************** !* OUTPUT FINAL LPUT RECORD AND SUMMARY TO LISTING FILE AND STOP * !* MODE = 0 BETWEEN MODULES !* 1 GENUINE END !*********************************************************************** %INTEGER I,ER !* %IF MODE=2 %THEN ->FAIL;! FOR AN EMPTY FILE %IF COM_SUBPROGTYPE > 0 %THEN MODE=1 %AND -> FAIL %IF COM_SCANONLY=YES %THEN ->REP !********* SATISFY LOCAL REFS I=TIDY GLA(2,0,0) SAT REFS !******** GLOBAL FIXUPS QPUT(19,2,12,6);! LOCATE CONST AREA !******* OUTPUT TYPE 7 BLOCK TYPE7(6)=COM_CNSTCA TYPE7(8)=0 %CYCLE I=1,1,7 TYPE7(8) = TYPE7(8)+TYPE7(I) TTYPE7(I)=TTYPE7(I)+TYPE7(I) %REPEAT TTYPE7(8)=TTYPE7(8)+TYPE7(8) !* %IF TYPE7(8) = 0 %AND MODE#1 %THENSTART FAIL: LFAULT(303);! END STATEMENT MISSING ! UNLESS >200 FAULTS ! SUBPROGEND %FINISH FAIL2: COM_FAULTY = COM_FAULTY+COM_FNO COM_FNO=0 %IF COM_FAULTY=0 %THENSTART QPUT(7,40,0,ADDR(TYPE7(1))) %IF COM_LISTL#0 %THEN TOTALS(TTYPE7) %FINISH REP: %IF COM_LISTL#0 %THEN REPORT(1) SELECTOUTPUT(0) REPORT(0) TOTAL FAULTS=0;! FOR NEXT TIME IN %END; ! FINISH !* %ROUTINE ENTRYCODE OP2(LDO0,LDC0) OPB(JNEB,3) %IF COM_SUBPROGTYPE=1 %THENSTART SYSCALL("INITMAIN") %FINISHELSESTART SYSCALL("INITGLA") %FINISH %END;! MAINCODE !* %ROUTINE STATEMENT MAP %INTEGER I,J,K,L,N,INDEX,LAST,LINE !! SET HEADING(4) K=0;! count of items per line (4) LAST=0 I=STATMAPHEAD %WHILE I#0 %CYCLE J=INTEGER(ADICT+I) %IF J=0 %THEN L=STATMAPINDEX<<2 %ELSE L=128 %CYCLE INDEX=4,4,L N=INTEGER(ADICT+I+INDEX) LINE=N&X'1FFF' %IF LINE>LAST %THENSTART LAST=LINE %IF K&3=0 %THEN NEWLINE %ELSE SPACES(14) K=K+1 WRITE(LINE+COM_FIRSTSTATNUM,4) WRITE(N>>13,10) %FINISH %REPEAT I=J %REPEAT NEWLINE %END;! STATEMENT MAP !* %INTEGERFN RT DEFN(%HALFINTEGER PS,RPS,%INTEGER ENTRY, %HALFINTEGER LL,DIAG,%INTEGER ATEMPLATE) %OWNRECORD(RTFMT) RT %HALFINTEGER LTS %IF STACKCA>RPS %THEN LTS=STACKCA-RPS %ELSE LTS=0 RT_PS=PS RT_RPS=RPS RT_LTS=LTS RT_ENTRY<-ENTRY RT_EXIT<-CODECA RT_LL=LL RT_SP1=0 RT_SP2=0 RT_DIAG=DIAG %if atemplate=0 %then atemplate=addr(zeropdesc) {Temp - Alan} RT_ATEMPLATE=ATEMPLATE OP1(RETURN) %RESULT=ADDR(RT_PS) %END;! RT DEFN !* %ROUTINE SUBPROGEND !*********************************************************************** !* CALLED FROM PHI(46) FOLLOWING RECOGNITION OF END STATEMENT * !*********************************************************************** !* %INTEGER I,J,K, CODEEP,CURPTR,AREA,PTR,ER,PCHECKS %HALFINTEGER ENTRIES,EPINDEX %RECORD(PRECF)%NAME PP %RECORD(PRECF)%NAME QQ %RECORD(SRECF)%NAME SS %RECORD(ARRAYDVF)%NAME DVREC %RECORD(PRECF)%NAME CMNBLK %RECORD(RTFMT) RT PCHECKS=PARCHECKS!ASSUMED SIZE %IF CODECA >= X'10000' %THEN LFAULT(310);! SUBPROGRAM TOO LARGE ! %WHILE COM_EXTERNALS#0 %CYCLE ! SS==RECORD(ADICT+COM_EXTERNALS) ! PTR=SS_INF0 ! QQ==RECORD(ADICT+PTR) ! %IF QQ_CLASS=8 %AND QQ_ADDR4=0 %THENSTART;! ENSURE EXTERNAL REF SET ! USER REF(QQ_IDEN,0,0,1) ! %FINISH ! COM_EXTERNALS=SS_LINK1 ! %REPEAT %UNLESS COM_SUBPROGTYPE=5 %THENSTART;! PROLOGUE,EPILOGUE,LOADDATA %IF COM_SUBPROGTYPE=1 %THENSTART;! STOP OP3(LDC0,LDC0,LDC0) OP2(MMS2,MMS) SYSCALL("F77STOP") %FINISHELSESTART;! RETURN OP1(LDC0) I=GET LABEL ADDRESS(PLABID,EPILOGUE) OPBB(JMPW,0,0) %FINISH %IF IOKEY#0 %THEN IO PROC SWITCH %IF ASSIGNED GOTOS#0 %THEN ASSIGNED LIST !* !****** PROCESS EACH ENTRY POINT !* CURPTR = COM_SUBPROGPTR ENTRIES=NO EPINDEX=0 %WHILE CURPTR#0 %CYCLE PP==RECORD(ADICT+CURPTR) %IF PP_LINK3#0 %THEN ENTRIES=YES PLAB==RECORD(ADICT+PP_DISP);! private label record %IF PROCEP#0 %THENSTART FILL JUMP(PROCEP) CODEEP=PROCEP PROCEP=0 %FINISHELSE CODEEP=CODECA ENTRYCODE !* %IF COM_SUBPROGTYPE=2 %THENSTART;! fn %IF PP_TYPE=CHARTYPE %OR PP_TYPE&7=CMPLXTYPE %C %THEN RESULT WORDS=4 %C %ELSE RESULT WORDS=2 %FINISHELSE RESULT WORDS=0 SET LINE NO(-COM_FIRSTSTATNUM) TPLATE(0)=1 TPLATE(1)=255;! default to null desc %UNLESS COM_SUBPROGTYPE=1 %THEN COPYPARS(CURPTR,0); ! COPY IN %IF ENTRIES=YES %THENSTART EPINDEX=EPINDEX+1 LDC(EPINDEX) STO(ENTRYNO WORD) %FINISH OPW(JMPW,PLAB_CODEAD-CODECA-3) %IF ENTRIES=YES %THENSTART IOSTEPS(EPINDEX)=CODECA %FINISHELSE DECLARE PLAB(EPILOGUE) %IF COM_SUBPROGTYPE#1 %THENSTART COPYPARS(CURPTR,1); ! COPY OUT !****** COPYPARS WILL ENSURE THAT RETURN NO IS SET IF NEC. %FINISH K=RT DEFN(PARAM WORDS,RESULT WORDS+PARAM WORDS, CODEEP,1,DIAGCA,ADDR(TPLATE(0))) %IF COM_SUBPROGTYPE=1 %THENSTART I=X'80010000' %FINISHELSESTART I=NOTE ENTRY(STRING(ANAMES+PP_IDEN),NEXT RTNO, LINEST,TPLATE(0),ADDR(TPLATE(0)),J) I=X'10000'!NEXT RTNO NEXT RTNO=NEXT RTNO+1 %FINISH QPUT(11,I,K,ANAMES+PP_IDEN) PP==RECORD(ADICT+CURPTR) CURPTR=PP_LINK3;! TO NEXT ENTRY POINT %REPEAT %IF ENTRIES=YES %THENSTART DECLARE PLAB(EPILOGUE) LDO(ENTRYNO WORD) %IF CODECA&1=0 %THEN OP1(QNOOP) OP1(XJP) PWORD(1) PWORD(EPINDEX) PWORD(EPINDEX<<1-2) %CYCLE I=1,1,EPINDEX PWORD(IOSTEPS(I)-CODECA) %REPEAT OP1(RETURN) %FINISH %IF CODECA&1#0 %THEN OP1(QNOOP) CODEOUT !* TYPE6(1)=CODECA-TYPE7(1) TYPE7(1)=CODECA %FINISH !* %IF CODECA-CODESTART>X'8000' %THEN LFAULT(320) !* LOADDATA COM_SUBPROGTYPE = -1 !****** CHECK LIST PROCESSING(PARAMETER ARRAYS) %WHILE COM_CHECKLIST#0 %CYCLE SS==RECORD(ADICT+COM_CHECKLIST) PP==RECORD(ADICT+SS_INF0) %IF PP_CLASS&X'60'=X'60' %THENSTART TFAULT(248,ANAMES+PP_IDEN,0) %FINISH COM_CHECKLIST=SS_LINK1 %REPEAT !* %IF CONTROL&X'8800'#0 %THENSTART;! ATTR/XREF MAP(1,COM_XREF&1,0,0,COMAD) %FINISH %END; ! SUBPROGEND !* !* !* !* !* %ROUTINE COPYPARS(%INTEGER AREC, MODE) %ROUTINESPEC SET ENTRY TEMPLATE(%INTEGER AREC) %ROUTINESPEC PARAM ARRAY(%INTEGER STACKPTR,PARAMREC) %ROUTINESPEC SET P DESC(%INTEGER OP) %RECORD(PRECF)%NAME ENTRY %RECORD(PRECF)%NAME PARAM %RECORD(SRECF)%NAME SS %RECORD(PRECF)%NAME PP %INTEGER I,J,P,STACKPTR,SHORT,COMPLEX,PARAMCHECK,OP,PTR %INTEGER DESCAD,LASTDESCAD,VRETURN,MATCH,PCLASS,AD %SWITCH T(1:12) %INTEGER ARRAYLIST !* SET ENTRY TEMPLATE(AREC) ARRAYLIST=0 %IF MODE=1 %AND COM_SUBPROGTYPE#2 %AND %C VARIABLE RETURN=YES %THEN VRETURN=1 %ELSE VRETURN=0 STACKPTR=RESULT WORDS;! PARAM ADDRESS ENTRY==RECORD(ADICT+AREC) P=ENTRY_LINK2;! LINK TO PARAM POINTERS %WHILE P#0 %CYCLE SS==RECORD(ADICT+P);! 2-WORD PARAM PTR CHAIN P=SS_LINK1 PTR=SS_INF0 %IF PTR=0 %THEN ->LOOP;! label param PARAM==RECORD(ADICT+PTR) ALLOC(PTR) PCLASS=PARAM_CLASS %IF PCLASS=9 %THENSTART;! PROCEDURE PARAM ! THEIR ADDRESSES COPIED %IF MODE=0 %THENSTART LOA(PARAM_ADDR4) LLA(STACKPTR) OPB(MOVB,4) %FINISH ->NEXT %FINISH %IF PARAM_X0&1=0 %THENSTART;! 'name' param - only char scalars in F77 %IF MODE=0 %THENSTART;! COPY DESC LOA(PARAM_DISP) LLA(STACKPTR) OPB(MOVB,6) I=PARAM_LEN %IF I#0 %THENSTART LDC(I) OP2(REPL,REPL) STL(PARAM_DISP+3);! set nominated length STL(PARAM_DISP+4);! set max len LDL(STACKPTR+4);! no of chars passed OP1(GTRI);! check bound<=passed total size RT ERROR(CSIZEFAULT);! if false report error %FINISH %FINISH STACKPTR=STACKPTR+2;! because 2 words more than usual ->NEXT %FINISH %IF PCLASS&4#0 %THENSTART;! ARRAY %IF MODE=0 %THENSTART;! DEFER ARRAY PROCESSING UNTIL SCALARS ! HAVE BEEN DEALT WITH. THIS ALLOWS ! FOR ARRAYS WITH SUBS. PARAMS AS ! ADJUSTABLE DIMENSIONS PTR=NEW LIST CELL3(ARRAYLIST) SS==RECORD(ADICT+PTR) SS_INF0=STACKPTR SS_INF2=ADDR(PARAM_CLASS) %FINISH %IF PARAM_TYPE=5 %THEN STACKPTR=STACKPTR+2;! 2 extra words for char items ->NEXT %FINISH I=PARAM_TYPE COMPLEX=0;! SET 4 C*8 8 C*16 AD=PARAM_ADDR4 ->T(I&15) T(3): ! COMPLEX COMPLEX=4 T(1): ! INTEGER T(2): ! REAL T(4): ! LOGICAL J=I&X'F0' LDLD(STACKPTR);! param @ %IF MODE=0 %THENSTART;! COPY IN %IF J=X'40' %THENSTART;! INT2 OP2(TLATE1,LDIND) STO(AD) %FINISHELSESTART %IF COMPLEX#0 %THENSTART OP1(MMS2) LOA(AD) OP2(MES2,TLATE1) OPB(MOVB,4) %FINISHELSESTART OP2(TLATE1,LDDW) STOD(AD) %FINISH %FINISH %FINISHELSESTART;! COPY BACK %IF J=X'40' %THENSTART LDO(AD) OP2(TLATE2,STIND) %FINISHELSESTART %IF COMPLEX#0 %THENSTART LOA(AD) OP3(TLATE2,MOVB,4) %FINISHELSESTART LDOD(AD) OP2(TLATE3,STDW) %FINISH %FINISH %FINISH ->NEXT T(5): T(6): T(7): T(8): NEXT: STACKPTR=STACKPTR+4 LOOP: %REPEAT;! FOR ALL PARAMS %WHILE ARRAYLIST#0 %CYCLE SS==RECORD(ADICT+ARRAYLIST) PARAM ARRAY(SS_INF0,SS_INF2) ARRAYLIST=SS_LINK1 %REPEAT PARAM WORDS=STACKPTR-RESULT WORDS %IF MODE#0 %THENSTART;! COPY BACK %IF COM_SUBPROGTYPE=2 %THENSTART;! FN, SO RESULT TO ACC PTR=AREC PP==RECORD(ADICT+PTR) %IF PP_X1&1=0 %THENSTART LFAULT(195);! function not assigned %RETURN %FINISH I=ENTRY_TYPE %FINISHELSESTART;! SUBROUTINE, SET RETURN VALUE IF NEC. %IF VRETURN#0 %THENSTART OP3(LDAP,LDC3,IXA1);! @ global of caller OP1(LDIND) OP2(LDC0+VRETURN WORD,IXA1);! @ caller's loc LDO(VRETURN WORD) OP1(STIND) %FINISH %FINISH %FINISH %RETURN !* !* %ROUTINE SET ENTRY TEMPLATE(%INTEGER AREC) %INTEGER PREC,PCOUNT,I,J,CLASS,NEXT,TSTART %RECORD(PRECF)%NAME ENTRY %RECORD(PRECF)%NAME PP %RECORD(SRECF)%NAME SS %IF PARCHECKS=NO %THEN %RETURN ENTRY==RECORD(ADICT+AREC) %IF COM_SUBPROGTYPE=3 %THEN I=0 %ELSE I=ENTRY_TYPE TPLATE(1)=I PREC=ENTRY_LINK2 PCOUNT=1 %WHILE PREC#0 %CYCLE SS==RECORD(ADICT+PREC) %IF SS_INF0#0 %THENSTART;! except for labels pro tem PP==RECORD(ADICT+SS_INF0) PCOUNT=PCOUNT+1 I=PP_TYPE %IF PP_CLASS&8#0 %THEN I=X'80';! subprog %IF PCOUNT<256 %THEN TPLATE(PCOUNT)=I %FINISH PREC=SS_LINK1 %REPEAT %IF PCOUNT>255 %THEN PCOUNT=255 TPLATE(0)=PCOUNT TPLATE(PCOUNT+1)=0;! ensure 0 in byte which may fill to word bdy %END;! SET TEMPLATE !* %ROUTINE PARAM ARRAY(%INTEGER STACKPTR,PARAMREC) !* following code is analogous to 2900 version, with !* ETOS == Breg !* ETOS-1 == acc %ROUTINESPEC DIMOP(%INTEGER D,MODE) %RECORD(ARRAYDVF)%NAME DVREC %INTEGER I,J,L,U,ADJUST,PCT,DVAD,PTYPE,SUM,M,GLADV %INTEGER LC,UC,OP,SUM2,BUSED,ACCUSED,ADJTABLE,CHLEN PARAM==RECORD(PARAMREC) DVREC==RECORD(ADICT+PARAM_ADDR4) DVAD=DVREC_ADDRDV PCT=DVREC_DIMS PTYPE=PARAM_TYPE !* ADJUST=NO BUSED=0 ACCUSED=0 %CYCLE I=1,1,PCT %IF DVREC_B(I)_M=-1 %THEN ->ADJUST %REPEAT %IF PARAM_CLASS&X'C0'=X'80' %THEN ->STAR I=DVREC_NUMELS %IF PTYPE=5 %THENSTART;! char LOA(DVAD+6);! for num els LDCD(I) OP1(STDW) LOA(DVAD+4);! for num chars CHLEN=PARAM_LEN %IF CHLEN=0 %THENSTART LDCD(I) LDL(STACKPTR+3);! passed element length OP1(REPL) LOA(DVAD+3) OP2(EXCH,STIND) OP2(LOPS,I2TOI4) OP2(LOPS,MULTOP) %FINISHELSESTART LOA(DVAD+3) LDC(CHLEN) OP1(STIND) I=I*CHLEN LDCD(I) %FINISH OP1(STDW) %FINISHELSESTART;! non-char LOA(DVAD+2);! num els LDCD(I) OP1(STDW) %FINISH ->COMMON !* ADJUST: %IF PARAM_CLASS&X'C0'=X'80' %THEN ->STAR;! NO ACTUAL ADJ. DIMS ADJUST=YES !* SUM=1;SUM2=0 %IF PTYPE=5 %THEN GLADV=DVAD+2 %ELSE GLADV=DVAD-2 %CYCLE I=1,1,PCT J=GLADV+I*6;! @ OF RELEVENT TRIPLE %IF BUSED#0 %THENSTART OP2(REPL2,MMS2) LOA(J);! multiplier OP2(MES2,STDW) %FINISH L=DVREC_B(I)_L U=DVREC_B(I)_U %IF L>>30=2 %THEN LC=1 %ELSE LC=0;! VAR ELSE CONST %IF U>>30=2 %THEN UC=1 %ELSE UC=0 %IF LC=0 %THENSTART %IF BUSED=0 %THENSTART %IF I=1 %THEN SUM2=L %ELSE SUM2=SUM2+L*DVREC_B(I)_M %FINISHELSESTART %IF ACCUSED=0 %THENSTART OP2(REPL2,MMS2);! save B, acc=B %UNLESS L=1 %THENSTART LDCD(L) OP2(LOPS,MULTOP) %FINISH LDCD(SUM2) OP3(LOPS,ADDOP,MES2);! acc=SUM2+B*lower, restore B %FINISHELSESTART OP2(REPL2,MMS2) %IF L#0 %THENSTART LDCD(L) OP2(LOPS,MULTOP) %FINISH OP3(LOPS,ADDOP,MES2);! acc=acc+B*lower %FINISH ACCUSED=1 %FINISH %IF UC=0 %THENSTART;! BOTH CONST %IF BUSED#0 %THENSTART;! ALREADY COMPUTING LDCD(U-L+1) OP2(LOPS,MULTOP);! B=B*(upper-lower+1) %FINISHELSESTART SUM=SUM*(U-L+1) %FINISH %FINISHELSESTART;! UPPER IS VAR %IF U>>29=5 %THEN ->STAR %IF BUSED#0 %THEN OP1(MMS2) LOA(J+4) DIMOP(U,0) OP3(REPL2,MMS2,STDW);! adjustable upper OP1(MES2) %UNLESS L=1 %THENSTART LDCD(L-1) OP2(LOPS,SUBOP);! upper-lower+1 %FINISH CHECK: %IF ARGCHECKS#NO %AND U>>29#5 %THENSTART;! ensure it is positive !!!? PF3(JAT,13,0,5);! IF BREG>0 !!!? RT ERROR(BOUND FAULT) %FINISH %IF BUSED=0 %THENSTART %IF I>1 %THENSTART LDCD(SUM) OP2(LOPS,MULTOP);! B*SUM %FINISH BUSED=1 %FINISHELSESTART OP3(MES2,LOPS,MULTOP) %FINISH %FINISH %FINISHELSESTART %IF BUSED#0 %THEN OP1(MMS2) %IF ACCUSED=0 %THENSTART %IF I=1 %THEN DIMOP(L,0) %ELSE LDCD(SUM2) %FINISH %IF I#1 %THENSTART OP1(REPL2) DIMOP(L,0) %IF BUSED=0 %THENSTART LDCD(DVREC_B(I)_M) %FINISHELSESTART OP3(MES2,REPL2,MMS2) %FINISH OP2(LOPS,MULTOP) OP2(LOPS,ADDOP) %FINISH ACCUSED=1 LOA(J+2) DIMOP(L,0) OP3(REPL2,MMS2,STDW) %IF UC=0 %THENSTART LDCD(U+1) %FINISHELSESTART %IF U>>29=5 %THEN ->STAR LOA(J+4) DIMOP(U,0) OP3(REPL2,MMS2,STDW) OP1(MES2) OP2(LDC1,ADI) %FINISH OP3(MES2,LOPS,SUBOP) ->CHECK %FINISH %REPEAT !* %IF U>>29=5 %THENSTART;! * upper bound STAR: LOA(DVAD+4) LLA(STACKPTR+4) OP2(LDDW,STDW) %IF ADJUST=NO %THEN ->COMMON %FINISHELSESTART %IF PTYPE=5 %THENSTART OP1(REPL2) STOD(DVAD+6) CHLEN=PARAM_LEN %IF CHLEN=0 %THENSTART LDL(STACKPTR+3) %FINISHELSE LDCD(CHLEN) OP2(LOPS,MULTOP) STOD(DVAD+4) %FINISHELSESTART STOD(DVAD+2) %FINISH %FINISH !* !* %IF COM_ARRAYCHECKS=FULL %AND PCT#1 %THEN ->COMMON !* %IF ACCUSED#0 %THENSTART %IF PTYPE=5 %THENSTART !! CHLEN=PARAM_LEN !! %IF CHLEN=0 %THENSTART !! OPDV(MYB,DVREC_ADDRDV-4) !! %FINISHELSE OPLITT(MYB,CHLEN) STOD(DVAD+8) %FINISHELSESTART STOD(DVAD+4) %FINISH %FINISH !* !* COMMON: LOA(DVAD) LLA(STACKPTR) OP2(LDDW,STDW) %IF PTYPE=5 %THENSTART LDL(STACKPTR+2) STO(DVAD+2);! disp %FINISH ! LDLD(STACKPTR+2);! no of els ! %IF ADJUST=YES %THENSTART ! OP1(MES2) ! %FINISHELSESTART ! I=DVREC_NUMELS ! OPW(LDDC,I>>16) ! PWORD(I&X'FFFF') ! %FINISH ! OP2(LOPS,LESOP) ! RT ERROR(ASIZEFAULT) !* %RETURN !* %ROUTINE DIMOP(%INTEGER D,MODE) %ROUTINESPEC DIMEVAL(%INTEGERNAME DISP) %INTEGER F,A,M,I,J,K,PTR %STRING(32) IDENTIFIER,ERRIDEN %RECORD(SRECF)%NAME SS %RECORD(PRECF)%NAME PP %RECORD(RESF) R %SWITCH S(0:7) R_W=D %IF D>>30#2 %THENSTART M=0 A=D %FINISHELSESTART R_H0=R_H0&X'7FFF' A=R_H0 %FINISH !* ->S(R_FORM&15) !* S(1): A=INTEGER(ADICT+D);! int in dict !* S(0): ! simple int LDCD(A) %RETURN !* S(3): S(4): S(5): ALLOC(A) PP==RECORD(ADICT+A) ERRIDEN=STRING(ANAMES+PP_IDEN) %IF PP_CLASS&2#0 %THENSTART;! in common R_FORM=CSCALID %FINISHELSESTART PTR=ENTRY_LINK2;! param list %WHILE PTR#0 %CYCLE SS==RECORD(ADICT+PTR) PTR=SS_LINK1 %IF A=SS_INF0 %THEN ->GOOD PAR %REPEAT TFAULT(250,ADDR(IDENTIFIER),ADDR(ERRIDEN));! dim not param or in common %RETURN GOODPAR:R_FORM=OSCALID;! has a local RD %FINISH !* %IF R_MODE>INT8 %THENSTART TFAULT(196,ADDR(IDENTIFIER),ADDR(ERRIDEN));! adjustable dimension not integer %RETURN %FINISH !* !* LOAD VAL(R) !* %RETURN !* S(6): ! temp loc %IF MODE=0 %THEN LDOD(A) %ELSE STOD(A) %RETURN !* S(7): !dimension expression DIMEVAL(A) %RETURN !* %ROUTINE DIMEVAL(%INTEGERNAME DISP) %CONSTBYTEINTEGERARRAY OP(0:6)=0(2),ADDOP,SUBOP,MULTOP,DIVOP,NEGOP %INTEGER CUR,END,AD CUR=DISP END=CUR+INTEGER(ADICT+CUR) CUR=CUR+W2 %WHILE CUR5 %THENSTART OP1(LDCMO) STO(NEXTPP);! to terminate parameter pairs list %FINISH %IF IOSTARTED#0 %THENSTART OP3(LDCMO,STL0,RETURN);! indicate end of io list IO LOCAL SWITCH FILL JUMP(IOSTARTED) IOSTARTED=0 %FINISH %IF IODSNUM#0 %THENSTART LDCD(IODSNUM) STOD(TCTBASE) %FINISH %IF IOINDEX<=1 %THENSTART;! no io list OP1(LDC0) STO(TCTBASE+TCTINDEX) %FINISH OP3(ATPB,1,LSSN) LOA(TCTBASE) OP1(MMS2);! @ io table LDC(FORM) LDC(IOKEY) OP1(MMS2);! ioform,iokey %IF UNASSCHECKS=YES %THEN MODE=MODE!4 LDC(MODE&255) LDC(MODE>>8) OP1(MMS2);! iomode,flags LDC(IOMARKERS) OP1(MMS);! existence indicators for end,err,iostat OPBB(LVRD,0,0);! actually LVRD W,UB1,UB2 OP2(IORTNO,2) OP2(MMS2,MMS2) INDEX=FORM TO INDEX(FORM) %IF INDEX<4 %THENSTART %IF MODE&X'200'#0 %THEN INDEX=INDEX+1 %FINISH SYSCALL(IONAME(INDEX)) %IF IOSTATVAR#0 %THENSTART LDO(TCTBASE+5) OPB(LOPS,I2TOI4) R_W=IOSTATVAR STORE VAL(R) %FINISH %IF IOMARKERS&3#0 %THENSTART OP1(MES) %IF IOMARKERS&3=3 %THEN OP2(REPL,MMS) %IF ENDLAB#0 %THENSTART R_W=ENDLAB OP1(LDC1) K=GET LABEL ADDRESS(LABID,R_H0) OPW(JEQW,K) %IF ERRLAB#0 %THEN OP1(MES) %FINISH %IF ERRLAB#0 %THENSTART R_W=ERRLAB OP1(LDC2) K=GET LABEL ADDRESS(LABID,R_H0) OPW(JEQW,K) %FINISH %FINISHELSE OPB(ATPB,-1) %END;! CALL IO !* %ROUTINE IO LIST ITEM(%RECORD(RESF) R) %HALFINTEGER L,ST,M !* %IF R_FORM&X'FF'=TRIAD %THENSTART R_FORM=EXTRIAD(R_H0,M,0) %FINISH L=MODETOWORDS(R_MODE) ST=MODETOST(R_MODE) !* !! STARTIO !* %IF ACCUSE#0 %THENSTART;! expression %IF R_FORM=ARREL %THENSTART STARTIO FREEACC ->NOACC %FINISH STOD(80);! use part of I/O area STARTIO OP2(LDL5,LDL4) OP1(LSSN) LOA(80) ACCUSE=0 %FINISHELSESTART STARTIO NOACC: OP2(LDL5,LDL4);! @ address %IF ST=CHARTYPE %THENSTART OP1(LSSN) L=LOCATE CHAR DESC(R,0) OP2(REPL2,MMS2) %FINISHELSE LOAD ADDRESS(R) %FINISH OP2(TLATE3,STDW);! @ item OP2(LDL3,LDL2);! @ len type LDC(ST) %IF ST=CHARTYPE %THENSTART OP3(MES2,LDC3,ADI) OP2(TLATE1,LDIND) %FINISHELSE LDC(L) OP2(TLATE3,STDW);! len(words), sizetype IOINDEX=IOINDEX+1 LDC(IOINDEX) STO(TCTBASE+TCTINDEX) %IF R_FORM&X'FF'=ARRID %THEN L=1 %ELSESTART %IF ST=CHARTYPE %THEN L=2 %ELSE L=0 %FINISH LDC(L) OP2(STL0,RETURN);! set result and exit IOSTEPS(IOINDEX)=CODECA %END;! IO LIST ITEM !* %ROUTINE IO SPEC CLAUSE(%INTEGER INDEX,PPKEY,%RECORD(RESF) R) %HALFINTEGER FORM,MODE %INTEGER I,PTR,L %RECORD(PRECF)%NAME PP %RECORD(ARRAYDVF)%NAME DVREC %RECORD(LABRECF)%NAME LABREC %RECORD(SRECF)%NAME SS %SWITCH SW(0:6) FORM=R_FORM&X'FF' MODE=R_MODE %IF INDEX>6 %THENSTART;! OPEN,CLOSE,INQUIRE %IF PPKEY&X'100'#0 %THEN K=PPKEY&X'1F' %ELSE K=PPKEY&X'5F' LDC(K);STO(NEXTPP);! parameter pair value NEXTPP=NEXTPP+1 %IF PPKEY&X'80'#0 %THEN I=4 %ELSESTART;! logical %IF PPKEY&X'40'#0 %THEN I=5 %ELSE I=1;! character or integer %FINISH %IF PPKEY&X'20'#0 %THENSTART;! descriptor to var required %IF I=5 %THENSTART OP1(LSSN) L=SET CHAR DESC(R,0) %FINISHELSE LOAD ADDRESS(R) %FINISHELSESTART %IF I=1 %THENSTART;! integer LOAD VAL(R) COERCE(MODE,INT4) %FINISHELSESTART %IF I=5 %THENSTART OP1(LSSN) L=SET CHAR DESC(R,0) %FINISHELSE LOAD ADDRESS(R) %FINISH %FINISH STOD(NEXTPP) NEXTPP=NEXTPP+2 %RETURN %FINISH ->SW(INDEX) !* SW(1):! UNIT= !* %IF FORM=LIT %THENSTART ;! int >=0 LDCD(R_H0) STOD(TCTBASE) IODSNUM=0 %FINISHELSESTART %IF FORM#ARRID %AND MODE<=INT8 %THENSTART ;! integer expression - external file IODSNUM=0;! will over-ride default settings LOAD VAL(R) COERCE(MODE,INT4) OP3(REPL2,LDC0,LDC0) OPB(LOPS,LESOP) RTERROR(NEGUNITFAULT);! report error if unit<0 STOD(TCTBASE) %FINISHELSESTART ;! must be internal file iden LOA(TCTBASE+12) I=LOCATE CHAR DESC(R,0) %IF FORM=ARRID %THENSTART OP3(REPL,LDC6,ADI);! @ num els OP1(LDDW) %FINISHELSE OP2(LDC0,LDC1) STOD(TCTBASE+16) OPB(MOVB,4);! base,disp,el len %FINISH %FINISH ACCUSE=0 %RETURN !* !* SW(2): ! FMT= !* %IF FORM=LABID %THENSTART;! format label LABREC==RECORD(ADICT+R_H0) LDOD(CONST REF) LDC(LABREC_ADDR4>>1);! displacement of format table in const area OP1(ADI) STOD(TCTBASE+8) LDC(LABREC_LINK3);! format length OP1(LDC0);! disp (always 0 for fmt table) STOD(TCTBASE+10) %RETURN %FINISH !* %IF FORM=ARRID %THENSTART ;! special iden (must be character array) LOAD ADDRESS(R) OP3(REPL2,TLATE1,LDDW);! base address STOD(TCTBASE+8) %IF R_MODE=CHARMODE %THENSTART OP3(REPL2,LDC2,ADI) OP2(TLATE1,LDIND);! disp STO(TCTBASE+10) OP2(LDC6,ADI);! TOTAL BYTES OP2(TLATE1,LDIND) STO(TCTBASE+11) %FINISHELSESTART OP3(LDC2,ADI,TLATE1) OP3(LDIND,LDC4,MPI) OP1(LDC0) STOD(TCTBASE+10) %FINISH %RETURN %FINISH !* %IF MODE=CHARMODE %THENSTART LOA(TCTBASE+8) I=LOCATE CHAR DESC(R,0) OPB(MOVB,4) %RETURN %FINISH !!#!* !!# %IF LSCALID<=FORM<=CSCALID %THENSTART ;! Scalar, must be assigned !!# PLANTOP(LCT,FORM,VAL) !!# CTBUSE=0 !!# %IF ANYCHECKS#NO %THENSTART !!# OPDIR(LSS,CTB,0) !!# OP PC(ICP,PCFMT) !!# PF3(JCC,8,0,5) !!# RTERROR(FMTLABFAULT) ;! format does not have the special marker !!# %FINISH !!# OPDIR(LDRL,CTB,4) !!#L522: OPLT(STD,GLAIOTABLE+20) !!# %RETURN !!# %FINISH !!#!* SW(3): ! REC= !* LOAD VAL(R) STOD(TCTBASE+2) ACCUSE=0 %RETURN !* SW(4): ! END = IOMARKERS=IOMARKERS!1 ENDLAB=R_W %RETURN !* SW(5): ! ERR= !* IOMARKERS=IOMARKERS!2 ERRLAB=R_W %RETURN !* SW(6): ! IOSTAT= !* IOMARKERS=IOMARKERS!4 IOSTATVAR=R_W %RETURN !* %END;! IO SPEC CLAUSE !* %ROUTINE CGENINIT !*********************************************************************** !* Re-initialise at start of each subprogram * !*********************************************************************** %INTEGER I,J %CYCLE I = 1,1,7 TYPE6(I) = 0 %REPEAT %CYCLE I=1,1,9 TEMPST(I)=0 %REPEAT ASL3=0 STATMAPINDEX=32 STATMAPHEAD=0 STATCOUNT=0 CURSTATMAP=0 LOCALDLIST=0 ASSIGNED GOTOS=0;! list of jumps to be filled in to go to common switch ASSIGNED LABS=0;! list of assigned labels to add to switch NEXT ASS LAB=1 RCOMPLEX=0 ICOMPLEX=0 CWORK=0 EXPWORK=0 COMPLEXTEMP=0 CDIV2=0 INARRAYSUBSCRIPT=NO ADJ FIXUPS=0 VARIABLE RETURN=NO ASSUMED SIZE=NO PROC PARLIST=0 STACKCA=0 STACKBASE=0 IOKEY=0 TCTBASE=12;! may be determined dynamically later RESULT WORDS=0 PARAM WORDS=0 STACKCA=COM_MAX PSTACK;! reserve max no words used for any param set %IF STACKCA<12 %THEN STACKCA=12;! lineno word must be > 0 LINENO WORD=STACKCA STACKCA=STACKCA+1 !* %IF CONTROL&X'10000000'#0 %THEN FLIP=YES;! to flip diags bytes if PARMX !* PROCEP=CODECA OPBB(JMPW,0,0);! will jump to prologue %IF UNASSCHECKS=YES %THENSTART PCUNASS=CODECA OPW(LDCW,UNASSFAULT) OP1(MMS) SYSCALL("F77RTERR") %FINISH !* %END;! CGENINIT !* !* %ROUTINE CGENSTART %INTEGER I,J,K AREFDATA=COM_ADEXT !{2900C} AREFDATA=ADDR(EXTAREA(0)) INIT EXT;! to reset !* CGEN INITIALISED=1 %IF CONTROL&X'10'#0 %THENSTART;! NOCHECK CHECKS=NO COM_UNASSPATTERN=0 UNASSCHECKS=NO COM_ARRAYCHECKS=YES;! keep array bound check CHARCHECKS=YES;! keep char checks ARGCHECKS=YES %FINISHELSESTART CHECKS=YES COM_UNASSPATTERN=X'80' UNASSCHECKS=YES COM_ARRAYCHECKS=YES ARGCHECKS=YES CHARCHECKS=YES %FINISH %IF CONTROL&X'20'#0 %THEN COM_ARRAYCHECKS=NO COM_XREF=(CONTROL&X'800')>>11;! LISTINGS=XREF LISTCODE=CONTROL&X'4000';! LISTINGS=OBJECT TRACETEMP=LISTCODE PARCHECKS=ARGCHECKS;! separate switch to turn off if necessary CALLSPEC=YES;! ditto !!#!* !* !****** INITIALISE OBJECT FILE GENERATION AREA !* %CYCLE I = 1,1,8 TYPE7(I) = 0 %REPEAT !* CODECA=0 DIAGCA=0 CODECURR=0 DIAGCURR=0 CODEBASE=0 DIAGBASE=0 !* LINEST=0 NEXT RTNO=1 !* CODELISTED=CODECA;! START POINT FOR DECOMPILING !* !****** INITIALISE SYMBOL TABLES !* PUTDIAG2(M'##',M'##') !* !****** INITIALISE CODE !* %CYCLE I=0,1,1 PWORD(0) %REPEAT !* %END;! CGENSTART !* !*********************************************************************** !*********************************************************************** !* %ROUTINESPEC COMPUTED GOTO(%HALFINTEGER LIST,MODE) %INTEGERFNSPEC NEW PLAB !* %CONSTBYTEINTEGERARRAY ARITHIF2(0:5)=LESI,GTRI,EQUI,LESI,GTRI,EQUI %CONSTBYTEINTEGERARRAY ARITHIF4(0:5)=LESOP,GTROP,EQUOP,LESOP,GTROP,EQUOP !* %SWITCH T(0:127) !* ADDRCOM=COMAD COM==RECORD(COMAD) ADICT=COM_ADICT ANAMES=COM_ANAMES CONTROL=COM_CONTROL OPTIONS1=COM_OPTIONS1 OPTIONS2=COM_OPTIONS2 !* %IF CGEN INITIALISED=0 %THEN CGENSTART !* %IF 1<=CGENEP<=2 %THENSTART;! physical end of file FINISH(CGENEP) %RETURN %FINISH !* CODESTART=CODECA !* CGENINIT NEXT TRIAD = 1 ATRIADS=COM_ATRIADS !{2900C} ATRIADS=ADDR(TRIADS(0));! for diagnostic use {PERQC} %CYCLE I=0,1,3 {PERQC} HALFINTEGER (ATRIADS+I*256+255)=-1 {PERQC} BLOCKIN(I)=-1 {PERQC} %REPEAT EPILOGUE=NEW PLAB;! label to be jumped to at RETURN !* TRIAD LOOP: !* TR==RECORD(ADDR TRIAD(NEXT TRIAD)) SAVE TRIAD =NEXT TRIAD NEXT TRIAD=NEXT TRIAD+1 I=TR_OP ->T(TR_OP) !* !* T(NOOP): -> TRIAD LOOP !* T(STMT): I=TR_VAL2 %IF I=0 %THENSTART;! compiler defined label DECLARE PLAB(TR_OPD2) %FINISHELSESTART CODEOUT LINEST=TR_SLN %IF I = 1 %THENSTART;! user defined label LABREC==RECORD(ADICT+TR_OPD2<TRIAD LOOP !* T(ADD): !* T(SUB): !* T(NEG): !* T(MULT): !* T(DIV): ARITHOPS(TR_OP,TR_RES1,TR_RES2) ->TRIAD LOOP !* T(EXP): EXPFN(TR_RES1,TR_RES2) -> TRIAD LOOP !* T(ASGN): OP1(LDC0) LDC(NEXT ASS LAB) STORE VAL(TR_RES1) NEXT ASS LAB=NEXT ASS LAB+1 DICT SPACE(W4) SS==RECORD(ADICT+COM_DPTR) SS_INF0=TR_OPD2;! labid record SS_LINK1=ASSIGNED LABS ASSIGNED LABS=COM_DPTR COM_DPTR=COM_DPTR+W4 ->TRIAD LOOP !* T(ASMT): !* T(CVT): ASSIGN(TR_RES1,TR_RES2) ->TRIAD LOOP !* T(ARR): !* T(ARR1): !!! ARR ACCESS(TR_OP,TR_RES1,TR_RES2) ->TRIAD LOOP !* T(BOP): INARRAYSUBSCRIPT=YES ->TRIAD LOOP !* T(JINN): !* T(JINP): !* T(JINZ): !* T(JIN): !* T(JIP): !* T(JIZ): %IF ACCUSE#0 %THENSTART FREEACC TMP==RECORD(ADICT+ACCDESC) TMP_REG=2;! do not free loc %FINISH MODE=TR_MODE %IF TR_QOPD1=TMPID %OR TR_QOPD1=PERMID %THENSTART;! ensure value is retained in case subs test TR_QOPD1=PERMID;! to avoid freeing temp ALLOC TEMP(TR_OPD1);! to ensure it is stored %IF ACCUSE#0 %THEN FREEACC LOAD VAL(TR_RES1) %FINISHELSE LOAD VAL(TR_RES1) OP1(LDC0) I=TR_OP-JINN %IF I<3 %THEN OP=JFW %ELSE OP=JTW %IF MODE=INT2 %THENSTART OP1(ARITHIF2(I)) %FINISHELSESTART %IF MODE=INT4 %THEN J=LOPS %ELSE J=ROPS OP3(LDC0,J,ARITHIF4(I)) %FINISH K=GET LABEL ADDRESS(TR_QOPD2,TR_OPD2) OPW(OP,K) ->TRIAD LOOP !* T(GOTO): %UNLESS TR_QOPD1=LABID %OR TR_QOPD1=PLABID %THENSTART;! assigned GOTO LOAD VAL(TR_RES1) COERCE(TR_MODE,INT2);! for use in the switch to be used %IF ASSIGNED GOTOS=0 %THEN ASSIGNED GOTOS=NEW PLAB TR_QOPD1=PLABID TR_OPD1=ASSIGNED GOTOS %FINISH K=GET LABEL ADDRESS(TR_QOPD1,TR_OPD1) OPW(JMPW,K) ->TRIAD LOOP !* T(CGT): COMPUTED GOTO(TR_OPD2,0) ->TRIAD LOOP !* T(NOT): LOAD VAL(TR_RES1);! will be 32 bit logical OP3(LNOT,LDC1,LAND);! ensure only single bit setting SAVE LOG: SAVE RES(TMPID,GET TEMP(INACC,LOG4)>>DSCALE) -> TRIAD LOOP !* T(EQUIV): !* T(NEQ): LOAD VAL(TR_RES1);! will be 32 bit logical LOAD VAL(TR_RES2) OP2(LOPS,ADDOP) OP2(LDC1,LAND) %IF TR_OP=EQUIV %THENSTART OP3(LNOT,LDC1,LAND) %FINISH -> SAVE LOG !* T(GT): !* T(LT): !* T(NE): !* T(EQ): !* T(GE): !* T(LE): CONDMASK=TR_OP-GT;! may get modified for reverse ops %IF TR_MODE=CHARMODE %THENSTART CHAROP(TR_RES1,1,TR_RES2) %FINISHELSESTART ARITHOPS(1,TR_RES1,TR_RES2) %FINISH -> TRIAD LOOP !* T(JIT): !* T(JIF): %IF TR_QOPD1#TRIAD %THENSTART;! logop - test not adequate!! TJIF1: TR_MODE=INT2;! must load only 1 word LOAD VAL(TR_RES1) OP1(LDC0) %IF TR_OP=JIF %THEN OP=JEQW %ELSE OP=JNEW K=GET LABEL ADDRESS(TR_QOPD2,TR_OPD2) OPW(OP,K) %FINISHELSESTART OLDTR==RECORD(ADDR TRIAD(TR_OPD1)) %IF OLDTR_MODE=LOG4 %THEN ->TJIF1 %IF TR_OP=JIF %THEN OP=JFW %ELSE OP=JTW K=GET LABEL ADDRESS(TR_QOPD2,TR_OPD2) OPW(OP,K) %FINISH -> TRIAD LOOP !* T(STOD1): MODE=TR_MODE;! INT2 or INT4 LOAD VAL(TR_RES2);! initial RES1=TR_RES1;! in case STOD2 is generated STORE VAL(TR_RES1);! index ->TRIAD LOOP !* T(STOD2): LOAD VAL(RES1);! index LOAD VAL(TR_RES1);! final %IF MODE=INT2 %THEN OP1(GTRI) %ELSE OP2(LOPS,GTROP) PLAB==RECORD(ADICT+TR_OPD2) PLAB_REF=CODECA OPBB(JTW,0,0) ->TRIAD LOOP !* T(EOD1): RES1 = TR_RES1;! control var RES2 = TR_RES2;! increment -> TRIAD LOOP !* T(EOD2): LOAD VAL(TR_RES1);! final LOAD VAL(RES1);! index LOAD VAL(RES2);! increment %IF MODE=INT2 %THEN OP2(ADI,REPL) %ELSE OP3(LOPS,ADDOP,REPL2) STORE VAL(RES1) %IF MODE=2 %THEN OP1(GEQI) %ELSE OP2(LOPS,GEQOP) K=GET LABEL ADDRESS(PLABID,TR_OPD2) OPW(JTW,K) -> TRIAD LOOP !* T(EODA): RES1 = TR_RES1;! count var RES2 = TR_RES2;! endref label record -> TRIAD LOOP !* T(EODB): PLAB==RECORD(ADICT+RES2_H0) FILL JUMP(PLAB_REF) LOAD VAL(RES1);! INT4 OP2(LDC0,LDC1) OP3(LOPS,SUBOP,REPL2) STORE VAL(RES1) OP2(LDC0,LDC0) OP2(LOPS,GEQOP) K=GET LABEL ADDRESS(PLABID,TR_OPD2) OPW(JTW,K) -> TRIAD LOOP !* T(FUN): I=NO CPROC:CALL SUBPROG(I,TR_OPD1<TRIAD LOOP !* T(SUBR): I=YES ->CPROC !* T(ARG): ->TRIAD LOOP !* T(STOP): !* T(PAUSE): %IF TR_MODE=NULL %THENSTART;! no specified param OP3(LDC0,LDC0,LDC0) %FINISHELSESTART %IF TR_MODE=CHARMODE %THENSTART J=TR_OPD1 I=ALLOC CHAR(INTEGER(ADICT+J),J+W2,IIN,K) OP1(LSSN) LOA(I) OP1(LDC2) %FINISHELSESTART TR_QOPD1=LIT LOAD ADDRESS(TR_RES1) OP1(LDC1) %FINISH %FINISH OP2(MMS,MMS2) %IF TR_OP=STOP %THEN SYSCALL("F77STOP") %C %ELSE SYSCALL("F77PAUSE") ->TRIAD LOOP !* T(RET): %IF TR_QOPD1=NULL %THENSTART OP1(LDC0);! in case variable return %FINISHELSESTART LOAD VAL(TR_RES1) VARIABLE RETURN=YES COERCE(TR_MODE,INT2) %FINISH STO(VRETURN WORD) K=GET LABEL ADDRESS(PLABID,EPILOGUE) OPBB(JMPW,0,0) ->TRIAD LOOP !* !* T(STRTSF): STATFN ENTRY=CODECA ->TRIAD LOOP !* T(ENDSF): STATFN REC=TR_OPD1 STATFN==RECORD(ADICT+STATFN REC) I=RT DEFN(0,0,STATFN ENTRY,2,0,0) ID="F_STATFN" QPUT(11,NEXT RTNO,I,ADDR(ID)) STATFN_IIN=NEXT RTNO NEXT RTNO=NEXT RTNO+1 PP==RECORD(ADICT+COM_SUBPROGPTR);! must update proc entry PLAB==RECORD(ADICT+PP_DISP);! past statement function PLAB_CODEAD=CODECA %CYCLE I=1,1,9 TEMPST(I)=0;! abandon temp locs to avoid conflict %REPEAT ->TRIAD LOOP !* T(CALLSF): FREEACC STATFN==RECORD(ADICT+TR_OPD1) RES1_W=STATFN_LINK2 %IF STATFN_TYPE=CHARTYPE %THENSTART I=ALLOC CHAR(STATFN_LEN,0,IIN,J) LOA(RES1_H0) LOA(I) OPB(MOVB,4) %FINISH OPB(CALL,STATFN_IIN) %IF TR_MODETRIAD LOOP !* T(STRTIO): IO STAT(TR_OPD2) ! STARTIO ->TRIAD LOOP !* T(IOITEM): IO LIST ITEM(TR_RES1) ->TRIAD LOOP !* T(IODO): STARTIO ->TRIAD LOOP !* T(IOSPEC): IO SPEC CLAUSE(TR_QOPD2,TR_OPD2,TR_RES1) ->TRIAD LOOP !* T(IO): CALL IO(TR_MODE,TR_QOPD1,TR_OPD1) ->TRIAD LOOP T(SUBSTR): !* T(CONCAT): !* T(CHAR): !* T(CHHEAD): ->TRIAD LOOP !* T(EOT): SUBPROGEND %RETURN !* %INTEGERFN NEW PLAB !*********************************************************************** !* Provide a new dict record for a private label * !*********************************************************************** %RECORD(PLABF)%NAME PLAB %INTEGER I DICT SPACE(PLABRECSIZE) I=COM_DPTR COM_DPTR=COM_DPTR+PLABRECSIZE PLAB==RECORD(ADICT+I) PLAB_INDEX=COM_NEXT PLAB PLAB_CODEAD=0 PLAB_REF=0 PLAB_REFCHAIN=0 COM_NEXT PLAB=COM_NEXT PLAB+1 %RESULT=I %END;! NEW PLAB !* %ROUTINE DECLARE PLAB(%HALFINTEGER PTR) %RECORD(PLABF)%NAME PLAB PLAB==RECORD(ADICT+PTR) PLAB_CODEAD=CODECA %IF PLAB_REF#0 %THEN FILL JUMP(PLAB_REF) SPTR=PLAB_REFCHAIN %WHILE SPTR#0 %CYCLE SS==RECORD(ADICT+SPTR) FILL JUMP(SS_INF0) SPTR=SS_LINK1 %REPEAT %END !* %INTEGERFN GET LABEL ADDRESS(%INTEGER LABTYPE,LABRECAD) %RECORD(SRECF)%NAME SS %RECORD(LABRECF)%NAME LABREC %RECORD(PLABF)%NAME PLAB %INTEGER AD DICT SPACE(W4) %IF LABTYPE=LABID %THENSTART LABREC==RECORD(ADICT+LABRECAD<