Merge remote-tracking branch 'origin/develop' into develop

src/arith/integer.c

@@ -100,13 +100,12 @@ __int128_t cell_value( struct cons_pointer c, char op, bool is_first_cell ) {
 __int128_t int128_to_integer( __int128_t val,
                               struct cons_pointer less_significant,
                               struct cons_pointer new ) {
-    struct cons_pointer cursor = NIL;
     __int128_t carry = 0;
 
     if ( MAX_INTEGER >= val ) {
         carry = 0;
     } else {
-        carry = val >> 60;
+        carry = val >> INTEGER_BIT_SHIFT; 
         debug_printf( DEBUG_ARITH,
                       L"int128_to_integer: 64 bit overflow; setting carry to %ld\n",
                       ( int64_t ) carry );
@@ -136,7 +135,7 @@ struct cons_pointer make_integer_128( __int128_t val,
             less_significant =
                 make_integer( ( long int ) val & MAX_INTEGER,
                               less_significant );
-            val = val >> 60;
+            val = val >> INTEGER_BIT_SHIFT;
         }
 
     } while ( nilp( result ) );
@@ -290,7 +289,7 @@ struct cons_pointer multiply_integers( struct cons_pointer a,
 
                 /* if xj exceeds one digit, break it into the digit dj and
                  * the carry */
-                carry = xj >> 60;
+                carry = xj >> INTEGER_BIT_SHIFT;
                 struct cons_pointer dj = make_integer( xj & MAX_INTEGER, NIL );
 
                 /* destructively modify ri by appending dj */
@@ -320,7 +319,7 @@ struct cons_pointer multiply_integers( struct cons_pointer a,
 }
 
 /**
- * don't use; private to integer_to_string, and somewaht dodgy.
+ * don't use; private to integer_to_string, and somewhat dodgy.
  */
 struct cons_pointer integer_to_string_add_digit( int digit, int digits,
                                                  struct cons_pointer tail ) {
@@ -361,7 +360,7 @@ struct cons_pointer integer_to_string( struct cons_pointer int_pointer,
             while ( accumulator > 0 || !nilp( next ) ) {
                 if ( accumulator < MAX_INTEGER && !nilp( next ) ) {
                     accumulator +=
-                        ( pointer2cell( next ).payload.integer.value << 60 );
+                        ( pointer2cell( next ).payload.integer.value << INTEGER_BIT_SHIFT );
                     next = pointer2cell( next ).payload.integer.more;
                 }
                 int offset = ( int ) ( accumulator % base );

src/arith/peano.h

@@ -13,10 +13,18 @@
 #define PEANO_H
 
 /**
- * The maximum value we will allow in an integer cell.
+ * The maximum value we will allow in an integer cell: one less than 2^60:
+ * (let ((s (make-string-output-stream)))
+ *   (format s "0x0~XL" (- (expt 2 60) 1))
+ *   (string-downcase (get-output-stream-string s)))
+ *                              "0x0fffffffffffffffl"
+ * 
+ * So left shifting and right shifting by 60 bits is correct.
  */
 #define MAX_INTEGER ((__int128_t)0x0fffffffffffffffL)
 
+#define INTEGER_BIT_SHIFT (60)
+
 bool zerop( struct cons_pointer arg );
 
 struct cons_pointer negative( struct cons_pointer arg );

src/init.c

@@ -9,6 +9,7 @@
  * Licensed under GPL version 2.0, or, at your option, any later version.
  */
 
+#include <getopt.h>
 #include <locale.h>
 #include <stdbool.h>
 #include <stdio.h>

src/io/print.h

@@ -11,6 +11,8 @@
 #include <ctype.h>
 #include <stdio.h>
 
+#include "io/fopen.h"
+
 #ifndef __print_h
 #define __print_h
 

src/memory/conspage.c

@@ -238,7 +238,7 @@ struct cons_pointer allocate_cell( uint32_t tag ) {
             total_cells_allocated++;
 
             debug_printf( DEBUG_ALLOC,
-                          L"Allocated cell of type '%4.4s' at %d, %d \n", tag,
+                          L"Allocated cell of type '%4.4s' at %d, %d \n", cell->tag.bytes,
                           result.page, result.offset );
         } else {
             debug_printf( DEBUG_ALLOC, L"WARNING: Allocating non-free cell!" );
@@ -267,6 +267,6 @@ void initialise_cons_pages(  ) {
 
 void summarise_allocation(  ) {
     fwprintf( stderr,
-              L"Allocation summary: allocated %lld; deallocated %lld.\n",
+              L"Allocation summary: allocated %lld; deallocated %lld; not deallocated %lld.\n",
-              total_cells_allocated, total_cells_freed );
+              total_cells_allocated, total_cells_freed, total_cells_allocated - total_cells_freed );
 }

src/memory/consspaceobject.c

@@ -9,9 +9,9 @@
  */
 
 #include <stdint.h>
+#include <stdio.h>
 #include <stdlib.h>
 #include <string.h>
-#include <stdio.h>
 /*
  * wide characters
  */
@@ -19,13 +19,13 @@
 #include <wctype.h>
 
 #include "authorise.h"
+#include "debug.h"
+#include "io/print.h"
 #include "memory/conspage.h"
 #include "memory/consspaceobject.h"
-#include "debug.h"
-#include "ops/intern.h"
-#include "io/print.h"
 #include "memory/stack.h"
 #include "memory/vectorspace.h"
+#include "ops/intern.h"
 
 /**
  * True if the value of the tag on the cell at this `pointer` is this `value`,
@@ -33,22 +33,22 @@
  * vectorspace object indicated by the cell is this `value`, else false.
  */
 bool check_tag( struct cons_pointer pointer, uint32_t value ) {
-    bool result = false;
+  bool result = false;
 
-    struct cons_space_object cell = pointer2cell( pointer );
+  struct cons_space_object cell = pointer2cell( pointer );
-    result = cell.tag.value == value;
+  result = cell.tag.value == value;
 
-    if ( result == false ) {
+  if ( result == false ) {
-        if ( cell.tag.value == VECTORPOINTTV ) {
+    if ( cell.tag.value == VECTORPOINTTV ) {
-            struct vector_space_object *vec = pointer_to_vso( pointer );
+      struct vector_space_object *vec = pointer_to_vso( pointer );
 
-            if ( vec != NULL ) {
+      if ( vec != NULL ) {
-                result = vec->header.tag.value == value;
+        result = vec->header.tag.value == value;
-            }
+      }
-        }
     }
+  }
 
-    return result;
+  return result;
 }
 
 /**
@@ -60,13 +60,13 @@ bool check_tag( struct cons_pointer pointer, uint32_t value ) {
  * Returns the `pointer`.
  */
 struct cons_pointer inc_ref( struct cons_pointer pointer ) {
-    struct cons_space_object *cell = &pointer2cell( pointer );
+  struct cons_space_object *cell = &pointer2cell( pointer );
 
-    if ( cell->count < MAXREFERENCE ) {
+  if ( cell->count < MAXREFERENCE ) {
-        cell->count++;
+    cell->count++;
-    }
+  }
 
-    return pointer;
+  return pointer;
 }
 
 /**
@@ -78,45 +78,42 @@ struct cons_pointer inc_ref( struct cons_pointer pointer ) {
  * Returns the `pointer`, or, if the cell has been freed, NIL.
  */
 struct cons_pointer dec_ref( struct cons_pointer pointer ) {
-    struct cons_space_object *cell = &pointer2cell( pointer );
+  struct cons_space_object *cell = &pointer2cell( pointer );
 
-    if ( cell->count > 0 ) {
+  if ( cell->count > 0 ) {
-        cell->count--;
+    cell->count--;
 
-        if ( cell->count == 0 ) {
+    if ( cell->count == 0 ) {
-            free_cell( pointer );
+      free_cell( pointer );
-            pointer = NIL;
+      pointer = NIL;
-        }
     }
+  }
 
-    return pointer;
+  return pointer;
 }
 
-
 /**
  * Get the Lisp type of the single argument.
  * @param pointer a pointer to the object whose type is requested.
  * @return As a Lisp string, the tag of the object which is at that pointer.
  */
 struct cons_pointer c_type( struct cons_pointer pointer ) {
-    struct cons_pointer result = NIL;
+  struct cons_pointer result = NIL;
-    struct cons_space_object cell = pointer2cell( pointer );
+  struct cons_space_object cell = pointer2cell( pointer );
 
-    if ( strncmp( ( char * ) &cell.tag.bytes, VECTORPOINTTAG, TAGLENGTH ) ==
+  if ( strncmp( (char *)&cell.tag.bytes, VECTORPOINTTAG, TAGLENGTH ) == 0 ) {
-         0 ) {
+    struct vector_space_object *vec = pointer_to_vso( pointer );
-        struct vector_space_object *vec = pointer_to_vso( pointer );
 
-        for ( int i = TAGLENGTH - 1; i >= 0; i-- ) {
+    for ( int i = TAGLENGTH - 1; i >= 0; i-- ) {
-            result =
+      result = make_string( (wchar_t)vec->header.tag.bytes[i], result );
-                make_string( ( wchar_t ) vec->header.tag.bytes[i], result );
-        }
-    } else {
-        for ( int i = TAGLENGTH - 1; i >= 0; i-- ) {
-            result = make_string( ( wchar_t ) cell.tag.bytes[i], result );
-        }
     }
+  } else {
+    for ( int i = TAGLENGTH - 1; i >= 0; i-- ) {
+      result = make_string( (wchar_t)cell.tag.bytes[i], result );
+    }
+  }
 
-    return result;
+  return result;
 }
 
 /**
@@ -124,13 +121,13 @@ struct cons_pointer c_type( struct cons_pointer pointer ) {
  * authorised to read it, does not error but returns nil.
  */
 struct cons_pointer c_car( struct cons_pointer arg ) {
-    struct cons_pointer result = NIL;
+  struct cons_pointer result = NIL;
 
-    if ( truep( authorised( arg, NIL ) ) && consp( arg ) ) {
+  if ( truep( authorised( arg, NIL ) ) && consp( arg ) ) {
-        result = pointer2cell( arg ).payload.cons.car;
+    result = pointer2cell( arg ).payload.cons.car;
-    }
+  }
 
-    return result;
+  return result;
 }
 
 /**
@@ -138,96 +135,98 @@ struct cons_pointer c_car( struct cons_pointer arg ) {
  * not authorised to read it,does not error but returns nil.
  */
 struct cons_pointer c_cdr( struct cons_pointer arg ) {
-    struct cons_pointer result = NIL;
+  struct cons_pointer result = NIL;
 
-    if ( truep( authorised( arg, NIL ) ) ) {
+  if ( truep( authorised( arg, NIL ) ) ) {
-        struct cons_space_object *cell = &pointer2cell( arg );
+    struct cons_space_object *cell = &pointer2cell( arg );
 
-        switch ( cell->tag.value ) {
+    switch ( cell->tag.value ) {
-            case CONSTV:
+      case CONSTV:
-                result = cell->payload.cons.cdr;
+        result = cell->payload.cons.cdr;
-                break;
+        break;
-            case KEYTV:
+      case KEYTV:
-            case STRINGTV:
+      case STRINGTV:
-            case SYMBOLTV:
+      case SYMBOLTV:
-                result = cell->payload.string.cdr;
+        result = cell->payload.string.cdr;
-                break;
+        break;
-        }
     }
+  }
 
-    return result;
+  return result;
 }
 
 /**
- * Implementation of `length` in C. If arg is not a cons, does not error but returns 0.
+ * Implementation of `length` in C. If arg is not a cons, does not error but
+ * returns 0.
  */
 int c_length( struct cons_pointer arg ) {
-    int result = 0;
+  int result = 0;
 
-    for ( struct cons_pointer c = arg; !nilp( c ); c = c_cdr( c ) ) {
+  for ( struct cons_pointer c = arg; !nilp( c ); c = c_cdr( c ) ) {
-        result++;
+    result++;
-    }
+  }
 
-    return result;
+  return result;
 }
 
-
 /**
  * Construct a cons cell from this pair of pointers.
  */
 struct cons_pointer make_cons( struct cons_pointer car,
                                struct cons_pointer cdr ) {
-    struct cons_pointer pointer = NIL;
+  struct cons_pointer pointer = NIL;
 
-    pointer = allocate_cell( CONSTV );
+  pointer = allocate_cell( CONSTV );
 
-    struct cons_space_object *cell = &pointer2cell( pointer );
+  struct cons_space_object *cell = &pointer2cell( pointer );
 
-    inc_ref( car );
+  inc_ref( car );
-    inc_ref( cdr );
+  inc_ref( cdr );
-    cell->payload.cons.car = car;
+  cell->payload.cons.car = car;
-    cell->payload.cons.cdr = cdr;
+  cell->payload.cons.cdr = cdr;
 
-    return pointer;
+  return pointer;
 }
 
 /**
  * Construct an exception cell.
- * @param message should be a lisp string describing the problem, but actually any cons pointer will do;
+ * @param message should be a lisp string describing the problem, but actually
- * @param frame_pointer should be the pointer to the frame in which the exception occurred.
+ * any cons pointer will do;
+ * @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 cons_pointer frame_pointer ) {
-    struct cons_pointer result = NIL;
+  struct cons_pointer result = NIL;
-    struct cons_pointer pointer = allocate_cell( EXCEPTIONTV );
+  struct cons_pointer pointer = allocate_cell( EXCEPTIONTV );
-    struct cons_space_object *cell = &pointer2cell( pointer );
+  struct cons_space_object *cell = &pointer2cell( pointer );
 
-    inc_ref( message );
+  inc_ref( message );
-    inc_ref( frame_pointer );
+  inc_ref( frame_pointer );
-    cell->payload.exception.payload = message;
+  cell->payload.exception.payload = message;
-    cell->payload.exception.frame = frame_pointer;
+  cell->payload.exception.frame = frame_pointer;
 
-    result = pointer;
+  result = pointer;
 
-    return result;
+  return result;
 }
 
-
 /**
  * Construct a cell which points to an executable Lisp function.
  */
-struct cons_pointer
+struct cons_pointer make_function(
-make_function( struct cons_pointer meta, struct cons_pointer ( *executable )
+    struct cons_pointer meta,
-                ( struct stack_frame *,
+    struct cons_pointer ( *executable )( struct stack_frame *,
-                  struct cons_pointer, struct cons_pointer ) ) {
+                                         struct cons_pointer,
-    struct cons_pointer pointer = allocate_cell( FUNCTIONTV );
+                                         struct cons_pointer ) ) {
-    struct cons_space_object *cell = &pointer2cell( pointer );
+  struct cons_pointer pointer = allocate_cell( FUNCTIONTV );
-    inc_ref( meta );
+  struct cons_space_object *cell = &pointer2cell( pointer );
+  inc_ref( meta );
 
-    cell->payload.function.meta = meta;
+  cell->payload.function.meta = meta;
-    cell->payload.function.executable = executable;
+  cell->payload.function.executable = executable;
 
-    return pointer;
+  return pointer;
 }
 
 /**
@@ -235,17 +234,18 @@ make_function( struct cons_pointer meta, struct cons_pointer ( *executable )
  */
 struct cons_pointer make_lambda( struct cons_pointer args,
                                  struct cons_pointer body ) {
-    struct cons_pointer pointer = allocate_cell( LAMBDATV );
+  struct cons_pointer pointer = allocate_cell( LAMBDATV );
-    struct cons_space_object *cell = &pointer2cell( pointer );
+  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( 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( args );
+  inc_ref( args );
-    inc_ref( body );
+  inc_ref( body );
-    cell->payload.lambda.args = args;
+  cell->payload.lambda.args = args;
-    cell->payload.lambda.body = body;
+  cell->payload.lambda.body = body;
 
-    return pointer;
+  return pointer;
 }
 
 /**
@@ -254,17 +254,18 @@ struct cons_pointer make_lambda( struct cons_pointer args,
  */
 struct cons_pointer make_nlambda( struct cons_pointer args,
                                   struct cons_pointer body ) {
-    struct cons_pointer pointer = allocate_cell( NLAMBDATV );
+  struct cons_pointer pointer = allocate_cell( NLAMBDATV );
 
-    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( 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 */
 
-    struct cons_space_object *cell = &pointer2cell( pointer );
+  struct cons_space_object *cell = &pointer2cell( pointer );
-    inc_ref( args );
+  inc_ref( args );
-    inc_ref( body );
+  inc_ref( body );
-    cell->payload.lambda.args = args;
+  cell->payload.lambda.args = args;
-    cell->payload.lambda.body = body;
+  cell->payload.lambda.body = body;
 
-    return pointer;
+  return pointer;
 }
 
 /**
@@ -279,23 +280,22 @@ struct cons_pointer make_nlambda( struct cons_pointer args,
  * returns 0 for things which are not string like.
  */
 uint32_t calculate_hash( wint_t c, struct cons_pointer ptr ) {
-    struct cons_space_object *cell = &pointer2cell( ptr );
+  struct cons_space_object *cell = &pointer2cell( ptr );
-    uint32_t result = 0;
+  uint32_t result = 0;
 
-    switch ( cell->tag.value ) {
+  switch ( cell->tag.value ) {
-        case KEYTV:
+    case KEYTV:
-        case STRINGTV:
+    case STRINGTV:
-        case SYMBOLTV:
+    case SYMBOLTV:
-            if ( nilp( cell->payload.string.cdr ) ) {
+      if ( nilp( cell->payload.string.cdr ) ) {
-                result = ( uint32_t ) c;
+        result = (uint32_t)c;
-            } else {
+      } else {
-                result = ( ( uint32_t ) c *
+        result = ( (uint32_t)c * cell->payload.string.hash ) & 0xffffffff;
-                           cell->payload.string.hash ) & 0xffffffff;
+      }
-            }
+      break;
-            break;
+  }
-    }
 
-    return result;
+  return result;
 }
 
 /**
@@ -304,31 +304,31 @@ uint32_t calculate_hash( wint_t c, struct cons_pointer ptr ) {
  * has one character and a pointer to the next; in the last cell the
  * pointer to next is NIL.
  */
-struct cons_pointer
+struct cons_pointer make_string_like_thing( wint_t c, struct cons_pointer tail,
-make_string_like_thing( wint_t c, struct cons_pointer tail, uint32_t tag ) {
+                                            uint32_t tag ) {
-    struct cons_pointer pointer = NIL;
+  struct cons_pointer pointer = NIL;
 
-    if ( check_tag( tail, tag ) || check_tag( tail, NILTV ) ) {
+  if ( check_tag( tail, tag ) || check_tag( tail, NILTV ) ) {
-        pointer = allocate_cell( tag );
+    pointer = allocate_cell( tag );
-        struct cons_space_object *cell = &pointer2cell( pointer );
+    struct cons_space_object *cell = &pointer2cell( pointer );
 
-        inc_ref( tail );
+    inc_ref( tail );
-        cell->payload.string.character = c;
+    cell->payload.string.character = c;
-        cell->payload.string.cdr.page = tail.page;
+    cell->payload.string.cdr.page = tail.page;
-        /* \todo There's a problem here. Sometimes the offsets on
+    /* \todo There's a problem here. Sometimes the offsets on
-         * strings are quite massively off. Fix is probably
+     * strings are quite massively off. Fix is probably
-         * cell->payload.string.cdr = tail */
+     * cell->payload.string.cdr = tail */
-        cell->payload.string.cdr.offset = tail.offset;
+    cell->payload.string.cdr.offset = tail.offset;
 
-        cell->payload.string.hash = calculate_hash( c, tail );
+    cell->payload.string.hash = calculate_hash( c, tail );
-    } else {
+  } else {
-        // \todo should throw an exception!
+    // \todo should throw an exception!
-        debug_printf( DEBUG_ALLOC,
+    debug_printf( DEBUG_ALLOC,
-                      L"Warning: only NIL and %4.4s can be prepended to %4.4s\n",
+                  L"Warning: only NIL and %4.4s can be prepended to %4.4s\n",
-                      tag, tag );
+                  tag, tag );
-    }
+  }
 
-    return pointer;
+  return pointer;
 }
 
 /**
@@ -340,7 +340,7 @@ make_string_like_thing( wint_t c, struct cons_pointer tail, uint32_t tag ) {
  * @param tail the string which is being built.
  */
 struct cons_pointer make_string( wint_t c, struct cons_pointer tail ) {
-    return make_string_like_thing( c, tail, STRINGTV );
+  return make_string_like_thing( c, tail, STRINGTV );
 }
 
 /**
@@ -353,36 +353,45 @@ struct cons_pointer make_string( wint_t c, struct cons_pointer tail ) {
  */
 struct cons_pointer make_symbol_or_key( wint_t c, struct cons_pointer tail,
                                         uint32_t tag ) {
-    struct cons_pointer result = make_string_like_thing( c, tail, tag );
+  struct cons_pointer result;
+
+  if ( tag == SYMBOLTV || tag == KEYTV ) {
+    result = make_string_like_thing( c, tail, tag );
 
     if ( tag == KEYTV ) {
-        struct cons_pointer r = internedp( result, oblist );
+      struct cons_pointer r = internedp( result, oblist );
 
-        if ( nilp( r ) ) {
+      if ( nilp( r ) ) {
-            intern( result, oblist );
+        intern( result, oblist );
-        } else {
+      } else {
-            result = r;
+        result = r;
-        }
+      }
     }
+  } else {
+    result = make_exception(
+        c_string_to_lisp_string( L"Unexpected tag when making symbol or key." ), 
+        NIL);
+  }
 
-    return result;
+  return result;
 }
 
 /**
  * Construct a cell which points to an executable Lisp special form.
  */
-struct cons_pointer
+struct cons_pointer make_special(
-make_special( struct cons_pointer meta, struct cons_pointer ( *executable )
+    struct cons_pointer meta,
-               ( struct stack_frame * frame,
+    struct cons_pointer ( *executable )( struct stack_frame *frame,
-                 struct cons_pointer, struct cons_pointer env ) ) {
+                                         struct cons_pointer,
-    struct cons_pointer pointer = allocate_cell( SPECIALTV );
+                                         struct cons_pointer env ) ) {
-    struct cons_space_object *cell = &pointer2cell( pointer );
+  struct cons_pointer pointer = allocate_cell( SPECIALTV );
-    inc_ref( meta );
+  struct cons_space_object *cell = &pointer2cell( pointer );
+  inc_ref( meta );
 
-    cell->payload.special.meta = meta;
+  cell->payload.special.meta = meta;
-    cell->payload.special.executable = executable;
+  cell->payload.special.executable = executable;
 
-    return pointer;
+  return pointer;
 }
 
 /**
@@ -391,15 +400,15 @@ make_special( struct cons_pointer meta, struct cons_pointer ( *executable )
  * @param metadata a pointer to an associaton containing metadata on the stream.
  * @return a pointer to the new read stream.
  */
-struct cons_pointer make_read_stream( URL_FILE * input,
+struct cons_pointer make_read_stream( URL_FILE *input,
                                       struct cons_pointer metadata ) {
-    struct cons_pointer pointer = allocate_cell( READTV );
+  struct cons_pointer pointer = allocate_cell( READTV );
-    struct cons_space_object *cell = &pointer2cell( pointer );
+  struct cons_space_object *cell = &pointer2cell( pointer );
 
-    cell->payload.stream.stream = input;
+  cell->payload.stream.stream = input;
-    cell->payload.stream.meta = metadata;
+  cell->payload.stream.meta = metadata;
 
-    return pointer;
+  return pointer;
 }
 
 /**
@@ -408,59 +417,59 @@ struct cons_pointer make_read_stream( URL_FILE * input,
  * @param metadata a pointer to an associaton containing metadata on the stream.
  * @return a pointer to the new read stream.
  */
-struct cons_pointer make_write_stream( URL_FILE * output,
+struct cons_pointer make_write_stream( URL_FILE *output,
                                        struct cons_pointer metadata ) {
-    struct cons_pointer pointer = allocate_cell( WRITETV );
+  struct cons_pointer pointer = allocate_cell( WRITETV );
-    struct cons_space_object *cell = &pointer2cell( pointer );
+  struct cons_space_object *cell = &pointer2cell( pointer );
 
-    cell->payload.stream.stream = output;
+  cell->payload.stream.stream = output;
-    cell->payload.stream.meta = metadata;
+  cell->payload.stream.meta = metadata;
 
-    return pointer;
+  return pointer;
 }
 
 /**
- * Return a lisp keyword representation of this wide character string. In keywords,
+ * Return a lisp keyword representation of this wide character string. In
- * I am accepting only lower case characters and numbers.
+ * keywords, I am accepting only lower case characters and numbers.
  */
 struct cons_pointer c_string_to_lisp_keyword( wchar_t *symbol ) {
-    struct cons_pointer result = NIL;
+  struct cons_pointer result = NIL;
 
-    for ( int i = wcslen( symbol ) - 1; i >= 0; i-- ) {
+  for ( int i = wcslen( symbol ) - 1; i >= 0; i-- ) {
-        wchar_t c = towlower( symbol[i] );
+    wchar_t c = towlower( symbol[i] );
 
-        if ( iswalnum( c ) || c == L'-' ) {
+    if ( iswalnum( c ) || c == L'-' ) {
-            result = make_keyword( c, result );
+      result = make_keyword( c, result );
-        }
     }
+  }
 
-    return result;
+  return result;
 }
 
 /**
  * Return a lisp string representation of this wide character string.
  */
 struct cons_pointer c_string_to_lisp_string( wchar_t *string ) {
-    struct cons_pointer result = NIL;
+  struct cons_pointer result = NIL;
 
-    for ( int i = wcslen( string ) - 1; i >= 0; i-- ) {
+  for ( int i = wcslen( string ) - 1; i >= 0; i-- ) {
-        if ( iswprint( string[i] ) && string[i] != '"' ) {
+    if ( iswprint( string[i] ) && string[i] != '"' ) {
-            result = make_string( string[i], result );
+      result = make_string( string[i], result );
-        }
     }
+  }
 
-    return result;
+  return result;
 }
 
 /**
  * Return a lisp symbol representation of this wide character string.
  */
 struct cons_pointer c_string_to_lisp_symbol( wchar_t *symbol ) {
-    struct cons_pointer result = NIL;
+  struct cons_pointer result = NIL;
 
-    for ( int i = wcslen( symbol ); i > 0; i-- ) {
+  for ( int i = wcslen( symbol ); i > 0; i-- ) {
-        result = make_symbol( symbol[i - 1], result );
+    result = make_symbol( symbol[i - 1], result );
-    }
+  }
 
-    return result;
+  return result;
 }

src/memory/consspaceobject.h

@@ -478,6 +478,8 @@ struct free_payload {
  * exceeds 60 bits, the least significant 60 bits are stored in the first cell
  * in the chain, the next 60 in the next cell, and so on. Only the value of the
  * first cell in any chain should be negative.
+ * 
+ * \todo Why is this 60, and not 64 bits?
  */
 struct integer_payload {
     /** the value of the payload (i.e. 60 bits) of this cell. */

src/memory/vectorspace.c

@@ -84,10 +84,11 @@ struct cons_pointer make_vso( uint32_t tag, uint64_t payload_size ) {
 
     if ( vso != NULL ) {
         memset( vso, 0, padded );
+                vso->header.tag.value = tag;
+
         debug_printf( DEBUG_ALLOC,
-                      L"make_vso: about to write tag '%4.4s' into vso at %p\n",
+                      L"make_vso: written tag '%4.4s' into vso at %p\n",
-                      tag, vso );
+                      vso->header.tag.bytes, vso );
-        vso->header.tag.value = tag;
         result = make_vec_pointer( vso, tag );
         debug_dump_object( result, DEBUG_ALLOC );
         vso->header.vecp = result;

src/ops/lispops.c

@@ -682,6 +682,8 @@ bool end_of_stringp( struct cons_pointer arg ) {
  * cdr is nill, and b is of type string, then returns a new string cell;
  * otherwise returns a new cons cell.
  * 
+ * Thus: `(cons "a" "bcd") -> "abcd"`, but `(cons "ab" "cd") -> ("ab" . "cd")`
+ *
  * * (cons a b)
  *
  * @param frame my stack_frame.
@@ -700,7 +702,6 @@ lisp_cons( struct stack_frame *frame, struct cons_pointer frame_pointer,
         return NIL;
     } else if ( stringp( car ) && stringp( cdr ) &&
                 end_of_stringp( c_cdr( car ) ) ) {
-        // \todo check that car is of length 1
         result =
             make_string( pointer2cell( car ).payload.string.character, cdr );
     } else {

src/version.h

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

unit-tests/memory.sh

@@ -0,0 +1,14 @@
+#!/bin/bash
+
+actual=`echo "" | target/psse  2>&1 | tail -2`
+
+alloc=`echo $actual | sed 's/[[:punct:]]/ /g' | awk '{print $4}'`
+dealloc=`echo $actual | sed 's/[[:punct:]]/ /g' | awk '{print $6}'`
+
+if [ "${alloc}" = "${dealloc}" ]
+then
+    echo "OK"
+else
+    echo "Fail: expected '${alloc}', got '${dealloc}'"
+    exit 1
+fi