! Routines for IMP77 compatiblity with the standard ERCC IMP library.
%external %routine %spec  DEF INFO (%integer chan, %string(255) %name file,
                                    %integer %name status)
%system   %routine %spec  DEFINE (%integer  chan, %string(255) parm,
                                  %integer %name  addr, flag)
%system   %routine %spec  SET FNAME (%string(40) fname)
%system   %integer %map %spec COMREG (%integer n)
%system   %integer %function %spec IOCP (%integer ENO, PARM)
%external %integer %function %spec  EXIST (%string(255) s)
%system   %string(255) %function %spec FAILURE MESSAGE (%integer errno)
%external %string(255) %function %spec  UINFS (%integer e)

! COMREG values used -
%const %integer  creg instream   = 22
%const %integer  creg outstream  = 23
%const %integer  creg errmess    = 24

! IOCP codes used -
%const %integer  iocp rsym    =  4  {read symbol (actually 'ch')}
%const %integer  iocp psym    =  5  {print symbol (actually 'ch')} 
%const %integer  iocp nsym    = 18  {next symbol (actually 'ch')}
%const %integer  iocp selin   =  8  {select input}
%const %integer  iocp selout  =  9  {select output}
%const %integer  iocp reset   = 16  {'close stream'}
! Magic error numbers
%const %integer  error fnf = 218 {File Not Found}


%const %integer  max stream    = 15;   ! may open input/output streams 1-15
%const %integer  input offset  =  0;   ! in  stream 1 => channel  1 etc
%const %integer  output offset = 15;   ! out stream 1 => channel 16 etc

%own %integer %array  valid (0 : 30) = 1, 0(*)


%own %string(5)  default = ""

!**********************************************************************
!*                                                                    *
!*   S E C T I O N   0   -   Miscellaneous                            *
!*                                                                    *
!**********************************************************************

%external %integer %function  REM (%integer a, b)
   %result = a - a//b * b
%end

!**********************************************************************
!*                                                                    *
!*   S E C T I O N   1   -   General input and output routines        *
!*                                                                    *
!**********************************************************************

%external %routine  READ SYMBOL %alias "I77#RSYM" (%integer %name  sym)
   sym = iocp (iocp rsym, 0)
%end

%external %routine  SKIP SYMBOL %alias "I77#SSYM"
   %integer  d
   d = iocp (iocp rsym, 0)
%end

%external %integer %function  NEXT SYMBOL %alias "I77#NSYM"
   %result = iocp (iocp nsym, 0)
%end

%external %routine  PRINT SYMBOL %alias "I77#PSYM" (%integer sym)
   %integer  d
   d = iocp (iocp psym, sym)
%end

!
! Number/string manipulation
! ==========================
!
%const %integer  max int = (-1)>>1;            ! On 2's complement machines
%const %integer  min int = \max int;           !       ditto.
!
! Adjust following for appropriate word length
!
%const %integer  min int last digit = '8';     ! rem (|min int|, 10) + '0'
%const %integer  max digits         = 11;      ! # chars in 'min int'

!
! ITOS0
!
! Returns a string representing the argument as
! a decimal number, without any space justification
! or padding.
!
%external %string(max digits) %function  ITOS0 %alias "I77#IT0S" (%integer n)
   %string(max digits) res
   %integer  s, p, e
   s = 0
   %if n < 0 %start
      s = -1;                       ! mark -ve
      %if n = min int %start;       ! special case
         n = max int;               ! rely on  "max int = (-min int) - 1"
         s = 1;                     ! mark special
      %finish %else %start
         n = -n
      %finish
   %finish
   p = addr(res) + max digits
   e = p;                           ! end point
   byteinteger(p) = rem(n,10)+'0' %and n = n//10 %and p = p - 1 %until n = 0
   %if s # 0 %start;                ! negative
      byteinteger(p) = '-'
      p = p - 1 
      %if s > 0 %start;             ! min int
         charno(res,max digits) = min int last digit
      %finish
   %finish
   byteinteger(p) = e - p;          ! length byte
   %result = string(p)
%end

