/pliant/language/compiler/expression/expression2.pli
1	# Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx
2	# Copyright (C) 1999  Patrice Ossona de Mendez  pom@ehess.fr
3	#
4	# This program is free software; you can redistribute it and/or
5	# modify it under the terms of the GNU General Public License version 2
6	# as published by the Free Software Foundation.
7	#
8	# This program is distributed in the hope that it will be useful,
9	# but WITHOUT ANY WARRANTY; without even the implied warranty of
10	# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
11	# GNU General Public License for more details.
12	#
13	# You should have received a copy of the GNU General Public License
14	# version 2 along with this program; if not, write to the Free Software
15	# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
16
17	scope "/pliant/language/" "/pliant/install/"
18	module "/pliant/install/ring2.pli"
19
20
21	method e packed_size -> s
22	arg Expression e ; arg Int s
23	if (entry_type e:value)=Ident and (e:value map Str):len<256
24	s := Int:size+(e:value map Str):len
25	else
26	s := Address size
27	s := s+ListingPosition:size
28	s := s+Int:size
29	for (var Int i) 0 e:size-1
30	s := s+(e:i packed_size)
31
32	function pack e c
33	arg Expression e ; arg_rw Address c
34	if (entry_type e:value)=Ident and (e:value map Str):len<256
35	var Int l := (e:value map Str) len
36	c map Int := l ; c := c translate Int 1
37	memory_copy (e:value map Str):characters c l ; c := c translate Byte l
38	else
39	c map Address := e value ; entry_lock e:value ; c := c translate Address 1
40	ListingPosition build_instance c
41	c map ListingPosition := e position ; c := c translate ListingPosition 1
42	c map Int := e size ; c := c translate Int 1
43	for (var Int i) 0 e:size-1
44	pack e:i c
45
46	function unpack c -> e
47	arg_rw Address c ; arg Link:Expression e
48	e :> new Expression
49	if (c map Int)>=0 and (c map Int)<256
50	var Int l := c map Int ; c := c translate Int 1
51	(var Str s) set c l false
52	e value := entry_new Ident
53	e:value map Str := s ; c := c translate Byte l
54	else
55	e value := c map Address ; c := c translate Address 1
56	e position := c map ListingPosition ; c := c translate ListingPosition 1
57	e 'size :=' (c map Int) ; c := c translate Int 1
58	for (var Int i) 0 e:size-1
59	e:arguments i := addressof unpack:c
60
61	function drop c
62	arg_rw Address c
63	if (c map Int)>=0 and (c map Int)<256
64	var Int l := c map Int ; c := (c translate Int 1) translate Byte l
65	else
66	entry_unlock (c map Address) ; c := c translate Address 1
67	ListingPosition destroy_instance c ; c := c translate ListingPosition 1
68	l := c map Int ; c := c translate Int 1
69	for (var Int i) 0 l-1
70	drop c
71
72	type PackedExpression
73	field Address buffer <- null
74
75	function destroy pe
76	arg_w PackedExpression pe
77	if pe:buffer<>null
78	var Address c := pe buffer
79	drop c
80	memory_free pe:buffer
81
82	function 'cast (Link PackedExpression)' e -> pe
83	arg Expression e ; arg Link:PackedExpression pe
84	implicit
85	pe :> new PackedExpression
86	var Int ps := e packed_size
87	pe buffer := memory_allocate ps addressof:pe
88	var Address c := pe buffer ; pack e c
89	check c=(pe:buffer translate Byte ps)
90
91	function 'cast (Link Expression)' pe -> e
92	arg PackedExpression pe ; arg Link:Expression e
93	implicit
94	check pe:buffer<>null
95	var Address c := pe buffer
96	e :> unpack c
97
98	export PackedExpression 'cast (Link PackedExpression)' 'cast (Link Expression)'
99
100
101	function duplicate e -> e2
102	arg Expression e ; arg_RW Expression e2
103	e2 :> new Expression
104	e2 module :> e module
105	e2 position := e position
106	e2 value := e value
107	e2 'size :=' e:size
108	for (var Int i) 0 e:size-1
109	e2:arguments i := addressof (duplicate e:i)
110
111
112	method e 'ident :=' id
113	arg_rw Expression e ; arg Str id
114	e value := entry_new Ident
115	e:value map Ident := cast id Ident
116
117
118	method e near original
119	arg_rw Expression e ; arg Expression original
120	if (addressof e:module)=null
121	e module :> original module
122	if e:position=""
123	e position := original position
124	for (var Int i) 0 e:size-1
125	e:i near original
126
127	method e near_nothing
128	arg_rw Expression e
129	e module :> null map Module
130	e position := var ListingPosition empty_position
131	for (var Int i) 0 e:size-1
132	e:i near_nothing
133
134	function duplicate_near_nothing e -> e2
135	arg Expression e ; arg_RW Expression e2
136	e2 :> duplicate e
137	e2 near_nothing
138
139
140	method e is_linked -> c
141	arg Expression e ; arg CBool c
142	for (var Int i) 0 e:size-1
143	if not e:i:is_linked
144	return false
145	c := (addressof e:module)<>null
146
147
148	type ExpressionRange
149	field Link:Expression expr
150	field Int base nb
151
152	method e '' base nb -> range
153	arg Expression e ; arg Int base nb ; arg ExpressionRange range
154	check base>=0 and nb>=0 and base+nb<=e:size
155	range expr :> e
156	range base := base
157	range nb := nb
158
159
160	method e substitute id value -> newone
161	arg_rw Expression e ; arg Str id ; arg Expression value ; arg_RW Expression newone
162	check value:is_linked error_id_unexpected "The substituted expression must be linked to a module"
163	if e:ident=id and (addressof e:module)=null
164	if e:size=0
165	newone :> duplicate:value
166	eif value:size=0
167	newone :> duplicate value
168	newone 'size :=' e:size
169	for (var Int i) 0 e:size-1
170	newone:arguments i := addressof (e:i substitute id value)
171	else
172	newone :> new Expression
173	newone position := e position
174	newone module :> e module
175	newone value := addressof entry_new:Ident ; (newone value) map Ident := cast "()" Ident
176	newone 'size :=' e:size+1
177	newone:arguments 0 := addressof (duplicate value)
178	for (var Int i) 0 e:size-1
179	e:arguments i+1 := addressof (e:i substitute id value)
180	else
181	for (var Int i) 0 e:size-1
182	e:arguments i := addressof (e:i substitute id value)
183	newone :> e
184
185
186	method e substitute id values
187	arg_rw Expression e ; arg Str id ; arg ExpressionRange values
188	if pliant_debugging_level>=2
189	for (var Int i) 0 values:nb-1
190	check values:expr:(values:base+i):is_linked error_id_unexpected "The substituted expressions must be linked to a module"
191	var Int i := 0
192	while i<e:size
193	if e:i:is_pure_ident and e:i:ident=id and (addressof e:i:module)=null
194	if values:nb>1
195	e:arguments 'size :=' e:size+values:nb-1
196	for (var Int j) e:size-values:nb i step -1
197	e:arguments j+(values:nb-1) := e:arguments j
198	eif values:nb=0
199	for (var Int j) i e:size-2
200	e:arguments j := e:arguments j+1
201	e:arguments 'size :=' e:size-1
202	for (var Int j) 0 values:nb-1
203	e:arguments i+j := addressof (duplicate values:expr:(values:base+j))
204	i := i+values:nb
205	else
206	e:i substitute id values
207	i := i+1
208
209
210	method e insert id value
211	arg_rw Expression e ; arg Str id ; arg Expression value
212	check value:is_linked error_id_unexpected "The substituted expression must be linked to a module"
213	var Int i := 0
214	while i<e:size
215	if e:i:is_pure_ident and e:i:ident=id and (addressof e:i:module)=null
216	e:arguments 'size :=' e:size+1
217	for (var Int j) e:size-2 i step -1
218	e:arguments j+1 := e:arguments j
219	e:arguments i := addressof duplicate:value
220	i := i+2
221	else
222	e:i insert id value
223	i := i+1
224
225	method e remove id
226	arg_rw Expression e ; arg Str id
227	var Int i := 0
228	while i<e:size
229	if e:i:is_pure_ident and e:i:ident=id and (addressof e:i:module)=null
230	for (var Int j) i e:size-2
231	e:arguments j := e:arguments j+1
232	e:arguments 'size :=' e:size-1
233	else
234	e:i remove id
235	i := i+1
236
237
238	gvar Int counter := 0
239
240	method e auto_rename2 dict
241	arg_rw Expression e ; arg_rw Dictionary dict
242	if e:ident:len>0 and (e:ident e:ident:len-1 1)="_" and (addressof e:module)=null
243	var Link:Ident id
244	var Pointer:Arrow a :> dict first e:ident
245	if a=null
246	counter := counter+1
247	id :> new Ident
248	id := cast "pliant ident "+'convert to string':counter+"("+e:ident+")" Ident
249	dict insert e:ident true addressof:id
250	else
251	id :> a map Ident
252	e value := addressof:id
253	for (var Int i) 0 e:size-1
254	e:i auto_rename2 dict
255
256	method e auto_rename
257	arg_rw Expression e
258	var Dictionary dict
259	e auto_rename2 dict
260
261
262	function new_expression -> e2
263	arg_RW Expression e2
264	e2 :> new Expression
265
266	method e set_constant_value type value
267	arg_rw Expression e ; arg Type type ; arg Universal value
268	e value := entry_new type
269	type copy_instance addressof:value e:value
270
271	method e set_mapped_constant_value type value
272	arg_rw Expression e ; arg Type type ; arg Universal value
273	e value := addressof:value
274
275	method e add_subexpression sub
276	arg_rw Expression e ; arg Expression sub
277	var Int i := e size
278	e 'size :=' i+1
279	e:arguments i := addressof sub
280
281	method e add_subexpressions range
282	arg_rw Expression e ; arg ExpressionRange range
283	var Int i := e size
284	e 'size :=' i+range:nb
285	for (var Int j) 0 range:nb-1
286	e:arguments i+j := addressof (range:expr range:base+j)
287
288	meta expression e
289	var CBool done := false
290	var Link:Argument expr :> argument indirect Expression (argument local Address) 0
291	var Int i := 0
292	while i<e:size
293	if e:i:ident="map" and i+1<e:size and (e:(i+1) cast Expression) and not done
294	e suckup e:(i+1)
295	expr :> e:(i+1) result
296	done := true ; i := i+2
297	eif e:i:ident="duplicate" and i+1<e:size and (e:(i+1) cast Expression) and not done
298	e suckup e:(i+1)
299	e add (instruction (the_function duplicate Expression -> Expression) e:(i+1):result expr)
300	done := true ; i := i+2
301	eif e:i:ident="immediat" and i+1<e:size and not done
302	e add (instruction (the_function duplicate Expression -> Expression) (argument mapped_constant Expression (duplicate_near_nothing e:(i+1))) expr)
303	done := true ; i := i+2
304	eif e:i:ident="constant" and i+1<e:size
305	if not done
306	e add (instruction (the_function new_expression -> Expression) expr)
307	done := true
308	e:(i+1) compile
309	var Pointer:Type t :>e:(i+1):result:type:real_data_type
310	if not (e:(i+1) cast t) return
311	e suckup e:(i+1)
312	e add (instruction (the_function '. set_constant_value' Expression Type Universal) expr (argument mapped_constant Type t) e:(i+1):result)
313	i := i+2
314	eif e:i:ident="mapped_constant" and i+1<e:size
315	if not done
316	e add (instruction (the_function new_expression -> Expression) expr)
317	done := true
318	e:(i+1) compile
319	var Pointer:Type t :>e:(i+1):result:type:real_data_type
320	if not (e:(i+1) cast t) return
321	e suckup e:(i+1)
322	e add (instruction (the_function '. set_mapped_constant_value' Expression Type Universal) expr (argument mapped_constant Type t) e:(i+1):result)
323	i := i+2
324	eif e:i:ident="ident" and i+1<e:size and (e:(i+1) cast Str)
325	if not done
326	e add (instruction (the_function new_expression -> Expression) expr)
327	done := true
328	e suckup e:(i+1)
329	e add (instruction (the_function '. ident :=' Expression Str) expr e:(i+1):result)
330	i := i+2
331	eif e:i:ident="auto_rename" and done
332	e add (instruction (the_function '. auto_rename' Expression) expr)
333	i := i+1
334	eif e:i:ident="near" and i+1<e:size and done and (e:(i+1) cast Expression)
335	e suckup e:(i+1)
336	e add (instruction (the_function '. near' Expression Expression) expr e:(i+1):result)
337	i := i+2
338	eif e:i:ident="subexpressions" and done
339	if not done
340	e add (instruction (the_function new_expression -> Expression) expr)
341	done := true
342	e add (instruction (the_function '. size :=' Expression Int) expr (argument constant Int 0))
343	for (var Int j) i+1 e:size-1
344	if (e:j cast Expression)
345	e suckup e:j
346	e add(instruction (the_function '. add_subexpression' Expression Expression) expr e:j:result)
347	eif (e:j cast ExpressionRange)
348	e suckup e:j
349	e add(instruction (the_function '. add_subexpressions' Expression ExpressionRange) expr e:j:result)
350	else
351	return
352	i := e:size
353	eif e:i:ident="substitute" and i+2<e:size and e:(i+1):ident<>"" and (e:(i+2) cast Expression) and done
354	e suckup e:(i+2)
355	e add (instruction (the_function '. substitute' Expression Str Expression -> Expression) expr (argument constant Str e:(i+1):ident) e:(i+2):result expr)
356	i := i+3
357	eif e:i:ident="substitute" and i+2<e:size and e:(i+1):ident<>"" and (e:(i+2) cast ExpressionRange) and done
358	e suckup e:(i+2)
359	e add (instruction (the_function '. substitute' Expression Str ExpressionRange) expr (argument constant Str e:(i+1):ident) e:(i+2):result)
360	i := i+3
361	eif e:i:ident="insert" and i+2<e:size and e:(i+1):ident<>"" and (e:(i+2) cast Expression) and done
362	e suckup e:(i+2)
363	e add (instruction (the_function '. insert' Expression Str Expression) expr (argument constant Str e:(i+1):ident) e:(i+2):result)
364	i := i+3
365	eif e:i:ident="remove" and i+1<e:size and e:(i+1):ident<>"" and done
366	e add (instruction (the_function '. remove' Expression Str) expr (argument constant Str e:(i+1):ident))
367	i := i+2
368	else
369	return
370	if done
371	e set_result expr access_read+access_write
372
373
374	method e might_compile_as e2 -> success
375	arg_rw Expression e e2 ; arg CBool success
376	entry_lock addressof:e2
377	e2 near e
378	e2 compile_step3
379	if e2:is_compiled
380	if e:is_compiled
381	error error_id_compile "ambiguous expression at "+e:position
382	if e:instructions:first<>null
383	error error_id_corrupted "Expression instructions list is not empty"
384	e suckup e2
385	e set_result e2:result e2:access
386	success := true
387	else
388	success := false
389	entry_unlock addressof:e2
390
391	method e compile_as e2 -> success
392	arg_rw Expression e e2 ; arg CBool success
393	entry_lock addressof:e2
394	success := e might_compile_as e2
395	if not:success and e2:error_message="" # patch by pom in release 54
396	e2 compile
397	e suckup_error e2
398	entry_unlock addressof:e2
399
400
401	meta named_expression e
402	if e:size<>2 or not e:0:is_pure_ident
403	return
404	e compile_as (expression immediat (gvar Link:PackedExpression id :> expression immediat body) substitute id e:0 substitute body e:1)
405
406
407	method e add_nested_instructions open close
408	arg_rw Expression e ; arg_rw Instruction open close
409	var Link:Instruction escape :> null map Instruction
410	var Pointer:Arrow a :> e:instructions first
411	while a<>addressof:escape
412	var Pointer:Instruction instr :> a map Instruction
413	if (addressof instr:jump)=(cast -1 Address)
414	if addressof:escape=null
415	var Link:Instruction last :> instruction (the_function 'do nothing')
416	e add (instruction (the_function 'jump anyway') jump last)
417	escape :> duplicate close
418	e add escape
419	e add (instruction (the_function 'jump anyway') jump ((cast -1 Address) map Instruction))
420	e add last
421	instr jump :> escape
422	a :> e:instructions next a
423	open nested_with :> close
424	e:instructions insert_before e:instructions:first addressof:open
425	e add close
426
427
428	export duplicate
429	export '. ident :=' '. near'
430	export '. substitute' '. insert' '. remove' '. auto_rename'
431	export expression ''
432	export '. might_compile_as' '. compile_as'
433	export named_expression
434	export '. add_nested_instructions'
435
436
437	function track_expression template ident expr e -> ok
438	arg Expression template; arg Str ident; arg_rw Expression expr; arg_w Link:Expression e; arg CBool ok
439	if template:ident=ident
440	e :> expr
441	return true
442	else
443	check template:size=expr:size
444	for (var Int i) 0 template:size-1
445	if (track_expression template:i ident expr:i e)
446	return true
447	return false
448
449	export track_expression