(HP71B) ASM question

[J-F Garnier]

(08-05-2024 04:21 AM)brouhaha Wrote:  

(07-30-2024 07:54 AM)J-F Garnier Wrote:  I didn't know the connection to the Fairchild PPS 25.

See my comment in the HP 9199A thread, and Steve Simkin's reply.

Thanks for linking to this thread !
As Kim, I missed it at the time, maybe I misread "9199" as a TI 99xx thing (a completely different story too).

Quote:

Quote:Do you know where the Capricorn CPU architecture, used in the Series 80 and the 75C, comes from?

The HP Journal article KeithB mentioned explains their rationale for designing a custom architecture, namely BCD arithmetic and variable length data. It is unclear that any specific architecture(s) influenced it, other than the generalized influence of the BCD and variable length word of the calculator processors.
The earlier Fairchild F8 architecture (also used by Mostek 3870) was AFAIK the earliest microprocessor architecture to have 64 registers, but it doesn't really appear that it had a significant influence.

I can also think of the CDP 1802 with its 16 16-bit register bank (so only 32 bytes total).
As for the Capricorn, one of the register was acting as the program counter, but the subroutine mechanism was completely different and unusual.
Actually I used it for a project beginning of the '80s at about the same time I was discovering the HP-85 assembly language.
The 1802 was introduced in 1976, so I doubt it could have been a source of inspiration to HP.
The story of the 1802 is interesting too.

J-F

[floppy]

New word "X<0?" since it was not in the HP71B Forth standard word list but in the HP41. Variants of it with different P values will create the other missing X<=0? & X>0?
( the missing X#0? would be

Code:

X=0? NOT

in Forth therefore imho no urgent need so far to create an ASM Word for this ).

Code:

=XXYY   EQU #E212D            comparison of X and perhaps Y (or zero)
=CMPST  EQU #E216C            comparison operator routine
* X<0?  check if the value in X is <0 then put 0 (false) 
*   or -1 (true) into the integer stack
*   similar to HP41
*   no float stack change
*   tested 17Aug2024
       WORD 'X<0?'
       ST=1   0
       GOSBVL =CMPST
       P=     1
       GOVLNG =XXYY

UPDATE. All X comparison with 0 in a single file

Code:

* X<0?  check if the value in X is <0 then put 0 (false) 
*   or -1 (true) into the integer stack
*   similar to HP41; however use of an integer stack instead of
*   program counter jump or not (like the Forth word X=0?)
*   no float stack change
*   tested 21Aug2024
       WORD 'X<0?'
       ST=1   0
       GOSBVL =CMPST
       P=     1
       GOTO   CMP0
*
* X<=0?
       WORD 'X<=0?'
       ST=1   0
       GOSBVL =CMPST
       P=     3
       GOTO   CMP0
*
* X#0?
       WORD 'X#0?'
       ST=1   0
       GOSBVL =CMPST
       P=     5
       GOTO   CMP0
*
* X>0?
       WORD 'X>0?'
       ST=1   0
       GOSBVL =CMPST
       P=     4
CMP0   GOVLNG =XXYY

Any remarks are welcomed for improvement or shortening of such suggested Forth words.

[floppy]

Lets give more flexibility in working with the float stack in Forth.

the entry point listed in the new words..

Code:

=OX     EQU #2FBD0            X address

Code:

* X<> exchange the value in the variable with the value in X like the HP41 command
*       use: FVAR1 X<>   tested 15july2024
       WORD 'X<>'
       P=     0
       LC(5)  =OX             put X-address into C(A)
       CD0EX                 exchange data pointer address D0 with C(A)
       R2=C                  save D0
       A=DAT0 W              A = value of X from its address in C(A)
       R0=A                  R0 = X
       C=DAT1 A              copy data at address in D1 into C(A)
       CD0EX
       A=DAT0 W              copy data at address in D0 (in C(A)) into W in A
       R1=A                  R1 = Reg value
       P=     0
       LC(5)  =OX             put X-address into C(A)
       CD0EX                 exchange data pointer address D0 with C(A)
       A=R1
       DAT0=A W              X has now value of Reg
       C=DAT1 A              copy data at address in D1 into C(A)
       CD0EX                 exchange C(A) with D0
       A=R0
       DAT0=A W              value of X into reg
       C=R2
       D0=C                  restore D0
       D1=D1+ 5              return nothing on data stack
       RTNCC

Code:

* X<>Z exchange the HP41 registers. tested 12 July 2024
       WORD 'X<>Z'
       P=     0
       LC(5)  =OX             put X-address into field A of register C
