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

Moved legacy code into archive, ready for a new rapid(?) prototype.

Browse source 
I may regret doing this!
This commit is contained in:
Simon Brooke 2026-03-24 16:25:09 +00:00
parent 09051a3e63
commit 914c35ead0
114 changed files with 165 additions and 1 deletions
Download patch file Download diff file Expand all files Collapse all files

508
archive/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
archive/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
archive/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
archive/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
archive/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
archive/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
archive/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
archive/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
archive/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
archive/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
archive/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
archive/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
archive/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
archive/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
archive/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
archive/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
archive/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
archive/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
archive/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
archive/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
archive/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
archive/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
archive/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
archive/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
archive/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
archive/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
archive/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
archive/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
archive/c/memory/cursor.h Normal file
View file

Binary file not shown.

166
archive/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
archive/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
archive/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
archive/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
archive/c/memory/lookup3.c Normal file
View file

File diff suppressed because it is too large Load diff

16
archive/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
archive/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
archive/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
archive/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
archive/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
archive/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
archive/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
archive/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
archive/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
archive/c/ops/lispops.c Normal file
View file

File diff suppressed because it is too large Load diff

250
archive/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
archive/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
archive/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
archive/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
archive/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
archive/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
archive/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
archive/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
archive/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
archive/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
archive/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
archive/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"

92
archive/unit-tests/add.sh Executable file
View file

