SECTION "E5"

GET ".ECCE-HDR"
GET ".SFO-HDR/3/S"

MANIFEST {
block_psz = block_csz/page_size
}

STATIC
{ byte_count        = ?     // for byte counts of files
  byte_count_excess = ?     // needed for 16 bit machines
  int_enabled = FALSE       // TRUE if 'enable_interrupt' called.
}
 
LET expect_ch(stream, ch) = VALOF
/* Start a single character non-echoed get into the specified character
   buffer 'ch'.
   Returns 0 if successfull, -1 on error (E4FAILCODE set to error code)
*/
{1 LET p = WorkSpace          // must use static space since we don't wait.
   LET dtab = stream*str.entrysize+devtable
   
   p!0:=dtab+str.rtn
   p!2:=rtnlist+2
   p!3:=ch           // note this is the address of a character buffer
   p!4:=1            // transfer length 1 character
   p!5:=#X0100
   p!7:=#X4001       // unpacked non-echoed get

   e4failcode:=extracode(iop, 2, p)
   RESULTIS e4failcode=0 -> 0, -1
}1

LET arrived_ch(stream) = VALOF
/* Looks to see if the transfer initiated by 'expect_ch' has terminated.
   Returns +ve if character arrived,
           0   if no character has arrived,
           -ve on error (e4failcode set to error code)
*/
{1 LET dtab=stream*str.entrysize+devtable
   
   e4failcode:=extracode(iop, 16, dtab!str.rtn)
   UNLESS e4failcode=0 RESULTIS -1

   RESULTIS extracoderesults!r.b=0 -> 1,
               extracoderesults!r.b<0 -> 0, -1
}1

LET wait_ch(stream) = VALOF
/* Wait for the transfer initiated by 'expect_ch' to complete.
   Returns 0 when character arrives or
           -1 if error (e4failcode set to error code)
*/
{1 LET dtab=stream*str.entrysize+devtable

   e4failcode:=extracode(wait, wait.on.transfer, dtab!str.rtn)
   UNLESS e4failcode=0 RESULTIS -1

   RESULTIS extracoderesults!r.b=0 -> 0, -1
}1

LET cancel_ch(stream) = VALOF
/* Cancel any outstanding transfer on nominated stream.
   Returns 0 if successfull, -1 otherwise (e4failcode set to error code)
*/
{1 LET dtab=stream*str.entrysize+devtable

   e4failcode:=extracode(iop, 20, dtab!str.rtn, 0)

   RESULTIS e4failcode
}1

LET enable_interrupt() BE
{1 STATIC { ch = ? }
   UNLESS batch DO
   {   UNLESS expect_ch(control, @ch) = 0 STOP(E4failcode)
       int_enabled := TRUE
   }
}1

