OK, my idea that long multiplication is like long addition is wrong.
It's still broken, but it's broken because of fundamental misunderstanding which tinkering won't solve.
This commit is contained in:
parent
22fa7314d6
commit
64fc43e9fc
|
@ -45,4 +45,4 @@
|
||||||
(inspect (set! z (+ y y y y y y y y y y)))
|
(inspect (set! z (+ y y y y y y y y y y)))
|
||||||
|
|
||||||
"This blows up: 10^37, which is a three cell bignum."
|
"This blows up: 10^37, which is a three cell bignum."
|
||||||
(inspect (+ z z z z z z z z z z))
|
(inspect (set! final (+ z z z z z z z z z z)))
|
||||||
|
|
|
@ -81,4 +81,5 @@
|
||||||
(inspect
|
(inspect
|
||||||
(set! z (+ y y y y y y y y)))
|
(set! z (+ y y y y y y y y)))
|
||||||
|
|
||||||
(inspect (+ z z z z z z z z))
|
(inspect
|
||||||
|
(set! final (+ z z z z z z z z)))
|
||||||
|
|
|
@ -27,6 +27,7 @@
|
||||||
#include "conspage.h"
|
#include "conspage.h"
|
||||||
#include "consspaceobject.h"
|
#include "consspaceobject.h"
|
||||||
#include "debug.h"
|
#include "debug.h"
|
||||||
|
#include "lispops.h"
|
||||||
|
|
||||||
/*
|
/*
|
||||||
* The maximum value we will allow in an integer cell.
|
* The maximum value we will allow in an integer cell.
|
||||||
|
@ -104,14 +105,20 @@ struct cons_pointer make_integer( int64_t value, struct cons_pointer more ) {
|
||||||
* \see operate_on_integers
|
* \see operate_on_integers
|
||||||
*/
|
*/
|
||||||
__int128_t cell_value( struct cons_pointer c, char op, bool is_first_cell ) {
|
__int128_t cell_value( struct cons_pointer c, char op, bool is_first_cell ) {
|
||||||
long int val = nilp( c ) ? 0 : pointer2cell( c ).payload.integer.value;
|
long int val = nilp( c ) ?
|
||||||
|
0 :
|
||||||
|
pointer2cell( c ).payload.integer.value;
|
||||||
|
|
||||||
long int carry = is_first_cell ? 0 : ( MAX_INTEGER + 1 );
|
long int carry = is_first_cell ? 0 : ( MAX_INTEGER + 1 );
|
||||||
|
|
||||||
__int128_t result = ( __int128_t ) integerp( c ) ?
|
__int128_t result = ( __int128_t ) integerp( c ) ?
|
||||||
( val == 0 ) ? carry : val : op == '*' ? 1 : 0;
|
( val == 0 ) ?
|
||||||
|
carry :
|
||||||
|
val :
|
||||||
|
0;
|
||||||
debug_printf( DEBUG_ARITH,
|
debug_printf( DEBUG_ARITH,
|
||||||
L"cell_value: raw value is %ld, op = '%c', is_first_cell = %s; returning ",
|
L"cell_value: raw value is %ld, op = '%c', is_first_cell = %s; %4.4s; returning ",
|
||||||
val, op, is_first_cell ? "true" : "false" );
|
val, op, is_first_cell ? "true" : "false", pointer2cell(c).tag.bytes);
|
||||||
debug_print_128bit( result, DEBUG_ARITH );
|
debug_print_128bit( result, DEBUG_ARITH );
|
||||||
debug_println( DEBUG_ARITH );
|
debug_println( DEBUG_ARITH );
|
||||||
|
|
||||||
|
@ -139,6 +146,7 @@ struct cons_pointer operate_on_integers( struct cons_pointer a,
|
||||||
struct cons_pointer b, char op ) {
|
struct cons_pointer b, char op ) {
|
||||||
struct cons_pointer result = NIL;
|
struct cons_pointer result = NIL;
|
||||||
struct cons_pointer cursor = NIL;
|
struct cons_pointer cursor = NIL;
|
||||||
|
|
||||||
__int128_t carry = 0;
|
__int128_t carry = 0;
|
||||||
bool is_first_cell = true;
|
bool is_first_cell = true;
|
||||||
|
|
||||||
|
@ -163,7 +171,7 @@ struct cons_pointer operate_on_integers( struct cons_pointer a,
|
||||||
|
|
||||||
switch ( op ) {
|
switch ( op ) {
|
||||||
case '*':
|
case '*':
|
||||||
rv = av * ( bv + carry );
|
rv = (av * bv) + carry;
|
||||||
break;
|
break;
|
||||||
case '+':
|
case '+':
|
||||||
rv = av + bv + carry;
|
rv = av + bv + carry;
|
||||||
|
|
|
@ -136,7 +136,12 @@ struct cons_pointer eval_forms( struct stack_frame *frame,
|
||||||
/**
|
/**
|
||||||
* Return the object list (root namespace).
|
* Return the object list (root namespace).
|
||||||
*
|
*
|
||||||
* (oblist)
|
* * (oblist)
|
||||||
|
*
|
||||||
|
* @param frame the stack frame in which the expression is to be interpreted;
|
||||||
|
* @param frame_pointer a pointer to my stack_frame.
|
||||||
|
* @param env my environment (ignored).
|
||||||
|
* @return the root namespace.
|
||||||
*/
|
*/
|
||||||
struct cons_pointer
|
struct cons_pointer
|
||||||
lisp_oblist( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
lisp_oblist( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
||||||
|
@ -165,12 +170,15 @@ struct cons_pointer compose_body( struct stack_frame *frame ) {
|
||||||
}
|
}
|
||||||
|
|
||||||
/**
|
/**
|
||||||
* Construct an interpretable function.
|
* Construct an interpretable function. *NOTE* that if `args` is a single symbol
|
||||||
|
* rather than a list, a varargs function will be created.
|
||||||
*
|
*
|
||||||
* (lambda args body)
|
* (lambda args body)
|
||||||
*
|
*
|
||||||
* @param frame the stack frame in which the expression is to be interpreted;
|
* @param frame the stack frame in which the expression is to be interpreted;
|
||||||
|
* @param frame_pointer a pointer to my stack_frame.
|
||||||
* @param env the environment in which it is to be intepreted.
|
* @param env the environment in which it is to be intepreted.
|
||||||
|
* @return an interpretable function with these `args` and this `body`.
|
||||||
*/
|
*/
|
||||||
struct cons_pointer
|
struct cons_pointer
|
||||||
lisp_lambda( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
lisp_lambda( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
||||||
|
@ -179,12 +187,15 @@ lisp_lambda( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
||||||
}
|
}
|
||||||
|
|
||||||
/**
|
/**
|
||||||
* Construct an interpretable special form.
|
* Construct an interpretable special form. *NOTE* that if `args` is a single symbol
|
||||||
|
* rather than a list, a varargs special form will be created.
|
||||||
*
|
*
|
||||||
* (nlambda args body)
|
* (nlambda args body)
|
||||||
*
|
*
|
||||||
* @param frame the stack frame in which the expression is to be interpreted;
|
* @param frame the stack frame in which the expression is to be interpreted;
|
||||||
|
* @param frame_pointer a pointer to my stack_frame.
|
||||||
* @param env the environment in which it is to be intepreted.
|
* @param env the environment in which it is to be intepreted.
|
||||||
|
* @return an interpretable special form with these `args` and this `body`.
|
||||||
*/
|
*/
|
||||||
struct cons_pointer
|
struct cons_pointer
|
||||||
lisp_nlambda( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
lisp_nlambda( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
||||||
|
@ -612,6 +623,16 @@ lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
||||||
return result;
|
return result;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
/**
|
||||||
|
* @return true if `arg` represents an end of string, else false.
|
||||||
|
* \todo candidate for moving to a memory/string.c file
|
||||||
|
*/
|
||||||
|
bool end_of_stringp(struct cons_pointer arg) {
|
||||||
|
return nilp(arg) ||
|
||||||
|
( stringp( arg ) &&
|
||||||
|
pointer2cell(arg).payload.string.character == (wint_t)'\0');
|
||||||
|
}
|
||||||
|
|
||||||
/**
|
/**
|
||||||
* Function;
|
* Function;
|
||||||
* returns a cell constructed from a and b. If a is of type string but its
|
* returns a cell constructed from a and b. If a is of type string but its
|
||||||
|
@ -634,7 +655,8 @@ lisp_cons( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
||||||
|
|
||||||
if ( nilp( car ) && nilp( cdr ) ) {
|
if ( nilp( car ) && nilp( cdr ) ) {
|
||||||
return NIL;
|
return NIL;
|
||||||
} else if ( stringp( car ) && stringp( cdr )) {
|
} else if ( stringp( car ) && stringp( cdr ) &&
|
||||||
|
end_of_stringp( c_cdr( car)) ) {
|
||||||
// \todo check that car is of length 1
|
// \todo check that car is of length 1
|
||||||
result =
|
result =
|
||||||
make_string( pointer2cell( car ).payload.string.character, cdr );
|
make_string( pointer2cell( car ).payload.string.character, cdr );
|
||||||
|
@ -1084,7 +1106,7 @@ throw_exception( struct cons_pointer message,
|
||||||
* normally return. A function which detects a problem it cannot resolve
|
* normally return. A function which detects a problem it cannot resolve
|
||||||
* *should* return an exception.
|
* *should* return an exception.
|
||||||
*
|
*
|
||||||
* * (exception <message> <frame>)
|
* * (exception message frame)
|
||||||
*
|
*
|
||||||
* @param frame my stack frame.
|
* @param frame my stack frame.
|
||||||
* @param frame_pointer a pointer to my stack_frame.
|
* @param frame_pointer a pointer to my stack_frame.
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
#!/bin/bash
|
#!/bin/bash
|
||||||
|
|
||||||
expected='(Special form)'
|
expected='<Special form>'
|
||||||
actual=`echo "(eval 'cond)" | target/psse | tail -1`
|
actual=`echo "(eval 'cond)" | target/psse | tail -1`
|
||||||
|
|
||||||
if [ "${expected}" = "${actual}" ]
|
if [ "${expected}" = "${actual}" ]
|
||||||
|
|
|
@ -6,7 +6,18 @@ actual=`echo "(+ 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)" | target/psse | tail -1`
|
||||||
if [ "${expected}" = "${actual}" ]
|
if [ "${expected}" = "${actual}" ]
|
||||||
then
|
then
|
||||||
echo "OK"
|
echo "OK"
|
||||||
exit 0
|
else
|
||||||
|
echo "Fail: expected '${expected}', got '${actual}'"
|
||||||
|
exit 1
|
||||||
|
fi
|
||||||
|
|
||||||
|
# check that all the args are actually being evaluated...
|
||||||
|
expected="120"
|
||||||
|
actual=`echo "(+ (+ 0 1) (+ 0 2) (+ 0 3) (+ 0 4) (+ 0 5) (+ 0 6) (+ 0 7) (+ 0 8) (+ 0 9) (+ 0 10) (+ 0 11) (+ 0 12) (+ 0 13) (+ 0 14 ) (+ 0 15))" | target/psse | tail -1`
|
||||||
|
|
||||||
|
if [ "${expected}" = "${actual}" ]
|
||||||
|
then
|
||||||
|
echo "OK"
|
||||||
else
|
else
|
||||||
echo "Fail: expected '${expected}', got '${actual}'"
|
echo "Fail: expected '${expected}', got '${actual}'"
|
||||||
exit 1
|
exit 1
|
||||||
|
|
Loading…
Reference in a new issue