/pliant/protocol/http/stack.pli
1	module "/pliant/language/compiler.pli"
2
3	constant default_buffer_size 1024
4
5
6	type TagBuffer
7	field ListNode_ node
8	field Address cursor stop
9
10	type TagTransition
11	field Int kind # 0 = mark, 1 = assignment
12	field Pointer:TagTransition previous
13	field Address a0 a1 a2 a3
14
15	type TagExtra
16	field Str id
17	field Str value
18	field Pointer:TagExtra next # must be the last field
19
20	type TagStack
21	field Array:Address map
22	field Pointer:TagTransition last_record
23	field Pointer:TagBuffer buffer
24	field List_ buffers
25	field Pointer:TagExtra first_extra
26	field (Pointer Pointer:TagExtra) last_extra
27
28
29	gvar Array:Arrow attr_default
30	gvar Sem sem
31
32	gvar TagBuffer no_buffer
33	memory_clear addressof:no_buffer TagBuffer:size
34
35
36	function tag_stack_slot type default -> index
37	arg Type type ; arg Address default ; arg Int index
38	sem request
39	index := attr_default size
40	var Arrow d := entry_new type
41	if default<>null
42	type copy_instance default d
43	attr_default += d
44	sem release
45
46
47	function build e
48	arg_w TagStack e
49	e buffer :> no_buffer
50	e last_record :> null map TagTransition
51	e first_extra :> null map TagExtra
52	e last_extra :>> e first_extra
53
54	function destroy e
55	arg_w TagStack e
56	if (exists e:last_record)
57	error error_id_mismatch "missing TagStack rewind instruction"
58	var Pointer:ListNode_ n :> e:buffers first
59	while exists:n
60	var Pointer:ListNode_ nn :> n next
61	memory_free addressof:n
62	n :> nn
63
64	method e initialize
65	arg_rw TagStack e
66	var Int old_size := e:map size
67	sem rd_request
68	e:map size := attr_default size
69	for (var Int i) old_size e:map:size-1
70	e:map i := attr_default i
71	sem rd_release
72
73
74	method e allocate size -> adr
75	arg_rw TagStack e ; arg Int size ; arg Address adr
76	var Pointer:TagBuffer b :> e buffer
77	part try
78	if (cast b:stop Int).-.(cast b:cursor Int)<size
79	b :> (addressof b:node:next) map TagBuffer
80	if exists:b
81	b cursor := addressof:b translate TagBuffer 1
82	e buffer :> b
83	restart try
84	var Int bsize := max default_buffer_size size
85	b :> (memory_allocate TagBuffer:size+bsize addressof:e) map TagBuffer
86	b cursor := addressof:b translate TagBuffer 1
87	b stop := b:cursor translate Byte bsize
88	e:buffers append b:node
89	e buffer :> b
90	adr := b cursor
91	b cursor := b:cursor translate Byte size
92
93
94	method e map index -> adr
95	arg TagStack e ; arg Int index ; arg Address adr
96	adr := e:map index
97
98
99	method e mark
100	arg_rw TagStack e
101	var Pointer:TagTransition t :> (e allocate TagTransition:size) map TagTransition
102	t kind := 0
103	t previous :> e last_record
104	t a0 := addressof e:buffer
105	t a1 := e:buffer cursor
106	t a2 := addressof e:first_extra
107	t a3 := addressof Pointer:TagExtra e:last_extra
108	e last_record :> t
109	e first_extra :> null map TagExtra
110	e last_extra :>> e first_extra
111
112	method e rewind
113	arg_rw TagStack e
114	var Pointer:TagTransition t :> e last_record
115	while t:kind=1
116	(t:a1 map Type) destroy_instance e:map:(cast t:a0 Int)
117	e:map (cast t:a0 Int) := t a2
118	t :> t previous
119	e buffer :> t:a0 map TagBuffer
120	e:buffer cursor := t a1
121	e first_extra :> t:a2 map TagExtra
122	e last_extra :>> t:a3 map Pointer:TagExtra
123	e last_record :> t previous
124
125
126	method e push index value type
127	arg_rw TagStack e ; arg Int index ; arg Address value ; arg Type type
128	check (entry_type attr_default:index)=type
129	var Pointer:TagTransition t :> (e allocate TagTransition:size) map TagTransition
130	t kind := 1
131	t previous :> e last_record
132	t a0 := cast index Address
133	t a1 := addressof type
134	t a2 := e:map index
135	e last_record :> t
136	var Address a := e allocate type:size
137	type build_instance a
138	type copy_instance value a
139	e:map index := a
140
141
142	method e set id value
143	arg_rw TagStack e ; arg Str id value
144	var Pointer:TagExtra ex :> (e allocate TagExtra:size+id:len+value:len) map TagExtra
145	TagExtra build_instance addressof:ex
146	ex:id set (addressof:ex translate TagExtra 1) id:len false
147	memory_copy id:characters ex:id:characters id:len
148	ex:value set (ex:id:characters translate Char id:len) value:len false
149	memory_copy value:characters ex:value:characters value:len
150	ex next :> null map TagExtra
151	e last_extra :> ex
152	e last_extra :>> ex next
153
154
155	method e walk id value
156	arg TagStack e ; arg_w Str id value
157	id set ((addressof Pointer:TagExtra e:first_extra) translate Pointer:TagExtra 1) 0 false
158
159	method e another id value -> available
160	arg TagStack e ; arg_w Str id ; arg_rw Str value ; arg CBool available
161	var Pointer:TagExtra ex :> id:characters map TagExtra -1
162	ex :> ex next
163	if exists:ex
164	id set ex:id:characters ex:id:len false
165	value set ex:value:characters ex:value:len false
166	available := true
167	else
168	id := ""
169	value := ""
170	available := false
171
172
173	export tag_stack_slot
174	export TagStack '. initialize' '. mark' '. rewind'
175	export '. map' '. push'
176	export '. set' '. walk' '. another'
177
178
179
180
181
182
183
184
185