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

Moved legacy code into archive, ready for a new rapid(?) prototype.

Browse source 
I may regret doing this!
This commit is contained in:
Simon Brooke 2026-03-24 16:25:09 +00:00
parent 09051a3e63
commit 914c35ead0
114 changed files with 165 additions and 1 deletions
Download patch file Download diff file Expand all files Collapse all files

290
archive/c/memory/conspage.c Normal file
View file

@ -0,0 +1,290 @@
/*
* conspage.c
*
* Setup and tear down cons pages, and (FOR NOW) do primitive
* allocation/deallocation of cells.
* NOTE THAT before we go multi-threaded, these functions must be
* aggressively
* thread safe.
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <stdbool.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include "memory/consspaceobject.h"
#include "memory/conspage.h"
#include "debug.h"
#include "memory/dump.h"
#include "memory/stack.h"
#include "memory/vectorspace.h"
/**
* Flag indicating whether conspage initialisation has been done.
*/
bool conspageinitihasbeencalled = false;
/**
* keep track of total cells allocated and freed to check for leakage.
*/
uint64_t total_cells_allocated = 0;
uint64_t total_cells_freed = 0;
/**
* the number of cons pages which have thus far been initialised.
*/
int initialised_cons_pages = 0;
/**
* The (global) pointer to the (global) freelist. Not sure whether this ultimately
* belongs in this file.
*/
struct cons_pointer freelist = NIL;
/**
* The exception message printed when the world blows up, initialised in
* `maybe_bind_init_symbols()` in `init.c`, q.v.
*/
struct cons_pointer privileged_string_memory_exhausted;
/**
* An array of pointers to cons pages.
*/
struct cons_page *conspages[NCONSPAGES];
/**
* Make a cons page. Initialise all cells and prepend each to the freelist;
* if `initialised_cons_pages` is zero, do not prepend cells 0 and 1 to the
* freelist but initialise them as NIL and T respectively.
* \todo we ought to handle cons space exhaustion more gracefully than just
* crashing; should probably return an exception instead, although obviously
* that exception would have to have been pre-built.
*/
void make_cons_page( ) {
struct cons_page *result = NULL;
if ( initialised_cons_pages < NCONSPAGES ) {
result = malloc( sizeof( struct cons_page ) );
}
if ( result != NULL ) {
conspages[initialised_cons_pages] = result;
for ( int i = 0; i < CONSPAGESIZE; i++ ) {
struct cons_space_object *cell =
&conspages[initialised_cons_pages]->cell[i];
if ( initialised_cons_pages == 0 && i < 2 ) {
switch ( i ) {
case 0:
/*
* initialise cell as NIL
*/
strncpy( &cell->tag.bytes[0], NILTAG, TAGLENGTH );
cell->count = MAXREFERENCE;
cell->payload.free.car = NIL;
cell->payload.free.cdr = NIL;
debug_printf( DEBUG_ALLOC,
L"Allocated special cell NIL\n" );
break;
case 1:
/*
* initialise cell as T
*/
strncpy( &cell->tag.bytes[0], TRUETAG, TAGLENGTH );
cell->count = MAXREFERENCE;
cell->payload.free.car = ( struct cons_pointer ) {
0, 1
};
cell->payload.free.cdr = ( struct cons_pointer ) {
0, 1
};
debug_printf( DEBUG_ALLOC,
L"Allocated special cell T\n" );
break;
}
} else {
/*
* otherwise, standard initialisation
*/
strncpy( &cell->tag.bytes[0], FREETAG, TAGLENGTH );
cell->payload.free.car = NIL;
cell->payload.free.cdr = freelist;
freelist.page = initialised_cons_pages;
freelist.offset = i;
}
}
initialised_cons_pages++;
} else {
fwide( stderr, 1 );
fwprintf( stderr,
L"FATAL: Failed to allocate memory for cons page %d\n",
initialised_cons_pages );
exit( 1 );
}
}
/**
* dump the allocated pages to this `output` stream.
*/
void dump_pages( URL_FILE *output ) {
for ( int i = 0; i < initialised_cons_pages; i++ ) {
url_fwprintf( output, L"\nDUMPING PAGE %d\n", i );
for ( int j = 0; j < CONSPAGESIZE; j++ ) {
struct cons_pointer pointer = ( struct cons_pointer ) { i, j };
if ( !freep( pointer ) ) {
dump_object( output, ( struct cons_pointer ) {
i, j
} );
}
}
}
}
/**
* Frees the cell at the specified `pointer`; for all the types of cons-space
* object which point to other cons-space objects, cascade the decrement.
* Dangerous, primitive, low level.
*
* @pointer the cell to free
*/
void free_cell( struct cons_pointer pointer ) {
struct cons_space_object *cell = &pointer2cell( pointer );
debug_printf( DEBUG_ALLOC, L"Freeing cell " );
debug_dump_object( pointer, DEBUG_ALLOC );
if ( !check_tag( pointer, FREETV ) ) {
if ( cell->count == 0 ) {
switch ( cell->tag.value ) {
case CONSTV:
dec_ref( cell->payload.cons.car );
dec_ref( cell->payload.cons.cdr );
break;
case EXCEPTIONTV:
dec_ref( cell->payload.exception.payload );
dec_ref( cell->payload.exception.frame );
break;
case FUNCTIONTV:
dec_ref( cell->payload.function.meta );
break;
case INTEGERTV:
dec_ref( cell->payload.integer.more );
break;
case LAMBDATV:
case NLAMBDATV:
dec_ref( cell->payload.lambda.args );
dec_ref( cell->payload.lambda.body );
break;
case RATIOTV:
dec_ref( cell->payload.ratio.dividend );
dec_ref( cell->payload.ratio.divisor );
break;
case READTV:
case WRITETV:
dec_ref( cell->payload.stream.meta );
url_fclose( cell->payload.stream.stream );
break;
case SPECIALTV:
dec_ref( cell->payload.special.meta );
break;
case STRINGTV:
case SYMBOLTV:
dec_ref( cell->payload.string.cdr );
break;
case VECTORPOINTTV:
free_vso( pointer );
break;
default:
fprintf( stderr, "WARNING: Freeing object of type %s!",
( char * ) &( cell->tag.bytes ) );
}
strncpy( &cell->tag.bytes[0], FREETAG, TAGLENGTH );
cell->payload.free.car = NIL;
cell->payload.free.cdr = freelist;
freelist = pointer;
total_cells_freed++;
} else {
debug_printf( DEBUG_ALLOC,
L"ERROR: Attempt to free cell with %d dangling references at page %d, offset %d\n",
cell->count, pointer.page, pointer.offset );
}
} else {
debug_printf( DEBUG_ALLOC,
L"ERROR: Attempt to free cell which is already FREE at page %d, offset %d\n",
pointer.page, pointer.offset );
}
}
/**
* Allocates a cell with the specified `tag`. Dangerous, primitive, low
* level.
*
* @param tag the tag of the cell to allocate - must be a valid cons space tag.
* @return the cons pointer which refers to the cell allocated.
* \todo handle the case where another cons_page cannot be allocated;
* return an exception. Which, as we cannot create such an exception when
* cons space is exhausted, means we must construct it at init time.
*/
struct cons_pointer allocate_cell( uint32_t tag ) {
struct cons_pointer result = freelist;
if ( result.page == NIL.page && result.offset == NIL.offset ) {
make_cons_page( );
result = allocate_cell( tag );
} else {
struct cons_space_object *cell = &pointer2cell( result );
if ( strncmp( &cell->tag.bytes[0], FREETAG, TAGLENGTH ) == 0 ) {
freelist = cell->payload.free.cdr;
cell->tag.value = tag;
cell->count = 1;
cell->payload.cons.car = NIL;
cell->payload.cons.cdr = NIL;
total_cells_allocated++;
debug_printf( DEBUG_ALLOC,
L"Allocated cell of type %4.4s at %u, %u \n",
( ( char * ) cell->tag.bytes ), result.page,
result.offset );
} else {
debug_printf( DEBUG_ALLOC, L"WARNING: Allocating non-free cell!" );
}
}
return result;
}
/**
* initialise the cons page system; to be called exactly once during startup.
*/
void initialise_cons_pages( ) {
if ( conspageinitihasbeencalled == false ) {
for ( int i = 0; i < NCONSPAGES; i++ ) {
conspages[i] = ( struct cons_page * ) NULL;
}
make_cons_page( );
conspageinitihasbeencalled = true;
} else {
debug_printf( DEBUG_ALLOC,
L"WARNING: initialise_cons_pages() called a second or subsequent time\n" );
}
}
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 );
}

68
archive/c/memory/conspage.h Normal file
View file

