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

Upversioned the C source tree to '0.0.7-SNAPSHOT', but proposing to start experimental

Browse source 
work towards 0.1.0 in separate source trees.
This commit is contained in:
Simon Brooke 2026-03-19 13:59:06 +00:00
parent 788cb48b37
commit 99d4794f3b
57 changed files with 2 additions and 2 deletions
Download patch file Download diff file Expand all files Collapse all files

508
src/c/arith/integer.c Normal file
View file

@ -0,0 +1,508 @@
/*
* integer.c
*
* functions for integer cells.
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#define _GNU_SOURCE
#include <limits.h>
#include <math.h>
#include <stdio.h>
#include <stdlib.h>
#include <inttypes.h>
/*
* wide characters
*/
#include <wchar.h>
#include <wctype.h>
#include "arith/integer.h"
#include "arith/peano.h"
#include "debug.h"
#include "memory/conspage.h"
#include "memory/consspaceobject.h"
#include "ops/equal.h"
#include "ops/lispops.h"
/**
* hexadecimal digits for printing numbers.
*/
const char *hex_digits = "0123456789ABCDEF";
/*
* Doctrine from here on in is that ALL integers are bignums, it's just
* that integers less than 61 bits are bignums of one cell only.
* that integers less than 61 bits are bignums of one cell only.
* TODO: why do I not have confidence to make this 64 bits?
*/
/*
* A small_int_cache array of pointers to the integers 0...23,
* used only by functions `acquire_integer(int64) => cons_pointer` and
* `release_integer(cons_pointer) => NULL` which, if the value desired is
* in the cache, supplies it from the cache, and, otherwise, calls
* make_integer() and dec_ref() respectively.
*/
#define SMALL_INT_LIMIT 24
bool small_int_cache_initialised = false;
struct cons_pointer small_int_cache[SMALL_INT_LIMIT];
/**
* Low level integer arithmetic, do not use elsewhere.
*
* @param c a pointer to a cell, assumed to be an integer cell;
* @param op a character representing the operation: expected to be either
* '+' or '*'; behaviour with other values is undefined.
* @param is_first_cell true if this is the first cell in a bignum
* chain, else false.
* \see multiply_integers
* \see add_integers
*/
__int128_t cell_value( struct cons_pointer c, char op, bool is_first_cell ) {
long int val = nilp( c ) ? 0 : pointer2cell( c ).payload.integer.value;
long int carry = is_first_cell ? 0 : ( INT_CELL_BASE );
__int128_t result = ( __int128_t ) integerp( c ) ?
( val == 0 ) ? carry : val : op == '*' ? 1 : 0;
debug_printf( DEBUG_ARITH,
L"cell_value: raw value is %ld, is_first_cell = %s; '%4.4s'; returning ",
val, is_first_cell ? "true" : "false",
pointer2cell( c ).tag.bytes );
debug_print_128bit( result, DEBUG_ARITH );
debug_println( DEBUG_ARITH );
return result;
}
/**
* Allocate an integer cell representing this `value` and return a cons_pointer to it.
* @param value an integer value;
* @param more `NIL`, or a pointer to the more significant cell(s) of this number.
* *NOTE* that if `more` is not `NIL`, `value` *must not* exceed `MAX_INTEGER`.
*/
struct cons_pointer make_integer( int64_t value, struct cons_pointer more ) {
struct cons_pointer result = NIL;
debug_print( L"Entering make_integer\n", DEBUG_ALLOC );
if ( integerp( more )
&& ( pointer2cell( more ).payload.integer.value < 0 ) ) {
printf( "WARNING: negative value %" PRId64
" passed as `more` to `make_integer`\n",
pointer2cell( more ).payload.integer.value );
}
if ( integerp( more ) || nilp( more ) ) {
result = allocate_cell( INTEGERTV );
struct cons_space_object *cell = &pointer2cell( result );
cell->payload.integer.value = value;
cell->payload.integer.more = more;
}
debug_print( L"make_integer: returning\n", DEBUG_ALLOC );
debug_dump_object( result, DEBUG_ALLOC );
return result;
}
/**
* @brief Supply small valued integers from the small integer cache, if available.
*
* The pattern here is intended to be that, at least within this file, instead of
* calling make_integer when an integer is required and dec_ref when it's no longer
* required, we call acquire_integer and release_integer respectively, in order to
* reduce allocation churn.
*
* In the initial implementation, acquire_integer supplies the integer from the
* small integer cache if available, else calls make_integer. Later, more
* sophisticated caching of integers which are currently in play may be enabled.
*
* @param value the value of the integer desired.
* @param more if this value is a bignum, the rest (less significant bits) of the
* value.
* @return struct cons_pointer a pointer to the integer acquired.
*/
struct cons_pointer acquire_integer( int64_t value, struct cons_pointer more ) {
struct cons_pointer result;
if ( !nilp( more ) || value < 0 || value >= SMALL_INT_LIMIT ) {
debug_print
( L"acquire_integer passing to make_integer (outside small int range)\n",
DEBUG_ALLOC );
result = make_integer( value, more );
} else {
if ( !small_int_cache_initialised ) {
for ( int64_t i = 0; i < SMALL_INT_LIMIT; i++ ) {
small_int_cache[i] = make_integer( i, NIL );
pointer2cell( small_int_cache[i] ).count = MAXREFERENCE; // lock it in so it can't be GC'd
}
small_int_cache_initialised = true;
debug_print( L"small_int_cache initialised.\n", DEBUG_ALLOC );
}
debug_printf( DEBUG_ALLOC, L"acquire_integer: returning %" PRId64 "\n",
value );
result = small_int_cache[value];
}
return result;
}
/**
* @brief if the value of p is less than the size of the small integer cache
* (and thus it was presumably supplied from there), suppress dec_ref.
*
* **NOTE THAT** at this stage it's still safe to dec_ref an arbitrary integer,
* because those in the cache are locked and can't be dec_refed.
*
* @param p a pointer, expected to be to an integer.
*/
void release_integer( struct cons_pointer p ) {
struct cons_space_object o = pointer2cell( p );
if ( !integerp( p ) || // what I've been passed isn't an integer;
!nilp( o.payload.integer.more ) || // or it's a bignum;
o.payload.integer.value >= SMALL_INT_LIMIT || // or it's bigger than the small int cache limit;
!eq( p, small_int_cache[o.payload.integer.value] ) // or it's simply not the copy in the cache...
) {
dec_ref( p );
} else {
debug_printf( DEBUG_ALLOC, L"release_integer: releasing %" PRId64 "\n",
o.payload.integer.value );
}
}
/**
* @brief Overwrite the value field of the integer indicated by `new` with
* the least significant INTEGER_BITS bits of `val`, and return the
* more significant bits (if any) right-shifted by INTEGER_BITS places.
*
* Destructive, primitive, DO NOT USE in any context except primitive
* operations on integers. The value passed as `new` MUST be constructed
* with `make_integer`, NOT acquired with `acquire_integer`.
*
* @param val the value to represent;
* @param less_significant the less significant words of this bignum, if any,
* else NIL;
* @param new a newly created integer, which will be destructively changed.
* @return carry, if any, else 0.
*/
__int128_t int128_to_integer( __int128_t val,
struct cons_pointer less_significant,
struct cons_pointer new ) {
__int128_t carry = 0;
if ( MAX_INTEGER >= val ) {
carry = 0;
} else {
carry = val % INT_CELL_BASE;
debug_printf( DEBUG_ARITH,
L"int128_to_integer: 64 bit overflow; setting carry to %ld\n",
( int64_t ) carry );
val /= INT_CELL_BASE;
}
struct cons_space_object *newc = &pointer2cell( new );
newc->payload.integer.value = ( int64_t ) val;
if ( integerp( less_significant ) ) {
struct cons_space_object *lsc = &pointer2cell( less_significant );
// inc_ref( new );
lsc->payload.integer.more = new;
}
return carry;
}
/**
* Return a pointer to an integer representing the sum of the integers
* pointed to by `a` and `b`. If either isn't an integer, will return nil.
*/
struct cons_pointer add_integers( struct cons_pointer a,
struct cons_pointer b ) {
struct cons_pointer result = NIL;
struct cons_pointer cursor = NIL;
__int128_t carry = 0;
bool is_first_cell = true;
while ( integerp( a ) || integerp( b ) || carry != 0 ) {
__int128_t av = cell_value( a, '+', is_first_cell );
__int128_t bv = cell_value( b, '+', is_first_cell );
__int128_t rv = ( av + bv ) + carry;
debug_print( L"add_integers: av = ", DEBUG_ARITH );
debug_print_128bit( av, DEBUG_ARITH );
debug_print( L"; bv = ", DEBUG_ARITH );
debug_print_128bit( bv, DEBUG_ARITH );
debug_print( L"; carry = ", DEBUG_ARITH );
debug_print_128bit( carry, DEBUG_ARITH );
debug_print( L"; rv = ", DEBUG_ARITH );
debug_print_128bit( rv, DEBUG_ARITH );
debug_print( L"\n", DEBUG_ARITH );
if ( carry == 0 && rv >= 0 && rv < SMALL_INT_LIMIT && is_first_cell ) {
result = acquire_integer( ( int64_t ) ( rv & MAX_INTEGER ), NIL );
break;
} else {
struct cons_pointer new = make_integer( 0, NIL );
carry = int128_to_integer( rv, cursor, new );
cursor = new;
if ( nilp( result ) ) {
result = cursor;
}
a = pointer2cell( a ).payload.integer.more;
b = pointer2cell( b ).payload.integer.more;
is_first_cell = false;
}
}
debug_print( L"add_integers returning: ", DEBUG_ARITH );
debug_print_object( result, DEBUG_ARITH );
debug_println( DEBUG_ARITH );
return result;
}
// TODO: I have really no idea what I was trying to do here, or why it could possibly be a good idea.
struct cons_pointer base_partial( int depth ) {
struct cons_pointer result = NIL;
debug_printf( DEBUG_ARITH, L"base_partial: depth = %d\n", depth );
for ( int i = 0; i < depth; i++ ) {
result = acquire_integer( 0, result );
}
return result;
}
/**
* @brief Return a copy of this `partial` with this `digit` appended.
*
* @param partial the more significant bits of a possible bignum.
* @param digit the less significant bits of that possible bignum. NOTE: the
* name `digit` is technically correct but possibly misleading, because the
* numbering system here is base INT_CELL_BASE, currently x0fffffffffffffffL
*/
struct cons_pointer append_cell( struct cons_pointer partial,
struct cons_pointer digit ) {
struct cons_space_object cell = pointer2cell( partial );
// TODO: I should recursively copy the whole bignum chain, because
// we're still destructively modifying the end of it.
struct cons_pointer c = make_integer( cell.payload.integer.value,
cell.payload.integer.more );
struct cons_pointer result = partial;
if ( nilp( partial ) ) {
result = digit;
} else {
// find the last digit in the chain...
while ( !nilp( pointer2cell( c ).payload.integer.more ) ) {
c = pointer2cell( c ).payload.integer.more;
}
( pointer2cell( c ) ).payload.integer.more = digit;
}
return result;
}
/**
* Return a pointer to an integer representing the product of the integers
* pointed to by `a` and `b`. If either isn't an integer, will return nil.
*
* Yes, this is one of Muhammad ibn Musa al-Khwarizmi's original recipes, so
* you'd think it would be easy; the reason that each step is documented is
* because I did not find it so.
*
* @param a an integer;
* @param b an integer.
*/
struct cons_pointer multiply_integers( struct cons_pointer a,
struct cons_pointer b ) {
struct cons_pointer result = acquire_integer( 0, NIL );
bool neg = is_negative( a ) != is_negative( b );
bool is_first_b = true;
int i = 0;
debug_print( L"multiply_integers: a = ", DEBUG_ARITH );
debug_print_object( a, DEBUG_ARITH );
debug_print( L"; b = ", DEBUG_ARITH );
debug_print_object( b, DEBUG_ARITH );
debug_println( DEBUG_ARITH );
if ( integerp( a ) && integerp( b ) ) {
/* for each digit in a, starting with the least significant (ai) */
for ( struct cons_pointer ai = a; !nilp( ai );
ai = pointer2cell( ai ).payload.integer.more ) {
/* set carry to 0 */
__int128_t carry = 0;
/* set least significant digits for result ri for this iteration
* to i zeros */
struct cons_pointer ri = base_partial( i++ );
/* for each digit in b, starting with the least significant (bj) */
for ( struct cons_pointer bj = b; !nilp( bj );
bj = pointer2cell( bj ).payload.integer.more ) {
debug_printf( DEBUG_ARITH,
L"multiply_integers: a[i] = %Ld, b[j] = %Ld, i = %d\n",
pointer2cell( ai ).payload.integer.value,
pointer2cell( bj ).payload.integer.value, i );
/* multiply ai with bj and add the carry, resulting in a
* value xj which may exceed one digit */
__int128_t xj = pointer2cell( ai ).payload.integer.value *
pointer2cell( bj ).payload.integer.value;
xj += carry;
/* if xj exceeds one digit, break it into the digit dj and
* the carry */
carry = xj >> INTEGER_BIT_SHIFT;
struct cons_pointer dj =
acquire_integer( xj & MAX_INTEGER, NIL );
replace_integer_p( ri, append_cell( ri, dj ) );
// struct cons_pointer new_ri = append_cell( ri, dj );
// release_integer( ri);
// ri = new_ri;
} /* end for bj */
/* if carry is not equal to zero, append it as a final cell
* to ri */
if ( carry != 0 ) {
replace_integer_i( ri, carry )
}
/* add ri to result */
result = add_integers( result, ri );
debug_print( L"multiply_integers: result is ", DEBUG_ARITH );
debug_print_object( result, DEBUG_ARITH );
debug_println( DEBUG_ARITH );
} /* end for ai */
}
debug_print( L"multiply_integers returning: ", DEBUG_ARITH );
debug_print_object( result, DEBUG_ARITH );
debug_println( DEBUG_ARITH );
return result;
}
/**
* don't use; private to integer_to_string, and somewhat dodgy.
*/
struct cons_pointer integer_to_string_add_digit( int digit, int digits,
struct cons_pointer tail ) {
wint_t character = btowc( hex_digits[digit] );
debug_printf( DEBUG_IO,
L"integer_to_string_add_digit: digit is %d, digits is %d; returning: ",
digit, digits );
struct cons_pointer r =
( digits % 3 == 0 ) ? make_string( L',', make_string( character,
tail ) ) :
make_string( character, tail );
debug_print_object( r, DEBUG_IO );
debug_println( DEBUG_IO );
return r;
}
/**
* @brief return a string representation of this integer, which may be a
* bignum.
*
* The general principle of printing a bignum is that you print the least
* significant digit in whatever base you're dealing with, divide through
* by the base, print the next, and carry on until you've none left.
* Obviously, that means you print from right to left. Given that we build
* strings from right to left, 'printing' an integer to a lisp string
* would seem reasonably easy. The problem is when you jump from one integer
* object to the next. 64 bit integers don't align with decimal numbers, so
* when we get to the last digit from one integer cell, we have potentially
* to be looking to the next. H'mmmm.
*
* @param int_pointer cons_pointer to the integer to print,
* @param base the base to print it in.
*/
struct cons_pointer integer_to_string( struct cons_pointer int_pointer,
int base ) {
struct cons_pointer result = NIL;
if ( integerp( int_pointer ) ) {
struct cons_pointer next =
pointer2cell( int_pointer ).payload.integer.more;
__int128_t accumulator =
llabs( pointer2cell( int_pointer ).payload.integer.value );
bool is_negative =
pointer2cell( int_pointer ).payload.integer.value < 0;
int digits = 0;
if ( accumulator == 0 && nilp( next ) ) {
result = c_string_to_lisp_string( L"0" );
} else {
while ( accumulator > 0 || !nilp( next ) ) {
if ( accumulator < MAX_INTEGER && !nilp( next ) ) {
accumulator +=
( pointer2cell( next ).payload.integer.value %
INT_CELL_BASE );
next = pointer2cell( next ).payload.integer.more;
}
int offset = ( int ) ( accumulator % base );
debug_printf( DEBUG_IO,
L"integer_to_string: digit is %ld, hexadecimal is %c, accumulator is: ",
offset, hex_digits[offset] );
debug_print_128bit( accumulator, DEBUG_IO );
debug_print( L"; result is: ", DEBUG_IO );
debug_print_object( result, DEBUG_IO );
debug_println( DEBUG_IO );
result =
integer_to_string_add_digit( offset, ++digits, result );
accumulator = accumulator / base;
}
if ( stringp( result )
&& pointer2cell( result ).payload.string.character == L',' ) {
/* if the number of digits in the string is divisible by 3, there will be
* an unwanted comma on the front. */
result = pointer2cell( result ).payload.string.cdr;
}
if ( is_negative ) {
result = make_string( L'-', result );
}
}
}
return result;
}
/**
* true if a and be are both integers whose value is the same value.
*/
bool equal_integer_integer( struct cons_pointer a, struct cons_pointer b ) {
bool result = false;
if ( integerp( a ) && integerp( b ) ) {
struct cons_space_object *cell_a = &pointer2cell( a );
struct cons_space_object *cell_b = &pointer2cell( b );
result =
cell_a->payload.integer.value == cell_b->payload.integer.value;
}
return result;
}

41
src/c/arith/integer.h Normal file
View file

