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

Subversion Repositories or1k

[/] [or1k/] [trunk/] [insight/] [tcl/] [generic/] [tclParse.c] - Blame information for rev 578

Go to most recent revision | Details | Compare with Previous | View Log

Line No. Rev Author Line
1 578 markom
/*
2
 * tclParse.c --
3
 *
4
 *      This file contains a collection of procedures that are used
5
 *      to parse Tcl commands or parts of commands (like quoted
6
 *      strings or nested sub-commands).
7
 *
8
 * Copyright (c) 1987-1993 The Regents of the University of California.
9
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
10
 *
11
 * See the file "license.terms" for information on usage and redistribution
12
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
13
 *
14
 * RCS: @(#) $Id: tclParse.c,v 1.1.1.1 2002-01-16 10:25:28 markom Exp $
15
 */
16
 
17
#include "tclInt.h"
18
#include "tclPort.h"
19
 
20
/*
21
 * Function prototypes for procedures local to this file:
22
 */
23
 
24
static char *   QuoteEnd _ANSI_ARGS_((char *string, char *lastChar,
25
                    int term));
26
static char *   ScriptEnd _ANSI_ARGS_((char *p, char *lastChar,
27
                    int nested));
28
static char *   VarNameEnd _ANSI_ARGS_((char *string,  char *lastChar));
29
 
30
/*
31
 *--------------------------------------------------------------
32
 *
33
 * TclParseQuotes --
34
 *
35
 *      This procedure parses a double-quoted string such as a
36
 *      quoted Tcl command argument or a quoted value in a Tcl
37
 *      expression.  This procedure is also used to parse array
38
 *      element names within parentheses, or anything else that
39
 *      needs all the substitutions that happen in quotes.
40
 *
41
 * Results:
42
 *      The return value is a standard Tcl result, which is
43
 *      TCL_OK unless there was an error while parsing the
44
 *      quoted string.  If an error occurs then interp->result
45
 *      contains a standard error message.  *TermPtr is filled
46
 *      in with the address of the character just after the
47
 *      last one successfully processed;  this is usually the
48
 *      character just after the matching close-quote.  The
49
 *      fully-substituted contents of the quotes are stored in
50
 *      standard fashion in *pvPtr, null-terminated with
51
 *      pvPtr->next pointing to the terminating null character.
52
 *
53
 * Side effects:
54
 *      The buffer space in pvPtr may be enlarged by calling its
55
 *      expandProc.
56
 *
57
 *--------------------------------------------------------------
58
 */
59
 
60
int
61
TclParseQuotes(interp, string, termChar, flags, termPtr, pvPtr)
62
    Tcl_Interp *interp;         /* Interpreter to use for nested command
63
                                 * evaluations and error messages. */
64
    char *string;               /* Character just after opening double-
65
                                 * quote. */
66
    int termChar;               /* Character that terminates "quoted" string
67
                                 * (usually double-quote, but sometimes
68
                                 * right-paren or something else). */
69
    int flags;                  /* Flags to pass to nested Tcl_Eval calls. */
70
    char **termPtr;             /* Store address of terminating character
71
                                 * here. */
72
    ParseValue *pvPtr;          /* Information about where to place
73
                                 * fully-substituted result of parse. */