@ -0,0 +1,92 @@
#!/bin/bash
result=0;
echo -n "$0: Add two small integers... "
expected='5'
actual=`echo "(add 2 3)" | target/psse 2>/dev/null | sed -r '/^\s*$/d' | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
echo -n "$0: Add float to integer... "
expected='5.5'
actual=`echo "(add 2.5 3)" | target/psse 2>/dev/null | sed -r '/^\s*$/d' | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
echo -n "$0: Add two rationals... "
expected='1/4'
actual=`echo "(+ 3/14 1/28)" | target/psse 2>/dev/null | sed -r '/^\s*$/d' | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
echo -n "$0: Add an integer to a rational... "
# (+ integer ratio) should be ratio
expected='25/4'
actual=`echo "(+ 6 1/4)" | target/psse 2>/dev/null | sed -r '/^\s*$/d' | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
echo -n "$0: Add a rational to an integer... "
# (+ ratio integer) should be ratio
expected='25/4'
actual=`echo "(+ 1/4 6)" | target/psse 2>/dev/null | sed -r '/^\s*$/d' | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
echo -n "$0: Add a real to a rational... "
# (+ real ratio) should be real
# for this test, trailing zeros can be ignored
expected='6.25'
actual=`echo "(+ 6.000000001 1/4)" |\
target/psse 2> /dev/null |\
sed -r '/^\s*$/d' |\
sed 's/0*$//'`
outcome=`echo "sqrt((${expected} - ${actual})^2) < 0.0000001" | bc`
if [ "${outcome}" -eq "1" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
exit ${result}

22
archive/unit-tests/allocation-tests/allocation-tester.sh Executable file
View file

@ -0,0 +1,22 @@
#1/bin/bash
echo "Case, Summary, Allocated, Deallocated, Not deallocated, Delta Allocated, Delta Deallocated, Delta Not Deallocated"
basecase=`echo '' | ../../target/psse 2>&1 | grep Allocation | tr -d '[:punct:]'`
bca=`echo ${basecase} | awk '{print $4}'`
bcd=`echo ${basecase} | awk '{print $6}'`
bcn=`echo ${basecase} | awk '{print $9}'`
echo "\"Basecase\", \"${basecase}\", ${bca}, ${bcd}, ${bcn}"
while IFS= read -r form; do
allocation=`echo ${form} | ../../target/psse 2>&1 | grep Allocation | tr -d '[:punct:]'`
tca=`echo ${allocation} | awk '{print $4}'`
tcd=`echo ${allocation} | awk '{print $6}'`
tcn=`echo ${allocation} | awk '{print $9}'`
dca=`echo "${tca} - ${bca}" | bc`
dcd=`echo "${tcd} - ${bcd}" | bc`
dcn=`echo "${tcn} - ${bcn}" | bc`
echo "\"${form}\", \"${allocation}\", ${tca}, ${tcd}, ${tcn}, ${dca}, ${dcd}, ${dcn}"
done

28
archive/unit-tests/allocation-tests/allocation-tests.csv Normal file
View file

@ -0,0 +1,28 @@
Case, Summary, Allocated, Deallocated, Not deallocated, Delta Allocated, Delta Deallocated, Delta Not Deallocated
"Basecase", "Allocation summary allocated 19986 deallocated 245 not deallocated 19741", 19986, 245, 19741
"", "Allocation summary allocated 19986 deallocated 245 not deallocated 19741", 19986, 245, 19741, 0, 0, 0
"nil", "Allocation summary allocated 20019 deallocated 253 not deallocated 19766", 20019, 253, 19766, 33, 8, 25
"()", "Allocation summary allocated 19990 deallocated 249 not deallocated 19741", 19990, 249, 19741, 4, 4, 0
"(quote ())", "Allocation summary allocated 20025 deallocated 247 not deallocated 19778", 20025, 247, 19778, 39, 2, 37
"(list)", "Allocation summary allocated 20023 deallocated 257 not deallocated 19766", 20023, 257, 19766, 37, 12, 25
"(list )", "Allocation summary allocated 20023 deallocated 257 not deallocated 19766", 20023, 257, 19766, 37, 12, 25
"(list 1)", "Allocation summary allocated 20033 deallocated 259 not deallocated 19774", 20033, 259, 19774, 47, 14, 33
"(list 1 1)", "Allocation summary allocated 20043 deallocated 261 not deallocated 19782", 20043, 261, 19782, 57, 16, 41
"(list 1 1 1)", "Allocation summary allocated 20053 deallocated 263 not deallocated 19790", 20053, 263, 19790, 67, 18, 49
"(list 1 2 3)", "Allocation summary allocated 20053 deallocated 263 not deallocated 19790", 20053, 263, 19790, 67, 18, 49
"(+)", "Allocation summary allocated 20022 deallocated 255 not deallocated 19767", 20022, 255, 19767, 36, 10, 26
"(+ 1)", "Allocation summary allocated 20030 deallocated 257 not deallocated 19773", 20030, 257, 19773, 44, 12, 32
"(+ 1 1)", "Allocation summary allocated 20039 deallocated 259 not deallocated 19780", 20039, 259, 19780, 53, 14, 39
"(+ 1 1 1)", "Allocation summary allocated 20048 deallocated 261 not deallocated 19787", 20048, 261, 19787, 62, 16, 46
"(+ 1 2 3)", "Allocation summary allocated 20048 deallocated 261 not deallocated 19787", 20048, 261, 19787, 62, 16, 46
"(list 'a 'a 'a)", "Allocation summary allocated 20137 deallocated 278 not deallocated 19859", 20137, 278, 19859, 151, 33, 118
"(list 'a 'b 'c)", "Allocation summary allocated 20137 deallocated 278 not deallocated 19859", 20137, 278, 19859, 151, 33, 118
"(list :a :b :c)", "Allocation summary allocated 20107 deallocated 260 not deallocated 19847", 20107, 260, 19847, 121, 15, 106
"(list :alpha :bravo :charlie)", "Allocation summary allocated 20471 deallocated 260 not deallocated 20211", 20471, 260, 20211, 485, 15, 470
"{}", "Allocation summary allocated 19992 deallocated 251 not deallocated 19741", 19992, 251, 19741, 6, 6, 0
"{:z 0}", "Allocation summary allocated 20029 deallocated 255 not deallocated 19774", 20029, 255, 19774, 43, 10, 33
"{:zero 0}", "Allocation summary allocated 20107 deallocated 255 not deallocated 19852", 20107, 255, 19852, 121, 10, 111
"{:z 0 :o 1}", "Allocation summary allocated 20066 deallocated 256 not deallocated 19810", 20066, 256, 19810, 80, 11, 69
"{:zero 0 :one 1}", "Allocation summary allocated 20196 deallocated 259 not deallocated 19937", 20196, 259, 19937, 210, 14, 196
"{:z 0 :o 1 :t 2}", "Allocation summary allocated 20103 deallocated 257 not deallocated 19846", 20103, 257, 19846, 117, 12, 105
"{:zero 0 :one 1 :two 2 :three 3 :four 4 :five five :six 6 :seven 7 :eight 8 :nine 9}", "Allocation summary allocated 21164 deallocated 286 not deallocated 20878", 21164, 286, 20878, 1178, 41, 1137
Can't render this file because it has a wrong number of fields in line 2.

BIN
archive/unit-tests/allocation-tests/allocation-tests.ods Normal file
View file

Binary file not shown.

30
archive/unit-tests/allocation-tests/feature-2.test.tmp Normal file
View file

@ -0,0 +1,30 @@
Case, Summary, Allocated, Deallocated, Not deallocated, Delta Allocated, Delta Deallocated, Delta Not Deallocated
"Basecase", "Allocation summary allocated 19986 deallocated 245 not deallocated 19741", 19986, 245, 19741
"", "Allocation summary allocated 19986 deallocated 245 not deallocated 19741", 19986, 245, 19741, 0, 0, 0
"nil", "Allocation summary allocated 20019 deallocated 253 not deallocated 19766", 20019, 253, 19766, 33, 8, 25
"()", "Allocation summary allocated 19990 deallocated 249 not deallocated 19741", 19990, 249, 19741, 4, 4, 0
"(quote ())", "Allocation summary allocated 20025 deallocated 247 not deallocated 19778", 20025, 247, 19778, 39, 2, 37
"(list)", "Allocation summary allocated 20023 deallocated 257 not deallocated 19766", 20023, 257, 19766, 37, 12, 25
"(list )", "Allocation summary allocated 20023 deallocated 257 not deallocated 19766", 20023, 257, 19766, 37, 12, 25
"(list 1)", "Allocation summary allocated 20033 deallocated 262 not deallocated 19771", 20033, 262, 19771, 47, 17, 30
"(list 1 1)", "Allocation summary allocated 20043 deallocated 267 not deallocated 19776", 20043, 267, 19776, 57, 22, 35
"(list 1 1 1)", "Allocation summary allocated 20053 deallocated 272 not deallocated 19781", 20053, 272, 19781, 67, 27, 40
"(list 1 2 3)", "Allocation summary allocated 20053 deallocated 272 not deallocated 19781", 20053, 272, 19781, 67, 27, 40
"(+)", "Allocation summary allocated 20022 deallocated 255 not deallocated 19767", 20022, 255, 19767, 36, 10, 26
"(+ 1)", "Allocation summary allocated 20030 deallocated 260 not deallocated 19770", 20030, 260, 19770, 44, 15, 29
"(+ 1 1)", "Allocation summary allocated 20039 deallocated 265 not deallocated 19774", 20039, 265, 19774, 53, 20, 33
"(+ 1 1 1)", "Allocation summary allocated 20048 deallocated 270 not deallocated 19778", 20048, 270, 19778, 62, 25, 37
"(+ 1 2 3)", "Allocation summary allocated 20048 deallocated 270 not deallocated 19778", 20048, 270, 19778, 62, 25, 37
"(list 'a 'a 'a)", "Allocation summary allocated 20137 deallocated 278 not deallocated 19859", 20137, 278, 19859, 151, 33, 118
"(list 'a 'b 'c)", "Allocation summary allocated 20137 deallocated 278 not deallocated 19859", 20137, 278, 19859, 151, 33, 118
"(list :a :b :c)", "Allocation summary allocated 20107 deallocated 260 not deallocated 19847", 20107, 260, 19847, 121, 15, 106
"(list :aa :bb :cc)", "Allocation summary allocated 20185 deallocated 260 not deallocated 19925", 20185, 260, 19925, 199, 15, 184
"(list :aaa :bbb :ccc)", "Allocation summary allocated 20263 deallocated 260 not deallocated 20003", 20263, 260, 20003, 277, 15, 262
"(list :alpha :bravo :charlie)", "Allocation summary allocated 20471 deallocated 260 not deallocated 20211", 20471, 260, 20211, 485, 15, 470
"{}", "Allocation summary allocated 19992 deallocated 251 not deallocated 19741", 19992, 251, 19741, 6, 6, 0
"{:z 0}", "Allocation summary allocated 20029 deallocated 257 not deallocated 19772", 20029, 257, 19772, 43, 12, 31
"{:zero 0}", "Allocation summary allocated 20107 deallocated 257 not deallocated 19850", 20107, 257, 19850, 121, 12, 109
"{:z 0 :o 1}", "Allocation summary allocated 20066 deallocated 261 not deallocated 19805", 20066, 261, 19805, 80, 16, 64
"{:zero 0 :one 1}", "Allocation summary allocated 20196 deallocated 263 not deallocated 19933", 20196, 263, 19933, 210, 18, 192
"{:z 0 :o 1 :t 2}", "Allocation summary allocated 20103 deallocated 265 not deallocated 19838", 20103, 265, 19838, 117, 20, 97
"{:zero 0 :one 1 :two 2 :three 3 :four 4 :five five :six 6 :seven 7 :eight 8 :nine 9}", "Allocation summary allocated 21164 deallocated 306 not deallocated 20858", 21164, 306, 20858, 1178, 61, 1117

19
archive/unit-tests/allocation-tests/grep.bb Executable file
View file

@ -0,0 +1,19 @@
#!/home/simon/bin/bb
(require '[clojure.java.io :as io])
(import '[java.lang ProcessBuilder$Redirect])
(defn grep [input pattern]
(let [proc (-> (ProcessBuilder. ["grep" pattern])
(.redirectOutput ProcessBuilder$Redirect/INHERIT)
(.redirectError ProcessBuilder$Redirect/INHERIT)
(.start))
proc-input (.getOutputStream proc)]
(with-open [w (io/writer proc-input)]
(binding [*out* w]
(print input)
(flush)))
(.waitFor proc)
nil))
(grep "hello\nbye\n" "e")

28
archive/unit-tests/allocation-tests/test-forms Normal file
View file

@ -0,0 +1,28 @@
nil
()
(quote ())
(list)
(list )
(list 1)
(list 1 1)
(list 1 1 1)
(list 1 2 3)
(+)
(+ 1)
(+ 1 1)
(+ 1 1 1)
(+ 1 2 3)
(list 'a 'a 'a)
(list 'a 'b 'c)
(list :a :b :c)
(list :aa :bb :cc)
(list :aaa :bbb :ccc)
(list :alpha :bravo :charlie)
{}
{:z 0}
{:zero 0}
{:z 0 :o 1}
{:zero 0 :one 1}
{:z 0 :o 1 :t 2}
{:zero 0 :one 1 :two 2 :three 3 :four 4 :five five :six 6 :seven 7 :eight 8 :nine 9}

44
archive/unit-tests/append.sh Executable file
View file

@ -0,0 +1,44 @@
#!/bin/bash
return=0;
echo -n "$0: Append two lists... "
expected='(a b c d e f)'
actual=`echo "(append '(a b c) '(d e f))" | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
return=`echo "${return} + 1" | bc`
fi
echo -n "$0: Append two strings... "
expected='"hellodere"'
actual=`echo '(append "hello" "dere")' | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
return=`echo "${return} + 1" | bc`
fi
echo -n "$0: Append keyword to string should error... "
expected='Exception:'
actual=`echo '(append "hello" :dere)' | target/psse 2>/dev/null | sed -r '/^\s*$/d' | awk '{print $1}'`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
return=`echo "${return} + 1" | bc`
fi
exit ${return}

29
archive/unit-tests/apply.sh Executable file
View file

@ -0,0 +1,29 @@
#!/bin/bash
result=1
echo -n "$0: Apply function to one argument... "
expected='1'
actual=`echo "(apply 'add '(1))"| target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
echo -n "$0: Apply function to multiple arguments... "
expected='3'
actual=`echo "(apply 'add '(1 2))"| target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
exit ${result}

60
archive/unit-tests/assoc.sh Normal file
View file

@ -0,0 +1,60 @@
#!/bin/bash
result=0
expected='1'
actual=`echo "(assoc 'foo '((foo . 1) (bar . 2) {ban 3 froboz 4 foo 5} (foobar . 6)))" | target/psse | tail -1`
echo -n "$0 $1: assoc list binding... "
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
expected='4'
actual=`echo "(assoc 'froboz '((foo . 1) (bar . 2) {ban 3 froboz 4 foo 5} (foobar . 6)))" | target/psse | tail -1`
echo -n "$0 $1: hashmap binding... "
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
expected='nil'
actual=`echo "(assoc 'ban '((foo . 1) (bar . 2) {ban nil froboz 4 foo 5} (foobar . 6) (ban . 7)))" | target/psse | tail -1`
echo -n "$0 $1: key bound to 'nil' (1)... "
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
expected='nil'
actual=`echo "(assoc 'foo '((foo . nil) (bar . 2) {ban 3 froboz 4 foo 5} (foobar . 6)))" | target/psse | tail -1`
echo -n "$0 $1: key bound to nil (2)... "
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi

278
archive/unit-tests/bignum-add.sh Executable file
View file

@ -0,0 +1,278 @@
#!/bin/bash
return=0
#####################################################################
# add two large numbers, not actally bignums to produce a smallnum
# (right on the boundary)
a=1152921504606846975
b=1
c=`echo "$a + $b" | bc`
expected='t'
output=`echo "(= (+ $a $b) $c)" | target/psse -v 2 2>tmp/psse.log`
actual=`echo $output |\
tail -1`
echo -n "$0 => adding $a to $b: "
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
return=`echo "${return} + 1" | bc`
fi
echo -n "$0: checking no bignum was created: "
grep -v 'BIGNUM!' tmp/psse.log > /dev/null
if [ $? -eq "0" ]
then
echo "OK"
else
echo "Fail"
return=`echo "${return} + 1" | bc`
fi
#####################################################################
# add two numbers, not actally bignums to produce a bignum
# (just over the boundary)
a='1152921504606846976'
b=1
c=`echo "$a + $b" | bc`
expected='t'
output=`echo "(= (+ $a $b) $c)" | target/psse -v 2 2>tmp/psse.log`
actual=`echo $output |\
tail -1 |\
sed 's/\,//g'`
echo -n "$0 => adding $a to $b: "
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
return=`echo "${return} + 1" | bc`
fi
echo -n "$0 => checking a bignum was created: "
grep 'BIGNUM!' tmp/psse.log > /dev/null
if [ $? -eq "0" ]
then
echo "OK"
else
echo "Fail"
return=`echo "${return} + 1" | bc`
fi
#####################################################################
# add a bignum and a smallnum to produce a bignum
# (just over the boundary)
a='1152921504606846977'
b=1
c=`echo "$a + $b" | bc`
expected='t'
output=`echo "(= (+ $a $b) $c)" | target/psse -v 2 2>tmp/psse.log`
actual=`echo $output |\
tail -1 |\
sed 's/\,//g'`
echo -n "$0 => adding $a to $b: "
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
return=`echo "${return} + 1" | bc`
fi
echo -n "$0 => checking a bignum was created: "
grep 'BIGNUM!' tmp/psse.log > /dev/null
if [ $? -eq "0" ]
then
echo "OK"
else
echo "Fail"
return=`echo "${return} + 1" | bc`
fi
#####################################################################
# add a smallnum and a bignum to produce a bignum
# (just over the boundary)
a=1
b=1152921504606846977
c=`echo "$a + $b" | bc`
expected='t'
output=`echo "(= (+ $a $b) $c)" | target/psse -v 2 2>tmp/psse.log`
actual=`echo $output |\
tail -1 |\
sed 's/\,//g'`
echo -n "$0 => adding $a to $b: "
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
return=`echo "${return} + 1" | bc`
fi
echo -n "$0 => checking a bignum was created: "
grep 'BIGNUM!' tmp/psse.log > /dev/null
if [ $? -eq "0" ]
then
echo "OK"
else
echo "Fail"
return=`echo "${return} + 1" | bc`
fi
#####################################################################
# add two small bignums to produce a bigger bignum
a=1152921504606846977
c=`echo "$a + $a" | bc`
echo -n "$0 => adding $a to $a: "
expected='t'
output=`echo "(= (+ $a $b) $c)" | target/psse -v 2 2>tmp/psse.log`
actual=`echo $output |\
tail -1 |\
sed 's/\,//g'`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
return=`echo "${return} + 1" | bc`
fi
#####################################################################
# add five small bignums to produce a bigger bignum
a=1152921504606846977
c=`echo "$a * 5" | bc`
echo -n "$0 => adding $a, $a $a, $a, $a: "
expected='t'
output=`echo "(= (+ $a $a $a $a $a) $c)" | target/psse -v 2 2>tmp/psse.log`
actual=`echo $output |\
tail -1 |\
sed 's/\,//g'`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
return=`echo "${return} + 1" | bc`
fi
#####################################################################
# add two bignums to produce a bignum
a=10000000000000000000
b=10000000000000000000
c=`echo "$a + $b" | bc`
expected='t'
output=`echo "(= (+ $a $b) $c)" | target/psse -v 2 2>tmp/psse.log`
actual=`echo $output |\
tail -1 |\
sed 's/\,//g'`
echo -n "$0 => adding $a to $b: "
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
return=`echo "${return} + 1" | bc`
fi
echo -n "$0 => checking a bignum was created: "
grep 'BIGNUM!' tmp/psse.log > /dev/null
if [ $? -eq "0" ]
then
echo "OK"
else
echo "Fail"
return=`echo "${return} + 1" | bc`
fi
#####################################################################
# add a smallnum and a two-cell bignum to produce a three-cell bignum
# (just over the boundary)
a=1
b=1329227995784915872903807060280344576
c=`echo "$a + $b" | bc`
expected='t'
output=`echo "(= (+ $a $b) $c)" | target/psse -v 2 2>tmp/psse.log`
actual=`echo $output |\
tail -1 |\
sed 's/\,//g'`
echo -n "$0 => adding $a to $b: "
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
return=`echo "${return} + 1" | bc`
fi
echo -n "$0 => checking a bignum was created: "
grep 'BIGNUM!' tmp/psse.log > /dev/null
if [ $? -eq "0" ]
then
echo "OK"
else
echo "Fail"
return=`echo "${return} + 1" | bc`
fi
#####################################################################
# This currently fails:
# (= (+ 1 3064991081731777716716694054300618367237478244367204352)
# 3064991081731777716716694054300618367237478244367204353)
a=1
b=3064991081731777716716694054300618367237478244367204352
c=`echo "$a + $b" | bc`
expected='t'
output=`echo "(= (+ $a $b) $c)" | target/psse -v 2 2>tmp/psse.log`
actual=`echo $output |\
tail -1 |\
sed 's/\,//g'`
echo -n "$0 => adding $a to $b: "
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
return=`echo "${return} + 1" | bc`
fi
echo -n "$0 => checking a bignum was created: "
grep 'BIGNUM!' tmp/psse.log > /dev/null
if [ $? -eq "0" ]
then
echo "OK"
else
echo "Fail"
return=`echo "${return} + 1" | bc`
fi
exit ${return}

136
archive/unit-tests/bignum-expt.sh Executable file
View file

@ -0,0 +1,136 @@
#!/bin/bash
result=0
#####################################################################
# last 'smallnum' value:
# sbcl calculates (expt 2 59) => 576460752303423488
expected='576460752303423488'
output=`target/psse 2>/dev/null <<EOF
(progn
(set! expt (lambda
(n x)
(cond
((= x 1) n)
(t (* n (expt n (- x 1)))))))
nil)
(expt 2 59)
EOF`
actual=`echo "$output" | tail -1 | sed 's/\,//g'`
echo -n "$0 => (expt 2 59): "
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
#####################################################################
# first 'bignum' value (right on the boundary):
# sbcl calculates (expt 2 60) => 1152921504606846976
expected='1152921504606846976'
output=`target/psse 2>/dev/null <<EOF
(progn
(set! expt (lambda
(n x)
(cond
((= x 1) n)
(t (* n (expt n (- x 1)))))))
nil)
(expt 2 60)
EOF`
actual=`echo "$output" | tail -1 | sed 's/\,//g'`
echo -n "$0 => (expt 2 60): "
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
#####################################################################
# second 'bignum' value (definitely a bignum):
# sbcl calculates (expt 2 61) => 2305843009213693952
expected='2305843009213693952'
output=`target/psse 2>/dev/null <<EOF
(progn
(set! expt (lambda
(n x)
(cond
((= x 1) n)
(t (* n (expt n (- x 1)))))))
nil)
(expt 2 61)
EOF`
actual=`echo "$output" | tail -1 | sed 's/\,//g'`
echo -n "$0 => (expt 2 61): "
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
# sbcl calculates (expt 2 64) => 18446744073709551616
expected='18446744073709551616'
output=`target/psse 2>/dev/null <<EOF
(progn
(set! expt (lambda
(n x)
(cond
((= x 1) n)
(t (* n (expt n (- x 1)))))))
nil)
(expt 2 64)
EOF`
actual=`echo "$output" | tail -1 | sed 's/\,//g'`
echo -n "$0 => (expt 2 64): "
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
# sbcl calculates (expt 2 65) => 36893488147419103232
expected='36893488147419103232'
output=`target/psse 2>/dev/null <<EOF
(progn
(set! expt (lambda
(n x)
(cond
((= x 1) n)
(t (* n (expt n (- x 1)))))))
nil)
(expt 2 65)
EOF`
actual=`echo "$output" | tail -1 | sed 's/\,//g'`
echo -n "$0 => (expt 2 65): "
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
exit ${result}

104
archive/unit-tests/bignum-print.sh Executable file
View file

@ -0,0 +1,104 @@
#!/bin/bash
return=0
#####################################################################
# large number, not actally a bignum
expected='576460752303423488'
output=`echo "(progn (print $expected) nil)" | target/psse -v 2 2>psse.log`
actual=`echo $output |\
sed 's/\,//g' |\
sed 's/[^0-9]*\([0-9]*\).*/\1/'`
echo -n "$0 => printing $expected: "
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
return=1
fi
#####################################################################
# right on the boundary
expected='1152921504606846976'
output=`echo "(progn (print $expected) nil)" | target/psse -v 2 2>psse.log`
actual=`echo $output |\
sed 's/\,//g' |\
sed 's/[^0-9]*\([0-9]*\).*/\1/'`
echo -n "$0 => printing $expected: "
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
return=1
fi
#####################################################################
# definitely a bignum
expected='1152921504606846977'
output=`echo "(progn (print $expected) nil)" | target/psse -v 2 2>psse.log`
actual=`echo $output |\
sed 's/\,//g' |\
sed 's/[^0-9]*\([0-9]*\).*/\1/'`
echo -n "$0 => printing $expected: "
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
return=1
fi
# Currently failing from here on, but it's failing in read because of
# the multiply bug. We know printing blows up at the 3 cell boundary
# because `lisp/scratchpad2.lisp` constructs a 3 cell bignum by
# repeated addition.
#####################################################################
# Just on the three cell boundary
expected='1329227995784915872903807060280344576'
output=`echo "(progn (print $expected) nil)" | target/psse -v 2 2>psse.log`
actual=`echo $output |\
sed 's/\,//g' |\
sed 's/[^0-9]*\([0-9]*\).*/\1/'`
echo -n "$0 => printing $expected: "
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', \n got '${actual}'"
return=1
fi
exit 0
#####################################################################
# definitely a three cell bignum
expected='1329227995784915872903807060280344577'
output=`echo "(progn (print $expected) nil)" | target/psse -v 2 2>psse.log`
actual=`echo $output |\
sed 's/\,//g' |\
sed 's/[^0-9]*\([0-9]*\).*/\1/'`
echo -n "$0 => printing $expected: "
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
return=1
fi
exit ${return}

119
archive/unit-tests/bignum-subtract.sh Executable file
View file

@ -0,0 +1,119 @@
#!/bin/bash
result=0
#####################################################################
# subtract a smallnum from a smallnum to produce a smallnum
# (right on the boundary)
a=1152921504606846976
b=1
expected='1152921504606846975'
output=`echo "(- $a $b)" | target/psse -v 2 2>psse.log`
actual=`echo $output |\
tail -1 |\
sed 's/\,//g'`
echo -n "$0 => subtracting $b from $a: "
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
echo -n "$0 => checking no bignum was created: "
grep -v 'BIGNUM!' psse.log > /dev/null
if [ $? -eq "0" ]
then
echo "OK"
else
echo "Fail"
result=`echo "${result} + 1" | bc`
fi
#####################################################################
# subtract a smallnum from a bignum to produce a smallnum
# (just over the boundary)
a='1152921504606846977'
b=1
expected='1152921504606846976'
output=`echo "(- $a $b)" | target/psse -v 2 2>psse.log`
actual=`echo $output |\
tail -1 |\
sed 's/\,//g'`
echo -n "$0 => subtracting $b from $a: "
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
#####################################################################
# subtract a smallnum from a bignum to produce a smallnum
a='1152921504606846978'
b=1
expected='1152921504606846977'
output=`echo "(- $a $b)" | target/psse -v 2 2>psse.log`
actual=`echo $output |\
tail -1 |\
sed 's/\,//g'`
echo -n "$0 => subtracting $b from $a: "
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
#####################################################################
# subtract a bignum from a smallnum to produce a negstive smallnum
# (just over the boundary)
a=1
b=1152921504606846977
expected='-1152921504606846976'
output=`echo "(- $a $b)" | target/psse -v 2 2>psse.log`
actual=`echo $output |\
tail -1 |\
sed 's/\,//g'`
echo -n "$0 => subtracting $b from $a: "
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
#####################################################################
# subtract a bignum from a bignum to produce a bignum
a=20000000000000000000
b=10000000000000000000
expected=10000000000000000000
output=`echo "(- $a $b)" | target/psse -v 2 2>psse.log`
actual=`echo $output |\
tail -1 |\
sed 's/\,//g'`
echo -n "$0 => subtracting $b from $a: "
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
exit ${result}

18
archive/unit-tests/bignum.sh Executable file
View file

@ -0,0 +1,18 @@
#!/bin/bash
return=0
expected='1,152,921,504,606,846,976'
# 1,152,921,504,606,846,975 is the largest single cell positive integer;
# consequently 1,152,921,504,606,846,976 is the first two cell positive integer.
actual=`echo '(+ 1,152,921,504,606,846,975 1)' | target/psse -v 68 2>bignum.log | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "$0 => Fail: expected '${expected}', got '${actual}'"
return=1
fi
exit ${return}

