From 8537f5b3f6397f7a9fb930be056487212423493f Mon Sep 17 00:00:00 2001 From: Hannu Vuolasaho Date: Mon, 9 Mar 2015 00:28:07 +0200 Subject: [PATCH 01/12] supress biary objects --- build/unix/.gitignore | 2 ++ 1 file changed, 2 insertions(+) create mode 100644 build/unix/.gitignore diff --git a/build/unix/.gitignore b/build/unix/.gitignore new file mode 100644 index 0000000..d507244 --- /dev/null +++ b/build/unix/.gitignore @@ -0,0 +1,2 @@ +*.eo +*.o From b0f10cbb3dd99351cd3d08323a6e0ef0dcdb055d Mon Sep 17 00:00:00 2001 From: Hannu Vuolasaho Date: Mon, 9 Mar 2015 00:33:55 +0200 Subject: [PATCH 02/12] more binaries --- build/unix/.gitignore | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/build/unix/.gitignore b/build/unix/.gitignore index d507244..33fb3a4 100644 --- a/build/unix/.gitignore +++ b/build/unix/.gitignore @@ -1,2 +1,6 @@ *.eo *.o +pfdicdat.h +pforth +pforth.dic +pforth_standalone From 0dd201ef18e74e20de6bd5c8624130169ab4c3b4 Mon Sep 17 00:00:00 2001 From: Hannu Vuolasaho Date: Mon, 13 Apr 2015 00:47:28 +0300 Subject: [PATCH 03/12] First version of wordlists and search order Search order done with custom functions. First copies addresses forth->C and those are used in creating and finding. Another C function to implement search wordlist. To enable wordlist support Macro PF_SUPPORT_WORDLIST must be defined. To set wordlist count fth/search.fth and constant WORDLISTS is to place to look. This commit currently breaks all words which use latest and context. For example WORDS display current compilation word list. Also FORGET might be also broken. --- .gitignore | 1 + build/unix/Makefile | 9 ++- csrc/pf_all.h | 2 +- csrc/pf_guts.h | 2 + csrc/pf_search.c | 116 ++++++++++++++++++++++++++++ csrc/pf_search.h | 44 +++++++++++ csrc/pf_text.c | 46 +++++++----- csrc/pfcompil.c | 103 +++++++++++++++++++++++-- csrc/pfcustom.c | 20 ++++- fth/loadp4th.fth | 5 +- fth/search.fth | 179 ++++++++++++++++++++++++++++++++++++++++++++ 11 files changed, 494 insertions(+), 33 deletions(-) create mode 100644 .gitignore create mode 100644 csrc/pf_search.c create mode 100644 csrc/pf_search.h create mode 100644 fth/search.fth diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..b25c15b --- /dev/null +++ b/.gitignore @@ -0,0 +1 @@ +*~ diff --git a/build/unix/Makefile b/build/unix/Makefile index c1df0d0..815d222 100644 --- a/build/unix/Makefile +++ b/build/unix/Makefile @@ -50,16 +50,19 @@ EMBCCOPTS = -DPF_STATIC_DIC PFINCLUDES = pf_all.h pf_cglue.h pf_clib.h pf_core.h pf_float.h \ pf_guts.h pf_host.h pf_inc1.h pf_io.h pf_mem.h pf_save.h \ pf_text.h pf_types.h pf_win32.h pf_words.h pfcompfp.h \ - pfcompil.h pfdicdat_arm.h pfinnrfp.h pforth.h + pfcompil.h pfdicdat_arm.h pfinnrfp.h pforth.h pf_search.h PFBASESOURCE = pf_cglue.c pf_clib.c pf_core.c pf_inner.c \ pf_io.c pf_io_none.c pf_main.c pf_mem.c pf_save.c \ - pf_text.c pf_words.c pfcompil.c pfcustom.c + pf_text.c pf_words.c pfcompil.c pfcustom.c pf_search.c PFSOURCE = $(PFBASESOURCE) $(IO_SOURCE) VPATH = .:$(CSRCDIR):$(CSRCDIR)/posix:$(CSRCDIR)/stdio:$(CSRCDIR)/win32_console:$(CSRCDIR)/win32 XCFLAGS = $(CCOPTS) -XCPPFLAGS = -DPF_SUPPORT_FP -D_DEFAULT_SOURCE + +XCPPFLAGS = -DPF_SUPPORT_FP -D_DEFAULT_SOURCE -DPF_SUPPORT_WORDLIST +#XCPPFLAGS = -DPF_SUPPORT_FP -D_DEFAULT_SOURCE + XLDFLAGS = $(WIDTHOPT) CPPFLAGS = -I. $(XCPPFLAGS) diff --git a/csrc/pf_all.h b/csrc/pf_all.h index 560b287..69ee601 100644 --- a/csrc/pf_all.h +++ b/csrc/pf_all.h @@ -57,7 +57,7 @@ #include "pf_mem.h" #include "pf_cglue.h" #include "pf_core.h" - +#include "pf_search.h" #ifdef PF_USER_INC2 /* This could be used to undef and redefine macros. */ #include PF_USER_INC2 diff --git a/csrc/pf_guts.h b/csrc/pf_guts.h index 80df530..f836d3b 100644 --- a/csrc/pf_guts.h +++ b/csrc/pf_guts.h @@ -367,6 +367,8 @@ enum cforth_primitive_ids #define THROW_EXECUTING (-14) #define THROW_PAIRS (-22) #define THROW_FLOAT_STACK_UNDERFLOW ( -45) +#define THROW_SEARCH_OVERFLOW (-49) +#define THROW_SEARCH_UNDERFLOW (-50) #define THROW_QUIT (-56) /* THROW codes unique to pForth */ diff --git a/csrc/pf_search.c b/csrc/pf_search.c new file mode 100644 index 0000000..7f5057d --- /dev/null +++ b/csrc/pf_search.c @@ -0,0 +1,116 @@ +/* @(#) search.c 15/04/09 1.0 */ +/*************************************************************** +** search order for PForth based on 'C' +** +** Author: Hannu Vuolasaho +** Copyright 2015 3DO, Phil Burk, Larry Polansky, David Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +**/ +#include "pf_all.h" +#ifdef PF_SUPPORT_WORDLIST + +/* Search order and word list arrays */ +cell_t searchOrder; +cell_t searchFirstIndex; +cell_t wordLists; + +/* compilationIndex is wordLists[compilationIdnex], head of comp. list. */ +cell_t compilationIndex; + +/* Previous entry. Is the previous link. + * When new wordlist is created, it is zeroed. + */ +cell_t previousEntry; + +/* (init-wordlists) ( search_addr search_index wl_addr comp_index -- ) */ +void ffInitWordLists( cell_t search_addr, cell_t search_index, + cell_t wl_addr, cell_t comp_index ) +{ + compilationIndex = comp_index; + wordLists = wl_addr; + searchFirstIndex = search_index; + searchOrder = search_addr; + MSG_NUM_D("comp ind ", compilationIndex); + MSG_NUM_D("comp ind * ", *(cell_t *)compilationIndex); + MSG_NUM_D("wl ", wordLists ); + MSG_NUM_D("wl * ", *(cell_t *)wordLists ); + MSG_NUM_D("first ", searchFirstIndex); + MSG_NUM_D("first * ", *(cell_t *) searchFirstIndex); + MSG_NUM_D("order ", searchOrder); + MSG_NUM_D("order * ", *(cell_t *)searchOrder); + MSG_NUM_D("order name * ", NAMEREL_TO_ABS((*(cell_t *)searchOrder))); + MSG_NUM_D("order code * ", CODEREL_TO_ABS((*(cell_t *)searchOrder))); + MSG_NUM_D("order code * * ", *(cell_t *)(CODEREL_TO_ABS((*(cell_t *)searchOrder)))); +} +cell_t getWordList( cell_t index ) +{ + cell_t temp_addr; + if(wordLists) + { + /* Don't underflow search */ + if( index < 0 ) return (cell_t) NULL; + /* Address to wordlist */ + temp_addr = (CODEREL_TO_ABS(*(((cell_t *)searchOrder) + index))); + if(temp_addr) + { + return *(cell_t *)temp_addr; + } + else + { + /* Empty wordlist in search order */ + return (cell_t) NULL; + } + } + else + { + return gVarContext; + } +} +/* search-wordlist ( c-addr u wid -- 0 | xt 1 | xt -1 ) */ +cell_t ffSearchWordList( cell_t c_addr, cell_t u, cell_t wid) +{ + cell_t Searching = TRUE; + cell_t Result = 0; + uint8_t NameLen; + const char *NameField; + if( wid == 0 ) return 0; + /* wid is code relative address of wordlists */ + /* referencing give content of gVarContext of compilation time of last word */ + NameField = (ForthString *) *((cell_t *) (CODEREL_TO_ABS(wid)) ); + do + { + NameLen = (uint8_t) ((ucell_t)(*NameField) & MASK_NAME_SIZE); + if( ((*NameField & FLAG_SMUDGE) == 0) && + (NameLen == u) && + ffCompareTextCaseN( NameField +1, (const char *) c_addr, u ) ) + { + PUSH_DATA_STACK(NameField); /* XT to stack */ + Result = ((*NameField) & FLAG_IMMEDIATE) ? 1 : -1; + Searching = FALSE; + } + else + { + NameField = NameToPrevious( NameField ); + if( NameField == NULL ) + { + Searching = FALSE; + } + } + }while(Searching); + return Result; +} + +#endif + + + + + diff --git a/csrc/pf_search.h b/csrc/pf_search.h new file mode 100644 index 0000000..b3ec348 --- /dev/null +++ b/csrc/pf_search.h @@ -0,0 +1,44 @@ +/* @(#) search.h 15/04/09 1.0 */ +#ifndef _pf_search_h +#define _pf_search_h +/*************************************************************** +** search order for PForth based on 'C' +** +** Author: Hannu Vuolasaho +** Copyright 2015 3DO, Phil Burk, Larry Polansky, David Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +**/ + +#ifdef PF_SUPPORT_WORDLIST +#define PF_WORDLIST_EXPORT_FUNCTIONS (2) + +/* Search order and word list arrays */ + +extern cell_t searchFirstIndex; +extern cell_t wordLists; + +/* compilationIndex is wordLists[compilationIdnex], head of comp. list. */ +extern cell_t compilationIndex; + +/* (init-wordlists) ( search_addr search_index wl_addr comp_index -- ) */ +void ffInitWordLists( cell_t search_addr, cell_t search_index, + cell_t wl_addr, cell_t comp_index ); +/* search-wordlist ( c-addr u wid -- 0 | xt 1 | xt -1 ) */ +cell_t ffSearchWordList( cell_t c_addr, cell_t u, cell_t wid); + +/* Helper function. + * Get the head of wordlist in search order index 'index' */ +cell_t getWordList( cell_t index ); + +#else +#define PF_WORDLIST_EXPORT_FUNCTIONS (0) +#endif +#endif diff --git a/csrc/pf_text.c b/csrc/pf_text.c index 9325851..9e2a52c 100644 --- a/csrc/pf_text.c +++ b/csrc/pf_text.c @@ -35,11 +35,11 @@ void pfReportError( const char *FunctionName, Err ErrCode ) { const char *s; - + MSG("Error in "); MSG(FunctionName); MSG(" - "); - + switch(ErrCode & 0xFF) { case PF_ERR_NO_MEM & 0xFF: @@ -107,6 +107,12 @@ void pfReportThrow( ThrowCode code ) s = "Executing a compile-only word!"; break; case THROW_FLOAT_STACK_UNDERFLOW: s = "Float Stack underflow!"; break; +#ifdef PF_SUPPORT_WORDLIST + case THROW_SEARCH_OVERFLOW: + s = "Search order or wordlist owerflow!"; break; + case THROW_SEARCH_UNDERFLOW: + s = "Search order or wordlist underflow!"; break; +#endif case THROW_UNDEFINED_WORD: s = "Undefined word!"; break; case THROW_PAIRS: @@ -121,7 +127,7 @@ void pfReportThrow( ThrowCode code ) default: s = "Unrecognized throw code!"; break; } - + if( s ) { MSG_NUM_D("THROW code = ", code ); @@ -178,7 +184,7 @@ char *CStringToForth( char *dst, const char *CString, cell_t dstSize ) cell_t ffCompareText( const char *s1, const char *s2, cell_t len ) { cell_t i, Result; - + Result = TRUE; for( i=0; icfnl_PreviousName, + ABS_TO_NAMEREL( ( *((cell_t*)(wordLists)+ + *(cell_t*)(compilationIndex))))); + } + else + { + /* Empty wordlist doesn't have previous yet. */ + cfnl->cfnl_PreviousName = 0; + } + } + else + { + /* Wordlists aren't set up yet.*/ + WRITE_CELL_DIC( &cfnl->cfnl_PreviousName, ABS_TO_NAMEREL( gVarContext ) ); + } +#else WRITE_CELL_DIC( &cfnl->cfnl_PreviousName, ABS_TO_NAMEREL( gVarContext ) ); +#endif } else { @@ -407,9 +429,24 @@ cell_t ffTokenToName( ExecToken XT, const ForthString **NFAPtr ) cell_t Searching = TRUE; cell_t Result = 0; ExecToken TempXT; - +#ifdef PF_SUPPORT_WORDLIST + cell_t iterator; + if( wordLists ) + { + iterator = *(cell_t *) searchFirstIndex; + NameField = (ForthString *)getWordList(iterator); + --iterator; + } + else + { + /* Search order not yet initialized.*/ + NameField = (ForthString *) gVarContext; + iterator = 0; + } +#else NameField = (ForthString *) gVarContext; DBUGX(("\ffCodeToName: gVarContext = 0x%x\n", gVarContext)); +#endif do { @@ -427,8 +464,20 @@ DBUGX(("ffCodeToName: NFA = 0x%x\n", NameField)); NameField = NameToPrevious( NameField ); if( NameField == NULL ) { - *NFAPtr = 0; +#ifdef PF_SUPPORT_WORDLIST + if( wordLists && iterator >= 0) + { + NameField = (ForthString *)getWordList(iterator); + --iterator; + } + else + { +#endif + *NFAPtr = 0; Searching = FALSE; +#ifdef PF_SUPPORT_WORDLIST + } +#endif } } } while ( Searching); @@ -448,13 +497,36 @@ cell_t ffFindNFA( const ForthString *WordName, const ForthString **NFAPtr ) int8_t NameLen; cell_t Searching = TRUE; cell_t Result = 0; - +#ifdef PF_SUPPORT_WORDLIST + cell_t iterator; + if( wordLists ) + { + iterator = *(cell_t *) searchFirstIndex; + } + else + { + /* Search order not yet initialized.*/ + iterator = 0; + } +#endif WordLen = (uint8_t) ((ucell_t)*WordName & 0x1F); WordChar = WordName+1; - +#ifdef PF_SUPPORT_WORDLIST + if( wordLists ) + { + + NameField = (ForthString *)getWordList(iterator); + --iterator; + } + else{ + NameField = (ForthString *) gVarContext; + } + +#else NameField = (ForthString *) gVarContext; DBUG(("\nffFindNFA: WordLen = %d, WordName = %*s\n", WordLen, WordLen, WordChar )); DBUG(("\nffFindNFA: gVarContext = 0x%x\n", gVarContext)); +#endif do { NameLen = (uint8_t) ((ucell_t)(*NameField) & MASK_NAME_SIZE); @@ -474,8 +546,20 @@ DBUG(("ffFindNFA: found it at NFA = 0x%x\n", NameField)); NameField = NameToPrevious( NameField ); if( NameField == NULL ) { - *NFAPtr = WordName; - Searching = FALSE; +#ifdef PF_SUPPORT_WORDLIST + if( wordLists && iterator >= 0) + { + NameField = (ForthString *)getWordList(iterator); + --iterator; + } + else + { +#endif + *NFAPtr = WordName; + Searching = FALSE; +#ifdef PF_SUPPORT_WORDLIST + } +#endif } } } while ( Searching); @@ -690,6 +774,13 @@ void ffFinishSecondary( void ) { CODE_COMMA( ID_EXIT ); ffUnSmudge(); +#ifdef PF_SUPPORT_WORDLIST + /* Copy context to word list when they are available. */ + if( wordLists ) + { + *((cell_t*)(wordLists)+*(cell_t*)(compilationIndex)) = gVarContext; + } +#endif } /**************************************************************/ diff --git a/csrc/pfcustom.c b/csrc/pfcustom.c index 1cacea2..73d116b 100644 --- a/csrc/pfcustom.c +++ b/csrc/pfcustom.c @@ -63,12 +63,18 @@ static void CTest1( cell_t Val1, cell_t Val2 ) ** It is called by the pForth kernel. */ #define NUM_CUSTOM_FUNCTIONS (2) -CFunc0 CustomFunctionTable[NUM_CUSTOM_FUNCTIONS]; +CFunc0 CustomFunctionTable[NUM_CUSTOM_FUNCTIONS + PF_WORDLIST_EXPORT_FUNCTIONS]; Err LoadCustomFunctionTable( void ) { CustomFunctionTable[0] = CTest0; CustomFunctionTable[1] = CTest1; + /* Insert your functions here. */ + +#ifdef PF_SUPPORT_WORDLIST + CustomFunctionTable[NUM_CUSTOM_FUNCTIONS + 0] = ffInitWordLists; + CustomFunctionTable[NUM_CUSTOM_FUNCTIONS + 1] = ffSearchWordList; +#endif return 0; } @@ -81,6 +87,11 @@ CFunc0 CustomFunctionTable[] = { (CFunc0) CTest0, (CFunc0) CTest1 +#ifdef PF_SUPPORT_WORDLIST + , + (CFunc0) ffInitWordLists, + (CFunc0) ffSearchWordList +#endif }; #endif @@ -103,7 +114,12 @@ Err CompileCustomFunctions( void ) if( err < 0 ) return err; err = CreateGlueToC( "CTEST1", i++, C_RETURNS_VOID, 2 ); if( err < 0 ) return err; - +#ifdef PF_SUPPORT_WORDLIST + err = CreateGlueToC( "(INIT-WORDLISTS)", i++, C_RETURNS_VOID, 4 ); + if( err < 0 ) return err; + err = CreateGlueToC( "SEARCH-WORDLIST", i++, C_RETURNS_VALUE, 3 ); + if( err < 0 ) return err; +#endif return 0; } #else diff --git a/fth/loadp4th.fth b/fth/loadp4th.fth index 5cbfe2c..8fe0687 100644 --- a/fth/loadp4th.fth +++ b/fth/loadp4th.fth @@ -24,7 +24,10 @@ include? { locals.fth include? fm/mod math.fth include? task-misc2.fth misc2.fth include? [if] condcomp.fth - +\ load search order if support is in kernel +exists? (init-wordlists) + [IF] include? wordlists search.fth + [THEN] \ load floating point support if basic support is in kernel exists? F* [IF] include? task-floats.fth floats.fth diff --git a/fth/search.fth b/fth/search.fth new file mode 100644 index 0000000..86abaaf --- /dev/null +++ b/fth/search.fth @@ -0,0 +1,179 @@ +\ @(#) case.fth 15/04/10 0.1 +\ Search-Order wordset +\ +\ +\ +\ Author: Hannu Vuolasaho +\ Copyright 2015 3DO, Phil Burk, Larry Polansky, Devid Rosenboom +\ +\ The pForth software code is dedicated to the public domain, +\ and any third party may reproduce, distribute and modify +\ the pForth software code or any derivative works thereof +\ without any compensation or license. The pForth software +\ code is provided on an "as is" basis without any warranty +\ of any kind, including, without limitation, the implied +\ warranties of merchantability and fitness for a particular +\ purpose and their equivalents under the laws of any jurisdiction. + +anew task-search.fth + +\ This constant defines how many wordlist you get. Increase it +\ if more lists needed. +16 constant WORDLISTS + +\ Exeption codes +-49 constant ERR_SEARCH_OVERFLOW +-50 constant ERR_SEARCH_UNDERFLOW + +create forth-wordlist WORDLISTS cells allot +create [searchorder] WORDLISTS cells allot +variable wl.compile.index +variable wl.order.first +variable wl.used + + +\ works + +: wl.check ( index -- , throw if out of bounds ) + dup WORDLISTS >= ERR_SEARCH_OVERFLOW and throw + 0< ERR_SEARCH_UNDERFLOW and throw +; + +\ works + +: wl.check.wid ( wid -- throw if out of bounds ) + forth-wordlist if.use->rel dup wl.used @ + cells + ( wid min max ) + >r over ( wid min wid ) > ERR_SEARCH_UNDERFLOW and throw + r> > ERR_SEARCH_OVERFLOW and throw +; + +\ works + +: get-current ( -- wid , compilation word list ) + wl.compile.index @ cells forth-wordlist + if.use->rel +; + +\ works + +: get-order ( -- widn ... wid1 n ) + wl.order.first @ 1+ 0 + ?do + wl.order.first @ i - cells + [searchorder] + @ + loop + wl.order.first @ 1+ +; + +\ works +: set-current ( wid -- , compilation word list to wid ) + \ check wid + dup wl.check.wid + + \ make index and put it under + forth-wordlist use->rel - + cell / ( wid index-to-forth-wordlist ) + + wl.compile.index ! +; + +: definitions ( -- ) + \ get first in search order and set it to compilation + wl.order.first @ ( index ) + cells [searchorder] + @ ( wid ) + set-current +; + +\ works + +: set-order ( widn ... wid1 n -- , Set the search order ) + dup -1 = + if + drop forth-wordlist if.use->rel [searchorder] ! + 0 + else + dup wl.check + dup 0= + if + drop -1 + else + dup >r 0 do + i cells + [searchorder] + ! + loop + r> 1- + then + then + wl.order.first ! +; + +\ works + +: wordlist ( -- wid , Create a new empty word list ) + wl.used @ 1+ dup wl.check dup wl.used ! ( index , incerment and store ) + cells forth-wordlist + dup 0 swap ! ( addr , zero the wordlist ) + if.use->rel ( wid ) +; + +: also ( -- , copy first search wordlist to first in search order ) + get-order over swap 1+ set-order +; + +: forth ( -- , Remove first wordlist and put forth-wordlist as first ) + get-order nip forth-wordlist if.use->rel swap set-order +; + +: only ( -- , Set search order to forth-wordlist ) + -1 set-order +; + +\ works +: order ( -- , print search order wordlist ) + get-order 0 ?do + i . ." 0x" .hex cr + loop +; + +\ works +: previous ( -- ) get-order nip 1- set-order ; + +: init-wordlists ( -- , put forth context to forth-wordlist ) + WORDLISTS 1 do + 0 i cells forth-wordlist + ! + 0 i cells [searchorder] + ! + loop + context @ forth-wordlist ! + forth-wordlist if.use->rel [searchorder] ! + \ send variables to C + [searchorder] wl.order.first forth-wordlist wl.compile.index + (init-wordlists) +; +: auto.init + auto.init init-wordlists +; + + +\ implemented in C kernel +\ : search-wordlist ( c-addr u wid -- 0 | xt 1 | xt -1 ) + \ Find the definition identified by the string + \ c-addr u in the word list identified by wid +\ ; +\ : find ( c-addr -- c-addr 0 | xt 1 | xt -1 ) + \ Find named definitions from all word lists +\ ; + +: wordlists? ( -- ) + cr ." wordlists:" forth-wordlist dup use->rel .hex .hex cr + WORDLISTS 0 + do + forth-wordlist i cells + use->rel .hex i wl.used @ > if ." wl not in use: " then + i dup . cells forth-wordlist + @ .hex cr + loop + ." search order:" [searchorder] dup use->rel .hex .hex cr + WORDLISTS 1+ 1 ?do + WORDLISTS i - cells + [searchorder] + dup .hex @ + wl.order.first @ WORDLISTS i - < if ." order not in use: " then + WORDLISTS i - . .hex cr + loop +; From a30697991d06685937ade1dec258e83af22e6353 Mon Sep 17 00:00:00 2001 From: Hannu Vuolasaho Date: Mon, 13 Apr 2015 03:22:01 +0300 Subject: [PATCH 04/12] Cosmetic changes Renamed variables and commented more. --- csrc/pf_search.c | 63 +++++++++++++++++++++---------------------- csrc/pf_search.h | 10 +++---- csrc/pfcompil.c | 28 ++++++++++--------- fth/search.fth | 70 +++++++++++++++++++++++------------------------- 4 files changed, 83 insertions(+), 88 deletions(-) diff --git a/csrc/pf_search.c b/csrc/pf_search.c index 7f5057d..9571d7d 100644 --- a/csrc/pf_search.c +++ b/csrc/pf_search.c @@ -18,47 +18,46 @@ #ifdef PF_SUPPORT_WORDLIST /* Search order and word list arrays */ -cell_t searchOrder; -cell_t searchFirstIndex; -cell_t wordLists; +cell_t arrSearchOrder; + +/* global search order start index. points wl.order.first on forth. */ +cell_t gVarWlOrderFirst; +cell_t gVarWordLists; +/* gVarWlCompileIndex is gVarWordLists[compilationIdnex], head of comp. list. */ +cell_t gVarWlCompileIndex; -/* compilationIndex is wordLists[compilationIdnex], head of comp. list. */ -cell_t compilationIndex; -/* Previous entry. Is the previous link. - * When new wordlist is created, it is zeroed. - */ -cell_t previousEntry; /* (init-wordlists) ( search_addr search_index wl_addr comp_index -- ) */ void ffInitWordLists( cell_t search_addr, cell_t search_index, cell_t wl_addr, cell_t comp_index ) { - compilationIndex = comp_index; - wordLists = wl_addr; - searchFirstIndex = search_index; - searchOrder = search_addr; - MSG_NUM_D("comp ind ", compilationIndex); - MSG_NUM_D("comp ind * ", *(cell_t *)compilationIndex); - MSG_NUM_D("wl ", wordLists ); - MSG_NUM_D("wl * ", *(cell_t *)wordLists ); - MSG_NUM_D("first ", searchFirstIndex); - MSG_NUM_D("first * ", *(cell_t *) searchFirstIndex); - MSG_NUM_D("order ", searchOrder); - MSG_NUM_D("order * ", *(cell_t *)searchOrder); - MSG_NUM_D("order name * ", NAMEREL_TO_ABS((*(cell_t *)searchOrder))); - MSG_NUM_D("order code * ", CODEREL_TO_ABS((*(cell_t *)searchOrder))); - MSG_NUM_D("order code * * ", *(cell_t *)(CODEREL_TO_ABS((*(cell_t *)searchOrder)))); + gVarWlCompileIndex = comp_index; + gVarWordLists = wl_addr; + gVarWlOrderFirst = search_index; + arrSearchOrder = search_addr; + /* Debug Stuff. remove. */ + MSG_NUM_D("comp ind ", gVarWlCompileIndex); + MSG_NUM_D("comp ind * ", *(cell_t *)gVarWlCompileIndex); + MSG_NUM_D("wl ", gVarWordLists ); + MSG_NUM_D("wl * ", *(cell_t *)gVarWordLists ); + MSG_NUM_D("first ", gVarWlOrderFirst); + MSG_NUM_D("first * ", *(cell_t *) gVarWlOrderFirst); + MSG_NUM_D("order ", arrSearchOrder); + MSG_NUM_D("order * ", *(cell_t *)arrSearchOrder); + MSG_NUM_D("order name * ", NAMEREL_TO_ABS((*(cell_t *)arrSearchOrder))); + MSG_NUM_D("order code * ", CODEREL_TO_ABS((*(cell_t *)arrSearchOrder))); + MSG_NUM_D("order code * * ", *(cell_t *)(CODEREL_TO_ABS((*(cell_t *)arrSearchOrder)))); } cell_t getWordList( cell_t index ) { cell_t temp_addr; - if(wordLists) + if(gVarWordLists) { /* Don't underflow search */ if( index < 0 ) return (cell_t) NULL; /* Address to wordlist */ - temp_addr = (CODEREL_TO_ABS(*(((cell_t *)searchOrder) + index))); + temp_addr = (CODEREL_TO_ABS(*(((cell_t *)arrSearchOrder) + index))); if(temp_addr) { return *(cell_t *)temp_addr; @@ -74,6 +73,8 @@ cell_t getWordList( cell_t index ) return gVarContext; } } + +/* This should be written in forth */ /* search-wordlist ( c-addr u wid -- 0 | xt 1 | xt -1 ) */ cell_t ffSearchWordList( cell_t c_addr, cell_t u, cell_t wid) { @@ -82,8 +83,9 @@ cell_t ffSearchWordList( cell_t c_addr, cell_t u, cell_t wid) uint8_t NameLen; const char *NameField; if( wid == 0 ) return 0; - /* wid is code relative address of wordlists */ - /* referencing give content of gVarContext of compilation time of last word */ + /* wid is code relative address of wordlists + * referencing give content of gVarContext of + * compilation time of last word in word list*/ NameField = (ForthString *) *((cell_t *) (CODEREL_TO_ABS(wid)) ); do { @@ -109,8 +111,3 @@ cell_t ffSearchWordList( cell_t c_addr, cell_t u, cell_t wid) } #endif - - - - - diff --git a/csrc/pf_search.h b/csrc/pf_search.h index b3ec348..16e3399 100644 --- a/csrc/pf_search.h +++ b/csrc/pf_search.h @@ -22,11 +22,11 @@ /* Search order and word list arrays */ -extern cell_t searchFirstIndex; -extern cell_t wordLists; +extern cell_t gVarWlOrderFirst; +extern cell_t gVarWordLists; -/* compilationIndex is wordLists[compilationIdnex], head of comp. list. */ -extern cell_t compilationIndex; +/* compilationIndex is gVarWordLists[compilationIdnex], head of comp. list. */ +extern cell_t gVarWlCompileIndex; /* (init-wordlists) ( search_addr search_index wl_addr comp_index -- ) */ void ffInitWordLists( cell_t search_addr, cell_t search_index, @@ -34,7 +34,7 @@ void ffInitWordLists( cell_t search_addr, cell_t search_index, /* search-wordlist ( c-addr u wid -- 0 | xt 1 | xt -1 ) */ cell_t ffSearchWordList( cell_t c_addr, cell_t u, cell_t wid); -/* Helper function. +/* Helper function. * Get the head of wordlist in search order index 'index' */ cell_t getWordList( cell_t index ); diff --git a/csrc/pfcompil.c b/csrc/pfcompil.c index 1990446..b62ad66 100644 --- a/csrc/pfcompil.c +++ b/csrc/pfcompil.c @@ -64,13 +64,13 @@ void CreateDicEntry( ExecToken XT, const ForthStringPtr FName, ucell_t Flags ) if( gVarContext ) { #ifdef PF_SUPPORT_WORDLIST - if( wordLists ) + if( gVarWordLists ) { - if(*((cell_t*)(wordLists)+ *(cell_t*)(compilationIndex))) + if(*((cell_t*)(gVarWordLists)+ *(cell_t*)(gVarWlCompileIndex))) { WRITE_CELL_DIC( &cfnl->cfnl_PreviousName, - ABS_TO_NAMEREL( ( *((cell_t*)(wordLists)+ - *(cell_t*)(compilationIndex))))); + ABS_TO_NAMEREL( ( *((cell_t*)(gVarWordLists)+ + *(cell_t*)(gVarWlCompileIndex))))); } else { @@ -431,9 +431,9 @@ cell_t ffTokenToName( ExecToken XT, const ForthString **NFAPtr ) ExecToken TempXT; #ifdef PF_SUPPORT_WORDLIST cell_t iterator; - if( wordLists ) + if( gVarWordLists ) { - iterator = *(cell_t *) searchFirstIndex; + iterator = *(cell_t *) gVarWlOrderFirst; NameField = (ForthString *)getWordList(iterator); --iterator; } @@ -465,13 +465,15 @@ DBUGX(("ffCodeToName: NFA = 0x%x\n", NameField)); if( NameField == NULL ) { #ifdef PF_SUPPORT_WORDLIST - if( wordLists && iterator >= 0) + if( gVarWordLists && iterator >= 0) { NameField = (ForthString *)getWordList(iterator); --iterator; } else { + /* Wordlists aren't loaded or all are searched + * and nothing found */ #endif *NFAPtr = 0; Searching = FALSE; @@ -499,9 +501,9 @@ cell_t ffFindNFA( const ForthString *WordName, const ForthString **NFAPtr ) cell_t Result = 0; #ifdef PF_SUPPORT_WORDLIST cell_t iterator; - if( wordLists ) + if( gVarWordLists ) { - iterator = *(cell_t *) searchFirstIndex; + iterator = *(cell_t *) gVarWlOrderFirst; } else { @@ -512,7 +514,7 @@ cell_t ffFindNFA( const ForthString *WordName, const ForthString **NFAPtr ) WordLen = (uint8_t) ((ucell_t)*WordName & 0x1F); WordChar = WordName+1; #ifdef PF_SUPPORT_WORDLIST - if( wordLists ) + if( gVarWordLists ) { NameField = (ForthString *)getWordList(iterator); @@ -547,7 +549,7 @@ DBUG(("ffFindNFA: found it at NFA = 0x%x\n", NameField)); if( NameField == NULL ) { #ifdef PF_SUPPORT_WORDLIST - if( wordLists && iterator >= 0) + if( gVarWordLists && iterator >= 0) { NameField = (ForthString *)getWordList(iterator); --iterator; @@ -776,9 +778,9 @@ void ffFinishSecondary( void ) ffUnSmudge(); #ifdef PF_SUPPORT_WORDLIST /* Copy context to word list when they are available. */ - if( wordLists ) + if( gVarWordLists ) { - *((cell_t*)(wordLists)+*(cell_t*)(compilationIndex)) = gVarContext; + *((cell_t*)(gVarWordLists)+*(cell_t*)(gVarWlCompileIndex)) = gVarContext; } #endif } diff --git a/fth/search.fth b/fth/search.fth index 86abaaf..82fcdf5 100644 --- a/fth/search.fth +++ b/fth/search.fth @@ -25,37 +25,32 @@ anew task-search.fth -49 constant ERR_SEARCH_OVERFLOW -50 constant ERR_SEARCH_UNDERFLOW -create forth-wordlist WORDLISTS cells allot +\ Arrays for word lists and search order +\ Also available on C side. +create [wordlists] WORDLISTS cells allot create [searchorder] WORDLISTS cells allot -variable wl.compile.index -variable wl.order.first +variable wl.compile.index \ [wordlists] index which is compilation list +variable wl.order.first \ Start index of [searchorder] search is decending. + +\ Keep track which wordlists are already given. variable wl.used - -\ works - : wl.check ( index -- , throw if out of bounds ) dup WORDLISTS >= ERR_SEARCH_OVERFLOW and throw 0< ERR_SEARCH_UNDERFLOW and throw ; -\ works - : wl.check.wid ( wid -- throw if out of bounds ) - forth-wordlist if.use->rel dup wl.used @ + [wordlists] if.use->rel dup wl.used @ cells + ( wid min max ) >r over ( wid min wid ) > ERR_SEARCH_UNDERFLOW and throw r> > ERR_SEARCH_OVERFLOW and throw ; -\ works - : get-current ( -- wid , compilation word list ) - wl.compile.index @ cells forth-wordlist + if.use->rel + wl.compile.index @ cells [wordlists] + if.use->rel ; -\ works - : get-order ( -- widn ... wid1 n ) wl.order.first @ 1+ 0 ?do @@ -65,14 +60,13 @@ variable wl.used wl.order.first @ 1+ ; -\ works : set-current ( wid -- , compilation word list to wid ) \ check wid dup wl.check.wid \ make index and put it under - forth-wordlist use->rel - - cell / ( wid index-to-forth-wordlist ) + [wordlists] use->rel - + cell / ( wid index-to-[wordlists] ) wl.compile.index ! ; @@ -84,13 +78,11 @@ variable wl.used set-current ; -\ works - : set-order ( widn ... wid1 n -- , Set the search order ) dup -1 = if - drop forth-wordlist if.use->rel [searchorder] ! - 0 + drop [wordlists] if.use->rel [searchorder] ! + 0 else dup wl.check dup 0= @@ -107,11 +99,9 @@ variable wl.used wl.order.first ! ; -\ works - : wordlist ( -- wid , Create a new empty word list ) wl.used @ 1+ dup wl.check dup wl.used ! ( index , incerment and store ) - cells forth-wordlist + dup 0 swap ! ( addr , zero the wordlist ) + cells [wordlists] + dup 0 swap ! ( addr , zero the wordlist ) if.use->rel ( wid ) ; @@ -119,33 +109,31 @@ variable wl.used get-order over swap 1+ set-order ; -: forth ( -- , Remove first wordlist and put forth-wordlist as first ) - get-order nip forth-wordlist if.use->rel swap set-order +: forth ( -- , Remove first wordlist and put [wordlists] as first ) + get-order nip [wordlists] if.use->rel swap set-order ; -: only ( -- , Set search order to forth-wordlist ) +: only ( -- , Set search order to [wordlists] ) -1 set-order ; -\ works : order ( -- , print search order wordlist ) get-order 0 ?do i . ." 0x" .hex cr loop ; -\ works : previous ( -- ) get-order nip 1- set-order ; -: init-wordlists ( -- , put forth context to forth-wordlist ) +: init-wordlists ( -- , put forth context to [wordlists] ) WORDLISTS 1 do - 0 i cells forth-wordlist + ! + 0 i cells [wordlists] + ! 0 i cells [searchorder] + ! loop - context @ forth-wordlist ! - forth-wordlist if.use->rel [searchorder] ! + context @ [wordlists] ! + [wordlists] if.use->rel [searchorder] ! \ send variables to C - [searchorder] wl.order.first forth-wordlist wl.compile.index + [searchorder] wl.order.first [wordlists] wl.compile.index (init-wordlists) ; : auto.init @@ -161,13 +149,20 @@ variable wl.used \ : find ( c-addr -- c-addr 0 | xt 1 | xt -1 ) \ Find named definitions from all word lists \ ; +: forth-wordlist ( -- wid , Convert variable [wordlists] to wid ) + [wordlists] if.use->rel +; +\ debugiging words +\ Wordlists could be included earlier. misc2.fth provides +\ .hex which is limiting word inside wordlists?. +true [if] : wordlists? ( -- ) - cr ." wordlists:" forth-wordlist dup use->rel .hex .hex cr + cr ." wordlists:" [wordlists] dup use->rel .hex .hex cr WORDLISTS 0 do - forth-wordlist i cells + use->rel .hex i wl.used @ > if ." wl not in use: " then - i dup . cells forth-wordlist + @ .hex cr + [wordlists] i cells + use->rel .hex i wl.used @ > if ." wl not in use: " then + i dup . cells [wordlists] + @ .hex cr loop ." search order:" [searchorder] dup use->rel .hex .hex cr WORDLISTS 1+ 1 ?do @@ -177,3 +172,4 @@ variable wl.used WORDLISTS i - . .hex cr loop ; +[then] \ No newline at end of file From 51ed40efaeee5230e261ead72d8f9704fe226091 Mon Sep 17 00:00:00 2001 From: Hannu Vuolasaho Date: Wed, 20 May 2015 03:15:12 +0300 Subject: [PATCH 05/12] IT WORKS. About... Static dictionary UNTESTED FORGET breaks MARKER breaks --- csrc/pf_search.c | 13 ++-- csrc/pfcompil.c | 145 ++++++++++++++++++++++++++------------------- fth/search.fth | 51 ++++++++++------ fth/t_wordlist.fth | 135 +++++++++++++++++++++++++++++++++++++++++ 4 files changed, 262 insertions(+), 82 deletions(-) create mode 100644 fth/t_wordlist.fth diff --git a/csrc/pf_search.c b/csrc/pf_search.c index 9571d7d..fbfdab8 100644 --- a/csrc/pf_search.c +++ b/csrc/pf_search.c @@ -41,6 +41,8 @@ void ffInitWordLists( cell_t search_addr, cell_t search_index, MSG_NUM_D("comp ind * ", *(cell_t *)gVarWlCompileIndex); MSG_NUM_D("wl ", gVarWordLists ); MSG_NUM_D("wl * ", *(cell_t *)gVarWordLists ); + MSG_NUM_D("wl * * ", *(cell_t *)(*(cell_t *)gVarWordLists)); + MSG_NUM_D("wl+1 * * ", *(cell_t *)(*(cell_t *)gVarWordLists+1)); MSG_NUM_D("first ", gVarWlOrderFirst); MSG_NUM_D("first * ", *(cell_t *) gVarWlOrderFirst); MSG_NUM_D("order ", arrSearchOrder); @@ -51,15 +53,17 @@ void ffInitWordLists( cell_t search_addr, cell_t search_index, } cell_t getWordList( cell_t index ) { - cell_t temp_addr; + cell_t temp_addr, *tmp_arr; if(gVarWordLists) { /* Don't underflow search */ if( index < 0 ) return (cell_t) NULL; /* Address to wordlist */ - temp_addr = (CODEREL_TO_ABS(*(((cell_t *)arrSearchOrder) + index))); + tmp_arr = (cell_t *) arrSearchOrder; + temp_addr = tmp_arr[index]; if(temp_addr) { + temp_addr = CODEREL_TO_ABS(temp_addr); return *(cell_t *)temp_addr; } else @@ -82,7 +86,8 @@ cell_t ffSearchWordList( cell_t c_addr, cell_t u, cell_t wid) cell_t Result = 0; uint8_t NameLen; const char *NameField; - if( wid == 0 ) return 0; + + if( wid == 0 || !(*((cell_t *) (CODEREL_TO_ABS(wid))) )) return 0; /* wid is code relative address of wordlists * referencing give content of gVarContext of * compilation time of last word in word list*/ @@ -94,7 +99,7 @@ cell_t ffSearchWordList( cell_t c_addr, cell_t u, cell_t wid) (NameLen == u) && ffCompareTextCaseN( NameField +1, (const char *) c_addr, u ) ) { - PUSH_DATA_STACK(NameField); /* XT to stack */ + PUSH_DATA_STACK(NameToToken(NameField)); /* XT to stack */ Result = ((*NameField) & FLAG_IMMEDIATE) ? 1 : -1; Searching = FALSE; } diff --git a/csrc/pfcompil.c b/csrc/pfcompil.c index b62ad66..4e47981 100644 --- a/csrc/pfcompil.c +++ b/csrc/pfcompil.c @@ -105,7 +105,7 @@ void CreateDicEntry( ExecToken XT, const ForthStringPtr FName, ucell_t Flags ) /* Set flags. */ *(char*)gVarContext |= (char) Flags; - + /* Align to quad byte boundaries with zeroes. */ while( gCurrentDictionary->dic_HeaderPtr & UINT32_MASK ) { @@ -169,7 +169,7 @@ cell_t FindSpecialXTs( void ) if( ffFindC( "ACCEPT", &gAcceptP_XT ) == 0) goto nofind; DBUG(("gNumberQ_XT = 0x%x\n", (unsigned int)gNumberQ_XT )); return 0; - + nofind: ERR("FindSpecialXTs failed!\n"); return -1; @@ -187,7 +187,7 @@ PForthDictionary pfBuildDictionary( cell_t HeaderSize, cell_t CodeSize ) if( !dic ) goto nomem; pfDebugMessage("pfBuildDictionary: Start adding dictionary entries.\n"); - + gCurrentDictionary = dic; gNumPrimitives = NUM_PRIMITIVES; @@ -395,12 +395,12 @@ PForthDictionary pfBuildDictionary( cell_t HeaderSize, cell_t CodeSize ) CreateDicEntryC( ID_WORD_STORE, "W!", 0 ); CreateDicEntryC( ID_XOR, "XOR", 0 ); CreateDicEntryC( ID_ZERO_BRANCH, "0BRANCH", 0 ); - + pfDebugMessage("pfBuildDictionary: FindSpecialXTs\n"); if( FindSpecialXTs() < 0 ) goto error; - + if( CompileCustomFunctions() < 0 ) goto error; /* Call custom 'C' call builder. */ - + #ifdef PF_DEBUG DumpMemory( dic->dic_HeaderBase, 256 ); DumpMemory( dic->dic_CodeBase, 256 ); @@ -408,12 +408,12 @@ PForthDictionary pfBuildDictionary( cell_t HeaderSize, cell_t CodeSize ) pfDebugMessage("pfBuildDictionary: Finished adding dictionary entries.\n"); return (PForthDictionary) dic; - + error: pfDebugMessage("pfBuildDictionary: Error adding dictionary entries.\n"); pfDeleteDictionary( dic ); return NULL; - + nomem: return NULL; } @@ -446,12 +446,12 @@ cell_t ffTokenToName( ExecToken XT, const ForthString **NFAPtr ) #else NameField = (ForthString *) gVarContext; DBUGX(("\ffCodeToName: gVarContext = 0x%x\n", gVarContext)); -#endif +#endif do { TempXT = NameToToken( NameField ); - + if( TempXT == XT ) { DBUGX(("ffCodeToName: NFA = 0x%x\n", NameField)); @@ -469,6 +469,12 @@ DBUGX(("ffCodeToName: NFA = 0x%x\n", NameField)); { NameField = (ForthString *)getWordList(iterator); --iterator; + /* Ugly. */ + if( NameField == NULL) + { + *NFAPtr = 0; + Searching = FALSE; + } } else { @@ -483,7 +489,7 @@ DBUGX(("ffCodeToName: NFA = 0x%x\n", NameField)); } } } while ( Searching); - + return Result; } @@ -516,14 +522,24 @@ cell_t ffFindNFA( const ForthString *WordName, const ForthString **NFAPtr ) #ifdef PF_SUPPORT_WORDLIST if( gVarWordLists ) { - - NameField = (ForthString *)getWordList(iterator); - --iterator; + NameField = NULL; + /* Skip empty lists from begin. */ + while( NameField == NULL && iterator >= 0) + { + NameField = (ForthString *)getWordList(iterator); + --iterator; + } + if( NameField == NULL && iterator < 0 ) + { + /* Nothing found! */ + *NFAPtr = WordName; + return Result; + } } else{ NameField = (ForthString *) gVarContext; } - + #else NameField = (ForthString *) gVarContext; DBUG(("\nffFindNFA: WordLen = %d, WordName = %*s\n", WordLen, WordLen, WordChar )); @@ -551,8 +567,17 @@ DBUG(("ffFindNFA: found it at NFA = 0x%x\n", NameField)); #ifdef PF_SUPPORT_WORDLIST if( gVarWordLists && iterator >= 0) { - NameField = (ForthString *)getWordList(iterator); - --iterator; + do + { + /* Skip empty lists middle */ + NameField = (ForthString *)getWordList(iterator); + --iterator; + }while( NameField == NULL && iterator >= 0 ); + if( NameField == NULL) + { + *NFAPtr = WordName; + Searching = FALSE; + } } else { @@ -578,7 +603,7 @@ cell_t ffFind( const ForthString *WordName, ExecToken *pXT ) { const ForthString *NFA; cell_t Result; - + Result = ffFindNFA( WordName, &NFA ); DBUG(("ffFind: %8s at 0x%x\n", WordName+1, NFA)); /* WARNING, not NUL terminated. %Q */ if( Result ) @@ -610,7 +635,7 @@ DBUG(("ffFindC: %s\n", WordName )); #define DIC_SAFETY_MARGIN (400) /************************************************************* -** Check for dictionary overflow. +** Check for dictionary overflow. */ static cell_t ffCheckDicRoom( void ) { @@ -634,7 +659,7 @@ static cell_t ffCheckDicRoom( void ) } /************************************************************* -** Create a dictionary entry given a string name. +** Create a dictionary entry given a string name. */ void ffCreateSecondaryHeader( const ForthStringPtr FName) { @@ -664,9 +689,9 @@ static void ffStringColon( const ForthStringPtr FName) void ffColon( void ) { char *FName; - + gDepthAtColon = DATA_STACK_DEPTH; - + FName = ffWord( BLANK ); if( *FName > 0 ) { @@ -681,7 +706,7 @@ static cell_t CheckRedefinition( const ForthStringPtr FName ) { cell_t flag; ExecToken XT; - + flag = ffFind( FName, &XT); if ( flag && !gVarQuiet) { @@ -694,18 +719,18 @@ static cell_t CheckRedefinition( const ForthStringPtr FName ) void ffStringCreate( char *FName) { ffCreateSecondaryHeader( FName ); - + CODE_COMMA( ID_CREATE_P ); CODE_COMMA( ID_EXIT ); ffFinishSecondary(); - + } /* Read the next ExecToken from the Source and create a word. */ void ffCreate( void ) { char *FName; - + FName = ffWord( BLANK ); if( *FName > 0 ) { @@ -717,12 +742,12 @@ void ffStringDefer( const ForthStringPtr FName, ExecToken DefaultXT ) { pfDebugMessage("ffStringDefer()\n"); ffCreateSecondaryHeader( FName ); - + CODE_COMMA( ID_DEFER_P ); CODE_COMMA( DefaultXT ); - + ffFinishSecondary(); - + } #ifndef PF_NO_INIT /* Convert name then create deferred dictionary entry. */ @@ -738,7 +763,7 @@ static void CreateDeferredC( ExecToken DefaultXT, const char *CName ) void ffDefer( void ) { char *FName; - + FName = ffWord( BLANK ); if( *FName > 0 ) { @@ -757,7 +782,7 @@ ThrowCode ffSemiColon( void ) { ThrowCode exception = 0; gVarState = 0; - + if( (gDepthAtColon != DATA_STACK_DEPTH) && (gDepthAtColon != DEPTH_AT_COLON_INVALID) ) /* Ignore if no ':' */ { @@ -807,8 +832,8 @@ void ffLiteral( cell_t Num ) #ifdef PF_SUPPORT_FP void ffFPLiteral( PF_FLOAT fnum ) { - /* Hack for Metrowerks complier which won't compile the - * original expression. + /* Hack for Metrowerks complier which won't compile the + * original expression. */ PF_FLOAT *temp; cell_t *dicPtr; @@ -836,7 +861,7 @@ ThrowCode FindAndCompile( const char *theWord ) ExecToken XT; cell_t Num; ThrowCode exception = 0; - + Flag = ffFind( theWord, &XT); DBUG(("FindAndCompile: theWord = %8s, XT = 0x%x, Flag = %d\n", theWord, XT, Flag )); @@ -861,12 +886,12 @@ DBUG(("FindAndCompile: IMMEDIATE, theWord = 0x%x\n", theWord )); { /* Call deferred NUMBER? */ cell_t NumResult; - + DBUG(("FindAndCompile: not found, try number?\n" )); PUSH_DATA_STACK( theWord ); /* Push text of number */ exception = pfCatch( gNumberQ_XT ); if( exception ) goto error; - + DBUG(("FindAndCompile: after number?\n" )); NumResult = POP_DATA_STACK; /* Success? */ switch( NumResult ) @@ -878,7 +903,7 @@ DBUG(("FindAndCompile: after number?\n" )); ffLiteral( Num ); } break; - + case NUM_TYPE_DOUBLE: if( gVarState ) /* compiling? */ { @@ -902,7 +927,7 @@ DBUG(("FindAndCompile: after number?\n" )); MSG( " ? - unrecognized word!\n" ); exception = THROW_UNDEFINED_WORD; break; - + } } error: @@ -918,15 +943,15 @@ ThrowCode ffInterpret( void ) cell_t flag; char *theWord; ThrowCode exception = 0; - + /* Is there any text left in Source ? */ while( gCurrentTask->td_IN < (gCurrentTask->td_SourceNum) ) { - + pfDebugMessage("ffInterpret: calling ffWord(()\n"); theWord = ffWord( BLANK ); DBUG(("ffInterpret: theWord = 0x%x, Len = %d\n", theWord, *theWord )); - + if( *theWord > 0 ) { flag = 0; @@ -950,7 +975,7 @@ ThrowCode ffInterpret( void ) error: return exception; } - + /**************************************************************/ ThrowCode ffOK( void ) { @@ -990,7 +1015,7 @@ ThrowCode ffOK( void ) void pfHandleIncludeError( void ) { FileStream *cur; - + while( (cur = ffPopInputStream()) != PF_STDIN) { DBUG(("ffCleanIncludeStack: closing 0x%x\n", cur )); @@ -1026,7 +1051,7 @@ ThrowCode ffOuterInterpreterLoop( void ) ThrowCode ffIncludeFile( FileStream *InputFile ) { ThrowCode exception; - + /* Push file stream. */ exception = ffPushInputStream( InputFile ); if( exception < 0 ) return exception; @@ -1034,13 +1059,13 @@ ThrowCode ffIncludeFile( FileStream *InputFile ) /* Run outer interpreter for stream. */ exception = ffOuterInterpreterLoop(); if( exception ) - { + { int i; /* Report line number and nesting level. */ MSG("INCLUDE error on line #"); ffDot(gCurrentTask->td_LineNumber); MSG(", level = "); ffDot(gIncludeIndex ); EMIT_CR - + /* Dump line of error and show offset in line for >IN */ for( i=0; itd_SourceNum; i++ ) { @@ -1055,7 +1080,7 @@ ThrowCode ffIncludeFile( FileStream *InputFile ) /* Pop file stream. */ ffPopInputStream(); - + /* ANSI spec specifies that this should also close the file. */ sdCloseFile(InputFile); @@ -1071,7 +1096,7 @@ Err ffPushInputStream( FileStream *InputFile ) { cell_t Result = 0; IncludeFrame *inf; - + /* Push current input state onto special include stack. */ if( gIncludeIndex < MAX_INCLUDE_DEPTH ) { @@ -1096,8 +1121,8 @@ Err ffPushInputStream( FileStream *InputFile ) ERR("ffPushInputStream: max depth exceeded.\n"); return -1; } - - + + return Result; } @@ -1109,10 +1134,10 @@ FileStream *ffPopInputStream( void ) { IncludeFrame *inf; FileStream *Result; - + DBUG(("ffPopInputStream: gIncludeIndex = %d\n", gIncludeIndex)); Result = gCurrentTask->td_InputStream; - + /* Restore input state. */ if( gIncludeIndex > 0 ) { @@ -1161,7 +1186,7 @@ cell_t ffConvertStreamToSourceID( FileStream *Stream ) FileStream * ffConvertSourceIDToStream( cell_t id ) { FileStream *stream; - + if( id == 0 ) { stream = PF_STDIN; @@ -1170,7 +1195,7 @@ FileStream * ffConvertSourceIDToStream( cell_t id ) { stream = NULL; } - else + else { stream = (FileStream *) id; } @@ -1203,17 +1228,17 @@ DBUGX(("readLineFromStream(0x%x, 0x%x, 0x%x)\n", buffer, len, stream )); done = 1; if( len <= 0 ) len = -1; break; - + case '\n': DBUGX(("EOL=\\n\n")); if( lastChar != '\r' ) done = 1; break; - + case '\r': DBUGX(("EOL=\\r\n")); done = 1; break; - + default: *p++ = (char) c; len++; @@ -1224,7 +1249,7 @@ DBUGX(("readLineFromStream(0x%x, 0x%x, 0x%x)\n", buffer, len, stream )); /* NUL terminate line to simplify printing when debugging. */ if( (len >= 0) && (len < maxChars) ) p[len] = '\0'; - + return len; } @@ -1267,14 +1292,14 @@ cell_t ffRefill( void ) gCurrentTask->td_SourceNum = Num; gCurrentTask->td_LineNumber++; /* Bump for include. */ - + /* echo input if requested */ if( gVarEcho && ( Num > 0)) { ioType( gCurrentTask->td_SourcePtr, gCurrentTask->td_SourceNum ); EMIT_CR; } - + error: return Result; } diff --git a/fth/search.fth b/fth/search.fth index 82fcdf5..438af2f 100644 --- a/fth/search.fth +++ b/fth/search.fth @@ -1,4 +1,4 @@ -\ @(#) case.fth 15/04/10 0.1 +\ @(#) search.fth 15/05/20 0.2 \ Search-Order wordset \ \ @@ -54,8 +54,7 @@ variable wl.used : get-order ( -- widn ... wid1 n ) wl.order.first @ 1+ 0 ?do - wl.order.first @ i - cells - [searchorder] + @ + i cells [searchorder] + @ loop wl.order.first @ 1+ ; @@ -89,11 +88,12 @@ variable wl.used if drop -1 else - dup >r 0 do - i cells - [searchorder] + ! + dup 1- swap + 0 do + dup i - cells ( wid1 ... widn n offset ) + [searchorder] + ( wid1 ... widn n addr ) + rot swap ! loop - r> 1- then then wl.order.first ! @@ -113,7 +113,7 @@ variable wl.used get-order nip [wordlists] if.use->rel swap set-order ; -: only ( -- , Set search order to [wordlists] ) +: only ( -- , Set search order to forth-wordlist ) -1 set-order ; @@ -126,7 +126,7 @@ variable wl.used : previous ( -- ) get-order nip 1- set-order ; : init-wordlists ( -- , put forth context to [wordlists] ) - WORDLISTS 1 do + WORDLISTS 0 do 0 i cells [wordlists] + ! 0 i cells [searchorder] + ! loop @@ -153,23 +153,38 @@ variable wl.used [wordlists] if.use->rel ; +: seal ( -- , Make the top of the search order only word list in search order ) + get-order over >r 0 do drop loop r> 1 set-current +; + \ debugiging words \ Wordlists could be included earlier. misc2.fth provides \ .hex which is limiting word inside wordlists?. true [if] : wordlists? ( -- ) - cr ." wordlists:" [wordlists] dup use->rel .hex .hex cr + cr ." wordlists:"cr WORDLISTS 0 do - [wordlists] i cells + use->rel .hex i wl.used @ > if ." wl not in use: " then - i dup . cells [wordlists] + @ .hex cr + i ." index: " . [wordlists] i cells + + dup ." use: " .hex + dup ." rel: " use->rel .hex + @ ." val: " .hex + i wl.used @ > if ." wl not in use. " then + cr loop - ." search order:" [searchorder] dup use->rel .hex .hex cr - WORDLISTS 1+ 1 ?do - WORDLISTS i - cells - [searchorder] + dup .hex @ - wl.order.first @ WORDLISTS i - < if ." order not in use: " then - WORDLISTS i - . .hex cr + cr ." compilation list index: " wl.compile.index @ . + ." and list: " get-current .hex cr + ." search order:" cr + WORDLISTS 1+ 1 + ?do + WORDLISTS i - + dup ." index: " . + cells [searchorder] + + dup ." use: " .hex + dup ." rel: " use->rel .hex + @ ." val: " .hex wl.order.first @ WORDLISTS i - < if ." order not in use. " then + cr loop ; + [then] \ No newline at end of file diff --git a/fth/t_wordlist.fth b/fth/t_wordlist.fth new file mode 100644 index 0000000..206140d --- /dev/null +++ b/fth/t_wordlist.fth @@ -0,0 +1,135 @@ +\ @(#) t_wordlist.fth 15/05/20 0.2 +\ Search-Order wordset +\ +\ +\ +\ Author: Hannu Vuolasaho +\ +\ Copied and modified from +\ http://www.forth200x.org/documents/html3/testsuite.html#section.F.19 + +include? }T{ t_tools.fth + +test{ +VARIABLE wid1 +VARIABLE wid2 +wordlist wid1 ! +wordlist wid2 ! + +: save-orderlist ( widn ... wid1 n -- ) + DUP , 0 ?DO , LOOP +; + +CREATE order-list +T{ GET-ORDER save-orderlist }T{ }T + +: get-orderlist ( -- widn ... wid1 n ) + order-list DUP @ CELLS ( -- ad n ) + OVER + ( -- AD AD' ) + ?DO I @ -1 CELLS +LOOP ( -- ) +; +\ F.16.6.1.1595 +\ FORTH-WORDLIST +T{ FORTH-WORDLIST wid1 ! }T{ }T +\ F.16.6.1.1180 +\ DEFINITIONS +T{ ONLY FORTH DEFINITIONS }T{ }T +T{ GET-CURRENT }T{ FORTH-WORDLIST }T + +T{ GET-ORDER wid2 @ SWAP 1+ SET-ORDER DEFINITIONS GET-CURRENT +}T{ wid2 @ }T + +T{ GET-ORDER }T{ get-orderlist wid2 @ SWAP 1+ }T + +T{ PREVIOUS GET-ORDER }T{ get-orderlist }T + +T{ DEFINITIONS GET-CURRENT }T{ FORTH-WORDLIST }T + +: alsowid2 ALSO GET-ORDER wid2 @ ROT DROP SWAP SET-ORDER ; +alsowid2 +: w1 1234 ; +DEFINITIONS : w1 -9876 ; IMMEDIATE + +ONLY FORTH +T{ w1 }T{ 1234 }T +DEFINITIONS +T{ w1 }T{ 1234 }T +alsowid2 +T{ w1 }T{ -9876 }T +DEFINITIONS T{ w1 }T{ -9876 }T + +ONLY FORTH DEFINITIONS +: so5 DUP IF SWAP EXECUTE THEN ; + + T{ S" w1" wid1 @ SEARCH-WORDLIST so5 }T{ -1 1234 }T + T{ S" w1" wid2 @ SEARCH-WORDLIST so5 }T{ 1 -9876 }T + +: c"w1" C" w1" ; +T{ alsowid2 c"w1" FIND so5 }T{ 1 -9876 }T +T{ PREVIOUS c"w1" FIND so5 }T{ -1 1234 }T +\ F.16.6.1.1550 +\ FIND + +VARIABLE xt ' DUP xt ! +VARIABLE xti ' .( xti ! \ Immediate word + +: c"dup" C" DUP" ; +: c".(" C" .(" ; +: c"x" C" unknown word" ; + +T{ c"dup" FIND }T{ xt @ -1 }T +T{ c".(" FIND }T{ xti @ 1 }T +T{ c"x" FIND }T{ c"x" 0 }T + +\ F.16.6.1.2192 +\ SEARCH-WORDLIST +ONLY FORTH DEFINITIONS + +T{ S" DUP" wid1 @ SEARCH-WORDLIST }T{ xt @ -1 }T +T{ S" .(" wid1 @ SEARCH-WORDLIST }T{ xti @ 1 }T +T{ S" DUP" wid2 @ SEARCH-WORDLIST }T{ 0 }T +\ F.16.6.1.2195 +\ SET-CURRENT +T{ GET-CURRENT }T{ wid1 @ }T + +T{ WORDLIST wid2 ! }T{ }T +T{ wid2 @ SET-CURRENT }T{ }T +T{ GET-CURRENT }T{ wid2 @ }T + +T{ wid1 @ SET-CURRENT }T{ }T +\ F.16.6.1.2197 +\ SET-ORDER +T{ GET-ORDER OVER }T{ GET-ORDER wid1 @ }T +T{ GET-ORDER SET-ORDER }T{ }T +T{ GET-ORDER }T{ get-orderlist }T T{ get-orderlist DROP get-orderList 2* SET-ORDER }T{ }T +T{ GET-ORDER }T{ get-orderlist DROP get-orderList 2* }T +T{ get-orderlist SET-ORDER GET-ORDER }T{ get-orderlist }T + +: so2a GET-ORDER get-orderlist SET-ORDER ; +: so2 0 SET-ORDER so2a ; + +T{ so2 }T{ 0 }T \ 0 SET-ORDER leaves an empty search order + +: so3 -1 SET-ORDER so2a ; +: so4 ONLY so2a ; + +T{ so3 }T{ so4 }T \ -1 SET-ORDER is the same as ONLY +\ F.16.6.2.0715 +\ ALSO +T{ ALSO GET-ORDER ONLY }T{ get-orderlist OVER SWAP 1+ }T +\ F.16.6.2.1965 +\ ONLY +T{ ONLY FORTH GET-ORDER }T{ get-orderlist }T + +: so1 SET-ORDER ; \ In case it is unavailable in the forth wordlist + +T{ ONLY FORTH-WORDLIST 1 SET-ORDER get-orderlist so1 }T{ }T +T{ GET-ORDER }T{ get-orderlist }T +\ F.16.6.2.1985 +\ ORDER +CR .( ONLY FORTH DEFINITIONS search order and compilation list) CR +T{ ONLY FORTH DEFINITIONS ORDER }T{ }T + +CR .( Plus another unnamed wordlist at head of search order) CR +T{ alsowid2 DEFINITIONS ORDER }T{ }T +}test \ No newline at end of file From c0afc736b0c0ac80d8e0d657700437e6631b707b Mon Sep 17 00:00:00 2001 From: Hannu Vuolasaho Date: Thu, 4 Jun 2015 21:07:41 +0300 Subject: [PATCH 06/12] bugfixes dictionary file creation [X] works wordlists in dictionary files [X] works Warranty was woid because SEAL was broken. SEAL fixed. WORDS, FORGET and MARKER needs still still fixing. --- fth/search.fth | 49 ++++++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 46 insertions(+), 3 deletions(-) diff --git a/fth/search.fth b/fth/search.fth index 438af2f..e31dc0e 100644 --- a/fth/search.fth +++ b/fth/search.fth @@ -35,6 +35,8 @@ variable wl.order.first \ Start index of [searchorder] search is decending. \ Keep track which wordlists are already given. variable wl.used +variable wl.offset + : wl.check ( index -- , throw if out of bounds ) dup WORDLISTS >= ERR_SEARCH_OVERFLOW and throw 0< ERR_SEARCH_UNDERFLOW and throw @@ -132,10 +134,26 @@ variable wl.used loop context @ [wordlists] ! [wordlists] if.use->rel [searchorder] ! - \ send variables to C +; + +init-wordlists + +: init-wordlists ( -- , put forth context to [wordlists] and send to C ) + context @ [wordlists] ! + [wordlists] if.use->rel [searchorder] ! + \ Fix dictionaries. + WORDLISTS 1 do + i cells [wordlists] + dup @ dup 0<> ( addr val flag ) + if + wl.offset @ - namebase + swap ! ( ) + else + 2drop + then + loop [searchorder] wl.order.first [wordlists] wl.compile.index (init-wordlists) ; + : auto.init auto.init init-wordlists ; @@ -154,13 +172,28 @@ variable wl.used ; : seal ( -- , Make the top of the search order only word list in search order ) - get-order over >r 0 do drop loop r> 1 set-current + get-order over >r 0 do drop loop r> 1 set-order +; + +\ As values are in [wordlists] in usable format, save namebase to wl.offset +\ so next time it is possible to use them. + +\ This works as this file is included by loadp4th.fth +\ later than save-forth in system.fth + +\ redefine save-forth +: save-forth ( $name -- ) + namebase wl.offset ! save-forth ; +\ Now there yoy go. Use the wordlist +init-wordlists \ debugiging words \ Wordlists could be included earlier. misc2.fth provides \ .hex which is limiting word inside wordlists?. -true [if] + + true [if] +\ false [if] : wordlists? ( -- ) cr ." wordlists:"cr WORDLISTS 0 @@ -187,4 +220,14 @@ true [if] loop ; + +VARIABLE wid1 +wordlist wid1 ! + +wid1 @ set-current +: hello ." Hello wid1" cr ; + +forth-wordlist set-current +: hello ." Hello forth" cr ; + [then] \ No newline at end of file From c954699d5a27ba386f09f049af0be71f42300711 Mon Sep 17 00:00:00 2001 From: Hannu Vuolasaho Date: Thu, 4 Jun 2015 23:48:36 +0300 Subject: [PATCH 07/12] FORGET WORDS forget and words working --- fth/search.fth | 30 ++++++++++++++++++++++++++++-- 1 file changed, 28 insertions(+), 2 deletions(-) diff --git a/fth/search.fth b/fth/search.fth index e31dc0e..adf409a 100644 --- a/fth/search.fth +++ b/fth/search.fth @@ -186,11 +186,37 @@ init-wordlists namebase wl.offset ! save-forth ; -\ Now there yoy go. Use the wordlist +\ Now there you go. Use the wordlist. init-wordlists + +\ Words which are defined before and we want to work differently. +\ 15.6.1.2465 +\ WORDS +: WORDS ( -- ) + 0 + \ This part is different + wl.order.first @ cells [searchorder] + @ rel->use @ + \ end modification + BEGIN dup 0<> + WHILE dup id. tab cr? ?pause + prevname + swap 1+ swap + REPEAT drop + cr . ." words" cr +; + +\ 15.6.2.1580 +\ FORGET +\ If the Search-Order word set is present, FORGET searches the compilation word list. +\ An ambiguous condition exists if the compilation word list is deleted. +: [FORGET] ( -- , forget then exec forgotten words ) + wl.compile.index @ cells [wordlists] + @ .hex + context @ .hex [FORGET] context @ dup .hex wl.compile.index @ cells [wordlists] + ! +; + \ debugiging words \ Wordlists could be included earlier. misc2.fth provides -\ .hex which is limiting word inside wordlists?. +\ .hex which is limiting word inside wordlists?. [if] is in condcomp.fth true [if] \ false [if] From 9fc86399a01c1ba2333d14d468ca4b5ffc350bbb Mon Sep 17 00:00:00 2001 From: Hannu Vuolasaho Date: Thu, 4 Jun 2015 23:50:33 +0300 Subject: [PATCH 08/12] Makefile devchanges... --- build/unix/Makefile | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/build/unix/Makefile b/build/unix/Makefile index 815d222..628d75e 100644 --- a/build/unix/Makefile +++ b/build/unix/Makefile @@ -134,11 +134,12 @@ help: @echo " It allows pForth to work as a standalone image that does not need to load a dictionary file." test: $(PFORTHAPP) - wd=$$(pwd); (cd $(FTHDIR); $${wd}/$(PFORTHAPP) -q t_corex.fth) +# wd=$$(pwd); (cd $(FTHDIR); $${wd}/$(PFORTHAPP) -q t_corex.fth) wd=$$(pwd); (cd $(FTHDIR); $${wd}/$(PFORTHAPP) -q t_strings.fth) wd=$$(pwd); (cd $(FTHDIR); $${wd}/$(PFORTHAPP) -q t_locals.fth) wd=$$(pwd); (cd $(FTHDIR); $${wd}/$(PFORTHAPP) -q t_alloc.fth) wd=$$(pwd); (cd $(FTHDIR); $${wd}/$(PFORTHAPP) -q t_floats.fth) + wd=$$(pwd); (cd $(FTHDIR); $${wd}/$(PFORTHAPP) -q t_wordlist.fth) clean: rm -f $(PFOBJS) $(PFEMBOBJS) From b36ee82881e0c5065ea2effd9c0ad02ddde0eeb0 Mon Sep 17 00:00:00 2001 From: Hannu Vuolasaho Date: Fri, 5 Jun 2015 02:10:18 +0300 Subject: [PATCH 09/12] BUGFIX: Auto.term ran auto.init --- fth/history.fth | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/fth/history.fth b/fth/history.fth index 176d187..6299d1d 100644 --- a/fth/history.fth +++ b/fth/history.fth @@ -502,7 +502,7 @@ variable KH-INSIDE ( true if we are scrolling inside the history buffer ) ; : AUTO.TERM history.off - auto.init + auto.term ; if.forgotten history.off From bbce831b86b7053985fad92594626b7ac7505818 Mon Sep 17 00:00:00 2001 From: Hannu Vuolasaho Date: Fri, 5 Jun 2015 02:46:48 +0300 Subject: [PATCH 10/12] Should work First version which should work. More testing however required. Marker and forget aren't thoroughly tested --- build/unix/Makefile | 2 +- csrc/pf_search.c | 3 +- fth/search.fth | 106 +++++++++++++++++++++++++++++++++++--------- 3 files changed, 89 insertions(+), 22 deletions(-) diff --git a/build/unix/Makefile b/build/unix/Makefile index 628d75e..7826ca8 100644 --- a/build/unix/Makefile +++ b/build/unix/Makefile @@ -134,7 +134,7 @@ help: @echo " It allows pForth to work as a standalone image that does not need to load a dictionary file." test: $(PFORTHAPP) -# wd=$$(pwd); (cd $(FTHDIR); $${wd}/$(PFORTHAPP) -q t_corex.fth) + wd=$$(pwd); (cd $(FTHDIR); $${wd}/$(PFORTHAPP) -q t_corex.fth) wd=$$(pwd); (cd $(FTHDIR); $${wd}/$(PFORTHAPP) -q t_strings.fth) wd=$$(pwd); (cd $(FTHDIR); $${wd}/$(PFORTHAPP) -q t_locals.fth) wd=$$(pwd); (cd $(FTHDIR); $${wd}/$(PFORTHAPP) -q t_alloc.fth) diff --git a/csrc/pf_search.c b/csrc/pf_search.c index fbfdab8..c17f042 100644 --- a/csrc/pf_search.c +++ b/csrc/pf_search.c @@ -36,7 +36,7 @@ void ffInitWordLists( cell_t search_addr, cell_t search_index, gVarWordLists = wl_addr; gVarWlOrderFirst = search_index; arrSearchOrder = search_addr; - /* Debug Stuff. remove. */ + /* Debug Stuff. remove. MSG_NUM_D("comp ind ", gVarWlCompileIndex); MSG_NUM_D("comp ind * ", *(cell_t *)gVarWlCompileIndex); MSG_NUM_D("wl ", gVarWordLists ); @@ -50,6 +50,7 @@ void ffInitWordLists( cell_t search_addr, cell_t search_index, MSG_NUM_D("order name * ", NAMEREL_TO_ABS((*(cell_t *)arrSearchOrder))); MSG_NUM_D("order code * ", CODEREL_TO_ABS((*(cell_t *)arrSearchOrder))); MSG_NUM_D("order code * * ", *(cell_t *)(CODEREL_TO_ABS((*(cell_t *)arrSearchOrder)))); + */ } cell_t getWordList( cell_t index ) { diff --git a/fth/search.fth b/fth/search.fth index adf409a..4ef435b 100644 --- a/fth/search.fth +++ b/fth/search.fth @@ -1,4 +1,4 @@ -\ @(#) search.fth 15/05/20 0.2 +\ @(#) search.fth 5/06/20 0.3 \ Search-Order wordset \ \ @@ -17,8 +17,9 @@ anew task-search.fth -\ This constant defines how many wordlist you get. Increase it -\ if more lists needed. +\ This constant defines how many wordlist you get. Increase it if more +\ lists needed. + 16 constant WORDLISTS \ Exeption codes @@ -34,7 +35,7 @@ variable wl.order.first \ Start index of [searchorder] search is decending. \ Keep track which wordlists are already given. variable wl.used - +\ Namebase during dictionary file build variable wl.offset : wl.check ( index -- , throw if out of bounds ) @@ -120,6 +121,8 @@ variable wl.offset ; : order ( -- , print search order wordlist ) + get-current ." Compile to: 0x" .hex cr + ." search from:" cr get-order 0 ?do i . ." 0x" .hex cr loop @@ -138,11 +141,10 @@ variable wl.offset init-wordlists -: init-wordlists ( -- , put forth context to [wordlists] and send to C ) - context @ [wordlists] ! - [wordlists] if.use->rel [searchorder] ! +: init-wordlists ( -- , Relocate [wordlists] ) + \ Fix dictionaries. - WORDLISTS 1 do + WORDLISTS 0 do i cells [wordlists] + dup @ dup 0<> ( addr val flag ) if wl.offset @ - namebase + swap ! ( ) @@ -150,6 +152,7 @@ init-wordlists 2drop then loop + context @ wl.compile.index @ cells [wordlists] + ! [searchorder] wl.order.first [wordlists] wl.compile.index (init-wordlists) ; @@ -175,23 +178,29 @@ init-wordlists get-order over >r 0 do drop loop r> 1 set-order ; -\ As values are in [wordlists] in usable format, save namebase to wl.offset -\ so next time it is possible to use them. +\ As values are in [wordlists] in usable format, save namebase to +\ wl.offset so next time it is possible to use them. \ This works as this file is included by loadp4th.fth \ later than save-forth in system.fth + +\ Now there you go. Use the wordlist. +init-wordlists + +\ Words which are defined before and we want to work differently. + \ redefine save-forth : save-forth ( $name -- ) namebase wl.offset ! save-forth ; -\ Now there you go. Use the wordlist. -init-wordlists -\ Words which are defined before and we want to work differently. \ 15.6.1.2465 \ WORDS + +\ List the definition names in the first word list of the search +\ order. The format of the display is implementation-dependent. : WORDS ( -- ) 0 \ This part is different @@ -207,19 +216,76 @@ init-wordlists \ 15.6.2.1580 \ FORGET -\ If the Search-Order word set is present, FORGET searches the compilation word list. -\ An ambiguous condition exists if the compilation word list is deleted. + +\ If the Search-Order word set is present, FORGET searches the +\ compilation word list. An ambiguous condition exists if the +\ compilation word list is deleted. + : [FORGET] ( -- , forget then exec forgotten words ) - wl.compile.index @ cells [wordlists] + @ .hex - context @ .hex [FORGET] context @ dup .hex wl.compile.index @ cells [wordlists] + ! + [FORGET] context @ wl.compile.index @ cells [wordlists] + ! ; + +\ 6.2.1850 +\ MARKER + +\ Restore all dictionary allocation and search order +\ pointers to the state they had just prior to the definition of +\ name. Remove the definition of name and all subsequent +\ definitions. Restoration of any structures still existing that could +\ refer to deleted definitions or deallocated data space is not +\ necessarily provided. No other contextual information such as +\ numeric base is affected. + +: MARKER ( -- , define a word that forgets itself when executed, ANS ) + latest + CREATE + \ save the previous word + , + \ Save dictionary and word list status + [wordlists] WORDLISTS 0 + do + dup i cells + @ + namebase - \ convert to relocatable + , \ save for DOES> + loop + drop \ drop [wordlists] + \ Save search order + [searchorder] WORDLISTS 0 + do + dup i cells + @ , \ already relocatable + loop + drop + wl.compile.index @ , + wl.order.first @ , + wl.used @ , + DOES> ( -- body ) + dup @ context ! cell+ + \ restore wordlists + WORDLISTS 0 + do + dup @ namebase + \ convert back to NFA + i cells [wordlists] + ! + cell+ + loop + + WORDLISTS 0 + do + dup @ i cells [searchorder] + ! cell+ + loop + dup @ wl.compile.index ! cell+ + dup @ wl.order.first ! cell+ + @ wl.used ! + context @ wl.compile.index @ cells [wordlists] + ! +; + + \ debugiging words \ Wordlists could be included earlier. misc2.fth provides \ .hex which is limiting word inside wordlists?. [if] is in condcomp.fth - true [if] -\ false [if] + +false [if] : wordlists? ( -- ) cr ." wordlists:"cr WORDLISTS 0 @@ -233,6 +299,7 @@ init-wordlists loop cr ." compilation list index: " wl.compile.index @ . ." and list: " get-current .hex cr + ." with latest: " latest .hex cr ." search order:" cr WORDLISTS 1+ 1 ?do @@ -246,7 +313,6 @@ init-wordlists loop ; - VARIABLE wid1 wordlist wid1 ! From e35c3a579df3d701a4ffd715c7635464c21a6611 Mon Sep 17 00:00:00 2001 From: Hannu Vuolasaho Date: Fri, 5 Jun 2015 03:11:10 +0300 Subject: [PATCH 11/12] Test set fix for non WL compilation --- fth/t_wordlist.fth | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/fth/t_wordlist.fth b/fth/t_wordlist.fth index 206140d..e378323 100644 --- a/fth/t_wordlist.fth +++ b/fth/t_wordlist.fth @@ -7,7 +7,8 @@ \ \ Copied and modified from \ http://www.forth200x.org/documents/html3/testsuite.html#section.F.19 - +exists? (init-wordlists) +[if] include? }T{ t_tools.fth test{ @@ -132,4 +133,7 @@ T{ ONLY FORTH DEFINITIONS ORDER }T{ }T CR .( Plus another unnamed wordlist at head of search order) CR T{ alsowid2 DEFINITIONS ORDER }T{ }T -}test \ No newline at end of file +}test +[else] +." This compilation doesn't support word lists or SEARCH-ORDER word set" cr +[then] \ No newline at end of file From 07dfd0e5a4d1302efc0875b2b61d1d57139adb78 Mon Sep 17 00:00:00 2001 From: Hannu Vuolasaho Date: Fri, 5 Jun 2015 04:14:47 +0300 Subject: [PATCH 12/12] Word list avare FORGET and MARKER tst cases --- fth/t_wordlist.fth | 31 ++++++++++++++++++++++++++++++- 1 file changed, 30 insertions(+), 1 deletion(-) diff --git a/fth/t_wordlist.fth b/fth/t_wordlist.fth index e378323..c5b4e89 100644 --- a/fth/t_wordlist.fth +++ b/fth/t_wordlist.fth @@ -133,7 +133,36 @@ T{ ONLY FORTH DEFINITIONS ORDER }T{ }T CR .( Plus another unnamed wordlist at head of search order) CR T{ alsowid2 DEFINITIONS ORDER }T{ }T + +\ Marker tests +ONLY FORTH DEFINITIONS +wid2 @ set-current +create thisstays +marker mymark +create thisleaves +ONLY FORTH DEFINITIONS +create thisleavestoo +get-order wid2 @ swap 1+ set-order +\ Is search order and compilation lists returned? +T{ mymark get-order get-current }T{ forth-wordlist 1 wid2 @ }T +\ Are right words gone? +T{ exists? thisstays exists? thisleaves exists? thisleavestoo }T{ false false false }T +get-order wid2 @ swap 1+ set-order +T{ exists? thisstays exists? thisleaves exists? thisleavestoo }T{ true false false }T + +\ Forget testing Put something to wid2 +wid2 @ set-current +create thisleaves + +\ and forth-wordlist +forth-wordlist set-current +create thisstaystoo +wid2 @ set-current +forget thisleaves +\ Only thisleaves should be gone. +T{ exists? thisstays exists? thisleaves exists? thisstaystoo }T{ true false true }T + }test [else] -." This compilation doesn't support word lists or SEARCH-ORDER word set" cr +.( This compilation doesn't support word lists or SEARCH-ORDER word set) cr [then] \ No newline at end of file