74
{
75
    register char *src, *dst, c;
76
    char *lastChar = string + strlen(string);
77
 
78
    src = string;
79
    dst = pvPtr->next;
80
 
81
    while (1) {
82
        if (dst == pvPtr->end) {
83
            /*
84
             * Target buffer space is about to run out.  Make more space.
85
             */
86
 
87
            pvPtr->next = dst;
88
            (*pvPtr->expandProc)(pvPtr, 1);
89
            dst = pvPtr->next;
90
        }
91
 
92
        c = *src;
93
        src++;
94
        if (c == termChar) {
95
            *dst = '\0';
96
            pvPtr->next = dst;
97
            *termPtr = src;
98
            return TCL_OK;
99
        } else if (CHAR_TYPE(src-1, lastChar) == TCL_NORMAL) {
100
            copy:
101
            *dst = c;
102
            dst++;
103
            continue;
104
        } else if (c == '$') {
105
            int length;
106
            char *value;
107
 
108
            value = Tcl_ParseVar(interp, src-1, termPtr);
109
            if (value == NULL) {
110
                return TCL_ERROR;
111
            }
112
            src = *termPtr;
113
            length = strlen(value);
114
            if ((pvPtr->end - dst) <= length) {
115
                pvPtr->next = dst;
116
                (*pvPtr->expandProc)(pvPtr, length);
117
                dst = pvPtr->next;
118
            }
119
            strcpy(dst, value);
120
            dst += length;
121
            continue;
122
        } else if (c == '[') {
123
            int result;
124
 
125
            pvPtr->next = dst;
126
            result = TclParseNestedCmd(interp, src, flags, termPtr, pvPtr);
127
            if (result != TCL_OK) {
128
                return result;
129
            }
130
            src = *termPtr;
131
            dst = pvPtr->next;
132
            continue;
133
        } else if (c == '\\') {
134
            int numRead;
135
 
136
            src--;
137
            *dst = Tcl_Backslash(src, &numRead);
138
            dst++;
139
            src += numRead;
140
            continue;
141
        } else if (c == '\0') {
142
            char buf[30];
143
 
144
            Tcl_ResetResult(interp);
145
            sprintf(buf, "missing %c", termChar);
146
            Tcl_SetResult(interp, buf, TCL_VOLATILE);
147
            *termPtr = string-1;
148
            return TCL_ERROR;
149
        } else {
150
            goto copy;
151
        }
152
    }
153
}
154
 
155
/*
156
 *--------------------------------------------------------------
157
 *
158
 * TclParseNestedCmd --
159
 *
160
 *      This procedure parses a nested Tcl command between
161
 *      brackets, returning the result of the command.
162
 *
163
 * Results:
164
 *      The return value is a standard Tcl result, which is
165
 *      TCL_OK unless there was an error while executing the
166
 *      nested command.  If an error occurs then interp->result
167
 *      contains a standard error message.  *TermPtr is filled
168
 *      in with the address of the character just after the
169
 *      last one processed;  this is usually the character just
170
 *      after the matching close-bracket, or the null character
171
 *      at the end of the string if the close-bracket was missing
172
 *      (a missing close bracket is an error).  The result returned
173
 *      by the command is stored in standard fashion in *pvPtr,
174
 *      null-terminated, with pvPtr->next pointing to the null
175
 *      character.
176
 *
177
 * Side effects:
178
 *      The storage space at *pvPtr may be expanded.
179
 *
180
 *--------------------------------------------------------------
181
 */
182
 
183
int
184
TclParseNestedCmd(interp, string, flags, termPtr, pvPtr)
185
    Tcl_Interp *interp;         /* Interpreter to use for nested command
186
                                 * evaluations and error messages. */
187
    char *string;               /* Character just after opening bracket. */
188
    int flags;                  /* Flags to pass to nested Tcl_Eval. */
189
    char **termPtr;             /* Store address of terminating character
190
                                 * here. */
191
    register ParseValue *pvPtr; /* Information about where to place
192
                                 * result of command. */
193
{
194
    int result, length, shortfall;
195
    Interp *iPtr = (Interp *) interp;
196
 
197
    iPtr->evalFlags = flags | TCL_BRACKET_TERM;
198
    result = Tcl_Eval(interp, string);
199
    *termPtr = (string + iPtr->termOffset);
200
    if (result != TCL_OK) {
201
        /*
202
         * The increment below results in slightly cleaner message in
203
         * the errorInfo variable (the close-bracket will appear).
204
         */
205
 
206
        if (**termPtr == ']') {
207
            *termPtr += 1;
208
        }
209
        return result;
210
    }
211
    (*termPtr) += 1;
212
    length = strlen(iPtr->result);
213
    shortfall = length + 1 - (pvPtr->end - pvPtr->next);
214
    if (shortfall > 0) {
215
        (*pvPtr->expandProc)(pvPtr, shortfall);
216
    }
217
    strcpy(pvPtr->next, iPtr->result);
218
    pvPtr->next += length;
219
 
220
    Tcl_FreeResult(interp);
221
    iPtr->result = iPtr->resultSpace;
222
    iPtr->resultSpace[0] = '\0';
223
    return TCL_OK;
224
}
225
 
