~ubuntu-branches/ubuntu/utopic/xen/utopic

« back to all changes in this revision

Viewing changes to tools/vnet/libxutil/sxpr.c

  • Committer: Bazaar Package Importer
  • Author(s): Bastian Blank
  • Date: 2010-05-06 15:47:38 UTC
  • mto: (1.3.1) (15.1.1 sid) (4.1.1 experimental)
  • mto: This revision was merged to the branch mainline in revision 3.
  • Revision ID: james.westby@ubuntu.com-20100506154738-agoz0rlafrh1fnq7
Tags: upstream-4.0.0
ImportĀ upstreamĀ versionĀ 4.0.0

Show diffs side-by-side

added added

removed removed

Lines of Context:
 
1
/*
 
2
 * Copyright (C) 2001 - 2004 Mike Wray <mike.wray@hp.com>
 
3
 *
 
4
 * This library is free software; you can redistribute it and/or modify
 
5
 * it under the terms of the GNU Lesser General Public License as
 
6
 * published by the Free Software Foundation; either version 2.1 of the
 
7
 * License, or  (at your option) any later version. This library is 
 
8
 * distributed in the  hope that it will be useful, but WITHOUT ANY
 
9
 * WARRANTY; without even the implied warranty of MERCHANTABILITY or
 
10
 * FITNESS FOR A PARTICULAR PURPOSE.
 
11
 * See the GNU Lesser General Public License for more details.
 
12
 *
 
13
 * You should have received a copy of the GNU Lesser General Public License
 
14
 * along with this library; if not, write to the Free Software Foundation,
 
15
 * Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307 USA
 
16
 */
 
17
 
 
18
#include <stdarg.h>
 
19
#include "sys_string.h"
 
20
#include "lexis.h"
 
21
#include "sys_net.h"
 
22
#include "hash_table.h"
 
23
#include "sxpr.h"
 
24
 
 
25
#ifdef __KERNEL__
 
26
#include <linux/errno.h>
 
27
#else
 
28
#include <errno.h>
 
29
#endif
 
30
 
 
31
#ifdef __KERNEL__
 
32
#include <linux/random.h>
 
33
 
 
34
int rand(void){
 
35
    int v;
 
36
    get_random_bytes(&v, sizeof(v));
 
37
    return v;
 
38
}
 
39
 
 
40
#else
 
41
#include <stdlib.h>
 
42
#endif
 
43
 
 
44
#undef free
 
45
 
 
46
/** @file
 
47
 * General representation of sxprs.
 
48
 * Includes print, equal, and free functions for the sxpr types.
 
49
 *
 
50
 * Zero memory containing an Sxpr will have the value ONONE - this is intentional.
 
51
 * When a function returning an sxpr cannot allocate memory we return ONOMEM.
 
52
 *
 
53
 */
 
54
 
 
55
static int atom_print(IOStream *io, Sxpr obj, unsigned flags);
 
56
static int atom_equal(Sxpr x, Sxpr y);
 
57
static void atom_free(Sxpr obj);
 
58
static Sxpr atom_copy(Sxpr obj);
 
59
 
 
60
static int string_print(IOStream *io, Sxpr obj, unsigned flags);
 
61
static int string_equal(Sxpr x, Sxpr y);
 
62
static void string_free(Sxpr obj);
 
63
static Sxpr string_copy(Sxpr obj);
 
64
 
 
65
static int cons_print(IOStream *io, Sxpr obj, unsigned flags);
 
66
static int cons_equal(Sxpr x, Sxpr y);
 
67
static void cons_free(Sxpr obj);
 
68
static Sxpr cons_copy(Sxpr obj);
 
69
 
 
70
static int null_print(IOStream *io, Sxpr obj, unsigned flags);
 
71
static int none_print(IOStream *io, Sxpr obj, unsigned flags);
 
72
static int int_print(IOStream *io, Sxpr obj, unsigned flags);
 
73
static int bool_print(IOStream *io, Sxpr obj, unsigned flags);
 
74
static int err_print(IOStream *io, Sxpr obj, unsigned flags);
 
75
static int nomem_print(IOStream *io, Sxpr obj, unsigned flags);
 
76
 
 
77
/** Type definitions. */
 
78
static SxprType types[1024] = {
 
79
    [T_NONE]     { .type=    T_NONE,     .name= "none",       .print= none_print      },
 
80
    [T_NULL]     { .type=    T_NULL,     .name= "null",       .print= null_print      },
 
81
    [T_UINT]     { .type=    T_UINT,     .name= "int",        .print= int_print,      },
 
82
    [T_BOOL]     { .type=    T_BOOL,     .name= "bool",       .print= bool_print,     },
 
83
    [T_ERR]      { .type=    T_ERR,      .name= "err",        .print= err_print,      },
 
84
    [T_NOMEM]    { .type=    T_ERR,      .name= "nomem",      .print= nomem_print,    },
 
85
    [T_ATOM]     { .type=    T_ATOM,     .name= "atom",       .print= atom_print,
 
86
                   .pointer= TRUE,
 
87
                   .free=    atom_free,
 
88
                   .equal=   atom_equal,
 
89
                   .copy=    atom_copy,
 
90
                 },
 
91
    [T_STRING]   { .type=    T_STRING,   .name= "string",     .print= string_print,
 
92
                   .pointer= TRUE,
 
93
                   .free=    string_free,
 
94
                   .equal=   string_equal,
 
95
                   .copy=    string_copy,
 
96
                 },
 
97
    [T_CONS]     { .type=    T_CONS,     .name= "cons",       .print= cons_print,
 
98
                   .pointer= TRUE,
 
99
                   .free=    cons_free,
 
100
                   .equal=   cons_equal,
 
101
                   .copy=    cons_copy,
 
102
                 },
 
103
};
 
104
 
 
105
/** Number of entries in the types array. */
 
106
static int type_sup = sizeof(types)/sizeof(types[0]);
 
