// Micro Input Routines
// last edited March 12, 1981 10:36 AM
// Copyright Xerox Corporation 1979, 1981
get "micdecl.d"
get "streams.d"
get "altofilesys.d"
external // O.S.
[ OpenFile
Gets; Puts; Closes
GetCompleteFa; JumpToFa
FilePos; SetFilePos
DoubleAdd
MoveBlock; SetBlock; Zero
Noop
]
// Input stack structure
structure IR:
[ chain word
lbsym word
lblct word
lincnt word
cfa @CFA
name word 0
]
manifest lIR = size IR/16
manifest
[ minpt = #41 // lowest printing character
maxpt = #176 // highest printing character
ecEndOfFile = 1302
eofchar = -2 // dummy character for eof
trailerchar = #32 // Bravo trailer character
bssize = 30 // Bracket/paren stack size
]
// Static Storage
// Input stack
static [
@instk = 0 // input stack for INSERT
@stcct = 0 // backup char. count for current statement
]
let initin() be
// Initialize input variables
[ instk = 0
lbsym = 0
lblct = 0
lincnt = 1
stbuf = alloctemp(stbl+1)+1
stbend = stbuf+stbl
stbuf!-1 = endc
]
and inpush(filenm, fp; numargs na) = valof
// Push down the input stack and open the indicated file
// Return false if bad file.
[ let filename = vec filenamelength
copyfile(filename, filenm)
if na ls 2 then
[ fp = 0; filext(filename, filenm, "MC") ] // called from INSERT
if instk ne 0 then
[ GetCompleteFa(inchan, lv instk>>IR.cfa)
Closes(inchan)
]
inchan = OpenFile(filename, ksTypeReadOnly, charItem, verLatest, fp, inerr)
if inchan eq 0 then
[ if instk ne 0 then injump(instk)
resultis false
]
// Push an entry on the stack
let nw = (length(filename)+2) rshift 1
let rp = alloc(lIR+nw)
rp>>IR.chain = instk
MoveBlock(lv rp>>IR.name, filename, nw)
rp>>IR.lbsym = lbsym
rp>>IR.lblct = lblct
rp>>IR.lincnt = lincnt
instk = rp
lbsym = 0
lblct = 0
lincnt = 1
llstr("** FILE ")
lstr(filename)
lcrlf()
resultis true
]
and inpop() = valof
// Pop input stack. Return true if stack empty.
[ let rp = instk
if rp ne 0 then
[ Closes(inchan)
instk = rp>>IR.chain
]
if instk eq 0 then // nothing stacked
[ if rp ne 0 then dalloc(rp)
resultis true
]
injump(instk)
lbsym = rp>>IR.lbsym
lblct = rp>>IR.lblct
lincnt = rp>>IR.lincnt
llstr("** RETURN TO ")
lstr(lv instk>>IR.name)
lcrlf()
dalloc(rp)
resultis false
]
and injump(rp) be
// Reopen an input file and jump to a place in it
[ inchan = OpenFile(0, ksTypeReadOnly, charItem, 0, lv rp>>IR.cfa.fp, inerr)
if inchan eq 0 then error("CAN'T REOPEN FILE")
JumpToFa(inchan, lv rp>>IR.cfa.fa)
]
and inerr(st, ec) = valof
test ec eq ecEndOfFile
ifso resultis eofchar
ifnot error("ERROR READING INPUT FILE")
and readstat() = valof
// Read a statement, return false on eof
[ let fchar = nil // define first for assembly code
static [ @rswitch = 0; @rsloop; @bstk; @bstop ] // See initreadstat below
stbot = stbuf
sttop = stbuf
stlct, stcct = lincnt, 0
let bsptr = bstk
let lastsym = stbot
[ goto rsloop
//rsloop: fchar = Gets(inchan)
// stcct = stcct+1
// goto rswitch!fchar
let initreadstat(ucf) be
// Initialize readstat character dispatch
[ if rswitch eq 0 then
[ rswitch = alloctemp(#400-eofchar)-eofchar // eofchar is negative
rsloop = table[
0 // LDA 0 inchan
#6407 // JSR @Gets
1 // 1
#41004 // STA 0 fchar,2
0 // ISZ stcct
0 // LDA 3 rswitch
#117000 // ADD 0 3
#3400 // JMP @0,3
0 // Gets:
]
rsloop!0 = #20000+lv inchan
rsloop!4 = #10000+lv stcct
rsloop!5 = #34000+lv rswitch
rsloop!8 = Gets
SetBlock(rswitch, rschar, #400)
SetBlock(rswitch, rsskip, minpt)
SetBlock(rswitch+(maxpt+1), rsskip, #400-(maxpt+1))
rswitch!eofchar = rseof
rswitch!trailerchar = rstrailer
rswitch!$*N = rsnl
rswitch!$% = rspercent
rswitch!$( = rslpar
rswitch!$) = rsrpar
rswitch!$** = rsstar
rswitch!$: = rsdelim
rswitch!$; = rssemi
rswitch!$[ = rslbr
rswitch!$] = rsrbr
rswitch!$, = rsdelim
rswitch!$# = rsnosym
rswitch!$← = rsnosym
bstk = alloctemp(bssize+1)
@bstk = eofchar
bstop = bstk+bssize
]
SetBlock(rswitch+$a, (ucf? rsraise, rschar), $z-$a+1)
]
rstrailer: // Bravo trailer character
flush($*N, $*S)
rsnl: // *N
lincnt = lincnt+1
if sttop eq stbot then stlct, stcct = lincnt, 0
goto rsloop
rseof: // End of file
if sttop ne stbot then
[ errx("File ends with incomplete statement")
sttop = stbot
]
if inpop() then resultis false // end of top-level file
stlct, stcct = lincnt, 0
goto rsloop
rspercent: // %
flush($%, -1)
if sttop eq stbot then stlct, stcct = lincnt, 0
goto rsloop
rsstar: // *
fchar = Gets(inchan)
test fchar eq eofchar
ifso
[ ceoferr()
]
ifnot
test fchar ne cmtchar
ifso
[ flush($*N, fchar)
]
ifnot
// Look for sequence *cmtchar
[ flush($**, fchar)
fchar = Gets(inchan)
if fchar eq eofchar then
[ ceoferr()
break
]
if fchar eq cmtchar then
[ flush($*N, -1)
break
]
] repeat
if sttop eq stbot then stlct, stcct = lincnt, 0
goto rsloop
rslpar: // (
rslbr: // [
if bsptr eq bstop then
[ bserr("Too much nesting of () and []")
break
]
bsptr = bsptr+1
@bsptr = fchar
goto rsdelim
rsrpar: // )
if @bsptr ne $( then
[ bserr("Unmatched )")
break
]
bsptr = bsptr-1
goto rsdelim
rsrbr: // ]
if @bsptr ne $[ then
[ bserr("Unmatched ]")
break
]
bsptr = bsptr-1
goto rsdelim
rsdelim: // Symbol delimiter
[ let nc = sttop-lastsym
test (nc ge 2) & (@lastsym ge $A)
ifso
[ let ep = lookup(lastsym, nc)
if ep ne 0 then
[ @lastsym, lastsym!1 = ep-fstop, symc
sttop = lastsym+2
]
]
ifnot
if (@lastsym le $7) & (nc ne 0) & (@lastsym ge (nc eq 1? $0, $1)) & (nc le 6) then
[ let val = @lastsym-$0
for p = lastsym+1 to sttop-1 do
[ if (@p gr $7) % (@p ls $0) goto rnon
if (val & 160000b) ne 0 goto rnon // would overflow
val = val lshift 3 + @p-$0
]
@lastsym, lastsym!1 = val, numc
sttop = lastsym+2
rnon:
]
lastsym = sttop+1
goto rschar
]
rsnosym: // Suppress symbol lookup
lastsym = stbend
goto rschar
rsraise: // Raise lower-case letter
fchar = fchar+($A-$a)
rschar: // Normal character
test sttop gr stbend
ifso
[ errx("INPUT STATEMENT TOO LONG")
break
]
ifnot
[ @sttop = fchar
sttop = sttop+1
]
rsskip: // Non-printing character
goto rsloop
rssemi: // ;
if @bsptr ne eofchar then
bserr("Unmatched ( or [")
break
] repeat
tlbot = stbend
tltop = stbend
resultis true
]
and flush(marker, fchar) = valof
// Flush input stream until marker is detected.
// Increment stcct for each character skipped.
[ if fchar ls minpt then
[ if fchar eq trailerchar then
[ flush($*N, $*S)
fchar = $*N
]
if fchar eq $*N then lincnt = lincnt+1
if fchar eq eofchar then
[ ceoferr()
break
]
]
if fchar eq marker break
fchar = Gets(inchan)
stcct = stcct+1
] repeat
and ceoferr() be
errx("END OF FILE INSIDE COMMENT")
and bserr(str) be
[ errx(str)
flush($;, -1)
sttop = stbot
]
and printstat(outs) be
// Print the last statement read, by backing up inchan by stcct characters
// Remove Bravo trailers
[ let pos = vec 1
FilePos(inchan, pos)
let lastchar = -1
if stcct ne 0 then
[ let n0, n1 = -1, -stcct
DoubleAdd(pos, lv n0)
SetFilePos(inchan, pos)
let puts = Puts
for i = 1 to stcct do
[ lastchar = Gets(inchan)
switchon lastchar into
[ case trailerchar: puts = Noop; endcase
case $*N: puts = Puts; endcase
]
puts(outs, lastchar)
]
]
if lastchar ne $*N then Puts(outs, $*N)
]