*                               low order 5 nibbles
       CD0EX                 put data pointer D0 into C(A)
       R1=C                  save D0 into R1
       C=DAT0 W              C = value of X (which is in D0)
       D0=D0+ 16             D0 has now Y addr
       D0=D0+ 16             D0 has now Z addr
       A=DAT0 W              put value of Z into A via addr in D0
       DAT0=C W              Z = value of X
       D0=D0- 16
       D0=D0- 16             D0 -> X
       DAT0=A W              X = value of Z
       C=R1
       D0=C                  restore D0
       RTNCC

Code:

* X<>T exchange the HP41 registers, tested 12 July 2024
       WORD 'X<>T'
       P=     0
       LC(5)  =OX             put X-address into field A of register C
*                               low order 5 nibbles
       CD0EX                 put data pointer D0 into C(A)
       R1=C                  save D0 into R1
       C=DAT0 W              C = value of X
       D0=D0+ 16             D0 -> Y
       D0=D0+ 16             D0 -> Z
       D0=D0+ 16             D0--> T
       A=DAT0 W              put value of T into A
       DAT0=C W              T = value of X
       D0=D0- 16
       D0=D0- 16
       D0=D0- 16             D0 -> X
       DAT0=A W              X = value of T
       C=R1
       D0=C                  restore D0
       RTNCC

Code:

* X<>L exchange the HP41 registers, tested 12 July 2024
       WORD 'X<>L'
       P=     0
       LC(5)  =OX             put X-address into field A of register C
*                               low order 5 nibbles
       CD0EX                 put data pointer D0 into C(A)
       R1=C                  save D0 into R1
       C=DAT0 W              C = value of X
       D0=D0- 16             D0--> L
       A=DAT0 W              put value of L into A
       DAT0=C W              L = value of X
       D0=D0+ 16             D0 -> X
       DAT0=A W              X = value of L
       C=R1
       D0=C                  restore D0(A) from C(A)
       RTNCC

More words needed like example Z<>L ?
this word is
X<>Z
X<>L
X<>Z
therefore Z<>L could be a new Forth word (lower need since this is a combination of the 3 above new words).

As usual, remarks are welcomed.

[floppy]

Since beeping is healthy, lets create the TONE word like in HP41.
Usefull? perhaps

Entry points

Code:

=ABS    EQU #E1A23            (n -- |n|)
=SAVEFP EQU #E717A            save Forth pointer
=HDFLT  EQU #1B31B            change hex integ A(A) to 12dig float in A(W) exit DEC mode
=MP2-12 EQU #0C432            12 digit * (A) * (C) result 15dig in (A,B) 
=RESD1  EQU #0E1EE            reduce (AB) in (C), dont alter D1
=AD2-12 EQU #0C35F            12 digit add = (A) + (C) 15dig result in (A,B)
=BP     EQU #0EADF            make beep float A HZ Float C duration sec pdf ids3 page 1625
=GETFP  EQU #E71A5            restore Forth pointers

Code:

* create HP41 like tone function with input 0 (low)..9 (high)
* input in the integer stack (in HP41 it is as a line command TONE x)
* ( n -- ) TONE
* 0 .. 394 Hz  >> Value 394 + (43.777 * N) 
* 1 .. 437.8
* ..
* 8 .. 744.2
* 9 .. 788 HZ
* length 0,28s
* however inputs higher than 9 will be accepted
* negative values -8 (example) will be taken as 8
* tested Aug22 2024
* use  5 TONE in Forth prompt
       WORD 'TONE'
*
       GOSBVL =ABS           for positive whatever input was
       GOSBVL =SAVEFP
*
* not tested/completed; if bigger than 9, reduce with MOD 10
*       C=0    W
*       LCHEX  100000000000001  ? Integer format in integ stack?
*       D1=D1- 5
*       DAT1=C A
*       GOSBVL =MOD 
*
       A=DAT1 A
       GOSBVL =HDFLT          change A(A) to float A(W) 12 digits for further calc. exit with DEC mode
       C=0    S
       P=     0
       LCHEX  437777777777001 
       GOSBVL =MP2-12        result into (A,B)
       GOSBVL =RESD1         result into C
       R0=C
       C=0    S              S instead of W for less size?
       P=     0
       LCHEX  394000000000002
       A=R0
       GOSBVL =AD2-12        result into (A,B)
       GOSBVL =RESD1         result into C as 12 digit
       R0=C                  R0 Hz 
       C=0    W
       P=     0
       LCHEX  280000000000999 C duration
       SETDEC
       A=R0
       GOSBVL =BP
       GOSBVL =GETFP
       D1=D1+ 5              take the value out of the stack
       RTNCC

UPDATE: missing entry points included

[floppy]

Question: what is the best method for creating PI in Forth/ASM?
Is there a memory optimized calculation procedure?

In HP71B, apart from using the BASICX command with PI as parameter in a Forth word, its possible to upload a constant; but perhaps not the best memory cautious method.

Comments/remarks are welcome.

Entry points

Code:

