(     Title:  Convert between raw floating-point hex string and
              raw32, raw64, raw80, or raw128 data-stack formats
       File:  rawhex.fs
  Test file:  rawhex-test.fs
   Log file:  rawhex.log
    Version:  0.9.0
    Revised:  July 29, 2009
     Author:  David N. Williams
    License:  LGPL

Version 0.9.0
24Jul09 * Extracted rawhex.fs from version 0.9.0 of mixfloat.fs.
25Jul09 * Added missing ABORT for cells not 32 bits and for
          bits/float not 32, 64, 80, or 128.
        * Extracted rawhex-test.fs from mixfloat-test.fs 0.9.0.
        * Added conditionals to avoid redundancy with
          rawfloat.fs.
28Jul09 * Removed [IF] from behind a comment.
        * Released.

We believe any of this code derived from other authors to be
either in the public domain or otherwise compatible with the
LGPL.  For the sake of the LGPL, the rest is
)
\ Copyright (C) 2003, 2005, 2009  David N. Williams
(
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or at your option any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU Lesser General Public License for more details.

If you take advantage of the option in the LGPL to put a
particular version of this library under the GPL, the author[s]
would regard it as polite if you would put any direct
modifications under the LGPL as well, and include this paragraph
in your license notice.  A direct modification is
one that enhances or extends the library in line with its
original concept, as opposed to developing a distinct
application or library which might use it.

This library is a very simple subset of hexfloat.fs, which only
converts between hex strings and "raw float" formats on the data
stack.  It doesn't know anything about the details of the raw32,
raw64, raw80, or raw128 floating-point formats, just that they
occupy the high bits of enough cells to contain 32, 64, 80, and
128 bits, respectively, with the most significant cell topmost,
the next most significant just below it, and so on, towards the
bottom of the stack.

The hex input strings have to contain exactly 8, 16, 10, and 32
hex digits, with any number of embedded blanks.  The output hex
strings are formatted in 4-digit, blank separated groups.

The floating-point stack is used only to determine the number of
bits in the default float format, to define the default words
RAW>HEX and HEX>RAW.

There is an environmental dependence on lower case.

The library eventually refuses to load if cells are not 32 bits,
and chars are not 8 bits and 1 address unit.

The test file rawhex-test.fs contains syntax examples.

Notation:
"s" or "something.s" in stack comments stands for an ANS
    Forth string [addr len] pair.
"hex" in a word name indicates an ANS Forth string
    representing a raw format as hex digits, including all
    leading zero digits.  A trailing "8", "16", "20", or "32"
    indicates the number of hex digits corresponding to raw32,
    raw60, raw80, and raw64, respectively.
)

\ *** USER WORDS

\ CONSTANTS
\   bits/au  bits/cell  bits/float

\ UTILITY
\   lshift>ud  (qlshift)
\   -spaces  hex>ud  hex>uq
 
\ HEX/RAW CONVERSIONS
\   hex8>raw32  hex16>raw64  hex20>raw80  hex32>raw128
\   raw32>hex8  raw64>hex16  raw80>hex20  raw128>hex32

\   hex>raw  raw>hex

[UNDEFINED] hex>raw [IF]  \ mixraw.fs not loaded

\ *** GENERAL USE

decimal

