rendered paste body: immediate ['] .self reclass ;
: ?immediate ( xt -- flag ) >entry :class @ ['] .forth <> ;
' | 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 Fixed CONSTANT VARIABLE CREATE DOES> and >BODY to behave as required.
\ Version 1.4 Removed redefinitions of SPACES and FILL (fixed in the kernel).
\ Version 1.5 Removed a redundant (does) definition.
\ Version 1.6 Added ALIGN to CREATE. Changed ' to be compliant.
\ Added text for all standard exception messages, with last-parsed reporting.
\ Enhanced lookup to fail on non-found words.
\ Enhanced ABORT to return to interpretation state.
\ Added 2VARIABLE place place, count
\ Version 1.7 Minor changes; added list of provided words.
\
\ *** List of provided words:
\
\ >>> Standard words:
\
\ # #> #s ' */ */mod +loop .s 0< 0= 0> 2! 2* 2/ 2>r 2@ 2over 2r> 2r@ 2swap
\ 2variable : :noname ; <# >body >number ?dup [char] \ abort abort" abs
\ ahead align aligned also begin bl c, catch char char+ chars constant count
\ create d+ definitions depth do does> else evaluate exit find
\ fm/mod forth forth-wordlist get-current get-order hold i immediate invert
\ j leave loop lshift m* m* max min mu* only order pad postpone previous r@
\ recurse repeat rshift s>d search-wordlist set-current set-order sign
\ sm/rem throw u< u> um* um/mod unloop until variable while within word
\ wordlist
\
\ >>> Other useful words:
\
\ (.) (find) .exception >lower ?immediate allbits char>num digit?
\ exception: highbit lowbits mu/mod num>char place place, rp! rp@
\ signsdiffer? sp! sp@ xt>flag
\
\ >>> Internal factors and other words not externally useful:
\
\ (.s) (abort") (does) (loop) (lookup) abort-msg current exception-list hld holdaddr
\ last-parsed last-created max-searches reduce resolve search-order
\
\
\ 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
' not alias invert
' 1+ alias char+
' :: alias :noname
' ;; alias exit immediate
' 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
' 1, alias c,
: 0= 0 = ;
: 0< 0 < ;
: 0> 0 > ;
: 2@ dup cell+ @ swap @ ;
: 2! swap over ! cell+ ! ;
: aligned [ 1 cells 1- dup ] literal + [ invert ] literal and ;
: align here aligned h0 ! ;
: count dup char+ swap c@ ;
: ?dup dup 0; ;
32 constant bl
\ Common-usage Forth words:
' # alias (.)
: place ( str len addr -- ) 2dup c! char+ swap move ;
: place, ( str len -- ) here over char+ allot place ;
:: $fc4689 3, $fc768d 3, $b8 1, , ; is literal \ auto-inlining version pf LITERAL
: throw vector ; \ Defined a bit further down, needed here by '
: ' wsparse lookup 0 =if -13 throw then ; \ adjusted to be Standard-compliant
\ The joy of POSTPONE is not having to wonder whether to use x: or c:
: postpone ' dup literal, ?immediate if c: execute ;then c: compile ; immediate
\ *** This redefines CONSTANT VARIABLE and CREATE/DOES>/>BODY to behave
\ as expected in a Standard system.
: constant postpone : literal, postpone ; ['] .inline reclass ;
: variable align here 0 , constant ;
: 2variable align here 0 , 0 , constant ;
variable last-created
: (does) r> last-created @ ! ;
: does> c: (does) ; immediate
: create x: :
0 literal, here 1 cells - \ for backpatch, below
0 literal, here 1 cells - last-created ! \ for DOES> to use later
postpone execute postpone ;
align here swap ! \ backpatch dataspace address
does> ;
: >body 7 + @ ;
\ *** This adds Standard search-order support:
\ Fundamental wordlist infrastructure:
: wordlist align 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 friends from the EXCEPTION wordset.
\ These are defined here as early as possible so subsequent words can be enhanced to
\ throw error codes as appropriate.
\ 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
variable exception-list
2variable last-parsed
: exception: ( n "text" -- ) \ For building the exception-message table.
align here exception-list @ , swap , exception-list !
lnparse place, align ;
: .exception ( n -- ) \ Report a specified exception.
last-parsed 2@ type ." <- Exception: "
exception-list @
repeat
2dup cell+ @ =if nip 2 cells + count type ;; then
@ dup 0 =if drop . ;; then
again ;
align here exception-list ! 0 , \ Initialize the list.
\ The list of Standard exception messages.
\ New messages can be added in any order at any time.
-1 exception: ABORT
-2 exception: ABORT"
-3 exception: stack overflow
-4 exception: stack underflow
-5 exception: return stack overflow
-6 exception: return stack underflow
-7 exception: do-loops nested too deeply during execution
-8 exception: dictionary overflow
-9 exception: invalid memory address
-10 exception: division by zero
-11 exception: result out of range
-12 exception: argument type mismatch
-13 exception: undefined word
-14 exception: interpreting a compile-only word
-15 exception: invalid FORGET
-16 exception: attempt to use zero-length string as a name
-17 exception: pictured numeric output string overflow
-18 exception: parsed string overflow
-19 exception: definition name too long
-20 exception: write to a read-only location
-21 exception: unsupported operation
-22 exception: control structure mismatch
-23 exception: address alignment exception
-24 exception: invalid numeric argument
-25 exception: return stack imbalance
-26 exception: loop parameters unavailable
-27 exception: invalid recursion
-28 exception: user interrupt
-29 exception: compiler nesting
-30 exception: obsolescent feature
-31 exception: >BODY used on non-CREATEd definition
-32 exception: invalid name argument
-33 exception: block read exception
-34 exception: block write exception
-35 exception: invalid block number
-36 exception: invalid file position
-37 exception: file I/O exception
-38 exception: non-existent file
-39 exception: unexpected end of file
-40 exception: invalid BASE for floating point conversion
-41 exception: loss of precision
-42 exception: floating-point divide by zero
-43 exception: floating-point result out of range
-44 exception: floating-point stack overflow
-45 exception: floating-point stack underflow
-46 exception: floating-point invalid argument
-47 exception: compilation word list deleted
-48 exception: invalid POSTPONE
-49 exception: search-order overflow
-50 exception: search-order underflow
-51 exception: compilation word list changed
-52 exception: control-flow stack overflow
-53 exception: exception: stack overflow
-54 exception: floating-point underflow
-55 exception: floating-point unidentified fault
-56 exception: QUIT
-57 exception: exception: in sending or receiving a character
-58 exception: [IF], [ELSE], or [THEN] exception
2variable abort-msg \ for ABORT"
loc:
create handler 0 ,
: abort rdrop reset only 0 state ! ['] boot execute ;
: default-handler
dup -2 = if ." *** aborted: " abort-msg 2@ type cr then
.exception cr abort ;
:: ( catch ) sp@ >r handler @ >r rp@ handler ! execute r> handler ! rdrop 0 ;
:: ( throw ) 0; handler @ ?dup 0 =if default-handler ;then
rp! r> handler ! r> swap >r sp! drop r> ;
;loc
is throw
alias catch
: abort -1 throw ;
: (abort") abort-msg 2! if -2 throw then ;
: abort" postpone s" postpone (abort") ; immediate
\ ... 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:
: 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
dup if -13 throw ;then 2drop 0 ; is word?
\ Enhance parse to track the most-recently parsed word for THROW:
:: d: parse 2dup last-parsed 2! ; is parse
\ 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.
\ 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.
: 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 ;
: */mod >r m* r> sm/rem ;
: */ */mod nip ;
: chars ; immediate