! 10/12/85 - taken from optextb47, new include files incorporated
! 18/09/84 - insert switch for STFNID in ANAL and set QUAL(24) TO "STFNID"
! 27/08/84 - change PRINT TR for type 4 STMT triads
! 10/07/84 - new version of targetpnx_fptos
! 03/07/84 - put FPTOS in an include file
!          - set up string REG1 in targ_target & substitute for "reg-1"
! 21/03/84 - amend arrays OPVALS, ST, SZTY & REG
! 19/03/84 - change some address increments to W! etc.
! 08.03.84 - change INTEGER mapping increments to W1
! 28/02/84 - FPTOS inserted
!* modified 14/11/83
!*
! 01/11/83 copied from ercs06.rel90_optextb15
!*
%CONSTINTEGER OPSYS=0
!  =0  (Emas  ISO)
!  =1  (VME  EBCDIC)
!*
%INCLUDE "ERCS01:ftn_ht"
!* 
%INCLUDE "ERCS01:ftn_consts1"
!*
%INCLUDE "ERCS01:ftn_fmts2"
!*
%INCLUDE "ERCS01:ftn_triadops1"
!*
%INCLUDE "ERCS01:ftn_copy1"
!*
! %INCLUDE "targ_etoinitoe"
!*********************************************************************
!EBCDIC/ISO conversion routines
!*********************************************************************
!
!
%string(36) %fn FPTOS (%integer REAL ADDR{ess}, REAL MODE {3 for REAL* 4})
!                                                         {4 for REAL* 8}
!
!
!     A Procedure to print the value of either a single
!
!          or double or extended precision Real
!
!          for the FORTRAN77 Optimising Compiler.
!
!
!Note:  This version does not handle extended precision (REAL*16) reals
!
!
%longrealfnspec into range (%longreal a)

%routine copy (%integer length, from adr, from inc, to adr, to inc)
   !
   !
   from adr=from adr<< 1 %andc
     to adr=  to adr<< 1 %if host= perqpnx

    %while length>0 %cycle
           !
           byteinteger(to adr + to inc)= byteinteger(from adr + from inc)
                                to inc =   to inc + 1
                              from inc = from inc + 1
                                length =   length - 1
    %repeat
      !
%end; !of copy

!
!
!   Floating-Point Constants
!
!
%constlongrealarray rounding factor(0:1)=  5.0@-7 ,
                                           5.0@-7

%if HOST=ICL2900 %thenstart
        !
        !   Define Real Constants in ICL2900 Standard for EMAS
        !
        %constlongreal  ten to the max= r'7f235fadd81c2823'
        %constlongreal  ten to the min= r'0273cac65c39c961'
        %constlongreal   point one    = r'401999999999999a'

        %constinteger    maximum power=  75
        %constinteger    minimum power= -75

%finishelsestart
       !
       !   Define Real Constants in IEEE Standard on EMAS
       !
       %constintegerarray pnx ten to the max (0:1)= x'7fe1ccf3' , x'85ebc8a0'
       %constintegerarray pnx ten to the min (0:1)= x'0066789e' , x'3750f791'
       %constintegerarray pnx point one      (0:1)= x'3fb99999' , x'9999999a'

           %longrealname      ten to the max {to be mapped onto PNX TEN TO THE MAX}
           %longrealname      ten to the min {to be mapped onto PNX TEN TO THE MIN}
           %longrealname       point one     {to be mapped onto PNX POINT ONE     }

       %constinteger   maximum power=  308
       %constinteger   minimum power= -306
       %finish

!
!   Work-Areas
!
%byteintegerarray work area (0:30) {---used while formatting}
%byteintegerarray      text (0:37) {---used to construct the formatted value}

    %integer workarea addr {address of work-area(0)}
    %integer     text addr {address of text (0)}
!
!   Locals
!
    %integer     decs     ; !set to number of significant digits required
    %integer      exp     ; !set to number of digits to the left of the '.'
    %integer     sign     ; !set to either '+' or '-' or nothing
    %integer exponent     ; !set to the value of a floating-point exponent
    %integer   format     ; !set to 'F' if using fixed-point format, else set to 'E'
    %integer    chars reqd; !set to the number of digits to produce
    %integer     area ptr ; !ptr into WORK AREA
    %integer          ptr ; !ptr into TEXT
    %integer        i     ; !work variable
    %integer        n     ; !work variable

    %longreal    a; !the real value to be formatted
    %longreal    x; !the real value in the range 10.0> a>= 1.0


