/pliant/language/type/number/int.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/ring2.pli"
18
19
20	operator '.+.' 3*256+1*16 1 1
21	operator '.-.' 3*256+1*16 1 1
22	operator '.*.' 3*256+2*16 1 1
23	operator '.^.' 3*256+3*16 1 1
24
25
26
27
28
29	function abs i -> a
30	arg Int i a
31	gcc_inline "$2 = ($1>=0 ? $1 : -$1);"
32	if i>=0
33	a := i
34	else
35	a := -i
36
37	export abs
38
39
40	type uInt
41	field Int value
42
43
44	function cast_uInt_Int i -> j
45	arg uInt i ; arg Int j
46	extension ; has_no_side_effect ; gcc_nocheck_inline "$2 = $1;"
47	check i:value>=0 "The value is too large to fit in an Int"
48	j := i value
49	if pliant_debugging_level<2
50	(the_function cast_uInt_Int uInt -> Int) flags := '.or.' (the_function cast_uInt_Int uInt -> Int):flags function_flag_copy
51	(the_function cast_uInt_Int uInt -> Int) set_generate_assembly (the_function 'copy atomic' Int Int):generate_assembly
52
53	function cast_Int_uInt i -> j
54	arg Int i ; arg uInt j
55	reduction ; has_no_side_effect ; gcc_nocheck_inline "$2 = $1;"
56	check i>=0 "The integer is negative"
57	j value := i
58	if pliant_debugging_level<2
59	(the_function cast_Int_uInt Int -> uInt) flags := '.or.' (the_function cast_Int_uInt Int -> uInt):flags function_flag_copy
60	(the_function cast_Int_uInt Int -> uInt) set_generate_assembly (the_function 'copy atomic' Int Int):generate_assembly
61
62
63	function cast_uInt_Address i -> a
64	arg uInt i ; arg Address a
65	has_no_side_effect ; gcc_nocheck_inline "$2 = $1;"
66	check uInt:size=Address:size
67	memory_copy addressof:i addressof:a uInt:size
68	if pliant_debugging_level<2
69	(the_function cast_uInt_Address uInt -> Address) flags := (the_function cast_uInt_Address uInt -> Address):flags+function_flag_copy
70	(the_function cast_uInt_Address uInt -> Address) set_generate_assembly (the_function 'copy atomic' Int Int):generate_assembly
71
72	function cast_Address_uInt a -> i
73	arg Address a ; arg uInt i
74	has_no_side_effect ; gcc_nocheck_inline "$2 = $1;"
75	check uInt:size=Address:size
76	memory_copy addressof:a addressof:i uInt:size
77	if pliant_debugging_level<2
78	(the_function cast_Address_uInt Address -> uInt) flags := (the_function cast_Address_uInt Address -> uInt):flags+function_flag_copy
79	(the_function cast_Address_uInt Address -> uInt) set_generate_assembly (the_function 'copy atomic' Int Int):generate_assembly
80
81
82	function compare_uInt i j -> c
83	arg uInt i j ; arg Int c
84	gcc_inline "$3 = (unsigned int)$1<(unsigned int)$2 ? "+'convert to string':compare_inferior+" : (unsigned int)$1>(unsigned int)$2 ? "+'convert to string':compare_superior+" : "+'convert to string':compare_equal+";"
85	gcc_inline_compare "$3 = (unsigned int)$1 compare (unsigned int)$2;"
86	var Int ii := i:value+(-2)^(Int:bitsize-1)
87	var Int jj := j:value-(-2)^(Int:bitsize-1)
88	if ii=jj
89	c := compare_equal
90	eif ii<jj
91	c := compare_inferior
92	else
93	check ii>jj
94	c := compare_superior
95
96	export uInt
97	alias 'cast Int' cast_uInt_Int in "/pliant/language/basic/ultrasafe.pli"
98	alias 'cast uInt' cast_Int_uInt in "/pliant/language/basic/ultrasafe.pli"
99	alias 'cast Address' cast_uInt_Address in "/pliant/language/basic/safe.pli"
100	alias 'cast uInt' cast_Address_uInt in "/pliant/language/basic/safe.pli"
101	alias compare compare_uInt in "/pliant/language/basic/safe.pli"
102
103
104
105
106
107	if processor_name="i386"
108
109	function arithmetic_overflow
110	has_no_side_effect
111	error error_id_arithmetic "Arithmetic overflow"
112
113	function generate_parameter_is_valid i f
114	arg_rw Instruction i ; arg_rw Function f
115	function parameter_is_valid -> p
116	arg Int p
117	(the_function parameter_is_valid -> Int) set_generate_binary (the_function generate_parameter_is_valid Instruction Function)
118
119	function i386_jump_if_not_overflow
120	void
121	function generate_jump_if_not_overflow i f
122	arg_rw Instruction i ; arg_rw Function f
123	f code_immediat 8*4096+1*256+0*16+15 2
124	f code_jump i:jump
125	(the_function i386_jump_if_not_overflow) set_generate_binary (the_function generate_jump_if_not_overflow Instruction Function)
126
127	function i386_jump_if_not_carry
128	void
129	function generate_jump_if_not_carry i f
130	arg_rw Instruction i ; arg_rw Function f
131	f code_immediat 8*4096+3*256+0*16+15 2
132	f code_jump i:jump
133	(the_function i386_jump_if_not_carry) set_generate_binary (the_function generate_jump_if_not_carry Instruction Function)
134
135	function generate_overflow_checkup cur gc checkup parameter -> cur2
136	arg Pointer:Instruction cur cur2 ; arg_rw GeneratorContext gc ; arg Int checkup ; arg_rw Argument parameter
137	check checkup>=0 and checkup<=2 # 0 = no checkup , 1 = Int checkup , 2 = uInt checkup
138	if pliant_debugging_level<2 or checkup=0
139	return cur
140	var Link:Instruction back :> instruction (the_function parameter_is_valid -> Int) parameter
141	if checkup=1
142	cur2 :> gc insert_after_instruction cur (instruction (the_function i386_jump_if_not_overflow) jump back)
143	else
144	cur2 :> gc insert_after_instruction cur (instruction (the_function i386_jump_if_not_carry) jump back)
145	cur2 :> gc insert_after_instruction cur2 (instruction (the_function arithmetic_overflow))
146	cur2 :> gc insert_after_instruction cur2 back
147
148
149	function rename_function fun newname
150	arg_rw Function fun ; arg Str newname
151	pliant_general_dictionary insert2 newname true addressof:fun the_module:"/pliant/language/basic/safe.pli"
152	pliant_general_dictionary remove fun:name addressof:fun
153	fun name := newname
154
155	function assemble_simple i gc fun checkup
156	arg_rw Instruction i ; arg_rw GeneratorContext gc ; arg Function fun ; arg Int checkup
157	var Pointer:Instruction cur :> i
158	var Link:Argument r :> argument a_register
159	cur :> gc insert_after_instruction cur (instruction (the_function i386_mov Int Int) i:0 r)
160	cur :> gc insert_after_instruction cur (instruction fun i:1 r)
161	cur :> generate_overflow_checkup cur gc checkup r
162	cur :> gc insert_after_instruction cur (instruction (the_function i386_mov Int Int) r i:2)
163	gc remove i
164
165
166	rename_function (the_function '+' Int Int -> Int) ".+."
167
168	function '.+.' a b -> r
169	arg uInt a b r ; gcc_inline "$3 = $1 + $2;"
170	(the_function '.+.' uInt uInt -> uInt) set_generate_assembly (the_function '+' Int Int -> Int):generate_assembly
171
172	function plus a b -> r
173	arg Int a b r ; gcc_nocheck_inline "$3 = $1 + $2;"
174	function assemble_add_checkup_int i gc
175	arg_rw Instruction i ; arg_rw GeneratorContext gc
176	assemble_simple i gc (the_function i386_add Int Int) 1
177	(the_function plus Int Int -> Int) set_generate_assembly (the_function assemble_add_checkup_int Instruction GeneratorContext)
178	rename_function (the_function plus Int Int -> Int) "+"
179
180	function '+' a b -> r
181	arg uInt a b r ; gcc_nocheck_inline "$3 = $1 + $2;"
182	function assemble_add_checkup_uint i gc
183	arg_rw Instruction i ; arg_rw GeneratorContext gc
184	assemble_simple i gc (the_function i386_add Int Int) 2
185	(the_function '+' uInt uInt -> uInt) set_generate_assembly (the_function assemble_add_checkup_uint Instruction GeneratorContext)
186
187
188	rename_function (the_function '-' Int Int -> Int) ".-."
189
190	function '.-.' a b -> r
191	arg uInt a b r ; gcc_inline "$3 = $1 - $2;"
192	(the_function '.-.' uInt uInt -> uInt) set_generate_assembly (the_function '-' Int Int -> Int):generate_assembly
193
194	function minus a b -> r
195	arg Int a b r ; gcc_nocheck_inline "$3 = $1 - $2;"
196	function assemble_sub_checkup_int i gc
197	arg_rw Instruction i ; arg_rw GeneratorContext gc
198	assemble_simple i gc (the_function i386_sub Int Int) 1
199	(the_function minus Int Int -> Int) set_generate_assembly (the_function assemble_sub_checkup_int Instruction GeneratorContext)
200	rename_function (the_function minus Int Int -> Int) "-"
201
202	function '-' a b -> r
203	arg uInt a b r ; gcc_nocheck_inline "$3 = $1 - $2;"
204	function assemble_sub_checkup_uint i gc
205	arg_rw Instruction i ; arg_rw GeneratorContext gc
206	assemble_simple i gc (the_function i386_sub Int Int) 2
207	(the_function '-' uInt uInt -> uInt) set_generate_assembly (the_function assemble_sub_checkup_uint Instruction GeneratorContext)
208
209
210	function i386_imul x eax edx
211	arg Int x ; arg_rw Int eax ; arg_w Int edx
212	function generate_i386_imul i f
213	arg_rw Instruction i ; arg_rw Function f
214	check i:1:where=argument_register and i:1:register=i386_eax
215	check i:2:where=argument_register and i:2:register=i386_edx
216	i386_regmem f 15*16+7 1 5 i:0
217	(the_function i386_imul Int Int Int) set_generate_binary (the_function generate_i386_imul Instruction Function)
218	((the_function i386_imul Int Int Int) arg 1) access := access_read+access_write+access_byvalue
219	((the_function i386_imul Int Int Int) arg 2) access := access_write+access_byvalue
220
221	function i386_mul x eax edx
222	arg Int x ; arg_rw Int eax ; arg_w Int edx
223	function generate_i386_mul i f
224	arg_rw Instruction i ; arg_rw Function f
225	check i:1:where=argument_register and i:1:register=i386_eax
226	check i:2:where=argument_register and i:2:register=i386_edx
227	i386_regmem f 15*16+7 1 4 i:0
228	(the_function i386_mul Int Int Int) set_generate_binary (the_function generate_i386_mul Instruction Function)
229	((the_function i386_mul Int Int Int) arg 1) access := access_read+access_write+access_byvalue
230	((the_function i386_mul Int Int Int) arg 2) access := access_write+access_byvalue
231
232	function assemble_mul i gc checkup imul_mul
233	arg_rw Instruction i ; arg_rw GeneratorContext gc ; arg Int checkup imul_mul
234	var Pointer:Instruction cur :> i
235	var Pointer:Argument eax :> gc register i386_eax
236	var Pointer:Argument edx :> gc register i386_edx
237	cur :> gc insert_after_instruction cur (instruction (the_function i386_mov Int Int) i:0 eax)
238	if imul_mul=1
239	cur :> gc insert_after_instruction cur (instruction (the_function i386_imul Int Int Int) i:1 eax edx)
240	else
241	cur :> gc insert_after_instruction cur (instruction (the_function i386_mul Int Int Int) i:1 eax edx)
242	cur :> generate_overflow_checkup cur gc checkup eax
243	cur :> gc insert_after_instruction cur (instruction (the_function i386_mov Int Int) eax i:2)
244	gc remove i
245
246
247	rename_function (the_function '*' Int Int -> Int) ".*."
248
249	function '.*.' a b -> r
250	arg uInt a b r; gcc_inline "$3 = (unsigned int)$1 * (unsigned int)$2;"
251	function assemble_mul_nocheckup_uint i gc
252	arg_rw Instruction i ; arg_rw GeneratorContext gc
253	assemble_mul i gc 0 2
254	(the_function '.*.' uInt uInt -> uInt) set_generate_assembly (the_function assemble_mul_nocheckup_uint Instruction GeneratorContext)
255
256	function multiply a b -> r
257	arg Int a b r ; gcc_nocheck_inline "$3 = $1 * $2;"
258	function assemble_mul_checkup_int i gc
259	arg_rw Instruction i ; arg_rw GeneratorContext gc
260	assemble_mul i gc 1 1
261	(the_function multiply Int Int -> Int) set_generate_assembly (the_function assemble_mul_checkup_int Instruction GeneratorContext)
262	rename_function (the_function multiply Int Int -> Int) "*"
263
264	function '*' a b -> r
265	arg uInt a b r; gcc_nocheck_inline "$3 = (unsigned int)$1 * (unsigned int)$2;"
266	function assemble_mul_checkup_uint i gc
267	arg_rw Instruction i ; arg_rw GeneratorContext gc
268	assemble_mul i gc 2 2
269	(the_function '*' uInt uInt -> uInt) set_generate_assembly (the_function assemble_mul_checkup_uint Instruction GeneratorContext)
270
271
272	function i386_cdq eax edx
273	arg Int eax ; arg_w Int edx
274	function generate_i386_cdq i f
275	arg_rw Instruction i ; arg_rw Function f
276	check i:0:where=argument_register and i:0:register=i386_eax
277	check i:1:where=argument_register and i:1:register=i386_edx
278	f code_immediat 9*16+9 1
279	(the_function i386_cdq Int Int) set_generate_binary (the_function generate_i386_cdq Instruction Function)
280	((the_function i386_cdq Int Int) arg 1) access := access_write+access_byvalue
281
282	function i386_idiv eax edx x
283	arg_rw Int eax edx ; arg Int x
284	function generate_i386_idiv i f
285	arg_rw Instruction i ; arg_rw Function f
286	check i:0:where=argument_register and i:0:register=i386_eax
287	check i:1:where=argument_register and i:1:register=i386_edx
288	i386_regmem f 15*16+7 1 7 i:2
289	(the_function i386_idiv Int Int Int) set_generate_binary (the_function generate_i386_idiv Instruction Function)
290	((the_function i386_idiv Int Int Int) arg 0) access := access_read+access_write+access_byvalue
291	((the_function i386_idiv Int Int Int) arg 1) access := access_read+access_write+access_byvalue
292
293	function i386_div eax edx x
294	arg_rw Int eax edx ; arg Int x
295	function generate_i386_div i f
296	arg_rw Instruction i ; arg_rw Function f
297	check i:0:where=argument_register and i:0:register=i386_eax
298	check i:1:where=argument_register and i:1:register=i386_edx
299	i386_regmem f 15*16+7 1 6 i:2
300	(the_function i386_div Int Int Int) set_generate_binary (the_function generate_i386_div Instruction Function)
301	((the_function i386_div Int Int Int) arg 0) access := access_read+access_write+access_byvalue
302	((the_function i386_div Int Int Int) arg 1) access := access_read+access_write+access_byvalue
303
304
305	function assemble_divide i gc signed reg
306	arg_rw Instruction i ; arg_rw GeneratorContext gc ; arg CBool signed ; arg Int reg
307	var Pointer:Instruction cur :> i
308	var Link:Argument eax :> gc register i386_eax
309	var Link:Argument edx :> gc register i386_edx
310	cur :> gc insert_after_instruction cur (instruction (the_function i386_mov Int Int) i:0 eax)
311	if signed
312	cur :> gc insert_after_instruction cur (instruction (the_function i386_cdq Int Int) eax edx)
313	cur :> gc insert_after_instruction cur (instruction (the_function i386_idiv Int Int Int) eax edx i:1)
314	else
315	cur :> gc insert_after_instruction cur (instruction (the_function i386_mov Int Int) (argument constant Int 0) edx)
316	cur :> gc insert_after_instruction cur (instruction (the_function i386_div Int Int Int) eax edx i:1)
317	cur :> gc insert_after_instruction cur (instruction (the_function i386_mov Int Int) (gc register reg) i:2)
318	gc remove i
319
320	function assemble_idiv i gc
321	arg_rw Instruction i ; arg_rw GeneratorContext gc
322	assemble_divide i gc true i386_eax
323	(the_function '\' Int Int -> Int) set_generate_assembly (the_function assemble_idiv Instruction GeneratorContext)
324
325	function '\' a b -> r
326	arg uInt a b r ; gcc_inline "$3 = (unsigned int)$1 / (unsigned int)$2;"
327	function assemble_div i gc
328	arg_rw Instruction i ; arg_rw GeneratorContext gc
329	assemble_divide i gc false i386_eax
330	(the_function '\' uInt uInt -> uInt) set_generate_assembly (the_function assemble_div Instruction GeneratorContext)
331
332	function assemble_imod i gc
333	arg_rw Instruction i ; arg_rw GeneratorContext gc
334	assemble_divide i gc true i386_edx
335	(the_function '%' Int Int -> Int) set_generate_assembly (the_function assemble_imod Instruction GeneratorContext)
336
337	function '%' a b -> r
338	arg uInt a b r ; gcc_inline "$3 = (unsigned int)$1 % (unsigned int)$2;"
339	function assemble_mod i gc
340	arg_rw Instruction i ; arg_rw GeneratorContext gc
341	assemble_divide i gc false i386_edx
342	(the_function '%' uInt uInt -> uInt) set_generate_assembly (the_function assemble_mod Instruction GeneratorContext)
343
344
345	meta '-' e
346	strong_definition
347	if e:size<>2
348	return
349	var Pointer:uInt a :> (e:0 constant uInt) map uInt
350	if addressof:a=null
351	return
352	var Pointer:uInt b :> (e:1 constant uInt) map uInt
353	if addressof:b=null
354	return
355	if b>a
356	e set_result (argument constant Int (cast a Int)-(cast b Int)) access_read
357
358
359	export '+' '-' '*' '\' '%'
360	export '.+.' '.-.' '.*.'
361
362
363
364
365	module "/pliant/language/type/text/char.pli"
366
367
368	function parse_bin context line parameter
369	arg_rw ParserContext context ; arg Str line ; arg Address parameter
370	var uInt value := 0
371	for (var Int i) 0 line:len-1
372	var Char c := line i
373	if c="0" or c="1"
374	var uInt value2 := value .*. (cast 2 uInt) .+. (cast c:number-"0":0:number uInt)
375	if value2\(cast 2 uInt)<>value
376	return
377	value := value2
378	eif c="b" and i<>0
379	if i+1<line:len and (line i+1):isidentcharacter
380	return
381	var Link:uInt t :> new uInt
382	t := value
383	context add_token addressof:t
384	context forward i+1
385	return
386	else
387	return
388
389	gvar ParserFilter bin_filter
390	bin_filter function :> the_function parse_bin ParserContext Str Address
391	constant 'pliant parser basic types' bin_filter
392	export 'pliant parser basic types'
393
394
395	function parse_dec context line parameter
396	arg_rw ParserContext context ; arg Str line ; arg Address parameter
397	var uInt value := 0
398	var Int i := 0
399	while i<line:len and line:i:number>="0":0:number and line:i:number<="9":0:number
400	var uInt value2 := value .*. (cast 10 uInt) .+. (cast line:i:number-"0":0:number uInt)
401	if value2\(cast 10 uInt)<>value
402	return
403	i := i+1
404	value := value2
405	if i=0 or (i<line:len and line:i:isidentcharacter)
406	return
407	var Link:uInt t :> new uInt
408	t := value
409	context add_token addressof:t
410	context forward i
411
412	gvar ParserFilter dec_filter
413	dec_filter function :> the_function parse_dec ParserContext Str Address
414	constant 'pliant parser basic types' dec_filter
415	export 'pliant parser basic types'
416
417
418	function parse_hex context line parameter
419	arg_rw ParserContext context ; arg Str line ; arg Address parameter
420	var uInt value := 0
421	for (var Int i) 0 line:len-1
422	var Char c := line i
423	var uInt value2
424	if c:number>="0":0:number and c:number<="9":0:number
425	value2 := value .*. (cast 16 uInt) .+. (cast c:number-"0":0:number uInt)
426	if value2\(cast 16 uInt)<>value
427	return
428	value := value2
429	eif c:number>="A":0:number and c:number<="F":0:number
430	value2 := value .*. (cast 16 uInt) .+. (cast 10+c:number-"A":0:number uInt)
431	if value2\(cast 16 uInt)<>value
432	return
433	value := value2
434	eif c="h" and i<>0
435	if i+1<line:len and (line i+1):isidentcharacter
436	return
437	var Link:uInt t :> new uInt
438	t := value
439	context add_token addressof:t
440	context forward i+1
441	return
442	else
443	return
444
445	gvar ParserFilter hex_filter
446	hex_filter function :> the_function parse_hex ParserContext Str Address
447	constant 'pliant parser basic types' hex_filter
448	export 'pliant parser basic types'
449
450
451
452
453
454	if processor_name="i386"
455
456	function i386_or a b
457	arg Int a ; arg_rw Int b
458
459	function generate_i386_or i f
460	arg_rw Instruction i ; arg_rw Function f
461	if i:0:where=argument_register
462	i386_regmem f 00001001b 1 i:0:register i:1
463	eif i:1:where=argument_register
464	i386_regmem f 00001011b 1 i:1:register i:0
465	else
466	error error_id_unexpected "i386 code generation: Invalid or arguments"
467
468	(the_function i386_or Int Int) set_generate_binary (the_function generate_i386_or Instruction Function)
469	((the_function i386_or Int Int) arg 1) access := access_read+access_write+access_byvalue
470
471	function '.or.' a b -> r
472	arg uInt a b r
473	gcc_inline "$3 = $1 | $2;"
474
475	function assemble_bit_or i gc
476	arg_rw Instruction i ; arg_rw GeneratorContext gc
477	var Pointer:Instruction cur :> i
478	var Link:Argument reg :> argument a_register
479	cur :> gc insert_after_instruction cur (instruction (the_function i386_mov Int Int) i:0 reg)
480	cur :> gc insert_after_instruction cur (instruction (the_function i386_or Int Int) i:1 reg)
481	cur :> gc insert_after_instruction cur (instruction (the_function i386_mov Int Int) reg i:2)
482	gc remove i
483
484	(the_function '.or.' Int Int -> Int) set_generate_assembly (the_function assemble_bit_or Instruction GeneratorContext)
485	(the_function '.or.' uInt uInt -> uInt) set_generate_assembly (the_function assemble_bit_or Instruction GeneratorContext)
486
487	operator '.or.' 290h 1 1
488	export '.or.'
489
490
491	function i386_and a b
492	arg Int a ; arg_rw Int b
493
494	function generate_i386_and i f
495	arg_rw Instruction i ; arg_rw Function f
496	if i:0:where=argument_register
497	i386_regmem f 00100001b 1 i:0:register i:1
498	eif i:1:where=argument_register
499	i386_regmem f 00100011b 1 i:1:register i:0
500	else
501	error error_id_unexpected "i386 code generation: Invalid and arguments"
502
503	(the_function i386_and Int Int) set_generate_binary (the_function generate_i386_and Instruction Function)
504	((the_function i386_and Int Int) arg 1) access := access_read+access_write+access_byvalue
505
506	function '.and.' a b -> r
507	arg uInt a b r
508	gcc_inline "$3 = $1 & $2;"
509
510	function assemble_bit_and i gc
511	arg_rw Instruction i ; arg_rw GeneratorContext gc
512	var Pointer:Instruction cur :> i
513	var Link:Argument reg :> argument a_register
514	cur :> gc insert_after_instruction cur (instruction (the_function i386_mov Int Int) i:0 reg)
515	cur :> gc insert_after_instruction cur (instruction (the_function i386_and Int Int) i:1 reg)
516	cur :> gc insert_after_instruction cur (instruction (the_function i386_mov Int Int) reg i:2)
517	gc remove i
518
519	(the_function '.and.' Int Int -> Int) set_generate_assembly (the_function assemble_bit_and Instruction GeneratorContext)
520	(the_function '.and.' uInt uInt -> uInt) set_generate_assembly (the_function assemble_bit_and Instruction GeneratorContext)
521
522	operator '.and.' 290h 1 1
523	export '.and.'
524
525
526	function i386_xor a b
527	arg Int a ; arg_rw Int b
528
529	function generate_i386_xor i f
530	arg_rw Instruction i ; arg_rw Function f
531	if i:0:where=argument_register
532	i386_regmem f 00110001b 1 i:0:register i:1
533	eif i:1:where=argument_register
534	i386_regmem f 00110011b 1 i:1:register i:0
535	else
536	error error_id_unexpected "i386 code generation: Invalid and arguments"
537
538	(the_function i386_xor Int Int) set_generate_binary (the_function generate_i386_xor Instruction Function)
539	((the_function i386_xor Int Int) arg 1) access := access_read+access_write+access_byvalue
540
541	function '.xor.' a b -> r
542	arg Int a b r
543	gcc_inline "$3 = $1 ^ $2;"
544
545	function '.xor.' a b -> r
546	arg uInt a b r
547	gcc_inline "$3 = $1 ^ $2;"
548
549	function assemble_bit_xor i gc
550	arg_rw Instruction i ; arg_rw GeneratorContext gc
551	var Pointer:Instruction cur :> i
552	var Link:Argument reg :> argument a_register
553	cur :> gc insert_after_instruction cur (instruction (the_function i386_mov Int Int) i:0 reg)
554	cur :> gc insert_after_instruction cur (instruction (the_function i386_xor Int Int) i:1 reg)
555	cur :> gc insert_after_instruction cur (instruction (the_function i386_mov Int Int) reg i:2)
556	gc remove i
557
558	(the_function '.xor.' Int Int -> Int) set_generate_assembly (the_function assemble_bit_xor Instruction GeneratorContext)
559	(the_function '.xor.' uInt uInt -> uInt) set_generate_assembly (the_function assemble_bit_xor Instruction GeneratorContext)
560
561	operator '.xor.' 290h 1 1
562	export '.xor.'
563
564
565	function i386_not a
566	arg_rw Int a
567
568	function generate_i386_not i f
569	arg_rw Instruction i ; arg_rw Function f
570	i386_regmem f 11110111b 1 010b i:0
571
572	(the_function i386_not Int) set_generate_binary (the_function generate_i386_not Instruction Function)
573	((the_function i386_not Int) arg 0) access := access_read+access_write+access_byvalue
574
575
576	function '.not.' a -> r
577	arg uInt a r
578	gcc_inline "$2 = ~ $1;"
579
580	function assemble_bit_not i gc
581	arg_rw Instruction i ; arg_rw GeneratorContext gc
582	var Pointer:Instruction cur :> i
583	var Link:Argument reg :> argument a_register
584	cur :> gc insert_after_instruction cur (instruction (the_function i386_mov Int Int) i:0 reg)
585	cur :> gc insert_after_instruction cur (instruction (the_function i386_not Int) reg)
586	cur :> gc insert_after_instruction cur (instruction (the_function i386_mov Int Int) reg i:1)
587	gc remove i
588
589	(the_function '.not.' Int -> Int) set_generate_assembly (the_function assemble_bit_not Instruction GeneratorContext)
590	(the_function '.not.' uInt -> uInt) set_generate_assembly (the_function assemble_bit_not Instruction GeneratorContext)
591
592	operator '.not.' 2A0h 0 1
593	export '.not.'
594
595
596	function '.andnot.' a b -> r
597	arg Int a b r
598	r := a .and. .not. b
599
600	function '.andnot.' a b -> r
601	arg uInt a b r
602	r := a .and. .not. b
603
604	operator '.andnot.' 260h 1 1
605	export '.andnot.'
606
607
608
609
610
611	rename_function (the_function '^' Int Int -> Int) ".^."
612
613	function '^' a b -> r
614	arg Int a b r
615	check b>=0 "^ second argument must be positive"
616	r := 1 ; var Int p := a ; var Int e := b
617	while true
618	if (e .and. 1)=1
619	r := r*p
620	if e<2
621	return
622	p := p*p
623	e := e\2
624
625	function '.^.' a b -> r
626	arg uInt a r ; arg Int b
627	check b>=0 "^ second argument must be positive"
628	r := 1 ; var uInt p := a ; var Int e := b
629	while true
630	if (e .and. 1)=1
631	r := r .*. p
632	if e<2
633	return
634	p := p .*. p
635	e := e\2
636
637	function '^' a b -> r
638	arg uInt a r ; arg Int b
639	check b>=0 "^ second argument must be positive"
640	r := 1 ; var uInt p := a ; var Int e := b
641	while true
642	if (e .and. 1)=1
643	r := r*p
644	if e<2
645	return
646	p := p*p
647	e := e\2
648
649	export '^' '.^.'
650
651
652
653
654
655	function min a b -> m
656	arg Int a b m
657	gcc_inline "$3 = ($1 <= $2 ? $1 : $2);"
658	if a<=b
659	return a
660	else
661	return b
662
663
664	function max a b -> m
665	arg Int a b m
666	gcc_inline "$3 = ($1 >= $2 ? $1 : $2);"
667	if a>=b
668	return a
669	else
670	return b
671
672
673	export min max
674
675
676
677
678
679	function 'cast Status' i -> s
680	arg Int i ; arg Status s
681	explicit
682	if i=(-2)^(Int:bitsize-1)
683	s := undefined
684	else
685	s := defined
686
687	function 'cast Int' s -> i
688	arg Status s ; arg Int i
689	extension
690	if pliant_debugging_level>=2
691	if s<>undefined
692	error error_id_unexpected "Unexpected Status value"
693	i := (-2)^(Int:bitsize-1)
694
695
696
697
698
699	doc
700	[These functions have been removed because you should use 'parse' or 'eparse' instead]
701
702
703	# function 'cast Int' s -> i
704	#   arg Str s ; arg Int i
705	#   i := 0 ; var CBool some := false
706	#   var Int start := 0
707	#   if s:len>0 and s:0="-"
708	#     start := 1
709	#   for (var Int u) start s:len-1
710	#     if s:u:number>="0":0:number and s:u:number<="9":0:number
711	#       i := 10*i + (s:u:number - "0":0:number) ; some := true
712	#     else
713	#       return undefined
714	#   if not some
715	#     return undefined
716	#   if start=1
717	#     i := -i
718
719
720	# function 'cast uInt' s -> ui
721	#   arg Str s ; arg uInt ui
722	#   ui := 0 ; var CBool some := false
723	#   for (var Int u) 0 s:len-1
724	#     if s:u:number>="0":0:number and s:u:number<="9":0:number
725	#       ui := 10*ui + (cast s:u:number - "0":0:number uInt) ; some := true
726	#     else
727	#       return 0
728	#   if not some
729	#     return 0
730
731
732
733
734
735	method data 'to string' options -> s
736	arg uInt data ; arg Str options s
737	if data<2^(uInt:bitsize-1)
738	s := 'convert to string' (cast data Int)
739	else
740	s := ('convert to string' data\10)+('convert to string' data%10)
741	# this method is redefined in int_extra.pli
742
743	method data 'from string' string options may_skip skiped offset -> status
744	arg_w uInt data ; arg Str string options ; arg CBool may_skip ; arg_w Int skiped offset ; arg Status status
745	var Int stop := string:len-1
746	if not may_skip and stop<>(-1)
747	stop := 0
748	for (var Int i) 0 stop
749	var Int c0 := string:i number
750	if c0>="0":0:number and c0<="9":0:number
751	skiped := i
752	data := 0
753	while i<string:len and { var Int c := string:i number ; c>="0":0:number and c<="9":0:number }
754	var uInt data2 := 10*data + (c - "0":0:number)
755	if data2\(cast 10 uInt)<>data
756	data := 0
757	return failure
758	data := data2
759	i := i+1
760	offset := i
761	return success
762	data := 0
763	status := failure
764
765	method data 'to string' options -> s
766	arg Int data ; arg Str options ; arg Str s
767	s := 'convert to string' data
768	# this method is redefined in int_extra.pli
769
770	method data 'from string' string options may_skip skiped offset -> status
771	arg_w Int data ; arg Str string options ; arg CBool may_skip ; arg_w Int skiped offset ; arg Status status
772	var Int stop := string:len-1
773	if not may_skip and stop<>(-1)
774	stop := 0
775	for (var Int i) 0 stop
776	var Int c0 := string:i number
777	if c0>="0":0:number and c0<="9":0:number
778	skiped := i
779	data := 0
780	while i<string:len and { var Int c := string:i number ; c>="0":0:number and c<="9":0:number }
781	var Int data2 := 10*data + (c - "0":0:number)
782	if data2\(cast 10 Int)<>data
783	data := undefined
784	return failure
785	data := data2
786	i := i+1
787	offset := i
788	return success
789	eif c0="-":0:number and i+1<>string:len and string:(i+1):number>="0":0:number and string:(i+1):number<="9":0:number
790	skiped := i
791	i := i+1
792	data := 0
793	while i<string:len and { var Int c := string:i number ; c>="0":0:number and c<="9":0:number }
794	var Int data2 := 10*data + (c - "0":0:number)
795	if data2\(cast 10 Int)<>data
796	data := undefined
797	return failure
798	data := data2
799	i := i+1
800	data := -data
801	offset := i
802	return success
803	eif c0="?":0:number
804	data := undefined
805	skiped := i
806	offset := i+1
807	return success
808	data := undefined
809	if string="" and (options="db" or options="raw")
810	status := success
811	else
812	status := failure
813
814
815	export 'cast Status' 'cast Int'
816
817
818
819
820
821	if processor_name="i386"
822
823	function assemble_shift i gc fun
824	arg_rw Instruction i ; arg_rw GeneratorContext gc ; arg Function fun
825	var Pointer:Instruction cur :> i
826	var Link:Argument r :> argument a_register
827	var Link:Argument ecx :> gc register i386_ecx
828	cur :> gc insert_after_instruction cur (instruction (the_function i386_mov Int Int) i:0 r)
829	cur :> gc insert_after_instruction cur (instruction (the_function i386_mov Int Int) i:1 ecx)
830	cur :> gc insert_after_instruction cur (instruction fun r ecx)
831	cur :> gc insert_after_instruction cur (instruction (the_function i386_mov Int Int) r i:2)
832	gc remove i
833
834
835	function i386_shl i ecx
836	arg Int i ecx
837	function i386_shl_generate_binary instr function
838	arg Instruction instr ; arg_rw Function function
839	check instr:1:where=argument_register and instr:1:register=i386_ecx
840	i386_regmem function 0D3h 1 4h instr:0
841	(the_function i386_shl Int Int) set_generate_binary (the_function i386_shl_generate_binary Instruction Function)
842	((the_function i386_shl Int Int) arg 0) access := access_read+access_write+access_byvalue
843
844	function shift_left a n -> r
845	arg Int a n r ; gcc_nocheck_inline "$3 = $1 << $2;"
846	function assemble_shift_left i gc
847	arg_rw Instruction i ; arg_rw GeneratorContext gc
848	assemble_shift i gc (the_function i386_shl Int Int)
849	(the_function shift_left Int Int -> Int) set_generate_assembly (the_function assemble_shift_left Instruction GeneratorContext)
850
851
852	function i386_sar i ecx
853	arg Int i ecx
854	function i386_sar_generate_binary instr function
855	arg Instruction instr ; arg_rw Function function
856	check instr:1:where=argument_register and instr:1:register=i386_ecx
857	i386_regmem function 0D3h 1 7h instr:0
858	(the_function i386_sar Int Int) set_generate_binary (the_function i386_sar_generate_binary Instruction Function)
859	((the_function i386_sar Int Int) arg 0) access := access_read+access_write+access_byvalue
860
861	function shift_right a n -> r
862	arg Int a n r ; gcc_nocheck_inline "$3 = $1 >> $2;"
863	function assemble_shift_right2 i gc
864	arg_rw Instruction i ; arg_rw GeneratorContext gc
865	assemble_shift i gc (the_function i386_sar Int Int)
866	(the_function shift_right Int Int -> Int) set_generate_assembly (the_function assemble_shift_right2 Instruction GeneratorContext)
867
868
869	function i386_shr i ecx
870	arg Int i ecx
871	function i386_shr_generate_binary instr function
872	arg Instruction instr ; arg_rw Function function
873	check instr:1:where=argument_register and instr:1:register=i386_ecx
874	i386_regmem function 0D3h 1 5h instr:0
875	(the_function i386_shr Int Int) set_generate_binary (the_function i386_shr_generate_binary Instruction Function)
876	((the_function i386_shr Int Int) arg 0) access := access_read+access_write+access_byvalue
877
878	function shift_right a n -> r
879	arg uInt a r ; arg Int n ; gcc_nocheck_inline "$3 = (unsigned int)$1 >> $2;"
880	function assemble_shift_right1 i gc
881	arg_rw Instruction i ; arg_rw GeneratorContext gc
882	assemble_shift i gc (the_function i386_shr Int Int)
883	(the_function shift_right uInt Int -> uInt) set_generate_assembly (the_function assemble_shift_right1 Instruction GeneratorContext)
884
885
886	function optimize_add gc
887	arg_rw GeneratorContext gc
888	var Link:Instruction i :> gc first_instruction
889	while addressof:i<>null
890	var Link:Instruction i2 :> null map Instruction
891	var Pointer:Function f :> i function
892	if pliant_debugging_level<2
893	if f=(the_function '+' Int Int -> Int)
894	i function :> the_function '.+.' Int Int -> Int
895	if f=(the_function '+' uInt uInt -> uInt)
896	i function :> the_function '.+.' uInt uInt -> uInt
897	if f=(the_function '-' Int Int -> Int)
898	i function :> the_function '.-.' Int Int -> Int
899	if f=(the_function '-' uInt uInt -> uInt)
900	i function :> the_function '.-.' uInt uInt -> uInt
901	f :> i function
902	if f=(the_function '.+.' Int Int -> Int) or f=(the_function '.+.' uInt uInt -> uInt) or f=(the_function '.-.' Int Int -> Int) or f=(the_function '.-.' uInt uInt -> uInt)
903	for (var Int p) 0 1
904	if i:p:where=argument_constant
905	var uInt cst := i:p:constant map uInt
906	if cst=0
907	if f=(the_function '.+.' Int Int -> Int) or f=(the_function '.+.' uInt uInt -> uInt)
908	i2 :> instruction (the_function 'copy atomic' Int Int) i:(1-p) i:2
909	if f=(the_function '.-.' Int Int -> Int) or f=(the_function '.-.' uInt uInt -> uInt)
910	if p=1
911	i2 :> instruction (the_function 'copy atomic' Int Int) i:0 i:2
912	if addressof:i2<>null
913	gc insert_after_instruction i i2
914	gc remove i
915	i :> i2
916	i :> i next_instruction
917
918	function optimize_shift i gc -> i2
919	arg_rw Instruction i ; arg_rw GeneratorContext gc ; arg_C Instruction i2
920	i2 :> null map Instruction
921	var Pointer:Function f :> i function
922	if f=(the_function '^' uInt Int -> uInt)
923	if i:0:where=argument_constant and (i:0:constant map uInt)=2
924	return (instruction (the_function shift_left Int Int -> Int) (argument constant uInt 1) i:1 i:2)
925	if pliant_debugging_level<2
926	if f=(the_function '*' Int Int -> Int)
927	i function :> the_function '.*.' Int Int -> Int
928	if f=(the_function '*' uInt uInt -> uInt)
929	i function :> the_function '.*.' uInt uInt -> uInt
930	f :> i function
931	if f=(the_function '.*.' Int Int -> Int) or f=(the_function '.*.' uInt uInt -> uInt) or f=(the_function '\' Int Int -> Int) or f=(the_function '\' uInt uInt -> uInt) or f=(the_function '%' uInt uInt -> uInt)
932	for (var Int p) 0 1
933	if i:p:where=argument_constant
934	var uInt cst := i:p:constant map uInt
935	if cst=1
936	if f=(the_function '.*.' Int Int -> Int) or f=(the_function '.*.' uInt uInt -> uInt)
937	return (instruction (the_function 'copy atomic' Int Int) i:(1-p) i:2)
938	if f=(the_function '\' Int Int -> Int) or f=(the_function '\' uInt uInt -> uInt)
939	if p=1
940	return (instruction (the_function 'copy atomic' Int Int) i:0  i:2)
941	for (var Int b) 0 Int:bitsize-2
942	if cst=2^b
943	if f=(the_function '.*.' Int Int -> Int) or f=(the_function '.*.' uInt uInt -> uInt)
944	return (instruction (the_function shift_left Int Int -> Int) i:(1-p) (argument constant Int b) i:2)
945	eif f=(the_function '\' Int Int -> Int)
946	if p=1
947	return (instruction (the_function shift_right Int Int -> Int) i:0 (argument constant Int b) i:2)
948	eif f=(the_function '\' uInt uInt -> uInt)
949	if p=1
950	return (instruction (the_function shift_right uInt Int -> uInt) i:0 (argument constant Int b) i:2)
951	eif f=(the_function '%' uInt uInt -> uInt)
952	if p=1
953	return (instruction (the_function '.and.' Int Int -> Int) i:0 (argument constant Int 2^b-1) i:2)
954	if f=(the_function '.*.' Int Int -> Int) or f=(the_function '.*.' uInt uInt -> uInt) or f=(the_function '\' Int Int -> Int) or f=(the_function '\' uInt uInt -> uInt)
955	var Pointer:Argument a :> i 1
956	if a:first_instruction:function=(the_function shift_left Int Int -> Int) and a:last_instruction=i
957	if a:is_temporary
958	var Pointer:Argument c :> a:first_instruction:0
959	if c:where=argument_constant and (c:constant map uInt)=1
960	if (a:first_instruction:1 is_stable a:first_instruction i)
961	var Link:Argument s :> a:first_instruction 1
962	gc remove a:first_instruction
963	if f=(the_function '.*.' Int Int -> Int) or f=(the_function '.*.' uInt uInt -> uInt)
964	return (instruction (the_function shift_left Int Int -> Int) i:0 s i:2)
965	eif f=(the_function '\' Int Int -> Int)
966	return (instruction (the_function shift_right Int Int -> Int) i:0 s i:2)
967	eif f=(the_function '\' uInt uInt -> uInt)
968	return (instruction (the_function shift_right uInt Int -> uInt) i:0 s i:2)
969
970	function optimize_shift gc
971	arg_rw GeneratorContext gc
972	var Link:Instruction i :> gc first_instruction
973	while addressof:i<>null
974	var Link:Instruction i2 :> optimize_shift i gc
975	if addressof:i2<>null
976	gc insert_after_instruction i i2
977	gc remove i
978	i :> i2
979	i :> i next_instruction
980
981	record_optimizer_function optimize_add "pliant optimizer rewrite instructions"
982	record_optimizer_function optimize_shift "pliant optimizer rewrite instructions"