{ 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;