@ -0,0 +1,41 @@
/*
* integer.h
*
* functions for integer cells.
*
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#ifndef __integer_h
#define __integer_h
#include <stdbool.h>
#include <stdint.h>
#include "memory/consspaceobject.h"
#define replace_integer_i(p,i) {struct cons_pointer __p = acquire_integer(i,NIL); release_integer(p); p = __p;}
#define replace_integer_p(p,q) {struct cons_pointer __p = p; release_integer( p); p = q;}
struct cons_pointer make_integer( int64_t value, struct cons_pointer more );
struct cons_pointer acquire_integer( int64_t value, struct cons_pointer more );
void release_integer( struct cons_pointer p );
struct cons_pointer add_integers( struct cons_pointer a,
struct cons_pointer b );
struct cons_pointer multiply_integers( struct cons_pointer a,
struct cons_pointer b );
struct cons_pointer integer_to_string( struct cons_pointer int_pointer,
int base );
bool equal_integer_integer( struct cons_pointer a, struct cons_pointer b );
bool equal_integer_real( struct cons_pointer a, struct cons_pointer b );
#endif

825
src/c/arith/peano.c Normal file
View file

@ -0,0 +1,825 @@
/*
* 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 <math.h>
#include <stdbool.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include "memory/consspaceobject.h"
#include "memory/conspage.h"
#include "debug.h"
#include "ops/equal.h"
#include "arith/integer.h"
#include "ops/intern.h"
#include "ops/lispops.h"
#include "arith/peano.h"
#include "io/print.h"
#include "arith/ratio.h"
#include "io/read.h"
#include "arith/real.h"
#include "memory/stack.h"
long double to_long_double( struct cons_pointer arg );
int64_t to_long_int( struct cons_pointer arg );
struct cons_pointer add_2( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer arg1,
struct cons_pointer arg2 );
/**
* return true if this `arg` points to a number whose value is zero.
*/
bool zerop( struct cons_pointer arg ) {
bool result = false;
struct cons_space_object cell = pointer2cell( arg );
switch ( cell.tag.value ) {
case INTEGERTV:{
do {
debug_print( L"zerop: ", DEBUG_ARITH );
debug_dump_object( arg, DEBUG_ARITH );
result =
( pointer2cell( arg ).payload.integer.value == 0 );
arg = pointer2cell( arg ).payload.integer.more;
} while ( result && integerp( arg ) );
}
break;
case RATIOTV:
result = zerop( cell.payload.ratio.dividend );
break;
case REALTV:
result = ( cell.payload.real.value == 0 );
break;
}
return result;
}
// TODO: think about
// bool greaterp( struct cons_pointer arg_1, struct cons_pointer arg_2) {
// bool result = false;
// struct cons_space_object * cell_1 = & pointer2cell( arg_1 );
// struct cons_space_object * cell_2 = & pointer2cell( arg_2 );
// if (cell_1->tag.value == cell_2->tag.value) {
// switch ( cell_1->tag.value ) {
// case INTEGERTV:{
// if ( nilp(cell_1->payload.integer.more) && nilp( cell_2->payload.integer.more)) {
// result = cell_1->payload.integer.value > cell_2->payload.integer.value;
// }
// // else deal with comparing bignums...
// }
// break;
// case RATIOTV:
// result = lisp_ratio_to_real( cell_1) > ratio_to_real( cell_2);
// break;
// case REALTV:
// result = ( cell.payload.real.value == 0 );
// break;
// }
// }
// return result;
// }
/**
* does this `arg` point to a negative number?
*/
bool is_negative( struct cons_pointer arg ) {
bool result = false;
struct cons_space_object cell = pointer2cell( arg );
switch ( cell.tag.value ) {
case INTEGERTV:
result = cell.payload.integer.value < 0;
break;
case RATIOTV:
result = is_negative( cell.payload.ratio.dividend );
break;
case REALTV:
result = ( cell.payload.real.value < 0 );
break;
}
return result;
}
/**
* @brief if `arg` is a number, return the absolute value of that number, else
* `NIL`
*
* @param arg a cons space object, probably a number.
* @return struct cons_pointer
*/
struct cons_pointer absolute( struct cons_pointer arg ) {
struct cons_pointer result = NIL;
struct cons_space_object cell = pointer2cell( arg );
if ( numberp( arg ) ) {
if ( is_negative( arg ) ) {
switch ( cell.tag.value ) {
case INTEGERTV:
result =
make_integer( llabs( cell.payload.integer.value ),
cell.payload.integer.more );
break;
case RATIOTV:
result =
make_ratio( absolute( cell.payload.ratio.dividend ),
cell.payload.ratio.divisor, false );
break;
case REALTV:
result = make_real( 0 - cell.payload.real.value );
break;
}
} else {
result = arg;
}
}
return result;
}
/**
* Return the closest possible `binary64` representation to the value of
* this `arg`, expected to be an integer, ratio or real, or `NAN` if `arg`
* is not any of these.
*
* @arg a pointer to an integer, ratio or real.
*
* \todo cannot throw an exception out of here, which is a problem
* if a ratio may legally have zero as a divisor, or something which is
* not a number is passed in.
*/
long double to_long_double( struct cons_pointer arg ) {
long double result = 0;
struct cons_space_object cell = pointer2cell( arg );
switch ( cell.tag.value ) {
case INTEGERTV:
// obviously, this doesn't work for bignums
result = ( long double ) cell.payload.integer.value;
// sadly, this doesn't work at all.
// result += 1.0;
// for (bool is_first = false; integerp(arg); is_first = true) {
// debug_printf(DEBUG_ARITH, L"to_long_double: accumulator = %lf, arg = ", result);
// debug_dump_object(arg, DEBUG_ARITH);
// if (!is_first) {
// result *= (long double)(MAX_INTEGER + 1);
// }
// result *= (long double)(cell.payload.integer.value);
// arg = cell.payload.integer.more;
// cell = pointer2cell( arg );
// }
break;
case RATIOTV:
result = to_long_double( cell.payload.ratio.dividend ) /
to_long_double( cell.payload.ratio.divisor );
break;
case REALTV:
result = cell.payload.real.value;
break;
default:
result = NAN;
break;
}
debug_print( L"to_long_double( ", DEBUG_ARITH );
debug_print_object( arg, DEBUG_ARITH );
debug_printf( DEBUG_ARITH, L") => %lf\n", result );
return result;
}
/**
* Return the closest possible `int64_t` representation to the value of
* this `arg`, expected to be an integer, ratio or real, or `NAN` if `arg`
* is not any of these.
*
* @arg a pointer to an integer, ratio or real.
*
* \todo cannot throw an exception out of here, which is a problem
* if a ratio may legally have zero as a divisor, or something which is
* not a number (or is a big number) is passed in.
*/
int64_t to_long_int( struct cons_pointer arg ) {
int64_t result = 0;
struct cons_space_object cell = pointer2cell( arg );
switch ( cell.tag.value ) {
case INTEGERTV:
/* \todo if (integerp(cell.payload.integer.more)) {
* throw an exception!
* } */
result = cell.payload.integer.value;
break;
case RATIOTV:
result = lroundl( to_long_double( arg ) );
break;
case REALTV:
result = lroundl( cell.payload.real.value );
break;
}
return result;
}
/**
* Function: calculate the absolute value of a number.
*
* (absolute arg)
*
* @param env the evaluation environment - ignored;
* @param frame the stack frame.
* @return the absolute value of the number represented by the first
* argument, or NIL if it was not a number.
*/
struct cons_pointer lisp_absolute( struct stack_frame
*frame, struct cons_pointer frame_pointer, struct
cons_pointer env ) {
return absolute( frame->arg[0] );
}
/**
* return a cons_pointer indicating a number which is the sum of
* the numbers indicated by `arg1` and `arg2`.
*/
struct cons_pointer add_2( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer arg1,
struct cons_pointer arg2 ) {
struct cons_pointer result;
struct cons_space_object cell1 = pointer2cell( arg1 );
struct cons_space_object cell2 = pointer2cell( arg2 );
debug_print( L"add_2( arg1 = ", DEBUG_ARITH );
debug_dump_object( arg1, DEBUG_ARITH );
debug_print( L"; arg2 = ", DEBUG_ARITH );
debug_dump_object( arg2, DEBUG_ARITH );
debug_print( L"\n", DEBUG_ARITH );
if ( zerop( arg1 ) ) {
result = arg2;
} else if ( zerop( arg2 ) ) {
result = arg1;
} else {
switch ( cell1.tag.value ) {
case EXCEPTIONTV:
result = arg1;
break;
case INTEGERTV:
switch ( cell2.tag.value ) {
case EXCEPTIONTV:
result = arg2;
break;
case INTEGERTV:
result = add_integers( arg1, arg2 );
break;
case RATIOTV:
result = add_integer_ratio( arg1, arg2 );
break;
case REALTV:
result =
make_real( to_long_double( arg1 ) +
to_long_double( arg2 ) );
break;
default:
result =
throw_exception( c_string_to_lisp_symbol( L"+" ),
c_string_to_lisp_string
( L"Cannot add: not a number" ),
frame_pointer );
break;
}
break;
case RATIOTV:
switch ( cell2.tag.value ) {
case EXCEPTIONTV:
result = arg2;
break;
case INTEGERTV:
result = add_integer_ratio( arg2, arg1 );
break;
case RATIOTV:
result = add_ratio_ratio( arg1, arg2 );
break;
case REALTV:
result =
make_real( to_long_double( arg1 ) +
to_long_double( arg2 ) );
break;
default:
result =
throw_exception( c_string_to_lisp_symbol( L"+" ),
c_string_to_lisp_string
( L"Cannot add: not a number" ),
frame_pointer );
break;
}
break;
case REALTV:
result =
make_real( to_long_double( arg1 ) +
to_long_double( arg2 ) );
break;
default:
result = exceptionp( arg2 ) ? arg2 :
throw_exception( c_string_to_lisp_symbol( L"+" ),
c_string_to_lisp_string
( L"Cannot add: not a number" ),
frame_pointer );
}
}
debug_print( L"}; => ", DEBUG_ARITH );
debug_print_object( arg2, DEBUG_ARITH );
debug_print( L"\n", DEBUG_ARITH );
return result;
}
/**
* Add an indefinite number of numbers together
* @param env the evaluation environment - ignored;
* @param frame the stack frame.
* @return a pointer to an integer, ratio or real.
* @exception if any argument is not a number, returns an exception.
*/
struct cons_pointer lisp_add( struct stack_frame
*frame, struct cons_pointer frame_pointer, struct
cons_pointer env ) {
struct cons_pointer result = make_integer( 0, NIL );
struct cons_pointer tmp;
for ( int i = 0;
i < args_in_frame &&
!nilp( frame->arg[i] ) && !exceptionp( result ); i++ ) {
tmp = result;
result = add_2( frame, frame_pointer, result, frame->arg[i] );
if ( !eq( tmp, result ) ) {
dec_ref( tmp );
}
}
struct cons_pointer more = frame->more;
while ( consp( more ) && !exceptionp( result ) ) {
tmp = result;
result = add_2( frame, frame_pointer, result, c_car( more ) );
if ( !eq( tmp, result ) ) {
dec_ref( tmp );
}
more = c_cdr( more );
}
return result;
}
/**
* return a cons_pointer indicating a number which is the product of
* the numbers indicated by `arg1` and `arg2`.
*/
struct cons_pointer multiply_2( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer arg1,
struct cons_pointer arg2 ) {
struct cons_pointer result;
struct cons_space_object cell1 = pointer2cell( arg1 );
struct cons_space_object cell2 = pointer2cell( arg2 );
debug_print( L"multiply_2( arg1 = ", DEBUG_ARITH );
debug_print_object( arg1, DEBUG_ARITH );
debug_print( L"; arg2 = ", DEBUG_ARITH );
debug_print_object( arg2, DEBUG_ARITH );
debug_print( L")\n", DEBUG_ARITH );
if ( zerop( arg1 ) ) {
result = arg2;
} else if ( zerop( arg2 ) ) {
result = arg1;
} else {
switch ( cell1.tag.value ) {
case EXCEPTIONTV:
result = arg1;
break;
case INTEGERTV:
switch ( cell2.tag.value ) {
case EXCEPTIONTV:
result = arg2;
break;
case INTEGERTV:
result = multiply_integers( arg1, arg2 );
break;
case RATIOTV:
result = multiply_integer_ratio( arg1, arg2 );
break;
case REALTV:
result =
make_real( to_long_double( arg1 ) *
to_long_double( arg2 ) );
break;
default:
result =
throw_exception( c_string_to_lisp_symbol( L"*" ),
make_cons
( c_string_to_lisp_string
( L"Cannot multiply: argument 2 is not a number: " ),
c_type( arg2 ) ),
frame_pointer );
break;
}
break;
case RATIOTV:
switch ( cell2.tag.value ) {
case EXCEPTIONTV:
result = arg2;
break;
case INTEGERTV:
result = multiply_integer_ratio( arg2, arg1 );
break;
case RATIOTV:
result = multiply_ratio_ratio( arg1, arg2 );
break;
case REALTV:
result =
make_real( to_long_double( arg1 ) *
to_long_double( arg2 ) );
break;
default:
result =
throw_exception( c_string_to_lisp_symbol( L"*" ),
make_cons
( c_string_to_lisp_string
( L"Cannot multiply: argument 2 is not a number" ),
c_type( arg2 ) ),
frame_pointer );
}
break;
case REALTV:
result = exceptionp( arg2 ) ? arg2 :
make_real( to_long_double( arg1 ) *
to_long_double( arg2 ) );
break;
default:
result = throw_exception( c_string_to_lisp_symbol( L"*" ),
make_cons( c_string_to_lisp_string
( L"Cannot multiply: argument 1 is not a number" ),
c_type( arg1 ) ),
frame_pointer );
break;
}
}
debug_print( L"multiply_2 returning: ", DEBUG_ARITH );
debug_print_object( result, DEBUG_ARITH );
debug_print( L"\n", DEBUG_ARITH );
return result;
}
#define multiply_one_arg(arg) {if (exceptionp(arg)){result=arg;}else{tmp = result; result = multiply_2( frame, frame_pointer, result, arg ); if ( !eq( tmp, result ) ) dec_ref( tmp );}}
/**
* Multiply an indefinite number of numbers together
* @param env the evaluation environment - ignored;
* @param frame the stack frame.
* @return a pointer to an integer, ratio or real.
* @exception if any argument is not a number, returns an exception.
*/
struct cons_pointer lisp_multiply( struct
stack_frame
*frame, struct cons_pointer frame_pointer, struct
cons_pointer env ) {
struct cons_pointer result = make_integer( 1, NIL );
struct cons_pointer tmp;
for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] )
&& !exceptionp( result ); i++ ) {
debug_print( L"lisp_multiply: accumulator = ", DEBUG_ARITH );
debug_print_object( result, DEBUG_ARITH );
debug_print( L"; arg = ", DEBUG_ARITH );
debug_print_object( frame->arg[i], DEBUG_ARITH );
debug_println( DEBUG_ARITH );
multiply_one_arg( frame->arg[i] );
}
struct cons_pointer more = frame->more;
while ( consp( more )
&& !exceptionp( result ) ) {
multiply_one_arg( c_car( more ) );
more = c_cdr( more );
}
debug_print( L"lisp_multiply returning: ", DEBUG_ARITH );
debug_print_object( result, DEBUG_ARITH );
debug_println( DEBUG_ARITH );
return result;
}
/**
* return a cons_pointer indicating a number which is the
* 0 - the number indicated by `arg`.
*/
struct cons_pointer negative( struct cons_pointer arg ) {
struct cons_pointer result = NIL;
struct cons_space_object cell = pointer2cell( arg );
switch ( cell.tag.value ) {
case EXCEPTIONTV:
result = arg;
break;
case INTEGERTV:
result =
make_integer( 0 - cell.payload.integer.value,
cell.payload.integer.more );
break;
case NILTV:
result = TRUE;
break;
case RATIOTV:
result = make_ratio( negative( cell.payload.ratio.dividend ),
cell.payload.ratio.divisor, false );
break;
case REALTV:
result = make_real( 0 - to_long_double( arg ) );
break;
case TRUETV:
result = NIL;
break;
}
return result;
}
/**
* Function: is this number negative?
*
* * (negative? arg)
*
* @param env the evaluation environment - ignored;
* @param frame the stack frame.
* @return T if the first argument was a negative number, or NIL if it
* was not.
*/
struct cons_pointer lisp_is_negative( struct stack_frame
*frame,
struct cons_pointer frame_pointer, struct
cons_pointer env ) {
return is_negative( frame->arg[0] ) ? TRUE : NIL;
}
/**
* return a cons_pointer indicating a number which is the result of
* subtracting the number indicated by `arg2` from that indicated by `arg1`,
* in the context of this `frame`.
*/
struct cons_pointer subtract_2( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer arg1,
struct cons_pointer arg2 ) {
struct cons_pointer result = NIL;
switch ( pointer2cell( arg1 ).tag.value ) {
case EXCEPTIONTV:
result = arg1;
break;
case INTEGERTV:
switch ( pointer2cell( arg2 ).tag.value ) {
case EXCEPTIONTV:
result = arg2;
break;
case INTEGERTV:{
struct cons_pointer i = negative( arg2 );
inc_ref( i );
result = add_integers( arg1, i );
dec_ref( i );
}
break;
case RATIOTV:{
struct cons_pointer tmp = make_ratio( arg1,
make_integer( 1,
NIL ),
false );
inc_ref( tmp );
result = subtract_ratio_ratio( tmp, arg2 );
dec_ref( tmp );
}
break;
case REALTV:
result =
make_real( to_long_double( arg1 ) -
to_long_double( arg2 ) );
break;
default:
result = throw_exception( c_string_to_lisp_symbol( L"-" ),
c_string_to_lisp_string
( L"Cannot subtract: not a number" ),
frame_pointer );
break;
}
break;
case RATIOTV:
switch ( pointer2cell( arg2 ).tag.value ) {
case EXCEPTIONTV:
result = arg2;
break;
case INTEGERTV:{
struct cons_pointer tmp = make_ratio( arg2,
make_integer( 1,
NIL ),
false );
inc_ref( tmp );
result = subtract_ratio_ratio( arg1, tmp );
dec_ref( tmp );
}
break;
case RATIOTV:
result = subtract_ratio_ratio( arg1, arg2 );
break;
case REALTV:
result =
make_real( to_long_double( arg1 ) -
to_long_double( arg2 ) );
break;
default:
result = throw_exception( c_string_to_lisp_symbol( L"-" ),
c_string_to_lisp_string
( L"Cannot subtract: not a number" ),
frame_pointer );
break;
}
break;
case REALTV:
result = exceptionp( arg2 ) ? arg2 :
make_real( to_long_double( arg1 ) - to_long_double( arg2 ) );
break;
default:
result = throw_exception( c_string_to_lisp_symbol( L"-" ),
c_string_to_lisp_string
( L"Cannot subtract: not a number" ),
frame_pointer );
break;
}
// and if not nilp[frame->arg[2]) we also have an error.
return result;
}
/**
* Subtract one number from another. If more than two arguments are passed
* in the frame, the additional arguments are ignored.
* @param env the evaluation environment - ignored;
* @param frame the stack frame.
* @return a pointer to an integer, ratio or real.
* @exception if either argument is not a number, returns an exception.
*/
struct cons_pointer lisp_subtract( struct
stack_frame
*frame, struct cons_pointer frame_pointer, struct
cons_pointer env ) {
return subtract_2( frame, frame_pointer, frame->arg[0], frame->arg[1] );
}
/**
* Divide one number by another. If more than two arguments are passed
* in the frame, the additional arguments are ignored.
* @param env the evaluation environment - ignored;
* @param frame the stack frame.
* @return a pointer to an integer or real.
* @exception if either argument is not a number, returns an exception.
*/
struct cons_pointer lisp_divide( struct
stack_frame
*frame, struct cons_pointer frame_pointer, struct
cons_pointer env ) {
struct cons_pointer result = NIL;
struct cons_space_object arg0 = pointer2cell( frame->arg[0] );
struct cons_space_object arg1 = pointer2cell( frame->arg[1] );
switch ( arg0.tag.value ) {
case EXCEPTIONTV:
result = frame->arg[0];
break;
case INTEGERTV:
switch ( arg1.tag.value ) {
case EXCEPTIONTV:
result = frame->arg[1];
break;
case INTEGERTV:{
result =
make_ratio( frame->arg[0], frame->arg[1], true );
}
break;
case RATIOTV:{
struct cons_pointer one = make_integer( 1, NIL );
struct cons_pointer ratio =
make_ratio( frame->arg[0], one, false );
inc_ref( ratio );
result = divide_ratio_ratio( ratio, frame->arg[1] );
dec_ref( ratio );
}
break;
case REALTV:
result =
make_real( to_long_double( frame->arg[0] ) /
to_long_double( frame->arg[1] ) );
break;
default:
result = throw_exception( c_string_to_lisp_symbol( L"/" ),
c_string_to_lisp_string
( L"Cannot divide: not a number" ),
frame_pointer );
break;
}
break;
case RATIOTV:
switch ( arg1.tag.value ) {
case EXCEPTIONTV:
result = frame->arg[1];
break;
case INTEGERTV:{
struct cons_pointer one = make_integer( 1, NIL );
struct cons_pointer ratio =
make_ratio( frame->arg[1], one, false );
result = divide_ratio_ratio( frame->arg[0], ratio );
dec_ref( ratio );
dec_ref( one );
}
break;
case RATIOTV:
result =
divide_ratio_ratio( frame->arg[0], frame->arg[1] );
break;
case REALTV:
result =
make_real( to_long_double( frame->arg[0] ) /
to_long_double( frame->arg[1] ) );
break;
default:
result = throw_exception( c_string_to_lisp_symbol( L"/" ),
c_string_to_lisp_string
( L"Cannot divide: not a number" ),
frame_pointer );
break;
}
break;
case REALTV:
result = exceptionp( frame->arg[1] ) ? frame->arg[1] :
make_real( to_long_double( frame->arg[0] ) /
to_long_double( frame->arg[1] ) );
break;
default:
result = throw_exception( c_string_to_lisp_symbol( L"/" ),
c_string_to_lisp_string
( L"Cannot divide: not a number" ),
frame_pointer );
break;
}
return result;
}
/**
* @brief Function: return a real (approcimately) equal in value to the ratio
* which is the first argument.
*
* @param frame
* @param frame_pointer
* @param env
* @return struct cons_pointer a pointer to a real
*/
// struct cons_pointer lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer,
// struct cons_pointer env )
struct cons_pointer lisp_ratio_to_real( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ) {
struct cons_pointer result = NIL;
struct cons_pointer rat = frame->arg[0];
debug_print( L"\nc_ratio_to_ld: ", DEBUG_ARITH );
debug_print_object( rat, DEBUG_ARITH );
if ( ratiop( rat ) ) {
result = make_real( c_ratio_to_ld( rat ) );
} // TODO: else throw an exception?
return result;
}

95
src/c/arith/peano.h Normal file
View file

