Commit bcb3848f authored by pazsan's avatar pazsan

Beginning of a direct-flash Gforth

parent 6a40c07c
......@@ -96,6 +96,8 @@ end-macros
\ GFORTH minimal primitive set
\ ==============================================================
\ inner interpreter
align
Code: :docol
\ ': dout, \ only for debugging
# -2 , rp add.w:q
......@@ -105,13 +107,7 @@ end-macros
next,
End-Code
Code: :dovar
\ '2 dout, \ only for debugging
tos push.w:g
# 4 , w add.w:q
w , tos mov.w:g
next,
End-Code
align
Code: :docon
\ '2 dout, \ only for debugging
......@@ -120,6 +116,8 @@ end-macros
next,
End-Code
align
Code: :dovalue
\ '2 dout, \ only for debugging
tos push.w:g
......@@ -127,17 +125,23 @@ end-macros
next,
End-Code
align
Code: :dofield
4 [w] , tos add.w:g
next,
end-code
align
Code: :dodefer
\ # $05 , $E1 mov.b:g
4 [w] , w mov.w:g [w] , w mov.w:g
next1,
End-Code
align
Code: :dodoes ( -- pfa ) \ get pfa and execute DOES> part
\ '6 dout, \ only for debugging
\ # $06 , $E1 mov.b:g
......@@ -149,8 +153,18 @@ end-macros
# 4 , r1 add.w:q r1 , ip mov.w:g
next, \ execute does> part
End-Code
$C0FE here - allot
\ program flow
Code: :dovar
\ '2 dout, \ only for debugging
tos push.w:g
# 4 , w add.w:q
w , tos mov.w:g
next,
End-Code
\ program flow
Code ;s ( -- ) \ exit colon definition
\ '; dout, \ only for debugging
rp , w mov.w:g # 2 , rp add.w:q
......
......@@ -1751,7 +1751,11 @@ Ghost state drop
swap -rot bounds ?DO I c@ over X c! X char+ LOOP drop ;
2Variable last-string
X has? rom [IF] $60 [ELSE] $00 [THEN] Constant header-masks
: ht-header, ( addr count -- )
dup there swap last-string 2!
dup header-masks or T c, H bounds ?DO I c@ T c, H LOOP ;
: ht-string, ( addr count -- )
dup there swap last-string 2!
dup T c, H bounds ?DO I c@ T c, H LOOP ;
......@@ -2060,7 +2064,7 @@ $20 constant restrict-mask
>TARGET
X has? f83headerstring [IF]
: name, ( "name" -- ) bl word count ht-string, X cfalign ;
: name, ( "name" -- ) bl word count ht-header, X cfalign ;
[ELSE]
: name, ( "name" -- ) bl word count ht-lstring, X cfalign ;
[THEN]
......
......@@ -105,7 +105,8 @@ defer header ( -- ) \ gforth
: string, ( c-addr u -- ) \ gforth
\G puts down string as cstring
dup c, here swap chars dup allot move ;
dup [ has? rom [IF] ] $E0 [ [ELSE] ] alias-mask [ [THEN] ] or c,
here swap chars dup allot move ;
: longstring, ( c-addr u -- ) \ gforth
\G puts down string as longcstring
......@@ -115,14 +116,18 @@ defer header ( -- ) \ gforth
name-too-long?
dup max-name-length @ max max-name-length !
align here last !
[ has? ec [IF] ]
-1 A,
[ [ELSE] ]
current @ 1 or A, \ link field; before revealing, it contains the
\ tagged reveal-into wordlist
[ [THEN] ]
[ has? f83headerstring [IF] ]
string,
[ [ELSE] ]
longstring,
longstring, alias-mask lastflags cset
[ [THEN] ]
cfalign alias-mask lastflags cset ;
cfalign ;
: input-stream-header ( "name" -- )
parse-name name-too-short? header, ;
......@@ -383,6 +388,18 @@ has? peephole [IF]
\ \ Header states 23feb93py
\ problematic only for big endian machines
has? f83headerstring [IF]
: cset ( bmask c-addr -- )
tuck c@ or swap c! ;
: creset ( bmask c-addr -- )
tuck c@ swap invert and swap c! ;
: ctoggle ( bmask c-addr -- )
tuck c@ xor swap c! ;
[ELSE]
: cset ( bmask c-addr -- )
tuck @ or swap ! ;
......@@ -391,6 +408,7 @@ has? peephole [IF]
: ctoggle ( bmask c-addr -- )
tuck @ xor swap ! ;
[THEN]
: lastflags ( -- c-addr )
\ the address of the flags byte in the last header
......@@ -400,11 +418,11 @@ has? peephole [IF]
: immediate ( -- ) \ core
\G Make the compilation semantics of a word be to @code{execute}
\G the execution semantics.
immediate-mask lastflags cset ;
immediate-mask lastflags [ has? rom [IF] ] creset [ [ELSE] ] cset [ [THEN] ] ;
: restrict ( -- ) \ gforth
\G A synonym for @code{compile-only}
restrict-mask lastflags cset ;
restrict-mask lastflags [ has? rom [IF] ] creset [ [ELSE] ] cset [ [THEN] ] ;
' restrict alias compile-only ( -- ) \ gforth
\G Remove the interpretation semantics of a word.
......@@ -628,7 +646,21 @@ defer ;-hook ( sys2 -- sys1 )
: last? ( -- false / nfa nfa )
latest ?dup ;
has? ec 0= [IF]
Variable warnings ( -- addr ) \ gforth
G -1 warnings T !
has? ec [IF]
: reveal ( -- ) \ gforth
last?
if \ the last word has a header
dup ( name>link ) @ -1 =
if \ it is still hidden
current @ dup >r @ over ! r> !
else
drop
then
then ;
[ELSE]
: (reveal) ( nt wid -- )
wordlist-id dup >r
@ over ( name>link ) !
......@@ -636,13 +668,6 @@ has? ec 0= [IF]
\ make entry in wordlist-map
' (reveal) f83search reveal-method !
[ELSE]
: (reveal) ( nt wid -- )
dup >r @ over ! r> ! ;
[THEN]
Variable warnings ( -- addr ) \ gforth
G -1 warnings T !
: check-shadow ( addr count wid -- )
\G prints a warning if the string is already present in the wordlist
......@@ -665,17 +690,12 @@ G -1 warnings T !
if \ it is still hidden
dup ( name>link ) @ 1 xor ( nt wid )
2dup >r name>string r> check-shadow ( nt wid )
[ has? ec [IF] ]
(reveal)
[ [ELSE] ]
dup wordlist-map @ reveal-method perform
[ [THEN] ]
dup wordlist-map @ reveal-method perform
else
drop
then
then ;
has? EC 0= [IF]
: rehash ( wid -- )
dup wordlist-map @ rehash-method perform ;
[THEN]
......
......@@ -374,7 +374,7 @@ $1fffffff constant lcount-mask
: (x>int) ( cfa w -- xt )
\ get interpretation semantics of name
restrict-mask and
restrict-mask and [ has? rom [IF] ] 0= [ [THEN] ]
if
drop ['] compile-only-error
else
......@@ -423,7 +423,7 @@ has? f83headerstring [IF]
: name?int ( nt -- xt ) \ gforth
\G Like @code{name>int}, but perform @code{-2048 throw} if @i{nt}
\G has no interpretation semantics.
(name>x) restrict-mask and
(name>x) restrict-mask and [ has? rom [IF] ] 0= [ [THEN] ]
if
ticking-compile-only-error \ does not return
then
......@@ -438,12 +438,12 @@ has? f83headerstring [IF]
interpret/compile-comp @
then
[ [THEN] ]
r> immediate-mask and flag-sign
r> immediate-mask and [ has? rom [IF] ] 0= [ [THEN] ] flag-sign
;
: (name>intn) ( nfa -- xt +-1 )
(name>x) tuck (x>int) ( w xt )
swap immediate-mask and flag-sign ;
swap immediate-mask and [ has? rom [IF] ] 0= [ [THEN] ] flag-sign ;
const Create ??? 0 , 3 , char ? c, char ? c, char ? c,
\ ??? is used by dovar:, must be created/:dovar
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment