%include "itrimp_hostcodes"
%CONSTINTEGER TARGET=M88K
%EXTERNALROUTINESPEC IOCP %ALIAS "s_iocp"(%INTEGER EP,N)
%CONSTLONGREAL GREATEST= 7.2370055773322608@ 75{R'7FFFFFFFFFFFFFFF'}
%EXTERNALROUTINE MOVE %ALIAS "s_move"(%INTEGER LENGTH,FROM,TO)
%INTEGER I
      %RETURNIF LENGTH<=0
      %IF target=emas %THENSTART
         I=X'18000000'!LENGTH
         *LSS_FROM
         *LUH_I
         *LDTB_I
         *LDA_TO
         *MV_ %L = %DR
      %FINISHELSEIF target=perq %OR TARGET=ACCENT %OR target=pnx %START
         %CYCLE i=0,1,length>>2-1
            halfinteger(to+i)=halfinteger(from+i)
         %REPEAT
      %FINISHELSESTART;                 ! ibm etc
         %if FROM<=TO<=FROM+LENGTH %START
            %CYCLE I=length-1,-1,0
               byteinteger(to+i)=byteinteger(from+i)
            %repeat
         %else
            %CYCLE i=0,1,length-1
               byteinteger(to+i)=byteinteger(from+i)
            %REPEAT
         %finish
      %FINISH
%END
%EXTERNALROUTINE FILL %ALIAS "s_fill"(%INTEGER LENGTH,FROM,FILLER)
%INTEGER I,j
      %RETURNIF LENGTH<=0
      %IF target=emas %START
         I=X'18000000'!LENGTH
         *LDTB_I
         *LDA_FROM
         *LB_FILLER
         *MVL_ %L = %DR
      %FINISHELSEIF target=perq %OR TARGET=ACCENT %OR target=pnx %START
         j=filler<<8!filler
         %FOR i=0,1,length>>1-1 %CYCLE
            halfinteger(from+i)=j
         %REPEAT
      %FINISHELSESTART
         byteinteger(i)=filler %FOR i=FROM,1,FROM+length-1
      %FINISH
%END

! IMP ROUTINES FOR DATE AND TIME
%if target#DRS %then %start
%EXTERNALLONGREALFN CPUTIME
      %RESULT=1
%END;                                   ! CPUTIME
                                        !*
%EXTERNALSTRINGFN DATE
%STRING (10) D,T,U,V
      D="YYYY.MM.DD"
      T="HH:MM:SS"
      %RESULT=D
%END;                                   ! DATE
                                        !*
%EXTERNALSTRINGFN TIME
%STRING (10) D,T
      D="DD.MM.YY"
      T="HH:MM:SS"
      %RESULT=T
%END
%finish
%EXTERNALINTEGERFN SIZE OF %ALIAS "s_sizeof"(%NAME X)
!***********************************************************************
!*    returns the size of a %NAME paramterer                           *
!***********************************************************************
%CONSTBYTEINTEGERARRAY BYTES(0:7)= 1(4),2,4,8,16
%INTEGER I
      %IF target=emas %START
         *LSS_(%LNB +5)
         *ST_I
         %IF I&X'C2000000'#0 %THENRESULT=I&X'00FFFFFF'
         I=(I>>27)&7
      %FINISHELSEIF target=perq %or target=DRS %OR TARGET=ACCENT %START
         **x+4; **=i
         %IF i&7>=3 %THENRESULT=i>>16
         i=(i>>4)&7
      %FINISH%ELSE %IF target=pnx %START
         *ILP2; **=i
         %if i&7>=3 %THEN %RESULT=i>>16
         i=(i>>4)&7
      %FINISH %ELSE %IF TARGET=IBM %OR TARGET=IBMXA %OR TARGET=AMDAHL %START
         *L_1,X; *ST_1,I
         %RESULT=I>>16
      %FINISH %else %if 1<<target&emachine#0 %then %start
         **x; **=i
         %result=i>>16
      %finish
      %RESULT=BYTES(I)