@ -0,0 +1,68 @@
/*
* conspage.h
*
* Setup and tear down cons pages, and (FOR NOW) do primitive
* allocation/deallocation of cells.
* NOTE THAT before we go multi-threaded, these functions must be
* aggressively
* thread safe.
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#ifndef __psse_conspage_h
#define __psse_conspage_h
#include "memory/consspaceobject.h"
/**
* the number of cons cells on a cons page. The maximum value this can
* be (and consequently, the size which, by version 1, it will default
* to) is the maximum value of an unsigned 32 bit integer, which is to
* say 4294967296. However, we'll start small.
*/
#define CONSPAGESIZE 1024
/**
* the number of cons pages we will initially allow for. For
* convenience we'll set up an array of cons pages this big; however,
* later we will want a mechanism for this to be able to grow
* dynamically to the maximum we can currently allow, which is
* 4294967296.
*
* Note that this means the total number of addressable cons cells is
* 1.8e19, each of 20 bytes; or 3e20 bytes in total; and there are
* up to a maximum of 4e9 of heap space objects, each of potentially
* 4e9 bytes. So we're talking about a potential total of 8e100 bytes
* of addressable memory, which is only slightly more than the
* number of atoms in the universe.
*/
#define NCONSPAGES 64
/**
* a cons page is essentially just an array of cons space objects. It
* might later have a local free list (i.e. list of free cells on this
* page) and a pointer to the next cons page, but my current view is
* that that's probably unneccessary.
*/
struct cons_page {
struct cons_space_object cell[CONSPAGESIZE];
};
extern struct cons_pointer privileged_string_memory_exhausted;
extern struct cons_pointer freelist;
extern struct cons_page *conspages[NCONSPAGES];
void free_cell( struct cons_pointer pointer );
struct cons_pointer allocate_cell( uint32_t tag );
void initialise_cons_pages( );
void dump_pages( URL_FILE * output );
void summarise_allocation( );
#endif

561
archive/c/memory/consspaceobject.c Normal file
View file

