Jump to content

Camel99 Forth Information goes here

Recommended Posts

Yeah, I believe his colors represent what's going on at the moment kinda thing. As, compiled words are a color, remarks are a color, etc...

I just thought it gives something extra to the OS that, I believe, for newbies would be a visual aid.

Me, I just see red, error!!!!!

  • Like 1

Share this post

Link to post
Share on other sites
1 hour ago, TheBF said:

It would be trival to compile a new kernel that boots in Graphics mode if you want one. That would not give you COLOR Forth however.

The compiler loop must be changed to read the color of the text to determine what's going on in the code. Not really hard to do but it will require that I understand what COLOR Forth actually does.  :)   I think we would need to add some magic key code as well to control the text color.  Chuck originally developed Color Forth to use a 3 button mouse as the keyboard enhancement and he memorize the binary codes for 0 to 7 to control colors (It was something like that. I don't remember the exact detail)


Definitely need to grok the details, but, if it requires changing letters to any arbitrary color, Graphics mode cannot do that. Changing the color of any letter affects all 8 contiguous characters of the character set of which that character is a member.



  • Like 1

Share this post

Link to post
Share on other sites

Good point.


So a solution might be to create new fonts that are in contiguous color sets and then convert from ASCII to the new values when displaying to the screen.

I saw this kind of thing in XB256 project I think.  I assume this is how they got 6 upper case fonts in different colors. (?)


Total pain in the tushy to code it up but it might work... eventually :) 


  • Like 2

Share this post

Link to post
Share on other sites
1 hour ago, GDMike said:

Or, just thinking out loud, setting a color of a space character preceding the word. 

Yes, but that would be GDColorForth. :)


  • Haha 1

Share this post

Link to post
Share on other sites

Multi-User Platform Concept Test on TI-99 with SAMS


It works!  

I modified my multi-tasking file MTASK99 to make a multi-user version and it actually works.

It uses a partial memory swapper for the HI RAM from B000...FFFF.

The second process starts its own local Forth dictionary at B000 by default.

The second process has it's workspace in a shared block of memory at >2000 at this time. 


The test code is simply filling memory in the 2nd process at various address BUT it is NOT colliding with the primary Forth task because the context switcher is paging SAMS memory in and out for each context switch. :) 


The new word added is PROCESS:  ( map[] -- )   which needs the address of the MAP array. PROCESS: makes a 256 byte workspace for each new process, sets the local MEM variable to the array address and sets the local dictionary pointer to >B000.  This means the local process can compile code from B000 to FF00 and has it's own local terminal input buffer at FF00.  


It's a good beginning.  :) 

I made a video on my phone of this running, but it is 47Mbytes so I won't upload it. You will have to take my word for it.


Code for the second process.  Note:  MS below is passing control back to Forth while it waits. 

\ mtask demo



: PROCTEST  \ write to local memory pages
           100 0
              B000 100 I FILL  100 MS
              C000 100 I FILL  100 MS
              D000 100 I FILL  100 MS
         AGAIN ;



New MUSER99 file:

\ MUSER99.HSF for CAMEL99                       16AUG2020 Brian Fox
\ Multi-user system for SAMS Memory Card


\ Each task has a Process ID (PID)
\ In this system we use the workspace address as the PID
\ Each task swaps out HEX B000..FFFF for a task
CODE MYSELF  ( -- pid)
     0646 , \    *SP DECT,  ( make room on stack)
     C584 , \ TOS *SP MOV,  ( push TOS reg.)
     02A4 , \    TOS STWP,  (fetch the cpu WP register to Forth TOS)

MYSELF CONSTANT USER0    \ USER0 is the main Forth task workspace (>8300)

\ Extended "workspace" is 256 BYTES (>100)
\ Each workspace includes registers, user variables
\ the data stack & return stack.

\ name the CPU register addresses in a task's workspace
  12 USER 'SP             \ the task's Forth SP register ( R6)
  14 USER 'RP             \ the task's Forth RP register ( R7)
  18 USER 'IP             \ the task's Forth IP register ( R8)
  20 USER 'R10            \ address of R10 (holds the NEXT routine)

\ rename registers 13,14,15, used by RTWP to change context
  26 USER TLINK           \ R13 = next task's wksp
  28 USER TPC             \ R14 = next task's program counter
  30 USER TST             \ R15 = next task's status register

\ SAMS memory manager starts at page >FF. allocation decrements
VARIABLE MP  FF00  MP !  \ 1st SAMS page = >FF

\ Compile next SAMS page into array, decrement Memory pointer MP
: SAMS,    MP @ DUP ,   0100 - MP !  ;

\ create map arrays for 3 users
CREATE MAP0  0B00 , 0C00 , 0D00 , 0E00 , 0F00 , \ pass through values