%END
%EXTERNALSTRING (255) %FN SUBSTRING %ALIAS "s_substring"(%STRINGNAME S,
    %INTEGER I,J)
%INTEGER k
%STRING (255) HOLDS
      %IF I<1 %OR I>J+1 %OR J>LENGTH(S) %THENSIGNALEVENT 5,7
      J=J-I+1
      LENGTH(HOLDS)=J
      charno(holds,k)=charno(s,i+k-1) %FOR k=1,1,j
      %RESULT=HOLDS
%END
%EXTERNALROUTINE CLOSE STREAM(%INTEGER STREAM)
!      %IF STREAM>98 %OR STREAM<1 %OR COMREG(22)=STREAM           %C
%OR COMREG(23)=STREAM %THEN SSERR(24)
      IOCP(16,STREAM)
%END

%EXTERNALINTEGERFN SIGN %ALIAS "s_sign"(%LONGREAL VALUE)
      %IF VALUE>0 %THENRESULT=1
      %IF VALUE<0 %THENRESULT=-1
      %RESULT=0
%END
%EXTERNALLONGREALFN MAXREAL %ALIAS "s_maxreal"
      %RESULT=GREATEST
%END
%EXTERNALLONGREALFN MINREAL %ALIAS "s_minreal"
      %RESULT=R'0010000000000000'
%END
%EXTERNALINTEGERFN MAXINT %ALIAS "s_maxint"
      %RESULT=X'7FFFFFFF'
%END
%EXTERNALLONGREALFN EPSILON %ALIAS "s_epsilon"
      %RESULT=R'3410000000000000'
%END
                                        ! NEEDS CHANGING FOR OTHER WLENGT
%CONSTLONGREAL PMAX= 1@16
%CONSTLONGREAL DZ= 0
%CONSTLONGREAL D0= 0, D1 = 1
%STRING(15)%FNSPEC SWRITE(%INTEGER VALUE,PLACES)
!
%if target#Gould %and target#DRS %start
%EXTERNALROUTINE WRITE %ALIAS "s_write"(%INTEGER VALUE,PLACES)
!***********************************************************************
!*    SIMPLE MINDED ALL IMP VERSION NOT USING STRINGS                  *
!***********************************************************************
%INTEGER SIGN,WORK,PTR
%BYTEINTEGERARRAY CH(0:15)
      SIGN=' '
      %IF VALUE=X'80000000' %THEN PRINTSTRING(SWRITE(VALUE,PLACES)) %AND %RETURN
      %IF VALUE<0 %THEN SIGN='-' %AND VALUE=-VALUE
      PTR=0
      %CYCLE
         WORK=VALUE//10
         CH(PTR)=VALUE-10*WORK
         VALUE=WORK
         PTR=PTR+1
      %REPEATUNTIL VALUE=0
      %IF PLACES>PTR %THEN SPACES(PLACES-PTR)
      WORK=PTR-1
      PRINT SYMBOL(SIGN)
      PRINT SYMBOL(CH(PTR)+'0') %FOR PTR=WORK,-1,0
%END
%finish
%EXTERNALSTRING(15)%FN SWRITE %ALIAS "s_swrite"(%INTEGER VALUE,PLACES)
!***********************************************************************
!*    SIMPLE MINDED ALL IMP VERSION                                    *
!***********************************************************************
%STRING(1)SIGN
%STRING(15)RES
%INTEGER WORK,PTR
%STRING(1)%ARRAY CH(0:15)
      RES=""
      SIGN=" "
      %IF VALUE=X'80000000' %THEN %START
         RES="-2147483548"
         RES=" ".RES %FOR PTR=1,1,PLACES-10
         %RESULT=RES
      %FINISH
      %IF VALUE<0 %THEN SIGN="-" %AND VALUE=-VALUE
      PTR=0
      %CYCLE
         WORK=VALUE//10
         CH(PTR)=TOSTRING(VALUE-10*WORK+'0')
         VALUE=WORK
         PTR=PTR+1
      %REPEATUNTIL VALUE=0
      RES=RES." " %FOR WORK=PTR,1,PLACES-1
      WORK=PTR-1
      RES=RES.SIGN
      RES=RES.CH(PTR) %FOR PTR=WORK,-1,0
      %RESULT=RES