226
/*
227
 *--------------------------------------------------------------
228
 *
229
 * TclParseBraces --
230
 *
231
 *      This procedure scans the information between matching
232
 *      curly braces.
233
 *
234
 * Results:
235
 *      The return value is a standard Tcl result, which is
236
 *      TCL_OK unless there was an error while parsing string.
237
 *      If an error occurs then interp->result contains a
238
 *      standard error message.  *TermPtr is filled
239
 *      in with the address of the character just after the
240
 *      last one successfully processed;  this is usually the
241
 *      character just after the matching close-brace.  The
242
 *      information between curly braces is stored in standard
243
 *      fashion in *pvPtr, null-terminated with pvPtr->next
244
 *      pointing to the terminating null character.
245
 *
246
 * Side effects:
247
 *      The storage space at *pvPtr may be expanded.
248
 *
249
 *--------------------------------------------------------------
250
 */
251
 
252
int
253
TclParseBraces(interp, string, termPtr, pvPtr)
254
    Tcl_Interp *interp;         /* Interpreter to use for nested command
255
                                 * evaluations and error messages. */
256
    char *string;               /* Character just after opening bracket. */
257
    char **termPtr;             /* Store address of terminating character
258
                                 * here. */
259
    register ParseValue *pvPtr; /* Information about where to place
260
                                 * result of command. */
261
{
262
    int level;
263
    register char *src, *dst, *end;
264
    register char c;
265
    char *lastChar = string + strlen(string);
266
 
267
    src = string;
268
    dst = pvPtr->next;
269
    end = pvPtr->end;
270
    level = 1;
271
 
272
    /*
273
     * Copy the characters one at a time to the result area, stopping
274
     * when the matching close-brace is found.
275
     */
276
 
277
    while (1) {
278
        c = *src;
279
        src++;
280
        if (dst == end) {
281
            pvPtr->next = dst;
282
            (*pvPtr->expandProc)(pvPtr, 20);
283
            dst = pvPtr->next;
284
            end = pvPtr->end;
285
        }
286
        *dst = c;
287
        dst++;
288
        if (CHAR_TYPE(src-1, lastChar) == TCL_NORMAL) {
289
            continue;
290
        } else if (c == '{') {
291
            level++;
292
        } else if (c == '}') {
293
            level--;
294
            if (level == 0) {
295
                dst--;                  /* Don't copy the last close brace. */
296
                break;
297
            }
298
        } else if (c == '\\') {
299
            int count;
300
 
301
            /*
302
             * Must always squish out backslash-newlines, even when in
303
             * braces.  This is needed so that this sequence can appear
304
             * anywhere in a command, such as the middle of an expression.
305
             */
306
 
307
            if (*src == '\n') {
308
                dst[-1] = Tcl_Backslash(src-1, &count);
309
                src += count - 1;
310
            } else {
311
                (void) Tcl_Backslash(src-1, &count);
312
                while (count > 1) {
313
                    if (dst == end) {
314
                        pvPtr->next = dst;
315
                        (*pvPtr->expandProc)(pvPtr, 20);
316
                        dst = pvPtr->next;
317
                        end = pvPtr->end;
318
                    }
319
                    *dst = *src;
320
                    dst++;
321
                    src++;
322
                    count--;
323
                }
324
            }
325
        } else if (c == '\0') {
326
            Tcl_SetResult(interp, "missing close-brace", TCL_STATIC);
327
            *termPtr = string-1;
328
            return TCL_ERROR;
329
        }
330
    }
331
 
332
    *dst = '\0';
333
    pvPtr->next = dst;
334
    *termPtr = src;
335
    return TCL_OK;
336
}
337
 
338
/*
339
 *--------------------------------------------------------------
340
 *
341
 * TclExpandParseValue --
342
 *
343
 *      This procedure is commonly used as the value of the
344
 *      expandProc in a ParseValue.  It uses malloc to allocate
345
 *      more space for the result of a parse.
346
 *
347
 * Results:
348
 *      The buffer space in *pvPtr is reallocated to something
349
 *      larger, and if pvPtr->clientData is non-zero the old
350
 *      buffer is freed.  Information is copied from the old
351
 *      buffer to the new one.
352
 *
353
 * Side effects:
354
 *      None.
355
 *
356
 *--------------------------------------------------------------
357
 */
358
 
359
void
360
TclExpandParseValue(pvPtr, needed)
361
    register ParseValue *pvPtr;         /* Information about buffer that
362
                                         * must be expanded.  If the clientData
363
                                         * in the structure is non-zero, it
364
                                         * means that the current buffer is
365
                                         * dynamically allocated. */
366
    int needed;                         /* Minimum amount of additional space
367
                                         * to allocate. */
