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

Mostly fixing and standardising documentation.

Browse source
This commit is contained in:
Simon Brooke 2019-01-20 19:44:56 +00:00
parent 0f8bc990f2
commit 22fa7314d6
24 changed files with 770 additions and 503 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

14
Doxyfile
View file

@ -135,7 +135,7 @@ ABBREVIATE_BRIEF = "The $name class" \
# description. # description.
# The default value is: NO. # The default value is: NO.
ALWAYS_DETAILED_SEC = NO ALWAYS_DETAILED_SEC = YES
# If the INLINE_INHERITED_MEMB tag is set to YES, doxygen will show all # If the INLINE_INHERITED_MEMB tag is set to YES, doxygen will show all
# inherited members of a class in the documentation of that class as if those # inherited members of a class in the documentation of that class as if those
@ -162,7 +162,7 @@ FULL_PATH_NAMES = YES
# will be relative from the directory where doxygen is started. # will be relative from the directory where doxygen is started.
# This tag requires that the tag FULL_PATH_NAMES is set to YES. # This tag requires that the tag FULL_PATH_NAMES is set to YES.
STRIP_FROM_PATH = STRIP_FROM_PATH = src/
# The STRIP_FROM_INC_PATH tag can be used to strip a user-defined part of the # The STRIP_FROM_INC_PATH tag can be used to strip a user-defined part of the
# path mentioned in the documentation of a class, which tells the reader which # path mentioned in the documentation of a class, which tells the reader which
@ -187,7 +187,7 @@ SHORT_NAMES = NO
# description.) # description.)
# The default value is: NO. # The default value is: NO.
JAVADOC_AUTOBRIEF = NO JAVADOC_AUTOBRIEF = YES
# If the QT_AUTOBRIEF tag is set to YES then doxygen will interpret the first # If the QT_AUTOBRIEF tag is set to YES then doxygen will interpret the first
# line (until the first dot) of a Qt-style comment as the brief description. If # line (until the first dot) of a Qt-style comment as the brief description. If
@ -397,7 +397,7 @@ INLINE_GROUPED_CLASSES = NO
# Man pages) or section (for LaTeX and RTF). # Man pages) or section (for LaTeX and RTF).
# The default value is: NO. # The default value is: NO.
INLINE_SIMPLE_STRUCTS = NO INLINE_SIMPLE_STRUCTS = YES
# When TYPEDEF_HIDES_STRUCT tag is enabled, a typedef of a struct, union, or # When TYPEDEF_HIDES_STRUCT tag is enabled, a typedef of a struct, union, or
# enum is documented as struct, union, or enum with the name of the typedef. So # enum is documented as struct, union, or enum with the name of the typedef. So
@ -578,7 +578,7 @@ SORT_MEMBER_DOCS = YES
# this will also influence the order of the classes in the class list. # this will also influence the order of the classes in the class list.
# The default value is: NO. # The default value is: NO.
SORT_BRIEF_DOCS = NO SORT_BRIEF_DOCS = YES
# If the SORT_MEMBERS_CTORS_1ST tag is set to YES then doxygen will sort the # If the SORT_MEMBERS_CTORS_1ST tag is set to YES then doxygen will sort the
# (brief and detailed) documentation of class members so that constructors and # (brief and detailed) documentation of class members so that constructors and
@ -790,7 +790,7 @@ WARN_LOGFILE = doxy.log
# spaces. See also FILE_PATTERNS and EXTENSION_MAPPING # spaces. See also FILE_PATTERNS and EXTENSION_MAPPING
# Note: If this tag is empty the current directory is searched. # Note: If this tag is empty the current directory is searched.
INPUT = src src/arith src/memory src/ops INPUT = src
# This tag can be used to specify the character encoding of the source files # This tag can be used to specify the character encoding of the source files
# that doxygen parses. Internally doxygen uses the UTF-8 encoding. Doxygen uses # that doxygen parses. Internally doxygen uses the UTF-8 encoding. Doxygen uses
@ -864,7 +864,7 @@ FILE_PATTERNS = *.c \
# be searched for input files as well. # be searched for input files as well.
# The default value is: NO. # The default value is: NO.
RECURSIVE = NO RECURSIVE = YES
# The EXCLUDE tag can be used to specify files and/or directories that should be # The EXCLUDE tag can be used to specify files and/or directories that should be
# excluded from the INPUT source files. This way you can easily exclude a # excluded from the INPUT source files. This way you can easily exclude a

43
src/arith/integer.c
View file