=SAVEFP EQU #E717A            save Forth pointer
=STKLFT EQU #E7320            Stacklift Forth OM page 609 pdf
=OX     EQU #2FBD0            X address
=GETFP  EQU #E71A5            restore Forth pointers

PI word

Code:

* PI : put PI into X in the stack. uplift the float stack. lastx not changed (like HP41)
* tested 23Aug2024
       WORD 'PI'
       GOSBVL =SAVEFP
       C=0    S
       P=     0
       LCHEX  314159265359000
       R0=C                  R0 = Result
       GOSBVL =STKLFT
       A=R0
       D0=(5) =OX
       DAT0=A W              Result into X
       GOSBVL =GETFP
       RTNCC

[floppy]

Now, here is one new word written in ASM, like the HP41 function R-P, now for for HP71B Forth.
A warning is coming during the use WRN:
However the result is fine.
If anybody has an idea how to take this away, please contact me (the word works).

Code:

************************************************************
* R-P : Rad to Polar conversion
* see HP41 manual page 92
* 1.0 2.0 R-P gives 2.2361 (SQRT(5)) in X and 26.56° or 0.4636 Rad in Y
* change the output if use of the words RADIANS or DEGREES
* WRN: coming; reason unknown; however result ok
************************************************************
       WORD 'R-P'
       GOSBVL =NUMST         GET X INTO (A,B), uMODES;SAVEFP;GETX+L
       GOSBVL =uRES12        C = (A,B)
       A=C    W
       R0=A                  X in A and R0
*
       SETDEC
       GOSBVL =MP2-12
       GOSBVL =uRES12        C = (A,B)
       A=C    W
       R2=A                  X**2 in A and R2
*
       P=     0
       LC(5)  =OY
       CD0EX
       A=DAT0 W
       R1=A                  Y in A and R1
*
       C=R0                  X in C
       SETDEC
       GOSBVL =DV2-12
       GOSBVL =ATAN15
       GOSBVL =uRES12        C = (A,B)
       A=C    W
*
       P=     0
       LC(5)  =OY
       CD0EX
       DAT0=A W              copy data of A into Y
*
       A=R1
       C=A    W
       SETDEC
       GOSBVL =MP2-12
       GOSBVL =uRES12        C = (A,B)
       A=C    W              Y**2 in A
       C=R2                  X**2 in C
       SETDEC
       GOSBVL =AD2-12
       GOSBVL =SQR15
*
       GOSBVL =PUTABX
       RTNCC
************************************************************

[floppy]

Now a try to make the ISG function in HP41 under HP71B/Forth/ASM.
An usefull use in Forth is identified? not sure since it has the I DO LOOP or +LOOP.
However, having such frankensetein HP41 function in HP71B is funny.
Comments/remarks are welcome

Code:

*
****************************************************************
* ISG ( addr -- flag ) increment value
* need? since I DO LOOP or +LOOP exists, it should cover the needs
* HP41 like "increment and skip if greater". It increment sss and would "skip", what
*   we can interpret as put a NO/false (0) in the integer stack, if it becomes equal or greater than eee
*   hp41 om en page 164 (pdf 170)
* BUT here, no truncated according display
* use.. FVAR1 ISG (FVAR1 is a float variable) ; ssss,eeeiixxx in FVAR1 will 
*         return  0 (false) if sss+ii >= eee
*         return -1 (true) if sss+ii < eee
*       ii default is 1 if not given (00)
*
*       0.0 X ISG X FV. . >> Value: 1.000000000  &  0 in Intg Stack 
*       1.01 X ISG will increase X by default 1 with 
*          result 2.01000 in X and -1 in Intg Stack
*       -10.00102345 Y STO Y ISG will increase Y by 2 with 
*          result -8.00102345 in Y  and -1 in Intg Stack 
*       10.02003 X ISG      gives  13.02003 in X, -1 in Integ Stack
*       10.020001234 X ISG  gives  11.020001234 in X, -1 in Integ stack
*       10.020001234 X ISG X FV. .  Value in X: 11.020001234 -1  OK { 0 } 
*       10.020103456 X ISG  gives  20.020103456 in X, 0 in Integ stack
*       -10.02010 X ISG     gives  0.02010 in X, -1 in Integ Stack
*       0.0201 X ISG      gives  10.02010 in X, -1 in Integ Stack
*       10.02010 X ISG      gives  20.02010 in X, 0 in Integ Stack
*       20.02010 X ISG      gives  30.02010 in X, 0 in Integ Stack
*       -1.02010 X ISG FS. .   gives 9.02010 in X, -1 in Integ stack
*       0.00005 X ISG X FV. . >> 5.00005 in X and 0 in Integ stack
*       0.010405678 X ISG X FV. . >> 40.010405678 in X and 0 in Integ stack
*       -10.02010777 X ISG FS. . >> 0.02010777 in X and -1 in integ stack
*
* tested 07.10.2024
****************************************************************
       WORD 'ISG' 
       GOSBVL =SAVEFP
       C=DAT1 A              copy data at address in D1 into C(A)
       R0=C                  copy C(A) into R0
       CD0EX                 exchange C(A) with D0 pointer
       A=DAT0 W              value ssss,eeeiixxx into A
