From 64fc43e9fcc8b15a02cf02622a0c86a022c200d1 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 20 Jan 2019 23:34:46 +0000 Subject: [PATCH] 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. --- lisp/scratchpad.lisp | 2 +- lisp/scratchpad2.lisp | 3 ++- src/arith/integer.c | 18 +++++++++++++----- src/ops/lispops.c | 32 +++++++++++++++++++++++++++----- unit-tests/eval-quote-symbol.sh | 2 +- unit-tests/many-args.sh | 13 ++++++++++++- 6 files changed, 56 insertions(+), 14 deletions(-) diff --git a/lisp/scratchpad.lisp b/lisp/scratchpad.lisp index 494fe59..0474099 100644 --- a/lisp/scratchpad.lisp +++ b/lisp/scratchpad.lisp @@ -45,4 +45,4 @@ (inspect (set! z (+ y y y y y y y y y y))) "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))) diff --git a/lisp/scratchpad2.lisp b/lisp/scratchpad2.lisp index e608106..65f7aca 100644 --- a/lisp/scratchpad2.lisp +++ b/lisp/scratchpad2.lisp @@ -81,4 +81,5 @@ (inspect (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))) diff --git a/src/arith/integer.c b/src/arith/integer.c index c51bc56..5b2e26a 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -27,6 +27,7 @@ #include "conspage.h" #include "consspaceobject.h" #include "debug.h" +#include "lispops.h" /* * 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 */ __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 ); __int128_t result = ( __int128_t ) integerp( c ) ? - ( val == 0 ) ? carry : val : op == '*' ? 1 : 0; + ( val == 0 ) ? + carry : + val : + 0; debug_printf( DEBUG_ARITH, - L"cell_value: raw value is %ld, op = '%c', is_first_cell = %s; returning ", - val, op, is_first_cell ? "true" : "false" ); + L"cell_value: raw value is %ld, op = '%c', is_first_cell = %s; %4.4s; returning ", + val, op, is_first_cell ? "true" : "false", pointer2cell(c).tag.bytes); debug_print_128bit( result, 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 result = NIL; struct cons_pointer cursor = NIL; + __int128_t carry = 0; bool is_first_cell = true; @@ -163,7 +171,7 @@ struct cons_pointer operate_on_integers( struct cons_pointer a, switch ( op ) { case '*': - rv = av * ( bv + carry ); + rv = (av * bv) + carry; break; case '+': rv = av + bv + carry; diff --git a/src/ops/lispops.c b/src/ops/lispops.c index 775f3b4..c80d965 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -136,7 +136,12 @@ struct cons_pointer eval_forms( struct stack_frame *frame, /** * 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 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) * * @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. + * @return an interpretable function with these `args` and this `body`. */ struct cons_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) * * @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. + * @return an interpretable special form with these `args` and this `body`. */ struct cons_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 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; * 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 ) ) { 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 result = 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 * *should* return an exception. * - * * (exception ) + * * (exception message frame) * * @param frame my stack frame. * @param frame_pointer a pointer to my stack_frame. diff --git a/unit-tests/eval-quote-symbol.sh b/unit-tests/eval-quote-symbol.sh index 253ce32..7e80c48 100755 --- a/unit-tests/eval-quote-symbol.sh +++ b/unit-tests/eval-quote-symbol.sh @@ -1,6 +1,6 @@ #!/bin/bash -expected='(Special form)' +expected='' actual=`echo "(eval 'cond)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] diff --git a/unit-tests/many-args.sh b/unit-tests/many-args.sh index a574ecb..0317f77 100755 --- a/unit-tests/many-args.sh +++ b/unit-tests/many-args.sh @@ -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}" ] then 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 echo "Fail: expected '${expected}', got '${actual}'" exit 1