rendered paste body| 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 ;