From e67d85d64e03a0f5fe47371fec06d6f1060a3a3e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ond=C5=99ej=20Hru=C5=A1ka?= Date: Wed, 17 Nov 2021 23:58:01 +0100 Subject: [PATCH] many fixes and add some missing words --- README.md | 16 +- include/fh_config.h | 13 + include/fh_error.h | 2 +- include/fh_helpers.h | 36 + include/fh_parse.h | 9 +- include/fh_print.h | 5 - include/fh_runtime.h | 50 +- include/fh_stack.h | 3 + include/forth.h | 8 +- include/forth_internal.h | 31 + src/fh_builtins.c | 6 +- src/fh_builtins_arith.c | 244 ++++- src/fh_builtins_control.c | 30 +- src/fh_builtins_mem.c | 51 +- src/fh_builtins_meta.c | 50 +- src/fh_builtins_stack.c | 5 +- src/fh_builtins_system.c | 21 +- src/fh_builtins_text.c | 18 +- src/fh_error.c | 4 +- src/fh_mem.c | 28 +- src/fh_parse.c | 192 +++- src/fh_runtime.c | 202 +--- src/fh_see.c | 50 +- src/fh_stack.c | 24 +- src/main.c | 6 +- testfiles/combinedtest.f | 1845 +++++++++++++++++++++++++++++++++++++ testfiles/ifmacro.f | 33 + 27 files changed, 2631 insertions(+), 351 deletions(-) create mode 100644 include/fh_helpers.h create mode 100644 include/forth_internal.h create mode 100644 testfiles/combinedtest.f create mode 100644 testfiles/ifmacro.f diff --git a/README.md b/README.md index 66cb0e7..c2abfa5 100644 --- a/README.md +++ b/README.md @@ -44,15 +44,15 @@ Implementation status *(this section may be outdated)* -Implemented: +Implemented (some may be wrong, like `FM/MOD`): ``` CORE: ! ' ( * */ */MOD + +! +LOOP , - . ." / /mod 0< 0= 1+ 1- 2! 2* 2/ 2@ 2DROP 2DUP 2OVER 2SWAP -: ; < = > >IN >R ?DUP @ ABORT ABS ALIGN ALIGNED ALLOT AND BASE BEGIN BL CELL CELL+ CELLS CHAR CHAR+ -CHARS CONSTANT COUNT CR CREATE DECIMAL DEPTH DO DROP DUP ELSE EMIT ENVIRONMENT? EXECUTE EXIT FIND -HERE I IF IMMEDIATE INVERT J LEAVE LITERAL LOOP MOD NEGATE OR OVER POSTPONE QUIT R> R@ RECURSE -REPEAT ROT S" SOURCE SPACE SWAP THEN TYPE U< UNTIL VARIABLE WHILE WORD XOR [ ['] [CHAR] ] +: ; < = > >IN >R ?DUP @ ABORT ABS ALIGN ALIGNED ALLOT AND BASE BEGIN BL C! C, C@ CELL CELL+ CELLS CHAR CHAR+ +CHARS CONSTANT COUNT CR CREATE DECIMAL DEPTH DO DROP DUP ELSE EMIT ENVIRONMENT? EXECUTE EXIT FM/MOD FIND +HERE I IF IMMEDIATE INVERT J LEAVE LITERAL LOOP LSHIFT M* MAX MIN MOD NEGATE OR OVER POSTPONE QUIT R> R@ RECURSE +REPEAT ROT RSHIFT S>D S" SM/REM SOURCE SPACE STATE SWAP THEN TYPE U< UNTIL UM* UM/MOD UNLOOP VARIABLE WHILE WORD XOR [ ['] [CHAR] ] CORE-EXT: .( 0<> 0> 2>R 2R> 2R@ <> ?DO AGAIN FALSE HEX NIP PAD PICK ROLL S\" TO TRUE TUCK U.R U> UNUSED VALUE @@ -64,13 +64,11 @@ FORGET SEE BYE Missing: -basically, CASE-OF, pictured numbers, some specialty math stuff, working with characters, the more -weird metaprogramming things, and manipulating the input buffer. +basically, CASE-OF, pictured numbers, keyboard input, some weirder metaprogramming things, manipulating the input buffer. ``` CORE: -# #> #S <# >BODY >NUMBER ABORT" ACCEPT C! C, C@ DOES> EVALUATE FILL FM/MOD HOLD KEY LSHIFY M* MAX -MIN MOVE RSHIFT S>D SIGN SM/REM SPACES STATE U. UM* UM/MOD UNLOOP +# #> #S <# >BODY >NUMBER ABORT" ACCEPT DOES> EVALUATE FILL HOLD KEY MOVE SIGN SPACES U. CORE-EXT: .R :NONAME ACTION-OF BUFFER: C" CASE COMPILE, DEFER DEFER! DEFER@ ENDCASE ENDOF ERASE HOLDS IS diff --git a/include/fh_config.h b/include/fh_config.h index fdc05eb..b279c6f 100644 --- a/include/fh_config.h +++ b/include/fh_config.h @@ -19,4 +19,17 @@ #define CELL 4 +#define HEAP_END (HEAP_SIZE - WORDBUF_SIZE - INPUT_BUFFER_SIZE) +#define WORDBUF_ADDR HEAP_END +#define INPUTBUF_ADDR (HEAP_END + WORDBUF_SIZE) + +// SFR and magic addresses are "negative" +#define MAGICADDR_EXEC_INTERACTIVE 0xFFFFFFFFULL +#define MAGICADDR_DICTFIRST 0xFFFFd1c7ULL +#define MAGICADDR_BASE 0xFFFFBA5EULL +#define MAGICADDR_HERE 0xFFFF4E7EULL +#define MAGICADDR_STATE 0xFFFF57a7ULL +#define MAGICADDR_INPTR 0xFFFFF175ULL +#define MAGICADDR_UNRESOLVED 0xFFFFFBADULL + #endif //FORTH_FH_CONFIG_H diff --git a/include/fh_error.h b/include/fh_error.h index e5436d6..6591c6d 100644 --- a/include/fh_error.h +++ b/include/fh_error.h @@ -25,7 +25,7 @@ enum fh_error { FH_ERR_UNKNOWN_WORD, FH_ERR_ILLEGAL_FETCH, FH_ERR_ILLEGAL_STORE, - FH_ERR_DIV_BY_ZERO, + FH_ERR_ARITH, FH_ERR_SYNTAX, FH_ERR_NOT_APPLICABLE, FH_ERR_MAX, diff --git a/include/fh_helpers.h b/include/fh_helpers.h new file mode 100644 index 0000000..5471a4a --- /dev/null +++ b/include/fh_helpers.h @@ -0,0 +1,36 @@ +/** + * Helper macros + * + * Created on 2021/11/17. + */ + +#ifndef FORTH_FH_MACROS_H +#define FORTH_FH_MACROS_H + +/** + * strncasecmp with guard against prefix match + * + * a - input string + * b - example string with terminator + * n - len of input string + */ +#define EQ(a, b, n) (0 == strncasecmp((a), (b), (n)) && (b)[(n)]==0) + +/** Get a value rounded up to multiple of word size */ +#define WORDALIGNED(var) (((var) + 3) & ~3) + +_Static_assert(WORDALIGNED(0) == 0, "word align"); +_Static_assert(WORDALIGNED(1) == 4, "word align"); +_Static_assert(WORDALIGNED(2) == 4, "word align"); +_Static_assert(WORDALIGNED(3) == 4, "word align"); +_Static_assert(WORDALIGNED(4) == 4, "word align"); +_Static_assert(WORDALIGNED(5) == 8, "word align"); +_Static_assert(WORDALIGNED(1023) == 1024, "word align"); +_Static_assert(WORDALIGNED(1024) == 1024, "word align"); + +#define TRY(x) \ + do { \ + if (FH_OK != (rv = (x))) return rv; \ + } while (0) + +#endif //FORTH_FH_MACROS_H diff --git a/include/fh_parse.h b/include/fh_parse.h index b9205f9..aada5f9 100644 --- a/include/fh_parse.h +++ b/include/fh_parse.h @@ -7,15 +7,18 @@ #ifndef FORTH_FH_PARSE_H #define FORTH_FH_PARSE_H -typedef bool (*chartest_t)(char c, void* param); +typedef bool (*chartest_t)(char c, void *param); -void fh_input_consume_matching(struct fh_thread_s *fh, chartest_t test, void* param); +void fh_input_consume_matching(struct fh_thread_s *fh, chartest_t test, void *param); void fh_input_consume_spaces(struct fh_thread_s *fh); -enum fh_error fh_input_read_delimited(struct fh_thread_s *fh, char **out, size_t *len, chartest_t test, void* param); +enum fh_error fh_input_read_delimited(struct fh_thread_s *fh, char **out, size_t *len, chartest_t test, void *param); + enum fh_error fh_input_read_word(struct fh_thread_s *fh, char **out, size_t *len); enum fh_error fh_input_read_quotedstring(struct fh_thread_s *fh, bool escaped, char *outbuf, size_t capacity, size_t *out_len); +enum fh_error fh_handle_ascii_word(struct fh_thread_s *fh, const char *name, size_t wordlen); + #endif //FORTH_FH_PARSE_H diff --git a/include/fh_print.h b/include/fh_print.h index 61307ec..20fc9ad 100644 --- a/include/fh_print.h +++ b/include/fh_print.h @@ -7,11 +7,6 @@ #ifndef FORTH_FH_PRINT_H #define FORTH_FH_PRINT_H -/* for printing */ -#include -#include -#include "fh_globals.h" - /* logging */ #define LOG(format, ...) do { if(fh_globals.verbose) { fprintf(stderr, format "\n", ##__VA_ARGS__); } } while (0) #define LOGI(format, ...) fprintf(stderr, "\x1b[32m" format "\x1b[m\n", ##__VA_ARGS__) diff --git a/include/fh_runtime.h b/include/fh_runtime.h index 4a91b16..0a1af25 100644 --- a/include/fh_runtime.h +++ b/include/fh_runtime.h @@ -78,12 +78,6 @@ struct fh_instruction_s { uint32_t data; }; -static inline void instr_init(struct fh_instruction_s *instr, enum fh_instruction_kind kind, uint32_t data) -{ - instr->kind = kind; - instr->data = data; -} - #define INSTR_SIZE (sizeof(struct fh_instruction_s)) _Static_assert(sizeof(struct fh_instruction_s) % 4 == 0, "Instruction struct is aligned"); @@ -107,9 +101,12 @@ enum fh_substate { FH_SUBSTATE_PAREN_COMMENT, FH_SUBSTATE_LINE_COMMENT, FH_SUBSTATE_EXIT, + FH_SUBSTATE_SKIP_IF, FH_SUBSTATE_MAX, }; +extern const char *substatenames[FH_SUBSTATE_MAX]; + /** Marks a dictionary entry that is a word */ #define WORDFLAG_WORD 0x01 /** Indicates that this is a built-in instruction and not a word call */ @@ -147,11 +144,8 @@ struct fh_word_s { /** Word name */ char name[MAX_NAME_LEN]; // XXX this wastes RAM! - - }; -#define MAGICADDR_DICTFIRST 0xFFFFFFFFULL #define DICTWORD_SIZE sizeof(struct fh_word_s) /** @@ -201,11 +195,10 @@ struct fh_thread_s { /** Loop variable J */ uint32_t loop_j; -}; -#define HEAP_END (HEAP_SIZE - WORDBUF_SIZE - INPUT_BUFFER_SIZE) -#define WORDBUF_ADDR HEAP_END -#define INPUTBUF_ADDR (HEAP_END + WORDBUF_SIZE) + /** Nesting level of [if] */ + uint32_t parse_if_level; +}; enum fh_error fh_loop_nest(struct fh_thread_s *fh, uint32_t indexvalue); @@ -232,33 +225,6 @@ enum fh_error fh_see_word( size_t wordlen ); -/* if the return address is this, we should drop back to interactive mode */ - -// SFR and magic addresses are "negative" -#define MAGICADDR_EXEC_INTERACTIVE 0xFFFFFFFFULL - -#define MAGICADDR_BASE 0xFFFFBA5EULL -#define MAGICADDR_HERE 0xFFFF4E7EULL -#define MAGICADDR_INPTR 0xFFFFF111ULL -#define MAGICADDR_UNRESOLVED 0xFFFFFBADULL - -/** Get a value rounded up to multiple of word size */ -#define WORDALIGNED(var) (((var) + 3) & ~3) - -_Static_assert(WORDALIGNED(0) == 0, "word align"); -_Static_assert(WORDALIGNED(1) == 4, "word align"); -_Static_assert(WORDALIGNED(2) == 4, "word align"); -_Static_assert(WORDALIGNED(3) == 4, "word align"); -_Static_assert(WORDALIGNED(4) == 4, "word align"); -_Static_assert(WORDALIGNED(5) == 8, "word align"); -_Static_assert(WORDALIGNED(1023) == 1024, "word align"); -_Static_assert(WORDALIGNED(1024) == 1024, "word align"); - -#define TRY(x) \ - do { \ - if (FH_OK != (rv = (x))) return rv; \ - } while (0) - /** * Execute a dictionary word from a definition stored at the given address * @param fh @@ -278,4 +244,8 @@ enum fh_error fh_handle_word(struct fh_thread_s *fh, uint32_t addr); */ enum fh_error fh_find_word(struct fh_thread_s *fh, const char *name, size_t wordlen, uint32_t *addr_out); +enum fh_error fh_init(struct fh_thread_s *fh); + +enum fh_error fh_process_line(struct fh_thread_s *fh, const char *linebuf, size_t len); + #endif //FORTH_FH_RUNTIME_H diff --git a/include/fh_stack.h b/include/fh_stack.h index 7ee5425..cfb8b68 100644 --- a/include/fh_stack.h +++ b/include/fh_stack.h @@ -18,6 +18,9 @@ static inline enum fh_error cs_peek_n(struct fh_thread_s *fh, uint32_t *out, int return ds_peek_n(fh, out, n); } +enum fh_error ds_push_dw(struct fh_thread_s *fh, uint64_t in); +enum fh_error ds_pop_dw(struct fh_thread_s *fh, uint64_t *out); + enum fh_error rs_poke_n(struct fh_thread_s *fh, uint32_t value, int n); /** Peek top of data stack */ diff --git a/include/forth.h b/include/forth.h index 44db000..9a2a296 100644 --- a/include/forth.h +++ b/include/forth.h @@ -13,10 +13,8 @@ #include "fh_config.h" #include "fh_error.h" - -struct fh_thread_s; - -enum fh_error fh_init(struct fh_thread_s *fh); -enum fh_error fh_process_line(struct fh_thread_s *fh, const char *linebuf, size_t len); +#include "fh_globals.h" +#include "fh_runtime.h" +#include "fh_print.h" #endif //FORTH_H diff --git a/include/forth_internal.h b/include/forth_internal.h new file mode 100644 index 0000000..2ce78af --- /dev/null +++ b/include/forth_internal.h @@ -0,0 +1,31 @@ +/** + * TODO file description + * + * Created on 2021/11/17. + */ + +#ifndef FORTH_FORTH_INTERNAL_H +#define FORTH_FORTH_INTERNAL_H + +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#include "fh_config.h" +#include "fh_error.h" +#include "fh_helpers.h" +#include "fh_globals.h" +#include "fh_print.h" +#include "fh_runtime.h" +#include "fh_mem.h" +#include "fh_stack.h" +#include "fh_parse.h" +#include "fh_builtins.h" + +#endif //FORTH_FORTH_INTERNAL_H diff --git a/src/fh_builtins.c b/src/fh_builtins.c index bcb45e3..ad2e9ab 100644 --- a/src/fh_builtins.c +++ b/src/fh_builtins.c @@ -1,8 +1,4 @@ -#include -#include "fh_runtime.h" -#include "fh_error.h" -#include "fh_print.h" -#include "fh_builtins.h" +#include "forth_internal.h" enum fh_error fh_register_words_from_array(struct fh_thread_s *fh, const struct name_and_handler *p) { diff --git a/src/fh_builtins_arith.c b/src/fh_builtins_arith.c index 02add6e..da04faf 100644 --- a/src/fh_builtins_arith.c +++ b/src/fh_builtins_arith.c @@ -1,9 +1,4 @@ -#include "fh_error.h" -#include "fh_runtime.h" -#include "fh_mem.h" -#include "fh_stack.h" -#include "fh_print.h" -#include "fh_builtins.h" +#include "forth_internal.h" static enum fh_error wp_setbase(struct fh_thread_s *fh, const struct fh_word_s *w) { @@ -84,13 +79,35 @@ static enum fh_error w_xor(struct fh_thread_s *fh, const struct fh_word_s *w) return FH_OK; } +static enum fh_error w_lshift(struct fh_thread_s *fh, const struct fh_word_s *w) +{ + (void) w; + enum fh_error rv; + uint32_t a = 0, b = 0; + TRY(ds_pop(fh, &b)); + TRY(ds_pop(fh, &a)); + TRY(ds_push(fh, a << b)); + return FH_OK; +} + +static enum fh_error w_rshift(struct fh_thread_s *fh, const struct fh_word_s *w) +{ + (void) w; + enum fh_error rv; + uint32_t a = 0, b = 0; + TRY(ds_pop(fh, &b)); + TRY(ds_pop(fh, &a)); + TRY(ds_push(fh, a >> b)); + return FH_OK; +} + static enum fh_error w_zero_less(struct fh_thread_s *fh, const struct fh_word_s *w) { (void) w; enum fh_error rv; uint32_t a = 0; TRY(ds_pop(fh, &a)); - TRY(ds_push(fh, TOBOOL((int32_t)a < 0))); + TRY(ds_push(fh, TOBOOL((int32_t) a < 0))); return FH_OK; } @@ -124,6 +141,27 @@ static enum fh_error w_zero_not_equals(struct fh_thread_s *fh, const struct fh_w return FH_OK; } +static enum fh_error w_min(struct fh_thread_s *fh, const struct fh_word_s *w) +{ + (void) w; + enum fh_error rv; + uint32_t a = 0, b = 0; + TRY(ds_pop(fh, &b)); + TRY(ds_pop(fh, &a)); + TRY(ds_push(fh, (int32_t) a < (int32_t) b ? a : b)); + return FH_OK; +} + +static enum fh_error w_max(struct fh_thread_s *fh, const struct fh_word_s *w) +{ + (void) w; + enum fh_error rv; + uint32_t a = 0, b = 0; + TRY(ds_pop(fh, &b)); + TRY(ds_pop(fh, &a)); + TRY(ds_push(fh, (int32_t) a < (int32_t) b ? b : a)); + return FH_OK; +} static enum fh_error w_less(struct fh_thread_s *fh, const struct fh_word_s *w) { @@ -215,7 +253,17 @@ static enum fh_error wp_div(struct fh_thread_s *fh, const struct fh_word_s *w) enum fh_error rv; uint32_t a = 0; TRY(ds_pop(fh, &a)); - TRY(ds_push(fh, a * w->param)); + TRY(ds_push(fh, (int32_t) a / (int32_t) w->param)); + return FH_OK; +} + +static enum fh_error w_2div(struct fh_thread_s *fh, const struct fh_word_s *w) +{ + (void) w; + enum fh_error rv; + uint32_t a = 0; + TRY(ds_pop(fh, &a)); + TRY(ds_push(fh, (a & 0x80000000) | (a >> 1))); return FH_OK; } @@ -229,10 +277,10 @@ static enum fh_error w_star_slash(struct fh_thread_s *fh, const struct fh_word_s TRY(ds_pop(fh, &a)); if (c == 0) { - return FH_ERR_DIV_BY_ZERO; + return FH_ERR_ARITH; } - uint64_t v = ((uint64_t) a * (uint64_t) b) / (uint64_t) c; + int64_t v = ((int64_t) (int32_t)a * (int64_t) (int32_t)b) / (int64_t) (int32_t)c; TRY(ds_push(fh, (uint32_t) v)); return FH_OK; @@ -248,15 +296,15 @@ static enum fh_error w_star_slash_mod(struct fh_thread_s *fh, const struct fh_wo TRY(ds_pop(fh, &a)); if (c == 0) { - return FH_ERR_DIV_BY_ZERO; + return FH_ERR_ARITH; } - uint64_t product = ((uint64_t) a * (uint64_t) b); - uint64_t v = product / (uint64_t) c; - uint64_t m = product % (uint64_t) c; + int64_t product = ((int64_t) (int32_t)a * (int64_t) (int32_t)b); + int64_t v = product / (int64_t) (int32_t)c; + int64_t m = product % (int64_t) (int32_t)c; - TRY(ds_push(fh, (uint32_t) m)); - TRY(ds_push(fh, (uint32_t) v)); + TRY(ds_push(fh, (uint32_t) (int32_t)m)); + TRY(ds_push(fh, (uint32_t) (int32_t)v)); return FH_OK; } @@ -269,10 +317,10 @@ static enum fh_error w_slash(struct fh_thread_s *fh, const struct fh_word_s *w) TRY(ds_pop(fh, &a)); if (b == 0) { - return FH_ERR_DIV_BY_ZERO; + return FH_ERR_ARITH; } - TRY(ds_push(fh, a / b)); + TRY(ds_push(fh, (int32_t)a / (int32_t)b)); return FH_OK; } @@ -320,11 +368,11 @@ static enum fh_error w_slash_mod(struct fh_thread_s *fh, const struct fh_word_s TRY(ds_pop(fh, &a)); if (b == 0) { - return FH_ERR_DIV_BY_ZERO; + return FH_ERR_ARITH; } - uint32_t rem = a % b; - uint32_t div = a / b; + int32_t rem = (int32_t)a % (int32_t)b; + int32_t div = (int32_t)a / (int32_t)b; TRY(ds_push(fh, rem)); TRY(ds_push(fh, div)); @@ -340,15 +388,153 @@ static enum fh_error w_mod(struct fh_thread_s *fh, const struct fh_word_s *w) TRY(ds_pop(fh, &a)); if (b == 0) { - return FH_ERR_DIV_BY_ZERO; + return FH_ERR_ARITH; } - uint32_t rem = a % b; + int32_t rem = (int32_t)a % (int32_t)b; TRY(ds_push(fh, rem)); return FH_OK; } +static enum fh_error w_s_to_d(struct fh_thread_s *fh, const struct fh_word_s *w) +{ + (void) w; + enum fh_error rv; + uint32_t a = 0; + TRY(ds_pop(fh, &a)); + + int32_t as = (int32_t) a; // because of sign extend + int64_t a64 = as; + + TRY(ds_push_dw(fh, (uint64_t) a64)); + return FH_OK; +} + +static enum fh_error w_m_star(struct fh_thread_s *fh, const struct fh_word_s *w) +{ + (void) w; + enum fh_error rv; + uint32_t a = 0, b = 0; + TRY(ds_pop(fh, &a)); + TRY(ds_pop(fh, &b)); + + // make signed and then sign extend + int64_t res = (int64_t) (int32_t) a * (int64_t) (int32_t) b; + + TRY(ds_push_dw(fh, (uint64_t) res)); + return FH_OK; +} + +static enum fh_error w_um_star(struct fh_thread_s *fh, const struct fh_word_s *w) +{ + (void) w; + enum fh_error rv; + uint32_t a = 0, b = 0; + TRY(ds_pop(fh, &a)); + TRY(ds_pop(fh, &b)); + + // make signed and then sign extend + uint64_t res = (uint64_t) a * (uint64_t) b; + + TRY(ds_push_dw(fh, res)); + return FH_OK; +} + +// Copied from https://stackoverflow.com/a/51457071/2180189 +void floor_div64(int64_t *q, int64_t *r, int64_t a, int64_t b) +{ + int64_t q0 = a / b; + int64_t r0 = a % b; + if (b > 0){ + *q = r0 >= 0 ? q0 : q0 - 1; + *r = r0 >= 0 ? r0 : r0 + b; + } + else { + *q = r0 <= 0 ? q0 : q0 - 1; + *r = r0 <= 0 ? r0 : r0 + b; + } +} + +static enum fh_error w_fm_mod(struct fh_thread_s *fh, const struct fh_word_s *w) +{ + (void) w; + enum fh_error rv; + int32_t div; + int64_t num; + TRY(ds_pop(fh, (uint32_t*)&div)); + TRY(ds_pop_dw(fh, (uint64_t*)&num)); + + int64_t res, rem; + + floor_div64(&res, &rem, num, div); + + if ((int64_t)(int32_t)rem != rem) { + LOGE("Remainder too large"); + return FH_ERR_ARITH; + } + if ((int64_t)(int32_t)res != res) { + LOGE("Division result too large"); + return FH_ERR_ARITH; + } + + TRY(ds_push(fh, (int32_t)rem)); + TRY(ds_push(fh, (int32_t)res)); + return FH_OK; +} + +static enum fh_error w_um_mod(struct fh_thread_s *fh, const struct fh_word_s *w) +{ + (void) w; + enum fh_error rv; + uint32_t div; + uint64_t num; + TRY(ds_pop(fh, &div)); + TRY(ds_pop_dw(fh, &num)); + + uint64_t res = num / (uint64_t)div; // TODO verify this may be wrong + uint64_t rem = num % (uint64_t)div; + + if ((uint64_t)(uint32_t)rem != rem) { + LOGE("Remainder too large"); + return FH_ERR_ARITH; + } + if ((uint64_t)(uint32_t)res != res) { + LOGE("Division result too large"); + return FH_ERR_ARITH; + } + + TRY(ds_push(fh, (uint32_t)rem)); + TRY(ds_push(fh, (uint32_t)res)); + return FH_OK; +} + +static enum fh_error w_sm_rem(struct fh_thread_s *fh, const struct fh_word_s *w) +{ + (void) w; + enum fh_error rv; + int32_t div; + int64_t num; + TRY(ds_pop(fh, (uint32_t*)&div)); + TRY(ds_pop_dw(fh, (uint64_t*)&num)); + + int64_t res = num / (int64_t)div; + int64_t rem = num % (int64_t)div; + + if ((int64_t)(int32_t)rem != rem) { + LOGE("Remainder too large"); + return FH_ERR_ARITH; + } + if ((int64_t)(int32_t)res != res) { + LOGE("Division result too large"); + return FH_ERR_ARITH; + } + + TRY(ds_push(fh, (int32_t)rem)); + TRY(ds_push(fh, (int32_t)res)); + return FH_OK; +} + const struct name_and_handler fh_builtins_arith[] = { /* Arithmetics */ {"base", wp_const, 0, MAGICADDR_BASE}, @@ -370,6 +556,10 @@ const struct name_and_handler fh_builtins_arith[] = { {"mod", w_mod, 0, 0}, {"invert", w_invert, 0, 0}, {"negate", w_negate, 0, 0}, + {"lshift", w_lshift, 0, 0}, + {"rshift", w_rshift, 0, 0}, + {"min", w_min, 0, 0}, + {"max", w_max, 0, 0}, {"0<", w_zero_less, 0, 0}, {"0=", w_zero_equals, 0, 0}, {"0<>", w_zero_not_equals, 0, 0}, @@ -385,6 +575,12 @@ const struct name_and_handler fh_builtins_arith[] = { {"2+", wp_add, 0, 2}, {"2-", wp_add, 0, -2}, {"2*", wp_mul, 0, 2}, - {"2/", wp_div, 0, 2}, + {"2/", w_2div, 0, 0}, + {"s>d", w_s_to_d, 0, 0}, + {"m*", w_m_star, 0, 0}, + {"um*", w_um_star, 0, 0}, + {"fm/mod", w_fm_mod, 0, 0}, + {"sm/rem", w_sm_rem, 0, 0}, + {"um/mod", w_um_mod, 0, 0}, { /* end marker */ } }; diff --git a/src/fh_builtins_control.c b/src/fh_builtins_control.c index 93392f5..d4c19b2 100644 --- a/src/fh_builtins_control.c +++ b/src/fh_builtins_control.c @@ -1,9 +1,4 @@ -#include "fh_error.h" -#include "fh_runtime.h" -#include "fh_mem.h" -#include "fh_stack.h" -#include "fh_print.h" -#include "fh_builtins.h" +#include "forth_internal.h" static enum fh_error w_recurse(struct fh_thread_s *fh, const struct fh_word_s *w) { @@ -36,7 +31,7 @@ static enum fh_error w_else(struct fh_thread_s *fh, const struct fh_word_s *w) uint32_t ifaddr = 0; TRY(cs_pop(fh, &ifaddr)); struct fh_instruction_s *if_instr = fh_instr_at(fh, ifaddr); - if (if_instr->data != MAGICADDR_UNRESOLVED) { + if (!if_instr || if_instr->data != MAGICADDR_UNRESOLVED) { LOGE("IF-ELSE control stack corruption"); return FH_ERR_INTERNAL; } @@ -57,7 +52,7 @@ static enum fh_error w_then(struct fh_thread_s *fh, const struct fh_word_s *w) uint32_t ifaddr = 0; TRY(cs_pop(fh, &ifaddr)); struct fh_instruction_s *if_instr = fh_instr_at(fh, ifaddr); - if (if_instr->data != MAGICADDR_UNRESOLVED) { + if (!if_instr || if_instr->data != MAGICADDR_UNRESOLVED) { LOGE("IF-ELSE control stack corruption"); return FH_ERR_INTERNAL; } @@ -119,12 +114,16 @@ static enum fh_error wp_loop(struct fh_thread_s *fh, const struct fh_word_s *w) // resolve ?DO dest ii = fh_instr_at(fh, startaddr - INSTR_SIZE); - if (ii->kind == FH_INSTR_DO_QUESTION && ii->data == MAGICADDR_UNRESOLVED) { + if (!ii || ii->kind == FH_INSTR_DO_QUESTION && ii->data == MAGICADDR_UNRESOLVED) { ii->data = endaddr; } while (startaddr < loopendaddr) { ii = fh_instr_at(fh, startaddr); + if (!ii) { + LOGE("WHAT?"); + return FH_ERR_INTERNAL; + } if (ii->kind == FH_INSTR_LEAVE && ii->data == MAGICADDR_UNRESOLVED) { LOG("Resolve leave addr"); ii->data = endaddr; @@ -142,6 +141,16 @@ static enum fh_error wp_loop(struct fh_thread_s *fh, const struct fh_word_s *w) return FH_OK; } +static enum fh_error w_unloop(struct fh_thread_s *fh, const struct fh_word_s *w) +{ + (void) w; + enum fh_error rv; + uint32_t limit; + TRY(rs_pop(fh, &limit)); + TRY(fh_loop_unnest(fh)); + return FH_OK; +} + static enum fh_error w_leave(struct fh_thread_s *fh, const struct fh_word_s *w) { (void) w; @@ -182,7 +191,7 @@ static enum fh_error w_repeat(struct fh_thread_s *fh, const struct fh_word_s *w) TRY(cs_pop(fh, &origaddr)); struct fh_instruction_s *branch_instr = fh_instr_at(fh, origaddr); - if (branch_instr->data != MAGICADDR_UNRESOLVED) { + if (!branch_instr || branch_instr->data != MAGICADDR_UNRESOLVED) { LOGE("REPEAT control stack corruption"); return FH_ERR_INTERNAL; } @@ -231,6 +240,7 @@ const struct name_and_handler fh_builtins_control[] = { {"repeat", w_repeat, 1, 0}, {"again", w_again, 1, 0}, {"until", w_until, 1, 0}, + {"unloop", w_unloop, 0, 0}, { /* end marker */ } }; diff --git a/src/fh_builtins_mem.c b/src/fh_builtins_mem.c index 75d3334..3fde8ce 100644 --- a/src/fh_builtins_mem.c +++ b/src/fh_builtins_mem.c @@ -1,9 +1,4 @@ -#include "fh_error.h" -#include "fh_runtime.h" -#include "fh_mem.h" -#include "fh_stack.h" -#include "fh_print.h" -#include "fh_builtins.h" +#include "forth_internal.h" static enum fh_error w_fetch(struct fh_thread_s *fh, const struct fh_word_s *w) { @@ -117,6 +112,46 @@ static enum fh_error w_comma(struct fh_thread_s *fh, const struct fh_word_s *w) return FH_OK; } +static enum fh_error w_c_comma(struct fh_thread_s *fh, const struct fh_word_s *w) +{ + (void) w; + enum fh_error rv; + + uint32_t value = 0; + TRY(ds_pop(fh, &value)); + TRY(fh_heap_put(fh, &value, 1)); + return FH_OK; +} + +static enum fh_error w_c_store(struct fh_thread_s *fh, const struct fh_word_s *w) +{ + (void) w; + enum fh_error rv; + + uint32_t addr; + TRY(ds_pop(fh, &addr)); + + uint32_t value = 0; + TRY(ds_pop(fh, &value)); + TRY(fh_store_char(fh, addr, (char) value)); + return FH_OK; +} + +static enum fh_error w_c_fetch(struct fh_thread_s *fh, const struct fh_word_s *w) +{ + (void) w; + enum fh_error rv; + + uint32_t addr; + TRY(ds_pop(fh, &addr)); + + char value = 0; + TRY(fh_fetch_char(fh, addr, &value)); + + TRY(ds_push(fh, (uint32_t) value)); + return FH_OK; +} + static enum fh_error w_align(struct fh_thread_s *fh, const struct fh_word_s *w) { (void) w; @@ -161,7 +196,11 @@ const struct name_and_handler fh_builtins_mem[] = { {"allot", w_allot, 0, 0}, {"align", w_align, 0, 0}, {",", w_comma, 0, 0}, + {"c,", w_c_comma, 0, 0}, + {"c@", w_c_fetch, 0, 0}, + {"c!", w_c_store, 0, 0}, {"here", w_here, 0, 0}, + {"state", wp_const, 0, MAGICADDR_STATE}, {"pad", w_pad, 0, 0}, { /* end marker */ } diff --git a/src/fh_builtins_meta.c b/src/fh_builtins_meta.c index a6a98d4..e7bc0ad 100644 --- a/src/fh_builtins_meta.c +++ b/src/fh_builtins_meta.c @@ -1,11 +1,4 @@ -#include -#include "fh_error.h" -#include "fh_runtime.h" -#include "fh_mem.h" -#include "fh_stack.h" -#include "fh_print.h" -#include "fh_builtins.h" -#include "fh_parse.h" +#include "forth_internal.h" static enum fh_error w_colon(struct fh_thread_s *fh, const struct fh_word_s *w) { @@ -25,6 +18,7 @@ static enum fh_error w_colon(struct fh_thread_s *fh, const struct fh_word_s *w) TRY(fh_heap_reserve(fh, DICTWORD_SIZE, &ptr)); struct fh_word_s *new_word = fh_word_at(fh, ptr); + if (!new_word) return FH_ERR_INTERNAL; new_word->previous = fh->dict_last; new_word->param = fh->here; new_word->handler = w_user_word; @@ -53,6 +47,7 @@ static enum fh_error w_forget(struct fh_thread_s *fh, const struct fh_word_s *w) TRY(fh_find_word(fh, wordname, namelen, &addr)); struct fh_word_s *removedword = fh_word_at(fh, addr); + if (!removedword) return FH_ERR_INTERNAL; fh->dict_last = removedword->previous; return FH_OK; } @@ -91,6 +86,16 @@ static enum fh_error wp_variable(struct fh_thread_s *fh, const struct fh_word_s { (void) w; enum fh_error rv; + + bool is_value = w->param == 1; + bool is_const = w->param == 2; + + if (is_const && fh->state == FH_STATE_COMPILE) { + uint32_t wordaddr = (void *)w - (void *)&fh->heap[0]; // this is ugly + TRY(fh_put_instr(fh, FH_INSTR_WORD, wordaddr)); + return FH_OK; + } + ENSURE_STATE(FH_STATE_INTERPRET); char *wordname; @@ -101,9 +106,6 @@ static enum fh_error wp_variable(struct fh_thread_s *fh, const struct fh_word_s uint32_t ptr; uint32_t value = 0; - bool is_value = w->param == 1; - bool is_const = w->param == 2; - if (is_value || is_const) { TRY(ds_pop(fh, &value)); } @@ -111,6 +113,7 @@ static enum fh_error wp_variable(struct fh_thread_s *fh, const struct fh_word_s TRY(fh_heap_reserve(fh, DICTWORD_SIZE, &ptr)); struct fh_word_s *new_word = fh_word_at(fh, ptr); + if (!new_word) return FH_ERR_INTERNAL; new_word->previous = fh->dict_last; new_word->param = value; new_word->handler = (is_value || is_const) ? rt_read_value : rt_read_varaddr; @@ -147,10 +150,16 @@ static enum fh_error w_to(struct fh_thread_s *fh, const struct fh_word_s *w) TRY(fh_find_word(fh, wordname, namelen, &waddr)); struct fh_word_s *ww = fh_word_at(fh, waddr); + if (!ww) return FH_ERR_INTERNAL; + + if (ww->flags & WORDFLAG_WORD) { + LOGE("Cannot assign to dictionary word param field!"); + return FH_ERR_NOT_APPLICABLE; + } if (ww->flags & WORDFLAG_CONSTANT) { LOGE("Cannot assign to constant!"); - return FH_ERR_ILLEGAL_STORE; + return FH_ERR_NOT_APPLICABLE; } ww->param = value; @@ -236,7 +245,9 @@ static enum fh_error w_immediate(struct fh_thread_s *fh, const struct fh_word_s return FH_ERR_INVALID_STATE; } - fh_word_at(fh, fh->dict_last)->flags |= WORDFLAG_IMMEDIATE; + struct fh_word_s *word = fh_word_at(fh, fh->dict_last); + if (!word) return FH_ERR_INTERNAL; + word->flags |= WORDFLAG_IMMEDIATE; return FH_OK; } @@ -365,6 +376,7 @@ static enum fh_error w_create(struct fh_thread_s *fh, const struct fh_word_s *w) TRY(fh_heap_reserve(fh, DICTWORD_SIZE, &ptr)); struct fh_word_s *new_word = fh_word_at(fh, ptr); + if (!new_word) return FH_ERR_INTERNAL; new_word->previous = fh->dict_last; new_word->param = fh->here; new_word->handler = rt_read_value; @@ -398,6 +410,7 @@ static enum fh_error w_find(struct fh_thread_s *fh, const struct fh_word_s *w) } struct fh_word_s *word = fh_word_at(fh, addr); + if (!word) return FH_ERR_INTERNAL; TRY(ds_push(fh, addr)); TRY(ds_push(fh, (word->flags & WORDFLAG_IMMEDIATE) ? 1 : -1)); @@ -445,6 +458,10 @@ static enum fh_error w_execute(struct fh_thread_s *fh, const struct fh_word_s *w } struct fh_word_s *word = fh_word_at(fh, addr); + if (!word) { + LOGE("Execute with bad addr"); + return FH_ERR_NOT_APPLICABLE; + } if (!word->handler) { LOGE("Execute word with no handler"); return FH_ERR_NOT_APPLICABLE; @@ -463,8 +480,12 @@ static enum fh_error w_env_query(struct fh_thread_s *fh, const struct fh_word_s uint32_t addr; TRY(ds_pop(fh, &addr)); const char *str = fh_str_at(fh, addr); + if (!str) { + LOGE("Bad string addr for env query!"); + return FH_ERR_NOT_APPLICABLE; + } -#define EQ(a, b, n) (0 == strncasecmp((a), (b), n) && (b)[n]==0) + LOG("Test environment \"%.*s\"", len, str); if (EQ(str, "/COUNTED-STRING", len)) { TRY(ds_push(fh, 255)); @@ -522,7 +543,6 @@ static enum fh_error w_env_query(struct fh_thread_s *fh, const struct fh_word_s TRY(ds_push(fh, 0)); } -#undef EQ return FH_OK; } diff --git a/src/fh_builtins_stack.c b/src/fh_builtins_stack.c index 44f72de..acc240a 100644 --- a/src/fh_builtins_stack.c +++ b/src/fh_builtins_stack.c @@ -1,7 +1,4 @@ -#include "fh_error.h" -#include "fh_runtime.h" -#include "fh_stack.h" -#include "fh_builtins.h" +#include "forth_internal.h" static enum fh_error w_dupe(struct fh_thread_s *fh, const struct fh_word_s *w) { diff --git a/src/fh_builtins_system.c b/src/fh_builtins_system.c index 00cb5c3..ffb9a51 100644 --- a/src/fh_builtins_system.c +++ b/src/fh_builtins_system.c @@ -1,17 +1,9 @@ -#include "forth.h" -#include "fh_error.h" -#include "fh_runtime.h" -#include "fh_mem.h" -#include "fh_stack.h" -#include "fh_print.h" -#include "fh_builtins.h" +#include "forth_internal.h" // extension static enum fh_error w_reset(struct fh_thread_s *fh, const struct fh_word_s *w) { (void) w; - enum fh_error rv; - ENSURE_STATE(FH_STATE_INTERPRET); fh_init(fh); @@ -35,10 +27,21 @@ static enum fh_error w_debug(struct fh_thread_s *fh, const struct fh_word_s *w) return FH_OK; } +static enum fh_error w_exit(struct fh_thread_s *fh, const struct fh_word_s *w) +{ + (void) w; + enum fh_error rv; + ENSURE_STATE(FH_STATE_COMPILE); + // let's just hope the return stack is not clobbered! + TRY(fh_put_instr(fh, FH_INSTR_ENDWORD, 0)); + return FH_OK; +} + const struct name_and_handler fh_builtins_system[] = { {"reset", w_reset, 1, 0}, {"bye", w_bye, 0, 0}, {"debug", w_debug, 0, 0}, + {"exit", w_exit, 1, 0}, { /* end marker */ } }; diff --git a/src/fh_builtins_text.c b/src/fh_builtins_text.c index 9c7dbc4..b0d2e66 100644 --- a/src/fh_builtins_text.c +++ b/src/fh_builtins_text.c @@ -1,10 +1,4 @@ -#include "fh_error.h" -#include "fh_runtime.h" -#include "fh_mem.h" -#include "fh_stack.h" -#include "fh_print.h" -#include "fh_builtins.h" -#include "fh_parse.h" +#include "forth_internal.h" /** * Encode a code point using UTF-8 @@ -86,7 +80,12 @@ static enum fh_error w_type(struct fh_thread_s *fh, const struct fh_word_s *w) TRY(ds_pop(fh, &count)); TRY(ds_pop(fh, &addr)); - FHPRINT("%.*s", count, fh_str_at(fh, addr)); + const char *str = fh_str_at(fh, addr); + if (!str) { + LOGE("Type addr out of bounds!"); + return FH_ERR_NOT_APPLICABLE; + } + FHPRINT("%.*s", count, str); return FH_OK; } @@ -161,7 +160,8 @@ static enum fh_error w_s_quote(struct fh_thread_s *fh, const struct fh_word_s *w TRY(ds_push(fh, len)); } else { LOG("Compile a string: \"%.*s\"", len, start); - instr_init(&instr, FH_INSTR_ALLOCSTR, len); + instr.kind = FH_INSTR_ALLOCSTR; + instr.data = len; fh_heap_write(fh, addr - INSTR_SIZE, &instr, INSTR_SIZE); } diff --git a/src/fh_error.c b/src/fh_error.c index 7cbd3b2..db67bf8 100644 --- a/src/fh_error.c +++ b/src/fh_error.c @@ -1,4 +1,4 @@ -#include "fh_error.h" +#include "forth_internal.h" /** Error names */ static const char *errornames[FH_ERR_MAX] = { @@ -18,7 +18,7 @@ static const char *errornames[FH_ERR_MAX] = { [FH_ERR_UNKNOWN_WORD] = "UNKNOWN_WORD", [FH_ERR_ILLEGAL_FETCH] = "ILLEGAL_FETCH", [FH_ERR_ILLEGAL_STORE] = "ILLEGAL_STORE", - [FH_ERR_DIV_BY_ZERO] = "DIV_BY_ZERO", + [FH_ERR_ARITH] = "ARITHMETIC_ERROR", [FH_ERR_SYNTAX] = "SYNTAX_ERROR", [FH_ERR_NOT_APPLICABLE] = "NOT_APPLICABLE", }; diff --git a/src/fh_mem.c b/src/fh_mem.c index 3f08d66..66a924c 100644 --- a/src/fh_mem.c +++ b/src/fh_mem.c @@ -1,10 +1,4 @@ -#include -#include - -#include "fh_print.h" -#include "fh_error.h" -#include "fh_runtime.h" -#include "fh_mem.h" +#include "forth_internal.h" // Important distinction: HEAP_END is the end of the normally addressable region. HEAP_SIZE is the full memory area. // Buffers are placed at the end of the heap! @@ -41,6 +35,11 @@ enum fh_error fh_fetch(struct fh_thread_s *fh, uint32_t addr, uint32_t *dst) LOG("Fetch here %d", *dst); break; + case MAGICADDR_STATE: + *dst = TOBOOL(fh->state==FH_STATE_COMPILE); + LOG("Fetch state %d", *dst); + break; + case MAGICADDR_INPTR: *dst = fh->inputptr; LOG("Fetch >IN %d", *dst); @@ -86,6 +85,10 @@ enum fh_error fh_store(struct fh_thread_s *fh, uint32_t addr, uint32_t val) LOGE("HERE is read-only!"); return FH_ERR_ILLEGAL_STORE; + case MAGICADDR_STATE: + LOGE("STATE is read-only!"); + return FH_ERR_ILLEGAL_STORE; + case MAGICADDR_INPTR: LOG("set >IN %d", val); fh->inputptr = val; @@ -138,10 +141,8 @@ enum fh_error fh_heap_reserve( *addr = p; } - // Erase the region. This is out of abundance of caution, not really needed if it was erased initially. Maybe. - memset(&fh->heap[p], 0, len); - - fh->here = WORDALIGNED(p + len); + fh->here = p + len; + //fh->here = WORDALIGNED(p + len); return FH_OK; } @@ -158,6 +159,8 @@ void fh_heap_write(struct fh_thread_s *fh, uint32_t addr, const void *src, uint3 } enum fh_error fh_put_instr(struct fh_thread_s *fh, enum fh_instruction_kind kind, uint32_t data) { + fh_align(fh); + struct fh_instruction_s instr = { .kind = kind, .data = data, @@ -192,6 +195,7 @@ void fh_heap_copyptr(struct fh_thread_s *fh, uint32_t addr, char * source, uint3 char *fh_str_at(struct fh_thread_s *fh, uint32_t addr) { if (addr >= HEAP_SIZE) { LOGE("fh_str_at out of bounds!"); + return NULL; } return (char *) &fh->heap[addr]; } @@ -199,6 +203,7 @@ char *fh_str_at(struct fh_thread_s *fh, uint32_t addr) { struct fh_instruction_s *fh_instr_at(struct fh_thread_s *fh, uint32_t addr) { if (addr >= HEAP_END) { LOGE("fh_instr_at out of bounds!"); + return NULL; } return (void *) &fh->heap[addr]; } @@ -206,6 +211,7 @@ struct fh_instruction_s *fh_instr_at(struct fh_thread_s *fh, uint32_t addr) { struct fh_word_s *fh_word_at(struct fh_thread_s *fh, uint32_t addr) { if (addr >= HEAP_END) { LOGE("fh_word_at out of bounds!"); + return NULL; } return (struct fh_word_s *) &fh->heap[addr]; } diff --git a/src/fh_parse.c b/src/fh_parse.c index fb59b3d..21fe7e5 100644 --- a/src/fh_parse.c +++ b/src/fh_parse.c @@ -1,10 +1,65 @@ -#include -#include -#include -#include "fh_print.h" -#include "fh_runtime.h" -#include "fh_error.h" -#include "fh_parse.h" +#include "forth_internal.h" + +/** True if the character is CR or LF */ +static inline bool isnl(char c) +{ + return c == '\n' || c == '\r'; +} + +/** Process a word read from input */ +enum fh_error fh_handle_ascii_word( + struct fh_thread_s *fh, + const char *name, + const size_t wordlen +) +{ + enum fh_error rv; + if (wordlen >= MAX_NAME_LEN) { + return FH_ERR_NAME_TOO_LONG; + } + + /* First, try if it's a known word */ + + uint32_t wadr = 0; + if (FH_OK == fh_find_word(fh, name, wordlen, &wadr)) { + TRY(fh_handle_word(fh, wadr)); + return FH_OK; + } + + /* word not found, try parsing as number */ + errno = 0; + char *endptr; + int base = (int) fh->base; + + // prefix can override BASE - this is a syntax extension + if (name[0] == '0') { + if (name[1] == 'x') { + base = 16; + } else if (name[1] == 'b') { + base = 2; + } else if (name[1] == 'o') { + base = 8; + } + } + + long v = strtol(name, &endptr, base); // XXX if base is 0, this will use auto-detection + if (errno != 0 || (endptr - name) != wordlen) { + LOGE("Unknown word and fail to parse as number: \"%.*s\"", (int) wordlen, name); + return FH_ERR_UNKNOWN_WORD; + } + + if (fh->state == FH_STATE_COMPILE) { + LOG("\x1b[34m[COM] Compile number:\x1b[m %ld", v); + TRY(fh_put_instr(fh, FH_INSTR_NUMBER, (uint32_t) v)); + } else { + /* interpret */ + LOG("\x1b[35m[INT] Push number:\x1b[m %ld", v); + TRY(ds_push(fh, (uint32_t) v)); + } + + return FH_OK; +} + void fh_input_consume_matching(struct fh_thread_s *fh, chartest_t test, void* param) { char *rp = (char *) &fh->heap[INPUTBUF_ADDR + fh->inputptr]; @@ -141,3 +196,126 @@ enum fh_error fh_input_read_quotedstring(struct fh_thread_s *fh, bool escaped, c LOGE("String too long!"); return FH_ERR_SYNTAX; } + +/** Process a line read from input */ +enum fh_error fh_process_line(struct fh_thread_s *fh, const char *linebuf, size_t len) +{ + enum fh_error rv; + +#define ReadPtr ((char*)(&fh->heap[INPUTBUF_ADDR + fh->inputptr])) +#define ReadPos (fh->inputptr) +#define ReadLen (fh->inputlen) + + fh_fill_input_buffer(fh, linebuf, len); + + char c; + + if (fh_globals.echo && !fh_globals.interactive) { + LOGI("%s", linebuf); + } + + while (ReadPos < ReadLen && fh->state != FH_STATE_SHUTDOWN) { + c = *ReadPtr; + /* end on newline */ + if (isnl(c)) { + goto done; + } + /* skip whitespace */ + if (isspace(c)) { + ReadPos++; + continue; + } + + const char * const rp = ReadPtr; + + char *end; + size_t length; + switch (fh->substate) { + case FH_SUBSTATE_NONE: + /* try to read a word */ + end = strchr(rp, ' '); + if (end) { + length = end - rp; /* exclude the space */ + } else { + length = strlen(rp); + } + + ReadPos += length + 1; + + if (EQ(rp, "[if]", length)) { + if (0 == fh->parse_if_level) { + uint32_t val; + TRY(ds_pop(fh, &val)); + if (!val) { + LOG("\x1b[32m[if] false, start skipping\x1b[m"); + fh->parse_if_level++; + } else { + LOG("\x1b[32m[if] true, proceed\x1b[m"); + } + } else { + LOG("\x1b[32m[if] nest+\x1b[m"); + fh->parse_if_level++; + } + } else if (EQ(rp, "[else]", length)) { + if (fh->parse_if_level == 1) { + // we got here by running the [if] branch + LOG("\x1b[32m[else] end of false skip\x1b[m"); + fh->parse_if_level--; + } + } else if (EQ(rp, "[then]", length)) { + if (fh->parse_if_level > 0) { + fh->parse_if_level--; + if (fh->parse_if_level == 0) { + LOG("\x1b[32m[then] end of skipped section\x1b[m"); + } else { + LOG("\x1b[32m[then] nest-\x1b[m"); + } + } else { + LOG("\x1b[32m[then] end of conditional\x1b[m"); + } + } else if (fh->parse_if_level == 0) { + /* eval a word */ + //LOG("Handle \"%.*s\"", (int) length, rp); + TRY(fh_handle_ascii_word(fh, rp, length)); + } else { + if (EQ(rp, "\\", length)) { + // discard to EOL + LOG("Discard \"%.*s\"", fh->inputlen - fh->inputptr + length, rp); + goto done; + } + + LOG("Discard \"%.*s\"", length, rp); + } + + if (!end) { + goto done; + } + break; + + case FH_SUBSTATE_PAREN_COMMENT: + end = strchr(rp, ')'); + if (end) { + length = end - rp; + LOG("Discard inline comment: \"%.*s\"", length, rp); + fh_setsubstate(fh, FH_SUBSTATE_NONE); + ReadPos += length + 1; + } else { + /* no end, discard all */ + LOGE("Unterminated parenthesis comment"); + goto done; + } + break; + + case FH_SUBSTATE_LINE_COMMENT: + LOG("Discard line comment: \"%.*s\"", fh->inputlen - fh->inputptr, rp); + fh_setsubstate(fh, 0); + goto done; // just discard the rest + + default: + LOGE("Bad substate %s", substatenames[fh->substate]); + } + } + done: + //LOG("Line done."); + return FH_OK; +} diff --git a/src/fh_runtime.c b/src/fh_runtime.c index c6e65fe..c58f364 100644 --- a/src/fh_runtime.c +++ b/src/fh_runtime.c @@ -1,14 +1,4 @@ -#include -#include -#include - -#include "fh_error.h" -#include "fh_runtime.h" -#include "fh_builtins.h" -#include "fh_stack.h" -#include "fh_mem.h" -#include "fh_globals.h" -#include "fh_print.h" +#include "forth_internal.h" struct fh_global_s fh_globals = {}; @@ -29,11 +19,12 @@ static const char *stateshort[FH_STATE_MAX] = { }; /** Sub-state names */ -static const char *substatenames[FH_SUBSTATE_MAX] = { +const char *substatenames[FH_SUBSTATE_MAX] = { [FH_SUBSTATE_NONE] = "NONE", [FH_SUBSTATE_PAREN_COMMENT] = "PAREN_COMMENT", [FH_SUBSTATE_LINE_COMMENT] = "LINE_COMMENT", [FH_SUBSTATE_EXIT] = "EXIT", + [FH_SUBSTATE_SKIP_IF] = "SKIP_IF", }; /** Sub-state names */ @@ -76,7 +67,9 @@ enum fh_error fh_add_word(const struct fh_word_s *w, struct fh_thread_s *fh) //LOG("Added word \"%s\" at 0x%08x", w->name, ptr); // thread it onto the linked list - fh_word_at(fh, ptr)->previous = fh->dict_last; + struct fh_word_s *word = fh_word_at(fh, ptr); + if (!word) return FH_ERR_INTERNAL; + word->previous = fh->dict_last; fh->dict_last = ptr; return FH_OK; @@ -132,6 +125,10 @@ enum fh_error w_user_word(struct fh_thread_s *fh, const struct fh_word_s *w0) // make sure it's aligned fh->execptr = WORDALIGNED(fh->execptr); const struct fh_instruction_s *instr = fh_instr_at(fh, fh->execptr); + if (!instr) { + LOGE("Execution pointer out of bounds!"); + return FH_ERR_INTERNAL; + } fh->execptr += INSTR_SIZE; uint32_t strl; @@ -145,8 +142,12 @@ enum fh_error w_user_word(struct fh_thread_s *fh, const struct fh_word_s *w0) goto instr; case FH_INSTR_POSTPONED_WORD: - if (fh->state == FH_STATE_COMPILE) { + //if (fh->state == FH_STATE_COMPILE) { w2 = fh_word_at(fh, instr->data); + if (!w2) { + LOGE("Postponed bad word addr!"); + return FH_ERR_INTERNAL; + } if (w2->flags & WORDFLAG_IMMEDIATE) { LOG("Call immediate postponed word: %s", w2->name); TRY(w2->handler(fh, w2)); @@ -154,17 +155,21 @@ enum fh_error w_user_word(struct fh_thread_s *fh, const struct fh_word_s *w0) LOG("Add postponed word: %s", w2->name); TRY(fh_put_instr(fh, FH_INSTR_WORD, instr->data)); } - } else { + /*} else { LOGE("Postpone in interpret mode!"); goto end; - } + }*/ goto instr; case FH_INSTR_WORD: w2 = fh_word_at(fh, instr->data); + if (!w2) { + LOGE("Instr bad word addr!"); + return FH_ERR_INTERNAL; + } if (w2->flags & WORDFLAG_BUILTIN) { LOG("Exec: native-word \"%s\"", w2->name); - w2->handler(fh, w2); + TRY(w2->handler(fh, w2)); if (fh->substate == FH_SUBSTATE_EXIT) { fh_setsubstate(fh, 0); LOG("Exec: early return"); @@ -177,6 +182,10 @@ enum fh_error w_user_word(struct fh_thread_s *fh, const struct fh_word_s *w0) } else { LOG("Exec: user-word %s (CALL)", w2->name); w = fh_word_at(fh, instr->data); + if (!w) { + LOGE("CALL instr bad word addr!"); + return FH_ERR_INTERNAL; + } goto call; } @@ -203,6 +212,10 @@ enum fh_error w_user_word(struct fh_thread_s *fh, const struct fh_word_s *w0) case FH_INSTR_TO: TRY(ds_pop(fh, &val)); w2 = fh_word_at(fh, instr->data); + if (!w2) { + LOGE("TO instr bad variable addr!"); + return FH_ERR_INTERNAL; + } LOG("Exec: %d->%s", val, w2->name); if (w2->flags & WORDFLAG_CONSTANT) { @@ -255,7 +268,8 @@ enum fh_error w_user_word(struct fh_thread_s *fh, const struct fh_word_s *w0) LOG("after add: %d", fh->loop_i); - if (((int32_t)index0 < (int32_t)limit) == ((int32_t)fh->loop_i < (int32_t)limit)) { // boundary not crossed, continue + // FIXME this is probably wrong + if (((int32_t)index0 < (int32_t)limit) == ((int32_t)fh->loop_i < (int32_t)limit) && fh->loop_i != limit) { // boundary not crossed, continue fh->execptr = instr->data; // go to beginning } else { // end of loop @@ -290,7 +304,7 @@ enum fh_error w_user_word(struct fh_thread_s *fh, const struct fh_word_s *w0) goto instr; case FH_INSTR_ENDWORD: - LOG("Exec: word-end (RETURN)"); + LOG("Exec: word-end"); TRY(rs_pop(fh, &fh->execptr)); if (fh->execptr == MAGICADDR_EXEC_INTERACTIVE) { goto end; @@ -323,6 +337,7 @@ enum fh_error fh_handle_word(struct fh_thread_s *fh, uint32_t addr) { enum fh_error rv; struct fh_word_s *w = fh_word_at(fh, addr); + if (!w) return FH_ERR_INTERNAL; if (fh->state == FH_STATE_COMPILE && 0 == (w->flags & WORDFLAG_IMMEDIATE)) { LOG("\x1b[34m[%s] Compile word:\x1b[m %s", stateshort[fh->state], w->name); TRY(fh_put_instr(fh, FH_INSTR_WORD, addr)); @@ -341,12 +356,18 @@ enum fh_error fh_handle_word(struct fh_thread_s *fh, uint32_t addr) enum fh_error fh_find_word(struct fh_thread_s *fh, const char *name, size_t wordlen, uint32_t *addr_out) { + if (name == NULL) { + return FH_ERR_UNKNOWN_WORD; + } if (wordlen == 0) { wordlen = strlen(name); } uint32_t addr = fh->dict_last; while (addr != MAGICADDR_DICTFIRST) { struct fh_word_s *w = fh_word_at(fh, addr); + if (!w) { + break; + } if (0 == strncasecmp(name, w->name, wordlen) && w->name[wordlen] == 0) { if (addr_out) { *addr_out = addr; @@ -377,61 +398,6 @@ enum fh_error fh_loop_unnest(struct fh_thread_s *fh) return FH_OK; } -/** Process a word read from input */ -static enum fh_error fh_handle_ascii_word( - struct fh_thread_s *fh, - const char *name, - const size_t wordlen -) -{ - enum fh_error rv; - if (wordlen >= MAX_NAME_LEN) { - return FH_ERR_NAME_TOO_LONG; - } - - /* First, try if it's a known word */ - - uint32_t wadr = 0; - if (FH_OK == fh_find_word(fh, name, wordlen, &wadr)) { - TRY(fh_handle_word(fh, wadr)); - return FH_OK; - } - - /* word not found, try parsing as number */ - errno = 0; - char *endptr; - int base = (int) fh->base; - - // prefix can override BASE - this is a syntax extension - if (name[0] == '0') { - if (name[1] == 'x') { - base = 16; - } else if (name[1] == 'b') { - base = 2; - } else if (name[1] == 'o') { - base = 8; - } - } - - long v = strtol(name, &endptr, base); // XXX if base is 0, this will use auto-detection - if (errno != 0 || (endptr - name) != wordlen) { - LOGE("Unknown word and fail to parse as number: \"%.*s\"", (int) wordlen, name); - return FH_ERR_UNKNOWN_WORD; - } - - struct fh_instruction_s instr; - if (fh->state == FH_STATE_COMPILE) { - LOG("Compile number: %ld", v); - TRY(fh_put_instr(fh, FH_INSTR_NUMBER, (uint32_t) v)); - } else { - /* interpret */ - LOG("Interpret number: %ld", v); - TRY(ds_push(fh, (uint32_t) v)); - } - - return FH_OK; -} - /** Postpone a word */ enum fh_error fh_postpone_word( @@ -449,91 +415,3 @@ enum fh_error fh_postpone_word( return FH_OK; } - -/** True if the character is CR or LF */ -static inline bool isnl(char c) -{ - return c == '\n' || c == '\r'; -} - -/** Process a line read from input */ -enum fh_error fh_process_line(struct fh_thread_s *fh, const char *linebuf, size_t len) -{ - enum fh_error rv; - -#define ReadPtr ((char*)(&fh->heap[INPUTBUF_ADDR + fh->inputptr])) -#define ReadPos (fh->inputptr) -#define ReadLen (fh->inputlen) - - fh_fill_input_buffer(fh, linebuf, len); - - char c; - - if (fh_globals.echo && !fh_globals.interactive) { - LOGI("%s", linebuf); - } - - while (ReadPos < ReadLen && fh->state != FH_STATE_SHUTDOWN) { - c = *ReadPtr; - /* end on newline */ - if (isnl(c)) { - goto done; - } - /* skip whitespace */ - if (isspace(c)) { - ReadPos++; - continue; - } - - const char * const rp = ReadPtr; - - char *end; - size_t length; - switch (fh->substate) { - case FH_SUBSTATE_NONE: - /* try to read a word */ - end = strchr(rp, ' '); - if (end) { - length = end - rp; /* exclude the space */ - } else { - length = strlen(rp); - } - - ReadPos += length + 1; - - /* eval a word */ - //LOG("Handle \"%.*s\"", (int) length, rp); - TRY(fh_handle_ascii_word(fh, rp, length)); - - if (!end) { - goto done; - } - break; - - case FH_SUBSTATE_PAREN_COMMENT: - end = strchr(rp, ')'); - if (end) { - length = end - rp; - LOG("Discard inline comment"); - fh_setsubstate(fh, FH_SUBSTATE_NONE); - ReadPos += length + 1; - } else { - /* no end, discard all */ - LOGE("Unterminated parenthesis comment"); - goto done; - } - break; - - case FH_SUBSTATE_LINE_COMMENT: - LOG("Discard line comment"); - fh_setsubstate(fh, 0); - goto done; // just discard the rest - - default: - LOGE("Bad substate %s", substatenames[fh->substate]); - } - } - done: - LOG("Line done."); - return FH_OK; -} diff --git a/src/fh_see.c b/src/fh_see.c index 12792cd..562c416 100644 --- a/src/fh_see.c +++ b/src/fh_see.c @@ -1,20 +1,26 @@ -#include "forth.h" -#include "fh_runtime.h" -#include "fh_mem.h" -#include "fh_print.h" +#include "forth_internal.h" static void show_word(struct fh_thread_s *fh, const struct fh_word_s *w) { + if (!w) { + LOGE("NULL!"); + return; + } if (w->flags & WORDFLAG_WORD) { if (w->handler == w_user_word) { uint32_t execptr = w->param; - FHPRINT("Compiled word %s%s\n", w->name, (w->flags&WORDFLAG_IMMEDIATE) ? " IMMEDIATE" : ""); + FHPRINT("Compiled word %s%s\n", w->name, (w->flags & WORDFLAG_IMMEDIATE) ? " IMMEDIATE" : ""); while (1) { // make sure it's aligned execptr = WORDALIGNED(execptr); FHPRINT("0x%08x: ", execptr); const struct fh_instruction_s *instr = fh_instr_at(fh, execptr); + if (!instr) { + LOGE("Word pointer out of bounds!"); + return; + } + execptr += INSTR_SIZE; uint32_t strl; @@ -26,24 +32,36 @@ static void show_word(struct fh_thread_s *fh, const struct fh_word_s *w) case FH_INSTR_WORD: w2 = fh_word_at(fh, instr->data); - FHPRINT("Call(word %s)\n", w2->name); + if (w2) { + FHPRINT("Call(word %s)\n", w2->name); + } else { + FHPRINT("Call(BAD ADDRESS!!! 0x%08x)\n", instr->data); + } break; case FH_INSTR_POSTPONED_WORD: w2 = fh_word_at(fh, instr->data); - if (w2->name[0]) { - FHPRINT("Postpone(word %s)\n", w2->name); + if (w2) { + if (w2->name[0]) { + FHPRINT("Postpone(word %s)\n", w2->name); + } else { + FHPRINT("Postpone(word 0x%08x)\n", instr->data); + } } else { - FHPRINT("Postpone(word 0x%08x)\n", instr->data); + FHPRINT("Postpone(BAD ADDRESS!!! 0x%08x)\n", instr->data); } break; case FH_INSTR_TO: w2 = fh_word_at(fh, instr->data); - if (w2->name[0]) { - FHPRINT("To(var %s)\n", w2->name); + if (w2) { + if (w2->name[0]) { + FHPRINT("To(var %s)\n", w2->name); + } else { + FHPRINT("To(var 0x%08x)\n", instr->data); + } } else { - FHPRINT("To(var 0x%08x)\n", instr->data); + FHPRINT("To(BAD ADDRESS!!! 0x%08x)\n", instr->data); } break; @@ -96,13 +114,13 @@ static void show_word(struct fh_thread_s *fh, const struct fh_word_s *w) FHPRINT("Built-in word %s\n", w->name); }; } else if (w->flags & WORDFLAG_VARIABLE) { - FHPRINT("Variable %s, value %d (0x%08x)\n", w->name, (int32_t)w->param, w->param); + FHPRINT("Variable %s, value %d (0x%08x)\n", w->name, (int32_t) w->param, w->param); } else if (w->flags & WORDFLAG_CONSTANT) { - FHPRINT("Constant %s, value %d (0x%08x)\n", w->name, (int32_t)w->param, w->param); + FHPRINT("Constant %s, value %d (0x%08x)\n", w->name, (int32_t) w->param, w->param); } else if (w->flags & WORDFLAG_CREATED) { - FHPRINT("CREATE'd entry %s, param %d (0x%08x)\n", w->name, (int32_t)w->param, w->param); + FHPRINT("CREATE'd entry %s, param %d (0x%08x)\n", w->name, (int32_t) w->param, w->param); } else { - FHPRINT("Unknown entry %s, param %d (0x%08x)\n", w->name, (int32_t)w->param, w->param); + FHPRINT("Unknown entry %s, param %d (0x%08x)\n", w->name, (int32_t) w->param, w->param); } } diff --git a/src/fh_stack.c b/src/fh_stack.c index b373257..f43177a 100644 --- a/src/fh_stack.c +++ b/src/fh_stack.c @@ -1,8 +1,4 @@ -#include "fh_error.h" -#include "fh_config.h" -#include "fh_runtime.h" -#include "fh_stack.h" -#include "fh_print.h" +#include "forth_internal.h" // TODO stacks should grow down, not up! @@ -86,6 +82,24 @@ enum fh_error rs_pop(struct fh_thread_s *fh, uint32_t *out) } \ } while(0) +enum fh_error ds_push_dw(struct fh_thread_s *fh, uint64_t in) +{ + enum fh_error rv; + TRY(ds_push(fh, in & 0xFFFFFFFFULL)); + TRY(ds_push(fh, (in & 0xFFFFFFFF00000000ULL) >> 32)); + return FH_OK; +} + +enum fh_error ds_pop_dw(struct fh_thread_s *fh, uint64_t *out) +{ + enum fh_error rv; + uint32_t a, b; + TRY(ds_pop(fh, &a)); + TRY(ds_pop(fh, &b)); + *out = ((uint64_t)a << 32) | ((uint64_t)b); + return FH_OK; +} + /** Push to data stack */ enum fh_error ds_push(struct fh_thread_s *fh, uint32_t in) { diff --git a/src/main.c b/src/main.c index 62200ad..72c14d9 100644 --- a/src/main.c +++ b/src/main.c @@ -5,8 +5,6 @@ #include #include "forth.h" -#include "fh_runtime.h" -#include "fh_print.h" int main(int argc, char *argv[]) { @@ -70,7 +68,9 @@ int main(int argc, char *argv[]) /* process input line by line */ int linecnt = 0; char linebuf[MAXLINE]; - FHPRINT("%s", prompt); + if (fh_globals.interactive) { + FHPRINT("%s", prompt); + } while (fh.state != FH_STATE_SHUTDOWN && fgets(linebuf, MAXLINE, infile)) { linecnt++; diff --git a/testfiles/combinedtest.f b/testfiles/combinedtest.f new file mode 100644 index 0000000..769fcb9 --- /dev/null +++ b/testfiles/combinedtest.f @@ -0,0 +1,1845 @@ +\ From: John Hayes S1I +\ Subject: tester.fr +\ Date: Mon, 27 Nov 95 13:10:09 PST + +\ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY +\ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS. +\ VERSION 1.2 + +\ 24/11/2015 Replaced Core Ext word <> with = 0= +\ 31/3/2015 Variable #ERRORS added and incremented for each error reported. +\ 22/1/09 The words { and } have been changed to T{ and }T respectively to +\ agree with the Forth 200X file ttester.fs. This avoids clashes with +\ locals using { ... } and the FSL use of } + +HEX + +\ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY +\ ALLOW YOU TO TELL WHICH TEST CAUSED YOUR SYSTEM TO HANG. +VARIABLE VERBOSE +\ FALSE VERBOSE ! + TRUE VERBOSE ! + +: EMPTY-STACK \ ( ... -- ) EMPTY STACK: HANDLES UNDERFLOWED STACK TOO. + DEPTH ?DUP IF DUP 0< IF NEGATE 0 DO 0 LOOP ELSE 0 DO DROP LOOP THEN THEN ; + +VARIABLE #ERRORS 0 #ERRORS ! + +: ERROR \ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY + \ THE LINE THAT HAD THE ERROR. + CR TYPE SOURCE TYPE \ DISPLAY LINE CORRESPONDING TO ERROR + EMPTY-STACK \ THROW AWAY EVERY THING ELSE + #ERRORS @ 1 + #ERRORS ! +\ QUIT \ *** Uncomment this line to QUIT on an error +; + +VARIABLE ACTUAL-DEPTH \ STACK RECORD +CREATE ACTUAL-RESULTS 20 CELLS ALLOT + +: T{ \ ( -- ) SYNTACTIC SUGAR. + ; + +: -> \ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK. + DEPTH DUP ACTUAL-DEPTH ! \ RECORD DEPTH + ?DUP IF \ IF THERE IS SOMETHING ON STACK + 0 DO ACTUAL-RESULTS I CELLS + ! LOOP \ SAVE THEM + THEN ; + +: }T \ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED + \ (ACTUAL) CONTENTS. + DEPTH ACTUAL-DEPTH @ = IF \ IF DEPTHS MATCH + DEPTH ?DUP IF \ IF THERE IS SOMETHING ON THE STACK + 0 DO \ FOR EACH STACK ITEM + ACTUAL-RESULTS I CELLS + @ \ COMPARE ACTUAL WITH EXPECTED + = 0= IF S" INCORRECT RESULT: " ERROR LEAVE THEN + LOOP + THEN + ELSE \ DEPTH MISMATCH + S" WRONG NUMBER OF RESULTS: " ERROR + THEN ; + +: TESTING \ ( -- ) TALKING COMMENT. + SOURCE VERBOSE @ + IF DUP >R TYPE CR R> >IN ! + ELSE >IN ! DROP [CHAR] * EMIT + THEN ; + +\ From: John Hayes S1I +\ Subject: core.fr +\ Date: Mon, 27 Nov 95 13:10 + +\ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY +\ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS. +\ VERSION 1.2 +\ THIS PROGRAM TESTS THE CORE WORDS OF AN ANS FORTH SYSTEM. +\ THE PROGRAM ASSUMES A TWO'S COMPLEMENT IMPLEMENTATION WHERE +\ THE RANGE OF SIGNED NUMBERS IS -2^(N-1) ... 2^(N-1)-1 AND +\ THE RANGE OF UNSIGNED NUMBERS IS 0 ... 2^(N)-1. +\ I HAVEN'T FIGURED OUT HOW TO TEST KEY, QUIT, ABORT, OR ABORT"... +\ I ALSO HAVEN'T THOUGHT OF A WAY TO TEST ENVIRONMENT?... + +CR +TESTING CORE WORDS +HEX + +\ ------------------------------------------------------------------------ +TESTING BASIC ASSUMPTIONS + +T{ -> }T \ START WITH CLEAN SLATE +( TEST IF ANY BITS ARE SET; ANSWER IN BASE 1 ) +T{ : BITSSET? IF 0 0 ELSE 0 THEN ; -> }T +T{ 0 BITSSET? -> 0 }T ( ZERO IS ALL BITS CLEAR ) +T{ 1 BITSSET? -> 0 0 }T ( OTHER NUMBER HAVE AT LEAST ONE BIT ) +T{ -1 BITSSET? -> 0 0 }T + +\ ------------------------------------------------------------------------ +TESTING BOOLEANS: INVERT AND OR XOR + +T{ 0 0 AND -> 0 }T +T{ 0 1 AND -> 0 }T +T{ 1 0 AND -> 0 }T +T{ 1 1 AND -> 1 }T + +T{ 0 INVERT 1 AND -> 1 }T +T{ 1 INVERT 1 AND -> 0 }T + +0 CONSTANT 0S +0 INVERT CONSTANT 1S + +T{ 0S INVERT -> 1S }T +T{ 1S INVERT -> 0S }T + +T{ 0S 0S AND -> 0S }T +T{ 0S 1S AND -> 0S }T +T{ 1S 0S AND -> 0S }T +T{ 1S 1S AND -> 1S }T + +T{ 0S 0S OR -> 0S }T +T{ 0S 1S OR -> 1S }T +T{ 1S 0S OR -> 1S }T +T{ 1S 1S OR -> 1S }T + +T{ 0S 0S XOR -> 0S }T +T{ 0S 1S XOR -> 1S }T +T{ 1S 0S XOR -> 1S }T +T{ 1S 1S XOR -> 0S }T + +\ ------------------------------------------------------------------------ +TESTING 2* 2/ LSHIFT RSHIFT + +( WE TRUST 1S, INVERT, AND BITSSET?; WE WILL CONFIRM RSHIFT LATER ) +1S 1 RSHIFT INVERT CONSTANT MSB +T{ MSB BITSSET? -> 0 0 }T + +T{ 0S 2* -> 0S }T +T{ 1 2* -> 2 }T +T{ 4000 2* -> 8000 }T +T{ 1S 2* 1 XOR -> 1S }T +T{ MSB 2* -> 0S }T + +T{ 0S 2/ -> 0S }T +T{ 1 2/ -> 0 }T +T{ 4000 2/ -> 2000 }T +T{ 1S 2/ -> 1S }T \ MSB PROPOGATED +T{ 1S 1 XOR 2/ -> 1S }T +T{ MSB 2/ MSB AND -> MSB }T + +T{ 1 0 LSHIFT -> 1 }T +T{ 1 1 LSHIFT -> 2 }T +T{ 1 2 LSHIFT -> 4 }T +T{ 1 F LSHIFT -> 8000 }T \ BIGGEST GUARANTEED SHIFT +T{ 1S 1 LSHIFT 1 XOR -> 1S }T +T{ MSB 1 LSHIFT -> 0 }T + +T{ 1 0 RSHIFT -> 1 }T +T{ 1 1 RSHIFT -> 0 }T +T{ 2 1 RSHIFT -> 1 }T +T{ 4 2 RSHIFT -> 1 }T +T{ 8000 F RSHIFT -> 1 }T \ BIGGEST +T{ MSB 1 RSHIFT MSB AND -> 0 }T \ RSHIFT ZERO FILLS MSBS +T{ MSB 1 RSHIFT 2* -> MSB }T + +\ ------------------------------------------------------------------------ +TESTING COMPARISONS: 0= = 0< < > U< MIN MAX +0 INVERT CONSTANT MAX-UINT +0 INVERT 1 RSHIFT CONSTANT MAX-INT +0 INVERT 1 RSHIFT INVERT CONSTANT MIN-INT +0 INVERT 1 RSHIFT CONSTANT MID-UINT +0 INVERT 1 RSHIFT INVERT CONSTANT MID-UINT+1 + +0S CONSTANT +1S CONSTANT + +T{ 0 0= -> }T +T{ 1 0= -> }T +T{ 2 0= -> }T +T{ -1 0= -> }T +T{ MAX-UINT 0= -> }T +T{ MIN-INT 0= -> }T +T{ MAX-INT 0= -> }T + +T{ 0 0 = -> }T +T{ 1 1 = -> }T +T{ -1 -1 = -> }T +T{ 1 0 = -> }T +T{ -1 0 = -> }T +T{ 0 1 = -> }T +T{ 0 -1 = -> }T + +T{ 0 0< -> }T +T{ -1 0< -> }T +T{ MIN-INT 0< -> }T +T{ 1 0< -> }T +T{ MAX-INT 0< -> }T + +T{ 0 1 < -> }T +T{ 1 2 < -> }T +T{ -1 0 < -> }T +T{ -1 1 < -> }T +T{ MIN-INT 0 < -> }T +T{ MIN-INT MAX-INT < -> }T +T{ 0 MAX-INT < -> }T +T{ 0 0 < -> }T +T{ 1 1 < -> }T +T{ 1 0 < -> }T +T{ 2 1 < -> }T +T{ 0 -1 < -> }T +T{ 1 -1 < -> }T +T{ 0 MIN-INT < -> }T +T{ MAX-INT MIN-INT < -> }T +T{ MAX-INT 0 < -> }T + +T{ 0 1 > -> }T +T{ 1 2 > -> }T +T{ -1 0 > -> }T +T{ -1 1 > -> }T +T{ MIN-INT 0 > -> }T +T{ MIN-INT MAX-INT > -> }T +T{ 0 MAX-INT > -> }T +T{ 0 0 > -> }T +T{ 1 1 > -> }T +T{ 1 0 > -> }T +T{ 2 1 > -> }T +T{ 0 -1 > -> }T +T{ 1 -1 > -> }T +T{ 0 MIN-INT > -> }T +T{ MAX-INT MIN-INT > -> }T +T{ MAX-INT 0 > -> }T + +T{ 0 1 U< -> }T +T{ 1 2 U< -> }T +T{ 0 MID-UINT U< -> }T +T{ 0 MAX-UINT U< -> }T +T{ MID-UINT MAX-UINT U< -> }T +T{ 0 0 U< -> }T +T{ 1 1 U< -> }T +T{ 1 0 U< -> }T +T{ 2 1 U< -> }T +T{ MID-UINT 0 U< -> }T +T{ MAX-UINT 0 U< -> }T +T{ MAX-UINT MID-UINT U< -> }T + +T{ 0 1 MIN -> 0 }T +T{ 1 2 MIN -> 1 }T +T{ -1 0 MIN -> -1 }T +T{ -1 1 MIN -> -1 }T +T{ MIN-INT 0 MIN -> MIN-INT }T +T{ MIN-INT MAX-INT MIN -> MIN-INT }T +T{ 0 MAX-INT MIN -> 0 }T +T{ 0 0 MIN -> 0 }T +T{ 1 1 MIN -> 1 }T +T{ 1 0 MIN -> 0 }T +T{ 2 1 MIN -> 1 }T +T{ 0 -1 MIN -> -1 }T +T{ 1 -1 MIN -> -1 }T +T{ 0 MIN-INT MIN -> MIN-INT }T +T{ MAX-INT MIN-INT MIN -> MIN-INT }T +T{ MAX-INT 0 MIN -> 0 }T + +T{ 0 1 MAX -> 1 }T +T{ 1 2 MAX -> 2 }T +T{ -1 0 MAX -> 0 }T +T{ -1 1 MAX -> 1 }T +T{ MIN-INT 0 MAX -> 0 }T +T{ MIN-INT MAX-INT MAX -> MAX-INT }T +T{ 0 MAX-INT MAX -> MAX-INT }T +T{ 0 0 MAX -> 0 }T +T{ 1 1 MAX -> 1 }T +T{ 1 0 MAX -> 1 }T +T{ 2 1 MAX -> 2 }T +T{ 0 -1 MAX -> 0 }T +T{ 1 -1 MAX -> 1 }T +T{ 0 MIN-INT MAX -> 0 }T +T{ MAX-INT MIN-INT MAX -> MAX-INT }T +T{ MAX-INT 0 MAX -> MAX-INT }T + +\ ------------------------------------------------------------------------ +TESTING STACK OPS: 2DROP 2DUP 2OVER 2SWAP ?DUP DEPTH DROP DUP OVER ROT SWAP + +T{ 1 2 2DROP -> }T +T{ 1 2 2DUP -> 1 2 1 2 }T +T{ 1 2 3 4 2OVER -> 1 2 3 4 1 2 }T +T{ 1 2 3 4 2SWAP -> 3 4 1 2 }T +T{ 0 ?DUP -> 0 }T +T{ 1 ?DUP -> 1 1 }T +T{ -1 ?DUP -> -1 -1 }T +T{ DEPTH -> 0 }T +T{ 0 DEPTH -> 0 1 }T +T{ 0 1 DEPTH -> 0 1 2 }T +T{ 0 DROP -> }T +T{ 1 2 DROP -> 1 }T +T{ 1 DUP -> 1 1 }T +T{ 1 2 OVER -> 1 2 1 }T +T{ 1 2 3 ROT -> 2 3 1 }T +T{ 1 2 SWAP -> 2 1 }T + +\ ------------------------------------------------------------------------ +TESTING >R R> R@ + +T{ : GR1 >R R> ; -> }T +T{ : GR2 >R R@ R> DROP ; -> }T +T{ 123 GR1 -> 123 }T +T{ 123 GR2 -> 123 }T +T{ 1S GR1 -> 1S }T ( RETURN STACK HOLDS CELLS ) + +\ ------------------------------------------------------------------------ +TESTING ADD/SUBTRACT: + - 1+ 1- ABS NEGATE + +T{ 0 5 + -> 5 }T +T{ 5 0 + -> 5 }T +T{ 0 -5 + -> -5 }T +T{ -5 0 + -> -5 }T +T{ 1 2 + -> 3 }T +T{ 1 -2 + -> -1 }T +T{ -1 2 + -> 1 }T +T{ -1 -2 + -> -3 }T +T{ -1 1 + -> 0 }T +T{ MID-UINT 1 + -> MID-UINT+1 }T + +T{ 0 5 - -> -5 }T +T{ 5 0 - -> 5 }T +T{ 0 -5 - -> 5 }T +T{ -5 0 - -> -5 }T +T{ 1 2 - -> -1 }T +T{ 1 -2 - -> 3 }T +T{ -1 2 - -> -3 }T +T{ -1 -2 - -> 1 }T +T{ 0 1 - -> -1 }T +T{ MID-UINT+1 1 - -> MID-UINT }T + +T{ 0 1+ -> 1 }T +T{ -1 1+ -> 0 }T +T{ 1 1+ -> 2 }T +T{ MID-UINT 1+ -> MID-UINT+1 }T + +T{ 2 1- -> 1 }T +T{ 1 1- -> 0 }T +T{ 0 1- -> -1 }T +T{ MID-UINT+1 1- -> MID-UINT }T + +T{ 0 NEGATE -> 0 }T +T{ 1 NEGATE -> -1 }T +T{ -1 NEGATE -> 1 }T +T{ 2 NEGATE -> -2 }T +T{ -2 NEGATE -> 2 }T + +T{ 0 ABS -> 0 }T +T{ 1 ABS -> 1 }T +T{ -1 ABS -> 1 }T +T{ MIN-INT ABS -> MID-UINT+1 }T + +\ ------------------------------------------------------------------------ +TESTING MULTIPLY: S>D * M* UM* + +T{ 0 S>D -> 0 0 }T +T{ 1 S>D -> 1 0 }T +T{ 2 S>D -> 2 0 }T +T{ -1 S>D -> -1 -1 }T +T{ -2 S>D -> -2 -1 }T +T{ MIN-INT S>D -> MIN-INT -1 }T +T{ MAX-INT S>D -> MAX-INT 0 }T + +T{ 0 0 M* -> 0 S>D }T +T{ 0 1 M* -> 0 S>D }T +T{ 1 0 M* -> 0 S>D }T +T{ 1 2 M* -> 2 S>D }T +T{ 2 1 M* -> 2 S>D }T +T{ 3 3 M* -> 9 S>D }T +T{ -3 3 M* -> -9 S>D }T +T{ 3 -3 M* -> -9 S>D }T +T{ -3 -3 M* -> 9 S>D }T +T{ 0 MIN-INT M* -> 0 S>D }T +T{ 1 MIN-INT M* -> MIN-INT S>D }T +T{ 2 MIN-INT M* -> 0 1S }T +T{ 0 MAX-INT M* -> 0 S>D }T +T{ 1 MAX-INT M* -> MAX-INT S>D }T +T{ 2 MAX-INT M* -> MAX-INT 1 LSHIFT 0 }T +T{ MIN-INT MIN-INT M* -> 0 MSB 1 RSHIFT }T +T{ MAX-INT MIN-INT M* -> MSB MSB 2/ }T +T{ MAX-INT MAX-INT M* -> 1 MSB 2/ INVERT }T + +T{ 0 0 * -> 0 }T \ TEST IDENTITIES +T{ 0 1 * -> 0 }T +T{ 1 0 * -> 0 }T +T{ 1 2 * -> 2 }T +T{ 2 1 * -> 2 }T +T{ 3 3 * -> 9 }T +T{ -3 3 * -> -9 }T +T{ 3 -3 * -> -9 }T +T{ -3 -3 * -> 9 }T + +T{ MID-UINT+1 1 RSHIFT 2 * -> MID-UINT+1 }T +T{ MID-UINT+1 2 RSHIFT 4 * -> MID-UINT+1 }T +T{ MID-UINT+1 1 RSHIFT MID-UINT+1 OR 2 * -> MID-UINT+1 }T + +T{ 0 0 UM* -> 0 0 }T +T{ 0 1 UM* -> 0 0 }T +T{ 1 0 UM* -> 0 0 }T +T{ 1 2 UM* -> 2 0 }T +T{ 2 1 UM* -> 2 0 }T +T{ 3 3 UM* -> 9 0 }T + +T{ MID-UINT+1 1 RSHIFT 2 UM* -> MID-UINT+1 0 }T +T{ MID-UINT+1 2 UM* -> 0 1 }T +T{ MID-UINT+1 4 UM* -> 0 2 }T +T{ 1S 2 UM* -> 1S 1 LSHIFT 1 }T +T{ MAX-UINT MAX-UINT UM* -> 1 1 INVERT }T + +\ ------------------------------------------------------------------------ +TESTING DIVIDE: FM/MOD SM/REM UM/MOD */ */MOD / /MOD MOD + +T{ 0 S>D 1 FM/MOD -> 0 0 }T +T{ 1 S>D 1 FM/MOD -> 0 1 }T +T{ 2 S>D 1 FM/MOD -> 0 2 }T +T{ -1 S>D 1 FM/MOD -> 0 -1 }T +T{ -2 S>D 1 FM/MOD -> 0 -2 }T +T{ 0 S>D -1 FM/MOD -> 0 0 }T +T{ 1 S>D -1 FM/MOD -> 0 -1 }T +T{ 2 S>D -1 FM/MOD -> 0 -2 }T +T{ -1 S>D -1 FM/MOD -> 0 1 }T +T{ -2 S>D -1 FM/MOD -> 0 2 }T +T{ 2 S>D 2 FM/MOD -> 0 1 }T +T{ -1 S>D -1 FM/MOD -> 0 1 }T +T{ -2 S>D -2 FM/MOD -> 0 1 }T +T{ 7 S>D 3 FM/MOD -> 1 2 }T +T{ 7 S>D -3 FM/MOD -> -2 -3 }T +T{ -7 S>D 3 FM/MOD -> 2 -3 }T +T{ -7 S>D -3 FM/MOD -> -1 2 }T +T{ MAX-INT S>D 1 FM/MOD -> 0 MAX-INT }T +T{ MIN-INT S>D 1 FM/MOD -> 0 MIN-INT }T +T{ MAX-INT S>D MAX-INT FM/MOD -> 0 1 }T +T{ MIN-INT S>D MIN-INT FM/MOD -> 0 1 }T +T{ 1S 1 4 FM/MOD -> 3 MAX-INT }T +T{ 1 MIN-INT M* 1 FM/MOD -> 0 MIN-INT }T +T{ 1 MIN-INT M* MIN-INT FM/MOD -> 0 1 }T +T{ 2 MIN-INT M* 2 FM/MOD -> 0 MIN-INT }T +T{ 2 MIN-INT M* MIN-INT FM/MOD -> 0 2 }T +T{ 1 MAX-INT M* 1 FM/MOD -> 0 MAX-INT }T +T{ 1 MAX-INT M* MAX-INT FM/MOD -> 0 1 }T +T{ 2 MAX-INT M* 2 FM/MOD -> 0 MAX-INT }T +T{ 2 MAX-INT M* MAX-INT FM/MOD -> 0 2 }T +T{ MIN-INT MIN-INT M* MIN-INT FM/MOD -> 0 MIN-INT }T +T{ MIN-INT MAX-INT M* MIN-INT FM/MOD -> 0 MAX-INT }T +T{ MIN-INT MAX-INT M* MAX-INT FM/MOD -> 0 MIN-INT }T +T{ MAX-INT MAX-INT M* MAX-INT FM/MOD -> 0 MAX-INT }T + +T{ 0 S>D 1 SM/REM -> 0 0 }T +T{ 1 S>D 1 SM/REM -> 0 1 }T +T{ 2 S>D 1 SM/REM -> 0 2 }T +T{ -1 S>D 1 SM/REM -> 0 -1 }T +T{ -2 S>D 1 SM/REM -> 0 -2 }T +T{ 0 S>D -1 SM/REM -> 0 0 }T +T{ 1 S>D -1 SM/REM -> 0 -1 }T +T{ 2 S>D -1 SM/REM -> 0 -2 }T +T{ -1 S>D -1 SM/REM -> 0 1 }T +T{ -2 S>D -1 SM/REM -> 0 2 }T +T{ 2 S>D 2 SM/REM -> 0 1 }T +T{ -1 S>D -1 SM/REM -> 0 1 }T +T{ -2 S>D -2 SM/REM -> 0 1 }T +T{ 7 S>D 3 SM/REM -> 1 2 }T +T{ 7 S>D -3 SM/REM -> 1 -2 }T +T{ -7 S>D 3 SM/REM -> -1 -2 }T +T{ -7 S>D -3 SM/REM -> -1 2 }T +T{ MAX-INT S>D 1 SM/REM -> 0 MAX-INT }T +T{ MIN-INT S>D 1 SM/REM -> 0 MIN-INT }T +T{ MAX-INT S>D MAX-INT SM/REM -> 0 1 }T +T{ MIN-INT S>D MIN-INT SM/REM -> 0 1 }T +T{ 1S 1 4 SM/REM -> 3 MAX-INT }T +T{ 2 MIN-INT M* 2 SM/REM -> 0 MIN-INT }T +T{ 2 MIN-INT M* MIN-INT SM/REM -> 0 2 }T +T{ 2 MAX-INT M* 2 SM/REM -> 0 MAX-INT }T +T{ 2 MAX-INT M* MAX-INT SM/REM -> 0 2 }T +T{ MIN-INT MIN-INT M* MIN-INT SM/REM -> 0 MIN-INT }T +T{ MIN-INT MAX-INT M* MIN-INT SM/REM -> 0 MAX-INT }T +T{ MIN-INT MAX-INT M* MAX-INT SM/REM -> 0 MIN-INT }T +T{ MAX-INT MAX-INT M* MAX-INT SM/REM -> 0 MAX-INT }T + +T{ 0 0 1 UM/MOD -> 0 0 }T +T{ 1 0 1 UM/MOD -> 0 1 }T +T{ 1 0 2 UM/MOD -> 1 0 }T +T{ 3 0 2 UM/MOD -> 1 1 }T +T{ MAX-UINT 2 UM* 2 UM/MOD -> 0 MAX-UINT }T +T{ MAX-UINT 2 UM* MAX-UINT UM/MOD -> 0 2 }T +T{ MAX-UINT MAX-UINT UM* MAX-UINT UM/MOD -> 0 MAX-UINT }T + +: IFFLOORED + [ -3 2 / -2 = INVERT ] LITERAL IF POSTPONE \ THEN ; + +: IFSYM + [ -3 2 / -1 = INVERT ] LITERAL IF POSTPONE \ THEN ; + +\ THE SYSTEM MIGHT DO EITHER FLOORED OR SYMMETRIC DIVISION. +\ SINCE WE HAVE ALREADY TESTED M*, FM/MOD, AND SM/REM WE CAN USE THEM IN TEST. + +IFFLOORED : T/MOD >R S>D R> FM/MOD ; +IFFLOORED : T/ T/MOD SWAP DROP ; +IFFLOORED : TMOD T/MOD DROP ; +IFFLOORED : T*/MOD >R M* R> FM/MOD ; +IFFLOORED : T*/ T*/MOD SWAP DROP ; +IFSYM : T/MOD >R S>D R> SM/REM ; +IFSYM : T/ T/MOD SWAP DROP ; +IFSYM : TMOD T/MOD DROP ; +IFSYM : T*/MOD >R M* R> SM/REM ; +IFSYM : T*/ T*/MOD SWAP DROP ; + +T{ 0 1 /MOD -> 0 1 T/MOD }T +T{ 1 1 /MOD -> 1 1 T/MOD }T +T{ 2 1 /MOD -> 2 1 T/MOD }T +T{ -1 1 /MOD -> -1 1 T/MOD }T +T{ -2 1 /MOD -> -2 1 T/MOD }T +T{ 0 -1 /MOD -> 0 -1 T/MOD }T +T{ 1 -1 /MOD -> 1 -1 T/MOD }T +T{ 2 -1 /MOD -> 2 -1 T/MOD }T +T{ -1 -1 /MOD -> -1 -1 T/MOD }T +T{ -2 -1 /MOD -> -2 -1 T/MOD }T +T{ 2 2 /MOD -> 2 2 T/MOD }T +T{ -1 -1 /MOD -> -1 -1 T/MOD }T +T{ -2 -2 /MOD -> -2 -2 T/MOD }T +T{ 7 3 /MOD -> 7 3 T/MOD }T +T{ 7 -3 /MOD -> 7 -3 T/MOD }T +T{ -7 3 /MOD -> -7 3 T/MOD }T +T{ -7 -3 /MOD -> -7 -3 T/MOD }T +T{ MAX-INT 1 /MOD -> MAX-INT 1 T/MOD }T +T{ MIN-INT 1 /MOD -> MIN-INT 1 T/MOD }T +T{ MAX-INT MAX-INT /MOD -> MAX-INT MAX-INT T/MOD }T +T{ MIN-INT MIN-INT /MOD -> MIN-INT MIN-INT T/MOD }T + +T{ 0 1 / -> 0 1 T/ }T +T{ 1 1 / -> 1 1 T/ }T +T{ 2 1 / -> 2 1 T/ }T +T{ -1 1 / -> -1 1 T/ }T +T{ -2 1 / -> -2 1 T/ }T +T{ 0 -1 / -> 0 -1 T/ }T +T{ 1 -1 / -> 1 -1 T/ }T +T{ 2 -1 / -> 2 -1 T/ }T +T{ -1 -1 / -> -1 -1 T/ }T +T{ -2 -1 / -> -2 -1 T/ }T +T{ 2 2 / -> 2 2 T/ }T +T{ -1 -1 / -> -1 -1 T/ }T +T{ -2 -2 / -> -2 -2 T/ }T +T{ 7 3 / -> 7 3 T/ }T +T{ 7 -3 / -> 7 -3 T/ }T +T{ -7 3 / -> -7 3 T/ }T +T{ -7 -3 / -> -7 -3 T/ }T +T{ MAX-INT 1 / -> MAX-INT 1 T/ }T +T{ MIN-INT 1 / -> MIN-INT 1 T/ }T +T{ MAX-INT MAX-INT / -> MAX-INT MAX-INT T/ }T +T{ MIN-INT MIN-INT / -> MIN-INT MIN-INT T/ }T + +T{ 0 1 MOD -> 0 1 TMOD }T +T{ 1 1 MOD -> 1 1 TMOD }T +T{ 2 1 MOD -> 2 1 TMOD }T +T{ -1 1 MOD -> -1 1 TMOD }T +T{ -2 1 MOD -> -2 1 TMOD }T +T{ 0 -1 MOD -> 0 -1 TMOD }T +T{ 1 -1 MOD -> 1 -1 TMOD }T +T{ 2 -1 MOD -> 2 -1 TMOD }T +T{ -1 -1 MOD -> -1 -1 TMOD }T +T{ -2 -1 MOD -> -2 -1 TMOD }T +T{ 2 2 MOD -> 2 2 TMOD }T +T{ -1 -1 MOD -> -1 -1 TMOD }T +T{ -2 -2 MOD -> -2 -2 TMOD }T +T{ 7 3 MOD -> 7 3 TMOD }T +T{ 7 -3 MOD -> 7 -3 TMOD }T +T{ -7 3 MOD -> -7 3 TMOD }T +T{ -7 -3 MOD -> -7 -3 TMOD }T +T{ MAX-INT 1 MOD -> MAX-INT 1 TMOD }T +T{ MIN-INT 1 MOD -> MIN-INT 1 TMOD }T +T{ MAX-INT MAX-INT MOD -> MAX-INT MAX-INT TMOD }T +T{ MIN-INT MIN-INT MOD -> MIN-INT MIN-INT TMOD }T + +T{ 0 2 1 */ -> 0 2 1 T*/ }T +T{ 1 2 1 */ -> 1 2 1 T*/ }T +T{ 2 2 1 */ -> 2 2 1 T*/ }T +T{ -1 2 1 */ -> -1 2 1 T*/ }T +T{ -2 2 1 */ -> -2 2 1 T*/ }T +T{ 0 2 -1 */ -> 0 2 -1 T*/ }T +T{ 1 2 -1 */ -> 1 2 -1 T*/ }T +T{ 2 2 -1 */ -> 2 2 -1 T*/ }T +T{ -1 2 -1 */ -> -1 2 -1 T*/ }T +T{ -2 2 -1 */ -> -2 2 -1 T*/ }T +T{ 2 2 2 */ -> 2 2 2 T*/ }T +T{ -1 2 -1 */ -> -1 2 -1 T*/ }T +T{ -2 2 -2 */ -> -2 2 -2 T*/ }T +T{ 7 2 3 */ -> 7 2 3 T*/ }T +T{ 7 2 -3 */ -> 7 2 -3 T*/ }T +T{ -7 2 3 */ -> -7 2 3 T*/ }T +T{ -7 2 -3 */ -> -7 2 -3 T*/ }T +T{ MAX-INT 2 MAX-INT */ -> MAX-INT 2 MAX-INT T*/ }T +T{ MIN-INT 2 MIN-INT */ -> MIN-INT 2 MIN-INT T*/ }T + +T{ 0 2 1 */MOD -> 0 2 1 T*/MOD }T +T{ 1 2 1 */MOD -> 1 2 1 T*/MOD }T +T{ 2 2 1 */MOD -> 2 2 1 T*/MOD }T +T{ -1 2 1 */MOD -> -1 2 1 T*/MOD }T +T{ -2 2 1 */MOD -> -2 2 1 T*/MOD }T +T{ 0 2 -1 */MOD -> 0 2 -1 T*/MOD }T +T{ 1 2 -1 */MOD -> 1 2 -1 T*/MOD }T +T{ 2 2 -1 */MOD -> 2 2 -1 T*/MOD }T +T{ -1 2 -1 */MOD -> -1 2 -1 T*/MOD }T +T{ -2 2 -1 */MOD -> -2 2 -1 T*/MOD }T +T{ 2 2 2 */MOD -> 2 2 2 T*/MOD }T +T{ -1 2 -1 */MOD -> -1 2 -1 T*/MOD }T +T{ -2 2 -2 */MOD -> -2 2 -2 T*/MOD }T +T{ 7 2 3 */MOD -> 7 2 3 T*/MOD }T +T{ 7 2 -3 */MOD -> 7 2 -3 T*/MOD }T +T{ -7 2 3 */MOD -> -7 2 3 T*/MOD }T +T{ -7 2 -3 */MOD -> -7 2 -3 T*/MOD }T +T{ MAX-INT 2 MAX-INT */MOD -> MAX-INT 2 MAX-INT T*/MOD }T +T{ MIN-INT 2 MIN-INT */MOD -> MIN-INT 2 MIN-INT T*/MOD }T + +\ ------------------------------------------------------------------------ +TESTING HERE , @ ! CELL+ CELLS C, C@ C! CHARS 2@ 2! ALIGN ALIGNED +! ALLOT + +HERE 1 ALLOT +HERE +CONSTANT 2NDA +CONSTANT 1STA +T{ 1STA 2NDA U< -> }T \ HERE MUST GROW WITH ALLOT +T{ 1STA 1+ -> 2NDA }T \ ... BY ONE ADDRESS UNIT +( MISSING TEST: NEGATIVE ALLOT ) + +\ Added by GWJ so that ALIGN can be used before , (comma) is tested +1 ALIGNED CONSTANT ALMNT \ -- 1|2|4|8 for 8|16|32|64 bit alignment +ALIGN +T{ HERE 1 ALLOT ALIGN HERE SWAP - ALMNT = -> }T +\ End of extra test + +HERE 1 , +HERE 2 , +CONSTANT 2ND +CONSTANT 1ST +T{ 1ST 2ND U< -> }T \ HERE MUST GROW WITH ALLOT +T{ 1ST CELL+ -> 2ND }T \ ... BY ONE CELL +T{ 1ST 1 CELLS + -> 2ND }T +T{ 1ST @ 2ND @ -> 1 2 }T +T{ 5 1ST ! -> }T +T{ 1ST @ 2ND @ -> 5 2 }T +T{ 6 2ND ! -> }T +T{ 1ST @ 2ND @ -> 5 6 }T +T{ 1ST 2@ -> 6 5 }T +T{ 2 1 1ST 2! -> }T +T{ 1ST 2@ -> 2 1 }T +T{ 1S 1ST ! 1ST @ -> 1S }T \ CAN STORE CELL-WIDE VALUE + +HERE 1 C, +HERE 2 C, +CONSTANT 2NDC +CONSTANT 1STC +T{ 1STC 2NDC U< -> }T \ HERE MUST GROW WITH ALLOT +T{ 1STC CHAR+ -> 2NDC }T \ ... BY ONE CHAR +T{ 1STC 1 CHARS + -> 2NDC }T +T{ 1STC C@ 2NDC C@ -> 1 2 }T +T{ 3 1STC C! -> }T +T{ 1STC C@ 2NDC C@ -> 3 2 }T +T{ 4 2NDC C! -> }T +T{ 1STC C@ 2NDC C@ -> 3 4 }T + +ALIGN 1 ALLOT HERE ALIGN HERE 3 CELLS ALLOT +CONSTANT A-ADDR CONSTANT UA-ADDR +T{ UA-ADDR ALIGNED -> A-ADDR }T +T{ 1 A-ADDR C! A-ADDR C@ -> 1 }T +T{ 1234 A-ADDR ! A-ADDR @ -> 1234 }T +T{ 123 456 A-ADDR 2! A-ADDR 2@ -> 123 456 }T +T{ 2 A-ADDR CHAR+ C! A-ADDR CHAR+ C@ -> 2 }T +T{ 3 A-ADDR CELL+ C! A-ADDR CELL+ C@ -> 3 }T +T{ 1234 A-ADDR CELL+ ! A-ADDR CELL+ @ -> 1234 }T +T{ 123 456 A-ADDR CELL+ 2! A-ADDR CELL+ 2@ -> 123 456 }T + +: BITS ( X -- U ) + 0 SWAP BEGIN DUP WHILE DUP MSB AND IF >R 1+ R> THEN 2* REPEAT DROP ; +( CHARACTERS >= 1 AU, <= SIZE OF CELL, >= 8 BITS ) +T{ 1 CHARS 1 < -> }T +T{ 1 CHARS 1 CELLS > -> }T +( TBD: HOW TO FIND NUMBER OF BITS? ) + +( CELLS >= 1 AU, INTEGRAL MULTIPLE OF CHAR SIZE, >= 16 BITS ) +T{ 1 CELLS 1 < -> }T +T{ 1 CELLS 1 CHARS MOD -> 0 }T +T{ 1S BITS 10 < -> }T + +T{ 0 1ST ! -> }T +T{ 1 1ST +! -> }T +T{ 1ST @ -> 1 }T +T{ -1 1ST +! 1ST @ -> 0 }T + +\ ------------------------------------------------------------------------ +TESTING CHAR [CHAR] [ ] BL S" + +T{ BL -> 20 }T +T{ CHAR X -> 58 }T +T{ CHAR HELLO -> 48 }T +T{ : GC1 [CHAR] X ; -> }T +T{ : GC2 [CHAR] HELLO ; -> }T +T{ GC1 -> 58 }T +T{ GC2 -> 48 }T +T{ : GC3 [ GC1 ] LITERAL ; -> }T +T{ GC3 -> 58 }T +T{ : GC4 S" XY" ; -> }T +T{ GC4 SWAP DROP -> 2 }T +T{ GC4 DROP DUP C@ SWAP CHAR+ C@ -> 58 59 }T + +\ ------------------------------------------------------------------------ +TESTING ' ['] FIND EXECUTE IMMEDIATE COUNT LITERAL POSTPONE STATE + +T{ : GT1 123 ; -> }T +T{ ' GT1 EXECUTE -> 123 }T +T{ : GT2 ['] GT1 ; IMMEDIATE -> }T +T{ GT2 EXECUTE -> 123 }T +HERE 3 C, CHAR G C, CHAR T C, CHAR 1 C, CONSTANT GT1STRING +HERE 3 C, CHAR G C, CHAR T C, CHAR 2 C, CONSTANT GT2STRING +T{ GT1STRING FIND -> ' GT1 -1 }T +T{ GT2STRING FIND -> ' GT2 1 }T +( HOW TO SEARCH FOR NON-EXISTENT WORD? ) +T{ : GT3 GT2 LITERAL ; -> }T +T{ GT3 -> ' GT1 }T +T{ GT1STRING COUNT -> GT1STRING CHAR+ 3 }T + +T{ : GT4 POSTPONE GT1 ; IMMEDIATE -> }T +T{ : GT5 GT4 ; -> }T +T{ GT5 -> 123 }T +T{ : GT6 345 ; IMMEDIATE -> }T +T{ : GT7 POSTPONE GT6 ; -> }T +T{ GT7 -> 345 }T + +T{ : GT8 STATE @ ; IMMEDIATE -> }T +T{ GT8 -> 0 }T +T{ : GT9 GT8 LITERAL ; -> }T +T{ GT9 0= -> }T + +\ ------------------------------------------------------------------------ +TESTING IF ELSE THEN BEGIN WHILE REPEAT UNTIL RECURSE + +T{ : GI1 IF 123 THEN ; -> }T +T{ : GI2 IF 123 ELSE 234 THEN ; -> }T +T{ 0 GI1 -> }T +T{ 1 GI1 -> 123 }T +T{ -1 GI1 -> 123 }T +T{ 0 GI2 -> 234 }T +T{ 1 GI2 -> 123 }T +T{ -1 GI1 -> 123 }T + +T{ : GI3 BEGIN DUP 5 < WHILE DUP 1+ REPEAT ; -> }T +T{ 0 GI3 -> 0 1 2 3 4 5 }T +T{ 4 GI3 -> 4 5 }T +T{ 5 GI3 -> 5 }T +T{ 6 GI3 -> 6 }T + +T{ : GI4 BEGIN DUP 1+ DUP 5 > UNTIL ; -> }T +T{ 3 GI4 -> 3 4 5 6 }T +T{ 5 GI4 -> 5 6 }T +T{ 6 GI4 -> 6 7 }T + +T{ : GI5 BEGIN DUP 2 > + WHILE DUP 5 < WHILE DUP 1+ REPEAT 123 ELSE 345 THEN ; -> }T +T{ 1 GI5 -> 1 345 }T +T{ 2 GI5 -> 2 345 }T +T{ 3 GI5 -> 3 4 5 123 }T +T{ 4 GI5 -> 4 5 123 }T +T{ 5 GI5 -> 5 123 }T + +T{ : GI6 ( N -- 0,1,..N ) DUP IF DUP >R 1- RECURSE R> THEN ; -> }T +T{ 0 GI6 -> 0 }T +T{ 1 GI6 -> 0 1 }T +T{ 2 GI6 -> 0 1 2 }T +T{ 3 GI6 -> 0 1 2 3 }T +T{ 4 GI6 -> 0 1 2 3 4 }T + +\ ------------------------------------------------------------------------ +TESTING DO LOOP +LOOP I J UNLOOP LEAVE EXIT + +T{ : GD1 DO I LOOP ; -> }T +T{ 4 1 GD1 -> 1 2 3 }T +T{ 2 -1 GD1 -> -1 0 1 }T +T{ MID-UINT+1 MID-UINT GD1 -> MID-UINT }T + +T{ : GD2 DO I -1 +LOOP ; -> }T +T{ 1 4 GD2 -> 4 3 2 1 }T +T{ -1 2 GD2 -> 2 1 0 -1 }T +T{ MID-UINT MID-UINT+1 GD2 -> MID-UINT+1 MID-UINT }T + +T{ : GD3 DO 1 0 DO J LOOP LOOP ; -> }T +T{ 4 1 GD3 -> 1 2 3 }T +T{ 2 -1 GD3 -> -1 0 1 }T +T{ MID-UINT+1 MID-UINT GD3 -> MID-UINT }T + +T{ : GD4 DO 1 0 DO J LOOP -1 +LOOP ; -> }T +T{ 1 4 GD4 -> 4 3 2 1 }T +T{ -1 2 GD4 -> 2 1 0 -1 }T +T{ MID-UINT MID-UINT+1 GD4 -> MID-UINT+1 MID-UINT }T + +T{ : GD5 123 SWAP 0 DO I 4 > IF DROP 234 LEAVE THEN LOOP ; -> }T +T{ 1 GD5 -> 123 }T +T{ 5 GD5 -> 123 }T +T{ 6 GD5 -> 234 }T + +T{ : GD6 ( PAT: T{0 0},{0 0}{1 0}{1 1},{0 0}{1 0}{1 1}{2 0}{2 1}{2 2} ) + 0 SWAP 0 DO + I 1+ 0 DO I J + 3 = IF I UNLOOP I UNLOOP EXIT THEN 1+ LOOP + LOOP ; -> }T +T{ 1 GD6 -> 1 }T +T{ 2 GD6 -> 3 }T +T{ 3 GD6 -> 4 1 2 }T + +\ ------------------------------------------------------------------------ +TESTING DEFINING WORDS: : ; CONSTANT VARIABLE CREATE DOES> >BODY + +T{ 123 CONSTANT X123 -> }T +T{ X123 -> 123 }T +T{ : EQU CONSTANT ; -> }T +T{ X123 EQU Y123 -> }T +T{ Y123 -> 123 }T + +T{ VARIABLE V1 -> }T +T{ 123 V1 ! -> }T +T{ V1 @ -> 123 }T + +T{ : NOP : POSTPONE ; ; -> }T +T{ NOP NOP1 NOP NOP2 -> }T +T{ NOP1 -> }T +T{ NOP2 -> }T + +T{ : DOES1 DOES> @ 1 + ; -> }T +T{ : DOES2 DOES> @ 2 + ; -> }T +T{ CREATE CR1 -> }T +T{ CR1 -> HERE }T +T{ ' CR1 >BODY -> HERE }T +T{ 1 , -> }T +T{ CR1 @ -> 1 }T +T{ DOES1 -> }T +T{ CR1 -> 2 }T +T{ DOES2 -> }T +T{ CR1 -> 3 }T + +T{ : WEIRD: CREATE DOES> 1 + DOES> 2 + ; -> }T +T{ WEIRD: W1 -> }T +T{ ' W1 >BODY -> HERE }T +T{ W1 -> HERE 1 + }T +T{ W1 -> HERE 2 + }T + +\ ------------------------------------------------------------------------ +TESTING EVALUATE + +: GE1 S" 123" ; IMMEDIATE +: GE2 S" 123 1+" ; IMMEDIATE +: GE3 S" : GE4 345 ;" ; +: GE5 EVALUATE ; IMMEDIATE + +T{ GE1 EVALUATE -> 123 }T ( TEST EVALUATE IN INTERP. STATE ) +T{ GE2 EVALUATE -> 124 }T +T{ GE3 EVALUATE -> }T +T{ GE4 -> 345 }T + +T{ : GE6 GE1 GE5 ; -> }T ( TEST EVALUATE IN COMPILE STATE ) +T{ GE6 -> 123 }T +T{ : GE7 GE2 GE5 ; -> }T +T{ GE7 -> 124 }T + +\ ------------------------------------------------------------------------ +TESTING SOURCE >IN WORD + +: GS1 S" SOURCE" 2DUP EVALUATE + >R SWAP >R = R> R> = ; +T{ GS1 -> }T + +VARIABLE SCANS +: RESCAN? -1 SCANS +! SCANS @ IF 0 >IN ! THEN ; + +T{ 2 SCANS ! +345 RESCAN? +-> 345 345 }T + +: GS2 5 SCANS ! S" 123 RESCAN?" EVALUATE ; +T{ GS2 -> 123 123 123 123 123 }T + +: GS3 WORD COUNT SWAP C@ ; +T{ BL GS3 HELLO -> 5 CHAR H }T +T{ CHAR " GS3 GOODBYE" -> 7 CHAR G }T +T{ BL GS3 +DROP -> 0 }T \ BLANK LINE RETURN ZERO-LENGTH STRING + +: GS4 SOURCE >IN ! DROP ; +T{ GS4 123 456 +-> }T + +\ ------------------------------------------------------------------------ +TESTING <# # #S #> HOLD SIGN BASE >NUMBER HEX DECIMAL + +: S= \ ( ADDR1 C1 ADDR2 C2 -- T/F ) COMPARE TWO STRINGS. + >R SWAP R@ = IF \ MAKE SURE STRINGS HAVE SAME LENGTH + R> ?DUP IF \ IF NON-EMPTY STRINGS + 0 DO + OVER C@ OVER C@ - IF 2DROP UNLOOP EXIT THEN + SWAP CHAR+ SWAP CHAR+ + LOOP + THEN + 2DROP \ IF WE GET HERE, STRINGS MATCH + ELSE + R> DROP 2DROP \ LENGTHS MISMATCH + THEN ; + +: GP1 <# 41 HOLD 42 HOLD 0 0 #> S" BA" S= ; +T{ GP1 -> }T + +: GP2 <# -1 SIGN 0 SIGN -1 SIGN 0 0 #> S" --" S= ; +T{ GP2 -> }T + +: GP3 <# 1 0 # # #> S" 01" S= ; +T{ GP3 -> }T + +: GP4 <# 1 0 #S #> S" 1" S= ; +T{ GP4 -> }T + +24 CONSTANT MAX-BASE \ BASE 2 .. 36 +: COUNT-BITS + 0 0 INVERT BEGIN DUP WHILE >R 1+ R> 2* REPEAT DROP ; +COUNT-BITS 2* CONSTANT #BITS-UD \ NUMBER OF BITS IN UD + +: GP5 + BASE @ + MAX-BASE 1+ 2 DO \ FOR EACH POSSIBLE BASE + I BASE ! \ TBD: ASSUMES BASE WORKS + I 0 <# #S #> S" 10" S= AND + LOOP + SWAP BASE ! ; +T{ GP5 -> }T + +: GP6 + BASE @ >R 2 BASE ! + MAX-UINT MAX-UINT <# #S #> \ MAXIMUM UD TO BINARY + R> BASE ! \ S: C-ADDR U + DUP #BITS-UD = SWAP + 0 DO \ S: C-ADDR FLAG + OVER C@ [CHAR] 1 = AND \ ALL ONES + >R CHAR+ R> + LOOP SWAP DROP ; +T{ GP6 -> }T + +: GP7 + BASE @ >R MAX-BASE BASE ! + + A 0 DO + I 0 <# #S #> + 1 = SWAP C@ I 30 + = AND AND + LOOP + MAX-BASE A DO + I 0 <# #S #> + 1 = SWAP C@ 41 I A - + = AND AND + LOOP + R> BASE ! ; + +T{ GP7 -> }T + +\ >NUMBER TESTS +CREATE GN-BUF 0 C, +: GN-STRING GN-BUF 1 ; +: GN-CONSUMED GN-BUF CHAR+ 0 ; +: GN' [CHAR] ' WORD CHAR+ C@ GN-BUF C! GN-STRING ; + +T{ 0 0 GN' 0' >NUMBER -> 0 0 GN-CONSUMED }T +T{ 0 0 GN' 1' >NUMBER -> 1 0 GN-CONSUMED }T +T{ 1 0 GN' 1' >NUMBER -> BASE @ 1+ 0 GN-CONSUMED }T +T{ 0 0 GN' -' >NUMBER -> 0 0 GN-STRING }T \ SHOULD FAIL TO CONVERT THESE +T{ 0 0 GN' +' >NUMBER -> 0 0 GN-STRING }T +T{ 0 0 GN' .' >NUMBER -> 0 0 GN-STRING }T + +: >NUMBER-BASED + BASE @ >R BASE ! >NUMBER R> BASE ! ; + +T{ 0 0 GN' 2' 10 >NUMBER-BASED -> 2 0 GN-CONSUMED }T +T{ 0 0 GN' 2' 2 >NUMBER-BASED -> 0 0 GN-STRING }T +T{ 0 0 GN' F' 10 >NUMBER-BASED -> F 0 GN-CONSUMED }T +T{ 0 0 GN' G' 10 >NUMBER-BASED -> 0 0 GN-STRING }T +T{ 0 0 GN' G' MAX-BASE >NUMBER-BASED -> 10 0 GN-CONSUMED }T +T{ 0 0 GN' Z' MAX-BASE >NUMBER-BASED -> 23 0 GN-CONSUMED }T + +: GN1 \ ( UD BASE -- UD' LEN ) UD SHOULD EQUAL UD' AND LEN SHOULD BE ZERO. + BASE @ >R BASE ! + <# #S #> + 0 0 2SWAP >NUMBER SWAP DROP \ RETURN LENGTH ONLY + R> BASE ! ; +T{ 0 0 2 GN1 -> 0 0 0 }T +T{ MAX-UINT 0 2 GN1 -> MAX-UINT 0 0 }T +T{ MAX-UINT DUP 2 GN1 -> MAX-UINT DUP 0 }T +T{ 0 0 MAX-BASE GN1 -> 0 0 0 }T +T{ MAX-UINT 0 MAX-BASE GN1 -> MAX-UINT 0 0 }T +T{ MAX-UINT DUP MAX-BASE GN1 -> MAX-UINT DUP 0 }T + +: GN2 \ ( -- 16 10 ) + BASE @ >R HEX BASE @ DECIMAL BASE @ R> BASE ! ; +T{ GN2 -> 10 A }T + +\ ------------------------------------------------------------------------ +TESTING FILL MOVE + +CREATE FBUF 00 C, 00 C, 00 C, +CREATE SBUF 12 C, 34 C, 56 C, +: SEEBUF FBUF C@ FBUF CHAR+ C@ FBUF CHAR+ CHAR+ C@ ; + +T{ FBUF 0 20 FILL -> }T +T{ SEEBUF -> 00 00 00 }T + +T{ FBUF 1 20 FILL -> }T +T{ SEEBUF -> 20 00 00 }T + +T{ FBUF 3 20 FILL -> }T +T{ SEEBUF -> 20 20 20 }T + +T{ FBUF FBUF 3 CHARS MOVE -> }T \ BIZARRE SPECIAL CASE +T{ SEEBUF -> 20 20 20 }T + +T{ SBUF FBUF 0 CHARS MOVE -> }T +T{ SEEBUF -> 20 20 20 }T + +T{ SBUF FBUF 1 CHARS MOVE -> }T +T{ SEEBUF -> 12 20 20 }T + +T{ SBUF FBUF 3 CHARS MOVE -> }T +T{ SEEBUF -> 12 34 56 }T + +T{ FBUF FBUF CHAR+ 2 CHARS MOVE -> }T +T{ SEEBUF -> 12 12 34 }T + +T{ FBUF CHAR+ FBUF 2 CHARS MOVE -> }T +T{ SEEBUF -> 12 34 34 }T + +\ ------------------------------------------------------------------------ +TESTING OUTPUT: . ." CR EMIT SPACE SPACES TYPE U. + +: OUTPUT-TEST + ." YOU SHOULD SEE THE STANDARD GRAPHIC CHARACTERS:" CR + 41 BL DO I EMIT LOOP CR + 61 41 DO I EMIT LOOP CR + 7F 61 DO I EMIT LOOP CR + ." YOU SHOULD SEE 0-9 SEPARATED BY A SPACE:" CR + 9 1+ 0 DO I . LOOP CR + ." YOU SHOULD SEE 0-9 (WITH NO SPACES):" CR + [CHAR] 9 1+ [CHAR] 0 DO I 0 SPACES EMIT LOOP CR + ." YOU SHOULD SEE A-G SEPARATED BY A SPACE:" CR + [CHAR] G 1+ [CHAR] A DO I EMIT SPACE LOOP CR + ." YOU SHOULD SEE 0-5 SEPARATED BY TWO SPACES:" CR + 5 1+ 0 DO I [CHAR] 0 + EMIT 2 SPACES LOOP CR + ." YOU SHOULD SEE TWO SEPARATE LINES:" CR + S" LINE 1" TYPE CR S" LINE 2" TYPE CR + ." YOU SHOULD SEE THE NUMBER RANGES OF SIGNED AND UNSIGNED NUMBERS:" CR + ." SIGNED: " MIN-INT . MAX-INT . CR + ." UNSIGNED: " 0 U. MAX-UINT U. CR +; + +T{ OUTPUT-TEST -> }T + + +\ ------------------------------------------------------------------------ +TESTING INPUT: ACCEPT + +CREATE ABUF 50 CHARS ALLOT + +: ACCEPT-TEST + CR ." PLEASE TYPE UP TO 80 CHARACTERS:" CR + ABUF 50 ACCEPT + CR ." RECEIVED: " [CHAR] " EMIT + ABUF SWAP TYPE [CHAR] " EMIT CR +; + +T{ ACCEPT-TEST -> }T + +\ ------------------------------------------------------------------------ +TESTING DICTIONARY SEARCH RULES + +T{ : GDX 123 ; : GDX GDX 234 ; -> }T + +T{ GDX -> 123 234 }T + +CR .( End of Core word set tests) CR + + +\ To test the ANS Forth Core Extension word set + +\ This program was written by Gerry Jackson in 2006, with contributions from +\ others where indicated, and is in the public domain - it can be distributed +\ and/or modified in any way but please retain this notice. + +\ This program is distributed in the hope that it will be useful, +\ but WITHOUT ANY WARRANTY; without even the implied warranty of +\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +\ The tests are not claimed to be comprehensive or correct + +\ ------------------------------------------------------------------------------ +\ Version 0.13 28 October 2015 +\ Replace and with FALSE and TRUE to avoid +\ dependence on Core tests +\ Moved SAVE-INPUT and RESTORE-INPUT tests in a file to filetest.fth +\ Use of 2VARIABLE (from optional wordset) replaced with CREATE. +\ Minor lower to upper case conversions. +\ Calls to COMPARE replaced by S= (in utilities.fth) to avoid use +\ of a word from an optional word set. +\ UNUSED tests revised as UNUSED UNUSED = may return FALSE when an +\ implementation has the data stack sharing unused dataspace. +\ Double number input dependency removed from the HOLDS tests. +\ Minor case sensitivities removed in definition names. +\ 0.11 25 April 2015 +\ Added tests for PARSE-NAME HOLDS BUFFER: +\ S\" tests added +\ DEFER IS ACTION-OF DEFER! DEFER@ tests added +\ Empty CASE statement test added +\ [COMPILE] tests removed because it is obsolescent in Forth 2012 +\ 0.10 1 August 2014 +\ Added tests contributed by James Bowman for: +\ <> U> 0<> 0> NIP TUCK ROLL PICK 2>R 2R@ 2R> +\ HEX WITHIN UNUSED AGAIN MARKER +\ Added tests for: +\ .R U.R ERASE PAD REFILL SOURCE-ID +\ Removed ABORT from NeverExecuted to enable Win32 +\ to continue after failure of RESTORE-INPUT. +\ Removed max-intx which is no longer used. +\ 0.7 6 June 2012 Extra CASE test added +\ 0.6 1 April 2012 Tests placed in the public domain. +\ SAVE-INPUT & RESTORE-INPUT tests, position +\ of T{ moved so that tests work with ttester.fs +\ CONVERT test deleted - obsolete word removed from Forth 200X +\ IMMEDIATE VALUEs tested +\ RECURSE with :NONAME tested +\ PARSE and .( tested +\ Parsing behaviour of C" added +\ 0.5 14 September 2011 Removed the double [ELSE] from the +\ initial SAVE-INPUT & RESTORE-INPUT test +\ 0.4 30 November 2009 max-int replaced with max-intx to +\ avoid redefinition warnings. +\ 0.3 6 March 2009 { and } replaced with T{ and }T +\ CONVERT test now independent of cell size +\ 0.2 20 April 2007 ANS Forth words changed to upper case +\ Tests qd3 to qd6 by Reinhold Straub +\ 0.1 Oct 2006 First version released +\ ----------------------------------------------------------------------------- +\ The tests are based on John Hayes test program for the core word set + +\ Words tested in this file are: +\ .( .R 0<> 0> 2>R 2R> 2R@ :NONAME <> ?DO AGAIN C" CASE COMPILE, ENDCASE +\ ENDOF ERASE FALSE HEX MARKER NIP OF PAD PARSE PICK REFILL +\ RESTORE-INPUT ROLL SAVE-INPUT SOURCE-ID TO TRUE TUCK U.R U> UNUSED +\ VALUE WITHIN [COMPILE] + +\ Words not tested or partially tested: +\ \ because it has been extensively used already and is, hence, unnecessary +\ REFILL and SOURCE-ID from the user input device which are not possible +\ when testing from a file such as this one +\ UNUSED (partially tested) as the value returned is system dependent +\ Obsolescent words #TIB CONVERT EXPECT QUERY SPAN TIB as they have been +\ removed from the Forth 2012 standard + +\ Results from words that output to the user output device have to visually +\ checked for correctness. These are .R U.R .( + +\ ----------------------------------------------------------------------------- +\ Assumptions & dependencies: +\ - tester.fr (or ttester.fs), errorreport.fth and utilities.fth have been +\ included prior to this file +\ - the Core word set available +\ ----------------------------------------------------------------------------- +TESTING Core Extension words + +DECIMAL + +TESTING TRUE FALSE + +T{ TRUE -> 0 INVERT }T +T{ FALSE -> 0 }T + +\ ----------------------------------------------------------------------------- +TESTING <> U> (contributed by James Bowman) + +T{ 0 0 <> -> FALSE }T +T{ 1 1 <> -> FALSE }T +T{ -1 -1 <> -> FALSE }T +T{ 1 0 <> -> TRUE }T +T{ -1 0 <> -> TRUE }T +T{ 0 1 <> -> TRUE }T +T{ 0 -1 <> -> TRUE }T + +T{ 0 1 U> -> FALSE }T +T{ 1 2 U> -> FALSE }T +T{ 0 MID-UINT U> -> FALSE }T +T{ 0 MAX-UINT U> -> FALSE }T +T{ MID-UINT MAX-UINT U> -> FALSE }T +T{ 0 0 U> -> FALSE }T +T{ 1 1 U> -> FALSE }T +T{ 1 0 U> -> TRUE }T +T{ 2 1 U> -> TRUE }T +T{ MID-UINT 0 U> -> TRUE }T +T{ MAX-UINT 0 U> -> TRUE }T +T{ MAX-UINT MID-UINT U> -> TRUE }T + +\ ----------------------------------------------------------------------------- +TESTING 0<> 0> (contributed by James Bowman) + +T{ 0 0<> -> FALSE }T +T{ 1 0<> -> TRUE }T +T{ 2 0<> -> TRUE }T +T{ -1 0<> -> TRUE }T +T{ MAX-UINT 0<> -> TRUE }T +T{ MIN-INT 0<> -> TRUE }T +T{ MAX-INT 0<> -> TRUE }T + +T{ 0 0> -> FALSE }T +T{ -1 0> -> FALSE }T +T{ MIN-INT 0> -> FALSE }T +T{ 1 0> -> TRUE }T +T{ MAX-INT 0> -> TRUE }T + +\ ----------------------------------------------------------------------------- +TESTING NIP TUCK ROLL PICK (contributed by James Bowman) + +T{ 1 2 NIP -> 2 }T +T{ 1 2 3 NIP -> 1 3 }T + +T{ 1 2 TUCK -> 2 1 2 }T +T{ 1 2 3 TUCK -> 1 3 2 3 }T + +T{ : RO5 100 200 300 400 500 ; -> }T +T{ RO5 3 ROLL -> 100 300 400 500 200 }T +T{ RO5 2 ROLL -> RO5 ROT }T +T{ RO5 1 ROLL -> RO5 SWAP }T +T{ RO5 0 ROLL -> RO5 }T + +T{ RO5 2 PICK -> 100 200 300 400 500 300 }T +T{ RO5 1 PICK -> RO5 OVER }T +T{ RO5 0 PICK -> RO5 DUP }T + +\ ----------------------------------------------------------------------------- +TESTING 2>R 2R@ 2R> (contributed by James Bowman) + +T{ : RR0 2>R 100 R> R> ; -> }T +T{ 300 400 RR0 -> 100 400 300 }T +T{ 200 300 400 RR0 -> 200 100 400 300 }T + +T{ : RR1 2>R 100 2R@ R> R> ; -> }T +T{ 300 400 RR1 -> 100 300 400 400 300 }T +T{ 200 300 400 RR1 -> 200 100 300 400 400 300 }T + +T{ : RR2 2>R 100 2R> ; -> }T +T{ 300 400 RR2 -> 100 300 400 }T +T{ 200 300 400 RR2 -> 200 100 300 400 }T + +\ ----------------------------------------------------------------------------- +TESTING HEX (contributed by James Bowman) + +T{ BASE @ HEX BASE @ DECIMAL BASE @ - SWAP BASE ! -> 6 }T + +\ ----------------------------------------------------------------------------- +TESTING WITHIN (contributed by James Bowman) + +T{ 0 0 0 WITHIN -> FALSE }T +T{ 0 0 MID-UINT WITHIN -> TRUE }T +T{ 0 0 MID-UINT+1 WITHIN -> TRUE }T +T{ 0 0 MAX-UINT WITHIN -> TRUE }T +T{ 0 MID-UINT 0 WITHIN -> FALSE }T +T{ 0 MID-UINT MID-UINT WITHIN -> FALSE }T +T{ 0 MID-UINT MID-UINT+1 WITHIN -> FALSE }T +T{ 0 MID-UINT MAX-UINT WITHIN -> FALSE }T +T{ 0 MID-UINT+1 0 WITHIN -> FALSE }T +T{ 0 MID-UINT+1 MID-UINT WITHIN -> TRUE }T +T{ 0 MID-UINT+1 MID-UINT+1 WITHIN -> FALSE }T +T{ 0 MID-UINT+1 MAX-UINT WITHIN -> FALSE }T +T{ 0 MAX-UINT 0 WITHIN -> FALSE }T +T{ 0 MAX-UINT MID-UINT WITHIN -> TRUE }T +T{ 0 MAX-UINT MID-UINT+1 WITHIN -> TRUE }T +T{ 0 MAX-UINT MAX-UINT WITHIN -> FALSE }T +T{ MID-UINT 0 0 WITHIN -> FALSE }T +T{ MID-UINT 0 MID-UINT WITHIN -> FALSE }T +T{ MID-UINT 0 MID-UINT+1 WITHIN -> TRUE }T +T{ MID-UINT 0 MAX-UINT WITHIN -> TRUE }T +T{ MID-UINT MID-UINT 0 WITHIN -> TRUE }T +T{ MID-UINT MID-UINT MID-UINT WITHIN -> FALSE }T +T{ MID-UINT MID-UINT MID-UINT+1 WITHIN -> TRUE }T +T{ MID-UINT MID-UINT MAX-UINT WITHIN -> TRUE }T +T{ MID-UINT MID-UINT+1 0 WITHIN -> FALSE }T +T{ MID-UINT MID-UINT+1 MID-UINT WITHIN -> FALSE }T +T{ MID-UINT MID-UINT+1 MID-UINT+1 WITHIN -> FALSE }T +T{ MID-UINT MID-UINT+1 MAX-UINT WITHIN -> FALSE }T +T{ MID-UINT MAX-UINT 0 WITHIN -> FALSE }T +T{ MID-UINT MAX-UINT MID-UINT WITHIN -> FALSE }T +T{ MID-UINT MAX-UINT MID-UINT+1 WITHIN -> TRUE }T +T{ MID-UINT MAX-UINT MAX-UINT WITHIN -> FALSE }T +T{ MID-UINT+1 0 0 WITHIN -> FALSE }T +T{ MID-UINT+1 0 MID-UINT WITHIN -> FALSE }T +T{ MID-UINT+1 0 MID-UINT+1 WITHIN -> FALSE }T +T{ MID-UINT+1 0 MAX-UINT WITHIN -> TRUE }T +T{ MID-UINT+1 MID-UINT 0 WITHIN -> TRUE }T +T{ MID-UINT+1 MID-UINT MID-UINT WITHIN -> FALSE }T +T{ MID-UINT+1 MID-UINT MID-UINT+1 WITHIN -> FALSE }T +T{ MID-UINT+1 MID-UINT MAX-UINT WITHIN -> TRUE }T +T{ MID-UINT+1 MID-UINT+1 0 WITHIN -> TRUE }T +T{ MID-UINT+1 MID-UINT+1 MID-UINT WITHIN -> TRUE }T +T{ MID-UINT+1 MID-UINT+1 MID-UINT+1 WITHIN -> FALSE }T +T{ MID-UINT+1 MID-UINT+1 MAX-UINT WITHIN -> TRUE }T +T{ MID-UINT+1 MAX-UINT 0 WITHIN -> FALSE }T +T{ MID-UINT+1 MAX-UINT MID-UINT WITHIN -> FALSE }T +T{ MID-UINT+1 MAX-UINT MID-UINT+1 WITHIN -> FALSE }T +T{ MID-UINT+1 MAX-UINT MAX-UINT WITHIN -> FALSE }T +T{ MAX-UINT 0 0 WITHIN -> FALSE }T +T{ MAX-UINT 0 MID-UINT WITHIN -> FALSE }T +T{ MAX-UINT 0 MID-UINT+1 WITHIN -> FALSE }T +T{ MAX-UINT 0 MAX-UINT WITHIN -> FALSE }T +T{ MAX-UINT MID-UINT 0 WITHIN -> TRUE }T +T{ MAX-UINT MID-UINT MID-UINT WITHIN -> FALSE }T +T{ MAX-UINT MID-UINT MID-UINT+1 WITHIN -> FALSE }T +T{ MAX-UINT MID-UINT MAX-UINT WITHIN -> FALSE }T +T{ MAX-UINT MID-UINT+1 0 WITHIN -> TRUE }T +T{ MAX-UINT MID-UINT+1 MID-UINT WITHIN -> TRUE }T +T{ MAX-UINT MID-UINT+1 MID-UINT+1 WITHIN -> FALSE }T +T{ MAX-UINT MID-UINT+1 MAX-UINT WITHIN -> FALSE }T +T{ MAX-UINT MAX-UINT 0 WITHIN -> TRUE }T +T{ MAX-UINT MAX-UINT MID-UINT WITHIN -> TRUE }T +T{ MAX-UINT MAX-UINT MID-UINT+1 WITHIN -> TRUE }T +T{ MAX-UINT MAX-UINT MAX-UINT WITHIN -> FALSE }T + +T{ MIN-INT MIN-INT MIN-INT WITHIN -> FALSE }T +T{ MIN-INT MIN-INT 0 WITHIN -> TRUE }T +T{ MIN-INT MIN-INT 1 WITHIN -> TRUE }T +T{ MIN-INT MIN-INT MAX-INT WITHIN -> TRUE }T +T{ MIN-INT 0 MIN-INT WITHIN -> FALSE }T +T{ MIN-INT 0 0 WITHIN -> FALSE }T +T{ MIN-INT 0 1 WITHIN -> FALSE }T +T{ MIN-INT 0 MAX-INT WITHIN -> FALSE }T +T{ MIN-INT 1 MIN-INT WITHIN -> FALSE }T +T{ MIN-INT 1 0 WITHIN -> TRUE }T +T{ MIN-INT 1 1 WITHIN -> FALSE }T +T{ MIN-INT 1 MAX-INT WITHIN -> FALSE }T +T{ MIN-INT MAX-INT MIN-INT WITHIN -> FALSE }T +T{ MIN-INT MAX-INT 0 WITHIN -> TRUE }T +T{ MIN-INT MAX-INT 1 WITHIN -> TRUE }T +T{ MIN-INT MAX-INT MAX-INT WITHIN -> FALSE }T +T{ 0 MIN-INT MIN-INT WITHIN -> FALSE }T +T{ 0 MIN-INT 0 WITHIN -> FALSE }T +T{ 0 MIN-INT 1 WITHIN -> TRUE }T +T{ 0 MIN-INT MAX-INT WITHIN -> TRUE }T +T{ 0 0 MIN-INT WITHIN -> TRUE }T +T{ 0 0 0 WITHIN -> FALSE }T +T{ 0 0 1 WITHIN -> TRUE }T +T{ 0 0 MAX-INT WITHIN -> TRUE }T +T{ 0 1 MIN-INT WITHIN -> FALSE }T +T{ 0 1 0 WITHIN -> FALSE }T +T{ 0 1 1 WITHIN -> FALSE }T +T{ 0 1 MAX-INT WITHIN -> FALSE }T +T{ 0 MAX-INT MIN-INT WITHIN -> FALSE }T +T{ 0 MAX-INT 0 WITHIN -> FALSE }T +T{ 0 MAX-INT 1 WITHIN -> TRUE }T +T{ 0 MAX-INT MAX-INT WITHIN -> FALSE }T +T{ 1 MIN-INT MIN-INT WITHIN -> FALSE }T +T{ 1 MIN-INT 0 WITHIN -> FALSE }T +T{ 1 MIN-INT 1 WITHIN -> FALSE }T +T{ 1 MIN-INT MAX-INT WITHIN -> TRUE }T +T{ 1 0 MIN-INT WITHIN -> TRUE }T +T{ 1 0 0 WITHIN -> FALSE }T +T{ 1 0 1 WITHIN -> FALSE }T +T{ 1 0 MAX-INT WITHIN -> TRUE }T +T{ 1 1 MIN-INT WITHIN -> TRUE }T +T{ 1 1 0 WITHIN -> TRUE }T +T{ 1 1 1 WITHIN -> FALSE }T +T{ 1 1 MAX-INT WITHIN -> TRUE }T +T{ 1 MAX-INT MIN-INT WITHIN -> FALSE }T +T{ 1 MAX-INT 0 WITHIN -> FALSE }T +T{ 1 MAX-INT 1 WITHIN -> FALSE }T +T{ 1 MAX-INT MAX-INT WITHIN -> FALSE }T +T{ MAX-INT MIN-INT MIN-INT WITHIN -> FALSE }T +T{ MAX-INT MIN-INT 0 WITHIN -> FALSE }T +T{ MAX-INT MIN-INT 1 WITHIN -> FALSE }T +T{ MAX-INT MIN-INT MAX-INT WITHIN -> FALSE }T +T{ MAX-INT 0 MIN-INT WITHIN -> TRUE }T +T{ MAX-INT 0 0 WITHIN -> FALSE }T +T{ MAX-INT 0 1 WITHIN -> FALSE }T +T{ MAX-INT 0 MAX-INT WITHIN -> FALSE }T +T{ MAX-INT 1 MIN-INT WITHIN -> TRUE }T +T{ MAX-INT 1 0 WITHIN -> TRUE }T +T{ MAX-INT 1 1 WITHIN -> FALSE }T +T{ MAX-INT 1 MAX-INT WITHIN -> FALSE }T +T{ MAX-INT MAX-INT MIN-INT WITHIN -> TRUE }T +T{ MAX-INT MAX-INT 0 WITHIN -> TRUE }T +T{ MAX-INT MAX-INT 1 WITHIN -> TRUE }T +T{ MAX-INT MAX-INT MAX-INT WITHIN -> FALSE }T + +\ ----------------------------------------------------------------------------- +TESTING UNUSED (contributed by James Bowman & Peter Knaggs) + +VARIABLE UNUSED0 +T{ UNUSED DROP -> }T +T{ ALIGN UNUSED UNUSED0 ! 0 , UNUSED CELL+ UNUSED0 @ = -> TRUE }T +T{ UNUSED UNUSED0 ! 0 C, UNUSED CHAR+ UNUSED0 @ = + -> TRUE }T \ aligned -> unaligned +T{ UNUSED UNUSED0 ! 0 C, UNUSED CHAR+ UNUSED0 @ = -> TRUE }T \ unaligned -> ? + +\ ----------------------------------------------------------------------------- +TESTING AGAIN (contributed by James Bowman) + +T{ : AG0 701 BEGIN DUP 7 MOD 0= IF EXIT THEN 1+ AGAIN ; -> }T +T{ AG0 -> 707 }T + +\ ----------------------------------------------------------------------------- +TESTING MARKER (contributed by James Bowman) + +T{ : MA? BL WORD FIND NIP 0<> ; -> }T +T{ MARKER MA0 -> }T +T{ : MA1 111 ; -> }T +T{ MARKER MA2 -> }T +T{ : MA1 222 ; -> }T +T{ MA? MA0 MA? MA1 MA? MA2 -> TRUE TRUE TRUE }T +T{ MA1 MA2 MA1 -> 222 111 }T +T{ MA? MA0 MA? MA1 MA? MA2 -> TRUE TRUE FALSE }T +T{ MA0 -> }T +T{ MA? MA0 MA? MA1 MA? MA2 -> FALSE FALSE FALSE }T + +\ ----------------------------------------------------------------------------- +TESTING ?DO + +: QD ?DO I LOOP ; +T{ 789 789 QD -> }T +T{ -9876 -9876 QD -> }T +T{ 5 0 QD -> 0 1 2 3 4 }T + +: QD1 ?DO I 10 +LOOP ; +T{ 50 1 QD1 -> 1 11 21 31 41 }T +T{ 50 0 QD1 -> 0 10 20 30 40 }T + +: QD2 ?DO I 3 > IF LEAVE ELSE I THEN LOOP ; +T{ 5 -1 QD2 -> -1 0 1 2 3 }T + +: QD3 ?DO I 1 +LOOP ; +T{ 4 4 QD3 -> }T +T{ 4 1 QD3 -> 1 2 3 }T +T{ 2 -1 QD3 -> -1 0 1 }T + +: QD4 ?DO I -1 +LOOP ; +T{ 4 4 QD4 -> }T +T{ 1 4 QD4 -> 4 3 2 1 }T +T{ -1 2 QD4 -> 2 1 0 -1 }T + +: QD5 ?DO I -10 +LOOP ; +T{ 1 50 QD5 -> 50 40 30 20 10 }T +T{ 0 50 QD5 -> 50 40 30 20 10 0 }T +T{ -25 10 QD5 -> 10 0 -10 -20 }T + +VARIABLE ITERS +VARIABLE INCRMNT + +: QD6 ( limit start increment -- ) + INCRMNT ! + 0 ITERS ! + ?DO + 1 ITERS +! + I + ITERS @ 6 = IF LEAVE THEN + INCRMNT @ + +LOOP ITERS @ +; + +T{ 4 4 -1 QD6 -> 0 }T +T{ 1 4 -1 QD6 -> 4 3 2 1 4 }T +T{ 4 1 -1 QD6 -> 1 0 -1 -2 -3 -4 6 }T +T{ 4 1 0 QD6 -> 1 1 1 1 1 1 6 }T +T{ 0 0 0 QD6 -> 0 }T +T{ 1 4 0 QD6 -> 4 4 4 4 4 4 6 }T +T{ 1 4 1 QD6 -> 4 5 6 7 8 9 6 }T +T{ 4 1 1 QD6 -> 1 2 3 3 }T +T{ 4 4 1 QD6 -> 0 }T +T{ 2 -1 -1 QD6 -> -1 -2 -3 -4 -5 -6 6 }T +T{ -1 2 -1 QD6 -> 2 1 0 -1 4 }T +T{ 2 -1 0 QD6 -> -1 -1 -1 -1 -1 -1 6 }T +T{ -1 2 0 QD6 -> 2 2 2 2 2 2 6 }T +T{ -1 2 1 QD6 -> 2 3 4 5 6 7 6 }T +T{ 2 -1 1 QD6 -> -1 0 1 3 }T + +\ ----------------------------------------------------------------------------- +TESTING BUFFER: + +T{ 8 BUFFER: BUF:TEST -> }T +T{ BUF:TEST DUP ALIGNED = -> TRUE }T +T{ 111 BUF:TEST ! 222 BUF:TEST CELL+ ! -> }T +T{ BUF:TEST @ BUF:TEST CELL+ @ -> 111 222 }T + +\ ----------------------------------------------------------------------------- +TESTING VALUE TO + +T{ 111 VALUE VAL1 -999 VALUE VAL2 -> }T +T{ VAL1 -> 111 }T +T{ VAL2 -> -999 }T +T{ 222 TO VAL1 -> }T +T{ VAL1 -> 222 }T +T{ : VD1 VAL1 ; -> }T +T{ VD1 -> 222 }T +T{ : VD2 TO VAL2 ; -> }T +T{ VAL2 -> -999 }T +T{ -333 VD2 -> }T +T{ VAL2 -> -333 }T +T{ VAL1 -> 222 }T +T{ 123 VALUE VAL3 IMMEDIATE VAL3 -> 123 }T +T{ : VD3 VAL3 LITERAL ; VD3 -> 123 }T + +\ ----------------------------------------------------------------------------- +TESTING CASE OF ENDOF ENDCASE + +: CS1 CASE 1 OF 111 ENDOF + 2 OF 222 ENDOF + 3 OF 333 ENDOF + >R 999 R> + ENDCASE +; + +T{ 1 CS1 -> 111 }T +T{ 2 CS1 -> 222 }T +T{ 3 CS1 -> 333 }T +T{ 4 CS1 -> 999 }T + +\ Nested CASE's + +: CS2 >R CASE -1 OF CASE R@ 1 OF 100 ENDOF + 2 OF 200 ENDOF + >R -300 R> + ENDCASE + ENDOF + -2 OF CASE R@ 1 OF -99 ENDOF + >R -199 R> + ENDCASE + ENDOF + >R 299 R> + ENDCASE R> DROP +; + +T{ -1 1 CS2 -> 100 }T +T{ -1 2 CS2 -> 200 }T +T{ -1 3 CS2 -> -300 }T +T{ -2 1 CS2 -> -99 }T +T{ -2 2 CS2 -> -199 }T +T{ 0 2 CS2 -> 299 }T + +\ Boolean short circuiting using CASE + +: CS3 ( N1 -- N2 ) + CASE 1- FALSE OF 11 ENDOF + 1- FALSE OF 22 ENDOF + 1- FALSE OF 33 ENDOF + 44 SWAP + ENDCASE +; + +T{ 1 CS3 -> 11 }T +T{ 2 CS3 -> 22 }T +T{ 3 CS3 -> 33 }T +T{ 9 CS3 -> 44 }T + +\ Empty CASE statements with/without default + +T{ : CS4 CASE ENDCASE ; 1 CS4 -> }T +T{ : CS5 CASE 2 SWAP ENDCASE ; 1 CS5 -> 2 }T +T{ : CS6 CASE 1 OF ENDOF 2 ENDCASE ; 1 CS6 -> }T +T{ : CS7 CASE 3 OF ENDOF 2 ENDCASE ; 1 CS7 -> 1 }T + +\ ----------------------------------------------------------------------------- +TESTING :NONAME RECURSE + +VARIABLE NN1 +VARIABLE NN2 +:NONAME 1234 ; NN1 ! +:NONAME 9876 ; NN2 ! +T{ NN1 @ EXECUTE -> 1234 }T +T{ NN2 @ EXECUTE -> 9876 }T + +T{ :NONAME ( n -- 0,1,..n ) DUP IF DUP >R 1- RECURSE R> THEN ; + CONSTANT RN1 -> }T +T{ 0 RN1 EXECUTE -> 0 }T +T{ 4 RN1 EXECUTE -> 0 1 2 3 4 }T + +:NONAME ( n -- n1 ) \ Multiple RECURSEs in one definition + 1- DUP + CASE 0 OF EXIT ENDOF + 1 OF 11 SWAP RECURSE ENDOF + 2 OF 22 SWAP RECURSE ENDOF + 3 OF 33 SWAP RECURSE ENDOF + DROP ABS RECURSE EXIT + ENDCASE +; CONSTANT RN2 + +T{ 1 RN2 EXECUTE -> 0 }T +T{ 2 RN2 EXECUTE -> 11 0 }T +T{ 4 RN2 EXECUTE -> 33 22 11 0 }T +T{ 25 RN2 EXECUTE -> 33 22 11 0 }T + +\ ----------------------------------------------------------------------------- +TESTING C" + +T{ : CQ1 C" 123" ; -> }T +T{ CQ1 COUNT EVALUATE -> 123 }T +T{ : CQ2 C" " ; -> }T +T{ CQ2 COUNT EVALUATE -> }T +T{ : CQ3 C" 2345"COUNT EVALUATE ; CQ3 -> 2345 }T + +\ ----------------------------------------------------------------------------- +TESTING COMPILE, + +:NONAME DUP + ; CONSTANT DUP+ +T{ : Q DUP+ COMPILE, ; -> }T +T{ : AS1 [ Q ] ; -> }T +T{ 123 AS1 -> 246 }T + +\ ----------------------------------------------------------------------------- +\ Cannot automatically test SAVE-INPUT and RESTORE-INPUT from a console source + +TESTING SAVE-INPUT and RESTORE-INPUT with a string source + +VARIABLE SI_INC 0 SI_INC ! + +: SI1 + SI_INC @ >IN +! + 15 SI_INC ! +; + +: S$ S" SAVE-INPUT SI1 RESTORE-INPUT 12345" ; + +T{ S$ EVALUATE SI_INC @ -> 0 2345 15 }T + +\ ----------------------------------------------------------------------------- +TESTING .( + +CR CR .( Output from .() +T{ CR .( You should see -9876: ) -9876 . -> }T +T{ CR .( and again: ).( -9876)CR -> }T + +CR CR .( On the next 2 lines you should see First then Second messages:) +T{ : DOTP CR ." Second message via ." [CHAR] " EMIT \ Check .( is immediate + [ CR ] .( First message via .( ) ; DOTP -> }T +CR CR +T{ : IMM? BL WORD FIND NIP ; IMM? .( -> 1 }T + +\ ----------------------------------------------------------------------------- +TESTING .R and U.R - has to handle different cell sizes + +\ Create some large integers just below/above MAX and Min INTs +MAX-INT 73 79 */ CONSTANT LI1 +MIN-INT 71 73 */ CONSTANT LI2 + +LI1 0 <# #S #> NIP CONSTANT LENLI1 + +: (.R&U.R) ( u1 u2 -- ) \ u1 <= string length, u2 is required indentation + TUCK + >R + LI1 OVER SPACES . CR R@ LI1 SWAP .R CR + LI2 OVER SPACES . CR R@ 1+ LI2 SWAP .R CR + LI1 OVER SPACES U. CR R@ LI1 SWAP U.R CR + LI2 SWAP SPACES U. CR R> LI2 SWAP U.R CR +; + +: .R&U.R ( -- ) + CR ." You should see lines duplicated:" CR + ." indented by 0 spaces" CR 0 0 (.R&U.R) CR + ." indented by 0 spaces" CR LENLI1 0 (.R&U.R) CR \ Just fits required width + ." indented by 5 spaces" CR LENLI1 5 (.R&U.R) CR +; + +CR CR .( Output from .R and U.R) +T{ .R&U.R -> }T + +\ ----------------------------------------------------------------------------- +TESTING PAD ERASE +\ Must handle different size characters i.e. 1 CHARS >= 1 + +84 CONSTANT CHARS/PAD \ Minimum size of PAD in chars +CHARS/PAD CHARS CONSTANT AUS/PAD +: CHECKPAD ( caddr u ch -- f ) \ f = TRUE if u chars = ch + SWAP 0 + ?DO + OVER I CHARS + C@ OVER <> + IF 2DROP UNLOOP FALSE EXIT THEN + LOOP + 2DROP TRUE +; + +T{ PAD DROP -> }T +T{ 0 INVERT PAD C! -> }T +T{ PAD C@ CONSTANT MAXCHAR -> }T +T{ PAD CHARS/PAD 2DUP MAXCHAR FILL MAXCHAR CHECKPAD -> TRUE }T +T{ PAD CHARS/PAD 2DUP CHARS ERASE 0 CHECKPAD -> TRUE }T +T{ PAD CHARS/PAD 2DUP MAXCHAR FILL PAD 0 ERASE MAXCHAR CHECKPAD -> TRUE }T +T{ PAD 43 CHARS + 9 CHARS ERASE -> }T +T{ PAD 43 MAXCHAR CHECKPAD -> TRUE }T +T{ PAD 43 CHARS + 9 0 CHECKPAD -> TRUE }T +T{ PAD 52 CHARS + CHARS/PAD 52 - MAXCHAR CHECKPAD -> TRUE }T + +\ Check that use of WORD and pictured numeric output do not corrupt PAD +\ Minimum size of buffers for these are 33 chars and (2*n)+2 chars respectively +\ where n is number of bits per cell + +PAD CHARS/PAD ERASE +2 BASE ! +MAX-UINT MAX-UINT <# #S CHAR 1 DUP HOLD HOLD #> 2DROP +DECIMAL +BL WORD 12345678123456781234567812345678 DROP +T{ PAD CHARS/PAD 0 CHECKPAD -> TRUE }T + +\ ----------------------------------------------------------------------------- +TESTING PARSE + +T{ CHAR | PARSE 1234| DUP ROT ROT EVALUATE -> 4 1234 }T +T{ CHAR ^ PARSE 23 45 ^ DUP ROT ROT EVALUATE -> 7 23 45 }T +: PA1 [CHAR] $ PARSE DUP >R PAD SWAP CHARS MOVE PAD R> ; +T{ PA1 3456 + DUP ROT ROT EVALUATE -> 4 3456 }T +T{ CHAR A PARSE A SWAP DROP -> 0 }T +T{ CHAR Z PARSE + SWAP DROP -> 0 }T +T{ CHAR " PARSE 4567 "DUP ROT ROT EVALUATE -> 5 4567 }T + +\ ----------------------------------------------------------------------------- +TESTING PARSE-NAME (Forth 2012) +\ Adapted from the PARSE-NAME RfD tests + +T{ PARSE-NAME abcd STR1 S= -> TRUE }T \ No leading spaces +T{ PARSE-NAME abcde STR2 S= -> TRUE }T \ Leading spaces + +\ Test empty parse area, new lines are necessary +T{ PARSE-NAME + NIP -> 0 }T +\ Empty parse area with spaces after PARSE-NAME +T{ PARSE-NAME + NIP -> 0 }T + +T{ : PARSE-NAME-TEST ( "name1" "name2" -- n ) + PARSE-NAME PARSE-NAME S= ; -> }T +T{ PARSE-NAME-TEST abcd abcd -> TRUE }T +T{ PARSE-NAME-TEST abcd abcd -> TRUE }T \ Leading spaces +T{ PARSE-NAME-TEST abcde abcdf -> FALSE }T +T{ PARSE-NAME-TEST abcdf abcde -> FALSE }T +T{ PARSE-NAME-TEST abcde abcde + -> TRUE }T \ Parse to end of line +T{ PARSE-NAME-TEST abcde abcde + -> TRUE }T \ Leading and trailing spaces + +\ ----------------------------------------------------------------------------- +TESTING DEFER DEFER@ DEFER! IS ACTION-OF (Forth 2012) +\ Adapted from the Forth 200X RfD tests + +T{ DEFER DEFER1 -> }T +T{ : MY-DEFER DEFER ; -> }T +T{ : IS-DEFER1 IS DEFER1 ; -> }T +T{ : ACTION-DEFER1 ACTION-OF DEFER1 ; -> }T +T{ : DEF! DEFER! ; -> }T +T{ : DEF@ DEFER@ ; -> }T + +T{ ' * ' DEFER1 DEFER! -> }T +T{ 2 3 DEFER1 -> 6 }T +T{ ' DEFER1 DEFER@ -> ' * }T +T{ ' DEFER1 DEF@ -> ' * }T +T{ ACTION-OF DEFER1 -> ' * }T +T{ ACTION-DEFER1 -> ' * }T +T{ ' + IS DEFER1 -> }T +T{ 1 2 DEFER1 -> 3 }T +T{ ' DEFER1 DEFER@ -> ' + }T +T{ ' DEFER1 DEF@ -> ' + }T +T{ ACTION-OF DEFER1 -> ' + }T +T{ ACTION-DEFER1 -> ' + }T +T{ ' - IS-DEFER1 -> }T +T{ 1 2 DEFER1 -> -1 }T +T{ ' DEFER1 DEFER@ -> ' - }T +T{ ' DEFER1 DEF@ -> ' - }T +T{ ACTION-OF DEFER1 -> ' - }T +T{ ACTION-DEFER1 -> ' - }T + +T{ MY-DEFER DEFER2 -> }T +T{ ' DUP IS DEFER2 -> }T +T{ 1 DEFER2 -> 1 1 }T + +\ ----------------------------------------------------------------------------- +TESTING HOLDS (Forth 2012) + +: HTEST S" Testing HOLDS" ; +: HTEST2 S" works" ; +: HTEST3 S" Testing HOLDS works 123" ; +T{ 0 0 <# HTEST HOLDS #> HTEST S= -> TRUE }T +T{ 123 0 <# #S BL HOLD HTEST2 HOLDS BL HOLD HTEST HOLDS #> + HTEST3 S= -> TRUE }T +T{ : HLD HOLDS ; -> }T +T{ 0 0 <# HTEST HLD #> HTEST S= -> TRUE }T + +\ ----------------------------------------------------------------------------- +TESTING REFILL SOURCE-ID +\ REFILL and SOURCE-ID from the user input device can't be tested from a file, +\ can only be tested from a string via EVALUATE + +T{ : RF1 S" REFILL" EVALUATE ; RF1 -> FALSE }T +T{ : SID1 S" SOURCE-ID" EVALUATE ; SID1 -> -1 }T + +\ ------------------------------------------------------------------------------ +TESTING S\" (Forth 2012 compilation mode) +\ Extended the Forth 200X RfD tests +\ Note this tests the Core Ext definition of S\" which has unedfined +\ interpretation semantics. S\" in interpretation mode is tested in the tests on +\ the File-Access word set + +T{ : SSQ1 S\" abc" S" abc" S= ; -> }T \ No escapes +T{ SSQ1 -> TRUE }T +T{ : SSQ2 S\" " ; SSQ2 SWAP DROP -> 0 }T \ Empty string + +T{ : SSQ3 S\" \a\b\e\f\l\m\q\r\t\v\x0F0\x1Fa\xaBx\z\"\\" ; -> }T +T{ SSQ3 SWAP DROP -> 20 }T \ String length +T{ SSQ3 DROP C@ -> 7 }T \ \a BEL Bell +T{ SSQ3 DROP 1 CHARS + C@ -> 8 }T \ \b BS Backspace +T{ SSQ3 DROP 2 CHARS + C@ -> 27 }T \ \e ESC Escape +T{ SSQ3 DROP 3 CHARS + C@ -> 12 }T \ \f FF Form feed +T{ SSQ3 DROP 4 CHARS + C@ -> 10 }T \ \l LF Line feed +T{ SSQ3 DROP 5 CHARS + C@ -> 13 }T \ \m CR of CR/LF pair +T{ SSQ3 DROP 6 CHARS + C@ -> 10 }T \ LF of CR/LF pair +T{ SSQ3 DROP 7 CHARS + C@ -> 34 }T \ \q " Double Quote +T{ SSQ3 DROP 8 CHARS + C@ -> 13 }T \ \r CR Carriage Return +T{ SSQ3 DROP 9 CHARS + C@ -> 9 }T \ \t TAB Horizontal Tab +T{ SSQ3 DROP 10 CHARS + C@ -> 11 }T \ \v VT Vertical Tab +T{ SSQ3 DROP 11 CHARS + C@ -> 15 }T \ \x0F Given Char +T{ SSQ3 DROP 12 CHARS + C@ -> 48 }T \ 0 0 Digit follow on +T{ SSQ3 DROP 13 CHARS + C@ -> 31 }T \ \x1F Given Char +T{ SSQ3 DROP 14 CHARS + C@ -> 97 }T \ a a Hex follow on +T{ SSQ3 DROP 15 CHARS + C@ -> 171 }T \ \xaB Insensitive Given Char +T{ SSQ3 DROP 16 CHARS + C@ -> 120 }T \ x x Non hex follow on +T{ SSQ3 DROP 17 CHARS + C@ -> 0 }T \ \z NUL No Character +T{ SSQ3 DROP 18 CHARS + C@ -> 34 }T \ \" " Double Quote +T{ SSQ3 DROP 19 CHARS + C@ -> 92 }T \ \\ \ Back Slash + +\ The above does not test \n as this is a system dependent value. +\ Check it displays a new line +CR .( The next test should display:) +CR .( One line...) +CR .( another line) +T{ : SSQ4 S\" \nOne line...\nanotherLine\n" TYPE ; SSQ4 -> }T + +\ Test bare escapable characters appear as themselves +T{ : SSQ5 S\" abeflmnqrtvxz" S" abeflmnqrtvxz" S= ; SSQ5 -> TRUE }T + +T{ : SSQ6 S\" a\""2DROP 1111 ; SSQ6 -> 1111 }T \ Parsing behaviour + +T{ : SSQ7 S\" 111 : SSQ8 S\\\" 222\" EVALUATE ; SSQ8 333" EVALUATE ; -> }T +T{ SSQ7 -> 111 222 333 }T +T{ : SSQ9 S\" 11 : SSQ10 S\\\" \\x32\\x32\" EVALUATE ; SSQ10 33" EVALUATE ; -> }T +T{ SSQ9 -> 11 22 33 }T + +\ ----------------------------------------------------------------------------- +CORE-EXT-ERRORS SET-ERROR-COUNT + +CR .( End of Core Extension word tests) CR + + diff --git a/testfiles/ifmacro.f b/testfiles/ifmacro.f new file mode 100644 index 0000000..7487003 --- /dev/null +++ b/testfiles/ifmacro.f @@ -0,0 +1,33 @@ +1 [if] ." One," + 0 + [if] bla bla + [if] + [if] this + [then] + is + [then] + not parsed + [else] + ." Two," + [then] + ." Bla bla," +[then] +." End," + +0 +[if] + blabla +[else] + 1 + [if] + char A EMIT + [else] + [if] + [if] this + [then] + is not parsed + [then] + [then] +[then] + +char X EMIT