// SwatExp.bcpl - expression evaluator
// Copyright Xerox Corporation 1979, 1982
// Last modified March 21, 1982 1:39 PM by Boggs
// All you do is just...08/04/73 (alb)
get "Swat.decl"
external
[
// outgoing procedures
InitExp; Exp
// incoming procedures
SymToAddr; VMFetch; ReportFail
StoreVec; Allocate
// outgoing statics
ARGS; NARGS; ALTFLG; ALTFLG2
// incoming statics
sysZone
openCell; openFrame
]
static
[
ARGS; NARGS; ALTFLG; ALTFLG2
LkupStr // holds raw Characters read
Char // holds current Character
Lchar
Charno
Ostk; Astk; StrBuf; ComBuf
TkNxtChFlg; NoDigFlg; SymRdFlg; OctRdFlg
]
structure Stack:
[
ub word
ptr word
entry↑1,1 word
]
structure SStack: //String Stack
[
ub word //note that ptr plus entry is a BCPL string!
ptr byte
entry↑1,1 byte
]
structure [ LH byte; RH byte 1 ]
//---------------------------------------------------------------------------
let InitExp() be
//---------------------------------------------------------------------------
[
ARGS = Allocate(sysZone, 17)
LkupStr = Allocate(sysZone, 64); LkupStr>>SStack.ub = 125
StrBuf = Allocate(sysZone, 64); StrBuf>>SStack.ub = 125
Ostk = Allocate(sysZone, 64); Ostk>>Stack.ub = 62
Astk = Allocate(sysZone, 64); Astk>>Stack.ub = 62
]
//---------------------------------------------------------------------------
and StkRst(stknm) be stknm>>Stack.ptr = 0
//---------------------------------------------------------------------------
//---------------------------------------------------------------------------
and Push(value, stknm) be
//---------------------------------------------------------------------------
[
let t = stknm>>Stack.ptr
if t eq stknm>>Stack.ub do ReportFail("Exp stack overflow")
t = t +1
stknm>>Stack.entry↑t = value
stknm>>Stack.ptr = t
]
//---------------------------------------------------------------------------
and Pop(addr, stknm) = valof
//---------------------------------------------------------------------------
[
let t = stknm>>Stack.ptr
if t eq 0 resultis false
@addr = stknm>>Stack.entry↑t
stknm>>Stack.ptr = t-1
resultis true
]
//----------------------------------------------------------------------------
and SStkRst(sstknm) be sstknm>>SStack.ptr = 0
//----------------------------------------------------------------------------
//----------------------------------------------------------------------------
and SPush(char, sstknm) be
//----------------------------------------------------------------------------
[
let t = sstknm>>SStack.ptr
if t eq sstknm>>SStack.ub then ReportFail("String stack overflow")
t = t +1
sstknm>>SStack.entry↑t = char
sstknm>>SStack.ptr = t
]
//----------------------------------------------------------------------------
and SPop(addr, sstknm) = valof
//----------------------------------------------------------------------------
[
let t = sstknm>>SStack.ptr
if t eq 0 resultis false
@addr = sstknm>>SStack.entry↑t
sstknm>>SStack.ptr = t-1
resultis true
]
//---------------------------------------------------------------------------
and GetCh() be
//---------------------------------------------------------------------------
[
Charno = Charno +1
Lchar = Char
Char = ComBuf!Charno
]
//---------------------------------------------------------------------------
and GetVal(s) = valof
//---------------------------------------------------------------------------
[
if @s eq @"." resultis openCell
if @s eq @"$" resultis openFrame
if NoDigFlg eq 0 then //convert string to octal num
[
let val = 0
for i = 1 to s>>String.length do
val = (val lshift 3) + (s>>String.char↑i-$0)
resultis val
]
if NoDigFlg eq 1 & Lchar eq $. then //convert string to decimal num
[
@s = @s-400b //remove $.
let val = 0
for i = 1 to s>>String.length do
val = val*10 + (s>>String.char↑i-$0)
resultis val
]
resultis SymToAddr(s)
]
//---------------------------------------------------------------------------
and Op(char) = selecton char into
//---------------------------------------------------------------------------
[
case $!: true; case $": true; case $#: true; case $%: true
case $&: true; case $': true; case $(: true; case $**: true
case $+: true; case $-: true; case $@: true; case $\: true
case $*140: true; case $|: true; case $~: true
default: false
]
//---------------------------------------------------------------------------
and UnOp(char) = selecton char into
//---------------------------------------------------------------------------
[
case $": true; case $#: true; case $(: true; case $+: true
case $-: true; case $@: true; case $~: true
default: false
]
//---------------------------------------------------------------------------
and Prec(char, unopflg) = selecton char into
//---------------------------------------------------------------------------
[
case $!: #167; case $": #177; case $#: #177; case $%: #127
case $&: #133; case $': #123; case $(: #177; case $**: #157
case $+: unopflg? #163, #153
case $-: unopflg? #163, #153
case $@: #163; case $\: #157; case $*140: #123
case $|: #157; case $~: #137
default: #377
]
//---------------------------------------------------------------------------
and Apply(fun) be
//---------------------------------------------------------------------------
[
let t1, t2 = nil, nil
Pop(lv t1, Astk)
Push(selecton fun & 377B into
[
case $!: VMFetch(t1 & Pop(lv t2, Astk) + t2)
case $%: (t1 & Pop(lv t2,Astk)) % t2
case $&: (t1 & Pop(lv t2,Astk)) & t2
case $': (t1 & Pop(lv t2,Astk)) xor t2
case $**: (t1 & Pop(lv t2,Astk))*t2
case $+: valof
[
if (fun & 177400B) eq (163B lshift 8) resultis t1
Pop(lv t2, Astk)
resultis t1 + t2
]
case $-: valof
[
if (fun & 177400B) eq (163B lshift 8) resultis -t1
Pop(lv t2, Astk)
resultis t2 - t1
]
case $/: valof [ Pop(lv t2, Astk); resultis t2/t1 ]
case $@: VMFetch(t1)
case $\: valof [ Pop(lv t2, Astk); resultis t2 rem t1 ]
case $*140: (t1 & Pop(lv t2, Astk)) eqv t2
case $|: valof
[
Pop(lv t2, Astk)
resultis t1 ls 0? t2 rshift -t1, t2 lshift t1
]
case $~: not t1
default: t1
], Astk)
]
//---------------------------------------------------------------------------
and Exp(n) = valof
//---------------------------------------------------------------------------
[
ComBuf = n // set up for GetCh
let t = 0
Exp3: //reset flags, variables, stacks
Char = -1
Charno = 0
NARGS = 0
TkNxtChFlg = false
NoDigFlg = false
ALTFLG = false
ALTFLG2 = false
SymRdFlg = false
OctRdFlg = false
StkRst(Ostk)
StkRst(Astk)
SStkRst(StrBuf)
SStkRst(LkupStr)
ARGS!0 = 0
Exp4: //main reading loop
GetCh()
if TkNxtChFlg then [ TkNxtChFlg = false; goto Exp5 ]
//ctl-Char?
if Char ge 40b & Char ne $? then
[ //no
ALTFLG = false
if ALTFLG2 do [ NARGS, ALTFLG2 = NARGS+1, false ] //2 alt's
goto Exp6
]
unless SymRdFlg goto Exp1 //yes
SymRdFlg = false
Push(GetVal(LkupStr+1), Astk)
SStkRst(LkupStr) //reset string-stack for next time
NoDigFlg = false
while Pop(lv t, Ostk) & ((t & 377B) ne $() do Apply(t)
unless (Ostk>>Stack.ptr eq 0) & (Astk>>Stack.ptr eq 1) goto Experr
NARGS = NARGS+1; Pop(lv (ARGS!NARGS), Astk)
ARGS!0 = ARGS!0 % (1 lshift NARGS)
//alt-mode?
if Char eq $*033 then
[ //yes
if ALTFLG do [ ALTFLG = true; goto Exp4 ] //2nd alt?
ALTFLG = true
goto Exp4
]
resultis Char
Exp5:
unless SymRdFlg do SymRdFlg = true
SPush(Char, LkupStr)
goto Exp4
Exp6:
if Char eq $. % Char eq $$ % Char eq $↑ % (Char le $9 & Char ge $0) %
(Char le $z & Char ge $a) % (Char le $Z & Char ge $A) then
[
if Char le $9 & Char ge $0 then
[ //dec-dig?
if OctRdFlg then
[
if Char ls $8 goto Exp5 //oct-dig
goto Experr
]
goto Exp5
]
if OctRdFlg goto Experr
NoDigFlg = NoDigFlg +1
goto Exp5
]
if OctRdFlg & (LkupStr>>SStack.ptr eq 0) goto Experr
SymRdFlg = false
if (Lchar eq -1) % Op(Lchar) % (Lchar eq $*033) then
[
unless UnOp(Char) & not Lchar eq $# goto Experr
if Char eq $" goto Exp7
if Char eq $# then [ OctRdFlg = true; goto Exp4 ]
Push(Char+Prec(Char, true) lshift 8, Ostk)
goto Exp4
]
if Lchar eq $) then
[
if (Char ne $+) & (Char ne $-) & UnOp(Char) goto Experr
goto Exp2
]
Push(GetVal(LkupStr+1), Astk)
OctRdFlg, NoDigFlg = false, false
SStkRst(LkupStr) //reset string-stack for next time
Exp2:
if Char eq $) then
[
Exp98:
Pop(lv t, Ostk); if (t & 377B) eq $( goto Exp4
Apply(t)
goto Exp98
]
Exp99: //If the op-stack is empty, or if the top of the op-stack is ")",
// or if the current character has greater operator precedence than
//the top of the op-stack, then we apply the current character
// as an operator; otherwise we apply the top of the op-stack.
if (Ostk>>Stack.ptr eq 0) %
((lv (Ostk>>Stack.entry↑(Ostk>>Stack.ptr)))>>RH eq $() %
(Prec(Char, false) gr (lv (Ostk>>Stack.entry↑(Ostk>>Stack.ptr)))>>LH) then
[
Push(Char+Prec(Char, false) lshift 8, Ostk)
goto Exp4
]
Pop(lv t, Ostk); Apply(t)
goto Exp99
Exp7:
GetCh()
if Char eq $** then
[
GetCh()
switchon Char into
[
case $": endcase
case $**: endcase
case $n: [ SPush($*N, StrBuf); Char = $*L; endcase ]
case $s: [ Char = $*S; endcase ]
case $t: [ Char = $*T; endcase ]
default: goto Experr
]
SPush(Char, StrBuf)
]
unless Char eq $" do [ SPush(Char, StrBuf); goto Exp7 ]
t = (StrBuf>>SStack.ptr)/2+1
Push(StoreVec(StrBuf+1, t), Astk)
SStkRst(StrBuf)
goto Exp4
Exp1:
if Op(Lchar) & (Lchar ne $") goto Experr
while Pop(lv t, Ostk) do [ if (t & 377B) eq $( goto Experr; Apply(t) ]
unless Astk>>Stack.ptr ls 2 goto Experr
NARGS = NARGS +1
unless Char eq $*033 do //Esc
[
unless Astk>>Stack.ptr eq 0 do
[
ARGS!0 = ARGS!0 % (1 lshift NARGS)
Pop(lv (ARGS!NARGS), Astk)
]
if ALTFLG do NARGS = NARGS -1
if ALTFLG2 do NARGS = NARGS -1
if (ARGS!0 & (1 lshift NARGS)) eq 0 do NARGS = NARGS -1
resultis Char
]
if ALTFLG do [ ALTFLG2 = true; goto Exp4 ]
ALTFLG = true
unless Astk>>Stack.ptr eq 0 do
[
ARGS!0 = ARGS!0 % (1 lshift NARGS)
Pop(lv (ARGS!NARGS), Astk)
]
goto Exp4
Experr: ReportFail("Bad expression")
]