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
Show stats Download patch file Download diff file Expand all files Collapse all files

83
src/arith/integer.c
View file

@ -218,18 +218,19 @@ 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;
if (nilp( partial)) { if ( nilp( partial ) ) {
result = digit; result = digit;
} else { } else {
while ( !nilp( pointer2cell(c).payload.integer.more)) { while ( !nilp( pointer2cell( c ).payload.integer.more ) ) {
c = pointer2cell(c).payload.integer.more; c = pointer2cell( c ).payload.integer.more;
} }
(&pointer2cell(c))->payload.integer.more = digit; ( &pointer2cell( c ) )->payload.integer.more = digit;
} }
return result; return result;
} }
@ -248,8 +249,8 @@ struct cons_pointer append_digit( struct cons_pointer partial, struct cons_point
* @param b an integer. * @param b an integer.
*/ */
struct cons_pointer multiply_integers( struct cons_pointer a, struct cons_pointer multiply_integers( struct cons_pointer a,
struct cons_pointer b ) { struct cons_pointer b ) {
struct cons_pointer result = make_integer( 0, NIL); struct cons_pointer result = make_integer( 0, NIL );
bool neg = is_negative( a ) != is_negative( b ); bool neg = is_negative( a ) != is_negative( b );
bool is_first_b = true; bool is_first_b = true;
int i = 0; int i = 0;
@ -264,7 +265,7 @@ struct cons_pointer multiply_integers( struct cons_pointer a,
/* for each digit in a, starting with the least significant (ai) */ /* for each digit in a, starting with the least significant (ai) */
for ( struct cons_pointer ai = a; !nilp( ai ); for ( struct cons_pointer ai = a; !nilp( ai );
ai = pointer2cell(ai).payload.integer.more) { ai = pointer2cell( ai ).payload.integer.more ) {
/* set carry to 0 */ /* set carry to 0 */
__int128_t carry = 0; __int128_t carry = 0;
@ -274,41 +275,41 @@ struct cons_pointer multiply_integers( struct cons_pointer a,
/* for each digit in b, starting with the least significant (bj) */ /* for each digit in b, starting with the least significant (bj) */
for ( struct cons_pointer bj = b; !nilp( bj ); for ( struct cons_pointer bj = b; !nilp( bj );
bj = pointer2cell(bj).payload.integer.more) { bj = pointer2cell( bj ).payload.integer.more ) {
debug_printf( DEBUG_ARITH, debug_printf( DEBUG_ARITH,
L"multiply_integers: a[i] = %Ld, b[j] = %Ld, i = %d\n", L"multiply_integers: a[i] = %Ld, b[j] = %Ld, i = %d\n",
pointer2cell(ai).payload.integer.value, pointer2cell( ai ).payload.integer.value,
pointer2cell(bj).payload.integer.value, i); pointer2cell( bj ).payload.integer.value, i );
/* multiply ai with bj and add the carry, resulting in a /* multiply ai with bj and add the carry, resulting in a
* value xj which may exceed one digit */ * value xj which may exceed one digit */
__int128_t xj = pointer2cell(ai).payload.integer.value * __int128_t xj = pointer2cell( ai ).payload.integer.value *
pointer2cell(bj).payload.integer.value; pointer2cell( bj ).payload.integer.value;
xj += carry; xj += carry;
/* if xj exceeds one digit, break it into the digit dj and /* if xj exceeds one digit, break it into the digit dj and
* the carry */ * the carry */
carry = xj >> 60; carry = xj >> 60;
struct cons_pointer dj = make_integer( xj & MAX_INTEGER, NIL); struct cons_pointer dj = make_integer( xj & MAX_INTEGER, NIL );
/* destructively modify ri by appending dj */ /* destructively modify ri by appending dj */
ri = append_digit( ri, dj); ri = append_digit( ri, dj );
} /* end for bj */ } /* end for bj */
/* if carry is not equal to zero, append it as a final digit /* if carry is not equal to zero, append it as a final digit
* to ri */ * to ri */
if (carry != 0) { if ( carry != 0 ) {
ri = append_digit( ri, make_integer( carry, NIL)); ri = append_digit( ri, make_integer( carry, NIL ) );
} }
/* add ri to result */ /* add ri to result */
result = add_integers( result, ri); result = add_integers( result, ri );
debug_print( L"multiply_integers: result is ", DEBUG_ARITH ); debug_print( L"multiply_integers: result is ", DEBUG_ARITH );
debug_print_object( result, DEBUG_ARITH ); debug_print_object( result, DEBUG_ARITH );
debug_println( DEBUG_ARITH ); debug_println( DEBUG_ARITH );
} /* end for ai */ } /* end for ai */
} }
debug_print( L"multiply_integers returning: ", DEBUG_ARITH ); debug_print( L"multiply_integers returning: ", DEBUG_ARITH );
@ -342,13 +343,16 @@ struct cons_pointer integer_to_string_add_digit( int digit, int digits,
* to be looking to the next. H'mmmm. * to be looking to the next. H'mmmm.
*/ */
struct cons_pointer integer_to_string( struct cons_pointer int_pointer, struct cons_pointer integer_to_string( struct cons_pointer int_pointer,
int base ) { int base ) {
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,13 +360,14 @@ 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 +=
next = pointer2cell(next).payload.integer.more; ( pointer2cell( next ).payload.integer.value << 60 );
next = pointer2cell( next ).payload.integer.more;
} }
int offset = ( int ) ( accumulator % base ); int offset = ( int ) ( accumulator % base );
debug_printf( DEBUG_IO, debug_printf( DEBUG_IO,
L"integer_to_string: digit is %ld, hexadecimal is %c, accumulator is: ", L"integer_to_string: digit is %ld, hexadecimal is %c, accumulator is: ",
offset, hex_digits[offset] ); offset, hex_digits[offset] );
debug_print_128bit( accumulator, DEBUG_IO ); debug_print_128bit( accumulator, DEBUG_IO );
debug_print( L"; result is: ", DEBUG_IO ); debug_print( L"; result is: ", DEBUG_IO );
debug_print_object( result, DEBUG_IO ); debug_print_object( result, DEBUG_IO );
@ -374,7 +379,7 @@ struct cons_pointer integer_to_string( struct cons_pointer int_pointer,
} }
if ( stringp( result ) if ( stringp( result )
&& pointer2cell( result ).payload.string.character == L',' ) { && pointer2cell( result ).payload.string.character == L',' ) {
/* if the number of digits in the string is divisible by 3, there will be /* if the number of digits in the string is divisible by 3, there will be
* an unwanted comma on the front. */ * an unwanted comma on the front. */
result = pointer2cell( result ).payload.string.cdr; result = pointer2cell( result ).payload.string.cdr;
@ -393,14 +398,15 @@ struct cons_pointer integer_to_string( struct cons_pointer int_pointer,
/** /**
* true if a and be are both integers whose value is the same value. * true if a and be are both integers whose value is the same value.
*/ */
bool equal_integer_integer(struct cons_pointer a, struct cons_pointer b) { bool equal_integer_integer( struct cons_pointer a, struct cons_pointer b ) {
bool result = false; bool result = false;
if (integerp(a) && integerp(b)){ if ( integerp( a ) && integerp( 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;
@ -410,15 +416,14 @@ bool equal_integer_integer(struct cons_pointer a, struct cons_pointer b) {
* true if `a` is an integer, and `b` is a real number whose value is the * true if `a` is an integer, and `b` is a real number whose value is the
* value of that integer. * value of that integer.
*/ */
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 ) {
result = pointer2cell(a).payload.integer.value == (int64_t)bv; result = pointer2cell( a ).payload.integer.value == ( int64_t ) bv;
} }
} }

18
src/arith/integer.h
View file

@ -14,19 +14,19 @@
#include <stdbool.h> #include <stdbool.h>
#include <stdint.h> #include <stdint.h>
struct cons_pointer make_integer(int64_t value, struct cons_pointer more); struct cons_pointer make_integer( int64_t value, struct cons_pointer more );
struct cons_pointer add_integers(struct cons_pointer a, struct cons_pointer add_integers( struct cons_pointer a,
struct cons_pointer b); struct cons_pointer b );
struct cons_pointer multiply_integers(struct cons_pointer a, struct cons_pointer multiply_integers( struct cons_pointer a,
struct cons_pointer b); struct cons_pointer b );
struct cons_pointer integer_to_string(struct cons_pointer int_pointer, struct cons_pointer integer_to_string( struct cons_pointer int_pointer,
int base); int base );
bool equal_integer_integer(struct cons_pointer a, struct cons_pointer b); 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 );
#endif #endif

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 =

2
src/arith/peano.h
View file

@ -27,7 +27,7 @@ struct cons_pointer absolute( struct cons_pointer arg );
long double to_long_double( struct cons_pointer arg ); long double to_long_double( struct cons_pointer arg );
int64_t to_long_int( struct cons_pointer arg ) ; int64_t to_long_int( struct cons_pointer arg );
struct cons_pointer lisp_absolute( struct stack_frame struct cons_pointer lisp_absolute( struct stack_frame
*frame, struct cons_pointer frame_pointer, struct *frame, struct cons_pointer frame_pointer, struct

76
src/arith/ratio.c
View file

@ -43,35 +43,29 @@ int64_t least_common_multiple( int64_t m, int64_t n ) {
return m / greatest_common_divisor( m, n ) * n; return m / greatest_common_divisor( m, n ) * 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 {
} if ( ratiop( pointer ) ) {
else
{
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 );
{ } else {
result = make_integer(ddrv / gcd, NIL);
}
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;
@ -196,11 +189,10 @@ 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 );
@ -217,7 +209,7 @@ struct cons_pointer divide_ratio_ratio( struct cons_pointer arg1,
struct cons_pointer multiply_ratio_ratio( struct struct cons_pointer multiply_ratio_ratio( struct
cons_pointer arg1, struct cons_pointer arg1, struct
cons_pointer arg2 ) { 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 result; struct cons_pointer result;
debug_print( L"multiply_ratio_ratio( arg1 = ", DEBUG_ARITH ); debug_print( L"multiply_ratio_ratio( arg1 = ", DEBUG_ARITH );
@ -294,7 +286,7 @@ struct cons_pointer multiply_integer_ratio( struct cons_pointer intarg,
*/ */
struct cons_pointer subtract_ratio_ratio( struct cons_pointer arg1, struct cons_pointer subtract_ratio_ratio( struct cons_pointer arg1,
struct cons_pointer arg2 ) { struct cons_pointer arg2 ) {
struct cons_pointer i = negative( arg2), struct cons_pointer i = negative( arg2 ),
result = add_ratio_ratio( arg1, i ); result = add_ratio_ratio( arg1, i );
dec_ref( i ); dec_ref( i );
@ -333,19 +325,17 @@ 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);
result = equal_integer_integer(cell_a->payload.ratio.dividend, result = equal_integer_integer( cell_a->payload.ratio.dividend,
cell_b->payload.ratio.dividend) && cell_b->payload.ratio.dividend ) &&
equal_integer_integer(cell_a->payload.ratio.divisor, equal_integer_integer( cell_a->payload.ratio.divisor,
cell_b->payload.ratio.divisor); cell_b->payload.ratio.divisor );
} }
return result; return result;

2
src/arith/ratio.h
View file

@ -34,6 +34,6 @@ struct cons_pointer subtract_ratio_ratio( struct cons_pointer arg1,
struct cons_pointer make_ratio( struct cons_pointer dividend, struct cons_pointer make_ratio( struct cons_pointer dividend,
struct cons_pointer divisor ); struct cons_pointer divisor );
bool equal_ratio_ratio(struct cons_pointer a, struct cons_pointer b); bool equal_ratio_ratio( struct cons_pointer a, struct cons_pointer b );
#endif #endif

8
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,
if (nilp(acl)) { struct cons_pointer acl ) {
acl = pointer2cell(target).access; if ( nilp( acl ) ) {
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

57
src/init.c
View file

@ -84,8 +84,9 @@ void bind_value( wchar_t *name, struct cons_pointer value ) {
dec_ref( n ); dec_ref( n );
} }
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 );
} }
/** /**
@ -93,22 +94,24 @@ void print_banner() {
* *
* @stream the stream to print to. * @stream the stream to print to.
*/ */
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,
fwprintf(stream, L"\t-h\tPrint this message and exit;\n"); L"\t-d\tDump memory to standard out at end of run (copious!);\n" );
fwprintf(stream, L"\t-p\tShow a prompt (default is no prompt);\n"); fwprintf( stream, L"\t-h\tPrint this message and exit;\n" );
fwprintf(stream, L"\t-v LEVEL\n\t\tSet verbosity to the specified level (0...512)\n"); fwprintf( stream, L"\t-p\tShow a prompt (default is no prompt);\n" );
fwprintf(stream, L"\t\tWhere bits are interpreted as follows:\n"); fwprintf( stream,
fwprintf(stream, L"\t\t1\tALLOC;\n"); L"\t-v LEVEL\n\t\tSet verbosity to the specified level (0...512)\n" );
fwprintf(stream, L"\t\t2\tARITH;\n"); fwprintf( stream, L"\t\tWhere bits are interpreted as follows:\n" );
fwprintf(stream, L"\t\t4\tBIND;\n"); fwprintf( stream, L"\t\t1\tALLOC;\n" );
fwprintf(stream, L"\t\t8\tBOOTSTRAP;\n"); fwprintf( stream, L"\t\t2\tARITH;\n" );
fwprintf(stream, L"\t\t16\tEVAL;\n"); fwprintf( stream, L"\t\t4\tBIND;\n" );
fwprintf(stream, L"\t\t32\tINPUT/OUTPUT;\n"); fwprintf( stream, L"\t\t8\tBOOTSTRAP;\n" );
fwprintf(stream, L"\t\t64\tLAMBDA;\n"); fwprintf( stream, L"\t\t16\tEVAL;\n" );
fwprintf(stream, L"\t\t128\tREPL;\n"); fwprintf( stream, L"\t\t32\tINPUT/OUTPUT;\n" );
fwprintf(stream, L"\t\t256\tSTACK.\n"); fwprintf( stream, L"\t\t64\tLAMBDA;\n" );
fwprintf( stream, L"\t\t128\tREPL;\n" );
fwprintf( stream, L"\t\t256\tSTACK.\n" );
} }
/** /**
@ -132,8 +135,8 @@ int main( int argc, char *argv[] ) {
dump_at_end = true; dump_at_end = true;
break; break;
case 'h': case 'h':
print_banner(); print_banner( );
print_options(stdout); print_options( stdout );
exit( 0 ); exit( 0 );
break; break;
case 'p': case 'p':
@ -144,14 +147,14 @@ int main( int argc, char *argv[] ) {
break; break;
default: default:
fwprintf( stderr, L"Unexpected option %c\n", option ); fwprintf( stderr, L"Unexpected option %c\n", option );
print_options(stderr); print_options( stderr );
exit( 1 ); exit( 1 );
break; break;
} }
} }
if ( show_prompt ) { if ( show_prompt ) {
print_banner(); print_banner( );
} }
debug_print( L"About to initialise cons pages\n", DEBUG_BOOTSTRAP ); debug_print( L"About to initialise cons pages\n", DEBUG_BOOTSTRAP );
@ -225,10 +228,10 @@ int main( int argc, char *argv[] ) {
bind_function( L"equal", &lisp_equal ); bind_function( L"equal", &lisp_equal );
bind_function( L"eval", &lisp_eval ); bind_function( L"eval", &lisp_eval );
bind_function( L"exception", &lisp_exception ); bind_function( L"exception", &lisp_exception );
bind_function( L"get-hash", &lisp_get_hash); bind_function( L"get-hash", &lisp_get_hash );
bind_function(L"hashmap", lisp_make_hashmap); bind_function( L"hashmap", lisp_make_hashmap );
bind_function( L"inspect", &lisp_inspect ); bind_function( L"inspect", &lisp_inspect );
bind_function( L"keys", &lisp_keys); bind_function( L"keys", &lisp_keys );
bind_function( L"meta", &lisp_metadata ); bind_function( L"meta", &lisp_metadata );
bind_function( L"metadata", &lisp_metadata ); bind_function( L"metadata", &lisp_metadata );
bind_function( L"multiply", &lisp_multiply ); bind_function( L"multiply", &lisp_multiply );
@ -237,8 +240,8 @@ int main( int argc, char *argv[] ) {
bind_function( L"open", &lisp_open ); bind_function( L"open", &lisp_open );
bind_function( L"print", &lisp_print ); bind_function( L"print", &lisp_print );
bind_function( L"progn", &lisp_progn ); bind_function( L"progn", &lisp_progn );
bind_function( L"put", lisp_hashmap_put); bind_function( L"put", lisp_hashmap_put );
bind_function( L"put-all", &lisp_hashmap_put_all); bind_function( L"put-all", &lisp_hashmap_put_all );
bind_function( L"read", &lisp_read ); bind_function( L"read", &lisp_read );
bind_function( L"read-char", &lisp_read_char ); bind_function( L"read-char", &lisp_read_char );
bind_function( L"repl", &lisp_repl ); bind_function( L"repl", &lisp_repl );

2
src/io/fopen.c
View file

@ -213,7 +213,7 @@ URL_FILE *url_fopen( const char *url, const char *operation ) {
file->handle.file = fopen( url, operation ); file->handle.file = fopen( url, operation );
if ( file->handle.file ) { if ( file->handle.file ) {
file->type = CFTYPE_FILE; /* marked as file */ file->type = CFTYPE_FILE; /* marked as file */
} else if ( index_of(':', url ) > -1 ) { } else if ( index_of( ':', url ) > -1 ) {
file->type = CFTYPE_CURL; /* marked as URL */ file->type = CFTYPE_CURL; /* marked as URL */
file->handle.curl = curl_easy_init( ); file->handle.curl = curl_easy_init( );

36
src/io/io.c
View file

@ -265,7 +265,7 @@ struct cons_pointer add_meta_integer( struct cons_pointer meta, wchar_t *key,
struct cons_pointer add_meta_string( struct cons_pointer meta, wchar_t *key, struct cons_pointer add_meta_string( struct cons_pointer meta, wchar_t *key,
char *value ) { char *value ) {
value = trim( value); value = trim( value );
wchar_t buffer[strlen( value ) + 1]; wchar_t buffer[strlen( value ) + 1];
mbstowcs( buffer, value, strlen( value ) + 1 ); mbstowcs( buffer, value, strlen( value ) + 1 );
@ -280,9 +280,8 @@ struct cons_pointer add_meta_time( struct cons_pointer meta, wchar_t *key,
char datestring[256]; char datestring[256];
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 );
} }
@ -391,7 +390,7 @@ void collect_meta( struct cons_pointer stream, char *url ) {
} }
/* this is destructive change before the cell is released into the /* this is destructive change before the cell is released into the
* wild, and consequently permissible, just. */ * wild, and consequently permissible, just. */
cell->payload.stream.meta = meta; cell->payload.stream.meta = meta;
} }
@ -441,20 +440,23 @@ lisp_open( struct stack_frame *frame, struct cons_pointer frame_pointer,
URL_FILE *stream = url_fopen( url, "r" ); URL_FILE *stream = url_fopen( url, "r" );
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
frame_pointer); ( L"Could not open stream" ),
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
frame_pointer); ( L"Could not open file" ),
frame_pointer );
} }
break; break;
case CFTYPE_CURL: case CFTYPE_CURL:
@ -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;

88
src/io/print.c
View file

@ -88,38 +88,38 @@ void print_list( URL_FILE * output, struct cons_pointer pointer ) {
url_fputws( L")", output ); url_fputws( L")", output );
} }
void print_map( URL_FILE *output, struct cons_pointer map ) { void print_map( URL_FILE * output, struct cons_pointer map ) {
if ( hashmapp( map ) ) { if ( hashmapp( map ) ) {
struct vector_space_object *vso = pointer_to_vso( map ); struct vector_space_object *vso = pointer_to_vso( map );
url_fputwc( btowc( '{' ), output ); url_fputwc( btowc( '{' ), output );
for ( struct cons_pointer ks = hashmap_keys( map ); !nilp( ks ); for ( struct cons_pointer ks = hashmap_keys( map ); !nilp( ks );
ks = c_cdr( ks ) ) { ks = c_cdr( ks ) ) {
struct cons_pointer key = c_car( ks); struct cons_pointer key = c_car( ks );
print( output, key ); print( output, key );
url_fputwc( btowc( ' ' ), output ); url_fputwc( btowc( ' ' ), output );
print( output, hashmap_get( map, key ) ); print( output, hashmap_get( map, key ) );
if ( !nilp( c_cdr( ks ) ) ) { if ( !nilp( c_cdr( ks ) ) ) {
url_fputws( L", ", output ); url_fputws( L", ", output );
} }
}
url_fputwc( btowc( '}' ), output );
} }
url_fputwc( btowc( '}' ), output );
}
} }
void print_vso( URL_FILE * output, struct cons_pointer pointer) { void print_vso( URL_FILE * output, struct cons_pointer pointer ) {
struct vector_space_object *vso = pointer_to_vso(pointer); struct vector_space_object *vso = pointer_to_vso( pointer );
switch ( vso->header.tag.value) { switch ( vso->header.tag.value ) {
case HASHTV: case HASHTV:
print_map( output, pointer); print_map( output, pointer );
break; break;
// \todo: others. // \todo: others.
default: default:
fwprintf( stderr, L"Unrecognised vector-space type '%d'\n", fwprintf( stderr, L"Unrecognised vector-space type '%d'\n",
vso->header.tag.value ); vso->header.tag.value );
} }
} }
@ -130,14 +130,14 @@ void print_128bit( URL_FILE * output, __int128_t n ) {
if ( n == 0 ) { if ( n == 0 ) {
fwprintf( stderr, L"0" ); fwprintf( stderr, L"0" );
} else { } else {
char str[40] = { 0 }; // log10(1 << 128) + '\0' char str[40] = { 0 }; // log10(1 << 128) + '\0'
char *s = str + sizeof( str ) - 1; // start at the end char *s = str + sizeof( str ) - 1; // start at the end
while ( n != 0 ) { while ( n != 0 ) {
if ( s == str ) if ( s == str )
return; // never happens return; // never happens
*--s = "0123456789"[n % 10]; // save last digit *--s = "0123456789"[n % 10]; // save last digit
n /= 10; // drop it n /= 10; // drop it
} }
url_fwprintf( output, L"%s", s ); url_fwprintf( output, L"%s", s );
} }
@ -165,9 +165,9 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) {
dump_stack_trace( output, pointer ); dump_stack_trace( output, pointer );
break; break;
case FUNCTIONTV: case FUNCTIONTV:
url_fputws( L"<Function: ", output); url_fputws( L"<Function: ", output );
print( output, cell.payload.function.meta); print( output, cell.payload.function.meta );
url_fputwc( L'>', output); url_fputwc( L'>', output );
break; break;
case INTEGERTV:{ case INTEGERTV:{
struct cons_pointer s = integer_to_string( pointer, 10 ); struct cons_pointer s = integer_to_string( pointer, 10 );
@ -181,7 +181,7 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) {
print_string_contents( output, pointer ); print_string_contents( output, pointer );
break; break;
case LAMBDATV:{ case LAMBDATV:{
url_fputws( L"<Anonymous Function: ", output); url_fputws( L"<Anonymous Function: ", output );
struct cons_pointer to_print = struct cons_pointer to_print =
make_cons( c_string_to_lisp_symbol( L"\u03bb" ), make_cons( c_string_to_lisp_symbol( L"\u03bb" ),
make_cons( cell.payload.lambda.args, make_cons( cell.payload.lambda.args,
@ -191,14 +191,14 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) {
print( output, to_print ); print( output, to_print );
dec_ref( to_print ); dec_ref( to_print );
url_fputwc( L'>', output); url_fputwc( L'>', output );
} }
break; break;
case NILTV: case NILTV:
url_fwprintf( output, L"nil" ); url_fwprintf( output, L"nil" );
break; break;
case NLAMBDATV:{ case NLAMBDATV:{
url_fputws( L"<Anonymous Special Form: ", output); url_fputws( L"<Anonymous Special Form: ", output );
struct cons_pointer to_print = struct cons_pointer to_print =
make_cons( c_string_to_lisp_symbol( L"n\u03bb" ), make_cons( c_string_to_lisp_symbol( L"n\u03bb" ),
make_cons( cell.payload.lambda.args, make_cons( cell.payload.lambda.args,
@ -208,7 +208,7 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) {
print( output, to_print ); print( output, to_print );
dec_ref( to_print ); dec_ref( to_print );
url_fputwc( L'>', output); url_fputwc( L'>', output );
} }
break; break;
case RATIOTV: case RATIOTV:
@ -218,8 +218,8 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) {
break; break;
case READTV: case READTV:
url_fwprintf( output, L"<Input stream: " ); url_fwprintf( output, L"<Input stream: " );
print( output, cell.payload.stream.meta); print( output, cell.payload.stream.meta );
url_fputwc( L'>', output); url_fputwc( L'>', output );
break; break;
case REALTV: case REALTV:
/* \todo using the C heap is a bad plan because it will fragment. /* \todo using the C heap is a bad plan because it will fragment.
@ -245,26 +245,26 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) {
break; break;
case SPECIALTV: case SPECIALTV:
url_fwprintf( output, L"<Special form: " ); url_fwprintf( output, L"<Special form: " );
print( output, cell.payload.special.meta); print( output, cell.payload.special.meta );
url_fputwc( L'>', output); url_fputwc( L'>', output );
break; break;
case TIMETV: case TIMETV:
url_fwprintf( output, L"<Time: " ); url_fwprintf( output, L"<Time: " );
print_string( output, time_to_string( pointer)); print_string( output, time_to_string( pointer ) );
url_fputws( L"; ", output); url_fputws( L"; ", output );
print_128bit( output, pointer2cell(pointer).payload.time.value); print_128bit( output, pointer2cell( pointer ).payload.time.value );
url_fputwc( L'>', output); url_fputwc( L'>', output );
break; break;
case TRUETV: case TRUETV:
url_fwprintf( output, L"t" ); url_fwprintf( output, L"t" );
break; break;
case VECTORPOINTTV: case VECTORPOINTTV:
print_vso( output, pointer); print_vso( output, pointer );
break; break;
case WRITETV: case WRITETV:
url_fwprintf( output, L"<Output stream: " ); url_fwprintf( output, L"<Output stream: " );
print( output, cell.payload.stream.meta); print( output, cell.payload.stream.meta );
url_fputwc( L'>', output); url_fputwc( L'>', output );
break; break;
default: default:
fwprintf( stderr, fwprintf( stderr,

83
src/io/read.c
View file

@ -46,8 +46,8 @@ struct cons_pointer read_list( 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 );
struct cons_pointer read_map( struct stack_frame *frame, 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 );
struct cons_pointer read_string( URL_FILE * input, wint_t initial ); struct cons_pointer read_string( URL_FILE * input, wint_t initial );
struct cons_pointer read_symbol_or_key( URL_FILE * input, uint32_t tag, struct cons_pointer read_symbol_or_key( URL_FILE * input, uint32_t tag,
wint_t initial ); wint_t initial );
@ -106,7 +106,7 @@ struct cons_pointer read_continuation( struct stack_frame *frame,
break; break;
case '{': case '{':
result = read_map( frame, frame_pointer, input, result = read_map( frame, frame_pointer, input,
url_fgetwc( input ) ); url_fgetwc( input ) );
break; break;
case '"': case '"':
result = read_string( input, url_fgetwc( input ) ); result = read_string( input, url_fgetwc( input ) );
@ -134,10 +134,12 @@ 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
DEBUG_IO); ( L"read_continuation: dotted pair; read cdr ",
DEBUG_IO );
} else { } else {
read_symbol_or_key( input, SYMBOLTV, c ); read_symbol_or_key( input, SYMBOLTV, c );
} }
@ -284,37 +286,34 @@ struct cons_pointer read_number( struct stack_frame *frame,
* left parenthesis. * left parenthesis.
*/ */
struct cons_pointer read_list( struct stack_frame *frame, struct cons_pointer read_list( 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 ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
wint_t c; wint_t c;
if ( initial != ')' ) { if ( initial != ')' ) {
debug_printf( DEBUG_IO, debug_printf( DEBUG_IO,
L"read_list starting '%C' (%d)\n", initial, initial ); L"read_list starting '%C' (%d)\n", initial, initial );
struct cons_pointer car = struct cons_pointer car =
read_continuation( frame, frame_pointer, input, read_continuation( frame, frame_pointer, input,
initial ); initial );
/* 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
* initial periods, it must be a dotted pair. \todo Ought to check, * initial periods, it must be a dotted pair. \todo Ought to check,
* howerver, that there's only one form after the period. */ * howerver, that there's only one form after the period. */
result = result =
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 );
@ -325,35 +324,35 @@ struct cons_pointer read_list( struct stack_frame *frame,
struct cons_pointer read_map( struct stack_frame *frame, 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 =
wint_t c = initial; make_hashmap( DFLT_HASHMAP_BUCKETS, NIL, TRUE );
wint_t c = initial;
while ( c != L'}' ) { while ( c != L'}' ) {
struct cons_pointer key = struct cons_pointer key =
read_continuation( frame, frame_pointer, input, c ); read_continuation( frame, frame_pointer, input, c );
/* 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 );
} }
// default write ACL for maps should be NIL. // default write ACL for maps should be NIL.
pointer_to_vso( result )->payload.hashmap.write_acl = NIL; pointer_to_vso( result )->payload.hashmap.write_acl = NIL;
return result; return result;
} }
/** /**

2
src/memory/conspage.c
View file

@ -179,7 +179,7 @@ void free_cell( struct cons_pointer pointer ) {
dec_ref( cell->payload.string.cdr ); dec_ref( cell->payload.string.cdr );
break; break;
case VECTORPOINTTV: case VECTORPOINTTV:
free_vso( pointer); free_vso( pointer );
break; break;
} }

142
src/memory/consspaceobject.c
View file

@ -33,22 +33,22 @@
* vectorspace object indicated by the cell is this `value`, else false. * vectorspace object indicated by the cell is this `value`, else false.
*/ */
bool check_tag( struct cons_pointer pointer, uint32_t value ) { bool check_tag( struct cons_pointer pointer, uint32_t value ) {
bool result = false; bool result = false;
struct cons_space_object cell = pointer2cell( pointer ); struct cons_space_object cell = pointer2cell( pointer );
result = cell.tag.value == value; result = cell.tag.value == value;
if ( result == false ) { if ( result == false ) {
if ( cell.tag.value == VECTORPOINTTV ) { if ( cell.tag.value == VECTORPOINTTV ) {
struct vector_space_object *vec = pointer_to_vso( pointer ); struct vector_space_object *vec = pointer_to_vso( pointer );
if ( vec != NULL ) { if ( vec != NULL ) {
result = vec->header.tag.value == value; result = vec->header.tag.value == value;
} }
}
} }
}
return result; return result;
} }
/** /**
@ -99,22 +99,24 @@ struct cons_pointer dec_ref( struct cons_pointer pointer ) {
* @return As a Lisp string, the tag of the object which is at that pointer. * @return As a Lisp string, the tag of the object which is at that pointer.
*/ */
struct cons_pointer c_type( struct cons_pointer pointer ) { 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 ) ==
struct vector_space_object *vec = pointer_to_vso( pointer ); 0 ) {
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 {
for ( int i = TAGLENGTH - 1; i >= 0; i-- ) {
result = make_string( ( wchar_t ) cell.tag.bytes[i], result );
}
} }
} else {
for ( int i = TAGLENGTH - 1; i >= 0; i-- ) {
result = make_string( (wchar_t)cell.tag.bytes[i], result );
}
}
return result; return result;
} }
/** /**
@ -122,13 +124,13 @@ struct cons_pointer c_type( struct cons_pointer pointer ) {
* authorised to read it, does not error but returns nil. * authorised to read it, does not error but returns nil.
*/ */
struct cons_pointer c_car( struct cons_pointer arg ) { struct cons_pointer c_car( struct cons_pointer arg ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
if ( truep( authorised( arg, NIL ) ) && consp( arg ) ) { if ( truep( authorised( arg, NIL ) ) && consp( arg ) ) {
result = pointer2cell( arg ).payload.cons.car; result = pointer2cell( arg ).payload.cons.car;
} }
return result; return result;
} }
/** /**
@ -136,34 +138,34 @@ struct cons_pointer c_car( struct cons_pointer arg ) {
* not authorised to read it,does not error but returns nil. * not authorised to read it,does not error but returns nil.
*/ */
struct cons_pointer c_cdr( struct cons_pointer arg ) { struct cons_pointer c_cdr( struct cons_pointer arg ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
if ( truep( authorised( arg, NIL ) ) ) { if ( truep( authorised( arg, NIL ) ) ) {
struct cons_space_object *cell = &pointer2cell( arg ); struct cons_space_object *cell = &pointer2cell( arg );
switch ( cell->tag.value ) { switch ( cell->tag.value ) {
case CONSTV: case CONSTV:
result = cell->payload.cons.cdr; result = cell->payload.cons.cdr;
break; break;
case KEYTV: case KEYTV:
case STRINGTV: case STRINGTV:
case SYMBOLTV: case SYMBOLTV:
result = cell->payload.string.cdr; result = cell->payload.string.cdr;
break; break;
}
} }
}
return result; return result;
} }
/** /**
* Implementation of `length` in C. If arg is not a cons, does not error but returns 0. * Implementation of `length` in C. If arg is not a cons, does not error but returns 0.
*/ */
int c_length( struct cons_pointer arg) { int c_length( struct cons_pointer arg ) {
int result = 0; int result = 0;
for (struct cons_pointer c = arg; !nilp(c); c = c_cdr(c)) { for ( struct cons_pointer c = arg; !nilp( c ); c = c_cdr( c ) ) {
result ++; result++;
} }
return result; return result;
@ -276,27 +278,21 @@ 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;
{ } else {
result = (uint32_t)c; result = ( ( uint32_t ) c *
} cell->payload.string.hash ) & 0xffffffff;
else }
{ break;
result = ((uint32_t)c *
cell->payload.string.hash) &
0xffffffff;
}
break;
} }
return result; return result;
@ -324,7 +320,7 @@ make_string_like_thing( wint_t c, struct cons_pointer tail, uint32_t tag ) {
* cell->payload.string.cdr = tail */ * cell->payload.string.cdr = tail */
cell->payload.string.cdr.offset = tail.offset; cell->payload.string.cdr.offset = tail.offset;
cell->payload.string.hash = calculate_hash(c, tail); cell->payload.string.hash = calculate_hash( c, tail );
} else { } else {
// \todo should throw an exception! // \todo should throw an exception!
debug_printf( DEBUG_ALLOC, debug_printf( DEBUG_ALLOC,
@ -430,12 +426,12 @@ struct cons_pointer make_write_stream( URL_FILE * output,
struct cons_pointer c_string_to_lisp_keyword( wchar_t *symbol ) { struct cons_pointer c_string_to_lisp_keyword( wchar_t *symbol ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
for ( int i = wcslen( symbol ) -1; i >= 0; i-- ) { for ( int i = wcslen( symbol ) - 1; i >= 0; i-- ) {
wchar_t c = towlower(symbol[i]); wchar_t c = towlower( symbol[i] );
if (iswalnum(c) || c == L'-') { if ( iswalnum( c ) || c == L'-' ) {
result = make_keyword( c, result ); result = make_keyword( c, result );
} }
} }
return result; return result;
@ -448,9 +444,9 @@ struct cons_pointer c_string_to_lisp_string( wchar_t *string ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
for ( int i = wcslen( string ) - 1; i >= 0; i-- ) { for ( int i = wcslen( string ) - 1; i >= 0; i-- ) {
if (iswprint(string[i]) && string[i] != '"') { if ( iswprint( string[i] ) && string[i] != '"' ) {
result = make_string( string[i], result ); result = make_string( string[i], result );
} }
} }
return result; return result;

2
src/memory/consspaceobject.h
View file

@ -685,7 +685,7 @@ struct cons_pointer c_car( struct cons_pointer arg );
struct cons_pointer c_cdr( struct cons_pointer arg ); struct cons_pointer c_cdr( struct cons_pointer arg );
int c_length( struct cons_pointer arg); int c_length( struct cons_pointer arg );
struct cons_pointer make_cons( struct cons_pointer car, struct cons_pointer make_cons( struct cons_pointer car,
struct cons_pointer cdr ); struct cons_pointer cdr );

207
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" );
@ -57,105 +56,111 @@ void dump_string_cell( URL_FILE * output, wchar_t *prefix,
/** /**
* dump the object at this cons_pointer to this output stream. * dump the object at this cons_pointer to this output stream.
*/ */
void dump_object( URL_FILE *output, struct cons_pointer pointer ) { void dump_object( URL_FILE * output, struct cons_pointer pointer ) {
struct cons_space_object cell = pointer2cell( pointer ); struct cons_space_object cell = pointer2cell( pointer );
url_fwprintf( output, L"\t%4.4s (%d) at page %d, offset %d count %u\n", url_fwprintf( output, L"\t%4.4s (%d) at page %d, offset %d count %u\n",
cell.tag.bytes, cell.tag.value, pointer.page, pointer.offset, cell.tag.bytes, cell.tag.value, pointer.page, pointer.offset,
cell.count ); cell.count );
switch ( cell.tag.value ) { switch ( cell.tag.value ) {
case CONSTV: case CONSTV:
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,
print( output, pointer ); cell.payload.cons.cdr.offset, cell.count );
url_fputws( L"\n", output ); print( output, pointer );
break; url_fputws( L"\n", output );
case EXCEPTIONTV: break;
url_fwprintf( output, L"\t\tException cell: " ); case EXCEPTIONTV:
dump_stack_trace( output, pointer ); url_fwprintf( output, L"\t\tException cell: " );
break; dump_stack_trace( output, pointer );
case FREETV: break;
url_fwprintf( output, L"\t\tFree cell: next at page %d offset %d\n", case FREETV:
cell.payload.cons.cdr.page, cell.payload.cons.cdr.offset ); url_fwprintf( output,
break; L"\t\tFree cell: next at page %d offset %d\n",
case INTEGERTV: cell.payload.cons.cdr.page,
url_fwprintf( output, L"\t\tInteger cell: value %ld, count %u\n", cell.payload.cons.cdr.offset );
cell.payload.integer.value, cell.count ); break;
if ( !nilp( cell.payload.integer.more ) ) { case INTEGERTV:
url_fputws( L"\t\tBIGNUM! More at:\n", output ); url_fwprintf( output, L"\t\tInteger cell: value %ld, count %u\n",
dump_object( output, cell.payload.integer.more ); cell.payload.integer.value, cell.count );
} if ( !nilp( cell.payload.integer.more ) ) {
break; url_fputws( L"\t\tBIGNUM! More at:\n", output );
case KEYTV: dump_object( output, cell.payload.integer.more );
dump_string_cell( output, L"Keyword", pointer ); }
break; break;
case LAMBDATV: case KEYTV:
url_fwprintf( output, L"\t\t\u03bb cell;\n\t\t args: " ); dump_string_cell( output, L"Keyword", pointer );
print( output, cell.payload.lambda.args ); break;
url_fwprintf( output, L";\n\t\t\tbody: " ); case LAMBDATV:
print( output, cell.payload.lambda.body ); url_fwprintf( output, L"\t\t\u03bb cell;\n\t\t args: " );
url_fputws( L"\n", output ); print( output, cell.payload.lambda.args );
break; url_fwprintf( output, L";\n\t\t\tbody: " );
case NILTV: print( output, cell.payload.lambda.body );
break; url_fputws( L"\n", output );
case NLAMBDATV: break;
url_fwprintf( output, L"\t\tn\u03bb cell; \n\t\targs: " ); case NILTV:
print( output, cell.payload.lambda.args ); break;
url_fwprintf( output, L";\n\t\t\tbody: " ); case NLAMBDATV:
print( output, cell.payload.lambda.body ); url_fwprintf( output, L"\t\tn\u03bb cell; \n\t\targs: " );
url_fputws( L"\n", output ); print( output, cell.payload.lambda.args );
break; url_fwprintf( output, L";\n\t\t\tbody: " );
case RATIOTV: print( output, cell.payload.lambda.body );
url_fwprintf( url_fputws( L"\n", output );
output, L"\t\tRational cell: value %ld/%ld, count %u\n", break;
pointer2cell( cell.payload.ratio.dividend ).payload.integer.value, case RATIOTV:
pointer2cell( cell.payload.ratio.divisor ).payload.integer.value, url_fwprintf( output,
cell.count ); L"\t\tRational cell: value %ld/%ld, count %u\n",
break; pointer2cell( cell.payload.ratio.dividend ).payload.
case READTV: integer.value,
url_fputws( L"\t\tInput stream; metadata: ", output ); pointer2cell( cell.payload.ratio.divisor ).payload.
print( output, cell.payload.stream.meta ); integer.value, cell.count );
url_fputws( L"\n", output ); break;
break; case READTV:
case REALTV: url_fputws( L"\t\tInput stream; metadata: ", output );
url_fwprintf( output, L"\t\tReal cell: value %Lf, count %u\n", print( output, cell.payload.stream.meta );
cell.payload.real.value, cell.count ); url_fputws( L"\n", output );
break; break;
case STRINGTV: case REALTV:
dump_string_cell( output, L"String", pointer ); url_fwprintf( output, L"\t\tReal cell: value %Lf, count %u\n",
break; cell.payload.real.value, cell.count );
case SYMBOLTV: break;
dump_string_cell( output, L"Symbol", pointer ); case STRINGTV:
break; dump_string_cell( output, L"String", pointer );
case TRUETV: break;
break; case SYMBOLTV:
case VECTORPOINTTV: { dump_string_cell( output, L"Symbol", pointer );
url_fwprintf( output, L"\t\tPointer to vector-space object at %p\n", break;
cell.payload.vectorp.address ); case TRUETV:
struct vector_space_object *vso = cell.payload.vectorp.address; break;
url_fwprintf( output, case VECTORPOINTTV:{
L"\t\tVector space object of type %4.4s (%d), payload size " url_fwprintf( output,
L"%d bytes\n", L"\t\tPointer to vector-space object at %p\n",
&vso->header.tag.bytes, vso->header.tag.value, cell.payload.vectorp.address );
vso->header.size ); struct vector_space_object *vso = cell.payload.vectorp.address;
url_fwprintf( output,
L"\t\tVector space object of type %4.4s (%d), payload size "
L"%d bytes\n",
&vso->header.tag.bytes, vso->header.tag.value,
vso->header.size );
switch ( vso->header.tag.value ) { switch ( vso->header.tag.value ) {
case STACKFRAMETV: case STACKFRAMETV:
dump_frame( output, pointer ); dump_frame( output, pointer );
break; break;
case HASHTV: case HASHTV:
dump_map( output, pointer ); dump_map( output, pointer );
break; break;
} }
} break; }
case WRITETV: break;
url_fputws( L"\t\tOutput stream; metadata: ", output ); case WRITETV:
print( output, cell.payload.stream.meta ); url_fputws( L"\t\tOutput stream; metadata: ", output );
url_fputws( L"\n", output ); print( output, cell.payload.stream.meta );
break; url_fputws( L"\n", output );
} break;
}
} }

369
src/memory/hashmap.c
View file

@ -24,47 +24,46 @@
* then `(sxhash x)` and `(sxhash y)` will always be equal. * then `(sxhash x)` and `(sxhash y)` will always be equal.
*/ */
uint32_t sxhash( struct cons_pointer ptr ) { uint32_t sxhash( struct cons_pointer ptr ) {
// TODO: Not Yet Implemented // TODO: Not Yet Implemented
/* TODO: should look at the implementation of Common Lisp sxhash? /* TODO: should look at the implementation of Common Lisp sxhash?
* My current implementation of `print` only addresses URL_FILE * My current implementation of `print` only addresses URL_FILE
* streams. It would be better if it also addressed strings but * streams. It would be better if it also addressed strings but
* currently it doesn't. Creating a print string of the structure * currently it doesn't. Creating a print string of the structure
* and taking the hash of that would be one simple (but not necessarily * and taking the hash of that would be one simple (but not necessarily
* cheap) solution. * cheap) solution.
*/ */
/* TODO: sbcl's implementation of `sxhash` is in src/compiler/sxhash.lisp /* TODO: sbcl's implementation of `sxhash` is in src/compiler/sxhash.lisp
* and is EXTREMELY complex, and essentially has a different dispatch for * and is EXTREMELY complex, and essentially has a different dispatch for
* every type of object. It's likely we need to do the same. * every type of object. It's likely we need to do the same.
*/ */
return 0; return 0;
} }
/** /**
* 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;
switch ( cell->tag.value ) { switch ( cell->tag.value ) {
case INTEGERTV: case INTEGERTV:
/* Note that we're only hashing on the least significant word of an /* Note that we're only hashing on the least significant word of an
* integer. */ * integer. */
result = cell->payload.integer.value & 0xffffffff; result = cell->payload.integer.value & 0xffffffff;
break; break;
case KEYTV: case KEYTV:
case STRINGTV: case STRINGTV:
case SYMBOLTV: case SYMBOLTV:
result = cell->payload.string.hash; result = cell->payload.string.hash;
break; break;
case TRUETV: case TRUETV:
result = 1; // arbitrarily result = 1; // arbitrarily
break; break;
default: default:
result = sxhash( ptr ); result = sxhash( ptr );
break; break;
} }
return result; return result;
@ -74,35 +73,34 @@ uint32_t get_hash(struct cons_pointer ptr)
* Free the hashmap indicated by this `pointer`. * Free the hashmap indicated by this `pointer`.
*/ */
void free_hashmap( struct cons_pointer pointer ) { void free_hashmap( struct cons_pointer pointer ) {
struct cons_space_object *cell = &pointer2cell( pointer ); struct cons_space_object *cell = &pointer2cell( pointer );
if ( hashmapp( pointer ) ) { if ( hashmapp( pointer ) ) {
struct vector_space_object *vso = cell->payload.vectorp.address; struct vector_space_object *vso = cell->payload.vectorp.address;
dec_ref( vso->payload.hashmap.hash_fn ); dec_ref( vso->payload.hashmap.hash_fn );
dec_ref( vso->payload.hashmap.write_acl ); dec_ref( vso->payload.hashmap.write_acl );
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] );
} }
}
} else {
debug_printf( DEBUG_ALLOC, L"Non-hashmap passed to `free_hashmap`\n" );
} }
} else {
debug_printf( DEBUG_ALLOC, L"Non-hashmap passed to `free_hashmap`\n" );
}
} }
/** /**
* A lisp function signature conforming wrapper around get_hash, q.v.. * A lisp function signature conforming wrapper around get_hash, q.v..
*/ */
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);
} }
/** /**
@ -112,22 +110,23 @@ struct cons_pointer lisp_get_hash(struct stack_frame *frame,
struct cons_pointer make_hashmap( uint32_t n_buckets, 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( uint32_t ) * 2 ) ); ( sizeof( struct cons_pointer ) * ( n_buckets + 1 ) ) +
( sizeof( uint32_t ) * 2 ) );
struct hashmap_payload *payload = struct hashmap_payload *payload =
(struct hashmap_payload *)&pointer_to_vso( result )->payload; ( struct hashmap_payload * ) &pointer_to_vso( result )->payload;
payload->hash_fn = inc_ref(hash_fn); payload->hash_fn = inc_ref( hash_fn );
payload->write_acl = inc_ref(write_acl); payload->write_acl = inc_ref( write_acl );
payload->n_buckets = n_buckets; payload->n_buckets = n_buckets;
for ( int i = 0; i < n_buckets; i++ ) { for ( int i = 0; i < n_buckets; i++ ) {
payload->buckets[i] = NIL; payload->buckets[i] = NIL;
} }
return result; return result;
} }
/** /**
@ -141,52 +140,54 @@ struct cons_pointer make_hashmap( uint32_t n_buckets,
struct cons_pointer lisp_make_hashmap( struct stack_frame *frame, struct cons_pointer lisp_make_hashmap( struct stack_frame *frame,
struct cons_pointer frame_pointer, struct cons_pointer frame_pointer,
struct cons_pointer env ) { struct cons_pointer env ) {
uint32_t n = DFLT_HASHMAP_BUCKETS; uint32_t n = DFLT_HASHMAP_BUCKETS;
struct cons_pointer hash_fn = NIL; struct cons_pointer hash_fn = NIL;
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
if ( frame->args > 0 ) { if ( frame->args > 0 ) {
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 ) { hash_fn = frame->arg[1];
hash_fn = frame->arg[1];
}
if ( nilp( result ) ) {
/* if there are fewer than 4 args, then arg[3] ought to be nil anyway, which
* is fine */
result = make_hashmap( n, hash_fn, frame->arg[3] );
struct vector_space_object *map = pointer_to_vso( result );
if ( frame->args > 2 &&
truep( authorised( result, map->payload.hashmap.write_acl ) ) ) {
// then arg[2] ought to be an assoc list which we should iterate down
// populating the hashmap.
for ( struct cons_pointer cursor = frame->arg[2]; !nilp( cursor );
cursor = c_cdr( cursor ) ) {
struct cons_pointer pair = c_car( cursor );
struct cons_pointer key = c_car( pair );
struct cons_pointer val = c_cdr( pair );
uint32_t bucket_no =
get_hash( key ) %
( (struct hashmap_payload *)&( map->payload ) )->n_buckets;
map->payload.hashmap.buckets[bucket_no] =
inc_ref( make_cons( make_cons( key, val ),
map->payload.hashmap.buckets[bucket_no] ));
}
} }
}
return result; if ( nilp( result ) ) {
/* if there are fewer than 4 args, then arg[3] ought to be nil anyway, which
* is fine */
result = make_hashmap( n, hash_fn, frame->arg[3] );
struct vector_space_object *map = pointer_to_vso( result );
if ( frame->args > 2 &&
truep( authorised( result, map->payload.hashmap.write_acl ) ) ) {
// then arg[2] ought to be an assoc list which we should iterate down
// populating the hashmap.
for ( struct cons_pointer cursor = frame->arg[2]; !nilp( cursor );
cursor = c_cdr( cursor ) ) {
struct cons_pointer pair = c_car( cursor );
struct cons_pointer key = c_car( pair );
struct cons_pointer val = c_cdr( pair );
uint32_t bucket_no =
get_hash( key ) %
( ( struct hashmap_payload * ) &( map->payload ) )->
n_buckets;
map->payload.hashmap.buckets[bucket_no] =
inc_ref( make_cons( make_cons( key, val ),
map->payload.hashmap.
buckets[bucket_no] ) );
}
}
}
return result;
} }
@ -197,28 +198,30 @@ struct cons_pointer lisp_make_hashmap( struct stack_frame *frame,
* readable hashmap. * readable hashmap.
*/ */
struct cons_pointer clone_hashmap( struct cons_pointer ptr ) { struct cons_pointer clone_hashmap( struct cons_pointer ptr ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
if ( truep( authorised( ptr, NIL ) ) ) { if ( truep( authorised( ptr, NIL ) ) ) {
if ( hashmapp( ptr ) ) { if ( hashmapp( ptr ) ) {
struct vector_space_object *from = pointer_to_vso( ptr ); struct vector_space_object *from = pointer_to_vso( 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 =
struct vector_space_object *to = pointer_to_vso( result ); make_hashmap( from_pl.n_buckets, from_pl.hash_fn,
struct hashmap_payload to_pl = to->payload.hashmap; from_pl.write_acl );
struct vector_space_object *to = pointer_to_vso( result );
struct hashmap_payload to_pl = to->payload.hashmap;
for ( int i = 0; i < to_pl.n_buckets; i++ ) { for ( int i = 0; i < to_pl.n_buckets; i++ ) {
to_pl.buckets[i] = from_pl.buckets[i]; to_pl.buckets[i] = from_pl.buckets[i];
inc_ref( to_pl.buckets[i] ); inc_ref( to_pl.buckets[i] );
}
}
} }
}
} }
} // TODO: else exception?
// TODO: else exception?
return result; return result;
} }
/** /**
@ -229,37 +232,35 @@ struct cons_pointer clone_hashmap( struct cons_pointer ptr ) {
struct cons_pointer hashmap_put( struct cons_pointer mapp, struct cons_pointer hashmap_put( struct cons_pointer mapp,
struct cons_pointer key, struct cons_pointer key,
struct cons_pointer val ) { struct cons_pointer val ) {
// TODO: if current user has write access to this hashmap // TODO: if current user has write access to this hashmap
if ( hashmapp( mapp ) && !nilp( key ) ) { if ( hashmapp( mapp ) && !nilp( key ) ) {
struct vector_space_object *map = pointer_to_vso( mapp ); struct vector_space_object *map = pointer_to_vso( mapp );
if (nilp(authorised(mapp, map->payload.hashmap.write_acl))) { if ( nilp( authorised( mapp, map->payload.hashmap.write_acl ) ) ) {
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 ),
map->payload.hashmap.buckets[bucket_no] )); map->payload.hashmap.buckets[bucket_no] ) );
} }
return mapp; return mapp;
} }
struct cons_pointer hashmap_get( struct cons_pointer mapp, struct cons_pointer hashmap_get( struct cons_pointer mapp,
struct cons_pointer key ) { struct cons_pointer key ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
if ( hashmapp( mapp ) && truep( authorised( mapp, NIL ) ) && !nilp( key ) ) { if ( hashmapp( mapp ) && truep( authorised( mapp, NIL ) ) && !nilp( key ) ) {
struct vector_space_object *map = pointer_to_vso( mapp ); struct vector_space_object *map = pointer_to_vso( mapp );
uint32_t bucket_no = get_hash( key ) % map->payload.hashmap.n_buckets; uint32_t bucket_no = get_hash( key ) % map->payload.hashmap.n_buckets;
result = c_assoc( key, map->payload.hashmap.buckets[bucket_no] ); result = c_assoc( key, map->payload.hashmap.buckets[bucket_no] );
} }
return result; return result;
} }
/** /**
@ -272,11 +273,11 @@ struct cons_pointer hashmap_get( struct cons_pointer mapp,
struct cons_pointer lisp_hashmap_put( struct stack_frame *frame, struct cons_pointer lisp_hashmap_put( 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 mapp = frame->arg[0]; struct cons_pointer mapp = frame->arg[0];
struct cons_pointer key = frame->arg[1]; struct cons_pointer key = frame->arg[1];
struct cons_pointer val = frame->arg[2]; struct cons_pointer val = frame->arg[2];
return hashmap_put(mapp, key, val); return hashmap_put( mapp, key, val );
} }
/** /**
@ -286,21 +287,21 @@ struct cons_pointer lisp_hashmap_put( struct stack_frame *frame,
*/ */
struct cons_pointer hashmap_put_all( struct cons_pointer mapp, struct cons_pointer hashmap_put_all( struct cons_pointer mapp,
struct cons_pointer assoc ) { struct cons_pointer assoc ) {
// TODO: if current user has write access to this hashmap // TODO: if current user has write access to this hashmap
if ( hashmapp( mapp ) && !nilp( assoc ) ) { if ( hashmapp( mapp ) && !nilp( assoc ) ) {
struct vector_space_object *map = pointer_to_vso( mapp ); struct vector_space_object *map = pointer_to_vso( mapp );
if ( hashmapp( mapp ) && consp( assoc ) ) { if ( hashmapp( mapp ) && consp( assoc ) ) {
for ( struct cons_pointer pair = c_car( assoc ); !nilp( pair ); for ( struct cons_pointer pair = c_car( assoc ); !nilp( pair );
pair = c_car( assoc ) ) { pair = c_car( assoc ) ) {
/* TODO: this is really hammering the memory management system, because /* TODO: this is really hammering the memory management system, because
* it will make a new lone for every key/value pair added. Fix. */ * it will make a new lone for every key/value pair added. Fix. */
mapp = hashmap_put( mapp, c_car( pair ), c_cdr( pair ) ); mapp = hashmap_put( mapp, c_car( pair ), c_cdr( pair ) );
} }
}
} }
}
return mapp; return mapp;
} }
/** /**
@ -310,47 +311,47 @@ struct cons_pointer hashmap_put_all( struct cons_pointer mapp,
struct cons_pointer lisp_hashmap_put_all( struct stack_frame *frame, struct cons_pointer lisp_hashmap_put_all( struct stack_frame *frame,
struct cons_pointer frame_pointer, struct cons_pointer frame_pointer,
struct cons_pointer env ) { struct cons_pointer env ) {
return hashmap_put_all( frame->arg[0], frame->arg[1] ); return hashmap_put_all( frame->arg[0], frame->arg[1] );
} }
/** /**
* return a flat list of all the keys in the hashmap indicated by `map`. * return a flat list of all the keys in the hashmap indicated by `map`.
*/ */
struct cons_pointer hashmap_keys( struct cons_pointer mapp) { struct cons_pointer hashmap_keys( struct cons_pointer mapp ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
if ( hashmapp( mapp ) && truep( authorised( mapp, NIL ) )) { if ( hashmapp( mapp ) && truep( authorised( mapp, NIL ) ) ) {
struct vector_space_object *map = pointer_to_vso( mapp ); struct vector_space_object *map = pointer_to_vso( 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); }
}
}
} }
}
return result; return result;
} }
struct cons_pointer lisp_hashmap_keys( struct stack_frame *frame, struct cons_pointer lisp_hashmap_keys( struct stack_frame *frame,
struct cons_pointer frame_pointer, struct cons_pointer frame_pointer,
struct cons_pointer env ) { struct cons_pointer env ) {
return hashmap_keys( frame->arg[0] ); return hashmap_keys( frame->arg[0] );
} }
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 =
url_fwprintf( output, L"Hashmap with %d buckets:\n", payload->n_buckets ); &pointer_to_vso( pointer )->payload.hashmap;
url_fwprintf( output, L"\tHash function: " ); url_fwprintf( output, L"Hashmap with %d buckets:\n", payload->n_buckets );
print( output, payload->hash_fn ); url_fwprintf( output, L"\tHash function: " );
url_fwprintf( output, L"\n\tWrite ACL: " ); print( output, payload->hash_fn );
print( output, payload->write_acl ); url_fwprintf( output, L"\n\tWrite ACL: " );
url_fwprintf( output, L"\n\tBuckets:" ); print( output, payload->write_acl );
for ( int i = 0; i < payload->n_buckets; i++ ) { url_fwprintf( output, L"\n\tBuckets:" );
url_fwprintf( output, L"\n\t\t[%d]: ", i ); for ( int i = 0; i < payload->n_buckets; i++ ) {
print( output, payload->buckets[i] ); url_fwprintf( output, L"\n\t\t[%d]: ", i );
} print( output, payload->buckets[i] );
url_fwprintf( output, L"\n" ); }
url_fwprintf( output, L"\n" );
} }

2
src/memory/hashmap.h
View file

@ -21,7 +21,7 @@ uint32_t get_hash( struct cons_pointer ptr );
void free_hashmap( struct cons_pointer ptr ); void free_hashmap( struct cons_pointer ptr );
void dump_map( URL_FILE *output, struct cons_pointer pointer ); void dump_map( URL_FILE * output, struct cons_pointer pointer );
struct cons_pointer hashmap_get( struct cons_pointer mapp, struct cons_pointer hashmap_get( struct cons_pointer mapp,
struct cons_pointer key ); struct cons_pointer key );

1594
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

28
src/memory/vectorspace.c
View file

@ -119,24 +119,24 @@ struct cons_pointer make_vso( uint32_t tag, uint64_t payload_size ) {
* object. Dangerous! */ * object. Dangerous! */
void free_vso( struct cons_pointer pointer ) { void free_vso( struct cons_pointer pointer ) {
struct cons_space_object cell = pointer2cell( pointer ); struct cons_space_object cell = pointer2cell( pointer );
debug_printf( DEBUG_ALLOC, L"About to free vector-space object at 0x%lx\n", debug_printf( DEBUG_ALLOC, L"About to free vector-space object at 0x%lx\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;
switch ( vso->header.tag.value ) { switch ( vso->header.tag.value ) {
case HASHTV: case HASHTV:
free_hashmap( pointer ); free_hashmap( pointer );
break; break;
case STACKFRAMETV: case STACKFRAMETV:
free_stack_frame( get_stack_frame( pointer ) ); free_stack_frame( get_stack_frame( pointer ) );
break; break;
} }
// free( (void *)cell.payload.vectorp.address ); // free( (void *)cell.payload.vectorp.address );
debug_printf( DEBUG_ALLOC, L"Freed vector-space object at 0x%lx\n", debug_printf( DEBUG_ALLOC, L"Freed vector-space object at 0x%lx\n",
cell.payload.vectorp.address ); cell.payload.vectorp.address );
} }
// bool check_vso_tag( struct cons_pointer pointer, char * tag) { // bool check_vso_tag( struct cons_pointer pointer, char * tag) {

24
src/memory/vectorspace.h
View file

@ -61,7 +61,7 @@
struct cons_pointer make_vso( uint32_t tag, uint64_t payload_size ); struct cons_pointer make_vso( uint32_t tag, uint64_t payload_size );
void free_vso(struct cons_pointer pointer); void free_vso( struct cons_pointer pointer );
/** /**
* the header which forms the start of every vector space object. * the header which forms the start of every vector space object.
@ -86,18 +86,16 @@ 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 * namespace is that a hashmap has a write ACL
* namespace is that a hashmap has a write ACL * 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 buckets[]; /* actual hash buckets, which should be `NIL`
struct cons_pointer * or assoc lists or (possibly) further hashmaps. */
buckets[]; /* actual hash buckets, which should be `NIL`
* or assoc lists or (possibly) further hashmaps. */
}; };

169
src/ops/equal.c
View file

@ -20,9 +20,8 @@
* 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,10 +31,9 @@ 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);
return cell_a->tag.value == cell_b->tag.value; return cell_a->tag.value == cell_b->tag.value;
} }
@ -45,104 +43,95 @@ 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';
} }
/** /**
* 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: /* TODO: it is not OK to do this on the stack since list-like
/* TODO: it is not OK to do this on the stack since list-like * 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.car, cell_b->payload.cons.car) && equal(cell_a->payload.cons.cdr, && equal( cell_a->payload.cons.cdr,
cell_b->payload.cons.cdr); cell_b->payload.cons.cdr );
break; break;
case KEYTV: case KEYTV:
case STRINGTV: case STRINGTV:
case SYMBOLTV: case SYMBOLTV:
/* slightly complex because a string may or may not have a '\0' /* 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 * cell at the end, but I'll ignore that for now. I think in
* practice only the empty string will. * practice only the empty string will.
*/ */
/* TODO: it is not OK to do this on the stack since list-like /* TODO: it is not OK to do this on the stack since list-like
* 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 =
cell_a->payload.string.character == cell_a->payload.string.character ==
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 )
break; && end_of_string( cell_b->payload.string.cdr ) ) );
case INTEGERTV: break;
result = case INTEGERTV:
(cell_a->payload.integer.value == result =
cell_b->payload.integer.value) && ( cell_a->payload.integer.value ==
equal(cell_a->payload.integer.more, cell_b->payload.integer.value ) &&
cell_b->payload.integer.more); equal( cell_a->payload.integer.more,
break; cell_b->payload.integer.more );
case RATIOTV: break;
result = equal_ratio_ratio(a, b); case RATIOTV:
break; result = equal_ratio_ratio( a, b );
case REALTV: break;
{ case REALTV:
double num_a = to_long_double(a); {
double num_b = to_long_double(b); double num_a = to_long_double( a );
double max = double num_b = to_long_double( b );
fabs(num_a) > double max = fabs( num_a ) > fabs( num_b )
fabs(num_b) ? fabs( num_a )
? fabs(num_a) : fabs( num_b );
: fabs(num_b);
/* /*
* not more different than one part in a million - close enough * not more different than one part in a million - close enough
*/ */
result = fabs(num_a - num_b) < (max / 1000000.0); result = fabs( num_a - num_b ) < ( max / 1000000.0 );
}
break;
default:
result = false;
break;
} }
break; } else if ( numberp( a ) && numberp( b ) ) {
default: if ( integerp( a ) ) {
result = false; result = equal_integer_real( a, b );
break; } else if ( integerp( b ) ) {
} result = equal_integer_real( b, a );
}
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 * 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 * 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). * 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'm not certain what equality means for read and write streams, so
* I'll ignore them, too, for now. * I'll ignore them, too, for now.
*/ */
return result; return result;
} }

