
{$I VERSION - configure for TP7/BP7, Delphi, TMT}

{$IFDEF MSDOS} {$IFNDEF __TMT__} {$M 65520, 65536, 655360} {$ENDIF} {$ENDIF}
{$IFDEF DPMI} {$M 65520} {$ENDIF}
{$IFDEF BORPAS}{$IFNDEF VER70} Fail2! ; {$ENDIF}{$ENDIF}
{$IFNDEF DELPHI (I use D3: DCC32 -CC file)}
{}{$IFDEF WINDOWS} Fail1! ; {$ENDIF}
{$ENDIF}

{$B-} {$S+}
{$IFNDEF __TMT__ } {$N-,E-} {$ENDIF}
{$IFDEF DELPHI} {$H-} {$ENDIF}

{ RPN expression evaluation with vast integers - see end of file for more }

{$IFDEF PROGRAM} program {$ELSE} unit {$ENDIF} LONGCALC ;

{$IFNDEF PROGRAM} interface {$ENDIF}

  uses
  {$IFDEF PASCAL} Dos      {$ENDIF}
  {$IFDEF BORPAS}{$IFDEF MSDOS} , {TSUntEnv} JRS_EnvU {$ENDIF} {$ENDIF}
  {$IFDEF DELPHI} SysUtils, Windows {$ENDIF}
  ;

const
Cap1 = 'LONGCALC: ' ;
Cap2 = 'www.merlyn.demon.co.uk >= 2005-07-22' ;
Cap3 = ' compiled with ' +
  {$IFDEF __TMT__} 'TMT ' + {$ELSE} 'Borland ' + {$ENDIF}
  {$IFDEF DELPHI} 'Delphi.' {$ENDIF}
  {$IFDEF PASCAL} 'Pascal ' +
  {$IFDEF MSDOS} 'MSDOS' + {$ENDIF}
  {$IFDEF DPMI} 'DPMI' + {$ENDIF}
  ' mode.' {$ENDIF} ;

const
imax = {$IFDEF PASCAL} 65520 {$ENDIF} {$IFDEF DELPHI} 99999999 {$ENDIF} ;

type

TBytes = {$IFDEF PASCAL} word {$ENDIF} {$IFDEF DELPHI} longint {$ENDIF} ;
SgT = -1..1 ; idx = 0..imax ;
Figures = array [1..imax] of byte ;
Parr = ^Arr ;
{ "packed" needed for Delphi : }
Arr = packed record Magic : word ;
  Bytes : Tbytes ; Sg : SgT ; Sz : idx ; Ar : Figures end ;
Pstr = ^string ;

Datum = record Pad : char ;
  Case Sort : char of
  'a' : (Aptr : Parr) ;
  'b' : (Bvar : boolean) ;
  'q' : (Qvar : string [3]) ;
  't' : (Tptr : Pstr) ;
  end ;

PLET = ^ListElementType ;
ListElementType = record Next : PLET ; D : Datum end ;

QxT = '0'..'9' ;

var QA, QS, QM, QD, QR, QP : Parr ; QV : array [QxT] of Datum ;

{$IFNDEF PROGRAM}
function RPN(const St : string ; var SP : PLET) : boolean ;
function AtoL(const X : Parr ; var LI : longint) : boolean ;
function SgChar(const Sg : SgT) : char ;
function Sims(const B : byte) : char ;
{$ENDIF}

type
S40 = string [40] ; PS40 = ^S40 ;
TaskFunc = function (var SP : PLET) : boolean ;
OpT = record Cmnd : string [3] ; Task : pointer ; Proc : boolean ;
  Sk : string [12] ; PGen : PS40 ; Aid : string [30] end ;
PTList = ^TList ; OpTP = ^OpT ;
TList = record Next, Prev : PTList ; POpT : OpTP end ;

const
BList : PTList = NIL ;
Base : $02..$10 = 10 ;


{$IFNDEF PROGRAM}

implementation

{$IFDEF GUI} uses Dialogs, VastCalc1 ; {$ENDIF}

{$ENDIF}

const
MaxStr = {$IFDEF PASCAL} 255 {$ENDIF} {$IFDEF DELPHI}    65535 {$ENDIF} ;
SoB = 8 {bits/byte} ;

type
ShortArr = packed record Magic : word ;
  Bytes : Tbytes ; Sg : SgT ; Sz : idx ; Ar : array [1..1] of byte end ;
Sli = string [Succ(SizeOf(longint)*SoB)]
  { big enough for -MaxLongInt to minimum base} ;

const
Sfix = SizeOf(Arr)-imax ;

Sgns : array [SgT] of char = '-=+' ;
Sign = ['+', '-'] ;
Spc = #32 ;
Mrkr = $4762 { arbitrary word } ;

ConstOne : ShortArr
  = (Magic:Mrkr; Bytes:SizeOf(ShortArr); Sg:+1; Sz:1; Ar:(1)) ;
ConstZero : ShortArr
  = (Magic:Mrkr; Bytes:SizeOf(ShortArr); Sg: 0; Sz:0; Ar:(0)) ;
POne : Parr = Addr(ConstOne) ;
PZero : Parr = Addr(ConstZero) ;
Commas : boolean = true ;

var
CharSet : set of char ;
Syms : array [$0..$F] of char ;
Fo : text ;


{$IFDEF BORPAS}
function HeapFunc(Size : word) : integer { T4.343; BP7OLG.265 } ; FAR ;
begin HeapFunc := 1 { New & GetMem return NIL } end {HeapFunc} ;
{$ENDIF}



procedure Send(const S : string) ;
begin {$IFDEF GUI}
  with Form1.Console.Lines do Strings[Count-1] := Strings[Count-1] + S ;
  {$ELSE} Write(S) {$ENDIF} end {Send} ;


procedure Sendln ;
begin {$IFDEF GUI}
  with Form1.Console.Lines do begin
    if Count>40 then Delete(0) ;
    Append('') end ;
  {$ELSE} Writeln {$ENDIF} end {Sendln} ;


procedure WriteFo(const S : string) ;
begin {$IFDEF GUI}                               // needs upgrade for a file
    with Form1.Console.Lines do Strings[Count-1] := Strings[Count-1] + S ;
  {$ELSE} Write(Fo, S) {$ENDIF} end {WriteFo} ;


procedure WritelnFo ;
begin {$IFDEF GUI}                               // needs upgrade for a file
    with Form1.Console.Lines do begin
    if Count>40 then Delete(0) ;
    Append('') end ;
  {$ELSE} Writeln(Fo) {$ENDIF} end {WritelnFo} ;



function Garr(var P : Parr ; const S : TBytes) : boolean ;
begin Garr := false ; GetMem(P, S) ;
  if P=NIL then begin Send(' Heap: in Garr,') ; EXIT end ;
  P^.Bytes := S ; P^.Magic := Mrkr ; Garr := true end {Garr} ;


function Farr(var P : Parr) : boolean ;
begin Farr := false ;
  if P<>NIL then with P^ do begin
    if Magic<>Mrkr then begin Send(' Farr: Magic<>Mrkr') ; EXIT end ;
    Magic := Mrkr xor $FFFF ;
    FreeMem(P, Bytes) ; P := NIL ;
    end ;
  Farr := true end {Farr} ;


function Carr(const Src : Parr ; var Dst : Parr) : boolean ;
var PA : PArr {lest Src=Dst} ; const S = ' in Carr,' ;
begin Carr := false ;
  if Src=NIL then begin Send(' Carr(NIL,),') ; EXIT end ;
  if not Garr(PA, Sfix+Src^.Sz) then begin Send(S) ; EXIT end ;
  Move(Src^.Sg, PA^.Sg, SizeOf(SgT)+SizeOf(idx)+Src^.Sz) ;
  if not Farr(Dst) then begin Send(S) ; EXIT end ;
  Dst := PA ; Carr := true end {Carr} ;


function NewZero(var P : Parr) : boolean ;
begin NewZero := false ; GetMem(P, SizeOf(ConstZero)) ;
  if P=NIL then begin Send(' Heap: in NewZero,') ; EXIT end ;
  Move(ConstZero, P^, SizeOf(ConstZero)) ;
  NewZero := true end ;


procedure SetCharSet ;
var b : byte ;
begin CharSet := [','] ; Syms := '0123456789ABCDEF' ;
  for b := 0 to Pred(Base) do Include(CharSet, Syms[b]) ;
  for b := Base to $0F do Syms[b] := 'í' ;
  end {SetCharSet} ;


procedure More ;
begin {$IFDEF GUI} Sendln ; ShowMessage('See Console') ;
  {$ELSE} Send(' <cr>') ; Readln {$ENDIF} end {More} ;


function Sims(const B : byte) : char ;
begin if B<Base then Sims := Syms[B] else Sims := '?' end ;


function Check(const Place : string ; const Z : Parr) : boolean ;
{} function BadCh(const Z : Parr) : boolean ;
{} var K : word ;
{} begin BadCh := true ;
  {} with Z^ do for K := 1 to Sz do if Ar[K]>=Base then EXIT ;
  {} BadCh := false end ;
var J : word ; S : string [20] ; S10 : string [10] ; S2 : string [2] ;
begin Check := false ;
  if Z=NIL then begin
    Send('  ** Check: Nil Pointer after "'+Place+'"') ; EXIT end ;
  with Z^ do begin
    if Magic<>Mrkr then begin
      Send('  ** Check: Magic<>Mrkr after "'+Place+'"') ; EXIT end ;
    S := '' ;
    if Abs(shortint(Sg))>1 then S := 'Sign' else
      if Sz<0 then S := 'Sz<0' else
      if Sz>imax then S := 'Sz>imax' else
      if Sfix+Sz>Bytes then S := 'Sfix+Sz>Bytes' else
      if (Sz=0) xor (Sg=0) then S := 'Sz xor Sg' else
      if (Sz>0) and (Ar[Sz]=0) then S := 'Bad 0' else
      if BadCh(Z) then S := 'Bad digit' ;

    if S>'' then begin Str(Sz, S10) ; Str(Sg, S2) ;
      Send('  ** Check: bad number (' + S + '); ' +
        Place + ' is' + ' Sz=' + S10 + ' Sg=' + S2) ;
      if Sz>0 then Send(' Ar=') ;
      for J := Sz downto 1 do Send(Sims(Ar[J])) ;
      Str(Bytes, S10) ; Send(', By=' + S10) ; Sendln ; EXIT end ;
    end ;
  Check := true end {Check} ;


procedure Trim(var Z : Parr) ;
begin with Z^ do begin
    while (Sz>0) and (Ar[Sz]=0) do Dec(Sz) ;
    if Sz=0 then Sg := 0 ;
    end end {Trim} ;


function StoA(const St : string ; var A : Parr) : boolean ;
var PA : Parr ; B : word ; Ch : char ; S10 : string [10] ;
const S = ' in StoA,' ;
begin StoA := false ;
  if not Garr(PA, Sfix+MaxStr) then begin Send(S) ; EXIT end ;
  with PA^ do begin Sz := 0 ; Sg := +1 ;
    for B := Length(St) downto 1 do begin Ch := UpCase(St[B]) ;
      if B=1 then
        if Ch in Sign then begin Sg := 44-Ord(Ch) ; BREAK end ;
      if not (Ch in CharSet) then begin Str(B, S10) ;
        Send(' StoA: bad char "' + St[B] + '" at ' + S10 + ',') ;
        if not Farr(PA) then Send(S) ;
        EXIT end ;
      if Ch=',' then CONTINUE ;
      if Sz=imax then begin Str(imax, S10) ;
        Send(' StoA: more than ' + S10 + ' digits,') ;
        if not Farr(PA) then Send(S) ;
        EXIT end ;
      Inc(Sz) ; Ar[Sz] := Pred(Pos(Ch, Syms)) ;
      end {B} ;
    end {PA} ;
  if not Farr(A) then begin Send(S) ; EXIT end ;
  Trim(PA) ; if not Check('StoA', PA) then EXIT ;
  A := PA ; StoA := true end {StoA} ;


function StrF(const L : longint) : Sli ;
function S(const L : longint) : Sli ;
begin if L=0 then S := '' else S := S(L div Base)+Syms[L mod Base] end {S} ;
begin if L=0 then StrF := '0' else
    if L<0 then StrF := '-'+S(-L) else StrF := S(L) end {StrF} ;


function LtoA(const L : longint ; var A : Parr) : boolean ;
begin LtoA := StoA(StrF(L), A) end {LtoA} ;


function SgChar(const Sg : SgT) : char ;
begin if Abs(Sg)>1 then SgChar := 'ñ' else SgChar := Sgns[Sg] end {SgChar} ;


procedure WrtA(const A : Parr) ; FAR ;
var j : idx ;
begin with A^ do begin
    if Sg=0 then WriteFo('0') else begin WriteFo(SgChar(Sg)) ;
      if Sz=0 then WriteFo('o') else
        for j := Sz downto 1 do begin WriteFo(Sims(Ar[j])) ;
        if Commas then if j mod 3 = 1 then if j>1 then WriteFo(',') ;
        end {j} ;
      end ;
    end ;
  WriteFo(Spc) end {WrtA} ;


procedure Short(const A : Parr) ; FAR ;
var S10 : string [10] ;
begin with A^ do begin
    if Sg=0 then WriteFo('0') else begin WriteFo(SgChar(Sg)) ;
      if Sz=0 then WriteFo('o') else begin WriteFo(Sims(Ar[Sz])) ;
        if Sz>1 then begin Str(Sz-1, S10) ;
          WriteFo('.' + Sims(Ar[Sz-1]) + 'e' + S10) end ;
        end ;
      end ;
    end ;
  WriteFo(Spc) end {Short} ;


procedure Negate(var A : Parr) ;
begin with A^ do Sg := -Sg end {Negate} ;


function Ucomp(const X, Y : Arr) : SgT ;
var J : idx ;
begin UComp := 0 ;
  if X.Sz>Y.Sz then UComp := +1 else if X.Sz<Y.Sz then UComp := -1
    else for J := X.Sz downto 1 do begin
    if X.Ar[J]>Y.Ar[J] then begin UComp := +1 ; BREAK end ;
    if X.Ar[J]<Y.Ar[J] then begin UComp := -1 ; BREAK end ;
    end {J} ;
  end {Ucomp} ;


function Scomp(const X, Y : Arr) : SgT ;
begin
  if X.Sg>Y.Sg then Scomp := +1 else if X.Sg<Y.Sg then Scomp := -1 else
    Scomp := Ucomp(X, Y)*X.Sg end {Scomp} ;


function Max(const A, B : longint) : longint ;
begin if A>B then Max := A else Max := B end {Max} ;


function Sum(const X, Y : Arr ; var Z : Parr) : boolean ;
var PA : PArr ; Z_Sz : longint ; Carry, Digit : byte ; J : idx ;
const S = ' in Sum,' ;
begin Sum := false ;
  if X.Sg<>Y.Sg then RunError(222) ;
  Z_Sz := Max(X.Sz, Y.Sz)+1 ;
  if not Garr(PA, Sfix+Z_Sz) then begin Send(S) ; EXIT end ;
  PA^.Sg := X.Sg ; PA^.Sz := X.Sz ; Carry := 0 ;
  for J := 1 to Z_Sz do begin Digit := Carry ;
    if J<=X.Sz then Inc(Digit, X.Ar[J]) ;
    if J<=Y.Sz then Inc(Digit, Y.Ar[J]) ;
    Carry := Ord(Digit>=Base) ; if boolean(Carry) then Dec(Digit, Base) ;
    PA^.Ar[J] := Digit ;
    if (J>=X.Sz) and (J>=Y.Sz) and (Carry=0) then
      begin PA^.Sz := J ; BREAK end ;
    end {J} ;
  if Carry>0 then begin Send(' "Sum": overflow,') ; EXIT end ;
  if not Farr(Z) then begin Send(S) ; EXIT end ;
  Trim(PA) ; if not Check('Sum', PA) then EXIT ;
  Z := PA ; Sum := true end {Sum} ;


function Dif(const X, Y : Arr ; var Z : Parr) : boolean ;
var PA : PArr ; Borrow, Digit : shortint ; J : idx ;
const S = ' in Dif,' ;
begin Dif := false ;
  if X.Sg<>Y.Sg then RunError(223) ;
  if not Garr(PA, Sfix+X.Sz) then begin Send(S) ; EXIT end ;
  PA^.Sg := X.Sg ; Borrow := 0 ;
  for J := 1 to X.Sz do begin
    Digit := X.Ar[J] - Borrow ;
    if J<=Y.Sz then Dec(Digit, Y.Ar[J]) ;
    Borrow := Ord(Digit<0) ; if boolean(Borrow) then Inc(Digit, Base) ;
    if Digit>0 then PA^.Sz := J ;
    PA^.Ar[J] := Digit end {J} ;
  if not Farr(Z) then begin Send(S) ; EXIT end ;
  Trim(PA) ; if not Check('Dif', PA) then EXIT ;
  Z := PA ; Dif := true end {Dif} ;


function Sub(const X, Y : Arr ; var Z : Parr) : boolean ;
var Cf : SgT ; const S = ' in Sub,' ;
begin Sub := false ;
  Cf := Scomp(X, Y) ;
  if Cf=0 then begin
    if Carr(PZero, Z) then Sub := true else Send(S) ;
    EXIT end ;
  case Cf=X.Sg of
    true  : if not Dif(X, Y, Z) then begin Send(S) ; EXIT end ;
    false : begin if not Dif(Y, X, Z) then begin Send(S) ; EXIT end ;
      Negate(Z) end ;
    end ;
  Sub := true end {Sub} ;


function Minus(const X, Y : Arr ; var Z : Parr) : boolean ; FAR ;
var PY : Parr ; const S = ' in Minus,' ;
begin Minus := false ;
  if Y.Sg=0 then begin
    if Carr(@X, Z) then Minus := true else Send(S) ;
    EXIT end ;
  if X.Sg=0 then begin
    if Carr(@Y, Z) then begin Negate(Z) ; Minus := true end else Send(S) ;
    EXIT end ;
  case X.Sg=Y.Sg of
    true  : if not Sub(X, Y, Z) then begin Send(S) ; EXIT end ;
    false : begin PY := NIL ;
      if not Carr(@Y, PY) then begin Send(S) ; EXIT end ;
      Negate(PY) ;
      if not (Sum(X, PY^, Z) and Farr(PY)) then begin Send(S) ; EXIT end ;
      end ;
    end ;
  Minus := true end {Minus} ;


