Back to index

plt-scheme  4.2.1
symbol.c
Go to the documentation of this file.
00001 /*
00002   MzScheme
00003   Copyright (c) 2004-2009 PLT Scheme Inc.
00004   Copyright (c) 1995-2001 Matthew Flatt
00005 
00006     This library is free software; you can redistribute it and/or
00007     modify it under the terms of the GNU Library General Public
00008     License as published by the Free Software Foundation; either
00009     version 2 of the License, or (at your option) any later version.
00010 
00011     This library is distributed in the hope that it will be useful,
00012     but WITHOUT ANY WARRANTY; without even the implied warranty of
00013     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
00014     Library General Public License for more details.
00015 
00016     You should have received a copy of the GNU Library General Public
00017     License along with this library; if not, write to the Free
00018     Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
00019     Boston, MA 02110-1301 USA.
00020 
00021   libscheme
00022   Copyright (c) 1994 Brent Benson
00023   All rights reserved.
00024 */
00025 
00026 /* Some copilers don't like re-def of GC_malloc in schemef.h: */
00027 #ifndef MZ_PRECISE_GC
00028 # define SCHEME_NO_GC_PROTO
00029 #endif
00030 
00031 #include "schpriv.h"
00032 #include "mzrt.h"
00033 #include <string.h>
00034 #include <ctype.h>
00035 #include "schgc.h"
00036 
00037 # define HASH_TABLE_INIT_SIZE 256
00038 #ifdef SMALL_HASH_TABLES
00039 # define FILL_FACTOR 1.30
00040 #else
00041 # define FILL_FACTOR 2
00042 #endif
00043 
00044 #ifndef MZ_PRECISE_GC
00045 extern MZ_DLLIMPORT void (*GC_custom_finalize)(void);
00046 #endif
00047 #ifndef USE_SENORA_GC
00048 extern int GC_is_marked(void *);
00049 #endif
00050 
00051 Scheme_Hash_Table *scheme_symbol_table = NULL;
00052 Scheme_Hash_Table *scheme_keyword_table = NULL;
00053 Scheme_Hash_Table *scheme_parallel_symbol_table = NULL;
00054 
00055 #ifdef MZ_USE_PLACES
00056 mzrt_rwlock *symbol_table_lock;
00057 #else
00058 # define mzrt_rwlock_rdlock(l) /* empty */
00059 # define mzrt_rwlock_wrlock(l) /* empty */
00060 # define mzrt_rwlock_unlock(l) /* empty */
00061 #endif
00062 
00063 unsigned long scheme_max_found_symbol_name;
00064 
00065 /* globals */
00066 int scheme_case_sensitive = 1;
00067 
00068 void scheme_set_case_sensitive(int v) { scheme_case_sensitive =  v; }
00069 
00070 /* locals */
00071 static Scheme_Object *symbol_p_prim (int argc, Scheme_Object *argv[]);
00072 static Scheme_Object *symbol_interned_p_prim (int argc, Scheme_Object *argv[]);
00073 static Scheme_Object *string_to_symbol_prim (int argc, Scheme_Object *argv[]);
00074 static Scheme_Object *string_to_uninterned_symbol_prim (int argc, Scheme_Object *argv[]);
00075 static Scheme_Object *string_to_unreadable_symbol_prim (int argc, Scheme_Object *argv[]);
00076 static Scheme_Object *symbol_to_string_prim (int argc, Scheme_Object *argv[]);
00077 static Scheme_Object *keyword_p_prim (int argc, Scheme_Object *argv[]);
00078 static Scheme_Object *keyword_lt (int argc, Scheme_Object *argv[]);
00079 static Scheme_Object *string_to_keyword_prim (int argc, Scheme_Object *argv[]);
00080 static Scheme_Object *keyword_to_string_prim (int argc, Scheme_Object *argv[]);
00081 static Scheme_Object *gensym(int argc, Scheme_Object *argv[]);
00082 
00083 static int gensym_counter;
00084 
00085 /**************************************************************************/
00086 
00087 typedef unsigned long hash_v_t;
00088 #define HASH_SEED  0xF0E1D2C3
00089 
00090 #define SYMTAB_LOST_CELL scheme_false
00091 
00092 #ifdef MZ_PRECISE_GC
00093 # define WEAK_ARRAY_HEADSIZE 4
00094 #else
00095 # define WEAK_ARRAY_HEADSIZE 0
00096 #endif
00097 
00098 static Scheme_Object *rehash_symbol_bucket(Scheme_Hash_Table *table,
00099                                            GC_CAN_IGNORE const char *key, unsigned int length,
00100                                            Scheme_Object *naya);
00101 
00102 /* Special hashing for symbols: */
00103 static Scheme_Object *symbol_bucket(Scheme_Hash_Table *table,
00104                                 GC_CAN_IGNORE const char *key, unsigned int length,
00105                                 Scheme_Object *naya)
00106 {
00107   hash_v_t h, h2;
00108   unsigned long mask;
00109   Scheme_Object *bucket;
00110 
00111   /* WARNING: key may be GC-misaligned... */
00112   /* This function is designed to need no MZ_PRECISE_GC instrumentation.
00113      To handle re-hashing, it tail-calls rehash_symbol_bucket. */
00114 
00115   mask = table->size - 1;
00116 
00117   {
00118     unsigned int i;
00119     i = 0;
00120     h = HASH_SEED;
00121     h2 = 0;
00122 
00123     while (i < length) {
00124       int c = key[i++];
00125        h ^= (h << 5) + (h >> 2) + c;
00126        h2 += c;
00127     }
00128     /* post hash mixing helps for short symbols */
00129     h ^= (h << 5) + (h >> 2) + 0xA0A0;
00130     h ^= (h << 5) + (h >> 2) + 0x0505;
00131 
00132     h = h & mask;
00133     h2 = h2 & mask;
00134   }
00135 
00136   h2 |= 0x1;
00137 
00138   while ((bucket = table->keys[WEAK_ARRAY_HEADSIZE + h])) {
00139     if (SAME_OBJ(bucket, SYMTAB_LOST_CELL)) {
00140       if (naya) {
00141        /* We're re-using, so decrement count and it will be
00142           re-incremented. */
00143        --table->count;
00144        break;
00145       }
00146     } else if (((int)length == SCHEME_SYM_LEN(bucket))
00147               && !memcmp(key, SCHEME_SYM_VAL(bucket), length))
00148       return bucket;
00149     h = (h + h2) & mask;
00150   }
00151 
00152   /* In case it's GC-misaligned: */
00153   key = NULL;
00154 
00155   if (!naya)
00156     return NULL;
00157 
00158   if (table->count * FILL_FACTOR >= table->size) {
00159     return rehash_symbol_bucket(table, key, length, naya);
00160   }
00161 
00162   table->keys[WEAK_ARRAY_HEADSIZE + h] = naya;
00163 
00164   table->count++;
00165 
00166   return naya;
00167 }
00168 
00169 static Scheme_Object *rehash_symbol_bucket(Scheme_Hash_Table *table,
00170                                            GC_CAN_IGNORE const char *key, unsigned int length,
00171                                            Scheme_Object *naya)
00172 {
00173   int i, oldsize = table->size, newsize, lostc;
00174   size_t asize;
00175   Scheme_Object *cb;
00176   Scheme_Object **old = table->keys;
00177 
00178   /* WARNING: key may be GC-misaligned... */
00179 
00180   /* Don't grow table if it's mostly lost cells (due to lots of
00181      temporary symbols). */
00182   lostc = 0;
00183   for (i = 0; i < oldsize; i++) {
00184     cb = old[WEAK_ARRAY_HEADSIZE + i];
00185     if (cb == SYMTAB_LOST_CELL)
00186       lostc++;
00187   }
00188   if ((lostc * 2) < table->count)
00189     newsize = oldsize << 1;
00190   else
00191     newsize = oldsize;
00192 
00193   asize = (size_t)newsize * sizeof(Scheme_Object *);
00194   {
00195     Scheme_Object **ba;
00196 #ifdef MZ_PRECISE_GC
00197     ba = (Scheme_Object **)GC_malloc_weak_array(sizeof(Scheme_Object *) * newsize,
00198                                                 SYMTAB_LOST_CELL);
00199 #else
00200     ba = MALLOC_N_ATOMIC(Scheme_Object *, newsize);
00201     memset((char *)ba, 0, asize);
00202 #endif
00203     table->keys = ba;
00204   }
00205   table->size = newsize;
00206 
00207   table->count = 0;
00208 
00209   for (i = 0; i < oldsize; i++) {
00210     cb = old[WEAK_ARRAY_HEADSIZE + i] ;
00211     if (cb && (cb != SYMTAB_LOST_CELL))
00212       symbol_bucket(table, SCHEME_SYM_VAL(cb), SCHEME_SYM_LEN(cb), cb);
00213   }
00214 
00215   /* Restore GC-misaligned key: */
00216   key = SCHEME_SYM_VAL(naya);
00217 
00218   return symbol_bucket(table, key, length, naya);
00219 }
00220 
00221 #ifndef MZ_PRECISE_GC
00222 static void clean_one_symbol_table(Scheme_Hash_Table *symbol_table)
00223 {
00224   /* Clean the symbol table by removing pointers to collected
00225      symbols. The correct way to do this is to install a GC
00226      finalizer on symbol pointers, but that would be expensive. */
00227 
00228   if (symbol_table) {
00229     Scheme_Object **buckets = (Scheme_Object **)symbol_table->keys;
00230     int i = symbol_table->size;
00231     void *b;
00232 
00233     while (i--) {
00234       if (buckets[WEAK_ARRAY_HEADSIZE + i] && !SAME_OBJ(buckets[WEAK_ARRAY_HEADSIZE + i], SYMTAB_LOST_CELL)
00235          && (!(b = GC_base(buckets[WEAK_ARRAY_HEADSIZE + i]))
00236 #ifndef USE_SENORA_GC
00237              || !GC_is_marked(b)
00238 #endif
00239              )) {
00240        buckets[WEAK_ARRAY_HEADSIZE + i] = SYMTAB_LOST_CELL;
00241       }
00242     }
00243   }
00244 }
00245 
00246 static void clean_symbol_table(void)
00247 {
00248   clean_one_symbol_table(scheme_symbol_table);
00249   clean_one_symbol_table(scheme_keyword_table);
00250   clean_one_symbol_table(scheme_parallel_symbol_table);
00251   scheme_clear_ephemerons();
00252 # ifdef MZ_USE_JIT
00253   scheme_clean_native_symtab();
00254 # endif
00255 # ifndef MZ_PRECISE_GC
00256   scheme_clean_cust_box_list();
00257 # endif
00258 # ifndef MZ_PRECISE_GC
00259   scheme_notify_code_gc();
00260 # endif
00261 }
00262 #endif
00263 
00264 /**************************************************************************/
00265 
00266 static Scheme_Hash_Table *init_one_symbol_table()
00267 {
00268   Scheme_Hash_Table *symbol_table;
00269   int size;
00270   Scheme_Object **ba;
00271 
00272   symbol_table = scheme_make_hash_table(SCHEME_hash_ptr);
00273 
00274   symbol_table->size = HASH_TABLE_INIT_SIZE;
00275   
00276   size = symbol_table->size * sizeof(Scheme_Object *);
00277 #ifdef MZ_PRECISE_GC
00278   ba = (Scheme_Object **)GC_malloc_weak_array(size, SYMTAB_LOST_CELL);
00279 #else
00280   ba = MALLOC_N_ATOMIC(Scheme_Object *, size);
00281   memset((char *)ba, 0, size);
00282 #endif
00283   symbol_table->keys = ba;
00284 
00285   return symbol_table;
00286 }
00287 
00288 void
00289 scheme_init_symbol_table ()
00290 {
00291   REGISTER_SO(scheme_symbol_table);
00292   REGISTER_SO(scheme_keyword_table);
00293   REGISTER_SO(scheme_parallel_symbol_table);
00294 
00295   scheme_symbol_table = init_one_symbol_table();
00296   scheme_keyword_table = init_one_symbol_table();
00297   scheme_parallel_symbol_table = init_one_symbol_table();
00298 
00299 #ifdef MZ_USE_PLACES
00300   mzrt_rwlock_create(&symbol_table_lock);
00301 #endif
00302 
00303 #ifndef MZ_PRECISE_GC
00304   GC_custom_finalize = clean_symbol_table;
00305 #endif
00306 }
00307 
00308 void
00309 scheme_init_symbol_type (Scheme_Env *env)
00310 {
00311 }
00312 
00313 void
00314 scheme_init_symbol (Scheme_Env *env)
00315 {
00316   Scheme_Object *p;
00317 
00318   p = scheme_make_folding_prim(symbol_p_prim, "symbol?", 1, 1, 1);
00319   SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
00320   scheme_add_global_constant("symbol?", p, env);
00321   
00322   p = scheme_make_folding_prim(symbol_interned_p_prim, "symbol-interned?", 1, 1, 1);
00323   scheme_add_global_constant("symbol-interned?", p, env);
00324   
00325   GLOBAL_IMMED_PRIM("string->symbol",             string_to_symbol_prim,            1, 1, env);
00326   GLOBAL_IMMED_PRIM("string->uninterned-symbol",  string_to_uninterned_symbol_prim, 1, 1, env);
00327   GLOBAL_IMMED_PRIM("string->unreadable-symbol",  string_to_unreadable_symbol_prim, 1, 1, env);
00328   GLOBAL_IMMED_PRIM("symbol->string",             symbol_to_string_prim,            1, 1, env);
00329   GLOBAL_FOLDING_PRIM("keyword?",                 keyword_p_prim,                   1, 1, 1, env);
00330   GLOBAL_FOLDING_PRIM("keyword<?",                keyword_lt,                       2, -1, 1, env);
00331   GLOBAL_IMMED_PRIM("string->keyword",            string_to_keyword_prim,           1, 1, env);
00332   GLOBAL_IMMED_PRIM("keyword->string",            keyword_to_string_prim,           1, 1, env);
00333   GLOBAL_IMMED_PRIM("gensym",                     gensym,                           0, 1, env);
00334 }
00335 
00336 static Scheme_Object *
00337 make_a_symbol(const char *name, unsigned int len, int kind)
00338 {
00339   Scheme_Symbol *sym;
00340 
00341   sym = (Scheme_Symbol *)scheme_malloc_atomic_tagged(sizeof(Scheme_Symbol) + len - 3);
00342 
00343   sym->iso.so.type = scheme_symbol_type;
00344   MZ_OPT_HASH_KEY(&sym->iso) = kind;
00345   sym->len = len;
00346   memcpy(sym->s, name, len);
00347   sym->s[len] = 0;
00348 
00349   if (len > scheme_max_found_symbol_name) {
00350     scheme_max_found_symbol_name = len;
00351   }
00352 
00353   return (Scheme_Object *) sym;
00354 }
00355 
00356 Scheme_Object *
00357 scheme_make_symbol(const char *name)
00358 {
00359   return make_a_symbol(name, strlen(name), 0x1);
00360 }
00361 
00362 Scheme_Object *
00363 scheme_make_exact_symbol(const char *name, unsigned int len)
00364 {
00365   return make_a_symbol(name, len, 0x1);
00366 }
00367 
00368 Scheme_Object *
00369 scheme_make_exact_char_symbol(const mzchar *name, unsigned int len)
00370 {
00371   char buf[64], *bs;
00372   long blen;
00373   bs = scheme_utf8_encode_to_buffer_len(name, len, buf, 64, &blen);
00374   return make_a_symbol(bs, blen, 0x1);
00375 }
00376 
00377 Scheme_Object *
00378 scheme_intern_exact_symbol_in_table_worker(Scheme_Hash_Table *symbol_table, int kind, const char *name, unsigned int len)
00379 {
00380   Scheme_Object *sym;
00381 
00382   mzrt_rwlock_rdlock(symbol_table_lock);
00383   sym = symbol_bucket(symbol_table, name, len, NULL);
00384   mzrt_rwlock_unlock(symbol_table_lock);
00385 
00386   if (!sym) {
00387     Scheme_Object *newsymbol;
00388     newsymbol = make_a_symbol(name, len, kind);
00389     
00390     /* we must return the result of this symbol bucket call because another
00391      * thread could have inserted the same symbol between the first
00392      * :qsymbol_bucket call above and this one */
00393     mzrt_rwlock_wrlock(symbol_table_lock);
00394     sym = symbol_bucket(symbol_table, name, len, newsymbol);
00395     mzrt_rwlock_unlock(symbol_table_lock);
00396   }
00397 
00398   return sym;
00399 }
00400 
00401 Scheme_Object *
00402 scheme_intern_exact_symbol_in_table(Scheme_Hash_Table *symbol_table, int kind, const char *name, unsigned int len)
00403 {
00404 #if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
00405   void *return_payload;
00406   Scheme_Symbol_Parts parts;
00407   parts.table = symbol_table;
00408   parts.kind = kind;
00409   parts.len  = len;
00410   parts.name = name;
00411   return_payload = scheme_master_fast_path(3, &parts);
00412   return (Scheme_Object*) return_payload;
00413 #endif
00414   return scheme_intern_exact_symbol_in_table_worker(symbol_table, kind, name, len);
00415 }
00416 
00417 Scheme_Object *
00418 scheme_intern_exact_symbol(const char *name, unsigned int len)
00419 {
00420   return scheme_intern_exact_symbol_in_table(scheme_symbol_table, 0, name, len);
00421 }
00422 
00423 Scheme_Object *
00424 scheme_intern_exact_parallel_symbol(const char *name, unsigned int len)
00425 {
00426   return scheme_intern_exact_symbol_in_table(scheme_parallel_symbol_table, 0x2, name, len);
00427 }
00428 
00429 Scheme_Object *
00430 scheme_intern_exact_char_symbol(const mzchar *name, unsigned int len)
00431 {
00432   char buf[64], *bs;
00433   long blen;
00434   bs = scheme_utf8_encode_to_buffer_len(name, len, buf, 64, &blen);
00435   return scheme_intern_exact_symbol_in_table(scheme_symbol_table, 0, bs, blen);
00436 }
00437 
00438 Scheme_Object *
00439 scheme_intern_exact_keyword(const char *name, unsigned int len)
00440 {
00441   Scheme_Object *s;
00442   s = scheme_intern_exact_symbol_in_table(scheme_keyword_table, 0, name, len);
00443   if (s->type == scheme_symbol_type)
00444     s->type = scheme_keyword_type;
00445   return s;
00446 }
00447 
00448 Scheme_Object *scheme_intern_exact_char_keyword(const mzchar *name, unsigned int len)
00449 {
00450   char buf[64], *bs;
00451   long blen;
00452   Scheme_Object *s;
00453   bs = scheme_utf8_encode_to_buffer_len(name, len, buf, 64, &blen);
00454   s = scheme_intern_exact_symbol_in_table(scheme_keyword_table, 0, bs, blen);
00455   if (s->type == scheme_symbol_type)
00456     s->type = scheme_keyword_type;
00457   return s;
00458 }
00459 
00460 #define MAX_SYMBOL_SIZE 256
00461 
00462 Scheme_Object *
00463 scheme_intern_symbol(const char *name)
00464   /* `name' must be ASCII; this function is not suitable for non-ASCII
00465      conversion, necause it assumes that downcasing each C char
00466      is good enough to normalize the case. */
00467 {
00468   if (!scheme_case_sensitive) {
00469       unsigned long i, len;
00470     char *naya;
00471     char on_stack[MAX_SYMBOL_SIZE];
00472 
00473     len = strlen(name);
00474     if (len >= MAX_SYMBOL_SIZE)
00475       naya = (char *)scheme_malloc_atomic(len + 1);
00476     else
00477       naya = on_stack;
00478 
00479     for (i = 0; i < len; i++) {
00480       int c = ((unsigned char *)name)[i];
00481 
00482       c = scheme_tolower(c);
00483 
00484       naya[i] = c;
00485     }
00486 
00487     naya[len] = 0;
00488 
00489     return scheme_intern_exact_symbol(naya, len);
00490   }
00491 
00492   return scheme_intern_exact_symbol(name, strlen(name));
00493 }
00494 
00495 const char *scheme_symbol_name_and_size(Scheme_Object *sym, unsigned int *length, int flags)
00496 {
00497   int has_space = 0, has_special = 0, has_pipe = 0, has_upper = 0, digit_start;
00498   int dz;
00499   unsigned int i, len = SCHEME_SYM_LEN(sym), total_length;
00500   int pipe_quote;
00501   char buf[100];
00502   char *s, *result;
00503 
00504   if ((flags & SCHEME_SNF_PIPE_QUOTE) || (flags & SCHEME_SNF_FOR_TS))
00505     pipe_quote = 1;
00506   else if (flags & SCHEME_SNF_NO_PIPE_QUOTE)
00507     pipe_quote = 0;
00508   else {
00509     pipe_quote = SCHEME_TRUEP(scheme_get_param(scheme_current_config(), MZCONFIG_CAN_READ_PIPE_QUOTE));
00510   }
00511 
00512   if (len < 100) {
00513     s = buf;
00514     memcpy(buf, SCHEME_SYM_VAL(sym), len + 1);
00515   } else
00516     s = scheme_symbol_val(sym);
00517   
00518 
00519 #define isSpecial(ch) ((ch == '(') || (ch == '[') || (ch == '{')       \
00520                      || (ch == ')') || (ch == ']') || (ch == '}')    \
00521                      || (ch == ')') || (ch == '\\')   \
00522                      || (ch == '"') || (ch == '\'')   \
00523                      || (ch == '`') || (ch == ',')    \
00524                        || (ch == ';')                   \
00525                        || (((ch == '>') || (ch == '<')) \
00526                         && (flags & SCHEME_SNF_FOR_TS)))
00527 
00528   if (len) {
00529     if (flags & SCHEME_SNF_KEYWORD) {
00530       digit_start = 0;
00531     } else {
00532       digit_start = (isdigit((unsigned char)s[0]) || (s[0] == '.')
00533                    || (s[0] == '+') || (s[0] == '-'));
00534       if (s[0] == '#' && (len == 1 || s[1] != '%'))
00535        has_special = 1;
00536       if (s[0] == '.' && len == 1)
00537        has_special = 1;
00538     }
00539   } else {
00540     digit_start = 0;
00541     if (!(flags & SCHEME_SNF_KEYWORD))
00542       has_space = 1;
00543   }
00544 
00545   for (i = 0; i < len; i++) {
00546     if (isspace((unsigned char)s[i])) { /* used to have || !isprint((unsigned char)s[i]) */
00547       if ((flags & SCHEME_SNF_FOR_TS) && (s[i] == ' ')) {
00548        /* space is OK in type symbols */
00549       } else
00550        has_space = 1;
00551     } else if (isSpecial(s[i]))
00552       has_special = 1;
00553     else if (s[i] == '|')
00554       has_pipe = 1;
00555     else if (flags & SCHEME_SNF_NEED_CASE) {
00556       int ch = ((unsigned char *)s)[i];
00557       if (ch > 127) {
00558        /* Decode UTF-8. */
00559        mzchar buf[2];
00560        int ul = 2;
00561        while (1) {
00562          if (scheme_utf8_decode((unsigned char *)s, i, i + ul,
00563                              buf, 0, 1,
00564                              NULL, 0, 0) > 0)
00565            break;
00566          ul++;
00567        }
00568        ch = buf[0];
00569        if (scheme_isspecialcasing(ch)) {
00570          mzchar *rc;
00571          buf[1] = 0;
00572          rc = scheme_string_recase(buf, 0, 1, 3, 1, NULL);
00573          if ((rc != buf) || (rc[0] != ch))
00574            has_upper = 1;
00575          ch = 'a';
00576        }
00577        i += (ul - 1);
00578       }
00579       if (scheme_tofold(ch) != ch)
00580        has_upper = 1;
00581     }
00582   }
00583 
00584   result = NULL;
00585   total_length = 0;
00586 
00587   if (!has_space && !has_special && (!pipe_quote || !has_pipe) && !has_upper) {
00588     mzchar cbuf[100], *cs;
00589     long clen;
00590     dz = 0;
00591     cs = scheme_utf8_decode_to_buffer_len((unsigned char *)s, len, cbuf, 100, &clen);
00592     if (cs
00593        && digit_start
00594        && !(flags & SCHEME_SNF_FOR_TS)
00595        && (SCHEME_TRUEP(scheme_read_number(cs, clen, 0, 0, 1, 10, 0, NULL, &dz, 1, NULL, 0, 0, 0, 0, NULL))
00596            || dz)) {
00597       /* Need quoting: */
00598       if (pipe_quote)
00599        has_space = 1; /* Use normal */
00600       else {
00601        /* Just need a leading backslash: */
00602        result = (char *)scheme_malloc_atomic(len + 2);
00603        total_length = len + 1;
00604        memcpy(result + 1, s, len);
00605        result[0] = '\\';
00606        result[len + 1] = 0;
00607       }
00608     } else {
00609       total_length = len;
00610       result = s;
00611     }
00612   }
00613 
00614   if (!result) {
00615     if (!has_pipe && pipe_quote) {
00616       result = (char *)scheme_malloc_atomic(len + 3);
00617       total_length = len + 2;
00618       memcpy(result + 1, s, len);
00619       result[0] = '|';
00620       result[len + 1] = '|';
00621       result[len + 2] = 0;
00622     } else {
00623       int p = 0;
00624       unsigned int i = 0;
00625 
00626       result = (char *)scheme_malloc_atomic((2 * len) + 1);
00627 
00628       for (i = 0; i < len; i++) {
00629        if (isspace((unsigned char)s[i])
00630            || isSpecial(s[i])
00631            || ((s[i] == '|') && pipe_quote)
00632            || (!i && s[0] == '#')
00633            || (has_upper && ((((unsigned char)s[i]) >= 'A')
00634                            && (((unsigned char)s[i]) <= 'Z'))))
00635          result[p++] = '\\';
00636        result[p++] = s[i];
00637       }
00638 
00639       result[p] = 0;
00640       total_length = p;
00641     }
00642   }
00643 
00644   if (length)
00645     *length = total_length;
00646 
00647   return (result == buf) ? scheme_symbol_val (sym) : result;
00648 }
00649 
00650 const char *scheme_symbol_name(Scheme_Object *sym)
00651 {
00652   return scheme_symbol_name_and_size(sym, NULL, 0);
00653 }
00654 
00655 char *scheme_symbol_val(Scheme_Object *sym)
00656 {
00657   char *s;
00658   s = scheme_malloc_atomic(SCHEME_SYM_LEN(sym) + 1);
00659   memcpy(s, SCHEME_SYM_VAL(sym), SCHEME_SYM_LEN(sym) + 1);
00660   return s;
00661 }
00662 
00663 /* locals */
00664 
00665 static Scheme_Object *
00666 symbol_p_prim (int argc, Scheme_Object *argv[])
00667 {
00668   return SCHEME_SYMBOLP(argv[0]) ? scheme_true : scheme_false;
00669 }
00670 
00671 static Scheme_Object *
00672 symbol_interned_p_prim (int argc, Scheme_Object *argv[])
00673 {
00674   if (SCHEME_SYMBOLP(argv[0]))
00675     return (SCHEME_SYM_WEIRDP(argv[0]) ? scheme_false : scheme_true);
00676   
00677   scheme_wrong_type("symbol-interned?", "symbol", 0, argc, argv);
00678   return NULL;
00679 }
00680 
00681 static Scheme_Object *
00682 string_to_symbol_prim (int argc, Scheme_Object *argv[])
00683 {
00684   if (!SCHEME_CHAR_STRINGP(argv[0]))
00685     scheme_wrong_type("string->symbol", "string", 0, argc, argv);
00686   return scheme_intern_exact_char_symbol(SCHEME_CHAR_STR_VAL(argv[0]),
00687                                     SCHEME_CHAR_STRTAG_VAL(argv[0]));
00688 }
00689 
00690 static Scheme_Object *
00691 string_to_uninterned_symbol_prim (int argc, Scheme_Object *argv[])
00692 {
00693   if (!SCHEME_CHAR_STRINGP(argv[0]))
00694     scheme_wrong_type("string->uninterned-symbol", "string", 0, argc, argv);
00695   return scheme_make_exact_char_symbol(SCHEME_CHAR_STR_VAL(argv[0]),
00696                                    SCHEME_CHAR_STRTAG_VAL(argv[0]));
00697 }
00698 
00699 static Scheme_Object *
00700 string_to_unreadable_symbol_prim (int argc, Scheme_Object *argv[])
00701 {
00702   char buf[64], *bs;
00703   long blen;
00704 
00705   if (!SCHEME_CHAR_STRINGP(argv[0]))
00706     scheme_wrong_type("string->symbol", "string", 0, argc, argv);
00707 
00708   bs = scheme_utf8_encode_to_buffer_len(SCHEME_CHAR_STR_VAL(argv[0]),
00709                                         SCHEME_CHAR_STRTAG_VAL(argv[0]), 
00710                                         buf, 64, &blen);
00711 
00712   return scheme_intern_exact_parallel_symbol(bs, blen);
00713 }
00714 
00715 static Scheme_Object *
00716 symbol_to_string_prim (int argc, Scheme_Object *argv[])
00717 {
00718   Scheme_Object *sym, *str;
00719   GC_CAN_IGNORE unsigned char *s;
00720   GC_CAN_IGNORE mzchar *s2;
00721   long len, i;
00722 
00723   sym = argv[0];
00724 
00725   if (!SCHEME_SYMBOLP(sym))
00726     scheme_wrong_type("symbol->string", "symbol", 0, argc, argv);
00727 
00728   s = (unsigned char *)SCHEME_SYM_VAL(sym);
00729   len = SCHEME_SYM_LEN(sym);
00730   for (i = 0; i < len; i++) {
00731     if (s[i] >= 128)
00732       break;
00733   }
00734   s = NULL;
00735 
00736   if (i == len) {
00737     /* ASCII */
00738     str = scheme_alloc_char_string(len, 0);
00739     s = (unsigned char *)SCHEME_SYM_VAL(sym);
00740     s2 = SCHEME_CHAR_STR_VAL(str);
00741     for (i = 0; i < len; i++) {
00742       s2[i] = s[i];
00743     }
00744     return str;
00745   } else {
00746     return scheme_make_sized_offset_utf8_string((char *)sym,
00747                                                 SCHEME_SYMSTR_OFFSET(sym),
00748                                                 SCHEME_SYM_LEN(sym));
00749   }
00750 }
00751 
00752 static Scheme_Object *
00753 keyword_p_prim (int argc, Scheme_Object *argv[])
00754 {
00755   return SCHEME_KEYWORDP(argv[0]) ? scheme_true : scheme_false;
00756 }
00757 
00758 static Scheme_Object *keyword_lt (int argc, Scheme_Object *argv[])
00759 {
00760   Scheme_Object *prev = argv[0], *kw;
00761   GC_CAN_IGNORE unsigned char *a, *b;
00762   int i, al, bl, t;
00763 
00764   if (!SCHEME_KEYWORDP(prev))
00765     scheme_wrong_type("keyword<?", "keyword", 0, argc, argv);
00766 
00767   for (i = 1; i < argc; i++) {
00768     kw = argv[i];
00769     if (!SCHEME_KEYWORDP(kw))
00770       scheme_wrong_type("keyword<?", "keyword", i, argc, argv);
00771 
00772     a = (unsigned char *)SCHEME_SYM_VAL(prev);
00773     al = SCHEME_SYM_LEN(prev);
00774     b = (unsigned char *)SCHEME_SYM_VAL(kw);
00775     bl = SCHEME_SYM_LEN(kw);
00776     t = ((al < bl) ? al : bl);
00777     while (t--) {
00778       if (*a < *b) {
00779         al = 0;
00780         bl = 1;
00781         break;
00782       } else if (*a > *b) {
00783         al = bl = 0;
00784         break;
00785       } else {
00786         a++;
00787         b++;
00788       }
00789     }
00790     a = b = NULL;
00791 
00792     if (al >= bl) {
00793       /* Check remaining types */
00794       for (i++; i < argc; i++) {
00795         if (!SCHEME_KEYWORDP(argv[i]))
00796           scheme_wrong_type("keyword<?", "keyword", i, argc, argv);
00797       }
00798       return scheme_false;
00799     }
00800 
00801     prev = kw;
00802   }
00803 
00804   return scheme_true;
00805 }
00806 
00807 static Scheme_Object *
00808 string_to_keyword_prim (int argc, Scheme_Object *argv[])
00809 {
00810   if (!SCHEME_CHAR_STRINGP(argv[0]))
00811     scheme_wrong_type("string->keyword", "string", 0, argc, argv);
00812   return scheme_intern_exact_char_keyword(SCHEME_CHAR_STR_VAL(argv[0]),
00813                                      SCHEME_CHAR_STRTAG_VAL(argv[0]));
00814 }
00815 
00816 static Scheme_Object *
00817 keyword_to_string_prim (int argc, Scheme_Object *argv[])
00818 {
00819   if (!SCHEME_KEYWORDP(argv[0]))
00820     scheme_wrong_type("keyword->string", "keyword", 0, argc, argv);
00821   
00822   return scheme_make_sized_offset_utf8_string((char *)(argv[0]),
00823                                          SCHEME_SYMSTR_OFFSET(argv[0]),
00824                                          SCHEME_SYM_LEN(argv[0]));
00825 }
00826 
00827 static Scheme_Object *gensym(int argc, Scheme_Object *argv[])
00828 {
00829   char buffer[100], *str;
00830   Scheme_Object *r;
00831 
00832   if (argc)
00833     r = argv[0];
00834   else
00835     r = NULL;
00836 
00837   if (r && !SCHEME_SYMBOLP(r) && !SCHEME_CHAR_STRINGP(r))
00838     scheme_wrong_type("gensym", "symbol or string", 0, argc, argv);
00839 
00840   if (r) {
00841     char buf[64];
00842     if (SCHEME_CHAR_STRINGP(r)) {
00843       str = scheme_utf8_encode_to_buffer(SCHEME_CHAR_STR_VAL(r),
00844                                     SCHEME_CHAR_STRTAG_VAL(r),
00845                                     buf, 64);
00846     } else
00847       str = SCHEME_SYM_VAL(r);
00848     sprintf(buffer, "%.80s%d", str, gensym_counter++);
00849     str = NULL; /* because it might be GC-misaligned */
00850   } else
00851     sprintf(buffer, "g%d", gensym_counter++);
00852 
00853   r = scheme_make_symbol(buffer);
00854 
00855   return r;
00856 }
00857 
00858 Scheme_Object *scheme_symbol_append(Scheme_Object *s1, Scheme_Object *s2)
00859 {
00860   char *s;
00861   s = MALLOC_N_ATOMIC(char, SCHEME_SYM_LEN(s1) + SCHEME_SYM_LEN(s2) + 1);
00862   memcpy(s, SCHEME_SYM_VAL(s1), SCHEME_SYM_LEN(s1));
00863   memcpy(s + SCHEME_SYM_LEN(s1), SCHEME_SYM_VAL(s2), SCHEME_SYM_LEN(s2) + 1);
00864   if (SCHEME_SYM_UNINTERNEDP(s1) || SCHEME_SYM_UNINTERNEDP(s2))
00865     return scheme_make_exact_symbol(s, SCHEME_SYM_LEN(s1) + SCHEME_SYM_LEN(s2));
00866   else if (SCHEME_SYM_PARALLELP(s1) || SCHEME_SYM_PARALLELP(s2))
00867     return scheme_intern_exact_parallel_symbol(s, SCHEME_SYM_LEN(s1) + SCHEME_SYM_LEN(s2));
00868   else
00869     return scheme_intern_exact_symbol(s, SCHEME_SYM_LEN(s1) + SCHEME_SYM_LEN(s2));
00870 }