! 11Oct93 moved closestream to oldies

%constant %integer yes=1,no=0

!
! THESE CODE ARE ARBITARY BUT THE TOP DECIMAL DIGIT GIVES THE NO OF BYTES
! IN THE UNIT OF ADDRESSABILITY. BYTE ADDRESSED HOSTS BEING 1N ( also 0N) AND
! 16 BIT WORD ADDRESSED HOSTS BEING 2N ETC
%constant %integer pentium=4; ! PENTIUM chip Unix stack and completely swopped
%constant %integer rs6=06; ! imp on IBM rs6000
%constant %integer m88k=07; ! Imp on all forms of 88k
%constant %integer vax=08; ! Imp on Vax using F & G formats
%constant %integer unisys=09; ! Imp on UnisSys. Unix stack unswopped Vax reals
%constant %integer emas=10; ! emas on 2900 (unsigned shorts)
%constant %integer ibm=11; ! emas on 24 bit ibm hardware
%constant %integer ibmxa=12; ! emas of XA 31 bit hardware
%constant %integer wwc=13; ! WWc (Natsemi chip) completely swopped
%constant %integer amdahl=14; ! Emas on Amdahls guess at Xa Minor differences fron IBM)
%constant %integer perq3=15; ! ICL packaged 68k chip Unix stack but not swopped
%constant %integer gould=16; ! Gould unswopped forward stack. Needs 4&8 byte alined
%constant %integer vns=17; ! Unix on 2900 unsigned shorts params as
! 2900. Long int available but not in Ecode
%constant %integer eamd=18; ! Amdahl via the Emachine
%constant %integer drs=19; ! Intel chip Unix stack and mostly swopped
%constant %integer perq=20; ! Pos perq now obselete. Fully swopped forward stack
%constant %integer pnx=21; ! ICL's perq2 Unix stack byte swopped (unsigned shorts)
%constant %integer accent=22; ! Perq 1 under accent. obsolete now
! ACCENT DIFFERS FROM PERQ ONLY IN
! ASSEMBLES SEQUENCES&SYNTAX
! AND GENERATOR
%constant %integer orn=23
%constant %integer unsignedshorts=1<<emas!1<<pnx!1<<vns
%constant %integer lintavail=1<<ibm!1<<ibmxa!1<<amdahl!1<<emas!1<<gould
%constant %integer llrealavail=1<<ibm!1<<ibmxa!1<<amdahl!1<<emas
%constant %integer emachine=1<<drs!1<<wwc!1<<vax!1<<gould!1<< %c
perq3!1<<vns!1<<eamd!1<<orn!1<<unisys!1<<m88k !1<<pentium
%constant %integer ibmfpformat=1<<ibm!1<<ibmxa!1<<amdahl!1<<emas!1 %c
<<gould!1<<vns!1<<eamd
%constant %integer vaxfpformat=1<<vax!1<<unisys
%constant %integer ieeefpformat=1<<wwc!1<<perq3!1<<drs!1<<perq!1<<accent!1<<orn
%constant %integer byteswopped=1<<perq!1<<accent!1<<wwc!1<<vax!1<<pnx!1<<orn
%constant %integer halfswopped=1<<perq!1<<accent!1<<wwc!1<<vax!1<<drs!1<<orn
%constant %integer wordswopped=1<<perq!1<<accent!1<<wwc!1<<vax!1<<drs!1<<orn
%constant %integer riskmc=1<<m88k
!
! end of file hostcodes
!
%constant %integer target=drs
%external %routine %spec iocp %alias "s_iocp"(%integer ep, n)
%constant %long %real greatest= 7.2370055773322608@ 75{R'7FFFFFFFFFFFFFFF'}
%external %routine move %alias "s_move"(%integer length, from, to)
   %integer i
   %return %if length<=0
   %if target=emas %then %start
      i = X'18000000'!length
      *LSS_from
      *LUH_i
      *LDTB_i
      *LDA_to
      *MV_ %l = %dr
   %finish %else %if target=perq %or target=accent %or target=pnx %start
      %cycle i = 0, 1, length>>2-1
         halfinteger(to+i) = halfinteger(from+i)
      %repeat
   %finish %else %start; ! ibm etc
      %if from<=to<=from+length %start
         %cycle i = length-1, -1, 0
            byteinteger(to+i) = byteinteger(from+i)
         %repeat
      %finish %else %start
         %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
   %external %long %real %function cputime
      %result = 1
   %end; ! CPUTIME
   !*
   %external %string %function date
      %string (10) d, t, u, v
      d = "YYYY.MM.DD"
      t = "HH:MM:SS"
      %result = d
   %end; ! DATE
   !*
   %external %string %function imptime
      %string (10) d, t
      d = "DD.MM.YY"
      t = "HH:MM:SS"
      %result = t
   %end
%finish
%external %integer %function size of %alias "s_sizeof"(%name x)
!***********************************************************************
!*    returns the size of a %name paramterer                           *
!***********************************************************************
   %constant %byte %integer %array 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 %then %result = i&X'00FFFFFF'
      i = (i>>27)&7
   %finish %else %if target=perq %or target=drs %or target=accent %start
      **x+4; **=i
      %if i&7>=3 %then %result = 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
%external %string (255) %function substring %alias "s_substring"(%string %c
  %name s, %integer i, j)
   %integer k
   %string (255) holds
   %if i<1 %or i>j+1 %or j>length(s) %then %signal %event 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

%external %integer %function sign %alias "s_sign"(%long %real value)
   %if value>0 %then %result = 1
   %if value<0 %then %result = -1
   %result = 0
