strong.f

strongForth: a strongly typed dialect of Forth implemented in ANS Forth.

\ Copyright (C) 2008 Stephan Becher
\
\ This file is part of StrongForth.f.
\
\ StrongForth.f 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.
\
\ StrongForth.f 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 StrongForth.f; if not, write to the Free Software
\ Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
\
\ Contact: [e-mail]

\ If possible, warning "redefined" should be disabled.

\ If the Search-Order word set is available, it is recommended to compile
\ all StrongForth words except for STRONG into a dedicated word set.

\ Set CONSTANT CASE-INSENSITIVE to TRUE if you prefer a case-insensitive 
\ dictionary search. Dictionary headers are always compiled with upper-case 
\ names.

\ Use 'HOST and IMPORT to import words defined in the host system to 
\ StrongForth.f, e. g.
\
\ 'HOST DUMP IMPORT DUMP ( ADDRESS UNSIGNED -- )
\
\ If the word to be imported is a parsing word, 'HOST should be replaced 
\ with 'HOST-PARSING. 'HOST-PARSING creates a wrapper definition that 
\ ensures parsing is done correctly. Here's an example:
\
\ 'HOST-PARSING SEE IMPORT SEE ( -- )

\ Required ANS word sets:
\ CORE
\ DOUBLE
\ EXCEPTION
\ FILE
\ LOCALS
\ STRING
\ TOOLS

\ Implemented word sets:
\ CORE
\ DOUBLE
\ EXCEPTION
\ FILE
\ LOCALS
\ SEARCH
\ STRING

\ Data type hierarchy:
\ SINGLE
\   INTEGER
\     UNSIGNED
\     SIGNED
\     CHARACTER
\   ADDRESS
\     CADDRESS
\   LOGICAL
\     FLAG
\   DEFINITION
\   TOKEN
\     SEARCH-CRITERION
\   FILE
\   FAM
\   WID
\   R-SIZE
\   CONTROL-FLOW
\ DOUBLE
\   INTEGER-DOUBLE
\     UNSIGNED-DOUBLE
\       NUMBER-DOUBLE
\     SIGNED-DOUBLE
\   DATA-TYPE
\     STACK-DIAGRAM
\ TUPLE
\   INPUT-SOURCE
\ SYS
\   ORIG/DEST
\     ORIG
\     DEST
\   COLON-SYS
\     DOES-SYS
\   DO-SYS
\   CASE-SYS
\   OF-SYS

FALSE CONSTANT CASE-INSENSITIVE IMMEDIATE

BL WORD -ROT FIND [IF] DROP [ELSE] : -ROT ROT ROT ; [THEN]
BL WORD NOOP FIND [IF] DROP [ELSE] : NOOP         ; [THEN]

VARIABLE #ORDER
VARIABLE CURRENT
VARIABLE VOC-LINK
VARIABLE DTP-COMP
VARIABLE DTP-EXEC
VARIABLE DP
VARIABLE LP
VARIABLE CFSP

CREATE DT-COMP-BOTTOM 40 CELLS ALLOT
HERE CONSTANT DT-COMP-TOP
CREATE DT-EXEC-BOTTOM 40 CELLS ALLOT
HERE CONSTANT DT-EXEC-TOP
CREATE DICT-BOTTOM 10000 CELLS ALLOT
HERE CONSTANT DICT-TOP

DICT-BOTTOM DP !

CREATE REFERENCES 31 CELLS ALLOT
VARIABLE DATA-BOT
VARIABLE DATA-PTR
VARIABLE DATA-TOP

 9 CONSTANT #VOCS
20 CONSTANT #NESTING

CREATE CONTEXT #VOCS CELLS ALLOT
CREATE CFSTACK #NESTING CELLS ALLOT

  32 CONSTANT NONAME-ATTRIBUTE
 128 CONSTANT IMMEDIATE-ATTRIBUTE
 256 CONSTANT DATA-TYPE-ATTRIBUTE
 512 CONSTANT DEFERRED-ATTRIBUTE
1024 CONSTANT VALUE-ATTRIBUTE
2048 CONSTANT 2VALUE-ATTRIBUTE
4096 CONSTANT VOCABULARY-ATTRIBUTE
8192 CONSTANT VIRTUAL-ATTRIBUTE

0 VALUE LATEST
0 VALUE LATEST-DOES
0 VALUE SOURCE-ID
-1 CONSTANT STRING-ID
2VARIABLE SOURCE-SPEC

CREATE TIB 256 CHARS ALLOT
VARIABLE #TIB
CREATE FIB 1024 CHARS ALLOT
VARIABLE #FIB
CREATE STR 80 CHARS ALLOT
VARIABLE #STR

CREATE ERROR-MESSAGES 300 CELLS ALLOT
ERROR-MESSAGES 300 CELLS ERASE

