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.
2024-04-20 02:10:42 -07:00
parent 5619997682
commit 74d744dd00
14 changed files with 168 additions and 35 deletions
--- a/2
+++ b/2
@ -13,7 +13,7 @@
 # limitations under the License.

 SetVersions(
-    version='7.0.7.18',
+    version='7.0.7.19',
    stable='7.0.6.19',
    old_stable='7.0.5.4')

--- a/common/all_tests.fs
+++ b/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
--- a/common/base_tests.fs
+++ b/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
--- a/common/boot.fs
+++ b/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 ! ;
--- a/common/floats.fs
+++ b/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
--- a/common/floats.h
+++ b/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)) \
--- a/common/forth_namespace_tests.fs
+++ b/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 
--- a/common/io.fs
+++ b/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 ! ;
--- a/common/recognizer_tests.fs
+++ b/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
--- a/common/tier1_opcodes.h
+++ b/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) \
--- a/common/vocabulary.fs
+++ b/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 )
--- a/configure.py
+++ b/configure.py
@ -89,27 +89,10 @@ elif sys.platform == 'linux':

 LIBS = ['-ldl']

-WIN_CFLAGS = CFLAGS_COMMON + [
-  '-I', '"c:/Program Files (x86)/Microsoft SDKs/Windows/v7.1A/Include"',
-  '-I', '"c:/Program Files (x86)/Microsoft Visual Studio/2019/Community/VC/Tools/MSVC/14.28.29333/include"',
-  '-I', '"c:/Program Files (x86)/Windows Kits/10/Include/10.0.19041.0/ucrt"',
-]
-
-WIN_LIBS = [
-  'user32.lib',
-]
-
-WIN_LFLAGS32 = [
-  '/LIBPATH:"c:/Program Files (x86)/Microsoft SDKs/Windows/v7.1A/Lib"',
-  '/LIBPATH:"c:/Program Files (x86)/Microsoft Visual Studio/2019/Community/VC/Tools/MSVC/14.28.29333/lib/x86"',
-  '/LIBPATH:"c:/Program Files (x86)/Windows Kits/10/Lib/10.0.19041.0/ucrt/x86"',
-] + WIN_LIBS
-
-WIN_LFLAGS64 = [
-  '/LIBPATH:"c:/Program Files (x86)/Microsoft SDKs/Windows/v7.1A/Lib/x64"',
-  '/LIBPATH:"c:/Program Files (x86)/Microsoft Visual Studio/2019/Community/VC/Tools/MSVC/14.28.29333/lib/x64"',
-  '/LIBPATH:"c:/Program Files (x86)/Windows Kits/10/Lib/10.0.19041.0/ucrt/x64"',
-] + WIN_LIBS
+WIN_CFLAGS = CFLAGS_COMMON
+WIN_LIBS = ['user32.lib']
+WIN_LFLAGS32 = []
+WIN_LFLAGS64 = []

 WEB_ENABLED = False
 PICO_ICE_ENABLED = False
@ -156,9 +139,10 @@ def DetectWindowsTools(args):
  ARDUINO_CLI = LOCALAPPDATA + '/Programs/arduino-ide/resources/app/lib/backend/resources/arduino-cli.exe'
  WINTMP = LOCALAPPDATA + '/Temp'
  WINTMPR = LOCALAPPDATAR + '/Temp'
-  PROGFILES = '/mnt/c/Program Files (x86)'
+  PROGFILES = '/mnt/c/Program Files'
+  PROGFILES_X86 = '/mnt/c/Program Files (x86)'
  MSVS = PROGFILES + '/Microsoft Visual Studio'
-  MSKITS = PROGFILES + '/Windows Kits'
+  MSKITS = PROGFILES_X86 + '/Windows Kits'
  try:
    WIN_CL32 = LSQ(MSVS + '/*/*/VC/Tools/MSVC/*/bin/Hostx86/x86/cl.exe')
    WIN_CL64 = LSQ(MSVS + '/*/*/VC/Tools/MSVC/*/bin/Hostx86/x64/cl.exe')
@ -166,6 +150,26 @@ def DetectWindowsTools(args):
    WIN_LINK64 = LSQ(MSVS + '/*/*/VC/Tools/MSVC/*/bin/Hostx86/x64/link.exe')
    WIN_RC32 = LSQ(MSKITS + '/*/bin/*/x86/rc.exe')
    WIN_RC64 = LSQ(MSKITS + '/*/bin/*/x64/rc.exe')