368
{
369
    int newSpace;
370
    char *new;
371
 
372
    /*
373
     * Either double the size of the buffer or add enough new space
374
     * to meet the demand, whichever produces a larger new buffer.
375
     */
376
 
377
    newSpace = (pvPtr->end - pvPtr->buffer) + 1;
378
    if (newSpace < needed) {
379
        newSpace += needed;
380
    } else {
381
        newSpace += newSpace;
382
    }
383
    new = (char *) ckalloc((unsigned) newSpace);
384
 
385
    /*
386
     * Copy from old buffer to new, free old buffer if needed, and
387
     * mark new buffer as malloc-ed.
388
     */
389
 
390
    memcpy((VOID *) new, (VOID *) pvPtr->buffer,
391
            (size_t) (pvPtr->next - pvPtr->buffer));
392
    pvPtr->next = new + (pvPtr->next - pvPtr->buffer);
393
    if (pvPtr->clientData != 0) {
394
        ckfree(pvPtr->buffer);
395
    }
396
    pvPtr->buffer = new;
397
    pvPtr->end = new + newSpace - 1;
398
    pvPtr->clientData = (ClientData) 1;
399
}
400
 
401
/*
402
 *----------------------------------------------------------------------
403
 *
404
 * TclWordEnd --
405
 *
406
 *      Given a pointer into a Tcl command, find the end of the next
407
 *      word of the command.
408
 *
409
 * Results:
410
 *      The return value is a pointer to the last character that's part
411
 *      of the word pointed to by "start".  If the word doesn't end
412
 *      properly within the string then the return value is the address
413
 *      of the null character at the end of the string.
414
 *
415
 * Side effects:
416
 *      None.
417
 *
418
 *----------------------------------------------------------------------
419
 */
420
 
421
char *
422
TclWordEnd(start, lastChar, nested, semiPtr)
423
    char *start;                /* Beginning of a word of a Tcl command. */
424
    char *lastChar;             /* Terminating character in string. */
425
    int nested;                 /* Zero means this is a top-level command.
426
                                 * One means this is a nested command (close
427
                                 * bracket is a word terminator). */
428
    int *semiPtr;               /* Set to 1 if word ends with a command-
429
                                 * terminating semi-colon, zero otherwise.
430
                                 * If NULL then ignored. */
431
{
432
    register char *p;
433
    int count;
434
 
435
    if (semiPtr != NULL) {
436
        *semiPtr = 0;
437
    }
438
 
439
    /*
440
     * Skip leading white space (backslash-newline must be treated like
441
     * white-space, except that it better not be the last thing in the
442
     * command).
443
     */
444
 
445
    for (p = start; ; p++) {
446
        if (isspace(UCHAR(*p))) {
447
            continue;
448
        }
449
        if ((p[0] == '\\') && (p[1] == '\n')) {
450
            if (p+2 == lastChar) {
451
                return p+2;
452
            }
453
            continue;
454
        }
455
        break;
456
    }
457
 
458
    /*
459
     * Handle words beginning with a double-quote or a brace.
460
     */
461
 
462
    if (*p == '"') {
463
        p = QuoteEnd(p+1, lastChar, '"');
464
        if (p == lastChar) {
465
            return p;
466
        }
467
        p++;
468
    } else if (*p == '{') {
469
        int braces = 1;
470
        while (braces != 0) {
471
            p++;
472
            while (*p == '\\') {
473
                (void) Tcl_Backslash(p, &count);
474
                p += count;
475
            }
476
            if (*p == '}') {
477
                braces--;
478
            } else if (*p == '{') {
479
                braces++;
480
            } else if (p == lastChar) {
481
                return p;
482
            }
483
        }
484
        p++;
485
    }
486
 
487
    /*
488
     * Handle words that don't start with a brace or double-quote.
489
     * This code is also invoked if the word starts with a brace or
490
     * double-quote and there is garbage after the closing brace or
491
     * quote.  This is an error as far as Tcl_Eval is concerned, but
492
     * for here the garbage is treated as part of the word.
493
     */
494
 
495
    while (1) {
496
        if (*p == '[') {
497
            p = ScriptEnd(p+1, lastChar, 1);
498
            if (p == lastChar) {
499
                return p;
500
            }
501
            p++;
502
        } else if (*p == '\\') {
503
            if (p[1] == '\n') {
504
                /*
505
                 * Backslash-newline:  it maps to a space character
506
                 * that is a word separator, so the word ends just before
507
                 * the backslash.
508
                 */
509
 
510
                return p-1;
511
            }
512
            (void) Tcl_Backslash(p, &count);
513
            p += count;
514
        } else if (*p == '$') {
515
            p = VarNameEnd(p, lastChar);
516
            if (p == lastChar) {
517
                return p;
518
            }
519
            p++;
520
        } else if (*p == ';') {
521
            /*
522
             * Include the semi-colon in the word that is returned.
523
             */
524
 
525
            if (semiPtr != NULL) {
526
                *semiPtr = 1;
527
            }
528
            return p;
529
        } else if (isspace(UCHAR(*p))) {
530
            return p-1;
531
        } else if ((*p == ']') && nested) {
532
            return p-1;
533
        } else if (p == lastChar) {
534
            if (nested) {
535
                /*
536
                 * Nested commands can't end because of the end of the
537
                 * string.
538
                 */
539
                return p;
540
            }
541
            return p-1;
542
        } else {
543
            p++;
544
        }
545
    }
546
}
547
 
