OpenCores
URL https://opencores.org/ocsvn/or1k/or1k/trunk

Subversion Repositories or1k

[/] [or1k/] [trunk/] [insight/] [tcl/] [generic/] [tclBinary.c] - Blame information for rev 1765

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 578 markom
/*
2
 * tclBinary.c --
3
 *
4
 *      This file contains the implementation of the "binary" Tcl built-in
5
 *      command .
6
 *
7
 * Copyright (c) 1997 by Sun Microsystems, Inc.
8
 *
9
 * See the file "license.terms" for information on usage and redistribution
10
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
11
 *
12
 * RCS: @(#) $Id: tclBinary.c,v 1.1.1.1 2002-01-16 10:25:25 markom Exp $
13
 */
14
 
15
#include <math.h>
16
#include "tclInt.h"
17
#include "tclPort.h"
18
 
19
/*
20
 * The following constants are used by GetFormatSpec to indicate various
21
 * special conditions in the parsing of a format specifier.
22
 */
23
 
24
#define BINARY_ALL -1           /* Use all elements in the argument. */
25
#define BINARY_NOCOUNT -2       /* No count was specified in format. */
26
 
27
/*
28
 * Prototypes for local procedures defined in this file:
29
 */
30
 
31
static int              GetFormatSpec _ANSI_ARGS_((char **formatPtr,
32
                            char *cmdPtr, int *countPtr));
33
static int              FormatNumber _ANSI_ARGS_((Tcl_Interp *interp, int type,
34
                            Tcl_Obj *src, char **cursorPtr));
35
static Tcl_Obj *        ScanNumber _ANSI_ARGS_((char *buffer, int type));
36
 
37
/*
38
 *----------------------------------------------------------------------
39
 *
40
 * Tcl_BinaryObjCmd --
41
 *
42
 *      This procedure implements the "binary" Tcl command.
43
 *
44
 * Results:
45
 *      A standard Tcl result.
46
 *
47
 * Side effects:
48
 *      See the user documentation.
49
 *
50
 *----------------------------------------------------------------------
51
 */
52
 
53
int
54
Tcl_BinaryObjCmd(dummy, interp, objc, objv)
55
    ClientData dummy;           /* Not used. */
56
    Tcl_Interp *interp;         /* Current interpreter. */
57
    int objc;                   /* Number of arguments. */
58
    Tcl_Obj *CONST objv[];      /* Argument objects. */
