---

forth5mx_extend.fs

Código fuente

\ forth5mx_extend.fs

\ Copyright (C) 2005-2010 Marcos Cruz (http://programandala.net)

\ This file is part of Forth 5mx.

\ Forth 5mx 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 2
\ of the License, or (at your option) any later version.

\ This program is distributed in the hope that it will be useful,
\ but WITHOUT ANY WARRANTY; without even the implied warranty of
\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
\ GNU General Public License for more details.

\ You should have received a copy of the GNU General Public License
\ along with this program. If not, see <http://gnu.org/licenses>.


\ Comment marks:

\ :!!! = not finished
\ ?!!! = to be explored
\ *!!! = debug

\ Notation for the data stack arguments:

\ a-addr = cell-aligned address
\ addr = address
\ b = byte
\ c = printable character
\ char = printable character
\ c-addr = character-aligned address
\ f = flag
\ fam = file access method
\ fid = file identifier
\ ior = input/output result
\ n = signed number
\ +n = positive number
\ nt = name token
\ pfa = parameter field address (data field)
\ d = double number
\ u = unsigned number
\ ud = unsigned double number
\ x = unspecified cell
\ xt = execution token


10 BASE ! UNUSED

\ MARKER forth5mx_extend

.( Extending...) CR

\ ************************
\ .( -Core )

: '  ( -- xt ) \ Core
  BL WORD DUP FIND
  0= ROT COUNT ?abort
  ;

: ."  \ Core
  ?compiling
  POSTPONE S" POSTPONE TYPE
  ; IMMEDIATE

: <resolve  ( -- )
  HERE CELL+ - ,
  ;

: resolve>  ( a-addr -- )
  HERE OVER CELL+ - SWAP !
  ;

: <mark  ( -- a-addr )
  \ Set up a backward branch by leaving the current address on the stack.
  HERE
  ;

: mark>  ( -- a-addr )
  \ Mark the point of a forward branch by saving its address on the stack.
  HERE 0 ,
  ;


1 CONSTANT if-mark
2 CONSTANT else-mark
3 CONSTANT begin-mark
4 CONSTANT while-mark
5 CONSTANT do-mark
6 CONSTANT endof-mark
7 CONSTANT of-mark


: IF  \ Core
  ?compiling
  POSTPONE 0branch mark> if-mark
  ; IMMEDIATE

: THEN  \ Core
  ?compiling
  DUP if-mark <>  SWAP else-mark <>  AND
  S" IF missing" ?abort
  resolve>
  ; IMMEDIATE

: unstructured  ( u1 u2 c-addr3 u3 -- )
  2SWAP <>  IF error THEN 2DROP
  ;

: ELSE  \ Core
  ?compiling
  if-mark S" IF missing" unstructured
  POSTPONE branch  mark> SWAP  resolve> else-mark
  ; IMMEDIATE

: BEGIN  \ Core
  ?compiling
  <mark begin-mark
  ; IMMEDIATE

: UNTIL  \ Core
  ?compiling
  begin-mark S" BEGIN missing" unstructured
  POSTPONE 0branch  <resolve
  ; IMMEDIATE

: WHILE  \ Core
  ?compiling
  begin-mark S" BEGIN missing" unstructured
  POSTPONE 0branch  mark> while-mark
  ; IMMEDIATE

: REPEAT  \ Core
  ?compiling
  while-mark S" WHILE missing" unstructured
  POSTPONE branch SWAP <resolve resolve>
  ; IMMEDIATE

: DO  \ Core
  ?compiling
  POSTPONE (do) mark> <mark do-mark
  ; IMMEDIATE

: ?DO  \ Core
  ?compiling
  POSTPONE (?do) mark> <mark do-mark
  ; IMMEDIATE

: LOOP  \ Core
  ?compiling
  do-mark S" DO missing" unstructured
  POSTPONE (loop) <resolve resolve>
  ; IMMEDIATE

: +LOOP  \ Core
  ?compiling
  do-mark S" DO missing" unstructured
  POSTPONE (+loop) <resolve resolve>
  ; IMMEDIATE

: -LOOP  \ gforth
  \ :!!! *!!! experimental
  ?compiling
  do-mark S" DO missing" unstructured
  POSTPONE (-loop) <resolve resolve>
  ; IMMEDIATE


: ABORT"  ( f -- ) \ Core
  ?compiling POSTPONE S" POSTPONE ?abort
  ; IMMEDIATE

: 2!  \ Core
  SWAP OVER ! CELL+ !
  ;

: 2@  \ Core
  DUP CELL+ @ SWAP @
  ;

: BLANK  \ Core
  BL FILL
  ;

: S>D  \ Core
  \ Taken from gforth.
  DUP 0<
  ;

: LITERAL  ( Compile time: x -- ; Run time: -- x ) \ Core
  ?compiling  POSTPONE (literal) ,
  ; IMMEDIATE

: [']  \ Core  ( -- )
  ?compiling ' POSTPONE LITERAL
  ; IMMEDIATE

\ : literal, POSTPONE (literal) , ;
\ : ['] ?compiling ' literal, ; IMMEDIATE
\ : LITERAL ?compiling literal, ; IMMEDIATE

: use  ( xt -- ) \ PsiForth
  \ xt or cfa ?!!!
  \ Modify the code field content of the latest word, thereby
  \ giving it a different run time behaviour.
  \ latest name> ! \ PsiForth
  @ latest name> !  \ Forth 5mx
  ;

: CHAR  ( "<spaces>name" -- c ) \ Core
  BL WORD CHAR+ C@
  ;

: [CHAR]  ( Compilation: "<spaces>name" -- ; Run-time: -- c ) \ Core
  ?compiling
  CHAR POSTPONE LITERAL
  ; IMMEDIATE

: DECIMAL  ( -- ) \ Core
  10 BASE !
  ;

: next-header  ( nt1 -- nt2 ) \ PsiForth
  1-
  ;

: headers  ( xt -- ) \ PsiForth
  \ Executes xt for every word in the dictionary.
  \ In the first execution, the nt of the last word is on the stack.
  >R latest
  BEGIN  ?DUP  WHILE  R@ EXECUTE  REPEAT
  R> DROP
  ;

: >name  ( xt -- nt ) \ Forth 5mx
  cell- @
  ;

: DOES>  ( -- ) \ Core
  R>  latest name>  ['] (does>) >name
  OVER ! CELL+ !
  ;

: RECURSE  ( -- ) \ Core
  latest name> POSTPONE LITERAL POSTPONE EXECUTE
  ; IMMEDIATE

\ WORDLIST CONSTANT environment-wordlist
\ environment-wordlist DEFINITIONS

\ ENVIRONTMENT? strings:

\ /COUNTED-STRING is a high level constant
\ /HOLD is undefined
\ /PAD is a high level constant
FALSE CONSTANT BLOCK
FALSE CONSTANT BLOCK-EXT
FALSE CONSTANT CORE
FALSE CONSTANT CORE-EXT
FALSE CONSTANT DOUBLE
FALSE CONSTANT DOUBLE-EXT
FALSE CONSTANT EXCEPTION
FALSE CONSTANT EXCEPTION-EXT
FALSE CONSTANT FACILITY
FALSE CONSTANT FACILITY-EXT
FALSE CONSTANT FILE
FALSE CONSTANT FILE-EXT
FALSE CONSTANT FLOATING
FALSE CONSTANT FLOATING-EXT
\ FALSE CONSTANT FLOATING-STACK
\ FALSE CONSTANT FLOORED
\ FALSE CONSTANT MAX-D
\ FALSE CONSTANT MAX-FLOAT
\ FALSE CONSTANT MAX-N
\ FALSE CONSTANT MAX-U
\ FALSE CONSTANT MAX-UD
FALSE CONSTANT MEMORY-ALLOC
\ RETURN-STACK-CELLS is a high level constant
\ STACK-CELLS is a high level constant
FALSE CONSTANT SEARCH-ORDER
FALSE CONSTANT SEARCH-ORDER-EXT
FALSE CONSTANT STRINGS
FALSE CONSTANT TOOLS
FALSE CONSTANT TOOLS-EXT
\ WORDLISTS is a high level constant

: ENVIRONMENT?  ( c-addr u -- false | i*x true )

  \ Unfinished!!!

  \ environtment-wordlist search-wordlist \ :!!! Gforth
  find-name DUP IF
  name> EXECUTE TRUE
  THEN

  ;

\ FORTH DEFINITIONS


\ ************************
\ .( -Core Ext )

\ Commented out untill >NUMBER is defined:
\ : CONVERT  ( ud1 c-addr1 -- ud2 c-addr2 )  CHAR+ 65535 >NUMBER DROP  ;

: HEX  ( -- ) \ Core Ext
  16 BASE !
  ;

: AGAIN  \ Core Ext
  ?compiling
  begin-mark S" BEGIN missing" unstructured
  POSTPONE branch <resolve
  ; IMMEDIATE

: CASE  ( Compilation: -- 0 u ; Run-time: x -- x ) \ Core Ext
  ?compiling
  0 endof-mark
  ; IMMEDIATE

: OF  ( u endof-mark -- addr u of-mark ) \ Core Ext
  ?compiling
  endof-mark pluck IF  S" ENDOF missing"  ELSE  S" CASE missing" THEN  unstructured
  >R
  POSTPONE (of)
  mark>
  R> 1+ of-mark
  ; IMMEDIATE

: ENDOF  ( addr u of-mark -- addr u endof-mark ) \ Core Ext
  ?compiling
  of-mark S" OF missing" unstructured
  >R
  POSTPONE branch
  mark> SWAP
  resolve>
  R> endof-mark
  ; IMMEDIATE

: ENDCASE  ( Compile: addr_1...addr_u u endof-mark -- ; Run-time: x -- ) \ Core Ext
  ?compiling
  endof-mark S" ENDOF missing" unstructured
  POSTPONE DROP
  ?DUP IF
    0 DO resolve> LOOP
  THEN
  ; IMMEDIATE

: VALUE  ( x -- ) \ Core Ext
  CREATE ,  ['] (value) use
  ;

: <to>  ( x "<spaces>name" -- ) \ Forth 5mx
  ' >BODY !
  ;

: [to]  ( Compile: "<spaces>name" -- ; Run: x -- ) \ Forth 5mx
  ' >BODY  POSTPONE LITERAL  POSTPONE !
  ; IMMEDIATE

: TO  ( Interpretation: x "<spaces>name" -- ; Compilation: "<spaces>name" -- ; Run-time: x -- ) \ Core Ext
  STATE @
  IF  POSTPONE [to]
  ELSE  <to>
  THEN
  ; IMMEDIATE

-1 CONSTANT -1
 0 CONSTANT 0
 1 CONSTANT 1
 2 CONSTANT 2

: link  ( addr -- ) \ PsiForth
  \ ?!!! unused
  HERE SWAP exchange ,
  \ ?!!! exchange used only here
  ;

: ERASE  ( addr u -- ) \ Core Ext
  0 FILL
  ;

: WITHIN  ( test low high -- f ) \ Core Ext
  \ Taken from the ANS Forth documentation.
  OVER - >R - R>  U<
  ;

: sconstant  ( c-addr u -- ) \ Forth 5mx
  CREATE  s, ALIGN
  DOES>  COUNT
  ;

: message:  ( c-addr u -- ) \ PsiForth
  CREATE  s, ALIGN
  DOES>  COUNT TYPE SPACE
  ;

: error:  ( c-addr u -- ) \ PsiForth
  CREATE  S, ALIGN
  DOES>  COUNT error
  ;

: array  ( u -- ) \ PsiForth
  CREATE
  ['] doarray use
  CELLS ALLOT
  ;

: table  \ PsiForth
  CREATE
  ['] dotable use
  ;

: lookup:
  CREATE  HERE 0 ,
  DOES>  lookup
  ;

: ;lookup
  HERE OVER CELL+ -
  2 CELLS / SWAP !
  ;

: follow
  0 BEGIN
  SWAP ?DUP WHILE
    thread SWAP 1+
  REPEAT
  ;

: threads  ( -- )
  \ show # members per thread
  #threads 0 DO
    I DUP 7 AND 0= IF CR THEN
    DUP 4 .R 1+ thread follow  2 .R
  LOOP
  ;

\ ************************
\ CR .( -Double)

: 2VARIABLE  \ Double
  CREATE 2 CELLS ALLOT
  ;

 : 2LITERAL  ( d -- )  \ Double
  \ Taken from eForth.
  SWAP  POSTPONE LITERAL  POSTPONE LITERAL
  ; IMMEDIATE

\ : DNEGATE ( d -- -d )
  \ Taken from eForth.
\ INVERT >R INVERT 1 UM+ R> +
\ ;

\ : D-  ( d1 d2 -- d3 )  \ Double
  \ Taken from hForth and eForth.
\ DNEGATE D+
\ ;

\ : DNEGATE ( d -- -d )
  \ Taken from pForth.
\ 0 0 2SWAP d-
\ ;

: D>S  ( d -- n ) \ Double
  DROP
  ;

\ ************************
\ CR .( -Double Ext)

: 2ROT  ( x1 x2 x3 x4 x5 x6 -- x3 x4 x5 x6 x1 x2 ) \ Double Ext
  2>R 2SWAP 2R> 2SWAP
  ;

\ ************************
\ .(-File )

KIoOpenModeOpen
KIoOpenFormatBinary or
KIoOpenAccessRandom or
CONSTANT r/o \ read only file access method
\ This access method sets the file position to the start.

KIoOpenModeAppend
KIoOpenFormatBinary or
KIoOpenAccessRandom or
KIoOpenAccessUpdate or
DUP
CONSTANT w/o \ write only file access method
CONSTANT r/w \ read and write file access method
\ This access methods set the file position to the end.

: BIN  ( fam1 -- fam2 ) \ File
  \ Change file access method from text to binary.
  \ It does nothing, because all files are opened in binary mode.
  \ Old code:
  \ KIoOpenFormatText INVERT AND KIoOpenFormatBinary OR
  ;

: REPOSITION-FILE  ( ud fid -- ior ) \ File
  \ Reset the file position to ud .
  \ It doesn't work with files opened in text mode.
  >R D>S R>  \ :!!!
  1 ( mode) SWAP seek-file
  SWAP DROP
  ;

: rewind-file  ( fid -- ior ) \ Forth 5mx
  \ System specific version of REPOSITION-FILE .
  \ Rewind a text file to the start.
  \ It doesn't work with files opened in binary mode.
  0 ( offset) 6 ( mode) ROT seek-file
  SWAP DROP
  ;

\ not finished
\ defer (rewind)
\ ' REPOSITION-FILE is (rewind)
\ : rewind   ( fid -- ) \ Common use
\ 0 DUP ROT
\ ;

: FILE-POSITION  ( fid -- ud ior ) \ File
  \ Return the current file position.
  \ It doesn't work with files opened in text mode.
  0 ( offset) 3 ( mode) ROT seek-file
  >R S>D R>
  ;

: FILE-SIZE  ( fid -- ud ior ) \ File
  \ Return the file size.
  \ Unfinished:
  \ It doesn't work with files opened in text mode.
  \ It returns a dummy ior flag, always false :!!!
  DUP DUP file-position  ( fid fid d ior -- )  \ current file position
  ABORT" file-position error in file-size"
  ROT 0 ( offset) 2 ( mode) ROT seek-file  \ move file pointer to the end to get the file size
  ABORT" seek-file error in file-size"
  >R ROT REPOSITION-FILE  \ preserve the file size and restore the file pointer
  ABORT" reposition-file error in file-size"
  R> S>D  \ file lenght
  FALSE  \ dummy ior flag :!!!
  ;

: include?  ( "<spaces>word<spaces>filename" -- ) \ Taken from pForth
  BL WORD FIND
  IF  BL WORD 2DROP
  ELSE  DROP include
  THEN
  ;

' include? alias require  \ a more common name

\ ************************
\ .(-String )

: /STRING  ( c-addr1 u1 +n -- c-addr2 u2 ) \ String
  DUP >R - SWAP R> + SWAP
  ;

: str=  ( c-addr1 u1 c-addr2 u2 -- f ) \ gforth
  COMPARE 0=
  ;

: str<  ( c-addr1 u1 c-addr2 u2 -- f ) \ gforth
  COMPARE 0<
  ;

: string-prefix?  ( c-addr1 u1 c-addr2 u2 -- f ) \ gforth
  \ Is c-addr2 u2 a prefix of c-addr1 u1 ?
  TUCK 2>R MIN 2R> str=
  ;

\ ************************
\ .(-Tools )

: ?  ( addr -- ) \ Tools
  @ .
  ;

: .S  ( -- ) \ Tools
  DEPTH DUP 0> IF
    BEGIN DUP
    WHILE DUP PICK . 1-
    REPEAT
  ELSE
    S" stack empty" TYPE
  THEN DROP
  ;

: more  ( -- f) \ PsiForth
  \ f = TRUE (no key pressed, or other than Escape)
  \ f = FALSE (Escape key pressed)
  KEY? DUP  IF
    KEY esc <>  IF
      CR S" --- more ---" TYPE
      KEY esc = AND
    THEN
  THEN
  NOT
  ;

15 CONSTANT #creators
#creators array creator

: creator"  ( n -- ) \ PsiForth
  HERE SWAP creator !
  [CHAR] " WORD COUNT S,
  ;

0 creator" primitive"
1 creator" :"
2 creator" variable"
3 creator" variable" \ primitive variable
4 creator" constant"
5 creator" 2constant"
6 creator" does>"
7 creator" defer"
8 creator" uvariable"  \ ?!!! psiforth
9 creator" array"  \ ?!!! psiforth
10 creator" table"  \ ?!!! psiforth
11 creator" code"  \ ?!!! psiforth
12 creator" create"
13 creator" value"
14 creator" marker"
ALIGN

: .creator  ( nt -- ) \ Forth 5mx
  DUP #creators > AND
  DUP  IF
    name> @ DUP #creators < AND
  THEN
  creator @ COUNT  11 OVER - SPACES  TYPE SPACE
  ;

: .header  ( nt -- nt ) \ PsiForth
  CR DUP 6 .R
  DUP name> 7 .R
  BL OVER immediate?  IF  DROP [CHAR] #  THEN  EMIT
  DUP .creator
  DUP .name
  next-header more AND
  ;

: WORDS  ( -- ) \ Tool
  ['] .header headers
  ;


\ ************************
\ .(-Tools Ext )

\ The data stack is used as control stack:
' pick alias CS-PICK
' roll alias CS-ROLL

\ S" forth5mx_extend_[if].fs" INCLUDED

: [if]?  ( c-addr u -- f )
  S" [IF]" COMPARE 0=
  ;

: [else]?  ( c-addr u -- f )
  S" [ELSE]" COMPARE 0=
  ;

: [then]?  ( c-addr u -- f )
  S" [THEN]" COMPARE 0=
  ;

: [ELSE]  ( -- ) \ Tools Ext
  \ Skip the code until [THEN] is found.
  \ Code taken from pforth.
  1  \ recursion level
  BEGIN
    BEGIN
      \ parse-word DUP \ (this some times causes a "string too long OPL error" because of the parse-word implementation)
      BL WORD COUNT DUP  \ (the classic way 
    WHILE
      2DUP upper
      2DUP [if]?
      IF
        2DROP 1+
      ELSE
        2DUP [else]?
        IF
          2DROP 1- DUP IF  1+  THEN
        ELSE
          [then]? IF  1-  THEN
        THEN
      THEN
      ?DUP 0= IF  EXIT  THEN
    REPEAT
    2DROP REFILL 0=
  UNTIL
  ; IMMEDIATE

: [IF]  ( f -- ) \ Tools Ext
  \ If TOS is true, skip the code until [THEN] is found.
  \ Code taken from pforth.
  0= IF  POSTPONE [ELSE]  THEN
  ; IMMEDIATE

: [THEN]  ( -- ) \ Tools Ext
  ; IMMEDIATE



\ ************************
\ .( -Facility Ext )

: TIME&DATE  ( -- sec min hour day month year )
  second minute hour day month year
  ;

\ ************************
\ .(-Not ANS )  \ common use

: on  ( a-addr -- ) \ Common use
  TRUE SWAP !
  ;

: off ( a-addr -- ) \ Common use
  FALSE SWAP !
  ;

: [defined]  \ Common use
  BL WORD FIND NIP 0<>
  ; IMMEDIATE

: [ifdef]  \ Common use
  POSTPONE [defined]
  POSTPONE [IF]
  ; IMMEDIATE

: [undefined]  \ Common use
  POSTPONE [defined] INVERT
  ; IMMEDIATE

: [ifundef]  \ Common use
  POSTPONE [undefined]
  POSTPONE [IF]
  ; IMMEDIATE

: endif  \ Common use
  POSTPONE THEN ; IMMEDIATE

: defer ( "<spaces>name" -- )  \ Common use
  CREATE  ['] noop ,  ['] (defer) use
  ;

: <is>  ( xt "<spaces>name" -- ) \ gforth
  ' >BODY !
  ;

: [is]  ( compilation: "<spaces>name" -- ; run-time: xt -- ) \ gforth 
  ' >BODY  POSTPONE LITERAL  POSTPONE !
  ; IMMEDIATE

: is  ( xt "<spaces>name" -- ) \ Common use
  STATE @  IF  POSTPONE [is]
  ELSE  <is>
  THEN
  ; IMMEDIATE

: svariable  ( "<spaces>name" -- ) \ Common use
  CREATE  256 CHARS ALLOT  ALIGNED
  ;

: place  ( c-addr1 u1 c-addr2 --) \ Common use

  \ From "An so Forth..." by J.L. Bezemer (2001-04-06):
  \ OVER OVER >R >R CHAR+ SWAP CHARS CMOVE R> R> C!

  \ My own version, from my fstr toolkit (I called it STR! ):
  2DUP C! 1+ SWAP CMOVE

  ;

: binary  ( -- ) \ Common use
  2 BASE !
  ;

FALSE [IF]
: alias  ( xt "<spaces>name" -- ) \ Common use
  CREATE ,
  DOES> @ EXECUTE
  ;
[THEN]

: under+  ( n1 n2 n3 -- n4 n2 ) \ Common use
  ROT + SWAP
  ;

: bounds  ( c-addr1 u1 -- c-addr2 c-addr1 ) \ Common use
  OVER + SWAP
  ;

: under  ( x1 x2 x3 -- x3 x2 ) \ Common use
  ROT DROP SWAP
  ;


\ ************************
\ Facility Ext (defered)

defer EMIT?
' TRUE is EMIT?


\ ************************
\ - Not ANS - Forth 5mx

: -seconds  \ Forth 5mx
  ( second minute hour day month year -- seconds )
  \ Calculates time diference in seconds between the date given and now.
  date>secs TIME&DATE date>secs SWAP -
;

: pwd  \ Forth 5mx
  path TYPE
;

create 'newline
  2 c, 13 c, 10 c,   \ dos:  cr lf
: newline  ( -- c-addr u )
  \ Used in Gforth.
  \ Needed by the Forth Foundation Libray (in config.fs).
  \ 2010-03-21
  'newline count
  ;

: string,  ( -- c-addr u )
  \ Used in Gforth.
  \ Needed by the Forth Foundation Libray (in config.fs).
  \ 2010-03-21
  dup c, here swap dup allot move
  ;

\ ************************
\ - Sound

: play:

  \ 2006 08 16 I Simplified the PsiForth version: no sound path.

  CREATE  ( c-addr u -- )
    s, ALIGN
  DOES>  ( pfa -- )
    COUNT play

  ;

\ Examples:
\ S" c:\sounds\01" play: one
\ S" d:\doc\tmp\cock" play: cock

: bell 16 200 beep ;

: error-bell bell bell bell ;

\ ' error-bell error-sound-xt !
error-sound? on

\ ************************
\ Drafts and debugging

0 [IF]

: MARKER  ( "<spaces>name" -- ) \ Core Ext
  \ :!!!
  HERE latest
  CREATE , ,
  DOES> DUP @ (latest) ! CELL+ @ dp !
  ;

[THEN]

: .thread ( -- )
  #threads 1+ 1
  DO
    I thread CR .
  LOOP
  ;

\ ************************
\ Debug tools

: debug-included

  \ Redefine INCLUDED to detect unbalanced stack.

  \ 2007-06-19

  S" ' INCLUDED  : INCLUDED  LITERAL EXECUTE DEPTH IF 10 10 beep [CHAR] * EMIT KEY DROP THEN  ;" EVALUATE

  ;

\ ************************
\ Provisional

\ Words that must exist but are not developed yet.

: FORTH ;
: ONLY ;
: ALSO ;
: root ;
: DEFINITIONS  CONTEXT @ CURRENT ! ;
: SET-CURRENT  ( wid -- )  CURRENT !  ;
: GET-CURRENT  ( -- @ )  CURRENT @  ;
: environment ;  \ in the future this will be a word-list
: forth5mx ;  \ this will be in the environment word-list and will return some info
: FALIGNED ALIGNED ;

\ ************************
\ Dummy

: · CR ." Warning: Char · found" ;  \ just to avoid the error caused by this symbol, left at the end of file texts by some editors

\ ************************
\ License

: license ( -- )
 cr
 ." This program is free software; you can redistribute it and/or modify" cr
 ." it under the terms of the GNU General Public License as published by" cr
 ." the Free Software Foundation; either version 2 of the License, or" cr
 ." (at your option) any later version." cr cr

 ." This program is distributed in the hope that it will be useful," cr
 ." but WITHOUT ANY WARRANTY; without even the implied warranty of" cr
 ." MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the" cr
 ." GNU General Public License for more details." cr cr

 ." You should have received a copy of the GNU General Public License" cr
 ." along with this program. If not, see <http://gnu.org/licenses>." cr
 ;


\ ************************
\ Preferences

error-sound? on
debug? on


\ ************************
\ Free memory

UNUSED TUCK -

CR .( Memory stats: )
. .( bytes compiled, )
. .( bytes free)
CR