/* [<][>][^][v][top][bottom][index][help] */
DEFINITIONS
This source file includes following definitions.
- Scm_Intern
- Scm_Gensym
- symbol_print
- gloc_print
- Scm_MakeGloc
- Scm_MakeConstGloc
- Scm_GlocConstSetter
- Scm__InitSymbol
1 /*
2 * symbol.c - symbol implementation
3 *
4 * Copyright (c) 2000-2005 Shiro Kawai, All rights reserved.
5 *
6 * Redistribution and use in source and binary forms, with or without
7 * modification, are permitted provided that the following conditions
8 * are met:
9 *
10 * 1. Redistributions of source code must retain the above copyright
11 * notice, this list of conditions and the following disclaimer.
12 *
13 * 2. Redistributions in binary form must reproduce the above copyright
14 * notice, this list of conditions and the following disclaimer in the
15 * documentation and/or other materials provided with the distribution.
16 *
17 * 3. Neither the name of the authors nor the names of its contributors
18 * may be used to endorse or promote products derived from this
19 * software without specific prior written permission.
20 *
21 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
22 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
23 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
24 * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
25 * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
26 * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
27 * TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
28 * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
29 * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
30 * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
31 * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
32 *
33 * $Id: symbol.c,v 1.37 2005/10/13 08:14:13 shirok Exp $
34 */
35
36 #define LIBGAUCHE_BODY
37 #include "gauche.h"
38
39 /*-----------------------------------------------------------
40 * Symbols
41 */
42
43 static void symbol_print(ScmObj obj, ScmPort *port, ScmWriteContext *);
44 SCM_DEFINE_BUILTIN_CLASS_SIMPLE(Scm_SymbolClass, symbol_print);
45
46 #define INITSYM(sym, nam) \
47 sym = SCM_NEW(ScmSymbol); \
48 SCM_SET_CLASS(sym, SCM_CLASS_SYMBOL); \
49 sym->name = SCM_STRING(nam)
50
51 /* These two are global resource. Must be protected in MT environment. */
52 static ScmHashTable *obtable = NULL; /* name -> symbol mapper */
53 static int gensym_count = 0;
54
55 /* Intern */
56
57 ScmObj Scm_Intern(ScmString *name)
58 {
59 ScmHashEntry *e = Scm_HashTableGet(obtable, SCM_OBJ(name));
60 if (e) return e->value;
61 else {
62 ScmObj n = Scm_CopyStringWithFlags(name, SCM_STRING_IMMUTABLE,
63 SCM_STRING_IMMUTABLE);
64 ScmSymbol *sym;
65 INITSYM(sym, n);
66 Scm_HashTablePut(obtable, n, SCM_OBJ(sym));
67 return SCM_OBJ(sym);
68 }
69 }
70
71 /* Default prefix string. */
72 static SCM_DEFINE_STRING_CONST(default_prefix, "G", 1, 1);
73
74 /* Returns uninterned symbol.
75 PREFIX can be NULL*/
76 ScmObj Scm_Gensym(ScmString *prefix)
77 {
78 ScmString *name;
79 ScmSymbol *sym;
80 char numbuf[50];
81 int nc;
82
83 if (prefix == NULL) prefix = &default_prefix;
84 nc = snprintf(numbuf, 50, "%d", gensym_count++);
85 name = SCM_STRING(Scm_StringAppendC(prefix, numbuf, nc, nc));
86 INITSYM(sym, name);
87 return SCM_OBJ(sym);
88 }
89
90 /* Print */
91
92 /* table of special chars.
93 bit 0: bad char for symbol to begin with
94 bit 1: bad char for symbol to contain
95 bit 2: bad char for symbol, and should be written as \nnn
96 bit 3: bad char for symbol, and should be written as \c
97 bit 4: may be escaped when case fold mode
98 */
99 static char special[] = {
100 /* NUL .... */
101 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
102 /* .... */
103 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
104 /* ! " # $ % & ' ( ) * + , - . / */
105 3, 0, 3, 3, 0, 0, 0, 3, 3, 3, 0, 1, 3, 1, 1, 0,
106 /* 0 1 2 3 4 5 6 7 8 9 : ; < = > ? */
107 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 3, 0, 0, 0, 0,
108 /* @ A B C D E F G H I J K L M N O */
109 1, 16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,
110 /* P Q R S T U V W X Y Z [ \ ] ^ _ */
111 16,16,16,16,16,16,16,16,16,16,16,3, 11,3, 0, 0,
112 /* ` a b c d e f g h i j k l m n o */
113 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
114 /* p q r s t u v w x y z { | } ~ ^? */
115 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 11,3, 0, 7
116 };
117
118 static void symbol_print(ScmObj obj, ScmPort *port, ScmWriteContext *ctx)
119 {
120 if (SCM_WRITE_MODE(ctx) == SCM_WRITE_DISPLAY) {
121 SCM_PUTS(SCM_SYMBOL(obj)->name, port);
122 } else {
123 /* See if we have special characters, and use |-escape if necessary. */
124 /* TODO: For now, we regard chars over 0x80 is all "printable".
125 Need a more consistent mechanism. */
126 ScmString *snam = SCM_SYMBOL(obj)->name;
127 const ScmStringBody *b = SCM_STRING_BODY(snam);
128 const char *p = SCM_STRING_BODY_START(b), *q;
129 int siz = SCM_STRING_BODY_SIZE(b), i;
130 int escape = FALSE;
131 int case_mask =
132 ((SCM_WRITE_CASE(ctx) == SCM_WRITE_CASE_FOLD)? 0x12 : 0x02);
133
134 if (siz == 0) { /* special case */
135 SCM_PUTZ("||", -1, port);
136 return;
137 }
138 if (siz == 1 && (*p == '+' || *p == '-')) {
139 SCM_PUTC((unsigned)*p, port);
140 return;
141 }
142 if ((unsigned int)*p < 128 && (special[(unsigned int)*p]&1)) {
143 escape = TRUE;
144 } else {
145 for (i=0, q=p; i<siz; i++, q++) {
146 if ((unsigned int)*q < 128
147 && (special[(unsigned int)*q]&case_mask)) {
148 escape = TRUE;
149 break;
150 }
151 }
152 }
153 if (escape) {
154 SCM_PUTC('|', port);
155 for (q=p; q<p+siz; ) {
156 unsigned int ch;
157 SCM_CHAR_GET(q, ch);
158 q += SCM_CHAR_NBYTES(ch);
159 if (ch < 128) {
160 if (special[ch] & 8) {
161 SCM_PUTC('\\', port);
162 SCM_PUTC(ch, port);
163 } else if (special[ch] & 4) {
164 Scm_Printf(port, "\\x%02x", ch);
165 } else {
166 SCM_PUTC(ch, port);
167 }
168 } else {
169 SCM_PUTC(ch, port);
170 }
171 }
172 SCM_PUTC('|', port);
173 return;
174 } else {
175 SCM_PUTS(snam, port);
176 }
177 }
178 }
179
180 /*---------------------------------------------------------------
181 * GLOCs
182 */
183
184 static void gloc_print(ScmObj obj, ScmPort *port, ScmWriteContext *ctx)
185 {
186 ScmGloc *g = SCM_GLOC(obj);
187 Scm_Printf(port, "#<gloc %S%s%S>", g->module->name,
188 (g->exported?"#":"##"),
189 g->name);
190 }
191
192 SCM_DEFINE_BUILTIN_CLASS_SIMPLE(Scm_GlocClass, gloc_print);
193
194 ScmObj Scm_MakeGloc(ScmSymbol *sym, ScmModule *module)
195 {
196 ScmGloc *g = SCM_NEW(ScmGloc);
197 SCM_SET_CLASS(g, &Scm_GlocClass);
198 g->name = sym;
199 g->module = module;
200 g->value = SCM_UNBOUND;
201 g->exported = FALSE;
202 g->getter = NULL;
203 g->setter = NULL;
204 return SCM_OBJ(g);
205 }
206
207 ScmObj Scm_MakeConstGloc(ScmSymbol *sym, ScmModule *module)
208 {
209 ScmGloc *g = SCM_GLOC(Scm_MakeGloc(sym, module));
210 g->setter = Scm_GlocConstSetter;
211 return SCM_OBJ(g);
212 }
213
214 ScmObj Scm_GlocConstSetter(ScmGloc *gloc, ScmObj val)
215 {
216 Scm_Error("cannot change constant value of %S#%S",
217 gloc->module->name, gloc->name);
218 return SCM_UNDEFINED; /* dummy */
219 }
220
221 /*
222 * Initialization
223 */
224
225 #include "builtin-syms.c"
226
227 void Scm__InitSymbol(void)
228 {
229 obtable = SCM_HASH_TABLE(Scm_MakeHashTableSimple(SCM_HASH_STRING, 4096));
230 init_builtin_syms();
231 }