@ -0,0 +1,561 @@
/*
* consspaceobject.c
*
* Structures common to all cons space objects.
*
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <stdint.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
/*
* wide characters
*/
#include <wchar.h>
#include <wctype.h>
#include "authorise.h"
#include "debug.h"
#include "io/print.h"
#include "memory/conspage.h"
#include "memory/consspaceobject.h"
#include "memory/stack.h"
#include "memory/vectorspace.h"
#include "ops/intern.h"
/**
* Keywords used when constructing exceptions: `:location`. Instantiated in
* `init.c`q.v.
*/
struct cons_pointer privileged_keyword_location = NIL;
/**
* Keywords used when constructing exceptions: `:payload`. Instantiated in
* `init.c`, q.v.
*/
struct cons_pointer privileged_keyword_payload = NIL;
/**
* Keywords used when constructing exceptions: `:payload`. Instantiated in
* `init.c`, q.v.
*/
struct cons_pointer privileged_keyword_cause = NIL;
/**
* @brief keywords used in documentation: `:documentation`. Instantiated in
* `init.c`, q. v.
*
*/
struct cons_pointer privileged_keyword_documentation = NIL;
/**
* @brief keywords used in documentation: `:name`. Instantiated in
* `init.c`, q. v.
*/
struct cons_pointer privileged_keyword_name = NIL;
/**
* @brief keywords used in documentation: `:primitive`. Instantiated in
* `init.c`, q. v.
*/
struct cons_pointer privileged_keyword_primitive = NIL;
/**
* True if the value of the tag on the cell at this `pointer` is this `value`,
* or, if the tag of the cell is `VECP`, if the value of the tag of the
* vectorspace object indicated by the cell is this `value`, else false.
*/
bool check_tag( struct cons_pointer pointer, uint32_t value ) {
bool result = false;
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 ( vec != NULL ) {
result = vec->header.tag.value == value;
}
}
}
return result;
}
/**
* increment the reference count of the object at this cons pointer.
*
* You can't roll over the reference count. Once it hits the maximum
* value you cannot increment further.
*
* Returns the `pointer`.
*/
struct cons_pointer inc_ref( struct cons_pointer pointer ) {
struct cons_space_object *cell = &pointer2cell( pointer );
if ( cell->count < MAXREFERENCE ) {
cell->count++;
#ifdef DEBUG
debug_printf( DEBUG_ALLOC,
L"\nIncremented cell of type %4.4s at page %u, offset %u to count %u",
( ( char * ) cell->tag.bytes ), pointer.page,
pointer.offset, cell->count );
if ( strncmp( cell->tag.bytes, VECTORPOINTTAG, TAGLENGTH ) == 0 ) {
debug_printf( DEBUG_ALLOC,
L"; pointer to vector object of type %4.4s.\n",
( ( char * ) ( cell->payload.vectorp.tag.bytes ) ) );
} else {
debug_println( DEBUG_ALLOC );
}
#endif
}
return pointer;
}
/**
* Decrement the reference count of the object at this cons pointer.
*
* If a count has reached MAXREFERENCE it cannot be decremented.
* If a count is decremented to zero the cell should be freed.
*
* 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 );
if ( cell->count > 0 && cell->count != UINT32_MAX ) {
cell->count--;
#ifdef DEBUG
debug_printf( DEBUG_ALLOC,
L"\nDecremented cell of type %4.4s at page %d, offset %d to count %d",
( ( char * ) cell->tag.bytes ), pointer.page,
pointer.offset, cell->count );
if ( strncmp( ( char * ) cell->tag.bytes, VECTORPOINTTAG, TAGLENGTH )
== 0 ) {
debug_printf( DEBUG_ALLOC,
L"; pointer to vector object of type %4.4s.\n",
( ( char * ) ( cell->payload.vectorp.tag.bytes ) ) );
} else {
debug_println( DEBUG_ALLOC );
}
#endif
if ( cell->count == 0 ) {
free_cell( pointer );
pointer = NIL;
}
}
return pointer;
}
/**
* given a cons_pointer as argument, return the tag.
*/
uint32_t get_tag_value( struct cons_pointer pointer ) {
uint32_t result = pointer2cell( pointer ).tag.value;
if ( result == VECTORPOINTTV ) {
result = pointer_to_vso( pointer )->header.tag.value;
}
return result;
}
/**
* Get the Lisp type of the single argument.
* @param pointer a pointer to the object whose type is requested.
* @return As a Lisp string, the tag of the object which is at that pointer.
*/
struct cons_pointer c_type( struct cons_pointer pointer ) {
/* Strings read by `read` have the null character termination. This means
* that for the same printable string, the hashcode is different from
* strings made with NIL termination. The question is which should be
* fixed, and actually that's probably strings read by `read`. However,
* for now, it was easier to add a null character here. */
struct cons_pointer result = make_string( ( wchar_t ) 0, NIL );
struct cons_space_object *cell = &pointer2cell( pointer );
if ( cell->tag.value == VECTORPOINTTV ) {
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 );
}
} else {
for ( int i = TAGLENGTH - 1; i >= 0; i-- ) {
result = make_string( ( wchar_t ) cell->tag.bytes[i], result );
}
}
return result;
}
/**
* Implementation of car in C. If arg is not a cons, or the current user is not
* authorised to read it, does not error but returns nil.
*/
struct cons_pointer c_car( struct cons_pointer arg ) {
struct cons_pointer result = NIL;
if ( truep( authorised( arg, NIL ) ) && consp( arg ) ) {
result = pointer2cell( arg ).payload.cons.car;
}
return result;
}
/**
* Implementation of cdr in C. If arg is not a sequence, or the current user is
* 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;
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;
}
}
return result;
}
/**
* 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 result = 0;
for ( struct cons_pointer c = arg; !nilp( c ); c = c_cdr( c ) ) {
result++;
}
return result;
}
/**
* Construct a cons cell from this pair of pointers.
*/
struct cons_pointer make_cons( struct cons_pointer car,
struct cons_pointer cdr ) {
struct cons_pointer pointer = NIL;
pointer = allocate_cell( CONSTV );
struct cons_space_object *cell = &pointer2cell( pointer );
inc_ref( car );
inc_ref( cdr );
cell->payload.cons.car = car;
cell->payload.cons.cdr = cdr;
return pointer;
}
/**
* Construct an exception cell.
* @param message should be a lisp string describing the problem, but actually
* any cons pointer will do;
* @param frame_pointer should be the pointer to the frame in which the
* exception occurred.
*/
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 );
inc_ref( frame_pointer );
cell->payload.exception.payload = message;
cell->payload.exception.frame = frame_pointer;
result = pointer;
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 );
cell->payload.function.meta = meta;
cell->payload.function.executable = executable;
return pointer;
}
/**
* Construct a lambda (interpretable source) cell
*/
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 );
inc_ref( args );
inc_ref( body );
cell->payload.lambda.args = args;
cell->payload.lambda.body = body;
return pointer;
}
/**
* Construct an nlambda (interpretable source) cell; to a
* lambda as a special form is to a function.
*/
struct cons_pointer make_nlambda( struct cons_pointer args,
struct cons_pointer body ) {
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;
return pointer;
}
/**
* Return a hash value for this string like thing.
*
* What's important here is that two strings with the same characters in the
* same order should have the same hash value, even if one was created using
* `"foobar"` and the other by `(append "foo" "bar")`. I *think* this function
* has that property. I doubt that it's the most efficient hash function to
* have that property.
*
* 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;
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;
}
/**
* Construct a string from this character (which later will be UTF) and
* this tail. A string is implemented as a flat list of cells each of which
* has one character and a pointer to the next; in the last cell the
* pointer to next is NIL.
*/
struct cons_pointer make_string_like_thing( wint_t c, struct cons_pointer tail,
uint32_t tag ) {
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 );
cell->payload.string.character = c;
cell->payload.string.cdr = tail;
cell->payload.string.hash = calculate_hash( c, tail );
debug_dump_object( pointer, DEBUG_ALLOC );
debug_println( DEBUG_ALLOC );
} else {
// \todo should throw an exception!
debug_printf( DEBUG_ALLOC,
L"Warning: only %4.4s can be prepended to %4.4s\n",
tag, tag );
}
return pointer;
}
/**
* Construct a string from the character `c` and this `tail`. A string is
* implemented as a flat list of cells each of which has one character and a
* pointer to the next; in the last cell the pointer to next is NIL.
*
* @param c the character to add (prepend);
* @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 );
}
/**
* Construct a symbol or keyword from the character `c` and this `tail`.
* Each is internally identical to a string except for having a different tag.
*
* @param c the character to add (prepend);
* @param tail the symbol which is being built.
* @param tag the tag to use: expected to be "SYMB" or "KEYW"
*/
struct cons_pointer make_symbol_or_key( wint_t c, struct cons_pointer tail,
uint32_t tag ) {
struct cons_pointer result;
if ( tag == SYMBOLTV || tag == KEYTV ) {
result = make_string_like_thing( c, tail, tag );
// if ( tag == KEYTV ) {
// struct cons_pointer r = interned( result, oblist );
// 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 );
}
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 );
cell->payload.special.meta = meta;
cell->payload.special.executable = executable;
return pointer;
}
/**
* Construct a cell which points to a stream open for reading.
* @param input the C stream to wrap.
* @param metadata a pointer to an associaton containing metadata on the stream.
* @return a pointer to the new read stream.
*/
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 );
cell->payload.stream.stream = input;
cell->payload.stream.meta = metadata;
return pointer;
}
/**
* Construct a cell which points to a stream open for writing.
* @param output the C stream to wrap.
* @param metadata a pointer to an associaton containing metadata on the stream.
* @return a pointer to the new read stream.
*/
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 );
cell->payload.stream.stream = output;
cell->payload.stream.meta = metadata;
return pointer;
}
/**
* Return a lisp keyword representation of this wide character string. In
* 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;
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 );
}
}
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;
for ( int i = wcslen( string ) - 1; i >= 0; i-- ) {
if ( iswprint( string[i] ) && string[i] != '"' ) {
result = make_string( string[i], 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;
for ( int i = wcslen( symbol ); i > 0; i-- ) {
result = make_symbol( symbol[i - 1], result );
}
return result;
}

812
archive/c/memory/consspaceobject.h Normal file
View file

@ -0,0 +1,812 @@
/*
* consspaceobject.h
*
* Declarations common to all cons space objects.
*
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#ifndef __psse_consspaceobject_h
#define __psse_consspaceobject_h
#include <stdbool.h>
#include <stdint.h>
#include <stdio.h>
/*
* wide characters
*/
#include <wchar.h>
#include <wctype.h>
#include "io/fopen.h"
// #include "memory/conspage.h"
/**
* The length of a tag, in bytes.
*/
#define TAGLENGTH 4
/*
* tag values, all of which must be 4 bytes. Must not collide with vector space
* tag values
*/
/**
* An ordinary cons cell:
*/
#define CONSTAG "CONS"
/**
* The string `CONS`, considered as an `unsigned int`.
* @todo tag values should be collected into an enum.
*/
#define CONSTV 1397641027
/**
* An exception. TODO: we need a means of dealing with different classes of
* exception, and we don't have one yet.
*/
#define EXCEPTIONTAG "EXEP"
/**
* The string `EXEP`, considered as an `unsigned int`.
*/
#define EXCEPTIONTV 1346721861
/**
* Keywords used when constructing exceptions: `:location`. Instantiated in
* `init.c`.
*/
extern struct cons_pointer privileged_keyword_location;
/**
* Keywords used when constructing exceptions: `:payload`. Instantiated in
* `init.c`.
*/
extern struct cons_pointer privileged_keyword_payload;
/**
* Keywords used when constructing exceptions: `:cause`. Instantiated in
* `init.c`.
*/
extern struct cons_pointer privileged_keyword_cause;
/**
* @brief keywords used in documentation: `:documentation`. Instantiated in
* `init.c`, q. v.
*/
extern struct cons_pointer privileged_keyword_documentation;
/**
* @brief keywords used in documentation: `:name`. Instantiated in
* `init.c`, q. v.
*/
extern struct cons_pointer privileged_keyword_name;
/**
* @brief keywords used in documentation: `:primitive`. Instantiated in
* `init.c`, q. v.
*/
extern struct cons_pointer privileged_keyword_primitive;
/**
* An unallocated cell on the free list - should never be encountered by a Lisp
* function.
*/
#define FREETAG "FREE"
/**
* The string `FREE`, considered as an `unsigned int`.
*/
#define FREETV 1162170950
/**
* An ordinary Lisp function - one whose arguments are pre-evaluated.
* \see LAMBDATAG for interpretable functions.
* \see SPECIALTAG for functions whose arguments are not pre-evaluated.
*/
#define FUNCTIONTAG "FUNC"
/**
* The string `FUNC`, considered as an `unsigned int`.
*/
#define FUNCTIONTV 1129207110
/**
* An integer number (bignums are integers).
*/
#define INTEGERTAG "INTR"
/**
* The string `INTR`, considered as an `unsigned int`.
*/
#define INTEGERTV 1381256777
/**
* A keyword - an interned, self-evaluating string.
*/
#define KEYTAG "KEYW"
/**
* The string `KEYW`, considered as an `unsigned int`.
*/
#define KEYTV 1465468235
/**
* A lambda cell. Lambdas are the interpretable (source) versions of functions.
* \see FUNCTIONTAG.
*/
#define LAMBDATAG "LMDA"
/**
* The string `LMDA`, considered as an `unsigned int`.
*/
#define LAMBDATV 1094995276
/**
* A loop exit is a special kind of exception which has exactly the same
* payload as an exception.
*/
#define LOOPTAG "LOOP"
/**
* The string `LOOX`, considered as an `unsigned int`.
*/
#define LOOPTV 1347374924
/**
* @brief Tag for a lazy cons cell.
*
* A lazy cons cell is like a cons cell, but lazy.
*
*/
#define LAZYCONSTAG "LZYC"
/**
* @brief Tag for a lazy string cell.
*
* A lazy string cell is like a string cell, but lazy.
*
*/
#define LAZYSTRTAG "LZYS"
/**
* @brief Tag for a lazy worker cell.
*
* A lazy
*
*/
#define LAZYWRKRTAG "WRKR"
/**
* The special cons cell at address {0,0} whose car and cdr both point to
* itself.
*/
#define NILTAG "NIL "
/**
* The string `NIL `, considered as an `unsigned int`.
*/
#define NILTV 541870414
/**
* An nlambda cell. NLambdas are the interpretable (source) versions of special
* forms. \see SPECIALTAG.
*/
#define NLAMBDATAG "NLMD"
/**
* The string `NLMD`, considered as an `unsigned int`.
*/
#define NLAMBDATV 1145916494
/**
* A rational number, stored as pointers two integers representing dividend
* and divisor respectively.
*/
#define RATIOTAG "RTIO"
/**
* The string `RTIO`, considered as an `unsigned int`.
*/
#define RATIOTV 1330205778
/**
* An open read stream.
*/
#define READTAG "READ"
/**
* The string `READ`, considered as an `unsigned int`.
*/
#define READTV 1145128274
/**
* A real number, represented internally as an IEEE 754-2008 `binary128`.
*/
#define REALTAG "REAL"
/**
* The string `REAL`, considered as an `unsigned int`.
*/
#define REALTV 1279346002
/**
* A special form - one whose arguments are not pre-evaluated but passed as
* provided.
* \see NLAMBDATAG.
*/
#define SPECIALTAG "SPFM"
/**
* The string `SPFM`, considered as an `unsigned int`.
*/
#define SPECIALTV 1296453715
/**
* A string of characters, organised as a linked list.
*/
#define STRINGTAG "STRG"
/**
* The string `STRG`, considered as an `unsigned int`.
*/
#define STRINGTV 1196577875
/**
* A symbol is just like a keyword except not self-evaluating.
*/
#define SYMBOLTAG "SYMB"
/**
* The string `SYMB`, considered as an `unsigned int`.
*/
#define SYMBOLTV 1112365395
/**
* A time stamp.
*/
#define TIMETAG "TIME"
/**
* The string `TIME`, considered as an `unsigned int`.
*/
#define TIMETV 1162692948
/**
* The special cons cell at address {0,1} which is canonically different
* from NIL.
*/
#define TRUETAG "TRUE"
/**
* The string `TRUE`, considered as an `unsigned int`.
*/
#define TRUETV 1163219540
/**
* A pointer to an object in vector space.
*/
#define VECTORPOINTTAG "VECP"
/**
* The string `VECP`, considered as an `unsigned int`.
*/
#define VECTORPOINTTV 1346585942
/**
* An open write stream.
*/
#define WRITETAG "WRIT"
/**
* The string `WRIT`, considered as an `unsigned int`.
*/
#define WRITETV 1414091351
/**
* a cons pointer which points to the special NIL cell
*/
#define NIL (struct cons_pointer){ 0, 0}
/**
* a cons pointer which points to the special T cell
*/
#define TRUE (struct cons_pointer){ 0, 1}
/**
* the maximum possible value of a reference count
*/
#define MAXREFERENCE 4294967295
/**
* a macro to convert a tag into a number
*/
#define tag2uint(tag) ((uint32_t)*tag)
/**
* given a cons_pointer as argument, return the cell.
*/
#define pointer2cell(pointer) ((conspages[pointer.page]->cell[pointer.offset]))
/**
* true if `conspoint` points to the special cell NIL, else false
* (there should only be one of these so it's slightly redundant).
*/
#define nilp(conspoint) (check_tag(conspoint,NILTV))
/**
* true if `conspoint` points to a cons cell, else false
*/
#define consp(conspoint) (check_tag(conspoint,CONSTV))
/**
* true if `conspoint` points to an exception, else false
*/
#define exceptionp(conspoint) (check_tag(conspoint,EXCEPTIONTV))
/**
* true if `conspoint` points to an unassigned cell, else false
*/
#define freep(conspoint) (check_tag(conspoint,FREETV))
/**
* true if `conspoint` points to a function cell, else false
*/
#define functionp(conspoint) (check_tag(conspoint,FUNCTIONTV))
/**
* true if `conspoint` points to a keyword, else false
*/
#define keywordp(conspoint) (check_tag(conspoint,KEYTV))
/**
* true if `conspoint` points to a Lambda binding cell, else false
*/
#define lambdap(conspoint) (check_tag(conspoint,LAMBDATV))
/**
* true if `conspoint` points to a loop recursion, else false.
*/
#define loopp(conspoint) (check_tag(conspoint,LOOPTV))
/**
* true if `conspoint` points to a special form cell, else false
*/
#define specialp(conspoint) (check_tag(conspoint,SPECIALTV))
/**
* true if `conspoint` points to a string cell, else false
*/
#define stringp(conspoint) (check_tag(conspoint,STRINGTV))
/**
* true if `conspoint` points to a symbol cell, else false
*/
#define symbolp(conspoint) (check_tag(conspoint,SYMBOLTV))
/**
* true if `conspoint` points to an integer cell, else false
*/
#define integerp(conspoint) (check_tag(conspoint,INTEGERTV))
/**
* true if `conspoint` points to a rational number cell, else false
*/
#define ratiop(conspoint) (check_tag(conspoint,RATIOTV))
/**
* true if `conspoint` points to a read stream cell, else false
*/
#define readp(conspoint) (check_tag(conspoint,READTV))
/**
* true if `conspoint` points to a real number cell, else false
*/
#define realp(conspoint) (check_tag(conspoint,REALTV))
/**
* true if `conspoint` points to some sort of a number cell,
* else false
*/
#define numberp(conspoint) (check_tag(conspoint,INTEGERTV)||check_tag(conspoint,RATIOTV)||check_tag(conspoint,REALTV))
/**
* true if `conspoint` points to a sequence (list, string or, later, vector),
* else false.
*/
#define sequencep(conspoint) (check_tag(conspoint,CONSTV)||check_tag(conspoint,STRINGTV)||check_tag(conspoint,SYMBOLTV))
/**
* true if `conspoint` points to a vector pointer, else false.
*/
#define vectorpointp(conspoint) (check_tag(conspoint,VECTORPOINTTV))
/**
* true if `conspoint` points to a write stream cell, else false.
*/
#define writep(conspoint) (check_tag(conspoint,WRITETV))
#define streamp(conspoint) (check_tag(conspoint,READTV)||check_tag(conspoint,WRITETV))
/**
* true if `conspoint` points to a true cell, else false
* (there should only be one of these so it's slightly redundant).
* Also note that anything that is not NIL is truthy.
*/
#define tp(conspoint) (check_tag(conspoint,TRUETV))
/**
* true if `conspoint` points to a time cell, else false.
*/
#define timep(conspoint) (check_tag(conspoint,TIMETV))
/**
* true if `conspoint` points to something that is truthy, i.e.
* anything but NIL.
*/
#define truep(conspoint) (!check_tag(conspoint,NILTV))
/**
* An indirect pointer to a cons cell
*/
struct cons_pointer {
/** the index of the page on which this cell resides */
uint32_t page;
/** the index of the cell within the page */
uint32_t offset;
};
/*
* number of arguments stored in a stack frame
*/
#define args_in_frame 8
/**
* A stack frame. Yes, I know it isn't a cons-space object, but it's defined
* here to avoid circularity. \todo refactor.
*/
struct stack_frame {
/** the previous frame. */
struct cons_pointer previous;
/** first 8 arument bindings. */
struct cons_pointer arg[args_in_frame];
/** list of any further argument bindings. */
struct cons_pointer more;
/** the function to be called. */
struct cons_pointer function;
/** the number of arguments provided. */
int args;
/** the depth of the stack below this frame */
int depth;
};
/**
* payload of a cons cell.
*/
struct cons_payload {
/** Contents of the Address Register, naturally. */
struct cons_pointer car;
/** Contents of the Decrement Register, naturally. */
struct cons_pointer cdr;
};
/**
* Payload of an exception.
* Message should be a Lisp string; frame should be a pointer to an (unfreed) stack frame.
*/
struct exception_payload {
/** The payload: usually a Lisp string but in practice anything printable will do. */
struct cons_pointer payload;
/** pointer to the (unfreed) stack frame in which the exception was thrown. */
struct cons_pointer frame;
};
/**
* Payload of a function cell.
* source points to the source from which the function was compiled, or NIL
* if it is a primitive.
* executable points to a function which takes a pointer to a stack frame
* (representing its stack frame) and a cons pointer (representing its
* environment) as arguments and returns a cons pointer (representing its
* result).
*/
struct function_payload {
/**
* pointer to metadata (e.g. the source from which the function was compiled).
*/
struct cons_pointer meta;
/** pointer to a function which takes a cons pointer (representing
* its argument list) and a cons pointer (representing its environment) and a
* stack frame (representing the previous stack frame) as arguments and returns
* a cons pointer (representing its result).
* \todo check this documentation is current!
*/
struct cons_pointer ( *executable ) ( struct stack_frame *,
struct cons_pointer,
struct cons_pointer );
};
/**
* payload of a free cell. For the time being identical to a cons cell,
* but it may not be so in future.
*/
struct free_payload {
struct cons_pointer car;
struct cons_pointer cdr;
};
/**
* payload of an integer cell. An integer is in principle a sequence of cells;
* only 60 bits (+ sign bit) are actually used in each cell. If the value
* exceeds 60 bits, the least significant 60 bits are stored in the first cell
* in the chain, the next 60 in the next cell, and so on. Only the value of the
* first cell in any chain should be negative.
*
* \todo Why is this 60, and not 64 bits?
*/
struct integer_payload {
/** the value of the payload (i.e. 60 bits) of this cell. */
int64_t value;
/** the next (more significant) cell in the chain, or `NIL` if there are no
* more. */
struct cons_pointer more;
};
/**
* payload for lambda and nlambda cells.
*/
struct lambda_payload {
/** the arument list */
struct cons_pointer args;
/** the body of the function to be applied to the arguments. */
struct cons_pointer body;
};
/**
* payload for ratio cells. Both `dividend` and `divisor` must point to integer cells.
*/
struct ratio_payload {
/** a pointer to an integer representing the dividend */
struct cons_pointer dividend;
/** a pointer to an integer representing the divisor. */
struct cons_pointer divisor;
};
/**
* payload for a real number cell. Internals of this liable to change to give 128 bits
* precision, but I'm not sure of the detail.
*/
struct real_payload {
/** the value of the number */
long double value;
};
/**
* Payload of a special form cell. Currently identical to the payload of a
* function cell.
* \see function_payload
*/
struct special_payload {
/**
* pointer to the source from which the special form was compiled, or NIL
* if it is a primitive.
*/
struct cons_pointer meta;
/** pointer to a function which takes a cons pointer (representing
* its argument list) and a cons pointer (representing its environment) and a
* stack frame (representing the previous stack frame) as arguments and returns
* a cons pointer (representing its result). */
struct cons_pointer ( *executable ) ( struct stack_frame *,
struct cons_pointer,
struct cons_pointer );
};
/**
* payload of a read or write stream cell.
*/
struct stream_payload {
/** the stream to read from or write to. */
URL_FILE *stream;
/** metadata on the stream (e.g. its file attributes if a file, its HTTP
* headers if a URL, etc). Expected to be an association, or nil. Not yet
* implemented. */
struct cons_pointer meta;
};
/**
* payload of a string cell. At least at first, only one UTF character will
* be stored in each cell. The doctrine that 'a symbol is just a string'
* didn't work; however, the payload of a symbol or keyword cell is identical
* to the payload of a string cell, except that a keyword may store a hash
* of its own value in the padding.
*/
struct string_payload {
/** the actual character stored in this cell */
wint_t character;
/** a hash of the string value, computed at store time. */
uint32_t hash;
/** the remainder of the string following this character. */
struct cons_pointer cdr;
};
/**
* The payload of a time cell: an unsigned 128 bit value representing micro-
* seconds since the estimated date of the Big Bang (actually, for
* convenience, 14Bn years before 1st Jan 1970 (the UNIX epoch))
*/
struct time_payload {
unsigned __int128 value;
};
/**
* payload of a vector pointer cell.
*/
struct vectorp_payload {
/** the tag of the vector-space object. NOTE that the vector space object
* should itself have the identical tag. */
union {
/** the tag (type) of the vector-space object this cell
* points to, considered as bytes. */
char bytes[TAGLENGTH];
/** the tag considered as a number */
uint32_t value;
} tag;
/** unused padding to word-align the address */
uint32_t padding;
/** the address of the actual vector space
* object (\todo will change when I actually
* implement vector space) */
void *address;
};
/**
* an object in cons space.
*/
struct cons_space_object {
union {
/** the tag (type) of this cell,
* considered as bytes */
char bytes[TAGLENGTH];
/** the tag considered as a number */
uint32_t value;
} tag;
/** the count of the number of references to this cell */
uint32_t count;
/** cons pointer to the access control list of this cell */
struct cons_pointer access;
union {
/**
* if tag == CONSTAG
*/
struct cons_payload cons;
/**
* if tag == EXCEPTIONTAG || tag == LOOPTAG
*/
struct exception_payload exception;
/**
* if tag == FREETAG
*/
struct free_payload free;
/**
* if tag == FUNCTIONTAG
*/
struct function_payload function;
/**
* if tag == INTEGERTAG
*/
struct integer_payload integer;
/**
* if tag == LAMBDATAG or NLAMBDATAG
*/
struct lambda_payload lambda;
/**
* if tag == NILTAG; we'll treat the special cell NIL as just a cons
*/
struct cons_payload nil;
/**
* if tag == RATIOTAG
*/
struct ratio_payload ratio;
/**
* if tag == READTAG || tag == WRITETAG
*/
struct stream_payload stream;
/**
* if tag == REALTAG
*/
struct real_payload real;
/**
* if tag == SPECIALTAG
*/
struct special_payload special;
/**
* if tag == STRINGTAG || tag == SYMBOLTAG
*/
struct string_payload string;
/**
* if tag == TIMETAG
*/
struct time_payload time;
/**
* if tag == TRUETAG; we'll treat the special cell T as just a cons
*/
struct cons_payload t;
/**
* if tag == VECTORPTAG
*/
struct vectorp_payload vectorp;
} payload;
};
bool check_tag( struct cons_pointer pointer, uint32_t value );
struct cons_pointer inc_ref( struct cons_pointer pointer );
struct cons_pointer dec_ref( struct cons_pointer pointer );
/**
* given a cons_pointer as argument, return the tag.
*/
uint32_t get_tag_value( struct cons_pointer pointer );
struct cons_pointer c_type( struct cons_pointer pointer );
struct cons_pointer c_car( struct cons_pointer arg );
struct cons_pointer c_cdr( struct cons_pointer arg );
int c_length( struct cons_pointer arg );
struct cons_pointer make_cons( struct cons_pointer car,
struct cons_pointer cdr );
struct cons_pointer make_exception( struct cons_pointer message,
struct cons_pointer frame_pointer );
struct cons_pointer make_function( struct cons_pointer src,
struct cons_pointer ( *executable )
( struct stack_frame *,
struct cons_pointer,
struct cons_pointer ) );
struct cons_pointer c_string_to_lisp_keyword( wchar_t *symbol );
struct cons_pointer make_lambda( struct cons_pointer args,
struct cons_pointer body );
struct cons_pointer make_nlambda( struct cons_pointer args,
struct cons_pointer body );
struct cons_pointer make_special( struct cons_pointer src,
struct cons_pointer ( *executable )
( struct stack_frame *,
struct cons_pointer,
struct cons_pointer ) );
struct cons_pointer make_string_like_thing( wint_t c, struct cons_pointer tail,
uint32_t tag );
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 );
#define make_symbol(c, t) (make_symbol_or_key( c, t, SYMBOLTV))
#define make_keyword(c, t) (make_symbol_or_key( c, t, KEYTV))
struct cons_pointer make_read_stream( URL_FILE * input,
struct cons_pointer metadata );
struct cons_pointer make_write_stream( URL_FILE * output,
struct cons_pointer metadata );
struct cons_pointer c_string_to_lisp_string( wchar_t *string );
struct cons_pointer c_string_to_lisp_symbol( wchar_t *symbol );
#endif