59
{
60
    int arg;                    /* Index of next argument to consume. */
61
    int value = 0;               /* Current integer value to be packed.
62
                                 * Initialized to avoid compiler warning. */
63
    char cmd;                   /* Current format character. */
64
    int count;                  /* Count associated with current format
65
                                 * character. */
66
    char *format;               /* Pointer to current position in format
67
                                 * string. */
68
    char *cursor;               /* Current position within result buffer. */
69
    char *maxPos;               /* Greatest position within result buffer that
70
                                 * cursor has visited.*/
71
    char *buffer;               /* Start of data buffer. */
72
    char *errorString, *errorValue, *str;
73
    int offset, size, length;
74
    Tcl_Obj *resultPtr;
75
 
76
    static char *subCmds[] = { "format", "scan", (char *) NULL };
77
    enum { BinaryFormat, BinaryScan } index;
78
 
79
    if (objc < 2) {
80
        Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
81
        return TCL_ERROR;
82
    }
83
 
84
    if (Tcl_GetIndexFromObj(interp, objv[1], subCmds, "option", 0,
85
            (int *) &index) != TCL_OK) {
86
        return TCL_ERROR;
87
    }
88
 
89
    switch (index) {
90
        case BinaryFormat:
91
            if (objc < 3) {
92
                Tcl_WrongNumArgs(interp, 2, objv, "formatString ?arg arg ...?");
93
                return TCL_ERROR;
94
            }
95
            /*
96
             * To avoid copying the data, we format the string in two passes.
97
             * The first pass computes the size of the output buffer.  The
98
             * second pass places the formatted data into the buffer.
99
             */
100
 
101
            format = Tcl_GetStringFromObj(objv[2], NULL);
102
            arg = 3;
103
            offset = length = 0;
104
            while (*format != 0) {
105
                if (!GetFormatSpec(&format, &cmd, &count)) {
106
                    break;
107
                }
108
                switch (cmd) {
109
                    case 'a':
110
                    case 'A':
111
                    case 'b':
112
                    case 'B':
113
                    case 'h':
114
                    case 'H':
115
                        /*
116
                         * For string-type specifiers, the count corresponds
117
                         * to the number of characters in a single argument.
118
                         */
119
 
120
                        if (arg >= objc) {
121
                            goto badIndex;
122
                        }
123
                        if (count == BINARY_ALL) {
124
                            (void)Tcl_GetStringFromObj(objv[arg], &count);
125
                        } else if (count == BINARY_NOCOUNT) {
126
                            count = 1;
127
                        }
128
                        arg++;
129
                        if (cmd == 'a' || cmd == 'A') {
130
                            offset += count;
131
                        } else if (cmd == 'b' || cmd == 'B') {
132
                            offset += (count + 7) / 8;
133
                        } else {
134
                            offset += (count + 1) / 2;
135
                        }
136
                        break;
137
 
138
                    case 'c':
139
                        size = 1;
140
                        goto doNumbers;
141
                    case 's':
142
                    case 'S':
143
                        size = 2;
144
                        goto doNumbers;
145
                    case 'i':
146
                    case 'I':
147
                        size = 4;
148
                        goto doNumbers;
149
                    case 'f':
150
                        size = sizeof(float);
151
                        goto doNumbers;
152
                    case 'd':
153
                        size = sizeof(double);
154
                    doNumbers:
155
                        if (arg >= objc) {
156
                            goto badIndex;
157
                        }
158
 
159
                        /*
160
                         * For number-type specifiers, the count corresponds
161
                         * to the number of elements in the list stored in
162
                         * a single argument.  If no count is specified, then
163
                         * the argument is taken as a single non-list value.
164
                         */
165
 
166
                        if (count == BINARY_NOCOUNT) {
167
                            arg++;
168
                            count = 1;
169
                        } else {
170
                            int listc;
171
                            Tcl_Obj **listv;
172
                            if (Tcl_ListObjGetElements(interp, objv[arg++],
173
                                    &listc, &listv) != TCL_OK) {
174
                                return TCL_ERROR;
175
                            }
176
                            if (count == BINARY_ALL) {
177
                                count = listc;
178
                            } else if (count > listc) {
179
                                errorString = "number of elements in list does not match count";
180
                                goto error;
181
                            }
182
                        }
183
                        offset += count*size;
184
                        break;
185
 
186
                    case 'x':
187
                        if (count == BINARY_ALL) {
188
                            errorString = "cannot use \"*\" in format string with \"x\"";
189
                            goto error;
190
                        } else if (count == BINARY_NOCOUNT) {
191
                            count = 1;
192
                        }
193
                        offset += count;
194
                        break;
195
                    case 'X':
196
                        if (count == BINARY_NOCOUNT) {
197
                            count = 1;
198
                        }
199
                        if ((count > offset) || (count == BINARY_ALL)) {
200
                            count = offset;
201
                        }
202
                        if (offset > length) {
203
                            length = offset;
204
                        }
205
                        offset -= count;
206
                        break;
207
                    case '@':
208
                        if (offset > length) {
209
                            length = offset;
210
                        }
211
                        if (count == BINARY_ALL) {
212
                            offset = length;
213
                        } else if (count == BINARY_NOCOUNT) {
214
                            goto badCount;
215
                        } else {
216
                            offset = count;
217
                        }
218
                        break;
219
                    default: {
220
                        char buf[2];
221
 
222
                        Tcl_ResetResult(interp);
223
                        buf[0] = cmd;
224
                        buf[1] = '\0';
225
                        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
226
                                "bad field specifier \"", buf, "\"", NULL);
227
                        return TCL_ERROR;
228
                    }
229
                }
230
            }
231
            if (offset > length) {
232
                length = offset;
233
            }
234
            if (length == 0) {
235
                return TCL_OK;
236
            }
237
 
238
            /*
239
             * Prepare the result object by preallocating the caclulated
240
             * number of bytes and filling with nulls.
241
             */
242
 
243
            resultPtr = Tcl_GetObjResult(interp);
244
            Tcl_SetObjLength(resultPtr, length);
245
            buffer = Tcl_GetStringFromObj(resultPtr, NULL);
246
            memset(buffer, 0, (size_t) length);
247
 
248
            /*
249
             * Pack the data into the result object.  Note that we can skip
250
             * the error checking during this pass, since we have already
251
             * parsed the string once.
252
             */
253
 
254
            arg = 3;
255
            format = Tcl_GetStringFromObj(objv[2], NULL);
256
            cursor = buffer;
257
            maxPos = cursor;
258
            while (*format != 0) {
259
                if (!GetFormatSpec(&format, &cmd, &count)) {
260
                    break;
261
                }
262
                if ((count == 0) && (cmd != '@')) {
263
                    arg++;
264
                    continue;
265
                }
266
                switch (cmd) {
267
                    case 'a':
268
                    case 'A': {
269
                        char pad = (char) (cmd == 'a' ? '\0' : ' ');
270
 
271
                        str = Tcl_GetStringFromObj(objv[arg++], &length);
272
 
273
                        if (count == BINARY_ALL) {
274
                            count = length;
275
                        } else if (count == BINARY_NOCOUNT) {
276
                            count = 1;
277
                        }
278
                        if (length >= count) {
279
                            memcpy((VOID *) cursor, (VOID *) str,
280
                                    (size_t) count);
281
                        } else {
282
                            memcpy((VOID *) cursor, (VOID *) str,
283
                                    (size_t) length);
284
                            memset(cursor+length, pad,
285
                                    (size_t) (count - length));
286
                        }
287
                        cursor += count;
288
                        break;
289
                    }
290
                    case 'b':
291
                    case 'B': {
292
                        char *last;
293
 
294
                        str = Tcl_GetStringFromObj(objv[arg++], &length);
295
                        if (count == BINARY_ALL) {
296
                            count = length;
297
                        } else if (count == BINARY_NOCOUNT) {
298
                            count = 1;
299
                        }
300
                        last = cursor + ((count + 7) / 8);
301
                        if (count > length) {
302
                            count = length;
303
                        }
304
                        value = 0;
305
                        errorString = "binary";
306
                        if (cmd == 'B') {
307
                            for (offset = 0; offset < count; offset++) {
308
                                value <<= 1;
309
                                if (str[offset] == '1') {
310
                                    value |= 1;
311
                                } else if (str[offset] != '0') {
312
                                    errorValue = str;
313
                                    goto badValue;
314
                                }
315
                                if (((offset + 1) % 8) == 0) {
316
                                    *cursor++ = (char)(value & 0xff);
317
                                    value = 0;
318
                                }
319
                            }
320
                        } else {
321
                            for (offset = 0; offset < count; offset++) {
322
                                value >>= 1;
323
                                if (str[offset] == '1') {
324
                                    value |= 128;
325
                                } else if (str[offset] != '0') {
326
                                    errorValue = str;
327
                                    goto badValue;
328
                                }
329
                                if (!((offset + 1) % 8)) {
330
                                    *cursor++ = (char)(value & 0xff);
331
                                    value = 0;
332
                                }
333
                            }
334
                        }
335
                        if ((offset % 8) != 0) {
336
                            if (cmd == 'B') {
337
                                value <<= 8 - (offset % 8);
338
                            } else {
339
                                value >>= 8 - (offset % 8);
340
                            }
341
                            *cursor++ = (char)(value & 0xff);
342
                        }
343
                        while (cursor < last) {
344
                            *cursor++ = '\0';
345
                        }
346
                        break;
347
                    }
348
                    case 'h':
349
                    case 'H': {
350
                        char *last;
351
                        int c;
352
 
353
                        str = Tcl_GetStringFromObj(objv[arg++], &length);
354
                        if (count == BINARY_ALL) {
355
                            count = length;
356
                        } else if (count == BINARY_NOCOUNT) {
357
                            count = 1;
358
                        }
359
                        last = cursor + ((count + 1) / 2);
360
                        if (count > length) {
361
                            count = length;
362
                        }
363
                        value = 0;
364
                        errorString = "hexadecimal";
365
                        if (cmd == 'H') {
366
                            for (offset = 0; offset < count; offset++) {
367
                                value <<= 4;
368
                                c = tolower(((unsigned char *) str)[offset]);
369
                                if ((c >= 'a') && (c <= 'f')) {
370
                                    value |= ((c - 'a' + 10) & 0xf);
371
                                } else if ((c >= '0') && (c <= '9')) {
372
                                    value |= (c - '0') & 0xf;
373
                                } else {
374
                                    errorValue = str;
375
                                    goto badValue;
376
                                }
377
                                if (offset % 2) {
378
                                    *cursor++ = (char) value;
379
                                    value = 0;
380
                                }
381
                            }
382
                        } else {
383
                            for (offset = 0; offset < count; offset++) {
384
                                value >>= 4;
385
                                c = tolower(((unsigned char *) str)[offset]);
386
                                if ((c >= 'a') && (c <= 'f')) {
387
                                    value |= ((c - 'a' + 10) << 4) & 0xf0;
388
                                } else if ((c >= '0') && (c <= '9')) {
389
                                    value |= ((c - '0') << 4) & 0xf0;
390
                                } else {
391
                                    errorValue = str;
392
                                    goto badValue;
393
                                }
394
                                if (offset % 2) {
395
                                    *cursor++ = (char)(value & 0xff);
396
                                    value = 0;
397
                                }
398
                            }
399
                        }
400
                        if (offset % 2) {
401
                            if (cmd == 'H') {
402
                                value <<= 4;
403
                            } else {
404
                                value >>= 4;
405
                            }
406
                            *cursor++ = (char) value;
407
                        }
408
 
409
                        while (cursor < last) {
410
                            *cursor++ = '\0';
411
                        }
412
                        break;
413
                    }
414
                    case 'c':
415
                    case 's':
416
                    case 'S':
417
                    case 'i':
418
                    case 'I':
419
                    case 'd':
420
                    case 'f': {
421
                        int listc, i;
422
                        Tcl_Obj **listv;
423
 
424
                        if (count == BINARY_NOCOUNT) {
425
                            /*
426
                             * Note that we are casting away the const-ness of
427
                             * objv, but this is safe since we aren't going to
428
                             * modify the array.
429
                             */
430
 
431
                            listv = (Tcl_Obj**)(objv + arg);
432
                            listc = 1;
433
                            count = 1;
434
                        } else {
435
                            Tcl_ListObjGetElements(interp, objv[arg],
436
                                    &listc, &listv);
437
                            if (count == BINARY_ALL) {
438
                                count = listc;
439
                            }
440
                        }
441
                        arg++;
442
                        for (i = 0; i < count; i++) {
443
                            if (FormatNumber(interp, cmd, listv[i], &cursor)
444
                                    != TCL_OK) {
445
                                return TCL_ERROR;
446
                            }
447
                        }
448
                        break;
449
                    }
450
                    case 'x':
451
                        if (count == BINARY_NOCOUNT) {
452
                            count = 1;
453
                        }
454
                        memset(cursor, 0, (size_t) count);
455
                        cursor += count;
456
                        break;
457
                    case 'X':
458
                        if (cursor > maxPos) {
459
                            maxPos = cursor;
460
                        }
461
                        if (count == BINARY_NOCOUNT) {
462
                            count = 1;
463
                        }
464
                        if ((count == BINARY_ALL)
465
                                || (count > (cursor - buffer))) {
466
                            cursor = buffer;
467
                        } else {
468
                            cursor -= count;
469
                        }
470
                        break;
471
                    case '@':
472
                        if (cursor > maxPos) {
473
                            maxPos = cursor;
474
                        }
475
                        if (count == BINARY_ALL) {
476
                            cursor = maxPos;
477
                        } else {
478
                            cursor = buffer + count;
479
                        }
480
                        break;
481
                }
482
            }
483
            break;
484
 
485
        case BinaryScan: {
486
            int i;
487
            Tcl_Obj *valuePtr, *elementPtr;
488
 
489
            if (objc < 4) {
490
                Tcl_WrongNumArgs(interp, 2, objv,
491
                        "value formatString ?varName varName ...?");
492
                return TCL_ERROR;
493
            }
494
            buffer = Tcl_GetStringFromObj(objv[2], &length);
495
            format = Tcl_GetStringFromObj(objv[3], NULL);
496
            cursor = buffer;
497
            arg = 4;
498
            offset = 0;
499
            while (*format != 0) {
500
                if (!GetFormatSpec(&format, &cmd, &count)) {
501
                    goto done;
502
                }
503
                switch (cmd) {
504
                    case 'a':
505
                    case 'A':
506
                        if (arg >= objc) {
507
                            goto badIndex;
508
                        }
509
                        if (count == BINARY_ALL) {
510
                            count = length - offset;
511
                        } else {
512
                            if (count == BINARY_NOCOUNT) {
513
                                count = 1;
514
                            }
515
                            if (count > (length - offset)) {
516
                                goto done;
517
                            }
518
                        }
519
 
520
                        str = buffer + offset;
521
                        size = count;
522
 
523
                        /*
524
                         * Trim trailing nulls and spaces, if necessary.
525
                         */
526
 
527
                        if (cmd == 'A') {
528
                            while (size > 0) {
529
                                if (str[size-1] != '\0' && str[size-1] != ' ') {
530
                                    break;
531
                                }
532
                                size--;
533
                            }
534
                        }
535
                        valuePtr = Tcl_NewStringObj(str, size);
536
                        resultPtr = Tcl_ObjSetVar2(interp, objv[arg++], NULL,
537
                                valuePtr,
538
                                TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1);
539
                        if (resultPtr == NULL) {
540
                            Tcl_DecrRefCount(valuePtr); /* unneeded */
541
                            return TCL_ERROR;
542
                        }
543
                        offset += count;
544
                        break;
545
                    case 'b':
546
                    case 'B': {
547
                        char *dest;
548
 
549
                        if (arg >= objc) {
550
                            goto badIndex;
551
                        }
552
                        if (count == BINARY_ALL) {
553
                            count = (length - offset)*8;
554
                        } else {
555
                            if (count == BINARY_NOCOUNT) {
556
                                count = 1;
557
                            }
558
                            if (count > (length - offset)*8) {
559
                                goto done;
560
                            }
561
                        }
562
                        str = buffer + offset;
563
                        valuePtr = Tcl_NewObj();
564
                        Tcl_SetObjLength(valuePtr, count);
565
                        dest = Tcl_GetStringFromObj(valuePtr, NULL);
566
 
567
                        if (cmd == 'b') {
568
                            for (i = 0; i < count; i++) {
569
                                if (i % 8) {
570
                                    value >>= 1;
571
                                } else {
572
                                    value = *str++;
573
                                }
574
                                *dest++ = (char) ((value & 1) ? '1' : '0');
575
                            }
576
                        } else {
577
                            for (i = 0; i < count; i++) {
578
                                if (i % 8) {
579
                                    value <<= 1;
580
                                } else {
581
                                    value = *str++;
582
                                }
583
                                *dest++ = (char) ((value & 0x80) ? '1' : '0');
584
                            }
585
                        }
586
 
587
                        resultPtr = Tcl_ObjSetVar2(interp, objv[arg++], NULL,
588
                                valuePtr,
589
                                TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1);
590
                        if (resultPtr == NULL) {
591
                            Tcl_DecrRefCount(valuePtr); /* unneeded */
592
                            return TCL_ERROR;
593
                        }
594
                        offset += (count + 7 ) / 8;
595
                        break;
596
                    }
597
                    case 'h':
598
                    case 'H': {
599
                        char *dest;
600
                        int i;
601
                        static char hexdigit[] = "0123456789abcdef";
602
 
603
                        if (arg >= objc) {
604
                            goto badIndex;
605
                        }
606
                        if (count == BINARY_ALL) {
607
                            count = (length - offset)*2;
608
                        } else {
609
                            if (count == BINARY_NOCOUNT) {
610
                                count = 1;
611
                            }
612
                            if (count > (length - offset)*2) {
613
                                goto done;
614
                            }
615
                        }
616
                        str = buffer + offset;
617
                        valuePtr = Tcl_NewObj();
618
                        Tcl_SetObjLength(valuePtr, count);
619
                        dest = Tcl_GetStringFromObj(valuePtr, NULL);
620
 
621
                        if (cmd == 'h') {
622
                            for (i = 0; i < count; i++) {
623
                                if (i % 2) {
624
                                    value >>= 4;
625
                                } else {
626
                                    value = *str++;
627
                                }
628
                                *dest++ = hexdigit[value & 0xf];
629
                            }
630
                        } else {
631
                            for (i = 0; i < count; i++) {
632
                                if (i % 2) {
633
                                    value <<= 4;
634
                                } else {
635
                                    value = *str++;
636
                                }
637
                                *dest++ = hexdigit[(value >> 4) & 0xf];
638
                            }
639
                        }
640
 
641
                        resultPtr = Tcl_ObjSetVar2(interp, objv[arg++], NULL,
642
                                valuePtr,
643
                                TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1);
644
                        if (resultPtr == NULL) {
645
                            Tcl_DecrRefCount(valuePtr); /* unneeded */
646
                            return TCL_ERROR;
647
                        }
648
                        offset += (count + 1) / 2;
649
                        break;
650
                    }
651
                    case 'c':
652
                        size = 1;
653
                        goto scanNumber;
654
                    case 's':
655
                    case 'S':
656
                        size = 2;
657
                        goto scanNumber;
658
                    case 'i':
659
                    case 'I':
660
                        size = 4;
661
                        goto scanNumber;
662
                    case 'f':
663
                        size = sizeof(float);
664
                        goto scanNumber;
665
                    case 'd':
666
                        size = sizeof(double);
667
                        /* fall through */
668
                    scanNumber:
669
                        if (arg >= objc) {
670
                            goto badIndex;
671
                        }
672
                        if (count == BINARY_NOCOUNT) {
673
                            if ((length - offset) < size) {
674
                                goto done;
675
                            }
676
                            valuePtr = ScanNumber(buffer+offset, cmd);
677
                            offset += size;
678
                        } else {
679
                            if (count == BINARY_ALL) {
680
                                count = (length - offset) / size;
681
                            }
682
                            if ((length - offset) < (count * size)) {
683
                                goto done;
684
                            }
685
                            valuePtr = Tcl_NewObj();
686
                            str = buffer+offset;
687
                            for (i = 0; i < count; i++) {
688
                                elementPtr = ScanNumber(str, cmd);
689
                                str += size;
690
                                Tcl_ListObjAppendElement(NULL, valuePtr,
691
                                        elementPtr);
692
                            }
693
                            offset += count*size;
694
                        }
695
 
696
                        resultPtr = Tcl_ObjSetVar2(interp, objv[arg++], NULL,
697
                                valuePtr,
698
                                TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1);
699
                        if (resultPtr == NULL) {
700
                            Tcl_DecrRefCount(valuePtr); /* unneeded */
701
                            return TCL_ERROR;
702
                        }
703
                        break;
704
                    case 'x':
705
                        if (count == BINARY_NOCOUNT) {
706
                            count = 1;
707
                        }
708
                        if ((count == BINARY_ALL)
709
                                || (count > (length - offset))) {
710
                            offset = length;
711
                        } else {
712
                            offset += count;
713
                        }
714
                        break;
715
                    case 'X':
716
                        if (count == BINARY_NOCOUNT) {
717
                            count = 1;
718
                        }
719
                        if ((count == BINARY_ALL) || (count > offset)) {
720
                            offset = 0;
721
                        } else {
722
                            offset -= count;
723
                        }
724
                        break;
725
                    case '@':
726
                        if (count == BINARY_NOCOUNT) {
727
                            goto badCount;
728
                        }
729
                        if ((count == BINARY_ALL) || (count > length)) {
730
                            offset = length;
731
                        } else {
732
                            offset = count;
733
                        }
734
                        break;
735
                    default: {
736
                        char buf[2];
737
 
738
                        Tcl_ResetResult(interp);
739
                        buf[0] = cmd;
740
                        buf[1] = '\0';
741
                        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
742
                                "bad field specifier \"", buf, "\"", NULL);
743
                        return TCL_ERROR;
744
                    }
745
                }
746
            }
747
 
748
            /*
749
             * Set the result to the last position of the cursor.
750
             */
751
 
752
            done:
753
            Tcl_ResetResult(interp);
754
            Tcl_SetLongObj(Tcl_GetObjResult(interp), arg - 4);
755
            break;
756
        }