@ -0,0 +1,95 @@
/*
* peano.h
*
* Basic peano arithmetic
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#ifndef PEANO_H
#define PEANO_H
#include "memory/consspaceobject.h"
/**
* The maximum value we will allow in an integer cell: one less than 2^60:
* (let ((s (make-string-output-stream)))
* (format s "0x0~XL" (- (expt 2 60) 1))
* (string-downcase (get-output-stream-string s)))
* "0x0fffffffffffffffl"
*
* So left shifting and right shifting by 60 bits is correct.
*/
#define MAX_INTEGER ((__int128_t)0x0fffffffffffffffL)
#define INT_CELL_BASE ((__int128_t)MAX_INTEGER + 1) // ((__int128_t)0x1000000000000000L)
/**
* @brief Number of value bits in an integer cell
*
*/
#define INTEGER_BIT_SHIFT (60)
/**
* @brief return `true` if arg is `nil`, else `false`.
*
* Note that this doesn't really belong in `peano.h`, but after code cleanup it
* was the last thing remaining in either `boolean.c` or `boolean.h`, and it
* wasn't worth keeping two files around for one one-line macro.
*
* @param arg
* @return true if the sole argument is `nil`.
* @return false otherwise.
*/
#define truthy(arg)(!nilp(arg))
bool zerop( struct cons_pointer arg );
struct cons_pointer negative( struct cons_pointer arg );
bool is_negative( struct cons_pointer arg );
struct cons_pointer absolute( struct cons_pointer arg );
long double to_long_double( struct cons_pointer arg );
int64_t to_long_int( struct cons_pointer arg );
struct cons_pointer lisp_absolute( struct stack_frame
*frame, struct cons_pointer frame_pointer, struct
cons_pointer env );
struct cons_pointer
lisp_add( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_is_negative( struct stack_frame
*frame,
struct cons_pointer frame_pointer, struct
cons_pointer env );
struct cons_pointer
lisp_multiply( struct stack_frame *frame,
struct cons_pointer frame_pointer, struct cons_pointer env );
struct cons_pointer negative( struct cons_pointer arg );
struct cons_pointer subtract_2( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer arg1,
struct cons_pointer arg2 );
struct cons_pointer
lisp_subtract( struct stack_frame *frame,
struct cons_pointer frame_pointer, struct cons_pointer env );
struct cons_pointer
lisp_divide( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_ratio_to_real( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
#endif /* PEANO_H */

411
src/c/arith/ratio.c Normal file
View file

@ -0,0 +1,411 @@
/*
* ratio.c
*
* functions for rational number cells.
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#define _GNU_SOURCE
#include <math.h>
#include <stdio.h>
#include "arith/integer.h"
#include "arith/peano.h"
#include "arith/ratio.h"
#include "arith/real.h"
#include "debug.h"
#include "io/print.h"
#include "memory/conspage.h"
#include "memory/consspaceobject.h"
#include "memory/stack.h"
#include "ops/equal.h"
#include "ops/lispops.h"
/**
* @brief return, as an int64_t, the greatest common divisor of `m` and `n`,
*/
int64_t greatest_common_divisor( int64_t m, int64_t n ) {
int o;
while ( m ) {
o = m;
m = n % m;
n = o;
}
return o;
}
/**
* @brief return, as an int64_t, the least common multiple of `m` and `n`,
*/
int64_t least_common_multiple( int64_t m, int64_t n ) {
return m / greatest_common_divisor( m, n ) * n;
}
struct cons_pointer simplify_ratio( struct cons_pointer pointer ) {
struct cons_pointer result = pointer;
if ( ratiop( pointer ) ) {
struct cons_space_object cell = pointer2cell( pointer );
struct cons_space_object dividend =
pointer2cell( cell.payload.ratio.dividend );
struct cons_space_object divisor =
pointer2cell( cell.payload.ratio.divisor );
if ( divisor.payload.integer.value == 1 ) {
result = pointer2cell( pointer ).payload.ratio.dividend;
} else {
int64_t ddrv = dividend.payload.integer.value,
drrv = divisor.payload.integer.value,
gcd = greatest_common_divisor( ddrv, drrv );
if ( gcd > 1 ) {
if ( drrv / gcd == 1 ) {
result =
acquire_integer( ( int64_t ) ( ddrv / gcd ), NIL );
} else {
debug_printf( DEBUG_ARITH,
L"simplify_ratio: %ld/%ld => %ld/%ld\n",
ddrv, drrv, ddrv / gcd, drrv / gcd );
result =
make_ratio( acquire_integer( ddrv / gcd, NIL ),
acquire_integer( drrv / gcd, NIL ),
false );
}
}
}
}
// TODO: else throw exception?
return result;
}
/**
* return a cons_pointer indicating a number which is the sum of
* the ratios indicated by `arg1` and `arg2`.
* @exception will return an exception if either `arg1` or `arg2` is not a
* rational number.
*/
struct cons_pointer add_ratio_ratio( struct cons_pointer arg1,
struct cons_pointer arg2 ) {
struct cons_pointer r;
debug_print( L"\nadd_ratio_ratio: ", DEBUG_ARITH );
debug_print_object( arg1, DEBUG_ARITH );
debug_print( L" + ", DEBUG_ARITH );
debug_print_object( arg2, DEBUG_ARITH );
if ( ratiop( arg1 ) && ratiop( arg2 ) ) {
struct cons_space_object *cell1 = &pointer2cell( arg1 );
struct cons_space_object *cell2 = &pointer2cell( arg2 );
struct cons_pointer divisor =
multiply_integers( cell1->payload.ratio.divisor,
cell2->payload.ratio.divisor );
struct cons_pointer dividend =
add_integers( multiply_integers( cell1->payload.ratio.dividend,
cell2->payload.ratio.divisor ),
multiply_integers( cell2->payload.ratio.dividend,
cell1->payload.ratio.divisor ) );
r = make_ratio( dividend, divisor, true );
} else {
r = throw_exception( c_string_to_lisp_symbol( L"+" ),
make_cons( c_string_to_lisp_string
( L"Shouldn't happen: bad arg to add_ratio_ratio" ),
make_cons( arg1,
make_cons( arg2, NIL ) ) ),
NIL );
}
debug_print( L"add_ratio_ratio => ", DEBUG_ARITH );
debug_print_object( r, DEBUG_ARITH );
debug_print( L"\n", DEBUG_ARITH );
return r;
}
/**
* return a cons_pointer indicating a number which is the sum of
* the intger indicated by `intarg` and the ratio indicated by
* `ratarg`.
* @exception if either `intarg` or `ratarg` is not of the expected type.
*/
struct cons_pointer add_integer_ratio( struct cons_pointer intarg,
struct cons_pointer ratarg ) {
struct cons_pointer result;
debug_print( L"\nadd_integer_ratio: ", DEBUG_ARITH );
debug_print_object( intarg, DEBUG_ARITH );
debug_print( L" + ", DEBUG_ARITH );
debug_print_object( ratarg, DEBUG_ARITH );
if ( integerp( intarg ) && ratiop( ratarg ) ) {
struct cons_pointer one = acquire_integer( 1, NIL ),
ratio = make_ratio( intarg, one, false );
result = add_ratio_ratio( ratio, ratarg );
release_integer( one );
dec_ref( ratio );
} else {
result =
throw_exception( c_string_to_lisp_symbol( L"+" ),
make_cons( c_string_to_lisp_string
( L"Shouldn't happen: bad arg to add_integer_ratio" ),
make_cons( intarg,
make_cons( ratarg,
NIL ) ) ), NIL );
}
debug_print( L" => ", DEBUG_ARITH );
debug_print_object( result, DEBUG_ARITH );
debug_print( L"\n", DEBUG_ARITH );
return result;
}
/**
* return a cons_pointer to a ratio which represents the value of the ratio
* indicated by `arg1` divided by the ratio indicated by `arg2`.
* @exception will return an exception if either `arg1` or `arg2` is not a
* rational number.
*/
struct cons_pointer divide_ratio_ratio( struct cons_pointer arg1,
struct cons_pointer arg2 ) {
debug_print( L"\ndivide_ratio_ratio: ", DEBUG_ARITH );
debug_print_object( arg1, DEBUG_ARITH );
debug_print( L" / ", DEBUG_ARITH );
debug_print_object( arg2, DEBUG_ARITH );
// TODO: this now has to work if `arg1` is an integer
struct cons_pointer i =
make_ratio( pointer2cell( arg2 ).payload.ratio.divisor,
pointer2cell( arg2 ).payload.ratio.dividend, false ),
result = multiply_ratio_ratio( arg1, i );
dec_ref( i );
debug_print( L" => ", DEBUG_ARITH );
debug_print_object( result, DEBUG_ARITH );
debug_print( L"\n", DEBUG_ARITH );
return result;
}
/**
* return a cons_pointer indicating a number which is the product of
* the ratios indicated by `arg1` and `arg2`.
* @exception will return an exception if either `arg1` or `arg2` is not a
* rational number.
*/
struct cons_pointer multiply_ratio_ratio( struct
cons_pointer arg1, struct
cons_pointer arg2 ) {
// TODO: this now has to work if arg1 is an integer
struct cons_pointer result;
debug_print( L"multiply_ratio_ratio( arg1 = ", DEBUG_ARITH );
debug_print_object( arg1, DEBUG_ARITH );
debug_print( L"; arg2 = ", DEBUG_ARITH );
debug_print_object( arg2, DEBUG_ARITH );
debug_print( L")\n", DEBUG_ARITH );
if ( ratiop( arg1 ) && ratiop( arg2 ) ) {
struct cons_space_object cell1 = pointer2cell( arg1 );
struct cons_space_object cell2 = pointer2cell( arg2 );
int64_t dd1v =
pointer2cell( cell1.payload.ratio.dividend ).payload.integer.value,
dd2v =
pointer2cell( cell2.payload.ratio.dividend ).payload.integer.value,
dr1v =
pointer2cell( cell1.payload.ratio.divisor ).payload.integer.value,
dr2v =
pointer2cell( cell2.payload.ratio.divisor ).payload.integer.value,
ddrv = dd1v * dd2v, drrv = dr1v * dr2v;
struct cons_pointer dividend = acquire_integer( ddrv, NIL );
struct cons_pointer divisor = acquire_integer( drrv, NIL );
result = make_ratio( dividend, divisor, true );
release_integer( dividend );
release_integer( divisor );
} else {
result =
throw_exception( c_string_to_lisp_symbol( L"*" ),
c_string_to_lisp_string
( L"Shouldn't happen: bad arg to multiply_ratio_ratio" ),
NIL );
}
debug_print( L" => ", DEBUG_ARITH );
debug_print_object( result, DEBUG_ARITH );
debug_print( L"\n", DEBUG_ARITH );
return result;
}
/**
* return a cons_pointer indicating a number which is the product of
* the intger indicated by `intarg` and the ratio indicated by
* `ratarg`.
* @exception if either `intarg` or `ratarg` is not of the expected type.
*/
struct cons_pointer multiply_integer_ratio( struct cons_pointer intarg,
struct cons_pointer ratarg ) {
struct cons_pointer result;
debug_print( L"\nmultiply_integer_ratio: ", DEBUG_ARITH );
debug_print_object( intarg, DEBUG_ARITH );
debug_print( L" * ", DEBUG_ARITH );
debug_print_object( ratarg, DEBUG_ARITH );
if ( integerp( intarg ) && ratiop( ratarg ) ) {
struct cons_pointer one = acquire_integer( 1, NIL ),
ratio = make_ratio( intarg, one, false );
result = multiply_ratio_ratio( ratio, ratarg );
release_integer( one );
} else {
result =
throw_exception( c_string_to_lisp_symbol( L"*" ),
c_string_to_lisp_string
( L"Shouldn't happen: bad arg to multiply_integer_ratio" ),
NIL );
}
debug_print( L" => ", DEBUG_ARITH );
debug_print_object( result, DEBUG_ARITH );
debug_print( L"\n", DEBUG_ARITH );
return result;
}
/**
* return a cons_pointer indicating a number which is the difference of
* the ratios indicated by `arg1` and `arg2`.
* @exception will return an exception if either `arg1` or `arg2` is not a
* rational number.
*/
struct cons_pointer subtract_ratio_ratio( struct cons_pointer arg1,
struct cons_pointer arg2 ) {
debug_print( L"\nsubtract_ratio_ratio: ", DEBUG_ARITH );
debug_print_object( arg1, DEBUG_ARITH );
debug_print( L" * ", DEBUG_ARITH );
debug_print_object( arg2, DEBUG_ARITH );
struct cons_pointer i = negative( arg2 ),
result = add_ratio_ratio( arg1, i );
dec_ref( i );
return result;
}
/**
* Construct a ratio frame from this `dividend` and `divisor`, expected to
* be integers, in the context of the stack_frame indicated by this
* `frame_pointer`.
* @exception if either `dividend` or `divisor` is not an integer.
*/
struct cons_pointer make_ratio( struct cons_pointer dividend,
struct cons_pointer divisor, bool simplify ) {
debug_print( L"make_ratio: dividend = ", DEBUG_ALLOC );
debug_print_object( dividend, DEBUG_ALLOC );
debug_print( L"; divisor = ", DEBUG_ALLOC );
debug_print_object( divisor, DEBUG_ALLOC );
debug_printf( DEBUG_ALLOC, L"; simplify = %d\n", simplify );
struct cons_pointer result;
if ( integerp( dividend ) && integerp( divisor ) ) {
inc_ref( dividend );
inc_ref( divisor );
struct cons_pointer unsimplified = allocate_cell( RATIOTV );
struct cons_space_object *cell = &pointer2cell( unsimplified );
cell->payload.ratio.dividend = dividend;
cell->payload.ratio.divisor = divisor;
if ( simplify ) {
result = simplify_ratio( unsimplified );
if ( !eq( result, unsimplified ) ) {
dec_ref( unsimplified );
}
} else {
result = unsimplified;
}
} else {
result =
throw_exception( c_string_to_lisp_symbol( L"make_ratio" ),
c_string_to_lisp_string
( L"Dividend and divisor of a ratio must be integers" ),
NIL );
}
debug_print( L" => ", DEBUG_ALLOC );
debug_print_object( result, DEBUG_ALLOC );
debug_println( DEBUG_ALLOC );
return result;
}
/**
* True if a and be are identical rationals, else false.
*
* TODO: we need ways of checking whether rationals are equal
* to floats and to integers.
*/
bool equal_ratio_ratio( struct cons_pointer a, struct cons_pointer b ) {
bool result = false;
if ( ratiop( a ) && ratiop( b ) ) {
struct cons_space_object *cell_a = &pointer2cell( a );
struct cons_space_object *cell_b = &pointer2cell( b );
result = equal_integer_integer( cell_a->payload.ratio.dividend,
cell_b->payload.ratio.dividend ) &&
equal_integer_integer( cell_a->payload.ratio.divisor,
cell_b->payload.ratio.divisor );
}
return result;
}
/**
* @brief convert a ratio to an equivalent long double.
*
* @param rat a pointer to a ratio.
* @return long double
*/
long double c_ratio_to_ld( struct cons_pointer rat ) {
long double result = NAN;
debug_print( L"\nc_ratio_to_ld: ", DEBUG_ARITH );
debug_print_object( rat, DEBUG_ARITH );
if ( ratiop( rat ) ) {
struct cons_space_object *cell_a = &pointer2cell( rat );
struct cons_pointer dv = cell_a->payload.ratio.divisor;
struct cons_space_object *dv_cell = &pointer2cell( dv );
struct cons_pointer dd = cell_a->payload.ratio.dividend;
struct cons_space_object *dd_cell = &pointer2cell( dd );
if ( nilp( dv_cell->payload.integer.more )
&& nilp( dd_cell->payload.integer.more ) ) {
result =
( ( long double ) dd_cell->payload.integer.value ) /
( ( long double ) dv_cell->payload.integer.value );;
} else {
fwprintf( stderr,
L"real conversion is not yet implemented for bignums rationals." );
}
}
debug_printf( DEBUG_ARITH, L"\nc_ratio_to_ld returning %d\n", result );
return result;
}

41
src/c/arith/ratio.h Normal file
View file

@ -0,0 +1,41 @@
/**
* ratio.h
*
* functions for rational number cells.
*
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#ifndef __ratio_h
#define __ratio_h
struct cons_pointer simplify_ratio( struct cons_pointer arg );
struct cons_pointer add_ratio_ratio( struct cons_pointer arg1,
struct cons_pointer arg2 );
struct cons_pointer add_integer_ratio( struct cons_pointer intarg,
struct cons_pointer ratarg );
struct cons_pointer divide_ratio_ratio( struct cons_pointer arg1,
struct cons_pointer arg2 );
struct cons_pointer multiply_ratio_ratio( struct cons_pointer arg1, struct
cons_pointer arg2 );
struct cons_pointer multiply_integer_ratio( struct cons_pointer intarg,
struct cons_pointer ratarg );
struct cons_pointer subtract_ratio_ratio( struct cons_pointer arg1,
struct cons_pointer arg2 );
struct cons_pointer make_ratio( struct cons_pointer dividend,
struct cons_pointer divisor, bool simplify );
bool equal_ratio_ratio( struct cons_pointer a, struct cons_pointer b );
long double c_ratio_to_ld( struct cons_pointer rat );
#endif

29
src/c/arith/real.c Normal file
View file

@ -0,0 +1,29 @@
/*
* real.c
*
* functions for real number cells.
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include "memory/conspage.h"
#include "memory/consspaceobject.h"
#include "debug.h"
#include "io/read.h"
/**
* Allocate a real number cell representing this value and return a cons
* pointer to it.
* @param value the value to wrap;
* @return a real number cell wrapping this value.
*/
struct cons_pointer make_real( long double value ) {
struct cons_pointer result = allocate_cell( REALTV );
struct cons_space_object *cell = &pointer2cell( result );
cell->payload.real.value = value;
debug_dump_object( result, DEBUG_ARITH );
return result;
}

32
src/c/arith/real.h Normal file
View file

@ -0,0 +1,32 @@
/*
* To change this license header, choose License Headers in Project Properties.
* To change this template file, choose Tools | Templates
* and open the template in the editor.
*/
/*
* File: real.h
* Author: simon
*
* Created on 14 August 2017, 17:25
*/
#ifndef REAL_H
#define REAL_H
#ifdef __cplusplus
extern "C" {
#endif
/**
* Allocate a real number cell representing this value and return a cons
* pointer to it.
* @param value the value to wrap;
* @return a real number cell wrapping this value.
*/
struct cons_pointer make_real( long double value );
#ifdef __cplusplus
}
#endif
#endif /* REAL_H */

24
src/c/authorise.c Normal file
View file

@ -0,0 +1,24 @@
/*
* authorised.c
*
* For now, a dummy authorising everything.
*
* (c) 2021 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include "memory/conspage.h"
#include "memory/consspaceobject.h"
/**
* TODO: does nothing, yet. What it should do is access a magic value in the
* runtime environment and check that it is identical to something on this `acl`
*/
struct cons_pointer authorised( struct cons_pointer target,
struct cons_pointer acl ) {
if ( nilp( acl ) ) {
acl = pointer2cell( target ).access;
}
return TRUE;
}

16
src/c/authorise.h Normal file
View file

@ -0,0 +1,16 @@
/*
* authorise.h
*
* Basic implementation of a authorisation.
*
* (c) 2021 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#ifndef __psse_authorise_h
#define __psse_authorise_h
struct cons_pointer authorised( struct cons_pointer target,
struct cons_pointer acl );
#endif

181
src/c/debug.c Normal file
View file

@ -0,0 +1,181 @@
/*
* debug.c
*
* Better debug log messages.
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <ctype.h>
#include <stdarg.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
/*
* wide characters
*/
#include <wchar.h>
#include <wctype.h>
#include "memory/consspaceobject.h"
#include "debug.h"
#include "memory/dump.h"
#include "io/io.h"
#include "io/print.h"
/**
* @brief the controlling flags for `debug_print`; set in `init.c`, q.v.
*
* Interpreted as a set o binary flags. The values are controlled by macros
* with names 'DEBUG_[A_Z]*' in `debug.h`, q.v.
*/
int verbosity = 0;
/**
* When debugging, we want to see exceptions as they happen, because they may
* not make their way back down the stack to whatever is expected to handle
* them.
*/
void debug_print_exception( struct cons_pointer ex_ptr ) {
#ifdef DEBUG
if ( ( verbosity != 0 ) && exceptionp( ex_ptr ) ) {
fwide( stderr, 1 );
fputws( L"EXCEPTION: ", stderr );
URL_FILE *ustderr = file_to_url_file( stderr );
fwide( stderr, 1 );
print( ustderr, ex_ptr );
free( ustderr );
}
#endif
}
/**
* @brief print this debug `message` to stderr, if `verbosity` matches `level`.
*
* `verbosity` is a set of flags, see debug_print.h; so you can
* turn debugging on for only one part of the system.
*/
void debug_print( wchar_t *message, int level ) {
#ifdef DEBUG
if ( level & verbosity ) {
fwide( stderr, 1 );
fputws( message, stderr );
}
#endif
}
/**
* @brief print a 128 bit integer value to stderr, if `verbosity` matches `level`.
*
* `verbosity` is a set of flags, see debug_print.h; so you can
* turn debugging on for only one part of the system.
*
* stolen from https://stackoverflow.com/questions/11656241/how-to-print-uint128-t-number-using-gcc
*/
void debug_print_128bit( __int128_t n, int level ) {
#ifdef DEBUG
if ( level & verbosity ) {
if ( n == 0 ) {
fwprintf( stderr, L"0" );
} else {
char str[40] = { 0 }; // log10(1 << 128) + '\0'
char *s = str + sizeof( str ) - 1; // start at the end
while ( n != 0 ) {
if ( s == str )
return; // never happens
*--s = "0123456789"[n % 10]; // save last digit
n /= 10; // drop it
}
fwprintf( stderr, L"%s", s );
}
}
#endif
}
/**
* @brief print a line feed to stderr, if `verbosity` matches `level`.
*
* `verbosity` is a set of flags, see debug_print.h; so you can
* turn debugging on for only one part of the system.
*/
void debug_println( int level ) {
#ifdef DEBUG
if ( level & verbosity ) {
fwide( stderr, 1 );
fputws( L"\n", stderr );
}
#endif
}
/**
* @brief `wprintf` adapted for the debug logging system.
*
* Print to stderr only if `verbosity` matches `level`. All other arguments
* as for `wprintf`.
*/
void debug_printf( int level, wchar_t *format, ... ) {
#ifdef DEBUG
if ( level & verbosity ) {
fwide( stderr, 1 );
va_list( args );
va_start( args, format );
vfwprintf( stderr, format, args );
}
#endif
}
/**
* @brief print the object indicated by this `pointer` to stderr, if `verbosity`
* matches `level`.
*
* `verbosity` is a set of flags, see debug_print.h; so you can
* turn debugging on for only one part of the system.
*/
void debug_print_object( struct cons_pointer pointer, int level ) {
#ifdef DEBUG
if ( level & verbosity ) {
URL_FILE *ustderr = file_to_url_file( stderr );
fwide( stderr, 1 );
print( ustderr, pointer );
free( ustderr );
}
#endif
}
/**
* @brief Like `dump_object`, q.v., but protected by the verbosity mechanism.
*
* `verbosity` is a set of flags, see debug_print.h; so you can
* turn debugging on for only one part of the system.
*/
void debug_dump_object( struct cons_pointer pointer, int level ) {
#ifdef DEBUG
if ( level & verbosity ) {
URL_FILE *ustderr = file_to_url_file( stderr );
fwide( stderr, 1 );
dump_object( ustderr, pointer );
free( ustderr );
}
#endif
}
/**
* Standardise printing of binding trace messages.
*/
void debug_print_binding( struct cons_pointer key, struct cons_pointer val,
bool deep, int level ) {
#ifdef DEBUG
// wchar_t * depth = (deep ? L"Deep" : L"Shallow");
debug_print( ( deep ? L"Deep" : L"Shallow" ), level );
debug_print( L" binding `", level );
debug_print_object( key, level );
debug_print( L"` to `", level );
debug_print_object( val, level );
debug_print( L"`\n", level );
#endif
}

101
src/c/debug.h Normal file
View file

@ -0,0 +1,101 @@
/*
* debug.h
*
* Better debug log messages.
*
* (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 "memory/consspaceobject.h"
#ifndef __debug_print_h
#define __debug_print_h
/**
* @brief Print messages debugging memory allocation.
*
* Flag interpretation for the value of `verbosity`, defined in `debug.c`, q.v.
*/
#define DEBUG_ALLOC 1
/**
* @brief Print messages debugging arithmetic operations.
*
* Flag interpretation for the value of `verbosity`, defined in `debug.c`, q.v.
*/
#define DEBUG_ARITH 2
/**
* @brief Print messages debugging symbol binding.
*
* Flag interpretation for the value of `verbosity`, defined in `debug.c`, q.v.
*/
#define DEBUG_BIND 4
/**
* @brief Print messages debugging bootstrapping and teardown.
*
* Flag interpretation for the value of `verbosity`, defined in `debug.c`, q.v.
*/
#define DEBUG_BOOTSTRAP 8
/**
* @brief Print messages debugging evaluation.
*
* Flag interpretation for the value of `verbosity`, defined in `debug.c`, q.v.
*/
#define DEBUG_EVAL 16
/**
* @brief Print messages debugging input/output operations.
*
* Flag interpretation for the value of `verbosity`, defined in `debug.c`, q.v.
*/
#define DEBUG_IO 32
/**
* @brief Print messages debugging lambda functions (interpretation).
*
* Flag interpretation for the value of `verbosity`, defined in `debug.c`, q.v.
*/
#define DEBUG_LAMBDA 64
/**
* @brief Print messages debugging the read eval print loop.
*
* Flag interpretation for the value of `verbosity`, defined in `debug.c`, q.v.
*/
#define DEBUG_REPL 128
/**
* @brief Print messages debugging stack operations.
*
* Flag interpretation for the value of `verbosity`, defined in `debug.c`, q.v.
*/
#define DEBUG_STACK 256
/**
* @brief Print messages about equality tests.
*
* Flag interpretation for the value of `verbosity`, defined in `debug.c`, q.v.
*/
#define DEBUG_EQUAL 512
extern int verbosity;
void debug_print_exception( struct cons_pointer ex_ptr );
void debug_print( wchar_t *message, int level );
void debug_print_128bit( __int128_t n, int level );
void debug_println( int level );
void debug_printf( int level, wchar_t *format, ... );
void debug_print_object( struct cons_pointer pointer, int level );
void debug_dump_object( struct cons_pointer pointer, int level );
void debug_print_binding( struct cons_pointer key, struct cons_pointer val,
bool deep, int level );
#endif

564
src/c/init.c Normal file
View file

@ -0,0 +1,564 @@
/*
* init.c
*
* Start up and initialise the environement - just enough to get working
* and (ultimately) hand off to the executive.
*
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <getopt.h>
#include <locale.h>
#include <stdbool.h>
#include <stdio.h>
#include <stdlib.h>
#include <unistd.h>
#include <wchar.h>
/* libcurl, used for io */
#include <curl/curl.h>
#include "arith/peano.h"
#include "arith/ratio.h"
#include "debug.h"
#include "io/fopen.h"
#include "io/io.h"
#include "io/print.h"
#include "memory/conspage.h"
#include "memory/consspaceobject.h"
#include "memory/hashmap.h"
#include "memory/stack.h"
#include "ops/intern.h"
#include "ops/lispops.h"
#include "ops/meta.h"
#include "repl.h"
#include "time/psse_time.h"
#include "version.h"
/**
* @brief If `pointer` is an exception, display that exception to stderr,
* decrement that exception, and return NIL; else return the pointer.
*
* @param pointer a cons pointer.
* @param location_descriptor a description of where the pointer was caught.
* @return struct cons_pointer
*/
struct cons_pointer check_exception( struct cons_pointer pointer,
char *location_descriptor ) {
struct cons_pointer result = pointer;
if ( exceptionp( pointer ) ) {
struct cons_space_object *object = &pointer2cell( pointer );
result = NIL;
fprintf( stderr, "ERROR: Exception at %s: ", location_descriptor );
URL_FILE *ustderr = file_to_url_file( stderr );
fwide( stderr, 1 );
print( ustderr, object->payload.exception.payload );
free( ustderr );
dec_ref( pointer );
}
return result;
}
void maybe_bind_init_symbols( ) {
if ( nilp( privileged_keyword_documentation ) ) {
privileged_keyword_documentation =
c_string_to_lisp_keyword( L"documentation" );
}
if ( nilp( privileged_keyword_name ) ) {
privileged_keyword_name = c_string_to_lisp_keyword( L"name" );
}
if ( nilp( privileged_keyword_primitive ) ) {
privileged_keyword_primitive =
c_string_to_lisp_keyword( L"primitive" );
}
if ( nilp( privileged_symbol_nil ) ) {
privileged_symbol_nil = c_string_to_lisp_symbol( L"nil" );
}
// we can't make this string when we need it, because memory is then
// exhausted!
if ( nilp( privileged_string_memory_exhausted ) ) {
privileged_string_memory_exhausted =
c_string_to_lisp_string( L"Memory exhausted." );
}
if ( nilp( privileged_keyword_location ) ) {
privileged_keyword_location = c_string_to_lisp_keyword( L"location" );
}
if ( nilp( privileged_keyword_payload ) ) {
privileged_keyword_payload = c_string_to_lisp_keyword( L"payload" );
}
if ( nilp( privileged_keyword_cause ) ) {
privileged_keyword_cause = c_string_to_lisp_keyword( L"cause" );
}
}
void free_init_symbols( ) {
dec_ref( privileged_keyword_documentation );
dec_ref( privileged_keyword_name );
dec_ref( privileged_keyword_primitive );
}
/**
* Bind this compiled `executable` function, as a Lisp function, to
* this name in the `oblist`.
* \todo where a function is not compiled from source, we could cache
* the name on the source pointer. Would make stack frames potentially
* more readable and aid debugging generally.
*/
struct cons_pointer bind_function( wchar_t *name,
wchar_t *doc,
struct cons_pointer ( *executable )
( struct stack_frame *,
struct cons_pointer,
struct cons_pointer ) ) {
struct cons_pointer n = c_string_to_lisp_symbol( name );
struct cons_pointer d = c_string_to_lisp_string( doc );
struct cons_pointer meta =
make_cons( make_cons( privileged_keyword_primitive, TRUE ),
make_cons( make_cons( privileged_keyword_name, n ),
make_cons( make_cons
( privileged_keyword_documentation,
d ),
NIL ) ) );
struct cons_pointer r =
check_exception( deep_bind( n, make_function( meta, executable ) ),
"bind_function" );
dec_ref( n );
dec_ref( d );
return r;
}
/**
* Bind this compiled `executable` function, as a Lisp special form, to
* this `name` in the `oblist`.
*/
struct cons_pointer bind_special( wchar_t *name,
wchar_t *doc,
struct cons_pointer ( *executable )
( struct stack_frame *, struct cons_pointer,
struct cons_pointer ) ) {
struct cons_pointer n = c_string_to_lisp_symbol( name );
struct cons_pointer d = c_string_to_lisp_string( doc );
struct cons_pointer meta =
make_cons( make_cons( privileged_keyword_primitive, TRUE ),
make_cons( make_cons( privileged_keyword_name, n ),
make_cons( make_cons
( privileged_keyword_documentation,
d ),
NIL ) ) );
struct cons_pointer r =
check_exception( deep_bind( n, make_special( meta, executable ) ),
"bind_special" );
dec_ref( n );
dec_ref( d );
return r;
}
/**
* Bind this `value` to this `symbol` in the `oblist`.
*/
struct cons_pointer
bind_symbol_value( struct cons_pointer symbol, struct cons_pointer value,
bool lock ) {
struct cons_pointer r = check_exception( deep_bind( symbol, value ),
"bind_symbol_value" );
if ( lock && !exceptionp( r ) ) {
struct cons_space_object *cell = &pointer2cell( r );
cell->count = UINT32_MAX;
}
return r;
}
/**
* Bind this `value` to this `name` in the `oblist`.
*/
struct cons_pointer bind_value( wchar_t *name, struct cons_pointer value,
bool lock ) {
struct cons_pointer p = c_string_to_lisp_symbol( name );
struct cons_pointer r = bind_symbol_value( p, value, lock );
dec_ref( p );
return r;
}
void print_banner( ) {
fwprintf( stdout, L"Post-Scarcity Software Environment version %s\n\n",
VERSION );
}
/**
* Print command line options to this `stream`.
*
* @stream the stream to print to.
*/
void print_options( FILE *stream ) {
fwprintf( stream, L"Expected options are:\n" );
fwprintf( stream,
L"\t-d\tDump memory to standard out at end of run (copious!);\n" );
fwprintf( stream, L"\t-h\tPrint this message and exit;\n" );
fwprintf( stream, L"\t-p\tShow a prompt (default is no prompt);\n" );
fwprintf( stream,
L"\t-s LIMIT\n\t\tSet the maximum stack depth to this LIMIT (int)\n" );
#ifdef DEBUG
fwprintf( stream,
L"\t-v LEVEL\n\t\tSet verbosity to the specified level (0...512)\n" );
fwprintf( stream, L"\t\tWhere bits are interpreted as follows:\n" );
fwprintf( stream, L"\t\t1\tALLOC;\n" );
fwprintf( stream, L"\t\t2\tARITH;\n" );
fwprintf( stream, L"\t\t4\tBIND;\n" );
fwprintf( stream, L"\t\t8\tBOOTSTRAP;\n" );
fwprintf( stream, L"\t\t16\tEVAL;\n" );
fwprintf( stream, L"\t\t32\tINPUT/OUTPUT;\n" );
fwprintf( stream, L"\t\t64\tLAMBDA;\n" );
fwprintf( stream, L"\t\t128\tREPL;\n" );
fwprintf( stream, L"\t\t256\tSTACK;\n" );
fwprintf( stream, L"\t\t512\tEQUAL.\n" );
#endif
}
/**
* main entry point; parse command line arguments, initialise the environment,
* and enter the read-eval-print loop.
*/
int main( int argc, char *argv[] ) {
int option;
bool dump_at_end = false;
bool show_prompt = false;
char *infilename = NULL;
setlocale( LC_ALL, "" );
if ( io_init( ) != 0 ) {
fputs( "Failed to initialise I/O subsystem\n", stderr );
exit( 1 );
}
while ( ( option = getopt( argc, argv, "dhi:ps:v:" ) ) != -1 ) {
switch ( option ) {
case 'd':
dump_at_end = true;
break;
case 'h':
print_banner( );
print_options( stdout );
exit( 0 );
break;
case 'i':
infilename = optarg;
break;
case 'p':
show_prompt = true;
break;
case 's':
stack_limit = atoi( optarg );
break;
case 'v':
verbosity = atoi( optarg );
break;
default:
fwprintf( stderr, L"Unexpected option %c\n", option );
print_options( stderr );
exit( 1 );
break;
}
}
initialise_cons_pages( );
maybe_bind_init_symbols( );
if ( show_prompt ) {
print_banner( );
}
debug_print( L"About to initialise oblist\n", DEBUG_BOOTSTRAP );
oblist = make_hashmap( 32, NIL, TRUE );
debug_print( L"About to bind\n", DEBUG_BOOTSTRAP );
/*
* privileged variables (keywords)
*/
bind_symbol_value( privileged_symbol_nil, NIL, true );
bind_value( L"t", TRUE, true );
bind_symbol_value( privileged_keyword_location, TRUE, true );
bind_symbol_value( privileged_keyword_payload, TRUE, true );
/*
* standard input, output, error and sink streams
* attempt to set wide character acceptance on all streams
*/
URL_FILE *sink = url_fopen( "/dev/null", "w" );
fwide( stdin, 1 );
fwide( stdout, 1 );
fwide( stderr, 1 );
fwide( sink->handle.file, 1 );
FILE *infile = infilename == NULL ? stdin : fopen( infilename, "r" );
lisp_io_in =
bind_value( C_IO_IN,
make_read_stream( file_to_url_file( infile ),
make_cons( make_cons
( c_string_to_lisp_keyword
( L"url" ),
c_string_to_lisp_string
( L"system:standard input" ) ),
NIL ) ), false );
lisp_io_out =
bind_value( C_IO_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 ) ), false );
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 ) ), false );
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 ) ), false );
/*
* the default prompt
*/
prompt_name = bind_value( L"*prompt*",
show_prompt ? c_string_to_lisp_symbol( L":: " ) :
NIL, false );
/*
* primitive function operations
*/
/* TODO: docstrings should be moved to a header file, or even to an at-run-time resolution system.
* HTTP from an address at journeyman? */
bind_function( L"absolute",
L"`(absolute arg)`: If `arg` is a number, return the absolute value of that number, else `nil`.",
&lisp_absolute );
bind_function( L"add",
L"`(+ args...)`: If `args` are all numbers, return the sum of those numbers.",
&lisp_add );
bind_function( L"and",
L"`(and args...)`: Return a logical `and` of all the arguments and return `t` only if all are truthy, else `nil`.",
&lisp_and );
bind_function( L"append",
L"`(append args...)`: If args are all collections, return the concatenation of those collections.",
&lisp_append );
bind_function( L"apply",
L"`(apply f args)`: If `f` is usable as a function, and `args` is a collection, apply `f` to `args` and return the value.",
&lisp_apply );
bind_function( L"assoc",
L"`(assoc key store)`: Return the value associated with this `key` in this `store`.",
&lisp_assoc );
bind_function( L"car",
L"`(car arg)`: If `arg` is a sequence, return the item which is the head of that sequence.",
&lisp_car );
bind_function( L"cdr",
L"`(cdr arg)`: If `arg` is a sequence, return the remainder of that sequence with the first item removed.",
&lisp_cdr );
bind_function( L"close",
L"`(close stream)`: If `stream` is a stream, close that stream.",
&lisp_close );
bind_function( L"cons",
L"`(cons a b)`: Return a cons cell whose `car` is `a` and whose `cdr` is `b`.",
&lisp_cons );
bind_function( L"count",
L"`(count s)`: Return the number of items in the sequence `s`.",
&lisp_count );
bind_function( L"divide",
L"`(/ a b)`: If `a` and `b` are both numbers, return the numeric result of dividing `a` by `b`.",
&lisp_divide );
bind_function( L"eq?",
L"`(eq? args...)`: Return `t` if all args are the exact same object, else `nil`.",
&lisp_eq );
bind_function( L"equal?",
L"`(equal? args...)`: Return `t` if all args have logically equivalent value, else `nil`.",
&lisp_equal );
bind_function( L"eval", L"", &lisp_eval );
bind_function( L"exception",
L"`(exception message)`: Return (throw) an exception with this `message`.",
&lisp_exception );
bind_function( L"get-hash",
L"`(get-hash arg)`: returns the natural number hash value of `arg`.",
&lisp_get_hash );
bind_function( L"hashmap",
L"`(hashmap n-buckets hashfn store acl)`: Return a new hashmap, with `n-buckets` buckets and this `hashfn`, containing the content of this `store`.",
lisp_make_hashmap );
bind_function( L"inspect",
L"`(inspect object ouput-stream)`: Print details of this `object` to this `output-stream` or `*out*`.",
&lisp_inspect );
bind_function( L"interned?",
L"`(interned? key store)`: Return `t` if the symbol or keyword `key` is bound in this `store`, else `nil`.",
&lisp_internedp );
bind_function( L"keys",
L"`(keys store)`: Return a list of all keys in this `store`.",
&lisp_keys );
bind_function( L"list",
L"`(list args...)`: Return a list of these `args`.",
&lisp_list );
bind_function( L"mapcar",
L"`(mapcar function sequence)`: Apply `function` to each element of `sequence` in turn, and return a sequence of the results.",
&lisp_mapcar );
bind_function( L"meta",
L"`(meta symbol)`: If the binding of `symbol` has metadata, return that metadata, else `nil`.",
&lisp_metadata );
bind_function( L"metadata",
L"`(metadata symbol)`: If the binding of `symbol` has metadata, return that metadata, else `nil`.",
&lisp_metadata );
bind_function( L"multiply",
L"`(* args...)` Multiply these `args`, all of which should be numbers.",
&lisp_multiply );
bind_function( L"negative?",
L"`(negative? n)`: Return `t` if `n` is a negative number, else `nil`.",
&lisp_is_negative );
bind_function( L"not",
L"`(not arg)`: Return`t` only if `arg` is `nil`, else `nil`.",
&lisp_not );
bind_function( L"oblist",
L"`(oblist)`: Return the current symbol bindings, as a map.",
&lisp_oblist );
bind_function( L"open",
L"`(open url write?)`: Open a stream to this `url`. If `write?` is present and is non-nil, open it for writing, else reading.",
&lisp_open );
bind_function( L"or",
L"`(or args...)`: Return a logical `or` of all the arguments and return `t` if any is truthy, else `nil`.",
&lisp_or );
bind_function( L"print",
L"`(print object stream)`: Print `object` to `stream`, if specified, else to `*out*`.",
&lisp_print );
bind_function( L"println",
L"`(println stream)`: Print a new line character to `stream`, if specified, else to `*out*`.",
&lisp_println );
bind_function( L"put!", L"", lisp_hashmap_put );
bind_function( L"put-all!",
L"`(put-all! dest source)`: If `dest` is a namespace and is writable, copies all key-value pairs from `source` into `dest`.",
&lisp_hashmap_put_all );
bind_function( L"ratio->real",
L"`(ratio->real r)`: If `r` is a rational number, return the real number equivalent.",
&lisp_ratio_to_real );
bind_function( L"read",
L"`(read stream)`: read one complete lisp form and return it. If `stream` is specified and is a read stream, then read from that stream, else the stream which is the value of `*in*` in the environment.",
&lisp_read );
bind_function( L"read-char",
L"`(read-char stream)`: Return the next character. If `stream` is specified and is a read stream, then read from that stream, else the stream which is the value of `*in*` in the environment.",
&lisp_read_char );
bind_function( L"repl",
L"`(repl prompt input output)`: Starts a new read-eval-print-loop. All arguments are optional.",
&lisp_repl );
bind_function( L"reverse",
L"`(reverse sequence)` Returns a sequence of the top level elements of this `sequence`, which may be a list or a string, in the reverse order.",
&lisp_reverse );
bind_function( L"set", L"", &lisp_set );
bind_function( L"slurp",
L"`(slurp read-stream)` Read all the characters from `read-stream` to the end of stream, and return them as a string.",
&lisp_slurp );
bind_function( L"source",
L"`(source object)`: If `object` is an interpreted function or interpreted special form, returns the source code; else nil.",
&lisp_source );
bind_function( L"subtract",
L"`(- a b)`: Subtracts `b` from `a` and returns the result. Expects both arguments to be numbers.",
&lisp_subtract );
bind_function( L"throw",
L"`(throw message cause)`: Throw an exception with this `message`, and, if specified, this `cause` (which is expected to be an exception but need not be).",
&lisp_exception );
bind_function( L"time",
L"`(time arg)`: Return a time object. If an `arg` is supplied, it should be an integer which will be interpreted as a number of microseconds since the big bang, which is assumed to have happened 441,806,400,000,000,000 seconds before the UNIX epoch.",
&lisp_time );
bind_function( L"type",
L"`(type object)`: returns the type of the specified `object`. Currently (0.0.6) the type is returned as a four character string; this may change.",
&lisp_type );
bind_function( L"+",
L"`(+ args...)`: If `args` are all numbers, return the sum of those numbers.",
&lisp_add );
bind_function( L"*",
L"`(* args...)` Multiply these `args`, all of which should be numbers.",
&lisp_multiply );
bind_function( L"-",
L"`(- a b)`: Subtracts `b` from `a` and returns the result. Expects both arguments to be numbers.",
&lisp_subtract );
bind_function( L"/",
L"`(/ a b)`: If `a` and `b` are both numbers, return the numeric result of dividing `a` by `b`.",
&lisp_divide );
bind_function( L"=",
L"`(equal? args...)`: Return `t` if all args have logically equivalent value, else `nil`.",
&lisp_equal );
/*
* primitive special forms
*/
bind_special( L"cond",
L"`(cond clauses...)`: Conditional evaluation, `clauses` is a sequence of lists of forms such that if evaluating the first form in any clause returns non-`nil`, the subsequent forms in that clause will be evaluated and the value of the last returned; but any subsequent clauses will not be evaluated.",
&lisp_cond );
bind_special( L"lambda",
L"`(lambda arg-list forms...)`: Construct an interpretable λ funtion.",
&lisp_lambda );
bind_special( L"\u03bb", L"", &lisp_lambda ); // λ
bind_special( L"let",
L"`(let bindings forms)`: Bind these `bindings`, which should be specified as an association list, into the local environment and evaluate these forms sequentially in that context, returning the value of the last.",
&lisp_let );
bind_special( L"nlambda",
L"`(nlamda arg-list forms...)`: Construct an interpretable special form. When the form is interpreted, arguments specified in the `arg-list` will not be evaluated.",
&lisp_nlambda );
bind_special( L"n\u03bb", L"`(nlamda arg-list forms...)`: Construct an interpretable special form. When the form is interpreted, arguments specified in the `arg-list` will not be evaluated.", &lisp_nlambda ); // nλ
bind_special( L"progn",
L"`(progn forms...)` Evaluate `forms` sequentially, and return the value of the last.",
&lisp_progn );
bind_special( L"quote",
L"`(quote form)`: Returns `form`, unevaluated. More idiomatically expressed `'form`, where the quote mark is a reader macro which is expanded to `(quote form)`.",
&lisp_quote );
bind_special( L"set!",
L"`(set! symbol value namespace)`: Binds `symbol` in `namespace` to the value of `value`, altering the namespace in so doing, and returns `value`. If `namespace` is not specified, it defaults to the default namespace.",
&lisp_set_shriek );
bind_special( L"try", L"", &lisp_try );
debug_print( L"Initialised oblist\n", DEBUG_BOOTSTRAP );
debug_dump_object( oblist, DEBUG_BOOTSTRAP );
repl( show_prompt );
debug_dump_object( oblist, DEBUG_BOOTSTRAP );
debug_print( L"Freeing oblist\n", DEBUG_BOOTSTRAP );
while ( ( pointer2cell( oblist ) ).count > 0 ) {
fprintf( stderr, "Dangling refs on oblist: %d\n",
( pointer2cell( oblist ) ).count );
dec_ref( oblist );
}
free_init_symbols( );
if ( dump_at_end ) {
dump_pages( file_to_url_file( stdout ) );
}
summarise_allocation( );
curl_global_cleanup( );
return ( 0 );
}