107
 
 
108
/** Define a type.
 
109
 * The tydef must have a non-zero type code.
 
110
 * It is an error if the type code is out of range or already defined.
 
111
 *
 
112
 * @param tydef type definition
 
113
 * @return 0 on success, error code otherwise
 
114
 */
 
115
int def_sxpr_type(SxprType *tydef){
 
116
    int err = 0;
 
117
    int ty = tydef->type;
 
118
    if(ty < 0 || ty >= type_sup){
 
119
        err = -EINVAL;
 
120
        goto exit;
 
121
    }
 
122
    if(types[ty].type){
 
123
        err = -EEXIST;
 
124
        goto exit;
 
125
    }
 
126
    types[ty] = *tydef;
 
127
  exit:
 
128
    return err;
 
129
    
 
130
}
 
131
 
 
132
/** Get the type definition for a given type code.
 
133
 *
 
134
 * @param ty type code
 
135
 * @return type definition or null
 
136
 */
 
137
SxprType *get_sxpr_type(int ty){
 
138
    if(0 <= ty && ty < type_sup){
 
139
        return types+ty;
 
140
    }
 
141
    return NULL;
 
142
}
 
143
 
 
144
/** The default print function.
 
145
 *
 
146
 * @param io stream to print to
 
147
 * @param x sxpr to print
 
148
 * @param flags print flags
 
149
 * @return number of bytes written on success
 
150
 */
 
151
int default_print(IOStream *io, Sxpr x, unsigned flags){
 
152
    return IOStream_print(io, "#<%u %lu>\n", get_type(x), get_ul(x));
 
153
}
 
154
 
 
155
/** The default equal function.
 
156
 * Uses eq().
 
157
 *
 
158
 * @param x sxpr to compare
 
159
 * @param y sxpr to compare
 
160
 * @return 1 if equal, 0 otherwise
 
161
 */
 
162
int default_equal(Sxpr x, Sxpr y){
 
163
    return eq(x, y);
 
164
}
 
165
 
 
166
/** General sxpr print function.
 
167
 * Prints an sxpr on a stream using the print function for the sxpr type.
 
168
 * Printing is controlled by flags from the PrintFlags enum.
 
169
 * If PRINT_TYPE is in the flags the sxpr type is printed before the sxpr
 
170
 * (for debugging).
 
171
 *
 
172
 * @param io stream to print to
 
173
 * @param x sxpr to print
 
174
 * @param flags print flags
 
175
 * @return number of bytes written
 
176
 */
 
177
int objprint(IOStream *io, Sxpr x, unsigned flags){
 
178
    SxprType *def = get_sxpr_type(get_type(x));
 
179
    ObjPrintFn *print_fn = (def && def->print ? def->print : default_print);
 
180
    int k = 0;
 
181
    if(!io) return k;
 
182
    if(flags & PRINT_TYPE){
 
183
        k += IOStream_print(io, "%s:", def->name);
 
184
    }
 
185
    if(def->pointer && (flags & PRINT_ADDR)){
 
186
        k += IOStream_print(io, "<%p>", get_ptr(x));
 
187
    }
 
188
    k += print_fn(io, x, flags);
 
189
    return k;
 
190
}
 
191
 
 
192
Sxpr objcopy(Sxpr x){
 
193
    SxprType *def = get_sxpr_type(get_type(x));
 
194
    ObjCopyFn *copy_fn = (def ? def->copy : NULL);
 
195
    Sxpr v;
 
196
    if(copy_fn){
 
197
        v = copy_fn(x);
 
198
    } else if(def->pointer){
 
199
        v = ONOMEM;
 
200
    } else {
 
201
        v = x;
 
202
    }
 
203
    return v;
 
204
}
 
205
 
 
206
/** General sxpr free function.
 
207
 * Frees an sxpr using the free function for its type.
 
208
 * Free functions must recursively free any subsxprs.
 
209
 * If no function is defined then the default is to
 
210
 * free sxprs whose type has pointer true.
 
211
 * Sxprs must not be used after freeing.
 
212
 *
 
213
 * @param x sxpr to free
 
214
 */
 
215
void objfree(Sxpr x){
 
216
    SxprType *def = get_sxpr_type(get_type(x));
 
217
 
 
218
    if(def){
 
219
        if(def->free){
 
220
            def->free(x);
 
221
        } else if (def->pointer){
 
222
            hfree(x);
 
223
        }
 
224
    }
 
225
}
 
226
 
 
227
/** General sxpr equality function.
 
228
 * Compares x and y using the equal function for x.
 
229
 * Uses default_equal() if x has no equal function.
 
230
 *
 
231
 * @param x sxpr to compare
 
232
 * @param y sxpr to compare
 
233
 * @return 1 if equal, 0 otherwise
 
234
 */
 
235
int objequal(Sxpr x, Sxpr y){
 
236
    SxprType *def = get_sxpr_type(get_type(x));
 
237
    ObjEqualFn *equal_fn = (def && def->equal ? def->equal : default_equal);
 
238
    return equal_fn(x, y);
 
239
}
 
240
 
 
241
/** Search for a key in an alist.
 
242
 * An alist is a list of conses, where the cars
 
243
 * of the conses are the keys. Compares keys using equality.
 
244
 *
 
245
 * @param k key
 
246
 * @param l alist to search
 
247
 * @return first element of l with car k, or ONULL
 
248
 */
 
249
Sxpr assoc(Sxpr k, Sxpr l){
 
250
    for( ; CONSP(l) ; l = CDR(l)){
 
251
        Sxpr x = CAR(l);
 
252
        if(CONSP(x) && objequal(k, CAR(x))){
 
253
            return x;   
 
254
        }
 
255
    }
 
256
    return ONULL;
 
257
}
 
258
 
 
259
/** Search for a key in an alist.
 
260
 * An alist is a list of conses, where the cars
 
261
 * of the conses are the keys. Compares keys using eq.
 
262
 *
 
263
 * @param k key
 
264
 * @param l alist to search
 
265
 * @return first element of l with car k, or ONULL
 
266
 */
 
