rendered paste body: immediate ['] .self reclass ;
' | alias \ immediate \ Allows Standard line-comments
\ ANS Forth compatibility for RetroForth 9.2.8.
\ 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 Fixes CONSTANT VARIABLE CREATE DOES> and >BODY to behave as required.
\ Version 1.4 Removed redefinitions of SPACES and FILL (fixed in the kernel).
\
\ 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