git.gag.com Git - debian/pforth/blob - csrc/pf_core.c

   1 /* @(#) pf_core.c 98/01/28 1.5 */
   2 /***************************************************************
   3 ** Forth based on 'C'
   4 **
   5 ** This file has the main entry points to the pForth library.
   6 **
   7 ** Author: Phil Burk
   8 ** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
   9 **
  10 ** Permission to use, copy, modify, and/or distribute this
  11 ** software for any purpose with or without fee is hereby granted.
  12 **
  13 ** THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
  14 ** WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
  15 ** WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL
  16 ** THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
  17 ** CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING
  18 ** FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF
  19 ** CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
  20 ** OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
  21 **
  22 ****************************************************************
  23 ** 940502 PLB Creation.
  24 ** 940505 PLB More macros.
  25 ** 940509 PLB Moved all stack handling into inner interpreter.
  26 **        Added Create, Colon, Semicolon, HNumberQ, etc.
  27 ** 940510 PLB Got inner interpreter working with secondaries.
  28 **        Added (LITERAL).   Compiles colon definitions.
  29 ** 940511 PLB Added conditionals, LITERAL, CREATE DOES>
  30 ** 940512 PLB Added DO LOOP DEFER, fixed R>
  31 ** 940520 PLB Added INCLUDE
  32 ** 940521 PLB Added NUMBER?
  33 ** 940930 PLB Outer Interpreter now uses deferred NUMBER?
  34 ** 941005 PLB Added ANSI locals, LEAVE, modularised
  35 ** 950320 RDG Added underflow checking for FP stack
  36 ** 970702 PLB Added STACK_SAFETY to FP stack size.
  37 ***************************************************************/
  38
  39 #include "pf_all.h"
  40
  41 /***************************************************************
  42 ** Global Data
  43 ***************************************************************/
  44
  45 char            gScratch[TIB_SIZE];
  46 pfTaskData_t   *gCurrentTask = NULL;
  47 pfDictionary_t *gCurrentDictionary;
  48 cell_t          gNumPrimitives;
  49
  50 ExecToken       gLocalCompiler_XT;   /* custom compiler for local variables */
  51 ExecToken       gNumberQ_XT;         /* XT of NUMBER? */
  52 ExecToken       gQuitP_XT;           /* XT of (QUIT) */
  53 ExecToken       gAcceptP_XT;         /* XT of ACCEPT */
  54
  55 /* Depth of data stack when colon called. */
  56 cell_t          gDepthAtColon;
  57
  58 /* Global Forth variables. */
  59 cell_t          gVarContext;      /* Points to last name field. */
  60 cell_t          gVarState;        /* 1 if compiling. */
  61 cell_t          gVarBase;         /* Numeric Base. */
  62 cell_t          gVarByeCode;      /* Echo input. */
  63 cell_t          gVarEcho;         /* Echo input. */
  64 cell_t          gVarTraceLevel;   /* Trace Level for Inner Interpreter. */
  65 cell_t          gVarTraceStack;   /* Dump Stack each time if true. */
  66 cell_t          gVarTraceFlags;   /* Enable various internal debug messages. */
  67 cell_t          gVarQuiet;        /* Suppress unnecessary messages, OK, etc. */
  68 cell_t          gVarReturnCode;   /* Returned to caller of Forth, eg. UNIX shell. */
  69
  70 /* data for INCLUDE that allows multiple nested files. */
  71 IncludeFrame    gIncludeStack[MAX_INCLUDE_DEPTH];
  72 cell_t          gIncludeIndex;
  73
  74 static void pfResetForthTask( void );
  75 static void pfInit( void );
  76 static void pfTerm( void );
  77
  78 #define DEFAULT_RETURN_DEPTH (512)
  79 #define DEFAULT_USER_DEPTH (512)
  80
  81 #ifndef PF_DEFAULT_HEADER_SIZE
  82 #define PF_DEFAULT_HEADER_SIZE (120000)
  83 #endif
  84
  85 #ifndef PF_DEFAULT_CODE_SIZE
  86 #define PF_DEFAULT_CODE_SIZE (300000)
  87 #endif
  88
  89 /* Initialize globals in a function to simplify loading on
  90  * embedded systems which may not support initialization of data section.
  91  */
  92 static void pfInit( void )
  93 {
  94 /* all zero */
  95     gCurrentTask = NULL;
  96     gCurrentDictionary = NULL;
  97     gNumPrimitives = 0;
  98     gLocalCompiler_XT = 0;
  99     gVarContext = (cell_t)NULL;   /* Points to last name field. */
 100     gVarState = 0;        /* 1 if compiling. */
 101     gVarEcho = 0;       /* Echo input. */
 102     gVarTraceLevel = 0;   /* Trace Level for Inner Interpreter. */
 103     gVarTraceFlags = 0;   /* Enable various internal debug messages. */
 104     gVarReturnCode = 0;   /* Returned to caller of Forth, eg. UNIX shell. */
 105     gIncludeIndex = 0;
 106
 107 /* non-zero */
 108     gVarBase = 10;        /* Numeric Base. */
 109     gDepthAtColon = DEPTH_AT_COLON_INVALID;
 110     gVarTraceStack = 1;
 111
 112     pfInitMemoryAllocator();
 113     ioInit();
 114 }
 115 static void pfTerm( void )
 116 {
 117     ioTerm();
 118 }
 119
 120 /***************************************************************
 121 ** Task Management
 122 ***************************************************************/
 123
 124 void pfDeleteTask( PForthTask task )
 125 {
 126     pfTaskData_t *cftd = (pfTaskData_t *)task;
 127     FREE_VAR( cftd->td_ReturnLimit );
 128     FREE_VAR( cftd->td_StackLimit );
 129     pfFreeMem( cftd );
 130 }
 131
 132 /* Allocate some extra cells to protect against mild stack underflows. */
 133 #define STACK_SAFETY  (8)
 134 PForthTask pfCreateTask( cell_t UserStackDepth, cell_t ReturnStackDepth )
 135 {
 136     pfTaskData_t *cftd;
 137
 138     cftd = ( pfTaskData_t * ) pfAllocMem( sizeof( pfTaskData_t ) );
 139     if( !cftd ) goto nomem;
 140     pfSetMemory( cftd, 0, sizeof( pfTaskData_t ));
 141
 142 /* Allocate User Stack */
 143     cftd->td_StackLimit = (cell_t *) pfAllocMem((ucell_t)(sizeof(cell_t) *
 144                 (UserStackDepth + STACK_SAFETY)));
 145     if( !cftd->td_StackLimit ) goto nomem;
 146     cftd->td_StackBase = cftd->td_StackLimit + UserStackDepth;
 147     cftd->td_StackPtr = cftd->td_StackBase;
 148
 149 /* Allocate Return Stack */
 150     cftd->td_ReturnLimit = (cell_t *) pfAllocMem((ucell_t)(sizeof(cell_t) * ReturnStackDepth) );
 151     if( !cftd->td_ReturnLimit ) goto nomem;
 152     cftd->td_ReturnBase = cftd->td_ReturnLimit + ReturnStackDepth;
 153     cftd->td_ReturnPtr = cftd->td_ReturnBase;
 154
 155 /* Allocate Float Stack */
 156 #ifdef PF_SUPPORT_FP
 157 /* Allocate room for as many Floats as we do regular data. */
 158     cftd->td_FloatStackLimit = (PF_FLOAT *) pfAllocMem((ucell_t)(sizeof(PF_FLOAT) *
 159                 (UserStackDepth + STACK_SAFETY)));
 160     if( !cftd->td_FloatStackLimit ) goto nomem;
 161     cftd->td_FloatStackBase = cftd->td_FloatStackLimit + UserStackDepth;
 162     cftd->td_FloatStackPtr = cftd->td_FloatStackBase;
 163 #endif
 164
 165     cftd->td_InputStream = PF_STDIN;
 166
 167     cftd->td_SourcePtr = &cftd->td_TIB[0];
 168     cftd->td_SourceNum = 0;
 169
 170     return (PForthTask) cftd;
 171
 172 nomem:
 173     ERR("CreateTaskContext: insufficient memory.\n");
 174     if( cftd ) pfDeleteTask( (PForthTask) cftd );
 175     return NULL;
 176 }
 177
 178 /***************************************************************
 179 ** Dictionary Management
 180 ***************************************************************/
 181
 182 ThrowCode pfExecIfDefined( const char *CString )
 183 {
 184     ThrowCode result = 0;
 185     if( NAME_BASE != (cell_t)NULL)
 186     {
 187         ExecToken  XT;
 188         if( ffFindC( CString, &XT ) )
 189         {
 190             result = pfCatch( XT );
 191         }
 192     }
 193     return result;
 194 }
 195
 196 /***************************************************************
 197 ** Delete a dictionary created by pfCreateDictionary()
 198 */
 199 void pfDeleteDictionary( PForthDictionary dictionary )
 200 {
 201     pfDictionary_t *dic = (pfDictionary_t *) dictionary;
 202     if( !dic ) return;
 203
 204     if( dic->dic_Flags & PF_DICF_ALLOCATED_SEGMENTS )
 205     {
 206         FREE_VAR( dic->dic_HeaderBaseUnaligned );
 207         FREE_VAR( dic->dic_CodeBaseUnaligned );
 208     }
 209     pfFreeMem( dic );
 210 }
 211
 212 /***************************************************************
 213 ** Create a complete dictionary.
 214 ** The dictionary consists of two parts, the header with the names,
 215 ** and the code portion.
 216 ** Delete using pfDeleteDictionary().
 217 ** Return pointer to dictionary management structure.
 218 */
 219 PForthDictionary pfCreateDictionary( cell_t HeaderSize, cell_t CodeSize )
 220 {
 221 /* Allocate memory for initial dictionary. */
 222     pfDictionary_t *dic;
 223
 224     dic = ( pfDictionary_t * ) pfAllocMem( sizeof( pfDictionary_t ) );
 225     if( !dic ) goto nomem;
 226     pfSetMemory( dic, 0, sizeof( pfDictionary_t ));
 227
 228     dic->dic_Flags |= PF_DICF_ALLOCATED_SEGMENTS;
 229
 230 /* Align dictionary segments to preserve alignment of floats across hosts.
 231  * Thank you Helmut Proelss for pointing out that this needs to be cast
 232  * to (ucell_t) on 16 bit systems.
 233  */
 234 #define DIC_ALIGNMENT_SIZE  ((ucell_t)(0x10))
 235 #define DIC_ALIGN(addr)  ((((ucell_t)(addr)) + DIC_ALIGNMENT_SIZE - 1) & ~(DIC_ALIGNMENT_SIZE - 1))
 236
 237 /* Allocate memory for header. */
 238     if( HeaderSize > 0 )
 239     {
 240         dic->dic_HeaderBaseUnaligned = (ucell_t) pfAllocMem( (ucell_t) HeaderSize + DIC_ALIGNMENT_SIZE );
 241         if( !dic->dic_HeaderBaseUnaligned ) goto nomem;
 242 /* Align header base. */
 243         dic->dic_HeaderBase = DIC_ALIGN(dic->dic_HeaderBaseUnaligned);
 244         pfSetMemory( (char *) dic->dic_HeaderBase, 0xA5, (ucell_t) HeaderSize);
 245         dic->dic_HeaderLimit = dic->dic_HeaderBase + HeaderSize;
 246         dic->dic_HeaderPtr = dic->dic_HeaderBase;
 247     }
 248     else
 249     {
 250         dic->dic_HeaderBase = 0;
 251     }
 252
 253 /* Allocate memory for code. */
 254     dic->dic_CodeBaseUnaligned = (ucell_t) pfAllocMem( (ucell_t) CodeSize + DIC_ALIGNMENT_SIZE );
 255     if( !dic->dic_CodeBaseUnaligned ) goto nomem;
 256     dic->dic_CodeBase = DIC_ALIGN(dic->dic_CodeBaseUnaligned);
 257     pfSetMemory( (char *) dic->dic_CodeBase, 0x5A, (ucell_t) CodeSize);
 258
 259     dic->dic_CodeLimit = dic->dic_CodeBase + CodeSize;
 260     dic->dic_CodePtr.Byte = ((uint8_t *) (dic->dic_CodeBase + QUADUP(NUM_PRIMITIVES)));
 261
 262     return (PForthDictionary) dic;
 263 nomem:
 264     pfDeleteDictionary( dic );
 265     return NULL;
 266 }
 267
 268 /***************************************************************
 269 ** Used by Quit and other routines to restore system.
 270 ***************************************************************/
 271
 272 static void pfResetForthTask( void )
 273 {
 274 /* Go back to terminal input. */
 275     gCurrentTask->td_InputStream = PF_STDIN;
 276
 277 /* Reset stacks. */
 278     gCurrentTask->td_StackPtr = gCurrentTask->td_StackBase;
 279     gCurrentTask->td_ReturnPtr = gCurrentTask->td_ReturnBase;
 280 #ifdef PF_SUPPORT_FP  /* Reset Floating Point stack too! */
 281     gCurrentTask->td_FloatStackPtr = gCurrentTask->td_FloatStackBase;
 282 #endif
 283
 284 /* Advance >IN to end of input. */
 285     gCurrentTask->td_IN = gCurrentTask->td_SourceNum;
 286     gVarState = 0;
 287 }
 288
 289 /***************************************************************
 290 ** Set current task context.
 291 ***************************************************************/
 292
 293 void pfSetCurrentTask( PForthTask task )
 294 {
 295     gCurrentTask = (pfTaskData_t *) task;
 296 }
 297
 298 /***************************************************************
 299 ** Set Quiet Flag.
 300 ***************************************************************/
 301
 302 void pfSetQuiet( cell_t IfQuiet )
 303 {
 304     gVarQuiet = (cell_t) IfQuiet;
 305 }
 306
 307 /***************************************************************
 308 ** Query message status.
 309 ***************************************************************/
 310
 311 cell_t  pfQueryQuiet( void )
 312 {
 313     return gVarQuiet;
 314 }
 315
 316 /***************************************************************
 317 ** Top level interpreter.
 318 ***************************************************************/
 319 ThrowCode pfQuit( void )
 320 {
 321     ThrowCode exception;
 322     int go = 1;
 323
 324     while(go)
 325     {
 326         exception = ffOuterInterpreterLoop();
 327         if( exception == 0 )
 328         {
 329             exception = ffOK();
 330         }
 331
 332         switch( exception )
 333         {
 334         case 0:
 335             break;
 336
 337         case THROW_BYE:
 338             go = 0;
 339             break;
 340
 341         case THROW_ABORT:
 342         default:
 343             ffDotS();
 344             pfReportThrow( exception );
 345             pfHandleIncludeError();
 346             pfResetForthTask();
 347             break;
 348         }
 349     }
 350
 351     return gVarReturnCode;
 352 }
 353
 354 /***************************************************************
 355 ** Include file based on 'C' name.
 356 ***************************************************************/
 357
 358 cell_t pfIncludeFile( const char *FileName )
 359 {
 360     FileStream *fid;
 361     cell_t Result;
 362     char  buffer[32];
 363     cell_t numChars, len;
 364
 365 /* Open file. */
 366     fid = sdOpenFile( FileName, "r" );
 367     if( fid == NULL )
 368     {
 369         ERR("pfIncludeFile could not open ");
 370         ERR(FileName);
 371         EMIT_CR;
 372         return -1;
 373     }
 374
 375 /* Create a dictionary word named ::::FileName for FILE? */
 376     pfCopyMemory( &buffer[0], "::::", 4);
 377     len = (cell_t) pfCStringLength(FileName);
 378     numChars = ( len > (32-4-1) ) ? (32-4-1) : len;
 379     pfCopyMemory( &buffer[4], &FileName[len-numChars], numChars+1 );
 380     CreateDicEntryC( ID_NOOP, buffer, 0 );
 381
 382     Result = ffIncludeFile( fid ); /* Also close the file. */
 383
 384 /* Create a dictionary word named ;;;; for FILE? */
 385     CreateDicEntryC( ID_NOOP, ";;;;", 0 );
 386
 387     return Result;
 388 }
 389
 390 /***************************************************************
 391 ** Output 'C' string message.
 392 ** Use sdTerminalOut which works before initializing gCurrentTask.
 393 ***************************************************************/
 394 void pfDebugMessage( const char *CString )
 395 {
 396 #if 0
 397     while( *CString )
 398     {
 399         char c = *CString++;
 400         if( c == '\n' )
 401         {
 402             sdTerminalOut( 0x0D );
 403             sdTerminalOut( 0x0A );
 404             pfDebugMessage( "DBG: " );
 405         }
 406         else
 407         {
 408             sdTerminalOut( c );
 409         }
 410     }
 411 #else
 412     (void)CString;
 413 #endif
 414 }
 415
 416 /***************************************************************
 417 ** Print a decimal number to debug output.
 418 */
 419 void pfDebugPrintDecimalNumber( int n )
 420 {
 421     pfDebugMessage( ConvertNumberToText( n, 10, TRUE, 1 ) );
 422 }
 423
 424
 425 /***************************************************************
 426 ** Output 'C' string message.
 427 ** This is provided to help avoid the use of printf() and other I/O
 428 ** which may not be present on a small embedded system.
 429 ** Uses ioType & ioEmit so requires that gCurrentTask has been initialized.
 430 ***************************************************************/
 431 void pfMessage( const char *CString )
 432 {
 433     ioType( CString, (cell_t) pfCStringLength(CString) );
 434 }
 435
 436 /**************************************************************************
 437 ** Main entry point for pForth.
 438 */
 439 ThrowCode pfDoForth( const char *DicFileName, const char *SourceName, cell_t IfInit )
 440 {
 441     pfTaskData_t *cftd;
 442     pfDictionary_t *dic = NULL;
 443     ThrowCode Result = 0;
 444     ExecToken  EntryPoint = 0;
 445
 446 #ifdef PF_USER_INIT
 447     Result = PF_USER_INIT;
 448     if( Result < 0 ) goto error1;
 449 #endif
 450
 451     pfInit();
 452
 453 /* Allocate Task structure. */
 454     pfDebugMessage("pfDoForth: call pfCreateTask()\n");
 455     cftd = pfCreateTask( DEFAULT_USER_DEPTH, DEFAULT_RETURN_DEPTH );
 456
 457     if( cftd )
 458     {
 459         pfSetCurrentTask( cftd );
 460
 461         if( !gVarQuiet )
 462         {
 463             MSG( "PForth V"PFORTH_VERSION );
 464             if( IsHostLittleEndian() ) MSG("-LE");
 465             else MSG("-BE");
 466 #if PF_BIG_ENDIAN_DIC
 467             MSG("/BE");
 468 #elif PF_LITTLE_ENDIAN_DIC
 469             MSG("/LE");
 470 #endif
 471             if (sizeof(cell_t) == 8)
 472             {
 473                 MSG("/64");
 474             }
 475             else if (sizeof(cell_t) == 4)
 476             {
 477                 MSG("/32");
 478             }
 479
 480             MSG( ", built "__DATE__" "__TIME__ );
 481         }
 482
 483 /* Don't use MSG before task set. */
 484         if( SourceName )
 485         {
 486             pfDebugMessage("SourceName = "); pfDebugMessage(SourceName); pfDebugMessage("\n");
 487         }
 488
 489
 490 #ifdef PF_NO_GLOBAL_INIT
 491         if( LoadCustomFunctionTable() < 0 ) goto error2; /* Init custom 'C' call array. */
 492 #endif
 493
 494 #if (!defined(PF_NO_INIT)) && (!defined(PF_NO_SHELL))
 495         if( IfInit )
 496         {
 497             pfDebugMessage("Build dictionary from scratch.\n");
 498             dic = pfBuildDictionary( PF_DEFAULT_HEADER_SIZE, PF_DEFAULT_CODE_SIZE );
 499         }
 500         else
 501 #else
 502         TOUCH(IfInit);
 503 #endif /* !PF_NO_INIT && !PF_NO_SHELL*/
 504         {
 505             if( DicFileName )
 506             {
 507                 pfDebugMessage("DicFileName = "); pfDebugMessage(DicFileName); pfDebugMessage("\n");
 508                 if( !gVarQuiet )
 509                 {
 510                     EMIT_CR;
 511                 }
 512                 dic = pfLoadDictionary( DicFileName, &EntryPoint );
 513             }
 514             else
 515             {
 516                 if( !gVarQuiet )
 517                 {
 518                     MSG(" (static)");
 519                     EMIT_CR;
 520                 }
 521                 dic = pfLoadStaticDictionary();
 522             }
 523         }
 524         if( dic == NULL ) goto error2;
 525
 526         if( !gVarQuiet )
 527         {
 528             EMIT_CR;
 529         }
 530
 531         pfDebugMessage("pfDoForth: try AUTO.INIT\n");
 532         Result = pfExecIfDefined("AUTO.INIT");
 533         if( Result != 0 )
 534         {
 535             MSG("Error in AUTO.INIT");
 536             goto error2;
 537         }
 538
 539         if( EntryPoint != 0 )
 540         {
 541             Result = pfCatch( EntryPoint );
 542         }
 543 #ifndef PF_NO_SHELL
 544         else
 545         {
 546             if( SourceName == NULL )
 547             {
 548                 pfDebugMessage("pfDoForth: pfQuit\n");
 549                 Result = pfQuit();
 550             }
 551             else
 552             {
 553                 if( !gVarQuiet )
 554                 {
 555                     MSG("Including: ");
 556                     MSG(SourceName);
 557                     MSG("\n");
 558                 }
 559                 Result = pfIncludeFile( SourceName );
 560             }
 561         }
 562 #endif /* PF_NO_SHELL */
 563
 564     /* Clean up after running Forth. */
 565         pfExecIfDefined("AUTO.TERM");
 566         pfDeleteDictionary( dic );
 567         pfDeleteTask( cftd );
 568     }
 569
 570     pfTerm();
 571
 572 #ifdef PF_USER_TERM
 573     PF_USER_TERM;
 574 #endif
 575
 576     return Result ? Result : gVarByeCode;
 577
 578 error2:
 579     MSG("pfDoForth: Error occured.\n");
 580     pfDeleteTask( cftd );
 581     /* Terminate so we restore normal shell tty mode. */
 582     pfTerm();
 583
 584 #ifdef PF_USER_INIT
 585 error1:
 586 #endif
 587
 588     return -1;
 589 }
 590
 591
 592 #ifdef PF_UNIT_TEST
 593 cell_t pfUnitTest( void )
 594 {
 595     cell_t numErrors = 0;
 596     numErrors += pfUnitTestText();
 597     return numErrors;
 598 }
 599 #endif