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