%if HOST=PERQPNX %thenstart
        !
        !   Initialise Real Constants
        !
            ten to the max==longreal(addr(pnx ten to the max(0)))
            ten to the min==longreal(addr(pnx ten to the min(0)))
             point one    ==longreal(addr(pnx point one(0)))
        %finish

!
!   Initialise Variables
!
    workarea addr= addr(work area(0))
        text addr= addr(     text(0))

    real mode= real mode-3
%if real mode= 0 %then a=        real(real addr{ess}) %and decs=7 %c
                 %else a=    longreal(real addr{ess}) %and decs=7
          exp= 1

!
!   Pick Up the REAL
!
%if a<0.0 %then a=-a %and  sign='-'                                   %c
                     %else sign= 0

!Scale the REAL into the range: 10.0> a >=1.0
       !
      %if a = 0.0 %then       x= 0.0 %and exp= 0                   %c
                  %elsestart

          x =into range(a) + rounding factor(real mode)
      %if x>=10.0 %thenstart
                     x=  x/10.0; !apply correction if rounding
                   exp=exp+1   ; !      put the value back out of range
                  %finish
      %finish

%if 0<= exp< decs %thenstart
    !
    !
    !   Output the REAL in Fixed-Point Format
    !
    !
        decs= decs-exp; !reduce DECS by digits reqd to the left of the '.'
      format='F'
            {Fixed-Point}

%finishelsestart
 !
 !
 !   Output the REAL in Floating-Point Format
 !
 !
     exponent=  exp-1 %and exp= 1; !one digit reqd to the left of '.'
         decs= decs-1            ; !     and reduce digits right of '.' accordingly
       format='E'
      %finish

!Analyse Form of the Number Required:
                 !
                 !
       chars reqd= decs + exp

          %if exp= 0 %then workarea(0)= '0' %and  area ptr= 1 %and exp= 1   %c
                                            %else area ptr= 0

!Acquire the Digits in Character Form:
                    !
                    !
  %while chars reqd\= 0 %cycle
         chars reqd = chars reqd - 1

                  n = int pt (x)
                  x =   10.0*(x - n)
  workarea(area ptr)=     '0'   + n
           area ptr =  area ptr + 1
                    !
              %repeat

!Produce the Formatted Number:
             !
             !
         ptr = 1

%unless sign = 0 %then text(ptr)= sign                             %c
                 %and       ptr =  ptr+1
    !
    !   Write out Digits to the LEFT of the Decimal Point
    !
     copy (exp, workarea addr, 0, text addr, ptr)
              !
      area ptr=       exp
           ptr= ptr + exp

      text(ptr)= '.'     {write out              }
           ptr = ptr + 1 {      the decimal point}
    !
    !   Write Out the Digits to the RIGHT of the Decimal Point
    !
     copy (decs,workarea addr,area ptr,text addr,ptr)
      ptr= decs+ptr


%if format='E' %thenstart
    !
    !
    !   Now Format the Exponent
    !
    !
    %if exponent< 0 %then exponent=-exponent %and  sign='-'       %c
                                             %else sign='+'
        text(ptr  )= 'E'
        text(ptr+1)= sign
             ptr   =  ptr+2

          i = exponent//10
 text(ptr  )=       i + '0'
 text(ptr+1)= exponent- (i*10) + '0'
      ptr   = ptr+2
%finish


!Return the Formatted Value:
      !
      !
       text(0)= ptr-1 %andresult= string(addr(text(0)))



%longrealfn INTO RANGE (%longreal x)
!
!
!
!     A Procedure which brings the Value of the given
!
!       Parameter into the Range   10.0> X >=1.0
!
!
!Additionally, the variable EXP is changed to reflect the
!              magnitude (scale of 10) of the parameter.
!
!
%longreal y
%longreal z
!
%integer i; !a work variable

