Merge branch 'release/0.0.4'

.gitignore

@@ -28,3 +28,13 @@ log*
 \.project
 
 \.settings/language\.settings\.xml
+
+utils_src/readprintwc/out
+
+.kdev4/
+
+.vscode/
+
+hi.*
+
+post-scarcity.kdev4

Doxyfile

@@ -32,7 +32,7 @@ DOXYFILE_ENCODING      = UTF-8
 # title of most generated pages and in a few other places.
 # The default value is: My Project.
 
-PROJECT_NAME           = "\"Post Scarcity\""
+PROJECT_NAME           = "Post Scarcity"
 
 # The PROJECT_NUMBER tag can be used to enter a project or revision number. This
 # could be handy for archiving the generated documentation or if some version
@@ -58,7 +58,7 @@ PROJECT_LOGO           =
 # entered, it will be relative to the location where doxygen was started. If
 # left blank the current directory will be used.
 
-OUTPUT_DIRECTORY       = /home/simon/workspace/post-scarcity/doc
+OUTPUT_DIRECTORY       = doc
 
 # If the CREATE_SUBDIRS tag is set to YES then doxygen will create 4096 sub-
 # directories (in 2 levels) under the output directory of each output format and
@@ -778,7 +778,7 @@ WARN_FORMAT            = "$file:$line: $text"
 # messages should be written. If left blank the output is written to standard
 # error (stderr).
 
-WARN_LOGFILE           = 
+WARN_LOGFILE           = doxy.log
 
 #---------------------------------------------------------------------------
 # Configuration options related to the input files
@@ -790,7 +790,7 @@ WARN_LOGFILE           =
 # spaces. See also FILE_PATTERNS and EXTENSION_MAPPING
 # Note: If this tag is empty the current directory is searched.
 
-INPUT                  = /home/simon/workspace/post-scarcity/src
+INPUT                  = src src/arith src/memory src/ops
 
 # This tag can be used to specify the character encoding of the source files
 # that doxygen parses. Internally doxygen uses the UTF-8 encoding. Doxygen uses

Makefile

@@ -17,13 +17,13 @@ INDENT_FLAGS := -nbad -bap -nbc -br -brf -brs -c33 -cd33 -ncdb -ce -ci4 -cli4 \
 
 VERSION := "0.0.2"
 
-CPPFLAGS ?= $(INC_FLAGS) -MMD -MP -g
+CPPFLAGS ?= $(INC_FLAGS) -MMD -MP -g -DDEBUG
 LDFLAGS := -lm
 
 $(TARGET): $(OBJS) Makefile
 	$(CC) $(LDFLAGS) $(OBJS) -DVERSION=$(VERSION) -o $@ $(LDFLAGS) $(LOADLIBES) $(LDLIBS)
 
-doc: $(SRCS) Makefile
+doc: $(SRCS) Makefile Doxyfile
 	doxygen
 
 format: $(SRCS) $(HDRS) Makefile
@@ -38,7 +38,7 @@ test: $(OBJS) $(TESTS) Makefile
 
 .PHONY: clean
 clean:
-	$(RM) $(TARGET) $(OBJS) $(DEPS) $(SRC_DIRS)/*~ *~
+	$(RM) $(TARGET) $(OBJS) $(DEPS) $(SRC_DIRS)/*~ $(SRC_DIRS)/*/*~ *~
 
 repl:
 	$(TARGET) -p 2> psse.log

lisp/defun.lisp

@@ -1,10 +1,12 @@
-;; Because I don't (yet) have syntax for varargs, the body must be passed
+(set! list (lambda l l))
-;; to defun as a list of sexprs.
+
+(set! symbolp (lambda (x) (equal (type x) "SYMB")))
+
 (set! defun!
       (nlambda
        form
        (cond ((symbolp (car form))
-         (set (car form) (apply lambda (cdr form))))
+              (set (car form) (apply 'lambda (cdr form))))
          (t nil))))
 
 (defun! square (x) (* x x))

src/arith/bignum.c

@@ -0,0 +1,14 @@
+/*
+ * bignum.c
+ *
+ * Allocation of and operations on arbitrary precision integers.
+ *
+ * (c) 2018 Simon Brooke <simon@journeyman.cc>
+ * Licensed under GPL version 2.0, or, at your option, any later version.
+ */
+
+/*
+ * Bignums generally follow Knuth, vol 2, 4.3. The word size is 64 bits,
+ * and words are stored in individual cons-space objects, comprising the
+ * word itself and a pointer to the next word in the number.
+ */

src/arith/bignum.h

@@ -0,0 +1,16 @@
+/**
+ * bignum.h
+ *
+ * functions for bignum cells.
+ *
+ *
+ * (c) 2017 Simon Brooke <simon@journeyman.cc>
+ * Licensed under GPL version 2.0, or, at your option, any later version.
+ */
+
+#ifndef __bignum_h
+#define __bignum_h
+
+
+
+#endif

src/arith/integer.c

@@ -13,7 +13,7 @@
 
 #include "conspage.h"
 #include "consspaceobject.h"
-#include "read.h"
+#include "debug.h"
 
 /**
  * return the numeric value of this cell, as a C primitive double, not
@@ -36,12 +36,12 @@ long double numeric_value( struct cons_pointer pointer ) {
 /**
  * Allocate an integer cell representing this value and return a cons pointer to it.
  */
-struct cons_pointer make_integer( long int value ) {
+struct cons_pointer make_integer( int64_t value ) {
     struct cons_pointer result = allocate_cell( INTEGERTAG );
     struct cons_space_object *cell = &pointer2cell( result );
     cell->payload.integer.value = value;
 
-    dump_object( stderr, result );
+    debug_dump_object( result, DEBUG_ARITH );
 
     return result;
 }

src/arith/integer.h

@@ -16,6 +16,6 @@ long double numeric_value( struct cons_pointer pointer );
 /**
  * Allocate an integer cell representing this value and return a cons pointer to it.
  */
-struct cons_pointer make_integer( long int value );
+struct cons_pointer make_integer( int64_t value );
 
 #endif

src/arith/peano.c

@@ -0,0 +1,636 @@
+/*
+ * peano.c
+ *
+ * Basic peano arithmetic
+ *
+ * (c) 2017 Simon Brooke <simon@journeyman.cc>
+ * Licensed under GPL version 2.0, or, at your option, any later version.
+ */
+
+#include <ctype.h>
+#include <math.h>
+#include <stdbool.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+
+#include "consspaceobject.h"
+#include "conspage.h"
+#include "debug.h"
+#include "equal.h"
+#include "integer.h"
+#include "intern.h"
+#include "lispops.h"
+#include "print.h"
+#include "ratio.h"
+#include "read.h"
+#include "real.h"
+#include "stack.h"
+
+long double to_long_double( struct cons_pointer arg );
+int64_t to_long_int( struct cons_pointer arg );
+struct cons_pointer add_2( struct stack_frame *frame,
+                           struct cons_pointer frame_pointer,
+                           struct cons_pointer arg1,
+                           struct cons_pointer arg2 );
+
+
+bool zerop( struct cons_pointer arg ) {
+    bool result = false;
+    struct cons_space_object cell = pointer2cell( arg );
+
+    switch ( cell.tag.value ) {
+        case INTEGERTV:
+            result = cell.payload.integer.value == 0;
+            break;
+        case RATIOTV:
+            result = zerop( cell.payload.ratio.dividend );
+            break;
+        case REALTV:
+            result = ( cell.payload.real.value == 0 );
+            break;
+    }
+
+    return result;
+}
+
+/**
+ * TODO: cannot throw an exception out of here, which is a problem
+ * if a ratio may legally have zero as a divisor, or something which is
+ * not a number is passed in.
+ */
+long double to_long_double( struct cons_pointer arg ) {
+    long double result = 0;     /* not a number, as a long double */
+    struct cons_space_object cell = pointer2cell( arg );
+
+    switch ( cell.tag.value ) {
+        case INTEGERTV:
+            result = ( double ) cell.payload.integer.value;
+            break;
+        case RATIOTV:
+            {
+                struct cons_space_object dividend =
+                    pointer2cell( cell.payload.ratio.dividend );
+                struct cons_space_object divisor =
+                    pointer2cell( cell.payload.ratio.divisor );
+
+                result =
+                    ( long double ) dividend.payload.integer.value /
+                    divisor.payload.integer.value;
+            }
+            break;
+        case REALTV:
+            result = cell.payload.real.value;
+            break;
+        default:
+            result = NAN;
+            break;
+    }
+
+    debug_print( L"to_long_double( ", DEBUG_ARITH );
+    debug_print_object( arg, DEBUG_ARITH );
+    debug_printf( DEBUG_ARITH, L") => %lf\n", result );
+
+    return result;
+}
+
+
+/**
+ * TODO: cannot throw an exception out of here, which is a problem
+ * if a ratio may legally have zero as a divisor, or something which is
+ * not a number (or is a big number) is passed in.
+ */
+int64_t to_long_int( struct cons_pointer arg ) {
+    int64_t result = 0;
+    struct cons_space_object cell = pointer2cell( arg );
+    switch ( cell.tag.value ) {
+        case INTEGERTV:
+            result = cell.payload.integer.value;
+            break;
+        case RATIOTV:
+            result = lroundl( to_long_double( arg ) );
+            break;
+        case REALTV:
+            result = lroundl( cell.payload.real.value );
+            break;
+    }
+    return result;
+}
+
+
+/**
+* return a cons_pointer indicating a number which is the sum of
+* the numbers indicated by `arg1` and `arg2`.
+*/
+struct cons_pointer add_2( struct stack_frame *frame,
+                           struct cons_pointer frame_pointer,
+                           struct cons_pointer arg1,
+                           struct cons_pointer arg2 ) {
+    struct cons_pointer result;
+    struct cons_space_object cell1 = pointer2cell( arg1 );
+    struct cons_space_object cell2 = pointer2cell( arg2 );
+
+    debug_print( L"add_2( arg1 = ", DEBUG_ARITH );
+    debug_print_object( arg1, DEBUG_ARITH );
+    debug_print( L"; arg2 = ", DEBUG_ARITH );
+    debug_print_object( arg2, DEBUG_ARITH );
+    debug_print( L"\n", DEBUG_ARITH );
+
+    if ( zerop( arg1 ) ) {
+        result = arg2;
+    } else if ( zerop( arg2 ) ) {
+        result = arg1;
+    } else {
+
+        switch ( cell1.tag.value ) {
+            case EXCEPTIONTV:
+                result = arg1;
+                break;
+            case INTEGERTV:
+                switch ( cell2.tag.value ) {
+                    case EXCEPTIONTV:
+                        result = arg2;
+                        break;
+                    case INTEGERTV:
+                        result = make_integer( cell1.payload.integer.value +
+                                               cell2.payload.integer.value );
+                        break;
+                    case RATIOTV:
+                        result =
+                            add_integer_ratio( frame_pointer, arg1, arg2 );
+                        break;
+                    case REALTV:
+                        result =
+                            make_real( to_long_double( arg1 ) +
+                                       to_long_double( arg2 ) );
+                        break;
+                    default:
+                        result = throw_exception( c_string_to_lisp_string
+                                                  ( L"Cannot add: not a number" ),
+                                                  frame_pointer );
+                        break;
+                }
+                break;
+            case RATIOTV:
+                switch ( cell2.tag.value ) {
+                    case EXCEPTIONTV:
+                        result = arg2;
+                        break;
+                    case INTEGERTV:
+                        result =
+                            add_integer_ratio( frame_pointer, arg2, arg1 );
+                        break;
+                    case RATIOTV:
+                        result = add_ratio_ratio( frame_pointer, arg1, arg2 );
+                        break;
+                    case REALTV:
+                        result =
+                            make_real( to_long_double( arg1 ) +
+                                       to_long_double( arg2 ) );
+                        break;
+                    default:
+                        result = throw_exception( c_string_to_lisp_string
+                                                  ( L"Cannot add: not a number" ),
+                                                  frame_pointer );
+                        break;
+                }
+                break;
+            case REALTV:
+                result =
+                    make_real( to_long_double( arg1 ) +
+                               to_long_double( arg2 ) );
+                break;
+            default:
+                result = exceptionp( arg2 ) ? arg2 :
+                    throw_exception( c_string_to_lisp_string
+                                     ( L"Cannot add: not a number" ),
+                                     frame_pointer );
+        }
+    }
+
+    debug_print( L"}; => ", DEBUG_ARITH );
+    debug_print_object( arg2, DEBUG_ARITH );
+    debug_print( L"\n", DEBUG_ARITH );
+
+    return result;
+}
+
+/**
+ * Add an indefinite number of numbers together
+ * @param env the evaluation environment - ignored;
+ * @param frame the stack frame.
+ * @return a pointer to an integer or real.
+ */
+struct cons_pointer lisp_add( struct stack_frame
+                              *frame, struct cons_pointer frame_pointer, struct
+                              cons_pointer env ) {
+    struct cons_pointer result = make_integer( 0 );
+    struct cons_pointer tmp;
+
+    for ( int i = 0;
+          i < args_in_frame &&
+          !nilp( frame->arg[i] ) && !exceptionp( result ); i++ ) {
+        tmp = result;
+        result = add_2( frame, frame_pointer, result, frame->arg[i] );
+        if ( !eq( tmp, result ) ) {
+            dec_ref( tmp );
+        }
+    }
+
+    struct cons_pointer more = frame->more;
+    while ( consp( more ) && !exceptionp( result ) ) {
+        tmp = result;
+        result = add_2( frame, frame_pointer, result, c_car( more ) );
+        if ( !eq( tmp, result ) ) {
+            dec_ref( tmp );
+        }
+
+        more = c_cdr( more );
+    }
+
+    return result;
+}
+
+
+/**
+* return a cons_pointer indicating a number which is the product of
+* the numbers indicated by `arg1` and `arg2`.
+*/
+struct cons_pointer multiply_2( struct stack_frame *frame,
+                                struct cons_pointer frame_pointer,
+                                struct cons_pointer arg1,
+                                struct cons_pointer arg2 ) {
+    struct cons_pointer result;
+    struct cons_space_object cell1 = pointer2cell( arg1 );
+    struct cons_space_object cell2 = pointer2cell( arg2 );
+
+    debug_print( L"multiply_2( arg1 = ", DEBUG_ARITH );
+    debug_print_object( arg1, DEBUG_ARITH );
+    debug_print( L"; arg2 = ", DEBUG_ARITH );
+    debug_print_object( arg2, DEBUG_ARITH );
+    debug_print( L")", DEBUG_ARITH );
+
+    if ( zerop( arg1 ) ) {
+        result = arg2;
+    } else if ( zerop( arg2 ) ) {
+        result = arg1;
+    } else {
+        switch ( cell1.tag.value ) {
+            case EXCEPTIONTV:
+                result = arg1;
+                break;
+            case INTEGERTV:
+                switch ( cell2.tag.value ) {
+                    case EXCEPTIONTV:
+                        result = arg2;
+                        break;
+                    case INTEGERTV:
+                        result = make_integer( cell1.payload.integer.value *
+                                               cell2.payload.integer.value );
+                        break;
+                    case RATIOTV:
+                        result =
+                            multiply_integer_ratio( frame_pointer, arg1,
+                                                    arg2 );
+                        break;
+                    case REALTV:
+                        result =
+                            make_real( to_long_double( arg1 ) *
+                                       to_long_double( arg2 ) );
+                        break;
+                    default:
+                        result = throw_exception( c_string_to_lisp_string
+                                                  ( L"Cannot multiply: not a number" ),
+                                                  frame_pointer );
+                        break;
+                }
+                break;
+            case RATIOTV:
+                switch ( cell2.tag.value ) {
+                    case EXCEPTIONTV:
+                        result = arg2;
+                        break;
+                    case INTEGERTV:
+                        result =
+                            multiply_integer_ratio( frame_pointer, arg2,
+                                                    arg1 );
+                        break;
+                    case RATIOTV:
+                        result =
+                            multiply_ratio_ratio( frame_pointer, arg1, arg2 );
+                        break;
+                    case REALTV:
+                        result =
+                            make_real( to_long_double( arg1 ) *
+                                       to_long_double( arg2 ) );
+                        break;
+                    default:
+                        result = throw_exception( c_string_to_lisp_string
+                                                  ( L"Cannot multiply: not a number" ),
+                                                  frame_pointer );
+                }
+                break;
+            case REALTV:
+                result = exceptionp( arg2 ) ? arg2 :
+                    make_real( to_long_double( arg1 ) *
+                               to_long_double( arg2 ) );
+                break;
+            default:
+                result = throw_exception( c_string_to_lisp_string
+                                          ( L"Cannot multiply: not a number" ),
+                                          frame_pointer );
+                break;
+        }
+    }
+
+    debug_print( L" => ", DEBUG_ARITH );
+    debug_print_object( arg2, DEBUG_ARITH );
+    debug_print( L"\n", DEBUG_ARITH );
+
+    return result;
+}
+
+
+/**
+ * Multiply an indefinite number of numbers together
+ * @param env the evaluation environment - ignored;
+ * @param frame the stack frame.
+ * @return a pointer to an integer or real.
+ */
+struct cons_pointer lisp_multiply( struct
+                                   stack_frame
+                                   *frame, struct cons_pointer frame_pointer, struct
+                                   cons_pointer env ) {
+    struct cons_pointer result = make_integer( 1 );
+    struct cons_pointer tmp;
+
+    for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] )
+          && !exceptionp( result ); i++ ) {
+        tmp = result;
+        result = multiply_2( frame, frame_pointer, result, frame->arg[i] );
+
+        if ( !eq( tmp, result ) ) {
+            dec_ref( tmp );
+        }
+    }
+
+    struct cons_pointer more = frame->more;
+    while ( consp( more )
+            && !exceptionp( result ) ) {
+        tmp = result;
+        result = multiply_2( frame, frame_pointer, result, c_car( more ) );
+
+        if ( !eq( tmp, result ) ) {
+            dec_ref( tmp );
+        }
+
+        more = c_cdr( more );
+    }
+
+    return result;
+}
+
+/**
+ * return a cons_pointer indicating a number which is the
+ * inverse of the number indicated by `arg`.
+ */
+struct cons_pointer inverse( struct cons_pointer frame,
+                             struct cons_pointer arg ) {
+    struct cons_pointer result = NIL;
+    struct cons_space_object cell = pointer2cell( arg );
+
+    switch ( cell.tag.value ) {
+        case EXCEPTIONTV:
+            result = arg;
+            break;
+        case INTEGERTV:
+            result = make_integer( 0 - to_long_int( arg ) );
+            break;
+        case NILTV:
+            result = TRUE;
+            break;
+        case RATIOTV:
+            result = make_ratio( frame,
+                                 make_integer( 0 -
+                                               to_long_int( cell.payload.
+                                                            ratio.dividend ) ),
+                                 cell.payload.ratio.divisor );
+            break;
+        case REALTV:
+            result = make_real( 0 - to_long_double( arg ) );
+            break;
+        case TRUETV:
+            result = NIL;
+            break;
+    }
+
+    return result;
+}
+
+
+/**
+ * Subtract one number from another.
+ * @param env the evaluation environment - ignored;
+ * @param frame the stack frame.
+ * @return a pointer to an integer or real.
+ */
+struct cons_pointer lisp_subtract( struct
+                                   stack_frame
+                                   *frame, struct cons_pointer frame_pointer, struct
+                                   cons_pointer env ) {
+    struct cons_pointer result = NIL;
+    struct cons_space_object cell0 = pointer2cell( frame->arg[0] );
+    struct cons_space_object cell1 = pointer2cell( frame->arg[1] );
+
+    switch ( cell0.tag.value ) {
+        case EXCEPTIONTV:
+            result = frame->arg[0];
+            break;
+        case INTEGERTV:
+            switch ( cell1.tag.value ) {
+                case EXCEPTIONTV:
+                    result = frame->arg[1];
+                    break;
+                case INTEGERTV:
+                    result = make_integer( cell0.payload.integer.value
+                                           - cell1.payload.integer.value );
+                    break;
+                case RATIOTV:{
+                        struct cons_pointer tmp =
+                            make_ratio( frame_pointer, frame->arg[0],
+                                        make_integer( 1 ) );
+                        inc_ref( tmp );
+                        result =
+                            subtract_ratio_ratio( frame_pointer, tmp,
+                                                  frame->arg[1] );
+                        dec_ref( tmp );
+                    }
+                    break;
+                case REALTV:
+                    result =
+                        make_real( to_long_double( frame->arg[0] ) -
+                                   to_long_double( frame->arg[1] ) );
+                    break;
+                default:
+                    result = throw_exception( c_string_to_lisp_string
+                                              ( L"Cannot subtract: not a number" ),
+                                              frame_pointer );
+                    break;
+            }
+            break;
+        case RATIOTV:
+            switch ( cell1.tag.value ) {
+                case EXCEPTIONTV:
+                    result = frame->arg[1];
+                    break;
+                case INTEGERTV:{
+                        struct cons_pointer tmp =
+                            make_ratio( frame_pointer, frame->arg[1],
+                                        make_integer( 1 ) );
+                        inc_ref( tmp );
+                        result =
+                            subtract_ratio_ratio( frame_pointer, frame->arg[0],
+                                                  tmp );
+                        dec_ref( tmp );
+                    }
+                    break;
+                case RATIOTV:
+                    result =
+                        subtract_ratio_ratio( frame_pointer, frame->arg[0],
+                                              frame->arg[1] );
+                    break;
+                case REALTV:
+                    result =
+                        make_real( to_long_double( frame->arg[0] ) -
+                                   to_long_double( frame->arg[1] ) );
+                    break;
+                default:
+                    result = throw_exception( c_string_to_lisp_string
+                                              ( L"Cannot subtract: not a number" ),
+                                              frame_pointer );
+                    break;
+            }
+            break;
+        case REALTV:
+            result = exceptionp( frame->arg[1] ) ? frame->arg[1] :
+                make_real( to_long_double( frame->arg[0] ) -
+                           to_long_double( frame->arg[1] ) );
+            break;
+        default:
+            result = throw_exception( c_string_to_lisp_string
+                                      ( L"Cannot subtract: not a number" ),
+                                      frame_pointer );
+            break;
+    }
+
+    // and if not nilp[frame->arg[2]) we also have an error.
+
+    return result;
+}
+
+/**
+ * Divide one number by another.
+ * @param env the evaluation environment - ignored;
+ * @param frame the stack frame.
+ * @return a pointer to an integer or real.
+ */
+struct cons_pointer lisp_divide( struct
+                                 stack_frame
+                                 *frame, struct cons_pointer frame_pointer, struct
+                                 cons_pointer env ) {
+    struct cons_pointer result = NIL;
+    struct cons_space_object arg0 = pointer2cell( frame->arg[0] );
+    struct cons_space_object arg1 = pointer2cell( frame->arg[1] );
+
+    switch ( arg0.tag.value ) {
+        case EXCEPTIONTV:
+            result = frame->arg[0];
+            break;
+        case INTEGERTV:
+            switch ( arg1.tag.value ) {
+                case EXCEPTIONTV:
+                    result = frame->arg[1];
+                    break;
+                case INTEGERTV:{
+                        struct cons_pointer unsimplified =
+                            make_ratio( frame_pointer, frame->arg[0],
+                                        frame->arg[1] );
+                        /* OK, if result may be unsimplified, we should not inc_ref it
+                         * - but if not, we should dec_ref it. */
+                        result = simplify_ratio( frame_pointer, unsimplified );
+                        if ( !eq( unsimplified, result ) ) {
+                            dec_ref( unsimplified );
+                        }
+                    }
+                    break;
+                case RATIOTV:{
+                        struct cons_pointer one = make_integer( 1 );
+                        struct cons_pointer ratio =
+                            make_ratio( frame_pointer, frame->arg[0], one );
+                        result =
+                            divide_ratio_ratio( frame_pointer, ratio,
+                                                frame->arg[1] );
+                        dec_ref( ratio );
+                    }
+                    break;
+                case REALTV:
+                    result =
+                        make_real( to_long_double( frame->arg[0] ) /
+                                   to_long_double( frame->arg[1] ) );
+                    break;
+                default:
+                    result = throw_exception( c_string_to_lisp_string
+                                              ( L"Cannot divide: not a number" ),
+                                              frame_pointer );
+                    break;
+            }
+            break;
+        case RATIOTV:
+            switch ( arg1.tag.value ) {
+                case EXCEPTIONTV:
+                    result = frame->arg[1];
+                    break;
+                case INTEGERTV:{
+                        struct cons_pointer one = make_integer( 1 );
+                        inc_ref( one );
+                        struct cons_pointer ratio =
+                            make_ratio( frame_pointer, frame->arg[1], one );
+                        inc_ref( ratio );
+                        result =
+                            divide_ratio_ratio( frame_pointer, frame->arg[0],
+                                                ratio );
+                        dec_ref( ratio );
+                        dec_ref( one );
+                    }
+                    break;
+                case RATIOTV:
+                    result =
+                        divide_ratio_ratio( frame_pointer, frame->arg[0],
+                                            frame->arg[1] );
+                    break;
+                case REALTV:
+                    result =
+                        make_real( to_long_double( frame->arg[0] ) /
+                                   to_long_double( frame->arg[1] ) );
+                    break;
+                default:
+                    result = throw_exception( c_string_to_lisp_string
+                                              ( L"Cannot divide: not a number" ),
+                                              frame_pointer );
+                    break;
+            }
+            break;
+        case REALTV:
+            result = exceptionp( frame->arg[1] ) ? frame->arg[1] :
+                make_real( to_long_double( frame->arg[0] ) /
+                           to_long_double( frame->arg[1] ) );
+            break;
+        default:
+            result = throw_exception( c_string_to_lisp_string
+                                      ( L"Cannot divide: not a number" ),
+                                      frame_pointer );
+            break;
+    }
+
+    return result;
+}