526
src/c/io/fopen.c Normal file
View file

@ -0,0 +1,526 @@
/*
* fopen.c
*
* adapted from https://curl.haxx.se/libcurl/c/fopen.html.
*
* Modifications to read/write wide character streams by
* Simon Brooke.
*
* NOTE THAT: for my purposes, I'm only interested in wide characters,
* and I always read them one character at a time.
*
* Copyright (c) 2003, 2017 Simtec Electronics
* Some portions (c) 2019 Simon Brooke <simon@journeyman.cc>
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions
* are met:
* 1. Redistributions of source code must retain the above copyright
* notice, this list of conditions and the following disclaimer.
* 2. Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in the
* documentation and/or other materials provided with the distribution.
* 3. The name of the author may not be used to endorse or promote products
* derived from this software without specific prior written permission.
*
* THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
* IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
* OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
* IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT,
* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
* NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
* DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
* THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
* (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
* THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*
* This example requires libcurl 7.9.7 or later.
*/
#include <stdio.h>
#include <string.h>
#ifndef WIN32
#include <sys/time.h>
#endif
#include <stdlib.h>
#include <errno.h>
#include <curl/curl.h>
#include "io/fopen.h"
#ifdef FOPEN_STANDALONE
CURLSH *io_share;
#else
#include "memory/consspaceobject.h"
#include "io/io.h"
#include "utils.h"
#endif
/* exported functions */
URL_FILE *url_fopen( const char *url, const char *operation );
int url_fclose( URL_FILE * file );
int url_feof( 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 );
void url_rewind( URL_FILE * file );
/* we use a global one for convenience */
static CURLM *multi_handle;
/* curl calls this routine to get more data */
static size_t write_callback( char *buffer,
size_t size, size_t nitems, void *userp ) {
char *newbuff;
size_t rembuff;
URL_FILE *url = ( URL_FILE * ) userp;
size *= nitems;
rembuff = url->buffer_len - url->buffer_pos; /* remaining space in buffer */
if ( size > rembuff ) {
/* not enough space in buffer */
newbuff = realloc( url->buffer, url->buffer_len + ( size - rembuff ) );
if ( newbuff == NULL ) {
fprintf( stderr, "callback buffer grow failed\n" );
size = rembuff;
} else {
/* realloc succeeded increase buffer size */
url->buffer_len += size - rembuff;
url->buffer = newbuff;
}
}
memcpy( &url->buffer[url->buffer_pos], buffer, size );
url->buffer_pos += size;
return size;
}
/* use to attempt to fill the read buffer up to requested number of bytes */
static int fill_buffer( URL_FILE *file, size_t want ) {
fd_set fdread;
fd_set fdwrite;
fd_set fdexcep;
struct timeval timeout;
int rc;
CURLMcode mc; /* curl_multi_fdset() return code */
/* only attempt to fill buffer if transactions still running and buffer
* doesn't exceed required size already
*/
if ( ( !file->still_running ) || ( file->buffer_pos > want ) )
return 0;
/* attempt to fill buffer */
do {
int maxfd = -1;
long curl_timeo = -1;
FD_ZERO( &fdread );
FD_ZERO( &fdwrite );
FD_ZERO( &fdexcep );
/* set a suitable timeout to fail on */
timeout.tv_sec = 60; /* 1 minute */
timeout.tv_usec = 0;
curl_multi_timeout( multi_handle, &curl_timeo );
if ( curl_timeo >= 0 ) {
timeout.tv_sec = curl_timeo / 1000;
if ( timeout.tv_sec > 1 )
timeout.tv_sec = 1;
else
timeout.tv_usec = ( curl_timeo % 1000 ) * 1000;
}
/* get file descriptors from the transfers */
mc = curl_multi_fdset( multi_handle, &fdread, &fdwrite, &fdexcep,
&maxfd );
if ( mc != CURLM_OK ) {
fprintf( stderr, "curl_multi_fdset() failed, code %d.\n", mc );
break;
}
/* On success the value of maxfd is guaranteed to be >= -1. We call
select(maxfd + 1, ...); specially in case of (maxfd == -1) there are
no fds ready yet so we call select(0, ...) --or Sleep() on Windows--
to sleep 100ms, which is the minimum suggested value in the
curl_multi_fdset() doc. */
if ( maxfd == -1 ) {
#ifdef _WIN32
Sleep( 100 );
rc = 0;
#else
/* Portable sleep for platforms other than Windows. */
struct timeval wait = { 0, 100 * 1000 }; /* 100ms */
rc = select( 0, NULL, NULL, NULL, &wait );
#endif
} else {
/* Note that on some platforms 'timeout' may be modified by select().
If you need access to the original value save a copy beforehand. */
rc = select( maxfd + 1, &fdread, &fdwrite, &fdexcep, &timeout );
}
switch ( rc ) {
case -1:
/* select error */
break;
case 0:
default:
/* timeout or readable/writable sockets */
curl_multi_perform( multi_handle, &file->still_running );
break;
}
} while ( file->still_running && ( file->buffer_pos < want ) );
return 1;
}
/* use to remove want bytes from the front of a files buffer */
static int use_buffer( URL_FILE *file, size_t want ) {
/* sort out buffer */
if ( ( file->buffer_pos - want ) <= 0 ) {
/* ditch buffer - write will recreate */
free( file->buffer );
file->buffer = NULL;
file->buffer_pos = 0;
file->buffer_len = 0;
} else {
/* move rest down make it available for later */
memmove( file->buffer,
&file->buffer[want], ( file->buffer_pos - want ) );
file->buffer_pos -= want;
}
return 0;
}
URL_FILE *url_fopen( const char *url, const char *operation ) {
/* this code could check for URLs or types in the 'url' and
basically use the real fopen() for standard files */
URL_FILE *file;
( void ) operation;
file = calloc( 1, sizeof( URL_FILE ) );
if ( !file )
return NULL;
file->handle.file = fopen( url, operation );
if ( file->handle.file ) {
file->type = CFTYPE_FILE; /* marked as file */
} else if ( index_of( ':', url ) > -1 ) {
file->type = CFTYPE_CURL; /* marked as URL */
file->handle.curl = curl_easy_init( );
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_VERBOSE, 0L );
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 );
/* lets start the fetch */
curl_multi_perform( multi_handle, &file->still_running );
if ( ( file->buffer_pos == 0 ) && ( !file->still_running ) ) {
/* if still_running is 0 now, we should return NULL */
/* make sure the easy handle is not in the multi handle anymore */
curl_multi_remove_handle( multi_handle, file->handle.curl );
/* cleanup */
curl_easy_cleanup( file->handle.curl );
free( file );
file = NULL;
}
} else {
file->type = CFTYPE_NONE;
/* not a file, and doesn't look like a URL. */
}
return file;
}
int url_fclose( URL_FILE *file ) {
int ret = 0; /* default is good return */
switch ( file->type ) {
case CFTYPE_FILE:
ret = fclose( file->handle.file ); /* passthrough */
break;
case CFTYPE_CURL:
/* make sure the easy handle is not in the multi handle anymore */
curl_multi_remove_handle( multi_handle, file->handle.curl );
/* cleanup */
curl_easy_cleanup( file->handle.curl );
break;
default: /* unknown or supported type - oh dear */
ret = EOF;
errno = EBADF;
break;
}
free( file->buffer ); /* free any allocated buffer space */
free( file );
return ret;
}
int url_feof( URL_FILE *file ) {
int ret = 0;
switch ( file->type ) {
case CFTYPE_FILE:
ret = feof( file->handle.file );
break;
case CFTYPE_CURL:
if ( ( file->buffer_pos == 0 ) && ( !file->still_running ) )
ret = 1;
break;
default: /* unknown or supported type - oh dear */
ret = -1;
errno = EBADF;
break;
}
return ret;
}
size_t url_fread( void *ptr, size_t size, size_t nmemb, URL_FILE *file ) {
size_t want;
switch ( file->type ) {
case CFTYPE_FILE:
want = fread( ptr, size, nmemb, file->handle.file );
break;
case CFTYPE_CURL:
want = nmemb * size;
fill_buffer( file, want );
/* check if there's data in the buffer - if not fill_buffer()
* either errored or EOF */
if ( !file->buffer_pos )
return 0;
/* ensure only available data is considered */
if ( file->buffer_pos < want )
want = file->buffer_pos;
/* xfer data to caller */
memcpy( ptr, file->buffer, want );
use_buffer( file, want );
want = want / size; /* number of items */
break;
default: /* unknown or supported type - oh dear */
want = 0;
errno = EBADF;
break;
}
return want;
}
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 loop;
switch ( file->type ) {
case CFTYPE_FILE:
ptr = fgets( ptr, ( int ) size, file->handle.file );
break;
case CFTYPE_CURL:
fill_buffer( file, want );
/* check if there's data in the buffer - if not fill either errored or
* EOF */
if ( !file->buffer_pos )
return NULL;
/* ensure only available data is considered */
if ( file->buffer_pos < want )
want = file->buffer_pos;
/*buffer contains data */
/* look for newline or eof */
for ( loop = 0; loop < want; loop++ ) {
if ( file->buffer[loop] == '\n' ) {
want = loop + 1; /* include newline */
break;
}
}
/* xfer data to caller */
memcpy( ptr, file->buffer, want );
ptr[want] = 0; /* always null terminate */
use_buffer( file, want );
break;
default: /* unknown or supported type - oh dear */
ptr = NULL;
errno = EBADF;
break;
}
return ptr; /*success */
}
void url_rewind( URL_FILE *file ) {
switch ( file->type ) {
case CFTYPE_FILE:
rewind( file->handle.file ); /* passthrough */
break;
case CFTYPE_CURL:
/* halt transaction */
curl_multi_remove_handle( multi_handle, file->handle.curl );
/* restart */
curl_multi_add_handle( multi_handle, file->handle.curl );
/* ditch buffer - write will recreate - resets stream pos */
free( file->buffer );
file->buffer = NULL;
file->buffer_pos = 0;
file->buffer_len = 0;
break;
default: /* unknown or supported type - oh dear */
break;
}
}
#ifdef FOPEN_STANDALONE
#define FGETSFILE "fgets.test"
#define FREADFILE "fread.test"
#define REWINDFILE "rewind.test"
/* 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
* they contain 0 chars */
int main( int argc, char *argv[] ) {
URL_FILE *handle;
FILE *outf;
size_t nread;
char buffer[256];
const char *url;
CURL *curl;
CURLcode res;
curl_global_init( CURL_GLOBAL_DEFAULT );
curl = curl_easy_init( );
if ( argc < 2 )
url = "http://192.168.7.3/testfile"; /* default to testurl */
else
url = argv[1]; /* use passed url */
/* copy from url line by line with fgets */
outf = fopen( FGETSFILE, "wb+" );
if ( !outf ) {
perror( "couldn't open fgets output file\n" );
return 1;
}
handle = url_fopen( url, "r" );
if ( !handle ) {
printf( "couldn't url_fopen() %s\n", url );
fclose( outf );
return 2;
}
while ( !url_feof( handle ) ) {
url_fgets( buffer, sizeof( buffer ), handle );
fwrite( buffer, 1, strlen( buffer ), outf );
}
url_fclose( handle );
fclose( outf );
/* Copy from url with fread */
outf = fopen( FREADFILE, "wb+" );
if ( !outf ) {
perror( "couldn't open fread output file\n" );
return 1;
}
handle = url_fopen( "testfile", "r" );
if ( !handle ) {
printf( "couldn't url_fopen() testfile\n" );
fclose( outf );
return 2;
}
do {
nread = url_fread( buffer, 1, sizeof( buffer ), handle );
fwrite( buffer, 1, nread, outf );
} while ( nread );
url_fclose( handle );
fclose( outf );
/* Test rewind */
outf = fopen( REWINDFILE, "wb+" );
if ( !outf ) {
perror( "couldn't open fread output file\n" );
return 1;
}
handle = url_fopen( "testfile", "r" );
if ( !handle ) {
printf( "couldn't url_fopen() testfile\n" );
fclose( outf );
return 2;
}
nread = url_fread( buffer, 1, sizeof( buffer ), handle );
fwrite( buffer, 1, nread, outf );
url_rewind( handle );
buffer[0] = '\n';
fwrite( buffer, 1, 1, outf );
nread = url_fread( buffer, 1, sizeof( buffer ), handle );
fwrite( buffer, 1, nread, outf );
url_fclose( handle );
fclose( outf );
return 0; /* all done */
}
#endif

