Various refactorings around bignum arithmetic

src/arith/integer.c

@@ -36,7 +36,7 @@
 /**
  * hexadecimal digits for printing numbers.
  */
-const wchar_t hex_digits[16] = L"0123456789ABCDEF";
+const char * hex_digits = "0123456789ABCDEF";
 
 /*
  * Doctrine from here on in is that ALL integers are bignums, it's just
@@ -133,13 +133,24 @@ struct cons_pointer operate_on_integers( struct cons_pointer a,
 
           switch (op) {
             case '*':
-          rv = ( av * bv ) + carry;
+            rv = av * bv * ((carry == 0) ? 1 : carry);
             break;
             case '+':
             rv = av + bv + carry;
             break;
           }
 
+          debug_printf( DEBUG_ARITH, L"operate_on_integers: op = '%c'; av = ", op);
+          debug_print_128bit( av, DEBUG_ARITH);
+          debug_print( L"; bv = ",  DEBUG_ARITH);
+          debug_print_128bit( bv, DEBUG_ARITH);
+          debug_print( L"; carry = ",  DEBUG_ARITH);
+          debug_print_128bit( carry, DEBUG_ARITH);
+          debug_print( L"; rv = ",  DEBUG_ARITH);
+          debug_print_128bit( rv, DEBUG_ARITH);
+          debug_print( L"\n",  DEBUG_ARITH);
+
+
             if ( MAX_INTEGER >= rv ) {
               carry = 0;
             } else {
@@ -206,7 +217,7 @@ struct cons_pointer multiply_integers( struct cons_pointer a,
 struct cons_pointer integer_to_string_add_digit( int digit, int digits,
                                                  struct cons_pointer tail ) {
     digits++;
-    wint_t character = ( wint_t ) hex_digits[digit];
+    wint_t character = btowc(hex_digits[digit]);
     return ( digits % 3 == 0 ) ?
         make_string( L',', make_string( character,
                                         tail ) ) :
@@ -247,13 +258,14 @@ struct cons_pointer integer_to_string( struct cons_pointer int_pointer,
                           L"integer_to_string: accumulator is %ld\n:",
                           accumulator );
             do {
+              int offset = (int)(accumulator % base);
                 debug_printf( DEBUG_IO,
-                              L"integer_to_string: digit is %ld, hexadecimal is %C\n:",
+                              L"integer_to_string: digit is %ld, hexadecimal is %c\n:",
-                              accumulator % base,
+                              offset,
-                              btowc(hex_digits[accumulator % base] ));
+                              hex_digits[offset] );
 
                 result =
-                    integer_to_string_add_digit( accumulator % base, digits++,
+                    integer_to_string_add_digit( offset, digits++,
                                                  result );
                 accumulator = accumulator / base;
             } while ( accumulator > base );

src/arith/peano.c

@@ -41,7 +41,8 @@ bool zerop( struct cons_pointer arg ) {
 
     switch ( cell.tag.value ) {
         case INTEGERTV:
-            result = cell.payload.integer.value == 0;
+            result = cell.payload.integer.value == 0 &&
+              nilp(cell.payload.integer.more);
             break;
         case RATIOTV:
             result = zerop( cell.payload.ratio.dividend );
@@ -134,9 +135,9 @@ struct cons_pointer add_2( struct stack_frame *frame,
     struct cons_space_object cell2 = pointer2cell( arg2 );
 
     debug_print( L"add_2( arg1 = ", DEBUG_ARITH );
-    debug_print_object( arg1, DEBUG_ARITH );
+    debug_dump_object( arg1, DEBUG_ARITH );
     debug_print( L"; arg2 = ", DEBUG_ARITH );
-    debug_print_object( arg2, DEBUG_ARITH );
+    debug_dump_object( arg2, DEBUG_ARITH );
     debug_print( L"\n", DEBUG_ARITH );
 
     if ( zerop( arg1 ) ) {

src/debug.c

@@ -42,6 +42,29 @@ void debug_print( wchar_t *message, int level ) {
 #endif
 }
 
+/**
+ * stolen from https://stackoverflow.com/questions/11656241/how-to-print-uint128-t-number-using-gcc
+ */
+void debug_print_128bit( __int128_t n, int level ) {
+  #ifdef DEBUG
+  if ( level & verbosity ) {
+    if (n == 0) {
+      fwprintf(stderr, L"0");
+    } else {
+      char str[40] = {0}; // log10(1 << 128) + '\0'
+      char *s = str + sizeof(str) - 1; // start at the end
+      while (n != 0) {
+        if (s == str) return; // never happens
+
+        *--s = "0123456789"[n % 10]; // save last digit
+        n /= 10;                     // drop it
+      }
+      fwprintf(stderr, L"%s", s);
+    }
+  }
+  #endif
+}
+
 /**
  * print a line feed to stderr, if `verbosity` matches `level`.
  * `verbosity is a set of flags, see debug_print.h; so you can

src/debug.h

@@ -26,6 +26,7 @@
 extern int verbosity;
 
 void debug_print( wchar_t *message, int level );
+void debug_print_128bit( __int128_t n, 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 );

src/ops/lispops.c

@@ -1133,7 +1133,6 @@ struct cons_pointer lisp_source( struct stack_frame *frame,
 struct cons_pointer lisp_inspect( 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 = frame->arg[0];
     FILE *output = stdout;
     struct cons_pointer out_stream = writep( frame->arg[1] ) ?
         frame->arg[1] : get_default_stream( false, env );
@@ -1150,5 +1149,5 @@ struct cons_pointer lisp_inspect( struct stack_frame *frame, struct cons_pointer
         dec_ref( out_stream );
     }
 
-    return result;
+    return frame->arg[0];
 }

src/ops/read.c

@@ -157,91 +157,104 @@ struct cons_pointer read_continuation( struct stack_frame *frame,
  * garbage is collected.
  */
 struct cons_pointer read_number( struct stack_frame *frame,
-                                 struct cons_pointer frame_pointer,
+                                struct cons_pointer frame_pointer,
-                                 FILE * input,
+                                FILE * input,
-                                 wint_t initial, bool seen_period ) {
+                                wint_t initial, bool seen_period ) {
-    debug_print( L"entering read_number\n", DEBUG_IO );
+  debug_print( L"entering read_number\n", DEBUG_IO );
 
-    struct cons_pointer result = make_integer( 0, NIL );
+  struct cons_pointer result = make_integer( 0, NIL );
-    /* TODO: we really need to be getting `base` from a privileged Lisp name -
+  /* TODO: we really need to be getting `base` from a privileged Lisp name -
      * and it should be the same privileged name we use when writing numbers */
-    struct cons_pointer base = make_integer( 10, NIL );
+  struct cons_pointer base = make_integer( 10, NIL );
-    struct cons_pointer dividend = NIL;
+  struct cons_pointer dividend = NIL;
-    int places_of_decimals = 0;
+  int places_of_decimals = 0;
-    wint_t c;
+  wint_t c;
-    bool neg = initial == btowc( '-' );
+  bool neg = initial == btowc( '-' );
 
-    if ( neg ) {
+  if ( neg ) {
-        initial = fgetwc( input );
+    initial = fgetwc( input );
+  }
+
+  debug_printf( DEBUG_IO, L"read_number starting '%c' (%d)\n", initial,
+               initial );
+
+  for ( c = initial; iswdigit( c )
+       || c == L'.' || c == L'/' || c == L','; c = fgetwc( input ) ) {
+    switch (c) {
+      case L'.':
+      if ( seen_period || !nilp( dividend ) ) {
+        return throw_exception( c_string_to_lisp_string
+                               ( L"Malformed number: too many periods" ),
+                               frame_pointer );
+      } else {
+        debug_print(L"read_number: decimal point seen\n", DEBUG_IO);
+        seen_period = true;
+      }
+      break;
+      case L'/':
+      if ( seen_period || !nilp( dividend ) ) {
+        return throw_exception( c_string_to_lisp_string
+                               ( L"Malformed number: dividend of rational must be integer" ),
+                               frame_pointer );
+      } else {
+        debug_print(L"read_number: ratio slash seen\n", DEBUG_IO);
+        dividend = result;
+
+        result = make_integer( 0, NIL );
+      }
+      break;
+      case L',' :
+      // silently ignore it.
+      break;
+      default:
+      result = add_integers( multiply_integers( result, base ),
+                            make_integer( ( int ) c - ( int ) '0',
+                                         NIL ) );
+
+      debug_printf( DEBUG_IO,
+                   L"read_number: added character %c, result now ", c );
+      debug_print_object( result, DEBUG_IO);
+      debug_print( L"\n", DEBUG_IO);
+
+      if ( seen_period ) {
+        places_of_decimals++;
+      }
     }
+  }
 
-    debug_printf( DEBUG_IO, L"read_number starting '%c' (%d)\n", initial,
+  /*
-                  initial );
-
-    for ( c = initial; iswdigit( c )
-          || c == L'.' || c == L'/' || c == L','; c = fgetwc( input ) ) {
-        if ( c == btowc( '.' ) ) {
-            if ( seen_period || !nilp( dividend ) ) {
-                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 || !nilp( dividend ) ) {
-                return throw_exception( c_string_to_lisp_string
-                                        ( L"Malformed number: dividend of rational must be integer" ),
-                                        frame_pointer );
-            } else {
-                dividend = result;
-
-                result = make_integer( 0, NIL );
-            }
-        } else if ( c == L',' ) {
-            // silently ignore it.
-        } else {
-            result = add_integers( multiply_integers( result, base ),
-                                   make_integer( ( int ) c - ( int ) '0',
-                                                 NIL ) );
-
-            debug_printf( DEBUG_IO,
-                          L"Added character %c, result now %ld\n", c, result );
-
-            if ( seen_period ) {
-                places_of_decimals++;
-            }
-        }
-    }
-
-    /*
      * push back the character read which was not a digit
      */
-    ungetwc( c, input );
+  ungetwc( c, input );
-    if ( seen_period ) {
-        struct cons_pointer div = make_ratio( frame_pointer, result,
-                                              make_integer( powl
-                                                            ( to_long_double
-                                                              ( base ),
-                                                              places_of_decimals ),
-                                                            NIL ) );
-        inc_ref( div );
 
-        result = make_real( to_long_double( div ) );
+  if ( seen_period ) {
+    debug_print(L"read_number: converting result to real\n", DEBUG_IO);
+    struct cons_pointer div = make_ratio( frame_pointer, result,
+                                         make_integer( powl
+                                                      ( to_long_double
+                                                       ( base ),
+                                                       places_of_decimals ),
+                                                      NIL ) );
+    inc_ref( div );
 
-        dec_ref( div );
+    result = make_real( to_long_double( div ) );
-    } else if ( integerp( dividend ) ) {
-        result = make_ratio( frame_pointer, dividend, result );
-    }
 
-    if ( neg ) {
+    dec_ref( div );
-        result = negative( frame_pointer, result );
+  } else if ( integerp( dividend ) ) {
-    }
+    debug_print(L"read_number: converting result to ratio\n", DEBUG_IO);
+    result = make_ratio( frame_pointer, dividend, result );
+  }
 
-    debug_print( L"read_number returning\n", DEBUG_IO );
+  if ( neg ) {
-    debug_dump_object( result, DEBUG_IO );
+    debug_print(L"read_number: converting result to negative\n", DEBUG_IO);
 
-    return result;
+    result = negative( frame_pointer, result );
+  }
+
+  debug_print( L"read_number returning\n", DEBUG_IO );
+  debug_dump_object( result, DEBUG_IO );
+
+  return result;
 }
 
 /**