• R/O
  • HTTP
  • SSH
  • HTTPS

fig-forth-68000: Commit

Source code for fig-forth-68000


Commit MetaInfo

Revision3f1a4274944559b7e0e8b82ddd019a3be5528fc9 (tree)
Time2023-01-20 21:54:29
AuthorJoel Matthew Rees <joel.rees@gmai...>
CommiterJoel Matthew Rees

Log Message

variations on two loops

Change Summary

Incremental Difference

--- a/FIG68K.S
+++ b/FIG68K.S
@@ -608,8 +608,6 @@ ZBYES MOVE.L (IP)+,D0
608608
609609 * ######>> screen 16 <<
610610
611-******* Continue from the LOOP variables ********
612-
613611 * ======>> 6 <<
614612 * ( --- ) ( limit index *** limit index+1) C
615613 * ( limit index *** )
@@ -633,7 +631,7 @@ XLOOP DC.L *+NATWID
633631 MOVEQ #1,D0 ; Borrowing from BIF-6809.
634632 XLOOPA ADD.L (RP),D0 ; No return address to dodge.
635633 MOVE.L D0,(RP)
636- SUB.L NATWID(RP),D0
634+ SUB.L NATWID(RP),D0 ; Here's why we want the new count in a register.
637635 BMI.S ZBYES ; pseudo-signed-unsigned
638636 XLOOPN LEA NATWID(IP),IP
639637 LEA 2*NATWID(RP),RP ; Clean up the index and limit.
@@ -650,6 +648,25 @@ AXLUPN LEA NATWID(IP),IP
650648 MOVEM.L (RP)+,LUPLIM/LUPCT ; restore possible outer loop controls
651649 BRA.W NEXT
652650 *
651+* DXLUP DC.L *+NATWID
652+* MOVEQ #1,D0 ; Borrowing from BIF-6809.
653+* DXLUPA ADD.L D0,(RP) ; No return address to dodge.
654+* MOVE.L NATWID(RP),D0
655+* CMP.L D0,(RP) ; Here's why we wanted the new count in a register.
656+* BMI.S ZBYES ; pseudo-signed-unsigned
657+* DXLUPN LEA NATWID(IP),IP
658+* LEA 2*NATWID(RP),RP ; Clean up the index and limit.
659+* BRA.W NEXT
660+*
661+RXLUP DC.L *+NATWID
662+ MOVE.L #1,-(PSP) ; Inc value on stack
663+RXLUPA ADD.L (PSP)+,LUPCT
664+ CMP.L LUPLIM,LUPCT
665+ BMI.S ZBYES ; pseudo-signed-unsigned
666+RXLUPN LEA NATWID(IP),IP
667+ MOVEM.L (RP)+,LUPLIM/LUPCT ; restore possible outer loop controls
668+ BRA.W NEXT
669+*
653670 * ======>> 7 <<
654671 * ( n --- ) ( limit index *** limit index+n ) C
655672 * ( limit index *** )
@@ -687,6 +704,14 @@ AXPLUP DC.L *+NATWID ; Loop counter and limit in registers.
687704 BPL.S ZBYES ; pseudo-signed-unsigned
688705 BRA.S AXLUPN ; This path might be less time-sensitive.
689706 *
707+RXPLUP DC.L *+NATWID ; Loop counter and limit in registers.
708+ TST.L (PSP)
709+ BPL.S RXLUPA ; Steal plain loop code for forward count.
710+ ADD.L D0,LUPCT
711+ CMP.L LUPLIM,LUPCT
712+ BPL.S ZBYES ; pseudo-signed-unsigned
713+ BRA.S AXLUPN ; This path might be less time-sensitive.
714+*
690715 * ######>> screen 17 <<
691716 * ======>> 8 <<
692717 * ( limit index --- ) ( *** limit index )
@@ -716,16 +741,83 @@ AXDO DC.L *+NATWID ; This is the alternate register RUNTIME DO, not the COMPILIN
716741 DC.B 'I'|$80 I
717742 DC.L XDO-5-NATWID
718743 I DC.L *+NATWID
719- MOVE.L (RP),D0 ; No return address to dodge.
720- MOVE.L D0,-(PSP)
744+ MOVE.L (RP),-(PSP) ; No return address to dodge.
721745 BRA.W NEXT
722746 *
723747 * This is NOT a synonym for R.
724748 ALTI DC.L *+NATWID
725749 MOVE.L LUPCT,-(PSP) ; nothing to dodge
726750 BRA.W NEXT
727-
728-
751+*
752+* ######>> screen 25 <<
753+* ======>> 20 <<
754+* ( n1 n2 --- n )
755+* Bitwise and the top two integers.
756+ EVEN
757+ DC.B $83
758+ DC.B 'AN' ; 'AND'
759+ DC.B "D"|$80
760+ DC.L I-2-NATWIDTH ; ***** debug link *****
761+* DC.L USLASH-3-NATWID ; correct link
762+AND DC.L *+NATWID
763+ MOVE.L (PSP)+,D0
764+ AND.L D0,(PSP)
765+ BRA.W NEXT
766+*
767+* ======>> 21 <<
768+* ( n1 n2 --- n )
769+* Bitwise or the top two integers.
770+ EVEN
771+ DC.B 0
772+ DC.B $82
773+ DC.B 'O' ; 'OR'
774+ DC.B 'R'|$80
775+ DC.L AND-4-NATWID
776+OR DC.L *+NATWID
777+ MOVE.L (PSP)+,D0
778+ OR.L D0,(PSP)
779+ BRA.W NEXT
780+*
781+* ======>> 22 <<
782+* ( n1 n2 --- n )
783+* Bitwise exclusive or the top two integers.
784+ EVEN
785+ DC.B $83
786+ DC.B 'XO' ; 'XOR'
787+ DC.B 'R'|$80
788+ DC.L OR-3-NATWID
789+XOR DC.L *+NATWID
790+ MOVE.L (PSP)+,D0
791+ EOR.L D0,(PSP)
792+ BRA.W NEXT
793+*
794+* ######>> screen 26 <<
795+* ======>> 23 <<
796+* ( --- adr )
797+* Fetch the parameter stack pointer (before it is pushed).
798+* This points at whatever was on the top of stack before.
799+ EVEN
800+ DC.B $83
801+ DC.B 'SP' ; 'SP@'
802+ DC.B '@'|$80
803+ DC.L XOR-4-NATWID
804+SPAT DC.L *+NATWID
805+ MOVE.L PSP,-(PSP)
806+ BRA.W NEXT
807+*
808+* ======>> 24 <<
809+* ( whatever --- nothing )
810+* Initialize the parameter stack pointer from the USER variable S0.
811+* Effectively clears the stack.
812+ EVEN
813+ DC.B $83
814+ DC.B 'SP' ; 'SP!'
815+ DC.B $A1
816+ DC.L SPAT-4-NATWID
817+SPSTOR DC.L *+NATWID
818+ MOVE.L XSPZER-UORIG(UP),PSP
819+ BRA.W NEXT
820+*
729821
730822 * Fix these later:
731823
@@ -1576,100 +1668,6 @@ USLR LEAU NATWID,U
15761668 * LEAS 1,S ;
15771669 * JMP SWAP+4 reverse quotient & remainder
15781670 *
1579-* ######>> screen 25 <<
1580-* ======>> 20 <<
1581-* ( n1 n2 --- n )
1582-* Bitwise and the top two integers.
1583- FCB $83
1584- FCC 'AN' ; 'AND'
1585- FCB $C4
1586- FDB USLASH-5
1587-AND FDB *+NATWID
1588- PULU A,B
1589- ANDB 1,U
1590- ANDA ,U
1591- STD ,U
1592- LBRA NEXT
1593-* PULS A ;
1594-* PULS B ;
1595-* TFR S,X ; TSX :
1596-* ANDB 1,X
1597-* ANDA 0,X
1598-* JMP STD0X
1599-*
1600-* ======>> 21 <<
1601-* ( n1 n2 --- n )
1602-* Bitwise or the top two integers.
1603- FCB $82
1604- FCC 'O' ; 'OR'
1605- FCB $D2
1606- FDB AND-6
1607-OR FDB *+NATWID
1608- PULU A,B
1609- ORB 1,U
1610- ORA ,U
1611- STD ,U
1612- LBRA NEXT
1613-* PULS A ;
1614-* PULS B ;
1615-* TFR S,X ; TSX :
1616-* ORB 1,X
1617-* ORA 0,X
1618-* JMP STD0X
1619-*
1620-* ======>> 22 <<
1621-* ( n1 n2 --- n )
1622-* Bitwise exclusive or the top two integers.
1623- FCB $83
1624- FCC 'XO' ; 'XOR'
1625- FCB $D2
1626- FDB OR-5
1627-XOR FDB *+NATWID
1628- PULU A,B
1629- EORB 1,U
1630- EORA ,U
1631- STD ,U
1632- LBRA NEXT
1633-* PULS A ;
1634-* PULS B ;
1635-* TFR S,X ; TSX :
1636-* EORB 1,X
1637-* EORA 0,X
1638-* JMP STD0X
1639-*
1640-* ######>> screen 26 <<
1641-* ======>> 23 <<
1642-* ( --- adr )
1643-* Fetch the parameter stack pointer (before it is pushed).
1644-* This points at whatever was on the top of stack before.
1645- FCB $83
1646- FCC 'SP' ; 'SP@'
1647- FCB $C0
1648- FDB XOR-6
1649-SPAT FDB *+NATWID
1650- TFR U,X
1651- PSHU X
1652- LBRA NEXT
1653-* TFR S,X ; TSX :
1654-* STX N scratch area
1655-* LDX #N
1656-* JMP GETX
1657-*
1658-* ======>> 24 <<
1659-* ( whatever --- nothing )
1660-* Initialize the parameter stack pointer from the USER variable S0.
1661-* Effectively clears the stack.
1662- FCB $83
1663- FCC 'SP' ; 'SP!'
1664- FCB $A1
1665- FDB SPAT-6
1666-SPSTOR FDB *+NATWID
1667- LDU <XSPZER
1668- LBRA NEXT
1669-* LDX UP
1670-* LDX XSPZER-UORIG,X
1671-* TFR X,S ; TXS : watch it ! X and S are not equal on 6800.
1672-* JMP NEXT
16731671 * ======>> 25 <<
16741672 * ( whatever *** nothing )
16751673 * Initialize the return stack pointer from the initialization table
Show on old repository browser