%if x>=10.0 %thenstart
    !
    !   The value is too large
    !
    %if x< ten to the max %thenstart
        !
        !   Find the scale of the number and bring it into range
        !
         i= 1;  z= 10.0
                y=100.0
                !
        z=y %and y=z*10.0 %and i=i+1 %while x>=y
                !
                x=x/z %and exp=exp+ i
        %finishelse        exp=exp+ maximum power %and x=x/ten to the max
        %finish

%if x<1.0 %thenstart
    !
    !   The value is too small
    !
     x=x*10.0 %and exp=exp-1 %while x<ten to the min
            !
           i=  1
           z=point one
            !
     i=i+1 %and z=z/10.0 %while x<z
            !
         exp=exp-i
           x= x * (10.0**i)
    %finish

!
!   Return
!
%result= x
   %end; !of INTO RANGE



%end; !of FPTOS
!
%CONSTSTRING(7) %ARRAY OPVALS(0:116)=                                  %C
      "NULL",     "REL",      "+",        "-",
      "*",        "/",        "NEG",      "=",
      "CVT",      "ARR",      "ARR1",     "BOP",
      "ASGN",     "",         "EXP",      "",
      "AND",      "OR",       "NOT",      "EQUIV",
      "NEQ",      "GT",       "LT",       "NE",       
      "EQ",       "GE",      "LE",       "SUBSTR",
      "CHAR",     "CONCAT",   "CHHEAD",   "",
      "STOD1",    "STOD2",    "STODA",    "",      
      "EOD1",     "EOD2",     "EODA",     "EODB",
      "BRK",      "DEFARR",   "RSUB",     "RDIV",    
      "DCHAR",    "ASH",      "",         "",
      "STRTIO",   "IOITEM",   "IODO",     "IOSPEC",
      "IO",       "DIOITEM",  "ASGN",     "ASMT",
      "SUBS",     "ARGARR",   "INIT",     "INCR",     
      "DECR",     "DINIT",    "PINCR",    "",
      "NOOP",     "FUN",      "CALL",     "ARG",
      "STRTSF",   "ENDSF",    "CALLSF",   "IFUN",
      "DARG",     "IARG",     "REPL",     "REF",
      "LOADB",    "STOREB",   "MOO",      "",
      "JIT",      "JIF",      "JINN",     "JINP",
      "JINZ",     "JIN",      "JIP",      "JIZ",
      "CGT",      "GOTO",     "RET",      "STOP",
      "PAUSE",    "EOT",  "NINT",    "ANINT",
      "STMT",     "ITS",      "PA", "TOCHAR",
   "DIM",       "DMULT",      "AINT",     "ABS",
      "MOD",      "SIGN",     "MIN",      "MAX",
      "REAL",     "IMAG",     "CMPLX",    "CONJG",
      "LEN",      "ICHAR",    "INDEX",    "DCMPLX",
      "INTRIN"

!*
%CONSTSTRING(7) %ARRAY QUAL(0:66)=     %C
      "NULL",      "LABID",    "PLABID",   "PROCID",    "STKLIT",
    "GLALIT",     "SRTEMP",      "Breg",  "VALTEMP",   "DESTEMP",
          "",           "",          "",         "",          "",
          "",    "LSCALID",   "OSCALID",  "CSCALID",   "ASCALID",
   "PSCALID",      "ARRID",     "TMPID",   "PERMID",    "STFNID",
          "",           "",          "",         "",          "",
          "",           "",     "TRIAD",    "ARREL",    "CHAREL",
     "CHVAL",           "",          "",         "",           "",
          "",           "",          "",         "",           "",
          "",           "",          "",         "",           "",
          "",           "",          "",         "",           "",
          "",           "",          "",         "",           "",
          "",           "",          "",          "",       "LIT",
    "NEGLIT",     "CNSTID"
%CONSTBYTEINTEGERARRAY ST(0:15)=   %C
      X'41',X'51',X'61',X'52',X'62',X'72',X'53',X'63',
      X'73',X'34',X'44',X'54',X'64',X'05',X'51',X'31'
%CONSTSTRING(8) %ARRAY SZTY(0:15)=   %C
      "INT2",    "INT4",     "INT8",     "REAL4",     "REAL8",
      "REAL16",  "CMPLX4",   "CMPLX8",   "CMPLX16",   "LOG1",
      "LOG2",    "LOG4",    "LOG8",      "CHARMODE",  "HOLMODE",
      "BYTE"