9
archive/c/memory/cursor.c Normal file
View file

@ -0,0 +1,9 @@
/*
* a cursor is a cons-space object which holds:
* 1. a pointer to a vector (i.e. a vector-space object which holds an
* array of `cons_pointer`);
* 2. an integer offset into that array.
*
* this provides a mechanism for iterating through vectors (actually, in
* either direction)
*/

BIN
archive/c/memory/cursor.h Normal file
View file

Binary file not shown.

166
archive/c/memory/dump.c Normal file
View file

@ -0,0 +1,166 @@
/*
* dump.c
*
* Dump representations of both cons space and vector space objects.
*
*
* (c) 2018 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <stdint.h>
#include <stdlib.h>
#include <string.h>
#include <stdio.h>
/*
* wide characters
*/
#include <wchar.h>
#include <wctype.h>
#include "memory/conspage.h"
#include "memory/consspaceobject.h"
#include "debug.h"
#include "memory/hashmap.h"
#include "ops/intern.h"
#include "io/io.h"
#include "io/print.h"
#include "memory/stack.h"
#include "memory/vectorspace.h"
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 ) {
url_fwprintf( output,
L"\t\t%ls cell: termination; next at page %d offset %d, count %u\n",
prefix,
cell.payload.string.cdr.page,
cell.payload.string.cdr.offset, cell.count );
} else {
url_fwprintf( output,
L"\t\t%ls cell: character '%lc' (%d) with hash %d; next at page %d offset %d, count %u\n",
prefix,
( wint_t ) cell.payload.string.character,
cell.payload.string.character,
cell.payload.string.hash,
cell.payload.string.cdr.page,
cell.payload.string.cdr.offset, cell.count );
url_fwprintf( output, L"\t\t value: " );
print( output, pointer );
url_fwprintf( output, L"\n" );
}
}
/**
* dump the object at this cons_pointer to this output stream.
*/
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,
cell.count );
switch ( cell.tag.value ) {
case CONSTV:
url_fwprintf( output,
L"\t\tCons cell: car at page %d offset %d, cdr at page %d "
L"offset %d, count %u :",
cell.payload.cons.car.page,
cell.payload.cons.car.offset,
cell.payload.cons.cdr.page,
cell.payload.cons.cdr.offset, cell.count );
print( output, pointer );
url_fputws( L"\n", output );
break;
case EXCEPTIONTV:
url_fwprintf( output, L"\t\tException cell: " );
dump_stack_trace( output, pointer );
break;
case FREETV:
url_fwprintf( output,
L"\t\tFree cell: next at page %d offset %d\n",
cell.payload.cons.cdr.page,
cell.payload.cons.cdr.offset );
break;
case INTEGERTV:
url_fwprintf( output, L"\t\tInteger cell: value %ld, count %u\n",
cell.payload.integer.value, cell.count );
if ( !nilp( cell.payload.integer.more ) ) {
url_fputws( L"\t\tBIGNUM! More at:\n", output );
dump_object( output, cell.payload.integer.more );
}
break;
case KEYTV:
dump_string_cell( output, L"Keyword", pointer );
break;
case LAMBDATV:
url_fwprintf( output, L"\t\t\u03bb cell;\n\t\t args: " );
print( output, cell.payload.lambda.args );
url_fwprintf( output, L";\n\t\t\tbody: " );
print( output, cell.payload.lambda.body );
url_fputws( L"\n", output );
break;
case NILTV:
break;
case NLAMBDATV:
url_fwprintf( output, L"\t\tn\u03bb cell; \n\t\targs: " );
print( output, cell.payload.lambda.args );
url_fwprintf( output, L";\n\t\t\tbody: " );
print( output, cell.payload.lambda.body );
url_fputws( L"\n", output );
break;
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 );
break;
case READTV:
url_fputws( L"\t\tInput stream; metadata: ", output );
print( output, cell.payload.stream.meta );
url_fputws( L"\n", output );
break;
case REALTV:
url_fwprintf( output, L"\t\tReal cell: value %Lf, count %u\n",
cell.payload.real.value, cell.count );
break;
case STRINGTV:
dump_string_cell( output, L"String", pointer );
break;
case SYMBOLTV:
dump_string_cell( output, L"Symbol", pointer );
break;
case TRUETV:
break;
case VECTORPOINTTV:{
url_fwprintf( output,
L"\t\tPointer to vector-space object at %p\n",
cell.payload.vectorp.address );
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 ) {
case STACKFRAMETV:
dump_frame( output, pointer );
break;
case HASHTV:
dump_map( output, pointer );
break;
}
}
break;
case WRITETV:
url_fputws( L"\t\tOutput stream; metadata: ", output );
print( output, cell.payload.stream.meta );
url_fputws( L"\n", output );
break;
}
}