*
* saving the original value of the float variable
*
       R1=A                  value ssss,eeeiixxx into   >> R1 <<
*
* 10000 in (C)
       C=0    W
       P=     14
       C=C+1  P
       P=     0
       LCHEX  5              just retracting 5x 1 in X was not making it
*
       A=R1                  seems to make it better; see %OF, too
*                            = upload A after C prior MV DV ADD..
       SETDEC
       GOSBVL =MP2-12        sssseeeii,xxx into (A,B)
       GOSBVL =CLRFRC        sssseeeii,000 into (A,B)
       GOSBVL =uRESD1        into (C)
       R2=C                  sssseeeii,000 into R2
       C=0    W
       P=     14
       C=C+1  P
       P=     0
       LCHEX  998            0,01 now in C
*
       A=R2                  sssseeeii,000 into A
       SETDEC
       GOSBVL =MP2-12        sssseee,ii000 into (A,B)
       GOSBVL =CLRFRC        sssseee,00000 into (A,B); carry set if ii=00
*
       GONC   nadd0          if 0,ii000 # 0,00 then dont add one
*
* BRANCH: ii is ZERO .. then add ONE
*
       A=R2                  sssseee00,000 into A
       C=0    W
       P=     14
       C=C+1  P              1 in Register C
       C=A    S              it makes -1 if A<0; +1 if A>0
       A=R2                  sssseee00,000 into A
       GOSBVL =AD2-12        sssseee01,000 in (A,B)
       GOSBVL =uRESD1        sssseee01,000 into (C)
       R2=C                  sssseee01,000 into (R2)
*
* BRANCH: ii IS NOT ZERO from here
*
nadd0  C=0    W
       P=     14
       C=C+1  P
       P=     0
       LCHEX  998            0,01 now in C
       A=R2                  from here, sssseeeii,000 into A
       SETDEC
       GOSBVL =MP2-12        sssseee,ii000 into (A,B)
       GOSBVL =FRAC15        0,ii000 in (A,B). ii#00 for sure here  issue there if sssseee = 0?
       GOSBVL =uRESD1        into (C)
       A=C    W              0,ii000 into A
       P=     15
       A=0    P              +0,ii000 in (A)
       SETDEC
       R2=A                  +0,ii000 in R2 now
       C=0    W
       P=     14
       C=C+1  P
       P=     0
       LCHEX  2              100 in C
       A=R2                  +0,ii000 in (A)
*
       SETDEC                dont forget this before MP DV .. 2-12
       GOSBVL =MP2-12        +ii,000 into (A,B)
       GOSBVL =uRESD1        +ii,000 into (C)
*
       R2=C                  +ii,000 into (R2)
*
* ssss could be zero and could make an issue later with the use of FRAC15
* which is not necessary in case this is already 0,eeeiixxxx
*
       A=R1                  ssss,eeeiixxx into A
       GOSBVL =IF12A
       ?P#    14             test if A is like 0,eeeiixxx which means ssss = 0
       GOYES  SNZ            ssss is NOT ZERO (tested)
*
* BRANCH: ssss is ZERO; -ii is from here definitively NOT ZERO
*
       C=R1                  0,eeeiixxx is in C now (ssss is Zero tested before)
       A=R2                  +ii,000 (which is NOT ZERO) into A
       C=A    S              (C) should have the same sign than (A)
       GOSBVL =AD2-12        value (ssss=zero)+ii,eeeiixx in (A,B)
       GOSBVL =uRESD1        in C
       R1=C
       GOTO WEI
*
* Branch: ssss is not ZERO (tested)
*
SNZ    A=R1                  A is like ssss,eeeiixxx
       GOSBVL =SPLITA        A into (A,B)
       GOSBVL =CLRFRC        ssss,00 into (A,B)
       GOSBVL =uRESD1        ssss,00 into (C)
       A=R2                  +ii,000 into (A)
       SETDEC                dont forget this before MP DV .. 2-12
       GOSBVL =AD2-12        value ssss+ii,00 in (A,B)
       GOSBVL =uRESD1        ssss+ii,00 in C
       A=C    W              ssss+ii,00 in A
       R2=C                  ssss+ii,00 in R2
*
       ?A#0   M              (ssss+ii) not ZERO ?
       GOYES  WEIT           goto WEIT if (ssss+ii) not zero
