more words implemented

master
Ondřej Hruška 3 years ago
parent 37a1582801
commit bcc804289f
  1. 14
      README.md
  2. 1
      include/forth_internal.h
  3. 25
      src/fh_builtins_mem.c
  4. 47
      src/fh_builtins_text.c
  5. 4
      testfiles/combinedtest.f
  6. 9
      testfiles/dotquote.txt

@ -44,15 +44,15 @@ Implementation status
*(this section may be outdated)* *(this section may be outdated)*
Implemented (some may be wrong, like `FM/MOD`): Implemented and tested:
``` ```
CORE: CORE:
! ' ( * */ */MOD + +! +LOOP , - . ." / /mod 0< 0= 1+ 1- 2! 2* 2/ 2@ 2DROP 2DUP 2OVER 2SWAP ! ' ( * */ */MOD + +! +LOOP , - . ." # #> #S <# >BODY >NUMBER / /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+ : ; < = > >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 DOES> 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 FILL 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 HERE HOLD I IF IMMEDIATE INVERT J LEAVE LITERAL LOOP LSHIFT M* MAX MIN MOD MOVE 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] ] REPEAT ROT RSHIFT S>D S" SIGN SM/REM SOURCE SPACE SPACES STATE SWAP THEN TYPE U. U< UNTIL UM* UM/MOD UNLOOP VARIABLE WHILE WORD XOR [ ['] [CHAR] ]
CORE-EXT: CORE-EXT:
.( :NONAME 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
@ -64,11 +64,9 @@ FORGET SEE BYE
Missing: Missing:
basically, CASE-OF, pictured numbers, keyboard input, some weirder metaprogramming things, manipulating the input buffer.
``` ```
CORE: CORE:
# #> #S <# >BODY >NUMBER ABORT" ACCEPT EVALUATE FILL HOLD KEY MOVE SIGN SPACES U. ABORT" ACCEPT EVALUATE KEY
CORE-EXT: CORE-EXT:
.R 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

@ -16,6 +16,7 @@
#include <stdio.h> #include <stdio.h>
#include <stdlib.h> #include <stdlib.h>
#include <stddef.h> #include <stddef.h>
#include <inttypes.h>
#include "fh_config.h" #include "fh_config.h"
#include "fh_error.h" #include "fh_error.h"

@ -96,6 +96,30 @@ static enum fh_error w_allot(struct fh_thread_s *fh, const struct fh_word_s *w)
return FH_OK; return FH_OK;
} }
static enum fh_error w_move(struct fh_thread_s *fh, const struct fh_word_s *w)
{
(void) w;
enum fh_error rv;
uint32_t count = 0, dst = 0, src = 0;
TRY(ds_pop(fh, &count));
TRY(ds_pop(fh, &dst));
TRY(ds_pop(fh, &src));
if (src+count>=HEAP_SIZE) {
LOGE("MOVE src out of bounds");
return FH_ERR_ILLEGAL_FETCH;
}
if (dst+count>=HEAP_SIZE) {
LOGE("MOVE dst out of bounds");
return FH_ERR_ILLEGAL_STORE;
}
fh_heap_copy(fh, dst, src, count);
return FH_OK;
}
static enum fh_error w_comma(struct fh_thread_s *fh, const struct fh_word_s *w) static enum fh_error w_comma(struct fh_thread_s *fh, const struct fh_word_s *w)
{ {
(void) w; (void) w;
@ -202,6 +226,7 @@ const struct name_and_handler fh_builtins_mem[] = {
{"here", w_here, 0, 0}, {"here", w_here, 0, 0},
{"state", wp_const, 0, MAGICADDR_STATE}, {"state", wp_const, 0, MAGICADDR_STATE},
{"pad", w_pad, 0, 0}, {"pad", w_pad, 0, 0},
{"move", w_move, 0, 0},
{ /* end marker */ } { /* end marker */ }
}; };

@ -76,7 +76,19 @@ static enum fh_error w_dot(struct fh_thread_s *fh, const struct fh_word_s *w)
uint32_t a = 0; uint32_t a = 0;
TRY(ds_pop(fh, &a)); TRY(ds_pop(fh, &a));
FHPRINT("%d ", (int32_t) a); FHPRINT("%"PRIi32" ", (int32_t) a);
return FH_OK;
}
static enum fh_error w_u_dot(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));
FHPRINT("%"PRIu32" ", a);
return FH_OK; return FH_OK;
} }
@ -104,6 +116,21 @@ static enum fh_error w_type(struct fh_thread_s *fh, const struct fh_word_s *w)
return FH_OK; return FH_OK;
} }
static enum fh_error w_fill(struct fh_thread_s *fh, const struct fh_word_s *w)
{
(void) w;
enum fh_error rv;
uint32_t count = 0, addr = 0, ch;
TRY(ds_pop(fh, &ch));
TRY(pop_addr_len(fh, &addr, &count));
const char *str = fh_str_at(fh, addr);
if (!str) return FH_ERR_INTERNAL;
if (count > 0) {
memset((void*)str, (uint8_t)ch, count);
}
return FH_OK;
}
static enum fh_error wp_putc(struct fh_thread_s *fh, const struct fh_word_s *w) static enum fh_error wp_putc(struct fh_thread_s *fh, const struct fh_word_s *w)
{ {
(void) fh; (void) fh;
@ -203,6 +230,7 @@ static enum fh_error w_dot_quote(struct fh_thread_s *fh, const struct fh_word_s
char *start; char *start;
char c = (char)w->param; char c = (char)w->param;
uint32_t capacity = HEAP_END - addr; uint32_t capacity = HEAP_END - addr;
LOG("dotquote end: %c", c);
if (c == '\\') { if (c == '\\') {
start = (char *) &fh->heap[addr]; start = (char *) &fh->heap[addr];
TRY(fh_input_read_quotedstring(fh, 1, start, capacity, &len)); TRY(fh_input_read_quotedstring(fh, 1, start, capacity, &len));
@ -352,6 +380,18 @@ static enum fh_error w_holds(struct fh_thread_s *fh, const struct fh_word_s *w)
return FH_OK; return FH_OK;
} }
static enum fh_error w_spaces(struct fh_thread_s *fh, const struct fh_word_s *w)
{
(void) w;
enum fh_error rv;
uint32_t num;
TRY(ds_pop(fh, &num));
while(num-->0) {
FHPRINT(" ");
}
return FH_OK;
}
static enum fh_error w_to_number(struct fh_thread_s *fh, const struct fh_word_s *w) static enum fh_error w_to_number(struct fh_thread_s *fh, const struct fh_word_s *w)
{ {
(void) w; (void) w;
@ -408,12 +448,15 @@ const struct name_and_handler fh_builtins_text[] = {
{".(", w_dot_quote, 1, ')'}, {".(", w_dot_quote, 1, ')'},
{".\\\"", w_dot_quote, 1, '\\'}, // escaped, this is non-standard {".\\\"", w_dot_quote, 1, '\\'}, // escaped, this is non-standard
{".", w_dot, 0, 0}, {".", w_dot, 0, 0},
{"u.", w_u_dot, 0, 0},
{"type", w_type, 0, 0}, {"type", w_type, 0, 0},
{"fill", w_fill, 0, 0},
{"cr", wp_putc, 0, '\n'}, {"cr", wp_putc, 0, '\n'},
{"space", wp_putc, 0, ' '}, {"space", wp_putc, 0, ' '},
{"spaces", w_spaces, 0, 0},
{"bl", wp_const, 0, ' '}, {"bl", wp_const, 0, ' '},
{"u.r", w_u_r, 0, 0}, {"u.r", w_u_r, 0, 0},
{"??", w_debug_dump, 0, 0}, {"??", w_debug_dump, 0, 0}, // XXX non-standard
{"emit", w_emit, 0, 0}, {"emit", w_emit, 0, 0},
{"see", w_see, 0, 0}, {"see", w_see, 0, 0},
{"<#", w_less_hash, 0, 0}, {"<#", w_less_hash, 0, 0},

@ -1051,7 +1051,7 @@ TESTING OUTPUT: . ." CR EMIT SPACE SPACES TYPE U.
T{ OUTPUT-TEST -> }T T{ OUTPUT-TEST -> }T
0 [if] \ FIXME
\ ------------------------------------------------------------------------ \ ------------------------------------------------------------------------
TESTING INPUT: ACCEPT TESTING INPUT: ACCEPT
@ -1065,6 +1065,7 @@ CREATE ABUF 50 CHARS ALLOT
; ;
T{ ACCEPT-TEST -> }T T{ ACCEPT-TEST -> }T
[then]
\ ------------------------------------------------------------------------ \ ------------------------------------------------------------------------
TESTING DICTIONARY SEARCH RULES TESTING DICTIONARY SEARCH RULES
@ -1075,7 +1076,6 @@ T{ GDX -> 123 234 }T
CR .( End of Core word set tests) CR CR .( End of Core word set tests) CR
\ To test the ANS Forth Core Extension word set \ To test the ANS Forth Core Extension word set
\ This program was written by Gerry Jackson in 2006, with contributions from \ This program was written by Gerry Jackson in 2006, with contributions from

@ -0,0 +1,9 @@
." hello"
.\" banana"
." a" .( this should be shown) ." END" 65 EMIT
CR .( End of Core word set tests) CR
." This is the end."
Loading…
Cancel
Save