!* MODIFIED 20/03/82 !{2900C}%CONSTINTEGER W1=2;! 1 PERQ 2 EMAS !{2900C}%CONSTINTEGER W2=4 !{2900C}%CONSTINTEGER W4=8 !{2900C}%CONSTINTEGER W8=16 !{2900C}%CONSTINTEGER W66=132 {PERQC}%CONSTINTEGER W1=1 {PERQC}%CONSTINTEGER W2=2 {PERQC}%CONSTINTEGER W4=4 {PERQC}%CONSTINTEGER W8=8 {PERQC}%CONSTINTEGER W66=66 %OWNINTEGER TRACETEMP !************* IMP80 version ****************** !* !*********************************************************************** !*********************************************************************** !* !* !*********************** 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 CONCAT = 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 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 EXP3 = X'28' %CONSTINTEGER REL = X'29' %CONSTINTEGER RSUB = X'2A' %CONSTINTEGER RDIV = X'2C' %CONSTINTEGER STRTIO = X'30' %CONSTINTEGER IOITEM = X'31' %CONSTINTEGER IODO = X'32' %CONSTINTEGER IOSPEC = X'33' %CONSTINTEGER IO = X'34' %CONSTINTEGER ASGN = X'36' %CONSTINTEGER AIF = X'39' %CONSTINTEGER SBSCV = X'3A' %CONSTINTEGER SBSCE = X'3B' %CONSTINTEGER SBSCR = X'3C' %CONSTINTEGER NOOP = X'40' %CONSTINTEGER FUN = X'41' %CONSTINTEGER SUBR = X'42' %CONSTINTEGER ARG = X'43' %CONSTINTEGER DINIT = X'4B' %CONSTINTEGER STOREB = X'4C' %CONSTINTEGER LOADB = X'4D' %CONSTINTEGER SAVETM = X'4E' %CONSTINTEGER REF = X'4F' %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' !* !* !* !*********************************************************************** !*********************************************************************** !* !* !********************* 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 %CONSTINTEGER INBREG = 2 !* !*********************** length of maximum source statement *********** !* %CONSTINTEGER INPUT LIMIT = 200 !* !*********************************************************************** !*********************************************************************** !* !* !* !*********************************************************************** !*********************************************************************** !* !* !*********************************************************************** !* 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(%INTEGER DIMS, ADDRDV,GLADV, %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 = 28;! size of dict entry reserved for a new identifier %CONSTINTEGER CONRECSIZE = 16 %CONSTINTEGER CNSTRECMIN = 4 %CONSTINTEGER IMPDORECSIZE = 12;! size of DATA-implied-DO list item %CONSTINTEGER LABRECSIZE = 40 %CONSTINTEGER PLABRECSIZE = 16 %CONSTINTEGER XREFSIZE = 8 %CONSTINTEGER CMNRECEXT = 12;! extra space on iden record for common block name %CONSTINTEGER TMPRECSIZE = 12 %CONSTINTEGER DVRECSIZE = 14 !* !*********************************************************************** !* 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)) !* !*********************************************************************** !*********************************************************************** !* !*********************************************************************** !*********************************************************************** !* ! ! 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 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 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 !* !* !* %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) !* %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 FREELISTCELL(%INTEGERNAME LISTHEAD,%INTEGER N) %EXTERNALROUTINESPEC LFAULT(%INTEGER ER) %EXTERNALROUTINESPEC FAULT(%INTEGER ER) %EXTERNALINTEGERFNSPEC NEWLISTCELL(%INTEGERNAME LISTHEAD,%INTEGER N) %EXTERNALINTEGERFNSPEC FREESP(%INTEGER N) %EXTERNALINTEGERFNSPEC ALLOCCHAR(%INTEGER L,AD,%INTEGERNAME GLA 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:8) !* !* !*********************** following declarations used only by SUBPROGEND actions ********************** !* !* !{2900C}%SYSTEMINTEGERMAPSPEC COMREG(%INTEGER I) %EXTERNALROUTINESPEC ALLOC(%INTEGER PTR) %EXTERNALINTEGERFNSPEC TIDY GLA %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=1 %CONSTINTEGER CHARFAULT=4 %CONSTINTEGER INCRFAULT=5 %CONSTINTEGER FMTLABFAULT=17 %CONSTINTEGER NEGUNITFAULT=16 %CONSTINTEGER BOUNDFAULT=9 %CONSTINTEGER ASIZEFAULT=10 %CONSTINTEGER CSIZEFAULT=12 %CONSTINTEGER RECURSEFAULT=15 %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'41',X'05', 0, 0,X'34',X'64' !* %CONSTSTRING(6)%ARRAY GEN NAME(1:24)= %C "SQRT" ,"EXP" ,"LOG" ,"LOG10" , "SIN" ,"COS" ,"TAN" ,"COT" , "ASIN" ,"ACOS" ,"ATAN" ,"ATAN2" , "SINH" ,"COSH" ,"TANH" ,"ERF" , "ERFC" ,"GAMMA" ,"LGAMMA","ABS", "LGE" ,"LGT", "LLE", "LLT" !* !* !* !*********************************************************************** !* * !* 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 !* !* !* !*********************************************************************** !*********************************************************************** !* !* %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)), ADDR(CODE(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 4 TO MS {address of source is assumed to be in Estack } {assumes that MOVB copies the words in the same order } OP2(LDTP,TLATE2) OPB(MOVB,4) %END;! MOVE 4 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 I=(I&X'FF')<<8!(I>>8) QPUT(18,0,INST ADDR+1,I) %END;! FILL JUMP !* !* !* !*************************************************************************************************************** !*************************************************************************************************************** !* !* %EXTERNALROUTINE CODEGEN(%INTEGER CGENEP, %RECORD(TRIADF) %ARRAYNAME TRIADS, %INTEGER COMAD) %ROUTINESPEC RTERROR(%INTEGER ERR) %ROUTINESPEC SUBPROGEND !* %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 %INTEGER IODSNUM %INTEGER ASSIGNED GOTOS,ASSIGNED LABS %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 !* %INTEGERARRAY IOSTEPS(0:255) !* !* !* %ROUTINE CALL FAUX(%INTEGER EP) !* EP = 3 PAUSE 4 STOP %END;! CALL FAUX !* !* !* !* %ROUTINESPEC COPYPARS(%INTEGER AREC,MODE) %ROUTINESPEC LOADDATA !* !****************************************************************************** !* * !* 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 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 * !*********************************************************************** %INTEGER I I=SAVETRIAD TRIADS(I)_QOPD1=FORM TRIADS(I)_OPD1=OPD TRIADS(I)_OP=NULL;! to indicate triad use to diagnostic utilities %END;! SAVE RES !* %INTEGERFN EXTRIAD(%HALFINTEGERNAME OPD,MODE) !*********************************************************************** !* called when referenced item is a triad containing an r.d. * !*********************************************************************** %INTEGER I I=OPD OPD=TRIADS(I)_OPD1 MODE=TRIADS(I)_MODE %RESULT=TRIADS(I)_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 AD,D %INTEGER DISP %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 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)) PWORD(HALFINTEGER(AD+W1)) ->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) AD<-DISP&X'FFFF' OPW(LDDC,AD) AD<-DISP>>16 PWORD(AD) OPB(LOPS,ADDOP) %RETURN !* F(ASCALID): LOA(PP_ADDR4) 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): SS==RECORD(ADICT+D) PP==RECORD(ADICT+SS_INF2);! array iden record DVREC==RECORD(ADICT+SS_INF3) R_W=SS_INF0;! index !******************************* to be concluded ********************* %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 %SWITCH F(0:20) D=R_H0 WORDS=MODETOWORDS(R_MODE);! 1, 2 or 4 FORM=R_FORM&X'FF';! for diagnostics ->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)) PWORD(HALFINTEGER(AD+W1)) %RETURN %FINISH OPW(LDCW,HALFINTEGER(AD)) %RETURN !* 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) %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 F(ARREL): %IF WORDS=2 %THEN OP=LDDW %ELSE OP=LDIND OP2(TLATE1,OP) %RETURN !* F(ASCALID): PP==RECORD(ADICT+D) P=PP_ADDR4 D=0 ->CMNEL !* F(LABID): LAB==RECORD(ADICT+D) %RETURN %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_ADDR4 D=0 ->CMNEL %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 TEST UNASS(%INTEGER REG) !* REG = 0 ACC !* 1 B %INTEGER INST !!# %IF UNASS # 0 %THENSTART !!# %IF REG=0 %THEN INST=UCP %ELSE INST=CPB !!# OP PC(INST,UNASS);! COMPARE WITH UNASSIGNED PATTERN !!# PF3(JCC,8,0,(PCUNASS-CODECA)>>1);! JUMP IF EQUAL TO REPORT !!# %FINISH %END;! TEST UNASS !* %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-1)*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(%INTEGER LF,LA,LMODE,RF,RA,RMODE,OP,OPMODE) !* %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 RESR_FORM&X'FF'=TRIAD %THEN RESR_FORM=EXTRIAD(RESR_H0,I) 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, 11, 13 %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) %IF RESR_FORM&X'FF'=TRIAD %THEN RESR_FORM=EXTRIAD(RESR_H0,I) 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;! cannot include neg 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 %IF OP=6 %THENSTART;! neg QOP(OP,MODE) ->SAVE %FINISH 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) %UNLESS OP=6;! unless neg LOAD VAL(RESR) 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+6 %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) %IF RESR_FORM&X'FF'=TRIAD %THEN RESR_FORM=EXTRIAD(RESR_H0,I) 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 RMODE=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 LMODE=INT2 %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(MULTOP,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) LOAD VAL(RESR) OP1(MMS2) SYSCALL("POWER") OP1(MES2) ->SETRES %FINISH %END;! EXPFN !* %ROUTINE ARR ACCESS(%INTEGER TYPE,%RECORD(RESF) RESL,RESR) %RECORD(ARRAYDVF)%NAME DVREC %RECORD(PRECF)%NAME ARRAYREC %RECORD(RESF)%ARRAY SUBSCRIPT(0:7) %INTEGER PCT,I,J,L,PTR !!# ARRAYREC==RECORD(ADICT+RESL_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 !* !* %ROUTINE SET CHAR DESC(%RECORD(RESF) RRES,%INTEGER LOADOP,MODE) !*********************************************************************** !* RRES IS RD FOR CHAR CONST, SCALAR OR ARRAY ELEMENT * !* LOADOP IS LSD, LD OR SLD * !* MODE = 0 DESCRIPTER TO ELEMENT REQUIRED FOR ARRAY * !* 1 DESCRIPTOR TO BALANCE OF ARRAY REQUIRED * !* Sets RES = length of char value if known * !* 0 if (*) length * !*********************************************************************** %INTEGER I,J, A,F,INDEX,OP %RECORD(PRECF)%NAME PP %RECORD(PRECF)%NAME CMNEL %RECORD(PRECF)%NAME CMNBLK %RECORD(ARRAYDVF)%NAME DVREC %RECORD(CONRECF)%NAME CON %RECORD(CHARF)%NAME CH %RECORD(RESF) SUBSRD !!# F=RRES_FORM !!# A=RRES_H0 !!# %IF F=CHVAL %THENSTART;! SCALAR, DESCRIPTOR ON STACK !!# CH==RECORD(ADICT+A<SET DESC !!# %FINISH !!# %IF LOADOP=SLD %THEN OP=SLD %ELSE OP=LD !!# %IF F=CSCALID %THENSTART !!# CMNEL==RECORD(ADICT+A<TOACC !!# %FINISH !!# %IF F=ARRID %THENSTART;! CHAR ARRAY !!# PP==RECORD(ADICT+A<CHECK !!# %FINISH !!# %FINISH !!# %UNLESS F=ARREL %THENSTART;! CAN ONLY BE ARRAY !!#! %MONITOR !!# %RETURN !!# %FINISH !!# PP==RECORD(ADICT+INTEGER(ADICT+A+8));! DICREC FOR ARRAY !!# DVREC==RECORD(ADICT+PP_ADDR4) !!# SUBSRD_W=INTEGER(ADICT+A+4) !!# %IF SUBSRD_FORM=LIT %AND PP_LEN#0 %THENSTART;! SHORT INTEGER CONST !!# INDEX=SUBSRD_H0 !!# %IF SUBSRD_W<0 %THEN INDEX=INDEX!X'FFFF0000' !!# INDEX=INDEX*PP_LEN !!# %FINISHELSESTART !!# FREEBREG !!# FORCED LOAD(INBREG,SUBSRD_FORM,SUBSRD_H0,SUBSRD_MODE,INT4);! LOAD SUBSCRIPT TO B !!# I=PP_LEN !!# %IF I=0 %THENSTART !!# OPDV(MYB,DVREC_ADDRDV-4) !!# %FINISHELSE OPLITT(MYB,I);! MULTIPLY BY ELEMENT LENGTH !!# SUBSRD_W=-1;! FOR CORRECT EFFECT BELOW WHEN * LEN !!# BREGUSE=0 !!# %FINISH !!# %IF LOADOP=LSD %THEN OP=LD %ELSE OP=LOADOP !!# %IF OP=SLD %AND DESCUSE>=0 %THEN OP=LD !!# OPDV(OP,INTEGER(ADICT+A+12));! ARRAY DESC !!# %IF SUBSRD_FORM # LIT %THENSTART !!# OPBREG(MODD);! IAD OR ADB !!# %FINISHELSESTART !!# %UNLESS INDEX=0 %THEN OPLITT(MODD,INDEX) !!# %FINISH !!#CHECK: %IF MODE=0 %THENSTART !!# RES_W=PP_LEN !!# %IF RES_W=0 %THENSTART !!# OPDV(LDB,DVREC_ADDRDV-4) !!# %FINISHELSE OPLITT(LDB,RES_W) !!#TOACC: %IF LOADOP=LSD %THEN OPLITT(X'12',0);! CYD 0 !!# %FINISH !!# %FINISH %END;! SET CHAR DESC !* %ROUTINE SET CHAR RECORD %INTEGER I,PTR %RECORD(CHARF)%NAME CH !!# I=STACKCA-STACKBASE !!# PUTDESC(7,0,0) !!# OPLNB(STD,I) !!# PTR=FREESP(3) !!# CH==RECORD(ADICT+PTR) !!# CH_ADESC=I;! stack displacement of descriptor !!# CH_LEN=RES_W;! item length !!# RES_H0=PTR>>DSCALE; RES_H1=CHVAL<<8!CHARMODE %END;! SET CHAR RECORD !* %ROUTINE 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 DR with string descriptor - this * !* sets RES = 0 (*) length specification * !* #0 character item length * !* Carries out necessary checks and creates updated character * !* descriptor, stored in temporary stack location * !*********************************************************************** %ROUTINESPEC CHECK TOP %INTEGER LA,LF,RA,RF,I,PTR !!#%RECORD(SRECF)%NAME SS !!# LF=RESL_FORM !!# LA=RESL_H0 !!# RF=RESR_FORM !!# RA=RESR_H0 !!# FREE DESC !!# SET CHAR DESC(CHRES,LD,0) !!# FREE BREG !!# FREE ACC !!# %IF RESL_W=0 %THEN LA=1 !!# %IF RESR_W=0 %THENSTART !!# %IF LF=0 %THENSTART !!# %IF LA<=0 %THEN ->ER !!# %IF LA#1 %THEN OPLITT(MODD,LA-1) !!# %FINISHELSESTART !!# PLANTOP(LB,LF,LA) !!# OPLITT(SBB,1) !!# OPBREG(MODD) !!# %FINISH !!# ->SETRES !!# %FINISH !!# %IF CHARCHECKS=YES %THENSTART !!# %IF RES_W=0 %THENSTART;! (*) length !!# OPTOS(STD) !!# OPLITT(ASF,-1) !!# OPTOS(LSS) !!# OPLITT(USH,16) !!# OPLITT(USH,-16) !!# OPTOS(ST) !!# %FINISHELSESTART !!# %IF RF#0 %THENSTART !!# OPLITT(LB,RES_W) !!# OPTOS(STB) !!# %FINISH !!# %FINISH !!# %FINISH !!#!* !!# %IF LF=0 %AND RF=0 %THENSTART;! compile-time bound checks !!# %UNLESS 1<=LA<=RA %THENSTART !!#ER: FAULT(257);! invalid substring position value !!# ->SETRES !!# %FINISH !!# %IF RES_W#0 %THENSTART;! upper limit check too !!# %UNLESS RA<=RES_W %THEN ->ER !!# %FINISHELSESTART !!# %IF CHARCHECKS=YES %THEN CHECK TOP !!# %FINISH !!# %IF LA#1 %THEN OPLITT(INCA,LA-1) !!# OPLITT(LDB,RA-LA+1) !!#SETRES: SET CHAR RECORD !!# %RETURN !!# %FINISH !!# %IF CHARCHECKS=YES %THENSTART !!# %IF RES_W#0 %AND RF=0 %THENSTART !!# %IF RF>RES_W %THEN ->ER !!# PLANTOP(LB,RF,RA) !!# %FINISHELSE CHECK TOP !!# PLANTOP(LSS,LF,LA) !!# %IF LF=0 %THENSTART !!# %UNLESS LA>0 %THEN ->ER !!# %FINISHELSESTART !!# OPLITT(ICP,0) !!# PF3(JCC,12,0,5) !!# %FINISH !!# OPBREG(ICP) !!# PF3(JCC,12,0,5) !!# RTERROR(CHARFAULT) !!#ADJUST: OPLITT(ISB,1) !!# OPTOS(ST) !!# OPTOS(ST) !!# OPTOS(SBB) !!# OPTOS(INCA) !!# OPBREG(LDB) !!# ->SETRES !!# %FINISHELSESTART !!#NOCHECKS:%IF LF=0 %AND LA<1 %THEN ->ER !!# %IF RF=0 %AND RES_W#0 %AND RA>RES_W %THEN ->ER !!# PLANTOP(LSS,LF,LA) !!# PLANTOP(LB,RF,RA) !!# ->ADJUST !!# %FINISH !!#!* !!#%ROUTINE CHECK TOP !!# PLANTOP(LB,RF,RA) !!# OPTOS(CPB) !!# PF3(JCC,12,0,5) !!# RTERROR(CHARFAULT) !!#%END;! CHECK TOP !* %END;! CHAR SUBSTRING !* %INTEGERFN CONCAT CHARS(%RECORD(RESF) RES) !* 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 !* %ROUTINE CHAROP(%RECORD(RESF) RESL,%INTEGER OP,%RECORD(RESF) RESR) %CONSTBYTEINTEGERARRAY CHMASK(0:14)=0,1,2,3,8,9,10,2,1,3,8,10,9,0,0 %INTEGER I,LL,LR !!# %UNLESS RESL_MODE=CHARMODE %AND RESR_MODE=CHARMODE %THENSTART !!#ER: LFAULT(132) !!# RES_W=-1 !!# CONDMASK=0 !!# %RETURN !!# %FINISH !!# FREEREGS !!# %UNLESS OP=1 %OR OP=7 %THEN ->ER !!# RESL_W=CONCAT CHARS(RESL) !!# RESR_W=CONCAT CHARS(RESR) !!# SET CHAR DESC(RESL,LSD,0) !!# LL=RES_W !!# %IF UNASSCHECKS=YES %THENSTART !!# OPTOS(ST) !!# OPTOS(LD) !!# PUTC2(X'A380');! SWNE 0 !!# PUTC2(0) !!# PF3(JCC,4,0,(PCUNASS-CODECA)>>1) !!# %FINISH !!# SET CHAR DESC(RESR,LD,0) !!# LR=RES_W !!# RES_W=0 !!# %IF OP=7 %THENSTART !!# PF2(X'B2',1,1,0,0,SPACE CHAR);! MV !!# %FINISHELSESTART !!# %IF UNASSCHECKS=YES %THENSTART !!# OPTOS(STD) !!# PUTC2(X'A380');! SWNE 0 !!# PUTC2(0) !!# PF3(JCC,4,0,(PCUNASS-CODECA)>>1) !!# OPTOS(LD) !!# %FINISH !!# I=CONDMASK>>1 !!# %IF LL>LR %THENSTART !!# I=I+6 !!# OPTOS(STD) !!# OPTOS(SLSD) !!# OPTOS(LD) !!# %FINISH !!# CONDMASK=CHMASK(I) !!# PF2(X'A4',1,1,0,0,SPACECHAR);! CPS !!# %FINISH %END;! CHAROP !* %ROUTINESPEC LOADR(%INTEGER RDFMT,A,OLDMODE,NEWMODE) %ROUTINESPEC LOADI(%INTEGER RDFMT,A,OLDMODE,NEWMODE) !* %ROUTINESPEC INLINE1(%INTEGER FNTYPE,INDEX,RESTYPE, %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) %INTEGER A, FORM, SIZE, TYPE, MODE %INTEGER OP, BYTES, DESC INDEX %HALFINTEGER I,J,K,LOOP,PASCALPROC,PARAMDESC %INTEGER NUMELS;! 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=X'100'!MODETOST(RD_MODE);! default to scalar NUMELS=1 -> F(FORM) !!#!* !!#!****** CONST RECORD !!#F(CNSTID): CON == RECORD(ADICT+A<8 %THEN I=8 !!# K=-K;! to get string desc !!# %FINISH !!# I=ALLOC CHAR(I,K,J) !!#CHDESC: OPCHDESC(DESCOP,I) !!# ->STORED !!# %FINISH !!# I = CONSTADDR(A<ADPAR !* !****** in temporary F(TMPID): FREETEMP(A);! this call only modifies _LINK ->SCALAD !* !!#!* !!#!****** triad !!#F(TRIAD):FORM=EXTRIAD(A,MODE) !!# ->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'300';! must be a subprog %IF I = 8 %THENSTART; ! EXTERNAL SUBPROG USER REF(PP_IDEN,0,0,0);! load variable routine descriptor OP2(MMS2,MMS2) %FINISHELSESTART; ! PARAM SUBPROG LOA(PP_ADDR4);! address of variable routine desc (param) MOVE 4 TO MS %FINISH ->ADPAR !* !!#!****** ARRAY ELEMENT !!#F(ARREL): !!# %IF TYPE=CHARTYPE %THENSTART;! CHAR !!# SET CHAR DESC(RD,DESCOP,1) !!# ->STORED !!# %FINISH !!# A=A+4;! first word is number of subscripts !!# I=INTEGER(ADICT+A+8) !!# OPDV(DESCOP,I) !!# %IF SIZE=4 %THENSTART;! INTEGER*2 !!# OP CONSTANT(LDTB,SPEC CONST(SPC S2DESC)) !!# OPDV(LDB,I) !!# %FINISH !!# RD_W=INTEGER(ADICT+A) !!# K=RD_H0 !!# %IF RD_W<0 %THEN K=K!X'FFFF0000' !!#CARRAY: PLANTOP(MODD,RD_FORM,K) !!# %IF TYPE=CMPLXTYPE %OR SIZE=4 %THENSTART !!# %IF I&X'F00'=X'500' %THEN K=NEW LIST CELL(J,2);! AVOID DUPLICATE !!# ! ENTRIES BEING CREATED BY PLANTOP !!# SIZE=0 !!# TYPE=0 !!# ->CARRAY;! COMPLEX ARRAY, ALSO I*2(SINCE STRING DESC) !!# %FINISH !!# ->STORED !!#!* !!#!****** 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=FREESP(3) 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+NEWLISTCELL(PROCPARLIST,3)) 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) %CONSTSTRING(1)%ARRAY VARIANT(0:10) = %C "","","","","D","","C","","","","" %RECORD(PRECF)%NAME FN %HALFINTEGERARRAY T(0:511) %RECORD(RESF) R %RECORD(CHARF)%NAME CH %HALFINTEGER I,J,K,P2,PTR,CTEMP,RESLOC,RESWORDS,PCOUNT %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,AD) LOA(RESLOC) MOVE 4 TO MS;! copy desc as first(extra) param %FINISHELSESTART %IF I=CMPLXTYPE %THENSTART;! alloc space on local stack RESLOC=STACKCA STACKCA=STACKCA+4 LLA(RESLOC) OP1(MMS2);! address of complex result as first(extra) param %FINISHELSESTART I=FN_TYPE RESWORDS=1<<(I>>4-4);! 1,2, or 4 words OPB(ATPB,RESWORDS);! reserve result space %FINISH %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 SET PARAM(FPTR,TRIADS(PLINK)_RES1,P2) PLINK=TRIADS(PLINK)_OPD2 I=I-1 %REPEAT %FINISH !* %IF P2#2 %THEN FREE ACC ->C(P2) !* C(2): ! in-line fn C(3): ! MAX/MIN INLINE1(2,FN_LINK2,FN_TYPE,TRIADS(PLINK)_RES1) %RETURN !* C(1): ! INTRINSIC FNS REQUIRING A CALL I=FN_LINK2;! FN DETAILS K=FN_TYPE&15 J=I>>20&X'F';! PARAMETER MODE SYSCALL("F77".VARIANT(J).GEN NAME(I>>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 USER REF(FN_IDEN,ADDR(T(0)),PCOUNT+2,1) %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=FREESP(3) 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; ! DEFINE TEMP LOCATION ON STACK SAVE RES(STKLIT,CTEMP) %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 CELL(PROC PARLIST,3) PCOUNT=0 %WHILE NEXT#0 %CYCLE SS==RECORD(ADICT+NEXT) PCOUNT=PCOUNT+1 T(PCOUNT+1)=SS_INF0 FREE LIST CELL(NEXT,3) %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 false then report run-time error OPB(JTB,6) {jump if true 6 bytes} OPB(LDCB,ER) {2 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,RESMODE, %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) STL(TMP_ADDR);! store R part OP2(LDC2,ADI);! address I part OP2(TLATE1,LDDW) OPB(ROPS,NEGOP) STL(TMP_ADDR+2);! store I part CRES: RES_H0=I RES_H1=TMPID<<8!RESMODE %RETURN !* FN(25): ! IMAG + AIMAG LOAD ADDRESS(PARAMRES) OP2(LDC2,ADI) OP2(TLATE1,LDDW) RESMODE=REAL4 ->SETRES2 !* FN(6): ! CMPLX + DCMPLX RESMODE=CMPLX8 I=GET TEMP(0,CMPLX8) TMP==RECORD(ADICT+I) COERCE(PMODE,REAL4) STL(TMP_ADDR+2) OP3(MES2,TLATE1,LDDW) COERCE(PMODE,REAL4) STL(TMP_ADDR) ->CRES !* FN(10): ! ANINT SYSCALL("F77ROUNDL") SYSCALL("F77FLOATL") ->SETRES1 !* FN(11): ! NINT SYSCALL("F77FLOATL") %IF FNCODE=10 %THEN SYSCALL("F77FLOATL");! ANINT ->SETRES1 !* FN(9): ! AINIT + DINT SYSCALL("F77TRUNCL") ->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 %IF PMODE<3 %THENSTART;! int %IF PMODE=INT2 %THENSTART OP3(MES,EXCH,MODI) %FINISHELSESTART OP2(MES2,EXCH2) OPB(LOPS,MODOP) %FINISH %FINISHELSESTART OP3(MES2,EXCH2,REPL2);! a1,a2,a2 OP3(MMS2,MMS2,REPL2);! a1,a1 ... a2,a2 OP3(MES2,ROPS,DIVOP);! a1/a2 SYSCALL("F77TRUNCL") SYSCALL("F77FLOATL") OP3(MMS2,ROPS,MULTOP);! int(a1/a2)*a2 OPB(ROPS,SUBOP);! a1-int(a1/a2)*a2 %FINISH -> SETRES2 !* FN(14): ! SIGN + ISIGN,DSIGN %IF PMODE=INT2 %THENSTART OP3(MES,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(MMS2,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 %IF PMODE=INT2 %THENSTART OP3(MES,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(MES2,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: %IF RESMODE>TMP_MODE %THEN TMP_ADDR=0;! requires larger temp loc TMP_MODE=RESMODE %RETURN SETRES2: RES_H0=GET TEMP(INACC,RESMODE) RES_H1=TMPID<<8!RESMODE ACCUSE=-1 ACCDESC=RES_H0 %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=FREESP(3) !!# 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 LOADR (%INTEGER RDFMT, A, OLDMODE, NEW MODE) %INTEGER I !!# %IF OLDMODE >5 %THEN RCOMPLEX = 1 %AND OLDMODE = OLDMODE -3 !!# %IF UNASS#0 %AND RDFMT#CNSTID %THENSTART !!# I=LOAD(0,RDFMT,A,OLDMODE,OLDMODE) !!# %IF OLDMODE=5 %THEN OPTOS(STUH) !!# TEST UNASS(0) !!# %IF OLDMODE=5 %THEN OPTOS(LUH) !!# %UNLESS OLDMODE=NEWMODE&15 %THEN COERCE(OLDMODE,NEWMODE&15) !!# %FINISHELSESTART !!# LOAD TO ACC (RDFMT,A,OLDMODE,NEWMODE & 15) !!# %FINISH !!# ACCUSE=0 !!# RCOMPLEX = 0 %END ;! LOADR !* %ROUTINE LOADI (%INTEGER RDFMT,A,OLDMODE,NEWMODE) !!# %IF OLDMODE >5 %THENSTART !!# OLDMODE=OLDMODE-3 !!# ICOMPLEX = 1 <<(OLDMODE-1);! ITEM SIZE (BYTES) !!# RCOMPLEX = 1 !!# LOAD TO ACC (RDFMT,A,OLDMODE,NEWMODE & 15) !!# %FINISHELSESTART;! ZERO IMAGINARY PART !!# NEWMODE=NEWMODE&15 !!# %IF NEWMODE=3 %THEN A=LSS %ELSESTART !!# %IF NEWMODE=4 %THEN A=LSD %ELSE A=LSQ !!# %FINISH !!# OPLITT(A,0) !!# %FINISH !!# ACCUSE=0 !!# ICOMPLEX = 0 !!# RCOMPLEX = 0 %END ;!LOADI !* %ROUTINE STORER (%INTEGER RDFMT,A,OLDMODE,NEWMODE) !!# %IF NEWMODE>5 %THEN RCOMPLEX = 1 %AND NEWMODE = NEWMODE -3 !!# STORE(RDFMT,A,OLDMODE & 15,NEWMODE) !!# ACCUSE=0 !!# RCOMPLEX = 0 %END ;! STORE R !* %ROUTINE STORE I (%INTEGER RDFMT,A,OLDMODE,NEWMODE) !!# %IF NEWMODE >5 %THENSTART !!# NEWMODE = NEWMODE - 3 !!# ICOMPLEX = 1<<(NEWMODE-1);! ITEM SIZE (BYTES) !!# RCOMPLEX = 1 !!# %FINISHELSE %RETURN ;! ASSIGNING TO A REAL !!# STORE (RDFMT,A,OLDMODE & 15,NEWMODE) !!# ACCUSE=0 !!# ICOMPLEX = 0 !!# RCOMPLEX = 0 %END;! STORE I !* %ROUTINE COMPLEXOP(%INTEGER LF,LA,LMODE,RF,RA,RMODE,OP,OPMODE) %INTEGER TEMPA,I,CBASE,CPOWER,PTR,T %RECORD(TMPF)%NAME TMP %RECORD(RESF) NEWRES !* %RECORD(PRECF)%NAME PP %RECORD(SRECF)%NAME SS %SWITCH S(1:8) !************************************** do we need the following conversion of LA etc. *********** !!# %IF LF=CNSTID %THENSTART !!# LA=CONSTADDR(LA<>DSCALE !!# NEWRES_H1=TMPID<<8!(OPMODE&15+3) !!# %FINISH !!# ->S(OP) !!#!* !!#S(1): !COMPARISON !!# LFAULT(73);! COMPLEX OPERAND NOT VALID IN RELATIONAL EXPRESSION !!# RES=0 !!# %RETURN !!#!* !!#S(2): !+ !!# I=RAD !!#PLUSMINUS: LOADR(RF,RA,RMODE,OPMODE) !!# OPTOS(ST) !!# LOADR(LF,LA,LMODE,OPMODE) !!# OPTOS(I) !!# OPLNB(ST,TEMPA) !!# LOADI(RF,RA,RMODE,OPMODE) !!# %IF LMODE>5 %OR OP#2 %THENSTART !!# OPTOS(ST) !!# LOADI(LF,LA,LMODE,OPMODE) !!# OPTOS(I) !!# %FINISH !!#OUT: STOREI(2,TEMPA,OPMODE,OPMODE&7+3) !!#OUT1: RES=NEWRES !!# %IF LF=TMPID %THEN FREE TEMP(LA<PLUSMINUS !!#!* !!#S(4):!* !!#S(5):!/ !!# %IF CWORK=0 %THENSTART !!# CWORK=STACKCA-STACKBASE !!# PUTBYTES(7,96,0) !!# %FINISH !!# LOADR(RF,RA,RMODE,OPMODE) ;! R1 !!# OPLNB(ST,CWORK+32) !!# LOADI(RF,RA,RMODE,OPMODE) ;!C1 !!# OPLNB(ST,CWORK+48) !!# %IF LMODE>5 %OR OP=5 %THENSTART !!# LOADI(LF,LA,LMODE,OPMODE);!CO !!# OPLNB(ST,CWORK+16) !!# %FINISH !!# LOADR(LF,LA,LMODE,OPMODE) ;! R0 !!# OPLNB(ST,CWORK) !!# %IF OP=5 %THEN ->DIV !!# OPLNB(RMY,CWORK+32) ;!R0R1 !!# %IF LMODE>4 %THENSTART !!# OPLNB(SL,CWORK+16) ;!C0 !!# OPLNB(RMY,CWORK+48) ;!C0C1 !!# OPTOS(RRSB) ;!R0R1-C0C1 !!# %FINISH !!# OPLNB(ST,TEMPA) !!# OPLNB(LOADZ,CWORK) ;!R0 !!# OPLNB(RMY,CWORK+48) ;!R0C1 !!# %IF LMODE>5 %THENSTART !!# OPLNB(SL,CWORK+32) ;!R1 !!# OPLNB(RMY,CWORK+16) ;!R1C0 !!# OPTOS(RAD);!R0C1+R1C0 !!# %FINISH !!# ->OUT !!#DIV: PTR=NEW LIST CELL(CDIV2,2) !!# SS==RECORD(ADICT+PTR) !!# SS_INF0=CODECA !!# PLF1(JLK,0,0,0) ;! TO COMPLEX DIV !!# BREGUSE=0 !!# CTBUSE=0 !!# OPLNB(ST,TEMPA) !!# ->OUT1 !!#!* !!#S(6):! UNARY - !!# LF=0 !!# LA=0 !!# LMODE=1 !!# I=RSB !!# ->PLUSMINUS ;!CODE SOMEWHAT CRUDE !!#!* !!#S(7):!= !!# %IF LMODE>5 %THEN OPMODE=LMODE-3 %ELSE OPMODE=LMODE !!# LOADR(LF,LA,LMODE,OPMODE) !!# STORER(RF,RA,OPMODE,RMODE) !!# LOADI(LF,LA,LMODE,OPMODE) !!# STOREI(RF,RA,OPMODE,RMODE) !!# %RETURN !!#!* !!#S(8):!** !!# TMP==RECORD(ADICT+GET TEMP(0,CMPLX32));! TEMP LOCATION ON STACK !!# CBASE=TMP_ADDR !!# TMP==RECORD(ADICT+GET TEMP(0,CMPLX32)) !!# CPOWER=TMP_ADDR !!# LOADR(LF,LA,LMODE,OPMODE) !!# OPLNB(ST,CBASE) !!# LOADI(LF,LA,LMODE,OPMODE) !!# STOREI(2,CBASE,OPMODE,OPMODE&7+3) !!# LOADR(RF,RA,RMODE,OPMODE) !!# OPLNB(ST,CPOWER) !!# LOADI(RF,RA,RMODE,OPMODE) !!# STOREI(2,CPOWER,OPMODE,OPMODE&7+3) !!# OPTOS(STLN) !!# OPLITT(ASF,4) !!# %IF RMODE>5 %THEN I=2 %ELSE I=1;! C**C ELSE C**R !!# OPMODE=OPMODE&15 !!# OPLITT(LSS,OPMODE+2) !!# OPLITT(USH,27) !!# OPLITT(IAD,2) !!# OPLNB(SLSS,LNBSTACKBASE) !!# OPLITT(IAD,CBASE) !!# OPLITT(SLSS,OPMODE+2) !!# OPLITT(USH,27) !!# OPLITT(IAD,I) !!# OPLNB(SLSS,LNBSTACKBASE) !!# OPLITT(IAD,CPOWER) !!# OPLITT(SLSS,OPMODE+2) !!# OPLITT(USH,27) !!# OPLITT(IAD,2) !!# OPLNB(SLSS,LNBSTACKBASE) !!# OPLITT(IAD,TEMPA) !!# OPTOS(ST) !!# %IF I=1 %THEN OPMODE=OPMODE-3 !!# CALL PROC("ICL9CM".CX(OPMODE),11,1) !!# FREEREGS !!# ->OUT1 !* %END !* !* !* !****************************************************************************** !* * !* OBJECT FILE RED TAPE AND DIAGNOSTIC TABLES * !* * !****************************************************************************** !* %ROUTINE LOADDATA %INTEGERFNSPEC PUTNAME(%INTEGER AD) %ROUTINESPEC DEFER(%INTEGER FLAGS,AD) %HALFINTEGER I, J, K, REFAD, IDENAD, STARTST,DIAGS,PCTABLE %HALFINTEGER QPTR,PPTR,CNT,TOTCNT,CNTLOC,TOTCNTLOC,DEFLIST %HALFINTEGER PTR %INTEGER II;! required for cycles %INTEGER AD,LEN %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' REFAD=PP_CMNREFAD IDENAD=ANAMES+PP_IDEN %IF COM_SUBPROGTYPE=5 %THENSTART;! ENTRY IN BLOCK DATA I=REFAD REFAD=0 QPUT(14,LEN!(I<<24),REFAD,IDENAD) %FINISHELSESTART;! REF QPUT(10,7<<24!LEN,REFAD+STACKBASE,IDENAD) %FINISH %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 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 %FINISHELSESTART; !SCALAR J = PP_ADDR4 %IF PP_X0&16#0 %AND PP_TYPE#5 %THENSTART I=I!X'0010';! NON-CHAR SCALAR IN ARRAY AREA %FINISHELSESTART I=I!X'0040';! in GLA %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_ADDR4&X'FFFF8000'#0 %THENSTART;! USE FULL WORD ENTRY DEFER(I,PP_ADDR4) I=0; J=0 %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 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 !******** 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))) QPUT(8,0,0,0) %FINISH TOTALS(TTYPE7) %IF COM_FAULTY = 0 %THENSTART PRINTSTRING("Compilation successful ") !{2900C} COMREG(24)=0 !{2900C} COMREG(47)=LINEST %FINISHELSESTART !{2900C} COMREG(47)=COM_FAULTY WRITE(COM_FAULTY,4) PRINTSTRING(" errors in program ") %FINISH TOTAL FAULTS=0;! FOR NEXT TIME IN %STOP %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 !* %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 SYSCALL("STOP");! PRO TEM ******************************* !!# OPLITT(LSS,0) CALL FAUX(4) %FINISHELSESTART;! RETURN OP1(RETURN);! TEMP ACTION - MUST GO TO APPR. EPILOGUE ********** %FINISH !* !****** PROCESS EACH ENTRY POINT !* CURPTR = COM_SUBPROGPTR %WHILE CURPTR#0 %CYCLE PP==RECORD(ADICT+CURPTR) PLAB==RECORD(ADICT+PP_DISP);! private label record CODEEP=CODECA ENTRYCODE !* SET LINE NO(-COM_FIRSTSTATNUM) %UNLESS COM_SUBPROGTYPE=1 %THEN COPYPARS(CURPTR,0); ! COPY IN OPW(JMPW,PLAB_CODEAD-CODECA-3) %IF COM_SUBPROGTYPE#1 %THENSTART COPYPARS(CURPTR,1); ! COPY OUT !****** COPYPARS WILL ENSURE THAT RETURN NO IS SET IF NEC. %FINISH RT_PS=PARAM WORDS RT_RPS=RESULT WORDS+PARAM WORDS RT_LTS=STACKCA-RT_RPS RT_ENTRY<-CODEEP RT_EXIT<-CODECA RT_LL=1 RT_SP1=0 RT_SP2=0 RT_DIAG=DIAGCA RT_SP3=0 RT_ATEMPLATE=0 OP1(RETURN) %IF COM_SUBPROGTYPE=1 %THENSTART I=X'80010000' %FINISHELSESTART I=X'10000'!NEXT RTNO NEXT RTNO=NEXT RTNO+1 %FINISH QPUT(11,I,ADDR(RT_PS),ANAMES+PP_IDEN) PP==RECORD(ADICT+CURPTR) CURPTR=PP_LINK3;! TO NEXT ENTRY POINT %REPEAT 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 CELL(ARRAYLIST,3) 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(TLATE2,LDIND) STO(AD) %FINISHELSESTART %IF COMPLEX#0 %THENSTART OP1(LSSN) LOA(AD) OP3(EXCH2,STLATE,X'42') OPB(MOVB,4) %FINISHELSESTART OP2(TLATE3,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) FREE LIST CELL(ARRAYLIST,3) %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 !!# I=PTYPE>>4 !!# %IF PTYPE=5 %AND PARAM_LEN=0 %THENSTART;! CHARACTER*(*) array !!# OPLITT(PRCL,4) !!# OPLITT(LSS,STACKPTR) !!# OPLITT(USH,16) !!# OPLITT(IAD,DVAD) !!# OPLITT(LUH,15) !!# OPLNB(SLSS,4) !!# OPTOS(ST) !!# OPLNB(LCT,16) !!# OPLITT(RALN,8) !!# PLF1(CALL,DESC,CTB,FAUXREF);! enter F77AUX to extract element length (if available) !!# %IF ITEMSONSTACK=YES %THENSTART !!# OPLNB(LXN,0) !!# %FINISH !!# %FINISH !!# OPPARAM(LD,STACKPTR) !!# %IF I=4 %THENSTART;! INTEGER*2 !!# OPLITT(LDTB,0) !!# %FINISHELSESTART !!# %IF I=0 %THEN I=3;! X'18... FOR CHAR !!# OP CONSTANT(LDTB,SPEC CONST(I-3)) !!# %FINISH !!#!* !!# 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 COM_ARRAYCHECKS=NO %AND PTYPE#5 %THENSTART !!# I=I+DVREC_ZEROTOFIRST !!# OPLITT(INCA,-DVREC_ZEROTOFIRST*DVREC_ELLENGTH) !!# %FINISH !!# %IF PTYPE&7=3 %OR PTYPE=X'41' %THEN I=I<<1 !!# %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: !!# OPDV(STD,DVAD) !!# %IF COM_ARRAYCHECKS=FULL %THENSTART !!# OPPARAM(LSS,STACKPTR) !!# OPLITT(USH,8) !!# OPLITT(USH,-8) !!# %IF ADJUST=YES %THENSTART !!# OPBREG(ICP) !!# %FINISHELSESTART !!# OPLITT(ICP,DVREC_NUMELS) !!# %FINISH !!# PF3(JCC,10,0,5);! OK if >= !!# RT ERROR(ASIZEFAULT) !!# %FINISH !!#!* !!# %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 RT_PS=5 RT_RPS=6 %IF STACKCA>RT_RPS %THEN RT_LTS=STACKCA-RT_RPS %ELSE RT_LTS=0 RT_LL=2 RT_ENTRY<-ENTRY RT_EXIT<-CODECA RT_LL=2 RT_SP1=0 RT_SP2=0 RT_DIAG=0 RT_SP3=0 RT_ATEMPLATE=0 OP1(RETURN) ID="F_IOIT" QPUT(11,RTNO,ADDR(RT_PS),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) %HALFINTEGER RTNO RTNO=NEXT RTNO NEXT RTNO=NEXT RTNO+1 %IF IOTYPE>5 %THENSTART OP1(LDCMO) STO(TCTBASE+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) SYSCALL("F77IO") %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) %FINISH L=MODETOWORDS(R_MODE) ST=MODETOST(R_MODE) !* STARTIO !* OP2(LDL3,LDL2);! @ len type LDC(ST) LDC(L) OP2(TLATE3,STDW);! len(words), sizetype OP2(LDL5,LDL4);! @ address LOAD ADDRESS(R) OP2(TLATE3,STDW);! @ item 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 %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 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,GEQOP) 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<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<>11;! LISTINGS=XREF LISTCODE=(CONTROL&X'4000')>>14;! 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 !* RESULT WORDS=0 PARAM WORDS=0 LINENO WORD=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 !* !*********************************************************************** !*********************************************************************** !* %INTEGERFNSPEC GET LABEL ADDRESS(%INTEGER LABTYPE,LABREC) %ROUTINESPEC COMPUTED GOTO %INTEGERFNSPEC NEW PLAB %ROUTINESPEC DECLARE PLAB(%HALFINTEGER PTR) !* %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 CGENINIT !* %IF 1<=CGENEP<=2 %THENSTART;! physical end of file FINISH(CGENEP) %RETURN %FINISH !* LINEST=0 STACKCA=2 NEXT TRIAD = 1 ATRIADS=ADDR(TRIADS(0)_OP) EPILOGUE=NEW PLAB;! label to be jumped to at RETURN !* TRIAD LOOP: !* TR==RECORD(ADDR(TRIADS(NEXT TRIAD)_OP)) 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): !* 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): %IF TR_QOPD1=LABID %OR TR_QOPD1=PLABID %THENSTART K=GET LABEL ADDRESS(TR_QOPD1,TR_OPD1) OPW(JMPW,K) %FINISHELSESTART;! assigned GOTO LOAD VAL(TR_RES1) COERCE(TR_MODE,INT2);! for use in the switch to be used SS==RECORD(ADICT+COM_DPTR) SS_INF0=CODECA SS_LINK1=ASSIGNED GOTOS ASSIGNED GOTOS=COM_DPTR COM_DPTR=COM_DPTR+W4 OPBB(JMPW,0,0) %FINISH ->TRIAD LOOP !* T(CGT): COMPUTED GOTO ->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);! woill 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!! LOAD VAL(TR_RES1) K=GET LABEL ADDRESS(TR_QOPD2,TR_OPD2) OPW(JTW,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_QOPD1=NULL %THENSTART;! no specified param OP3(LDC0,LDC0,LDC0) %FINISHELSESTART 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(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+TR_OPD2<