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

Restandardised formatting.

Browse source
This commit is contained in:
Simon Brooke 2021-08-17 16:37:04 +01:00
parent 93d4bd14a0
commit b0a49fb71d
No known key found for this signature in database
GPG key ID: A7A4F18D1D4DF987
29 changed files with 1861 additions and 1604 deletions

21
src/arith/integer.c
View file

@ -218,7 +218,8 @@ struct cons_pointer base_partial( int depth ) {
/** /**
* destructively modify this `partial` by appending this `digit`. * destructively modify this `partial` by appending this `digit`.
*/ */
struct cons_pointer append_digit( struct cons_pointer partial, struct cons_pointer digit) { struct cons_pointer append_digit( struct cons_pointer partial,
struct cons_pointer digit ) {
struct cons_pointer c = partial; struct cons_pointer c = partial;
struct cons_pointer result = partial; struct cons_pointer result = partial;
@ -346,9 +347,12 @@ struct cons_pointer integer_to_string( struct cons_pointer int_pointer,
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
if ( integerp( int_pointer ) ) { if ( integerp( int_pointer ) ) {
struct cons_pointer next = pointer2cell( int_pointer ).payload.integer.more; struct cons_pointer next =
__int128_t accumulator = llabs( pointer2cell( int_pointer ).payload.integer.value ); pointer2cell( int_pointer ).payload.integer.more;
bool is_negative = pointer2cell( int_pointer ).payload.integer.value < 0; __int128_t accumulator =
llabs( pointer2cell( int_pointer ).payload.integer.value );
bool is_negative =
pointer2cell( int_pointer ).payload.integer.value < 0;
int digits = 0; int digits = 0;
if ( accumulator == 0 && nilp( next ) ) { if ( accumulator == 0 && nilp( next ) ) {
@ -356,7 +360,8 @@ struct cons_pointer integer_to_string( struct cons_pointer int_pointer,
} else { } else {
while ( accumulator > 0 || !nilp( next ) ) { while ( accumulator > 0 || !nilp( next ) ) {
if ( accumulator < MAX_INTEGER && !nilp( next ) ) { if ( accumulator < MAX_INTEGER && !nilp( next ) ) {
accumulator += (pointer2cell(next).payload.integer.value << 60); accumulator +=
( pointer2cell( next ).payload.integer.value << 60 );
next = pointer2cell( next ).payload.integer.more; next = pointer2cell( next ).payload.integer.more;
} }
int offset = ( int ) ( accumulator % base ); int offset = ( int ) ( accumulator % base );
@ -400,7 +405,8 @@ bool equal_integer_integer(struct cons_pointer a, struct cons_pointer b) {
struct cons_space_object *cell_a = &pointer2cell( a ); struct cons_space_object *cell_a = &pointer2cell( a );
struct cons_space_object *cell_b = &pointer2cell( b ); struct cons_space_object *cell_b = &pointer2cell( b );
result = cell_a->payload.integer.value == cell_b->payload.integer.value; result =
cell_a->payload.integer.value == cell_b->payload.integer.value;
} }
return result; return result;
@ -413,8 +419,7 @@ bool equal_integer_integer(struct cons_pointer a, struct cons_pointer b) {
bool equal_integer_real( struct cons_pointer a, struct cons_pointer b ) { bool equal_integer_real( struct cons_pointer a, struct cons_pointer b ) {
bool result = false; bool result = false;
if (integerp(a) && realp(b)) if ( integerp( a ) && realp( b ) ) {
{
long double bv = pointer2cell( b ).payload.real.value; long double bv = pointer2cell( b ).payload.real.value;
if ( floor( bv ) == bv ) { if ( floor( bv ) == bv ) {

49
src/arith/peano.c
View file

@ -247,8 +247,7 @@ struct cons_pointer add_2( struct stack_frame *frame,
result = add_integers( arg1, arg2 ); result = add_integers( arg1, arg2 );
break; break;
case RATIOTV: case RATIOTV:
result = result = add_integer_ratio( arg1, arg2 );
add_integer_ratio( arg1, arg2 );
break; break;
case REALTV: case REALTV:
result = result =
@ -268,8 +267,7 @@ struct cons_pointer add_2( struct stack_frame *frame,
result = arg2; result = arg2;
break; break;
case INTEGERTV: case INTEGERTV:
result = result = add_integer_ratio( arg2, arg1 );
add_integer_ratio( arg2, arg1 );
break; break;
case RATIOTV: case RATIOTV:
result = add_ratio_ratio( arg1, arg2 ); result = add_ratio_ratio( arg1, arg2 );
@ -380,9 +378,7 @@ struct cons_pointer multiply_2( struct stack_frame *frame,
result = multiply_integers( arg1, arg2 ); result = multiply_integers( arg1, arg2 );
break; break;
case RATIOTV: case RATIOTV:
result = result = multiply_integer_ratio( arg1, arg2 );
multiply_integer_ratio( arg1,
arg2 );
break; break;
case REALTV: case REALTV:
result = result =
@ -405,13 +401,10 @@ struct cons_pointer multiply_2( struct stack_frame *frame,
result = arg2; result = arg2;
break; break;
case INTEGERTV: case INTEGERTV:
result = result = multiply_integer_ratio( arg2, arg1 );
multiply_integer_ratio( arg2,
arg1 );
break; break;
case RATIOTV: case RATIOTV:
result = result = multiply_ratio_ratio( arg1, arg2 );
multiply_ratio_ratio( arg1, arg2 );
break; break;
case REALTV: case REALTV:
result = result =
@ -564,20 +557,18 @@ struct cons_pointer subtract_2( struct stack_frame *frame,
result = arg2; result = arg2;
break; break;
case INTEGERTV:{ case INTEGERTV:{
struct cons_pointer i = struct cons_pointer i = negative( arg2 );
negative( arg2 );
inc_ref( i ); inc_ref( i );
result = add_integers( arg1, i ); result = add_integers( arg1, i );
dec_ref( i ); dec_ref( i );
} }
break; break;
case RATIOTV:{ case RATIOTV:{
struct cons_pointer tmp = struct cons_pointer tmp = make_ratio( arg1,
make_ratio( arg1, make_integer( 1,
make_integer( 1, NIL ) ); NIL ) );
inc_ref( tmp ); inc_ref( tmp );
result = result = subtract_ratio_ratio( tmp, arg2 );
subtract_ratio_ratio( tmp, arg2 );
dec_ref( tmp ); dec_ref( tmp );
} }
break; break;
@ -599,12 +590,11 @@ struct cons_pointer subtract_2( struct stack_frame *frame,
result = arg2; result = arg2;
break; break;
case INTEGERTV:{ case INTEGERTV:{
struct cons_pointer tmp = struct cons_pointer tmp = make_ratio( arg2,
make_ratio( arg2, make_integer( 1,
make_integer( 1, NIL ) ); NIL ) );
inc_ref( tmp ); inc_ref( tmp );
result = result = subtract_ratio_ratio( arg1, tmp );
subtract_ratio_ratio( arg1, tmp );
dec_ref( tmp ); dec_ref( tmp );
} }
break; break;
@ -696,9 +686,7 @@ struct cons_pointer lisp_divide( struct
struct cons_pointer ratio = struct cons_pointer ratio =
make_ratio( frame->arg[0], one ); make_ratio( frame->arg[0], one );
inc_ref( ratio ); inc_ref( ratio );
result = result = divide_ratio_ratio( ratio, frame->arg[1] );
divide_ratio_ratio( ratio,
frame->arg[1] );
dec_ref( ratio ); dec_ref( ratio );
} }
break; break;
@ -725,17 +713,14 @@ struct cons_pointer lisp_divide( struct
struct cons_pointer ratio = struct cons_pointer ratio =
make_ratio( frame->arg[1], one ); make_ratio( frame->arg[1], one );
inc_ref( ratio ); inc_ref( ratio );
result = result = divide_ratio_ratio( frame->arg[0], ratio );
divide_ratio_ratio( frame->arg[0],
ratio );
dec_ref( ratio ); dec_ref( ratio );
dec_ref( one ); dec_ref( one );
} }
break; break;
case RATIOTV: case RATIOTV:
result = result =
divide_ratio_ratio( frame->arg[0], divide_ratio_ratio( frame->arg[0], frame->arg[1] );
frame->arg[1] );
break; break;
case REALTV: case REALTV:
result = result =

42
src/arith/ratio.c
View file

@ -46,29 +46,23 @@ int64_t least_common_multiple( int64_t m, int64_t n ) {
struct cons_pointer simplify_ratio( struct cons_pointer pointer ) { struct cons_pointer simplify_ratio( struct cons_pointer pointer ) {
struct cons_pointer result = pointer; struct cons_pointer result = pointer;
struct cons_space_object cell = pointer2cell( pointer ); struct cons_space_object cell = pointer2cell( pointer );
struct cons_space_object dividend = pointer2cell(cell.payload.ratio.dividend); struct cons_space_object dividend =
struct cons_space_object divisor = pointer2cell(cell.payload.ratio.divisor); pointer2cell( cell.payload.ratio.dividend );
struct cons_space_object divisor =
pointer2cell( cell.payload.ratio.divisor );
if (divisor.payload.integer.value == 1) if ( divisor.payload.integer.value == 1 ) {
{
result = pointer2cell( pointer ).payload.ratio.dividend; result = pointer2cell( pointer ).payload.ratio.dividend;
} } else {
else if ( ratiop( pointer ) ) {
{
if (ratiop(pointer))
{
int64_t ddrv = dividend.payload.integer.value, int64_t ddrv = dividend.payload.integer.value,
drrv = divisor.payload.integer.value, drrv = divisor.payload.integer.value,
gcd = greatest_common_divisor( ddrv, drrv ); gcd = greatest_common_divisor( ddrv, drrv );
if (gcd > 1) if ( gcd > 1 ) {
{ if ( drrv / gcd == 1 ) {
if (drrv / gcd == 1)
{
result = make_integer( ddrv / gcd, NIL ); result = make_integer( ddrv / gcd, NIL );
} } else {
else
{
result = result =
make_ratio( make_integer( ddrv / gcd, NIL ), make_ratio( make_integer( ddrv / gcd, NIL ),
make_integer( drrv / gcd, NIL ) ); make_integer( drrv / gcd, NIL ) );
@ -181,8 +175,7 @@ struct cons_pointer add_integer_ratio( struct cons_pointer intarg,
( L"Shouldn't happen: bad arg to add_integer_ratio" ), ( L"Shouldn't happen: bad arg to add_integer_ratio" ),
make_cons( intarg, make_cons( intarg,
make_cons( ratarg, make_cons( ratarg,
NIL ) ) ), NIL ) ) ), NIL );
NIL );
} }
return result; return result;
@ -197,10 +190,9 @@ struct cons_pointer add_integer_ratio( struct cons_pointer intarg,
struct cons_pointer divide_ratio_ratio( struct cons_pointer arg1, struct cons_pointer divide_ratio_ratio( struct cons_pointer arg1,
struct cons_pointer arg2 ) { struct cons_pointer arg2 ) {
// TODO: this now has to work if `arg1` is an integer // TODO: this now has to work if `arg1` is an integer
struct cons_pointer i = make_ratio( pointer2cell( arg2 ).payload. struct cons_pointer i =
ratio.divisor, make_ratio( pointer2cell( arg2 ).payload.ratio.divisor,
pointer2cell( arg2 ).payload. pointer2cell( arg2 ).payload.ratio.dividend ), result =
ratio.dividend ), result =
multiply_ratio_ratio( arg1, i ); multiply_ratio_ratio( arg1, i );
dec_ref( i ); dec_ref( i );
@ -333,12 +325,10 @@ struct cons_pointer make_ratio( struct cons_pointer dividend,
/** /**
* True if a and be are identical ratios, else false. * True if a and be are identical ratios, else false.
*/ */
bool equal_ratio_ratio(struct cons_pointer a, struct cons_pointer b) bool equal_ratio_ratio( struct cons_pointer a, struct cons_pointer b ) {
{
bool result = false; bool result = false;
if (ratiop(a) && ratiop(b)) if ( ratiop( a ) && ratiop( b ) ) {
{
struct cons_space_object *cell_a = &pointer2cell( a ); struct cons_space_object *cell_a = &pointer2cell( a );
struct cons_space_object *cell_b = &pointer2cell( b ); struct cons_space_object *cell_b = &pointer2cell( b );

4
src/authorise.c
View file

@ -15,10 +15,10 @@
* TODO: does nothing, yet. What it should do is access a magic value in the * TODO: does nothing, yet. What it should do is access a magic value in the
* runtime environment and check that it is identical to something on this `acl` * runtime environment and check that it is identical to something on this `acl`
*/ */
struct cons_pointer authorised(struct cons_pointer target, struct cons_pointer acl) { struct cons_pointer authorised( struct cons_pointer target,
struct cons_pointer acl ) {
if ( nilp( acl ) ) { if ( nilp( acl ) ) {
acl = pointer2cell( target ).access; acl = pointer2cell( target ).access;
} }
return TRUE; return TRUE;
} }

3
src/authorise.h
View file

@ -10,6 +10,7 @@
#ifndef __psse_authorise_h #ifndef __psse_authorise_h
#define __psse_authorise_h #define __psse_authorise_h
struct cons_pointer authorised(struct cons_pointer target, struct cons_pointer acl); struct cons_pointer authorised( struct cons_pointer target,
struct cons_pointer acl );
#endif #endif

9
src/init.c
View file

@ -85,7 +85,8 @@ void bind_value( wchar_t *name, struct cons_pointer value ) {
} }
void print_banner( ) { void print_banner( ) {
fwprintf(stdout, L"Post-Scarcity Software Environment version %s\n\n", VERSION); fwprintf( stdout, L"Post-Scarcity Software Environment version %s\n\n",
VERSION );
} }
/** /**
@ -95,10 +96,12 @@ void print_banner() {
*/ */
void print_options( FILE * stream ) { void print_options( FILE * stream ) {
fwprintf( stream, L"Expected options are:\n" ); fwprintf( stream, L"Expected options are:\n" );
fwprintf(stream, L"\t-d\tDump memory to standard out at end of run (copious!);\n"); fwprintf( stream,
L"\t-d\tDump memory to standard out at end of run (copious!);\n" );
fwprintf( stream, L"\t-h\tPrint this message and exit;\n" ); fwprintf( stream, L"\t-h\tPrint this message and exit;\n" );
fwprintf( stream, L"\t-p\tShow a prompt (default is no prompt);\n" ); fwprintf( stream, L"\t-p\tShow a prompt (default is no prompt);\n" );
fwprintf(stream, L"\t-v LEVEL\n\t\tSet verbosity to the specified level (0...512)\n"); fwprintf( stream,
L"\t-v LEVEL\n\t\tSet verbosity to the specified level (0...512)\n" );
fwprintf( stream, L"\t\tWhere bits are interpreted as follows:\n" ); fwprintf( stream, L"\t\tWhere bits are interpreted as follows:\n" );
fwprintf( stream, L"\t\t1\tALLOC;\n" ); fwprintf( stream, L"\t\t1\tALLOC;\n" );
fwprintf( stream, L"\t\t2\tARITH;\n" ); fwprintf( stream, L"\t\t2\tARITH;\n" );

20
src/io/io.c
View file

@ -281,8 +281,7 @@ struct cons_pointer add_meta_time( struct cons_pointer meta, wchar_t *key,
strftime( datestring, strftime( datestring,
sizeof( datestring ), sizeof( datestring ),
nl_langinfo( D_T_FMT ), nl_langinfo( D_T_FMT ), localtime( value ) );
localtime( value ) );
return add_meta_string( meta, key, datestring ); return add_meta_string( meta, key, datestring );
} }
@ -442,18 +441,21 @@ lisp_open( struct stack_frame *frame, struct cons_pointer frame_pointer,
debug_printf( DEBUG_IO, debug_printf( DEBUG_IO,
L"lisp_open: stream @ %ld, stream type = %d, stream handle = %ld\n", L"lisp_open: stream @ %ld, stream type = %d, stream handle = %ld\n",
(long int) &stream, (int)stream->type, (long int)stream->handle.file); ( long int ) &stream, ( int ) stream->type,
( long int ) stream->handle.file );
switch ( stream->type ) { switch ( stream->type ) {
case CFTYPE_NONE: case CFTYPE_NONE:
return make_exception( return
c_string_to_lisp_string( L"Could not open stream"), make_exception( c_string_to_lisp_string
( L"Could not open stream" ),
frame_pointer ); frame_pointer );
break; break;
case CFTYPE_FILE: case CFTYPE_FILE:
if ( stream->handle.file == NULL ) { if ( stream->handle.file == NULL ) {
return make_exception( return
c_string_to_lisp_string( L"Could not open file"), make_exception( c_string_to_lisp_string
( L"Could not open file" ),
frame_pointer ); frame_pointer );
} }
break; break;
@ -501,8 +503,8 @@ lisp_read_char( struct stack_frame *frame, struct cons_pointer frame_pointer,
if ( readp( frame->arg[0] ) ) { if ( readp( frame->arg[0] ) ) {
result = result =
make_string( url_fgetwc make_string( url_fgetwc
( pointer2cell( frame->arg[0] ).payload. ( pointer2cell( frame->arg[0] ).payload.stream.
stream.stream ), NIL ); stream ), NIL );
} }
return result; return result;

27
src/io/read.c
View file

@ -134,9 +134,11 @@ struct cons_pointer read_continuation( struct stack_frame *frame,
} else if ( iswblank( next ) ) { } else if ( iswblank( next ) ) {
/* dotted pair. \todo this isn't right, we /* dotted pair. \todo this isn't right, we
* really need to backtrack up a level. */ * really need to backtrack up a level. */
result = read_continuation( frame, frame_pointer, input, result =
read_continuation( frame, frame_pointer, input,
url_fgetwc( input ) ); url_fgetwc( input ) );
debug_print( L"read_continuation: dotted pair; read cdr ", debug_print
( L"read_continuation: dotted pair; read cdr ",
DEBUG_IO ); DEBUG_IO );
} else { } else {
read_symbol_or_key( input, SYMBOLTV, c ); read_symbol_or_key( input, SYMBOLTV, c );
@ -298,8 +300,7 @@ struct cons_pointer read_list( struct stack_frame *frame,
/* skip whitespace */ /* skip whitespace */
for ( c = url_fgetwc( input ); for ( c = url_fgetwc( input );
iswblank( c ) || iswcntrl( c ); iswblank( c ) || iswcntrl( c ); c = url_fgetwc( input ) );
c = url_fgetwc( input ));
if ( c == L'.' ) { if ( c == L'.' ) {
/* might be a dotted pair; indeed, if we rule out numbers with /* might be a dotted pair; indeed, if we rule out numbers with
@ -309,12 +310,10 @@ struct cons_pointer read_list( struct stack_frame *frame,
make_cons( car, make_cons( car,
c_car( read_list( frame, c_car( read_list( frame,
frame_pointer, frame_pointer,
input, input, url_fgetwc( input ) ) ) );
url_fgetwc( input ) ) ) );
} else { } else {
result = result =
make_cons( car, make_cons( car, read_list( frame, frame_pointer, input, c ) );
read_list( frame, frame_pointer, input, c ) );
} }
} else { } else {
debug_print( L"End of list detected\n", DEBUG_IO ); debug_print( L"End of list detected\n", DEBUG_IO );
@ -327,7 +326,8 @@ struct cons_pointer read_map( struct stack_frame *frame,
struct cons_pointer frame_pointer, struct cons_pointer frame_pointer,
URL_FILE * input, wint_t initial ) { URL_FILE * input, wint_t initial ) {
// set write ACL to true whilst creating to prevent GC churn // set write ACL to true whilst creating to prevent GC churn
struct cons_pointer result = make_hashmap( DFLT_HASHMAP_BUCKETS, NIL, TRUE ); struct cons_pointer result =
make_hashmap( DFLT_HASHMAP_BUCKETS, NIL, TRUE );
wint_t c = initial; wint_t c = initial;
while ( c != L'}' ) { while ( c != L'}' ) {
@ -336,16 +336,15 @@ struct cons_pointer read_map( struct stack_frame *frame,
/* skip whitespace */ /* skip whitespace */
for ( c = url_fgetwc( input ); iswblank( c ) || iswcntrl( c ); for ( c = url_fgetwc( input ); iswblank( c ) || iswcntrl( c );
c = url_fgetwc( input ) ) c = url_fgetwc( input ) );
;
struct cons_pointer value = struct cons_pointer value =
read_continuation( frame, frame_pointer, input, c ); read_continuation( frame, frame_pointer, input, c );
/* skip commaa and whitespace at this point. */ /* skip commaa and whitespace at this point. */
for ( c = url_fgetwc( input ); c == L',' || iswblank( c ) || iswcntrl( c ); for ( c = url_fgetwc( input );
c = url_fgetwc( input ) ) c == L',' || iswblank( c ) || iswcntrl( c );
; c = url_fgetwc( input ) );
result = hashmap_put( result, key, value ); result = hashmap_put( result, key, value );
} }

22
src/memory/consspaceobject.c
View file

@ -102,11 +102,13 @@ struct cons_pointer c_type( struct cons_pointer pointer ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
struct cons_space_object cell = pointer2cell( pointer ); struct cons_space_object cell = pointer2cell( pointer );
if ( strncmp( (char *)&cell.tag.bytes, VECTORPOINTTAG, TAGLENGTH ) == 0 ) { if ( strncmp( ( char * ) &cell.tag.bytes, VECTORPOINTTAG, TAGLENGTH ) ==
0 ) {
struct vector_space_object *vec = pointer_to_vso( pointer ); struct vector_space_object *vec = pointer_to_vso( pointer );
for ( int i = TAGLENGTH - 1; i >= 0; i-- ) { for ( int i = TAGLENGTH - 1; i >= 0; i-- ) {
result = make_string( (wchar_t)vec->header.tag.bytes[i], result ); result =
make_string( ( wchar_t ) vec->header.tag.bytes[i], result );
} }
} else { } else {
for ( int i = TAGLENGTH - 1; i >= 0; i-- ) { for ( int i = TAGLENGTH - 1; i >= 0; i-- ) {
@ -276,25 +278,19 @@ struct cons_pointer make_nlambda( struct cons_pointer args,
* *
* returns 0 for things which are not string like. * returns 0 for things which are not string like.
*/ */
uint32_t calculate_hash(wint_t c, struct cons_pointer ptr) uint32_t calculate_hash( wint_t c, struct cons_pointer ptr ) {
{
struct cons_space_object *cell = &pointer2cell( ptr ); struct cons_space_object *cell = &pointer2cell( ptr );
uint32_t result = 0; uint32_t result = 0;
switch (cell->tag.value) switch ( cell->tag.value ) {
{
case KEYTV: case KEYTV:
case STRINGTV: case STRINGTV:
case SYMBOLTV: case SYMBOLTV:
if (nilp(cell->payload.string.cdr)) if ( nilp( cell->payload.string.cdr ) ) {
{
result = ( uint32_t ) c; result = ( uint32_t ) c;
} } else {
else
{
result = ( ( uint32_t ) c * result = ( ( uint32_t ) c *
cell->payload.string.hash) & cell->payload.string.hash ) & 0xffffffff;
0xffffffff;
} }
break; break;
} }

33
src/memory/dump.c
View file

@ -46,8 +46,7 @@ void dump_string_cell( URL_FILE * output, wchar_t *prefix,
cell.payload.string.character, cell.payload.string.character,
cell.payload.string.hash, cell.payload.string.hash,
cell.payload.string.cdr.page, cell.payload.string.cdr.page,
cell.payload.string.cdr.offset, cell.payload.string.cdr.offset, cell.count );
cell.count );
url_fwprintf( output, L"\t\t value: " ); url_fwprintf( output, L"\t\t value: " );
print( output, pointer ); print( output, pointer );
url_fwprintf( output, L"\n" ); url_fwprintf( output, L"\n" );
@ -68,9 +67,10 @@ void dump_object( URL_FILE *output, struct cons_pointer pointer ) {
url_fwprintf( output, url_fwprintf( output,
L"\t\tCons cell: car at page %d offset %d, cdr at page %d " L"\t\tCons cell: car at page %d offset %d, cdr at page %d "
L"offset %d, count %u :", L"offset %d, count %u :",
cell.payload.cons.car.page, cell.payload.cons.car.offset, cell.payload.cons.car.page,
cell.payload.cons.cdr.page, cell.payload.cons.cdr.offset, cell.payload.cons.car.offset,
cell.count ); cell.payload.cons.cdr.page,
cell.payload.cons.cdr.offset, cell.count );
print( output, pointer ); print( output, pointer );
url_fputws( L"\n", output ); url_fputws( L"\n", output );
break; break;
@ -79,8 +79,10 @@ void dump_object( URL_FILE *output, struct cons_pointer pointer ) {
dump_stack_trace( output, pointer ); dump_stack_trace( output, pointer );
break; break;
case FREETV: case FREETV:
url_fwprintf( output, L"\t\tFree cell: next at page %d offset %d\n", url_fwprintf( output,
cell.payload.cons.cdr.page, cell.payload.cons.cdr.offset ); L"\t\tFree cell: next at page %d offset %d\n",
cell.payload.cons.cdr.page,
cell.payload.cons.cdr.offset );
break; break;
case INTEGERTV: case INTEGERTV:
url_fwprintf( output, L"\t\tInteger cell: value %ld, count %u\n", url_fwprintf( output, L"\t\tInteger cell: value %ld, count %u\n",
@ -110,11 +112,12 @@ void dump_object( URL_FILE *output, struct cons_pointer pointer ) {
url_fputws( L"\n", output ); url_fputws( L"\n", output );
break; break;
case RATIOTV: case RATIOTV:
url_fwprintf( url_fwprintf( output,
output, L"\t\tRational cell: value %ld/%ld, count %u\n", L"\t\tRational cell: value %ld/%ld, count %u\n",
pointer2cell( cell.payload.ratio.dividend ).payload.integer.value, pointer2cell( cell.payload.ratio.dividend ).payload.
pointer2cell( cell.payload.ratio.divisor ).payload.integer.value, integer.value,
cell.count ); pointer2cell( cell.payload.ratio.divisor ).payload.
integer.value, cell.count );
break; break;
case READTV: case READTV:
url_fputws( L"\t\tInput stream; metadata: ", output ); url_fputws( L"\t\tInput stream; metadata: ", output );
@ -134,7 +137,8 @@ void dump_object( URL_FILE *output, struct cons_pointer pointer ) {
case TRUETV: case TRUETV:
break; break;
case VECTORPOINTTV:{ case VECTORPOINTTV:{
url_fwprintf( output, L"\t\tPointer to vector-space object at %p\n", url_fwprintf( output,
L"\t\tPointer to vector-space object at %p\n",
cell.payload.vectorp.address ); cell.payload.vectorp.address );
struct vector_space_object *vso = cell.payload.vectorp.address; struct vector_space_object *vso = cell.payload.vectorp.address;
url_fwprintf( output, url_fwprintf( output,
@ -151,7 +155,8 @@ void dump_object( URL_FILE *output, struct cons_pointer pointer ) {
dump_map( output, pointer ); dump_map( output, pointer );
break; break;
} }
} break; }
break;
case WRITETV: case WRITETV:
url_fputws( L"\t\tOutput stream; metadata: ", output ); url_fputws( L"\t\tOutput stream; metadata: ", output );
print( output, cell.payload.stream.meta ); print( output, cell.payload.stream.meta );

41
src/memory/hashmap.c
View file

@ -43,8 +43,7 @@ uint32_t sxhash( struct cons_pointer ptr ) {
* Get the hash value for the cell indicated by this `ptr`; currently only * Get the hash value for the cell indicated by this `ptr`; currently only
* implemented for string like things and integers. * implemented for string like things and integers.
*/ */
uint32_t get_hash(struct cons_pointer ptr) uint32_t get_hash( struct cons_pointer ptr ) {
{
struct cons_space_object *cell = &pointer2cell( ptr ); struct cons_space_object *cell = &pointer2cell( ptr );
uint32_t result = 0; uint32_t result = 0;
@ -85,8 +84,8 @@ void free_hashmap( struct cons_pointer pointer ) {
for ( int i = 0; i < vso->payload.hashmap.n_buckets; i++ ) { for ( int i = 0; i < vso->payload.hashmap.n_buckets; i++ ) {
if ( !nilp( vso->payload.hashmap.buckets[i] ) ) { if ( !nilp( vso->payload.hashmap.buckets[i] ) ) {
debug_printf( DEBUG_ALLOC, debug_printf( DEBUG_ALLOC,
L"Decrementing bucket [%d] of hashmap at 0x%lx\n", i, L"Decrementing bucket [%d] of hashmap at 0x%lx\n",
cell->payload.vectorp.address ); i, cell->payload.vectorp.address );
dec_ref( vso->payload.hashmap.buckets[i] ); dec_ref( vso->payload.hashmap.buckets[i] );
} }
} }
@ -100,8 +99,7 @@ void free_hashmap( struct cons_pointer pointer ) {
*/ */
struct cons_pointer lisp_get_hash( struct stack_frame *frame, struct cons_pointer lisp_get_hash( struct stack_frame *frame,
struct cons_pointer frame_pointer, struct cons_pointer frame_pointer,
struct cons_pointer env) struct cons_pointer env ) {
{
return make_integer( get_hash( frame->arg[0] ), NIL ); return make_integer( get_hash( frame->arg[0] ), NIL );
} }
@ -113,7 +111,8 @@ struct cons_pointer make_hashmap( uint32_t n_buckets,
struct cons_pointer hash_fn, struct cons_pointer hash_fn,
struct cons_pointer write_acl ) { struct cons_pointer write_acl ) {
struct cons_pointer result = struct cons_pointer result =
make_vso( HASHTV, ( sizeof( struct cons_pointer ) * ( n_buckets + 1 ) ) + make_vso( HASHTV,
( sizeof( struct cons_pointer ) * ( n_buckets + 1 ) ) +
( sizeof( uint32_t ) * 2 ) ); ( sizeof( uint32_t ) * 2 ) );
struct hashmap_payload *payload = struct hashmap_payload *payload =
@ -149,10 +148,10 @@ struct cons_pointer lisp_make_hashmap( struct stack_frame *frame,
if ( integerp( frame->arg[0] ) ) { if ( integerp( frame->arg[0] ) ) {
n = to_long_int( frame->arg[0] ) % UINT32_MAX; n = to_long_int( frame->arg[0] ) % UINT32_MAX;
} else if ( !nilp( frame->arg[0] ) ) { } else if ( !nilp( frame->arg[0] ) ) {
result = make_exception( result =
c_string_to_lisp_string( L"First arg to `hashmap`, if passed, must " make_exception( c_string_to_lisp_string
L"be an integer or `nil`.`" ), ( L"First arg to `hashmap`, if passed, must "
NIL ); L"be an integer or `nil`.`" ), NIL );
} }
} }
if ( frame->args > 1 ) { if ( frame->args > 1 ) {
@ -177,11 +176,13 @@ struct cons_pointer lisp_make_hashmap( struct stack_frame *frame,
uint32_t bucket_no = uint32_t bucket_no =
get_hash( key ) % get_hash( key ) %
( (struct hashmap_payload *)&( map->payload ) )->n_buckets; ( ( struct hashmap_payload * ) &( map->payload ) )->
n_buckets;
map->payload.hashmap.buckets[bucket_no] = map->payload.hashmap.buckets[bucket_no] =
inc_ref( make_cons( make_cons( key, val ), inc_ref( make_cons( make_cons( key, val ),
map->payload.hashmap.buckets[bucket_no] )); map->payload.hashmap.
buckets[bucket_no] ) );
} }
} }
} }
@ -205,7 +206,9 @@ struct cons_pointer clone_hashmap( struct cons_pointer ptr ) {
if ( from != NULL ) { if ( from != NULL ) {
struct hashmap_payload from_pl = from->payload.hashmap; struct hashmap_payload from_pl = from->payload.hashmap;
result = make_hashmap( from_pl.n_buckets, from_pl.hash_fn, from_pl.write_acl ); result =
make_hashmap( from_pl.n_buckets, from_pl.hash_fn,
from_pl.write_acl );
struct vector_space_object *to = pointer_to_vso( result ); struct vector_space_object *to = pointer_to_vso( result );
struct hashmap_payload to_pl = to->payload.hashmap; struct hashmap_payload to_pl = to->payload.hashmap;
@ -237,9 +240,7 @@ struct cons_pointer hashmap_put( struct cons_pointer mapp,
mapp = clone_hashmap( mapp ); mapp = clone_hashmap( mapp );
map = pointer_to_vso( mapp ); map = pointer_to_vso( mapp );
} }
uint32_t bucket_no = uint32_t bucket_no = get_hash( key ) % map->payload.hashmap.n_buckets;
get_hash( key ) %
map->payload.hashmap.n_buckets;
map->payload.hashmap.buckets[bucket_no] = map->payload.hashmap.buckets[bucket_no] =
inc_ref( make_cons( make_cons( key, val ), inc_ref( make_cons( make_cons( key, val ),
@ -323,8 +324,7 @@ struct cons_pointer hashmap_keys( struct cons_pointer mapp) {
for ( int i = 0; i < map->payload.hashmap.n_buckets; i++ ) { for ( int i = 0; i < map->payload.hashmap.n_buckets; i++ ) {
for ( struct cons_pointer c = map->payload.hashmap.buckets[i]; for ( struct cons_pointer c = map->payload.hashmap.buckets[i];
!nilp(c); !nilp( c ); c = c_cdr( c ) ) {
c = c_cdr(c)) {
result = make_cons( c_car( c_car( c ) ), result ); result = make_cons( c_car( c_car( c ) ), result );
} }
@ -341,7 +341,8 @@ struct cons_pointer lisp_hashmap_keys( struct stack_frame *frame,
} }
void dump_map( URL_FILE * output, struct cons_pointer pointer ) { void dump_map( URL_FILE * output, struct cons_pointer pointer ) {
struct hashmap_payload *payload = &pointer_to_vso( pointer )->payload.hashmap; struct hashmap_payload *payload =
&pointer_to_vso( pointer )->payload.hashmap;
url_fwprintf( output, L"Hashmap with %d buckets:\n", payload->n_buckets ); url_fwprintf( output, L"Hashmap with %d buckets:\n", payload->n_buckets );
url_fwprintf( output, L"\tHash function: " ); url_fwprintf( output, L"\tHash function: " );
print( output, payload->hash_fn ); print( output, payload->hash_fn );

870
src/memory/lookup3.c
View file

File diff suppressed because it is too large Load diff

5
src/memory/lookup3.h
View file

@ -11,9 +11,6 @@
#ifndef __lookup3_h #ifndef __lookup3_h
#define __lookup3_h #define __lookup3_h
uint32_t hashword( uint32_t hashword( const uint32_t * k, size_t length, uint32_t initval );
const uint32_t *k,
size_t length,
uint32_t initval);
#endif #endif

6
src/memory/vectorspace.h
View file

@ -86,8 +86,7 @@ struct vector_space_header {
* i.e. either an assoc list or a further hashmap. * i.e. either an assoc list or a further hashmap.
*/ */
struct hashmap_payload { struct hashmap_payload {
struct cons_pointer struct cons_pointer hash_fn; /* function for hashing values in this hashmap, or `NIL` to use
hash_fn; /* function for hashing values in this hashmap, or `NIL` to use
the default hashing function */ the default hashing function */
struct cons_pointer write_acl; /* it seems to me that it is likely that the struct cons_pointer write_acl; /* it seems to me that it is likely that the
* principal difference between a hashmap and a * principal difference between a hashmap and a
@ -95,8 +94,7 @@ struct hashmap_payload {
* of `NIL`, meaning not writeable by anyone */ * of `NIL`, meaning not writeable by anyone */
uint32_t n_buckets; /* number of hash buckets */ uint32_t n_buckets; /* number of hash buckets */
uint32_t unused; /* for word alignment and possible later expansion */ uint32_t unused; /* for word alignment and possible later expansion */
struct cons_pointer struct cons_pointer buckets[]; /* actual hash buckets, which should be `NIL`
buckets[]; /* actual hash buckets, which should be `NIL`
* or assoc lists or (possibly) further hashmaps. */ * or assoc lists or (possibly) further hashmaps. */
}; };

39
src/ops/equal.c
View file

@ -20,8 +20,7 @@
* Shallow, and thus cheap, equality: true if these two objects are * Shallow, and thus cheap, equality: true if these two objects are
* the same object, else false. * the same object, else false.
*/ */
bool eq(struct cons_pointer a, struct cons_pointer b) bool eq( struct cons_pointer a, struct cons_pointer b ) {
{
return ( ( a.page == b.page ) && ( a.offset == b.offset ) ); return ( ( a.page == b.page ) && ( a.offset == b.offset ) );
} }
@ -32,8 +31,7 @@ bool eq(struct cons_pointer a, struct cons_pointer b)
* @return true if the objects at these two cons pointers have the same tag, * @return true if the objects at these two cons pointers have the same tag,
* else false. * else false.
*/ */
bool same_type(struct cons_pointer a, struct cons_pointer 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_a = &pointer2cell( a );
struct cons_space_object *cell_b = &pointer2cell( b ); struct cons_space_object *cell_b = &pointer2cell( b );
@ -45,8 +43,7 @@ bool same_type(struct cons_pointer a, struct cons_pointer b)
* @param string the string to test * @param string the string to test
* @return true if it's the end of a string. * @return true if it's the end of a string.
*/ */
bool end_of_string(struct cons_pointer string) bool end_of_string( struct cons_pointer string ) {
{
return nilp( string ) || return nilp( string ) ||
pointer2cell( string ).payload.string.character == '\0'; pointer2cell( string ).payload.string.character == '\0';
} }
@ -55,17 +52,14 @@ bool end_of_string(struct cons_pointer string)
* Deep, and thus expensive, equality: true if these two objects have * Deep, and thus expensive, equality: true if these two objects have
* identical structure, else false. * identical structure, else false.
*/ */
bool equal(struct cons_pointer a, struct cons_pointer b) bool equal( struct cons_pointer a, struct cons_pointer b ) {
{
bool result = eq( a, b ); bool result = eq( a, b );
if (!result && same_type(a, b)) if ( !result && same_type( a, b ) ) {
{
struct cons_space_object *cell_a = &pointer2cell( a ); struct cons_space_object *cell_a = &pointer2cell( a );
struct cons_space_object *cell_b = &pointer2cell( b ); struct cons_space_object *cell_b = &pointer2cell( b );
switch (cell_a->tag.value) switch ( cell_a->tag.value ) {
{
case CONSTV: case CONSTV:
case LAMBDATV: case LAMBDATV:
case NLAMBDATV: case NLAMBDATV:
@ -73,7 +67,8 @@ bool equal(struct cons_pointer a, struct cons_pointer b)
* structures can be of indefinite extent. It *must* be done by * structures can be of indefinite extent. It *must* be done by
* iteration (and even that is problematic) */ * iteration (and even that is problematic) */
result = result =
equal(cell_a->payload.cons.car, cell_b->payload.cons.car) && equal(cell_a->payload.cons.cdr, equal( cell_a->payload.cons.car, cell_b->payload.cons.car )
&& equal( cell_a->payload.cons.cdr,
cell_b->payload.cons.cdr ); cell_b->payload.cons.cdr );
break; break;
case KEYTV: case KEYTV:
@ -91,7 +86,8 @@ bool equal(struct cons_pointer a, struct cons_pointer b)
cell_b->payload.string.character && cell_b->payload.string.character &&
( equal( cell_a->payload.string.cdr, ( equal( cell_a->payload.string.cdr,
cell_b->payload.string.cdr ) || cell_b->payload.string.cdr ) ||
(end_of_string(cell_a->payload.string.cdr) && end_of_string(cell_b->payload.string.cdr))); ( end_of_string( cell_a->payload.string.cdr )
&& end_of_string( cell_b->payload.string.cdr ) ) );
break; break;
case INTEGERTV: case INTEGERTV:
result = result =
@ -107,9 +103,7 @@ bool equal(struct cons_pointer a, struct cons_pointer b)
{ {
double num_a = to_long_double( a ); double num_a = to_long_double( a );
double num_b = to_long_double( b ); double num_b = to_long_double( b );
double max = double max = fabs( num_a ) > fabs( num_b )
fabs(num_a) >
fabs(num_b)
? fabs( num_a ) ? fabs( num_a )
: fabs( num_b ); : fabs( num_b );
@ -123,15 +117,10 @@ bool equal(struct cons_pointer a, struct cons_pointer b)
result = false; result = false;
break; break;
} }
} } else if ( numberp( a ) && numberp( b ) ) {
else if (numberp(a) && numberp(b)) if ( integerp( a ) ) {
{
if (integerp(a))
{
result = equal_integer_real( a, b ); result = equal_integer_real( a, b );
} } else if ( integerp( b ) ) {
else if (integerp(b))
{
result = equal_integer_real( b, a ); result = equal_integer_real( b, a );
} }
} }

5
src/ops/intern.c
View file

@ -110,7 +110,9 @@ struct cons_pointer c_assoc( struct cons_pointer key,
} else if ( hashmapp( store ) ) { } else if ( hashmapp( store ) ) {
result = hashmap_get( store, key ); result = hashmap_get( store, key );
} else { } else {
result = throw_exception(c_string_to_lisp_string(L"Store is of unknown type"), NIL); result =
throw_exception( c_string_to_lisp_string
( L"Store is of unknown type" ), NIL );
} }
debug_print( L"c_assoc returning ", DEBUG_BIND ); debug_print( L"c_assoc returning ", DEBUG_BIND );
@ -195,4 +197,3 @@ intern( struct cons_pointer key, struct cons_pointer environment ) {
return result; return result;
} }

31
src/ops/lispops.c
View file

@ -124,16 +124,15 @@ struct cons_pointer eval_forms( struct stack_frame *frame,
struct cons_pointer lisp_try( struct stack_frame *frame, struct cons_pointer lisp_try( struct stack_frame *frame,
struct cons_pointer frame_pointer, struct cons_pointer frame_pointer,
struct cons_pointer env ) { struct cons_pointer env ) {
struct cons_pointer result = c_progn(frame, frame_pointer, frame->arg[0], env); struct cons_pointer result =
c_progn( frame, frame_pointer, frame->arg[0], env );
if (exceptionp(result)) if ( exceptionp( result ) ) {
{
// TODO: need to put the exception into the environment! // TODO: need to put the exception into the environment!
result = c_progn( frame, frame_pointer, frame->arg[1], result = c_progn( frame, frame_pointer, frame->arg[1],
make_cons( make_cons( make_cons
make_cons(c_string_to_lisp_keyword(L"*exception*"), ( c_string_to_lisp_keyword
result), ( L"*exception*" ), result ), env ) );
env));
} }
return result; return result;
@ -282,8 +281,7 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
result = eval_form( frame, frame_pointer, sexpr, new_env ); result = eval_form( frame, frame_pointer, sexpr, new_env );
if (exceptionp(result)) if ( exceptionp( result ) ) {
{
break; break;
} }
} }
@ -381,9 +379,10 @@ struct cons_pointer
/* \todo: if arg[0] is a CONS, treat it as a path */ /* \todo: if arg[0] is a CONS, treat it as a path */
result = c_assoc( eval_form( frame, result = c_assoc( eval_form( frame,
frame_pointer, frame_pointer,
c_car( c_cdr( frame->arg[0])), c_car( c_cdr
env), ( frame->
fn_pointer); arg[0] ) ),
env ), fn_pointer );
break; break;
} }
break; break;
@ -414,8 +413,9 @@ struct cons_pointer
result = next_pointer; result = next_pointer;
} else { } else {
result = result =
( *fn_cell.payload.special. ( *fn_cell.payload.
executable ) ( get_stack_frame( next_pointer ), special.executable ) ( get_stack_frame
( next_pointer ),
next_pointer, env ); next_pointer, env );
debug_print( L"Special form returning: ", DEBUG_EVAL ); debug_print( L"Special form returning: ", DEBUG_EVAL );
debug_print_object( result, DEBUG_EVAL ); debug_print_object( result, DEBUG_EVAL );
@ -781,7 +781,8 @@ lisp_cdr( struct stack_frame *frame, struct cons_pointer frame_pointer,
* @param env my environment (ignored). * @param env my environment (ignored).
* @return the length of `any`, if it is a sequence, or zero otherwise. * @return the length of `any`, if it is a sequence, or zero otherwise.
*/ */
struct cons_pointer lisp_length( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer lisp_length( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ) { struct cons_pointer env ) {
return make_integer( c_length( frame->arg[0] ), NIL ); return make_integer( c_length( frame->arg[0] ), NIL );
} }

9
src/time/psse_time.c
View file

@ -28,7 +28,8 @@
* PSSE Lisp epoch is 14 Bn years, or 441,806,400,000,000,000 seconds, before * PSSE Lisp epoch is 14 Bn years, or 441,806,400,000,000,000 seconds, before
* the UNIX epoch; the value in microseconds will break the C reader. * the UNIX epoch; the value in microseconds will break the C reader.
*/ */
unsigned __int128 epoch_offset = ((__int128)(seconds_per_year * 1000000000L) * unsigned __int128 epoch_offset =
( ( __int128 ) ( seconds_per_year * 1000000000L ) *
( __int128 ) ( 14L * 1000000000L ) ); ( __int128 ) ( 14L * 1000000000L ) );
/** /**
@ -60,7 +61,8 @@ struct cons_pointer make_time( struct cons_pointer integer_or_nil) {
struct cons_space_object *cell = &pointer2cell( pointer ); struct cons_space_object *cell = &pointer2cell( pointer );
if ( integerp( integer_or_nil ) ) { if ( integerp( integer_or_nil ) ) {
cell->payload.time.value = pointer2cell(integer_or_nil).payload.integer.value; cell->payload.time.value =
pointer2cell( integer_or_nil ).payload.integer.value;
// \todo: if integer is a bignum, deal with it. // \todo: if integer is a bignum, deal with it.
} else { } else {
cell->payload.time.value = unix_time_to_lisp_time( time( NULL ) ); cell->payload.time.value = unix_time_to_lisp_time( time( NULL ) );
@ -82,7 +84,8 @@ struct cons_pointer make_time( struct cons_pointer integer_or_nil) {
* is that number of microseconds after the notional big bang; else the current * is that number of microseconds after the notional big bang; else the current
* time. * time.
*/ */
struct cons_pointer lisp_time( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer lisp_time( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ) { struct cons_pointer env ) {
return make_time( frame->arg[0] ); return make_time( frame->arg[0] );
} }

3
src/time/psse_time.h
View file

@ -13,7 +13,8 @@
#define _GNU_SOURCE #define _GNU_SOURCE
#include "consspaceobject.h" #include "consspaceobject.h"
struct cons_pointer lisp_time( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer lisp_time( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );
struct cons_pointer time_to_string( struct cons_pointer pointer ); struct cons_pointer time_to_string( struct cons_pointer pointer );