64bit.fs 4.97 KB
Newer Older
bernd's avatar
bernd committed
1 2 3 4 5 6 7
\ portable functions for 64 bit numbers

cell 8 = [IF]
    : 64bit ;
    : 64, drop , ;
    ' @ Alias 64@
    ' ! Alias 64!
bernd's avatar
bernd committed
8 9
    ' rot Alias 64rot
    ' -rot Alias -64rot
10 11
    ' swap alias n64-swap
    ' swap alias 64n-swap
bernd's avatar
bernd committed
12 13 14
    ' dup Alias 64dup
    ' over Alias 64over
    ' drop Alias 64drop
bernd's avatar
bernd committed
15
    ' nip Alias 64nip
bernd's avatar
bernd committed
16
    ' swap Alias 64swap
bernd's avatar
bernd committed
17
    ' over Alias over64 ( n 64 -- n 64 n )
18
    ' tuck Alias 64tuck
bernd's avatar
bernd committed
19 20 21 22 23 24 25
    ' + Alias 64+
    ' - Alias 64-
    ' or Alias 64or
    ' and Alias 64and
    ' xor Alias 64xor
    ' l@ Alias 32@
    ' Variable Alias 64Variable
bernd's avatar
bernd committed
26
    ' User Alias 64User
bernd's avatar
bernd committed
27
    ' Constant Alias 64Constant
bernd's avatar
bernd committed
28
    ' Value Alias 64Value
bernd's avatar
bernd committed
29
    ' 2/ Alias 64-2/
bernd's avatar
bernd committed
30
    ' 2* Alias 64-2*
bernd's avatar
bernd committed
31
    ' negate Alias 64negate
bernd's avatar
bernd committed
32
    0 Constant 64#0
bernd's avatar
bernd committed
33 34 35
    -1 Constant 64#-1
    ' rshift Alias 64rshift
    ' lshift Alias 64lshift
bernd's avatar
bernd committed
36
    ' s>f Alias 64>f
bernd's avatar
bernd committed
37
    ' f>s Alias f>64
bernd's avatar
bernd committed
38
    ' = Alias 64=
bernd's avatar
bernd committed
39
    ' <> Alias 64<>
bernd's avatar
bernd committed
40
    -1 1 64rshift Constant max-int64
41
    ' u. alias 64.
bernd's avatar
bernd committed
42
    ' . alias s64.
bernd's avatar
bernd committed
43 44 45 46
    ' noop Alias 64>n immediate
    ' noop Alias n>64 immediate
    ' noop Alias u>64 immediate
    ' s>d Alias 64>d
bernd's avatar
bernd committed
47
    ' drop Alias d>64
bernd's avatar
bernd committed
48
    ' >r Alias 64>r
bernd's avatar
bernd committed
49
    ' r@ Alias 64r@
bernd's avatar
bernd committed
50
    ' r> Alias 64r>
bernd's avatar
bernd committed
51
    ' 0= Alias 64-0=
bernd's avatar
bernd committed
52
    ' 0<> Alias 64-0<>
bernd's avatar
bernd committed
53
    ' 0>= Alias 64-0>=
54
    ' 0<= Alias 64-0<=
bernd's avatar
bernd committed
55
    ' 0< Alias 64-0<
bernd's avatar
bernd committed
56
    ' < Alias 64<
bernd's avatar
bernd committed
57
    ' > Alias 64>
bernd's avatar
bernd committed
58
    ' u< Alias 64u<
59
    ' u> Alias 64u>
bernd's avatar
bernd committed
60
    ' u<= Alias 64u<=
61
    ' u>= Alias 64u>=
bernd's avatar
bernd committed
62 63
    ' on Alias 64on
    ' +! Alias 64+!
bernd's avatar
bernd committed
64 65
    ' min Alias 64min
    ' max Alias 64max
66 67
    ' umin Alias 64umin
    ' umax Alias 64umax
68
    ' abs Alias 64abs
