Browse files

allow reading of uninterned symbols

  • Loading branch information...
1 parent 9c0a512 commit fdcb9831b9cfb76f226ed6d331d6ac8b79c5f7b6 @adh committed Apr 11, 2012
Showing with 29 additions and 1 deletion.
  1. +1 −0 dfsch/dfsch.h
  2. +8 −0 src/package.c
  3. +12 −1 src/parse.c
  4. +8 −0 tests/fix-regression-tests.scm
View
1 dfsch/dfsch.h
@@ -323,6 +323,7 @@ extern "C" {
/** Makes symbol object from string. */
extern dfsch_object_t* dfsch_make_symbol(char* symbol);
+ extern dfsch_object_t* dfsch_make_uninterned_symbol(char* symbol);
/** Returns unique generated symbol. */
extern dfsch_object_t* dfsch_gensym();
View
8 src/package.c
@@ -604,6 +604,14 @@ dfsch_object_t* dfsch_make_symbol(char* symbol){
return dfsch_intern_symbol(dfsch_get_current_package(), symbol);
}
+dfsch_object_t* dfsch_make_uninterned_symbol(char* symbol){
+ dfsch__symbol_t* sym;
+ sym = GC_NEW(dfsch__symbol_t);
+ sym->name = dfsch_stracpy(symbol);
+ sym->package = NULL;
+ return DFSCH_TAG_ENCODE(sym, 2);
+}
+
char* dfsch_symbol(dfsch_object_t* symbol){
symbol_t* s;
View
13 src/parse.c
@@ -740,6 +740,10 @@ static void dispatch_number_base(dfsch_parser_ctx_t *ctx, char *data){
parse_object(ctx, dfsch_make_number_from_string(data, ctx->hash_arg));
}
+static void dispatch_uninterned(dfsch_parser_ctx_t *ctx, char *data){
+ parse_object(ctx, dfsch_make_uninterned_symbol(data));
+}
+
static void dispatch_atom(dfsch_parser_ctx_t *ctx, char *data){
#ifdef T_DEBUG
printf(";; Atom: [%s]\n", data);
@@ -1056,7 +1060,14 @@ static void tokenizer_process (dfsch_parser_ctx_t *ctx, char* data){
ctx->column++;
ctx->dispatch_atom_hook=dispatch_number_base;
- ctx->tokenizer_state = T_ATOM;
+ ctx->tokenizer_state = T_ATOM;
+ break;
+ case ':':
+ ++data;
+ ctx->column++;
+
+ ctx->dispatch_atom_hook=dispatch_uninterned;
+ ctx->tokenizer_state = T_ATOM;
break;
case '\\':
View
8 tests/fix-regression-tests.scm
@@ -8,3 +8,11 @@
(define-evaluation-test fracnum-absolute-value (:regression)
((abs -1/2) ===> 1/2))
+
+(define-test gensym-print (:language :numbers)
+ (let ((l1 (string->object (object->string (let ((x (gensym)))
+ (list x x)))))
+ (l2 (string->object (object->string (let ((x (unintern 'mnau)))
+ (list x x))))))
+ (assert-equal (car l1) (cadr l1))
+ (assert-equal (car l2) (cadr l2))))

0 comments on commit fdcb983

Please sign in to comment.