Adding Recognizers, and more.

Adding the proposed recognizers vocabulary, including a limited test.
Fixing windows build to better handle different VS versions.
Fixing various hidden word bugs.
Adding 3DUP opcode.
Bumping version number.

common/all_tests.fs

@@ -23,6 +23,7 @@ needs case_tests.fs
 needs doloop_tests.fs
 needs conditionals_tests.fs
 needs float_tests.fs
+needs recognizer_tests.fs
 needs forth_namespace_tests.fs
 needs structures_tests.fs
 needs fault_tests.fs

common/base_tests.fs

@@ -226,3 +226,12 @@ e: test-u<
   0 0 u< 0= assert
   -1 -1 u< 0= assert
 ;e
+
+e: test-postpone
+  : test postpone if postpone + postpone then ; immediate
+  : test2 test ;
+  3 4 1 test2 . cr
+  3 4 0 test2 . . cr
+  out: 7 
+  out: 4 3 
+;e

common/boot.fs

@@ -44,9 +44,9 @@ create AFT ' branch @ ' aft !         : aft   drop ['] aft , here 0 , here swap
 ( Recursion )
 : recurse   current @ @ aliteral ['] execute , ; immediate
 
-( Postpone - done here so we have ['] and IF )
+( Tools to build postpone later out of recognizers )
 : immediate? ( xt -- f ) >flags 1 and 0= 0= ;
-: postpone ' dup immediate? if , else aliteral ['] , , then ; immediate
+: postpone, ( xt -- ) aliteral ['] , , ;
 
 ( Rstack nest depth )
 variable nest-depth
@@ -55,6 +55,59 @@ variable nest-depth
 create FOR ' >r @ ' for !         : for   1 nest-depth +! ['] for , here ; immediate
 create NEXT ' donext @ ' next !   : next   -1 nest-depth +! ['] next , , ; immediate
 
+( Define a data type for Recognizers. )
+: RECTYPE: ( xt1 xt2 xt3 "name" -- ) CREATE , , , ;
+: do-notfound ( a n -- ) -1 'notfound @ execute ;
+' do-notfound ' do-notfound ' do-notfound  RECTYPE: RECTYPE-NONE
+' execute     ' ,           ' postpone,    RECTYPE: RECTYPE-WORD
+' execute     ' execute     ' ,            RECTYPE: RECTYPE-IMM
+' drop        ' execute     ' execute      RECTYPE: RECTYPE-NUM
+
+: RECOGNIZE ( c-addr len addr1 -- i*x addr2 )
+  dup @ for aft
+    cell+ 3dup >r >r >r @ execute
+    dup RECTYPE-NONE <> if rdrop rdrop rdrop rdrop exit then
+    drop r> r> r>
+  then next
+  drop 2drop RECTYPE-NONE
+;
+
+( Define a recognizer stack. )
+create RECSTACK 0 , 10 cells allot
+: +RECOGNIZER ( xt -- ) 1 RECSTACK +! RECSTACK dup @ cells + ! ;
+: -RECOGNIZER ( -- ) -1 RECSTACK +! ;
+: GET-RECOGNIZERS ( -- xtn..xt1 n )
+   RECSTACK @ for RECSTACK r@ cells + @ next ;
+: SET-RECOGNIZERS ( xtn..xt1 n -- )
+   0 RECSTACK ! for aft +RECOGNIZER then next ;
+
+( Create recognizer based words. )
+: postpone ( "name" -- ) bl parse RECSTACK RECOGNIZE @ execute ; immediate
+: +evaluate1
+  bl parse dup 0= if 2drop exit then
+  RECSTACK RECOGNIZE state @ 2 + cells + @ execute
+;
+
+( Setup recognizing words. )
+: REC-FIND ( c-addr len -- xt addr1 | addr2 )
+  find dup if
+    dup immediate? if RECTYPE-IMM else RECTYPE-WORD then
+  else
+    drop RECTYPE-NONE
+  then
+;
+' REC-FIND +RECOGNIZER
+
+( Setup recognizing integers. )
+: REC-NUM ( c-addr len -- n addr1 | addr2 )
+  s>number? if
+    ['] aliteral RECTYPE-NUM
+  else
+    RECTYPE-NONE
+  then
+;
+' REC-NUM +RECOGNIZER
+
 ( DO..LOOP )
 variable leaving
 : leaving,   here leaving @ , leaving ! ;

common/floats.fs

@@ -23,6 +23,18 @@
 6 value precision
 : set-precision ( n -- ) to precision ;
 
+( Add recognizer for floats. )
+also recognizers definitions
+: REC-FNUM ( c-addr len -- f addr1 | addr2 )
+  s>float? if
+    ['] afliteral RECTYPE-NUM
+  else
+    RECTYPE-NONE
+  then
+;
+' REC-FNUM +RECOGNIZER
+previous definitions
+
 internals definitions
 : #f+s ( r -- ) fdup precision for aft 10e f* then next
                 precision for aft fdup f>s 10 mod [char] 0 + hold 0.1e f* then next

common/floats.h

@@ -42,7 +42,8 @@
   X("1/F", FINVERSE, *fp = 1.0f / *fp) \
   X("S>F", STOF, *++fp = (float) tos; DROP) \
   X("F>S", FTOS, DUP; tos = (cell_t) *fp--) \
-  XV(internals, "S>FLOAT?", FCONVERT, tos = fconvert((const char *) *sp, tos, fp)|0; --sp) \
+  XV(internals, "S>FLOAT?", FCONVERT, \
+      ++fp; tos = fconvert((const char *) *sp, tos, fp)|0; if (!tos) --fp; --sp) \
   Y(SFLOAT, DUP; tos = sizeof(float)) \
   Y(SFLOATS, tos *= sizeof(float)) \
   X("SFLOAT+", SFLOATPLUS, tos += sizeof(float)) \

common/forth_namespace_tests.fs

@@ -106,7 +106,6 @@ e: check-boot
   out: value 
   out: throw 
   out: catch 
-  out: handler 
   out: K 
   out: J 
   out: I 
@@ -116,10 +115,10 @@ e: check-boot
   out: UNLOOP 
   out: ?do 
   out: do 
+  out: postpone 
   out: next 
   out: for 
-  out: nest-depth 
-  out: postpone 
+  out: postpone, 
   out: recurse 
   out: aft 
   out: repeat 
@@ -194,6 +193,7 @@ e: check-tier1-opcodes
   out: cell/ 
   out: 2drop 
   out: 2dup 
+  out: 3dup 
   out: 2@ 
   out: 2! 
 
@@ -390,6 +390,7 @@ e: check-blocks
 ;e
 
 e: check-vocabulary
+  out: recognizers 
   out: internals 
   out: sealed 
   out: previous 
@@ -537,6 +538,7 @@ e: test-windows-forth-voclist
   out: tasks 
   out: windows 
   out: structures 
+  out: recognizers 
   out: internalized 
   out: internals 
   out: FORTH 
@@ -576,6 +578,7 @@ e: test-posix-forth-voclist
   out: tasks 
   out: posix 
   out: structures 
+  out: recognizers 
   out: internalized 
   out: internals 
   out: FORTH 
@@ -635,6 +638,7 @@ e: test-esp32-forth-voclist
   out: Wire 
   out: ESP 
   out: structures 
+  out: recognizers 
   out: internalized 
   out: internals 
   out: FORTH 

common/io.fs

@@ -105,7 +105,7 @@ sp0 'stack-cells @ 2 3 */ cells + constant sp-limit
 
 ( REPL )
 : prompt   ."  ok" cr ;
-: evaluate-buffer   begin >in @ #tib @ < while evaluate1 ?stack repeat ;
+: evaluate-buffer   begin >in @ #tib @ < while ?stack +evaluate1 repeat ?stack ;
 : evaluate ( a n -- ) 'tib @ >r #tib @ >r >in @ >r
                       #tib ! 'tib ! 0 >in ! evaluate-buffer
                       r> >in ! r> #tib ! r> 'tib ! ;

common/recognizer_tests.fs

@@ -0,0 +1,32 @@
+\ Copyright 2024 Bradley D. Nelson
+\
+\ Licensed under the Apache License, Version 2.0 (the "License");
+\ you may not use this file except in compliance with the License.
+\ You may obtain a copy of the License at
+\
+\     http://www.apache.org/licenses/LICENSE-2.0
+\
+\ Unless required by applicable law or agreed to in writing, software
+\ distributed under the License is distributed on an "AS IS" BASIS,
+\ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+\ See the License for the specific language governing permissions and
+\ limitations under the License.
+
+e: test-recognizers
+  also recognizers
+  also internals
+  : rec-blah ( a n -- rec )
+    s" blah" str= if
+      123 ['] aliteral rectype-num
+    else
+      rectype-none
+    then
+  ;
+  ' rec-blah +recognizer
+  : test blah . cr ;
+  -recognizer
+  previous
+  previous
+  test
+  out: 123 
+;e

common/tier1_opcodes.h

@@ -47,6 +47,7 @@
   X("cell/", CELLSLASH, CELLSLASH_FUNC) \
   X("2drop", TWODROP, NIP; DROP) \
   X("2dup", TWODUP, DUP; tos = sp[-1]; DUP; tos = sp[-1]) \
+  X("3dup", THREEDUP, sp += 3; sp[-2] = tos; sp[-1] = sp[-4]; *sp = sp[-3]) \
   X("2@", TWOAT, DUP; *sp = *(cell_t *) tos; tos = ((cell_t *) tos)[1]) \
   X("2!", TWOSTORE, *(cell_t *) tos = sp[-1]; \
       ((cell_t *) tos)[1] = *sp; sp -= 2; DROP) \

common/vocabulary.fs

@@ -61,9 +61,10 @@ transfer{
   tib-setup input-limit sp-limit ?stack
   [SKIP] [SKIP]' raw-ok boot-prompt free.
   $place zplace BUILTIN_MARK
+  nest-depth handler +evaluate1 do-notfound
 }transfer
 
-( Move branching opcodes to separate vocabulary )
+( Move branching opcodes to separate vocabulary. )
 vocabulary internalized  internalized definitions
 : cleave   ' >link xt-transfer ;
 cleave begin   cleave again   cleave until
@@ -72,7 +73,17 @@ cleave else    cleave while   cleave repeat
 cleave aft     cleave for     cleave next
 cleave do      cleave ?do     cleave +loop
 cleave loop    cleave leave
+forth definitions
 
+( Move recognizers to separate vocabulary )
+vocabulary recognizers  recognizers definitions
+transfer{
+  REC-FIND REC-NUM
+  RECTYPE: RECTYPE-NONE RECTYPE-WORD RECTYPE-IMM RECTYPE-NUM
+  SET-RECOGNIZERS GET-RECOGNIZERS
+  -RECOGNIZER +RECOGNIZER RECSTACK
+  RECOGNIZE
+}transfer
 forth definitions
 
 ( Make DOES> switch to compile mode when interpreted )