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

This isn't working, but I think it's progress.

Browse source
This commit is contained in:
simon 2017-09-13 12:50:20 +01:00
parent 5dee093e65
commit 9661ad339a
13 changed files with 149 additions and 49 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
include/licence-header.txt Normal file
View file

@ -0,0 +1,2 @@
(c) 2017 Simon Brooke <simon@journeyman.cc>
Licensed under GPL version 2.0, or, at your option, any later version.

32
src/consspaceobject.c
View file

@ -19,6 +19,7 @@
#include "conspage.h"
#include "consspaceobject.h"
#include "print.h"
/**
* Check that the tag on the cell at this pointer is this tag
@ -73,28 +74,47 @@ void dump_object( FILE * output, struct cons_pointer pointer ) {
cell.tag.bytes[3],
cell.tag.value, pointer.page, pointer.offset, cell.count );
if ( check_tag( pointer, CONSTAG ) ) {
switch ( cell.tag.value) {
case CONSTV:
fwprintf( output,
L"\t\tCons cell: car at page %d offset %d, cdr at page %d offset %d\n",
cell.payload.cons.car.page,
cell.payload.cons.car.offset,
cell.payload.cons.cdr.page, cell.payload.cons.cdr.offset );
} else if ( check_tag( pointer, INTEGERTAG ) ) {
break;
case INTEGERTV:
fwprintf( output,
L"\t\tInteger cell: value %ld\n",
cell.payload.integer.value );
} else if ( check_tag( pointer, FREETAG ) ) {
break;
case FREETV:
fwprintf( output, L"\t\tFree cell: next at page %d offset %d\n",
cell.payload.cons.cdr.page, cell.payload.cons.cdr.offset );
} else if ( check_tag( pointer, REALTAG ) ) {
break;
case REALTV:
fwprintf( output, L"\t\tReal cell: value %Lf\n",
cell.payload.real.value );
} else if ( check_tag( pointer, STRINGTAG ) ) {
break;
case STRINGTV:
fwprintf( output,
L"\t\tString cell: character '%1c' (%1d) next at page %2d offset %3d\n",
cell.payload.string.character,
cell.payload.string.cdr.page,
cell.payload.string.cdr.offset );
fwprintf( output, L"\t\t value:");
print(output, pointer);
fwprintf( output, L"\n");
break;
case SYMBOLTV:
fwprintf( output,
L"\t\tSymbol cell: character '%1c' (%1d) next at page %2d offset %3d\n",
cell.payload.string.character,
cell.payload.string.cdr.page,
cell.payload.string.cdr.offset );
fwprintf( output, L"\t\t value:");
print(output, pointer);
fwprintf( output, L"\n");
break;
}
}
@ -150,7 +170,7 @@ make_string_like_thing( wint_t c, struct cons_pointer tail, char *tag ) {
inc_ref( tail );
cell->payload.string.character = c;
cell->payload.string.cdr.page = tail.page;
/* TODO: There's a problem here. Sometimes the offsets on
/* TODO: There's a problem here. Sometimes the offsets on
* strings are quite massively off. */
cell->payload.string.cdr.offset = tail.offset;
} else {

2
src/consspaceobject.h
View file

@ -156,7 +156,7 @@
#define stringp(conspoint) (check_tag(conspoint,STRINGTAG))
/**
* true if conspointer points to a string cell, else false
* true if conspointer points to a symbol cell, else false
*/
#define symbolp(conspoint) (check_tag(conspoint,SYMBOLTAG))

52
src/equal.c
View file

@ -22,6 +22,21 @@ bool eq( struct cons_pointer a, struct cons_pointer b ) {
return ( ( a.page == b.page ) && ( a.offset == b.offset ) );
}
/**
* True if the objects at these two cons pointers have the same tag, else false.
* @param a a pointer to a cons-space object;
* @param b another pointer to a cons-space object.
* @return true if the objects at these two cons pointers have the same tag,
* else false.
*/
bool same_type( struct cons_pointer a, struct cons_pointer b ) {
struct cons_space_object *cell_a = &pointer2cell( a );
struct cons_space_object *cell_b = &pointer2cell( b );
return cell_a->tag.value == cell_b->tag.value;
}
/**
* Deep, and thus expensive, equality: true if these two objects have
* identical structure, else false.
@ -29,15 +44,18 @@ bool eq( struct cons_pointer a, struct cons_pointer b ) {
bool equal( struct cons_pointer a, struct cons_pointer b ) {
bool result = eq( a, b );
if ( !result ) {
if ( !result && same_type( a, b ) ) {
struct cons_space_object *cell_a = &pointer2cell( a );
struct cons_space_object *cell_b = &pointer2cell( b );
if ( consp( a ) && consp( b ) ) {
switch ( cell_a->tag.value ) {
case CONSTV:
result =
equal( cell_a->payload.cons.car, cell_b->payload.cons.car )
&& equal( cell_a->payload.cons.cdr, cell_b->payload.cons.cdr );
} else if ( stringp( a ) && stringp( b ) ) {
break;
case STRINGTV:
case SYMBOLTV:
/*
* slightly complex because a string may or may not have a '\0'
* cell at the end, but I'll ignore that for now. I think in
@ -48,17 +66,27 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) {
cell_b->payload.string.character
&& equal( cell_a->payload.string.cdr,
cell_b->payload.string.cdr );
} else if ( numberp( a ) && numberp( b ) ) {
double num_a = numeric_value( a );
double num_b = numeric_value( b );
double max =
fabs( num_a ) > fabs( num_b ) ? fabs( num_a ) : fabs( num_b );
break;
case INTEGERTV:
case REALTV:
{
double num_a = numeric_value( a );
double num_b = numeric_value( b );
double max =
fabs( num_a ) >
fabs( num_b ) ? fabs( num_a ) : fabs( num_b );
/*
* not more different than one part in a million - close enough
*/
result = fabs( num_a - num_b ) < ( max / 1000000.0 );
/*
* not more different than one part in a million - close enough
*/
result = fabs( num_a - num_b ) < ( max / 1000000.0 );
}
break;
default:
result = false;
break;
}
/*
* there's only supposed ever to be one T and one NIL cell, so each
* should be caught by eq; equality of vector-space objects is a whole

21
src/init.c
View file

@ -54,14 +54,14 @@ int main( int argc, char *argv[] ) {
show_prompt = true;
break;
default:
fprintf( stderr, "Unexpected option %c\n", option );
fwprintf( stderr, L"Unexpected option %c\n", option );
break;
}
}
if ( show_prompt ) {
fprintf( stdout,
"Post scarcity software environment version %s\n\n",
fwprintf( stdout,
L"Post scarcity software environment version %s\n\n",
VERSION );
}
@ -70,12 +70,17 @@ int main( int argc, char *argv[] ) {
/*
* privileged variables (keywords)
*/
/*
deep_bind( intern( c_string_to_lisp_string( "nil" ), oblist ), NIL );
deep_bind( intern( c_string_to_lisp_string( "t" ), oblist ), TRUE );
*/
struct cons_pointer lisp_symbol = c_string_to_lisp_symbol( "oblist");
deep_bind( lisp_symbol, &oblist);
/*
* primitive function operations
*/
/*
bind_function( "assoc", &lisp_assoc );
bind_function( "car", &lisp_car );
bind_function( "cdr", &lisp_cdr );
@ -84,14 +89,20 @@ int main( int argc, char *argv[] ) {
bind_function( "equal", &lisp_equal );
bind_function( "read", &lisp_read );
bind_function( "print", &lisp_print );
*/
/*
* primitive special forms
*/
/*
bind_special( "apply", &lisp_apply );
bind_special( "eval", &lisp_eval );
bind_special( "quote", &lisp_quote );
*/
if ( show_prompt) {
fwprintf( stderr, L"Oblist: ");
print(stderr, *oblist);
}
repl( stdin, stdout, stderr, show_prompt );
if ( dump_at_end ) {

2
src/integer.c
View file

@ -41,7 +41,7 @@ struct cons_pointer make_integer( long int value ) {
struct cons_space_object *cell = &pointer2cell( result );
cell->payload.integer.value = value;
dump_object( stderr, result);
dump_object( stderr, result );
return result;
}

6
src/intern.c
View file

@ -32,7 +32,7 @@
* they're visible to all users/threads, but again I don't yet have any idea how
* that will work.
*/
struct cons_pointer oblist = NIL;
struct cons_pointer oblist = & NIL;
/**
* Implementation of interned? in C. The final implementation if interned? will
@ -91,7 +91,7 @@ struct cons_pointer c_assoc( struct cons_pointer key,
* Return a new key/value store containing all the key/value pairs in this store
* with this key/value pair added to the front.
*/
struct cons_pointer
struct cons_pointer
bind( struct cons_pointer key, struct cons_pointer value,
struct cons_pointer store ) {
return make_cons( make_cons( key, value ), store );
@ -104,7 +104,7 @@ bind( struct cons_pointer key, struct cons_pointer value,
*/
struct cons_pointer
deep_bind( struct cons_pointer key, struct cons_pointer value ) {
oblist = bind( key, value, oblist );
oblist = &bind( key, value, *oblist );
return oblist;
}

2
src/intern.h
View file

@ -20,7 +20,7 @@
#ifndef __intern_h
#define __intern_h
extern struct cons_pointer oblist;
extern struct cons_pointer * oblist;
/**
* return the value associated with this key in this store. In the current

25
src/lispops.c
View file

@ -104,8 +104,7 @@ eval_cons( struct cons_pointer s_expr, struct cons_pointer env,
{
struct cons_space_object special = pointer2cell( fn_pointer );
result =
( *special.payload.special.executable ) ( args, env,
my_frame );
( *special.payload.special.executable ) ( args, env, my_frame );
}
break;
@ -164,15 +163,15 @@ lisp_eval( struct cons_pointer s_expr, struct cons_pointer env,
struct cons_pointer result = s_expr;
struct cons_space_object cell = pointer2cell( s_expr );
fprintf( stderr, "In eval; about to make stack frame" );
struct stack_frame *frame = make_stack_frame( previous, s_expr, env );
fprintf( stderr, "In eval; stack frame made" );
switch ( cell.tag.value ) {
case CONSTV:
fwprintf( stderr, L"In eval; about to make stack frame" );
struct stack_frame *frame = make_stack_frame( previous, s_expr, env );
fwprintf( stderr, L"In eval; stack frame made" );
result = eval_cons( s_expr, env, frame );
free_stack_frame( frame );
break;
case SYMBOLTV:
@ -197,8 +196,6 @@ lisp_eval( struct cons_pointer s_expr, struct cons_pointer env,
*/
}
free_stack_frame( frame );
return result;
}
@ -212,7 +209,7 @@ lisp_eval( struct cons_pointer s_expr, struct cons_pointer env,
struct cons_pointer
lisp_quote( struct cons_pointer args, struct cons_pointer env,
struct stack_frame *frame ) {
return c_car( args );
return frame->arg[0];
}
/**
@ -360,10 +357,10 @@ lisp_print( struct stack_frame *frame, struct cons_pointer env ) {
*/
struct cons_pointer
lisp_throw( struct cons_pointer message, struct stack_frame *frame ) {
fprintf( stderr, "\nERROR: " );
fwprintf( stderr, L"\nERROR: " );
print( stderr, message );
fprintf( stderr,
"\n\nAn exception was thrown and I've no idea what to do now\n" );
fwprintf( stderr,
L"\n\nAn exception was thrown and I've no idea what to do now\n" );
exit( 1 );
}

35
src/peano.c Normal file
View file

@ -0,0 +1,35 @@
/**
* peano.c
*
* Basic peano arithmetic
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <ctype.h>
#include <stdbool.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include "consspaceobject.h"
#include "conspage.h"
#include "equal.h"
#include "integer.h"
#include "intern.h"
#include "lispops.h"
#include "print.h"
#include "read.h"
#include "stack.h"
/*
struct cons_pointer
lisp_plus( struct cons_pointer s_expr, struct cons_pointer env,
struct stack_frame *frame ) {
struct cons_space_object cell = pointer2cell( s_expr );
struct cons_space_object result = NIL;
}
*/

6
src/print.c
View file

@ -100,6 +100,12 @@ void print( FILE * output, struct cons_pointer pointer ) {
case TRUETV:
fwprintf( output, L"t" );
break;
case FUNCTIONTV:
fwprintf( output, L"(Function)");
break;
case SPECIALTV:
fwprintf( output, L"(Special form)");
break;
default:
fwprintf( stderr,
L"Error: Unrecognised tag value %d (%c%c%c%c)\n",

3
src/read.c
View file

@ -96,7 +96,8 @@ struct cons_pointer read_number( FILE * input, wint_t initial ) {
} else {
accumulator = accumulator * 10 + ( ( int ) c - ( int ) '0' );
fprintf( stderr, "Added character %c, accumulator now %ld\n", c, accumulator);
fprintf( stderr, "Added character %c, accumulator now %ld\n", c,
accumulator );
if ( seen_period ) {
places_of_decimals++;

10
src/repl.c
View file

@ -35,13 +35,13 @@ repl( FILE * in_stream, FILE * out_stream, FILE * error_stream,
fwprintf( out_stream, L"\n-> " );
}
/* OK, I think what's going wrong here is we're passing by
* value and I think we should be passing by reference.
/* OK, I think what's going wrong here is we're passing by
* value and I think we should be passing by reference.
* I'm not certain about that, and as it will be a really
* major change I'm going to think some more before making
* in */
// print( out_stream, lisp_eval(input, oblist, NULL));
print( out_stream, input );
* in */
print( out_stream, lisp_eval( input, oblist, NULL ) );
// print( out_stream, input );
fwprintf( out_stream, L"\n" );
fwprintf( error_stream, L"\neval {%d,%d}=> ", input.page,
input.offset );