Jump to content
Have You Played Atari Today?
2600|5200|7800|Lynx|Jaguar|Forums|Store
IGNORED

fbForth—TI Forth with File-based Block I/O [Post #1 UPDATED: 06/09/2023]

Lee Stewart

By Lee Stewart
in TI-99/4A Development

 Share

Recommended Posts

TheBF River Patroller

+TheBF

Posted
Posted
57 minutes ago, Lee Stewart said:

Here is the next alpha of fbForth 2.1 (build #). In addition to the changes in build @, it adds the following:

  • The cursor used by KEY is now the inverse of the character under the cursor. This is most apparent in the 40/80 column editor.
  • Rewrote WLITERAL per discussion somewhere above.
  • Rewrote zero-compare words, 0= , 0< , 0> , for efficiency.

fbForth210_9.bin 32 kB · 1 download        fbForth210_8.bin 32 kB · 1 download       fbForth210.rpk 20.98 kB · 1 download

 

...lee

 

That cursor with repeating keys is pretty slick Lee.

;) 

  • Like 1
  • Thanks 1
Link to comment
Share on other sites
Lee Stewart Quadrunner

+Lee Stewart

Posted
  • Author
Posted
12 hours ago, TheBF said:

That cursor with repeating keys is pretty slick Lee.

;) 

 

Adding an inverse-character cursor to KEY re-exposed a gotcha I had forgotten about. Initially, I used all of registers R0 – R7. This broke fbForth. I finally traced the problem to adding the use of R5. Fortunately, I could use CRU (R12) within the routine without any deleterious effect.

 

Of course, I could not leave it there without knowing why I could not safely use R5. Using KEY in most situations is not a problem, but the infinite outer interpreter loop uses EXPECT to handle keyboard input and EXPECT calls KEY expecting R5 to be preserved. EXPECT uses R5 as a pointer to the current character position in the Terminal Input Buffer. Calling KEY with BL means that both EXPECT and KEY use the same workspace. The only indication this could be a problem was the comment, “R5 only safe reg”, I had added to my first use of R5 in the EXPECT code. For the terminally curious, the ALC for KEY follows in the spoiler:

 

Spoiler 

;[*== KEY routine                           CODE =  -2  =================
*
*  Keyboard part of this routine uses all available Forth registers:
*     R0..R4, R6..R7, CRU
*  R5 is unavailable because EXPECT calls this routine expecting R5
*  to be preserved!
*
KY    MOV  @$ALTI(U),R0      alternate input device?
       JEQ  KEY0              jump to keyboard input if not
*
*  R0 now points to PAB for alternate input device, the one-byte buffer
*  for which must immediately precede its PAB.  PAB must have been set up
*  to read one byte.
*
       CLR  R7                prepare to zero status byte
       MOVB R7,@KYSTAT        zero status byte
       INC  R0                point R0 to Flag/Status byte
       BLWP @VSBR             read it
       ANDI R1,>1F00          clear error bits without disturbing flag bits
       BLWP @VSBW             write it back to PAB
       MOV  R0,R1             Set up pointer...
       AI   R1,8              ...to namelength byte of PAB
       MOV  R1,@SUBPTR        copy to DSR subroutine name-length pointer
       MOV  R0,R3             save pointer (DSRLNK will trash it!)
       BLWP @DSRLNK           get 1 byte from device
       DATA >8
       MOV  R3,R0             restore pointer
       DECT R0                point to one-byte VRAM buffer in front of PAB
       BLWP @VSBR             read character
       SRL  R1,8              move to LSB
       MOV  R1,R0             copy to return register
       JMP  BKLINK           return to caller
* 
* Input is coming from the keyboard.
*
* This routine has been modified to allow for key repeats by holding
* a key down long enough. Repeats can be disabled by storing an odd
* number at RH. User can do this by storing at DCT+16. Access to RL
* is similarly at DCT+18, but should never be odd.
*
KEY0   INC  @KEYCNT           inc cursor/char blink count
       JNE  KEY1              jump if re-entry
       MOV  @CURPO$(U),R0     get cursor position
       BLWP @VSBR             Read character at cursor position..
       MOVB R1,@CURCHR        ..and save it
       JMP  KEY2A             Place cursor character on screen
*
* Check for keystroke
KEY1   BLWP @KSCAN            check keyboard..
       MOVB @KYSTAT,R0        ..for keystroke
       COC  @H2000,R0         check status
       JEQ  KEYX              jump if key was pressed
* 
* Check time for char blink
       LI   R7,180            load time for char blink
       C    @KEYCNT,R7        time to blink char?
       JNE  KEY2              jump if not
       MOVB @CURCHR,R1        yes..get char to display
       JMP  KEY3              and display it
*
* Check time for cursor blink
KEY2   SLA  R7,1              load time (360) for cursor blink
       C    @KEYCNT,R7        time to blink cursor?
       JNE  KEY4              jump if not
       CLR  @KEYCNT           yes..clear blink count for re-entry
*
* Cursor to Inverse of Current Character
KEY2A  MOVB @CURCHR,R0        ASCII of CURCHR to R0
       SRL  R0,8              get to LSB
       SLA  R0,3              compute PDT offset of CURCHR pattern
       A    @$PDT(U),R0       PDT position of CURCHR pattern in VRAM
       LI   R1,CHRSAV         CPU work area below
       LI   R2,8              byte count to transfer
       BLWP @VMBR             transfer bytes
       SETO R3                set R3 to all ones for XOR
       MOV  R1,R4             copy CHRSAV address
       MOV  R2,R6             copy byte count
*
* Pattern inversion loop...
* ...using CRU (should be free to use here) because CRU is the
*    only available register left!
KEY2LP MOV  *R4,CRU           copy pattern word to CRU
       XOR  R3,CRU            invert it
       MOV  CRU,*R4+          copy inverted pattern back
       DECT R6                done?
       JNE  KEY2LP            invert another word if not done
       LI   R0,>00F0          PDT offset of cursor char pattern
       A    @$PDT(U),R0       PDT position of cursor char pattern in VRAM
       BLWP @VMBW             write inverted pattern to cursor char pattern
*
* Continue cursor blink
       LI   R1,>1E00          get cursor char
KEY3   MOV  @CURPO$(U),R0     get cursor position
       BLWP @VSBW             display cursor or char
*
* Check for key, pressed or not
KEY4   CB   @KYCHAR,@HXFF00   no key?
       JNE  KEY5              jump if we have a key
       MOV  @RH,@RCNT         reset repeat count
       JMP  KEY6              re-enter via fbForth's KEY
* 
* Repeat key processing
KEY5   DECT @RCNT             time to repeat key?
       JNE  KEY6              jump if not yet time
       MOV  @RL,@RCNT         set repeat count to low count
       JMP  KEYX              process key
* 
* Set up to re-enter via fbForth's KEY       
KEY6   MOV  @INTACT,R7        Are we in user's ISR?
       JNE  KEY7              Don't enable interrupts if so.
       LIMI 2                 no..enable interrupts
KEY7   DECT IP                re-execute fbForth's KEY
       B    *NEXT
* 
* Return pressed/same key to caller
KEYX   SETO @KEYCNT           -1 to reset re-entry indicator
       MOV  @CURPO$(U),R0     Restore character at cursor location
       MOVB @CURCHR,R1
       BLWP @VSBW
       MOVB @KYCHAR,R0        Put char in...
       SRL  R0,8              ...LSB of R0
       B    @BKLINK           return to caller
*
CHRSAV BSS  8                 Work area for char inversion
*
;]*

 

 

...lee

  • Like 2
Link to comment
Share on other sites
TheBF River Patroller

+TheBF

Posted
Posted

You are pushing the old girl to the max. :) 

Your R0 comment is making me think about alternate in/out devices.

I only recently realized that since EMIT and TYPE output to VDP RAM they could just as easily output to a PAB buffer. Duh! :) 

  • Like 2
