// 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")
]