267
Sxpr assocq(Sxpr k, Sxpr l){
 
268
    for( ; CONSP(l); l = CDR(l)){
 
269
        Sxpr x = CAR(l);
 
270
        if(CONSP(x) && eq(k, CAR(x))){
 
271
            return x;
 
272
        }
 
273
    }
 
274
    return ONULL;
 
275
}
 
276
 
 
277
/** Add a new key and value to an alist.
 
278
 *
 
279
 * @param k key
 
280
 * @param l value
 
281
 * @param l alist
 
282
 * @return l with the new cell added to the front
 
283
 */
 
284
Sxpr acons(Sxpr k, Sxpr v, Sxpr l){
 
285
    Sxpr x, y;
 
286
    x = cons_new(k, v);
 
287
    if(NOMEMP(x)) return x;
 
288
    y = cons_new(x, l);
 
289
    if(NOMEMP(y)) cons_free_cells(x);
 
290
    return y;
 
291
}
 
292
 
 
293
/** Test if a list contains an element.
 
294
 * Uses sxpr equality.
 
295
 *
 
296
 * @param l list
 
297
 * @param x element to look for
 
298
 * @return a tail of l with x as car, or ONULL
 
299
 */
 
300
Sxpr cons_member(Sxpr l, Sxpr x){
 
301
    for( ; CONSP(l) && !eq(x, CAR(l)); l = CDR(l)){}
 
302
    return l;
 
303
}
 
304
 
 
305
/** Test if a list contains an element satisfying a test.
 
306
 * The test function is called with v and an element of the list.
 
307
 *
 
308
 * @param l list
 
309
 * @param test_fn test function to use
 
310
 * @param v value for first argument to the test
 
311
 * @return a tail of l with car satisfying the test, or 0
 
312
 */
 
313
Sxpr cons_member_if(Sxpr l, ObjEqualFn *test_fn, Sxpr v){
 
314
    for( ; CONSP(l) && !test_fn(v, CAR(l)); l = CDR(l)){ }
 
315
    return l;
 
316
}
 
317
 
 
318
/** Test if the elements of list 't' are a subset of the elements
 
319
 * of list 's'. Element order is not significant.
 
320
 *
 
321
 * @param s element list to check subset of
 
322
 * @param t element list to check if is a subset
 
323
 * @return 1 if is a subset, 0 otherwise
 
324
 */
 
325
int cons_subset(Sxpr s, Sxpr t){
 
326
    for( ; CONSP(t); t = CDR(t)){
 
327
        if(!CONSP(cons_member(s, CAR(t)))){
 
328
            return 0;
 
329
        }
 
330
    }
 
331
    return 1;
 
332
}
 
333
 
 
334
/** Test if two lists have equal sets of elements.
 
335
 * Element order is not significant.
 
336
 *
 
337
 * @param s list to check
 
338
 * @param t list to check
 
339
 * @return 1 if equal, 0 otherwise
 
340
 */
 
341
int cons_set_equal(Sxpr s, Sxpr t){
 
342
    return cons_subset(s, t) && cons_subset(t, s);
 
343
}
 
344
 
 
345
#ifdef USE_GC
 
346
/*============================================================================*/
 
347
/* The functions inside this ifdef are only safe if GC is used.
 
348
 * Otherwise they may leak memory.
 
349
 */
 
350
 
 
351
/** Remove an element from a list (GC only).
 
352
 * Uses sxpr equality and removes all instances, even
 
353
 * if there are more than one.
 
354
 *
 
355
 * @param l list to remove elements from
 
356
 * @param x element to remove
 
357
 * @return modified input list
 
358
 */
 
359
Sxpr cons_remove(Sxpr l, Sxpr x){
 
360
    return cons_remove_if(l, eq, x);
 
361
}
 
362
 
 
363
/** Remove elements satisfying a test (GC only).
 
364
 * The test function is called with v and an element of the set.
 
365
 *
 
366
 * @param l list to remove elements from
 
367
 * @param test_fn function to use to decide if an element should be removed
 
368
 * @return modified input list
 
369
 */
 
370
Sxpr cons_remove_if(Sxpr l, ObjEqualFn *test_fn, Sxpr v){
 
371
    Sxpr prev = ONULL, elt, next;
 
372
 
 
373
    for(elt = l; CONSP(elt); elt = next){
 
374
        next = CDR(elt);
 
375
        if(test_fn(v, CAR(elt))){
 
376
            if(NULLP(prev)){
 
377
                l = next;
 
378
            } else {
 
379
                CDR(prev) = next;
 
380
            }
 
381
        }
 
382
    }
 
383
    return l;
 
384
}
 
385
 
 
386
/** Set the value for a key in an alist (GC only).
 
387
 * If the key is present, changes the value, otherwise
 
388
 * adds a new cell.
 
389
 *
 
390
 * @param k key
 
391
 * @param v value
 
392
 * @param l alist
 
393
 * @return modified or extended list
 
394
 */
 
395
Sxpr setf(Sxpr k, Sxpr v, Sxpr l){
 
396
    Sxpr e = assoc(k, l);
 
397
    if(NULLP(e)){
 
398
        l = acons(k, v, l);
 
399
    } else {
 
400
        CAR(CDR(e)) = v;
 
401
    }
 
402
    return l;
 
403
}
 
404
/*============================================================================*/
 
405
#endif /* USE_GC */
 
406
 
 
407
/** Create a new atom with the given name.
 
408
 *
 
409
 * @param name the name
 
410
 * @return new atom
 
411
 */
 
412
Sxpr atom_new(char *name){
 
413
    Sxpr n, obj = ONOMEM;
 
414
    long v;
 
415
 
 
416
    // Don't always want to do this.
 
417
    if(0 && convert_atol(name, &v) == 0){
 
418
        obj = OINT(v);
 
419
    } else {
 
420
        n = string_new(name);
 
421
        if(NOMEMP(n)) goto exit;
 
422
        obj = HALLOC(ObjAtom, T_ATOM);
 
423
        if(NOMEMP(obj)){
 
424
            string_free(n);
 
425
            goto exit;
 
426
        }
 
427
        OBJ_ATOM(obj)->name = n;
 
428
    }
 
429
  exit:
 
430
    return obj;
 
431
}
 