13
archive/unit-tests/complex-list.sh Executable file
View file

@ -0,0 +1,13 @@
#!/bin/bash
expected='(1 2 3 ("Fred") nil 77,354)'
actual=`echo "'(1 2 3 (\"Fred\") () 77354)" | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
exit 0
else
echo "Fail: expected '${expected}', got '${actual}'"
exit 1
fi

31
archive/unit-tests/cond.sh Executable file
View file

@ -0,0 +1,31 @@
#!/bin/bash
result=0
echo -n "$0: cond with one clause... "
expected='5'
actual=`echo "(cond ((equal? 2 2) 5))" | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
echo -n "$0: cond with two clauses... "
expected='"should"'
actual=`echo "(cond ((equal? 2 3) \"shouldn't\")(t \"should\"))" | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
exit ${result}

19
archive/unit-tests/empty-list.sh Executable file
View file

@ -0,0 +1,19 @@
#!/bin/bash
#
# File: empty-list.sh.bash
# Author: simon
#
# Created on 14-Aug-2017, 15:06:40
#
expected=nil
actual=`echo "'()" | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
exit 0
else
echo "Fail: expected '${expected}', got '${actual}'"
exit 1
fi

13
archive/unit-tests/empty-string.sh Executable file
View file

@ -0,0 +1,13 @@
#!/bin/bash
expected="\"\""
actual=`echo '""' | target/psse 2>/dev/null | tail -1`
if [ "$expected" = "$actual" ]
then
echo "OK"
exit 0
else
echo "Fail: expected '$expected', got '$actual'"
exit 1
fi

