Commit 94adafcb authored by pazsan's avatar pazsan

added an experimental hash table (search/order.fs)

allowed the user to select caps-stored names or even case-
sensitive search.
Made gforth.texi compilable.
parent 2c6934a3
\ CROSS.FS The Cross-Compiler 06oct92py \ CROSS.FS The Cross-Compiler 06oct92py
\ $Id: cross.fs,v 1.4 1994-05-18 17:29:50 pazsan Exp $ \ $Id: cross.fs,v 1.5 1994-06-01 10:05:14 pazsan Exp $
\ Idea and implementation: Bernd Paysan (py) \ Idea and implementation: Bernd Paysan (py)
\ Copyright 1992 by the ANSI figForth Development Group \ Copyright 1992 by the ANSI figForth Development Group
...@@ -23,6 +23,12 @@ ...@@ -23,6 +23,12 @@
include other.fs \ ansforth extentions for cross include other.fs \ ansforth extentions for cross
: comment? ( c-addr u -- c-addr u )
2dup s" (" compare 0=
IF postpone (
ELSE 2dup s" \" compare 0= IF postpone \ THEN
THEN ;
decimal decimal
\ number? 11may93jaw \ number? 11may93jaw
...@@ -155,10 +161,10 @@ endian 0 pad ! -1 pad c! pad @ 0< ...@@ -155,10 +161,10 @@ endian 0 pad ! -1 pad c! pad @ 0<
\ Fixed bug in else part 11may93jaw \ Fixed bug in else part 11may93jaw
[IFDEF] Memory \ Memory is a bigFORTH feature [IFDEF] Memory \ Memory is a bigFORTH feature
Memory also Memory
: initmem ( var len -- ) : initmem ( var len -- )
2dup swap handle! >r @ r> erase ; 2dup swap handle! >r @ r> erase ;
Target toss
[ELSE] [ELSE]
: initmem ( var len -- ) : initmem ( var len -- )
tuck allocate abort" CROSS: No memory for target" tuck allocate abort" CROSS: No memory for target"
...@@ -263,8 +269,10 @@ Variable atonce atonce off ...@@ -263,8 +269,10 @@ Variable atonce atonce off
: gfind ( string -- ghost true/1 / string false ) : gfind ( string -- ghost true/1 / string false )
\ searches for string in word-list ghosts \ searches for string in word-list ghosts
\ !! wouldn't it be simpler to just use search-wordlist ? ae \ !! wouldn't it be simpler to just use search-wordlist ? ae
>r get-order 0 set-order also ghosts r> find >r >r dup count [ ' ghosts >body ] ALiteral search-wordlist
set-order r> r@ IF >body THEN r> ; \ >r get-order 0 set-order also ghosts r> find >r >r
>r r@ IF >body nip THEN r> ;
\ set-order r> r@ IF >body THEN r> ;
VARIABLE Already VARIABLE Already
......
/* /*
$Id: engine.c,v 1.6 1994-05-18 17:29:52 pazsan Exp $ $Id: engine.c,v 1.7 1994-06-01 10:05:15 pazsan Exp $
Copyright 1992 by the ANSI figForth Development Group Copyright 1992 by the ANSI figForth Development Group
*/ */
...@@ -14,16 +14,10 @@ ...@@ -14,16 +14,10 @@
#include <stdlib.h> #include <stdlib.h>
#include <time.h> #include <time.h>
#include <sys/time.h> #include <sys/time.h>
#include <sys/unistd.h>
#include "forth.h" #include "forth.h"
#include "io.h" #include "io.h"
#ifndef unlink
extern unlink(char *);
#endif
#ifndef ftruncate
extern ftruncate(int, int);
#endif
typedef union { typedef union {
struct { struct {
#ifdef BIG_ENDIAN #ifdef BIG_ENDIAN
...@@ -87,30 +81,6 @@ int emitcounter; ...@@ -87,30 +81,6 @@ int emitcounter;
static char* fileattr[6]={"r","rb","r+","r+b","w+","w+b"}; static char* fileattr[6]={"r","rb","r+","r+b","w+","w+b"};
#if ~defined(select) && defined(DOS)
/* select replacement for DOS computers for ms only */
void select(int n, int a, int b, int c, struct timeval * timeout)
{
struct timeval time1;
struct timeval time2;
struct timezone zone1;
gettimeofday(&time1,&zone1);
time1.tv_sec += timeout->tv_sec;
time1.tv_usec += timeout->tv_usec;
while(time1.tv_usec >= 1000000)
{
time1.tv_usec -= 1000000;
time1.tv_sec++;
}
do
{
gettimeofday(&time2,&zone1);
}
while(time2.tv_usec < time1.tv_usec || time2.tv_sec < time1.tv_sec);
}
#endif
Label *engine(Xt *ip, Cell *sp, Cell *rp, Float *fp, Address lp) Label *engine(Xt *ip, Cell *sp, Cell *rp, Float *fp, Address lp)
/* executes code at ip, if ip!=NULL /* executes code at ip, if ip!=NULL
returns array of machine code labels (for use in a loader), if ip==NULL returns array of machine code labels (for use in a loader), if ip==NULL
......
...@@ -327,7 +327,7 @@ standard complying program and if you are using local variables in a ...@@ -327,7 +327,7 @@ standard complying program and if you are using local variables in a
word, forget about return stack manipulations in that word (see the word, forget about return stack manipulations in that word (see the
standard document for the exact rules). standard document for the exact rules).
@subsetion Data stack @subsection Data stack
drop drop
nip nip
dup dup
......
...@@ -74,6 +74,7 @@ include search-order.fs ...@@ -74,6 +74,7 @@ include search-order.fs
vocabulary locals \ this contains the local variables vocabulary locals \ this contains the local variables
' locals >body Constant locals-list \ acts like a variable that contains ' locals >body Constant locals-list \ acts like a variable that contains
\ a linear list of locals names \ a linear list of locals names
: locals-list! ( list -- ) locals-list ! locals-list rehash ;
create locals-buffer 1000 allot \ !! limited and unsafe create locals-buffer 1000 allot \ !! limited and unsafe
\ here the names of the local variables are stored \ here the names of the local variables are stored
...@@ -412,7 +413,7 @@ variable dead-code \ true if normal code at "here" would be dead ...@@ -412,7 +413,7 @@ variable dead-code \ true if normal code at "here" would be dead
else else
0 0 0 0
endif endif
locals-list ! locals-list!
locals-size ! ; locals-size ! ;
: check-begin ( list -- ) : check-begin ( list -- )
...@@ -446,12 +447,12 @@ variable dead-code \ true if normal code at "here" would be dead ...@@ -446,12 +447,12 @@ variable dead-code \ true if normal code at "here" would be dead
dead-code @ dead-code @
if if
>resolve >resolve
locals-list ! locals-list!
locals-size ! locals-size !
else else
locals-size @ 3 roll - compile-lp+!# locals-size @ 3 roll - compile-lp+!#
>resolve >resolve
locals-list @ common-list locals-list ! locals-list @ common-list locals-list!
locals-size @ locals-list @ list-size - compile-lp+!# locals-size @ locals-list @ list-size - compile-lp+!#
endif endif
dead-code off ; immediate dead-code off ; immediate
...@@ -461,7 +462,7 @@ variable dead-code \ true if normal code at "here" would be dead ...@@ -461,7 +462,7 @@ variable dead-code \ true if normal code at "here" would be dead
: endscope ( dest -- ) : endscope ( dest -- )
drop drop
locals-list @ common-list locals-list ! locals-list @ common-list locals-list!
locals-size @ locals-list @ list-size - compile-lp+!# locals-size @ locals-list @ list-size - compile-lp+!#
drop ; immediate drop ; immediate
...@@ -622,7 +623,7 @@ variable leave-sp leave-stack leave-sp ! ...@@ -622,7 +623,7 @@ variable leave-sp leave-stack leave-sp !
clear-leave-stack clear-leave-stack
0 locals-size ! 0 locals-size !
locals-buffer locals-dp ! locals-buffer locals-dp !
0 locals-list ! ; ( clear locals vocabulary ) 0 locals-list! ; ( clear locals vocabulary )
: locals-;-hook ( sys addr xt -- sys ) : locals-;-hook ( sys addr xt -- sys )
0 TO locals-wordlist 0 TO locals-wordlist
......
...@@ -131,6 +131,7 @@ Defer source ...@@ -131,6 +131,7 @@ Defer source
dup count chars bounds dup count chars bounds
?DO I c@ toupper I c! 1 chars +LOOP ; ?DO I c@ toupper I c! 1 chars +LOOP ;
: (name) ( -- addr ) bl word ; : (name) ( -- addr ) bl word ;
: (cname) ( -- addr ) bl word capitalize ;
\ Literal 17dec92py \ Literal 17dec92py
...@@ -594,27 +595,35 @@ AVariable current ...@@ -594,27 +595,35 @@ AVariable current
\ word list structure: \ word list structure:
\ struct \ struct
\ 1 cells: field find-method \ xt: ( c_addr u w1 -- name-id ) w1 is a method-\ specific wordlist-id (not the same as wid) \ 1 cells: field find-method \ xt: ( c_addr u wid -- name-id )
\ 1 cells: field reveal-method \ xt: ( -- ) \ 1 cells: field reveal-method \ xt: ( -- )
\ 1 cells: field rehash-method \ xt: ( wid -- )
\ \ !! what else \ \ !! what else
\ end-struct wordlist-map-struct \ end-struct wordlist-map-struct
\ struct \ struct
\ 1 cells: field wordlist-id \ not the same as wid; representation depends on implementation \ 1 cells: field wordlist-id \ not the same as wid; representation depends on implementation
\ 1 cells: field wordlist-map \ pointer to a wordlist-map-struct \ 1 cells: field wordlist-map \ pointer to a wordlist-map-struct
\ 1 cells: field ???? \ 1 cells: field wordlist-link \ link field to other wordlists
\ 1 cells: field ???? \ 1 cells: field wordlist-extend \ points to wordlist extensions (eg hash)
\ end-struct wordlist-struct \ end-struct wordlist-struct
: f83find ( addr len wordlist -- nfa / false ) @ (f83find) ;
: f83casefind ( addr len wordlist -- nfa / false ) @ (f83casefind) ;
\ Search list table: find reveal \ Search list table: find reveal
Create f83search ' (f83find) A, ' (reveal) A, Create f83search ' f83casefind A, ' (reveal) A, ' drop A,
: caps-name ['] (cname) IS name ['] f83find f83search ! ;
: case-name ['] (name) IS name ['] f83casefind f83search ! ;
: case-sensitive ['] (name) IS name ['] f83find f83search ! ;
Create forth-wordlist NIL A, G f83search T A, NIL A, NIL A, Create forth-wordlist NIL A, G f83search T A, NIL A, NIL A,
AVariable search G forth-wordlist search T ! AVariable search G forth-wordlist search T !
G forth-wordlist current T ! G forth-wordlist current T !
: (search-wordlist) ( addr count wid -- nfa / false ) : (search-wordlist) ( addr count wid -- nfa / false )
dup @ swap cell+ @ @ execute ; dup ( @ swap ) cell+ @ @ execute ;
: search-wordlist ( addr count wid -- 0 / xt +-1 ) : search-wordlist ( addr count wid -- 0 / xt +-1 )
(search-wordlist) dup IF found THEN ; (search-wordlist) dup IF found THEN ;
...@@ -644,6 +653,8 @@ Variable warnings G -1 warnings T ! ...@@ -644,6 +653,8 @@ Variable warnings G -1 warnings T !
then then
current @ cell+ @ cell+ @ execute ; current @ cell+ @ cell+ @ execute ;
: rehash ( wid -- ) dup cell+ @ cell+ cell+ @ execute ;
: ' ( "name" -- addr ) name find 0= no.extensions ; : ' ( "name" -- addr ) name find 0= no.extensions ;
: ['] ( "name" -- addr ) ' postpone ALiteral ; immediate : ['] ( "name" -- addr ) ' postpone ALiteral ; immediate
\ Input 13feb93py \ Input 13feb93py
......
...@@ -621,7 +621,14 @@ wior = a_addr2==NULL; /* !! Define a return code */ ...@@ -621,7 +621,14 @@ wior = a_addr2==NULL; /* !! Define a return code */
(f83find) c_addr u f83name1 -- f83name2 new paren_f83find (f83find) c_addr u f83name1 -- f83name2 new paren_f83find
for (; f83name1 != NULL; f83name1 = f83name1->next) for (; f83name1 != NULL; f83name1 = f83name1->next)
if (F83NAME_COUNT(f83name1)==u && !F83NAME_SMUDGE(f83name1) && if (F83NAME_COUNT(f83name1)==u &&
strncmp(c_addr, f83name1->name, u)== 0 /* or inline? */)
break;
f83name2=f83name1;
(f83casefind) c_addr u f83name1 -- f83name2 new paren_f83casefind
for (; f83name1 != NULL; f83name1 = f83name1->next)
if (F83NAME_COUNT(f83name1)==u &&
strncasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */) strncasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */)
break; break;
f83name2=f83name1; f83name2=f83name1;
...@@ -817,7 +824,7 @@ else ...@@ -817,7 +824,7 @@ else
represent r c_addr u -- n f1 f2 float represent r c_addr u -- n f1 f2 float
char *sig; char *sig;
int flag; int flag;
sig=ecvt(r, u, &n, &flag); sig=ecvt(r, u, (int *)&n, &flag);
f1=FLAG(flag!=0); f1=FLAG(flag!=0);
f2=FLAG(isdigit(sig[0])!=0); f2=FLAG(isdigit(sig[0])!=0);
memmove(c_addr,sig,u); memmove(c_addr,sig,u);
...@@ -829,7 +836,7 @@ char number[u+1]; ...@@ -829,7 +836,7 @@ char number[u+1];
char *endconv; char *endconv;
cstr(number, c_addr, u); cstr(number, c_addr, u);
r=strtod(number,&endconv); r=strtod(number,&endconv);
if(flag=FLAG(!(int)*endconv)) if((flag=FLAG(!(int)*endconv)))
{ {
IF_FTOS(fp[0] = FTOS); IF_FTOS(fp[0] = FTOS);
fp += -1; fp += -1;
...@@ -839,7 +846,7 @@ else if(*endconv=='d' || *endconv=='D') ...@@ -839,7 +846,7 @@ else if(*endconv=='d' || *endconv=='D')
{ {
*endconv='E'; *endconv='E';
r=strtod(number,&endconv); r=strtod(number,&endconv);
if(flag=FLAG(!(int)*endconv)) if((flag=FLAG(!(int)*endconv)))
{ {
IF_FTOS(fp[0] = FTOS); IF_FTOS(fp[0] = FTOS);
fp += -1; fp += -1;
...@@ -978,4 +985,4 @@ lp -= sizeof(Float); ...@@ -978,4 +985,4 @@ lp -= sizeof(Float);
*(Float *)lp = r; *(Float *)lp = r;
up! a_addr -- new up_store up! a_addr -- new up_store
up=a_addr; up=(char *)a_addr;
...@@ -2,8 +2,8 @@ ...@@ -2,8 +2,8 @@
$10 constant maxvp $10 constant maxvp
Variable vp Variable vp
0 A, 0 A, 0 A, 0 A, 0 A, 0 A, 0 A, 0 A, 0 A, 0 A, 0 A, 0 A, 0 A, 0 A, 0 A, 0 A,
0 A, 0 A, 0 A, 0 A, 0 A, 0 A, 0 A, 0 A, 0 A, 0 A, 0 A, 0 A, 0 A, 0 A, 0 A, 0 A,
: get-current ( -- wid ) current @ ; : get-current ( -- wid ) current @ ;
: set-current ( wid -- ) current ! ; : set-current ( wid -- ) current ! ;
...@@ -11,12 +11,57 @@ Variable vp ...@@ -11,12 +11,57 @@ Variable vp
: context ( -- addr ) vp dup @ cells + ; : context ( -- addr ) vp dup @ cells + ;
: definitions ( -- ) context @ current ! ; : definitions ( -- ) context @ current ! ;
\ hash search 29may94py
\ uses a direct hash mapped cache --- idea from Heinz Schnitter
: hashkey ( addr count -- key )
swap c@ toupper 3 * + $3F and ; \ gives a simple hash key
Variable hits
Variable fails
: hash-find ( addr count wid -- nfa / false )
>r 2dup hashkey
cells r@ 3 cells + @ + \ hashed addr
dup @
IF >r r@ @ cell+ c@ over =
IF 2dup r@ @ cell+ char+ capscomp 0=
IF 2drop r> @ rdrop 1 hits +! EXIT THEN THEN
r>
THEN r> swap >r @ (f83casefind) dup
IF dup r@ ! THEN rdrop 1 fails +! ;
: hash-reveal ( -- )
last?
IF dup cell+ count hashkey cells
current @ 3 cells + @ + !
(reveal)
THEN ;
: clear-hash ( wid -- ) 3 cells + @ $40 cells erase ;
Create hashsearch
' hash-find A, ' hash-reveal A, ' clear-hash A,
\ for testing
: .hash ( wid -- ) 3 cells + @ ?dup 0= ?EXIT cr
8 0 DO
8 0 DO dup I J 8 * + cells + @ dup
IF cell+ count $1F and tuck 10 min type
10 swap - spaces
ELSE drop 10 spaces THEN
LOOP
LOOP drop ;
\ wordlist Vocabulary also previous 14may93py \ wordlist Vocabulary also previous 14may93py
AVariable voclink AVariable voclink
: wordlist ( -- wid ) : wordlist ( -- wid )
here 0 A, Forth-wordlist cell+ @ A, voclink @ A, 0 A, here 0 A, hashsearch A, voclink @ A,
here cell+ A, here $40 cells dup allot erase
dup 2 cells + voclink ! ; dup 2 cells + voclink ! ;
: Vocabulary ( -- ) Create wordlist drop DOES> context ! ; : Vocabulary ( -- ) Create wordlist drop DOES> context ! ;
...@@ -29,7 +74,7 @@ AVariable voclink ...@@ -29,7 +74,7 @@ AVariable voclink
\ vocabulary find 14may93py \ vocabulary find 14may93py
: (vocfind) ( addr count nfa1 -- nfa2|false ) : (vocfind) ( addr count wid -- nfa2|false )
\ !! generalize this to be independent of vp \ !! generalize this to be independent of vp
drop 1 vp @ drop 1 vp @
DO 2dup vp I cells + @ (search-wordlist) dup DO 2dup vp I cells + @ (search-wordlist) dup
...@@ -41,7 +86,7 @@ AVariable voclink ...@@ -41,7 +86,7 @@ AVariable voclink
0 value locals-wordlist 0 value locals-wordlist
: (localsvocfind) ( addr count nfa1 -- nfa2|false ) : (localsvocfind) ( addr count wid -- nfa2|false )
\ !! use generalized (vocfind) \ !! use generalized (vocfind)
drop locals-wordlist drop locals-wordlist
IF 2dup locals-wordlist (search-wordlist) dup IF 2dup locals-wordlist (search-wordlist) dup
...@@ -57,7 +102,8 @@ AVariable voclink ...@@ -57,7 +102,8 @@ AVariable voclink
\ (including locals) \ (including locals)
\ this is the wordlist-map of the dictionary \ this is the wordlist-map of the dictionary
Create vocsearch ' (localsvocfind) A, ' (reveal) A, Create vocsearch
' (localsvocfind) A, ' (reveal) A, ' drop A,
\ Only root 14may93py \ Only root 14may93py
...@@ -77,6 +123,8 @@ Only Forth also definitions ...@@ -77,6 +123,8 @@ Only Forth also definitions
search A! \ our dictionary search order becomes the law search A! \ our dictionary search order becomes the law
' Forth >body AConstant Forth-wordlist
\ get-order set-order 14may93py \ get-order set-order 14may93py
: get-order ( -- wid1 .. widn n ) : get-order ( -- wid1 .. widn n )
......
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