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`,
@@ -92,7 +92,6 @@ struct cons_pointer dec_ref( struct cons_pointer pointer ) {
   return pointer;
 }
 
-
 /**
  * Get the Lisp type of the single argument.
  * @param pointer a pointer to the object whose type is requested.
@@ -102,13 +101,11 @@ struct cons_pointer c_type( struct cons_pointer pointer ) {
   struct cons_pointer result = NIL;
   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 );
 
     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-- ) {
@@ -159,7 +156,8 @@ struct cons_pointer c_cdr( struct cons_pointer arg ) {
 }
 
 /**
- * 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;
@@ -171,7 +169,6 @@ int c_length( struct cons_pointer arg ) {
   return result;
 }
 
-
 /**
  * Construct a cons cell from this pair of pointers.
  */
@@ -193,8 +190,10 @@ 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 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 ) {
@@ -212,14 +211,14 @@ struct cons_pointer make_exception( struct cons_pointer message,
   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 ) ) {
   struct cons_pointer pointer = allocate_cell( FUNCTIONTV );
   struct cons_space_object *cell = &pointer2cell( pointer );
   inc_ref( meta );
@@ -238,7 +237,8 @@ struct cons_pointer make_lambda( struct cons_pointer args,
   struct cons_pointer pointer = allocate_cell( LAMBDATV );
   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( body );
@@ -256,7 +256,8 @@ struct cons_pointer make_nlambda( struct cons_pointer args,
                                   struct cons_pointer body ) {
   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 );
   inc_ref( args );
@@ -289,8 +290,7 @@ uint32_t calculate_hash( wint_t c, struct cons_pointer ptr ) {
       if ( nilp( cell->payload.string.cdr ) ) {
         result = (uint32_t)c;
       } else {
-                result = ( ( uint32_t ) c *
+        result = ( (uint32_t)c * cell->payload.string.hash ) & 0xffffffff;
-                           cell->payload.string.hash ) & 0xffffffff;
       }
       break;
   }
@@ -304,8 +304,8 @@ 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;
 
   if ( check_tag( tail, tag ) || check_tag( tail, NILTV ) ) {
@@ -353,7 +353,10 @@ 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 );
@@ -364,6 +367,11 @@ struct cons_pointer make_symbol_or_key( wint_t c, struct cons_pointer tail,
         result = r;
       }
     }
+  } else {
+    result = make_exception(
+        c_string_to_lisp_string( L"Unexpected tag when making symbol or key." ), 
+        NIL);
+  }
 
   return result;
 }
@@ -371,10 +379,11 @@ struct cons_pointer make_symbol_or_key( wint_t c, struct cons_pointer tail,
 /**
  * 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 env ) ) {
   struct cons_pointer pointer = allocate_cell( SPECIALTV );
   struct cons_space_object *cell = &pointer2cell( pointer );
   inc_ref( meta );
@@ -420,8 +429,8 @@ struct cons_pointer make_write_stream( URL_FILE * output,
 }
 
 /**
- * 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;

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 );
-        debug_printf( DEBUG_ALLOC,
-                      L"make_vso: about to write tag '%4.4s' into vso at %p\n",
-                      tag, vso );
                 vso->header.tag.value = tag;
+
+        debug_printf( DEBUG_ALLOC,
+                      L"make_vso: written tag '%4.4s' into vso at %p\n",
+                      vso->header.tag.bytes, vso );
         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