commit 39758c47430b9d5cf0b8989ab82f983f1b64599b
parent 14ca909f3d424d6a926f12414c4ca0e38f9c17f2
Author: Virgil Dupras <hsoft@hardcoded.net>
Date: Fri, 2 Dec 2022 21:09:53 -0500
comp/c: simplify Forth proxying mechanism
We scrap the "signature metadata" system and now we simply have C units (or the
stdlib) declare prototypes for Forth words they want to use.
See doc/cc/usage
Diffstat:
11 files changed, 116 insertions(+), 106 deletions(-)
diff --git a/fs/comp/c/lib.fs b/fs/comp/c/lib.fs
@@ -4,52 +4,68 @@
?f<< /lib/str.fs
?f<< /lib/fmt.fs
-0 const NULL
-(S str -- len )
+\ A few system word proxies
+:c void abort();
+:c unsigned int min(unsigned int a, unsigned int b);
+:c unsigned int max(unsigned int a, unsigned int b);
+:c void stype(char *str);
+:c int StdIn();
+:c int StdOut();
+:c int ConsoleIn();
+:c int ConsoleOut();
+:c unsigned char stdin();
+:c void stdout(unsigned char c);
+
: strlen c@ ;
-(S a c n -- )
-: memset swap fill ;
+:c unsigned int strlen(char *str);
-$100 MemFile :new const _sfile
+: memset swap fill ;
+:c void memset(char *a, char c, unsigned int n);
-(S hdl -- c )
: fgetc IO :getc ;
-(S c hdl -- )
+:c char fgetc(int hdl);
: fputc IO :putc ;
-(S c hdl -- )
+:c void fputc(char c, int hdl);
: fputback IO :putback ;
-(S hdl -- str-or-0 )
+:c void fputback(char c, int hdl);
: freadline IO :readline ;
-(S str -- hdl )
+:c char* freadline(int hdl);
: fopen curpath :find# Path :open ;
-(S a n hdl -- )
+:c int fopen(char *path);
+
: fread IO :read ;
-(S a n hdl -- )
+:c void fread(char *a, unsigned int n, int hdl);
+
: fwrite IO :write ;
-(S 'a n hdl -- read-n )
+:c void fwrite(char *a, unsigned int n, int hdl);
: freadbuf IO :readbuf ( 'a a? read-n ) dup if ( 'a a read-n )
rot> swap ! else ( 'a 0 ) nip then ;
-(S a n hdl -- written-n )
+:c unsigned int freadbuf(char **a, unsigned int n, int hdl);
: fwritebuf IO :writebuf ;
-(S pos hdl -- )
+:c unsigned int fwritebuf(char *a, unsigned int n, int hdl);
: fseek File :seek ;
-(S hdl -- )
+:c void fseek(unsigned int pos, int hdl);
: fclose IO :close ;
+:c void fclose(int hdl);
-(S str hdl -- )
: fputs IO :puts ;
+:c void fputs(char *str, int hdl);
: puts ( str ) StdOut fputs ;
+:c void puts(char *str);
: fprintf IO :printf ;
+:c void fprintf(char *fmt, int hdl);
: printf ( .. n1? n0? fmt -- ) StdOut fprintf ;
+:c void printf(char *fmt);
-(S ... fmt -- str )
+$100 MemFile :new const _sfile
: sprintf
1 to _sfile MemFile pos _sfile fprintf
_sfile MemFile pos 1- ( len ) _sfile MemFile :buf( tuck c! ;
+:c char* sprintf(char *fmt);
-(S c -- f )
: isdigit 0-9? ;
+:c int isdigit(char c);
:c void fscanf() {
void *iohdl = pspop();
@@ -94,12 +110,12 @@ $100 MemFile :new const _sfile
pspush(res);
}
-(S fmt -- f )
: scanf StdOut fscanf ;
-(S fmt str -- f )
+:c int scanf(char* fmt);
: sscanf
0 _sfile MemFile :seek c@+ _sfile IO :write
0 _sfile MemFile :seek _sfile fscanf ;
+:c int sscanf(char* fmt, char *str);
:c struct File {
unsigned int putback;
diff --git a/fs/comp/c/pgen.fs b/fs/comp/c/pgen.fs
@@ -31,7 +31,6 @@ $400 const MAXLITSZ
: spit ( a u -- ) swap >r >r begin
r@ 40 mod not if nl> then
8b to@+ V1 .x1 next rdrop ;
-: wordfunctype ( w -- type ) wordsig nip 1 = if TYPE_UINT else TYPE_VOID then ;
\ Unary operators
7 const UOPSCNT
@@ -195,15 +194,12 @@ alias noop parseFactor ( tok -- ) \ forward declaration
\ we have a func call and its target in in vmop
: _funcall ( -- )
- vmop type ctype? if
- \ We either have a direct function signature or a pointer to it.
- \ TODO: :funcptr? doesn't work correctly here. fix this
- vmop type ctype'
- dup CType :funcsig? not if CType type ctype' then
- dup CType :funcsig? _assert CType type
- else
- vmop loc VM_CONSTANT =
- if vmop arg wordfunctype else TYPE_VOID then then ( type )
+ vmop type ctype? _assert
+ \ We either have a direct function signature or a pointer to it.
+ \ TODO: :funcptr? doesn't work correctly here. fix this
+ vmop type ctype'
+ dup CType :funcsig? not if CType type ctype' then
+ dup CType :funcsig? _assert CType type ( type )
')' readChar? if 0 else ( type tok )
to nexttputback vmop :push >r \ V1=callop
MAXARGCNT CELLSZ * Stack SZ +
@@ -290,11 +286,7 @@ MAXLITSZ Stack :new structbind Stack _list
nextt parseFactor ( opid ) \ vmop is set
uopgentbl swap wexec endof
of isIdent? \ lvalue, FunCall or macro
- r@ findIdent ?dup if ctype>op else
- r@ sysdict @ find ?dup not if r@ stype abort" not found" then
- TYPE_VOID to vmop type const>op then
- parsePostfixOp
- endof
+ r@ findIdent ?dup _assert ctype>op parsePostfixOp endof
r@ parse if const>op else _err then
endcase ;
current to parseFactor
@@ -432,8 +424,13 @@ current to parseStatement
0 to _curfunc ;
: parseFunctionProto ( ctype tok -- )
- ';' expectChar dup CType :incomplete! dup addSymbol
- here swap to CType offset -1 vmjmp, ;
+ ';' expectChar dup addSymbol curstatic if
+ dup CType :incomplete! here ['] _err vmjmp,
+ \ allot a little extra space in case the replacement jump is wider
+ CELLSZ allot
+ else dup CType name sysdict @ find ?dup not if
+ CType name stype abort" not found" then then ( ctype addr )
+ swap to CType offset ;
: parseGlobalDecl ( ctype -- )
dup addSymbol
diff --git a/fs/doc/cc/lib.txt b/fs/doc/cc/lib.txt
@@ -12,6 +12,19 @@ ensure that it's loaded with `?f<< /comp/c/lib.fs`.
## Standard Library API
+### Proxied Forth words
+
+void abort();
+unsigned int min(unsigned int a, unsigned int b);
+unsigned int max(unsigned int a, unsigned int b);
+void stype(char *str);
+int StdIn();
+int StdOut();
+int ConsoleIn();
+int ConsoleOut();
+unsigned char stdin();
+void stdout(unsigned char c);
+
### Strings
unsigned char strlen(char *str)
diff --git a/fs/doc/cc/usage.txt b/fs/doc/cc/usage.txt
@@ -58,25 +58,6 @@ are a few differences:
to write that?!?) must be written as "a ? (b ? c : d) : (e ? f : g)"
* The keyword "static" has a slightly different meaning. See below.
-## Calling Forth words
-
-Words from the system dictionary can be called. They are considered to have a
-void return type and an unspecified number of arguments.
-
-Arguments to Forth words can be passed normally, but return values have to be
-handled with pspop() and pspush(). Whenever you call such a function, you should
-return to "PS normality" before using one of your function arguments, because if
-you don't, PS offsets for those arguments will be wrong.
-
-For example, let's say that you want to call "max", a forth word with a
-signature "a b -- n". You would do so like this:
-
-int mymax(int a, int b) {
- max(a, b);
- // don't use a or b before having called pspop(), they're broken.
- return pspop();
-}
-
## Pre-processor
The pre-processor allows you to define text expansion macros which can then be
@@ -100,6 +81,40 @@ is the exact same equivalent to:
int bar() { return 42; }
+## Function prototypes
+
+A function prototype is a function without a body. Examples:
+
+ static int foo(short a, char b);
+ unsigned int max(unsigned int a, unsigned int b);
+
+There are two types of prototypes, static and non-static, with both a completely
+different usage.
+
+Static prototypes are for forward declarations. When you declare them, it
+allocates enough space for a jump. Then, when the real function is declared, it
+writes a jump to itself in that reserved space.
+
+The static attribute of the prototype is not carried to the implementation
+function. You can very well have a prototype (which uses "static") that is a
+forward declaration to a non-static implementation.
+
+The non-static prototype is to allow C to call Forth words. By default, C has no
+visibility to the Forth dictionary because Forth words don't have C function
+signatures. When you declare a static function prototype, the CC looks into the
+system dictionary for a word of that name and links that symbol to the found
+word. There's an error if not found.
+
+You can only link words that have a signature compatible with C, that is: 0 or 1
+return value.
+
+Be aware that if you link words that do fancy things like shrinking PS or that
+modifying RS, you are on risky grounds and you should know what you do. The best
+approach with these situation is to proxy the word as "void()" and use "pspop()"
+and "pspush()" for argument passing.
+
+Also, note that CC's lib (doc/cc/lib) already proxies quite a few system words.
+
## Symbols, types and macro visibility and lifetime
The C compiler create two kinds of artifacts: types and symbols.
diff --git a/fs/lib/meta.fs b/fs/lib/meta.fs
@@ -22,13 +22,3 @@ ENTRYSZ neg &+ 'emeta
: .doc ( w -- ) emeta begin ( ll )
EMETA_DOCLINE swap findemeta ?dup while ( ll )
dup 'emetadata begin c@+ dup emit LF = until drop llnext repeat ;
-
-\ Signature
-: wordsig ( w -- argcnt retcnt )
- emeta EMETA_SIGCNT swap findemeta dup if ( ll )
- 'emetadata dup c@ swap 1+ c@ else ( 0 ) 0 then ;
-
-\ Define signatures for some words defined before (S
-: _ nextmeta @ ' 'emeta llappend 0 nextmeta ! ;
-(S a b -- n ) _ max
-(S a b -- n ) _ min
diff --git a/fs/sys/io.fs b/fs/sys/io.fs
@@ -21,7 +21,6 @@ struct+[ IO
create _buf( $100 allot
here value _)buf
- (S hdl -- str-or-0 )
: :readline
dup :getc dup 0< if ( EOF ) 2drop 0 exit then ( hdl c )
swap >r _buf( 1+ >r begin ( c ) \ V1=hdl V2=buf
@@ -33,9 +32,7 @@ struct+[ IO
-1 V1 :readbuf ?dup while ( a n ) V2 :write repeat rdrop rdrop ;
]struct
-(S -- c )
: stdin StdIn IO :getc ;
-(S c -- )
: stdout StdOut IO :putc ;
: stdio$ ConsoleIn to StdIn ConsoleOut to StdOut ;
diff --git a/fs/tests/comp/c/cc.fs b/fs/tests/comp/c/cc.fs
@@ -39,8 +39,7 @@ global 1234 #eq
globalinc 1236 #eq
globalinc 1238 #eq
1 globalshort 2 #eq
-42 142 sysword 142 #eq
-42 142 funcsig 142 #eq
+42 142 funcsig 184 #eq
capture helloworld S" Hello World!" #s=
create expected ," Null terminated\0"
nullstr expected 16 []= #
diff --git a/fs/tests/comp/c/lib.fs b/fs/tests/comp/c/lib.fs
@@ -3,6 +3,12 @@
?f<< comp/c/lib.fs
testbegin
\ Tests for the C library
+\ "max" is a forth word defined in the system
+:c int sysword(int a, int b) {
+ return max(a, b);
+}
+42 142 sysword 142 #eq
+
:c int foo() { return strlen("Hello World!"); }
foo 12 #eq
@@ -22,6 +28,7 @@ S" bar" 42 43 44 45 capture foo S" foo 45 2c 002b 0000002a bar" #s=
capture foo S" Hello World!" #s=
$20 MemFile :new const memfile
+:c int memfile();
S" What about this?" const s
:c void foo() { fputs("What about this?", memfile()); }
foo
diff --git a/fs/tests/comp/c/test.c b/fs/tests/comp/c/test.c
@@ -156,18 +156,13 @@ short globalshort(int idx) {
return shortarray[idx];
}
-// "max" is a forth word defined in the system
-int sysword(int a, int b) {
- return max(a, b);
-}
-
-typedef unsigned int (*MaxSig)(unsigned int, unsigned int);
-// Same as above, but through a function signature typedef
+typedef unsigned int (*AdderSig)(unsigned int, unsigned int);
int funcsig(int a, int b) {
- MaxSig fn = max;
+ AdderSig fn = adder;
return fn(a, b);
}
+void stype(char *str);
static char *msgs[1] = {"Hello World!"};
void helloworld() {
stype(msgs[0]);
diff --git a/fs/tests/lib/meta.fs b/fs/tests/lib/meta.fs
@@ -1,17 +1,6 @@
?f<< /tests/harness.fs
?f<< /lib/meta.fs
testbegin
-\ signatures
-42 value foo
-' foo wordsig 1 #eq 0 #eq
-' here wordsig 1 #eq 0 #eq
-' max wordsig 1 #eq 2 #eq
-(S a b c -- d e )
-: someword ;
-' someword wordsig 2 #eq 3 #eq
-: someword ;
-' someword wordsig 0 #eq 0 #eq
-
\ metadata
: bar ;
' bar emeta 0 #eq
diff --git a/fs/xcomp/bootlo.fs b/fs/xcomp/bootlo.fs
@@ -104,6 +104,9 @@ create _ 0 ,
: toexec ( a w -- ) compiling if
swap litn 0 toptr @! ?dup if nip then execute, else
0 toptr @! ?dup if nip then execute then ;
+: value doer , immediate does> ['] @ toexec ;
+: ivalue doer , immediate does> @ ['] @ toexec ;
+HERE ivalue here
: _ @ execute ;
: alias ' doer , immediate does> ['] _ toexec ;
: ialias doer , immediate does> @ ['] _ toexec ;
@@ -154,8 +157,8 @@ $20 const SPC $0d const CR $0a const LF $08 const BS
\ emit all chars of "str"
: stype ( str -- ) c@+ rtype ;
: S" ( comp: -- ) ( not-comp: -- str )
- compiling if compile (s) else HERE @ then
- HERE @ 1 allot HERE @ ," HERE @ -^ ( 'len len ) swap c! ; immediate
+ compiling if compile (s) else here then
+ here 1 allot here ," here -^ ( 'len len ) swap c! ; immediate
: ."
compiling if [compile] S" compile stype else
begin "< dup 0>= while emit repeat drop then ; immediate
@@ -174,25 +177,14 @@ alias noop [then]
begin 2dup llnext = not while llnext ?dup while repeat
abort" llprev failed" then nip ;
: llappend ( elem ll -- ) llend ! ;
-: lladd ( ll -- newll ) HERE @ swap llappend HERE @ 0 , ;
-: llinsert ( 'll -- newll ) HERE @ over @ , ( 'll newll ) dup rot ! ;
+: lladd ( ll -- newll ) here swap llappend here 0 , ;
+: llinsert ( 'll -- newll ) here over @ , ( 'll newll ) dup rot ! ;
: llcnt ( ll -- count ) 0 >r begin ?dup while 1 to+ V1 llnext repeat r> ;
\ Entry metadata
1 const EMETA_DOCLINE \ a doc strings that ends with LF
\ a \\ comment goes before the creation of the word it comments
: \\ nextmeta lladd drop EMETA_DOCLINE , begin IN< @ execute dup c, LF = until ;
-2 const EMETA_SIGCNT \ 1b arg count, 1b result count
-: sigcnt, ( argcnt retcnt ll -- ) lladd drop EMETA_SIGCNT , swap c, c, ;
-: (S -1 begin ( cnt )
- 1+ word S" )" s= if abort" not a signature" then curword S" --" s= until
- -1 begin ( cnt ) 1+ word S" )" s= until nextmeta sigcnt, ;
-
-: value 0 1 nextmeta sigcnt, doer , immediate does> ['] @ toexec ;
-: ivalue 0 1 nextmeta sigcnt, doer , immediate does> @ ['] @ toexec ;
-HERE ivalue here
-\ re-declare with sigcnt
-: const 0 1 nextmeta sigcnt, code litn exit, ;
\ Alias chaining. See doc/usage.
: _ ( 'target 'alias -- )