: MESSAGE,( ( n -- )
  HERE ERROR-MESSAGES ROT CELLS + !
  [CHAR] ) PARSE DUP C, HERE SWAP DUP CHARS ALLOT CMOVE ;

  1 MESSAGE,( ABORT)
  2 MESSAGE,( ABORT")
  3 MESSAGE,( stack overflow)
  4 MESSAGE,( stack underflow)
  5 MESSAGE,( return stack overflow)
  6 MESSAGE,( return stack underflow)
  7 MESSAGE,( do-loops nested too deeply during execution)
  8 MESSAGE,( dictionary overflow)
  9 MESSAGE,( invalid memory address)
 10 MESSAGE,( division by zero)
 11 MESSAGE,( result out of range)
 12 MESSAGE,( argument type mismatch)
 13 MESSAGE,( undefined word)
 14 MESSAGE,( interpreting a compile-only word)
 15 MESSAGE,( invalid FORGET)
 16 MESSAGE,( attempt to use zero-length string as a name)
 17 MESSAGE,( pictured numeric output string overflow)
 18 MESSAGE,( parsed string overflow)
 19 MESSAGE,( definition name too long)
 20 MESSAGE,( write to a read-only location)
 21 MESSAGE,( unsupported operation)
 22 MESSAGE,( control structure mismatch)
 23 MESSAGE,( address alignment exception)
 24 MESSAGE,( invalid numeric argument)
 25 MESSAGE,( return stack imbalance)
 26 MESSAGE,( loop parameters unavailable)
 27 MESSAGE,( invalid recursion)
 28 MESSAGE,( user interrupt)
 29 MESSAGE,( compiler nesting)
 30 MESSAGE,( obsolescent feature)
 31 MESSAGE,( >BODY used on non-CREATEd definition)
 32 MESSAGE,( invalid name argument)
 33 MESSAGE,( block read exception)
 34 MESSAGE,( block write exception)
 35 MESSAGE,( invalid block number)
 36 MESSAGE,( invalid file position)
 37 MESSAGE,( file I/O exception)
 38 MESSAGE,( non-existent file)
 39 MESSAGE,( unexpected end of file)
 40 MESSAGE,( invalid BASE for floating point conversion)
 41 MESSAGE,( loss of precision)
 42 MESSAGE,( floating-point divide by zero)
 43 MESSAGE,( floating-point result out of range)
 44 MESSAGE,( floating-point stack overflow)
 45 MESSAGE,( floating-point stack underflow)
 46 MESSAGE,( floating-point invalid argument)
 47 MESSAGE,( compilation word list deleted)
 48 MESSAGE,( invalid POSTPONE)
 49 MESSAGE,( search-order overflow)
 50 MESSAGE,( search-order underflow)
 51 MESSAGE,( compilation word list changed)
 52 MESSAGE,( control-flow stack overflow)
 53 MESSAGE,( exception stack overflow)
 54 MESSAGE,( floating-point underflow)
 55 MESSAGE,( floating-point unidentified fault)
 56 MESSAGE,( QUIT)
 57 MESSAGE,( exception in sending or receiving a character)
 58 MESSAGE,( [IF], [ELSE], or [THEN] exception)
256 MESSAGE,( data type heap overflow)
257 MESSAGE,( data type heap underflow)
258 MESSAGE,( data types not congruent)
259 MESSAGE,( too many parameters)
260 MESSAGE,( is not a data type)
261 MESSAGE,( invalid reference)
262 MESSAGE,( invalid stack diagram)
263 MESSAGE,( local syntax violation)
264 MESSAGE,( definition not untouched)
265 MESSAGE,( is no subtype of TOKEN)
266 MESSAGE,( test failed)
267 MESSAGE,( definition has no name)
268 MESSAGE,( not enough memory)
269 MESSAGE,( is no deferred definition)
270 MESSAGE,( is not a colon definition)
271 MESSAGE,( invalid item size)
272 MESSAGE,( invalid index)
273 MESSAGE,( is not a letter)
274 MESSAGE,( is not a code definition)
275 MESSAGE,( empty tuple)
276 MESSAGE,( is no data structure)
277 MESSAGE,( invalid line number)
278 MESSAGE,( text not found)
279 MESSAGE,( out of branching range)
280 MESSAGE,( illegal byte/word combination)
281 MESSAGE,( illegal addressing mode)
282 MESSAGE,( illegal floating-point addressing mode)
283 MESSAGE,( illegal port address)
284 MESSAGE,( invalid interrupt number)
285 MESSAGE,( invalid register operand)
286 MESSAGE,( bit field exceeds cell)
287 MESSAGE,( is not an object)
288 MESSAGE,( is not a virtual member function)
289 MESSAGE,( invalid class)
290 MESSAGE,( is no virtual member)
291 MESSAGE,( has already friends)
292 MESSAGE,( is not a friend)
293 MESSAGE,( trying to execute pure virtual function)
294 MESSAGE,( parent class not yet defined)

: OVER-SD ( n d -- n d n )
  2 PICK ;

: OVER-DS ( d n -- d n d )
  2 PICK 2 PICK ;

: NIP-SD ( n d -- d )
  ROT DROP ;

: NIP-DS ( d n -- n )
  NIP NIP ;

: 2NIP ( d1 d2 -- d2 )
  ROT DROP ROT DROP ;

: TUCK-SD ( n d -- d n d )
  ROT OVER-DS ;

: TUCK-DS ( d n -- n d n )
  -ROT OVER-SD ;

: 2TUCK ( d1 d2 -- d2 d1 d2 )
  2SWAP 2OVER ;

: ROT-SSD ( n1 n2 d -- n2 d n1 )
  3 ROLL ;

: ROT-SDD ( n d1 d2 -- d1 d2 n )
  4 ROLL ;

: ROT-DSD ( d1 n d2 -- n d2 d1 )
  4 ROLL 4 ROLL ;

: C@EXT ( ( c-addr -- n )
  C@ DUP 128 AND IF 256 - THEN ;

: 1CELL ( -- u )
  1 CELLS ;

: 2CELLS ( -- u )
  2 CELLS ;

: 1CHAR ( -- u )
  1 CHARS ;

: DCELLS \ -- u )
  CELLS 2* ;

: CELLS+ ( addr1 n -- addr2 )
  CELLS + ;

: DCELLS+ ( addr1 n -- addr2 )
  DCELLS + ;

: CHARS+ ( c-addr1 n -- c-addr2 )
  CHARS + ;

: UM+ ( d1 u -- d2 )
  0 D+ ;

: CELLS- ( addr1 n -- addr2 )
  CELLS - ;

: DCELLS- ( addr1 n -- addr2 )
  DCELLS - ;

: CHARS- ( c-addr1 n -- c-addr2 )
  CHARS - ;

: UM- ( d1 u -- d2 )
  0 D- ;

: M- ( d1 n -- d2 )
  S>D D- ;

: 2CELLS+ ( addr1 -- addr2 )
  CELL+ CELL+ ;

: CELL- ( addr1 -- addr2 )
  1CELL - ;

: 2CELLS- ( addr1 -- addr2 )
  2 CELLS- ;

: CHAR- ( addr1 -- addr2 )
  1 CHARS- ;

: FILL-S ( addr u n -- )
  ROT DUP >R ROT CELLS+ R> ?DO DUP I ! 1CELL +LOOP DROP ;

: FILL-D ( addr u d -- )
  3 ROLL >R ROT R@ SWAP DCELLS+ R> ?DO 2DUP I 2! 2CELLS +LOOP 2DROP ;

: ERASE-S ( addr u -- )
  CELLS ERASE ;

: ERASE-D ( addr u -- )
  2* CELLS ERASE ;

: ERASE-C ( addr u -- )
  CHARS ERASE ;

: MOVE-S ( addr1 addr2 u -- )
  CELLS MOVE ;

: MOVE-D ( addr1 addr2 u -- )
  DCELLS MOVE ;

: MOVE-C ( c-addr1 c-addr2 u -- )
  CHARS MOVE ;

: -S ( addr1 addr2 -- n )
  - 1CELL / ;

: -D ( addr1 addr2 -- n )
  - 2CELLS / ;

: -C ( c-addr1 c-addr2 -- n )
  - 1CHAR / ;

: D1+ ( d1 -- d2 )
  1. D+ ;

: D1- ( d1 -- d2 )
  1. D- ;

: D+! ( d a-addr -- )
  DUP >R 2@ D+ R> 2! ;

: UM+! ( u a-addr -- )
  >R 0 R@ 2@ D+ R> 2! ;

: M+! ( n a-addr -- )
  >R S>D R@ 2@ D+ R> 2! ;

: C+! \ n c-addr -- )
  DUP >R C@ + R> C! ;

