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.

cross.fs

 \ 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)
 \ Copyright 1992 by the ANSI figForth Development Group
 
@@ -23,6 +23,12 @@
 
 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
 
 \ number?                                               11may93jaw
@@ -155,10 +161,10 @@ endian  0 pad ! -1 pad c! pad @ 0<
 \ Fixed bug in else part                               11may93jaw
 
 [IFDEF] Memory \ Memory is a bigFORTH feature
-   Memory
+   also Memory
    : initmem ( var len -- )
      2dup swap handle! >r @ r> erase ;
-   Target
+   toss
 [ELSE]
    : initmem ( var len -- )
      tuck allocate abort" CROSS: No memory for target"
@@ -263,8 +269,10 @@ Variable atonce atonce off
 : gfind   ( string -- ghost true/1 / string false )
 \ searches for string in word-list ghosts
 \ !! wouldn't it be simpler to just use search-wordlist ? ae
-  >r get-order  0 set-order also ghosts  r> find >r >r
-  set-order  r> r@  IF  >body  THEN  r> ;
+  dup count [ ' ghosts >body ] ALiteral search-wordlist
+\ >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
 

engine.c

 /*
-  $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
 */
 
@@ -14,16 +14,10 @@
 #include <stdlib.h>
 #include <time.h>
 #include <sys/time.h>
+#include <sys/unistd.h>
 #include "forth.h"
 #include "io.h"
 
-#ifndef unlink
-	extern unlink(char *);
-#endif
-#ifndef ftruncate
-	extern ftruncate(int, int);
-#endif
-
 typedef union {
   struct {
 #ifdef BIG_ENDIAN
@@ -87,30 +81,6 @@ int emitcounter;
 
 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)
 /* executes code at ip, if ip!=NULL
    returns array of machine code labels (for use in a loader), if ip==NULL

gforth.texi

@@ -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
 standard document for the exact rules).
 
-@subsetion Data stack
+@subsection Data stack
 drop
 nip
 dup

glocals.fs

@@ -74,6 +74,7 @@ include search-order.fs
 vocabulary locals \ this contains the local variables
 ' locals >body Constant locals-list \ acts like a variable that contains
 				    \ a linear list of locals names
+: locals-list! ( list -- )  locals-list ! locals-list rehash ;
 
 create locals-buffer 1000 allot \ !! limited and unsafe
     \ 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
  else
    0 0
  endif
- locals-list !
+ locals-list!
  locals-size ! ;
 
 : check-begin ( list -- )
@@ -446,12 +447,12 @@ variable dead-code \ true if normal code at "here" would be dead
  dead-code @
  if
    >resolve
-   locals-list !
+   locals-list!
    locals-size !
  else
    locals-size @ 3 roll - compile-lp+!#
    >resolve
-   locals-list @ common-list locals-list !
+   locals-list @ common-list locals-list!
    locals-size @  locals-list @ list-size - compile-lp+!#
  endif
  dead-code off ; immediate
@@ -461,7 +462,7 @@ variable dead-code \ true if normal code at "here" would be dead
 
 : endscope ( dest -- )
  drop
- locals-list @ common-list locals-list !
+ locals-list @ common-list locals-list!
  locals-size @  locals-list @ list-size - compile-lp+!#
  drop ; immediate
 
@@ -622,7 +623,7 @@ variable leave-sp  leave-stack leave-sp !
     clear-leave-stack
     0 locals-size !
     locals-buffer locals-dp !
-    0 locals-list ! ; ( clear locals vocabulary )
+    0 locals-list! ; ( clear locals vocabulary )
 
 : locals-;-hook ( sys addr xt -- sys )
     0 TO locals-wordlist

kernal.fs

@@ -131,6 +131,7 @@ Defer source
   dup count chars bounds
   ?DO  I c@ toupper I c! 1 chars +LOOP ;
 : (name)  ( -- addr )  bl word ;
+: (cname) ( -- addr )  bl word capitalize ;
 
 \ Literal                                              17dec92py
 
@@ -594,27 +595,35 @@ AVariable current
 
 \ word list structure:
 \ 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 rehash-method \ xt: ( wid -- )
 \   \ !! what else
 \ end-struct wordlist-map-struct
 
 \ struct
 \   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 ????
-\   1 cells: field ????
+\   1 cells: field wordlist-link \ link field to other wordlists
+\   1 cells: field wordlist-extend \ points to wordlist extensions (eg hash)
 \ end-struct wordlist-struct
 
+: f83find      ( addr len wordlist -- nfa / false )  @ (f83find) ;
+: f83casefind  ( addr len wordlist -- nfa / false )  @ (f83casefind) ;
 
 \ 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,
 AVariable search       G forth-wordlist search T !
 G forth-wordlist current T !
 
 : (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) dup  IF  found  THEN ;
@@ -644,6 +653,8 @@ Variable warnings  G -1 warnings T !
  then
  current @ cell+ @ cell+ @ execute ;
 
+: rehash  ( wid -- )  dup cell+ @ cell+ cell+ @ execute ;
+
 : '    ( "name" -- addr )  name find 0= no.extensions ;
 : [']  ( "name" -- addr )  ' postpone ALiteral ; immediate
 \ Input                                                13feb93py

primitives

@@ -621,7 +621,14 @@ wior = a_addr2==NULL;	/* !! Define a return code */
 
 (f83find)	c_addr u f83name1 -- f83name2	new	paren_f83find
 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? */)
     break;
 f83name2=f83name1;
@@ -817,7 +824,7 @@ else
 represent		r c_addr u -- n f1 f2	float
 char *sig;
 int flag;
-sig=ecvt(r, u, &n, &flag);
+sig=ecvt(r, u, (int *)&n, &flag);
 f1=FLAG(flag!=0);
 f2=FLAG(isdigit(sig[0])!=0);
 memmove(c_addr,sig,u);
@@ -829,7 +836,7 @@ char number[u+1];
 char *endconv;
 cstr(number, c_addr, u);
 r=strtod(number,&endconv);
-if(flag=FLAG(!(int)*endconv))
+if((flag=FLAG(!(int)*endconv)))
 {
 	IF_FTOS(fp[0] = FTOS);
 	fp += -1;
@@ -839,7 +846,7 @@ else if(*endconv=='d' || *endconv=='D')
 {
 	*endconv='E';
 	r=strtod(number,&endconv);
-	if(flag=FLAG(!(int)*endconv))
+	if((flag=FLAG(!(int)*endconv)))
 	{
 		IF_FTOS(fp[0] = FTOS);
 		fp += -1;
@@ -978,4 +985,4 @@ lp -= sizeof(Float);
 *(Float *)lp = r;
 
 up!	a_addr --	new	up_store
-up=a_addr;
+up=(char *)a_addr;

search-order.fs

@@ -2,8 +2,8 @@
 
 $10 constant maxvp
 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 @ ;
 : set-current  ( wid -- )  current ! ;
@@ -11,12 +11,57 @@ Variable vp
 : context ( -- addr )  vp dup @ cells + ;
 : 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
 
 AVariable voclink
 
 : 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 ! ;
 
 : Vocabulary ( -- ) Create wordlist drop  DOES> context ! ;
@@ -29,7 +74,7 @@ AVariable voclink
 
 \ vocabulary find                                      14may93py
 
-: (vocfind)  ( addr count nfa1 -- nfa2|false )
+: (vocfind)  ( addr count wid -- nfa2|false )
     \ !! generalize this to be independent of vp
     drop 1 vp @
     DO  2dup vp I cells + @ (search-wordlist) dup
@@ -41,7 +86,7 @@ AVariable voclink
 
 0 value locals-wordlist
 
-: (localsvocfind)  ( addr count nfa1 -- nfa2|false )
+: (localsvocfind)  ( addr count wid -- nfa2|false )
     \ !! use generalized (vocfind)
     drop locals-wordlist
     IF 2dup locals-wordlist (search-wordlist) dup
@@ -57,7 +102,8 @@ AVariable voclink
 \  (including locals)
 
 \ 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
 
@@ -77,6 +123,8 @@ Only Forth also definitions
 
 search A! \ our dictionary search order becomes the law
 
+' Forth >body AConstant Forth-wordlist
+
 \ get-order set-order                                  14may93py
 
 : get-order  ( -- wid1 .. widn n )