548
/*
549
 *----------------------------------------------------------------------
550
 *
551
 * QuoteEnd --
552
 *
553
 *      Given a pointer to a string that obeys the parsing conventions
554
 *      for quoted things in Tcl, find the end of that quoted thing.
555
 *      The actual thing may be a quoted argument or a parenthesized
556
 *      index name.
557
 *
558
 * Results:
559
 *      The return value is a pointer to the last character that is
560
 *      part of the quoted string (i.e the character that's equal to
561
 *      term).  If the quoted string doesn't terminate properly then
562
 *      the return value is a pointer to the null character at the
563
 *      end of the string.
564
 *
565
 * Side effects:
566
 *      None.
567
 *
568
 *----------------------------------------------------------------------
569
 */
570
 
571
static char *
572
QuoteEnd(string, lastChar, term)
573
    char *string;               /* Pointer to character just after opening
574
                                 * "quote". */
575
    char *lastChar;             /* Terminating character in string. */
576
    int term;                   /* This character will terminate the
577
                                 * quoted string (e.g. '"' or ')'). */
578
{
579
    register char *p = string;
580
    int count;
581
 
582
    while (*p != term) {
583
        if (*p == '\\') {
584
            (void) Tcl_Backslash(p, &count);
585
            p += count;
586
        } else if (*p == '[') {
587
            for (p++; *p != ']'; p++) {
588
                p = TclWordEnd(p, lastChar, 1, (int *) NULL);
589
                if (*p == 0) {
590
                    return p;
591
                }
592
            }
593
            p++;
594
        } else if (*p == '$') {
595
            p = VarNameEnd(p, lastChar);
596
            if (*p == 0) {
597
                return p;
598
            }
599
            p++;
600
        } else if (p == lastChar) {
601
            return p;
602
        } else {
603
            p++;
604
        }
605
    }
606
    return p-1;
607
}
608
 
609
/*
610
 *----------------------------------------------------------------------
611
 *
612
 * VarNameEnd --
613
 *
614
 *      Given a pointer to a variable reference using $-notation, find
615
 *      the end of the variable name spec.
616
 *
617
 * Results:
618
 *      The return value is a pointer to the last character that
619
 *      is part of the variable name.  If the variable name doesn't
620
 *      terminate properly then the return value is a pointer to the
621
 *      null character at the end of the string.
622
 *
623
 * Side effects:
624
 *      None.
625
 *
626
 *----------------------------------------------------------------------
627
 */
628
 
629
static char *
630
VarNameEnd(string, lastChar)
631
    char *string;               /* Pointer to dollar-sign character. */
632
    char *lastChar;             /* Terminating character in string. */
633
{
634
    register char *p = string+1;
635
 
636
    if (*p == '{') {
637
        for (p++; (*p != '}') && (p != lastChar); p++) {
638
            /* Empty loop body. */
639
        }
640
        return p;
641
    }
642
    while (isalnum(UCHAR(*p)) || (*p == '_')) {
643
        p++;
644
    }
645
    if ((*p == '(') && (p != string+1)) {
646
        return QuoteEnd(p+1, lastChar, ')');
647
    }
648
    return p-1;
649
}
650
 
651
 
