/pliant/language/basic/part.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	type PartProperty
20	field Str label
21	field CBool restart
22
23
24	meta part e
25	if e:size<2 or e:size>3 or e:0:ident=""
26	return
27	if e:size=3 and not (e:1 cast Str)
28	return
29	var Str label := e:0:ident
30	var Link:Expression body :> e e:size-1
31	if body:ident<>"{}"
32	return
33	if e:size=3
34	var Link:Argument ar :> argument local ActionRecord
35	e suckup e:1
36	e add (instruction (the_function mt_action_push_record ActionRecord Str) ar e:1:result)
37	var Link:Instruction begin :> instruction (the_function 'do nothing')
38	e add begin
39	var Link:Void v :> new Void
40	e:module define "pliant part "+label addressof:v
41	body compile
42	e:module undefine "pliant part "+label addressof:v
43	e suckup body
44	var Link:Instruction end :> instruction (the_function 'do nothing')
45	e add end
46	if e:size=3
47	e add (instruction (the_function mt_action_pull_record ActionRecord) ar)
48	var Pointer:Arrow c :> e:instructions first
49	while c<>null
50	var Pointer:Instruction i :> c map Instruction
51	if (addressof i:jump)=(cast -1 Address)
52	var Pointer:PartProperty p :> (i:properties first "pliant part") map PartProperty
53	if addressof:p<>null and (entry_type addressof:p)=PartProperty and p:label=label
54	if p:restart
55	i jump :> begin
56	else
57	i jump :> end
58	c :> e:instructions next c
59	e set_void_result
60
61
62	function leave_restart e restart
63	arg_rw Expression e ; arg CBool restart
64	if e:size<>1 or e:0:ident=""
65	return
66	var Pointer:Arrow c :> e:module first "pliant part "+e:0:ident
67	if c=null
68	return
69	var Link:Instruction jump :> instruction (the_function 'jump anyway')
70	jump jump :> (cast -1 Address) map Instruction
71	var Link:PartProperty p :> new PartProperty
72	p label := e:0 ident
73	p restart := restart
74	jump:properties insert "pliant part" true addressof:p
75	e add jump
76	e set_void_result
77
78	meta leave e
79	leave_restart e false
80
81	meta restart e
82	leave_restart e true
83
84
85	export part leave restart