45
src/ops/intern.c
View file

@ -89,16 +89,16 @@ internedp( struct cons_pointer key, struct cons_pointer store ) {
* of that key from the store; otherwise return NIL. * of that key from the store; otherwise return NIL.
*/ */
struct cons_pointer c_assoc( struct cons_pointer key, struct cons_pointer c_assoc( struct cons_pointer key,
struct cons_pointer store ) { struct cons_pointer store ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
debug_print( L"c_assoc; key is `", DEBUG_BIND); debug_print( L"c_assoc; key is `", DEBUG_BIND );
debug_print_object( key, DEBUG_BIND); debug_print_object( key, DEBUG_BIND );
debug_print( L"`\n", DEBUG_BIND); debug_print( L"`\n", DEBUG_BIND );
if (consp(store)) { if ( consp( store ) ) {
for ( struct cons_pointer next = store; for ( struct cons_pointer next = store;
consp( next ); next = pointer2cell( next ).payload.cons.cdr ) { consp( next ); next = pointer2cell( next ).payload.cons.cdr ) {
struct cons_space_object entry = struct cons_space_object entry =
pointer2cell( pointer2cell( next ).payload.cons.car ); pointer2cell( pointer2cell( next ).payload.cons.car );
@ -107,15 +107,17 @@ struct cons_pointer c_assoc( struct cons_pointer key,
break; break;
} }
} }
} 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 );
debug_print_object( result, DEBUG_BIND); debug_print_object( result, DEBUG_BIND );
debug_println( DEBUG_BIND); debug_println( DEBUG_BIND );
return result; return result;
} }
@ -125,8 +127,8 @@ struct cons_pointer c_assoc( struct cons_pointer key,
* with this key/value pair added to the front. * with this key/value pair added to the front.
*/ */
struct cons_pointer struct cons_pointer
set( struct cons_pointer key, struct cons_pointer value, set( struct cons_pointer key, struct cons_pointer value,
struct cons_pointer store ) { struct cons_pointer store ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
debug_print( L"set: binding `", DEBUG_BIND ); debug_print( L"set: binding `", DEBUG_BIND );
@ -134,18 +136,18 @@ struct cons_pointer
debug_print( L"` to `", DEBUG_BIND ); debug_print( L"` to `", DEBUG_BIND );
debug_print_object( value, DEBUG_BIND ); debug_print_object( value, DEBUG_BIND );
debug_print( L"` in store ", DEBUG_BIND ); debug_print( L"` in store ", DEBUG_BIND );
debug_dump_object( store, DEBUG_BIND); debug_dump_object( store, DEBUG_BIND );
debug_println( DEBUG_BIND ); debug_println( DEBUG_BIND );
if (nilp( store) || consp(store)) { if ( nilp( store ) || consp( store ) ) {
result = make_cons( make_cons( key, value ), store ); result = make_cons( make_cons( key, value ), store );
} else if (hashmapp( store)) { } else if ( hashmapp( store ) ) {
result = hashmap_put( store, key, value); result = hashmap_put( store, key, value );
} }
debug_print( L"set returning ", DEBUG_BIND); debug_print( L"set returning ", DEBUG_BIND );
debug_print_object( result, DEBUG_BIND); debug_print_object( result, DEBUG_BIND );
debug_println( DEBUG_BIND); debug_println( DEBUG_BIND );
return result; return result;
} }
@ -195,4 +197,3 @@ intern( struct cons_pointer key, struct cons_pointer environment ) {
return result; return result;
} }