LET interrupt_arrived() = VALOF
{1 IF batch | ~int_enabled RESULTIS FALSE 
 { LET r = arrived_ch(control)

   IF r < 0 STOP(E4failcode)
   IF r = 0 RESULTIS FALSE
   int_enabled := FALSE
   RESULTIS TRUE
}1

LET disable_interrupt() BE
   UNLESS batch | ~int_enabled DO 
   {  UNLESS cancel_ch(control) = 0 STOP(E4failcode)
      int_enabled := FALSE
   }
 
LET set_cursor(row, col) BE
/* Set cursor to specified screen position using WRCH.
   Note that either NEWLINE or FORCEOUT must be used to cause output.
*/
{1 /* wrch(home_code)
      FOR i=0 TO row-1 DO wrch(lf_code)
      FOR i=0 TO col-1 DO wrch(fwd_code)
   */

   wrch(coord.code)
   wrch(col)
   wrch(row+1)
}1

LET log_record(r) = VALOF
{1 LET v = VEC line_bsz
   LET l = r!0 + 2

   v!0, v!1, v!l := l, parity('*L'), parity('*C')
   FOR i=1 TO r!0 DO v!(i+1) := r!i 
   
   IF fput(logstream, v) = errorvalue
   THEN filing_error(logstream, E4failcode)
}1
 
LET get_line(buff, max) = VALOF
// Read a line of input into buff of max length 'max'.
// If the global CUE is non_zero it is output as a prompt string.
// Returns length if successfull, -1 if end of file
//
{1 LET ch = ?
   
   IF prompting THEN out_prefix(cue)

   FOR i=1 TO max DO
   {  ch := rdch()

      IF ch=endstreamch THEN
      {  IF e4failcode \= 0
         THEN endread()
         RESULTIS errorvalue
      }
      IF ch='*N' THEN
      {  buff!0:=i-1
         log_record(buff)
         RESULTIS i-1
      }

      buff!i:=ch
   }
   warn(m_input_too_long)
   {  ch := rdch()
      IF ch=endstreamch THEN
      {  IF E4failcode \= 0
         THEN endread()
         RESULTIS errorvalue
      }
   } REPEATUNTIL ch = '*N'
}1 REPEAT

AND out_prefix(cue) BE
   report("%S*E", cue) 
 
AND report(msg, a, b, c, d) BE
{1 LET out=output()
   selectoutput(outstream)
   writef(msg, a, b, c, d)
   selectoutput(out)
}1

AND warn(n) BE
{1 report("%S*N", VALOF SWITCHON n INTO 
   {  CASE m_over: 
         RESULTIS "The workspace has overflowed" 
      CASE m_input_too_long:
         RESULTIS "The last line input was too long"
      DEFAULT:
         RESULTIS "Unknown error!!"
   } )
}1

AND sys_command(s) BE
/*  Issue the system command, which is the string 's', and return
immediately to ECCE.  */
{1 LET Error = opsys(s)

   UNLESS Error = 0 DO report("System command failed %x4*n", Error)
}1 

AND sys_return() BE
/* This returns temporarily to the system without  unloading  the
editor, so that CHEF may be restarted. */
{1
     LET error = 0
     LET packed_buff = VEC 144/bytesperword
     LET CommBuf = VEC 144
     LET old_cue = cue

     cue := "<Ecce>"

     {  get_line(CommBuf, 144)
        IF !CommBuf = 0 BREAK
        packstring(CommBuf, packed_buff)
        error := opsys(packed_buff)

        UNLESS error = 0 DO report("System command failed %x4*N", Error)
     } REPEAT
   
     cue := old_cue
}1



/* --------------------- optimization ---------------------------
     The  following  procedures  are written independently of the
operating system, but they might well be written as direct  calls
to the system, thereby speeding them up.  */

AND copy_and_unpack(amount,from,offset,dest) BE
/* Copy bytes from 'FROM' at offset 'offset' to a word buffer 'dest'
*/
   FOR i=0 TO amount-1 DO dest!i:=from%(offset+i)

AND copy_and_pack(amount,from,dest,offset) BE
/* Copy a word buffer 'from' to a byte buffer 'dest' at offset 'offset'.
*/
   FOR i=0 TO amount-1 DO dest%(offset+i):=from!i
 
AND copy_bytes(l, s1, o1, s2, o2) BE
/*  Copies  the  'l'  bytes  from  's1' at offset 'o1' to 's2' at
offset 'o2'.  */
{1  // trace("copy_bytes:")
     FOR i =           0 TO l-1  DO s2%(o2+i) := s1%(o1+i)
}1 
 
AND copy_cells(length, source, destination) BE
/* This copies 'length' cells.
*/
{1  // trace("copy_cells:")
   FOR i = 0 TO length-1 DO destination!i := source!i }1

AND copy_string(s, d) BE
/* Copies the string s to the string d.  */
{1  // trace("copy_string:")
   FOR i = 0 TO (s%0)/2 + 1 DO d!i := s!i }1

AND eq_str(s1, s2) = VALOF
/* Yield true if the strings 's1' and 's2' are  equal;  otherwise
yield false */
{1 FOR i = 0 TO s1%0 DO UNLESS s1%i = s2%i THEN RESULTIS FALSE
   RESULTIS TRUE }1

AND check_blocks(b1,b2) BE
/*  Check  that  blocks  'b1'  to  'b2'  in  the  workfile can be
accessed, after extending the workfile if  possible. This  cannot
be  done  by  'save_block',  since  by  that time there is useful
information which must be stored in that block, and until this is
stored the editor cannot access other blocks in order to save the
work so far. */
 
/* In the CTL implementation we must take care to avoid extent problems, so
we check that both b1 and b2 are in range then if they are not we extend
the workfile by a block rather than just a few pages 

We assume that b2 is always greater than b1 (a wee bit hopeful methinks)
and then extend the file to the next track boundary beyond b2
*/
{   LET DT = DEVTABLE + STR.EntrySize*work_stream
    LET WorkSize = DT!Str.FileSize

    IF b1 > b2 THEN b2 := b1

    IF b2*block_psz >= WorkSize THEN
    { LET ExtendSize = 160        // 5 medium allocation units
     $(
        extendfile(work_stream, WorkSize + ExtendSize)
  
        SWITCHON E4FailCode INTO
        $(
           CASE 0:  RETURN       // no error - thats OK
           DEFAULT:              // unknown error - thats Bad
           CASE #X2C72: BREAK    // no extents left
           CASE #X2C74:          // no space on partition
           CASE #X2CB0:          // no space in  allocation
                        ExtendSize := ExtendSize / 2
                        ENDCASE
        $)
     $) REPEATUNTIL  ExtendSize <= block_psz

      warn(m_over)
      recover()
    }
}



AND restore_block(buffer, b) BE
/* Read block number 'b' to 'buffer'.   Note  that  'b+1'  avoids
trouble with those (curious) systems that have files with no line
zero.  */
{ // trace("restore_block: b=%N", b) 
{ LET result = readdirect(work_stream,b*block_psz,buffer,block_csz) 
  IF result \= block_csz THEN stop(e4failcode)
}
}

AND save_block(buffer, b) BE
/* Write 'buffer' to block number 'b' in the  work  file.    Note
that  'b+1'  avoids  record  number  0, which is awkward for some
systems.  */
{ LET result = 0
  // trace("write block b=%N", b)

  result := writedirect(work_stream,b*block_psz,buffer,block_csz)

  UNLESS result = block_csz stop(e4failcode)
}

AND WriteUnpackedLine(l, line) = VALOF
/* Copy buffer into local workspace adding length, parity and leading
   and trailing *L and *C.
*/
{1 LET v = VEC line_bsz
   LET par = TABLE  0, 129, 130, 3, 132, 5, 6, 135, 136, 9, 10, 139, 12, 
             141, 142,  15, 144,  17,  18, 147,  20, 149, 150,  23,  24, 153,
             154,  27, 156,  29,  30, 159, 160,  33,  34, 163,  36, 165, 166,
              39,  40, 169, 170,  43, 172,  45,  46, 175,  48, 177, 178,  51,
             180,  53,  54, 183, 184,  57,  58, 187,  60, 189, 190,  63, 192,
              65,  66, 195,  68, 197, 198,  71,  72, 201, 202,  75, 204,  77,
              78, 207,  80, 209, 210,  83, 212,  85,  86, 215, 216,  89,  90,
             219,  92, 221, 222,  95,  96, 225, 226,  99, 228, 101, 102, 231,
             232, 105, 106, 235, 108, 237, 238, 111, 240, 113, 114, 243, 116,
             245, 246, 119, 120, 249, 250, 123, 252, 125, 126, 255

   v!0, v!1, v!(l+2) := l+2, par!'*L', par!'*C'
   FOR i=0 to l-1 DO v!(i+2) := par!(line!i)
   RESULTIS fput(file_out_stream, v)
}1

/*!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
AND ReadPackedLine() BE
$( LET UnpackedLine = VEC line_bsz
   LET Len = ?
   AND Off = ?

   // trace("ReadPackedLine:")

   READBUFF(UnpackedLine, len, '*C')
   UNLESS E4failcode = 0 RESULTIS errorvalue

   Len := UnpackedLine!0
 
   TEST UnpackedLine!Len = PARITY('*C')
     THEN Len -:= 1
     ELSE warn(m_input_too_long);

   IF UnpackedLine!1 = PARITY('*L') THEN
   {
      UnpackedLine+:= 1; Len -:= 1
   }

   Line!0 := (Len << 8) \/ (UnpackedLine!1 & #X7F)
 
   Off := 2

   FOR i = 1 TO Len/2 DO
   $(
      Line!i := (((UnpackedLine!Off) & #X7F) << 8) +
                ((UnpackedLine!(Off+1)) & #X7F) 
      Off +:= 2
   $)
 
$)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!*/

AND ReadUnpackedLine(buff, len) = VALOF
{1 LET UnpackedLine = VEC line_bsz

   // trace("ReadPackedLine:")

   UNLESS fget(file_in_stream, UnpackedLine, len, parity('*C')) = 0
   DO RESULTIS errorvalue

   Len := UnpackedLine!0
 
   TEST (UnpackedLine!Len & #X7F) = '*C'
     THEN Len -:= 1
     ELSE warn(m_input_too_long);

   IF (UnpackedLine!1 & #X7F) = '*L' THEN
   {
      UnpackedLine+:= 1; Len -:= 1
   }

   buff -:= 1

   FOR i = 1 TO Len DO
      buff!i := UnpackedLine!i & #X7F
 
   RESULTIS len
}1

AND compare(s1, s2) = VALOF
{1 FOR i=1 TO s1%0 DO
      UNLESS (s1%i & #XD0) = (s2%i & #XD0) RESULTIS FALSE
   RESULTIS TRUE
}1
 
AND yes_reply(prompt, yes) = VALOF
{1 LET v = VEC 40
   LET reply = VEC 4
   LET df_text = yes -> " [Yes]", " [No]"
   LET append_pos = prompt%0

   FOR i=0 TO prompt%0 DO v%i := prompt%i
   FOR i=1 TO df_text%0 DO v%(append_pos+i) := df_text%i 

   v%0 +:= df_text%0

   askfor(-1, v, reply)
   IF reply%0 = 0 RESULTIS yes

   RESULTIS compare("YES", reply) |
            compare("OK", reply) |
            compare("TRUE", reply)
}1

/* ------------------- byte counting --------------------------
     The following four routines look after  a  double  precision
byte count for large files on 16 bit machines.  */
 
AND reset_byte_count() BE
/* Set the byte count to zero.  */
{1 byte_count := 0
   byte_count_excess := 0
}1

AND add_byte_count(n) BE
/* Add 'n' to the byte count.   */
{1 byte_count := byte_count + n
     IF byte_count > 9999 THEN
     byte_count_excess, byte_count :=
       byte_count_excess + 1, byte_count - 10000 }1

AND print_byte_count() BE
/* Print the double precision number. */
{1 TEST byte_count_excess > 0 
     THEN
       { writef("%N", byte_count_excess)
         WRZ(byte_count, 4) 
       }
     ELSE
       writef("%N", byte_count)
     writes(" bytes*N")
}1 

AND wrz(n, d) BE
{  IF d>1 THEN wrz(n/10, d-1)
   wrch(n REM 10 + '0')
}

AND null_stream(s) = VALOF
{1 MANIFEST {
      sbit.null = (1 << bit.nullstream)
   }

   LET dtab=s*str.entrysize+devtable
   RESULTIS (dtab!str.type & sbit.null) \= 0
}1

AND vdu_stream(s) = VALOF
{1 LET dtab = s*str.entrysize+devtable
   RESULTIS dtab!0 = pmi.tt
}1
 
AND convert_file_name(s) = VALOF
{1 LET dtab=s*str.entrysize+devtable
   LET f = dtab+11

   FOR i=0 TO 15 DO
   {  LET c=f%i & #X7F
      
      IF c='*S' THEN
      {  workspace%0:=i
         RESULTIS workspace
      }
      workspace%(i+1):=c
   }
   workspace%0:=16
   RESULTIS workspace
}1
 
AND getfilename(s) = (null_stream(s) -> "**N", convert_file_name(s))

AND get_pmi(pmi) = VALOF SWITCHON pmi INTO
{  CASE 0: RESULTIS "ST"
   CASE 2: RESULTIS "AD"
   CASE 3: RESULTIS "BD"
   CASE 4: RESULTIS "CR"
   CASE 7: RESULTIS "FD"
   CASE 8: RESULTIS "ED"
   CASE 9: RESULTIS "GP"
   CASE 10: RESULTIS "LP"
   CASE 11: RESULTIS "MT"
   CASE 12: RESULTIS "IP"
   CASE 13: RESULTIS "TP"
   CASE 14: RESULTIS "TR"
   CASE 15: RESULTIS "TT"
   CASE 16: RESULTIS "CD"
   CASE 22: RESULTIS "MS"
   CASE 23: RESULTIS "SL"
   CASE 24: RESULTIS "FY"
   CASE 26: RESULTIS "DD"
   DEFAULT: RESULTIS ""
}

AND print_filespec(stream) BE
{1 LET fspec = stream*str.entrysize+devtable
   UNLESS fspec%0 = 0 RETURN
   SWITCHON fspec!2 & #XFF INTO
   {  CASE 7:
         writef("/(%N)", fspec!5)

      CASE 0:
         UNLESS fspec!6 = principal DO writef(".%N", fspec!6)
         writef(".%S", convert_file_name(stream)) 
         ENDCASE

      CASE 3:
         writef("****")
         ENDCASE

      CASE 4:
         writef("**N")
         ENDCASE

      CASE 5:
         TEST fspec!1>1 THEN writef("**A%N", fspec!1)
         ELSE TEST fspec!1 = 0 THEN writef("**C")
         ELSE writef("**M")
         ENDCASE

      CASE 6:
         writef("/%S%N", get_pmi(fspec%1), fspec!1)
         ENDCASE

   }
   writef("*N")
}1

AND print_fs_err(code) BE
{1 LET op = VALOF SWITCHON code>>8 INTO
   {  CASE #X28: RESULTIS "Create"
      CASE #X29: RESULTIS "Open"
      CASE #X2C: RESULTIS "Extend"
      CASE #X1F: RESULTIS "Retain"
      CASE #X20: RESULTIS "Delete"
      CASE #X2F: RESULTIS "Get/Put"
      DEFAULT:   RESULTIS ""
   }
   writef("%S failed %x4 - %s*N", op, code, 
   VALOF SWITCHON code & #XFF INTO
   {  CASE #X40: RESULTIS (code>>8) = #X28 -> "File already exists",
                                            "File does not exist"
      CASE #X10: 
      CASE #X14: RESULTIS "Insufficient access"
      CASE #X41: RESULTIS "File exhausted"
      CASE #X50: RESULTIS "Password incorrect"
      CASE #X51: RESULTIS "Principal has no dictionary on partition"
      CASE #X60: RESULTIS "LVN/Partition does not exist"
      CASE #X71: RESULTIS "Peripheral unavailable"
      CASE #X72: RESULTIS "Too many extents (disc fragmented)"
      CASE #X74: RESULTIS "Insufficient space"
      CASE #X75: RESULTIS "Dictionary full"
      CASE #X92: RESULTIS "Transfer cancelled"
      CASE #X95: RESULTIS "Medium failure (file exhausted)"
      CASE #XB0: RESULTIS "Space allocation exceeded"
      DEFAULT:   RESULTIS ""
   })
}1

AND filing_error(stream, code) BE
{1 LET out = output()

   selectoutput(outstream)
   writef("Error on file: ")
   print_filespec(stream)
   print_fs_err(code)
   selectoutput(out)
}1