83
src/c/io/fopen.h Normal file
View file

@ -0,0 +1,83 @@
/*
* fopen.h
*
* adapted from https://curl.haxx.se/libcurl/c/fopen.html.
*
*
* Modifications to read/write wide character streams by
* Simon Brooke.
*
* NOTE THAT: for my purposes, I'm only interested in wide characters,
* and I always read them one character at a time.
*
* Copyright (c) 2003, 2017 Simtec Electronics
* Some portions (c) 2019 Simon Brooke <simon@journeyman.cc>
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions
* are met:
* 1. Redistributions of source code must retain the above copyright
* notice, this list of conditions and the following disclaimer.
* 2. Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in the
* documentation and/or other materials provided with the distribution.
* 3. The name of the author may not be used to endorse or promote products
* derived from this software without specific prior written permission.
*
* THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
* IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
* OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
* IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT,
* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
* NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
* DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
* THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
* (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
* THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*
* This example requires libcurl 7.9.7 or later.
*/
#ifndef __fopen_h
#define __fopen_h
#include <curl/curl.h>
/*
* wide characters
*/
#include <wchar.h>
#include <wctype.h>
#define url_fwprintf(f, ...) ((f->type = CFTYPE_FILE) ? fwprintf( f->handle.file, __VA_ARGS__) : -1)
#define url_fputws(ws, f) ((f->type = CFTYPE_FILE) ? fputws(ws, f->handle.file) : 0)
#define url_fputwc(wc, f) ((f->type = CFTYPE_FILE) ? fputwc(wc, f->handle.file) : 0)
enum fcurl_type_e {
CFTYPE_NONE = 0,
CFTYPE_FILE = 1,
CFTYPE_CURL = 2
};
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 buffer's length */
size_t buffer_pos; /* cursor into in buffer */
int still_running; /* Is background url fetch still in progress */
};
typedef struct fcurl_data URL_FILE;
/* exported functions */
URL_FILE *url_fopen( const char *url, const char *operation );
int url_fclose( URL_FILE * file );
int url_feof( 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 );
void url_rewind( URL_FILE * file );
#endif

14
src/c/io/history.c Normal file
View file

@ -0,0 +1,14 @@
/*
* history.c
*
* Maintain, and recall, a history of things which have been read from standard
* input. Necessarily the history must be stored on the user session, and not be
* global.
*
* I *think* history will be maintained as a list of forms, not of strings, so
* only forms which have successfully been read can be recalled, and forms which
* have not been completed when the history function is invoked will be lost.
*
* (c) 2025 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/

14
src/c/io/history.h Normal file
View file

@ -0,0 +1,14 @@
/*
* history.h
*
* Maintain, and recall, a history of things which have been read from standard
* input. Necessarily the history must be stored on the user session, and not be
* global.
*
* I *think* history will be maintained as a list of forms, not of strings, so
* only forms which have successfully been read can be recalled, and forms which
* have not been completed when the history function is invoked will be lost.
*
* (c) 2025 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/

557
src/c/io/io.c Normal file
View file

@ -0,0 +1,557 @@
/*
* io.c
*
* Communication between PSSE and the outside world, via libcurl. NOTE
* that this file destructively changes metadata on URL connections,
* because the metadata is not available until the stream has been read
* from. It would be better to find a workaround!
*
* (c) 2019 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <grp.h>
#include <langinfo.h>
#include <pwd.h>
#include <stdlib.h>
#include <string.h>
#include <time.h>
#include <sys/stat.h>
#include <sys/types.h>
#include <unistd.h>
#include <uuid/uuid.h>
/*
* wide characters
*/
#include <wchar.h>
#include <wctype.h>
#include <curl/curl.h>
#include "arith/integer.h"
#include "debug.h"
#include "io/fopen.h"
#include "io/io.h"
#include "memory/conspage.h"
#include "memory/consspaceobject.h"
#include "ops/intern.h"
#include "ops/lispops.h"
#include "utils.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;
/**
* @brief bound to the Lisp string representing C_IO_IN in initialisation.
*/
struct cons_pointer lisp_io_in = NIL;
/**
* @brief bound to the Lisp string representing C_IO_OUT in initialisation.
*/
struct cons_pointer lisp_io_out = NIL;
/**
* Allow a one-character unget facility. This may not be enough - we may need
* to allocate a buffer.
*/
wint_t ungotten = 0;
/**
* Initialise the I/O subsystem.
*
* @return 0 on success; any other value means failure.
*/
int io_init( ) {
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
* keywords) into a UTF-8 string. NOTE that the returned value has been
* malloced and must be freed. TODO: candidate to moving into a utilities
* file.
*
* @param s the lisp string or symbol;
* @return the c string.
*/
char *lisp_string_to_c_string( struct cons_pointer s ) {
char *result = NULL;
if ( stringp( s ) || symbolp( s ) ) {
int len = 0;
for ( struct cons_pointer c = s; !nilp( c );
c = pointer2cell( c ).payload.string.cdr ) {
len++;
}
wchar_t *buffer = calloc( len + 1, sizeof( wchar_t ) );
/* worst case, one wide char = four utf bytes */
result = calloc( ( len * 4 ) + 1, sizeof( char ) );
int i = 0;
for ( struct cons_pointer c = s; !nilp( c );
c = pointer2cell( c ).payload.string.cdr ) {
buffer[i++] = pointer2cell( c ).payload.string.character;
}
wcstombs( result, buffer, len );
free( buffer );
}
debug_print( L"lisp_string_to_c_string( ", DEBUG_IO );
debug_print_object( s, DEBUG_IO );
debug_printf( DEBUG_IO, L") => '%s'\n", result );
return result;
}
/**
* given this file handle f, return a new url_file handle wrapping it.
*
* @param f the file to be wrapped;
* @return the new handle, or null if no such handle could be allocated.
*/
URL_FILE *file_to_url_file( FILE *f ) {
URL_FILE *result = ( URL_FILE * ) malloc( sizeof( URL_FILE ) );
if ( result != NULL ) {
result->type = CFTYPE_FILE, result->handle.file = f;
}
return result;
}
/**
* get one wide character from the buffer.
*
* @param file the stream to read from;
* @return the next wide character on the stream, or zero if no more.
*/
wint_t url_fgetwc( URL_FILE *input ) {
wint_t result = -1;
if ( ungotten != 0 ) {
/* TODO: not thread safe */
result = ungotten;
ungotten = 0;
} else {
switch ( input->type ) {
case CFTYPE_FILE:
fwide( input->handle.file, 1 ); /* wide characters */
result = fgetwc( input->handle.file ); /* passthrough */
break;
case CFTYPE_CURL:{
char *cbuff =
calloc( sizeof( wchar_t ) + 2, sizeof( char ) );
wchar_t *wbuff = calloc( 2, sizeof( wchar_t ) );
size_t count = 0;
debug_print( L"url_fgetwc: about to call url_fgets\n",
DEBUG_IO );
url_fgets( cbuff, 2, input );
debug_print( L"url_fgetwc: back from url_fgets\n",
DEBUG_IO );
int c = ( int ) cbuff[0];
// TODO: risk of reading off cbuff?
debug_printf( DEBUG_IO,
L"url_fgetwc: cbuff is '%s'; (first) character = %d (%c)\n",
cbuff, c, c & 0xf7 );
/* The value of each individual byte indicates its UTF-8 function, as follows:
*
* 00 to 7F hex (0 to 127): first and only byte of a sequence.
* 80 to BF hex (128 to 191): continuing byte in a multi-byte sequence.
* C2 to DF hex (194 to 223): first byte of a two-byte sequence.
* E0 to EF hex (224 to 239): first byte of a three-byte sequence.
* F0 to FF hex (240 to 255): first byte of a four-byte sequence.
*/
if ( c <= 0xf7 ) {
count = 1;
} else if ( c >= 0xc2 && c <= 0xdf ) {
count = 2;
} else if ( c >= 0xe0 && c <= 0xef ) {
count = 3;
} else if ( c >= 0xf0 && c <= 0xff ) {
count = 4;
}
if ( count > 1 ) {
url_fgets( ( char * ) &cbuff[1], count, input );
}
mbstowcs( wbuff, cbuff, 2 ); //(char *)(&input->buffer[input->buffer_pos]), 1 );
result = wbuff[0];
free( wbuff );
free( cbuff );
}
break;
case CFTYPE_NONE:
break;
}
}
debug_printf( DEBUG_IO, L"url_fgetwc returning %d (%C)\n", result,
result );
return result;
}
wint_t url_ungetwc( wint_t wc, URL_FILE *input ) {
wint_t result = -1;
switch ( input->type ) {
case CFTYPE_FILE:
fwide( input->handle.file, 1 ); /* wide characters */
result = ungetwc( wc, input->handle.file ); /* passthrough */
break;
case CFTYPE_CURL:{
ungotten = wc;
break;
case CFTYPE_NONE:
break;
}
}
return result;
}
/**
* Function, sort-of: close the file indicated by my first arg, and return
* nil. If the first arg is not a stream, does nothing. All other args are
* ignored.
*
* * (close stream)
*
* @param frame my stack_frame.
* @param frame_pointer a pointer to my stack_frame.
* @param env my environment.
* @return T if the stream was successfully closed, else NIL.
*/
struct cons_pointer
lisp_close( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
struct cons_pointer result = NIL;
if ( readp( frame->arg[0] ) || writep( frame->arg[0] ) ) {
if ( url_fclose( pointer2cell( frame->arg[0] ).payload.stream.stream )
== 0 ) {
result = TRUE;
}
}
return result;
}
struct cons_pointer add_meta_integer( struct cons_pointer meta, wchar_t *key,
long int value ) {
return
make_cons( make_cons
( c_string_to_lisp_keyword( key ),
make_integer( value, NIL ) ), meta );
}
struct cons_pointer add_meta_string( struct cons_pointer meta, wchar_t *key,
char *value ) {
value = trim( value );
wchar_t buffer[strlen( value ) + 1];
mbstowcs( buffer, value, strlen( value ) + 1 );
return make_cons( make_cons( c_string_to_lisp_keyword( key ),
c_string_to_lisp_string( buffer ) ), meta );
}
struct cons_pointer add_meta_time( struct cons_pointer meta, wchar_t *key,
time_t *value ) {
/* I don't yet have a concept of a date-time object, which is a
* bit of an oversight! */
char datestring[256];
strftime( datestring,
sizeof( datestring ),
nl_langinfo( D_T_FMT ), localtime( value ) );
return add_meta_string( meta, key, datestring );
}
/**
* 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( char *string, size_t size, size_t nmemb,
struct cons_pointer stream ) {
struct cons_space_object *cell = &pointer2cell( stream );
/* make a copy of the string that we can destructively change */
char *s = calloc( strlen( string ), sizeof( char ) );
strcpy( s, string );
if ( strncmp( &cell->tag.bytes[0], READTAG, 4 ) ||
strncmp( &cell->tag.bytes[0], WRITETAG, 4 ) ) {
int offset = index_of( ':', s );
if ( offset != -1 ) {
s[offset] = ( char ) 0;
char *name = trim( s );
char *value = trim( &s[++offset] );
wchar_t wname[strlen( name )];
mbstowcs( wname, name, strlen( name ) + 1 );
cell->payload.stream.meta =
add_meta_string( cell->payload.stream.meta, wname, value );
debug_printf( DEBUG_IO,
L"write_meta_callback: added header '%s': value '%s'\n",
name, value );
} else if ( strncmp( "HTTP", s, 4 ) == 0 ) {
int offset = index_of( ' ', s );
char *value = trim( &s[offset] );
cell->payload.stream.meta =
add_meta_integer( add_meta_string
( cell->payload.stream.meta, L"status",
value ), L"status-code", strtol( value,
NULL,
10 ) );
debug_printf( DEBUG_IO,
L"write_meta_callback: added header 'status': value '%s'\n",
value );
} else {
debug_printf( DEBUG_IO,
L"write_meta_callback: header passed with no colon: '%s'\n",
s );
}
} else {
debug_print
( L"Pointer passed to write_meta_callback did not point to a stream: ",
DEBUG_IO );
debug_dump_object( stream, DEBUG_IO );
}
free( s );
return strlen( string );
}
void collect_meta( struct cons_pointer stream, char *url ) {
struct cons_space_object *cell = &pointer2cell( stream );
URL_FILE *s = pointer2cell( stream ).payload.stream.stream;
struct cons_pointer meta =
add_meta_string( cell->payload.stream.meta, L"url", url );
struct stat statbuf;
int result = stat( url, &statbuf );
struct passwd *pwd;
struct group *grp;
switch ( s->type ) {
case CFTYPE_NONE:
break;
case CFTYPE_FILE:
if ( result == 0 ) {
if ( ( pwd = getpwuid( statbuf.st_uid ) ) != NULL ) {
meta = add_meta_string( meta, L"owner", pwd->pw_name );
} else {
meta = add_meta_integer( meta, L"owner", statbuf.st_uid );
}
if ( ( grp = getgrgid( statbuf.st_gid ) ) != NULL ) {
meta = add_meta_string( meta, L"group", grp->gr_name );
} else {
meta = add_meta_integer( meta, L"group", statbuf.st_gid );
}
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_HEADERFUNCTION,
write_meta_callback );
curl_easy_setopt( s->handle.curl, CURLOPT_HEADERDATA, stream );
break;
}
/* this is destructive change before the cell is released into the
* wild, and consequently permissible, just. */
cell->payload.stream.meta = meta;
}
/**
* Resutn the current default input, or of `inputp` is false, output stream from
* this `env`ironment.
*/
struct cons_pointer get_default_stream( bool inputp, struct cons_pointer env ) {
struct cons_pointer result = NIL;
struct cons_pointer stream_name = inputp ? lisp_io_in : lisp_io_out;
result = c_assoc( stream_name, env );
return result;
}
/**
* 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 writing. At
* present, further arguments are ignored and there is no mechanism to open
* to append, or error if the URL is faulty or indicates an unavailable
* resource.
*
* * (open url)
*
* @param frame my stack_frame.
* @param frame_pointer a pointer to my stack_frame.
* @param env my environment.
* @return a string of one character, namely the next available character
* on my stream, if any, else NIL.
*/
struct cons_pointer
lisp_open( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
struct cons_pointer result = NIL;
if ( stringp( frame->arg[0] ) ) {
char *url = lisp_string_to_c_string( frame->arg[0] );
if ( nilp( frame->arg[1] ) ) {
URL_FILE *stream = url_fopen( url, "r" );
debug_printf( DEBUG_IO,
L"lisp_open: stream @ %ld, stream type = %d, stream handle = %ld\n",
( long int ) &stream, ( int ) stream->type,
( long int ) stream->handle.file );
switch ( stream->type ) {
case CFTYPE_NONE:
return
make_exception( c_string_to_lisp_string
( L"Could not open stream" ),
frame_pointer );
break;
case CFTYPE_FILE:
if ( stream->handle.file == NULL ) {
return
make_exception( c_string_to_lisp_string
( L"Could not open file" ),
frame_pointer );
}
break;
case CFTYPE_CURL:
/* can't tell whether a URL is bad without reading it */
break;
}
result = make_read_stream( stream, NIL );
} else {
// TODO: anything more complex is a problem for another day.
URL_FILE *stream = url_fopen( url, "w" );
result = make_write_stream( stream, NIL );
}
if ( pointer2cell( result ).payload.stream.stream == NULL ) {
result = NIL;
} else {
collect_meta( result, url );
}
free( url );
}
return result;
}
/**
* Function: return the next character from the stream indicated by arg 0;
* further arguments are ignored.
*
* * (read-char stream)
*
* @param frame my stack_frame.
* @param frame_pointer a pointer to my stack_frame.
* @param env my environment.
* @return a string of one character, namely the next available character
* on my stream, if any, else NIL.
*/
struct cons_pointer
lisp_read_char( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
struct cons_pointer result = NIL;
if ( readp( frame->arg[0] ) ) {
result =
make_string( url_fgetwc
( pointer2cell( frame->arg[0] ).payload.
stream.stream ), NIL );
}
return result;
}
/**
* Function: return a string representing all characters from the stream
* indicated by arg 0; further arguments are ignored.
*
* TODO: it should be possible to optionally pass a string URL to this function,
*
* * (slurp stream)
*
* @param frame my stack_frame.
* @param frame_pointer a pointer to my stack_frame.
* @param env my environment.
* @return a string of one character, namely the next available character
* on my stream, if any, else NIL.
*/
struct cons_pointer
lisp_slurp( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
struct cons_pointer result = NIL;
if ( readp( frame->arg[0] ) ) {
URL_FILE *stream = pointer2cell( frame->arg[0] ).payload.stream.stream;
struct cons_pointer cursor = make_string( url_fgetwc( stream ), NIL );
result = cursor;
for ( wint_t c = url_fgetwc( stream ); !url_feof( stream ) && c != 0;
c = url_fgetwc( stream ) ) {
debug_print( L"slurp: cursor is: ", DEBUG_IO );
debug_dump_object( cursor, DEBUG_IO );
debug_print( L"; result is: ", DEBUG_IO );
debug_dump_object( result, DEBUG_IO );
debug_println( DEBUG_IO );
struct cons_space_object *cell = &pointer2cell( cursor );
cursor = make_string( ( wchar_t ) c, NIL );
cell->payload.string.cdr = cursor;
}
}
return result;
}

