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

#8: Done

Browse source 
I'm now of the opinion that this is done at the wrong level in the stack and needs to be redone later; but it works for now.

There's a regression in `open`, but I can't see why.
This commit is contained in:
Simon Brooke 2019-02-07 09:02:28 +00:00
parent 0687b0baeb
commit f36436a9e1
12 changed files with 134 additions and 41 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
src/init.c
View file

@ -69,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 ) );
}
/**

7
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 );
}

30
src/io/print.c
View file

@ -104,18 +104,18 @@ void print_list( URL_FILE * output, struct cons_pointer pointer ) {
}
void print_map( URL_FILE * output, struct cons_pointer pointer) {
if ( vectorpointp( pointer)) {
struct vector_space_object *vso = pointer_to_vso( pointer);
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(pointer);
!nilp(ks); ks = c_cdr(ks)) {
print( output, c_car(ks));
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( pointer, c_car(ks)));
print( output, c_assoc( c_car( ks), map));
if ( !nilp( c_cdr( ks))) {
url_fputws( L", ", output );
@ -162,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 );
@ -214,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.
@ -248,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));
@ -260,7 +266,9 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) {
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

36
src/memory/map.c
View file

@ -15,6 +15,7 @@
#include "dump.h"
#include "fopen.h"
#include "intern.h"
#include "io.h"
#include "lookup3.h"
#include "map.h"
#include "print.h"
@ -61,10 +62,10 @@ struct map_payload *get_map_payload( struct cons_pointer pointer ) {
if (vectorpointp(pointer) && mapp( vso ) ) {
result = ( struct map_payload * ) &( vso->payload );
debug_printf( DEBUG_STACK,
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_STACK );
debug_print( L"get_map_payload: fail, returning NULL\n", DEBUG_BIND );
}
return result;
@ -79,7 +80,7 @@ struct map_payload *get_map_payload( struct cons_pointer pointer ) {
* @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_ALLOC );
debug_print( L"Entering make_empty_map\n", DEBUG_BIND );
struct cons_pointer result =
make_vso( MAPTAG, sizeof( struct map_payload ) );
@ -94,6 +95,7 @@ struct cons_pointer make_empty_map( struct cons_pointer hash_function ) {
}
}
debug_print( L"Leaving make_empty_map\n", DEBUG_BIND );
return result;
}
@ -143,6 +145,7 @@ struct cons_pointer bind_in_map( struct cons_pointer parent,
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 );
@ -158,18 +161,27 @@ struct cons_pointer keys( struct cons_pointer store) {
pointer2cell( store ).payload.vectorp.address;
if ( mapp( vso ) ) {
struct map_payload * payload = get_map_payload( result );
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;
}
@ -187,6 +199,7 @@ struct cons_pointer keys( struct cons_pointer store) {
*/
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)) {
@ -202,24 +215,31 @@ struct cons_pointer merge_into_map( struct cons_pointer parent,
}
}
debug_print( L"Leaving merge_into_map\n", DEBUG_BIND );
return result;
}
struct cons_pointer assoc_in_map( struct cons_pointer map,
struct cons_pointer key) {
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.
@ -251,7 +271,7 @@ void dump_map( URL_FILE * output, struct cons_pointer map_pointer ) {
struct map_payload *payload = get_map_payload( map_pointer );
if ( payload != NULL ) {
url_fputws( L"Immutable map; hash function:", output );
url_fputws( L"Immutable map; hash function: ", output );
if (nilp(payload->hash_function)) {
url_fputws( L"default", output);

6
src/memory/map.h
View file

@ -73,6 +73,8 @@ 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);
@ -82,8 +84,8 @@ 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 map,
struct cons_pointer key);
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,

4
src/ops/intern.c
View file

@ -94,9 +94,7 @@ struct cons_pointer c_assoc( struct cons_pointer key,
debug_print( L"c_assoc; key is `", DEBUG_BIND);
debug_print_object( key, DEBUG_BIND);
debug_print( L"`; store is \n", DEBUG_BIND);
debug_dump_object( store, DEBUG_BIND);
debug_println(DEBUG_BIND);
debug_print( L"`\n", DEBUG_BIND);
if (consp(store)) {
for ( struct cons_pointer next = store;

1
src/ops/lispops.c
View file

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

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}" ]

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`