/pliant/language/debug/error2.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	meta '?' e
21	if e:size<>1
22	return
23	e:0 compile
24	if error_notified
25	return
26	e suckup e:0
27	var Link:Argument a :> argument local CBool
28	e add (instruction (the_function error_notified -> CBool) a)
29	e add (instruction (the_function 'jump if' CBool) a jump ((cast -1 Address) map Instruction))
30	e set_result e:0:result e:0:access
31
32	operator '?' 518h 1000000000 0
33
34
35	function add src dest
36	arg Str src ; arg_rw Str dest
37	dest := dest+src
38
39	function clear dest
40	arg_w Str dest
41	dest := ""
42
43	meta comment e
44	if e:size<2
45	return
46	for (var Int i) 0 e:size-2
47	if not (e:i explicit_cast Str)
48	return
49	e:(e:size-1) compile ?
50	var Link:Argument msg
51	if e:size<>2
52	msg :> argument local Str
53	e add (instruction (the_function clear Str) msg)
54	for (var Int i) 0 e:size-2
55	e suckup e:i
56	e add (instruction (the_function add Str Str) e:i:result msg)
57	else
58	e suckup e:0
59	msg :> e:0 result
60	var Link:Argument r :> argument local ActionRecord
61	var Link:Instruction push :> (instruction (the_function action_push_record ActionRecord Str) r msg)
62	var Link:Instruction pull :> instruction (the_function action_pull_record ActionRecord) r
63	e suckup e:(e:size-1)
64	e add_nested_instructions push pull
65	e set_void_result
66
67
68	meta shy e
69	if e:size<>1
70	return
71	e:0 compile ?
72	var Link:Argument a :> argument local CBool
73	var Pointer:Instruction end :> instruction (the_function 'do nothing')
74	e add (instruction (the_function error_notified -> CBool) a)
75	e add (instruction (the_function 'jump if' CBool) a jump end)
76	e suckup e:0
77	var List nesteds
78	var Pointer:Arrow c :> e:instructions first
79	while c<>null
80	check entry_type:c=Instruction
81	var Pointer:Instruction i :> c map Instruction
82	var Pointer:Function f :> i function
83	if (f:flags .and. function_flag_may_generate_error)<>0
84	c :> e:instructions insert_after c addressof:(instruction (the_function error_notified -> CBool) a)
85	if nesteds:first=null
86	c :> e:instructions insert_after c addressof:(instruction (the_function 'jump if' CBool) a jump end)
87	else
88	var Pointer:Instruction continue :> instruction (the_function 'do nothing')
89	c :> e:instructions insert_after c addressof:(instruction (the_function 'jump if not' CBool) a jump continue)
90	var Pointer:Arrow c2 :> nesteds first
91	while c2<>null
92	var Pointer:Instruction i2 :> c2 map Instruction
93	c :> e:instructions insert_after c (addressof duplicate:i2)
94	c2 :> nesteds next c2
95	c :> e:instructions insert_after c addressof:continue
96	if (addressof i:nested_with)<>null
97	nesteds append (addressof i:nested_with)
98	var Pointer:Arrow c2 :> nesteds first
99	while c2<>null
100	if c=c2
101	c2 :> nesteds remove c2
102	else
103	c2 :> nesteds next c2
104	c :> e:instructions next c
105	e add end
106	e set_result e:0:result e:0:access
107
108
109	function error_clear_and_pull r
110	arg_rw ErrorRecord r
111	r id := error_id_noerror
112	error_pull_record r
113
114	function pick_error_message r -> m
115	arg ErrorRecord r ; arg_R Str m
116	m :> r message
117
118	meta safe e
119	var Pointer:Arrow c :> pliant_general_dictionary first "pliant function"
120	if c=null or entry_type:c<>Function
121	return
122	var Link:Function current_function :> c map Function
123	if e:size<1
124	return
125	e:0 compile ?
126	e suckup e:0
127	var Link:Argument r :> argument local ErrorRecord
128	var Int i := 1
129	while i<e:size
130	if not e:i:is_pure_ident or i+1>=e:size
131	return
132	var Str id := e:i:ident
133	if i=1
134	var Link:Argument cond :> argument local CBool
135	e add (instruction (the_function error_notified -> CBool) cond)
136	var Link:Expression body
137	var Link:Argument msg :> null map Argument
138	if id="failure" and i+2<e:size and e:(i+1):is_pure_ident
139	msg :> argument indirect Str (argument local Address) 0
140	var Link:LocalVariable lv :> new LocalVariable
141	lv name := e:(i+1):ident
142	lv body :> msg
143	lv access := access_read
144	lv function :> current_function
145	e define lv:name addressof:lv e:module
146	body :> e i+2 ; i := i+3
147	eif id="failure"
148	body :> e i+1 ; i := i+2
149	eif id="success"
150	body :> e i+1 ; i := i+2
151	else
152	return
153	body compile ?
154	var Link:Instruction end :> instruction (the_function 'do nothing')
155	if id="success"
156	e add (instruction (the_function 'jump if' CBool) cond jump end)
157	e suckup body
158	else
159	e add (instruction (the_function 'jump if not' CBool) cond jump end)
160	if addressof:msg<>null
161	e add (instruction (the_function pick_error_message ErrorRecord -> Str) r msg)
162	var Link:Expression e2 :> new Expression
163	e2 suckup body
164	var Link:Argument r2 :> argument local ErrorRecord
165	var Link:Instruction open2 :> instruction (the_function error_push_record ErrorRecord ErrorID) r2 (argument constant ErrorID error_filter_none)
166	var Link:Instruction close2 :> instruction (the_function error_pull_record ErrorRecord) r2
167	e2 add_nested_instructions open2 close2
168	e suckup e2
169	e add end
170	var Link:Instruction open :> instruction (the_function error_push_record ErrorRecord ErrorID) r (argument constant ErrorID error_filter_all)
171	var Link:Instruction close :> instruction (the_function error_clear_and_pull ErrorRecord) r
172	e add_nested_instructions open close
173	e set_void_result
174
175	dual_keyword safe 1 3 success 1 1
176	dual_keyword safe 1 3 failure 1 2
177
178
179	export '?' comment shy safe