: immediate ['] .self reclass ; : ?immediate ( xt -- flag ) >entry :class @ dup ['] .self = swap ['] .macro = or ; ' | alias \ immediate \ Allows Standard line-comments \ ANS Forth compatibility layer 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 \ \ This layer provides: \ - Near-100% Standard Forth compliance (see 'Caveats for Progammers', below). \ - Standard multiple-wordlist and search-order support. \ - Standard CATCH/THROW error handling with extensible full-text error messages. \ - Double-number recognition at the console. \ - The ability to find UPPERCASE versions of lowercase words. \ - A .S that displays only what's on the stack. \ - Speed-optimized LITERALs. \ \ >>> Caveats for programmers: \ \ RetroForth's >IN is non-standard. \ RetroForth does not have SOURCE. \ RetroForth's MOVE does not pass coretest. \ RetroForth does not have ACCEPT . \ \ >>> Standard words available with this file loaded: \ \ ] \ [char] ['] [ xor words wordlist word within while variable until unloop um/mod \ um* u> u< u. type tuck true throw then swap state spaces space sm/rem sign set-order \ set-current search-wordlist s>d s" rshift rot repeat recurse r@ r> previous postpone \ parse pad over order or only nip negate move mod min max m+ m* lshift loop literal \ leave key j invert immediate if i hold hex here get-order get-current forth-wordlist \ forth fm/mod find fill false exit execute evaluate emit else dup drop does> do dnegate \ depth definitions decimal dabs d>s d2* d.r d. d+ create cr count constant chars char+ \ char cells cell+ catch c@ c, c! bye bl begin base and also allot aligned align \ again abs abort" abort @ ?dup ?do >r >number >in >body > = <> <# < ; :noname : \ 2variable 2swap 2r@ 2r> 2over 2dup 2drop 2@ 2>r 2/ 2* 2! 1- 1+ 0> 0= 0< /string /mod \ / .s .( ." . - , +loop +! + */mod */ * ( ' #s #> # ! compile, \ \ >>> 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 2nip (ud.) variable: \ \ >>> 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 wordpad \ \ *** Changelog: \ \ 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 reset STATE. \ Added 2VARIABLE place place, count \ Version 1.7 Minor changes; added list of provided words. \ Version 1.8 Enhanced >NUMBER to accept lower-case letters when base > 10. \ Added 2nip UD. D. DNEGATE and /STRING. Enhanced the RetroForth interpreter \ to allow double-cell values with embedded '.'. \ Support $ # % & and ' (character) prefixes, though the character prefix is \ set to an equivalent base of 256, rather than RetroForth's 255 (a bug?) \ With the character prefix, more than 4 characters results in a double-cell value. \ (e.g. 'elephant d. -> 7308327828777430644 ) \ Version 1.9 Adjusted lookup and word? to force all dictionary searches to match \ forced lower-case versions. \ Version 1.10 Fixed a search-order bug introduced in version 1.9. \ Version 1.11 Fixed a bug with '-prefixed numbers. \ Version 1.12 Minor changes. \ Version 1.13 Bug in the dictionary lookup fixed. \ Version 1.14 Added .( M+ D2* Redefined ['] \ Version 1.15 Bugfix for D. Added D.R DABS \ Added a bugfix for RetroForth's SPACES . \ Version 1.16 Redefined RetroForth's variable: to produce compliant variables. \ Simplified D+ Moved BL so it is defined as a real constant. \ Added STATE TRUE >IN and FALSE as real constants. \ Added ?DO . Fixed an issue with postponing inlined words. \ Version 1.17 Removed all use of { }. Added COMPILE, Changed WORD not to use PAD. \ Version 1.18 Minor changes. Re-ordering for readability. \ Version 1.19 Further reordering. \ Version 1.20 Relocated LITERAL upward so it will be used in subsequent code. \ Added BASE as a real constant. decimal :: $fc4689 3, $fc768d 3, $b8 1, , ; is literal \ auto-inlining version of LITERAL ' not alias invert ' 1+ alias char+ ' :: alias :noname ' ;; alias exit immediate ' r alias r@ immediate ' r alias i immediate \ works both in RetroForth for/next and in ANS do-loops ' >> alias rshift ' << alias lshift ' eval alias evaluate ' 1, alias c, ' drop alias d>s ' compile alias compile, ' # alias (.) : chars ; immediate : 0= 0 = ; : 0< 0 < ; : 0> 0 > ; : 2* 1 lshift ; : abs dup 0> tuck xor - ; : .( ') parse type ; immediate : 2@ dup cell+ @ swap @ ; : 2! swap over ! cell+ ! ; \ 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 : 2>r postpone swap postpone >r postpone >r ; immediate : 2r> postpone r> postpone r> postpone swap ; immediate : 2r@ postpone 2r> postpone 2dup postpone 2>r ; immediate : aligned [ 1 cells 1- dup ] literal + [ invert ] literal and ; : align here aligned h0 ! ; : min 2dup if drop ;then nip ; : count dup char+ swap c@ ; : /string 2dup - >r nip + r> ; : ?dup dup 0; ; : 2over >r >r 2dup r> -rot r> -rot ; : 2swap rot >r rot r> ; : 2nip 2swap 2drop ; : ahead $e9 1, here 0 , ; immediate : else postpone ahead swap postpone then ; immediate : begin here ; immediate : while postpone if swap ; immediate : repeat postpone again postpone then ; immediate : resolve ( dest orig -- ) over cell+ - swap ! ; : until postpone while resolve ; immediate \ Stack pointer access: : sp@ dup [ $f089 2, ] ; \ mov eax,esi : sp! [ $c689 2, ] drop ; \ mov esi,eax : rp@ postpone dup $e089 2, ; immediate : rp! $c489 2, postpone 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 ; : mu* swap over * >r um* r> + ; : mu/mod >r 0 r@ um/mod r> swap >r um/mod r> ; : */mod >r m* r> sm/rem ; : */ */mod nip ; : xt>flag ( xt -- 1 | -1 ) ?immediate 1 and 1 << 1- ; : (find) lookup if dup xt>flag ;then 2drop 0 ; : find dup count (find) rot drop ; : throw vector ; \ Defined below. ' drop is throw \ A temporary definition. : ' wsparse lookup 0= -13 and throw ; \ redefined to be Standard-compliant : ['] ' literal, ; immediate : constant postpone : literal, postpone ; ['] .inline reclass ; \ Redefine RetroForth's non-Standard constants and variables: true constant true false constant false state constant state >in constant >in base constant base : variable: align here swap , constant ; : variable 0 variable: ; : 2variable align here 0 , 0 , constant ; variable last-created : (does) r> last-created @ ! ; : does> postpone (does) ; immediate : create postpone : 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 + @ ; 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/ dup 1 rshift swap highbit and or ; : within over - >r - r> u< ; : d+ >r rot over + dup >r u> if 1+ then r> swap r> + ; : m+ s>d d+ ; : d2* 2dup d+ ; : dnegate invert swap invert swap 1 0 d+ ; : dabs dup 0< if dnegate then ; 32 constant bl : char bl parse drop c@ ; : [char] char literal, ; immediate : place ( str len addr -- ) 2dup c! char+ swap move ; : place, ( str len -- ) here over char+ allot place ; : num>char dup 9 > 7 and + '0 + ; : char>num dup '9 > 39 and - '0 - ; : >lower dup 91 if 32 + then then ; : digit? >lower char>num dup 0 base @ within ; create pad 84 allot create wordpad 32 allot : word wordpad >r parse r@ place r> ; : spaces 0 max begin dup while space 1- repeat drop ; \ RetroForth bug-fix \ 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 char hold ; : #s begin # 2dup or 0= until ; : (ud.) <# #s #> type ; : d.r >r tuck dabs <# #s rot sign #> r> over - spaces type ; : d. 0 d.r space ; : . s>d d. ; : u. 0 d. ; \ >>> Dictionary and word-lookup enhancements. \ Add Standard wordlist and search-order support: : 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 and to search for \ forced-lowercase names: loc: create reduce-buffer 31 allot :: 2dup reduce-buffer swap move nip reduce-buffer swap 2dup for dup c@ >lower over c! 1+ next drop ; ;loc alias reduce : (lookup) search-order @ for search-order r cells + @ set-current d: lookup if rdrop true ;then next false ; :: get-current >r (lookup) dup 0 =if drop 2dup reduce (lookup) dup 0 =if nip nip then dup if 2nip then then r> set-current ; is lookup : 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 ; \ Redefine WORDS for correct behaviour: :: get-current definitions d: words set-current ; is words \ An implementation of SEARCH-WORDLIST: : search-wordlist search-order @ >r search-order cell+ @ >r 1 search-order ! search-order cell+ ! (find) r> search-order cell+ ! r> search-order ! ; \ Undefined words throw the appropriate exception: :: dup if -13 throw ;then 2drop 0 ; is word? \ Enhance parse to track the most-recently parsed word for THROW: 2variable last-parsed :: 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 \ *** CATCH/THROW and friends from the EXCEPTION wordset. variable exception-list : 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 @ begin 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 \ *** A .S that makes use of DEPTH: : (.s) depth 0 >if >r recurse r> dup . then ; : .s depth ." <" (.) ." > " (.s) cr ; \ *** A compliant implementation of DO/LOOP and friends. : (do) 0 literal, here cell- \ the leave address, to be backpatched by +LOOP later postpone >r ( leave ) postpone swap postpone >r ( limit ) postpone >r ( index ) postpone begin ; immediate : unloop postpone rdrop postpone rdrop postpone 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 ; : ?resolve-do if postpone then then ; : (+loop) literal, postpone (loop) here swap ! \ backpatch the leave address ; immediate : +loop postpone (+loop) ?resolve-do ; immediate : loop 1 literal, postpone (+loop) ?resolve-do ; immediate : do false postpone (do) ; immediate : ?do postpone 2dup postpone =if postpone 2drop postpone else true postpone (do) ; immediate : j 2r> 2r> r@ -rot 2>r -rot 2>r ; \ *** Numeric conversion. The extra code comes from defining a new Standard >NUMBER \ while enhancing the RetroForth internal >number to support double-cell values. : (>number) \ Standard version, named to temporarily avoid clashing. >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> ; \ Redefine RetroForth's internal >number used by the interpreter: loc: variable starting-base : save-base base @ starting-base ! ; : restore-base starting-base @ base ! ; variable negative : negative? negative off over c@ '- = if negative on 1 /string then ; create prefixes ( # ) 10 c, ( $ ) 16 c, ( % ) 2 c, ( & ) 8 c, ( ' ) 255 c, : prefixed? over c@ '# - dup 0 5 within if prefixes + c@ base ! 1 /string else drop then ; create ascii-buffer 8 chars allot : >ascii 0 0 ascii-buffer 2! 8 min for count ascii-buffer r 1- + c! next drop ascii-buffer 2@ swap ; : success 2drop 2nip negative @ if dnegate then restore-base true ; :: ( addr u -- n true | d. true | addr u false ) dup 0 =if false ;then save-base 2dup negative? prefixed? base @ 255 = if restore-base 2nip >ascii true over 0= if nip then ;then 0 0 2swap (>number) dup 0 =if success ( single ) nip ;then over c@ '. =if 1 /string (>number) dup 0 =if success ( double ) ;then then ( failed ) 2drop 2drop restore-base false ; ;loc is >number ' (>number) alias >number \ Set the correct name.