757
    }
758
    return TCL_OK;
759
 
760
    badValue:
761
    Tcl_ResetResult(interp);
762
    Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "expected ", errorString,
763
            " string but got \"", errorValue, "\" instead", NULL);
764
    return TCL_ERROR;
765
 
766
    badCount:
767
    errorString = "missing count for \"@\" field specifier";
768
    goto error;
769
 
770
    badIndex:
771
    errorString = "not enough arguments for all format specifiers";
772
    goto error;
773
 
774
    error:
775
    Tcl_ResetResult(interp);
776
    Tcl_AppendToObj(Tcl_GetObjResult(interp), errorString, -1);
777
    return TCL_ERROR;
778
}
779
 
780
/*
781
 *----------------------------------------------------------------------
782
 *
783
 * GetFormatSpec --
784
 *
785
 *      This function parses the format strings used in the binary
786
 *      format and scan commands.
787
 *
788
 * Results:
789
 *      Moves the formatPtr to the start of the next command. Returns
790
 *      the current command character and count in cmdPtr and countPtr.
791
 *      The count is set to BINARY_ALL if the count character was '*'
792
 *      or BINARY_NOCOUNT if no count was specified.  Returns 1 on
793
 *      success, or 0 if the string did not have a format specifier.
794
 *
795
 * Side effects:
796
 *      None.
797
 *
798
 *----------------------------------------------------------------------
799
 */
