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

Reformatted code; made paths in generated documentation relative.

Browse source
This commit is contained in:
Simon Brooke 2026-02-14 15:32:59 +00:00
parent 222368bf64
commit 08a7c4153c
24 changed files with 496 additions and 716 deletions
Download patch file Download diff file Expand all files Collapse all files

97
src/arith/integer.c
View file

@ -90,10 +90,11 @@ struct cons_pointer make_integer( int64_t value, struct cons_pointer more ) {
struct cons_pointer result = NIL;
debug_print( L"Entering make_integer\n", DEBUG_ALLOC );
if ( integerp(more) && (pointer2cell( more ).payload.integer.value < 0))
{
printf("WARNING: negative value %" PRId64 " passed as `more` to `make_integer`\n",
pointer2cell( more ).payload.integer.value);
if ( integerp( more )
&& ( pointer2cell( more ).payload.integer.value < 0 ) ) {
printf( "WARNING: negative value %" PRId64
" passed as `more` to `make_integer`\n",
pointer2cell( more ).payload.integer.value );
}
if ( integerp( more ) || nilp( more ) ) {
@ -128,20 +129,23 @@ struct cons_pointer make_integer( int64_t value, struct cons_pointer more ) {
struct cons_pointer acquire_integer( int64_t value, struct cons_pointer more ) {
struct cons_pointer result;
if ( !nilp( more) || value < 0 || value >= SMALL_INT_LIMIT) {
debug_print( L"acquire_integer passing to make_integer (outside small int range)\n", DEBUG_ALLOC );
result = make_integer( value, more);
if ( !nilp( more ) || value < 0 || value >= SMALL_INT_LIMIT ) {
debug_print
( L"acquire_integer passing to make_integer (outside small int range)\n",
DEBUG_ALLOC );
result = make_integer( value, more );
} else {
if ( !small_int_cache_initialised) {
for (int64_t i = 0; i < SMALL_INT_LIMIT; i++) {
small_int_cache[i] = make_integer( i, NIL);
pointer2cell(small_int_cache[i]).count = UINT32_MAX; // lock it in so it can't be GC'd
if ( !small_int_cache_initialised ) {
for ( int64_t i = 0; i < SMALL_INT_LIMIT; i++ ) {
small_int_cache[i] = make_integer( i, NIL );
pointer2cell( small_int_cache[i] ).count = UINT32_MAX; // lock it in so it can't be GC'd
}
small_int_cache_initialised = true;
small_int_cache_initialised = true;
debug_print( L"small_int_cache initialised.\n", DEBUG_ALLOC );
}
debug_printf( DEBUG_ALLOC, L"acquire_integer: returning %" PRId64 "\n", value);
debug_printf( DEBUG_ALLOC, L"acquire_integer: returning %" PRId64 "\n",
value );
result = small_int_cache[value];
}
return result;
@ -156,15 +160,17 @@ struct cons_pointer acquire_integer( int64_t value, struct cons_pointer more ) {
*
* @param p a pointer, expected to be to an integer.
*/
void release_integer( struct cons_pointer p) {
struct cons_space_object o = pointer2cell( p);
if ( !integerp( p) || // what I've been passed isn't an integer;
!nilp( o.payload.integer.more) || // or it's a bignum;
o.payload.integer.value >= SMALL_INT_LIMIT || // or it's bigger than the small int cache limit;
!eq( p, small_int_cache[ o.payload.integer.value]) // or it's simply not the copy in the cache...
) { dec_ref( p); } else {
debug_printf( DEBUG_ALLOC, L"release_integer: releasing %" PRId64 "\n",
o.payload.integer.value);
void release_integer( struct cons_pointer p ) {
struct cons_space_object o = pointer2cell( p );
if ( !integerp( p ) || // what I've been passed isn't an integer;
!nilp( o.payload.integer.more ) || // or it's a bignum;
o.payload.integer.value >= SMALL_INT_LIMIT || // or it's bigger than the small int cache limit;
!eq( p, small_int_cache[o.payload.integer.value] ) // or it's simply not the copy in the cache...
) {
dec_ref( p );
} else {
debug_printf( DEBUG_ALLOC, L"release_integer: releasing %" PRId64 "\n",
o.payload.integer.value );
}
}
@ -192,7 +198,7 @@ __int128_t int128_to_integer( __int128_t val,
if ( MAX_INTEGER >= val ) {
carry = 0;
} else {
carry = val % INT_CELL_BASE;
carry = val % INT_CELL_BASE;
debug_printf( DEBUG_ARITH,
L"int128_to_integer: 64 bit overflow; setting carry to %ld\n",
( int64_t ) carry );
@ -200,7 +206,7 @@ __int128_t int128_to_integer( __int128_t val,
}
struct cons_space_object *newc = &pointer2cell( new );
newc->payload.integer.value = (int64_t)val;
newc->payload.integer.value = ( int64_t ) val;
if ( integerp( less_significant ) ) {
struct cons_space_object *lsc = &pointer2cell( less_significant );
@ -239,7 +245,7 @@ struct cons_pointer add_integers( struct cons_pointer a,
while ( !nilp( a ) || !nilp( b ) || carry != 0 ) {
__int128_t av = cell_value( a, '+', is_first_cell );
__int128_t bv = cell_value( b, '+', is_first_cell );
__int128_t rv = (av + bv) + carry;
__int128_t rv = ( av + bv ) + carry;
debug_print( L"add_integers: av = ", DEBUG_ARITH );
debug_print_128bit( av, DEBUG_ARITH );
@ -251,8 +257,9 @@ struct cons_pointer add_integers( struct cons_pointer a,
debug_print_128bit( rv, DEBUG_ARITH );
debug_print( L"\n", DEBUG_ARITH );
if ( carry == 0 && ( rv >= 0 || rv < SMALL_INT_LIMIT)) {
result = acquire_integer( (int64_t)(rv & 0xffffffff), NIL);
if ( carry == 0 && ( rv >= 0 || rv < SMALL_INT_LIMIT ) ) {
result =
acquire_integer( ( int64_t ) ( rv & 0xffffffff ), NIL );
break;
} else {
struct cons_pointer new = make_integer( 0, NIL );
@ -281,7 +288,7 @@ struct cons_pointer add_integers( struct cons_pointer a,
struct cons_pointer base_partial( int depth ) {
struct cons_pointer result = NIL;
debug_printf( DEBUG_ARITH, L"base_partial: depth = %d\n", depth);
debug_printf( DEBUG_ARITH, L"base_partial: depth = %d\n", depth );
for ( int i = 0; i < depth; i++ ) {
result = acquire_integer( 0, result );
@ -299,15 +306,15 @@ struct cons_pointer base_partial( int depth ) {
* numbering system here is base INT_CELL_BASE, currently x0fffffffffffffffL
*/
struct cons_pointer append_cell( struct cons_pointer partial,
struct cons_pointer digit ) {
struct cons_space_object cell = pointer2cell( partial);
struct cons_pointer digit ) {
struct cons_space_object cell = pointer2cell( partial );
// TODO: I should recursively copy the whole bignum chain, because
// we're still destructively modifying the end of it.
struct cons_pointer c = make_integer( cell.payload.integer.value,
cell.payload.integer.more);
struct cons_pointer c = make_integer( cell.payload.integer.value,
cell.payload.integer.more );
struct cons_pointer result = partial;
if ( nilp( partial)) {
if ( nilp( partial ) ) {
result = digit;
} else {
// find the last digit in the chain...
@ -376,9 +383,10 @@ struct cons_pointer multiply_integers( struct cons_pointer a,
/* if xj exceeds one digit, break it into the digit dj and
* the carry */
carry = xj >> INTEGER_BIT_SHIFT;
struct cons_pointer dj = acquire_integer( xj & MAX_INTEGER, NIL );
struct cons_pointer dj =
acquire_integer( xj & MAX_INTEGER, NIL );
replace_integer_p( ri, append_cell( ri, dj ));
replace_integer_p( ri, append_cell( ri, dj ) );
// struct cons_pointer new_ri = append_cell( ri, dj );
// release_integer( ri);
// ri = new_ri;
@ -387,7 +395,7 @@ struct cons_pointer multiply_integers( struct cons_pointer a,
/* if carry is not equal to zero, append it as a final cell
* to ri */
if ( carry != 0 ) {
replace_integer_i( ri, carry)
replace_integer_i( ri, carry )
}
/* add ri to result */
@ -412,14 +420,16 @@ struct cons_pointer multiply_integers( struct cons_pointer a,
struct cons_pointer integer_to_string_add_digit( int digit, int digits,
struct cons_pointer tail ) {
wint_t character = btowc( hex_digits[digit] );
debug_printf( DEBUG_IO, L"integer_to_string_add_digit: digit is %d, digits is %d; returning: ", digit, digits);
struct cons_pointer r = ( digits % 3 == 0 ) ?
make_string( L',', make_string( character,
tail ) ) :
debug_printf( DEBUG_IO,
L"integer_to_string_add_digit: digit is %d, digits is %d; returning: ",
digit, digits );
struct cons_pointer r =
( digits % 3 == 0 ) ? make_string( L',', make_string( character,
tail ) ) :
make_string( character, tail );
debug_print_object( r, DEBUG_IO);
debug_println( DEBUG_IO);
debug_print_object( r, DEBUG_IO );
debug_println( DEBUG_IO );
return r;
}
@ -460,7 +470,8 @@ struct cons_pointer integer_to_string( struct cons_pointer int_pointer,
while ( accumulator > 0 || !nilp( next ) ) {
if ( accumulator < MAX_INTEGER && !nilp( next ) ) {
accumulator +=
( pointer2cell( next ).payload.integer.value % INT_CELL_BASE );
( pointer2cell( next ).payload.integer.value %
INT_CELL_BASE );
next = pointer2cell( next ).payload.integer.more;
}
int offset = ( int ) ( accumulator % base );

2
src/arith/integer.h
View file

@ -21,7 +21,7 @@ struct cons_pointer make_integer( int64_t value, struct cons_pointer more );
struct cons_pointer acquire_integer( int64_t value, struct cons_pointer more );
void release_integer( struct cons_pointer p);
void release_integer( struct cons_pointer p );
struct cons_pointer add_integers( struct cons_pointer a,
struct cons_pointer b );

28
src/arith/ratio.c
View file

@ -64,15 +64,16 @@ struct cons_pointer simplify_ratio( struct cons_pointer pointer ) {
if ( drrv / gcd == 1 ) {
result = acquire_integer( ddrv / gcd, NIL );
} else {
debug_printf( DEBUG_ARITH,
L"simplify_ratio: %ld/%ld => %ld/%ld\n", ddrv, drrv, ddrv/gcd, drrv/gcd);
debug_printf( DEBUG_ARITH,
L"simplify_ratio: %ld/%ld => %ld/%ld\n",
ddrv, drrv, ddrv / gcd, drrv / gcd );
result =
make_ratio( acquire_integer( ddrv / gcd, NIL ),
acquire_integer( drrv / gcd, NIL ) );
}
}
}
}
}
// TODO: else throw exception?
return result;
@ -126,8 +127,12 @@ struct cons_pointer add_ratio_ratio( struct cons_pointer arg1,
r = add_ratio_ratio( r1, r2 );
if (!eq( r, r1)) { dec_ref( r1);}
if (!eq( r, r2)) { dec_ref( r2);}
if ( !eq( r, r1 ) ) {
dec_ref( r1 );
}
if ( !eq( r, r2 ) ) {
dec_ref( r2 );
}
/* because the references on dd1vm, dr1vm, dd2vm and dr2vm were
* never incremented except when making r1 and r2, decrementing
@ -238,12 +243,11 @@ struct cons_pointer multiply_ratio_ratio( struct
struct cons_pointer dividend = acquire_integer( ddrv, NIL );
struct cons_pointer divisor = acquire_integer( drrv, NIL );
struct cons_pointer unsimplified =
make_ratio( dividend, divisor);
struct cons_pointer unsimplified = make_ratio( dividend, divisor );
result = simplify_ratio( unsimplified );
release_integer( dividend);
release_integer( divisor);
release_integer( dividend );
release_integer( divisor );
if ( !eq( unsimplified, result ) ) {
dec_ref( unsimplified );
@ -320,8 +324,10 @@ struct cons_pointer make_ratio( struct cons_pointer dividend,
cell->payload.ratio.dividend = dividend;
cell->payload.ratio.divisor = divisor;
result = simplify_ratio( unsimplified);
if ( !eq( result, unsimplified)) { dec_ref( unsimplified); }
result = simplify_ratio( unsimplified );
if ( !eq( result, unsimplified ) ) {
dec_ref( unsimplified );
}
} else {
result =
throw_exception( c_string_to_lisp_string

159
src/init.c
View file

@ -45,19 +45,20 @@
* @param location_descriptor a description of where the pointer was caught.
* @return struct cons_pointer
*/
struct cons_pointer check_exception( struct cons_pointer pointer, char * location_descriptor) {
struct cons_pointer check_exception( struct cons_pointer pointer,
char *location_descriptor ) {
struct cons_pointer result = NIL;
struct cons_space_object * object = &pointer2cell( pointer);
struct cons_space_object *object = &pointer2cell( pointer );
if ( exceptionp( pointer)) {
fprintf( stderr, "ERROR: Exception at %s: ", location_descriptor);
if ( exceptionp( pointer ) ) {
fprintf( stderr, "ERROR: Exception at %s: ", location_descriptor );
URL_FILE *ustderr = file_to_url_file( stderr );
fwide( stderr, 1 );
print( ustderr, object->payload.exception.payload );
free( ustderr );
dec_ref( pointer);
dec_ref( pointer );
} else {
result = pointer;
}
@ -68,21 +69,21 @@ struct cons_pointer check_exception( struct cons_pointer pointer, char * locatio
struct cons_pointer init_name_symbol = NIL;
struct cons_pointer init_primitive_symbol = NIL;
void maybe_bind_init_symbols() {
if ( nilp( init_name_symbol)) {
void maybe_bind_init_symbols( ) {
if ( nilp( init_name_symbol ) ) {
init_name_symbol = c_string_to_lisp_keyword( L"name" );
}
if ( nilp( init_primitive_symbol)) {
if ( nilp( init_primitive_symbol ) ) {
init_primitive_symbol = c_string_to_lisp_keyword( L"primitive" );
}
if ( nilp( privileged_symbol_nil)) {
privileged_symbol_nil = c_string_to_lisp_symbol( L"nil");
if ( nilp( privileged_symbol_nil ) ) {
privileged_symbol_nil = c_string_to_lisp_symbol( L"nil" );
}
}
void free_init_symbols() {
dec_ref( init_name_symbol);
dec_ref( init_primitive_symbol);
void free_init_symbols( ) {
dec_ref( init_name_symbol );
dec_ref( init_primitive_symbol );
}
/**
@ -92,20 +93,22 @@ void free_init_symbols() {
* the name on the source pointer. Would make stack frames potentially
* more readable and aid debugging generally.
*/
struct cons_pointer bind_function( wchar_t *name, struct cons_pointer ( *executable )
( struct stack_frame *,
struct cons_pointer, struct cons_pointer ) ) {
struct cons_pointer bind_function( wchar_t *name,
struct cons_pointer ( *executable )
( struct stack_frame *,
struct cons_pointer,
struct cons_pointer ) ) {
struct cons_pointer n = c_string_to_lisp_symbol( name );
struct cons_pointer meta =
make_cons( make_cons( init_primitive_symbol, TRUE ),
make_cons( make_cons( init_name_symbol, n ),
NIL ) );
struct cons_pointer r = check_exception(
deep_bind( n, make_function( meta, executable ) ),
"bind_function");
dec_ref( n);
struct cons_pointer r =
check_exception( deep_bind( n, make_function( meta, executable ) ),
"bind_function" );
dec_ref( n );
return r;
}
@ -114,20 +117,21 @@ struct cons_pointer bind_function( wchar_t *name, struct cons_pointer ( *executa
* Bind this compiled `executable` function, as a Lisp special form, to
* this `name` in the `oblist`.
*/
struct cons_pointer bind_special( wchar_t *name, struct cons_pointer ( *executable )
( struct stack_frame *,
struct cons_pointer, struct cons_pointer ) ) {
struct cons_pointer bind_special( wchar_t *name,
struct cons_pointer ( *executable )
( struct stack_frame *, struct cons_pointer,
struct cons_pointer ) ) {
struct cons_pointer n = c_string_to_lisp_symbol( name );
struct cons_pointer meta =
make_cons( make_cons( init_primitive_symbol, TRUE ),
make_cons( make_cons( init_name_symbol, n), NIL ) );
make_cons( make_cons( init_name_symbol, n ), NIL ) );
struct cons_pointer r =
check_exception(deep_bind( n, make_special( meta, executable ) ),
"bind_special");
dec_ref( n);
struct cons_pointer r =
check_exception( deep_bind( n, make_special( meta, executable ) ),
"bind_special" );
dec_ref( n );
return r;
}
@ -135,14 +139,14 @@ struct cons_pointer bind_special( wchar_t *name, struct cons_pointer ( *executab
/**
* Bind this `value` to this `symbol` in the `oblist`.
*/
struct cons_pointer
bind_symbol_value( struct cons_pointer symbol, struct cons_pointer value, bool lock) {
struct cons_pointer r = check_exception(
deep_bind( symbol, value ),
"bind_symbol_value");
struct cons_pointer
bind_symbol_value( struct cons_pointer symbol, struct cons_pointer value,
bool lock ) {
struct cons_pointer r = check_exception( deep_bind( symbol, value ),
"bind_symbol_value" );
if ( lock && !exceptionp( r)){
struct cons_space_object * cell = & pointer2cell( r);
if ( lock && !exceptionp( r ) ) {
struct cons_space_object *cell = &pointer2cell( r );
cell->count = UINT32_MAX;
}
@ -153,12 +157,13 @@ bind_symbol_value( struct cons_pointer symbol, struct cons_pointer value, bool l
/**
* Bind this `value` to this `name` in the `oblist`.
*/
struct cons_pointer bind_value( wchar_t *name, struct cons_pointer value, bool lock ) {
struct cons_pointer bind_value( wchar_t *name, struct cons_pointer value,
bool lock ) {
struct cons_pointer p = c_string_to_lisp_symbol( name );
struct cons_pointer r = bind_symbol_value( p, value, lock);
struct cons_pointer r = bind_symbol_value( p, value, lock );
dec_ref( p);
dec_ref( p );
return r;
}
@ -173,7 +178,7 @@ void print_banner( ) {
*
* @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"\t-d\tDump memory to standard out at end of run (copious!);\n" );
@ -201,7 +206,7 @@ int main( int argc, char *argv[] ) {
int option;
bool dump_at_end = false;
bool show_prompt = false;
char * infilename = NULL;
char *infilename = NULL;
setlocale( LC_ALL, "" );
if ( io_init( ) != 0 ) {
@ -219,7 +224,7 @@ int main( int argc, char *argv[] ) {
print_options( stdout );
exit( 0 );
break;
case 'i' :
case 'i':
infilename = optarg;
break;
case 'p':
@ -236,9 +241,9 @@ int main( int argc, char *argv[] ) {
}
}
initialise_cons_pages();
initialise_cons_pages( );
maybe_bind_init_symbols();
maybe_bind_init_symbols( );
if ( show_prompt ) {
@ -254,7 +259,7 @@ int main( int argc, char *argv[] ) {
/*
* privileged variables (keywords)
*/
bind_symbol_value( privileged_symbol_nil, NIL, true);
bind_symbol_value( privileged_symbol_nil, NIL, true );
bind_value( L"t", TRUE, true );
/*
@ -267,43 +272,49 @@ int main( int argc, char *argv[] ) {
fwide( stderr, 1 );
fwide( sink->handle.file, 1 );
FILE *infile = infilename == NULL ? stdin : fopen( infilename, "r");
FILE *infile = infilename == NULL ? stdin : fopen( infilename, "r" );
lisp_io_in = bind_value( C_IO_IN, make_read_stream( file_to_url_file(infile),
make_cons( make_cons
( c_string_to_lisp_keyword
( L"url" ),
c_string_to_lisp_string
( L"system:standard input" ) ),
NIL ) ), false );
lisp_io_out = bind_value( C_IO_OUT,
make_write_stream( file_to_url_file( stdout ),
lisp_io_in =
bind_value( C_IO_IN,
make_read_stream( file_to_url_file( infile ),
make_cons( make_cons
( c_string_to_lisp_keyword
( L"url" ),
c_string_to_lisp_string
( L"system:standard input" ) ),
NIL ) ), false );
lisp_io_out =
bind_value( C_IO_OUT,
make_write_stream( file_to_url_file( stdout ),
make_cons( make_cons
( c_string_to_lisp_keyword
( L"url" ),
c_string_to_lisp_string
( L"system:standard output]" ) ),
NIL ) ), false );
bind_value( L"*log*",
make_write_stream( file_to_url_file( stderr ),
make_cons( make_cons
( c_string_to_lisp_keyword
( L"url" ),
c_string_to_lisp_string
( L"system:standard output]" ) ),
NIL ) ), false);
bind_value( L"*log*", make_write_stream( file_to_url_file( stderr ),
make_cons( make_cons
( c_string_to_lisp_keyword
( L"url" ),
c_string_to_lisp_string
( L"system:standard log" ) ),
NIL ) ), false );
bind_value( L"*sink*", make_write_stream( sink,
make_cons( make_cons
( c_string_to_lisp_keyword
( L"url" ),
c_string_to_lisp_string
( L"system:standard sink" ) ),
NIL ) ), false );
( L"system:standard log" ) ),
NIL ) ), false );
bind_value( L"*sink*",
make_write_stream( sink,
make_cons( make_cons
( c_string_to_lisp_keyword
( L"url" ),
c_string_to_lisp_string
( L"system:standard sink" ) ),
NIL ) ), false );
/*
* the default prompt
*/
prompt_name = bind_value( L"*prompt*",
show_prompt ? c_string_to_lisp_symbol( L":: " ) : NIL, false );
show_prompt ? c_string_to_lisp_symbol( L":: " ) :
NIL, false );
/*
* primitive function operations
*/
@ -377,7 +388,7 @@ int main( int argc, char *argv[] ) {
debug_print( L"Freeing oblist\n", DEBUG_BOOTSTRAP );
dec_ref( oblist );
free_init_symbols();
free_init_symbols( );
summarise_allocation( );
curl_global_cleanup( );

14
src/io/fopen.c
View file

@ -99,7 +99,7 @@ static size_t write_callback( char *buffer,
}
/* use to attempt to fill the read buffer up to requested number of bytes */
static int fill_buffer( URL_FILE * file, size_t want ) {
static int fill_buffer( URL_FILE *file, size_t want ) {
fd_set fdread;
fd_set fdwrite;
fd_set fdexcep;
@ -181,7 +181,7 @@ static int fill_buffer( URL_FILE * file, size_t want ) {
}
/* use to remove want bytes from the front of a files buffer */
static int use_buffer( URL_FILE * file, size_t want ) {
static int use_buffer( URL_FILE *file, size_t want ) {
/* sort out buffer */
if ( ( file->buffer_pos - want ) <= 0 ) {
/* ditch buffer - write will recreate */
@ -255,7 +255,7 @@ URL_FILE *url_fopen( const char *url, const char *operation ) {
return file;
}
int url_fclose( URL_FILE * file ) {
int url_fclose( URL_FILE *file ) {
int ret = 0; /* default is good return */
switch ( file->type ) {
@ -283,7 +283,7 @@ int url_fclose( URL_FILE * file ) {
return ret;
}
int url_feof( URL_FILE * file ) {
int url_feof( URL_FILE *file ) {
int ret = 0;
switch ( file->type ) {
@ -304,7 +304,7 @@ int url_feof( URL_FILE * file ) {
return ret;
}
size_t url_fread( void *ptr, size_t size, size_t nmemb, URL_FILE * file ) {
size_t url_fread( void *ptr, size_t size, size_t nmemb, URL_FILE *file ) {
size_t want;
switch ( file->type ) {
@ -343,7 +343,7 @@ size_t url_fread( void *ptr, size_t size, size_t nmemb, URL_FILE * file ) {
return want;
}
char *url_fgets( char *ptr, size_t size, URL_FILE * file ) {
char *url_fgets( char *ptr, size_t size, URL_FILE *file ) {
size_t want = size - 1; /* always need to leave room for zero termination */
size_t loop;
@ -390,7 +390,7 @@ char *url_fgets( char *ptr, size_t size, URL_FILE * file ) {
return ptr; /*success */
}
void url_rewind( URL_FILE * file ) {
void url_rewind( URL_FILE *file ) {
switch ( file->type ) {
case CFTYPE_FILE:
rewind( file->handle.file ); /* passthrough */

2
src/io/history.c
View file

@ -11,4 +11,4 @@
*
* (c) 2025 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
*/

2
src/io/history.h
View file

@ -11,4 +11,4 @@
*
* (c) 2025 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
*/

15
src/io/io.c
View file

@ -131,7 +131,7 @@ char *lisp_string_to_c_string( struct cons_pointer s ) {
* @param f the file to be wrapped;
* @return the new handle, or null if no such handle could be allocated.
*/
URL_FILE *file_to_url_file( FILE * f ) {
URL_FILE *file_to_url_file( FILE *f ) {
URL_FILE *result = ( URL_FILE * ) malloc( sizeof( URL_FILE ) );
if ( result != NULL ) {
@ -148,7 +148,7 @@ URL_FILE *file_to_url_file( FILE * f ) {
* @param file the stream to read from;
* @return the next wide character on the stream, or zero if no more.
*/
wint_t url_fgetwc( URL_FILE * input ) {
wint_t url_fgetwc( URL_FILE *input ) {
wint_t result = -1;
if ( ungotten != 0 ) {
@ -217,7 +217,7 @@ wint_t url_fgetwc( URL_FILE * input ) {
return result;
}
wint_t url_ungetwc( wint_t wc, URL_FILE * input ) {
wint_t url_ungetwc( wint_t wc, URL_FILE *input ) {
wint_t result = -1;
switch ( input->type ) {
@ -284,7 +284,7 @@ struct cons_pointer add_meta_string( struct cons_pointer meta, wchar_t *key,
}
struct cons_pointer add_meta_time( struct cons_pointer meta, wchar_t *key,
time_t * value ) {
time_t *value ) {
/* I don't yet have a concept of a date-time object, which is a
* bit of an oversight! */
char datestring[256];
@ -410,8 +410,7 @@ void collect_meta( struct cons_pointer stream, char *url ) {
*/
struct cons_pointer get_default_stream( bool inputp, struct cons_pointer env ) {
struct cons_pointer result = NIL;
struct cons_pointer stream_name =
inputp ? lisp_io_in : lisp_io_out;
struct cons_pointer stream_name = inputp ? lisp_io_in : lisp_io_out;
result = c_assoc( stream_name, env );
@ -509,8 +508,8 @@ lisp_read_char( struct stack_frame *frame, struct cons_pointer frame_pointer,
if ( readp( frame->arg[0] ) ) {
result =
make_string( url_fgetwc
( pointer2cell( frame->arg[0] ).payload.stream.
stream ), NIL );
( pointer2cell( frame->arg[0] ).payload.
stream.stream ), NIL );
}
return result;

18
src/io/print.c
View file

@ -32,7 +32,7 @@
* onto this `output`; if `pointer` does not indicate a string or symbol,
* don't print anything but just return.
*/
void print_string_contents( URL_FILE * output, struct cons_pointer pointer ) {
void print_string_contents( URL_FILE *output, struct cons_pointer pointer ) {
while ( stringp( pointer ) || symbolp( pointer ) || keywordp( pointer ) ) {
struct cons_space_object *cell = &pointer2cell( pointer );
wchar_t c = cell->payload.string.character;
@ -49,7 +49,7 @@ void print_string_contents( URL_FILE * output, struct cons_pointer pointer ) {
* the stream at this `output`, prepending and appending double quote
* characters.
*/
void print_string( URL_FILE * output, struct cons_pointer pointer ) {
void print_string( URL_FILE *output, struct cons_pointer pointer ) {
url_fputwc( btowc( '"' ), output );
print_string_contents( output, pointer );
url_fputwc( btowc( '"' ), output );
@ -61,7 +61,7 @@ void print_string( URL_FILE * output, struct cons_pointer pointer ) {
* a space character.
*/
void
print_list_contents( URL_FILE * output, struct cons_pointer pointer,
print_list_contents( URL_FILE *output, struct cons_pointer pointer,
bool initial_space ) {
struct cons_space_object *cell = &pointer2cell( pointer );
@ -82,13 +82,13 @@ print_list_contents( URL_FILE * output, struct cons_pointer pointer,
}
}
void print_list( URL_FILE * output, struct cons_pointer pointer ) {
void print_list( URL_FILE *output, struct cons_pointer pointer ) {
url_fputws( L"(", output );
print_list_contents( output, pointer, false );
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 ) ) {
struct vector_space_object *vso = pointer_to_vso( map );
@ -110,7 +110,7 @@ void print_map( URL_FILE * output, struct cons_pointer map ) {
}
}
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 );
switch ( vso->header.tag.value ) {
case HASHTV:
@ -126,7 +126,7 @@ void print_vso( URL_FILE * output, struct cons_pointer pointer ) {
/**
* stolen from https://stackoverflow.com/questions/11656241/how-to-print-uint128-t-number-using-gcc
*/
void print_128bit( URL_FILE * output, __int128_t n ) {
void print_128bit( URL_FILE *output, __int128_t n ) {
if ( n == 0 ) {
fwprintf( stderr, L"0" );
} else {
@ -148,7 +148,7 @@ void print_128bit( URL_FILE * output, __int128_t n ) {
* Print the cons-space object indicated by `pointer` to the stream indicated
* by `output`.
*/
struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) {
struct cons_pointer print( URL_FILE *output, struct cons_pointer pointer ) {
struct cons_space_object cell = pointer2cell( pointer );
char *buffer;
@ -272,6 +272,6 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) {
return pointer;
}
void println( URL_FILE * output ) {
void println( URL_FILE *output ) {
url_fputws( L"\n", output );
}

33
src/io/read.c
View file

@ -83,14 +83,14 @@ struct cons_pointer c_quote( struct cons_pointer arg ) {
* 3. one or more symbols separated by slashes; or
* 4. keywords (with leading colons) interspersed with symbols (prefixed by slashes).
*/
struct cons_pointer read_path( URL_FILE * input, wint_t initial,
struct cons_pointer read_path( URL_FILE *input, wint_t initial,
struct cons_pointer q ) {
bool done = false;
struct cons_pointer prefix = NIL;
switch ( initial ) {
case '/':
prefix = c_string_to_lisp_symbol( L"oblist" );
prefix = make_cons( c_string_to_lisp_symbol( L"oblist" ), NIL);
break;
case '$':
case LSESSION:
@ -155,7 +155,7 @@ struct cons_pointer read_path( URL_FILE * input, wint_t initial,
struct cons_pointer read_continuation( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env,
URL_FILE * input, wint_t initial ) {
URL_FILE *input, wint_t initial ) {
debug_print( L"entering read_continuation\n", DEBUG_IO );
struct cons_pointer result = NIL;
@ -287,7 +287,7 @@ struct cons_pointer read_continuation( struct stack_frame *frame,
*/
struct cons_pointer read_number( struct stack_frame *frame,
struct cons_pointer frame_pointer,
URL_FILE * input,
URL_FILE *input,
wint_t initial, bool seen_period ) {
debug_print( L"entering read_number\n", DEBUG_IO );
@ -308,7 +308,8 @@ struct cons_pointer read_number( struct stack_frame *frame,
initial );
for ( c = initial; iswdigit( c )
|| c == LPERIOD || c == LSLASH || c == LCOMMA; c = url_fgetwc( input ) ) {
|| c == LPERIOD || c == LSLASH || c == LCOMMA;
c = url_fgetwc( input ) ) {
switch ( c ) {
case LPERIOD:
if ( seen_period || !nilp( dividend ) ) {
@ -342,8 +343,8 @@ struct cons_pointer read_number( struct stack_frame *frame,
break;
default:
result = add_integers( multiply_integers( result, base ),
acquire_integer( ( int ) c - ( int ) '0',
NIL ) );
acquire_integer( ( int ) c -
( int ) '0', NIL ) );
debug_printf( DEBUG_IO,
L"read_number: added character %c, result now ",
@ -366,10 +367,10 @@ struct cons_pointer read_number( struct stack_frame *frame,
debug_print( L"read_number: converting result to real\n", DEBUG_IO );
struct cons_pointer div = make_ratio( result,
acquire_integer( powl
( to_long_double
( base ),
places_of_decimals ),
NIL ) );
( to_long_double
( base ),
places_of_decimals ),
NIL ) );
inc_ref( div );
result = make_real( to_long_double( div ) );
@ -400,7 +401,7 @@ struct cons_pointer read_number( struct stack_frame *frame,
struct cons_pointer read_list( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env,
URL_FILE * input, wint_t initial ) {
URL_FILE *input, wint_t initial ) {
struct cons_pointer result = NIL;
wint_t c;
@ -440,7 +441,7 @@ struct cons_pointer read_list( struct stack_frame *frame,
struct cons_pointer read_map( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env,
URL_FILE * input, wint_t initial ) {
URL_FILE *input, wint_t initial ) {
// set write ACL to true whilst creating to prevent GC churn
struct cons_pointer result =
make_hashmap( DFLT_HASHMAP_BUCKETS, NIL, TRUE );
@ -480,7 +481,7 @@ struct cons_pointer read_map( struct stack_frame *frame,
* so delimited in which case it may not contain whitespace (unless escaped)
* but may contain a double quote character (probably not a good idea!)
*/
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 cdr = NIL;
struct cons_pointer result;
switch ( initial ) {
@ -503,7 +504,7 @@ struct cons_pointer read_string( URL_FILE * input, wint_t initial ) {
return result;
}
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 ) {
struct cons_pointer cdr = NIL;
struct cons_pointer result;
@ -558,7 +559,7 @@ struct cons_pointer read_symbol_or_key( URL_FILE * input, uint32_t tag,
struct cons_pointer read( struct
stack_frame
*frame, struct cons_pointer frame_pointer,
struct cons_pointer env, URL_FILE * input ) {
struct cons_pointer env, URL_FILE *input ) {
return read_continuation( frame, frame_pointer, env, input,
url_fgetwc( input ) );
}

12
src/memory/conspage.c
View file

@ -121,7 +121,7 @@ void make_cons_page( ) {
/**
* dump the allocated pages to this `output` stream.
*/
void dump_pages( URL_FILE * output ) {
void dump_pages( URL_FILE *output ) {
for ( int i = 0; i < initialised_cons_pages; i++ ) {
url_fwprintf( output, L"\nDUMPING PAGE %d\n", i );
@ -188,7 +188,8 @@ void free_cell( struct cons_pointer pointer ) {
free_vso( pointer );
break;
default:
fprintf( stderr, "WARNING: Freeing object of type %s!", (char *) &(cell->tag.bytes));
fprintf( stderr, "WARNING: Freeing object of type %s!",
( char * ) &( cell->tag.bytes ) );
}
strncpy( &cell->tag.bytes[0], FREETAG, TAGLENGTH );
@ -240,8 +241,8 @@ struct cons_pointer allocate_cell( uint32_t tag ) {
total_cells_allocated++;
debug_printf( DEBUG_ALLOC,
L"Allocated cell of type '%4.4s' at %d, %d \n", cell->tag.bytes,
result.page, result.offset );
L"Allocated cell of type '%4.4s' at %d, %d \n",
cell->tag.bytes, result.page, result.offset );
} else {
debug_printf( DEBUG_ALLOC, L"WARNING: Allocating non-free cell!" );
}
@ -270,5 +271,6 @@ void initialise_cons_pages( ) {
void summarise_allocation( ) {
fwprintf( stderr,
L"Allocation summary: allocated %lld; deallocated %lld; not deallocated %lld.\n",
total_cells_allocated, total_cells_freed, total_cells_allocated - total_cells_freed );
total_cells_allocated, total_cells_freed,
total_cells_allocated - total_cells_freed );
}

384
src/memory/consspaceobject.c
View file

@ -33,22 +33,22 @@
* vectorspace object indicated by the cell is this `value`, else false.
*/
bool check_tag( struct cons_pointer pointer, uint32_t value ) {
bool result = false;
bool result = false;
struct cons_space_object cell = pointer2cell( pointer );
result = cell.tag.value == value;
struct cons_space_object cell = pointer2cell( pointer );
result = cell.tag.value == value;
if ( result == false ) {
if ( cell.tag.value == VECTORPOINTTV ) {
struct vector_space_object *vec = pointer_to_vso( pointer );
if ( result == false ) {
if ( cell.tag.value == VECTORPOINTTV ) {
struct vector_space_object *vec = pointer_to_vso( pointer );
if ( vec != NULL ) {
result = vec->header.tag.value == value;
}
if ( vec != NULL ) {
result = vec->header.tag.value == value;
}
}
}
}
return result;
return result;
}
/**
@ -60,13 +60,13 @@ bool check_tag( struct cons_pointer pointer, uint32_t value ) {
* Returns the `pointer`.
*/
struct cons_pointer inc_ref( struct cons_pointer pointer ) {
struct cons_space_object *cell = &pointer2cell( pointer );
struct cons_space_object *cell = &pointer2cell( pointer );
if ( cell->count < MAXREFERENCE ) {
cell->count++;
}
if ( cell->count < MAXREFERENCE ) {
cell->count++;
}
return pointer;
return pointer;
}
/**
@ -78,18 +78,18 @@ struct cons_pointer inc_ref( struct cons_pointer pointer ) {
* Returns the `pointer`, or, if the cell has been freed, NIL.
*/
struct cons_pointer dec_ref( struct cons_pointer pointer ) {
struct cons_space_object *cell = &pointer2cell( pointer );
struct cons_space_object *cell = &pointer2cell( pointer );
if ( cell->count > 0 && cell->count != UINT32_MAX) {
cell->count--;
if ( cell->count > 0 && cell->count != UINT32_MAX ) {
cell->count--;
if ( cell->count == 0 ) {
free_cell( pointer );
pointer = NIL;
if ( cell->count == 0 ) {
free_cell( pointer );
pointer = NIL;
}
}
}
return pointer;
return pointer;
}
/**
@ -98,22 +98,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.
*/
struct cons_pointer c_type( struct cons_pointer pointer ) {
struct cons_pointer result = NIL;
struct cons_space_object cell = pointer2cell( pointer );
struct cons_pointer result = NIL;
struct cons_space_object cell = pointer2cell( pointer );
if ( strncmp( (char *)&cell.tag.bytes, VECTORPOINTTAG, TAGLENGTH ) == 0 ) {
struct vector_space_object *vec = pointer_to_vso( pointer );
if ( strncmp( ( char * ) &cell.tag.bytes, VECTORPOINTTAG, TAGLENGTH ) ==
0 ) {
struct vector_space_object *vec = pointer_to_vso( pointer );
for ( int i = TAGLENGTH - 1; i >= 0; i-- ) {
result = make_string( (wchar_t)vec->header.tag.bytes[i], result );
for ( int i = TAGLENGTH - 1; i >= 0; i-- ) {
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;
}
/**
@ -121,13 +123,13 @@ struct cons_pointer c_type( struct cons_pointer pointer ) {
* authorised to read it, does not error but returns nil.
*/
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 ) ) {
result = pointer2cell( arg ).payload.cons.car;
}
if ( truep( authorised( arg, NIL ) ) && consp( arg ) ) {
result = pointer2cell( arg ).payload.cons.car;
}
return result;
return result;
}
/**
@ -135,24 +137,24 @@ struct cons_pointer c_car( struct cons_pointer arg ) {
* not authorised to read it,does not error but returns nil.
*/
struct cons_pointer c_cdr( struct cons_pointer arg ) {
struct cons_pointer result = NIL;
struct cons_pointer result = NIL;
if ( truep( authorised( arg, NIL ) ) ) {
struct cons_space_object *cell = &pointer2cell( arg );
if ( truep( authorised( arg, NIL ) ) ) {
struct cons_space_object *cell = &pointer2cell( arg );
switch ( cell->tag.value ) {
case CONSTV:
result = cell->payload.cons.cdr;
break;
case KEYTV:
case STRINGTV:
case SYMBOLTV:
result = cell->payload.string.cdr;
break;
switch ( cell->tag.value ) {
case CONSTV:
result = cell->payload.cons.cdr;
break;
case KEYTV:
case STRINGTV:
case SYMBOLTV:
result = cell->payload.string.cdr;
break;
}
}
}
return result;
return result;
}
/**
@ -160,13 +162,13 @@ struct cons_pointer c_cdr( struct cons_pointer arg ) {
* returns 0.
*/
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 ) ) {
result++;
}
for ( struct cons_pointer c = arg; !nilp( c ); c = c_cdr( c ) ) {
result++;
}
return result;
return result;
}
/**
@ -174,18 +176,18 @@ int c_length( struct cons_pointer arg ) {
*/
struct cons_pointer make_cons( struct cons_pointer car,
struct cons_pointer cdr ) {
struct cons_pointer pointer = NIL;
struct cons_pointer pointer = NIL;
pointer = allocate_cell( CONSTV );
pointer = allocate_cell( CONSTV );
struct cons_space_object *cell = &pointer2cell( pointer );
struct cons_space_object *cell = &pointer2cell( pointer );
inc_ref( car );
inc_ref( cdr );
cell->payload.cons.car = car;
cell->payload.cons.cdr = cdr;
inc_ref( car );
inc_ref( cdr );
cell->payload.cons.car = car;
cell->payload.cons.cdr = cdr;
return pointer;
return pointer;
}
/**
@ -197,35 +199,39 @@ struct cons_pointer make_cons( struct cons_pointer car,
*/
struct cons_pointer make_exception( struct cons_pointer message,
struct cons_pointer frame_pointer ) {
struct cons_pointer result = NIL;
struct cons_pointer pointer = allocate_cell( EXCEPTIONTV );
struct cons_space_object *cell = &pointer2cell( pointer );
struct cons_pointer result = NIL;
struct cons_pointer pointer = allocate_cell( EXCEPTIONTV );
struct cons_space_object *cell = &pointer2cell( pointer );
inc_ref( frame_pointer );
cell->payload.exception.payload = message;
cell->payload.exception.frame = frame_pointer;
inc_ref( frame_pointer );
cell->payload.exception.payload = message;
cell->payload.exception.frame = frame_pointer;
result = pointer;
result = pointer;
return result;
return result;
}
/**
* Construct a cell which points to an executable Lisp function.
*/
struct cons_pointer make_function(
struct cons_pointer meta,
struct cons_pointer ( *executable )( struct stack_frame *,
struct cons_pointer,
struct cons_pointer ) ) {
struct cons_pointer pointer = allocate_cell( FUNCTIONTV );
struct cons_space_object *cell = &pointer2cell( pointer );
inc_ref( meta );
struct cons_pointer make_function( struct cons_pointer meta,
struct cons_pointer ( *executable ) ( struct
stack_frame
*,
struct
cons_pointer,
struct
cons_pointer ) )
{
struct cons_pointer pointer = allocate_cell( FUNCTIONTV );
struct cons_space_object *cell = &pointer2cell( pointer );
inc_ref( meta );
cell->payload.function.meta = meta;
cell->payload.function.executable = executable;
cell->payload.function.meta = meta;
cell->payload.function.executable = executable;
return pointer;
return pointer;
}
/**
@ -233,15 +239,15 @@ struct cons_pointer make_function(
*/
struct cons_pointer make_lambda( struct cons_pointer args,
struct cons_pointer body ) {
struct cons_pointer pointer = allocate_cell( LAMBDATV );
struct cons_space_object *cell = &pointer2cell( pointer );
struct cons_pointer pointer = allocate_cell( LAMBDATV );
struct cons_space_object *cell = &pointer2cell( pointer );
inc_ref( args );
inc_ref( body );
cell->payload.lambda.args = args;
cell->payload.lambda.body = body;
inc_ref( args );
inc_ref( body );
cell->payload.lambda.args = args;
cell->payload.lambda.body = body;
return pointer;
return pointer;
}
/**
@ -250,15 +256,15 @@ struct cons_pointer make_lambda( struct cons_pointer args,
*/
struct cons_pointer make_nlambda( struct cons_pointer args,
struct cons_pointer body ) {
struct cons_pointer pointer = allocate_cell( NLAMBDATV );
struct cons_pointer pointer = allocate_cell( NLAMBDATV );
struct cons_space_object *cell = &pointer2cell( pointer );
inc_ref( args );
inc_ref( body );
cell->payload.lambda.args = args;
cell->payload.lambda.body = body;
struct cons_space_object *cell = &pointer2cell( pointer );
inc_ref( args );
inc_ref( body );
cell->payload.lambda.args = args;
cell->payload.lambda.body = body;
return pointer;
return pointer;
}
/**
@ -273,22 +279,24 @@ struct cons_pointer make_nlambda( struct cons_pointer args,
* returns 0 for things which are not string like.
*/
uint32_t calculate_hash( wint_t c, struct cons_pointer ptr ) {
struct cons_space_object *cell = &pointer2cell( ptr );
uint32_t result = 0;
struct cons_space_object *cell = &pointer2cell( ptr );
uint32_t result = 0;
switch ( cell->tag.value ) {
case KEYTV:
case STRINGTV:
case SYMBOLTV:
if ( nilp( cell->payload.string.cdr ) ) {
result = (uint32_t)c;
} else {
result = ( (uint32_t)c * cell->payload.string.hash ) & 0xffffffff;
}
break;
}
switch ( cell->tag.value ) {
case KEYTV:
case STRINGTV:
case SYMBOLTV:
if ( nilp( cell->payload.string.cdr ) ) {
result = ( uint32_t ) c;
} else {
result =
( ( uint32_t ) c *
cell->payload.string.hash ) & 0xffffffff;
}
break;
}
return result;
return result;
}
/**
@ -299,24 +307,24 @@ uint32_t calculate_hash( wint_t c, struct cons_pointer ptr ) {
*/
struct cons_pointer make_string_like_thing( wint_t c, struct cons_pointer tail,
uint32_t tag ) {
struct cons_pointer pointer = NIL;
struct cons_pointer pointer = NIL;
if ( check_tag( tail, tag ) || check_tag( tail, NILTV ) ) {
pointer = allocate_cell( tag );
struct cons_space_object *cell = &pointer2cell( pointer );
if ( check_tag( tail, tag ) || check_tag( tail, NILTV ) ) {
pointer = allocate_cell( tag );
struct cons_space_object *cell = &pointer2cell( pointer );
cell->payload.string.character = c;
cell->payload.string.cdr = tail;
cell->payload.string.character = c;
cell->payload.string.cdr = tail;
cell->payload.string.hash = calculate_hash( c, tail );
} else {
// \todo should throw an exception!
debug_printf( DEBUG_ALLOC,
L"Warning: only NIL and %4.4s can be prepended to %4.4s\n",
tag, tag );
}
cell->payload.string.hash = calculate_hash( c, tail );
} else {
// \todo should throw an exception!
debug_printf( DEBUG_ALLOC,
L"Warning: only NIL and %4.4s can be prepended to %4.4s\n",
tag, tag );
}
return pointer;
return pointer;
}
/**
@ -328,7 +336,7 @@ struct cons_pointer make_string_like_thing( wint_t c, struct cons_pointer tail,
* @param tail the string which is being built.
*/
struct cons_pointer make_string( wint_t c, struct cons_pointer tail ) {
return make_string_like_thing( c, tail, STRINGTV );
return make_string_like_thing( c, tail, STRINGTV );
}
/**
@ -341,45 +349,51 @@ struct cons_pointer make_string( wint_t c, struct cons_pointer tail ) {
*/
struct cons_pointer make_symbol_or_key( wint_t c, struct cons_pointer tail,
uint32_t tag ) {
struct cons_pointer result;
struct cons_pointer result;
if ( tag == SYMBOLTV || tag == KEYTV ) {
result = make_string_like_thing( c, tail, tag );
if ( tag == SYMBOLTV || tag == KEYTV ) {
result = make_string_like_thing( c, tail, tag );
if ( tag == KEYTV ) {
struct cons_pointer r = internedp( result, oblist );
if ( tag == KEYTV ) {
struct cons_pointer r = internedp( result, oblist );
if ( nilp( r ) ) {
intern( result, oblist );
} else {
result = r;
}
if ( nilp( r ) ) {
intern( result, oblist );
} else {
result = r;
}
}
} else {
result =
make_exception( c_string_to_lisp_string
( L"Unexpected tag when making symbol or key." ),
NIL );
}
} else {
result = make_exception(
c_string_to_lisp_string( L"Unexpected tag when making symbol or key." ),
NIL);
}
return result;
return result;
}
/**
* Construct a cell which points to an executable Lisp special form.
*/
struct cons_pointer make_special(
struct cons_pointer meta,
struct cons_pointer ( *executable )( struct stack_frame *frame,
struct cons_pointer,
struct cons_pointer env ) ) {
struct cons_pointer pointer = allocate_cell( SPECIALTV );
struct cons_space_object *cell = &pointer2cell( pointer );
inc_ref( meta );
struct cons_pointer make_special( struct cons_pointer meta,
struct cons_pointer ( *executable ) ( struct
stack_frame
*frame,
struct
cons_pointer,
struct
cons_pointer
env ) )
{
struct cons_pointer pointer = allocate_cell( SPECIALTV );
struct cons_space_object *cell = &pointer2cell( pointer );
inc_ref( meta );
cell->payload.special.meta = meta;
cell->payload.special.executable = executable;
cell->payload.special.meta = meta;
cell->payload.special.executable = executable;
return pointer;
return pointer;
}
/**
@ -390,13 +404,13 @@ struct cons_pointer make_special(
*/
struct cons_pointer make_read_stream( URL_FILE *input,
struct cons_pointer metadata ) {
struct cons_pointer pointer = allocate_cell( READTV );
struct cons_space_object *cell = &pointer2cell( pointer );
struct cons_pointer pointer = allocate_cell( READTV );
struct cons_space_object *cell = &pointer2cell( pointer );
cell->payload.stream.stream = input;
cell->payload.stream.meta = metadata;
cell->payload.stream.stream = input;
cell->payload.stream.meta = metadata;
return pointer;
return pointer;
}
/**
@ -407,13 +421,13 @@ struct cons_pointer make_read_stream( URL_FILE *input,
*/
struct cons_pointer make_write_stream( URL_FILE *output,
struct cons_pointer metadata ) {
struct cons_pointer pointer = allocate_cell( WRITETV );
struct cons_space_object *cell = &pointer2cell( pointer );
struct cons_pointer pointer = allocate_cell( WRITETV );
struct cons_space_object *cell = &pointer2cell( pointer );
cell->payload.stream.stream = output;
cell->payload.stream.meta = metadata;
cell->payload.stream.stream = output;
cell->payload.stream.meta = metadata;
return pointer;
return pointer;
}
/**
@ -421,43 +435,43 @@ struct cons_pointer make_write_stream( URL_FILE *output,
* keywords, I am accepting only lower case characters and numbers.
*/
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-- ) {
wchar_t c = towlower( symbol[i] );
for ( int i = wcslen( symbol ) - 1; i >= 0; i-- ) {
wchar_t c = towlower( symbol[i] );
if ( iswalnum( c ) || c == L'-' ) {
result = make_keyword( c, result );
if ( iswalnum( c ) || c == L'-' ) {
result = make_keyword( c, result );
}
}
}
return result;
return result;
}
/**
* Return a lisp string representation of this wide character string.
*/
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-- ) {
if ( iswprint( string[i] ) && string[i] != '"' ) {
result = make_string( string[i], result );
for ( int i = wcslen( string ) - 1; i >= 0; i-- ) {
if ( iswprint( string[i] ) && string[i] != '"' ) {
result = make_string( string[i], result );
}
}
}
return result;
return result;
}
/**
* Return a lisp symbol representation of this wide character string.
*/
struct cons_pointer c_string_to_lisp_symbol( wchar_t *symbol ) {
struct cons_pointer result = NIL;
struct cons_pointer result = NIL;
for ( int i = wcslen( symbol ); i > 0; i-- ) {
result = make_symbol( symbol[i - 1], result );
}
for ( int i = wcslen( symbol ); i > 0; i-- ) {
result = make_symbol( symbol[i - 1], result );
}
return result;
return result;
}

12
src/memory/dump.c
View file

@ -29,7 +29,7 @@
#include "memory/vectorspace.h"
void dump_string_cell( URL_FILE * output, wchar_t *prefix,
void dump_string_cell( URL_FILE *output, wchar_t *prefix,
struct cons_pointer pointer ) {
struct cons_space_object cell = pointer2cell( pointer );
if ( cell.payload.string.character == 0 ) {
@ -56,7 +56,7 @@ void dump_string_cell( URL_FILE * output, wchar_t *prefix,
/**
* 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 );
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,
@ -114,10 +114,10 @@ void dump_object( URL_FILE * output, struct cons_pointer pointer ) {
case RATIOTV:
url_fwprintf( output,
L"\t\tRational cell: value %ld/%ld, count %u\n",
pointer2cell( cell.payload.ratio.dividend ).payload.
integer.value,
pointer2cell( cell.payload.ratio.divisor ).payload.
integer.value, cell.count );
pointer2cell( cell.payload.ratio.dividend ).
payload.integer.value,
pointer2cell( cell.payload.ratio.divisor ).
payload.integer.value, cell.count );
break;
case READTV:
url_fputws( L"\t\tInput stream; metadata: ", output );

15
src/memory/hashmap.c
View file

@ -54,12 +54,12 @@ struct cons_pointer lisp_make_hashmap( struct stack_frame *frame,
}
}
if ( frame->args > 1 ) {
if ( functionp( frame->arg[1])) {
hash_fn = frame->arg[1];
} else if ( nilp(frame->arg[1])){
if ( functionp( frame->arg[1] ) ) {
hash_fn = frame->arg[1];
} else if ( nilp( frame->arg[1] ) ) {
/* that's allowed */
} else {
result =
result =
make_exception( c_string_to_lisp_string
( L"Second arg to `hashmap`, if passed, must "
L"be a function or `nil`.`" ), NIL );
@ -88,8 +88,7 @@ struct cons_pointer lisp_make_hashmap( struct stack_frame *frame,
map->payload.hashmap.buckets[bucket_no] =
make_cons( make_cons( key, val ),
map->payload.hashmap.
buckets[bucket_no] );
map->payload.hashmap.buckets[bucket_no] );
}
}
}
@ -114,7 +113,7 @@ struct cons_pointer lisp_hashmap_put( struct stack_frame *frame,
struct cons_pointer val = frame->arg[2];
struct cons_pointer result = hashmap_put( mapp, key, val );
struct cons_space_object *cell = &pointer2cell( result);
struct cons_space_object *cell = &pointer2cell( result );
return result;
// TODO: else clone and return clone.
@ -136,7 +135,7 @@ struct cons_pointer lisp_hashmap_keys( struct stack_frame *frame,
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;
url_fwprintf( output, L"Hashmap with %d buckets:\n", payload->n_buckets );

12
src/memory/lookup3.c
View file

@ -170,7 +170,7 @@ and these came close:
hashlittle() has to dance around fitting the key bytes into registers.
--------------------------------------------------------------------
*/
uint32_t hashword( const uint32_t * k, /* the key, an array of uint32_t values */
uint32_t hashword( const uint32_t *k, /* the key, an array of uint32_t values */
size_t length, /* the length of the key, in uint32_ts */
uint32_t initval ) { /* the previous hash, or an arbitrary value */
uint32_t a, b, c;
@ -213,10 +213,10 @@ both be initialized with seeds. If you pass in (*pb)==0, the output
(*pc) will be the same as the return value from hashword().
--------------------------------------------------------------------
*/
void hashword2( const uint32_t * k, /* the key, an array of uint32_t values */
void hashword2( const uint32_t *k, /* the key, an array of uint32_t values */
size_t length, /* the length of the key, in uint32_ts */
uint32_t * pc, /* IN: seed OUT: primary hash value */
uint32_t * pb ) { /* IN: more seed OUT: secondary hash value */
uint32_t *pc, /* IN: seed OUT: primary hash value */
uint32_t *pb ) { /* IN: more seed OUT: secondary hash value */
uint32_t a, b, c;
/* Set up the internal state */
@ -538,8 +538,8 @@ uint32_t hashlittle( const void *key, size_t length, uint32_t initval ) {
*/
void hashlittle2( const void *key, /* the key to hash */
size_t length, /* length of the key */
uint32_t * pc, /* IN: primary initval, OUT: primary hash */
uint32_t * pb ) { /* IN: secondary initval, OUT: secondary hash */
uint32_t *pc, /* IN: primary initval, OUT: primary hash */
uint32_t *pb ) { /* IN: secondary initval, OUT: secondary hash */
uint32_t a, b, c; /* internal state */
union {
const void *ptr;

4
src/memory/stack.c
View file

@ -241,7 +241,7 @@ void free_stack_frame( struct stack_frame *frame ) {
* @param output the stream
* @param frame_pointer the pointer to the frame
*/
void dump_frame( URL_FILE * output, struct cons_pointer frame_pointer ) {
void dump_frame( URL_FILE *output, struct cons_pointer frame_pointer ) {
struct stack_frame *frame = get_stack_frame( frame_pointer );
if ( frame != NULL ) {
@ -265,7 +265,7 @@ void dump_frame( URL_FILE * output, struct cons_pointer frame_pointer ) {
}
}
void dump_stack_trace( URL_FILE * output, struct cons_pointer pointer ) {
void dump_stack_trace( URL_FILE *output, struct cons_pointer pointer ) {
if ( exceptionp( pointer ) ) {
print( output, pointer2cell( pointer ).payload.exception.payload );
url_fputws( L"\n", output );

2
src/memory/vectorspace.c
View file

@ -85,7 +85,7 @@ struct cons_pointer make_vso( uint32_t tag, uint64_t payload_size ) {
if ( vso != NULL ) {
memset( vso, 0, padded );
vso->header.tag.value = tag;
vso->header.tag.value = tag;
debug_printf( DEBUG_ALLOC,
L"make_vso: written tag '%4.4s' into vso at %p\n",

60
src/ops/intern.c
View file

@ -191,20 +191,20 @@ struct cons_pointer hashmap_put_all( struct cons_pointer mapp,
pair = c_car( assoc ) ) {
/* TODO: this is really hammering the memory management system, because
* it will make a new lone for every key/value pair added. Fix. */
if (consp( pair)) {
if ( consp( pair ) ) {
mapp = hashmap_put( mapp, c_car( pair ), c_cdr( pair ) );
} else if (hashmapp( pair)) {
hashmap_put_all( mapp, pair);
} else if ( hashmapp( pair ) ) {
hashmap_put_all( mapp, pair );
} else {
hashmap_put( mapp, pair, TRUE);
hashmap_put( mapp, pair, TRUE );
}
assoc = c_cdr( assoc);
assoc = c_cdr( assoc );
}
} else if (hashmapp( assoc)) {
for (struct cons_pointer keys = hashmap_keys( assoc); !nilp( keys);
keys = c_cdr( keys)) {
struct cons_pointer key = c_car( keys);
hashmap_put( mapp, key, hashmap_get( assoc, key));
} else if ( hashmapp( assoc ) ) {
for ( struct cons_pointer keys = hashmap_keys( assoc );
!nilp( keys ); keys = c_cdr( keys ) ) {
struct cons_pointer key = c_car( keys );
hashmap_put( mapp, key, hashmap_get( assoc, key ) );
}
}
}
@ -246,7 +246,8 @@ struct cons_pointer clone_hashmap( struct cons_pointer ptr ) {
result =
make_hashmap( from_pl.n_buckets, from_pl.hash_fn,
from_pl.write_acl );
struct vector_space_object const *to = pointer_to_vso( result );
struct vector_space_object const *to =
pointer_to_vso( result );
struct hashmap_payload to_pl = to->payload.hashmap;
for ( int i = 0; i < to_pl.n_buckets; i++ ) {
@ -257,9 +258,9 @@ struct cons_pointer clone_hashmap( struct cons_pointer ptr ) {
}
} else {
result =
make_exception( c_string_to_lisp_string
( L"Arg to `clone_hashmap` must "
L"be a readable hashmap.`" ), NIL );
make_exception( c_string_to_lisp_string
( L"Arg to `clone_hashmap` must "
L"be a readable hashmap.`" ), NIL );
}
return result;
@ -299,9 +300,9 @@ internedp( struct cons_pointer key, struct cons_pointer store ) {
// if ( equal( key, entry.payload.cons.car ) ) {
// result = entry.payload.cons.car;
// }
if (!nilp( c_assoc( key, store))) {
if ( !nilp( c_assoc( key, store ) ) ) {
result = key;
} else if ( equal( key, privileged_symbol_nil)) {
} else if ( equal( key, privileged_symbol_nil ) ) {
result = privileged_symbol_nil;
}
} else {
@ -349,9 +350,10 @@ struct cons_pointer c_assoc( struct cons_pointer key,
result = hashmap_get( entry_ptr, key );
break;
default:
throw_exception( c_append(
c_string_to_lisp_string( L"Store entry is of unknown type: " ),
c_type( entry_ptr)), NIL);
throw_exception( c_append
( c_string_to_lisp_string
( L"Store entry is of unknown type: " ),
c_type( entry_ptr ) ), NIL );
}
}
}
@ -359,13 +361,13 @@ struct cons_pointer c_assoc( struct cons_pointer key,
result = hashmap_get( store, key );
} else if ( !nilp( store ) ) {
debug_print( L"c_assoc; store is of unknown type `", DEBUG_BIND );
debug_print_object( c_type( store), DEBUG_BIND );
debug_print_object( c_type( store ), DEBUG_BIND );
debug_print( L"`\n", DEBUG_BIND );
result =
throw_exception(
c_append(
c_string_to_lisp_string( L"Store is of unknown type: " ),
c_type( store)), NIL );
throw_exception( c_append
( c_string_to_lisp_string
( L"Store is of unknown type: " ),
c_type( store ) ), NIL );
}
debug_print( L"c_assoc returning ", DEBUG_BIND );
@ -419,14 +421,14 @@ struct cons_pointer set( struct cons_pointer key, struct cons_pointer value,
debug_dump_object( store, DEBUG_BIND );
debug_println( DEBUG_BIND );
debug_printf( DEBUG_BIND, L"set: store is %s\n`", lisp_string_to_c_string( c_type( store)) );
if (nilp( value)) {
debug_printf( DEBUG_BIND, L"set: store is %s\n`",
lisp_string_to_c_string( c_type( store ) ) );
if ( nilp( value ) ) {
result = store;
}
else if ( nilp( store ) || consp( store ) ) {
} else if ( nilp( store ) || consp( store ) ) {
result = make_cons( make_cons( key, value ), store );
} else if ( hashmapp( store ) ) {
debug_print( L"set: storing in hashmap\n", DEBUG_BIND);
debug_print( L"set: storing in hashmap\n", DEBUG_BIND );
result = hashmap_put( store, key, value );
}

2
src/ops/intern.h
View file

@ -36,7 +36,7 @@ struct cons_pointer hashmap_get( struct cons_pointer mapp,
struct cons_pointer hashmap_put( struct cons_pointer mapp,
struct cons_pointer key,
struct cons_pointer val );
struct cons_pointer hashmap_put_all( struct cons_pointer mapp,
struct cons_pointer assoc );

53
src/ops/lispops.c
View file

@ -446,9 +446,10 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
result = next_pointer;
} else {
result =
( *fn_cell.payload.special.
executable ) ( get_stack_frame( next_pointer ),
next_pointer, env );
( *fn_cell.payload.
special.executable ) ( get_stack_frame
( next_pointer ),
next_pointer, env );
debug_print( L"Special form returning: ", DEBUG_EVAL );
debug_print_object( result, DEBUG_EVAL );
debug_println( DEBUG_EVAL );
@ -1245,7 +1246,8 @@ lisp_exception( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
struct cons_pointer message = frame->arg[0];
return exceptionp( message ) ? message : throw_exception( message,
frame->previous );
frame->
previous );
}
/**
@ -1264,34 +1266,36 @@ struct cons_pointer lisp_repl( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ) {
struct cons_pointer expr = NIL;
debug_printf(DEBUG_REPL, L"Entering new inner REPL\n");
debug_printf( DEBUG_REPL, L"Entering new inner REPL\n" );
struct cons_pointer input = get_default_stream( true, env );
struct cons_pointer output = get_default_stream( false, env );
// struct cons_pointer prompt_name = c_string_to_lisp_symbol( L"*prompt*" );
struct cons_pointer old_oblist = oblist;
struct cons_pointer new_env = env;
if (truep(frame->arg[0])) {
new_env = set( prompt_name, frame->arg[0], new_env);
if ( truep( frame->arg[0] ) ) {
new_env = set( prompt_name, frame->arg[0], new_env );
}
if (readp(frame->arg[1])) {
new_env = set( c_string_to_lisp_symbol(L"*in*"), frame->arg[1], new_env);
if ( readp( frame->arg[1] ) ) {
new_env =
set( c_string_to_lisp_symbol( L"*in*" ), frame->arg[1], new_env );
input = frame->arg[1];
}
if (readp(frame->arg[2])) {
new_env = set( c_string_to_lisp_symbol(L"*out*"), frame->arg[2], new_env);
if ( readp( frame->arg[2] ) ) {
new_env =
set( c_string_to_lisp_symbol( L"*out*" ), frame->arg[2], new_env );
output = frame->arg[2];
}
inc_ref( input );
inc_ref( output );
inc_ref( prompt_name );
URL_FILE *os = pointer2cell( output ).payload.stream.stream;
/* \todo this is subtly wrong. If we were evaluating
* (print (eval (read)))
* then the stack frame for read would have the stack frame for
@ -1353,10 +1357,10 @@ struct cons_pointer lisp_repl( struct stack_frame *frame,
dec_ref( input );
dec_ref( output );
dec_ref( prompt_name );
dec_ref( new_env);
dec_ref( new_env );
debug_printf( DEBUG_REPL, L"Leaving inner repl\n" );
debug_printf(DEBUG_REPL, L"Leaving inner repl\n");
return expr;
}
@ -1426,13 +1430,14 @@ struct cons_pointer c_append( struct cons_pointer l1, struct cons_pointer l2 ) {
if ( pointer2cell( l1 ).tag.value == pointer2cell( l2 ).tag.value ) {
if ( nilp( c_cdr( l1 ) ) ) {
return
make_string_like_thing( ( pointer2cell( l1 ).payload.
string.character ), l2,
make_string_like_thing( ( pointer2cell( l1 ).
payload.string.character ),
l2,
pointer2cell( l1 ).tag.value );
} else {
return
make_string_like_thing( ( pointer2cell( l1 ).payload.
string.character ),
make_string_like_thing( ( pointer2cell( l1 ).
payload.string.character ),
c_append( c_cdr( l1 ), l2 ),
pointer2cell( l1 ).tag.value );
}
@ -1588,8 +1593,8 @@ struct cons_pointer lisp_let( struct stack_frame *frame,
// }
// }
// }
// return result;
// }
// }

6
src/repl.c
View file

@ -23,15 +23,15 @@
*
* @param dummy
*/
void int_handler(int dummy) {
wprintf(L"TODO: handle ctrl-C in a more interesting way\n");
void int_handler( int dummy ) {
wprintf( L"TODO: handle ctrl-C in a more interesting way\n" );
}
/**
* The read/eval/print loop.
*/
void repl( ) {
signal(SIGINT, int_handler);
signal( SIGINT, int_handler );
debug_print( L"Entered repl\n", DEBUG_REPL );
struct cons_pointer env =