1 /* symbol.c -*- mode:c; coding:utf-8; -*-
2 *
3 * Copyright (c) 2010-2021 Takashi Kato <ktakashi@ymail.com>
4 *
5 * Redistribution and use in source and binary forms, with or without
6 * modification, are permitted provided that the following conditions
7 * are met:
8 *
9 * 1. Redistributions of source code must retain the above copyright
10 * notice, this list of conditions and the following disclaimer.
11 *
12 * 2. Redistributions in binary form must reproduce the above copyright
13 * notice, this list of conditions and the following disclaimer in the
14 * documentation and/or other materials provided with the distribution.
15 *
16 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
17 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
18 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
19 * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
20 * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
21 * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
22 * TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
23 * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
24 * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
25 * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
26 * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
27 *
28 * $Id: $
29 */
30 #define LIBSAGITTARIUS_BODY
31 #include "sagittarius/private/symbol.h"
32 #include "sagittarius/private/hashtable.h"
33 #include "sagittarius/private/thread.h"
34 #include "sagittarius/private/port.h"
35 #include "sagittarius/private/number.h"
36 #include "sagittarius/private/writer.h"
37
38 #include "gc-incl.inc"
39
40 #ifdef USE_WEAK_SYMBOL
41 # include "sagittarius/private/weak.h"
42 # define Sg_HashTableRef Sg_WeakHashTableRef
43 # define Sg_HashTableSet Sg_WeakHashTableSet
44 static SgWeakHashTable *obtable = NULL;
45 #else
46 static SgHashTable *obtable = NULL;
47 #endif
48
49 static SgInternalMutex obtable_mutax;
50 static SgInternalMutex unique_symbol_mutax;
51
52
symbol_print(SgObject sym,SgPort * port,SgWriteContext * ctx)53 static void symbol_print(SgObject sym, SgPort *port, SgWriteContext *ctx)
54 {
55 SgSymbol *obj = SG_SYMBOL(sym);
56 SG_PORT_LOCK_WRITE(port);
57 ASSERT(SG_STRINGP(obj->name));
58 if (SG_WRITE_MODE(ctx) == SG_WRITE_DISPLAY) {
59 Sg_PutsUnsafe(port, obj->name);
60 } else {
61 if (SG_UNINTERNED_SYMBOL(obj)) Sg_PutuzUnsafe(port, UC("#:"));
62 Sg_WriteSymbolName(obj->name, port, ctx, 0);
63 }
64 SG_PORT_UNLOCK_WRITE(port);
65 }
66
67 SG_DEFINE_BUILTIN_CLASS_SIMPLE(Sg_SymbolClass, symbol_print);
68
69
make_symbol(SgObject name,int interned)70 static SgSymbol* make_symbol(SgObject name, int interned)
71 {
72 SgSymbol *z = SG_NEW(SgSymbol);
73 SG_SET_CLASS(z, SG_CLASS_SYMBOL);
74 z->name = SG_STRING(name);
75 z->flags = 0;
76 if (interned) {
77 z->flags |= SG_SYMBOL_INTERNED;
78 }
79 return z;
80 }
81
Sg_MakeSymbol(SgString * name,int interned)82 SgObject Sg_MakeSymbol(SgString *name, int interned)
83 {
84 SgObject e, sname;
85 SgSymbol *sym;
86
87 if (interned) {
88 Sg_LockMutex(&obtable_mutax);
89 ASSERT(SG_STRING_VALUE(name));
90 e = Sg_HashTableRef(obtable, SG_OBJ(name), SG_FALSE);
91 Sg_UnlockMutex(&obtable_mutax);
92 if (!SG_FALSEP(e)) {
93 ASSERT(SG_SYMBOLP(e));
94 return e;
95 }
96 }
97 if (SG_IMMUTABLE_STRINGP(name)) {
98 sname = name;
99 } else {
100 sname = Sg_StringToIString(name, 0, -1);
101 }
102 sym = make_symbol(sname, interned);
103 if (!interned) return SG_OBJ(sym);
104
105 Sg_LockMutex(&obtable_mutax);
106 e = Sg_HashTableSet(obtable, SG_OBJ(name), SG_OBJ(sym), SG_HASH_NO_OVERWRITE);
107 Sg_UnlockMutex(&obtable_mutax);
108 return e;
109 }
110
111 static SgString *default_prefix;
112
Sg_Gensym(SgString * prefix)113 SgObject Sg_Gensym(SgString *prefix)
114 {
115 SgObject name;
116 SgSymbol *sym;
117 char numbuf[50] = {0};
118 SgChar buf[50] = {0};
119 int nc, i;
120
121 static intptr_t gensym_count = 0;
122
123 if (prefix == NULL) prefix = default_prefix;
124 nc = snprintf(numbuf, sizeof(numbuf), "%"PRIdPTR, gensym_count++);
125
126 /* TODO it's really inconvenient */
127 for (i = 0; i < 50; i++) {
128 buf[i] = (SgChar)numbuf[i];
129 }
130 name = Sg_StringAppendC(prefix, buf, nc);
131 sym = make_symbol(name, FALSE);
132 return SG_OBJ(sym);
133 }
134
135 static uint64_t unique_symbol_count = 0;
Sg_MakeUniqueSymbol(SgString * prefix)136 SgObject Sg_MakeUniqueSymbol(SgString *prefix)
137 {
138 uint64_t suffix;
139 unsigned long sec, usec;
140 SgObject name, p1, p2, p3;
141
142 Sg_GetTimeOfDay(&sec, &usec);
143 /* increment suffix */
144 Sg_LockMutex(&obtable_mutax);
145 suffix = ++unique_symbol_count;
146 Sg_UnlockMutex(&obtable_mutax);
147 /* TODO maybe we also want to get PID */
148 p1 = Sg_NumberToString(Sg_MakeIntegerU(sec), 32, FALSE);
149 p2 = Sg_NumberToString(Sg_MakeIntegerU(usec), 32, FALSE);
150 p3 = Sg_NumberToString(Sg_MakeIntegerFromU64(suffix), 32, FALSE);
151 if (prefix == NULL) prefix = default_prefix;
152
153 name = Sg_Sprintf(UC("%A%A%A_%A"), prefix, p1, p2, p3);
154 return make_symbol(SG_STRING(name), TRUE);
155 }
156
157 #include "builtin-symbols.c"
158
DEFINE_DEBUG_DUMPER(symbol,obtable)159 DEFINE_DEBUG_DUMPER(symbol, obtable)
160
161 void Sg__InitSymbol()
162 {
163 Sg_InitMutex(&obtable_mutax, FALSE);
164 Sg_InitMutex(&unique_symbol_mutax, FALSE);
165 #ifdef USE_WEAK_SYMBOL
166 obtable = SG_WEAK_HASHTABLE(Sg_MakeWeakHashTableSimple(SG_HASH_STRING,
167 SG_WEAK_REMOVE_VALUE,
168 4096, SG_FALSE));
169 #else
170 obtable = SG_HASHTABLE(Sg_MakeHashTableSimple(SG_HASH_STRING, 4096));
171 #endif
172 default_prefix = SG_MAKE_STRING("G");
173 init_builtin_symbols();
174
175 ADD_DEBUG_DUMPER(symbol);
176 }
177
178
179 /*
180 end of file
181 Local Variables:
182 coding: utf-8-unix
183 End
184 */
185