Camel99 Forth Information goes here

+TheBF · February 22, 2019

About that ISR driven RS232

I have got something pretty stable working for ISR on RS232/1 thanks again to all the help one gets here on Atariage.

The spoiler shows the current code and test routine and the little movie shows it in action at 9600 bps.

It is worth noting that at 9600 bps, sending a 7K file with a 256 byte buffer, the file was captured and echoed back to the terminal no problem.

The same test done a 19.2Kbps dropped characters near the end of the file. So with a bigger buffer I can capture faster, but if I need the memory I need to slow down the sending a bit.

Or I could stop the echo and just put the bytes in storage buffer somewhere. However 9600 is fast enough for what I am doing.

Also note I am using expansion RAM (variables) for QHEAD and QTAIL not scratchpad RAM. Seems to be ok for my needs.

For the assembly language coders out there, you can compare how I took insanemultitasker's code but gave the various routines names in the Forth "dictionary".

This means I can run the ALC routines from the Forth command line and see how the work.

\ RS232/1 Interrupt Handler for CAMEL99 Forth   B Fox Feb 14 2019

NEEDS DUMP FROM DSK1.TOOLS  \ DEBUG ONLY
NEEDS MOV, FROM DSK1.ASM9900

\ ****************************************************************************
\ *      Adaptation of Jeff Brown / Thierry Nouspikel (sp) idea to leverage
\ *      the ROM-based ISR to service external interrupts (RS232 in our case)
\ *      within the VDP interrupt framework.
\ *

HEX
    83C0 CONSTANT ISRWKSP

\ Queue pointers, Initialized during setup
  VARIABLE QHEAD    
  VARIABLE QTAIL  

\ *circular Q management
    0100 CONSTANT QSIZE    \ 256 byte buffer
QSIZE 1- CONSTANT QMASK    \ circular mask value

\ allocate to 256 byte circular buffer in low RAM
QSIZE MALLOC CONSTANT Q    \ *Q must be assigned memory when system boots

\ ***********************************************************
\ * queue debugging tools
\ : CIRC++   ( addr -- ) DUP @ 1+ QMASK AND   SWAP ! ;
\ : ENQ      ( c -- )  Q QTAIL @ + C!  QTAIL CIRC++ ;
\ : ENQ$     ( adr len -- ) BOUNDS DO I C@ ENQ LOOP ;

\ : QKEY?  ( -- c | 0 )  \ read char from queue or return 0
\        FALSE                \ assume no char waiting
\        QHEAD @ QTAIL @ <>
\        IF
\           DROP              \ drop false flag
\           Q QHEAD @ + C@
\           QHEAD CIRC++
\        THEN ;               \ 32 bytes

\ : QPRINT     BEGIN
\                 QKEY1 DUP
\              WHILE ( tos<>0)
\                 EMIT
\              REPEAT
\              DROP ;


\ ************************************************************
\ * QKEY? - Read character from 'Q' at index 'QHEAD'
HEX
 CODE QKEY? ( -- c | 0 )         \ 0 means queue empty
       TOS PUSH,                 \ make space in the TOS cache register
       TOS CLR,                  \ FLAG to say no char ready
       QHEAD @@ QTAIL @@ CMP,
       NE IF,                    \ head<>tail means char waiting
           QHEAD @@ W MOV,       \ get queue head index to W
           Q (W) TOS MOVB,       \ get char from Q -> TOS
           TOS SWPB,             \ move to other side of register
           W INC,                \ inc the index
           W QMASK ANDI,         \ wrap the index
           W QHEAD @@ MOV,       \ save the new index
       ENDIF,
       NEXT,                     \ 34 bytes
       ENDCODE

\ ************************************************************
\ * Init RS232,buffers,CIB.
\ * usage:  100 MALLOC /TTY1 OPEN-TTY

HEX
CODE OPEN-TTY ( buffer cruaddr -- )
       0 LIMI,              \ inhibit ints until setup is complete
       R12  RPUSH,          \ save R12 which might be in use
       TOS R12 MOV,         \ 9902 CRU address -> R12
       1F SBO,              \ Reset 9902

\ * Need a delay after reset so...
\ * Assign buffer to  Q, init Q head and tail indices
      *SP+  ' Q >BODY @@ MOV,  \ POP buffer to Forth constant 'Q'
       QHEAD @@ CLR,        \ clear the head
       QTAIL @@ CLR,        \ clear the tail

\ * We can configure the 9902 now
       0D SBZ,              \ 9902 Bit 13, disable interval register
       PROTO @@ 08 LDCR,     \ set protocol (8n1 is normal)
       BPS   @@ 0C LDCR,     \ set baud (typically 9600)
       R12 RPOP,            \ restore R12
       TOS POP,             \ refill Forth top of stack cache
       NEXT,
       ENDCODE

\ **********************************************************
\ * Interrupt Handler
\ *    Entered from the ROM ISR via the user defined interrupt
\ *    We immediately test the configured RS232 for a received character.
\ *--------------------------------------------------------
\ * RS232 Circular Buffer character reception
\ *      Only test interrupts on active port as defined during setup
\ *      Spurious ints from another RS232 will result in virtual lockup
\ *      because they will never be serviced
\ *      OVERRUNS will overwrite old data in the QUEUE


\ **************************************************************
\ * ISR is in workspace 83C0. ONLY R3 & R4 are free to use!!!

DECIMAL
CREATE TTY1-ISR ( * this is a label, not a runnable Forth word * )
       ISRWKSP LWPI,                                           \   10
       R12 CLR,          \ select 9901 chip CRU address        \   10
       2 SBZ,            \ Disable VDP int prioritization      \   12
       R11 SETO,         \ 3.5.16 hinder screen timeout        \   10
       PORT @@ R12 MOV,  \ set CRU PORT                        \   22
       QTAIL @@ R4 MOV,  \ index->R4                           \   22
       16 TB,            \ interrupt received?                 \   12
       EQ IF,            \ Yes; enqueue char                   \    8
            Q R4 () 8 STCR,    \                                   52
            18 SBO,            \ clr rcv buffer, enable interrupts 12
            R4 INC,            \ bump the index                    10
            R4 QMASK ANDI,     \ wrap the index                    14
            R4 QTAIL @@ MOV,   \ save the index                    22
       ENDIF,
       R12 CLR,        \ select 9901 chip CRU address              10
       3 SBO,          \ reset timer int                           12
       RTWP,           \ Return                     \           = 238

\ **************************************************************
\ * Configure ROM ISR to pass through external interrupts as VDP interrupts
\ *   (Jeff Brown/Thierry)

\ * variable use to transport ISR from Forth to ISR workspace
VARIABLE HANDLER

HEX
CODE INSTALL ( ISR_address -- )
       TOS HANDLER @@ MOV,
       0 LIMI,
       83E0 LWPI,
       R14 CLR,         \ Disable cassette interrupt; protect 8379
       R15 877B LI,     \ disable VDPST reading; protect 837B

       ISRWKSP LWPI,    \ switch to ISR workspace
       R1 SETO,         \ [83C2] Disable all VDP interrupt processing
       HANDLER @@ R2 MOV,   \ [83C4] set our interrupt vector
       R11 SETO,        \ Disable screen timeouts

       R12 CLR,         \ Set to 9901 CRU base
       BEGIN,
          2 TB,         \ check for VDP int
       NE UNTIL,        \ loop until <> 0

       1  SBO,          \ Enable external interrupt prioritization
       2  SBZ,          \ Disable VDP interrupt prioritization
       3  SBZ,          \ Disable Timer interrupt prioritization
       8300 LWPI,       \ return to the FORTH WS
       TOS POP,         \ refill cache register
       2 LIMI,          \ 3.2  [rs232 ints now serviced!]
       NEXT,            \ and return to Forth
       ENDCODE

DECIMAL
CODE RCVON ( cru -- )  \ * Turn on the 9902 interrupts
       0 LIMI,
       TOS R12 MOV,
       18 SBO,          \  Enable rs232 RCV int
       TOS POP,
       2 LIMI,
       NEXT,
       ENDCODE

CODE RCVOFF ( cru -- )  \ * Turn off the 9902 interrupts
       0 LIMI,
       TOS R12 MOV,      \ i.e., >1340
       18 SBZ,           \ Disable rs232 rcv int
       TOS POP,
       2 LIMI,
       NEXT,
       ENDCODE

 : QCLEAR      QHEAD OFF  QTAIL OFF ;

Q /TTY1 OPEN-TTY

: ISR-TEST
      QCLEAR             \ reset Queue pointers
      CKEY? DROP         \ clear any chars from 9902
      TTY1-ISR INSTALL    \ obvious :-)
      /TTY1 RCVON        \ activate isr
       BEGIN
         QKEY? DUP EMIT  \ emit each char
         3 =             \ until ^C is sent
       UNTIL
      /TTY1 RCVOFF
      0 INSTALL ;

TTY1 ISR DEMO.mp4

Edited February 22, 2019 by TheBF

+TheBF · February 27, 2019

Here a bug, there a bug, everywhere a bug bug. Old theBF had some RAM, ee I ee I oh!

I thought I was so clever using scratchpad memory after the >8300 workspace to hold Forth's USER VARIABLEs. LOL

The old machine got me again. I can use the addresses up to 8344 for various system variables.

I tried placing I/O vectors in the space after that and the !$@#%^ file sys DSR uses some of those locations. :mad:

I have found that >8352 and >836E are un-touched (so far) so I use those for vectors.

      20 USER: TFLAG             \ TASK flag awake/asleep status
      22 USER: JOB               \ Forth word that runs in a task
      24 USER: DP                \ dictionary pointer
      26 USER: HP                \ hold pointer, for text->number conversion
      28 USER: CSP
      2A USER: BASE
      2C USER: >IN
      2E USER: C/L               \ Chars per line (32 or 40 depending on VDP mode)
      30 USER: OUT               \ counts chars since last CR (newline)
      32 USER: VROW              \ current VDP column (in fast RAM)
      34 USER: VCOL              \ current VDP row (in fast RAM)
\     36 USER: CURRENT
\     38 USER: CONTEXT
      3A USER: LP                \ LEAVE stack pointer.
      3C USER: SOURCE-ID         \ 0 for console,  -1 for EVALUATE, 1 for include
      3E USER: 'SOURCE           \ WATCH OUT! This is 2variable, occupies 3E and 40
\      40 USER: -------          \ used by 'SOURCE
      42 USER: TPAD
\ *********************************************************************
       44 USER: 'KEY?           \ vector to test for key press
\       46 USER: ???     might be ok
\      48 USER: ---             \ DSR use *PROTECTED IN ROOT TASK
\      4A USER: ---             \ DSR use *PROTECTED IN ROOT TASK
\      4C USER: ---             \ DSR use *PROTECTED IN ROOT TASK
\      4E USER: ---             \ DSR use *PROTECTED IN ROOT TASK
\      50 USER: ---             \ DSR use *PROTECTED IN ROOT TASK
       52 USER: 'EMIT           \ vector for char. output routine
\      54 USER: ---  1+ DSRSIZ  \ DSR use *PROTECTED IN ROOT TASK
\      56 USER: ---  DSRNAM     \ DSR use *PROTECTED IN ROOT TASK
\      58 USER: ---             \ DSR use *PROTECTED IN ROOT TASK
       6E USER: 'PAGE           \ vector for screen clear routine

+TheBF · February 27, 2019

STRAIGHT An old PolyForth word

After fighting with the ISR routine and getting it to work, I found I was not happy with how the rest of the system worked using the work around.

Polled I/O works great for keyboard entry so I wondered if there was a way to blast code at the machine when I needed to without fooling around with the GPL and ISR workspaces.

Someone here reminded me to disable interrupts for full attention of my polled code and sure enough that worked.

So I create STRAIGHT, a word from PolyForth and now I can blast source code into a big buffer in low RAM whenever I need to at full speed.

I had trouble getting the ALC code to wait for the first character so I just gave up and put that in Forth as well as the user notification stuff cuz that's way simpler in Forth.

Now I just need to write a little routine to write the buffer to a DV80 file and one to from memory and I have what I wanted.

PC -> Ti-99 saving and/or compilation without leaving the terminal emulator.

\ STRAIGHT a word from PolyForth
\ Accept chars into a buffer with no echo
\ capable of reading continuous data at 9600 bps

NEEDS MOV, FROM DSK1.ASM9900

CREATE ALLDONE     \ branch here to exit readcom
         R12 RPOP,
         2 LIMI,
         R1 TOS MOV,  \ get the char count to Forth TOS
         NEXT,