+    WIN_TOOL_ROOT = WIN_CL32.replace('/mnt/c/', 'c:/').replace('/bin/Hostx86/x86/cl.exe', '').replace('"', '')
+    WINDOWS_H = LSQ(MSKITS + '/*/Include/*/um/windows.h')
+    WINKIT_HEADERS = WINDOWS_H.replace('/mnt/c/', 'c:/').replace('/um/windows.h', '').replace('"', '')
+    WINKIT_LIBS = WINKIT_HEADERS.replace('/Include/', '/Lib/')
+    WIN_CFLAGS.extend([
+      '-I', '"%s/include"' % WIN_TOOL_ROOT,
+      '-I', '"%s/um"' % WINKIT_HEADERS,
+      '-I', '"%s/ucrt"' % WINKIT_HEADERS,
+      '-I', '"%s/shared"' % WINKIT_HEADERS,
+    ])
+    WIN_LFLAGS32.extend([
+      '/LIBPATH:"%s/lib/x86"' % WIN_TOOL_ROOT,
+      '/LIBPATH:"%s/ucrt/x86"' % WINKIT_LIBS,
+      '/LIBPATH:"%s/um/x86"' % WINKIT_LIBS,
+    ])
+    WIN_LFLAGS64.extend([
+      '/LIBPATH:"%s/lib/x64"' % WIN_TOOL_ROOT,
+      '/LIBPATH:"%s/ucrt/x64"' % WINKIT_LIBS,
+      '/LIBPATH:"%s/um/x64"' % WINKIT_LIBS,
+    ])
  except:
    if not args.quiet:
      sys.stderr.write('Windows tools not available, Windows support disabled.\n')
@ -250,6 +254,7 @@ D8 = {D8}
 WIN_CFLAGS = {' '.join(WIN_CFLAGS)}
 WIN_LFLAGS32 = {' '.join(WIN_LFLAGS32)}
 WIN_LFLAGS64 = {' '.join(WIN_LFLAGS64)}
+WIN_LIBS = {' '.join(WIN_LIBS)}

 rule config
  description = CONFIG
@ -297,11 +302,11 @@ rule compile_win64

 rule link_win32
  description = WIN_LINK32 $in
-  command = $WIN_LINK32 /nologo /OUT:$out $WIN_LFLAGS32 $in && touch $out && chmod a+x $out
+  command = $WIN_LINK32 /nologo /OUT:$out $WIN_LFLAGS32 $WIN_LIBS $in && touch $out && chmod a+x $out

 rule link_win64
  description = WIN_LINK64 $in
-  command = $WIN_LINK64 /nologo /OUT:$out $WIN_LFLAGS64 $in && touch $out && chmod a+x $out
+  command = $WIN_LINK64 /nologo /OUT:$out $WIN_LFLAGS64 $WIN_LIBS $in && touch $out && chmod a+x $out

 rule rc_win32
  description = WIN_RC32 $in
--- a/tools/check_web_sanity.py
+++ b/tools/check_web_sanity.py
@ -23,7 +23,7 @@ if 'Invalid' in source:
  print(source)
  sys.exit(1)

-if not source.strip().endswith('--> 123'):
+if not source.strip().endswith('\n--> 123'):
  print('MISSING EXPECTED OUTPUT')
  print(source)
  sys.exit(1)
--- a/web/fuse_web.js
+++ b/web/fuse_web.js
@ -86,12 +86,16 @@ cases = ReplaceAll(cases, 'fp[-2]', 'fround(f32[(fp - 8)>>2])');

 cases = ReplaceAll(cases, /[*](.)p = /, 'i32[$1p>>2] = ');
 cases = ReplaceAll(cases, 'sp[-1] = ', 'i32[(sp - 4)>>2] = ');
+cases = ReplaceAll(cases, 'sp[-2] = ', 'i32[(sp - 8)>>2] = ');
 cases = ReplaceAll(cases, /[*](.)p/, '(i32[$1p>>2]|0)');
 cases = ReplaceAll(cases, 'sp[-1]', '(i32[(sp - 4)>>2]|0)');
+cases = ReplaceAll(cases, 'sp[-3]', '(i32[(sp - 12)>>2]|0)');
+cases = ReplaceAll(cases, 'sp[-4]', '(i32[(sp - 16)>>2]|0)');

 cases = ReplaceAll(cases, /([+-]).(.)p/, '$2p = ($2p $1 4) | 0');
 cases = ReplaceAll(cases, 'sp -= (2-1)', 'sp = (sp - 4) | 0');
 cases = ReplaceAll(cases, 'sp -= 2', 'sp = (sp - 8) | 0');
+cases = ReplaceAll(cases, 'sp += 3', 'sp = (sp + 12) | 0');
 cases = ReplaceAll(cases, 'fp -= 2', 'fp = (fp - 8) | 0');
 cases = ReplaceAll(cases, 'sizeof(cell_t)', '4');
 cases = ReplaceAll(cases, 'sizeof(float)', '4');