/pliant/language/type/number/intn.pli
1	# Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx
2	#
3	# This program is free software; you can redistribute it and/or
4	# modify it under the terms of the GNU General Public License version 2
5	# as published by the Free Software Foundation.
6	#
7	# This program is distributed in the hope that it will be useful,
8	# but WITHOUT ANY WARRANTY; without even the implied warranty of
9	# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
10	# GNU General Public License for more details.
11	#
12	# You should have received a copy of the GNU General Public License
13	# version 2 along with this program; if not, write to the Free Software
14	# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
15
16	scope "/pliant/language/""/pliant/install/"
17	module "/pliant/install/ring3.pli"
18
19
20	constant please_retry 0FFFFFFFFh
21	constant read_locks   1FFFFFFFh
22	constant write_locked 20000000h
23	constant undefinedn   40000000h
24	constant positive     80000000h
25
26
27	type Intn
28	field Address bits
29	field Int size
30	field uInt status
31
32
33
34	#  locking and resizing
35
36
37	method i get_status -> status
38	arg Intn i ; arg uInt status
39	while true
40	status := atomic_read_and_set ((addressof i:status) map uInt) please_retry
41	if status<>please_retry
42	return
43
44	method i read_lock -> i_is_positive
45	arg Intn i ; arg uInt i_is_positive
46	while true
47	var uInt status := i get_status
48	if (status .and. write_locked)=0
49	(addressof i:status) map uInt := status+1
50	i_is_positive := status .and. positive
51	return
52	else
53	(addressof i:status) map uInt := status
54	os_yield
55
56	method i read_unlock
57	arg Intn i
58	(addressof i:status) map uInt := i:get_status-1
59
60	method i write_lock
61	arg_rw Intn i
62	while true
63	var uInt status := i get_status
64	if (status .and. read_locks+write_locked)=0
65	i status := status+write_locked
66	return
67	else
68	i status := status
69	os_yield
70
71	method i write_unlock
72	arg_rw Intn i
73	i status := i:get_status-write_locked
74
75
76	method i extend2 n
77	arg_rw Intn i ; arg Int n
78	if n*uInt:size>(memory_size i:bits)
79	i bits := memory_zresize i:bits n*uInt:size addressof:i
80
81	method i extend n
82	arg Intn i ; arg Int n
83	while n*uInt:size>(memory_size i:bits)
84	i read_unlock
85	(addressof:i map Intn) write_lock
86	(addressof:i map Intn) extend2 n
87	(addressof:i map Intn) write_unlock
88	i read_lock
89
90
91	method i resize n
92	arg_rw Intn i ; arg Int n
93	if n<i:size
94	memory_clear (i:bits translate uInt n) (i:size-n)*uInt:size
95	eif n*uInt:size>(memory_size i:bits)
96	i bits := memory_zresize i:bits n*uInt:size addressof:i
97	i size := n
98
99
100	method i zresize n
101	arg_rw Intn i ; arg Int n
102	memory_clear i:bits i:size*uInt:size
103	if n*uInt:size>(memory_size i:bits)
104	i bits := memory_zresize i:bits n*uInt:size addressof:i
105	i size := n
106
107
108	method i shrink
109	arg_rw Intn i
110	while i:size>0 and ((i:bits translate uInt i:size-1) map uInt)=0
111	i size := i:size-1
112	if i:size=0
113	i status := positive
114
115
116
117	#  basic operations
118
119
120	method i nbbits -> n
121	arg uInt i ; arg Int n
122	if i<2^4
123	n := shunt i=0 0 i<2 1 i<4 2 i<8 3 4
124	eif i<2^8
125	n := 4+(i\2^4 nbbits)
126	eif i<2^16
127	n := 8+(i\2^8 nbbits)
128	else
129	n := 16+(i\2^16 nbbits)
130
131	method i nbbits -> n
132	arg Intn i ; arg Int n
133	if i:size<>0
134	n := (i:size-1)*uInt:bitsize + ((i:bits translate uInt i:size-1) map uInt):nbbits
135	else
136	n := 0
137
138
139	method i set_bit u
140	arg_rw Intn i ; arg Int u
141	check u>=0 and u<i:size*uInt:bitsize
142	var Pointer:uInt bloc :> (i:bits translate uInt u\uInt:bitsize) map uInt
143	bloc := bloc .or. 2^(u%uInt:bitsize)
144
145
146	method i test_bit u -> on
147	arg Intn i ; arg Int u ; arg CBool on
148	check u>=0 and u<i:size*uInt:bitsize
149	var Pointer:uInt bloc :> (i:bits translate uInt u\uInt:bitsize) map uInt
150	on := (bloc .and. 2^(u%uInt:bitsize))<>0
151
152
153	function unsigned_compare a b -> r
154	arg Intn a b ; arg Int r
155	if a:size<>b:size
156	return (shunt a:size>b:size compare_superior compare_inferior)
157	for (var Int i) a:size-1 0 step -1
158	var uInt ai := (a:bits translate uInt i) map uInt
159	var uInt bi := (b:bits translate uInt i) map uInt
160	if ai>bi
161	return compare_superior
162	eif ai<bi
163	return compare_inferior
164	return compare_equal
165
166
167	if uInt:size=4
168	alias Half uInt16 from "/pliant/language/type/number/int_sized.pli"
169	eif uInt:size=8
170	alias Half uInt32 from "/pliant/language/type/number/int_sized.pli"
171
172
173	function add a b r size
174	arg Address a b r ; arg Int size
175	var uInt carry := 0
176	for (var Int i) 0 2*size-1
177	carry := carry + ((a translate Half i) map Half) + ((b translate Half i) map Half)
178	if carry<2^Half:bitsize
179	(r translate Half i) map Half := carry
180	carry := 0
181	else
182	(r translate Half i) map Half := carry - 2^Half:bitsize
183	carry := 1
184	check carry=0
185
186
187	function sub a b r size
188	arg Address a b r ; arg Int size
189	var Int carry := 0
190	for (var Int i) 0 2*size-1
191	carry := carry + ((a translate Half i) map Half) - ((b translate Half i) map Half)
192	if carry>=0
193	(r translate Half i) map Half := carry
194	carry := 0
195	else
196	(r translate Half i) map Half := carry + 2^Half:bitsize
197	carry := -1
198	check carry=0
199
200
201	function add_mul src dest size factor
202	arg Address src dest ; arg Int size ; arg uInt factor
203	var uInt carry := 0
204	for (var Int i) 0 size*2-1
205	carry := carry + ((dest translate Half i) map Half) + ((src translate Half i) map Half) * factor
206	(dest translate Half i) map Half := carry .and. 2^Half:bitsize-1
207	carry := carry \ 2^Half:bitsize
208	var Int i := size*2
209	while carry<>0
210	carry := carry + ((dest translate Half i) map Half)
211	(dest translate Half i) map Half := carry .and. 2^Half:bitsize-1
212	carry := carry \ 2^Half:bitsize
213	i := i+1
214
215
216
217	#  shifted
218
219
220	method i bloc u -> r
221	arg Intn i ; arg Int u ; arg uInt r
222	if u>=0 and u<i:size
223	r := (i:bits translate uInt u) map uInt
224	else
225	r := 0
226
227
228	function do_shift low high shift -> result
229	arg uInt low high result ; arg Int shift
230	check shift>=0 and shift<uInt:bitsize
231	if shift<>0
232	result := (low \ 2^(uInt:bitsize-shift)) .or. (high .*. 2^shift)
233	else
234	result := high
235
236
237	method i size_shifted shift -> r
238	arg Intn i ; arg Int shift ; arg Int r
239	r := i:size+(shift+uInt:bitsize-1)\uInt:bitsize
240
241
242	method i bloc_shifted u shift -> r
243	arg Intn i ; arg Int u shift ; arg uInt r
244	var Int t := u.-.shift\uInt:bitsize
245	var Int s := shift%uInt:bitsize
246	r := do_shift (i bloc t.-.1) (i bloc t) s
247
248
249	function unsigned_compare_shifted1 a b b_shift -> r
250	arg Intn a b ; arg Int b_shift ; arg Int r
251	for (var Int i) (max a:size (b size_shifted b_shift))-1 0 step -1
252	var uInt ai := a bloc i
253	var uInt bi := b bloc_shifted i b_shift
254	if ai>bi
255	return compare_superior
256	eif ai<bi
257	return compare_inferior
258	return compare_equal
259
260
261	constant dl pliant_debugging_level
262	if dl>=4
263
264	function unsigned_compare_shifted2 a b b_shift -> r
265	arg Intn a b ; arg Int b_shift ; arg Int r
266	for (var Int i) (max a:nbbits b:nbbits+b_shift) 0 step -1
267	var CBool ai := shunt i<a:size*uInt:bitsize (a test_bit i) false
268	var CBool bi := shunt i-b_shift>=0 and i-b_shift<b:size*uInt:bitsize (b test_bit i-b_shift) false
269	if ai<>bi
270	return (shunt ai compare_superior compare_inferior)
271	return compare_equal
272
273
274	function unsigned_compare_shifted a b b_shift -> r
275	arg Intn a b ; arg Int b_shift ; arg Int r
276	var Int r1 := unsigned_compare_shifted1 a b b_shift
277	var Int r2 := unsigned_compare_shifted2 a b b_shift
278	check r1=r2
279	r := r1
280
281	else
282
283	alias unsigned_compare_shifted unsigned_compare_shifted1
284
285
286	function sub1 src dest carry
287	arg Half src ; arg_rw Half dest ; arg_rw Int carry
288	carry := carry + (addressof:dest map Half) - (addressof:src map Half)
289	if carry>=0
290	addressof:dest map Half := carry
291	carry := 0
292	else
293	addressof:dest map Half := carry + 2^Half:bitsize
294	carry := -1
295
296
297	function sub2 src dest carry
298	arg uInt src ; arg_rw uInt dest ; arg_rw Int carry
299	sub1 (addressof:src map Half) (addressof:dest map Half) carry
300	sub1 ((addressof:src translate Half 1) map Half) ((addressof:dest translate Half 1) map Half) carry
301
302
303	function sub_shifted src dest size src_shift
304	arg Address src dest ; arg Int size src_shift
305	var Int t := src_shift\uInt:bitsize
306	var Int s := src_shift%uInt:bitsize
307	var Int carry := 0
308	for (var Int i) 0 size
309	var uInt32 shifted := do_shift (shunt i>0 ((src translate uInt i-1) map uInt) 0) ((src translate uInt i) map uInt) s
310	sub2 shifted ((dest translate uInt i+t) map uInt) carry
311	var Int i := t+size*2
312	while carry<>0
313	carry := carry + ((dest translate Half i) map Half)
314	if carry>=0
315	(dest translate Half i) map Half := carry
316	carry := 0
317	else
318	(dest translate Half i) map Half := carry + 2^Half:bitsize
319	carry := -1
320	i := i+1
321
322
323
324	#  generic operations
325
326
327	function build  i
328	arg_w Intn i
329	i bits := null
330	i size := 0
331	i status := positive
332
333
334	function destroy i
335	arg_w Intn i
336	memory_free i:bits
337
338
339	function copy src dest
340	arg Intn src ; arg_w Intn dest
341	src read_lock
342	dest resize src:size
343	memory_copy src:bits dest:bits src:size*uInt:size
344	src read_unlock
345	dest status := src:status .and. (positive .or. undefinedn)
346
347
348	function compare a b -> r
349	arg Intn a b ; arg Int r
350	if (a:status .and. undefinedn)<>0 or (b:status .and. undefinedn)<>0
351	return (