Commit d23898c6 authored by anton's avatar anton

changed most state-smart words into words with interpretation: behaviour.

added postponetest.fs to "make test"
made HashTable into a value (for speed)
replaced 'flag!' by lastflags, cset, creset, ctoggle
parent 10524ce9
......@@ -103,6 +103,7 @@ GFORTH_FI_SRC = \
glocals.fs \
hash.fs \
history.fs \
interpretation.fs \
look.fs \
search-order.fs \
see.fs \
......@@ -130,7 +131,7 @@ FORTH_SRC = $(KERN_SRC) $(GFORTH_FI_SRC) \
site-init.fs \
tt.fs sokoban.fs \
wordsets.fs \
tester.fs coretest.fs dbltest.fs \
tester.fs coretest.fs postponetest.fs dbltest.fs \
bubble.fs siev.fs matrix.fs fib.fs
SOURCES = CVS compat Makefile.in configure.in configure config.sub config.guess \
......@@ -283,7 +284,7 @@ check: test
touch test
test: gforth gforth.fi
$(FORTH) tester.fs coretest.fs dbltest.fs -e bye
$(FORTH) tester.fs coretest.fs postponetest.fs dbltest.fs -e bye
$(FORTH) code.fs checkans.fs -e bye
@echo 'Expect no differences'
$(FORTH) prims2x.fs -e "s\" primitives.b\" ' output-c process-file bye"| diff -c - primitives.i
......@@ -303,22 +304,22 @@ gforth: $(OBJECTS)
@MAKE_EXE@
kernl16l.fi-: $(KERN_SRC) mach16l.fs $(FORTH_GEN0)
$(FORTHK) -p . -e 's" mach16l.fs"' main.fs -e "save-cross kernl16l.fi- $(bindir)/gforth-$(VERSION) bye"
$(FORTHK) -p . interpretation.fs -e 's" mach16l.fs"' main.fs -e "save-cross kernl16l.fi- $(bindir)/gforth-$(VERSION) bye"
kernl16b.fi-: $(KERN_SRC) mach16b.fs $(FORTH_GEN0)
$(FORTHK) -p . -e 's" mach16b.fs"' main.fs -e "save-cross kernl16b.fi- $(bindir)/gforth-$(VERSION) bye"
$(FORTHK) -p . interpretation.fs -e 's" mach16b.fs"' main.fs -e "save-cross kernl16b.fi- $(bindir)/gforth-$(VERSION) bye"
kernl32l.fi-: $(KERN_SRC) mach32l.fs $(FORTH_GEN0)
$(FORTHK) -p . -e 's" mach32l.fs"' main.fs -e "save-cross kernl32l.fi- $(bindir)/gforth-$(VERSION) bye"
$(FORTHK) -p . interpretation.fs -e 's" mach32l.fs"' main.fs -e "save-cross kernl32l.fi- $(bindir)/gforth-$(VERSION) bye"
kernl32b.fi-: $(KERN_SRC) mach32b.fs $(FORTH_GEN0)
$(FORTHK) -p . -e 's" mach32b.fs"' main.fs -e "save-cross kernl32b.fi- $(bindir)/gforth-$(VERSION) bye"
$(FORTHK) -p . interpretation.fs -e 's" mach32b.fs"' main.fs -e "save-cross kernl32b.fi- $(bindir)/gforth-$(VERSION) bye"
kernl64l.fi-: $(KERN_SRC) mach64l.fs $(FORTH_GEN0)
$(FORTHK) -p . -e 's" mach64l.fs"' main.fs -e "save-cross kernl64l.fi- $(bindir)/gforth-$(VERSION) bye"
$(FORTHK) -p . interpretation.fs -e 's" mach64l.fs"' main.fs -e "save-cross kernl64l.fi- $(bindir)/gforth-$(VERSION) bye"
kernl64b.fi-: $(KERN_SRC) mach64b.fs $(FORTH_GEN0)
$(FORTHK) -p . -e 's" mach64b.fs"' main.fs -e "save-cross kernl64b.fi- $(bindir)/gforth-$(VERSION) bye"
$(FORTHK) -p . interpretation.fs -e 's" mach64b.fs"' main.fs -e "save-cross kernl64b.fi- $(bindir)/gforth-$(VERSION) bye"
kernl16b.fi: $(KERNLS)
-$(CP) kernl16b.fi kernl16b.fi~
......@@ -393,7 +394,7 @@ doc.fd: makedoc.fs float.fs search-order.fs glocals.fs environ.fs \
$(FORTHK) -p . -e "s\" doc.fd\"" makedoc.fs startup.fs code.fs -e bye
crossdoc.fd: $(KERN_SRC) $(FORTH_GEN0)
$(FORTHK) -p . -e 's" mach32l.fs"' main.fs
$(FORTHK) -p . interpretation.fs -e 's" mach32l.fs"' main.fs
gforth.texi: gforth.ds primitives.b ds2texi.fs prims2x.fs doc.fd crossdoc.fd
$(FORTHK) -p . ds2texi.fs -e "s\" gforth.ds\" r/o open-file throw ds2texi bye" >$@
......
......@@ -879,7 +879,7 @@ bigendian Constant bigendian
Create magic s" Gforth10" here over allot swap move
[char] 1 bigendian + cell + magic 7 + c!
char 1 bigendian + cell + magic 7 + c!
: save-cross ( "image-name" "binary-name" -- )
bl parse ." Saving to " 2dup type cr
......
......@@ -505,35 +505,32 @@ forth definitions
then ;
: TO ( c|w|d|r "name" -- ) \ core-ext,local
0 0 0. 0.0e0 { c: clocal w: wlocal d: dlocal f: flocal }
' dup >definer
state @
if
case
[ ' locals-wordlist >definer ] literal \ value
OF >body POSTPONE Aliteral POSTPONE ! ENDOF
[ ' clocal >definer ] literal
OF POSTPONE laddr# >body @ lp-offset, POSTPONE c! ENDOF
[ ' wlocal >definer ] literal
OF POSTPONE laddr# >body @ lp-offset, POSTPONE ! ENDOF
[ ' dlocal >definer ] literal
OF POSTPONE laddr# >body @ lp-offset, POSTPONE 2! ENDOF
[ ' flocal >definer ] literal
OF POSTPONE laddr# >body @ lp-offset, POSTPONE f! ENDOF
-&32 throw
endcase
else
[ ' locals-wordlist >definer ] literal =
if
>body !
else
-&32 throw
endif
endif ; immediate
0 0 0. 0.0e0 { c: clocal w: wlocal d: dlocal f: flocal }
' dup >definer
case
[ ' locals-wordlist >definer ] literal \ value
OF >body POSTPONE Aliteral POSTPONE ! ENDOF
[ ' clocal >definer ] literal
OF POSTPONE laddr# >body @ lp-offset, POSTPONE c! ENDOF
[ ' wlocal >definer ] literal
OF POSTPONE laddr# >body @ lp-offset, POSTPONE ! ENDOF
[ ' dlocal >definer ] literal
OF POSTPONE laddr# >body @ lp-offset, POSTPONE 2! ENDOF
[ ' flocal >definer ] literal
OF POSTPONE laddr# >body @ lp-offset, POSTPONE f! ENDOF
-&32 throw
endcase ; immediate
interpretation:
' dup >definer [ ' locals-wordlist >definer ] literal =
if
>body !
else
-&32 throw
endif ;
: locals|
\ don't use 'locals|'! use '{'! A portable and free '{'
\ implementation is anslocals.fs
\ implementation is compat/anslocals.fs
BEGIN
name 2dup s" |" compare 0<>
WHILE
......
......@@ -27,8 +27,8 @@ Variable revealed
\ Memory handling 10oct94py
Variable HashPointer
Variable HashTable
Variable HashIndex
0 Value HashTable
\ DelFix and NewFix are from bigFORTH 15jul94py
......@@ -49,7 +49,7 @@ Variable HashIndex
\ @var{bucket-addr} is the address of a cell that points to the first
\ element in the list of the bucket for the string @var{addr len}
wordlist-extend @ -rot hash xor ( bucket# )
cells HashTable @ + ;
cells HashTable + ;
: hash-find ( addr len wordlist -- nfa / false )
>r 2dup r> bucket @ (hashfind) ;
......@@ -85,7 +85,7 @@ Variable HashIndex
BEGIN @ dup @ WHILE dup 'initvoc REPEAT drop ;
: clearhash ( -- )
HashTable @ Hashlen cells bounds
HashTable Hashlen cells bounds
DO I @
BEGIN dup WHILE
dup @ swap HashPointer DelFix
......@@ -101,14 +101,14 @@ Create hashsearch-map ( -- wordlist-map )
\ hash allocate and vocabulary initialization 10oct94py
: hash-alloc ( addr -- addr ) HashTable @ 0= IF
Hashlen cells allocate throw HashTable !
HashTable @ Hashlen cells erase THEN
: hash-alloc ( addr -- addr ) HashTable 0= IF
Hashlen cells allocate throw TO HashTable
HashTable Hashlen cells erase THEN
HashIndex @ over ! 1 HashIndex +!
HashIndex @ Hashlen >=
IF clearhash
1 hashbits 1+ dup to hashbits lshift to hashlen
HashTable @ free
HashTable free
addall
THEN ;
......@@ -119,7 +119,7 @@ Create hashsearch-map ( -- wordlist-map )
BEGIN @ dup WHILE 2dup swap (reveal REPEAT
2drop r> insRule ! ;
' (initvoc) IS 'initvoc
' (initvoc) ' 'initvoc >body !
\ Hash-Find 01jan93py
......@@ -127,17 +127,17 @@ addall \ Baum aufbauen
\ Baumsuche ist installiert.
: hash-cold ( -- ) Defers 'cold
HashPointer off HashTable off HashIndex off
HashPointer off 0 TO HashTable HashIndex off
voclink
BEGIN @ dup @ WHILE
dup cell - @ >r
dup 'initvoc
r> over cell - !
REPEAT drop ;
' hash-cold IS 'cold
' hash-cold ' 'cold >body !
: .words ( -- )
base @ >r hex HashTable @ Hashlen 0
base @ >r hex HashTable Hashlen 0
DO cr i 2 .r ." : " dup i cells +
BEGIN @ dup WHILE
dup cell+ @ .name REPEAT drop
......@@ -150,7 +150,7 @@ addall \ Baum aufbauen
\ \ gives the number of words in the current wordlist
\ \ and the sum of squares for the sublist lengths
\ 0 0
\ hashtable @ Hashlen cells bounds DO
\ hashtable Hashlen cells bounds DO
\ 0 i BEGIN
\ @ dup WHILE
\ swap 1+ swap
......
......@@ -72,8 +72,10 @@ s" ~/.gforth-history" get-history
REPEAT 2drop THEN
tuck 2dup type 0 ;
: ctrl ( "<char>" -- ctrl-code )
char [char] @ - postpone Literal ; immediate
: ctrl ( compilation: "<char>" -- ) ( run-time: -- ctrl-code )
char [char] @ - postpone Literal ; immediate
interpretation: ( "<char>" -- ctrl-code )
char [char] @ - ;
Create lfpad #lf c,
......
......@@ -20,7 +20,9 @@
\ This file defines a mechanism for specifying special interpretation
\ semantics as well as the interpretation semantics of several words.
\ semantics and the interpretation semantics of several words.
require search-order.fs
table constant interpretation-semantics
......@@ -32,7 +34,7 @@ table constant interpretation-semantics
else
defers interpret-special
endif ;
IS interpret-special
' interpret-special >body !
: interpretation: ( -- colon-sys ) \ gforth
\G make the last word one with special interpretation semantics and
......@@ -45,6 +47,48 @@ IS interpret-special
interpretation-semantics set-current : reveal
r> set-current ;
\ !! split notfound and sfnumber in a compiler and an interpreter part?
\ ' [']
\ !! or keep it state-smart?
' [char] Alias Ascii immediate
interpretation: ( "char" -- c )
\ currently also the interpretation semantics of [char]
char ;
\ [I]
\ the following interpretation semantics definitions restrict the
\ preceeding word. However, this does not matter because these
\ restricted words are in interpretation-semantics and are never
\ interpreted like regular words.
\ we cannot use s" interpretively yet (to make a string for (sfind), so:
' S" lastcfa !
interpretation: ( "ccc<">" -- c-addr u )
[char] " parse
/line min >r s"-buffer r@ cmove
s"-buffer r> ;
' ." lastcfa !
interpretation: ( "ccc<">" -- )
[char] " parse type ;
' does> lastcfa !
interpretation: ( -- colon-sys ) ( name execution: -- addr )
align dodoes, here !does ]
defstart :-hook ;
' is lastcfa !
interpretation: ( addr "name" -- )
' >body ! ;
' what's lastcfa !
interpretation: ( "name" -- addr )
' >body @ ;
\ : foo
\ ." compilation semantics" ; immediate
\ interpretation:
......
......@@ -247,16 +247,14 @@ Defer source ( -- addr count ) \ core
\ Literal 17dec92py
: Literal ( compilation n -- ; run-time -- n ) \ core
state @ IF postpone lit , THEN ; immediate
postpone lit , ; immediate restrict
: ALiteral ( compilation addr -- ; run-time -- addr ) \ gforth
state @ IF postpone lit A, THEN ;
immediate
postpone lit A, ; immediate restrict
: char ( 'char' -- n ) \ core
bl word char+ c@ ;
: [char] ( compilation 'char' -- ; run-time -- n )
char postpone Literal ; immediate
' [char] Alias Ascii immediate
char postpone Literal ; immediate restrict
: (compile) ( -- ) \ gforth
r> dup cell+ >r @ compile, ;
......@@ -953,18 +951,10 @@ Avariable leave-sp leave-stack 3 cells + leave-sp !
immediate restrict
create s"-buffer /line chars allot
: S" ( compilation 'ccc"' -- ; run-time -- c-addr u ) \ core,file s-quote
[char] " parse
state @
IF
postpone SLiteral
ELSE
/line min >r s"-buffer r@ cmove
s"-buffer r>
THEN ; immediate
[char] " parse postpone SLiteral ; immediate restrict
: ." ( compilation 'ccc"' -- ; run-time -- ) \ core dot-quote
state @ IF postpone (.") ," align
ELSE [char] " parse type THEN ; immediate
postpone (.") ," align ; immediate restrict
: ( ( compilation 'ccc<close-paren>' -- ; run-time -- ) \ core,file paren
BEGIN
>in @ [char] ) parse nip >in @ rot - =
......@@ -998,12 +988,20 @@ create s"-buffer /line chars allot
\ Header states 23feb93py
: flag! ( 8b -- )
last @ dup 0= abort" last word was headerless"
cell+ tuck c@ xor swap c! ;
: immediate $20 flag! ;
: restrict $40 flag! ;
\ ' noop alias restrict
: 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! ;
: lastflags ( -- c-addr )
\ the address of the flags byte in the last header
\ 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 ;
\ Header 23feb93py
......@@ -1025,7 +1023,7 @@ defer header ( -- ) \ gforth
: input-stream-header ( "name" -- )
\ !! this is f83-implementation-dependent
align here last ! -1 A,
name, $80 flag! ;
name, $80 lastflags cset ;
: input-stream ( -- ) \ general
\ switches back to getting the name from the input stream ;
......@@ -1041,7 +1039,7 @@ create nextname-buffer 32 chars allot
nextname-buffer count
align here last ! -1 A,
string, cfalign
$80 flag!
$80 lastflags cset
input-stream ;
\ the next name is given in the string
......@@ -1064,7 +1062,9 @@ create nextname-buffer 32 chars allot
lastcfa @ ;
: Alias ( cfa "name" -- ) \ gforth
Header reveal , $80 flag! ;
Header reveal
$80 lastflags creset
dup A, lastcfa ! ;
: name>string ( nfa -- addr count ) \ gforth name-to-string
cell+ count $1F and ;
......@@ -1099,13 +1099,8 @@ Create ??? 0 , 3 c, char ? c, char ? c, char ? c,
\ DOES> 17mar93py
: DOES> ( compilation colon-sys1 -- colon-sys2 ; run-time nest-sys -- ) \ core does
state @
IF
;-hook postpone (does>) ?struc dodoes,
ELSE
align dodoes, here !does ]
THEN
defstart :-hook ; immediate
;-hook postpone (does>) ?struc dodoes,
defstart :-hook ; immediate restrict
\ Create Variable User Constant 17mar93py
......@@ -1145,22 +1140,13 @@ Create ??? 0 , 3 c, char ? c, char ? c, char ? c,
\ perform ;
: IS ( addr "name" -- ) \ gforth
' >body
state @
IF postpone ALiteral postpone !
ELSE !
THEN ; immediate
' >body postpone ALiteral postpone ! ; immediate restrict
' IS Alias TO ( addr "name" -- ) \ core-ext
immediate
immediate restrict
: What's ( "name" -- addr ) \ gforth
' >body
state @
IF
postpone ALiteral postpone @
ELSE
@
THEN ; immediate
' >body postpone ALiteral postpone @ ; immediate restrict
: Defers ( "name" -- ) \ gforth
' >body @ compile, ; immediate
......@@ -1245,6 +1231,9 @@ G -1 warnings T !
then
2drop 2drop ;
: (sfind) ( c-addr u -- nfa | 0 )
lookup @ (search-wordlist) ;
: sfind ( c-addr u -- xt n / 0 ) \ gforth
lookup @ search-wordlist ;
......@@ -1266,7 +1255,7 @@ G -1 warnings T !
: ' ( "name" -- addr ) \ core tick
name sfind 0= if -&13 bounce then ;
: ['] ( compilation "name" -- ; run-time --addr ) \ core bracket-tick
' postpone ALiteral ; immediate
' postpone ALiteral ; immediate restrict
\ Input 13feb93py
07 constant #bell ( -- c ) \ gforth
......
......@@ -203,7 +203,7 @@ print-token !
: ` ( -- terminal ) ( use: ` c )
( creates anonymous terminal for the character c )
[compile] ascii singleton ['] ?nextchar make-terminal ;
char singleton ['] ?nextchar make-terminal ;
char a char z .. char A char Z .. union char _ singleton union charclass letter
char 0 char 9 .. charclass digit
......
......@@ -34,7 +34,7 @@ Variable vp
AVariable voclink
Defer 'initvoc
' drop IS 'initvoc
' drop ' 'initvoc >body !
Variable slowvoc slowvoc off
......
......@@ -20,6 +20,7 @@
warnings off
require interpretation.fs
\ include float.fs
\ include search-order.fs
include glocals.fs
......
......@@ -83,7 +83,7 @@ User (i)
: [LOOP] ( -- ) 1 rdrop rdrop ; immediate
: [FOR] ( n -- ) 0 swap postpone [DO] ; immediate
: [NEXT] ( n -- ) -1 rdrop rdrop ; immediate
: [I] ( -- index ) (I) @ postpone Literal ; immediate
: [I] ( -- index ) (I) @ postpone Literal ; immediate restrict
: [BEGIN] >in @ >r BEGIN r@ >in ! interpret UNTIL rdrop ;
immediate
' [+LOOP] Alias [UNTIL] immediate
......
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