/pliant/language/type/misc/tag.pli
1	scope "/pliant/language/" "/pliant/install/"
2	module "/pliant/install/ring1.pli"
3
4	constant use_properties false
5
6	type TagMarker
7	void
8
9	function active_type tp access e
10	arg TagMarker tp ; arg Int access ; arg_rw Expression e
11	e set_void_result
12
13	export TagMarker
14
15	method t 'get position' -> pos
16	oarg Universal t; arg ListingPosition pos
17	generic
18	pos:=new ListingPosition
19	export '. get position'
20
21	gvar Int 'pliant generate listing tags' := 1
22	gvar Relation 'pliant tag watch'
23
24	function 'pliant watch' t is_active -> data
25	arg Type t; arg CBool is_active; arg_RW Str data
26	has_no_side_effect
27	if is_active
28	var Address adr := 'pliant tag watch' query addressof:t null
29	if adr=null
30	'pliant tag watch' define addressof:t null (addressof new:Str)
31	adr := 'pliant tag watch' query addressof:t null
32	else
33	var Address adr := 'pliant tag watch' query null addressof:t
34	if adr=null
35	'pliant tag watch' define null addressof:t (addressof new:Str)
36	adr := 'pliant tag watch' query null addressof:t
37	return (adr map Str)
38
39	method t 'pliant is_watched' is_active -> data
40	arg Type t; arg CBool is_active; arg_RW Str data
41	has_no_side_effect
42	if is_active
43	var Address adr := 'pliant tag watch' query addressof:t null
44	else
45	var Address adr := 'pliant tag watch' query null addressof:t
46	return (adr map Str)
47
48	export 'pliant watch' '. pliant is_watched'
49
50	'pliant watch' Meta true
51	'pliant watch' Function true
52	'pliant watch' LocalVariable true
53	'pliant watch' GlobalVariable true
54	'pliant watch' TagMarker true
55	'pliant watch' InlineText false
56	'pliant watch' Type false
57
58	export 'pliant generate listing tags'
59
60	type ListingTag
61	field Int line
62	field Int column
63	field Arrow value
64
65	export ListingTag '. line' '. column' '. value'
66
67
68	type ListingTags
69	field Address ptr
70	field Int size
71
72	function build lt
73	arg_w ListingTags lt
74	lt ptr := null
75	lt size := 0
76
77	method lt add t
78	arg_rw ListingTags lt ; arg ListingTag t
79	var Int tsize := Int size
80	var Int code := t:line*2^17+t:column*2
81	if t:value<>null
82	code := code+1
83	if ('.and.' code 1)<>0
84	tsize := tsize+Arrow:size
85	lt ptr := memory_resize lt:ptr lt:size+tsize addressof:lt
86	var Address a := lt:ptr translate Byte lt:size
87	a map Int := code
88	if ('.and.' code 1)<>0
89	entry_lock t:value
90	(a translate Int 1) map Address := t value
91	lt size := lt:size+tsize
92
93	method lt first -> a
94	arg ListingTags lt ; arg Address a
95	a := lt ptr
96
97	method lt next a -> aa
98	arg ListingTags lt ; arg Address a aa
99	var Int code := a map Int
100	if ('.and.' code 1)<>0
101	aa := (a translate Int 1) translate Arrow 1
102	else
103	aa := a translate Int 1
104	if aa=(lt:ptr translate Byte lt:size)
105	aa := null
106
107	function destroy lt
108	arg_w ListingTags lt
109	if true # FIXME: this is the part of the code disturbing the memory unload at the end of debugging level 2 precompiling
110	var Address cur := lt first
111	while cur<>null
112	var Int code := cur map Int
113	if ('.and.' code 1)<>0
114	entry_unlock ((cur translate Int 1) map Address)
115	cur := lt next cur
116	memory_free lt:ptr
117
118	function copy src dest
119	arg ListingTags src; arg_w ListingTags dest
120	ListingTags destroy_instance addressof:dest
121	dest ptr := memory_allocate src:size addressof:dest
122	dest size := src size
123	memory_copy src:ptr dest:ptr src:size
124	var Address cur := src first
125	while cur<>null
126	var Pointer:Int pc :> cur map Int
127	if ('.and.' pc 1)<>0
128	entry_lock ((cur translate Int 1) map Address)
129	cur := src next cur
130
131	method lt get cur -> t
132	arg ListingTags lt; arg Address cur; arg ListingTag t
133	var Pointer:Int pc :> cur map Int
134	t column := '.and.' (pc \ 2) (2^16-1)
135	t line := pc \ (2^17)
136	if ('.and.' pc 1)<>0
137	t value := (cur translate Int 1) map Arrow
138	else
139	t value := null
140
141	export ListingTags '. add' '. first' '. next' '. get'
142
143
144	function active_record object access e
145	arg Universal object; arg Int access; arg_rw Expression e
146	if 'pliant generate listing tags'<>0 and (e:properties first "active")=null
147	var Link:Type t :> entry_type addressof:object
148	if addressof:(t 'pliant is_watched' true)<>null
149	e:properties insert "active" true addressof:object
150
151	entry_root addressof:(the_function active_record Universal Int Expression)
152
153
154	method e recursive_uncompile
155	arg_rw Expression e
156	for (var Int i) 0 e:size-1
157	e:i recursive_uncompile
158	e uncompile
159
160	function parser_tag_record2 e lt
161	arg_rw Expression e; arg_rw ListingTags lt
162	var ListingTag t
163	t line := e:position:line
164	t column := e:position:column
165	t value := null
166	var Pointer:Arrow r :> e:properties first "active"
167	if r<>null
168	if entry_type:(e value)<>Ident or (e:ident<>"{}" and e:ident<>"()")
169	t value := r
170	lt add t
171	else
172	if ('.and.' e:access access_constant)<>0 and e:size=0 and e:result:type<>Void
173	if addressof:(e:result:type 'pliant is_watched' false)<>null or 'pliant generate listing tags'=2
174	t value := e:result:constant
175	eif entry_type:(e value)<>Ident
176	if addressof:(entry_type:(e value) 'pliant is_watched' false)<>null
177	t value := e value
178	lt add t
179	for (var Int i) 0 e:size-1
180	parser_tag_record2 e:i lt
181
182	function parser_tag_record e
183	arg_rw Expression e
184	e recursive_uncompile
185	e compile
186	var Link:Module module :> e module
187	if addressof:(module:external)<>null
188	module :> module external
189	if use_properties
190	var Pointer:Arrow r :> module:properties first "pliant tags list"
191	else
192	var Pointer:Arrow r :> module first "pliant tags list "+module:name
193	if r=null
194	var Link:ListingTags lt :> new ListingTags
195	if use_properties
196	module:properties insert "pliant tags list" true addressof:lt
197	else
198	module define "pliant tags list "+module:name addressof:lt
199	else
200	lt :> r map ListingTags
201	parser_tag_record2 e lt
202	entry_root addressof:(the_function parser_tag_record Expression)
203
204
205	function activate_tag_hooks
206	pliant_compiler_post_active_hook := (the_function active_record Universal Int Expression) executable
207	pliant_parser_pre_execute_hook := (the_function parser_tag_record Expression) executable
208
209	if pliant_debugging_level>=1
210	activate_tag_hooks
211