432
 
 
433
/** Free an atom.
 
434
 *
 
435
 * @param obj to free
 
436
 */
 
437
void atom_free(Sxpr obj){
 
438
    // Interned atoms are shared, so do not free.
 
439
    if(OBJ_ATOM(obj)->interned) return;
 
440
    objfree(OBJ_ATOM(obj)->name);
 
441
    hfree(obj);
 
442
}
 
443
 
 
444
/** Copy an atom.
 
445
 *
 
446
 * @param obj to copy
 
447
 */
 
448
Sxpr atom_copy(Sxpr obj){
 
449
    Sxpr v;
 
450
    if(OBJ_ATOM(obj)->interned){
 
451
        v = obj;
 
452
    } else {
 
453
        v = atom_new(atom_name(obj));
 
454
    }
 
455
    return v;
 
456
}
 
457
 
 
458
/** Print an atom. Prints the atom name.
 
459
 *
 
460
 * @param io stream to print to
 
461
 * @param obj to print
 
462
 * @param flags print flags
 
463
 * @return number of bytes printed
 
464
 */
 
465
int atom_print(IOStream *io, Sxpr obj, unsigned flags){
 
466
    return objprint(io, OBJ_ATOM(obj)->name, flags);
 
467
}
 
468
 
 
469
/** Atom equality.
 
470
 *
 
471
 * @param x to compare
 
472
 * @param y to compare
 
473
 * @return 1 if equal, 0 otherwise
 
474
 */
 
475
int atom_equal(Sxpr x, Sxpr y){
 
476
    int ok;
 
477
    ok = eq(x, y);
 
478
    if(ok) goto exit;
 
479
    ok = ATOMP(y) && string_equal(OBJ_ATOM(x)->name, OBJ_ATOM(y)->name);
 
480
    if(ok) goto exit;
 
481
    ok = STRINGP(y) && string_equal(OBJ_ATOM(x)->name, y);
 
482
  exit:
 
483
    return ok;
 
484
}
 
485
 
 
486
/** Get the name of an atom.
 
487
 *
 
488
 * @param obj atom
 
489
 * @return name
 
490
 */
 
491
char * atom_name(Sxpr obj){
 
492
    return string_string(OBJ_ATOM(obj)->name);
 
493
}
 
494
 
 
495
int atom_length(Sxpr obj){
 
496
    return string_length(OBJ_ATOM(obj)->name);
 
497
}
 
498
 
 
499
/** Get the C string from a string sxpr.
 
500
 *
 
501
 * @param obj string sxpr
 
502
 * @return string
 
503
 */
 
504
char * string_string(Sxpr obj){
 
505
    return OBJ_STRING(obj)->data;
 
506
}
 
507
 
 
508
/** Get the length of a string.
 
509
 *
 
510
 * @param obj string
 
511
 * @return length
 
512
 */
 
513
int string_length(Sxpr obj){
 
514
    return OBJ_STRING(obj)->len;
 
515
}
 
516
 
 
517
/** Create a new string. The input string is copied,
 
518
 * and must be null-terminated.
 
519
 *
 
520
 * @param s characters to put in the string
 
521
 * @return new sxpr
 
522
 */
 
523
Sxpr string_new(char *s){
 
524
    int n = (s ? strlen(s) : 0);
 
525
    return string_new_n(s, n);
 
526
}
 
527
 
 
528
/** Create a new string. The input string is copied,
 
529
 * and need not be null-terminated.
 
530
 *
 
531
 * @param s characters to put in the string (may be null)
 
532
 * @param n string length
 
533
 * @return new sxpr
 
534
 */
 
535
Sxpr string_new_n(char *s, int n){
 
536
    Sxpr obj;
 
537
    obj = halloc(sizeof(ObjString) + n + 1, T_STRING);
 
538
    if(!NOMEMP(obj)){
 
539
        char *str = OBJ_STRING(obj)->data;
 
540
        OBJ_STRING(obj)->len = n;
 
541
        if(s){
 
542
            memcpy(str, s, n);
 
543
            str[n] = '\0';
 
544
        } else {
 
545
            memset(str, 0, n + 1);
 
546
        }
 
547
    }
 
548
    return obj;
 
549
}
 
550
 
 
551
/** Free a string.
 
552
 *
 
553
 * @param obj to free
 
554
 */
 
555
void string_free(Sxpr obj){
 
556
    hfree(obj);
 
557
}
 
558
 
 
559
/** Copy a string.
 
560
 *
 
561
 * @param obj to copy
 
562
 */
 
563
Sxpr string_copy(Sxpr obj){
 
564
    return string_new_n(string_string(obj), string_length(obj));
 
565
}
 
566
 
 
567
/** Determine if a string needs escapes when printed
 
568
 * using the given flags.
 
569
 *
 
570
 * @param str string to check
 
571
 * @param n string length
 
572
 * @param flags print flags
 
573
 * @return 1 if needs escapes, 0 otherwise
 
574
 */
 
575
int needs_escapes(char *str, int n, unsigned flags){
 
576
    char *c;
 
577
    int i;
 
578
    int val = 0;
 
579
 
 
580
    if(str){
 
581
        for(i=0, c=str; i<n; i++, c++){
 
582
            if(in_alpha_class(*c)) continue;
 
583
            if(in_decimal_digit_class(*c)) continue;
 
584
            if(in_class(*c, "/._+:@~-")) continue;
 
585
            val = 1;
 
586
            break;
 
587
        }
 
588
    }
 
589
    return val;
 
590
}
 
591
 
 
592
char randchar(void){
 
593
    int r;
 
594
    char c;
 
595
    for( ; ; ){
 
596
        r = rand();
 
597
        c = (r >> 16) & 0xff;
 
598
        if('a' <= c && c <= 'z') break;
 
599
    }
 
600
    return c;
 
601
}
 