*
* BRANCH: (ssss+ii) is ZERO
*
       A=0    W              necessary(?)
       R2=A                  necessary(?)
*
       A=R1                  ssss,eeeiixxx (NOT like 0,eeeiixxx) in A
       GOSBVL =SPLITA        A into (A,B)
       GOSBVL =FRAC15        0,eeeiixxx in (A,B)
       GOSBVL =uRESD1        into (C)
       C=0    S              +0,eeeiixxx (= ssss+ii,eeeiixxx) in (C)
       R1=C                  +0,eeeiixxx (= ssss+ii,eeeiixxx) in (R1)
       GOTO   WEI
*
*
* BRANCH: (ssss+ii) and (ssss) are both NOT ZERO
*
WEIT   A=R1                  ssss,eeeiixxx into A
       GOSBVL =SPLITA        ssss,eeeiixxx into (A,B)
       GOSBVL =FRAC15        0,eeeiixxx in (A,B)
       GOSBVL =uRESD1        0,eeeiixxx into (C)
       A=R2                  ssss+ii,00 into (A)
       C=A    S
       GOSBVL =AD2-12        value ssss+ii,eeeiixxx in (A,B)
       GOSBVL =uRESD1        ssss+ii,eeeiixxx into C
       R1=C                  ssss+ii,eeeiixxx in (R1)
*
* Upload the ISG action back into the variable
*
WEI    A=R1
       C=R0
       CD0EX                 exchange C(A) with D0
       DAT0=A W              Store increased value ssss+ii,eeeiixxx back into variable
*
* Now upload the TRUE FALSE into the integer stack
* So far, R2 has ssss+ii,00
* So far, R1 has ssss+ii,eeeiixxx
*
* isolate eee
*
       A=R1                  ssss+ii,eeeiixxx in (A)
*
       GOSBVL =IF12A
       ?P=    14             test if A like 0,eeeiixxx
       GOYES  SIZ            ssss+ii is ZERO (tested)
*
* BRANCH (again) ssss+ii IS NOT ZERO
*
       A=R1 
       GOSBVL =SPLITA        A into (A,B)
       GOSBVL =FRAC15        0,eeeiixxx into (A,B)
       GOSBVL =uRESD1        0,eeeiixxx (A,B) into C
       R1=C                  0,eeeiixxx in R1
*
* BRANCH (again) ssss-ii IS ZERO
* 0,eeeiixxx
*
SIZ    C=0    W
       P=     14
       C=C+1  P
       P=     0
       LCHEX  3              1000 in (C)
       A=R1                  0,eeeiixxx into A
       SETDEC                dont forget this before MP2-12
       GOSBVL =MP2-12        eee,iixxx into (A,B)
       GOSBVL =CLRFRC        eee,00000 into (A,B)
       GOSBVL =uRESD1        eee,00 into (C)
       C=0    S              +eee,00 in (C)
       R1=C                  +eee,00 in (R1)
*
       C=R1                  +eee,00    in C
       A=R2                  ssss+ii,00 in A
       P=     1
       GOSBVL =uTEST
       SETHEX
       A=0    A
       GONC   TRO1
       A=A-1  A
TRO1   GOSBVL =GETFP
       DAT1=A A
       RTNCC
*
****************************************************************

AND: an overtaking of the GAMMA function of the Math module is currently analyzed: however, the BASIC ASM function I got from JF Garnier seems to use stack mechanisms I could not reconduct on Forth/ASM (for sure, the Forth has stack mechanisms). So, the idea is to have a GAMMA Forth/ASM (low prio); however the path to it is still not found. Any hints are welcomed.
GAMMA in pure FORTH is there https://rosettacode.org/wiki/Gamma_function#Forth and is the plan B.

UPDATED 25Sept2024: the code above
UPDATED 07Oct2024: the code above (with entry 0,xxxx it was not correctly working)

[J-F Garnier]

(09-24-2024 12:00 PM)floppy Wrote:  AND: an overtaking of the GAMMA function of the Math module is currently analyzed: however, the BASIC ASM function I got from JF Garnier seems to use stack mechanisms I could not reconduct on Forth/ASM (for sure, the Forth has stack mechanisms). So, the idea is to have a GAMMA Forth/ASM (low prio); however the path to it is still not found. Any hints are welcomed.

The gamma asm code from the Math ROM (the dogam subroutine) should be useable in a Forth primitive, rewriting only the wrapper code to interface with the Forth environment.

The code is referring to a "math scratch stack", like:

Code:

     GOSUB  =stscr+   store it to math scratch stack
     GOSUB  =rcscr+   recall from math scratch stack

The HP naming is confusing, because there is also a "Math stack", specific to BASIC, to hold parameters and results during BASIC expression evaluation.
The "math scratch stack" is different, it's a reserved fixed place in the system memory implementing a 4-level stack to hold temporary extended precision values during numeric calculations.
So I believe it's perfectly useable in Forth too.

