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

Merge branch 'develop' into feature/time

Browse source
This commit is contained in:
Simon Brooke 2019-02-07 14:29:05 +00:00
parent 23e4f0befa b35eb8f5c7
commit 0a9d54f97d
22 changed files with 1850 additions and 157 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
.gitignore vendored
View file

@ -36,3 +36,5 @@ utils_src/readprintwc/out
*.bak
src/io/fopen
hi\.*

4
src/init.c
View file

@ -26,6 +26,7 @@
#include "intern.h"
#include "io.h"
#include "lispops.h"
#include "map.h"
#include "meta.h"
#include "peano.h"
#include "print.h"
@ -68,7 +69,7 @@ void bind_special( wchar_t *name, struct cons_pointer ( *executable )
n ),
NIL ) );
deep_bind( n, make_special( NIL, executable ) );
deep_bind( n, make_special( meta, executable ) );
}
/**
@ -196,6 +197,7 @@ int main( int argc, char *argv[] ) {
bind_function( L"eval", &lisp_eval );
bind_function( L"exception", &lisp_exception );
bind_function( L"inspect", &lisp_inspect );
bind_function( L"make-map", &lisp_make_map);
bind_function( L"meta", &lisp_metadata );
bind_function( L"metadata", &lisp_metadata );
bind_function( L"multiply", &lisp_multiply );

11
src/io/io.c
View file

@ -15,6 +15,7 @@
#include <pwd.h>
#include <stdlib.h>
#include <string.h>
#include <time.h>
#include <sys/stat.h>
#include <sys/types.h>
#include <unistd.h>
@ -277,9 +278,11 @@ struct cons_pointer add_meta_time( struct cons_pointer meta, wchar_t *key,
/* I don't yet have a concept of a date-time object, which is a
* bit of an oversight! */
char datestring[256];
struct tm *tm = localtime( value );
strftime( datestring, sizeof( datestring ), nl_langinfo( D_T_FMT ), tm );
strftime( datestring,
sizeof( datestring ),
nl_langinfo( D_T_FMT ),
localtime( value ) );
return add_meta_string( meta, key, datestring );
}
@ -375,13 +378,13 @@ void collect_meta( struct cons_pointer stream, char *url ) {
meta =
add_meta_integer( meta, L"size",
( intmax_t ) statbuf.st_size );
/*
meta = add_meta_time( meta, L"modified", &statbuf.st_mtime );
*/
}
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 );

58
src/io/print.c
View file