602
 
 
603
int string_contains(char *s, int s_n, char *k, int k_n){
 
604
    int i, n = s_n - k_n;
 
605
    for(i=0; i < n; i++){
 
606
        if(!memcmp(s+i, k, k_n)) return 1;
 
607
    }
 
608
    return 0;
 
609
}
 
610
 
 
611
int string_delim(char *s, int s_n, char *d, int d_n){
 
612
    int i;
 
613
    if(d_n < 4) return -1;
 
614
    memset(d, 0, d_n+1);
 
615
    for(i=0; i<3; i++){
 
616
        d[i] = randchar();
 
617
    }
 
618
    for( ; i < d_n; i++){
 
619
        if(!string_contains(s, s_n, d, i)){
 
620
            return i;
 
621
        }
 
622
        d[i] = randchar();
 
623
    }
 
624
    return -1;
 
625
}
 
626
 
 
627
/** Print the bytes in a string as-is.
 
628
 *
 
629
 * @param io stream
 
630
 * @param str string
 
631
 * @param n length
 
632
 * @return bytes written or error code
 
633
 */
 
634
int _string_print_raw(IOStream *io, char *str, int n){
 
635
    int k = 0;
 
636
    k = IOStream_write(io, str, n);
 
637
    return k;
 
638
}
 
639
 
 
640
/** Print a string in counted data format.
 
641
 *
 
642
 * @param io stream
 
643
 * @param str string
 
644
 * @param n length
 
645
 * @return bytes written or error code
 
646
 */
 
647
int _string_print_counted(IOStream *io, char *str, int n){
 
648
    int k = 0;
 
649
    k += IOStream_print(io, "%c%c%d%c",
 
650
                        c_data_open, c_data_count, n, c_data_count);
 
651
    k += IOStream_write(io, str, n);
 
652
    return k;
 
653
}
 
654
  
 
655
/** Print a string in quoted data format.
 
656
 *
 
657
 * @param io stream
 
658
 * @param str string
 
659
 * @param n length
 
660
 * @return bytes written or error code
 
661
 */
 
662
int _string_print_quoted(IOStream *io, char *str, int n){
 
663
    int k = 0;
 
664
    char d[10];
 
665
    int d_n;
 
666
    d_n = string_delim(str, n, d, sizeof(d) - 1);
 
667
    k += IOStream_print(io, "%c%c%s%c",
 
668
                        c_data_open, c_data_quote, d, c_data_quote);
 
669
    k += IOStream_write(io, str, n);
 
670
    k += IOStream_print(io, "%c%s%c", c_data_quote, d, c_data_quote);
 
671
    return k;
 
672
}
 
673
 
 
674
/** Print a string as a quoted string.
 
675
 *
 
676
 * @param io stream
 
677
 * @param str string
 
678
 * @param n length
 
679
 * @return bytes written or error code
 
680
 */
 
681
int _string_print_string(IOStream *io, char *str, int n){
 
682
    int k = 0;
 
683
    
 
684
    k += IOStream_print(io, "\"");
 
685
    if(str){
 
686
        char *s, *t;
 
687
        for(s = str, t = str + n; s < t; s++){
 
688
            if(*s < ' ' || *s >= 127 ){
 
689
                switch(*s){
 
690
                case '\a': k += IOStream_print(io, "\\a");  break;
 
691
                case '\b': k += IOStream_print(io, "\\b");  break;
 
692
                case '\f': k += IOStream_print(io, "\\f");  break;
 
693
                case '\n': k += IOStream_print(io, "\\n");  break;
 
694
                case '\r': k += IOStream_print(io, "\\r");  break;
 
695
                case '\t': k += IOStream_print(io, "\\t");  break;
 
696
                case '\v': k += IOStream_print(io, "\\v");  break;
 
697
                default:
 
698
                    // Octal escape;
 
699
                    k += IOStream_print(io, "\\%o", *s);
 
700
                    break;
 
701
                }
 
702
            } else if(*s == c_double_quote ||
 
703
                      *s == c_single_quote ||
 
704
                      *s == c_escape){
 
705
                k += IOStream_print(io, "\\%c", *s);
 
706
            } else {
 
707
                k+= IOStream_print(io, "%c", *s);
 
708
            }
 
709
        }
 
710
    }
 
711
    k += IOStream_print(io, "\"");
 
712
    return k;
 
713
}
 
714
 
 
715
/** Print a string to a stream, with escapes if necessary.
 
716
 *
 
717
 * @param io stream to print to
 
718
 * @param str string
 
719
 * @param n string length
 
720
 * @param flags print flags
 
721
 * @return number of bytes written
 
722
 */
 
723
int _string_print(IOStream *io, char *str, int n, unsigned flags){
 
724
    int k = 0;
 
725
    if((flags & PRINT_COUNTED)){
 
726
        k = _string_print_counted(io, str, n);
 
727
    } else if((flags & PRINT_RAW) || !needs_escapes(str, n, flags)){
 
728
        k = _string_print_raw(io, str, n);
 
729
    } else if(n > 50){
 
730
        k = _string_print_quoted(io, str, n);
 
731
    } else {
 
732
        k = _string_print_string(io, str, n);
 
733
    }
 
734
    return k;
 
735
}
 
736
 
 
737
/** Print a string to a stream, with escapes if necessary.
 
738
 *
 
739
 * @param io stream to print to
 
740
 * @param obj string
 
741
 * @param flags print flags
 
742
 * @return number of bytes written
 
743
 */
 
744
int string_print(IOStream *io, Sxpr obj, unsigned flags){
 
745
    return _string_print(io,
 
746
                         OBJ_STRING(obj)->data,
 
747
                         OBJ_STRING(obj)->len,
 
748
                         flags);
 
749
}
 
750
 
 
751
int string_eq(char *s, int s_n, char *t, int t_n){
 
752
    return (s_n == t_n) && (memcmp(s, t, s_n) == 0);
 
753
}
 
754
 
 
755
/** Compare an sxpr with a string for equality.
 
756
 *
 
757
 * @param x string to compare with
 
758
 * @param y sxpr to compare
 
759
 * @return 1 if equal, 0 otherwise
 
760
 */
 
