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

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