! General utility procedures %option "-nocheck-nostack-low" %include "Config.Inc" %include "System:Common" %include "System:Errors.Inc" %include "System:Schedule.Inc" %include "Inc:Util.Imp" %include "Inc:FS.Imp" %routinespec pdate %ownrecord(common fm)%name common %recordformat frig fm(%record(common fm)%name common) %externalrecord(frig fm) common frig ! These are necessary, because %external %names don't work ! "High-density" hex. Usually just "normal" hex, except that ! the high order hexit isn't forced to be modulo 16, and the ! sequence goes ...8, 9, :, ;, .... rather than the more ! normal ...8, 9, A, B, .... %externalstring(1)%fn hdx1(%integer i) ! single hexit version %result = tostring(i + '0') %end %externalstring(2)%fn hdx2(%integer i) ! two hexit version %result = "" %if i < 0 { Special } %result = tostring(i >> 4 + '0') . tostring(i & 15 + '0') %end %externalstring(4)%fn hdx4(%integer i) ! four hexit version %string(7) s %integer j, k, n s = "" %for n = 1, 1, 4 %cycle j = i // 16 k = i - 16 * j s = tostring(k + '0') . s i = j %repeat %result = s %end %externalintegerfn hdx to i(%string(255) s) ! convert from "high-density" hex to binary %integer i, x = 0 %result = 0 %if s = "" x = x << 4 + charno(s, i) - '0' %c %for i = 1, 1, length(s) %result = x %end ! "Normal" hex !%externalroutine pxb(%integer what) ! ! This one is redundant, as it is pre-defined in ! ! the operating system. ! %integer ch ! ch = (what >> 4) & 15 ! %if 0 <= ch <= 9 %then print symbol(ch + '0') %c ! %else print symbol(ch - 10 + 'A') ! ch = what & 15 ! %if 0 <= ch <= 9 %then print symbol(ch + '0') %c ! %else print symbol(ch - 10 + 'A') !%end %externalstring(2)%fn itox2(%integer what) ! convert binary to a 2-hexit string %string(3) s %integer ch ch = (what >> 4) & 15 %if 0 <= ch <= 9 %then s = to string(ch + '0') %c %else s = to string(ch - 10 + 'A') ch = what & 15 %if 0 <= ch <= 9 %then s = s . to string(ch + '0') %c %else s = s . to string(ch - 10 + 'A') %result = s %end ! Case conversion %externalroutine upper case(%string(*)%name s) ! convert the parameter to upper case %bytename ch %integer l l = length(s) %return %if l = 0 ch == charno(s, 1) %while l > 0 %cycle ch = ch - 'a' + 'A' %if 'a' <= ch <= 'z' ch == ch[1] l = l - 1 %repeat %end ! Zap login. (And also set and quoted passwords). Ensures that ! passwords don't appear either in the trace buffer or on the ! console. %externalroutine zap login(%string(*)%name text) { L, Q, P } %integer l, ch %return %if text = "" ch = charno(text, 1) ch = ch - 'a' + 'A' %if 'a' <= ch <= 'z' %if ch = 'P' %or ch = 'Q' %start ! Password or Quote. Only one parameter. length(text) = 2 text = text . "????" %else %if ch = 'L' ! Login. Two parameters. The first is variable ! in length, so we have to hunt for the start of ! the second.... l = length(text) l = l - 1 %while l > 0 %and charno(text, l) # ',' length(text) = l %if l # 0 text = text . "????" %else %if ch = ']' %if length(text) > 4 %and charno(text, 3) = '6' %start ! Setting system password length(text) = 4 text = text . "????" %finish %finish %end ! Pack / unpack filenames. Radix-40 used throughout the ! file system, both for filenames and for usernames. %externalintegerfn pack(%string(255) s, %integername p1, p2) %integer l, pos, error = success %integerfn pack3 ! pack one 16-bit portion %integer i, j = 0, ch %for i = 1, 1, 3 %cycle j = 40 * j pos = pos + 1 %if pos <= l %start ch = charno(s, pos) %if 'A' <= ch <= 'Z' %start ch = ch - 'A' + 1 %else %if 'a' <= ch <= 'z' ch = ch - 'a' + 1 %else %if '0' <= ch <= '9' ch = ch - '0' + 28 %else %if ch = '.' ch = 38 %else %if ch = '$' ch = 39 %else %if ch = '_' ch = 27 %else %if ch = '#' ch = 0 %else error = param error ch = 0 %finish j = j + ch %finish %repeat %result = j %end l = length(s) %if l = 0 %start ! null filename -- special case p1 = 0; p2 = 0 %result = success %finish %result = param error %unless l <= 12; ! too long pos = 0 p1 = pack3 << 16 ! pack3 p2 = pack3 << 16 ! pack3 %result = param error %if p1 = 0 %and p2 = 0 %result = error %end %constbytearray pchar(0 : 39) = '#', 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z', '_', '0', '1', '2', '3', '4', '5', '6', '7', '8', '9', '.', '$' %constinteger dollars = 16_F9FF %externalstring(31)%fn unpack(%integer p1, p2) %string(3)%fn unpack3(%integer p, z1, z2, z3) ! unpack one 16-bit portion %bytearray u(1 : 3) %string(3) s = "" %integer i, q, r, last, it %result = "" %if p = 0 %and z1 = 0 %and z2 = 0 %and z3 = 0 %result = "***" %unless 0 <= p <= dollars %for i = 3, -1, 1 %cycle q = p // 40 r = p - 40 * q u(i) = r p = q %repeat last = z1 ! z2 ! z3 %for i = 3, -1, 1 %cycle it = u(i) s = to string(pchar(it)) . s %if it # 0 %or last # 0 last = it %if last = 0 %repeat %result = s %end %integer x1, x2, x3, x4 %result = "*bad*" %if p1 = -1 %result = "?zero?" %if p1 = 0 %and p2 = 0 x1 = p1 >> 16; x2 = p1 & 16_FFFF x3 = p2 >> 16; x4 = p2 & 16_FFFF %result = unpack3(x1, x2, x3, x4) . %c unpack3(x2, x3, x4, 0) . %c unpack3(x3, x4, 0, 0) . %c unpack3(x4, 0, 0, 0) %end ! Password encryption -- probably secure enough....? %integerfn ecma crc(%integer ad, len) ! Provided by Gordon Brebner %integer rem %routine include(%byte b) %integer i, flag %for i = 0, 1, 7 %cycle flag = rem rem = rem<<1 ! b&1 rem = rem !! 2_00000100110000010001110110110111 %if flag < 0 b = b>>1 %repeat %end rem = 16_FFFFFFFF include(byte integer(ad)) %for ad = ad, 1, ad+len-1 include(0); include(0) %result = \rem %end %externalintegerfn encrypt(%string(255) pass) %result = 0 %if pass = "" upper case(pass) %result = ecma crc(addr(pass) + 1, length(pass)) %end %externalstring(255)%fn endecrypt(%string(255)owner,pass,%integer en) ! Encrypt (EN#0) or decrypt (EN=0) PASS by xorring in a CRC ! which has been initialised by passing OWNER through it. ! We assume that the raw data in PASS is only seven bits wide ! and use the parity bit to show that the character has been ! encrypted. %integer rem,i %routine include bit(%integer b) %integer flag flag = rem rem = rem<<1 ! b&1 rem = rem !! 2_00000100110000010001110110110111 %if flag < 0 %end %routine include byte(%integer b) %integer i include bit(b) %and b = b>>1 %for i = 0, 1, 7 %end %routine translate(%bytename b) %integer i,bit=1 %returnif b&128=en %for i = 1,1,7 %cycle include bit(0) b = b!!bit %if rem&1=0 bit = bit<<1 %repeat b = b!!bit %end en = 128 %unless en=0 uppercase(owner); uppercase(pass) rem = 16_FFFFFFFF include byte(charno(owner,i)) %for i = 1,1,length(owner) translate(charno(pass,i)) %for i = 1,1,length(pass) %result = pass %end ! Bulk move of bytes %externalroutine bulk move(%integer bytes, %bytename from, to) ! This routine based on one by RWT %if bytes <= 0 %start pdate printstring("*** Bulk move "); write(bytes, 0) printstring(" bytes ????") newline %return %finish ! printstring("Bulk move "); write(bytes, 0) ! printstring(" from "); phex(addr(from)) ! printstring(" to "); phex(addr(to)) ! newline bytes = bytes - 1 *move.l from, a0 *move.l to, a1 *move.l bytes, d0 loop: *move.b (a0)+, (a1)+ *dbra d0, loop %end ! Add text to trace buffer. ! The labels circumvent(ed) a compiler problem. %externalroutine trace(%integer context, inout, %string(255) text) %record(trace fm)%name trace %integer x length(text) = length(text) - 1 %if text # "" %c %and charno(text, length(text)) = nl length(text) = 55 %if length(text) > 55 zap login(text) %if inout = trace in trace == common_trace_t(common_trace_p) c1: x = (common_trace_p + 1) & tbuffs c2: common_trace_p = x c3: common_trace_q = x trace_context = context trace_inout = inout trace_text = text %end ! Interrupt enabling/disabling. These must be callable from ! contexts with a non-zero IPL, hence must save and restore ! things correctly. %owninteger previous sr = 0 %externalroutine iof *mfsr D1 *move.w D1, D0 *or.w #16_0700, D0 *trap #0 *move.w D1, previous sr %end %externalroutine ion *move.w previous sr, D0 *trap #0 %end ! Claim and release system buffers. Buffers are either: ! (a) in use; ! (b) pushed onto the free list if they are no longer required; ! (c) above the high water mark, if they have never been used. %externalintegerfn claim buffer %integer claimed %record(buffer fm)%name buffer iof %if common_buffer pool free # 0 %start ! Something on the free list claimed = common_buffer pool free buffer == common_buffer(claimed) common_buffer pool free = buffer_link %else ! Free list exhausted, bring the tide in some more.... claimed = common_buffer pool used + 1 %if claimed > buffs %start ! None left -- probably a disaster ion %result = -1 %finish common_buffer pool used = claimed buffer == common_buffer(claimed) %finish ion buffer = 0; ! zap it, just in case buffer_ether packet = -1 %result = claimed %end %externalroutine release buffer(%integer which) %record(buffer fm)%name buffer iof buffer == common_buffer(which) buffer_context = 0 buffer_link = common_buffer pool free common_buffer pool free = which ion %end ! Generate / unpack dates and times. The algorithms are taken ! from Mouses V9.2, but appear to be the same as used in the ! old filestore......? %owninteger current date = 0 %owninteger current time = 0 %owninteger current offset %owninteger next log stamp %constinteger minutes per day = 24 * 60 %externalroutine time stamp(%shortname date, time) %integer now, x, q now = CPU time x = (now - current offset) // (60 * clock factor) %if x > 0 %start ! More minutes to add to the current time current time = current time + x current offset = current offset + (60 * clock factor) * x ! Find out if it's tomorrow yet.... x = current time // minutes per day %if x > 0 %start ! Wrapped round into tomorrow, or even beyond.... current date = current date + x q = minutes per day * x current time = current time - q next log stamp = next log stamp - q %finish %if current time > next log stamp %start ! Another console log stamp due. kick(stamp flag) next log stamp = current time + stamp interval %finish %finish date = current date time = current time %end ! Convert the date into a printable form. ! (This %must surely be a well-known algorithm??) %externalstring(15)%fn unpack date(%short date) %owninteger last unpacked = -1 %ownbytearray s(0 : 8) %integer d, m, y %if date # last unpacked %start last unpacked = date d = (date + 21000) << 2 - 1 y = d // 1461 + 1 d = rem(d, 1461) d = ((d + 4) >> 2) * 5 - 3 m = d // 153 - 9 %if m <= 0 %start m = m + 12; y = y - 1 %finish d = (rem(d, 153) + 5) // 5 s(0) = 8 s(1) = d // 10 + '0' s(2) = rem(d, 10) + '0' s(3) = '/' s(4) = m // 10 + '0' s(5) = rem(m, 10) + '0' s(6) = '/' s(7) = y // 10 + '0' s(8) = rem(y, 10) + '0' %finish %result = string(addr(s(0))) %end ! This one is easy -- just converts minutes to hours and minutes. %externalstring(7)%fn unpack time(%short time) %bytearray b(0 : 5) %integer h, m h = time // 60 m = rem(time, 60) b(0) = 5 b(1) = h // 10 + '0' b(2) = rem(h, 10) + '0' b(3) = '.' b(4) = m // 10 + '0' b(5) = rem(m, 10) + '0' %result = string(addr(b(0))) %end ! Again, a well-known algorithm.....? %externalintegerfn pack date(%string(255) date) %integer y, m m = charno(date, 4) * 10 + charno(date, 5) - '0' * 11 y = charno(date, 7) * 10 + charno(date, 8) - '0' * 11 m = m - 3 m = m + 12 %and y = y - 1 %if m < 0 %result = (charno(date, 1) ! 16) * 10 + charno(date, 2) - '0' * 11 %c + (y * 1461) >> 2 %c + (m * 153 + 2) // 5 %c - 21000 %end ! Hours and minutes -> minutes %externalintegerfn pack time(%string(255) time) %integer h, m h = charno(time, 1) * 10 + charno(time, 2) - 11 * '0' m = charno(time, 4) * 10 + charno(time, 5) - 11 * '0' %result = -1 %unless 0 <= h <= 23 %and 0 <= m <= 59 %result = h * 60 + m %end ! Same as , but takes a different input format. %conststring(3)%array months(1 : 12) = "JAN", "FEB", "MAR", "APR", "MAY", "JUN", "JUL", "AUG", "SEP", "OCT", "NOV", "DEC" %integerfn pack VAX date(%string(255) date) %integer y, m, n %string(3) nn %result = 0 %if length(date) # 11 m = 13 n = charno(date, 1) nn = sub string(date, 4, 6) %cycle m = m - 1; %result = 0 %if m = 0 %exit %if months(m) = nn %repeat y = charno(date, 10) * 10 + charno(date, 11) - '0' * 11 m = m - 3 m = m + 12 %and y = y - 1 %if m < 0 n = (n ! 16) * 10 + charno(date, 2) - '0' * 11 %c + (y * 1461) >> 2 %c + (m * 153 + 2) // 5 %c - 21000 %result = n %end %externalstring(15)%fn unpack VAX date(%short date) %ownbytearray s(0 : 11) %integer d, m, y d = (date + 21000) << 2 - 1 y = d // 1461 + 1 d = rem(d, 1461) d = ((d + 4) >> 2) * 5 - 3 m = d // 153 - 9 %if m <= 0 %start m = m + 12; y = y - 1 %finish d = (rem(d, 153) + 5) // 5 s(0) = 11 s(1) = d // 10 + '0' s(2) = rem(d, 10) + '0' string(addr(s(3))) = months(m) s(3) = '-' s(7) = '-' s(8) = '1' s(9) = '9' s(10) = y // 10 + '0' s(11) = rem(y, 10) + '0' %result = string(addr(s(0))) %end ! Set to a given date & time %externalintegerfn set date and time(%string(15) date, time) %string(15) unpacked date, unpacked time %integer pd, pt pd = pack date(date) pt = pack time(time); %result = param error %if pt < 0 unpacked date = unpack date(pd) %result = param error %if unpacked date # date unpacked time = unpack time(pt) %result = param error %if unpacked time # time current date = pd current time = pt current offset = CPU time next log stamp = current time - 1; ! Force a stamp %result = success %end ! Initialise everything (during boot). %externalroutine set VAX date(%string(255) VAX time) %string(255) date, time VAX time -> date .(" "). time current date = pack VAX date(date) current time = pack time(time) current offset = CPU time next log stamp = current time + stamp interval %end ! Print out the time. Print the date if it has changed. %constinteger day fixup = 2 %conststring(11)%array days(0 : 6) = "Monday ", "Tuesday ", "Wednesday ", "Thursday ", "Friday ", "Saturday ", "Sunday " %externalroutine pdate %short date, time %ownshort current date = 16_7fff time stamp(date, time) %if date # current date %start newline printstring("Today is ") printstring(days(rem(date + day fixup, 7))) printstring(unpack date(date)) current date = date newline; newline %finish printstring(unpack time(time)) spaces(2) %end ! Common area stuff. If %external %names worked we wouldn't ! need all this stuff...... %externalrecord(common fm)%map common area %result == common %end %externalroutine init common common == common frig_common %end ! System monitoring stuff follows. Prints out Ether and ! scheduling states. %externalintegerspec schedule mask %externalintegerspec schedule cutoff %externalintegerspec inhibit count %externalintegerarrayspec ack wait mask(0 : ether TX procs - 1) %externalroutine show ether status %integer i printstring("DTX: "); phex(DTX) printstring(", ACK: "); phex(ACK) printstring(", NAK: "); phex(NAK) printstring(", ES: "); phex2(EthS) newline printstring("AWait:") space %and phex(ack wait mask(i)) %for i = 0, 1, ether TX procs - 1 newline %end %externalroutine show system status %record(buffer fm)%name b %integername x pdate printstring("System status.... ") phex(schedule mask); write(schedule cutoff, 1) write(inhibit count, 1) write(common_disc request, 1) printstring(" disc iwait") %if common_disc twait # 0 newline show ether status printstring("Ether: ") write((common_ether buffer_next to use %c - common_ether buffer_next to process) & ether buffers, 0) printstring(" /") %if common_ether request queue = 0 %start printstring(" queue empty") %else x == common_ether request queue %while x # 0 %cycle write(x, 1) x == common_buffer(x)_link %repeat %finish newline printstring("Proc: ") %if common_proc request queue = 0 %start printstring(" queue empty") %else x == common_proc request queue %while x # 0 %cycle write(x, 1) x == common_buffer(x)_link %repeat %finish newline kick(stamp flag) %end %externalroutine show buffer info %record(buffer fm)%name b %record(port fm)%name p %integer i pdate write(common_buffer pool used, 0) printstring(" used of "); write(buffs, 0) %for i = 1, 1, common_buffer pool used %cycle b == common_buffer(i) %if i & 7 = 1 %start newline spaces(5) %finish write(i, 3); space write(b_context, 3) %if 0 < b_context <= ports %start p == common_port info(b_context) %if p_state = 0 %start printstring(" closed") %else space phex2(p_remote) print symbol('.') phex2(p_port) space %finish %else %if b_context < 0 printstring(" system") %else printstring(" free ") %finish %repeat newline %end %end %of %file