J-F

[floppy]

Information: new word for the "HP41&71" community "DSE"
That was a hard nut: FRAC15 dont like a number like 0,xxxxxx therefore it must be tested if it is a number of type 0,xxxxxx instead of using FRAC15 for all numbers.

Code:

=IF12A  EQU #0C739           return where the decimal point is. Out is the number in P. Page 1412 If E<0, P =14 etc.
*                              alter A,B,C(A),P,CARRY

Comments/remarks are welcome.

Code:

****************************************************************
* DSE : decrement value  
* HP41 like; manual page 163; decrement and skip if equal
* It decrement sss and would "skip", what we can interpret as 
*   put a NO/false (0) in the integer stack, if it becomes equal or less than eee
* (ssss,eeeii in X) X DSE return  0  (false) if ssss <= eee
*                                 -1 (true) if ssss > eee
* use: 20.01001 X DSE  >> output .. X: 19.010010000  ..  0  OK { 0 } 
*   this value can be saved into any variable Z T or FVARX
*   then FVARX DSE can be used
*
* use cases for testing:
*   0.0 X DSE            -1.0 in X    & 0 in integ stack
*   20.00020 X DSE       0.00020 in X & 0 in integ stack
*   20.010010000 X DSE   19.010010000 in X & -1 in integer stack
*   20.010001234 X DSE   19.010001234 in X & -1 in integer stack
*   20.010023456 X DSE   18.010023456 in X & -1 in integer stack
*   0.010023456 X DSE   -2.010023456 in X & 0 in integer stack
*   1.010023456 X DSE   -1.010023456 in X & 0 in integer stack
*   20.010103456 X DSE   10.010103456 in X & 0 in integer stack
*   10.010103456 X DSE   0.010103456 in X & 0 in integer stack
*   -10.0000566666 X DSE   -15.000056667 in X & 0  OK { 0 }
*   -10.000000000  X DSE FS. .  >> X: -11.000000000 >> 0  OK { 0 } 
*   0.010003456 X DSE FS. .     >> -1.010003456 .. 0  OK { 0 }
*   1.0200234567 X DSE FS. .    >> -1.020023457 .. 0  OK { 0 } 
*   0.00000345678 X DSE FS. .   >> -1.00000345678 .. 0  OK { 0 } 
*   0.01002 X DSE FS. .         >> -2.01002        0
*   0.01 X DSE FS. .  >> -1.01                    0 
*   0.00002 X DSE FS. . >> -2.00002               0
*
* tested 07 Oct 2024
****************************************************************
       WORD 'DSE'
*       GOSBVL =uMODES        necessary?
       GOSBVL =SAVEFP
       C=DAT1 A              copy data at address in D1 into C(A)
       R0=C                  copy C(A) into R0
       CD0EX                 exchange C(A) with D0 pointer
       A=DAT0 W              value ssss,eeeiixxx into A
*
* saving the original value of the float variable
*
       R1=A                  value ssss,eeeiixxx into   >> R1 <<
*
* ssss or sssseee or sssseeeii = 0 seems to be an issue because the numbers after ii , are gone. 
*               lets consider that case to bypass later calculations
*               >> FRAC15 dont like something like 0,xxxx
*
* 10000 in (C)
       C=0    W
       P=     14
       C=C+1  P
       P=     0
       LCHEX  5              just retracting 5x 1 in X was not making it
*
       A=R1                  seems to make it better; see %OF, too
*                            = upload A after C prior MV DV ADD..
       SETDEC
       GOSBVL =MP2-12        sssseeeii,xxx into (A,B)
       GOSBVL =CLRFRC        sssseeeii,000 into (A,B)
       GOSBVL =uRESD1        into (C)
       R2=C                  sssseeeii,000 into R2
       C=0    W
       P=     14
       C=C+1  P
       P=     0
       LCHEX  998            0,01 now in C
*
       A=R2                  sssseeeii,000 into A
       SETDEC
       GOSBVL =MP2-12        sssseee,ii000 into (A,B)
       GOSBVL =CLRFRC        sssseee,00000 into (A,B); carry set if ii=00
*
       GONC   nadd0          if 0,ii000 # 0,00 then dont add one
*
* BRANCH: ii is ZERO .. then add ONE
*
       A=R2                  sssseee00,000 into A
       C=0    W
       P=     14
       C=C+1  P              1 in Register C
       C=A    S              it makes -1 if A<0; +1 if A>0
       A=R2                  sssseee00,000 into A
       GOSBVL =AD2-12        sssseee01,000 in (A,B)
       GOSBVL =uRESD1        sssseee01,000 into (C)
       R2=C                  sssseee01,000 into (R2)