%end
%external %long %real %function maxreal %alias "s_maxreal"
   %result = greatest
%end
%external %long %real %function minreal %alias "s_minreal"
   %result = R'0010000000000000'
%end
%external %integer %function maxint %alias "s_maxint"
   %result = X'7FFFFFFF'
%end
%external %long %real %function epsilon %alias "s_epsilon"
   %result = R'3410000000000000'
%end
! NEEDS CHANGING FOR OTHER WLENGT
%constant %long %real pmax= 1@16
%constant %long %real dz= 0
%constant %long %real d0= 0, d1 = 1
%external %string (15) %function %spec swrite %alias "s_swrite"(%integer %c
  value, places)
!
%if target#gould {%and target#DRS} %start
   %external %routine write %alias "s_write"(%integer value, places)
!***********************************************************************
!*    SIMPLE MINDED ALL IMP VERSION NOT USING STRINGS                  *
!***********************************************************************
      %integer sign, work, ptr
      %byte %integer %array ch(0:15)
      sign = ' '
      %if value=X'80000000' %then %c
        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
      %repeat %until 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
%external %string (15) %function 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 = "-2147483648"
      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
   %repeat %until 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
%external %string (15) %function 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
%constant %string (1) %array hex(0:15)="0","1","2","3","4",
               "5","6","7","8","9","A","B","C","D","E","F"
%routine prhex(%integer value, places)
   %integer i
   %cycle i = places<<2-4, -4, 0
      print string(hex(value>>i&15))
   %repeat
%end
%external %routine phex %alias "s_phex"(%integer value)
   prhex(value, 8)
%end
%external %string (8) %function 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)
   %external %routine print %alias "s_print"(%long %real 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    *
!***********************************************************************
      %long %real y, z, round, factor
      %integer i, j, l
      %byte %integer 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 %then %start; ! 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 %then %return; ! 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
   %external %routine printfl %alias "s_printfl"(%long %real 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                  *
!***********************************************************************
      %long %real 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 %else %start
         %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
%constant %long %real imax=2147483647; ! MAX INTEGER FOR 32 BIT WORD
! NEEDS CHANGING FOR OTHER WLENGT
%external %routine 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
      %long %integer livalue
   %finish
   %if 1<<target&llrealavail#0 %start
      %long %long %real rwork, scale
   %finish %else %start
      %long %real 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=m88k %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' %then %start
         partype = 1
         prec = 4
      %finish %else %start
         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' %then %signal %event 9, 1
   ! RECORD INITIAL MINUS
   %if cursym='-' %then flag = -1 %and cursym = '+'
   ! MOVE OVER SIGN ONCE IT HAS
   ! BEEN RECORDED IN FLAG
   %if cursym='+' %then %start
      %cycle
         skip symbol
         cursym = next symbol
      %repeat %until cursym#' '
   %finish
   %if '0'<=cursym %and cursym<='9' %then %start
      rwork = cursym-'0'; ! KEEP TOTAL IN RWORK
      type = 1; ! VALID DIGIT
      %cycle
         skip symbol
         cursym = next symbol
         %exit %unless '0'<=cursym %and cursym<='9'
         rwork = 10.0*rwork+(cursym-'0'); ! CONTINUE EVALUATING
      %repeat
   %finish %else rwork = 0
   %if cursym='.' %and partype=2 %then %start
      scale = 10.0
      %cycle
         skip symbol
         cursym = next symbol
         %exit %unless '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 %then %start
      %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
   %signal %event 4, 1 %if type=0; ! NO VALID DIGIT FOUND
!
! KNOCK NUMBER INTO RIGHT FORM
!
   %if partype=1 %then %start
      %if 1<<target&lintavail#0 %and prec=6 %then %start
         livalue = flag*lint(rwork)
      %finish %else %start
         %if rwork>imax %then %signal %event 1, 1
         ivalue = flag*int(rwork)
      %finish
      ->il(prec)
   %finish
   %if partype#2 %then %signal %event 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 %then %start
      longinteger(adr) = livalue
      %return
   %finish %else %signal %event 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 %then %start
      *LSD_ = X'7F'; *USH_ = 25
      *OR_ = 1; *USH_ = 31; ! ACC=X'7F00000080000000'
      *AND_rwork; *RAD_rwork; ! SOFTWARE ROUND
      *STUH_(typebnd)
   %finish %else real(adr) = rwork
   %return
rl(6):                                   ! 64 BIT REAL
   %if target=emas %then %start
      *LSD_ = X'7F'; *USH_ = 56; *AND_rwork
      *SLSD_ = 1; *USH_ = 55; *AND_rwork+8
      *LUH_ %tos; *RAD_rwork; ! SOFTWARE ROUND
      *STUH_(typebnd)
   %finish %else longreal(adr) = rwork
   %return
rl(7):                                   ! 128 BIT REAL
   %if 1<<target&llrealavail#0 %then %start
      longlongreal(adr) = rwork
   %finish %else %signal %event 8, 3
!
!  %monitor (N) == FORCE FAULT NO N
!  N=16    REAL INSTEAD OF INTEGER IN DATA
!  N=14    SYMBOL IN DATA
!
%end
%external %routine 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
   %signal %event 4, 2 %unless i='''' %or i='"'; ! SYMBOL INSTEAD OF STRING
   s = ""; delim = i
   %cycle
      %if nextsymbol=delim %start
         skip symbol
         %exit %unless next symbol=delim
      %finish
      %if len>=maxlen %then %signal %event 6, 1
      readitem(t)
      s = s.t
      len = len+1
   %repeat
   dest = s
%end
%end %of %file