761
int string_equal(Sxpr x, Sxpr y){
 
762
    int ok = 0;
 
763
    ok = eq(x,y);
 
764
    if(ok) goto exit;
 
765
    ok = has_type(y, T_STRING) &&
 
766
        string_eq(OBJ_STRING(x)->data, OBJ_STRING(x)->len,
 
767
                  OBJ_STRING(y)->data, OBJ_STRING(y)->len);
 
768
    if(ok) goto exit;
 
769
    ok = has_type(y, T_ATOM) &&
 
770
        string_eq(OBJ_STRING(x)->data, OBJ_STRING(x)->len,
 
771
                  atom_name(y), atom_length(y));
 
772
  exit:
 
773
    return ok;
 
774
}
 
775
 
 
776
/** Create a new cons cell.
 
777
 * The cell is ONOMEM if either argument is.
 
778
 *
 
779
 * @param car sxpr for the car
 
780
 * @param cdr sxpr for the cdr
 
781
 * @return new cons
 
782
 */
 
783
Sxpr cons_new(Sxpr car, Sxpr cdr){
 
784
    Sxpr obj;
 
785
    if(NOMEMP(car) || NOMEMP(cdr)){
 
786
        obj = ONOMEM;
 
787
    } else {
 
788
        obj = HALLOC(ObjCons, T_CONS);
 
789
        if(!NOMEMP(obj)){
 
790
            ObjCons *z = OBJ_CONS(obj);
 
791
            z->car = car;
 
792
            z->cdr = cdr;
 
793
        }
 
794
    }
 
795
    return obj;
 
796
}
 
797
 
 
798
/** Push a new element onto a list.
 
799
 *
 
800
 * @param list list to add to
 
801
 * @param elt element to add
 
802
 * @return 0 if successful, error code otherwise
 
803
 */
 
804
int cons_push(Sxpr *list, Sxpr elt){
 
805
    Sxpr l;
 
806
    l = cons_new(elt, *list);
 
807
    if(NOMEMP(l)) return -ENOMEM;
 
808
    *list = l;
 
809
    return 0;
 
810
}
 
811
 
 
812
/** Free a cons. Recursively frees the car and cdr.
 
813
 *
 
814
 * @param obj to free
 
815
 */
 
816
void cons_free(Sxpr obj){
 
817
    Sxpr next;
 
818
    for(; CONSP(obj); obj = next){
 
819
        next = CDR(obj);
 
820
        objfree(CAR(obj));
 
821
        hfree(obj);
 
822
    }
 
823
    if(!NULLP(obj)){
 
824
        objfree(obj);
 
825
    }
 
826
}
 
827
 
 
828
/** Copy a cons. Recursively copies the car and cdr.
 
829
 *
 
830
 * @param obj to copy
 
831
 */
 
832
Sxpr cons_copy(Sxpr obj){
 
833
    Sxpr v = ONULL;
 
834
    Sxpr l = ONULL, x = ONONE;
 
835
    for(l = obj; CONSP(l); l = CDR(l)){
 
836
        x = objcopy(CAR(l));
 
837
        if(NOMEMP(x)) goto exit;
 
838
        x = cons_new(x, v);
 
839
        if(NOMEMP(x)) goto exit;
 
840
        v = x;
 
841
    }
 
842
    v = nrev(v);
 
843
  exit:
 
844
    if(NOMEMP(x)){
 
845
        objfree(v);
 
846
        v = ONOMEM;
 
847
    }
 
848
    return v;
 
849
}
 
850
 
 
851
/** Free a cons and its cdr cells, but not the car sxprs.
 
852
 * Does nothing if called on something that is not a cons.
 
853
 *
 
854
 * @param obj to free
 
855
 */
 
856
void cons_free_cells(Sxpr obj){
 
857
    Sxpr next;
 
858
    for(; CONSP(obj); obj = next){
 
859
        next = CDR(obj);
 
860
        hfree(obj);
 
861
    }
 
862
}
 
863
 
 
864
/** Print a cons.
 
865
 * Prints the cons in list format if the cdrs are conses.
 
866
 * uses pair (dot) format if the last cdr is not a cons (or null).
 
867
 *
 
868
 * @param io stream to print to
 
869
 * @param obj to print
 
870
 * @param flags print flags
 
871
 * @return number of bytes written
 
872
 */
 
873
int cons_print(IOStream *io, Sxpr obj, unsigned flags){
 
874
    int first = 1;
 
875
    int k = 0;
 
876
    k += IOStream_print(io, "(");
 
877
    for( ; CONSP(obj) ; obj = CDR(obj)){
 
878
        if(first){ 
 
879
            first = 0;
 
880
        } else {
 
881
            k += IOStream_print(io, " ");
 
882
        }
 
883
        k += objprint(io, CAR(obj), flags);
 
884
    }
 
885
    if(!NULLP(obj)){
 
886
        k += IOStream_print(io, " . ");
 
887
        k += objprint(io, obj, flags);
 
888
    }
 
889
    k += IOStream_print(io, ")");
 
890
    return (IOStream_error(io) ? -1 : k);
 
891
}
 
892
 
 
893
/** Compare a cons with another sxpr for equality.
 
894
 * If y is a cons, compares the cars and cdrs recursively.
 
895
 *
 
896
 * @param x cons to compare
 
897
 * @param y sxpr to compare
 
898
 * @return 1 if equal, 0 otherwise
 
899
 */
 
900
int cons_equal(Sxpr x, Sxpr y){
 
901
    return CONSP(y) &&
 
902
        objequal(CAR(x), CAR(y)) &&
 
903
        objequal(CDR(x), CDR(y));
 
904
}
 
905
 
 
906
/** Return the length of a cons list.
 
907
 *
 
908
 * @param obj list
 
909
 * @return length
 
910
 */
 
911
int cons_length(Sxpr obj){
 
912
    int count = 0;
 
913
    for( ; CONSP(obj); obj = CDR(obj)){
 
914
        count++;
 
915
    }
 
916
    return count;
 
917
}
 
