From 8d2acbeb0f67ccafd3d31d130d5f406624f5ec62 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 22 Apr 2026 21:09:15 +0100 Subject: [PATCH] Still making progress. Dropped the archive because it was causing problems. --- archive/c/arith/integer.c | 508 -------- archive/c/arith/integer.h | 41 - archive/c/arith/peano.c | 825 ------------- archive/c/arith/peano.h | 95 -- archive/c/arith/ratio.c | 411 ------- archive/c/arith/ratio.h | 41 - archive/c/arith/real.c | 29 - archive/c/arith/real.h | 32 - archive/c/authorise.c | 24 - archive/c/authorise.h | 16 - archive/c/debug.c | 181 --- archive/c/debug.h | 101 -- archive/c/init.c | 564 --------- archive/c/io/fopen.c | 526 -------- archive/c/io/fopen.h | 83 -- archive/c/io/history.c | 14 - archive/c/io/history.h | 14 - archive/c/io/io.c | 557 --------- archive/c/io/io.h | 46 - archive/c/io/print.c | 356 ------ archive/c/io/print.h | 30 - archive/c/io/read.c | 570 --------- archive/c/io/read.h | 32 - archive/c/memory/conspage.c | 290 ----- archive/c/memory/conspage.h | 68 - archive/c/memory/consspaceobject.c | 561 --------- archive/c/memory/consspaceobject.h | 812 ------------ archive/c/memory/cursor.c | 9 - archive/c/memory/cursor.h | Bin 614 -> 0 bytes archive/c/memory/dump.c | 166 --- archive/c/memory/dump.h | 27 - archive/c/memory/hashmap.c | 152 --- archive/c/memory/hashmap.h | 38 - archive/c/memory/lookup3.c | 1281 ------------------- archive/c/memory/lookup3.h | 16 - archive/c/memory/stack.c | 380 ------ archive/c/memory/stack.h | 69 -- archive/c/memory/vectorspace.c | 158 --- archive/c/memory/vectorspace.h | 121 -- archive/c/ops/equal.c | 433 ------- archive/c/ops/equal.h | 36 - archive/c/ops/intern.c | 574 --------- archive/c/ops/intern.h | 81 -- archive/c/ops/lispops.c | 1840 ---------------------------- archive/c/ops/lispops.h | 250 ---- archive/c/ops/loop.c | 50 - archive/c/ops/loop.h | 10 - archive/c/ops/meta.c | 45 - archive/c/ops/meta.h | 18 - archive/c/repl.c | 50 - archive/c/repl.h | 29 - archive/c/time/psse_time.c | 109 -- archive/c/time/psse_time.h | 21 - archive/c/utils.c | 33 - archive/c/utils.h | 17 - archive/c/version.h | 11 - src/c/environment/environment.c | 20 +- src/c/io/io.c | 164 ++- src/c/io/io.h | 11 +- src/c/io/print.c | 43 +- src/c/io/print.h | 4 +- src/c/io/read.c | 52 +- src/c/io/read.h | 9 +- src/c/memory/destroy.c | 6 +- src/c/memory/memory.c | 12 +- src/c/memory/node.c | 23 +- src/c/memory/page.c | 3 +- src/c/memory/pso.c | 6 +- src/c/memory/tags.c | 6 +- src/c/memory/tags.h | 3 +- src/c/ops/assoc.c | 18 +- src/c/ops/bind.c | 17 +- src/c/ops/bind.h | 10 +- src/c/ops/eq.h | 2 +- src/c/ops/eval_apply.c | 58 +- src/c/ops/eval_apply.h | 14 +- src/c/ops/list_ops.c | 20 +- src/c/ops/list_ops.h | 2 +- src/c/ops/repl.c | 51 +- src/c/ops/repl.h | 3 +- src/c/ops/reverse.c | 23 +- src/c/ops/stack_ops.c | 7 +- src/c/ops/stack_ops.h | 2 +- src/c/ops/truth.c | 54 +- src/c/ops/truth.h | 4 +- src/c/payloads/character.h | 3 +- src/c/payloads/cons.c | 142 ++- src/c/payloads/cons.h | 7 +- src/c/payloads/exception.c | 21 +- src/c/payloads/exception.h | 3 +- src/c/payloads/integer.c | 3 +- src/c/payloads/integer.h | 3 +- src/c/payloads/psse_string.c | 14 +- src/c/payloads/psse_string.h | 3 +- src/c/payloads/stack.c | 77 +- src/c/payloads/stack.h | 18 +- src/c/psse.c | 20 +- 97 files changed, 490 insertions(+), 13322 deletions(-) delete mode 100644 archive/c/arith/integer.c delete mode 100644 archive/c/arith/integer.h delete mode 100644 archive/c/arith/peano.c delete mode 100644 archive/c/arith/peano.h delete mode 100644 archive/c/arith/ratio.c delete mode 100644 archive/c/arith/ratio.h delete mode 100644 archive/c/arith/real.c delete mode 100644 archive/c/arith/real.h delete mode 100644 archive/c/authorise.c delete mode 100644 archive/c/authorise.h delete mode 100644 archive/c/debug.c delete mode 100644 archive/c/debug.h delete mode 100644 archive/c/init.c delete mode 100644 archive/c/io/fopen.c delete mode 100644 archive/c/io/fopen.h delete mode 100644 archive/c/io/history.c delete mode 100644 archive/c/io/history.h delete mode 100644 archive/c/io/io.c delete mode 100644 archive/c/io/io.h delete mode 100644 archive/c/io/print.c delete mode 100644 archive/c/io/print.h delete mode 100644 archive/c/io/read.c delete mode 100644 archive/c/io/read.h delete mode 100644 archive/c/memory/conspage.c delete mode 100644 archive/c/memory/conspage.h delete mode 100644 archive/c/memory/consspaceobject.c delete mode 100644 archive/c/memory/consspaceobject.h delete mode 100644 archive/c/memory/cursor.c delete mode 100644 archive/c/memory/cursor.h delete mode 100644 archive/c/memory/dump.c delete mode 100644 archive/c/memory/dump.h delete mode 100644 archive/c/memory/hashmap.c delete mode 100644 archive/c/memory/hashmap.h delete mode 100644 archive/c/memory/lookup3.c delete mode 100644 archive/c/memory/lookup3.h delete mode 100644 archive/c/memory/stack.c delete mode 100644 archive/c/memory/stack.h delete mode 100644 archive/c/memory/vectorspace.c delete mode 100644 archive/c/memory/vectorspace.h delete mode 100644 archive/c/ops/equal.c delete mode 100644 archive/c/ops/equal.h delete mode 100644 archive/c/ops/intern.c delete mode 100644 archive/c/ops/intern.h delete mode 100644 archive/c/ops/lispops.c delete mode 100644 archive/c/ops/lispops.h delete mode 100644 archive/c/ops/loop.c delete mode 100644 archive/c/ops/loop.h delete mode 100644 archive/c/ops/meta.c delete mode 100644 archive/c/ops/meta.h delete mode 100644 archive/c/repl.c delete mode 100644 archive/c/repl.h delete mode 100644 archive/c/time/psse_time.c delete mode 100644 archive/c/time/psse_time.h delete mode 100644 archive/c/utils.c delete mode 100644 archive/c/utils.h delete mode 100644 archive/c/version.h diff --git a/archive/c/arith/integer.c b/archive/c/arith/integer.c deleted file mode 100644 index 682efd0..0000000 --- a/archive/c/arith/integer.c +++ /dev/null @@ -1,508 +0,0 @@ -/* - * integer.c - * - * functions for integer cells. - * - * (c) 2017 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#define _GNU_SOURCE -#include -#include -#include -#include -#include -/* - * wide characters - */ -#include -#include - -#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; -} diff --git a/archive/c/arith/integer.h b/archive/c/arith/integer.h deleted file mode 100644 index e08549f..0000000 --- a/archive/c/arith/integer.h +++ /dev/null @@ -1,41 +0,0 @@ -/* - * integer.h - * - * functions for integer cells. - * - * - * (c) 2017 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#ifndef __integer_h -#define __integer_h - -#include -#include -#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 diff --git a/archive/c/arith/peano.c b/archive/c/arith/peano.c deleted file mode 100644 index 9a1b478..0000000 --- a/archive/c/arith/peano.c +++ /dev/null @@ -1,825 +0,0 @@ -/* - * peano.c - * - * Basic peano arithmetic - * - * (c) 2017 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#include -#include -#include -#include -#include -#include - -#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; -} diff --git a/archive/c/arith/peano.h b/archive/c/arith/peano.h deleted file mode 100644 index c85a9d8..0000000 --- a/archive/c/arith/peano.h +++ /dev/null @@ -1,95 +0,0 @@ -/* - * peano.h - * - * Basic peano arithmetic - * - * (c) 2017 Simon Brooke - * 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 */ diff --git a/archive/c/arith/ratio.c b/archive/c/arith/ratio.c deleted file mode 100644 index 82f9138..0000000 --- a/archive/c/arith/ratio.c +++ /dev/null @@ -1,411 +0,0 @@ -/* - * ratio.c - * - * functions for rational number cells. - * - * (c) 2017 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#define _GNU_SOURCE -#include -#include - -#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; -} diff --git a/archive/c/arith/ratio.h b/archive/c/arith/ratio.h deleted file mode 100644 index 2e39754..0000000 --- a/archive/c/arith/ratio.h +++ /dev/null @@ -1,41 +0,0 @@ -/** - * ratio.h - * - * functions for rational number cells. - * - * - * (c) 2017 Simon Brooke - * 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 diff --git a/archive/c/arith/real.c b/archive/c/arith/real.c deleted file mode 100644 index 34d29d0..0000000 --- a/archive/c/arith/real.c +++ /dev/null @@ -1,29 +0,0 @@ -/* - * real.c - * - * functions for real number cells. - * - * (c) 2017 Simon Brooke - * 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; -} diff --git a/archive/c/arith/real.h b/archive/c/arith/real.h deleted file mode 100644 index 6e4ed53..0000000 --- a/archive/c/arith/real.h +++ /dev/null @@ -1,32 +0,0 @@ -/* - * 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 */ diff --git a/archive/c/authorise.c b/archive/c/authorise.c deleted file mode 100644 index afd730d..0000000 --- a/archive/c/authorise.c +++ /dev/null @@ -1,24 +0,0 @@ -/* - * authorised.c - * - * For now, a dummy authorising everything. - * - * (c) 2021 Simon Brooke - * 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; -} diff --git a/archive/c/authorise.h b/archive/c/authorise.h deleted file mode 100644 index 6c55b32..0000000 --- a/archive/c/authorise.h +++ /dev/null @@ -1,16 +0,0 @@ -/* - * authorise.h - * - * Basic implementation of a authorisation. - * - * (c) 2021 Simon Brooke - * 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 diff --git a/archive/c/debug.c b/archive/c/debug.c deleted file mode 100644 index 3df7dc1..0000000 --- a/archive/c/debug.c +++ /dev/null @@ -1,181 +0,0 @@ -/* - * debug.c - * - * Better debug log messages. - * - * (c) 2017 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#include -#include -#include -#include -#include -/* - * wide characters - */ -#include -#include - -#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( char32_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, char32_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 - // char32_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 -} diff --git a/archive/c/debug.h b/archive/c/debug.h deleted file mode 100644 index cccf3ff..0000000 --- a/archive/c/debug.h +++ /dev/null @@ -1,101 +0,0 @@ -/* - * debug.h - * - * Better debug log messages. - * - * (c) 2017 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#include -#include -#include - -#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( char32_t *message, int level ); -void debug_print_128bit( __int128_t n, int level ); -void debug_println( int level ); -void debug_printf( int level, char32_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 diff --git a/archive/c/init.c b/archive/c/init.c deleted file mode 100644 index fbfdb2f..0000000 --- a/archive/c/init.c +++ /dev/null @@ -1,564 +0,0 @@ -/* - * init.c - * - * Start up and initialise the environement - just enough to get working - * and (ultimately) hand off to the executive. - * - * - * (c) 2017 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#include -#include -#include -#include -#include -#include -#include - -/* libcurl, used for io */ -#include - -#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 ); - c_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( char32_t *name, - char32_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( char32_t *name, - char32_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( char32_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 ); -} diff --git a/archive/c/io/fopen.c b/archive/c/io/fopen.c deleted file mode 100644 index bf918ec..0000000 --- a/archive/c/io/fopen.c +++ /dev/null @@ -1,526 +0,0 @@ -/* - * 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 - * - * 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 -#include -#ifndef WIN32 -#include -#endif -#include -#include - -#include - -#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 diff --git a/archive/c/io/fopen.h b/archive/c/io/fopen.h deleted file mode 100644 index 5f87bd2..0000000 --- a/archive/c/io/fopen.h +++ /dev/null @@ -1,83 +0,0 @@ -/* - * 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 - * - * 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 -/* - * wide characters - */ -#include -#include - -#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 diff --git a/archive/c/io/history.c b/archive/c/io/history.c deleted file mode 100644 index 417a6b1..0000000 --- a/archive/c/io/history.c +++ /dev/null @@ -1,14 +0,0 @@ -/* - * 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 - * Licensed under GPL version 2.0, or, at your option, any later version. - */ diff --git a/archive/c/io/history.h b/archive/c/io/history.h deleted file mode 100644 index ffdd262..0000000 --- a/archive/c/io/history.h +++ /dev/null @@ -1,14 +0,0 @@ -/* - * 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 - * Licensed under GPL version 2.0, or, at your option, any later version. - */ diff --git a/archive/c/io/io.c b/archive/c/io/io.c deleted file mode 100644 index f8a400c..0000000 --- a/archive/c/io/io.c +++ /dev/null @@ -1,557 +0,0 @@ -/* - * 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 - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -/* - * wide characters - */ -#include -#include - -#include - -#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++; - } - - char32_t *buffer = calloc( len + 1, sizeof( char32_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( char32_t ) + 2, sizeof( char ) ); - char32_t *wbuff = calloc( 2, sizeof( char32_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, char32_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, char32_t *key, - char *value ) { - value = trim( value ); - char32_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, char32_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] ); - char32_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( ( char32_t ) c, NIL ); - cell->payload.string.cdr = cursor; - } - } - - return result; -} diff --git a/archive/c/io/io.h b/archive/c/io/io.h deleted file mode 100644 index 0f971a3..0000000 --- a/archive/c/io/io.h +++ /dev/null @@ -1,46 +0,0 @@ - -/* - * io.h - * - * Communication between PSSE and the outside world, via libcurl. - * - * (c) 2019 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#ifndef __psse_io_h -#define __psse_io_h -#include -#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 diff --git a/archive/c/io/print.c b/archive/c/io/print.c deleted file mode 100644 index c945943..0000000 --- a/archive/c/io/print.c +++ /dev/null @@ -1,356 +0,0 @@ -/* - * print.c - * - * First pass at a printer, for bootstrapping. - * - * (c) 2017 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#include -#include -#include -#include -/* - * wide characters - */ -#include -#include - -#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 ); - char32_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 ); - } - c_print( output, cell->payload.cons.car ); - - print_list_contents( output, cell->payload.cons.cdr, true ); - break; - case NILTV: - break; - default: - url_fwprintf( output, L" . " ); - c_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 ); - c_print( output, key ); - url_fputwc( btowc( ' ' ), output ); - c_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 c_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"', 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"', output ); - } - break; - case NILTV: - url_fwprintf( output, L"nil" ); - break; - case NLAMBDATV:{ - url_fputws( L"', output ); - } - break; - case RATIOTV: - c_print( output, cell.payload.ratio.dividend ); - url_fputws( L"/", output ); - c_print( output, cell.payload.ratio.divisor ); - break; - case READTV: - url_fwprintf( output, 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"', output ); - break; - case TIMETV: - url_fwprintf( output, 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 ); - 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 = c_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; -} diff --git a/archive/c/io/print.h b/archive/c/io/print.h deleted file mode 100644 index 0d9aae8..0000000 --- a/archive/c/io/print.h +++ /dev/null @@ -1,30 +0,0 @@ -/** - * print.h - * - * First pass at a printer, for bootstrapping. - * - * - * (c) 2017 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#include -#include - -#include "io/fopen.h" - -#ifndef __print_h -#define __print_h - -struct cons_pointer c_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 diff --git a/archive/c/io/read.c b/archive/c/io/read.c deleted file mode 100644 index fee80b3..0000000 --- a/archive/c/io/read.c +++ /dev/null @@ -1,570 +0,0 @@ -/* - * read.c - * - * First pass at a reader, for bootstrapping. - * - * - * (c) 2017 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#include -#include -#include -/* - * wide characters - */ -#include -#include - -#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 -// #include - - -/* - * 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 ) ); -} diff --git a/archive/c/io/read.h b/archive/c/io/read.h deleted file mode 100644 index 7f58d0c..0000000 --- a/archive/c/io/read.h +++ /dev/null @@ -1,32 +0,0 @@ -/** - * read.c - * - * First pass at a reader, for bootstrapping. - * - * - * (c) 2017 Simon Brooke - * 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 diff --git a/archive/c/memory/conspage.c b/archive/c/memory/conspage.c deleted file mode 100644 index 31ab050..0000000 --- a/archive/c/memory/conspage.c +++ /dev/null @@ -1,290 +0,0 @@ -/* - * 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 - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#include -#include -#include -#include - -#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 ); -} diff --git a/archive/c/memory/conspage.h b/archive/c/memory/conspage.h deleted file mode 100644 index 3bad3ae..0000000 --- a/archive/c/memory/conspage.h +++ /dev/null @@ -1,68 +0,0 @@ -/* - * 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 - * 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 diff --git a/archive/c/memory/consspaceobject.c b/archive/c/memory/consspaceobject.c deleted file mode 100644 index 4220618..0000000 --- a/archive/c/memory/consspaceobject.c +++ /dev/null @@ -1,561 +0,0 @@ -/* - * consspaceobject.c - * - * Structures common to all cons space objects. - * - * - * (c) 2017 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#include -#include -#include -#include -/* - * wide characters - */ -#include -#include - -#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( ( char32_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( ( char32_t ) vec->header.tag.bytes[i], result ); - } - } else { - for ( int i = TAGLENGTH - 1; i >= 0; i-- ) { - result = make_string( ( char32_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( char32_t *symbol ) { - struct cons_pointer result = NIL; - - for ( int i = wcslen( symbol ) - 1; i >= 0; i-- ) { - char32_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( char32_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( char32_t *symbol ) { - struct cons_pointer result = NIL; - - for ( int i = wcslen( symbol ); i > 0; i-- ) { - result = make_symbol( symbol[i - 1], result ); - } - - return result; -} diff --git a/archive/c/memory/consspaceobject.h b/archive/c/memory/consspaceobject.h deleted file mode 100644 index 62713bb..0000000 --- a/archive/c/memory/consspaceobject.h +++ /dev/null @@ -1,812 +0,0 @@ -/* - * consspaceobject.h - * - * Declarations common to all cons space objects. - * - * - * (c) 2017 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#ifndef __psse_consspaceobject_h -#define __psse_consspaceobject_h - -#include -#include -#include -/* - * wide characters - */ -#include -#include - -#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( char32_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( char32_t *string ); - -struct cons_pointer c_string_to_lisp_symbol( char32_t *symbol ); - -#endif diff --git a/archive/c/memory/cursor.c b/archive/c/memory/cursor.c deleted file mode 100644 index 31a38b2..0000000 --- a/archive/c/memory/cursor.c +++ /dev/null @@ -1,9 +0,0 @@ -/* - * 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) - */ diff --git a/archive/c/memory/cursor.h b/archive/c/memory/cursor.h deleted file mode 100644 index a50aff600d3015faae07bdd40e47973ce43ee241..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 614 zcmZWm!A=4(6!g4b@d6hmWLeOJpvH)3xR5|Vx$c&3$rei=X}gg9dtX~H7&qC&wDac8 zbb6gm0v!Ne8;d5b2n75txMGGmiP{3k{T?+q1f~=rIj~UxU*@T3WK-&4hC6& z2rKDl-VEZmfM@H`>kez9MYCr*<@_b^XOatTMG3Vog@Nf}21j8m?S(;_bpcHmn1hBU z0T12}VcmdYj_7BqH_%Ixw%n4)7Vfyfx^&xaAx5-WN1CG$cHvj+t diff --git a/archive/c/memory/dump.c b/archive/c/memory/dump.c deleted file mode 100644 index edaf269..0000000 --- a/archive/c/memory/dump.c +++ /dev/null @@ -1,166 +0,0 @@ -/* - * dump.c - * - * Dump representations of both cons space and vector space objects. - * - * - * (c) 2018 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#include -#include -#include -#include -/* - * wide characters - */ -#include -#include - -#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, char32_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: " ); - c_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 ); - c_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: " ); - c_print( output, cell.payload.lambda.args ); - url_fwprintf( output, L";\n\t\t\tbody: " ); - c_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: " ); - c_print( output, cell.payload.lambda.args ); - url_fwprintf( output, L";\n\t\t\tbody: " ); - c_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 ); - c_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 ); - c_print( output, cell.payload.stream.meta ); - url_fputws( L"\n", output ); - break; - } -} diff --git a/archive/c/memory/dump.h b/archive/c/memory/dump.h deleted file mode 100644 index e3a4fc2..0000000 --- a/archive/c/memory/dump.h +++ /dev/null @@ -1,27 +0,0 @@ -/* - * dump.h - * - * Dump representations of both cons space and vector space objects. - * - * (c) 2018 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#include -#include -#include -/* - * wide characters - */ -#include -#include - -#ifndef __dump_h -#define __dump_h - -void dump_string_cell( URL_FILE * output, char32_t *prefix, - struct cons_pointer pointer ); - -void dump_object( URL_FILE * output, struct cons_pointer pointer ); - -#endif diff --git a/archive/c/memory/hashmap.c b/archive/c/memory/hashmap.c deleted file mode 100644 index 96baf39..0000000 --- a/archive/c/memory/hashmap.c +++ /dev/null @@ -1,152 +0,0 @@ -/* - * hashmap.c - * - * Basic implementation of a hashmap. - * - * (c) 2021 Simon Brooke - * 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: " ); - c_print( output, payload->hash_fn ); - url_fwprintf( output, L"\n\tWrite ACL: " ); - c_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 ); - c_print( output, payload->buckets[i] ); - } - url_fwprintf( output, L"\n" ); -} diff --git a/archive/c/memory/hashmap.h b/archive/c/memory/hashmap.h deleted file mode 100644 index 05823bb..0000000 --- a/archive/c/memory/hashmap.h +++ /dev/null @@ -1,38 +0,0 @@ -/* - * hashmap.h - * - * Basic implementation of a hashmap. - * - * (c) 2021 Simon Brooke - * 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 diff --git a/archive/c/memory/lookup3.c b/archive/c/memory/lookup3.c deleted file mode 100644 index 043d703..0000000 --- a/archive/c/memory/lookup3.c +++ /dev/null @@ -1,1281 +0,0 @@ -/* -------------------------------------------------------------------------------- -lookup3.c, by Bob Jenkins, May 2006, Public Domain. - -These are functions for producing 32-bit hashes for hash table lookup. -hashword(), hashlittle(), hashlittle2(), hashbig(), mix(), and final() -are externally useful functions. Routines to test the hash are included -if SELF_TEST is defined. You can use this free for any purpose. It's in -the public domain. It has no warranty. - -You probably want to use hashlittle(). hashlittle() and hashbig() -hash byte arrays. hashlittle() is is faster than hashbig() on -little-endian machines. Intel and AMD are little-endian machines. -On second thought, you probably want hashlittle2(), which is identical to -hashlittle() except it returns two 32-bit hashes for the price of one. -You could implement hashbig2() if you wanted but I haven't bothered here. - -If you want to find a hash of, say, exactly 7 integers, do - a = i1; b = i2; c = i3; - mix(a,b,c); - a += i4; b += i5; c += i6; - mix(a,b,c); - a += i7; - final(a,b,c); -then use c as the hash value. If you have a variable length array of -4-byte integers to hash, use hashword(). If you have a byte array (like -a character string), use hashlittle(). If you have several byte arrays, or -a mix of things, see the comments above hashlittle(). - -Why is this so big? I read 12 bytes at a time into 3 4-byte integers, -then mix those integers. This is fast (you can do a lot more thorough -mixing with 12*3 instructions on 3 integers than you can with 3 instructions -on 1 byte), but shoehorning those bytes into integers efficiently is messy. -------------------------------------------------------------------------------- -*/ -// #define SELF_TEST 1 - -#include /* defines printf for tests */ -#include /* defines time_t for timings in the test */ -#include /* defines uint32_t etc */ -#include /* attempt to define endianness */ -#ifdef linux -#include /* attempt to define endianness */ -#endif - -/* - * My best guess at if you are big-endian or little-endian. This may - * need adjustment. - */ -#if (defined(__BYTE_ORDER) && defined(__LITTLE_ENDIAN) && \ - __BYTE_ORDER == __LITTLE_ENDIAN) || \ - (defined(i386) || defined(__i386__) || defined(__i486__) || \ - defined(__i586__) || defined(__i686__) || defined(vax) || defined(MIPSEL)) -#define HASH_LITTLE_ENDIAN 1 -#define HASH_BIG_ENDIAN 0 -#elif (defined(__BYTE_ORDER) && defined(__BIG_ENDIAN) && \ - __BYTE_ORDER == __BIG_ENDIAN) || \ - (defined(sparc) || defined(POWERPC) || defined(mc68000) || defined(sel)) -#define HASH_LITTLE_ENDIAN 0 -#define HASH_BIG_ENDIAN 1 -#else -#define HASH_LITTLE_ENDIAN 0 -#define HASH_BIG_ENDIAN 0 -#endif - -#define hashsize(n) ((uint32_t)1<<(n)) -#define hashmask(n) (hashsize(n)-1) -#define rot(x,k) (((x)<<(k)) | ((x)>>(32-(k)))) - -/* -------------------------------------------------------------------------------- -mix -- mix 3 32-bit values reversibly. - -This is reversible, so any information in (a,b,c) before mix() is -still in (a,b,c) after mix(). - -If four pairs of (a,b,c) inputs are run through mix(), or through -mix() in reverse, there are at least 32 bits of the output that -are sometimes the same for one pair and different for another pair. -This was tested for: -* pairs that differed by one bit, by two bits, in any combination - of top bits of (a,b,c), or in any combination of bottom bits of - (a,b,c). -* "differ" is defined as +, -, ^, or ~^. For + and -, I transformed - the output delta to a Gray code (a^(a>>1)) so a string of 1's (as - is commonly produced by subtraction) look like a single 1-bit - difference. -* the base values were pseudorandom, all zero but one bit set, or - all zero plus a counter that starts at zero. - -Some k values for my "a-=c; a^=rot(c,k); c+=b;" arrangement that -satisfy this are - 4 6 8 16 19 4 - 9 15 3 18 27 15 - 14 9 3 7 17 3 -Well, "9 15 3 18 27 15" didn't quite get 32 bits diffing -for "differ" defined as + with a one-bit base and a two-bit delta. I -used http://burtleburtle.net/bob/hash/avalanche.html to choose -the operations, constants, and arrangements of the variables. - -This does not achieve avalanche. There are input bits of (a,b,c) -that fail to affect some output bits of (a,b,c), especially of a. The -most thoroughly mixed value is c, but it doesn't really even achieve -avalanche in c. - -This allows some parallelism. Read-after-writes are good at doubling -the number of bits affected, so the goal of mixing pulls in the opposite -direction as the goal of parallelism. I did what I could. Rotates -seem to cost as much as shifts on every machine I could lay my hands -on, and rotates are much kinder to the top and bottom bits, so I used -rotates. -------------------------------------------------------------------------------- -*/ -#define mix(a,b,c) \ -{ \ - a -= c; a ^= rot(c, 4); c += b; \ - b -= a; b ^= rot(a, 6); a += c; \ - c -= b; c ^= rot(b, 8); b += a; \ - a -= c; a ^= rot(c,16); c += b; \ - b -= a; b ^= rot(a,19); a += c; \ - c -= b; c ^= rot(b, 4); b += a; \ -} - -/* -------------------------------------------------------------------------------- -final -- final mixing of 3 32-bit values (a,b,c) into c - -Pairs of (a,b,c) values differing in only a few bits will usually -produce values of c that look totally different. This was tested for -* pairs that differed by one bit, by two bits, in any combination - of top bits of (a,b,c), or in any combination of bottom bits of - (a,b,c). -* "differ" is defined as +, -, ^, or ~^. For + and -, I transformed - the output delta to a Gray code (a^(a>>1)) so a string of 1's (as - is commonly produced by subtraction) look like a single 1-bit - difference. -* the base values were pseudorandom, all zero but one bit set, or - all zero plus a counter that starts at zero. - -These constants passed: - 14 11 25 16 4 14 24 - 12 14 25 16 4 14 24 -and these came close: - 4 8 15 26 3 22 24 - 10 8 15 26 3 22 24 - 11 8 15 26 3 22 24 -------------------------------------------------------------------------------- -*/ -#define final(a,b,c) \ -{ \ - c ^= b; c -= rot(b,14); \ - a ^= c; a -= rot(c,11); \ - b ^= a; b -= rot(a,25); \ - c ^= b; c -= rot(b,16); \ - a ^= c; a -= rot(c,4); \ - b ^= a; b -= rot(a,14); \ - c ^= b; c -= rot(b,24); \ -} - -/* --------------------------------------------------------------------- - This works on all machines. To be useful, it requires - -- that the key be an array of uint32_t's, and - -- that the length be the number of uint32_t's in the key - - The function hashword() is identical to hashlittle() on little-endian - machines, and identical to hashbig() on big-endian machines, - except that the length has to be measured in uint32_ts rather than in - bytes. hashlittle() is more complicated than hashword() only because - hashlittle() has to dance around fitting the key bytes into registers. --------------------------------------------------------------------- -*/ -uint32_t hashword( const uint32_t *k, /* the key, an array of uint32_t values */ - size_t length, /* the length of the key, in uint32_ts */ - uint32_t initval ) { /* the previous hash, or an arbitrary value */ - uint32_t a, b, c; - - /* Set up the internal state */ - a = b = c = 0xdeadbeef + ( ( ( uint32_t ) length ) << 2 ) + initval; - - /*------------------------------------------------- handle most of the key */ - while ( length > 3 ) { - a += k[0]; - b += k[1]; - c += k[2]; - mix( a, b, c ); - length -= 3; - k += 3; - } - - /*------------------------------------------- handle the last 3 uint32_t's */ - switch ( length ) { /* all the case statements fall through */ - case 3: - c += k[2]; - case 2: - b += k[1]; - case 1: - a += k[0]; - final( a, b, c ); - case 0: /* case 0: nothing left to add */ - break; - } - /*------------------------------------------------------ report the result */ - return c; -} - - -/* --------------------------------------------------------------------- -hashword2() -- same as hashword(), but take two seeds and return two -32-bit values. pc and pb must both be nonnull, and *pc and *pb must -both be initialized with seeds. If you pass in (*pb)==0, the output -(*pc) will be the same as the return value from hashword(). --------------------------------------------------------------------- -*/ -void hashword2( const uint32_t *k, /* the key, an array of uint32_t values */ - size_t length, /* the length of the key, in uint32_ts */ - uint32_t *pc, /* IN: seed OUT: primary hash value */ - uint32_t *pb ) { /* IN: more seed OUT: secondary hash value */ - uint32_t a, b, c; - - /* Set up the internal state */ - a = b = c = 0xdeadbeef + ( ( uint32_t ) ( length << 2 ) ) + *pc; - c += *pb; - - /*------------------------------------------------- handle most of the key */ - while ( length > 3 ) { - a += k[0]; - b += k[1]; - c += k[2]; - mix( a, b, c ); - length -= 3; - k += 3; - } - - /*------------------------------------------- handle the last 3 uint32_t's */ - switch ( length ) { /* all the case statements fall through */ - case 3: - c += k[2]; - case 2: - b += k[1]; - case 1: - a += k[0]; - final( a, b, c ); - case 0: /* case 0: nothing left to add */ - break; - } - /*------------------------------------------------------ report the result */ - *pc = c; - *pb = b; -} - - -/* -------------------------------------------------------------------------------- -hashlittle() -- hash a variable-length key into a 32-bit value - k : the key (the unaligned variable-length array of bytes) - length : the length of the key, counting by bytes - initval : can be any 4-byte value -Returns a 32-bit value. Every bit of the key affects every bit of -the return value. Two keys differing by one or two bits will have -totally different hash values. - -The best hash table sizes are powers of 2. There is no need to do -mod a prime (mod is sooo slow!). If you need less than 32 bits, -use a bitmask. For example, if you need only 10 bits, do - h = (h & hashmask(10)); -In which case, the hash table should have hashsize(10) elements. - -If you are hashing n strings (uint8_t **)k, do it like this: - for (i=0, h=0; i 12 ) { - a += k[0]; - b += k[1]; - c += k[2]; - mix( a, b, c ); - length -= 12; - k += 3; - } - - /*----------------------------- handle the last (probably partial) block */ - /* - * "k[2]&0xffffff" actually reads beyond the end of the string, but - * then masks off the part it's not allowed to read. Because the - * string is aligned, the masked-off tail is in the same word as the - * rest of the string. Every machine with memory protection I've seen - * does it on word boundaries, so is OK with this. But VALGRIND will - * still catch it and complain. The masking trick does make the hash - * noticably faster for short strings (like English words). - */ -#ifndef VALGRIND - - switch ( length ) { - case 12: - c += k[2]; - b += k[1]; - a += k[0]; - break; - case 11: - c += k[2] & 0xffffff; - b += k[1]; - a += k[0]; - break; - case 10: - c += k[2] & 0xffff; - b += k[1]; - a += k[0]; - break; - case 9: - c += k[2] & 0xff; - b += k[1]; - a += k[0]; - break; - case 8: - b += k[1]; - a += k[0]; - break; - case 7: - b += k[1] & 0xffffff; - a += k[0]; - break; - case 6: - b += k[1] & 0xffff; - a += k[0]; - break; - case 5: - b += k[1] & 0xff; - a += k[0]; - break; - case 4: - a += k[0]; - break; - case 3: - a += k[0] & 0xffffff; - break; - case 2: - a += k[0] & 0xffff; - break; - case 1: - a += k[0] & 0xff; - break; - case 0: - return c; /* zero length strings require no mixing */ - } - -#else /* make valgrind happy */ - - k8 = ( const uint8_t * ) k; - switch ( length ) { - case 12: - c += k[2]; - b += k[1]; - a += k[0]; - break; - case 11: - c += ( ( uint32_t ) k8[10] ) << 16; /* fall through */ - case 10: - c += ( ( uint32_t ) k8[9] ) << 8; /* fall through */ - case 9: - c += k8[8]; /* fall through */ - case 8: - b += k[1]; - a += k[0]; - break; - case 7: - b += ( ( uint32_t ) k8[6] ) << 16; /* fall through */ - case 6: - b += ( ( uint32_t ) k8[5] ) << 8; /* fall through */ - case 5: - b += k8[4]; /* fall through */ - case 4: - a += k[0]; - break; - case 3: - a += ( ( uint32_t ) k8[2] ) << 16; /* fall through */ - case 2: - a += ( ( uint32_t ) k8[1] ) << 8; /* fall through */ - case 1: - a += k8[0]; - break; - case 0: - return c; - } - -#endif /* !valgrind */ - - } else if ( HASH_LITTLE_ENDIAN && ( ( u.i & 0x1 ) == 0 ) ) { - const uint16_t *k = ( const uint16_t * ) key; /* read 16-bit chunks */ - const uint8_t *k8; - - /*--------------- all but last block: aligned reads and different mixing */ - while ( length > 12 ) { - a += k[0] + ( ( ( uint32_t ) k[1] ) << 16 ); - b += k[2] + ( ( ( uint32_t ) k[3] ) << 16 ); - c += k[4] + ( ( ( uint32_t ) k[5] ) << 16 ); - mix( a, b, c ); - length -= 12; - k += 6; - } - - /*----------------------------- handle the last (probably partial) block */ - k8 = ( const uint8_t * ) k; - switch ( length ) { - case 12: - c += k[4] + ( ( ( uint32_t ) k[5] ) << 16 ); - b += k[2] + ( ( ( uint32_t ) k[3] ) << 16 ); - a += k[0] + ( ( ( uint32_t ) k[1] ) << 16 ); - break; - case 11: - c += ( ( uint32_t ) k8[10] ) << 16; /* fall through */ - case 10: - c += k[4]; - b += k[2] + ( ( ( uint32_t ) k[3] ) << 16 ); - a += k[0] + ( ( ( uint32_t ) k[1] ) << 16 ); - break; - case 9: - c += k8[8]; /* fall through */ - case 8: - b += k[2] + ( ( ( uint32_t ) k[3] ) << 16 ); - a += k[0] + ( ( ( uint32_t ) k[1] ) << 16 ); - break; - case 7: - b += ( ( uint32_t ) k8[6] ) << 16; /* fall through */ - case 6: - b += k[2]; - a += k[0] + ( ( ( uint32_t ) k[1] ) << 16 ); - break; - case 5: - b += k8[4]; /* fall through */ - case 4: - a += k[0] + ( ( ( uint32_t ) k[1] ) << 16 ); - break; - case 3: - a += ( ( uint32_t ) k8[2] ) << 16; /* fall through */ - case 2: - a += k[0]; - break; - case 1: - a += k8[0]; - break; - case 0: - return c; /* zero length requires no mixing */ - } - - } else { /* need to read the key one byte at a time */ - const uint8_t *k = ( const uint8_t * ) key; - - /*--------------- all but the last block: affect some 32 bits of (a,b,c) */ - while ( length > 12 ) { - a += k[0]; - a += ( ( uint32_t ) k[1] ) << 8; - a += ( ( uint32_t ) k[2] ) << 16; - a += ( ( uint32_t ) k[3] ) << 24; - b += k[4]; - b += ( ( uint32_t ) k[5] ) << 8; - b += ( ( uint32_t ) k[6] ) << 16; - b += ( ( uint32_t ) k[7] ) << 24; - c += k[8]; - c += ( ( uint32_t ) k[9] ) << 8; - c += ( ( uint32_t ) k[10] ) << 16; - c += ( ( uint32_t ) k[11] ) << 24; - mix( a, b, c ); - length -= 12; - k += 12; - } - - /*-------------------------------- last block: affect all 32 bits of (c) */ - switch ( length ) { /* all the case statements fall through */ - case 12: - c += ( ( uint32_t ) k[11] ) << 24; - case 11: - c += ( ( uint32_t ) k[10] ) << 16; - case 10: - c += ( ( uint32_t ) k[9] ) << 8; - case 9: - c += k[8]; - case 8: - b += ( ( uint32_t ) k[7] ) << 24; - case 7: - b += ( ( uint32_t ) k[6] ) << 16; - case 6: - b += ( ( uint32_t ) k[5] ) << 8; - case 5: - b += k[4]; - case 4: - a += ( ( uint32_t ) k[3] ) << 24; - case 3: - a += ( ( uint32_t ) k[2] ) << 16; - case 2: - a += ( ( uint32_t ) k[1] ) << 8; - case 1: - a += k[0]; - break; - case 0: - return c; - } - } - - final( a, b, c ); - return c; -} - - -/* - * hashlittle2: return 2 32-bit hash values - * - * This is identical to hashlittle(), except it returns two 32-bit hash - * values instead of just one. This is good enough for hash table - * lookup with 2^^64 buckets, or if you want a second hash if you're not - * happy with the first, or if you want a probably-unique 64-bit ID for - * the key. *pc is better mixed than *pb, so use *pc first. If you want - * a 64-bit value do something like "*pc + (((uint64_t)*pb)<<32)". - */ -void hashlittle2( const void *key, /* the key to hash */ - size_t length, /* length of the key */ - uint32_t *pc, /* IN: primary initval, OUT: primary hash */ - uint32_t *pb ) { /* IN: secondary initval, OUT: secondary hash */ - uint32_t a, b, c; /* internal state */ - union { - const void *ptr; - size_t i; - } u; /* needed for Mac Powerbook G4 */ - - /* Set up the internal state */ - a = b = c = 0xdeadbeef + ( ( uint32_t ) length ) + *pc; - c += *pb; - - u.ptr = key; - if ( HASH_LITTLE_ENDIAN && ( ( u.i & 0x3 ) == 0 ) ) { - const uint32_t *k = ( const uint32_t * ) key; /* read 32-bit chunks */ - const uint8_t *k8; - - /*------ all but last block: aligned reads and affect 32 bits of (a,b,c) */ - while ( length > 12 ) { - a += k[0]; - b += k[1]; - c += k[2]; - mix( a, b, c ); - length -= 12; - k += 3; - } - - /*----------------------------- handle the last (probably partial) block */ - /* - * "k[2]&0xffffff" actually reads beyond the end of the string, but - * then masks off the part it's not allowed to read. Because the - * string is aligned, the masked-off tail is in the same word as the - * rest of the string. Every machine with memory protection I've seen - * does it on word boundaries, so is OK with this. But VALGRIND will - * still catch it and complain. The masking trick does make the hash - * noticably faster for short strings (like English words). - */ -#ifndef VALGRIND - - switch ( length ) { - case 12: - c += k[2]; - b += k[1]; - a += k[0]; - break; - case 11: - c += k[2] & 0xffffff; - b += k[1]; - a += k[0]; - break; - case 10: - c += k[2] & 0xffff; - b += k[1]; - a += k[0]; - break; - case 9: - c += k[2] & 0xff; - b += k[1]; - a += k[0]; - break; - case 8: - b += k[1]; - a += k[0]; - break; - case 7: - b += k[1] & 0xffffff; - a += k[0]; - break; - case 6: - b += k[1] & 0xffff; - a += k[0]; - break; - case 5: - b += k[1] & 0xff; - a += k[0]; - break; - case 4: - a += k[0]; - break; - case 3: - a += k[0] & 0xffffff; - break; - case 2: - a += k[0] & 0xffff; - break; - case 1: - a += k[0] & 0xff; - break; - case 0: - *pc = c; - *pb = b; - return; /* zero length strings require no mixing */ - } - -#else /* make valgrind happy */ - - k8 = ( const uint8_t * ) k; - switch ( length ) { - case 12: - c += k[2]; - b += k[1]; - a += k[0]; - break; - case 11: - c += ( ( uint32_t ) k8[10] ) << 16; /* fall through */ - case 10: - c += ( ( uint32_t ) k8[9] ) << 8; /* fall through */ - case 9: - c += k8[8]; /* fall through */ - case 8: - b += k[1]; - a += k[0]; - break; - case 7: - b += ( ( uint32_t ) k8[6] ) << 16; /* fall through */ - case 6: - b += ( ( uint32_t ) k8[5] ) << 8; /* fall through */ - case 5: - b += k8[4]; /* fall through */ - case 4: - a += k[0]; - break; - case 3: - a += ( ( uint32_t ) k8[2] ) << 16; /* fall through */ - case 2: - a += ( ( uint32_t ) k8[1] ) << 8; /* fall through */ - case 1: - a += k8[0]; - break; - case 0: - *pc = c; - *pb = b; - return; /* zero length strings require no mixing */ - } - -#endif /* !valgrind */ - - } else if ( HASH_LITTLE_ENDIAN && ( ( u.i & 0x1 ) == 0 ) ) { - const uint16_t *k = ( const uint16_t * ) key; /* read 16-bit chunks */ - const uint8_t *k8; - - /*--------------- all but last block: aligned reads and different mixing */ - while ( length > 12 ) { - a += k[0] + ( ( ( uint32_t ) k[1] ) << 16 ); - b += k[2] + ( ( ( uint32_t ) k[3] ) << 16 ); - c += k[4] + ( ( ( uint32_t ) k[5] ) << 16 ); - mix( a, b, c ); - length -= 12; - k += 6; - } - - /*----------------------------- handle the last (probably partial) block */ - k8 = ( const uint8_t * ) k; - switch ( length ) { - case 12: - c += k[4] + ( ( ( uint32_t ) k[5] ) << 16 ); - b += k[2] + ( ( ( uint32_t ) k[3] ) << 16 ); - a += k[0] + ( ( ( uint32_t ) k[1] ) << 16 ); - break; - case 11: - c += ( ( uint32_t ) k8[10] ) << 16; /* fall through */ - case 10: - c += k[4]; - b += k[2] + ( ( ( uint32_t ) k[3] ) << 16 ); - a += k[0] + ( ( ( uint32_t ) k[1] ) << 16 ); - break; - case 9: - c += k8[8]; /* fall through */ - case 8: - b += k[2] + ( ( ( uint32_t ) k[3] ) << 16 ); - a += k[0] + ( ( ( uint32_t ) k[1] ) << 16 ); - break; - case 7: - b += ( ( uint32_t ) k8[6] ) << 16; /* fall through */ - case 6: - b += k[2]; - a += k[0] + ( ( ( uint32_t ) k[1] ) << 16 ); - break; - case 5: - b += k8[4]; /* fall through */ - case 4: - a += k[0] + ( ( ( uint32_t ) k[1] ) << 16 ); - break; - case 3: - a += ( ( uint32_t ) k8[2] ) << 16; /* fall through */ - case 2: - a += k[0]; - break; - case 1: - a += k8[0]; - break; - case 0: - *pc = c; - *pb = b; - return; /* zero length strings require no mixing */ - } - - } else { /* need to read the key one byte at a time */ - const uint8_t *k = ( const uint8_t * ) key; - - /*--------------- all but the last block: affect some 32 bits of (a,b,c) */ - while ( length > 12 ) { - a += k[0]; - a += ( ( uint32_t ) k[1] ) << 8; - a += ( ( uint32_t ) k[2] ) << 16; - a += ( ( uint32_t ) k[3] ) << 24; - b += k[4]; - b += ( ( uint32_t ) k[5] ) << 8; - b += ( ( uint32_t ) k[6] ) << 16; - b += ( ( uint32_t ) k[7] ) << 24; - c += k[8]; - c += ( ( uint32_t ) k[9] ) << 8; - c += ( ( uint32_t ) k[10] ) << 16; - c += ( ( uint32_t ) k[11] ) << 24; - mix( a, b, c ); - length -= 12; - k += 12; - } - - /*-------------------------------- last block: affect all 32 bits of (c) */ - switch ( length ) { /* all the case statements fall through */ - case 12: - c += ( ( uint32_t ) k[11] ) << 24; - case 11: - c += ( ( uint32_t ) k[10] ) << 16; - case 10: - c += ( ( uint32_t ) k[9] ) << 8; - case 9: - c += k[8]; - case 8: - b += ( ( uint32_t ) k[7] ) << 24; - case 7: - b += ( ( uint32_t ) k[6] ) << 16; - case 6: - b += ( ( uint32_t ) k[5] ) << 8; - case 5: - b += k[4]; - case 4: - a += ( ( uint32_t ) k[3] ) << 24; - case 3: - a += ( ( uint32_t ) k[2] ) << 16; - case 2: - a += ( ( uint32_t ) k[1] ) << 8; - case 1: - a += k[0]; - break; - case 0: - *pc = c; - *pb = b; - return; /* zero length strings require no mixing */ - } - } - - final( a, b, c ); - *pc = c; - *pb = b; -} - - - -/* - * hashbig(): - * This is the same as hashword() on big-endian machines. It is different - * from hashlittle() on all machines. hashbig() takes advantage of - * big-endian byte ordering. - */ -uint32_t hashbig( const void *key, size_t length, uint32_t initval ) { - uint32_t a, b, c; - union { - const void *ptr; - size_t i; - } u; /* to cast key to (size_t) happily */ - - /* Set up the internal state */ - a = b = c = 0xdeadbeef + ( ( uint32_t ) length ) + initval; - - u.ptr = key; - if ( HASH_BIG_ENDIAN && ( ( u.i & 0x3 ) == 0 ) ) { - const uint32_t *k = ( const uint32_t * ) key; /* read 32-bit chunks */ - const uint8_t *k8; - - /*------ all but last block: aligned reads and affect 32 bits of (a,b,c) */ - while ( length > 12 ) { - a += k[0]; - b += k[1]; - c += k[2]; - mix( a, b, c ); - length -= 12; - k += 3; - } - - /*----------------------------- handle the last (probably partial) block */ - /* - * "k[2]<<8" actually reads beyond the end of the string, but - * then shifts out the part it's not allowed to read. Because the - * string is aligned, the illegal read is in the same word as the - * rest of the string. Every machine with memory protection I've seen - * does it on word boundaries, so is OK with this. But VALGRIND will - * still catch it and complain. The masking trick does make the hash - * noticably faster for short strings (like English words). - */ -#ifndef VALGRIND - - switch ( length ) { - case 12: - c += k[2]; - b += k[1]; - a += k[0]; - break; - case 11: - c += k[2] & 0xffffff00; - b += k[1]; - a += k[0]; - break; - case 10: - c += k[2] & 0xffff0000; - b += k[1]; - a += k[0]; - break; - case 9: - c += k[2] & 0xff000000; - b += k[1]; - a += k[0]; - break; - case 8: - b += k[1]; - a += k[0]; - break; - case 7: - b += k[1] & 0xffffff00; - a += k[0]; - break; - case 6: - b += k[1] & 0xffff0000; - a += k[0]; - break; - case 5: - b += k[1] & 0xff000000; - a += k[0]; - break; - case 4: - a += k[0]; - break; - case 3: - a += k[0] & 0xffffff00; - break; - case 2: - a += k[0] & 0xffff0000; - break; - case 1: - a += k[0] & 0xff000000; - break; - case 0: - return c; /* zero length strings require no mixing */ - } - -#else /* make valgrind happy */ - - k8 = ( const uint8_t * ) k; - switch ( length ) { /* all the case statements fall through */ - case 12: - c += k[2]; - b += k[1]; - a += k[0]; - break; - case 11: - c += ( ( uint32_t ) k8[10] ) << 8; /* fall through */ - case 10: - c += ( ( uint32_t ) k8[9] ) << 16; /* fall through */ - case 9: - c += ( ( uint32_t ) k8[8] ) << 24; /* fall through */ - case 8: - b += k[1]; - a += k[0]; - break; - case 7: - b += ( ( uint32_t ) k8[6] ) << 8; /* fall through */ - case 6: - b += ( ( uint32_t ) k8[5] ) << 16; /* fall through */ - case 5: - b += ( ( uint32_t ) k8[4] ) << 24; /* fall through */ - case 4: - a += k[0]; - break; - case 3: - a += ( ( uint32_t ) k8[2] ) << 8; /* fall through */ - case 2: - a += ( ( uint32_t ) k8[1] ) << 16; /* fall through */ - case 1: - a += ( ( uint32_t ) k8[0] ) << 24; - break; - case 0: - return c; - } - -#endif /* !VALGRIND */ - - } else { /* need to read the key one byte at a time */ - const uint8_t *k = ( const uint8_t * ) key; - - /*--------------- all but the last block: affect some 32 bits of (a,b,c) */ - while ( length > 12 ) { - a += ( ( uint32_t ) k[0] ) << 24; - a += ( ( uint32_t ) k[1] ) << 16; - a += ( ( uint32_t ) k[2] ) << 8; - a += ( ( uint32_t ) k[3] ); - b += ( ( uint32_t ) k[4] ) << 24; - b += ( ( uint32_t ) k[5] ) << 16; - b += ( ( uint32_t ) k[6] ) << 8; - b += ( ( uint32_t ) k[7] ); - c += ( ( uint32_t ) k[8] ) << 24; - c += ( ( uint32_t ) k[9] ) << 16; - c += ( ( uint32_t ) k[10] ) << 8; - c += ( ( uint32_t ) k[11] ); - mix( a, b, c ); - length -= 12; - k += 12; - } - - /*-------------------------------- last block: affect all 32 bits of (c) */ - switch ( length ) { /* all the case statements fall through */ - case 12: - c += k[11]; - case 11: - c += ( ( uint32_t ) k[10] ) << 8; - case 10: - c += ( ( uint32_t ) k[9] ) << 16; - case 9: - c += ( ( uint32_t ) k[8] ) << 24; - case 8: - b += k[7]; - case 7: - b += ( ( uint32_t ) k[6] ) << 8; - case 6: - b += ( ( uint32_t ) k[5] ) << 16; - case 5: - b += ( ( uint32_t ) k[4] ) << 24; - case 4: - a += k[3]; - case 3: - a += ( ( uint32_t ) k[2] ) << 8; - case 2: - a += ( ( uint32_t ) k[1] ) << 16; - case 1: - a += ( ( uint32_t ) k[0] ) << 24; - break; - case 0: - return c; - } - } - - final( a, b, c ); - return c; -} - - -#ifdef SELF_TEST - -/* used for timings */ -void driver1( ) { - uint8_t buf[256]; - uint32_t i; - uint32_t h = 0; - time_t a, z; - - time( &a ); - for ( i = 0; i < 256; ++i ) - buf[i] = 'x'; - for ( i = 0; i < 1; ++i ) { - h = hashlittle( &buf[0], 1, h ); - } - time( &z ); - if ( z - a > 0 ) - printf( "time %d %.8x\n", z - a, h ); -} - -/* check that every input bit changes every output bit half the time */ -#define HASHSTATE 1 -#define HASHLEN 1 -#define MAXPAIR 60 -#define MAXLEN 70 -void driver2( ) { - uint8_t qa[MAXLEN + 1], qb[MAXLEN + 2], *a = &qa[0], *b = &qb[1]; - uint32_t c[HASHSTATE], d[HASHSTATE], i = 0, j = 0, k, l, m = 0, z; - uint32_t e[HASHSTATE], f[HASHSTATE], g[HASHSTATE], h[HASHSTATE]; - uint32_t x[HASHSTATE], y[HASHSTATE]; - uint32_t hlen; - - printf( "No more than %d trials should ever be needed \n", MAXPAIR / 2 ); - for ( hlen = 0; hlen < MAXLEN; ++hlen ) { - z = 0; - for ( i = 0; i < hlen; ++i ) { -/*----------------------- for each input byte, */ - for ( j = 0; j < 8; ++j ) { -/*------------------------ for each input bit, */ - for ( m = 1; m < 8; ++m ) { -/*------------ for serveral possible initvals, */ - for ( l = 0; l < HASHSTATE; ++l ) - e[l] = f[l] = g[l] = h[l] = x[l] = y[l] = - ~( ( uint32_t ) 0 ); - - /*---- check that every output bit is affected by that input bit */ - for ( k = 0; k < MAXPAIR; k += 2 ) { - uint32_t finished = 1; - /* keys have one bit different */ - for ( l = 0; l < hlen + 1; ++l ) { - a[l] = b[l] = ( uint8_t ) 0; - } - /* have a and b be two keys differing in only one bit */ - a[i] ^= ( k << j ); - a[i] ^= ( k >> ( 8 - j ) ); - c[0] = hashlittle( a, hlen, m ); - b[i] ^= ( ( k + 1 ) << j ); - b[i] ^= ( ( k + 1 ) >> ( 8 - j ) ); - d[0] = hashlittle( b, hlen, m ); - /* check every bit is 1, 0, set, and not set at least once */ - for ( l = 0; l < HASHSTATE; ++l ) { - e[l] &= ( c[l] ^ d[l] ); - f[l] &= ~( c[l] ^ d[l] ); - g[l] &= c[l]; - h[l] &= ~c[l]; - x[l] &= d[l]; - y[l] &= ~d[l]; - if ( e[l] | f[l] | g[l] | h[l] | x[l] | y[l] ) - finished = 0; - } - if ( finished ) - break; - } - if ( k > z ) - z = k; - if ( k == MAXPAIR ) { - printf( "Some bit didn't change: " ); - printf( "%.8x %.8x %.8x %.8x %.8x %.8x ", - e[0], f[0], g[0], h[0], x[0], y[0] ); - printf( "i %d j %d m %d len %d\n", i, j, m, hlen ); - } - if ( z == MAXPAIR ) - goto done; - } - } - } - done: - if ( z < MAXPAIR ) { - printf( "Mix success %2d bytes %2d initvals ", i, m ); - printf( "required %d trials\n", z / 2 ); - } - } - printf( "\n" ); -} - -/* Check for reading beyond the end of the buffer and alignment problems */ -void driver3( ) { - uint8_t buf[MAXLEN + 20], *b; - uint32_t len; - uint8_t q[] = - "This is the time for all good men to come to the aid of their country..."; - uint32_t h; - uint8_t qq[] = - "xThis is the time for all good men to come to the aid of their country..."; - uint32_t i; - uint8_t qqq[] = - "xxThis is the time for all good men to come to the aid of their country..."; - uint32_t j; - uint8_t qqqq[] = - "xxxThis is the time for all good men to come to the aid of their country..."; - uint32_t ref, x, y; - uint8_t *p; - - printf - ( "Endianness. These lines should all be the same (for values filled in):\n" ); - printf - ( "%.8x %.8x %.8x\n", - hashword( ( const uint32_t * ) q, ( sizeof( q ) - 1 ) / 4, 13 ), - hashword( ( const uint32_t * ) q, ( sizeof( q ) - 5 ) / 4, 13 ), - hashword( ( const uint32_t * ) q, ( sizeof( q ) - 9 ) / 4, 13 ) ); - p = q; - printf( "%.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x\n", - hashlittle( p, sizeof( q ) - 1, 13 ), hashlittle( p, - sizeof( q ) - 2, - 13 ), - hashlittle( p, sizeof( q ) - 3, 13 ), hashlittle( p, - sizeof( q ) - 4, - 13 ), - hashlittle( p, sizeof( q ) - 5, 13 ), hashlittle( p, - sizeof( q ) - 6, - 13 ), - hashlittle( p, sizeof( q ) - 7, 13 ), hashlittle( p, - sizeof( q ) - 8, - 13 ), - hashlittle( p, sizeof( q ) - 9, 13 ), hashlittle( p, - sizeof( q ) - 10, - 13 ), - hashlittle( p, sizeof( q ) - 11, 13 ), hashlittle( p, - sizeof( q ) - - 12, 13 ) ); - p = &qq[1]; - printf( "%.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x\n", - hashlittle( p, sizeof( q ) - 1, 13 ), hashlittle( p, - sizeof( q ) - 2, - 13 ), - hashlittle( p, sizeof( q ) - 3, 13 ), hashlittle( p, - sizeof( q ) - 4, - 13 ), - hashlittle( p, sizeof( q ) - 5, 13 ), hashlittle( p, - sizeof( q ) - 6, - 13 ), - hashlittle( p, sizeof( q ) - 7, 13 ), hashlittle( p, - sizeof( q ) - 8, - 13 ), - hashlittle( p, sizeof( q ) - 9, 13 ), hashlittle( p, - sizeof( q ) - 10, - 13 ), - hashlittle( p, sizeof( q ) - 11, 13 ), hashlittle( p, - sizeof( q ) - - 12, 13 ) ); - p = &qqq[2]; - printf( "%.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x\n", - hashlittle( p, sizeof( q ) - 1, 13 ), hashlittle( p, - sizeof( q ) - 2, - 13 ), - hashlittle( p, sizeof( q ) - 3, 13 ), hashlittle( p, - sizeof( q ) - 4, - 13 ), - hashlittle( p, sizeof( q ) - 5, 13 ), hashlittle( p, - sizeof( q ) - 6, - 13 ), - hashlittle( p, sizeof( q ) - 7, 13 ), hashlittle( p, - sizeof( q ) - 8, - 13 ), - hashlittle( p, sizeof( q ) - 9, 13 ), hashlittle( p, - sizeof( q ) - 10, - 13 ), - hashlittle( p, sizeof( q ) - 11, 13 ), hashlittle( p, - sizeof( q ) - - 12, 13 ) ); - p = &qqqq[3]; - printf( "%.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x\n", - hashlittle( p, sizeof( q ) - 1, 13 ), hashlittle( p, - sizeof( q ) - 2, - 13 ), - hashlittle( p, sizeof( q ) - 3, 13 ), hashlittle( p, - sizeof( q ) - 4, - 13 ), - hashlittle( p, sizeof( q ) - 5, 13 ), hashlittle( p, - sizeof( q ) - 6, - 13 ), - hashlittle( p, sizeof( q ) - 7, 13 ), hashlittle( p, - sizeof( q ) - 8, - 13 ), - hashlittle( p, sizeof( q ) - 9, 13 ), hashlittle( p, - sizeof( q ) - 10, - 13 ), - hashlittle( p, sizeof( q ) - 11, 13 ), hashlittle( p, - sizeof( q ) - - 12, 13 ) ); - printf( "\n" ); - - /* check that hashlittle2 and hashlittle produce the same results */ - i = 47; - j = 0; - hashlittle2( q, sizeof( q ), &i, &j ); - if ( hashlittle( q, sizeof( q ), 47 ) != i ) - printf( "hashlittle2 and hashlittle mismatch\n" ); - - /* check that hashword2 and hashword produce the same results */ - len = 0xdeadbeef; - i = 47, j = 0; - hashword2( &len, 1, &i, &j ); - if ( hashword( &len, 1, 47 ) != i ) - printf( "hashword2 and hashword mismatch %x %x\n", - i, hashword( &len, 1, 47 ) ); - - /* check hashlittle doesn't read before or after the ends of the string */ - for ( h = 0, b = buf + 1; h < 8; ++h, ++b ) { - for ( i = 0; i < MAXLEN; ++i ) { - len = i; - for ( j = 0; j < i; ++j ) - *( b + j ) = 0; - - /* these should all be equal */ - ref = hashlittle( b, len, ( uint32_t ) 1 ); - *( b + i ) = ( uint8_t ) ~ 0; - *( b - 1 ) = ( uint8_t ) ~ 0; - x = hashlittle( b, len, ( uint32_t ) 1 ); - y = hashlittle( b, len, ( uint32_t ) 1 ); - if ( ( ref != x ) || ( ref != y ) ) { - printf( "alignment error: %.8x %.8x %.8x %d %d\n", ref, x, y, - h, i ); - } - } - } -} - -/* check for problems with nulls */ -void driver4( ) { - uint8_t buf[1]; - uint32_t h, i, state[HASHSTATE]; - - - buf[0] = ~0; - for ( i = 0; i < HASHSTATE; ++i ) - state[i] = 1; - printf( "These should all be different\n" ); - for ( i = 0, h = 0; i < 8; ++i ) { - h = hashlittle( buf, 0, h ); - printf( "%2ld 0-byte strings, hash is %.8x\n", i, h ); - } -} - -void driver5( ) { - uint32_t b, c; - b = 0, c = 0, hashlittle2( "", 0, &c, &b ); - printf( "hash is %.8lx %.8lx\n", c, b ); /* deadbeef deadbeef */ - b = 0xdeadbeef, c = 0, hashlittle2( "", 0, &c, &b ); - printf( "hash is %.8lx %.8lx\n", c, b ); /* bd5b7dde deadbeef */ - b = 0xdeadbeef, c = 0xdeadbeef, hashlittle2( "", 0, &c, &b ); - printf( "hash is %.8lx %.8lx\n", c, b ); /* 9c093ccd bd5b7dde */ - b = 0, c = 0, hashlittle2( "Four score and seven years ago", 30, &c, &b ); - printf( "hash is %.8lx %.8lx\n", c, b ); /* 17770551 ce7226e6 */ - b = 1, c = 0, hashlittle2( "Four score and seven years ago", 30, &c, &b ); - printf( "hash is %.8lx %.8lx\n", c, b ); /* e3607cae bd371de4 */ - b = 0, c = 1, hashlittle2( "Four score and seven years ago", 30, &c, &b ); - printf( "hash is %.8lx %.8lx\n", c, b ); /* cd628161 6cbea4b3 */ - c = hashlittle( "Four score and seven years ago", 30, 0 ); - printf( "hash is %.8lx\n", c ); /* 17770551 */ - c = hashlittle( "Four score and seven years ago", 30, 1 ); - printf( "hash is %.8lx\n", c ); /* cd628161 */ -} - - -int main( ) { - driver1( ); /* test that the key is hashed: used for timings */ - driver2( ); /* test that whole key is hashed thoroughly */ - driver3( ); /* test that nothing but the key is hashed */ - driver4( ); /* test hashing multiple buffers (all buffers are null) */ - driver5( ); /* test the hash against known vectors */ - return 1; -} - -#endif /* SELF_TEST */ diff --git a/archive/c/memory/lookup3.h b/archive/c/memory/lookup3.h deleted file mode 100644 index 6df9447..0000000 --- a/archive/c/memory/lookup3.h +++ /dev/null @@ -1,16 +0,0 @@ -/** - * lookup3.h - * - * Minimal header file wrapping Bob Jenkins' lookup3.c - * - * - * (c) 2019 Simon Brooke - * Public domain. - */ - -#ifndef __lookup3_h -#define __lookup3_h - -uint32_t hashword( const uint32_t * k, size_t length, uint32_t initval ); - -#endif diff --git a/archive/c/memory/stack.c b/archive/c/memory/stack.c deleted file mode 100644 index 9b8df3e..0000000 --- a/archive/c/memory/stack.c +++ /dev/null @@ -1,380 +0,0 @@ -/* - * 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 - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#include - -#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" <= " ); - c_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 ); - - c_print( output, frame->arg[arg] ); - url_fputws( L"\n", output ); - } - if ( !nilp( frame->more ) ) { - url_fputws( L"More: \t", output ); - c_print( output, frame->more ); - url_fputws( L"\n", output ); - } - } -} - -void dump_stack_trace( URL_FILE *output, struct cons_pointer pointer ) { - if ( exceptionp( pointer ) ) { - c_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; -} diff --git a/archive/c/memory/stack.h b/archive/c/memory/stack.h deleted file mode 100644 index 111df48..0000000 --- a/archive/c/memory/stack.h +++ /dev/null @@ -1,69 +0,0 @@ -/** - * 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 - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#ifndef __psse_stack_h -#define __psse_stack_h - -#include - -#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 diff --git a/archive/c/memory/vectorspace.c b/archive/c/memory/vectorspace.c deleted file mode 100644 index 26a23d9..0000000 --- a/archive/c/memory/vectorspace.c +++ /dev/null @@ -1,158 +0,0 @@ -/* - * vectorspace.c - * - * Structures common to all vector space objects. - * - * - * (c) 2017 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#include -#include -#include -#include -#include - - -/* - * wide characters - */ -#include -#include - -#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; -// } diff --git a/archive/c/memory/vectorspace.h b/archive/c/memory/vectorspace.h deleted file mode 100644 index 3265225..0000000 --- a/archive/c/memory/vectorspace.h +++ /dev/null @@ -1,121 +0,0 @@ -/** - * vectorspace.h - * - * Declarations common to all vector space objects. - * - * - * (c) 2017 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#include -#include -#include -/* - * wide characters - */ -#include -#include - -#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 diff --git a/archive/c/ops/equal.c b/archive/c/ops/equal.c deleted file mode 100644 index 77e07c4..0000000 --- a/archive/c/ops/equal.c +++ /dev/null @@ -1,433 +0,0 @@ -/* - * equal.c - * - * Checks for shallow and deep equality - * - * (c) 2017 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#include -#include -#include - -#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 ( !c_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 c_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 = - c_equal( cell_a->payload.cons.car, cell_b->payload.cons.car ) - && c_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 ) { - char32_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 ) - && c_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; -} diff --git a/archive/c/ops/equal.h b/archive/c/ops/equal.h deleted file mode 100644 index a3ae93a..0000000 --- a/archive/c/ops/equal.h +++ /dev/null @@ -1,36 +0,0 @@ -/** - * equal.h - * - * Checks for shallow and deep equality - * - * (c) 2017 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#include -#include - -#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 c_equal( struct cons_pointer a, struct cons_pointer b ); - -#endif diff --git a/archive/c/ops/intern.c b/archive/c/ops/intern.c deleted file mode 100644 index f16733d..0000000 --- a/archive/c/ops/intern.c +++ /dev/null @@ -1,574 +0,0 @@ -/* - * 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 - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#include -#include -/* - * wide characters - */ -#include -#include - -#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 ( c_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 ( c_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; -} diff --git a/archive/c/ops/intern.h b/archive/c/ops/intern.h deleted file mode 100644 index 0b8f657..0000000 --- a/archive/c/ops/intern.h +++ /dev/null @@ -1,81 +0,0 @@ -/* - * 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 - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#ifndef __intern_h -#define __intern_h - -#include - - -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 diff --git a/archive/c/ops/lispops.c b/archive/c/ops/lispops.c deleted file mode 100644 index 3b0d5c1..0000000 --- a/archive/c/ops/lispops.c +++ /dev/null @@ -1,1840 +0,0 @@ -/* - * lispops.c - * - * 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 - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#include -#include -#include -#include -#include - -#include "arith/integer.h" -#include "arith/peano.h" -#include "debug.h" -#include "io/io.h" -#include "io/print.h" -#include "io/read.h" -#include "memory/conspage.h" -#include "memory/consspaceobject.h" -#include "memory/stack.h" -#include "memory/vectorspace.h" -#include "memory/dump.h" -#include "ops/equal.h" -#include "ops/intern.h" -#include "ops/lispops.h" - -/** - * @brief the name of the symbol to which the prompt is bound; - * - * Set in init to `*prompt*` - */ -struct cons_pointer prompt_name; - -/* - * also to create in this section: - * struct cons_pointer lisp_let( struct cons_pointer args, struct cons_pointer env, - * struct stack_frame* frame); - * - * and others I haven't thought of yet. - */ - -/** - * 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 ) { - debug_print( L"eval_form: ", DEBUG_EVAL ); - debug_print_object( form, DEBUG_EVAL ); - debug_println( DEBUG_EVAL ); - - struct cons_pointer result = form; - switch ( pointer2cell( form ).tag.value ) { - /* things which evaluate to themselves */ - case EXCEPTIONTV: - case FREETV: // shouldn't happen, but anyway... - case INTEGERTV: - case KEYTV: - case LOOPTV: // don't think this should happen... - case NILTV: - case RATIOTV: - case REALTV: - case READTV: - case STRINGTV: - case TIMETV: - case TRUETV: - case WRITETV: - break; - default: - { - struct cons_pointer next_pointer = - make_empty_frame( parent_pointer ); - - if ( exceptionp( next_pointer ) ) { - result = next_pointer; - } else { - struct stack_frame *next = get_stack_frame( next_pointer ); - set_reg( next, 0, form ); - next->args = 1; - - result = lisp_eval( next, next_pointer, env ); - - if ( !exceptionp( result ) ) { - /* if we're returning an exception, we should NOT free the - * stack frame. Corollary is, when we free an exception, we - * should free all the frames it's holding on to. */ - dec_ref( next_pointer ); - } - } - } - break; - } - - debug_print( L"eval_form ", DEBUG_EVAL ); - debug_print_object( form, DEBUG_EVAL ); - debug_print( L" returning: ", DEBUG_EVAL ); - debug_print_object( result, DEBUG_EVAL ); - debug_println( DEBUG_EVAL ); - - return result; -} - -/** - * Evaluate 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. - * @param frame the stack frame. - * @param list the list of forms to be evaluated. - * @param env the evaluation environment. - * @return a list of the the results of evaluating the forms. - */ -struct cons_pointer eval_forms( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer list, - struct cons_pointer env ) { - struct cons_pointer result = NIL; - - while ( consp( list ) ) { - result = - make_cons( eval_form( frame, frame_pointer, c_car( list ), env ), - result ); - list = c_cdr( list ); - } - - return c_reverse( result ); -} - -/** - * OK, the idea here (and I know this is less than perfect) is that the basic `try` - * special form in PSSE takes two arguments, the first, `body`, being a list of forms, - * and the second, `catch`, being a catch handler (which is also a list of forms). - * Forms from `body` are evaluated in turn until one returns an exception object, - * or until the list is exhausted. If the list was exhausted, then the value of - * evaluating the last form in `body` is returned. If an exception was encountered, - * then each of the forms in `catch` is evaluated and the value of the last of - * those is returned. - * - * This is experimental. It almost certainly WILL change. - */ -struct cons_pointer lisp_try( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ) { - struct cons_pointer result = - c_progn( frame, frame_pointer, frame->arg[0], env ); - - if ( exceptionp( result ) ) { - // TODO: need to put the exception into the environment! - result = c_progn( frame, frame_pointer, frame->arg[1], - make_cons( make_cons - ( c_string_to_lisp_symbol - ( L"*exception*" ), result ), env ) ); - } - - return result; -} - - -/** - * Return the object list (root namespace). - * - * * (oblist) - * - * @param frame the stack frame in which the expression is to be interpreted; - * @param frame_pointer a pointer to my stack_frame. - * @param env my environment (ignored). - * @return the root namespace. - */ -struct cons_pointer -lisp_oblist( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ) { - return oblist; -} - -/** - * Used to construct the body for `lambda` and `nlambda` expressions. - */ -struct cons_pointer compose_body( struct stack_frame *frame ) { - struct cons_pointer body = frame->more; - - for ( int i = args_in_frame - 1; i > 0; i-- ) { - if ( !nilp( body ) ) { - body = make_cons( frame->arg[i], body ); - } else if ( !nilp( frame->arg[i] ) ) { - body = make_cons( frame->arg[i], body ); - } - } - - debug_print( L"compose_body returning ", DEBUG_LAMBDA ); - debug_dump_object( body, DEBUG_LAMBDA ); - - return body; -} - -/** - * Construct an interpretable function. *NOTE* that if `args` is a single symbol - * rather than a list, a varargs function will be created. - * - * (lambda args body) - * - * @param frame the stack frame in which the expression is to be interpreted; - * @param frame_pointer a pointer to my stack_frame. - * @param env the environment in which it is to be intepreted. - * @return an interpretable function with these `args` and this `body`. - */ -struct cons_pointer -lisp_lambda( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ) { - return make_lambda( frame->arg[0], compose_body( frame ) ); -} - -/** - * Construct an interpretable special form. *NOTE* that if `args` is a single symbol - * rather than a list, a varargs special form will be created. - * - * (nlambda args body) - * - * @param frame the stack frame in which the expression is to be interpreted; - * @param frame_pointer a pointer to my stack_frame. - * @param env the environment in which it is to be intepreted. - * @return an interpretable special form with these `args` and this `body`. - */ -struct cons_pointer -lisp_nlambda( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ) { - return make_nlambda( frame->arg[0], compose_body( frame ) ); -} - - -/** - * Evaluate a lambda or nlambda expression. - */ -struct cons_pointer -eval_lambda( struct cons_space_object *cell, struct stack_frame *frame, - struct cons_pointer frame_pointer, struct cons_pointer env ) { - struct cons_pointer result = NIL; -#ifdef DEBUG - debug_print( L"eval_lambda called\n", DEBUG_LAMBDA ); - debug_println( DEBUG_LAMBDA ); -#endif - - struct cons_pointer new_env = env; - struct cons_pointer names = cell->payload.lambda.args; - struct cons_pointer body = cell->payload.lambda.body; - - if ( consp( names ) ) { - /* if `names` is a list, bind successive items from that list - * to values of arguments */ - for ( int i = 0; i < frame->args && consp( names ); i++ ) { - struct cons_pointer name = c_car( names ); - struct cons_pointer val = frame->arg[i]; - - new_env = set( name, val, new_env ); - debug_print_binding( name, val, false, DEBUG_BIND ); - - names = c_cdr( names ); - } - - /* \todo if there's more than `args_in_frame` arguments, bind those too. */ - } else if ( symbolp( names ) ) { - /* if `names` is a symbol, rather than a list of symbols, - * then bind a list of the values of args to that symbol. */ - /* \todo eval all the things in frame->more */ - struct cons_pointer vals = - eval_forms( frame, frame_pointer, frame->more, env ); - - for ( int i = args_in_frame - 1; i >= 0; i-- ) { - struct cons_pointer val = - eval_form( frame, frame_pointer, frame->arg[i], env ); - - if ( nilp( val ) && nilp( vals ) ) { /* nothing */ - } else { - vals = make_cons( val, vals ); - } - } - - new_env = set( names, vals, new_env ); - } - - while ( !nilp( body ) ) { - struct cons_pointer sexpr = c_car( body ); - body = c_cdr( body ); - - debug_print( L"In lambda: evaluating ", DEBUG_LAMBDA ); - debug_print_object( sexpr, DEBUG_LAMBDA ); - // debug_print( L"\t env is: ", DEBUG_LAMBDA ); - // debug_print_object( new_env, DEBUG_LAMBDA ); - debug_println( DEBUG_LAMBDA ); - - /* if a result is not the terminal result in the lambda, it's a - * side effect, and needs to be GCed */ - dec_ref( result ); - - result = eval_form( frame, frame_pointer, sexpr, new_env ); - - if ( exceptionp( result ) ) { - break; - } - } - - // TODO: I think we do need to dec_ref everything on new_env back to env - // dec_ref( new_env ); - - debug_print( L"eval_lambda returning: \n", DEBUG_LAMBDA ); - debug_print_object( result, DEBUG_LAMBDA ); - debug_println( DEBUG_LAMBDA ); - - return result; -} - -/** - * if `r` is an exception, and it doesn't have a location, fix up its location from - * the name associated with this fn_pointer, if any. - */ -struct cons_pointer maybe_fixup_exception_location( struct cons_pointer r, - struct cons_pointer - fn_pointer ) { - struct cons_pointer result = r; - - if ( exceptionp( result ) - && ( functionp( fn_pointer ) || specialp( fn_pointer ) ) ) { - struct cons_space_object *fn_cell = &pointer2cell( fn_pointer ); - - struct cons_pointer payload = - pointer2cell( result ).payload.exception.payload; - - switch ( get_tag_value( payload ) ) { - case NILTV: - case CONSTV: - case HASHTV: - { - if ( nilp( c_assoc( privileged_keyword_location, - payload ) ) ) { - pointer2cell( result ).payload.exception.payload = - set( privileged_keyword_location, - c_assoc( privileged_keyword_name, - fn_cell->payload.function.meta ), - payload ); - } - } - break; - default: - pointer2cell( result ).payload.exception.payload = - make_cons( make_cons( privileged_keyword_location, - c_assoc( privileged_keyword_name, - fn_cell->payload.function. - meta ) ), - make_cons( make_cons - ( privileged_keyword_payload, - payload ), NIL ) ); - } - } - - return result; -} - - -/** - * Internal guts of apply. - * @param frame the stack frame, expected to have only one argument, a list - * comprising something that evaluates to a function and its arguments. - * @param env The evaluation environment. - * @return the result of evaluating the function with its arguments. - */ -struct cons_pointer -c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ) { - debug_print( L"Entering c_apply\n", DEBUG_EVAL ); - struct cons_pointer result = NIL; - - struct cons_pointer fn_pointer = - eval_form( frame, frame_pointer, c_car( frame->arg[0] ), env ); - - if ( exceptionp( fn_pointer ) ) { - result = fn_pointer; - } else { - struct cons_space_object *fn_cell = &pointer2cell( fn_pointer ); - struct cons_pointer args = c_cdr( frame->arg[0] ); - - switch ( get_tag_value( fn_pointer ) ) { - case EXCEPTIONTV: - /* just pass exceptions straight back */ - result = fn_pointer; - break; - - case FUNCTIONTV: - { - struct cons_pointer exep = NIL; - struct cons_pointer next_pointer = - make_stack_frame( frame_pointer, args, env ); - - if ( exceptionp( next_pointer ) ) { - result = next_pointer; - } else { - struct stack_frame *next = - get_stack_frame( next_pointer ); - - result = maybe_fixup_exception_location( ( * - ( fn_cell->payload.function.executable ) ) - ( next, - next_pointer, - env ), - fn_pointer ); - dec_ref( next_pointer ); - } - } - break; - - case KEYTV: - result = c_assoc( fn_pointer, - eval_form( frame, - frame_pointer, - c_car( c_cdr( frame->arg[0] ) ), - env ) ); - break; - - case LAMBDATV: - { - struct cons_pointer exep = NIL; - struct cons_pointer next_pointer = - make_stack_frame( frame_pointer, args, env ); - - if ( exceptionp( next_pointer ) ) { - result = next_pointer; - } else { - struct stack_frame *next = - get_stack_frame( next_pointer ); - result = - eval_lambda( fn_cell, next, next_pointer, env ); - if ( !exceptionp( result ) ) { - dec_ref( next_pointer ); - } - } - } - break; - - case HASHTV: - /* \todo: if arg[0] is a CONS, treat it as a path */ - result = c_assoc( eval_form( frame, - frame_pointer, - c_car( c_cdr - ( frame->arg - [0] ) ), env ), - fn_pointer ); - break; - - case NLAMBDATV: - { - struct cons_pointer next_pointer = - make_special_frame( frame_pointer, args, env ); - - if ( exceptionp( next_pointer ) ) { - result = next_pointer; - } else { - struct stack_frame *next = - get_stack_frame( next_pointer ); - result = - eval_lambda( fn_cell, next, next_pointer, env ); - dec_ref( next_pointer ); - } - } - break; - - case SPECIALTV: - { - struct cons_pointer next_pointer = - make_special_frame( frame_pointer, args, env ); - - if ( exceptionp( next_pointer ) ) { - result = next_pointer; - } else { - result = maybe_fixup_exception_location( ( * - ( fn_cell->payload.special.executable ) ) - ( get_stack_frame( next_pointer ), next_pointer, env ), fn_pointer ); - debug_print( L"Special form returning: ", DEBUG_EVAL ); - debug_print_object( result, DEBUG_EVAL ); - debug_println( DEBUG_EVAL ); - dec_ref( next_pointer ); - } - } - break; - - default: - { - int bs = sizeof( char32_t ) * 1024; - char32_t *buffer = malloc( bs ); - memset( buffer, '\0', bs ); - swprintf( buffer, bs, - L"Unexpected cell with tag %d (%4.4s) in function position", - fn_cell->tag.value, &( fn_cell->tag.bytes[0] ) ); - struct cons_pointer message = - c_string_to_lisp_string( buffer ); - free( buffer ); - result = - throw_exception( c_string_to_lisp_symbol( L"apply" ), - message, frame_pointer ); - } - } - - } - - debug_print( L"c_apply: returning: ", DEBUG_EVAL ); - debug_print_object( result, DEBUG_EVAL ); - debug_println( DEBUG_EVAL ); - - return result; -} - -/** - * Function; evaluate the expression which is the first argument in the frame; - * further arguments are ignored. - * - * * (eval expression) - * - * @param frame my stack_frame. - * @param frame_pointer a pointer to my stack_frame. - * @param env my environment. - * @return - * * If `expression` is a number, string, `nil`, or `t`, returns `expression`. - * * If `expression` is a symbol, returns the value that expression is bound - * to in the evaluation environment (`env`). - * * If `expression` is a list, expects the car to be something that evaluates to a - * function or special form: - * * If a function, evaluates all the other top level elements in `expression` and - * passes them in a stack frame as arguments to the function; - * * If a special form, passes the cdr of expression to the special form as argument. - * @exception if `expression` is a symbol which is not bound in `env`. - */ -struct cons_pointer -lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ) { - debug_print( L"Eval: ", DEBUG_EVAL ); - debug_dump_object( frame_pointer, DEBUG_EVAL ); - - struct cons_pointer result = frame->arg[0]; - struct cons_space_object *cell = &pointer2cell( frame->arg[0] ); - - switch ( cell->tag.value ) { - case CONSTV: - result = c_apply( frame, frame_pointer, env ); - break; - - case SYMBOLTV: - { - struct cons_pointer canonical = interned( frame->arg[0], env ); - if ( nilp( canonical ) ) { - struct cons_pointer message = - make_cons( c_string_to_lisp_string - ( L"Attempt to take value of unbound symbol." ), - frame->arg[0] ); - result = - throw_exception( c_string_to_lisp_symbol( L"eval" ), - message, frame_pointer ); - } else { - result = c_assoc( canonical, env ); -// inc_ref( result ); - } - } - break; - /* - * \todo - * the Clojure practice of having a map serve in the function place of - * an s-expression is a good one and I should adopt it; - * H'mmm... this is working, but it isn't here. Where is it? - */ - default: - result = frame->arg[0]; - break; - } - - debug_print( L"Eval returning ", DEBUG_EVAL ); - debug_dump_object( result, DEBUG_EVAL ); - - return result; -} - - -/** - * Function; apply the function which is the result of evaluating the - * first argument to the list of values which is the result of evaluating - * the second argument - * - * * (apply fn args) - * - * @param frame my stack_frame. - * @param frame_pointer a pointer to my stack_frame. - * @param env my environment. - * @return the result of applying `fn` to `args`. - */ -struct cons_pointer -lisp_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ) { - debug_print( L"Apply: ", DEBUG_EVAL ); - debug_dump_object( frame_pointer, DEBUG_EVAL ); - - set_reg( frame, 0, make_cons( frame->arg[0], frame->arg[1] ) ); - set_reg( frame, 1, NIL ); - - struct cons_pointer result = c_apply( frame, frame_pointer, env ); - - debug_print( L"Apply returning ", DEBUG_EVAL ); - debug_dump_object( result, DEBUG_EVAL ); - - return result; -} - - -/** - * Special form; - * returns its argument (strictly first argument - only one is expected but - * this isn't at this stage checked) unevaluated. - * - * * (quote a) - * - * @param frame my stack_frame. - * @param frame_pointer a pointer to my stack_frame. - * @param env my environment (ignored). - * @return `a`, unevaluated, - */ -struct cons_pointer -lisp_quote( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ) { - return frame->arg[0]; -} - - -/** - * Function; - * binds the value of `name` in the `namespace` to value of `value`, altering - * the namespace in so doing. Retuns `value`. - * `namespace` defaults to the oblist. - * \todo doesn't actually work yet for namespaces which are not the oblist. - * - * * (set name value) - * * (set name value namespace) - * - * @param frame my stack_frame. - * @param frame_pointer a pointer to my stack_frame. - * @param env my environment (ignored). - * @return `value` - */ -struct cons_pointer -lisp_set( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ) { - struct cons_pointer result = NIL; - struct cons_pointer namespace = - nilp( frame->arg[2] ) ? oblist : frame->arg[2]; - - if ( symbolp( frame->arg[0] ) ) { - deep_bind( frame->arg[0], frame->arg[1] ); - result = frame->arg[1]; - } else { - result = - throw_exception( c_string_to_lisp_symbol( L"set" ), - make_cons - ( c_string_to_lisp_string - ( L"The first argument to `set` is not a symbol: " ), - make_cons( frame->arg[0], NIL ) ), - frame_pointer ); - } - - return result; -} - - -/** - * Special form; - * binds `symbol` in the `namespace` to value of `value`, altering - * the namespace in so doing, and returns value. `namespace` defaults to - * the value of `oblist`. - * \todo doesn't actually work yet for namespaces which are not the oblist. - * - * * (set! symbol value) - * * (set! symbol value namespace) - * - * @param frame my stack_frame. - * @param frame_pointer a pointer to my stack_frame. - * @param env my environment (ignored). - * @return `value` - */ -struct cons_pointer -lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ) { - struct cons_pointer result = NIL; - struct cons_pointer namespace = frame->arg[2]; - - if ( symbolp( frame->arg[0] ) ) { - struct cons_pointer val = - eval_form( frame, frame_pointer, frame->arg[1], env ); - deep_bind( frame->arg[0], val ); - result = val; - } else { - result = - throw_exception( c_string_to_lisp_symbol( L"set!" ), - make_cons - ( c_string_to_lisp_string - ( L"The first argument to `set!` is not a symbol: " ), - make_cons( frame->arg[0], NIL ) ), - frame_pointer ); - } - - return result; -} - -/** - * @return true if `arg` represents an end of string, else false. - * \todo candidate for moving to a memory/string.c file - */ -bool end_of_stringp( struct cons_pointer arg ) { - return nilp( arg ) || - ( stringp( arg ) && - pointer2cell( arg ).payload.string.character == ( wint_t ) '\0' ); -} - -/** - * Function; - * returns a cell constructed from a and b. If a is of type string but its - * cdr is nill, and b is of type string, then returns a new string cell; - * otherwise returns a new cons cell. - * - * Thus: `(cons "a" "bcd") -> "abcd"`, but `(cons "ab" "cd") -> ("ab" . "cd")` - * - * * (cons a b) - * - * @param frame my stack_frame. - * @param frame_pointer a pointer to my stack_frame. - * @param env my environment (ignored). - * @return a new cons cell whose `car` is `a` and whose `cdr` is `b`. - */ -struct cons_pointer -lisp_cons( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ) { - struct cons_pointer car = frame->arg[0]; - struct cons_pointer cdr = frame->arg[1]; - struct cons_pointer result; - - if ( nilp( car ) && nilp( cdr ) ) { - return NIL; - } else if ( stringp( car ) && stringp( cdr ) && - end_of_stringp( c_cdr( car ) ) ) { - result = - make_string( pointer2cell( car ).payload.string.character, cdr ); - } else { - result = make_cons( car, cdr ); - } - - return result; -} - -/** - * Function; - * returns the first item (head) of a sequence. Valid for cons cells, - * strings, read streams and TODO other things which can be considered as sequences. - * - * * (car expression) - * - * @param frame my stack_frame. - * @param frame_pointer a pointer to my stack_frame. - * @param env my environment (ignored). - * @return the first item (head) of `expression`. - * @exception if `expression` is not a sequence. - */ -struct cons_pointer -lisp_car( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ) { - struct cons_pointer result = NIL; - struct cons_space_object *cell = &pointer2cell( frame->arg[0] ); - - switch ( cell->tag.value ) { - case CONSTV: - result = cell->payload.cons.car; - break; - case NILTV: - break; - case READTV: - result = - make_string( url_fgetwc( cell->payload.stream.stream ), NIL ); - break; - case STRINGTV: - result = make_string( cell->payload.string.character, NIL ); - break; - default: - result = - throw_exception( c_string_to_lisp_symbol( L"car" ), - c_string_to_lisp_string - ( L"Attempt to take CAR of non sequence" ), - frame_pointer ); - } - - return result; -} - -/** - * Function; - * returns the remainder of a sequence when the head is removed. Valid for cons cells, - * strings, read streams and TODO other things which can be considered as sequences. - * *NOTE* that if the argument is an input stream, the first character is removed AND - * DISCARDED. - * - * * (cdr expression) - * - * @param frame my stack_frame. - * @param frame_pointer a pointer to my stack_frame. - * @param env my environment (ignored). - * @return the remainder of `expression` when the head is removed. - * @exception if `expression` is not a sequence. - */ -struct cons_pointer -lisp_cdr( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ) { - struct cons_pointer result = NIL; - struct cons_space_object *cell = &pointer2cell( frame->arg[0] ); - - switch ( cell->tag.value ) { - case CONSTV: - result = cell->payload.cons.cdr; - break; - case NILTV: - break; - case READTV: - url_fgetwc( cell->payload.stream.stream ); - result = frame->arg[0]; - break; - case STRINGTV: - result = cell->payload.string.cdr; - break; - default: - result = - throw_exception( c_string_to_lisp_symbol( L"cdr" ), - c_string_to_lisp_string - ( L"Attempt to take CDR of non sequence" ), - frame_pointer ); - } - - return result; -} - -/** - * Function: return, as an integer, the length of the sequence indicated by - * the first argument, or zero if it is not a sequence. - * - * * (length any) - * - * @param frame my stack_frame. - * @param frame_pointer a pointer to my stack_frame. - * @param env my environment (ignored). - * @return the length of `any`, if it is a sequence, or zero otherwise. - */ -struct cons_pointer lisp_length( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ) { - return make_integer( c_length( frame->arg[0] ), NIL ); -} - -/** - * Function; look up the value of a `key` in a `store`. - * - * * (assoc key store) - * - * @param frame my stack_frame. - * @param frame_pointer a pointer to my stack_frame. - * @param env my environment (ignored). - * @return the value associated with `key` in `store`, or `nil` if not found. - */ -struct cons_pointer -lisp_assoc( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ) { - return c_assoc( frame->arg[0], - nilp( frame->arg[1] ) ? oblist : frame->arg[1] ); -} - -/** - * @brief `(interned? key store)`: Return `t` if the symbol or keyword `key` is bound in this `store`, else `nil`. - * - * @param frame - * @param frame_pointer - * @param env - * @return struct cons_pointer - */ -struct cons_pointer -lisp_internedp( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ) { - struct cons_pointer result = internedp( frame->arg[0], - nilp( frame->arg[1] ) ? oblist : - frame->arg[1] ); - - if ( exceptionp( result ) ) { - struct cons_pointer old = result; - struct cons_space_object *cell = &( pointer2cell( result ) ); - result = - throw_exception( c_string_to_lisp_symbol( L"interned?" ), - cell->payload.exception.payload, frame_pointer ); - dec_ref( old ); - } - - return result; -} - -struct cons_pointer c_keys( struct cons_pointer store ) { - struct cons_pointer result = NIL; - - if ( consp( store ) ) { - for ( struct cons_pointer pair = c_car( store ); !nilp( pair ); - pair = c_car( store ) ) { - if ( consp( pair ) ) { - result = make_cons( c_car( pair ), result ); - } else if ( hashmapp( pair ) ) { - result = c_append( hashmap_keys( pair ), result ); - } - - store = c_cdr( store ); - } - } else if ( hashmapp( store ) ) { - result = hashmap_keys( store ); - } - - return result; -} - - - -struct cons_pointer lisp_keys( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ) { - return c_keys( frame->arg[0] ); -} - -/** - * Function; are these two objects the same object? Shallow, cheap equality. - * - * * (eq a b) - * - * @param frame my stack_frame. - * @param frame_pointer a pointer to my stack_frame. - * @param env my environment (ignored). - * @return `t` if `a` and `b` are pointers to the same object, else `nil`; - */ -struct cons_pointer lisp_eq( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ) { - struct cons_pointer result = TRUE; - - if ( frame->args > 1 ) { - for ( int b = 1; ( truep( result ) ) && ( b < frame->args ); b++ ) { - result = eq( frame->arg[0], fetch_arg( frame, b ) ) ? TRUE : NIL; - } - } - - return result; -} - -/** - * Function; are these two arguments identical? Deep, expensive equality. - * - * * (equal a b) - * - * @param frame my stack_frame. - * @param frame_pointer a pointer to my stack_frame. - * @param env my environment (ignored). - * @return `t` if `a` and `b` are recursively identical, else `nil`. - */ -struct cons_pointer -lisp_equal( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ) { - struct cons_pointer result = TRUE; - - if ( frame->args > 1 ) { - for ( int b = 1; ( truep( result ) ) && ( b < frame->args ); b++ ) { - result = - c_equal( frame->arg[0], fetch_arg( frame, b ) ) ? TRUE : NIL; - } - } - - return result; -} - -long int c_count( struct cons_pointer p ) { - struct cons_space_object *cell = &pointer2cell( p ); - int result = 0; - - switch ( cell->tag.value ) { - case CONSTV: - case STRINGTV: - /* I think doctrine is that you cannot treat symbols or keywords as - * sequences, although internally, of course, they are. Integers are - * also internally sequences, but also should not be treated as such. - */ - for ( p; !nilp( p ); p = c_cdr( p ) ) { - result++; - } - } - - return result; -} - -/** - * Function: return the number of top level forms in the object which is - * the first (and only) argument, if it is a sequence (which for current - * purposes means a list or a string) - * - * * (count l) - * - * @param frame my stack_frame. - * @param frame_pointer a pointer to my stack_frame. - * @param env my environment (ignored). - * @return the number of top level forms in a list, or characters in a - * string, else 0. - */ -struct cons_pointer -lisp_count( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ) { - return acquire_integer( c_count( frame->arg[0] ), NIL ); -} - -/** - * Function; read one complete lisp form and return it. If read-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. - * - * * (read) - * * (read read-stream) - * - * @param frame my stack_frame. - * @param frame_pointer a pointer to my stack_frame. - * @param env my environment. - * @return the expression read. - */ -struct cons_pointer -lisp_read( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ) { -#ifdef DEBUG - debug_print( L"entering lisp_read\n", DEBUG_IO ); -#endif - URL_FILE *input; - - struct cons_pointer in_stream = readp( frame->arg[0] ) ? - frame->arg[0] : get_default_stream( true, env ); - - if ( readp( in_stream ) ) { - debug_print( L"lisp_read: setting input stream\n", - DEBUG_IO | DEBUG_REPL ); - debug_dump_object( in_stream, DEBUG_IO ); - input = pointer2cell( in_stream ).payload.stream.stream; - inc_ref( in_stream ); - } else { - /* should not happen, but has done. */ - debug_print( L"WARNING: invalid input stream; defaulting!\n", - DEBUG_IO | DEBUG_REPL ); - input = file_to_url_file( stdin ); - } - - struct cons_pointer result = read( frame, frame_pointer, env, input ); - debug_print( L"lisp_read returning\n", DEBUG_IO ); - debug_dump_object( result, DEBUG_IO ); - - if ( readp( in_stream ) ) { - dec_ref( in_stream ); - } else { - free( input ); - } - - - return result; -} - - -/** - * reverse a sequence (if it is a sequence); else return it unchanged. - */ -struct cons_pointer c_reverse( struct cons_pointer arg ) { - struct cons_pointer result = NIL; - - if ( sequencep( arg ) ) { - for ( struct cons_pointer p = arg; sequencep( p ); p = c_cdr( p ) ) { - struct cons_space_object o = pointer2cell( p ); - switch ( o.tag.value ) { - case CONSTV: - result = make_cons( o.payload.cons.car, result ); - break; - case STRINGTV: - result = make_string( o.payload.string.character, result ); - break; - case SYMBOLTV: - result = - make_symbol_or_key( o.payload.string.character, result, - SYMBOLTV ); - break; - } - } - } else { - result = arg; - } - - return result; -} - - -/** - * Function; reverse the order of members in s sequence. - * - * * (reverse sequence) - * - * @param frame my stack_frame. - * @param frame_pointer a pointer to my stack_frame. - * @param env my environment (ignored). - * @return a sequence like this `sequence` but with the members in the reverse order. - */ -struct cons_pointer lisp_reverse( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ) { - return c_reverse( frame->arg[0] ); -} - -/** - * Function: dump/inspect 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. - * - * * (inspect expr) - * * (inspect 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_inspect( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ) { - debug_print( L"Entering lisp_inspect\n", DEBUG_IO ); - struct cons_pointer result = NIL; - struct cons_pointer out_stream = writep( frame->arg[1] ) - ? frame->arg[1] - : get_default_stream( false, env ); - URL_FILE *output; - - if ( writep( out_stream ) ) { - debug_print( L"lisp_inspect: setting output stream\n", DEBUG_IO ); - debug_dump_object( out_stream, DEBUG_IO ); - output = pointer2cell( out_stream ).payload.stream.stream; - } else { - output = file_to_url_file( stderr ); - } - - dump_object( output, frame->arg[0] ); - - debug_print( L"Leaving lisp_inspect", DEBUG_IO ); - - return result; -} - - -/** - * Function: get the Lisp type of the single argument. - * - * * (type expression) - * - * @param frame my stack frame. - * @param frame_pointer a pointer to my stack_frame. - * @param env my environment (ignored). - * @return As a Lisp string, the tag of `expression`. - */ -struct cons_pointer -lisp_type( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ) { - return c_type( frame->arg[0] ); -} - -/** - * Evaluate each of these expressions in this `env`ironment over this `frame`, - * returning only the value of the last. - */ -struct cons_pointer -c_progn( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer expressions, struct cons_pointer env ) { - struct cons_pointer result = NIL; - - while ( consp( expressions ) ) { - struct cons_pointer r = result; - - result = eval_form( frame, frame_pointer, c_car( expressions ), env ); - dec_ref( r ); - - expressions = exceptionp( result ) ? NIL : c_cdr( expressions ); - } - - return result; -} - - -/** - * Special form; evaluate the expressions which are listed in my arguments - * sequentially and return the value of the last. This function is called 'do' - * in some dialects of Lisp. - * - * * (progn expressions...) - * - * @param frame my stack frame. - * @param frame_pointer a pointer to my stack_frame. - * @param env the environment in which expressions are evaluated. - * @return the value of the last `expression` of 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 ) { - struct cons_pointer result = NIL; - - for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] ); i++ ) { - struct cons_pointer r = result; - - result = eval_form( frame, frame_pointer, frame->arg[i], env ); - - dec_ref( r ); - } - - if ( consp( frame->more ) ) { - result = c_progn( frame, frame_pointer, frame->more, env ); - } - - return result; -} - -/** - * @brief evaluate a single cond clause; if the test part succeeds return a - * pair whose car is TRUE and whose cdr is the value of the action part - */ -struct cons_pointer eval_cond_clause( struct cons_pointer clause, - struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ) { - struct cons_pointer result = NIL; - -#ifdef DEBUG - debug_print( L"\n\tCond clause: ", DEBUG_EVAL ); - debug_print_object( clause, DEBUG_EVAL ); - debug_println( DEBUG_EVAL ); -#endif - - if ( consp( clause ) ) { - struct cons_pointer val = - eval_form( frame, frame_pointer, c_car( clause ), - env ); - - if ( !nilp( val ) ) { - result = - make_cons( TRUE, - c_progn( frame, frame_pointer, c_cdr( clause ), - env ) ); - -#ifdef DEBUG - debug_print( L"\n\t\tCond clause ", DEBUG_EVAL ); - debug_print_object( clause, DEBUG_EVAL ); - debug_print( L" succeeded; returning: ", DEBUG_EVAL ); - debug_print_object( result, DEBUG_EVAL ); - debug_println( DEBUG_EVAL ); - } else { - debug_print( L"\n\t\tCond clause ", DEBUG_EVAL ); - debug_print_object( clause, DEBUG_EVAL ); - debug_print( L" failed.\n", DEBUG_EVAL ); -#endif - } - } else { - result = throw_exception( c_string_to_lisp_symbol( L"cond" ), - c_string_to_lisp_string - ( L"Arguments to `cond` must be lists" ), - frame_pointer ); - } - - return result; -} - -/** - * Special form: conditional. Each `clause` 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. - * - * * (cond clauses...) - * - * @param frame my stack frame. - * @param frame_pointer a pointer to my stack_frame. - * @param env the environment in which arguments will be evaluated. - * @return the value of the last expression 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 result = NIL; - bool done = false; - - for ( int i = 0; ( i < frame->args ) && !done; i++ ) { - struct cons_pointer clause_pointer = fetch_arg( frame, i ); - - result = eval_cond_clause( clause_pointer, frame, frame_pointer, env ); - - if ( !nilp( result ) && truep( c_car( result ) ) ) { - result = c_cdr( result ); - done = true; - break; - } - } -#ifdef DEBUG - debug_print( L"\tCond returning: ", DEBUG_EVAL ); - debug_print_object( result, DEBUG_EVAL ); - debug_println( DEBUG_EVAL ); -#endif - - return result; -} - -/** - * Throw an exception with a cause. - * `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. - * object pointing to it. Then this should become a normal lisp function - * which expects a normally bound frame and environment, such that - * frame->arg[0] is the payload, frame->arg[1] is the cause, and frame->arg[2] is the cons-space - * pointer to the frame in which the exception occurred. - */ -struct cons_pointer throw_exception_with_cause( struct cons_pointer location, - struct cons_pointer message, - struct cons_pointer cause, - struct cons_pointer - frame_pointer ) { - struct cons_pointer result = NIL; - -#ifdef DEBUG - debug_print( L"\nERROR: `", 511 ); - debug_print_object( message, 511 ); - debug_print( L"` at `", 511 ); - debug_print_object( location, 511 ); - debug_print( L"`\n", 511 ); - if ( !nilp( cause ) ) { - debug_print( L"\tCaused by: ", 511 ); - debug_print_object( cause, 511 ); - debug_print( L"`\n", 511 ); - } -#endif - struct cons_space_object *cell = &pointer2cell( message ); - - if ( cell->tag.value == EXCEPTIONTV ) { - result = message; - } else { - result = - make_exception( make_cons - ( make_cons( privileged_keyword_location, - location ), - make_cons( make_cons - ( privileged_keyword_payload, - message ), - ( nilp( cause ) ? NIL : - make_cons( make_cons - ( privileged_keyword_cause, - cause ), NIL ) ) ) ), - frame_pointer ); - } - - return result; - -} - -/** - * 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. - * object pointing to it. Then this should become a normal lisp function - * which expects a normally bound frame and environment, such that - * frame->arg[0] is the payload, frame->arg[1] is the cause, and frame->arg[2] is the cons-space - * pointer to the frame in which the exception occurred. - */ -struct cons_pointer -throw_exception( struct cons_pointer location, - struct cons_pointer payload, - struct cons_pointer frame_pointer ) { - return throw_exception_with_cause( location, payload, NIL, frame_pointer ); -} - -/** - * Function; create an exception. Exceptions are special in as much as if an - * exception is created in the binding of the arguments of any function, the - * function will return the exception rather than whatever else it would - * normally return. A function which detects a problem it cannot resolve - * *should* return an exception. - * - * * (exception message location) - * - * @param frame my stack frame. - * @param frame_pointer a pointer to my stack_frame. - * @param env the environment in which arguments will be evaluated. - * @return areturns an exception whose message is this `message`, and whose - * stack frame is the parent stack frame when the function is invoked. - * `message` does not have to be a string but should be something intelligible - * which can be read. - * If `message` is itself an exception, returns that instead. - */ -struct cons_pointer -lisp_exception( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ) { - struct cons_pointer message = frame->arg[0]; - - return exceptionp( message ) ? message : - throw_exception_with_cause( message, frame->arg[1], frame->arg[2], - frame->previous ); -} - -/** - * Function: the read/eval/print loop. - * - * * (repl) - * * (repl prompt) - * * (repl prompt input_stream output_stream) - * - * @param frame my stack frame. - * @param frame_pointer a pointer to my stack_frame. - * @param env the environment in which epressions will be evaluated. - * @return the value of the last expression read. - */ -struct cons_pointer lisp_repl( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ) { - struct cons_pointer expr = NIL; - -#ifdef DEBUG - debug_print( L"Entering new inner REPL\n\tenv is `", DEBUG_REPL ); - debug_print_object( env, DEBUG_REPL ); - debug_print( L"`\n", DEBUG_REPL ); -#endif - - struct cons_pointer input = get_default_stream( true, env ); - struct cons_pointer output = get_default_stream( false, env ); - struct cons_pointer old_oblist = oblist; - struct cons_pointer new_env = env; - - if ( truep( frame->arg[0] ) ) { - new_env = set( prompt_name, frame->arg[0], new_env ); - } - if ( readp( frame->arg[1] ) ) { - new_env = - set( c_string_to_lisp_symbol( L"*in*" ), frame->arg[1], new_env ); - input = frame->arg[1]; - } - if ( writep( frame->arg[2] ) ) { - new_env = - set( c_string_to_lisp_symbol( L"*out*" ), frame->arg[2], new_env ); - output = frame->arg[2]; - } - - inc_ref( input ); - inc_ref( output ); - inc_ref( prompt_name ); - - /* output should NEVER BE nil; but during development it has happened. - * To allow debugging under such circumstances, we need an emergency - * default. */ - URL_FILE *os = - !writep( output ) ? file_to_url_file( stdout ) : - pointer2cell( output ).payload.stream.stream; - if ( !writep( output ) ) { - debug_print( L"WARNING: invalid output; defaulting!\n", - DEBUG_IO | DEBUG_REPL ); - } - - /* \todo this is subtly wrong. If we were evaluating - * (print (eval (read))) - * then the stack frame for read would have the stack frame for - * eval as parent, and it in turn would have the stack frame for - * print as parent. - */ - while ( readp( input ) && writep( output ) - && !url_feof( pointer2cell( input ).payload.stream.stream ) ) { - /* OK, here's a really subtle problem: because lists are immutable, anything - * bound in the oblist subsequent to this function being invoked isn't in the - * environment. So, for example, changes to *prompt* or *log* made in the oblist - * are not visible. So copy changes made in the oblist into the enviroment. - * \todo the whole process of resolving symbol values needs to be revisited - * when we get onto namespaces. */ - /* OK, there's something even more subtle here if the root namespace is a map. - * H'mmmm... - * I think that now the oblist is a hashmap masquerading as a namespace, - * we should no longer have to do this. TODO: test, and if so, delete this - * statement. */ - if ( !eq( oblist, old_oblist ) ) { - struct cons_pointer cursor = oblist; - - while ( !nilp( cursor ) && !eq( cursor, old_oblist ) ) { - struct cons_pointer old_new_env = new_env; - debug_print - ( L"lisp_repl: copying new oblist binding into REPL environment:\n", - DEBUG_REPL ); - debug_print_object( c_car( cursor ), DEBUG_REPL ); - debug_println( DEBUG_REPL ); - - new_env = make_cons( c_car( cursor ), new_env ); - inc_ref( new_env ); - dec_ref( old_new_env ); - cursor = c_cdr( cursor ); - } - old_oblist = oblist; - } - - println( os ); - - struct cons_pointer prompt = c_assoc( prompt_name, new_env ); - if ( !nilp( prompt ) ) { - c_print( os, prompt ); - } - - expr = lisp_read( get_stack_frame( frame_pointer ), frame_pointer, - new_env ); - - if ( exceptionp( expr ) - && url_feof( pointer2cell( input ).payload.stream.stream ) ) { - /* suppress printing end of stream exception */ - dec_ref( expr ); - break; - } - - println( os ); - - c_print( os, eval_form( frame, frame_pointer, expr, new_env ) ); - - dec_ref( expr ); - } - - if ( nilp( output ) ) { - free( os ); - } - dec_ref( input ); - dec_ref( output ); - dec_ref( prompt_name ); - dec_ref( new_env ); - - debug_printf( DEBUG_REPL, L"Leaving inner repl\n" ); - - return expr; -} - -/** - * Function. return the source code of the object which is its first argument, - * if it is an executable and has source code. - * - * * (source object) - * - * @param frame my stack frame. - * @param frame_pointer a pointer to my stack_frame. - * @param env the environment (ignored). - * @return the source of the `object` indicated, if it is a function, a lambda, - * an nlambda, or a spcial form; else `nil`. - */ -struct cons_pointer lisp_source( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ) { - struct cons_pointer result = NIL; - struct cons_space_object *cell = &pointer2cell( frame->arg[0] ); - struct cons_pointer source_key = c_string_to_lisp_keyword( L"source" ); - switch ( cell->tag.value ) { - case FUNCTIONTV: - result = c_assoc( source_key, cell->payload.function.meta ); - break; - case SPECIALTV: - result = c_assoc( source_key, cell->payload.special.meta ); - break; - case LAMBDATV: - result = make_cons( c_string_to_lisp_symbol( L"lambda" ), - make_cons( cell->payload.lambda.args, - cell->payload.lambda.body ) ); - break; - case NLAMBDATV: - result = make_cons( c_string_to_lisp_symbol( L"nlambda" ), - make_cons( cell->payload.lambda.args, - cell->payload.lambda.body ) ); - break; - } - // \todo suffers from premature GC, and I can't see why! - inc_ref( result ); - - return result; -} - -/** - * A version of append which can conveniently be called from C. - */ -struct cons_pointer c_append( struct cons_pointer l1, struct cons_pointer l2 ) { - switch ( pointer2cell( l1 ).tag.value ) { - case CONSTV: - if ( pointer2cell( l1 ).tag.value == pointer2cell( l2 ).tag.value ) { - if ( nilp( c_cdr( l1 ) ) ) { - return make_cons( c_car( l1 ), l2 ); - } else { - return make_cons( c_car( l1 ), - c_append( c_cdr( l1 ), l2 ) ); - } - } else { - throw_exception( c_string_to_lisp_symbol( L"append" ), - c_string_to_lisp_string - ( L"Can't append: not same type" ), NIL ); - } - break; - case KEYTV: - case STRINGTV: - case SYMBOLTV: - if ( pointer2cell( l1 ).tag.value == pointer2cell( l2 ).tag.value ) { - if ( nilp( c_cdr( l1 ) ) ) { - return - make_string_like_thing( ( pointer2cell( l1 ). - payload.string.character ), - l2, - pointer2cell( l1 ).tag.value ); - } else { - return - make_string_like_thing( ( pointer2cell( l1 ). - payload.string.character ), - c_append( c_cdr( l1 ), l2 ), - pointer2cell( l1 ).tag.value ); - } - } else { - throw_exception( c_string_to_lisp_symbol( L"append" ), - c_string_to_lisp_string - ( L"Can't append: not same type" ), NIL ); - } - break; - default: - throw_exception( c_string_to_lisp_symbol( L"append" ), - c_string_to_lisp_string - ( L"Can't append: not a sequence" ), NIL ); - break; - } -} - -/** - * should really be overwritten with a version in Lisp, since this is much easier to write in Lisp - */ -struct cons_pointer lisp_append( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ) { - struct cons_pointer result = fetch_arg( frame, ( frame->args - 1 ) ); - - for ( int a = frame->args - 2; a >= 0; a-- ) { - result = c_append( fetch_arg( frame, a ), result ); - } - - return result; -} - -struct cons_pointer lisp_mapcar( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ) { - struct cons_pointer result = NIL; - debug_print( L"Mapcar: ", DEBUG_EVAL ); - debug_dump_object( frame_pointer, DEBUG_EVAL ); - int i = 0; - - for ( struct cons_pointer c = frame->arg[1]; truep( c ); c = c_cdr( c ) ) { - struct cons_pointer expr = - make_cons( frame->arg[0], make_cons( c_car( c ), NIL ) ); - - debug_printf( DEBUG_EVAL, L"Mapcar %d, evaluating ", i ); - debug_print_object( expr, DEBUG_EVAL ); - debug_println( DEBUG_EVAL ); - - struct cons_pointer r = eval_form( frame, frame_pointer, expr, env ); - - if ( exceptionp( r ) ) { - result = r; - inc_ref( expr ); // to protect exception from the later dec_ref - break; - } else { - result = make_cons( r, result ); - } - debug_printf( DEBUG_EVAL, L"Mapcar %d, result is ", i++ ); - debug_print_object( result, DEBUG_EVAL ); - debug_println( DEBUG_EVAL ); - - dec_ref( expr ); - } - - result = consp( result ) ? c_reverse( result ) : result; - - debug_print( L"Mapcar returning: ", DEBUG_EVAL ); - debug_print_object( result, DEBUG_EVAL ); - debug_println( DEBUG_EVAL ); - - return result; -} - -/** - * @brief construct and return a list of arbitrarily many arguments. - * - * @param frame The stack frame. - * @param frame_pointer A pointer to the stack frame. - * @param env The evaluation environment. - * @return struct cons_pointer a pointer to the result - */ -struct cons_pointer lisp_list( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ) { - struct cons_pointer result = frame->more; - - for ( int a = nilp( result ) ? frame->args - 1 : args_in_frame - 1; - a >= 0; a-- ) { - result = make_cons( fetch_arg( frame, a ), result ); - } - - return result; -} - - - -/** - * Special form: evaluate a series of forms in an environment in which - * these bindings are bound. - * This is `let*` in Common Lisp parlance; `let` in Clojure parlance. - */ -struct cons_pointer lisp_let( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ) { - struct cons_pointer bindings = env; - struct cons_pointer result = NIL; - - for ( struct cons_pointer cursor = frame->arg[0]; - truep( cursor ); cursor = c_cdr( cursor ) ) { - struct cons_pointer pair = c_car( cursor ); - struct cons_pointer symbol = c_car( pair ); - - if ( symbolp( symbol ) ) { - struct cons_pointer val = - eval_form( frame, frame_pointer, c_cdr( pair ), - bindings ); - - debug_print_binding( symbol, val, false, DEBUG_BIND ); - - bindings = make_cons( make_cons( symbol, val ), bindings ); - } else { - result = - throw_exception( c_string_to_lisp_symbol( L"let" ), - c_string_to_lisp_string - ( L"Let: cannot bind, not a symbol" ), - frame_pointer ); - break; - } - } - - debug_print( L"\nlet: bindings complete.\n", DEBUG_BIND ); - - /* i.e., no exception yet */ - for ( int form = 1; !exceptionp( result ) && form < frame->args; form++ ) { - result = - eval_form( frame, frame_pointer, fetch_arg( frame, form ), - bindings ); - } - - /* release the local bindings as they go out of scope! **BUT** - * bindings were consed onto the front of env, so caution... */ - // for (struct cons_pointer cursor = bindings; !eq( cursor, env); cursor = c_cdr(cursor)) { - // dec_ref( cursor); - // } - - return result; - -} - -/** - * @brief Boolean `and` of arbitrarily many arguments. - * - * @param frame The stack frame. - * @param frame_pointer A pointer to the stack frame. - * @param env The evaluation environment. - * @return struct cons_pointer a pointer to the result - */ -struct cons_pointer lisp_and( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ) { - bool accumulator = true; - struct cons_pointer result = frame->more; - - for ( int a = 0; accumulator == true && a < frame->args; a++ ) { - accumulator = truthy( fetch_arg( frame, a ) ); - } -# - return accumulator ? TRUE : NIL; -} - -/** - * @brief Boolean `or` of arbitrarily many arguments. - * - * @param frame The stack frame. - * @param frame_pointer A pointer to the stack frame. - * @param env The evaluation environment. - * @return struct cons_pointer a pointer to the result - */ -struct cons_pointer lisp_or( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ) { - bool accumulator = false; - struct cons_pointer result = frame->more; - - for ( int a = 0; accumulator == false && a < frame->args; a++ ) { - accumulator = truthy( fetch_arg( frame, a ) ); - } - - return accumulator ? TRUE : NIL; -} - -/** - * @brief Logical inverese: if the first argument is `nil`, return `t`, else `nil`. - * - * @param frame The stack frame. - * @param frame_pointer A pointer to the stack frame. - * @param env The evaluation environment. - * @return struct cons_pointer `t` if the first argument is `nil`, else `nil`. - */ -struct cons_pointer lisp_not( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ) { - return nilp( frame->arg[0] ) ? TRUE : NIL; -} diff --git a/archive/c/ops/lispops.h b/archive/c/ops/lispops.h deleted file mode 100644 index 66f46c8..0000000 --- a/archive/c/ops/lispops.h +++ /dev/null @@ -1,250 +0,0 @@ -/** - * 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 - * 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 diff --git a/archive/c/ops/loop.c b/archive/c/ops/loop.c deleted file mode 100644 index 6ccada6..0000000 --- a/archive/c/ops/loop.c +++ /dev/null @@ -1,50 +0,0 @@ -/* - * 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 - * 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]; - -} diff --git a/archive/c/ops/loop.h b/archive/c/ops/loop.h deleted file mode 100644 index 27714a8..0000000 --- a/archive/c/ops/loop.h +++ /dev/null @@ -1,10 +0,0 @@ -/* - * 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 - * Licensed under GPL version 2.0, or, at your option, any later version. - */ diff --git a/archive/c/ops/meta.c b/archive/c/ops/meta.c deleted file mode 100644 index f00824f..0000000 --- a/archive/c/ops/meta.c +++ /dev/null @@ -1,45 +0,0 @@ -/* - * meta.c - * - * Get metadata from a cell which has it. - * - * (c) 2019 Simon Brooke - * 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; -} diff --git a/archive/c/ops/meta.h b/archive/c/ops/meta.h deleted file mode 100644 index f441a50..0000000 --- a/archive/c/ops/meta.h +++ /dev/null @@ -1,18 +0,0 @@ -/* - * meta.h - * - * Get metadata from a cell which has it. - * - * (c) 2019 Simon Brooke - * 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 diff --git a/archive/c/repl.c b/archive/c/repl.c deleted file mode 100644 index 8ae0b43..0000000 --- a/archive/c/repl.c +++ /dev/null @@ -1,50 +0,0 @@ -/* - * repl.c - * - * the read/eval/print loop - * - * (c) 2017 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#include -#include -#include -#include - -#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 ); -} diff --git a/archive/c/repl.h b/archive/c/repl.h deleted file mode 100644 index 8ff8b19..0000000 --- a/archive/c/repl.h +++ /dev/null @@ -1,29 +0,0 @@ -/* - * 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 */ diff --git a/archive/c/time/psse_time.c b/archive/c/time/psse_time.c deleted file mode 100644 index a2deb86..0000000 --- a/archive/c/time/psse_time.c +++ /dev/null @@ -1,109 +0,0 @@ -/* - * psse_time.c - * - * Bare bones of PSSE time. See issue #16. - * - * (c) 2019 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#include -#include -#include -/* - * wide characters - */ -#include -#include - -#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; - char32_t buffer[l]; - - mbstowcs( buffer, bytes, l ); - result = c_string_to_lisp_string( buffer ); - } - - return result; -} diff --git a/archive/c/time/psse_time.h b/archive/c/time/psse_time.h deleted file mode 100644 index f2afdd2..0000000 --- a/archive/c/time/psse_time.h +++ /dev/null @@ -1,21 +0,0 @@ -/* - * psse_time.h - * - * Bare bones of PSSE time. See issue #16. - * - * (c) 2019 Simon Brooke - * 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 diff --git a/archive/c/utils.c b/archive/c/utils.c deleted file mode 100644 index 9919dbe..0000000 --- a/archive/c/utils.c +++ /dev/null @@ -1,33 +0,0 @@ -/* - * utils.c - * - * little generally useful functions which aren't in any way special to PSSE. - * - * (c) 2019 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#include -#include -#include - - -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]; -} diff --git a/archive/c/utils.h b/archive/c/utils.h deleted file mode 100644 index 456e4d0..0000000 --- a/archive/c/utils.h +++ /dev/null @@ -1,17 +0,0 @@ -/* - * utils.h - * - * little generally useful functions which aren't in any way special to PSSE. - * - * (c) 2019 Simon Brooke - * 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 diff --git a/archive/c/version.h b/archive/c/version.h deleted file mode 100644 index 6548d30..0000000 --- a/archive/c/version.h +++ /dev/null @@ -1,11 +0,0 @@ -/** - * version.h - * - * Just the version number. There's DEFINITELY a better way to do this! - * - * - * (c) 2017 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#define VERSION "0.0.7-SNAPSHOT" diff --git a/src/c/environment/environment.c b/src/c/environment/environment.c index f15c382..3bbb021 100644 --- a/src/c/environment/environment.c +++ b/src/c/environment/environment.c @@ -41,11 +41,11 @@ bool environment_initialised = false; struct pso_pointer initialise_environment( uint32_t node ) { struct pso_pointer result = initialise_memory( node ); - struct pso_pointer frame = make_frame(0, nil); + struct pso_pointer frame_pointer = make_frame( 0, nil ); if ( c_truep( result ) ) { debug_print( L"Initialising `nil`... ", DEBUG_BOOTSTRAP, 0 ); - struct pso_pointer n = allocate( frame, NILTAG, 2 ); + struct pso_pointer n = allocate( frame_pointer, NILTAG, 2 ); if ( ( n.page == 0 ) && ( n.offset == 0 ) ) { struct pso2 *object = pointer_to_object( n ); @@ -62,7 +62,7 @@ struct pso_pointer initialise_environment( uint32_t node ) { } if ( !c_nilp( result ) ) { debug_print( L"Initialising `t`... ", DEBUG_BOOTSTRAP, 0 ); - struct pso_pointer n = allocate( frame, TRUETAG, 2 ); + struct pso_pointer n = allocate( frame_pointer, TRUETAG, 2 ); // offset is in words, and size of a pso2 is four words if ( ( n.page == 0 ) && ( n.offset == 4 ) ) { @@ -79,11 +79,19 @@ struct pso_pointer initialise_environment( uint32_t node ) { } } if ( !exceptionp( result ) ) { - result = c_bind( c_string_to_lisp_symbol( frame, L"nil" ), nil, nil ); + result = + lisp_bind( make_frame + ( 3, frame_pointer, + c_string_to_lisp_symbol( frame_pointer, L"nil" ), nil, + nil ) ); debug_print( L"Environment after binding `nil`: ", DEBUG_BOOTSTRAP, 0 ); debug_print_object( result, DEBUG_BOOTSTRAP, 0 ); - result = c_bind( c_string_to_lisp_symbol( frame, L"t" ), t, result ); + result = + lisp_bind( make_frame + ( 3, frame_pointer, + c_string_to_lisp_symbol( frame_pointer, L"t" ), t, + result ) ); environment_initialised = true; debug_print( L"Environment after binding `t`: ", DEBUG_BOOTSTRAP, 0 ); @@ -93,5 +101,7 @@ struct pso_pointer initialise_environment( uint32_t node ) { DEBUG_BOOTSTRAP, 0 ); } + dec_ref( frame_pointer ); + return result; } diff --git a/src/c/io/io.c b/src/c/io/io.c index f63264d..20e01e1 100644 --- a/src/c/io/io.c +++ b/src/c/io/io.c @@ -26,6 +26,7 @@ */ #include #include +#include #include @@ -149,65 +150,79 @@ int initialise_io( ) { return result; } -struct pso_pointer initialise_default_streams( struct pso_pointer env ) { +struct pso_pointer initialise_default_streams( struct pso_pointer stack_frame, + struct pso_pointer env ) { // todo: issue #21: should this have stack frame passed in? // It's called in initialisation before everything else is set // up, so **possibly** not? - lisp_io_in = c_string_to_lisp_symbol( C_IO_IN ); - lisp_io_out = c_string_to_lisp_symbol( C_IO_OUT ); - lisp_io_log = c_string_to_lisp_symbol( C_IO_LOG ); - lisp_io_prompt = c_string_to_lisp_symbol( C_IO_PROMPT ); + lisp_io_in = c_string_to_lisp_symbol( stack_frame, C_IO_IN ); + lisp_io_out = c_string_to_lisp_symbol( stack_frame, C_IO_OUT ); + lisp_io_log = c_string_to_lisp_symbol( stack_frame, C_IO_LOG ); + lisp_io_prompt = c_string_to_lisp_symbol( stack_frame, C_IO_PROMPT ); debug_print( L"In initialise_default_streams; environment is: ", DEBUG_IO, 0 ); debug_print_object( env, DEBUG_IO, 0 ); env = - c_bind( lisp_io_prompt, c_string_to_lisp_string( INITIAL_PROMPT ), - env ); - - lisp_stdin = lock_object( make_read_stream( file_to_url_file( stdin ), - make_cons( make_cons - ( c_string_to_lisp_keyword - ( L"url" ), - c_string_to_lisp_string - ( L"::system:standard-input" ) ), - nil ) ) ); - - env = c_bind( lisp_io_in, lisp_stdin, env ); + lisp_bind( make_frame + ( 3, stack_frame, lisp_io_prompt, + c_string_to_lisp_string( stack_frame, INITIAL_PROMPT ), + env ) ); + lisp_stdin = + lock_object( make_read_stream + ( stack_frame, file_to_url_file( stdin ), + make_cons( stack_frame, + make_cons( stack_frame, + c_string_to_lisp_keyword + ( stack_frame, L"url" ), + c_string_to_lisp_string + ( stack_frame, + L"::system:standard-input" ) ), + stack_frame ) ) ); + env = + lisp_bind( make_frame( 3, stack_frame, lisp_io_in, lisp_stdin, env ) ); debug_print_object( env, DEBUG_IO, 0 ); - if ( !nilp( env ) && !exceptionp( env ) ) { + if ( !c_nilp( env ) && !exceptionp( env ) ) { lisp_stdout = - lock_object( 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 ) ) ); - - env = c_bind( lisp_io_out, lisp_stdout, env ); + lock_object( make_write_stream( stack_frame, + file_to_url_file( stdout ), + make_cons( stack_frame, + make_cons( stack_frame, + c_string_to_lisp_keyword + ( stack_frame, + L"url" ), + c_string_to_lisp_string + ( stack_frame, + L"::system:standard-output" ) ), + nil ) ) ); + env = + lisp_bind( make_frame + ( 3, stack_frame, lisp_io_out, lisp_stdout, env ) ); } - if ( !nilp( env ) && !exceptionp( env ) ) { + if ( !c_nilp( env ) && !exceptionp( env ) ) { lisp_stderr = lock_object( 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-output" ) ), + ( stack_frame, file_to_url_file( stderr ), + make_cons( stack_frame, + make_cons( stack_frame, + c_string_to_lisp_keyword + ( stack_frame, L"url" ), + c_string_to_lisp_string + ( stack_frame, + L"::system:standard-output" ) ), nil ) ) ); - - env = c_bind( lisp_io_log, lisp_stderr, env ); + env = + lisp_bind( make_frame + ( 3, frame_pointer, lisp_io_log, lisp_stderr, env ) ); } debug_print( L"Leaving initialise_default_streams; environment is: ", DEBUG_IO, 0 ); debug_print_object( env, DEBUG_IO, 0 ); - return env; } @@ -222,20 +237,17 @@ struct pso_pointer initialise_default_streams( struct pso_pointer env ) { */ char *lisp_string_to_c_string( struct pso_pointer s ) { char *result = NULL; - if ( stringp( s ) || symbolp( s ) ) { int len = 0; - - for ( struct pso_pointer c = s; !nilp( c ); c = c_cdr( c ) ) { + for ( struct pso_pointer c = s; !c_nilp( c ); c = c_cdr( c ) ) { len++; } char32_t *buffer = calloc( len + 1, sizeof( char32_t ) ); /* worst case, one wide char = four utf bytes */ result = calloc( ( len * 4 ) + 1, sizeof( char ) ); - int i = 0; - for ( struct pso_pointer c = s; !nilp( c ); c = c_cdr( c ) ) { + for ( struct pso_pointer c = s; !c_nilp( c ); c = c_cdr( c ) ) { buffer[i++] = pointer_to_object( c )->payload.string.character; } @@ -246,7 +258,6 @@ char *lisp_string_to_c_string( struct pso_pointer s ) { debug_print( L"lisp_string_to_c_string( ", DEBUG_IO, 0 ); debug_print_object( s, DEBUG_IO, 0 ); debug_printf( DEBUG_IO, 0, L") => '%s'\n", result ); - return result; } @@ -258,7 +269,6 @@ char *lisp_string_to_c_string( struct pso_pointer s ) { */ wint_t url_fgetwc( URL_FILE *input ) { wint_t result = -1; - if ( ungotten != 0 ) { /* TODO: not thread safe */ result = ungotten; @@ -269,14 +279,11 @@ wint_t url_fgetwc( URL_FILE *input ) { fwide( input->handle.file, 1 ); /* wide characters */ result = fgetwc( input->handle.file ); /* passthrough */ break; - case CFTYPE_CURL:{ char *cbuff = calloc( sizeof( char32_t ) + 2, sizeof( char ) ); char32_t *wbuff = calloc( 2, sizeof( char32_t ) ); - size_t count = 0; - debug_print( L"url_fgetwc: about to call url_fgets\n", DEBUG_IO, 0 ); url_fgets( cbuff, 2, input ); @@ -312,10 +319,10 @@ wint_t url_fgetwc( URL_FILE *input ) { } mbstowcs( wbuff, cbuff, 2 ); //(char *)(&input->buffer[input->buffer_pos]), 1 ); result = wbuff[0]; - free( wbuff ); free( cbuff ); - } break; + } + break; case CFTYPE_NONE: break; } @@ -328,13 +335,11 @@ wint_t url_fgetwc( URL_FILE *input ) { 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; @@ -356,12 +361,11 @@ wint_t url_ungetwc( wint_t wc, URL_FILE *input ) { */ struct pso_pointer get_character( struct pso_pointer read_stream ) { struct pso_pointer result = nil; - if ( readp( read_stream ) ) { result = make_character( url_fgetwc - ( pointer_to_object_of_size_class( read_stream, 2 ) - ->payload.stream.stream ) ); + ( pointer_to_object_of_size_class + ( read_stream, 2 )->payload.stream.stream ) ); } return result; @@ -378,7 +382,6 @@ struct pso_pointer get_character( struct pso_pointer read_stream ) { struct pso_pointer push_back_character( struct pso_pointer c, struct pso_pointer r ) { struct pso_pointer result = nil; - if ( characterp( c ) && readp( r ) ) { if ( url_ungetwc( ( wint_t ) ( pointer_to_object( c )->payload.character. @@ -407,10 +410,11 @@ struct pso_pointer lisp_close( struct pso_pointer frame_pointer, struct pso_pointer env ) { struct pso4 *frame = pointer_to_pso4( frame_pointer ); struct pso_pointer result = nil; - if ( readp( fetch_arg( frame, 0 ) ) || writep( fetch_arg( frame, 0 ) ) ) { - if ( url_fclose( pointer_to_object( fetch_arg( frame, 0 ) ) - ->payload.stream.stream ) == 0 ) { + if ( url_fclose + ( pointer_to_object( fetch_arg( frame, 0 ) )->payload.stream. + stream ) + == 0 ) { result = t; } } @@ -433,7 +437,6 @@ struct pso_pointer add_meta_string( struct pso_pointer meta, char32_t *key, value = trim( value ); char32_t buffer[strlen( value ) + 1]; mbstowcs( buffer, value, strlen( value ) + 1 ); - return make_cons( make_cons ( c_string_to_lisp_keyword( frame_pointer, key ), @@ -444,10 +447,8 @@ struct pso_pointer add_meta_time( struct pso_pointer meta, char32_t *key, time_t *value ) { // todo: issue #21: must have stack frame passed in. char datestring[256]; - strftime( datestring, sizeof( datestring ), nl_langinfo( D_T_FMT ), localtime( value ) ); - return add_meta_string( meta, key, datestring ); } @@ -458,43 +459,33 @@ struct pso_pointer add_meta_time( struct pso_pointer meta, char32_t *key, static size_t write_meta_callback( char *string, size_t size, size_t nmemb, struct pso_pointer stream ) { struct pso2 *cell = pointer_to_object( stream ); - // TODO: reimplement - /* make a copy of the string that we can destructively change */ // char *s = calloc( strlen( string ), sizeof( char ) ); - // strcpy( s, string ); - // if ( check_tag( cell, READTV) || // check_tag( cell, WRITETV) ) { // int offset = index_of( ':', s ); - // if ( offset != -1 ) { // s[offset] = ( char ) 0; // char *name = trim( s ); // char *value = trim( &s[++offset] ); // char32_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 ); @@ -510,7 +501,6 @@ static size_t write_meta_callback( char *string, size_t size, size_t nmemb, // DEBUG_IO ); // debug_dump_object( stream, DEBUG_IO ); // } - // free( s ); return 0; // strlen( string ); } @@ -519,12 +509,12 @@ void collect_meta( struct pso_pointer stream, char *url ) { struct pso2 *cell = pointer_to_object( stream ); URL_FILE *s = pointer_to_object( stream )->payload.stream.stream; struct pso_pointer meta = - add_meta_string( cell->payload.stream.meta, L"url", url ); + 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; @@ -545,7 +535,6 @@ void collect_meta( struct pso_pointer stream, char *url ) { meta = add_meta_integer( meta, L"size", ( intmax_t ) statbuf.st_size ); - meta = add_meta_time( meta, L"modified", &statbuf.st_mtime ); } break; @@ -569,9 +558,7 @@ void collect_meta( struct pso_pointer stream, char *url ) { struct pso_pointer get_default_stream( bool inputp, struct pso_pointer env ) { struct pso_pointer result = nil; struct pso_pointer stream_name = inputp ? lisp_io_in : lisp_io_out; - result = c_assoc( stream_name, env ); - return result; } @@ -581,10 +568,8 @@ struct pso_pointer get_default_stream( bool inputp, struct pso_pointer env ) { */ URL_FILE *stream_get_url_file( struct pso_pointer s ) { URL_FILE *result = NULL; - if ( readp( s ) || writep( s ) ) { struct pso2 *obj = pointer_to_object( s ); - result = obj->payload.stream.stream; } @@ -610,18 +595,14 @@ struct pso_pointer lisp_open( struct pso_pointer frame_pointer, struct pso_pointer env ) { struct pso4 *frame = pointer_to_pso4( frame_pointer ); struct pso_pointer result = nil; - // if ( stringp( fetch_arg( frame, 0) ) ) { // char *url = lisp_string_to_c_string( fetch_arg( frame, 0) ); - - // if ( nilp( fetch_arg( frame, 1) ) ) { + // if ( c_nilp( fetch_arg( frame, 1) ) ) { // URL_FILE *stream = url_fopen( url, "r" ); - // debug_printf( DEBUG_IO, 0, // 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 @@ -641,23 +622,19 @@ struct pso_pointer lisp_open( struct pso_pointer frame_pointer, // /* 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 ( pointer_to_object( result )->payload.stream.stream == NULL ) { // result = nil; // } else { // collect_meta( result, url ); // } - // free( url ); // } - return result; } @@ -677,12 +654,11 @@ struct pso_pointer lisp_read_char( struct pso_pointer frame_pointer, struct pso_pointer env ) { struct pso4 *frame = pointer_to_pso4( frame_pointer ); struct pso_pointer result = nil; - struct pso_pointer stream_pointer = fetch_arg( frame, 0 ); if ( readp( stream_pointer ) ) { - result = - make_string( frame_pointer, url_fgetwc( stream_get_url_file( stream_pointer ) ), - nil ); + result = make_string( frame_pointer, + url_fgetwc( stream_get_url_file + ( stream_pointer ) ), nil ); } return result; @@ -706,12 +682,11 @@ struct pso_pointer lisp_slurp( struct pso_pointer frame_pointer, struct pso_pointer env ) { struct pso4 *frame = pointer_to_pso4( frame_pointer ); struct pso_pointer result = nil; - if ( readp( fetch_arg( frame, 0 ) ) ) { URL_FILE *stream = stream_get_url_file( fetch_arg( frame, 0 ) ); - struct pso_pointer cursor = make_string( frame_pointer, url_fgetwc( stream ), nil ); + struct pso_pointer cursor = make_string( frame_pointer, + 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, 0 ); @@ -719,7 +694,6 @@ struct pso_pointer lisp_slurp( struct pso_pointer frame_pointer, debug_print( L"; result is: ", DEBUG_IO, 0 ); debug_dump_object( result, DEBUG_IO, 0 ); debug_println( DEBUG_IO ); - struct pso2 *cell = pointer_to_object( cursor ); cursor = make_string( frame_pointer, ( char32_t ) c, nil ); cell->payload.string.cdr = cursor; diff --git a/src/c/io/io.h b/src/c/io/io.h index f90e589..cc660d1 100644 --- a/src/c/io/io.h +++ b/src/c/io/io.h @@ -12,6 +12,13 @@ #define __psse_io_io_h #include +/* + * wide characters + */ +#include +#include +#include + #include "memory/pointer.h" #include "memory/pso2.h" #include "memory/pso4.h" @@ -19,7 +26,9 @@ extern CURLSH *io_share; int initialise_io( ); -struct pso_pointer initialise_default_streams( struct pso_pointer env ); +struct pso_pointer initialise_default_streams( struct pso_pointer + frame_pointer, + struct pso_pointer env ); #define C_IO_IN L"*in*" #define C_IO_OUT L"*out*" diff --git a/src/c/io/print.c b/src/c/io/print.c index d6bf63b..b1ce56e 100644 --- a/src/c/io/print.c +++ b/src/c/io/print.c @@ -42,6 +42,7 @@ #include "payloads/exception.h" #include "payloads/integer.h" +#include "ops/stack_ops.h" #include "ops/truth.h" struct pso_pointer in_write( struct pso_pointer p, URL_FILE * output, @@ -78,7 +79,7 @@ struct pso_pointer print_string_like_thing( struct pso_pointer p, } if ( keywordp( p ) || stringp( p ) || symbolp( p ) ) { - for ( struct pso_pointer cursor = p; !nilp( cursor ); + for ( struct pso_pointer cursor = p; !c_nilp( cursor ); cursor = pointer_to_object( cursor )->payload.string.cdr ) { char32_t wc = pointer_to_object( cursor )->payload.string.character; @@ -190,7 +191,9 @@ struct pso_pointer in_write( struct pso_pointer p, URL_FILE *output, * This is kind of modelled after the implementation of PRIN* variants on page * 383 of the aluminium book. It is the inner workings of all PRIN* functions. * - * @param p pointer to the object to print. + * (write object stream escape? nl_before? nl_after?) + * + * @param object pointer to the object to print. * @param output stream to print to. * @param escape if true, print everything so that it can be read by the Lisp * reader; otherwise, print it appropriately for human readers. @@ -198,9 +201,14 @@ struct pso_pointer in_write( struct pso_pointer p, URL_FILE *output, * @param nl_after if true, print a newline *after* printing `p`; else a space. * @return p on success, exception on failure. */ -struct pso_pointer write( struct pso_pointer p, struct pso_pointer stream, - bool escape, bool nl_before, bool nl_after ) { - struct pso_pointer result = p; +struct pso_pointer write( struct pso_pointer frame_pointer ) { + struct pso4 *frame = pointer_to_pso4( frame_pointer ); + struct pso_pointer object = fetch_arg( frame, 0 ); + struct pso_pointer stream = fetch_arg( frame, 1 ); + bool escape = c_truep( fetch_arg( frame, 2 ) ); + bool nl_before = c_truep( fetch_arg( frame, 3 ) ); + bool nl_after = c_truep( fetch_arg( frame, 4 ) ); + struct pso_pointer result = object; URL_FILE *output = writep( stream ) ? pointer_to_object( stream )->payload.stream.stream : file_to_url_file( stdout ); @@ -211,16 +219,17 @@ struct pso_pointer write( struct pso_pointer p, struct pso_pointer stream, if ( nl_before ) url_fputwc( L'\n', output ); - result = in_write( p, output, true ); + result = in_write( object, output, true ); url_fputwc( nl_after ? L'\n' : L' ', output ); dec_ref( stream ); } else { result = - make_exception( c_string_to_lisp_string - ( L"Bad write stream passed to write." ), nil, nil, - nil ); + make_exception( make_frame( 1, frame_pointer, + c_string_to_lisp_string + ( frame_pointer, + L"Bad write stream passed to write." ) ) ); } return result; @@ -233,13 +242,21 @@ struct pso_pointer write( struct pso_pointer p, struct pso_pointer stream, * @param stream if a pointer to an open write stream, print to there. * @return struct pso_pointer `nil`, or an exception if some erroe occurred. */ -struct pso_pointer c_print( struct pso_pointer p, struct pso_pointer stream ) { - return write( p, stream, true, true, false ); +struct pso_pointer print( struct pso_pointer frame_pointer ) { + struct pso4 *frame = pointer_to_pso4( frame_pointer ); + + return write( make_frame( 5, frame_pointer, + fetch_arg( frame, 0 ), fetch_arg( frame, 1 ), t, + t, nil ) ); } /** * @brief princ is pretty much like print except things are printed `unescaped` */ -struct pso_pointer c_princ( struct pso_pointer p, struct pso_pointer stream ) { - return write( p, stream, false, true, false ); +struct pso_pointer princ( struct pso_pointer frame_pointer ) { + struct pso4 *frame = pointer_to_pso4( frame_pointer ); + + return write( make_frame( 5, frame_pointer, + fetch_arg( frame, 0 ), fetch_arg( frame, 1 ), + nil, t, nil ) ); } diff --git a/src/c/io/print.h b/src/c/io/print.h index d239913..c6716e4 100644 --- a/src/c/io/print.h +++ b/src/c/io/print.h @@ -16,8 +16,8 @@ #include #include "io/fopen.h" -struct pso_pointer c_print( struct pso_pointer p, struct pso_pointer stream ); -struct pso_pointer c_princ( struct pso_pointer p, struct pso_pointer stream ); +struct pso_pointer print( struct pso_pointer frame_pointer ); +struct pso_pointer princ( struct pso_pointer frame_pointer ); #define PRINT_VARIANT_PRINT 0 #define PRINT_VARIANT_PRIN1 1 diff --git a/src/c/io/read.c b/src/c/io/read.c index c2d0335..8525836 100644 --- a/src/c/io/read.c +++ b/src/c/io/read.c @@ -98,12 +98,7 @@ struct pso_pointer read_example( * 1. The read table currently in use; * 2. The character most recently read from that stream. */ -struct pso_pointer read_number( -#ifndef MANAGED_POINTER_ONLY - struct pso4 *frame, -#endif - struct pso_pointer frame_pointer, - struct pso_pointer env ) { +struct pso_pointer read_number( struct pso_pointer frame_pointer ) { struct pso4 *frame = pointer_to_pso4( frame_pointer ); struct pso_pointer stream = fetch_arg( frame, 0 ); struct pso_pointer readtable = fetch_arg( frame, 1 ); @@ -115,10 +110,10 @@ struct pso_pointer read_number( int64_t value = 0; if ( readp( stream ) ) { - if ( nilp( character ) ) { + if ( c_nilp( character ) ) { character = get_character( stream ); } - char32_t c = nilp( character ) + char32_t c = c_nilp( character ) ? 0 : pointer_to_object( character )->payload.character.character; URL_FILE *input = pointer_to_object( stream )->payload.stream.stream; @@ -127,18 +122,13 @@ struct pso_pointer read_number( } url_ungetwc( c, input ); - result = make_integer( value ); + result = make_integer( frame_pointer, value ); } // else exception? return result; } -struct pso_pointer read_symbol( -#ifndef MANAGED_POINTER_ONLY - struct pso4 *frame, -#endif - struct pso_pointer frame_pointer, - struct pso_pointer env ) { +struct pso_pointer read_symbol( struct pso_pointer frame_pointer ) { struct pso4 *frame = pointer_to_pso4( frame_pointer ); struct pso_pointer stream = fetch_arg( frame, 0 ); struct pso_pointer readtable = fetch_arg( frame, 1 ); @@ -146,16 +136,17 @@ struct pso_pointer read_symbol( struct pso_pointer result = nil; if ( readp( stream ) ) { - if ( nilp( character ) ) { + if ( c_nilp( character ) ) { character = get_character( stream ); } - char32_t c = nilp( character ) + char32_t c = c_nilp( character ) ? 0 : pointer_to_object( character )->payload.character.character; URL_FILE *input = pointer_to_object( stream )->payload.stream.stream; for ( ; iswalnum( c ); c = url_fgetwc( input ) ) { - result = make_string_like_thing( c, result, SYMBOLTAG ); + result = + make_string_like_thing( frame_pointer, c, result, SYMBOLTAG ); } url_ungetwc( c, input ); @@ -176,12 +167,7 @@ struct pso_pointer read_symbol( * 1. The read table currently in use; * 2. The character most recently read from that stream. */ -struct pso_pointer read( -#ifndef MANAGED_POINTER_ONLY - struct pso4 *frame, -#endif - struct pso_pointer frame_pointer, - struct pso_pointer env ) { +struct pso_pointer read( struct pso_pointer frame_pointer ) { struct pso4 *frame = pointer_to_pso4( frame_pointer ); struct pso_pointer stream = fetch_arg( frame, 0 ); struct pso_pointer readtable = fetch_arg( frame, 1 ); @@ -189,22 +175,23 @@ struct pso_pointer read( struct pso_pointer result = nil; - if ( nilp( stream ) ) { - stream = make_read_stream( file_to_url_file( stdin ), nil ); + if ( c_nilp( stream ) ) { + stream = + make_read_stream( frame_pointer, file_to_url_file( stdin ), nil ); } - if ( nilp( readtable ) ) { + if ( c_nilp( readtable ) ) { // TODO: check for the value of `*read-table*` in the environment and // use that. } - if ( nilp( character ) ) { + if ( c_nilp( character ) ) { character = get_character( stream ); } struct pso_pointer readmacro = c_assoc( character, readtable ); - if ( !nilp( readmacro ) ) { + if ( !c_nilp( readmacro ) ) { // invoke the read macro on the stream } else if ( readp( stream ) && characterp( character ) ) { char32_t c = @@ -228,12 +215,13 @@ struct pso_pointer read( default: struct pso_pointer next = make_frame( 3, frame_pointer, stream, readtable, - make_character( c ) ); + make_character + ( frame_pointer, c ) ); inc_ref( next ); if ( iswdigit( c ) ) { - result = read_number( next, env ); + result = read_number( next ); } else if ( iswalpha( c ) ) { - result = read_symbol( next, env ); + result = read_symbol( next ); } else { // result = // throw_exception( diff --git a/src/c/io/read.h b/src/c/io/read.h index a3e0ffc..7bb4687 100644 --- a/src/c/io/read.h +++ b/src/c/io/read.h @@ -13,13 +13,10 @@ #ifndef __psse_io_read_h #define __psse_io_read_h -struct pso_pointer read_number( struct pso_pointer frame_pointer, - struct pso_pointer env ); +struct pso_pointer read_number( struct pso_pointer frame_pointer ); -struct pso_pointer read_symbol( struct pso_pointer frame_pointer, - struct pso_pointer env ); +struct pso_pointer read_symbol( struct pso_pointer frame_pointer ); -struct pso_pointer read( struct pso_pointer frame_pointer, - struct pso_pointer env ); +struct pso_pointer read( struct pso_pointer frame_pointer ); #endif diff --git a/src/c/memory/destroy.c b/src/c/memory/destroy.c index 41adcb6..9879f6b 100644 --- a/src/c/memory/destroy.c +++ b/src/c/memory/destroy.c @@ -44,15 +44,15 @@ struct pso_pointer destroy( struct pso_pointer p ) { switch ( get_tag_value( p ) ) { case CONSTV: - destroy_cons( f, nil ); + destroy_cons( f ); break; case EXCEPTIONTV: - destroy_exception( f, nil ); + destroy_exception( f ); break; case KEYTV: case STRINGTV: case SYMBOLTV: - destroy_string( f, nil ); + destroy_string( f ); break; case STACKTV: // destroy_stack_frame( f, nil ); diff --git a/src/c/memory/memory.c b/src/c/memory/memory.c index 6e7e5af..adbf827 100644 --- a/src/c/memory/memory.c +++ b/src/c/memory/memory.c @@ -58,9 +58,9 @@ struct pso_pointer initialise_memory( uint32_t node ) { struct pso_pointer result = nil; if ( memory_initialised ) { result = - make_exception( c_string_to_lisp_string - ( L"Attenpt to reinitialise memory." ), nil, nil, - nil ); + make_exception( make_frame( 1, nil, c_string_to_lisp_string + ( nil, + L"Attenpt to reinitialise memory." ) ) ); } else { for ( uint8_t i = 0; i <= MAX_SIZE_CLASS; i++ ) { freelists[i] = nil; @@ -82,18 +82,18 @@ struct pso_pointer pop_freelist( uint8_t size_class ) { struct pso_pointer result = t; if ( size_class <= MAX_SIZE_CLASS ) { - if ( nilp( freelists[size_class] ) ) { + if ( c_nilp( freelists[size_class] ) ) { result = allocate_page( size_class ); } - if ( nilp( result ) ) { + if ( c_nilp( result ) ) { fputws( L"FATAL: Page space exhausted\n", stderr ); exit( 1 ); // TODO: we don't want to do this! Somehow, we need to // recover a workable environment, ideally by throwing a pre-made // exception. } - if ( !exceptionp( result ) && !nilp( result ) ) { + if ( !exceptionp( result ) && !c_nilp( result ) ) { pthread_mutex_lock( &freelists_mutices[size_class] ); result = freelists[size_class]; struct pso2 *object = pointer_to_object( result ); diff --git a/src/c/memory/node.c b/src/c/memory/node.c index 083536e..42ff995 100644 --- a/src/c/memory/node.c +++ b/src/c/memory/node.c @@ -16,12 +16,15 @@ #include "memory/memory.h" #include "memory/pointer.h" +#include "memory/pso.h" #include "memory/tags.h" +#include "payloads/exception.h" + #include "ops/eq.h" +#include "ops/stack_ops.h" #include "ops/string_ops.h" #include "ops/truth.h" -#include "payloads/exception.h" /** * @brief Flag to prevent the node being initialised more than once. @@ -56,9 +59,9 @@ struct pso_pointer t = ( struct pso_pointer ) { 0, 0, 4 }; */ struct pso_pointer in_debugging_mode = #ifdef DEBUG - ( struct pso_pointer ) { 0, 0, 4 }; +( struct pso_pointer ) { 0, 0, 4 }; #else - ( struct pso_pointer ) { 0, 0, 0 }; +( struct pso_pointer ) { 0, 0, 0 }; #endif /** @@ -77,18 +80,22 @@ struct pso_pointer initialise_node( uint32_t index ) { node_index = index; struct pso_pointer result = initialise_environment( index ); + struct pso_pointer base_of_stack = make_frame( 0, nil ); if ( !c_nilp( result ) && !exceptionp( result ) ) { - node_initialised = true; + node_initialised = true; if ( initialise_io( ) == 0 ) { - result = initialise_default_streams( result ); + result = initialise_default_streams( base_of_stack, result ); } else { result = - make_exception( make_frame(1, nil, - c_string_to_lisp_string( nil, L"Failed to initialise default streams" ))); + make_exception( make_frame( 1, base_of_stack, + c_string_to_lisp_string + ( base_of_stack, + L"Failed to initialise default streams" ) ) ); } } + dec_ref( base_of_stack ); + return result; } - diff --git a/src/c/memory/page.c b/src/c/memory/page.c index 9857a1d..580f100 100644 --- a/src/c/memory/page.c +++ b/src/c/memory/page.c @@ -286,7 +286,8 @@ struct pso_pointer initialise_page( union page *page_addr, uint16_t page_index, result = nil; } - debug_print( nilp( result ) ? L"fail.\n" : L"success.\n", DEBUG_ALLOC, 0 ); + debug_print( c_nilp( result ) ? L"fail.\n" : L"success.\n", DEBUG_ALLOC, + 0 ); return result; } diff --git a/src/c/memory/pso.c b/src/c/memory/pso.c index e0c4272..16e60f9 100644 --- a/src/c/memory/pso.c +++ b/src/c/memory/pso.c @@ -64,7 +64,7 @@ struct pso_pointer allocate( struct pso_pointer frame_pointer, char *tag, #endif struct pso_pointer result = pop_freelist( size_class ); - struct pso4* frame = pointer_to_pso4(frame_pointer); + struct pso4 *frame = pointer_to_pso4( frame_pointer ); if ( !c_nilp( result ) ) { strncpy( ( char * ) ( pointer_to_object( result )->header.tag. @@ -72,8 +72,8 @@ struct pso_pointer allocate( struct pso_pointer frame_pointer, char *tag, debug_printf( DEBUG_ALLOC, 0, L"at page %d, offset %d... ", result.page, result.offset ); - if ( stackp(frame_pointer)) { - struct pso_pointer locals = make_cons( result, + if ( stackp( frame_pointer ) ) { + struct pso_pointer locals = make_cons( frame_pointer, result, frame->payload. stack_frame.locals ); frame->payload.stack_frame.locals = locals; diff --git a/src/c/memory/tags.c b/src/c/memory/tags.c index 721ba1e..635f19c 100644 --- a/src/c/memory/tags.c +++ b/src/c/memory/tags.c @@ -31,13 +31,15 @@ uint32_t get_tag_value( struct pso_pointer p ) { * * @param p must be a struct pso_pointer, indicating the appropriate object. */ -struct pso_pointer get_tag_string( struct pso_pointer p ) { +struct pso_pointer get_tag_string( struct pso_pointer frame_pointer, + struct pso_pointer p ) { struct pso_pointer result = nil; struct pso2 *object = pointer_to_object( p ); for ( int i = 2 - 1; i >= 0; i-- ) { result = - make_string( ( char32_t ) ( object->header.tag.bytes.mnemonic[i] ), + make_string( frame_pointer, + ( char32_t ) ( object->header.tag.bytes.mnemonic[i] ), result ); } diff --git a/src/c/memory/tags.h b/src/c/memory/tags.h index afea5f5..422c1dd 100644 --- a/src/c/memory/tags.h +++ b/src/c/memory/tags.h @@ -87,7 +87,8 @@ // #define get_tag_value(p)((pointer_to_object(p)->header.tag.value) & 0xffffff) uint32_t get_tag_value( struct pso_pointer p ); -struct pso_pointer get_tag_string( struct pso_pointer p ); +struct pso_pointer get_tag_string( struct pso_pointer frame_pointer, + struct pso_pointer p ); /** * @brief check that the tag of the object indicated by this poiner has this diff --git a/src/c/ops/assoc.c b/src/c/ops/assoc.c index e9bc4cf..f77cbb8 100644 --- a/src/c/ops/assoc.c +++ b/src/c/ops/assoc.c @@ -101,13 +101,15 @@ struct pso_pointer assoc( #ifndef MANAGED_POINTER_ONLY struct pso4 *frame, #endif - struct pso_pointer frame_pointer) { + struct pso_pointer frame_pointer ) { #ifdef MANAGED_POINTER_ONLY struct pso4 *frame = pointer_to_pso4( frame_pointer ); #endif struct pso_pointer key = fetch_arg( frame, 0 ); struct pso_pointer store = or( make_frame( 2, frame_pointer, - fetch_arg( frame, 1 ), frame->payload.stack_frame.env)); + fetch_arg( frame, 1 ), + frame->payload. + stack_frame.env ) ); return c_assoc( key, store ); } @@ -121,13 +123,15 @@ struct pso_pointer interned( #ifndef MANAGED_POINTER_ONLY struct pso4 *frame, #endif - struct pso_pointer frame_pointer) { + struct pso_pointer frame_pointer ) { #ifdef MANAGED_POINTER_ONLY struct pso4 *frame = pointer_to_pso4( frame_pointer ); #endif struct pso_pointer key = fetch_arg( frame, 0 ); struct pso_pointer store = or( make_frame( 2, frame_pointer, - fetch_arg( frame, 1 ), frame->payload.stack_frame.env)); + fetch_arg( frame, 1 ), + frame->payload. + stack_frame.env ) ); return c_interned( key, store ); } @@ -141,13 +145,15 @@ struct pso_pointer internedp( #ifndef MANAGED_POINTER_ONLY struct pso4 *frame, #endif - struct pso_pointer frame_pointer) { + struct pso_pointer frame_pointer ) { #ifdef MANAGED_POINTER_ONLY struct pso4 *frame = pointer_to_pso4( frame_pointer ); #endif struct pso_pointer key = fetch_arg( frame, 0 ); struct pso_pointer store = or( make_frame( 2, frame_pointer, - fetch_arg( frame, 1 ), frame->payload.stack_frame.env)); + fetch_arg( frame, 1 ), + frame->payload. + stack_frame.env ) ); return c_internedp( key, store ) ? t : nil; } diff --git a/src/c/ops/bind.c b/src/c/ops/bind.c index 4c552ed..2b6f447 100644 --- a/src/c/ops/bind.c +++ b/src/c/ops/bind.c @@ -22,19 +22,16 @@ #include "payloads/function.h" #include "payloads/stack.h" -struct pso_pointer bind( -#ifndef MANAGED_POINTER_ONLY - struct pso4 *frame, -#endif - struct pso_pointer frame_pointer) { -#ifdef MANAGED_POINTER_ONLY +/** + * (bind key value store) + */ +struct pso_pointer lisp_bind( struct pso_pointer frame_pointer ) { struct pso4 *frame = pointer_to_pso4( frame_pointer ); -#endif struct pso_pointer key = fetch_arg( frame, 0 ); struct pso_pointer value = fetch_arg( frame, 1 ); struct pso_pointer store = fetch_arg( frame, 2 ); - struct pso_pointer binding = cons( make_frame( 2, frame_pointer, key, value)); + struct pso_pointer binding = + cons( make_frame( 2, frame_pointer, key, value ) ); - return cons( make_frame( 2, frame_pointer, binding, store)); + return cons( make_frame( 2, frame_pointer, binding, store ) ); } - diff --git a/src/c/ops/bind.h b/src/c/ops/bind.h index 2682fe8..79cb753 100644 --- a/src/c/ops/bind.h +++ b/src/c/ops/bind.h @@ -16,15 +16,7 @@ #include "memory/pointer.h" #include "memory/pso4.h" -struct pso_pointer c_bind( struct pso_pointer key, - struct pso_pointer value, - struct pso_pointer store ); -struct pso_pointer lisp_bind( -#ifndef MANAGED_POINTER_ONLY - struct pso4 *frame, -#endif - struct pso_pointer frame_pointer, - struct pso_pointer env ); +struct pso_pointer lisp_bind( struct pso_pointer frame_pointer ); #endif diff --git a/src/c/ops/eq.h b/src/c/ops/eq.h index 98e8ddc..0f3e10a 100644 --- a/src/c/ops/eq.h +++ b/src/c/ops/eq.h @@ -32,7 +32,7 @@ struct pso_pointer equal( #ifndef MANAGED_POINTER_ONLY struct pso4 *frame, #endif - struct pso_pointer frame_pointer); + struct pso_pointer frame_pointer ); #endif diff --git a/src/c/ops/eval_apply.c b/src/c/ops/eval_apply.c index 284a33b..c95513c 100644 --- a/src/c/ops/eval_apply.c +++ b/src/c/ops/eval_apply.c @@ -31,14 +31,7 @@ * * * (apply fn args) */ -struct pso_pointer apply( -#ifndef MANAGED_POINTER_ONLY - struct pso4 *frame, -#endif - struct pso_pointer frame_pointer) { -#ifdef MANAGED_POINTER_ONLY - struct pso4 *frame = pointer_to_pso4( frame_pointer ); -#endif +struct pso_pointer apply( struct pso_pointer frame_pointer ) { // TODO. @@ -49,16 +42,11 @@ struct pso_pointer apply( * * * (eval form) */ -struct pso_pointer eval( -#ifndef MANAGED_POINTER_ONLY - struct pso4 *frame, -#endif - struct pso_pointer frame_pointer) { -#ifdef MANAGED_POINTER_ONLY +struct pso_pointer eval( struct pso_pointer frame_pointer ) { struct pso4 *frame = pointer_to_pso4( frame_pointer ); -#endif + struct pso_pointer arg = fetch_arg( frame, 0 ); - struct pso_pointer result = nil; + struct pso_pointer result = nil; switch ( get_tag_value( arg ) ) { // case CONSTV: @@ -68,10 +56,10 @@ struct pso_pointer eval( case KEYTV: case STRINGTV: // self evaluating - result = nil; + result = nil; break; case SYMBOLTV: - arg = c_assoc( arg, fetch_env(frame_pointer) ); + arg = c_assoc( arg, fetch_env( frame_pointer ) ); break; // case LAMBDATV: // result = eval_lambda( frame, frame_pointer, env); @@ -84,22 +72,22 @@ struct pso_pointer eval( // break; default: arg = - make_exception( - make_frame(1, frame_pointer, - make_cons( frame_pointer, - c_string_to_lisp_string( frame_pointer, - L"Can't yet evaluate things of this type: " ), - arg ), - make_cons( frame_pointer, - make_cons - ( frame_pointer, - c_string_to_lisp_keyword - ( frame_pointer, - L"tag" ), - get_tag_string - ( arg ) ), - nil ), - nil )); + make_exception( make_frame( 1, frame_pointer, + make_cons( frame_pointer, + c_string_to_lisp_string + ( frame_pointer, + L"Can't yet evaluate things of this type: " ), + arg ), + make_cons( frame_pointer, + make_cons + ( frame_pointer, + c_string_to_lisp_keyword + ( frame_pointer, + L"tag" ), + get_tag_string + ( frame_pointer, + arg ) ), nil ), + nil ) ); } if ( exceptionp( arg ) ) { @@ -108,7 +96,7 @@ struct pso_pointer eval( EXCEPTIONTV ); if ( c_nilp( x->payload.exception.stack ) ) { - + } } diff --git a/src/c/ops/eval_apply.h b/src/c/ops/eval_apply.h index 18b0f01..2f326fa 100644 --- a/src/c/ops/eval_apply.h +++ b/src/c/ops/eval_apply.h @@ -17,20 +17,10 @@ #include "memory/pso4.h" #include "payloads/function.h" -struct pso_pointer apply( -#ifndef MANAGED_POINTER_ONLY - struct pso4 *frame, -#endif - struct pso_pointer frame_pointer, - struct pso_pointer env ); +struct pso_pointer apply( struct pso_pointer frame_pointer ); -struct pso_pointer eval( -#ifndef MANAGED_POINTER_ONLY - struct pso4 *frame, -#endif - struct pso_pointer frame_pointer, - struct pso_pointer env ); +struct pso_pointer eval( struct pso_pointer frame_pointer ); #endif diff --git a/src/c/ops/list_ops.c b/src/c/ops/list_ops.c index e253b44..3baeabf 100644 --- a/src/c/ops/list_ops.c +++ b/src/c/ops/list_ops.c @@ -17,16 +17,16 @@ #include "ops/truth.h" -struct pso_pointer length( struct pso_pointer frame_pointer) { - struct pso4* frame = pointer_to_pso4(frame_pointer); - - struct pso_pointer list = fetch_arg( frame, 0); - int count = 0; +struct pso_pointer length( struct pso_pointer frame_pointer ) { + struct pso4 *frame = pointer_to_pso4( frame_pointer ); - for ( struct pso_pointer cursor = list; !c_nilp( cursor); - cursor = cdr( make_frame( 1, frame_pointer, list))) { - count++; - } + struct pso_pointer list = fetch_arg( frame, 0 ); + int count = 0; - return make_integer( frame_pointer, count); + for ( struct pso_pointer cursor = list; !c_nilp( cursor ); + cursor = cdr( make_frame( 1, frame_pointer, list ) ) ) { + count++; + } + + return make_integer( frame_pointer, count ); } diff --git a/src/c/ops/list_ops.h b/src/c/ops/list_ops.h index 3b1fcb1..0dd74d1 100644 --- a/src/c/ops/list_ops.h +++ b/src/c/ops/list_ops.h @@ -17,6 +17,6 @@ #include "payloads/function.h" -struct pso_pointer length( struct pso_pointer frame_pointer); +struct pso_pointer length( struct pso_pointer frame_pointer ); #endif diff --git a/src/c/ops/repl.c b/src/c/ops/repl.c index 151b5b7..e2f46fe 100644 --- a/src/c/ops/repl.c +++ b/src/c/ops/repl.c @@ -33,6 +33,7 @@ #include "ops/assoc.h" #include "ops/eval_apply.h" +#include "ops/stack_ops.h" #include "ops/truth.h" /** @@ -47,14 +48,14 @@ void int_handler( int dummy ) { /** * Very simple read/eval/print loop for bootstrapping. */ -void c_repl( bool show_prompt ) { +void repl( struct pso_pointer frame_pointer ) { + struct pso4 *frame = pointer_to_pso4( frame_pointer ); + bool show_prompt = c_truep( fetch_arg( frame, 0 ) ); // todo: issue #21: must have stack frame passed in. signal( SIGINT, int_handler ); debug_print( L"Entered repl\n", DEBUG_REPL, 0 ); - // TODO: NULL is not OK here, but will do until we have a REPL in Lisp. - struct pso_pointer env = - consp( oblist ) ? oblist : make_cons( nil, oblist, nil ); + struct pso_pointer env = fetch_env( frame_pointer ); struct pso_pointer input_stream = c_assoc( lisp_io_in, env ); struct pso_pointer output_stream = c_assoc( lisp_io_out, env ); @@ -72,32 +73,28 @@ void c_repl( bool show_prompt ) { while ( readp( input_stream ) && !url_feof( stream_get_url_file( input_stream ) ) ) { if ( show_prompt ) - c_princ( c_assoc( lisp_io_prompt, env ), output_stream ); + princ( make_frame( 2, frame_pointer, + c_assoc( lisp_io_prompt, env ), + output_stream ) ); - /* bottom of stack */ - struct pso_pointer frame_pointer = make_frame( 1, nil, input_stream ); + /* the reason for initialising a new stack for each REPL input is to + * be sure the old stack is fully torn down and reclaimed. Once I'm + * confident of that, TODO: do not start a new stack base each time! + */ + struct pso_pointer base_of_stack = + inc_ref( make_frame_with_env( 0, nil, + consp( oblist ) ? oblist : + make_cons( nil, oblist, nil ) ) ); - if ( c_nilp( frame_pointer ) ) - break; - struct pso_pointer input = read( -#ifndef MANAGED_POINTER_ONLY - pointer_to_pso4( frame_pointer ), -#endif - frame_pointer, env ); + print( make_frame + ( 2, base_of_stack, + eval( make_frame + ( 1, base_of_stack, + read( make_frame + ( 1, base_of_stack, input_stream ) ) ) ), + output_stream ) ); - frame_pointer = make_frame( 1, frame_pointer, input ); - if ( c_nilp( frame_pointer ) ) - break; - - struct pso_pointer result = eval( -#ifndef MANAGED_POINTER_ONLY - pointer_to_pso4( frame_pointer ), -#endif - frame_pointer, oblist ); - - c_print( result, output_stream ); - - dec_ref( frame_pointer ); + dec_ref( base_of_stack ); } debug_print( L"Leaving repl\n", DEBUG_REPL, 0 ); diff --git a/src/c/ops/repl.h b/src/c/ops/repl.h index 0dc862f..b7ab6de 100644 --- a/src/c/ops/repl.h +++ b/src/c/ops/repl.h @@ -13,8 +13,7 @@ #define SRC_C_OPS_REPL_H_ - // todo: issue #21: must have stack frame passed in. -void c_repl( ); +void repl( struct pso_pointer frame_pointer ); #endif /* SRC_C_OPS_REPL_H_ */ diff --git a/src/c/ops/reverse.c b/src/c/ops/reverse.c index 65be27a..9bfe934 100644 --- a/src/c/ops/reverse.c +++ b/src/c/ops/reverse.c @@ -35,7 +35,8 @@ * @return a sequence like the `sequence` passed, but reversed; or `nil` if * the argument was not a sequence. */ -struct pso_pointer c_reverse( struct pso_pointer frame_pointer, struct pso_pointer sequence ) { +struct pso_pointer c_reverse( struct pso_pointer frame_pointer, + struct pso_pointer sequence ) { // todo: issue #21: must have stack frame passed in. struct pso_pointer result = nil; @@ -49,27 +50,31 @@ struct pso_pointer c_reverse( struct pso_pointer frame_pointer, struct pso_point case KEYTV: // TODO: should you be able to reverse keywords and symbols? result = - make_string_like_thing( frame_pointer, object->payload.string.character, + make_string_like_thing( frame_pointer, + object->payload.string.character, result, KEYTAG ); break; case STRINGTV: result = - make_string_like_thing( frame_pointer, object->payload.string.character, + make_string_like_thing( frame_pointer, + object->payload.string.character, result, STRINGTAG ); break; case SYMBOLTV: // TODO: should you be able to reverse keywords and symbols? result = - make_string_like_thing( frame_pointer, object->payload.string.character, + make_string_like_thing( frame_pointer, + object->payload.string.character, result, SYMBOLTAG ); break; default: result = - make_exception( make_frame( 1, frame_pointer, - make_cons( frame_pointer, - c_string_to_lisp_string - ( frame_pointer, L"Invalid object in sequence" ), - cursor ) )); + make_exception( make_frame( 1, frame_pointer, + make_cons( frame_pointer, + c_string_to_lisp_string + ( frame_pointer, + L"Invalid object in sequence" ), + cursor ) ) ); goto exit; break; } diff --git a/src/c/ops/stack_ops.c b/src/c/ops/stack_ops.c index ccadf42..bdf5e15 100644 --- a/src/c/ops/stack_ops.c +++ b/src/c/ops/stack_ops.c @@ -50,8 +50,7 @@ struct pso_pointer fetch_arg( struct pso4 *frame, unsigned int index ) { * * @param frame_pointer a pointer to a stack frame. */ -struct pso_pointer fetch_env( struct pso_pointer frame_pointer) { - return stackp(frame_pointer) ? - pointer_to_pso4(frame_pointer)->payload.stack_frame.env : - nil; +struct pso_pointer fetch_env( struct pso_pointer frame_pointer ) { + return stackp( frame_pointer ) ? + pointer_to_pso4( frame_pointer )->payload.stack_frame.env : nil; } diff --git a/src/c/ops/stack_ops.h b/src/c/ops/stack_ops.h index 3601724..fb1c4cc 100644 --- a/src/c/ops/stack_ops.h +++ b/src/c/ops/stack_ops.h @@ -27,6 +27,6 @@ extern uint32_t stack_limit; struct pso_pointer fetch_arg( struct pso4 *frame, unsigned int index ); -struct pso_pointer fetch_env( struct pso_pointer frame_pointer); +struct pso_pointer fetch_env( struct pso_pointer frame_pointer ); #endif diff --git a/src/c/ops/truth.c b/src/c/ops/truth.c index d9790e0..4b7b9d8 100644 --- a/src/c/ops/truth.c +++ b/src/c/ops/truth.c @@ -27,7 +27,7 @@ * @return true if `p` points to `nil`. * @return false otherwise. */ -bool c_nilp(struct pso_pointer p) { +bool c_nilp( struct pso_pointer p ) { return ( p.page == 0 && p.offset == 0 ); } @@ -80,7 +80,7 @@ struct pso_pointer truep( struct pso_pointer frame_pointer ) { * @param frame_pointer A pointer to the current stack frame; * @return `t` if the first argument in this frame is not `nil`, else `t`. */ -struct pso_pointer not( struct pso_pointer frame_pointer) { +struct pso_pointer not( struct pso_pointer frame_pointer ) { struct pso4 *frame = pointer_to_pso4( frame_pointer ); return ( !c_nilp( fetch_arg( frame, 0 ) ) ? t : nil ); @@ -91,18 +91,19 @@ struct pso_pointer not( struct pso_pointer frame_pointer) { * * @return `nil` if any `arg` is `nil`, else `t`. */ -struct pso_pointer and( struct pso_pointer frame_pointer) { - struct pso4* frame = pointer_to_pso4( frame_pointer); - struct pso_pointer result = t; - - for (int arg = 0; c_truep(result) && arg < frame->payload.stack_frame.args; arg++) { - if (c_nilp(fetch_arg(frame, arg))) { - result = nil; - break; - } - } - - return result; +struct pso_pointer and( struct pso_pointer frame_pointer ) { + struct pso4 *frame = pointer_to_pso4( frame_pointer ); + struct pso_pointer result = t; + + for ( int arg = 0; + c_truep( result ) && arg < frame->payload.stack_frame.args; arg++ ) { + if ( c_nilp( fetch_arg( frame, arg ) ) ) { + result = nil; + break; + } + } + + return result; } @@ -111,16 +112,17 @@ struct pso_pointer and( struct pso_pointer frame_pointer) { * * @return `t` if any `arg` is non-nil, else `nil`. */ -struct pso_pointer or( struct pso_pointer frame_pointer) { - struct pso4* frame = pointer_to_pso4( frame_pointer); - struct pso_pointer result = nil; - - for (int arg = 0; c_truep(result) && arg < frame->payload.stack_frame.args; arg++) { - if (!c_nilp(fetch_arg(frame, arg))) { - result = t; - break; - } - } - - return result; +struct pso_pointer or( struct pso_pointer frame_pointer ) { + struct pso4 *frame = pointer_to_pso4( frame_pointer ); + struct pso_pointer result = nil; + + for ( int arg = 0; + c_truep( result ) && arg < frame->payload.stack_frame.args; arg++ ) { + if ( !c_nilp( fetch_arg( frame, arg ) ) ) { + result = t; + break; + } + } + + return result; } diff --git a/src/c/ops/truth.h b/src/c/ops/truth.h index 38de633..e775ff2 100644 --- a/src/c/ops/truth.h +++ b/src/c/ops/truth.h @@ -25,7 +25,7 @@ struct pso_pointer and( struct pso_pointer frame_pointer ); struct pso_pointer or( struct pso_pointer frame_pointer ); -bool c_nilp(struct pso_pointer p); -bool c_truep(struct pso_pointer p); +bool c_nilp( struct pso_pointer p ); +bool c_truep( struct pso_pointer p ); #endif diff --git a/src/c/payloads/character.h b/src/c/payloads/character.h index 2862bfe..6995631 100644 --- a/src/c/payloads/character.h +++ b/src/c/payloads/character.h @@ -38,5 +38,6 @@ struct character_payload { char32_t character; }; -struct pso_pointer make_character( struct pso_pointer frame_pointer, wint_t c ); +struct pso_pointer make_character( struct pso_pointer frame_pointer, + wint_t c ); #endif diff --git a/src/c/payloads/cons.c b/src/c/payloads/cons.c index 39b10a4..dccdf13 100644 --- a/src/c/payloads/cons.c +++ b/src/c/payloads/cons.c @@ -31,19 +31,21 @@ * @param frame_pointer a pointer to a stack frame. * @return struct pso_pointer a pointer to the newly allocated cons cell. */ -struct pso_pointer cons(struct pso_pointer frame_pointer) { - struct pso4 *frame = pointer_to_pso4(frame_pointer); - struct pso_pointer result = allocate(frame_pointer, CONSTAG, 2); +struct pso_pointer cons( struct pso_pointer frame_pointer ) { + struct pso4 *frame = pointer_to_pso4( frame_pointer ); + struct pso_pointer result = allocate( frame_pointer, CONSTAG, 2 ); - struct pso2 *object = pointer_to_object(result); - object->payload.cons.car = inc_ref(fetch_arg(frame, 0)); - object->payload.cons.cdr = inc_ref(fetch_arg(frame, 1)); + struct pso2 *object = pointer_to_object( result ); + object->payload.cons.car = inc_ref( fetch_arg( frame, 0 ) ); + object->payload.cons.cdr = inc_ref( fetch_arg( frame, 1 ) ); - return result; + return result; } -struct pso_pointer make_cons(struct pso_pointer frame_pointer, struct pso_pointer car, struct pso_pointer cdr){ - return cons( make_frame(2, frame_pointer, car, cdr)); +struct pso_pointer make_cons( struct pso_pointer frame_pointer, + struct pso_pointer car, + struct pso_pointer cdr ) { + return cons( make_frame( 2, frame_pointer, car, cdr ) ); } /** @@ -55,26 +57,32 @@ struct pso_pointer make_cons(struct pso_pointer frame_pointer, struct pso_pointe * @return the car of the indicated cell. * @exception if the pointer does not indicate a cons cell. */ -struct pso_pointer car(struct pso_pointer frame_pointer) { - struct pso_pointer result = nil; - struct pso4 *frame = pointer_to_pso4(frame_pointer); - struct pso_pointer cons = fetch_arg(frame, 0); - struct pso2 *object = pointer_to_object(cons); +struct pso_pointer car( struct pso_pointer frame_pointer ) { + struct pso_pointer result = nil; + struct pso4 *frame = pointer_to_pso4( frame_pointer ); + struct pso_pointer cons = fetch_arg( frame, 0 ); + struct pso2 *object = pointer_to_object( cons ); - if (consp(cons)) { - result = object->payload.cons.car; - } else { - result = make_exception(make_frame( - 2, frame_pointer, - c_string_to_lisp_string(frame_pointer, L"Invalid type for car"), - make_cons(frame_pointer, make_cons( - frame_pointer, - c_string_to_lisp_keyword(frame_pointer, L"type"), - get_tag_string(cons)), - nil))); - } + if ( consp( cons ) ) { + result = object->payload.cons.car; + } else { + result = make_exception( make_frame( 2, frame_pointer, + c_string_to_lisp_string + ( frame_pointer, + L"Invalid type for car" ), + make_cons( frame_pointer, + make_cons + ( frame_pointer, + c_string_to_lisp_keyword + ( frame_pointer, + L"type" ), + get_tag_string + ( frame_pointer, + cons ) ), + nil ) ) ); + } - return result; + return result; } /** @@ -86,36 +94,40 @@ struct pso_pointer car(struct pso_pointer frame_pointer) { * @return the cdr of the indicated cell. * @exception if the pointer does not indicate a cons cell. */ -struct pso_pointer cdr(struct pso_pointer frame_pointer) { - struct pso_pointer result = nil; - struct pso4 *frame = pointer_to_pso4(frame_pointer); - struct pso_pointer cons = fetch_arg(frame, 0); - struct pso2 *object = pointer_to_object(cons); +struct pso_pointer cdr( struct pso_pointer frame_pointer ) { + struct pso_pointer result = nil; + struct pso4 *frame = pointer_to_pso4( frame_pointer ); + struct pso_pointer cons = fetch_arg( frame, 0 ); + struct pso2 *object = pointer_to_object( cons ); - switch (get_tag_value(cons)) { - case CONSTV: - result = object->payload.cons.cdr; - break; - case KEYTV: - case STRINGTV: - case SYMBOLTV: - result = object->payload.string.cdr; - break; - default: - struct pso_pointer type_binding = - make_cons(frame_pointer, - c_string_to_lisp_keyword(frame_pointer, L"type"), - get_tag_string(cons)); - result = make_exception(make_frame( - 2, frame_pointer, - c_string_to_lisp_string(frame_pointer, L"Invalid type for cdr"), - make_cons(frame_pointer, - type_binding, - nil))); - break; - } + switch ( get_tag_value( cons ) ) { + case CONSTV: + result = object->payload.cons.cdr; + break; + case KEYTV: + case STRINGTV: + case SYMBOLTV: + result = object->payload.string.cdr; + break; + default: + result = make_exception( make_frame( 2, frame_pointer, + c_string_to_lisp_string + ( frame_pointer, + L"Invalid type for cdr" ), + make_cons( frame_pointer, + make_cons + ( frame_pointer, + c_string_to_lisp_keyword + ( frame_pointer, + L"type" ), + get_tag_string + ( frame_pointer, + cons ) ), + nil ) ) ); + break; + } - return result; + return result; } /** @@ -125,15 +137,15 @@ struct pso_pointer cdr(struct pso_pointer frame_pointer) { * Lisp calling conventions; one expected arg, the pointer to the cell to * be destroyed. */ -struct pso_pointer destroy_cons(struct pso_pointer fp) { - if (stackp(fp)) { - struct pso4 *frame = pointer_to_pso4(fp); - struct pso_pointer p = frame->payload.stack_frame.arg[0]; +struct pso_pointer destroy_cons( struct pso_pointer fp ) { + if ( stackp( fp ) ) { + struct pso4 *frame = pointer_to_pso4( fp ); + struct pso_pointer p = frame->payload.stack_frame.arg[0]; - if (check_tag(p, CONSTV)) { - struct pso2 *cons = pointer_to_object(p); - dec_ref(cons->payload.cons.car); - dec_ref(cons->payload.cons.cdr); - } - } + if ( check_tag( p, CONSTV ) ) { + struct pso2 *cons = pointer_to_object( p ); + dec_ref( cons->payload.cons.car ); + dec_ref( cons->payload.cons.cdr ); + } + } } diff --git a/src/c/payloads/cons.h b/src/c/payloads/cons.h index 540034c..fdbfc8f 100644 --- a/src/c/payloads/cons.h +++ b/src/c/payloads/cons.h @@ -33,11 +33,10 @@ struct pso_pointer cdr( struct pso_pointer frame_pointer ); struct pso_pointer cons( struct pso_pointer frame_pointer ); -struct pso_pointer destroy_cons( struct pso_pointer frame_pointer); +struct pso_pointer destroy_cons( struct pso_pointer frame_pointer ); -struct pso_pointer make_cons(struct pso_pointer frame_pointer, - struct pso_pointer car, - struct pso_pointer cdr); +struct pso_pointer make_cons( struct pso_pointer frame_pointer, + struct pso_pointer car, struct pso_pointer cdr ); /** * macro short-cuts for make_cons. diff --git a/src/c/payloads/exception.c b/src/c/payloads/exception.c index e184354..aa9f33c 100644 --- a/src/c/payloads/exception.c +++ b/src/c/payloads/exception.c @@ -47,21 +47,21 @@ b * @param meta metadata for this exception. Must be an assoc list, hashtable, * or `nil` * @param cause the exception that caused this exception to be `thrown`. */ -struct pso_pointer make_exception( struct pso_pointer frame_pointer) { - struct pso4* frame = pointer_to_pso4( frame_pointer); - struct pso_pointer message = fetch_arg(frame, 0); - struct pso_pointer previous = frame->payload.stack_frame.previous; - struct pso_pointer meta = fetch_arg( frame, 1); - struct pso_pointer cause = fetch_arg( frame, 2); +struct pso_pointer make_exception( struct pso_pointer frame_pointer ) { + struct pso4 *frame = pointer_to_pso4( frame_pointer ); + struct pso_pointer message = fetch_arg( frame, 0 ); + struct pso_pointer previous = frame->payload.stack_frame.previous; + struct pso_pointer meta = fetch_arg( frame, 1 ); + struct pso_pointer cause = fetch_arg( frame, 2 ); - struct pso_pointer result = - allocate( frame_pointer, EXCEPTIONTAG, 3 ); + struct pso_pointer result = allocate( frame_pointer, EXCEPTIONTAG, 3 ); if ( !c_nilp( result ) && !exceptionp( result ) ) { struct pso3 *object = ( struct pso3 * ) pointer_to_object( result ); object->payload.exception.message = message; - object->payload.exception.stack = stackp( frame_pointer ) ? frame_pointer : nil; + object->payload.exception.stack = + stackp( frame_pointer ) ? frame_pointer : nil; object->payload.exception.meta = ( consp( meta ) || hashtabp( meta ) ) ? meta : nil; object->payload.exception.cause = exceptionp( cause ) ? cause : nil; @@ -76,8 +76,7 @@ struct pso_pointer make_exception( struct pso_pointer frame_pointer) { * Lisp calling conventions; one expected arg, the pointer to the object to * be destroyed. */ -struct pso_pointer destroy_exception( struct pso_pointer fp, - struct pso_pointer env ) { +struct pso_pointer destroy_exception( struct pso_pointer fp ) { if ( stackp( fp ) ) { struct pso4 *frame = pointer_to_pso4( fp ); struct pso_pointer p = frame->payload.stack_frame.arg[0]; diff --git a/src/c/payloads/exception.h b/src/c/payloads/exception.h index 27e7e08..4bb088e 100644 --- a/src/c/payloads/exception.h +++ b/src/c/payloads/exception.h @@ -28,7 +28,6 @@ struct exception_payload { struct pso_pointer make_exception( struct pso_pointer frame_pointer ); -struct pso_pointer destroy_exception( struct pso_pointer fp, - struct pso_pointer env ); +struct pso_pointer destroy_exception( struct pso_pointer fp ); #endif diff --git a/src/c/payloads/integer.c b/src/c/payloads/integer.c index 032005d..8fe53d7 100644 --- a/src/c/payloads/integer.c +++ b/src/c/payloads/integer.c @@ -25,7 +25,8 @@ * @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 pso_pointer make_integer( struct pso_pointer frame_pointer, int64_t value ) { +struct pso_pointer make_integer( struct pso_pointer frame_pointer, + int64_t value ) { struct pso_pointer result = nil; debug_print( L"Entering make_integer\n", DEBUG_ALLOC, 0 ); diff --git a/src/c/payloads/integer.h b/src/c/payloads/integer.h index b537388..ea8464a 100644 --- a/src/c/payloads/integer.h +++ b/src/c/payloads/integer.h @@ -25,6 +25,7 @@ struct integer_payload { __int128_t value; }; -struct pso_pointer make_integer( struct pso_pointer frame_pointer, int64_t value ); +struct pso_pointer make_integer( struct pso_pointer frame_pointer, + int64_t value ); #endif diff --git a/src/c/payloads/psse_string.c b/src/c/payloads/psse_string.c index f1a1fb8..2206138 100644 --- a/src/c/payloads/psse_string.c +++ b/src/c/payloads/psse_string.c @@ -22,6 +22,8 @@ #include "payloads/cons.h" +#include "ops/stack_ops.h" + /** * @brief When an string is freed, its cdr pointer must be decremented. @@ -29,14 +31,10 @@ * Lisp calling conventions; one expected arg, the pointer to the object to * be destroyed. */ -struct pso_pointer destroy_string( struct pso_pointer fp, - struct pso_pointer env ) { - if ( stackp( fp ) ) { - struct pso4 *frame = pointer_to_pso4( fp ); - struct pso_pointer p = frame->payload.stack_frame.arg[0]; - - dec_ref( c_cdr( p ) ); - } +struct pso_pointer destroy_string( struct pso_pointer frame_pointer ) { + if ( stackp( frame_pointer ) ) { + dec_ref( c_cdr( fetch_arg( pointer_to_pso4( frame_pointer ), 0 ) ) ); + } return nil; } diff --git a/src/c/payloads/psse_string.h b/src/c/payloads/psse_string.h index 9b83d99..8c71039 100644 --- a/src/c/payloads/psse_string.h +++ b/src/c/payloads/psse_string.h @@ -33,7 +33,6 @@ struct string_payload { struct pso_pointer cdr; }; -struct pso_pointer destroy_string( struct pso_pointer fp, - struct pso_pointer env ); +struct pso_pointer destroy_string( struct pso_pointer fp ); #endif diff --git a/src/c/payloads/stack.c b/src/c/payloads/stack.c index 86c68b1..3a3fa70 100644 --- a/src/c/payloads/stack.c +++ b/src/c/payloads/stack.c @@ -43,9 +43,8 @@ struct pso_pointer make_frame( int arg_count, struct pso_pointer previous, va_start( args, previous ); struct pso4 *prev_frame = pointer_to_pso4( previous ); - struct pso_pointer new_pointer = - allocate( previous, STACKTAG, 4 ); - struct pso4* new_frame = pointer_to_pso4(new_pointer); + struct pso_pointer new_pointer = allocate( previous, STACKTAG, 4 ); + struct pso4 *new_frame = pointer_to_pso4( new_pointer ); #ifdef DEBUG debug_printf( DEBUG_ALLOC, 0, @@ -57,14 +56,16 @@ struct pso_pointer make_frame( int arg_count, struct pso_pointer previous, prev_frame->payload.stack_frame.previous = previous; if ( stackp( previous ) ) { - new_frame->payload.stack_frame.depth = prev_frame->payload.stack_frame.depth + 1; - new_frame->payload.stack_frame.env = prev_frame->payload.stack_frame.env; + new_frame->payload.stack_frame.depth = + prev_frame->payload.stack_frame.depth + 1; + new_frame->payload.stack_frame.env = + prev_frame->payload.stack_frame.env; } else { - new_frame->payload.stack_frame.depth = 0; + new_frame->payload.stack_frame.depth = 0; } debug_printf( DEBUG_ALLOC, 1, L"depth is %d...\n", - new_frame->payload.stack_frame.depth ); + new_frame->payload.stack_frame.depth ); int cursor = 0; new_frame->payload.stack_frame.args = arg_count; @@ -86,7 +87,7 @@ struct pso_pointer make_frame( int arg_count, struct pso_pointer previous, new_frame->payload.stack_frame.more = c_reverse( more_args ); } else { for ( ; cursor < args_in_frame; cursor++ ) { - new_frame->payload.stack_frame.arg[cursor] = nil; + new_frame->payload.stack_frame.arg[cursor] = nil; } } @@ -117,9 +118,8 @@ struct pso_pointer make_frame_with_env( int arg_count, va_start( args, env ); struct pso4 *prev_frame = pointer_to_pso4( previous ); - struct pso_pointer new_pointer = - allocate( previous, STACKTAG, 4 ); - struct pso4* new_frame = pointer_to_pso4(new_pointer); + struct pso_pointer new_pointer = allocate( previous, STACKTAG, 4 ); + struct pso4 *new_frame = pointer_to_pso4( new_pointer ); #ifdef DEBUG debug_printf( DEBUG_ALLOC, 0, @@ -131,14 +131,15 @@ struct pso_pointer make_frame_with_env( int arg_count, prev_frame->payload.stack_frame.previous = previous; if ( stackp( previous ) ) { - new_frame->payload.stack_frame.depth = prev_frame->payload.stack_frame.depth + 1; + new_frame->payload.stack_frame.depth = + prev_frame->payload.stack_frame.depth + 1; new_frame->payload.stack_frame.env = env; } else { - new_frame->payload.stack_frame.depth = 0; + new_frame->payload.stack_frame.depth = 0; } debug_printf( DEBUG_ALLOC, 1, L"depth is %d...\n", - new_frame->payload.stack_frame.depth ); + new_frame->payload.stack_frame.depth ); int cursor = 0; new_frame->payload.stack_frame.args = arg_count; @@ -160,7 +161,7 @@ struct pso_pointer make_frame_with_env( int arg_count, new_frame->payload.stack_frame.more = c_reverse( more_args ); } else { for ( ; cursor < args_in_frame; cursor++ ) { - new_frame->payload.stack_frame.arg[cursor] = nil; + new_frame->payload.stack_frame.arg[cursor] = nil; } } @@ -181,14 +182,19 @@ struct pso_pointer make_frame_with_env( int arg_count, * * @return pointer to the new frame. */ -struct pso_pointer make_frame_with_arglist_and_env( struct pso_pointer previous, struct pso_pointer argvalues, - struct pso_pointer env) { +struct pso_pointer make_frame_with_arglist_and_env( struct pso_pointer + previous, + struct pso_pointer + argvalues, + struct pso_pointer env ) { struct pso4 *prev_frame = pointer_to_pso4( previous ); - struct pso_pointer new_pointer = - allocate( previous, STACKTAG, 4 ); - struct pso4* new_frame = pointer_to_pso4(new_pointer); - struct pso_pointer arg_length = length(make_frame(1, previous, argvalues)); - int arg_count = integerp(arg_length) ? pointer_to_object(arg_length)->payload.integer.value : 0; + struct pso_pointer new_pointer = allocate( previous, STACKTAG, 4 ); + struct pso4 *new_frame = pointer_to_pso4( new_pointer ); + struct pso_pointer arg_length = + length( make_frame( 1, previous, argvalues ) ); + int arg_count = + integerp( arg_length ) ? pointer_to_object( arg_length )-> + payload.integer.value : 0; #ifdef DEBUG debug_printf( DEBUG_ALLOC, 0, L"\nAllocating stack frame with %d arguments at page %d, " @@ -199,28 +205,31 @@ struct pso_pointer make_frame_with_arglist_and_env( struct pso_pointer previous, prev_frame->payload.stack_frame.previous = previous; if ( stackp( previous ) ) { - new_frame->payload.stack_frame.depth = prev_frame->payload.stack_frame.depth + 1; - new_frame->payload.stack_frame.env = inc_ref( prev_frame->payload.stack_frame.env); + new_frame->payload.stack_frame.depth = + prev_frame->payload.stack_frame.depth + 1; + new_frame->payload.stack_frame.env = + inc_ref( prev_frame->payload.stack_frame.env ); } else { - new_frame->payload.stack_frame.depth = 0; + new_frame->payload.stack_frame.depth = 0; } debug_printf( DEBUG_ALLOC, 1, L"depth is %d...\n", - new_frame->payload.stack_frame.depth ); + new_frame->payload.stack_frame.depth ); int cursor = 0; new_frame->payload.stack_frame.args = arg_count; for ( ; cursor < arg_count && cursor < args_in_frame; cursor++ ) { - new_frame->payload.stack_frame.arg[cursor] = inc_ref( make_frame( 1, previous, car(argvalues))); - argvalues = cdr( make_frame( 1, previous, argvalues)); + new_frame->payload.stack_frame.arg[cursor] = + inc_ref( make_frame( 1, previous, car( argvalues ) ) ); + argvalues = cdr( make_frame( 1, previous, argvalues ) ); } if ( cursor < arg_count ) { - new_frame->payload.stack_frame.more = inc_ref( argvalues); + new_frame->payload.stack_frame.more = inc_ref( argvalues ); } else { for ( ; cursor < args_in_frame; cursor++ ) { - new_frame->payload.stack_frame.arg[cursor] = nil; + new_frame->payload.stack_frame.arg[cursor] = nil; } } @@ -239,8 +248,12 @@ struct pso_pointer make_frame_with_arglist_and_env( struct pso_pointer previous, * * @return pointer to the new frame. */ -struct pso_pointer make_frame_with_arglist( struct pso_pointer previous, struct pso_pointer argvalues) { - return make_frame_with_arglist_and_env( previous, argvalues, pointer_to_pso4(previous)->payload.stack_frame.env); +struct pso_pointer make_frame_with_arglist( struct pso_pointer previous, + struct pso_pointer argvalues ) { + return make_frame_with_arglist_and_env( previous, argvalues, + pointer_to_pso4 + ( previous )->payload.stack_frame. + env ); } diff --git a/src/c/payloads/stack.h b/src/c/payloads/stack.h index a9e1a0d..5fb9267 100644 --- a/src/c/payloads/stack.h +++ b/src/c/payloads/stack.h @@ -43,17 +43,19 @@ struct stack_frame_payload { struct pso_pointer make_frame( int arg_count, struct pso_pointer previous, ... ); - + struct pso_pointer make_frame_with_env( int arg_count, struct pso_pointer previous, struct pso_pointer env, ... ); - -struct pso_pointer make_frame_with_arglist_and_env( struct pso_pointer previous, - struct pso_pointer argvalues, - struct pso_pointer env); - -struct pso_pointer make_frame_with_arglist( struct pso_pointer previous, - struct pso_pointer argvalues); + +struct pso_pointer make_frame_with_arglist_and_env( struct pso_pointer + previous, + struct pso_pointer + argvalues, + struct pso_pointer env ); + +struct pso_pointer make_frame_with_arglist( struct pso_pointer previous, + struct pso_pointer argvalues ); struct pso_pointer destroy_stack_frame( struct pso_pointer fp, struct pso_pointer env ); diff --git a/src/c/psse.c b/src/c/psse.c index f1f4e13..65e9196 100644 --- a/src/c/psse.c +++ b/src/c/psse.c @@ -1,4 +1,3 @@ - /** * psse.c * @@ -120,7 +119,7 @@ int main( int argc, char *argv[] ) { debug_print_object( oblist, DEBUG_BOOTSTRAP, 0 ); debug_println( DEBUG_BOOTSTRAP ); - if ( nilp( oblist ) ) { + if ( c_nilp( oblist ) ) { fputs( "Failed to initialise node\n", stderr ); exit( 1 ); } @@ -134,7 +133,22 @@ int main( int argc, char *argv[] ) { stdout ); } - c_repl( show_prompt ); + struct pso_pointer bootstrap_stack = inc_ref( make_frame_with_env( 1, nil, + consp + ( oblist ) + ? oblist + : + make_cons + ( nil, + oblist, + nil ), + show_prompt + ? t : + nil ) ); + + repl( bootstrap_stack ); + + dec_ref( bootstrap_stack ); exit( 0 ); }