206
archive/unit-tests/equal.sh Normal file
View file

@ -0,0 +1,206 @@
#!/bin/bash
# Tests for equality.
result=0
echo -n "$0: integers... "
expected="t"
actual=`echo "(= 5 5)" | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
echo -n "$0: different integers... "
expected="nil"
actual=`echo "(= 4 5)" | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
echo -n "$0: reals... "
expected="t"
actual=`echo "(= 5.001 5.001)" | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
echo -n "$0: different reals... "
expected="nil"
actual=`echo "(= 5.001 5.002)" | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
echo -n "$0: ratios... "
expected="t"
actual=`echo "(= 4/5 4/5)" | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
echo -n "$0: equivalent ratios... "
expected="t"
actual=`echo "(= 4/5 12/15)" | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
echo -n "$0: different ratios... "
expected="nil"
actual=`echo "(= 4/5 5/5)" | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
echo -n "$0: atoms... "
expected="t"
actual=`echo "(= 'foo 'foo)" | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
echo -n "$0: different atoms... "
expected="nil"
actual=`echo "(= 'foo 'bar)" | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
echo -n "$0: keywords... "
expected="t"
actual=`echo "(= :foo :foo)" | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
echo -n "$0: different keywords... "
expected="nil"
actual=`echo "(= :foo :bar)" | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
echo -n "$0: strings... "
expected="t"
actual=`echo '(= "foo" "foo")' | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
echo -n "$0: different strings... "
expected="nil"
actual=`echo '(= "foo" "bar")' | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
echo -n "$0: maps... "
expected="t"
actual=`echo '(= {:foo 1 :bar 2} {:bar 2 :foo 1})' | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
echo -n "$0: different maps... "
expected="nil"
actual=`echo '(= {:foo 1 :bar 2} {:bar 1 :foo 2})' | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
exit ${result}

12
archive/unit-tests/eval-integer.sh Executable file
View file

@ -0,0 +1,12 @@
#!/bin/bash
expected='5'
actual=`echo "(eval 5)" | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
exit 1
fi

