simon/post-scarcity
1
0
Fork 0
Code Issues 4 Pull requests Projects Releases Packages Wiki Activity Actions

Work on exception handling, especially around ratio arithmetic

Browse source 
Much simplified but will break things!
This commit is contained in:
Simon Brooke 2021-07-25 17:02:28 +01:00
parent d2101dbd47
commit 70d176982b
No known key found for this signature in database
GPG key ID: A7A4F18D1D4DF987
14 changed files with 298 additions and 258 deletions
Download patch file Download diff file Expand all files Collapse all files

154
src/ops/equal.c
View file

@ -12,14 +12,17 @@
#include "conspage.h"
#include "consspaceobject.h"
#include "integer.h"
#include "peano.h"
#include "ratio.h"
/**
* Shallow, and thus cheap, equality: true if these two objects are
* the same object, else false.
*/
bool eq( struct cons_pointer a, struct cons_pointer b ) {
return ( ( a.page == b.page ) && ( a.offset == b.offset ) );
bool eq(struct cons_pointer a, struct cons_pointer b)
{
return ((a.page == b.page) && (a.offset == b.offset));
}
/**
@ -29,12 +32,12 @@ bool eq( struct cons_pointer a, struct cons_pointer b ) {
* @return true if the objects at these two cons pointers have the same tag,
* else false.
*/
bool same_type( struct cons_pointer a, struct cons_pointer b ) {
struct cons_space_object *cell_a = &pointer2cell( a );
struct cons_space_object *cell_b = &pointer2cell( b );
bool same_type(struct cons_pointer a, struct cons_pointer b)
{
struct cons_space_object *cell_a = &pointer2cell(a);
struct cons_space_object *cell_b = &pointer2cell(b);
return cell_a->tag.value == cell_b->tag.value;
}
/**
@ -42,82 +45,99 @@ bool same_type( struct cons_pointer a, struct cons_pointer b ) {
* @param string the string to test
* @return true if it's the end of a string.
*/
bool end_of_string( struct cons_pointer string ) {
return nilp( string ) ||
pointer2cell( string ).payload.string.character == '\0';
bool end_of_string(struct cons_pointer string)
{
return nilp(string) ||
pointer2cell(string).payload.string.character == '\0';
}
/**
* Deep, and thus expensive, equality: true if these two objects have
* identical structure, else false.
*/
bool equal( struct cons_pointer a, struct cons_pointer b ) {
bool result = eq( a, b );
bool equal(struct cons_pointer a, struct cons_pointer b)
{
bool result = eq(a, b);
if ( !result && same_type( a, b ) ) {
struct cons_space_object *cell_a = &pointer2cell( a );
struct cons_space_object *cell_b = &pointer2cell( b );
if (!result && same_type(a, b))
{
struct cons_space_object *cell_a = &pointer2cell(a);
struct cons_space_object *cell_b = &pointer2cell(b);
switch ( cell_a->tag.value ) {
case CONSTV:
case LAMBDATV:
case NLAMBDATV:
result =
equal( cell_a->payload.cons.car, cell_b->payload.cons.car )
&& equal( cell_a->payload.cons.cdr,
cell_b->payload.cons.cdr );
break;
case KEYTV:
case STRINGTV:
case SYMBOLTV:
/*
switch (cell_a->tag.value)
{
case CONSTV:
case LAMBDATV:
case NLAMBDATV:
result =
equal(cell_a->payload.cons.car, cell_b->payload.cons.car) && equal(cell_a->payload.cons.cdr,
cell_b->payload.cons.cdr);
break;
case KEYTV:
case STRINGTV:
case SYMBOLTV:
/*
* slightly complex because a string may or may not have a '\0'
* cell at the end, but I'll ignore that for now. I think in
* practice only the empty string will.
*/
result =
cell_a->payload.string.character ==
cell_b->payload.string.character
&& ( equal( cell_a->payload.string.cdr,
cell_b->payload.string.cdr )
|| ( end_of_string( cell_a->payload.string.cdr )
&& end_of_string( cell_b->payload.string.
cdr ) ) );
break;
case INTEGERTV:
result =
( cell_a->payload.integer.value ==
cell_b->payload.integer.value ) &&
equal( cell_a->payload.integer.more,
cell_b->payload.integer.more );
break;
case REALTV:
{
double num_a = to_long_double( a );
double num_b = to_long_double( b );
double max =
fabs( num_a ) >
fabs( num_b ) ? fabs( num_a ) : fabs( num_b );
result =
cell_a->payload.string.character ==
cell_b->payload.string.character &&
(equal(cell_a->payload.string.cdr,
cell_b->payload.string.cdr) ||
(end_of_string(cell_a->payload.string.cdr) && end_of_string(cell_b->payload.string.cdr)));
break;
case INTEGERTV:
result =
(cell_a->payload.integer.value ==
cell_b->payload.integer.value) &&
equal(cell_a->payload.integer.more,
cell_b->payload.integer.more);
break;
case RATIOTV:
result = equal_ratio_ratio(a, b);
break;
case REALTV:
{
double num_a = to_long_double(a);
double num_b = to_long_double(b);
double max =
fabs(num_a) >
fabs(num_b)
? fabs(num_a)
: fabs(num_b);
/*
* not more different than one part in a million - close enough
*/
result = fabs( num_a - num_b ) < ( max / 1000000.0 );
}
break;
default:
result = false;
break;
/*
* not more different than one part in a million - close enough
*/
result = fabs(num_a - num_b) < (max / 1000000.0);
}
break;
default:
result = false;
break;
}
/*
* there's only supposed ever to be one T and one NIL cell, so each
* should be caught by eq; equality of vector-space objects is a whole
* other ball game so we won't deal with it now (and indeed may never).
* I'm not certain what equality means for read and write streams, so
* I'll ignore them, too, for now.
*/
}
else if (numberp(a) && numberp(b))
{
if (integerp(a))
{
result = equal_integer_real(a, b);
}
else if (integerp(b))
{
result = equal_integer_real(b, a);
}
}
/*
* there's only supposed ever to be one T and one NIL cell, so each
* should be caught by eq; equality of vector-space objects is a whole
* other ball game so we won't deal with it now (and indeed may never).
* I'm not certain what equality means for read and write streams, so
* I'll ignore them, too, for now.
*/
return result;
}

62
src/ops/exceptions.c
View file

@ -1,62 +0,0 @@
/*
* exceptions.c
*
* This is really, really unfinished and doesn't yet work. One of the really key
* things about exceptions is that the stack frames between the throw and the
* catch should not be derefed, so eval/apply will need to be substantially
* re-written.
*
* (c) 2021 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <ctype.h>
#include <stdbool.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include "consspaceobject.h"
#include "conspage.h"
#include "debug.h"
#include "dump.h"
#include "equal.h"
#include "integer.h"
#include "intern.h"
#include "io.h"
#include "lispops.h"
#include "map.h"
#include "print.h"
#include "read.h"
#include "stack.h"
#include "vectorspace.h"
/**
* OK, the idea here (and I know this is less than perfect) is that the basic `try`
* function in PSSE takes two arguments, the first, `body`, being a list of forms,
* and the second, `catch`, being a catch handler (which is also a list of forms).
* Forms from `body` are evaluated in turn until one returns an exception object,
* or until the list is exhausted. If the list was exhausted, then the value of
* evaluating the last form in `body` is returned. If an exception was encountered,
* then each of the forms in `catch` is evaluated and the value of the last of
* those is returned.
*
* This is experimental. It almost certainly WILL change.
*/
struct cons_pointer lisp_try(struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env)
{
struct cons_pointer result = c_progn(frame, frame_pointer, frame->arg[0], env);
if (loopexitp(result))
{
// TODO: need to put the exception into the environment!
result = c_progn(frame, frame_pointer, frame->arg[1], env);
}
return result;
}

36
src/ops/lispops.c
View file

@ -110,6 +110,37 @@ struct cons_pointer eval_forms( struct stack_frame *frame,
return c_reverse( result);
}
/**
* OK, the idea here (and I know this is less than perfect) is that the basic `try`
* function in PSSE takes two arguments, the first, `body`, being a list of forms,
* and the second, `catch`, being a catch handler (which is also a list of forms).
* Forms from `body` are evaluated in turn until one returns an exception object,
* or until the list is exhausted. If the list was exhausted, then the value of
* evaluating the last form in `body` is returned. If an exception was encountered,
* then each of the forms in `catch` is evaluated and the value of the last of
* those is returned.
*
* This is experimental. It almost certainly WILL change.
*/
struct cons_pointer lisp_try(struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env) {
struct cons_pointer result = c_progn(frame, frame_pointer, frame->arg[0], env);
if (exceptionp(result))
{
// TODO: need to put the exception into the environment!
result = c_progn(frame, frame_pointer, frame->arg[1],
make_cons(
make_cons(c_string_to_lisp_keyword(L"*exception*"),
result),
env));
}
return result;
}
/**
* Return the object list (root namespace).
*
@ -251,6 +282,11 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
dec_ref( result );
result = eval_form( frame, frame_pointer, sexpr, new_env );
if (exceptionp(result))
{
break;
}
}
dec_ref( new_env );