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, Devid 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( int32 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( int32 n )
  40 {
  41         MSG( ConvertNumberToText( n, 16, FALSE, 1 ) );
  42         EMIT(' ');
  43 }
  44
  45 /* ( ... --- ... , print stack ) */
  46 void ffDotS( void )
  47 {
  48         cell *sp;
  49         int32 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 ffSkip( char *AddrIn, cell 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 ffScan( char *AddrIn, cell 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 ***************************************************************/\r
 140 \r
 141 /* Convert a single digit to the corresponding hex number. */\r
 142 static cell HexDigitToNumber( char c )\r
 143 {       \r
 144         if( (c >= '0') && (c <= '9') )\r
 145         {\r
 146                 return( c - '0' );\r
 147         }\r
 148         else if ( (c >= 'A') && (c <= 'F') )\r
 149         {\r
 150                 return( c - 'A' + 0x0A );\r
 151         }\r
 152         else\r
 153         {\r
 154                 return -1;\r
 155         }\r
 156 }\r
 157
 158 /* Convert a string to the corresponding number using BASE. */
 159 cell ffNumberQ( const char *FWord, cell *Num )
 160 {
 161         int32 Len, i, Accum=0, n, Sign=1;
 162         const char *s;
 163
 164 /* get count */
 165         Len = *FWord++;
 166         s = FWord;
 167
 168 /* process initial minus sign */
 169         if( *s == '-' )
 170         {
 171                 Sign = -1;
 172                 s++;
 173                 Len--;
 174         }
 175
 176         for( i=0; i<Len; i++)
 177         {
 178                 n = HexDigitToNumber( *s++ );
 179                 if( (n < 0) || (n >= gVarBase) )
 180                 {
 181                         return NUM_TYPE_BAD;
 182                 }
 183
 184                 Accum = (Accum * gVarBase) + n;
 185         }
 186         *Num = Accum * Sign;
 187         return NUM_TYPE_SINGLE;
 188 }
 189
 190 /***************************************************************
 191 ** Compiler Support
 192 ***************************************************************/
 193
 194 /* ( char -- c-addr , parse word ) */
 195 char * ffWord( char c )
 196 {
 197         char *s1,*s2,*s3;
 198         int32 n1, n2, n3;
 199         int32 i, nc;
 200
 201         s1 = gCurrentTask->td_SourcePtr + gCurrentTask->td_IN;
 202         n1 = gCurrentTask->td_SourceNum - gCurrentTask->td_IN;
 203         n2 = ffSkip( s1, n1, c, &s2 );
 204 DBUGX(("ffWord: s2=%c, %d\n", *s2, n2 ));
 205         n3 = ffScan( s2, n2, c, &s3 );
 206 DBUGX(("ffWord: s3=%c, %d\n", *s3, n3 ));
 207         nc = n2-n3;
 208         if (nc > 0)
 209         {
 210                 gScratch[0] = (char) nc;
 211                 for( i=0; i<nc; i++ )
 212                 {
 213                         gScratch[i+1] = pfCharToUpper( s2[i] );
 214                 }
 215         }
 216         else
 217         {
 218
 219                 gScratch[0] = 0;
 220         }
 221         gCurrentTask->td_IN += (n1-n3) + 1;
 222         return &gScratch[0];
 223 }