Link to comment
Share on other sites
TheBF River Patroller

+TheBF

Posted
Posted
1 hour ago, Lee Stewart said:

 

Of course, I could not leave it there without knowing why I could not safely use R5. Using KEY in most situations is not a problem, but the infinite outer interpreter loop uses EXPECT to handle keyboard input and EXPECT calls KEY expecting R5 to be preserved. EXPECT uses R5 as a pointer to the current character position in the Terminal Input Buffer. 

Would you ever consider replacing a register or 2 with with some local space on the R stack?

9900  *RP access is till pretty quick.

Link to comment
Share on other sites
Lee Stewart Quadrunner

+Lee Stewart

Posted
  • Author
Posted
2 hours ago, TheBF said:

Would you ever consider replacing a register or 2 with with some local space on the R stack?

9900  *RP access is till pretty quick.

 

Surely. But, when writing ALC, I would just need to be very careful the return stack was cleared of local stuff before any possible exits (there are two)—except ABORT , of course.

 

...lee

  • Like 2
Link to comment
Share on other sites
Lee Stewart Quadrunner

+Lee Stewart

Posted
  • Author
Posted (edited)

fbForth has four different joystick words:

  • JKBD for handling input from both the keyboard and the joysticks
  • JCRU for reading only the CRU bits for the joysticks
  • JOYST for calling JKBD ( JMODE = 0 ) or JCRU ( JMODE ≠ 0 )
  • JMODE for controlling behavior of JOYST

I have rewritten the joystick routine ( JKBD ) that processes keyboard/joystick input via KSCAN. It recovers some space by using a smaller (16 bytes) lookup table (was 48 bytes) and doing away with MPY. I have included the code for your delectation. The old routine is in the first spoiler and the new routine (along with all of the above joystick words) is in the second spoiler:

 

Spoiler 

*++ JTBL ++* table of values (chr, xstat & ystat) for JKBD ***
JTBL   BYTE >00,>00,>FC     ; chr = >00
       BYTE >00,>00,>00     ; chr = >01 (illegal)
       BYTE >02,>FC,>00     ; chr = >02
       BYTE >03,>04,>00     ; chr = >03
       BYTE >04,>FC,>04     ; chr = >04
       BYTE >05,>00,>04     ; chr = >05
       BYTE >06,>04,>04     ; chr = >06
       BYTE >00,>00,>00     ; chr = >07 (illegal)
       BYTE >00,>00,>00     ; chr = >08 (illegal)
       BYTE >00,>00,>00     ; chr = >09 (illegal)
       BYTE >00,>00,>00     ; chr = >0A (illegal)
       BYTE >00,>00,>00     ; chr = >0B (illegal)
       BYTE >00,>00,>00     ; chr = >0C (illegal)
       BYTE >00,>00,>00     ; chr = >0D (illegal)
       BYTE >0E,>04,>FC     ; chr = >0E
       BYTE >0F,>FC,>FC     ; chr = >0F

