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