46
src/c/io/io.h Normal file
View file

@ -0,0 +1,46 @@
/*
* io.h
*
* Communication between PSSE and the outside world, via libcurl.
*
* (c) 2019 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#ifndef __psse_io_h
#define __psse_io_h
#include <curl/curl.h>
#include "memory/consspaceobject.h"
extern CURLSH *io_share;
int io_init( );
#define C_IO_IN L"*in*"
#define C_IO_OUT L"*out*"
extern struct cons_pointer lisp_io_in;
extern struct cons_pointer lisp_io_out;
URL_FILE *file_to_url_file( FILE * f );
wint_t url_fgetwc( URL_FILE * input );
wint_t url_ungetwc( wint_t wc, URL_FILE * input );
struct cons_pointer get_default_stream( bool inputp, struct cons_pointer env );
struct cons_pointer
lisp_close( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer
lisp_open( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer
lisp_read_char( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer
lisp_slurp( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env );
char *lisp_string_to_c_string( struct cons_pointer s );
#endif

356
src/c/io/print.c Normal file
View file

@ -0,0 +1,356 @@
/*
* print.c
*
* First pass at a printer, for bootstrapping.
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <ctype.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
/*
* wide characters
*/
#include <wchar.h>
#include <wctype.h>
#include "arith/integer.h"
#include "debug.h"
#include "io/io.h"
#include "io/print.h"
#include "memory/conspage.h"
#include "memory/consspaceobject.h"
#include "memory/hashmap.h"
#include "memory/stack.h"
#include "memory/vectorspace.h"
#include "ops/intern.h"
#include "time/psse_time.h"
/**
* print all the characters in the symbol or string indicated by `pointer`
* onto this `output`; if `pointer` does not indicate a string or symbol,
* don't print anything but just return.
*/
void print_string_contents( URL_FILE *output, struct cons_pointer pointer ) {
while ( stringp( pointer ) || symbolp( pointer ) || keywordp( pointer ) ) {
struct cons_space_object *cell = &pointer2cell( pointer );
wchar_t c = cell->payload.string.character;
if ( c != '\0' ) {
url_fputwc( c, output );
}
pointer = cell->payload.string.cdr;
}
}
/**
* print all the characters in the string indicated by `pointer` onto
* the stream at this `output`, prepending and appending double quote
* characters.
*/
void print_string( URL_FILE *output, struct cons_pointer pointer ) {
url_fputwc( btowc( '"' ), output );
print_string_contents( output, pointer );
url_fputwc( btowc( '"' ), output );
}
/**
* Print a single list cell (cons cell) indicated by `pointer` to the
* stream indicated by `output`. if `initial_space` is `true`, prepend
* a space character.
*/
void
print_list_contents( URL_FILE *output, struct cons_pointer pointer,
bool initial_space ) {
struct cons_space_object *cell = &pointer2cell( pointer );
switch ( cell->tag.value ) {
case CONSTV:
if ( initial_space ) {
url_fputwc( btowc( ' ' ), output );
}
print( output, cell->payload.cons.car );
print_list_contents( output, cell->payload.cons.cdr, true );
break;
case NILTV:
break;
default:
url_fwprintf( output, L" . " );
print( output, pointer );
}
}
void print_list( URL_FILE *output, struct cons_pointer pointer ) {
url_fputws( L"(", output );
print_list_contents( output, pointer, false );
url_fputws( L")", output );
}
void print_map( URL_FILE *output, struct cons_pointer map ) {
if ( hashmapp( map ) ) {
struct vector_space_object *vso = pointer_to_vso( map );
url_fputwc( btowc( '{' ), output );
for ( struct cons_pointer ks = hashmap_keys( map ); !nilp( ks );
ks = c_cdr( ks ) ) {
struct cons_pointer key = c_car( ks );
print( output, key );
url_fputwc( btowc( ' ' ), output );
print( output, hashmap_get( map, key, false ) );
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 = pointer_to_vso( pointer );
switch ( vso->header.tag.value ) {
case HASHTV:
print_map( output, pointer );
break;
case STACKFRAMETV:
dump_stack_trace( output, pointer );
break;
// \todo: others.
default:
fwprintf( stderr, L"Unrecognised vector-space type '%d'\n",
vso->header.tag.value );
}
}
/**
* stolen from https://stackoverflow.com/questions/11656241/how-to-print-uint128-t-number-using-gcc
*/
void print_128bit( URL_FILE *output, __int128_t n ) {
if ( n == 0 ) {
fwprintf( stderr, L"0" );
} else {
char str[40] = { 0 }; // log10(1 << 128) + '\0'
char *s = str + sizeof( str ) - 1; // start at the end
while ( n != 0 ) {
if ( s == str )
return; // never happens
*--s = "0123456789"[n % 10]; // save last digit
n /= 10; // drop it
}
url_fwprintf( output, L"%s", s );
}
}
/**
* Print the cons-space object indicated by `pointer` to the stream indicated
* by `output`.
*/
struct cons_pointer print( URL_FILE *output, struct cons_pointer pointer ) {
struct cons_space_object cell = pointer2cell( pointer );
char *buffer;
/*
* Because tags have values as well as bytes, this if ... else if
* statement can ultimately be replaced by a switch, which will be neater.
*/
switch ( cell.tag.value ) {
case CONSTV:
print_list( output, pointer );
break;
case EXCEPTIONTV:
url_fputws( L"\nException: ", output );
dump_stack_trace( output, pointer );
break;
case FUNCTIONTV:
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 );
print_string_contents( output, s );
dec_ref( s );
break;
case KEYTV:
url_fputws( L":", output );
print_string_contents( output, pointer );
break;
case LAMBDATV:{
url_fputws( L"<Anonymous Function: ", output );
struct cons_pointer to_print =
make_cons( c_string_to_lisp_symbol( L"\u03bb" ),
make_cons( cell.payload.lambda.args,
cell.payload.lambda.body ) );
print( output, to_print );
dec_ref( to_print );
url_fputwc( L'>', output );
}
break;
case NILTV:
url_fwprintf( output, L"nil" );
break;
case NLAMBDATV:{
url_fputws( L"<Anonymous Special Form: ", output );
struct cons_pointer to_print =
make_cons( c_string_to_lisp_symbol( L"n\u03bb" ),
make_cons( cell.payload.lambda.args,
cell.payload.lambda.body ) );
print( output, to_print );
dec_ref( to_print );
url_fputwc( L'>', output );
}
break;
case RATIOTV:
print( output, cell.payload.ratio.dividend );
url_fputws( L"/", output );
print( output, cell.payload.ratio.divisor );
break;
case READTV:
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.
* As soon as I have working vector space I'll use a special purpose
* vector space object */
buffer = ( char * ) malloc( 24 );
memset( buffer, 0, 24 );
/* format it really long, then clear the trailing zeros */
sprintf( buffer, "%-.23Lg", cell.payload.real.value );
if ( strchr( buffer, '.' ) != NULL ) {
for ( int i = strlen( buffer ) - 1; buffer[i] == '0'; i-- ) {
buffer[i] = '\0';
}
}
url_fwprintf( output, L"%s", buffer );
free( buffer );
break;
case STRINGTV:
print_string( output, pointer );
break;
case SYMBOLTV:
print_string_contents( output, pointer );
break;
case SPECIALTV:
url_fwprintf( output, L"<Special form: " );
print( output, cell.payload.special.meta );
url_fputwc( L'>', output );
break;
case TIMETV:
url_fwprintf( output, L"<Time: " );
print_string( output, time_to_string( pointer ) );
url_fputws( L"; ", output );
print_128bit( output, cell.payload.time.value );
url_fputwc( L'>', output );
break;
case TRUETV:
url_fwprintf( output, L"t" );
break;
case VECTORPOINTTV:
print_vso( output, pointer );
break;
case WRITETV:
url_fwprintf( output, L"<Output stream: " );
print( output, cell.payload.stream.meta );
url_fputwc( L'>', output );
break;
default:
fwprintf( stderr,
L"Error: Unrecognised tag value %d (%4.4s)\n",
cell.tag.value, &cell.tag.bytes[0] );
// dump_object( stderr, pointer);
break;
}
return pointer;
}
/**
* Function; print one complete lisp expression and return NIL. If write-stream is specified and
* is a write stream, then print to that stream, else the stream which is the value of
* `*out*` in the environment.
*
* * (print expr)
* * (print expr write-stream)
*
* @param frame my stack_frame.
* @param frame_pointer a pointer to my stack_frame.
* @param env my environment (from which the stream may be extracted).
* @return NIL.
*/
struct cons_pointer
lisp_print( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
debug_print( L"Entering print\n", DEBUG_IO );
struct cons_pointer result = NIL;
URL_FILE *output;
struct cons_pointer out_stream = writep( frame->arg[1] ) ?
frame->arg[1] : get_default_stream( false, env );
if ( writep( out_stream ) ) {
debug_print( L"lisp_print: setting output stream\n", DEBUG_IO );
debug_dump_object( out_stream, DEBUG_IO );
output = pointer2cell( out_stream ).payload.stream.stream;
inc_ref( out_stream );
} else {
output = file_to_url_file( stderr );
}
debug_print( L"lisp_print: about to print\n", DEBUG_IO );
debug_dump_object( frame->arg[0], DEBUG_IO );
result = print( output, frame->arg[0] );
debug_print( L"lisp_print returning\n", DEBUG_IO );
debug_dump_object( result, DEBUG_IO );
if ( writep( out_stream ) ) {
dec_ref( out_stream );
} else {
free( output );
}
return result;
}
void println( URL_FILE *output ) {
url_fputws( L"\n", output );
}
/**
* @brief `(prinln out-stream)`: Print a new line character to `out-stream`, if
* it is specified and is an output stream, else to `*out*`.
*
* @param frame
* @param frame_pointer
* @param env
* @return `nil`
*/
struct cons_pointer
lisp_println( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
URL_FILE *output;
struct cons_pointer out_stream = writep( frame->arg[1] ) ?
frame->arg[1] : get_default_stream( false, env );
if ( writep( out_stream ) ) {
output = pointer2cell( out_stream ).payload.stream.stream;
println( output );
}
return NIL;
}

30
src/c/io/print.h Normal file
View file

@ -0,0 +1,30 @@
/**
* print.h
*
* First pass at a printer, for bootstrapping.
*
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <ctype.h>
#include <stdio.h>
#include "io/fopen.h"
#ifndef __print_h
#define __print_h
struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer );
void println( URL_FILE * output );
struct cons_pointer lisp_print( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_println( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
#endif

570
src/c/io/read.c Normal file
View file

@ -0,0 +1,570 @@
/*
* read.c
*
* First pass at a reader, for bootstrapping.
*
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <math.h>
#include <stdbool.h>
#include <stdio.h>
/*
* wide characters
*/
#include <wchar.h>
#include <wctype.h>
#include "memory/consspaceobject.h"
#include "debug.h"
#include "memory/dump.h"
#include "memory/hashmap.h"
#include "arith/integer.h"
#include "ops/intern.h"
#include "io/io.h"
#include "ops/lispops.h"
#include "arith/peano.h"
#include "io/print.h"
#include "arith/ratio.h"
#include "io/read.h"
#include "arith/real.h"
#include "memory/vectorspace.h"
// We can't, I think, use libreadline, because we read character by character,
// not line by line, and because we use wide characters. So we're going to have
// to reimplement it. So we're going to have to maintain history of the forms
// (or strings, but I currently think forms). So we're going to have to be able
// to detact special keys, particularly, at this stage, the uparrow and down-
// arrow keys
// #include <readline/readline.h>
// #include <readline/history.h>
/*
* for the time being things which may be read are:
* * strings
* * numbers - either integer, ratio or real
* * lists
* * maps
* * keywords
* * atoms
*/
struct cons_pointer read_number( struct stack_frame *frame,
struct cons_pointer frame_pointer,
URL_FILE * input, wint_t initial,
bool seen_period );
struct cons_pointer read_list( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env,
URL_FILE * input, wint_t initial );
struct cons_pointer read_map( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env,
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, uint32_t tag,
wint_t initial );
/**
* quote reader macro in C (!)
*/
struct cons_pointer c_quote( struct cons_pointer arg ) {
return make_cons( c_string_to_lisp_symbol( L"quote" ),
make_cons( arg, NIL ) );
}
/**
* Read a path macro from the stream. A path macro is expected to be
* 1. optionally a leading character such as '/' or '$', followed by
* 2. one or more keywords with leading colons (':') but no intervening spaces; or
* 3. one or more symbols separated by slashes; or
* 4. keywords (with leading colons) interspersed with symbols (prefixed by slashes).
*/
struct cons_pointer read_path( URL_FILE *input, wint_t initial,
struct cons_pointer q ) {
bool done = false;
struct cons_pointer prefix = NIL;
switch ( initial ) {
case '/':
prefix = make_cons( c_string_to_lisp_symbol( L"oblist" ), NIL );
break;
case '$':
case LSESSION:
prefix = c_string_to_lisp_symbol( L"session" );
break;
}
while ( !done ) {
wint_t c = url_fgetwc( input );
if ( iswblank( c ) || iswcntrl( c ) ) {
done = true;
} else if ( url_feof( input ) ) {
done = true;
} else {
switch ( c ) {
case ':':
q = make_cons( read_symbol_or_key
( input, KEYTV, url_fgetwc( input ) ), q );
break;
case '/':
q = make_cons( make_cons
( c_string_to_lisp_symbol( L"quote" ),
make_cons( read_symbol_or_key
( input, SYMBOLTV,
url_fgetwc( input ) ),
NIL ) ), q );
break;
default:
if ( iswalpha( c ) ) {
q = make_cons( read_symbol_or_key
( input, SYMBOLTV, c ), q );
} else {
// TODO: it's really an error. Exception?
url_ungetwc( c, input );
done = true;
}
}
}
}
// right, we now have the path we want (reversed) in q.
struct cons_pointer r = NIL;
for ( struct cons_pointer p = q; !nilp( p ); p = c_cdr( p ) ) {
r = make_cons( c_car( p ), r );
}
dec_ref( q );
if ( !nilp( prefix ) ) {
r = make_cons( prefix, r );
}
return make_cons( c_string_to_lisp_symbol( L"->" ), r );
}
/**
* Read the next object on this input stream and return a cons_pointer to it,
* treating this initial character as the first character of the object
* representation.
*/
struct cons_pointer read_continuation( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env,
URL_FILE *input, wint_t initial ) {
debug_print( L"entering read_continuation\n", DEBUG_IO );
struct cons_pointer result = NIL;
wint_t c;
for ( c = initial;
c == '\0' || iswblank( c ) || iswcntrl( c );
c = url_fgetwc( input ) );
if ( url_feof( input ) ) {
result =
throw_exception( c_string_to_lisp_symbol( L"read" ),
c_string_to_lisp_string
( L"End of file while reading" ), frame_pointer );
} else {
switch ( c ) {
case ';':
for ( c = url_fgetwc( input ); c != '\n';
c = url_fgetwc( input ) );
/* skip all characters from semi-colon to the end of the line */
break;
case EOF:
result = throw_exception( c_string_to_lisp_symbol( L"read" ),
c_string_to_lisp_string
( L"End of input while reading" ),
frame_pointer );
break;
case '\'':
result =
c_quote( read_continuation
( frame, frame_pointer, env, input,
url_fgetwc( input ) ) );
break;
case '(':
result =
read_list( frame, frame_pointer, env, input,
url_fgetwc( input ) );
break;
case '{':
result = read_map( frame, frame_pointer, env, input,
url_fgetwc( input ) );
break;
case '"':
result = read_string( input, url_fgetwc( input ) );
break;
case '-':{
wint_t next = url_fgetwc( input );
url_ungetwc( next, input );
if ( iswdigit( next ) ) {
result =
read_number( frame, frame_pointer, input, c,
false );
} else {
result = read_symbol_or_key( input, SYMBOLTV, c );
}
}
break;
case '.':
{
wint_t next = url_fgetwc( input );
if ( iswdigit( next ) ) {
url_ungetwc( next, input );
result =
read_number( frame, frame_pointer, input, c,
true );
} 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, env,
input, url_fgetwc( input ) );
debug_print
( L"read_continuation: dotted pair; read cdr ",
DEBUG_IO );
} else {
read_symbol_or_key( input, SYMBOLTV, c );
}
}
break;
case ':':
result =
read_symbol_or_key( input, KEYTV, url_fgetwc( input ) );
break;
case '/':
{
/* slash followed by whitespace is legit provided it's not
* preceded by anything - it's the division operator. Otherwise,
* it's terminal, probably part of a path, and needs pushed back.
*/
wint_t cn = url_fgetwc( input );
if ( nilp( result )
&& ( iswblank( cn ) || iswcntrl( cn ) ) ) {
url_ungetwc( cn, input );
result = make_symbol_or_key( c, NIL, SYMBOLTV );
} else {
url_ungetwc( cn, input );
result = read_path( input, c, NIL );
}
}
break;
case '$':
case LSESSION:
result = read_path( input, c, NIL );
break;
default:
if ( iswdigit( c ) ) {
result =
read_number( frame, frame_pointer, input, c, false );
} else if ( iswprint( c ) ) {
result = read_symbol_or_key( input, SYMBOLTV, c );
} else {
result =
throw_exception( c_string_to_lisp_symbol( L"read" ),
make_cons( c_string_to_lisp_string
( L"Unrecognised start of input character" ),
make_string( c, NIL ) ),
frame_pointer );
}
break;
}
}
debug_print( L"read_continuation returning\n", DEBUG_IO );
debug_dump_object( result, DEBUG_IO );
return result;
}
/**
* read a number from this input stream, given this initial character.
* \todo Need to do a lot of inc_ref and dec_ref, to make sure the
* garbage is collected.
*/
struct cons_pointer read_number( struct stack_frame *frame,
struct cons_pointer frame_pointer,
URL_FILE *input,
wint_t initial, bool seen_period ) {
debug_print( L"entering read_number\n", DEBUG_IO );
struct cons_pointer result = acquire_integer( 0, NIL );
/* \todo we really need to be getting `base` from a privileged Lisp name -
* and it should be the same privileged name we use when writing numbers */
struct cons_pointer base = acquire_integer( 10, NIL );
struct cons_pointer dividend = NIL;
int places_of_decimals = 0;
wint_t c;
bool neg = initial == btowc( '-' );
if ( neg ) {
initial = url_fgetwc( input );
}
debug_printf( DEBUG_IO, L"read_number starting '%c' (%d)\n", initial,
initial );
for ( c = initial; iswdigit( c )
|| c == LPERIOD || c == LSLASH || c == LCOMMA;
c = url_fgetwc( input ) ) {
switch ( c ) {
case LPERIOD:
if ( seen_period || !nilp( dividend ) ) {
return throw_exception( c_string_to_lisp_symbol( L"read" ),
c_string_to_lisp_string
( L"Malformed number: too many periods" ),
frame_pointer );
} else {
debug_print( L"read_number: decimal point seen\n",
DEBUG_IO );
seen_period = true;
}
break;
case LSLASH:
if ( seen_period || !nilp( dividend ) ) {
return throw_exception( c_string_to_lisp_symbol( L"read" ),
c_string_to_lisp_string
( L"Malformed number: dividend of rational must be integer" ),
frame_pointer );
} else {
debug_print( L"read_number: ratio slash seen\n",
DEBUG_IO );
dividend = result;
result = acquire_integer( 0, NIL );
// If I do replace_integer_p here instead of acquire_integer,
// and thus reclaim the garbage, I get a regression. Dom't yet
// know why.
}
break;
case LCOMMA:
// silently ignore comma.
break;
default:
result = add_integers( multiply_integers( result, base ),
acquire_integer( ( int ) c -
( int ) '0', NIL ) );
debug_printf( DEBUG_IO,
L"read_number: added character %c, result now ",
c );
debug_print_object( result, DEBUG_IO );
debug_print( L"\n", DEBUG_IO );
if ( seen_period ) {
places_of_decimals++;
}
}
}
/*
* push back the character read which was not a digit
*/
url_ungetwc( c, input );
if ( seen_period ) {
debug_print( L"read_number: converting result to real\n", DEBUG_IO );
struct cons_pointer div = make_ratio( result,
acquire_integer( powl
( to_long_double
( base ),
places_of_decimals ),
NIL ), true );
inc_ref( div );
result = make_real( to_long_double( div ) );
dec_ref( div );
} else if ( integerp( dividend ) ) {
debug_print( L"read_number: converting result to ratio\n", DEBUG_IO );
result = make_ratio( dividend, result, true );
}
if ( neg ) {
debug_print( L"read_number: converting result to negative\n",
DEBUG_IO );
result = negative( result );
}
debug_print( L"read_number returning\n", DEBUG_IO );
debug_dump_object( result, DEBUG_IO );
return result;
}
/**
* Read a list from this input stream, which no longer contains the opening
* left parenthesis.
*/
struct cons_pointer read_list( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env,
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 );
struct cons_pointer car =
read_continuation( frame, frame_pointer, env, input,
initial );
/* skip whitespace */
for ( c = url_fgetwc( input );
iswblank( c ) || iswcntrl( c ); c = url_fgetwc( input ) );
if ( c == LPERIOD ) {
/* 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,
env,
input, url_fgetwc( input ) ) ) );
} else {
result =
make_cons( car,
read_list( frame, frame_pointer, env, input, c ) );
}
} else {
debug_print( L"End of list detected\n", DEBUG_IO );
}
return result;
}
struct cons_pointer read_map( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env,
URL_FILE *input, wint_t initial ) {
// set write ACL to true whilst creating to prevent GC churn
struct cons_pointer result =
make_hashmap( DFLT_HASHMAP_BUCKETS, NIL, TRUE );
wint_t c = initial;
while ( c != LCBRACE ) {
struct cons_pointer key =
read_continuation( frame, frame_pointer, env, 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, env, input, c );
/* skip commaa and whitespace at this point. */
for ( c = url_fgetwc( input );
c == LCOMMA || iswblank( c ) || iswcntrl( c );
c = url_fgetwc( input ) );
result =
hashmap_put( result, key,
eval_form( frame, frame_pointer, value, env ) );
}
// default write ACL for maps should be NIL.
pointer_to_vso( result )->payload.hashmap.write_acl = 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
* not contain a double quote character (unless escaped), or one not
* so delimited in which case it may not contain whitespace (unless escaped)
* but may contain a double quote character (probably not a good idea!)
*/
struct cons_pointer read_string( URL_FILE *input, wint_t initial ) {
struct cons_pointer cdr = NIL;
struct cons_pointer result;
switch ( initial ) {
case '\0':
result = NIL;
break;
case '"':
/* making a string of the null character means we can have an empty
* string. Just returning NIL here would make an empty string
* impossible. */
result = make_string( '\0', NIL );
break;
default:
result =
make_string( initial,
read_string( input, url_fgetwc( input ) ) );
break;
}
return result;
}
struct cons_pointer read_symbol_or_key( URL_FILE *input, uint32_t tag,
wint_t initial ) {
struct cons_pointer cdr = NIL;
struct cons_pointer result;
switch ( initial ) {
case '\0':
result = make_symbol_or_key( initial, NIL, tag );
break;
case '"':
case '\'':
/* unwise to allow embedded quotation marks in symbols */
case ')':
case ':':
case '/':
/*
* symbols and keywords may not include right-parenthesis,
* slashes or colons.
*/
result = NIL;
/*
* push back the character read
*/
url_ungetwc( initial, input );
break;
default:
if ( iswprint( initial )
&& !iswblank( initial ) ) {
result =
make_symbol_or_key( initial,
read_symbol_or_key( input,
tag,
url_fgetwc
( input ) ), tag );
} else {
result = NIL;
/*
* push back the character read
*/
url_ungetwc( initial, input );
}
break;
}
debug_print( L"read_symbol_or_key returning\n", DEBUG_IO );
debug_dump_object( result, DEBUG_IO );
return result;
}
/**
* Read the next object on this input stream and return a cons_pointer to it.
*/
struct cons_pointer read( struct
stack_frame
*frame, struct cons_pointer frame_pointer,
struct cons_pointer env, URL_FILE *input ) {
return read_continuation( frame, frame_pointer, env, input,
url_fgetwc( input ) );
}