27
archive/c/memory/dump.h Normal file
View file

@ -0,0 +1,27 @@
/*
* dump.h
*
* Dump representations of both cons space and vector space objects.
*
* (c) 2018 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <stdbool.h>
#include <stdint.h>
#include <stdio.h>
/*
* wide characters
*/
#include <wchar.h>
#include <wctype.h>
#ifndef __dump_h
#define __dump_h
void dump_string_cell( URL_FILE * output, wchar_t *prefix,
struct cons_pointer pointer );
void dump_object( URL_FILE * output, struct cons_pointer pointer );
#endif

152
archive/c/memory/hashmap.c Normal file
View file

@ -0,0 +1,152 @@
/*
* hashmap.c
*
* Basic implementation of a hashmap.
*
* (c) 2021 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include "arith/integer.h"
#include "arith/peano.h"
#include "authorise.h"
#include "debug.h"
#include "ops/intern.h"
#include "io/print.h"
#include "memory/conspage.h"
#include "memory/consspaceobject.h"
#include "memory/hashmap.h"
#include "memory/vectorspace.h"
/**
* A lisp function signature conforming wrapper around get_hash, q.v..
*/
struct cons_pointer lisp_get_hash( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ) {
return make_integer( get_hash( frame->arg[0] ), NIL );
}
/**
* Lisp funtion of up to four args (all optional), where
*
* first is expected to be an integer, the number of buckets, or nil;
* second is expected to be a hashing function, or nil;
* third is expected to be an assocable, or nil;
* fourth is a list of user tokens, to be used as a write ACL, or nil.
*/
struct cons_pointer lisp_make_hashmap( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ) {
uint32_t n = DFLT_HASHMAP_BUCKETS;
struct cons_pointer hash_fn = NIL;
struct cons_pointer result = NIL;
if ( frame->args > 0 ) {
if ( integerp( frame->arg[0] ) ) {
n = to_long_int( frame->arg[0] ) % UINT32_MAX;
} else if ( !nilp( frame->arg[0] ) ) {
result =
make_exception( c_string_to_lisp_string
( L"First arg to `hashmap`, if passed, must "
L"be an integer or `nil`.`" ), NIL );
}
}
if ( frame->args > 1 ) {
if ( functionp( frame->arg[1] ) ) {
hash_fn = frame->arg[1];
} else if ( nilp( frame->arg[1] ) ) {
/* that's allowed */
} else {
result =
make_exception( c_string_to_lisp_string
( L"Second arg to `hashmap`, if passed, must "
L"be a function or `nil`.`" ), NIL );
}
}
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] =
make_cons( make_cons( key, val ),
map->payload.hashmap.buckets[bucket_no] );
}
}
}
return result;
}
/**
* Expects `frame->arg[1]` to be a hashmap or namespace; `frame->arg[2]` to be
* a string-like-thing (perhaps necessarily a keyword); frame->arg[3] to be
* any value. If
* current user is authorised to write to this hashmap, modifies the hashmap and
* returns it; if not, clones the hashmap, modifies the clone, and returns that.
*/
struct cons_pointer lisp_hashmap_put( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ) {
// TODO: if current user has write access to this hashmap
struct cons_pointer mapp = frame->arg[0];
struct cons_pointer key = frame->arg[1];
struct cons_pointer val = frame->arg[2];
struct cons_pointer result = hashmap_put( mapp, key, val );
struct cons_space_object *cell = &pointer2cell( result );
return result;
// TODO: else clone and return clone.
}
/**
* Lisp function expecting two arguments, a hashmap and an assoc list. Copies all
* key/value pairs from the assoc list into the map.
*/
struct cons_pointer lisp_hashmap_put_all( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ) {
return hashmap_put_all( frame->arg[0], frame->arg[1] );
}
struct cons_pointer lisp_hashmap_keys( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ) {
return hashmap_keys( frame->arg[0] );
}
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 );
url_fwprintf( output, L"\tHash function: " );
print( output, payload->hash_fn );
url_fwprintf( output, L"\n\tWrite ACL: " );
print( output, payload->write_acl );
url_fwprintf( output, L"\n\tBuckets:" );
for ( int i = 0; i < payload->n_buckets; i++ ) {
url_fwprintf( output, L"\n\t\t[%d]: ", i );
print( output, payload->buckets[i] );
}
url_fwprintf( output, L"\n" );
}