918
 
 
919
/** Destructively reverse a cons list in-place.
 
920
 * If the argument is not a cons it is returned unchanged.
 
921
 * 
 
922
 * @param l to reverse
 
923
 * @return reversed list
 
924
 */
 
925
Sxpr nrev(Sxpr l){
 
926
    if(CONSP(l)){
 
927
        // Iterate down the cells in the list making the cdr of
 
928
        // each cell point to the previous cell. The last cell 
 
929
        // is the head of the reversed list.
 
930
        Sxpr prev = ONULL;
 
931
        Sxpr cell = l;
 
932
        Sxpr next;
 
933
 
 
934
        while(1){
 
935
            next = CDR(cell);
 
936
            CDR(cell) = prev;
 
937
            if(!CONSP(next)) break;
 
938
            prev = cell;
 
939
            cell = next;
 
940
        }
 
941
        l = cell;
 
942
    }
 
943
    return l;
 
944
}
 
945
 
 
946
/** Print the null sxpr.        
 
947
 *
 
948
 * @param io stream to print to
 
949
 * @param obj to print
 
950
 * @param flags print flags
 
951
 * @return number of bytes written
 
952
 */
 
953
static int null_print(IOStream *io, Sxpr obj, unsigned flags){
 
954
    return IOStream_print(io, "()");
 
955
}
 
956
 
 
957
/** Print the `unspecified' sxpr none.
 
958
 *
 
959
 * @param io stream to print to
 
960
 * @param obj to print
 
961
 * @param flags print flags
 
962
 * @return number of bytes written
 
963
 */
 
964
static int none_print(IOStream *io, Sxpr obj, unsigned flags){
 
965
    return IOStream_print(io, "<none>");
 
966
}
 
967
 
 
968
/** Print an integer.
 
969
 *
 
970
 * @param io stream to print to
 
971
 * @param obj to print
 
972
 * @param flags print flags
 
973
 * @return number of bytes written
 
974
 */
 
975
static int int_print(IOStream *io, Sxpr obj, unsigned flags){
 
976
    return IOStream_print(io, "%d", OBJ_INT(obj));
 
977
}
 
978
 
 
979
/** Print a boolean.
 
980
 *
 
981
 * @param io stream to print to
 
982
 * @param obj to print
 
983
 * @param flags print flags
 
984
 * @return number of bytes written
 
985
 */
 
986
static int bool_print(IOStream *io, Sxpr obj, unsigned flags){
 
987
    return IOStream_print(io, (OBJ_UINT(obj) ? k_true : k_false));
 
988
}
 
989
 
 
990
/** Print an error.
 
991
 *
 
992
 * @param io stream to print to
 
993
 * @param obj to print
 
994
 * @param flags print flags
 
995
 * @return number of bytes written
 
996
 */
 
997
static int err_print(IOStream *io, Sxpr obj, unsigned flags){
 
998
    int err = OBJ_INT(obj);
 
999
    if(err < 0) err = -err;
 
1000
    return IOStream_print(io, "[error:%d:%s]", err, strerror(err));
 
1001
}
 
1002
 
 
1003
/** Print the 'nomem' sxpr.
 
1004
 *
 
1005
 * @param io stream to print to
 
1006
 * @param obj to print
 
1007
 * @param flags print flags
 
1008
 * @return number of bytes written
 
1009
 */
 
1010
static int nomem_print(IOStream *io, Sxpr obj, unsigned flags){
 
1011
    return IOStream_print(io, "[ENOMEM]");
 
1012
}
 
1013
 
 
1014
int sxprp(Sxpr obj, Sxpr name){
 
1015
    return CONSP(obj) && objequal(CAR(obj), name);
 
1016
}
 
1017
 
 
1018
/** Get the name of an element.
 
1019
 * 
 
1020
 * @param obj element
 
1021
 * @return name
 
1022
 */
 
1023
Sxpr sxpr_name(Sxpr obj){
 
1024
    Sxpr val = ONONE;
 
1025
    if(CONSP(obj)){
 
1026
        val = CAR(obj);
 
1027
    } else if(STRINGP(obj) || ATOMP(obj)){
 
1028
        val = obj;
 
1029
    }
 
1030
    return val;
 
1031
}
 
1032
 
 
1033
int sxpr_is(Sxpr obj, char *s){
 
1034
    if(ATOMP(obj)) return string_eq(atom_name(obj), atom_length(obj), s, strlen(s));
 
1035
    if(STRINGP(obj)) return string_eq(string_string(obj), string_length(obj), s, strlen(s));
 
1036
    return 0;
 
1037
}
 
1038
 
 
1039
int sxpr_elementp(Sxpr obj, Sxpr name){
 
1040
    int ok = 0;
 
1041
    ok = CONSP(obj) && objequal(CAR(obj), name);
 
1042
    return ok;
 
1043
}
 
1044
 
 
1045
/** Get the attributes of an sxpr.
 
1046
 * 
 
1047
 * @param obj sxpr
 
1048
 * @return attributes
 
1049
 */
 
1050
Sxpr sxpr_attributes(Sxpr obj){
 
1051
    Sxpr val = ONULL;
 
1052
    if(CONSP(obj)){
 
1053
        obj = CDR(obj);
 
1054
        if(CONSP(obj)){
 
1055
            obj = CAR(obj);
 
1056
            if(sxprp(obj, intern("@"))){
 
1057
                val = CDR(obj);
 
1058
            }
 
1059
        }
 
1060
    }
 
1061
    return val;
 
1062
}
 
1063
 
 
1064
Sxpr sxpr_attribute(Sxpr obj, Sxpr key, Sxpr def){
 
1065
    Sxpr val = ONONE;
 
1066
    val = assoc(sxpr_attributes(obj), key);
 
1067
    if(CONSP(val) && CONSP(CDR(val))){
 
1068
        val = CADR(def);
 
1069
    } else {
 
1070
        val = def;
 
1071
    }
 
1072
    return val;
 
1073
}
 
