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

Fixed bug that reading map literal didn't evaluate values.

Browse source
This commit is contained in:
Simon Brooke 2021-09-12 15:28:27 +01:00
parent 40e3502247
commit 462c0c69b4
No known key found for this signature in database
GPG key ID: A7A4F18D1D4DF987
3 changed files with 71 additions and 36 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

33
src/io/read.c
View file

@ -48,9 +48,11 @@ struct cons_pointer read_number( struct stack_frame *frame,
bool seen_period ); bool seen_period );
struct cons_pointer read_list( struct stack_frame *frame, struct cons_pointer read_list( struct stack_frame *frame,
struct cons_pointer frame_pointer, struct cons_pointer frame_pointer,
struct cons_pointer env,
URL_FILE * input, wint_t initial ); URL_FILE * input, wint_t initial );
struct cons_pointer read_map( struct stack_frame *frame, struct cons_pointer read_map( struct stack_frame *frame,
struct cons_pointer frame_pointer, struct cons_pointer frame_pointer,
struct cons_pointer env,
URL_FILE * input, wint_t initial ); URL_FILE * input, wint_t initial );
struct cons_pointer read_string( URL_FILE * input, wint_t initial ); struct cons_pointer read_string( URL_FILE * input, wint_t initial );
struct cons_pointer read_symbol_or_key( URL_FILE * input, uint32_t tag, struct cons_pointer read_symbol_or_key( URL_FILE * input, uint32_t tag,
@ -142,6 +144,7 @@ struct cons_pointer read_path( URL_FILE * input, wint_t initial,
*/ */
struct cons_pointer read_continuation( struct stack_frame *frame, struct cons_pointer read_continuation( struct stack_frame *frame,
struct cons_pointer frame_pointer, struct cons_pointer frame_pointer,
struct cons_pointer env,
URL_FILE * input, wint_t initial ) { URL_FILE * input, wint_t initial ) {
debug_print( L"entering read_continuation\n", DEBUG_IO ); debug_print( L"entering read_continuation\n", DEBUG_IO );
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
@ -171,16 +174,16 @@ struct cons_pointer read_continuation( struct stack_frame *frame,
case '\'': case '\'':
result = result =
c_quote( read_continuation c_quote( read_continuation
( frame, frame_pointer, input, ( frame, frame_pointer, env, input,
url_fgetwc( input ) ) ); url_fgetwc( input ) ) );
break; break;
case '(': case '(':
result = result =
read_list( frame, frame_pointer, input, read_list( frame, frame_pointer, env, input,
url_fgetwc( input ) ); url_fgetwc( input ) );
break; break;
case '{': case '{':
result = read_map( frame, frame_pointer, input, result = read_map( frame, frame_pointer, env, input,
url_fgetwc( input ) ); url_fgetwc( input ) );
break; break;
case '"': case '"':
@ -210,8 +213,8 @@ struct cons_pointer read_continuation( struct stack_frame *frame,
/* dotted pair. \todo this isn't right, we /* dotted pair. \todo this isn't right, we
* really need to backtrack up a level. */ * really need to backtrack up a level. */
result = result =
read_continuation( frame, frame_pointer, input, read_continuation( frame, frame_pointer, env,
url_fgetwc( input ) ); input, url_fgetwc( input ) );
debug_print debug_print
( L"read_continuation: dotted pair; read cdr ", ( L"read_continuation: dotted pair; read cdr ",
DEBUG_IO ); DEBUG_IO );
@ -383,6 +386,7 @@ struct cons_pointer read_number( struct stack_frame *frame,
*/ */
struct cons_pointer read_list( struct stack_frame *frame, struct cons_pointer read_list( struct stack_frame *frame,
struct cons_pointer frame_pointer, struct cons_pointer frame_pointer,
struct cons_pointer env,
URL_FILE * input, wint_t initial ) { URL_FILE * input, wint_t initial ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
wint_t c; wint_t c;
@ -391,7 +395,7 @@ struct cons_pointer read_list( struct stack_frame *frame,
debug_printf( DEBUG_IO, debug_printf( DEBUG_IO,
L"read_list starting '%C' (%d)\n", initial, initial ); L"read_list starting '%C' (%d)\n", initial, initial );
struct cons_pointer car = struct cons_pointer car =
read_continuation( frame, frame_pointer, input, read_continuation( frame, frame_pointer, env, input,
initial ); initial );
/* skip whitespace */ /* skip whitespace */
@ -406,10 +410,12 @@ struct cons_pointer read_list( struct stack_frame *frame,
make_cons( car, make_cons( car,
c_car( read_list( frame, c_car( read_list( frame,
frame_pointer, frame_pointer,
env,
input, url_fgetwc( input ) ) ) ); input, url_fgetwc( input ) ) ) );
} else { } else {
result = result =
make_cons( car, read_list( frame, frame_pointer, input, c ) ); make_cons( car,
read_list( frame, frame_pointer, env, input, c ) );
} }
} else { } else {
debug_print( L"End of list detected\n", DEBUG_IO ); debug_print( L"End of list detected\n", DEBUG_IO );
@ -420,6 +426,7 @@ struct cons_pointer read_list( struct stack_frame *frame,
struct cons_pointer read_map( struct stack_frame *frame, struct cons_pointer read_map( struct stack_frame *frame,
struct cons_pointer frame_pointer, struct cons_pointer frame_pointer,
struct cons_pointer env,
URL_FILE * input, wint_t initial ) { URL_FILE * input, wint_t initial ) {
// set write ACL to true whilst creating to prevent GC churn // set write ACL to true whilst creating to prevent GC churn
struct cons_pointer result = struct cons_pointer result =
@ -428,21 +435,23 @@ struct cons_pointer read_map( struct stack_frame *frame,
while ( c != L'}' ) { while ( c != L'}' ) {
struct cons_pointer key = struct cons_pointer key =
read_continuation( frame, frame_pointer, input, c ); read_continuation( frame, frame_pointer, env, input, c );
/* skip whitespace */ /* skip whitespace */
for ( c = url_fgetwc( input ); iswblank( c ) || iswcntrl( c ); for ( c = url_fgetwc( input ); iswblank( c ) || iswcntrl( c );
c = url_fgetwc( input ) ); c = url_fgetwc( input ) );
struct cons_pointer value = struct cons_pointer value =
read_continuation( frame, frame_pointer, input, c ); read_continuation( frame, frame_pointer, env, input, c );
/* skip commaa and whitespace at this point. */ /* skip commaa and whitespace at this point. */
for ( c = url_fgetwc( input ); for ( c = url_fgetwc( input );
c == L',' || iswblank( c ) || iswcntrl( c ); c == L',' || iswblank( c ) || iswcntrl( c );
c = url_fgetwc( input ) ); c = url_fgetwc( input ) );
result = hashmap_put( result, key, value ); result =
hashmap_put( result, key,
eval_form( frame, frame_pointer, value, env ) );
} }
// default write ACL for maps should be NIL. // default write ACL for maps should be NIL.
@ -536,7 +545,7 @@ struct cons_pointer read_symbol_or_key( URL_FILE * input, uint32_t tag,
struct cons_pointer read( struct struct cons_pointer read( struct
stack_frame stack_frame
*frame, struct cons_pointer frame_pointer, *frame, struct cons_pointer frame_pointer,
URL_FILE * input ) { struct cons_pointer env, URL_FILE * input ) {
return read_continuation( frame, frame_pointer, input, return read_continuation( frame, frame_pointer, env, input,
url_fgetwc( input ) ); url_fgetwc( input ) );
} }

4
src/io/read.h
View file

@ -11,11 +11,13 @@
#ifndef __read_h #ifndef __read_h
#define __read_h #define __read_h
#include "memory/consspaceobject.h"
/** /**
* read the next object on this input stream and return a cons_pointer to it. * read the next object on this input stream and return a cons_pointer to it.
*/ */
struct cons_pointer read( struct stack_frame *frame, struct cons_pointer read( struct stack_frame *frame,
struct cons_pointer frame_pointer, struct cons_pointer frame_pointer,
URL_FILE * input ); struct cons_pointer env, URL_FILE * input );
#endif #endif

70
src/ops/lispops.c
View file

@ -63,21 +63,45 @@ struct cons_pointer eval_form( struct stack_frame *parent,
debug_print_object( form, DEBUG_EVAL ); debug_print_object( form, DEBUG_EVAL );
debug_println( DEBUG_EVAL ); debug_println( DEBUG_EVAL );
struct cons_pointer result = NIL; struct cons_pointer result = form;
struct cons_pointer next_pointer = make_empty_frame( parent_pointer ); switch ( pointer2cell( form ).tag.value ) {
inc_ref( next_pointer ); /* things which evaluate to themselves */
case EXCEPTIONTV:
case FREETV: // shouldn't happen, but anyway...
// FUNCTIONTV, LAMBDATV, NLAMBDATV, SPECIALTV ?
case INTEGERTV:
case KEYTV:
case LOOPTV: // don't think this should happen...
case NILTV:
case RATIOTV:
case REALTV:
case READTV:
case STRINGTV:
case TIMETV:
case TRUETV:
// case VECTORPOINTTV: ?
case WRITETV:
break;
default:
{
struct cons_pointer next_pointer =
make_empty_frame( parent_pointer );
inc_ref( next_pointer );
struct stack_frame *next = get_stack_frame( next_pointer ); struct stack_frame *next = get_stack_frame( next_pointer );
set_reg( next, 0, form ); set_reg( next, 0, form );
next->args = 1; next->args = 1;
result = lisp_eval( next, next_pointer, env ); result = lisp_eval( next, next_pointer, env );
if ( !exceptionp( result ) ) { if ( !exceptionp( result ) ) {
/* if we're returning an exception, we should NOT free the /* if we're returning an exception, we should NOT free the
* stack frame. Corollary is, when we free an exception, we * stack frame. Corollary is, when we free an exception, we
* should free all the frames it's holding on to. */ * should free all the frames it's holding on to. */
dec_ref( next_pointer ); dec_ref( next_pointer );
}
}
break;
} }
debug_print( L"eval_form returning: ", DEBUG_EVAL ); debug_print( L"eval_form returning: ", DEBUG_EVAL );
@ -113,16 +137,16 @@ struct cons_pointer eval_forms( struct stack_frame *frame,
} }
/** /**
* OK, the idea here (and I know this is less than perfect) is that the basic `try` * OK, the idea here (and I know this is less than perfect) is that the basic `try`
* function in PSSE takes two arguments, the first, `body`, being a list of forms, * function in PSSE takes two arguments, the first, `body`, being a list of forms,
* and the second, `catch`, being a catch handler (which is also a list of forms). * and the second, `catch`, being a catch handler (which is also a list of forms).
* Forms from `body` are evaluated in turn until one returns an exception object, * Forms from `body` are evaluated in turn until one returns an exception object,
* or until the list is exhausted. If the list was exhausted, then the value of * or until the list is exhausted. If the list was exhausted, then the value of
* evaluating the last form in `body` is returned. If an exception was encountered, * evaluating the last form in `body` is returned. If an exception was encountered,
* then each of the forms in `catch` is evaluated and the value of the last of * then each of the forms in `catch` is evaluated and the value of the last of
* those is returned. * those is returned.
* *
* This is experimental. It almost certainly WILL change. * This is experimental. It almost certainly WILL change.
*/ */
struct cons_pointer lisp_try( struct stack_frame *frame, struct cons_pointer lisp_try( struct stack_frame *frame,
struct cons_pointer frame_pointer, struct cons_pointer frame_pointer,
@ -891,7 +915,7 @@ lisp_read( struct stack_frame *frame, struct cons_pointer frame_pointer,
input = file_to_url_file( stdin ); input = file_to_url_file( stdin );
} }
struct cons_pointer result = read( frame, frame_pointer, input ); struct cons_pointer result = read( frame, frame_pointer, env, input );
debug_print( L"lisp_read returning\n", DEBUG_IO ); debug_print( L"lisp_read returning\n", DEBUG_IO );
debug_dump_object( result, DEBUG_IO ); debug_dump_object( result, DEBUG_IO );
@ -1406,7 +1430,7 @@ struct cons_pointer c_append( struct cons_pointer l1, struct cons_pointer l2 ) {
} }
/** /**
* should really be overwritten with a version in Lisp, since this is much easier to write in Lisp * should really be overwritten with a version in Lisp, since this is much easier to write in Lisp
*/ */
struct cons_pointer lisp_append( struct stack_frame *frame, struct cons_pointer lisp_append( struct stack_frame *frame,
struct cons_pointer frame_pointer, struct cons_pointer frame_pointer,
@ -1476,7 +1500,7 @@ struct cons_pointer lisp_list( struct stack_frame *frame,
} }
/** /**
* Special form: evaluate a series of forms in an environment in which * Special form: evaluate a series of forms in an environment in which
* these bindings are bound. * these bindings are bound.
* This is `let*` in Common Lisp parlance; `let` in Clojure parlance. * This is `let*` in Common Lisp parlance; `let` in Clojure parlance.
*/ */