rendered paste body: 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 ;
: max 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 dup 64 >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 <if '- hold then ;
: # base @ mu/mod rot num>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.