652
/*
653
 *----------------------------------------------------------------------
654
 *
655
 * ScriptEnd --
656
 *
657
 *      Given a pointer to the beginning of a Tcl script, find the end of
658
 *      the script.
659
 *
660
 * Results:
661
 *      The return value is a pointer to the last character that's part
662
 *      of the script pointed to by "p".  If the command doesn't end
663
 *      properly within the string then the return value is the address
664
 *      of the null character at the end of the string.
665
 *
666
 * Side effects:
667
 *      None.
668
 *
669
 *----------------------------------------------------------------------
670
 */
671
 
672
static char *
673
ScriptEnd(p, lastChar, nested)
674
    char *p;                    /* Script to check. */
675
    char *lastChar;             /* Terminating character in string. */
676
    int nested;                 /* Zero means this is a top-level command.
677
                                 * One means this is a nested command (the
678
                                 * last character of the script must be
679
                                 * an unquoted ]). */
680
{
681
    int commentOK = 1;
682
    int length;
683
 
684
    while (1) {
685
        while (isspace(UCHAR(*p))) {
686
            if (*p == '\n') {
687
                commentOK = 1;
688
            }
689
            p++;
690
        }
691
        if ((*p == '#') && commentOK) {
692
            do {
693
                if (*p == '\\') {
694
                    /*
695
                     * If the script ends with backslash-newline, then
696
                     * this command isn't complete.
697
                     */
698
 
699
                    if ((p[1] == '\n') && (p+2 == lastChar)) {
700
                        return p+2;
701
                    }
702
                    Tcl_Backslash(p, &length);
703
                    p += length;
704
                } else {
705
                    p++;
706
                }
707
            } while ((p != lastChar) && (*p != '\n'));
708
            continue;
709
        }
710
        p = TclWordEnd(p, lastChar, nested, &commentOK);
711
        if (p == lastChar) {
712
            return p;
713
        }
714
        p++;
715
        if (nested) {
716
            if (*p == ']') {
717
                return p;
718
            }
719
        } else {
720
            if (p == lastChar) {
721
                return p-1;
722
            }
723
        }
724
    }
725
}
726
 
727
/*
728
 *----------------------------------------------------------------------
729
 *
730
 * Tcl_ParseVar --
731
 *
732
 *      Given a string starting with a $ sign, parse off a variable
733
 *      name and return its value.
734
 *
735
 * Results:
736
 *      The return value is the contents of the variable given by
737
 *      the leading characters of string.  If termPtr isn't NULL,
738
 *      *termPtr gets filled in with the address of the character
739
 *      just after the last one in the variable specifier.  If the
740
 *      variable doesn't exist, then the return value is NULL and
741
 *      an error message will be left in interp->result.
742
 *
743
 * Side effects:
744
 *      None.
745
 *
746
 *----------------------------------------------------------------------
747
 */
748
 
749
char *
750
Tcl_ParseVar(interp, string, termPtr)
751
    Tcl_Interp *interp;                 /* Context for looking up variable. */
752
    register char *string;              /* String containing variable name.
753
                                         * First character must be "$". */
754
    char **termPtr;                     /* If non-NULL, points to word to fill
755
                                         * in with character just after last
756
                                         * one in the variable specifier. */
757
 
