commit dceccf2ca00c8133c7c60e3cd508bd203dc100ed
parent 4c1b658bc2ea51c4525a1cb58cc9a46a027e5e8c
Author: Virgil Dupras <hsoft@hardcoded.net>
Date: Wed, 14 Sep 2022 10:39:24 -0400
cc: add signed comparisons
Diffstat:
9 files changed, 37 insertions(+), 25 deletions(-)
diff --git a/fs/app/cos/tools/blkpack.c b/fs/app/cos/tools/blkpack.c
@@ -1,6 +1,5 @@
// This doesn't actually work, I'm just drafting how it would look.
// TODO: string scanning
-// TODO: signed arithmetics
#[ 10 const BUMP_GRANULARITY ]#
diff --git a/fs/asm/i386.fs b/fs/asm/i386.fs
@@ -211,8 +211,8 @@ $04e9 op jmp, $02e8 op call,
dup 16 rshift opreg! $ffff and opmodrm, ;
$0400f7 op mul, $0600f7 op div, $0300f7 op neg, $0200f7 op not,
$0100ff op dec, $0000ff op inc,
-$000f9f op setg, $000f9c op setl, $000f94 op setz, $000f95 op setnz,
-$000f92 op setc, $000f93 op setnc,
+$000f9f op setg, $000f9c op setl, $000f97 op seta, $000f92 op setb,
+$000f94 op setz, $000f95 op setnz, $000f92 op setc, $000f93 op setnc,
$020f01 op lgdt, $030f01 op lidt,
\ Two operands
diff --git a/fs/cc/gen.fs b/fs/cc/gen.fs
@@ -170,7 +170,9 @@ BOPSCNT wordtbl bopgentblpost ( -- )
'w vm<<=,
'w vm>>=,
-: decl>op ( dnode -- ) case
+: decl>op ( dnode -- )
+ dup Declare type typeunsigned? if opsunsigned! then ( dnode )
+ case
of Declare :isglobal? r@ Declare address mem>op endof
of Declare :isarg? r@ Declare address ps+>op endof
r@ Declare address sf+>op
diff --git a/fs/cc/type.fs b/fs/cc/type.fs
@@ -5,14 +5,14 @@
\ All information related to a basic type fits in a 32b integer, so that's
\ how "type" is passed around. Structure:
\ b2:0 = size. 0=0 1=8 2=16 3=32 4+=reserved for future use
-\ b3 = sign. 0=unsigned 1=signed
+\ b3 = sign. 0=signed 1=unsigned
\ 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 ;
+: typeunsigned? ( type -- flags ) 2 rshift 1 and ;
: type*lvl ( type -- lvl ) 3 rshift 3 and ;
: type*lvl! ( lvl type -- type ) $f and swap 3 lshift or ;
: type*lvl+ ( type -- type ) dup type*lvl 1+ swap type*lvl! ;
@@ -39,6 +39,6 @@ create _ 0 c, 1 c, 2 c, 4 c,
typenames sfind dup 0>= if ( type idx ) or 1 else 2drop 0 then ( type ) ;
: printtype ( type -- )
- dup typesigned? if ." unsigned " then
+ dup typeunsigned? if ." unsigned " then
dup 3 and typenames slistiter stype
type*lvl ?dup if >r begin '*' emit next then ;
diff --git a/fs/cc/vm/common.fs b/fs/cc/vm/common.fs
@@ -22,6 +22,7 @@ $14 const VM_*REGISTER \ [eax]
\ 2 operands, 2 fields each (type, arg), 4b per field
create operands 16 allot0
+0 value opsunsigned \ when 1, ops are considered unsigned
operands value 'curop
: selop1 ( -- ) operands to 'curop ;
@@ -36,8 +37,10 @@ operands value 'curop
: 'oparg 'curop 4 + ;
: oparg ( -- arg ) 'oparg @ ;
: oparg! ( arg -- ) 'oparg ! ;
+: opsunsigned! 1 to opsunsigned ;
: .ops selectedop .x1 spc> 4 >r operands begin @+ .x spc> next drop nl> ;
+: _ops$ operands 16 0 fill 0 to opsunsigned ;
\ Managing operands
diff --git a/fs/cc/vm/forth.fs b/fs/cc/vm/forth.fs
@@ -29,9 +29,7 @@ create argsframe MAXARGSZ allot
: opdeinit VM_NONE optype! ;
: opfree optypelo VM_TOS = if compile drop then opdeinit ;
-: ops$
- selop2 opfree selop1 opfree
- operands 16 0 fill ;
+: ops$ selop2 opfree selop1 opfree _ops$ ;
: TOS# selop^ optypelo VM_TOS <> _assert selop^ ;
: op>TOS VM_TOS optype! ;
@@ -143,7 +141,8 @@ unop vm--op, 1-
postop vmop++, 1+
postop vmop--, 1-
-: binop doer ' , does> @ ( w )
+\ 2 fields: signed op, unsigned op
+: binop doer ' , ' , does> opsunsigned if CELLSZ + then @ ( w )
selop1 opCompile* opdeinit \ op1 is "lost" on PS
selop2 hasop# optypelo VM_TOS = if
\ if op2=TOS, we need to swap because our previous opCompile* buried it.
@@ -152,18 +151,19 @@ postop vmop--, 1-
( w ) execute,
selop1 op>TOS ; \ result in op1 as VM_TOS
-binop vmadd, +
-binop vmsub, -
-binop vmmul, *
-binop vm&, and
-binop vm|, or
-binop vm^, xor
-binop vm<<, lshift
-binop vm>>, rshift
-binop vm<, <
-binop vm==, =
-binop vm&&, and
-binop vm||, or
+binop vmadd, + +
+binop vmsub, - -
+binop vmmul, * *
+binop vm&, and and
+binop vm|, or or
+binop vm^, xor xor
+binop vm<<, lshift lshift
+binop vm>>, rshift rshift
+: s< $80000000 + swap $80000000 + swap < ;
+binop vm<, s< <
+binop vm==, = =
+binop vm&&, and and
+binop vm||, or and
\ a binop= is like a unop in the sense that it operates directly on op1, but
\ with the participation of op2.
diff --git a/fs/cc/vm/i386.fs b/fs/cc/vm/i386.fs
@@ -72,7 +72,7 @@ create registers AX c, BX c, CX c, DX c, SI c, DI c,
: ops$
selop2 opdeinit selop1 opdeinit
reglvl if abort" unbalanced reg allot/free" then
- operands 16 0 fill ;
+ _ops$ ;
\ Resolve current operand as an assembler "src" argument.
: opAsm ( -- )
@@ -258,7 +258,7 @@ create registers AX c, BX c, CX c, DX c, SI c, DI c,
: _
selop1 op>reg opAsm selop2 opAsm cmp, opdeinit
selop1 opAsm 0 i) mov, ;
-: vm<, _ opAsm setl, ;
+: vm<, _ opAsm opsunsigned if setb, else setl, then ;
: vm==, _ opAsm setz, ;
: _ ( 'w -- ) selop1 opAsm selop2 opAsm execute opdeinit selop1 vmboolify, ;
: vm&&, ['] and, _ ;
diff --git a/fs/tests/cc/cc.fs b/fs/tests/cc/cc.fs
@@ -39,6 +39,8 @@ capture helloworld S" Hello World!" #s=
42 multret 32 #eq
55 capture multretvoid S" Nope" #s=
42 capture multretvoid S" Answer to the universe" #s=
+-1 0 lts #
+-1 0 ltu not #
\ and what about inline functions?
:cfunc int myinline() { return 42; }
diff --git a/fs/tests/cc/test.c b/fs/tests/cc/test.c
@@ -159,3 +159,9 @@ extern int forbreak() {
}
return i;
}
+extern int lts(int a, int b) {
+ return a < b;
+}
+extern int ltu(unsigned int a, unsigned int b) {
+ return a < b;
+}