%CONSTBYTEINTEGERARRAY C(0:15)='0','1','2','3','4','5','6','7',
                               '8','9','A','B','C','D','E','F'
%CONSTSTRING(2) %ARRAY COMPAR(1:6)="GT","LV","NE","EQ","GE","LE"
%CONSTSTRING(5) %ARRAY LOG(0:1)="FALSE","TRUE"
%CONSTBYTEINTEGERARRAY INDENT(1:9)=10,8,8,14,10,10,10,6,68
%CONSTSTRING(6) TMPRES="IR IN "
%OWNINTEGER IRADR
!*
!*                        PSTRING                                    *!
!*
%ROUTINE PSTRING(%INTEGER TAB,%STRING(32) S,%INTEGER LEVEL)
%INTEGER LEN
%SWITCH SW(0:1)
      LEN=LENGTH(S)
      -> SW(TAB) %IF TAB<2 %AND TAB>=0
      -> PRINT
SW(0): 
      NEWLINE
      PRINTSTRING("TRIADNO   LHS     OP      RHS")
      %IF LEVEL=2 %THEN %START
         SPACES(11)
         PRINTSTRING("QL        QR        MODE")
      %FINISH
      NEWLINE
      %RETURN
SW(1):
      PRINTSTRING("p".S)
      SPACES(INDENT(TAB)-LEN-1)
      %RETURN
PRINT:
      PRINTSTRING(S)
      %IF IRADR#0 %THENSTART
         WRITE(IRADR,12)
         IRADR=0
         LEN=LEN+12
      %FINISH
      SPACES(INDENT(TAB)-LEN)
      %RETURN
%END
!*                                                                   *!
!*                           ITOS                                    *!
!*                                                                   *!
%STRING(31) %FN ITOS(%INTEGER N)
%CONSTINTEGERARRAY TENS(0:9)=%C
1,10,100,1000,10000,100000,1000000,10000000,100000000,1000000000
%STRING(11) RES
%INTEGER M,R,I,STARTED,J
      %IF N=0 %THEN %RESULT="0";
      %IF N<0 %THEN N=-N %AND RES="-" %ELSE RES=""
      STARTED=0
      %CYCLE I=9,-1,0
      R=TENS(I)
      %IF N>=R %OR STARTED#0 %START
      STARTED=1
      M=N//R
      RES=RES.TOSTRING(M+'0')
      N=N-M*R
      %FINISH
      %REPEAT
      %RESULT=RES
%END
!*                         ANAL                                      *!
!*                                                                   *!
%ROUTINE ANAL(%INTEGER INDEX,OPD,TAB,ADICT,ANAMES,LEVEL)
%SWITCH SW(0:66)
%SWITCH T(0:14)
%STRING(32) S
%INTEGER J,LEN,ADR,IDEN,I,K
%REAL X,Y
%LONGREAL XX,YY
%LONGLONGREAL XXX,YYY
%RECORD (CONSTRECF) %NAME CNST
%RECORD (PRECF) %NAME SCAL
%RECORD (PRECF) %NAME PROC
%RECORD (TMPF) %NAME TMP
%RECORD (LABRECF) %NAME LAB
%RECORD(PLABF)%NAME PLAB
%RECORD(TERECF)%NAME TE
%RECORD(DTRECF)%NAME DT
      -> SW(INDEX)
SW(*):%RETURN
SW(NULL):   !NULL                                             NULL
      PSTRING(TAB,QUAL(0),LEVEL)
      %RETURN
SW(LIT):   !LITERAL                                          LIT
      S=ITOS(OPD)
SW1:  PSTRING(TAB,S,LEVEL)
      %RETURN
SW(NEGLIT):
      S="-".ITOS(OPD)
      ->SW1
SW(CNSTID):   !CONST RECORD IN DICT                             CNSTID
      CNST==RECORD(OPD<<DSCALE+ADICT)
      ADR=CNST_DADDR
      -> T(CNST_MODE)
T(INT2):
      J=HALFINTEGER(ADR+ADICT)
      -> INT
