commit b5a4a9afe8eae70bf0adc1664de5285c2c4f5cd5
parent 388f40446ef4d4499c191eb54cd7f24da4bb1b7c
Author: Virgil Dupras <hsoft@hardcoded.net>
Date: Wed, 14 Sep 2022 06:58:49 -0400
cc: parse EMETA_SIGCNT when calling words from system dict
When the signature is correct, properly infer the return type "unsigned int".
Otherwise, infer "void", as before.
Diffstat:
7 files changed, 27 insertions(+), 14 deletions(-)
diff --git a/fs/cc/gen.fs b/fs/cc/gen.fs
@@ -44,8 +44,9 @@
\ 5. restore the result to Op1.
\ cc/vm abstracts away the save/restore mechanism through oppush/oppop.
-?f<< lib/wordtbl.fs
-?f<< cc/ast.fs
+?f<< /lib/wordtbl.fs
+?f<< /lib/meta.fs
+?f<< /cc/ast.fs
\ This unit also requires vm/(ARCH).fs, but it's loaded in cc/cc.fs
: _err ( -- ) abort" gen error" ;
@@ -66,6 +67,8 @@ alias noop gennode ( node -- ) \ forward declaration
( name name fnode ) Function :finddecl ?dup not if ( name )
Unit :find else nip then dup to lastidentfound ;
+: wordfunctype ( w -- type ) wordsig nip 1 = if TYPE_UINT else TYPE_VOID then ;
+
\ Multiply the value of "node" by a factor of "n"
\ TODO: support lvalues and expressions
: node*=n ( n node -- )
@@ -256,15 +259,16 @@ ASTIDCNT wordtbl gentbl ( node -- )
\ Resolve address node
0 to lastidentfound
dup Node firstchild gennode \ op has call address
- lastidentfound swap
- oppush rot ( funcident oparg optype node )
+ lastidentfound ?dup if
+ dup Node id AST_FUNCTION = if Function type else drop TYPE_VOID then
+ else optype VM_*CONSTANT = if oparg wordfunctype else TYPE_VOID then then
+ ( node type ) swap oppush rot ( type oparg optype node )
\ pass arguments
selop1 Node firstchild begin ( argnode )
Node nextsibling ?dup while ( argnode )
dup gennode vmcallarg, repeat
\ call
- oppop vmcall, ( funcident ) ?dup if dup Node id AST_FUNCTION = if
- Function type if selop1 vmpspop, then else drop then then ;
+ oppop vmcall, ( type ) if selop1 vmpspop, then ;
:w ( For )
Node firstchild dup _assert dup gennode ops$ ( exprnode ) \ initialization
here swap ( loop_addr node )
diff --git a/fs/cc/type.fs b/fs/cc/type.fs
@@ -8,6 +8,9 @@
\ b3 = sign. 0=unsigned 1=signed
\ b6:4 = *lvl. Indirection levels, from 0 to 7.
+0 const TYPE_VOID
+4 const TYPE_UINT
+
4 stringlist typenames "void" "char" "short" "int"
: typesigned? ( type -- flags ) 2 rshift 1 and ;
: type*lvl ( type -- lvl ) 3 rshift 3 and ;
diff --git a/fs/lib/meta.fs b/fs/lib/meta.fs
@@ -26,3 +26,8 @@
: 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
@@ -22,7 +22,7 @@ extends IO struct[ MemIO
: _maxn ( n hdl -- real-n ) >r V1 ptr + V1 bufsz min r> ptr - ;
: _readbuf ( n hdl -- a? read-n )
>r V1 _maxn ( read-n ) dup if V1 :ptr swap dup V1 to+ ptr then rdrop ;
- : _writebuf ( a n hdl -- written-n ) 'X' emit
+ : _writebuf ( a n hdl -- written-n )
>r V1 _maxn ( a write-n ) dup if ( a write-n )
tuck V1 :ptr swap ( write-n a dst n ) move ( write-n ) dup V1 to+ ptr
else nip then rdrop ;
diff --git a/fs/tests/cc/test.c b/fs/tests/cc/test.c
@@ -116,8 +116,7 @@ extern int global() {
}
// "max" is a forth word defined in the system
extern int sysword(int a, int b) {
- max(a, b);
- return pspop();
+ return max(a, b);
}
extern void helloworld() {
stype("Hello World!");
diff --git a/fs/tests/kernel.fs b/fs/tests/kernel.fs
@@ -17,6 +17,7 @@ to' foo @ 48 #eq
\ signatures
' 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
diff --git a/fs/xcomp/bootlo.fs b/fs/xcomp/bootlo.fs
@@ -171,7 +171,8 @@ alias noop [then]
: llprev ( tgt ll -- prev )
begin 2dup llnext = not while llnext ?dup while repeat
abort" llprev failed" then nip ;
-: lladd ( ll -- newll ) HERE @ swap llend ! HERE @ 0 , ;
+: llappend ( elem ll -- ) llend ! ;
+: 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> ;
@@ -180,13 +181,13 @@ alias noop [then]
\ 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 -- ) nextmeta lladd drop EMETA_SIGCNT , swap c, c, ;
+: 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 sigcnt, ;
+ -1 begin ( cnt ) 1+ word S" )" s= until nextmeta sigcnt, ;
-: value 0 1 sigcnt, doer , immediate does> ['] @ toexec ;
-: ivalue 0 1 sigcnt, doer , immediate does> @ ['] @ toexec ;
+: value 0 1 nextmeta sigcnt, doer , immediate does> ['] @ toexec ;
+: ivalue 0 1 nextmeta sigcnt, doer , immediate does> @ ['] @ toexec ;
HERE ivalue here
\ Alias chaining. See doc/usage.