bernd's avatar
bernd committed
69
    ' off Alias 64off
bernd's avatar
bernd committed
70
    ' */ Alias 64*/
bernd's avatar
bernd committed
71
    ' * Alias 64*
bernd's avatar
bernd committed
72
    ' within alias 64within
bernd's avatar
bernd committed
73
    : 128xor ( ud1 ud2 -- ud3 )  rot xor >r xor r> ;
bernd's avatar
bernd committed
74
    : 128@ ( addr -- d ) 2@ swap ;
bernd's avatar
bernd committed
75
    ' d= Alias 128= ( d1 d2 -- flag )
bernd's avatar
bernd committed
76
    : 128! ( d addr -- ) >r swap r> 2! ;
bernd's avatar
bernd committed
77
    ' stop-ns alias stop-64ns
78 79
    also locals-types definitions
    ' w: alias 64:
80
    ' w^ alias 64^
81
    previous definitions
bernd's avatar
bernd committed
82
[ELSE]
bernd's avatar
bernd committed
83 84
    ' 2swap alias 64rot
    ' 2swap alias -64rot
85 86
    ' rot alias n64-swap
    ' -rot alias 64n-swap
bernd's avatar
bernd committed
87
    ' 2drop alias 64drop
bernd's avatar
bernd committed
88
    ' 2nip alias 64nip
bernd's avatar
bernd committed
89 90
    ' 2dup Alias 64dup
    ' 2over Alias 64over
bernd's avatar
bernd committed
91
    ' 2swap Alias 64swap
92
    ' 2tuck Alias 64tuck
bernd's avatar
bernd committed
93
    : over64 ( n 64 -- n 64 n ) 2 pick ;
bernd's avatar
bernd committed
94 95 96
    : 64,  swap 2, ;
    : 64@  2@ swap ; [IFDEF] macro macro [THEN]
    : 64!  >r swap r> 2! ; [IFDEF] macro macro [THEN]
bernd's avatar
bernd committed
97 98
    ' d+ Alias 64+
    ' d- Alias 64-
bernd's avatar
bernd committed
99 100 101 102 103
    : 64or rot or >r or r> ;
    : 64and rot and >r and r> ;
    : 64xor rot xor >r xor r> ;
    ' @ Alias 32@
    ' 2Variable Alias 64Variable
bernd's avatar
bernd committed
104
    : 64User  User cell uallot drop ;
bernd's avatar
bernd committed
105
    ' 2Constant Alias 64Constant
bernd's avatar
bernd committed
106
    ' 2Value Alias 64Value
bernd's avatar
bernd committed
107
    ' d2/ Alias 64-2/
bernd's avatar
bernd committed
108
    ' d2* Alias 64-2*
bernd's avatar
bernd committed
109
    ' dnegate Alias 64negate
bernd's avatar
bernd committed
110
    0. 2Constant 64#0
bernd's avatar
bernd committed
111
    -1. 2Constant 64#-1
112 113 114 115 116 117 118 119 120 121 122 123 124 125
    : 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 ;
bernd's avatar
bernd committed
126
    ' d>f Alias 64>f
bernd's avatar
bernd committed
127
    ' f>d Alias f>64
bernd's avatar
bernd committed
128
    ' d= Alias 64=
bernd's avatar
bernd committed
129
    ' d<> Alias 64<>
bernd's avatar
bernd committed
130
    -1. 1 64rshift 64Constant max-int64
131
    ' ud. alias 64.
bernd's avatar
bernd committed
132
    ' d. alias s64.
bernd's avatar
bernd committed
133 134
    ' drop Alias 64>n
    ' noop Alias 64>d immediate
bernd's avatar
bernd committed
135
    ' noop Alias d>64 immediate
bernd's avatar
bernd committed
136 137
    ' s>d Alias n>64
    ' false Alias u>64
bernd's avatar
bernd committed
138 139
    ' 2>r Alias 64>r
    ' 2r> Alias 64r>