@ -20,9 +20,12 @@
#include "conspage.h"
#include "consspaceobject.h"
#include "integer.h"
#include "intern.h"
#include "map.h"
#include "stack.h"
#include "print.h"
#include "time.h"
#include "vectorspace.h"
/**
* Whether or not we colorise output.
@ -98,7 +101,43 @@ void print_list( URL_FILE * output, struct cons_pointer pointer ) {
} else {
url_fputws( L")", output );
}
}
void print_map( URL_FILE * output, struct cons_pointer map) {
if ( vectorpointp( map)) {
struct vector_space_object *vso = pointer_to_vso( map);
if ( mapp( vso ) ) {
url_fputwc( btowc( '{' ), output );
for ( struct cons_pointer ks = keys( map);
!nilp( ks); ks = c_cdr( ks)) {
print( output, c_car( ks));
url_fputwc( btowc( ' ' ), output );
print( output, c_assoc( c_car( ks), map));
if ( !nilp( c_cdr( ks))) {
url_fputws( L", ", output );
}
}
url_fputwc( btowc( '}' ), output );
}
}
}
void print_vso( URL_FILE * output, struct cons_pointer pointer) {
struct vector_space_object *vso =
pointer2cell( pointer ).payload.vectorp.address;
switch ( vso->header.tag.value) {
case MAPTV:
print_map( output, pointer);
break;
// \todo: others.
}
}
/**
@ -123,7 +162,9 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) {
dump_stack_trace( output, pointer );
break;
case FUNCTIONTV:
url_fwprintf( output, L"<Function>" );
url_fputws( L"<Function: ", output);
print( output, cell.payload.function.meta);
url_fputwc( L'>', output);
break;
case INTEGERTV:{
struct cons_pointer s = integer_to_string( pointer, 10 );
@ -175,7 +216,9 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) {
print( output, cell.payload.ratio.divisor );
break;
case READTV:
url_fwprintf( output, L"<Input stream>" );
url_fwprintf( output, L"<Input stream: " );
print( output, cell.payload.stream.meta);
url_fputwc( L'>', output);
break;
case REALTV:
/* \todo using the C heap is a bad plan because it will fragment.
@ -209,7 +252,9 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) {
print_string_contents( output, pointer );
break;
case SPECIALTV:
url_fwprintf( output, L"<Special form>" );
url_fwprintf( output, L"<Special form: " );
print( output, cell.payload.special.meta);
url_fputwc( L'>', output);
break;
case TIMETV:
print_string(output, time_to_string( pointer));
@ -217,8 +262,13 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) {
case TRUETV:
url_fwprintf( output, L"t" );
break;
case VECTORPOINTTV:
print_vso( output, pointer);
break;
case WRITETV:
url_fwprintf( output, L"<Output stream>" );
url_fwprintf( output, L"<Output stream: " );
print( output, cell.payload.stream.meta);
url_fputwc( L'>', output);
break;
default:
fwprintf( stderr,

79
src/io/read.c
View file

@ -24,6 +24,7 @@
#include "intern.h"
#include "io.h"
#include "lispops.h"
#include "map.h"
#include "peano.h"
#include "print.h"
#include "ratio.h"
@ -44,6 +45,9 @@ struct cons_pointer read_number( struct stack_frame *frame,
struct cons_pointer read_list( struct stack_frame *frame,
struct cons_pointer frame_pointer,
URL_FILE * input, wint_t initial );
struct cons_pointer read_map( struct stack_frame *frame,
struct cons_pointer frame_pointer,
URL_FILE * input, wint_t initial );
struct cons_pointer read_string( URL_FILE * input, wint_t initial );
struct cons_pointer read_symbol_or_key( URL_FILE * input, char *tag,
wint_t initial );
@ -100,6 +104,10 @@ struct cons_pointer read_continuation( struct stack_frame *frame,
read_list( frame, frame_pointer, input,
url_fgetwc( input ) );
break;
case '{':
result = read_map( frame, frame_pointer, input,
url_fgetwc( input ) );
break;
case '"':
result = read_string( input, url_fgetwc( input ) );
break;
@ -126,9 +134,10 @@ struct cons_pointer read_continuation( struct stack_frame *frame,
} else if ( iswblank( next ) ) {
/* dotted pair. \todo this isn't right, we
* really need to backtrack up a level. */
result =
read_continuation( frame, frame_pointer, input,
result = read_continuation( frame, frame_pointer, input,
url_fgetwc( input ) );
debug_print( L"read_continuation: dotted pair; read cdr ",
DEBUG_IO);
} else {
read_symbol_or_key( input, SYMBOLTAG, c );
}
@ -275,19 +284,38 @@ struct cons_pointer read_number( struct stack_frame *frame,
* left parenthesis.
*/
struct cons_pointer read_list( struct stack_frame *frame,
struct cons_pointer frame_pointer,
URL_FILE * input, wint_t initial ) {
struct cons_pointer frame_pointer,
URL_FILE * input, wint_t initial ) {
struct cons_pointer result = NIL;
wint_t c;
if ( initial != ')' ) {
debug_printf( DEBUG_IO,
L"read_list starting '%C' (%d)\n", initial, initial );
L"read_list starting '%C' (%d)\n", initial, initial );
struct cons_pointer car =
read_continuation( frame, frame_pointer, input,
initial );
result =
make_cons( car,
read_list( frame, frame_pointer, input,
url_fgetwc( input ) ) );
initial );
/* skip whitespace */
for (c = url_fgetwc( input );
iswblank( c ) || iswcntrl( c );
c = url_fgetwc( input ));
if ( c == L'.') {
/* might be a dotted pair; indeed, if we rule out numbers with
* initial periods, it must be a dotted pair. \todo Ought to check,
* howerver, that there's only one form after the period. */
result =
make_cons( car,
c_car( read_list( frame,
frame_pointer,
input,
url_fgetwc( input ) ) ) );
} else {
result =
make_cons( car,
read_list( frame, frame_pointer, input, c ) );
}
} else {
debug_print( L"End of list detected\n", DEBUG_IO );
}
@ -295,6 +323,37 @@ struct cons_pointer read_list( struct stack_frame *frame,
return result;
}
struct cons_pointer read_map( struct stack_frame *frame,
struct cons_pointer frame_pointer,
URL_FILE * input, wint_t initial ) {
struct cons_pointer result = make_empty_map( NIL);
wint_t c = initial;
while ( c != L'}' ) {
struct cons_pointer key =
read_continuation( frame, frame_pointer, input, c );
/* skip whitespace */
for (c = url_fgetwc( input );
iswblank( c ) || iswcntrl( c );
c = url_fgetwc( input ));
struct cons_pointer value =
read_continuation( frame, frame_pointer, input, c );
/* skip commaa and whitespace at this point. */
for (c = url_fgetwc( input );
c == L',' || iswblank( c ) || iswcntrl( c );
c = url_fgetwc( input ));
result = merge_into_map( result, make_cons( make_cons( key, value), NIL));
}
return result;
}
/**
* Read a string. This means either a string delimited by double quotes
* (is_quoted == true), in which case it may contain whitespace but may

27
src/memory/consspaceobject.c
View file

@ -96,18 +96,41 @@ 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.
* Implementation of cdr in C. If arg is not a sequence, 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 ) ) {
struct cons_space_object cell = pointer2cell( arg );
switch (cell.tag.value) {
case CONSTV:
result = pointer2cell( arg ).payload.cons.cdr;
break;
case KEYTV:
case STRINGTV:
case SYMBOLTV:
result = pointer2cell( arg ).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.
*/

