From: Phil Burk Date: Fri, 23 Dec 2016 19:26:36 +0000 (-0800) Subject: Merge pull request #23 from ellerh/forth2012-number-syntax X-Git-Url: http://git.subgeniuskitty.com/pforth/.git/commitdiff_plain/a8013caa3cff6927fb5612fd465d535b7aa32e2c?hp=1f02140179ae9dd0b5d7f477b514c5af8210bf80 Merge pull request #23 from ellerh/forth2012-number-syntax Recognize Forth 2012 number syntax --- diff --git a/csrc/pf_words.c b/csrc/pf_words.c index 7a753ec..8fe2fd3 100644 --- a/csrc/pf_words.c +++ b/csrc/pf_words.c @@ -158,13 +158,25 @@ static cell_t HexDigitToNumber( char c ) /* 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; + 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 == '-' ) { @@ -176,12 +188,12 @@ cell_t ffNumberQ( const char *FWord, cell_t *Num ) for( i=0; i= gVarBase) ) + if( (n < 0) || (n >= Base) ) { return NUM_TYPE_BAD; } - Accum = (Accum * gVarBase) + n; + Accum = (Accum * Base) + n; } *Num = Accum * Sign; return NUM_TYPE_SINGLE; @@ -191,8 +203,11 @@ cell_t ffNumberQ( const char *FWord, cell_t *Num ) ** Compiler Support ***************************************************************/ -/* ( char -- c-addr , parse word ) */ -char * ffWord( char c ) +/* 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; @@ -201,16 +216,16 @@ char * ffWord( char c ) s1 = gCurrentTask->td_SourcePtr + gCurrentTask->td_IN; n1 = gCurrentTask->td_SourceNum - gCurrentTask->td_IN; n2 = ffSkip( s1, n1, c, &s2 ); -DBUGX(("ffWord: s2=%c, %d\n", *s2, n2 )); +DBUGX(("Word: s2=%c, %d\n", *s2, n2 )); n3 = ffScan( s2, n2, c, &s3 ); -DBUGX(("ffWord: s3=%c, %d\n", *s3, n3 )); +DBUGX(("Word: s3=%c, %d\n", *s3, n3 )); nc = n2-n3; if (nc > 0) { gScratch[0] = (char) nc; for( i=0; itd_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 ); +} diff --git a/csrc/pfcompil.c b/csrc/pfcompil.c index 04bc000..2f0c04e 100644 --- a/csrc/pfcompil.c +++ b/csrc/pfcompil.c @@ -831,7 +831,7 @@ ThrowCode ffInterpret( void ) { pfDebugMessage("ffInterpret: calling ffWord(()\n"); - theWord = ffWord( BLANK ); + theWord = ffLWord( BLANK ); DBUG(("ffInterpret: theWord = 0x%x, Len = %d\n", theWord, *theWord )); if( *theWord > 0 ) diff --git a/csrc/pfcompil.h b/csrc/pfcompil.h index 3ff831c..1323fa5 100644 --- a/csrc/pfcompil.h +++ b/csrc/pfcompil.h @@ -38,6 +38,7 @@ cell_t ffTokenToName( ExecToken XT, const ForthString **NFAPtr ); cell_t *NameToCode( ForthString *NFA ); PForthDictionary pfBuildDictionary( cell_t HeaderSize, cell_t CodeSize ); char *ffWord( char c ); +char *ffLWord( char c ); const ForthString *NameToPrevious( const ForthString *NFA ); cell_t FindSpecialCFAs( void ); cell_t FindSpecialXTs( void ); diff --git a/fth/numberio.fth b/fth/numberio.fth index 833ca69..e79c5b8 100644 --- a/fth/numberio.fth +++ b/fth/numberio.fth @@ -84,21 +84,43 @@ decimal 1 constant NUM_TYPE_SINGLE 2 constant NUM_TYPE_DOUBLE +\ Like >number, but temporarily switch BASE. +: (>number-with-base) ( ud c-addr u base -- ud' c-addr' u' ) + base @ >r base ! >number r> base ! +; + \ This is similar to the F83 NUMBER? except that it returns a number type \ and then either a single or double precision number. : ((NUMBER?)) ( c-addr u -- 0 | n 1 | d 2 , convert string to number ) dup 0= IF 2drop NUM_TYPE_BAD exit THEN \ any chars? -\ prepare for >number - 0 0 2swap ( 0 0 c-addr cnt ) + base @ -rot ( base c-addr u ) + + \ Recognize prefixes and change base if needed + over c@ >r ( base c-addr u ) ( r: char ) + r@ [char] # = if rot drop 10 -rot 1 /string then + r@ [char] $ = if rot drop 16 -rot 1 /string then + r@ [char] % = if rot drop 2 -rot 1 /string then + r@ [char] ' = if + \ Recognize '' + dup 3 = if + over 2 chars + c@ [char] ' = if + drop nip rdrop + char+ c@ NUM_TYPE_SINGLE exit + then + then + then + r> drop \ check for '-' at beginning, skip if present over c@ ascii - = \ is it a '-' dup >r \ save flag - IF 1- >r 1+ r> ( -- 0 0 c-addr+1 cnt-1 , skip past minus sign ) + IF 1 /string ( -- base c-addr+1 cnt-1 , skip past minus sign ) THEN -\ - >number dup 0= \ convert as much as we can + + ( base c-addr cnt ) ( r: minus-flag ) + rot >r 0 0 2swap r> + (>number-with-base) dup 0= \ convert as much as we can IF 2drop \ drop addr cnt drop \ drop hi part of num diff --git a/fth/t_corex.fth b/fth/t_corex.fth index 3b07d89..405b5c1 100644 --- a/fth/t_corex.fth +++ b/fth/t_corex.fth @@ -281,6 +281,39 @@ T{ 0 MIN-INT 1+ -1 MIN-INT GD8 }T{ 1 }T T{ 0 MIN-INT 1+ 1 MIN-INT GD8 }T{ 2 }T T{ 0 MIN-INT 1+ DUP MIN-INT GD8 }T{ 1 }T +\ ---------------------------------------------------------------------------- +\ .( TESTING number prefixes # $ % and 'c' character input ) +\ Adapted from the Forth 200X Draft 14.5 document + +VARIABLE OLD-BASE +DECIMAL BASE @ OLD-BASE ! +T{ #1289 }T{ 1289 }T +T{ #-1289 }T{ -1289 }T +T{ $12eF }T{ 4847 }T +T{ $-12eF }T{ -4847 }T +T{ %10010110 }T{ 150 }T +T{ %-10010110 }T{ -150 }T +T{ 'z' }T{ 122 }T +T{ 'Z' }T{ 90 }T +\ Check BASE is unchanged +T{ BASE @ OLD-BASE @ = }T{ TRUE }T + +\ Repeat in Hex mode +16 OLD-BASE ! 16 BASE ! +T{ #1289 }T{ 509 }T +T{ #-1289 }T{ -509 }T +T{ $12eF }T{ 12EF }T +T{ $-12eF }T{ -12EF }T +T{ %10010110 }T{ 96 }T +T{ %-10010110 }T{ -96 }T +T{ 'z' }T{ 7a }T +T{ 'Z' }T{ 5a }T +\ Check BASE is unchanged +T{ BASE @ OLD-BASE @ = }T{ TRUE }T \ 2 + +DECIMAL +\ Check number prefixes in compile mode +T{ : nmp #8327 $-2cbe %011010111 ''' ; nmp }T{ 8327 -11454 215 39 }T }TEST