/pliant/language/type/number/float.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	constant do_init true
20	constant buggy_pow true
21
22
23	type Float
24	field Int low high
25
26	alias Float64 Float
27
28
29	type Float32
30	field Int value
31	(addressof:Float32 map Type) flags := Float32:flags .and. .not. type_flag_atomic
32
33
34	if do_init
35	function i386_finit
36	void
37	function generate_i386_finit i f
38	arg_rw Instruction i ; arg_rw Function f
39	f code_immediat 11011011b 1 ; f code_immediat 11100011b 1
40	(the_function i386_finit) set_generate_binary (the_function generate_i386_finit Instruction Function)
41
42
43	function i386_wait
44	void
45	function generate_i386_wait i f
46	arg_rw Instruction i ; arg_rw Function f
47	f code_immediat 10011011b 1
48	(the_function i386_wait) set_generate_binary (the_function generate_i386_wait Instruction Function)
49
50
51	function i386_fld f
52	arg Float f
53	function generate_i386_fld64 i f
54	arg_rw Instruction i ; arg_rw Function f
55	i386_regmem f 11011101b 1 000b i:0
56	(the_function i386_fld Float) set_generate_binary (the_function generate_i386_fld64 Instruction Function)
57
58	function i386_fld f
59	arg Float32 f
60	function generate_i386_fld32 i f
61	arg_rw Instruction i ; arg_rw Function f
62	i386_regmem f 11011001b 1 000b i:0
63	(the_function i386_fld Float32) set_generate_binary (the_function generate_i386_fld32 Instruction Function)
64
65
66	function i386_fstp f
67	arg_w Float f
68	function generate_i386_fstp64 i f
69	arg_rw Instruction i ; arg_rw Function f
70	i386_regmem f 11011101b 1 011b i:0
71	(the_function i386_fstp Float) set_generate_binary (the_function generate_i386_fstp64 Instruction Function)
72
73	function i386_fstp f
74	arg_w Float32 f
75	function generate_i386_fstp32 i f
76	arg_rw Instruction i ; arg_rw Function f
77	i386_regmem f 11011001b 1 011b i:0
78	(the_function i386_fstp Float32) set_generate_binary (the_function generate_i386_fstp32 Instruction Function)
79
80
81	function i386_fincstp
82	void
83	function generate_i386_fincstp i f
84	arg_rw Instruction i ; arg_rw Function f
85	f code_immediat 0D9h 1 ; f code_immediat 0F7h 1
86	(the_function i386_fincstp) set_generate_binary (the_function generate_i386_fincstp Instruction Function)
87
88
89	function i386_faddp
90	void
91	function generate_i386_faddp i f
92	arg_rw Instruction i ; arg_rw Function f
93	f code_immediat 11011110b 1 ; f code_immediat 11000000b+1 1
94	the_function:i386_faddp set_generate_binary (the_function generate_i386_faddp Instruction Function)
95
96	function i386_fadd f
97	arg Float f
98	function generate_i386_fadd i f
99	arg_rw Instruction i ; arg_rw Function f
100	i386_regmem f 11011100b 1 000b i:0
101	(the_function i386_fadd Float) set_generate_binary (the_function generate_i386_fadd Instruction Function)
102
103	function '+' a b -> r
104	arg Float a b r
105	gcc_inline "*(double *)@3 = *(double *)@1 + *(double *)@2;"
106	function assemble_plus_Float i gc
107	arg_rw Instruction i ; arg_rw GeneratorContext gc
108	var Pointer:Instruction cur :> i
109	cur :> gc insert_after_instruction cur (instruction (the_function i386_fld Float) i:0)
110	cur :> gc insert_after_instruction cur (instruction (the_function i386_fadd Float) i:1)
111	cur :> gc insert_after_instruction cur (instruction (the_function i386_fstp Float) i:2)
112	cur :> gc insert_after_instruction cur (instruction the_function:i386_wait)
113	gc remove i
114	(the_function '+' Float Float -> Float) set_generate_assembly (the_function assemble_plus_Float Instruction GeneratorContext)
115
116
117	function i386_fsub f
118	arg Float f
119	function generate_i386_fsub i f
120	arg_rw Instruction i ; arg_rw Function f
121	i386_regmem f 11011100b 1 100b i:0
122	(the_function i386_fsub Float) set_generate_binary (the_function generate_i386_fsub Instruction Function)
123
124	function '-' a b -> r
125	arg Float a b r
126	gcc_inline "*(double *)@3 = *(double *)@1 - *(double *)@2;"
127	function assemble_minus_Float i gc
128	arg_rw Instruction i ; arg_rw GeneratorContext gc
129	var Pointer:Instruction cur :> i
130	cur :> gc insert_after_instruction cur (instruction (the_function i386_fld Float) i:0)
131	cur :> gc insert_after_instruction cur (instruction (the_function i386_fsub Float) i:1)
132	cur :> gc insert_after_instruction cur (instruction (the_function i386_fstp Float) i:2)
133	cur :> gc insert_after_instruction cur (instruction the_function:i386_wait)
134	gc remove i
135	(the_function '-' Float Float -> Float) set_generate_assembly (the_function assemble_minus_Float Instruction GeneratorContext)
136
137
138	function i386_fmul f
139	arg Float f
140	function generate_i386_fmul i f
141	arg_rw Instruction i ; arg_rw Function f
142	i386_regmem f 11011100b 1 001b i:0
143	(the_function i386_fmul Float) set_generate_binary (the_function generate_i386_fmul Instruction Function)
144
145	function '*' a b -> r
146	arg Float a b r
147	gcc_inline "*(double *)@3 = *(double *)@1 * *(double *)@2;"
148	function assemble_multiply_Float i gc
149	arg_rw Instruction i ; arg_rw GeneratorContext gc
150	var Pointer:Instruction cur :> i
151	cur :> gc insert_after_instruction cur (instruction (the_function i386_fld Float) i:0)
152	cur :> gc insert_after_instruction cur (instruction (the_function i386_fmul Float) i:1)
153	cur :> gc insert_after_instruction cur (instruction (the_function i386_fstp Float) i:2)
154	cur :> gc insert_after_instruction cur (instruction the_function:i386_wait)
155	gc remove i
156	(the_function '*' Float Float -> Float) set_generate_assembly (the_function assemble_multiply_Float Instruction GeneratorContext)
157
158
159	function i386_fdiv f
160	arg Float f
161	function generate_i386_fdiv i f
162	arg_rw Instruction i ; arg_rw Function f
163	i386_regmem f 11011100b 1 110b i:0
164	(the_function i386_fdiv Float) set_generate_binary (the_function generate_i386_fdiv Instruction Function)
165
166	function '/' a b -> r
167	arg Float a b r
168	gcc_inline "*(double *)@3 = *(double *)@1 / *(double *)@2;"
169	function assemble_divide_Float i gc
170	arg_rw Instruction i ; arg_rw GeneratorContext gc
171	var Pointer:Instruction cur :> i
172	cur :> gc insert_after_instruction cur (instruction (the_function i386_fld Float) i:0)
173	cur :> gc insert_after_instruction cur (instruction (the_function i386_fdiv Float) i:1)
174	cur :> gc insert_after_instruction cur (instruction (the_function i386_fstp Float) i:2)
175	cur :> gc insert_after_instruction cur (instruction the_function:i386_wait)
176	gc remove i
177	(the_function '/' Float Float -> Float) set_generate_assembly (the_function assemble_divide_Float Instruction GeneratorContext)
178
179
180	function i386_fcomp f
181	arg Float f
182	function generate_i386_fcomp i f
183	arg_rw Instruction i ; arg_rw Function f
184	i386_regmem f 11011100b 1 011b i:0
185	(the_function i386_fcomp Float) set_generate_binary (the_function generate_i386_fcomp Instruction Function)
186
187	function i386_fstsw_ax r
188	arg_w Int r
189	function generate_i386_fstsw_ax i f
190	arg_rw Instruction i ; arg_rw Function f
191	if i:0:where=argument_register and i:0:register=i386_eax
192	f code_immediat 11011111b 1 ; f code_immediat 11100000b 1
193	else
194	error error_id_unexpected "Expected eax"
195	(the_function i386_fstsw_ax Int) set_generate_binary (the_function generate_i386_fstsw_ax Instruction Function)
196
197	function compare_Float a b -> c
198	arg Float a b ; arg Int c
199	gcc_inline "$3 = *(double *)@1<*(double *)@2 ? "+'convert to string':compare_inferior+" : *(double *)@1>*(double *)@2 ? "+'convert to string':compare_superior+" : "+'convert to string':compare_equal+";"
200	gcc_inline_compare "$3 = *(double *)@1 compare *(double *)@2;"
201	function assemble_compare_Float i gc
202	arg_rw Instruction i ; arg_rw GeneratorContext gc
203	var Pointer:Instruction cur :> i
204	cur :> gc insert_after_instruction cur (instruction (the_function i386_fld Float) i:0)
205	cur :> gc insert_after_instruction cur (instruction (the_function i386_fcomp Float) i:1)
206	cur :> gc insert_after_instruction cur (instruction (the_function i386_fstsw_ax Int) (gc register i386_eax))
207	cur :> gc insert_after_instruction cur (instruction (the_function i386_mov Int Int) (gc register i386_eax) i:2)
208	gc remove i
209	(the_function compare_Float Float Float -> Int) set_generate_assembly (the_function assemble_compare_Float Instruction GeneratorContext)
210
211
212	function i386_fcomp f32
213	arg Float32 f32
214	function generate_i386_fcomp32 i f
215	arg_rw Instruction i ; arg_rw Function f
216	i386_regmem f 11011000b 1 011b i:0
217	(the_function i386_fcomp Float32) set_generate_binary (the_function generate_i386_fcomp32 Instruction Function)
218
219	function compare_Float32 a b -> c
220	arg Float32 a b ; arg Int c
221	gcc_inline "$3 = *(float *)@1<*(float *)@2 ? "+'convert to string':compare_inferior+" : *(float *)@1>*(float *)@2 ? "+'convert to string':compare_superior+" : "+'convert to string':compare_equal+";"
222	gcc_inline_compare "$3 = *(float *)@1 compare *(float *)@2;"
223	function assemble_compare_Float32 i gc
224	arg_rw Instruction i ; arg_rw GeneratorContext gc
225	var Pointer:Instruction cur :> i
226	cur :> gc insert_after_instruction cur (instruction (the_function i386_fld Float32) i:0)
227	cur :> gc insert_after_instruction cur (instruction (the_function i386_fcomp Float32) i:1)
228	cur :> gc insert_after_instruction cur (instruction (the_function i386_fstsw_ax Int) (gc register i386_eax))
229	cur :> gc insert_after_instruction cur (instruction (the_function i386_mov Int Int) (gc register i386_eax) i:2)
230	gc remove i
231	(the_function compare_Float32 Float32 Float32 -> Int) set_generate_assembly (the_function assemble_compare_Float32 Instruction GeneratorContext)
232
233
234	function i386_frndint
235	void
236	function generate_i386_frndint i f
237	arg_rw Instruction i ; arg_rw Function f
238	f code_immediat 11011001b 1 ; f code_immediat 11111100b 1
239	the_function:i386_frndint set_generate_binary (the_function generate_i386_frndint Instruction Function)
240
241	function i386_fstp i
242	arg Int i
243	function generate_i386_fstp_int i f
244	arg_rw Instruction i ; arg_rw Function f
245	i386_regmem f 11011011b 1 011b i:0
246	(the_function i386_fstp Int) set_generate_binary (the_function generate_i386_fstp_int Instruction Function)
247
248	function 'cast Int' f -> i
249	arg Float f ; arg Int i
250	gcc_inline "$2 = (int)(*(double *)@1+0.5);"
251	function assemble_cast_Float_Int i gc
252	arg_rw Instruction i ; arg_rw GeneratorContext gc
253	var Pointer:Instruction cur :> i
254	cur :> gc insert_after_instruction cur (instruction (the_function i386_fld Float) i:0)
255	cur :> gc insert_after_instruction cur (instruction the_function:i386_frndint)
256	if i:1:where=argument_indirect
257	cur :> gc insert_after_instruction cur (instruction (the_function i386_fstp Int) i:1)
258	else
259	cur :> gc insert_after_instruction cur (instruction (the_function i386_add Int Int) (argument constant Int -4) (gc register i386_esp))
260	cur :> gc insert_after_instruction cur (instruction (the_function i386_fstp Int) (argument indirect Int (gc register i386_esp) 0))
261	cur :> gc insert_after_instruction cur (instruction (the_function i386_pop Int) i:1)
262	cur :> gc insert_after_instruction cur (instruction the_function:i386_wait)
263	gc remove i
264	(the_function 'cast Int' Float -> Int) set_generate_assembly (the_function assemble_cast_Float_Int Instruction GeneratorContext)
265
266
267	function i386_fld i
268	arg Int i
269	function generate_i386_fld_int i f
270	arg_rw Instruction i ; arg_rw Function f
271	if i:0:where=argument_constant
272	var Link:Int imm :> new Int ; imm := i:0:constant map Int
273	f record_external addressof:imm false
274	i386_memory f 11011011b 1 000b undefined undefined 1 (cast addressof:imm Int)
275	else
276	i386_regmem f 11011011b 1 000b i:0
277	(the_function i386_fld Int) set_generate_binary (the_function generate_i386_fld_int Instruction Function)
278
279	function cast_Int_Float i -> f
280	arg Int i ; arg Float f
281	extension
282	gcc_inline "*(double *)@2 = $1;"
283	function assemble_cast_Int_Float i gc
284	arg_rw Instruction i ; arg_rw GeneratorContext gc
285	var Pointer:Instruction cur :> i
286	if i:0:where=argument_indirect
287	cur :> gc insert_after_instruction cur (instruction (the_function i386_fld Int) i:0)
288	else
289	cur :> gc insert_after_instruction cur (instruction (the_function i386_push Int) i:0)
290	cur :> gc insert_after_instruction cur (instruction (the_function i386_fld Int) (argument indirect Int (gc register i386_esp) 0))
291	cur :> gc insert_after_instruction cur (instruction (the_function i386_add Int Int) (argument constant Int 4) (gc register i386_esp))
292	check i:1:where=argument_indirect
293	cur :> gc insert_after_instruction cur (instruction (the_function i386_fstp Float) i:1)
294	cur :> gc insert_after_instruction cur (instruction the_function:i386_wait)
295	gc remove i
296	(the_function cast_Int_Float Int -> Float) set_generate_assembly (the_function assemble_cast_Int_Float Instruction GeneratorContext)
297
298	alias 'cast Float' cast_Int_Float in "/pliant/language/basic/ultrasafe.pli"
299
300
301	function 'cast Float' f32 -> f
302	arg Float32 f32 ; arg Float f
303	extension
304	gcc_inline "*(double *)@2 = *(float *)@1;"
305	function assemble_cast_Float32_Float i gc
306	arg_rw Instruction i ; arg_rw GeneratorContext gc
307	var Pointer:Instruction cur :> i
308	cur :> gc insert_after_instruction cur (instruction (the_function i386_fld Float32) i:0)
309	cur :> gc insert_after_instruction cur (instruction (the_function i386_fstp Float) i:1)
310	cur :> gc insert_after_instruction cur (instruction the_function:i386_wait)
311	gc remove i
312	(the_function 'cast Float' Float32 -> Float) set_generate_assembly (the_function assemble_cast_Float32_Float Instruction GeneratorContext)
313
314	function 'cast Float32' f -> f32
315	arg Float f ; arg Float32 f32
316	reduction
317	gcc_inline "*(float *)@2 = *(double *)@1;"
318	function assemble_cast_Float_Float32 i gc
319	arg_rw Instruction i ; arg_rw GeneratorContext gc
320	var Pointer:Instruction cur :> i
321	cur :> gc insert_after_instruction cur (instruction (the_function i386_fld Float) i:0)
322	cur :> gc insert_after_instruction cur (instruction (the_function i386_fstp Float32) i:1)
323	cur :> gc insert_after_instruction cur (instruction the_function:i386_wait)
324	gc remove i
325	(the_function 'cast Float32' Float -> Float32) set_generate_assembly (the_function assemble_cast_Float_Float32 Instruction GeneratorContext)
326
327
328	module "/pliant/language/type/misc/status.pli"
329
330	function 'cast Status' f -> s
331	arg Float f ; arg Status s
332	explicit
333	if (f:high .and. 7FF00000h)=7FF00000h
334	s := undefined
335	else
336	s := defined
337
338	function 'cast Float' s -> f
339	arg Status s ; arg Float f
340	extension
341	if s<>undefined
342	error error_id_unexpected "Unexpected Status value"
343	f low := -1 ; f high := -1
344
345	function 'cast Status' f32 -> s
346	arg Float32 f32 ; arg Status s
347	explicit
348	if (f32:value .and. 7F800000h)=7F800000h
349	s := undefined
350	else
351	s := defined
352
353	function 'cast Float32' s -> f32
354	arg Status s ; arg Float32 f32
355	extension
356	if s<>undefined
357	error error_id_unexpected "Unexpected Status value"
358	f32 value := -1
359
360	function i386_fabs
361	void
362	function generate_i386_fabs i f
363	arg_rw Instruction i ; arg_rw Function f
364	f code_immediat 11011001b 1 ; f code_immediat 11100001b 1
365	the_function:i386_fabs set_generate_binary (the_function generate_i386_fabs Instruction Function)
366
367	function abs f -> r
368	arg Float f r
369	gcc_inline "*(double *)@2 = (*(double *)@1>=0 ? *(double *)@1 : -*(double *)@1);"
370	function assemble_abs_Float i gc
371	arg_rw Instruction i ; arg_rw GeneratorContext gc
372	var Pointer:Instruction cur :> i
373	cur :> gc insert_after_instruction cur (instruction (the_function i386_fld Float) i:0)
374	cur :> gc insert_after_instruction cur (instruction the_function:i386_fabs)
375	cur :> gc insert_after_instruction cur (instruction (the_function i386_fstp Float) i:1)
376	cur :> gc insert_after_instruction cur (instruction the_function:i386_wait)
377	gc remove i
378	(the_function abs Float -> Float) set_generate_assembly (the_function assemble_abs_Float Instruction GeneratorContext)
379
380
381	function i386_fyl2x
382	void
383	function generate_i386_fyl2x i f
384	arg_rw Instruction i ; arg_rw Function f
385	f code_immediat 11011001b 1 ; f code_immediat 11110001b 1
386	the_function:i386_fyl2x set_generate_binary (the_function generate_i386_fyl2x Instruction Function)
387
388	function i386_fldlg2
389	void
390	function generate_i386_fldlg2 i f
391	arg_rw Instruction i ; arg_rw Function f
392	f code_immediat 11011001b 1 ; f code_immediat 11101100b 1
393	the_function:i386_fldlg2 set_generate_binary (the_function generate_i386_fldlg2 Instruction Function)
394
395	function log10 f -> r
396	arg Float f r
397	gcc_inline "asm( [dq]fldlg2\n[dq] [dq]fxch\n[dq] [dq]fyl2x[dq] : [dq]=t[dq] (*(double *)@2) : [dq]0[dq] (*(double *)@1));"
398	function assemble_log10_Float i gc
399	arg_rw Instruction i ; arg_rw GeneratorContext gc
400	var Pointer:Instruction cur :> i
401	cur :> gc insert_after_instruction cur (instruction the_function:i386_fldlg2)
402	cur :> gc insert_after_instruction cur (instruction (the_function i386_fld Float) i:0)
403	cur :> gc insert_after_instruction cur (instruction the_function:i386_fyl2x)
404	cur :> gc insert_after_instruction cur (instruction (the_function i386_fstp Float) i:1)
405	cur :> gc insert_after_instruction cur (instruction the_function:i386_wait)
406	gc remove i
407	(the_function log10 Float -> Float) set_generate_assembly (the_function assemble_log10_Float Instruction GeneratorContext)
408
409
410	function power_inline_code
411	void
412	function generate_power_inline_code i f
413	arg_rw Instruction i ; arg_rw Function f
414	f code_immediat 0D9h 1 ; f code_immediat 0F1h 1  # fyl2x
415	f code_immediat 0D9h 1 ; f code_immediat 0C0h 1  # fld st(0)
416	f code_immediat 0D9h 1 ; f code_immediat 0FCh 1  # frndint
417	f code_immediat 0D9h 1 ; f code_immediat 0C9h 1  # fxch st(1)
418	f code_immediat 0D8h 1 ; f code_immediat 0E9h 1  # fsubr st(1)
419	f code_immediat 0D9h 1 ; f code_immediat 0E0h 1  # fchs
420	f code_immediat 0D9h 1 ; f code_immediat 0F0h 1  # f2xm1
421	f code_immediat 0D9h 1 ; f code_immediat 0E8h 1  # fld1
422	f code_immediat 0DEh 1 ; f code_immediat 0C1h 1  # faddp st(1)
423	f code_immediat 0D9h 1 ; f code_immediat 0FDh 1  # fscale
424	if not buggy_pow
425	f code_immediat 0D9h 1 ; f code_immediat 0C9h 1  # fxch st(1)
426	f code_immediat 0D9h 1 ; f code_immediat 0F7h 1  # fincstp
427	the_function:power_inline_code set_generate_binary (the_function generate_power_inline_code Instruction Function)
428	gvar Int old_debugging_level := pliant_debugging_level_variable ; pliant_debugging_level_variable := 0
429	gcc_off
430	function 'pliant power raw code'
431	power_inline_code
432	pliant_debugging_level_variable := old_debugging_level
433
434	function assemble_power i gc
435	arg_rw Instruction i ; arg_rw GeneratorContext gc
436	var Pointer:Instruction cur :> i
437	cur :> gc insert_after_instruction cur (instruction (the_function i386_fld Float) i:1)
438	cur :> gc insert_after_instruction cur (instruction (the_function i386_fld Float) i:0)
439	var Link:Instruction ii :> new Instruction
440	ii function :> the_function 'pliant power raw code'
441	cur :> gc insert_after_instruction cur ii
442	cur :> gc insert_after_instruction cur (instruction (the_function i386_fstp Float) i:2)
443	cur :> gc insert_after_instruction cur (instruction the_function:i386_wait)
444	if buggy_pow
445	cur :> gc insert_after_instruction cur (instruction the_function:i386_finit)
446	gc remove i
447
448	function '^' x y -> r
449	arg Float x y r
450	if buggy_pow
451	gcc_inline (constant "asm volatile( [dq]fldl (%1)\n[dq] [dq]fldl (%0)\n[dq] [dq]call "+'convert to string':(cast the_function:'pliant power raw code':executable Int)+"\n[dq] [dq]fstpl (%2)\n[dq] [dq]fwait\n[dq] [dq]finit\n[dq] : : [dq]r[dq]((int)@1) , [dq]r[dq]((int)@2) , [dq]r[dq]((int)@3) : [dq]memory[dq]);")
452	else
453	gcc_inline (constant "asm volatile( [dq]fldl (%1)\n[dq] [dq]fldl (%0)\n[dq] [dq]call "+'convert to string':(cast the_function:'pliant power raw code':executable Int)+"\n[dq] [dq]fstpl (%2)\n[dq] [dq]fwait\n[dq] : : [dq]r[dq]((int)@1) , [dq]r[dq]((int)@2) , [dq]r[dq]((int)@3) : [dq]memory[dq]);")
454	(the_function '^' Float Float -> Float) set_generate_assembly (the_function assemble_power Instruction GeneratorContext)
455
456
457	function fmod_inline_code
458	void
459	function generate_fmod_inline_code i f
460	arg_rw Instruction i ; arg_rw Function f
461	f code_immediat 0D9h 1 ; f code_immediat 0F8h 1  # fprem
462	f code_immediat 0DFh 1 ; f code_immediat 0E0h 1  # fnstsw ax
463	f code_immediat 09Eh 1                           # sahf
464	f code_immediat 07Ah 1 ; f code_immediat 0F9h 1  # jp <beginning>
465	f code_immediat 0DDh 1 ; f code_immediat 0D9h 1  # ftsp st(1)
466	the_function:fmod_inline_code set_generate_binary (the_function generate_fmod_inline_code Instruction Function)
467	old_debugging_level := pliant_debugging_level_variable ; pliant_debugging_level_variable := 0
468	function fmod_raw_code
469	fmod_inline_code
470	pliant_debugging_level_variable := old_debugging_level
471
472	function assemble_fmod i gc
473	arg_rw Instruction i ; arg_rw GeneratorContext gc
474	var Pointer:Instruction cur :> i
475	cur :> gc insert_after_instruction cur (instruction (the_function i386_fld Float) i:1)
476	cur :> gc insert_after_instruction cur (instruction (the_function i386_fld Float) i:0)
477	var Link:Instruction ii :> new Instruction
478	ii function :> the_function fmod_raw_code
479	cur :> gc insert_after_instruction cur ii
480	cur :> gc insert_after_instruction cur (instruction (the_function i386_fstp Float) i:2)
481	cur :> gc insert_after_instruction cur (instruction the_function:i386_wait)
482	gc remove i
483
484	function '%' x y -> r
485	arg Float x y r
486	(the_function '%' Float Float -> Float) set_generate_assembly (the_function assemble_fmod Instruction GeneratorContext)
487
488
489	method data 'from string' string options may_skip skiped offset -> status
490	arg_w Float data ; arg Str string options ; arg CBool may_skip ; arg_w Int skiped offset ; arg Status status
491	var Int stop := string:len-1
492	if not may_skip and stop<>(-1)
493	stop := 0
494	for (var Int i) 0 stop
495	var Int c0 := string:i number
496	if c0>="0":0:number and c0<="9":0:number or c0="?":0:number or (c0="-":0:number and i+1<>string:len and string:(i+1):number>="0":0:number and string:(i+1):number<="9":0:number)
497	skiped := i
498	if c0="?":0:number
499	data := undefined
500	offset := i+1
501	return success
502	data := 0 ; var Int sign := 1
503	if c0="-":0:number
504	sign := -1
505	i := i+1
506	while i<string:len and string:i:number>="0":0:number and string:i:number<="9":0:number
507	data := data*10 + string:i:number-"0":0:number
508	i := i+1
509	if i<string:len and string:i:number=".":0:number
510	i := i+1
511	var Float deci := 1
512	while i<string:len and string:i:number>="0":0:number and string:i:number<="9":0:number
513	deci := deci/10
514	data := data + (string:i:number-"0":0:number)*deci
515	i := i+1
516	if i<string:len and (string:i:number="e":0:number or string:i:number="E":0:number)
517	if (from_string addressof:(var Int expo) Int (string i+1 string:len) "" false (var Int skiped2) (var Int offset2))=success
518	data := data * (cast 10 Float)^expo
519	i := i+1+offset2
520	data := data * sign
521	offset := i
522	return success
523	data := undefined
524	status := shunt string="" and options="db" success failure
525
526
527	function parse_float context line parameter
528	arg_rw ParserContext context ; arg Str line ; arg Address parameter
529	if (from_string addressof:(var Float data) Float line "" false (var Int skip) (var Int offset))=failure
530	return
531	if ((line 0 offset) search "." -1)=(-1) and ((line 0 offset) search "e" -1)=(-1) and ((line 0 offset) search "E" -1)=(-1)
532	return
533	if line:0:number="-":0:number or line:0:number="?":0:number
534	return
535	if offset<>line:len and line:offset:isidentcharacter
536	return
537	var Link:Float f :> new Float
538	f := data
539	context add_token addressof:f
540	context forward offset
541
542	gvar ParserFilter float_filter
543	float_filter function :> the_function parse_float ParserContext Str Address
544	constant 'pliant parser basic types' float_filter
545	export 'pliant parser basic types'
546
547
548	function compare a b -> c
549	arg Float a b ; arg Int c
550	gcc_inline "$3 = *(double *)@1<*(double *)@2 ? "+'convert to string':compare_inferior+" : *(double *)@1>*(double *)@2 ? "+'convert to string':compare_superior+" : "+'convert to string':compare_equal+";"
551	gcc_inline_compare "$3 = *(double *)@1 compare *(double *)@2;"
552	var Int r := compare_Float a b
553	if (r .and. 2^14+2^8)=2^14+2^8
554	return (compare (cast a Status) (cast b Status))
555	eif (r .and. 2^14)<>0
556	return compare_equal
557	eif (r .and. 2^8)<>0
558	return compare_inferior
559	else
560	return compare_superior
561
562	function compare a b -> c
563	arg Float32 a b ; arg Int c
564	gcc_inline "$3 = *(float *)@1<*(float *)@2 ? "+'convert to string':compare_inferior+" : *(float *)@1>*(float *)@2 ? "+'convert to string':compare_superior+" : "+'convert to string':compare_equal+";"
565	gcc_inline_compare "$3 = *(float *)@1 compare *(float *)@2;"
566	var Int r := compare_Float32 a b
567	if (r .and. 2^14+2^8)=2^14+2^8
568	return (compare (cast a Status) (cast b Status))
569	eif (r .and. 2^14)<>0
570	return compare_equal
571	eif (r .and. 2^8)<>0
572	return compare_inferior
573	else
574	return compare_superior
575
576
577	function display_float ff dig_maxi dec_mini dec_maxi e_mini e_maxi undef -> s
578	arg Float ff ; arg Int dig_maxi dec_mini dec_maxi e_mini e_maxi ; arg Str undef ; arg Str s
579	if dig_maxi<=0
580	error error_id_unexpected "out of range dig_maxi"
581	if dec_mini<0 or dec_maxi<dec_mini
582	error error_id_unexpected "out of range dec_mini or dec_maxi"
583	if ff=undefined
584	return undef
585	var Float f
586	if ff>=0
587	s := "" ; f := ff
588	else
589	s := "-" ; f := 0-ff
590	var Int e
591	if f>=1e-300
592	e := cast log10:f-0.5 Int
593	else
594	e := 0
595	if e<=e_mini or e>=e_maxi
596	f := f/10.0^e
597	else
598	e := 0
599	var Int n := 0
600	while f>=1
601	n := n+1 ; f := f/10
602	var Int dec := max (min dec_maxi dig_maxi-n) dec_mini
603	var Float delta := 0.1^(n+dec)
604	if f+0.5*delta>=1
605	n := n+1 ; f := f/10
606	dec := max (min dec_maxi dig_maxi-n) dec_mini
607	delta := 0.1^(n+dec)
608	f := f+0.5*delta
609	if n<>0
610	for (var Int i) 1 n
611	f := f*10 ; delta := delta*10
612	var Int d := min (max (cast f-0.5 Int) 0) 9
613	s := s+(character "0":0:number+d)
614	f := f-d
615	else
616	s := s+"0"
617	if (f>delta and dec>0) or dec_mini>0
618	s := s+"."
619	var Int i := 0
620	while (f>delta and i<dec) or i<dec_mini
621	f := f*10 ; delta := delta*10
622	d := min (max (cast f-0.5 Int) 0) 9
623	s := s+(character "0":0:number+d)
624	f := f-d
625	i := i+1
626	eif n=0
627	s := "0"
628	if e<>0
629	s := s+"e"+('convert to string' e)
630
631	method data 'to string' options -> string
632	arg Float32 data ; arg Str options string
633	if options:len=7 and (options 0 6)="fixed "
634	var Int fixed := options:6:number-"0":number
635	string := display_float data 6 fixed fixed -6 6 ""
636	else
637	string := display_float data 6 0 6 -6 6 (shunt options="db" or options="raw" "" "?")
638
639	method data 'to string' options -> string
640	arg Float data ; arg Str options string
641	if options:len=7 and (options 0 6)="fixed "
642	var Int fixed := options:6:number-"0":number
643	string := display_float data 12 fixed fixed -12 12 ""
644	else
645	string := display_float data 12 0 12 -12 12 (shunt options="db" or options="raw" "" "?")
646
647
648	function '-' a -> r
649	arg Float a r
650	gcc_inline "*(double *)@2 = - *(double *)@1;"
651	r := 0.0-a
652
653
654	function '-' u -> i
655	arg uInt u ; arg Int i
656	gcc_inline "$2 = - $1;"
657	i := -(cast u Int)
658	# todo: add inline assembly for the_function '-' Int -> Int
659	# (the_function '-' uInt -> Int) set_generate_assembly (the_function '-' Int -> Int):generate_assembly
660
661	function i386_fld64 i64
662	arg Int i64
663	function generate_i386_fld_int64 i f
664	arg_rw Instruction i ; arg_rw Function f
665	i386_regmem f 11011111b 1 101b i:0
666	(the_function i386_fld64 Int) set_generate_binary (the_function generate_i386_fld_int64 Instruction Function)
667
668	function cast_uInt_Float u -> f
669	arg uInt u ; arg Float f
670	extension
671	gcc_inline "*(double *)@2 = (unsigned int)$1;"
672	if u<2^31
673	f := cast_Int_Float (cast u Int)
674	else
675	f := 2.0^31+cast_Int_Float:(cast u .-. 2^31 Int)
676
677	function assemble_cast_uInt_Float i gc
678	arg_rw Instruction i ; arg_rw GeneratorContext gc
679	var Pointer:Instruction cur :> i
680	cur :> gc insert_after_instruction cur (instruction (the_function i386_push Int) (argument constant Int 0))
681	cur :> gc insert_after_instruction cur (instruction (the_function i386_push Int) i:0)
682	cur :> gc insert_after_instruction cur (instruction (the_function i386_fld64 Int) (argument indirect Int (gc register i386_esp) 0))
683	cur :> gc insert_after_instruction cur (instruction (the_function i386_add Int Int) (argument constant Int 8) (gc register i386_esp))
684	check i:1:where=argument_indirect
685	cur :> gc insert_after_instruction cur (instruction (the_function i386_fstp Float) i:1)
686	cur :> gc insert_after_instruction cur (instruction the_function:i386_wait)
687	gc remove i
688	# (the_function cast_uInt_Float uInt -> Float) set_generate_assembly (the_function assemble_cast_uInt_Float Instruction GeneratorContext)
689	# known bug: assemble_cast_uInt_Float breaks some programs
690
691	alias 'cast Float' cast_uInt_Float in "/pliant/language/basic/ultrasafe.pli"
692
693
694	export Float Float32 Float64 '+' '-' '*' '/'
695	export 'cast Int' 'cast Float' 'cast Float32' 'cast Status' compare
696	export abs log10 '^' '%'
697	export display_float parse_float
698
699
700	if do_init
701	i386_finit
702	function init_coprocessor p fh
703	arg Address p ; arg Int fh
704	i386_finit
705	gvar DelayedAction restore
706	restore function :> the_function init_coprocessor Address Int
707	pliant_restore_actions append addressof:restore
708
709
710	function min f1 f2 -> f
711	arg Float f1 f2 f
712	weak_definition
713	f := shunt f1<=f2 f1 f2
714
715	function max f1 f2 -> f
716	arg Float f1 f2 f
717	weak_definition
718	f := shunt f1>=f2 f1 f2
719
720	export min max