function Plus(const X, Y : Arr ; var Z : Parr) : boolean ; FAR ;
var PY : Parr ; const S = ' in Plus,' ;
begin Plus := false ;
  if Y.Sg=0 then begin
    if Carr(@X, Z) then Plus := true else Send(S) ;
    EXIT end ;
  if X.Sg=0 then begin
    if Carr(@Y, Z) then Plus := true else Send(S) ;
    EXIT end ;
  case X.Sg=Y.Sg of
    true  : if not Sum(X, Y, Z) then begin Send(S) ; EXIT end ;
    false : begin PY := NIL ;
      if not Carr(@Y, PY) then begin Send(S) ; EXIT end ;
      Negate(PY) ;
      if not (Sub(X, PY^, Z) and Farr(PY)) then begin Send(S) ; EXIT end ;
      end ;
    end ;
  Plus := true end {Plus} ;


function Times(const X, Y : Arr ; var Z : Parr) : boolean ;
{ This is standard manual method; there are faster ones, for large numbers,
  in ALGORITHMICS by Brassard & Bratley, ISBN 0-13-023169-X (NML) }
const S = ' in Times,' ;
var PZ : PArr ; J, K : idx ; Z_Sz : longint ; Digit, Carry : byte ;
begin Times := false ;
  if (X.Sg=0) or (Y.Sg=0) then begin
    if Carr(PZero, Z) then Times := true else Send(S) ;
    EXIT end ;
  Z_Sz := Pred(longint(X.Sz)+Y.Sz) ;
  if Z_Sz>imax then begin Send(' Times: OverSize,') ; EXIT end ;
  J := X.Sz+Y.Sz ;
  if not Garr(PZ, Sfix+J) then begin Send(S) ; EXIT end ;
  with PZ^ do begin
    Sz := J ; Sg := X.Sg*Y.Sg ; FillChar(Ar[1], Sz, 0) ;
    for J := 1 to Y.Sz do begin Digit := Y.Ar[J] ;
      if Digit>0 then begin Carry := 0 ;
        for K := 1 to X.Sz do begin Inc(Carry, Digit*X.Ar[K] + Ar[J+K-1]) ;
          Ar[J+K-1] := Carry mod Base ; Carry := Carry div Base end {K} ;
        K := J+X.Sz-1 ;
        while Carry>0 do begin
          if K>=imax then begin Send(' Times: OverCarry,') ;
            if not Farr(PZ) then Send(S) ;
            EXIT end ;
          Inc(K) ; if K>Sz then Inc(Sz) ; Inc(Carry, Ar[K]) ;
          Ar[K] := Carry mod Base ; Carry := Carry div Base ;
          end {Carry>0} ;
        end {Digit>0} ;
      end {J} ;
    end ;
  if not Farr(Z) then begin Send(S) ; EXIT end ;
  Trim(PZ) ; if not Check('Times', PZ) then EXIT ;
  Z := PZ ; Times := true end {Times} ;


function Divd(const X, Y : Arr ; var Q, R : Parr) : boolean
  { R takes sign of X; otherwise, ignores both signs } ;
var PQ, PR : Parr ; AnsSiz, K, AnsIdx, YIdx : idx ; Borrow, Done : boolean ;
XD, YD, Ans : byte ; Digit : shortint ;
const S = ' in Divd,' ;
begin Divd := false ;
  AnsSiz := 1+X.Sz-Y.Sz ; PR := NIL ;
  if not (Garr(PQ, Sfix+AnsSiz) and Carr(@X, PR))
    then begin Send(S) ; EXIT end ;
  with PQ^ do begin Sz := AnsSiz ; Sg := +1 end ;

  with PR^ do for AnsIdx := AnsSiz downto 1 do begin Ans := 0 ;

    repeat Done := false ;
      for K := Sz downto AnsIdx do begin
        XD := Ar[K] ; YIdx := K-AnsIdx+1 ;
        if YIdx>Y.Sz then YD := 0 else YD := Y.Ar[YIdx] ;
        if XD>YD then begin Done := false ; BREAK end ;
        if XD<YD then begin Done := true ; BREAK end ;
        end ;
      if Done then BREAK ;
      Inc(Ans) ; Borrow := false ;
      for K := AnsIdx to Sz do begin
        Digit := Ar[K] - Ord(Borrow) ; YIdx := K-AnsIdx+1 ;
        if YIdx<=Y.Sz then Dec(Digit, Y.Ar[YIdx]) ;
        Borrow := Digit<0 ; if Borrow then Inc(Digit, Base) ;
        Ar[K] := Digit end ;
      until false ;

    PQ^.Ar[AnsIdx] := Ans end {AnsIdx} ;

  Trim(PQ) ; Trim(PR) ;
  if not (Check('DivdQ', PQ) and Check('DivdR', PR)) then EXIT ;
  if not (Farr(Q) and FArr(R)) then begin Send(S) ; EXIT end ;
  Q := PQ ; R := PR ; Divd := true end {Divd} ;


function Divide(const X, Y : Arr ; var Q, R : Parr) : boolean ;
const S = ' in Divide,' ;
begin Divide := false ;
  if Y.Sg=0 then begin Send(' Divide: by 0,') ; EXIT end ;
  if X.Sg=0 then begin
    if (Carr(PZero, Q) and Carr(PZero, R)) then Divide := true else Send(S) ;
    EXIT end ;
  if (Y.Sz>X.Sz) or (Scomp(X, Y)*X.Sg<0) then begin
    if not (Carr(PZero, Q) and Carr(@X, R)) then begin Send(S) ; EXIT end ;
    end else
    if not Divd(X, Y, Q, R) then begin Send(S) ; EXIT end ;
  if X.Sg<>Y.Sg then begin Q^.Sg := -1 ;
    if R^.Sg<>0 then begin
      if not Minus(Q^, POne^, Q) then begin Send(S) ; EXIT end ;
      R^.Sg := Y.Sg ;
      if not Minus(Y, R^, R) then begin Send(S) ; EXIT end ;
      end end ;
  Divide := true end {Divide} ;


function Root(const X : Arr ; var Q, R : Parr) : boolean ;
var PQ, PR : Parr ; PF : ^Figures ; AnsIdx, AnsSiz, K, QIdx : idx ;
Borrow, Digit : shortint ;
const S = ' in Root,' ;
begin Root := false ;
  if X.Sg<0 then begin Send(' Root: of <0 !,') ; EXIT end ;
  if X.Sg=0 then begin
    if (Carr(PZero, Q) and Carr(PZero, R)) then Root := true else Send(S) ;
    EXIT end ;

  AnsSiz := Succ(X.Sz) div 2 ; PR := NIL ;
  if not (Garr(PQ, Sfix+AnsSiz) and Carr(@X, PR))
    then begin Send(S) ; EXIT end ;
  with PQ^ do begin Sg := +1 ; Sz := AnsSiz end ;
  GetMem(PF, X.Sz) ;
  if PF=NIL then begin Send(' Heap:' + S) ; EXIT end ;

  for AnsIdx := AnsSiz downto 1 do begin
    PQ^.Ar[AnsIdx] := 0 ;

    repeat Move(PR^.Ar[1], PF^, PR^.Sz) ;
      Borrow := 1 ;
      for K := 2*AnsIdx-1 to PR^.Sz do begin
        Digit := PR^.Ar[K] - Borrow ; QIdx := K-AnsIdx+1 ;
        if QIdx<=PQ^.Sz then Dec(Digit, 2*PQ^.Ar[QIdx]) ;
        Borrow := 0 ;
        while Digit<0 do begin Inc(Borrow) ; Inc(Digit, Base) end ;
        PR^.Ar[K] := Digit end ;
      if Borrow>0 then begin Move(PF^, PR^.Ar[1], PR^.Sz) ; BREAK end ;
      Inc(PQ^.Ar[AnsIdx]) until false ;

    end {AnsIdx} ;
  FreeMem(PF, X.Sz) ;

  Trim(PQ) ; Trim(PR) ;
  if not (Check('RootQ', PQ) and Check('RootR', PR)) then EXIT ;
  if not (Farr(Q) and Farr(R)) then begin Send(S) ; EXIT end ;
  Q := PQ ; R := PR ; Root := true end {Root} ;


function Power(const X : Arr ; const c : longint ; var Z : Parr) : boolean ;
var PT : Parr ; b : byte ; OK : boolean ; const S = ' in Power,' ;
begin Power := false ;
  if c<0 then begin Send(' Power: arg<0,') ; EXIT end ;
  PT := NIL ;
  if not Carr(Pone, PT) then begin Send(S) ; EXIT end ;
  for b := Pred(SoB*SizeOf(c)) downto 0 do begin
    OK := Times(PT^, PT^, PT) ; if not OK then BREAK ;
    if (c and (longint(1) shl b))<>0 then begin
      OK := Times(PT^, X, PT) ; if not OK then BREAK ;
      end ;
    end {b} ;
  if not OK then begin Send(S) ;
    if not Farr(PT) then Send(S) ;
    EXIT end ;
  if not Farr(Z) then begin Send(S) ; EXIT end ;
  Z := PT ; Power := true end {Power} ;


function AtoL(const X : Parr ; var LI : longint) : boolean ;
var PosVal : longint ; J : idx ; const S = ' AtoL: Overflow,' {inexact} ;
begin AtoL := false ;
  with X^ do begin LI := 0 ; J := 1 ; PosVal := Sg ;
    if Sz>0 then repeat Inc(LI, Ar[J]*PosVal) ;
      if J=Sz then BREAK ;
      if PosVal>(MaxLongInt div Base) then begin Send(S) ; EXIT end ;
      Inc(J) ; PosVal := PosVal*Base until false ;
    AtoL := true end end {AtoL} ;


const Empty = ' <empty> ' ;


type WrtProc = procedure (const D : Parr) ;

procedure WrtEl(const D : Datum ; const X : WrtProc) ;
const A : array [boolean] of string [4] = ('Nay ', 'Aye ') ;
begin with D do case Sort of
    'a' : X(Aptr) ;
    'b' : WriteFo(A[Bvar]) ;
    'q' : WriteFo(Qvar + Spc) ;
    't' : WriteFo(Tptr^) ;
    else RunError(224) ;
    end end {WrtEl} ;


procedure WrtElS(const D : Datum ; const X : WrtProc) ;
begin WrtEl(D, X) ; if D.Sort='t' then WriteFo(Spc) end {WrtElS} ;


procedure ScreenToS(const SP : PLET) ;
begin Send(' ToS = ') ;
  if SP=NIL then Send(Empty) else WrtEl(SP^.D, WrtA) ;
  Sendln end {ScreenToS} ;


procedure Stak(const SP : PLET) ;
var P : PLET ;
begin WriteFo(' Stack: top ') ; P := SP ;
  if P=NIL then WriteFo(Empty) else repeat WrtElS(P^.D, Short) ;
    P := P^.Next until P=NIL ;
  WriteFo('end') ; WritelnFo end {Stak} ;


function Fstk(var SP : PLET) : boolean ; FAR ;
begin Stak(SP) ; Fstk := true end {Fstk} ;


function EmptyDatum(var D : Datum) : boolean ;
var S3 : string [3] ;
const S = ' in EmptyDatum,' ;
begin EmptyDatum := false ;
  with D do begin
    case Sort of
      'a' : if not Farr(Aptr) then begin Send(S) ; EXIT end ;
      'b' : ;
      'q' : ;
      't' : if TPtr<>NIL then Dispose(Tptr) ;
      '0' : {already empty} ;
      else begin Str(Ord(Sort), S3) ;
        Send(' EmptyDatum: Ord(Sort)='+ S3 + '   ') ; EXIT end ;
      end ;
    Sort := '0' ; Aptr := NIL ;
    end ;
  EmptyDatum := true end {EmptyDatum} ;


function Pop(var SP : PLET) : boolean ;
var TP : PLET ; const S = ' in Pop,' ;
begin Pop := false ;
  if SP=NIL then RunError(225) ;
  TP := SP ; SP := SP^.Next ;
  if not EmptyDatum(TP^.D) then begin Send(S) ; EXIT end ;
  Dispose(TP) ;
  Pop := true end {Pop} ;


function Fpop(var SP : PLET) : boolean ; FAR ;
const S = ' in Fpop,' ;
begin Fpop := false ;
  with SP^.D do if not (Sort in ['a', 'b', 'q', 't']) then
    begin Send(' Fpop: Sort=' + Sort + '!,') ; EXIT end ;
  if not Pop(SP) then begin Send(S) ; EXIT end ;
  Fpop := true end {Fpop} ;


function Fnop(var SP : PLET) : boolean ; FAR ;
begin Fnop := true end {Fnop} ;


function Fcon(var SP : PLET) : boolean ; FAR ;
begin Commas := true ; Fcon := true end {Fcon} ;


function Fcof(var SP : PLET) : boolean ; FAR ;
begin Commas := false ; Fcof := true end {Fcof} ;


function Fpip(var SP : PLET) : boolean ; FAR ;
begin Send(^G) ; Fpip := true end {Fpip} ;


function Ferr(var SP : PLET) : boolean ; FAR ;
begin Send(' Ferr!,') ; Ferr := false end {Ferr} ;


function Fhlt(var SP : PLET) : boolean ; FAR ;
begin {$IFDEF DELPHI} Fhlt := false ; {$ENDIF}
  Sendln ; Send('RPN hlt executed - HALT.') ; Sendln ; HALT end {Fhlt} ;


function Fneg(var SP : PLET) : boolean ; FAR ;
begin Negate(SP^.D.Aptr) ; Fneg := true end {Fneg} ;


function Fabs(var SP : PLET) : boolean ; FAR ;
begin with SP^.D.Aptr^ do Sg := Abs(Sg) ; Fabs := true end {Fabs} ;


function CopyDatum(const Src : Datum ; var Dst : Datum) : boolean ;
const S = ' in CopyDatum,' ;
begin CopyDatum := false ;
  if not EmptyDatum(Dst) then begin Send(S) ; EXIT end ;
  Dst.Sort := Src.Sort  ;
  with Dst do case Sort of
    'a' : if not Carr(Src.Aptr, Aptr) then
      begin Send(' in CopyDatum,') ; EXIT end ;
    'b' : Bvar := Src.Bvar ;
    'q' : Qvar := Src.Qvar ;
    't' : begin New(Tptr) ;
      if Tptr=NIL then begin Send(' Heap:' + S) ; EXIT end ;
      Tptr^ := Src.Tptr^ end ;
    else begin Send(' CopyDatum: Sort=", Sort, ",') ; EXIT end ;
    end ;
  CopyDatum := true end {CopyDatum} ;


function Fdup(var SP : PLET) : boolean ; FAR ;
var P : PLET ; const S = ' in Fdup,' ;
begin Fdup := false ; New(P) ;
  if P=NIL then begin Send(' Heap:' + S) ; EXIT end ;
  with P^.D do begin Aptr := NIL ; Sort := '0' end ;
  if not CopyDatum(SP^.D, P^.D) then begin Send(S) ; EXIT end ;
  P^.Next := SP ; SP := P ; Fdup := true end {Fdup} ;


function Fcls(var SP : PLET) : boolean ; FAR ;
const S = ' in Fcls,' ;
begin Fcls := false ;
  while SP<>NIL do if not Pop(SP) then begin Send(S) ; EXIT end ;
  Fcls := true end {Fcls} ;


procedure ClrStk(var SP : PLET) ;
begin if Fcls(SP) then ; end {ClrStk} ;


const DSU = ': data stack underflow,' ;


procedure Info ;
begin
  Send('  Variables :') ; Sendln ;
  Send('    Names : /q' + Low(QxT) + '../q' + High(QxT)) ; Sendln ;
  Send('    Values : q' + Low(QxT) + '..q' + High(QxT) + ', Stack,') ; Sendln ;
  Send('      qa, qs, qm, qd qr, qp' +
    ' (latest results of add, sub, mul, div/mod/srt, pow)') ; Sendln ;
  Send('  Help : ? / ?? / ??? / ?<opr> ;' +
    {$IFDEF BORPAS} '   Pascal arrow keys;' + {$ENDIF}
    '   # ends the program.') ; Sendln ;
  end {Info} ;


function RegsZero(var QQ : Parr) : boolean ; FAR ;
const S = ' in RegsZero,' ;
begin RegsZero := false ;
  if not Carr(PZero, QQ) then begin Send(S) ; EXIT end ;
  RegsZero := true end {RegsZero} ;


function RegsFresh(var PA : Parr) : boolean ; FAR ;
const S = ' in RegsFresh,' ;
begin RegsFresh := false ; PA := NIL ;
  if not RegsZero(PA) then begin Send(S) ; EXIT end ;
  RegsFresh := true end {RegsFresh} ;


function StoreZero(var QQ : Datum) : boolean ; FAR ;
const S = ' in StoreZero,' ;
begin StoreZero := false ;
  if not EmptyDatum(QQ) then begin Send(S) ; EXIT end ;
  with QQ do begin
    if not RegsZero(Aptr) then begin Send(S) ; EXIT end ;
    Sort := 'a' end ;
  StoreZero := true end {StoreZero} ;


function StoreFresh(var QQ : Datum) : boolean ; FAR ;
const S = ' in StoreFresh,' ;
begin StoreFresh := false ;
  with QQ do begin if not RegsFresh(Aptr) then begin Send(S) ; EXIT end ;
    Sort := 'a' end ;
  StoreFresh := true end {StoreFresh} ;


type
QsjobProc = function (var QQ : Datum) : boolean ;
QrjobProc = function (var QQ : Parr) : boolean ;

function CheckDatum(var QQ : Datum) : boolean ; FAR ;
begin CheckDatum := false ;
  with QQ do if Sort = 'a' then if not Check('CheckDatum', Aptr) then EXIT ;
  CheckDatum := true end {CheckDatum} ;


function Qstores(Qsjob : QsjobProc) : boolean ;
var Qx : QxT ;
begin Qstores := false ;
  for Qx := Low(Qx) to High(Qx) do if not Qsjob(QV[Qx]) then
    begin
    Send(' in Qstores Qx=' + char(Qx) + ',') ; EXIT end ;
  Qstores := true end {Qstores} ;


function Qregs(Qjob : QrjobProc) : boolean ;
const S = ' in Qregs ' ;
begin Qregs := false ;
  if not Qjob(QA) then begin Send(S + 'QA,') ; EXIT end ;
  if not Qjob(QS) then begin Send(S + 'QS,') ; EXIT end ;
  if not Qjob(QM) then begin Send(S + 'QM,') ; EXIT end ;
  if not Qjob(QD) then begin Send(S + 'QD,') ; EXIT end ;
  if not Qjob(QR) then begin Send(S + 'QR,') ; EXIT end ;
  if not Qjob(QP) then begin Send(S + 'QP,') ; EXIT end ;
  Qregs := true end {Qregs} ;


