Test programs and Examples

Definitions above the kernel (wfroth.wft)

This chapter presents the listing of the file wfroth.wft which contains many forth definitions defined above the kernel..

Last update:	7-February-1999
State (estimation)	55%

---

/* ===========================================================================
 
 wfroth.wft  Oliver Singla
 
 Description: This file defines words for wfroth which are not defined 
 into the kernel.
 
 Remember: The primary usage of wfroth is to write forth cross-compilers
 for targets such DSP and Microcontrolers.
 
 =========================================================================== */
 
// *************
// *** STACK ***
// *************
 
: under  ( n1 n2 --- n2 )
 swap drop ;
' under alias nip
 
: below  ( n1 n2 n3 --- n2 n3 )
 rot drop ;
 
: above  ( n1 n2 n3 --- n1 n2 n3 n1 )
 3 pick ;
' above alias pluck
 
: tuck ( n1 n2 --- n2 n1 n2 )
 swap over ;
 
: -rot ( n1 n2 n3 --- n3 n1 n2 )
 rot rot ;
 
: ddrop  ( n1 n2 --- )
 drop drop ;
' ddrop alias 2drop
 
: ddup ( n1 n2 --- n1 n2 n1 n2 )
 over over ;
' ddup alias 2dup
 
: 3dup ( n1 n2 n3 --- n1 n2 n3 n1 n2 n3 )
 above above above ;
 
: 3drop ( n1 n2 n3 --- )
 2drop drop ;
 
 
// *************
// *** ARITH ***
// *************
 
: decimal base 10 ! ;
: hex  base 16 ! ;
: binary base 2 ! ;
: octal base 8 ! ;
 
: 1+ ( n --- n+1 )
 1 + ;
 
: 2+ ( n --- n+2 )
 2 + ;
 
: -  ( n1 n2 --- n3 )
 negate + ;
 
: 1- ( n --- n-1 )
 1 - ;
 
: 2- ( n --- n-2 )
 2 - ;
 
: 2* ( n --- n*2 )
 1 shl ;
 
: 2/ ( n --- n/2 )
 1 shr ;
 
 
// **************
// *** MEMORY ***
// **************
 
: -A ( n --- )
 negate +A ;
 
: -! ( n --- )
 negate +! ;
 
: 1+! ( --- )
 1 +! ;
' 1+! alias incr
 
: 1-! ( --- )
 -1 +! ;
' 1-! alias decr
 
: 0!
 0 ! ;
 
: peek ( a --- )
 A> >R >A @ R> >A ;
 
: poke ( n a --- )
 A> >R >A ! R> >A ;
 
 
// *****************
// *** UTILITIES ***
// *****************
 
: exit
 [compile] (;) ; immediate
 
: cellsize+
 cellsize + ;
 
: cellsize-
 cellsize + ;
 
: cellsize*
 cellsize * ;
 
: space  ( --- )
 32 emit ;
 
: cr ( --- )
 13 emit 10 emit ;
 
: type
 A> >R
 >A [ here ] C@ (0branch) [ here ] noop C@+ emit
 (branch) noop [ swap here - 1 + here 1 - !code
 here over - swap !code ]
 R> >A ;
 
: ?enought ( n --- )
 depth 1- > " Not enought parameters on stack" ?"error ;
 
: split  ( hilo --- lo hi )
 dup $FF and swap 8 shr ;
 
: join ( n1 n2 --- n3 )
 8 shl swap + ;
 
 
// **************************
// *** CONTROL STRUCTURES ***
// *** IF..[ELSE]..ENDIF ***
// **************************
 
: create_control_stack
 build> 
  dup 2 * 2 + allot !+ 0 !
 does> ;
 
64 create_control_stack control_stack
 
: dummy 1000 ;
 
: >control ( addr mark --- )
 control_stack @+ drop 1+! @+ 1- cellsize * 2 * A> + >A 
 swap !+ ! ;
 
: control> ( --- addr mark )
 control_stack @+ drop 1-! @+ cellsize * 2 * A> + >A
 @+ @ ;
 
: control ( --- addr mark )
 control_stack @+ drop @+ 1- cellsize * 2 * A> + >A
 @+ @ ;
 
