!* MODIFIED 12/04/82 !{2900C}%CONSTINTEGER W1=2;! 1 PERQ 2 EMAS !{2900C}%CONSTINTEGER W2=4 !{2900C}%CONSTINTEGER W3=6 !{2900C}%CONSTINTEGER W4=8 !{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 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 DORECF( %C %INTEGER LABEL, LINK1, LOOPAD, ENDREF, %RECORD(RESF) INDEXRD, INCRD, FINALRD, ICRD, %INTEGER LABLIST,LINE) !* %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 LRECF(%INTEGER NOTFLAG,LINK1,ORLIST,ANDLIST,RELOP) !* %RECORDFORMAT IFRECF(%INTEGER TYPE,LINK1,ENDIFJUMP,FALSELIST, %C LABLIST,LINE) !* %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 IMPDORECF(%INTEGER VAL,LINK,IDEN) !* %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 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) !* %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 FAULT(%INTEGER ER) %EXTERNALINTEGERFNSPEC ALLOCCHAR(%INTEGER L,AD,%HALFINTEGERNAME IIN, %INTEGERNAME DISP) %EXTERNALROUTINESPEC DICFUL {PERQC}%EXTERNALROUTINESPEC READBLOCK(%HALFINTEGER FILEID, BLOCK,%INTEGER AD) !* !* !* !* %OWNINTEGER LINEST %OWNINTEGER LISTCODE %OWNINTEGER CGEN INITIALISED=0 %OWNINTEGER ACCUSE,ACCDESC %OWNINTEGER CHECKS %OWNRECORD(RESF) RES %OWNINTEGER EXPWORK %OWNINTEGER STATMAPHEAD,CURSTATMAP,STATMAPINDEX,STATCOUNT %OWNINTEGER PCT %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 TPUSEDFLAG %OWNINTEGER UNASSCHECKS %OWNINTEGER ARGCHECKS %OWNINTEGER CHARCHECKS %OWNINTEGER CALLSPEC %OWNINTEGER PROC PARLIST %OWNINTEGER LINKFAULTS %OWNINTEGER ARGFAULTS !* %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 STACKBASE) !* !* !* !* %EXTERNALINTEGER PARCHECKS !* %OWNINTEGER VARIABLE RETURN,RETURN LIST %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 !* %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 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) %HALFINTEGER 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) %HALFINTEGER I I=CODECA-INST ADDR-3 QPUT(18,0,INST ADDR+1,I) %END;! FILL JUMP !* !* !* !*************************************************************************************************************** !*************************************************************************************************************** !* !* !* !{2900C}%OWNINTEGERARRAY EXTAREA(0:255) %OWNINTEGER AREFDATA,MAX REFDATA,CUR REFDATA %OWNINTEGER ENTRIES,REFS !* %RECORDFORMAT EXTF(%INTEGER LINK,(%INTEGER RTNO %OR %INTEGER REFCHAIN), %INTEGER LINENO,PDESC LEN,PDESC AD, %STRING(8) NAME) %RECORDFORMAT CHAINF(%INTEGER LINK,AD) !* %CONSTINTEGER EXTFLEN=32 %CONSTINTEGER REFCHAINLEN=8 !* %INTEGERFN EXT SPACE(%HALFINTEGER LEN) %INTEGER I I=CUR REFDATA CUR REFDATA=CUR REFDATA+LEN %IF CUR REFDATA>MAX REFDATA %THEN %MONITOR %AND %STOP %RESULT=AREFDATA+I %END !* %ROUTINE INIT EXT CUR REFDATA=0 MAX REFDATA=1024 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 %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) EXT==RECORD(I) EXT_NAME=NAME EXT_LINK=ENTRIES ENTRIES=I EXT_RTNO=RTNO EXT_LINENO=LINENO !**************************************** note pdesc for subs checking EXT_PDESC LEN=0 EXT_PDESC AD=0 %RESULT=0 %END;! NOTE ENTRY !* %EXTERNALHALFINTEGERFN NOTE REF(%STRING(32) NAME,%INTEGER ADREF, LINENO,PDESC LEN,PDESC AD) %RECORD(EXTF)%NAME EXT %RECORD(CHAINF)%NAME CHAIN %INTEGER I,J %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 EXT_REFCHAIN=J CHAIN_AD=ADREF %RESULT=0 %FINISH I=EXT_LINK %REPEAT I=EXT SPACE(EXTFLEN) EXT==RECORD(I) EXT_NAME=NAME EXT_LINK=REFS REFS=I EXT_REFCHAIN=0 !****************************** check param desc correspondence EXT_PDESC LEN=0 EXT_PDESC AD=0 ->ADD REF %END;! NOTE REF !* %EXTERNALROUTINE SAT REFS %INTEGER I,J,K %BYTEINTEGER B0,B1,B2,B3 %RECORD(EXTF)%NAME REF %RECORD(EXTF)%NAME ENT %RECORD(CHAINF)%NAME CHAIN I=REFS %WHILE I#0 %CYCLE REF==RECORD(I) J=ENTRIES %WHILE J#0 %CYCLE ENT==RECORD(J) %IF REF_NAME=ENT_NAME %THENSTART !{2900C} B0=186 !{2900C} B1=ENT_RTNO {PERQC} B1=186;! call {PERQC} B0=ENT_RTNO B2=93;! no-op B3=93;! no-op K=REF_REFCHAIN %WHILE K#0 %CYCLE CHAIN==RECORD(K) QPUT(41,4,CHAIN_AD,ADDR(B0)) K=CHAIN_LINK %REPEAT ->NEXT REF %FINISH J=ENT_LINK %REPEAT !****************************************** report to QPUT NEWLINE PRINTSTRING("Unsatisfied reference ") PRINTSTRING(REF_NAME) NEWLINE NEXT REF:I=REF_LINK %REPEAT !* !********************************* define entries to QPUT !* %END;! SAT REFS !* !* %EXTERNALROUTINE CODEGEN(%INTEGER CGENEP, %RECORD(TRIADF) %ARRAYNAME TRIADS, %INTEGER COMAD) %ROUTINESPEC RTERROR(%INTEGER ERR) %ROUTINESPEC SUBPROGEND %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,IODISPS1,IODISPS2,IOSTARTED %OWNINTEGER ATRIADS,RESULT WORDS,PARAM WORDS %OWNINTEGER LINENO WORD %HALFINTEGER EPILOGUE %INTEGER SPTR %HALFINTEGER TCTBASE,IOMARKERS,IOKEY,IOINDEX %HALFINTEGER MODE,CONDMASK,EL LEN %INTEGER IODSNUM,PROCEP,PCUNASS %INTEGER ASSIGNED GOTOS,ASSIGNED LABS,NEXT ASS LAB %INTEGER STATFN ENTRY,STATFN REC %HALFINTEGERARRAY BLOCKIN(0:3) %RECORD(TMPF)%NAME TMP %RECORD(COMFMT)%NAME COM %RECORD(TRIADF)%NAME TR %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) !* !* %ROUTINESPEC ASSIGNED LIST %ROUTINESPEC COPYPARS(%INTEGER AREC,MODE) %ROUTINESPEC LOADDATA !* %OWNINTEGER ASL3 !* %INTEGERFN FREESP3 !*********************************************************************** !* OBTAIN 3-WORD(32 BIT) LIST ITEM. SET PTR AND MAP SS RECORD * !*********************************************************************** %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} READBLOCK(COM_TRFILEID,J,AD) {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 %INTEGER DISP,AD %SWITCH F(0:21) D=R_H0 PP==RECORD(ADICT+D) ->F(R_FORM&X'FF') !* F(LIT): OP1(LDC0) LDC(D) LITAD:AD=STACKCA STACKCA=STACKCA+2 STORE:STL(AD) STL(AD+1) LOCAD:OP1(LSSN) LLA(AD) %RETURN !* 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)) AD=STACKCA STACKCA=STACKCA+4 STL(AD+2) STL(AD+3) %FINISH ->LITAD !* F(TMPID): !* F(PERMID): TMP==RECORD(ADICT+D) AD=TMP_ADDR ->LOCAD !* 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): !*** USERREF(STRING(ANAMES+PP_IDEN)) %RETURN !* F(ARREL): ARR ACCESS(D,1);! index to triad describing array element %RETURN %END;! LOAD ADDRESS !* %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) FREETEMP(D) %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(OSCALID): PP==RECORD(ADICT+D) D=PP_ADDR4 F(GLALIT): %IF WORDS=2 %THEN LDO(D+1) LDO(D) TEST: %IF WORDS=2 %AND UNASSCHECKS=YES %THENSTART OP3(REPL2,LDDC,X'80') OP3(X'80',X'80',X'80') OP2(LOPS,EQUOP) OPW(JTW,PCUNASS-CODECA-3) %FINISH %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 %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) 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, 2, 4, 5, 6, 3, 14, 12, 10, 9, 13, 11 %CONSTBYTEINTEGERARRAY REVCMP(0:6) = 0, 2, 1, 4, 3, 6, 5 !* %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!RESR_MODE>CMPLX8 %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 %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 %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 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,0) PWORD(X'4000');! 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) OP2(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,0) PWORD(X'4000') OP3(MES2,ROPS,DIVOP);! invert real result %FINISH ->SETRES %FINISHELSESTART;! ** OPB(ATPB,2);! reserve space for result OP1(MMS2) OP3(LDC0,LDC1,MMS2) LOAD VAL(RESR) OP1(MMS2) OP3(LDC0,LDC1,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 * !* set EL LEN = element length or 0 (for *(*) ) if char * !*********************************************************************** %RECORD(TRIADF)%NAME TR %RECORD(ARRAYDVF)%NAME DVREC %RECORD(PRECF)%NAME ARRAYREC %RECORD(RESF)%ARRAY SUBSCRIPT(0:7) %INTEGER PCT,I,J,L,PTR %HALFINTEGER ADV,H %IF LHS=YES %AND 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) PCT=DVREC_DIMS ADV=DVREC_ADDRDV %IF LHS=2 %THENSTART;! param required OP3(LDTP,ATPB,2) %FINISH LOA(ADV);! @ of dv in global OP1(LDDW);! array base @ %IF TR_QOPD2=LIT %THENSTART;! must be short I=TR_OPD2-DVREC_ZEROTOFIRST %IF I=0 %THENSTART %IF LHS=2 %THENSTART LOA(ADV+2) OP3(LDDW,MMS2,STDW) %FINISH %RETURN %FINISHELSE LDC(I) %FINISHELSESTART LOAD VAL(TR_RES2) OP2(LOPS,I4TOI2) LDC(DVREC_ZEROTOFIRST) OP1(SBI) %FINISH %IF LHS=2 %THENSTART OP3(REPL,LDC0,EXCH) LOA(ADV+2) OP2(LDDW,EXCH2) OP3(LOPS,SUBOP,MMS2) %FINISH OP1(IXA2) %IF LHS=2 %THEN OP1(STDW) !!# %IF TYPE=ARR %THENSTART !!# %IF COM_ARRAYCHECKS#NO %OR ARRAYREC_TYPE=5 %THENSTART !!# %IF ARRAYREC_CLASS&X'40'=0 %THENSTART;! NO ADJUSTABLE DIMS !!# I=DVREC_ZEROTOFIRST !!# J=LIT !!# %FINISHELSESTART !!# I=ARRAYREC_TYPE !!# %IF I&15=3 %OR I=5 %OR I=X'41' %THENSTART;! COMPLEX,CHAR OR I*2 !!# FREEACC !!# PLANTOP(LSS,STKLIT,DVREC_ADDRDV+8);! ZEROTOFIRST !!# %IF I=5 %THENSTART;! CHAR !!# PLANTOP(IDV,STKLIT,DVREC_ADDRDV-4);! DIVIDE BY ELEMENT SIZE !!# %FINISHELSE OPLITT(USH,-1);! REQUIRED IN COMPLEX ELS OR BYTES !!# I=STACKCA-STACKBASE !!# OPLNB(ST,I) !!# PUTWORD(7,0) !!# %FINISHELSESTART !!# I=DVREC_ADDRDV+8 !!# %FINISH !!# J=STKLIT !!# %FINISH !!# %IF I#0 %THENSTART !!# %IF J=LIT %AND (RESR_FORM=LIT %OR RESR_FORM=NEGLIT) %C !!# %THENSTART !!# K=RESR_H0 !!# %IF RESR_FORM=NEGLIT %THEN K=-K !!# K=K-I !!# %IF K<0 %THEN K=-K %AND J=NEGLIT !!# RESR_H0=K !!# RESR_FORM=J !!# %FINISHELSESTART !!# ARITHOPS(3,RESR_FORM,RESR_H0,J,I,INT4) !!# RESR=TRIADS(SAVETRIAD)_RES1 !!# %FINISH !!# %FINISH !!# %FINISH !!# SS_INF0=0;! to indicate 'old' form !!# %FINISHELSESTART !!# MOVE(PCT<<2,ADICT+RESR_H0<1 %THENSTART !!# %IF I=PCT %THEN L=LSS %ELSE L=IAD !!# OPBREG(L) !!# %FINISH !!# %REPEAT !!# %UNLESS PCT=1 %THEN OPBREG(ST) !!# RESR_H0=GET TEMP(INBREG,INT4)>>DSCALE !!# RESR_FORM=TMPID !!# RESR_MODE=INT4 !!# %FINISH !!# SS_LINK1=RESR_W;! R.D. to subscript !!# RESL_FORM=ARREL !!# RESL_H0=PTR>>DSCALE !!# TRIADS(SAVETRIAD)_RES1=RESL;! RESULT DESCRIPTOR FOR ARRAY ELEMENT !!# %IF CMPLX8<=RESL_MODE<=CMPLX32 %THEN FREE B REG;! AVOID CONFUSION OVER SUBSCIPTING !!# ! COMPLEX ARRAY ELEMENTS !!# INARRAYSUBSCRIPT=NO %END;! ARR ACCESS !* !* %INTEGERFN SET CHAR DESC(%RECORD(RESF) RRES,%HALFINTEGER COPY) !*********************************************************************** !* RRES IS RD FOR CHAR CONST, SCALAR OR ARRAY ELEMENT * !* Load Estack with pointer to character descriptor * !* copy = 0 @ actual descriptor for a scalar * !* 1 @ copy of descriptor (because substring) !* Sets result = length of char value if known * !* 0 if (*) length * !*********************************************************************** %HALFINTEGER FORM,IIN %INTEGER A,DISP %RECORD(PRECF)%NAME PP %RECORD(ARRAYDVF)%NAME DVREC %RECORD(CONRECF)%NAME CON FORM=RRES_FORM A=RRES_H0 %IF FORM=TRIAD %THENSTART;! must be array el ARR ACCESS(RRES_H0,0);! @ desc to Estack %RESULT=EL LEN;! element length or 0 (if *(*) ) %FINISH OP1(LSSN) %IF FORM=CNSTID %THENSTART;! CONST RECORD CON==RECORD(ADICT+A) EL LEN=INTEGER(ADICT+CON_DADDR) I=ALLOC CHAR(EL LEN,CON_DADDR+W2,IIN,DISP) LOA(I) %RESULT=EL LEN %FINISH %IF FORM=GLALIT %THENSTART;! stat fn LOA(A) %RESULT=0;! len is available in desc %FINISH PP==RECORD(ADICT+A) %IF FORM=ARRID %THENSTART;! CHAR ARRAY DVREC==RECORD(ADICT+PP_ADDR4) LOA(DVREC_ADDRDV) %RESULT=PP_LEN %FINISH %IF COPY=1 %THENSTART;! copy may be needed for descs to scalars (if substring) LLA(STACKCA) STACKCA=STACKCA+6 OP1(REPL) LOA(PP_DISP) OPB(MOVB,6) %FINISHELSE LOA(PP_DISP) %RESULT=PP_LEN %END;! SET CHAR DESC !* %HALFINTEGERFN CHAR SUBSTRING(%RECORD(RESF) CHRES,RESL,RESR) !*********************************************************************** !* CHRES result descriptor for char scalar,const or array el * !* RESL result descriptor of lower substring bound * !* RESR result desriptor of upper substring bound * !* Calls SET CHAR DESC to load Estack with @ string descriptor - this * !* sets RES = 0 (*) length specification * !* #0 character item length * !* Carries out necessary checks and updates character descriptor, * !* the address of which is retained in Estack * !*********************************************************************** %HALFINTEGER I,MAXLEN %IF RESL_FORM=TRIAD %THEN RESL_FORM=EXTRIAD(RESL_H0,I,0) %IF RESR_FORM=TRIAD %THEN RESR_FORM=EXTRIAD(RESR_H0,I,0) MAXLEN=SET CHAR DESC(CHRES,1);! must be a descriptor which can be modified %IF RESR_FORM#NULL %THENSTART;! unless :) OP3(REPL,LDC3,ADI);! @ length word (only need disp - on stack) RESR_MODE=INT2 LOAD VAL(RESR) %IF (RESR_FORM#LIT %OR MAXLEN=0) %AND CHARCHECKS=YES %THENSTART OP3(REPL2,EXCH,LDIND) OP1(GTRI) RTERROR(CHARFAULT);! if rhs > len %FINISH OP1(STIND) %FINISH !* %IF RESL_FORM#NULL %THENSTART;! unless (: OP2(REPL,REPL2);! 3 words to be updated OP2(LDC3,ADI);! @ len RESL_MODE=INT2 LOAD VAL(RESL) %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,LDC2) OP1(LEQI) RTERROR(CHARFAULT);! if lhs <= 0 %FINISH OP3(REPL2,EXCH,LDIND) OP1(GTRI) RTERROR(CHARFAULT);! lhs > len %FINISH OP3(REPL,REPL,MES2) OP3(MES,REPL,LDIND) OP3(MMS,SBI,STIND);! len = len - lhs OP3(LDC2,ADI,REPL) OP3(MMS,ADI,STIND);! disp = disp + lhs OP3(LDC4,ADI,REPL) OP3(MMS,SBI,STIND);! balance = balance - lhs %FINISH !* %RESULT=0;! provide actual length if known !* %END;! CHAR SUBSTRING !* %INTEGERFN CONCAT CHARS(%HALFINTEGER LINK,CHINDEX,MODE) !* if RES is a concatenation list then form new value %INTEGER I,J,K,SIZE,NUM,ADJ,TARGET,PTR %RECORD(CHARF)%NAME CH !!# %IF RES_H1#CHVAL<<8!CHARMODE %THEN %RESULT=RES_W !!#!* !!# I=RES_H0 !!# ADJ=0 !!# SIZE=0 !!# NUM=0 !!# %WHILE I#0 %CYCLE !!# CH==RECORD(ADICT+I<512 %THENSTART;! USE PRIVATE AREA !!# FREEREGS !!# TARGET=STACKCA-STACKBASE !!# PUTDESC(7,0,0) !!# OPLITT(PRCL,4) !!# OPLITT(LSS,TARGET) !!# OPLNB(IAD,4) !!# OPLITT(LUH,13) !!# OPLITT(SLSS,0) !!# OPTOS(ST) !!# OPLNB(LCT,16) !!# OPLITT(RALN,8) !!# PLF1(CALL,DESC,CTB,FAUXREF) !!# FREEREGS !!# XNBTOSTACK !!# %FINISHELSESTART !!# TARGET=ALLOC CHAR(SIZE,0,J);! J is location (not needed) !!# ! TARGET is desc @ on stack !!# %FINISH !!# K=GLACA !!# PUTBYTES(2,(NUM+1)<<3,0) !!# J=K+8 !!# PUTDESC(7,0,0) !!# TARGET=TARGET+8 !!# OPLNB(LD,TARGET-8) !!# OPLNB(STD,TARGET);! COPY MADE IN CASE ACTUAL LENGTH GETS MODIFIED !!# OPLT(STD,K) !!# I=RES_H0 !!# %WHILE I#0 %CYCLE !!# CH==RECORD(ADICT+I<>DSCALE !!# %RESULT=RES_W %END;! CONCAT CHARS !* %HALFINTEGERFN LOCATE CHAR DESC(%HALFINTEGER INDEX,MODE) !*********************************************************************** !* INDEX is a triad index * !* 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 TR==RECORD(ADDR TRIAD(INDEX)) %IF TR_OP=CHHEAD %THENSTART;! concat list LEN=CONCAT CHARS(TR_OPD1,TR_OPD2,MODE) %RESULT=MODE %FINISHELSESTART %IF TR_QOPD2#NULL %THENSTART;! substring TR2==RECORD(ADDR TRIAD(TR_OPD2)) LEN=CHAR SUBSTRING(TR_RES1,TR2_RES1,TR2_RES2) %FINISHELSESTART LEN=SET CHAR DESC(TR_RES1,0) %FINISH %RESULT=0 %FINISH %END;! LOCATE CHAR DESC !* %ROUTINE CHAROP(%RECORD(RESF) RESL,%INTEGER OP,%RECORD(RESF) RESR) %HALFINTEGER I,MODE,LEN %IF OP=1 %THEN LDC(CONDMASK) %AND OP1(MMS) OP3(LDTP,ATPB,4) %IF RESL_FORM=TRIAD %THENSTART;! concat or substring I=LOCATE CHAR DESC(RESL_H0,0) %FINISHELSE LEN=SET CHAR DESC(RESL,0);! char const,scalar or array el OP3(TLATE1,MOVB,4);! lhs to stack OP3(LDTP,ATPB,4) %IF RESR_FORM=TRIAD %THENSTART %IF OP=1 %THEN MODE=0 %ELSE MODE=1 I=LOCATE CHAR DESC(RESR_H0,MODE);! result is 1 if concat %FINISHELSESTART LEN=SET CHAR DESC(RESR,0) I=0 %FINISH OP3(TLATE1,MOVB,4) %IF OP=1 %THENSTART;! comparison SYSCALL("F77CHREL") OP1(EQUI);! will set appropriate result condition %FINISHELSESTART %IF I=0 %THENSTART;! simple assign SYSCALL("F77COPY") %FINISHELSESTART SYSCALL("F77CONCAT") %FINISH %FINISH %END;! CHAROP !* !* %ROUTINESPEC INLINE1(%INTEGER FNTYPE,INDEX,%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 %HALFINTEGER I,J,K,LOOP,PASCALPROC,PARAMDESC,IIN %INTEGER NUMELS,AD,II;! allow 32 bit value %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) !* !!# %IF RD_H1=CHVAL<<8!CHARMODE %THEN RD_W=CONCAT CHARS(RD) 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=1 %ELSE PASCALPROC=0 MODE=0;! to avoid unass check prior to exit PARAMDESC=MODETOST(RD_MODE) NUMELS=1 -> F(FORM) !* !****** CONST RECORD F(CNSTID): CON == RECORD(ADICT+A) MODE=CON_MODE BYTES=MODETOBYTES(MODE) %IF CHARMODE<=MODE<=HOLMODE %THENSTART;! char or Holerith I=INTEGER(ADICT+CON_DADDR) K=CON_DADDR+W2 %IF MODE=HOLMODE %THEN PARAMDESC=6 I=ALLOC CHAR(I,K,IIN,AD) LOA(I);! @ of char descriptor MOVE TO MS(6) %FINISHELSE ->SCALAD ADPAR:%IF FNTYPE=0 %THEN ADD PAR(PARAMDESC,FNPTR);! for user subprogs only %RETURN !* !****** SHORT LITERAL F(LIT): !****** local F(LSCALID): !****** scalar in global area F(OSCALID): !****** DICT RECORD FOR SCALAR IN COMMON F(CSCALID): !****** SCALAR IN ARRAY AREA F(ASCALID): SCALAD:LOAD ADDRESS(RD) OP1(MMS2) %IF FNTYPE<=1 %THENSTART;! USER OR OUT OF LINE FN OP3(LDC0,LDC1,MMS2);! single element STACKFRAME=STACKFRAME+4 %FINISHELSE STACKFRAME=STACKFRAME+2 ->ADPAR !* !****** 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<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 ID="F77".VARIANT(J).GEN NAME(II>>24) QPUT(12,1,CODECA,ADDR(ID)) OPW(LVRD,1) OP2(0,0) %FINISHELSE USER REF(PP_IDEN,0,0,0);! load variable routine descriptor OP2(MMS2,MMS2) %FINISHELSESTART; ! PARAM SUBPROG OP1(LSSN) LOA(PP_ADDR4);! address of variable routine desc (param) MOVE TO MS(4) %FINISH ->ADPAR !* !****** ARRAY ELEMENT F(ARREL): %IF TYPE=CHARTYPE %THENSTART;! CHAR J=SET CHAR DESC(RD,1) MOVE TO MS(6) STACKFRAME=STACKFRAME+6 %FINISHELSESTART ARR ACCESS(RD_H0,2);! compute address of array element and store ! on Mstack with balance of number of els STACKFRAME=STACKFRAME+4 %FINISH ->ADPAR !* !!#!****** CHAR SCALAR !!#F(CHVAL): !!# CH==RECORD(ADICT+A<CHDESC !* !* %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 %HALFINTEGERARRAY T(0:511) %RECORD(RESF) R %RECORD(TRIADF)%NAME TR %RECORD(CHARF)%NAME CH %HALFINTEGER I,J,K,P2,PTR,RESLOC,RESWORDS,PCOUNT,IIN %INTEGER II %INTEGER AD %SWITCH C(0:3) !* 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) LOA(RESLOC) MOVE TO MS(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,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 !!# I = FN_ADDR4; ! ADDRESS OF GLA REF OR INDEX FOR 'PERM' FUNCTION 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 I=NOTE REF(STRING(ANAMES+FN_IDEN),CODECA,LINEST, PCOUNT+2,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 PTR=FREESP3 CH==RECORD(ADICT+PTR) CH_ADESC=RESLOC CH_LEN=FN_LEN SAVE RES(CHVAL,PTR) %FINISHELSESTART %IF K#CMPLXTYPE %THENSTART; ! NOT COMPLEX SAVE RES(TMPID,GET TEMP(INACC,TR_MODE)>>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 %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(0)=I HEAD==RECORD(ADICT+PROC PARLIST) NEXT=HEAD_INF0 FREE LIST CELL3(PROC PARLIST) PCOUNT=0 %WHILE NEXT#0 %CYCLE SS==RECORD(ADICT+NEXT) PCOUNT=PCOUNT+1 T(PCOUNT+1)=SS_INF0 FREE LIST CELL3(NEXT) %REPEAT %IF STDFN=YES %THEN %RESULT=NO;! has served to free list cells T(1)=PCOUNT !***************************** RECORD PARAM DESC LIST SUBS CHECKING %RESULT=YES %END;! SET TEMPLATE !* %END;! CALL SUBPROG !* !* !* !* !* %INTEGERFN DESC TO VAR(%RECORD(RESF) RD,%INTEGER REQUIRED MODE,AD) %RECORD(PRECF)%NAME PP %RECORD(PRECF)%NAME CMNEL %RECORD(PRECF)%NAME CMNBLK %RECORD(RESF) RR %INTEGER A,F,D0,I,J,K !!# CTBTOGLA !!# %UNLESS RD_MODE = REQUIRED MODE %THEN %RESULT=1 !!# J=AD !!# A=RD_H0 !!# F=RD_FORM !!# %IF REQUIRED MODE # CHARMODE %THENSTART !!# I=MODETOST(RD_FORM)>>4 !!# %UNLESS 5<=I<=6 %THEN %RESULT=1 !!# D0=X'58000000'!(4<<(I-5)) !!# %FINISHELSE D0=0 !!# PLUGWORD(2,J,D0) !!# PP==RECORD(ADICT+A<OUT %RESULT=1 %END;! DESC TO VAR !* %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,%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=CHARMODE %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) 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) %RETURN !* 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=2;! JCC VALUE !!# ->MAXMIN !!#!* !!#FN(20): ! MIN + MIN0,AMIN1,DMIN1 !!#!* !!#FN(21): ! AMIN0 !!#!* !!#FN(22): ! MIN1 !!#!* !!# L=4;! JCC VALUE !!#MAXMIN:J=(STACKFRAME-7)>>1;! NO. OF PARAMS - 1 !!# %IF PMODE<4 %THEN I=LSS %ELSESTART !!# %IF PMODE=4 %THEN I=LSD %ELSE I=LSQ !!# %FINISH !!# %IF PMODE=2 %THEN I=LSD;! TO COPE WITH I8 OPTION !!# %IF PMODE<3 %THEN K=ICP %ELSE K=RCP !!# %IF J>1 %THEN OPLITT(LB,J) !!# PLF1(I,DESC,TOS,0) !!# PLF1(K,DESC,TOS,0) !!# M=3 !!# PF3(JCC,L,0,M) !!# PLF1(I,DESC,DRVAL,0) !!# M=-4 !!# %IF J>1 %THEN OPLITT(DEBJ,M) !!# COERCE(PMODE,FMODE) %UNLESS PMODE=0;! I*2 FN RESULT IS I*4 !!# BREGUSE=0 !!# ACCUSE=0 !!# ->SETRES2 SETRES1: SETRES2: ACCDESC=GET TEMP(INACC,FMODE) ACCUSE=-1 SAVERES(TMPID,ACCDESC) %RETURN !!#!* !!#FN(7): ! ICHAR !!# FREEREGS !!# SET CHAR DESC(PARAMRES,LD,0) !!# OPLITT(LDB,1) !!# PLF1(LSS,DESC,DRVAL,0) !!# ->SETRES2 !!#!* !!#FN(8): !CHAR !!# FREEREGS !!# I=STACKCA !!# PUTDESC(7,X'58000001',I+8);! CHARDESC !!# LPUT(19,7,I+4,7) !!# PUTWORD(7,0) !!# OPLITT(USH,24) !!# J=I-STACKBASE !!# OPLNB(ST,J+8) !!# PTR=FREESP3 !!# CH==RECORD(ADICT+PTR) !!# CH_ADESC=J !!# CH_LEN=1 !!# RES_H0=PTR>>DSCALE; RES_H1=CHVAL<<8!CHARMODE !!# %RETURN !!#!* !!#FN(23): ! LEN !!# FREEREGS !!# SET CHAR DESC(PARAMRES,LSD,0) !!# OPTOS(STUH) !!# OPTOS(LSS) !!# OPLITT(USH,8) !!# OPLITT(USH,-8) !!# ->SETRES2 !!#!* !!#FN(24): ! INDEX !!# FREEREGS !!# SET CHAR DESC(PARAMRES,LSD,0) !!# OPTOS(LD) !!# OPLITT(PRCL,4) !!# OPTOS(STD) !!# OPTOS(ST) !!# CALL PROC("ICL9CEFINDEX",9,1) !!# ->SETRES2 !* %END;! INLINE1 !* %ROUTINE CMPLX TO MS(%RECORD(RESF) R) LOAD ADDRESS(R) %IF R_FORM>=CMPLX8 %THENSTART MOVE TO MS(4) %FINISHELSESTART OP2(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>3 %THEN OP1(LSSN) LLA(TMP_ADDR) %IF OP>3 %THEN OP1(MMS2) %ELSE OP1(REPL) %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(MMS2,ROPS,QOP);! r1 op r2 %IF RF>= 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 %THEN OP2(REPL2,MMS2) OP2(TLATE1,LDDW);! load real part OP2(TLATE3,STDW);! store %IF LF>=CMPLX8 %THENSTART OP2(LDC2,ADI);! @ complex result %IF RF>=CMPLX8 %THENSTART OP3(MES2,LDC2,ADI);! @ complex part OP2(TLATE1,LDDW);! load complex part %FINISHELSESTART OP2(LDC0,LDC0);! or zero %FINISH OP2(TLATE3,STDW);! store %FINISH %RETURN !* S(8):!** %RETURN !* %END !* !* !* !****************************************************************************** !* * !* OBJECT FILE RED TAPE AND DIAGNOSTIC TABLES * !* * !****************************************************************************** !* %ROUTINE LOADDATA %INTEGERFNSPEC PUTNAME(%INTEGER AD) %ROUTINESPEC DEFER(%INTEGER FLAGS,AD) %HALFINTEGER I, J, K, REFAD, STARTST,DIAGS,PCTABLE %HALFINTEGER QPTR,PPTR,CNT,TOTCNT,CNTLOC,TOTCNTLOC,DEFLIST %HALFINTEGER PTR %INTEGER IDENAD %INTEGER II;! required for cycles %INTEGER AD,LEN %RECORDFORMAT HHF(%HALFINTEGER L,R) %RECORD(HHF) HH %RECORD(SRECF)%NAME SS %RECORD(PRECF)%NAME PP %RECORD(PRECF)%NAME QQ %RECORD(ARRAYDVF)%NAME DVREC !* DEFLIST=0 !* DIAGS=4 !* !*****COMMON AREAS - DEFINE IN BLOCKDATA, OTHERWISE REFERENCE !* PPTR = COM_CBNPTR %WHILE PPTR # 0 %CYCLE PP == RECORD(ADICT+PPTR); ! MAPS TO COMMON BLOCK RECORD PTR = PP_LINK2; ! LINK TO FIRST ITEM IN COMMON AREA %IF PTR#0 %THENSTART;! CHECK NEC. IN CASE ERR IN DECL. QQ==RECORD(ADICT+PTR) ALLOC(PTR) PP == RECORD(ADICT+PPTR); ! BACK TO COMMON BLOCK LEN = PP_CMNLENGTH LEN = (LEN+7)&X'FFFF8' IDENAD=ANAMES+PP_IDEN II=QQ_IIN II=II<<16 %IF COM_SUBPROGTYPE=5 %THENSTART;! ENTRY IN BLOCK DATA II=II!X'D';! initialised common, preset %FINISHELSESTART;! REF II=II!X'9';! common,referenced,preset if new %FINISH %IF UNASSCHECKS=YES %THEN II=II!X'10' ! QPUT(16,II,LEN,IDENAD) I=TIDY GLA(1,QQ_IIN,LEN) %FINISH PPTR = PP_ADDR4; ! LINK TO NEXT COMMON BLOCK NAME !* N.B. SET APPROP DESC IN GLA !* N.B.REQUEST RELOC OF ARRAY ZERO ELS BY COMMON BLK BASE %REPEAT !* !******* OUTPUT REST OF LOAD DATA !* !! %IF COM_SUBPROGTYPE=5 %AND BLOCKDATAID#"" %THENSTART !! QPUT(11,2,0,ADDR(BLOCKDATAID));! DEFINE ENTRY FOR NAMED BLOCKDATA !! %FINISH I=TIDY GLA(0,0,0) I=I+I;! in bytes TYPE6(2)=I-TYPE7(2) TYPE7(2) = I !* !******* SYMBOL TABLES !* %IF COM_SUBPROGTYPE#5 %THENSTART;! EXCEPT BLOCKDATA STARTST=DIAGCA I=0 %IF CHECKS=NO %THEN I=I!X'8000';! USE STAT MAP, RELATIVE FORM PUTDIAG2(LINENO WORD,I);! @ ON STACK OF CURRENT LINE NO PP == RECORD(ADICT+COM_SUBPROGPTR) PUTDIAG2(0,PP_TYPE<<8!COM_SUBPROGTYPE);! words 4,5 I=PUTNAME(PP_IDEN) TOTCNTLOC=DIAGCA CNTLOC=TOTCNTLOC+1 PUTDIAG2(0,0);! FOR TOTAL IDEN & LOCAL IDEN COUNTS TOTCNT=0 CNT=0 %IF CONTROL&X'4' = 0 %THENSTART; ! FULL DIAG TABLES REQUESTED %IF COM_SUBPROGTYPE=2 %THENSTART;! FUNCTION, SO PUT ENTRY IN DIAGS LIST PUTDIAG2(PP_TYPE<<8!X'80',PP_ADDR4);! on stack I=PUTNAME(PP_IDEN) CNT=CNT+1 %FINISH PTR = COM_SCPTR %WHILE PTR # 0 %CYCLE; ! THROUGH LOCAL SCALAR LIST PP == RECORD(ADICT+PTR) I=PP_TYPE<<8 %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_X0&16#0 %AND PP_TYPE#5 %THENSTART I=I!X'0050';! NON-CHAR SCALAR IN ARRAY AREA J=PP_DISP %FINISHELSESTART I=I!X'0040';! in GLA %IF PP_TYPE=5 %THEN J=PP_DISP %ELSE J = PP_ADDR4 %FINISH %FINISH PUTDIAG2(I,J) I=PUTNAME(PP_IDEN) CNT=CNT+1 LOCALS LOOP: PTR = PP_LINK2 %REPEAT PLUGDIAG(CNTLOC,CNT);! LOCALS COUNT TOTCNT=CNT CNT=0 !* O/P COMMON SCALARS QPTR = COM_CBNPTR %WHILE QPTR # 0 %CYCLE; ! THROUGH COMMON BLOCKS QQ == RECORD(ADICT+QPTR) %IF QQ_LINK2=0 %THEN ->NEXTCMN2 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) PUTDIAGW(SS_INF2) PUTDIAG(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 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 NEWLINE %IF COM_FAULTY = 0 %THENSTART PRINTSTRING("Compilation successful ") !{2900C} COMREG(24)=0 !{2900C} COMREG(47)=LINEST %FINISHELSESTART !{2900C} COMREG(47)=COM_FAULTY PRINTSTRING("Compilation failed ") WRITE(COM_FAULTY,3) PRINTSTRING(" error") %IF COM_FAULTY>1 %THEN PRINTSYMBOL('s') NEWLINE %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 %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 !********* 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 %IF COM_LISTL#0 %THEN REPORT SELECTOUTPUT(0) REPORT 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 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 %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 FAULT(310);! SUBPROGRAM TOO LARGE !!XX CKLAB; ! LIST UNSATISFIED LABELS %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 ASSIGNED GOTOS#0 %THEN ASSIGNED LIST !* !****** PROCESS EACH ENTRY POINT !* CURPTR = COM_SUBPROGPTR %WHILE CURPTR#0 %CYCLE PP==RECORD(ADICT+CURPTR) 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 %THEN RESULT WORDS=4 %C %ELSE RESULT WORDS=2 %FINISHELSE RESULT WORDS=0 SET LINE NO(-COM_FIRSTSTATNUM) %UNLESS COM_SUBPROGTYPE=1 %THEN COPYPARS(CURPTR,0); ! COPY IN OPW(JMPW,PLAB_CODEAD-CODECA-3) 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,0) %IF COM_SUBPROGTYPE=1 %THENSTART I=X'80010000' %FINISHELSESTART I=NOTE ENTRY(STRING(ANAMES+PP_IDEN),NEXT RTNO, LINEST,0,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 CODECA&1#0 %THEN OP1(QNOOP) CODEOUT !* TYPE6(1)=CODECA-TYPE7(1) TYPE7(1)=CODECA %FINISH !* 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 !!# IDENTIFIER=STRING(ANAMES+PP_IDEN) !!# LFAULT(248) !!# %FINISH !!# COM_CHECKLIST=SS_LINK1 !!# %REPEAT !!#!* %IF CONTROL&X'8800'#0 %THENSTART;! ATTR/XREF MAP(1,COM_XREF&1,0,0,0) %FINISH ! %IF OPTIONS1&X'8000'#0 %THENSTART;! MAPS ! STATEMENT MAP ! NEWPAGE ! COM_HEADINGS=0 ! MAP(0,0,1,((GLACA+7)>>3)<<3,STACKBASE) ! NEWPAGE ! COM_HEADINGS=0 ! %FINISH %END; ! SUBPROGEND !* !* !* !* !* %ROUTINE COPYPARS(%INTEGER AREC, MODE) %INTEGERFNSPEC 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 !* 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 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_ADDR4) LLA(STACKPTR) OPB(MOVB,4) I=PARAM_LEN %IF I#0 %THENSTART LDC(I) OP1(REPL) STL(PARAM_ADDR4+3);! set nominated length LDL(STACKPTR+3);! passed length LDL(STACKPTR+4);! no of els passed OP2(MPI,LEQI);! 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(LSSN) LOA(AD) OP3(EXCH2,STLATE,X'42') 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 %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;! COPYIN !!# %IF ARGCHECKS=YES %THENSTART !!# I=STACKPTR !!# %IF COM_SUBPROGTYPE=2 %THENSTART !!# J=ENTRY_TYPE&15 !!# %IF J=5 %AND ENTRY_LEN=0 %THENSTART;! *(*) FUNCTION !!# OPPARAM(LSD,I) !!# OPLNB(ST,ENTRY_ADDR4) !!# %FINISH !!# %IF J=3 %OR J=5 %THEN I=I+8 !!# %FINISH !!# PLUGBYTES(1,2,PARAMCHECK,ADDR(I)+2) !!# %FINISH !!# %FINISHELSESTART;! 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 !!# %IF I&15=3 %THENSTART;! COPMLEX, SO COPY RESULT !!# %IF I&X'F0'=X'50' %THEN OP=LSD %ELSE OP=LSQ !!# OPLNB(OP,FUNRESDISP) !!# OPPDESC(STUH,STACKPTR) !!# PLF1(ST,DRMOD,0,1) !!# %FINISHELSESTART !!# %IF I=5 %THENSTART;! CHAR fn !!# %IF ENTRY_LEN#0 %THENSTART;! not *(*) !!# OPLNB(LSD,ENTRY_ADDR4) !!# OPPARAM(LD,STACKPTR) !!# PF2(X'B2',1,1,0,0,SPACE CHAR);! MV !!# %FINISH !!#!!! %FINISHELSE ARITHOP(1,10,ENTRY_ADDR4<<12!X'200'!I) !!#%FINISH !!#!*********************************************************************** !!# %FINISH !!# %FINISHELSESTART;! SUBROUTINE, SET RETURN VALUE IF NEC. !!# %IF VRETURN#0 %THENSTART !!# %IF VRETURN<0 %THEN I=TOS %ELSE I=BREG !!# OPDIR(LSS,I,0) !!# %FINISH !!# %FINISH !!# %FINISH %RETURN !* !* %INTEGERFN SET ENTRY TEMPLATE(%INTEGER AREC) %INTEGER PREC,PCOUNT,I,J,CLASS,NEXT,TSTART %BYTEINTEGERARRAY T(0:257) %RECORD(PRECF)%NAME ENTRY %RECORD(PRECF)%NAME PP %RECORD(SRECF)%NAME SS %IF PARCHECKS=NO %THEN %RESULT=0 ENTRY==RECORD(ADICT+AREC) %IF COM_SUBPROGTYPE=3 %THEN I=0 %ELSE I=ENTRY_TYPE T(1)=I PREC=ENTRY_LINK2 PCOUNT=1 %WHILE PREC#0 %CYCLE SS==RECORD(ADICT+PREC) PP==RECORD(ADICT+SS_INF0) PCOUNT=PCOUNT+1 I=PP_TYPE %IF PP_CLASS&8#0 %THEN I=I!X'80';! subprog %IF PCOUNT<256 %THEN T(PCOUNT)=I PREC=SS_LINK1 %REPEAT %IF PCOUNT>255 %THEN PCOUNT=255 T(0)=PCOUNT T(PCOUNT+1)=0;! ensure 0 in byte which may fill to word bdy !* !***************************************ensure label params included !***************************************ensure pdesc retained for qput !!# %RESULT=J-STACKBASE %END;! SET TEMPLATE !* %ROUTINE PARAM ARRAY(%INTEGER STACKPTR,PARAMREC) %ROUTINESPEC DIMOP(%INTEGER OP,D) %ROUTINESPEC ITSBOUND(%INTEGER P,DISP) %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) !!# IDENTIFIER=STRING(ANAMES+PARAM_IDEN) DVREC==RECORD(ADICT+PARAM_ADDR4) DVAD=DVREC_ADDRDV PCT=DVREC_DIMS !!# PTYPE=PARAM_TYPE !* ADJUST=NO %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 !!# CHLEN=PARAM_LEN !!# %IF CHLEN=0 %THENSTART !!# OPLITT(LB,I) !!# OPDV(MYB,DVREC_ADDRDV-4) !!# OPBREG(LDB) !!# ->COMMON !!# %FINISHELSE I=I*CHLEN !!# %FINISH !!# OPLITT(LDB,I) !!# ->COMMON !!#!* !!#ADJUST: !!# %IF PARAM_CLASS&X'C0'=X'80' %THEN ->STAR;! NO ACTUAL ADJ. DIMS !!# ADJUST=YES !!#!* !!# SUM=1;SUM2=0 !!# %CYCLE I=1,1,PCT !!# J=GLADV+(PCT-I)*12;! @ OF RELEVENT TRIPLE !!# %IF BUSED#0 %THENSTART !!# OPLT(STB,J+4) !!# OPLT(STB,J+20) !!# %IF COM_ARRAYCHECKS#FULL %THENSTART;! NOR POSS FOR I=1 !!# OPDV(STB,DVAD+I*4+4) !!# %FINISH !!# OP=SLB !!# %FINISHELSE OP=LB !!# 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 !!# OPBREG(LSS) !!# %UNLESS L=1 %THEN OPLITT(IMY,L) !!# OPLITT(IAD,SUM2) !!# %FINISHELSESTART !!# %IF L=1 %THENSTART !!# OPBREG(IAD) !!# %FINISHELSESTART !!# OPLITT(SLSS,L) !!# OPBREG(IMY) !!# OPTOS(IAD) !!# %FINISH !!# %FINISH !!# ACCUSED=1 !!# %FINISH !!# %IF UC=0 %THENSTART;! BOTH CONST !!# %IF BUSED#0 %THENSTART;! ALREADY COMPUTING !!# OPLITT(MYB,U-L+1) !!# %FINISHELSESTART !!# SUM=SUM*(U-L+1) !!# %FINISH !!# %FINISHELSESTART;! UPPER IS VAR !!# %IF U>>29=5 %THEN ->STAR !!# DIMOP(OP,U) !!# ITSBOUND(I,4);! store upper bound if ITS !!# %UNLESS L=1 %THEN OPLITT(SBB,L-1) !!#CHECK: %IF ARGCHECKS#NO %AND U>>29#5 %THENSTART !!# PF3(JAT,13,0,5);! IF BREG>0 !!# RT ERROR(BOUND FAULT) !!# %FINISH !!# %IF BUSED=0 %THENSTART !!# %IF I>1 %THEN OPLITT(MYB,SUM) !!# BUSED=1 !!# %FINISHELSESTART !!# OPTOS(MYB) !!# %FINISH !!# %FINISH !!# %FINISHELSESTART !!# %IF ACCUSED=0 %THENSTART !!# %IF I=1 %THEN DIMOP(LSS,L) %ELSE OPLITT(LSS,SUM2) !!# %FINISH !!# %IF I#1 %THENSTART !!# DIMOP(SLSS,L) !!# %IF BUSED=0 %THENSTART !!# OPLITT(IMY,DVREC_B(I)_M) !!# %FINISHELSESTART !!# OPBREG(IMY) !!# %FINISH !!# OPTOS(IAD) !!# %FINISH !!# ACCUSED=1 !!# DIMOP(OP,L) !!# ITSBOUND(I,0);! store lower bound if ITS !!# OPLT(STB,J) !!# %IF UC=0 %THENSTART !!# OPLITT(SLB,U+1) !!# %FINISHELSESTART !!# %IF U>>29=5 %THEN ->STAR !!# DIMOP(SLB,U) !!# OPLITT(ADB,1) !!# %FINISH !!# OPTOS(SBB) !!# ->CHECK !!# %FINISH !!# %REPEAT !!# OPLT(STB,J+8) !!#!* !!# %IF U>>29=5 %THENSTART;! * upper bound !!#STAR: OPPARAM(LSS,STACKPTR) !!# OPLITT(USH,8) !!# OPLITT(USH,-8) !!# OPLT(ST,GLADV+8) !!# OPLT(LDB,GLADV+8) !!# %IF ADJUST=NO %THENSTART !!# %IF COM_ARRAYCHECKS=NO %AND PTYPE#5 %THENSTART !!# OPLITT(INCA,-DVREC_ZEROTOFIRST*DVREC_ELLENGTH) !!# %FINISH !!# ->COMMON !!# %FINISH !!# %FINISHELSESTART !!# %IF PTYPE&7=3 %OR PTYPE=X'41' %THEN OPBREG(ADB) !!# %IF PTYPE=5 %THENSTART !!# CHLEN=PARAM_LEN !!# %IF CHLEN=0 %THENSTART !!# OPDV(MYB,DVREC_ADDRDV-4) !!# %FINISHELSE OPLITT(MYB,CHLEN) !!# %FINISH !!# OPBREG(LDB) !!# %FINISH !!#!* !!#!* !!# %IF COM_ARRAYCHECKS=FULL %AND PCT#1 %THEN ->COMMON !!#!* !!# %IF ACCUSED#0 %THENSTART !!# %IF PTYPE=X'41' %OR PTYPE&7=3 %THENSTART !!# OPBREG(ST) !!# OPBREG(IAD) !!# %FINISH !!# %IF PTYPE=5 %THENSTART !!# CHLEN=PARAM_LEN !!# %IF CHLEN=0 %THENSTART !!# OPDV(MYB,DVREC_ADDRDV-4) !!# %FINISHELSE OPLITT(MYB,CHLEN) !!# %FINISH !!# OPDV(ST,DVAD+8) !!# %FINISH !!# %IF COM_ARRAYCHECKS=NO %AND PTYPE#5 %THENSTART !!# OPLITT(LB,0) !!# OPDV(SBB,DVAD+8) !!# OPBREG(MODD) !!# %FINISH !!#!* !!#!* COMMON: LOA(DVAD) LLA(STACKPTR) OP2(LDDW,STDW) LDLD(STACKPTR+W2);! 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 OP,D) !!#%ROUTINESPEC DIMEVAL(%INTEGERNAME DISP) !!#%INTEGER F,A,M,I,J,K,PTR !!#%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<S(R_FORM) !!#!* !!#S(0): OPLITT(OP,A);! simple int !!# %RETURN !!#!* !!#S(1): A=SETCONREC(D);! int in dict !!# OPCONST(OP,1,A,1) !!# %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=LSCALID;! has a local RD !!# %FINISH !!#!* !!# %IF R_MODE>INT8 %THENSTART !!# TFAULT(196,ADDR(IDENTIFIER),ADDR(ERRIDEN));! adjustable dimension not integer !!# %RETURN !!# %FINISH !!#!* !!# %IF R_MODE#INT4 %THENSTART !!# %IF OP=SLB %THEN OPTOS(STB) !!# OPTOS(ST) !!#!!! ARITHOP(X'51',11,RES);! load to breg as I*4 !!#!*********************************************************************** !!# %FINISHELSESTART !!# PLANTOP(OP,R_FORM,R_H0) !!# %FINISH !!#!* !!# %IF UNASSCHECKS=YES %THENSTART !!# OPPC(CPB,PCUNASSPATT) !!# PF3(JCC,7,0,5);! continue unless = !!# RT ERROR(UNASSFAULT) !!# %FINISH !!#!* !!# %IF D&X'F'#1 %THEN OPTOS(LSS) !!# %RETURN !!#!* !!#S(6): ! temp loc !!# OPLNB(OP,A) !!# %RETURN !!#!* !!#S(7): !dimension expression !!# %IF ACCUSED#0 %THEN OPTOS(ST) !!# DIMEVAL(A) !!# %IF ACCUSED#0 %THEN OPTOS(LSS) !!# OPLNB(OP,A) !!# %RETURN !!#!* !!#%ROUTINE DIMEVAL(%INTEGERNAME DISP) !!#%CONSTBYTEINTEGERARRAY OP(0:6)=0(2),X'E0',X'E2',X'EA',X'AA',X'E2' !!#%INTEGER CUR,END,AD !!# CUR=DISP !!# END=CUR+INTEGER(ADICT+CUR) !!# CUR=CUR+4 !!# %WHILE CUR>13 !!#%END !* %END;! DIMOP !* %END;! PARAM ARRAY !* %END; ! COPYPARS !* !* %ROUTINE IO LOCAL SWITCH(%HALFINTEGER RTNO) %INTEGER ENTRY %INTEGER I %RECORD(RTFMT) RT %STRING(6) ID ENTRY=CODECA LDO(TCTBASE+TCTINDEX) %IF CODECA&1=0 %THEN OP1(QNOOP);! to ensure following are word alligned OP1(XJP) PWORD(1);! lower bound PWORD(IOINDEX);! upper bound PWORD(IOINDEX<<1-2);! jump to return %CYCLE I=1,1,IOINDEX PWORD(IOSTEPS(I)-CODECA) %REPEAT I=RT DEFN(5,6,ENTRY,2,0,0) ID="F_IOIT" QPUT(11,RTNO,I,ADDR(ID)) %END;! IO LOCAL SWITCH !* %ROUTINE IOSTAT(%HALFINTEGER IOTYPE) IOMARKERS=0;! for end,err,iostat IOINDEX=0;! for co-routines IOKEY=IOKEY+1 IOSTARTED=0;! when non-zero specifies @ of jump around coroutines IODSNUM=-IOTYPE;! set default channel indicators: -1 input, -2 output NEXTPP=TCTBASE+TCTPP;! next parameter pair location for OPEN,CLOSE,INQUIRE %END;! IOSTAT !* %ROUTINE STARTIO %IF IOSTARTED=0 %THENSTART IOINDEX=1 OP1(LDC1) STO(TCTBASE+TCTINDEX) IOSTARTED=CODECA;! SAVE ADDRESS FOR JUMPING AROUND COROUTINES OPBB(JMPW,0,0) IOSTEPS(1)=CODECA %FINISH %END;! STARTIO !* !* %ROUTINE CALL IO(%HALFINTEGER IOTYPE,FORM,MODE) %CONSTBYTEINTEGERARRAY FORM TO INDEX(0:9)=4,0,0,2,0,0,0,5,5,0 %CONSTSTRING(6)%ARRAY IONAME(0:5)= %C "F77IOA","F77IOB","F77IOC","F77IOD","F7IOE","F77IOF" %HALFINTEGER RTNO,INDEX RTNO=NEXT RTNO NEXT RTNO=NEXT RTNO+1 %IF IOTYPE>5 %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(RTNO) FILL JUMP(IOSTARTED) IOSTARTED=0 %FINISH %IF IODSNUM#0 %THENSTART LDC(IODSNUM) OPB(LOPS,I2TOI4) STOD(TCTBASE) %FINISH %IF IOINDEX=0 %THENSTART;! no io list OP1(LDC0) STO(TCTBASE+TCTINDEX) %FINISH OP1(LSSN) LOA(TCTBASE) OP1(MMS2);! @ io table LDC(FORM) LDC(IOKEY) OP1(MMS2);! ioform,iokey 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(RTNO,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)) %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 !* OP2(LDL5,LDL4);! @ address %IF ST=CHARTYPE %THENSTART L=SET CHAR DESC(R,0) OP2(REPL2,MMS2) %FINISHELSE LOAD ADDRESS(R) 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 LOAD ADDRESS(R) %FINISHELSESTART %IF I=1 %THENSTART;! integer LOAD VAL(R) COERCE(MODE,INT4) %FINISHELSESTART %IF I=5 %THENSTART L=SET CHAR DESC(R,0) %FINISHELSE LOAD ADDRESS(R) %FINISH STOD(NEXTPP) %FINISH NEXTPP=NEXTPP+2 %RETURN %FINISH ->SW(INDEX) !* SW(1):! UNIT= !* %IF FORM=LIT %THENSTART ;! int >=0 IODSNUM=R_H0 %FINISHELSESTART %IF 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 !!# PLUGWORD(2,GLAIOTABLE,-1) ;! I/O table !!# %IF FORM=ARRID %THENSTART;! char array !!# PP==RECORD(ADICT+VAL<>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) !!# PP==RECORD(ADICT+VAL<L522 !!# %FINISH !!#!* !!# %IF MODE=CHARMODE %THENSTART !!# RES_FORM=FORM !!# RES_H0=VAL !!# RES_MODE=CHARMODE !!# SET CHAR DESC(RES,LD,0) !!# ->L522 !!# %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= !!#!* !!# FORCED LOAD(INACC,FORM,VAL,MODE,INT4) !!# OPLT(ST,GLACA) !!# IODISPS2=IODISPS2 !((GLACA-GLAIOTABLE)<<24) !!# PUTWORD(2,0) %RETURN !!#!* SW(4): ! END = !!#!* SW(5): ! ERR= !!#!* !!# LABREC==RECORD(ADICT+VAL< 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=NO %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,EQUI,GTRI,LESI,EQUI,GTRI %CONSTBYTEINTEGERARRAY ARITHIF4(0:5)=LESOP,EQUOP,GTROP,LESOP,EQUOP,GTROP !* %SWITCH T(0:127) !* 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 !* CGENINIT NEXT TRIAD = 1 ATRIADS=COM_ATRIADS !{PERQ} %CYCLE I=0,1,3 !{PERQ} BLOCKIN(I)=-1 !{PERQ} %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): 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 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!! 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 %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,LESOP) 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 TR_QOPD1=LIT LOAD ADDRESS(TR_RES1) %IF TR_MODE=CHARMODE %THEN OP1(LDC2) %ELSE OP1(LDC1) %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) COERCE(TR_MODE,INT2) %FINISH 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): STATFN==RECORD(ADICT+TR_OPD1) OPB(CALL,STATFN_IIN) RES1_W=STATFN_LINK2 %IF TR_MODETRIAD LOOP !* T(STRTIO): IO STAT(TR_OPD2) ->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(EOT): SUBPROGEND %RETURN !* %INTEGERFN NEW PLAB !*********************************************************************** !* Provide a new dict record for a private label * !*********************************************************************** %RECORD(PLABF)%NAME PLAB %INTEGER I 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<