32
src/c/io/read.h Normal file
View file

@ -0,0 +1,32 @@
/**
* read.c
*
* First pass at a reader, for bootstrapping.
*
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#ifndef __read_h
#define __read_h
#include "memory/consspaceobject.h"
/* characters (other than arabic numberals) used in number representations */
#define LCOMMA L','
#define LPERIOD L'.'
#define LSLASH L'/'
/* ... used in map representations */
#define LCBRACE L'}'
/* ... used in path representations */
#define LSESSION L'§'
/**
* read the next object on this input stream and return a cons_pointer to it.
*/
struct cons_pointer read( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env, URL_FILE * input );
#endif

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

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

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

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

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

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

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

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

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

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

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

Binary file not shown.

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

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

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

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

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

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

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

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

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

File diff suppressed because it is too large Load diff

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

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

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

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

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

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

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

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

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

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

433
src/c/ops/equal.c Normal file
View file

@ -0,0 +1,433 @@
/*
* equal.c
*
* Checks for shallow and deep equality
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <math.h>
#include <stdbool.h>
#include <string.h>
#include "arith/integer.h"
#include "arith/peano.h"
#include "arith/ratio.h"
#include "debug.h"
#include "memory/conspage.h"
#include "memory/consspaceobject.h"
#include "memory/vectorspace.h"
#include "ops/equal.h"
#include "ops/intern.h"
/**
* Shallow, and thus cheap, equality: true if these two objects are
* the same object, else false.
*/
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;
}
/**
* Some strings will be null terminated and some will be NIL terminated... ooops!
* @param string the string to test
* @return true if it's the end of a string.
*/
bool end_of_string( struct cons_pointer string ) {
return nilp( string ) ||
pointer2cell( string ).payload.string.character == '\0';
}
/**
* @brief compare two long doubles and returns true if they are the same to
* within a tolerance of one part in a billion.
*
* @param a
* @param b
* @return true if `a` and `b` are equal to within one part in a billion.
* @return false otherwise.
*/
bool equal_ld_ld( long double a, long double b ) {
long double fa = fabsl( a );
long double fb = fabsl( b );
/* difference of magnitudes */
long double diff = fabsl( fa - fb );
/* average magnitude of the two */
long double av = ( fa > fb ) ? ( fa - diff ) : ( fb - diff );
/* amount of difference we will tolerate for equality */
long double tolerance = av * 0.000000001;
bool result = ( fabsl( a - b ) < tolerance );
debug_printf( DEBUG_EQUAL, L"\nequal_ld_ld returning %d\n", result );
return result;
}
/**
* @brief Private function, don't use. It depends on its arguments being
* numbers and doesn't sanity check them.
*
* @param a a lisp integer -- if it isn't an integer, things will break.
* @param b a lisp real -- if it isn't a real, things will break.
* @return true if the two numbers have equal value.
* @return false if they don't.
*/
bool equal_integer_real( struct cons_pointer a, struct cons_pointer b ) {
debug_print( L"\nequal_integer_real: ", DEBUG_ARITH );
debug_print_object( a, DEBUG_ARITH );
debug_print( L" = ", DEBUG_ARITH );
debug_print_object( b, DEBUG_ARITH );
bool result = false;
struct cons_space_object *cell_a = &pointer2cell( a );
struct cons_space_object *cell_b = &pointer2cell( b );
if ( nilp( cell_a->payload.integer.more ) ) {
result =
equal_ld_ld( ( long double ) cell_a->payload.integer.value,
cell_b->payload.real.value );
} else {
fwprintf( stderr,
L"\nequality is not yet implemented for bignums compared to reals." );
}
debug_printf( DEBUG_ARITH, L"\nequal_integer_real returning %d\n",
result );
return result;
}
/**
* @brief Private function, don't use. It depends on its arguments being
* numbers and doesn't sanity check them.
*
* @param a a lisp integer -- if it isn't an integer, things will break.
* @param b a lisp number.
* @return true if the two numbers have equal value.
* @return false if they don't.
*/
bool equal_integer_number( struct cons_pointer a, struct cons_pointer b ) {
debug_print( L"\nequal_integer_number: ", DEBUG_ARITH );
debug_print_object( a, DEBUG_ARITH );
debug_print( L" = ", DEBUG_ARITH );
debug_print_object( b, DEBUG_ARITH );
bool result = false;
struct cons_space_object *cell_b = &pointer2cell( b );
switch ( cell_b->tag.value ) {
case INTEGERTV:
result = equal_integer_integer( a, b );
break;
case REALTV:
result = equal_integer_real( a, b );
break;
case RATIOTV:
result = false;
break;
}
debug_printf( DEBUG_ARITH, L"\nequal_integer_number returning %d\n",
result );
return result;
}
/**
* @brief Private function, don't use. It depends on its arguments being
* numbers and doesn't sanity check them.
*
* @param a a lisp real -- if it isn't an real, things will break.
* @param b a lisp number.
* @return true if the two numbers have equal value.
* @return false if they don't.
*/
bool equal_real_number( struct cons_pointer a, struct cons_pointer b ) {
debug_print( L"\nequal_real_number: ", DEBUG_ARITH );
debug_print_object( a, DEBUG_ARITH );
debug_print( L" = ", DEBUG_ARITH );
debug_print_object( b, DEBUG_ARITH );
bool result = false;
struct cons_space_object *cell_b = &pointer2cell( b );
switch ( cell_b->tag.value ) {
case INTEGERTV:
result = equal_integer_real( b, a );
break;
case REALTV:{
struct cons_space_object *cell_a = &pointer2cell( a );
result =
equal_ld_ld( cell_a->payload.real.value,
cell_b->payload.real.value );
}
break;
case RATIOTV:
struct cons_space_object *cell_a = &pointer2cell( a );
result =
equal_ld_ld( c_ratio_to_ld( b ), cell_a->payload.real.value );
break;
}
debug_printf( DEBUG_ARITH, L"\nequal_real_number returning %d\n", result );
return result;
}
/**
* @brief Private function, don't use. It depends on its arguments being
* numbers and doesn't sanity check them.
*
* @param a a number
* @param b a number
* @return true if the two numbers have equal value.
* @return false if they don't.
*/
bool equal_number_number( struct cons_pointer a, struct cons_pointer b ) {
bool result = eq( a, b );
debug_print( L"\nequal_number_number: ", DEBUG_ARITH );
debug_print_object( a, DEBUG_ARITH );
debug_print( L" = ", DEBUG_ARITH );
debug_print_object( b, DEBUG_ARITH );
if ( !result ) {
struct cons_space_object *cell_a = &pointer2cell( a );
struct cons_space_object *cell_b = &pointer2cell( b );
switch ( cell_a->tag.value ) {
case INTEGERTV:
result = equal_integer_number( a, b );
break;
case REALTV:
result = equal_real_number( a, b );
break;
case RATIOTV:
switch ( cell_b->tag.value ) {
case INTEGERTV:
/* as ratios are simplified by make_ratio, any
* ratio that would simplify to an integer is an
* integer, TODO: no longer always true. */
result = false;
break;
case REALTV:
result = equal_real_number( b, a );
break;
case RATIOTV:
result = equal_ratio_ratio( a, b );
break;
/* can't throw an exception from here, but non-numbers
* shouldn't have been passed in anyway, so no default. */
}
break;
/* can't throw an exception from here, but non-numbers
* shouldn't have been passed in anyway, so no default. */
}
}
debug_printf( DEBUG_ARITH, L"\nequal_number_number returning %d\n",
result );
return result;
}
/**
* @brief equality of two map-like things.
*
* The list returned by `keys` on a map-like thing is not sorted, and is not
* guaranteed always to come out in the same order. So equality is established
* if:
* 1. the length of the keys list is the same; and
* 2. the value of each key in the keys list for map `a` is the same in map `a`
* and in map `b`.
*
* Private function, do not use outside this file, **WILL NOT** work
* unless both arguments are VECPs.
*
* @param a a pointer to a vector space object.
* @param b another pointer to a vector space object.
* @return true if the two objects have the same logical structure.
* @return false otherwise.
*/
bool equal_map_map( struct cons_pointer a, struct cons_pointer b ) {
bool result = false;
struct cons_pointer keys_a = hashmap_keys( a );
if ( c_length( keys_a ) == c_length( hashmap_keys( b ) ) ) {
result = true;
for ( struct cons_pointer i = keys_a; !nilp( i ); i = c_cdr( i ) ) {
struct cons_pointer key = c_car( i );
if ( !equal
( hashmap_get( a, key, false ),
hashmap_get( b, key, false ) ) ) {
result = false;
break;
}
}
}
return result;
}
/**
* @brief equality of two vector-space things.
*
* Expensive, but we need to be able to check for equality of at least hashmaps
* and namespaces.
*
* Private function, do not use outside this file, not guaranteed to work
* unless both arguments are VECPs pointing to map like things.
*
* @param a a pointer to a vector space object.
* @param b another pointer to a vector space object.
* @return true if the two objects have the same logical structure.
* @return false otherwise.
*/
bool equal_vector_vector( struct cons_pointer a, struct cons_pointer b ) {
bool result = false;
if ( eq( a, b ) ) {
result = true; // same
/* there shouldn't ever be two separate VECP cells which point to the
* same address in vector space, so I don't believe it's worth checking
* for this.
*/
} else if ( vectorp( a ) && vectorp( b ) ) {
struct vector_space_object *va = pointer_to_vso( a );
struct vector_space_object *vb = pointer_to_vso( b );
/* what we're saying here is that a namespace is not equal to a map,
* even if they have identical logical structure. Is this right? */
if ( va->header.tag.value == vb->header.tag.value ) {
switch ( va->header.tag.value ) {
case HASHTV:
case NAMESPACETV:
result = equal_map_map( a, b );
break;
}
}
}
// else can't throw an exception from here but TODO: should log.
return result;
}
/**
* Deep, and thus expensive, equality: true if these two objects have
* identical structure, else false.
*/
bool equal( struct cons_pointer a, struct cons_pointer b ) {
debug_print( L"\nequal: ", DEBUG_EQUAL );
debug_print_object( a, DEBUG_EQUAL );
debug_print( L" = ", DEBUG_EQUAL );
debug_print_object( b, DEBUG_EQUAL );
bool result = false;
if ( eq( a, b ) ) {
result = true;
} else if ( !numberp( a ) && same_type( a, b ) ) {
struct cons_space_object *cell_a = &pointer2cell( a );
struct cons_space_object *cell_b = &pointer2cell( b );
switch ( cell_a->tag.value ) {
case CONSTV:
case LAMBDATV:
case NLAMBDATV:
/* TODO: it is not OK to do this on the stack since list-like
* structures can be of indefinite extent. It *must* be done by
* iteration (and even that is problematic) */
result =
equal( cell_a->payload.cons.car, cell_b->payload.cons.car )
&& equal( cell_a->payload.cons.cdr,
cell_b->payload.cons.cdr );
break;
case KEYTV:
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
* practice only the empty string will.
*/
/* TODO: it is not OK to do this on the stack since list-like
* structures can be of indefinite extent. It *must* be done by
* iteration (and even that is problematic) */
if ( cell_a->payload.string.hash ==
cell_b->payload.string.hash ) {
wchar_t a_buff[STRING_SHIPYARD_SIZE],
b_buff[STRING_SHIPYARD_SIZE];
uint32_t tag = cell_a->tag.value;
int i = 0;
memset( a_buff, 0, sizeof( a_buff ) );
memset( b_buff, 0, sizeof( b_buff ) );
for ( ; ( i < ( STRING_SHIPYARD_SIZE - 1 ) ) && !nilp( a )
&& !nilp( b ); i++ ) {
a_buff[i] = cell_a->payload.string.character;
a = c_cdr( a );
cell_a = &pointer2cell( a );
b_buff[i] = cell_b->payload.string.character;
b = c_cdr( b );
cell_b = &pointer2cell( b );
}
#ifdef DEBUG
debug_print( L"Comparing '", DEBUG_EQUAL );
debug_print( a_buff, DEBUG_EQUAL );
debug_print( L"' to '", DEBUG_EQUAL );
debug_print( b_buff, DEBUG_EQUAL );
debug_print( L"'\n", DEBUG_EQUAL );
#endif
/* OK, now we have wchar string buffers loaded from the objects. We
* may not have exhausted either string, so the buffers being equal
* isn't sufficient. So we recurse at least once. */
result = ( wcsncmp( a_buff, b_buff, i ) == 0 )
&& equal( c_cdr( a ), c_cdr( b ) );
}
break;
case VECTORPOINTTV:
if ( cell_b->tag.value == VECTORPOINTTV ) {
result = equal_vector_vector( a, b );
} else {
result = false;
}
break;
default:
result = false;
break;
}
} else if ( numberp( a ) && numberp( b ) ) {
result = equal_number_number( a, b );
}
/*
* there's only supposed ever to be one T and one NIL cell, so each
* should be caught by eq.
*
* I'm not certain what equality means for read and write streams, so
* I'll ignore them, too, for now.
*/
debug_printf( DEBUG_EQUAL, L"\nequal returning %d\n", result );
return result;
}

36
src/c/ops/equal.h Normal file
View file

@ -0,0 +1,36 @@
/**
* equal.h
*
* Checks for shallow and deep equality
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <math.h>
#include <stdbool.h>
#include "consspaceobject.h"
#ifndef __equal_h
#define __equal_h
/**
* size of buffer for assembling strings. Likely to be useful to
* read, too.
*/
#define STRING_SHIPYARD_SIZE 1024
/**
* Shallow, and thus cheap, equality: true if these two objects are
* the same object, else false.
*/
bool eq( struct cons_pointer a, struct cons_pointer b );
/**
* Deep, and thus expensive, equality: true if these two objects have
* identical structure, else false.
*/
bool equal( struct cons_pointer a, struct cons_pointer b );
#endif

574
src/c/ops/intern.c Normal file
View file