: IF
 compile (0branch)
 here 'IFFI >control
 dummy code, ; immediate
 
: if? ( mark --- )
 'IFFI == 0 == " IF not called before" ?"error ;
 
: ELSE
 control> if?
 compile (branch)
 here 'IFFI >control
 dummy code,
 here over - swap !code ; immediate
 
: ENDIF 
 control> if? 
 here over - swap !code ; immediate
' ENDIF alias THEN
 
 
// ***************
// *** LOGICAL ***
// ***************
 
: true ( --- tf )
 -1 ;
 
: false  ( --- ff )
 0 ;
 
: true!  ( --- )
 true ! ;
 
: false! ( --- )
 false ! ;
 
: not ( f1 --- f2 )
 IF false ELSE true ENDIF ;
 
: 0!= ( n --- f )
 IF true ELSE false ENDIF ;
' 0!= alias 0<>
 
: && ( n1 n2 --- f )
 0!= swap 0!= AND ;
 
: || ( n1 n2 --- f )
 0!= swap 0!= OR ;
 
: = == ;
' == alias =
 
: != ( n1 n2 --- f )
 == not ;
' != alias <>
 
: 0= ( n --- f )
 0 == ;
 
: <  ( n1 n2 --- f )
 ddup > -rot == or not ;
 
: >= ( n1 n2 --- f )
 ddup > -rot == or ;
 
: <= ( n1 n2 --- f )
 > not ;
 
: U< ( u1 u2 --- f )
 ddup U> -rot == or not ;
 
: U>= ( u1 u2 --- f )
 ddup U> -rot == or ;
 
: U<= ( u1 u2 --- f )
 U> not ;
 
 
// **************************
// *** CONTROL STRUCTURES ***
// *** BEGIN..UNTIL   ***
// **************************
 
: BEGIN
 here 'BEGI >control ; immediate
 
: begin? ( mark --- )
 'BEGI != " BEGIN not called before" ?"error ;
 
: break?
 dup 'BREA == IF
  drop
  here over - 1+ swap !code
  control>
  myself
 ENDIF ;
 
: begin_or_break? ( addr mark --- )
 under dup 'BEGI != swap dup 'BREA != 
 swap 'WHIL != and and
 " BREAK not allowed here" ?"error ;
 
: ?break
 compile (1branch)
 control begin_or_break?
 here 'BREA >control
 dummy code, ; immediate
 
: ?continue
 compile (1branch)
 control over -rot begin_or_break?
 here - code, ; immediate
 
: AGAIN
 compile (branch)
 control> break? begin?
 here - code, ; immediate
 
: UNTIL
 compile (0branch)
 control> break? begin?
 here - code, ; immediate
 
: WHILE
 compile (0branch)
 control begin_or_break?
 here 'WHIL >control
 dummy code, ; immediate
 
: while? ( mark --- )
 'WHIL != " WHILE not called before" ?"error ;
 
: REPEAT
 compile (branch)
 control> break? while?
 here over - 1+ swap !code
 control> break? begin?
 here - code, ; immediate
 
 
: CASE
 here 'CASE >control ; immediate
 
: case?  ( mark --- )
 dup 'CASE != swap 'ENDO != and 
 " CASE not called before" ?"error ;
 
: of? ( mark --- )
 'OFFO != " OF not called before" ?"error ;
 
: tipof? ( addr mark --- addr mark )
 dup 'TIPO == IF
  drop here over - 2+ swap !code
  control> ddrop control myself
 ENDIF ;
 
: OF
 control tipof?
 under case?
 compile (of)
 here 'OFFO >control
 dummy code, ; immediate
 
: ENDOF
 control> of?
 compile (branch)
 here 'ENDO >control
 here over - 1+ swap !code
 dummy code, ; immediate
 
: TIPOF
 control> of?
 compile (branch)
 here 'TIPO >control
 here over - 1+ swap !code
 dummy code, ; immediate
 
: ENDCASE
 control> 'ENDO == IF
  here over - swap !code
  myself
 ENDIF drop ; immediate
 
 