;]
;[*** JKBD ***       ( kbd --- chr xstat ystat )
*        DATA MGFY_N
* JKBD_N DATA 4+TERMBT*LSHFT8+'J','KB','D '+TERMBT

JKBD   DATA $+2
JKBDP  MOVB @1(SP),@>8374   ; set keyboard mode
       LIMI 0               ; interrupts will be re-enabled when next routine returns
       BL   @QKY            ; get 0 or key to R0 (will be ignored)
       MOVB @>8375,@1(SP)   ; get code from >8375 to right byte of top of stack
       MOV  *SP,R1          ; also, to R1
       DECT SP              ; reserve stack space
       CLR  *SP             ; zero top of stack for byte transfer
       DECT SP              ; reserve stack space
       CLR  *SP             ; zero top of stack for byte transfer
       CI   R1,>0012        ; fire button?
       JEQ  FBJOY
       CI   R1,>00FF        ; joystick?
       JEQ  FBJOY
       CI   R1,>000F        ; legal joystick key?
       JLE  JKBD01
       LI   R1,1            ; set to illegal chr
JKBD01 ANDI R1,>000F        ; strip all but last byte
       LI   R0,3            ; load multiplier
       MPY  R1,R0           ; multiply by 3
       AI   R1,JTBL         ; get entry into JTBL
       MOVB *R1+,@5(SP)     ; STACK: (from JTBL-->) chr 0 0
       MOVB *R1+,@3(SP)     ; STACK: (from JTBL-->) chr xstat 0
       MOVB *R1,@1(SP)      ; STACK: (from JTBL-->) chr xstat ystat
       JMP  JKBDEX          ; we're outta here
FBJOY  MOVB @>8377,@3(SP)   ; STACK: 12h|FFh xstat 0
       MOVB @>8376,@1(SP)   ; STACK: 12h|FFh xstat ystat
JKBDEX CLR  R1
       MOVB R1,@>8374       ; restore keyboard mode
       B    *NEXT

 

 

Spoiler 

*       __              __  _     __     _      __            __  
*   __ / /__  __ _____ / /_(_)___/ /__  | | /| / /__  _______/ /__
*  / // / _ \/ // (_-</ __/ / __/  '_/  | |/ |/ / _ \/ __/ _  (_-<
*  \___/\___/\_, /___/\__/_/\__/_/\_\   |__/|__/\___/_/  \_,_/___/
*           /___/     
                                                     
;[*++ JTBL ++* table of values (xstat & ystat) for JKBD ***
** Byte is a composite of the 2 bytes, xstat and ystat, for
** each left (1) or right (2) keyboard character from 0..>0F.
** Each nybble maps to an x|y-stat byte value as follows:
**    Nybble x|y-stat
**    ------ --------
**      >0     >00
**      >4     >04
**      >C     >FC
*
JTBL   BYTE >0C     ; chr = >00
       BYTE >00     ; chr = >01 (illegal)
       BYTE >C0     ; chr = >02
       BYTE >40     ; chr = >03
       BYTE >C4     ; chr = >04
       BYTE >04     ; chr = >05
       BYTE >44     ; chr = >06
       BYTE >00     ; chr = >07 (illegal)
       BYTE >00     ; chr = >08 (illegal)
       BYTE >00     ; chr = >09 (illegal)
       BYTE >00     ; chr = >0A (illegal)
       BYTE >00     ; chr = >0B (illegal)
       BYTE >00     ; chr = >0C (illegal)
       BYTE >00     ; chr = >0D (illegal)
       BYTE >4C     ; chr = >0E
       BYTE >CC     ; chr = >0F

;]
;[*** JKBD ***       ( kbd --- chr xstat ystat )
*        DATA MGFY_N
* JKBD_N .name_field 4, 'JKBD '

JKBD   DATA $+2
JKBDP  MOVB @1(SP),@>8374   ; set keyboard mode
       LIMI 0               ; disable interrupts
       BLWP @KSCAN          ; get key
       MOV  @INTACT,R7      ; Are we in user's ISR?
       JNE  JKBD00          ; Don't enable interrupts if so
       LIMI 2               ; enable interrupts
JKBD00 MOVB @>8375,@1(SP)   ; get code from >8375 to LSB of top of stack
       MOV  *SP,R1          ; also, to R1
       DECT SP              ; reserve stack space
       CLR  *SP             ; zero top of stack for byte transfer
       DECT SP              ; reserve stack space
       CLR  *SP             ; zero top of stack for byte transfer
       CI   R1,>0012        ; fire button?
       JEQ  FBJOY
       CI   R1,>00FF        ; joystick?
       JEQ  FBJOY
       CI   R1,>000F        ; possibly legal joystick key?
       JLE  JKBD01
       LI   R1,1            ; nope..set to illegal chr
JKBD01 ANDI R1,>000F        ; strip all but last nybble
       MOVB @JTBL(R1),R2    ; copy byte (xstat,ystat) from JTBL to R2
       JNE  JKBD02          ; if not 0, skip zeroing chr
       CLR  R1              ; zero chr for stack copy
       JMP  JKBD03          ; STACK: [8375] 0 0
JKBD02 SRA  R2,4            ; shift (with sign bit) MS nybble 1 nybble right
       MOVB R2,@3(SP)       ; STACK: [8375]|0 xstat 0
       SLA  R2,8            ; shift ystat nybble to MSN
       SRA  R2,4            ; shift (with sign bit) MSN 1 nybble right
       MOVB R2,@1(SP)       ; STACK: [8375]|0 xstat ystat
JKBD03 MOV  R1,@4(SP)       ; STACK: chr xstat ystat
       JMP  JKBDEX          ; we're outta here
FBJOY  MOVB @>8377,@3(SP)   ; STACK: 12h|FFh xstat 0
       MOVB @>8376,@1(SP)   ; STACK: 12h|FFh xstat ystat
JKBDEX CLR  R1
       MOVB R1,@>8374       ; restore keyboard mode
       B    *NEXT

* HEX
* : JKBD      ( kbd --- chr xstat ystat )  
*     8374 C!                     
*     ?KEY DROP
*     8375 C@ DUP                   ( STACK: chr chr)
*     12 =                          ( chr=12h? [fire button] STACK: chr flag1)
*     OVER 0FF =                    ( chr=FFh? [joystick] STACK: chr flag1 flag2)
*     OR                            ( STACK: chr flag1 OR flag2)
*     IF        ( fire button or joystick activated)
*         8377 C@ 8376 C@           ( STACK: 12h|FFh xstat ystat)
*     ELSE                          ( key depressed)
*         DUP                       ( STACK: chr chr)
*         CASE
*             4 OF 0FC 4  ENDOF  
*             5 OF 0 4 ENDOF  
*             6 OF 4   4 ENDOF      
*             2 OF 0FC 0  ENDOF  
*             3 OF 4 0 ENDOF  
*             0 OF 0 0FC ENDOF      
*             0F OF 0FC 0FC ENDOF 
*             0E OF 4 0FC ENDOF 
*             DROP DROP 0 0 0 0     ( illegal key STACK: 0 0 0 0)
*         ENDCASE                   ( STACK: 0 0 0, if it gets here)
*     THEN                          ( STACK: chr xstat ystat)
*     0 8374 C!  ;                  ( restore previous full keyboard mode)
;]
;[*** JCRU ***       ( joystick# --- value )
* Code for JCRU is courtesy of Mark Wills and was ported from his 
* TurboForth code for JOYST.
*
*        DATA JKBD_N
* JCRU_N .name_field 4, 'JCRU '

JCRU   DATA $+2
JCRUP  MOV  *SP,R1          ; get unit number
       AI   R1,5            ; use keyboard select 6 for #1, 7 for #2
       SWPB R1              ; get keyboard select to MSB
       LI   CRU,>0024       ; point to joystick/keyboard
       LDCR R1,3            ; strobe relevant joystick/keyboard line
       LI   CRU,6           ; point to keyboard outputs
       STCR R1,5            ; store 5 bits
       SWPB R1              ; get to LSB
       INV  R1              ; convert each strobe to 1
       ANDI R1,>001F        ; insure we have only the 5 bits of interest
       MOV  R1,*SP          ; push to stack for decoding by user
       CLR  @>83D6          ; defeat auto screen blanking without KSCAN
       B    *NEXT
;]
;[*** JMODE ***      ( --- addr )
*++ User Variable contains 0 for TI Forth or ~0 for CRU)

*        DATA JCRU_N
* JMDE_N .name_field 5, 'JMODE'

JMODE  DATA DOUSER              ; get address of user variable JMODE to stack
       DATA $JMODE
;]
;[*** JOYST ***      ( kbd|joyst --- [chr xst yst]|n ) 
*        DATA JMDE_N
* JOY__N .name_field 5, 'JOYST'
JOYST  DATA $+2
       MOV  @$JMODE(U),R0       ; test JMODE
       JEQ  JKBDP               ; JKBD, if JMODE = 0
       JMP  JCRUP               ; JCRU, if JMODE = ~0

* : JOYST     ( kbd|joyst --- [chr xst yst]|n )                       
*     JMODE @ 
*     IF 
*         JCRU 
*     ELSE 
*         JKBD 
*     THEN  ;
;]

 

 

...lee

Edited by Lee Stewart
Added attribution for JCRU code
  • Like 2
Link to comment
Share on other sites
TheBF River Patroller

+TheBF

Posted
Posted

That's seem like a nice improvement. I don't fully understand the table.

Does it translate joystick outputs to equivalent keyboard values?

 

I have a very simple JOYST word which I have never used.

I think I looked at Mark's code to figure something out. 

I see it looks very much like your JCRUP. 

  

\ HEX Outputs in TOS register
\ 01 = Fire
\ 02 = Left
\ 04 = Right
\ 08 = Down
\ 10 = Up
HEX
CODE JOYST ( joystick# -- value ) \ #0 = joyst1, #1 = joyst2
   0224 , 0006 ,  \ TOS  06 AI,     \ joyst# to real CRU adress
   06C4 ,         \ TOS     SWPB,   \
   020C , 0024 ,  \ R12  24 LI,     \ joystick i/o address
   30C4 ,         \ TOS  03 LDCR,   \ write 3 bits to enable joysticks
   020C , 0006 ,  \ R12  06 LI,     \ select column 6
   3544 ,         \ TOS  05 STCR,   \ get 5 bits from joystick
   06C4 ,         \ TOS     SWPB,   \ swap byte
   0544 ,         \ TOS     INV,    \ change to positive logic
   0244 , 001F ,  \ TOS 01F ANDI,   \ mask off the junk
   04E0 , 83D6 ,  \ 83D6 @@ CLR,    \ reset screen timeout
   NEXT,
   ENDCODE

 

Link to comment
Share on other sites
Lee Stewart Quadrunner

+Lee Stewart

Posted
  • Author
Posted (edited)
9 hours ago, TheBF said:

I think I looked at Mark's code to figure something out. 

I see it looks very much like your JCRUP. 

 

That’s because I’m reasonably sure that’s where I got it. I should have credited @Willsy in the code.  |:)   I will correct that tomorrow. [done]

 

...lee

Edited by Lee Stewart
  • Like 3
  • Thanks 1
Link to comment
Share on other sites
Lee Stewart Quadrunner

+Lee Stewart

Posted
  • Author
Posted
1 hour ago, TheBF said:

That seems like a nice improvement. I don't fully understand the table.

Does it translate joystick outputs to equivalent keyboard values?

 

Pretty much. The table covers the possible key-value range, 0 – 15 (0 – >F), and contains the corresponding equivalent of the directional joystick x and y bytes collapsed to two nybbles in one byte for each key value, obviating the need to calculate the table offset—the key value is the table offset. The illegal, i.e., non-joystick, key values ( 1, 7 – 13 ) are all returned as zeroes. The code is read into the MSB of R2 to be manipulated for the stack by a 4-bit arithmetic right shift that converts the left nybble to the x byte in the MSB. After copying that byte to the stack, two arithmetic shifts, 8 bits left followed by 4 bits right, isolate and convert the right nybble to the y byte in the MSB, which is subsequently copied to the stack.

 

Allowable directional byte values are >00, >04, >FC. For the table, the left nybble of these bytes is simply dropped and the table byte composed of the remaining x and y nybbles. A retrieved table byte is processed by insuring that each nybble is the MSN (Most Significant Nybble) before right-shifting it into its proper position for transfer.  This will fill the left nybble with the sign bit. Of course, this only matters for >C, which is changed from >C to >FC by the right arithmetic shift. I’ll stop talking now....

 

...lee

  • Like 3
  • Thanks 1
Link to comment
Share on other sites
Lee Stewart Quadrunner

+Lee Stewart

Posted
  • Author
Posted

I am considering changing the bootup state of fbForth 2.1’s ISR. Currently, the ISR is enabled at bootup so that the fbForth speech and sound routines are processed by default. This does, unnecessarily, slow the interpreter down a touch. I suspect that the host of fbForth users out there :waving: are not very often availing themselves of the relatively new fbForth speech and sound routines. Servicing those and the user’s own ISR(s) is the only reason for enabling fbForth 2.1’s ISR. What do you think?

 

...lee

  • Like 2
Link to comment
Share on other sites
TheBF River Patroller

+TheBF

Posted
Posted
44 minutes ago, Lee Stewart said:

I am considering changing the bootup state of fbForth 2.1’s ISR. Currently, the ISR is enabled at bootup so that the fbForth speech and sound routines are processed by default. This does, unnecessarily, slow the interpreter down a touch. I suspect that the host of fbForth users out there :waving: are not very often availing themselves of the relatively new fbForth speech and sound routines. Servicing those and the user’s own ISR(s) is the only reason for enabling fbForth 2.1’s ISR. What do you think?

 

...lee

I think I remember some time back where I compared some benchmarks on FbForth with ISR running/not running and there was not a measurable difference. (I might have done it wrong)

Back of the napkin, I would guess that entering the interrupt every 16mS and returning, after doing nothing, would not be much compared to the time spent in the inner interpreter.

 

I think this is a good case for testing your hypothesis. ;) 

 

  • Like 2
