Tactical commit only. Something is badly broken in read, although I think

this version is better thwan the last one.
This commit is contained in:
Simon Brooke 2026-05-07 21:07:16 +01:00
parent d1bfb029b8
commit 6f39dae75f
2 changed files with 217 additions and 217 deletions

View file

@ -42,9 +42,9 @@
#include "ops/assoc.h"
#include "ops/reverse.h"
#include "payloads/stack.h"
#include "ops/string_ops.h"
#include "ops/truth.h"
#include "payloads/stack.h"
// TODO: what I've copied from 0.0.6 is *weirdly* over-complex for just now.
// I think I'm going to essentially delete all this and start again. We need
@ -77,21 +77,21 @@
* 1. The read table currently in use;
* 2. The character most recently read from that stream.
*/
struct pso_pointer read_example( struct pso_pointer frame_pointer ) {
struct pso4 *frame = pointer_to_pso4( frame_pointer );
struct pso_pointer stream = fetch_arg( frame, 0 );
struct pso_pointer readtable = fetch_arg( frame, 1 );
struct pso_pointer character = fetch_arg( frame, 2 );
struct pso_pointer result = nil;
struct pso_pointer read_example(struct pso_pointer frame_pointer) {
struct pso4 *frame = pointer_to_pso4(frame_pointer);
struct pso_pointer stream = fetch_arg(frame, 0);
struct pso_pointer readtable = fetch_arg(frame, 1);
struct pso_pointer character = fetch_arg(frame, 2);
struct pso_pointer result = nil;
return result;
return result;
}
struct pso_pointer make_eof_exception( struct pso_pointer frame_pointer ) {
return make_exception( make_frame( 1, frame_pointer,
c_string_to_lisp_string
( frame_pointer,
L"Read: end of input while reading" ) ) );
struct pso_pointer make_eof_exception(struct pso_pointer frame_pointer) {
return make_exception(
make_frame(1, frame_pointer,
c_string_to_lisp_string(
frame_pointer, L"Read: end of input while reading")));
}
/**
@ -106,20 +106,20 @@ struct pso_pointer make_eof_exception( struct pso_pointer frame_pointer ) {
* @return a string of one character, namely the next available character
* on my stream, if any, else nil.
*/
struct pso_pointer read_character( struct pso_pointer frame_pointer ) {
struct pso4 *frame = pointer_to_pso4( frame_pointer );
struct pso_pointer result = nil;
struct pso_pointer stream_pointer = fetch_arg( frame, 0 );
if ( readp( stream_pointer ) ) {
wint_t chr = url_fgetwc( stream_get_url_file( stream_pointer ) );
result = make_character( frame_pointer, chr );
struct pso_pointer read_character(struct pso_pointer frame_pointer) {
struct pso4 *frame = pointer_to_pso4(frame_pointer);
struct pso_pointer result = nil;
struct pso_pointer stream_pointer = fetch_arg(frame, 0);
if (readp(stream_pointer)) {
wint_t chr = url_fgetwc(stream_get_url_file(stream_pointer));
result = make_character(frame_pointer, chr);
#ifdef DEBUG
debug_printf( DEBUG_IO, 0, L"\nRead character %lc\n", chr );
debug_printf(DEBUG_IO, 0, L"\nRead character %lc\n", chr);
#endif
}
}
return result;
return result;
}
/**
@ -128,82 +128,75 @@ struct pso_pointer read_character( struct pso_pointer frame_pointer ) {
* potentially the first such character. Returns the first non-space character
* encountered, or an exception.
*/
struct pso_pointer skip_whitespace( struct pso_pointer frame_pointer ) {
struct pso4 *frame = pointer_to_pso4( frame_pointer );
struct pso_pointer stream = fetch_arg( frame, 0 );
struct pso_pointer readtable = fetch_arg( frame, 1 );
struct pso_pointer character = fetch_arg( frame, 2 );
struct pso_pointer result = nil;
struct pso_pointer skip_whitespace(struct pso_pointer frame_pointer) {
struct pso4 *frame = pointer_to_pso4(frame_pointer);
struct pso_pointer stream = fetch_arg(frame, 0);
struct pso_pointer readtable = fetch_arg(frame, 1);
struct pso_pointer character = fetch_arg(frame, 2);
struct pso_pointer result = nil;
do {
if (!characterp(character)) {
character = read_character(make_frame( 1, frame_pointer, stream));
}
if (characterp(character)) {
wchar_t wc = pointer_to_object(character)->payload.character.character;
if (!iswspace(wc) && !iswcntrl(wc) && wc != L',') {
result = character;
} else if (exceptionp(character)){
result = character;
} else {
character = nil;
}
}
} while (c_nilp(result));
if ( characterp( character ) ) {
wchar_t wc =
pointer_to_object( character )->payload.character.character;
if ( !iswspace( wc ) && wc != L',' ) {
result = character;
}
}
if ( c_nilp( result ) && readp( stream ) ) {
URL_FILE *input = pointer_to_object( stream )->payload.stream.stream;
wint_t wc = url_fgetwc( input );
while ( iswspace( wc ) || wc == L',' ) {
wc = url_fgetwc( input );
}
result =
( wc ==
WEOF ) ? make_eof_exception( frame_pointer ) :
make_character( frame_pointer, wc );
}
return result;
return result;
}
struct pso_pointer read_list( struct pso_pointer frame_pointer ) {
struct pso4 *frame = pointer_to_pso4( frame_pointer );
struct pso_pointer stream = fetch_arg( frame, 0 );
struct pso_pointer readtable = fetch_arg( frame, 1 );
struct pso_pointer character = fetch_arg( frame, 2 );
struct pso_pointer result = nil;
struct pso_pointer read_list(struct pso_pointer frame_pointer) {
struct pso4 *frame = pointer_to_pso4(frame_pointer);
struct pso_pointer stream = fetch_arg(frame, 0);
struct pso_pointer readtable = fetch_arg(frame, 1);
struct pso_pointer character = fetch_arg(frame, 2);
struct pso_pointer result = nil;
if ( !c_nilp( character ) && characterp( character ) &&
pointer_to_object( character )->payload.character.character ==
SYNTAX_LPAR ) {
// it's OK if an LPAR is passed in, but we don't want it now.
character = nil;
}
if ( !c_nilp( character ) ) {
// if anything other than LPAR is passed in as character, TODO: throw exception.
}
if (!c_nilp(character) && characterp(character) &&
pointer_to_object(character)->payload.character.character ==
SYNTAX_LPAR) {
// it's OK if an LPAR is passed in, but we don't want it now.
character = nil;
}
if (!c_nilp(character)) {
// if anything other than LPAR is passed in as character, TODO: throw
// exception.
}
while ( c_nilp( character ) || ( characterp( character ) &&
pointer_to_object( character )->
payload.character.character !=
SYNTAX_RPAR ) ) {
character =
skip_whitespace( make_frame
( 3, frame_pointer, stream, readtable,
character ) );
struct pso_pointer r =
read( make_frame
( 3, frame_pointer, stream, readtable, character ) );
do {
character = skip_whitespace(
make_frame(3, frame_pointer, stream, readtable, character));
struct pso_pointer r =
read(make_frame(3, frame_pointer, stream, readtable, character));
if ( exceptionp( r ) ) {
result = r;
break;
} else {
result = make_cons( frame_pointer, r, result );
character =
skip_whitespace( make_frame
( 3, frame_pointer, stream, readtable,
character ) );
}
}
if (exceptionp(r)) {
result = r;
break;
} else {
result = make_cons(frame_pointer, r, result);
character = skip_whitespace(
make_frame(3, frame_pointer, stream, readtable, character));
struct pso2 *ch = pointer_to_object(character);
return consp( result ) ? c_reverse( frame_pointer, result ) : result;
debug_dump_object(character, DEBUG_IO, 2);
}
} while (c_nilp(character) ||
(characterp(character) &&
pointer_to_object(character)->payload.character.character !=
SYNTAX_RPAR));
return consp(result) ? c_reverse(frame_pointer, result) : result;
}
/**
* @brief Read one integer from the stream and return it.
*
@ -214,76 +207,78 @@ struct pso_pointer read_list( struct pso_pointer frame_pointer ) {
* 1. The read table currently in use;
* 2. The character most recently read from that stream.
*/
struct pso_pointer read_number( struct pso_pointer frame_pointer ) {
struct pso4 *frame = pointer_to_pso4( frame_pointer );
struct pso_pointer stream = fetch_arg( frame, 0 );
struct pso_pointer readtable = fetch_arg( frame, 1 );
struct pso_pointer character = fetch_arg( frame, 2 );
struct pso_pointer result = nil;
struct pso_pointer read_number(struct pso_pointer frame_pointer) {
struct pso4 *frame = pointer_to_pso4(frame_pointer);
struct pso_pointer stream = fetch_arg(frame, 0);
struct pso_pointer readtable = fetch_arg(frame, 1);
struct pso_pointer character = fetch_arg(frame, 2);
struct pso_pointer result = nil;
int base = 10;
// TODO: should check for *read-base* in the environment
int64_t value = 0;
int base = 10;
// TODO: should check for *read-base* in the environment
int64_t value = 0;
if ( readp( stream ) ) {
if ( c_nilp( character ) ) {
character =
read_character( make_frame( 1, frame_pointer, stream ) );
}
wchar_t c = c_nilp( character )
? 0 : pointer_to_object( character )->payload.character.character;
if (readp(stream)) {
if (c_nilp(character)) {
character = read_character(make_frame(1, frame_pointer, stream));
}
wchar_t c =
c_nilp(character)
? 0
: pointer_to_object(character)->payload.character.character;
URL_FILE *input = pointer_to_object( stream )->payload.stream.stream;
for ( ; iswdigit( c ) || c == L','; c = url_fgetwc( input ) ) {
if ( iswdigit( c ) ) {
value = ( value * base ) + ( ( int ) c - ( int ) L'0' );
}
}
URL_FILE *input = pointer_to_object(stream)->payload.stream.stream;
for (; iswdigit(c) || c == L','; c = url_fgetwc(input)) {
if (iswdigit(c)) {
value = (value * base) + ((int)c - (int)L'0');
}
}
url_ungetwc( c, input );
result = make_integer( frame_pointer, value );
} // else exception?
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 );
debug_dump_object( result, DEBUG_IO, 1 );
debug_printf(DEBUG_IO, 0, L"\nRead number %ld\n", value);
debug_dump_object(result, DEBUG_IO, 1);
#endif
return result;
return result;
}
struct pso_pointer read_symbol( struct pso_pointer frame_pointer ) {
struct pso4 *frame = pointer_to_pso4( frame_pointer );
struct pso_pointer stream = fetch_arg( frame, 0 );
struct pso_pointer readtable = fetch_arg( frame, 1 );
struct pso_pointer character = fetch_arg( frame, 2 );
struct pso_pointer result = nil;
struct pso_pointer read_symbol(struct pso_pointer frame_pointer) {
struct pso4 *frame = pointer_to_pso4(frame_pointer);
struct pso_pointer stream = fetch_arg(frame, 0);
struct pso_pointer readtable = fetch_arg(frame, 1);
struct pso_pointer character = fetch_arg(frame, 2);
struct pso_pointer result = nil;
if ( readp( stream ) ) {
if ( c_nilp( character ) ) {
character =
read_character( make_frame( 1, frame_pointer, stream ) );
}
if (readp(stream)) {
if (c_nilp(character)) {
character = read_character(make_frame(1, frame_pointer, stream));
}
wchar_t c = c_nilp( character )
? 0 : pointer_to_object( character )->payload.character.character;
wchar_t c =
c_nilp(character)
? 0
: pointer_to_object(character)->payload.character.character;
URL_FILE *input = pointer_to_object( stream )->payload.stream.stream;
for ( ; symbol_char_p( c ); c = url_fgetwc( input ) ) {
result =
make_string_like_thing( frame_pointer, c, result, SYMBOLTAG );
}
URL_FILE *input = pointer_to_object(stream)->payload.stream.stream;
for (; symbol_char_p(c); c = url_fgetwc(input)) {
result =
make_string_like_thing(frame_pointer, c, result, SYMBOLTAG);
}
url_ungetwc( c, input );
result = c_reverse( frame_pointer, result );
}
url_ungetwc(c, input);
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 );
debug_dump_object( result, DEBUG_IO, 1 );
debug_print(L"\nRead symbol `", DEBUG_IO, 0);
debug_print_object(result, DEBUG_IO, 0);
debug_print(L"`\n\t", DEBUG_IO, 0);
debug_dump_object(result, DEBUG_IO, 1);
#endif
return result;
return result;
}
/**
@ -297,86 +292,85 @@ struct pso_pointer read_symbol( struct pso_pointer frame_pointer ) {
* 1. The read table currently in use;
* 2. The character most recently read from that stream.
*/
struct pso_pointer read( struct pso_pointer frame_pointer ) {
struct pso4 *frame = pointer_to_pso4( frame_pointer );
struct pso_pointer stream = fetch_arg( frame, 0 );
struct pso_pointer readtable = fetch_arg( frame, 1 );
struct pso_pointer character = fetch_arg( frame, 2 );
struct pso_pointer read(struct pso_pointer frame_pointer) {
struct pso4 *frame = pointer_to_pso4(frame_pointer);
struct pso_pointer stream = fetch_arg(frame, 0);
struct pso_pointer readtable = fetch_arg(frame, 1);
struct pso_pointer character = fetch_arg(frame, 2);
struct pso_pointer result = nil;
struct pso_pointer result = nil;
if ( c_nilp( stream ) ) {
stream =
make_read_stream( frame_pointer, file_to_url_file( stdin ), nil );
}
if (c_nilp(stream)) {
stream = make_read_stream(frame_pointer, file_to_url_file(stdin), nil);
}
if ( c_nilp( readtable ) ) {
readtable = c_assoc( lisp_io_read_table, fetch_env( frame_pointer ) );
}
if (c_nilp(readtable)) {
readtable = c_assoc(lisp_io_read_table, fetch_env(frame_pointer));
}
if ( c_nilp( character ) ) {
character = skip_whitespace( make_frame( 1, frame_pointer, stream ) );
}
if (c_nilp(character)) {
character = skip_whitespace(make_frame(1, frame_pointer, stream));
}
struct pso_pointer readmacro = c_assoc( character, readtable );
struct pso_pointer readmacro = c_assoc(character, readtable);
if ( !c_nilp( readmacro ) ) {
// invoke the read macro on the stream
} else if ( readp( stream ) && characterp( character ) ) {
wchar_t c =
pointer_to_object( character )->payload.character.character;
URL_FILE *input = pointer_to_object( stream )->payload.stream.stream;
if (!c_nilp(readmacro)) {
// invoke the read macro on the stream
} else if (readp(stream) && characterp(character)) {
wchar_t c = pointer_to_object(character)->payload.character.character;
URL_FILE *input = pointer_to_object(stream)->payload.stream.stream;
switch ( c ) {
case SYNTAX_SEMICOLON:
for ( c = url_fgetwc( input ); c != '\n';
c = url_fgetwc( input ) );
/* skip all characters from semi-colon to the end of the line */
break;
case SYNTAX_LPAR:
result =
read_list( make_frame( 3, stream, readtable, character ) );
break;
case EOF:
result = make_eof_exception( frame_pointer );
break;
default:
struct pso_pointer next = make_frame( 3, frame_pointer, stream,
readtable,
make_character
( frame_pointer, c ) );
inc_ref( next );
if ( iswdigit( c ) ) {
result = push_local( frame_pointer, read_number( next ) );
} else if ( symbol_char_p( c ) ) {
result = push_local( frame_pointer, read_symbol( next ) );
} else {
// result =
// throw_exception(
// c_string_to_lisp_symbol( L"read" ),
// make_cons(
// c_string_to_lisp_string
// (
// L"Unrecognised
// start of
// input
// character"
// ),
// make_string(
// c, NIL )
// ),
// frame_pointer );
}
// dec_ref( next );
break;
}
}
switch (c) {
case SYNTAX_SEMICOLON:
for (c = url_fgetwc(input); c != '\n'; c = url_fgetwc(input))
;
/* skip all characters from semi-colon to the end of the line */
break;
case SYNTAX_LPAR:
result = read_list(make_frame(3, frame_pointer, stream, readtable, character));
break;
case EOF:
result = make_eof_exception(frame_pointer);
break;
default:
struct pso_pointer next =
make_frame(3, frame_pointer, stream, readtable,
make_character(frame_pointer, c));
inc_ref(next);
if (iswdigit(c)) {
result = push_local(frame_pointer, read_number(next));
} else if (symbol_char_p(c)) {
result = push_local(frame_pointer, read_symbol(next));
} else {
// result =
// throw_exception(
// c_string_to_lisp_symbol( L"read"
// ),
// make_cons(
// c_string_to_lisp_string
// (
// L"Unrecognised
// start
// of
// input
// character"
// ),
// make_string(
// c, NIL
// )
// ),
// frame_pointer );
}
// dec_ref( next );
break;
}
}
#ifdef DEBUG
debug_print( L"Read expression: `", DEBUG_IO, 0 );
debug_print_object( result, DEBUG_IO, 0 );
debug_print( L"`\n", DEBUG_IO, 0 );
debug_dump_object( result, DEBUG_IO, 1 );
debug_print(L"Read expression: `", DEBUG_IO, 0);
debug_print_object(result, DEBUG_IO, 0);
debug_print(L"`\n", DEBUG_IO, 0);
debug_dump_object(result, DEBUG_IO, 1);
#endif
return result;
return result;
}

View file

@ -197,7 +197,9 @@ struct pso_pointer dump_object( struct pso_pointer frame_pointer ) {
// url_fputws( L"\n", output );
// fflush(stderr);
URL_FILE *output = pointer_to_object( stream )->payload.stream.stream;
URL_FILE *output = writep(stream) ?
pointer_to_object( stream )->payload.stream.stream :
file_to_url_file(stderr);
if ( c_nilp( pointer ) ) {
// the object at (node, 0, 0) ought to have been initialised, but may not
@ -214,6 +216,10 @@ struct pso_pointer dump_object( struct pso_pointer frame_pointer ) {
pointer.offset, object->header.count );
switch ( get_tag_value( pointer ) ) {
case CHARACTERTV: {
wchar_t wc = pointer_to_object(pointer)->payload.character.character;
url_fwprintf(output, L"\t\tCharacter object: character `%lc` (%d)\n", wc, wc);
} break;
case CONSTV:
url_fwprintf( output,
L"\t\tCons object: car at page %d offset %d, cdr at page %d "