Utilities

\ ************************************************
\ Utility words for FlashForth 4.8
\ MJM 9/17/12, 7/14/13
\ MJM 11/1/13
\ Some by Mike Miller 
\ Some by Mikael Nordman, mod by MJM
\ www.moonvalleycircuits.com
\ ************************************************

fl+   \ allow flash writes
decimal
utilwords
marker utilwords

hex
: 4+ ( n --- n+4 )
  4 + ;

: fcon \ make constant in flash that can be written
  flash create , 
  does> @ ; 
\ to write: <value> ' <name> 4+ !

: f2con \ make 2constant in flash that can be written
  flash create swap , ,
  does> 2@ ;
\ to write: <dvalue> ' <name> 4+ 2!

: fcon! ( n, cfa --- ) \ write flash constant
  fl+  4+ !  iflush  fl- ;

: f2con! ( d, cfa --- ) \ write flash 2constant
  fl+  4+ 2!  iflush fl- ;

: fcmove ( addr1 faddr2 u -- ) \ cmove into flash
  fl+  cmove  iflush fl-  ;

: ?  ( addr -- )
  @ . ;

: u? ( addr -- )
  @ u.  ;

: c? ( addr -- )
  c@ . ;

: 0! ( addr -- )
  0 swap ! ;

: off ( addr -- ) \ set addr false
  0 swap ! ;

: on ( addr -- ) \ set addr true
  true swap ! ;

: pick ( xu ... x0 u -- xu ... x0 xu) 
  2* 2+ sp@ swap - @ ;

: ?dup ( n -- n, n; or-- 0 )   \ dup if not zero
  dup  if   dup   then ;

: boolean ( n --- f ) \ convert number to boolean flag
  0= 0= ;

: nop ;

: 4* ( n --- 4n )
 2* 2* ;

: 4/ ( n --- n\4 )
 2/ 2/ ;

: 2swap ( d1, d2 -- d2, d1 )
  rot >r  rot r> ;

: scale ( b, n --- b \ scale b by 2^n)
  dup 0<
  if
     abs for 2/ next
   else
     for 2* next
  then ;

: depth ( --- n ) \ depth of stack
  sp@ s0 @ - 2/ ;

: needed ( .., n --- )
  depth 1-
  1+ < 0=
  if
    ." not enough stack items" abort
  then ;

hex
: combine ( l, h --- n |combine two bytes into words)
   100 * + ;

: split ( n --- l, h |split word int high & low bytes)
   100 /mod ;

: >< ( n --- n | byte-swap 16 bitt number)
  split swap combine ;

: >w@< ( addr -- n | sign-extended fetch)
  w@ dup 7fff > if ffff0000 + then ;

: wconvert ( addr --- | flips word at addr)
  dup w@ >< swap w! ;
decimal

: u- ( u1, u2 --- u | u1-u2 )
 dup 0< 2 pick 0< not and if swap then - ;
 swap if u2 is negative but u1 is not
: u-  - ;

: -dump ( addr -- )   \ dump before, after addr
  $10 - $40 dump ;

: hdump ( addr -- )   \ hex dump before, after addr
  base @ swap  hex -dump base ! ;

: count ( addr -- addr+1, count )  \ Get count & address of counted string
  c@+ ; \  dup 1+   swap c@  ;

: -count ( addr+1, count, --- addr )  \ Get staddr from count & address in RAM
  over 1- c! 1- ;

: #>str  ( d -- addr, cnt )   \ simple number to string & sign
  tuck dabs  <# #s  rot sign  #>  ;

: #st1  ( d -- addr, cnt )   \  number to string w/ one dp & sign
  tuck dabs  <#   #  [char] . hold  #s  rot sign  #>  ;

: #st2  ( d -- addr, cnt )   \  number to string w/ two dp & sign
  tuck dabs  <#   #  #  [char] . hold  #s  rot sign  #>  ;

: #st3  ( d -- addr, cnt )   \  number to string w/ three dp & sign
  tuck dabs  <#   #  #  # [char] . hold  #s  rot sign  #>  ;

: $>$  ( saddr, daddr --- )  \  move counted string
  over c@ 1+ cmove ;

: $comp ( saddr1, saddr2, -- f ) \ compare counted strings, ft if equal
  !p>r true swap dup c@ 1+              \ saddr2>p, --- ft, saddr1+1, count
  for
     c@+ pc@ =                          \ compare chr
     p+
     rot and swap                       \ AND flag
  next 
  drop r>p  ;

: strcat ( straddr1, count1, straddr2, count2 --- straddr1, count )
\ concatenate strings           \ straddr1 must be in RAM
  >r >r                         \ -- straddr1, count1   R-- count2, straddr2
  2dup + r> swap r@ cmove       \ -- straddr1, count1  R-- count2 
  r> + 
  over 1- over swap c! ;        \ store new count in case we concatenate again

variable dpl   \ decimal point location for (number), number

