{$IFDEF DEBUG} {$M 64000, 33000, 33000} {$ELSE} {$M 64000, 0, 0} {$ENDIF}

program ENVICALC ;

uses
  {$IFDEF DEBUG} Crt, {$ENDIF}
  {$IFDEF DPMI} JRS_EnvD {$ELSE} JRS_EnvU {$ENDIF},
  Dos ;


const EN = ' ENVICALC: ' ;
StkLen = 40 ;
Gen : integer = 8 { TS default } ;
Beg : byte = 1 ;
Len : byte = 255 ;
SFs : byte = 10 ;
Mon : boolean = false ;

var Scr : text ;

type S30 = string [30] ;


procedure Help ;
begin Writeln(Scr, EN,
    ' www.merlyn.demon.co.uk  >= 2002-04-14; see ENVICALC.TXT.',
    ^M^J' To do RPN Int32 calculations with Environment variables.') ;
  HALT end {Help} ;


procedure FAIL(const St : string ; const XC : word) ;
begin
  Writeln(Scr, ^I'Error ', XC, ': ', St, ' ; HALT.') ; HALT(XC) end {FAIL} ;


function GetLI(const St : S30) : longint ;
var J : integer ; F : longint ;
begin if St='' then begin GetLI := 0 ; EXIT end ;
  Val(St, F, J) ;
  if J<>0 then FAIL('GetLI: "' + St + '" is bad number', 2) ;
  GetLI := F end {GetLI} ;


type
StkNdx = 0..StkLen ;
Letter = 'A'..'Z' ;

const Narr = 99 ;
NStk : StkNdx = 0 ;
ToShift = SizeOf(longint)*(StkLen-1) ;