\ each user has a variable that points to their MAP array
  6E USER MEM      MAP0 MEM !   \ pass thru pages are default

CREATE 'YIELD \ *this is the context switcher
\ Address of TSTAT is loaded into R14 of every task. ie program counter)
         RTWP,                \ change tasks! 1 instruction
( TSTAT) R1 STWP,             \ get our workspace -> R1
         20 R1 () R0 MOV,     \ fetch TFLAG->R0
     NE UNTIL,               \ if tflag=0 jmp to RTWP
     6E R1 ()  R2 MOV,       \ get MEM map array -> R2
     R12 1E00  LI,
     0 SBO,             \ card on
     R0  4016  LI,      \ HI ram SAMS register for B000
     R2 *+  R0 *+ MOV,  \ MAP B000
     R2 *+  R0 *+ MOV,  \ MAP C000
     R2 *+  R0 *+ MOV,  \ MAP D000
     R2 *+  R0 *+ MOV,  \ MAP E000
     R2 *+  R0 ** MOV,  \ MAP F000
     0 SBZ,             \ card off
     NEXT,              \ run Forth

'YIELD CELL+ CONSTANT 'TSTAT  \ record tstat address as constant

 'R10 @ CONSTANT 'NEXT      \ R10 has the address of Forth NEXT

.( ..)
\ PID = process ID.  It is the address of the task's user area memory block
: LOCAL    ( PID uvar -- addr' ) MYSELF - + ;     \ get a task's user var.
: SLEEP    ( PID -- ) FALSE SWAP TFLAG LOCAL ! ;  \ put PID to sleep
: WAKE     ( PID -- ) TRUE  SWAP TFLAG LOCAL ! ;  \ wake up PID

\ turn multi-tasking on or off by changing the CODE address in PAUSE
: SINGLE   ( -- ) 'NEXT  ['] PAUSE ! ;  \ disable multi-tasking
: MULTI    ( -- ) 'YIELD ['] PAUSE ! ;  \ enable multi-tasking.

( *** YOU  M U S T  use INIT-MULTI before multi-tasking ***)
: INIT-MULTI ( -- )
        MYSELF TLINK !    \ Set my TLINK to my own Workspace
       'TSTAT TPC !       \ set my task PC register to TSTAT
        MYSELF WAKE  ;    \ mark myself awake

\ - copy the the calling task's USER area into a new workspace.
\ - SET both stack addresses to the proper registers in the user area,
\ - insert PID into the round-robin list
\ - your program needs to allocate USIZE bytes in heap
\ - the address of your memory block will become the PID.

: FORK ( PID -- )
       DUP >R                               \ copy PID to RSTACK
      ( PID) USIZE 0 FILL                   \ erase new task block
       MYSELF [email protected] USIZE CMOVE                \ copy myself to the new task

       [email protected] USIZE +  ( addr )                 \ calc. end of task block
       DUP [email protected] 'RP LOCAL !                   \ dup & store in local RP
     ( RPaddr) 22 CELLS -                   \ calc. Pstack addr
       [email protected] 'SP LOCAL !                       \ store in local SP register

\ insert this task into round-robin list of tasks
       TLINK @                 ( -- link)   \ get round-robin link
       [email protected] TLINK !                           \ replace with addr of new task
       [email protected] TLINK LOCAL !                     \ store copy in new task's tlink
       R> SLEEP ;                           \ mark this new task as asleep

.( ..)
: JOB->IP ( xt pid -- xt pid)     \ XT -> task's IP register

: ASSIGN ( xt pid -- )
       JOB->IP  JOB LOCAL ! ; \ store the XT in the PID's JOB user var.

: RESTART ( pid -- )
       DUP USIZE +  OVER 'RP LOCAL !  \ reset local Rstack
       WAKE ;                         \ pid wake

\ overwrite these commands for mulit-tasking
: COLD  ( -- ) SINGLE  COLD ;  \ stop multi-tasker before quitting Forth
: BYE   ( -- ) SINGLE  BYE ;

: PROCESS: ( map[] -- )
          USIZE MALLOC  ( -- workspace )
          DUP FORK                 \ copy current workspace
          SWAP OVER MEM LOCAL !    \ set local MEM to map array
          B000 OVER DP LOCAL !     \ set local dictionary pointer to B000
          CONSTANT ;               \ name this workspace

CR .( Multi-tasker initialized)





  • Like 3
  • Thanks 1

Share this post

Link to post
Share on other sites

Higher Order Function (HOF) for Files


A concept of some high level languages is the ability to MAP some computer operation across an entire array of data.

While working on ED99 I found an error in my save-file routine.  The save and load file code is completely different.

