-/* @(#) pf_words.c 96/12/18 1.10 */\r
-/***************************************************************\r
-** Forth words for PForth based on 'C'\r
-**\r
-** Author: Phil Burk\r
-** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom\r
-**\r
-** The pForth software code is dedicated to the public domain,\r
-** and any third party may reproduce, distribute and modify\r
-** the pForth software code or any derivative works thereof\r
-** without any compensation or license. The pForth software\r
-** code is provided on an "as is" basis without any warranty\r
-** of any kind, including, without limitation, the implied\r
-** warranties of merchantability and fitness for a particular\r
-** purpose and their equivalents under the laws of any jurisdiction.\r
-**\r
-**\r
-** 941031 rdg fix ffScan() to look for CRs and LFs\r
-**\r
-***************************************************************/\r
-\r
-#include "pf_all.h"\r
-\r
-\r
-/***************************************************************\r
-** Print number in current base to output stream.\r
-** This version does not handle double precision.\r
-*/\r
-void ffDot( cell_t n )\r
-{\r
- MSG( ConvertNumberToText( n, gVarBase, TRUE, 1 ) );\r
- EMIT(' ');\r
-}\r
-\r
-/***************************************************************\r
-** Print number in current base to output stream.\r
-** This version does not handle double precision.\r
-*/\r
-void ffDotHex( cell_t n )\r
-{\r
- MSG( ConvertNumberToText( n, 16, FALSE, 1 ) );\r
- EMIT(' ');\r
-}\r
-\r
-/* ( ... --- ... , print stack ) */\r
-void ffDotS( void )\r
-{\r
- cell_t *sp;\r
- cell_t i, Depth;\r
-\r
- MSG("Stack<");\r
- MSG( ConvertNumberToText( gVarBase, 10, TRUE, 1 ) ); /* Print base in decimal. */\r
- MSG("> ");\r
- \r
- Depth = gCurrentTask->td_StackBase - gCurrentTask->td_StackPtr;\r
- sp = gCurrentTask->td_StackBase;\r
- \r
- if( Depth < 0 )\r
- {\r
- MSG("UNDERFLOW!");\r
- }\r
- else\r
- {\r
- for( i=0; i<Depth; i++ )\r
- {\r
-/* Print as unsigned if not base 10. */\r
- MSG( ConvertNumberToText( *(--sp), gVarBase, (gVarBase == 10), 1 ) );\r
- EMIT(' ');\r
- }\r
- }\r
- MSG("\n");\r
-}\r
-\r
-/* ( addr cnt char -- addr' cnt' , skip leading characters ) */\r
-cell_t ffSkip( char *AddrIn, cell_t Cnt, char c, char **AddrOut )\r
-{\r
- char *s;\r
- \r
- s = AddrIn;\r
-\r
- if( c == BLANK )\r
- {\r
- while( ( Cnt > 0 ) &&\r
- (( *s == BLANK) || ( *s == '\t')) )\r
- {\r
-DBUGX(("ffSkip BLANK: %c, %d\n", *s, Cnt ));\r
- s++;\r
- Cnt--;\r
- }\r
- }\r
- else\r
- {\r
- while(( Cnt > 0 ) && ( *s == c ))\r
- {\r
-DBUGX(("ffSkip: %c=0x%x, %d\n", *s, Cnt ));\r
- s++;\r
- Cnt--;\r
- }\r
- }\r
- *AddrOut = s;\r
- return Cnt;\r
-}\r
-\r
-/* ( addr cnt char -- addr' cnt' , scan for char ) */\r
-cell_t ffScan( char *AddrIn, cell_t Cnt, char c, char **AddrOut )\r
-{\r
- char *s;\r
- \r
- s = AddrIn;\r
-\r
- if( c == BLANK )\r
- {\r
- while(( Cnt > 0 ) &&\r
- ( *s != BLANK) &&\r
- ( *s != '\r') &&\r
- ( *s != '\n') &&\r
- ( *s != '\t'))\r
- {\r
-DBUGX(("ffScan BLANK: %c, %d\n", *s, Cnt ));\r
- s++;\r
- Cnt--;\r
- }\r
- }\r
- else\r
- {\r
- while(( Cnt > 0 ) && ( *s != c ))\r
- {\r
-DBUGX(("ffScan: %c, %d\n", *s, Cnt ));\r
- s++;\r
- Cnt--;\r
- }\r
- }\r
- *AddrOut = s;\r
- return Cnt;\r
-}\r
-\r
-/***************************************************************\r
-** Forth equivalent 'C' functions.\r
-***************************************************************/\r
-\r
-/* Convert a single digit to the corresponding hex number. */\r
-static cell_t HexDigitToNumber( char c )\r
-{ \r
- if( (c >= '0') && (c <= '9') )\r
- {\r
- return( c - '0' );\r
- }\r
- else if ( (c >= 'A') && (c <= 'F') )\r
- {\r
- return( c - 'A' + 0x0A );\r
- }\r
- else\r
- {\r
- return -1;\r
- }\r
-}\r
-\r
-/* Convert a string to the corresponding number using BASE. */\r
-cell_t ffNumberQ( const char *FWord, cell_t *Num )\r
-{\r
- cell_t Len, i, Accum=0, n, Sign=1;\r
- const char *s;\r
- \r
-/* get count */\r
- Len = *FWord++;\r
- s = FWord;\r
-\r
-/* process initial minus sign */\r
- if( *s == '-' )\r
- {\r
- Sign = -1;\r
- s++;\r
- Len--;\r
- }\r
-\r
- for( i=0; i<Len; i++)\r
- {\r
- n = HexDigitToNumber( *s++ );\r
- if( (n < 0) || (n >= gVarBase) )\r
- {\r
- return NUM_TYPE_BAD;\r
- }\r
- \r
- Accum = (Accum * gVarBase) + n;\r
- }\r
- *Num = Accum * Sign;\r
- return NUM_TYPE_SINGLE;\r
-}\r
-\r
-/***************************************************************\r
-** Compiler Support\r
-***************************************************************/\r
-\r
-/* ( char -- c-addr , parse word ) */\r
-char * ffWord( char c )\r
-{\r
- char *s1,*s2,*s3;\r
- cell_t n1, n2, n3;\r
- cell_t i, nc;\r
-\r
- s1 = gCurrentTask->td_SourcePtr + gCurrentTask->td_IN;\r
- n1 = gCurrentTask->td_SourceNum - gCurrentTask->td_IN;\r
- n2 = ffSkip( s1, n1, c, &s2 );\r
-DBUGX(("ffWord: s2=%c, %d\n", *s2, n2 ));\r
- n3 = ffScan( s2, n2, c, &s3 );\r
-DBUGX(("ffWord: s3=%c, %d\n", *s3, n3 ));\r
- nc = n2-n3;\r
- if (nc > 0)\r
- {\r
- gScratch[0] = (char) nc;\r
- for( i=0; i<nc; i++ )\r
- {\r
- gScratch[i+1] = pfCharToUpper( s2[i] );\r
- }\r
- }\r
- else\r
- {\r
- \r
- gScratch[0] = 0;\r
- }\r
- gCurrentTask->td_IN += (n1-n3) + 1;\r
- return &gScratch[0];\r
-}\r
+/* @(#) pf_words.c 96/12/18 1.10 */
+/***************************************************************
+** Forth words for PForth based on 'C'
+**
+** Author: Phil Burk
+** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
+**
+** Permission to use, copy, modify, and/or distribute this
+** software for any purpose with or without fee is hereby granted.
+**
+** THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
+** WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
+** WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL
+** THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
+** CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING
+** FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF
+** CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+** OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+**
+**
+** 941031 rdg fix ffScan() to look for CRs and LFs
+**
+***************************************************************/
+
+#include "pf_all.h"
+
+
+/***************************************************************
+** Print number in current base to output stream.
+** This version does not handle double precision.
+*/
+void ffDot( cell_t n )
+{
+ MSG( ConvertNumberToText( n, gVarBase, TRUE, 1 ) );
+ EMIT(' ');
+}
+
+/***************************************************************
+** Print number in current base to output stream.
+** This version does not handle double precision.
+*/
+void ffDotHex( cell_t n )
+{
+ MSG( ConvertNumberToText( n, 16, FALSE, 1 ) );
+ EMIT(' ');
+}
+
+/* ( ... --- ... , print stack ) */
+void ffDotS( void )
+{
+ cell_t *sp;
+ cell_t i, Depth;
+
+ MSG("Stack<");
+ MSG( ConvertNumberToText( gVarBase, 10, TRUE, 1 ) ); /* Print base in decimal. */
+ MSG("> ");
+
+ Depth = gCurrentTask->td_StackBase - gCurrentTask->td_StackPtr;
+ sp = gCurrentTask->td_StackBase;
+
+ if( Depth < 0 )
+ {
+ MSG("UNDERFLOW!");
+ }
+ else
+ {
+ for( i=0; i<Depth; i++ )
+ {
+/* Print as unsigned if not base 10. */
+ MSG( ConvertNumberToText( *(--sp), gVarBase, (gVarBase == 10), 1 ) );
+ EMIT(' ');
+ }
+ }
+ MSG("\n");
+}
+
+/* ( addr cnt char -- addr' cnt' , skip leading characters ) */
+cell_t ffSkip( char *AddrIn, cell_t Cnt, char c, char **AddrOut )
+{
+ char *s;
+
+ s = AddrIn;
+
+ if( c == BLANK )
+ {
+ while( ( Cnt > 0 ) &&
+ (( *s == BLANK) || ( *s == '\t')) )
+ {
+DBUGX(("ffSkip BLANK: %c, %d\n", *s, Cnt ));
+ s++;
+ Cnt--;
+ }
+ }
+ else
+ {
+ while(( Cnt > 0 ) && ( *s == c ))
+ {
+DBUGX(("ffSkip: %c=0x%x, %d\n", *s, Cnt ));
+ s++;
+ Cnt--;
+ }
+ }
+ *AddrOut = s;
+ return Cnt;
+}
+
+/* ( addr cnt char -- addr' cnt' , scan for char ) */
+cell_t ffScan( char *AddrIn, cell_t Cnt, char c, char **AddrOut )
+{
+ char *s;
+
+ s = AddrIn;
+
+ if( c == BLANK )
+ {
+ while(( Cnt > 0 ) &&
+ ( *s != BLANK) &&
+ ( *s != '\r') &&
+ ( *s != '\n') &&
+ ( *s != '\t'))
+ {
+DBUGX(("ffScan BLANK: %c, %d\n", *s, Cnt ));
+ s++;
+ Cnt--;
+ }
+ }
+ else
+ {
+ while(( Cnt > 0 ) && ( *s != c ))
+ {
+DBUGX(("ffScan: %c, %d\n", *s, Cnt ));
+ s++;
+ Cnt--;
+ }
+ }
+ *AddrOut = s;
+ return Cnt;
+}
+
+/***************************************************************
+** Forth equivalent 'C' functions.
+***************************************************************/
+
+/* Convert a single digit to the corresponding hex number. */
+static cell_t HexDigitToNumber( char c )
+{
+ if( (c >= '0') && (c <= '9') )
+ {
+ return( c - '0' );
+ }
+ else if ( (c >= 'A') && (c <= 'F') )
+ {
+ return( c - 'A' + 0x0A );
+ }
+ else
+ {
+ return -1;
+ }
+}
+
+/* Convert a string to the corresponding number using BASE. */
+cell_t ffNumberQ( const char *FWord, cell_t *Num )
+{
+ cell_t Len, i, Accum=0, n, Sign=1, Base=gVarBase;
+ const char *s;
+
+/* get count */
+ Len = *FWord++;
+ s = FWord;
+
+ switch (*s) {
+ case '#': Base = 10; s++; Len--; break;
+ case '$': Base = 16; s++; Len--; break;
+ case '%': Base = 2; s++; Len--; break;
+ case '\'':
+ if( Len == 3 && s[2] == '\'' )
+ {
+ *Num = s[1];
+ return NUM_TYPE_SINGLE;
+ }
+ }
+
+/* process initial minus sign */
+ if( *s == '-' )
+ {
+ Sign = -1;
+ s++;
+ Len--;
+ }
+
+ for( i=0; i<Len; i++)
+ {
+ n = HexDigitToNumber( *s++ );
+ if( (n < 0) || (n >= Base) )
+ {
+ return NUM_TYPE_BAD;
+ }
+
+ Accum = (Accum * Base) + n;
+ }
+ *Num = Accum * Sign;
+ return NUM_TYPE_SINGLE;
+}
+
+/***************************************************************
+** Compiler Support
+***************************************************************/
+
+/* Skip whitespace, then parse input delimited by C. If UPCASE is true
+ * convert the word to upper case. The result is stored in
+ * gScratch.
+ */
+static char * Word ( char c, int Upcase )
+{
+ char *s1,*s2,*s3;
+ cell_t n1, n2, n3;
+ cell_t i, nc;
+
+ s1 = gCurrentTask->td_SourcePtr + gCurrentTask->td_IN;
+ n1 = gCurrentTask->td_SourceNum - gCurrentTask->td_IN;
+ n2 = ffSkip( s1, n1, c, &s2 );
+DBUGX(("Word: s2=%c, %d\n", *s2, n2 ));
+ n3 = ffScan( s2, n2, c, &s3 );
+DBUGX(("Word: s3=%c, %d\n", *s3, n3 ));
+ nc = n2-n3;
+ if (nc > 0)
+ {
+ gScratch[0] = (char) nc;
+ for( i=0; i<nc; i++ )
+ {
+ gScratch[i+1] = Upcase ? pfCharToUpper( s2[i] ) : s2[i] ;
+ }
+ }
+ else
+ {
+
+ gScratch[0] = 0;
+ }
+ gCurrentTask->td_IN += (n1-n3) + 1;
+ return &gScratch[0];
+}
+
+/* ( char -- c-addr , parse word ) */
+char * ffWord( char c )
+{
+ return Word( c, TRUE );
+}
+
+/* ( char -- c-addr , parse word, preserving case ) */
+char * ffLWord( char c )
+{
+ return Word( c, FALSE );
+}
projects / pforth / blobdiff