Floating point with variable length encoding

64bit.fs

@@ -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:

net2o-cmd.fs

@@ -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 ;

net2o-err.fs

@@ -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!!

net2o.fs

@@ -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! ;