: immediate  ['] .self reclass ;
' | alias \ immediate    \ Allows Standard line-comments

\ 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
\
\ History:
\ Version 1.0  Original release
\ Version 1.1  Improved POSTPONE
\ Version 1.2  Added Standard search-order support.
\   Extended lookup to search for forced-lowercase names.
\   Relocated CATCH/THROW and ABORT earlier in the file.
\ Version 1.3  Fixeed CONSTANT VARIABLE CREATE DOES> and >BODY to behave as required.
\
\ TO DO:
\ coretest.fs tests involving  source  and  >in  do not presently work.
\ Range checking & throws as appropriate.
\ RetroForth's  move  does not pass coretest.
\ RetroForth does not have  accept .
 
decimal

\ The following hairy code redefines CONSTANT VARIABLE and CREATE/DOES>/>BODY
\ to behave as expected in a Standard system:

macro
: class> here 16 + x: literal 
  c: reclass x: ;; ;
loc:
  : (does) state @ if swap 
    literal, compile ;then 
    execute ;
  here ] x: class> here 16 + 
    literal, ['] (does) compile 
    x: ;; ;
;loc alias does>
forth

:: $fc4689 3, $fc768d 3, $b8 1, , ; is literal
: constant x: : x: literal x: ;  ['] .inline reclass ;
: variable  here 0 , constant ;

variable lastcreate
: (does) r> lastcreate @ ! ; 
: does>  c: (does) ; immediate
: create  x: :  as .forth
  0 literal,  here 1 cells -  \ for backpatch, below
  0 literal,  here 1 cells - lastcreate !
  c: execute  x: ;
  here swap !  \ backpatch dataspace address
  does> ; 
: >body  7 + @ ;


\ *** This adds Standard search-order support to RetroForth:

\ Fundamental wordlist infrastructure:

: wordlist  here 0 , ;

variable current
: set-current  last @ current @ !  dup current !  @ last ! ;
: get-current  current @ ;

wordlist constant forth-wordlist
last @ forth-wordlist !  forth-wordlist current !   \ Initialize the base wordlist

16 constant max-searches
create search-order  max-searches cells allot

: only  1 search-order !  forth-wordlist search-order cell+ ! ;

only  \ initialize the search order

\ Extend lookup to iterate over the search order:
: (lookup)
  search-order @ for
    search-order r cells + @ set-current
    d: lookup if  rdrop true  ;then
  next false ;
:: get-current >r (lookup) r> set-current ;  is lookup


\ *** A brief aside to define CATCH and THROW and ABORT from the EXCEPTION wordset.
\ These are defined here as early as possible so subsequent words can be enhanced to
\ throw error codes as appropriate.

\ A few prerequisite words:

: ?dup  dup 0; ;

\ 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
 
loc:
  create handler  0 ,
  : abort  rdrop reset  only  ['] boot execute ;
  : default-handler  dup -1 <>if  cr ." Unhandled exception: " . cr  then  abort ;
  :: ( throw )  sp@ >r  handler @ >r  rp@ handler !  execute  r> handler !  rdrop  0 ;
  :: ( 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 ;


\ ... search-order support continued:

: get-order
  search-order @ for  search-order @  r - 1+ cells search-order + @  next
  search-order @ ;
: order  get-order for . next '[ emit get-current # '] emit cr ;
: set-order  dup search-order !  for  search-order r cells + !  next ;
: definitions  get-order over set-current set-order ;
: also  get-order  over swap 1+ set-order ;
: previous  get-order  nip 1- set-order ;
: forth  get-order nip forth-wordlist swap set-order ;

\ Adjust WORDS for correct behaviour:
:: get-current definitions d: words set-current ; is words

\ An implementation of SEARCH-WORDLIST:

: ?immediate ( xt -- flag )  >entry :class @  ['] .forth  <> ;
 
: xt>flag ( xt -- 1 \ -1 )  ?immediate  1 and  1 <<  1- ;

: (find)  lookup if  dup xt>flag ;then  2drop 0 ;

: search-wordlist
  search-order @ >r  search-order cell+ @ >r
  1 search-order !  search-order cell+ !
  (find)
  r> search-order cell+ !  r> search-order ! ;

\ .... wordlist support is now complete.


\ *** Extend lookup to first search for forced-lowercase names:

: >lower  dup 91 <if dup 64 >if 32 + then then ;

: reduce  2dup for  dup c@ >lower  over c!  1+  next  drop ;
:: reduce lookup if  dup >entry :class @ execute true  ;then  d: word? ;  is word?


\ A few RetroForth words aliased directly to Standard names:
' :: alias :noname
' ;; alias exit  immediate
 
' # alias (.)          \ a common-usage alias.  # is redefined below.

 
\ The joy of POSTPONE is not having to wonder whether to use  x:  or  c:
: postpone  ' dup literal, ?immediate if { execute } ;then { compile } ; 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
  :noname ( recurse )  oldlast @ :xt @ compile  ; ( immediate )
  :noname ( ; )  oldlast @ last !  postpone ;  ; ( immediate )
  :noname ( : )  last @  postpone :  last @ oldlast !  last ! ;
;loc
  alias :
  alias ;  immediate
  alias recurse  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 ;
 
: 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 ;