800
 
801
static int
802
GetFormatSpec(formatPtr, cmdPtr, countPtr)
803
    char **formatPtr;           /* Pointer to format string. */
804
    char *cmdPtr;               /* Pointer to location of command char. */
805
    int *countPtr;              /* Pointer to repeat count value. */
806
{
807
    /*
808
     * Skip any leading blanks.
809
     */
810
 
811
    while (**formatPtr == ' ') {
812
        (*formatPtr)++;
813
    }
814
 
815
    /*
816
     * The string was empty, except for whitespace, so fail.
817
     */
818
 
819
    if (!(**formatPtr)) {
820
        return 0;
821
    }
822
 
823
    /*
824
     * Extract the command character and any trailing digits or '*'.
825
     */
826
 
827
    *cmdPtr = **formatPtr;
828
    (*formatPtr)++;
829
    if (**formatPtr == '*') {
830
        (*formatPtr)++;
831
        (*countPtr) = BINARY_ALL;
832
    } else if (isdigit(UCHAR(**formatPtr))) {
833
        (*countPtr) = strtoul(*formatPtr, formatPtr, 10);
834
    } else {
835
        (*countPtr) = BINARY_NOCOUNT;
836
    }
837
    return 1;
838
}
839
 
840
/*
841
 *----------------------------------------------------------------------
842
 *
843
 * FormatNumber --
844
 *
845
 *      This routine is called by Tcl_BinaryObjCmd to format a number
846
 *      into a location pointed at by cursor.
847
 *
848
 * Results:
849
 *       A standard Tcl result.
850
 *
851
 * Side effects:
852
 *      Moves the cursor to the next location to be written into.
853
 *
854
 *----------------------------------------------------------------------
855
 */