: +!-S ( n a-addr -- )
  >R CELLS R@ @ + R> ! ;

: +!-D ( n a-addr -- )
  >R DCELLS R@ @ + R> ! ;

: +!-C ( n a-addr -- )
  >R CHARS R@ @ + R> ! ;

: T* ( ud u -- ut )
  >R SWAP R@ UM* ROT R> UM* ROT UM+ ;

: T/MOD ( ut u1 -- u2 ud )
  DUP >R UM/MOD -ROT R> UM/MOD ROT ;

: TM* ( d1 u -- d2 )
  T* DROP ;

: U/ ( u1 u2 -- u3 )
  0 SWAP UM/MOD NIP ;

: M/ ( ud1 u -- ud2 )
  0 SWAP T/MOD NIP-SD ;

: UMOD ( u1 u2 -- u3 )
  0 SWAP UM/MOD DROP ;

: UMMOD ( ud u1 -- u2 )
  0 SWAP T/MOD 2DROP ;

: U/MOD ( u1 u2 -- u3 u4 )
  0 SWAP UM/MOD ;

: TM/MOD \ ud1 u1 -- u2 ud2 )
  0 SWAP T/MOD ;

: U*/ ( u1 u2 u3 -- u4 )
  >R UM* R> UM/MOD NIP ;