ftp.barnyard.co.uk/2015.02.ftp.barnyard.co.uk.tar/ftp.barnyard.co.uk/cpm/walnut-creek-CDROM/MBUG/MBUG184.ARC/ROS34.LBR/ROSKMS.IZC/ROSKMS.INC

Text File | 1979-12-31 | 10KB | 329 lines

{ ROSKMS.INC - Remote Operating System Kernel - Miscellaneous routines }

procedure SetSect(Drive, User: integer);
{ Set to file section }
  begin
    BDOS(seldrive, Drive);
    BDOS(getseluser, User)
  end;

procedure FindSect(req: FileName; var Drive, User: integer; var found: boolean);
{ Find file section from requested name }
  var
    this: SectPtr;
  begin
    this := SectBase;
    while (req <> this^.SectName) and (this <> nil) do
      this := this^.next;
    found := ((req = this^.SectName) and (cold or (user_rec.access >= this^.SectAccs)));
    if found
      then
        begin
          Drive := this^.SectDrive;
          User := this^.SectUser
        end
  end;

function diskfree: integer;
{ Compute amount of disk space free on current drive }
  type
    param =
      record
        spt: integer;
        bsh, blm, exm: byte;
        dsm, drm, al, cks, off: integer
      end;
  var
    allocptr, reserved, blocksize, disksize, i: integer;
    dpbptr: ^param;
  begin
    allocptr := BDOSHL(getallocvec, 0);
    dpbptr   := ptr(BDOSHL(getdiskparm, 0));
    with dpbptr^ do
      begin
        reserved := 0;
        for i := 0 to 15 do
          reserved := reserved + (al shr i) and 1;
        disksize := succ(dsm) - reserved;
        for i := reserved to dsm do
          disksize := disksize - (((mem[allocptr + i shr 3] shl (i mod 8)) and $80) shr 7);
        blocksize := 1 shl (bsh - 3)
      end;
    diskfree := disksize * blocksize
  end;

procedure hide_release(name: FileName; status: record_status);
{ Hide or release file }
  var
    i: integer;
    temp_file: file;
  begin
    Assign(temp_file, name);
    i := pos('.', name) + 2;
    if status = public
      then name[i] := chr($7F and ord(name[i]))  { Turn $SYS bit off }
      else name[i] := chr($80 or ord(name[i]));  { Turn $SYS bit on }
    {$I-} Rename(temp_file, name) {$I+};
    if IOresult <> 0
      then writeln(USR, name, ' not found.')
  end;

function min(x, y: integer): integer;
{ Return minimum of two integers }
  begin
    if x < y
      then min := x
      else min := y
  end;

function max(x, y: integer): integer;
{ Return greater of two integers }
  begin
    if x > y
      then max := x
      else max := y
  end;

function trim(st: StrStd): StrStd;
{ Remove leading and trailing blanks }
  var
   i, j: integer;
  begin
    i := 1;
    j := length(st);
    while (st[i] = ' ') and (i <= j) do
      i := succ(i);
    while (st[j] = ' ') and (j >= i) do
      j := pred(j);
    trim := copy(st, i, succ(j - i))
  end;

function pad(st: StrStd; i: integer): StrStd;
{ Pad string with spaces to length of i }
  begin
    while length(st) < i do
      st := st + ' ';
    pad := st
  end;

function intstr(n, w: integer): Str10;
{ Return a string value (width 'w')for the input integer ('n') }
  var
    st: Str10;
  begin
    str(n:w, st);
    intstr := st
  end;

function strint(st: Str10): integer;
{ Convert string to integer }
  var
    x, code: integer;
  begin
    if st[1] = '+'
      then delete(st, 1, 1);
    if st = ''
      then code := 1
      else val(st, x, code);
    if code = 0
      then strint := x
      else strint := 0                      { Error, return with 0 }
  end;