@ -41,13 +41,12 @@ const char *hex_digits = "0123456789ABCDEF";
/* /*
* Doctrine from here on in is that ALL integers are bignums, it's just * Doctrine from here on in is that ALL integers are bignums, it's just
* that integers less than 65 bits are bignums of one cell only. * that integers less than 65 bits are bignums of one cell only.
*
* TODO: I have no idea at all how I'm going to print bignums!
*/ */
/** /**
* return the numeric value of this cell, as a C primitive double, not * return the numeric value of the cell indicated by this `pointer`, as a C
* as a cons-space object. Cell may in principle be any kind of number. * primitive double, not as a cons_space_object. The indicated cell may in
* principle be any kind of number; if it is not a number, will return `NAN`.
*/ */
long double numeric_value( struct cons_pointer pointer ) { long double numeric_value( struct cons_pointer pointer ) {
long double result = NAN; long double result = NAN;
@ -75,7 +74,10 @@ long double numeric_value( struct cons_pointer pointer ) {
} }
/** /**
* Allocate an integer cell representing this value and return a cons pointer to it. * 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 make_integer( int64_t value, struct cons_pointer more ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
@ -94,7 +96,13 @@ struct cons_pointer make_integer( int64_t value, struct cons_pointer more ) {
return result; return result;
} }
/**
* Internal to `operate_on_integers`, do not use.
* @param c a pointer to a cell, assumed to be an integer cell;
* @param op a character representing the operation: expectedto be either
* '+' or '*'; behaviour with other values is undefined.
* \see operate_on_integers
*/
__int128_t cell_value( struct cons_pointer c, char op, bool is_first_cell ) { __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 val = nilp( c ) ? 0 : pointer2cell( c ).payload.integer.value;
long int carry = is_first_cell ? 0 : ( MAX_INTEGER + 1 ); long int carry = is_first_cell ? 0 : ( MAX_INTEGER + 1 );
@ -115,8 +123,15 @@ __int128_t cell_value( struct cons_pointer c, char op, bool is_first_cell ) {
* possibly, later, other operations. Apply the operator `op` to the * possibly, later, other operations. Apply the operator `op` to the
* integer arguments `a` and `b`, and return a pointer to the result. If * integer arguments `a` and `b`, and return a pointer to the result. If
* either `a` or `b` is not an integer, returns `NIL`. * either `a` or `b` is not an integer, returns `NIL`.
*
* @param a a pointer to a cell, assumed to be an integer cell;
* @param b 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.
* \see add_integers
* \see multiply_integers
*/ */
/* TODO: there is a significant bug here, which manifests in multiply but /* \todo there is a significant bug here, which manifests in multiply but
* may not manifest in add. The value in the least significant cell ends * may not manifest in add. The value in the least significant cell ends
* up significantly WRONG, but the value in the more significant cell * up significantly WRONG, but the value in the more significant cell
* ends up correct. */ * ends up correct. */
@ -148,7 +163,7 @@ struct cons_pointer operate_on_integers( struct cons_pointer a,
switch ( op ) { switch ( op ) {
case '*': case '*':
rv = av * bv * ( ( carry == 0 ) ? 1 : carry ); rv = av * ( bv + carry );
break; break;
case '+': case '+':
rv = av + bv + carry; rv = av + bv + carry;
@ -170,7 +185,7 @@ struct cons_pointer operate_on_integers( struct cons_pointer a,
if ( MAX_INTEGER >= rv ) { if ( MAX_INTEGER >= rv ) {
carry = 0; carry = 0;
} else { } else {
// TODO: we're correctly detecting overflow, but not yet correctly // \todo we're correctly detecting overflow, but not yet correctly
// handling it. // handling it.
carry = rv >> 60; carry = rv >> 60;
debug_printf( DEBUG_ARITH, debug_printf( DEBUG_ARITH,
@ -210,8 +225,8 @@ struct cons_pointer operate_on_integers( struct cons_pointer a,
} }
/** /**
* Return the sum of the integers pointed to by `a` and `b`. If either isn't * Return a pointer to an integer representing the sum of the integers
* an integer, will return nil. * 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 add_integers( struct cons_pointer a,
struct cons_pointer b ) { struct cons_pointer b ) {
@ -220,8 +235,8 @@ struct cons_pointer add_integers( struct cons_pointer a,
} }
/** /**
* Return the product of the integers pointed to by `a` and `b`. If either isn't * Return a pointer to an integer representing the product of the integers
* an integer, will return nil. * pointed to by `a` and `b`. If either isn't an integer, will return nil.
*/ */
struct cons_pointer multiply_integers( struct cons_pointer a, struct cons_pointer multiply_integers( struct cons_pointer a,
struct cons_pointer b ) { struct cons_pointer b ) {
@ -253,7 +268,7 @@ struct cons_pointer integer_to_string_add_digit( int digit, int digits,
* to be looking to the next. H'mmmm. * to be looking to the next. H'mmmm.
*/ */
/* /*
* TODO: this blows up when printing three-cell integers, but works fine * \todo this blows up when printing three-cell integers, but works fine
* for two-cell. What's happening is that when we cross the barrier we * for two-cell. What's happening is that when we cross the barrier we
* SHOULD print 2^120, but what we actually print is 2^117. H'mmm. * SHOULD print 2^120, but what we actually print is 2^117. H'mmm.
*/ */

5
src/arith/integer.h
View file

@ -1,4 +1,4 @@
/** /*
* integer.h * integer.h
* *
* functions for integer cells. * functions for integer cells.
@ -13,9 +13,6 @@
long double numeric_value( struct cons_pointer pointer ); long double numeric_value( struct cons_pointer pointer );
/**
* Allocate an integer cell representing this value and return a cons pointer to it.
*/
struct cons_pointer make_integer( int64_t value, struct cons_pointer more ); struct cons_pointer make_integer( int64_t value, struct cons_pointer more );
struct cons_pointer add_integers( struct cons_pointer a, struct cons_pointer add_integers( struct cons_pointer a,

46
src/arith/peano.c
View file

@ -34,7 +34,9 @@ struct cons_pointer add_2( struct stack_frame *frame,
struct cons_pointer arg1, struct cons_pointer arg1,
struct cons_pointer arg2 ); struct cons_pointer arg2 );
/**
* return true if this `arg` points to a number whose value is zero.
*/
bool zerop( struct cons_pointer arg ) { bool zerop( struct cons_pointer arg ) {
bool result = false; bool result = false;
struct cons_space_object cell = pointer2cell( arg ); struct cons_space_object cell = pointer2cell( arg );
@ -56,7 +58,13 @@ bool zerop( struct cons_pointer arg ) {
} }
/** /**
* TODO: cannot throw an exception out of here, which is a problem * 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 * if a ratio may legally have zero as a divisor, or something which is
* not a number is passed in. * not a number is passed in.
*/ */
@ -97,7 +105,13 @@ long double to_long_double( struct cons_pointer arg ) {
/** /**
* TODO: cannot throw an exception out of here, which is a problem * 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 * 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. * not a number (or is a big number) is passed in.
*/ */
@ -106,7 +120,7 @@ int64_t to_long_int( struct cons_pointer arg ) {
struct cons_space_object cell = pointer2cell( arg ); struct cons_space_object cell = pointer2cell( arg );
switch ( cell.tag.value ) { switch ( cell.tag.value ) {
case INTEGERTV: case INTEGERTV:
/* TODO: if (integerp(cell.payload.integer.more)) { /* \todo if (integerp(cell.payload.integer.more)) {
* throw an exception! * throw an exception!
* } */ * } */
result = cell.payload.integer.value; result = cell.payload.integer.value;
@ -123,9 +137,9 @@ int64_t to_long_int( struct cons_pointer arg ) {
/** /**
* return a cons_pointer indicating a number which is the sum of * return a cons_pointer indicating a number which is the sum of
* the numbers indicated by `arg1` and `arg2`. * the numbers indicated by `arg1` and `arg2`.
*/ */
struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer add_2( struct stack_frame *frame,
struct cons_pointer frame_pointer, struct cons_pointer frame_pointer,
struct cons_pointer arg1, struct cons_pointer arg1,
@ -222,7 +236,8 @@ struct cons_pointer add_2( struct stack_frame *frame,
* Add an indefinite number of numbers together * Add an indefinite number of numbers together
* @param env the evaluation environment - ignored; * @param env the evaluation environment - ignored;
* @param frame the stack frame. * @param frame the stack frame.
* @return a pointer to an integer or real. * @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 struct cons_pointer lisp_add( struct stack_frame
*frame, struct cons_pointer frame_pointer, struct *frame, struct cons_pointer frame_pointer, struct
@ -356,7 +371,8 @@ struct cons_pointer multiply_2( struct stack_frame *frame,
* Multiply an indefinite number of numbers together * Multiply an indefinite number of numbers together
* @param env the evaluation environment - ignored; * @param env the evaluation environment - ignored;
* @param frame the stack frame. * @param frame the stack frame.
* @return a pointer to an integer or real. * @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 struct cons_pointer lisp_multiply( struct
stack_frame stack_frame
@ -431,7 +447,7 @@ struct cons_pointer negative( struct cons_pointer frame,
/** /**
* return a cons_pointer indicating a number which is the result of * return a cons_pointer indicating a number which is the result of
* subtracting the numbers indicated by `arg2` from that indicated by `arg1`, * subtracting the number indicated by `arg2` from that indicated by `arg1`,
* in the context of this `frame`. * in the context of this `frame`.
*/ */
struct cons_pointer subtract_2( struct stack_frame *frame, struct cons_pointer subtract_2( struct stack_frame *frame,
@ -526,10 +542,12 @@ struct cons_pointer subtract_2( struct stack_frame *frame,
} }
/** /**
* Subtract one number from another. * 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 env the evaluation environment - ignored;
* @param frame the stack frame. * @param frame the stack frame.
* @return a pointer to an integer or real. * @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 struct cons_pointer lisp_subtract( struct
stack_frame stack_frame
@ -539,10 +557,12 @@ struct cons_pointer lisp_subtract( struct
} }
/** /**
* Divide one number by another. * 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 env the evaluation environment - ignored;
* @param frame the stack frame. * @param frame the stack frame.
* @return a pointer to an integer or real. * @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 struct cons_pointer lisp_divide( struct
stack_frame stack_frame

6
src/arith/peano.h
View file

@ -1,4 +1,4 @@
/** /*
* peano.h * peano.h
* *
* Basic peano arithmetic * Basic peano arithmetic
@ -18,7 +18,7 @@ struct cons_pointer negative( struct cons_pointer frame,
struct cons_pointer arg ); struct cons_pointer arg );
/** /**
* TODO: cannot throw an exception out of here, which is a problem * \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 * if a ratio may legally have zero as a divisor, or something which is
* not a number is passed in. * not a number is passed in.
*/ */
@ -35,7 +35,7 @@ lisp_add( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );
/** /**
* Multiply an indefinite number of numbers together * Multiply an indefinite number of numbers together.
* @param env the evaluation environment - ignored; * @param env the evaluation environment - ignored;
* @param frame the stack frame. * @param frame the stack frame.
* @return a pointer to an integer or real. * @return a pointer to an integer or real.

37
src/arith/ratio.c
View file

@ -46,8 +46,8 @@ int64_t least_common_multiple( int64_t m, int64_t n ) {
/** /**
* return a cons_pointer indicating a number which is of the * return a cons_pointer indicating a number which is of the
* same value as the ratio indicated by `arg`, but which may * same value as the ratio indicated by `arg`, but which may
* be in a simplified representation. If `arg` isn't a ratio, * be in a simplified representation.
* will throw exception. * @exception If `arg` isn't a ratio, will return an exception.
*/ */
struct cons_pointer simplify_ratio( struct cons_pointer frame_pointer, struct cons_pointer simplify_ratio( struct cons_pointer frame_pointer,
struct cons_pointer arg ) { struct cons_pointer arg ) {
@ -83,8 +83,9 @@ struct cons_pointer simplify_ratio( struct cons_pointer frame_pointer,
/** /**
* return a cons_pointer indicating a number which is the sum of * return a cons_pointer indicating a number which is the sum of
* the ratios indicated by `arg1` and `arg2`. If you pass non-ratios, * the ratios indicated by `arg1` and `arg2`.
* this is going to break horribly. * @exception will return an exception if either `arg1` or `arg2` is not a
* rational number.
*/ */
struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer, struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer,
struct cons_pointer arg1, struct cons_pointer arg1,
@ -100,7 +101,6 @@ struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer,
if ( ratiop( arg1 ) && ratiop( arg2 ) ) { if ( ratiop( arg1 ) && ratiop( arg2 ) ) {
struct cons_space_object cell1 = pointer2cell( arg1 ); struct cons_space_object cell1 = pointer2cell( arg1 );
struct cons_space_object cell2 = pointer2cell( arg2 ); struct cons_space_object cell2 = pointer2cell( arg2 );
// TODO: to be entirely reworked for bignums. All vars must be lisp integers.
int64_t dd1v = int64_t dd1v =
pointer2cell( cell1.payload.ratio.dividend ).payload.integer.value, pointer2cell( cell1.payload.ratio.dividend ).payload.integer.value,
dd2v = dd2v =
@ -160,7 +160,8 @@ struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer,
/** /**
* return a cons_pointer indicating a number which is the sum of * return a cons_pointer indicating a number which is the sum of
* the intger indicated by `intarg` and the ratio indicated by * the intger indicated by `intarg` and the ratio indicated by
* `ratarg`. If you pass other types, this is going to break horribly. * `ratarg`.
* @exception if either `intarg` or `ratarg` is not of the expected type.
*/ */
struct cons_pointer add_integer_ratio( struct cons_pointer frame_pointer, struct cons_pointer add_integer_ratio( struct cons_pointer frame_pointer,
struct cons_pointer intarg, struct cons_pointer intarg,
@ -190,8 +191,9 @@ struct cons_pointer add_integer_ratio( struct cons_pointer frame_pointer,
/** /**
* return a cons_pointer to a ratio which represents the value of the ratio * return a cons_pointer to a ratio which represents the value of the ratio
* indicated by `arg1` divided by the ratio indicated by `arg2`. If either * indicated by `arg1` divided by the ratio indicated by `arg2`.
* of these aren't RTIO cells, something horrid will happen and it is YOUR FAULT. * @exception will return an exception if either `arg1` or `arg2` is not a
* rational number.
*/ */
struct cons_pointer divide_ratio_ratio( struct cons_pointer frame_pointer, struct cons_pointer divide_ratio_ratio( struct cons_pointer frame_pointer,
struct cons_pointer arg1, struct cons_pointer arg1,
@ -210,8 +212,9 @@ struct cons_pointer divide_ratio_ratio( struct cons_pointer frame_pointer,
/** /**
* return a cons_pointer indicating a number which is the product of * return a cons_pointer indicating a number which is the product of
* the ratios indicated by `arg1` and `arg2`. If you pass non-ratios, * the ratios indicated by `arg1` and `arg2`.
* this is going to break horribly. * @exception will return an exception if either `arg1` or `arg2` is not a
* rational number.
*/ */
struct cons_pointer multiply_ratio_ratio( struct cons_pointer frame_pointer, struct struct cons_pointer multiply_ratio_ratio( struct cons_pointer frame_pointer, struct
cons_pointer arg1, struct cons_pointer arg1, struct
@ -258,7 +261,8 @@ struct cons_pointer multiply_ratio_ratio( struct cons_pointer frame_pointer, str
/** /**
* return a cons_pointer indicating a number which is the product of * return a cons_pointer indicating a number which is the product of
* the intger indicated by `intarg` and the ratio indicated by * the intger indicated by `intarg` and the ratio indicated by
* `ratarg`. If you pass other types, this is going to break horribly. * `ratarg`.
* @exception if either `intarg` or `ratarg` is not of the expected type.
*/ */
struct cons_pointer multiply_integer_ratio( struct cons_pointer frame_pointer, struct cons_pointer multiply_integer_ratio( struct cons_pointer frame_pointer,
struct cons_pointer intarg, struct cons_pointer intarg,
@ -285,8 +289,9 @@ struct cons_pointer multiply_integer_ratio( struct cons_pointer frame_pointer,
/** /**
* return a cons_pointer indicating a number which is the difference of * return a cons_pointer indicating a number which is the difference of
* the ratios indicated by `arg1` and `arg2`. If you pass non-ratios, * the ratios indicated by `arg1` and `arg2`.
* this is going to break horribly. * @exception will return an exception if either `arg1` or `arg2` is not a
* rational number.
*/ */
struct cons_pointer subtract_ratio_ratio( struct cons_pointer frame_pointer, struct cons_pointer subtract_ratio_ratio( struct cons_pointer frame_pointer,
struct cons_pointer arg1, struct cons_pointer arg1,
@ -301,8 +306,10 @@ struct cons_pointer subtract_ratio_ratio( struct cons_pointer frame_pointer,
/** /**
* Construct a ratio frame from these two pointers, expected to be integers * Construct a ratio frame from this `dividend` and `divisor`, expected to
* or (later) bignums, in the context of this stack_frame. * 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 frame_pointer, struct cons_pointer make_ratio( struct cons_pointer frame_pointer,
struct cons_pointer dividend, struct cons_pointer dividend,

22
src/init.c
View file

@ -27,20 +27,28 @@
// extern char *optarg; /* defined in unistd.h */ // extern char *optarg; /* defined in unistd.h */
/**
* 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.
*/
void bind_function( wchar_t *name, struct cons_pointer ( *executable ) void bind_function( wchar_t *name, struct cons_pointer ( *executable )
( struct stack_frame *, ( struct stack_frame *,
struct cons_pointer, struct cons_pointer ) ) { struct cons_pointer, struct cons_pointer ) ) {
struct cons_pointer n = c_string_to_lisp_symbol( name ); struct cons_pointer n = c_string_to_lisp_symbol( name );
inc_ref( n ); inc_ref( n );
/* 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. */
deep_bind( n, make_function( NIL, executable ) ); deep_bind( n, make_function( NIL, executable ) );
dec_ref( n ); dec_ref( n );
} }
/**
* Bind this compiled `executable` function, as a Lisp special form, to
* this `name` in the `oblist`.
*/
void bind_special( wchar_t *name, struct cons_pointer ( *executable ) void bind_special( wchar_t *name, struct cons_pointer ( *executable )
( struct stack_frame *, ( struct stack_frame *,
struct cons_pointer, struct cons_pointer ) ) { struct cons_pointer, struct cons_pointer ) ) {
@ -52,6 +60,9 @@ void bind_special( wchar_t *name, struct cons_pointer ( *executable )
dec_ref( n ); dec_ref( n );
} }
/**
* Bind this `value` to this `name` in the `oblist`.
*/
void bind_value( wchar_t *name, struct cons_pointer value ) { void bind_value( wchar_t *name, struct cons_pointer value ) {
struct cons_pointer n = c_string_to_lisp_symbol( name ); struct cons_pointer n = c_string_to_lisp_symbol( name );
inc_ref( n ); inc_ref( n );
@ -61,6 +72,10 @@ void bind_value( wchar_t *name, struct cons_pointer value ) {
dec_ref( n ); dec_ref( n );
} }
/**
* main entry point; parse command line arguments, initialise the environment,
* and enter the read-eval-print loop.
*/
int main( int argc, char *argv[] ) { int main( int argc, char *argv[] ) {
int option; int option;
bool dump_at_end = false; bool dump_at_end = false;
@ -179,7 +194,6 @@ int main( int argc, char *argv[] ) {
dec_ref( oblist ); dec_ref( oblist );
debug_dump_object( oblist, DEBUG_BOOTSTRAP ); debug_dump_object( oblist, DEBUG_BOOTSTRAP );
if ( dump_at_end ) { if ( dump_at_end ) {
dump_pages( stdout ); dump_pages( stdout );
} }

130
src/memory/conspage.c
View file

@ -45,9 +45,12 @@ struct cons_pointer freelist = NIL;
struct cons_page *conspages[NCONSPAGES]; struct cons_page *conspages[NCONSPAGES];
/** /**
* Make a cons page whose serial number (i.e. index in the conspages directory) is pageno. * Make a cons page. Initialise all cells and prepend each to the freelist;
* Initialise all cells and prepend each to the freelist; if pageno is zero, do not prepend * if `initialised_cons_pages` is zero, do not prepend cells 0 and 1 to the
* cells 0 and 1 to the freelist but initialise them as NIL and T respectively. * 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( ) { void make_cons_page( ) {
struct cons_page *result = malloc( sizeof( struct cons_page ) ); struct cons_page *result = malloc( sizeof( struct cons_page ) );
@ -110,7 +113,7 @@ void make_cons_page( ) {
} }
/** /**
* dump the allocated pages to this output stream. * dump the allocated pages to this `output` stream.
*/ */
void dump_pages( FILE * output ) { void dump_pages( FILE * output ) {
for ( int i = 0; i < initialised_cons_pages; i++ ) { for ( int i = 0; i < initialised_cons_pages; i++ ) {
@ -125,8 +128,9 @@ void dump_pages( FILE * output ) {
} }
/** /**
* Frees the cell at the specified pointer. Dangerous, primitive, low * Frees the cell at the specified `pointer`; for all the types of cons-space
* level. * object which point to other cons-space objects, cascade the decrement.
* Dangerous, primitive, low level.
* *
* @pointer the cell to free * @pointer the cell to free
*/ */
@ -136,63 +140,62 @@ void free_cell( struct cons_pointer pointer ) {
debug_printf( DEBUG_ALLOC, L"Freeing cell " ); debug_printf( DEBUG_ALLOC, L"Freeing cell " );
debug_dump_object( pointer, DEBUG_ALLOC ); debug_dump_object( pointer, DEBUG_ALLOC );
switch ( cell->tag.value ) {
/* for all the types of cons-space object which point to other
* cons-space objects, cascade the decrement. */
case CONSTV:
dec_ref( cell->payload.cons.car );
dec_ref( cell->payload.cons.cdr );
break;
case EXCEPTIONTV:
dec_ref( cell->payload.exception.message );
dec_ref( cell->payload.exception.frame );
break;
case FUNCTIONTV:
dec_ref( cell->payload.function.source );
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 SPECIALTV:
dec_ref( cell->payload.special.source );
break;
case STRINGTV:
case SYMBOLTV:
dec_ref( cell->payload.string.cdr );
break;
case VECTORPOINTTV:
/* for vector space pointers, free the actual vector-space
* object. Dangerous! */
debug_printf( DEBUG_ALLOC,
L"About to free vector-space object at 0x%lx\n",
cell->payload.vectorp.address );
struct vector_space_object *vso = cell->payload.vectorp.address;
switch ( vso->header.tag.value ) {
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 );
break;
}
if ( !check_tag( pointer, FREETAG ) ) { if ( !check_tag( pointer, FREETAG ) ) {
if ( cell->count == 0 ) { 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.message );
dec_ref( cell->payload.exception.frame );
break;
case FUNCTIONTV:
dec_ref( cell->payload.function.source );
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 SPECIALTV:
dec_ref( cell->payload.special.source );
break;
case STRINGTV:
case SYMBOLTV:
dec_ref( cell->payload.string.cdr );
break;
case VECTORPOINTTV:
/* for vector space pointers, free the actual vector-space
* object. Dangerous! */
debug_printf( DEBUG_ALLOC,
L"About to free vector-space object at 0x%lx\n",
cell->payload.vectorp.address );
struct vector_space_object *vso =
cell->payload.vectorp.address;
switch ( vso->header.tag.value ) {
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 );
break;
}
strncpy( &cell->tag.bytes[0], FREETAG, TAGLENGTH ); strncpy( &cell->tag.bytes[0], FREETAG, TAGLENGTH );
cell->payload.free.car = NIL; cell->payload.free.car = NIL;
cell->payload.free.cdr = freelist; cell->payload.free.cdr = freelist;
@ -210,11 +213,14 @@ void free_cell( struct cons_pointer pointer ) {
} }
/** /**
* Allocates a cell with the specified tag. Dangerous, primitive, low * Allocates a cell with the specified `tag`. Dangerous, primitive, low
* level. * level.
* *
* @param tag the tag of the cell to allocate - must be a valid cons space tag. * @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. * @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( char *tag ) { struct cons_pointer allocate_cell( char *tag ) {
struct cons_pointer result = freelist; struct cons_pointer result = freelist;

26
src/memory/conspage.h
View file

@ -37,42 +37,16 @@ struct cons_page {
struct cons_space_object cell[CONSPAGESIZE]; struct cons_space_object cell[CONSPAGESIZE];
}; };
/**
* The (global) pointer to the (global) freelist. Not sure whether this ultimately
* belongs in this file.
*/
extern struct cons_pointer freelist; extern struct cons_pointer freelist;
/**
* An array of pointers to cons pages.
*/
extern struct cons_page *conspages[NCONSPAGES]; extern struct cons_page *conspages[NCONSPAGES];
/**
* Frees the cell at the specified pointer. Dangerous, primitive, low
* level.
*
* @pointer the cell to free
*/
void free_cell( struct cons_pointer pointer ); void free_cell( struct cons_pointer pointer );
/**
* 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.
*/
struct cons_pointer allocate_cell( char *tag ); struct cons_pointer allocate_cell( char *tag );
/**
* initialise the cons page system; to be called exactly once during startup.
*/
void initialise_cons_pages( ); void initialise_cons_pages( );
/**
* dump the allocated pages to this output stream.
*/
void dump_pages( FILE * output ); void dump_pages( FILE * output );
#endif #endif

26
src/memory/consspaceobject.c
View file

@ -25,9 +25,9 @@
#include "stack.h" #include "stack.h"
/** /**
* Check that the tag on the cell at this pointer is this tag * True if the tag on the cell at this `pointer` is this `tag`, else false.
*/ */
int check_tag( struct cons_pointer pointer, char *tag ) { bool check_tag( struct cons_pointer pointer, char *tag ) {
struct cons_space_object cell = pointer2cell( pointer ); struct cons_space_object cell = pointer2cell( pointer );
return strncmp( &cell.tag.bytes[0], tag, TAGLENGTH ) == 0; return strncmp( &cell.tag.bytes[0], tag, TAGLENGTH ) == 0;
} }
@ -178,12 +178,12 @@ make_string_like_thing( wint_t c, struct cons_pointer tail, char *tag ) {
inc_ref( tail ); inc_ref( tail );
cell->payload.string.character = c; cell->payload.string.character = c;
cell->payload.string.cdr.page = tail.page; cell->payload.string.cdr.page = tail.page;
/* TODO: There's a problem here. Sometimes the offsets on /* \todo There's a problem here. Sometimes the offsets on
* strings are quite massively off. Fix is probably * strings are quite massively off. Fix is probably
* cell->payload.string.cdr = tsil */ * cell->payload.string.cdr = tsil */
cell->payload.string.cdr.offset = tail.offset; cell->payload.string.cdr.offset = tail.offset;
} else { } else {
// TODO: should throw an exception! // \todo should throw an exception!
debug_printf( DEBUG_ALLOC, debug_printf( DEBUG_ALLOC,
L"Warning: only NIL and %s can be prepended to %s\n", L"Warning: only NIL and %s can be prepended to %s\n",
tag, tag ); tag, tag );
@ -193,17 +193,23 @@ make_string_like_thing( wint_t c, struct cons_pointer tail, char *tag ) {
} }
/** /**
* Construct a string from this character and * Construct a string from the character `c` and this `tail`. A string is
* this tail. A string is implemented as a flat list of cells each of which * implemented as a flat list of cells each of which has one character and a
* has one character and a pointer to the next; in the last cell the * pointer to the next; in the last cell the pointer to next is NIL.
* 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 ) { struct cons_pointer make_string( wint_t c, struct cons_pointer tail ) {
return make_string_like_thing( c, tail, STRINGTAG ); return make_string_like_thing( c, tail, STRINGTAG );
} }
/** /**
* Construct a symbol from this character and this tail. * Construct a symbol from the character `c` and this `tail`. A symbol 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.
*/ */
struct cons_pointer make_symbol( wint_t c, struct cons_pointer tail ) { struct cons_pointer make_symbol( wint_t c, struct cons_pointer tail ) {
return make_string_like_thing( c, tail, SYMBOLTAG ); return make_string_like_thing( c, tail, SYMBOLTAG );
@ -239,7 +245,7 @@ struct cons_pointer make_read_stream( FILE * input ) {
} }
/** /**
* Construct a cell which points to a stream open for writeing. * Construct a cell which points to a stream open for writing.
* @param output the C stream to wrap. * @param output the C stream to wrap.
*/ */
struct cons_pointer make_write_stream( FILE * output ) { struct cons_pointer make_write_stream( FILE * output ) {

359
src/memory/consspaceobject.h
View file

@ -1,4 +1,4 @@
/** /*
* consspaceobject.h * consspaceobject.h
* *
* Declarations common to all cons space objects. * Declarations common to all cons space objects.
@ -25,113 +25,189 @@
*/ */
#define TAGLENGTH 4 #define TAGLENGTH 4
/** /*
* tag values, all of which must be 4 bytes. Must not collide with vector space tag values * tag values, all of which must be 4 bytes. Must not collide with vector space
* tag values
*/ */
/** /**
* An ordinary cons cell: 1397641027 * An ordinary cons cell:
*/ */
#define CONSTAG "CONS" #define CONSTAG "CONS"
/**
* The string `CONS`, considered as an `unsigned int`.
*/
#define CONSTV 1397641027 #define CONSTV 1397641027
/** /**
* An exception. * An exception.
*/ */
#define EXCEPTIONTAG "EXEP" #define EXCEPTIONTAG "EXEP"
/**
* The string `EXEP`, considered as an `unsigned int`.
*/
#define EXCEPTIONTV 1346721861 #define EXCEPTIONTV 1346721861
/** /**
* An unallocated cell on the free list - should never be encountered by a Lisp * An unallocated cell on the free list - should never be encountered by a Lisp
* function. 1162170950 * function.
*/ */
#define FREETAG "FREE" #define FREETAG "FREE"
/**
* The string `FREE`, considered as an `unsigned int`.
*/
#define FREETV 1162170950 #define FREETV 1162170950
/** /**
* An ordinary Lisp function - one whose arguments are pre-evaluated and passed as * An ordinary Lisp function - one whose arguments are pre-evaluated.
* a stack frame. 1129207110 * \see LAMBDATAG for interpretable functions.
* \see SPECIALTAG for functions whose arguments are not pre-evaluated.
*/ */
#define FUNCTIONTAG "FUNC" #define FUNCTIONTAG "FUNC"
#define FUNCTIONTV 1129207110
/** /**
* An integer number. 1381256777 * The string `FUNC`, considered as an `unsigned int`.
*/
#define FUNCTIONTV 1129207110
/**
* An integer number (bignums are integers).
*/ */
#define INTEGERTAG "INTR" #define INTEGERTAG "INTR"
/**
* The string `INTR`, considered as an `unsigned int`.
*/
#define INTEGERTV 1381256777 #define INTEGERTV 1381256777
/** /**
* A lambda cell. * A lambda cell. Lambdas are the interpretable (source) versions of functions.
* \see FUNCTIONTAG.
*/ */
#define LAMBDATAG "LMDA" #define LAMBDATAG "LMDA"
/**
* The string `LMDA`, considered as an `unsigned int`.
*/
#define LAMBDATV 1094995276 #define LAMBDATV 1094995276
/** /**
* The special cons cell at address {0,0} whose car and cdr both point to itself. * The special cons cell at address {0,0} whose car and cdr both point to
* 541870414 * itself.
*/ */
#define NILTAG "NIL " #define NILTAG "NIL "
/**
* The string `NIL `, considered as an `unsigned int`.
*/
#define NILTV 541870414 #define NILTV 541870414
/** /**
* An nlambda cell. * An nlambda cell. NLambdas are the interpretable (source) versions of special
* forms. \see SPECIALTAG.
*/ */
#define NLAMBDATAG "NLMD" #define NLAMBDATAG "NLMD"
/**
* The string `NLMD`, considered as an `unsigned int`.
*/
#define NLAMBDATV 1145916494 #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. * An open read stream.
*/ */
#define READTAG "READ" #define READTAG "READ"
/**
* The string `READ`, considered as an `unsigned int`.
*/
#define READTV 1145128274 #define READTV 1145128274
/** /**
* A real number. * A real number, represented internally as an IEEE 754-2008 `binary64`.
*/ */
#define REALTAG "REAL" #define REALTAG "REAL"
/**
* The string `REAL`, considered as an `unsigned int`.
*/
#define REALTV 1279346002 #define REALTV 1279346002
/** /**
* A ratio. * A special form - one whose arguments are not pre-evaluated but passed as
*/ * provided.
#define RATIOTAG "RTIO" * \see NLAMBDATAG.
#define RATIOTV 1330205778
/**
* A special form - one whose arguments are not pre-evaluated but passed as a
* s-expression. 1296453715
*/ */
#define SPECIALTAG "SPFM" #define SPECIALTAG "SPFM"
/**
* The string `SPFM`, considered as an `unsigned int`.
*/
#define SPECIALTV 1296453715 #define SPECIALTV 1296453715
/** /**
* A string of characters, organised as a linked list. 1196577875 * A string of characters, organised as a linked list.
*/ */
#define STRINGTAG "STRG" #define STRINGTAG "STRG"
/**
* The string `STRG`, considered as an `unsigned int`.
*/
#define STRINGTV 1196577875 #define STRINGTV 1196577875
/** /**
* A symbol is just like a string except not self-evaluating. 1112365395 * A symbol is just like a string except not self-evaluating.
*/ */
#define SYMBOLTAG "SYMB" #define SYMBOLTAG "SYMB"
/**
* The string `SYMB`, considered as an `unsigned int`.
*/
#define SYMBOLTV 1112365395 #define SYMBOLTV 1112365395
/** /**
* The special cons cell at address {0,1} which is canonically different from NIL. * The special cons cell at address {0,1} which is canonically different
* 1163219540 * from NIL.
*/ */
#define TRUETAG "TRUE" #define TRUETAG "TRUE"
/**
* The string `TRUE`, considered as an `unsigned int`.
*/
#define TRUETV 1163219540 #define TRUETV 1163219540
/** /**
* A pointer to an object in vector space. * A pointer to an object in vector space.
*/ */
#define VECTORPOINTTAG "VECP" #define VECTORPOINTTAG "VECP"
/**
* The string `VECP`, considered as an `unsigned int`.
*/
#define VECTORPOINTTV 1346585942 #define VECTORPOINTTV 1346585942
/** /**
* An open write stream. * An open write stream.
*/ */
#define WRITETAG "WRIT" #define WRITETAG "WRIT"
/**
* The string `WRIT`, considered as an `unsigned int`.
*/
#define WRITETV 1414091351 #define WRITETV 1414091351
/** /**
@ -154,96 +230,103 @@
*/ */
#define tag2uint(tag) ((uint32_t)*tag) #define tag2uint(tag) ((uint32_t)*tag)
/**
* given a cons_pointer as argument, return the cell.
*/
#define pointer2cell(pointer) ((conspages[pointer.page]->cell[pointer.offset])) #define pointer2cell(pointer) ((conspages[pointer.page]->cell[pointer.offset]))
/** /**
* true if conspointer points to the special cell NIL, else false * true if `conspoint` points to the special cell NIL, else false
* (there should only be one of these so it's slightly redundant). * (there should only be one of these so it's slightly redundant).
*/ */
#define nilp(conspoint) (check_tag(conspoint,NILTAG)) #define nilp(conspoint) (check_tag(conspoint,NILTAG))
/** /**
* true if conspointer points to a cons cell, else false * true if `conspoint` points to a cons cell, else false
*/ */
#define consp(conspoint) (check_tag(conspoint,CONSTAG)) #define consp(conspoint) (check_tag(conspoint,CONSTAG))
/** /**
* true if conspointer points to an exception, else false * true if `conspoint` points to an exception, else false
*/ */
#define exceptionp(conspoint) (check_tag(conspoint,EXCEPTIONTAG)) #define exceptionp(conspoint) (check_tag(conspoint,EXCEPTIONTAG))
/** /**
* true if conspointer points to a function cell, else false * true if `conspoint` points to a function cell, else false
*/ */
#define functionp(conspoint) (check_tag(conspoint,FUNCTIONTAG)) #define functionp(conspoint) (check_tag(conspoint,FUNCTIONTAG))
/** /**
* true if conspointer points to a special Lambda cell, else false * true if `conspoint` points to a special Lambda cell, else false
*/ */
#define lambdap(conspoint) (check_tag(conspoint,LAMBDATAG)) #define lambdap(conspoint) (check_tag(conspoint,LAMBDATAG))
/** /**
* true if conspointer points to a special form cell, else false * true if `conspoint` points to a special form cell, else false
*/ */
#define specialp(conspoint) (check_tag(conspoint,SPECIALTAG)) #define specialp(conspoint) (check_tag(conspoint,SPECIALTAG))
/** /**
* true if conspointer points to a string cell, else false * true if `conspoint` points to a string cell, else false
*/ */
#define stringp(conspoint) (check_tag(conspoint,STRINGTAG)) #define stringp(conspoint) (check_tag(conspoint,STRINGTAG))
/** /**
* true if conspointer points to a symbol cell, else false * true if `conspoint` points to a symbol cell, else false
*/ */
#define symbolp(conspoint) (check_tag(conspoint,SYMBOLTAG)) #define symbolp(conspoint) (check_tag(conspoint,SYMBOLTAG))
/** /**
* true if conspointer points to an integer cell, else false * true if `conspoint` points to an integer cell, else false
*/ */
#define integerp(conspoint) (check_tag(conspoint,INTEGERTAG)) #define integerp(conspoint) (check_tag(conspoint,INTEGERTAG))
/** /**
* true if conspointer points to a rational number cell, else false * true if `conspoint` points to a rational number cell, else false
*/ */
#define ratiop(conspoint) (check_tag(conspoint,RATIOTAG)) #define ratiop(conspoint) (check_tag(conspoint,RATIOTAG))
/** /**
* true if conspointer points to a read stream cell, else false * true if `conspoint` points to a read stream cell, else false
*/ */
#define readp(conspoint) (check_tag(conspoint,READTAG)) #define readp(conspoint) (check_tag(conspoint,READTAG))
/** /**
* true if conspointer points to a real number cell, else false * true if `conspoint` points to a real number cell, else false
*/ */
#define realp(conspoint) (check_tag(conspoint,REALTAG)) #define realp(conspoint) (check_tag(conspoint,REALTAG))
/** /**
* true if conspointer points to some sort of a number cell, * true if `conspoint` points to some sort of a number cell,
* else false * else false
*/ */
#define numberp(conspoint) (check_tag(conspoint,INTEGERTAG)||check_tag(conspoint,RATIOTAG)||check_tag(conspoint,REALTAG)||check_tag(conspoint,BIGNUMTAG)) #define numberp(conspoint) (check_tag(conspoint,INTEGERTAG)||check_tag(conspoint,RATIOTAG)||check_tag(conspoint,REALTAG)||check_tag(conspoint,BIGNUMTAG))
/**
* true if `conspoint` points to a sequence (list, string or, later, vector),
* else false.
*/
#define sequencep(conspoint) (check_tag(conspoint,CONSTAG)||check_tag(conspoint,STRINGTAG)||check_tag(conspoint,SYMBOLTAG)) #define sequencep(conspoint) (check_tag(conspoint,CONSTAG)||check_tag(conspoint,STRINGTAG)||check_tag(conspoint,SYMBOLTAG))
/** /**
* true if thr conspointer points to a vector pointer. * true if `conspoint` points to a vector pointer, else false.
*/ */
#define vectorpointp(conspoint) (check_tag(conspoint,VECTORPOINTTAG)) #define vectorpointp(conspoint) (check_tag(conspoint,VECTORPOINTTAG))
/** /**
* true if conspointer points to a write stream cell, else false. * true if `conspoint` points to a write stream cell, else false.
*/ */
#define writep(conspoint) (check_tag(conspoint,WRITETAG)) #define writep(conspoint) (check_tag(conspoint,WRITETAG))
/** /**
* true if conspointer points to a true cell, else false * true if `conspoint` points to a true cell, else false
* (there should only be one of these so it's slightly redundant). * (there should only be one of these so it's slightly redundant).
* Also note that anything that is not NIL is truthy. * Also note that anything that is not NIL is truthy.
*/ */
#define tp(conspoint) (checktag(conspoint,TRUETAG)) #define tp(conspoint) (checktag(conspoint,TRUETAG))
/** /**
* true if conspoint points to something that is truthy, i.e. * true if `conspoint` points to something that is truthy, i.e.
* anything but NIL. * anything but NIL.
*/ */
#define truep(conspoint) (!checktag(conspoint,NILTAG)) #define truep(conspoint) (!checktag(conspoint,NILTAG))
@ -265,16 +348,18 @@ struct cons_pointer {
/** /**
* A stack frame. Yes, I know it isn't a cons-space object, but it's defined * A stack frame. Yes, I know it isn't a cons-space object, but it's defined
* here to avoid circularity. TODO: refactor. * here to avoid circularity. \todo refactor.
*/ */
struct stack_frame { struct stack_frame {
struct cons_pointer previous; /* the previous frame */ /** the previous frame. */
struct cons_pointer previous;
/** first 8 arument bindings. */
struct cons_pointer arg[args_in_frame]; struct cons_pointer arg[args_in_frame];
/* /** list of any further argument bindings. */
* first 8 arument bindings struct cons_pointer more;
*/ /** the function to be called. */
struct cons_pointer more; /* list of any further argument bindings */ struct cons_pointer function;
struct cons_pointer function; /* the function to be called */ /** the number of arguments provided. */
int args; int args;
}; };
@ -282,7 +367,9 @@ struct stack_frame {
* payload of a cons cell. * payload of a cons cell.
*/ */
struct cons_payload { struct cons_payload {
/** Contents of the Address Register, naturally. */
struct cons_pointer car; struct cons_pointer car;
/** Contents of the Decrement Register, naturally. */
struct cons_pointer cdr; struct cons_pointer cdr;
}; };
@ -291,7 +378,9 @@ struct cons_payload {
* Message should be a Lisp string; frame should be a pointer to an (unfreed) stack frame. * Message should be a Lisp string; frame should be a pointer to an (unfreed) stack frame.
*/ */
struct exception_payload { struct exception_payload {
/** The message: should be a Lisp string but in practice anything printable will do. */
struct cons_pointer message; struct cons_pointer message;
/** pointer to the (unfreed) stack frame in which the exception was thrown. */
struct cons_pointer frame; struct cons_pointer frame;
}; };
@ -305,7 +394,17 @@ struct exception_payload {
* result). * result).
*/ */
struct function_payload { struct function_payload {
/**
* pointer to the source from which the function was compiled, or NIL
* if it is a primitive.
*/
struct cons_pointer source; struct cons_pointer source;
/** 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 ( *executable ) ( struct stack_frame *,
struct cons_pointer, struct cons_pointer,
struct cons_pointer ); struct cons_pointer );
@ -321,28 +420,37 @@ struct free_payload {
}; };
/** /**
* payload of an integer cell. For the time being just a signed integer; * payload of an integer cell. An integer is in principle a sequence of cells;
* later might be a signed 128 bit integer, or might have some flag to point to an * only 60 bits (+ sign bit) are actually used in each cell. If the value
* optional bignum object. * 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.
*/ */
struct integer_payload { struct integer_payload {
/** the value of the payload (i.e. 60 bits) of this cell. */
int64_t value; int64_t value;
/** the next (more significant) cell in the chain, ir `NIL` if there are no
* more. */
struct cons_pointer more; struct cons_pointer more;
}; };
/** /**
* payload for lambda and nlambda cells * payload for lambda and nlambda cells.
*/ */
struct lambda_payload { struct lambda_payload {
/** the arument list */
struct cons_pointer args; struct cons_pointer args;
/** the body of the function to be applied to the arguments. */
struct cons_pointer body; struct cons_pointer body;
}; };
/** /**
* payload for ratio cells. Both dividend and divisor must point to integer (or, later, bignum) cells. * payload for ratio cells. Both `dividend` and `divisor` must point to integer cells.
*/ */
struct ratio_payload { struct ratio_payload {
/** a pointer to an integer representing the dividend */
struct cons_pointer dividend; struct cons_pointer dividend;
/** a pointer to an integer representing the divisor. */
struct cons_pointer divisor; struct cons_pointer divisor;
}; };
@ -351,20 +459,25 @@ struct ratio_payload {
* precision, but I'm not sure of the detail. * precision, but I'm not sure of the detail.
*/ */
struct real_payload { struct real_payload {
/** the value of the number */
long double value; long double value;
}; };
/** /**
* Payload of a special form cell. * Payload of a special form cell. Currently identical to the payload of a
* source points to the source from which the function was compiled, or NIL * function cell.
* if it is a primitive. * \see function_payload
* executable points 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 special_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 source; struct cons_pointer source;
/** 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 ( *executable ) ( struct stack_frame *,
struct cons_pointer, struct cons_pointer,
struct cons_pointer ); struct cons_pointer );
@ -374,6 +487,7 @@ struct special_payload {
* payload of a read or write stream cell. * payload of a read or write stream cell.
*/ */
struct stream_payload { struct stream_payload {
/** the stream to read from or write to. */
FILE *stream; FILE *stream;
}; };
@ -384,8 +498,11 @@ struct stream_payload {
* payload of a string cell. * payload of a string cell.
*/ */
struct string_payload { struct string_payload {
wint_t character; /* the actual character stored in this cell */ /** the actual character stored in this cell */
uint32_t padding; /* unused padding to word-align the cdr */ wint_t character;
/** unused padding to word-align the cdr */
uint32_t padding;
/** the remainder of the string following this character. */
struct cons_pointer cdr; struct cons_pointer cdr;
}; };
@ -393,19 +510,21 @@ struct string_payload {
* payload of a vector pointer cell. * payload of a vector pointer cell.
*/ */
struct vectorp_payload { struct vectorp_payload {
/** the tag of the vector-space object. NOTE that the vector space object
* should itself have the identical tag. */
union { union {
char bytes[TAGLENGTH]; /* the tag (type) of the /** the tag (type) of the vector-space object this cell
* vector-space object this cell * points to, considered as bytes. */
* points to, considered as bytes. char bytes[TAGLENGTH];
* NOTE that the vector space object /** the tag considered as a number */
* should itself have the identical uint32_t value;
* tag. */
uint32_t value; /* the tag considered as a number */
} tag; } tag;
void *address; /** unused padding to word-align the address */
/* the address of the actual vector space uint32_t padding;
* object (TODO: will change when I actually /** the address of the actual vector space
* object (\todo will change when I actually
* implement vector space) */ * implement vector space) */
void *address;
}; };
/** /**
@ -413,87 +532,80 @@ struct vectorp_payload {
*/ */
struct cons_space_object { struct cons_space_object {
union { union {
char bytes[TAGLENGTH]; /* the tag (type) of this cell, /** the tag (type) of this cell,
* considered as bytes */ * considered as bytes */
uint32_t value; /* the tag considered as a number */ char bytes[TAGLENGTH];
/** the tag considered as a number */
uint32_t value;
} tag; } tag;
uint32_t count; /* the count of the number of references to /** the count of the number of references to this cell */
* this cell */ uint32_t count;
struct cons_pointer access; /* cons pointer to the access control list of /** cons pointer to the access control list of this cell */
* this cell */ struct cons_pointer access;
union { union {
/* /**
* if tag == CONSTAG * if tag == CONSTAG
*/ */
struct cons_payload cons; struct cons_payload cons;
/* /**
* if tag == EXCEPTIONTAG * if tag == EXCEPTIONTAG
*/ */
struct exception_payload exception; struct exception_payload exception;
/* /**
* if tag == FREETAG * if tag == FREETAG
*/ */
struct free_payload free; struct free_payload free;
/* /**
* if tag == FUNCTIONTAG * if tag == FUNCTIONTAG
*/ */
struct function_payload function; struct function_payload function;
/* /**
* if tag == INTEGERTAG * if tag == INTEGERTAG
*/ */
struct integer_payload integer; struct integer_payload integer;
/* /**
* if tag == LAMBDATAG or NLAMBDATAG * if tag == LAMBDATAG or NLAMBDATAG
*/ */
struct lambda_payload lambda; struct lambda_payload lambda;
/* /**
* if tag == NILTAG; we'll treat the special cell NIL as just a cons * if tag == NILTAG; we'll treat the special cell NIL as just a cons
*/ */
struct cons_payload nil; struct cons_payload nil;
/* /**
* if tag == RATIOTAG * if tag == RATIOTAG
*/ */
struct ratio_payload ratio; struct ratio_payload ratio;
/* /**
* if tag == READTAG || tag == WRITETAG * if tag == READTAG || tag == WRITETAG
*/ */
struct stream_payload stream; struct stream_payload stream;
/* /**
* if tag == REALTAG * if tag == REALTAG
*/ */
struct real_payload real; struct real_payload real;
/* /**
* if tag == SPECIALTAG * if tag == SPECIALTAG
*/ */
struct special_payload special; struct special_payload special;
/* /**
* if tag == STRINGTAG || tag == SYMBOLTAG * if tag == STRINGTAG || tag == SYMBOLTAG
*/ */
struct string_payload string; struct string_payload string;
/* /**
* if tag == TRUETAG; we'll treat the special cell T as just a cons * if tag == TRUETAG; we'll treat the special cell T as just a cons
*/ */
struct cons_payload t; struct cons_payload t;
/* /**
* if tag == VECTORPTAG * if tag == VECTORPTAG
*/ */
struct vectorp_payload vectorp; struct vectorp_payload vectorp;
} payload; } payload;
}; };
/** bool check_tag( struct cons_pointer pointer, char *tag );
* Check that the tag on the cell at this pointer is this tag
*/
int check_tag( struct cons_pointer pointer, char *tag );
/**
* increment the reference count of the object at this cons pointer
*/
void inc_ref( struct cons_pointer pointer ); void inc_ref( struct cons_pointer pointer );
/**
* decrement the reference count of the object at this cons pointer
*/
void dec_ref( struct cons_pointer pointer ); void dec_ref( struct cons_pointer pointer );
struct cons_pointer make_cons( struct cons_pointer car, struct cons_pointer make_cons( struct cons_pointer car,
@ -502,71 +614,34 @@ struct cons_pointer make_cons( struct cons_pointer car,
struct cons_pointer make_exception( struct cons_pointer message, struct cons_pointer make_exception( struct cons_pointer message,
struct cons_pointer frame_pointer ); struct cons_pointer frame_pointer );
/**
* Construct a cell which points to an executable Lisp special form.
*/
struct cons_pointer make_function( struct cons_pointer src, struct cons_pointer make_function( struct cons_pointer src,
struct cons_pointer ( *executable ) struct cons_pointer ( *executable )
( struct stack_frame *, ( struct stack_frame *,
struct cons_pointer, struct cons_pointer,
struct cons_pointer ) ); struct cons_pointer ) );
/**
* Construct a lambda (interpretable source) cell
*/
struct cons_pointer make_lambda( struct cons_pointer args, struct cons_pointer make_lambda( struct cons_pointer args,
struct cons_pointer body ); struct cons_pointer body );
/**
* 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 make_nlambda( struct cons_pointer args,
struct cons_pointer body ); struct cons_pointer body );
/**
* Construct a cell which points to an executable Lisp special form.
*/
struct cons_pointer make_special( struct cons_pointer src, struct cons_pointer make_special( struct cons_pointer src,
struct cons_pointer ( *executable ) struct cons_pointer ( *executable )
( struct stack_frame *, ( struct stack_frame *,
struct cons_pointer, struct cons_pointer,
struct cons_pointer ) ); struct cons_pointer ) );
/**
* Construct a string from this character 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( wint_t c, struct cons_pointer tail ); struct cons_pointer make_string( wint_t c, struct cons_pointer tail );
/**
* Construct a symbol from this character and this tail. A symbol is identical
* to a string except for having a different tag.
*/
struct cons_pointer make_symbol( wint_t c, struct cons_pointer tail ); struct cons_pointer make_symbol( wint_t c, struct cons_pointer tail );
/**
* Construct a cell which points to a stream open for reading.
* @param input the C stream to wrap.
*/
struct cons_pointer make_read_stream( FILE * input ); struct cons_pointer make_read_stream( FILE * input );
/**
* Construct a cell which points to a stream open for writeing.
* @param output the C stream to wrap.
*/
struct cons_pointer make_write_stream( FILE * output ); struct cons_pointer make_write_stream( FILE * output );
/**
* Return a lisp string representation of this old skool ASCII string.
*/
struct cons_pointer c_string_to_lisp_string( wchar_t *string ); struct cons_pointer c_string_to_lisp_string( wchar_t *string );
/**
* Return a lisp symbol representation of this old skool ASCII string.
*/
struct cons_pointer c_string_to_lisp_symbol( wchar_t *symbol ); struct cons_pointer c_string_to_lisp_symbol( wchar_t *symbol );
#endif #endif

1
src/memory/dump.c
View file

@ -151,4 +151,3 @@ void dump_object( FILE * output, struct cons_pointer pointer ) {
break; break;
} }
} }

5
src/memory/dump.h
View file

@ -1,4 +1,4 @@
/** /*
* dump.h * dump.h
* *
* Dump representations of both cons space and vector space objects. * Dump representations of both cons space and vector space objects.
@ -20,9 +20,6 @@
#define __dump_h #define __dump_h
/**
* dump the object at this cons_pointer to this output stream.
*/
void dump_object( FILE * output, struct cons_pointer pointer ); void dump_object( FILE * output, struct cons_pointer pointer );
#endif #endif

25
src/memory/stack.c
View file

@ -26,14 +26,22 @@
#include "stack.h" #include "stack.h"
#include "vectorspace.h" #include "vectorspace.h"
/**
* 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 ) { void set_reg( struct stack_frame *frame, int reg, struct cons_pointer value ) {
debug_printf( DEBUG_STACK, L"Setting register %d to ", reg ); debug_printf( DEBUG_STACK, L"Setting register %d to ", reg );
debug_print_object( value, DEBUG_STACK ); debug_print_object( value, DEBUG_STACK );
debug_println( DEBUG_STACK ); debug_println( DEBUG_STACK );
frame->arg[reg++] = value; 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 ); inc_ref( value );
if ( reg > frame->args ) {
frame->args = reg; if ( reg == frame->args ) {
frame->args++;
} }
} }
@ -71,15 +79,10 @@ struct cons_pointer make_empty_frame( struct cons_pointer previous ) {
debug_dump_object( result, DEBUG_ALLOC ); debug_dump_object( result, DEBUG_ALLOC );
// debug_printf( DEBUG_STACK,
// L"make_empty_frame: got vector_space_object with size %lu, tag %4.4s\n",
// pointer_to_vso( result )->header.size,
// &pointer_to_vso( result )->header.tag.bytes );
if ( !nilp( result ) ) { if ( !nilp( result ) ) {
struct stack_frame *frame = get_stack_frame( result ); struct stack_frame *frame = get_stack_frame( result );
/* /*
* TODO: later, pop a frame off a free-list of stack frames * \todo later, pop a frame off a free-list of stack frames
*/ */
frame->previous = previous; frame->previous = previous;
@ -131,7 +134,7 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous,
struct cons_space_object cell = pointer2cell( args ); struct cons_space_object cell = pointer2cell( args );
/* /*
* TODO: if we were running on real massively parallel hardware, * \todo if we were running on real massively parallel hardware,
* each arg except the first should be handed off to another * each arg except the first should be handed off to another
* processor to be evaled in parallel; but see notes here: * processor to be evaled in parallel; but see notes here:
* https://github.com/simon-brooke/post-scarcity/wiki/parallelism * https://github.com/simon-brooke/post-scarcity/wiki/parallelism
@ -220,7 +223,7 @@ struct cons_pointer make_special_frame( struct cons_pointer previous,
*/ */
void free_stack_frame( struct stack_frame *frame ) { void free_stack_frame( struct stack_frame *frame ) {
/* /*
* TODO: later, push it back on the stack-frame freelist * \todo later, push it back on the stack-frame freelist
*/ */
debug_print( L"Entering free_stack_frame\n", DEBUG_ALLOC ); debug_print( L"Entering free_stack_frame\n", DEBUG_ALLOC );
for ( int i = 0; i < args_in_frame; i++ ) { for ( int i = 0; i < args_in_frame; i++ ) {

8
src/memory/stack.h
View file

@ -35,12 +35,6 @@
*/ */
#define stackframep(vso)(((struct vector_space_object *)vso)->header.tag.value == STACKFRAMETV) #define stackframep(vso)(((struct vector_space_object *)vso)->header.tag.value == STACKFRAMETV)
/**
* set a register in a stack frame. Alwaye use this macro to do so,
• because that way we can be sure the inc_ref happens!
*/
//#define set_reg(frame,register,value){frame->arg[register]=value; inc_ref(value);}
void set_reg( struct stack_frame *frame, int reg, struct cons_pointer value ); void set_reg( struct stack_frame *frame, int reg, struct cons_pointer value );
struct stack_frame *get_stack_frame( struct cons_pointer pointer ); struct stack_frame *get_stack_frame( struct cons_pointer pointer );
@ -65,7 +59,7 @@ struct cons_pointer make_special_frame( struct cons_pointer previous,
/* /*
* struct stack_frame is defined in consspaceobject.h to break circularity * struct stack_frame is defined in consspaceobject.h to break circularity
* TODO: refactor. * \todo refactor.
*/ */
#endif #endif

31
src/memory/vectorspace.c
View file

@ -26,19 +26,28 @@
/** /**
* make a cons-space object which points to the vector space object * Make a cons_space_object which points to the vector_space_object
* with this `tag` at this `address`. * with this `tag` at this `address`.
* NOTE that `tag` should be the vector-space tag of the particular type of *
* vector-space object, NOT `VECTORPOINTTAG`. * @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 `VECTORPOINTTAG`.
*
* @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 ) { struct cons_pointer make_vec_pointer( struct vector_space_object *address, char *tag ) {
debug_print( L"Entered make_vec_pointer\n", DEBUG_ALLOC ); debug_print( L"Entered make_vec_pointer\n", DEBUG_ALLOC );
struct cons_pointer pointer = allocate_cell( VECTORPOINTTAG ); struct cons_pointer pointer = allocate_cell( VECTORPOINTTAG );
struct cons_space_object *cell = &pointer2cell( pointer ); struct cons_space_object *cell = &pointer2cell( pointer );
debug_printf( DEBUG_ALLOC, debug_printf( DEBUG_ALLOC,
L"make_vec_pointer: tag written, about to set pointer address to %p\n", L"make_vec_pointer: tag written, about to set pointer address to %p\n",
address ); address );
cell->payload.vectorp.address = address; cell->payload.vectorp.address = address;
strncpy(&cell->payload.vectorp.tag.bytes[0], tag, TAGLENGTH);
debug_printf( DEBUG_ALLOC, debug_printf( DEBUG_ALLOC,
L"make_vec_pointer: all good, returning pointer to %p\n", L"make_vec_pointer: all good, returning pointer to %p\n",
cell->payload.vectorp.address ); cell->payload.vectorp.address );
@ -49,11 +58,15 @@ struct cons_pointer make_vec_pointer( struct vector_space_object *address ) {
} }
/** /**
* allocate a vector space object with this `payload_size` and `tag`, * 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. * and return a `cons_pointer` which points to an object whigh points to it.
* NOTE that `tag` should be the vector-space tag of the particular type of *
* vector-space object, NOT `VECTORPOINTTAG`. * @tag the vector-space tag of the particular type of vector-space object,
* Returns NIL if the vector could not be allocated due to memory exhaustion. * 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( char *tag, uint64_t payload_size ) { struct cons_pointer make_vso( char *tag, uint64_t payload_size ) {
debug_print( L"Entered make_vso\n", DEBUG_ALLOC ); debug_print( L"Entered make_vso\n", DEBUG_ALLOC );
@ -72,7 +85,7 @@ struct cons_pointer make_vso( char *tag, uint64_t payload_size ) {
L"make_vso: about to write tag '%s' into vso at %p\n", L"make_vso: about to write tag '%s' into vso at %p\n",
tag, vso ); tag, vso );
strncpy( &vso->header.tag.bytes[0], tag, TAGLENGTH ); strncpy( &vso->header.tag.bytes[0], tag, TAGLENGTH );
result = make_vec_pointer( vso ); result = make_vec_pointer( vso, tag );
debug_dump_object( result, DEBUG_ALLOC ); debug_dump_object( result, DEBUG_ALLOC );
vso->header.vecp = result; vso->header.vecp = result;
// memcpy(vso->header.vecp, result, sizeof(struct cons_pointer)); // memcpy(vso->header.vecp, result, sizeof(struct cons_pointer));

46
src/memory/vectorspace.h
View file

@ -40,32 +40,48 @@
#define VECTORTAG "VECT" #define VECTORTAG "VECT"
#define VECTORTV 0 #define VECTORTV 0
/**
* 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)) #define pointer_to_vso(pointer)((vectorpointp(pointer)? (struct vector_space_object *) pointer2cell(pointer).payload.vectorp.address : (struct vector_space_object *) NULL))
#define vso_get_vecp(vso)((vso->header.vecp))
/**
* 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( char *tag, uint64_t payload_size ); struct cons_pointer make_vso( char *tag, uint64_t payload_size );
/**
* the header which forms the start of every vector space object.
*/
struct vector_space_header { struct vector_space_header {
/** the tag (type) of this vector-space object. */
union { union {
char bytes[TAGLENGTH]; /* the tag (type) of the /** the tag considered as bytes. */
* vector-space object this cell char bytes[TAGLENGTH];
* points to, considered as bytes. /** the tag considered as a number */
* NOTE that the vector space object uint32_t value;
* should itself have the identical
* tag. */
uint32_t value; /* the tag considered as a number */
} tag; } tag;
struct cons_pointer vecp; /* back pointer to the vector pointer /** back pointer to the vector pointer which uniquely points to this vso */
* which uniquely points to this vso */ struct cons_pointer vecp;
uint64_t size; /* the size of my payload, in bytes */ /** the size of my payload, in bytes */
uint64_t size;
}; };
/** 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 { struct vector_space_object {
/** the header of this object */
struct vector_space_header header; struct vector_space_header header;
char payload; /* we'll malloc `size` bytes for payload, /** we'll malloc `size` bytes for payload, `payload` is just the first of these.
* `payload` is just the first of these. * \todo this is almost certainly not idiomatic C. */
* TODO: this is almost certainly not char payload;
* idiomatic C. */
}; };
#endif #endif

3
src/ops/intern.c
View file

@ -27,7 +27,8 @@
#include "print.h" #include "print.h"
/** /**
* The object list. What is added to this during system setup is 'global', that is, * 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 * 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 * 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 * make the contents of their own environment persistent between threads but I don't

25
src/ops/intern.h
View file

@ -1,4 +1,4 @@
/** /*
* intern.h * intern.h
* *
* For now this implements an oblist and shallow binding; local environments can * For now this implements an oblist and shallow binding; local environments can
@ -22,42 +22,19 @@
extern struct cons_pointer oblist; extern struct cons_pointer oblist;
/**
* return the value associated with this key in this store. In the current
* implementation a store is just an assoc list, but in future it might be a
* namespace, a regularity or a homogeneity.
*/
struct cons_pointer c_assoc( struct cons_pointer key, struct cons_pointer c_assoc( struct cons_pointer key,
struct cons_pointer store ); struct cons_pointer store );
/**
* Return true if this key is present as a key in this enviroment, defaulting to
* the oblist if no environment is passed.
*/
struct cons_pointer internedp( struct cons_pointer key, struct cons_pointer internedp( struct cons_pointer key,
struct cons_pointer environment ); struct cons_pointer environment );
/**
* 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 bind( struct cons_pointer key, struct cons_pointer bind( struct cons_pointer key,
struct cons_pointer value, struct cons_pointer value,
struct cons_pointer store ); struct cons_pointer store );
/**
* Binds this key to this value in the global oblist, but doesn't affect the
* current environment. May not be useful except in bootstrapping (and even
* there it may not be especially useful).
*/
struct cons_pointer deep_bind( struct cons_pointer key, struct cons_pointer deep_bind( struct cons_pointer key,
struct cons_pointer value ); struct cons_pointer value );
/**
* 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 NIL.
*/
struct cons_pointer intern( struct cons_pointer key, struct cons_pointer intern( struct cons_pointer key,
struct cons_pointer environment ); struct cons_pointer environment );

361
src/ops/lispops.c
View file

@ -39,9 +39,9 @@
/* /*
* also to create in this section: * also to create in this section:
* struct cons_pointer lisp_let( struct cons_pointer args, struct cons_pointer env, * struct cons_pointer lisp_let( struct cons_pointer args, struct cons_pointer env,
struct stack_frame* frame); * struct stack_frame* frame);
* struct cons_pointer lisp_mapcar( struct cons_pointer args, struct cons_pointer env, * struct cons_pointer lisp_mapcar( struct cons_pointer args, struct cons_pointer env,
struct stack_frame* frame); * struct stack_frame* frame);
* *
* and others I haven't thought of yet. * and others I haven't thought of yet.
*/ */
@ -109,9 +109,13 @@ struct cons_pointer eval_form( struct stack_frame *parent,
} }
/** /**
* eval all the forms in this `list` in the context of this stack `frame` * 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 * and this `env`, and return a list of their values. If the arg passed as
* `list` is not in fact a list, return nil. * `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 eval_forms( struct stack_frame *frame,
struct cons_pointer frame_pointer, struct cons_pointer frame_pointer,
@ -140,9 +144,8 @@ lisp_oblist( struct stack_frame *frame, struct cons_pointer frame_pointer,
return oblist; return oblist;
} }
/** /**
* used to construct the body for `lambda` and `nlambda` expressions. * Used to construct the body for `lambda` and `nlambda` expressions.
*/ */
struct cons_pointer compose_body( struct stack_frame *frame ) { struct cons_pointer compose_body( struct stack_frame *frame ) {
struct cons_pointer body = frame->more; struct cons_pointer body = frame->more;
@ -164,6 +167,8 @@ struct cons_pointer compose_body( struct stack_frame *frame ) {
/** /**
* Construct an interpretable function. * Construct an interpretable function.
* *
* (lambda args body)
*
* @param frame the stack frame in which the expression is to be interpreted; * @param frame the stack frame in which the expression is to be interpreted;
* @param env the environment in which it is to be intepreted. * @param env the environment in which it is to be intepreted.
*/ */
@ -176,6 +181,8 @@ lisp_lambda( struct stack_frame *frame, struct cons_pointer frame_pointer,
/** /**
* Construct an interpretable special form. * Construct an interpretable special form.
* *
* (nlambda args body)
*
* @param frame the stack frame in which the expression is to be interpreted; * @param frame the stack frame in which the expression is to be interpreted;
* @param env the environment in which it is to be intepreted. * @param env the environment in which it is to be intepreted.
*/ */
@ -220,11 +227,11 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
} }
inc_ref( new_env ); inc_ref( new_env );
/* TODO: if there's more than `args_in_frame` arguments, bind those too. */ /* \todo if there's more than `args_in_frame` arguments, bind those too. */
} else if ( symbolp( names ) ) { } else if ( symbolp( names ) ) {
/* if `names` is a symbol, rather than a list of symbols, /* if `names` is a symbol, rather than a list of symbols,
* then bind a list of the values of args to that symbol. */ * then bind a list of the values of args to that symbol. */
/* TODO: eval all the things in frame->more */ /* \todo eval all the things in frame->more */
struct cons_pointer vals = struct cons_pointer vals =
eval_forms( frame, frame_pointer, frame->more, env ); eval_forms( frame, frame_pointer, frame->more, env );
@ -412,17 +419,24 @@ struct cons_pointer c_type( struct cons_pointer pointer ) {
/** /**
* (eval s_expr) * Function; evaluate the expression which is the first argument in the frame;
* further arguments are ignored.
* *
* function. * * (eval expression)
* If s_expr is a number, NIL, or T, returns s_expr. *
* If s_expr is an unprotected string, returns the value that s_expr is bound * @param frame my stack_frame.
* to in the evaluation environment (env). * @param frame_pointer a pointer to my stack_frame.
* If s_expr is a list, expects the car to be something that evaluates to a * @param env my environment.
* function or special form. * @return
* If a function, evaluates all the other top level elements in s_expr and * * If `expression` is a number, string, `nil`, or `t`, returns `expression`.
* passes them in a stack frame as arguments to the function. * * If `expression` is a symbol, returns the value that expression is bound
* If a special form, passes the cdr of s_expr to the special form as argument. * 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 struct cons_pointer
lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer, lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer,
@ -457,12 +471,9 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer,
} }
break; break;
/* /*
* TODO: * \todo
* the Clojure practice of having a map serve in the function place of * 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; also if the * an s-expression is a good one and I should adopt it;
* object is a consp it could be interpretable source code but in the
* long run I don't want an interpreter, and if I can get away without
* so much the better.
*/ */
default: default:
result = frame->arg[0]; result = frame->arg[0];
@ -477,11 +488,16 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer,
/** /**
* (apply fn args) * Function; apply the function which is the result of evaluating the
* * first argument to the list of values which is the result of evaluating
* function. Apply the function which is the result of evaluating the
* first argoment to the list of arguments which is the result of evaluating
* the second argument * 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 struct cons_pointer
lisp_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, lisp_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
@ -502,11 +518,16 @@ lisp_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
/** /**
* (quote a) * Special form;
* * returns its argument (strictly first argument - only one is expected but
* Special form
* Returns its argument (strictly first argument - only one is expected but
* this isn't at this stage checked) unevaluated. * 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 struct cons_pointer
lisp_quote( struct stack_frame *frame, struct cons_pointer frame_pointer, lisp_quote( struct stack_frame *frame, struct cons_pointer frame_pointer,
@ -516,13 +537,19 @@ lisp_quote( struct stack_frame *frame, struct cons_pointer frame_pointer,
/** /**
* (set name value) * Function;
* (set name value namespace) * binds the value of `name` in the `namespace` to value of `value`, altering
* * the namespace in so doing. Retuns `value`.
* Function.
* `namespace` defaults to the oblist. * `namespace` defaults to the oblist.
* Binds the value of `name` in the `namespace` to value of `value`, altering * \todo doesn't actually work yet for namespaces which are not the oblist.
* the namespace in so doing. `namespace` defaults to the value of `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 struct cons_pointer
lisp_set( struct stack_frame *frame, struct cons_pointer frame_pointer, lisp_set( struct stack_frame *frame, struct cons_pointer frame_pointer,
@ -548,20 +575,25 @@ lisp_set( struct stack_frame *frame, struct cons_pointer frame_pointer,
/** /**
* (set! symbol value) * Special form;
* (set! symbol value namespace) * 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.
* *
* Special form. * * (set! symbol value)
* `namespace` defaults to the oblist. * * (set! symbol value namespace)
* Binds `symbol` in the `namespace` to value of `value`, altering *
* the namespace in so doing. `namespace` defaults to the value of `oblist`. * @param frame my stack_frame.
* @param frame_pointer a pointer to my stack_frame.
* @param env my environment (ignored).
* @return `value`
*/ */
struct cons_pointer struct cons_pointer
lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer, lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) { struct cons_pointer env ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
struct cons_pointer namespace = struct cons_pointer namespace = frame->arg[2];
nilp( frame->arg[2] ) ? oblist : frame->arg[2];
if ( symbolp( frame->arg[0] ) ) { if ( symbolp( frame->arg[0] ) ) {
struct cons_pointer val = struct cons_pointer val =
@ -581,12 +613,17 @@ lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer,
} }
/** /**
* (cons a b) * Function;
* * returns a cell constructed from a and b. If a is of type string but its
* 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; * cdr is nill, and b is of type string, then returns a new string cell;
* otherwise returns a new cons cell. * otherwise returns a new cons cell.
*
* * (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 struct cons_pointer
lisp_cons( struct stack_frame *frame, struct cons_pointer frame_pointer, lisp_cons( struct stack_frame *frame, struct cons_pointer frame_pointer,
@ -597,8 +634,8 @@ lisp_cons( struct stack_frame *frame, struct cons_pointer frame_pointer,
if ( nilp( car ) && nilp( cdr ) ) { if ( nilp( car ) && nilp( cdr ) ) {
return NIL; return NIL;
} else if ( stringp( car ) && stringp( cdr ) && } else if ( stringp( car ) && stringp( cdr )) {
nilp( pointer2cell( car ).payload.string.cdr ) ) { // \todo check that car is of length 1
result = result =
make_string( pointer2cell( car ).payload.string.character, cdr ); make_string( pointer2cell( car ).payload.string.character, cdr );
} else { } else {
@ -609,9 +646,17 @@ lisp_cons( struct stack_frame *frame, struct cons_pointer frame_pointer,
} }
/** /**
* (car s_expr) * Function;
* Returns the first item (head) of a sequence. Valid for cons cells, * returns the first item (head) of a sequence. Valid for cons cells,
* strings, and TODO read streams and other things which can be considered as sequences. * 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 struct cons_pointer
lisp_car( struct stack_frame *frame, struct cons_pointer frame_pointer, lisp_car( struct stack_frame *frame, struct cons_pointer frame_pointer,
@ -626,11 +671,11 @@ lisp_car( struct stack_frame *frame, struct cons_pointer frame_pointer,
case READTV: case READTV:
result = make_string( fgetwc( cell.payload.stream.stream ), NIL ); result = make_string( fgetwc( cell.payload.stream.stream ), NIL );
break; break;
case NILTV:
break;
case STRINGTV: case STRINGTV:
result = make_string( cell.payload.string.character, NIL ); result = make_string( cell.payload.string.character, NIL );
break; break;
case NILTV:
break;
default: default:
result = result =
throw_exception( c_string_to_lisp_string throw_exception( c_string_to_lisp_string
@ -642,11 +687,19 @@ lisp_car( struct stack_frame *frame, struct cons_pointer frame_pointer,
} }
/** /**
* (cdr s_expr) * Function;
* Returns the remainder of a sequence when the head is removed. Valid for cons cells, * returns the remainder of a sequence when the head is removed. Valid for cons cells,
* strings, and TODO read streams and other things which can be considered as sequences. * 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 * *NOTE* that if the argument is an input stream, the first character is removed AND
* DISCARDED. * 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 struct cons_pointer
lisp_cdr( struct stack_frame *frame, struct cons_pointer frame_pointer, lisp_cdr( struct stack_frame *frame, struct cons_pointer frame_pointer,
@ -678,8 +731,14 @@ lisp_cdr( struct stack_frame *frame, struct cons_pointer frame_pointer,
} }
/** /**
* (assoc key store) * Function; look up the value of a `key` in a `store`.
* Returns the value associated with key in store, or NIL if not found. *
* * (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 struct cons_pointer
lisp_assoc( struct stack_frame *frame, struct cons_pointer frame_pointer, lisp_assoc( struct stack_frame *frame, struct cons_pointer frame_pointer,
@ -688,8 +747,14 @@ lisp_assoc( struct stack_frame *frame, struct cons_pointer frame_pointer,
} }
/** /**
* (eq a b) * Function; are these two objects the same object? Shallow, cheap equality.
* Returns T if a and b are pointers to the same object, else NIL *
* * (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 lisp_eq( struct stack_frame *frame,
struct cons_pointer frame_pointer, struct cons_pointer frame_pointer,
@ -698,8 +763,14 @@ struct cons_pointer lisp_eq( struct stack_frame *frame,
} }
/** /**
* (eq a b) * Function; are these two arguments identical? Deep, expensive equality.
* Returns T if a and b are pointers to structurally identical objects, else NIL *
* * (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 struct cons_pointer
lisp_equal( struct stack_frame *frame, struct cons_pointer frame_pointer, lisp_equal( struct stack_frame *frame, struct cons_pointer frame_pointer,
@ -728,10 +799,17 @@ struct cons_pointer get_default_stream( bool inputp, struct cons_pointer env ) {
/** /**
* (read) * Function; read one complete lisp form and return it. If read-stream is specified and
* (read read-stream) * is a read stream, then read from that stream, else the stream which is the value of
* Read one complete lisp form and return it. If read-stream is specified and * `*in*` in the environment.
* is a read stream, then read from that stream, else stdin. *
* * (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 struct cons_pointer
lisp_read( struct stack_frame *frame, struct cons_pointer frame_pointer, lisp_read( struct stack_frame *frame, struct cons_pointer frame_pointer,
@ -788,8 +866,14 @@ struct cons_pointer c_reverse( struct cons_pointer arg ) {
/** /**
* (reverse sequence) * Function; reverse the order of members in s sequence.
* Return a sequence like this sequence but with the members in the reverse order. *
* * (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 lisp_reverse( struct stack_frame *frame,
struct cons_pointer frame_pointer, struct cons_pointer frame_pointer,
@ -799,10 +883,17 @@ struct cons_pointer lisp_reverse( struct stack_frame *frame,
/** /**
* (print expr) * Function; print one complete lisp expression and return NIL. If write-stream is specified and
* (print expr write-stream) * is a write stream, then print to that stream, else the stream which is the value of
* Print one complete lisp form and return NIL. If write-stream is specified and * `*out*` in the environment.
* is a write stream, then print to that stream, else stdout. *
* * (print expr)
* * (print expr write-stream)
*
* @param frame my stack_frame.
* @param frame_pointer a pointer to my stack_frame.
* @param env my environment (ignored).
* @return the value of `expr`.
*/ */
struct cons_pointer struct cons_pointer
lisp_print( struct stack_frame *frame, struct cons_pointer frame_pointer, lisp_print( struct stack_frame *frame, struct cons_pointer frame_pointer,
@ -837,10 +928,14 @@ lisp_print( struct stack_frame *frame, struct cons_pointer frame_pointer,
/** /**
* Function: Get the Lisp type of the single argument. * Function: get the Lisp type of the single argument.
* @param frame My stack frame. *
* @param env My environment (ignored). * * (type expression)
* @return As a Lisp string, the tag of the object which is the argument. *
* @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 struct cons_pointer
lisp_type( struct stack_frame *frame, struct cons_pointer frame_pointer, lisp_type( struct stack_frame *frame, struct cons_pointer frame_pointer,
@ -849,21 +944,21 @@ lisp_type( struct stack_frame *frame, struct cons_pointer frame_pointer,
} }
/** /**
* Evaluate each of these forms in this `env`ironment over this `frame`, * Evaluate each of these expressions in this `env`ironment over this `frame`,
* returning only the value of the last. * returning only the value of the last.
*/ */
struct cons_pointer struct cons_pointer
c_progn( struct stack_frame *frame, struct cons_pointer frame_pointer, c_progn( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer forms, struct cons_pointer env ) { struct cons_pointer expressions, struct cons_pointer env ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
while ( consp( forms ) ) { while ( consp( expressions ) ) {
struct cons_pointer r = result; struct cons_pointer r = result;
inc_ref( r ); inc_ref( r );
result = eval_form( frame, frame_pointer, c_car( forms ), env ); result = eval_form( frame, frame_pointer, c_car( expressions ), env );
dec_ref( r ); dec_ref( r );
forms = c_cdr( forms ); expressions = c_cdr( expressions );
} }
return result; return result;
@ -871,15 +966,16 @@ c_progn( struct stack_frame *frame, struct cons_pointer frame_pointer,
/** /**
* (progn forms...) * Special form; evaluate the expressions which are listed in my arguments
*
* Special form; evaluate the forms which are listed in my arguments
* sequentially and return the value of the last. This function is called 'do' * sequentially and return the value of the last. This function is called 'do'
* in some dialects of Lisp. * in some dialects of Lisp.
* *
* @param frame My stack frame. * * (progn expressions...)
* @param env My environment (ignored). *
* @return the value of the last form on the sequence which is my single * @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. * argument.
*/ */
struct cons_pointer struct cons_pointer
@ -904,16 +1000,20 @@ lisp_progn( struct stack_frame *frame, struct cons_pointer frame_pointer,
} }
/** /**
* Special form: conditional. Each arg is expected to be a list; if the first * 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 * 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) * 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. * has a first element which evaluates to non NIL, then NIL is returned.
* @param frame My stack frame. *
* @param env My environment (ignored). * * (cond clauses...)
* @return the value of the last form of the first successful clause. *
* @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 struct cons_pointer
lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer, lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) { struct cons_pointer env ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
bool done = false; bool done = false;
@ -943,7 +1043,7 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer,
frame_pointer ); frame_pointer );
} }
} }
/* TODO: if there are more than 8 clauses we need to continue into the /* \todo if there are more than 8 clauses we need to continue into the
* remainder */ * remainder */
return result; return result;
@ -978,9 +1078,18 @@ throw_exception( struct cons_pointer message,
} }
/** /**
* (exception <message>) * 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.
* *
* Function. Returns an exception whose message is this `message`, and whose * * (exception <message> <frame>)
*
* @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. * 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 * `message` does not have to be a string but should be something intelligible
* which can be read. * which can be read.
@ -995,19 +1104,23 @@ lisp_exception( struct stack_frame *frame, struct cons_pointer frame_pointer,
} }
/** /**
* (repl) * Function: the read/eval/print loop.
* (repl prompt)
* (repl prompt input_stream output_stream)
* *
* Function: the read/eval/print loop. Returns the value of the last expression * * (repl)
* entered. * * (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 lisp_repl( struct stack_frame *frame,
struct cons_pointer frame_pointer, struct cons_pointer frame_pointer,
struct cons_pointer env ) { struct cons_pointer env ) {
struct cons_pointer expr = NIL; struct cons_pointer expr = NIL;
/* TODO: bind *prompt*, *input*, *output* in the environment to the values /* \todo bind *prompt*, *input*, *output* in the environment to the values
* of arguments 0, 1, and 2 respectively, but in each case only if the * of arguments 0, 1, and 2 respectively, but in each case only if the
* argument is not nil */ * argument is not nil */
@ -1023,7 +1136,7 @@ struct cons_pointer lisp_repl( struct stack_frame *frame,
inc_ref( output ); inc_ref( output );
inc_ref( prompt_name ); inc_ref( prompt_name );
/* TODO: this is subtly wrong. If we were evaluating /* \todo this is subtly wrong. If we were evaluating
* (print (eval (read))) * (print (eval (read)))
* then the stack frame for read would have the stack frame for * 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 * eval as parent, and it in turn would have the stack frame for
@ -1035,7 +1148,7 @@ struct cons_pointer lisp_repl( struct stack_frame *frame,
* bound in the oblist subsequent to this function being invoked isn't in the * 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 * 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. * 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 * \todo the whole process of resolving symbol values needs to be revisited
* when we get onto namespaces. */ * when we get onto namespaces. */
if ( !eq( oblist, old_oblist ) ) { if ( !eq( oblist, old_oblist ) ) {
struct cons_pointer cursor = oblist; struct cons_pointer cursor = oblist;
@ -1089,11 +1202,16 @@ struct cons_pointer lisp_repl( struct stack_frame *frame,
} }
/** /**
* (source object) * Function. return the source code of the object which is its first argument,
* if it is an executable and has source code.
* *
* Function. * * (source object)
* Return the source code of the object, if it is an executable *
* and has source code. * @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 lisp_source( struct stack_frame *frame,
struct cons_pointer frame_pointer, struct cons_pointer frame_pointer,
@ -1119,7 +1237,7 @@ struct cons_pointer lisp_source( struct stack_frame *frame,
cell.payload.lambda.body ) ); cell.payload.lambda.body ) );
break; break;
} }
// TODO: suffers from premature GC, and I can't see why! // \todo suffers from premature GC, and I can't see why!
inc_ref( result ); inc_ref( result );
return result; return result;
@ -1127,11 +1245,20 @@ struct cons_pointer lisp_source( struct stack_frame *frame,
/** /**
* Print the internal representation of the object indicated by `frame->arg[0]` to the * Function; print the internal representation of the object indicated by `frame->arg[0]` to the
* (optional, defaults to `stdout`) stream indicated by `frame->arg[1]`. * (optional, defaults to the value of `*out*` in the environment) stream indicated by `frame->arg[1]`.
*
* * (inspect expression)
* * (inspect expression <write-stream>)
*
* @param frame my stack frame.
* @param frame_pointer a pointer to my stack_frame.
* @param env the environment.
* @return the value of the first argument - `expression`.
*/ */
struct cons_pointer lisp_inspect( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer lisp_inspect( struct stack_frame *frame,
struct cons_pointer env ) { struct cons_pointer frame_pointer,
struct cons_pointer env ) {
debug_print( L"Entering print\n", DEBUG_IO ); debug_print( L"Entering print\n", DEBUG_IO );
FILE *output = stdout; FILE *output = stdout;
struct cons_pointer out_stream = writep( frame->arg[1] ) ? struct cons_pointer out_stream = writep( frame->arg[1] ) ?

5
src/ops/lispops.h
View file

@ -202,5 +202,6 @@ struct cons_pointer lisp_source( struct stack_frame *frame,
struct cons_pointer frame_pointer, struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );
struct cons_pointer lisp_inspect( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer lisp_inspect( struct stack_frame *frame,
struct cons_pointer env ); struct cons_pointer frame_pointer,
struct cons_pointer env );

12
src/ops/print.c
View file

@ -25,7 +25,7 @@
/** /**
* Whether or not we colorise output. * Whether or not we colorise output.
* TODO: this should be a Lisp symbol binding, not a C variable. * \todo this should be a Lisp symbol binding, not a C variable.
*/ */
int print_use_colours = 0; int print_use_colours = 0;
@ -122,7 +122,7 @@ struct cons_pointer print( FILE * output, struct cons_pointer pointer ) {
dump_stack_trace( output, pointer ); dump_stack_trace( output, pointer );
break; break;
case FUNCTIONTV: case FUNCTIONTV:
fwprintf( output, L"(Function)" ); fwprintf( output, L"<Function>" );
break; break;
case INTEGERTV:{ case INTEGERTV:{
struct cons_pointer s = integer_to_string( pointer, 10 ); struct cons_pointer s = integer_to_string( pointer, 10 );
@ -167,10 +167,10 @@ struct cons_pointer print( FILE * output, struct cons_pointer pointer ) {
print( output, cell.payload.ratio.divisor ); print( output, cell.payload.ratio.divisor );
break; break;
case READTV: case READTV:
fwprintf( output, L"(Input stream)" ); fwprintf( output, L"<Input stream>" );
break; break;
case REALTV: case REALTV:
/* TODO: using the C heap is a bad plan because it will fragment. /* \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 * As soon as I have working vector space I'll use a special purpose
* vector space object */ * vector space object */
buffer = ( char * ) malloc( 24 ); buffer = ( char * ) malloc( 24 );
@ -201,13 +201,13 @@ struct cons_pointer print( FILE * output, struct cons_pointer pointer ) {
print_string_contents( output, pointer ); print_string_contents( output, pointer );
break; break;
case SPECIALTV: case SPECIALTV:
fwprintf( output, L"(Special form)" ); fwprintf( output, L"<Special form>" );
break; break;
case TRUETV: case TRUETV:
fwprintf( output, L"t" ); fwprintf( output, L"t" );
break; break;
case WRITETV: case WRITETV:
fwprintf( output, L"(Output stream)" ); fwprintf( output, L"<Output stream>" );
break; break;
default: default:
fwprintf( stderr, fwprintf( stderr,

8
src/ops/read.c
View file

@ -119,7 +119,7 @@ struct cons_pointer read_continuation( struct stack_frame *frame,
read_number( frame, frame_pointer, input, c, read_number( frame, frame_pointer, input, c,
true ); true );
} else if ( iswblank( next ) ) { } else if ( iswblank( next ) ) {
/* dotted pair. TODO: this isn't right, we /* dotted pair. \todo this isn't right, we
* really need to backtrack up a level. */ * really need to backtrack up a level. */
result = result =
read_continuation( frame, frame_pointer, input, read_continuation( frame, frame_pointer, input,
@ -153,7 +153,7 @@ struct cons_pointer read_continuation( struct stack_frame *frame,
/** /**
* read a number from this input stream, given this initial character. * 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 * \todo Need to do a lot of inc_ref and dec_ref, to make sure the
* garbage is collected. * garbage is collected.
*/ */
struct cons_pointer read_number( struct stack_frame *frame, struct cons_pointer read_number( struct stack_frame *frame,
@ -163,7 +163,7 @@ struct cons_pointer read_number( struct stack_frame *frame,
debug_print( L"entering read_number\n", DEBUG_IO ); debug_print( L"entering read_number\n", DEBUG_IO );
struct cons_pointer result = make_integer( 0, NIL ); struct cons_pointer result = make_integer( 0, NIL );
/* TODO: we really need to be getting `base` from a privileged Lisp name - /* \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 */ * and it should be the same privileged name we use when writing numbers */
struct cons_pointer base = make_integer( 10, NIL ); struct cons_pointer base = make_integer( 10, NIL );
struct cons_pointer dividend = NIL; struct cons_pointer dividend = NIL;
@ -298,7 +298,7 @@ struct cons_pointer read_string( FILE * input, wint_t initial ) {
struct cons_pointer result; struct cons_pointer result;
switch ( initial ) { switch ( initial ) {
case '\0': case '\0':
result = make_string( initial, NIL ); result = NIL;
break; break;
case '"': case '"':
/* making a string of the null character means we can have an empty /* making a string of the null character means we can have an empty

25
unit-tests/string-cons.sh Normal file
View file

@ -0,0 +1,25 @@
#!/bin/bash
# We should be able to cons a single character string onto the front of a string
expected='"Test"'
actual=`echo '(cons "T" "est")' | target/psse | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
exit 1
fi
# But if the first argument has more than one character, we should get a dotted pair
expected='("Test" . "pass")'
actual=`echo '(cons "Test" "pass")' | target/psse | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
exit 1
fi