// BCPL1.bcpl - BCPL Compiler -- IO routines // Copyright Xerox Corporation 1980 // Use Dvec to allocate FileNameLength -- Swinehart, 6 May 77 get "bcplx" get "bcpliox" structure [ blank bit 15; ODDBIT bit 1 ] let Packstring(u, p) be [ let n = u!0 let i, j = 0, 0 [ p!j = u!i lshift 8 i = i + 1; if i gr n return p!j = p!j + (u!i & #377) i = i + 1; if i gr n return j = j + 1 ] repeat ] and Unpackstring(p, u) be [ let n = p!0 rshift 8 let i, j = 0, 0 [ u!i = p!j rshift 8 i = i + 1; if i gr n return u!i = p!j & #377 i = i + 1; if i gr n return j = j + 1 ] repeat ] and Movestring(p1, p2) be [ let n = p1!0 rshift 8 test n eq 0 then n = p1!0 or n = n/2 for i = 0 to n do p2!i = p1!i ] and Length(p) = p!0 rshift 8 and Char(p, n) = valof [ let i = n rshift 1 test (n & 1) eq 0 then resultis p!i rshift 8 or resultis p!i & #377 ] and WriteS(s) be [ let u = vec 256 Unpackstring(s, u) for i = 1 to u!0 do WW(u!i) ] and WriteN(n) be [ if n ls 0 do [ n = -n; WW($-) ] let zsw = false let k = 10000 for i = 1 to 4 do [ let d = n/k if zsw % (d ne 0) do [ WW(d+$0); zsw = true ] n = n rem k k = k/10 ] WW(n+$0) ] and WriteO(n) be [ let zsw = true for i = 15 to 3 by -3 do [ let d = (n rshift i) & #7 test zsw & (d eq 0) then [ WW($*s) ] or [ WW(d+$0); zsw = false ] ] WW((n & #7) + $0) ] and CloseInput(channel) be closechannel(channel) and CloseOutput(channel) be closechannel(channel) // will flush buffer in closechannel and CloseTemp(channel, ch) be closechannel(channel) // will flush buffer in closechannel and syscallerror(call, ac, stream; numargs nargs) be [ let callac = vec 3; for i = 0 to 3 do callac!i = ac!i Ostream = TTOstream WriteS("UNEXPECTED SYSTEM CALL ERROR ") WriteO(callac!2) [ WriteS(" ON CALL "); WriteO(call); WW($*n) ] if SWHelp do Help("SYSTEM CALL ERROR") finish ] and BadSwitch(i) be [ //illegal switch detected -- abort Ostream = TTOstream let n = FileNameLength/2; Dvec(BadSwitch,lv n); Packstring(filename, n) WriteS(n) for i = 1 to sw!0 do [ WW($/); WW(sw!i) ] WriteS(" -- BAD SWITCH "); WW(sw!i); WW($*n) if SWHelp do Help("HELP") finish ] and Error(message) be [ //fatal error detected -- abort Ostream = TTOstream WW($*n); WriteS(message); WW($*n) if SWHelp do Help("HELP") finish ] and FixFileName(Newname, ext, dev) be [ let udev = FileNameLength; Dvec(FixFileName, lv udev) let devsw = false let n = 0 [ n = n + 1 if n gr filename!0 do [ let v = vec 3 Unpackstring(ext, v) for i = 1 to v!0 do filename!(n+i-1) = v!i filename!0 = filename!0 + v!0 break ] if filename!n eq $. break if filename!n eq $: do devsw = true ] repeat let uname = filename test dev ne 0 & dev!0 ne 0 & not devsw then Unpackstring(dev, udev) or udev!0 = 0 if udev!0 ge 4 & udev!4 eq $: do [ uname = filename - 4 uname!0 = filename!0 + 4 for i = 1 to 4 do uname!i = udev!i ] if uname!(uname!0) eq $. do uname!0 = uname!0 - 1 Packstring(uname, Newname) filename!0 = n - 1 ] and DecValue(name) = valof [ //get decimal number from unpacked string let n = 0 for i = 1 to name!0 do [ unless $0 le name!i & name!i le $9 do Error("BAD DECIMAL NUMBER") n = n*10 + (name!i-$0) ] resultis n ] and OctValue(name) = valof [ //get octal number from unpacked string let n = 0 for i = 1 to name!0 do [ unless $0 le name!i & name!i le $7 do Error("BAD OCTAL NUMBER") n = n*8 + (name!i-$0) ] resultis n ] and Zerovec(n) = valof [ let v = Newvec(n) for i = 0 to n do v!i = 0 resultis v ] and List1(a) = valof [ let v = Newvec(1-1) v!0 = a resultis v ] and List2(a,b) = valof [ let v = Newvec(2-1) v!0, v!1 = a, b resultis v ] and List3(a,b,c) = valof [ let v = Newvec(3-1) v!0, v!1, v!2 = a, b, c resultis v ] and List4(a,b,c,d) = valof [ let v = Newvec(4-1) v!0, v!1, v!2, v!3 = a, b, c, d resultis v ] and List5(a,b,c,d,e) = valof [ let v = Newvec(5-1) v!0, v!1, v!2, v!3, v!4 = a, b, c, d, e resultis v ] and List6(a,b,c,d,e,f) = valof [ let v = Newvec(6-1) v!0, v!1, v!2, v!3, v!4, v!5 = a, b, c, d, e, f resultis v ] and List7(a,b,c,d,e,f,g) = valof [ let v = Newvec(7-1) v!0, v!1, v!2, v!3, v!4, v!5, v!6 = a, b, c, d, e, f, g resultis v ] and Nextparam() = valof [ static [ nextp = 0 ] nextp = nextp + 1; resultis nextp ] and Nextentry() = valof [ static [ nexte = 0 ] nexte = nexte + 1; resultis nexte ] and Nextstatic() = valof [ static [ nexts = 0 ] nexts = nexts + 1; resultis nexts ]