function QClear : boolean ;
begin QClear := false ;
  if not (Qstores(StoreZero) and Qregs(RegsZero)) then
    begin Send(' in QClear,') ; EXIT end ;
  QClear := true end {QClear} ;


function Fclq(var xx : PLET) : boolean ; FAR ;
begin Fclq := false ;
  if not QClear then begin Send(' in Fclq,') ; EXIT end ;
  Fclq := true end {Fclq} ;


function Fvar(var xx : PLET) : boolean ; FAR ;
var Qx : QxT ;
begin Send(' q[' + Low(Qx) + '..' + High(Qx) + '] : ') ;
  for Qx := Low(Qx) to High(Qx) do WrtElS(QV[Qx], Short) ;
  Send(^M^J' q asmdrp: ') ;
  Short(QA) ; Short(QS) ; Short(QM) ; Short(QD) ; Short(QR) ; Short(QP) ;
  Sendln ; Fvar := true end {Fvar} ;


function Fall(var SP : PLET) : boolean ; FAR ;
begin Fall := Fvar(SP) and Fstk(SP) end {Fall} ;


function GetQx(Next : PLET ; var Qx : QxT) : boolean ;
const GQx = ' GetQx: arg' ;
var Qc : char absolute Qx ;
begin GetQx := false ;
  with Next^.D do begin
    if Sort<>'q' then
      begin Send(GQx + ' type "' + Sort + '".') ; RunError(226) end ;
    if Copy(Qvar, 1, 2)<>'/q' then
      begin Send(GQx + ' name"' + Qvar + '",') ; EXIT end ;
    Qc := Qvar[3] ;
    if not (Qc in ['0'..'9']) then
      begin Send(GQx + ' index "' + Qc + '",') ; EXIT end ;
    end {Next^} ;
  GetQX := true end {GetQx} ;


type SumF = function (const X, Y : Arr ; var Z : Parr) : boolean ;

function Fincdec(var SP : PLET ; Fn : SumF) : boolean ; FAR ;
const S = ' in Fincdec,' ;
var Qx : QxT ; B : boolean ;
begin FincDec := false ;
  with SP^.D do case Sort of
    'a' : B := Fn(Aptr^, POne^, Aptr) ;
    'q' : begin
      if not (GetQx(SP, Qx) and Pop(SP)) then begin Send(S) ; EXIT end ;
      with QV[Qx] do B := Fn(Aptr^, POne^, Aptr) ;
      end {q} ;
    else begin Send(' Fincdec: arg type "'+ Sort + '",') ; EXIT end ;
    end {case} ;
  if B then FincDec := true else Send(S) ;
  end {Fincdec} ;


function Finc(var SP : PLET) : boolean ; FAR ;
begin Finc := Fincdec(SP, Plus) end {Finc} ;


function Fdec(var SP : PLET) : boolean ; FAR ;
begin Fdec := Fincdec(SP, Minus) end {Fdec} ;


function PopLI(var LI : longint ; var SP : PLET) : boolean ;
const S = ' in PopLI,' ;
begin PopLI := false ;
  if not (AtoL(SP^.D.Aptr, LI) and Pop(SP)) then begin Send(S) ; EXIT end ;
  PopLI := true end {PopLI} ;


function Fshl(var SP : PLET) : boolean ; FAR ;
var PA : PArr ; LI : longint ; const S = ' in Fshl,' ;
begin Fshl := false ;
  if not PopLI(LI, SP) then begin Send(S) ; EXIT end ;
  with SP^.D, Aptr^ do if Sg<>0 then begin
    if Sz+LI>imax then begin Send(' Fshl: overflow,') ; EXIT end ;
    if not Garr(PA, Sfix+Sz+LI) then begin Send(S) ; EXIT end ;
    PA^.Sg := Sg ; PA^.Sz := Sz+LI ;
    Move(Ar[1], PA^.Ar[LI+1], Sz) ;
    FillChar(PA^.Ar[1], LI, 0) ;
    if not Farr(Aptr) then begin Send(S) ; EXIT end ;
    Aptr := PA end ;
  Fshl := true end {Fshl} ;


function Fshr(var SP : PLET) : boolean ; FAR ;
var LI : longint ;
begin Fshr := false ;
  if not PopLI(LI, SP) then begin Send(' in Fshr,') ; EXIT end ;
  with SP^.D.Aptr^ do begin
    if LI>Sz then Sz := 0 else begin
      Move(Ar[LI+1], Ar[1], Sz-LI) ; Dec(Sz, LI) end ;
    if Sz=0 then Sg := 0 ;
    end ;
  Fshr := true end {Fshr} ;


procedure SwapPtrs(var P1, P2) ;
var PP : pointer ;
begin PP := pointer(P1) ; pointer(P1) := pointer(P2) ; pointer(P2) := PP ;
  end {SwapPtrs} ;


function Fmin(var SP : PLET) : boolean ; FAR ;
const S = ' in Fmin,' ;
begin Fmin := false ;
  with SP^, D do
    if Scomp(Next^.D.Aptr^, Aptr^)>0 then SwapPtrs(Aptr, Next^.D.Aptr) ;
  if not Pop(SP) then begin Send(S) ; EXIT end ;
  FMin := true end {Fmin} ;


function Fmax(var SP : PLET) : boolean ; FAR ;
const S = ' in Fmax,' ;
begin Fmax := false ;
  with SP^, D do
    if Scomp(Next^.D.Aptr^, Aptr^)<0 then SwapPtrs(Aptr, Next^.D.Aptr) ;
  if not Pop(SP) then begin Send(S) ; EXIT end ;
  FMax := true end {Fmax} ;


function Fcmp(var SP : PLET) : boolean ; FAR ;
var Sgn : SgT ; const S = ' in Fcmp,' ;
begin Fcmp := false ;
  with SP^, D do begin
    if Sort<>Next^.D.Sort then begin Send(' Fcmp: Sorts differ,') ; EXIT end ;
    case Sort of
      'a' : Sgn := Scomp(Next^.D.Aptr^, Aptr^) ;
      't' : if Next^.D.Tptr^>Tptr^ then Sgn := +1 else
        if Next^.D.Tptr^<Tptr^ then Sgn := -1 else Sgn := 0 ;
      'b' : Sgn := Ord(Next^.D.Bvar)-Ord(Bvar) ;
      else begin Send(' Fcmp: non-comparable Sort,') ; EXIT end ;
      end {case} ;
    end {SP^, D} ;
  if not Pop(SP) then begin Send(S) ; EXIT end ;
  with SP^.D do begin
    if Sort='t' then begin Dispose(Tptr) ; TPtr := NIL end ;
    if Sort='a' then if not Farr(Aptr) then begin Send(S) ; EXIT end ;
    Sort := 'a' ;
    if not Garr(Aptr, Sfix+1) then begin Send(S) ; EXIT end ;
    with Aptr^ do begin Sg := Sgn ;
      if Sgn=0 then Sz := 0 else begin Sz := 1 ; Ar[1] := 1 end ;
      end {Aptr^} ;
    end {SP^.D} ;
  Fcmp := true end {Fcmp} ;


function Fmag(var SP : PLET) : boolean ; FAR ;
var Sgn : SgT ; const S = ' in Fmag,' ;
begin Fmag := false ;
  with SP^ do Sgn := Ucomp(Next^.D.Aptr^, D.Aptr^) ;
  if not Pop(SP) then begin Send(S) ; EXIT end ;
  with SP^.D do begin
    if not (Farr(Aptr) and Garr(Aptr, Sfix+1)) then begin Send(S) ; EXIT end ;
    with Aptr^ do begin Sg := Sgn ;
      if Sgn=0 then Sz := 0 else begin Sz := 1 ; Ar[1] := 1 end ;
      end {Aptr^} ;
    end {SP^.D} ;
  Fmag := true end {Fmag} ;


function Fadd(var SP : PLET) : boolean ; FAR ;
const S = ' in Fadd,' ;
begin Fadd := false ;
  with SP^ do
    if not (Plus(Next^.D.Aptr^, D.Aptr^, QA) and
    Pop(SP) and Carr(QA, SP^.D.Aptr)) then begin Send(S) ; EXIT end ;
  Fadd := true end {Fadd} ;


function Fand(var SP : PLET) : boolean ; FAR ;
var J : idx ; const S = ' in Fand,' ;
begin Fand := false ;
  with SP^, D do begin
    if Next^.D.Aptr^.Sz > Aptr^.Sz then SwapPtrs(Aptr, Next^.D.Aptr) ;
    with Next^.D.Aptr^ do
     for J := 1 to Sz do Ar[J] := Ar[J] and SP^.D.Aptr^.Ar[J] ;
    end ;
  if not Pop(SP) then begin Send(S) ; EXIT end ;
  Fand := true end {Fand} ;


function Fnot(var SP : PLET) : boolean ; FAR ;
var J : idx ; Q : byte ; { const S = ' in Fnot,' ; }
begin { Fnot := false ; }
  Q := 1 ; while Q<Base do Q := Q shl 1 ; Dec(Q) ;
  with SP^.D.Aptr^ do
    for J := 1 to Sz do Ar[J] := (not Ar[J]) and Q ;
  Fnot := true end {Fnot} ;


function Fxor(var SP : PLET) : boolean ; FAR ;
var J : idx ; const S = ' in Fxor,' ;
begin Fxor := false ;
  with SP^, D do begin
    if Next^.D.Aptr^.Sz < Aptr^.Sz then SwapPtrs(Aptr, Next^.D.Aptr) ;
    with Next^.D.Aptr^ do
     for J := 1 to SP^.D.Aptr^.Sz do Ar[J] := Ar[J] xor SP^.D.Aptr^.Ar[J] ;
    end ;
  if not Pop(SP) then begin Send(S) ; EXIT end ;
  Fxor := true end {Fxor} ;


function Foar(var SP : PLET) : boolean ; FAR ;
var J : idx ; const S = ' in Foar,' ;
begin Foar := false ;
  with SP^, D do begin
    if Next^.D.Aptr^.Sz < Aptr^.Sz then SwapPtrs(Aptr, Next^.D.Aptr) ;
    with Next^.D.Aptr^ do
     for J := 1 to Aptr^.Sz do Ar[J] := Ar[J] or SP^.D.Aptr^.Ar[J] ;
    end ;
  if not Pop(SP) then begin Send(S) ; EXIT end ;
  Foar := true end {Foar} ;


function Fsub(var SP : PLET) : boolean ; FAR ;
const S = ' in Fsub,' ;
begin Fsub := false ;
  with SP^ do
    if not (Minus(Next^.D.Aptr^, D.Aptr^, QS) and
    Pop(SP) and Carr(QS, SP^.D.Aptr)) then begin Send(S) ; EXIT end ;
  Fsub := true end {Fsub} ;


function Fmul(var SP : PLET) : boolean ; FAR ;
const S = ' in Fmul,' ;
begin Fmul := false ;
  with SP^, D do
    if not (Times(Next^.D.Aptr^, Aptr^, QM) and
    Pop(SP) and Carr(QM, SP^.D.Aptr)) then begin Send(S) ; EXIT end ;
  Fmul := true end {Fmul} ;


function Fdiv(var SP : PLET) : boolean ; FAR ;
const S = ' in Fdiv,' ;
begin Fdiv := false ;
  with SP^, D do
    if not (Divide(Next^.D.Aptr^, Aptr^, QD, QR) and
    Pop(SP) and Carr(QD, SP^.D.Aptr)) then begin Send(S) ; EXIT end ;
  Fdiv := true end {Fdiv} ;


function Fmod(var SP : PLET) : boolean ; FAR ;
const S = ' in Fmod,' ;
begin Fmod := false ;
  with SP^, D do
    if not (Divide(Next^.D.Aptr^, Aptr^, QD, QR) and
    Pop(SP) and Carr(QR, SP^.D.Aptr)) then begin Send(S) ; EXIT end ;
  Fmod := true end {Fmod} ;


function Fsrt(var SP : PLET) : boolean ; FAR ;
const S = ' in Fsrt,' ;
begin Fsrt := false ;
  with SP^.D do if not (Root(Aptr^, QD, QR) and Carr(QD, Aptr))
    then begin Send(S) ; EXIT end ;
  Fsrt := true end {Fsrt} ;


function Fpow(var SP : PLET) : boolean ; FAR ;
var LI : longint ; const S = ' in Fpow,' ;
begin Fpow := false ;
  with SP^, D do if not (AtoL(Aptr, LI) and Power(Next^.D.Aptr^, LI, QP)
    and Pop(SP) and Carr(QP, SP^.D.Aptr)) then begin Send(S) ; EXIT end ;
  FPow := true end {Fpow} ;


function Fdeffed(const Psrc, Pdstname : PLET ; var SP : PLET) : boolean ;
const S = ' in Fdeffed,' ;
var Qx : QxT ;
begin Fdeffed := false ;
  if not (GetQx(Pdstname, Qx) and CopyDatum(Psrc^.D, QV[Qx]) and
    Pop(SP) and Pop(SP)) then begin Send(S) ; EXIT end ;
  Fdeffed := true end {Fdeffed} ;


function Fdef(var SP : PLET) : boolean ; FAR ;
begin Fdef := Fdeffed(SP, SP^.Next, SP) end {Fdef} ;


function Ffed(var SP : PLET) : boolean ; FAR ;
begin Ffed := Fdeffed(SP^.Next, SP, SP) end {Ffed} ;


function Fval(var SP : PLET) : boolean ; FAR ;
var P : PArr ; const S = ' in Fval,' ;
begin Fval := false ;
  with SP^, D do begin P := NIL ;
    if not StoA(Tptr^, P) then begin Send(S) ; EXIT end ;
    Dispose(Tptr) ; Sort := 'a' ; Aptr := P end ;
  Fval := true end {Fval} ;


function Fstr(var SP : PLET) : boolean ; FAR ;
var PS : Pstr ; j : idx ; const S = ' in Fstr,' ;
begin Fstr := false ;
  New(PS) ; if PS=NIL then begin Send(' Heap:' + S) ; EXIT end ;
  with SP^.D, Aptr^ do begin
    if Sg=0 then PS^ := '0' else begin PS^ := SgChar(Sg) ;
      if Sz=0 then PS^ := PS^+'o' else
        for j := Sz downto 1 do begin
        if Length(PS^)=MaxStr then begin
          Send(' Fstr: too long,') ; Dispose(PS) ; EXIT end ;
        PS^ := PS^ + Sims(Ar[j]) ;
        if Commas then if j mod 3 = 1 then if j>1 then PS^ := PS^ + ',' ;
        end {j} ;
      end ;
    if not Farr(Aptr) then begin Send(S) ; Dispose(PS) ; EXIT end ;
    Tptr := PS ; Sort := 't' end ;
  Fstr := true end {Fstr} ;


function Fswp(var SP : PLET) : boolean ; FAR ;
var P : PLET ;
begin P := SP ; SP := SP^.Next ; P^.Next := SP^.Next ; SP^.Next := P ;
  Fswp := true end {Fswp} ;


function Foik(var SP : PLET) : boolean ; FAR ;
var P, Q : PLET ; LI : longint ; const S = ' in Foik,' ;
begin Foik := false ;
  if not PopLI(LI, SP) then begin Send(S) ; EXIT end ;
  if LI>0 then begin P := SP ;
    repeat Q := P ; P := P^.Next ;
      if P=NIL then begin Send(' Foik' + DSU) ; EXIT end ;
      Dec(LI) until LI=0 ;
    Q^.Next := P^.Next ; P^.Next := SP ; SP := P end ;
  Foik := true end {Foik} ;


function Fdig(var SP : PLET) : boolean ; FAR ;
var P : PLET ; LI : longint ; const S = ' in Fdig,' ;
begin Fdig := false ;
  if not AtoL(SP^.D.Aptr, LI) then begin Send(S) ; EXIT end ;
  P := SP^.Next ;
  while LI>0 do begin P := P^.Next ;
    if P=NIL then begin Send(' Fdig' + DSU) ; EXIT end ;
    Dec(LI) end ;
  if not CopyDatum(P^.D, SP^.D) then begin Send(S) ; EXIT end ;
  Fdig := true end {Fdig} ;


function Fkio(var SP : PLET) : boolean ; FAR ;
var P, Q : PLET ; LI : longint ; const S = ' in Fkio,' ;
begin Fkio := false ;
  if not PopLI(LI, SP) then begin Send(S) ; EXIT end ;
  if LI>0 then begin P := SP ;
    repeat if P=NIL then begin Send(' Fkio' + DSU) ; EXIT end ;
      Q := P ; P := P^.Next ;
      Dec(LI) until LI<0 ;
    Q^.Next := SP ; SP := SP^.Next ; Q^.Next^.Next := P end ;
  Fkio := true end {Fkio} ;


function Fwts(var SP : PLET) : boolean ; FAR ;
begin WrtEl(SP^.D, WrtA) ; Fwts := true end {Fwts} ;


function Fwns(var SP : PLET) : boolean ; FAR ;
var P : PLET ; LI : longint ; const S = ' in Fwns,' ;
begin Fwns := false ;
  if not PopLI(LI, SP) then begin Send(S) ; EXIT end ;
  P := SP ;
  while LI>0 do begin P := P^.Next ;
    if P=NIL then begin Send(' Fwns' + DSU) ; EXIT end ;
    Dec(LI) end ;
  if not Fwts(P) then begin Send(S) ; EXIT end ;
  Fwns := true end {Fwns} ;


function Fwrt(var SP : PLET) : boolean ; FAR ;
const S = ' in Fwrt,' ;
begin Fwrt := false ;
  if not (Fwts(SP) and Pop(SP)) then begin Send(S) ; EXIT end ;
  Fwrt := true end {Fwrt} ;


function Fwln(var SP : PLET) : boolean ; FAR ; {?}
begin WritelnFo ; Fwln := true end {Fwrt} ;


function Fwrs(var SP : PLET) : boolean ; FAR ; {?}
begin WriteFo(Spc) ; Fwrs := true end {Fwrs} ;


function Ftab(var SP : PLET) : boolean ; FAR ; {?}
begin WriteFo(^I) ; Ftab := true end {Ftab} ;