I decided to see if I could use the same loop of code for all file operations and that way remove this kind of error.


The method is to use a common loop to scan through a file and use a DEFER word to perform the action.

The action can be passed to the common loop as a parameter.  So far it is working to perform the read a file into SAMS and to interpret a file like the config file.

Saving may break the mold because I have to open the file in write mode but this looks promising



DEFER MAPACTION     \ what to do with each file record

: MAPFILE ( addr len XT -- ) \ perform XT on all records in file
       PAD DUP 80 [email protected] READ-LINE ?FILERR ( -- pad len ?)
       MAPACTION   \ perform on every record

: STORE_REC ( addr len -- )
       LASTLINE 1+! ;

: LOADDV80 ( addr len -- )

: EVAL_REC  ( addr len -- ) EVALUATE   LINES 1+! ;

.( .)
 : LOADFILE ( addr len -- ) \ interprets the ED99CONFIG file
     ['] EVAL_REC  MAPFILE ;



  • Like 1

Share this post

Link to post
Share on other sites



I was reading a thread in comp.lang.forth about these words and discovered that a lot of people don't bother implementing the most formal interpretation of these words for small systems.

By formal I mean something that would allow allocation, freeing and resizing memory blocks in such a way that there would never be fragmentation. This requires a way to read all the allocations either in a table or as a linked list so you can examine the state of each allocation.


However if you don't need all that it becomes quite simple to make simple system that does the same job with the caveat that you have a more static allocation process which is more in line with Forth thinking.

So instead of a full implementation that takes 768 bytes.  Here is one that takes 118 bytes. :)  In fact if you remove the luxury of remembering the size of an allocation it would be even smaller.

This version includes the word SIZE which seems to be commonly written by others.

The Forth variable H is initialized to >2000 when Camel99 Forth starts and is used a the HEAP pointer for the lower 8K RAM.

To reset the heap you would use  HEX 2000 H !  in Forth or make a word to do it.

\ Minimal ALLOCATE FREE RESIZE for Camel99 Forth B Fox Sept 3 2020
\ Mostly Static allocation
: HEAP,    ( n --) H @ !  [ 1 CELLS ] LITERAL  H +! ;
: ALLOCATE ( n -- addr ?) DUP HEAP, H @   SWAP H +!  FALSE ;
: SIZE     ( addr -- n) 2- @ ; \ not ANS/ISO commonly found
\ *warning* FREE removes everything above it as well
: FREE     ( addr -- ?) 2- DUP OFF  H ! FALSE ;
\ *warning* RESIZE will fragment the HEAP
: RESIZE   ( n addr -- addr ?) DROP ALLOCATE ;


Usage would typically be something like this:

\ protection and syntax sugar
 : ?ALLOC ( ? --) ABORT" Allocate error" ;
 : ->     ( -- addr ?) ?ALLOC  POSTPONE TO ; IMMEDIATE

\ define the variables during compiling

    50 ALLOCATE -> X
    50 ALLOCATE -> Y
    .... PROGRAM continues


  • Like 2

Share this post

Link to post
Share on other sites

In my efforts to speed up erasing SAMS memory for ED99 I came up with a variation on the Forth word FILL.  FILL16 copies the character argument to both sides of a register and writes two bytes at once. 

It will always write an even number of bytes but that it good for erasing 4K pages.  It allows me to erase 64K of SAMS pages in under 1 second, about 2X faster than using standard Forth FILL.


\ FILL16 fills even number of bytes a CELL at a time

CODE FILL16   ( addr cnt char -- )
\ copy char into both bytes of TOS register
             TOS R0 MOV,      \ dup the char
             R0 SWPB,         \ move to other byte
             R0 TOS SOC,      \ OR both bytes into TOS

\ compute even number of loops
            *SP+ R0 MOV,       \ pop cnt->R0
             R0  INC,          \ inc by one
             R0  1 SRA,        \ divide cnt by 2
\ do the filling...
            *SP+ R1 MOV,       \ pop addr->R1
                TOS R1 *+ MOV, \ 2 chars are in TOS register
                R0 DEC,        \ decr. count
             EQ UNTIL,         \ loop until r0=0
             TOS POP,          \ refill the TOS register


  • Like 3

Share this post

Link to post
Share on other sites

My new IDE card forced me to take a look at my DSR routine. I have never been totally happy with it. It's not nicely structured code and it uses three variables that had questionable value IMHO. :)

Anyway I wanted to be sure it could see a card at CRU address >1000.

While there I of course got distracted with the parts I didn't like and took a run at it. It still seems to work and I saved another 30 bytes!


One day I will stop doing all that @!#$!$ text comparisons for the file name. They should be done once before entering the DSR and the "real" PAB address at the '.' should recorded for re-use for that PAB.

