: 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 Fixes 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 \ \ 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+ : 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 ; \ An optimized auto-inlining LITERAL: :: $fc4689 3, $fc768d 3, $b8 1, , ; is literal : throw vector ; \ Defined a bit further down, needed here by ' \ This redefines ' to be compliant: : ' wsparse lookup 0 =if -13 throw then ; \ 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 lastcreate : (does) r> lastcreate @ ! ; : does> c: (does) ; immediate : create x: : 0 literal, here 1 cells - \ for backpatch, below 0 literal, here 1 cells - lastcreate ! \ for DOES> to use later postpone execute postpone ; align 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. \ 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" -- ) align here exception-list @ , swap , exception-list ! lnparse place, align ; : .exception ( n -- ) 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 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? :: d: parse 2dup last-parsed 2! ; is parse ' :: alias :noname ' ;; alias exit 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 ' 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. : 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 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 ; : */mod >r m* r> sm/rem ; : */ */mod nip ; : chars ; immediate