2
src/memory/consspaceobject.h
View file

@ -667,6 +667,8 @@ 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 );

5
src/memory/dump.c
View file

@ -21,6 +21,8 @@
#include "conspage.h"
#include "consspaceobject.h"
#include "debug.h"
#include "intern.h"
#include "map.h"
#include "print.h"
#include "stack.h"
#include "vectorspace.h"
@ -146,6 +148,9 @@ void dump_object( URL_FILE * output, struct cons_pointer pointer ) {
case STACKFRAMETV:
dump_frame( output, pointer );
break;
case MAPTV:
dump_map( output, pointer);
break;
}
}
break;

1001
src/memory/lookup3.c Normal file
View file

File diff suppressed because it is too large Load diff

19
src/memory/lookup3.h Normal file
View file

@ -0,0 +1,19 @@
/**
* 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

289
src/memory/map.c Normal file
View file

@ -0,0 +1,289 @@
/*
* map.c
*
* An immutable hashmap in vector space.
*
* (c) 2019 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <stdlib.h>
#include "consspaceobject.h"
#include "conspage.h"
#include "debug.h"
#include "dump.h"
#include "fopen.h"
#include "intern.h"
#include "io.h"
#include "lookup3.h"
#include "map.h"
#include "print.h"
#include "vectorspace.h"
/* \todo: a lot of this will be inherited by namespaces, regularities and
* homogeneities. Exactly how I don't yet know. */
/**
* Get a hash value for this key.
*/
uint32_t get_hash_32(struct cons_pointer f, struct cons_pointer key) {
uint32_t result = 0;
int l = c_length(key);
if (keywordp(key) || stringp(key) || symbolp( key)) {
if ( l > 0) {
uint32_t buffer[l];
if (!nilp(f)) {
fputws(L"Custom hashing functions are not yet implemented.\n", stderr);
}
for (int i = 0; i < l; i++) {
buffer[i] = (uint32_t)pointer2cell(key).payload.string.character;
}
result = hashword( buffer, l, 0);
}
} else {
fputws(L"Hashing is thus far implemented only for keys, strings and symbols.\n", stderr);
}
return result;
}
/**
* get the actual map object from this `pointer`, or NULL if
* `pointer` is not a map pointer.
*/
struct map_payload *get_map_payload( struct cons_pointer pointer ) {
struct map_payload *result = NULL;
struct vector_space_object *vso =
pointer2cell( pointer ).payload.vectorp.address;
if (vectorpointp(pointer) && mapp( vso ) ) {
result = ( struct map_payload * ) &( vso->payload );
debug_printf( DEBUG_BIND,
L"get_map_payload: all good, returning %p\n", result );
} else {
debug_print( L"get_map_payload: fail, returning NULL\n", DEBUG_BIND );
}
return result;
}
/**
* Make an empty immutable map, and return it.
*
* @param hash_function a pointer to a function of one argument, which
* returns an integer; or (more usually) `nil`.
* @return the new map, or NULL if memory is exhausted.
*/
struct cons_pointer make_empty_map( struct cons_pointer hash_function ) {
debug_print( L"Entering make_empty_map\n", DEBUG_BIND );
struct cons_pointer result =
make_vso( MAPTAG, sizeof( struct map_payload ) );
if ( !nilp( result ) ) {
struct map_payload *payload = get_map_payload( result );
payload->hash_function = functionp( hash_function) ? hash_function : NIL;
inc_ref(hash_function);
for ( int i = 0; i < BUCKETSINMAP; i++) {
payload->buckets[i] = NIL;
}
}
debug_print( L"Leaving make_empty_map\n", DEBUG_BIND );
return result;
}
struct cons_pointer make_duplicate_map( struct cons_pointer parent) {
struct cons_pointer result = NIL;
struct map_payload * parent_payload = get_map_payload(parent);
if (parent_payload != NULL) {
result =
make_vso( MAPTAG, sizeof( struct map_payload ) );
if ( !nilp( result ) ) {
struct map_payload *payload = get_map_payload( result );
payload->hash_function = parent_payload->hash_function;
inc_ref(payload->hash_function);
for ( int i = 0; i < BUCKETSINMAP; i++) {
payload->buckets[i] = parent_payload->buckets[i];
inc_ref(payload->buckets[i]);
}
}
}
return result;
}
struct cons_pointer bind_in_map( struct cons_pointer parent,
struct cons_pointer key,
struct cons_pointer value) {
struct cons_pointer result = make_duplicate_map(parent);
if ( !nilp( result)) {
struct map_payload * payload = get_map_payload( result );
int bucket = get_hash_32(payload->hash_function, key) % BUCKETSINMAP;
payload->buckets[bucket] = make_cons(
make_cons(key, value), payload->buckets[bucket]);
inc_ref(payload->buckets[bucket]);
}
return result;
}
struct cons_pointer keys( struct cons_pointer store) {
debug_print( L"Entering keys\n", DEBUG_BIND );
struct cons_pointer result = NIL;
struct cons_space_object cell = pointer2cell( store );
switch (pointer2cell( store ).tag.value) {
case CONSTV:
for (struct cons_pointer c = store; !nilp(c); c = c_cdr(c)) {
result = make_cons( c_car( c_car( c)), result);
}
break;
case VECTORPOINTTV: {
struct vector_space_object *vso =
pointer2cell( store ).payload.vectorp.address;
if ( mapp( vso ) ) {
struct map_payload * payload = get_map_payload( store );
for (int bucket = 0; bucket < BUCKETSINMAP; bucket++) {
for (struct cons_pointer c = payload->buckets[bucket];
!nilp(c); c = c_cdr(c)) {
debug_print( L"keys: c is ", DEBUG_BIND);
debug_print_object( c, DEBUG_BIND);
result = make_cons( c_car( c_car( c)), result);
debug_print( L"; result is ", DEBUG_BIND);
debug_print_object( result, DEBUG_BIND);
debug_println( DEBUG_BIND);
}
}
}
}
break;
}
debug_print( L"keys returning ", DEBUG_BIND );
debug_print_object( result, DEBUG_BIND );
debug_println( DEBUG_BIND);
return result;
}
/**
* Return a new map which represents the merger of `to_merge` into
* `parent`. `parent` must be a map, but `to_merge` may be a map or
* an assoc list.
*
* @param parent a map;
* @param to_merge an association from which key/value pairs will be merged.
* @result a new map, containing all key/value pairs from `to_merge`
* together with those key/value pairs from `parent` whose keys did not
* collide.
*/
struct cons_pointer merge_into_map( struct cons_pointer parent,
struct cons_pointer to_merge) {
debug_print( L"Entering merge_into_map\n", DEBUG_BIND );
struct cons_pointer result = make_duplicate_map(parent);
if (!nilp(result)) {
struct map_payload *payload = get_map_payload( result );
for (struct cons_pointer c = keys(to_merge);
!nilp(c); c = c_cdr(c)) {
struct cons_pointer key = c_car( c);
int bucket = get_hash_32(payload->hash_function, key) % BUCKETSINMAP;
payload->buckets[bucket] = make_cons(
make_cons( key, c_assoc( key, to_merge)),
payload->buckets[bucket]);
}
}
debug_print( L"Leaving merge_into_map\n", DEBUG_BIND );
return result;
}
struct cons_pointer assoc_in_map( struct cons_pointer key,
struct cons_pointer map) {
debug_print( L"Entering assoc_in_map\n", DEBUG_BIND );
struct cons_pointer result = NIL;
struct map_payload *payload = get_map_payload( map );
if (payload != NULL) {
int bucket = get_hash_32(payload->hash_function, key) % BUCKETSINMAP;
result = c_assoc(key, payload->buckets[bucket]);
}
debug_print( L"assoc_in_map returning ", DEBUG_BIND );
debug_print_object( result, DEBUG_BIND);
debug_println( DEBUG_BIND);
return result;
}
/**
* Function: create a map initialised with key/value pairs from my
* first argument.
*
* * (make-map)
* * (make-map store)
*
* @param frame the stack frame in which the expression is to be interpreted;
* @param frame_pointer a pointer to my stack_frame.
* @param env the environment in which it is to be intepreted.
* @return a new containing all the key/value pairs from store.
*/
struct cons_pointer
lisp_make_map( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
return merge_into_map( make_empty_map( NIL), frame->arg[0]);
}
/**
* Dump a map to this stream for debugging
* @param output the stream
* @param map_pointer the pointer to the frame
*/
void dump_map( URL_FILE * output, struct cons_pointer map_pointer ) {
struct vector_space_object *vso =
pointer2cell( map_pointer ).payload.vectorp.address;
if (vectorpointp(map_pointer) && mapp( vso ) ) {
struct map_payload *payload = get_map_payload( map_pointer );
if ( payload != NULL ) {
url_fputws( L"Immutable map; hash function: ", output );
if (nilp(payload->hash_function)) {
url_fputws( L"default", output);
} else {
dump_object( output, payload->hash_function);
}
for (int i = 0; i < BUCKETSINMAP; i++) {
url_fwprintf(output, L"\n\tBucket %d: ", i);
print( output, payload->buckets[i]);
}
}
}
}