: (number) ( d1 addr1 --- d2 addr2 ) \ similar to FIG
\ Run-time routine of number conversion.   Convert an ASCII text beginning at
\ addr1+ according to BASE.   The result is accumulated with d1 to become d2.
\ addr2 is the address of the first unconvertable digit.  

  begin
        1+ dup >r       \ save addr1+1, address of the first digit, on return stack.
        c@              \ get a digit
        digit?          \ A primitive.  ( c n1 -- n2 tf or nx ff )
                        \ Convert the character c according to base to a binary
                        \ number n2 with a true flag on top of stack.  
  while                 \ successful conversion, accumulate into d1.
        swap            \ get the high order part of d1 to the top.
        base @ um*      \ multiply by base value
        drop            \ drop the high order part of the product
        rot             \ move the low order part of d1 to top of stack
        base @ um*      \ multiply by base value
        d+              \ accumulate result into d1
        p+              \ inc conversion flag
        dpl @ 1+        \ see if dpl is other than -1
        if              \ DPL is not -1, a decimal point was encountered
           1 dpl +!     \ Increment DPL, one more digit to right of decimal point
        then
        r>              \ Pop addr1+1 back to convert the next digit.
  repeat                \ If an invalid digit was found, exit the loop here. Otherwise
                        \ repeat the conversion until the string is exhausted.
  drop r>  ;            \ Pop return stack which contains the address of the first
                        \ non-convertable digit, addr2.

: number ( addr -- d, n or ff ) \ Fig style number, with thanks to C. H. Ting
\ Convert counted character string at addr to signed double integer number,
\ using the current base.  If  a decimal point is encountered
\ in the text, its position will  be given in DPL, number of digits is in
\ the conversion  flag.  
\ String must have a trailing (unconvertible) chr
  0 !p>r        \ conversion flag
  0 0 rot       \ push two zero's on stack as the initial value of d .
  dup 1+ c@     \ get the first digit
  $2d =         \ is it a - sign?
  dup >r        \ Save the sign flag on return stack.
  negate +      \ If the first digit is -, the flag is 1, and addr+1 points to
                \ the second digit.  If the first digit is not -, the flag is 0.
                \ addr+0 remains the same, pointing to the first digit.
  -1            \ The initial value of DPL
  begin         \ Start the conversion process
     dpl !      \ Store the decimal point counter
     (number)   \ Convert one digit after another until an invalid char occurs.
                \ Result is accumulated into d .
     dup c@     \ fetch the invalid digit
     $2e =      \ is it "."
  while         \ it is a decimal point
    0           \ A decimal point was found.  Set DPL to 0
  repeat        \ exit here if non-convertible chr found,  otherwise repeat the
                \ conversion process.
  drop          \ discard addr on stack
  r>            \ pop the flag of - sign back
  if dnegate    \ negate d if the first digit is a - sign.
  then          \ All done.  A double integer is on stack.
  @p r>p        \ conversion count on stack
  dup 0= 
  if nip nip then ; \ drop double in no digits

create stringbuff  ( -- addr )  #40 allot   \ a convenient string buffer

: get stringbuff 1+ #40 accept stringbuff c! ; \ accept following text to buffer

\ *******************************************************************
\ Copied from jt.txt by Mikael Nordman 
\
\ create an execution table with n entries
\ each entry consists of 'nn' cell sized comparison value
\ and 'an' the address of the corresponding word to be executed.
\ At least two entries must be provided, the last one beeing the
\ default action.
\ mod 5/12/13 MJM

: jte nip cell+ @ex ;

: jt ( an nn n -- ) \ compile an execution table
     ( m -- )       \ execute aword corresponding to m
  flash                \ MJM
  create
  dup 1- ,             \ store the table size
  for
    , ,                \ store an entry
  next
  ram                  \ MJM
  does>                \ m addr 
  dup @                \ m a n
  for
    cell+
    2dup @ =           \ m a flag
    if
      \ a match was found
      jte rdrop exit
    then
    cell+             \ m a
  next
  \ Execute the default action.
  cell+ jte
;
ram

: tx2out  ['] tx2 r0 2+ ! ;      \ Set task EMIT vector to TX2 for debug

\ LMI WinForth structure words by MJM 12/14/94
\ emulate CSI Mac Forth
\ adapted to Flash Forth 5/10/13 MJM
\ Last Revision: 5/28/13  01:06:59 PM  MJM

\ macforth structures

variable evenstructures
evenstructures on

: =cells
  evenstructures @
  if 1+ -2 and then ;

: field ( n1 -- )
  create ,    \ w, w@ if 32 bit
  does> @ + ; ( n2 -- n1+n2)

: :aligned
  2  needed
  swap =cells swap over field + ;

: struct:
  :aligned ;

: :member
  2 needed
  over field + ;

: byte:
  1 :member ;

: bytes:
  :member ;

: string:
  bytes: ;

: short:
  2 :aligned ;

: shorts:
  2 * :aligned ;

: long:
  4 :aligned ;

: longs:
  4 * :aligned ;

: structure
  flash
  create here  0 , 0 ( --- here, 0 )
  does> @ ; ( --- n )

: structure.end
  2 needed 
  =cells swap !
  ram ;

\ Structure example:
structure t&drecord     \ time & date
byte:           +year
byte:           +month
byte:           +day
byte:           +hours
byte:           +minutes
byte:           +seconds
structure.end

create t&d t&drecord 4 * allot   \ create a structure with 4 time & date records

: @minute ( record --- minutes)  \ fetch minutes from record 0 - 3
  t&drecord *
  t&d +                          \ beginning of desired t&d record
  +minutes c@ ;

[Mike Miller]

Mike Miller