1074
 
 
1075
/** Get the children of an sxpr.
 
1076
 * 
 
1077
 * @param obj sxpr
 
1078
 * @return children
 
1079
 */
 
1080
Sxpr sxpr_children(Sxpr obj){
 
1081
    Sxpr val = ONULL;
 
1082
    if(CONSP(obj)){
 
1083
        val = CDR(obj);
 
1084
        if(CONSP(val) && sxprp(CAR(val), intern("@"))){
 
1085
            val = CDR(val);
 
1086
        }
 
1087
    }
 
1088
    return val;
 
1089
}
 
1090
 
 
1091
Sxpr sxpr_child(Sxpr obj, Sxpr name, Sxpr def){
 
1092
    Sxpr val = ONONE;
 
1093
    Sxpr l;
 
1094
    for(l = sxpr_children(obj); CONSP(l); l = CDR(l)){
 
1095
        if(sxprp(CAR(l), name)){
 
1096
            val = CAR(l);
 
1097
            break;
 
1098
        }
 
1099
    }
 
1100
    if(NONEP(val)) val = def;
 
1101
    return val;
 
1102
}
 
1103
 
 
1104
Sxpr sxpr_child0(Sxpr obj, Sxpr def){
 
1105
    Sxpr val = ONONE;
 
1106
    Sxpr l = sxpr_children(obj);
 
1107
    if(CONSP(l)){
 
1108
        val = CAR(l);
 
1109
    } else {
 
1110
        val = def;
 
1111
    }
 
1112
    return val;
 
1113
}
 
1114
 
 
1115
Sxpr sxpr_childN(Sxpr obj, int n, Sxpr def){
 
1116
    Sxpr val = def;
 
1117
    Sxpr l;
 
1118
    int i;
 
1119
    for (i = 0, l = sxpr_children(obj); CONSP(l); i++, l = CDR(l)){
 
1120
        if(i == n){
 
1121
            val = CAR(l);
 
1122
            break;
 
1123
        }
 
1124
    }
 
1125
    return val;
 
1126
}
 
1127
    
 
1128
Sxpr sxpr_child_value(Sxpr obj, Sxpr name, Sxpr def){
 
1129
    Sxpr val = ONONE;
 
1130
    val = sxpr_child(obj, name, ONONE);
 
1131
    if(NONEP(val)){
 
1132
        val = def;
 
1133
    } else {
 
1134
        val = sxpr_child0(val, def);
 
1135
    }
 
1136
    return val;
 
1137
}
 
1138
 
 
1139
/** Table of interned symbols. Indexed by symbol name. */
 
1140
static HashTable *symbols = NULL;
 
1141
 
 
1142
/** Hash function for entries in the symbol table.
 
1143
 *
 
1144
 * @param key to hash
 
1145
 * @return hashcode
 
1146
 */
 
1147
static Hashcode sym_hash_fn(void *key){
 
1148
    return hash_string((char*)key);
 
1149
}
 
1150
 
 
1151
/** Key equality function for the symbol table.
 
1152
 *
 
1153
 * @param x to compare
 
1154
 * @param y to compare
 
1155
 * @return 1 if equal, 0 otherwise
 
1156
 */
 
1157
static int sym_equal_fn(void *x, void *y){
 
1158
    return !strcmp((char*)x, (char*)y);
 
1159
}
 
1160
 
 
1161
/** Entry free function for the symbol table.
 
1162
 *
 
1163
 * @param table the entry is in
 
1164
 * @param entry being freed
 
1165
 */
 
1166
static void sym_free_fn(HashTable *table, HTEntry *entry){
 
1167
    if(entry){
 
1168
        objfree(((ObjAtom*)entry->value)->name);
 
1169
        HTEntry_free(entry);
 
1170
    }
 
1171
}
 
1172
        
 
1173
/** Initialize the symbol table.
 
1174
 *
 
1175
 * @return 0 on sucess, error code otherwise
 
1176
 */
 
1177
static int init_symbols(void){
 
1178
    symbols = HashTable_new(100);
 
1179
    if(symbols){
 
1180
        symbols->key_hash_fn = sym_hash_fn;
 
1181
        symbols->key_equal_fn = sym_equal_fn;
 
1182
        symbols->entry_free_fn = sym_free_fn;
 
1183
        return 0;
 
1184
    }
 
1185
    return -1;
 
1186
}
 
1187
 
 
1188
/** Cleanup the symbol table. Frees the table and all its symbols.
 
1189
 */
 
1190
void cleanup_symbols(void){
 
1191
    HashTable_free(symbols);
 
1192
    symbols = NULL;
 
1193
}
 
1194
 
 
1195
/** Get the interned symbol with the given name.
 
1196
 * No new symbol is created.
 
1197
 *
 
1198
 * @return symbol or null
 
1199
 */
 
1200
Sxpr get_symbol(char *sym){
 
1201
    HTEntry *entry;
 
1202
    if(!symbols){
 
1203
        if(init_symbols()) return ONOMEM;
 
1204
        return ONULL;
 
1205
    }
 
1206
    entry = HashTable_get_entry(symbols, sym);
 
1207
    if(entry){
 
1208
        return OBJP(T_ATOM, entry->value);
 
1209
    } else {
 
1210
        return ONULL;
 
1211
    }
 
1212
}
 
1213
 
 
1214
/** Get the interned symbol with the given name.
 
1215
 * Creates a new symbol if necessary.
 
1216
 *
 
1217
 * @return symbol
 
1218
 */
 
1219
Sxpr intern(char *sym){
 
1220
    Sxpr symbol = get_symbol(sym);
 
1221
    if(NULLP(symbol)){
 
1222
        if(!symbols) return ONOMEM;
 
1223
        symbol = atom_new(sym);
 
1224
        if(!NOMEMP(symbol)){
 
1225
            OBJ_ATOM(symbol)->interned = TRUE;
 
1226
            HashTable_add(symbols, atom_name(symbol), get_ptr(symbol));
 
1227
        }
 
1228
    }
 
1229
    return symbol;
 
1230
}