T(INT4):
      J=INTEGER(ADR+ADICT)
      -> INT
T(INT8):
      J=INTEGER(ADR+ADICT+W1)
INT:  S=ITOS(J)
SOUT: PSTRING(TAB,S,LEVEL)
      %RETURN
T(REAL4):
      X=REAL(ADR+ADICT)
      S=FPTOS(ADDR(X),3)
      ->SOUT
T(REAL8):
      XX=LONGREAL(ADR+ADICT)
      S=FPTOS(ADDR(XX),4)
      ->SOUT
!*
! %INCLUDE "targ_text2"
! ***********************************************************************
! include code for REAL*16 numbers if required
! ***************************************************************************
!*
T(CMPLX8):
      X=REAL(ADR+ADICT)
      Y=REAL(ADR+ADICT+W1)
      S="(".FPTOS(ADDR(X),3).",".FPTOS(ADDR(Y),3).")"
      ->SOUT
T(CMPLX16):
      XX=LONGREAL(ADR+ADICT)
      YY=LONGREAL(ADR+ADICT+W2)
      S="(".FPTOS(ADDR(XX),4).",".FPTOS(ADDR(YY),4).")"
      -> SOUT
SP:
      %IF CNST_MODE<6 %THEN J=9 %ELSE J=21
      SPACES(INDENT(TAB)-J)
      %RETURN
T(LOG4):
      J=INTEGER(ADR+ADICT)
      -> LOG
T(LOG8):
      J=INTEGER(ADR+ADICT+W1)
LOG:
      %IF J#0 %THEN J=1
      PSTRING(TAB,LOG(J),LEVEL)
      %RETURN
T(CHARMODE):
T(HOLMODE):
      LEN=INTEGER(ADR+ADICT)
      %IF LEN>4 %THEN LEN=4
      COPY(LEN,ADR+ADICT,4,ADDR(S),1)
      LENGTH(S)=LEN
      S="'".S."'"
      LEN=LEN+2
!      %INCLUDE "targ_text1"
! *************************************************************************
! include code for EBCDIC/ISO conversion if required
! *****************************************************************************
      PSTRING(TAB,S,LEVEL)
      %RETURN
T(*):
      %RETURN
SW(SRTEMP):  ! strength reduction temporary
      S="sr".ITOS(OPD)
      ->SOUT
SW(ARREL):   ! ARRAY ELEMENT TRIAD
SW(CHAREL):   ! CHAR SUBSTRING TRIAD
SW(TRIAD):   !TRIAD                                            TRIAD
      S=ITOS(OPD)
      S="p".S
      ->SOUT
SW(LSCALID):   !LOCAL SCALAR                                     LSCALID
SW(OSCALID):   !OWN SCALAR                                       OSCALID
SW(CSCALID):   !COMMON SCALAR                                    CSCALID
SW(ASCALID):   !   scalar equivalenced to array
SW(PSCALID):   !PARAMETER SCALAR                                 PSCALID
SW(ARRID):   !ARRAY ID                                         ARRID
      SCAL==RECORD(OPD<<DSCALE+ADICT)
      S=STRING(ANAMES+SCAL_IDEN)
      ->SOUT
SW(PERMID):
SW(TMPID):   !TEMP SCALAR                                      TMPID
      TMP==RECORD(OPD<<DSCALE+ADICT)
      s=itos(tmp_index)
      s="TEMP".s
      ->SOUT
SW(LABID):  !LABEL IDENTIFIER                                 LABID
      LAB==RECORD(OPD<<DSCALE+ADICT)
      S=ITOS(LAB_LAB)
      S="LABEL ".S
      ->SOUT
SW(PLABID):  !PRIVATE LABEL IDENTIFIER                         PLABID
      PLAB==RECORD(ADICT+OPD<<DSCALE)
      s=ITOS(PLAB_INDEX)
      s="PLAB".s
      ->SOUT
SW(PROCID):  !PROCEDURE IDENTIFIER                             PROCID
SW(STFNID):  !STMT. FUNCTION IDENTIFIER
      PROC==RECORD(ADICT+OPD<<DSCALE)
      S=STRING(ANAMES+PROC_IDEN)
      ->SOUT
