diff --git a/ueforth/Makefile b/ueforth/Makefile index 59fa02d..7349bff 100644 --- a/ueforth/Makefile +++ b/ueforth/Makefile @@ -115,25 +115,23 @@ $(GEN): POSIX_BOOT = common/boot.fs common/vocabulary.fs common/hide_calls.fs common/ansi.fs \ posix/posix.fs posix/posix_highlevel.fs \ - common/highlevel.fs common/filetools.fs posix/posix_desktop.fs \ - common/tasks.fs common/streams.fs common/blocks.fs posix/args.fs \ - common/utils.fs + common/utils.fs common/highlevel.fs common/filetools.fs posix/posix_desktop.fs \ + common/tasks.fs common/streams.fs common/blocks.fs posix/args.fs $(GEN)/posix_boot.h: common/source_to_string.js $(POSIX_BOOT) | $(GEN) echo "ok" | cat $(POSIX_BOOT) - | $< boot >$@ WINDOWS_BOOT = common/boot.fs common/vocabulary.fs common/hide_calls.fs common/ansi.fs \ windows/windows.fs windows/windows_highlevel.fs common/highlevel.fs \ - common/tasks.fs common/streams.fs common/blocks.fs \ - common/utils.fs + common/utils.fs common/tasks.fs common/streams.fs common/blocks.fs $(GEN)/windows_boot.h: common/source_to_string.js $(WINDOWS_BOOT) | $(GEN) echo "ok" | cat $(WINDOWS_BOOT) - | $< boot >$@ ARDUINO_BOOT = common/boot.fs common/vocabulary.fs \ arduino/arduino.fs arduino/arduino_highlevel.fs \ - arduino/hide_io.fs \ - common/highlevel.fs common/filetools.fs \ + arduino/hide_io.fs common/highlevel.fs \ + common/filetools.fs common/utils.fs \ common/tasks.fs common/streams.fs arduino/arduino_server.fs \ - arduino/esp_camera.fs common/blocks.fs common/utils.fs \ + arduino/esp_camera.fs common/blocks.fs \ arduino/autoboot.fs $(GEN)/arduino_boot.h: common/source_to_string.js $(ARDUINO_BOOT) | $(GEN) echo "ok" | cat $(ARDUINO_BOOT) - | $< boot >$@ diff --git a/ueforth/common/testing.fs b/ueforth/common/testing.fs index 1d7abd9..47087b6 100644 --- a/ueforth/common/testing.fs +++ b/ueforth/common/testing.fs @@ -1,9 +1,4 @@ -( Utilities, probably should go elsewhere ) -: mem= ( a a n -- f) - for aft 2dup c@ swap c@ <> if 2drop rdrop 0 exit then 1+ swap 1+ then next 2drop -1 ; -: str= ( a n a n -- f) >r swap r@ <> if rdrop 2drop 0 exit then r> mem= ; -: startswith? ( a n a n -- f ) >r swap r@ < if rdrop 2drop 0 exit then r> mem= ; -: assert ( f -- ) 0= throw ; +also ansi also posix ( Support for eval tests ) 1000 constant expect-limit @@ -45,9 +40,7 @@ variable tests-found variable tests-run variable tests-passed : check-fresh depth if }confirm ." DEPTH LEAK! " depth . 1 throw then ; : wrap-test ( xt -- ) expect-reset >r check-fresh r> execute check-fresh expect-finish ; : red 1 fg ; : green 2 fg ; : hr 40 for [char] - emit next cr ; -ansi : replace-line 13 emit clear-to-eol ; -forth : label-test ( xt -- ) replace-line >name type ; : run-test ( xt -- ) dup label-test confirm{ ['] wrap-test catch }confirm if drop ( cause xt restored on throw ) red ." FAILED" normal cr @@ -62,9 +55,8 @@ forth else ." FAILED: " red tests-run @ tests-passed @ - . normal cr then hr ; -posix : run-tests reset-test-counters ['] count-test for-tests ['] run-test for-tests show-test-results tests-passed @ tests-found @ <> sysexit ; -forth +only forth diff --git a/ueforth/common/utils.fs b/ueforth/common/utils.fs index 9bb1fdc..7736849 100644 --- a/ueforth/common/utils.fs +++ b/ueforth/common/utils.fs @@ -2,4 +2,13 @@ : .s ." <" depth <# #s #> type ." > " depth 0 max for aft sp@ r@ cells - @ . then next cr ; +: assert ( f -- ) 0= throw ; + +internals definitions +: mem= ( a a n -- f) + for aft 2dup c@ swap c@ <> if 2drop rdrop 0 exit then 1+ swap 1+ then next 2drop -1 ; +forth definitions also internals +: str= ( a n a n -- f) >r swap r@ <> if rdrop 2drop 0 exit then r> mem= ; +: startswith? ( a n a n -- f ) >r swap r@ < if rdrop 2drop 0 exit then r> mem= ; +only forth definitions diff --git a/ueforth/common/vocabulary.fs b/ueforth/common/vocabulary.fs index 7833a6d..2155280 100644 --- a/ueforth/common/vocabulary.fs +++ b/ueforth/common/vocabulary.fs @@ -13,12 +13,18 @@ : }transfer ; : transfer{ begin ' dup ['] }transfer = if drop exit then transfer-xt again ; +( Watered down versions of these ) +: only forth 0 context cell+ ! ; +: last-voc ( -- a) context begin dup @ while cell+ repeat ; +: also context context cell+ last-voc over - cell+ cmove> ; +: sealed 0 current @ ! ; + ( Hide some words in an internals vocabulary ) vocabulary internals internals definitions transfer{ - transfer-xt + transfer-xt last-voc branch 0branch donext dolit - 'notfound notfound + 'context 'notfound notfound immediate? input-buffer ?echo ?echo-prompt evaluate1 evaluate-buffer 'sys 'heap aliteral