| ANS Forth compatibility for RetroForth 9.2.7.
| These are the fundamentals to get RetroForth to pass most of the tests in coretest,
| with a collection of other non-CORE Standard words.
| Neal Bridges, August 2006.
| neal@quartus.net  http://quartus.net
| Version 1.0
| Notes:
| All word names are lower-cased.
| coretest.fs tests involving  source  and  >in  do not presently work.
| RetroForth's  fill  does not pass coretest. It has a replacement in this file.
| RetroForth's  move  does not pass coretest. It is not yet replaced here.
| RetroForth does not have  accept .


decimal

| *** First the really funky stuff involving RetroForth internals, embedded opcodes, etc.


: immediate  ['] .self reclass ;

' | alias \ immediate  \ allows Standard line comments

\ A few RetroForth words aliased directly to Standard names:
' :: alias :noname
' ;; alias exit  immediate

' # alias (.)          \ a common-usage alias.  # is redefined below.

\ The second cell in a CREATEd word's header holds the dataspace address:
: >body  >entry cell+ @ ;

\ The third cell in a RetroForth word's header holds the xt of the word's class:
: ?immediate ( xt -- flag )  >entry 2 cells + @  ['] .forth  <> ;

\ The joy of POSTPONE is not having to wonder whether to use  x:  or  c:
: (postpone)  if  execute  ;then  x: compile  ;
: postpone  ' dup literal,  ?immediate literal,  c: (postpone) ; immediate

\ Arrange for a definition's name not to be findable until the definition is 
\  completed, as per Standard dictionary search rules:
loc:
  variable oldlast
  \ The second cell in a RetroForth colon-word's header holds the xt:
  :noname ( recurse )  oldlast @ cell+ @ compile  ; ( immediate )
  :noname ( ; )  oldlast @ last !  postpone ;  ; ( immediate )
  :noname ( : )  last @  postpone :  last @ oldlast !  last ! ;
;loc
  alias :
  alias ;  immediate
  alias recurse  immediate

\ Stack pointer access:
: sp@  dup [ $f089 2, ]  ;  \ mov eax,esi
: sp!  [ $c689 2, ] drop ;  \ mov esi,eax
: rp@  c: dup  $e089 2, ; immediate
: rp!  $c489 2,  c: drop ; immediate

: depth  [ sp@ ] literal sp@ - 1 cells /  1- ;

\ Some of RetroForth's double-cell library words, corrected for Standard cell-order:
: s>d  [ $04ee8399 , $1689 2, ] swap ;
: m*  [ $892ef799 , $16 1, ] swap ;
: um*  [ $26f7d231 , $1689 2, ] swap ;
: fm/mod  >r swap r> [ $168bad91 , $d285f9f7 , $c0850774 , $01480379 , $1689ca 3, ] ;
: sm/rem  >r swap r>  [ $168bad91 , $1689f9f7 , ] ;
: um/mod  >r swap r> [ $168bad91 , $1689f1f7 , ] ;
: m*  [ $892ef799 , $16 1, ] swap ;

\ A control-flow word from the TOOLS EXT wordset:
: ahead  $e9 1, here 0 , ; immediate

\ A factor of UNTIL (defined below):
: resolve ( dest orig -- )  over cell+ -  swap ! ;


\ *** Smoother sailing from here on down; fewer internal RetroForth details required.


\ More RetroForth words aliased directly to Standard names.
' r alias r@  immediate
' r alias i  immediate   \ this works both in RetroForth for/next and in ANS do-loops
' >> alias rshift
' << alias lshift
' eval alias evaluate
' not alias invert
' 1+ alias char+
' 1, alias c,

: 0=  0 = ; 
: 0<  0 < ;
: 0>  0 > ;

\ A .S that makes use of DEPTH:
: (.s)  depth 0 >if  >r recurse r> dup .  then ;
: .s  depth  ." <" (.) ." > " (.s) cr ;

true constant allbits
allbits 1 rshift constant lowbits
lowbits invert constant highbit

: signsdiffer?  xor highbit and ;  \ optimized, doesn't return an all-bits-set flag

: u<  2dup signsdiffer? if  nip 0<  ;then  - 0< ;
: u>  swap u< ;

: 2*  1 lshift ;
: 2/  dup 1 rshift  swap highbit and  or ;

: 2r@  { r> r> 2dup >r >r swap } ; immediate
: 2>r  { swap >r >r } ; immediate
: 2r>  { r> r> swap } ; immediate

: 2swap  rot >r rot r> ;


\ Additional and redefined control-flow words.

: else  postpone ahead  swap  postpone then ; immediate
: begin  here ; immediate
: while  postpone if  swap ; immediate
: repeat  postpone again  postpone then ; immediate
: until   postpone while  resolve ; immediate


\ A compliant implementation of DO/LOOP/+LOOP/UNLOOP/LEAVE and J.

: do
  0 literal,  here cell-  \ the leave address, to be backpatched by +LOOP later
  { >r ( leave )  swap  >r ( limit )  >r ( index ) }
  postpone begin ; immediate

: unloop  { rdrop rdrop rdrop } ; immediate

: leave  unloop ;

: (loop) ( Run-time: incr start --   R:  leave lim idx -- | leave lim idx' )
  swap r>  swap r>    ( start ret incr idx       R: leave lim )
  2dup +  r@ swap >r  ( start ret incr idx lim   R: leave lim idx' )
  - tuck +  signsdiffer? if  nip unloop  else  drop  then  >r ;

: +loop
  { literal (loop) }  here swap !  \ backpatch the leave address
; immediate

: loop  { 1 +loop } ; immediate

: j  2r> 2r>  r@  -rot 2>r -rot 2>r ; 


\ Parsing words.

32 constant bl

: char  bl parse drop c@ ;
: [char]  char literal, ; immediate

create pad 84 allot

: word  parse dup pad c!  pad char+ swap move  pad ;


\ Pictured numeric output words.

66 allot here constant holdaddr
variable hld 
: <#  0 hld ! ;
: hold  1 hld +!  holdaddr hld @ - c! ;
: #>  2drop hld @  holdaddr over - swap ;
: sign  0 <if  '- hold  then ;
: mu/mod  >r  0 r@ um/mod  r> swap >r  um/mod r>  ;
: num>char  dup 9 > 7 and + '0 + ;
: char>num  dup '9 > 7 and - '0 - ;
: #  base @ mu/mod  rot  num>char hold ;
: #s  begin  # 2dup or  0= until ;


\ Numeric conversion.

: mu*  swap over * >r um* r> + ;
: within  over - >r - r> u< ;            
: d+  >r rot over +  dup >r  u> if 1+ then  r> swap r> + ;

: digit?  char>num dup 0 base @ within ;

: >number 
  >r 
  begin
  r@ while
  dup c@ digit? while
    swap >r >r  base @ mu*  r> 0 d+  r> char+
    r> 1- >r
  repeat
  drop
  then  r> ;


\ Miscellany.

: count  dup char+ swap c@ ;

: find
  dup count lookup if  nip  dup ?immediate  1 and 2* 1-
  else  nip nip  then ;

: ?dup  dup 0; ;
: 2over  >r >r 2dup r> -rot r> -rot ;

: abs  dup 0> tuck xor - ;

: min  2dup <if drop ;then nip ;
: max  2dup >if drop ;then nip ;

: 2@  dup cell+ @ swap @ ;
: 2!  swap over ! cell+ ! ;

: aligned  dup 1 cells mod + ;
: align  here aligned h0 ! ;

: */mod  >r m* r> sm/rem ;
: */  */mod nip ;

: chars ; immediate

\ This corrects the built-in RetroForth  spaces  :
: spaces  ?dup if  1- spaces  then ;

\ The built-in RetroForth  fill  failed when asked to fill a zero-length region.
: fill  over 0 >if  -rot for  2dup c! char+  next  else  drop  then  2drop ;


\ *** Additional Standard words beyond those required to pass the coretest.


\ Standard CATCH and THROW and ABORT from the EXCEPTION wordset:
loc:
  create handler  0 ,
  : abort  rdrop reset ['] boot execute ;
  : default-handler  dup -1 <>if  cr ." Unhandled exception: " . cr  then  abort ;
  :noname ( throw )  sp@ >r  handler @ >r  rp@ handler !  execute  r> handler !  rdrop  0 ;
  :noname ( catch )  0;  handler @ ?dup 0 =if  default-handler  ;then
    rp! r> handler !  r> swap >r sp!  drop  r> ;
;loc
  alias throw
  alias catch

: abort  -1 throw ;