var
Stack : array [1..StkLen] of longint ;
Arr : array [-100..100] of longint { for # ], # [ } ;
Vars : array [letter] of longint { for ]x, [x } ;


procedure UnderTest(const C : char ; const N : StkNdx) ;
begin if NStk<N then FAIL('Stack Underflow at '+C, 7) end {UnderTest} ;


procedure OverTest ;
begin if NStk>StkLen then FAIL('Stack Overflow', 8) end {OverTest} ;


procedure Pop ;
begin UnderTest('p', 1) ;
  Move(Stack[2], Stack[1], ToShift) ;
  Dec(NStk) end {Pop} ;


procedure Push(const Q : longint) ;
begin
  Move(Stack[1], Stack[2], ToShift) ;
  Stack[1] := Q ; Inc(NStk) end {Push} ;


procedure PushVal(const St : S30) ;
var J : integer ; Q : longint ;
begin if St='' then Q := 0 else begin Val(St, Q, J) ;
    if J<>0 then FAIL('PushVal error in "'+St+'"', 9) end ;
  Push(Q) end {PushVal} ;


function LZn(const Q {>=0}: longint ; const n : byte) : S30 ;
var St : string [10] ;
begin Str(Q, St) ; while Length(St)<n do St := '0'+St ; LZn := St end {LZn} ;


function TOSstring(const C : char) : S30 ;
const Sign : array [boolean] of char = '-+' ;
begin UnderTest(C, 1) ;
  TOSstring := Copy(Sign[Stack[1]>=0]+LZn(Abs(Stack[1]), SFs), Beg, Len) ;
  end {TOSstring} ;


function Power(const A, B : longint) : longint ;
var K, Q : longint ;
begin Q := 1 ;
  for K := 1 to B do Q := Q*A {sub-optimal} ;
  Power := Q end {Power} ;


procedure LTrim(var St : string) ;
begin while (St>'') and (St[1]<=#32) do Delete(St, 1, 1) end {LTrim} ;


procedure DoAFile(const Name : PathStr) ; FORWARD ;


function DoAWord(const AWord : S30) : boolean ;
var Z : longint ; St : S30 ; {RO : string [2] ;}
Ostr : string ; Ch : char ; P, Status : byte ; J : StkNdx ;
begin DoAWord := false ;
  St := AWord ;

  if Mon then Write(Scr, EN, AWord, #32) ;

  Ch := St[1] ;

  if (Ch in ['0'..'9']) or ((Ch in ['+', '-', '$']) and (Length(St)>1)) then
    PushVal(St)

    else begin

    Delete(St, 1, 1) ;

    if St='' then

      case Ch of

      '+', '-', '*', '/', '%', '\', '^', '~' : begin UnderTest(Ch, 2) ;
        case Ch of
          '+' : Stack[2] := Stack[2]+Stack[1] ;
          '-' : Stack[2] := Stack[2]-Stack[1] ;
          '~' : Stack[2] := Abs(Stack[2]-Stack[1]) ;
          '*' : Stack[2] := Stack[2]*Stack[1] ;
          '/' : Stack[2] := Stack[2] div Stack[1] ;
          '%', '\' : Stack[2] := Stack[2] mod Stack[1] ;
          '^' : Stack[2] := Power(Stack[2], Stack[1]) ;
          end ;
        Pop end ;

      's' : begin UnderTest(Ch, 2) ;
        Z := Stack[2] ; Stack[2] := Stack[1] ; Stack[1] := Z end ;
      'd' : begin UnderTest(Ch, 1) ;
        Move(Stack[1], Stack[2], ToShift) ; Inc(NStk) end ;
      'a' : begin UnderTest(Ch, 1) ; Stack[1] := Abs(Stack[1]) end ;
      { 'r' : begin UnderTest(Ch, 1) ; Stack[1] := Trunc(Sqrt(Stack[1])) end ; }
      'n' : begin UnderTest(Ch, 1) ; Stack[1] := -Stack[1] end ;
      'g' : begin UnderTest(Ch, 1) ; Stack[1] := Stack[Stack[1]] end ;
      'i' : begin UnderTest(Ch, 1) ;
        if Stack[1]>0 then Stack[1] := +1 ;
        if Stack[1]<0 then Stack[1] := -1 ;
        end ;
      'p' : Pop ;

      ']' : begin UnderTest(Ch, 2) ; Arr[Stack[1]] := Stack[2] ; Pop ; Pop end ;
      '[' : begin UnderTest(Ch, 1) ; Stack[1] := Arr[Stack[1]] end ;

      'œ' : begin if not Mon then Write(Scr, EN, 'œ ') ;
        Write(Scr, '? ') ; Readln end ;
      '?' : Help ;

      '{', '=', '}' : begin Z := Stack[1] ; Pop ;
        case Ch of
          '=' : DoAWord := Z = 0 ;
          '{' : DoAWord := Z < 0 ;
          '}' : DoAWord := Z > 0 ;
          end ;
        end ;

      'T' : Write(#32, TOSstring(Ch)) ;


      else FAIL(Ch + ' is bad option', 1) ;
      end {Ch}

    else

      case Ch of



      '&' : if St[1] = 'n' then
        begin UnderTest(Ch, 1) ; Stack[1] := not Stack[1] end else
        begin UnderTest(Ch, 2) ;
        case St[1] of
          'a' : Stack[2] := Stack[2] and Stack[1] ;
          'o' : Stack[2] := Stack[2]  or Stack[1] ;
          'x' : Stack[2] := Stack[2] xor Stack[1] ;
          else ;
          end ;
        PoP end ;


      '{', '=', '}' : begin if Length(St)>1 then FAIL('"' + Ch+St + '"', 12) ;
        Z := Stack[1] ; Pop ;
        case Ord(Ch)*256+Ord(St[1]) of
          Ord('{')*256+Ord('=') : DoAWord := Z <= 0 ;
          Ord('{')*256+Ord('}') : DoAWord := Z <> 0 ;
          Ord('}')*256+Ord('=') : DoAWord := Z >= 0 ;
          else FAIL('"' + Ch+St + '"', 4) ;
          end ;
        end ;

      ']' : begin UnderTest(Ch, 1) ; Vars[UpCase(St[1])] := Stack[1] ; Pop end ;
      '[' : begin {UnderTest(Ch, 0)} Push(Vars[UpCase(St[1])]) end ;

      'E',
        'V' : begin Ostr := TOSstring(Ch) ;
        Environ(Gen, Put, St, Ostr, Status) ;
        if (Ch='E') or (Status<>0) then Writeln(Scr, ^I, St, '=', Ostr,
          ', Environ Status = ', Status, ', OK=', Status=0) ;
        if Status<>0 then FAIL('Environment write failed', 10) ;
        Pop end ;
      'P' : begin Writeln( 'SET ' + St + '=' + TOSstring(Ch)) ; Pop end ;
      'Q' : begin Writeln('@SET ' + St + '=' + TOSstring(Ch)) ; Pop end ;
      'R' : begin St := GetEnv(St) ;
        P := Pos('œ', St) ; if P>0 then St[P] := '=' ;
        Writeln(St + TOSstring(Ch)) end ;

      'T' : if St='^' then Writeln else
        if St>'' then Write(#32, St) ;

      'C' : begin
        Environ(Gen, Get, St, Ostr, Status) ;
        {} {$IFDEF DEBUG} Writeln(Scr, '*** C: Ostr="', Ostr, '"') ; {$ENDIF}
        if Status<>0 then Writeln(Scr, ^I, 'Environ Status = ', Status,
          ', OK=', Status=0 {, #32, St, '=', Ostr}) ;
        if Status<>0 then FAIL('Environment read failed', 11) ;
        PushVal(Ostr) end ;

      'D' : begin for P := 1 to Ord(St[1])-Ord('0') do begin
           Read(Z) ; Push(Z) end ;
           Readln end ;

      'B' : Beg := GetLI(St) ;
      'L' : Len := GetLI(St) ;
      'S' : SFs := GetLI(St) ;
      'X' : begin Mon := Odd(GetLI(St)) ;
        if Mon then Write(Scr, EN, AWord, #32) ;
        end ;

      'G' : Gen := GetLI(St) ;
      '@' : DoAFile(St) ;
      '!' : begin
        Environ(Gen, Get, St, Ostr, Status) ;
        {} {$IFDEF DEBUG} Writeln(Scr, '*** !: Ostr="', Ostr, '"') ; {$ENDIF}
        if Status<>0 then Writeln(Scr, ^I, 'Environ Status = ', Status,
          ', OK=', Status=0 {, #32, St, '=', Ostr}) ;
        if Status<>0 then FAIL('Environment read failed', 11) ;
        SwapVectors ; Exec(GetEnv('COMSPEC'), ' /C '+Ostr) ;
        SwapVectors end ;

      else FAIL(Ch + ' is bad option', 3) ;
      end {Ch} ;

    end ;

  if Mon then begin Write(Scr, ^I'stack (', NStk, ') ') ;
    for J := 1 to NStk do Write(Scr, #32, Stack[J]) ;
    Writeln(Scr) end ;

  OverTest ;
  end {DoAWord} ;


function DoALine(St : string) : boolean ; FORWARD ;


procedure DoParenthesis(var St : string) ;
var J, K : byte ;
begin K := 0 ;
  for J := 1 to Length(St) do begin
    if St[J]='(' then Inc(K) ;
    if St[J]=')' then Dec(K) ;
    if K=0 then begin
      while DoALine(Copy(St, 2, J-2)+#32) do ;
      Delete(St, 1, J) ;
      LTrim(St) ;
      EXIT end ;
    end ;
  FAIL('unbalanced ()', 6) ;
  end {DoParenthesis} ;


function DoALine(St : string) : boolean ;
var Temp : S30 ; Ix : byte ;
begin DoALine := true ;
  while (St>'') do begin
    LTrim(St) ; if St='' then EXIT ;
    if St[1]=';' then EXIT ;
    if St[1]='(' then begin DoParenthesis(St) end ;
    Ix := Pos(#32, St) ;
    if Ix=0 then Ix := 255 ;
    Temp := Copy(St, 1, Ix-1) ; Delete(St, 1, Ix) ;
    if Temp>'' {2002-04-13} then
      if DoAWord(Temp) then begin DoALine := false ; EXIT end ;
    end ;
  end {DoALine} ;


procedure DoAFile(const Name : PathStr) ;
var F : text ; St : string ; B : boolean ;
begin if Mon then Writeln(Scr, EN, 'open file ', Name) ;
  Assign(F, Name) ; Reset(F) ;
  while not EoF(F) do begin Readln(F, St) ;
    if Length(St)>254 then FAIL('line too long', 5) ;
    B := DoALine(St+#32) end ;
  if Mon then Writeln(Scr, EN, 'close file ', Name) ;
  Close(F) end {DoAFile} ;



var LM, Par : word ; ParS : string ; B : boolean ;

BEGIN ;
Assign(Scr, 'CON') ; Rewrite(Scr) ; { Writeln(Scr) ; }
{} {$IFDEF DEBUG}
{} LM := LastMode ;
{} TextMode(LM + Font8x8) ;
{} Writeln(Scr, EN, 'starting') ;
{} {$ENDIF}
if ParamCount=0 then Help ;
FillChar(Arr, SizeOf(Arr), 0) ;
FillChar(Vars, SizeOf(Vars), 0) ;
ParS := '' ;
for Par := 1 to ParamCount do ParS := ParS + ParamStr(Par) + #32 ;
B := DoALine(ParS) ;
{} {$IFDEF DEBUG}
{} TextMode(LM) ;
{} {$ENDIF}
if Mon then Writeln(Scr, EN, ' end.'^M^J) ;
Close(Scr) ;
END.