diff --git a/BUILD b/BUILD index c090249..beb3198 100644 --- a/BUILD +++ b/BUILD @@ -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') diff --git a/common/all_tests.fs b/common/all_tests.fs index 2fb22d8..32bf15c 100644 --- 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 diff --git a/common/base_tests.fs b/common/base_tests.fs index 175fdd1..c6a7a19 100644 --- 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 diff --git a/common/boot.fs b/common/boot.fs index 270fb7c..7c84238 100644 --- 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 ! ; diff --git a/common/floats.fs b/common/floats.fs index 5baa316..ce6bd9d 100644 --- 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 diff --git a/common/floats.h b/common/floats.h index ea54813..9d64515 100644 --- 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)) \ diff --git a/common/forth_namespace_tests.fs b/common/forth_namespace_tests.fs index 0933ba7..1a77f84 100644 --- 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 diff --git a/common/io.fs b/common/io.fs index e63a6a2..9a27a22 100644 --- 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 ! ; diff --git a/common/recognizer_tests.fs b/common/recognizer_tests.fs new file mode 100644 index 0000000..07a1b97 --- /dev/null +++ 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 diff --git a/common/tier1_opcodes.h b/common/tier1_opcodes.h index e70caee..5ff347f 100644 --- 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) \ diff --git a/common/vocabulary.fs b/common/vocabulary.fs index 2347bbb..db6ad3d 100644 --- 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 ) diff --git a/configure.py b/configure.py index 6325652..3ea1679 100755 --- 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 diff --git a/tools/check_web_sanity.py b/tools/check_web_sanity.py index 867334c..576ccbb 100755 --- 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) diff --git a/web/fuse_web.js b/web/fuse_web.js index a656380..938bc04 100755 --- 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');