procedure RandomArr(var PQ : Parr ; const R : word) ;
var K : idx ;
begin with PQ^ do begin
    Sg := Pred(shortint(2)*Random(2)) ;
    Sz := Random(R) ;
    for K := 1 to Sz do Ar[K] := Random(Base) ;
    end ;
  Trim(PQ) end {RandomArr} ;



function Frze(var SP : PLET) : boolean ; FAR ;
begin Randomize ; Frze := true end {Frze} ;


function Frnd(var SP : PLET) : boolean ; FAR ;
const S = ' in Frnd,' ;
var { PR : Parr ; } LI : longint ; Wd : word absolute LI ;
begin Frnd := false ;
  with SP^.D do begin
    if not AtoL(Aptr, LI) then begin Send(S) ; EXIT end ;
    if Wd<>LI then begin Send(' rnd: arg error,') ; EXIT end ;
    Wd := Random(Wd) ;
    if not LtoA(Wd, Aptr) then begin Send(S) ; EXIT end ;
    end ;
  Frnd := true end {Frnd} ;



function Frdd(var SP : PLET) : boolean ; FAR ;
const S = ' in Frdd,' ;
var PR : Parr ; LI : longint ; Wd : word absolute LI ;
begin Frdd := false ;
  with SP^.D do begin
    if not AtoL(Aptr, LI) then begin Send(S) ; EXIT end ;
    if Wd<>LI then begin Send(' rdd: arg error,') ; EXIT end ;
    Wd := Random(Wd) ;
    if not Garr(PR, Sfix+Wd) then begin Send(S) ; EXIT end ;
    RandomArr(PR, Wd) ;
    if not Farr(Aptr) then begin Send(S) ; EXIT end ;
    Aptr := PR end ;
  Frdd := true end {Frdd} ;



{$IFDEF BORPAS}
{$IFDEF MSDOS}

const NDeep : word = 8 ;


function Fedp(var SP : PLET) : boolean ; FAR ;
var LI : longint ; S10 : string [10] ; const S = ' in Fedp,' ;
begin Fedp := false ;
  if not (AtoL(SP^.D.Aptr, LI) and Pop(SP)) then begin Send(S) ; EXIT end ;
  if word(LI)<>LI then
    begin Str(LI, S10) ; Send(' Fedp arg ' + S10 + ' : ') ; EXIT end ;
  NDeep := LI ; Fedp := true end {Fedp} ;


function Fgnv(var SP : PLET) : boolean ; FAR ;
var Status : byte ; const S = ' in Fgnv,' ;
begin Fgnv := false ;
  with SP^.D do Environ(NDeep, Get, Tptr^, TPtr^, Status) ;
  if Status>0 then begin Send(S+' Status='+char(48+Status)+',') ; EXIT end ;
  Fgnv := true end {Fgnv} ;

{ $DEFINE FGNV}


function Fpnv(var SP : PLET) : boolean ; FAR ;
var LI : longint ; Status : byte ; const S = ' in Fpnv,' ;
begin Fpnv := false ;
  Environ(NDeep, Put, SP^.D.Tptr^, SP^.Next^.D.TPtr^, Status) ;
  if Status>0 then begin Send(S+' Status='+char(48+Status)+',') ; EXIT end ;
  if not (Pop(SP) and Pop(SP)) then begin Send(S) ; EXIT end ;
  Fpnv := true end {Fpnv} ;

{$ENDIF}

{$IFNDEF MSDOS}
function Fgnv(var SP : PLET) : boolean ; FAR ;
begin Fgnv := false ;
  with SP^.D do TPtr^ := GetEnv(TPtr^) ;
  Fgnv := true end {Fgnv} ;
{$ENDIF}

{$ENDIF}




const PTen : Parr = NIL ;


function S10toA(const St : string ; var A : Parr) : boolean ;
var PA, PB : Parr ; J : word ; C, Err : char ; Sgn : SgT ;
const S = ' in S10toA, ' ;
begin S10toA := false ; PA := NIL ;
  if not Carr(PZero, PA) then begin Send(S) ; EXIT end ;
  PB := NIL ; Err := #0 ; Sgn := 1 ;
  for J := 1 to Length(St) do begin C := St[J] ;
    if J=1 then
      if C in Sign then begin Sgn := 44-Ord(C) ; CONTINUE end ;
    if C=',' then CONTINUE ;
    if not Times(PA^, PTen^, PA) then begin Err := '*' ; BREAK end ;
    if not (C in ['0'..'9'])     then begin Err := '?' ; BREAK end ;
    if not LtoA(Ord(C)-48, PB)   then begin Err := '#' ; BREAK end ;
    if not Plus(PA^, PB^, PA)    then begin Err := '+' ; BREAK end ;
    end ;
  PA^.Sg := Sgn ;
  if not Farr(PB) then begin Send(S) ; EXIT end ;
  if Err<>#0 then begin Send(' S10toA ' + Err + ':') ;
    if not Farr(PA) then Send(S) ;
    EXIT end ;
  if not Farr(A) then begin Send(S) ; EXIT end ;
  Trim(PA) ; if not Check('S10toA', PA) then EXIT ;
  A := PA ; S10toA := true end {S10toA} ;


function FetchQvarContent(const Atom : string ; var SP : PLET) : boolean ;
var PA : Parr ; const S = ' in FetchQvarContent,' ;
begin FetchQvarContent := false ;
  if Length(Atom)<>2 then RunError(227) ;
  if Atom[1]<>'q' then RunError(228) ;
  if Atom[2] in ['0'..'9'] then begin
    if not CopyDatum(QV[Atom[2]], SP^.D) then begin Send(S) ; EXIT end ;
    end
  else begin
    case Atom[2] of
      'a' : PA := QA ;
      's' : PA := QS ;
      'm' : PA := QM ;
      'd' : PA := QD ;
      'r' : PA := QR ;
      'p' : PA := QP ;
      else begin Send(' FetchQvarContent: "' + Atom + '",') ; EXIT end ;
      end {case} ;
    with SP^.D do begin Sort := 'a' ;
      if not Carr(PA, Aptr) then begin Send(S) ; EXIT end ;
      end ;
    end ;
  FetchQvarContent := true end {FetchQvarContent} ;


function PushEmpty(var SP : PLET) : boolean ;
var P : PLET ;
begin PushEmpty := false ; New(P) ;
  if P=NIL then begin Send(' Heap: in PushEmpty,') ; EXIT end ;
  FillChar(P^, SizeOf(P^), 0) ;
  P^.Next := SP ; P^.D.Sort := '0' ;
  SP := P ; PushEmpty := true end {PushEmpty} ;


function PushLiteralNumber(Atom : string ; var SP : PLET) : boolean ;
var PA : PArr ;
begin PushLiteralNumber := false ; PA := NIL ;
  if not (StoA(Atom, PA) and PushEmpty(SP)) then begin
    Send(' in PushLiteralNumber,') ;
    if not Farr(PA) then ;
    EXIT end ;
  with SP^.D do begin Aptr := PA ; Sort := 'a' end ;
  PushLiteralNumber := true end {PushLiteralNumber} ;


function PushDecimalNumber(const Atom : string ; var SP : PLET) : boolean ;
var PA : PArr ;
begin PushDecimalNumber := false ; PA := NIL ;
  if not (S10toA(Atom, PA) and PushEmpty(SP)) then begin
    Send(' in PushDecimalNumber,') ;
    if not Farr(PA) then ;
    EXIT end ;
  with SP^.D do begin Aptr := PA ; Sort := 'a' end ;
  PushDecimalNumber := true end {PushDecimalNumber} ;


function PushLongint(const LI : longint ; var SP : PLET) : boolean ;
var PA : PArr ;
begin PushLongint := false ; PA := NIL ;
  if not (LtoA(LI, PA) and PushEmpty(SP)) then begin
    Send(' in PushLongint,') ;
    if not Farr(PA) then ;
    EXIT end ;
  with SP^.D do begin Aptr := PA ; Sort := 'a' end ;
  PushLongint := true end {PushLongint} ;


function PushQuotedText(const Atom : string ; var SP : PLET) : boolean ;
const S = ' in PushQuotedText,' ;
begin PushQuotedText := false ;
  if Atom[Length(Atom)]<>')' then begin
    Send(' PushQuotedText: no ")" at end,') ; EXIT end ;
  if not PushEmpty(SP) then begin Send(S) ; EXIT end ;
  with SP^.D do begin New(Tptr) ;
    if Tptr=NIL then begin Send(' Heap:' + S) ; EXIT end ;
    Tptr^ := Copy(Atom, 2, Length(Atom)-2) ; Sort := 't' end ;
  PushQuotedText := true end {PushQuotedText} ;


function PushQvarName(const Atom : string ; var SP : PLET) : boolean ;
begin PushQvarName := false ;
  if Length(Atom)<>3 then begin
    Send(' PushQvarName : Length(' + Atom + ')<>3 ') ; EXIT end ;
  if not PushEmpty(SP) then begin Send(' in PushQvarName,') ; EXIT end ;
  with SP^.D do begin Qvar := Atom ; Sort := 'q' end ;
  PushQvarName := true end {PushQvarName} ;


function PushQvarContent(const Atom : string ; var SP : PLET) : boolean ;
begin PushQvarContent := false ;
  if Length(Atom)<>2 then begin
    Send(' PushQvarContent : Length(' + Atom + ')<>2 ') ; EXIT end ;
  if not PushEmpty(SP) then begin Send(' in PushQvarContent,') ; EXIT end ;
  SP^.D.Sort := 'q' {?} ;
  if not FetchQvarContent(Atom, SP) then
    begin Send(' in PushQvarContent,') ;
    if not Pop(SP) then ;
    EXIT end ;
  PushQvarContent := true end {PushQvarContent} ;


{$IFDEF PROGRAM}
function RPN(const St : string ; var SP : PLET) : boolean ; forward ;
{$ENDIF}


function Tix : longint ;
{$IFDEF BORPAS} assembler ;
asm
    mov es,[Seg0040] ;
  @1: mov ax,[es:$6c] ; mov dx,[es:$6e] ; mov cl,[es:$70]
    cmp ax,[es:$6c] ; jne @1
    cmp cl,0 ; je @2
    add ax,$B0 ; adc dx,$18 ;
  @2:
    end {$ENDIF}
{$IFDEF __TMT__} assembler ;
{label Dollar1, Dollar2 ;}
asm ;
  { Dollar1:
    mov eax,[$046C] ; mov cl,[$0470] ; cmp eax,[$046C] ; jne Dollar1
    cmp cl,0 ; je Dollar2
    add eax,$1800B0 ;
    Dollar2: }
  mov eax,[$046C] ;
  end {$ENDIF}
{$IFDEF DELPHI}
begin Tix := GetTickCount div 55 end
{$ENDIF}
{Tix} ;


function Mls : longint ;
begin Mls :=
    {$IFDEF PASCAL} Tix * 55 {$ENDIF}
    {$IFDEF DELPHI} GetTickCount {$ENDIF}
    end {Mls} ;


function Ftix(var SP : PLET) : boolean ; FAR ;
const S = ' in Ftix,' ;
begin Ftix := false ;
  if not PushLongint(Tix, SP) then begin Send(S) ; EXIT end ;
  Ftix := true end {Ftix} ;


function Fmls(var SP : PLET) : boolean ; FAR ;
const S = ' in Fmls,' ;
begin Fmls := false ;
  if not PushLongint(Mls, SP) then begin Send(S) ; EXIT end ;
  Fmls := true end {Fmls} ;


{$IFDEF DELPHI}
(* from Robert Lee <rhlee@nwu.edu> - needs Delphi 4 or higher :
  function GetCycleCount : int64 ;
  (This is minimally invasive and accurate down to about 40 cycles.}
  asm  DB 0FH ; DB 031H  end ;  *)

procedure GetCycleCount(var Lo,Hi:integer) ;
asm  push ebx ; mov ecx,eax ; mov ebx,edx
    DB 0FH ; DB 031H
    mov dword ptr[ecx], eax ; mov dword ptr[ebx], edx
    { mov Lo, eax ; mov  Hi, edx  }
    pop ebx  end { Bob Lee} ;

function Frdtsc : longint ; assembler ;
asm  dw $310F {Clock to edx:eax}  end {Frtdsc} ;

function Fcpu(var SP : PLET) : boolean ; FAR ;
const S = ' in Fcpu,' ;
begin Fcpu := false ;
  if not PushLongint(Frdtsc, SP) then begin Send(S) ; EXIT end ;
  Fcpu := true end {Fcpu} ;

function Fcpu2(var SP : PLET) : boolean ; FAR ;
var SA, SM : Parr ;
const S = ' in Fcpu2,' ;
var H, L : longint ;
begin Fcpu2 := false ; GetCycleCount(L, H) ;
  SA := QA ; QA := NIL ; SM := QM ; QM := NIL ; { used in conversion! }
  if not ( PushLongint(L, SP) and PushLongInt(H, SP) and
    RPN('4294967296 mul add', SP) ) then begin Send(S) ; EXIT end ;
  QM := SM ; QA := SA ;
  Fcpu2 := true end {Fcpu} ;
{$ENDIF}


function Flen(var SP : PLET) : boolean ; FAR ;
const S = ' in Flen,' ;
var LI : longint ;
begin Flen := false ; {$IFDEF DELPHI} LI := 0 ; {$ENDIF}
  with SP^.D do begin
    case Sort of
      't' : begin LI := Length(Tptr^) ;
        Dispose(TPtr) ; Tptr := NIL ; Sort := 'a' ;
        end ;
      'a' : LI := Aptr^.Sz ;
      end ;
    if not LtoA(LI, Aptr) then begin Send(S) ; EXIT end ;
    end ;
  Flen := true end {Flen} ;


function Fimp(var SP : PLET) : boolean ; FAR ;
const S = ' in Fimp,' ;
begin Fimp := false ;
  if not RPN('not oar', SP) then begin Send(S) ; EXIT end ;
  Fimp := true end {Fimp} ;


var OldBase : byte ;
const POldB : Parr = NIL ;


function ConvBas(var PA : PArr) : boolean ;
var TA, PD : PArr ; J : idx ; B : boolean ;
const S = ' in ConvBas, ' ;
begin ConvBas := false ; B := true ; PD := NIL ;
  if not NewZero(TA) then begin Send(S) ; EXIT end ;
  with PA^ do for J := Sz downto 1 do begin
    B := Times(TA^, POldB^, TA) and LtoA(Ar[J], PD) and Plus(TA^, PD^, TA) ;
    if not B then CONTINUE ;
    end ;
  if not B then Send(S) ;
  TA^.Sg := PA^.Sg { 2005-07-22 } ;
  if not (FArr(PD) and FArr(PA)) then begin Send(S) ; EXIT end  ;
  PA := TA ; ConvBas := B end {ConvBas} ;


function StoresConv(var QQ : Datum) : boolean ; FAR ;
const S = ' in StoresConv,' ;
begin StoresConv := false ;
  with QQ do if Sort='a' {stet} then
    if not ConvBas(Aptr) then begin Send(S) ; EXIT end ;
  StoresConv := true end {StoresConv} ;


function RegsConv : boolean ;
var SA, SM : Parr ;
begin RegsConv := false ;
  SA := QA ; QA := NIL ; SM := QM ; QM := NIL ; { used in conversions! }
  if not ( ConvBas(SA) and ConvBas(SM)
    and ConvBas(QS) and ConvBas(QD) and ConvBas(QR) and ConvBas(QP)
    and Farr(QM) and Farr(QA) )
    then begin Send(' in RegsConv,') ; EXIT end ;
  QM := SM ; QA := SA ;
  RegsConv := true end {RegsConv} ;


function ConvertBase(P : PLET) : boolean ;
const S = ' in ConvertBase,' ;
begin ConvertBase := false ;
  while P<>NIL do begin
    with P^.D do if Sort='a' {stet} then
      if not ConvBas(Aptr) then begin Send(S) ; EXIT end ;
    P := P^.Next end ;
  if not (QStores(StoresConv) and RegsConv) then begin Send(S) ; EXIT end ;
  ConvertBase := true end {ConvertBase} ;


function Fbas(var SP : PLET) : boolean ; FAR ;
var LI : longint ; S10 : string [10] ; const S = ' in Fbas,' ;
begin Fbas := false ;
  if not (AtoL(SP^.D.Aptr, LI) and Pop(SP)) then begin Send(S) ; EXIT end ;
  if not ((byte(LI)=LI) and (byte(LI) in [Low(Base)..High(Base)])) then
    begin Str(LI, S10) ; Send(' Fbas arg ' + S10 + ' : ') ; EXIT end ;
  OldBase := Base ; Base := LI ; SetCharSet ;
  if not (LtoA(10, PTen) and LtoA(OldBase, POldB) and
    ConvertBase(SP) and Farr(POldB)) then begin Send(S) ; EXIT end ;
  Fbas := true end {Fbas} ;


function Ftry(var SP : PLET) : boolean ; FAR ;
const S = ' in Ftry,' ;
begin Ftry := false ;
  if not
    RPN('', SP)
    then begin Send(S) ; EXIT end ;
  Ftry := true end {Ftry} ;


function Ffac(var SP : PLET) : boolean ; FAR ;
const S = ' in Ffac,' ;
begin Ffac := false ;
  if not RPN('1 (mul) 1 3 oik for', SP) then begin Send(S) ; EXIT end ;
  Ffac := true end {Ffac} ;


function Ffor(var SP : PLET) : boolean ; FAR ;
var PA1, PA2 : Parr ; St : string ; B : boolean ;
const S = ' in Ffor,' ;
begin Ffor := false ;
  PA2 := NIL ; SwapPtrs(PA2, SP^.D.Aptr) ;
  if not Pop(SP) then begin Send(S) ; EXIT end ;
  PA1 := NIL ; SwapPtrs(PA1, SP^.D.Aptr) ;
  if not Pop(SP) then begin Send(S) ; EXIT end ;
  St := SP^.D.Tptr^ ;
  if not Pop(SP) then begin Send(S) ; EXIT end ;
  B := true ;
  while B and (Scomp(PA1^, PA2^)<=0) do begin
    if not PushEmpty(SP) then begin Send(S) ; EXIT end ;
    with SP^.D do begin Sort := 'a' ;
      if not Carr(PA1, Aptr) then begin Send(S) ; EXIT end ;
      end ;
    B := RPN(St, SP) and Plus(PA1^, Pone^, PA1) ;
    end ;
  if not (B and Farr(PA1) and Farr(PA2)) then begin Send(S) ; EXIT end ;
  Ffor := true end {Ffor} ;