38
archive/c/memory/hashmap.h Normal file
View file

@ -0,0 +1,38 @@
/*
* hashmap.h
*
* Basic implementation of a hashmap.
*
* (c) 2021 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#ifndef __psse_hashmap_h
#define __psse_hashmap_h
#include "arith/integer.h"
#include "memory/conspage.h"
#include "memory/consspaceobject.h"
#include "memory/vectorspace.h"
#define DFLT_HASHMAP_BUCKETS 32
struct cons_pointer lisp_get_hash( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_hashmap_put( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_hashmap_put_all( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_make_hashmap( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
#endif

1281
archive/c/memory/lookup3.c Normal file
View file

File diff suppressed because it is too large Load diff

16
archive/c/memory/lookup3.h Normal file
View file

@ -0,0 +1,16 @@
/**
* lookup3.h
*
* Minimal header file wrapping Bob Jenkins' lookup3.c
*
*
* (c) 2019 Simon Brooke <simon@journeyman.cc>
* Public domain.
*/
#ifndef __lookup3_h
#define __lookup3_h
uint32_t hashword( const uint32_t * k, size_t length, uint32_t initval );
#endif

380
archive/c/memory/stack.c Normal file
View file

@ -0,0 +1,380 @@
/*
* stack.c
*
* The Lisp evaluation stack.
*
* Stack frames could be implemented in cons space; indeed, the stack
* could simply be an assoc list consed onto the front of the environment.
* But such a stack would be costly to search. The design sketched here,
* with stack frames as special objects, SHOULD be substantially more
* efficient, but does imply we need to generalise the idea of cons pages
* with freelists to a more general 'equal sized object pages', so that
* allocating/freeing stack frames can be more efficient.
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <stdlib.h>
#include "debug.h"
#include "io/print.h"
#include "memory/conspage.h"
#include "memory/consspaceobject.h"
#include "memory/dump.h"
#include "memory/stack.h"
#include "memory/vectorspace.h"
#include "ops/lispops.h"
/**
* @brief If non-zero, maximum depth of stack.
*
*/
uint32_t stack_limit = 0;
/**
* set a register in a stack frame. Alwaye use this to do so,
* because that way we can be sure the inc_ref happens!
*/
void set_reg( struct stack_frame *frame, int reg, struct cons_pointer value ) {
debug_printf( DEBUG_STACK, L"\tSetting register %d to ", reg );
debug_print_object( value, DEBUG_STACK );
debug_println( DEBUG_STACK );
dec_ref( frame->arg[reg] ); /* if there was anything in that slot
* previously other than NIL, we need to decrement it;
* NIL won't be decremented as it is locked. */
frame->arg[reg] = value;
inc_ref( value );
if ( reg == frame->args ) {
frame->args++;
}
}
/**
* get the actual stackframe object from this `pointer`, or NULL if
* `pointer` is not a stackframe pointer.
*/
struct stack_frame *get_stack_frame( struct cons_pointer pointer ) {
struct stack_frame *result = NULL;
struct vector_space_object *vso =
pointer2cell( pointer ).payload.vectorp.address;
if ( vectorpointp( pointer ) && stackframep( vso ) ) {
result = ( struct stack_frame * ) &( vso->payload );
// debug_printf( DEBUG_STACK,
// L"\nget_stack_frame: all good, returning %p\n", result );
} else {
debug_print( L"\nget_stack_frame: fail, returning NULL\n",
DEBUG_STACK );
}
return result;
}
/**
* Make an empty stack frame, and return it.
*
* This function does the actual meat of making the frame.
*
* @param previous the current top-of-stack;
* @param depth the depth of the new frame.
* @return the new frame, or NULL if memory is exhausted.
*/
struct cons_pointer in_make_empty_frame( struct cons_pointer previous,
uint32_t depth ) {
debug_print( L"Entering make_empty_frame\n", DEBUG_ALLOC );
struct cons_pointer result =
make_vso( STACKFRAMETV, sizeof( struct stack_frame ) );
if ( !nilp( result ) ) {
struct stack_frame *frame = get_stack_frame( result );
/*
* \todo later, pop a frame off a free-list of stack frames
*/
frame->previous = previous;
frame->depth = depth;
/*
* The frame has already been cleared with memset in make_vso, but our
* NIL is not the same as C's NULL.
*/
frame->more = NIL;
frame->function = NIL;
frame->args = 0;
for ( int i = 0; i < args_in_frame; i++ ) {
frame->arg[i] = NIL;
}
debug_dump_object( result, DEBUG_ALLOC );
}
debug_print( L"Leaving make_empty_frame\n", DEBUG_ALLOC );
debug_dump_object( result, DEBUG_ALLOC );
return result;
}
/**
* @brief Make an empty stack frame, and return it.
*
* This function does the error checking around actual construction.
*
* @param previous the current top-of-stack;
* @param env the environment in which evaluation happens.
* @return the new frame, or NULL if memory is exhausted.
*/
struct cons_pointer make_empty_frame( struct cons_pointer previous ) {
struct cons_pointer result = NIL;
uint32_t depth =
( nilp( previous ) ) ? 0 : ( get_stack_frame( previous ) )->depth + 1;
if ( stack_limit == 0 || stack_limit > depth ) {
result = in_make_empty_frame( previous, depth );
} else {
debug_printf( DEBUG_STACK,
L"WARNING: Exceeded stack limit of %d\n", stack_limit );
result =
make_exception( c_string_to_lisp_string
( L"Stack limit exceeded." ), previous );
}
if ( nilp( result ) ) {
/* i.e. out of memory */
result =
make_exception( privileged_string_memory_exhausted, previous );
}
return result;
}
/**
* Allocate a new stack frame with its previous pointer set to this value,
* its arguments set up from these args, evaluated in this env.
* @param previous the current top-of-stack;
* @args the arguments to load into this frame;
* @param env the environment in which evaluation happens.
* @return the new frame, or an exception if one occurred while building it.
*/
struct cons_pointer make_stack_frame( struct cons_pointer previous,
struct cons_pointer args,
struct cons_pointer env ) {
debug_print( L"Entering make_stack_frame\n", DEBUG_STACK );
struct cons_pointer result = make_empty_frame( previous );
if ( !exceptionp( result ) ) {
struct stack_frame *frame = get_stack_frame( result );
while ( frame->args < args_in_frame && consp( args ) ) {
/* iterate down the arg list filling in the arg slots in the
* frame. When there are no more slots, if there are still args,
* stash them on more */
struct cons_space_object cell = pointer2cell( args );
/*
* \todo if we were running on real massively parallel hardware,
* each arg except the first should be handed off to another
* processor to be evaled in parallel; but see notes here:
* https://github.com/simon-brooke/post-scarcity/wiki/parallelism
*/
struct cons_pointer val =
eval_form( frame, result, cell.payload.cons.car, env );
if ( exceptionp( val ) ) {
result = val;
break;
} else {
debug_printf( DEBUG_STACK, L"\tSetting argument %d to ",
frame->args );
debug_print_object( cell.payload.cons.car, DEBUG_STACK );
debug_print( L"\n", DEBUG_STACK );
set_reg( frame, frame->args, val );
}
args = cell.payload.cons.cdr;
}
if ( !exceptionp( result ) ) {
if ( consp( args ) ) {
/* if we still have args, eval them and stick the values on `more` */
struct cons_pointer more =
eval_forms( get_stack_frame( previous ), previous, args,
env );
frame->more = more;
inc_ref( more );
for ( ; !nilp( args ); args = c_cdr( args ) ) {
frame->args++;
}
}
}
debug_print( L"make_stack_frame: returning\n", DEBUG_STACK );
debug_dump_object( result, DEBUG_STACK );
}
return result;
}
/**
* A 'special' frame is exactly like a normal stack frame except that the
* arguments are unevaluated.
* @param previous the previous stack frame;
* @param args a list of the arguments to be stored in this stack frame;
* @param env the execution environment;
* @return a new special frame.
*/
struct cons_pointer make_special_frame( struct cons_pointer previous,
struct cons_pointer args,
struct cons_pointer env ) {
debug_print( L"Entering make_special_frame\n", DEBUG_STACK );
struct cons_pointer result = make_empty_frame( previous );
if ( !exceptionp( result ) ) {
struct stack_frame *frame = get_stack_frame( result );
while ( frame->args < args_in_frame && !nilp( args ) ) {
/* iterate down the arg list filling in the arg slots in the
* frame. When there are no more slots, if there are still args,
* stash them on more */
struct cons_space_object cell = pointer2cell( args );
set_reg( frame, frame->args, cell.payload.cons.car );
args = cell.payload.cons.cdr;
}
if ( !exceptionp( result ) ) {
if ( consp( args ) ) {
frame->more = args;
inc_ref( args );
}
}
}
debug_print( L"make_special_frame: returning\n", DEBUG_STACK );
debug_dump_object( result, DEBUG_STACK );
return result;
}
/**
* Free this stack frame.
*/
void free_stack_frame( struct stack_frame *frame ) {
/*
* \todo later, push it back on the stack-frame freelist
*/
debug_print( L"Entering free_stack_frame\n", DEBUG_ALLOC );
for ( int i = 0; i < args_in_frame; i++ ) {
dec_ref( frame->arg[i] );
}
if ( !nilp( frame->more ) ) {
dec_ref( frame->more );
}
debug_print( L"Leaving free_stack_frame\n", DEBUG_ALLOC );
}
struct cons_pointer frame_get_previous( struct cons_pointer frame_pointer ) {
struct stack_frame *frame = get_stack_frame( frame_pointer );
struct cons_pointer result = NIL;
if ( frame != NULL ) {
result = frame->previous;
}
return result;
}
void dump_frame_context_fragment( URL_FILE *output,
struct cons_pointer frame_pointer ) {
struct stack_frame *frame = get_stack_frame( frame_pointer );
if ( frame != NULL ) {
url_fwprintf( output, L" <= " );
print( output, frame->arg[0] );
}
}
void dump_frame_context( URL_FILE *output, struct cons_pointer frame_pointer,
int depth ) {
struct stack_frame *frame = get_stack_frame( frame_pointer );
if ( frame != NULL ) {
url_fwprintf( output, L"\tContext: " );
int i = 0;
for ( struct cons_pointer cursor = frame_pointer;
i++ < depth && !nilp( cursor );
cursor = frame_get_previous( cursor ) ) {
dump_frame_context_fragment( output, cursor );
}
url_fwprintf( output, L"\n" );
}
}
/**
* Dump a stackframe to this stream for debugging
* @param output the stream
* @param frame_pointer the pointer to the frame
*/
void dump_frame( URL_FILE *output, struct cons_pointer frame_pointer ) {
struct stack_frame *frame = get_stack_frame( frame_pointer );
if ( frame != NULL ) {
url_fwprintf( output, L"Stack frame %d with %d arguments:\n",
frame->depth, frame->args );
dump_frame_context( output, frame_pointer, 4 );
for ( int arg = 0; arg < frame->args; arg++ ) {
struct cons_space_object cell = pointer2cell( frame->arg[arg] );
url_fwprintf( output, L"\tArg %d:\t%4.4s\tcount: %10u\tvalue: ",
arg, cell.tag.bytes, cell.count );
print( output, frame->arg[arg] );
url_fputws( L"\n", output );
}
if ( !nilp( frame->more ) ) {
url_fputws( L"More: \t", output );
print( output, frame->more );
url_fputws( L"\n", output );
}
}
}
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 );
dump_stack_trace( output,
pointer2cell( pointer ).payload.exception.frame );
} else {
while ( vectorpointp( pointer )
&& stackframep( pointer_to_vso( pointer ) ) ) {
dump_frame( output, pointer );
pointer = get_stack_frame( pointer )->previous;
}
}
}
/**
* Fetch a pointer to the value of the local variable at this index.
*/
struct cons_pointer fetch_arg( struct stack_frame *frame, unsigned int index ) {
struct cons_pointer result = NIL;
if ( index < args_in_frame ) {
result = frame->arg[index];
} else {
struct cons_pointer p = frame->more;
for ( int i = args_in_frame; i < index; i++ ) {
p = pointer2cell( p ).payload.cons.cdr;
}
result = pointer2cell( p ).payload.cons.car;
}
return result;
}