One day...


I have yet to try calling this DSRLINK with the 'A" parameter so more work to do.


In the meantime here is how it looks written in CROSS-ASSEMBLER. 

[cc] means use the cross-compiler vocabulary.  [tc] means use the target compiler vocabulary. 

[cc] allows me to use the host computer's interpreter for calculations and control commands

[tc] compiles code into the memory image used for the TI-99.


\ DSRLNKT.HSF for XFC99 cross-compiler/Assembler  12Apr2019 B. Fox
\ 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

\ Changes 12Apr2019
\ - Changed some jumps to structured loops & IF/THEN
\ - ADD GPL error byte to error code on Forth TOS
\ - Removed GPLSTAT constant from kernel, made an Equate here
\ - saved 44 bytes!!

\ Changes 17Sep2020
\ - Changed search to begin at CRU address >1000
\ - Moved NAMBUF to memory below DSR WORKSPACE in high RAM
\ - Removed H1000,H2000,CYC1 variables.
\ - Removed setting R13 EQ bit. Not used in Forth
\ - Changed card search to use a while loop
\ - saved 30 bytes


\ 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:

\ MACROS to simplify the code
: VDPWA, ( reg -- )
                   0 LIMI,   \ disable interrupts
       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

RP0 80 -      EQU DREGS    \ memory below Forth RETURN stack is DSR workspace
DREGS 5 2* +  EQU DREG(5)  \ compute address of DREGS register 5
DREGS 6 -     EQU NAMBUF   \ 6 byte buffer below DREGS workspace

l: HEX20   20 BYTE,
l: '.'     2E BYTE,      \ Forth can use any chars for labels :)

l: DSR1                     \ dsr entry
      *R14+     R5  MOV,    \ fetch '8' from program->R5, auto inc PC 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,   \ read length of FNAME -> R1

\ setup to copy VDP FNAME ->namebuf up to '.' character
       R1       R3  MOVB,   \ DUP length byte to R3
       R3       08  SRL,    \ swap the byte to other side
       R4           SETO,   \ R4 = -1
       R2   NAMBUF  LI,     \ R2 is ^namebuf
         R0            INC,    \ point to next fname VDP address
         R4            INC,    \ counter starts at -1
         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   '.' @@  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,     \ GPL R1 returns error
       R12 R12 MOV,
       NE IF,
         00 SBZ,             \ turn off any card selected now
\ scan for I/O cards
       R12     1000 LI,      \ init CRU base to 1st card address
@@A:   BEGIN,                \ card activation...
          R12  83D0 @@ MOV,  \ save card CRU in magic address
          00           SBO,  \ turn on the card
          R2   4000    LI,   \ Card ROM addr -> R2
         *R2  HEXAA @@ CMPB, \ test for card ID byte "AA"
       NE WHILE,             \ loop until card is found
          00 SBZ,            \ turn off the card
          83D0 @@      CLR,  \ erase magic address
          R12    0100  ADDI, \ advance CRU to next card
          R12    2000  CMPI, \ last card?
          @@5          JEQ,  \ YES goto error handler
       DREG(5) @@ R2 ADD,    \ add '8'+4000= >4008 DSR ROM list
       @@B           JMP,

@@3: \ scan ROM linked list for code address
           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
         R6   NAMBUF  LI,      \ R6 hold ^nambuf
           *R6+ *R2+ CMPB,     \ compare namebuf to ROM string
            @@3        JNE,    \ if mismatch goto @@3
            R5         DEC,    \ dec the counter register
         EQ UNTIL,
\ --- run DSR code ---
@@4:     R1       INC,         \ count entries into the DSR ?
        *R9       BL,          \ call the DSR code
     AGAIN,                    \ try next card
\ -- DSR returns here if we are done (uses R11 INCT technique)
     00            SBZ,        \ Turn off the card
\ ==== DSR Workspace ====
     DREGS         LWPI,
     R9           VDPWA,       \ set vdp address
     VDPRD @@  R1  MOVB,       \ read error value to DREGS R1
     R1 0D         SRL,        \ shift error to correct range
     NE IF,                    \ if an error is detected
@@5:        DREGS         LWPI,  \ restore DREGS workspace
@@6:      \ device length =0
@@8:      \ device length >7
            R1            SETO,  \ I use -1 for device not found
            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,
    TOS GPLSTAT @@ MOVB,   \ clear GPL status register
           DLNK @@ BLWP,
                 8 DATA,   \ Offset to DSR linked list in card ROM



  • Like 1

Share this post

Link to post
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

Reply to this topic...

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

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

×   Your previous content has been restored.   Clear editor

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


  • Recently Browsing   0 members

    No registered users viewing this page.

  • Create New...