@ -0,0 +1,574 @@
/*
* intern.c
*
* For now this implements an oblist and shallow binding; local environments can
* be consed onto the front of the oblist. Later, this won't do; bindings will happen
* in namespaces, which will probably be implemented as hash tables.
*
* Doctrine is that cons cells are immutable, and life is a lot more simple if they are;
* so when a symbol is rebound in the master oblist, what in fact we do is construct
* a new oblist without the previous binding but with the new binding. Anything which,
* prior to this action, held a pointer to the old oblist (as all current threads'
* environments must do) continues to hold a pointer to the old oblist, and consequently
* doesn't see the change. This is probably good but does mean you cannot use bindings
* on the oblist to signal between threads.
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <stdbool.h>
#include <string.h>
/*
* wide characters
*/
#include <wchar.h>
#include <wctype.h>
#include "authorise.h"
#include "debug.h"
#include "io/io.h"
#include "memory/conspage.h"
#include "memory/consspaceobject.h"
#include "memory/hashmap.h"
#include "ops/equal.h"
#include "ops/intern.h"
#include "ops/lispops.h"
// #include "print.h"
/**
* @brief The global object list/or, to put it differently, the root namespace.
* What is added to this during system setup is 'global', that is,
* visible to all sessions/threads. What is added during a session/thread is local to
* that session/thread (because shallow binding). There must be some way for a user to
* make the contents of their own environment persistent between threads but I don't
* know what it is yet. At some stage there must be a way to rebind deep values so
* 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;
/**
* @brief the symbol `NIL`, which is special!
*
*/
struct cons_pointer privileged_symbol_nil = NIL;
/**
* Return a hash value for the structure indicated by `ptr` such that if
* `x`,`y` are two separate structures whose print representation is the same
* then `(sxhash x)` and `(sxhash y)` will always be equal.
*/
uint32_t sxhash( struct cons_pointer ptr ) {
// TODO: Not Yet Implemented
/* TODO: should look at the implementation of Common Lisp sxhash?
* My current implementation of `print` only addresses URL_FILE
* streams. It would be better if it also addressed strings but
* currently it doesn't. Creating a print string of the structure
* and taking the hash of that would be one simple (but not necessarily
* cheap) solution.
*/
/* TODO: sbcl's implementation of `sxhash` is in src/compiler/sxhash.lisp
* and is EXTREMELY complex, and essentially has a different dispatch for
* every type of object. It's likely we need to do the same.
*/
return 0;
}
/**
* Get the hash value for the cell indicated by this `ptr`; currently only
* implemented for string like things and integers.
*/
uint32_t get_hash( struct cons_pointer ptr ) {
struct cons_space_object *cell = &pointer2cell( ptr );
uint32_t result = 0;
switch ( cell->tag.value ) {
case INTEGERTV:
/* Note that we're only hashing on the least significant word of an
* integer. */
result = cell->payload.integer.value & 0xffffffff;
break;
case KEYTV:
case STRINGTV:
case SYMBOLTV:
result = cell->payload.string.hash;
break;
case TRUETV:
result = 1; // arbitrarily
break;
default:
result = sxhash( ptr );
break;
}
return result;
}
/**
* Free the hashmap indicated by this `pointer`.
*/
void free_hashmap( struct cons_pointer pointer ) {
struct cons_space_object *cell = &pointer2cell( pointer );
if ( hashmapp( pointer ) ) {
struct vector_space_object *vso = cell->payload.vectorp.address;
dec_ref( vso->payload.hashmap.hash_fn );
dec_ref( vso->payload.hashmap.write_acl );
for ( int i = 0; i < vso->payload.hashmap.n_buckets; i++ ) {
if ( !nilp( vso->payload.hashmap.buckets[i] ) ) {
debug_printf( DEBUG_ALLOC,
L"Decrementing bucket [%d] of hashmap at 0x%lx\n",
i, cell->payload.vectorp.address );
dec_ref( vso->payload.hashmap.buckets[i] );
}
}
} else {
debug_printf( DEBUG_ALLOC, L"Non-hashmap passed to `free_hashmap`\n" );
}
}
/**
* Make a hashmap with this number of buckets, using this `hash_fn`. If
* `hash_fn` is `NIL`, use the standard hash funtion.
*/
struct cons_pointer make_hashmap( uint32_t n_buckets,
struct cons_pointer hash_fn,
struct cons_pointer write_acl ) {
struct cons_pointer result = make_vso( HASHTV,
( sizeof( struct cons_pointer ) *
( n_buckets + 2 ) ) +
( sizeof( uint32_t ) * 2 ) );
struct hashmap_payload *payload =
( struct hashmap_payload * ) &pointer_to_vso( result )->payload;
payload->hash_fn = inc_ref( hash_fn );
payload->write_acl = inc_ref( write_acl );
payload->n_buckets = n_buckets;
for ( int i = 0; i < n_buckets; i++ ) {
payload->buckets[i] = NIL;
}
return result;
}
/**
* return a flat list of all the keys in the hashmap indicated by `map`.
*/
struct cons_pointer hashmap_keys( struct cons_pointer mapp ) {
struct cons_pointer result = NIL;
if ( hashmapp( mapp ) && truep( authorised( mapp, NIL ) ) ) {
struct vector_space_object *map = pointer_to_vso( mapp );
for ( int i = 0; i < map->payload.hashmap.n_buckets; i++ ) {
for ( struct cons_pointer c = map->payload.hashmap.buckets[i];
!nilp( c ); c = c_cdr( c ) ) {
result = make_cons( c_car( c_car( c ) ), result );
}
}
}
return result;
}
/**
* Copy all key/value pairs in this association list `assoc` into this hashmap `mapp`. If
* current user is authorised to write to this hashmap, modifies the hashmap and
* returns it; if not, clones the hashmap, modifies the clone, and returns that.
*/
struct cons_pointer hashmap_put_all( struct cons_pointer mapp,
struct cons_pointer assoc ) {
// TODO: if current user has write access to this hashmap
if ( hashmapp( mapp ) ) {
struct vector_space_object *map = pointer_to_vso( mapp );
if ( consp( assoc ) ) {
for ( struct cons_pointer pair = c_car( assoc ); !nilp( pair );
pair = c_car( assoc ) ) {
/* TODO: this is really hammering the memory management system, because
* it will make a new clone for every key/value pair added. Fix. */
if ( consp( pair ) ) {
mapp = hashmap_put( mapp, c_car( pair ), c_cdr( pair ) );
} else if ( hashmapp( pair ) ) {
hashmap_put_all( mapp, pair );
} else {
hashmap_put( mapp, pair, TRUE );
}
assoc = c_cdr( assoc );
}
} else if ( hashmapp( assoc ) ) {
for ( struct cons_pointer keys = hashmap_keys( assoc );
!nilp( keys ); keys = c_cdr( keys ) ) {
struct cons_pointer key = c_car( keys );
hashmap_put( mapp, key, hashmap_get( assoc, key, false ) );
}
}
}
return mapp;
}
/** Get a value from a hashmap.
*
* Note that this is here, rather than in memory/hashmap.c, because it is
* closely tied in with search_store, q.v.
*/
struct cons_pointer hashmap_get( struct cons_pointer mapp,
struct cons_pointer key, bool return_key ) {
#ifdef DEBUG
debug_print( L"\nhashmap_get: key is `", DEBUG_BIND );
debug_print_object( key, DEBUG_BIND );
debug_print( L"`; store of type `", DEBUG_BIND );
debug_print_object( c_type( mapp ), DEBUG_BIND );
debug_printf( DEBUG_BIND, L"`; returning `%s`.\n",
return_key ? "key" : "value" );
#endif
struct cons_pointer result = NIL;
if ( hashmapp( mapp ) && truep( authorised( mapp, NIL ) ) && !nilp( key ) ) {
struct vector_space_object *map = pointer_to_vso( mapp );
uint32_t bucket_no = get_hash( key ) % map->payload.hashmap.n_buckets;
result =
search_store( key, map->payload.hashmap.buckets[bucket_no],
return_key );
}
#ifdef DEBUG
debug_print( L"\nhashmap_get returning: `", DEBUG_BIND );
debug_print_object( result, DEBUG_BIND );
debug_print( L"`\n", DEBUG_BIND );
#endif
return result;
}
/**
* If this `ptr` is a pointer to a hashmap, return a new identical hashmap;
* else return an exception.
*/
struct cons_pointer clone_hashmap( struct cons_pointer ptr ) {
struct cons_pointer result = NIL;
if ( truep( authorised( ptr, NIL ) ) ) {
if ( hashmapp( ptr ) ) {
struct vector_space_object const *from = pointer_to_vso( ptr );
if ( from != NULL ) {
struct hashmap_payload from_pl = from->payload.hashmap;
result =
make_hashmap( from_pl.n_buckets, from_pl.hash_fn,
from_pl.write_acl );
struct vector_space_object const *to =
pointer_to_vso( result );
struct hashmap_payload to_pl = to->payload.hashmap;
for ( int i = 0; i < to_pl.n_buckets; i++ ) {
to_pl.buckets[i] = from_pl.buckets[i];
inc_ref( to_pl.buckets[i] );
}
}
}
} else {
result =
make_exception( c_string_to_lisp_string
( L"Arg to `clone_hashmap` must "
L"be a readable hashmap.`" ), NIL );
}
return result;
}
/**
* @brief `(search-store key store return-key?)` Search this `store` for this
* a key lexically identical to this `key`.
*
* If found, then, if `return-key?` is non-nil, return the copy found in the
* `store`, else return the value associated with it.
*
* At this stage the following structures are legal stores:
* 1. an association list comprising (key . value) dotted pairs;
* 2. a hashmap;
* 3. a namespace (which for these purposes is identical to a hashmap);
* 4. a hybrid list comprising both (key . value) pairs and hashmaps as first
* level items;
* 5. such a hybrid list, but where the last CDR pointer is to a hashmap
* rather than to a cons sell or to `nil`.
*
* This is over-complex and type 5 should be disallowed, but it will do for
* now.
*/
struct cons_pointer search_store( struct cons_pointer key,
struct cons_pointer store,
bool return_key ) {
struct cons_pointer result = NIL;
#ifdef DEBUG
debug_print( L"\nsearch_store; key is `", DEBUG_BIND );
debug_print_object( key, DEBUG_BIND );
debug_print( L"`; store of type `", DEBUG_BIND );
debug_print_object( c_type( store ), DEBUG_BIND );
debug_printf( DEBUG_BIND, L"`; returning `%s`.\n",
return_key ? "key" : "value" );
#endif
switch ( get_tag_value( key ) ) {
case SYMBOLTV:
case KEYTV:
struct cons_space_object *store_cell = &pointer2cell( store );
switch ( get_tag_value( store ) ) {
case CONSTV:
for ( struct cons_pointer cursor = store;
nilp( result ) && ( consp( cursor )
|| hashmapp( cursor ) );
cursor = pointer2cell( cursor ).payload.cons.cdr ) {
switch ( get_tag_value( cursor ) ) {
case CONSTV:
struct cons_pointer entry_ptr =
c_car( cursor );
switch ( get_tag_value( entry_ptr ) ) {
case CONSTV:
if ( equal( key, c_car( entry_ptr ) ) ) {
result =
return_key ? c_car( entry_ptr )
: c_cdr( entry_ptr );
goto found;
}
break;
case HASHTV:
case NAMESPACETV:
result =
hashmap_get( entry_ptr, key,
return_key );
break;
default:
result =
throw_exception
( c_string_to_lisp_symbol
( L"search-store (entry)" ),
make_cons
( c_string_to_lisp_string
( L"Unexpected store type: " ),
c_type( c_car( entry_ptr ) ) ),
NIL );
}
break;
case HASHTV:
case NAMESPACETV:
debug_print
( L"\n\tHashmap as top-level value in list",
DEBUG_BIND );
result =
hashmap_get( cursor, key, return_key );
break;
default:
result =
throw_exception( c_string_to_lisp_symbol
( L"search-store (cursor)" ),
make_cons
( c_string_to_lisp_string
( L"Unexpected store type: " ),
c_type( cursor ) ),
NIL );
}
}
break;
case HASHTV:
case NAMESPACETV:
result = hashmap_get( store, key, return_key );
break;
default:
result =
throw_exception( c_string_to_lisp_symbol
( L"search-store (store)" ),
make_cons( c_string_to_lisp_string
( L"Unexpected store type: " ),
c_type( store ) ), NIL );
break;
}
break;
case EXCEPTIONTV:
result =
throw_exception( c_string_to_lisp_symbol
( L"search-store (exception)" ),
make_cons( c_string_to_lisp_string
( L"Unexpected key type: " ),
c_type( key ) ), NIL );
break;
default:
result =
throw_exception( c_string_to_lisp_symbol
( L"search-store (key)" ),
make_cons( c_string_to_lisp_string
( L"Unexpected key type: " ),
c_type( key ) ), NIL );
}
found:
debug_print( L"search-store: returning `", DEBUG_BIND );
debug_print_object( result, DEBUG_BIND );
debug_print( L"`\n", DEBUG_BIND );
return result;
}
struct cons_pointer interned( struct cons_pointer key,
struct cons_pointer store ) {
return search_store( key, store, true );
}
/**
* @brief Implementation of `interned?` in C.
*
* @param key the key to search for.
* @param store the store to search in.
* @return struct cons_pointer `t` if the key was found, else `nil`.
*/
struct cons_pointer internedp( struct cons_pointer key,
struct cons_pointer store ) {
struct cons_pointer result = NIL;
if ( consp( store ) ) {
for ( struct cons_pointer pair = c_car( store );
eq( result, NIL ) && !nilp( pair ); pair = c_car( store ) ) {
if ( consp( pair ) ) {
if ( equal( c_car( pair ), key ) ) {
// yes, this should be `eq`, but if symbols are correctly
// interned this will work efficiently, and if not it will
// still work.
result = TRUE;
}
} else if ( hashmapp( pair ) ) {
result = internedp( key, pair );
}
store = c_cdr( store );
}
} else if ( hashmapp( store ) ) {
struct vector_space_object *map = pointer_to_vso( store );
for ( int i = 0; i < map->payload.hashmap.n_buckets; i++ ) {
for ( struct cons_pointer c = map->payload.hashmap.buckets[i];
!nilp( c ); c = c_cdr( c ) ) {
result = internedp( key, c );
}
}
}
return result;
}
/**
* Implementation of assoc in C. Like interned?, the final implementation will
* deal with stores which can be association lists or hashtables or hybrids of
* the two, but that will almost certainly be implemented in lisp.
*
* If this key is lexically identical to a key in this store, return the value
* of that key from the store; otherwise return NIL.
*/
struct cons_pointer c_assoc( struct cons_pointer key,
struct cons_pointer store ) {
return search_store( key, store, false );
}
/**
* Store this `val` as the value of this `key` in this hashmap `mapp`. If
* current user is authorised to write to this hashmap, modifies the hashmap and
* returns it; if not, clones the hashmap, modifies the clone, and returns that.
*/
struct cons_pointer hashmap_put( struct cons_pointer mapp,
struct cons_pointer key,
struct cons_pointer val ) {
if ( hashmapp( mapp ) && !nilp( key ) ) {
struct vector_space_object *map = pointer_to_vso( mapp );
if ( nilp( authorised( mapp, map->payload.hashmap.write_acl ) ) ) {
mapp = clone_hashmap( mapp );
map = pointer_to_vso( mapp );
}
uint32_t bucket_no = get_hash( key ) % map->payload.hashmap.n_buckets;
// TODO: if there are too many values in the bucket, rehash the whole
// hashmap to a bigger number of buckets, and return that.
map->payload.hashmap.buckets[bucket_no] =
make_cons( make_cons( key, val ),
map->payload.hashmap.buckets[bucket_no] );
}
debug_print( L"hashmap_put:\n", DEBUG_BIND );
debug_dump_object( mapp, DEBUG_BIND );
return mapp;
}
/**
* If this store is modifiable, add this key value pair to it. Otherwise,
* 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 set( struct cons_pointer key, struct cons_pointer value,
struct cons_pointer store ) {
struct cons_pointer result = NIL;
#ifdef DEBUG
bool deep = eq( store, oblist );
debug_print_binding( key, value, deep, DEBUG_BIND );
if ( deep ) {
debug_printf( DEBUG_BIND, L"\t-> %4.4s\n",
pointer2cell( store ).payload.vectorp.tag.bytes );
}
#endif
if ( nilp( store ) || consp( store ) ) {
result = make_cons( make_cons( key, value ), store );
} else if ( hashmapp( store ) ) {
result = hashmap_put( store, key, value );
}
return result;
}
/**
* @brief Binds this `key` to this `value` in the global oblist, and returns the `key`.
*/
struct cons_pointer
deep_bind( struct cons_pointer key, struct cons_pointer value ) {
debug_print( L"Entering deep_bind\n", DEBUG_BIND );
oblist = set( key, value, oblist );
debug_print( L"deep_bind returning ", DEBUG_BIND );
debug_print_object( key, DEBUG_BIND );
debug_println( DEBUG_BIND );
return key;
}
/**
* Ensure that a canonical copy of this key is bound in this environment, and
* return that canonical copy. If there is currently no such binding, create one
* with the value TRUE.
*/
struct cons_pointer
intern( struct cons_pointer key, struct cons_pointer environment ) {
struct cons_pointer result = environment;
struct cons_pointer canonical = internedp( key, environment );
if ( nilp( canonical ) ) {
/*
* not currently bound. TODO: this should bind to NIL?
*/
result = set( key, TRUE, environment );
}
return result;
}

81
src/c/ops/intern.h Normal file
View file

@ -0,0 +1,81 @@
/*
* intern.h
*
* For now this implements an oblist and shallow binding; local environments can
* be consed onto the front of the oblist. Later, this won't do; bindings will happen
* in namespaces, which will probably be implemented as hash tables.
*
* Doctrine is that cons cells are immutable, and life is a lot more simple if they are;
* so when a symbol is rebound in the master oblist, what in fact we do is construct
* a new oblist without the previous binding but with the new binding. Anything which,
* prior to this action, held a pointer to the old oblist (as all current threads'
* environments must do) continues to hold a pointer to the old oblist, and consequently
* doesn't see the change. This is probably good but does mean you cannot use bindings
* on the oblist to signal between threads.
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#ifndef __intern_h
#define __intern_h
#include <stdbool.h>
extern struct cons_pointer privileged_symbol_nil;
extern struct cons_pointer oblist;
uint32_t get_hash( struct cons_pointer ptr );
void free_hashmap( struct cons_pointer ptr );
void dump_map( URL_FILE * output, struct cons_pointer pointer );
struct cons_pointer hashmap_get( struct cons_pointer mapp,
struct cons_pointer key, bool return_key );
struct cons_pointer hashmap_put( struct cons_pointer mapp,
struct cons_pointer key,
struct cons_pointer val );
struct cons_pointer hashmap_put_all( struct cons_pointer mapp,
struct cons_pointer assoc );
struct cons_pointer hashmap_keys( struct cons_pointer map );
struct cons_pointer make_hashmap( uint32_t n_buckets,
struct cons_pointer hash_fn,
struct cons_pointer write_acl );
struct cons_pointer search_store( struct cons_pointer key,
struct cons_pointer store, bool return_key );
struct cons_pointer c_assoc( struct cons_pointer key,
struct cons_pointer store );
struct cons_pointer interned( struct cons_pointer key,
struct cons_pointer environment );
struct cons_pointer internedp( struct cons_pointer key,
struct cons_pointer environment );
struct cons_pointer hashmap_put( struct cons_pointer mapp,
struct cons_pointer key,
struct cons_pointer val );
struct cons_pointer set( struct cons_pointer key,
struct cons_pointer value,
struct cons_pointer store );
struct cons_pointer deep_bind( struct cons_pointer key,
struct cons_pointer value );
struct cons_pointer intern( struct cons_pointer key,
struct cons_pointer environment );
struct cons_pointer internedp( struct cons_pointer key,
struct cons_pointer store );
#endif

1840
src/c/ops/lispops.c Normal file
View file

File diff suppressed because it is too large Load diff

250
src/c/ops/lispops.h Normal file
View file

@ -0,0 +1,250 @@
/**
* lispops.h
*
* List processing operations.
*
* The general idea here is that a list processing operation is a
* function which takes two arguments, both cons_pointers:
*
* 1. args, the argument list to this function;
* 2. env, the environment in which this function should be evaluated;
*
* and returns a cons_pointer, the result.
*
* They must all have the same signature so that I can call them as
* function pointers.
*
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#ifndef __psse_lispops_h
#define __psse_lispops_h
extern struct cons_pointer prompt_name;
/*
* utilities
*/
struct cons_pointer c_keys( struct cons_pointer store );
struct cons_pointer c_reverse( struct cons_pointer arg );
struct cons_pointer c_progn( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer expressions,
struct cons_pointer env );
/**
* Useful building block; evaluate this single form in the context of this
* parent stack frame and this environment.
* @param parent the parent stack frame.
* @param form the form to be evaluated.
* @param env the evaluation environment.
* @return the result of evaluating the form.
*/
struct cons_pointer eval_form( struct stack_frame *parent,
struct cons_pointer parent_pointer,
struct cons_pointer form,
struct cons_pointer env );
/**
* eval all the forms in this `list` in the context of this stack `frame`
* and this `env`, and return a list of their values. If the arg passed as
* `list` is not in fact a list, return nil.
*/
struct cons_pointer eval_forms( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer list,
struct cons_pointer env );
/*
* special forms
*/
struct cons_pointer lisp_eval( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_apply( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_keys( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_oblist( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_set( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_set_shriek( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
/**
* Construct an interpretable function.
*
* @param frame the stack frame in which the expression is to be interpreted;
* @param lexpr the lambda expression to be interpreted;
* @param env the environment in which it is to be intepreted.
*/
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.
*
* @param frame the stack frame in which the expression is to be interpreted;
* @param env the environment in which it is to be intepreted.
*/
struct cons_pointer lisp_nlambda( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_quote( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
/*
* functions
*/
struct cons_pointer lisp_assoc( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_cons( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_car( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_cdr( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_inspect( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_internedp( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_eq( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_equal( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_read( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_repl( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_reverse( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer
lisp_count( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env );
/**
* Function: Get the Lisp type of the single argument.
* @param frame My stack frame.
* @param env My environment (ignored).
* @return As a Lisp string, the tag of the object which is the argument.
*/
struct cons_pointer lisp_type( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
/**
* Function; evaluate the forms which are listed in my single argument
* sequentially and return the value of the last. This function is called 'do'
* in some dialects of Lisp.
*
* @param frame My stack frame.
* @param env My environment (ignored).
* @return the value of the last form on the sequence which is my single
* argument.
*/
struct cons_pointer lisp_progn( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
/**
* Special form: conditional. Each arg is expected to be a list; if the first
* item in such a list evaluates to non-NIL, the remaining items in that list
* are evaluated in turn and the value of the last returned. If no arg (clause)
* has a first element which evaluates to non NIL, then NIL is returned.
* @param frame My stack frame.
* @param env My environment (ignored).
* @return the value of the last form of the first successful clause.
*/
struct cons_pointer lisp_cond( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer throw_exception_with_cause( struct cons_pointer location,
struct cons_pointer message,
struct cons_pointer cause,
struct cons_pointer
frame_pointer );
/**
* Throw an exception.
* `throw_exception` is a misnomer, because it doesn't obey the calling
* signature of a lisp function; but it is nevertheless to be preferred to
* make_exception. A real `throw_exception`, which does, will be needed.
*/
struct cons_pointer throw_exception( struct cons_pointer location,
struct cons_pointer message,
struct cons_pointer frame_pointer );
struct cons_pointer lisp_exception( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_source( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer c_append( struct cons_pointer l1, struct cons_pointer l2 );
struct cons_pointer lisp_append( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_mapcar( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_list( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_let( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_try( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_and( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_or( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_not( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
#endif

50
src/c/ops/loop.c Normal file
View file

@ -0,0 +1,50 @@
/*
* loop.c
*
* Iteration functions. This has *a lot* of similarity to try/catch --
* essentially what `recur` does is throw a special purpose exception which is
* caught by `loop`.
*
* Essentially the syntax I want is
*
* (defun expt (n e)
* (loop ((n1 . n) (r . n) (e1 . e))
* (cond ((= e 0) r)
* (t (recur n1 (* n1 r) (- e 1)))))
*
* It might in future be good to allow the body of the loop to comprise many
* expressions, like a `progn`, but for now if you want that you can just
* shove a `progn` in. Note that, given that what `recur` is essentially
* doing is throwing a special purpose exception, the `recur` expression
* doesn't actually have to be in the same function as the `loop` expression.
*
* (c) 2021 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include "consspaceobject.h"
#include "lispops.h"
#include "loop.h"
/**
* Special form, not dissimilar to `let`. Essentially,
*
* 1. the first arg (`args`) is an assoc list;
* 2. the second arg (`body`) is an expression.
*
* Each of the vals in the assoc list is evaluated, and bound to its
* respective key in a new environment. The body is then evaled in that
* environment. If the result is an object of type LOOP, it should carry
* a list of values of the same arity as args. Each of the keys in args
* is then rebound in a new environment to the respective value from the
* LOOP object, and body is then re-evaled in that environment.
*
* If the result is not a LOOP object, it is simply returned.
*/
struct cons_pointer
lisp_loop( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
struct cons_pointer keys = c_keys( frame->arg[0] );
struct cons_pointer body = frame->arg[1];
}

10
src/c/ops/loop.h Normal file
View file

@ -0,0 +1,10 @@
/*
* loop.h
*
* Iteration functions. This has *a lot* of similarity to try/catch --
* essentially what `recur` does is throw a special purpose exception which is
* caught by `loop`.
*
* (c) 2021 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/

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

@ -0,0 +1,45 @@
/*
* 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 "memory/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.stream.meta;
break;
}
return make_cons( make_cons( c_string_to_lisp_keyword( L"type" ),
c_type( frame->arg[0] ) ), result );
// return result;
}

18
src/c/ops/meta.h Normal file
View file

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

50
src/c/repl.c Normal file
View file

@ -0,0 +1,50 @@
/*
* repl.c
*
* the read/eval/print loop
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <stdbool.h>
#include <stdio.h>
#include <wchar.h>
#include <signal.h>
#include "memory/consspaceobject.h"
#include "debug.h"
#include "ops/intern.h"
#include "ops/lispops.h"
#include "memory/stack.h"
/**
* @brief Handle an interrupt signal.
*
* @param dummy
*/
void int_handler( int dummy ) {
wprintf( L"TODO: handle ctrl-C in a more interesting way\n" );
}
/**
* The read/eval/print loop.
*/
void repl( ) {
signal( SIGINT, int_handler );
debug_print( L"Entered repl\n", DEBUG_REPL );
struct cons_pointer env =
consp( oblist ) ? oblist : make_cons( oblist, NIL );
/* bottom of stack */
struct cons_pointer frame_pointer = make_stack_frame( NIL, NIL, env );
if ( !nilp( frame_pointer ) ) {
lisp_repl( get_stack_frame( frame_pointer ), frame_pointer, env );
dec_ref( frame_pointer );
}
debug_print( L"Leaving repl\n", DEBUG_REPL );
}

29
src/c/repl.h Normal file
View file

@ -0,0 +1,29 @@
/*
* To change this license header, choose License Headers in Project Properties.
* To change this template file, choose Tools | Templates
* and open the template in the editor.
*/
/*
* File: repl.h
* Author: simon
*
* Created on 14 August 2017, 14:40
*/
#ifndef REPL_H
#define REPL_H
#ifdef __cplusplus
extern "C" {
#endif
/**
* The read/eval/print loop
*/
void repl( );
#ifdef __cplusplus
}
#endif
#endif /* REPL_H */

109
src/c/time/psse_time.c Normal file
View file

@ -0,0 +1,109 @@
/*
* psse_time.c
*
* Bare bones of PSSE time. See issue #16.
*
* (c) 2019 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <stdlib.h>
#include <string.h>
#include <time.h>
/*
* wide characters
*/
#include <wchar.h>
#include <wctype.h>
#include "memory/conspage.h"
#include "memory/consspaceobject.h"
#include "arith/integer.h"
#include "time/psse_time.h"
#define _GNU_SOURCE
#define seconds_per_year 31557600L
/**
* PSSE Lisp epoch is 14 Bn years, or 441,806,400,000,000,000 seconds, before
* the UNIX epoch; the value in microseconds will break the C reader.
*/
unsigned __int128 epoch_offset =
( ( __int128 ) ( seconds_per_year * 1000000000L ) *
( __int128 ) ( 14L * 1000000000L ) );
/**
* Return the UNIX time value which represents this time, if it falls within
* the period representable in UNIX time, or zero otherwise.
*/
long int lisp_time_to_unix_time( struct cons_pointer t ) {
long int result = 0;
if ( timep( t ) ) {
unsigned __int128 value = pointer2cell( t ).payload.time.value;
if ( value > epoch_offset ) { // \todo && value < UNIX time rollover
result = ( ( value - epoch_offset ) / 1000000000 );
}
}
return result;
}
unsigned __int128 unix_time_to_lisp_time( time_t t ) {
unsigned __int128 result = epoch_offset + ( t * 1000000000 );
return result;
}
struct cons_pointer make_time( struct cons_pointer integer_or_nil ) {
struct cons_pointer pointer = allocate_cell( TIMETV );
struct cons_space_object *cell = &pointer2cell( pointer );
if ( integerp( integer_or_nil ) ) {
cell->payload.time.value =
pointer2cell( integer_or_nil ).payload.integer.value;
} else {
cell->payload.time.value = unix_time_to_lisp_time( time( NULL ) );
}
return pointer;
}
/**
* Function; return a time representation of the first argument in the frame;
* further arguments are ignored.
*
* * (time integer_or_nil)
*
* @param frame my stack_frame.
* @param frame_pointer a pointer to my stack_frame.
* @param env my environment.
* @return a lisp time; if `integer_or_nil` is an integer, return a time which
* is that number of microseconds after the notional big bang; else the current
* time.
*/
struct cons_pointer lisp_time( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ) {
return make_time( frame->arg[0] );
}
/**
* This is temporary, for bootstrapping.
*/
struct cons_pointer time_to_string( struct cons_pointer pointer ) {
struct cons_pointer result = NIL;
long int t = lisp_time_to_unix_time( pointer );
if ( t != 0 ) {
char *bytes = ctime( &t );
int l = strlen( bytes ) + 1;
wchar_t buffer[l];
mbstowcs( buffer, bytes, l );
result = c_string_to_lisp_string( buffer );
}
return result;
}

21
src/c/time/psse_time.h Normal file
View file

@ -0,0 +1,21 @@
/*
* psse_time.h
*
* Bare bones of PSSE time. See issue #16.
*
* (c) 2019 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#ifndef __psse_time_h
#define __psse_time_h
#define _GNU_SOURCE
#include "consspaceobject.h"
struct cons_pointer lisp_time( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer time_to_string( struct cons_pointer pointer );
#endif

33
src/c/utils.c Normal file
View file

@ -0,0 +1,33 @@
/*
* utils.c
*
* little generally useful functions which aren't in any way special to PSSE.
*
* (c) 2019 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <ctype.h>
#include <stdlib.h>
#include <string.h>
int index_of( char c, const 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 >= 0;
i-- ) {
s[i] = '\0';
}
for ( i = 0; s[i] != '\0' && ( isblank( s[i] ) || iscntrl( s[i] ) ); i++ );
return ( char * ) &s[i];
}

17
src/c/utils.h Normal file
View file

@ -0,0 +1,17 @@
/*
* utils.h
*
* little generally useful functions which aren't in any way special to PSSE.
*
* (c) 2019 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#ifndef __psse_utils_h
#define __psse_utils_h
int index_of( char c, const char *s );
char *trim( char *s );
#endif

11
src/c/version.h Normal file
View file

@ -0,0 +1,11 @@
/**
* version.h
*
* Just the version number. There's DEFINITELY a better way to do this!
*
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#define VERSION "0.0.7-SNAPSHOT"