function Fsbs(var SP : PLET) : boolean ; FAR ;
var L1, L2 : longint ; const S = ' in Fsbs,' ;
begin Fsbs := false ;
  if not (PopLI(L2, SP) and PopLI(L1, SP)) then begin Send(S) ; EXIT end ;
  with SP^.D do Tptr^ := Copy(Tptr^, L1, L2) ;
  Fsbs := true end {Fsbs} ;


function Fcat(var SP : PLET) : boolean ; FAR ;
var LI : longint ; const S = ' in Fcat,' ;
begin Fcat := false ;
  with SP^.Next^.D do begin
    LI := Length(Tptr^)+Length(SP^.D.Tptr^) ;
    Tptr^ := Tptr^+SP^.D.Tptr^ ;
    if Length(Tptr^)<>LI then begin Send(' Fcat: length,') ; EXIT end ;
    end ;
  if not Pop(SP) then begin Send(S) ; EXIT end ;
  Fcat := true end {Fcat} ;


function Fexe(var SP : PLET) : boolean ; FAR ;
var PS : Pstr ; const S = ' in Fexe,' ;
begin Fexe := false ;
  with SP^.D do begin PS := Tptr ; Tptr := NIL end ;
  if not (Pop(SP) and RPN(PS^, SP)) then begin Send(S) ; EXIT end ;
  Dispose(PS) { 2001-04-10 } ;
  Fexe := true end {Fexe} ;


function Fwhl(var SP : PLET) : boolean ; FAR ;
var PS : Pstr ; const S = ' in Fwhl,' ;
begin Fwhl := false ;
  with SP^.D do begin PS := Tptr ; Tptr := NIL end ;
  if not Pop(SP) then begin Send(S) ; EXIT end ;
  while SP^.D.Aptr^.Sg<>0 do {not popped}
    if not RPN(PS^, SP) then begin Send(S) ; EXIT end ;
  Fwhl := true end {Fwhl} ;


function FKEY(var SP : PLET) : boolean ; FAR ;
var St : string ; const S = ' in FKEY,' ;
begin FKEY := false ;
  Write(' ? ') ; Readln(St) ;
  if not RPN(St, SP) then begin Send(S) ; EXIT end ;
  FKEY := true end {FKEY} ;