%END
%EXTERNALSTRING(15)%FN ITOS %ALIAS "s_itos"(%INTEGER N)
!***********************************************************************
!*    SIMPLE PRINT WITH NO LEADING SPACE                               *
!***********************************************************************
%STRING(16)S
%INTEGER SIGN, W, D
      %RESULT = "0" %IF N = 0
!
      SIGN = 1
      %IF N < 0 %START
         SIGN = -1
         %IF N = X'80000000' %THEN %RESULT="-2147483648"
         N = -N
      %FINISH
      S = ""
      %WHILE N > 0 %CYCLE
         W = N // 10
         D = N - W * 10
         S = TOSTRING('0' + D) . S
         N = W
      %REPEAT
      S = "-" . S %IF SIGN < 0
      %RESULT = S
%END; ! ITOS
%CONSTSTRING(1)%ARRAY HEX(0:15)="0","1","2","3","4",
               "5","6","7","8","9","A","B","C","D","E","F"
%EXTERNALROUTINE PRHEX(%INTEGER VALUE, PLACES)
%INTEGER I
      %CYCLE I=PLACES<<2-4, -4, 0
         PRINT STRING(HEX(VALUE>>I&15))
      %REPEAT
%END
%EXTERNALSTRING(8)%FN HTOS %ALIAS "s_htos" (%INTEGER VALUE,PLACES)
%INTEGER I
%STRING(8)RES
      RES=""
      %FOR I=PLACES<<2-4,-4,0 %CYCLE
         RES=RES.HEX(VALUE>>I&15)
      %REPEAT
      %RESULT=RES
%END
 %if Target#Gould %and target#DRS %then %Start
%ROUTINESPEC PRINTFL(%LONGREAL X, %INTEGER N)
%EXTERNALROUTINE PRINT %ALIAS "s_print"(%LONGREAL X, %INTEGER N,M)
!***********************************************************************
!*       PRINTS A REAL NUMBER (X) ALLOWING N PLACES BEFORE THE DECIMAL *
!*       POINT AND M PLACES AFTER.IT REQUIRES (M+N+2) PRINT PLACES     *
!*       UNLESS (M=0) WHEN  (N+1) PLACES ARE REQUIRED.                 *
!*                                                                     *
!*       A LITTLE CARE IS NEEDED TO AVOID UNNECESSARY LOSS OF ACCURACY *
!*       AND TO AVOID OVERFLOW WHEN DEALING WITH VERY LARGE NUMBERS    *
!***********************************************************************
%LONGREAL Y,Z,ROUND,FACTOR
%INTEGER I,J,L
%BYTEINTEGER SIGN
      M=M&63;                           ! DEAL WITH STUPID PARAMS
      %IF N<0 %THEN N=1; N=N&31;        ! DEAL WITH STUPID PARAMS
      X=X+DZ;                           ! NORMALISE
      SIGN=' ';                         ! '+' IMPLIED
      %IF X<0 %THEN SIGN='-'
      Y=MOD(X);                         ! ALL WORK DONE WITH Y
      ROUND=0.5/10**M;                  ! ROUNDING FACTOR
      %IF Y>PMAX %OR N=0 %THENSTART;    ! MEANINGLESS FIGURES GENERATED
         %IF N>M %THEN M=N;             ! FOR FIXED POINT PRINTING
         PRINT FL(X,M);                 ! OF ENORMOUS NUMBERS
         %RETURN;                       ! SO PRINT IN FLOATING FORM
      %FINISH
      I=0; Z=1; Y=Y+ROUND
      %UNTIL Z>Y %CYCLE;                ! COUNT LEADING PLACES
         I=I+1; Z=10*Z;                 ! NO DANGER OF OVERFLOW HERE
      %REPEAT
      SPACES(N-I);                      ! O.K FOR ZERO OR -VE SPACES
      PRINT SYMBOL(SIGN)
      J=I-1; Z=10**J
      FACTOR=1/10
      %CYCLE
         %UNTIL J<0 %CYCLE
            L=INT PT(Y/Z);              ! OBTAIN NEXT DIGIT
            Y=Y-L*Z; Z=Z*FACTOR;        ! AND REDUCE TOTAL
            PRINT SYMBOL(L+'0')
            J=J-1
         %REPEAT
         %IF M=0 %THENRETURN;           ! NO DECIMAL PART TO BE O/P
         PRINTSTRING(".")
         J=M-1; Z=10**(J-1); M=0
         Y=10*Y*Z
      %REPEAT