src/arith/peano.h

@@ -23,7 +23,8 @@ extern "C" {
  * @return a pointer to an integer or real.
  */
     struct cons_pointer
-     lisp_add( struct stack_frame *frame, struct cons_pointer env );
+     lisp_add( struct stack_frame *frame, struct cons_pointer frame_pointer,
+               struct cons_pointer env );
 
 /**
  * Multiply an indefinite number of numbers together
@@ -32,7 +33,9 @@ extern "C" {
  * @return a pointer to an integer or real.
  */
     struct cons_pointer
-     lisp_multiply( struct stack_frame *frame, struct cons_pointer env );
+     lisp_multiply( struct stack_frame *frame,
+                    struct cons_pointer frame_pointer,
+                    struct cons_pointer env );
 
 /**
  * Subtract one number from another.
@@ -41,7 +44,9 @@ extern "C" {
  * @return a pointer to an integer or real.
  */
     struct cons_pointer
-     lisp_subtract( struct stack_frame *frame, struct cons_pointer env );
+     lisp_subtract( struct stack_frame *frame,
+                    struct cons_pointer frame_pointer,
+                    struct cons_pointer env );
 
 /**
  * Divide one number by another.
@@ -50,7 +55,8 @@ extern "C" {
  * @return a pointer to an integer or real.
  */
     struct cons_pointer
-     lisp_divide( struct stack_frame *frame, struct cons_pointer env );
+     lisp_divide( struct stack_frame *frame, struct cons_pointer frame_pointer,
+                  struct cons_pointer env );
 
 #ifdef __cplusplus
 }

src/arith/ratio.c

@@ -0,0 +1,333 @@
+/*
+ * ratio.c
+ *
+ * functions for rational number cells.
+ *
+ * (c) 2017 Simon Brooke <simon@journeyman.cc>
+ * Licensed under GPL version 2.0, or, at your option, any later version.
+ */
+
+#define _GNU_SOURCE
+#include <math.h>
+#include <stdio.h>
+
+#include "conspage.h"
+#include "consspaceobject.h"
+#include "debug.h"
+#include "equal.h"
+#include "integer.h"
+#include "lispops.h"
+#include "print.h"
+#include "ratio.h"
+
+
+/*
+ * declared in peano.c, can't include piano.h here because
+ * circularity. TODO: refactor.
+ */
+struct cons_pointer inverse( struct cons_pointer frame_pointer,
+                             struct cons_pointer arg );
+
+/**
+ * return, as a int64_t, the greatest common divisor of `m` and `n`,
+ */
+int64_t greatest_common_divisor( int64_t m, int64_t n ) {
+    int o;
+    while ( m ) {
+        o = m;
+        m = n % m;
+        n = o;
+    }
+
+    return o;
+}
+
+/**
+ * return, as a int64_t, the least common multiple of `m` and `n`,
+ */
+int64_t least_common_multiple( int64_t m, int64_t n ) {
+    return m / greatest_common_divisor( m, n ) * n;
+}
+
+/**
+ * return a cons_pointer indicating a number which is of the
+ * same value as the ratio indicated by `arg`, but which may
+ * be in a simplified representation. If `arg` isn't a ratio,
+ * will throw exception.
+ */
+struct cons_pointer simplify_ratio( struct cons_pointer frame_pointer,
+                                    struct cons_pointer arg ) {
+    struct cons_pointer result = arg;
+
+    if ( ratiop( arg ) ) {
+        int64_t ddrv =
+            pointer2cell( pointer2cell( arg ).payload.ratio.dividend ).
+            payload.integer.value, drrv =
+            pointer2cell( pointer2cell( arg ).payload.ratio.divisor ).
+            payload.integer.value, gcd = greatest_common_divisor( ddrv, drrv );
+
+        if ( gcd > 1 ) {
+            if ( drrv / gcd == 1 ) {
+                result = make_integer( ddrv / gcd );
+            } else {
+                result =
+                    make_ratio( frame_pointer, make_integer( ddrv / gcd ),
+                                make_integer( drrv / gcd ) );
+            }
+        }
+    } else {
+        result =
+            throw_exception( make_cons( c_string_to_lisp_string
+                                        ( L"Shouldn't happen: bad arg to simplify_ratio" ),
+                                        arg ), frame_pointer );
+    }
+
+    return result;
+}
+
+
+
+/**
+ * return a cons_pointer indicating a number which is the sum of
+ * the ratios indicated by `arg1` and `arg2`. If you pass non-ratios,
+ * this is going to break horribly.
+ */
+struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer,
+                                     struct cons_pointer arg1,
+                                     struct cons_pointer arg2 ) {
+    struct cons_pointer r, result;
+
+    debug_print( L"add_ratio_ratio( arg1 = ", DEBUG_ARITH );
+    debug_print_object( arg1, DEBUG_ARITH );
+    debug_print( L"; arg2 = ", DEBUG_ARITH );
+    debug_print_object( arg2, DEBUG_ARITH );
+    debug_print( L")\n", DEBUG_ARITH );
+
+    if ( ratiop( arg1 ) && ratiop( arg2 ) ) {
+        struct cons_space_object cell1 = pointer2cell( arg1 );
+        struct cons_space_object cell2 = pointer2cell( arg2 );
+        int64_t dd1v =
+            pointer2cell( cell1.payload.ratio.dividend ).payload.integer.value,
+            dd2v =
+            pointer2cell( cell2.payload.ratio.dividend ).payload.integer.value,
+            dr1v =
+            pointer2cell( cell1.payload.ratio.divisor ).payload.integer.value,
+            dr2v =
+            pointer2cell( cell2.payload.ratio.divisor ).payload.integer.value,
+            lcm = least_common_multiple( dr1v, dr2v ),
+            m1 = lcm / dr1v, m2 = lcm / dr2v;
+
+        debug_printf( DEBUG_ARITH, L"); lcm = %ld; m1 = %ld; m2 = %ld", lcm, m1, m2 );
+
+        if ( dr1v == dr2v ) {
+            r = make_ratio( frame_pointer,
+                            make_integer( dd1v + dd2v ),
+                            cell1.payload.ratio.divisor );
+        } else {
+            struct cons_pointer dd1vm = make_integer( dd1v * m1 ),
+                dr1vm = make_integer( dr1v * m1 ),
+                dd2vm = make_integer( dd2v * m2 ),
+                dr2vm = make_integer( dr2v * m2 ),
+                r1 = make_ratio( frame_pointer, dd1vm, dr1vm ),
+                r2 = make_ratio( frame_pointer, dd2vm, dr2vm );
+
+            r = add_ratio_ratio( frame_pointer, r1, r2 );
+
+            /* because the references on dd1vm, dr1vm, dd2vm and dr2vm were
+             * never incremented except when making r1 and r2, decrementing
+             * r1 and r2 should be enought to garbage collect them. */
+            dec_ref( r1 );
+            dec_ref( r2 );
+        }
+
+        result = simplify_ratio( frame_pointer, r );
+        if ( !eq( r, result ) ) {
+            dec_ref( r );
+        }
+    } else {
+        result =
+            throw_exception( make_cons( c_string_to_lisp_string
+                                        ( L"Shouldn't happen: bad arg to add_ratio_ratio" ),
+                                        make_cons( arg1,
+                                                   make_cons( arg2, NIL ) ) ),
+                             frame_pointer );
+    }
+
+    debug_print( L" => ", DEBUG_ARITH );
+    debug_print_object( result, DEBUG_ARITH );
+    debug_print( L"\n", DEBUG_ARITH );
+
+    return result;
+}
+
+
+/**
+ * return a cons_pointer indicating a number which is the sum of
+ * the intger indicated by `intarg` and the ratio indicated by
+ * `ratarg`. If you pass other types, this is going to break horribly.
+ */
+struct cons_pointer add_integer_ratio( struct cons_pointer frame_pointer,
+                                       struct cons_pointer intarg,
+                                       struct cons_pointer ratarg ) {
+    struct cons_pointer result;
+
+    if ( integerp( intarg ) && ratiop( ratarg ) ) {
+        struct cons_pointer one = make_integer( 1 ),
+            ratio = make_ratio( frame_pointer, intarg, one );
+
+        result = add_ratio_ratio( frame_pointer, ratio, ratarg );
+
+        dec_ref( one );
+        dec_ref( ratio );
+    } else {
+        result =
+            throw_exception( make_cons( c_string_to_lisp_string
+                                        ( L"Shouldn't happen: bad arg to add_integer_ratio" ),
+                                        make_cons( intarg,
+                                                   make_cons( ratarg,
+                                                              NIL ) ) ),
+                             frame_pointer );
+    }
+
+    return result;
+}
+
+/**
+ * return a cons_pointer to a ratio which represents the value of the ratio
+ * indicated by `arg1` divided by the ratio indicated by `arg2`. If either
+ * of these aren't RTIO cells, something horrid will happen and it is YOUR FAULT.
+ */
+struct cons_pointer divide_ratio_ratio( struct cons_pointer frame_pointer,
+                                        struct cons_pointer arg1,
+                                        struct cons_pointer arg2 ) {
+    struct cons_pointer i = make_ratio( frame_pointer,
+                                        pointer2cell( arg2 ).payload.
+                                        ratio.divisor,
+                                        pointer2cell( arg2 ).payload.
+                                        ratio.dividend ),
+    result =
+        multiply_ratio_ratio( frame_pointer, arg1, i );
+
+    dec_ref( i );
+
+    return result;
+}
+
+/**
+ * return a cons_pointer indicating a number which is the product of
+ * the ratios indicated by `arg1` and `arg2`. If you pass non-ratios,
+ * this is going to break horribly.
+ */
+struct cons_pointer multiply_ratio_ratio( struct cons_pointer frame_pointer, struct
+                                          cons_pointer arg1, struct
+                                          cons_pointer arg2 ) {
+    struct cons_pointer result;
+
+    debug_print( L"multiply_ratio_ratio( arg1 = ", DEBUG_ARITH );
+    debug_print_object( arg1, DEBUG_ARITH );
+    debug_print( L"; arg2 = ", DEBUG_ARITH );
+    debug_print_object( arg2, DEBUG_ARITH );
+    debug_print( L")\n", DEBUG_ARITH );
+
+    if ( ratiop( arg1 ) && ratiop( arg2 ) ) {
+        struct cons_space_object cell1 = pointer2cell( arg1 );
+        struct cons_space_object cell2 = pointer2cell( arg2 );
+        int64_t dd1v =
+            pointer2cell( cell1.payload.ratio.dividend ).payload.integer.value,
+            dd2v =
+            pointer2cell( cell2.payload.ratio.dividend ).payload.integer.value,
+            dr1v =
+            pointer2cell( cell1.payload.ratio.divisor ).payload.integer.value,
+            dr2v =
+            pointer2cell( cell2.payload.ratio.divisor ).payload.integer.value,
+            ddrv = dd1v * dd2v, drrv = dr1v * dr2v;
+
+        struct cons_pointer unsimplified =
+            make_ratio( frame_pointer, make_integer( ddrv ),
+                        make_integer( drrv ) );
+        result = simplify_ratio( frame_pointer, unsimplified );
+
+        if ( !eq( unsimplified, result ) ) {
+            dec_ref( unsimplified );
+        }
+    } else {
+        result =
+            throw_exception( c_string_to_lisp_string
+                             ( L"Shouldn't happen: bad arg to multiply_ratio_ratio" ),
+                             frame_pointer );
+    }
+
+    return result;
+}
+
+/**
+ * return a cons_pointer indicating a number which is the product of
+ * the intger indicated by `intarg` and the ratio indicated by
+ * `ratarg`. If you pass other types, this is going to break horribly.
+ */
+struct cons_pointer multiply_integer_ratio( struct cons_pointer frame_pointer,
+                                            struct cons_pointer intarg,
+                                            struct cons_pointer ratarg ) {
+    struct cons_pointer result;
+
+    if ( integerp( intarg ) && ratiop( ratarg ) ) {
+        struct cons_pointer one = make_integer( 1 ),
+            ratio = make_ratio( frame_pointer, intarg, one );
+        result = multiply_ratio_ratio( frame_pointer, ratio, ratarg );
+
+        dec_ref( one );
+        dec_ref( ratio );
+    } else {
+        result =
+            throw_exception( c_string_to_lisp_string
+                             ( L"Shouldn't happen: bad arg to multiply_integer_ratio" ),
+                             frame_pointer );
+    }
+
+    return result;
+}
+
+
+/**
+ * return a cons_pointer indicating a number which is the difference of
+ * the ratios indicated by `arg1` and `arg2`. If you pass non-ratios,
+ * this is going to break horribly.
+ */
+struct cons_pointer subtract_ratio_ratio( struct cons_pointer frame_pointer,
+                                          struct cons_pointer arg1,
+                                          struct cons_pointer arg2 ) {
+    struct cons_pointer i = inverse( frame_pointer, arg2 ),
+        result = add_ratio_ratio( frame_pointer, arg1, i );
+
+    dec_ref( i );
+
+    return result;
+}
+
+
+/**
+ * Construct a ratio frame from these two pointers, expected to be integers
+ * or (later) bignums, in the context of this stack_frame.
+ */
+struct cons_pointer make_ratio( struct cons_pointer frame_pointer,
+                                struct cons_pointer dividend,
+                                struct cons_pointer divisor ) {
+    struct cons_pointer result;
+    if ( integerp( dividend ) && integerp( divisor ) ) {
+        inc_ref( dividend );
+        inc_ref( divisor );
+        result = allocate_cell( RATIOTAG );
+        struct cons_space_object *cell = &pointer2cell( result );
+        cell->payload.ratio.dividend = dividend;
+        cell->payload.ratio.divisor = divisor;
+    } else {
+        result =
+            throw_exception( c_string_to_lisp_string
+                             ( L"Dividend and divisor of a ratio must be integers" ),
+                             frame_pointer );
+    }
+    debug_dump_object( result, DEBUG_ARITH );
+
+
+    return result;
+}

src/arith/ratio.h

@@ -0,0 +1,46 @@
+/**
+ * ratio.h
+ *
+ * functions for rational number cells.
+ *
+ *
+ * (c) 2017 Simon Brooke <simon@journeyman.cc>
+ * Licensed under GPL version 2.0, or, at your option, any later version.
+ */
+
+#ifndef __ratio_h
+#define __ratio_h
+
+struct cons_pointer simplify_ratio( struct cons_pointer frame_pointer,
+                                    struct cons_pointer arg );
+
+struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer,
+                                     struct cons_pointer arg1,
+                                     struct cons_pointer arg2 );
+
+struct cons_pointer add_integer_ratio( struct cons_pointer frame_pointer,
+                                       struct cons_pointer intarg,
+                                       struct cons_pointer ratarg );
+
+struct cons_pointer divide_ratio_ratio( struct cons_pointer frame_pointer,
+                                        struct cons_pointer arg1,
+                                        struct cons_pointer arg2 );
+
+struct cons_pointer multiply_ratio_ratio( struct cons_pointer frame_pointer, struct
+                                          cons_pointer arg1, struct
+                                          cons_pointer arg2 );
+
+struct cons_pointer multiply_integer_ratio( struct cons_pointer frame_pointer,
+                                            struct cons_pointer intarg,
+                                            struct cons_pointer ratarg );
+
+struct cons_pointer subtract_ratio_ratio( struct cons_pointer frame_pointer,
+                                          struct cons_pointer arg1,
+                                          struct cons_pointer arg2 );
+
+struct cons_pointer make_ratio( struct cons_pointer frame_pointer,
+                                struct cons_pointer dividend,
+                                struct cons_pointer divisor );
+
+
+#endif

src/arith/real.c

@@ -9,6 +9,7 @@
 
 #include "conspage.h"
 #include "consspaceobject.h"
+#include "debug.h"
 #include "read.h"
 
 /**
@@ -22,5 +23,7 @@ struct cons_pointer make_real( long double value ) {
     struct cons_space_object *cell = &pointer2cell( result );
     cell->payload.real.value = value;
 
+    debug_dump_object( result, DEBUG_ARITH );
+
     return result;
 }

src/debug.c

@@ -0,0 +1,99 @@
+/**
+ * debug.c
+ *
+ * Better debug log messages.
+ *
+ * (c) 2017 Simon Brooke <simon@journeyman.cc>
+ * Licensed under GPL version 2.0, or, at your option, any later version.
+ */
+
+#include <ctype.h>
+#include <stdarg.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+/*
+ * wide characters
+ */
+#include <wchar.h>
+#include <wctype.h>
+
+#include "consspaceobject.h"
+#include "debug.h"
+#include "dump.h"
+#include "print.h"
+
+/**
+ * the controlling flags for `debug_print`; set in `init.c`, q.v.
+ */
+int verbosity = 0;
+
+/**
+ * print this debug `message` to stderr, if `verbosity` matches `level`.
+ * `verbosity is a set of flags, see debug_print.h; so you can
+ * turn debugging on for only one part of the system.
+ */
+void debug_print( wchar_t *message, int level ) {
+#ifdef DEBUG
+    if ( level & verbosity ) {
+        fwide( stderr, 1 );
+        fputws( message, stderr );
+    }
+#endif
+}
+
+/**
+ * print a line feed to stderr, if `verbosity` matches `level`.
+ * `verbosity is a set of flags, see debug_print.h; so you can
+ * turn debugging on for only one part of the system.
+ */
+void debug_println( int level ) {
+#ifdef DEBUG
+    if ( level & verbosity ) {
+        fwide( stderr, 1 );
+        fputws( L"\n", stderr );
+    }
+#endif
+}
+
+
+/**
+ * `wprintf` adapted for the debug logging system. Print to stderr only
+ * `verbosity` matches `level`. All other arguments as for `wprintf`.
+ */
+void debug_printf( int level, wchar_t * format, ...) {
+  #ifdef DEBUG
+  if ( level & verbosity ) {
+    fwide( stderr, 1 );
+    va_list(args);
+    va_start(args, format);
+    vfwprintf(stderr, format, args);
+  }
+  #endif
+}
+
+/**
+ * print the object indicated by this `pointer` to stderr, if `verbosity`
+ * matches `level`.`verbosity is a set of flags, see debug_print.h; so you can
+ * turn debugging on for only one part of the system.
+ */
+void debug_print_object( struct cons_pointer pointer, int level ) {
+#ifdef DEBUG
+    if ( level & verbosity ) {
+        fwide( stderr, 1 );
+        print( stderr, pointer );
+    }
+#endif
+}
+
+/**
+ * Like `dump_object`, q.v., but protected by the verbosity mechanism.
+ */
+void debug_dump_object( struct cons_pointer pointer, int level ) {
+#ifdef DEBUG
+    if ( level & verbosity ) {
+          fwide( stderr, 1 );
+        dump_object( stderr, pointer );
+    }
+#endif
+}

src/debug.h

@@ -0,0 +1,33 @@
+/**
+ * debug.h
+ *
+ * Better debug log messages.
+ *
+ * (c) 2017 Simon Brooke <simon@journeyman.cc>
+ * Licensed under GPL version 2.0, or, at your option, any later version.
+ */
+
+#include <ctype.h>
+#include <stdio.h>
+
+#ifndef __debug_print_h
+#define __debug_print_h
+
+#define DEBUG_ALLOC 1
+#define DEBUG_STACK 2
+#define DEBUG_ARITH 4
+#define DEBUG_EVAL 8
+#define DEBUG_LAMBDA 16
+#define DEBUG_BOOTSTRAP 32
+#define DEBUG_IO 64
+#define DEBUG_REPL 128
+
+extern int verbosity;
+
+void debug_print( wchar_t *message, int level );
+void debug_println( int level );
+void debug_printf( int level, wchar_t * format, ...);
+void debug_print_object( struct cons_pointer pointer, int level );
+void debug_dump_object( struct cons_pointer pointer, int level );
+
+#endif

