From 355bf09ec9b94ecba70e424fba3287640f722719 Mon Sep 17 00:00:00 2001 From: ketmar Date: Wed, 18 Oct 2023 16:58:01 +0000 Subject: [PATCH] UrForth: added some words for the address register manipulation; TYPE and others are in Forth now FossilOrigin-Name: 1d9e37e85e74a3d20ef24ce39338d3d083cc82e0afc632022007dded3769d51f --- dox/urforth.txt | 12 ++ src/liburforth/urforth.c | 233 ++++++++++++++++---------------- urflibs/init/bootstrap/00-main-loader.f | 1 + urflibs/init/stdlib.f | 24 ++-- urflibs/init/struct.f | 14 +- 5 files changed, 149 insertions(+), 135 deletions(-) diff --git a/dox/urforth.txt b/dox/urforth.txt index a031532..6bd10d4 100644 --- a/dox/urforth.txt +++ b/dox/urforth.txt @@ -811,6 +811,18 @@ A-SWAP ( rega -- olda ) swap TOS and the address register. ++1>A +( -- ) +increment the address register. + +A>R +( -- | rega ) +copy the address register to the return stack. + +R>A +( | rega -- ) +restore the address register from the return stack. + C@A ( -- byte ) diff --git a/src/liburforth/urforth.c b/src/liburforth/urforth.c index eadcd4e..3affccc 100644 --- a/src/liburforth/urforth.c +++ b/src/liburforth/urforth.c @@ -2688,6 +2688,24 @@ UFWORD(REGA_SWAP) { ufoRegA = newa; } +// +1>A +// ( -- ) +UFWORD(REGA_INC) { + ufoRegA += 1u; +} + +// A>R +// ( -- | rega ) +UFWORD(REGA_TO_R) { + ufoRPush(ufoRegA); +} + +// R>A +// ( | rega -- ) +UFWORD(R_TO_REGA) { + ufoRegA = ufoRPop(); +} + // ////////////////////////////////////////////////////////////////////////// // // useful to work with handles and normal addreses uniformly @@ -3434,55 +3452,35 @@ UFWORD(PARSE) { ufoPushBool(0); UFCALL(PAR_PARSE); } -// (WORD-OR-PARSE) -// ( delim skip-leading-delim? -- here TRUE / FALSE ) -// parse word, copy it to HERE as counted string. -// adds trailing zero after the string, but doesn't include it in count. -// doesn't advance line. - -// WORD -// ( delim -- here ) -// parse word, copy it to HERE as counted string. -// adds trailing zero after the string, but doesn't include it in count. -// doesn't advance line. -// return empty string on EOL. - -// PARSE-TO-HERE -// ( delim -- addr count TRUE / FALSE ) -// parse word w/o skipping delimiters, copy it to HERE as counted string. -// adds trailing zero after the string, but doesn't include it in count. -// doesn't advance line. - // ////////////////////////////////////////////////////////////////////////// // // char output // -// (EMIT) -// ( n -- ) -UFWORD(PAR_EMIT) { - uint32_t ch = ufoPop()&0xffU; - ufoLastEmitWasCR = (ch == 10); - putchar((char)ch); -} - -// EMIT -// ( n -- ) -UFWORD(EMIT) { +// (NORM-EMIT-CHAR) +// ( ch -- ) +UFWORD(PAR_NORM_EMIT_CHAR) { uint32_t ch = ufoPop()&0xffU; if (ch < 32 || ch == 127) { if (ch != 9 && ch != 10 && ch != 13) ch = '?'; } - ufoLastEmitWasCR = (ch == 10); - putchar((char)ch); + ufoPush(ch); +} + +// (NORM-XEMIT-CHAR) +// ( ch -- ) +UFWORD(PAR_NORM_XEMIT_CHAR) { + uint32_t ch = ufoPop()&0xffU; + if (ch < 32 || ch == 127) ch = '?'; + ufoPush(ch); } -// XEMIT +// (EMIT) // ( n -- ) -UFWORD(XEMIT) { +UFWORD(PAR_EMIT) { uint32_t ch = ufoPop()&0xffU; - putchar(ch < 32 || ch == 127 ? '?' : (char)ch); - ufoLastEmitWasCR = 0; + ufoLastEmitWasCR = (ch == 10); + putchar((char)ch); } // LASTCR? @@ -3497,73 +3495,6 @@ UFWORD(LASTCRSET) { ufoLastEmitWasCR = !!ufoPop(); } -// CR -// ( -- ) -UFWORD(CR) { - putchar('\n'); - ufoLastEmitWasCR = 1; -} - -// SPACE -// ( -- ) -UFWORD(SPACE) { - putchar(' '); - ufoLastEmitWasCR = 0; -} - -// SPACES -// ( n -- ) -UFWORD(SPACES) { - char tmpbuf[64]; - int32_t n = (int32_t)ufoPop(); - if (n > 0) { - memset(tmpbuf, 32, sizeof(tmpbuf)); - while (n > 0) { - int32_t xwr = n; - if (xwr > (int32_t)sizeof(tmpbuf) - 1) xwr = (int32_t)sizeof(tmpbuf) - 1; - tmpbuf[xwr] = 0; - printf("%s", tmpbuf); - n -= xwr; - } - ufoLastEmitWasCR = 0; - } -} - -// ENDCR -// ( -- ) -UFWORD(ENDCR) { - if (ufoLastEmitWasCR == 0) { - putchar('\n'); - ufoLastEmitWasCR = 1; - } -} - -// TYPE -// ( addr count -- ) -UFWORD(TYPE) { - int32_t count = (int32_t)ufoPop(); - uint32_t addr = ufoPop(); - while (count > 0) { - const uint8_t ch = ufoImgGetU8Ext(addr); - ufoPush(ch); - UFCALL(EMIT); - addr += 1; count -= 1; - } -} - -// XTYPE -// ( addr count -- ) -UFWORD(XTYPE) { - int32_t count = (int32_t)ufoPop(); - uint32_t addr = ufoPop(); - while (count > 0) { - const uint8_t ch = ufoImgGetU8Ext(addr); - ufoPush(ch); - UFCALL(XEMIT); - addr += 1; count -= 1; - } -} - // FLUSH-EMIT // ( -- ) UFWORD(FLUSH_EMIT) { @@ -6117,6 +6048,7 @@ static void ufoDefineSColonForth (const char *name) { // //========================================================================== UFO_FORCE_INLINE void ufoDoneForth (void) { + UFC("FORTH:(EXIT)"); } @@ -6332,6 +6264,81 @@ UFO_FORCE_INLINE void ufoResolveBwd (uint32_t jaddr) { //========================================================================== // +// ufoDefineEmitType +// +//========================================================================== +UFO_DISABLE_INLINE void ufoDefineEmitType (void) { + // ( ch -- ) + ufoDefineForth("EMIT"); + UFC("(NORM-EMIT-CHAR)"); + UFC("(EMIT)"); + ufoDoneForth(); + + // ( ch -- ) + ufoDefineForth("XEMIT"); + UFC("(NORM-XEMIT-CHAR)"); + UFC("(EMIT)"); + ufoDoneForth(); + + // ( -- ) + ufoDefineForth("CR"); + UFC("NL"); UFC("(EMIT)"); + ufoDoneForth(); + + // ( -- ) + ufoDefineForth("SPACE"); + UFC("BL"); UFC("(EMIT)"); + ufoDoneForth(); + + // ( count -- ) + ufoDefineForth("SPACES"); + const uint32_t spaces_again = ufoMarkBwd(); + UFC("DUP"); ufoCompileLit(0); UFC(">"); + UFC("FORTH:(0BRANCH)"); const uint32_t spaces_exit = ufoMarkFwd(); + UFC("SPACE"); ufoCompileLit(1); UFC("-"); + UFC("FORTH:(BRANCH)"); ufoResolveBwd(spaces_again); + ufoResolveFwd(spaces_exit); + UFC("DROP"); + ufoDoneForth(); + + // ( -- ) + ufoDefineForth("ENDCR"); + UFC("LASTCR?"); + UFC("FORTH:(TBRANCH)"); const uint32_t endcr_exit = ufoMarkFwd(); + UFC("CR"); + ufoResolveFwd(endcr_exit); + ufoDoneForth(); + + // ( addr count -- ) + ufoDefineForth("TYPE"); + UFC("A>R"); UFC("SWAP"); UFC(">A"); + const uint32_t type_again = ufoMarkBwd(); + UFC("DUP"); ufoCompileLit(0); UFC(">"); + UFC("FORTH:(0BRANCH)"); const uint32_t type_exit = ufoMarkFwd(); + ufoCompileLit(0); UFC("C@A+"); UFC("EMIT"); UFC("+1>A"); + ufoCompileLit(1); UFC("-"); + UFC("FORTH:(BRANCH)"); ufoResolveBwd(type_again); + ufoResolveFwd(type_exit); + UFC("DROP"); UFC("R>A"); + ufoDoneForth(); + + // ( addr count -- ) + ufoDefineForth("XTYPE"); + UFC("A>R"); UFC("SWAP"); UFC(">A"); + const uint32_t xtype_again = ufoMarkBwd(); + UFC("DUP"); ufoCompileLit(0); UFC(">"); + UFC("FORTH:(0BRANCH)"); const uint32_t xtype_exit = ufoMarkFwd(); + ufoCompileLit(0); UFC("C@A+"); UFC("XEMIT"); UFC("+1>A"); + ufoCompileLit(1); UFC("-"); + UFC("FORTH:(BRANCH)"); ufoResolveBwd(xtype_again); + ufoResolveFwd(xtype_exit); + UFC("DROP"); UFC("R>A"); + ufoDoneForth(); +} + + +//========================================================================== +// // ufoDefineInterpret // // define "INTERPRET" in Forth @@ -6354,7 +6361,6 @@ UFO_DISABLE_INLINE void ufoDefineInterpret (void) { UFC("FORTH:(UFO-INTERPRET-FINISHED)"); // patch the jump above ufoResolveFwd(label_ipn_exit_fwd); - UFC("FORTH:(EXIT)"); ufoDoneForth(); //ufoDecompileWord(ufoFindWordChecked("(INTERPRET-PARSE-NAME)")); @@ -6567,6 +6573,9 @@ UFO_DISABLE_INLINE void ufoInitBasicWords (void) { UFWORDX("A>", REGA_LOAD); UFWORDX(">A", REGA_STORE); UFWORDX("A-SWAP", REGA_SWAP); + UFWORDX("+1>A", REGA_INC); + UFWORDX("A>R", REGA_TO_R); + UFWORDX("R>A", R_TO_REGA); UFWORDX("@A+", PEEK_REGA_IDX); UFWORDX("C@A+", CPEEK_REGA_IDX); @@ -6736,14 +6745,8 @@ UFO_DISABLE_INLINE void ufoInitMoreWords (void) { UFWORDX("FLUSH-EMIT", FLUSH_EMIT); UFWORDX("(EMIT)", PAR_EMIT); - UFWORD(EMIT); - UFWORD(XEMIT); - UFWORD(TYPE); - UFWORD(XTYPE); - UFWORD(SPACE); - UFWORD(SPACES); - UFWORD(CR); - UFWORD(ENDCR); + UFWORDX("(NORM-EMIT-CHAR)", PAR_NORM_EMIT_CHAR); + UFWORDX("(NORM-XEMIT-CHAR)", PAR_NORM_XEMIT_CHAR); UFWORDX("LASTCR?", LASTCRQ); UFWORDX("LASTCR!", LASTCRSET); @@ -7009,18 +7012,17 @@ UFO_DISABLE_INLINE void ufoInitVeryVeryHighWords (void) { // interpret defer //ufoDefineDefer("INTERPRET", idumbCFA); + ufoDefineEmitType(); + // ( addr count FALSE -- addr count FALSE / TRUE ) ufoDefineSColonForth("(INTERPRET-CHECK-WORD)"); - UFC("FORTH:(EXIT)"); ufoDoneForth(); // ( addr count FALSE -- addr count FALSE / TRUE ) ufoDefineSColonForth("(INTERPRET-WORD-NOT-FOUND)"); - UFC("FORTH:(EXIT)"); ufoDoneForth(); // ( FALSE -- FALSE / TRUE ) -- called in "EXIT", before compiling "FORTH:(EXIT)" // return TRUE to stop calling other chained words, and omit default exit ufoDefineSColonForth("(EXIT-EXTENDER)"); - UFC("FORTH:(EXIT)"); ufoDoneForth(); // create "FORTH:EXIT" @@ -7032,7 +7034,6 @@ UFO_DISABLE_INLINE void ufoInitVeryVeryHighWords (void) { UFC("FORTH:(LITCFA)"); UFC("FORTH:(EXIT)"); UFC("FORTH:COMPILE,"); ufoResolveFwd(exit_branch_end); - UFC("FORTH:(EXIT)"); ufoDoneForth(); ufoDefineInterpret(); diff --git a/urflibs/init/bootstrap/00-main-loader.f b/urflibs/init/bootstrap/00-main-loader.f index 4bf12ef..6317bf4 100644 --- a/urflibs/init/bootstrap/00-main-loader.f +++ b/urflibs/init/bootstrap/00-main-loader.f @@ -10,6 +10,7 @@ ;; GET-MSECS $INCLUDE-ONCE <01-colon-semicolon.f> +\ $INCLUDE-ONCE <05-emit-type.f> $INCLUDE-ONCE <10-mem-utils.f> $INCLUDE-ONCE <20-base-creatori.f> $INCLUDE-ONCE <25-scolon.f> diff --git a/urflibs/init/stdlib.f b/urflibs/init/stdlib.f index 933932f..0a3eac1 100644 --- a/urflibs/init/stdlib.f +++ b/urflibs/init/stdlib.f @@ -124,13 +124,13 @@ ALSO STRING DEFINITIONS ; : -TRAILING ( addr count -- addr count ) - A> >R OVER >A + A>R OVER >A BEGIN DUP 0> WHILE ( addr count ) DUP 1- C@A+ BL <= IF 1- FALSE ELSE TRUE ENDIF UNTIL - R> >A + R>A ; ;; adjust the character string at c-addr1 by n characters. @@ -183,24 +183,24 @@ PREVIOUS DEFINITIONS ;; -1, 0 or 1 : MEMCMP ( addr1 addr2 size -- n ) - A> >R >R 0 NROT R> ( 0 a1 a2 sz | rega ) + A>R >R 0 NROT R> ( 0 a1 a2 sz | rega ) FOR ( 0 a1 a2 | rega ) OVER >A C@A OVER >A C@A - ?DUP IF ( 0 a1 a2 sgn ) >R DROP R> NROT BREAK ENDIF 1+ SWAP 1+ SWAP ENDFOR 2DROP - R> >A SIGN? + R>A SIGN? ; ;; -1, 0 or 1 : MEMCMP-CI ( addr1 addr2 size -- n ) - A> >R >R 0 NROT R> ( 0 a1 a2 sz | rega ) + A>R >R 0 NROT R> ( 0 a1 a2 sz | rega ) FOR ( 0 a1 a2 | rega ) OVER >A C@A STRING:CHAR-UPPER OVER >A C@A STRING:CHAR-UPPER - ?DUP IF ( 0 a1 a2 sgn ) >R DROP R> NROT BREAK ENDIF 1+ SWAP 1+ SWAP ENDFOR 2DROP - R> >A SIGN? + R>A SIGN? ; : UCMP ( a b -- -1|0|1 ) @@ -219,9 +219,9 @@ PREVIOUS DEFINITIONS ; : FILL ( addr count byte -- ) - A> >R ROT >A + A>R ROT >A SWAP FOR DUP I C!A+ ENDFOR DROP - R> >A + R>A ; : BLANKS ( addr count -- ) BL FILL ; @@ -235,13 +235,13 @@ PREVIOUS DEFINITIONS \ FOR \ OVER C@ OVER C! 1+ SWAP 1+ SWAP \ ENDFOR 2DROP - A> >R + A>R FOR ( source dest ) SWAP DUP >A 1+ SWAP ( source+1 dest ) -- source in A C@A SWAP DUP >A 1+ SWAP ( source+1 dest+1 c ) -- dest in A C!A ENDFOR 2DROP - R> >A + R>A ; : CMOVE> ( source dest count -- ) @@ -249,14 +249,14 @@ PREVIOUS DEFINITIONS \ ." to=" OVER U. \ ." count=" DUP U. \ CR - A> >R + A>R >R SWAP R@ + SWAP R@ + R> FOR ( source+count dest+count ) SWAP 1- DUP >A SWAP ( source-1 dest ) -- source-1 in A C@A SWAP 1- DUP >A SWAP ( source-1 dest-1 c ) -- dest-1 in A C!A ENDFOR 2DROP - R> >A + R>A ; ;; uses CMOVE or CMOVE> (i.e. works like libc `memmove`) diff --git a/urflibs/init/struct.f b/urflibs/init/struct.f index 269dc02..95abef8 100644 --- a/urflibs/init/struct.f +++ b/urflibs/init/struct.f @@ -131,7 +131,7 @@ ALSO STRUCT-INTERNALS DEFINITIONS : (CHECK-TYPE) ( stx vocid -- ) OVER (ADDR-STRUCT?) " allocated struct expected" ?NOT-ERROR ;; get stx-self - A> >R SWAP >A (SOFS-SELF) @A+ R> >A ( vocid parent-vocid ) + A>R SWAP >A (SOFS-SELF) @A+ R>A ( vocid parent-vocid ) BEGIN DUP " invalid struct type" ?NOT-ERROR 2DUP <> @@ -155,11 +155,11 @@ ALSO STRUCT-INTERNALS DEFINITIONS ; : (@FIELD-DOER) ( stx pfa -- value ) - A> >R SWAP >A (@A-FIELD-DOER) R> >A + A>R SWAP >A (@A-FIELD-DOER) R>A ; : (!FIELD-DOER) ( value stx pfa -- value ) - A> >R SWAP >A (!A-FIELD-DOER) R> >A + A>R SWAP >A (!A-FIELD-DOER) R>A ; ;; check if we aren't defining a struct @@ -312,23 +312,23 @@ ALSO STRUCT-INTERNALS ;; for allocated structs : @SIZE-OF ( stx -- size ) DUP (ADDR-STRUCT?) " allocated struct expected" ?NOT-ERROR - A> >R >A (SOFS-SIZE) @A+ R> >A + A>R >A (SOFS-SIZE) @A+ R>A ; : @PARENT-OF ( stx -- parent-vocid / 0 ) DUP (ADDR-STRUCT?) " allocated struct expected" ?NOT-ERROR - A> >R >A (SOFS-PARENT) @A+ R> >A + A>R >A (SOFS-PARENT) @A+ R>A ; : @ID-OF ( stx -- vocid ) DUP (ADDR-STRUCT?) " allocated struct expected" ?NOT-ERROR - A> >R >A (SOFS-SELF) @A+ R> >A + A>R >A (SOFS-SELF) @A+ R>A ; ;; get name of the structure pointed to by the given vocid : @NAME-OF ( vocid -- addr count ) DUP (ADDR-STRUCT?) " allocated struct expected" ?NOT-ERROR - A> >R >A (SOFS-SELF) @A+ R> >A + A>R >A (SOFS-SELF) @A+ R>A DUP (VOCID-STRUCT?) " struct vocid expected" ?NOT-ERROR COMPILER:(VOCOFS-HEADER) + @ ?DUP IF STRING:NCOUNT ELSE 0 0 ENDIF -- 2.11.4.GIT