%END;                                   ! OF ROUTINE PRINT
%EXTERNALROUTINE PRINTFL %ALIAS "s_printfl"(%LONGREAL X, %INTEGER N)
!***********************************************************************
!*       PRINTS IN FLOATING POINT FORMAT WITH N PLACES AFTER THE       *
!*       DECIMAL POINT. ALWAYS TAKES N+7 PRINTING POSITIONS.           *
!*       CARE REQUIRED TO AVOID OVERFLOW WITH LARGE X                  *
!***********************************************************************
%LONGREAL SIGN,ROUND,FACTOR,LB,UB
%INTEGER COUNT,INC
      ROUND=0.5/10**N;                  ! TO ROUND SCALED NO
      LB=1-ROUND; UB=10-ROUND
      SIGN=1
      X=X+DZ;                           ! NORMALISE
      %IF X=0 %THEN COUNT=-99 %ELSESTART
         %IF X<0 %THEN X=-X %AND SIGN=-SIGN
         INC=1; COUNT=0
         FACTOR=1/10
         %IF X<=1 %THEN FACTOR=10 %AND INC=-1
                                        ! FORCE INTO RANGE 1->10
         %WHILE X<LB %OR X>=UB %CYCLE
            X=X*FACTOR; COUNT=COUNT+INC
         %REPEAT
      %FINISH
      PRINT(SIGN*X,1,N)
      PRINTSTRING("@")
      WRITE(COUNT,2)
%END;                                   ! OF ROUTINE PRINTFL
%finish
%CONSTLONGREAL IMAX=2147483647;         ! MAX INTEGER FOR 32 BIT WORD
                                        ! NEEDS CHANGING FOR OTHER WLENGT
%EXTERNALROUTINE READ %ALIAS "s#read"(%NAME OPND)
!***********************************************************************
!*       THIS ROUTINE IS THE IMP IMPLICITLY SPECIFIED ROUTINE WITH A   *
!*       %NAME PARAMETER. TYPEBND AND ADR ARE A 64 BIT DESCRIPTOR TO   *
!*       THE ACTUAL PARAMETER. THE BND FIELD HAS THE TYPE CODE IN IT   *
!*       (=1 FOR INTEGER =2 FOR REAL).  FOR %SHORT %INTEGER, THE       *
!*       PARAMETER WILL BE A STRING DESCRIPTOR OF LENGTH 2.            *
!*                                                                     *
!*       THE METHOD USED IS SIMPLE REPEATED MULTIPLICATION USING LONG  *
!*       REAL VARIABLES. SOME ROUNDING ERRORS ARE INTRODUCED WHICH     *
!*       COULD BE AVOIDED BY USING PACKED DECIMAL INSTNS WITH NECESSARY*
!*       SCALING.                                                      *
!***********************************************************************
%INTEGER TYPE,PREC,FLAG,CURSYM;         ! FLAG= 0FOR'-',1 FOR '+'
%INTEGER IVALUE,PARTYPE,TYPEBND,ADR
      %IF 1<<TARGET&LINTAVAIL#0 %THEN %START
      %LONGINTEGER LIVALUE
      %FINISH
      %IF 1<<TARGET&LLREALAVAIL#0 %START
      %LONGLONGREAL RWORK,SCALE
      %FINISHELSESTART
      %LONGREAL RWORK,SCALE
      %FINISH
