Commit 5b1014dc authored by anton's avatar anton

eliminated state-smartness in ;code and sfnumber

immediate-flag is now $40 and restrict-flag $20
HEADER now stores the compilation wordlist in the header and
	REVEAL reveals into that wordlist
assorted cleanups
parent d23898c6
......@@ -37,13 +37,11 @@ vocabulary assembler ( -- ) \ tools-ext
: ;code ( colon-sys1 -- colon-sys2 ) \ tools-ext semicolon-code
( create the [;code] part of a low level defining word )
state @
IF
;-hook postpone (;code) ?struc postpone [
ELSE
align here lastxt code-address!
THEN
defstart init-asm ; immediate
;-hook postpone (;code) ?struc postpone [
defstart init-asm ; immediate
interpretation: ( -- colon-sys )
align here lastxt code-address!
defstart init-asm ;
: end-code ( colon-sys -- ) \ gforth end_code
( end a code definition )
......
......@@ -357,11 +357,11 @@ variable ResolveFlag
VARIABLE ^imm
>TARGET
: immediate 20 flag!
: immediate 40 flag!
^imm @ @ dup <imm> = IF drop EXIT THEN
<res> <> ABORT" CROSS: Cannot immediate a unresolved word"
<imm> ^imm @ ! ;
: restrict 40 flag! ;
: restrict 20 flag! ;
>CROSS
\ ALIAS2 ansforth conform alias 9may93jaw
......
......@@ -100,26 +100,36 @@ DOES> ( -- r )
require debugging.fs
: sfnumber ( c-addr u -- r / )
2dup [CHAR] e scan
: sfnumber ( c-addr u -- r true | false )
2dup [CHAR] e scan ( c-addr u c-addr2 u2 )
dup 0=
IF
2drop 2dup [CHAR] E scan
2drop 2dup [CHAR] E scan ( c-addr u c-addr3 u3 )
THEN
nip
IF
2dup >float
IF
2drop state @
IF
POSTPONE FLiteral
THEN
EXIT
THEN
THEN
defers notfound ;
>float
ELSE
2drop false
THEN ;
' sfnumber IS notfound
:noname ( c-addr u -- )
2dup sfnumber
IF
2drop POSTPONE FLiteral
ELSE
defers compiler-notfound
ENDIF ;
IS compiler-notfound
:noname ( c-addr u -- r )
2dup sfnumber
IF
2drop
ELSE
defers interpreter-notfound
ENDIF ;
IS interpreter-notfound
: fvariable ( -- )
Create 0.0E0 f, ;
......
......@@ -3198,9 +3198,11 @@ Not implemented (yet).
@table @i
@item changing the compilation wordlist (during compilation):
The definition is put into the wordlist that is the compilation wordlist
when @code{REVEAL} is executed (by @code{;}, @code{DOES>},
@code{RECURSIVE}, etc.).
The word is entered into the wordlist that was the compilation wordlist
at the start of the definition. Any changes to the name field (e.g.,
@code{immediate}) or the code field (e.g., when executing @code{DOES>})
are applied to the latest defined word (as reported by @code{last} or
@code{lastxt}), if possible, irrespective of the compilation wordlist.
@item search order empty (@code{previous}):
@code{abort" Vocstack empty"}.
......@@ -3218,7 +3220,7 @@ when @code{REVEAL} is executed (by @code{;}, @code{DOES>},
@chapter Emacs and Gforth
Gforth comes with @file{gforth.el}, an improved version of
@file{forth.el} by Goran Rydqvist (icluded in the TILE package). The
@file{forth.el} by Goran Rydqvist (included in the TILE package). The
improvements are a better (but still not perfect) handling of
indentation. I have also added comment paragraph filling (@kbd{M-q}),
commenting (@kbd{C-x \}) and uncommenting (@kbd{C-u C-x \}) regions and
......@@ -3243,7 +3245,7 @@ several tags files at the same time (e.g., one for the Gforth sources
and one for your program, @pxref{Select Tags Table,,Selecting a Tags
Table,emacs, Emacs Manual}). The TAGS file for the preloaded words is
@file{$(datadir)/gforth/$(VERSION)/TAGS} (e.g.,
@file{/usr/local/share/gforth/0.2/TAGS}).
@file{/usr/local/share/gforth/0.2.0/TAGS}).
To get all these benefits, add the following lines to your @file{.emacs}
file:
......@@ -3298,7 +3300,7 @@ limitations: GNU C, the version of C processed by the GNU C compiler
GNU C Manual}). Its labels as values feature (@pxref{Labels as Values, ,
Labels as Values, gcc.info, GNU C Manual}) makes direct and indirect
threading possible, its @code{long long} type (@pxref{Long Long, ,
Double-Word Integers, gcc.info, GNU C Manual}) corresponds to Forths
Double-Word Integers, gcc.info, GNU C Manual}) corresponds to Forth's
double numbers@footnote{Unfortunately, long longs are not implemented
properly on all machines (e.g., on alpha-osf1, long longs are only 64
bits, the same size as longs (and pointers), but they should be twice as
......
......@@ -254,7 +254,8 @@ previous
: new-locals-reveal ( -- )
true abort" this should not happen: new-locals-reveal" ;
create new-locals-map ' new-locals-find A, ' new-locals-reveal A,
create new-locals-map ( -- wordlist-map )
' new-locals-find A, ' new-locals-reveal A,
vocabulary new-locals
new-locals-map ' new-locals >body cell+ A! \ !! use special access words
......
......@@ -59,7 +59,7 @@ Variable HashIndex
: lastlink! ( addr link -- )
BEGIN dup @ dup WHILE nip REPEAT drop ! ;
: (reveal ( addr voc -- )
: (reveal ( nfa wid -- )
dup wordlist-extend @ 0<
IF
2drop EXIT
......@@ -74,11 +74,8 @@ Variable HashIndex
THEN
revealed on ;
: hash-reveal ( -- )
(reveal) last?
IF
current @ (reveal
THEN ;
: hash-reveal ( nfa wid -- )
2dup (reveal) (reveal ;
: addall ( -- )
voclink
......
......@@ -44,7 +44,7 @@ table constant interpretation-semantics
restrict
lastcfa cell nextname \ !! use nfa instead of cfa
get-current >r
interpretation-semantics set-current : reveal
interpretation-semantics set-current :
r> set-current ;
\ !! split notfound and sfnumber in a compiler and an interpreter part?
......
......@@ -145,17 +145,21 @@ HEX
\ name> found 17dec92py
$80 constant alias-mask \ set when the word is not an alias!
$40 constant immediate-mask
$20 constant restrict-mask
: (name>) ( nfa+cell -- cfa )
1 cells - name>string + cfaligned ;
: name> ( nfa -- cfa ) \ gforth
cell+
dup (name>) swap c@ $80 and 0= IF @ THEN ;
dup (name>) swap c@ alias-mask and 0= IF @ THEN ;
: found ( nfa -- cfa n ) \ gforth
cell+
dup c@ >r (name>) r@ $80 and 0= IF @ THEN
-1 r@ $40 and IF 1- THEN
r> $20 and IF negate THEN ;
dup c@ >r (name>) r@ alias-mask and 0= IF @ THEN
-1 r@ restrict-mask and IF 1- THEN
r> immediate-mask and IF negate THEN ;
\ (find) 17dec92py
......@@ -484,11 +488,13 @@ Defer parser
Defer name ( -- c-addr count ) \ gforth
\ get the next word from the input buffer
' (name) IS name
Defer notfound ( c-addr count -- )
Defer compiler-notfound ( c-addr count -- )
Defer interpreter-notfound ( c-addr count -- )
: no.extensions ( addr u -- )
2drop -&13 bounce ;
' no.extensions IS notfound
' no.extensions IS compiler-notfound
' no.extensions IS interpreter-notfound
: compile-only ( ... -- )
-&14 throw ;
......@@ -521,7 +527,7 @@ Defer interpret-special ( c-addr u xt -- ) \ !! use nfa instead of xt?
IF
2rdrop
ELSE
2r> notfound
2r> interpreter-notfound
THEN ;
' interpreter IS parser
......@@ -546,7 +552,7 @@ Defer interpret-special ( c-addr u xt -- ) \ !! use nfa instead of xt?
postpone Literal
2drop
ELSE
drop notfound
drop compiler-notfound
THEN ;
: [ ( -- ) \ core left-bracket
......@@ -1000,8 +1006,8 @@ create s"-buffer /line chars allot
\ aborts if the last defined word was headerless
last @ dup 0= abort" last word was headerless" cell+ ;
: immediate $20 lastflags cset ;
: restrict $40 lastflags cset ;
: immediate immediate-mask lastflags cset ;
: restrict restrict-mask lastflags cset ;
\ Header 23feb93py
......@@ -1017,14 +1023,16 @@ defer header ( -- ) \ gforth
\ puts down string as cstring
dup c, here swap chars dup allot move ;
: name, ( "name" -- ) \ gforth
name name-too-short? name-too-long?
string, cfalign ;
: input-stream-header ( "name" -- )
\ !! this is f83-implementation-dependent
align here last ! -1 A,
name, $80 lastflags cset ;
: header, ( c-addr u -- ) \ gforth
name-too-long?
align here last !
current @ 1 or A, \ link field; before revealing, it contains the
\ tagged reveal-into wordlist
string, cfalign
alias-mask lastflags cset ;
: input-stream-header ( "name" -- )
name name-too-short? header, ;
: input-stream ( -- ) \ general
\ switches back to getting the name from the input stream ;
['] input-stream-header IS (header) ;
......@@ -1035,11 +1043,7 @@ defer header ( -- ) \ gforth
create nextname-buffer 32 chars allot
: nextname-header ( -- )
\ !! f83-implementation-dependent
nextname-buffer count
align here last ! -1 A,
string, cfalign
$80 lastflags cset
nextname-buffer count header,
input-stream ;
\ the next name is given in the string
......@@ -1063,7 +1067,7 @@ create nextname-buffer 32 chars allot
: Alias ( cfa "name" -- ) \ gforth
Header reveal
$80 lastflags creset
alias-mask lastflags creset
dup A, lastcfa ! ;
: name>string ( nfa -- addr count ) \ gforth name-to-string
......@@ -1072,7 +1076,7 @@ create nextname-buffer 32 chars allot
Create ??? 0 , 3 c, char ? c, char ? c, char ? c,
: >name ( cfa -- nfa ) \ gforth to-name
$21 cell do
dup i - count $9F and + cfaligned over $80 + = if
dup i - count $9F and + cfaligned over alias-mask + = if
i - cell - unloop exit
then
cell +loop
......@@ -1170,16 +1174,10 @@ AVariable current ( -- addr ) \ gforth
: last? ( -- false / nfa nfa )
last @ ?dup ;
: (reveal) ( -- )
last?
IF
dup @ 0<
IF
current @ @ over ! current @ !
ELSE
drop
THEN
THEN ;
: (reveal) ( nfa wid -- )
( wid>wordlist-id ) dup >r
@ over ( name>link ) !
r> ! ;
\ object oriented search list 17mar93py
......@@ -1187,7 +1185,7 @@ AVariable current ( -- addr ) \ gforth
struct
1 cells: field find-method \ xt: ( c_addr u wid -- name-id )
1 cells: field reveal-method \ xt: ( -- ) \ used by dofield:, must be field
1 cells: field reveal-method \ xt: ( nfa wid -- ) \ used by dofield:, must be field
1 cells: field rehash-method \ xt: ( wid -- )
\ \ !! what else
end-struct wordlist-map-struct
......@@ -1199,10 +1197,12 @@ struct
1 cells: field wordlist-extend \ points to wordlist extensions (eg hash)
end-struct wordlist-struct
: f83find ( addr len wordlist -- nfa / false ) @ (f83find) ;
: f83find ( addr len wordlist -- nfa / false )
( wid>wordlist-id ) @ (f83find) ;
\ Search list table: find reveal
Create f83search ' f83find A, ' (reveal) A, ' drop A,
Create f83search ( -- wordlist-map )
' f83find A, ' (reveal) A, ' drop A,
Create forth-wordlist NIL A, G f83search T A, NIL A, NIL A,
AVariable lookup G forth-wordlist lookup T !
......@@ -1244,10 +1244,15 @@ G -1 warnings T !
then ;
: reveal ( -- ) \ gforth
last? if
name>string current @ check-shadow
then
current @ wordlist-map @ reveal-method perform ;
last?
if \ the last word has a header
dup ( name>link ) @ 1 and
if \ it is still hidden
dup ( name>link ) @ 1 xor ( nfa wid )
2dup >r name>string r> check-shadow ( nfa wid )
dup wordlist-map @ reveal-method perform
then
then ;
: rehash ( wid -- )
dup wordlist-map @ rehash-method perform ;
......@@ -1572,8 +1577,8 @@ create image-included-files 1 , A, ( pointer to and count of included files )
: recurse ( compilation -- ; run-time ?? -- ?? ) \ core
lastxt compile, ; immediate restrict
: recursive ( -- ) \ gforth
reveal last off ; immediate
' reveal alias recursive ( -- ) \ gforth
immediate
\ */MOD */ 17may93jaw
......
......@@ -32,7 +32,7 @@ decimal
\ : >name ( xt -- nfa )
\ BEGIN 1 chars -
\ dup c@ 128 and
\ dup c@ alias-mask and
\ UNTIL ;
: PrimStart ['] true >name ;
......
......@@ -81,7 +81,8 @@ Variable slowvoc slowvoc off
\ (including locals)
\ this is the wordlist-map of the dictionary
Create vocsearch ' (localsvocfind) A, ' (reveal) A, ' drop A,
Create vocsearch ( -- wordlist-map )
' (localsvocfind) A, ' (reveal) A, ' drop A,
\ Only root 14may93py
......
......@@ -590,8 +590,9 @@ create wordtypes
wordtypes
BEGIN dup @ dup
WHILE 2 pick = IF cell+ @ nip EXECUTE
r> dup 32 and IF ." immediate" THEN
64 and IF ." restrict" THEN EXIT THEN
r> dup immediate-mask and IF ." immediate" THEN
restrict-mask and IF ." restrict" THEN
EXIT THEN
2 cells +
REPEAT
2drop rdrop
......
......@@ -24,7 +24,9 @@ Create sleepers sleepers A, sleepers A, 0 ,
\ USER' computes the task offset
: user' ( 'user' -- n )
' >body @ state @ IF postpone Literal THEN ; immediate
' >body @ postpone literal ; immediate
interpretation:
' >body @ ;
\ NEWTASK creates a new, sleeping task
: NewTask ( n -- Task ) dup 2* 2* udp @ + dup
......
......@@ -32,7 +32,7 @@ INCLUDE look.fs
\ it in many respects - anton
: alias? ( nfa1 -- nfa2|0 )
\ if nfa1 is an alias, nfa2 is the name of the original word
cell+ dup c@ $80 and 0=
cell+ dup c@ alias-mask and 0=
IF
(name>) @ >name ( use look instead? )
ELSE
......
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