Link to comment
Share on other sites
Lee Stewart Quadrunner

+Lee Stewart

Posted
  • Author
Posted
5 hours ago, TheBF said:

I think I remember some time back where I compared some benchmarks on FbForth with ISR running/not running and there was not a measurable difference. (I might have done it wrong)

Back of the napkin, I would guess that entering the interrupt every 16mS and returning, after doing nothing, would not be much compared to the time spent in the inner interpreter.

 

I think this is a good case for testing your hypothesis. ;) 

 

I wrote some Forth words (see the spoiler below) to exercise the interpreter with ( +ISR ) and without ( -ISR ) the ISR hook enabled:

 

Spoiler 

HEX
: ZEROTIMER
   0 83D6 !       \ zero screen timeout timer
;
: TICKS   ( -- ticks )
   83D6 @         \ read double ticks from timer
   1 SRL          \ convert to ticks
;
DECIMAL
: DOSTUFF
   ZEROTIMER
   CURPOS @             \ get cursor position
   30001 1 DO           \ loop 30000 times
      I 1000 MOD
      0= IF             \ every 1000 MODs
         DUP CURPOS !   \ reset cursor
         I .            \ print loop index over last one
      THEN
   LOOP
   DROP                 \ clean up
   CR TICKS . ." ticks" CR    \ result
;
HEX
: +ISR
   INTLNK @ 83C4 !
   DOSTUFF
;

: -ISR
   0 83C4 !
   DOSTUFF
;
DECIMAL

 

 

Each word runs DOSTUFF to loop a MOD calculation 30000 times, printing every 1000th iteration. When done, the number of timer ticks (60ths of a second) is displayed:

 

Word   Ticks

----   -----

+ISR   1559

-ISR   1547

 

As you can see the ISR was only ~0.8 % slower. Still....

 

...lee

  • Like 3
Link to comment
Share on other sites
TheBF River Patroller

+TheBF

Posted
Posted

I stand corrected. :) 

So I guess it comes down to any other ramifications or inconvenience that disabling interrupts may cause.

If I understand correctly you are just disabling your code on the USER interrupt.

The screen timer etc. will still be running normally?

 

Link to comment
Share on other sites
Lee Stewart Quadrunner

+Lee Stewart

Posted
  • Author
Posted
7 minutes ago, TheBF said:

I stand corrected. :) 

So I guess it comes down to any other ramifications or inconvenience that disabling interrupts may cause.

If I understand correctly you are just disabling your code on the USER interrupt.

The screen timer etc. will still be running normally?

 

Yes. Interrupts are not disabled. Rather, setting the ISR hook at >83C4 to 0, prevents the fbForth ISR from running every time the console ISR runs. Unless you really know what you are doing, user ISRs should never be installed at >83C4. That should be reserved for the address of the fbForth ISR contained in the INTLNK user variable. A user ISR’s cfa should be copied to the ISR user variable to be run by the enabled fbForth ISR. This is all explained in excruciating detail in Chapter 10 of fbForth 2.0: A File-Based Cartridge Implementation of TI Forth. 

 

...lee

  • Like 3
  • Haha 1
Link to comment
Share on other sites
Lee Stewart Quadrunner

+Lee Stewart

Posted
  • Author
Posted (edited)

I finally got around to running the console ROM’s XML FMULT routine against fbForth 2.1’s F* in ROM3. The code is in the spoiler below:

 

Spoiler 

HEX
: ZEROTIMER
   0 83D6 !       \ zero screen timeout timer
;
\ One tick is 1/60 second
: TICKS   ( -- ticks )
   83D6 @         \ read double ticks from timer
   1 SRL          \ convert to ticks
;
DECIMAL

\ Test fbForth 2.1 ROM3 FP multiply
: F*TEST1   ( fp1 fp2 -- )
   ZEROTIMER
   10000 0  DO
      FOVER FOVER
      F*             \ fbForth 2.1 ROM3 FP multiply
      FDROP
   LOOP
   FDROP FDROP
   TICKS CR ." Done! " . ." ticks"
; 

HEX
834A CONSTANT FAC
835C CONSTANT ARG
0E88 CONSTANT FMULT
83E0 CONSTANT GPLWS
8300 CONSTANT FORTHWS

\ Forth Assembler version of call to console ROM XML FMULT
ASM: FXML*  ( fp1 fp2 -- fp3 )
\ stack to ARG
   R0 ARG LI,
   *SP+ *R0+ MOV,
   *SP+ *R0+ MOV,
   *SP+ *R0+ MOV,
   *SP+ *R0 MOV,
   
\ stack to FAC
   R0 FAC LI,
   *SP+ *R0+ MOV,
   *SP+ *R0+ MOV,
   *SP+ *R0+ MOV,
   *SP  *R0 MOV,
   SP -6 AI,            \ restore last FP top of stack

\ call XML FMULT in console ROM
   GPLWS LWPI,          \ change to GPL workspace
   FMULT @@ BL,         \ call console FMULT
   FORTHWS LWPI,        \ back to Forth workspace
   
\ FAC to stack
   R0 FAC LI,
   *R0+ *SP+ MOV,
   *R0+ *SP+ MOV,
   *R0+ *SP+ MOV,
   *R0  *SP MOV,
   SP -6 AI,            \ restore last FP top of stack
;ASM
DECIMAL

\ Test the console ROM XML FMULT routine
: F*TEST2   ( fp1 fp2 -- )
   ZEROTIMER
   10000 0  DO
      FOVER FOVER
      FXML*             \ console ROM XML FMULT
      FDROP
   LOOP
   FDROP FDROP
   TICKS CR ." Done! " . ." ticks"
;

ASM: F2DROP   ( fp1 fp2 -- )
   SP 16 AI,       \ pop 8 bytes from stack
;ASM

\ Test the loop without FP multiply
: FTEST   ( fp1 fp2 -- )
   ZEROTIMER
   10000 0  DO
      FOVER FOVER
      F2DROP
   LOOP
   FDROP FDROP
   TICKS CR ." Done! " . ." ticks"
;

 

 

F*TEST1 runs F* in a loop 10000 times. F*TEST2 runs FXML* in the same loop. Finally, FTEST runs the same loop, as a control, without any FP multiply. FTEST took 3.7 seconds. After accounting for that, F*TEST2 took 10.3 seconds, handily beating F*TEST1 's 17 seconds! 

 

F* and FXML* are running pretty much the same code. The time difference is entirely due to the console ROM running on the 16-bit bus over the fbForth ROM on the 8-bit bus.

 

...lee

 

Edited by Lee Stewart
ADDITIONAL COMMENT
  • Like 5
Link to comment
Share on other sites
  • 6 months later...
Lee Stewart Quadrunner

+Lee Stewart

Posted
  • Author
Posted (edited)

I did some work on the fbForth TMS9900 Assembler to attempt to reduce its footprint and to divine explanations for the words. I managed only a 90-byte reduction from 3208 to 3118. The explanations could probably use some work, but this is a start. So far, the only testing I have done is to confirm that it compiles successfully. The code is in the spoiler:

 

Spoiler 
\ fbForth ASSEMBLER       ..from TI Forth 12JUL82 LCT
\   ..modified by Lee Stewart 12DEC2013 and 12NOV2022
HEX 
ASSEMBLER DEFINITIONS

\ Helper word to test whether the operand includes an address?
: ADDR?  ( {addr} operand -- flag ) 
   DUP 1F > SWAP  \ S:operand>1F operand
   30 < AND  ;    \ S:(operand>1F)&(operand<30)

\ GOP' ..helper word to compile General address operand
\        and OPcode.
: GOP'  ( {addr} operand opcode -- )
   \ compute instruction and compile it
   OVER + ,       \ S:{addr} opnd
   ADDR?          \ S:{addr} (opnd>1F)&(opnd<30)
   IF             \ S:addr
      ,        \ compile addr
   ENDIF  ;    

\ GROP' ..helper word to compile General address src and
\         Register dst operands and OPcode.
: GROP'  ( {addr1} operand1 opcode operand2 -- )
   6 SLA +     \ shift operand2 and add to opcode
   GOP'  ;     \ compute instruction..compile it and any address

\ GOP ..define word to compile instruction with single General
\       address operand and OPcode.
: GOP   ( opcode -- )  ( IS:<instruction name> )
   <BUILDS , 
   DOES>  ( {addr} operand pfa -- )
      @           \ S:{addr} operand opcode
      GOP' ;
                                  
0440 GOP B,     
0680 GOP BL,    
0400 GOP BLWP,                 
04C0 GOP CLR,   
0700 GOP SETO,  
0540 GOP INV,                  
0500 GOP NEG,   
0740 GOP ABS,   
06C0 GOP SWPB,                 
0580 GOP INC,   
05C0 GOP INCT,  
0600 GOP DEC,   
0640 GOP DECT,  
0480 GOP X,

\ GROP ..define word to compile instruction with General
\        address src and Register dst operands and OPcode.
: GROP  ( opcode -- )  ( IS:<instruction name>)
   <BUILDS , 
   DOES>  ( {addr1} operand1 operand2 pfa -- )
      @              \ S:{addr1} operand1 operand2 opcode
      SWAP           \ S:{addr1} operand1 opcode operand2
      GROP' ;
                     
2000 GROP COC,  
2400 GROP CZC,  
2800 GROP XOR,                  
3800 GROP MPY,  
3C00 GROP DIV,  
2C00 GROP XOP,

