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