/pliant/language/type/text/str32.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	abstract
17	[UTF-32 ] ; link "Unicode" "http://www.unicode.org/" ; [ strings]
18
19	# scope "/pliant/language/" "/pliant/install/"
20	module "/pliant/install/ring2.pli"
21	ring_module
22
23	constant undefined_character "?"
24
25
26	type Char32
27	field Int32 num
28
29	function character32 i -> c
30	arg Int i ; arg Char32 c
31	c num := i
32
33	method c number -> i
34	arg Char32 c ; arg Int i
35	i := c num
36
37
38	type Str32
39	field Address characters
40	field Int count
41
42
43	method s set buf len allocated
44	arg_w Str32 s ; arg Address buf ; arg Int len ; arg CBool allocated
45	if s:count>0
46	memory_free s:characters
47	s characters := buf
48	s count := shunt allocated len -len
49
50	method s len -> l
51	arg Str32 s ; arg Int l
52	l := abs s:count
53
54	method s '' i -> c
55	arg Str32 s ; arg Int i ; arg_C Char32 c
56	check i>=0 and i<s:len
57	c :> s:characters map Char32 i
58	# ((the_function '' Str32 Int -> Char32) arg 2) maps := 1
59
60	method s '' i j -> sub
61	arg Str32 s ; arg Int i j ; arg Str32 sub
62	check i>=0 and j>=0
63	var Int l := max (min j s:len-i) 0
64	sub set (s:characters translate Char32 i) l false
65	((the_function '' Str32 Int Int -> Str32) arg 3) maps := 1
66
67
68	function build s
69	arg_w Str32 s
70	s characters := null
71	s count := 0
72
73	function destroy s
74	arg_w Str32 s
75	if s:count>0
76	memory_free s:characters
77
78	function copy s d
79	arg Str32 s ; arg_w Str32 d
80	var Int l := s len
81	var Address c := memory_allocate l*Char32:size addressof:d
82	memory_copy s:characters c l*Char32:size
83	d set c l true
84
85
86	function '+' s1 s2 -> s
87	arg Str32 s1 s2 s
88	var Int l := s1:len+s2:len
89	s set (memory_allocate l*Char32:size addressof:s) l true
90	memory_copy s1:characters s:characters s1:len*Char32:size
91	memory_copy s2:characters (s:characters translate Char32 s1:len) s2:len*Char32:size
92
93
94	function compare s1 s2 -> c
95	arg Str32 s1 s2 ; arg Int c
96	var Int l := min s1:len s2:len
97	var Address p1 := s1 characters ; var Address stop := p1 translate Int32 l
98	var Address p2 := s2 characters
99	while p1<>stop
100	if (p1 map Int32)<>(p2 map Int32)
101	return (compare (p1 map Int32) (p2 map Int32))
102	p1 := p1 translate Int32 1 ; p2 := p2 translate Int32 1
103	if s1:len>s2:len
104	c := compare_superior
105	eif s1:len<s2:len
106	c := compare_inferior
107	else
108	c := compare_equal
109
110
111	export Char32
112	export character32 '. number'
113	export Str32 '. set'
114	export '. characters' '. len' ''
115	export compare '+'
116
117
118	function 'cast Str32' c -> s
119	arg Char32 c ; arg Str32 s
120	extension
121	s set (memory_allocate Char32:size addressof:s) 1 true
122	s:characters map Char32 := c
123
124
125	function 'cast Str32' s -> s32
126	arg Str s ; arg Str32 s32
127	extension
128	if default_charset_is_utf8
129	module "/pliant/util/encoding/utf8.pli"
130	s32 := utf8_decode s
131	else
132	var Int l := s len
133	s32 set (memory_allocate l*Char32:size addressof:s32) l true
134	var Address src := s characters ; var Address stop := src translate uInt8 l
135	var Address dest := s32 characters
136	while src<>stop
137	dest map Int32 := src map uInt8
138	src := src translate uInt8 1 ; dest := dest translate Int32 1
139
140
141	function 'cast Str' s32 -> s
142	arg Str32 s32 ; arg Str s
143	reduction
144	if default_charset_is_utf8
145	module "/pliant/util/encoding/utf8.pli"
146	s := utf8_encode s32
147	else
148	var Int l := s32 len
149	s set (memory_allocate l addressof:s) l true
150	var Address src := s32 characters
151	var Address dest := s characters ; var Address stop := dest translate uInt8 l
152	while dest<>stop
153	var Int c := src map Int32
154	if c>=100h
155	c := undefined_character number
156	dest map uInt8 := c
157	src := src translate Int32 1 ; dest := dest translate uInt8 1
158
159
160	method s search pattern default -> index
161	arg Str32 s pattern ; arg Int default index
162	if true
163	var Int ls := s len ; var Int lp := pattern len
164	check lp<>0
165	if ls>=lp
166	var Address cur := s characters
167	var Address stop := cur translate Char32 ls-lp+1
168	var Address wished := pattern characters ; var Int size := lp*Char32:size
169	var Int ch := wished map Int32
170	while cur<>stop
171	if (cur map Int32)=ch
172	if not (memory_different cur size wished size)
173	return ((cast cur Int) .-. (cast s:characters Int))\Char32:size
174	cur := cur translate Char32
175	index := default
176	else
177	check pattern:len>0
178	for index 0 s:len-pattern:len
179	if (s index pattern:len)=pattern
180	return
181	index := default
182
183
184	export 'cast Str32' 'cast Str' '. search'