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 ** Permission to use, copy, modify, and/or distribute this
   9 ** software for any purpose with or without fee is hereby granted.
  10 **
  11 ** THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
  12 ** WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
  13 ** WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL
  14 ** THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
  15 ** CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING
  16 ** FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF
  17 ** CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
  18 ** OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
  19 **
  20 **
  21 **  941031  rdg     fix ffScan() to look for CRs and LFs
  22 **
  23 ***************************************************************/
  24
  25 #include "pf_all.h"
  26
  27
  28 /***************************************************************
  29 ** Print number in current base to output stream.
  30 ** This version does not handle double precision.
  31 */
  32 void ffDot( cell_t n )
  33 {
  34     MSG( ConvertNumberToText( n, gVarBase, TRUE, 1 ) );
  35     EMIT(' ');
  36 }
  37
  38 /***************************************************************
  39 ** Print number in current base to output stream.
  40 ** This version does not handle double precision.
  41 */
  42 void ffDotHex( cell_t n )
  43 {
  44     MSG( ConvertNumberToText( n, 16, FALSE, 1 ) );
  45     EMIT(' ');
  46 }
  47
  48 /* ( ... --- ... , print stack ) */
  49 void ffDotS( void )
  50 {
  51     cell_t *sp;
  52     cell_t i, Depth;
  53
  54     MSG("Stack<");
  55     MSG( ConvertNumberToText( gVarBase, 10, TRUE, 1 ) ); /* Print base in decimal. */
  56     MSG("> ");
  57
  58     Depth = gCurrentTask->td_StackBase - gCurrentTask->td_StackPtr;
  59     sp = gCurrentTask->td_StackBase;
  60
  61     if( Depth < 0 )
  62     {
  63         MSG("UNDERFLOW!");
  64     }
  65     else
  66     {
  67         for( i=0; i<Depth; i++ )
  68         {
  69 /* Print as unsigned if not base 10. */
  70             MSG( ConvertNumberToText( *(--sp), gVarBase, (gVarBase == 10), 1 ) );
  71             EMIT(' ');
  72         }
  73     }
  74     MSG("\n");
  75 }
  76
  77 /* ( addr cnt char -- addr' cnt' , skip leading characters ) */
  78 cell_t ffSkip( char *AddrIn, cell_t Cnt, char c, char **AddrOut )
  79 {
  80     char *s;
  81
  82     s = AddrIn;
  83
  84     if( c == BLANK )
  85     {
  86         while( ( Cnt > 0 ) &&
  87             (( *s == BLANK) || ( *s == '\t')) )
  88         {
  89 DBUGX(("ffSkip BLANK: %c, %d\n", *s, Cnt ));
  90             s++;
  91             Cnt--;
  92         }
  93     }
  94     else
  95     {
  96         while(( Cnt > 0 ) && ( *s == c ))
  97         {
  98 DBUGX(("ffSkip: %c=0x%x, %d\n", *s, Cnt ));
  99         s++;
 100         Cnt--;
 101         }
 102     }
 103     *AddrOut = s;
 104     return Cnt;
 105 }
 106
 107 /* ( addr cnt char -- addr' cnt' , scan for char ) */
 108 cell_t ffScan( char *AddrIn, cell_t Cnt, char c, char **AddrOut )
 109 {
 110     char *s;
 111
 112     s = AddrIn;
 113
 114     if( c == BLANK )
 115     {
 116         while(( Cnt > 0 ) &&
 117             ( *s != BLANK) &&
 118             ( *s != '\r') &&
 119             ( *s != '\n') &&
 120             ( *s != '\t'))
 121         {
 122 DBUGX(("ffScan BLANK: %c, %d\n", *s, Cnt ));
 123             s++;
 124             Cnt--;
 125         }
 126     }
 127     else
 128     {
 129         while(( Cnt > 0 ) && ( *s != c ))
 130         {
 131 DBUGX(("ffScan: %c, %d\n", *s, Cnt ));
 132             s++;
 133             Cnt--;
 134         }
 135     }
 136     *AddrOut = s;
 137     return Cnt;
 138 }
 139
 140 /***************************************************************
 141 ** Forth equivalent 'C' functions.
 142 ***************************************************************/
 143
 144 /* Convert a single digit to the corresponding hex number. */
 145 static cell_t HexDigitToNumber( char c )
 146 {
 147     if( (c >= '0') && (c <= '9') )
 148     {
 149         return( c - '0' );
 150     }
 151     else if ( (c >= 'A') && (c <= 'F') )
 152     {
 153         return( c - 'A' + 0x0A );
 154     }
 155     else
 156     {
 157         return -1;
 158     }
 159 }
 160
 161 /* Convert a string to the corresponding number using BASE. */
 162 cell_t ffNumberQ( const char *FWord, cell_t *Num )
 163 {
 164     cell_t Len, i, Accum=0, n, Sign=1, Base=gVarBase;
 165     const char *s;
 166
 167 /* get count */
 168     Len = *FWord++;
 169     s = FWord;
 170
 171     switch (*s) {
 172     case '#': Base = 10; s++; Len--; break;
 173     case '$': Base = 16; s++; Len--; break;
 174     case '%': Base =  2; s++; Len--; break;
 175     case '\'':
 176         if( Len == 3 && s[2] == '\'' )
 177         {
 178             *Num = s[1];
 179             return NUM_TYPE_SINGLE;
 180         }
 181     }
 182
 183 /* process initial minus sign */
 184     if( *s == '-' )
 185     {
 186         Sign = -1;
 187         s++;
 188         Len--;
 189     }
 190
 191     for( i=0; i<Len; i++)
 192     {
 193         n = HexDigitToNumber( *s++ );
 194         if( (n < 0) || (n >= Base) )
 195         {
 196             return NUM_TYPE_BAD;
 197         }
 198
 199         Accum = (Accum * Base) + n;
 200     }
 201     *Num = Accum * Sign;
 202     return NUM_TYPE_SINGLE;
 203 }
 204
 205 /***************************************************************
 206 ** Compiler Support
 207 ***************************************************************/
 208
 209 /* Skip whitespace, then parse input delimited by C. If UPCASE is true
 210  * convert the word to upper case.  The result is stored in
 211  * gScratch.
 212  */
 213 static char * Word ( char c, int Upcase )
 214 {
 215     char *s1,*s2,*s3;
 216     cell_t n1, n2, n3;
 217     cell_t i, nc;
 218
 219     s1 = gCurrentTask->td_SourcePtr + gCurrentTask->td_IN;
 220     n1 = gCurrentTask->td_SourceNum - gCurrentTask->td_IN;
 221     n2 = ffSkip( s1, n1, c, &s2 );
 222 DBUGX(("Word: s2=%c, %d\n", *s2, n2 ));
 223     n3 = ffScan( s2, n2, c, &s3 );
 224 DBUGX(("Word: s3=%c, %d\n", *s3, n3 ));
 225     nc = n2-n3;
 226     if (nc > 0)
 227     {
 228         gScratch[0] = (char) nc;
 229         for( i=0; i<nc; i++ )
 230         {
 231             gScratch[i+1] = Upcase ? pfCharToUpper( s2[i] ) : s2[i] ;
 232         }
 233     }
 234     else
 235     {
 236
 237         gScratch[0] = 0;
 238     }
 239     gCurrentTask->td_IN += (n1-n3) + 1;
 240     return &gScratch[0];
 241 }
 242
 243 /* ( char -- c-addr , parse word ) */
 244 char * ffWord( char c )
 245 {
 246   return Word( c, TRUE );
 247 }
 248
 249 /* ( char -- c-addr , parse word, preserving case ) */
 250 char * ffLWord( char c )
 251 {
 252   return Word( c, FALSE );
 253 }