!SW(ARREL):  !ARRAY ELEMENT REFERENCE                          ARREL
      PROC==RECORD(OPD<<DSCALE+ADICT)
      S=STRING(ANAMES+PROC_IDEN)
      ->SOUT
SW(VALTEMP):
      TE==RECORD(ADICT+OPD<<DSCALE)
      s=ITOS(TE_INDEX)
      s="vt".s
      ->SOUT
SW(DESTEMP):
      DT==RECORD(ADICT+OPD<<DSCALE)
      s=ITOS(DT_INDEX)
      s="dt".s
      ->SOUT
SW(BREG):
      S=REG1
      ->SOUT
%END
!*
!*                         PRINT TRIAD
!*
%CONSTBYTEINTEGERARRAY HEX(0 : 15) =   %C
 '0','1','2','3','4','5','6',
'7','8','9','A','B','C','D','E','F'
%ROUTINE PRHEX(%INTEGER J)
%INTEGER K
      %CYCLE K = 28,-4,0
         PRINT SYMBOL(HEX((J>>K)&15))
      %REPEAT
%END
%ROUTINE DUMP(%INTEGER AD,LEN)
%INTEGER I
      %CYCLE I=1,1,3
         SPACES(2)
         PRHEX(INTEGER(AD))
         AD=AD+W1
      %REPEAT
%END;! DUMP
!*
%EXTERNALROUTINE PRINT TR(                                        %C
                              %INTEGER INDEX,ADICT,ANAMES,LEVEL,
                              %RECORD (TRIADF) %NAME TRIADS)                            
%INTEGER I,J,VAL
%STRING(32) MODE,OP,NO,SPARE
%STRING(1) P
      NO=""
      SPARE=""
      IRADR=0
      %IF LEVEL<0 %THENSTART
         LEVEL=-LEVEL
         PSTRING(0,NO,LEVEL)
      %FINISH
      NO=ITOS(INDEX)
      PSTRING(1,NO,LEVEL)
      P="p"
      OP=OPVALS(TRIADS_OP&X'7F')
      %IF OP="PAUSE" %OR OP="STOP" %THENSTART
         PSTRING(2," ",LEVEL)
         ->SKIP
      %FINISH
      %IF OP="IOSPEC" %THENSTART
         PRINTSTRING("        IOSPEC                ")
         ->OUT
      %FINISH
      %IF OP="IO" %THENSTART
         PRINTSTRING("        IO                    ")
         ->OUT
      %FINISH
      %IF OP="PA" %THENSTART
         PSTRING(2,"NULL",LEVEL)
         PSTRING(3,OP,LEVEL)
         PSTRING(4,"NULL",LEVEL)
         -> OUT
      %FINISH
      %IF OP="STMT" %THENSTART
         PSTRING(2,ITOS(TRIADS_SLN),LEVEL)
         MODE="NULL"
        %IF TRIADS_VAL2=4 %THENSTART
          PSTRING(3,OP,LEVEL)
          %IF TRIADS_QOPD2=0 %THEN SPARE="start " %ELSE SPARE="end "
          SPARE=SPARE.STRING(TRIADS_OPD2<<DSCALE+ADICT)
          PSTRING(4,SPARE,LEVEL)
          ->SKIP2
        %FINISH
      %FINISHELSESTART
         ANAL(TRIADS_QOPD1,TRIADS_OPD1,2,ADICT,ANAMES,LEVEL)
         MODE=SZTY(TRIADS_MODE&15)
      %FINISH
SKIP: PSTRING(3,OP,LEVEL)
      ANAL(TRIADS_QOPD2,TRIADS_OPD2,4,ADICT,ANAMES,LEVEL)
SKIP2:%IF LEVEL=2 %THEN %START
         PSTRING(5,MODE,LEVEL)
         PSTRING(6,QUAL(TRIADS_QOPD1),LEVEL)
         PSTRING(7,QUAL(TRIADS_QOPD2),LEVEL)
         %IF SPARE#"" %THEN PSTRING(8,SPARE,LEVEL) %AND SPARE=""
      %FINISH
OUT:  DUMP(ADDR(TRIADS_OP),12)
      NEWLINE
%END
!*
%ENDOFFILE