: DO
 compile (do)
 here 'DOOD >control ; immediate
 
: do? ( mark --- )
 'DOOD == 0 == " DO not called before" ?"error ;
 
: LOOP
 compile (loop)
  control> break? do?
 here - code, ; immediate
' LOOP alias ENDDO
 
: +LOOP
 compile (+loop)
 control> break? do?
 here - code, ; immediate
' +LOOP alias +ENDDO
 
 
: TIMES
 compile (times)
 here 'TIME >control
 dummy code, ; immediate
 
: times? ( mark --- )
 'TIME == 0 == " TIMES not called before" ?"error ;
 
: ENDTIMES
 compile (endtimes)
 control> break? times?
 dup here - 1+ code,
 here over - swap !code
; immediate
 
: :
 [compile] : ; immediate flush
 
: ;
 ?named IF
  A> >R
  control_stack @+ drop @ 0 > " Control Structure not endded" ?"error
  R> >A 
 ENDIF
 [compile] ; ; immediate flush
 
 
// ***********************
// *** BASIC VARIABLES ***
// ***********************
 
// Create an uninitialized integer variable
// Example of creation:  int myVar
// Examples of utilization: 90 myVar !
// myVar @
: int
 build> 1 allot does> ;
' int alias integer
' int alias variable
 
// Create an initialized integer variable
// Example of creation:  123 int myVar
// Examples of utilization: 90 myVar !
// myVar @
: iint
 build> , does> ;
 
// Create a constant integer
// Example of creation:  10 const ten
// Examples of utilization: ten
: const 
 build> , does> @ ;
' const alias constant
 
 
// *****************
// *** PLATFORMS ***
// *****************
 
1 const WINDOWS
2 const QNXPHOTON
3 const CONSOLE
 
// *******************
// *** TARGET/HOST ***
// *******************
 
int target_mode
 
: host target_mode false! ;
' host alias ok
 
: target target_mode true! ;
' target alias tok
 
: host?  A> target_mode @ not swap >A ;
: target? A> target_mode @ swap >A ;
 
 
// ******************
// *** ARITHMETIC ***
// ******************
 
: min ( n1 n2 --- n3 )
 over over > IF under ELSE drop ENDIF ;
 
: max ( n1 n2 --- n3 )
 over over > IF drop ELSE under ENDIF ;
 
 
// **************
// *** STRING ***
// **************
 
: $len ( sz --- n )
 >A 0 BEGIN C@+ WHILE 1+ REPEAT ;
 
 
// *******************
// *** NUMERIC I/O ***
// *******************
 
int hld
 
: hold ( c --- )
 hld decr @ >A C! ;
 
: digit  ( n --- c )
 dup 9 > IF 55 ELSE 48 ENDIF + ;
 
: <# ( n --- n )
 pad A> hld ! ;
 
: #  ( n1 --- n2 )
 base @ /mod swap digit hold ;
 
: #> ( n --- )
 drop hld @ >A ;
 
: #S ( n --- )
 BEGIN # dup 0 == UNTIL ;
 
: <#S> ( n --- sz )
 <# #S #> A> ;
 
: .  ( n --- )
 A> >R <# #S #> A> type space R> >A ;
 
: .R  ( n1 n2 --- )
 A> >R 
 swap <#S> dup $len rot 2dup < IF swap DO space ENDDO ELSE 2drop ENDIF type
 R> >A ;
 
: .L  ( n1 n2 --- )
 A> >R 
 swap <#S> dup type $len 2dup > IF DO space ENDDO ELSE 2drop ENDIF 
 R> >A ;
 
: h. ( n --- )
 A> >R base @ >R hex . R> base ! R> >A ;
 
: h02. ( n --- )
 A> >R base @ >R hex 
 A> >R <# # # #> A> type R> >A
 R> base ! R> >A ;
 
: h04. ( n --- )
 A> >R base @ >R hex 
 A> >R <# # # # # #> A> type R> >A
 R> base ! R> >A ;
 
