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

Setting up medatata works...

Browse source 
And the `inspect` function correctly shows it. However, the `metadata` function segfaults.
This commit is contained in:
Simon Brooke 2019-01-29 18:31:30 +00:00
parent 10098a83bf
commit eb394d153f
16 changed files with 866 additions and 580 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

70
src/init.c
View file

@ -26,6 +26,7 @@
#include "intern.h" #include "intern.h"
#include "io.h" #include "io.h"
#include "lispops.h" #include "lispops.h"
#include "meta.h"
#include "peano.h" #include "peano.h"
#include "print.h" #include "print.h"
#include "repl.h" #include "repl.h"
@ -43,11 +44,14 @@ void bind_function( wchar_t *name, struct cons_pointer ( *executable )
( struct stack_frame *, ( struct stack_frame *,
struct cons_pointer, struct cons_pointer ) ) { struct cons_pointer, struct cons_pointer ) ) {
struct cons_pointer n = c_string_to_lisp_symbol( name ); struct cons_pointer n = c_string_to_lisp_symbol( name );
inc_ref( n ); struct cons_pointer meta = make_cons(
make_cons(c_string_to_lisp_keyword(L"primitive"), TRUE),
make_cons( make_cons(
c_string_to_lisp_keyword(L"name"),
n),
NIL));
deep_bind( n, make_function( NIL, executable ) ); deep_bind( n, make_function( meta, executable ) );
dec_ref( n );
} }
/** /**
@ -58,11 +62,14 @@ void bind_special( wchar_t *name, struct cons_pointer ( *executable )
( struct stack_frame *, ( struct stack_frame *,
struct cons_pointer, struct cons_pointer ) ) { struct cons_pointer, struct cons_pointer ) ) {
struct cons_pointer n = c_string_to_lisp_symbol( name ); struct cons_pointer n = c_string_to_lisp_symbol( name );
inc_ref( n ); struct cons_pointer meta = make_cons(
make_cons(c_string_to_lisp_keyword(L"primitive"), TRUE),
make_cons( make_cons(
c_string_to_lisp_keyword(L"name"),
n),
NIL));
deep_bind( n, make_special( NIL, executable ) ); deep_bind( n, make_special( NIL, executable ) );
dec_ref( n );
} }
/** /**
@ -87,7 +94,10 @@ int main( int argc, char *argv[] ) {
bool show_prompt = false; bool show_prompt = false;
setlocale( LC_ALL, "" ); setlocale( LC_ALL, "" );
curl_global_init( CURL_GLOBAL_DEFAULT ); if (io_init() != 0) {
fputs("Failed to initialise I/O subsystem\n", stderr);
exit(1);
}
while ( ( option = getopt( argc, argv, "cpdv:" ) ) != -1 ) { while ( ( option = getopt( argc, argv, "cpdv:" ) ) != -1 ) {
switch ( option ) { switch ( option ) {
@ -136,17 +146,40 @@ int main( int argc, char *argv[] ) {
fwide( stdout, 1 ); fwide( stdout, 1 );
fwide( stderr, 1 ); fwide( stderr, 1 );
fwide( sink->handle.file, 1 ); fwide( sink->handle.file, 1 );
bind_value( L"*in*", make_read_stream( file_to_url_file( stdin ) ) ); bind_value( L"*in*", make_read_stream( file_to_url_file( stdin ),
bind_value( L"*out*", make_write_stream( file_to_url_file( stdout ) ) ); make_cons( make_cons
bind_value( L"*log*", make_write_stream( file_to_url_file( stderr ) ) ); ( c_string_to_lisp_keyword
bind_value( L"*sink*", make_write_stream( sink ) ); ( L"url" ),
c_string_to_lisp_string
( L"system:standard input" ) ),
NIL ) ) );
bind_value( L"*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 ) ) );
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 ) ) );
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 ) ) );
/* /*
* the default prompt * the default prompt
*/ */
bind_value( L"*prompt*", bind_value( L"*prompt*",
show_prompt ? c_string_to_lisp_symbol( L":: " ) : NIL ); show_prompt ? c_string_to_lisp_symbol( L":: " ) : NIL );
/* /*
* primitive function operations * primitive function operations
*/ */
@ -164,6 +197,8 @@ int main( int argc, char *argv[] ) {
bind_function( L"eval", &lisp_eval ); bind_function( L"eval", &lisp_eval );
bind_function( L"exception", &lisp_exception ); bind_function( L"exception", &lisp_exception );
bind_function( L"inspect", &lisp_inspect ); bind_function( L"inspect", &lisp_inspect );
bind_function( L"meta", &lisp_metadata );
bind_function( L"metadata", &lisp_metadata );
bind_function( L"multiply", &lisp_multiply ); bind_function( L"multiply", &lisp_multiply );
bind_function( L"negative?", &lisp_is_negative ); bind_function( L"negative?", &lisp_is_negative );
bind_function( L"oblist", &lisp_oblist ); bind_function( L"oblist", &lisp_oblist );
@ -180,13 +215,11 @@ int main( int argc, char *argv[] ) {
bind_function( L"subtract", &lisp_subtract ); bind_function( L"subtract", &lisp_subtract );
bind_function( L"throw", &lisp_exception ); bind_function( L"throw", &lisp_exception );
bind_function( L"type", &lisp_type ); bind_function( L"type", &lisp_type );
bind_function( L"+", &lisp_add ); bind_function( L"+", &lisp_add );
bind_function( L"*", &lisp_multiply ); bind_function( L"*", &lisp_multiply );
bind_function( L"-", &lisp_subtract ); bind_function( L"-", &lisp_subtract );
bind_function( L"/", &lisp_divide ); bind_function( L"/", &lisp_divide );
bind_function( L"=", &lisp_equal ); bind_function( L"=", &lisp_equal );
/* /*
* primitive special forms * primitive special forms
*/ */
@ -198,19 +231,16 @@ int main( int argc, char *argv[] ) {
bind_special( L"progn", &lisp_progn ); bind_special( L"progn", &lisp_progn );
bind_special( L"quote", &lisp_quote ); bind_special( L"quote", &lisp_quote );
bind_special( L"set!", &lisp_set_shriek ); bind_special( L"set!", &lisp_set_shriek );
debug_print( L"Initialised oblist\n", DEBUG_BOOTSTRAP ); debug_print( L"Initialised oblist\n", DEBUG_BOOTSTRAP );
debug_dump_object( oblist, DEBUG_BOOTSTRAP ); debug_dump_object( oblist, DEBUG_BOOTSTRAP );
repl( show_prompt ); repl( show_prompt );
debug_print( L"Freeing oblist\n", DEBUG_BOOTSTRAP ); debug_print( L"Freeing oblist\n", DEBUG_BOOTSTRAP );
dec_ref( oblist ); dec_ref( oblist );
debug_dump_object( oblist, DEBUG_BOOTSTRAP ); debug_dump_object( oblist, DEBUG_BOOTSTRAP );
if ( dump_at_end ) { if ( dump_at_end ) {
dump_pages( file_to_url_file( stdout ) ); dump_pages( file_to_url_file( stdout ) );
} }
curl_global_cleanup( );
return ( 0 ); return ( 0 );
} }

346
src/io/fopen.c
View file

@ -47,76 +47,58 @@
#include <curl/curl.h> #include <curl/curl.h>
enum fcurl_type_e { #include "fopen.h"
CFTYPE_NONE = 0, #ifdef FOPEN_STANDALONE
CFTYPE_FILE = 1, CURLSH *io_share;
CFTYPE_CURL = 2 #else
}; #include "io.h"
#include "consspaceobject.h"
#endif
struct fcurl_data
{
enum fcurl_type_e type; /* type of handle */
union {
CURL *curl;
FILE *file;
} handle; /* handle */
char *buffer; /* buffer to store cached data*/
size_t buffer_len; /* currently allocated buffers length */
size_t buffer_pos; /* end of data in buffer*/
int still_running; /* Is background url fetch still in progress */
};
typedef struct fcurl_data URL_FILE;
/* exported functions */ /* exported functions */
URL_FILE *url_fopen(const char *url, const char *operation); URL_FILE *url_fopen( const char *url, const char *operation );
int url_fclose(URL_FILE *file); int url_fclose( URL_FILE * file );
int url_feof(URL_FILE *file); int url_feof( URL_FILE * file );
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 );
char *url_fgets(char *ptr, size_t size, URL_FILE *file); char *url_fgets( char *ptr, size_t size, URL_FILE * file );
void url_rewind(URL_FILE *file); void url_rewind( URL_FILE * file );
/* we use a global one for convenience */ /* we use a global one for convenience */
static CURLM *multi_handle; static CURLM *multi_handle;
/* curl calls this routine to get more data */ /* curl calls this routine to get more data */
static size_t write_callback(char *buffer, static size_t write_callback( char *buffer,
size_t size, size_t size, size_t nitems, void *userp ) {
size_t nitems,
void *userp)
{
char *newbuff; char *newbuff;
size_t rembuff; size_t rembuff;
URL_FILE *url = (URL_FILE *)userp; URL_FILE *url = ( URL_FILE * ) userp;
size *= nitems; size *= nitems;
rembuff = url->buffer_len - url->buffer_pos; /* remaining space in buffer */ rembuff = url->buffer_len - url->buffer_pos; /* remaining space in buffer */
if(size > rembuff) { if ( size > rembuff ) {
/* not enough space in buffer */ /* not enough space in buffer */
newbuff = realloc(url->buffer, url->buffer_len + (size - rembuff)); newbuff = realloc( url->buffer, url->buffer_len + ( size - rembuff ) );
if(newbuff == NULL) { if ( newbuff == NULL ) {
fprintf(stderr, "callback buffer grow failed\n"); fprintf( stderr, "callback buffer grow failed\n" );
size = rembuff; size = rembuff;
} } else {
else { /* realloc succeeded increase buffer size */
/* realloc succeeded increase buffer size*/
url->buffer_len += size - rembuff; url->buffer_len += size - rembuff;
url->buffer = newbuff; url->buffer = newbuff;
} }
} }
memcpy(&url->buffer[url->buffer_pos], buffer, size); memcpy( &url->buffer[url->buffer_pos], buffer, size );
url->buffer_pos += size; url->buffer_pos += size;
return size; return size;
} }
/* use to attempt to fill the read buffer up to requested number of bytes */ /* 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 fdread;
fd_set fdwrite; fd_set fdwrite;
fd_set fdexcep; fd_set fdexcep;
@ -127,7 +109,7 @@ static int fill_buffer(URL_FILE *file, size_t want)
/* only attempt to fill buffer if transactions still running and buffer /* only attempt to fill buffer if transactions still running and buffer
* doesn't exceed required size already * doesn't exceed required size already
*/ */
if((!file->still_running) || (file->buffer_pos > want)) if ( ( !file->still_running ) || ( file->buffer_pos > want ) )
return 0; return 0;
/* attempt to fill buffer */ /* attempt to fill buffer */
@ -135,28 +117,29 @@ static int fill_buffer(URL_FILE *file, size_t want)
int maxfd = -1; int maxfd = -1;
long curl_timeo = -1; long curl_timeo = -1;
FD_ZERO(&fdread); FD_ZERO( &fdread );
FD_ZERO(&fdwrite); FD_ZERO( &fdwrite );
FD_ZERO(&fdexcep); FD_ZERO( &fdexcep );
/* set a suitable timeout to fail on */ /* set a suitable timeout to fail on */
timeout.tv_sec = 60; /* 1 minute */ timeout.tv_sec = 60; /* 1 minute */
timeout.tv_usec = 0; timeout.tv_usec = 0;
curl_multi_timeout(multi_handle, &curl_timeo); curl_multi_timeout( multi_handle, &curl_timeo );
if(curl_timeo >= 0) { if ( curl_timeo >= 0 ) {
timeout.tv_sec = curl_timeo / 1000; timeout.tv_sec = curl_timeo / 1000;
if(timeout.tv_sec > 1) if ( timeout.tv_sec > 1 )
timeout.tv_sec = 1; timeout.tv_sec = 1;
else else
timeout.tv_usec = (curl_timeo % 1000) * 1000; timeout.tv_usec = ( curl_timeo % 1000 ) * 1000;
} }
/* get file descriptors from the transfers */ /* get file descriptors from the transfers */
mc = curl_multi_fdset(multi_handle, &fdread, &fdwrite, &fdexcep, &maxfd); mc = curl_multi_fdset( multi_handle, &fdread, &fdwrite, &fdexcep,
&maxfd );
if(mc != CURLM_OK) { if ( mc != CURLM_OK ) {
fprintf(stderr, "curl_multi_fdset() failed, code %d.\n", mc); fprintf( stderr, "curl_multi_fdset() failed, code %d.\n", mc );
break; break;
} }
@ -166,23 +149,22 @@ static int fill_buffer(URL_FILE *file, size_t want)
to sleep 100ms, which is the minimum suggested value in the to sleep 100ms, which is the minimum suggested value in the
curl_multi_fdset() doc. */ curl_multi_fdset() doc. */
if(maxfd == -1) { if ( maxfd == -1 ) {
#ifdef _WIN32 #ifdef _WIN32
Sleep(100); Sleep( 100 );
rc = 0; rc = 0;
#else #else
/* Portable sleep for platforms other than Windows. */ /* Portable sleep for platforms other than Windows. */
struct timeval wait = { 0, 100 * 1000 }; /* 100ms */ struct timeval wait = { 0, 100 * 1000 }; /* 100ms */
rc = select(0, NULL, NULL, NULL, &wait); rc = select( 0, NULL, NULL, NULL, &wait );
#endif #endif
} } else {
else {
/* Note that on some platforms 'timeout' may be modified by select(). /* Note that on some platforms 'timeout' may be modified by select().
If you need access to the original value save a copy beforehand. */ If you need access to the original value save a copy beforehand. */
rc = select(maxfd + 1, &fdread, &fdwrite, &fdexcep, &timeout); rc = select( maxfd + 1, &fdread, &fdwrite, &fdexcep, &timeout );
} }
switch(rc) { switch ( rc ) {
case -1: case -1:
/* select error */ /* select error */
break; break;
@ -190,78 +172,78 @@ static int fill_buffer(URL_FILE *file, size_t want)
case 0: case 0:
default: default:
/* timeout or readable/writable sockets */ /* timeout or readable/writable sockets */
curl_multi_perform(multi_handle, &file->still_running); curl_multi_perform( multi_handle, &file->still_running );
break; break;
} }
} while(file->still_running && (file->buffer_pos < want)); } while ( file->still_running && ( file->buffer_pos < want ) );
return 1; return 1;
} }
/* use to remove want bytes from the front of a files buffer */ /* 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 */ /* sort out buffer */
if((file->buffer_pos - want) <= 0) { if ( ( file->buffer_pos - want ) <= 0 ) {
/* ditch buffer - write will recreate */ /* ditch buffer - write will recreate */
free(file->buffer); free( file->buffer );
file->buffer = NULL; file->buffer = NULL;
file->buffer_pos = 0; file->buffer_pos = 0;
file->buffer_len = 0; file->buffer_len = 0;
} } else {
else {
/* move rest down make it available for later */ /* move rest down make it available for later */
memmove(file->buffer, memmove( file->buffer,
&file->buffer[want], &file->buffer[want], ( file->buffer_pos - want ) );
(file->buffer_pos - want));
file->buffer_pos -= want; file->buffer_pos -= want;
} }
return 0; return 0;
} }
URL_FILE *url_fopen(const char *url, const char *operation) URL_FILE *url_fopen( const char *url, const char *operation ) {
{
/* this code could check for URLs or types in the 'url' and /* this code could check for URLs or types in the 'url' and
basically use the real fopen() for standard files */ basically use the real fopen() for standard files */
URL_FILE *file; URL_FILE *file;
(void)operation; ( void ) operation;
file = calloc(1, sizeof(URL_FILE)); file = calloc( 1, sizeof( URL_FILE ) );
if(!file) if ( !file )
return NULL; return NULL;
file->handle.file = fopen(url, operation); file->handle.file = fopen( url, operation );
if(file->handle.file) if ( file->handle.file )
file->type = CFTYPE_FILE; /* marked as URL */ file->type = CFTYPE_FILE; /* marked as URL */
else { else {
file->type = CFTYPE_CURL; /* marked as URL */ file->type = CFTYPE_CURL; /* marked as URL */
file->handle.curl = curl_easy_init(); file->handle.curl = curl_easy_init( );
curl_easy_setopt(file->handle.curl, CURLOPT_URL, url); curl_easy_setopt( file->handle.curl, CURLOPT_URL, url );
curl_easy_setopt(file->handle.curl, CURLOPT_WRITEDATA, file); curl_easy_setopt( file->handle.curl, CURLOPT_WRITEDATA, file );
curl_easy_setopt(file->handle.curl, CURLOPT_VERBOSE, 0L); curl_easy_setopt( file->handle.curl, CURLOPT_VERBOSE, 0L );
curl_easy_setopt(file->handle.curl, CURLOPT_WRITEFUNCTION, write_callback); curl_easy_setopt( file->handle.curl, CURLOPT_WRITEFUNCTION,
write_callback );
/* use the share object */
curl_easy_setopt(file->handle.curl, CURLOPT_SHARE, io_share);
if(!multi_handle)
multi_handle = curl_multi_init();
curl_multi_add_handle(multi_handle, file->handle.curl); if ( !multi_handle )
multi_handle = curl_multi_init( );
curl_multi_add_handle( multi_handle, file->handle.curl );
/* lets start the fetch */ /* lets start the fetch */
curl_multi_perform(multi_handle, &file->still_running); curl_multi_perform( multi_handle, &file->still_running );
if((file->buffer_pos == 0) && (!file->still_running)) { if ( ( file->buffer_pos == 0 ) && ( !file->still_running ) ) {
/* if still_running is 0 now, we should return NULL */ /* if still_running is 0 now, we should return NULL */
/* make sure the easy handle is not in the multi handle anymore */ /* make sure the easy handle is not in the multi handle anymore */
curl_multi_remove_handle(multi_handle, file->handle.curl); curl_multi_remove_handle( multi_handle, file->handle.curl );
/* cleanup */ /* cleanup */
curl_easy_cleanup(file->handle.curl); curl_easy_cleanup( file->handle.curl );
free(file); free( file );
file = NULL; file = NULL;
} }
@ -269,21 +251,20 @@ URL_FILE *url_fopen(const char *url, const char *operation)
return file; return file;
} }
int url_fclose(URL_FILE *file) int url_fclose( URL_FILE * file ) {
{ int ret = 0; /* default is good return */
int ret = 0;/* default is good return */
switch(file->type) { switch ( file->type ) {
case CFTYPE_FILE: case CFTYPE_FILE:
ret = fclose(file->handle.file); /* passthrough */ ret = fclose( file->handle.file ); /* passthrough */
break; break;
case CFTYPE_CURL: case CFTYPE_CURL:
/* make sure the easy handle is not in the multi handle anymore */ /* make sure the easy handle is not in the multi handle anymore */
curl_multi_remove_handle(multi_handle, file->handle.curl); curl_multi_remove_handle( multi_handle, file->handle.curl );
/* cleanup */ /* cleanup */
curl_easy_cleanup(file->handle.curl); curl_easy_cleanup( file->handle.curl );
break; break;
default: /* unknown or supported type - oh dear */ default: /* unknown or supported type - oh dear */
@ -292,23 +273,22 @@ int url_fclose(URL_FILE *file)
break; break;
} }
free(file->buffer);/* free any allocated buffer space */ free( file->buffer ); /* free any allocated buffer space */
free(file); free( file );
return ret; return ret;
} }
int url_feof(URL_FILE *file) int url_feof( URL_FILE * file ) {
{
int ret = 0; int ret = 0;
switch(file->type) { switch ( file->type ) {
case CFTYPE_FILE: case CFTYPE_FILE:
ret = feof(file->handle.file); ret = feof( file->handle.file );
break; break;
case CFTYPE_CURL: case CFTYPE_CURL:
if((file->buffer_pos == 0) && (!file->still_running)) if ( ( file->buffer_pos == 0 ) && ( !file->still_running ) )
ret = 1; ret = 1;
break; break;
@ -320,33 +300,32 @@ int url_feof(URL_FILE *file)
return ret; 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; size_t want;
switch(file->type) { switch ( file->type ) {
case CFTYPE_FILE: case CFTYPE_FILE:
want = fread(ptr, size, nmemb, file->handle.file); want = fread( ptr, size, nmemb, file->handle.file );
break; break;
case CFTYPE_CURL: case CFTYPE_CURL:
want = nmemb * size; want = nmemb * size;
fill_buffer(file, want); fill_buffer( file, want );
/* check if there's data in the buffer - if not fill_buffer() /* check if there's data in the buffer - if not fill_buffer()
* either errored or EOF */ * either errored or EOF */
if(!file->buffer_pos) if ( !file->buffer_pos )
return 0; return 0;
/* ensure only available data is considered */ /* ensure only available data is considered */
if(file->buffer_pos < want) if ( file->buffer_pos < want )
want = file->buffer_pos; want = file->buffer_pos;
/* xfer data to caller */ /* xfer data to caller */
memcpy(ptr, file->buffer, want); memcpy( ptr, file->buffer, want );
use_buffer(file, want); use_buffer( file, want );
want = want / size; /* number of items */ want = want / size; /* number of items */
break; break;
@ -360,42 +339,41 @@ size_t url_fread(void *ptr, size_t size, size_t nmemb, URL_FILE *file)
return want; 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 want = size - 1;/* always need to leave room for zero termination */
size_t loop; size_t loop;
switch(file->type) { switch ( file->type ) {
case CFTYPE_FILE: case CFTYPE_FILE:
ptr = fgets(ptr, (int)size, file->handle.file); ptr = fgets( ptr, ( int ) size, file->handle.file );
break; break;
case CFTYPE_CURL: case CFTYPE_CURL:
fill_buffer(file, want); fill_buffer( file, want );
/* check if there's data in the buffer - if not fill either errored or /* check if there's data in the buffer - if not fill either errored or
* EOF */ * EOF */
if(!file->buffer_pos) if ( !file->buffer_pos )
return NULL; return NULL;
/* ensure only available data is considered */ /* ensure only available data is considered */
if(file->buffer_pos < want) if ( file->buffer_pos < want )
want = file->buffer_pos; want = file->buffer_pos;
/*buffer contains data */ /*buffer contains data */
/* look for newline or eof */ /* look for newline or eof */
for(loop = 0; loop < want; loop++) { for ( loop = 0; loop < want; loop++ ) {
if(file->buffer[loop] == '\n') { if ( file->buffer[loop] == '\n' ) {
want = loop + 1;/* include newline */ want = loop + 1; /* include newline */
break; break;
} }
} }
/* xfer data to caller */ /* xfer data to caller */
memcpy(ptr, file->buffer, want); memcpy( ptr, file->buffer, want );
ptr[want] = 0;/* always null terminate */ ptr[want] = 0; /* always null terminate */
use_buffer(file, want); use_buffer( file, want );
break; break;
@ -405,25 +383,24 @@ char *url_fgets(char *ptr, size_t size, URL_FILE *file)
break; break;
} }
return ptr;/*success */ return ptr; /*success */
} }
void url_rewind(URL_FILE *file) void url_rewind( URL_FILE * file ) {
{ switch ( file->type ) {
switch(file->type) {
case CFTYPE_FILE: case CFTYPE_FILE:
rewind(file->handle.file); /* passthrough */ rewind( file->handle.file ); /* passthrough */
break; break;
case CFTYPE_CURL: case CFTYPE_CURL:
/* halt transaction */ /* halt transaction */
curl_multi_remove_handle(multi_handle, file->handle.curl); curl_multi_remove_handle( multi_handle, file->handle.curl );
/* restart */ /* restart */
curl_multi_add_handle(multi_handle, file->handle.curl); curl_multi_add_handle( multi_handle, file->handle.curl );
/* ditch buffer - write will recreate - resets stream pos*/ /* ditch buffer - write will recreate - resets stream pos */
free(file->buffer); free( file->buffer );
file->buffer = NULL; file->buffer = NULL;
file->buffer_pos = 0; file->buffer_pos = 0;
file->buffer_len = 0; file->buffer_len = 0;
@ -443,8 +420,7 @@ void url_rewind(URL_FILE *file)
/* Small main program to retrieve from a url using fgets and fread saving the /* Small main program to retrieve from a url using fgets and fread saving the
* output to two test files (note the fgets method will corrupt binary files if * output to two test files (note the fgets method will corrupt binary files if
* they contain 0 chars */ * they contain 0 chars */
int main(int argc, char *argv[]) int main( int argc, char *argv[] ) {
{
URL_FILE *handle; URL_FILE *handle;
FILE *outf; FILE *outf;
@ -455,92 +431,92 @@ int main(int argc, char *argv[])
CURL *curl; CURL *curl;
CURLcode res; CURLcode res;
curl_global_init(CURL_GLOBAL_DEFAULT); curl_global_init( CURL_GLOBAL_DEFAULT );
curl = curl_easy_init(); curl = curl_easy_init( );
if(argc < 2) if ( argc < 2 )
url = "http://192.168.7.3/testfile";/* default to testurl */ url = "http://192.168.7.3/testfile"; /* default to testurl */
else else
url = argv[1];/* use passed url */ url = argv[1]; /* use passed url */
/* copy from url line by line with fgets */ /* copy from url line by line with fgets */
outf = fopen(FGETSFILE, "wb+"); outf = fopen( FGETSFILE, "wb+" );
if(!outf) { if ( !outf ) {
perror("couldn't open fgets output file\n"); perror( "couldn't open fgets output file\n" );
return 1; return 1;
} }
handle = url_fopen(url, "r"); handle = url_fopen( url, "r" );
if(!handle) { if ( !handle ) {
printf("couldn't url_fopen() %s\n", url); printf( "couldn't url_fopen() %s\n", url );
fclose(outf); fclose( outf );
return 2; return 2;
} }
while(!url_feof(handle)) { while ( !url_feof( handle ) ) {
url_fgets(buffer, sizeof(buffer), handle); url_fgets( buffer, sizeof( buffer ), handle );
fwrite(buffer, 1, strlen(buffer), outf); fwrite( buffer, 1, strlen( buffer ), outf );
} }
url_fclose(handle); url_fclose( handle );
fclose(outf); fclose( outf );
/* Copy from url with fread */ /* Copy from url with fread */
outf = fopen(FREADFILE, "wb+"); outf = fopen( FREADFILE, "wb+" );
if(!outf) { if ( !outf ) {
perror("couldn't open fread output file\n"); perror( "couldn't open fread output file\n" );
return 1; return 1;
} }
handle = url_fopen("testfile", "r"); handle = url_fopen( "testfile", "r" );
if(!handle) { if ( !handle ) {
printf("couldn't url_fopen() testfile\n"); printf( "couldn't url_fopen() testfile\n" );
fclose(outf); fclose( outf );
return 2; return 2;
} }
do { do {
nread = url_fread(buffer, 1, sizeof(buffer), handle); nread = url_fread( buffer, 1, sizeof( buffer ), handle );
fwrite(buffer, 1, nread, outf); fwrite( buffer, 1, nread, outf );
} while(nread); } while ( nread );
url_fclose(handle); url_fclose( handle );
fclose(outf); fclose( outf );
/* Test rewind */ /* Test rewind */
outf = fopen(REWINDFILE, "wb+"); outf = fopen( REWINDFILE, "wb+" );
if(!outf) { if ( !outf ) {
perror("couldn't open fread output file\n"); perror( "couldn't open fread output file\n" );
return 1; return 1;
} }
handle = url_fopen("testfile", "r"); handle = url_fopen( "testfile", "r" );
if(!handle) { if ( !handle ) {
printf("couldn't url_fopen() testfile\n"); printf( "couldn't url_fopen() testfile\n" );
fclose(outf); fclose( outf );
return 2; return 2;
} }
nread = url_fread(buffer, 1, sizeof(buffer), handle); nread = url_fread( buffer, 1, sizeof( buffer ), handle );
fwrite(buffer, 1, nread, outf); fwrite( buffer, 1, nread, outf );
url_rewind(handle); url_rewind( handle );
buffer[0]='\n'; buffer[0] = '\n';
fwrite(buffer, 1, 1, outf); fwrite( buffer, 1, 1, outf );
nread = url_fread(buffer, 1, sizeof(buffer), handle); nread = url_fread( buffer, 1, sizeof( buffer ), handle );
fwrite(buffer, 1, nread, outf); fwrite( buffer, 1, nread, outf );
url_fclose(handle); url_fclose( handle );
fclose(outf); fclose( outf );
return 0;/* all done */ return 0; /* all done */
} }
#endif #endif

160
src/io/io.c
View file

@ -8,6 +8,17 @@
*/ */
#include <stdlib.h> #include <stdlib.h>
#include <string.h>
#include <sys/stat.h>
#include <sys/types.h>
#include <unistd.h>
/*
* wide characters
*/
#include <wchar.h>
#include <wctype.h>
#include <curl/curl.h>
#include "conspage.h" #include "conspage.h"
#include "consspaceobject.h" #include "consspaceobject.h"
@ -15,12 +26,42 @@
#include "fopen.h" #include "fopen.h"
#include "lispops.h" #include "lispops.h"
/**
* The sharing hub for all connections. TODO: Ultimately this probably doesn't
* work for a multi-user environment and we will need one sharing hub for each
* user, or else we will need to not share at least cookies and ssl sessions.
*/
CURLSH *io_share;
/** /**
* Allow a one-character unget facility. This may not be enough - we may need * Allow a one-character unget facility. This may not be enough - we may need
* to allocate a buffer. * to allocate a buffer.
*/ */
wint_t ungotten = 0; wint_t ungotten = 0;
/**
* Initialise the I/O subsystem.
*
* @return 0 on success; any other value means failure.
*/
int io_init() {
CURL *curl;
CURLcode res;
int result = curl_global_init( CURL_GLOBAL_SSL );
io_share = curl_share_init();
if (result == 0) {
curl_share_setopt(io_share, CURLSHOPT_SHARE, CURL_LOCK_DATA_CONNECT);
curl_share_setopt(io_share, CURLSHOPT_SHARE, CURL_LOCK_DATA_COOKIE );
curl_share_setopt(io_share, CURLSHOPT_SHARE, CURL_LOCK_DATA_DNS );
curl_share_setopt(io_share, CURLSHOPT_SHARE, CURL_LOCK_DATA_SSL_SESSION );
curl_share_setopt(io_share, CURLSHOPT_SHARE, CURL_LOCK_DATA_PSL );
}
return result;
}
/** /**
* Convert this lisp string-like-thing (also works for symbols, and, later * Convert this lisp string-like-thing (also works for symbols, and, later
* keywords) into a UTF-8 string. NOTE that the returned value has been * keywords) into a UTF-8 string. NOTE that the returned value has been
@ -107,9 +148,11 @@ wint_t url_fgetwc( URL_FILE * input ) {
size_t count = 0; size_t count = 0;
debug_print( L"url_fgetwc: about to call url_fgets\n", DEBUG_IO ); debug_print( L"url_fgetwc: about to call url_fgets\n",
DEBUG_IO );
url_fgets( cbuff, 2, input ); url_fgets( cbuff, 2, input );
debug_print( L"url_fgetwc: back from url_fgets\n", DEBUG_IO ); debug_print( L"url_fgetwc: back from url_fgets\n",
DEBUG_IO );
int c = ( int ) cbuff[0]; int c = ( int ) cbuff[0];
debug_printf( DEBUG_IO, debug_printf( DEBUG_IO,
L"url_fgetwc: cbuff is '%s'; (first) character = %d (%c)\n", L"url_fgetwc: cbuff is '%s'; (first) character = %d (%c)\n",
@ -133,7 +176,7 @@ wint_t url_fgetwc( URL_FILE * input ) {
} }
if ( count > 1 ) { if ( count > 1 ) {
url_fgets( (char *)&cbuff[1], count, input ); url_fgets( ( char * ) &cbuff[1], count, input );
} }
mbstowcs( wbuff, cbuff, 1 ); //(char *)(&input->buffer[input->buffer_pos]), 1 ); mbstowcs( wbuff, cbuff, 1 ); //(char *)(&input->buffer[input->buffer_pos]), 1 );
result = wbuff[0]; result = wbuff[0];
@ -163,18 +206,6 @@ wint_t url_ungetwc( wint_t wc, URL_FILE * input ) {
case CFTYPE_CURL:{ case CFTYPE_CURL:{
ungotten = wc; ungotten = wc;
// wchar_t *wbuff = calloc( 2, sizeof( wchar_t ) );
// char *cbuff = calloc( 5, sizeof( char ) );
//
// wbuff[0] = wc;
// result = wcstombs( cbuff, wbuff, 1 );
//
// input->buffer_pos -= strlen( cbuff );
//
// free( cbuff );
// free( wbuff );
//
// result = result > 0 ? wc : result;
break; break;
case CFTYPE_NONE: case CFTYPE_NONE:
break; break;
@ -212,6 +243,85 @@ lisp_close( struct stack_frame *frame, struct cons_pointer frame_pointer,
return result; return result;
} }
int index_of( char c, char * s) {
int i;
for (i = 0; s[i] != c && s[i] != 0; i++);
return s[i] == c ? i : -1;
}
char * trim(char *s) {
int i;
for (i = strlen(s); (isblank(s[i]) || iscntrl(s[i])) && i > -1; i--) {
s[i] = (char) 0;
}
for (i = 0; isblank(s[i]) && s[i] != 0; i++);
return (char *)&s[i];
}
/**
* Callback to assemble metadata for a URL stream. This is naughty because
* it modifies data, but it's really the only way to create metadata.
*/
static size_t write_meta_callback(void *ptr, size_t size, size_t nmemb, struct cons_pointer stream)
{
struct cons_space_object * cell = &pointer2cell(stream);
if (strncmp(&cell->tag.bytes[0], READTAG, 4) ||
strncmp(&cell->tag.bytes[0], WRITETAG, 4)) {
char * s = (char *)ptr;
int offset = index_of (':', ptr);
if (offset != -1) {
s[offset] = (char)0;
char * name = s;
char * value = trim( &s[++offset]);
wchar_t * wname = calloc(strlen(name), sizeof(wchar_t));
wchar_t * wvalue = calloc(strlen(value), sizeof(wchar_t));
mbstowcs(wname, name, strlen(name));
mbstowcs(wvalue, value, strlen(value));
cell->payload.stream.meta = make_cons(
make_cons(
c_string_to_lisp_keyword( wname),
c_string_to_lisp_string(wvalue)),
cell->payload.stream.meta);
debug_printf( DEBUG_IO, L"write_meta_callback: added header '%s': value '%s'\n", name, value);
}
} else {
debug_print( L"Pointer passed to write_meta_callback did not point to a stream: ", DEBUG_IO);
debug_dump_object(stream, DEBUG_IO);
}
return nmemb;
}
void collect_meta( struct cons_pointer stream, struct cons_pointer url ) {
URL_FILE * s = pointer2cell(stream).payload.stream.stream;
switch ( s->type ) {
case CFTYPE_NONE:
break;
case CFTYPE_FILE:
/* don't know whether you can get metadata on an open stream in C,
* although we could of course get it from the URL */
break;
case CFTYPE_CURL:
curl_easy_setopt( s->handle.curl, CURLOPT_VERBOSE, 1L );
curl_easy_setopt( s->handle.curl, CURLOPT_HEADER, 1L );
curl_easy_setopt( s->handle.curl, CURLOPT_HEADERFUNCTION, write_meta_callback);
curl_easy_setopt( s->handle.curl, CURLOPT_HEADERDATA, stream);
break;
}
}
/** /**
* Function: return a stream open on the URL indicated by the first argument; * Function: return a stream open on the URL indicated by the first argument;
* if a second argument is present and is non-nil, open it for reading. At * if a second argument is present and is non-nil, open it for reading. At
@ -228,24 +338,34 @@ lisp_close( struct stack_frame *frame, struct cons_pointer frame_pointer,
* on my stream, if any, else NIL. * on my stream, if any, else NIL.
*/ */
struct cons_pointer struct cons_pointer
lisp_open( struct stack_frame *frame, struct cons_pointer frame_pointer, lisp_open( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) { struct cons_pointer env ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
if ( stringp( frame->arg[0] ) ) { if ( stringp( frame->arg[0] ) ) {
struct cons_pointer meta =
make_cons( make_cons(
c_string_to_lisp_keyword( L"url" ),
frame->arg[0] ),
NIL );
char *url = lisp_string_to_c_string( frame->arg[0] ); char *url = lisp_string_to_c_string( frame->arg[0] );
if ( nilp( frame->arg[1] ) ) { if ( nilp( frame->arg[1] ) ) {
result = make_read_stream( url_fopen( url, "r" ) ); URL_FILE *stream = url_fopen( url, "r" );
result = make_read_stream( stream, meta );
} else { } else {
// TODO: anything more complex is a problem for another day. // TODO: anything more complex is a problem for another day.
result = make_write_stream( url_fopen( url, "w" ) ); URL_FILE *stream = url_fopen( url, "w" );
result = make_write_stream( stream, meta);
} }
free( url ); free( url );
if ( pointer2cell( result ).payload.stream.stream == NULL ) { if ( pointer2cell( result ).payload.stream.stream == NULL ) {
result = NIL; result = NIL;
} else {
collect_meta( result, frame->arg[0]);
} }
} }
@ -272,8 +392,8 @@ lisp_read_char( struct stack_frame *frame, struct cons_pointer frame_pointer,
if ( readp( frame->arg[0] ) ) { if ( readp( frame->arg[0] ) ) {
result = result =
make_string( url_fgetwc make_string( url_fgetwc
( pointer2cell( frame->arg[0] ).payload.stream. ( pointer2cell( frame->arg[0] ).payload.
stream ), NIL ); stream.stream ), NIL );
} }
return result; return result;

6
src/io/io.h
View file

@ -10,6 +10,12 @@
#ifndef __psse_io_h #ifndef __psse_io_h
#define __psse_io_h #define __psse_io_h
#include <curl/curl.h>
#include "consspaceobject.h"
extern CURLSH *io_share;
int io_init();
URL_FILE *file_to_url_file( FILE * f ); URL_FILE *file_to_url_file( FILE * f );
wint_t url_fgetwc( URL_FILE * input ); wint_t url_fgetwc( URL_FILE * input );

7
src/memory/conspage.c
View file

@ -152,7 +152,7 @@ void free_cell( struct cons_pointer pointer ) {
dec_ref( cell->payload.exception.frame ); dec_ref( cell->payload.exception.frame );
break; break;
case FUNCTIONTV: case FUNCTIONTV:
dec_ref( cell->payload.function.source ); dec_ref( cell->payload.function.meta );
break; break;
case INTEGERTV: case INTEGERTV:
dec_ref( cell->payload.integer.more ); dec_ref( cell->payload.integer.more );
@ -168,10 +168,11 @@ void free_cell( struct cons_pointer pointer ) {
break; break;
case READTV: case READTV:
case WRITETV: case WRITETV:
url_fclose( cell->payload.stream.stream); dec_ref(cell->payload.stream.meta);
url_fclose( cell->payload.stream.stream );
break; break;
case SPECIALTV: case SPECIALTV:
dec_ref( cell->payload.special.source ); dec_ref( cell->payload.special.meta );
break; break;
case STRINGTV: case STRINGTV:
case SYMBOLTV: case SYMBOLTV:

18
src/memory/conspage.h
View file

@ -1,7 +1,19 @@
#include "consspaceobject.h" /*
* 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
#ifndef __conspage_h #include "consspaceobject.h"
#define __conspage_h
/** /**
* the number of cons cells on a cons page. The maximum value this can * the number of cons cells on a cons page. The maximum value this can

102
src/memory/consspaceobject.c
View file

@ -21,6 +21,7 @@
#include "conspage.h" #include "conspage.h"
#include "consspaceobject.h" #include "consspaceobject.h"
#include "debug.h" #include "debug.h"
#include "intern.h"
#include "print.h" #include "print.h"
#include "stack.h" #include "stack.h"
@ -65,6 +66,48 @@ void dec_ref( struct cons_pointer pointer ) {
} }
/**
* 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 ) {
struct cons_pointer result = NIL;
struct cons_space_object cell = pointer2cell( pointer );
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, does not error but returns nil.
*/
struct cons_pointer c_car( struct cons_pointer arg ) {
struct cons_pointer result = NIL;
if ( consp( arg ) ) {
result = pointer2cell( arg ).payload.cons.car;
}
return result;
}
/**
* Implementation of cdr in C. If arg is not a cons, does not error but returns nil.
*/
struct cons_pointer c_cdr( struct cons_pointer arg ) {
struct cons_pointer result = NIL;
if ( consp( arg ) || stringp( arg ) || symbolp( arg ) ) {
result = pointer2cell( arg ).payload.cons.cdr;
}
return result;
}
/** /**
* Construct a cons cell from this pair of pointers. * Construct a cons cell from this pair of pointers.
*/ */
@ -107,16 +150,17 @@ struct cons_pointer make_exception( struct cons_pointer message,
/** /**
* Construct a cell which points to an executable Lisp special form. * Construct a cell which points to an executable Lisp function.
*/ */
struct cons_pointer struct cons_pointer
make_function( struct cons_pointer src, struct cons_pointer ( *executable ) make_function( struct cons_pointer meta, struct cons_pointer ( *executable )
( struct stack_frame *, ( struct stack_frame *,
struct cons_pointer, struct cons_pointer ) ) { struct cons_pointer, struct cons_pointer ) ) {
struct cons_pointer pointer = allocate_cell( FUNCTIONTAG ); struct cons_pointer pointer = allocate_cell( FUNCTIONTAG );
struct cons_space_object *cell = &pointer2cell( pointer ); struct cons_space_object *cell = &pointer2cell( pointer );
inc_ref( meta);
cell->payload.function.source = src; cell->payload.function.meta = meta;
cell->payload.function.executable = executable; cell->payload.function.executable = executable;
return pointer; return pointer;
@ -203,27 +247,42 @@ struct cons_pointer make_string( wint_t c, struct cons_pointer tail ) {
} }
/** /**
* Construct a symbol from the character `c` and this `tail`. A symbol is * Construct a symbol or keyword from the character `c` and this `tail`.
* internally identical to a string except for having a different tag. * Each is internally identical to a string except for having a different tag.
* *
* @param c the character to add (prepend); * @param c the character to add (prepend);
* @param tail the symbol which is being built. * @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( wint_t c, struct cons_pointer tail ) { struct cons_pointer make_symbol_or_key( wint_t c, struct cons_pointer tail,
return make_string_like_thing( c, tail, SYMBOLTAG ); char *tag ) {
struct cons_pointer result = make_string_like_thing( c, tail, tag );
if ( strncmp( tag, KEYTAG, 4 ) == 0 ) {
struct cons_pointer r = internedp( result, oblist );
if ( nilp(r)) {
intern(result, oblist);
} else {
result = r;
}
}
return result;
} }
/** /**
* Construct a cell which points to an executable Lisp special form. * Construct a cell which points to an executable Lisp special form.
*/ */
struct cons_pointer struct cons_pointer
make_special( struct cons_pointer src, struct cons_pointer ( *executable ) make_special( struct cons_pointer meta, struct cons_pointer ( *executable )
( struct stack_frame * frame, ( struct stack_frame * frame,
struct cons_pointer, struct cons_pointer env ) ) { struct cons_pointer, struct cons_pointer env ) ) {
struct cons_pointer pointer = allocate_cell( SPECIALTAG ); struct cons_pointer pointer = allocate_cell( SPECIALTAG );
struct cons_space_object *cell = &pointer2cell( pointer ); struct cons_space_object *cell = &pointer2cell( pointer );
inc_ref( meta);
cell->payload.special.source = src; cell->payload.special.meta = meta;
cell->payload.special.executable = executable; cell->payload.special.executable = executable;
return pointer; return pointer;
@ -232,12 +291,16 @@ make_special( struct cons_pointer src, struct cons_pointer ( *executable )
/** /**
* Construct a cell which points to a stream open for reading. * Construct a cell which points to a stream open for reading.
* @param input the C stream to wrap. * @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 make_read_stream( URL_FILE * input,
struct cons_pointer metadata ) {
struct cons_pointer pointer = allocate_cell( READTAG ); struct cons_pointer pointer = allocate_cell( READTAG );
struct cons_space_object *cell = &pointer2cell( pointer ); struct cons_space_object *cell = &pointer2cell( pointer );
cell->payload.stream.stream = input; cell->payload.stream.stream = input;
cell->payload.stream.meta = metadata;
return pointer; return pointer;
} }
@ -245,16 +308,33 @@ struct cons_pointer make_read_stream( URL_FILE * input ) {
/** /**
* Construct a cell which points to a stream open for writing. * Construct a cell which points to a stream open for writing.
* @param output the C stream to wrap. * @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 make_write_stream( URL_FILE * output,
struct cons_pointer metadata ) {
struct cons_pointer pointer = allocate_cell( WRITETAG ); struct cons_pointer pointer = allocate_cell( WRITETAG );
struct cons_space_object *cell = &pointer2cell( pointer ); struct cons_space_object *cell = &pointer2cell( pointer );
cell->payload.stream.stream = output; cell->payload.stream.stream = output;
cell->payload.stream.meta = metadata;
return pointer; return pointer;
} }
/**
* Return a lisp keyword representation of this wide character string.
*/
struct cons_pointer c_string_to_lisp_keyword( wchar_t *symbol ) {
struct cons_pointer result = NIL;
for ( int i = wcslen( symbol ); i > 0; i-- ) {
result = make_keyword( symbol[i - 1], result );
}
return result;
}
/** /**
* Return a lisp string representation of this wide character string. * Return a lisp string representation of this wide character string.
*/ */

56
src/memory/consspaceobject.h
View file

@ -8,6 +8,9 @@
* Licensed under GPL version 2.0, or, at your option, any later version. * 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 <stdbool.h>
#include <stdint.h> #include <stdint.h>
#include <stdio.h> #include <stdio.h>
@ -19,8 +22,6 @@
#include "fopen.h" #include "fopen.h"
#ifndef __consspaceobject_h
#define __consspaceobject_h
/** /**
* The length of a tag, in bytes. * The length of a tag, in bytes.
@ -39,6 +40,7 @@
/** /**
* The string `CONS`, considered as an `unsigned int`. * The string `CONS`, considered as an `unsigned int`.
* @todo tag values should be collected into an enum.
*/ */
#define CONSTV 1397641027 #define CONSTV 1397641027
@ -85,6 +87,16 @@
*/ */
#define INTEGERTV 1381256777 #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. * A lambda cell. Lambdas are the interpretable (source) versions of functions.
* \see FUNCTIONTAG. * \see FUNCTIONTAG.
@ -258,6 +270,11 @@
*/ */
#define functionp(conspoint) (check_tag(conspoint,FUNCTIONTAG)) #define functionp(conspoint) (check_tag(conspoint,FUNCTIONTAG))
/**
* true if `conspoint` points to a keyword, else false
*/
#define keywordp(conspoint) (check_tag(conspoint,KEYTAG))
/** /**
* true if `conspoint` points to a special Lambda cell, else false * true if `conspoint` points to a special Lambda cell, else false
*/ */
@ -320,6 +337,8 @@
*/ */
#define writep(conspoint) (check_tag(conspoint,WRITETAG)) #define writep(conspoint) (check_tag(conspoint,WRITETAG))
#define streamp(conspoint) (check_tag(conspoint,READTAG)||check_tag(conspoint,WRITETAG))
/** /**
* true if `conspoint` points to a true cell, else false * true if `conspoint` points to a true cell, else false
* (there should only be one of these so it's slightly redundant). * (there should only be one of these so it's slightly redundant).
@ -397,10 +416,9 @@ struct exception_payload {
*/ */
struct function_payload { struct function_payload {
/** /**
* pointer to the source from which the function was compiled, or NIL * pointer to metadata (e.g. the source from which the function was compiled).
* if it is a primitive.
*/ */
struct cons_pointer source; struct cons_pointer meta;
/** pointer to a function which takes a cons pointer (representing /** pointer to a function which takes a cons pointer (representing
* its argument list) and a cons pointer (representing its environment) and a * its argument list) and a cons pointer (representing its environment) and a
* stack frame (representing the previous stack frame) as arguments and returns * stack frame (representing the previous stack frame) as arguments and returns
@ -475,7 +493,7 @@ struct special_payload {
* pointer to the source from which the special form was compiled, or NIL * pointer to the source from which the special form was compiled, or NIL
* if it is a primitive. * if it is a primitive.
*/ */
struct cons_pointer source; struct cons_pointer meta;
/** pointer to a function which takes a cons pointer (representing /** pointer to a function which takes a cons pointer (representing
* its argument list) and a cons pointer (representing its environment) and a * its argument list) and a cons pointer (representing its environment) and a
* stack frame (representing the previous stack frame) as arguments and returns * stack frame (representing the previous stack frame) as arguments and returns
@ -500,8 +518,9 @@ struct stream_payload {
/** /**
* payload of a string cell. At least at first, only one UTF character will * 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' * be stored in each cell. The doctrine that 'a symbol is just a string'
* didn't work; however, the payload of a symbol cell is identical to the * didn't work; however, the payload of a symbol or keyword cell is identical
* payload of a string cell. * 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 { struct string_payload {
/** the actual character stored in this cell */ /** the actual character stored in this cell */
@ -614,6 +633,12 @@ void inc_ref( struct cons_pointer pointer );
void dec_ref( struct cons_pointer pointer ); void dec_ref( 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 );
struct cons_pointer make_cons( struct cons_pointer car, struct cons_pointer make_cons( struct cons_pointer car,
struct cons_pointer cdr ); struct cons_pointer cdr );
@ -626,6 +651,8 @@ struct cons_pointer make_function( struct cons_pointer src,
struct cons_pointer, struct cons_pointer,
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 make_lambda( struct cons_pointer args,
struct cons_pointer body ); struct cons_pointer body );
@ -640,11 +667,18 @@ struct cons_pointer make_special( struct cons_pointer src,
struct cons_pointer make_string( wint_t c, struct cons_pointer tail ); struct cons_pointer make_string( wint_t c, struct cons_pointer tail );
struct cons_pointer make_symbol( wint_t c, struct cons_pointer tail ); struct cons_pointer make_symbol_or_key( wint_t c, struct cons_pointer tail,
char *tag );
struct cons_pointer make_read_stream( URL_FILE * input ); #define make_symbol(c, t) (make_symbol_or_key( c, t, SYMBOLTAG))
struct cons_pointer make_write_stream( URL_FILE * output ); #define make_keyword(c, t) (make_symbol_or_key( c, t, KEYTAG))
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_string( wchar_t *string );

16
src/memory/dump.c
View file

@ -108,13 +108,15 @@ void dump_object( URL_FILE * output, struct cons_pointer pointer ) {
case RATIOTV: case RATIOTV:
url_fwprintf( output, url_fwprintf( output,
L"\t\tRational cell: value %ld/%ld, count %u\n", L"\t\tRational cell: value %ld/%ld, count %u\n",
pointer2cell( cell.payload.ratio.dividend ). pointer2cell( cell.payload.ratio.dividend ).payload.
payload.integer.value, integer.value,
pointer2cell( cell.payload.ratio.divisor ). pointer2cell( cell.payload.ratio.divisor ).payload.
payload.integer.value, cell.count ); integer.value, cell.count );
break; break;
case READTV: case READTV:
url_fwprintf( output, L"\t\tInput stream\n" ); url_fputws( L"\t\tInput stream; metadata: ", output );
print(output, cell.payload.stream.meta);
url_fputws( L"\n", output );
break; break;
case REALTV: case REALTV:
url_fwprintf( output, L"\t\tReal cell: value %Lf, count %u\n", url_fwprintf( output, L"\t\tReal cell: value %Lf, count %u\n",
@ -148,7 +150,9 @@ void dump_object( URL_FILE * output, struct cons_pointer pointer ) {
} }
break; break;
case WRITETV: case WRITETV:
url_fwprintf( output, L"\t\tOutput stream\n" ); url_fputws( L"\t\tOutput stream; metadata: ", output );
print(output, cell.payload.stream.meta);
url_fputws( L"\n", output );
break; break;
} }
} }

5
src/ops/equal.c
View file

@ -67,6 +67,7 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) {
&& equal( cell_a->payload.cons.cdr, && equal( cell_a->payload.cons.cdr,
cell_b->payload.cons.cdr ); cell_b->payload.cons.cdr );
break; break;
case KEYTV:
case STRINGTV: case STRINGTV:
case SYMBOLTV: case SYMBOLTV:
/* /*
@ -80,8 +81,8 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) {
&& ( equal( cell_a->payload.string.cdr, && ( equal( cell_a->payload.string.cdr,
cell_b->payload.string.cdr ) cell_b->payload.string.cdr )
|| ( end_of_string( cell_a->payload.string.cdr ) || ( end_of_string( cell_a->payload.string.cdr )
&& end_of_string( cell_b->payload. && end_of_string( cell_b->payload.string.
string.cdr ) ) ); cdr ) ) );
break; break;
case INTEGERTV: case INTEGERTV:
result = result =

57
src/ops/lispops.c
View file

@ -47,32 +47,6 @@
* and others I haven't thought of yet. * and others I haven't thought of yet.
*/ */
/**
* Implementation of car in C. If arg is not a cons, does not error but returns nil.
*/
struct cons_pointer c_car( struct cons_pointer arg ) {
struct cons_pointer result = NIL;
if ( consp( arg ) ) {
result = pointer2cell( arg ).payload.cons.car;
}
return result;
}
/**
* Implementation of cdr in C. If arg is not a cons, does not error but returns nil.
*/
struct cons_pointer c_cdr( struct cons_pointer arg ) {
struct cons_pointer result = NIL;
if ( consp( arg ) || stringp( arg ) || symbolp( arg ) ) {
result = pointer2cell( arg ).payload.cons.cdr;
}
return result;
}
/** /**
* Useful building block; evaluate this single form in the context of this * Useful building block; evaluate this single form in the context of this
@ -378,8 +352,9 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
result = next_pointer; result = next_pointer;
} else { } else {
result = result =
( *fn_cell.payload.special. ( *fn_cell.payload.
executable ) ( get_stack_frame( next_pointer ), special.executable ) ( get_stack_frame
( next_pointer ),
next_pointer, env ); next_pointer, env );
debug_print( L"Special form returning: ", DEBUG_EVAL ); debug_print( L"Special form returning: ", DEBUG_EVAL );
debug_print_object( result, DEBUG_EVAL ); debug_print_object( result, DEBUG_EVAL );
@ -411,24 +386,6 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
return result; 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 ) {
struct cons_pointer result = NIL;
struct cons_space_object cell = pointer2cell( pointer );
for ( int i = TAGLENGTH - 1; i >= 0; i-- ) {
result = make_string( ( wchar_t ) cell.tag.bytes[i], result );
}
return result;
}
/** /**
* Function; evaluate the expression which is the first argument in the frame; * Function; evaluate the expression which is the first argument in the frame;
* further arguments are ignored. * further arguments are ignored.
@ -885,7 +842,7 @@ struct cons_pointer c_reverse( struct cons_pointer arg ) {
result = make_string( o.payload.string.character, result ); result = make_string( o.payload.string.character, result );
break; break;
case SYMBOLTV: case SYMBOLTV:
result = make_symbol( o.payload.string.character, result ); result = make_symbol_or_key( o.payload.string.character, result, SYMBOLTAG );
break; break;
} }
} }
@ -1251,13 +1208,13 @@ struct cons_pointer lisp_source( struct stack_frame *frame,
struct cons_pointer env ) { struct cons_pointer env ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
struct cons_space_object cell = pointer2cell( frame->arg[0] ); struct cons_space_object cell = pointer2cell( frame->arg[0] );
struct cons_pointer source_key = c_string_to_lisp_keyword(L"source");
switch ( cell.tag.value ) { switch ( cell.tag.value ) {
case FUNCTIONTV: case FUNCTIONTV:
result = cell.payload.function.source; result = c_assoc( source_key, cell.payload.function.meta);
break; break;
case SPECIALTV: case SPECIALTV:
result = cell.payload.special.source; result = c_assoc( source_key, cell.payload.special.meta);
break; break;
case LAMBDATV: case LAMBDATV:
result = make_cons( c_string_to_lisp_symbol( L"lambda" ), result = make_cons( c_string_to_lisp_symbol( L"lambda" ),

21
src/ops/lispops.h
View file

@ -19,26 +19,13 @@
* Licensed under GPL version 2.0, or, at your option, any later version. * Licensed under GPL version 2.0, or, at your option, any later version.
*/ */
#ifndef __psse_lispops_h
#define __psse_lispops_h
/* /*
* utilities * utilities
*/ */
/**
* 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 );
/**
* Implementation of car in C. If arg is not a cons, does not error but returns nil.
*/
struct cons_pointer c_car( struct cons_pointer arg );
/**
* Implementation of cdr in C. If arg is not a cons, does not error but returns nil.
*/
struct cons_pointer c_cdr( struct cons_pointer arg );
struct cons_pointer c_reverse( struct cons_pointer arg ); struct cons_pointer c_reverse( struct cons_pointer arg );
@ -205,3 +192,5 @@ struct cons_pointer lisp_source( struct stack_frame *frame,
struct cons_pointer lisp_inspect( struct stack_frame *frame, struct cons_pointer lisp_inspect( struct stack_frame *frame,
struct cons_pointer frame_pointer, struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );
#endif

47
src/ops/meta.c Normal file
View file

@ -0,0 +1,47 @@
/*
* meta.c
*
* Get metadata from a cell which has it.
*
* (c) 2019 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include "conspage.h"
#include "debug.h"
/**
* Function: get metadata describing my first argument.
*
* * (metadata any)
*
* @return a pointer to the metadata of my first argument, or nil if none.
*/
struct cons_pointer lisp_metadata( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
debug_print(L"lisp_metadata: entered\n", DEBUG_EVAL);
debug_dump_object(frame->arg[0], DEBUG_EVAL);
struct cons_pointer result = NIL;
struct cons_space_object cell = pointer2cell(frame->arg[0]);
switch( cell.tag.value) {
case FUNCTIONTV:
result = cell.payload.function.meta;
break;
case SPECIALTV:
result = cell.payload.special.meta;
break;
case READTV:
case WRITETV:
result = cell.payload.special.meta;
break;
}
return make_cons(
make_cons(
c_string_to_lisp_keyword( L"type"),
c_type(frame->arg[0])),
result);
// return result;
}

17
src/ops/meta.h Normal file
View file

@ -0,0 +1,17 @@
/*
* meta.h
*
* Get metadata from a cell which has it.
*
* (c) 2019 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#ifndef __psse_meta_h
#define __psse_meta_h
struct cons_pointer lisp_metadata( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) ;
#endif

9
src/ops/print.c
View file

@ -35,7 +35,7 @@ int print_use_colours = 0;
* don't print anything but just return. * 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 ) ) { while ( stringp( pointer ) || symbolp( pointer ) || keywordp(pointer)) {
struct cons_space_object *cell = &pointer2cell( pointer ); struct cons_space_object *cell = &pointer2cell( pointer );
wchar_t c = cell->payload.string.character; wchar_t c = cell->payload.string.character;
@ -134,6 +134,13 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) {
dec_ref( s ); dec_ref( s );
} }
break; break;
case KEYTV:
if ( print_use_colours ) {
url_fputws( L"\x1B[1;33m", output );
}
url_fputws( L":", output );
print_string_contents( output, pointer );
break;
case LAMBDATV:{ case LAMBDATV:{
struct cons_pointer to_print = struct cons_pointer to_print =
make_cons( c_string_to_lisp_symbol( L"lambda" ), make_cons( c_string_to_lisp_symbol( L"lambda" ),

41
src/ops/read.c
View file

@ -45,7 +45,8 @@ struct cons_pointer read_list( struct stack_frame *frame,
struct cons_pointer frame_pointer, struct cons_pointer frame_pointer,
URL_FILE * input, wint_t initial ); URL_FILE * input, wint_t initial );
struct cons_pointer read_string( URL_FILE * input, wint_t initial ); struct cons_pointer read_string( URL_FILE * input, wint_t initial );
struct cons_pointer read_symbol( URL_FILE * input, wint_t initial ); struct cons_pointer read_symbol_or_key( URL_FILE * input, char *tag,
wint_t initial );
/** /**
* quote reader macro in C (!) * quote reader macro in C (!)
@ -110,7 +111,7 @@ struct cons_pointer read_continuation( struct stack_frame *frame,
read_number( frame, frame_pointer, input, c, read_number( frame, frame_pointer, input, c,
false ); false );
} else { } else {
result = read_symbol( input, c ); result = read_symbol_or_key( input, SYMBOLTAG, c );
} }
} }
break; break;
@ -129,17 +130,20 @@ struct cons_pointer read_continuation( struct stack_frame *frame,
read_continuation( frame, frame_pointer, input, read_continuation( frame, frame_pointer, input,
url_fgetwc( input ) ); url_fgetwc( input ) );
} else { } else {
read_symbol( input, c ); read_symbol_or_key( input, SYMBOLTAG, c );
} }
} }
break; break;
//case ':': reserved for keywords and paths case ':':
result =
read_symbol_or_key( input, KEYTAG, url_fgetwc( input ) );
break;
default: default:
if ( iswdigit( c ) ) { if ( iswdigit( c ) ) {
result = result =
read_number( frame, frame_pointer, input, c, false ); read_number( frame, frame_pointer, input, c, false );
} else if ( iswprint( c ) ) { } else if ( iswprint( c ) ) {
result = read_symbol( input, c ); result = read_symbol_or_key( input, SYMBOLTAG, c );
} else { } else {
result = result =
throw_exception( make_cons( c_string_to_lisp_string throw_exception( make_cons( c_string_to_lisp_string
@ -321,24 +325,22 @@ struct cons_pointer read_string( URL_FILE * input, wint_t initial ) {
return result; return result;
} }
struct cons_pointer read_symbol( URL_FILE * input, wint_t initial ) { struct cons_pointer read_symbol_or_key( URL_FILE * input, char *tag,
wint_t initial ) {
struct cons_pointer cdr = NIL; struct cons_pointer cdr = NIL;
struct cons_pointer result; struct cons_pointer result;
switch ( initial ) { switch ( initial ) {
case '\0': case '\0':
result = make_symbol( initial, NIL ); result = make_symbol_or_key( initial, NIL, tag );
break; break;
case '"': case '"':
/* case '\'':
* THIS IS NOT A GOOD IDEA, but is legal /* unwise to allow embedded quotation marks in symbols */
*/
result =
make_symbol( initial,
read_symbol( input, url_fgetwc( input ) ) );
break;
case ')': case ')':
case ':':
/* /*
* symbols may not include right-parenthesis; * symbols and keywords may not include right-parenthesis
* or colons.
*/ */
result = NIL; result = NIL;
/* /*
@ -350,8 +352,11 @@ struct cons_pointer read_symbol( URL_FILE * input, wint_t initial ) {
if ( iswprint( initial ) if ( iswprint( initial )
&& !iswblank( initial ) ) { && !iswblank( initial ) ) {
result = result =
make_symbol( initial, make_symbol_or_key( initial,
read_symbol( input, url_fgetwc( input ) ) ); read_symbol_or_key( input,
tag,
url_fgetwc( input ) ),
tag );
} else { } else {
result = NIL; result = NIL;
/* /*
@ -362,7 +367,7 @@ struct cons_pointer read_symbol( URL_FILE * input, wint_t initial ) {
break; break;
} }
debug_print( L"read_symbol returning\n", DEBUG_IO ); debug_print( L"read_symbol_or_key returning\n", DEBUG_IO );
debug_dump_object( result, DEBUG_IO ); debug_dump_object( result, DEBUG_IO );
return result; return result;