function zeller(day, month, year: integer): integer;
{ Compute the day of the week using Zeller's Congruence }
  var
    century: integer;
  begin
    if month > 2
      then month := month - 2
      else
        begin
          month := month + 10;
          year := pred(year)
        end;
    century := year div 100;
    year := year mod 100;
    zeller := (day - 1 + ((13 * month - 1) div 5) + (5 * year div 4) +
              century div 4 - 2 * century + 1) mod 7
  end;

function FormTAD(t: tad_array): StrTAD;
{ Build printable string of current time and date }
  const
    day: array [0..6] of string[6] =
      ('Sun','Mon','Tues','Wednes','Thurs','Fri','Satur');
    month: array [1..12] of string[3] =
      ('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec');
  var
    i: integer;
    line: StrTAD;
  begin
    if (t[1] in [0..59]) and (t[2] in [0..23])
      then line := intstr(t[2], 2) + ':' + intstr(t[1], 2)
      else line := '';
    for i:= 1 to length(line) do
      if line[i] = ' '
        then line[i]:= '0';
    if (t[3] in [1..31]) and (t[4] in [1..12]) and (t[5] in [0..99])
      then FormTAD :=
        line + '  ' +
        day[zeller(t[3], t[4], 1900 + t[5])] + 'day  ' +
        intstr(t[3], 2) + '-' + month[t[4]] + '-' + intstr(t[5], 2)
      else FormTAD := 'No Date'
  end;

procedure send_time(size: integer; var mm, ss: integer);
{ Compute the file transfer time }
  var
    tr_time: real;
  begin
    tr_time := size * 23.5 / rate;          { Factor is empirically derived  }
    mm := trunc(tr_time);
    ss := round(60.0 * frac(tr_time))
  end;

procedure timer(var time_on, time_left: integer);
{ Compute the time on and the time remaining to the current user }
  var
    t: tad_array;
  begin
    GetTAD(t);
    time_on := 60 * (t[2] - login_t[2]) + t[1] - login_t[1];
    if time_on < 0
      then time_on := time_on + 1440;
    time_left := user_rec.limit + extra_time - time_on
  end;

procedure log(activity: byte; text: FileName);
{ Update log file }
  begin
    seek(logr_file, FileSize(logr_file));
    GetTAD(logr_rec.date);
    logr_rec.action := activity;
    logr_rec.user := user_loc;
    logr_rec.text := text;
    write(logr_file, logr_rec)
  end;

procedure mesg_insert(TypMsg: byte);
{ Insert message into linked list }
  var
    this: MesgPtr;
  begin
    new(this);
    if MesgBase = nil
      then MesgBase := this
      else MesgLast^.next := this;
    MesgLast := this;
    MesgLast^.MesgNo := summ_rec.num;
    MesgLast^.SummLoc := pred(FilePos(summ_file));
    MesgLast^.TypMsg := TypMsg;
    MesgLast^.next := nil
  end;

procedure InsertFile(fname: name_array; index, size: integer;
                     var entries, total: integer; var first: FilePtr);
{ Insert a new file name into an alphabetic list }
  var
    space: integer;
    f,                                      { File name entry being created }
    this, last: FilePtr;                    { Followers for insertion }
    fn: FileName;
  begin
    fn := '           ';                    { Initialize string }
    move(fname, fn[1], 11);                 { Move name into place }
    insert('.', fn, 9);
    last := nil;
    this := first;
    while (this <> nil) and (this^.fname < fn) do
      begin
        last := this;
        this := this^.next
      end;
    space := size shr 3;
    if (size mod 8) <> 0
      then space := succ(space);
    if this^.fname <> fn
      then
        begin
          entries := succ(entries);
          total := total + space;
          new(f);
          f^.fname := fn;
          f^.index := index;
          f^.fsize := size;
          f^.next  := this;
          if last = nil
            then first := f
            else last^.next := f
        end
    else if (this^.fname = fn) and (this^.fsize < size)
      then
        begin
          total := total + space;
          space := this^.fsize shr 3;
          if (this^.fsize mod 8) <> 0
            then space := succ(space);
          total := total - space;
          this^.fsize := size
        end
  end;

{ Notes on updcrc:

   Purists that want ROS to be written COMPLETELY in Pascal, should use the
   Pascal version, but it is slower than the inline code version.  The inline
   code version is, of course, Z-80 specific, but it is MUCH faster.

   The two procedures are functionally equivalent - simply comment out the
   procedure you don't want to use.
}

(*
procedure updcrc(var crc: integer; acc: integer);
{ Update CRC with passed value }
    var
      carry: boolean;
      i: integer;
    begin
      for i := 1 to 8 do
        begin
          carry := ((crc and $8000) <> 0);
          crc := crc shl 1;
          if (acc and $0080) <> 0
            then crc := succ(crc);
          acc := acc shl 1;
          if carry
            then crc := crc xor $1021       { Use $8005 for CRC-16 }
        end
    end;
*)

procedure updcrc(var crc: integer; acc: integer);
{ Update CRC with passed value }
  begin
    inline($2A/crc/       {         LD      HL,(crc)    ; point to crc    }
           $5E/           {         LD      E,(HL)      ; put crc into DE }
           $23/           {         INC     HL          ;                 }
           $56/           {         LD      D,(HL)      ;                 }
           $EB/           {         EX      DE,HL       ; put it into HL  }
           $ED/$4B/acc/   {         LD      BC,(acc)    ; get acc into C  }
           $06/$08/       {         LD      B,8         ; shift 8 times   }
           $CB/$01/       { UPDLP:  RLC     C           ; shift input     }
           $ED/$6A/       {         ADC     HL,HL       ; shift crc       }
           $30/$08/       {         JR      NC,SKIPIT   ; jump if no carry}
           $7C/           {         LD      A,H         ; xor with $1021  }
           $EE/$10/       {         XOR     10H         ; use $8005 for   }
           $67/           {         LD      H,A         ;   CRC-16        }
           $7D/           {         LD      A,L         ;                 }
           $EE/$21/       {         XOR     21H         ;                 }
           $6F/           {         LD      L,A         ;                 }
           $10/$F0/       { SKIPIT: DJNZ    UPDLP       ; done?           }
           $EB/           {         EX      DE,HL       ; result to DE    }
           $72/           {         LD      (HL),E      ; then into       }
           $2B/           {         DEC     HL          ;   into          }
           $73)           {         LD      (HL),D      ;     memory      }
end;