*
* BRANCH: ii IS NOT ZERO from here
*
nadd0  C=0    W
       P=     14
       C=C+1  P
       P=     0
       LCHEX  998            0,01 now in C
       A=R2                  from here, sssseeeii,000 into A
       SETDEC
       GOSBVL =MP2-12        sssseee,ii000 into (A,B)
       GOSBVL =FRAC15        0,ii000 in (A,B). ii#00 for sure here  issue there if sssseee = 0?
       GOSBVL =uRESD1        into (C)
       A=C    W              0,ii000 into A
       P=     15
       A=0    P              +0,ii000 in (A)
       SETDEC
       A=-A-1 S              A = -0,ii000
       R2=A                  -0,ii000 in R2 now
       C=0    W
       P=     14
       C=C+1  P
       P=     0
       LCHEX  2              100 in C
       A=R2                  -0,ii000 in (A)
*
       SETDEC                dont forget this before MP DV .. 2-12
       GOSBVL =MP2-12        -ii,000 into (A,B)
       GOSBVL =uRESD1        -ii,000 into (C)
*
       R2=C                  -ii,000 into (R2)
*
* ssss could be zero and could make an issue later with the use of FRAC15
* which is not necessary in case this is already 0,eeeiixxxx
*
       A=R1                  ssss,eeeiixxx into A
       GOSBVL =IF12A
       ?P#    14             test if A is like 0,eeeiixxx which means ssss = 0
       GOYES  SNZ            ssss is NOT ZERO (tested)
*
* BRANCH: ssss is ZERO; -ii is from here definitively NOT ZERO
*
       C=R1                  0,eeeiixxx is in C now (ssss is Zero tested before)
       A=R2                  -ii,000 (which is NOT ZERO) into A
       C=A    S              (C) should have the same sign than (A)
       GOSBVL =AD2-12        value (ssss=zero)-ii,eeeiixx in (A,B)
       GOSBVL =uRESD1        in C
       R1=C
       GOTO WEI
*
* Branch: ssss is not ZERO (tested)
*
SNZ    A=R1                  A is like ssss,eeeiixxx
       GOSBVL =SPLITA        A into (A,B)
       GOSBVL =CLRFRC        ssss,00 into (A,B)
       GOSBVL =uRESD1        ssss,00 into (C)
       A=R2                  -ii,000 into (A)
       SETDEC                dont forget this before MP DV .. 2-12
       GOSBVL =AD2-12        value ssss-ii,00 in (A,B)
       GOSBVL =uRESD1        ssss-ii,00 in C
       A=C    W              ssss-ii,00 in A
       R2=C                  ssss-ii,00 in R2
*
       ?A#0   M              (ssss-ii) not ZERO ?
       GOYES  WEIT           goto WEIT if (ssss-ii) not zero
*
* BRANCH: (ssss-ii) is ZERO
*
       A=0    W              necessary(?)
       R2=A                  necessary(?)
*
       A=R1                  ssss,eeeiixxx (NOT like 0,eeeiixxx) in A
       GOSBVL =SPLITA        A into (A,B)
       GOSBVL =FRAC15        0,eeeiixxx in (A,B)
       GOSBVL =uRESD1        into (C)
       C=0    S              +0,eeeiixxx (= ssss-ii,eeeiixxx) in (C)
       R1=C                  +0,eeeiixxx (= ssss-ii,eeeiixxx) in (R1)
       GOTO   WEI
*
*
* BRANCH: (ssss-ii) and (ssss) are both NOT ZERO
*
WEIT   A=R1                  ssss,eeeiixxx into A
       GOSBVL =SPLITA        ssss,eeeiixxx into (A,B)
       GOSBVL =FRAC15        0,eeeiixxx in (A,B)
       GOSBVL =uRESD1        0,eeeiixxx into (C)
       A=R2                  ssss-ii,00 into (A)
       C=A    S
       GOSBVL =AD2-12        value ssss-ii,eeeiixxx in (A,B)
       GOSBVL =uRESD1        ssss-ii,eeeiixxx into C
       R1=C                  ssss-ii,eeeiixxx in (R1)
*
* Upload the DSE action back into the variable
*
WEI    A=R1
       C=R0
       CD0EX                 exchange C(A) with D0
       DAT0=A W              Store increased value ssss-ii,eeeiixxx back into variable
*
* Now upload the TRUE FALSE into the integer stack
* So far, R2 has ssss-ii,00
* So far, R1 has ssss-ii,eeeiixxx
*
* isolate eee
*
       A=R1                  ssss-ii,eeeiixxx in (A)
*
       GOSBVL =IF12A
       ?P=    14             test if A like 0,eeeiixxx
       GOYES  SIZ            ssss-ii is ZERO (tested)