\ GGOP ..define word to compile instruction with General
\        address src and General address dst operands and OPcode.
: GGOP  ( opcode -- )  ( IS:<instruction name>)
   <BUILDS , 
   DOES>  ( {{addr1} operand1 {addr2} operand2 pfa -- ) \ S:{ad} rop pfa
      @ SWAP DUP ADDR?        \ S:{ad} rop opcd
      IF             \ operand2 is a symbolic or indexed address
         ROT >R      \ get addr2 to return stack   
         GROP' R> ,  \ process instruction, ending by compiling addr2
      ELSE           \ operand2 is register-based
         GROP'       \ process instruction (no addr2)
      ENDIF ;
    
A000 GGOP A, 
B000 GGOP AB,  
8000 GGOP C,   
9000 GGOP CB,       
6000 GGOP S,  
7000 GGOP SB,  
E000 GGOP SOC, 
F000 GGOP SOCB,     
4000 GGOP SZC,  
5000 GGOP SZCB,  
C000 GGOP MOV,  
D000 GGOP MOVB,

\ 0OP ..define word to compile instruction with 0 operands
\       plus OPcode.
: 0OP  ( opcode -- )  ( IS:<instruction name>)
   <BUILDS , 
   DOES>   ( pfa -- )
      @ , ;    \ get opcode and compile instruction

0340 0OP IDLE,  
0360 0OP RSET, 
03C0 0OP CKOF,                   
03A0 0OP CKON,  
03E0 0OP LREX, 
0380 0OP RTWP,

\ ROP ..define word to compile instruction with single
\       Register operand and OPcode.
: ROP  ( opcode -- )  ( IS:<instruction name>)
   <BUILDS , 
   DOES>   ( reg pfa -- )
      @ + , ;     \ get opcode, add reg and compile instruction

02C0 ROP STST,  
02A0 ROP STWP,
   
\ IOP ..define word to compile instruction with Immediate
\       value operand and OPcode.
: IOP  ( opcode -- )  ( IS:<instruction name>)
   <BUILDS , 
   DOES>   ( n pfa -- )
      @ , , ;     \ get opcode..compile instruction and value

02E0 IOP LWPI,  
0300 IOP LIMI,
   
\ RIOP ..define word to compile instruction with Register
\        and Immediate value operands and OPcode.
: RIOP  ( opcode -- )  ( IS:<instruction name>)
   <BUILDS , 
   DOES>   ( reg n pfa -- )
      @ ROT + ,   \ get opcode..add reg..compile instruction
      ,  ;        \ compile immediate value

0220 RIOP AI,            
0240 RIOP ANDI,  
0280 RIOP CI,  
0200 RIOP LI,  
0260 RIOP ORI,   

\ RCOP ..define word to compile instruction with Register
\        operand and shift Count value and OPcode.
: RCOP  ( opcode -- )  ( IS:<instruction name>)
   <BUILDS , 
   DOES>   ( reg n pfa -- )
      @ SWAP 4 SLA + +     \ get opcode..add reg..add shift count
      ,  ;                 \ compile instruction
                      
0A00 RCOP SLA,  
0800 RCOP SRA,  
0B00 RCOP SRC,  
0900 RCOP SRL,  

\ DOP ..define word to compile instruction with signed-byte
\       jump Distance (in 16-bit words) and OPcode. The last
\       3 CRU instructions are included here because they
\       have the same format but with the CRU bit value
\       instead of jump distance.
: DOP  ( opcode -- )  ( IS:<instruction name>)
   <BUILDS , 
   DOES>   ( n pfa -- )
      @                 \ get opcode
      SWAP 00FF AND OR  \ force n to byte and OR to opcode LSB
      ,  ;              \ compile instruction
                    
1300 DOP JEQ,  
1500 DOP JGT,  
1B00 DOP JH,  
1400 DOP JHE,       
1A00 DOP JL,  
1200 DOP JLE,  
1100 DOP JLT,  
1000 DOP JMP,       
1700 DOP JNC,  
1600 DOP JNE,  
1900 DOP JNO,  
1800 DOP JOC,      
1C00 DOP JOP,  
1D00 DOP SBO,  
1E00 DOP SBZ,  
1F00 DOP TB,       

\ GCOP ..define word to compile instruction with General address
\        and number-of-Cru-bits operands and OPcode.
: GCOP  ( opcode -- )  ( IS:<instruction name>)
   <BUILDS , 
   DOES>  ( {addr} operand n pfa -- )
      @              \ get opcode
      SWAP 000F AND  \ force n to 0-15
      GROP' ;        \ process remainder of instruction

3000 GCOP LDCR,  
3400 GCOP STCR,

00 CONSTANT R0  
01 CONSTANT R1  
02 CONSTANT R2  
03 CONSTANT R3  
04 CONSTANT R4  
05 CONSTANT R5  
06 CONSTANT R6
07 CONSTANT R7  
08 CONSTANT R8  
09 CONSTANT R9  
0A CONSTANT R10  
0B CONSTANT R11
0C CONSTANT R12  
0D CONSTANT R13  
0E CONSTANT R14              
0F CONSTANT R15  
08 CONSTANT UP  
09 CONSTANT SP  
0A CONSTANT W  
0D CONSTANT IP  
0E CONSTANT RP  
0F CONSTANT NEXT                

\ Addressing modes
020 CONSTANT @()    ( addr -- addr 020 )  
: *?   010 + ( reg -- reg+010 ) ;  
: *?+  030 + ( reg -- reg+030) ;  
: @(?) 020 + ( addr reg -- addr reg+020 ) ; 
       
: @(R0)   R0   @(?) ;   : *R0   R0   *? ;  : *R0+   R0   *?+ ;               
: @(R1)   R1   @(?) ;   : *R1   R1   *? ;  : *R1+   R1   *?+ ;               
: @(R2)   R2   @(?) ;   : *R2   R2   *? ;  : *R2+   R2   *?+ ;               
: @(R3)   R3   @(?) ;   : *R3   R3   *? ;  : *R3+   R3   *?+ ;               
: @(R4)   R4   @(?) ;   : *R4   R4   *? ;  : *R4+   R4   *?+ ;               
: @(R5)   R5   @(?) ;   : *R5   R5   *? ;  : *R5+   R5   *?+ ;
: @(R6)   R6   @(?) ;   : *R6   R6   *? ;  : *R6+   R6   *?+ ;               
: @(R7)   R7   @(?) ;   : *R7   R7   *? ;  : *R7+   R7   *?+ ;               
: @(R8)   R8   @(?) ;   : *R8   R8   *? ;  : *R8+   R8   *?+ ;               
: @(R9)   R9   @(?) ;   : *R9   R9   *? ;  : *R9+   R9   *?+ ;               
: @(R10)  R10  @(?) ;   : *R10  R10  *? ;  : *R10+  R10  *?+ ;         
: @(R11)  R11  @(?) ;   : *R11  R11  *? ;  : *R11+  R11  *?+ ;         
: @(R12)  R12  @(?) ;   : *R12  R12  *? ;  : *R12+  R12  *?+ ;         
: @(R13)  R13  @(?) ;   : *R13  R13  *? ;  : *R13+  R13  *?+ ;         
: @(R14)  R14  @(?) ;   : *R14  R14  *? ;  : *R14+  R14  *?+ ;         
: @(R15)  R15  @(?) ;   : *R15  R15  *? ;  : *R15+  R15  *?+ ;         
: @(UP)   UP   @(?) ;   : *UP   UP   *? ;  : *UP+   UP   *?+ ;               
: @(SP)   SP   @(?) ;   : *SP   SP   *? ;  : *SP+   SP   *?+ ;               
: @(W)    W    @(?) ;   : *W    W    *? ;  : *W+    W    *?+ ;                    
: @(IP)   IP   @(?) ;   : *IP   IP   *? ;  : *IP+   IP   *?+ ;             
: @(RP)   RP   @(?) ;   : *RP   RP   *? ;  : *RP+   RP   *?+ ;               
: @(NEXT) NEXT @(?) ;   : *NEXT NEXT *? ;  : *NEXT+ NEXT *?+ ;  

\ Addressing modes in Wycove syntax 
020 CONSTANT @@   \ equivalent to @() 
: ** *?   ; 
: *+ *?+  ; 
: () @(?) ;    
                                                                
( DEFINE JUMP TOKENS )  \ constants are 2 bytes cheaper
01 CONSTANT GTE  
02 CONSTANT H    
03 CONSTANT NE   
04 CONSTANT L    
05 CONSTANT LTE  
06 CONSTANT EQ       
07 CONSTANT OC   
08 CONSTANT NC   
09 CONSTANT OO   
0A CONSTANT HE   
0B CONSTANT LE   
0C CONSTANT NP   
0D CONSTANT LT   
0E CONSTANT GT   
0F CONSTANT NO   
10 CONSTANT OP                       

: CJMP
   ?EXEC                                                 
   CASE 
      LT OF 1101 , 0 ENDOF
      GT OF 1501 , 0 ENDOF          
      NO OF 1901 , 0 ENDOF
      OP OF 1C01 , 0 ENDOF          
      DUP 0< OVER 10 > OR 
      IF 
         19 ERROR
      ENDIF
      DUP
   ENDCASE 
   SWPB 1000 + ,  ;  
   
: IF,     
   ?EXEC 
   [COMPILE] CJMP 
   HERE 2- 42  ;     IMMEDIATE           
: ENDIF,  
   ?EXEC                                                 
   42 ?PAIRS 
   HERE OVER - 
   2- 1 SRL 
   SWAP 1+ C!  ;     IMMEDIATE         
: ELSE,   
   ?EXEC 
   42 ?PAIRS 0 
   [COMPILE] CJMP 
   HERE 2- SWAP 42      
   [COMPILE] ENDIF,
   42  ;             IMMEDIATE                             
: BEGIN,  
   ?EXEC 
   HERE 41  ;        IMMEDIATE                             
: UNTIL,  
   ?EXEC 
   SWAP 41 ?PAIRS 
   [COMPILE] CJMP 
   HERE - 1 SRL 
   00FF AND 
   HERE 1- C!  ;     IMMEDIATE                                  
: AGAIN,   
   ?EXEC  
   0 
   [COMPILE] UNTIL, 
   ;                 IMMEDIATE                
: REPEAT,   
   ?EXEC 
   >R >R 
   [COMPILE] AGAIN,
   R> R> 2- 
   [COMPILE] ENDIF,
   ;                 IMMEDIATE                     
: WHILE,   
   ?EXEC 
   [COMPILE] IF, 
   2+  ;             IMMEDIATE                   
: THEN, [COMPILE] ENDIF, ; IMMEDIATE  ( ENDIF, synonym )        

\ : NEXT, *NEXT B, ;     <---now in kernel 

\ RT pseudo-instruction                    
: RT, *R11 B, ;  

FORTH DEFINITIONS  : A$$M ;

 

 

Comments and questions are encouraged!

 

...lee

 

[Note: More modifications 2 posts down.]

Edited by Lee Stewart
ASSEMBLER MOD NOTE
  • Like 2
  • Thanks 1
Link to comment
Share on other sites
TheBF River Patroller

+TheBF

Posted
Posted

Since your new code is well commented and you are looking for space savings, you might consider commenting this section out, since the E/A manual tells us not to use these instructions except for RTWP. 

: 0OP  ( opcode -- )  ( IS:<instruction name>)
   <BUILDS , 
   DOES>   ( pfa -- )
      @ , ;    \ get opcode and compile instruction

0340 0OP IDLE,  
0360 0OP RSET, 
03C0 0OP CKOF,                   
03A0 0OP CKON,  
03E0 0OP LREX, 
0380 0OP RTWP,

 

I commented it out in my version and replaced it with:

  

: RTWP,   0380 ,  ;

 

  • Like 1
  • Thanks 1
Link to comment
Share on other sites
Lee Stewart Quadrunner

+Lee Stewart

Posted
  • Author
Posted
4 hours ago, TheBF said:

Since your new code is well commented and you are looking for space savings, you might consider commenting this section out, since the E/A manual tells us not to use these instructions except for RTWP. 

: 0OP  ( opcode -- )  ( IS:<instruction name>)
   <BUILDS , 
   DOES>   ( pfa -- )
      @ , ;    \ get opcode and compile instruction

0340 0OP IDLE,  
0360 0OP RSET, 
03C0 0OP CKOF,                   
03A0 0OP CKON,  
03E0 0OP LREX, 
0380 0OP RTWP,

I commented it out in my version and replaced it with: 

: RTWP,   0380 ,  ;

 

 

Yeah—I did think of that, but got distracted by trying to decipher what those cryptic word names meant. I think I got all of those. Per your poke ( thanks! ), I have replaced 0OP and its defined words with the single RTWP, definition. This brings the fbForth Assembler down to 3040 bytes (down 168 bytes). Probably can’t get much lower.

 

It is curious that TI allowed those warned-against instructions to be assembled for the TI-99/4A, unless the E/A Assembler was intended to assemble code that could be run elsewhere—the TI-990 minicomputer, perhaps. I do not think there is much utility for these discouraged words in this Forth Assembler—which should only be assembling code snippets, anyway. Here is the updated fbForth Assembler:

 

Spoiler 
\ fbForth ASSEMBLER       ..from TI Forth 12JUL82 LCT
\   ..modified by Lee Stewart 12DEC2013 and 12NOV2022
HEX 
ASSEMBLER DEFINITIONS

\ Helper word to test whether the operand includes an address?
: ADDR?  ( {addr} operand -- flag ) 
   DUP 1F > SWAP  \ S:operand>1F operand
   30 < AND  ;    \ S:(operand>1F)&(operand<30)

\ GOP' ..helper word to compile General address operand
\        and OPcode.
: GOP'  ( {addr} operand opcode -- )
   \ compute instruction and compile it
   OVER + ,       \ S:{addr} opnd
   ADDR?          \ S:{addr} (opnd>1F)&(opnd<30)
   IF             \ S:addr
      ,        \ compile addr
   ENDIF  ;    

\ GROP' ..helper word to compile General address src and
\         Register dst operands and OPcode.
: GROP'  ( {addr1} operand1 opcode operand2 -- )
   6 SLA +     \ shift operand2 and add to opcode
   GOP'  ;     \ compute instruction..compile it and any address

\ GOP ..define word to compile instruction with single General
\       address operand and OPcode.
: GOP   ( opcode -- )  ( IS:<instruction name> )
   <BUILDS , 
   DOES>  ( {addr} operand pfa -- )
      @           \ S:{addr} operand opcode
      GOP' ;
                                  
0440 GOP B,     
0680 GOP BL,    
0400 GOP BLWP,                 
04C0 GOP CLR,   
0700 GOP SETO,  
0540 GOP INV,                  
0500 GOP NEG,   
0740 GOP ABS,   
06C0 GOP SWPB,                 
0580 GOP INC,   
05C0 GOP INCT,  
0600 GOP DEC,   
0640 GOP DECT,  
0480 GOP X,

\ GROP ..define word to compile instruction with General
\        address src and Register dst operands and OPcode.
: GROP  ( opcode -- )  ( IS:<instruction name>)
   <BUILDS , 
   DOES>  ( {addr1} operand1 operand2 pfa -- )
      @              \ S:{addr1} operand1 operand2 opcode
      SWAP           \ S:{addr1} operand1 opcode operand2
      GROP' ;
                     
2000 GROP COC,  
2400 GROP CZC,  
2800 GROP XOR,                  
3800 GROP MPY,  
3C00 GROP DIV,  
2C00 GROP XOP,

\ GGOP ..define word to compile instruction with General
\        address src and General address dst operands and OPcode.
: GGOP  ( opcode -- )  ( IS:<instruction name>)
   <BUILDS , 
   DOES>  ( {{addr1} operand1 {addr2} operand2 pfa -- ) \ S:{ad} rop pfa
      @ SWAP DUP ADDR?        \ S:{ad} rop opcd
      IF             \ operand2 is a symbolic or indexed address
         ROT >R      \ get addr2 to return stack   
         GROP' R> ,  \ process instruction, ending by compiling addr2
      ELSE           \ operand2 is register-based
         GROP'       \ process instruction (no addr2)
      ENDIF ;
    
A000 GGOP A, 
B000 GGOP AB,  
8000 GGOP C,   
9000 GGOP CB,       
6000 GGOP S,  
7000 GGOP SB,  
E000 GGOP SOC, 
F000 GGOP SOCB,     
4000 GGOP SZC,  
5000 GGOP SZCB,  
C000 GGOP MOV,  
D000 GGOP MOVB,

\ RTWP ( compiled by RTWP, ) is the only one of the six
\      TMS9900 control instructions implemented here.
: RTWP, 0380 ,  ;

\ ROP ..define word to compile instruction with single
\       Register operand and OPcode.
: ROP  ( opcode -- )  ( IS:<instruction name>)
   <BUILDS , 
   DOES>   ( reg pfa -- )
      @ + , ;     \ get opcode, add reg and compile instruction

02C0 ROP STST,  
02A0 ROP STWP,
   
\ IOP ..define word to compile instruction with Immediate
\       value operand and OPcode.
: IOP  ( opcode -- )  ( IS:<instruction name>)
   <BUILDS , 
   DOES>   ( n pfa -- )
      @ , , ;     \ get opcode..compile instruction and value

02E0 IOP LWPI,  
0300 IOP LIMI,
   
\ RIOP ..define word to compile instruction with Register
\        and Immediate value operands and OPcode.
: RIOP  ( opcode -- )  ( IS:<instruction name>)
   <BUILDS , 
   DOES>   ( reg n pfa -- )
      @ ROT + ,   \ get opcode..add reg..compile instruction
      ,  ;        \ compile immediate value

0220 RIOP AI,            
0240 RIOP ANDI,  
0280 RIOP CI,  
0200 RIOP LI,  
0260 RIOP ORI,   

\ RCOP ..define word to compile instruction with Register
\        operand and shift Count value and OPcode.
: RCOP  ( opcode -- )  ( IS:<instruction name>)
   <BUILDS , 
   DOES>   ( reg n pfa -- )
      @ SWAP 4 SLA + +     \ get opcode..add reg..add shift count
      ,  ;                 \ compile instruction
                      
0A00 RCOP SLA,  
0800 RCOP SRA,  
0B00 RCOP SRC,  
0900 RCOP SRL,  

\ DOP ..define word to compile instruction with signed-byte
\       jump Distance (in 16-bit words) and OPcode. The last
\       3 CRU instructions are included here because they
\       have the same format but with the CRU bit value
\       instead of jump distance.
: DOP  ( opcode -- )  ( IS:<instruction name>)
   <BUILDS , 
   DOES>   ( n pfa -- )
      @                 \ get opcode
      SWAP 00FF AND OR  \ force n to byte and OR to opcode LSB
      ,  ;              \ compile instruction
                    
1300 DOP JEQ,  
1500 DOP JGT,  
1B00 DOP JH,  
1400 DOP JHE,       
1A00 DOP JL,  
1200 DOP JLE,  
1100 DOP JLT,  
1000 DOP JMP,       
1700 DOP JNC,  
1600 DOP JNE,  
1900 DOP JNO,  
1800 DOP JOC,      
1C00 DOP JOP,  
1D00 DOP SBO,  
1E00 DOP SBZ,  
1F00 DOP TB,       

\ GCOP ..define word to compile instruction with General address
\        and number-of-Cru-bits operands and OPcode.
: GCOP  ( opcode -- )  ( IS:<instruction name>)
   <BUILDS , 
   DOES>  ( {addr} operand n pfa -- )
      @              \ get opcode
      SWAP 000F AND  \ force n to 0-15
      GROP' ;        \ process remainder of instruction

3000 GCOP LDCR,  
3400 GCOP STCR,

00 CONSTANT R0  
01 CONSTANT R1  
02 CONSTANT R2  
03 CONSTANT R3  
04 CONSTANT R4  
05 CONSTANT R5  
06 CONSTANT R6
07 CONSTANT R7  
08 CONSTANT R8  
09 CONSTANT R9  
0A CONSTANT R10  
0B CONSTANT R11
0C CONSTANT R12  
0D CONSTANT R13  
0E CONSTANT R14              
0F CONSTANT R15  
08 CONSTANT UP  
09 CONSTANT SP  
0A CONSTANT W  
0D CONSTANT IP  
0E CONSTANT RP  
0F CONSTANT NEXT                

\ Addressing modes
020 CONSTANT @()    ( addr -- addr 020 )  
: *?   010 + ( reg -- reg+010 ) ;  
: *?+  030 + ( reg -- reg+030) ;  
: @(?) 020 + ( addr reg -- addr reg+020 ) ; 
       
: @(R0)   R0   @(?) ;   : *R0   R0   *? ;  : *R0+   R0   *?+ ;               
: @(R1)   R1   @(?) ;   : *R1   R1   *? ;  : *R1+   R1   *?+ ;               
: @(R2)   R2   @(?) ;   : *R2   R2   *? ;  : *R2+   R2   *?+ ;               
: @(R3)   R3   @(?) ;   : *R3   R3   *? ;  : *R3+   R3   *?+ ;               
: @(R4)   R4   @(?) ;   : *R4   R4   *? ;  : *R4+   R4   *?+ ;               
: @(R5)   R5   @(?) ;   : *R5   R5   *? ;  : *R5+   R5   *?+ ;
: @(R6)   R6   @(?) ;   : *R6   R6   *? ;  : *R6+   R6   *?+ ;               
: @(R7)   R7   @(?) ;   : *R7   R7   *? ;  : *R7+   R7   *?+ ;               
: @(R8)   R8   @(?) ;   : *R8   R8   *? ;  : *R8+   R8   *?+ ;               
: @(R9)   R9   @(?) ;   : *R9   R9   *? ;  : *R9+   R9   *?+ ;               
: @(R10)  R10  @(?) ;   : *R10  R10  *? ;  : *R10+  R10  *?+ ;         
: @(R11)  R11  @(?) ;   : *R11  R11  *? ;  : *R11+  R11  *?+ ;         
: @(R12)  R12  @(?) ;   : *R12  R12  *? ;  : *R12+  R12  *?+ ;         
: @(R13)  R13  @(?) ;   : *R13  R13  *? ;  : *R13+  R13  *?+ ;         
: @(R14)  R14  @(?) ;   : *R14  R14  *? ;  : *R14+  R14  *?+ ;         
: @(R15)  R15  @(?) ;   : *R15  R15  *? ;  : *R15+  R15  *?+ ;         
: @(UP)   UP   @(?) ;   : *UP   UP   *? ;  : *UP+   UP   *?+ ;               
: @(SP)   SP   @(?) ;   : *SP   SP   *? ;  : *SP+   SP   *?+ ;               
: @(W)    W    @(?) ;   : *W    W    *? ;  : *W+    W    *?+ ;                    
: @(IP)   IP   @(?) ;   : *IP   IP   *? ;  : *IP+   IP   *?+ ;             
: @(RP)   RP   @(?) ;   : *RP   RP   *? ;  : *RP+   RP   *?+ ;               
: @(NEXT) NEXT @(?) ;   : *NEXT NEXT *? ;  : *NEXT+ NEXT *?+ ;  

\ Addressing modes in Wycove syntax 
020 CONSTANT @@   \ equivalent to @() 
: ** *?   ; 
: *+ *?+  ; 
: () @(?) ;    
                                                                
( DEFINE JUMP TOKENS )  \ constants are 2 bytes cheaper
01 CONSTANT GTE  
02 CONSTANT H    
03 CONSTANT NE   
04 CONSTANT L    
05 CONSTANT LTE  
06 CONSTANT EQ       
07 CONSTANT OC   
08 CONSTANT NC   
09 CONSTANT OO   
0A CONSTANT HE   
0B CONSTANT LE   
0C CONSTANT NP   
0D CONSTANT LT   
0E CONSTANT GT   
0F CONSTANT NO   
10 CONSTANT OP                       

: CJMP
   ?EXEC                                                 
   CASE 
      LT OF 1101 , 0 ENDOF
      GT OF 1501 , 0 ENDOF          
      NO OF 1901 , 0 ENDOF
      OP OF 1C01 , 0 ENDOF          
      DUP 0< OVER 10 > OR 
      IF 
         19 ERROR
      ENDIF
      DUP
   ENDCASE 
   SWPB 1000 + ,  ;  
   
: IF,     
   ?EXEC 
   [COMPILE] CJMP 
   HERE 2- 42  ;     IMMEDIATE           
: ENDIF,  
   ?EXEC                                                 
   42 ?PAIRS 
   HERE OVER - 
   2- 1 SRL 
   SWAP 1+ C!  ;     IMMEDIATE         
: ELSE,   
   ?EXEC 
   42 ?PAIRS 0 
   [COMPILE] CJMP 
   HERE 2- SWAP 42      
   [COMPILE] ENDIF,
   42  ;             IMMEDIATE                             
: BEGIN,  
   ?EXEC 
   HERE 41  ;        IMMEDIATE                             
: UNTIL,  
   ?EXEC 
   SWAP 41 ?PAIRS 
   [COMPILE] CJMP 
   HERE - 1 SRL 
   00FF AND 
   HERE 1- C!  ;     IMMEDIATE                                  
: AGAIN,   
   ?EXEC  
   0 
   [COMPILE] UNTIL, 
   ;                 IMMEDIATE                
: REPEAT,   
   ?EXEC 
   >R >R 
   [COMPILE] AGAIN,
   R> R> 2- 
   [COMPILE] ENDIF,
   ;                 IMMEDIATE                     
: WHILE,   
   ?EXEC 
   [COMPILE] IF, 
   2+  ;             IMMEDIATE                   
: THEN, [COMPILE] ENDIF, ; IMMEDIATE  ( ENDIF, synonym )        

\ : NEXT, *NEXT B, ;     <---now in kernel 

\ RT pseudo-instruction                    
: RT, *R11 B, ;  

FORTH DEFINITIONS  : A$$M ;

 

 

Any further improvement will likely have to await my jamming it into ROM. 😇

 

...lee

  • Like 2
Link to comment
Share on other sites
TheBF River Patroller

+TheBF

Posted
Posted

I wondered about those instructions myself. It could just have been a zealous young engineer trying to be thorough.

 

Not sure if this will actually net out smaller but you could try this code but add the traditional Fig-Forth ?PAIRS compiler testing for compatibility.

The word AJUMP could be replaced with 0 CJMP I think. 

However adding the compiler tests might eat up any space savings.

Repeat is 10 bytes smaller when done this way.

  

CR .( Simplified branching and looping)
: AJUMP,  ( token --) >< 1000 + , ;   \ >1000+token makes a jump instruction
: RESOLVE ( 'jmp offset --)  2- 2/ SWAP 1+ C! ; \ compile offset into 'jmp'
: <BACK   ( addr addr' -- ) TUCK -  RESOLVE ;

: IF,     ( addr token -- 'jmp') HERE SWAP AJUMP, ;
: ENDIF,  ( 'jmp addr --)  HERE OVER -  RESOLVE ;
: ELSE,   ( -- addr ) HERE 0 JMP, SWAP ENDIF, ;

: BEGIN,  ( -- addr)  HERE ;
: WHILE,  ( token -- *while *begin) IF, SWAP ;
: AGAIN,  ( *begin --) HERE  0 JMP, <BACK ;
: UNTIL,  ( *begin token --) HERE SWAP AJUMP, <BACK ;
: REPEAT, ( *while *begin -- ) AGAIN, ENDIF, ;

 

  • Like 2
Link to comment
Share on other sites
  • 1 month later...
Lee Stewart Quadrunner

+Lee Stewart

Posted
  • Author
Posted

I finally finished (I think!) debugging the font editor. There was more wrong with it than I thought!:

  • CTRL-D, Load File, was corrupting the input file and forcing it to 12 KiB from 4 – 8 KiB.
  • CTRL-X, Cut character pattern to clipboard, was acting like a normal character—bad test for function keys.
  • Other piddling corrections

I will post the next beta alpha (fbForth 2.1:$) later tonight. :waving:

 

...lee

  • Like 2
Link to comment
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Reply to this topic...

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

Loading...
×
 Share
Go to topic listing

  • Recently Browsing   0 members

    • No registered users viewing this page.
AtariAge
Forums
Store
General
Follow AtariAge

Copyright ©1998-2021 AtariAge

×
×
  • Create New...