%external %string(63) %function  ITOS %alias "I77#ITOS" (%integer n, places)
   %string(63+maxdigits)  res
   %integer  p, slen
   p = addr(res) + 62;              ! digit string right justified
   string(p) = itos0 (n)
   slen = byteinteger(p)
   %if n > 0 %and places > 0 %start
      byteinteger(p) = ' '
      p = p - 1
      slen = slen + 1
   %finish
   %if places <= 0 %start
      places = -places
   %finishelsestart
      places = places + 1
   %finish
   places = 63 %if places > 63
   %while slen < places %cycle
      byteinteger(p) = ' ';   p = p - 1 
      slen = slen + 1
   %repeat
   byteinteger(p) = slen
   %result = string(p)
%end

%external %routine  WRITE %alias "I77#WRITE" (%integer num, pl)
   %string(63)  res
   res = itos (num, pl)
   pl = \pl %if pl < 0
   spaces (pl-62)
   print string (res)
%end

%external %string(127) %function RTOS (%long %real NUM, %integer PL, DP)
   %string(127) bs, as
   bs = itos (intpt (NUM), PL)
   as = itos (intpt (fracpt(NUM) * 10\DP), 0)
   as = "0".as %while length(as) < PL
   %result = bs.".".as
%end

%external %routine  PRINT %alias "I77#PRINT" (%long %real num, %integer pl, dp)
   %string(255)  res
   res = rtos (num, pl, dp)
   pl = \pl %if pl < 0
   spaces (pl-62)
   print string (res)
%end

!**********************************************************************
!*                                                                    *
!*   S E C T I O N  1  -  Event handling.                             *
!*                                                                    *
!**********************************************************************

%record %format  eventfm (%integer event, sub, extra, %string(255) message)
%external %record(eventfm)  event = 0

%external %routine  SIGNAL (%integer ev, sub, ex)
   ! Note that '%signal a,b,c' should be replaced by 'signal (a,b,c)' to 
   ! fill the event record.  The EMAS only routine SET EVENT which must 
   ! be spec'd separately can be used to fill the record from an event 
   ! not signaled by this routine.
   ! This has fewer restrictions on it than the EMAS %signal mechanism.
   %switch  es (0:15)

   %unless 0 <= ev <= 15 %start
      ! Event out of range.
      ex = ev;  ev = 6;  sub = 0
   %finish
   event_event = ev
   event_sub = sub
   event_extra = ex
   -> es (ev)

es(0): ! Note that the ERCC don't allow this.
       %monitor %if sub < 0
       com reg(creg err mess) = sub %if sub > 0
       %stop

es(1):  %signal  1, sub
es(2):  %signal  2, sub
es(3):  %signal  3, sub
es(4):  %signal  4, sub
es(5):  %signal  5, sub
es(6):  %signal  6, sub
es(7):  %signal  7, sub
es(8):  %signal  8, sub
es(9):  %signal  9, sub
es(10): %signal 10, sub
es(11): %signal 11, sub
es(12): %signal 12, sub
es(13): %signal 13, sub
es(14): %signal 14, sub
es(15): ! This is not allowed by the EMAS signal mechanism, so it is
        ! signaled as 14, but the event record has the correct value.
        %signal 14, sub
%end

%external %routine  SET EVENT
   %on 1,2,3,4,5,6,7,8,9 %start
       event = 0
       %return
   %finish
   event_event = event inf >> 8 & 15
   event_event = 9 %if event_event=1
   event_sub = event inf & 255
%end

%external %string(255) %function  LAST STREAM ERROR
   %string(255)  err
   err = ""
   %if event_event = 9 %start
      %if event_sub = 3 %start
         set fname (event_message)
         err = failure message (event_extra)
        err = substring(err,2,length(err)) %if charno(err,1) = ' '
         length(err) = length(err) - 1;       ! remove NL
      %finish %else %if event_sub = 2 %start
         err = "invalid stream ".itos(event_extra,0)
      %finish %else %if event_sub = 1 %start
         err = "End of file"
      %finish
   %finish %else %if event_event # 0 %start
      err = "Signal ".itos(event_event,0).", ".itos(event_sub,0). %c
            ", ".itos(event_extra,0)
   %finish
   %result = err
%end

!**********************************************************************
!*                                                                    *
!*   S E C T I O N  2   -   File handling                             *
!*                                                                    *
!**********************************************************************


! UTILITIES