96
src/memory/map.h Normal file
View file

@ -0,0 +1,96 @@
/*
* map.h
*
* An immutable hashmap in vector space.
*
* (c) 2019 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#ifndef __psse_map_h
#define __psse_map_h
#include "consspaceobject.h"
#include "conspage.h"
/**
* macros for the tag of a mutable map.
*/
#define MAPTAG "IMAP"
#define MAPTV 1346456905
/**
* Number of buckets in a single tier map.
*/
#define BUCKETSINMAP 256
/**
* Maximum number of entries in an association-list bucket.
*/
#define MAXENTRIESINASSOC 16
/**
* true if this vector_space_object is a map, else false.
*/
#define mapp( vso) (((struct vector_space_object *)vso)->header.tag.value == MAPTV)
/**
* The vector-space payload of a map object. Essentially a vector of
* `BUCKETSINMAP` + 1 `cons_pointer`s, but the first one is considered
* special.
*/
struct map_payload {
/**
* There is a default hash function, which is used if `hash_function` is
* `nil` (which it normally should be); and keywords will probably carry
* their own hash values. But it will be possible to override the hash
* function by putting a function of one argument returning an integer
* here. */
struct cons_pointer hash_function;
/**
* Obviously the number of buckets in a map is a trade off, and this may need
* tuning - or it may even be necessary to have different sized base maps. The
* idea here is that the value of a bucket is
*
* 1. `nil`; or
* 2. an association list; or
* 3. a map.
*
* All buckets are initially `nil`. Adding a value to a `nil` bucket returns
* a map with a new bucket in the form of an assoc list. Subsequent additions
* cons new key/value pairs onto the assoc list, until there are
* `MAXENTRIESINASSOC` pairs, at which point if a further value is added to
* the same bucket the bucket returned will be in the form of a second level
* map. My plan is that buckets the first level map will be indexed on the
* first sixteen bits of the hash value, those in the second on the second
* sixteen, and, potentially, so on.
*/
struct cons_pointer buckets[BUCKETSINMAP];
};
uint32_t get_hash_32(struct cons_pointer f, struct cons_pointer key);
struct map_payload *get_map_payload( struct cons_pointer pointer );
struct cons_pointer make_empty_map( struct cons_pointer hash_function );
struct cons_pointer bind_in_map( struct cons_pointer parent,
struct cons_pointer key,
struct cons_pointer value);
struct cons_pointer keys( struct cons_pointer store);
struct cons_pointer merge_into_map( struct cons_pointer parent,
struct cons_pointer to_merge);
struct cons_pointer assoc_in_map( struct cons_pointer key,
struct cons_pointer map);
struct cons_pointer lisp_make_map( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
void dump_map( URL_FILE * output, struct cons_pointer map_pointer );
#endif

6
src/memory/stack.h
View file

@ -18,12 +18,12 @@
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#ifndef __psse_stack_h
#define __psse_stack_h
#include "consspaceobject.h"
#include "conspage.h"
#ifndef __stack_h
#define __stack_h
/**
* macros for the tag of a stack frame.
*/

67
src/ops/intern.c
View file

@ -24,6 +24,7 @@
#include "debug.h"
#include "equal.h"
#include "lispops.h"
#include "map.h"
#include "print.h"
/**
@ -51,7 +52,7 @@ struct cons_pointer
internedp( struct cons_pointer key, struct cons_pointer store ) {
struct cons_pointer result = NIL;
if ( symbolp( key ) ) {
if ( symbolp( key ) || keywordp( key ) ) {
for ( struct cons_pointer next = store;
nilp( result ) && consp( next );
next = pointer2cell( next ).payload.cons.cdr ) {
@ -73,7 +74,7 @@ internedp( struct cons_pointer key, struct cons_pointer store ) {
debug_print_object( key, DEBUG_BIND );
debug_print( L"` is a ", DEBUG_BIND );
debug_print_object( c_type( key ), DEBUG_BIND );
debug_print( L", not a SYMB", DEBUG_BIND );
debug_print( L", not a KEYW or SYMB", DEBUG_BIND );
}
return result;
@ -88,20 +89,32 @@ internedp( struct cons_pointer key, struct cons_pointer store ) {
* of that key from the store; otherwise return NIL.
*/
struct cons_pointer c_assoc( struct cons_pointer key,
struct cons_pointer store ) {
struct cons_pointer store ) {
struct cons_pointer result = NIL;
for ( struct cons_pointer next = store;
consp( next ); next = pointer2cell( next ).payload.cons.cdr ) {
struct cons_space_object entry =
pointer2cell( pointer2cell( next ).payload.cons.car );
debug_print( L"c_assoc; key is `", DEBUG_BIND);
debug_print_object( key, DEBUG_BIND);
debug_print( L"`\n", DEBUG_BIND);
if ( equal( key, entry.payload.cons.car ) ) {
result = entry.payload.cons.cdr;
break;
if (consp(store)) {
for ( struct cons_pointer next = store;
consp( next ); next = pointer2cell( next ).payload.cons.cdr ) {
struct cons_space_object entry =
pointer2cell( pointer2cell( next ).payload.cons.car );
if ( equal( key, entry.payload.cons.car ) ) {
result = entry.payload.cons.cdr;
break;
}
}
} else if (vectorpointp( store)) {
result = assoc_in_map( key, store);
}
debug_print( L"c_assoc returning ", DEBUG_BIND);
debug_print_object( result, DEBUG_BIND);
debug_println( DEBUG_BIND);
return result;
}
@ -110,15 +123,29 @@ struct cons_pointer c_assoc( struct cons_pointer key,
* with this key/value pair added to the front.
*/
struct cons_pointer
set( struct cons_pointer key, struct cons_pointer value,
struct cons_pointer store ) {
debug_print( L"Binding ", DEBUG_BIND );
set( struct cons_pointer key, struct cons_pointer value,
struct cons_pointer store ) {
struct cons_pointer result = NIL;
debug_print( L"set: binding `", DEBUG_BIND );
debug_print_object( key, DEBUG_BIND );
debug_print( L" to ", DEBUG_BIND );
debug_print( L"` to `", DEBUG_BIND );
debug_print_object( value, DEBUG_BIND );
debug_print( L"` in store ", DEBUG_BIND );
debug_dump_object( store, DEBUG_BIND);
debug_println( DEBUG_BIND );
return make_cons( make_cons( key, value ), store );
if (nilp( store) || consp(store)) {
result = make_cons( make_cons( key, value ), store );
} else if (vectorpointp( store)) {
result = bind_in_map( store, key, value);
}
debug_print( L"set returning ", DEBUG_BIND);
debug_print_object( result, DEBUG_BIND);
debug_println( DEBUG_BIND);
return result;
}
/**
@ -131,11 +158,19 @@ deep_bind( struct cons_pointer key, struct cons_pointer value ) {
debug_print( L"Entering deep_bind\n", DEBUG_BIND );
struct cons_pointer old = oblist;
debug_print( L"deep_bind: binding `", DEBUG_BIND );
debug_print_object( key, DEBUG_BIND );
debug_print( L"` to ", DEBUG_BIND );
debug_print_object( value, DEBUG_BIND );
debug_println( DEBUG_BIND );
oblist = set( key, value, oblist );
inc_ref( oblist );
dec_ref( old );
debug_print( L"Leaving deep_bind\n", DEBUG_BIND );
debug_print( L"deep_bind returning ", DEBUG_BIND );
debug_print_object( oblist, DEBUG_BIND );
debug_println( DEBUG_BIND );
return oblist;
}

209
src/ops/lispops.c
View file

@ -33,9 +33,11 @@
#include "intern.h"
#include "io.h"
#include "lispops.h"
#include "map.h"
#include "print.h"
#include "read.h"
#include "stack.h"
#include "vectorspace.h"
/*
* also to create in this section:
@ -269,8 +271,8 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
* @return the result of evaluating the function with its arguments.
*/
struct cons_pointer
c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
debug_print( L"Entering c_apply\n", DEBUG_EVAL );
struct cons_pointer result = NIL;
@ -285,96 +287,122 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
switch ( fn_cell.tag.value ) {
case EXCEPTIONTV:
/* just pass exceptions straight back */
result = fn_pointer;
break;
case FUNCTIONTV:
{
struct cons_pointer exep = NIL;
struct cons_pointer next_pointer =
make_stack_frame( frame_pointer, args, env );
inc_ref( next_pointer );
if ( exceptionp( next_pointer ) ) {
result = next_pointer;
} else {
struct stack_frame *next =
get_stack_frame( next_pointer );
/* just pass exceptions straight back */
result = fn_pointer;
break;
result =
( *fn_cell.payload.function.executable ) ( next,
next_pointer,
env );
dec_ref( next_pointer );
}
case FUNCTIONTV:
{
struct cons_pointer exep = NIL;
struct cons_pointer next_pointer =
make_stack_frame( frame_pointer, args, env );
inc_ref( next_pointer );
if ( exceptionp( next_pointer ) ) {
result = next_pointer;
} else {
struct stack_frame *next =
get_stack_frame( next_pointer );
result =
( *fn_cell.payload.function.executable ) ( next,
next_pointer,
env );
dec_ref( next_pointer );
}
break;
}
break;
case KEYTV:
result = c_assoc( fn_pointer,
eval_form(frame,
frame_pointer,
c_car( c_cdr( frame->arg[0])),
env));
break;
case LAMBDATV:
{
struct cons_pointer exep = NIL;
struct cons_pointer next_pointer =
make_stack_frame( frame_pointer, args, env );
inc_ref( next_pointer );
if ( exceptionp( next_pointer ) ) {
result = next_pointer;
} else {
struct stack_frame *next =
get_stack_frame( next_pointer );
result =
eval_lambda( fn_cell, next, next_pointer, env );
if ( !exceptionp( result ) ) {
dec_ref( next_pointer );
}
{
struct cons_pointer exep = NIL;
struct cons_pointer next_pointer =
make_stack_frame( frame_pointer, args, env );
inc_ref( next_pointer );
if ( exceptionp( next_pointer ) ) {
result = next_pointer;
} else {
struct stack_frame *next =
get_stack_frame( next_pointer );
result =
eval_lambda( fn_cell, next, next_pointer, env );
if ( !exceptionp( result ) ) {
dec_ref( next_pointer );
}
}
}
break;
case VECTORPOINTTV:
switch ( pointer_to_vso(fn_pointer)->header.tag.value) {
case MAPTV:
/* \todo: if arg[0] is a CONS, treat it as a path */
result = c_assoc( eval_form(frame,
frame_pointer,
c_car( c_cdr( frame->arg[0])),
env),
fn_pointer);
break;
}
break;
case NLAMBDATV:
{
struct cons_pointer next_pointer =
make_special_frame( frame_pointer, args, env );
inc_ref( next_pointer );
if ( exceptionp( next_pointer ) ) {
result = next_pointer;
} else {
struct stack_frame *next =
get_stack_frame( next_pointer );
result =
eval_lambda( fn_cell, next, next_pointer, env );
dec_ref( next_pointer );
}
{
struct cons_pointer next_pointer =
make_special_frame( frame_pointer, args, env );
inc_ref( next_pointer );
if ( exceptionp( next_pointer ) ) {
result = next_pointer;
} else {
struct stack_frame *next =
get_stack_frame( next_pointer );
result =
eval_lambda( fn_cell, next, next_pointer, env );
dec_ref( next_pointer );
}
break;
}
break;
case SPECIALTV:
{
struct cons_pointer next_pointer =
make_special_frame( frame_pointer, args, env );
inc_ref( next_pointer );
if ( exceptionp( next_pointer ) ) {
result = next_pointer;
} else {
result =
( *fn_cell.payload.special.
executable ) ( get_stack_frame( next_pointer ),
next_pointer, env );
debug_print( L"Special form returning: ", DEBUG_EVAL );
debug_print_object( result, DEBUG_EVAL );
debug_println( DEBUG_EVAL );
dec_ref( next_pointer );
}
{
struct cons_pointer next_pointer =
make_special_frame( frame_pointer, args, env );
inc_ref( next_pointer );
if ( exceptionp( next_pointer ) ) {
result = next_pointer;
} else {
result =
( *fn_cell.payload.special.
executable ) ( get_stack_frame( next_pointer ),
next_pointer, env );
debug_print( L"Special form returning: ", DEBUG_EVAL );
debug_print_object( result, DEBUG_EVAL );
debug_println( DEBUG_EVAL );
dec_ref( next_pointer );
}
break;
}
break;
default:
{
int bs = sizeof( wchar_t ) * 1024;
wchar_t *buffer = malloc( bs );
memset( buffer, '\0', bs );
swprintf( buffer, bs,
L"Unexpected cell with tag %d (%4.4s) in function position",
fn_cell.tag.value, &fn_cell.tag.bytes[0] );
struct cons_pointer message =
c_string_to_lisp_string( buffer );
free( buffer );
result = throw_exception( message, frame_pointer );
}
{
int bs = sizeof( wchar_t ) * 1024;
wchar_t *buffer = malloc( bs );
memset( buffer, '\0', bs );
swprintf( buffer, bs,
L"Unexpected cell with tag %d (%4.4s) in function position",
fn_cell.tag.value, &fn_cell.tag.bytes[0] );
struct cons_pointer message =
c_string_to_lisp_string( buffer );
free( buffer );
result = throw_exception( message, frame_pointer );
}
}
}
@ -416,9 +444,7 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer,
switch ( cell.tag.value ) {
case CONSTV:
{
result = c_apply( frame, frame_pointer, env );
}
break;
case SYMBOLTV:
@ -709,6 +735,22 @@ lisp_cdr( struct stack_frame *frame, struct cons_pointer frame_pointer,
return result;
}
/**
* Function: return, as an integer, the length of the sequence indicated by
* the first argument, or zero if it is not a sequence.
*
* * (length any)
*
* @param frame my stack_frame.
* @param frame_pointer a pointer to my stack_frame.
* @param env my environment (ignored).
* @return the length of `any`, if it is a sequence, or zero otherwise.
*/
struct cons_pointer lisp_length( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
return make_integer( c_length( frame->arg[0]), NIL);
}
/**
* Function; look up the value of a `key` in a `store`.
*
@ -1265,6 +1307,7 @@ struct cons_pointer lisp_inspect( struct stack_frame *frame,
}
dump_object( output, frame->arg[0] );
url_fputws( L"\n", output );
if ( writep( out_stream ) ) {
dec_ref( out_stream );

4
src/ops/lispops.h
View file

@ -85,7 +85,9 @@ lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer lisp_lambda( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_length( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
/**
* Construct an interpretable special form.
*

2
src/utils.c
View file

@ -12,7 +12,7 @@
#include <string.h>
int index_of( char c, char *s ) {
int index_of( char c, const char *s ) {
int i;
for ( i = 0; s[i] != c && s[i] != 0; i++ );

4
src/utils.h
View file

@ -10,6 +10,8 @@
#ifndef __psse_utils_h
#define __psse_utils_h
int index_of( char c, char *s );
int index_of( char c, const char *s );
char *trim( char *s );
#endif

2
unit-tests/eval-quote-symbol.sh
View file

@ -1,6 +1,6 @@
#!/bin/bash
expected='<Special form>'
expected='<Special form: ((:primitive . t) (:name . cond))>'
actual=`echo "(eval 'cond)" | target/psse | tail -1`
if [ "${expected}" = "${actual}" ]

89
unit-tests/map.sh Executable file
View file

@ -0,0 +1,89 @@
#!/bin/bash
#####################################################################
# Create an empty map using map notation
expected='{}'
actual=`echo "$expected" | target/psse | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
exit 1
fi
#####################################################################
# Create an empty map using make-map
expected='{}'
actual=`echo "(make-map)" | target/psse | tail -1`
echo -n "Empty map using (make-map): "
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
exit 1
fi
#####################################################################
# Create a map using map notation: order of keys in output is not
# significant at this stage, but in the long term should be sorted
# alphanumerically
expected='{:two 2, :one 1, :three 3}'
actual=`echo "{:one 1 :two 2 :three 3}" | target/psse | tail -1`
echo -n "Map using map notation: "
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
exit 1
fi
#####################################################################
# Create a map using make-map: order of keys in output is not
# significant at this stage, but in the long term should be sorted
# alphanumerically
expected='{:two 2, :one 1, :three 3}'
actual=`echo "(make-map '((:one . 1)(:two . 2)(:three . 3)))" | target/psse | tail -1`
echo -n "Map using (make-map): "
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
exit 1
fi
#####################################################################
# Keyword in function position
expected='2'
actual=`echo "(:two {:one 1 :two 2 :three 3})" | target/psse | tail -1`
echo -n "Keyword in function position: "
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
exit 1
fi
#####################################################################
# Map in function position
expected='2'
actual=`echo "({:one 1 :two 2 :three 3} :two)" | target/psse | tail -1`
echo -n "Map in function position: "
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
exit 1
fi

2
unit-tests/slurp.sh
View file

@ -1,6 +1,6 @@
#!/bin/bash
tmp=hi$$
tmp=hi.$$
echo "Hello, there." > ${tmp}
expected='"Hello, there.'
actual=`echo "(slurp (open \"${tmp}\"))" | target/psse | tail -2 | head -1`

29
where-does-it-break.sh
View file

@ -1,29 +0,0 @@
#!/bin/bash
# Not really a unit test, but a check to see where bignum addition breaks
broken=0
i=11529215046068469750
# we've already proven we can successfullu get up to here
increment=1
while [ $broken -eq "0" ]
do
expr="(+ $i $increment)"
# Use sbcl as our reference implementation...
expected=`echo "$expr" | sbcl --noinform | grep -v '*'`
actual=`echo "$expr" | target/psse | tail -1 | sed 's/\,//g'`
echo -n "adding $increment to $i: "
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
broken=1
exit 1
fi
i=$expected
done