From cf655e8020abc9785588d1e22db8880a9a07f1d9 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 6 May 2026 09:16:46 +0100 Subject: [PATCH] Investigating why symbols created by `read` are not equal to those created in C. --- src/c/environment/function_bindings.c | 16 ++-- src/c/io/read.c | 24 +++++- src/c/ops/assoc.c | 23 +++++- src/c/ops/eval_apply.c | 112 ++------------------------ src/c/ops/string_ops.c | 5 +- src/c/payloads/symbol.h | 10 +++ 6 files changed, 67 insertions(+), 123 deletions(-) diff --git a/src/c/environment/function_bindings.c b/src/c/environment/function_bindings.c index 50225a9..cae295e 100644 --- a/src/c/environment/function_bindings.c +++ b/src/c/environment/function_bindings.c @@ -177,13 +177,13 @@ struct function_data function_initialisers[] = { U"return that expression unevaluated.", &read}, {U"read-character", - U"(read_character stream): read a single character from `stream` and " + U"(read-character stream): read a single character from `stream` and " U"return it.", &read_character}, - {U"read_number", + {U"read-number", U"(read-number stream): read a number from `stream` and return it.", &read_number}, - {U"read_symbol", + {U"read-symbol", U"(read-symbol stream): read a symbol from `stream` and return it.", &read_symbol}, #endif @@ -318,16 +318,18 @@ initialise_function_bindings(struct pso_pointer frame_pointer) { struct pso_pointer result = fetch_env(frame_pointer); for (int i = 0; function_initialisers[i].executable != NULL; i++) { - result = bind_function(push_local(frame_pointer, make_frame_with_env(0, frame_pointer, result)), + struct pso_pointer b = c_car( bind_function( frame_pointer, function_initialisers[i].name, function_initialisers[i].documentation, - function_initialisers[i].executable); + function_initialisers[i].executable)); + result = make_cons( frame_pointer, b, result); } for (int i = 0; special_initialisers[i].executable != NULL; i++) { - result = bind_function(push_local( frame_pointer, make_frame_with_env(0, frame_pointer, result)), + struct pso_pointer b = c_car( bind_special( frame_pointer, special_initialisers[i].name, special_initialisers[i].documentation, - special_initialisers[i].executable); + special_initialisers[i].executable)); + result = make_cons( frame_pointer, b, result); } return result; diff --git a/src/c/io/read.c b/src/c/io/read.c index 5c09457..fa244c8 100644 --- a/src/c/io/read.c +++ b/src/c/io/read.c @@ -33,10 +33,12 @@ #include "memory/tags.h" #include "payloads/character.h" +#include "payloads/cons.h" #include "payloads/exception.h" #include "payloads/function.h" #include "payloads/integer.h" #include "payloads/read_stream.h" +#include "payloads/symbol.h" #include "ops/assoc.h" #include "ops/reverse.h" @@ -150,6 +152,9 @@ struct pso_pointer read_number( struct pso_pointer frame_pointer ) { url_ungetwc( c, input ); result = make_integer( frame_pointer, value ); } // else exception? +#ifdef DEBUG + debug_printf( DEBUG_IO, 0, L"\nRead number %ld\n", value ); +#endif return result; } @@ -171,7 +176,7 @@ struct pso_pointer read_symbol( struct pso_pointer frame_pointer ) { ? 0 : pointer_to_object( character )->payload.character.character; URL_FILE *input = pointer_to_object( stream )->payload.stream.stream; - for ( ; iswalnum( c ); c = url_fgetwc( input ) ) { + for ( ; symbol_char_p( c ); c = url_fgetwc( input ) ) { result = make_string_like_thing( frame_pointer, c, result, SYMBOLTAG ); } @@ -180,6 +185,17 @@ struct pso_pointer read_symbol( struct pso_pointer frame_pointer ) { result = c_reverse( frame_pointer, result ); } +#ifdef DEBUG + debug_print( L"\nRead symbol `", DEBUG_IO, 0 ); + debug_print_object( result, DEBUG_IO, 0); + debug_print( L"`\n\t", DEBUG_IO, 0); + for ( struct pso_pointer cursor = result; !c_nilp(cursor); cursor = c_cdr(cursor)) { + wint_t c = pointer_to_object(cursor)->payload.string.character; + debug_printf( DEBUG_IO, 0, L"[Character %lc (%d)]", c, c); + } + debug_println(DEBUG_IO); +#endif + return result; } @@ -244,7 +260,7 @@ struct pso_pointer read( struct pso_pointer frame_pointer ) { inc_ref( next ); if ( iswdigit( c ) ) { result = push_local( frame_pointer, read_number( next ) ); - } else if ( iswalpha( c ) ) { + } else if ( symbol_char_p( c ) ) { result = push_local( frame_pointer, read_symbol( next ) ); } else { // result = @@ -268,9 +284,9 @@ struct pso_pointer read( struct pso_pointer frame_pointer ) { } } #ifdef DEBUG - debug_print( L"Read object: ", DEBUG_IO, 0 ); + debug_print( L"Read expression: `", DEBUG_IO, 0 ); debug_print_object( result, DEBUG_IO, 0 ); - debug_println( DEBUG_IO ); + debug_print( L"`\n", DEBUG_IO, 0 ); #endif return result; diff --git a/src/c/ops/assoc.c b/src/c/ops/assoc.c index 401aeb1..6b68a19 100644 --- a/src/c/ops/assoc.c +++ b/src/c/ops/assoc.c @@ -42,9 +42,16 @@ struct pso_pointer search( struct pso_pointer key, bool found = false; #ifdef DEBUG - debug_print( L"In search; key is: ", DEBUG_BIND, 0 ); + debug_print( L"In search; key is: `", DEBUG_BIND, 0 ); debug_print_object( key, DEBUG_BIND, 0 ); - debug_println( DEBUG_BIND ); + debug_print( L"`\n", DEBUG_BIND, 0 ); + debug_print(L"", DEBUG_BIND, 2); + if (symbolp(key)) { + for ( struct pso_pointer cursor = key; !c_nilp(cursor); cursor = c_cdr(cursor)) { + wint_t c = pointer_to_object(cursor)->payload.string.character; + debug_printf( DEBUG_BIND, 0, L"[Character %lc (%d)]", c, c); + } + } #endif if ( consp( store ) ) { @@ -53,7 +60,17 @@ struct pso_pointer search( struct pso_pointer key, struct pso_pointer pair = c_car( cursor ); #ifdef DEBUG debug_print( L"Checking ", DEBUG_BIND, 2 ); - debug_print_object( pair, DEBUG_BIND, 0 ); + debug_print_object( c_car( pair), DEBUG_BIND, 0 ); + debug_println( DEBUG_BIND); + debug_print(L"", DEBUG_BIND, 4); + if (symbolp(c_car( pair))) { + for ( struct pso_pointer cursor = c_car(pair); !c_nilp(cursor); cursor = c_cdr(cursor)) { + wint_t c = pointer_to_object(cursor)->payload.string.character; + debug_printf( DEBUG_BIND, 0, L"[Character %lc (%d)]", c, c); + } + } + debug_println(DEBUG_BIND); + #endif if ( consp( pair ) && c_equal( c_car( pair ), key ) ) { diff --git a/src/c/ops/eval_apply.c b/src/c/ops/eval_apply.c index 03c1411..5ced0e2 100644 --- a/src/c/ops/eval_apply.c +++ b/src/c/ops/eval_apply.c @@ -45,112 +45,6 @@ #include "payloads/stack.h" #include "payloads/symbol.h" -///** -// * @brief Apply a function to arguments in an environment. -// * -// * * (apply fn args) -// */ -//struct pso_pointer apply( struct pso_pointer frame_pointer ) { -// -//// TODO. -// -//} -// -///** -// * @brief Evaluate a form, in an environment -// * -// * * (eval form) -// */ -//struct pso_pointer eval( struct pso_pointer frame_pointer ) { -// struct pso4 *frame = pointer_to_pso4( frame_pointer ); -// -// struct pso_pointer arg = fetch_arg( frame, 0 ); -// struct pso_pointer result = nil; -// -// if ( !c_c_nilp( arg ) ) { -// switch ( get_tag_value( arg ) ) { -// // case CONSTV: -// // result = eval_cons( frame, frame_pointer, env); -// // break; -// case INTEGERTV: -// case KEYTV: -// case NILTV: -// case STRINGTV: -// // self evaluating -// result = nil; -// break; -// case SYMBOLTV: -// result = c_assoc( arg, fetch_env( frame_pointer ) ); -// break; -// // case LAMBDATV: -// // result = eval_lambda( frame, frame_pointer, env); -// // break; -// // case NLAMBDATV: -// // result = eval_nlambda( frame, frame_pointer, env); -// // break; -// // case SPECIALTV: -// // result = eval_special( frame, frame_pointer, env); -// // break; -// default: -//#ifdef DEBUG -// struct pso2 *object = pointer_to_object( arg ); -// debug_printf( DEBUG_EVAL, 0, -// L"Can't yet evaluate objects of type %3.3s\n", -// object->header.tag.bytes.mnemonic[0] ); -// debug_print_object( arg, DEBUG_EVAL, 2 ); -// debug_println( DEBUG_EVAL, 0 ); -//#endif -// result = make_exception( make_frame( 1, frame_pointer, -// make_cons( frame_pointer, -// c_string_to_lisp_string -// ( frame_pointer, -// L"Can't yet evaluate things of this type: " ), -// arg ), -// make_cons( frame_pointer, -// make_cons -// ( frame_pointer, -// c_string_to_lisp_keyword -// ( frame_pointer, -// L"tag" ), -// get_tag_string -// ( frame_pointer, -// arg ) ), -// nil ), nil ) ); -// } -// } -// -// if ( exceptionp( result ) ) { -// struct pso3 *x = -// ( struct pso3 * ) pointer_to_object_with_tag_value( result, -// EXCEPTIONTV ); -// -// if ( c_c_nilp( x->payload.exception.stack ) ) { -// x->payload.exception.stack = frame_pointer; -// } -// } -// -// return result; -//} -/* - * lispops.c - * - * List processing operations. - * - * The general idea here is that a list processing operation is a - * function which takes two arguments, both pso_pointers: - * - * 1. args, the argument list to this function; - * 2. env, the environment in which this function should be evaluated; - * - * and returns a pso_pointer, the result. - * - * They must all have the same signature so that I can call them as - * function pointers. - * - * (c) 2017 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - /** * Useful building block; evaluate this single form in the context of this * parent stack frame and this environment. @@ -779,6 +673,12 @@ lisp_eval( struct pso_pointer frame_pointer ) { case SYMBOLTV: { +#ifdef DEBUG + debug_print( L"\nEvaluating symbol `", DEBUG_EVAL, 0); + debug_print_object( fetch_arg( frame, 0), DEBUG_EVAL, 0); + debug_print( L"`\n\tEnvironment is: ", DEBUG_EVAL, 0); + debug_dump_object( fetch_env(frame_pointer), DEBUG_EVAL, 0); +#endif struct pso_pointer canonical = c_interned( frame->payload.stack_frame.arg[0], fetch_env(frame_pointer) ); if ( c_nilp( canonical ) ) { diff --git a/src/c/ops/string_ops.c b/src/c/ops/string_ops.c index 95c6fc5..c9ff224 100644 --- a/src/c/ops/string_ops.c +++ b/src/c/ops/string_ops.c @@ -172,7 +172,6 @@ char *lisp_string_to_c_string( struct pso_pointer s ) { return result; } - /** * Return a lisp symbol representation of this wide character string. In * symbols, I am accepting only lower case characters and certain punctuation. @@ -182,9 +181,9 @@ struct pso_pointer c_string_to_lisp_symbol( struct pso_pointer frame_pointer, struct pso_pointer result = nil; for ( int i = wcslen( symbol ) - 1; i >= 0; i-- ) { - char32_t c = towlower( symbol[i] ); + char32_t c = symbol[i]; - if ( iswalpha( c ) || wcschr(L"-*|!?", c)) { + if ( symbol_char_p(c)) { result = make_symbol( frame_pointer, c, result ); } } diff --git a/src/c/payloads/symbol.h b/src/c/payloads/symbol.h index 3460983..2b0dd48 100644 --- a/src/c/payloads/symbol.h +++ b/src/c/payloads/symbol.h @@ -14,6 +14,16 @@ #include "memory/pointer.h" +/** + * @brief true if the argument `wc`, a wide character, is suitable for + * inclusion in a symbol. + * + * Note that Common Lisp is *much* less restrictive + * than this currently is, so rethinking may be necessary. + */ +#define symbol_char_p(wc)(iswalpha( wc ) || wcschr(L"-*|!?", wc)) + + /* TODO: for now, Symbol shares a payload with String, but this may change. * Strings are of indefinite length, but symbols are really not, and might * fit into any size class. */