*
* BRANCH (again) ssss-ii IS NOT ZERO
*
       A=R1 
       GOSBVL =SPLITA        A into (A,B)
       GOSBVL =FRAC15        0,eeeiixxx into (A,B)
       GOSBVL =uRESD1        0,eeeiixxx (A,B) into C
       R1=C                  0,eeeiixxx in R1
*
* BRANCH (again) ssss-ii IS ZERO
* 0,eeeiixxx
*
SIZ    C=0    W
       P=     14
       C=C+1  P
       P=     0
       LCHEX  3              1000 in (C)
       A=R1                  0,eeeiixxx into A
       SETDEC                dont forget this before MP2-12
       GOSBVL =MP2-12        eee,iixxx into (A,B)
       GOSBVL =CLRFRC        eee,00000 into (A,B)
       GOSBVL =uRESD1        eee,00 into (C)
       C=0    S              +eee,00 in (C)
       R1=C                  +eee,00 in (R1)
*
       C=R2                  ssss-ii,00 in C
       A=R1                  +eee,00    in A
       P=     1
       GOSBVL =uTEST
       SETHEX
       A=0    A
       GONC   TRO1
       A=A-1  A
TRO1   GOSBVL =GETFP
       DAT1=A A
       RTNCC
*
****************************************************************

[floppy]

In order to initiate a float variable for the ISG and DSE words, here is a new word: it uses the integer stack for this. Questions/remarks are welcomed.

Code:

****************************************************************
* CLCV : control looping creation in variable
* use IIIII FFF CC FVAR CLCR where 
*       IIIII is the counter value integer
*       FFF   is the counter test value integer
*       CC    is the increment value integer
*       FVAR  is the float variable where IIII.FFFCC will be stored
*     IIIII FFF CC 
*         1     22    3    X    CLCV  will put  1.02203  into X
*   D1+20 D1+15 D1+10 D1+5 D1 (?)
*
* tested 2024 Oct 16
* 777 888 11 Y CLCV FS.   result  Y: 77.888110000 
****************************************************************
       WORD 'CLCV'
       GOSBVL =SAVEFP
*
       P= 0                  Set to 0 made it.
       D1=D1+ 5              CC; go to the first address of the variable in the integ stack 
       A=DAT1 A              copy data at address in D1 into A(A)
       GOSBVL =HDFLT         change A(A) to float A(W) 12 digits for further calc. exit with DEC mode
       R0=A
       C=0    W
       P=     14
       C=C+1  P
       P=     0
       LCHEX  995            0,00001 now in (C)
       A=R0
       SETDEC
       GOSBVL =MP2-12        0,000CC into (A,B)
       GOSBVL =uRESD1        into (C)
       R1=C
*
       D1=D1+ 5
       A=DAT1 A              copy data at address in D1 into A(A)
       GOSBVL =HDFLT         change A(A) to float A(W) 12 digits for further calc. exit with DEC mode
       R0=A
       C=0    W
       P=     14
       C=C+1  P
       P=     0
       LCHEX  3              1000 in (C)
       A=R0
       SETDEC
       GOSBVL =DV2-12        0,FFF into (A,B)
       GOSBVL =uRESD1        into (C)
       A=R1
       SETDEC
       GOSBVL =AD2-12        0,FFFCC into (A,B)
       GOSBVL =uRESD1        into (C)
       R1=C
*
       D1=D1+ 5              IIIII
       A=DAT1 A              copy data at address in D1 into A(A)
       GOSBVL =HDFLT         change A(A) to float A(W) 12 digits for further calc. exit with DEC mode
       R0=A
       C=R1
       A=R0
       SETDEC
       GOSBVL =AD2-12        IIIII,FFFCC into (A,B)
       SETHEX
       GOSBVL =uRESD1        into (C)
       R1=C                  IIIII,FFFCC into R1
*
       D1=D1- 15
       C=DAT1 A              copy data at address in D1 into C(A)
       CD0EX                 Put it into D0
       A=R1                  IIIII,FFFCC into A
       DAT0=A W              Store value IIIII,FFFCC into variable
       D0=C
*
       GOSBVL =GETFP
       D1=D1+ 15
       D1=D1+ 5
       RTNCC
*
****************************************************************

[floppy]

Now here is the good old FACT function from HP41. Same behaviour now in HP71B Forth.

Entry point new to be used (see other entry points in previous posts)

Code:

=FAC15S EQU #0E72B           factorial 15digit (A,B) into (A,B), v3 page 1591

Code:

****************************************************************
* FACT : factorial function (see HP41)
* tested 18 Oct 2024
* use: 6.0 FACT
* > X: 720.000000000 
* > L: 6.000000000 
       WORD 'FACT'
       GOSBVL =NUMST
       SB=0                  issue gone when included
       XM=0                  same
       SETDEC                same
       GOSBVL =FAC15S
       GOSBVL =PUTABX
       RTNCC
****************************************************************