src/init.c

@@ -11,26 +11,32 @@
 
 #include <stdbool.h>
 #include <stdio.h>
+#include <stdlib.h>
 #include <unistd.h>
 #include <wchar.h>
 
 #include "version.h"
 #include "conspage.h"
 #include "consspaceobject.h"
+#include "debug.h"
 #include "intern.h"
 #include "lispops.h"
 #include "peano.h"
 #include "print.h"
 #include "repl.h"
 
-void bind_function( char *name, struct cons_pointer ( *executable )
+// extern char *optarg; /* defined in unistd.h */
-                     ( struct stack_frame *, struct cons_pointer ) ) {
+
+void bind_function( wchar_t *name, struct cons_pointer ( *executable )
+                     ( struct stack_frame *,
+                       struct cons_pointer, struct cons_pointer ) ) {
     deep_bind( c_string_to_lisp_symbol( name ),
                make_function( NIL, executable ) );
 }
 
-void bind_special( char *name, struct cons_pointer ( *executable )
+void bind_special( wchar_t *name, struct cons_pointer ( *executable )
-                    ( struct stack_frame * frame, struct cons_pointer env ) ) {
+                    ( struct stack_frame *,
+                      struct cons_pointer, struct cons_pointer ) ) {
     deep_bind( c_string_to_lisp_symbol( name ),
                make_special( NIL, executable ) );
 }
@@ -46,7 +52,7 @@ int main( int argc, char *argv[] ) {
     bool dump_at_end = false;
     bool show_prompt = false;
 
-    while ( ( option = getopt( argc, argv, "pdc" ) ) != -1 ) {
+    while ( ( option = getopt( argc, argv, "cpdv:" ) ) != -1 ) {
         switch ( option ) {
             case 'c':
                 print_use_colours = true;
@@ -57,6 +63,9 @@ int main( int argc, char *argv[] ) {
             case 'p':
                 show_prompt = true;
                 break;
+            case 'v':
+                verbosity = atoi( optarg );
+                break;
             default:
                 fwprintf( stderr, L"Unexpected option %c\n", option );
                 break;
@@ -69,51 +78,60 @@ int main( int argc, char *argv[] ) {
                   VERSION );
     }
 
+    debug_print( L"About to initialise cons pages\n", DEBUG_BOOTSTRAP );
+
     initialise_cons_pages(  );
 
+    debug_print( L"Initialised cons pages, about to bind\n", DEBUG_BOOTSTRAP );
+
     /*
      * privileged variables (keywords)
      */
-    deep_bind( c_string_to_lisp_symbol( "nil" ), NIL );
+    deep_bind( c_string_to_lisp_symbol( L"nil" ), NIL );
-    deep_bind( c_string_to_lisp_symbol( "t" ), TRUE );
+    deep_bind( c_string_to_lisp_symbol( L"t" ), TRUE );
 
     /*
      * primitive function operations
      */
-    bind_function( "add", &lisp_add );
+     bind_function( L"add", &lisp_add );
-    bind_function( "apply", &lisp_apply );
+     bind_function( L"apply", &lisp_apply );
-    bind_function( "assoc", &lisp_assoc );
+     bind_function( L"assoc", &lisp_assoc );
-    bind_function( "car", &lisp_car );
+     bind_function( L"car", &lisp_car );
-    bind_function( "cdr", &lisp_cdr );
+     bind_function( L"cdr", &lisp_cdr );
-    bind_function( "cons", &lisp_cons );
+     bind_function( L"cons", &lisp_cons );
-    bind_function( "divide", &lisp_divide );
+     bind_function( L"divide", &lisp_divide );
-    bind_function( "eq", &lisp_eq );
+     bind_function( L"eq", &lisp_eq );
-    bind_function( "equal", &lisp_equal );
+     bind_function( L"equal", &lisp_equal );
-    bind_function( "eval", &lisp_eval );
+     bind_function( L"eval", &lisp_eval );
-    bind_function( "multiply", &lisp_multiply );
+     bind_function( L"exception", &lisp_exception );
-    bind_function( "read", &lisp_read );
+     bind_function( L"multiply", &lisp_multiply );
-    bind_function( "oblist", &lisp_oblist );
+     bind_function( L"read", &lisp_read );
-    bind_function( "print", &lisp_print );
+     bind_function( L"oblist", &lisp_oblist );
-    bind_function( "progn", &lisp_progn );
+     bind_function( L"print", &lisp_print );
-    bind_function( "set", &lisp_set );
+     bind_function( L"progn", &lisp_progn );
-    bind_function( "subtract", &lisp_subtract );
+     bind_function( L"reverse", &lisp_reverse );
-    bind_function( "type", &lisp_type );
+     bind_function( L"set", &lisp_set );
+     bind_function( L"subtract", &lisp_subtract );
+     bind_function( L"throw", &lisp_exception );
+     bind_function( L"type", &lisp_type );
 
-    bind_function( "+", &lisp_add );
+     bind_function( L"+", &lisp_add );
-    bind_function( "*", &lisp_multiply );
+     bind_function( L"*", &lisp_multiply );
-    bind_function( "-", &lisp_subtract );
+     bind_function( L"-", &lisp_subtract );
-    bind_function( "/", &lisp_divide );
+     bind_function( L"/", &lisp_divide );
-    bind_function( "=", &lisp_equal );
+     bind_function( L"=", &lisp_equal );
 
     /*
      * primitive special forms
      */
-    bind_special( "cond", &lisp_cond );
+     bind_special( L"cond", &lisp_cond );
-    bind_special( "lambda", &lisp_lambda );
+     bind_special( L"lambda", &lisp_lambda );
-    bind_special( "nlambda", &lisp_nlambda );
+     // bind_special( L"λ", &lisp_lambda );
-    bind_special( "progn", &lisp_progn );
+     bind_special( L"nlambda", &lisp_nlambda );
-    bind_special( "quote", &lisp_quote );
+     // bind_special( L"nλ", &lisp_nlambda );
-    bind_special( "set!", &lisp_set_shriek );
+     bind_special( L"progn", &lisp_progn );
+     bind_special( L"quote", &lisp_quote );
+     bind_special( L"set!", &lisp_set_shriek );
 
     repl( stdin, stdout, stderr, show_prompt );
 

src/memory/conspage.c

@@ -18,6 +18,8 @@
 
 #include "consspaceobject.h"
 #include "conspage.h"
+#include "debug.h"
+#include "dump.h"
 
 /**
  * Flag indicating whether conspage initialisation has been done.
@@ -64,7 +66,7 @@ void make_cons_page(  ) {
                         cell->count = MAXREFERENCE;
                         cell->payload.free.car = NIL;
                         cell->payload.free.cdr = NIL;
-                        fwprintf( stderr, L"Allocated special cell NIL\n" );
+                        debug_printf( DEBUG_ALLOC, L"Allocated special cell NIL\n" );
                         break;
                     case 1:
                         /*
@@ -78,7 +80,7 @@ void make_cons_page(  ) {
                         cell->payload.free.cdr = ( struct cons_pointer ) {
                             0, 1
                         };
-                        fwprintf( stderr, L"Allocated special cell T\n" );
+                        debug_printf( DEBUG_ALLOC, L"Allocated special cell T\n" );
                         break;
                 }
             } else {
@@ -95,7 +97,7 @@ void make_cons_page(  ) {
 
         initialised_cons_pages++;
     } else {
-        fwprintf( stderr,
+        debug_printf( DEBUG_ALLOC,
                   L"FATAL: Failed to allocate memory for cons page %d\n",
                   initialised_cons_pages );
         exit( 1 );
@@ -127,6 +129,9 @@ void dump_pages( FILE * output ) {
 void free_cell( struct cons_pointer pointer ) {
     struct cons_space_object *cell = &pointer2cell( pointer );
 
+    debug_printf( DEBUG_ALLOC, L"Freeing cell " );
+    debug_dump_object( pointer, DEBUG_ALLOC );
+
     switch ( cell->tag.value ) {
             /* for all the types of cons-space object which point to other
              * cons-space objects, cascade the decrement. */
@@ -145,6 +150,10 @@ void free_cell( struct cons_pointer pointer ) {
             dec_ref( cell->payload.lambda.args );
             dec_ref( cell->payload.lambda.body );
             break;
+        case RATIOTV:
+            dec_ref( cell->payload.ratio.dividend );
+            dec_ref( cell->payload.ratio.divisor );
+            break;
         case SPECIALTV:
             dec_ref( cell->payload.special.source );
             break;
@@ -152,24 +161,30 @@ void free_cell( struct cons_pointer pointer ) {
         case SYMBOLTV:
             dec_ref( cell->payload.string.cdr );
             break;
+        case VECTORPOINTTV:
+            /* for vector space pointers, free the actual vector-space
+             * object. Dangerous! */
+            debug_printf( DEBUG_ALLOC, L"About to free vector-space object at %ld\n",
+                      cell->payload.vectorp.address );
+            //free( ( void * ) cell->payload.vectorp.address );
+            break;
+
     }
 
     if ( !check_tag( pointer, FREETAG ) ) {
         if ( cell->count == 0 ) {
-            fwprintf( stderr, L"Freeing cell " );
+            strncpy( &cell->tag.bytes[0], FREETAG, TAGLENGTH );
-            dump_object( stderr, pointer );
-            strncpy( &cell->tag.bytes[0], FREETAG, 4 );
             cell->payload.free.car = NIL;
             cell->payload.free.cdr = freelist;
             freelist = pointer;
         } else {
-            fwprintf( stderr,
+            debug_printf( DEBUG_ALLOC,
-                      L"Attempt to free cell with %d dangling references at page %d, offset %d\n",
+                      L"ERROR: Attempt to free cell with %d dangling references at page %d, offset %d\n",
                       cell->count, pointer.page, pointer.offset );
         }
     } else {
-        fwprintf( stderr,
+        debug_printf( DEBUG_ALLOC,
-                  L"Attempt to free cell which is already FREE at page %d, offset %d\n",
+                  L"ERROR: Attempt to free cell which is already FREE at page %d, offset %d\n",
                   pointer.page, pointer.offset );
     }
 }
@@ -194,19 +209,17 @@ struct cons_pointer allocate_cell( char *tag ) {
         if ( strncmp( &cell->tag.bytes[0], FREETAG, TAGLENGTH ) == 0 ) {
             freelist = cell->payload.free.cdr;
 
-            strncpy( &cell->tag.bytes[0], tag, 4 );
+            strncpy( &cell->tag.bytes[0], tag, TAGLENGTH );
 
             cell->count = 0;
             cell->payload.cons.car = NIL;
             cell->payload.cons.cdr = NIL;
 
-#ifdef DEBUG
+            debug_printf( DEBUG_ALLOC,
-            fwprintf( stderr,
                       L"Allocated cell of type '%s' at %d, %d \n", tag,
                       result.page, result.offset );
-#endif
         } else {
-            fwprintf( stderr, L"WARNING: Allocating non-free cell!" );
+            debug_printf( DEBUG_ALLOC, L"WARNING: Allocating non-free cell!" );
         }
     }
 
@@ -225,7 +238,7 @@ void initialise_cons_pages(  ) {
         make_cons_page(  );
         conspageinitihasbeencalled = true;
     } else {
-        fwprintf( stderr,
+        debug_printf( DEBUG_ALLOC,
                   L"WARNING: initialise_cons_pages() called a second or subsequent time\n" );
     }
 }

src/memory/consspaceobject.c

@@ -20,6 +20,7 @@
 
 #include "conspage.h"
 #include "consspaceobject.h"
+#include "debug.h"
 #include "print.h"
 #include "stack.h"
 
@@ -54,7 +55,7 @@ void inc_ref( struct cons_pointer pointer ) {
 void dec_ref( struct cons_pointer pointer ) {
     struct cons_space_object *cell = &pointer2cell( pointer );
 
-    if ( cell->count <= MAXREFERENCE ) {
+    if ( cell->count > 0 ) {
         cell->count--;
 
         if ( cell->count == 0 ) {
@@ -63,90 +64,6 @@ void dec_ref( struct cons_pointer pointer ) {
     }
 }
 
-void dump_string_cell( FILE * output, wchar_t *prefix,
-                       struct cons_pointer pointer ) {
-    struct cons_space_object cell = pointer2cell( pointer );
-    if ( cell.payload.string.character == 0 ) {
-        fwprintf( output,
-                  L"\t\t%ls cell: termination; next at page %d offset %d, count %u\n",
-                  prefix,
-                  cell.payload.string.cdr.page, cell.payload.string.cdr.offset,
-                  cell.count );
-    } else {
-        fwprintf( output,
-                  L"\t\t%ls cell: character '%lc' (%d) next at page %d offset %d, count %u\n",
-                  prefix,
-                  ( wint_t ) cell.payload.string.character,
-                  cell.payload.string.character,
-                  cell.payload.string.cdr.page,
-                  cell.payload.string.cdr.offset, cell.count );
-        fwprintf( output, L"\t\t value: " );
-        print( output, pointer );
-        fwprintf( output, L"\n" );
-    }
-}
-
-/**
- * dump the object at this cons_pointer to this output stream.
- */
-void dump_object( FILE * output, struct cons_pointer pointer ) {
-    struct cons_space_object cell = pointer2cell( pointer );
-    fwprintf( output,
-              L"\t%c%c%c%c (%d) at page %d, offset %d count %u\n",
-              cell.tag.bytes[0],
-              cell.tag.bytes[1],
-              cell.tag.bytes[2],
-              cell.tag.bytes[3],
-              cell.tag.value, pointer.page, pointer.offset, cell.count );
-
-    switch ( cell.tag.value ) {
-        case CONSTV:
-            fwprintf( output,
-                      L"\t\tCons cell: car at page %d offset %d, cdr at page %d offset %d, count %u\n",
-                      cell.payload.cons.car.page,
-                      cell.payload.cons.car.offset,
-                      cell.payload.cons.cdr.page,
-                      cell.payload.cons.cdr.offset, cell.count );
-            break;
-        case EXCEPTIONTV:
-            fwprintf( output, L"\t\tException cell: " );
-            print( output, cell.payload.exception.message );
-            fwprintf( output, L"\n" );
-            for ( struct stack_frame * frame = cell.payload.exception.frame;
-                  frame != NULL; frame = frame->previous ) {
-                dump_frame( output, frame );
-            }
-            break;
-        case FREETV:
-            fwprintf( output, L"\t\tFree cell: next at page %d offset %d\n",
-                      cell.payload.cons.cdr.page,
-                      cell.payload.cons.cdr.offset );
-            break;
-        case INTEGERTV:
-            fwprintf( output,
-                      L"\t\tInteger cell: value %ld, count %u\n",
-                      cell.payload.integer.value, cell.count );
-            break;
-        case LAMBDATV:
-            fwprintf( output, L"\t\tLambda cell; args: " );
-            print( output, cell.payload.lambda.args );
-            fwprintf( output, L";\n\t\t\tbody: " );
-            print( output, cell.payload.lambda.body );
-            break;
-        case READTV:
-            fwprintf( output, L"\t\tInput stream\n" );
-        case REALTV:
-            fwprintf( output, L"\t\tReal cell: value %Lf, count %u\n",
-                      cell.payload.real.value, cell.count );
-            break;
-        case STRINGTV:
-            dump_string_cell( output, L"String", pointer );
-            break;
-        case SYMBOLTV:
-            dump_string_cell( output, L"Symbol", pointer );
-            break;
-    }
-}
 
 /**
  * Construct a cons cell from this pair of pointers.
@@ -170,20 +87,24 @@ struct cons_pointer make_cons( struct cons_pointer car,
 /**
  * Construct an exception cell.
  * @param message should be a lisp string describing the problem, but actually any cons pointer will do;
- * @param frame should be the frame in which the exception occurred.
+ * @param frame_pointer should be the pointer to the frame in which the exception occurred.
  */
 struct cons_pointer make_exception( struct cons_pointer message,
-                                    struct stack_frame *frame ) {
+                                    struct cons_pointer frame_pointer ) {
+    struct cons_pointer result = NIL;
     struct cons_pointer pointer = allocate_cell( EXCEPTIONTAG );
     struct cons_space_object *cell = &pointer2cell( pointer );
 
     inc_ref( pointer );         /* this is a hack; I don't know why it's necessary to do this, but if I don't the cell gets freed */
 
     inc_ref( message );
+    inc_ref( frame_pointer );
     cell->payload.exception.message = message;
-    cell->payload.exception.frame = frame;
+    cell->payload.exception.frame = frame_pointer;
 
-    return pointer;
+    result = pointer;
+
+    return result;
 }
 
 
@@ -192,7 +113,8 @@ struct cons_pointer make_exception( struct cons_pointer message,
  */
 struct cons_pointer
 make_function( struct cons_pointer src, struct cons_pointer ( *executable )
-                ( struct stack_frame *, struct cons_pointer ) ) {
+                ( struct stack_frame *,
+                  struct cons_pointer, struct cons_pointer ) ) {
     struct cons_pointer pointer = allocate_cell( FUNCTIONTAG );
     struct cons_space_object *cell = &pointer2cell( pointer );
 
@@ -257,11 +179,13 @@ make_string_like_thing( wint_t c, struct cons_pointer tail, char *tag ) {
         cell->payload.string.character = c;
         cell->payload.string.cdr.page = tail.page;
         /* TODO: There's a problem here. Sometimes the offsets on
-         * strings are quite massively off. */
+         * strings are quite massively off. Fix is probably
+         * cell->payload.string.cdr = tsil */
         cell->payload.string.cdr.offset = tail.offset;
     } else {
-        fwprintf( stderr,
+      // TODO: should throw an exception!
-                  L"Warning: only NIL and %s can be appended to %s\n",
+        debug_printf( DEBUG_ALLOC,
+                  L"Warning: only NIL and %s can be prepended to %s\n",
                   tag, tag );
     }
 
@@ -290,7 +214,8 @@ struct cons_pointer make_symbol( wint_t c, struct cons_pointer tail ) {
  */
 struct cons_pointer
 make_special( struct cons_pointer src, struct cons_pointer ( *executable )
-               ( struct stack_frame * frame, struct cons_pointer env ) ) {
+               ( struct stack_frame * frame,
+                 struct cons_pointer, struct cons_pointer env ) ) {
     struct cons_pointer pointer = allocate_cell( SPECIALTAG );
     struct cons_space_object *cell = &pointer2cell( pointer );
 
@@ -327,26 +252,26 @@ struct cons_pointer make_write_stream( FILE * output ) {
 }
 
 /**
- * Return a lisp string representation of this old skool ASCII string.
+ * Return a lisp string representation of this wide character string.
  */
-struct cons_pointer c_string_to_lisp_string( char *string ) {
+struct cons_pointer c_string_to_lisp_string( wchar_t *string ) {
     struct cons_pointer result = NIL;
 
-    for ( int i = strlen( string ); i > 0; i-- ) {
+    for ( int i = wcslen( string ); i > 0; i-- ) {
-        result = make_string( ( wint_t ) string[i - 1], result );
+        result = make_string( string[i - 1], result );
     }
 
     return result;
 }
 
 /**
- * Return a lisp symbol representation of this old skool ASCII string.
+ * Return a lisp symbol representation of this wide character string.
  */
-struct cons_pointer c_string_to_lisp_symbol( char *symbol ) {
+struct cons_pointer c_string_to_lisp_symbol( wchar_t *symbol ) {
     struct cons_pointer result = NIL;
 
-    for ( int i = strlen( symbol ); i > 0; i-- ) {
+    for ( int i = wcslen( symbol ); i > 0; i-- ) {
-        result = make_symbol( ( wint_t ) symbol[i - 1], result );
+        result = make_symbol( symbol[i - 1], result );
     }
 
     return result;

src/memory/consspaceobject.h

@@ -28,6 +28,13 @@
 /**
  * tag values, all of which must be 4 bytes. Must not collide with vector space tag values
  */
+
+/**
+ * A word within a bignum - arbitrary precision integer.
+ */
+#define BIGNUMTAG "BIGN"
+#define BIGNUMTV 1313294658
+
 /**
  * An ordinary cons cell: 1397641027
  */
@@ -38,7 +45,6 @@
  * An exception.
  */
 #define EXCEPTIONTAG "EXEP"
-/* TODO: this is wrong */
 #define EXCEPTIONTV 1346721861
 
 /**
@@ -91,6 +97,12 @@
 #define REALTAG     "REAL"
 #define REALTV      1279346002
 
+/**
+ * A ratio.
+ */
+#define RATIOTAG    "RTIO"
+#define RATIOTV     1330205778
+
 /**
  * A special form - one whose arguments are not pre-evaluated but passed as a
  * s-expression. 1296453715
@@ -121,12 +133,11 @@
  * A pointer to an object in vector space.
  */
 #define VECTORPOINTTAG  "VECP"
-
+#define VECTORPOINTTV 1346585942
 /**
  * An open write stream.
  */
 #define WRITETAG    "WRIT"
-/* TODO: this is wrong */
 #define WRITETV 1414091351
 
 /**
@@ -157,6 +168,11 @@
  */
 #define nilp(conspoint) (check_tag(conspoint,NILTAG))
 
+/**
+ * true if conspointer points to a cons cell, else false
+ */
+#define bignump(conspoint) (check_tag(conspoint,BIGNUMTAG))
+
 /**
  * true if conspointer points to a cons cell, else false
  */
@@ -197,6 +213,11 @@
  */
 #define integerp(conspoint) (check_tag(conspoint,INTEGERTAG))
 
+/**
+ * true if conspointer points to a rational number cell, else false
+ */
+#define ratiop(conspoint) (check_tag(conspoint,RATIOTAG))
+
 /**
  * true if conspointer points to a read stream cell, else false
  */
@@ -211,7 +232,14 @@
  * true if conspointer points to some sort of a number cell,
  * else false
  */
-#define numberp(conspoint) (check_tag(conspoint,INTEGERTAG)||check_tag(conspoint,REALTAG))
+#define numberp(conspoint) (check_tag(conspoint,INTEGERTAG)||check_tag(conspoint,RATIOTAG)||check_tag(conspoint,REALTAG)||check_tag(conspoint,BIGNUMTAG))
+
+#define sequencep(conspoint) (check_tag(conspoint,CONSTAG)||check_tag(conspoint,STRINGTAG)||check_tag(conspoint,SYMBOLTAG))
+
+/**
+ * true if thr conspointer points to a vector pointer.
+ */
+#define vectorpointp(conspoint) (check_tag(conspoint,VECTORPOINTTAG))
 
 /**
  * true if conspointer points to a write stream cell, else false.
@@ -235,9 +263,10 @@
  * An indirect pointer to a cons cell
  */
 struct cons_pointer {
-    uint32_t page;              /* the index of the page on which this cell
+   /** the index of the page on which this cell resides */
-                                 * resides */
+    uint32_t page;
-    uint32_t offset;            /* the index of the cell within the page */
+    /** the index of the cell within the page */
+    uint32_t offset;
 };
 
 /*
@@ -250,15 +279,26 @@ struct cons_pointer {
  * here to avoid circularity. TODO: refactor.
  */
 struct stack_frame {
-    struct stack_frame *previous; /* the previous frame */
+    struct cons_pointer previous; /* the previous frame */
     struct cons_pointer arg[args_in_frame];
     /*
      * first 8 arument bindings
      */
     struct cons_pointer more;   /* list of any further argument bindings */
     struct cons_pointer function; /* the function to be called */
+    int args;
 };
 
+/**
+ * payload of a bignum cell. Intentionally similar to an integer payload, but
+ * with a next pointer.
+ */
+struct bignum_payload {
+    int64_t value;
+    struct cons_pointer next;
+};
+
+
 /**
  * payload of a cons cell.
  */
@@ -273,7 +313,7 @@ struct cons_payload {
  */
 struct exception_payload {
     struct cons_pointer message;
-    struct stack_frame *frame;
+    struct cons_pointer frame;
 };
 
 /**
@@ -288,6 +328,7 @@ struct exception_payload {
 struct function_payload {
     struct cons_pointer source;
     struct cons_pointer ( *executable ) ( struct stack_frame *,
+                                          struct cons_pointer,
                                           struct cons_pointer );
 };
 
@@ -306,7 +347,7 @@ struct free_payload {
  * optional bignum object.
  */
 struct integer_payload {
-    long int value;
+    int64_t value;
 };
 
 /**
@@ -317,10 +358,19 @@ struct lambda_payload {
     struct cons_pointer body;
 };
 
+/**
+ * payload for ratio cells. Both dividend and divisor must point to integer (or, later, bignum) cells.
+ */
+struct ratio_payload {
+    struct cons_pointer dividend;
+    struct cons_pointer divisor;
+};
+
 /**
  * payload for a real number cell. Internals of this liable to change to give 128 bits
  * precision, but I'm not sure of the detail.
- */ struct real_payload {
+ */
+struct real_payload {
     long double value;
 };
 
@@ -332,13 +382,11 @@ struct lambda_payload {
  * its argument list) and a cons pointer (representing its environment) and a
  * stack frame (representing the previous stack frame) as arguments and returns
  * a cons pointer (representing its result).
- *
- * NOTE that this means that special forms do not appear on the lisp stack,
- * which may be confusing. TODO: think about this.
  */
 struct special_payload {
     struct cons_pointer source;
     struct cons_pointer ( *executable ) ( struct stack_frame *,
+                                          struct cons_pointer,
                                           struct cons_pointer );
 };
 
@@ -361,6 +409,9 @@ struct string_payload {
     struct cons_pointer cdr;
 };
 
+/**
+ * payload of a vector pointer cell.
+ */
 struct vectorp_payload {
     union {
         char bytes[TAGLENGTH];  /* the tag (type) of the
@@ -371,7 +422,8 @@ struct vectorp_payload {
                                  * tag. */
         uint32_t value;         /* the tag considered as a number */
     } tag;
-    uint64_t address;           /* the address of the actual vector space
+    void *address;
+    /* the address of the actual vector space
      * object (TODO: will change when I actually
      * implement vector space) */
 };
@@ -418,6 +470,10 @@ struct cons_space_object {
          * if tag == NILTAG; we'll treat the special cell NIL as just a cons
          */
         struct cons_payload nil;
+        /*
+         * if tag == RATIOTAG
+         */
+        struct ratio_payload ratio;
         /*
          * if tag == READTAG || tag == WRITETAG
          */
@@ -460,20 +516,11 @@ void inc_ref( struct cons_pointer pointer );
  */
 void dec_ref( struct cons_pointer pointer );
 
-/**
- * dump the object at this cons_pointer to this output stream.
- */
-void dump_object( FILE * output, struct cons_pointer pointer );
-
 struct cons_pointer make_cons( struct cons_pointer car,
                                struct cons_pointer cdr );
-/**
+
- * Construct an exception cell.
- * @param message should be a lisp string describing the problem, but actually any cons pointer will do;
- * @param frame should be the frame in which the exception occurred.
- */
 struct cons_pointer make_exception( struct cons_pointer message,
-                                    struct stack_frame *frame );
+                                    struct cons_pointer frame_pointer );
 
 /**
  * Construct a cell which points to an executable Lisp special form.
@@ -481,6 +528,7 @@ struct cons_pointer make_exception( struct cons_pointer message,
 struct cons_pointer make_function( struct cons_pointer src,
                                    struct cons_pointer ( *executable )
                                     ( struct stack_frame *,
+                                      struct cons_pointer,
                                       struct cons_pointer ) );
 
 /**
@@ -502,6 +550,7 @@ struct cons_pointer make_nlambda( struct cons_pointer args,
 struct cons_pointer make_special( struct cons_pointer src,
                                   struct cons_pointer ( *executable )
                                    ( struct stack_frame *,
+                                     struct cons_pointer,
                                      struct cons_pointer ) );
 
 /**
@@ -533,11 +582,11 @@ struct cons_pointer make_write_stream( FILE * output );
 /**
  * Return a lisp string representation of this old skool ASCII string.
  */
-struct cons_pointer c_string_to_lisp_string( char *string );
+struct cons_pointer c_string_to_lisp_string( wchar_t *string );
 
 /**
  * Return a lisp symbol representation of this old skool ASCII string.
  */
-struct cons_pointer c_string_to_lisp_symbol( char *symbol );
+struct cons_pointer c_string_to_lisp_symbol( wchar_t *symbol );
 
 #endif

src/memory/cursor.c

@@ -0,0 +1,9 @@
+/*
+ * a cursor is a cons-space object which holds:
+ * 1. a pointer to a vector (i.e. a vector-space object which holds an
+ *    array of `cons_pointer`);
+ * 2. an integer offset into that array.
+ *
+ * this provides a mechanism for iterating through vectors (actually, in
+ * either direction)
+ */

src/memory/dump.c

@@ -0,0 +1,140 @@
+/*
+ *  dump.c
+ *
+ *  Dump representations of both cons space and vector space objects.
+ *
+ *
+ *  (c) 2018 Simon Brooke <simon@journeyman.cc>
+ *  Licensed under GPL version 2.0, or, at your option, any later version.
+ */
+
+#include <stdint.h>
+#include <stdlib.h>
+#include <string.h>
+#include <stdio.h>
+/*
+ * wide characters
+ */
+#include <wchar.h>
+#include <wctype.h>
+
+#include "conspage.h"
+#include "consspaceobject.h"
+#include "debug.h"
+#include "print.h"
+#include "stack.h"
+#include "vectorspace.h"
+
+
+void dump_string_cell( FILE * output, wchar_t *prefix,
+                       struct cons_pointer pointer ) {
+    struct cons_space_object cell = pointer2cell( pointer );
+    if ( cell.payload.string.character == 0 ) {
+        fwprintf( output,
+                  L"\t\t%ls cell: termination; next at page %d offset %d, count %u\n",
+                  prefix,
+                  cell.payload.string.cdr.page, cell.payload.string.cdr.offset,
+                  cell.count );
+    } else {
+        fwprintf( output,
+                  L"\t\t%ls cell: character '%lc' (%d) next at page %d offset %d, count %u\n",
+                  prefix,
+                  ( wint_t ) cell.payload.string.character,
+                  cell.payload.string.character,
+                  cell.payload.string.cdr.page,
+                  cell.payload.string.cdr.offset, cell.count );
+        fwprintf( output, L"\t\t value: " );
+        print( output, pointer );
+        fwprintf( output, L"\n" );
+    }
+}
+
+/**
+ * dump the object at this cons_pointer to this output stream.
+ */
+void dump_object( FILE * output, struct cons_pointer pointer ) {
+    struct cons_space_object cell = pointer2cell( pointer );
+    fwprintf( output,
+              L"\t%4.4s (%d) at page %d, offset %d count %u\n",
+              cell.tag.bytes,
+              cell.tag.value, pointer.page, pointer.offset, cell.count );
+
+    switch ( cell.tag.value ) {
+        case CONSTV:
+            fwprintf( output,
+                      L"\t\tCons cell: car at page %d offset %d, cdr at page %d offset %d, count %u :",
+                      cell.payload.cons.car.page,
+                      cell.payload.cons.car.offset,
+                      cell.payload.cons.cdr.page,
+                      cell.payload.cons.cdr.offset, cell.count );
+            print( output, pointer);
+            fputws( L"\n", output);
+            break;
+        case EXCEPTIONTV:
+            fwprintf( output, L"\t\tException cell: " );
+            dump_stack_trace( output, pointer );
+            break;
+        case FREETV:
+            fwprintf( output, L"\t\tFree cell: next at page %d offset %d\n",
+                      cell.payload.cons.cdr.page,
+                      cell.payload.cons.cdr.offset );
+            break;
+        case INTEGERTV:
+            fwprintf( output,
+                      L"\t\tInteger cell: value %ld, count %u\n",
+                      cell.payload.integer.value, cell.count );
+            break;
+        case LAMBDATV:
+            fwprintf( output, L"\t\tLambda cell; args: " );
+            print( output, cell.payload.lambda.args );
+            fwprintf( output, L";\n\t\t\tbody: " );
+            print( output, cell.payload.lambda.body );
+            break;
+        case NILTV:
+            break;
+        case RATIOTV:
+            fwprintf( output,
+                      L"\t\tRational cell: value %ld/%ld, count %u\n",
+                      pointer2cell( cell.payload.ratio.dividend ).
+                      payload.integer.value,
+                      pointer2cell( cell.payload.ratio.divisor ).
+                      payload.integer.value, cell.count );
+            break;
+        case READTV:
+            fwprintf( output, L"\t\tInput stream\n" );
+            break;
+        case REALTV:
+            fwprintf( output, L"\t\tReal cell: value %Lf, count %u\n",
+                      cell.payload.real.value, cell.count );
+            break;
+        case STRINGTV:
+            dump_string_cell( output, L"String", pointer );
+            break;
+        case SYMBOLTV:
+            dump_string_cell( output, L"Symbol", pointer );
+            break;
+        case TRUETV:
+            break;
+        case VECTORPOINTTV:{
+                fwprintf( output,
+                          L"\t\tPointer to vector-space object at %p\n",
+                          cell.payload.vectorp.address );
+                struct vector_space_object *vso = cell.payload.vectorp.address;
+                fwprintf( output,
+                          L"\t\tVector space object of type %4.4s (%d), payload size %d bytes\n",
+                          &vso->header.tag.bytes, vso->header.tag.value, vso->header.size );
+          if (stackframep(vso)) {
+            dump_frame(output, pointer);
+          }
+                switch ( vso->header.tag.value ) {
+                    case STACKFRAMETV:
+                        dump_frame( output, pointer );
+                        break;
+                }
+            }
+            break;
+        case WRITETV:
+            fwprintf( output, L"\t\tOutput stream\n" );
+            break;
+    }
+}

src/memory/dump.h

@@ -0,0 +1,29 @@
+/**
+ *  dump.h
+ *
+ *  Dump representations of both cons space and vector space objects.
+ *
+ *  (c) 2018 Simon Brooke <simon@journeyman.cc>
+ *  Licensed under GPL version 2.0, or, at your option, any later version.
+ */
+
+#include <stdbool.h>
+#include <stdint.h>
+#include <stdio.h>
+/*
+ * wide characters
+ */
+#include <wchar.h>
+#include <wctype.h>
+
+#ifndef __dump_h
+#define __dump_h
+
+
+/**
+ * dump the object at this cons_pointer to this output stream.
+ */
+void dump_object( FILE * output, struct cons_pointer pointer );
+
+
+#endif

src/memory/stack.c

@@ -0,0 +1,298 @@
+/*
+ * stack.c
+ *
+ * The Lisp evaluation stack.
+ *
+ * Stack frames could be implemented in cons space; indeed, the stack
+ * could simply be an assoc list consed onto the front of the environment.
+ * But such a stack would be costly to search. The design sketched here,
+ * with stack frames as special objects, SHOULD be substantially more
+ * efficient, but does imply we need to generalise the idea of cons pages
+ * with freelists to a more general 'equal sized object pages', so that
+ * allocating/freeing stack frames can be more efficient.
+ *
+ * (c) 2017 Simon Brooke <simon@journeyman.cc>
+ * Licensed under GPL version 2.0, or, at your option, any later version.
+ */
+
+#include <stdlib.h>
+
+#include "consspaceobject.h"
+#include "conspage.h"
+#include "debug.h"
+#include "dump.h"
+#include "lispops.h"
+#include "print.h"
+#include "stack.h"
+#include "vectorspace.h"
+
+void set_reg(struct stack_frame * frame, int reg, struct cons_pointer value) {
+  debug_printf(DEBUG_STACK, L"Setting register %d to ", reg);
+  debug_print_object(value, DEBUG_STACK);
+  debug_println(DEBUG_STACK);
+  frame->arg[reg++] = value;
+  inc_ref(value);
+  if (reg > frame->args) {
+    frame->args = reg;
+  }
+}
+
+
+/**
+ * get the actual stackframe object from this `pointer`, or NULL if
+ * `pointer` is not a stackframe pointer.
+ */
+struct stack_frame *get_stack_frame( struct cons_pointer pointer ) {
+    struct stack_frame *result = NULL;
+    struct vector_space_object *vso =
+        pointer2cell( pointer ).payload.vectorp.address;
+
+    if ( vectorpointp( pointer ) && stackframep( vso ) ) {
+        result = ( struct stack_frame * ) &( vso->payload );
+        debug_printf( DEBUG_STACK, L"get_stack_frame: all good, returning %p\n",
+                  result );
+    } else {
+        debug_print( L"get_stack_frame: fail, returning NULL\n", DEBUG_STACK );
+    }
+
+    return result;
+}
+
+/**
+ * Make an empty stack frame, and return it.
+ * @param previous the current top-of-stack;
+ * @param env the environment in which evaluation happens.
+ * @return the new frame, or NULL if memory is exhausted.
+ */
+struct cons_pointer make_empty_frame( struct cons_pointer previous ) {
+    debug_print( L"Entering make_empty_frame\n", DEBUG_ALLOC );
+    struct cons_pointer result =
+        make_vso( STACKFRAMETAG, sizeof( struct stack_frame ) );
+
+    debug_dump_object( result, DEBUG_ALLOC );
+
+//    debug_printf( DEBUG_STACK,
+//              L"make_empty_frame: got vector_space_object with size %lu, tag %4.4s\n",
+//              pointer_to_vso( result )->header.size,
+//              &pointer_to_vso( result )->header.tag.bytes );
+
+    if ( !nilp( result ) ) {
+        struct stack_frame *frame = get_stack_frame( result );
+        /*
+         * TODO: later, pop a frame off a free-list of stack frames
+         */
+
+        frame->previous = previous;
+
+        /*
+         * clearing the frame with memset would probably be slightly quicker, but
+         * this is clear.
+         */
+        frame->more = NIL;
+        frame->function = NIL;
+        frame->args = 0;
+
+        for ( int i = 0; i < args_in_frame; i++ ) {
+            frame->arg[i] = NIL;
+        }
+    }
+    debug_print( L"Leaving make_empty_frame\n", DEBUG_ALLOC );
+    debug_dump_object( result, DEBUG_ALLOC);
+
+    return result;
+}
+
+/**
+ * Allocate a new stack frame with its previous pointer set to this value,
+ * its arguments set up from these args, evaluated in this env.
+ * @param previous the current top-of-stack;
+ * @args the arguments to load into this frame;
+ * @param env the environment in which evaluation happens.
+ * @return the new frame, or an exception if one occurred while building it.
+ */
+struct cons_pointer make_stack_frame( struct cons_pointer previous,
+                                      struct cons_pointer args,
+                                      struct cons_pointer env ) {
+    debug_print( L"Entering make_stack_frame\n", DEBUG_STACK );
+    struct cons_pointer result = make_empty_frame( previous );
+
+    if ( nilp( result ) ) {
+        /* i.e. out of memory */
+        result =
+            make_exception( c_string_to_lisp_string( L"Memory exhausted." ),
+                            previous );
+    } else {
+        struct stack_frame *frame = get_stack_frame( result );
+
+        while ( frame->args < args_in_frame && consp( args )) {
+            /* iterate down the arg list filling in the arg slots in the
+             * frame. When there are no more slots, if there are still args,
+             * stash them on more */
+            struct cons_space_object cell = pointer2cell( args );
+
+            /*
+             * TODO: if we were running on real massively parallel hardware,
+             * each arg except the first should be handed off to another
+             * processor to be evaled in parallel; but see notes here:
+             * https://github.com/simon-brooke/post-scarcity/wiki/parallelism
+             */
+                struct cons_pointer val = eval_form(frame, result, cell.payload.cons.car, env);
+                if ( exceptionp( val ) ) {
+                    result = val;
+                    break;
+                } else {
+                    debug_printf( DEBUG_STACK, L"Setting argument %d to ", frame->args);
+                    debug_print_object(cell.payload.cons.car, DEBUG_STACK);
+                    set_reg( frame, frame->args, val );
+                }
+
+                args = cell.payload.cons.cdr;
+            }
+
+        if ( !exceptionp( result ) ) {
+            if ( consp( args ) ) {
+                /* if we still have args, eval them and stick the values on `more` */
+                struct cons_pointer more =
+                    eval_forms( get_stack_frame( previous ), previous, args,
+                                env );
+                frame->more = more;
+                inc_ref( more );
+            }
+
+        }
+    }
+    debug_print( L"make_stack_frame: returning\n", DEBUG_STACK );
+    debug_dump_object( result, DEBUG_STACK );
+
+    return result;
+}
+
+/**
+ * A 'special' frame is exactly like a normal stack frame except that the
+ * arguments are unevaluated.
+ * @param previous the previous stack frame;
+ * @param args a list of the arguments to be stored in this stack frame;
+ * @param env the execution environment;
+ * @return a new special frame.
+ */
+struct cons_pointer make_special_frame( struct cons_pointer previous,
+                                        struct cons_pointer args,
+                                        struct cons_pointer env ) {
+    debug_print( L"Entering make_special_frame\n", DEBUG_STACK );
+
+    struct cons_pointer result = make_empty_frame( previous );
+
+    if ( nilp( result ) ) {
+        /* i.e. out of memory */
+        result =
+            make_exception( c_string_to_lisp_string( L"Memory exhausted." ),
+                            previous );
+    } else {
+        struct stack_frame *frame = get_stack_frame( result );
+
+        while ( frame->args < args_in_frame && !nilp( args )) {
+            /* iterate down the arg list filling in the arg slots in the
+             * frame. When there are no more slots, if there are still args,
+             * stash them on more */
+            struct cons_space_object cell = pointer2cell( args );
+
+            set_reg( frame, frame->args, cell.payload.cons.car );
+
+            args = cell.payload.cons.cdr;
+        }
+        if ( !exceptionp( result ) ) {
+            if ( consp( args ) ) {
+                frame->more = args;
+                inc_ref( args );
+            }
+        }
+    }
+    debug_print( L"make_special_frame: returning\n", DEBUG_STACK );
+    debug_dump_object( result, DEBUG_STACK );
+
+    return result;
+}
+
+/**
+ * Free this stack frame.
+ */
+void free_stack_frame( struct stack_frame *frame ) {
+    /*
+     * TODO: later, push it back on the stack-frame freelist
+     */
+    for ( int i = 0; i < args_in_frame; i++ ) {
+        dec_ref( frame->arg[i] );
+    }
+    if ( !nilp( frame->more ) ) {
+        dec_ref( frame->more );
+    }
+
+    free( frame );
+}
+
+
+/**
+ * Dump a stackframe to this stream for debugging
+ * @param output the stream
+ * @param frame_pointer the pointer to the frame
+ */
+void dump_frame( FILE * output, struct cons_pointer frame_pointer ) {
+    struct stack_frame *frame = get_stack_frame( frame_pointer );
+
+    if ( frame != NULL ) {
+        fwprintf( output, L"Stack frame with %d arguments:\n", frame->args);
+        for ( int arg = 0; arg < frame->args; arg++ ) {
+            struct cons_space_object cell = pointer2cell( frame->arg[arg] );
+
+            fwprintf( output, L"Arg %d:\t%c%c%c%c\tcount: %10u\tvalue: ", arg,
+                      cell.tag.bytes[0],
+                      cell.tag.bytes[1], cell.tag.bytes[2], cell.tag.bytes[3],
+                      cell.count );
+
+            print( output, frame->arg[arg] );
+            fputws( L"\n", output );
+        }
+      if (!nilp(frame->more))
+      {
+        fputws( L"More: \t", output );
+        print( output, frame->more );
+        fputws( L"\n", output );
+      }
+    }
+}
+
+void dump_stack_trace( FILE * output, struct cons_pointer pointer ) {
+    if ( exceptionp( pointer ) ) {
+        print( output, pointer2cell( pointer ).payload.exception.message );
+        fputws( L"\n", output );
+        dump_stack_trace( output,
+                          pointer2cell( pointer ).payload.exception.frame );
+    } else {
+        while ( vectorpointp( pointer )
+                && stackframep( pointer_to_vso( pointer ) ) ) {
+            dump_frame( output, pointer );
+            pointer = get_stack_frame( pointer )->previous;
+        }
+    }
+}
+
+/**
+ * Fetch a pointer to the value of the local variable at this index.
+ */
+struct cons_pointer fetch_arg( struct stack_frame *frame, unsigned int index ) {
+    struct cons_pointer result = NIL;
+
+    if ( index < args_in_frame ) {
+        result = frame->arg[index];
+    } else {
+        struct cons_pointer p = frame->more;
+
+        for ( int i = args_in_frame; i < index; i++ ) {
+            p = pointer2cell( p ).payload.cons.cdr;
+        }
+
+        result = pointer2cell( p ).payload.cons.car;
+    }
+
+    return result;
+}

src/memory/stack.h

@@ -25,38 +25,41 @@
 #define __stack_h
 
 /**
- * Make an empty stack frame, and return it.
+ * macros for the tag of a stack frame.
- * @param previous the current top-of-stack;
- * @param env the environment in which evaluation happens.
- * @return the new frame.
  */
-struct stack_frame *make_empty_frame( struct stack_frame *previous,
+#define STACKFRAMETAG "STAK"
-                                      struct cons_pointer env );
+#define STACKFRAMETV 1262572627
-
-struct stack_frame *make_stack_frame( struct stack_frame *previous,
-                                      struct cons_pointer args,
-                                      struct cons_pointer env,
-                                      struct cons_pointer *exception );
-void free_stack_frame( struct stack_frame *frame );
 
 /**
- * Dump a stackframe to this stream for debugging
+ * is this vector-space object a stack frame?
- * @param output the stream
- * @param frame the frame
  */
-void dump_frame( FILE * output, struct stack_frame *frame );
+#define stackframep(vso)(((struct vector_space_object *)vso)->header.tag.value == STACKFRAMETV)
+
+/**
+ * set a register in a stack frame. Alwaye use this macro to do so,
+ • because that way we can be sure the inc_ref happens!
+ */
+//#define set_reg(frame,register,value){frame->arg[register]=value; inc_ref(value);}
+
+void set_reg(struct stack_frame * frame, int reg, struct cons_pointer value);
+
+struct stack_frame *get_stack_frame( struct cons_pointer pointer );
+
+struct cons_pointer make_empty_frame( struct cons_pointer previous );
+
+struct cons_pointer make_stack_frame( struct cons_pointer previous,
+                                      struct cons_pointer args,
+                                      struct cons_pointer env );
+
+void free_stack_frame( struct stack_frame *frame );
+
+void dump_frame( FILE * output, struct cons_pointer pointer );
+
+void dump_stack_trace( FILE * output, struct cons_pointer frame_pointer );
 
 struct cons_pointer fetch_arg( struct stack_frame *frame, unsigned int n );
 
-/**
+struct cons_pointer make_special_frame( struct cons_pointer previous,
- * A 'special' frame is exactly like a normal stack frame except that the
- * arguments are unevaluated.
- * @param previous the previous stack frame;
- * @param args a list of the arguments to be stored in this stack frame;
- * @param env the execution environment;
- * @return a new special frame.
- */
-struct stack_frame *make_special_frame( struct stack_frame *previous,
                                         struct cons_pointer args,
                                         struct cons_pointer env );
 

src/memory/vectorspace.c

@@ -0,0 +1,97 @@
+/*
+ *  vectorspace.c
+ *
+ *  Structures common to all vector space objects.
+ *
+ *
+ *  (c) 2017 Simon Brooke <simon@journeyman.cc>
+ *  Licensed under GPL version 2.0, or, at your option, any later version.
+ */
+
+#include <math.h>
+#include <stdint.h>
+#include <stdlib.h>
+#include <string.h>
+#include <stdio.h>
+/*
+ * wide characters
+ */
+#include <wchar.h>
+#include <wctype.h>
+
+#include "conspage.h"
+#include "consspaceobject.h"
+#include "debug.h"
+#include "vectorspace.h"
+
+
+/**
+ * make a cons-space object which points to the vector space object
+ * with this `tag` at this `address`.
+ * NOTE that `tag` should be the vector-space tag of the particular type of
+ * vector-space object, NOT `VECTORPOINTTAG`.
+ */
+struct cons_pointer make_vec_pointer( struct vector_space_object *address ) {
+    debug_print( L"Entered make_vec_pointer\n", DEBUG_ALLOC );
+    struct cons_pointer pointer = allocate_cell( VECTORPOINTTAG );
+    struct cons_space_object *cell = &pointer2cell( pointer );
+    debug_printf( DEBUG_ALLOC,
+              L"make_vec_pointer: tag written, about to set pointer address to %p\n",
+              address );
+    cell->payload.vectorp.address = address;
+    debug_printf( DEBUG_ALLOC, L"make_vec_pointer: all good, returning pointer to %p\n",
+              cell->payload.vectorp.address );
+
+    debug_dump_object( pointer, DEBUG_ALLOC );
+
+    return pointer;
+}
+
+/**
+ * allocate a vector space object with this `payload_size` and `tag`,
+ * and return a `cons_pointer` which points to an object whigh points to it.
+ * NOTE that `tag` should be the vector-space tag of the particular type of
+ * vector-space object, NOT `VECTORPOINTTAG`.
+ * Returns NIL if the vector could not be allocated due to memory exhaustion.
+ */
+struct cons_pointer make_vso( char *tag, uint64_t payload_size ) {
+    debug_print( L"Entered make_vso\n", DEBUG_ALLOC );
+    struct cons_pointer result = NIL;
+    int64_t total_size = sizeof( struct vector_space_header ) + payload_size;
+
+    /* Pad size to 64 bit words. This is intended to promote access efficiancy
+     * on 64 bit machines but may just be voodoo coding */
+    uint64_t padded = ceil( ( total_size * 8.0 ) / 8.0 );
+    debug_print( L"make_vso: about to malloc\n", DEBUG_ALLOC );
+    struct vector_space_object *vso = malloc( padded );
+
+    if ( vso != NULL ) {
+        debug_printf( DEBUG_ALLOC,
+                  L"make_vso: about to write tag '%s' into vso at %p\n", tag,
+                  vso );
+        strncpy( &vso->header.tag.bytes[0], tag, TAGLENGTH );
+        result = make_vec_pointer( vso );
+        debug_dump_object( result, DEBUG_ALLOC );
+        vso->header.vecp = result;
+        // memcpy(vso->header.vecp, result, sizeof(struct cons_pointer));
+
+        vso->header.size = payload_size;
+
+#ifdef DEBUG
+        debug_printf( DEBUG_ALLOC,
+                  L"Allocated vector-space object of type %4.4s, total size %ld, payload size %ld, at address %p, payload address %p\n",
+                  &vso->header.tag.bytes, total_size, vso->header.size, vso,
+                  &vso->payload );
+        if ( padded != total_size ) {
+            debug_printf( DEBUG_ALLOC, L"\t\tPadded from %d to %d\n",
+                      total_size, padded );
+        }
+#endif
+    }
+#ifdef DEBUG
+    debug_printf( DEBUG_ALLOC, L"make_vso: all good, returning pointer to %p\n",
+              pointer2cell( result ).payload.vectorp.address );
+#endif
+
+    return result;
+}

src/memory/vectorspace.h

@@ -0,0 +1,71 @@
+/**
+ *  vectorspace.h
+ *
+ *  Declarations common to all vector space objects.
+ *
+ *
+ *  (c) 2017 Simon Brooke <simon@journeyman.cc>
+ *  Licensed under GPL version 2.0, or, at your option, any later version.
+ */
+
+#include <stdbool.h>
+#include <stdint.h>
+#include <stdio.h>
+/*
+ * wide characters
+ */
+#include <wchar.h>
+#include <wctype.h>
+
+#include "consspaceobject.h"
+
+#ifndef __vectorspace_h
+#define __vectorspace_h
+
+/*
+ * part of the implementation structure of a namespace.
+ */
+#define HASHTAG "HASH"
+#define HASHTV 0
+
+/*
+ * a namespace (i.e. a binding of names to values, implemented as a hashmap)
+ */
+#define NAMESPACETAG "NMSP"
+#define NAMESPACETV 0
+
+/*
+ * a vector of cons pointers.
+ */
+#define VECTORTAG "VECT"
+#define VECTORTV 0
+
+#define pointer_to_vso(pointer)((vectorpointp(pointer)? (struct vector_space_object *) pointer2cell(pointer).payload.vectorp.address : (struct vector_space_object *) NULL))
+#define vso_get_vecp(vso)((vso->header.vecp))
+
+struct cons_pointer make_vso( char *tag, uint64_t payload_size );
+
+struct vector_space_header {
+    union {
+        char bytes[TAGLENGTH];  /* the tag (type) of the
+                                 * vector-space object this cell
+                                 * points to, considered as bytes.
+                                 * NOTE that the vector space object
+                                 * should itself have the identical
+                                 * tag. */
+        uint32_t value;         /* the tag considered as a number */
+    } tag;
+    struct cons_pointer vecp;   /* back pointer to the vector pointer
+                                 * which uniquely points to this vso */
+    uint64_t size;              /* the size of my payload, in bytes */
+};
+
+struct vector_space_object {
+    struct vector_space_header header;
+    char payload;               /* we'll malloc `size` bytes for payload,
+                                 * `payload` is just the first of these.
+                                 * TODO: this is almost certainly not
+                                 * idiomatic C. */
+};
+
+#endif

src/ops/equal.c

@@ -80,8 +80,8 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) {
                     && ( equal( cell_a->payload.string.cdr,
                                 cell_b->payload.string.cdr )
                          || ( end_of_string( cell_a->payload.string.cdr )
-                              && end_of_string( cell_b->payload.string.
+                              && end_of_string( cell_b->payload.
-                                                cdr ) ) );
+                                                string.cdr ) ) );
                 break;
             case INTEGERTV:
                 result =

src/ops/intern.c

@@ -21,6 +21,7 @@
 
 #include "conspage.h"
 #include "consspaceobject.h"
+#include "debug.h"
 #include "equal.h"
 #include "lispops.h"
 #include "print.h"
@@ -56,22 +57,22 @@ internedp( struct cons_pointer key, struct cons_pointer store ) {
             struct cons_space_object entry =
                 pointer2cell( pointer2cell( next ).payload.cons.car );
 
-            fputws( L"Internedp: checking whether `", stderr );
+            debug_print( L"Internedp: checking whether `", DEBUG_ALLOC );
-            print( stderr, key );
+            debug_print_object( key, DEBUG_ALLOC );
-            fputws( L"` equals `", stderr );
+            debug_print( L"` equals `", DEBUG_ALLOC );
-            print( stderr, entry.payload.cons.car );
+            debug_print_object( entry.payload.cons.car, DEBUG_ALLOC );
-            fputws( L"`\n", stderr );
+            debug_print( L"`\n", DEBUG_ALLOC );
 
             if ( equal( key, entry.payload.cons.car ) ) {
                 result = entry.payload.cons.car;
             }
         }
     } else {
-        fputws( L"`", stderr );
+        debug_print( L"`", DEBUG_ALLOC );
-        print( stderr, key );
+        debug_print_object( key, DEBUG_ALLOC );
-        fputws( L"` is a ", stderr );
+        debug_print( L"` is a ", DEBUG_ALLOC );
-        print( stderr, c_type( key ) );
+        debug_print_object( c_type( key ), DEBUG_ALLOC );
-        fputws( L", not a SYMB", stderr );
+        debug_print( L", not a SYMB", DEBUG_ALLOC );
     }
 
     return result;
@@ -110,6 +111,12 @@ struct cons_pointer c_assoc( struct cons_pointer key,
 struct cons_pointer
 bind( struct cons_pointer key, struct cons_pointer value,
       struct cons_pointer store ) {
+  debug_print(L"Binding ", DEBUG_ALLOC);
+  debug_print_object(key, DEBUG_ALLOC);
+  debug_print(L" to ", DEBUG_ALLOC);
+  debug_print_object(value, DEBUG_ALLOC);
+  debug_println(DEBUG_ALLOC);
+
     return make_cons( make_cons( key, value ), store );
 }
 
@@ -120,7 +127,17 @@ bind( struct cons_pointer key, struct cons_pointer value,
  */
 struct cons_pointer
 deep_bind( struct cons_pointer key, struct cons_pointer value ) {
+    debug_print( L"Entering deep_bind\n", DEBUG_ALLOC );
+    debug_print( L"\tSetting ", DEBUG_ALLOC );
+    debug_print_object( key, DEBUG_ALLOC );
+    debug_print( L" to ", DEBUG_ALLOC );
+    debug_print_object( value, DEBUG_ALLOC );
+    debug_print( L"\n", DEBUG_ALLOC );
+
     oblist = bind( key, value, oblist );
+
+    debug_print( L"Leaving deep_bind\n", DEBUG_ALLOC );
+
     return oblist;
 }
 

src/ops/lispops.c

@@ -26,6 +26,8 @@
 
 #include "consspaceobject.h"
 #include "conspage.h"
+#include "debug.h"
+#include "dump.h"
 #include "equal.h"
 #include "integer.h"
 #include "intern.h"
@@ -80,23 +82,27 @@ struct cons_pointer c_cdr( struct cons_pointer arg ) {
  * @return the result of evaluating the form.
  */
 struct cons_pointer eval_form( struct stack_frame *parent,
+                               struct cons_pointer parent_pointer,
                                struct cons_pointer form,
                                struct cons_pointer env ) {
-    fputws( L"eval_form: ", stderr );
+    debug_print( L"eval_form: ", DEBUG_EVAL );
-    print( stderr, form );
+    debug_dump_object( form, DEBUG_EVAL );
-    fputws( L"\n", stderr );
 
     struct cons_pointer result = NIL;
-    struct stack_frame *next = make_empty_frame( parent, env );
+    struct cons_pointer next_pointer = make_empty_frame( parent_pointer );
-    next->arg[0] = form;
+    inc_ref( next_pointer );
-    inc_ref( next->arg[0] );
+
-    result = lisp_eval( next, env );
+    struct stack_frame *next = get_stack_frame( next_pointer );
+    set_reg( next, 0, form );
+    next->args = 1;
+
+    result = lisp_eval( next, next_pointer, env );
 
     if ( !exceptionp( result ) ) {
         /* if we're returning an exception, we should NOT free the
          * stack frame. Corollary is, when we free an exception, we
          * should free all the frames it's holding on to. */
-        free_stack_frame( next );
+        dec_ref( next_pointer );
     }
 
     return result;
@@ -108,11 +114,14 @@ struct cons_pointer eval_form( struct stack_frame *parent,
  * `list` is not in fact a list, return nil.
  */
 struct cons_pointer eval_forms( struct stack_frame *frame,
+                                struct cons_pointer frame_pointer,
                                 struct cons_pointer list,
                                 struct cons_pointer env ) {
+    /* TODO: refactor. This runs up the C stack. */
     return consp( list ) ?
-        make_cons( eval_form( frame, c_car( list ), env ),
+        make_cons( eval_form( frame, frame_pointer, c_car( list ), env ),
-                   eval_forms( frame, c_cdr( list ), env ) ) : NIL;
+                   eval_forms( frame, frame_pointer, c_cdr( list ),
+                               env ) ) : NIL;
 }
 
 /**
@@ -121,7 +130,8 @@ struct cons_pointer eval_forms( struct stack_frame *frame,
  * (oblist)
  */
 struct cons_pointer
-lisp_oblist( struct stack_frame *frame, struct cons_pointer env ) {
+lisp_oblist( struct stack_frame *frame, struct cons_pointer frame_pointer,
+             struct cons_pointer env ) {
     return oblist;
 }
 
@@ -130,8 +140,7 @@ lisp_oblist( struct stack_frame *frame, struct cons_pointer env ) {
  * used to construct the body for `lambda` and `nlambda` expressions.
  */
 struct cons_pointer compose_body( struct stack_frame *frame ) {
-    struct cons_pointer body =
+    struct cons_pointer body = frame->more;
-        !nilp( frame->arg[args_in_frame - 1] ) ? frame->more : NIL;
 
     for ( int i = args_in_frame - 1; i > 0; i-- ) {
         if ( !nilp( body ) ) {
@@ -141,9 +150,8 @@ struct cons_pointer compose_body( struct stack_frame *frame ) {
         }
     }
 
-    fputws( L"compose_body returning ", stderr );
+    debug_print( L"compose_body returning ", DEBUG_LAMBDA );
-    print( stderr, body );
+    debug_dump_object( body, DEBUG_LAMBDA );
-    fputws( L"\n", stderr );
 
     return body;
 }
@@ -155,7 +163,8 @@ struct cons_pointer compose_body( struct stack_frame *frame ) {
  * @param env the environment in which it is to be intepreted.
  */
 struct cons_pointer
-lisp_lambda( struct stack_frame *frame, struct cons_pointer env ) {
+lisp_lambda( struct stack_frame *frame, struct cons_pointer frame_pointer,
+             struct cons_pointer env ) {
     return make_lambda( frame->arg[0], compose_body( frame ) );
 }
 
@@ -166,16 +175,16 @@ lisp_lambda( struct stack_frame *frame, struct cons_pointer env ) {
  * @param env the environment in which it is to be intepreted.
  */
 struct cons_pointer
-lisp_nlambda( struct stack_frame *frame, struct cons_pointer env ) {
+lisp_nlambda( struct stack_frame *frame, struct cons_pointer frame_pointer,
+              struct cons_pointer env ) {
     return make_nlambda( frame->arg[0], compose_body( frame ) );
 }
 
 void log_binding( struct cons_pointer name, struct cons_pointer val ) {
-    print( stderr, c_string_to_lisp_string( "\n\tBinding " ) );
+    debug_print( L"\n\tBinding ", DEBUG_ALLOC );
-    print( stderr, name );
+    debug_dump_object( name, DEBUG_ALLOC );
-    print( stderr, c_string_to_lisp_string( " to " ) );
+    debug_print( L" to ", DEBUG_ALLOC );
-    print( stderr, val );
+    debug_dump_object( val, DEBUG_ALLOC );
-    fputws( L"\"\n", stderr );
 }
 
 /**
@@ -183,9 +192,9 @@ void log_binding( struct cons_pointer name, struct cons_pointer val ) {
  */
 struct cons_pointer
 eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
-             struct cons_pointer env ) {
+             struct cons_pointer frame_pointer, struct cons_pointer env ) {
     struct cons_pointer result = NIL;
-    fwprintf( stderr, L"eval_lambda called\n" );
+    debug_print( L"eval_lambda called\n", DEBUG_EVAL );
 
     struct cons_pointer new_env = env;
     struct cons_pointer names = cell.payload.lambda.args;
@@ -194,7 +203,7 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
     if ( consp( names ) ) {
         /* if `names` is a list, bind successive items from that list
          * to values of arguments */
-        for ( int i = 0; i < args_in_frame && consp( names ); i++ ) {
+        for ( int i = 0; i < frame->args && consp( names ); i++ ) {
             struct cons_pointer name = c_car( names );
             struct cons_pointer val = frame->arg[i];
 
@@ -203,13 +212,16 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
 
             names = c_cdr( names );
         }
+      /* TODO: if there's more than `args_in_frame` arguments, bind those too. */
     } else if ( symbolp( names ) ) {
         /* if `names` is a symbol, rather than a list of symbols,
          * then bind a list of the values of args to that symbol. */
+        /* TODO: eval all the things in frame->more */
         struct cons_pointer vals = frame->more;
 
         for ( int i = args_in_frame - 1; i >= 0; i-- ) {
-            struct cons_pointer val = eval_form( frame, frame->arg[i], env );
+            struct cons_pointer val =
+                eval_form( frame, frame_pointer, frame->arg[i], env );
 
             if ( nilp( val ) && nilp( vals ) ) {  /* nothing */
             } else {
@@ -223,8 +235,10 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
     while ( !nilp( body ) ) {
         struct cons_pointer sexpr = c_car( body );
         body = c_cdr( body );
-        fputws( L"In lambda: ", stderr );
+
-        result = eval_form( frame, sexpr, new_env );
+        debug_print( L"In lambda: ", DEBUG_LAMBDA );
+
+        result = eval_form( frame, frame_pointer, sexpr, new_env );
     }
 
     return result;
@@ -239,20 +253,17 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
  * @return the result of evaluating the function with its arguments.
  */
 struct cons_pointer
-c_apply( struct stack_frame *frame, struct cons_pointer env ) {
+c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
+         struct cons_pointer env ) {
+  debug_print(L"Entering c_apply\n", DEBUG_EVAL);
   struct cons_pointer result = NIL;
-    struct stack_frame *fn_frame = make_empty_frame( frame, env );
-    fn_frame->arg[0] = c_car( frame->arg[0] );
-    inc_ref( fn_frame->arg[0] );
-    struct cons_pointer fn_pointer = lisp_eval( fn_frame, env );
 
-    if ( !exceptionp( result ) ) {
+    struct cons_pointer fn_pointer =
-        /* if we're returning an exception, we should NOT free the
+        eval_form( frame, frame_pointer, c_car( frame->arg[0] ), env );
-         * stack frame. Corollary is, when we free an exception, we
-         * should free all the frames it's holding on to. */
-        free_stack_frame( fn_frame );
-    }
 
+    if ( exceptionp( fn_pointer ) ) {
+        result = fn_pointer;
+    } else {
     struct cons_space_object fn_cell = pointer2cell( fn_pointer );
     struct cons_pointer args = c_cdr( frame->arg[0] );
 
@@ -264,80 +275,92 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) {
         case FUNCTIONTV:
             {
                 struct cons_pointer exep = NIL;
-                struct stack_frame *next =
+                struct cons_pointer next_pointer =
-                    make_stack_frame( frame, args, env, &exep );
+                    make_stack_frame( frame_pointer, args, env );
-                result = ( *fn_cell.payload.special.executable ) ( next, env );
+                inc_ref( next_pointer );
-                if ( exceptionp( exep ) ) {
+                if ( exceptionp( next_pointer ) ) {
-                    /* if we're returning an exception, we should NOT free the
+                    result = next_pointer;
-                     * stack frame. Corollary is, when we free an exception, we
-                     * should free all the frames it's holding on to. */
-                    result = exep;
                 } else {
-                    free_stack_frame( next );
+                    struct stack_frame *next = get_stack_frame( next_pointer );
+
+                    result =
+                        ( *fn_cell.payload.function.executable ) ( next,
+                                                                   next_pointer,
+                                                                   env );
+                    dec_ref( next_pointer );
                 }
             }
             break;
         case LAMBDATV:
             {
                 struct cons_pointer exep = NIL;
-                struct stack_frame *next =
+                struct cons_pointer next_pointer =
-                    make_stack_frame( frame, args, env, &exep );
+                    make_stack_frame( frame_pointer, args, env );
-                fputws( L"Stack frame for lambda\n", stderr );
+                inc_ref( next_pointer );
-                dump_frame( stderr, next );
+                if ( exceptionp( next_pointer ) ) {
-                result = eval_lambda( fn_cell, next, env );
+                    result = next_pointer;
-                if ( exceptionp( result ) ) {
-                    /* if we're returning an exception, we should NOT free the
-                     * stack frame. Corollary is, when we free an exception, we
-                     * should free all the frames it's holding on to. */
-                    result = exep;
                 } else {
-                    free_stack_frame( next );
+                    struct stack_frame *next = get_stack_frame( next_pointer );
+                    result = eval_lambda( fn_cell, next, next_pointer, env );
+                    if ( !exceptionp( result ) ) {
+                        dec_ref( next_pointer );
+                    }
                 }
             }
             break;
         case NLAMBDATV:
             {
+                struct cons_pointer next_pointer =
+                    make_special_frame( frame_pointer, args, env );
+                inc_ref( next_pointer );
+                if ( exceptionp( next_pointer ) ) {
+                    result = next_pointer;
+                } else {
                     struct stack_frame *next =
-                    make_special_frame( frame, args, env );
+                        get_stack_frame( next_pointer );
-                fputws( L"Stack frame for nlambda\n", stderr );
+                    result = eval_lambda( fn_cell, next, next_pointer, env );
-                dump_frame( stderr, next );
+                        dec_ref( next_pointer );
-                result = eval_lambda( fn_cell, next, env );
-                if ( !exceptionp( result ) ) {
-                    /* if we're returning an exception, we should NOT free the
-                     * stack frame. Corollary is, when we free an exception, we
-                     * should free all the frames it's holding on to. */
-                    free_stack_frame( next );
                 }
             }
             break;
         case SPECIALTV:
             {
-                struct stack_frame *next =
+                struct cons_pointer next_pointer =
-                    make_special_frame( frame, args, env );
+                    make_special_frame( frame_pointer, args, env );
-                result = ( *fn_cell.payload.special.executable ) ( next, env );
+                inc_ref( next_pointer );
-                if ( !exceptionp( result ) ) {
+                if ( exceptionp( next_pointer ) ) {
-                    /* if we're returning an exception, we should NOT free the
+                    result = next_pointer;
-                     * stack frame. Corollary is, when we free an exception, we
+                } else {
-                     * should free all the frames it's holding on to. */
+                    result =
-                    free_stack_frame( next );
+                        ( *fn_cell.payload.special.executable ) ( get_stack_frame( next_pointer ),
+                                                                  next_pointer,
+                                                                  env );
+                   debug_print(L"Special form returning: ", DEBUG_EVAL);
+                  debug_print_object(result, DEBUG_EVAL);
+                  debug_println(DEBUG_EVAL);
+                    dec_ref( next_pointer );
                 }
             }
             break;
         default:
             {
-                char *buffer = malloc( 1024 );
+              int bs = sizeof(wchar_t) * 1024;
-                memset( buffer, '\0', 1024 );
+                wchar_t *buffer = malloc( bs );
-                sprintf( buffer,
+                memset( buffer, '\0', bs );
-                         "Unexpected cell with tag %d (%c%c%c%c) in function position",
+                swprintf( buffer, bs,
-                         fn_cell.tag.value, fn_cell.tag.bytes[0],
+                         L"Unexpected cell with tag %d (%4.4s) in function position",
-                         fn_cell.tag.bytes[1], fn_cell.tag.bytes[2],
+                         fn_cell.tag.value, &fn_cell.tag.bytes[0] );
-                         fn_cell.tag.bytes[3] );
                 struct cons_pointer message =
                     c_string_to_lisp_string( buffer );
                 free( buffer );
-                result = lisp_throw( message, frame );
+                result = throw_exception( message, frame_pointer );
             }
     }
+    }
+
+    debug_print(L"c_apply: returning: ", DEBUG_EVAL);
+    debug_print_object(result, DEBUG_EVAL);
+    debug_println(DEBUG_EVAL);
 
     return result;
 }
@@ -349,13 +372,13 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) {
  * @return As a Lisp string, the tag of the object which is at that pointer.
  */
 struct cons_pointer c_type( struct cons_pointer pointer ) {
-    char *buffer = malloc( TAGLENGTH + 1 );
+    struct cons_pointer result = NIL;
-    memset( buffer, 0, TAGLENGTH + 1 );
     struct cons_space_object cell = pointer2cell( pointer );
-    strncpy( buffer, cell.tag.bytes, TAGLENGTH );
 
-    struct cons_pointer result = c_string_to_lisp_string( buffer );
+    for (int i = TAGLENGTH; i >= 0; i--)
-    free( buffer );
+    {
+      result = make_string((wchar_t)cell.tag.bytes[i], result);
+    }
 
     return result;
 }
@@ -375,17 +398,18 @@ struct cons_pointer c_type( struct cons_pointer pointer ) {
  * If a special form, passes the cdr of s_expr to the special form as argument.
  */
 struct cons_pointer
-lisp_eval( struct stack_frame *frame, struct cons_pointer env ) {
+lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer,
+           struct cons_pointer env ) {
+    debug_print( L"Eval: ", DEBUG_EVAL );
+    debug_dump_object( frame_pointer, DEBUG_EVAL );
+
     struct cons_pointer result = frame->arg[0];
     struct cons_space_object cell = pointer2cell( frame->arg[0] );
 
-    fputws( L"Eval: ", stderr );
-    dump_frame( stderr, frame );
-
     switch ( cell.tag.value ) {
         case CONSTV:
             {
-                result = c_apply( frame, env );
+                result = c_apply( frame, frame_pointer, env );
             }
             break;
 
@@ -396,9 +420,9 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer env ) {
                 if ( nilp( canonical ) ) {
                     struct cons_pointer message =
                         make_cons( c_string_to_lisp_string
-                                   ( "Attempt to take value of unbound symbol." ),
+                                   ( L"Attempt to take value of unbound symbol." ),
                                    frame->arg[0] );
-                    result = lisp_throw( message, frame );
+                    result = throw_exception( message, frame_pointer );
                 } else {
                     result = c_assoc( canonical, env );
                     inc_ref( result );
@@ -418,9 +442,8 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer env ) {
             break;
     }
 
-    fputws( L"Eval returning ", stderr );
+    debug_print( L"Eval returning ", DEBUG_EVAL );
-    print( stderr, result );
+    debug_dump_object( result, DEBUG_EVAL );
-    fputws( L"\n", stderr );
 
     return result;
 }
@@ -434,19 +457,19 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer env ) {
  * the second argument
  */
 struct cons_pointer
-lisp_apply( struct stack_frame *frame, struct cons_pointer env ) {
+lisp_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
-    fputws( L"Apply: ", stderr );
+            struct cons_pointer env ) {
-    dump_frame( stderr, frame );
+#ifdef DEBUG
+    debug_print( L"Apply: ", DEBUG_EVAL );
+    dump_frame( stderr, frame_pointer );
+#endif
+    set_reg( frame, 0, make_cons( frame->arg[0], frame->arg[1] ) );
+    set_reg( frame, 1, NIL );
 
-    frame->arg[0] = make_cons( frame->arg[0], frame->arg[1] );
+    struct cons_pointer result = c_apply( frame, frame_pointer, env );
-    inc_ref( frame->arg[0] );
-    frame->arg[1] = NIL;
 
-    struct cons_pointer result = c_apply( frame, env );
+    debug_print( L"Apply returning ", DEBUG_EVAL );
-
+    debug_dump_object( result, DEBUG_EVAL );
-    fputws( L"Apply returning ", stderr );
-    print( stderr, result );
-    fputws( L"\n", stderr );
 
     return result;
 }
@@ -460,7 +483,8 @@ lisp_apply( struct stack_frame *frame, struct cons_pointer env ) {
  * this isn't at this stage checked) unevaluated.
  */
 struct cons_pointer
-lisp_quote( struct stack_frame *frame, struct cons_pointer env ) {
+lisp_quote( struct stack_frame *frame, struct cons_pointer frame_pointer,
+            struct cons_pointer env ) {
     return frame->arg[0];
 }
 
@@ -475,7 +499,8 @@ lisp_quote( struct stack_frame *frame, struct cons_pointer env ) {
  * the namespace in so doing. `namespace` defaults to the value of `oblist`.
  */
 struct cons_pointer
-lisp_set( struct stack_frame *frame, struct cons_pointer env ) {
+lisp_set( struct stack_frame *frame, struct cons_pointer frame_pointer,
+          struct cons_pointer env ) {
     struct cons_pointer result = NIL;
     struct cons_pointer namespace =
         nilp( frame->arg[2] ) ? oblist : frame->arg[2];
@@ -487,8 +512,9 @@ lisp_set( struct stack_frame *frame, struct cons_pointer env ) {
         result =
             make_exception( make_cons
                             ( c_string_to_lisp_string
-                              ( "The first argument to `set!` is not a symbol: " ),
+                              ( L"The first argument to `set` is not a symbol: " ),
-                              make_cons( frame->arg[0], NIL ) ), frame );
+                              make_cons( frame->arg[0], NIL ) ),
+                            frame_pointer );
     }
 
     return result;
@@ -505,21 +531,24 @@ lisp_set( struct stack_frame *frame, struct cons_pointer env ) {
  * the namespace in so doing. `namespace` defaults to the value of `oblist`.
  */
 struct cons_pointer
-lisp_set_shriek( struct stack_frame *frame, struct cons_pointer env ) {
+lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer,
+                 struct cons_pointer env ) {
     struct cons_pointer result = NIL;
     struct cons_pointer namespace =
         nilp( frame->arg[2] ) ? oblist : frame->arg[2];
 
     if ( symbolp( frame->arg[0] ) ) {
-        struct cons_pointer val = eval_form( frame, frame->arg[1], env );
+        struct cons_pointer val =
+            eval_form( frame, frame_pointer, frame->arg[1], env );
         deep_bind( frame->arg[0], val );
         result = val;
     } else {
         result =
             make_exception( make_cons
                             ( c_string_to_lisp_string
-                              ( "The first argument to `set!` is not a symbol: " ),
+                              ( L"The first argument to `set!` is not a symbol: " ),
-                              make_cons( frame->arg[0], NIL ) ), frame );
+                              make_cons( frame->arg[0], NIL ) ),
+                            frame_pointer );
     }
 
     return result;
@@ -534,7 +563,8 @@ lisp_set_shriek( struct stack_frame *frame, struct cons_pointer env ) {
  * otherwise returns a new cons cell.
  */
 struct cons_pointer
-lisp_cons( struct stack_frame *frame, struct cons_pointer env ) {
+lisp_cons( struct stack_frame *frame, struct cons_pointer frame_pointer,
+           struct cons_pointer env ) {
     struct cons_pointer car = frame->arg[0];
     struct cons_pointer cdr = frame->arg[1];
     struct cons_pointer result;
@@ -558,7 +588,8 @@ lisp_cons( struct stack_frame *frame, struct cons_pointer env ) {
  * strings, and TODO read streams and other things which can be considered as sequences.
  */
 struct cons_pointer
-lisp_car( struct stack_frame *frame, struct cons_pointer env ) {
+lisp_car( struct stack_frame *frame, struct cons_pointer frame_pointer,
+          struct cons_pointer env ) {
     struct cons_pointer result = NIL;
 
     if ( consp( frame->arg[0] ) ) {
@@ -569,8 +600,8 @@ lisp_car( struct stack_frame *frame, struct cons_pointer env ) {
         result = make_string( cell.payload.string.character, NIL );
     } else {
         struct cons_pointer message =
-            c_string_to_lisp_string( "Attempt to take CAR of non sequence" );
+            c_string_to_lisp_string( L"Attempt to take CAR of non sequence" );
-        result = lisp_throw( message, frame );
+        result = throw_exception( message, frame_pointer );
     }
 
     return result;
@@ -582,7 +613,8 @@ lisp_car( struct stack_frame *frame, struct cons_pointer env ) {
  * strings, and TODO read streams and other things which can be considered as sequences.
  */
 struct cons_pointer
-lisp_cdr( struct stack_frame *frame, struct cons_pointer env ) {
+lisp_cdr( struct stack_frame *frame, struct cons_pointer frame_pointer,
+          struct cons_pointer env ) {
     struct cons_pointer result = NIL;
 
     if ( consp( frame->arg[0] ) ) {
@@ -593,8 +625,8 @@ lisp_cdr( struct stack_frame *frame, struct cons_pointer env ) {
         result = cell.payload.string.cdr;
     } else {
         struct cons_pointer message =
-            c_string_to_lisp_string( "Attempt to take CDR of non sequence" );
+            c_string_to_lisp_string( L"Attempt to take CDR of non sequence" );
-        result = lisp_throw( message, frame );
+        result = throw_exception( message, frame_pointer );
     }
 
     return result;
@@ -605,7 +637,8 @@ lisp_cdr( struct stack_frame *frame, struct cons_pointer env ) {
  * Returns the value associated with key in store, or NIL if not found.
  */
 struct cons_pointer
-lisp_assoc( struct stack_frame *frame, struct cons_pointer env ) {
+lisp_assoc( struct stack_frame *frame, struct cons_pointer frame_pointer,
+            struct cons_pointer env ) {
     return c_assoc( frame->arg[0], frame->arg[1] );
 }
 
@@ -614,6 +647,7 @@ lisp_assoc( struct stack_frame *frame, struct cons_pointer env ) {
  * Returns T if a and b are pointers to the same object, else NIL
  */
 struct cons_pointer lisp_eq( struct stack_frame *frame,
+                             struct cons_pointer frame_pointer,
                              struct cons_pointer env ) {
     return eq( frame->arg[0], frame->arg[1] ) ? TRUE : NIL;
 }
@@ -623,7 +657,8 @@ struct cons_pointer lisp_eq( struct stack_frame *frame,
  * Returns T if a and b are pointers to structurally identical objects, else NIL
  */
 struct cons_pointer
-lisp_equal( struct stack_frame *frame, struct cons_pointer env ) {
+lisp_equal( struct stack_frame *frame, struct cons_pointer frame_pointer,
+            struct cons_pointer env ) {
     return equal( frame->arg[0], frame->arg[1] ) ? TRUE : NIL;
 }
 
@@ -634,14 +669,58 @@ lisp_equal( struct stack_frame *frame, struct cons_pointer env ) {
  * is a read stream, then read from that stream, else stdin.
  */
 struct cons_pointer
-lisp_read( struct stack_frame *frame, struct cons_pointer env ) {
+lisp_read( struct stack_frame *frame, struct cons_pointer frame_pointer,
+           struct cons_pointer env ) {
+#ifdef DEBUG
+    debug_print( L"entering lisp_read\n", DEBUG_IO );
+#endif
     FILE *input = stdin;
 
     if ( readp( frame->arg[0] ) ) {
         input = pointer2cell( frame->arg[0] ).payload.stream.stream;
     }
 
-    return read( frame, input );
+    struct cons_pointer result = read( frame, frame_pointer, input );
+    debug_print( L"lisp_read returning\n", DEBUG_IO );
+    debug_dump_object( result, DEBUG_IO );
+
+    return result;
+}
+
+
+/**
+ * reverse a sequence.
+ */
+struct cons_pointer c_reverse( struct cons_pointer arg ) {
+    struct cons_pointer result = NIL;
+
+    for ( struct cons_pointer p = arg; sequencep( p ); p = c_cdr( p ) ) {
+        struct cons_space_object o = pointer2cell( p );
+        switch ( o.tag.value ) {
+            case CONSTV:
+                result = make_cons( o.payload.cons.car, result );
+                break;
+            case STRINGTV:
+                result = make_string( o.payload.string.character, result );
+                break;
+            case SYMBOLTV:
+                result = make_symbol( o.payload.string.character, result );
+                break;
+        }
+    }
+
+    return result;
+}
+
+
+/**
+ * (reverse sequence)
+ * Return a sequence like this sequence but with the members in the reverse order.
+ */
+struct cons_pointer lisp_reverse( struct stack_frame *frame,
+                                  struct cons_pointer frame_pointer,
+                                  struct cons_pointer env ) {
+    return c_reverse( frame->arg[0] );
 }
 
 
@@ -652,16 +731,26 @@ lisp_read( struct stack_frame *frame, struct cons_pointer env ) {
  * is a write stream, then print to that stream, else stdout.
  */
 struct cons_pointer
-lisp_print( struct stack_frame *frame, struct cons_pointer env ) {
+lisp_print( struct stack_frame *frame, struct cons_pointer frame_pointer,
+            struct cons_pointer env ) {
+    debug_print( L"Entering print\n", DEBUG_IO );
+    struct cons_pointer result = NIL;
     FILE *output = stdout;
 
     if ( writep( frame->arg[1] ) ) {
+        debug_print( L"lisp_print: setting output stream\n", DEBUG_IO );
+        debug_dump_object( frame->arg[1], DEBUG_IO );
         output = pointer2cell( frame->arg[1] ).payload.stream.stream;
     }
+    debug_print( L"lisp_print: about to print\n", DEBUG_IO );
+    debug_dump_object( frame->arg[0], DEBUG_IO );
 
-    print( output, frame->arg[0] );
+    result = print( output, frame->arg[0] );
 
-    return NIL;
+    debug_print( L"lisp_print returning\n", DEBUG_IO );
+    debug_dump_object( result, DEBUG_IO );
+
+    return result;
 }
 
 
@@ -672,7 +761,8 @@ lisp_print( struct stack_frame *frame, struct cons_pointer env ) {
  * @return As a Lisp string, the tag of the object which is the argument.
  */
 struct cons_pointer
-lisp_type( struct stack_frame *frame, struct cons_pointer env ) {
+lisp_type( struct stack_frame *frame, struct cons_pointer frame_pointer,
+           struct cons_pointer env ) {
     return c_type( frame->arg[0] );
 }
 
@@ -690,16 +780,17 @@ lisp_type( struct stack_frame *frame, struct cons_pointer env ) {
  * argument.
  */
 struct cons_pointer
-lisp_progn( struct stack_frame *frame, struct cons_pointer env ) {
+lisp_progn( struct stack_frame *frame, struct cons_pointer frame_pointer,
+            struct cons_pointer env ) {
     struct cons_pointer remaining = frame->more;
     struct cons_pointer result = NIL;
 
     for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] ); i++ ) {
-        result = eval_form( frame, frame->arg[i], env );
+        result = eval_form( frame, frame_pointer, frame->arg[i], env );
     }
 
     while ( consp( remaining ) ) {
-        result = eval_form( frame, c_car( remaining ), env );
+        result = eval_form( frame, frame_pointer, c_car( remaining ), env );
 
         remaining = c_cdr( remaining );
     }
@@ -717,22 +808,26 @@ lisp_progn( struct stack_frame *frame, struct cons_pointer env ) {
  * @return the value of the last form of the first successful clause.
  */
 struct cons_pointer
-lisp_cond( struct stack_frame *frame, struct cons_pointer env ) {
+lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer,
+           struct cons_pointer env ) {
     struct cons_pointer result = NIL;
     bool done = false;
 
     for ( int i = 0; i < args_in_frame && !done; i++ ) {
         struct cons_pointer clause_pointer = frame->arg[i];
-        fputws( L"Cond clause: ", stderr );
+        debug_print( L"Cond clause: ", DEBUG_EVAL );
-        print( stderr, clause_pointer );
+        debug_dump_object( clause_pointer, DEBUG_EVAL );
 
         if ( consp( clause_pointer ) ) {
             struct cons_space_object cell = pointer2cell( clause_pointer );
-            result = eval_form( frame, c_car( clause_pointer ), env );
+            result =
+                eval_form( frame, frame_pointer, c_car( clause_pointer ),
+                           env );
 
             if ( !nilp( result ) ) {
                 struct cons_pointer vals =
-                    eval_forms( frame, c_cdr( clause_pointer ), env );
+                    eval_forms( frame, frame_pointer, c_cdr( clause_pointer ),
+                                env );
 
                 while ( consp( vals ) ) {
                     result = c_car( vals );
@@ -744,9 +839,9 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer env ) {
         } else if ( nilp( clause_pointer ) ) {
             done = true;
         } else {
-            result = lisp_throw( c_string_to_lisp_string
+            result = throw_exception( c_string_to_lisp_string
-                                 ( "Arguments to `cond` must be lists" ),
+                                      ( L"Arguments to `cond` must be lists" ),
-                                 frame );
+                                      frame_pointer );
         }
     }
     /* TODO: if there are more than 8 clauses we need to continue into the
@@ -756,17 +851,20 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer env ) {
 }
 
 /**
- * TODO: make this do something sensible somehow.
+ * Throw an exception.
- * This requires that a frame be a heap-space object with a cons-space
+ * `throw_exception` is a misnomer, because it doesn't obey the calling signature of a
+ * lisp function; but it is nevertheless to be preferred to make_exception. A
+ * real `throw_exception`, which does, will be needed.
  * object pointing to it. Then this should become a normal lisp function
  * which expects a normally bound frame and environment, such that
  * frame->arg[0] is the message, and frame->arg[1] is the cons-space
  * pointer to the frame in which the exception occurred.
  */
 struct cons_pointer
-lisp_throw( struct cons_pointer message, struct stack_frame *frame ) {
+throw_exception( struct cons_pointer message,
-    fwprintf( stderr, L"\nERROR: " );
+                 struct cons_pointer frame_pointer ) {
-    print( stderr, message );
+    debug_print( L"\nERROR: ", DEBUG_EVAL );
+    debug_dump_object( message, DEBUG_EVAL );
     struct cons_pointer result = NIL;
 
     struct cons_space_object cell = pointer2cell( message );
@@ -774,8 +872,25 @@ lisp_throw( struct cons_pointer message, struct stack_frame *frame ) {
     if ( cell.tag.value == EXCEPTIONTV ) {
         result = message;
     } else {
-        result = make_exception( message, frame );
+        result = make_exception( message, frame_pointer );
     }
 
     return result;
 }
+
+/**
+ * (exception <message>)
+ *
+ * Function. Returns an exception whose message is this `message`, and whose
+ * stack frame is the parent stack frame when the function is invoked.
+ * `message` does not have to be a string but should be something intelligible
+ * which can be read.
+ * If `message` is itself an exception, returns that instead.
+ */
+struct cons_pointer
+lisp_exception( struct stack_frame *frame, struct cons_pointer frame_pointer,
+                struct cons_pointer env ) {
+    struct cons_pointer message = frame->arg[0];
+    return exceptionp( message ) ? message : make_exception( message,
+                                                             frame->previous );
+}

src/ops/lispops.h

@@ -40,6 +40,7 @@ struct cons_pointer c_car( struct cons_pointer arg );
  */
 struct cons_pointer c_cdr( struct cons_pointer arg );
 
+struct cons_pointer c_reverse( struct cons_pointer arg );
 
 /**
  * Useful building block; evaluate this single form in the context of this
@@ -50,6 +51,7 @@ struct cons_pointer c_cdr( struct cons_pointer arg );
  * @return the result of evaluating the form.
  */
 struct cons_pointer eval_form( struct stack_frame *parent,
+                               struct cons_pointer parent_pointer,
                                struct cons_pointer form,
                                struct cons_pointer env );
 
@@ -59,6 +61,7 @@ struct cons_pointer eval_form( struct stack_frame *parent,
  * `list` is not in fact a list, return nil.
  */
 struct cons_pointer eval_forms( struct stack_frame *frame,
+                                struct cons_pointer frame_pointer,
                                 struct cons_pointer list,
                                 struct cons_pointer env );
 
@@ -67,18 +70,23 @@ struct cons_pointer eval_forms( struct stack_frame *frame,
  * special forms
  */
 struct cons_pointer lisp_eval( struct stack_frame *frame,
+                               struct cons_pointer frame_pointer,
                                struct cons_pointer env );
 struct cons_pointer lisp_apply( struct stack_frame *frame,
+                                struct cons_pointer frame_pointer,
                                 struct cons_pointer env );
 
 struct cons_pointer
-lisp_oblist( struct stack_frame *frame, struct cons_pointer env );
+lisp_oblist( struct stack_frame *frame, struct cons_pointer frame_pointer,
+             struct cons_pointer env );
 
 struct cons_pointer
-lisp_set( struct stack_frame *frame, struct cons_pointer env );
+lisp_set( struct stack_frame *frame, struct cons_pointer frame_pointer,
+          struct cons_pointer env );
 
 struct cons_pointer
-lisp_set_shriek( struct stack_frame *frame, struct cons_pointer env );
+lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer,
+                 struct cons_pointer env );
 
 /**
  * Construct an interpretable function.
@@ -88,6 +96,7 @@ lisp_set_shriek( struct stack_frame *frame, struct cons_pointer env );
  * @param env the environment in which it is to be intepreted.
  */
 struct cons_pointer lisp_lambda( struct stack_frame *frame,
+                                 struct cons_pointer frame_pointer,
                                  struct cons_pointer env );
 
 /**
@@ -97,29 +106,42 @@ struct cons_pointer lisp_lambda( struct stack_frame *frame,
  * @param env the environment in which it is to be intepreted.
  */
 struct cons_pointer
-lisp_nlambda( struct stack_frame *frame, struct cons_pointer env );
+lisp_nlambda( struct stack_frame *frame, struct cons_pointer frame_pointer,
+              struct cons_pointer env );
 
 struct cons_pointer lisp_quote( struct stack_frame *frame,
+                                struct cons_pointer frame_pointer,
                                 struct cons_pointer env );
 
 /*
  * functions
  */
 struct cons_pointer lisp_cons( struct stack_frame *frame,
+                               struct cons_pointer frame_pointer,
                                struct cons_pointer env );
 struct cons_pointer lisp_car( struct stack_frame *frame,
+                              struct cons_pointer frame_pointer,
                               struct cons_pointer env );
 struct cons_pointer lisp_cdr( struct stack_frame *frame,
+                              struct cons_pointer frame_pointer,
                               struct cons_pointer env );
 struct cons_pointer lisp_assoc( struct stack_frame *frame,
+                                struct cons_pointer frame_pointer,
                                 struct cons_pointer env );
 struct cons_pointer lisp_eq( struct stack_frame *frame,
+                             struct cons_pointer frame_pointer,
                              struct cons_pointer env );
 struct cons_pointer lisp_equal( struct stack_frame *frame,
-                                struct cons_pointer env );
+                                struct cons_pointer frame_pointer,
-struct cons_pointer lisp_read( struct stack_frame *frame,
                                 struct cons_pointer env );
 struct cons_pointer lisp_print( struct stack_frame *frame,
+                                struct cons_pointer frame_pointer,
+                                struct cons_pointer env );
+struct cons_pointer lisp_read( struct stack_frame *frame,
+                               struct cons_pointer frame_pointer,
+                               struct cons_pointer env );
+struct cons_pointer lisp_reverse( struct stack_frame *frame,
+                                  struct cons_pointer frame_pointer,
                                   struct cons_pointer env );
 /**
  * Function: Get the Lisp type of the single argument.
@@ -128,7 +150,8 @@ struct cons_pointer lisp_print( struct stack_frame *frame,
  * @return As a Lisp string, the tag of the object which is the argument.
  */
 struct cons_pointer
-lisp_type( struct stack_frame *frame, struct cons_pointer env );
+lisp_type( struct stack_frame *frame, struct cons_pointer frame_pointer,
+           struct cons_pointer env );
 
 
 /**
@@ -142,7 +165,8 @@ lisp_type( struct stack_frame *frame, struct cons_pointer env );
  * argument.
  */
 struct cons_pointer
-lisp_progn( struct stack_frame *frame, struct cons_pointer env );
+lisp_progn( struct stack_frame *frame, struct cons_pointer frame_pointer,
+            struct cons_pointer env );
 
 /**
  * Special form: conditional. Each arg is expected to be a list; if the first
@@ -154,10 +178,18 @@ lisp_progn( struct stack_frame *frame, struct cons_pointer env );
  * @return the value of the last form of the first successful clause.
  */
 struct cons_pointer
-lisp_cond( struct stack_frame *frame, struct cons_pointer env );
+lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer,
+           struct cons_pointer env );
 
-/*
+/**
- * neither, at this stage, really
+ * Throw an exception.
+ * `throw_exception` is a misnomer, because it doesn't obey the calling signature of a
+ * lisp function; but it is nevertheless to be preferred to make_exception. A
+ * real `throw_exception`, which does, will be needed.
  */
-struct cons_pointer lisp_throw( struct cons_pointer message,
+struct cons_pointer throw_exception( struct cons_pointer message,
-                                struct stack_frame *frame );
+                                     struct cons_pointer frame_pointer );
+
+struct cons_pointer
+lisp_exception( struct stack_frame *frame, struct cons_pointer frame_pointer,
+                struct cons_pointer env );

src/ops/print.c

@@ -20,6 +20,7 @@
 #include "conspage.h"
 #include "consspaceobject.h"
 #include "integer.h"
+#include "stack.h"
 #include "print.h"
 
 /**
@@ -36,7 +37,7 @@ int print_use_colours = 0;
 void print_string_contents( FILE * output, struct cons_pointer pointer ) {
     while ( stringp( pointer ) || symbolp( pointer ) ) {
         struct cons_space_object *cell = &pointer2cell( pointer );
-        wint_t c = cell->payload.string.character;
+        wchar_t c = cell->payload.string.character;
 
         if ( c != '\0' ) {
             fputwc( c, output );
@@ -103,7 +104,7 @@ void print_list( FILE * output, struct cons_pointer pointer ) {
  * Print the cons-space object indicated by `pointer` to the stream indicated
  * by `output`.
  */
-void print( FILE * output, struct cons_pointer pointer ) {
+struct cons_pointer print( FILE * output, struct cons_pointer pointer ) {
     struct cons_space_object cell = pointer2cell( pointer );
     char *buffer;
 
@@ -118,7 +119,7 @@ void print( FILE * output, struct cons_pointer pointer ) {
         case EXCEPTIONTV:
             fwprintf( output, L"\n%sException: ",
                       print_use_colours ? "\x1B[31m" : "" );
-            print_string_contents( output, cell.payload.exception.message );
+            dump_stack_trace( output, pointer );
             break;
         case FUNCTIONTV:
             fwprintf( output, L"(Function)" );
@@ -130,19 +131,24 @@ void print( FILE * output, struct cons_pointer pointer ) {
             fwprintf( output, L"%ld%", cell.payload.integer.value );
             break;
         case LAMBDATV:
-            print( output, make_cons( c_string_to_lisp_symbol( "lambda" ),
+            print( output, make_cons( c_string_to_lisp_symbol( L"lambda" ),
                                       make_cons( cell.payload.lambda.args,
-                                                 cell.payload.
+                                                 cell.payload.lambda.
-                                                 lambda.body ) ) );
+                                                 body ) ) );
             break;
         case NILTV:
             fwprintf( output, L"nil" );
             break;
         case NLAMBDATV:
-            print( output, make_cons( c_string_to_lisp_symbol( "nlambda" ),
+            print( output, make_cons( c_string_to_lisp_symbol( L"nlambda" ),
                                       make_cons( cell.payload.lambda.args,
-                                                 cell.payload.
+                                                 cell.payload.lambda.
-                                                 lambda.body ) ) );
+                                                 body ) ) );
+            break;
+        case RATIOTV:
+            print( output, cell.payload.ratio.dividend );
+            fputws( L"/", output );
+            print( output, cell.payload.ratio.divisor );
             break;
         case READTV:
             fwprintf( output, L"(Input stream)" );
@@ -184,6 +190,9 @@ void print( FILE * output, struct cons_pointer pointer ) {
         case TRUETV:
             fwprintf( output, L"t" );
             break;
+        case WRITETV:
+            fwprintf( output, L"(Output stream)" );
+            break;
         default:
             fwprintf( stderr,
                       L"%sError: Unrecognised tag value %d (%c%c%c%c)\n",
@@ -196,4 +205,6 @@ void print( FILE * output, struct cons_pointer pointer ) {
     if ( print_use_colours ) {
         fputws( L"\x1B[39m", output );
     }
+
+    return pointer;
 }

src/ops/print.h

@@ -14,7 +14,7 @@
 #ifndef __print_h
 #define __print_h
 
-void print( FILE * output, struct cons_pointer pointer );
+struct cons_pointer print( FILE * output, struct cons_pointer pointer );
 extern int print_use_colours;
 
 #endif

src/ops/read.c

@@ -18,12 +18,16 @@
 #include <wctype.h>
 
 #include "consspaceobject.h"
+#include "debug.h"
+#include "dump.h"
 #include "integer.h"
 #include "intern.h"
 #include "lispops.h"
 #include "print.h"
+#include "ratio.h"
 #include "read.h"
 #include "real.h"
+#include "vectorspace.h"
 
 /*
  * for the time being things which may be read are: strings numbers - either
@@ -31,8 +35,12 @@
  * atoms because I don't yet know what an atom is or how it's stored.
  */
 
-struct cons_pointer read_number( FILE * input, wint_t initial );
+struct cons_pointer read_number( struct stack_frame *frame,
-struct cons_pointer read_list( struct stack_frame *frame, FILE * input,
+                                 struct cons_pointer frame_pointer,
+                                 FILE * input, wint_t initial,
+                                 bool seen_period );
+struct cons_pointer read_list( struct stack_frame *frame,
+                               struct cons_pointer frame_pointer, FILE * input,
                                wint_t initial );
 struct cons_pointer read_string( FILE * input, wint_t initial );
 struct cons_pointer read_symbol( FILE * input, wint_t initial );
@@ -41,7 +49,7 @@ struct cons_pointer read_symbol( FILE * input, wint_t initial );
  * quote reader macro in C (!)
  */
 struct cons_pointer c_quote( struct cons_pointer arg ) {
-    return make_cons( c_string_to_lisp_symbol( "quote" ),
+    return make_cons( c_string_to_lisp_symbol( L"quote" ),
                       make_cons( arg, NIL ) );
 }
 
@@ -50,8 +58,10 @@ struct cons_pointer c_quote( struct cons_pointer arg ) {
  * treating this initial character as the first character of the object
  * representation.
  */
-struct cons_pointer read_continuation( struct stack_frame *frame, FILE * input,
+struct cons_pointer read_continuation( struct stack_frame *frame,
-                                       wint_t initial ) {
+                                       struct cons_pointer frame_pointer,
+                                       FILE * input, wint_t initial ) {
+    debug_print( L"entering read_continuation\n", DEBUG_IO );
     struct cons_pointer result = NIL;
 
     wint_t c;
@@ -61,8 +71,8 @@ struct cons_pointer read_continuation( struct stack_frame *frame, FILE * input,
 
     if ( feof( input ) ) {
         result =
-            make_exception( c_string_to_lisp_string
+            throw_exception( c_string_to_lisp_string
-                            ( "End of file while reading" ), frame );
+                            ( L"End of file while reading" ), frame_pointer );
     } else {
         switch ( c ) {
             case ';':
@@ -70,31 +80,49 @@ struct cons_pointer read_continuation( struct stack_frame *frame, FILE * input,
                 /* skip all characters from semi-colon to the end of the line */
                 break;
             case EOF:
-                result = lisp_throw( c_string_to_lisp_string
+                result = throw_exception( c_string_to_lisp_string
-                                     ( "End of input while reading" ), frame );
+                                          ( L"End of input while reading" ),
+                                          frame_pointer );
                 break;
             case '\'':
                 result =
                     c_quote( read_continuation
-                             ( frame, input, fgetwc( input ) ) );
+                             ( frame, frame_pointer, input,
+                               fgetwc( input ) ) );
                 break;
             case '(':
-                result = read_list( frame, input, fgetwc( input ) );
+                result =
+                    read_list( frame, frame_pointer, input, fgetwc( input ) );
                 break;
             case '"':
                 result = read_string( input, fgetwc( input ) );
                 break;
+            case '-':{
+                    wint_t next = fgetwc( input );
+                    ungetwc( next, input );
+                    if ( iswdigit( next ) ) {
+                        result =
+                            read_number( frame, frame_pointer, input, c,
+                                         false );
+                    } else {
+                        result = read_symbol( input, c );
+                    }
+                }
+                break;
             case '.':
                 {
                     wint_t next = fgetwc( input );
                     if ( iswdigit( next ) ) {
                         ungetwc( next, input );
-                        result = read_number( input, c );
+                        result =
+                            read_number( frame, frame_pointer, input, c,
+                                         true );
                     } else if ( iswblank( next ) ) {
                         /* dotted pair. TODO: this isn't right, we
                          * really need to backtrack up a level. */
                         result =
-                            read_continuation( frame, input, fgetwc( input ) );
+                            read_continuation( frame, frame_pointer, input,
+                                               fgetwc( input ) );
                     } else {
                         read_symbol( input, c );
                     }
@@ -102,40 +130,76 @@ struct cons_pointer read_continuation( struct stack_frame *frame, FILE * input,
                 break;
             default:
                 if ( iswdigit( c ) ) {
-                    result = read_number( input, c );
+                    result =
+                        read_number( frame, frame_pointer, input, c, false );
                 } else if ( iswprint( c ) ) {
                     result = read_symbol( input, c );
                 } else {
                     result =
-                        make_exception( c_string_to_lisp_string
+                        throw_exception( make_cons( c_string_to_lisp_string
-                                        ( "Unrecognised start of input character" ),
+                                                   ( L"Unrecognised start of input character" ),
-                                        frame );
+                                                   make_string( c, NIL ) ),
-                }
+                                        frame_pointer );
+                }
+                break;
         }
     }
+    debug_print( L"read_continuation returning\n", DEBUG_IO );
+    debug_dump_object( result, DEBUG_IO );
 
     return result;
 }
 
 /**
  * read a number from this input stream, given this initial character.
+ * TODO: to be able to read bignums, we need to read the number from the
+ * input stream into a Lisp string, and then convert it to a number.
  */
-struct cons_pointer read_number( FILE * input, wint_t initial ) {
+struct cons_pointer read_number( struct stack_frame *frame,
+                                 struct cons_pointer frame_pointer,
+                                 FILE * input,
+                                 wint_t initial, bool seen_period ) {
+    debug_print( L"entering read_number\n", DEBUG_IO );
     struct cons_pointer result = NIL;
-    long int accumulator = 0;
+    int64_t accumulator = 0;
+    int64_t dividend = 0;
     int places_of_decimals = 0;
-    bool seen_period = false;
     wint_t c;
-    fwprintf( stderr, L"read_number starting '%c' (%d)\n", initial, initial );
+    bool negative = initial == btowc( '-' );
+
+    if ( negative ) {
+        initial = fgetwc( input );
+    }
+
+    debug_printf( DEBUG_IO, L"read_number starting '%c' (%d)\n", initial, initial );
+
     for ( c = initial; iswdigit( c )
-          || c == btowc( '.' ); c = fgetwc( input ) ) {
+          || c == btowc( '.' ) || c == btowc( '/' ); c = fgetwc( input ) ) {
         if ( c == btowc( '.' ) ) {
+            if ( seen_period || dividend != 0 ) {
+                return throw_exception( c_string_to_lisp_string
+                                       ( L"Malformed number: too many periods" ),
+                                       frame_pointer );
+            } else {
                 seen_period = true;
+            }
+        } else if ( c == btowc( '/' ) ) {
+            if ( seen_period || dividend > 0 ) {
+                return throw_exception( c_string_to_lisp_string
+                                       ( L"Malformed number: dividend of rational must be integer" ),
+                                       frame_pointer );
+            } else {
+                dividend = negative ? 0 - accumulator : accumulator;
+
+                accumulator = 0;
+            }
         } else {
             accumulator = accumulator * 10 + ( ( int ) c - ( int ) '0' );
-            fwprintf( stderr,
+
+            debug_printf( DEBUG_IO,
                       L"Added character %c, accumulator now %ld\n",
                       c, accumulator );
+
             if ( seen_period ) {
                 places_of_decimals++;
             }
@@ -149,12 +213,24 @@ struct cons_pointer read_number( FILE * input, wint_t initial ) {
     if ( seen_period ) {
         long double rv = ( long double )
             ( accumulator / pow( 10, places_of_decimals ) );
-        fwprintf( stderr, L"read_numer returning %Lf\n", rv );
+        if ( negative ) {
+            rv = 0 - rv;
+        }
         result = make_real( rv );
+    } else if ( dividend != 0 ) {
+        result =
+            make_ratio( frame_pointer, make_integer( dividend ),
+                        make_integer( accumulator ) );
     } else {
+        if ( negative ) {
+            accumulator = 0 - accumulator;
+        }
         result = make_integer( accumulator );
     }
 
+    debug_print( L"read_number returning\n", DEBUG_IO );
+    debug_dump_object( result, DEBUG_IO );
+
     return result;
 }
 
@@ -162,18 +238,22 @@ struct cons_pointer read_number( FILE * input, wint_t initial ) {
  * Read a list from this input stream, which no longer contains the opening
  * left parenthesis.
  */
-struct cons_pointer read_list( struct
+struct cons_pointer read_list( struct stack_frame *frame,
-                               stack_frame
+                               struct cons_pointer frame_pointer,
-                               *frame, FILE * input, wint_t initial ) {
+                               FILE * input, wint_t initial ) {
     struct cons_pointer result = NIL;
     if ( initial != ')' ) {
-        fwprintf( stderr,
+        debug_printf( DEBUG_IO,
                   L"read_list starting '%C' (%d)\n", initial, initial );
-        struct cons_pointer car = read_continuation( frame, input,
+        struct cons_pointer car =
+            read_continuation( frame, frame_pointer, input,
                                initial );
-        result = make_cons( car, read_list( frame, input, fgetwc( input ) ) );
+        result =
+            make_cons( car,
+                       read_list( frame, frame_pointer, input,
+                                  fgetwc( input ) ) );
     } else {
-        fwprintf( stderr, L"End of list detected\n" );
+        debug_print( L"End of list detected\n", DEBUG_IO );
     }
 
     return result;
@@ -245,9 +325,9 @@ struct cons_pointer read_symbol( FILE * input, wint_t initial ) {
             break;
     }
 
-    fputws( L"Read symbol '", stderr );
+    debug_print( L"read_symbol returning\n", DEBUG_IO );
-    print( stderr, result );
+    debug_dump_object( result, DEBUG_IO );
-    fputws( L"'\n", stderr );
+
     return result;
 }
 
@@ -256,6 +336,7 @@ struct cons_pointer read_symbol( FILE * input, wint_t initial ) {
  */
 struct cons_pointer read( struct
                           stack_frame
-                          *frame, FILE * input ) {
+                          *frame, struct cons_pointer frame_pointer,
-    return read_continuation( frame, input, fgetwc( input ) );
+                          FILE * input ) {
+    return read_continuation( frame, frame_pointer, input, fgetwc( input ) );
 }

src/ops/read.h

@@ -14,6 +14,7 @@
 /**
  * read the next object on this input stream and return a cons_pointer to it.
  */
-struct cons_pointer read( struct stack_frame *frame, FILE * input );
+struct cons_pointer read( struct stack_frame *frame,
+                          struct cons_pointer frame_pointer, FILE * input );
 
 #endif

src/peano.c

@@ -1,237 +0,0 @@
-/*
- * peano.c
- *
- * Basic peano arithmetic
- *
- * (c) 2017 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 <math.h>
-
-#include "consspaceobject.h"
-#include "conspage.h"
-#include "equal.h"
-#include "integer.h"
-#include "intern.h"
-#include "lispops.h"
-#include "print.h"
-#include "read.h"
-#include "real.h"
-#include "stack.h"
-
-/**
- * Internal guts of add. Dark and mysterious.
- */
-struct cons_pointer add_accumulate( struct cons_pointer arg,
-                                    struct stack_frame *frame,
-                                    long int *i_accumulator,
-                                    long double *d_accumulator, int *is_int ) {
-    struct cons_pointer result = NIL;
-    struct cons_space_object cell = pointer2cell( arg );
-
-    switch ( cell.tag.value ) {
-        case INTEGERTV:
-            ( *i_accumulator ) += cell.payload.integer.value;
-            ( *d_accumulator ) += numeric_value( arg );
-            break;
-        case REALTV:
-            ( *d_accumulator ) += cell.payload.real.value;
-            ( *is_int ) &= false;
-            break;
-        case EXCEPTIONTV:
-            result = arg;
-            break;
-        default:
-            result = lisp_throw( c_string_to_lisp_string
-                                 ( "Cannot multiply: not a number" ), frame );
-    }
-    return result;
-}
-
-
-/**
- * Add an indefinite number of numbers together
- * @param env the evaluation environment - ignored;
- * @param frame the stack frame.
- * @return a pointer to an integer or real.
- */
-struct cons_pointer
-lisp_add( struct stack_frame *frame, struct cons_pointer env ) {
-    struct cons_pointer result = NIL;
-    long int i_accumulator = 0;
-    long double d_accumulator = 0;
-    int is_int = true;
-
-    for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] ); i++ ) {
-        result =
-            add_accumulate( frame->arg[i], frame, &i_accumulator,
-                            &d_accumulator, &is_int );
-    }
-
-    struct cons_pointer more = frame->more;
-
-    while ( consp( more ) ) {
-        result =
-            add_accumulate( c_car( more ), frame, &i_accumulator,
-                            &d_accumulator, &is_int );
-        more = c_cdr( more );
-    }
-
-    if ( is_int ) {
-        result = make_integer( i_accumulator );
-    } else {
-        result = make_real( d_accumulator );
-    }
-
-    return result;
-}
-
-/**
- * Internal guts of multiply. Dark and mysterious.
- */
-struct cons_pointer multiply_accumulate( struct cons_pointer arg,
-                                         struct stack_frame *frame,
-                                         long int *i_accumulator,
-                                         long double *d_accumulator,
-                                         int *is_int ) {
-    struct cons_pointer result = NIL;
-    struct cons_space_object cell = pointer2cell( arg );
-
-    switch ( cell.tag.value ) {
-        case INTEGERTV:
-            ( *i_accumulator ) *= cell.payload.integer.value;
-            ( *d_accumulator ) *= numeric_value( arg );
-            break;
-        case REALTV:
-            ( *d_accumulator ) *= cell.payload.real.value;
-            ( *is_int ) &= false;
-            break;
-        case EXCEPTIONTV:
-            result = arg;
-            break;
-        default:
-            result = lisp_throw( c_string_to_lisp_string
-                                 ( "Cannot multiply: not a number" ), frame );
-    }
-    return result;
-}
-
-/**
- * Multiply an indefinite number of numbers together
- * @param env the evaluation environment - ignored;
- * @param frame the stack frame.
- * @return a pointer to an integer or real.
- */
-struct cons_pointer
-lisp_multiply( struct stack_frame *frame, struct cons_pointer env ) {
-    struct cons_pointer result = NIL;
-    long int i_accumulator = 1;
-    long double d_accumulator = 1;
-    int is_int = true;
-
-    for ( int i = 0;
-          i < args_in_frame && !nilp( frame->arg[i] ) && !exceptionp( result );
-          i++ ) {
-        result =
-            multiply_accumulate( frame->arg[i], frame, &i_accumulator,
-                                 &d_accumulator, &is_int );
-    }
-
-    struct cons_pointer more = frame->more;
-
-    while ( consp( more ) && !exceptionp( result ) ) {
-        result =
-            multiply_accumulate( c_car( more ), frame, &i_accumulator,
-                                 &d_accumulator, &is_int );
-        more = c_cdr( more );
-    }
-
-    if ( !exceptionp( result ) ) {
-        if ( is_int ) {
-            result = make_integer( i_accumulator );
-        } else {
-            result = make_real( d_accumulator );
-        }
-    }
-
-    return result;
-}
-
-/**
- * Subtract one number from another.
- * @param env the evaluation environment - ignored;
- * @param frame the stack frame.
- * @return a pointer to an integer or real.
- */
-struct cons_pointer
-lisp_subtract( struct stack_frame *frame, struct cons_pointer env ) {
-    struct cons_pointer result = NIL;
-
-    struct cons_space_object arg0 = pointer2cell( frame->arg[0] );
-    struct cons_space_object arg1 = pointer2cell( frame->arg[1] );
-
-    if ( integerp( frame->arg[0] ) && integerp( frame->arg[1] ) ) {
-        result =
-            make_integer( arg0.payload.integer.value -
-                          arg1.payload.integer.value );
-    } else if ( realp( frame->arg[0] ) && realp( frame->arg[1] ) ) {
-        result =
-            make_real( arg0.payload.real.value - arg1.payload.real.value );
-    } else if ( integerp( frame->arg[0] ) && realp( frame->arg[1] ) ) {
-        result =
-            make_real( numeric_value( frame->arg[0] ) -
-                       arg1.payload.real.value );
-    } else if ( realp( frame->arg[0] ) && integerp( frame->arg[1] ) ) {
-        result =
-            make_real( arg0.payload.real.value -
-                       numeric_value( frame->arg[1] ) );
-    } else {
-        /* TODO: throw an exception */
-        lisp_throw( c_string_to_lisp_string
-                    ( "Cannot subtract: not a number" ), frame );
-    }
-
-    // and if not nilp[frame->arg[2]) we also have an error.
-
-    return result;
-}
-
-/**
- * Divide one number by another.
- * @param env the evaluation environment - ignored;
- * @param frame the stack frame.
- * @return a pointer to an integer or real.
- */
-struct cons_pointer
-lisp_divide( struct stack_frame *frame, struct cons_pointer env ) {
-    struct cons_pointer result = NIL;
-
-    struct cons_space_object arg0 = pointer2cell( frame->arg[0] );
-    struct cons_space_object arg1 = pointer2cell( frame->arg[1] );
-
-    if ( numberp( frame->arg[1] ) && numeric_value( frame->arg[1] ) == 0 ) {
-        lisp_throw( c_string_to_lisp_string
-                    ( "Cannot divide: divisor is zero" ), frame );
-    } else if ( numberp( frame->arg[0] ) && numberp( frame->arg[1] ) ) {
-        long int i = ( long int ) numeric_value( frame->arg[0] ) /
-            numeric_value( frame->arg[1] );
-        long double r = ( long double ) numeric_value( frame->arg[0] ) /
-            numeric_value( frame->arg[1] );
-        if ( fabsl( ( long double ) i - r ) < 0.0000000001 ) {
-            result = make_integer( i );
-        } else {
-            result = make_real( r );
-        }
-    } else {
-        lisp_throw( c_string_to_lisp_string
-                    ( "Cannot divide: not a number" ), frame );
-    }
-
-    return result;
-}

src/repl.c

@@ -13,6 +13,7 @@
 
 #include "conspage.h"
 #include "consspaceobject.h"
+#include "debug.h"
 #include "intern.h"
 #include "lispops.h"
 #include "read.h"
@@ -31,11 +32,18 @@
  * Dummy up a Lisp read call with its own stack frame.
  */
 struct cons_pointer repl_read( struct cons_pointer stream_pointer ) {
-    struct stack_frame *frame = make_empty_frame( NULL, oblist );
+    struct cons_pointer result = NIL;
-
+    debug_print( L"Entered repl_read\n", DEBUG_REPL );
-    frame->arg[0] = stream_pointer;
+    struct cons_pointer frame_pointer = make_stack_frame( NIL, make_cons(stream_pointer, NIL), oblist );
-    struct cons_pointer result = lisp_read( frame, oblist );
+    debug_print( L"repl_read: got stack_frame pointer\n",  DEBUG_REPL );
-    free_stack_frame( frame );
+    debug_dump_object( frame_pointer, DEBUG_REPL );
+    if ( !nilp( frame_pointer ) ) {
+        inc_ref( frame_pointer );
+        result = lisp_read( get_stack_frame( frame_pointer ), frame_pointer, oblist );
+        dec_ref( frame_pointer );
+    }
+    debug_print( L"repl_read: returning\n",  DEBUG_REPL );
+    debug_dump_object( result, DEBUG_REPL );
 
     return result;
 }
@@ -44,14 +52,13 @@ struct cons_pointer repl_read( struct cons_pointer stream_pointer ) {
  * Dummy up a Lisp eval call with its own stack frame.
  */
 struct cons_pointer repl_eval( struct cons_pointer input ) {
-    struct stack_frame *frame = make_empty_frame( NULL, oblist );
+    debug_print( L"Entered repl_eval\n",  DEBUG_REPL );
+    struct cons_pointer result = NIL;
 
-    frame->arg[0] = input;
+    result = eval_form( NULL, NIL, input, oblist );
-    struct cons_pointer result = lisp_eval( frame, oblist );
 
-    if ( !exceptionp( result ) ) {
+    debug_print( L"repl_eval: returning\n",  DEBUG_REPL );
-        free_stack_frame( frame );
+    debug_dump_object( result, DEBUG_REPL );
-    }
 
     return result;
 }
@@ -61,12 +68,12 @@ struct cons_pointer repl_eval( struct cons_pointer input ) {
  */
 struct cons_pointer repl_print( struct cons_pointer stream_pointer,
                                 struct cons_pointer value ) {
-    struct stack_frame *frame = make_empty_frame( NULL, oblist );
+    debug_print( L"Entered repl_print\n",  DEBUG_REPL );
-
+    debug_dump_object( value, DEBUG_REPL );
-    frame->arg[0] = value;
+    struct cons_pointer result =
-    frame->arg[1] = NIL /* stream_pointer */ ;
+      print( pointer2cell( stream_pointer ).payload.stream.stream, value );
-    struct cons_pointer result = lisp_print( frame, oblist );
+    debug_print( L"repl_print: returning\n",  DEBUG_REPL );
-    free_stack_frame( frame );
+    debug_dump_object( result, DEBUG_REPL );
 
     return result;
 }
@@ -81,30 +88,30 @@ struct cons_pointer repl_print( struct cons_pointer stream_pointer,
 void
 repl( FILE * in_stream, FILE * out_stream, FILE * error_stream,
       bool show_prompt ) {
+    debug_print( L"Entered repl\n",  DEBUG_REPL );
     struct cons_pointer input_stream = make_read_stream( in_stream );
-    struct cons_pointer output_stream = make_write_stream( out_stream );
+    inc_ref( input_stream );
 
+    struct cons_pointer output_stream = make_write_stream( out_stream );
+    inc_ref( output_stream );
     while ( !feof( pointer2cell( input_stream ).payload.stream.stream ) ) {
         if ( show_prompt ) {
             fwprintf( out_stream, L"\n:: " );
         }
 
         struct cons_pointer input = repl_read( input_stream );
+        inc_ref( input );
 
         if ( exceptionp( input ) ) {
+            /* suppress the end-of-stream exception */
+            if ( !feof( pointer2cell( input_stream ).payload.stream.stream ) ) {
+                repl_print( output_stream, input );
+            }
             break;
         } else {
-
+            repl_print( output_stream, repl_eval( input ) );
-            struct cons_pointer val = repl_eval( input );
-
-            if ( feof( pointer2cell( input_stream ).payload.stream.stream ) ) {
-                /* suppress the 'end of stream' exception */
-                if ( !exceptionp( val ) ) {
-                    repl_print( output_stream, val );
-                }
-            } else {
-                repl_print( output_stream, val );
-            }
         }
+        dec_ref( input );
     }
+     debug_print( L"Leaving repl\n",  DEBUG_REPL );
 }

src/stack.c

@@ -1,206 +0,0 @@
-/*
- * stack.c
- *
- * The Lisp evaluation stack.
- *
- * Stack frames could be implemented in cons space; indeed, the stack
- * could simply be an assoc list consed onto the front of the environment.
- * But such a stack would be costly to search. The design sketched here,
- * with stack frames as special objects, SHOULD be substantially more
- * efficient, but does imply we need to generalise the idea of cons pages
- * with freelists to a more general 'equal sized object pages', so that
- * allocating/freeing stack frames can be more efficient.
- *
- * Stack frames are not yet a first class object; they have no VECP pointer
- * in cons space.
- *
- * (c) 2017 Simon Brooke <simon@journeyman.cc>
- * Licensed under GPL version 2.0, or, at your option, any later version.
- */
-
-#include <stdlib.h>
-
-#include "consspaceobject.h"
-#include "conspage.h"
-#include "lispops.h"
-#include "print.h"
-#include "stack.h"
-
-/**
- * Make an empty stack frame, and return it.
- * @param previous the current top-of-stack;
- * @param env the environment in which evaluation happens.
- * @return the new frame.
- */
-struct stack_frame *make_empty_frame( struct stack_frame *previous,
-                                      struct cons_pointer env ) {
-    struct stack_frame *result = malloc( sizeof( struct stack_frame ) );
-    /*
-     * TODO: later, pop a frame off a free-list of stack frames
-     */
-
-    result->previous = previous;
-
-    /*
-     * clearing the frame with memset would probably be slightly quicker, but
-     * this is clear.
-     */
-    result->more = NIL;
-    result->function = NIL;
-
-    for ( int i = 0; i < args_in_frame; i++ ) {
-        result->arg[i] = NIL;
-    }
-
-    return result;
-}
-
-
-/**
- * Allocate a new stack frame with its previous pointer set to this value,
- * its arguments set up from these args, evaluated in this env.
- * @param previous the current top-of-stack;
- * @args the arguments to load into this frame;
- * @param env the environment in which evaluation happens.
- * @return the new frame.
- */
-struct stack_frame *make_stack_frame( struct stack_frame *previous,
-                                      struct cons_pointer args,
-                                      struct cons_pointer env,
-                                      struct cons_pointer *exception ) {
-    struct stack_frame *result = make_empty_frame( previous, env );
-
-    for ( int i = 0; i < args_in_frame && consp( args ); i++ ) {
-        /* iterate down the arg list filling in the arg slots in the
-         * frame. When there are no more slots, if there are still args,
-         * stash them on more */
-        struct cons_space_object cell = pointer2cell( args );
-
-        /*
-         * TODO: if we were running on real massively parallel hardware,
-         * each arg except the first should be handed off to another
-         * processor to be evaled in parallel; but see notes here:
-         * https://github.com/simon-brooke/post-scarcity/wiki/parallelism
-         */
-        struct stack_frame *arg_frame = make_empty_frame( result, env );
-        arg_frame->arg[0] = cell.payload.cons.car;
-        inc_ref( arg_frame->arg[0] );
-
-        struct cons_pointer val = lisp_eval( arg_frame, env );
-        if ( exceptionp( val ) ) {
-            exception = &val;
-            break;
-        } else {
-            result->arg[i] = val;
-        }
-        inc_ref( val );
-
-        free_stack_frame( arg_frame );
-
-        args = cell.payload.cons.cdr;
-    }
-    if ( consp( args ) ) {
-        /* if we still have args, eval them and stick the values on `more` */
-        struct cons_pointer more = eval_forms( previous, args, env );
-        result->more = more;
-        inc_ref( more );
-    }
-
-    dump_frame( stderr, result );
-    return result;
-}
-
-/**
- * A 'special' frame is exactly like a normal stack frame except that the
- * arguments are unevaluated.
- * @param previous the previous stack frame;
- * @param args a list of the arguments to be stored in this stack frame;
- * @param env the execution environment;
- * @return a new special frame.
- */
-struct stack_frame *make_special_frame( struct stack_frame *previous,
-                                        struct cons_pointer args,
-                                        struct cons_pointer env ) {
-    struct stack_frame *result = make_empty_frame( previous, env );
-
-    for ( int i = 0; i < args_in_frame && !nilp( args ); i++ ) {
-        /* iterate down the arg list filling in the arg slots in the
-         * frame. When there are no more slots, if there are still args,
-         * stash them on more */
-        struct cons_space_object cell = pointer2cell( args );
-
-        result->arg[i] = cell.payload.cons.car;
-        inc_ref( result->arg[i] );
-
-        args = cell.payload.cons.cdr;
-    }
-    if ( consp( args ) ) {
-        result->more = args;
-        inc_ref( args );
-    }
-
-    return result;
-}
-
-/**
- * Free this stack frame.
- */
-void free_stack_frame( struct stack_frame *frame ) {
-    /*
-     * TODO: later, push it back on the stack-frame freelist
-     */
-    for ( int i = 0; i < args_in_frame; i++ ) {
-        dec_ref( frame->arg[i] );
-    }
-    if ( !nilp( frame->more ) ) {
-        dec_ref( frame->more );
-    }
-
-    free( frame );
-}
-
-
-/**
- * Dump a stackframe to this stream for debugging
- * @param output the stream
- * @param frame the frame
- */
-void dump_frame( FILE * output, struct stack_frame *frame ) {
-    fputws( L"Dumping stack frame\n", output );
-    for ( int arg = 0; arg < args_in_frame; arg++ ) {
-        struct cons_space_object cell = pointer2cell( frame->arg[arg] );
-
-        fwprintf( output, L"Arg %d:\t%c%c%c%c\tcount: %10u\tvalue: ", arg,
-                  cell.tag.bytes[0],
-                  cell.tag.bytes[1], cell.tag.bytes[2], cell.tag.bytes[3],
-                  cell.count );
-
-        print( output, frame->arg[arg] );
-        fputws( L"\n", output );
-    }
-    fputws( L"More: \t", output );
-    print( output, frame->more );
-    fputws( L"\n", output );
-}
-
-
-/**
- * Fetch a pointer to the value of the local variable at this index.
- */
-struct cons_pointer fetch_arg( struct stack_frame *frame, unsigned int index ) {
-    struct cons_pointer result = NIL;
-
-    if ( index < args_in_frame ) {
-        result = frame->arg[index];
-    } else {
-        struct cons_pointer p = frame->more;
-
-        for ( int i = args_in_frame; i < index; i++ ) {
-            p = pointer2cell( p ).payload.cons.cdr;
-        }
-
-        result = pointer2cell( p ).payload.cons.car;
-    }
-
-    return result;
-}

src/version.h

@@ -8,4 +8,4 @@
  *  Licensed under GPL version 2.0, or, at your option, any later version.
  */
 
-#define VERSION "0.0.3"
+#define VERSION "0.0.4"

unit-tests/add.sh

@@ -23,3 +23,57 @@ else
     exit 1
 fi
 
+expected='1/4'
+actual=`echo "(+ 3/14 1/28)" | target/psse 2> /dev/null | head -2 | tail -1`
+
+if [ "${expected}" = "${actual}" ]
+then
+    echo "OK"
+else
+    echo "Fail: expected '${expected}', got '${actual}'"
+    exit 1
+fi
+
+# (+ integer ratio) should be ratio
+expected='25/4'
+actual=`echo "(+ 6 1/4)" | target/psse 2> /dev/null | head -2 | tail -1`
+
+if [ "${expected}" = "${actual}" ]
+then
+    echo "OK"
+else
+    echo "Fail: expected '${expected}', got '${actual}'"
+    exit 1
+fi
+
+# (+ ratio integer) should be ratio
+expected='25/4'
+actual=`echo "(+ 1/4 6)" | target/psse 2> /dev/null | head -2 | tail -1`
+
+if [ "${expected}" = "${actual}" ]
+then
+    echo "OK"
+else
+    echo "Fail: expected '${expected}', got '${actual}'"
+    exit 1
+fi
+
+# (+ real ratio) should be real
+# for this test, trailing zeros can be ignored
+expected='6.25'
+actual=`echo "(+ 6.000000001 1/4)" |\
+  target/psse 2> /dev/null |\
+  sed 's/0*$//' |\
+  head -2 |\
+  tail -1`
+
+outcome=`echo "sqrt((${expected} - ${actual})^2) < 0.0000001" | bc`
+
+if [ "${outcome}" = "1" ]
+then
+    echo "OK"
+else
+    echo "Fail: expected '${expected}', got '${actual}'"
+    exit 1
+fi
+

unit-tests/nlambda.sh

@@ -0,0 +1,13 @@
+#!/bin/bash
+
+expected='a'
+actual=`echo "((nlambda (x) x) a)" | target/psse 2> /dev/null | head -2 | tail -1`
+
+if [ "${expected}" = "${actual}" ]
+then
+    echo "OK"
+    exit 0
+else
+    echo "Fail: expected '${expected}', got '${actual}'"
+    exit 1
+fi

unit-tests/ratio-addition.sh

@@ -0,0 +1,12 @@
+#!/bin/bash
+
+expected='1/4'
+actual=`echo "(+ 3/14 1/28)" | target/psse 2> /dev/null | head -2 | tail -1`
+
+if [ "${expected}" = "${actual}" ]
+then
+    echo "OK"
+else
+    echo "Fail: expected '${expected}', got '${actual}'"
+    exit 1
+fi

unit-tests/reverse.sh

@@ -0,0 +1,36 @@
+#!/bin/bash
+
+expected='"god yzal eht revo depmuj xof nworb kciuq ehT"'
+actual=`echo '(reverse "The quick brown fox jumped over the lazy dog")' | target/psse 2> /dev/null | head -2 | tail -1`
+
+if [ "${expected}" = "${actual}" ]
+then
+    echo "OK"
+else
+    echo "Fail: expected '${expected}', got '${actual}'"
+    exit 1
+fi
+
+expected='(1024 512 256 128 64 32 16 8 4 2)'
+actual=`echo "(reverse '(2 4 8 16 32 64 128 256 512 1024))" | target/psse 2> /dev/null | head -2 | tail -1`
+
+if [ "${expected}" = "${actual}" ]
+then
+    echo "OK"
+else
+    echo "Fail: expected '${expected}', got '${actual}'"
+    exit 1
+fi
+
+expected='esrever'
+actual=`echo "(reverse 'reverse)" | target/psse 2> /dev/null | head -2 | tail -1`
+
+if [ "${expected}" = "${actual}" ]
+then
+    echo "OK"
+    exit 0
+else
+    echo "Fail: expected '${expected}', got '${actual}'"
+    exit 1
+fi
+

unit-tests/string-allocation.sh

@@ -1,17 +1,15 @@
 #!/bin/bash
 
-log=log.$$
 value='"Fred"'
-expected="String cell: character 'F' (70)"
+expected="String cell: character 'F'"
-echo ${value} | target/psse -d > ${log} 2>/dev/null
+# set! protects "Fred" from the garbage collector.
-grep "${expected}" ${log} > /dev/null
+actual=`echo "(set! x ${value})" | target/psse -d 2>&1 | grep "$expected" | sed 's/ *\(.*\) next.*$/\1/'`
 
 if [ $? -eq 0 ]
 then
     echo "OK"
-    rm ${log}
     exit 0
 else
-    echo "Expected '${expected}', not found in ${log}"
+    echo "Fail: expected '${expected}', got '${actual}'"
     exit 1
 fi

utils_src/debugflags/debugflags.c

@@ -0,0 +1,43 @@
+#include <inttypes.h>
+#include <stdint.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+
+
+#define DEBUG_ALLOC 1
+#define DEBUG_STACK 2
+#define DEBUG_ARITH 4
+#define DEBUG_EVAL 8
+#define DEBUG_LAMBDA 16
+#define DEBUG_BOOTSTRAP 32
+#define DEBUG_IO 64
+#define DEBUG_REPL 128
+
+int check_level( int v, int level, char * name) {
+  int result = 0;
+  if (v & level) {
+    printf("\t\t%s (%d) matches;\n", name, level);
+    result = 1;
+  }
+
+  return result;
+}
+
+int main( int argc, char *argv[] ) {
+
+  for (int i = 1; i < argc; i++) {
+    int v = atoi(argv[i]);
+
+    printf("Level %d:\n", v);
+    int matches = check_level(v, DEBUG_ALLOC, "DEBUG_ALLOC") +
+    check_level(v, DEBUG_STACK, "DEBUG_STACK") +
+    check_level(v, DEBUG_ARITH, "DEBUG_ARITH") +
+    check_level(v, DEBUG_EVAL, "DEBUG_EVAL") +
+    check_level(v, DEBUG_LAMBDA, "DEBUG_LAMBDA") +
+    check_level(v, DEBUG_BOOTSTRAP, "DEBUG_BOOTSTRAP") +
+    check_level(v, DEBUG_IO, "DEBUG_IO") +
+    check_level(v, DEBUG_REPL, "DEBUG_REPL");
+    printf("\t%d matches\n", matches);
+  }
+}

utils_src/readprintwc/readprintwc.c

@@ -0,0 +1,17 @@
+#include <stdio.h>
+#include <stdlib.h>
+#include <wchar.h>
+#include <wctype.h>
+
+int main( int argc, char *argv[] ) {
+    fwide( stdin, 1 );
+    fwide( stdout, 1 );
+
+  for (wchar_t c = fgetwc( stdin ); !feof( stdin); c = fgetwc( stdin )) {
+    if (c != '\n') {
+      fwprintf( stdout, L"Read character %d, %C\t", (int)c, c);
+      fputwc( c, stdout);
+      fputws(L"\n", stdout);
+    }
+  }
+}

utils_src/tagvalcalc/tagvalcalc.c

@@ -0,0 +1,26 @@
+#include <stdint.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+
+#define TAGLENGTH 4
+
+struct dummy {
+  union {
+    char bytes[TAGLENGTH];  /* the tag (type) of this cell,
+                                   * considered as bytes */
+    uint32_t value;         /* the tag considered as a number */
+  } tag;
+};
+
+int main( int argc, char *argv[] ) {
+  struct dummy *b = malloc( sizeof( struct dummy));
+  struct dummy buffer = *b;
+
+  for (int i = 1; i < argc; i++) {
+
+    strncpy( &buffer.tag.bytes[0], argv[i], TAGLENGTH );
+
+    printf( "%4.4s:\t%d\n", argv[i], buffer.tag.value);
+  }
+}