Tried to get more sensible printing of floating point numbers

Results are quite disappointing. Resolution on long doubles is nothing like as good as I hoped; they're out by one part in 10^20.

All unit tests except one pass, and the one that doesn't is a very minor rounding issue, so I'm calling it good.

Makefile

@@ -38,7 +38,7 @@ test: $(OBJS) $(TESTS) Makefile
 
 .PHONY: clean
 clean:
-	$(RM) $(TARGET) $(OBJS) $(DEPS) $(SRC_DIRS)/*~
+	$(RM) $(TARGET) $(OBJS) $(DEPS) $(SRC_DIRS)/*~ *~
 
 repl:
 	$(TARGET) -p 2> psse.log

src/init.c

@@ -73,7 +73,6 @@ int main( int argc, char *argv[] ) {
      */
     deep_bind( c_string_to_lisp_symbol( "nil" ), NIL );
     deep_bind( c_string_to_lisp_symbol( "t" ), TRUE );
-    /* deep_bind( c_string_to_lisp_symbol( L"λ"), LAMBDA ); */
     deep_bind( c_string_to_lisp_symbol( "lambda" ), LAMBDA );
 
     /*
@@ -85,6 +84,7 @@ int main( int argc, char *argv[] ) {
     bind_function( "car", &lisp_car );
     bind_function( "cdr", &lisp_cdr );
     bind_function( "cons", &lisp_cons );
+    bind_function( "divide", &lisp_divide );
     bind_function( "eq", &lisp_eq );
     bind_function( "equal", &lisp_equal );
     bind_function( "eval", &lisp_eval );
@@ -98,6 +98,7 @@ int main( int argc, char *argv[] ) {
     bind_function( "+", &lisp_add );
     bind_function( "*", &lisp_multiply );
     bind_function( "-", &lisp_subtract );
+    bind_function( "/", &lisp_divide );
 
     /*
      * primitive special forms

src/integer.c

@@ -21,7 +21,7 @@
  * but only integers and reals are so far implemented.
  */
 long double numeric_value( struct cons_pointer pointer ) {
-    double result = NAN;
+    long double result = NAN;
     struct cons_space_object *cell = &pointer2cell( pointer );
 
     if ( integerp( pointer ) ) {

src/peano.c

@@ -170,13 +170,16 @@ lisp_divide( struct stack_frame *frame, struct cons_pointer env ) {
     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 ( integerp( frame->arg[0] ) && integerp( frame->arg[1] ) ) {
-        result = make_integer( arg0.payload.integer.value /
-                               arg1.payload.integer.value );
     } else if ( numberp( frame->arg[0] ) && numberp( frame->arg[1] ) ) {
-        result =
-            make_real( numeric_value( frame->arg[0] ) /
-                       numeric_value( 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 );

src/peano.h

@@ -43,6 +43,15 @@ extern "C" {
     struct cons_pointer
      lisp_subtract( struct stack_frame *frame, struct cons_pointer env );
 
+/**
+ * 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 );
+
 #ifdef __cplusplus
 }
 #endif

src/print.c

@@ -9,6 +9,7 @@
 
 #include <ctype.h>
 #include <stdio.h>
+#include <stdlib.h>
 #include <string.h>
 /*
  * wide characters
@@ -72,6 +73,7 @@ void print_list( FILE * output, struct cons_pointer pointer ) {
 
 void print( FILE * output, struct cons_pointer pointer ) {
     struct cons_space_object cell = pointer2cell( pointer );
+    char *buffer;
 
     /*
      * Because tags have values as well as bytes, this if ... else if
@@ -95,7 +97,20 @@ void print( FILE * output, struct cons_pointer pointer ) {
         fwprintf( output, L"nil" );
         break;
     case REALTV:
-        fwprintf( output, L"%Lf", cell.payload.real.value );
+        /* TODO: using the C heap is a bad plan because it will fragment.
+         * As soon as I have working vector space I'll use a special purpose
+         * vector space object */
+        buffer = ( char * ) malloc( 24 );
+        memset( buffer, 0, 24 );
+        /* format it really long, then clear the trailing zeros */
+        sprintf( buffer, "%-.23Lg", cell.payload.real.value );
+        if ( strchr( buffer, '.' ) != NULL ) {
+            for ( int i = strlen( buffer ) - 1; buffer[i] == '0'; i-- ) {
+                buffer[i] = '\0';
+            }
+        }
+        fwprintf( output, L"%s", buffer );
+        free( buffer );
         break;
     case STRINGTV:
         print_string( output, pointer );

unit-tests/add.sh

@@ -11,7 +11,7 @@ else
     exit 1
 fi
 
-expected='5.500000'
+expected='5.5'
 actual=`echo "(add 2.5 3)" | target/psse 2> /dev/null | head -2 | tail -1`
 
 if [ "${expected}" = "${actual}" ]

unit-tests/multiply.sh

@@ -11,7 +11,7 @@ else
     exit 1
 fi
 
-expected='7.500000'
+expected='7.5'
 actual=`echo "(multiply 2.5 3)" | target/psse 2> /dev/null | head -2 | tail -1`
 
 if [ "${expected}" = "${actual}" ]

unit-tests/string-allocation.sh

@@ -1,14 +1,17 @@
 #!/bin/bash
 
+log=log.$$
 value='"Fred"'
 expected="String cell: character 'F' (70)"
-echo ${value} | target/psse -d 2>/dev/null | grep "${expected}" > /dev/null
+echo ${value} | target/psse -d > ${log} 2>/dev/null
+grep "${expected}" ${log} > /dev/null
 
 if [ $? -eq 0 ]
 then
     echo "OK"
+    rm ${log}
     exit 0
 else
-    echo "Expected '${expected}', not found"
+    echo "Expected '${expected}', not found in ${log}"
     exit 1
 fi