13
archive/unit-tests/eval-quote-sexpr.sh Executable file
View file

@ -0,0 +1,13 @@
#!/bin/bash
expected='5'
actual=`echo "(eval '(add 2 3))" | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
exit 1
fi
2>/dev/null

12
archive/unit-tests/eval-quote-symbol.sh Executable file
View file

@ -0,0 +1,12 @@
#!/bin/bash
expected='<Special form: ((:primitive . t) (:name . cond) (:documentation . "`(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."))>'
actual=`echo "(eval 'cond)" | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
exit 1
fi

21
archive/unit-tests/eval-real.sh Executable file
View file

@ -0,0 +1,21 @@
#!/bin/bash
# for this test, trailing zeros can be ignored
expected='5.05'
actual=`echo "(eval 5.05)" |\
target/psse 2>/dev/null |\
sed 's/0*$//' |\
tail -1`
# one part in a million is close enough...
outcome=`echo "sqrt((${expected} - ${actual})^2) < 0.0000001" | bc`
if [ "${outcome}" = "1" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
exit 1
fi

12
archive/unit-tests/eval-string.sh Executable file
View file

@ -0,0 +1,12 @@
#!/bin/bash
expected='"5"'
actual=`echo '(eval "5")' | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
exit 1
fi

13
archive/unit-tests/fred.sh Executable file
View file

@ -0,0 +1,13 @@
#!/bin/bash
expected='"Fred"'
actual=`echo ${expected} | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
exit 0
else
echo "Fail: expected '$expected', got '$actual'"
exit 1
fi

14
archive/unit-tests/integer-allocation.sh Executable file
View file

@ -0,0 +1,14 @@
#!/bin/bash
value=354
expected="(${value} \"INTR\")"
echo "(set! x $value)(list x (type x))" | target/psse 2>&1 | grep "${expected}" > /dev/null
if [ $? -eq 0 ]
then
echo "OK"
exit 0
else
echo "Expected '${expected}', not found"
exit 1
fi

13
archive/unit-tests/integer.sh Executable file
View file

@ -0,0 +1,13 @@
#!/bin/bash
expected='354'
actual=`echo ${expected} | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
exit 0
else
echo "Expected '${expected}', got '${actual}'"
exit 1
fi

12
archive/unit-tests/interpreter.sh Executable file
View file

@ -0,0 +1,12 @@
#!/bin/bash
expected='6'
actual=`echo "(apply '(lambda (x y z) (/ (* y z) x)) '(2 3 4))" | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
exit 1
fi

17
archive/unit-tests/lambda.sh Executable file
View file

@ -0,0 +1,17 @@
#!/bin/bash
expected='<Anonymous Function: (λ (l) l)> (1 2 3 4 5 6 7 8 9 10)'
output=`target/psse 2>/dev/null <<EOF
(set! list (lambda (l) l))
(list '(1 2 3 4 5 6 7 8 9 10))
EOF`
actual=`echo $output | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
exit 0
else
echo "Fail: expected '${expected}', got '${actual}'"
exit 1
fi

29
archive/unit-tests/let.sh Executable file
View file

@ -0,0 +1,29 @@
#!/bin/bash
result=0
expected='11'
actual=`echo "(let ((a . 5)(b . 6)) (+ a b))" | target/psse | tail -1`
echo -n "$0: let with two bindings, one form in body... "
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '$expected', got '$actual'"
result=`echo "${result} + 1" | bc`
fi
expected='1'
actual=`echo "(let ((a . 5)(b . 6)) (+ a b) (- b a))" | target/psse | tail -1`
echo -n "$0: let with two bindings, two forms in body..."
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '$expected', got '$actual'"
result=`echo "${result} + 1" | bc`
fi
exit ${result}

47
archive/unit-tests/list-test.sh Normal file
View file

@ -0,0 +1,47 @@
#!/bin/bash
result=0
echo -n "$0: flat list with 16 elements... "
expected="(0 1 2 3 4 5 6 7 8 9 a b c d e f)"
actual=`echo "(list 0 1 2 3 4 5 6 7 8 9 'a 'b 'c 'd 'e 'f)" |\
target/psse 2>/dev/null |\
tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '$expected', got '$actual'"
result=`echo "${result} + 1" | bc`
fi
echo -n "$0: flat list with 5 elements... "
expected="(0 1 2 3 4)"
actual=`echo "(list 0 1 2 3 4)" | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '$expected', got '$actual'"
result=`echo "${result} + 1" | bc`
fi
echo -n "$0: flat list with 8 elements... "
expected="(0 1 2 3 4 5 6 7)"
actual=`echo "(list 0 1 2 3 4 5 6 7)" | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
exit 0
else
echo "Fail: expected '$expected', got '$actual'"
result=`echo "${result} + 1" | bc`
fi
exit ${result}

30
archive/unit-tests/many-args.sh Executable file
View file

@ -0,0 +1,30 @@
#!/bin/bash
result=0
echo -n "$0: plus with fifteen arguments... "
expected="120"
actual=`echo "(+ 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)" | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
echo -n "$0: check that all the args are actually being evaluated... "
expected="120"
actual=`echo "(+ (+ 0 1) (+ 0 2) (+ 0 3) (+ 0 4) (+ 0 5) (+ 0 6) (+ 0 7) (+ 0 8) (+ 0 9) (+ 0 10) (+ 0 11) (+ 0 12) (+ 0 13) (+ 0 14 ) (+ 0 15))" | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
exit ${result}

95
archive/unit-tests/map.sh Executable file
View file

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

31
archive/unit-tests/mapcar.sh Normal file
View file

@ -0,0 +1,31 @@
#!/bin/bash
result=0
#####################################################################
# Create an empty map using map notation
expected='(2 3 4)'
actual=`echo "(mapcar (lambda (n) (+ n 1)) '(1 2 3))" | target/psse | tail -1`
echo -n "$0: Mapping interpreted function across list: "
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=1
fi
#####################################################################
# Create an empty map using make-map
expected='("INTR" "REAL" "RTIO" "KEYW")'
actual=`echo "(mapcar type '(1 1.0 1/2 :one))" | target/psse | tail -1`
echo -n "$0: Mapping primitive function across list: "
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=1
fi

108
archive/unit-tests/memberp.sh Normal file
View file

@ -0,0 +1,108 @@
#!/bin/bash
result=0
expected='t'
output=`target/psse $1 <<EOF
(progn
(set! nil? (lambda (o) (= (type o) "NIL ")))
(set! member?
(lambda
(item collection)
(cond
((nil? collection) nil)
((= item (car collection)) t)
(t (member? item (cdr collection))))))
(member? 1 '(1 2 3 4)))
EOF`
actual=`echo $output | tail -1`
echo -n "$0 $1: (member? 1 '(1 2 3 4))... "
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
expected='t'
output=`target/psse $1 <<EOF
(progn
(set! nil? (lambda (o) (= (type o) "NIL ")))
(set! member?
(lambda
(item collection)
(cond
((nil? collection) nil)
((= item (car collection)) t)
(t (member? item (cdr collection))))))
(member? 4 '(1 2 3 4)))
EOF`
actual=`echo $output | tail -1`
echo -n "$0: (member? 4 '(1 2 3 4))... "
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
expected='nil'
output=`target/psse $1 <<EOF
(progn
(set! nil? (lambda (o) (= (type o) "NIL ")))
(set! member?
(lambda
(item collection)
;; (progn (print (list "In member; collection is:" collection)) (println))
(cond
((nil? collection) nil)
((= item (car collection)) t)
(t (member? item (cdr collection))))))
(member? 5 '(1 2 3 4)))
EOF`
actual=`echo $output | tail -1`
echo -n "$0: (member? 5 '(1 2 3 4))... "
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
expected='nil'
output=`target/psse $1 -s100<<EOF
(progn
(set! nil? (lambda (o) (= (type o) "NIL ")))
(set! member?
(lambda
(item collection)
;; (print (list "in member?: " 'item item 'collection collection) *log*)(println *log*)
(cond
((nil? collection) nil)
((= item (car collection)) t)
(t (member? item (cdr collection))))))
(member? 5 '(1 2 3 4)))
EOF`
actual=`echo $output | tail -1`
echo -n "$0: (member? 5 '(1 2 3 4)) with stack limit... "
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
exit $result

14
archive/unit-tests/memory.sh Normal file
View file

@ -0,0 +1,14 @@
#!/bin/bash
actual=`echo "" | target/psse 2>&1 | tail -2`
alloc=`echo $actual | sed 's/[[:punct:]]/ /g' | awk '{print $4}'`
dealloc=`echo $actual | sed 's/[[:punct:]]/ /g' | awk '{print $6}'`
if [ "${alloc}" = "${dealloc}" ]
then
echo "OK"
else
echo "Fail: expected '${alloc}', got '${dealloc}'"
exit 1
fi

31
archive/unit-tests/multiply.sh Executable file
View file

@ -0,0 +1,31 @@
#!/bin/bash
result=0
echo -n "$0: multiply two integers... "
expected='6'
actual=`echo "(multiply 2 3)" | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
echo -n "$0: multiply a real by an integer... "
expected='7.5'
actual=`echo "(multiply 2.5 3)" | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
exit ${result}

13
archive/unit-tests/nil.sh Executable file
View file

@ -0,0 +1,13 @@
#!/bin/bash
expected=nil
actual=`echo 'nil' | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
exit 0
else
echo "Fail: expected '${expected}', got '${actual}'"
exit 1
fi

13
archive/unit-tests/nlambda.sh Executable file
View file

@ -0,0 +1,13 @@
#!/bin/bash
expected='a'
actual=`echo "((nlambda (x) x) a)" | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
exit 0
else
echo "Fail: expected '${expected}', got '${actual}'"
exit 1
fi

34
archive/unit-tests/path-notation.sh Executable file
View file

@ -0,0 +1,34 @@
#!/bin/bash
result=0
#####################################################################
# Create a path from root using compact path notation
echo -n "$0: Create a path from root using compact path notation... "
expected='(-> (oblist) :users :simon :functions (quote assoc))'
actual=`echo "'/:users:simon:functions/assoc" | target/psse 2>&1 | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
#####################################################################
# Create a path from the current session using compact path notation
echo -n "$0: Create a path from the current session using compact path notation... "
expected='(-> session :input-stream)'
actual=`echo "'$:input-stream" | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
exit ${result}

29
archive/unit-tests/progn.sh Executable file
View file

@ -0,0 +1,29 @@
#!/bin/bash
result=0
echo -n "$0: progn with one form... "
expected='5'
actual=`echo "(progn (add 2 3))" | target/psse | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
echo -n "$0: progn with two forms... "
expected='"foo"'
actual=`echo "(progn (add 2.5 3) \"foo\")" | target/psse | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
exit ${result}

13
archive/unit-tests/quote.sh Executable file
View file

@ -0,0 +1,13 @@
#!/bin/bash
expected='Fred'
actual=`echo "'Fred" | target/psse 2>&1 | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
exit 0
else
echo "Fail: expected '${expected}', got '${actual}'"
exit 1
fi

13
archive/unit-tests/quoted-list.sh Executable file
View file

@ -0,0 +1,13 @@
#!/bin/bash
expected='(123 (4 (5 nil)) Fred)'
actual=`echo "'(123 (4 (5 ())) Fred)" | target/psse 2>&1 | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
exit 0
else
echo "Fail: expected '${expected}', got '${actual}'"
exit 1
fi

Some files were not shown because too many files have changed in this diff Show more