293
src/ops/lispops.c
View file

@ -106,7 +106,7 @@ struct cons_pointer eval_forms( struct stack_frame *frame,
list = c_cdr( list ); list = c_cdr( list );
} }
return c_reverse( result); return c_reverse( result );
} }
/** /**
@ -121,19 +121,18 @@ struct cons_pointer eval_forms( struct stack_frame *frame,
* *
* This is experimental. It almost certainly WILL change. * This is experimental. It almost certainly WILL change.
*/ */
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;
} }
} }
@ -306,8 +304,8 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
* @return the result of evaluating the function with its arguments. * @return the result of evaluating the function with its arguments.
*/ */
struct cons_pointer struct cons_pointer
c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) { struct cons_pointer env ) {
debug_print( L"Entering c_apply\n", DEBUG_EVAL ); debug_print( L"Entering c_apply\n", DEBUG_EVAL );
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
@ -322,122 +320,124 @@ struct cons_pointer
switch ( fn_cell.tag.value ) { switch ( fn_cell.tag.value ) {
case EXCEPTIONTV: case EXCEPTIONTV:
/* just pass exceptions straight back */ /* just pass exceptions straight back */
result = fn_pointer; result = fn_pointer;
break; break;
case FUNCTIONTV: case FUNCTIONTV:
{ {
struct cons_pointer exep = NIL; struct cons_pointer exep = NIL;
struct cons_pointer next_pointer = struct cons_pointer next_pointer =
make_stack_frame( frame_pointer, args, env ); make_stack_frame( frame_pointer, args, env );
inc_ref( next_pointer ); inc_ref( next_pointer );
if ( exceptionp( next_pointer ) ) { if ( exceptionp( next_pointer ) ) {
result = next_pointer; result = next_pointer;
} else { } else {
struct stack_frame *next = struct stack_frame *next =
get_stack_frame( next_pointer ); get_stack_frame( next_pointer );
result = result =
( *fn_cell.payload.function.executable ) ( next, ( *fn_cell.payload.function.executable ) ( next,
next_pointer, next_pointer,
env ); env );
dec_ref( next_pointer );
}
}
break;
case KEYTV:
result = c_assoc( fn_pointer,
eval_form(frame,
frame_pointer,
c_car( c_cdr( frame->arg[0])),
env));
break;
case LAMBDATV:
{
struct cons_pointer exep = NIL;
struct cons_pointer next_pointer =
make_stack_frame( frame_pointer, args, env );
inc_ref( next_pointer );
if ( exceptionp( next_pointer ) ) {
result = next_pointer;
} else {
struct stack_frame *next =
get_stack_frame( next_pointer );
result =
eval_lambda( fn_cell, next, next_pointer, env );
if ( !exceptionp( result ) ) {
dec_ref( next_pointer ); dec_ref( next_pointer );
} }
} }
} break;
break;
case KEYTV:
result = c_assoc( fn_pointer,
eval_form( frame,
frame_pointer,
c_car( c_cdr( frame->arg[0] ) ),
env ) );
break;
case LAMBDATV:
{
struct cons_pointer exep = NIL;
struct cons_pointer next_pointer =
make_stack_frame( frame_pointer, args, env );
inc_ref( next_pointer );
if ( exceptionp( next_pointer ) ) {
result = next_pointer;
} else {
struct stack_frame *next =
get_stack_frame( next_pointer );
result =
eval_lambda( fn_cell, next, next_pointer, env );
if ( !exceptionp( result ) ) {
dec_ref( next_pointer );
}
}
}
break;
case VECTORPOINTTV: case VECTORPOINTTV:
switch ( pointer_to_vso(fn_pointer)->header.tag.value) { switch ( pointer_to_vso( fn_pointer )->header.tag.value ) {
case HASHTV: case HASHTV:
/* \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;
case NLAMBDATV: case NLAMBDATV:
{ {
struct cons_pointer next_pointer = struct cons_pointer next_pointer =
make_special_frame( frame_pointer, args, env ); make_special_frame( frame_pointer, args, env );
inc_ref( next_pointer ); inc_ref( next_pointer );
if ( exceptionp( next_pointer ) ) { if ( exceptionp( next_pointer ) ) {
result = next_pointer; result = next_pointer;
} else { } else {
struct stack_frame *next = struct stack_frame *next =
get_stack_frame( next_pointer ); get_stack_frame( next_pointer );
result = result =
eval_lambda( fn_cell, next, next_pointer, env ); eval_lambda( fn_cell, next, next_pointer, env );
dec_ref( next_pointer ); dec_ref( next_pointer );
}
} }
} break;
break;
case SPECIALTV: case SPECIALTV:
{ {
struct cons_pointer next_pointer = struct cons_pointer next_pointer =
make_special_frame( frame_pointer, args, env ); make_special_frame( frame_pointer, args, env );
inc_ref( next_pointer ); inc_ref( next_pointer );
if ( exceptionp( next_pointer ) ) { if ( exceptionp( next_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, env ); ( next_pointer ),
debug_print( L"Special form returning: ", DEBUG_EVAL ); next_pointer, env );
debug_print_object( result, DEBUG_EVAL ); debug_print( L"Special form returning: ", DEBUG_EVAL );
debug_println( DEBUG_EVAL ); debug_print_object( result, DEBUG_EVAL );
dec_ref( next_pointer ); debug_println( DEBUG_EVAL );
dec_ref( next_pointer );
}
} }
} break;
break;
default: default:
{ {
int bs = sizeof( wchar_t ) * 1024; int bs = sizeof( wchar_t ) * 1024;
wchar_t *buffer = malloc( bs ); wchar_t *buffer = malloc( bs );
memset( buffer, '\0', bs ); memset( buffer, '\0', bs );
swprintf( buffer, bs, swprintf( buffer, bs,
L"Unexpected cell with tag %d (%4.4s) in function position", L"Unexpected cell with tag %d (%4.4s) in function position",
fn_cell.tag.value, &fn_cell.tag.bytes[0] ); fn_cell.tag.value, &fn_cell.tag.bytes[0] );
struct cons_pointer message = struct cons_pointer message =
c_string_to_lisp_string( buffer ); c_string_to_lisp_string( buffer );
free( buffer ); free( buffer );
result = throw_exception( message, frame_pointer ); result = throw_exception( message, frame_pointer );
} }
} }
} }
@ -479,7 +479,7 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer,
switch ( cell.tag.value ) { switch ( cell.tag.value ) {
case CONSTV: case CONSTV:
result = c_apply( frame, frame_pointer, env ); result = c_apply( frame, frame_pointer, env );
break; break;
case SYMBOLTV: case SYMBOLTV:
@ -781,9 +781,10 @@ 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 env ) { struct cons_pointer frame_pointer,
return make_integer( c_length( frame->arg[0]), NIL); struct cons_pointer env ) {
return make_integer( c_length( frame->arg[0] ), NIL );
} }
/** /**
@ -802,24 +803,24 @@ lisp_assoc( struct stack_frame *frame, struct cons_pointer frame_pointer,
return c_assoc( frame->arg[0], frame->arg[1] ); return c_assoc( frame->arg[0], frame->arg[1] );
} }
struct cons_pointer c_keys(struct cons_pointer store) { struct cons_pointer c_keys( struct cons_pointer store ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
if ( hashmapp( store ) ) { if ( hashmapp( store ) ) {
result = hashmap_keys( store ); result = hashmap_keys( store );
} else if ( consp( store ) ) { } else if ( consp( store ) ) {
for ( struct cons_pointer c = store; !nilp( c ); c = c_cdr( c ) ) { for ( struct cons_pointer c = store; !nilp( c ); c = c_cdr( c ) ) {
result = make_cons( c_car( c ), result ); result = make_cons( c_car( c ), result );
}
} }
}
return result; return result;
} }
struct cons_pointer lisp_keys( struct stack_frame *frame, struct cons_pointer lisp_keys( struct stack_frame *frame,
struct cons_pointer frame_pointer, struct cons_pointer frame_pointer,
struct cons_pointer env ) { struct cons_pointer env ) {
return c_keys( frame->arg[0]); return c_keys( frame->arg[0] );
} }
/** /**
@ -962,26 +963,26 @@ struct cons_pointer lisp_reverse( struct stack_frame *frame,
struct cons_pointer lisp_inspect( struct stack_frame *frame, struct cons_pointer lisp_inspect( struct stack_frame *frame,
struct cons_pointer frame_pointer, struct cons_pointer frame_pointer,
struct cons_pointer env ) { struct cons_pointer env ) {
debug_print( L"Entering lisp_inspect\n", DEBUG_IO ); debug_print( L"Entering lisp_inspect\n", DEBUG_IO );
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
struct cons_pointer out_stream = writep( frame->arg[1] ) struct cons_pointer out_stream = writep( frame->arg[1] )
? frame->arg[1] ? frame->arg[1]
: get_default_stream( false, env ); : get_default_stream( false, env );
URL_FILE *output; URL_FILE *output;
if ( writep( out_stream ) ) { if ( writep( out_stream ) ) {
debug_print( L"lisp_inspect: setting output stream\n", DEBUG_IO ); debug_print( L"lisp_inspect: setting output stream\n", DEBUG_IO );
debug_dump_object( out_stream, DEBUG_IO ); debug_dump_object( out_stream, DEBUG_IO );
output = pointer2cell( out_stream ).payload.stream.stream; output = pointer2cell( out_stream ).payload.stream.stream;
} else { } else {
output = file_to_url_file( stderr ); output = file_to_url_file( stderr );
} }
dump_object( output, frame->arg[0] ); dump_object( output, frame->arg[0] );
debug_print( L"Leaving lisp_inspect", DEBUG_IO ); debug_print( L"Leaving lisp_inspect", DEBUG_IO );
return result; return result;
} }
/** /**
@ -1064,7 +1065,7 @@ c_progn( struct stack_frame *frame, struct cons_pointer frame_pointer,
result = eval_form( frame, frame_pointer, c_car( expressions ), env ); result = eval_form( frame, frame_pointer, c_car( expressions ), env );
dec_ref( r ); dec_ref( r );
expressions = exceptionp(result) ? NIL : c_cdr( expressions ); expressions = exceptionp( result ) ? NIL : c_cdr( expressions );
} }
return result; return result;

4
src/ops/lispops.h
View file

@ -127,8 +127,8 @@ struct cons_pointer lisp_cdr( 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 lisp_inspect( struct stack_frame *frame, struct cons_pointer lisp_inspect( 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 lisp_eq( struct stack_frame *frame, struct cons_pointer lisp_eq( struct stack_frame *frame,
struct cons_pointer frame_pointer, struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );

51
src/time/psse_time.c
View file

@ -28,42 +28,44 @@
* 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)(14L * 1000000000L)); ( ( __int128 ) ( seconds_per_year * 1000000000L ) *
( __int128 ) ( 14L * 1000000000L ) );
/** /**
* Return the UNIX time value which represents this time, if it falls within * Return the UNIX time value which represents this time, if it falls within
* the period representable in UNIX time, or zero otherwise. * the period representable in UNIX time, or zero otherwise.
*/ */
long int lisp_time_to_unix_time(struct cons_pointer t) { long int lisp_time_to_unix_time( struct cons_pointer t ) {
long int result = 0; long int result = 0;
if (timep( t)) { if ( timep( t ) ) {
unsigned __int128 value = pointer2cell(t).payload.time.value; unsigned __int128 value = pointer2cell( t ).payload.time.value;
if (value > epoch_offset) { // \todo && value < UNIX time rollover if ( value > epoch_offset ) { // \todo && value < UNIX time rollover
result = ((value - epoch_offset) / 1000000000); result = ( ( value - epoch_offset ) / 1000000000 );
} }
} }
return result; return result;
} }
unsigned __int128 unix_time_to_lisp_time( time_t t) { unsigned __int128 unix_time_to_lisp_time( time_t t ) {
unsigned __int128 result = epoch_offset + (t * 1000000000); unsigned __int128 result = epoch_offset + ( t * 1000000000 );
return result; return result;
} }
struct cons_pointer make_time( struct cons_pointer integer_or_nil) { struct cons_pointer make_time( struct cons_pointer integer_or_nil ) {
struct cons_pointer pointer = allocate_cell( TIMETV ); struct cons_pointer pointer = allocate_cell( TIMETV );
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 ) );
} }
return pointer; return pointer;
@ -82,25 +84,26 @@ 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 env ) { struct cons_pointer frame_pointer,
return make_time( frame->arg[0]); struct cons_pointer env ) {
return make_time( frame->arg[0] );
} }
/** /**
* This is temporary, for bootstrapping. * This is temporary, for bootstrapping.
*/ */
struct cons_pointer time_to_string( struct cons_pointer pointer) { struct cons_pointer time_to_string( struct cons_pointer pointer ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
long int t = lisp_time_to_unix_time(pointer); long int t = lisp_time_to_unix_time( pointer );
if ( t != 0) { if ( t != 0 ) {
char * bytes = ctime(&t); char *bytes = ctime( &t );
int l = strlen(bytes) + 1; int l = strlen( bytes ) + 1;
wchar_t buffer[ l]; wchar_t buffer[l];
mbstowcs( buffer, bytes, l); mbstowcs( buffer, bytes, l );
result = c_string_to_lisp_string( buffer); result = c_string_to_lisp_string( buffer );
} }
return result; return result;

7
src/time/psse_time.h
View file

@ -13,8 +13,9 @@
#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 env ); struct cons_pointer frame_pointer,
struct cons_pointer time_to_string( struct cons_pointer pointer); struct cons_pointer env );
struct cons_pointer time_to_string( struct cons_pointer pointer );
#endif #endif