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

   1 /* @(#) pf_words.c 96/12/18 1.10 */
   2 /***************************************************************
   3 ** Forth words for PForth based on 'C'
   4 **
   5 ** Author: Phil Burk
   6 ** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
   7 **
   8 ** The pForth software code is dedicated to the public domain,
   9 ** and any third party may reproduce, distribute and modify
  10 ** the pForth software code or any derivative works thereof
  11 ** without any compensation or license.  The pForth software
  12 ** code is provided on an "as is" basis without any warranty
  13 ** of any kind, including, without limitation, the implied
  14 ** warranties of merchantability and fitness for a particular
  15 ** purpose and their equivalents under the laws of any jurisdiction.
  16 **
  17 **
  18 **  941031  rdg     fix ffScan() to look for CRs and LFs
  19 **
  20 ***************************************************************/
  21
  22 #include "pf_all.h"
  23
  24
  25 /***************************************************************
  26 ** Print number in current base to output stream.
  27 ** This version does not handle double precision.
  28 */
  29 void ffDot( cell_t n )
  30 {
  31     MSG( ConvertNumberToText( n, gVarBase, TRUE, 1 ) );
  32     EMIT(' ');
  33 }
  34
  35 /***************************************************************
  36 ** Print number in current base to output stream.
  37 ** This version does not handle double precision.
  38 */
  39 void ffDotHex( cell_t n )
  40 {
  41     MSG( ConvertNumberToText( n, 16, FALSE, 1 ) );
  42     EMIT(' ');
  43 }
  44
  45 /* ( ... --- ... , print stack ) */
  46 void ffDotS( void )
  47 {
  48     cell_t *sp;
  49     cell_t i, Depth;
  50
  51     MSG("Stack<");
  52     MSG( ConvertNumberToText( gVarBase, 10, TRUE, 1 ) ); /* Print base in decimal. */
  53     MSG("> ");
  54
  55     Depth = gCurrentTask->td_StackBase - gCurrentTask->td_StackPtr;
  56     sp = gCurrentTask->td_StackBase;
  57
  58     if( Depth < 0 )
  59     {
  60         MSG("UNDERFLOW!");
  61     }
  62     else
  63     {
  64         for( i=0; i<Depth; i++ )
  65         {
  66 /* Print as unsigned if not base 10. */
  67             MSG( ConvertNumberToText( *(--sp), gVarBase, (gVarBase == 10), 1 ) );
  68             EMIT(' ');
  69         }
  70     }
  71     MSG("\n");
  72 }
  73
  74 /* ( addr cnt char -- addr' cnt' , skip leading characters ) */
  75 cell_t ffSkip( char *AddrIn, cell_t Cnt, char c, char **AddrOut )
  76 {
  77     char *s;
  78
  79     s = AddrIn;
  80
  81     if( c == BLANK )
  82     {
  83         while( ( Cnt > 0 ) &&
  84             (( *s == BLANK) || ( *s == '\t')) )
  85         {
  86 DBUGX(("ffSkip BLANK: %c, %d\n", *s, Cnt ));
  87             s++;
  88             Cnt--;
  89         }
  90     }
  91     else
  92     {
  93         while(( Cnt > 0 ) && ( *s == c ))
  94         {
  95 DBUGX(("ffSkip: %c=0x%x, %d\n", *s, Cnt ));
  96         s++;
  97         Cnt--;
  98         }
  99     }
 100     *AddrOut = s;
 101     return Cnt;
 102 }
 103
 104 /* ( addr cnt char -- addr' cnt' , scan for char ) */
 105 cell_t ffScan( char *AddrIn, cell_t Cnt, char c, char **AddrOut )
 106 {
 107     char *s;
 108
 109     s = AddrIn;
 110
 111     if( c == BLANK )
 112     {
 113         while(( Cnt > 0 ) &&
 114             ( *s != BLANK) &&
 115             ( *s != '\r') &&
 116             ( *s != '\n') &&
 117             ( *s != '\t'))
 118         {
 119 DBUGX(("ffScan BLANK: %c, %d\n", *s, Cnt ));
 120             s++;
 121             Cnt--;
 122         }
 123     }
 124     else
 125     {
 126         while(( Cnt > 0 ) && ( *s != c ))
 127         {
 128 DBUGX(("ffScan: %c, %d\n", *s, Cnt ));
 129             s++;
 130             Cnt--;
 131         }
 132     }
 133     *AddrOut = s;
 134     return Cnt;
 135 }
 136
 137 /***************************************************************
 138 ** Forth equivalent 'C' functions.
 139 ***************************************************************/
 140
 141 /* Convert a single digit to the corresponding hex number. */
 142 static cell_t HexDigitToNumber( char c )
 143 {
 144     if( (c >= '0') && (c <= '9') )
 145     {
 146         return( c - '0' );
 147     }
 148     else if ( (c >= 'A') && (c <= 'F') )
 149     {
 150         return( c - 'A' + 0x0A );
 151     }
 152     else
 153     {
 154         return -1;
 155     }
 156 }
 157
 158 /* Convert a string to the corresponding number using BASE. */
 159 cell_t ffNumberQ( const char *FWord, cell_t *Num )
 160 {
 161     cell_t Len, i, Accum=0, n, Sign=1, Base=gVarBase;
 162     const char *s;
 163
 164 /* get count */
 165     Len = *FWord++;
 166     s = FWord;
 167
 168     switch (*s) {
 169     case '#': Base = 10; s++; Len--; break;
 170     case '$': Base = 16; s++; Len--; break;
 171     case '%': Base =  2; s++; Len--; break;
 172     case '\'':
 173         if( Len == 3 && s[2] == '\'' )
 174         {
 175             *Num = s[1];
 176             return NUM_TYPE_SINGLE;
 177         }
 178     }
 179
 180 /* process initial minus sign */
 181     if( *s == '-' )
 182     {
 183         Sign = -1;
 184         s++;
 185         Len--;
 186     }
 187
 188     for( i=0; i<Len; i++)
 189     {
 190         n = HexDigitToNumber( *s++ );
 191         if( (n < 0) || (n >= Base) )
 192         {
 193             return NUM_TYPE_BAD;
 194         }
 195
 196         Accum = (Accum * Base) + n;
 197     }
 198     *Num = Accum * Sign;
 199     return NUM_TYPE_SINGLE;
 200 }
 201
 202 /***************************************************************
 203 ** Compiler Support
 204 ***************************************************************/
 205
 206 /* Skip whitespace, then parse input delimited by C. If UPCASE is true
 207  * convert the word to upper case.  The result is stored in
 208  * gScratch.
 209  */
 210 static char * Word ( char c, int Upcase )
 211 {
 212     char *s1,*s2,*s3;
 213     cell_t n1, n2, n3;
 214     cell_t i, nc;
 215
 216     s1 = gCurrentTask->td_SourcePtr + gCurrentTask->td_IN;
 217     n1 = gCurrentTask->td_SourceNum - gCurrentTask->td_IN;
 218     n2 = ffSkip( s1, n1, c, &s2 );
 219 DBUGX(("Word: s2=%c, %d\n", *s2, n2 ));
 220     n3 = ffScan( s2, n2, c, &s3 );
 221 DBUGX(("Word: s3=%c, %d\n", *s3, n3 ));
 222     nc = n2-n3;
 223     if (nc > 0)
 224     {
 225         gScratch[0] = (char) nc;
 226         for( i=0; i<nc; i++ )
 227         {
 228             gScratch[i+1] = Upcase ? pfCharToUpper( s2[i] ) : s2[i] ;
 229         }
 230     }
 231     else
 232     {
 233
 234         gScratch[0] = 0;
 235     }
 236     gCurrentTask->td_IN += (n1-n3) + 1;
 237     return &gScratch[0];
 238 }
 239
 240 /* ( char -- c-addr , parse word ) */
 241 char * ffWord( char c )
 242 {
 243   return Word( c, TRUE );
 244 }
 245
 246 /* ( char -- c-addr , parse word, preserving case ) */
 247 char * ffLWord( char c )
 248 {
 249   return Word( c, FALSE );
 250 }