diff --git a/.vscode/settings.json b/.vscode/settings.json new file mode 100644 index 0000000..14fb483 --- /dev/null +++ b/.vscode/settings.json @@ -0,0 +1,7 @@ +{ + "files.associations": { + "future": "cpp", + "system_error": "cpp", + "functional": "c" + } +} \ No newline at end of file diff --git a/src/memory/conspage.c b/src/memory/conspage.c index 2d0958d..53496d3 100644 --- a/src/memory/conspage.c +++ b/src/memory/conspage.c @@ -148,7 +148,7 @@ void free_cell( struct cons_pointer pointer ) { dec_ref( cell->payload.cons.cdr ); break; case EXCEPTIONTV: - dec_ref( cell->payload.exception.message ); + dec_ref( cell->payload.exception.payload ); dec_ref( cell->payload.exception.frame ); break; case FUNCTIONTV: diff --git a/src/memory/consspaceobject.c b/src/memory/consspaceobject.c index 344f4ae..98bb495 100644 --- a/src/memory/consspaceobject.c +++ b/src/memory/consspaceobject.c @@ -163,7 +163,7 @@ struct cons_pointer make_exception( struct cons_pointer message, inc_ref( message ); inc_ref( frame_pointer ); - cell->payload.exception.message = message; + cell->payload.exception.payload = message; cell->payload.exception.frame = frame_pointer; result = pointer; diff --git a/src/memory/consspaceobject.h b/src/memory/consspaceobject.h index 9197172..4b0500b 100644 --- a/src/memory/consspaceobject.h +++ b/src/memory/consspaceobject.h @@ -45,7 +45,8 @@ #define CONSTV 1397641027 /** - * An exception. + * An exception. TODO: we need a means of dealing with different classes of + * exception, and we don't have one yet. */ #define EXCEPTIONTAG "EXEP" @@ -108,6 +109,17 @@ */ #define LAMBDATV 1094995276 +/** + * A loop exit is a special kind of exception which has exactly the same + * payload as an exception. + */ +#define LOOPXTAG "LOOX" + +/** + * The string `LOOX`, considered as an `unsigned int`. + */ +#define LOOPXTV 1481592652 + /** * The special cons cell at address {0,0} whose car and cdr both point to * itself. @@ -286,10 +298,15 @@ #define keywordp(conspoint) (check_tag(conspoint,KEYTAG)) /** - * true if `conspoint` points to a special Lambda cell, else false + * true if `conspoint` points to a Lambda binding cell, else false */ #define lambdap(conspoint) (check_tag(conspoint,LAMBDATAG)) +/** + * true if `conspoint` points to a loop exit exception, else false. + */ +#define loopexitp(conspoint) (check_tag(conspoint,LOOPXTAG)) + /** * true if `conspoint` points to a special form cell, else false */ @@ -414,8 +431,8 @@ struct cons_payload { * Message should be a Lisp string; frame should be a pointer to an (unfreed) stack frame. */ struct exception_payload { - /** The message: should be a Lisp string but in practice anything printable will do. */ - struct cons_pointer message; + /** The payload: usually a Lisp string but in practice anything printable will do. */ + struct cons_pointer payload; /** pointer to the (unfreed) stack frame in which the exception was thrown. */ struct cons_pointer frame; }; diff --git a/src/memory/stack.c b/src/memory/stack.c index 3f4a271..d6d3c36 100644 --- a/src/memory/stack.c +++ b/src/memory/stack.c @@ -267,7 +267,8 @@ void dump_frame( URL_FILE * output, struct cons_pointer frame_pointer ) { void dump_stack_trace( URL_FILE * output, struct cons_pointer pointer ) { if ( exceptionp( pointer ) ) { - print( output, pointer2cell( pointer ).payload.exception.message ); + // todo: if the payload isn't a message, we maybe shouldn't print it? + print( output, pointer2cell( pointer ).payload.exception.payload ); url_fputws( L"\n", output ); dump_stack_trace( output, pointer2cell( pointer ).payload.exception.frame ); diff --git a/src/ops/exceptions.c b/src/ops/exceptions.c new file mode 100644 index 0000000..48c031f --- /dev/null +++ b/src/ops/exceptions.c @@ -0,0 +1,62 @@ + /* + * exceptions.c + * + * This is really, really unfinished and doesn't yet work. One of the really key + * things about exceptions is that the stack frames between the throw and the + * catch should not be derefed, so eval/apply will need to be substantially + * re-written. + * + * (c) 2021 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include +#include +#include +#include +#include + +#include "consspaceobject.h" +#include "conspage.h" +#include "debug.h" +#include "dump.h" +#include "equal.h" +#include "integer.h" +#include "intern.h" +#include "io.h" +#include "lispops.h" +#include "map.h" +#include "print.h" +#include "read.h" +#include "stack.h" +#include "vectorspace.h" + + +/** + * 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, + * 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, + * 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, + * then each of the forms in `catch` is evaluated and the value of the last of + * those is returned. + * + * This is experimental. It almost certainly WILL change. + */ +struct cons_pointer lisp_try(struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env) +{ + struct cons_pointer result = c_progn(frame, frame_pointer, frame->arg[0], env); + + if (loopexitp(result)) + { + // TODO: need to put the exception into the environment! + result = c_progn(frame, frame_pointer, frame->arg[1], env); + } + + return result; +} + + diff --git a/src/ops/lispops.c b/src/ops/lispops.c index 4e2ddbf..8dd0109 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -107,7 +107,7 @@ struct cons_pointer eval_forms( struct stack_frame *frame, list = c_cdr( list ); } - return result; + return c_reverse( result); } /** @@ -991,7 +991,7 @@ c_progn( struct stack_frame *frame, struct cons_pointer frame_pointer, result = eval_form( frame, frame_pointer, c_car( expressions ), env ); dec_ref( r ); - expressions = c_cdr( expressions ); + expressions = exceptionp(result) ? NIL : c_cdr( expressions ); } return result; @@ -1259,7 +1259,7 @@ struct cons_pointer lisp_source( struct stack_frame *frame, case SPECIALTV: result = c_assoc( source_key, cell.payload.special.meta ); break; - case LAMBDATV: + case LAMBDATV: result = make_cons( c_string_to_lisp_symbol( L"lambda" ), make_cons( cell.payload.lambda.args, cell.payload.lambda.body ) ); diff --git a/src/ops/lispops.h b/src/ops/lispops.h index 122635f..f359252 100644 --- a/src/ops/lispops.h +++ b/src/ops/lispops.h @@ -29,6 +29,10 @@ struct cons_pointer c_reverse( struct cons_pointer arg ); +struct cons_pointer +c_progn( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer expressions, struct cons_pointer env ); + /** * Useful building block; evaluate this single form in the context of this * parent stack frame and this environment. diff --git a/utils_src/tagvalcalc/tvc b/utils_src/tagvalcalc/tvc index a639364..acd850a 100755 Binary files a/utils_src/tagvalcalc/tvc and b/utils_src/tagvalcalc/tvc differ