Commit 37f3ac86 authored by bernd's avatar bernd

Floating point with variable length encoding

parent 15f95246
......@@ -76,6 +76,7 @@ cell 8 = [IF]
: 128! ( d addr -- ) >r swap r> 2! ;
also locals-types definitions
' w: alias 64:
' w^ alias 64^
previous definitions
[ELSE]
' 2swap alias 64rot
......@@ -107,12 +108,20 @@ cell 8 = [IF]
' dnegate Alias 64negate
0. 2Constant 64#0
-1. 2Constant 64#-1
: 64lshift ( u64 u -- u64' ) >r
r@ lshift over 8 cells r@ - rshift or
swap r> lshift swap ;
: 64rshift ( u64 u -- u64' ) >r swap
r@ rshift over 8 cells r@ - lshift or
swap r> rshift ;
: 64lshift ( u64 u -- u64' )
dup $20 u>= IF
nip $20 - lshift 0 swap
ELSE >r
r@ lshift over 8 cells r@ - rshift or
swap r> lshift swap
THEN ;
: 64rshift ( u64 u -- u64' )
dup $20 u>= IF
$20 - rshift nip 0
ELSE >r swap
r@ rshift over 8 cells r@ - lshift or
swap r> rshift
THEN ;
' d>f Alias 64>f
' f>d Alias f>64
' d= Alias 64=
......@@ -169,6 +178,7 @@ cell 8 = [IF]
r> 3 cells + ! ;
also locals-types definitions
' d: alias 64:
' d^ alias 64^
previous definitions
[THEN]
\ independent of cell size, using dfloats:
......
......@@ -119,13 +119,26 @@ User t-stack
t-stack $[]# 1- dup 0< !!object-empty!!
t-stack $[] @ t-stack $@len cell- t-stack $!len ;
\ floats assume unaligned float access is possible
\ i.e. so far, they are unused stubs ;-)
: pdf@ ( -- r )
buf-state 2@ over + >r dup df@ dfloat+ r> over - buf-state 2! ;
: psf@ ( -- r )
buf-state 2@ over + >r dup sf@ sfloat+ r> over - buf-state 2! ;
\ float are stored big endian.
: pf@+ ( addr u -- addr' u' r )
2>r 64 64#0 2r> bounds ?DO
7 64lshift I c@ $7F and n>64 64+ 64>r 7 - 64r>
I c@ $80 and 0= IF
n64-swap 64lshift
0e { f^ pftmp } pftmp 64! pftmp f@
I 1+ I' over - unloop EXIT THEN
LOOP true !!floatfit!! ;
: pf!+ ( addr r -- addr' ) { f^ pftmp }
BEGIN
pftmp 64@ 57 64rshift 64>n
pftmp 64@ 7 64lshift 64dup pftmp 64!
64-0<> WHILE $80 or over c! 1+ REPEAT
over c! 1+ ;
: pf@ ( -- r )
buf-state 2@ pf@+ buf-state 2! ;
\ Command streams contain both commands and data
\ the dispatcher is a byte-wise dispatcher, though
......@@ -168,10 +181,9 @@ Defer gen-table
1 of p@ 64. ." lit, " endof
2 of ps@ s64. ." slit, " endof
3 of string@ n2o.string endof
4 of pdf@ f. ." dfloat, " endof
5 of psf@ f. ." sfloat, " endof
6 of ." endwith " cr t-pop token-table ! endof
7 of ." oswap " cr token-table @ t-pop token-table ! t-push endof
4 of pf@ f. ." float, " endof
5 of ." endwith " cr t-pop token-table ! endof
6 of ." oswap " cr token-table @ t-pop token-table ! t-push endof
.net2o-name
0 endcase ]hex ;
......@@ -229,10 +241,8 @@ get-current also net2o-base definitions previous
ps@ ;
+net2o: string ( "string" -- $:string ) \ string literal
string@ ;
+net2o: dflit ( "dfloat" -- r ) \ double float literal
pdf@ ;
+net2o: sflit ( "sfloat" -- r ) \ double float literal
psf@ ;
+net2o: flit ( "dfloat" -- r ) \ double float literal
pf@ ;
+net2o: endwith ( o:current -- ) \ pop object stack
n:o> ;
+net2o: oswap ( o:nest o:current -- o:current o:nest )
......@@ -272,6 +282,7 @@ User cmdbuf#
: cmdreset cmdbuf# off ;
: cmd, ( 64n -- ) cmdbuf$ + dup >r p!+ r> - cmdbuf+ ;
: flit, ( 64n -- ) cmdbuf$ + dup >r pf!+ r> - cmdbuf+ ;
: net2o, @ n>64 cmd, ;
......@@ -413,8 +424,7 @@ also net2o-base definitions
: slit, ( n -- ) slit n>zz cmd, ;
: nlit, ( n -- ) n>64 slit, ;
: ulit, ( u -- ) u>64 lit, ;
: sfloat, ( r -- ) sflit cmdbuf$ + sf! 1 sfloats cmdbuf+ ;
: dfloat, ( r -- ) sflit cmdbuf$ + df! 1 dfloats cmdbuf+ ;
: float, ( r -- ) flit flit, ;
: flag, ( flag -- ) IF tru ELSE fals THEN ;
: (end-code) ( -- ) expect-reply? cmd cmdlock unlock ;
: end-code ( -- ) (end-code) previous ;
......
......@@ -26,6 +26,7 @@ s" wrong packet size" throwcode !!size!!
s" no power of two" throwcode !!pow2!!
s" unimplemented net2o function" throwcode !!function!!
s" too many commands" throwcode !!commands!!
s" float does not fit" throwcode !!floatfit!!
s" string does not fit" throwcode !!stringfit!!
s" ivs must be 64 bytes" throwcode !!ivs!!
s" net2o timed out" throwcode !!timeout!!
......
......@@ -83,6 +83,8 @@ UValue statbuf
' umax! Alias 64umax!
' !@ Alias 64!@
[ELSE]
: dumin ( ud1 ud2 -- ud3 ) 2over 2over du> IF 2swap THEN 2drop ;
: dumax ( ud1 ud2 -- ud3 ) 2over 2over du< IF 2swap THEN 2drop ;
: 64!@ ( value addr -- old-value ) >r r@ 64@ 64swap r> 64! ;
: 64min! ( d addr -- ) >r r@ 64@ dmin r> 64! ;
: 64max! ( d addr -- ) >r r@ 64@ dmax r> 64! ;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment