← Back to branch summary

~ubuntu-branches/ubuntu/intrepid/ecl/intrepid

« back to all changes in this revision

Viewing changes to src/c/sequence.d

  • Committer: Bazaar Package Importer
  • Author(s): Peter Van Eynde
  • Date: 2006-05-17 02:46:26 UTC
  • Revision ID: james.westby@ubuntu.com-20060517024626-lljr08ftv9g9vefl
Tags: upstream-0.9h-20060510
Import upstream version 0.9h-20060510

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/c/sequence.d
 
1
/*
 
2
    sequence.d -- Sequence routines.
 
3
*/
 
4
/*
 
5
    Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
 
6
    Copyright (c) 1990, Giuseppe Attardi.
 
7
    Copyright (c) 2001, Juan Jose Garcia Ripoll.
 
8
 
 
9
    ECL is free software; you can redistribute it and/or
 
10
    modify it under the terms of the GNU Library General Public
 
11
    License as published by the Free Software Foundation; either
 
12
    version 2 of the License, or (at your option) any later version.
 
13
 
 
14
    See file '../Copyright' for full details.
 
15
*/
 
16
 
 
17
#include <ecl/ecl.h>
 
18
#include <limits.h>
 
19
#include <ecl/ecl-inl.h>
 
20
 
 
21
/*
 
22
        I know the following name is not good.
 
23
*/
 
24
cl_object
 
25
cl_alloc_simple_vector(cl_index l, cl_elttype aet)
 
26
{
 
27
        cl_object x;
 
28
 
 
29
        if (aet == aet_ch)
 
30
                return cl_alloc_simple_string(l);
 
31
        if (aet == aet_bit) {
 
32
                x = cl_alloc_object(t_bitvector);
 
33
                x->vector.hasfillp = FALSE;
 
34
                x->vector.adjustable = FALSE;
 
35
                x->vector.displaced = Cnil;
 
36
                x->vector.dim = x->vector.fillp = l;
 
37
                x->vector.offset = 0;
 
38
                x->vector.self.bit = NULL;
 
39
        } else {
 
40
                x = cl_alloc_object(t_vector);
 
41
                x->vector.hasfillp = FALSE;
 
42
                x->vector.adjustable = FALSE;
 
43
                x->vector.displaced = Cnil;
 
44
                x->vector.dim = x->vector.fillp = l;
 
45
                x->vector.self.t = NULL;
 
46
                x->vector.elttype = (short)aet;
 
47
        }
 
48
        array_allocself(x);
 
49
        return(x);
 
50
}
 
51
 
 
52
cl_object
 
53
cl_elt(cl_object x, cl_object i)
 
54
{
 
55
        @(return elt(x, fixint(i)))
 
56
}
 
57
 
 
58
cl_object
 
59
elt(cl_object seq, cl_fixnum index)
 
60
{
 
61
        cl_fixnum i;
 
62
        cl_object l;
 
63
 
 
64
        if (index < 0)
 
65
                goto E;
 
66
        switch (type_of(seq)) {
 
67
        case t_cons:
 
68
                for (i = index, l = seq;  i > 0;  --i)
 
69
                        if (endp(l))
 
70
                                goto E;
 
71
                        else
 
72
                                l = CDR(l);
 
73
                if (endp(l))
 
74
                        goto E;
 
75
                return(CAR(l));
 
76
 
 
77
        case t_vector:
 
78
        case t_bitvector:
 
79
                if (index >= seq->vector.fillp)
 
80
                        goto E;
 
81
                return(aref(seq, index));
 
82
 
 
83
        case t_string:
 
84
                if (index >= seq->string.fillp)
 
85
                        goto E;
 
86
                return(CODE_CHAR(seq->string.self[index]));
 
87
 
 
88
        case t_symbol:
 
89
                if (Null(seq))
 
90
                        break;
 
91
        default:
 
92
                FEwrong_type_argument(@'sequence', seq);
 
93
        }
 
94
E:
 
95
        FEtype_error_index(seq, MAKE_FIXNUM(index));
 
96
}
 
97
 
 
98
cl_object
 
99
si_elt_set(cl_object seq, cl_object index, cl_object val)
 
100
{
 
101
        @(return elt_set(seq, fixint(index), val))
 
102
}
 
103
 
 
104
cl_object
 
105
elt_set(cl_object seq, cl_fixnum index, cl_object val)
 
106
{
 
107
        cl_fixnum i;
 
108
        cl_object l;
 
109
 
 
110
        if (index < 0)
 
111
                goto E;
 
112
        switch (type_of(seq)) {
 
113
        case t_cons:
 
114
                for (i = index, l = seq;  i > 0;  --i)
 
115
                        if (endp(l))
 
116
                                goto E;
 
117
                        else
 
118
                                l = CDR(l);
 
119
                if (endp(l))
 
120
                        goto E;
 
121
                return(CAR(l) = val);
 
122
 
 
123
        case t_vector:
 
124
        case t_bitvector:
 
125
                if (index >= seq->vector.fillp)
 
126
                        goto E;
 
127
                return(aset(seq, index, val));
 
128
 
 
129
        case t_string:
 
130
                if (index >= seq->string.fillp)
 
131
                        goto E;
 
132
                /* INV: char_code() checks the type of `val' */
 
133
                seq->string.self[index] = char_code(val);
 
134
                return(val);
 
135
 
 
136
        default:
 
137
                FEwrong_type_argument(@'sequence', seq);
 
138
        }
 
139
E:
 
140
        FEtype_error_index(seq, MAKE_FIXNUM(index));
 
141
}
 
