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

Merge branch 'release/0.0.4'

Browse source
This commit is contained in:
Simon Brooke 2018-12-28 22:36:43 +00:00
parent 614e20ab45 2d5fc4a202
commit 4033dbc82a
No known key found for this signature in database
GPG key ID: A7A4F18D1D4DF987
53 changed files with 2872 additions and 1002 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

10
.gitignore vendored
View file

@ -28,3 +28,13 @@ log*
\.project
\.settings/language\.settings\.xml
utils_src/readprintwc/out
.kdev4/
.vscode/
hi.*
post-scarcity.kdev4

8
Doxyfile
View file

@ -32,7 +32,7 @@ DOXYFILE_ENCODING = UTF-8
# title of most generated pages and in a few other places.
# The default value is: My Project.
PROJECT_NAME = "\"Post Scarcity\""
PROJECT_NAME = "Post Scarcity"
# The PROJECT_NUMBER tag can be used to enter a project or revision number. This
# could be handy for archiving the generated documentation or if some version
@ -58,7 +58,7 @@ PROJECT_LOGO =
# entered, it will be relative to the location where doxygen was started. If
# left blank the current directory will be used.
OUTPUT_DIRECTORY = /home/simon/workspace/post-scarcity/doc
OUTPUT_DIRECTORY = doc
# If the CREATE_SUBDIRS tag is set to YES then doxygen will create 4096 sub-
# directories (in 2 levels) under the output directory of each output format and
@ -778,7 +778,7 @@ WARN_FORMAT = "$file:$line: $text"
# messages should be written. If left blank the output is written to standard
# error (stderr).
WARN_LOGFILE =
WARN_LOGFILE = doxy.log
#---------------------------------------------------------------------------
# Configuration options related to the input files
@ -790,7 +790,7 @@ WARN_LOGFILE =
# spaces. See also FILE_PATTERNS and EXTENSION_MAPPING
# Note: If this tag is empty the current directory is searched.
INPUT = /home/simon/workspace/post-scarcity/src
INPUT = src src/arith src/memory src/ops
# 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

6
Makefile
View file

@ -17,13 +17,13 @@ INDENT_FLAGS := -nbad -bap -nbc -br -brf -brs -c33 -cd33 -ncdb -ce -ci4 -cli4 \
VERSION := "0.0.2"
CPPFLAGS ?= $(INC_FLAGS) -MMD -MP -g
CPPFLAGS ?= $(INC_FLAGS) -MMD -MP -g -DDEBUG
LDFLAGS := -lm
$(TARGET): $(OBJS) Makefile
$(CC) $(LDFLAGS) $(OBJS) -DVERSION=$(VERSION) -o $@ $(LDFLAGS) $(LOADLIBES) $(LDLIBS)
doc: $(SRCS) Makefile
doc: $(SRCS) Makefile Doxyfile
doxygen
format: $(SRCS) $(HDRS) Makefile
@ -38,7 +38,7 @@ test: $(OBJS) $(TESTS) Makefile
.PHONY: clean
clean:
$(RM) $(TARGET) $(OBJS) $(DEPS) $(SRC_DIRS)/*~ *~
$(RM) $(TARGET) $(OBJS) $(DEPS) $(SRC_DIRS)/*~ $(SRC_DIRS)/*/*~ *~
repl:
$(TARGET) -p 2> psse.log

8
lisp/defun.lisp
View file

@ -1,10 +1,12 @@
;; Because I don't (yet) have syntax for varargs, the body must be passed
;; to defun as a list of sexprs.
(set! list (lambda l l))
(set! symbolp (lambda (x) (equal (type x) "SYMB")))
(set! defun!
(nlambda
form
(cond ((symbolp (car form))
(set (car form) (apply lambda (cdr form))))
(set (car form) (apply 'lambda (cdr form))))
(t nil))))
(defun! square (x) (* x x))

14
src/arith/bignum.c Normal file
View file

@ -0,0 +1,14 @@
/*
* bignum.c
*
* Allocation of and operations on arbitrary precision integers.
*
* (c) 2018 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
/*
* Bignums generally follow Knuth, vol 2, 4.3. The word size is 64 bits,
* and words are stored in individual cons-space objects, comprising the
* word itself and a pointer to the next word in the number.
*/

16
src/arith/bignum.h Normal file
View file

@ -0,0 +1,16 @@
/**
* bignum.h
*
* functions for bignum cells.
*
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#ifndef __bignum_h
#define __bignum_h
#endif

6
src/integer.c → src/arith/integer.c
View file

@ -13,7 +13,7 @@
#include "conspage.h"
#include "consspaceobject.h"
#include "read.h"
#include "debug.h"
/**
* return the numeric value of this cell, as a C primitive double, not
@ -36,12 +36,12 @@ 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( long int value ) {
struct cons_pointer make_integer( int64_t value ) {
struct cons_pointer result = allocate_cell( INTEGERTAG );
struct cons_space_object *cell = &pointer2cell( result );
cell->payload.integer.value = value;
dump_object( stderr, result );
debug_dump_object( result, DEBUG_ARITH );
return result;
}

2
src/integer.h → src/arith/integer.h
View file

@ -16,6 +16,6 @@ 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( long int value );
struct cons_pointer make_integer( int64_t value );
#endif

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

@ -0,0 +1,636 @@
/*
* peano.c
*
* Basic peano arithmetic
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <ctype.h>
#include <math.h>
#include <stdbool.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include "consspaceobject.h"
#include "conspage.h"
#include "debug.h"
#include "equal.h"
#include "integer.h"
#include "intern.h"
#include "lispops.h"
#include "print.h"
#include "ratio.h"
#include "read.h"
#include "real.h"
#include "stack.h"
long double to_long_double( struct cons_pointer arg );
int64_t to_long_int( struct cons_pointer arg );
struct cons_pointer add_2( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer arg1,
struct cons_pointer arg2 );
bool zerop( struct cons_pointer arg ) {
bool result = false;
struct cons_space_object cell = pointer2cell( arg );
switch ( cell.tag.value ) {
case INTEGERTV:
result = cell.payload.integer.value == 0;
break;
case RATIOTV:
result = zerop( cell.payload.ratio.dividend );
break;
case REALTV:
result = ( cell.payload.real.value == 0 );
break;
}
return result;
}
/**
* TODO: cannot throw an exception out of here, which is a problem
* if a ratio may legally have zero as a divisor, or something which is
* not a number is passed in.
*/
long double to_long_double( struct cons_pointer arg ) {
long double result = 0; /* not a number, as a long double */
struct cons_space_object cell = pointer2cell( arg );
switch ( cell.tag.value ) {
case INTEGERTV:
result = ( double ) cell.payload.integer.value;
break;
case RATIOTV:
{
struct cons_space_object dividend =
pointer2cell( cell.payload.ratio.dividend );
struct cons_space_object divisor =
pointer2cell( cell.payload.ratio.divisor );
result =
( long double ) dividend.payload.integer.value /
divisor.payload.integer.value;
}
break;
case REALTV:
result = cell.payload.real.value;
break;
default:
result = NAN;
break;
}
debug_print( L"to_long_double( ", DEBUG_ARITH );
debug_print_object( arg, DEBUG_ARITH );
debug_printf( DEBUG_ARITH, L") => %lf\n", result );
return result;
}
/**
* TODO: cannot throw an exception out of here, which is a problem
* if a ratio may legally have zero as a divisor, or something which is
* not a number (or is a big number) is passed in.
*/
int64_t to_long_int( struct cons_pointer arg ) {
int64_t result = 0;
struct cons_space_object cell = pointer2cell( arg );
switch ( cell.tag.value ) {
case INTEGERTV:
result = cell.payload.integer.value;
break;
case RATIOTV:
result = lroundl( to_long_double( arg ) );
break;
case REALTV:
result = lroundl( cell.payload.real.value );
break;
}
return result;
}
/**
* return a cons_pointer indicating a number which is the sum of
* the numbers indicated by `arg1` and `arg2`.
*/
struct cons_pointer add_2( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer arg1,
struct cons_pointer arg2 ) {
struct cons_pointer result;
struct cons_space_object cell1 = pointer2cell( arg1 );
struct cons_space_object cell2 = pointer2cell( arg2 );
debug_print( L"add_2( arg1 = ", DEBUG_ARITH );
debug_print_object( arg1, DEBUG_ARITH );
debug_print( L"; arg2 = ", DEBUG_ARITH );
debug_print_object( arg2, DEBUG_ARITH );
debug_print( L"\n", DEBUG_ARITH );
if ( zerop( arg1 ) ) {
result = arg2;
} else if ( zerop( arg2 ) ) {
result = arg1;
} else {
switch ( cell1.tag.value ) {
case EXCEPTIONTV:
result = arg1;
break;
case INTEGERTV:
switch ( cell2.tag.value ) {
case EXCEPTIONTV:
result = arg2;
break;
case INTEGERTV:
result = make_integer( cell1.payload.integer.value +
cell2.payload.integer.value );
break;
case RATIOTV:
result =
add_integer_ratio( frame_pointer, arg1, arg2 );
break;
case REALTV:
result =
make_real( to_long_double( arg1 ) +
to_long_double( arg2 ) );
break;
default:
result = throw_exception( c_string_to_lisp_string
( L"Cannot add: not a number" ),
frame_pointer );
break;
}
break;
case RATIOTV:
switch ( cell2.tag.value ) {
case EXCEPTIONTV:
result = arg2;
break;
case INTEGERTV:
result =
add_integer_ratio( frame_pointer, arg2, arg1 );
break;
case RATIOTV:
result = add_ratio_ratio( frame_pointer, arg1, arg2 );
break;
case REALTV:
result =
make_real( to_long_double( arg1 ) +
to_long_double( arg2 ) );
break;
default:
result = throw_exception( c_string_to_lisp_string
( L"Cannot add: not a number" ),
frame_pointer );
break;
}
break;
case REALTV:
result =
make_real( to_long_double( arg1 ) +
to_long_double( arg2 ) );
break;
default:
result = exceptionp( arg2 ) ? arg2 :
throw_exception( c_string_to_lisp_string
( L"Cannot add: not a number" ),
frame_pointer );
}
}
debug_print( L"}; => ", DEBUG_ARITH );
debug_print_object( arg2, DEBUG_ARITH );
debug_print( L"\n", DEBUG_ARITH );
return result;
}
/**
* Add an indefinite number of numbers together
* @param env the evaluation environment - ignored;
* @param frame the stack frame.
* @return a pointer to an integer or real.
*/
struct cons_pointer lisp_add( struct stack_frame
*frame, struct cons_pointer frame_pointer, struct
cons_pointer env ) {
struct cons_pointer result = make_integer( 0 );
struct cons_pointer tmp;
for ( int i = 0;
i < args_in_frame &&
!nilp( frame->arg[i] ) && !exceptionp( result ); i++ ) {
tmp = result;
result = add_2( frame, frame_pointer, result, frame->arg[i] );
if ( !eq( tmp, result ) ) {
dec_ref( tmp );
}
}
struct cons_pointer more = frame->more;
while ( consp( more ) && !exceptionp( result ) ) {
tmp = result;
result = add_2( frame, frame_pointer, result, c_car( more ) );
if ( !eq( tmp, result ) ) {
dec_ref( tmp );
}
more = c_cdr( more );
}
return result;
}
/**
* return a cons_pointer indicating a number which is the product of
* the numbers indicated by `arg1` and `arg2`.
*/
struct cons_pointer multiply_2( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer arg1,
struct cons_pointer arg2 ) {
struct cons_pointer result;
struct cons_space_object cell1 = pointer2cell( arg1 );
struct cons_space_object cell2 = pointer2cell( arg2 );
debug_print( L"multiply_2( arg1 = ", DEBUG_ARITH );
debug_print_object( arg1, DEBUG_ARITH );
debug_print( L"; arg2 = ", DEBUG_ARITH );
debug_print_object( arg2, DEBUG_ARITH );
debug_print( L")", DEBUG_ARITH );
if ( zerop( arg1 ) ) {
result = arg2;
} else if ( zerop( arg2 ) ) {
result = arg1;
} else {
switch ( cell1.tag.value ) {
case EXCEPTIONTV:
result = arg1;
break;
case INTEGERTV:
switch ( cell2.tag.value ) {
case EXCEPTIONTV:
result = arg2;
break;
case INTEGERTV:
result = make_integer( cell1.payload.integer.value *
cell2.payload.integer.value );
break;
case RATIOTV:
result =
multiply_integer_ratio( frame_pointer, arg1,
arg2 );
break;
case REALTV:
result =
make_real( to_long_double( arg1 ) *
to_long_double( arg2 ) );
break;
default:
result = throw_exception( c_string_to_lisp_string
( L"Cannot multiply: not a number" ),
frame_pointer );
break;
}
break;
case RATIOTV:
switch ( cell2.tag.value ) {
case EXCEPTIONTV:
result = arg2;
break;
case INTEGERTV:
result =
multiply_integer_ratio( frame_pointer, arg2,
arg1 );
break;
case RATIOTV:
result =
multiply_ratio_ratio( frame_pointer, arg1, arg2 );
break;
case REALTV:
result =
make_real( to_long_double( arg1 ) *
to_long_double( arg2 ) );
break;
default:
result = throw_exception( c_string_to_lisp_string
( L"Cannot multiply: not a number" ),
frame_pointer );
}
break;
case REALTV:
result = exceptionp( arg2 ) ? arg2 :
make_real( to_long_double( arg1 ) *
to_long_double( arg2 ) );
break;
default:
result = throw_exception( c_string_to_lisp_string
( L"Cannot multiply: not a number" ),
frame_pointer );
break;
}
}
debug_print( L" => ", DEBUG_ARITH );
debug_print_object( arg2, DEBUG_ARITH );
debug_print( L"\n", DEBUG_ARITH );
return result;
}
/**
* Multiply an indefinite number of numbers together
* @param env the evaluation environment - ignored;
* @param frame the stack frame.
* @return a pointer to an integer or real.
*/
struct cons_pointer lisp_multiply( struct
stack_frame
*frame, struct cons_pointer frame_pointer, struct
cons_pointer env ) {
struct cons_pointer result = make_integer( 1 );
struct cons_pointer tmp;
for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] )
&& !exceptionp( result ); i++ ) {
tmp = result;
result = multiply_2( frame, frame_pointer, result, frame->arg[i] );
if ( !eq( tmp, result ) ) {
dec_ref( tmp );
}
}
struct cons_pointer more = frame->more;
while ( consp( more )
&& !exceptionp( result ) ) {
tmp = result;
result = multiply_2( frame, frame_pointer, result, c_car( more ) );
if ( !eq( tmp, result ) ) {
dec_ref( tmp );
}
more = c_cdr( more );
}
return result;
}
/**
* return a cons_pointer indicating a number which is the
* inverse of the number indicated by `arg`.
*/
struct cons_pointer inverse( struct cons_pointer frame,
struct cons_pointer arg ) {
struct cons_pointer result = NIL;
struct cons_space_object cell = pointer2cell( arg );
switch ( cell.tag.value ) {
case EXCEPTIONTV:
result = arg;
break;
case INTEGERTV:
result = make_integer( 0 - to_long_int( arg ) );
break;
case NILTV:
result = TRUE;
break;
case RATIOTV:
result = make_ratio( frame,
make_integer( 0 -
to_long_int( cell.payload.
ratio.dividend ) ),
cell.payload.ratio.divisor );
break;
case REALTV:
result = make_real( 0 - to_long_double( arg ) );
break;
case TRUETV:
result = NIL;
break;
}
return result;
}
/**
* Subtract one number from another.
* @param env the evaluation environment - ignored;
* @param frame the stack frame.
* @return a pointer to an integer or real.
*/
struct cons_pointer lisp_subtract( struct
stack_frame
*frame, struct cons_pointer frame_pointer, struct
cons_pointer env ) {
struct cons_pointer result = NIL;
struct cons_space_object cell0 = pointer2cell( frame->arg[0] );
struct cons_space_object cell1 = pointer2cell( frame->arg[1] );
switch ( cell0.tag.value ) {
case EXCEPTIONTV:
result = frame->arg[0];
break;
case INTEGERTV:
switch ( cell1.tag.value ) {
case EXCEPTIONTV:
result = frame->arg[1];
break;
case INTEGERTV:
result = make_integer( cell0.payload.integer.value
- cell1.payload.integer.value );
break;
case RATIOTV:{
struct cons_pointer tmp =
make_ratio( frame_pointer, frame->arg[0],
make_integer( 1 ) );
inc_ref( tmp );
result =
subtract_ratio_ratio( frame_pointer, tmp,
frame->arg[1] );
dec_ref( tmp );
}
break;
case REALTV:
result =
make_real( to_long_double( frame->arg[0] ) -
to_long_double( frame->arg[1] ) );
break;
default:
result = throw_exception( c_string_to_lisp_string
( L"Cannot subtract: not a number" ),
frame_pointer );
break;
}
break;
case RATIOTV:
switch ( cell1.tag.value ) {
case EXCEPTIONTV:
result = frame->arg[1];
break;
case INTEGERTV:{
struct cons_pointer tmp =
make_ratio( frame_pointer, frame->arg[1],
make_integer( 1 ) );
inc_ref( tmp );
result =
subtract_ratio_ratio( frame_pointer, frame->arg[0],
tmp );
dec_ref( tmp );
}
break;
case RATIOTV:
result =
subtract_ratio_ratio( frame_pointer, frame->arg[0],
frame->arg[1] );
break;
case REALTV:
result =
make_real( to_long_double( frame->arg[0] ) -
to_long_double( frame->arg[1] ) );
break;
default:
result = throw_exception( c_string_to_lisp_string
( L"Cannot subtract: not a number" ),
frame_pointer );
break;
}
break;
case REALTV:
result = exceptionp( frame->arg[1] ) ? frame->arg[1] :
make_real( to_long_double( frame->arg[0] ) -
to_long_double( frame->arg[1] ) );
break;
default:
result = throw_exception( c_string_to_lisp_string
( L"Cannot subtract: not a number" ),
frame_pointer );
break;
}
// and if not nilp[frame->arg[2]) we also have an error.
return result;
}
/**
* Divide one number by another.
* @param env the evaluation environment - ignored;
* @param frame the stack frame.
* @return a pointer to an integer or real.
*/
struct cons_pointer lisp_divide( struct
stack_frame
*frame, struct cons_pointer frame_pointer, struct
cons_pointer env ) {
struct cons_pointer result = NIL;
struct cons_space_object arg0 = pointer2cell( frame->arg[0] );
struct cons_space_object arg1 = pointer2cell( frame->arg[1] );
switch ( arg0.tag.value ) {
case EXCEPTIONTV:
result = frame->arg[0];
break;
case INTEGERTV:
switch ( arg1.tag.value ) {
case EXCEPTIONTV:
result = frame->arg[1];
break;
case INTEGERTV:{
struct cons_pointer unsimplified =
make_ratio( frame_pointer, frame->arg[0],
frame->arg[1] );
/* OK, if result may be unsimplified, we should not inc_ref it
* - but if not, we should dec_ref it. */
result = simplify_ratio( frame_pointer, unsimplified );
if ( !eq( unsimplified, result ) ) {
dec_ref( unsimplified );
}
}
break;
case RATIOTV:{
struct cons_pointer one = make_integer( 1 );
struct cons_pointer ratio =
make_ratio( frame_pointer, frame->arg[0], one );
result =
divide_ratio_ratio( frame_pointer, ratio,
frame->arg[1] );
dec_ref( ratio );
}
break;
case REALTV:
result =
make_real( to_long_double( frame->arg[0] ) /
to_long_double( frame->arg[1] ) );
break;
default:
result = throw_exception( c_string_to_lisp_string
( L"Cannot divide: not a number" ),
frame_pointer );
break;
}
break;
case RATIOTV:
switch ( arg1.tag.value ) {
case EXCEPTIONTV:
result = frame->arg[1];
break;
case INTEGERTV:{
struct cons_pointer one = make_integer( 1 );
inc_ref( one );
struct cons_pointer ratio =
make_ratio( frame_pointer, frame->arg[1], one );
inc_ref( ratio );
result =
divide_ratio_ratio( frame_pointer, frame->arg[0],
ratio );
dec_ref( ratio );
dec_ref( one );
}
break;
case RATIOTV:
result =
divide_ratio_ratio( frame_pointer, frame->arg[0],
frame->arg[1] );
break;
case REALTV:
result =
make_real( to_long_double( frame->arg[0] ) /
to_long_double( frame->arg[1] ) );
break;
default:
result = throw_exception( c_string_to_lisp_string
( L"Cannot divide: not a number" ),
frame_pointer );
break;
}
break;
case REALTV:
result = exceptionp( frame->arg[1] ) ? frame->arg[1] :
make_real( to_long_double( frame->arg[0] ) /
to_long_double( frame->arg[1] ) );
break;
default:
result = throw_exception( c_string_to_lisp_string
( L"Cannot divide: not a number" ),
frame_pointer );
break;
}
return result;
}