69
archive/c/memory/stack.h Normal file
View file

@ -0,0 +1,69 @@
/**
* stack.h
*
* The Lisp evaluation stack.
*
* Stack frames could be implemented in cons space; indeed, the stack
* could simply be an assoc list consed onto the front of the environment.
* But such a stack would be costly to search. The design sketched here,
* with stack frames as special objects, SHOULD be substantially more
* efficient, but does imply we need to generalise the idea of cons pages
* with freelists to a more general 'equal sized object pages', so that
* allocating/freeing stack frames can be more efficient.
*
* Stack frames are not yet a first class object; they have no VECP pointer
* in cons space.
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#ifndef __psse_stack_h
#define __psse_stack_h
#include <stdint.h>
#include "consspaceobject.h"
#include "conspage.h"
/**
* macros for the tag of a stack frame.
*/
#define STACKFRAMETAG "STAK"
#define STACKFRAMETV 1262572627
/**
* is this vector-space object a stack frame?
*/
#define stackframep(vso)(((struct vector_space_object *)vso)->header.tag.value == STACKFRAMETV)
extern uint32_t stack_limit;
void set_reg( struct stack_frame *frame, int reg, struct cons_pointer value );
struct stack_frame *get_stack_frame( struct cons_pointer pointer );
struct cons_pointer make_empty_frame( struct cons_pointer previous );
struct cons_pointer make_stack_frame( struct cons_pointer previous,
struct cons_pointer args,
struct cons_pointer env );
void free_stack_frame( struct stack_frame *frame );
void dump_frame( URL_FILE * output, struct cons_pointer pointer );
void dump_stack_trace( URL_FILE * output, struct cons_pointer frame_pointer );
struct cons_pointer fetch_arg( struct stack_frame *frame, unsigned int n );
struct cons_pointer make_special_frame( struct cons_pointer previous,
struct cons_pointer args,
struct cons_pointer env );
/*
* struct stack_frame is defined in consspaceobject.h to break circularity
* \todo refactor.
*/
#endif