: h04.(.) ( n --- )
 dup '$ emit h04. space '( emit
 A> >R base @ >R decimal 
 A> >R <#S> type R> >A
 R> base ! R> >A ') emit ;
 
: h08. ( n --- )
 A> >R base @ >R hex 
 A> >R <# # # # # # # # # #> A> type R> >A
 R> base ! R> >A ;
 
 
// ************************
// *** TEXT TERMINAL IO ***
// ************************
 
: wherex ( --- x )
 wherexy drop ;
 
: wherey ( --- y )
 wherexy under ;
 
: gotox  ( x --- )
 wherey gotoxy ;
 
: gotoy  ( y --- )
 wherex swap gotoxy ;
 
: spaces ( n --- )
 BEGIN space 1- dup not UNTIL drop ;
 
 
// ***************
// *** VARIOUS ***
// ***************
 
: ?  ( --- )
 @ . ;
 
: drops  ( n --- )
 TIMES drop ENDTIMES ;
 
 
// *****************
// *** UTILITIES ***
// *****************
 
32 constant BL
27 constant ESC
 
: [within] ( n1 n2 n3 --- f )
 -rot over <= -rot >= and ;
 
: [within[ ( n1 n2 n3 --- f )
 -rot over <= -rot > and ;
 
: ]within] ( n1 n2 n3 --- f )
 -rot over < -rot >= and ;
 
: ]within[ ( n1 n2 n3 --- f )
 -rot over < -rot > and ;
 
: words
 0 -1 BEGIN
  nextword
  under under swap 
  rot over $len + 1+ dup #cols >= IF
  cr drop dup $len 1+
  ENDIF
  -rot type space
  DUP -1 == 
 UNTIL drop drop ; immediate
 
 
// *******************
// *** SERIAL COMM ***
// *******************
 
0 const NOPARITY 
1 const ODDPARITY
2 const EVENPARITY
 
0 const NOFLOWCTRL
1 const HFLOW
2 const XONXOFF
 
1 const COM1:
2 const COM2:
3 const COM3:
4 const COM4:
 
 
// *************************************
// *** TOOLS  ***
// *************************************
 
// Stack dump
: .S
 cr " Stack: " type
 depth 0 == IF
 " empty" type
 ELSE
 0 depth 1- DO I pick . -1 +ENDDO
 ENDIF ; immediate
 
// Information on a definition
// Example:  WHAT dup
: what
 [compile] 'nfa
 dup not " Definition not found" ?"error 
 >R R >A @+ IF 
  cr " Is an alias of " type cellsize -A @+ 10 cellsize* + type
 ENDIF 
 cr @+ IF
  " 'C' definition - Token = " type
  @ h. space " (-" type @+ negate . ') emit
 ELSE
  " Colon definition - Begin=" type
  cellsize +A @+ h. space " End=" type @+ h.
  @ IF
  cr " BUILD> " type @+ h. 2 spaces
  " DOES> " type @+ h.
  ENDIF
 ENDIF
 cr " Flags: " type
 R> >A 7 cellsize* +A
 @ dup 1 AND IF " IMMEDIATE " type ENDIF
 dup 2 AND IF " FLUSH " type ENDIF
 dup 4 AND IF " DEFW" type ENDIF
 drop ; immediate
 
: help
 cr " words list all definitions" type 
 cr " infos show nb of words and memory use" type
 cr " what <def> basic infos on a given definition" type
 cr " see <def> decompilation of the given definition" type
 cr " *** All these words are immediate and therefore do not need ; ***" type
 cr " Do not forget ; (semicolon) to execute the current compiled definition" type 
; immediate
 
: infos
 meminfos
 cr . " rt words - " type . " words" type
 cr 3dup " Code: " type dup h08. '- emit + h08. 2 spaces " cp=" type h08.
  2 spaces " (Used=" type above over - 5 .L
  " Free=" type + - negate 5 .L ') emit
 cr 3dup " Data: " type dup h08. '- emit + h08. 2 spaces " dp=" type h08.
  2 spaces " (Used=" type above over - 5 .L
  " Free=" type + - negate 5 .L ') emit ; immediate
' infos alias ??
 
 
// *************************************
// *** Compile the user file startup ***
// *************************************
 
" /wfroth/startup.wft" "load ;