forth/lib/64bit.fs

   1 \
   2 \ Copyright (C) 2009 Stefan Reinauer
   3 \
   4 \ See the file "COPYING" for further information about
   5 \ the copyright and warranty status of this work.
   6 \
   7
   8 \ Implementation of IEEE Draft Std P1275.6/D5
   9 \ Standard for Boot (Initialization Configuration) Firmware
  10 \ 64 Bit Extensions
  11
  12
  13 cell /x = constant 64bit?
  14
  15 64bit? [IF]
  16
  17 : 32>64 ( 32bitsigned -- 64bitsigned )
  18   dup 80000000 and if           \ is it negative?
  19     ffffffff00000000 or         \ then set all high bits
  20   then
  21 ;
  22
  23 : 64>32 ( 64bitsigned -- 32bitsigned )
  24   h# ffffffff and
  25 ;
  26
  27 : lxjoin ( quad.lo quad.hi -- o )
  28   d# 32 lshift or
  29 ;
  30
  31 : wxjoin ( w.lo w.2 w.3 w.hi -- o )
  32   wljoin >r wljoin r> lxjoin
  33 ;
  34
  35 : bxjoin ( b.lo b.2 b.3 b.4 b.5 b.6 b.7 b.hi -- o )
  36   bljoin >r bljoin r> lxjoin
  37 ;
  38
  39 : <l@ ( qaddr -- n )
  40   l@ 32>64
  41 ;
  42
  43 : unaligned-x@ ( addr - o )
  44   dup la1+ unaligned-l@ 64>32 swap unaligned-l@ 64>32 lxjoin
  45 ;
  46
  47 : unaligned-x! ( o oaddr -- )
  48   >r dup d# 32 rshift r@ unaligned-l!
  49   h# ffffffff and r> la1+ unaligned-l!
  50 ;
  51
  52 : x@ ( oaddr -- o )
  53   unaligned-x@ \ for now
  54 ;
  55
  56 : x! ( o oaddr -- )
  57   unaligned-x! \ for now
  58 ;
  59
  60 : (rx@) ( oaddr - o )
  61   x@
  62 ;
  63
  64 : (rx!) ( o oaddr -- )
  65   x!
  66 ;
  67
  68 : x, ( o -- )
  69   here /x allot x!
  70 ;
  71
  72 : /x* ( nu1 -- nu2 )
  73   /x *
  74 ;
  75
  76 : xa+ ( addr1 index -- addr2 )
  77   /x* +
  78 ;
  79
  80 : xa1+ ( addr1 -- addr2 )
  81   /x +
  82 ;
  83
  84 : xlsplit ( o -- quad.lo quad.hi )
  85   dup h# ffffffff and swap d# 32 rshift
  86 ;
  87
  88 : xwsplit ( o -- w.lo w.2 w.3 w.hi )
  89   xlsplit >r lwsplit r> lwsplit
  90 ;
  91
  92 : xbsplit ( o -- b.lo b.2 b.3 b.4 b.5 b.6 b.7 b.hi )
  93   xlsplit >r lbsplit r> lbsplit
  94 ;
  95
  96 : xlflip ( oct1 -- oct2 )
  97   xlsplit swap lxjoin
  98 ;
  99
 100 : xlflips ( oaddr len -- )
 101   bounds ?do
 102     i unaligned-x@ xlflip i unaligned-x!
 103   /x +loop
 104 ;
 105
 106 : xwflip ( oct1 -- oct2 )
 107   xlsplit lwflip swap lwflip lxjoin
 108 ;
 109
 110 : xwflips ( oaddr len -- )
 111   bounds ?do
 112     i unaligned-x@ xwflip i unaligned-x! /x
 113   +loop
 114 ;
 115
 116 : xbflip ( oct1 -- oct2 )
 117   xlsplit lbflip swap lbflip lxjoin
 118 ;
 119
 120 : xbflips ( oaddr len -- )
 121   bounds ?do
 122     i unaligned-x@ xbflip i unaligned-x!
 123   /x +loop
 124 ;
 125
 126 \ : b(lit) b(lit) 32>64 ;
 127
 128 [THEN]