856
 
857
static int
858
FormatNumber(interp, type, src, cursorPtr)
859
    Tcl_Interp *interp;         /* Current interpreter, used to report
860
                                 * errors. */
861
    int type;                   /* Type of number to format. */
862
    Tcl_Obj *src;               /* Number to format. */
863
    char **cursorPtr;           /* Pointer to index into destination buffer. */
864
{
865
    int value;
866
    double dvalue;
867
    char cmd = (char)type;
868
 
869
    if (cmd == 'd' || cmd == 'f') {
870
        /*
871
         * For floating point types, we need to copy the data using
872
         * memcpy to avoid alignment issues.
873
         */
874
 
875
        if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) {
876
            return TCL_ERROR;
877
        }
878
        if (cmd == 'd') {
879
            memcpy((*cursorPtr), &dvalue, sizeof(double));
880
            (*cursorPtr) += sizeof(double);
881
        } else {
882
            float fvalue;
883
 
884
            /*
885
             * Because some compilers will generate floating point exceptions
886
             * on an overflow cast (e.g. Borland), we restrict the values
887
             * to the valid range for float.
888
             */
889
 
890
            if (fabs(dvalue) > (double)FLT_MAX) {
891
                fvalue = (dvalue >= 0.0) ? FLT_MAX : -FLT_MAX;
892
            } else {
893
                fvalue = (float) dvalue;
894
            }
895
            memcpy((*cursorPtr), &fvalue, sizeof(float));
896
            (*cursorPtr) += sizeof(float);
897
        }
898
    } else {
899
        if (Tcl_GetIntFromObj(interp, src, &value) != TCL_OK) {
900
            return TCL_ERROR;
901
        }
902
        if (cmd == 'c') {
903
            *(*cursorPtr)++ = (char)(value & 0xff);
904
        } else if (cmd == 's') {
905
            *(*cursorPtr)++ = (char)(value & 0xff);
906
            *(*cursorPtr)++ = (char)((value >> 8) & 0xff);
907
        } else if (cmd == 'S') {
908
            *(*cursorPtr)++ = (char)((value >> 8) & 0xff);
909
            *(*cursorPtr)++ = (char)(value & 0xff);
910
        } else if (cmd == 'i') {
911
            *(*cursorPtr)++ = (char)(value & 0xff);
912
            *(*cursorPtr)++ = (char)((value >> 8) & 0xff);
913
            *(*cursorPtr)++ = (char)((value >> 16) & 0xff);
914
            *(*cursorPtr)++ = (char)((value >> 24) & 0xff);
915
        } else if (cmd == 'I') {
916
            *(*cursorPtr)++ = (char)((value >> 24) & 0xff);
917
            *(*cursorPtr)++ = (char)((value >> 16) & 0xff);
918
            *(*cursorPtr)++ = (char)((value >> 8) & 0xff);
919
            *(*cursorPtr)++ = (char)(value & 0xff);
920
        }
921
    }
