Ratio multiplication and subtraction

src/conspage.c

@@ -127,6 +127,9 @@ void dump_pages( FILE * output ) {
 void free_cell( struct cons_pointer pointer ) {
     struct cons_space_object *cell = &pointer2cell( pointer );
 
+    fwprintf( stderr, L"Freeing cell " );
+    dump_object( stderr, pointer );
+
     switch ( cell->tag.value ) {
             /* for all the types of cons-space object which point to other
              * cons-space objects, cascade the decrement. */
@@ -160,20 +163,18 @@ void free_cell( struct cons_pointer pointer ) {
 
     if ( !check_tag( pointer, FREETAG ) ) {
         if ( cell->count == 0 ) {
-            fwprintf( stderr, L"Freeing cell " );
-            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,
-                      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,
-                  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 );
     }
 }

src/consspaceobject.c

@@ -133,6 +133,14 @@ void dump_object( FILE * output, struct cons_pointer pointer ) {
             fwprintf( output, L";\n\t\t\tbody: " );
             print( output, cell.payload.lambda.body );
             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" );
         case REALTV:

src/peano.c

@@ -26,7 +26,7 @@
 #include "stack.h"
 
 long double to_long_double( struct cons_pointer arg );
-long int to_long_int( struct stack_frame *frame, struct cons_pointer arg );
+long int to_long_int( struct cons_pointer arg );
 struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer arg1,
                            struct cons_pointer arg2 );
 
@@ -96,7 +96,7 @@ long double to_long_double( struct cons_pointer arg ) {
  * 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.
  */
-long int to_long_int( struct stack_frame *frame, struct cons_pointer arg ) {
+long int to_long_int( struct cons_pointer arg ) {
     long int result = 0;
     struct cons_space_object cell = pointer2cell( arg );
     switch ( cell.tag.value ) {
@@ -128,6 +128,28 @@ long int least_common_multiple( long int m, long int n ) {
     return m / greatest_common_divisor( m, n ) * n;
 }
 
+struct cons_pointer simplify_ratio( struct stack_frame *frame,
+                                    struct cons_pointer arg ) {
+    struct cons_pointer result = arg;
+    long int 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, make_integer( ddrv / gcd ),
+                            make_integer( drrv / gcd ) );
+        }
+    }
+    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,
@@ -141,7 +163,7 @@ struct cons_pointer add_ratio_ratio( struct stack_frame *frame,
     fputws( L"; arg2 = ", stderr );
     print( stderr, arg2 );
 
-    struct cons_pointer result;
+    struct cons_pointer r1, result;
     struct cons_space_object cell1 = pointer2cell( arg1 );
     struct cons_space_object cell2 = pointer2cell( arg2 );
     long int dd1v =
@@ -158,29 +180,11 @@ struct cons_pointer add_ratio_ratio( struct stack_frame *frame,
     fwprintf( stderr, L"); lcm = %ld; m1 = %ld; m2 = %ld", lcm, m1, m2 );
 
     if ( dr1v == dr2v ) {
-        result =
+        r1 = make_ratio( frame,
-            make_ratio( frame,
                          make_integer( dd1v + dd2v ),
                          cell1.payload.ratio.divisor );
-
-        long int ddrv =
-            pointer2cell( pointer2cell( result ).payload.ratio.
-                          dividend ).payload.integer.value, drrv =
-            pointer2cell( pointer2cell( result ).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 =
+        r1 = add_ratio_ratio( frame,
-                    make_ratio( frame, make_integer( ddrv / gcd ),
-                                make_integer( drrv / gcd ) );
-            }
-        }
-    } else {
-        result = add_ratio_ratio( frame,
                               make_ratio( frame,
                                           make_integer( dd1v * m1 ),
                                           make_integer( dr1v * m1 ) ),
@@ -189,6 +193,11 @@ struct cons_pointer add_ratio_ratio( struct stack_frame *frame,
                                           make_integer( dr2v * m2 ) ) );
     }
 
+    result = simplify_ratio( frame, r1 );
+    if ( !eq( r1, result ) ) {
+        dec_ref( r1 );
+    }
+
     fputws( L" => ", stderr );
     print( stderr, result );
     fputws( L"\n", stderr );
@@ -257,6 +266,7 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer arg1,
                         result = lisp_throw( c_string_to_lisp_string
                                              ( "Cannot add: not a number" ),
                                              frame );
+                        break;
                 }
                 break;
             case RATIOTV:
@@ -275,6 +285,11 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer arg1,
                             make_real( to_long_double( arg1 ) +
                                        to_long_double( arg2 ) );
                         break;
+                    default:
+                        result = lisp_throw( c_string_to_lisp_string
+                                             ( "Cannot add: not a number" ),
+                                             frame );
+                        break;
                 }
                 break;
             case REALTV:
@@ -292,7 +307,6 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer arg1,
     print( stderr, arg2 );
     fputws( L"\n", stderr );
 
-
     return result;
 }
 
@@ -306,56 +320,173 @@ struct cons_pointer lisp_add( struct stack_frame
                               *frame, 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, 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, result, c_car( more ) );
+        if ( !eq( tmp, result ) ) {
+            dec_ref( tmp );
+        }
+
         more = c_cdr( more );
     }
 
     return result;
 }
 
-/**
+struct cons_pointer multiply_ratio_ratio( struct
- * Internal guts of multiply. Dark and mysterious.
- */
-struct cons_pointer multiply_accumulate( struct
-                                         cons_pointer arg, struct
                                           stack_frame
-                                         *frame, long
+                                          *frame, struct
-                                         int
+                                          cons_pointer arg1, struct
-                                         *i_accumulator, long
+                                          cons_pointer arg2 ) {
-                                         double
+    fputws( L"multiply_ratio_ratio( arg1 = ", stderr );
-                                         *d_accumulator, int
+    print( stderr, arg1 );
-                                         *is_int ) {
+    fputws( L"; arg2 = ", stderr );
-    struct cons_pointer result = NIL;
+    print( stderr, arg2 );
-    struct cons_space_object cell = pointer2cell( arg );
+
-    switch ( cell.tag.value ) {
+    struct cons_pointer result;
-        case INTEGERTV:
+    struct cons_space_object cell1 = pointer2cell( arg1 );
-            ( *i_accumulator ) *= cell.payload.integer.value;
+    struct cons_space_object cell2 = pointer2cell( arg2 );
-            ( *d_accumulator ) *= numeric_value( arg );
+    long int dd1v =
-            break;
+        pointer2cell( cell1.payload.ratio.dividend ).payload.integer.value,
-        case REALTV:
+        dd2v =
-            ( *d_accumulator ) *= cell.payload.real.value;
+        pointer2cell( cell2.payload.ratio.dividend ).payload.integer.value,
-            ( *is_int ) &= false;
+        dr1v =
-            break;
+        pointer2cell( cell1.payload.ratio.divisor ).payload.integer.value,
-        case EXCEPTIONTV:
+        dr2v =
-            result = arg;
+        pointer2cell( cell2.payload.ratio.divisor ).payload.integer.value,
-            break;
+        ddrv = dd1v * dd2v, drrv = dr1v * dr2v;
-        default:
+
-            result =
+    struct cons_pointer unsimplified = make_ratio( frame, make_integer( ddrv ),
-                lisp_throw
+                                                   make_integer( drrv ) );
-                ( c_string_to_lisp_string
+    result = simplify_ratio( frame, unsimplified );
-                  ( "Cannot multiply: not a number" ), frame );
+
+    if ( !eq( unsimplified, result ) ) {
+        dec_ref( unsimplified );
     }
+
     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 multiply_integer_ratio( struct stack_frame *frame,
+                                            struct cons_pointer intarg,
+                                            struct cons_pointer ratarg ) {
+    return multiply_ratio_ratio( frame,
+                                 make_ratio( frame, intarg,
+                                             make_integer( 1 ) ), ratarg );
+}
+
+
+/**
+* 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 arg1,
+                                struct cons_pointer arg2 ) {
+    struct cons_pointer result;
+    struct cons_space_object cell1 = pointer2cell( arg1 );
+    struct cons_space_object cell2 = pointer2cell( arg2 );
+
+    fputws( L"multiply_2( arg1 = ", stderr );
+    print( stderr, arg1 );
+    fputws( L"; arg2 = ", stderr );
+    print( stderr, arg2 );
+
+    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, arg1, arg2 );
+                        break;
+                    case REALTV:
+                        result =
+                            make_real( to_long_double( arg1 ) *
+                                       to_long_double( arg2 ) );
+                        break;
+                    default:
+                        result = lisp_throw( c_string_to_lisp_string
+                                             ( "Cannot multiply: not a number" ),
+                                             frame );
+                        break;
+                }
+                break;
+            case RATIOTV:
+                switch ( cell2.tag.value ) {
+                    case EXCEPTIONTV:
+                        result = arg2;
+                        break;
+                    case INTEGERTV:
+                        result = multiply_integer_ratio( frame, arg2, arg1 );
+                        break;
+                    case RATIOTV:
+                        result = multiply_ratio_ratio( frame, arg1, arg2 );
+                        break;
+                    case REALTV:
+                        result =
+                            make_real( to_long_double( arg1 ) *
+                                       to_long_double( arg2 ) );
+                        break;
+                    default:
+                        result = lisp_throw( c_string_to_lisp_string
+                                             ( "Cannot multiply: not a number" ),
+                                             frame );
+                }
+                break;
+            case REALTV:
+                result =
+                    make_real( to_long_double( arg1 ) *
+                               to_long_double( arg2 ) );
+                break;
+            default:
+                result = lisp_throw( c_string_to_lisp_string
+                                     ( "Cannot multiply: not a number" ),
+                                     frame );
+                break;
+        }
+    }
+
+    fputws( L"}; => ", stderr );
+    print( stderr, arg2 );
+    fputws( L"\n", stderr );
+
+    return result;
+}
+
+
 /**
  * Multiply an indefinite number of numbers together
  * @param env the evaluation environment - ignored;
@@ -366,40 +497,79 @@ struct cons_pointer lisp_multiply( struct
                                    stack_frame
                                    *frame, struct
                                    cons_pointer env ) {
-    struct cons_pointer result = NIL;
+    struct cons_pointer result = make_integer( 1 );
-    long int i_accumulator = 1;
+    struct cons_pointer tmp;
-    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 =
+        tmp = result;
-            multiply_accumulate( frame->arg[i],
+        result = multiply_2( frame, result, frame->arg[i] );
-                                 frame,
+
-                                 &i_accumulator, &d_accumulator, &is_int );
+        if ( !eq( tmp, result ) ) {
+            dec_ref( tmp );
+        }
     }
 
     struct cons_pointer more = frame->more;
     while ( consp( more )
             && !exceptionp( result ) ) {
-        result =
+        tmp = result;
-            multiply_accumulate( c_car
+        result = multiply_2( frame, result, c_car( more ) );
-                                 ( more ),
+        if ( !eq( tmp, result ) ) {
-                                 frame,
+            dec_ref( tmp );
-                                 &i_accumulator, &d_accumulator, &is_int );
+        }
+
         more = c_cdr( more );
     }
 
-    if ( !exceptionp( result ) ) {
+    return result;
-        if ( is_int ) {
+}
-            result = make_integer( i_accumulator );
+
-        } else {
+struct cons_pointer inverse( struct stack_frame *frame,
-            result = make_real( d_accumulator );
+                             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;
 }
 
+
+struct cons_pointer subtract_ratio_ratio( struct stack_frame *frame,
+                                          struct cons_pointer arg1,
+                                          struct cons_pointer arg2 ) {
+    struct cons_pointer i = inverse( frame, arg2 ),
+        result = add_ratio_ratio( frame, arg1, i );
+
+    dec_ref( i );
+
+    return result;
+}
+
 /**
  * Subtract one number from another.
  * @param env the evaluation environment - ignored;
@@ -411,32 +581,83 @@ struct cons_pointer lisp_subtract( struct
                                    *frame, struct
                                    cons_pointer env ) {
     struct cons_pointer result = NIL;
-    struct cons_space_object arg0 = pointer2cell( frame->arg[0] );
+    struct cons_space_object cell0 = pointer2cell( frame->arg[0] );
-    struct cons_space_object arg1 = pointer2cell( frame->arg[1] );
+    struct cons_space_object cell1 = pointer2cell( frame->arg[1] );
-    if ( integerp( frame->arg[0] )
+
-         && integerp( 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, frame->arg[0],
+                                        make_integer( 1 ) );
                         result =
-            make_integer( arg0.payload.integer.value
+                            subtract_ratio_ratio( frame, tmp, frame->arg[1] );
-                          - arg1.payload.integer.value );
+                        dec_ref( tmp );
-    } else if ( realp( frame->arg[0] )
+                    }
-                && realp( frame->arg[1] ) ) {
+                    break;
+                case REALTV:
                     result =
-            make_real( arg0.payload.real.value - arg1.payload.real.value );
+                        make_real( to_long_double( frame->arg[0] ) -
-    } else if ( integerp( frame->arg[0] )
+                                   to_long_double( frame->arg[1] ) );
-                && realp( frame->arg[1] ) ) {
+                    break;
+                default:
+                    result = lisp_throw( c_string_to_lisp_string
+                                         ( "Cannot multiply: not a number" ),
+                                         frame );
+                    break;
+            }
+            break;
+        case RATIOTV:
+            switch ( cell1.tag.value ) {
+                case EXCEPTIONTV:
+                    result = frame->arg[1];
+                    break;
+                case INTEGERTV:{
+                        struct cons_pointer tmp =
+                            make_ratio( frame, frame->arg[1],
+                                        make_integer( 1 ) );
                         result =
-            make_real( numeric_value
+                            subtract_ratio_ratio( frame, frame->arg[0], tmp );
-                       ( frame->arg[0] ) - arg1.payload.real.value );
+                        dec_ref( tmp );
-    } else if ( realp( frame->arg[0] )
+                    }
-                && integerp( frame->arg[1] ) ) {
+                    break;
+                case RATIOTV:
                     result =
-            make_real( arg0.payload.real.value -
+                        subtract_ratio_ratio( frame, frame->arg[0],
-                       numeric_value( frame->arg[1] ) );
+                                              frame->arg[1] );
-    } else {
+                    break;
-        /* TODO: throw an exception */
+                case REALTV:
-        lisp_throw
+                    result =
-            ( c_string_to_lisp_string
+                        make_real( to_long_double( frame->arg[0] ) -
-              ( "Cannot subtract: not a number" ), frame );
+                                   to_long_double( frame->arg[1] ) );
+                    break;
+                default:
+                    result = lisp_throw( c_string_to_lisp_string
+                                         ( "Cannot multiply: not a number" ),
+                                         frame );
+                    break;
+            }
+            break;
+        case REALTV:
+            result =
+                make_real( to_long_double( frame->arg[0] ) -
+                           to_long_double( frame->arg[1] ) );
+            break;
+        default:
+            result = lisp_throw( c_string_to_lisp_string
+                                 ( "Cannot multiply: not a number" ), frame );
+            break;
     }
 
     // and if not nilp[frame->arg[2]) we also have an error.