bernd's avatar
bernd committed
140
    ' 2r@ Alias 64r@
bernd's avatar
bernd committed
141
    ' d0= Alias 64-0=
bernd's avatar
bernd committed
142
    ' d0<> Alias 64-0<>
bernd's avatar
bernd committed
143
    ' d0>= Alias 64-0>=
144
    ' d0<= Alias 64-0<=
bernd's avatar
bernd committed
145
    ' d0< Alias 64-0<
bernd's avatar
bernd committed
146
    ' d< Alias 64<
bernd's avatar
bernd committed
147
    ' d> Alias 64>
bernd's avatar
bernd committed
148
    ' du< Alias 64u<
149
    ' du> Alias 64u>
bernd's avatar
bernd committed
150
    ' du<= Alias 64u<=
151
    ' du>= Alias 64u>=
bernd's avatar
bernd committed
152 153
    : 64on ( addr -- )  >r 64#-1 r> 64! ;
    : 64+!  ( 64n addr -- )  dup >r 64@ 64+ r> 64! ;
bernd's avatar
bernd committed
154 155
    ' dmin Alias 64min
    ' dmax Alias 64max
156 157
    : 64umin  2over 2over du> IF  2swap  THEN  2drop ;
    : 64umax  2over 2over du< IF  2swap  THEN  2drop ;
158
    ' dabs Alias 64abs
bernd's avatar
bernd committed
159
    : 64off 0. rot 64! ;
bernd's avatar
bernd committed
160
    ' m*/ Alias 64*/
bernd's avatar
bernd committed
161 162
    : 64* ( d1 d2 -- d3 ) { l1 h1 l2 h2 }
	l1 l2 um* l1 h2 um* l2 h1 um* d+ drop + ;
bernd's avatar
bernd committed
163 164
    : 64within ( d1 d2 d3 -- flag )
	2over d- 2>r d- 2r> du< ;
bernd's avatar
bernd committed
165 166 167 168 169 170 171 172 173 174 175 176 177 178 179
    : 128xor { x1 x2 x3 x4 y1 y2 y3 y4 -- z1 z2 z3 z4 }
	x1 y1 xor  x2 y2 xor  x3 y3 xor  x4 y4 xor ;
    : 128@ ( addr -- x1..x4 )
	>r
	r@ 3 cells + @
	r@ 2 cells + @
	r@ cell+ @
	r> @ ;
    : 128= ( x1..y4 y1..y4 -- flag )  128xor  or or or 0= ;
    : 128! ( x1..x4 addr -- )
	>r
	r@ !
	r@ cell+ !
	r@ 2 cells + !
	r> 3 cells + ! ;
bernd's avatar
bernd committed
180
    ' stop-dns alias stop-64ns
bernd's avatar
bernd committed
181 182 183 184
    : compile-pushlocal-64 ( a-addr -- ) ( run-time: w1 w2 -- )
	locals-size @ alignlp-w cell+ cell+ dup locals-size !
	swap !
	postpone >l postpone >l ;
185 186
    also locals-types definitions
    ' d: alias 64:
bernd's avatar
bernd committed
187 188 189 190 191
    : 64^ ( "name" -- a-addr xt ) \ gforth d-caret
	create-local
	['] compile-pushlocal-64
      does> ( Compilation: -- ) ( Run-time: -- w )
	postpone laddr# @ lp-offset, ;
192
    previous definitions
bernd's avatar
bernd committed
193
[THEN]
bernd's avatar
bernd committed
194
\ independent of cell size, using dfloats:
bernd's avatar
bernd committed
195 196 197
' dfloats Alias 64s
' dfloat+ Alias 64'+
' dfaligned Alias 64aligned
bernd's avatar
bernd committed
198
' dffield: Alias 64field:
bernd's avatar
bernd committed
199
: $64. ( 64n -- ) ['] 64. $10 base-execute ;