%SWITCH IL(3:6),RL(5:7)
      FLAG=1; TYPE=0
      %IF TARGET=EMAS %START
         *LSD_OPND; *ST_TYPEBND
      %finish %else %if TARGET=IBM %OR TARGET=IBMXA %OR TARGET=AMDAHL %START
         *MVC_TYPEBND(8),OPND
      %finish %else %if TARGET=PNX %START
         **@OPND; **@TYPEBND; *CI8; *MVB
      %finish %else %if target=perq %or target=drs %Start
         **opnd+4; **=typebnd; adr=addr(opnd)
      %finish %else %if 1<<target&Emachine#0 %start
         **opnd; **=typebnd; adr=addr(opnd)
      %finish
      PARTYPE=TYPEBND&7
      PREC=TYPEBND>>4&7
      %IF TARGET=EMAS %START
         %IF TYPEBND=X'58000002' %THENSTART
            PARTYPE=1
            PREC=4
         %FINISHELSESTART
            PREC=(TYPEBND>>27)&7
         %FINISH
         %IF TYPEBND=X'20000001' %THEN TYPEBND=X'58000002'
      %FINISH
      CURSYM=NEXT SYMBOL;               ! CARE NOT TO READ TERMINATOR
                                        ! NOW IGNORE LEADING SPACES
      %WHILE CURSYM=' ' %OR CURSYM=NL %CYCLE
         SKIP SYMBOL
         CURSYM=NEXT SYMBOL
      %REPEAT
      %IF CURSYM=X'19' %THENSIGNALEVENT 9,1
                                        ! RECORD INITIAL MINUS
      %IF CURSYM='-' %THEN FLAG=-1 %AND CURSYM='+'
                                        ! MOVE OVER SIGN ONCE IT HAS
                                        ! BEEN RECORDED IN FLAG
      %IF CURSYM='+' %THENSTART
         %CYCLE
            SKIP SYMBOL
            CURSYM=NEXT SYMBOL
         %REPEATUNTIL CURSYM#' '
      %FINISH
      %IF '0'<=CURSYM %AND CURSYM<='9' %THENSTART
         RWORK=CURSYM-'0';              ! KEEP TOTAL IN RWORK
         TYPE=1;                        ! VALID DIGIT
         %CYCLE
            SKIP SYMBOL
            CURSYM=NEXT SYMBOL
            %EXITUNLESS '0'<=CURSYM %AND CURSYM<='9'
            RWORK=10.0*RWORK+(CURSYM-'0'); ! CONTINUE EVALUATING
         %REPEAT
      %FINISHELSE RWORK=0
      %IF CURSYM='.' %AND PARTYPE=2 %THENSTART
         SCALE=10.0
         %CYCLE
            SKIP SYMBOL
            CURSYM=NEXT SYMBOL
            %EXITUNLESS '0'<=CURSYM %AND CURSYM<='9'
            TYPE=1
            RWORK=RWORK+(CURSYM-'0')/SCALE
            SCALE=10.0*SCALE
         %REPEAT
      %FINISH
!
! THE VALUE HAS NOW BEEN READ INTO RWORK. THERE MIGHT BE AN EXPONENT
! E.G. '1.7@10 '  IS VALID DATA FOR READ
!
      %IF (CURSYM='@' %OR CURSYM='&') %AND PARTYPE=2 %THENSTART
         %IF TYPE=0 %THEN TYPE=1 %AND RWORK=1
         SKIP SYMBOL;                   ! MOVE PAST THE '@'
         READ(IVALUE);                  ! RECURSIVE CALL TO FIND EXPONENT
         %IF IVALUE=-99 %THEN RWORK=0 %ELSE RWORK=RWORK*10.0**IVALUE
      %FINISH
      %SIGNALEVENT 4,1 %IF TYPE=0;      ! NO VALID DIGIT FOUND