922
    return TCL_OK;
923
}
924
 
925
/*
926
 *----------------------------------------------------------------------
927
 *
928
 * ScanNumber --
929
 *
930
 *      This routine is called by Tcl_BinaryObjCmd to scan a number
931
 *      out of a buffer.
932
 *
933
 * Results:
934
 *      Returns a newly created object containing the scanned number.
935
 *      This object has a ref count of zero.
936
 *
937
 * Side effects:
938
 *      None.
939
 *
940
 *----------------------------------------------------------------------
941
 */
942
 
943
static Tcl_Obj *
944
ScanNumber(buffer, type)
945
    char *buffer;               /* Buffer to scan number from. */
946
    int type;                   /* Format character from "binary scan" */
947
{
948
    int value;
949
 
950
    /*
951
     * We cannot rely on the compiler to properly sign extend integer values
952
     * when we cast from smaller values to larger values because we don't know
953
     * the exact size of the integer types.  So, we have to handle sign
954
     * extension explicitly by checking the high bit and padding with 1's as
955
     * needed.
956
     */
957
 
958
    switch ((char) type) {
959
        case 'c':
960
            value = buffer[0];
961
 
962
            if (value & 0x80) {
963
                value |= -0x100;
964
            }
965
            return Tcl_NewLongObj((long)value);
966
        case 's':
967
            value = (((unsigned char)buffer[0])
968
                    + ((unsigned char)buffer[1] << 8));
969
            goto shortValue;
970
        case 'S':
971
            value = (((unsigned char)buffer[1])
972
                    + ((unsigned char)buffer[0] << 8));
973
            shortValue:
974
            if (value & 0x8000) {
975
                value |= -0x10000;
976
            }
977
            return Tcl_NewLongObj((long)value);
978
        case 'i':
979
            value =  (((unsigned char)buffer[0])
980
                    + ((unsigned char)buffer[1] << 8)
981
                    + ((unsigned char)buffer[2] << 16)
982
                    + ((unsigned char)buffer[3] << 24));
983
            goto intValue;
984
        case 'I':
985
            value = (((unsigned char)buffer[3])
986
                    + ((unsigned char)buffer[2] << 8)
987
                    + ((unsigned char)buffer[1] << 16)
988
                    + ((unsigned char)buffer[0] << 24));
989
            intValue:
990
            /*
991
             * Check to see if the value was sign extended properly on
992
             * systems where an int is more than 32-bits.
993
             */
994
 
995
            if ((value & (((unsigned int)1)<<31)) && (value > 0)) {
996
                value -= (((unsigned int)1)<<31);
997
                value -= (((unsigned int)1)<<31);
998
            }
999
 
1000
            return Tcl_NewLongObj((long)value);
1001
        case 'f': {
1002
            float fvalue;
1003
            memcpy(&fvalue, buffer, sizeof(float));
1004
            return Tcl_NewDoubleObj(fvalue);
1005
        }
1006
        case 'd': {
1007
            double dvalue;
1008
            memcpy(&dvalue, buffer, sizeof(double));
1009
            return Tcl_NewDoubleObj(dvalue);
1010
        }
1011
    }
1012
    return NULL;
1013
}

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.