function FSCR(var SP : PLET) : boolean ; FAR ;
var St : string ; Fi : text ; IOR : integer ;
const S = ' in FSCR,' ;
begin FSCR := false ; St := SP^.D.Tptr^ ;
  if not Pop(SP) then begin Send(S) ; EXIT end ;
  Send(' File ' + St + #32) ;
  Assign(Fi, St) ; {$I-} Reset(Fi) ; IOR := IOResult {$I+} ;
  if IOR<>0 then begin Str(IOR, St) ; Send(' IOResult ' + St + S) ; EXIT end ;
  Send('found') ; Sendln ;
  while not EoF(Fi) do begin Readln(Fi, St) ;
    if not RPN(St, SP) then begin Close(Fi) ; EXIT end ;
    end ;
  Close(Fi) ;
  Send(' SCR done') ; Sendln ;
  FSCR := true end {FSCR} ;


function Fiftf(TF : boolean ; Sign : SgT ; var SP : PLET) : boolean ;
var St : string ; B : boolean ; const S = ' in Fiftf,' ;
begin Fiftf := false ; St := SP^.D.Tptr^ ;
  if not Pop(SP) then begin Send(S) ; EXIT end ;
  B := SP^.D.Aptr^.Sg=Sign ;
  if not Pop(SP) then begin Send(S) ; EXIT end ;
  if B=TF then Fiftf := RPN(St, SP) else Fiftf := true ;
  end {Fiftf} ;


function Fif0(var SP : PLET) : boolean ; FAR ;
const S = ' in Fif0,' ;
begin Fif0 := false ;
  if not Fiftf(true, 0, SP) then begin Send(S) ; EXIT end ;
  Fif0 := true end {Fif0} ;


function Fno0(var SP : PLET) : boolean ; FAR ;
const S = ' in Fno0,' ;
begin Fno0 := false ;
  if not Fiftf(false, 0, SP) then begin Send(S) ; EXIT end ;
  Fno0 := true end {Fno0} ;


function FifG(var SP : PLET) : boolean ; FAR ;
const S = ' in FifG,' ;
begin FifG := false ;
  if not Fiftf(true, +1, SP) then begin Send(S) ; EXIT end ;
  FifG := true end {FifG} ;


function FnoG(var SP : PLET) : boolean ; FAR ;
const S = ' in FnoG,' ;
begin FnoG := false ;
  if not Fiftf(false, +1, SP) then begin Send(S) ; EXIT end ;
  FnoG := true end {FnoG} ;


function FifL(var SP : PLET) : boolean ; FAR ;
const S = ' in FifL,' ;
begin FifL := false ;
  if not Fiftf(true, -1, SP) then begin Send(S) ; EXIT end ;
  FifL := true end {FifL} ;


function FnoL(var SP : PLET) : boolean ; FAR ;
const S = ' in FnoL,' ;
begin FnoL := false ;
  if not Fiftf(false, -1, SP) then begin Send(S) ; EXIT end ;
  FnoL := true end {FnoL} ;


const SPGA = ' Secs from Prol Greg Ast 0000/03/01-00:00:00: ' ;
DaysString =
  ' (%% 306 337 000 +31 +61 +92 122 153 184 214 245 275 306 337 999) ' ;


function F_dw(var SP : PLET) : boolean ; FAR ;
const S = ' in F_dw,' ;
begin F_dw := false ;
  if not RPN('86400 div 3 add 7 mod', SP) then begin Send(S) ; EXIT end ;
  F_dw := true end {F_dw} ;



function F_ws(var SP : PLET) : boolean ; FAR ;
const S = ' in F_ws,' ;
begin F_ws := false ;
  if not RPN('(SunMonTueWedThuFriSat) swp 3 mul inc 3 sbs', SP)
    then begin Send(S) ; EXIT end ;
  F_ws := true end {F_ws} ;


function F_ds(var SP : PLET) {y m d h m s #ds x} : boolean ; FAR ;
begin F_ds :=
    RPN('(F_ds.  ) wrt swp 60 mul add  swp 3600 mul add  /q1 fed', SP)
    and RPN('(Secs of Day: ) wrt q1 wrt', SP)
    and RPN({y m d} '2 kio  dup 3 cmp (swp dec swp) ifl ', SP)
    and RPN({d y' m} DaysString + ' swp 4 mul 3 sbs exe ' {d y' A[m]}
    + ' 2 oik add' {y' d} , SP)
    and RPN('(  Day of ) wrt 1 wns (: ) wrt wts /q0 fed', SP)
    and RPN('(  Days in Date: ) wrt', SP)
    and RPN('   400 div 146097 mul  q0 add /q0 fed', SP)
    and RPN('qr 100 div  36524 mul  q0 add /q0 fed', SP)
    and RPN('qr   4 div   1461 mul  q0 add /q0 fed', SP)
    and RPN('qr   1 div    365 mul  q0 add /q0 fed', SP)
    and RPN('q0 wrt wln', SP)
    and RPN('q0 dec 86400 mul q1 add', SP)
    and RPN('( Total' + SPGA + ') wrt wts wln', SP) ;
  end {F_ds} ;


function F_sd(var SP : PLET) {x #sd y d h m s} : boolean ; FAR ;
const IndexIt = ' swp 0 sub 4 mul 3 sbs exe (([) wrt wts (]) wrt) pop' ;
begin F_sd := RPN('(F_sd. ' + SPGA + ') wrt wts wln', SP)
    and RPN('( Day of "Era" (0..): ) wrt 86400 div wts /q3 fed', SP)
    and RPN('( & Secs: ) wrt /q1 qr def  qr wrt', SP)
    and RPN('(   DoW Sun=0: ) wrt  q3 3 add 7 mod wts /q7 fed', SP)

    and RPN('wln ( Years: { add ) wrt /q2 0 def', SP)
    and RPN('q3 146097 div  qr  /q3 fed  400 mul  wts  q2 add /q2 fed', SP)

    and RPN('q3  36524 div  3 min  dup 36524 mul  q3 sub neg', SP)
    and RPN('                   /q3 fed  100 mul  wts  q2 add /q2 fed', SP)
    and RPN('q3   1461 div  qr  /q3 fed    4 mul  wts  q2 add /q2 fed', SP)
    and RPN('q3    365 div  3 min  dup   365 mul  q3 sub neg', SP)
    and RPN('                   /q3 fed  001 mul  wts  q2 add        ', SP)

    and RPN('(} total: ) wrt wts', SP)

    and RPN({y' d} '( Day{0..}= ) wrt q3 wrt /q5 fed', SP)  { q3=D q5:=Y }
    and RPN('( =>  M'':= ) wrt', SP)
    and RPN('q3 95 add 32 div wts /q4 fed', SP) { q4=M := ((D+95) shr 5) }
    and RPN(' (' + DaysString + IndexIt + ' ) dup', SP)
    and RPN('q4 inc swp exe '{DaysFromFeb[M+1]}, SP)
    and RPN('q3 cmp 1 cmp (/q4 inc) ifl', SP)
    and RPN('q3 inc swp q4 swp exe sub /q3 fed', SP)
    and RPN('q4 12 cmp (/q4 q4 12 sub def  /q5 inc) ifg wln', SP)

    and RPN('( Year: ) wrt q5 wts', SP)
    and RPN('( Month: ) wrt q4 wts', SP)
    and RPN('( Day: ) wrt q3 wts', SP)
    {    and RPN('wrs (SunMonTueWedThuFriSat) q7 3 mul inc 3 sbs wrt', SP) }
    and RPN('wrs q7 #ws wrt', SP)
    and RPN('(  Hrs: ) wrt q1 3600 div wts', SP)
    and RPN('( Mins: ) wrt qr 60 div wts', SP)
    and RPN('( Secs: ) wrt qr wts wln', SP) ;
  end {F_sd} ;


function F_us(var SP : PLET) : boolean ; FAR ;
begin F_us := RPN('(F_us.) wrt 1970 1 1 0 0 0', SP) end {F_us} ;


function F_uf(var SP : PLET) : boolean ; FAR ;
begin F_uf :=
    RPN('(F_uf:  ) wrt wts (seconds from UNIX base Date: ) wrt', SP)
    and RPN('#us (neg 6 add wns) 1 6 for wln', SP)
    and RPN('#ds', SP)
    and RPN('(   Add ) wrt swp wts (to get ) wrt add wts wln', SP)
    and RPN('#sd ( UTC) wrt wln', SP) ;
  end {F_uf} ;


function F_sa(var SP : PLET) : boolean ; FAR ;
begin F_sa := RPN('(F_sa.) wrt add wln #ds wln #sd wln', SP) end {F_sa} ;


function F_dt(var SP : PLET) : boolean ; FAR ;
var Yr, Mo, Dy, Hr, Mn, Sc, X : word ;
{$IFDEF PASCAL} Dx : word ; {$ENDIF}
{$IFDEF DELPHI} T : TDateTime ; {$ENDIF}
begin
  {$IFDEF PASCAL} repeat
    GetDate(Yr, Mo, Dx, X) ; GetTime(Hr, Mn, Sc, X) ;
    GetDate(Yr, Mo, Dy, X) until Dy=Dx ; {$ENDIF}
  {$IFDEF DELPHI} T := Now ;
  DecodeDate(T, Yr, Mo, Dy) ; DecodeTime(T, Hr, Mn, Sc, X) ; {$ENDIF}
  F_dt := RPN('(F_dt.) wrt', SP) and
    PushLongint(Yr, SP) and PushLongint(Mo, SP) and PushLongint(Dy, SP) and
    PushLongint(Hr, SP) and PushLongint(Mn, SP) and PushLongint(Sc, SP) ;
  end {F_dt} ;


function F_dd(var SP : PLET) : boolean ; FAR ;
begin F_dd :=
    RPN('(F_dd.) wrt', SP)
    and RPN('wln #ds wln  neg  6 kio  #ds wln  add', SP)
    and RPN('dup (Date Difference: ) wrt wrt (seconds.) wrt wln', SP) ;
  end {F_dd} ;


function F_dy(var SP : PLET) : boolean ; FAR ;
begin F_dy :=
    RPN('(F_dy.) wrt wln', SP)
    and RPN('2000 1 1 0 0 0 #ds   #dt wln #ds sub', SP)
    and RPN('( Secs to go to Y2k :) wrt dup wrt wln', SP)
    and RPN('0 1 1 0 0 0 #ds add  #sd', SP)
    and RPN('( Y/M/D - h:m:s until Year 2000 :  ) wrt', SP)
    and RPN('5 oik wrt  (/ ) wrt  4 oik dec wrt  (/ ) wrt  3 oik dec wrt', SP)
    and RPN('( - ) wrt', SP)
    and RPN('2 oik wrt  (: ) wrt  1 oik  wrt  (: ) wrt  0 oik  wrt', SP)
    and RPN('wln', SP) ;
  end {F_dy} ;


function F_fn(var SP : PLET) {Fibonacci} : boolean ; FAR ;
{ F1=F2=1 here; some say F0=F1=1 }
begin F_fn := RPN('0 1 (pop dup 2 oik add) 2 4 oik for 1 oik pop', SP) ;
  end {F_fn} ;


function F_f9(var SP : PLET) : boolean ; FAR ;
const
{ For N4 N5 N6, see D.Tel. 21/06/90 p.4 -
  N4*N5*N6 factored using 1000 computers 2«mths at DEC. }
N4 = '2,424,833' ;
N5 = '7,455,602,825,647,884,208,337,395,736,200,454,918,783,366,342,657' ;
N6 =            '741,640,062,627,530,801,524,787,141,'
  + '901,937,474,059,940,781,097,519,023,905,821,316,'
  + '144,415,759,504,705,008,092,818,711,693,940,737' ;
{ N4*N5*N6=N7 = F9, 9th Fermat number, 2^(2^9)+1 }
N7 =
  '13,407,807,929,942,597,099,574,024,998,205,846,127,479,365,820,592,393,'
  +'377,723,561,443,721,764,030,073,546,976,801,874,298,166,903,427,690,'
  +'031,858,186,486,050,853,753,882,811,946,569,946,433,649,006,084,097' ;
var SPin : PLET ;
procedure CheckSP ;
begin if SP<>SPin then Send(' Stack Pointer changed, '^G) ;
  More end {CheckSP} ;

begin F_f9 := true ; SPin := SP ;
  if not RPN('(F_f9. Store constants: factors N4 N5 N6, N7=F9: ) wrt ',
    SP) then EXIT ;
  { Store N4..N7 in Q4..Q7 }
  if not RPN('/q4 '+N4+' def  /q5 '+N5+' def  /q6 '+N6+' def', SP) then EXIT ;
  if not RPN('/q7 '+N7+' def  wln', SP) then EXIT ;
  {  CheckSP ;  }

  if not ( { Generate q2=2 and qm=9 from 1, to work in all bases:}
    RPN('/q2 1 inc def  q2 inc dup mul pop', SP)
    and RPN('(Calculate the Ninth Fermat Number, F9, as 2^(2^9)+1) wrt', SP)
    and RPN('wln  /q9 q2 q2 qm pow pow inc wts def wln', SP) ) then EXIT ;
  CheckSP ;

  if not (
    RPN('(Calculate F0..F9 independently as 2^(2^n)+1) wrt wln', SP)
    and RPN('wrs (wts q2 swp pow q2 swp pow inc wrt wln) 0 9 for', SP) )
    then EXIT;

  if not
    RPN('(Check Q9=F9 - discrepancy is ) wrt  q9 q7 cmp wrt', SP)
    then EXIT ;
  CheckSP ;

  if not (
    RPN('(Multiply the given factors of F9) wrt wln', SP)
    and RPN('/q0  q4 q5 q6 mul mul  wts def wln', SP)
    and RPN('(Check Q0=Q9 - discrepancy is ) wrt  q0 q9 cmp wrt', SP) )
    then EXIT ;
  CheckSP ;

  if not (
    RPN('(Divide F9 by each factor:) wrt wln', SP)
    and RPN('/q8 ( div wrt wln (Remainder ) wrt qr wrt wln) def', SP)
    and RPN('q9 (By N4: ) wrt q4 q8 exe', SP)
    and RPN('q9 (By N5: ) wrt q5 q8 exe', SP)
    and RPN('q9 (By N6: ) wrt q6 q8 exe', SP)
    and
    RPN('(And by all three in turn:) wrt wln', SP)
    and RPN('(F9 ) wrt q9 wts wln', SP)
    and RPN('/q8 ( div wts wln (Remainder ) wrt qr wrt wln) def', SP)
    and RPN('(By N4: ) wrt q4 q8 exe', SP)
    and RPN('(By N5: ) wrt q5 q8 exe', SP)
    and RPN('(By N6: ) wrt q6 q8 exe', SP)
    and RPN('(Check Ans=1 - discrepancy is ) wrt  1 cmp wrt', SP) )
    then EXIT ;
  CheckSP ;

  if not (
    RPN('(Repeated Square Roots of F9 - slow) wrt wln', SP)
    and RPN('(F9 ) wrt q9 wts wln  ', SP)
    and RPN('(wrt srt wts wln) 1 9 for', SP)
    and RPN('(Check Ans=2 - discrepancy is ) wrt 2 cmp wrt', SP) )
    then EXIT ;
  CheckSP ;

  end {F_f9} ;



function F_ms(var SP : PLET) : boolean ; FAR ;
begin F_ms := false ;
  if not RPN('678881 add 86400 mul', SP)
    then begin Send(' in F_ms,') ; EXIT end ;
  F_ms := true end {F_ms} ;


function F_sm(var SP : PLET) : boolean ; FAR ;
begin F_sm := false ;
  if not RPN('86400 div 678881 sub', SP)
    then begin Send(' in F_sm,') ; EXIT end ;
  F_sm := true end {F_sm} ;


function Fncr(var SP : PLET) : boolean ; FAR ;
begin Fncr := false ;
  if not RPN('swp dup fac  2 oik dup fac  3 oik 2 oik sub fac  mul div', SP)
    then begin Send(' in Fncr,') ; EXIT end ;
  Fncr := true end {Fncr} ;


function Fhcf(var SP : PLET) : boolean ; FAR ;
begin Fhcf := false ;
  if not (RPN('dup 2 oik dup 3 oik sub (swp) nol'
    + ' (dup 2 kio mod) whl pop', SP))
    then begin Send(' in Fhcf,') ; EXIT end ;
  Fhcf := true end {Fhcf} ;


function Flcm(var SP : PLET) : boolean ; FAR ;
begin Flcm := false ;
  if not (RPN('dup 2 oik dup 3 oik mul 2 kio hcf div', SP))
    then begin Send(' in Flcm,') ; EXIT end ;
  Flcm := true end {Flcm} ;


function F_ge(var SP : PLET) : boolean ; FAR ; {Gregorian Easter }
begin F_ge := false ;
  (* Claus Tondering, as in paschal.pas :
    G = year mod 19
    C = year/100
    H = (C - C/4 - (8*C+13)/25 + 19*G + 15) mod 30
    I = H - (H/28)*(1 - (H/28)*(29/(H + 1))*((21 - G)/11))
    J = (year + year/4 + I + 2 - C + C/4) mod 7
    L = I - J
    EasterMonth = 3 + (L + 40)/44
    EasterDay = L + 28 - 31*(EasterMonth/4) *)
  if not (RPN('/q0 fed', SP) {q0 := Year}
    and RPN('/q1  q0 19 mod  def', SP) {q1 := G}
    and RPN('/q2  q0 100 div  def', SP) {q2 := C}
    and RPN('/q3  q2  q2 4 div sub  8 q2 mul 13 add 25 div sub '+
    ' 19 q1 mul  add  15 add  30 mod  def', SP) {q3 := H}
    and RPN('/q4  q3 '+
    ' q3 28 div '+
    ' 1  q3 28 div  29 q3 inc div  mul nop  21 q1 sub 11 div  mul '+
    '   sub  mul  sub  def', SP) {q4 := I}
    and RPN('/q5  q0  q0 4 div  add q4 add  2 add  q2 sub  q2 4 div add '+
    ' 7 mod  def', SP) {q5 := J}
    and RPN('/q6  q4 q5 sub  def', SP) {q6 := L}
    and RPN('/q7  3  q6 40 add 44 div  add  def', SP) {q7 := Month}
    and RPN('/q8  q6  28 add  31 q7 4 div mul sub  def', SP) {q8 := Day}
    (*
    and RPN('wln ((Y) wrt q0 wrt tab) pop  (G) wrt q1 wrt tab', SP)
    and RPN('(C) wrt q2 wrt tab (H) wrt q3 wrt tab', SP)
    and RPN('(I) wrt q4 wrt tab (J) wrt q5 wrt tab (L) wrt q6 wrt wln ', SP)
    *)
    and RPN(' q8  q7', SP) {stack them}
    ) then begin Send(' in F_ge,') ; EXIT end ;
  F_ge := true end {F_ge} ;


function F_eg(var SP : PLET) : boolean ; FAR ; {Gregorian Easter }
begin F_eg := false ;
  (* E G Richards, as in paschal.pas : Algorithm P+Q :
    A = Y/100
    B = A - A/4
    C = MOD(Y,19)
    D = MOD(15 + 19*C + B - (A - (A - 17)/25)/3,30)
    E = D - (C+11*D)/319
    S = 22 + E + MOD(140004 - Y - Y/4 + B - E,7)
    M = 3 + S/32
    D = 1 + MOD(S-1,31)
    *)
  if not (RPN('/q0 fed', SP) {q0 := Year}
    and RPN('/q1  q0 100 div  def', SP) {q1 := A}
    and RPN('/q2  q1 dup 4 div sub  def', SP) {q2 := B}
    and RPN('/q3  q0 19 mod  def', SP) {q3 := C}
    and RPN('/q4'+
    ' 15  19 q3 mul add  q2  add  q1  q1 17 sub 25 div sub  3 div  sub'+
    ' 30 mod  def', SP) {q4 := D}
    and RPN('/q5  q4  q3 11 q4 mul add 319 div  sub  def', SP) {q5 := E}
    and RPN('/q6  22 q5 add'+
    ' 140004 q0 sub q0 4 div sub q2 add q5 sub'+
    ' 7 mod  add  def', SP) {q6 := S}
    and RPN('/q7  3  q6 32 div  add  def', SP) {q7 := M}
    and RPN('/q8  1  q6 dec 31 mod  add  def', SP) {q8 := D}
    (*
    and RPN('wln ((Y) wrt q0 wrt tab) pop  (A) wrt q1 wrt tab', SP)
    and RPN('(B) wrt q2 wrt tab (C) wrt q3 wrt tab', SP)
    and RPN('(D) wrt q4 wrt tab (E) wrt q5 wrt tab (S) wrt q6 wrt wln ', SP)
    *)
    and RPN(' q8  q7', SP) {stack them}
    ) then begin Send(' in F_eg,') ; EXIT end ;
  F_eg := true end {F_eg} ;


function F_pi(var SP : PLET) : boolean ; FAR ;
{ Bailey-Borwein-Plouffe : Pi = sum from n=0 to infinity of
  (4/(8n+1) - 2/(8n+4) - 1/(8n+5) - 1/(8n+6)) / 16**n
  http://www.mathsoft.com/asolve/plouffe/plouffe.html }
{ Parameters to #pi : ~repeats, multiplier }
{ for any base: }
{ q0 scale; q1 result; q2 2; q3 term; q4 4; q5 16^n; q6; q7; q8 8; q9 16 }
begin F_pi :=
    RPN('(F_pi. ) wrt wln /q0 fed  /q1 0 def', SP) { multiplier result }
    and RPN('1 dup add dup /q2 fed  dup add dup /q4 fed', SP) { 2 4 }
    and RPN('  dup add dup /q8 fed  dup add     /q9 fed', SP) { 8 16 }
    and RPN('/q5 1 def', SP)
    and RPN('/q3 (q8 mul inc  dup q0 q4 mul swp div swp ' +
    ' inc inc inc  dup q0 q2 mul swp div swp ' +
    ' inc dup q0 swp div swp ' +
    ' inc     q0 swp div  add add sub  q5 div) def', SP) {term}
    and RPN('(q3 exe  q1 add dup /q1 fed wrt wln /q5 q5 q9 mul def) ' +
    {    ' 0 20 for', SP) ; }
    ' 0 2 oik for', SP) ;
  end {F_pi} ;




function FINS(var SP : PLET) : boolean ; FAR ;
var PL : PTList ; const S = ' in FINS,' ;
begin FINS := false ;
  New(PL) ; if PL=NIL then begin Send(' Heap:' + S) ; EXIT end ;
  with PL^ do begin
    Prev := NIL ; Next := BList ; if Next<>NIL then Next^.Prev := PL ;
    BList := PL ;
    New(POpt) ; if POpT=NIL then begin Send(' Heap:' + S) ; EXIT end ;
    with POpT^ do begin Proc := false ;
      Aid := SP^.D.Tptr^ ;
      if not Pop(SP) then begin Send(S) ; EXIT end ;
      Pgen := PS40(SP^.D.Tptr) ; SP^.D.Tptr := NIL ;
      if not Pop(SP) then begin Send(S) ; EXIT end ;
      Sk := SP^.D.Tptr^ ;
      if not Pop(SP) then begin Send(S) ; EXIT end ;
      Task := SP^.D.Tptr ; SP^.D.Tptr := NIL ;
      if not Pop(SP) then begin Send(S) ; EXIT end ;
      Cmnd := SP^.D.Tptr^ ;
      if not Pop(SP) then begin Send(S) ; EXIT end ;
      end {POpT^} ;
    end {PL^} ;
  FINS := true end {FINS} ;


function FOUT(var SP : PLET) : boolean ; FAR ;
var IOR : integer ; S10 : string [10] ;
const S = ' in FOUT,' ;
begin FOUT := false ;
  Close(Fo) ; Assign(Fo, SP^.D.Tptr^) ;
  if not Pop(SP) then begin Send(S) ; EXIT end ;
  {$I-} Rewrite(Fo) ; IOR := IOResult {$I+} ;
  if IOR<>0 then begin
    Assign(Fo, '') ; Append(Fo) ;
    Str(IOR, S10) ; Send(' IOResult ' + S10 + S) ; EXIT end ;
  FOUT := true end {FOUT} ;


procedure StartList ;

const      { 0123456789012345678901234567890123456789 }
_nop : S40 = 'NoOP - do nothing' ;
_pip : S40 = 'just PIP the speaker - ^G' ;
_tix : S40 = 'push : P: TIX from $40:$6C; D: mls/55' ;
_mls : S40 = 'push MiLliSecs, P:tix*55 D:gettickcount' ;
{$IFDEF DELPHI} _cpu : S40 = 'rdtsc - CPU clock cycles' ; {$ENDIF}
_err : S40 = 'ERRor - do nothing, and fail' ;
_hlt : S40 = 'HaLT - kill the Pascal/Delphi program' ;
_all : S40 = 'show ALL q-variables and stack' ;
_var : S40 = 'show all q-VARiables' ;
_stk : S40 = 'show all STacK' ;
_cls : S40 = 'CLear Stack' ;
_clq : S40 = 'CLear all Q-variables' ;

_try : S40 = 'used for testing' ;

_rze : S40 = 'RandomiZE (as Pascal)' ;
_rnd : S40 = 'Random Number (as Pascal)' ;
_rdd : S40 = 'RanDom number of n Digits (~ log dist)' ;
_neg : S40 = 'NEGate top of stack' ;
_val : S40 = 'convert numerical string to VALue' ;
_str : S40 = 'convert numerical value to STRing' ;
_abs : S40 = 'ABSolute value of top of stack' ;
_inc : S40 = 'INCrement top of stack or q#-reg' ;
_dec : S40 = 'DECrement top of stack or q#-reg' ;
_pop : S40 = 'POP top of stack off' ;
_dup : S40 = 'DUPlicate top of stack' ;
_fac : S40 = 'push FACtorial' ;
_srt : S40 = 'Square RooT, also sets qd,qr' ;
_len : S40 = 'push LENgth of string or number' ;

_wln : S40 = 'Write LiNe' ;
_wrs : S40 = 'WRite Space' ;
_tab : S40 = 'write TAB' ;
_wrt : S40 = 'WRite Top of stack and pop it' ;
_wts : S40 = 'Write Top element of Stack' ;
_wns : S40 = 'Write N''th of Stack (top=#0)' ;

_and : S40 = 'AND, result to ToS' ;
_oar : S40 = 'OR, result to ToS' ;
_xor : S40 = 'XOR, result to ToS' ;
_not : S40 = 'NOT, result to ToS' ;
_imp : S40 = 'IMPLIES, result to ToS' ;

_add : S40 = 'ADD, sum to ToS & qa' ;
_min : S40 = 'MINimum to ToS' ;
_max : S40 = 'MAXimum to ToS' ;
_cmp : S40 = 'CoMPare - result in [-1, 0, +1]' ;
_mag : S40 = 'MAGnitude (unsigned) number compare' ;
_sub : S40 = 'SUBtract, diff to ToS & qs' ;
_mul : S40 = 'MULtiply - product to ToS & qm' ;
_div : S40 = 'DIVide - quot to ToS & qd, rem to qr' ;
_mod : S40 = 'MODulus - rem to ToS & qr, quot to qd' ;
_pow : S40 = 'number to non-negative integer POWer' ;
_shl : S40 = 'SHift Left, digitwise' ;
_shr : S40 = 'SHift Right, digitwise' ;

_swp : S40 = 'SWaP top two elements of stack' ;
_oik : S40 = 'roll +n : move n''th of stack to top' ;
_dig : S40 = 'push +n : copy n''th of stack to top' ;
_kio : S40 = 'roll -n : move top to n''th of stack' ;

_def : S40 = 'DEFine : pop ToS data & /Q#-addr, store' ;
_fed : S40 = 'reverse DEF : equivalent to swp def' ;
_sbs : S40 = 'SuBString y chars, starting at x, of t' ;
_cat : S40 = 'conCATenate two strings' ;

_exe : S40 = 'EXEcute a string - subroutine call' ;
_for : S40 = 'FOR z := x to y do (push z, execute t)' ;
_if0 : S40 = 'IF a is 0, execute t' ;
_no0 : S40 = 'if a NOt 0, execute t' ;
_ifG : S40 = 'IF a is Greater than 0, execute t' ;
_noG : S40 = 'if a NOt Greater than 0, execute t' ;
_ifL : S40 = 'IF a is Less than 0, execute t' ;
_noL : S40 = 'if a NOt Less than 0, execute t' ;
_ctu : S40 = 'ConTinUe - skip rest of current RPN' ;
_whl : S40 = 'WHiLe - pop & execute while ToS<>0' ;

_ncr : S40 = 'nCr - combinations of r objects from n' ;
_hcf : S40 = 'Highest Common Factor' ;
_lcm : S40 = 'Lowest Common Multiple' ;
__f9 : S40 = 'Fermat number factorisation tests - F9' ;
__fn : S40 = 'Fibonacci Number a - 1 1 2 3 5 8 13 ..' ;
__pi : S40 = 'PI by Bailey-Borwein-Plouffe algorithm' ;

__sd : S40 = 'Seconds from 0000/03/01 0s to Date' ;
__ds : S40 = 'Date to Seconds from 0000/03/01 0s' ;
__sm : S40 = 'Seconds from 0000/03/01 0s to MJD' ;
__ms : S40 = 'MJD to Seconds from 0000/03/01 0s' ;
__dw : S40 = 'Day of Week (Sun=0), from seconds' ;
__ws : S40 = 'Day of Week (Sun=0) to string' ;
__uf : S40 = 'Unix Fail, seconds from 1970/01/01 0s' ;
__sa : S40 = 'Seconds Add, to date' ;
__dt : S40 = 'push present Date/Time' ;
__us : S40 = 'push Unix Start date/time' ;
__dd : S40 = 'Date Difference, in seconds' ;
__dy : S40 = 'Duration to Year2000' ;
__ge : S40 = 'Gregorian Easter (Claus Tondering)' ;
__eg : S40 = 'EG Richards'' Gregorian Easter' ;
_KEY : S40 = 'KEY - read rpn line from keyboard' ;
_SCR : S40 = 'SCRipt - read rpn file named at ToS' ;
_INS : S40 = 'TLA RPN-code Paracheck Words I/O INS' ;
_OUT : S40 = 'file/device name for RPN OUTput' ;
_con : S40 = 'Commas ON in write number (default)' ;
_cof : S40 = 'Commas OFF in write number' ;
_bas : S40 = 'change number BASe (incl. stk,regs)' ;
_edp : S40 = 'Environment Depth Parameter' ;

{$IFDEF BORPAS}
_gnv : S40 = 'Get eNVironment string' ;
_pnv : S40 = 'Put eNVironment string' ;
{$ENDIF}

const T = true ;
Defs : array [0..93
  {$IFDEF BORPAS} +1 {$IFDEF MSDOS} +2 {$ENDIF} {$ENDIF}
  {$IFDEF DELPHI} +1 {$ENDIF}
  ] of OpT = (
  (Cmnd : 'nop' ; Task : @Fnop ; Proc : T ; Sk :    '' ;
  {  } Pgen : @_nop ; Aid : 'nop'),
  (Cmnd : 'tix' ; Task : @Ftix ; Proc : T ; Sk :    '' ;
  {  } Pgen : @_tix ; Aid : 'tix x'),
  (Cmnd : 'mls' ; Task : @Fmls ; Proc : T ; Sk :    '' ;
  {  } Pgen : @_mls ; Aid : 'mls x'),
  {$IFDEF DELPHI}
  (Cmnd : 'cpu' ; Task : @Fcpu2 ; Proc : T ; Sk :    '' ;
  {  } Pgen : @_cpu ; Aid : 'cpu x'),
  {$ENDIF}
  (Cmnd : 'err' ; Task : @Ferr ; Proc : T ; Sk :    '' ;
  {  } Pgen : @_err ; Aid : 'err'),
  (Cmnd : 'all' ; Task : @Fall ; Proc : T ; Sk :    '' ;
  {  } Pgen : @_all ; Aid : 'all'),
  (Cmnd : 'stk' ; Task : @Fstk ; Proc : T ; Sk :    '' ;
  {  } Pgen : @_stk ; Aid : 'stk'),
  (Cmnd : 'var' ; Task : @Fvar ; Proc : T ; Sk :    '' ;
  {  } Pgen : @_var ; Aid : 'var'),
  (Cmnd : 'cls' ; Task : @Fcls ; Proc : T ; Sk :    '' ;
  {  } Pgen : @_cls ; Aid : '*** cls'),
  (Cmnd : 'clq' ; Task : @Fclq ; Proc : T ; Sk :    '' ;
  {  } Pgen : @_clq ; Aid : 'clq'),
  (Cmnd : 'wln' ; Task : @Fwln ; Proc : T ; Sk :    '' ;
  {  } Pgen : @_wln ; Aid : 'wln'),
  (Cmnd : 'wrs' ; Task : @Fwrs ; Proc : T ; Sk :    '' ;
  {  } Pgen : @_wrs ; Aid : 'wrs'),
  (Cmnd : 'tab' ; Task : @Ftab ; Proc : T ; Sk :    '' ;
  {  } Pgen : @_tab ; Aid : 'tab'),
  (Cmnd : 'rdd' ; Task : @Frdd ; Proc : T ; Sk :   'a' ;
  {  } Pgen : @_rdd ; Aid : 'x rdd X'),
  (Cmnd : 'rze' ; Task : @Frze ; Proc : T ; Sk :    '' ;
  {  } Pgen : @_rze ; Aid : 'rze'),
  (Cmnd : 'rnd' ; Task : @Frnd ; Proc : T ; Sk :   'a' ;
  {  } Pgen : @_rnd ; Aid : 'x rnd x'),
  (Cmnd : 'val' ; Task : @Fval ; Proc : T ; Sk :   't' ;
  {  } Pgen : @_val ; Aid : 't val x'),
  (Cmnd : 'str' ; Task : @Fstr ; Proc : T ; Sk :   'a' ;
  {  } Pgen : @_str ; Aid : 'x str s'),
  (Cmnd : 'neg' ; Task : @Fneg ; Proc : T ; Sk :   'a' ;
  {  } Pgen : @_neg ; Aid : 'x neg x'),
  (Cmnd : 'abs' ; Task : @Fabs ; Proc : T ; Sk :   'a' ;
  {  } Pgen : @_abs ; Aid : 'x abs x'),
  (Cmnd : 'inc' ; Task : @Finc ; Proc : T ; Sk :   '*' ;
  {  } Pgen : @_inc ; Aid : 'x inc x'),
  (Cmnd : 'dec' ; Task : @Fdec ; Proc : T ; Sk :   '*' ;
  {  } Pgen : @_dec ; Aid : 'x dec x'),
  (Cmnd : 'pop' ; Task : @Fpop ; Proc : T ; Sk :   '*' ;
  {  } Pgen : @_pop ; Aid : 'x pop'),
  (Cmnd : 'dup' ; Task : @Fdup ; Proc : T ; Sk :   '*' ;
  {  } Pgen : @_dup ; Aid : 'x dup x x'),
  (Cmnd : 'fac' ; Task : @Ffac ; Proc : T ; Sk :   'a' ;
  {  } Pgen : @_fac ; Aid : 'x fac x'),
  (Cmnd : 'srt' ; Task : @Fsrt ; Proc : T ; Sk :   'a' ;
  {  } Pgen : @_srt ; Aid : 'x srt x'),
  (Cmnd : 'len' ; Task : @Flen ; Proc : T ; Sk :   '*' ;
  {  } Pgen : @_len ; Aid : '? len n'),
  (Cmnd : 'wrt' ; Task : @Fwrt ; Proc : T ; Sk :   '*' ;
  {  } Pgen : @_wrt ; Aid : '* wrt'),
  (Cmnd : 'wts' ; Task : @Fwts ; Proc : T ; Sk :   '*' ;
  {  } Pgen : @_wts ; Aid : '* wts *'),
  (Cmnd : 'wns' ; Task : @Fwns ; Proc : T ; Sk :  'a*' ;
  {  } Pgen : @_wns ; Aid : '* ... n wns * ...'),
  (Cmnd : 'shl' ; Task : @Fshl ; Proc : T ; Sk :  'aa' ;
  {  } Pgen : @_shl ; Aid : 'x n shl x'),
  (Cmnd : 'shr' ; Task : @Fshr ; Proc : T ; Sk :  'aa' ;
  {  } Pgen : @_shr ; Aid : 'x n shr x'),
  (Cmnd : 'min' ; Task : @Fmin ; Proc : T ; Sk :  'aa' ;
  {  } Pgen : @_min ; Aid : 'x y min x|y'),
  (Cmnd : 'max' ; Task : @Fmax ; Proc : T ; Sk :  'aa' ;
  {  } Pgen : @_max ; Aid : 'x y max x|y'),
  (Cmnd : 'cmp' ; Task : @Fcmp ; Proc : T ; Sk :  '**' ;
  {  } Pgen : @_cmp ; Aid : 'x y cmp x=y'),
  (Cmnd : 'mag' ; Task : @Fmag ; Proc : T ; Sk :  'aa' ;
  {  } Pgen : @_mag ; Aid : 'x y mag |x|=|y|'),

  (Cmnd : 'add' ; Task : @Fadd ; Proc : T ; Sk :  'aa' ;
  {  } Pgen : @_add ; Aid : 'x y add x+y'),

  (Cmnd : 'and' ; Task : @Fand ; Proc : T ; Sk :  'aa' ;
  {  } Pgen : @_and ; Aid : 'x y and xANDy'),
  (Cmnd : 'xor' ; Task : @Fxor ; Proc : T ; Sk :  'aa' ;
  {  } Pgen : @_xor ; Aid : 'x y xor xXORy'),
  (Cmnd : 'oar' ; Task : @Foar ; Proc : T ; Sk :  'aa' ;
  {  } Pgen : @_oar ; Aid : 'x y oar xORy'),
  (Cmnd : 'not' ; Task : @Fnot ; Proc : T ; Sk :  'a' ;
  {  } Pgen : @_not ; Aid : 'x not NOTx'),
  (Cmnd : 'imp' ; Task : @Fimp ; Proc : T ; Sk :  'aa' ;
  {  } Pgen : @_imp ; Aid : 'x y imp xIMPy ?'),

  (Cmnd : 'sub' ; Task : @Fsub ; Proc : T ; Sk :  'aa' ;
  {  } Pgen : @_sub ; Aid : 'x y sub x-y'),
  (Cmnd : 'mul' ; Task : @Fmul ; Proc : T ; Sk :  'aa' ;
  {  } Pgen : @_mul ; Aid : 'x y mul x*y'),
  (Cmnd : 'div' ; Task : @Fdiv ; Proc : T ; Sk :  'aa' ;
  {  } Pgen : @_div ; Aid : 'x y div x/y'),
  (Cmnd : 'mod' ; Task : @Fmod ; Proc : T ; Sk :  'aa' ;
  {  } Pgen : @_mod ; Aid : 'x y mod x|y'),
  (Cmnd : 'pow' ; Task : @Fpow ; Proc : T ; Sk :  'aa' ;
  {  } Pgen : @_pow ; Aid : 'x n pow x^n'),
  (Cmnd : 'swp' ; Task : @Fswp ; Proc : T ; Sk :  '**' ;
  {  } Pgen : @_swp ; Aid : 'x y swp y x'),
  (Cmnd : 'oik' ; Task : @Foik ; Proc : T ; Sk :  'a*' ;
  {  } Pgen : @_oik ; Aid : '* ... n oik  ... *'),
  (Cmnd : 'dig' ; Task : @Fdig ; Proc : T ; Sk :  'a*' ;
  {  } Pgen : @_dig ; Aid : '* ... n dig  ... *'),
  (Cmnd : 'kio' ; Task : @Fkio ; Proc : T ; Sk :  'a*' ;
  {  } Pgen : @_kio ; Aid : '* ... n kio  ... *'),
  (Cmnd : 'def' ; Task : @Fdef ; Proc : T ; Sk :  '*q' ;
  {  } Pgen : @_def ; Aid : '/Qn * def'),
  (Cmnd : 'fed' ; Task : @Ffed ; Proc : T ; Sk :  'q*' ;
  {  } Pgen : @_fed ; Aid : '* /Qn fed'),
  (Cmnd : 'cat' ; Task : @Fcat ; Proc : T ; Sk :  'tt' ;
  {  } Pgen : @_cat ; Aid : 't t cat t'),
  (Cmnd : 'sbs' ; Task : @Fsbs ; Proc : T ; Sk : 'aat' ;
  {  } Pgen : @_sbs ; Aid : 't x y sbs t'),

  (Cmnd : 'exe' ; Task : @Fexe ; Proc : T ; Sk :   't' ;
  {  } Pgen : @_exe ; Aid : 't exe ...'),
  (Cmnd : 'for' ; Task : @Ffor ; Proc : T ; Sk : 'aat' ;
  {  } Pgen : @_for ; Aid : 't x y for ...'),
  (Cmnd : 'if0' ; Task : @Fif0 ; Proc : T ; Sk :  'ta' ;
  {  } Pgen : @_if0 ; Aid : 'a t if0 ...'),
  (Cmnd : 'no0' ; Task : @Fno0 ; Proc : T ; Sk :  'ta' ;
  {  } Pgen : @_no0 ; Aid : 'a t no0 ...'),
  (Cmnd : 'ifl' ; Task : @FifL ; Proc : T ; Sk :  'ta' ;
  {  } Pgen : @_ifL ; Aid : 'a t ifL ...'),
  (Cmnd : 'nol' ; Task : @FnoL ; Proc : T ; Sk :  'ta' ;
  {  } Pgen : @_noL ; Aid : 'a t noL ...'),
  (Cmnd : 'ifg' ; Task : @FifG ; Proc : T ; Sk :  'ta' ;
  {  } Pgen : @_ifG ; Aid : 'a t ifG ...'),
  (Cmnd : 'nog' ; Task : @FnoG ; Proc : T ; Sk :  'ta' ;
  {  } Pgen : @_noG ; Aid : 'a t noG ...'),
  (Cmnd : 'whl' ; Task : @Fwhl ; Proc : T ; Sk :  'ta' ;
  {  } Pgen : @_whl ; Aid : 'a t whl'),

  (Cmnd : 'ncr' ; Task : @Fncr ; Proc : T ; Sk :  'aa' ;
  {  } Pgen : @_ncr ; Aid : 'a a ncr a'),
  (Cmnd : 'hcf' ; Task : @Fhcf ; Proc : T ; Sk :  'aa' ;
  {  } Pgen : @_hcf ; Aid : 'a a hcf a'),
  (Cmnd : 'lcm' ; Task : @Flcm ; Proc : T ; Sk :  'aa' ;
  {  } Pgen : @_lcm ; Aid : 'a a lcm a'),
  (Cmnd : '#f9' ; Task : @F_f9 ; Proc : T ; Sk :    '' ;
  {  } Pgen : @__f9 ; Aid : '#f9'),
  (Cmnd : '#fn' ; Task : @F_fn ; Proc : T ; Sk :   'a' ;
  {  } Pgen : @__fn ; Aid : 'a #fn'),
  (Cmnd : '#pi' ; Task : @F_pi ; Proc : T ; Sk :  'aa' ;
  {  } Pgen : @__pi ; Aid : 'a #pi'),
  (Cmnd : '#sd' ; Task : @F_sd ; Proc : T ; Sk :   'a' ;
  {  } Pgen : @__sd ; Aid : 'x #sd y m d h m s'),
  (Cmnd : '#ds' ; Task : @F_ds ; Proc : T ; Sk : 'aaaaaa' ;
  {  } Pgen : @__ds ; Aid : 'y m d h m s #ds x'),

  (Cmnd : '#sm' ; Task : @F_sm ; Proc : T ; Sk :   'a' ;
  {  } Pgen : @__sm ; Aid : 'x #sm d'),
  (Cmnd : '#ms' ; Task : @F_ms ; Proc : T ; Sk :   'a' ;
  {  } Pgen : @__ms ; Aid : 'd #ms x'),

  (Cmnd : '#dw' ; Task : @F_dw ; Proc : T ; Sk :   'a' ;
  {  } Pgen : @__dw ; Aid : 's #dw n'),
  (Cmnd : '#ws' ; Task : @F_ws ; Proc : T ; Sk :   'a' ;
  {  } Pgen : @__ws ; Aid : 'n #ws t'),
  (Cmnd : '#uf' ; Task : @F_uf ; Proc : T ; Sk :   'a' ;
  {  } Pgen : @__uf ; Aid : 'x #uf y m d h m s'),
  (Cmnd : '#sa' ; Task : @F_sa ; Proc : T ; Sk : 'aaaaaaa' ;
  {  } Pgen : @__sa ; Aid : 'y m d h m s s #sa y m d h m s'),
  (Cmnd : '#dt' ; Task : @F_dt ; Proc : T ; Sk :    '' ;
  {  } Pgen : @__dt ; Aid : '#dt y m d h m s'),
  (Cmnd : '#us' ; Task : @F_us ; Proc : T ; Sk :    '' ;
  {  } Pgen : @__us ; Aid : '#us 1970 1 1 0 0 0'),
  (Cmnd : '#dd' ; Task : @F_dd ; Proc : T ; Sk : 'aaaaaaaaaaaa' ;
  {  } Pgen : @__dd ; Aid : 'y m d h m s y m d h m s #dd'),
  (Cmnd : '#dy' ; Task : @F_dy ; Proc : T ; Sk :    '' ;
  {  } Pgen : @__dy ; Aid : '#dy'),
  (Cmnd : '#ge' ; Task : @F_ge ; Proc : T ; Sk :   'a' ;
  {  } Pgen : @__ge ; Aid : 'y #ge m d'),
  (Cmnd : '#eg' ; Task : @F_eg ; Proc : T ; Sk :   'a' ;
  {  } Pgen : @__eg ; Aid : 'y #eg m d'),
  (Cmnd : 'ctu' ; Task :   NIL ; Proc : T ; Sk :    '' ;
  {  } Pgen : @_ctu ; Aid : 'ctu'),
  (Cmnd : 'INS' ; Task : @FINS ; Proc : T ; Sk : 'ttttt' ;
  {  } Pgen : @_INS ; Aid : 't t t t t INS'),
  (Cmnd : 'OUT' ; Task : @FOUT ; Proc : T ; Sk : 't' ;
  {  } Pgen : @_OUT ; Aid : 't OUT'),
  (Cmnd : 'KEY' ; Task : @FKEY ; Proc : T ; Sk :    '' ;
  {  } Pgen : @_KEY ; Aid : 'KEY ...'),
  (Cmnd : 'SCR' ; Task : @FSCR ; Proc : T ; Sk :   't' ;
  {  } Pgen : @_SCR ; Aid : 't SCR ...'),

  (Cmnd : 'bas' ; Task : @Fbas ; Proc : T ; Sk :   'a' ;
  {  } Pgen : @_bas ; Aid : 'x bas'),

  (Cmnd : 'try' ; Task : @Ftry ; Proc : T ; Sk :    '' ;
  {  } Pgen : @_try ; Aid : '? try ?'),
  (Cmnd : 'pip' ; Task : @Fpip ; Proc : T ; Sk :    '' ;
  {  } Pgen : @_pip ; Aid : 'pip'),

  {$IFDEF BORPAS}
  (Cmnd : 'gnv' ; Task : @Fgnv ; Proc : T ; Sk :   't' ;
  {  } Pgen : @_gnv ; Aid : 't gnv t'),
  {$IFDEF MSDOS}
  (Cmnd : 'pnv' ; Task : @Fpnv ; Proc : T ; Sk :  'tt' ;
  {  } Pgen : @_pnv ; Aid : 't t pnv'),
  (Cmnd : 'edp' ; Task : @Fedp ; Proc : T ; Sk :   'a' ;
  {  } Pgen : @_edp ; Aid : 'x edp'),
  {$ENDIF} {$ENDIF}

  (Cmnd : 'cof' ; Task : @Fcof ; Proc : T ; Sk :    '' ;
  {  } Pgen : @_cof ; Aid : 'cof'),
  (Cmnd : 'con' ; Task : @Fcon ; Proc : T ; Sk :    '' ;
  {  } Pgen : @_con ; Aid : 'con'),

  (Cmnd : 'hlt' ; Task : @Fhlt ; Proc : T ; Sk :    '' ;
  {  } Pgen : @_hlt ; Aid : 'hlt')
  ) ;

var P : PTList ; J : byte ;
begin for J := High(Defs) downto Low(Defs) do begin
    New(P) ; if P=NIL then begin Send(' Heap Error.') ; HALT end ;
    with P^ do begin POpT := @Defs[J] ;
      Prev := NIL ; Next := BList ; if Next<>NIL then Next^.Prev := P ;
      BList := P end {P} ;
    end {J} ;
  end {StartList} ;



function InFail(TempSP : PLET ; const Sk, Atom : string) : boolean ;
procedure Wst ; begin Send(' InFail: "' + Atom + '" Stack ') end {Wst} ;
var N : byte ; S3 : string [3] ;
begin InFail := true ;
  for N := 1 to Length(Sk) do begin
    if TempSP=NIL then begin Wst ; Send(' argument underflow,') ; EXIT end ;
    if (Sk[N]<>'*') and (Sk[N]<>TempSP^.D.Sort) then begin Wst ; Str(N, S3) ;
      Send('type ' + TempSP^.D.Sort + ' @ ' + S3 +
        ' is RPN error, expect ' + Sk[N] + Spc) ; Sendln ;
      EXIT end ;
    TempSP := TempSP^.Next end {N} ;
  InFail := false end {InFail} ;



function Operate(const Atom : string ; var SP : PLET) : boolean ;
var P : PTList ; const S = ' in Operate,' ;
begin if Atom='' then RunError(229) ;
  Operate := false ;
  P := BList ;
  while P<>NIL do begin
    with P^, POpT^ do if Atom=Cmnd then begin
      if InFail(SP, Sk, Atom) then begin Stak(SP) ; Send(S) ; EXIT end ;
      if Proc then Operate := TaskFunc(Task)(SP)
        else Operate := RPN(PStr(Task)^, SP) ;
      if Prev<>NIL then SwapPtrs(POpT, Prev^.POpT) ;
      EXIT end {Cmnd} ;
    P := P^.Next end {P} ;
  Send(' Operate: "' + Atom + '" unknown,') end {Operate} ;



procedure DoHelp(Atom : string) ;
procedure Wr(Q : OpTP) ;
const S15 : string [15] = '               ' ;
begin with Q^ do begin S15[0] := char(15-Length(Sk)) ;
    Send(Spc + Cmnd + ':' + Spc + S15 + Sk + '        ' + Aid) ;
    Sendln end end {Wr} ;
var P : PTList ; K : byte ;
begin if (Atom='') or (Atom[1]<>'?') then RunError(230) ;
  if Atom='?' then begin Info ; EXIT end {Atom=?} ;
  if Atom='??' then begin Send(' Operators :') ;
    P := BList ;
    while P<>NIL do begin Write(P^.POpT^.Cmnd:4) ; P := P^.Next end ;
    Sendln ; EXIT end {Atom=??} ;
  if Atom='???' then begin
    Send('Operator: In-Types, OldStack opr NewStack -') ; Sendln ;
    P := BList ; K := 0 ;
    while P<>NIL do begin Wr(P^.POpT) ;
      Inc(K) ; if (K mod 20)=0 then More ;
      P := P^.Next end ;
    EXIT end {Atom=???} ;
  Delete(Atom, 1, 1) ; if Atom[1]='\' then Atom[1] := '#' ;
  P := BList ;
  while P<>NIL do begin
    with P^, POpT^ do if Atom=Cmnd then begin Wr(PopT) ;
      if Pgen<>NIL then Write('':6, Pgen^) ;
      Sendln ; EXIT end ;
    P := P^.Next end ;
  Send('** Unknown command "' + Atom + '" **') ; Sendln ;
  end {DoHelp} ;


function DoAtom(const Atom : string ; var SP : PLET) : boolean ;
begin if Atom='' then RunError(231) ;
  case Atom[1] of
    '1'..'9', '+', '-' : DoAtom := PushDecimalNumber(Atom, SP) ;
    '0' : DoAtom := PushLiteralNumber(Atom, SP) ;
    '(' : DoAtom := PushQuotedText(Atom, SP) ;
    '/' : DoAtom := PushQvarName(Atom, SP) ;
    'q' : DoAtom := PushQvarContent(Atom, SP) ;
    else DoAtom := Operate(Atom, SP) end ;
  end {DoAtom} ;


function GetAtom
  (const St : string ; var J : byte ; var Atom : string) : boolean ;
var xj : byte ; bc : shortint ; ch : char ;
begin GetAtom := false ; xj := J ; bc := 0 ;
  repeat ch := St[J] ; Inc(J) ;
    if ch='(' then Inc(bc) ;
    if ch=')' then Dec(bc) ;
    if bc<0 then begin Send(' GetAtom: Premature ")",') ; EXIT end ;
    if (bc=0) and ((ch=Spc) or (ch=')')) then BREAK ;
    until J>Length(St) ;
  if Ch=Spc then Dec(J) ;
  Atom := Copy(St, xj, J-xj) ;
  if bc>0 then begin Send(' GetAtom: Incomplete String,') ; EXIT end ;
  GetAtom := true end {GetAtom} ;



function RPN(const St : string ; var SP : PLET) : boolean ;
var Atom : string ; J : byte ;
procedure Bad ;
var K : byte ;
begin
  Send(' fail in') ; Sendln ;
  Send('** ''' + St + ''' **' {$IFNDEF GUI} + ^G {$ENDIF}) ; Sendln ;
  Send('**  ') ; for K := 2 to J do Send(Spc) ; Send('^ ') ;
  More end {Bad} ;
begin RPN := false ; J := 1 ;
  while J<=Length(St) do if St[J]<=Spc then Inc(J) else begin
    if St[J]=';' then BREAK ; (*****)
    if not GetAtom(St, J, Atom) then begin Bad ; EXIT end ;
    if Atom='ctu' {and ???} then begin BREAK end ;
    if Atom[1]='\' then Atom[1] := '#' { UK kbd without Keyb } ;
    if not DoAtom(Atom, SP) then begin Bad ; EXIT end ;
    end {J in St} ;
  RPN := true end {RPN} ;


function GetFree : string ;
{$IFDEF BORPAS} var P, Q : string [9] ; {$ENDIF}
begin
  {$IFDEF BORPAS}
  Str(MemAvail:8, P) ; Str(Sptr:6, Q) ; GetFree := P + Q ;
  {$ELSE} GetFree := '' ; {$ENDIF}
  end {GetFree} ;



procedure RPNcalc ;
{$IFDEF DELPHI} type TextRec = TTextRec ; {$ENDIF}
const S = ' in RPNcalc.' ;
var SP : PLET ; J : word ; Cmnd : string ;

{$IFDEF BORPAS}

function GetKbd : word ; assembler ;
asm  mov AH,0 ; int 16h  end {GetKbd} ;

function GetCols : byte ; assembler ;
asm  mov AH,$0F ; int 10h ; mov al,ah  end {GetCols} ;

procedure GotoXY(X, Y : byte) { Position Cursor } ; assembler ;
asm  mov ah,$02 ; mov bh,0 ; mov dh,Y ; mov dl,X ;
  { Michael Kennedy says some old systems may need Push BP, Pop BP }
  push BP ; int $10 ; pop BP  end {GotoXY} ;

function WhereY { Locate Cursor } : byte ; assembler ;
asm  mov ah,$03 ; mov bh,0 ;
  { Michael Kennedy says some old systems may need Push BP, Pop BP }
  push BP ; int $10 ; pop BP ; mov al,dh  end {WhereY} ;


const XH = 15 ;
var XCmnds : array [0..XH] of string ;


procedure PascalGetLine ;
var Len, KW : word ; LP, Cur : byte ; J, Row : 0..XH ; Ins : boolean ;
Prompt : string [31] ; St : string [9] ;
Cols, Y, DY : byte ;
begin
  Str(Base, St) ; Prompt := GetFree + ' ['+St+'] RPN (#) ? ' ;
  LP := Length(Prompt) ;
  Cmnd := '' ; Cur := 1 ; Row := 0 ; Ins := true ; Cols := GetCols;

  repeat
    Len := LP + Length(Cmnd);
    DY := (Len div Cols) ;
    for Y := 1 to DY do Write(^J) ;
    Y := WhereY - DY ;
    GotoXY(0, Y) ;
    Write(Prompt, Cmnd , '':(Pred(10*Cols)-Len) mod Cols) ;
    Len := Pred(LP)+Cur ;
    GotoXY(Len mod Cols, Y + Len div Cols) ;
    KW := GetKbd ;
    GotoXY(0, Y) ;
    case Lo(KW) of
      0 : case Hi(KW) of
        71 : {Home} Cur := 1 ;
        72 : {up} begin
          if (Row=0) and (Cmnd>'') then XCmnds[Row] := Cmnd ;
          if Row<XH then begin Write(Prompt, '':Length(Cmnd)) ;
            Inc(Row) ; Cmnd := XCmnds[Row] ; Cur := Succ(Length(Cmnd)) end ;
          end ;
        75 : {left} if Cur>1 then Dec(Cur) ;
        77 : {right} if Cur<=Length(Cmnd) then Inc(Cur) ;
        79 : {End} Cur := Succ(Length(Cmnd)) ;
        80 : {down} if Row>0 then begin Write(Prompt, '':Length(Cmnd)) ;
          Dec(Row) ; Cmnd := XCmnds[Row] ; Cur := Succ(Length(Cmnd)) end ;
        82 : {Insert} Ins := not Ins ;
        83 : {Del} if Cur<=Length(Cmnd) then Delete(Cmnd, Cur, 1) ;
        end {case Hi} ;
      3 : {^C} HALT ;
      8 : {BS} if Cmnd>'' then begin Dec(Cur) ; Delete(Cmnd, Cur, 1) end ;
      13 : {CR} BREAK ;
      27 : {ESC} begin Write(Prompt, '':Length(Cmnd)) ;
        Cmnd := '' ; Cur := 1 end ;
      else begin
        if not Ins then Delete(Cmnd, Cur, 1) ;
        Insert(char(Lo(KW)), Cmnd, Cur) ; Inc(Cur) end ;
      end {case Lo} ;
    GotoXY(0, Y) ;
    until false ;

  GotoXY(0, Y + Len div Cols) ;
  Writeln ;
  if Cmnd='' then EXIT ;
  if (Cmnd[1]<>'?') and (Cmnd<>XCmnds[1]) then begin
    for J := XH downto 2 do XCmnds[J] := XCmnds[Pred(J)] ;
    XCmnds[1] := Cmnd end ;
  end {PascalGetLine} ;

{$ELSE}


procedure DelphiGetLine ;
begin (* TMemoryManager, - *)
  Write(' [', Base, '] RPN (#) ? ') ;
  Readln(Cmnd) end {DelphiGetLine} ;

{$ENDIF BORPAS}


begin {RPNcalc}

  {  if not QClear then begin Send(S) ; EXIT end ; }
  SP := NIL ; Cmnd := '' ;
  for J := 1 to ParamCount do Cmnd := Cmnd+ParamStr(J)+Spc ;
  if Cmnd>'' then begin if RPN(Cmnd, SP) then ; Writeln ; EXIT end ;

  Writeln(GetFree, ' RPN Sanity Check and Square Root Test :') ;
  Writeln(RPN('((Input ) wrt -7424 wts dup dup mul dup ( Square ) wrt wts' +
    ' ( Root ) wrt srt wrt ' +
    ' swp div ( Div ) wrt wrt ( Mod ) wrt qr wrt wrs cls)' +
    ' wts wln exe', SP)) ;
  Writeln ;

  Writeln('RPN CALCULATOR NOW MODERATELY TESTED BUT STILL CHANGING;',
    '  MOD ALTERED 19990614.'^M^J) ;
  Writeln('Vast signed integer calculator, cf. PostScript :',
    ' up to ', imax, ' base ', Base, ' digits.') ;
  Info ;

  if not (QClear and Fcls(SP)) then begin Write(S) ; EXIT end ;


  {$IFDEF BORPAS} FillChar(XCmnds, SizeOf(XCmnds), #0) ; {$ENDIF}
  repeat
    repeat
      {$IFDEF BORPAS} PascalGetLine {$ELSE} DelphiGetLine {$ENDIF} ;
      until Cmnd>'' ;
    if Cmnd='#' then BREAK ;
    if Cmnd[1]='?' then begin DoHelp(Cmnd) ; CONTINUE end ;
    if RPN(Cmnd, SP) then ;
    {$IFNDEF GUI} if TextRec(Fo).Name[0]=#0 then ScreenToS(SP) ; {$ENDIF}
    until false ;

  if not (QClear and Fcls(SP)) then begin Write(S) ; EXIT end ;
  Writeln(GetFree, ' Done.') ;
  end {RPNcalc} ;



procedure SimpleTest ;
var J : shortint ; SP : PLET ; St : string ;
begin SP := NIL ;
  Writeln(
    RPN('/q0 (wts exe (  Ans: ) wrt wrt wln) def', SP) and
    RPN('( 10  20 sub) q0 exe', SP) and
    RPN('(-10 -20 sub) q0 exe', SP) and
    RPN('( 20  10 sub) q0 exe', SP) and
    RPN('(-20 -10 sub) q0 exe', SP) ) ;
  More ;
  for J := -2 to +5 do begin
    St := StrF(J) + ' 2 29 1 2 3 #ds #sd wln' ;
    Writeln(St) ; Writeln(RPN(St, SP)) ; More end ;
  Writeln(RPN('wln (2 31 pow #uf) dup wrt wln exe', SP)) ;
  if not QClear then begin Write(' in SimpleTest.') ; HALT end ;
  ClrStk(SP) ; More ;
  Writeln(RPN('wln (2 32 pow #uf) dup wrt wln exe', SP)) ;
  if not QClear then begin Write(' in SimpleTest.') ; HALT end ;
  ClrStk(SP) ; More ;
  end {SimpleTest} ;




procedure ArithTest ;
var PR, PQ, PX, PY, PZ : Parr ; k : word ; b1, b2 : boolean ;
const S = ' in ArithTest.' ;
TryMax = 43 ;
CheckTry : 4..imax = TryMax ;
begin
  if not (Garr(PR, Sfix+TryMax) and Garr(PQ, Sfix+TryMax)
    and   Garr(PX, Sfix+TryMax) and Garr(PY, Sfix+TryMax)
    and   Garr(PZ, Sfix+TryMax)) then begin Write(S) ; HALT end ;
  Writeln('+- :') ;
  for k := 1 to 100 do begin Write(k:5) ;
    RandomArr(PX, TryMax) ;
    RandomArr(PY, TryMax) ; Write(Spc) ;
    b1 := Plus(PX^, PY^, PZ) ; Write(',') ;
    b2 := Minus(PZ^, PY^, PR) ; Write(Spc) ;
    if (not b1) or (not b2) or (Scomp(PX^, PR^)<>0) then
      begin Writeln ;
      Write('   X ') ; WrtA(PX) ; Writeln ;
      Write('   Y ') ; WrtA(PY) ; Writeln ;
      Write('  += ') ; WrtA(PZ) ; Writeln ;
      Write('  -= ') ; WrtA(PR) ; Readln ;
      end ;
    end ;
  Writeln('*/ :') ;
  for k := 1 to 100 do begin Write(k:5) ;
    RandomArr(PX, TryMax div 2) ;
    repeat RandomArr(PY, TryMax div 2) until PY^.Sg<>0 ; Write(Spc) ;
    b1 := Times(PX^, PY^, PZ) ; Write(',') ;
    b2 := Divide(PZ^, PY^, PQ, PR) ; Write(Spc) ;
    if (not b1) or (not b2) or (PR^.Sg<>0) or (Scomp(PX^, PQ^)<>0) then
      begin Writeln ;
      Write('   X ') ; WrtA(PX) ; Writeln ;
      Write('   Y ') ; WrtA(PY) ; Writeln ;
      Write('  *= ') ; WrtA(PZ) ; Writeln ;
      Write('  /= ') ; WrtA(PQ) ; WrtA(PR) ; Readln ;
      end ;
    end ;
  Writeln('/* :') ;
  for k := 1 to 100 do begin Write(k:5) ;
    RandomArr(PX, TryMax) ;
    repeat RandomArr(PY, TryMax) until PY^.Sg<>0 ; Write(Spc) ;
    b1 := Divide(PX^, PY^, PQ, PR) ; Write(',') ;
    b2 := (Times(PQ^, PY^, PZ) and Plus(PZ^, PR^, PZ)) ;
    Write(Spc) ;
    if (not b1) or (not b2) or (Scomp(PX^, PZ^)<>0)
      or (PR^.Sg*PY^.Sg=-1) or (Ucomp(PR^, PY^)=1) then
      begin Writeln ;
      Write('   X ') ; WrtA(PX) ; Writeln ;
      Write('   Y ') ; WrtA(PY) ; Writeln ;
      Write('  QR ') ; WrtA(PQ) ; WrtA(PR) ; Writeln ;
      Write(' *+= ') ; WrtA(PZ) ; Readln ;
      end ;
    end ;
  Writeln('*û :') ;
  for k := 1 to 100 do begin Write(k:5) ;
    repeat RandomArr(PX, TryMax div 2) until PX^.Sg>0 ; Write(Spc) ;
    b1 := Times(PX^, PX^, PZ) ; Write(',') ;
    b2 := Root(PZ^, PQ, PR) ; Write(Spc) ;
    if (not b1) or (not b2) or (PR^.Sg<>0) or (Scomp(PX^, PQ^)<>0) then
      begin Writeln ;
      Write('   X ') ; WrtA(PX) ; Writeln ;
      Write(' ^2= ') ; WrtA(PZ) ; Writeln ;
      Write('  û= ') ; WrtA(PQ) ; WrtA(PR) ; Readln ;
      end ;
    end ;
  if not (Farr(PZ) and Farr(PY) and Farr(PX) and Farr(PQ) and Farr(PR))
    then begin Write(S) ; HALT end ;
  Writeln end {ArithTest} ;


BEGIN {$IFDEF BORPAS} HeapError := @HeapFunc ; { HeapLimit := 1 ; } {$ENDIF}
{$IFNDEF GUI}
Sendln ; Send(Cap1+Cap2) ; Sendln ; Send(Cap3) ; Sendln ; Flush(Output) ;
{$ENDIF nGUI}
SetCharSet ;
StartList ;
if not (LtoA(10, PTen) and Qstores(StoreFresh) and Qregs(RegsFresh))
  then begin Send(' in Main.') ; HALT end ;

if not QClear then begin Send('in Init') ; HALT end ;

{$IFNDEF GUI} Assign(Fo, '') ; Rewrite(Fo) ; {$ENDIF nGUI}
{$IFDEF PROGRAM}
{$DEFINE nDEF}
{$UNDEF nDEF}
{$IFDEF nDEF} SimpleTest ; {$ENDIF}
{$IFDEF nDEF} ArithTest ; {$ENDIF}
RPNcalc ;
{$ENDIF PROGRAM}
{$IFNDEF GUI} Close(Fo) ; {$ENDIF nGUI}

{
  The number 7424, and how to square root its square, are from Peggy Tolmie.

  RPN is Reverse Polish Notation : the command string is read left-to-right,
  values (numbers, strings, addresses) encountered are placed on top of a
  stack, and operators are performed immediately on the top element(s) of
  the stack, generally replacing their inputs with their outputs.

  Knowledge of PostScript (R) is not needed to use this; but it could help.

  Franz Glaser has a related RPN page (referring to his calculators) at
  http://www.geocities.com/SiliconValley/2926/txt/rpn_explanation.html

  Here, operators and addresses are *all* case-sensitive three-character
  "words", and strings are the contents of nestable parentheses.

  Numbers are signed decimal, except for those beginning with 0, which
  are unsigned and to the current base (for negative ones, put neg after).

  A semicolon introduces comment to end of current RPN string or line.

  There are ten writeable registers q0..q9, addresses /q0../q9; and
  qa qs qm qd qr qp hold results of the latest add sub mul div/mod/srt pwr.

  Enter
  #f9 is F9 test
  #pi is N*Pi by the B B P method ("repeats" added 19990624)
  #ds is DateTime-to-Seconds
  #sd is Seconds-to-DateTime
  #sa is DateTime Seconds-AddTo
  #dd is DateTime-Difference in seconds
  #uf is Unix-Fail - 2 N dec pow #uf is N-bit signed time fail date/time.
  #dt is push present DateTime
  N.B. the Base Date for Seconds is now
  Astronomical Proleptic Gregorian 0000-03-01 00:00:00.

  Other commands are general RPN operators; for examples of their use,
  see statements of the form "... RPN(..., SP) ..." above.

  Note that "div" and "mod" are integer division;
  AND that "mod" no longer stacks both results.
  The integers can now have opposite signs.
  They solve X=Q*Y+R, for R in the range from 0 to nearly Y, with same sign.

  There is no documentation for this program, at present or expected,
  other than the contents of this file.

  For Help, use ? ?? ??? ?<opr> (not in GUI).

  KEY inputs a keyboard line; (file.ext) SCR inputs a script <file.ext>.

  If there is any parameter, the parameter list is executed (not in GUI).
  So    longcalc (dosfile.scr) SCR     executes dosfile.scr; I have a few
  such files : weeknumb.scr pastri.scr.

  Needs Heap Overflow Tests for Delphi, TMT?

  For operating hints, look above at the RPN calls in the code,
  and at array Defs, and at '?' characters.

  Command 'bas' converts the base of all bar string contents.  It is SLOW;
  clear all possible numbers first, incl. 0 0 add 0 sub 0 mul 0 pow srt .

  Command 'INS' adds an instruction to the set; first push five strings:
  the TLA; the RPN code; the param-check; the help words; the I/O pattern.

  #dt now should not err at date rollover.

  I usually compile this in BP7 with all runtime checks ON; with all off,
  it is about pi times quicker.  With D3 DCC32 -cc, it is 4 times faster.
  Note the top lines.

  This is written for BP7.  In Delphi and TMT, command editing & history
  are not supported.  AFAICT, all else works in Delphi, but some crashes
  in TMT.  If PROGRAM is defined, it is a program, else a unit for vastcalc.

  Timers tix & mls are from midnight in Pascal, from Windows boot in Delphi,
  as Pascal uses $40:$6c & Delphi uses GetTickCount; conversion factor 55.

  GetEnv, PutEnv do not need Prof. Timo Salmi's TSUntEnv.TPU; no *.TPP?; ? .

  The effect of logicals - AND OAR XOR NOT IMP - needs thought; operations
  are digit-by-digit, and if Base<>2^n can give duff digits.  Results are
  however masked down to the number of bits Base implies.

  From 2003-08-05, len also works on numbers, giving digit count.
  From 2003-08-06, Env. write changed from TSuntE to JRS_EnvU (BP7 MSDOS).
  From 2003-08-06, Env. read changed from GetEnv to JRS_EnvU (BP7 MSDOS).
  2005-07-21 : Note that bas ignored sign.  Corrected.

  }

END.
