From a096f55a679928c3701d190b713150cace9ca54a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ond=C5=99ej=20Hru=C5=A1ka?= Date: Sun, 21 Nov 2021 00:32:38 +0100 Subject: [PATCH] more fixes in DOES>, now it's almost correct and extra weird --- README.md | 8 ++-- include/fh_runtime.h | 2 + src/fh_builtins_meta.c | 80 ++++++++++++++++++++++++++++++++++++++-- src/fh_mem.c | 1 + src/fh_runtime.c | 3 ++ src/fh_see.c | 12 ++++-- testfiles/combinedtest.f | 1 + 7 files changed, 97 insertions(+), 10 deletions(-) diff --git a/README.md b/README.md index c2abfa5..2c630dc 100644 --- a/README.md +++ b/README.md @@ -50,12 +50,12 @@ 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 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 +CHARS CONSTANT COUNT CR CREATE DECIMAL DEPTH DO DOES> 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 +.( :NONAME 0<> 0> 2>R 2R> 2R@ <> ?DO AGAIN FALSE HEX NIP PAD PICK ROLL S\" TO TRUE TUCK U.R U> UNUSED VALUE \ Other sets: @@ -68,10 +68,10 @@ basically, CASE-OF, pictured numbers, keyboard input, some weirder metaprogrammi ``` CORE: -# #> #S <# >BODY >NUMBER ABORT" ACCEPT DOES> EVALUATE FILL HOLD KEY MOVE SIGN SPACES U. +# #> #S <# >BODY >NUMBER ABORT" ACCEPT 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 +.R ACTION-OF BUFFER: C" CASE COMPILE, DEFER DEFER! DEFER@ ENDCASE ENDOF ERASE HOLDS IS MARKER OF PARSE PARSE-NAME REFILL RESTORE-INPUT SAVE-INPUT SOURCE-ID WITHIN [COMPILE] ``` diff --git a/include/fh_runtime.h b/include/fh_runtime.h index 0a1af25..cb9d219 100644 --- a/include/fh_runtime.h +++ b/include/fh_runtime.h @@ -198,6 +198,8 @@ struct fh_thread_s { /** Nesting level of [if] */ uint32_t parse_if_level; + + bool executing_compiled; }; enum fh_error fh_loop_nest(struct fh_thread_s *fh, uint32_t indexvalue); diff --git a/src/fh_builtins_meta.c b/src/fh_builtins_meta.c index d6b2664..45ac6b7 100644 --- a/src/fh_builtins_meta.c +++ b/src/fh_builtins_meta.c @@ -31,20 +31,81 @@ static enum fh_error w_colon(struct fh_thread_s *fh, const struct fh_word_s *w) return FH_OK; } -static enum fh_error w_does(struct fh_thread_s *fh, const struct fh_word_s *w) +static enum fh_error w_colon_noname(struct fh_thread_s *fh, const struct fh_word_s *w) { (void) w; enum fh_error rv; ENSURE_STATE(FH_STATE_INTERPRET); + + LOG("Starting noname compilation"); + + fh_setstate(fh, FH_STATE_COMPILE, 0); + + uint32_t ptr; + 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 = MAGICADDR_DICTFIRST; + new_word->param = fh->here; + new_word->handler = w_user_word; + new_word->name[0] = 0; + new_word->flags = WORDFLAG_WORD; + + TRY(ds_push(fh, ptr)); // TODO maybe should do this at semicolon? + + return FH_OK; +} + +static enum fh_error w_does(struct fh_thread_s *fh, const struct fh_word_s *w) +{ + (void) w; + enum fh_error rv; + bool crazy = 0; + + if (fh->executing_compiled) { + LOG("DOES> in compiled code. OK but weird"); + //FIXME make this less shitty + + // FIXME this works correctly, but the test fails, because it assumes + // that compiled DOES> just changes some pointer in the dict entry, + // whereas we do it by generating helper instructions. + + crazy = 1; + goto banana; + banana2: + + // We are in :NONAME or : NAME. + // This word should be compiled. + TRY(fh_put_instr(fh, FH_INSTR_JUMP, fh->execptr + INSTR_SIZE)); // skip two forward + // next instr run is the ENDWORD emitted at compile time + + return FH_OK; + } + + if (fh->state == FH_STATE_COMPILE) { + TRY(fh_put_instr(fh, FH_INSTR_WORD, (void*)w - (void*)&fh->heap[0])); // call the DOES word + TRY(fh_put_instr(fh, FH_INSTR_ENDWORD, 1)); + return FH_OK; + } fh_setstate(fh, FH_STATE_COMPILE, 0); + banana: struct fh_word_s *last_word = fh_word_at(fh, fh->dict_last); if (!last_word) return FH_ERR_INTERNAL; - last_word->handler = w_user_word; - last_word->param = fh->here; + last_word->handler = w_user_word; + last_word->param = fh->here; // + CELL; // skip the one cell used to hold data. this is a shitty hack last_word->flags = WORDFLAG_WORD; + + uint32_t dptr = fh->here; + //TRY(fh_heap_reserve(fh, CELL, NULL)); + + TRY(fh_put_instr(fh, FH_INSTR_NUMBER, dptr)); // put pointer to the reserved cell + + if (crazy) goto banana2; + return FH_OK; } @@ -328,6 +389,17 @@ static enum fh_error w_to_in(struct fh_thread_s *fh, const struct fh_word_s *w) return FH_OK; } +static enum fh_error w_to_body(struct fh_thread_s *fh, const struct fh_word_s *w) +{ + (void) w; + enum fh_error rv; + + uint32_t xt; + TRY(ds_pop(fh, &xt)); // xt is now a dict entry (hopefully) + TRY(ds_push(fh, xt + DICTWORD_SIZE)); // XXX should it still point here if DOES> was used? + return FH_OK; +} + static bool chartest_equals_or_end(char c, void *param) { char cc = (char) *(uint32_t *) param; @@ -567,7 +639,9 @@ const struct name_and_handler fh_builtins_meta[] = { {"depth", w_depth, 0, 0}, {"unused", w_unused, 0, 0}, {">in", w_to_in, 0, 0}, + {">body", w_to_body, 0, 0}, {":", w_colon, 0, 0}, + {":noname", w_colon_noname, 0, 0}, {"does>", w_does, 1, 0}, {";", w_semicolon, 1, 0}, {"forget", w_forget, 1, 0}, diff --git a/src/fh_mem.c b/src/fh_mem.c index 4437ad7..cd45fbe 100644 --- a/src/fh_mem.c +++ b/src/fh_mem.c @@ -175,6 +175,7 @@ enum fh_error fh_heap_put(struct fh_thread_s *fh, const void *src, uint32_t len) enum fh_error rv; uint32_t addr = 0; TRY(fh_heap_reserve(fh, len, &addr)); + LOG("Put %d bytes at 0x%08x", len, addr); fh_heap_write(fh, addr, src, len); return FH_OK; } diff --git a/src/fh_runtime.c b/src/fh_runtime.c index c824851..adfe246 100644 --- a/src/fh_runtime.c +++ b/src/fh_runtime.c @@ -107,6 +107,8 @@ enum fh_error w_user_word(struct fh_thread_s *fh, const struct fh_word_s *w0) const struct fh_word_s *w; struct fh_word_s *w2; + fh->executing_compiled = 1; + w = w0; call: if (!w) { return FH_ERR_INTERNAL; } @@ -332,6 +334,7 @@ enum fh_error w_user_word(struct fh_thread_s *fh, const struct fh_word_s *w0) } end: + fh->executing_compiled = 0; return FH_OK; } diff --git a/src/fh_see.c b/src/fh_see.c index 562c416..17e3113 100644 --- a/src/fh_see.c +++ b/src/fh_see.c @@ -27,7 +27,7 @@ static void show_word(struct fh_thread_s *fh, const struct fh_word_s *w) const struct fh_word_s *w2; switch (instr->kind) { case FH_INSTR_NUMBER: - FHPRINT("Number(%d)\n", instr->data); + FHPRINT("Number(%d / 0x%08x)\n", instr->data, instr->data); break; case FH_INSTR_WORD: @@ -103,8 +103,13 @@ static void show_word(struct fh_thread_s *fh, const struct fh_word_s *w) break; case FH_INSTR_ENDWORD: - FHPRINT("END\n"); - return; + if (instr->data == 1) { + FHPRINT("END (synthetic for DOES>)\n"); + break; + } else { + FHPRINT("END\n"); + return; + } default: FHPRINT("Unknown(kind 0x%08x, data 0x%08x)\n", instr->kind, instr->data); @@ -133,6 +138,7 @@ enum fh_error fh_see_word( { enum fh_error rv; uint32_t addr; + // TODO allow see with addr to inspect :NONAME defined words TRY(fh_find_word(fh, name, wordlen, &addr)); show_word(fh, fh_word_at(fh, addr)); return FH_OK; diff --git a/testfiles/combinedtest.f b/testfiles/combinedtest.f index 769fcb9..f74f1f5 100644 --- a/testfiles/combinedtest.f +++ b/testfiles/combinedtest.f @@ -826,6 +826,7 @@ 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