!
! KNOCK NUMBER INTO RIGHT FORM
!
      %IF PARTYPE=1 %THENSTART
         %IF 1<<TARGET&LINTAVAIL#0 %AND PREC=6 %THENSTART
            LIVALUE=FLAG*LINT(RWORK)
         %FINISHELSESTART
            %IF RWORK>IMAX %THENSIGNALEVENT 1,1
            IVALUE=FLAG*INT(RWORK)
         %FINISH
         ->IL(PREC)
      %FINISH
      %IF PARTYPE#2 %THENSIGNALEVENT 8,3; ! UNASSIGNED PARAMETER TYPE
      %IF FLAG<0 %THEN RWORK=-RWORK
      %IF PREC<5 %THEN PREC=5
      ->RL(PREC)

IL(6):                                  ! 64 BIT INTEGERS
      %IF 1<<TARGET&LINTAVAIL#0 %THENSTART
         LONGINTEGER(ADR)=LIVALUE
         %RETURN
      %FINISHELSESIGNALEVENT 8,3
IL(5):                                  ! 32 BIT INTEGERS
      INTEGER(ADR)=IVALUE
      %RETURN
IL(4):                                  ! 16 BIT REAL
      HALFINTEGER(ADR)=IVALUE
      %RETURN
IL(3):                                  ! 8 BIT INTEGER
      BYTEINTEGER(ADR)=IVALUE
      %RETURN
RL(5):                                  ! 32 BIT REAL
      %IF TARGET=EMAS %THENSTART
         *LSD_=X'7F'; *USH_=25
         *OR_=1; *USH_=31;              ! ACC=X'7F00000080000000'
         *AND_RWORK; *RAD_RWORK;        ! SOFTWARE ROUND
         *STUH_(TYPEBND)
      %FINISHELSE REAL(ADR)=RWORK
      %RETURN
RL(6):                                  ! 64 BIT REAL
      %IF TARGET=EMAS %THENSTART
         *LSD_=X'7F'; *USH_=56; *AND_RWORK
         *SLSD_=1; *USH_=55; *AND_RWORK+8
         *LUH_ %TOS; *RAD_RWORK;        ! SOFTWARE ROUND
         *STUH_(TYPEBND)
      %FINISHELSE LONGREAL(ADR)=RWORK
      %RETURN
RL(7):                                  ! 128 BIT REAL
      %IF 1<<TARGET&LLREALAVAIL#0 %THENSTART
         LONGLONGREAL(ADR)=RWORK
      %FINISHELSESIGNALEVENT 8,3
!
!  %MONITOR (N) == FORCE FAULT NO N
!  N=16    REAL INSTEAD OF INTEGER IN DATA
!  N=14    SYMBOL IN DATA
!
%END
%EXTERNALROUTINE READSTRING(%STRING (*) %NAME DEST)
%INTEGER I,DELIM,LEN,MAXLEN; %STRING (1) T
%STRING (255) S
      LEN=0;                            !CURRENT LENGTH
      MAXLEN=SIZE OF(DEST)-1;           !BOUND LESS 1 BYTE FOR LENGTH BYTE
      READSYMBOL(I) %UNTIL I>32
      %SIGNALEVENT 4,2 %UNLESS I='''' %OR I='"'; ! SYMBOL INSTEAD OF STRING
      S=""; DELIM=I
      %CYCLE
         %IF NEXTSYMBOL=DELIM %START
            SKIP SYMBOL
            %EXITUNLESS NEXT SYMBOL=DELIM
         %FINISH
         %IF LEN>=MAXLEN %THENSIGNALEVENT 6,1
         READITEM(T)
         S=S.T
         LEN=LEN+1
      %REPEAT
      DEST=S
%END
%ENDOFFILE