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/.gitignore b/build/unix/.gitignore new file mode 100644 index 0000000..33fb3a4 --- /dev/null +++ b/build/unix/.gitignore @@ -0,0 +1,6 @@ +*.eo +*.o +pfdicdat.h +pforth +pforth.dic +pforth_standalone diff --git a/build/unix/Makefile b/build/unix/Makefile index c1df0d0..7826ca8 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) @@ -136,6 +139,7 @@ test: $(PFORTHAPP) 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) 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..c17f042 --- /dev/null +++ b/csrc/pf_search.c @@ -0,0 +1,119 @@ +/* @(#) 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 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; + + + +/* (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 ) +{ + 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("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); + 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, *tmp_arr; + if(gVarWordLists) + { + /* Don't underflow search */ + if( index < 0 ) return (cell_t) NULL; + /* Address to wordlist */ + 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 + { + /* Empty wordlist in search order */ + return (cell_t) NULL; + } + } + else + { + 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) +{ + cell_t Searching = TRUE; + cell_t Result = 0; + uint8_t NameLen; + const char *NameField; + + 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*/ + 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(NameToToken(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..16e3399 --- /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 gVarWlOrderFirst; +extern cell_t gVarWordLists; + +/* 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, + 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*)(gVarWordLists)+ + *(cell_t*)(gVarWlCompileIndex))))); + } + 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 { @@ -83,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 ) { @@ -147,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; @@ -165,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; @@ -373,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 ); @@ -386,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; } @@ -407,14 +429,29 @@ 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( gVarWordLists ) + { + iterator = *(cell_t *) gVarWlOrderFirst; + 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 { TempXT = NameToToken( NameField ); - + if( TempXT == XT ) { DBUGX(("ffCodeToName: NFA = 0x%x\n", NameField)); @@ -427,12 +464,32 @@ DBUGX(("ffCodeToName: NFA = 0x%x\n", NameField)); NameField = NameToPrevious( NameField ); if( NameField == NULL ) { - *NFAPtr = 0; +#ifdef PF_SUPPORT_WORDLIST + if( gVarWordLists && iterator >= 0) + { + NameField = (ForthString *)getWordList(iterator); + --iterator; + /* Ugly. */ + if( NameField == NULL) + { + *NFAPtr = 0; + Searching = FALSE; + } + } + else + { + /* Wordlists aren't loaded or all are searched + * and nothing found */ +#endif + *NFAPtr = 0; Searching = FALSE; +#ifdef PF_SUPPORT_WORDLIST + } +#endif } } } while ( Searching); - + return Result; } @@ -448,13 +505,46 @@ 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( gVarWordLists ) + { + iterator = *(cell_t *) gVarWlOrderFirst; + } + else + { + /* Search order not yet initialized.*/ + iterator = 0; + } +#endif WordLen = (uint8_t) ((ucell_t)*WordName & 0x1F); WordChar = WordName+1; - +#ifdef PF_SUPPORT_WORDLIST + if( gVarWordLists ) + { + 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 )); DBUG(("\nffFindNFA: gVarContext = 0x%x\n", gVarContext)); +#endif do { NameLen = (uint8_t) ((ucell_t)(*NameField) & MASK_NAME_SIZE); @@ -474,8 +564,29 @@ 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( gVarWordLists && iterator >= 0) + { + do + { + /* Skip empty lists middle */ + NameField = (ForthString *)getWordList(iterator); + --iterator; + }while( NameField == NULL && iterator >= 0 ); + if( NameField == NULL) + { + *NFAPtr = WordName; + Searching = FALSE; + } + } + else + { +#endif + *NFAPtr = WordName; + Searching = FALSE; +#ifdef PF_SUPPORT_WORDLIST + } +#endif } } } while ( Searching); @@ -492,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 ) @@ -524,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 ) { @@ -548,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) { @@ -578,9 +689,9 @@ static void ffStringColon( const ForthStringPtr FName) void ffColon( void ) { char *FName; - + gDepthAtColon = DATA_STACK_DEPTH; - + FName = ffWord( BLANK ); if( *FName > 0 ) { @@ -595,7 +706,7 @@ static cell_t CheckRedefinition( const ForthStringPtr FName ) { cell_t flag; ExecToken XT; - + flag = ffFind( FName, &XT); if ( flag && !gVarQuiet) { @@ -608,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 ) { @@ -631,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. */ @@ -652,7 +763,7 @@ static void CreateDeferredC( ExecToken DefaultXT, const char *CName ) void ffDefer( void ) { char *FName; - + FName = ffWord( BLANK ); if( *FName > 0 ) { @@ -671,7 +782,7 @@ ThrowCode ffSemiColon( void ) { ThrowCode exception = 0; gVarState = 0; - + if( (gDepthAtColon != DATA_STACK_DEPTH) && (gDepthAtColon != DEPTH_AT_COLON_INVALID) ) /* Ignore if no ':' */ { @@ -690,6 +801,13 @@ void ffFinishSecondary( void ) { CODE_COMMA( ID_EXIT ); ffUnSmudge(); +#ifdef PF_SUPPORT_WORDLIST + /* Copy context to word list when they are available. */ + if( gVarWordLists ) + { + *((cell_t*)(gVarWordLists)+*(cell_t*)(gVarWlCompileIndex)) = gVarContext; + } +#endif } /**************************************************************/ @@ -714,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; @@ -743,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 )); @@ -768,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 ) @@ -785,7 +903,7 @@ DBUG(("FindAndCompile: after number?\n" )); ffLiteral( Num ); } break; - + case NUM_TYPE_DOUBLE: if( gVarState ) /* compiling? */ { @@ -809,7 +927,7 @@ DBUG(("FindAndCompile: after number?\n" )); MSG( " ? - unrecognized word!\n" ); exception = THROW_UNDEFINED_WORD; break; - + } } error: @@ -825,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; @@ -857,7 +975,7 @@ ThrowCode ffInterpret( void ) error: return exception; } - + /**************************************************************/ ThrowCode ffOK( void ) { @@ -897,7 +1015,7 @@ ThrowCode ffOK( void ) void pfHandleIncludeError( void ) { FileStream *cur; - + while( (cur = ffPopInputStream()) != PF_STDIN) { DBUG(("ffCleanIncludeStack: closing 0x%x\n", cur )); @@ -933,7 +1051,7 @@ ThrowCode ffOuterInterpreterLoop( void ) ThrowCode ffIncludeFile( FileStream *InputFile ) { ThrowCode exception; - + /* Push file stream. */ exception = ffPushInputStream( InputFile ); if( exception < 0 ) return exception; @@ -941,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++ ) { @@ -962,7 +1080,7 @@ ThrowCode ffIncludeFile( FileStream *InputFile ) /* Pop file stream. */ ffPopInputStream(); - + /* ANSI spec specifies that this should also close the file. */ sdCloseFile(InputFile); @@ -978,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 ) { @@ -1003,8 +1121,8 @@ Err ffPushInputStream( FileStream *InputFile ) ERR("ffPushInputStream: max depth exceeded.\n"); return -1; } - - + + return Result; } @@ -1016,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 ) { @@ -1068,7 +1186,7 @@ cell_t ffConvertStreamToSourceID( FileStream *Stream ) FileStream * ffConvertSourceIDToStream( cell_t id ) { FileStream *stream; - + if( id == 0 ) { stream = PF_STDIN; @@ -1077,7 +1195,7 @@ FileStream * ffConvertSourceIDToStream( cell_t id ) { stream = NULL; } - else + else { stream = (FileStream *) id; } @@ -1110,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++; @@ -1131,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; } @@ -1174,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/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/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 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..4ef435b --- /dev/null +++ b/fth/search.fth @@ -0,0 +1,325 @@ +\ @(#) search.fth 5/06/20 0.3 +\ 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 + +\ 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 \ [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 +\ Namebase during dictionary file build +variable wl.offset + +: wl.check ( index -- , throw if out of bounds ) + dup WORDLISTS >= ERR_SEARCH_OVERFLOW and throw + 0< ERR_SEARCH_UNDERFLOW and throw +; + +: wl.check.wid ( wid -- throw if out of bounds ) + [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 +; + +: get-current ( -- wid , compilation word list ) + wl.compile.index @ cells [wordlists] + if.use->rel +; + +: get-order ( -- widn ... wid1 n ) + wl.order.first @ 1+ 0 + ?do + i cells [searchorder] + @ + loop + wl.order.first @ 1+ +; + +: set-current ( wid -- , compilation word list to wid ) + \ check wid + dup wl.check.wid + + \ make index and put it under + [wordlists] use->rel - + cell / ( wid index-to-[wordlists] ) + + wl.compile.index ! +; + +: definitions ( -- ) + \ get first in search order and set it to compilation + wl.order.first @ ( index ) + cells [searchorder] + @ ( wid ) + set-current +; + +: set-order ( widn ... wid1 n -- , Set the search order ) + dup -1 = + if + drop [wordlists] if.use->rel [searchorder] ! + 0 + else + dup wl.check + dup 0= + if + drop -1 + else + dup 1- swap + 0 do + dup i - cells ( wid1 ... widn n offset ) + [searchorder] + ( wid1 ... widn n addr ) + rot swap ! + loop + then + then + wl.order.first ! +; + +: wordlist ( -- wid , Create a new empty word list ) + wl.used @ 1+ dup wl.check dup wl.used ! ( index , incerment and store ) + cells [wordlists] + 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 [wordlists] as first ) + get-order nip [wordlists] if.use->rel swap set-order +; + +: only ( -- , Set search order to forth-wordlist ) + -1 set-order +; + +: order ( -- , print search order wordlist ) + get-current ." Compile to: 0x" .hex cr + ." search from:" cr + get-order 0 ?do + i . ." 0x" .hex cr + loop +; + +: previous ( -- ) get-order nip 1- set-order ; + +: init-wordlists ( -- , put forth context to [wordlists] ) + WORDLISTS 0 do + 0 i cells [wordlists] + ! + 0 i cells [searchorder] + ! + loop + context @ [wordlists] ! + [wordlists] if.use->rel [searchorder] ! +; + +init-wordlists + +: init-wordlists ( -- , Relocate [wordlists] ) + + \ Fix dictionaries. + WORDLISTS 0 do + i cells [wordlists] + dup @ dup 0<> ( addr val flag ) + if + wl.offset @ - namebase + swap ! ( ) + else + 2drop + then + loop + context @ wl.compile.index @ cells [wordlists] + ! + [searchorder] wl.order.first [wordlists] 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 +\ ; +: forth-wordlist ( -- wid , Convert variable [wordlists] to wid ) + [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-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 + + +\ 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 +; + + +\ 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 + 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 ) + [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 + + +false [if] +: wordlists? ( -- ) + cr ." wordlists:"cr + WORDLISTS 0 + do + 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 + 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 + 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 +; + +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 diff --git a/fth/t_wordlist.fth b/fth/t_wordlist.fth new file mode 100644 index 0000000..c5b4e89 --- /dev/null +++ b/fth/t_wordlist.fth @@ -0,0 +1,168 @@ +\ @(#) 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 +exists? (init-wordlists) +[if] +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 + +\ 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 +[then] \ No newline at end of file