%external %routine  SET DEFAULT EXTENSION (%string(6) def)
   def = "#".def %if def # "" %and %not def -> ("#")
   default <- def
%end

%routine  UPPER CASE (%string(*) %name s)
   %integer  l
   %byte %name  c
   %for l = 1, 1, length(s) %cycle
      c == charno(s,l)
      c = c - 'a' + 'A' %if 'a' <= c <= 'z'
   %repeat
%end

%routine  CHECK STREAM (%integer stream)
   %integer  status, d
   %string(255) fn
   def info (stream, fn, status)
   define (stream, ".NULL", d, d) %if fn = ""
   valid(stream) = 1
%end

%external %string(255) %function  BASE NAME (%string(255) file)
   %result = "" %if file = ""
   %result = file %if charno(file,1) = '.';     ! Device ??
   %if file -> (".") . file %start; %finish;    ! remove username
   %if file -> ("_") . file %start; %finish;    ! remove PD top name
   %if file -> file . ("#") %start; %finish;    ! remove "extension"
   %result = file
%end


! INPUT STREAM PROCEDURES


%external %routine  CLOSE INPUT
   %integer  s, d
   s = com reg (creg instream)
   %if 0 < s <= 80 %start
      d = iocp (iocp reset, s)
      define (s, ".NULL", d, d)
   %finish
%end

%external %routine ABANDON INPUT
   close input
%end

%external %routine  RESET INPUT
   %integer  i
   i = comreg(creg instream)
   i = iocp (iocp reset, i) %if 0 < i <= 80
%end

%external %routine  SELECT INPUT %alias "I77#SELIN" (%integer stream)
   %integer  d
   signal (9, 2, stream) %unless 0 <= stream <= max stream
   stream = stream + input offset %if stream # 0
   check stream (stream) %if valid(stream) = 0
   d = iocp (iocp selin, stream)
%end

%external %integer %function  IN STREAM  %alias "I77#ISTRM"
   %integer  s
   s = com reg(creg instream)
   s = s - input offset %if input offset+1 <= s <= input offset+max stream
   %result = s
%end

%external %string(255) %function  IN FILE NAME
   %string(255)  fn
   %integer  status
   def info (comreg(creg instream), fn, status)
   %if fn # "" %and charno(fn,1) # '.' %and %not fn -> (".") %start
      fn = uinfs(1) . "." . fn;        ! Fill in user name
   %finish
   upper case (fn)
   %result = fn
%end

%external %integer %function  IN TYPE
   %string(255)  in
   in = in file name
   %result = -1 %if in = ".IN"
   %result =  0 %if in = "" %or in = ".NULL"
   %result = -2 %if charno (in,1) = '.'
   %result =  1
%end

%external %routine  OPEN INPUT (%integer stm, %string(255) file)
   %integer  errno, d, olds
   %string(255)  full file
   signal (9, 2, stm) %unless 1 <= stm <= max stream
   upper case (file)
   file = ".IN"   %if file = ".TT" %or file = "T:"
   file = ".NULL" %if file = ".N"  %or file = "N:" %or file = "NL:"
   full file = file
   %unless file -> ("#") %or charno(file,1) = '.' %start
      full file = file . default
   %finish
   %if exist (full file)#0 %start
      file = full file
   %finishelsestart
      %unless exist (file)#0 %or charno(file,1) = '.' %start
         event_message = file
         signal (9, 3, error fnf)
      %finish
   %finish
   stm = stm + input offset
   d = iocp (iocp reset, stm)
   define (stm, file, d, errno)
   valid (stm) = 1
   %if errno # 0 %start
       define (stm, ".NULL", d, d)
       event_message = file
       signal (9, 3, errno)
   %finish
   stm = stm - input offset
   olds = instream
   select input (stm);             ! To initialise it
   select input (olds);            ! and back again
%end


! OUTPUT STREAM PROCEDURES


%external %routine  CLOSE OUTPUT
   %integer  s, d
   s = comreg(creg outstream)
   d = iocp (iocp reset, s) %and define (s, ".NULL", d, d) %if 0 < s <= 80
%end

!%external %routine  ABANDON OUTPUT
!   ! Still to be written
!   SIGNAL (10, 0, 0)
!%end

%external %routine  RESET OUTPUT
   %integer  s
   s = comreg(creg outstream)
   s = iocp (iocp reset, s) %if 0 < s <= 80
