simon/post-scarcity
1
0
Fork 0
Code Issues 18 Pull requests Projects Releases Packages Wiki Activity Actions

Investigating why symbols created by read are not equal to those created in C.

Browse source
This commit is contained in:
Simon Brooke 2026-05-06 09:16:46 +01:00
parent 1cfd333e26
commit cf655e8020
6 changed files with 67 additions and 123 deletions
Download patch file Download diff file Expand all files Collapse all files

16
src/c/environment/function_bindings.c
View file

@ -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;

24
src/c/io/read.c
View file

@ -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;

23
src/c/ops/assoc.c
View file

@ -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 ) ) {

112
src/c/ops/eval_apply.c
View file

@ -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 <simon@journeyman.cc>
* 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 ) ) {

5
src/c/ops/string_ops.c
View file

@ -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 );
}
}

10
src/c/payloads/symbol.h
View file

@ -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. */