758
{
759
    char *name1, *name1End, c, *result;
760
    register char *name2;
761
#define NUM_CHARS 200
762
    char copyStorage[NUM_CHARS];
763
    ParseValue pv;
764
 
765
    /*
766
     * There are three cases:
767
     * 1. The $ sign is followed by an open curly brace.  Then the variable
768
     *    name is everything up to the next close curly brace, and the
769
     *    variable is a scalar variable.
770
     * 2. The $ sign is not followed by an open curly brace.  Then the
771
     *    variable name is everything up to the next character that isn't
772
     *    a letter, digit, or underscore, or a "::" namespace separator.
773
     *    If the following character is an open parenthesis, then the
774
     *    information between parentheses is the array element name, which
775
     *    can include any of the substitutions permissible between quotes.
776
     * 3. The $ sign is followed by something that isn't a letter, digit,
777
     *    underscore, or a "::" namespace separator: in this case,
778
     *    there is no variable name, and "$" is returned.
779
     */
780
 
781
    name2 = NULL;
782
    string++;
783
    if (*string == '{') {
784
        string++;
785
        name1 = string;
786
        while (*string != '}') {
787
            if (*string == 0) {
788
                Tcl_SetResult(interp, "missing close-brace for variable name",
789
                        TCL_STATIC);
790
                if (termPtr != 0) {
791
                    *termPtr = string;
792
                }
793
                return NULL;
794
            }
795
            string++;
796
        }
797
        name1End = string;
798
        string++;
799
    } else {
800
        name1 = string;
801
        while (isalnum(UCHAR(*string)) || (*string == '_')
802
                || (*string == ':')) {
803
            if (*string == ':') {
804
                if (*(string+1) == ':') {
805
                    string += 2;  /* skip over the initial :: */
806
                    while (*string == ':') {
807
                        string++; /* skip over a subsequent : */
808
                    }
809
                } else {
810
                    break;        /* : by itself */
811
                }
812
            } else {
813
                string++;
814
            }
815
        }
816
        if (string == name1) {
817
            if (termPtr != 0) {
818
                *termPtr = string;
819
            }
820
            return "$";
821
        }
822
        name1End = string;
823
        if (*string == '(') {
824
            char *end;
825
 
826
            /*
827
             * Perform substitutions on the array element name, just as
828
             * is done for quotes.
829
             */
830
 
831
            pv.buffer = pv.next = copyStorage;
832
            pv.end = copyStorage + NUM_CHARS - 1;
833
            pv.expandProc = TclExpandParseValue;
834
            pv.clientData = (ClientData) NULL;
835
            if (TclParseQuotes(interp, string+1, ')', 0, &end, &pv)
836
                    != TCL_OK) {
837
                char msg[200];
838
                int length;
839
 
840
                length = string-name1;
841
                if (length > 100) {
842
                    length = 100;
843
                }
844
                sprintf(msg, "\n    (parsing index for array \"%.*s\")",
845
                        length, name1);
846
                Tcl_AddErrorInfo(interp, msg);
847
                result = NULL;
848
                name2 = pv.buffer;
849
                if (termPtr != 0) {
850
                    *termPtr = end;
851
                }
852
                goto done;
853
            }
854
            Tcl_ResetResult(interp);
855
            string = end;
856
            name2 = pv.buffer;
857
        }
858
    }
859
    if (termPtr != 0) {
860
        *termPtr = string;
861
    }
862
 
863
    c = *name1End;
864
    *name1End = 0;
865
    result = Tcl_GetVar2(interp, name1, name2, TCL_LEAVE_ERR_MSG);
866
    *name1End = c;
867
 
868
    done:
869
    if ((name2 != NULL) && (pv.buffer != copyStorage)) {
870
        ckfree(pv.buffer);
871
    }
872
    return result;
873
}
874
 
875
/*
876
 *----------------------------------------------------------------------
877
 *
878
 * Tcl_CommandComplete --
879
 *
880
 *      Given a partial or complete Tcl command, this procedure
881
 *      determines whether the command is complete in the sense
882
 *      of having matched braces and quotes and brackets.
883
 *
884
 * Results:
885
 *      1 is returned if the command is complete, 0 otherwise.
886
 *
887
 * Side effects:
888
 *      None.
889
 *
890
 *----------------------------------------------------------------------
891
 */
892
 
893
int
894
Tcl_CommandComplete(cmd)
895
    char *cmd;                  /* Command to check. */
896
{
897
    char *p;
898
 
899
    if (*cmd == 0) {
900
        return 1;
901
    }
902
    p = ScriptEnd(cmd, cmd+strlen(cmd), 0);
903
    return (*p != 0);
904
}
905
 
906
/*
907
 *----------------------------------------------------------------------
908
 *
909
 * TclObjCommandComplete --
910
 *
911
 *      Given a partial or complete Tcl command in a Tcl object, this
912
 *      procedure determines whether the command is complete in the sense of
913
 *      having matched braces and quotes and brackets.
914
 *
915
 * Results:
916
 *      1 is returned if the command is complete, 0 otherwise.
917
 *
918
 * Side effects:
919
 *      None.
920
 *
921
 *----------------------------------------------------------------------
922
 */
923
 
924
int
925
TclObjCommandComplete(cmdPtr)
926
    Tcl_Obj *cmdPtr;                    /* Points to object holding command
927
                                         * to check. */
928
{
929
    char *cmd, *p;
930
    int length;
931
 
932
    cmd = Tcl_GetStringFromObj(cmdPtr, &length);
933
    if (length == 0) {
934
        return 1;
935
    }
936
    p = ScriptEnd(cmd, cmd+length, /*nested*/ 0);
937
    return (*p != 0);
938
}

powered by: WebSVN 2.1.0

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