%end

%external %routine  SELECT OUTPUT %alias "I77#SELOUT" (%integer stream)
   %integer  d
   signal (9, 2, 0) %unless 0 <= stream <= max stream
   stream = stream + output offset %if stream # 0
   check stream (stream) %if valid(stream) = 0
   d = iocp (iocp selout, stream)
%end

%external %integer %function  OUT STREAM %alias "I77#OSTRM"
   %integer  s
   s = com reg(creg outstream)
   s = s - output offset %if output offset+1 <= s <= output offset+max stream
   %result = s
%end

%external %string(255) %function  OUT FILE NAME
   %string(255)  fn
   %integer  status
   def info (comreg(creg outstream), fn, status)
   %if fn # "" %and charno(fn,1) # '.' %and %not fn -> (".") %start
      fn = uinfs(1) . "." . fn;        ! Fill in user name
   %finish
   upper case (fn)
   %result = fn
%end

%external %integer %function  OUT TYPE
   %string(255)  out
   out = out file name
   %result = -1 %if out = ".OUT";               ! standard output stream
   %result =  0 %if out = "" %or out = ".NULL"
   %result = -2 %if charno(out,1) = '.';        ! other device
   %result =  1;                                ! file
%end

%external %routine  OPEN OUTPUT (%integer stm, %string(255) file)
   %integer  errno, d, olds
   upper case (file)
   file = ".OUT" %if file = ".TT" %or file -> ("T:")
   file = ".NULL" %if file = ".N" %or file -> ("N:") %or file -> ("NL:")
   file = file.default %unless file -> ("#") %or charno(file,1) = '.'
   signal (9, 2, stm) %unless 1 <= stm <= max stream
   stm = stm + output offset
   d = iocp (iocp reset, stm)
   define (stm, file, d, errno)
   valid (stm) = 1
   %if errno # 0 %start
       define (stm, ".NULL", d, d)
       event_message = failure message (errno)
       signal (9, 3, errno)
   %finish
   stm = stm - output offset
   olds = outstream
   select output (stm);                  ! so that it blows up now..??
   select output (olds);                 ! Phew!
%end


! GENERAL STREAM ROUTINES


%external %routine  SPLIT STREAMS (%string(255) def, 
                                   %string(*) %array %name in, out)
   %string(255)  outputs, x
   %string(255) %name  s
   %string(*) %array %name  list
   %integer  n, d
   outputs = ""  %unless  def  ->  def . ("/") . outputs
   d = 0;  n = 0;  s == def;  list == in
   %cycle
      x = s  %and  s = ""  %unless  s  ->  x . (",") . s
      n = n + 1
      list(n) = x
      %if s = "" %start;           ! end of this list
         list(n) = "" %for n = n+1, 1, max stream
         %return %if d # 0;        ! done outputs
         s == outputs;             ! now onto output streams
         list == out
         n = 0;   d = 1
      %finish
   %repeat
%end


%external %routine  SET STREAMS (%string(255) def)
   ! Should this be phased out??
   %string(255) %array  in, out (1 : max stream)
   %integer  s
   split streams (def, in, out)
   open input (1, ".TT");   open output (1, ".TT")
   %for s = 1, 1, max stream %cycle
      open input  (s, in(s))  %if  in(s) # ""
      open output (s, out(s)) %if out(s) # ""
   %repeat
   select input (1);  select output (1)
%end

%external %routine  SET IMP77 STREAMS (%string(255)  slist, defaults,
                                       %integer %name  error)
   %string(255) %array  in, out, defin, defout (1 : max stream)
   %integer  s
   %on 9 %start
      select output (0)
      print string ("*Failed to set up streams:")
      newline
      print string (last stream error)
      newline
      error = 1
      %return
   %finish
   error = 0
   split streams (slist, in, out)
   split streams (defaults, defin, defout)
   open input (1, ".TT");  open output (1, ".TT")
   %for s = 1, 1, max stream %cycle
      %if in(s) # "" %start
         set default extension (defin(s))
         open input (s, in(s))
      %finish
      %if out(s) # "" %start
         set default extension (defout(s))
         open output (s, out(s))
      %finish
   %repeat
   select input (1);  select output (1)
%end

%end %of %file