// ScanStrings.bcpl
// ScanInit(b,file) (b= vec SCANIlen). Sets up a scan
// control block, using specified file to read from.
// ScanClose() Closes current file.
// ScanSet(b) (b = vec SCANIlen) use this file for scanner.
// b is set up with ScanInit
// Returns old pointer, if any, so you may restore.
// Scan() => token identifier (numbers defined in scan.defs)
// ScanFor(token) scans to be sure next thing is "token"
// ScanUntil(token) scans until token detected
// (if token=RPAREN, must be at this "level")
// ScanBack(token) arranges to have next token be token
// ScanGiveID() returns pointer to string last scanned as ID.
// ScanCh() returns a single character from the file.
// ReadNumber(STR) parses a number in STR format
// result in FPAC 1; integer part is result of fcn
// will handle numbers up to 2↑16-1 (unsigned)
// PrintNumber(STR,num [,radix])
// PrintFloat(str,lvnum) Prints floating point number.
// StrEq(a,b) => true if two strings equal
// StrCop(f,t) copy STR f to STR t
// Type(STR) type string on terminal
// TypeIn(STR) get a string from the terminal, terminated by CR
// TypeForm(xxxxx)
// Types a formatted message. For each entry in the call,
// If it is not in the range 0-#177, type it as a string ptr.
// Otherwise if it is:
// 0 -- type carriage-return line feed
// 1 -- use the next entry as a string pointer to accept typein
// 2 -- print the next entry as a floating point number
// 3 -- Double precision (fixed,fraction)
// 4 -- Double integer
// 8,10 -- print the next entry as a number in corresonding
// radix
// default -- print it as a single character.
// ReadCom(str,sw) =res
// Reads command file and returns true if more
// there. STR will contain string; sw if present
// is a list of switches (sw!0= # of sw's)
// ReadComInit() starts it off
get "scanstrings.d"
get "streams.d"
// outgoing procedures
external
[
Scan
ScanFor
ScanUntil
ScanInit
ScanClose
ScanSet
ScanBack
ScanGiveID
ScanCh
ReadNumber
PrintNumber
PrintFloat
StrEq
StrCop
Type
TypeIn
TypeForm
ReadComInit
ReadCom
]
// outgoing statics
external
[
outstream //If non-zero, use for typing.
ScanSavedLetter
]
static
[
outstream
ScanSavedLetter
]
// incoming procedures
external
[
Scream //This is for reporting errors
//OS
Gets
Puts
Endofs
OpenFile
Closes
Wss
Zero
//FLOAT
FLD;FST;FTR;FLDI;FNEG;FAD;FSB;FML;FDV;FCM;FSN
FLDV;FSTV;FLDDP;FSTDP;DPAD;DPSB
//SDialog
// DlgInit
// DlgStr
]
// incoming statics
external
[
fpComCm
keys
dsp
]
// internal statics
static
[
coms
sc
]
// File-wide structure and manifest declarations.
structure STR: [
length byte
char↑1,255 byte
]
manifest strlen=10 //number of words
manifest [ DEL=#177
CONTROLA=1
BACKSPACE=$H-$A+1
]
// Procedures
let
//Scanner routines.
ScanInit(b,s) be [
Zero(b, SCANIlen)
let str=OpenFile(s, ksTypeReadOnly, 1)
if str eq 0 then Scream("File not found")
b>>SCANI.stream=str
]
and
ScanClose() be Closes(sc>>SCANI.stream)
and
Scan() = valof [
let ins=sc>>SCANI.stream
let lastch=sc>>SCANI.lastch
let ch=sc>>SCANI.backtoken
if ch ne 0 then
[
sc>>SCANI.backtoken=0
resultis ch
]
test lastch eq 0 then ch=Gets(ins) or ch=lastch
let idname=lv sc>>SCANI.idname
sc>>SCANI.lastch=0
[ if Endofs(ins) then resultis EOF
let c=getcharclass(ch)
switchon c into
[
case 0: //separator...
endcase
case 1: // left parenthesis.
if Endofs(ins) then resultis LPAREN
ch=Gets(ins)
if getcharclass(ch) eq 2 then resultis SNIL
sc>>SCANI.lastch=ch
resultis LPAREN
case 2: resultis RPAREN
case 3: [ // "
let cn=0
[ if Endofs(ins) then break
ch=Gets(ins)
if getcharclass(ch) eq 3 then break
cn=cn+1
idname>>STR.char↑cn=ch
] repeat
idname>>STR.length=cn
resultis STRING
]
case 4: resultis SLASH
case 5:
case 6: [ //Scan into an identifier.
let firstclass=c
let cn=0
[
ScanSavedLetter=ch
if $a le ch & ch le $z then ch=ch-$a+$A
cn=cn+1
idname>>STR.char↑cn=ch
if Endofs(ins) then break
ch=Gets(ins)
let c=getcharclass(ch)
if c ls 5 then break //out of bounds.
] repeat
idname>>STR.length=cn
sc>>SCANI.lastch=ch
let failflg=true //try number, but may not be one
if firstclass eq 5 then ReadNumber(idname,1,lv failflg);
resultis (failflg? ID,NUMBER)
]
case 7: resultis EQUAL
]
ch=Gets(ins)
] repeat
]
and
ScanFor(token) be [
let c=Scan()
if c ne token then Scream("Format")
]
and
ScanUntil(token) be [
let level=0
[
let c=Scan()
if c eq token then
[
if token ne RPAREN % level eq 0 then return
]
if c eq LPAREN then level=level+1
if c eq RPAREN then level=level-1
] repeat
]
and
ScanBack(token) be [
sc>>SCANI.backtoken=token
]
and
ScanSet(b) = valof [
let c=sc
sc=b
resultis c
]
and
ScanGiveID() = lv sc>>SCANI.idname
and
ScanCh() = valof
[
let ch=sc>>SCANI.lastch
sc>>SCANI.lastch=0
if ch then resultis ch
let ins=sc>>SCANI.stream
if Endofs(ins) then resultis EOF
ch=Gets(ins)
resultis ch
]
and
getcharclass(ch) = valof [
switchon ch into
[
case $*s: case $*l: case $*n: case #11:
resultis 0
case $(:
resultis 1
case $):
resultis 2
case $":
resultis 3
case $/:
resultis 4
case $-: case $.: case $0: case $1: case $2: case $3:
case $4: case $5: case $6: case $7: case $8: case $9:
resultis 5
case $=:
resultis 7
default:
resultis 6
]
]
and
//Number reading and printing....
ReadNumber (str,x,fail;numargs n) = valof [
// Read a number from str and return it in FPAC 1
// uses FPAC's 2,3,4
// Set @fail if it turns out not to be a number.
if n eq 1 then x=1
let a=nil
if n ls 3 then fail=lv a
@fail=false
let octn=0
let sign=false
FLDI(1,0); FLDI(4,10); FLDI(2,1)
let pseen=false
for i=x to str>>STR.length do
[
let ch=str>>STR.char↑i
test ch eq $. then pseen=true or
test ch eq $- then sign=not sign or
test $0 le ch & ch le $9 then
[
FLDI(3,ch-$0)
test pseen
ifso [ FDV(2,4); FML(3,2) ]
ifnot FML(1,4)
FAD(1,3)
octn=(octn lshift 3)+ch-$0
]
or
test ch eq $E then
[ //exponent...
let flg=nil
let s=vec 2; FST(1,s);
ReadNumber(str,i+1,lv flg)
if flg then [ @fail=true; break ]
let exp=FTR(1)
FLD(1,s)
FLDI(4,10)
while exp gr 0 do [ FML(1,4); exp=exp-1 ]
while exp ls 0 do [ FDV(1,4); exp=exp+1 ]
break
] or
test ch eq $Q then FLDI(1,octn) or
[
@fail=true
break //Don't try to parse any more
]
]
if @fail ne 0 & n ls 3 then Scream("ReadNumber: format")
if sign then FNEG(1)
resultis(FTR(1))
]
and
PrintNumber(str,n,radix,pos; numargs a) be [
if a ls 4 then str>>STR.length=0
if a ls 3 then radix=10
if n ls 0 then
[
n=-n
pb(str,$-)
]
printnumber2(str,n,radix)
]
and
printnumber2(str,n,radix) be [
let f=n/radix
if f ne 0 then printnumber2(str,f,radix)
pb(str,$0+(n rem radix))
]
and
PrintFloat(s,lvnum) be [
let v=vec 4*5
for i=1 to 4 do FSTV(i,v+4*i)
@s=0
FLD(1,lvnum)
let p=FSN(1)
test p eq 0 then pb(s,$0) or [ //Really work
if p eq -1 then [ FNEG(1); pb(s,$-) ]
FLDV(2,table [ 0; 1; #100000; 4 ]); //Fuzz1= 1+2E-9
FML(1,2) //n←fuzz1*number
FLDI(3,1);FLDI(2,10)
FLD(4,1) //number
p=0
while FCM(4,2) eq 1 do [ FDV(4,2); p=p+1 ]
while FCM(4,3) eq -1 do [ FML(4,2); p=p-1 ]
// 4 has number between 1 and 10, and p has power
FLD(3,table [ #031325; #163073 ]) //Fuzz2 = 5E-9
FML(3,1) //s←fuzz2 * n
let q=p
test p gr 7 % p ls -3 then p=0 or q=0
test p ls 0 then [ pb(s,$0); pb(s,$.)
for i=p to -2 do pb(s,$0)
for i=1 to -p do FDV(3,2) //s=s E P
] or [ for i=1 to p do FML(3,2) ]
//now print (s suppresses trailing zeroes)
for i=1 to 9 do [
let ipart=FTR(4)
pb(s,$0+ipart)
p=p-1
FLDI(1,ipart); FSB(4,1); FML(4,2)
if p ls 0 then [
if p eq -1 then pb(s,$.)
FML(3,2)
if FCM(4,3) eq -1 then break //fuzz
]
]
if q ne 0 then
[
pb(s,$E);
PrintNumber(s,q,10,nil)
]
] //Really work
for i=1 to 4 do FLDV(i,v+4*i)
]
and
pb(s,b) be [
let l=s>>STR.length+1
s>>STR.char↑l=b
s>>STR.length=l
]
and
//Type in and out routines.
TypeForm(m,nil,nil,nil,nil,nil,nil,nil,nil,nil,nil,nil; numargs n) be [
let lvm=lv m
let i=0; let str=vec 20
while i ls n do
[
let x=lvm!i
let i1=i+1
if (x𫗀) eq 0 then switchon x into
[
case 8:
case 10: i=i1
PrintNumber(str,lvm!i,x)
x=str
endcase
case 0: x="*N*L"
endcase
case 1: i=i1
TypeIn(lvm!i)
x=""
endcase
case 2: i=i1
PrintFloat(str,lvm!i)
x=str
endcase
case 3: case 4: [
i=i1
let v=vec 4
FSTV(1,v)
FLDDP(1,lvm!i)
if x eq 4 then
[
let s=vec 4
FSTV(1,s); s!1=s!1+16; FLDV(1,s)
]
PrintFloat(str,1)
FLDV(1, v)
x=str
endcase ]
default: str!0=x+#400
x=str
endcase
]
Type(x)
i=i+1
]
]
and
Type(str) be [
Wss(((outstream eq 0)? dsp, outstream), str)
]
and
TypeIn(str) be [
// DlgInit()
// DlgStr("", str)
let count=0
let ch = Gets(keys)
until ch eq $*N do
[ switchon ch into
[ case BACKSPACE: case CONTROLA:
[ if count eq 0 then endcase
Puts(dsp,$/);Puts(dsp,str>>STR.char↑count)
count = count - 1
endcase
]
case DEL: Type("XXX");count=0;endcase
default: count = count + 1
str>>STR.char↑count = ch
Puts(dsp,ch)
endcase
] //end of switchon
ch=Gets(keys)
] //end of wait for *n
str>>STR.length=count
Puts(dsp,$*n)
]
and
//String stuff
StrEq(a,b) = valof [
if a>>STR.length ne b>>STR.length then resultis false
for i=1 to a>>STR.length do
[ let c1=a>>STR.char↑i
let c2=b>>STR.char↑i
if (c1 ge $a)&(c1 le $z) then c1=c1+$A-$a
if (c2 ge $a)&(c2 le $z) then c2=c2+$A-$a
unless c1 eq c2 then resultis false
]
resultis true
]
and
StrCop(f,t) be [
for i=1 to f>>STR.length do t>>STR.char↑i=f>>STR.char↑i
t>>STR.length=f>>STR.length
]
and
//Command line reader and processor. Uses the main routine SCAN above.
ReadComInit() be [
coms=table [ 0;0;0;0;0;0;0;0;0;0;0;0;0;0 ]
compileif SCANIlen gr 14 then [ foo=nil ]
Zero(coms, SCANIlen)
coms>>SCANI.stream=OpenFile("Com.Cm", ksTypeReadOnly, 1, 0, fpComCm)
]
and
ReadCom(str,sw; numargs n) = valof [
if n eq 2 then sw!0=0
let old=ScanSet(coms)
let ans=valof
[
let c=Scan()
if c eq EOF then [ ScanBack(EOF); resultis 0 ]
if c eq ID % c eq NUMBER then
[
StrCop(lv coms>>SCANI.idname,str)
while coms>>SCANI.lastch eq $/ do
[ //switches
Scan() //To pick up /
Scan()
if n eq 2 then
[
let s=(lv coms>>SCANI.idname)
for i=1 to s>>STR.length do
[
sw!0=sw!0+1
sw!(sw!0)=s>>STR.char↑i
]
]
]
resultis c
]
Scream("Invalid command line")
]
ScanSet(old)
resultis ans
]