DECIMAL
CODE READCOM ( addr n -- n' )
         R12 RPUSH,
         PORT @@ R12 MOV,       \ select the 9902
        *SP+ W MOV,             \ addr ->W   (ie: R8)
         W TOS ADD,             \ calc last address ->TOS
         R0 SETO,               \ set timeout register >FFFF
         R1 CLR,                \ reset char counter
         0 LIMI,                \ we need the entire machine
         BEGIN,
            21 TB,
            EQ IF,
               *W+ 8 STCR,    \ put char in buf & inc
                18 SBO,       \ clr rcv buffer
                R0 SETO,      \ reset timeout
                R1 INC,       \ count char
            ELSE,
                 R0 DEC,      \ no char, dec TIMEDOUT
                 EQ IF,
                    ALLDONE @@ B,
                 ENDIF,
            ENDIF,
            W TOS CMP,        \ W =   end of buffer ?
        EQ UNTIL,
        ALLDONE @@ B,
        ENDCODE

: STRAIGHT   ( addr len -- n)
       SWAP 1+ TUCK 1-   ( addr+1 n addr)
       CR ." Send file now..."
       KEY SWAP C!     \ store first Char
       READCOM
       CR ." Complete"  CKEY? DROP 
       CR ;

HEX

+TheBF · February 28, 2019

Xon/Xoff in Forth

I thought it would be handy to include a way to control the TI-99 sending data to the terminal. I remember using control S and control Q on the DEC 10 Terminal in the old days.

It means that any utility you write that is gushing data to the terminal can be stopped and started with the same key strokes. Handy.

By changing the routine that is plugged into the output vector 'EMIT, we get Xon/Off in Camel Forth.

In the process I discovered that making a simple one byte buffer for a serial port receive routine has a benefit.

I only update the buffer if a new key was pressed. It means the (XEMIT) routine does not have to run any CRU code to read the flow control key.

Edit: The reason this can work is because I read the keyboard in the utilities for a "break" by the user, therefore KBUFF gets filled with key while DUMP, or DIR etc. are running.

\ this is cross-compiler Forth

VARIABLE: KBUFF           \ holds the last char rcv'd

[CC] DECIMAL
CROSS-ASSEMBLING
CODE: CKEY? ( -- n )         \  "com-key"
         0 LIMI,
         R12 RPUSH,
         PORT @@ R12 MOV,    \ select >1340 CRU address
         TOS PUSH,
         TOS CLR,
         21 TB,              \ test if char ready
         EQ IF,
             TOS 8 STCR,        \ read the char
             18 SBZ,            \ reset 9902 rcv buffer
             TOS 8 SRL,         \ shift to other byte
             TOS KBUFF @@ MOV,  \ record the key press
         ENDIF,
         R12 RPOP,
         2 LIMI,
         NEXT,
         END-CODE

Xon Xoff in Forth

I recant: reading the byte buffer did not really give much advantage. Code changed.

\ XONXOFF.FTH
HEX
11 CONSTANT ^Q
13 CONSTANT ^S

: (XEMIT)  ( c -- )   \ * XON/XOFF version*
         KEY? ^S =
         IF
           BEGIN
              PAUSE    \ let another task have a turn while we wait
              KEY? DUP 3 = ABORT" ^C"
              ^Q =
           UNTIL
         THEN
         CEMIT ;   \ send c to comm TTY1

: XON/XOFF   ( -- ) ['] (XEMIT)  'EMIT ! ;
: NOHANDSHK  ( -- ) ['] (EMIT)   'EMIT ! ;

Edited February 28, 2019 by TheBF

+TheBF · March 4, 2019

Making a Sound Lexicon for the TMS9919

Many years ago I remember wondering how I might tackle the challenge of programming the TMS9919 with a set of Forth words.

I spent some time today working on how it might be done and I modified my preliminary work.

This version lets you do the minus number duration trick that we have in TI- BASIC by running a very small ISR that just keeps trying to turn off the sound channels if the volume number is not zero.

The other thing I always wanted was a way to play BASS notes by frequency in Herz, so this word set has the word ( dur freq vol ) BASS which makes it easy.

Using the same math we can also play white noise notes that track frequency. No kidding!

Here's the code. I will have to make some demo recordings. At the moment I have been using Vorticon's Stratego game sounds for inspiration.

EDIT: Created the word PLAY to save memory and improve code clarity

\ TMS9919 SOUND CHIP DRIVER and CONTROL LEXICON     Jan 2017 BJF
\ Modified to use ISR timers to control durations   Mar 2 2019 BJF
 
 NEEDS DUMP FROM DSK1.TOOLS   \ debugging
 NEEDS MOV, FROM DSK1.ASM9900

\ frequency code must be ORed with these numbers to create a sound
HEX
  8000 CONSTANT OSC1      A000 CONSTANT OSC2   ( oscillators take 2 nibbles)
  C000 CONSTANT OSC3        E0 CONSTANT OSC4   ( noise takes 1 nibble)
 
\ Attenuation values are ORed with these values to change volume
( 0= max, 15 = off)
    90 CONSTANT ATT1         B0 CONSTANT ATT2
    D0 CONSTANT ATT3         F0 CONSTANT ATT4  ( OSC4 volume adjust)

\ timer array:  1 for each voice
CREATE TIMERS ( -- addr)  0 , 0 , 0 , 0 ,

\ names for each timer in the array
TIMERS   CONSTANT T1
T1 CELL+ CONSTANT T2
T2 CELL+ CONSTANT T3
T3 CELL+ CONSTANT T4

\ =====================================================
\ There are no 32 bit numbers in the CAMEL99 compiler
\ so we create a double variable with primtives
: >DOUBLE  ( addr len -- d ) 0 0 2SWAP >NUMBER 2DROP ;

DECIMAL
S" 111861" >DOUBLE CREATE f(clk) ( -- d)  ,  ,  \ 32 bit int.
 
\ >FCODE re-arranges freq. value nibbles (4bits) for the TMS9919
HEX
 CODE >FCODE ( 0abc -- 0cab) \ version by Farmer Potato Atariage
            0B44 ,  \ TOS 4  SRC,  \ C0AB
            C204 ,  \ TOS W  MOV,  \ DUP
            0948 ,  \   W 4  SRL,   \ 0C0A
            D108 ,  \  W TOS MOVB, \ 0CAB
            NEXT,
            ENDCODE   

\ we set the "ACTIVE CHANNEL" with these variables
 VARIABLE OSC       \ holds the active OSC value
 VARIABLE ATT       \ holds the active ATTENUATOR value
 VARIABLE T         \ hold active timer address

\ convert freq. to 9919 chip code
: HZ>CODE  ( freq -- fcode ) f(clk) 2@ ROT UM/MOD NIP >FCODE ;

HEX
\ **for testing**  echo sound data to screen AND make sound
\ : SND!  ( c -- )  ." >"  BASE @ >R  HEX DUP U. 8400 C! R> BASE ! ;

\ TMS9919 is a memory mapped device on the TI-99 @ >8400
\ : SND!    ( c -- ) 8400 C! ;

CODE SND! ( c -- )
           TOS SWPB,
           TOS 8400 @@ MOVB,
           TOS POP,
           NEXT, 
           ENDCODE

\ Set the sound "GENerator that is active by assigning
\ timer, attenuator and oscillator
\ : GEN! ( osc att tmr -- )  T !  ATT !  OSC !  ;

CODE GEN! ( osc att tmr -- )
          TOS    T @@ MOV,
         *SP+  ATT @@ MOV,
         *SP+  OSC @@ MOV,
          TOS POP,
          NEXT,
          ENDCODE

CREATE MUTE-ISR     \ creates a label for this sub-routine
     R1 TIMERS LI,  \ R1=timer array address
     R2 8400   LI,  \ R2=sound port address
     R3 9F00   LI,  \ R3=attenuator "off"  value
     R5 TIMERS 4 CELLS + LI,  \ compute last timer() address
     R0 CLR,                  \ need a zero value
     BEGIN,
       R1 ** R0 CMP,          \ timer <>0
       NE IF,
          R1 ** DEC,          \ decrement timer
          EQ IF,
             R3 R2 ** MOVB,   \ mute attenuator
          ENDIF,
       ENDIF,
       R1 INCT,         \ next timer
       R3 2000 AI,      \ next attenuator
       R1 R5 CMP,       \ is this the last timer?
     EQ UNTIL,          \ loop until true
     RT,
     ENDCODE

HEX
: INSTALL  ( sub-routine -- ) 83C4 ! ;

\ enable/disable background sound mute ISR
: BG-ON   ( -- ) MUTE-ISR INSTALL ;
: BG-OFF  ( -- ) 0 INSTALL ;
: COLD    ( -- ) BG-OFF COLD ;  \ disable ISR before re-booting Forth

\ ================================================================
\ S O U N D   C O N T R O L   L E X I C O N

\ sound "voice" selectors
: VOX1    ( -- )  OSC1  ATT1 T1 GEN! ;
: VOX2    ( -- )  OSC2  ATT2 T2 GEN! ;
: VOX3    ( -- )  OSC3  ATT3 T3 GEN! ;
: VOX4    ( -- )  OSC4  ATT4 T4 GEN! ;

\ low level API
: HZ      ( f -- )  HZ>CODE  OSC @ OR  SPLIT SND!  SND! ;
: DB      ( level -- ) 2/  0F MIN ATT @ OR  SND! ; \ Usage: 6 DB
: TICKS   ( t -- )  T @  ! ;        \ store 't' in active timer
: 16/     ( n -- n') 4 RSHIFT ;     \ converts mS -> ticks

: MUTE    ( -- ) 30 DB  ;
: SILENT  ( -- ) 9F SND!  BF SND!  DF SND!  FF SND! ;

: DURATION ( ms -- )
          DUP 0<                    \ negative value?
          IF   ABS 16/ TICKS        \ Yes. use background mute timer
          ELSE MS MUTE              \ No. Wait, then mute
          THEN ;

\ =============================================================
\ hi-level API for each voice

: PLAY ( dur vol  -- ) DB DURATION ; \ common factor, saves memory

( We set freq. before opening attenuator for cleanest sound)
: SND1  ( dur freq vol  -- ) VOX1 SWAP HZ PLAY ;
: SND2  ( dur freq vol  -- ) VOX2 SWAP HZ PLAY ;
: SND3  ( dur freq vol  -- ) VOX3 SWAP HZ PLAY ;

\ 1 1 1 0 0 w r r
\  >E      | | |
\          | 0 0 : 0  6991 Hz
\          | 0 1 : 1  3496 Hz
\          | 1 0 : 2  1748 Hz
\          | 1 1 : track freq of gen.3
\          1 0 0 : 4 low freq white noise
\          1 0 1 : 5 med freq white noise
\          1 1 0 : 6 hi  freq white noise
\          0 : Periodic noise
\          1 : White noise    7 = tracking white noise

: NOISETYPE ( n -- ) OSC4 OR SND! ;   \ faster create for noise byte

: NOISE ( dur freq vol  -- ) VOX4 SWAP 07 AND NOISETYPE PLAY ;

DECIMAL
: >BASS ( n -- n') 14777 1000 */ ;  \ n'= n x 14.777

: BASS ( dur freq vol -- ) \ steal VOX3 & VOX4 to play low freq
         VOX3 SWAP >BASS HZ MUTE
         VOX4 3 NOISETYPE  PLAY ;

: WHITE ( dur freq vol -- ) \ steal VOX3 & VOX4. Pitched white noise
         VOX3 SWAP >BASS HZ MUTE
         VOX4 7 NOISETYPE  PLAY ;

Edited March 5, 2019 by TheBF

+TheBF · March 19, 2019

Semantic Power of the 9900 Instruction Set (Fantastic!)

While doing some analysis of how improve compiling times I zoomed in on a word in Camel Forth called DIGIT?. This word takes an ascii character and converts it to a numeric value. It returns two arguments.

If the conversion is good the number and a true flag is left on the data stack. If the conversion is bad, the input character and a false flag are left on the data stack.

Camel Forth defines this function in Forth using some clever binary logic.

However this word is called in a loop to convert multi-digit numbers so it was a good target to improve the speed of number interpretation and compilation.

Camel Forth's DIGIT? (original comments by Dr. Brad Rodriguez)

: DIGIT?     ( char -- n -1)             \ if char is a valid digit
\            (      -- x  0 )            \ if char is not valid
              DUP 39 > 100 AND +         \ silly looking
              DUP 140 > 107 AND -
              [CHAR] 0 -                 \ but it works!
              DUP BASE @ U< ;

I used the GForth decompiler to see how it was done in GForth, one of the reference implementations of ANS/ISO Forth and I saw this:

: DIGIT?
      30 - 
      DUP 9 U>
      IF 7 - DUP 9 U<=
        IF
          DROP FALSE EXIT
        THEN
      THEN
      DUP BASE @ U>=
      IF
        DROP FALSE EXIT
      THEN
      TRUE ;

Looking at this example I wrote the equivalent in Forth assembler and it's almost a direct translation. It actually worked the first time I coded it. ;-)

The 9900 instruction set is almost the same level as Forth, when structured branching and looping are added to the assembler.

*Notes:

The combination of a jump token and IF, ( GT IF,) in this assembler simply create a JMP instruction around the following code to the nearest ENDIF, location.
TOS is an alias for R4, used a cache register for the top value on the Forth data stack
PUSH is a 2 instruction macro that decrements R6 and then moves R4 to the data stack ( DECT R6 MOV R4,*R6 )

The code below puts the equivalent Forth code in the comments

CODE DIGIT? ( char -- n f )           \ : digit?
               TOS PUSH,              \ 2 extra instructions
               TOS -30 AI,            \ 30 -
               TOS 9 CI, GT           \ DUP 9 U>
               IF,                    \ IF
                  TOS -7 AI, LTE      \    7 - DUP 9 U<=
                  IF,                 \    IF
                      TOS CLR,        \       DROP FALSE
                      NEXT,           \       EXIT
                  ENDIF,              \    THEN
               ENDIF,                 \ THEN
               TOS BASE @@ CMP, GTE   \ DUP BASE @ U>=
               IF,                    \ IF
                  TOS CLR,            \     DROP FALSE
                  NEXT,               \     EXIT
               ENDIF,                 \ THEN
               TOS *SP MOV,           \ extra instruction
               TOS SETO,              \ TRUE
               NEXT,                  \ ;
               ENDCODE

Amazing design by TI Engineers all those years ago.

+Lee Stewart · March 19, 2019

FYI, here is the ALC from TI Forth’s DIGIT (from fig-Forth) and the equivalent (I think!) fbForth Assembler code, which only leaves FALSE if the ASCII character cannot be converted to a digit:

*** TI Forth ALC primitive for DIGIT (inherited by fbForth)
*** DIGIT ***

DIGIT  DATA $+2
       MOV  *SP+,R1     pop base to R1
       MOV  *SP,R2      copy ASCII of char to R2
       AI   R2,->0030   convert to binary form
       CI   R2,10       0-9?
       JL   DIGIT1      yes..check base
       AI   R2,-7       no..remove ASCII gap
       CI   R2,10       >= 10?
       JHE  DIGIT1      yes..check base
DIGIT2 CLR  *SP         no..leave FALSE on stack
       B    *NEXT       return to interpreter
DIGIT1 C    R2,R1       >= base?
       JHE  DIGIT2      yes..leave FALSE and return
       MOV  R2,*SP      no..leave converted digit on stack
       DECT  SP         reserve stack space
       SETO *SP         leave -1
       NEG  *SP         change to 1 for TRUE
       B    *NEXT       return to interpreter

\ fbForth Assembler code for above ALC
HEX
ASM: DIGIT ( char base -- FALSE | [n TRUE] )
   *SP+ R1 MOV,      \ pop base to R1
   *SP R2 MOV,       \ copy ASCII of char to R2
   R2 -030 AI,       \ convert to binary form
   R2 0A CI,         \ compare digit to 10
   HE IF,            \ >= 10?
      R2 -7 AI,      \ yes..remove ASCII gap
      R2 0A CI,      \ compare digit to 10
      L IF,          \ < 10?
         *SP CLR,    \ yes..leave FALSE on stack
         NEXT,       \ return to interpreter
      THEN,
   THEN,
   R2 R1 C,          \ compare digit to base
   HE IF,            \ >= base?
      *SP CLR,       \ yes..leave FALSE on stack
   ELSE,             \ no..
      R2 *SP MOV,    \ leave converted digit on stack
      SP DECT,       \ reserve stack space
      *SP SETO,      \ leave -1
      *SP NEG,       \ change to 1 for TRUE
   THEN,
;ASM                 \ return to interpreter

...lee

+TheBF · March 19, 2019

FYI, here is the ALC from TI Forth’s DIGIT (from fig-Forth) and the equivalent (I think!) fbForth Assembler code, which only leaves FALSE if the ASCII character cannot be converted to a digit:

*** TI Forth ALC primitive for DIGIT (inherited by fbForth)
*** DIGIT ***

DIGIT  DATA $+2
       MOV  *SP+,R1     pop base to R1
       MOV  *SP,R2      copy ASCII of char to R2
       AI   R2,->0030   convert to binary form
       CI   R2,10       0-9?
       JL   DIGIT1      yes..check base
       AI   R2,-7       no..remove ASCII gap
       CI   R2,10       >= 10?
       JHE  DIGIT1      yes..check base
DIGIT2 CLR  *SP         no..leave FALSE on stack
       B    *NEXT       return to interpreter
DIGIT1 C    R2,R1       >= base?
       JHE  DIGIT2      yes..leave FALSE and return
       MOV  R2,*SP      no..leave converted digit on stack
       DECT  SP         reserve stack space
       SETO *SP         leave -1
       NEG  *SP         change to 1 for TRUE
       B    *NEXT       return to interpreter

\ fbForth Assembler code for above ALC
HEX
ASM: DIGIT ( char base -- FALSE | [n TRUE] )
   *SP+ R1 MOV,      \ pop base to R1
   *SP R2 MOV,       \ copy ASCII of char to R2
   R2 -030 AI,       \ convert to binary form
   R2 0A CI,         \ compare digit to 10
   HE IF,            \ >= 10?
      R2 -7 AI,      \ yes..remove ASCII gap
      R2 0A CI,      \ compare digit to 10
      L IF,          \ < 10?
         *SP CLR,    \ yes..leave FALSE on stack
         NEXT,       \ return to interpreter
      THEN,
   THEN,
   R2 R1 C,          \ compare digit to base
   HE IF,            \ >= base?
      *SP CLR,       \ yes..leave FALSE on stack
   ELSE,             \ no..
      R2 *SP MOV,    \ leave converted digit on stack
      SP DECT,       \ reserve stack space
      *SP SETO,      \ leave -1
      *SP NEG,       \ change to 1 for TRUE
   THEN,
;ASM                 \ return to interpreter

...lee

Ah... so the TI guys built this into TI-Forth in the '80s. Makes sense.

The hi-level Forth version Brad did was 48 bytes, the code version based in GForth is 24 bytes and it is approximately 7X faster.

All this points to the fact that modern commercial Forth systems have abandoned threaded code for native code. However it is a much harder compiler to build.

+Lee Stewart · March 19, 2019

...

Camel Forth's DIGIT? (original comments by Dr. Brad Rodriguez)

: DIGIT?     ( char -- n -1)             \ if char is a valid digit
\            (      -- x  0 )            \ if char is not valid
              DUP 39 > 100 AND +         \ silly looking
              DUP 140 > 107 AND -
              [CHAR] 0 -                 \ but it works!
              DUP BASE @ U< ;

Clever code, indeed—but it confused me at first because of a missing HEX ahead of the definition. I especially like how the ASCII gap is handled. It insures that any character in the gap is treated as a number higher than any likely radix (314 – 320), which should fail the comparison at the end of the definition.

[Edit: I should add that the two AND operations will not work in TI Forth or fbForth because operations that yield TRUE or FALSE, unfortunately, render TRUE as 1 rather than -1 (FFFFh) as in the above case.]

...lee

+TheBF · March 23, 2019

CAMEL99 Forth Version G Release

I forgot how many things I had been working on since last November. It's good to look back and see how far we've come sometimes.

I just posted version G. It fixes a bug in the interpreter error detection and adds a bunch of new library files.

https://github.com/bfox9900/CAMEL99-V2(forgot the link)

### Nov 30, 2018 V2.1.G

Version G corrects a long-time bug in the interpreter that reported
"empty stack" under some conditions erroneously (CAMELG2.HSF)
Compiler switch name has been changed to USEFORTH (previously SMALLER) because
sometimes Forth is smaller and sometimes Assembler code is smaller.
Version G has a code word for DIGIT? to improved compile times
The word ?SIGN is now PRIVATE, not visible in the dictionary to save space
The word >NUMBER has been changed slighly from the original CAMEL FORTH that speeds it for the 9900 cpu.
The ELAPSE.FTH program has been significantly improved for accuracy and the code size has been reduced.
A file based BLOCK system is available as a library: /LIB.ITC/BLOCKS.FTH
These blocks are compatible with FBFORTH and Turbo Forth allowing the developer read programs from these other Forth systems.
Compiling this code will not be possible without writing a "translation harness" however for simple programs this is not too difficult.
A simple demo of BLOCK usage is file LINEDIT80.FTH for use with 80col displays or the TTY based kernel CAMEL99T
Data structures per Forth 2012 are now supported in file STRUC12.FTH.
A simple example is part of the file. (remove or comment out if you use the file)
ACCEPT has been changed passing backspace cursor control to EMIT. (see below)
EMIT has been changed to handle newline and backspace characters
(EMIT) and (CR) i/o primitives can be compiled as Forth or CODE (controlled by USEFORTH )

### CAMEL99T (tty)

Version CAMEL99T is built to use RS232/1 as the primary console.
It has been tested with Tera Term, Hyper-terminal and PUTTY under windows 10.
Terminal configuration is 9600,8,n,1, hardware handshake.
A word VTYPE ( $addr len VDPaddr -- ) is part of the CAMEL99T to allow simple printing to the VDP screen at a screen address. (no protection!)
Library file call XONXOFF.FTH vectors EMIT to provide XON/XOFF protocol.
File VT100.FTH can be included to provide cursor control for a VT100 terminal.

Edited March 23, 2019 by TheBF

+TheBF · April 3, 2019

The DSRLINK...

I am forever grateful for insanemulti-tasker and the TI tech pages for giving me the foundation for DSRLINK. I could not resist trying to understand it better.

In going through what I was using, I found a number of lines that did not make sense and a couple of variables that I thought could be eliminated by using immediate operations rather than indirect addressing.

I improved some of my comments and when I was done the kernel was 44 bytes smaller using this version for DSRLINK.

One of the savings was removing the static string buffer NAMEBUF. Instead I used the un-allocated memory in the CAMEL99 HEAP (low RAM).
The system variable 'H' always contains the address of free memory in the heap. It's probably got some corner cases where I could clobber it, like if I allowed a preemptive task to change the value of 'H' with MALLOC, but I don't use preemptive multi-tasking so I am not too worried. I think I can manage it the next time I have to use CAMEL99 Forth for a space mission with NASA. :grin:

The spoiler has the new version.
Edit: Updated to latest code Apr 21 2018, Put 2 lines back that I thought were not needed, but I was wrong.

\ DSRLNKA.HSF for XFC99 cross-compiler/Assembler  12Apr2019

\ PASSES error code back to Forth workspace, TOS register

\ Source:
\ http://atariage.com/forums/topic/283914-specialized-file-access-from-xb/page-2
\ posted by InsaneMultitasker via Thierry Nouspikel

\ - Re-write to used CAMEL Forth Heap via the variable 'H' for NAMBUF
\ - Changed some jumps to structured loops & IF/THEN
\ - ADD GPl error byte to error code on Forth TOS
\ - saved 44 bytes!!                                        B. Fox

CROSS-ASSEMBLING  XASSEMBLER DEFINITIONS

\ we need more labels than I normally use for Forth style CODE Words
 A DUP refer: @@A    binder: @@A:
 B DUP refer: @@B    binder: @@B:

CROSS-COMPILING XASSEMBLER DEFINITIONS
\ MACRO to simplify the VDP code
: VDPWA, ( reg -- )
       DUP           SWPB,   \ setup VDP address
       DUP VDPWA @@  MOVB,   \ write 1st byte of address to VDP chip
       DUP           SWPB,
           VDPWA @@  MOVB,   \ write 2nd byte of address to VDP chip
                     NOP,  ; \ need this tiny delay for VDP chip

: [TOS]      8 (R13)  ;  \ gives access to Forth top of stack register

[CC] HEX

TARGET-COMPILING
l: HEX20   20 BYTE,
l: HEXAA   AA BYTE,
l: PERIOD  2E BYTE,    \ '.'
          .EVEN

l: H2000   DATA 2000
l: CYC1    DATA 0000
l: H1300   DATA 1300

[CC] RP0 80 -    [TC] EQU DREGS     \ use memory below Forth RETURN stack for workspace
[CC] 5 2* DREGS + [TC] EQU DREG(5)  \ compute address of DREGS register 5

CLR-JMPTABLE
\ === DSR ENTRY POINT ===
l: DSR1                      \ headless code
      *R14+     R5  MOV,    \ get '8'->R5, auto inc for return
       HEX20 @@ R15 SZCB,   \ >20 eq flag=0
       8356 @@  R0  MOV,    \ [PAB FNAME] to R0
       R0       R9  MOV,    \ dup R0 to R9
       R9       -8  ADDI,   \ R9-8 = [PAB FLG]
       R0          VDPWA,   \ set the VDP address to use
       VDPRD @@ R1  MOVB,   \ R1= length of FNAME

\ setup to copy VDP FNAME ->namebuf to '.' character
       R1       R3  MOVB,   \ DUP length byte to R3
       R3       08  SRL,    \ swap the byte to other side
       R4           SETO,   \ R4 = -1
       H @@      R2 MOV,     \ unused heap becomes temp. namebuf
       BEGIN,
         R0            INC,    \ point to next fname VDP address
         R4            INC,    \ counter starts at 0
         R4       R3   CMP,    \ is counter = fnamelength
         @@1           JEQ,    \ if true goto @@1:
         R0          VDPWA,    \ set VDP address
         VDPRD @@ R1  MOVB,    \ read next VDP char from fname
         R1      *R2+ MOVB,    \ copy to namebuf & inc pointer
         R1 PERIOD @@ CMPB,    \ is it a '.'
       EQ UNTIL,               \ until '.' found  34 bytes!!!

@@1:   R4        R4  MOV,    \ test R4(device name length)=0
       @@6           JEQ,    \ if so, goto ERROR6
       R4        07  CMPI,   \ is dev name length>7
       @@8           JGT,    \ if so, goto @@8 (ERROR6)
       83D0 @@       CLR,    \ erase magic CRU addr. holder
       R4   8354 @@  MOV,    \ put length in magic address
       R4            INC,    \ +1 points to '.' character
       R4   8356 @@  ADD,    \ add offset to PAB address (makes "real PAB")

\ ==== GPL WORKSPACE ====
       83E0         LWPI,    \ SROM (search ROM device list)
       R1           CLR,     \ MAGIC GPL REGISTER=0
       H2000 @@ CYC1 @@ MOV, \ init the CYC1 variable ??
       R12     0F00 LI,      \ init CRU base to 0F00
       @@A          JMP,

@@9:    \ scan for I/O cards
       R12   1000   LI,      \ init CRU address
       H1300 @@ CYC1 @@ MOV, \
      BEGIN,
@@A:     R12   R12   MOV,
         NE IF,              \ if card address<>0
              00 SBZ,        \ turn off card
         ENDIF,
         R12    0100  ADDI,  \ advance CRU to next card
         83D0 @@      CLR,   \ erase magic addres
         R12    2000  CMPI,  \
         @@9          JEQ,   \ Scan ROM
         R12  CYC1 @@ CMP,
         @@5          JEQ,   \ no more cards. goto ERROR5
\ card activation...
         R12  83D0 @@ MOV,   \ save card CRU in magic address
         00           SBO,   \ turn on the card
         R2   4000    LI,    \ ROM start addr -> R2
        *R2  HEXAA @@ CMPB,  \ test for card present
       EQ UNTIL,             \ loop until card is found

       DREG(5) @@ R2 ADD,    \ add '8'+4000= >4008 DSR ROM list
       @@B          JMP,

@@3: \ scan ROM linked list for code address
      BEGIN,
         BEGIN,
           83D2 @@   R2 MOV,   \ start of ROM device list -> R2
           00           SBO,   \ turn card on

@@B:      *R2       R2  MOV,   \ Fetch next link
           @@A          JEQ,   \ if link=0 goto @@A (NEXT CARD)
           R2  83D2 @@  MOV,   \ save link address in magic address
           R2           INCT,  \ R2 = code pointer
          *R2+      R9  MOV,   \ fetch code address ->R9
           8355 @@  R5  MOVB,  \ dev length->R5
           @@4          JEQ,   \ if 0 we have a string match
           R5      *R2+ CMPB,
        EQ UNTIL,

\ find dev string match
         R5       08  SRL,     \ shift length byte
         H @@     R6  MOV,     \ heap ->R6 is NAMEBUF
         BEGIN,
           *R6+   *R2+ CMPB,   \ compare namebuf to ROM string
            @@3        JNE,    \ if mismatch goto @@3
            R5         DEC,    \ dec the counter register
         EQ UNTIL,
@@4: \ run DSR code
         R1        INC,    \ count entries into the DSR ?
        *R9         BL,     \ call the DSR code
      AGAIN,                   \ try next card

\   -- DSR returns here if we are done --
       00            SBZ,  \ Turn off the card
       DREGS         LWPI, \ ==== DSR Workspace ====
       R9           VDPWA, \ set vdp address
       VDPRD @@  R1  MOVB, \ read error value to DREGS R1
       R1 0D         SRL,  \ shift error to correct range
       @@7           JNE,  \ if error<>0 goto @@7
                     RTWP, \ else return to Forth workspace

\ error condition handlers
@@5:   DREGS         LWPI, \ we came from GPL workspace, restore DREGS

\ device name length errors
@@6:
@@8:  R1            SETO, \  error code in R1. *THIS SEEMS TO MATTER*

\ device not found error
@@7:  R1      [TOS] MOV,  \ Move error code to Forth TOS

\ GPL error test
      GPLSTAT @@ R0 MOVB, \ get gpl status byte
                 R0 SWPB,
      R0       0020 ANDI, \ mask to get GPL error bit
      R0      [TOS] OR,   \ combine GPL & DSR error codes
                    RTWP, \ return to Forth

\    ====== DSR LINK ENDS======
\ /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/

\ create the vector for BLWP
l: DLNK      DREGS DATA,   \ the workspace
             DSR1  DATA,   \ entry address of the code


CODE: DSRLNK  ( [pab_fname] -- ior)
      TOS  8356 @@ MOV,
               TOS CLR,
                 0 LIMI,   \ disable interrupts here
    TOS GPLSTAT @@ MOVB,   \ clear GPL status register
           DLNK @@ BLWP,
                 8 DATA,
                 2 LIMI,
                   NEXT,
END-CODE

Edited April 21, 2019 by TheBF

+TheBF · April 4, 2019

The old saying goes "Any program that can be written in 1000 bytes can be written in 999 bytes".

Integrating DSRLINK into Forth means I have other ways to pass parameters than just using registers.

I realized that DSRLINK could take a parameter from the stack. The parameter it needed was the PAB file-name address moved to >8356.

Previously I had been moving the PAB file-name to >8356 in the FILEOP command with FORTH like this:

: FILEOP  ( opcode -- err)                   \ TI99 O/S call
          [PAB VC!                           \ write opcode byte to VDP PAB
          [PAB FLG] DUP VC@ 1F AND SWAP VC!  \ clear err code bits
          0 GPLSTAT C!                       \ clear GPL status register
          [PAB FNAME] DSRNAM !               \ ** THIS LINE ***
          DSRLNK ( -- err)                   \ DSRLINK with parameter 8
          GPLSTAT C@ 20 AND  OR              \ get GPL status, or with err
;

By changing 1 line in DSRLNK to take a parameter from the stack and stuff it into >8356, I save 4 bytes and speed up my FILEOP command a little.

: FILEOP  ( opcode -- err)                   \ TI99 O/S call
          [PAB VC!                           \ write opcode byte to VDP PAB
          [PAB FLG] DUP VC@ 1F AND SWAP VC!  \ clear err code bits
\          0 GPLSTAT C!                      \ *** MOVE INTO DSR routine
          [PAB FNAME] DSRLNK ( -- err)       \ *** PASS filename to DSRLNK **
\          GPLSTAT C@ 20 AND  OR             \ *** MOVE INTO DSR routine
;

New DSRLNK call looks like this:

HEX
CODE: DSRLNK  ( [pab_fname]-- ior)
        TOS 8356 @@ MOV,    \ ** this line ** replaces TOS PUSH, (2 instructions)
        TOS CLR,
        0 LIMI,          
        DLNK @@ BLWP,
        8 DATA,
        2 LIMI,
        NEXT,
        END-CODE

And this saves another 2 bytes, because I had to PUSH the TOS register to make room for the error code anyway.

EDIT: And while I am here I just removed the last line and put it into the DSR routine. This makes FILEOP faster, but added 2 bytes versus the FORTH version. (Yes it's true, Forth and be smaller than ALC, but not always)

EDIT2: And why not move the line that clears the GPL status byte into DSRLNK too? That saves my 2 bytes I just lost.

EDIT3: These changes improved compile times from floppy disk by 2.6% on real iron versus Version "F" Nice!

CODE: DSRLNK  ( [pab_fname]-- ior)
          TOS 8356 @@ MOV,
          TOS CLR,
          TOS GPLSTAT @@ MOVB,   \ clear GPL status register
          0 LIMI,                \ critical that we disable interrupts here.
        DLNK @@ BLWP,
          8 DATA,
          2 LIMI,
        NEXT,
        END-CODE

Edited April 4, 2019 by TheBF

+TheBF · April 9, 2019

They Don't Really Use Forth Anymore Do They?

I thought the gang here might like to see this video while they need a break from debugging.

(or while waiting for C to compile) :_( (It's a joke) ;-)

https://wiki.forth-ev.de/doku.php/events:ef2018:forth-in-that

+InsaneMultitasker · April 9, 2019

The DSRLINK...

I am forever grateful for insanemulti-tasker and the TI tech pages for giving me the foundation for DSRLINK. I could not resist trying to understand it better.
\ Source:
\ http://atariage.com/forums/topic/283914-specialized-file-access-from-xb/page-2
\ by InsaneMultitasker via Thierry Nouspikel

Nice job working through that DSRLNK code. I might have mentioned it before (and if not, I will say it here) that I did not write the DSRLNK and never intended to give you that impression. That version has been in my 'toolbox' for ages; I just passed it along.

+TheBF · April 9, 2019

Nice job working through that DSRLNK code. I might have mentioned it before (and if not, I will say it here) that I did not write the DSRLNK and never intended to give you that impression. That version has been in my 'toolbox' for ages; I just passed it along.

Understood. Somehow that version made a little more sense to me than others I had looked at.

That made it easier to integrate into my Forth system.

+TheBF · April 11, 2019

In case you ever wondered...

After playing for over a year a various optimizations I thought I should create a "mostly" Forth version for educational purposes. My entire reason for this project was to learn about cross-compiling Forth and that hopefully others could get jumpstart should they ever want to try it themselves.

So this version of the code has been cleaned of wordy comments and most of the code is Forth.

The VDP driver is written in Forth here as well using a few VDP routines so that's interesting. It seems to perform quite well too.

There is another file of Assembly language primitives that are the un-pinnings of Forth, but the spoiler is just the hi-level language to make a Forth compiler and interpreter written in Forth.

\ CAMEL99 Forth for the TI-99  un-optimized  version  11Apr2019
\ Copyright (c) 2018 Brian Fox
\ KILWORTH Ontario Canada
\ brian.fox@brianfox.ca

\ compiles with XFCC99.EXE cross-compiler

\ This program is free software; you can redistribute it and/or modify
\ it under the terms of the GNU General Public License as published by
\ the Free Software Foundation; either version 3 of the License, or
\ (at your option) any later version.
\ You should have received a copy of the GNU General Public License
\ along with this program.  If not, see <http://www.gnu.org/licenses/>.
\
\ The work derived from CAMEL Forth under the GNU General Public License.
\ CamelForth (c) 2009 Bradford J. Rodriguez.
\ Commercial inquiries for Camel Forth should be directed to:
\ 115 First St., #105, Collingwood, Ontario L9Y 4W3 Canada
\ or via email to bj@camelforth.com

\ History
\ Apr 11 2019 removed unnecessary comments for clarity
\             removed conditional compilation switches

\ ========================================================================
\ M E M O R Y   U S A G E   D E F I N I T I O N S
CROSS-COMPILING
HEX
       0FFF0   EQU EMEM    \ EMEM = "end of memory"
   EMEM 0080 - EQU 'TIB    \ ADDRESS OF Terminal Input Buffer
   EMEM 'TIB - EQU TIBSIZE

\  FORTH stacks at upper end of TI-99 memory
HEX
     'TIB 2-   EQU SP0    \ FORTH parameter stack base address.
      SP0 80 - EQU RP0    \ FORTH return stack base address

CROSS-COMPILING

     INCLUDE CC9900\compiler\ITCTYPES.HSF   \ indirect threaded versions
\ ========================================================================
\ C O D E   P R I M I T I V E S
\ [CC] is short form for CROSS-COMPILING

[CC] cr .( Compile Forth Assembler primitives ...)

 INCLUDE CC9900\9900FAS2.HSF
 INCLUDE CC9900\TI99PRIM.HSF

\ ========================================================================
\ RESOLVE CODE WORD FORWARD REFERENCES FOR CROSS-COMPILER

[CC]
 T' EXIT   RESOLVES 'EXIT
    ENTR   RESOLVES 'DOCOL
 T' DOVAR  RESOLVES 'DOVAR
 T' LIT    RESOLVES 'LIT
 T' DOCON  RESOLVES 'DOCON
 T' DOUSER RESOLVES 'DOUSER
 T' DODOES RESOLVES 'DODOES

\ ========================================================================
\ T A R G E T   D E - C O M P I L E R
\ debugging tool

CROSS-COMPILING
FALSE [IF]   INCLUDE CC9900\CCLIB\TSEE.HSF   [THEN]

\ ========================================================================
\ T A R G E T  S T A T E  C O N T R O L

TARGET-COMPILING

   VARIABLE: STATE

   STATE [CC] TO XSTATE

\ ========================================================================
\ C R O S S   C O M P I L E R   B O O T - S T R A P P I N G
\ add loop and branch words to the cross-compiler (not the TARGET)

CROSS-COMPILING
INCLUDE CC9900\cclib\BOOTSTRP.HSF

\ ========================================================================
\ S Y S T E M   C O N S T A N T S

[CC] HEX
cr .( Constants and Variables...)

TARGET-COMPILING
\ ASM/Equate       Forth Name
\ -----------      ------------
 'TIB     constant: TIB
 SP0      constant: SP0
 RP0      constant: RP0
 TIBSIZE  constant: TIB#

\ Utility constants
        0 constant: FALSE
       -1 constant: TRUE
        0 constant: 0
        1 constant: 1
        2 constant: 2
        3 constant: 3
       20 constant: BL

\ ========================================================================
\ U S E R   V A R I A B L E S
\ CAMEL99 uses space after workspace for user vars.
\ User variables begin at >8320 for the primary Forth task
[CC] HEX [TC]

      20 USER: TFLAG
      22 USER: JOB
      24 USER: DP
      26 USER: HP
      28 USER: CSP
      2A USER: BASE
      2C USER: >IN
      2E USER: C/L
      30 USER: OUT
      32 USER: VROW
      34 USER: VCOL
\      36 USER: CURRENT
\      38 USER: CONTEXT
      3A USER: LP
      3C USER: SOURCE-ID
      3E USER: 'SOURCE
\      40 USER: -------          \ used by 'SOURCE

      46 USER: TPAD

\ memory locations used by Forth ie: "variables"
 _CURSR constant: CURS
 _floor constant: FLOOR

 \ TI-99 system memory locations
   83C6 constant: KUNIT#  \ byte
   837C constant: GPLSTAT \ byte

\ These system variables control cold starting the system
variable: LATEST
variable: ORGDP
variable: ORGLAST
variable: BOOT

[CC] DECIMAL [TC]
   0024 constant: L/SCR

[CC] HEX [TC]
variable: VMODE
variable: VTOP
variable: L0  [CC] 3 CELLS TALLOT  [TC]
variable: ^PAB
variable: LINES
variable: C/SCR
variable: 'INTERPRET
variable: H

?stk
\ ========================================================================
[CC] cr .( Hi-level FORTH Primitives...)

TARGET-COMPILING
: HERE      ( -- addr) DP @  ;
: ALLOT     ( n --) DP +! ;
: COMPILE,  ( n -- ) HERE !   2 ALLOT ;
: ,         ( n -- )  COMPILE,  ;
: C,        ( c --)  HERE C!  1 ALLOT ;
: ALIGN     ( -- )   HERE ALIGNED DP ! ;
: PAD       ( -- addr) HERE TPAD @ + ;
: COMPILE   ( -- )  R> DUP 2+ >R @ COMPILE, ;
: IMMEDIATE ( --)  01 LATEST @ 1-  C! ;
: LITERAL   ( n -- n|~) STATE @ IF  COMPILE LIT  COMPILE,  THEN ;  XIMMEDIATE
: ]         ( -- ) STATE ON  ;  XIMMEDIATE
: [         ( -- ) STATE OFF ;  XIMMEDIATE

\ ========================================================================
\ Minimalist heap memory manager ( see SCROLL for example)
: MALLOC     ( n -- addr ) H @  SWAP H +! ;
: MFREE      ( n -- ) NEGATE H +! ;

\ ========================================================================
\ PAB base address
: VDPTOP  ( -- n) 8370 @ 2- ;


\ ========================================================================
\ S T A C K   P R I M I T I V E S
[CC] cr .( Stack primitives ...)  [tc]

: TUCK  ( w1 w2 --  w2 w1 w2 ) SWAP OVER ;

 CODE: 2>R    ( d -- ) ( r-- n n)
              RP -4 ADDI,          \ 14
              TOS 2 (RP) MOV,      \ 22
             *SP+   *RP MOV,       \ 26
              TOS POP,             \ 22
              NEXT,              \ = 84
              END-CODE

 CODE: 2R>     ( -- d )
              TOS PUSH,            \ 28
              SP DECT,             \ 10
             *SP  RPOP,            \ 26
              TOS RPOP,            \ 22
              NEXT,              \ = 88
              END-CODE

\ ========================================================================
\ C O M P A R I S O N   O P E R A T O R S

TARGET-COMPILING
: U>  ( n n -- ?)  SWAP U< ;
: 0>  ( n -- ?)    1- 0< INVERT ;
: <>  ( n n == ?)  =  INVERT ;
: UMIN ( u1 u2 -- u )  2DUP U> IF SWAP THEN DROP ;
: UMAX ( u1 u2 -- u )  2DUP U< IF SWAP THEN DROP ;
: WITHIN ( u lo hi -- t ) OVER - -ROT - U> ;

\ ========================================================================
\ M I X E D  (32BIT/16BIT)   M A T H   O P E R A T I O N S

: */MOD  ( n1 n2 n3 -- n4 n5)  >R UM* R> M/MOD ;
: S>D    ( n -- d)  DUP 0< ;
: /MOD   ( n1 n2 -- n3 n4) >R S>D R> M/MOD ;
: /      ( n n -- n)   /MOD NIP  ;
: MOD    ( n n -- n)   /MOD DROP ;
: */     ( n n n -- n) */MOD NIP ;

\ ========================================================================
\ S T R I N G   T H I N G S

TARGET-COMPILING
: MOVE    ( src dst n -- )
          >R  2DUP SWAP DUP R@ +
          WITHIN
          IF    R> CMOVE>
          ELSE  R> CMOVE
          THEN ;

\ CAMEL Forth calls this ">COUNTED"
: PLACE   ( src n dst -- ) 2DUP C! 1+ SWAP MOVE ;
: /STRING ( c-addr1 u1 n -- c-addr2 u2 ) ROT OVER + -ROT - ;
: S,         ( c-addr u -- ) HERE OVER 1+ ALLOT PLACE  ALIGN ;

\ ========================================================================
\ H E A D E R   N A V I G A T I O N

TARGET-COMPILING
: NFA>LFA       ( nfa -- lfa)  3 - ;
: NFA>CFA       ( nfa -- cfa ) COUNT  7F AND + ALIGNED ;

\ smudge bit control in the Camel Forth
: HIDE          ( -- )  LATEST @ ( nfa) DUP C@ 80 OR  SWAP C! ;
: REVEAL        ( -- )  LATEST @ ( nfa) DUP C@ 7F AND SWAP C! ;


\ ========================================================================
\ P A R S E   W O R D
[CC] cr .( Parsing...)
TARGET-COMPILING
: SOURCE  'SOURCE 2@ ;    \ Common factor, saves space

                    [CC] [PRIVATE] [TC]
: ADR>IN      ( c-addr' --  ) SOURCE  -ROT -  MIN  0 MAX >IN ! ;

                    [CC] [PUBLIC] [TC]
: PARSE       ( char -- c-addr n)
              SOURCE >IN @ /STRING
              OVER >R ROT SCAN
              OVER SWAP
              IF 1+ THEN
              ADR>IN
              R> TUCK - ;

: PARSE-WORD  ( char -- c-addr n)
              DUP SOURCE >IN @ /STRING
              ROT SKIP
              DROP ADR>IN PARSE ;

: WORD        ( char -- c-addr)
              PARSE-WORD HERE PLACE
              HERE BL OVER COUNT + C! ;


\ ========================================================================
\ S T R I N G  T O  N U M B E R   C O N V E R S I O N
[CC] CR .( CAMEL FORTH Number conversion)
 HEX

TARGET-COMPILING

: DIGIT?     ( char -- n -1)
\            (      -- x  0 )
              DUP 39 > 100 AND +
              DUP 140 > 107 AND -
              T[CHAR] 0 -
              DUP BASE @ U< ;

                       [PRIVATE]
: ?SIGN      ( adr n -- adr' n' ?)
             OVER C@
             2C - DUP ABS 1 = AND
             DUP IF 1+
                    >R 1 /STRING R>
             THEN ;

                       [PUBLIC]
: UD*        ( ud1 u2 -- ud3)
             DUP >R * SWAP R> UM* ROT + ;

: >NUMBER    ( ud adr u -- ud' adr' u' )
            BEGIN  DUP
            WHILE
              OVER C@ DIGIT?
              IF  >R 2SWAP BASE @ UD*
                  R> M+ 2SWAP 1 /STRING
              ELSE DROP EXIT
              THEN
            REPEAT ;

: ?NUMBER    ( c-addr -- n -1 )
\ ;Z                  -- c-addr 0         \ if convert error
             DUP  0 0 ROT COUNT
             ?SIGN >R
             >NUMBER
             IF    R> 2DROP 2DROP FALSE
             ELSE  2DROP NIP R>
                IF NEGATE THEN TRUE
             THEN ;

\ ========================================================================
\ S I M P L E   S O U N D  I N T E R F A C E

[CC] include cc9900\cclib\ticktock.hsf   \ hardware milli-second timer

TARGET-COMPILING

\ write a byte to address of TMS9919 chip
: SND!   ( c -- )  8400 C!  ;  \ 4 bytes, 277 uS

: BEEP     ( -- )
            80 SND! 5 SND!   \ precalulated values for OSC1 1328Hz
            91 SND!
            AA MS
            9F SND! ;

: HONK     ( -- )
            81 SND! 20 SND!  \ precalculated values for OSC1 218Hz
            90 SND!
            AA MS
            9F SND! ;

\ ========================================================================
\ V D P  S C R E E N   D R I V E R
[CC] cr .( Console output)

TARGET-COMPILING
\ pronounced "SEE-PER-ELL-STORE"
: C/L!       ( c/l -- )
             DUP C/L !           \ set chars per line
             L/SCR *  C/SCR ! ;  \ calc.chars per screen

[cc] HEX [tc]

\ : GETXY   ( -- col row ) VROW 2@  ;
: AT-XY   ( col row -- ) VROW 2! ;
: VPOS    ( -- vaddr)    VROW 2@ >VPOS ;
: CLRLN   ( col row -- ) AT-XY VPOS C/L@ BL VFILL ;

\ -----------------------------------------------------------------------
\ Scrolling has been implemented in Forth using VREAD & VWRITE
\ MALLOC creates a temporary buffer to hold 2 lines of screen text

                              [PRIVATE]
\ calc size of 2 lines,
: 2C/L ( -- n) C/L@ 2* ;

                              [PUBLIC]
: SCROLL   ( -- )
           2C/L DUP  MALLOC ( -- c/s heap)
           C/SCR @  C/L@ VTOP @ +
           DO
              PAUSE
              I  ( -- c/s heap scr-addr)
              OVER 2DUP     2C/L VREAD
              SWAP C/L@ -   2C/L VWRITE
              2C/L
           +LOOP
           0 17  CLRLN
           DROP
           MFREE ;

\ ========================================================================
\ V D P   T E X T   O U T P U T

[cc] HEX [tc]

: (CR)   ( -- ?)
          OUT OFF  VCOL OFF
          1 VROW +!
          FALSE
          VROW @ L/SCR = IF  DROP TRUE THEN ;

: VPUT      ( c -- ) VPOS VC! ;

: (EMIT) ( char -- ?) \ ?=TRUE if at end of line
          VPUT
          1  OUT +!
          1 VCOL +!
          FALSE
          C/L@ VCOL @ = IF  DROP TRUE THEN ;

: PAGE      ( -- )
             VTOP @
             DUP C/SCR @ OVER -
             BL VFILL
             0 SWAP C/L@ / AT-XY ;

: CR        ( -- )
            PAUSE
            (CR) ( -- ?)
            IF  SCROLL  THEN  ;

: BS  ( --)  VCOL DUP @ 1- 0 MAX SWAP !
             -1 OUT +! ;

[CC] HEX [TC]
: EMIT      ( char -- )  \ shows how to handle control characters
            DUP 0D = IF DROP CR   EXIT THEN
            DUP 08 = IF DROP BS   EXIT THEN
            (EMIT)   IF CR THEN  ;

: TYPE      ( adr cnt --) PAUSE BOUNDS ?DO  I C@ EMIT  LOOP ;
: SPACE     ( -- )   BL EMIT ;
: SPACES    ( n -- ) PAUSE 0 MAX  0 ?DO SPACE LOOP ;


\ ========================================================================
\ S T R I N G   L I T E R A L S
[cc] HEX [tc]
\ run-time action of S"   (For ITC Forth only)
: (S")      ( -- c-addr u) R>  COUNT  2DUP + ALIGNED  >R ;

\ ========================================================================
\ Re-solve CROSS-COMPILER Forward reference for '(S") and 'TYPE
CROSS-COMPILING

T' (S")  RESOLVES '(S")
T' TYPE  RESOLVES 'TYPE

[cc] cr .( Character input)
\ ========================================================================
\ C H A R A C T E R   I N P U T

TARGET-COMPILING
: KEY       ( -- char)
            BEGIN
              CURS@ VPUT
              PAUSE         \ Multi-tasking while we wait
              KEY?          \ call ROM KSCAN
            UNTIL
            8375 C@ 7F AND  \ read KSCAN buffer, mask to 7 bits
            BL VPUT ;

\ High level: input/output          (c) 31mar95 bjr
: ACCEPT     ( c-addr +n -- +n')
             OVER + 1- OVER
             BEGIN  KEY DUP 0D <>
             WHILE
                DUP EMIT
                DUP 8 =
                IF   DROP 1-  >R OVER R> UMAX
                ELSE OVER C!  1+ OVER UMIN
                THEN
             REPEAT
             DROP NIP SWAP -  ;

[cc] cr .( Number printing)
\ ======================================================================
\ N U M B E R   T O   S T R I N G   C O N V E R S I O N

TARGET-COMPILING
: UD/MOD ( ud1 u2 -- u3 ud4) >R 0 R@ UM/MOD -ROT R> UM/MOD ROT ;
: HOLD   ( char -- )  HP -1 OVER +! @ C! ;
: >DIGIT ( n -- c) DUP 9 > 7 AND + 30 + ;
: <#     ( --)          PAD HP ! ;
: #      ( ud1 -- ud2)  BASE @ UD/MOD ROT  >DIGIT  HOLD  ;
: #S     ( ud1 -- ud2)  BEGIN  #   2DUP OR  WHILE REPEAT ;
: #>     ( ud1 -- c-addr u) 2DROP HP @ PAD OVER - ;
: SIGN   ( n -- ) 0< IF T[CHAR] -  HOLD THEN ;
: DU.    ( d -- ) <#  #S  #>  TYPE SPACE ;
: U.     ( u -- ) 0 DU. ;
: .      ( n -- ) DUP ABS 0  <# #S ROT SIGN #> TYPE SPACE ;

\ ========================================================================
\ M I S C E L L A N E O U S
[cc] HEX [tc]

: RECURSE     ( -- ) LATEST @ NFA>CFA COMPILE,  ; XIMMEDIATE
: DECIMAL     ( -- ) 0A BASE ! ;
: HEX         ( -- ) 10 BASE ! ;

\ ========================================================================
\ I N T E R P R E T E R

: INTERPRET    ( addr len -- )  'INTERPRET @ EXECUTE ;

\ ========================================================================
\ Q U I T :  The  O U T E R   I N T E R P R E T E R

: QUIT         ( -- )
               L0 LP !
               RP0 RP!
               SOURCE-ID OFF
               VDPTOP ^PAB !   \ set base pab pointer
               t[COMPILE] [
               BEGIN
                  TIB DUP TIB# ACCEPT SPACE
                ( addr len) INTERPRET
                  STATE @ 0= IF  T."  ok" CR THEN
               AGAIN ;

: EVALUATE     ( c-addr u -- j*x)
               SOURCE-ID ON
               SOURCE 2>R
               >IN @ >R
               INTERPRET
               R> >IN !
               2R> 'SOURCE 2!
               SOURCE-ID OFF ;

\ ========================================================================
\ E R R O R   H A N D L I N G
\
: ABORT       ( -- )  SP0 SP!  CR QUIT ;

: ?ABORT  ( f c-addr u --)
           ROT IF  HONK
                   CR CR T." ? "  TYPE
                   SOURCE-ID @   ( if source is NOT console)
                   IF  T."  Line " LINES @ U.
                       CR CR SOURCE TYPE
                   THEN ABORT
           THEN 2DROP ;

: ?FIND       ( ? -- )       0=    HERE COUNT ?ABORT ;
: ?PAIRS      ( n1 n2 --)     -    TS" Unpaired"       ?ABORT ;
: ?COMP       ( -- ) STATE @ 0=    TS" Compile only"   ?ABORT ;
: ?EXEC       ( -- ) STATE @       TS" Interpret only" ?ABORT ;
: ?CSP        ( -- ) SP@ CSP @ -   TS" Unfinished"     ?ABORT ;
: ?STACK      ( -- ) SP0 2- SP@ U< TS" Empty stack"    ?ABORT ;
: !CSP        ( -- ) SP@ CSP ! ;

\ ========================================================================
\ S T R I N G   L I T E R A L
\ Non-standard: when interpreting S" puts the string in PAD

: S"          ( cccc" -- )
              T[CHAR] " PARSE
              STATE @
              IF  COMPILE (S")  S,
              ELSE PAD PLACE PAD COUNT
              THEN ; XIMMEDIATE

: ABORT"      ( i*x 0  -- i*x)    \ R: j*x -- j*x  x1=0
              ?COMP
             T[COMPILE] S"
              COMPILE ?ABORT ; XIMMEDIATE

[cc] cr .( FIND )
\ ========================================================================
\ D I C T I O N A R Y   S E A R C H

TARGET-COMPILING
: FIND  ( caddr --  caddr  0  if not found)
\                    xt  1  if immediate,
\                    xt -1  if "normal"
                    LATEST @  (FIND) ;

: '        ( -- xt) BL WORD FIND ?FIND ;

: [']      ( -- <name> ) ?COMP  '  T[COMPILE] LITERAL ; XIMMEDIATE

: POSTPONE ( <name> -- )      \ replaces COMPILE and [COMPILE]
          ?COMP
          BL WORD FIND DUP ?FIND
          0< IF   COMPILE COMPILE
             THEN  COMPILE, ; XIMMEDIATE

\ ========================================================================
\ T E X T   O U T P U T

: ."    (  ccc" -- )
        t[COMPILE] S"                ( -- str len)
        STATE @ IF   COMPILE TYPE
                ELSE TYPE
                THEN ; XIMMEDIATE

: .(     T[CHAR] ) PARSE TYPE ;

[CC] cr .( Interpreter/compiler loop)
\ ========================================================================
\ I N T E R P R E T E R  /  C O M P I L E R

TARGET-COMPILING
: <INTERPRET>  ( i*x c-addr u -- j*x )
               'SOURCE 2!  >IN OFF
               BEGIN
                  BL WORD DUP C@ ( -- addr len)
               WHILE
                  FIND
                  ?DUP IF ( it's a word)
                       1+ STATE @ 0= OR
                       IF   EXECUTE
                       ELSE COMPILE,
                       THEN

                  ELSE ( it's a number)
                       ?NUMBER
                       IF  t[COMPILE] LITERAL
                       ELSE TRUE SWAP COUNT ?ABORT
                       THEN
                  THEN
                  ?STACK
               REPEAT
               DROP ;

\ ======================================================================
\ T I - 9 9   T E X T   M O D E   C O N T R O L
TARGET-COMPILING

: TEXT      ( -- )
             F0 DUP 83D4 C!
       ( -- F0) 01 VWTR
             20  7 VWTR
             28 C/L!
             VTOP OFF
             VROW OFF
             VCOL OFF
             2 VMODE !
             PAGE ;

\ ========================================================================
\ D I C T I O N A R Y   C R E A T I O N

: HEADER, ( addr len --)
            ALIGN
            LATEST @ ,
            0 C,
            HERE LATEST !
            S, ;

: HEADER   BL PARSE-WORD HEADER, ;

\ ========================================================================
\ T A R G E T   S Y S T E M   D E F I N I N G   W O R D S

\                    text    runtime-action   parameter
\ -------------------------  --------------- -----------
: CONSTANT  ( n --)  HEADER  COMPILE DOCON     COMPILE, ;
: USER      ( n --)  HEADER  COMPILE DOUSER    COMPILE, ;
: CREATE    ( -- )   HEADER  COMPILE DOVAR              ;
: VARIABLE  ( -- )   CREATE                  0 COMPILE, ;

\ (:noname) came from studying gforth. It's a nice factor.
\ had to use the literal address of ENTR ($839E) to make this work.
: (:NONAME) ( -- )  839E COMPILE,  HIDE  ]  ;

\ =======================================================================
\ D O E S   S U P P O R T
: (;CODE)
         R>
        LATEST @ NFA>CFA
         !  ;

: DOES>  ( -- )
        COMPILE (;CODE)
        0460 , T['] DODOES ,  \ compile machine code:  B @DODOES
       ; XIMMEDIATE

\ =======================================================================
\ TI-99 F I L E   S Y S T E M   I N T E R F A C E

 [CC] include CC9900\cclib\dsrlink9.hsf
 [CC] include CC9900\cclib\filesysX.hsf

\ =======================================================================
\ LOOPS AND BRANCH COMPILERS FOR THE TI-99 SYSTEM
 [CC] CR .( TARGET Forth BRANCHING and LOOPING ...)

 [CC]  include cc9900\cclib\targloop.hsf

\ =======================================================================
\ INIT: Set Workspace, copy code to scratch pad, set stacks, run BOOT

CROSS-ASSEMBLING

CODE: INIT
              WRKSP0 LWPI,
              R0 HSprims LI,   \ source
              R1 HSstart LI,   \ destination
              BEGIN,
               *R0+ *R1+ MOV,
                R1 HSend CMPI,
              EQ UNTIL,

              SP  SP0  LI,
              RP  RP0  LI,
              R10 NEXT2 LI,
              IP  BOOT  LI,
             *R10 B,
              END-CODE

[CC] HEX
\ ======================================================================
\ B O O T   U P   C O D E
TARGET-COMPILING
: COLD       ( -- )
              80 83C2 C!   \ ISR disable flags:
              ORGDP @ DP !
              ORGLAST @ LATEST !
              26 TPAD !
              2000 H !                       \ reset the heap
              TMR!                           \ 9901 timer runs continuously
              2 KUNIT# C!                    \ use BASIC keyboard
              T['] <INTERPRET> 'INTERPRET !  \ set the interpreter vector
              HEX                            \ default to hex
\ VDP start screen
              TEXT BEEP
              TS" CAMEL99 Forth" TYPE
              VDPTOP ^PAB !
              TS" DSK1.START" INCLUDED
              ABORT ;

\ ======================================================================
\ define target comment words
TARGET-COMPILING
: (         T[CHAR] ) PARSE 2DROP ; XIMMEDIATE
: \                 1 PARSE 2DROP ; XIMMEDIATE

[CC]

TARGET-COMPILING
 X: :         !CSP  HEADER (:NONAME)  ;X

 X: :NONAME   HERE  !CSP   (:NONAME)  ;X

 X: ;        [  REVEAL COMPILE EXIT ?CSP ;X  XIMMEDIATE

[CC]
\           F O R T H   S Y S T E M   C O D E   E N D S
\ /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/
cr .( Forth Kernel compiled completely")
            END.   ( report compile time)

\ ======================================================================
\  P A T C H   T H E   T A R G E T  S Y S T E M   V A R I A B L E S

[CC]   XLATEST @ DUP LATEST T!
                    ORGLAST T!
               THERE DUP DP T!
                      ORGDP T!

\ ======================================================================
\ P A T C H   T A R G E T   I M A G E  F I L E   H E A D E R

         FILENAME: CAMEL99
         T' INIT >BODY BOOT-ADDRESS T!

\ S E T   T H E   B O O T   W O R D   T O   R U N

         T' COLD       BOOT T!

\ ======================================================================
\ S A V E   B I N A R Y  I M A G E   F I L E

         FILENAME$ $SAVE-EA5.     \ FILENAME$ was set by FILENAME:

\ ======================================================================
\  C O P Y   T O   T I - 9 9   V I R T U A L   D I S K
.( copying binary file to TI-99 Emulator DSK1.)

( //  shells out to the DOS shell in HSF2012)

      // copy CAMEL99 cc9900\clssic99\dsk1\

CROSS-COMPILING

 CR ." === COMPILE ENDED PROPERLY ==="

 BYE  ( return to DOS)

Edit: comment fix

Edited April 11, 2019 by TheBF

+TheBF · April 19, 2019

Re-visiting Direct Threaded Code (DTC)

I was working on the DTC version of CAMEL99 Forth because I had not figured out how to make DOES> work.
For the non-forther CREATE DOES> gives forth a very simple form of object oriented programming that pre-dates OOP by about 15 years.

I took to reading the bible on the matter Brad Rodriguez's papers called "Moving Forth"

In Part 3 http://http://www.bradrodriguez.com/papers/moving3.htm we can read about how DOES> works with indirect threading, direct threading and sub-routine threading.

While reading this over I realized that I had missed something about DTC.

DTC works by creating ALC routines just like you would in assembler but you end them with a branch to a 2 instruction routine call "next" that works like "return" but uses the Forth return Stack.
(typically this routine's address is kept in a register so it is B *R10 for example which is only 2 bytes for each Forth routine.

\ Forth DTC NEXT routine in Forth Assembler 
\ IP is the instruction pointer register for the Forth virtual machine (R9 in CAMEL99 forth)

l: _next                     
       *IP+ R5 MOV,    \ read contents at IP into R5, auto inct IP
           *R5 B,      \ branch to the address in R5

This is great for code words. Very simple and you get nestable sub-routine calls with only 2 instructions. Not bad!

But Forth words are lists of addresses so they need a routine to "interpret" those lists. To enter a Forth word we use DOCOL
( called "do colon" because ":" is how we create a new Forth word)

In a DTC system we need to start every Forth word with a branch to that DOCOL Routine like below:

<wordname>  <B @DOCOL >  <forth> <forth> <forth> etc...

But the list of Forth addresses starts 4 bytes after the branch instruction so when we run DOCOL, I used a temp register to keep track of this and advance it by 4 bytes to get to the correct place with Forth "instructions".
My old docol is shown below.

Edit: changed to R5 to align with DOCOL example

l: _docol     IP RPUSH,
              R5 4 ADDI,      \ jump past the code fragment in the Forth word
              R5 IP MOV,      \ move new IP address into Forth IP register              
              NEXT,           \ goto next routine

Brad mentions using a JSR instruction (jump to subroutine) to make this easier but I always thought we needed a stacked sub-routine address to make this work like in the 6809 CPU example.

BUT NO!

The reason to use JSR is because it automatically computes the address where we need to return to, which is ... 4 bytes ahead!

So the BL instruction takes care of that perfectly by putting that special address in R11 AUTOMATICALLY! So all I needed to do was this:

\ Using Branch and Link

<wordname>  <BL @DOCOL >  <forth> <forth> <forth> etc...
                         ^ 
                         |  
\ R11 points to here: ---^  YEAH!

So my new DOCOL looks like this:

l: _docol     IP RPUSH,      
              R11 IP MOV,    
              NEXT,        \ EDITed

And this benefit extends to the "Executor" routines for variables and constants too:

\ Executor that executes a "CONSTANT"
l: _docon    TOS PUSH,      \ make room in TOS
             *R11 TOS MOV,  \ move PFA into Forth IP register    14
              NEXT,

 \ Executor that executes a "VARIABLE"
l: _dovar     TOS    PUSH,   \ make room in TOS                   28
              R11  TOS MOV,  \ move PFA into Forth IP register    14
              NEXT,

I still haven't got DOES> working but the new DTC Forth system runs between 10% and 21% faster than the ITC system.

Forth word headers still consume 4 bytes extra however. But CODE words are 2 bytes smaller.

DTC also means that I can begin "inlining" small CODE routines seamlessly into Forth definitions so I need to explore making a peep hole optimizer on the Forth compiler.

Many Forth primitives are only one 9900 instruction so this will work really well.

So much code, so little time

Happy Easter and a Blessed Passover

Edited April 21, 2019 by TheBF

+TheBF · April 20, 2019

DTC Update

One cool thing about direct threaded code is that it works better with code that is put in scratch-pad RAM.

With in-direct threading you have to put the scratch-pad address in a Forth word in expansion RAM so that it can be called removing some of the advantage.

CAMEL99 Forth keeps the Forth virtual machine instructions call BRANCH ( un-conditional jump) and ?BRANCH ( jump if top of stack contains a zero) in scratch-pad RAM.

After modifying the compiler to compile the scratch-pad addresses "directly" here is the speed-up of this empty 64K loop:

: TEST FFFF BEGIN 1- DUP WHILE REPEAT ;

That's a 30% improvement.

+TheBF · April 23, 2019

Final word on DTC (for me)

So after all that work of creating a better DTC system, I compared how long it took to compile the assembler into each system, ITC Fast version and the DTC version.

The same amount of Forth Assembler words are used by both systems.

ITC time: 19.06 seconds

DTC time: 18.98 seconds

Almost no difference.

BUT! The DTC code used 300 bytes more space in creating the assembler opcodes and directives.

So unless you write your entire project in Forth Assembler, there is really no advantage with DTC on the 9900 that I can see.

This was not true on the older '86 CPUs where DTC made a very snappy system.

On to native code generation. It's the only thing that will make a material improvement.

+TheBF · April 23, 2019

I have uploaded my latest code and included the clean version of CAMEL99 which writes the compiler in Forth.

I also included a demo that pulls together some graphics and sound. (no sprites)

This one creates a fly in random mazes.

The fun part was making a buzzing sound. The fly gets angry when it is trying to find a way out of a corner.

I made use of the lower frequency sounds you get from signal generator 4 in NOISE 3 mode.

The word HERZ lets me input very low frequencies to create an effective buzzing sound.

The video shows you what it does.

The code is just to demonstrate a Forth way of coding (games perhaps) with commands that your create yourself.

\ alpha intelligence demonstration with a Fly graphic

\ INCLUDE DSK1.TOOLS
INCLUDE DSK1.GRAFIX
INCLUDE DSK1.RANDOM
INCLUDE DSK1.SOUND

VARIABLE SPEED

\ ==================================
\ sound words
DECIMAL
: SNDINIT     GEN4 3 NOISE MUTE    \ MODE 3: osc 3 controls OSC 4 frequency
              GEN3 1300 HZ MUTE ;

DECIMAL
: HERZ ( n -- n')  15 * HZ  ;  \ convert n -> Hz for NOISE 3 mode.

\             Osc 3 freq. ctrl       Osc 4 volume control
\            ---------------------  --------------------
: BUZZ        GEN3 87  5 RND + HERZ   GEN4 12 4 RND + DB ;
: ANGRY       GEN3 90 10 RND + HERZ   GEN4  6 2 RND + DB ;

\ ==================================
\ character patterns
HEX
 00FE FEFE FEFE FEFE PATTERN: REDBRICK
 3C7E DBFF DBE7 7E3C PATTERN: HAPPYFACE
 3C7E DBFF E7DB 7E3C PATTERN: SADFACE

\ fly's direction patterns
0044 3838 7CFE EE44 PATTERN: NORTHFLY
0060 F27C 3C7C F260 PATTERN: EASTFLY
0006 4F3E 3C3E 4F06 PATTERN: WESTFLY
0044 EEFE 7C38 3844 PATTERN: SOUTHFLY
0808 7CFF 7C1C 1C08 PATTERN: NORTHEASTFLY
1010 3EFF 3E38 3810 PATTERN: NORTHWESTFLY
1038 383E FF3E 1010 PATTERN: SOUTHWESTFLY
081C 1C7C FF7C 0808 PATTERN: SOUTHEASTFLY

\ named chars
DECIMAL
160 CONSTANT THE-FLY
168 CONSTANT BRICK

\ define chars
 REDBRICK  BRICK CHARDEF   BRICK SET#  7 15 COLOR
 NORTHFLY  THE-FLY CHARDEF

: CLIP   ( n low hi -- n') ROT MIN MAX ;

: RNDX   ( -- x)  23 RND 2 22 CLIP ;
: RNDY   ( -- y)  33 RND 2 30 CLIP ;

: .BORDER   ( -- )
          \ col row
             0   1 BRICK 32 HCHAR
             0  23 BRICK 32 HCHAR
             0   1 BRICK 23 VCHAR
            31   1 BRICK 23 VCHAR ;

: .WALLS
            RNDY  RNDX BRICK 10 VCHAR
            RNDY  RNDX BRICK 18 HCHAR
            RNDY  RNDX BRICK  8 HCHAR
            RNDY  RNDX BRICK 10 VCHAR
            RNDY  RNDX BRICK  4 VCHAR
            RNDY  RNDX BRICK  3 VCHAR
            RNDY  RNDX BRICK  8 HCHAR
            RNDY  RNDX BRICK 10 VCHAR
            RNDY  RNDX BRICK  5 HCHAR
            RNDY  RNDX BRICK  3 VCHAR ;

\ ==================================
\ double variable hold Y and X
CREATE VECTOR 0 , 0 ,
CREATE MY-XY  0 , 0 ,    \ independant cursor for alpha guy

: RNDV     ( -- -1 0 1 )  3 RND 1- ;
: NON-0    ( -- n)  BEGIN  RNDV ?DUP UNTIL ;

: NEW-VECTORS  ( -- X Y)      \ we need to prevent a (0,0) vector condition
               RNDV DUP 0=    \ If 1st # is 0
               IF    NON-0    \ wait for a non-zero 2nd #
               ELSE  RNDV
               THEN ;

\ direction testers
: EAST?    ( y x -- y x ? ) 2DUP 0= SWAP 0> AND ;
: NTHEAST? ( y x -- y x ? ) 2DUP 0< SWAP 0> AND ;
: STHEAST? ( y x -- y x ? ) 2DUP 0> SWAP 0> AND ;
: WEST?    ( y x -- y x ? ) 2DUP 0= SWAP 0< AND ;
: NTHWEST? ( y x -- y x ? ) 2DUP 0< SWAP 0< AND ;
: STHWEST? ( y x -- y x ? ) 2DUP 0> SWAP 0< AND ;
: SOUTH?   ( y x -- y x ? ) 2DUP 0> SWAP 0= AND ;
: NORTH?   ( y x -- y x ? ) 2DUP 0< SWAP 0= AND ;

\ change the fly's character to point in the correct direction
: ROTATE-FLY  ( x y -- )
          EAST?    IF 2DROP  EASTFLY      THE-FLY CHARDEF   EXIT THEN
          WEST?    IF 2DROP  WESTFLY      THE-FLY CHARDEF   EXIT THEN
          NORTH?   IF 2DROP  NORTHFLY     THE-FLY CHARDEF   EXIT THEN
          NTHEAST? IF 2DROP  NORTHEASTFLY THE-FLY CHARDEF   EXIT THEN
          STHEAST? IF 2DROP  SOUTHEASTFLY THE-FLY CHARDEF   EXIT THEN
          SOUTH?   IF 2DROP  SOUTHFLY     THE-FLY CHARDEF   EXIT THEN
          NTHWEST? IF 2DROP  NORTHWESTFLY THE-FLY CHARDEF   EXIT THEN
          STHWEST? IF 2DROP  SOUTHWESTFLY THE-FLY CHARDEF   EXIT THEN
          2DROP  ;

: CHANGE-DIR   ( -- )  NEW-VECTORS 2DUP VECTOR 2!  ROTATE-FLY ;

: VECTOR@      ( --  dx dy)  VECTOR 2@ ;
: VECT+        ( x y dx dy -- x' y' ) ROT +  -ROT + SWAP ;

\ direct memory screen control
: >VPOS        ( Y X -- vaddr)  C/L@ * + ;
: GETXY        ( -- x y) MY-XY 2@ ;
: PUT-CHAR     ( c -- ) GETXY >VPOS VC! ;
: ERASE-FLY    ( -- )   BL PUT-CHAR ;
: SHOW-FLY    ( -- )   THE-FLY PUT-CHAR ;

: READ-CHAR    ( Y X -- c) >VPOS VC@ ;  \ read char without moving cursor
: NEXT-POS     ( -- Y X ) GETXY VECTOR@ VECT+  ;

: MOVE-FLY    ( -- )  ERASE-FLY  NEXT-POS MY-XY 2!  SHOW-FLY ;

DECIMAL
VARIABLE TRYS

\ print right justified n spaces
: .R   ( n n -- )  >R DUP ABS 0 <# #S ROT SIGN #>  R> OVER - SPACES TYPE ;
: .VECTOR  ." Vector"  VECTOR 2@  2 .R  2 .R ." , ";
: .TRYS    ." Trys"   TRYS @  2 .R ." , ";
: .SPEED   ." Speed"  SPEED @ 3 .R ;
: .BRAIN  ( -- )  0 0 CLRLN  .VECTOR SPACE .TRYS SPACE .SPEED  ;
: SAD         THE-FLY SET#  7 1 COLOR  ;
: HAPPY       THE-FLY SET#  2 1 COLOR  ;
: LOOK-AHEAD   ( -- c) NEXT-POS READ-CHAR ;
: CLEAR-AHEAD? ( -- ?) LOOK-AHEAD  BL = ;

: THINK  ( -- )
            SAD                        \ change face & color while thinking
            TRYS OFF                   \ reset the trys counter
            BEGIN
               ANGRY
               CHANGE-DIR              \ get new direction
               .BRAIN                  \ report to screen
               1 TRYS +!               \ count the try
               ?TERMINAL IF EXIT THEN  \ escape if it gets trapped
               CLEAR-AHEAD?
            UNTIL
            HAPPY  ;

: ?REST        ( -- ) 200 RND 7 = IF  SILENT  1500 RND MS  THEN ;
: CHANGE-SPEED ( -- ) 35 30  RND + DUP SPEED !  MS  ;

: ?HALT        ( -- )
        ?TERMINAL
        IF SILENT CLEAR
          ." Exit program? (Y/N)"
          KEY [CHAR] Y =
          IF
             BYE
          THEN
       THEN ;

DECIMAL
: RUN      ( -- )
      BEGIN
         SNDINIT SILENT
         16 SCREEN
         PAGE 4 11 AT-XY ." Fly Intelligence Demo"  1000 MS
         PAGE  .BORDER  .WALLS
         RNDY RNDX MY-XY 2!
         HAPPY SHOW-FLY
         CHANGE-DIR
         BEGIN
           CLEAR-AHEAD?
           IF   MOVE-FLY
           ELSE THINK
           THEN CHANGE-SPEED
           BUZZ ?REST
           KEY?
         UNTIL
         ?HALT
      AGAIN ;

TheFlyDemo.mp4

Edited April 23, 2019 by TheBF

+TheBF · April 27, 2019

GDMike showed us a screen full of character definitions he is working on in Turbo Forth in the thread Mystified by the input command.

Here is some code that I use that looks like it will work in Turbo Forth with small tweaks.

It reads the default character patterns from GROM and puts them back into the pattern table in VDP RAM.

Someone will notice that I did not properly search for the pattern table entry GROM but used "dead reckoning" using the actual address.

If I ever change my internal GROMS to an updated version I will be sure and fix this. :-)

Two things to change for TurboForth that I can see:

Replace VC! with V! ( V! in CAMEL99 Forth stores 16 bits)
Check the word ]PDT and replace 800 with the TurboForth pattern descriptor table address
You will need to define the word SPLIT which is : SPLIT DUP 0FF AND SWAP FF00 AND 8 >> ; *EDIT #2 per Lee's corrections
You could use this method to create patterns above ASCII 127 by adding $100 to as shown in the comments (untested)

\ CHARSET restores TI-99 default characters from GROM

\ GROM Character Sets           Address  ASCII Codes  Bytes/Char
\ ----------------------------  -------  -----------  ----------
\ Large caps                     04B4h     32   95      8
\ Normal Capitals                06B4h     32   95      7
\ Lowercase                      087Bh     96  126      7

HEX
\ 9800 CONSTANT GRMRD ( GROM base)   \ GROM read byte
\ 9802 CONSTANT GRMRA                \ GROM set read address

\ 9C00 CONSTANT GRMWD                \ GROM write byte
\ 9C02 CONSTANT GRMWA                \ GROM set write address
HEX
: GROM   ( addr -- ) SPLIT 9C02 C! 9C02 C! ;     \ set the GROM address)
: GC@+   ( -- c)     9800 C@ ;                   \ read & auto-increment address)
: ]PDT   ( char# -- 'pdt[n] )  8* 800 + ;        \ VDP pattern Descriptor table
: ]GFONT ( ascii -- grom_adr)  BL -  7 * 6B4 + ; \ GROM array of TIFont data

\ transfer directly from GROM to VDP
: GVMOVE  ( grom_addr vdp_addr cnt -- )
          ROT GROM   BOUNDS DO  GC@+ I VC!  LOOP ;

: CHARSET ( -- )
        [CHAR] ~ 1+  BL                \ all ASCII chars
        DO
           I ]GFONT                     \ get GROM address for char I
           I ]PDT                       \ get PDT address for char I
\          I 100 + ]PDT                 \ this will write patterns above ASCII chars
           0 OVER VC!                   \ store 1st zero in VDP
           1+                           \ inc PDT address
           7 GVMOVE                     \ write 7 bytes GROM->VDP
        LOOP ;

\ BONUS WORD: loads the TITLE screen font from GROM
 : BIGCAPS  ( -- ) 4B4 900 200 GVMOVE ;  \ TI title page fonts

\ move data from GROM to CPU RAM
\ : GCMOVE  ( grom addr cnt -- ) ROT GROM  BOUNDS DO  GC@+ I C!  LOOP  ;

Edited April 27, 2019 by TheBF

+TheBF · April 27, 2019

Using Classic99's cool Build function I have saved a SNAKE game as two EA5 files.

It's not fancy but as it speeds up I can't get past a snake of 30 ft. :woozy:

\ snake  a simple game in Forth ported to CAMEL99 Forth
\ DERIVED FROM: https://skilldrick.github.io/easyforth/#snake

\ Re-written for CAMEL99 Forth

HERE

NEEDS RND FROM DSK1.RANDOM
NEEDS GRAPHICS FROM DSK1.GRAFIX
\ INCLUDE DSK1.TOOLS    \ for debugging only


: ENUM  ( 0 <text> -- n) DUP CONSTANT  1+ ;

\ named colors per Ti BASIC
1 ENUM TRANS
  ENUM BLACK
  ENUM MEDGRN
  ENUM LTGRN
  ENUM DKBLU
  ENUM LTBLU
  ENUM DKRED
  ENUM CYAN
  ENUM MEDRED
  ENUM LTRED
  ENUM DKYEL
  ENUM LTYEL
  ENUM DKGRN
  ENUM MAGENTA
  ENUM GRAY
  ENUM WHT
DROP

\ =======================================
\ We use direct control of the sound chip
\ rather than sound lists and a player.
HEX

\ noise control words
: NOISE   ( n -- ) E0 OR SND! ; \ n selects the noise type

\ noise envelope control
: NOISE-DB   ( db --) F MIN F0 OR SND! ;
: NOISE-OFF  ( -- )   F NOISE-DB ;

HEX
: NOISE-UP    ( speed  -- ) 2  F  DO  I NOISE-DB  DUP MS   -1 +LOOP DROP ;
: NOISE-DOWN ( speed -- )   F  2  DO  I NOISE-DB  DUP MS     LOOP DROP NOISE-OFF ;

\ channel 1 sound control words

DECIMAL
: f(clk) ( -- d) 46324 1  ;   \ this is 111,860 as 32 bit int.

\ >FCODE re-arranges freq. value nibbles (4bits) for the TMS9919
HEX
: >FCODE   ( 0abc -- 0cab)    \ ASM would make this much faster
           DUP 0F AND SWAP      ( -- 000c 0abc)
           4 RSHIFT             ( -- 000c 00ab)
           SWAP ><  ( SWPB)     ( -- 00ab 0c00)
           + ;

: HZ>CODE  ( freq -- fcode )  f(clk) ROT UM/MOD NIP >FCODE 8000 OR  ;

\ *TRICKY STUFF*
\ Calculating the 9919 freq. code takes too long BUT we can convert frequency
\ to 9919 chip code at compile time then compile as 16 bit literal number
\ using this text MACRO
: [HZ] ( freq -- fcode ) S" HZ>CODE ] LITERAL" EVALUATE ;

\ sound channel #1 control words
: FREQ!    ( fcode -- ) SPLIT SND! SND! ;
: ]HZ      ( freq -- ) [HZ] POSTPONE FREQ! ;  \ pre-compiled fcode version
: HZ       ( freq -- )  HZ>CODE FREQ! ;       \ runtime calculation version
: DB       ( n -- )    90 OR SND! ;
: MUTE     ( -- )      9F SND! ;

DECIMAL
500 CONSTANT MAXLENGTH

\ x/y coordinate storage for the snake
CREATE SNAKE-X-HEAD  MAXLENGTH CELLS ALLOT
CREATE SNAKE-Y-HEAD  MAXLENGTH CELLS ALLOT

VARIABLE SPEED
VARIABLE PREY-X
VARIABLE PREY-Y
VARIABLE DIRECTION
VARIABLE LENGTH

0 CONSTANT LEFT
1 CONSTANT UP
2 CONSTANT RIGHT
3 CONSTANT DOWN

\ characters used
128 CONSTANT PREY
 42 CONSTANT SNAKE  ( body char)
136 CONSTANT HEAD  ( snake's head)
 30 CONSTANT BRICK

\ shape data for PREY, brick, mouse and snake chars
HEX
007E 6A56 6A56 7E00 PATTERN: CLAY
3C5E EBF7 EBDD 7E3C PATTERN: VIPER
183C 5AFF FFFF 7E3C PATTERN: UPHEAD
3C7E FFFF FF5A 3C18 PATTERN: DNHEAD
1C3E 5FFF FF5F 3E1C PATTERN: LHEAD
387C FAFF FFFA 7C38 PATTERN: RHEAD
0004 3E7B 7FFC 8270 PATTERN: MOUSE
0008 3F7B 7EFC 8270 PATTERN: MOUSE2 \ mouse looking up
84BE FB7F 3C42 0000 PATTERN: JUMPMS

\ get random x or y position within playable area
: RANDOM-X ( -- n ) C/L@  2-  RND 1+ ;
: RANDOM-Y ( -- n ) L/SCR 2-  RND 1+ ;

\ machine Forth macros make it easy to create fast arrays
: CELLS, ( n -- 2(n)  0A14 , ;  \ TOS  1 SLA, (mult. By 2)

: ()@,   ( addr -- )  C124 , ( addr) ,   \ addr(TOS) TOS MOV
;

: ()!,   ( addr -- )
          C936 , ( addr) ,  \ *SP+ ARRAY (TOS) MOV,
          C136 ,            \ TOS pop
;

\ snake coordinate arrays
CODE ]SNAKE-X@ ( index -- address )  CELLS, SNAKE-X-HEAD ()@,   NEXT, ENDCODE
CODE ]SNAKE-X! ( index -- address )  CELLS, SNAKE-X-HEAD ()!,   NEXT, ENDCODE

CODE ]SNAKE-Y@ ( index -- address )  CELLS, SNAKE-Y-HEAD ()@,   NEXT, ENDCODE
CODE ]SNAKE-Y! ( index -- address )  CELLS, SNAKE-Y-HEAD ()!,   NEXT, ENDCODE

\ : >VPOS  ( x y -- VADR) C/L@ * + ;  \ now in V2 kernel

: DRAW ( char X Y -- )  >VPOS  VC! ;

: DRAW-PREY ( -- ) PREY  PREY-X @ PREY-Y @  DRAW ;

DECIMAL
: DRAW-WALLS
      0  0 BRICK 31 HCHAR
      0  1 BRICK 22 VCHAR
     31  0 BRICK 24 VCHAR
      0 23 BRICK 31 HCHAR ;

: DRAW-SNAKE
     HEAD  SNAKE-X-HEAD @ SNAKE-Y-HEAD @ DRAW
     LENGTH @ 1
     DO
        SNAKE  I ]SNAKE-X@   I ]SNAKE-Y@   DRAW
     LOOP
     BL LENGTH @ ]SNAKE-X@  LENGTH @ ]SNAKE-Y@  DRAW ;

: PLACE-PREY ( y x -- ) PREY-X ! PREY-Y ! ;

: MOVE-UP     ( -- ) SNAKE-Y-HEAD 1-! ;
: MOVE-LEFT   ( -- ) SNAKE-X-HEAD 1-! ;
: MOVE-DOWN   ( -- ) SNAKE-Y-HEAD 1+! ;
: MOVE-RIGHT  ( -- ) SNAKE-X-HEAD 1+! ;

: LOOKUP      UPHEAD HEAD CHARDEF ;
: LOOKDN      DNHEAD HEAD CHARDEF ;
: LOOKLEFT    LHEAD  HEAD CHARDEF ;
: LOOKRIGHT   RHEAD  HEAD CHARDEF ;

: MOVE-SNAKE-HEAD ( direction  -- )
     DIRECTION @
     LEFT  OVER = IF LOOKLEFT MOVE-LEFT  ELSE
     UP    OVER = IF LOOKUP   MOVE-UP    ELSE
     RIGHT OVER = IF LOOKRIGHT MOVE-RIGHT ELSE
     DOWN  OVER = IF LOOKDN   MOVE-DOWN
     THEN THEN THEN THEN DROP ;

\ move each segment of the snake forward by one
 : MOVE-SNAKE-TAIL
     0 LENGTH @
     DO
        I ]SNAKE-X@ I 1+ ]SNAKE-X!
        I ]SNAKE-Y@ I 1+ ]SNAKE-Y!
     -1 +LOOP ;

HEX
: MOVE-SNAKE  (  -- )
              MOUSE2 PREY CHARDEF
              04 NOISE  06 NOISE-DB     \ soft white noise
              MOVE-SNAKE-TAIL 0A NOISE-DB
              MOVE-SNAKE-HEAD 04 NOISE-DB
              NOISE-OFF
              MOUSE PREY CHARDEF ;

DECIMAL
: HORIZONTAL? ( -- ?) DIRECTION @ DUP  LEFT = SWAP RIGHT = OR ;
: VERTICAL?   ( -- ?) DIRECTION @ DUP    UP = SWAP  DOWN = OR ;

: TURN-UP        HORIZONTAL? IF UP    DIRECTION ! THEN ;
: TURN-LEFT      VERTICAL?   IF LEFT  DIRECTION !  THEN ;
: TURN-DOWN      HORIZONTAL? IF DOWN  DIRECTION !  THEN ;
: TURN-RIGHT     VERTICAL?   IF RIGHT DIRECTION !  THEN ;

: ADJUST-DIRECTION ( key -- )
     [CHAR] S OVER = IF TURN-LEFT  ELSE
     [CHAR] E OVER = IF TURN-UP    ELSE
     [CHAR] D OVER = IF TURN-RIGHT ELSE
     [CHAR] X OVER = IF TURN-DOWN
     THEN THEN THEN THEN DROP ;

\ : ADJUST-DIRECTION ( joyst-key -- )
\      2 OVER = IF TURN-LEFT  ELSE
\      5 OVER = IF TURN-UP    ELSE
\      3 OVER = IF TURN-RIGHT ELSE
\      0 OVER = IF TURN-DOWN
\     THEN THEN THEN THEN DROP ;

\ read key is also the delay loop since KSCAN takes 1.1 mS
\ much more responsive to keys than a delay loop
HEX
: READ-KEY  ( -- char | 0)
        0 83C8 !
        FALSE KEY? IF DROP 8375 C@ THEN  ;  \ read GPL key buffer 8375

DECIMAL
\ : CHECK-INPUT  ( -- ) READ-KEY ADJUST-DIRECTION ;

: SWOOSH      ( -- )
      NOISE-OFF
      5 NOISE
      8 NOISE-UP
      20 NOISE-DOWN ;

: NEW-PREY
     SWOOSH
     BL PREY-X @ PREY-Y @ DRAW
     RANDOM-Y RANDOM-X PLACE-PREY
     DRAW-PREY ;

: GROW-SNAKE  ( -- ) LENGTH 1+! ;

: DEAD-SNAKE  ( -- )
              NOISE-OFF
              SNAKE SET#  DUP LTYEL 1 COLOR
              250 MS
              DKBLU 1 COLOR ;

: HAPPY-SNAKE ( -- )
              [ SNAKE SET# ] LITERAL
              12 4
              DO
                DUP I 1 COLOR
                40 MS
              LOOP
     ( -- 5)  DKGRN 1 COLOR ;

DECIMAL
: DECAY        ( n -- ) 16 0 DO  I DB  DUP MS LOOP DROP ;

: SQUEAK      ( -- )
               NOISE-OFF
               [ 3800 ]HZ 0 DB  45 MS  \ pre-computed freq. are faster
               6 DB  25 MS
               [ 3500 ]HZ 75 MS
                8 DB 25 MS
               [ 1300 ]HZ
               11 DB 25 MS
               [ 800 ]HZ
               MUTE ;
DECIMAL
: SCARED-PREY ( -- )
              JUMPMS PREY CHARDEF
             [ PREY SET# ] LITERAL  DUP DKRED 1 COLOR
              SQUEAK
              GRAY 1 COLOR
              MOUSE PREY CHARDEF ;

: FASTER      SPEED @ 1-  1 MAX SPEED ! ;

: CHECK-PREY
     SNAKE-X-HEAD @ PREY-X @ =
     SNAKE-Y-HEAD @ PREY-Y @ =  AND
     IF
        SCARED-PREY
        HAPPY-SNAKE
        GROW-SNAKE
        FASTER
        NEW-PREY
     THEN ;

: COLLISION? ( -- ? )
     SNAKE-X-HEAD @ SNAKE-Y-HEAD @ >VPOS VC@  BL <> ;

\ utility words for menus
: WAIT-KEY   BEGIN KEY? UNTIL ;
: AT"        POSTPONE AT-XY  POSTPONE ." ;  IMMEDIATE

: INITIALIZE-SNAKE
      4 DUP
      LENGTH !
      1+ 0
      DO
         12 I - I ]SNAKE-X!
         12 I ]SNAKE-Y!
      LOOP
      RIGHT DIRECTION !  ;

: INITIALIZE
     PAGE  LTGRN SCREEN

     MOUSE PREY  CHARDEF    PREY  SET#  GRAY  TRANS COLOR
     CLAY  BRICK CHARDEF    BRICK SET#  LTRED TRANS COLOR
     VIPER SNAKE CHARDEF    SNAKE SET#  DKGRN TRANS COLOR
     RHEAD HEAD  CHARDEF    HEAD  SET#  DKYEL TRANS COLOR

     DRAW-WALLS
     INITIALIZE-SNAKE
     RANDOM-Y RANDOM-X PLACE-PREY
     25 SPEED !  ;


: PLAY ( -- )
       BEGIN
          DRAW-SNAKE
          DRAW-PREY
          SPEED @ 0
          DO
            READ-KEY
            ADJUST-DIRECTION
          LOOP
          MOVE-SNAKE
          CHECK-PREY
          COLLISION?
       UNTIL
       HONK 12 10 AT" GAME OVER"
       HONK
       DEAD-SNAKE ;

DECIMAL
: TITLE  ( -- )
       GRAPHICS
       5  5 AT" THE SNAKE"
       5  7 AT" Use the E,S,D,X keys"
       5  8 AT" to move the snake
       5  9 AT" and catch the mouse."
       5 12 AT" The more he eats,
       5 13 AT" the faster he goes!"
       5 20 AT" Press any key to begin..."
       WAIT-KEY ;

: RUN ( -- )
      TITLE
      BEGIN
         INITIALIZE
         PLAY
         5 11 AT" Your snake was " LENGTH @ . ." Ft. long"
         5 11 AT" Press ENTER to play again"
         KEY 13 <>
      UNTIL
      NOISE-OFF
      8 20 AT" Ssssssee you later!"
      1500 MS
      BYE ;

HERE SWAP - . .( bytes)

Edit updated version. Fixed a text bug on exit screen.

Edited April 27, 2019 by TheBF

+Lee Stewart · April 27, 2019

GDMike showed us a screen full of character definitions he is working on in Turbo Forth in the thread Mystified by the input command.

Here is some code that I use that looks like it will work in Turbo Forth with small tweaks.

It reads the default character patterns from GROM and puts them back into the pattern table in VDP RAM.

Someone will notice that I did not properly search for the pattern table entry GROM but used "dead reckoning" using the actual address.

If I ever change my internal GROMS to an updated version I will be sure and fix this. :-)

Two things to change for TurboForth that I can see:

Replace VC! with V! ( V! in CAMEL99 Forth stores 16 bits)

Check the word ]PDT and replace 800 with the TurboForth pattern descriptor table address

You will need to define the word SPLIT which is : SPLIT DUP 0FF AND SWAP FF00 AND 4 RSHIFT ; *EDIT

You could use this method to create patterns above ASCII 127 by adding $100 to as shown in the comments (untested)
\ CHARSET restores TI-99 default characters from GROM

\ GROM Character Sets           Address  ASCII Codes  Bytes/Char
\ ----------------------------  -------  -----------  ----------
\ Large caps                     04B4h     32   95      8
\ Normal Capitals                06B4h     32   95      7
\ Lowercase                      087Bh     96  126      7

HEX
\ 9800 CONSTANT GRMRD ( GROM base)   \ GROM read byte
\ 9802 CONSTANT GRMRA                \ GROM set read address

\ 9C00 CONSTANT GRMWD                \ GROM write byte
\ 9C02 CONSTANT GRMWA                \ GROM set write address
HEX
: GROM   ( addr -- ) SPLIT 9C02 C! 9C02 C! ;     \ set the GROM address)
: GC@+   ( -- c)     9800 C@ ;                   \ read & auto-increment address)
: ]PDT   ( char# -- 'pdt[n] )  8* 800 + ;        \ VDP pattern Descriptor table
: ]GFONT ( ascii -- grom_adr)  BL -  7 * 6B4 + ; \ GROM array of TIFont data

\ transfer directly from GROM to VDP
: GVMOVE  ( grom_addr vdp_addr cnt -- )
          ROT GROM   BOUNDS DO  GC@+ I VC!  LOOP ;

: CHARSET ( -- )
        [CHAR] ~ 1+  BL                \ all ASCII chars
        DO
           I ]GFONT                     \ get GROM address for char I
           I ]PDT                       \ get PDT address for char I