158
archive/c/memory/vectorspace.c Normal file
View file

@ -0,0 +1,158 @@
/*
* vectorspace.c
*
* Structures common to all vector space objects.
*
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <math.h>
#include <stdint.h>
#include <stdlib.h>
#include <string.h>
#include <stdio.h>
/*
* wide characters
*/
#include <wchar.h>
#include <wctype.h>
#include "memory/conspage.h"
#include "memory/consspaceobject.h"
#include "debug.h"
#include "io/io.h"
#include "memory/hashmap.h"
#include "memory/stack.h"
#include "memory/vectorspace.h"
#include "ops/intern.h"
/**
* Make a cons_space_object which points to the vector_space_object
* with this `tag` at this `address`.
*
* @address the address of the vector_space_object to point to.
* @tag the vector-space tag of the particular type of vector-space object,
* NOT `VECTORPOINTTV`.
*
* @return a cons_pointer to the object, or NIL if the object could not be
* allocated due to memory exhaustion.
*/
struct cons_pointer make_vec_pointer( struct vector_space_object *address,
uint32_t tag ) {
debug_print( L"Entered make_vec_pointer\n", DEBUG_ALLOC );
struct cons_pointer pointer = allocate_cell( VECTORPOINTTV );
struct cons_space_object *cell = &pointer2cell( pointer );
debug_printf( DEBUG_ALLOC,
L"make_vec_pointer: tag written, about to set pointer address to %p\n",
address );
cell->payload.vectorp.address = address;
cell->payload.vectorp.tag.value = tag;
debug_printf( DEBUG_ALLOC,
L"make_vec_pointer: all good, returning pointer to %p\n",
cell->payload.vectorp.address );
debug_dump_object( pointer, DEBUG_ALLOC );
return pointer;
}
/**
* Allocate a vector space object with this `payload_size` and `tag`,
* and return a `cons_pointer` which points to an object whigh points to it.
*
* @tag the vector-space tag of the particular type of vector-space object,
* NOT `VECTORPOINTTAG`.
* @payload_size the size of the payload required, in bytes.
*
* @return a cons_pointer to the object, or NIL if the object could not be
* allocated due to memory exhaustion.
*/
struct cons_pointer make_vso( uint32_t tag, uint64_t payload_size ) {
debug_print( L"Entered make_vso\n", DEBUG_ALLOC );
struct cons_pointer result = NIL;
int64_t total_size = sizeof( struct vector_space_header ) + payload_size;
/* Pad size to 64 bit words. This is intended to promote access efficiancy
* on 64 bit machines but may just be voodoo coding */
uint64_t padded = ceil( ( total_size * 8.0 ) / 8.0 );
debug_print( L"make_vso: about to malloc\n", DEBUG_ALLOC );
struct vector_space_object *vso = malloc( padded );
if ( vso != NULL ) {
memset( vso, 0, padded );
vso->header.tag.value = tag;
debug_printf( DEBUG_ALLOC,
L"make_vso: written tag '%4.4s' into vso at %p\n",
vso->header.tag.bytes, vso );
result = make_vec_pointer( vso, tag );
debug_dump_object( result, DEBUG_ALLOC );
vso->header.vecp = result;
// memcpy(vso->header.vecp, result, sizeof(struct cons_pointer));
vso->header.size = payload_size;
#ifdef DEBUG
debug_printf( DEBUG_ALLOC,
L"Allocated vector-space object of type %4.4s, total size %ld, payload size %ld, at address %p, payload address %p\n",
&vso->header.tag.bytes, total_size, vso->header.size,
vso, &vso->payload );
if ( padded != total_size ) {
debug_printf( DEBUG_ALLOC, L"\t\tPadded from %d to %d\n",
total_size, padded );
}
#endif
}
#ifdef DEBUG
debug_printf( DEBUG_ALLOC,
L"make_vso: all good, returning pointer to %p\n",
pointer2cell( result ).payload.vectorp.address );
#endif
return result;
}
/** for vector space pointers, free the actual vector-space
* object. Dangerous! */
void free_vso( struct cons_pointer pointer ) {
struct cons_space_object cell = pointer2cell( pointer );
debug_printf( DEBUG_ALLOC,
L"About to free vector-space object of type %s at 0x%lx\n",
( char * ) cell.payload.vectorp.tag.bytes,
cell.payload.vectorp.address );
struct vector_space_object *vso = cell.payload.vectorp.address;
switch ( vso->header.tag.value ) {
case HASHTV:
free_hashmap( pointer );
break;
case STACKFRAMETV:
free_stack_frame( get_stack_frame( pointer ) );
break;
}
// free( (void *)cell.payload.vectorp.address );
debug_printf( DEBUG_ALLOC, L"Freed vector-space object at 0x%lx\n",
cell.payload.vectorp.address );
}
// bool check_vso_tag( struct cons_pointer pointer, char * tag) {
// bool result = false;
// if (check_tag(pointer, VECTORPOINTTAG)) {
// struct vector_space_object * vso = pointer_to_vso(pointer);
// result = strncmp( vso->header.tag.bytes[0], tag, TAGLENGTH);
// }
// return result;
// }

121
archive/c/memory/vectorspace.h Normal file
View file

@ -0,0 +1,121 @@
/**
* vectorspace.h
*
* Declarations common to all vector space objects.
*
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <stdbool.h>
#include <stdint.h>
#include <stdio.h>
/*
* wide characters
*/
#include <wchar.h>
#include <wctype.h>
#include "consspaceobject.h"
#include "hashmap.h"
#ifndef __vectorspace_h
#define __vectorspace_h
/*
* part of the implementation structure of a namespace.
*/
#define HASHTAG "HASH"
#define HASHTV 1213415752
#define hashmapp(conspoint)((check_tag(conspoint,HASHTV)))
/*
* a namespace (i.e. a binding of names to values, implemented as a hashmap)
* TODO: but note that a namespace is now essentially a hashmap with a write ACL
* whose name is interned.
*/
#define NAMESPACETAG "NMSP"
#define NAMESPACETV 1347636558
#define namespacep(conspoint)(check_tag(conspoint,NAMESPACETV))
/*
* a vector of cons pointers.
*/
#define VECTORTAG "VECT"
#define VECTORTV 1413694806
#define vectorp(conspoint)(check_tag(conspoint,VECTORTV))
/**
* given a pointer to a vector space object, return the object.
*/
#define pointer_to_vso(pointer)((vectorpointp(pointer)? (struct vector_space_object *) pointer2cell(pointer).payload.vectorp.address : (struct vector_space_object *) NULL))
/**
* given a vector space object, return its canonical pointer.
*/
#define vso_get_vecp(vso)((((vector_space_object)vso)->header.vecp))
struct cons_pointer make_vso( uint32_t tag, uint64_t payload_size );
void free_vso( struct cons_pointer pointer );
/**
* the header which forms the start of every vector space object.
*/
struct vector_space_header {
/** the tag (type) of this vector-space object. */
union {
/** the tag considered as bytes. */
char bytes[TAGLENGTH];
/** the tag considered as a number */
uint32_t value;
} tag;
/** back pointer to the vector pointer which uniquely points to this vso */
struct cons_pointer vecp;
/** the size of my payload, in bytes */
uint64_t size;
};
/**
* The payload of a hashmap. The number of buckets is assigned at run-time,
* and is stored in n_buckets. Each bucket is something ASSOC can consume:
* i.e. either an assoc list or a further hashmap.
*/
struct hashmap_payload {
struct cons_pointer hash_fn; /* function for hashing values in this hashmap, or `NIL` to use
the default hashing function */
struct cons_pointer write_acl; /* it seems to me that it is likely that the
* principal difference between a hashmap and a
* namespace is that a hashmap has a write ACL
* of `NIL`, meaning not writeable by anyone */
uint32_t n_buckets; /* number of hash buckets */
uint32_t unused; /* for word alignment and possible later expansion */
struct cons_pointer buckets[]; /* actual hash buckets, which should be `NIL`
* or assoc lists or (possibly) further hashmaps. */
};
/** a vector_space_object is just a vector_space_header followed by a
* lump of bytes; what we deem to be in there is a function of the tag,
* and at this stage we don't have a good picture of what these may be.
*
* \see stack_frame for an example payload;
* \see make_empty_frame for an example of how to initialise and use one.
*/
struct vector_space_object {
/** the header of this object */
struct vector_space_header header;
/** we'll malloc `size` bytes for payload, `payload` is just the first of these.
* \todo this is almost certainly not idiomatic C. */
union {
/** the payload considered as bytes */
char bytes;
struct hashmap_payload hashmap;
} payload;
};
#endif