(HP71B) ASM question
Hello,
I have here few ASM words (yes, looks similar to HP41 especially the total rekall module fcts).
Code:
FORTH
*
* columns..
* 1:label 8:mnemonic 15:modifier from 24:comments
*
* FORTH entry points:
CHS EQU #E1518 change X sign; dont change LastX
NUMST EQU #E1718 GET X INTO (A,B); L := X
FEND EQU #E08E9 PUTABX,GETFP
PUTABX EQU #E72F5 Put (A,B) into X, .. GETFP
GETX EQU #E728A Put X into (A,B)
GETX+L EQU #E72DF Put X into (A,B) and X in L
SAVEFP EQU #E717A save Forth pointer
GETFP EQU #E71A5 restore Forth pointers
* System entry points: see 14-1 of IMS Vol 1
AD2-15 EQU #0C363 15-digit add
MP2-15 EQU #0C43A 15-digit multiply
DV2-15 EQU #0C4AC 15-digit divise
* DV15S EQU #0C4B2
SPLITA EQU #0C6BF Extend (A) into (A,B)
SPLTAC EQU #0C934 Extend (A) and (C) into (A,B) % (C,D)
SPLITC EQU #0C940 Extend (C) into (C,D)
RES12 EQU #0C994 Reduce (A,B) into (C)
* addresses
* MTHSTK EQU #2F599 data stack
OX EQU #2FBD0 X address
OZ EQU #2FBF0 Z address
*
* CLX : set X to zero. LastX not modified (see HP41). tested 15july24
WORD 'CLX'
GOSBVL SAVEFP
P= 0
LC(5) OX put X-address into field A of register C
* low order 5 nibbles
CD0EX exchange data pointer address D0 with C(A)
A=0 W
DAT0=A W
D0=C
GOSBVL GETFP
RTNCC
*
* X*2 : multiply X by 2; X transfered to LASTX. Tested 11July2024
WORD 'X*2'
GOSBVL NUMST GET X INTO (A,B), uMODES;SAVEFP;GETX+L
C=B W
D=C W
C=A W copy (A,B) to (C,D)
GOSBVL AD2-15 (A,B) + (C,D) and put result in (A,B) = X+X = 2*X
GOSBVL PUTABX
RTNCC
*
* X/2 : divise X by 2; X transfered to LASTX. Tested 10July2024
WORD 'X/2' ?? * warning: word not unique, in line 0037
GOSBVL NUMST GET X INTO A(A,B), uMODES;SAVEFP;GETX+L
C=0 W
D=C W
P= 14
D=D+1 P
D=D+1 P 2 in Register D
GOSBVL DV2-15 (A,B) / (C,D) = and result in (A,B)
GOSBVL PUTABX
RTNCC
*
* X+2 : add 2 to X ; X transfered to LASTX. Tested 10 July 2024
WORD 'X+2'
GOSBVL NUMST GET X INTO A(A,B), uMODES;SAVEFP;GETX+L
C=B W
D=C W
C=A W copy (A,B) to (C,D)
A=0 W
B=A W
P= 14
B=B+1 P
B=B+1 P 2 in Register B
GOSBVL AD2-15 (A,B) + (C,D) and result in (A,B) = 2+X
GOSBVL PUTABX
RTNCC
*
* X<> exchange the value in the variable with the value in X
* 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
*
* X<>Z exchange the HP41 registers, similar to X<>Y. 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
*
* 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
*
* 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
*
* Z<>T exchange the HP41 registers, tested July 11 2024
WORD 'Z<>T'
P= 0
LC(5) OZ put Z-address into field A of register C
* low order 5 nibbles C(A)
CD0EX exchange data pointer address D0 with C(A)
R1=C save D0 into R1
C=DAT0 W C = value of Z from its address in C(A)
D0=D0+ 16 D0 show now towards T
A=DAT0 W put value of T (from address D0) into A
DAT0=C W T = value of Z
D0=D0- 16 D0 -> Z
DAT0=A W Z = value of T
C=R1
D0=C restore D0
RTNCC
*
* STO- substract X value in the reg address, no lastX, tested 13 07 2024
* use: FVARNAME1 STO- will substract the X value within FVARNAME1
WORD 'STO-'
GOSBVL CHS change sign of X for later calc
GOSBVL SAVEFP
*
C=DAT1 A copy data at address in D1 into C(A) = field A of reg C
* D1 is the data pointer
CD0EX exchange C(A) with D0 (the instruction pointer)
* for now reading the values
A=DAT0 W copy data at address in D0 (in C(A)) into W in A
R0=A R0: value of data at address for later
*
P= 0
LC(5) OX load of X register addr into C(A)
CD0EX exchange C(A) with D0 (the instruction pointer)
A=DAT0 W copy data of X into A
CD0EX exchange C(A) with D0 (the instruction pointer)
C=A W (-XValue) into (C)
A=R0 (RegValue) into (A)
GOSBVL SPLTAC (A) in (A,B) and (C) in (C,D)
GOSBVL AD2-15 (A,B) + (C,D) and result in (A,B) = RegVal -X
GOSBVL RES12 (A,B) into (C)
A=C W put C into A
* now like in STO word
C=DAT1 A copy data at address in D1 into C(A)
CD0EX exchange C(A) with D0 (the instruction pointer)
DAT0=A W Write value (OrgRegVal -X) to reg back
D0=C
GOSBVL GETFP
GOSBVL CHS change back from -X to X
D1=D1+ 5 return nothing on data stack
RTNCC
*
* RCL* upload register value, put X into LastX, multipl reg val with X value,
* upload result into X
WORD 'RCL*'
GOSBVL NUMST X into A,B and X into LastX, SAVEFP
R0=A
A=B W
R1=A X= (A,B) -> (R0,R1)
C=DAT1 A
CD0EX
A=DAT0 W
GOSBVL SPLITA
C=B W
D=C W
C=A W
A=R1
B=A W
A=R0
GOSBVL MP2-15
GOSBVL PUTABX
D1=D1+ 5
RTNCC
*
* RCL- RCL+ RCL/ STO* STO+ ST2* STO/ STO^ coming see total recall HP41 module
* math functions agm magm fibon iterated coming
END
Forth word for a formatted stack output:
Code:
: FSTA. RUP ." T: " F. RUP CR ." Z: " F. RUP CR ." Y: " F.
RUP CR ." X: " F. CR X<>L ." L: " F. X<>L CR ;
I am struggling with the RCL* (the others works).
1.0 2.0 3.0 4.0 FVARIABLE TBX TBX 7.0 STO X<>Y FSTA.
T: 2
Z: 3
Y: 7
X: 4
L: 4
OK { 0 }
TBX RCL*
OK { 0 }
FSTA.
T: 2
Z: 3
Y: 7
X: -2.94024001018E303 should show 28 and not -2.94
L: 4
OK { 0 }
Any idea is welcome how to solve this (having the correct result.. MP2-15 seems a bit weird how to make it working).
UPDATE: the now working word is in the posts below.
All listed routines in the words are entry points which must be defined. Here the list which has to be included into the word file before you start the command in the forth prompt >> " NEWWORDFILE" ASSEMBLE << (I will try to keep it updated; if any issue, let me know via PM).
Code:
* System entry points: see 14-1 of IMS Vol 1
=UMODES EQU #0BDB1 set the modes
=ARGERR EQU #0BF19 for report invalid arg error
=PI EQU #0C000 PI 12digit form (LCHEX)
=SUBONE EQU #0C327 substract 1 to X (A,B) page 1392 of idsv3
=ADDONE EQU #0C330 add 1 to X = (A,B) (AD15S..)
=IN2-15 EQU #0C33E 1/X where X=(A,B)
=X/Y15 EQU #0C34F X/Y where X=(A,B) and Y=(C,D)
=AD2-12 EQU #0C35F 12 digit add = (A) + (C)
=AD2-15 EQU #0C363 15-digit add = (A,B) + (C,D)
=AD15S EQU #0C369 same + SB reset page 1394 of idsv3
=MP2-12 EQU #0C432 12 digit * (A) * (C)
=MP1-12 EQU #0C436 12 digit * (A,B) * (C)
=MP2-15 EQU #0C43A 15-digit multiply (A,B) * (C,D)
=MP15S EQU #0C440 15-digit multiply (A,B) * (C,D)
=MULTF EQU #0C446 ?? Multiply float
*
=DV2-12 EQU #0C4A8 12-digit divise
=DV2-15 EQU #0C4AC 15-digit divise
=DV15S EQU #0C4B2 15-digit divise SB not cleared
*
=SPLITA EQU #0C6BF Extend (A) into (A,B)
=CLRFRC EQU #0C6F4 (A,B) to (A,B) w/o fractio part page 1409
=SPLTAC EQU #0C934 Extend (A) and (C) into (A,B) and (C,D)
=SPLITC EQU #0C940 Extend (C) into (C,D)
=uRES12 EQU #0C994 Reduce (A,B) into (C)
=NRM12 EQU #0C9BB ?? Round to 12 sig digits
*
=YX2-12 EQU #0D274 Y^X & Reg 0 2 3 modified
=STAB1 EQU #0D3D9 Store AB into scratch1 (R0,R1)
=EXAB1 EQU #0D3E7 Exch AB and scratch1
=RCCD1 EQU #0D3F1 Put scratch into CD
=STAB2 EQU #0D400 Store AB into scratch2 (R2,R3)
=EXAB2 EQU #0D40E Exch AB and scratch2
=RCCD2 EQU #0D41C Put scratch2 into CD
=STCD2 EQU #0D427 Store AB into scratch2 (R2,R3)
=uTEST EQU #0D435 User real comparison Page 1484..6
*
=TST15 EQU #0D47A Compare numbers 15dg AB vs CD
* P has the cell# assoClated width the nUMber pair, arg's in 15-dig forM unchanged.
* page 1486 of idsv3
*
=MAKEPI EQU #0D6F1 Put PI into (C,D)
=TWO* EQU #0DB38 Dbl precision doubler
=PI/2 EQU #0DB77 load PI/2 into (C,D)
*
=SB15S EQU #0E19A substraction 15 digits (A,B) = (A,B) - (C,D) . needs SETDEC before
=DMP15S EQU #0E1B3 SETDEC then MP15S
=RESD1 EQU #0E1EE like RES12, dont alter D1
=SPLTAX EQU #0E62B SETDEC, Extend (A) into (A,B) Page 1585
=SIGTST EQU #0E636 Handle signal NaN Page 1585
=BP EQU #0EADF make beep float A HZ Float C duration sec
*
=POP1R EQU #0E8FD RTN of POP1N #0BD1C Seite 1361
* take 1 arg off mathstack
*
=STSCR EQU #0E92C Push (A,B) into top math scratch stack page 1607
*
=RCLW1 EQU #0E981 recall 1 top math stack entry page 1610
* move (AB) to (CD) then recal into (AB)
*
=FNRTN4 EQU #0F238 function return, page 1679
=FLOAT EQU #1B322 change integ to 12dig float in A
*
=MTHSTK EQU #2F599 data stack
*
=FUNCD0 EQU #2F8BB function scratch RAM allocation 5 nibbles
* see FUNCD1 FUNCR0..R1 too page 3089
*
=OL EQU #2FBC0 L address
=OX EQU #2FBD0 X address
=OY EQU #2FBE0 Y address
=OZ EQU #2FBF0 Z address
=OT EQU #2FC00 T address
*
=FEND EQU #E08E9 PUTABX,GETFP
=CHS EQU #E1518 change X sign; dont change LastX
=NUMST EQU #E1718 GET X INTO (A,B); L = X
=MOD EQU #E1718 modulo
*
=OVER EQU #E2538 (n1 n2 -- n1 n2 n1)
=SAVEFP EQU #E717A save Forth pointer
=GETFP EQU #E71A5 restore Forth pointers
=PUTABX EQU #E72F5 Put (A,B) into X, .. GETFP
=GETX EQU #E728A Put X into (A,B)
=GETX+L EQU #E72DF Put X into (A,B) and X in L
HP71B 4TH/ASM/Multimod, HP41CV/X/Y & Nov64d, PILBOX, HP-IL 821.62A & 64A & 66A, Deb11 64b-PC & PI2 3 4 w/ ILPER, VIDEO80, V41 & EMU71, DM41X
|
Search
Member List
Calendar
Help
