Started to try to get back into this; work on exceptions and loops.

.vscode/settings.json

@@ -0,0 +1,7 @@
+{
+    "files.associations": {
+        "future": "cpp",
+        "system_error": "cpp",
+        "functional": "c"
+    }
+}

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:

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;

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. */
+  /** The payload: usually a Lisp string but in practice anything printable will do. */
-    struct cons_pointer message;
+    struct cons_pointer payload;
   /** pointer to the (unfreed) stack frame in which the exception was thrown. */
     struct cons_pointer frame;
 };

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

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 <simon@journeyman.cc>
+ * Licensed under GPL version 2.0, or, at your option, any later version.
+ */
+
+#include <ctype.h>
+#include <stdbool.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+
+#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;
+}
+
+

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;

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.