14
src/peano.h → src/arith/peano.h
View file

@ -23,7 +23,8 @@ extern "C" {
* @return a pointer to an integer or real.
*/
struct cons_pointer
lisp_add( struct stack_frame *frame, struct cons_pointer env );
lisp_add( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env );
/**
* Multiply an indefinite number of numbers together
@ -32,7 +33,9 @@ extern "C" {
* @return a pointer to an integer or real.
*/
struct cons_pointer
lisp_multiply( struct stack_frame *frame, struct cons_pointer env );
lisp_multiply( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
/**
* Subtract one number from another.
@ -41,7 +44,9 @@ extern "C" {
* @return a pointer to an integer or real.
*/
struct cons_pointer
lisp_subtract( struct stack_frame *frame, struct cons_pointer env );
lisp_subtract( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
/**
* Divide one number by another.
@ -50,7 +55,8 @@ extern "C" {
* @return a pointer to an integer or real.
*/
struct cons_pointer
lisp_divide( struct stack_frame *frame, struct cons_pointer env );
lisp_divide( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env );
#ifdef __cplusplus
}

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

@ -0,0 +1,333 @@
/*
* ratio.c
*
* functions for rational number cells.
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#define _GNU_SOURCE
#include <math.h>
#include <stdio.h>
#include "conspage.h"
#include "consspaceobject.h"
#include "debug.h"
#include "equal.h"
#include "integer.h"
#include "lispops.h"
#include "print.h"
#include "ratio.h"
/*
* declared in peano.c, can't include piano.h here because
* circularity. TODO: refactor.
*/
struct cons_pointer inverse( struct cons_pointer frame_pointer,
struct cons_pointer arg );
/**
* return, as a int64_t, the greatest common divisor of `m` and `n`,
*/
int64_t greatest_common_divisor( int64_t m, int64_t n ) {
int o;
while ( m ) {
o = m;
m = n % m;
n = o;
}
return o;
}
/**
* return, as a int64_t, the least common multiple of `m` and `n`,
*/
int64_t least_common_multiple( int64_t m, int64_t n ) {
return m / greatest_common_divisor( m, n ) * n;
}
/**
* return a cons_pointer indicating a number which is of the
* same value as the ratio indicated by `arg`, but which may
* be in a simplified representation. If `arg` isn't a ratio,
* will throw exception.
*/
struct cons_pointer simplify_ratio( struct cons_pointer frame_pointer,
struct cons_pointer arg ) {
struct cons_pointer result = arg;
if ( ratiop( arg ) ) {
int64_t ddrv =
pointer2cell( pointer2cell( arg ).payload.ratio.dividend ).
payload.integer.value, drrv =
pointer2cell( pointer2cell( arg ).payload.ratio.divisor ).
payload.integer.value, gcd = greatest_common_divisor( ddrv, drrv );
if ( gcd > 1 ) {
if ( drrv / gcd == 1 ) {
result = make_integer( ddrv / gcd );
} else {
result =
make_ratio( frame_pointer, make_integer( ddrv / gcd ),
make_integer( drrv / gcd ) );
}
}
} else {
result =
throw_exception( make_cons( c_string_to_lisp_string
( L"Shouldn't happen: bad arg to simplify_ratio" ),
arg ), frame_pointer );
}
return result;
}
/**
* return a cons_pointer indicating a number which is the sum of
* the ratios indicated by `arg1` and `arg2`. If you pass non-ratios,
* this is going to break horribly.
*/
struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer,
struct cons_pointer arg1,
struct cons_pointer arg2 ) {
struct cons_pointer r, result;
debug_print( L"add_ratio_ratio( arg1 = ", DEBUG_ARITH );
debug_print_object( arg1, DEBUG_ARITH );
debug_print( L"; arg2 = ", DEBUG_ARITH );
debug_print_object( arg2, DEBUG_ARITH );
debug_print( L")\n", DEBUG_ARITH );
if ( ratiop( arg1 ) && ratiop( arg2 ) ) {
struct cons_space_object cell1 = pointer2cell( arg1 );
struct cons_space_object cell2 = pointer2cell( arg2 );
int64_t dd1v =
pointer2cell( cell1.payload.ratio.dividend ).payload.integer.value,
dd2v =
pointer2cell( cell2.payload.ratio.dividend ).payload.integer.value,
dr1v =
pointer2cell( cell1.payload.ratio.divisor ).payload.integer.value,
dr2v =
pointer2cell( cell2.payload.ratio.divisor ).payload.integer.value,
lcm = least_common_multiple( dr1v, dr2v ),
m1 = lcm / dr1v, m2 = lcm / dr2v;
debug_printf( DEBUG_ARITH, L"); lcm = %ld; m1 = %ld; m2 = %ld", lcm, m1, m2 );
if ( dr1v == dr2v ) {
r = make_ratio( frame_pointer,
make_integer( dd1v + dd2v ),
cell1.payload.ratio.divisor );
} else {
struct cons_pointer dd1vm = make_integer( dd1v * m1 ),
dr1vm = make_integer( dr1v * m1 ),
dd2vm = make_integer( dd2v * m2 ),
dr2vm = make_integer( dr2v * m2 ),
r1 = make_ratio( frame_pointer, dd1vm, dr1vm ),
r2 = make_ratio( frame_pointer, dd2vm, dr2vm );
r = add_ratio_ratio( frame_pointer, r1, r2 );
/* because the references on dd1vm, dr1vm, dd2vm and dr2vm were
* never incremented except when making r1 and r2, decrementing
* r1 and r2 should be enought to garbage collect them. */
dec_ref( r1 );
dec_ref( r2 );
}
result = simplify_ratio( frame_pointer, r );
if ( !eq( r, result ) ) {
dec_ref( r );
}
} else {
result =
throw_exception( make_cons( c_string_to_lisp_string
( L"Shouldn't happen: bad arg to add_ratio_ratio" ),
make_cons( arg1,
make_cons( arg2, NIL ) ) ),
frame_pointer );
}
debug_print( L" => ", DEBUG_ARITH );
debug_print_object( result, DEBUG_ARITH );
debug_print( L"\n", DEBUG_ARITH );
return result;
}
/**
* return a cons_pointer indicating a number which is the sum of
* the intger indicated by `intarg` and the ratio indicated by
* `ratarg`. If you pass other types, this is going to break horribly.
*/
struct cons_pointer add_integer_ratio( struct cons_pointer frame_pointer,
struct cons_pointer intarg,
struct cons_pointer ratarg ) {
struct cons_pointer result;
if ( integerp( intarg ) && ratiop( ratarg ) ) {
struct cons_pointer one = make_integer( 1 ),
ratio = make_ratio( frame_pointer, intarg, one );
result = add_ratio_ratio( frame_pointer, ratio, ratarg );
dec_ref( one );
dec_ref( ratio );
} else {
result =
throw_exception( make_cons( c_string_to_lisp_string
( L"Shouldn't happen: bad arg to add_integer_ratio" ),
make_cons( intarg,
make_cons( ratarg,
NIL ) ) ),
frame_pointer );
}
return result;
}
/**
* return a cons_pointer to a ratio which represents the value of the ratio
* indicated by `arg1` divided by the ratio indicated by `arg2`. If either
* of these aren't RTIO cells, something horrid will happen and it is YOUR FAULT.
*/
struct cons_pointer divide_ratio_ratio( struct cons_pointer frame_pointer,
struct cons_pointer arg1,
struct cons_pointer arg2 ) {
struct cons_pointer i = make_ratio( frame_pointer,
pointer2cell( arg2 ).payload.
ratio.divisor,
pointer2cell( arg2 ).payload.
ratio.dividend ),
result =
multiply_ratio_ratio( frame_pointer, arg1, i );
dec_ref( i );
return result;
}
/**
* return a cons_pointer indicating a number which is the product of
* the ratios indicated by `arg1` and `arg2`. If you pass non-ratios,
* this is going to break horribly.
*/
struct cons_pointer multiply_ratio_ratio( struct cons_pointer frame_pointer, struct
cons_pointer arg1, struct
cons_pointer arg2 ) {
struct cons_pointer result;
debug_print( L"multiply_ratio_ratio( arg1 = ", DEBUG_ARITH );
debug_print_object( arg1, DEBUG_ARITH );
debug_print( L"; arg2 = ", DEBUG_ARITH );
debug_print_object( arg2, DEBUG_ARITH );
debug_print( L")\n", DEBUG_ARITH );
if ( ratiop( arg1 ) && ratiop( arg2 ) ) {
struct cons_space_object cell1 = pointer2cell( arg1 );
struct cons_space_object cell2 = pointer2cell( arg2 );
int64_t dd1v =
pointer2cell( cell1.payload.ratio.dividend ).payload.integer.value,
dd2v =
pointer2cell( cell2.payload.ratio.dividend ).payload.integer.value,
dr1v =
pointer2cell( cell1.payload.ratio.divisor ).payload.integer.value,
dr2v =
pointer2cell( cell2.payload.ratio.divisor ).payload.integer.value,
ddrv = dd1v * dd2v, drrv = dr1v * dr2v;
struct cons_pointer unsimplified =
make_ratio( frame_pointer, make_integer( ddrv ),
make_integer( drrv ) );
result = simplify_ratio( frame_pointer, unsimplified );
if ( !eq( unsimplified, result ) ) {
dec_ref( unsimplified );
}
} else {
result =
throw_exception( c_string_to_lisp_string
( L"Shouldn't happen: bad arg to multiply_ratio_ratio" ),
frame_pointer );
}
return result;
}
/**
* return a cons_pointer indicating a number which is the product of
* the intger indicated by `intarg` and the ratio indicated by
* `ratarg`. If you pass other types, this is going to break horribly.
*/
struct cons_pointer multiply_integer_ratio( struct cons_pointer frame_pointer,
struct cons_pointer intarg,
struct cons_pointer ratarg ) {
struct cons_pointer result;
if ( integerp( intarg ) && ratiop( ratarg ) ) {
struct cons_pointer one = make_integer( 1 ),
ratio = make_ratio( frame_pointer, intarg, one );
result = multiply_ratio_ratio( frame_pointer, ratio, ratarg );
dec_ref( one );
dec_ref( ratio );
} else {
result =
throw_exception( c_string_to_lisp_string
( L"Shouldn't happen: bad arg to multiply_integer_ratio" ),
frame_pointer );
}
return result;
}
/**
* return a cons_pointer indicating a number which is the difference of
* the ratios indicated by `arg1` and `arg2`. If you pass non-ratios,
* this is going to break horribly.
*/
struct cons_pointer subtract_ratio_ratio( struct cons_pointer frame_pointer,
struct cons_pointer arg1,
struct cons_pointer arg2 ) {
struct cons_pointer i = inverse( frame_pointer, arg2 ),
result = add_ratio_ratio( frame_pointer, arg1, i );
dec_ref( i );
return result;
}
/**
* Construct a ratio frame from these two pointers, expected to be integers
* or (later) bignums, in the context of this stack_frame.
*/
struct cons_pointer make_ratio( struct cons_pointer frame_pointer,
struct cons_pointer dividend,
struct cons_pointer divisor ) {
struct cons_pointer result;
if ( integerp( dividend ) && integerp( divisor ) ) {
inc_ref( dividend );
inc_ref( divisor );
result = allocate_cell( RATIOTAG );
struct cons_space_object *cell = &pointer2cell( result );
cell->payload.ratio.dividend = dividend;
cell->payload.ratio.divisor = divisor;
} else {
result =
throw_exception( c_string_to_lisp_string
( L"Dividend and divisor of a ratio must be integers" ),
frame_pointer );
}
debug_dump_object( result, DEBUG_ARITH );
return result;
}

46
src/arith/ratio.h Normal file
View file

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

3
src/real.c → src/arith/real.c
View file

@ -9,6 +9,7 @@
#include "conspage.h"
#include "consspaceobject.h"
#include "debug.h"
#include "read.h"
/**
@ -22,5 +23,7 @@ struct cons_pointer make_real( long double value ) {
struct cons_space_object *cell = &pointer2cell( result );
cell->payload.real.value = value;
debug_dump_object( result, DEBUG_ARITH );
return result;
}

0
src/real.h → src/arith/real.h
View file

99
src/debug.c Normal file
View file

@ -0,0 +1,99 @@
/**
* debug.c
*
* Better debug log messages.
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <ctype.h>
#include <stdarg.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
/*
* wide characters
*/
#include <wchar.h>
#include <wctype.h>
#include "consspaceobject.h"
#include "debug.h"
#include "dump.h"
#include "print.h"
/**
* the controlling flags for `debug_print`; set in `init.c`, q.v.
*/
int verbosity = 0;
/**
* print this debug `message` to stderr, if `verbosity` matches `level`.
* `verbosity is a set of flags, see debug_print.h; so you can
* turn debugging on for only one part of the system.
*/
void debug_print( wchar_t *message, int level ) {
#ifdef DEBUG
if ( level & verbosity ) {
fwide( stderr, 1 );
fputws( message, stderr );
}
#endif
}
/**
* print a line feed to stderr, if `verbosity` matches `level`.
* `verbosity is a set of flags, see debug_print.h; so you can
* turn debugging on for only one part of the system.
*/
void debug_println( int level ) {
#ifdef DEBUG
if ( level & verbosity ) {
fwide( stderr, 1 );
fputws( L"\n", stderr );
}
#endif
}
/**
* `wprintf` adapted for the debug logging system. Print to stderr only
* `verbosity` matches `level`. All other arguments as for `wprintf`.
*/
void debug_printf( int level, wchar_t * format, ...) {
#ifdef DEBUG
if ( level & verbosity ) {
fwide( stderr, 1 );
va_list(args);
va_start(args, format);
vfwprintf(stderr, format, args);
}
#endif
}
/**
* print the object indicated by this `pointer` to stderr, if `verbosity`
* matches `level`.`verbosity is a set of flags, see debug_print.h; so you can
* turn debugging on for only one part of the system.
*/
void debug_print_object( struct cons_pointer pointer, int level ) {
#ifdef DEBUG
if ( level & verbosity ) {
fwide( stderr, 1 );
print( stderr, pointer );
}
#endif
}
/**
* Like `dump_object`, q.v., but protected by the verbosity mechanism.
*/
void debug_dump_object( struct cons_pointer pointer, int level ) {
#ifdef DEBUG
if ( level & verbosity ) {
fwide( stderr, 1 );
dump_object( stderr, pointer );
}
#endif
}

33
src/debug.h Normal file
View file

@ -0,0 +1,33 @@
/**
* debug.h
*
* Better debug log messages.
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <ctype.h>
#include <stdio.h>
#ifndef __debug_print_h
#define __debug_print_h
#define DEBUG_ALLOC 1
#define DEBUG_STACK 2
#define DEBUG_ARITH 4
#define DEBUG_EVAL 8
#define DEBUG_LAMBDA 16
#define DEBUG_BOOTSTRAP 32
#define DEBUG_IO 64
#define DEBUG_REPL 128
extern int verbosity;
void debug_print( wchar_t *message, int level );
void debug_println( int level );
void debug_printf( int level, wchar_t * format, ...);
void debug_print_object( struct cons_pointer pointer, int level );
void debug_dump_object( struct cons_pointer pointer, int level );
#endif

90
src/init.c
View file

@ -11,26 +11,32 @@
#include <stdbool.h>
#include <stdio.h>
#include <stdlib.h>
#include <unistd.h>
#include <wchar.h>
#include "version.h"
#include "conspage.h"
#include "consspaceobject.h"
#include "debug.h"
#include "intern.h"
#include "lispops.h"
#include "peano.h"
#include "print.h"
#include "repl.h"
void bind_function( char *name, struct cons_pointer ( *executable )
( struct stack_frame *, struct cons_pointer ) ) {
// extern char *optarg; /* defined in unistd.h */
void bind_function( wchar_t *name, struct cons_pointer ( *executable )
( struct stack_frame *,
struct cons_pointer, struct cons_pointer ) ) {
deep_bind( c_string_to_lisp_symbol( name ),
make_function( NIL, executable ) );
}
void bind_special( char *name, struct cons_pointer ( *executable )
( struct stack_frame * frame, struct cons_pointer env ) ) {
void bind_special( wchar_t *name, struct cons_pointer ( *executable )
( struct stack_frame *,
struct cons_pointer, struct cons_pointer ) ) {
deep_bind( c_string_to_lisp_symbol( name ),
make_special( NIL, executable ) );
}
@ -46,7 +52,7 @@ int main( int argc, char *argv[] ) {
bool dump_at_end = false;
bool show_prompt = false;
while ( ( option = getopt( argc, argv, "pdc" ) ) != -1 ) {
while ( ( option = getopt( argc, argv, "cpdv:" ) ) != -1 ) {
switch ( option ) {
case 'c':
print_use_colours = true;
@ -57,6 +63,9 @@ int main( int argc, char *argv[] ) {
case 'p':
show_prompt = true;
break;
case 'v':
verbosity = atoi( optarg );
break;
default:
fwprintf( stderr, L"Unexpected option %c\n", option );
break;
@ -69,51 +78,60 @@ int main( int argc, char *argv[] ) {
VERSION );
}
debug_print( L"About to initialise cons pages\n", DEBUG_BOOTSTRAP );
initialise_cons_pages( );
debug_print( L"Initialised cons pages, about to bind\n", DEBUG_BOOTSTRAP );
/*
* privileged variables (keywords)
*/
deep_bind( c_string_to_lisp_symbol( "nil" ), NIL );
deep_bind( c_string_to_lisp_symbol( "t" ), TRUE );
deep_bind( c_string_to_lisp_symbol( L"nil" ), NIL );
deep_bind( c_string_to_lisp_symbol( L"t" ), TRUE );
/*
* primitive function operations
*/
bind_function( "add", &lisp_add );
bind_function( "apply", &lisp_apply );
bind_function( "assoc", &lisp_assoc );
bind_function( "car", &lisp_car );
bind_function( "cdr", &lisp_cdr );
bind_function( "cons", &lisp_cons );
bind_function( "divide", &lisp_divide );
bind_function( "eq", &lisp_eq );
bind_function( "equal", &lisp_equal );
bind_function( "eval", &lisp_eval );
bind_function( "multiply", &lisp_multiply );
bind_function( "read", &lisp_read );
bind_function( "oblist", &lisp_oblist );
bind_function( "print", &lisp_print );
bind_function( "progn", &lisp_progn );
bind_function( "set", &lisp_set );
bind_function( "subtract", &lisp_subtract );
bind_function( "type", &lisp_type );
bind_function( L"add", &lisp_add );
bind_function( L"apply", &lisp_apply );
bind_function( L"assoc", &lisp_assoc );
bind_function( L"car", &lisp_car );
bind_function( L"cdr", &lisp_cdr );
bind_function( L"cons", &lisp_cons );
bind_function( L"divide", &lisp_divide );
bind_function( L"eq", &lisp_eq );
bind_function( L"equal", &lisp_equal );
bind_function( L"eval", &lisp_eval );
bind_function( L"exception", &lisp_exception );
bind_function( L"multiply", &lisp_multiply );
bind_function( L"read", &lisp_read );
bind_function( L"oblist", &lisp_oblist );
bind_function( L"print", &lisp_print );
bind_function( L"progn", &lisp_progn );
bind_function( L"reverse", &lisp_reverse );
bind_function( L"set", &lisp_set );
bind_function( L"subtract", &lisp_subtract );
bind_function( L"throw", &lisp_exception );
bind_function( L"type", &lisp_type );
bind_function( "+", &lisp_add );
bind_function( "*", &lisp_multiply );
bind_function( "-", &lisp_subtract );
bind_function( "/", &lisp_divide );
bind_function( "=", &lisp_equal );
bind_function( L"+", &lisp_add );
bind_function( L"*", &lisp_multiply );
bind_function( L"-", &lisp_subtract );
bind_function( L"/", &lisp_divide );
bind_function( L"=", &lisp_equal );
/*
* primitive special forms
*/
bind_special( "cond", &lisp_cond );
bind_special( "lambda", &lisp_lambda );
bind_special( "nlambda", &lisp_nlambda );
bind_special( "progn", &lisp_progn );
bind_special( "quote", &lisp_quote );
bind_special( "set!", &lisp_set_shriek );
bind_special( L"cond", &lisp_cond );
bind_special( L"lambda", &lisp_lambda );
// bind_special( L"λ", &lisp_lambda );
bind_special( L"nlambda", &lisp_nlambda );
// bind_special( L"nλ", &lisp_nlambda );
bind_special( L"progn", &lisp_progn );
bind_special( L"quote", &lisp_quote );
bind_special( L"set!", &lisp_set_shriek );
repl( stdin, stdout, stderr, show_prompt );

45
src/conspage.c → src/memory/conspage.c
View file

@ -18,6 +18,8 @@
#include "consspaceobject.h"
#include "conspage.h"
#include "debug.h"
#include "dump.h"
/**
* Flag indicating whether conspage initialisation has been done.
@ -64,7 +66,7 @@ void make_cons_page( ) {
cell->count = MAXREFERENCE;
cell->payload.free.car = NIL;
cell->payload.free.cdr = NIL;
fwprintf( stderr, L"Allocated special cell NIL\n" );
debug_printf( DEBUG_ALLOC, L"Allocated special cell NIL\n" );
break;
case 1:
/*
@ -78,7 +80,7 @@ void make_cons_page( ) {
cell->payload.free.cdr = ( struct cons_pointer ) {
0, 1
};
fwprintf( stderr, L"Allocated special cell T\n" );
debug_printf( DEBUG_ALLOC, L"Allocated special cell T\n" );
break;
}
} else {
@ -95,7 +97,7 @@ void make_cons_page( ) {
initialised_cons_pages++;
} else {
fwprintf( stderr,
debug_printf( DEBUG_ALLOC,
L"FATAL: Failed to allocate memory for cons page %d\n",
initialised_cons_pages );
exit( 1 );
@ -127,6 +129,9 @@ void dump_pages( FILE * output ) {
void free_cell( struct cons_pointer pointer ) {
struct cons_space_object *cell = &pointer2cell( pointer );
debug_printf( DEBUG_ALLOC, L"Freeing cell " );
debug_dump_object( pointer, DEBUG_ALLOC );
switch ( cell->tag.value ) {
/* for all the types of cons-space object which point to other
* cons-space objects, cascade the decrement. */
@ -145,6 +150,10 @@ void free_cell( struct cons_pointer pointer ) {
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;
@ -152,24 +161,30 @@ void free_cell( struct cons_pointer pointer ) {
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 %ld\n",
cell->payload.vectorp.address );
//free( ( void * ) cell->payload.vectorp.address );
break;
}
if ( !check_tag( pointer, FREETAG ) ) {
if ( cell->count == 0 ) {
fwprintf( stderr, L"Freeing cell " );
dump_object( stderr, pointer );
strncpy( &cell->tag.bytes[0], FREETAG, 4 );
strncpy( &cell->tag.bytes[0], FREETAG, TAGLENGTH );
cell->payload.free.car = NIL;
cell->payload.free.cdr = freelist;
freelist = pointer;
} else {
fwprintf( stderr,
L"Attempt to free cell with %d dangling references at page %d, offset %d\n",
debug_printf( DEBUG_ALLOC,
L"ERROR: Attempt to free cell with %d dangling references at page %d, offset %d\n",
cell->count, pointer.page, pointer.offset );
}
} else {
fwprintf( stderr,
L"Attempt to free cell which is already FREE at page %d, offset %d\n",
debug_printf( DEBUG_ALLOC,
L"ERROR: Attempt to free cell which is already FREE at page %d, offset %d\n",
pointer.page, pointer.offset );
}
}
@ -194,19 +209,17 @@ struct cons_pointer allocate_cell( char *tag ) {
if ( strncmp( &cell->tag.bytes[0], FREETAG, TAGLENGTH ) == 0 ) {
freelist = cell->payload.free.cdr;
strncpy( &cell->tag.bytes[0], tag, 4 );
strncpy( &cell->tag.bytes[0], tag, TAGLENGTH );
cell->count = 0;
cell->payload.cons.car = NIL;
cell->payload.cons.cdr = NIL;
#ifdef DEBUG
fwprintf( stderr,
debug_printf( DEBUG_ALLOC,
L"Allocated cell of type '%s' at %d, %d \n", tag,
result.page, result.offset );
#endif
} else {
fwprintf( stderr, L"WARNING: Allocating non-free cell!" );
debug_printf( DEBUG_ALLOC, L"WARNING: Allocating non-free cell!" );
}
}
@ -225,7 +238,7 @@ void initialise_cons_pages( ) {
make_cons_page( );
conspageinitihasbeencalled = true;
} else {
fwprintf( stderr,
debug_printf( DEBUG_ALLOC,
L"WARNING: initialise_cons_pages() called a second or subsequent time\n" );
}
}

0
src/conspage.h → src/memory/conspage.h
View file

129
src/consspaceobject.c → src/memory/consspaceobject.c
View file

@ -20,6 +20,7 @@
#include "conspage.h"
#include "consspaceobject.h"
#include "debug.h"
#include "print.h"
#include "stack.h"
@ -54,7 +55,7 @@ void inc_ref( struct cons_pointer pointer ) {
void dec_ref( struct cons_pointer pointer ) {
struct cons_space_object *cell = &pointer2cell( pointer );
if ( cell->count <= MAXREFERENCE ) {
if ( cell->count > 0 ) {
cell->count--;
if ( cell->count == 0 ) {
@ -63,90 +64,6 @@ void dec_ref( struct cons_pointer pointer ) {
}
}
void dump_string_cell( FILE * output, wchar_t *prefix,
struct cons_pointer pointer ) {
struct cons_space_object cell = pointer2cell( pointer );
if ( cell.payload.string.character == 0 ) {
fwprintf( output,
L"\t\t%ls cell: termination; next at page %d offset %d, count %u\n",
prefix,
cell.payload.string.cdr.page, cell.payload.string.cdr.offset,
cell.count );
} else {
fwprintf( output,
L"\t\t%ls cell: character '%lc' (%d) next at page %d offset %d, count %u\n",
prefix,
( wint_t ) cell.payload.string.character,
cell.payload.string.character,
cell.payload.string.cdr.page,
cell.payload.string.cdr.offset, cell.count );
fwprintf( output, L"\t\t value: " );
print( output, pointer );
fwprintf( output, L"\n" );
}
}
/**
* dump the object at this cons_pointer to this output stream.
*/
void dump_object( FILE * output, struct cons_pointer pointer ) {
struct cons_space_object cell = pointer2cell( pointer );
fwprintf( output,
L"\t%c%c%c%c (%d) at page %d, offset %d count %u\n",
cell.tag.bytes[0],
cell.tag.bytes[1],
cell.tag.bytes[2],
cell.tag.bytes[3],
cell.tag.value, pointer.page, pointer.offset, cell.count );
switch ( cell.tag.value ) {
case CONSTV:
fwprintf( output,
L"\t\tCons cell: car at page %d offset %d, cdr at page %d offset %d, count %u\n",
cell.payload.cons.car.page,
cell.payload.cons.car.offset,
cell.payload.cons.cdr.page,
cell.payload.cons.cdr.offset, cell.count );
break;
case EXCEPTIONTV:
fwprintf( output, L"\t\tException cell: " );
print( output, cell.payload.exception.message );
fwprintf( output, L"\n" );
for ( struct stack_frame * frame = cell.payload.exception.frame;
frame != NULL; frame = frame->previous ) {
dump_frame( output, frame );
}
break;
case FREETV:
fwprintf( output, L"\t\tFree cell: next at page %d offset %d\n",
cell.payload.cons.cdr.page,
cell.payload.cons.cdr.offset );
break;
case INTEGERTV:
fwprintf( output,
L"\t\tInteger cell: value %ld, count %u\n",
cell.payload.integer.value, cell.count );
break;
case LAMBDATV:
fwprintf( output, L"\t\tLambda cell; args: " );
print( output, cell.payload.lambda.args );
fwprintf( output, L";\n\t\t\tbody: " );
print( output, cell.payload.lambda.body );
break;
case READTV:
fwprintf( output, L"\t\tInput stream\n" );
case REALTV:
fwprintf( output, L"\t\tReal cell: value %Lf, count %u\n",
cell.payload.real.value, cell.count );
break;
case STRINGTV:
dump_string_cell( output, L"String", pointer );
break;
case SYMBOLTV:
dump_string_cell( output, L"Symbol", pointer );
break;
}
}
/**
* Construct a cons cell from this pair of pointers.
@ -170,20 +87,24 @@ struct cons_pointer make_cons( struct cons_pointer car,
/**
* Construct an exception cell.
* @param message should be a lisp string describing the problem, but actually any cons pointer will do;
* @param frame should be the frame in which the exception occurred.
* @param frame_pointer should be the pointer to the frame in which the exception occurred.
*/
struct cons_pointer make_exception( struct cons_pointer message,
struct stack_frame *frame ) {
struct cons_pointer frame_pointer ) {
struct cons_pointer result = NIL;
struct cons_pointer pointer = allocate_cell( EXCEPTIONTAG );
struct cons_space_object *cell = &pointer2cell( pointer );
inc_ref( pointer ); /* this is a hack; I don't know why it's necessary to do this, but if I don't the cell gets freed */
inc_ref( message );
inc_ref( frame_pointer );
cell->payload.exception.message = message;
cell->payload.exception.frame = frame;
cell->payload.exception.frame = frame_pointer;
return pointer;
result = pointer;
return result;
}
@ -192,7 +113,8 @@ struct cons_pointer make_exception( struct cons_pointer message,
*/
struct cons_pointer
make_function( struct cons_pointer src, struct cons_pointer ( *executable )
( struct stack_frame *, struct cons_pointer ) ) {
( struct stack_frame *,
struct cons_pointer, struct cons_pointer ) ) {
struct cons_pointer pointer = allocate_cell( FUNCTIONTAG );
struct cons_space_object *cell = &pointer2cell( pointer );
@ -257,11 +179,13 @@ make_string_like_thing( wint_t c, struct cons_pointer tail, char *tag ) {
cell->payload.string.character = c;
cell->payload.string.cdr.page = tail.page;
/* TODO: There's a problem here. Sometimes the offsets on
* strings are quite massively off. */
* strings are quite massively off. Fix is probably
* cell->payload.string.cdr = tsil */
cell->payload.string.cdr.offset = tail.offset;
} else {
fwprintf( stderr,
L"Warning: only NIL and %s can be appended to %s\n",
// TODO: should throw an exception!
debug_printf( DEBUG_ALLOC,
L"Warning: only NIL and %s can be prepended to %s\n",
tag, tag );
}
@ -290,7 +214,8 @@ struct cons_pointer make_symbol( wint_t c, struct cons_pointer tail ) {
*/
struct cons_pointer
make_special( struct cons_pointer src, struct cons_pointer ( *executable )
( struct stack_frame * frame, struct cons_pointer env ) ) {
( struct stack_frame * frame,
struct cons_pointer, struct cons_pointer env ) ) {
struct cons_pointer pointer = allocate_cell( SPECIALTAG );
struct cons_space_object *cell = &pointer2cell( pointer );
@ -327,26 +252,26 @@ struct cons_pointer make_write_stream( FILE * output ) {
}
/**
* Return a lisp string representation of this old skool ASCII string.
* Return a lisp string representation of this wide character string.
*/
struct cons_pointer c_string_to_lisp_string( char *string ) {
struct cons_pointer c_string_to_lisp_string( wchar_t *string ) {
struct cons_pointer result = NIL;
for ( int i = strlen( string ); i > 0; i-- ) {
result = make_string( ( wint_t ) string[i - 1], result );
for ( int i = wcslen( string ); i > 0; i-- ) {
result = make_string( string[i - 1], result );
}
return result;
}
/**
* Return a lisp symbol representation of this old skool ASCII string.
* Return a lisp symbol representation of this wide character string.
*/
struct cons_pointer c_string_to_lisp_symbol( char *symbol ) {
struct cons_pointer c_string_to_lisp_symbol( wchar_t *symbol ) {
struct cons_pointer result = NIL;
for ( int i = strlen( symbol ); i > 0; i-- ) {
result = make_symbol( ( wint_t ) symbol[i - 1], result );
for ( int i = wcslen( symbol ); i > 0; i-- ) {
result = make_symbol( symbol[i - 1], result );
}
return result;

111
src/consspaceobject.h → src/memory/consspaceobject.h
View file

@ -28,6 +28,13 @@
/**
* tag values, all of which must be 4 bytes. Must not collide with vector space tag values
*/
/**
* A word within a bignum - arbitrary precision integer.
*/
#define BIGNUMTAG "BIGN"
#define BIGNUMTV 1313294658
/**
* An ordinary cons cell: 1397641027
*/
@ -38,7 +45,6 @@
* An exception.
*/
#define EXCEPTIONTAG "EXEP"
/* TODO: this is wrong */
#define EXCEPTIONTV 1346721861
/**
@ -91,6 +97,12 @@
#define REALTAG "REAL"
#define REALTV 1279346002
/**
* A ratio.
*/
#define RATIOTAG "RTIO"
#define RATIOTV 1330205778
/**
* A special form - one whose arguments are not pre-evaluated but passed as a
* s-expression. 1296453715
@ -121,12 +133,11 @@
* A pointer to an object in vector space.
*/
#define VECTORPOINTTAG "VECP"
#define VECTORPOINTTV 1346585942
/**
* An open write stream.
*/
#define WRITETAG "WRIT"
/* TODO: this is wrong */
#define WRITETV 1414091351
/**
@ -157,6 +168,11 @@
*/
#define nilp(conspoint) (check_tag(conspoint,NILTAG))
/**
* true if conspointer points to a cons cell, else false
*/
#define bignump(conspoint) (check_tag(conspoint,BIGNUMTAG))
/**
* true if conspointer points to a cons cell, else false
*/
@ -197,6 +213,11 @@
*/
#define integerp(conspoint) (check_tag(conspoint,INTEGERTAG))
/**
* true if conspointer points to a rational number cell, else false
*/
#define ratiop(conspoint) (check_tag(conspoint,RATIOTAG))
/**
* true if conspointer points to a read stream cell, else false
*/
@ -211,7 +232,14 @@
* true if conspointer points to some sort of a number cell,
* else false
*/
#define numberp(conspoint) (check_tag(conspoint,INTEGERTAG)||check_tag(conspoint,REALTAG))
#define numberp(conspoint) (check_tag(conspoint,INTEGERTAG)||check_tag(conspoint,RATIOTAG)||check_tag(conspoint,REALTAG)||check_tag(conspoint,BIGNUMTAG))
#define sequencep(conspoint) (check_tag(conspoint,CONSTAG)||check_tag(conspoint,STRINGTAG)||check_tag(conspoint,SYMBOLTAG))
/**
* true if thr conspointer points to a vector pointer.
*/
#define vectorpointp(conspoint) (check_tag(conspoint,VECTORPOINTTAG))
/**
* true if conspointer points to a write stream cell, else false.
@ -235,9 +263,10 @@
* An indirect pointer to a cons cell
*/
struct cons_pointer {
uint32_t page; /* the index of the page on which this cell
* resides */
uint32_t offset; /* the index of the cell within the page */
/** the index of the page on which this cell resides */
uint32_t page;
/** the index of the cell within the page */
uint32_t offset;
};
/*
@ -250,15 +279,26 @@ struct cons_pointer {
* here to avoid circularity. TODO: refactor.
*/
struct stack_frame {
struct stack_frame *previous; /* the previous frame */
struct cons_pointer previous; /* the previous frame */
struct cons_pointer arg[args_in_frame];
/*
* first 8 arument bindings
*/
struct cons_pointer more; /* list of any further argument bindings */
struct cons_pointer function; /* the function to be called */
int args;
};
/**
* payload of a bignum cell. Intentionally similar to an integer payload, but
* with a next pointer.
*/
struct bignum_payload {
int64_t value;
struct cons_pointer next;
};
/**
* payload of a cons cell.
*/
@ -273,7 +313,7 @@ struct cons_payload {
*/
struct exception_payload {
struct cons_pointer message;
struct stack_frame *frame;
struct cons_pointer frame;
};
/**
@ -288,6 +328,7 @@ struct exception_payload {
struct function_payload {
struct cons_pointer source;
struct cons_pointer ( *executable ) ( struct stack_frame *,
struct cons_pointer,
struct cons_pointer );
};
@ -306,7 +347,7 @@ struct free_payload {
* optional bignum object.
*/
struct integer_payload {
long int value;
int64_t value;
};
/**
@ -317,10 +358,19 @@ struct lambda_payload {
struct cons_pointer body;
};
/**
* payload for ratio cells. Both dividend and divisor must point to integer (or, later, bignum) cells.
*/
struct ratio_payload {
struct cons_pointer dividend;
struct cons_pointer divisor;
};
/**
* payload for a real number cell. Internals of this liable to change to give 128 bits
* precision, but I'm not sure of the detail.
*/ struct real_payload {
*/
struct real_payload {
long double value;
};
@ -332,13 +382,11 @@ struct lambda_payload {
* 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).
*
* NOTE that this means that special forms do not appear on the lisp stack,
* which may be confusing. TODO: think about this.
*/
struct special_payload {
struct cons_pointer source;
struct cons_pointer ( *executable ) ( struct stack_frame *,
struct cons_pointer,
struct cons_pointer );
};
@ -361,6 +409,9 @@ struct string_payload {
struct cons_pointer cdr;
};
/**
* payload of a vector pointer cell.
*/
struct vectorp_payload {
union {
char bytes[TAGLENGTH]; /* the tag (type) of the
@ -371,9 +422,10 @@ struct vectorp_payload {
* tag. */
uint32_t value; /* the tag considered as a number */
} tag;
uint64_t address; /* the address of the actual vector space
* object (TODO: will change when I actually
* implement vector space) */
void *address;
/* the address of the actual vector space
* object (TODO: will change when I actually
* implement vector space) */
};
/**
@ -418,6 +470,10 @@ struct cons_space_object {
* if tag == NILTAG; we'll treat the special cell NIL as just a cons
*/
struct cons_payload nil;
/*
* if tag == RATIOTAG
*/
struct ratio_payload ratio;
/*
* if tag == READTAG || tag == WRITETAG
*/
@ -460,20 +516,11 @@ void inc_ref( struct cons_pointer pointer );
*/
void dec_ref( struct cons_pointer pointer );
/**
* dump the object at this cons_pointer to this output stream.
*/
void dump_object( FILE * output, struct cons_pointer pointer );
struct cons_pointer make_cons( struct cons_pointer car,
struct cons_pointer cdr );
/**
* Construct an exception cell.
* @param message should be a lisp string describing the problem, but actually any cons pointer will do;
* @param frame should be the frame in which the exception occurred.
*/
struct cons_pointer make_exception( struct cons_pointer message,
struct stack_frame *frame );
struct cons_pointer frame_pointer );
/**
* Construct a cell which points to an executable Lisp special form.
@ -481,6 +528,7 @@ struct cons_pointer make_exception( struct cons_pointer message,
struct cons_pointer make_function( struct cons_pointer src,
struct cons_pointer ( *executable )
( struct stack_frame *,
struct cons_pointer,
struct cons_pointer ) );
/**
@ -496,12 +544,13 @@ struct cons_pointer make_lambda( struct cons_pointer args,
struct cons_pointer make_nlambda( struct cons_pointer args,
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 ( *executable )
( struct stack_frame *,
struct cons_pointer,
struct cons_pointer ) );
/**
@ -533,11 +582,11 @@ 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( char *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( char *symbol );
struct cons_pointer c_string_to_lisp_symbol( wchar_t *symbol );
#endif

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

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

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

Binary file not shown.

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

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

29
src/memory/dump.h Normal file
View file

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

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

@ -0,0 +1,298 @@
/*
* stack.c
*
* The Lisp evaluation stack.
*
* Stack frames could be implemented in cons space; indeed, the stack
* could simply be an assoc list consed onto the front of the environment.
* But such a stack would be costly to search. The design sketched here,
* with stack frames as special objects, SHOULD be substantially more
* efficient, but does imply we need to generalise the idea of cons pages
* with freelists to a more general 'equal sized object pages', so that
* allocating/freeing stack frames can be more efficient.
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <stdlib.h>
#include "consspaceobject.h"
#include "conspage.h"
#include "debug.h"
#include "dump.h"
#include "lispops.h"
#include "print.h"
#include "stack.h"
#include "vectorspace.h"
void set_reg(struct stack_frame * frame, int reg, struct cons_pointer value) {
debug_printf(DEBUG_STACK, L"Setting register %d to ", reg);
debug_print_object(value, DEBUG_STACK);
debug_println(DEBUG_STACK);
frame->arg[reg++] = value;
inc_ref(value);
if (reg > frame->args) {
frame->args = reg;
}
}
/**
* get the actual stackframe object from this `pointer`, or NULL if
* `pointer` is not a stackframe pointer.
*/
struct stack_frame *get_stack_frame( struct cons_pointer pointer ) {
struct stack_frame *result = NULL;
struct vector_space_object *vso =
pointer2cell( pointer ).payload.vectorp.address;
if ( vectorpointp( pointer ) && stackframep( vso ) ) {
result = ( struct stack_frame * ) &( vso->payload );
debug_printf( DEBUG_STACK, L"get_stack_frame: all good, returning %p\n",
result );
} else {
debug_print( L"get_stack_frame: fail, returning NULL\n", DEBUG_STACK );
}
return result;
}
/**
* Make an empty stack frame, and return it.
* @param previous the current top-of-stack;
* @param env the environment in which evaluation happens.
* @return the new frame, or NULL if memory is exhausted.
*/
struct cons_pointer make_empty_frame( struct cons_pointer previous ) {
debug_print( L"Entering make_empty_frame\n", DEBUG_ALLOC );
struct cons_pointer result =
make_vso( STACKFRAMETAG, sizeof( struct stack_frame ) );
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 ) ) {
struct stack_frame *frame = get_stack_frame( result );
/*
* TODO: later, pop a frame off a free-list of stack frames
*/
frame->previous = previous;
/*
* clearing the frame with memset would probably be slightly quicker, but
* this is clear.
*/
frame->more = NIL;
frame->function = NIL;
frame->args = 0;
for ( int i = 0; i < args_in_frame; i++ ) {
frame->arg[i] = NIL;
}
}
debug_print( L"Leaving make_empty_frame\n", DEBUG_ALLOC );
debug_dump_object( result, DEBUG_ALLOC);
return result;
}
/**
* Allocate a new stack frame with its previous pointer set to this value,
* its arguments set up from these args, evaluated in this env.
* @param previous the current top-of-stack;
* @args the arguments to load into this frame;
* @param env the environment in which evaluation happens.
* @return the new frame, or an exception if one occurred while building it.
*/
struct cons_pointer make_stack_frame( struct cons_pointer previous,
struct cons_pointer args,
struct cons_pointer env ) {
debug_print( L"Entering make_stack_frame\n", DEBUG_STACK );
struct cons_pointer result = make_empty_frame( previous );
if ( nilp( result ) ) {
/* i.e. out of memory */
result =
make_exception( c_string_to_lisp_string( L"Memory exhausted." ),
previous );
} else {
struct stack_frame *frame = get_stack_frame( result );
while ( frame->args < args_in_frame && consp( args )) {
/* iterate down the arg list filling in the arg slots in the
* frame. When there are no more slots, if there are still args,
* stash them on more */
struct cons_space_object cell = pointer2cell( args );
/*
* TODO: if we were running on real massively parallel hardware,
* each arg except the first should be handed off to another
* processor to be evaled in parallel; but see notes here:
* https://github.com/simon-brooke/post-scarcity/wiki/parallelism
*/
struct cons_pointer val = eval_form(frame, result, cell.payload.cons.car, env);
if ( exceptionp( val ) ) {
result = val;
break;
} else {
debug_printf( DEBUG_STACK, L"Setting argument %d to ", frame->args);
debug_print_object(cell.payload.cons.car, DEBUG_STACK);
set_reg( frame, frame->args, val );
}
args = cell.payload.cons.cdr;
}
if ( !exceptionp( result ) ) {
if ( consp( args ) ) {
/* if we still have args, eval them and stick the values on `more` */
struct cons_pointer more =
eval_forms( get_stack_frame( previous ), previous, args,
env );
frame->more = more;
inc_ref( more );
}
}
}
debug_print( L"make_stack_frame: returning\n", DEBUG_STACK );
debug_dump_object( result, DEBUG_STACK );
return result;
}
/**
* A 'special' frame is exactly like a normal stack frame except that the
* arguments are unevaluated.
* @param previous the previous stack frame;
* @param args a list of the arguments to be stored in this stack frame;
* @param env the execution environment;
* @return a new special frame.
*/
struct cons_pointer make_special_frame( struct cons_pointer previous,
struct cons_pointer args,
struct cons_pointer env ) {
debug_print( L"Entering make_special_frame\n", DEBUG_STACK );
struct cons_pointer result = make_empty_frame( previous );
if ( nilp( result ) ) {
/* i.e. out of memory */
result =
make_exception( c_string_to_lisp_string( L"Memory exhausted." ),
previous );
} else {
struct stack_frame *frame = get_stack_frame( result );
while ( frame->args < args_in_frame && !nilp( args )) {
/* iterate down the arg list filling in the arg slots in the
* frame. When there are no more slots, if there are still args,
* stash them on more */
struct cons_space_object cell = pointer2cell( args );
set_reg( frame, frame->args, cell.payload.cons.car );
args = cell.payload.cons.cdr;
}
if ( !exceptionp( result ) ) {
if ( consp( args ) ) {
frame->more = args;
inc_ref( args );
}
}
}
debug_print( L"make_special_frame: returning\n", DEBUG_STACK );
debug_dump_object( result, DEBUG_STACK );
return result;
}
/**
* Free this stack frame.
*/
void free_stack_frame( struct stack_frame *frame ) {
/*
* TODO: later, push it back on the stack-frame freelist
*/
for ( int i = 0; i < args_in_frame; i++ ) {
dec_ref( frame->arg[i] );
}
if ( !nilp( frame->more ) ) {
dec_ref( frame->more );
}
free( frame );
}
/**
* Dump a stackframe to this stream for debugging
* @param output the stream
* @param frame_pointer the pointer to the frame
*/
void dump_frame( FILE * output, struct cons_pointer frame_pointer ) {
struct stack_frame *frame = get_stack_frame( frame_pointer );
if ( frame != NULL ) {
fwprintf( output, L"Stack frame with %d arguments:\n", frame->args);
for ( int arg = 0; arg < frame->args; arg++ ) {
struct cons_space_object cell = pointer2cell( frame->arg[arg] );
fwprintf( output, L"Arg %d:\t%c%c%c%c\tcount: %10u\tvalue: ", arg,
cell.tag.bytes[0],
cell.tag.bytes[1], cell.tag.bytes[2], cell.tag.bytes[3],
cell.count );
print( output, frame->arg[arg] );
fputws( L"\n", output );
}
if (!nilp(frame->more))
{
fputws( L"More: \t", output );
print( output, frame->more );
fputws( L"\n", output );
}
}
}
void dump_stack_trace( FILE * output, struct cons_pointer pointer ) {
if ( exceptionp( pointer ) ) {
print( output, pointer2cell( pointer ).payload.exception.message );
fputws( L"\n", output );
dump_stack_trace( output,
pointer2cell( pointer ).payload.exception.frame );
} else {
while ( vectorpointp( pointer )
&& stackframep( pointer_to_vso( pointer ) ) ) {
dump_frame( output, pointer );
pointer = get_stack_frame( pointer )->previous;
}
}
}
/**
* Fetch a pointer to the value of the local variable at this index.
*/
struct cons_pointer fetch_arg( struct stack_frame *frame, unsigned int index ) {
struct cons_pointer result = NIL;
if ( index < args_in_frame ) {
result = frame->arg[index];
} else {
struct cons_pointer p = frame->more;
for ( int i = args_in_frame; i < index; i++ ) {
p = pointer2cell( p ).payload.cons.cdr;
}
result = pointer2cell( p ).payload.cons.car;
}
return result;
}

53
src/stack.h → src/memory/stack.h
View file

@ -25,38 +25,41 @@
#define __stack_h
/**
* Make an empty stack frame, and return it.
* @param previous the current top-of-stack;
* @param env the environment in which evaluation happens.
* @return the new frame.
* macros for the tag of a stack frame.
*/
struct stack_frame *make_empty_frame( struct stack_frame *previous,
struct cons_pointer env );
struct stack_frame *make_stack_frame( struct stack_frame *previous,
struct cons_pointer args,
struct cons_pointer env,
struct cons_pointer *exception );
void free_stack_frame( struct stack_frame *frame );
#define STACKFRAMETAG "STAK"
#define STACKFRAMETV 1262572627
/**
* Dump a stackframe to this stream for debugging
* @param output the stream
* @param frame the frame
* is this vector-space object a stack frame?
*/
void dump_frame( FILE * output, struct stack_frame *frame );
#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);
struct stack_frame *get_stack_frame( struct cons_pointer pointer );
struct cons_pointer make_empty_frame( struct cons_pointer previous );
struct cons_pointer make_stack_frame( struct cons_pointer previous,
struct cons_pointer args,
struct cons_pointer env );
void free_stack_frame( struct stack_frame *frame );
void dump_frame( FILE * output, struct cons_pointer pointer );
void dump_stack_trace( FILE * output, struct cons_pointer frame_pointer );
struct cons_pointer fetch_arg( struct stack_frame *frame, unsigned int n );
/**
* A 'special' frame is exactly like a normal stack frame except that the
* arguments are unevaluated.
* @param previous the previous stack frame;
* @param args a list of the arguments to be stored in this stack frame;
* @param env the execution environment;
* @return a new special frame.
*/
struct stack_frame *make_special_frame( struct stack_frame *previous,
struct cons_pointer make_special_frame( struct cons_pointer previous,
struct cons_pointer args,
struct cons_pointer env );

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

@ -0,0 +1,97 @@
/*
* vectorspace.c
*
* Structures common to all vector space objects.
*
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <math.h>
#include <stdint.h>
#include <stdlib.h>
#include <string.h>
#include <stdio.h>
/*
* wide characters
*/
#include <wchar.h>
#include <wctype.h>
#include "conspage.h"
#include "consspaceobject.h"
#include "debug.h"
#include "vectorspace.h"
/**
* make a cons-space object which points to the vector space object
* 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`.
*/
struct cons_pointer make_vec_pointer( struct vector_space_object *address ) {
debug_print( L"Entered make_vec_pointer\n", DEBUG_ALLOC );
struct cons_pointer pointer = allocate_cell( VECTORPOINTTAG );
struct cons_space_object *cell = &pointer2cell( pointer );
debug_printf( DEBUG_ALLOC,
L"make_vec_pointer: tag written, about to set pointer address to %p\n",
address );
cell->payload.vectorp.address = address;
debug_printf( DEBUG_ALLOC, L"make_vec_pointer: all good, returning pointer to %p\n",
cell->payload.vectorp.address );
debug_dump_object( pointer, DEBUG_ALLOC );
return pointer;
}
/**
* allocate a vector space object with this `payload_size` and `tag`,
* and return a `cons_pointer` which points to an object whigh points to it.
* NOTE that `tag` should be the vector-space tag of the particular type of
* vector-space object, NOT `VECTORPOINTTAG`.
* Returns NIL if the vector could not be allocated due to memory exhaustion.
*/
struct cons_pointer make_vso( char *tag, uint64_t payload_size ) {
debug_print( L"Entered make_vso\n", DEBUG_ALLOC );
struct cons_pointer result = NIL;
int64_t total_size = sizeof( struct vector_space_header ) + payload_size;
/* Pad size to 64 bit words. This is intended to promote access efficiancy
* on 64 bit machines but may just be voodoo coding */
uint64_t padded = ceil( ( total_size * 8.0 ) / 8.0 );
debug_print( L"make_vso: about to malloc\n", DEBUG_ALLOC );
struct vector_space_object *vso = malloc( padded );
if ( vso != NULL ) {
debug_printf( DEBUG_ALLOC,
L"make_vso: about to write tag '%s' into vso at %p\n", tag,
vso );
strncpy( &vso->header.tag.bytes[0], tag, TAGLENGTH );
result = make_vec_pointer( vso );
debug_dump_object( result, DEBUG_ALLOC );
vso->header.vecp = result;
// memcpy(vso->header.vecp, result, sizeof(struct cons_pointer));
vso->header.size = payload_size;
#ifdef DEBUG
debug_printf( DEBUG_ALLOC,
L"Allocated vector-space object of type %4.4s, total size %ld, payload size %ld, at address %p, payload address %p\n",
&vso->header.tag.bytes, total_size, vso->header.size, vso,
&vso->payload );
if ( padded != total_size ) {
debug_printf( DEBUG_ALLOC, L"\t\tPadded from %d to %d\n",
total_size, padded );
}
#endif
}
#ifdef DEBUG
debug_printf( DEBUG_ALLOC, L"make_vso: all good, returning pointer to %p\n",
pointer2cell( result ).payload.vectorp.address );
#endif
return result;
}

71
src/memory/vectorspace.h Normal file
View file

@ -0,0 +1,71 @@
/**
* vectorspace.h
*
* Declarations common to all vector space objects.
*
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <stdbool.h>
#include <stdint.h>
#include <stdio.h>
/*
* wide characters
*/
#include <wchar.h>
#include <wctype.h>
#include "consspaceobject.h"
#ifndef __vectorspace_h
#define __vectorspace_h
/*
* part of the implementation structure of a namespace.
*/
#define HASHTAG "HASH"
#define HASHTV 0
/*
* a namespace (i.e. a binding of names to values, implemented as a hashmap)
*/
#define NAMESPACETAG "NMSP"
#define NAMESPACETV 0
/*
* a vector of cons pointers.
*/
#define VECTORTAG "VECT"
#define VECTORTV 0
#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))
struct cons_pointer make_vso( char *tag, uint64_t payload_size );
struct vector_space_header {
union {
char bytes[TAGLENGTH]; /* the tag (type) of the
* vector-space object this cell
* points to, considered as bytes.
* NOTE that the vector space object
* should itself have the identical
* tag. */
uint32_t value; /* the tag considered as a number */
} tag;
struct cons_pointer vecp; /* back pointer to the vector pointer
* which uniquely points to this vso */
uint64_t size; /* the size of my payload, in bytes */
};
struct vector_space_object {
struct vector_space_header header;
char payload; /* we'll malloc `size` bytes for payload,
* `payload` is just the first of these.
* TODO: this is almost certainly not
* idiomatic C. */
};
#endif

4
src/equal.c → src/ops/equal.c
View file

@ -80,8 +80,8 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) {
&& ( equal( cell_a->payload.string.cdr,
cell_b->payload.string.cdr )
|| ( end_of_string( cell_a->payload.string.cdr )
&& end_of_string( cell_b->payload.string.
cdr ) ) );
&& end_of_string( cell_b->payload.
string.cdr ) ) );
break;
case INTEGERTV:
result =

0
src/equal.h → src/ops/equal.h
View file

37
src/intern.c → src/ops/intern.c
View file

@ -21,6 +21,7 @@
#include "conspage.h"
#include "consspaceobject.h"
#include "debug.h"
#include "equal.h"
#include "lispops.h"
#include "print.h"
@ -56,22 +57,22 @@ internedp( struct cons_pointer key, struct cons_pointer store ) {
struct cons_space_object entry =
pointer2cell( pointer2cell( next ).payload.cons.car );
fputws( L"Internedp: checking whether `", stderr );
print( stderr, key );
fputws( L"` equals `", stderr );
print( stderr, entry.payload.cons.car );
fputws( L"`\n", stderr );
debug_print( L"Internedp: checking whether `", DEBUG_ALLOC );
debug_print_object( key, DEBUG_ALLOC );
debug_print( L"` equals `", DEBUG_ALLOC );
debug_print_object( entry.payload.cons.car, DEBUG_ALLOC );
debug_print( L"`\n", DEBUG_ALLOC );
if ( equal( key, entry.payload.cons.car ) ) {
result = entry.payload.cons.car;
}
}
} else {
fputws( L"`", stderr );
print( stderr, key );
fputws( L"` is a ", stderr );
print( stderr, c_type( key ) );
fputws( L", not a SYMB", stderr );
debug_print( L"`", DEBUG_ALLOC );
debug_print_object( key, DEBUG_ALLOC );
debug_print( L"` is a ", DEBUG_ALLOC );
debug_print_object( c_type( key ), DEBUG_ALLOC );
debug_print( L", not a SYMB", DEBUG_ALLOC );
}
return result;
@ -110,6 +111,12 @@ struct cons_pointer c_assoc( struct cons_pointer key,
struct cons_pointer
bind( struct cons_pointer key, struct cons_pointer value,
struct cons_pointer store ) {
debug_print(L"Binding ", DEBUG_ALLOC);
debug_print_object(key, DEBUG_ALLOC);
debug_print(L" to ", DEBUG_ALLOC);
debug_print_object(value, DEBUG_ALLOC);
debug_println(DEBUG_ALLOC);
return make_cons( make_cons( key, value ), store );
}
@ -120,7 +127,17 @@ bind( struct cons_pointer key, struct cons_pointer value,
*/
struct cons_pointer
deep_bind( struct cons_pointer key, struct cons_pointer value ) {
debug_print( L"Entering deep_bind\n", DEBUG_ALLOC );
debug_print( L"\tSetting ", DEBUG_ALLOC );
debug_print_object( key, DEBUG_ALLOC );
debug_print( L" to ", DEBUG_ALLOC );
debug_print_object( value, DEBUG_ALLOC );
debug_print( L"\n", DEBUG_ALLOC );
oblist = bind( key, value, oblist );
debug_print( L"Leaving deep_bind\n", DEBUG_ALLOC );
return oblist;
}

0
src/intern.h → src/ops/intern.h
View file

421
src/lispops.c → src/ops/lispops.c
View file

@ -26,6 +26,8 @@
#include "consspaceobject.h"
#include "conspage.h"
#include "debug.h"
#include "dump.h"
#include "equal.h"
#include "integer.h"
#include "intern.h"
@ -80,23 +82,27 @@ struct cons_pointer c_cdr( struct cons_pointer arg ) {
* @return the result of evaluating the form.
*/
struct cons_pointer eval_form( struct stack_frame *parent,
struct cons_pointer parent_pointer,
struct cons_pointer form,
struct cons_pointer env ) {
fputws( L"eval_form: ", stderr );
print( stderr, form );
fputws( L"\n", stderr );
debug_print( L"eval_form: ", DEBUG_EVAL );
debug_dump_object( form, DEBUG_EVAL );
struct cons_pointer result = NIL;
struct stack_frame *next = make_empty_frame( parent, env );
next->arg[0] = form;
inc_ref( next->arg[0] );
result = lisp_eval( next, env );
struct cons_pointer next_pointer = make_empty_frame( parent_pointer );
inc_ref( next_pointer );
struct stack_frame *next = get_stack_frame( next_pointer );
set_reg( next, 0, form );
next->args = 1;
result = lisp_eval( next, next_pointer, env );
if ( !exceptionp( result ) ) {
/* if we're returning an exception, we should NOT free the
* stack frame. Corollary is, when we free an exception, we
* should free all the frames it's holding on to. */
free_stack_frame( next );
dec_ref( next_pointer );
}
return result;
@ -108,11 +114,14 @@ struct cons_pointer eval_form( struct stack_frame *parent,
* `list` is not in fact a list, return nil.
*/
struct cons_pointer eval_forms( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer list,
struct cons_pointer env ) {
/* TODO: refactor. This runs up the C stack. */
return consp( list ) ?
make_cons( eval_form( frame, c_car( list ), env ),
eval_forms( frame, c_cdr( list ), env ) ) : NIL;
make_cons( eval_form( frame, frame_pointer, c_car( list ), env ),
eval_forms( frame, frame_pointer, c_cdr( list ),
env ) ) : NIL;
}
/**
@ -121,7 +130,8 @@ struct cons_pointer eval_forms( struct stack_frame *frame,
* (oblist)
*/
struct cons_pointer
lisp_oblist( struct stack_frame *frame, struct cons_pointer env ) {
lisp_oblist( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
return oblist;
}
@ -130,8 +140,7 @@ lisp_oblist( struct stack_frame *frame, struct cons_pointer env ) {
* used to construct the body for `lambda` and `nlambda` expressions.
*/
struct cons_pointer compose_body( struct stack_frame *frame ) {
struct cons_pointer body =
!nilp( frame->arg[args_in_frame - 1] ) ? frame->more : NIL;
struct cons_pointer body = frame->more;
for ( int i = args_in_frame - 1; i > 0; i-- ) {
if ( !nilp( body ) ) {
@ -141,9 +150,8 @@ struct cons_pointer compose_body( struct stack_frame *frame ) {
}
}
fputws( L"compose_body returning ", stderr );
print( stderr, body );
fputws( L"\n", stderr );
debug_print( L"compose_body returning ", DEBUG_LAMBDA );
debug_dump_object( body, DEBUG_LAMBDA );
return body;
}
@ -155,7 +163,8 @@ struct cons_pointer compose_body( struct stack_frame *frame ) {
* @param env the environment in which it is to be intepreted.
*/
struct cons_pointer
lisp_lambda( struct stack_frame *frame, struct cons_pointer env ) {
lisp_lambda( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
return make_lambda( frame->arg[0], compose_body( frame ) );
}
@ -166,16 +175,16 @@ lisp_lambda( struct stack_frame *frame, struct cons_pointer env ) {
* @param env the environment in which it is to be intepreted.
*/
struct cons_pointer
lisp_nlambda( struct stack_frame *frame, struct cons_pointer env ) {
lisp_nlambda( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
return make_nlambda( frame->arg[0], compose_body( frame ) );
}
void log_binding( struct cons_pointer name, struct cons_pointer val ) {
print( stderr, c_string_to_lisp_string( "\n\tBinding " ) );
print( stderr, name );
print( stderr, c_string_to_lisp_string( " to " ) );
print( stderr, val );
fputws( L"\"\n", stderr );
debug_print( L"\n\tBinding ", DEBUG_ALLOC );
debug_dump_object( name, DEBUG_ALLOC );
debug_print( L" to ", DEBUG_ALLOC );
debug_dump_object( val, DEBUG_ALLOC );
}
/**
@ -183,9 +192,9 @@ void log_binding( struct cons_pointer name, struct cons_pointer val ) {
*/
struct cons_pointer
eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
struct cons_pointer env ) {
struct cons_pointer frame_pointer, struct cons_pointer env ) {
struct cons_pointer result = NIL;
fwprintf( stderr, L"eval_lambda called\n" );
debug_print( L"eval_lambda called\n", DEBUG_EVAL );
struct cons_pointer new_env = env;
struct cons_pointer names = cell.payload.lambda.args;
@ -194,7 +203,7 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
if ( consp( names ) ) {
/* if `names` is a list, bind successive items from that list
* to values of arguments */
for ( int i = 0; i < args_in_frame && consp( names ); i++ ) {
for ( int i = 0; i < frame->args && consp( names ); i++ ) {
struct cons_pointer name = c_car( names );
struct cons_pointer val = frame->arg[i];
@ -203,13 +212,16 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
names = c_cdr( names );
}
/* TODO: if there's more than `args_in_frame` arguments, bind those too. */
} else if ( symbolp( names ) ) {
/* if `names` is a symbol, rather than a list of symbols,
* then bind a list of the values of args to that symbol. */
/* TODO: eval all the things in frame->more */
struct cons_pointer vals = frame->more;
for ( int i = args_in_frame - 1; i >= 0; i-- ) {
struct cons_pointer val = eval_form( frame, frame->arg[i], env );
struct cons_pointer val =
eval_form( frame, frame_pointer, frame->arg[i], env );
if ( nilp( val ) && nilp( vals ) ) { /* nothing */
} else {
@ -223,8 +235,10 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
while ( !nilp( body ) ) {
struct cons_pointer sexpr = c_car( body );
body = c_cdr( body );
fputws( L"In lambda: ", stderr );
result = eval_form( frame, sexpr, new_env );
debug_print( L"In lambda: ", DEBUG_LAMBDA );
result = eval_form( frame, frame_pointer, sexpr, new_env );
}
return result;
@ -239,20 +253,17 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
* @return the result of evaluating the function with its arguments.
*/
struct cons_pointer
c_apply( struct stack_frame *frame, struct cons_pointer env ) {
struct cons_pointer result = NIL;
struct stack_frame *fn_frame = make_empty_frame( frame, env );
fn_frame->arg[0] = c_car( frame->arg[0] );
inc_ref( fn_frame->arg[0] );
struct cons_pointer fn_pointer = lisp_eval( fn_frame, env );
c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
debug_print(L"Entering c_apply\n", DEBUG_EVAL);
struct cons_pointer result = NIL;
if ( !exceptionp( result ) ) {
/* if we're returning an exception, we should NOT free the
* stack frame. Corollary is, when we free an exception, we
* should free all the frames it's holding on to. */
free_stack_frame( fn_frame );
}
struct cons_pointer fn_pointer =
eval_form( frame, frame_pointer, c_car( frame->arg[0] ), env );
if ( exceptionp( fn_pointer ) ) {
result = fn_pointer;
} else {
struct cons_space_object fn_cell = pointer2cell( fn_pointer );
struct cons_pointer args = c_cdr( frame->arg[0] );
@ -264,80 +275,92 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) {
case FUNCTIONTV:
{
struct cons_pointer exep = NIL;
struct stack_frame *next =
make_stack_frame( frame, args, env, &exep );
result = ( *fn_cell.payload.special.executable ) ( next, env );
if ( exceptionp( exep ) ) {
/* if we're returning an exception, we should NOT free the
* stack frame. Corollary is, when we free an exception, we
* should free all the frames it's holding on to. */
result = exep;
struct cons_pointer next_pointer =
make_stack_frame( frame_pointer, args, env );
inc_ref( next_pointer );
if ( exceptionp( next_pointer ) ) {
result = next_pointer;
} else {
free_stack_frame( next );
struct stack_frame *next = get_stack_frame( next_pointer );
result =
( *fn_cell.payload.function.executable ) ( next,
next_pointer,
env );
dec_ref( next_pointer );
}
}
break;
case LAMBDATV:
{
struct cons_pointer exep = NIL;
struct stack_frame *next =
make_stack_frame( frame, args, env, &exep );
fputws( L"Stack frame for lambda\n", stderr );
dump_frame( stderr, next );
result = eval_lambda( fn_cell, next, env );
if ( exceptionp( result ) ) {
/* if we're returning an exception, we should NOT free the
* stack frame. Corollary is, when we free an exception, we
* should free all the frames it's holding on to. */
result = exep;
struct cons_pointer next_pointer =
make_stack_frame( frame_pointer, args, env );
inc_ref( next_pointer );
if ( exceptionp( next_pointer ) ) {
result = next_pointer;
} else {
free_stack_frame( next );
struct stack_frame *next = get_stack_frame( next_pointer );
result = eval_lambda( fn_cell, next, next_pointer, env );
if ( !exceptionp( result ) ) {
dec_ref( next_pointer );
}
}
}
break;
case NLAMBDATV:
{
struct stack_frame *next =
make_special_frame( frame, args, env );
fputws( L"Stack frame for nlambda\n", stderr );
dump_frame( stderr, next );
result = eval_lambda( fn_cell, next, env );
if ( !exceptionp( result ) ) {
/* if we're returning an exception, we should NOT free the
* stack frame. Corollary is, when we free an exception, we
* should free all the frames it's holding on to. */
free_stack_frame( next );
struct cons_pointer next_pointer =
make_special_frame( frame_pointer, args, env );
inc_ref( next_pointer );
if ( exceptionp( next_pointer ) ) {
result = next_pointer;
} else {
struct stack_frame *next =
get_stack_frame( next_pointer );
result = eval_lambda( fn_cell, next, next_pointer, env );
dec_ref( next_pointer );
}
}
break;
case SPECIALTV:
{
struct stack_frame *next =
make_special_frame( frame, args, env );
result = ( *fn_cell.payload.special.executable ) ( next, env );
if ( !exceptionp( result ) ) {
/* if we're returning an exception, we should NOT free the
* stack frame. Corollary is, when we free an exception, we
* should free all the frames it's holding on to. */
free_stack_frame( next );
struct cons_pointer next_pointer =
make_special_frame( frame_pointer, args, env );
inc_ref( next_pointer );
if ( exceptionp( next_pointer ) ) {
result = next_pointer;
} else {
result =
( *fn_cell.payload.special.executable ) ( get_stack_frame( next_pointer ),
next_pointer,
env );
debug_print(L"Special form returning: ", DEBUG_EVAL);
debug_print_object(result, DEBUG_EVAL);
debug_println(DEBUG_EVAL);
dec_ref( next_pointer );
}
}
break;
default:
{
char *buffer = malloc( 1024 );
memset( buffer, '\0', 1024 );
sprintf( buffer,
"Unexpected cell with tag %d (%c%c%c%c) in function position",
fn_cell.tag.value, fn_cell.tag.bytes[0],
fn_cell.tag.bytes[1], fn_cell.tag.bytes[2],
fn_cell.tag.bytes[3] );
int bs = sizeof(wchar_t) * 1024;
wchar_t *buffer = malloc( bs );
memset( buffer, '\0', bs );
swprintf( buffer, bs,
L"Unexpected cell with tag %d (%4.4s) in function position",
fn_cell.tag.value, &fn_cell.tag.bytes[0] );
struct cons_pointer message =
c_string_to_lisp_string( buffer );
free( buffer );
result = lisp_throw( message, frame );
result = throw_exception( message, frame_pointer );
}
}
}
debug_print(L"c_apply: returning: ", DEBUG_EVAL);
debug_print_object(result, DEBUG_EVAL);
debug_println(DEBUG_EVAL);
return result;
}
@ -349,13 +372,13 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) {
* @return As a Lisp string, the tag of the object which is at that pointer.
*/
struct cons_pointer c_type( struct cons_pointer pointer ) {
char *buffer = malloc( TAGLENGTH + 1 );
memset( buffer, 0, TAGLENGTH + 1 );
struct cons_pointer result = NIL;
struct cons_space_object cell = pointer2cell( pointer );
strncpy( buffer, cell.tag.bytes, TAGLENGTH );
struct cons_pointer result = c_string_to_lisp_string( buffer );
free( buffer );
for (int i = TAGLENGTH; i >= 0; i--)
{
result = make_string((wchar_t)cell.tag.bytes[i], result);
}
return result;
}
@ -375,17 +398,18 @@ struct cons_pointer c_type( struct cons_pointer pointer ) {
* If a special form, passes the cdr of s_expr to the special form as argument.
*/
struct cons_pointer
lisp_eval( struct stack_frame *frame, struct cons_pointer env ) {
lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
debug_print( L"Eval: ", DEBUG_EVAL );
debug_dump_object( frame_pointer, DEBUG_EVAL );
struct cons_pointer result = frame->arg[0];
struct cons_space_object cell = pointer2cell( frame->arg[0] );
fputws( L"Eval: ", stderr );
dump_frame( stderr, frame );
switch ( cell.tag.value ) {
case CONSTV:
{
result = c_apply( frame, env );
result = c_apply( frame, frame_pointer, env );
}
break;
@ -396,9 +420,9 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer env ) {
if ( nilp( canonical ) ) {
struct cons_pointer message =
make_cons( c_string_to_lisp_string
( "Attempt to take value of unbound symbol." ),
( L"Attempt to take value of unbound symbol." ),
frame->arg[0] );
result = lisp_throw( message, frame );
result = throw_exception( message, frame_pointer );
} else {
result = c_assoc( canonical, env );
inc_ref( result );
@ -418,9 +442,8 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer env ) {
break;
}
fputws( L"Eval returning ", stderr );
print( stderr, result );
fputws( L"\n", stderr );
debug_print( L"Eval returning ", DEBUG_EVAL );
debug_dump_object( result, DEBUG_EVAL );
return result;
}
@ -434,19 +457,19 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer env ) {
* the second argument
*/
struct cons_pointer
lisp_apply( struct stack_frame *frame, struct cons_pointer env ) {
fputws( L"Apply: ", stderr );
dump_frame( stderr, frame );
lisp_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
#ifdef DEBUG
debug_print( L"Apply: ", DEBUG_EVAL );
dump_frame( stderr, frame_pointer );
#endif
set_reg( frame, 0, make_cons( frame->arg[0], frame->arg[1] ) );
set_reg( frame, 1, NIL );
frame->arg[0] = make_cons( frame->arg[0], frame->arg[1] );
inc_ref( frame->arg[0] );
frame->arg[1] = NIL;
struct cons_pointer result = c_apply( frame, frame_pointer, env );
struct cons_pointer result = c_apply( frame, env );
fputws( L"Apply returning ", stderr );
print( stderr, result );
fputws( L"\n", stderr );
debug_print( L"Apply returning ", DEBUG_EVAL );
debug_dump_object( result, DEBUG_EVAL );
return result;
}
@ -460,7 +483,8 @@ lisp_apply( struct stack_frame *frame, struct cons_pointer env ) {
* this isn't at this stage checked) unevaluated.
*/
struct cons_pointer
lisp_quote( struct stack_frame *frame, struct cons_pointer env ) {
lisp_quote( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
return frame->arg[0];
}
@ -475,7 +499,8 @@ lisp_quote( struct stack_frame *frame, struct cons_pointer env ) {
* the namespace in so doing. `namespace` defaults to the value of `oblist`.
*/
struct cons_pointer
lisp_set( struct stack_frame *frame, struct cons_pointer env ) {
lisp_set( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
struct cons_pointer result = NIL;
struct cons_pointer namespace =
nilp( frame->arg[2] ) ? oblist : frame->arg[2];
@ -487,8 +512,9 @@ lisp_set( struct stack_frame *frame, struct cons_pointer env ) {
result =
make_exception( make_cons
( c_string_to_lisp_string
( "The first argument to `set!` is not a symbol: " ),
make_cons( frame->arg[0], NIL ) ), frame );
( L"The first argument to `set` is not a symbol: " ),
make_cons( frame->arg[0], NIL ) ),
frame_pointer );
}
return result;
@ -505,21 +531,24 @@ lisp_set( struct stack_frame *frame, struct cons_pointer env ) {
* the namespace in so doing. `namespace` defaults to the value of `oblist`.
*/
struct cons_pointer
lisp_set_shriek( struct stack_frame *frame, struct cons_pointer env ) {
lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
struct cons_pointer result = NIL;
struct cons_pointer namespace =
nilp( frame->arg[2] ) ? oblist : frame->arg[2];
if ( symbolp( frame->arg[0] ) ) {
struct cons_pointer val = eval_form( frame, frame->arg[1], env );
struct cons_pointer val =
eval_form( frame, frame_pointer, frame->arg[1], env );
deep_bind( frame->arg[0], val );
result = val;
} else {
result =
make_exception( make_cons
( c_string_to_lisp_string
( "The first argument to `set!` is not a symbol: " ),
make_cons( frame->arg[0], NIL ) ), frame );
( L"The first argument to `set!` is not a symbol: " ),
make_cons( frame->arg[0], NIL ) ),
frame_pointer );
}
return result;
@ -534,7 +563,8 @@ lisp_set_shriek( struct stack_frame *frame, struct cons_pointer env ) {
* otherwise returns a new cons cell.
*/
struct cons_pointer
lisp_cons( struct stack_frame *frame, struct cons_pointer env ) {
lisp_cons( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
struct cons_pointer car = frame->arg[0];
struct cons_pointer cdr = frame->arg[1];
struct cons_pointer result;
@ -558,7 +588,8 @@ lisp_cons( struct stack_frame *frame, struct cons_pointer env ) {
* strings, and TODO read streams and other things which can be considered as sequences.
*/
struct cons_pointer
lisp_car( struct stack_frame *frame, struct cons_pointer env ) {
lisp_car( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
struct cons_pointer result = NIL;
if ( consp( frame->arg[0] ) ) {
@ -569,8 +600,8 @@ lisp_car( struct stack_frame *frame, struct cons_pointer env ) {
result = make_string( cell.payload.string.character, NIL );
} else {
struct cons_pointer message =
c_string_to_lisp_string( "Attempt to take CAR of non sequence" );
result = lisp_throw( message, frame );
c_string_to_lisp_string( L"Attempt to take CAR of non sequence" );
result = throw_exception( message, frame_pointer );
}
return result;
@ -582,7 +613,8 @@ lisp_car( struct stack_frame *frame, struct cons_pointer env ) {
* strings, and TODO read streams and other things which can be considered as sequences.
*/
struct cons_pointer
lisp_cdr( struct stack_frame *frame, struct cons_pointer env ) {
lisp_cdr( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
struct cons_pointer result = NIL;
if ( consp( frame->arg[0] ) ) {
@ -593,8 +625,8 @@ lisp_cdr( struct stack_frame *frame, struct cons_pointer env ) {
result = cell.payload.string.cdr;
} else {
struct cons_pointer message =
c_string_to_lisp_string( "Attempt to take CDR of non sequence" );
result = lisp_throw( message, frame );
c_string_to_lisp_string( L"Attempt to take CDR of non sequence" );
result = throw_exception( message, frame_pointer );
}
return result;
@ -605,7 +637,8 @@ lisp_cdr( struct stack_frame *frame, struct cons_pointer env ) {
* Returns the value associated with key in store, or NIL if not found.
*/
struct cons_pointer
lisp_assoc( struct stack_frame *frame, struct cons_pointer env ) {
lisp_assoc( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
return c_assoc( frame->arg[0], frame->arg[1] );
}
@ -614,6 +647,7 @@ lisp_assoc( struct stack_frame *frame, struct cons_pointer env ) {
* Returns T if a and b are pointers to the same object, else NIL
*/
struct cons_pointer lisp_eq( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ) {
return eq( frame->arg[0], frame->arg[1] ) ? TRUE : NIL;
}
@ -623,7 +657,8 @@ struct cons_pointer lisp_eq( struct stack_frame *frame,
* Returns T if a and b are pointers to structurally identical objects, else NIL
*/
struct cons_pointer
lisp_equal( struct stack_frame *frame, struct cons_pointer env ) {
lisp_equal( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
return equal( frame->arg[0], frame->arg[1] ) ? TRUE : NIL;
}
@ -634,14 +669,58 @@ lisp_equal( struct stack_frame *frame, struct cons_pointer env ) {
* is a read stream, then read from that stream, else stdin.
*/
struct cons_pointer
lisp_read( struct stack_frame *frame, struct cons_pointer env ) {
lisp_read( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
#ifdef DEBUG
debug_print( L"entering lisp_read\n", DEBUG_IO );
#endif
FILE *input = stdin;
if ( readp( frame->arg[0] ) ) {
input = pointer2cell( frame->arg[0] ).payload.stream.stream;
}
return read( frame, input );
struct cons_pointer result = read( frame, frame_pointer, input );
debug_print( L"lisp_read returning\n", DEBUG_IO );
debug_dump_object( result, DEBUG_IO );
return result;
}
/**
* reverse a sequence.
*/
struct cons_pointer c_reverse( struct cons_pointer arg ) {
struct cons_pointer result = NIL;
for ( struct cons_pointer p = arg; sequencep( p ); p = c_cdr( p ) ) {
struct cons_space_object o = pointer2cell( p );
switch ( o.tag.value ) {
case CONSTV:
result = make_cons( o.payload.cons.car, result );
break;
case STRINGTV:
result = make_string( o.payload.string.character, result );
break;
case SYMBOLTV:
result = make_symbol( o.payload.string.character, result );
break;
}
}
return result;
}
/**
* (reverse sequence)
* Return a sequence like this sequence but with the members in the reverse order.
*/
struct cons_pointer lisp_reverse( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ) {
return c_reverse( frame->arg[0] );
}
@ -652,16 +731,26 @@ lisp_read( struct stack_frame *frame, struct cons_pointer env ) {
* is a write stream, then print to that stream, else stdout.
*/
struct cons_pointer
lisp_print( struct stack_frame *frame, struct cons_pointer env ) {
lisp_print( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
debug_print( L"Entering print\n", DEBUG_IO );
struct cons_pointer result = NIL;
FILE *output = stdout;
if ( writep( frame->arg[1] ) ) {
debug_print( L"lisp_print: setting output stream\n", DEBUG_IO );
debug_dump_object( frame->arg[1], DEBUG_IO );
output = pointer2cell( frame->arg[1] ).payload.stream.stream;
}
debug_print( L"lisp_print: about to print\n", DEBUG_IO );
debug_dump_object( frame->arg[0], DEBUG_IO );
print( output, frame->arg[0] );
result = print( output, frame->arg[0] );
return NIL;
debug_print( L"lisp_print returning\n", DEBUG_IO );
debug_dump_object( result, DEBUG_IO );
return result;
}
@ -672,7 +761,8 @@ lisp_print( struct stack_frame *frame, struct cons_pointer env ) {
* @return As a Lisp string, the tag of the object which is the argument.
*/
struct cons_pointer
lisp_type( struct stack_frame *frame, struct cons_pointer env ) {
lisp_type( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
return c_type( frame->arg[0] );
}
@ -690,16 +780,17 @@ lisp_type( struct stack_frame *frame, struct cons_pointer env ) {
* argument.
*/
struct cons_pointer
lisp_progn( struct stack_frame *frame, struct cons_pointer env ) {
lisp_progn( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
struct cons_pointer remaining = frame->more;
struct cons_pointer result = NIL;
for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] ); i++ ) {
result = eval_form( frame, frame->arg[i], env );
result = eval_form( frame, frame_pointer, frame->arg[i], env );
}
while ( consp( remaining ) ) {
result = eval_form( frame, c_car( remaining ), env );
result = eval_form( frame, frame_pointer, c_car( remaining ), env );
remaining = c_cdr( remaining );
}
@ -717,22 +808,26 @@ lisp_progn( struct stack_frame *frame, struct cons_pointer env ) {
* @return the value of the last form of the first successful clause.
*/
struct cons_pointer
lisp_cond( struct stack_frame *frame, struct cons_pointer env ) {
lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
struct cons_pointer result = NIL;
bool done = false;
for ( int i = 0; i < args_in_frame && !done; i++ ) {
struct cons_pointer clause_pointer = frame->arg[i];
fputws( L"Cond clause: ", stderr );
print( stderr, clause_pointer );
debug_print( L"Cond clause: ", DEBUG_EVAL );
debug_dump_object( clause_pointer, DEBUG_EVAL );
if ( consp( clause_pointer ) ) {
struct cons_space_object cell = pointer2cell( clause_pointer );
result = eval_form( frame, c_car( clause_pointer ), env );
result =
eval_form( frame, frame_pointer, c_car( clause_pointer ),
env );
if ( !nilp( result ) ) {
struct cons_pointer vals =
eval_forms( frame, c_cdr( clause_pointer ), env );
eval_forms( frame, frame_pointer, c_cdr( clause_pointer ),
env );
while ( consp( vals ) ) {
result = c_car( vals );
@ -744,9 +839,9 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer env ) {
} else if ( nilp( clause_pointer ) ) {
done = true;
} else {
result = lisp_throw( c_string_to_lisp_string
( "Arguments to `cond` must be lists" ),
frame );
result = throw_exception( c_string_to_lisp_string
( L"Arguments to `cond` must be lists" ),
frame_pointer );
}
}
/* TODO: if there are more than 8 clauses we need to continue into the
@ -756,17 +851,20 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer env ) {
}
/**
* TODO: make this do something sensible somehow.
* This requires that a frame be a heap-space object with a cons-space
* Throw an exception.
* `throw_exception` is a misnomer, because it doesn't obey the calling signature of a
* lisp function; but it is nevertheless to be preferred to make_exception. A
* real `throw_exception`, which does, will be needed.
* object pointing to it. Then this should become a normal lisp function
* which expects a normally bound frame and environment, such that
* frame->arg[0] is the message, and frame->arg[1] is the cons-space
* pointer to the frame in which the exception occurred.
*/
struct cons_pointer
lisp_throw( struct cons_pointer message, struct stack_frame *frame ) {
fwprintf( stderr, L"\nERROR: " );
print( stderr, message );
throw_exception( struct cons_pointer message,
struct cons_pointer frame_pointer ) {
debug_print( L"\nERROR: ", DEBUG_EVAL );
debug_dump_object( message, DEBUG_EVAL );
struct cons_pointer result = NIL;
struct cons_space_object cell = pointer2cell( message );
@ -774,8 +872,25 @@ lisp_throw( struct cons_pointer message, struct stack_frame *frame ) {
if ( cell.tag.value == EXCEPTIONTV ) {
result = message;
} else {
result = make_exception( message, frame );
result = make_exception( message, frame_pointer );
}
return result;
}
/**
* (exception <message>)
*
* Function. Returns an exception whose message is this `message`, and whose
* stack frame is the parent stack frame when the function is invoked.
* `message` does not have to be a string but should be something intelligible
* which can be read.
* If `message` is itself an exception, returns that instead.
*/
struct cons_pointer
lisp_exception( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
struct cons_pointer message = frame->arg[0];
return exceptionp( message ) ? message : make_exception( message,
frame->previous );
}

58
src/lispops.h → src/ops/lispops.h
View file

@ -40,6 +40,7 @@ struct cons_pointer c_car( struct cons_pointer arg );
*/
struct cons_pointer c_cdr( struct cons_pointer arg );
struct cons_pointer c_reverse( struct cons_pointer arg );
/**
* Useful building block; evaluate this single form in the context of this
@ -50,6 +51,7 @@ struct cons_pointer c_cdr( struct cons_pointer arg );
* @return the result of evaluating the form.
*/
struct cons_pointer eval_form( struct stack_frame *parent,
struct cons_pointer parent_pointer,
struct cons_pointer form,
struct cons_pointer env );
@ -59,6 +61,7 @@ struct cons_pointer eval_form( struct stack_frame *parent,
* `list` is not in fact a list, return nil.
*/
struct cons_pointer eval_forms( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer list,
struct cons_pointer env );
@ -67,18 +70,23 @@ struct cons_pointer eval_forms( struct stack_frame *frame,
* special forms
*/
struct cons_pointer lisp_eval( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_apply( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer
lisp_oblist( struct stack_frame *frame, struct cons_pointer env );
lisp_oblist( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer
lisp_set( struct stack_frame *frame, struct cons_pointer env );
lisp_set( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer
lisp_set_shriek( struct stack_frame *frame, struct cons_pointer env );
lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env );
/**
* Construct an interpretable function.
@ -88,6 +96,7 @@ lisp_set_shriek( struct stack_frame *frame, struct cons_pointer env );
* @param env the environment in which it is to be intepreted.
*/
struct cons_pointer lisp_lambda( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
/**
@ -97,30 +106,43 @@ struct cons_pointer lisp_lambda( struct stack_frame *frame,
* @param env the environment in which it is to be intepreted.
*/
struct cons_pointer
lisp_nlambda( struct stack_frame *frame, struct cons_pointer env );
lisp_nlambda( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_quote( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
/*
* functions
*/
struct cons_pointer lisp_cons( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_car( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_cdr( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_assoc( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_eq( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_equal( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_print( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_read( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_print( struct stack_frame *frame,
struct cons_pointer env );
struct cons_pointer lisp_reverse( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
/**
* Function: Get the Lisp type of the single argument.
* @param frame My stack frame.
@ -128,7 +150,8 @@ struct cons_pointer lisp_print( struct stack_frame *frame,
* @return As a Lisp string, the tag of the object which is the argument.
*/
struct cons_pointer
lisp_type( struct stack_frame *frame, struct cons_pointer env );
lisp_type( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env );
/**
@ -142,7 +165,8 @@ lisp_type( struct stack_frame *frame, struct cons_pointer env );
* argument.
*/
struct cons_pointer
lisp_progn( struct stack_frame *frame, struct cons_pointer env );
lisp_progn( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env );
/**
* Special form: conditional. Each arg is expected to be a list; if the first
@ -154,10 +178,18 @@ lisp_progn( struct stack_frame *frame, struct cons_pointer env );
* @return the value of the last form of the first successful clause.
*/
struct cons_pointer
lisp_cond( struct stack_frame *frame, struct cons_pointer env );
lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env );
/*
* neither, at this stage, really
/**
* Throw an exception.
* `throw_exception` is a misnomer, because it doesn't obey the calling signature of a
* lisp function; but it is nevertheless to be preferred to make_exception. A
* real `throw_exception`, which does, will be needed.
*/
struct cons_pointer lisp_throw( struct cons_pointer message,
struct stack_frame *frame );
struct cons_pointer throw_exception( struct cons_pointer message,
struct cons_pointer frame_pointer );
struct cons_pointer
lisp_exception( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env );

29
src/print.c → src/ops/print.c
View file

@ -20,6 +20,7 @@
#include "conspage.h"
#include "consspaceobject.h"
#include "integer.h"
#include "stack.h"
#include "print.h"
/**
@ -36,7 +37,7 @@ int print_use_colours = 0;
void print_string_contents( FILE * output, struct cons_pointer pointer ) {
while ( stringp( pointer ) || symbolp( pointer ) ) {
struct cons_space_object *cell = &pointer2cell( pointer );
wint_t c = cell->payload.string.character;
wchar_t c = cell->payload.string.character;
if ( c != '\0' ) {
fputwc( c, output );
@ -103,7 +104,7 @@ void print_list( FILE * output, struct cons_pointer pointer ) {
* Print the cons-space object indicated by `pointer` to the stream indicated
* by `output`.
*/
void print( FILE * output, struct cons_pointer pointer ) {
struct cons_pointer print( FILE * output, struct cons_pointer pointer ) {
struct cons_space_object cell = pointer2cell( pointer );
char *buffer;
@ -118,7 +119,7 @@ void print( FILE * output, struct cons_pointer pointer ) {
case EXCEPTIONTV:
fwprintf( output, L"\n%sException: ",
print_use_colours ? "\x1B[31m" : "" );
print_string_contents( output, cell.payload.exception.message );
dump_stack_trace( output, pointer );
break;
case FUNCTIONTV:
fwprintf( output, L"(Function)" );
@ -130,19 +131,24 @@ void print( FILE * output, struct cons_pointer pointer ) {
fwprintf( output, L"%ld%", cell.payload.integer.value );
break;
case LAMBDATV:
print( output, make_cons( c_string_to_lisp_symbol( "lambda" ),
print( output, make_cons( c_string_to_lisp_symbol( L"lambda" ),
make_cons( cell.payload.lambda.args,
cell.payload.
lambda.body ) ) );
cell.payload.lambda.
body ) ) );
break;
case NILTV:
fwprintf( output, L"nil" );
break;
case NLAMBDATV:
print( output, make_cons( c_string_to_lisp_symbol( "nlambda" ),
print( output, make_cons( c_string_to_lisp_symbol( L"nlambda" ),
make_cons( cell.payload.lambda.args,
cell.payload.
lambda.body ) ) );
cell.payload.lambda.
body ) ) );
break;
case RATIOTV:
print( output, cell.payload.ratio.dividend );
fputws( L"/", output );
print( output, cell.payload.ratio.divisor );
break;
case READTV:
fwprintf( output, L"(Input stream)" );
@ -184,6 +190,9 @@ void print( FILE * output, struct cons_pointer pointer ) {
case TRUETV:
fwprintf( output, L"t" );
break;
case WRITETV:
fwprintf( output, L"(Output stream)" );
break;
default:
fwprintf( stderr,
L"%sError: Unrecognised tag value %d (%c%c%c%c)\n",
@ -196,4 +205,6 @@ void print( FILE * output, struct cons_pointer pointer ) {
if ( print_use_colours ) {
fputws( L"\x1B[39m", output );
}
return pointer;
}

2
src/print.h → src/ops/print.h
View file

@ -14,7 +14,7 @@
#ifndef __print_h
#define __print_h
void print( FILE * output, struct cons_pointer pointer );
struct cons_pointer print( FILE * output, struct cons_pointer pointer );
extern int print_use_colours;
#endif

157
src/read.c → src/ops/read.c
View file

@ -18,12 +18,16 @@
#include <wctype.h>
#include "consspaceobject.h"
#include "debug.h"
#include "dump.h"
#include "integer.h"
#include "intern.h"
#include "lispops.h"
#include "print.h"
#include "ratio.h"
#include "read.h"
#include "real.h"
#include "vectorspace.h"
/*
* for the time being things which may be read are: strings numbers - either
@ -31,8 +35,12 @@
* atoms because I don't yet know what an atom is or how it's stored.
*/
struct cons_pointer read_number( FILE * input, wint_t initial );
struct cons_pointer read_list( struct stack_frame *frame, FILE * input,
struct cons_pointer read_number( struct stack_frame *frame,
struct cons_pointer frame_pointer,
FILE * input, wint_t initial,
bool seen_period );
struct cons_pointer read_list( struct stack_frame *frame,
struct cons_pointer frame_pointer, FILE * input,
wint_t initial );
struct cons_pointer read_string( FILE * input, wint_t initial );
struct cons_pointer read_symbol( FILE * input, wint_t initial );
@ -41,7 +49,7 @@ struct cons_pointer read_symbol( FILE * input, wint_t initial );
* quote reader macro in C (!)
*/
struct cons_pointer c_quote( struct cons_pointer arg ) {
return make_cons( c_string_to_lisp_symbol( "quote" ),
return make_cons( c_string_to_lisp_symbol( L"quote" ),
make_cons( arg, NIL ) );
}
@ -50,8 +58,10 @@ struct cons_pointer c_quote( struct cons_pointer arg ) {
* treating this initial character as the first character of the object
* representation.
*/
struct cons_pointer read_continuation( struct stack_frame *frame, FILE * input,
wint_t initial ) {
struct cons_pointer read_continuation( struct stack_frame *frame,
struct cons_pointer frame_pointer,
FILE * input, wint_t initial ) {
debug_print( L"entering read_continuation\n", DEBUG_IO );
struct cons_pointer result = NIL;
wint_t c;
@ -61,8 +71,8 @@ struct cons_pointer read_continuation( struct stack_frame *frame, FILE * input,
if ( feof( input ) ) {
result =
make_exception( c_string_to_lisp_string
( "End of file while reading" ), frame );
throw_exception( c_string_to_lisp_string
( L"End of file while reading" ), frame_pointer );
} else {
switch ( c ) {
case ';':
@ -70,31 +80,49 @@ struct cons_pointer read_continuation( struct stack_frame *frame, FILE * input,
/* skip all characters from semi-colon to the end of the line */
break;
case EOF:
result = lisp_throw( c_string_to_lisp_string
( "End of input while reading" ), frame );
result = throw_exception( c_string_to_lisp_string
( L"End of input while reading" ),
frame_pointer );
break;
case '\'':
result =
c_quote( read_continuation
( frame, input, fgetwc( input ) ) );
( frame, frame_pointer, input,
fgetwc( input ) ) );
break;
case '(':
result = read_list( frame, input, fgetwc( input ) );
result =
read_list( frame, frame_pointer, input, fgetwc( input ) );
break;
case '"':
result = read_string( input, fgetwc( input ) );
break;
case '-':{
wint_t next = fgetwc( input );
ungetwc( next, input );
if ( iswdigit( next ) ) {
result =
read_number( frame, frame_pointer, input, c,
false );
} else {
result = read_symbol( input, c );
}
}
break;
case '.':
{
wint_t next = fgetwc( input );
if ( iswdigit( next ) ) {
ungetwc( next, input );
result = read_number( input, c );
result =
read_number( frame, frame_pointer, input, c,
true );
} else if ( iswblank( next ) ) {
/* dotted pair. TODO: this isn't right, we
* really need to backtrack up a level. */
result =
read_continuation( frame, input, fgetwc( input ) );
read_continuation( frame, frame_pointer, input,
fgetwc( input ) );
} else {
read_symbol( input, c );
}
@ -102,40 +130,76 @@ struct cons_pointer read_continuation( struct stack_frame *frame, FILE * input,
break;
default:
if ( iswdigit( c ) ) {
result = read_number( input, c );
result =
read_number( frame, frame_pointer, input, c, false );
} else if ( iswprint( c ) ) {
result = read_symbol( input, c );
} else {
result =
make_exception( c_string_to_lisp_string
( "Unrecognised start of input character" ),
frame );
throw_exception( make_cons( c_string_to_lisp_string
( L"Unrecognised start of input character" ),
make_string( c, NIL ) ),
frame_pointer );
}
break;
}
}
debug_print( L"read_continuation returning\n", DEBUG_IO );
debug_dump_object( result, DEBUG_IO );
return result;
}
/**
* read a number from this input stream, given this initial character.
* TODO: to be able to read bignums, we need to read the number from the
* input stream into a Lisp string, and then convert it to a number.
*/
struct cons_pointer read_number( FILE * input, wint_t initial ) {
struct cons_pointer read_number( struct stack_frame *frame,
struct cons_pointer frame_pointer,
FILE * input,
wint_t initial, bool seen_period ) {
debug_print( L"entering read_number\n", DEBUG_IO );
struct cons_pointer result = NIL;
long int accumulator = 0;
int64_t accumulator = 0;
int64_t dividend = 0;
int places_of_decimals = 0;
bool seen_period = false;
wint_t c;
fwprintf( stderr, L"read_number starting '%c' (%d)\n", initial, initial );
bool negative = initial == btowc( '-' );
if ( negative ) {
initial = fgetwc( input );
}
debug_printf( DEBUG_IO, L"read_number starting '%c' (%d)\n", initial, initial );
for ( c = initial; iswdigit( c )
|| c == btowc( '.' ); c = fgetwc( input ) ) {
|| c == btowc( '.' ) || c == btowc( '/' ); c = fgetwc( input ) ) {
if ( c == btowc( '.' ) ) {
seen_period = true;
if ( seen_period || dividend != 0 ) {
return throw_exception( c_string_to_lisp_string
( L"Malformed number: too many periods" ),
frame_pointer );
} else {
seen_period = true;
}
} else if ( c == btowc( '/' ) ) {
if ( seen_period || dividend > 0 ) {
return throw_exception( c_string_to_lisp_string
( L"Malformed number: dividend of rational must be integer" ),
frame_pointer );
} else {
dividend = negative ? 0 - accumulator : accumulator;
accumulator = 0;
}
} else {
accumulator = accumulator * 10 + ( ( int ) c - ( int ) '0' );
fwprintf( stderr,
debug_printf( DEBUG_IO,
L"Added character %c, accumulator now %ld\n",
c, accumulator );
if ( seen_period ) {
places_of_decimals++;
}
@ -149,12 +213,24 @@ struct cons_pointer read_number( FILE * input, wint_t initial ) {
if ( seen_period ) {
long double rv = ( long double )
( accumulator / pow( 10, places_of_decimals ) );
fwprintf( stderr, L"read_numer returning %Lf\n", rv );
if ( negative ) {
rv = 0 - rv;
}
result = make_real( rv );
} else if ( dividend != 0 ) {
result =
make_ratio( frame_pointer, make_integer( dividend ),
make_integer( accumulator ) );
} else {
if ( negative ) {
accumulator = 0 - accumulator;
}
result = make_integer( accumulator );
}
debug_print( L"read_number returning\n", DEBUG_IO );
debug_dump_object( result, DEBUG_IO );
return result;
}
@ -162,18 +238,22 @@ struct cons_pointer read_number( FILE * input, wint_t initial ) {
* Read a list from this input stream, which no longer contains the opening
* left parenthesis.
*/
struct cons_pointer read_list( struct
stack_frame
*frame, FILE * input, wint_t initial ) {
struct cons_pointer read_list( struct stack_frame *frame,
struct cons_pointer frame_pointer,
FILE * input, wint_t initial ) {
struct cons_pointer result = NIL;
if ( initial != ')' ) {
fwprintf( stderr,
debug_printf( DEBUG_IO,
L"read_list starting '%C' (%d)\n", initial, initial );
struct cons_pointer car = read_continuation( frame, input,
initial );
result = make_cons( car, read_list( frame, input, fgetwc( input ) ) );
struct cons_pointer car =
read_continuation( frame, frame_pointer, input,
initial );
result =
make_cons( car,
read_list( frame, frame_pointer, input,
fgetwc( input ) ) );
} else {
fwprintf( stderr, L"End of list detected\n" );
debug_print( L"End of list detected\n", DEBUG_IO );
}
return result;
@ -245,9 +325,9 @@ struct cons_pointer read_symbol( FILE * input, wint_t initial ) {
break;
}
fputws( L"Read symbol '", stderr );
print( stderr, result );
fputws( L"'\n", stderr );
debug_print( L"read_symbol returning\n", DEBUG_IO );
debug_dump_object( result, DEBUG_IO );
return result;
}
@ -256,6 +336,7 @@ struct cons_pointer read_symbol( FILE * input, wint_t initial ) {
*/
struct cons_pointer read( struct
stack_frame
*frame, FILE * input ) {
return read_continuation( frame, input, fgetwc( input ) );
*frame, struct cons_pointer frame_pointer,
FILE * input ) {
return read_continuation( frame, frame_pointer, input, fgetwc( input ) );
}

3
src/read.h → src/ops/read.h
View file

@ -14,6 +14,7 @@
/**
* read the next object on this input stream and return a cons_pointer to it.
*/
struct cons_pointer read( struct stack_frame *frame, FILE * input );
struct cons_pointer read( struct stack_frame *frame,
struct cons_pointer frame_pointer, FILE * input );
#endif

237
src/peano.c
View file

@ -1,237 +0,0 @@
/*
* peano.c
*
* Basic peano arithmetic
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <ctype.h>
#include <stdbool.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <math.h>
#include "consspaceobject.h"
#include "conspage.h"
#include "equal.h"
#include "integer.h"
#include "intern.h"
#include "lispops.h"
#include "print.h"
#include "read.h"
#include "real.h"
#include "stack.h"
/**
* Internal guts of add. Dark and mysterious.
*/
struct cons_pointer add_accumulate( struct cons_pointer arg,
struct stack_frame *frame,
long int *i_accumulator,
long double *d_accumulator, int *is_int ) {
struct cons_pointer result = NIL;
struct cons_space_object cell = pointer2cell( arg );
switch ( cell.tag.value ) {
case INTEGERTV:
( *i_accumulator ) += cell.payload.integer.value;
( *d_accumulator ) += numeric_value( arg );
break;
case REALTV:
( *d_accumulator ) += cell.payload.real.value;
( *is_int ) &= false;
break;
case EXCEPTIONTV:
result = arg;
break;
default:
result = lisp_throw( c_string_to_lisp_string
( "Cannot multiply: not a number" ), frame );
}
return result;
}
/**
* Add an indefinite number of numbers together
* @param env the evaluation environment - ignored;
* @param frame the stack frame.
* @return a pointer to an integer or real.
*/
struct cons_pointer
lisp_add( struct stack_frame *frame, struct cons_pointer env ) {
struct cons_pointer result = NIL;
long int i_accumulator = 0;
long double d_accumulator = 0;
int is_int = true;
for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] ); i++ ) {
result =
add_accumulate( frame->arg[i], frame, &i_accumulator,
&d_accumulator, &is_int );
}
struct cons_pointer more = frame->more;
while ( consp( more ) ) {
result =
add_accumulate( c_car( more ), frame, &i_accumulator,
&d_accumulator, &is_int );
more = c_cdr( more );
}
if ( is_int ) {
result = make_integer( i_accumulator );
} else {
result = make_real( d_accumulator );
}
return result;
}
/**
* Internal guts of multiply. Dark and mysterious.
*/
struct cons_pointer multiply_accumulate( struct cons_pointer arg,
struct stack_frame *frame,
long int *i_accumulator,
long double *d_accumulator,
int *is_int ) {
struct cons_pointer result = NIL;
struct cons_space_object cell = pointer2cell( arg );
switch ( cell.tag.value ) {
case INTEGERTV:
( *i_accumulator ) *= cell.payload.integer.value;
( *d_accumulator ) *= numeric_value( arg );
break;
case REALTV:
( *d_accumulator ) *= cell.payload.real.value;
( *is_int ) &= false;
break;
case EXCEPTIONTV:
result = arg;
break;
default:
result = lisp_throw( c_string_to_lisp_string
( "Cannot multiply: not a number" ), frame );
}
return result;
}
/**
* Multiply an indefinite number of numbers together
* @param env the evaluation environment - ignored;
* @param frame the stack frame.
* @return a pointer to an integer or real.
*/
struct cons_pointer
lisp_multiply( struct stack_frame *frame, struct cons_pointer env ) {
struct cons_pointer result = NIL;
long int i_accumulator = 1;
long double d_accumulator = 1;
int is_int = true;
for ( int i = 0;
i < args_in_frame && !nilp( frame->arg[i] ) && !exceptionp( result );
i++ ) {
result =
multiply_accumulate( frame->arg[i], frame, &i_accumulator,
&d_accumulator, &is_int );
}
struct cons_pointer more = frame->more;
while ( consp( more ) && !exceptionp( result ) ) {
result =
multiply_accumulate( c_car( more ), frame, &i_accumulator,
&d_accumulator, &is_int );
more = c_cdr( more );
}
if ( !exceptionp( result ) ) {
if ( is_int ) {
result = make_integer( i_accumulator );
} else {
result = make_real( d_accumulator );
}
}
return result;
}
/**
* Subtract one number from another.
* @param env the evaluation environment - ignored;
* @param frame the stack frame.
* @return a pointer to an integer or real.
*/
struct cons_pointer
lisp_subtract( struct stack_frame *frame, struct cons_pointer env ) {
struct cons_pointer result = NIL;
struct cons_space_object arg0 = pointer2cell( frame->arg[0] );
struct cons_space_object arg1 = pointer2cell( frame->arg[1] );
if ( integerp( frame->arg[0] ) && integerp( frame->arg[1] ) ) {
result =
make_integer( arg0.payload.integer.value -
arg1.payload.integer.value );
} else if ( realp( frame->arg[0] ) && realp( frame->arg[1] ) ) {
result =
make_real( arg0.payload.real.value - arg1.payload.real.value );
} else if ( integerp( frame->arg[0] ) && realp( frame->arg[1] ) ) {
result =
make_real( numeric_value( frame->arg[0] ) -
arg1.payload.real.value );
} else if ( realp( frame->arg[0] ) && integerp( frame->arg[1] ) ) {
result =
make_real( arg0.payload.real.value -
numeric_value( frame->arg[1] ) );
} else {
/* TODO: throw an exception */
lisp_throw( c_string_to_lisp_string
( "Cannot subtract: not a number" ), frame );
}
// and if not nilp[frame->arg[2]) we also have an error.
return result;
}
/**
* Divide one number by another.
* @param env the evaluation environment - ignored;
* @param frame the stack frame.
* @return a pointer to an integer or real.
*/
struct cons_pointer
lisp_divide( struct stack_frame *frame, struct cons_pointer env ) {
struct cons_pointer result = NIL;
struct cons_space_object arg0 = pointer2cell( frame->arg[0] );
struct cons_space_object arg1 = pointer2cell( frame->arg[1] );
if ( numberp( frame->arg[1] ) && numeric_value( frame->arg[1] ) == 0 ) {
lisp_throw( c_string_to_lisp_string
( "Cannot divide: divisor is zero" ), frame );
} else if ( numberp( frame->arg[0] ) && numberp( frame->arg[1] ) ) {
long int i = ( long int ) numeric_value( frame->arg[0] ) /
numeric_value( frame->arg[1] );
long double r = ( long double ) numeric_value( frame->arg[0] ) /
numeric_value( frame->arg[1] );
if ( fabsl( ( long double ) i - r ) < 0.0000000001 ) {
result = make_integer( i );
} else {
result = make_real( r );
}
} else {
lisp_throw( c_string_to_lisp_string
( "Cannot divide: not a number" ), frame );
}
return result;
}

65
src/repl.c
View file

@ -13,6 +13,7 @@
#include "conspage.h"
#include "consspaceobject.h"
#include "debug.h"
#include "intern.h"
#include "lispops.h"
#include "read.h"
@ -31,11 +32,18 @@
* Dummy up a Lisp read call with its own stack frame.
*/
struct cons_pointer repl_read( struct cons_pointer stream_pointer ) {
struct stack_frame *frame = make_empty_frame( NULL, oblist );
frame->arg[0] = stream_pointer;
struct cons_pointer result = lisp_read( frame, oblist );
free_stack_frame( frame );
struct cons_pointer result = NIL;
debug_print( L"Entered repl_read\n", DEBUG_REPL );
struct cons_pointer frame_pointer = make_stack_frame( NIL, make_cons(stream_pointer, NIL), oblist );
debug_print( L"repl_read: got stack_frame pointer\n", DEBUG_REPL );
debug_dump_object( frame_pointer, DEBUG_REPL );
if ( !nilp( frame_pointer ) ) {
inc_ref( frame_pointer );
result = lisp_read( get_stack_frame( frame_pointer ), frame_pointer, oblist );
dec_ref( frame_pointer );
}
debug_print( L"repl_read: returning\n", DEBUG_REPL );
debug_dump_object( result, DEBUG_REPL );
return result;
}
@ -44,14 +52,13 @@ struct cons_pointer repl_read( struct cons_pointer stream_pointer ) {
* Dummy up a Lisp eval call with its own stack frame.
*/
struct cons_pointer repl_eval( struct cons_pointer input ) {
struct stack_frame *frame = make_empty_frame( NULL, oblist );
debug_print( L"Entered repl_eval\n", DEBUG_REPL );
struct cons_pointer result = NIL;
frame->arg[0] = input;
struct cons_pointer result = lisp_eval( frame, oblist );
result = eval_form( NULL, NIL, input, oblist );
if ( !exceptionp( result ) ) {
free_stack_frame( frame );
}
debug_print( L"repl_eval: returning\n", DEBUG_REPL );
debug_dump_object( result, DEBUG_REPL );
return result;
}
@ -61,12 +68,12 @@ struct cons_pointer repl_eval( struct cons_pointer input ) {
*/
struct cons_pointer repl_print( struct cons_pointer stream_pointer,
struct cons_pointer value ) {
struct stack_frame *frame = make_empty_frame( NULL, oblist );
frame->arg[0] = value;
frame->arg[1] = NIL /* stream_pointer */ ;
struct cons_pointer result = lisp_print( frame, oblist );
free_stack_frame( frame );
debug_print( L"Entered repl_print\n", DEBUG_REPL );
debug_dump_object( value, DEBUG_REPL );
struct cons_pointer result =
print( pointer2cell( stream_pointer ).payload.stream.stream, value );
debug_print( L"repl_print: returning\n", DEBUG_REPL );
debug_dump_object( result, DEBUG_REPL );
return result;
}
@ -81,30 +88,30 @@ struct cons_pointer repl_print( struct cons_pointer stream_pointer,
void
repl( FILE * in_stream, FILE * out_stream, FILE * error_stream,
bool show_prompt ) {
debug_print( L"Entered repl\n", DEBUG_REPL );
struct cons_pointer input_stream = make_read_stream( in_stream );
struct cons_pointer output_stream = make_write_stream( out_stream );
inc_ref( input_stream );
struct cons_pointer output_stream = make_write_stream( out_stream );
inc_ref( output_stream );
while ( !feof( pointer2cell( input_stream ).payload.stream.stream ) ) {
if ( show_prompt ) {
fwprintf( out_stream, L"\n:: " );
}
struct cons_pointer input = repl_read( input_stream );
inc_ref( input );
if ( exceptionp( input ) ) {
/* suppress the end-of-stream exception */
if ( !feof( pointer2cell( input_stream ).payload.stream.stream ) ) {
repl_print( output_stream, input );
}
break;
} else {
struct cons_pointer val = repl_eval( input );
if ( feof( pointer2cell( input_stream ).payload.stream.stream ) ) {
/* suppress the 'end of stream' exception */
if ( !exceptionp( val ) ) {
repl_print( output_stream, val );
}
} else {
repl_print( output_stream, val );
}
repl_print( output_stream, repl_eval( input ) );
}
dec_ref( input );
}
debug_print( L"Leaving repl\n", DEBUG_REPL );
}

206
src/stack.c
View file

@ -1,206 +0,0 @@
/*
* stack.c
*
* The Lisp evaluation stack.
*
* Stack frames could be implemented in cons space; indeed, the stack
* could simply be an assoc list consed onto the front of the environment.
* But such a stack would be costly to search. The design sketched here,
* with stack frames as special objects, SHOULD be substantially more
* efficient, but does imply we need to generalise the idea of cons pages
* with freelists to a more general 'equal sized object pages', so that
* allocating/freeing stack frames can be more efficient.
*
* Stack frames are not yet a first class object; they have no VECP pointer
* in cons space.
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <stdlib.h>
#include "consspaceobject.h"
#include "conspage.h"
#include "lispops.h"
#include "print.h"
#include "stack.h"
/**
* Make an empty stack frame, and return it.
* @param previous the current top-of-stack;
* @param env the environment in which evaluation happens.
* @return the new frame.
*/
struct stack_frame *make_empty_frame( struct stack_frame *previous,
struct cons_pointer env ) {
struct stack_frame *result = malloc( sizeof( struct stack_frame ) );
/*
* TODO: later, pop a frame off a free-list of stack frames
*/
result->previous = previous;
/*
* clearing the frame with memset would probably be slightly quicker, but
* this is clear.
*/
result->more = NIL;
result->function = NIL;
for ( int i = 0; i < args_in_frame; i++ ) {
result->arg[i] = NIL;
}
return result;
}
/**
* Allocate a new stack frame with its previous pointer set to this value,
* its arguments set up from these args, evaluated in this env.
* @param previous the current top-of-stack;
* @args the arguments to load into this frame;
* @param env the environment in which evaluation happens.
* @return the new frame.
*/
struct stack_frame *make_stack_frame( struct stack_frame *previous,
struct cons_pointer args,
struct cons_pointer env,
struct cons_pointer *exception ) {
struct stack_frame *result = make_empty_frame( previous, env );
for ( int i = 0; i < args_in_frame && consp( args ); i++ ) {
/* iterate down the arg list filling in the arg slots in the
* frame. When there are no more slots, if there are still args,
* stash them on more */
struct cons_space_object cell = pointer2cell( args );
/*
* TODO: if we were running on real massively parallel hardware,
* each arg except the first should be handed off to another
* processor to be evaled in parallel; but see notes here:
* https://github.com/simon-brooke/post-scarcity/wiki/parallelism
*/
struct stack_frame *arg_frame = make_empty_frame( result, env );
arg_frame->arg[0] = cell.payload.cons.car;
inc_ref( arg_frame->arg[0] );
struct cons_pointer val = lisp_eval( arg_frame, env );
if ( exceptionp( val ) ) {
exception = &val;
break;
} else {
result->arg[i] = val;
}
inc_ref( val );
free_stack_frame( arg_frame );
args = cell.payload.cons.cdr;
}
if ( consp( args ) ) {
/* if we still have args, eval them and stick the values on `more` */
struct cons_pointer more = eval_forms( previous, args, env );
result->more = more;
inc_ref( more );
}
dump_frame( stderr, result );
return result;
}
/**
* A 'special' frame is exactly like a normal stack frame except that the
* arguments are unevaluated.
* @param previous the previous stack frame;
* @param args a list of the arguments to be stored in this stack frame;
* @param env the execution environment;
* @return a new special frame.
*/
struct stack_frame *make_special_frame( struct stack_frame *previous,
struct cons_pointer args,
struct cons_pointer env ) {
struct stack_frame *result = make_empty_frame( previous, env );
for ( int i = 0; i < args_in_frame && !nilp( args ); i++ ) {
/* iterate down the arg list filling in the arg slots in the
* frame. When there are no more slots, if there are still args,
* stash them on more */
struct cons_space_object cell = pointer2cell( args );
result->arg[i] = cell.payload.cons.car;
inc_ref( result->arg[i] );
args = cell.payload.cons.cdr;
}
if ( consp( args ) ) {
result->more = args;
inc_ref( args );
}
return result;
}
/**
* Free this stack frame.
*/
void free_stack_frame( struct stack_frame *frame ) {
/*
* TODO: later, push it back on the stack-frame freelist
*/
for ( int i = 0; i < args_in_frame; i++ ) {
dec_ref( frame->arg[i] );
}
if ( !nilp( frame->more ) ) {
dec_ref( frame->more );
}
free( frame );
}
/**
* Dump a stackframe to this stream for debugging
* @param output the stream
* @param frame the frame
*/
void dump_frame( FILE * output, struct stack_frame *frame ) {
fputws( L"Dumping stack frame\n", output );
for ( int arg = 0; arg < args_in_frame; arg++ ) {
struct cons_space_object cell = pointer2cell( frame->arg[arg] );
fwprintf( output, L"Arg %d:\t%c%c%c%c\tcount: %10u\tvalue: ", arg,
cell.tag.bytes[0],
cell.tag.bytes[1], cell.tag.bytes[2], cell.tag.bytes[3],
cell.count );
print( output, frame->arg[arg] );
fputws( L"\n", output );
}
fputws( L"More: \t", output );
print( output, frame->more );
fputws( L"\n", output );
}
/**
* Fetch a pointer to the value of the local variable at this index.
*/
struct cons_pointer fetch_arg( struct stack_frame *frame, unsigned int index ) {
struct cons_pointer result = NIL;
if ( index < args_in_frame ) {
result = frame->arg[index];
} else {
struct cons_pointer p = frame->more;
for ( int i = args_in_frame; i < index; i++ ) {
p = pointer2cell( p ).payload.cons.cdr;
}
result = pointer2cell( p ).payload.cons.car;
}
return result;
}

2
src/version.h
View file

@ -8,4 +8,4 @@
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#define VERSION "0.0.3"
#define VERSION "0.0.4"

54
unit-tests/add.sh
View file

@ -23,3 +23,57 @@ else
exit 1
fi
expected='1/4'
actual=`echo "(+ 3/14 1/28)" | target/psse 2> /dev/null | head -2 | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
exit 1
fi
# (+ integer ratio) should be ratio
expected='25/4'
actual=`echo "(+ 6 1/4)" | target/psse 2> /dev/null | head -2 | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
exit 1
fi
# (+ ratio integer) should be ratio
expected='25/4'
actual=`echo "(+ 1/4 6)" | target/psse 2> /dev/null | head -2 | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
exit 1
fi
# (+ real ratio) should be real
# for this test, trailing zeros can be ignored
expected='6.25'
actual=`echo "(+ 6.000000001 1/4)" |\
target/psse 2> /dev/null |\
sed 's/0*$//' |\
head -2 |\
tail -1`
outcome=`echo "sqrt((${expected} - ${actual})^2) < 0.0000001" | bc`
if [ "${outcome}" = "1" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
exit 1
fi

13
unit-tests/nlambda.sh Normal file
View file

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

12
unit-tests/ratio-addition.sh Normal file
View file

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

36
unit-tests/reverse.sh Normal file
View file

@ -0,0 +1,36 @@
#!/bin/bash
expected='"god yzal eht revo depmuj xof nworb kciuq ehT"'
actual=`echo '(reverse "The quick brown fox jumped over the lazy dog")' | target/psse 2> /dev/null | head -2 | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
exit 1
fi
expected='(1024 512 256 128 64 32 16 8 4 2)'
actual=`echo "(reverse '(2 4 8 16 32 64 128 256 512 1024))" | target/psse 2> /dev/null | head -2 | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
exit 1
fi
expected='esrever'
actual=`echo "(reverse 'reverse)" | target/psse 2> /dev/null | head -2 | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
exit 0
else
echo "Fail: expected '${expected}', got '${actual}'"
exit 1
fi

10
unit-tests/string-allocation.sh
View file

@ -1,17 +1,15 @@
#!/bin/bash
log=log.$$
value='"Fred"'
expected="String cell: character 'F' (70)"
echo ${value} | target/psse -d > ${log} 2>/dev/null
grep "${expected}" ${log} > /dev/null
expected="String cell: character 'F'"
# set! protects "Fred" from the garbage collector.
actual=`echo "(set! x ${value})" | target/psse -d 2>&1 | grep "$expected" | sed 's/ *\(.*\) next.*$/\1/'`
if [ $? -eq 0 ]
then
echo "OK"
rm ${log}
exit 0
else
echo "Expected '${expected}', not found in ${log}"
echo "Fail: expected '${expected}', got '${actual}'"
exit 1
fi

BIN
utils_src/debugflags/debugflags Executable file
View file

Binary file not shown.

43
utils_src/debugflags/debugflags.c Normal file
View file

@ -0,0 +1,43 @@
#include <inttypes.h>
#include <stdint.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#define DEBUG_ALLOC 1
#define DEBUG_STACK 2
#define DEBUG_ARITH 4
#define DEBUG_EVAL 8
#define DEBUG_LAMBDA 16
#define DEBUG_BOOTSTRAP 32
#define DEBUG_IO 64
#define DEBUG_REPL 128
int check_level( int v, int level, char * name) {
int result = 0;
if (v & level) {
printf("\t\t%s (%d) matches;\n", name, level);
result = 1;
}
return result;
}
int main( int argc, char *argv[] ) {
for (int i = 1; i < argc; i++) {
int v = atoi(argv[i]);
printf("Level %d:\n", v);
int matches = check_level(v, DEBUG_ALLOC, "DEBUG_ALLOC") +
check_level(v, DEBUG_STACK, "DEBUG_STACK") +
check_level(v, DEBUG_ARITH, "DEBUG_ARITH") +
check_level(v, DEBUG_EVAL, "DEBUG_EVAL") +
check_level(v, DEBUG_LAMBDA, "DEBUG_LAMBDA") +
check_level(v, DEBUG_BOOTSTRAP, "DEBUG_BOOTSTRAP") +
check_level(v, DEBUG_IO, "DEBUG_IO") +
check_level(v, DEBUG_REPL, "DEBUG_REPL");
printf("\t%d matches\n", matches);
}
}

17
utils_src/readprintwc/readprintwc.c Normal file
View file

@ -0,0 +1,17 @@
#include <stdio.h>
#include <stdlib.h>
#include <wchar.h>
#include <wctype.h>
int main( int argc, char *argv[] ) {
fwide( stdin, 1 );
fwide( stdout, 1 );
for (wchar_t c = fgetwc( stdin ); !feof( stdin); c = fgetwc( stdin )) {
if (c != '\n') {
fwprintf( stdout, L"Read character %d, %C\t", (int)c, c);
fputwc( c, stdout);
fputws(L"\n", stdout);
}
}
}

26
utils_src/tagvalcalc/tagvalcalc.c Normal file
View file

@ -0,0 +1,26 @@
#include <stdint.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#define TAGLENGTH 4
struct dummy {
union {
char bytes[TAGLENGTH]; /* the tag (type) of this cell,
* considered as bytes */
uint32_t value; /* the tag considered as a number */
} tag;
};
int main( int argc, char *argv[] ) {
struct dummy *b = malloc( sizeof( struct dummy));
struct dummy buffer = *b;
for (int i = 1; i < argc; i++) {
strncpy( &buffer.tag.bytes[0], argv[i], TAGLENGTH );
printf( "%4.4s:\t%d\n", argv[i], buffer.tag.value);
}
}

BIN
utils_src/tagvalcalc/tvc Executable file
View file

Binary file not shown.