// BCPLDOS.bcpl - BCPL DOS-specific functions
// Copyright Xerox Corporation 1980
// Swinehart, 6 May 77, file lengths -> statics
// InitBCPL calls Main<SWINEHART>BCPLDOS.;5 4-APR-75 07:56:19 EDIT BY SWINEHART
// pull SWAltoc...ime <SWINEHART>BCPLDOS.;3 28-MAR-75 13:22:29 EDIT BY SWINEHART
get "bcplx"
get "bcpliox"
external[
bufferio
displaystream
ReadchKLUDGE
streamvec
syscall
WritechKLUDGE
InitToRead
openfile
]
manifest [
zframemax = #335
zframenext = #336
zframefirst = #337
zreturn = #366
]
// system-dependent manifests, used by InitBCPL
manifest
[
STREAMsize = ((size STREAM + 15)/16)
streamvecsize = 7
]
structure [ blank bit 15; ODDBIT bit 1 ]
let InitBCPL(paramvec) be
[
Version = (2 lshift 8) + 0
SWAlto = false // default -- compile NOVA code
TTOstream = OpenOutput(0)
TTIstream = OpenInput(0)
Ostream = TTOstream; Istream = TTIstream;
let v = vec streamvecsize
streamvec = v
let streamtables = vec (streamvecsize+1)*STREAMsize
FreeMax = paramvec!#37-1
// Limits are Max's
DictFreeLimit = FreeMax - (paramvec!1+1)
TreeFreeLimit = FreeMax - (paramvec!2+1)
CodeFreeLimit = FreeMax - (paramvec!3+1)
FileNameLength = 20
GetFileMax = 12
for i = 0 to 7 do
[
streamvec!i = streamtables
streamtables = streamtables + STREAMsize + 1
]
// CALL THE COMPILER
Main(paramvec)
]
and syscall(call, ac) = valof
[ let err = syscallproc(call, ac)
if err eq -1 resultis 0
if err eq 0 do err = #15
resultis err
]
and Position(stream) = valof
[
if stream ls 0 then resultis -1
let channel = stream>>STREAM.channel
unless 0 le channel & channel le 7 resultis -1
let v = #430 //DOS channel table in page one
let t = v!channel //DOS descriptor for the channel
let bytenum = t!#25 //word 25 is byte number in current block
let bloknum = t!#24 //word 24 is current block number
let dospos = ((bloknum * 255) lshift 1) + bytenum
if stream>>STREAM.action eq writeact then
resultis dospos + stream>>STREAM.count
if dospos eq 0 then resultis 0
resultis dospos - (stream>>STREAM.max - stream>>STREAM.count) -1
]
and bufferio(stream, opr, count) = valof
[
sysac!0 = (lv stream>>STREAM.bytebuffer) lshift 1
sysac!1 = count
sysac!2 = stream>>STREAM.channel
resultis syscall(opr, sysac)
]
and Help(Message) be
[
let v = vec 3
let m = vec 64
Unpackstring(Message, m)
for i = 1 to m!0 do [ v!0 = m!i; syscall(syspchar, v) ]
Unpackstring(" -- HELP*n", m)
for i = 1 to m!0 do [ v!0 = m!i; syscall(syspchar, v) ]
sysdebugproc()
return
]
and Readch(stream, lvc) be
[Rch
let numbytes = 1
ReadchKLUDGE: // THIS IS THE ENTRY POINT FROM READWORD !!UGH!!!!
let v = vec 2
test stream eq -1
ifso // tty simultation
for i = 1 to numbytes do[ syscall(sysgchar, sysac)
v!i = sysac!0 & #377 ]
ifnot [fileio // talking to a real file!
for i = 1 to numbytes do
[mainloop
let count = stream>>STREAM.count
if count gr stream>>STREAM.max then
[
let err = bufferio(stream, sysrds, maxstreambytes)
let num = sysac!1
stream>>STREAM.max = num -1
//displaystream(stream); WriteS("err=");WriteO(err);WW($*N)
if err then unless err eq 6 do syscallerror(sysrds, sysac,
stream)
if num eq 0 then [
v!1, v!2 = #777, #777
break ]
count = 0
]
v!i = stream>>STREAM.bytebuffer↑count
stream>>STREAM.count = count + 1
loop
]mainloop
]fileio // talking to a real file!
//for i = 1 to numbytes do [ WW(v!i); WriteO(v!i); WW($*N) ]
if numbytes eq 1 then
[ @lvc = v!1; return ]
v!2 <<LEFTHALF = v!1
@lvc = v!2
]Rch
and Writech(stream, ch) be
[Wch
let numbytes = 1
WritechKLUDGE: // <<<< ENTRY POINT for Writeword !!!! (UGH!!)
if stream>>STREAM.action ne writeact then [ WriteO(stream);
Help("writing a read stream")]
let v = vec 2
test numbytes eq 1
ifso v!1 = ch
ifnot [ v!1 = ch << LEFTHALF; v!2 = ch<<RIGHTHALF ]
test stream eq -1
ifso for i = 1 to numbytes do [ sysac!0 = v!i
syscall(syspchar, sysac)
]
ifnot [fileio
for i = 1 to numbytes do
[mainloop
let count = stream >>STREAM.count
if count gr maxbyteindex then
[
if bufferio(stream, syswrs, maxstreambytes) then
syscallerror(syswrs, sysac, stream)
count = 0
]
stream>>STREAM.bytebuffer↑count = v!i
stream>>STREAM.count = count + 1
loop
]mainloop
]fileio
]Wch
// note this code assumes the buffer begins and ends on
// even word boundries.
and Readword(stream, lvw) be
[
if stream>>STREAM.action ne readact then [ WriteO(stream);
Help("reading a write-stream")]
let numbytes = 2
let c = stream>>STREAM.count
if c<<ODDBIT % (c + 1 gr stream>>STREAM.max) then goto ReadchKLUDGE
@lvw = stream>>STREAM.wordbuffer↑(c rshift 1)
stream>>STREAM.count = c + 2
return
let v = vec 25 // ALLOCATE ENOUGH STACK SPACE UGH,UGH!!!
]
and Readaddr(stream, lva) be
[ Readaddr = Readword
Readword(stream, lva)
]
and Writeword(stream, w) be
[
if stream>>STREAM.action ne writeact then [ WriteO(stream);
Help("writing a read stream")]
let numbytes = 2
let c = stream>>STREAM.count
if c<<ODDBIT % (c + 1 gr stream>>STREAM.max) then goto WritechKLUDGE // goto is fast! UGH!!!!!
stream>>STREAM.wordbuffer↑(c rshift 1) = w
stream>>STREAM.count = c + 2
return
let v = vec 25 // ALLOCATE ENOUGH STACK SPACE UGH,UGH!!!
]
and Writeaddr(stream, a) be
[ Writeaddr = Writeword
Writeword(stream, a)
]
and WW(ch) be
[
static [ newlinecount = 0 ]
let newline = ch eq $*n
test newline
ifnot newlinecount = 0
ifso [ if newlinecount ge 2 return
newlinecount = newlinecount + 1
]
if SWOneCase do
if $a le ch & ch le $z do ch = ch + ($A-$a)
test Ostream eq -1
then
[ sysac!0 = ch; syscall(syspchar, sysac)
if newline do
[ sysac!0 = #12; syscall(syspchar, sysac)
if SWWait do Wait() ]
]
or
[ Writech(Ostream, ch)
if newline do
[ static [ lastformfeed = 0 ]
if Position(Ostream) gr lastformfeed+#20000 do
[ lastformfeed = Position(Ostream); WW(#14) ]
]
]
]
and Wait() be
[
static [ waitcount = 20; waitdefault = 20 ]
waitcount = waitcount - 1
if waitcount ne 0 return
l:let v = vec 3
v!0 = #7; syscall(syspchar, v)
v!0 = $:; syscall(syspchar, v)
let n = -1
syscall(sysgchar, v)
let ch = v!0 & #177
m:switchon ch into
[ case #15: unless n eq -1 do waitdefault = n
waitcount = waitdefault
v!0 = #15; syscall(syspchar, v)
return
case #12: unless n ne -1 do n = 1
waitcount = n
v!0 = #15; syscall(syspchar, v)
return
case #33: Help("PAUSE")
goto l
case $0 to $9: syscall(syspchar, v)
n = ch - $0
[ syscall(sysgchar, v); ch = v!0 & #177
unless $0 le ch & ch le $9 break
syscall(syspchar, v)
n = n*10 + (ch - $0)
] repeat
goto m
default: v!0 = $?; syscall(syspchar, v)
goto l
]
]
and ReadSequential(stream,wd,ct) be
[
sysac!0 = wd lshift 1
sysac!1 = ct lshift 1
sysac!2 = stream>>STREAM.channel
let err = syscall(sysrds,sysac)
unless err return
syscallerror(sysrds,sysac)
]
and WriteSequential(stream,wd,ct) be
[
sysac!0 = wd lshift 1
sysac!1 = ct lshift 1
sysac!2 = stream>>STREAM.channel
let err = syscall(syswrs,sysac)
unless err return
syscallerror(syswrs,sysac)
]
and ReadWord(stream) = valof
[
let w = nil
ReadSequential(stream,(lv w),1)
resultis w
]
and WriteWord(stream,w) be
WriteSequential(stream,(lv w), 1)
and dospointer(bcplname, dosname) = valof
[
Movestring(bcplname, dosname)
let n = dosname!0 rshift 8
if (n & 1) eq 1 do dosname!(n/2+1) = 0
resultis (dosname lshift 1)+1
]
and OpenInput(name) = valof
[
if name eq 0 resultis -1
if name!0 eq 0 resultis -1
resultis newstream(name, readact)
]
and OpenOutput(name) = valof
[
if name eq 0 resultis -1
if name!0 eq 0 resultis -1
let dosname = FileNameLength; Dvec(OpenOutput, lv dosname)
sysac!0 = dospointer(name, dosname)
let deleteerr = syscall(sysdelete, sysac)
if deleteerr unless deleteerr eq #12 do
[ Ostream = TTOstream
WriteS("ERROR : CAN'T DELETE FILE *""); WriteS(name)
WriteS("*"*n")
finish
]
let createerr = syscall(syscreate, sysac)
if createerr do
[ Ostream = TTOstream
WriteS("ERROR : CAN'T CREATE FILE *""); WriteS(name)
WriteS("*"*n")
finish
]
resultis newstream(name, writeact)
]
and OpenTemp(ch, inputflag; numargs nargs) = valof
[
if nargs eq 1 then inputflag = false
let name = FileNameLength/2; Dvec(OpenTemp,lv name)
Unpackstring("$$$.B0", filename)
filename!(filename!0) = ch
FixFileName(name, "", "")
let channel = inputflag? OpenInput(name), OpenOutput(name)
resultis channel
]
and Reposition(stream, pos) be
[
let channel = nil
if stream ls 0 return
flushbuffer(stream)
if Position(stream) eq pos then return
channel = stream>>STREAM.channel
unless 0 le channel & channel le 7 then return
let bloknum = (pos rshift 1) / 255
let bytenum = pos - ((bloknum * 255) lshift 1)
let v = #430
let t = v!channel
t!#25 = bytenum
t!#24 = bloknum
t!#17 = t!#17 % #4 //set "first write" bit in status word
test stream>>STREAM.action eq writeact
then stream>>STREAM.max = maxbyteindex
or readbuffer(stream)
]
and ResetStream(channel) be Reposition(channel, 0)
and IsFile(name) = valof
[
let dosname = FileNameLength; Dvec(IsFile,lv dosname)
sysac!0 = dospointer(name, dosname)
sysac!1 = sysac!0
let err = syscall(sysrename, sysac)
resultis err ne #12
]
and InitToRead(stream) be
[
if stream>>STREAM.action eq readact then return
flushbuffer(stream)
readbuffer(stream)
]
and openfile(bcplname) = valof
[
let dosname = FileNameLength; Dvec(openfile,lv dosname)
if bcplname eq 0 resultis -1
if bcplname!0 eq 0 resultis -1
let channel = 7
let v = #430 //DOS channel table in page one
for i = 0 to 7 do
if (v!i & #100000) ne 0 do [ channel = i; break ]
sysac!0 = dospointer(bcplname, dosname)
sysac!1 = 0
sysac!2 = channel
let err = syscall(sysopen, sysac)
if err then channel = sysac!2 + #1000
let s = 0
for i = 0 to 7 do // there are seven channels possobile
[
if streamvec!i ls 0 loop
s = streamvec!i
streamvec!i = s + #100000
break
]
if s eq 0 then [ WriteS("can't open ")
WriteS(bcplname)
Error("--out of streams")
]
s>>STREAM.channel = channel
s>>STREAM.max = maxbyteindex
resultis s
]
and closechannel(stream) be
[
if stream eq -1 return
flushbuffer(stream)
sysac!2 = stream>>STREAM.channel
let err = syscall(sysclose, sysac)
if err do
syscallerror(sysclose, sysac, stream)
returnstream(stream)
]
and newstream(name, action) = valof
[
let s = openfile(name)
if s>>STREAM.channel gr #1000 do
[
Ostream = TTOstream
let m = s>>STREAM.channel eq #1012 ?
"ERROR : NO FILE NAMED *"" ,
s>>STREAM.channel eq #1021 ?
"ERROR : NO FREE CHANNEL FOR *"" ,
"ERROR : CAN'T OPEN FILE *""
WriteS(m); WriteS(name); WriteS("*"*n")
finish
]
s>>STREAM.action = action
s>>STREAM.count = 0
test action eq readact
ifso readbuffer(s)
ifnot s>>STREAM.max = maxbyteindex
resultis s
]
and returnstream(stream) be
[
for i = 0 to 7 do
[
if (streamvec!i & #77777) eq stream then
[
streamvec!i = stream
return
]
]
Error("can't return stream")
]
and flushbuffer(stream) be
[
if stream>>STREAM.action eq writeact then
[
if (stream>>STREAM.count ne 0) then
bufferio(stream, syswrs, stream>>STREAM.count )
]
stream>>STREAM.count = 0
stream>>STREAM.max = maxbyteindex
]
and readbuffer(stream) be
[
bufferio(stream, sysrds, maxstreambytes)
stream>>STREAM.max = sysac!1 -1
stream>>STREAM.count = 0
stream>>STREAM.action = readact
]
and displaystream(s) be
[
WriteS("*NDisplay a stream...*N")
for i = 0 to (offset STREAM.bytebuffer+15)/16 do WriteO(s!i)
WriteS("*N")
]
and Overlay(name, loc) be
[
let s = openfile(name) //circumvent "OpenInput" because we don't
// want io buffered for us
let ch = s>>STREAM.channel
let h = vec 15
sysac!0 = h lshift 1
sysac!1 = 32
sysac!2 = ch
syscall(sysrds, sysac)
sysac!0 = loc lshift 1
sysac!1 = h!1 lshift 1
sysac!2 = ch
syscall(sysrds, sysac)
let n = nil
sysac!0 = lv n lshift 1
sysac!1 = 2
sysac!2 = ch
syscall(sysrds, sysac)
let p =vec 1
for i = 1 to n do
[ sysac!0 = p lshift 1
sysac!1 = 4
sysac!2 = ch
syscall(sysrds, sysac)
@(p!0) = p!1 + loc
]
closechannel(s)
]
and ReadCOMCM() be
[ //read the next name and switch list from COM.CM
static [ cstream = #100000 ]
if cstream eq #100000 do cstream = OpenInput("COM.CM")
let i = 1
[ Readch(cstream, lv filename!i)
if filename!i eq 0 break
if i gr FileNameLength do Error("BAD FILE NAME")
if filename!i eq #377 do
[ CloseInput(cstream)
filename!0 = -1
cstream = #100000 ///*DCS* so can re-read in LEX
return
]
i = i + 1
] repeat
filename!0 = i-1
let s = nil
let i, j = 0, 0
for k = 1 to 4 do
[ Readch(cstream, lv s)
for l = 1 to 8 do
[ if (s & #200) ne 0 do
[ j = j + 1
sw!j = i + $A
]
i = i + 1
s = s lshift 1
]
]
sw!0 = j
]
and InitFree(max) be
[ FreelistP = max
rv zframemax = max
]
and Newvec(n) = valof
[ let v = FreelistP - n
if v ls lv v do
[ rv zframemax = rv zframemax + 1000
Error("OUT OF FREE STORAGE -- PROGRAM IS TOO BIG")
]
FreelistP = v - 1
rv zframemax = v
resultis v
]
and Dvec(rout,lvN) be
[ let rslt = (lv rout)-4
let FSO() be [ let v = vec 31000; v = v ]
let newMax = rslt + @lvN + 1
if newMax > @zframemax then FSO()
@zframenext = newMax
@lvN = rslt
//***!!! This will stop working if RETURN code is changed
rslt = (@zreturn)+1 // bypass resetting zframenext
rslt() // returns
]