[UNDEFINED] bits/cell [IF]
s" ADDRESS-UNIT-BITS" environment? 0=
[IF] cr .( ***Can't determine ADDRESS-UNIT-BITS.) ABORT [THEN]
                  constant bits/au
bits/au 1 cells * constant bits/cell
[THEN]

: lshift>ud  ( u +n -- ud' )
(
Assume +n <= BITS/CELL.  Logical shift u to the left by +n bits
into an unsigned double number.
)
  LOCALS| n u |
  n 0=          IF u 0 EXIT THEN
  n bits/cell = IF 0 u EXIT THEN
  u n lshift u bits/cell n - rshift  ;

: (qlshift)  ( q +n -- q' )
(
Assume +n <= BITS/CELL.  Logical shift the quadruple q to the
left by +n bits.
)
  LOCALS| n q0 q1 q2 q3 |
  n bits/cell = IF 0 ELSE q0 n lshift THEN ( q0'.hi)
  q1 n lshift>ud ( q0'.hi q1'.hi q0'.lo)
  rot + ( q0') to q0
  ( q1'.hi) q2 n lshift>ud ( q1'.hi q2'.hi q1'.lo)
  rot + ( q1') to q1
  ( q2'.hi) q3 n lshift>ud ( q2'.hi q3'.hi q2'.lo)
  rot + q1 q0 ;

: -spaces  ( s -- s' )
(
Remove all blanks from the ANS Forth string s and leave the
compacted string s'.  The new string body address is at PAD.
This works even if the input string s starts somewhere in PAD,
but then it may get partially written over.
)
  pad >r
  BEGIN
    ( len) dup 0>
  WHILE
    over c@ bl <>
    IF over c@ r@ c! r> 1+ >r THEN
    1 /string
  REPEAT 2drop
  pad r> pad - ;

: hex>ud  ( s -- ud flag ) 
(
If the string contains only hexadecimal digits with no sign, or
is empty, leave true and the unsigned double number conversion
[0 if there are no digits].  Otherwise leave an undefined ud
result and false.
)
  base @ >r hex
  0 0 2swap >number ( ud rest.s)
  nip 0=   r> base ! ;

: ?hex>ud  ( s -- ud )  hex>ud 0= ABORT"  ***Not a hex string" ;

: hex>uq  ( s -- uq flag ) 
(
If the string contains only hexadecimal digits with no sign, or
is empty, leave true and the unsigned quadruple number
conversion [0 if there are no digits].  Otherwise leave an
undefined uq result and false.
)
  ( len) dup 16 <=
  IF over 0 2swap ELSE 16 - 2dup + 16 THEN ( hi.s lo.s)
  LOCALS| lo.len lo.addr hi.len hi.addr |
  base @ >r hex
  0 0 lo.addr lo.len >number
  IF
    ( lo.ud addr) 0 false
  ELSE  
    ( lo.ud addr) drop 0 0 hi.addr hi.len >number
    ( lo.ud hi.ud addr' len') nip 0=
  THEN  
  r> base ! ;

: ?hex>uq  ( s -- uq )  hex>uq 0= ABORT" ***Not a hex string" ;


\ *** RAW TO HEX

: num>s  ( n -- n.s )
(
Convert the number according to the current BASE to a Forth
string in transient memory.  Traditional.
)
  <# dup >r abs s>d #s r> sign #> ;

(
Because char-counted strings are deprecated, we use "measured
strings" [mstrings], which are strings with an implementation-
defined count-field size.  Our library defaults to cell-size.

In stack comments, a $ suffix indicates the address of an
mstring.
)

: m$>s  ( m$ -- s )  \ COUNT for cell count-field
  >r r@ cell+ ( addr) r> @  ( len) ;

: s-m$+  ( s m$ -- )
(
Append the Forth string to the mstring.  Transliteration of Wil
Baden's APPEND.
)
  2dup 2>r   m$>s +   swap move 2r> +! ;

hex
0000FFFF constant lo16-mask
FFFF0000 constant hi16-mask
decimal

create hex$ 128 chars allot

: 0hex$  ( -- )    0 hex$ ! ;
: hex$>s ( -- )    hex$ m$>s ;
: hex+   ( s -- )  hex$ s-m$+ ;
: bl+    ( -- )    s"  " hex+ ;

: digs+  ( +num #digs -- )
  ( #digs) >r num>s
  r> over ( len) - dup 0< ABORT" ***Too many digits."
  ( #digs-len) 0 ?DO s" 0" hex+ LOOP
  ( num.s) hex+ ;

: bl-4digs+  ( +4.digit.num -- )  bl+ 4 digs+ ;

\ HEX8>RAW32, HEX16>RAW64, HEX20>RAW80, HEX32>RAW128
(
Translate a Forth string representation of a raw floating-point
datum to the corresponding raw format on the data stack.  These
words are for convenience in expressing raw data without concern
for right to left stack notation, and with embedded blanks for
readability.  They all ABORT if the string does not contain
exactly the required number of hex digits.
)

: hex8>raw32  ( hex8.s -- raw32 )
  -spaces dup 8 <> ABORT" ***Not 8 hex digits."
  ?hex>ud ( hi) drop ;

: hex16>raw64  ( hex16.s -- raw64 )
  -spaces dup 16 <> ABORT" ***Not 16 hex digits."
  ?hex>ud ;

: hex20>raw80  ( hex20.s -- raw80 )
  -spaces dup 20 <> ABORT" ***Not 20 hex digits."
  ?hex>uq 16 (qlshift) drop ;

: hex32>raw128  ( hex32.s -- raw128 )
  -spaces dup 32 <> ABORT" ***Not 32 hex digits."
  ?hex>uq ;

\ RAW32>HEX8, RAW64>HEX16, RAW80>HEX20, RAW128>HEX32
(
Translate the raw formats to hex strings of hex digits formatted
in 4-digit, blank-separated groups.
)

: u>hex+  ( u -- )
(
Translate u to a string of 8 hex digits, in two 4-digit,
blank-separated groups, and append it to hex$.
)
  base @ >r hex dup hi16-mask and 16 rshift 4 digs+
  lo16-mask and bl-4digs+ r> base ! ;

: raw32>hex8   ( raw32 -- hex8.s )   0hex$ u>hex+ hex$>s ;
: raw64>hex16  ( raw64 -- hex16.s )  0hex$ u>hex+ bl+ u>hex+ hex$>s ;

: raw80>hex20  ( raw80 -- hex20.s )
  0hex$ u>hex+ bl+ u>hex+ bl+ u>hex+ hex$>s 5 - ;

: raw128>hex32  ( raw128 -- hex32.s )
  0hex$ u>hex+ 3 0 DO bl+ u>hex+ LOOP hex$>s ;


\ *** WORDS SPECIFIC TO DEFAULT FLOAT FORMAT
(
This code will abort if a Forth char is not 8 bits, if a cell is
not 32 bits, or if the default float format is not 32, 64, 80,
or 128 bits.
)
decimal

bits/au 1 chars * 8 <> [IF] cr
  .( ***1 CHARS is not 8 bits.) ABORT [THEN]
bits/cell 32 <> [IF] cr
  .( ***bits/cell is ) bits/cell . .( bits, not 32) ABORT [THEN]

\ Use this instead for pfe's integrated fp stack option:
\ s" FPNOSTACK-EXT"
s" FLOATING-EXT"
environment? [IF] ( flag) drop
[ELSE] cr .( ***Floating point not available.) ABORT [THEN]

1 floats 16 >
[IF] cr .( ***1 FLOATS is too big.) ABORT [THEN]

[UNDEFINED] bits/float [IF]
MARKER -FIND-BITS/FLOAT

[UNDEFINED] QFALIGNED [IF]
  : qfaligned  ( addr -- addr' )  127 + [ 127 invert ] literal and ;
[THEN]
[UNDEFINED] QFALIGN [IF]
  : qfalign  ( -- )  here qfaligned here - allot ;
[THEN]

qfalign here 5 cells allot constant qfpad  \ 1 extra cell

qfpad 4 cells 1+ char U fill

: #fbytes  ( -- #bytes )
  0 4 cells 1+ 0
  DO drop i qfpad i + c@ [char] U = IF LEAVE THEN LOOP ;

1E qfpad f! #fbytes ( #bytes) bits/au *

-FIND-BITS/FLOAT ( bits/float)
    constant bits/float
[THEN]

bits/float 32 =     bits/float 64 = or
bits/float 80 = or  bits/float 128 = or
0= [IF] cr
  .( ***Unrecognized float format, bits/float = )
  bits/float . ABORT [THEN]

: hex>raw  ( hex.s -- raw.default )
  [ bits/float 32 = ]  [IF] hex8>raw32 [ELSE]
  [ bits/float 64 = ]  [IF] hex16>raw64 [ELSE]
  [ bits/float 80 = ]  [IF] hex32>raw80 [ELSE]
  [ bits/float 128 = ] [IF] hex64>raw128 [THEN] [THEN] [THEN] [THEN] ;

: raw>hex  ( raw64.default -- hex.s )
  [ bits/float 32 = ]  [IF] raw32>hex8 [ELSE]
  [ bits/float 64 = ]  [IF] raw64>hex16 [ELSE]
  [ bits/float 80 = ]  [IF] raw80>hex32 [ELSE]
  [ bits/float 128 = ] [IF] raw128>hex64 [THEN] [THEN] [THEN] [THEN] ;

[THEN]  \ HEX>RAW