\          I 100 + ]PDT                 \ this will write patterns above ASCII chars
           0 OVER VC!                   \ store 1st zero in VDP
           1+                           \ inc PDT address
           7 GVMOVE                     \ write 7 bytes GROM->VDP
        LOOP ;

\ BONUS WORD: loads the TITLE screen font from GROM
 : BIGCAPS  ( -- ) 4B4 900 200 GVMOVE ;  \ TI title page fonts

\ move data from GROM to CPU RAM
\ : GCMOVE  ( grom addr cnt -- ) ROT GROM  BOUNDS DO  GC@+ I C!  LOOP  ;
 

SPLIT for Camel99 Forth should be

HEX
: SPLIT  DUP 0FF AND SWAP FF00 AND 8 RSHIFT ;

which for TurboForth would be

: SPLIT  DUP $0FF AND SWAP $FF00 AND 8 >> ;

or perhaps better, using >< (swap bytes),

: SPLIT  DUP $0FF AND SWAP $FF00 AND >< ;

...lee

+TheBF · April 27, 2019

Using Classic99's cool Build function I have saved a SNAKE game as two EA5 files.

It's not fancy but as it speeds up I can't get past a snake of 30 "ft". :woozy:

Update after Tursi and Mizapf found my bugs for me.

This verison is built on CAMEL99X which does not use the 9901 timer and so will run current verisons of Class99.

I got it to 35 ft but after that I lose control.

TISNAKE2.ZIP

Edited April 29, 2019 by TheBF

Tursi · April 28, 2019

I tried this in Classic99 from Editor/Assembler and it worked fine until I got a mouse or bit my own tail, then it just hung on the sound effect. Do I need a different runtime environment?

Camel99 Forth Information goes here

Recommended Posts

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Join the conversation

Recently Browsing 0 members