{$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(' ') ; Readln {$ENDIF} end {More} ; function Sims(const B : byte) : char ; begin if B=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.SzY.Ar[J] then begin UComp := +1 ; BREAK end ; if X.Ar[J]Y.Sg then Scomp := +1 else if X.SgB 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 XDX.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 = ' ' ; 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 : ? / ?? / ??? / ? ;' + {$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^ 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 Q1 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 - 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 Row1 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 ? ?? ??? ? (not in GUI). KEY inputs a keyboard line; (file.ext) SCR inputs a script . 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.