142
 
 
143
@(defun subseq (sequence start &optional end &aux x)
 
144
        cl_fixnum s, e;
 
145
        cl_fixnum i, j;
 
146
@
 
147
        s = fixnnint(start);
 
148
        if (Null(end))
 
149
                e = -1;
 
150
        else
 
151
                e = fixnnint(end);
 
152
        switch (type_of(sequence)) {
 
153
        case t_symbol:
 
154
                if (Null(sequence)) {
 
155
                        if (s > 0)
 
156
                                goto ILLEGAL_START_END;
 
157
                        if (e > 0)
 
158
                                goto ILLEGAL_START_END;
 
159
                        @(return Cnil)
 
160
                }
 
161
                FEwrong_type_argument(@'sequence', sequence);
 
162
 
 
163
        case t_cons:
 
164
                if (e >= 0)
 
165
                        if ((e -= s) < 0)
 
166
                                goto ILLEGAL_START_END;
 
167
                while (s-- > 0) {
 
168
                        if (ATOM(sequence))
 
169
                                goto ILLEGAL_START_END;
 
170
                        sequence = CDR(sequence);
 
171
                }
 
172
                if (e < 0)
 
173
                        return cl_copy_list(sequence);
 
174
                { cl_object *z = &x;
 
175
                  for (i = 0;  i < e;  i++) {
 
176
                    if (ATOM(sequence))
 
177
                      goto ILLEGAL_START_END;
 
178
                    z = &CDR(*z = CONS(CAR(sequence), Cnil));
 
179
                    sequence = CDR(sequence);
 
180
                  }
 
181
                }
 
182
                @(return x)
 
183
 
 
184
        case t_vector:
 
185
        case t_bitvector:
 
186
        case t_string:
 
187
                if (s > sequence->vector.fillp)
 
188
                        goto ILLEGAL_START_END;
 
189
                if (e < 0)
 
190
                        e = sequence->vector.fillp;
 
191
                else if (e < s || e > sequence->vector.fillp)
 
192
                        goto ILLEGAL_START_END;
 
193
                x = cl_alloc_simple_vector(e - s, array_elttype(sequence));
 
194
                ecl_copy_subarray(x, 0, sequence, s, e-s);
 
195
                @(return x)
 
196
 
 
197
        default:
 
198
                FEwrong_type_argument(@'sequence', sequence);
 
199
        }
 
200
 
 
201
ILLEGAL_START_END:
 
202
        FEerror("~S and ~S are illegal as :START and :END~%\
 
203
for the sequence ~S.", 3, start, end, sequence);
 
204
@)
 
205
 
 
206
cl_object
 
207
cl_copy_seq(cl_object x)
 
208
{
 
209
        return @subseq(2, x, MAKE_FIXNUM(0));
 
210
}
 
211
 
 
212
cl_object
 
213
cl_length(cl_object x)
 
214
{
 
215
        @(return MAKE_FIXNUM(length(x)))
 
216
}
 
217
 
 
218
cl_fixnum
 
219
length(cl_object x)
 
220
{
 
221
        cl_fixnum i;
 
222
 
 
223
        switch (type_of(x)) {
 
224
        case t_symbol:
 
225
                if (Null(x))
 
226
                        return(0);
 
227
                FEwrong_type_argument(@'sequence', x);
 
228
 
 
229
        case t_cons:
 
230
                /* INV: A list's length always fits in a fixnum */
 
231
                i = 0;
 
232
                loop_for_in(x) {
 
233
                        i++;
 
234
                } end_loop_for_in;
 
235
                return(i);
 
236
 
 
237
        case t_vector:
 
238
        case t_string:
 
239
        case t_bitvector:
 
240
                return(x->vector.fillp);
 
241
 
 
242
        default:
 
243
                FEwrong_type_argument(@'sequence', x);
 
244
        }
 
245
}
 
246
 
 
247
cl_object
 
248
cl_reverse(cl_object seq)
 
249
{
 
250
        cl_object output, x;
 
251
 
 
252
        switch (type_of(seq)) {
 
253
        case t_symbol:
 
254
                if (Null(seq))
 
255
                        output = Cnil;
 
256
                else
 
257
                        FEwrong_type_argument(@'sequence', seq);
 
258
                break;
 
259
        case t_cons: {
 
260
                for (x = seq, output = Cnil;  !endp(x);  x = CDR(x))
 
261
                        output = CONS(CAR(x), output);
 
262
                break;
 
263
        }
 
264
        case t_vector:
 
265
        case t_bitvector:
 
266
        case t_string:
 
267
                output = cl_alloc_simple_vector(seq->vector.fillp, array_elttype(seq));
 
268
                ecl_copy_subarray(output, 0, seq, 0, seq->vector.fillp);
 
269
                ecl_reverse_subarray(output, 0, seq->vector.fillp);
 
270
                break;
 
271
 
 
272
        default:
 
273
                FEwrong_type_argument(@'sequence', seq);
 
274
        }
 
275
        @(return output)
 
276
}
 
277
 
 
278
cl_object
 
279
cl_nreverse(cl_object seq)
 
280
{
 
281
        switch (type_of(seq)) {
 
282
        case t_symbol:
 
283
                if (!Null(seq))
 
284
                        FEwrong_type_argument(@'sequence', seq);
 
285
                break;
 
286
        case t_cons: {
 
287
                cl_object x, y, z;
 
288
                for (x = Cnil, y = seq;  !endp(CDR(y));) {
 
289
                        z = y;
 
290
                        y = CDR(y);
 
291
                        CDR(z) = x;
 
292
                        x = z;
 
293
                }
 
294
                CDR(y) = x;
 
295
                seq = y;
 
296
                break;
 
297
        }
 
298
        case t_vector:
 
299
        case t_string:
 
300
        case t_bitvector:
 
301
                ecl_reverse_subarray(seq, 0, seq->vector.fillp);
 
302
                break;
 
303
        default:
 
304
                FEwrong_type_argument(@'sequence', seq);
 
305
        }
 
306
        @(return seq)
 
307
}