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

Reorganised source files to make navigation easier

Browse source 
All tests still pass (slightly to my surprise)
This commit is contained in:
Simon Brooke 2018-12-24 19:27:04 +00:00
parent f6ff403249
commit a5e1d3ccd8
24 changed files with 73 additions and 72 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -0,0 +1,120 @@
/*
* equal.c
*
* Checks for shallow and deep equality
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <math.h>
#include <stdbool.h>
#include "conspage.h"
#include "consspaceobject.h"
#include "integer.h"
/**
* Shallow, and thus cheap, equality: true if these two objects are
* the same object, else false.
*/
bool eq( struct cons_pointer a, struct cons_pointer b ) {
return ( ( a.page == b.page ) && ( a.offset == b.offset ) );
}
/**
* True if the objects at these two cons pointers have the same tag, else false.
* @param a a pointer to a cons-space object;
* @param b another pointer to a cons-space object.
* @return true if the objects at these two cons pointers have the same tag,
* else false.
*/
bool same_type( struct cons_pointer a, struct cons_pointer b ) {
struct cons_space_object *cell_a = &pointer2cell( a );
struct cons_space_object *cell_b = &pointer2cell( b );
return cell_a->tag.value == cell_b->tag.value;
}
/**
* Some strings will be null terminated and some will be NIL terminated... ooops!
* @param string the string to test
* @return true if it's the end of a string.
*/
bool end_of_string( struct cons_pointer string ) {
return nilp( string ) ||
pointer2cell( string ).payload.string.character == '\0';
}
/**
* Deep, and thus expensive, equality: true if these two objects have
* identical structure, else false.
*/
bool equal( struct cons_pointer a, struct cons_pointer b ) {
bool result = eq( a, b );
if ( !result && same_type( a, b ) ) {
struct cons_space_object *cell_a = &pointer2cell( a );
struct cons_space_object *cell_b = &pointer2cell( b );
switch ( cell_a->tag.value ) {
case CONSTV:
case LAMBDATV:
case NLAMBDATV:
result =
equal( cell_a->payload.cons.car, cell_b->payload.cons.car )
&& equal( cell_a->payload.cons.cdr,
cell_b->payload.cons.cdr );
break;
case STRINGTV:
case SYMBOLTV:
/*
* slightly complex because a string may or may not have a '\0'
* cell at the end, but I'll ignore that for now. I think in
* practice only the empty string will.
*/
result =
cell_a->payload.string.character ==
cell_b->payload.string.character
&& ( 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 ) ) );
break;
case INTEGERTV:
result =
cell_a->payload.integer.value ==
cell_b->payload.integer.value;
break;
case REALTV:
{
double num_a = numeric_value( a );
double num_b = numeric_value( b );
double max =
fabs( num_a ) >
fabs( num_b ) ? fabs( num_a ) : fabs( num_b );
/*
* not more different than one part in a million - close enough
*/
result = fabs( num_a - num_b ) < ( max / 1000000.0 );
}
break;
default:
result = false;
break;
}
/*
* there's only supposed ever to be one T and one NIL cell, so each
* should be caught by eq; equality of vector-space objects is a whole
* other ball game so we won't deal with it now (and indeed may never).
* I'm not certain what equality means for read and write streams, so
* I'll ignore them, too, for now.
*/
}
return result;
}

30
src/ops/equal.h Normal file
View file

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

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

@ -0,0 +1,144 @@
/*
* intern.c
*
* For now this implements an oblist and shallow binding; local environments can
* be consed onto the front of the oblist. Later, this won't do; bindings will happen
* in namespaces, which will probably be implemented as hash tables.
*
* Doctrine is that cons cells are immutable, and life is a lot more simple if they are;
* so when a symbol is rebound in the master oblist, what in fact we do is construct
* a new oblist without the previous binding but with the new binding. Anything which,
* prior to this action, held a pointer to the old oblist (as all current threads'
* environments must do) continues to hold a pointer to the old oblist, and consequently
* doesn't see the change. This is probably good but does mean you cannot use bindings
* on the oblist to signal between threads.
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <stdbool.h>
#include "conspage.h"
#include "consspaceobject.h"
#include "equal.h"
#include "lispops.h"
#include "print.h"
/**
* The object list. What is added to this during system setup is 'global', that is,
* visible to all sessions/threads. What is added during a session/thread is local to
* that session/thread (because shallow binding). There must be some way for a user to
* make the contents of their own environment persistent between threads but I don't
* know what it is yet. At some stage there must be a way to rebind deep values so
* they're visible to all users/threads, but again I don't yet have any idea how
* that will work.
*/
struct cons_pointer oblist = NIL;
/**
* Implementation of interned? in C. The final implementation if interned? will
* deal with stores which can be association lists or hashtables or hybrids of
* the two, but that will almost certainly be implemented in lisp.
*
* If this key is lexically identical to a key in this store, return the key
* from the store (so that later when we want to retrieve a value, an eq test
* will work); otherwise return NIL.
*/
struct cons_pointer
internedp( struct cons_pointer key, struct cons_pointer store ) {
struct cons_pointer result = NIL;
if ( symbolp( key ) ) {
for ( struct cons_pointer next = store;
nilp( result ) && consp( next );
next = pointer2cell( next ).payload.cons.cdr ) {
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 );
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 );
}
return result;
}
/**
* Implementation of assoc in C. Like interned?, the final implementation will
* deal with stores which can be association lists or hashtables or hybrids of
* the two, but that will almost certainly be implemented in lisp.
*
* If this key is lexically identical to a key in this store, return the value
* of that key from the store; otherwise return NIL.
*/
struct cons_pointer c_assoc( struct cons_pointer key,
struct cons_pointer store ) {
struct cons_pointer result = NIL;
for ( struct cons_pointer next = store;
consp( next ); next = pointer2cell( next ).payload.cons.cdr ) {
struct cons_space_object entry =
pointer2cell( pointer2cell( next ).payload.cons.car );
if ( equal( key, entry.payload.cons.car ) ) {
result = entry.payload.cons.cdr;
break;
}
}
return result;
}
/**
* Return a new key/value store containing all the key/value pairs in this store
* with this key/value pair added to the front.
*/
struct cons_pointer
bind( struct cons_pointer key, struct cons_pointer value,
struct cons_pointer store ) {
return make_cons( make_cons( key, value ), store );
}
/**
* Binds this key to this value in the global oblist, but doesn't affect the
* current environment. May not be useful except in bootstrapping (and even
* there it may not be especially useful).
*/
struct cons_pointer
deep_bind( struct cons_pointer key, struct cons_pointer value ) {
oblist = bind( key, value, oblist );
return oblist;
}
/**
* Ensure that a canonical copy of this key is bound in this environment, and
* return that canonical copy. If there is currently no such binding, create one
* with the value NIL.
*/
struct cons_pointer
intern( struct cons_pointer key, struct cons_pointer environment ) {
struct cons_pointer result = environment;
struct cons_pointer canonical = internedp( key, environment );
if ( nilp( canonical ) ) {
/*
* not currently bound
*/
result = bind( key, NIL, environment );
}
return result;
}

64
src/ops/intern.h Normal file
View file

@ -0,0 +1,64 @@
/**
* intern.h
*
* For now this implements an oblist and shallow binding; local environments can
* be consed onto the front of the oblist. Later, this won't do; bindings will happen
* in namespaces, which will probably be implemented as hash tables.
*
* Doctrine is that cons cells are immutable, and life is a lot more simple if they are;
* so when a symbol is rebound in the master oblist, what in fact we do is construct
* a new oblist without the previous binding but with the new binding. Anything which,
* prior to this action, held a pointer to the old oblist (as all current threads'
* environments must do) continues to hold a pointer to the old oblist, and consequently
* doesn't see the change. This is probably good but does mean you cannot use bindings
* on the oblist to signal between threads.
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#ifndef __intern_h
#define __intern_h
extern struct cons_pointer oblist;
/**
* return the value associated with this key in this store. In the current
* implementation a store is just an assoc list, but in future it might be a
* namespace, a regularity or a homogeneity.
*/
struct cons_pointer c_assoc( struct cons_pointer key,
struct cons_pointer store );
/**
* Return true if this key is present as a key in this enviroment, defaulting to
* the oblist if no environment is passed.
*/
struct cons_pointer internedp( struct cons_pointer key,
struct cons_pointer environment );
/**
* Return a new key/value store containing all the key/value pairs in this store
* with this key/value pair added to the front.
*/
struct cons_pointer bind( struct cons_pointer key,
struct cons_pointer value,
struct cons_pointer store );
/**
* Binds this key to this value in the global oblist, but doesn't affect the
* current environment. May not be useful except in bootstrapping (and even
* there it may not be especially useful).
*/
struct cons_pointer deep_bind( struct cons_pointer key,
struct cons_pointer value );
/**
* Ensure that a canonical copy of this key is bound in this environment, and
* return that canonical copy. If there is currently no such binding, create one
* with the value NIL.
*/
struct cons_pointer intern( struct cons_pointer key,
struct cons_pointer environment );
#endif

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

@ -0,0 +1,783 @@
/*
* lispops.c
*
* List processing operations.
*
* The general idea here is that a list processing operation is a
* function which takes two arguments, both cons_pointers:
*
* 1. args, the argument list to this function;
* 2. env, the environment in which this function should be evaluated;
*
* and returns a cons_pointer, the result.
*
* They must all have the same signature so that I can call them as
* function pointers.
*
* (c) 2017 Simon Brooke <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 "consspaceobject.h"
#include "conspage.h"
#include "equal.h"
#include "integer.h"
#include "intern.h"
#include "lispops.h"
#include "print.h"
#include "read.h"
#include "stack.h"
/*
* also to create in this section:
* struct cons_pointer lisp_let( struct cons_pointer args, struct cons_pointer env,
struct stack_frame* frame);
* struct cons_pointer lisp_mapcar( struct cons_pointer args, struct cons_pointer env,
struct stack_frame* frame);
*
* and others I haven't thought of yet.
*/
/**
* Implementation of car in C. If arg is not a cons, does not error but returns nil.
*/
struct cons_pointer c_car( struct cons_pointer arg ) {
struct cons_pointer result = NIL;
if ( consp( arg ) ) {
result = pointer2cell( arg ).payload.cons.car;
}
return result;
}
/**
* Implementation of cdr in C. If arg is not a cons, does not error but returns nil.
*/
struct cons_pointer c_cdr( struct cons_pointer arg ) {
struct cons_pointer result = NIL;
if ( consp( arg ) || stringp( arg ) || symbolp( arg ) ) {
result = pointer2cell( arg ).payload.cons.cdr;
}
return result;
}
/**
* Useful building block; evaluate this single form in the context of this
* parent stack frame and this environment.
* @param parent the parent stack frame.
* @param form the form to be evaluated.
* @param env the evaluation environment.
* @return the result of evaluating the form.
*/
struct cons_pointer eval_form( struct stack_frame *parent,
struct cons_pointer form,
struct cons_pointer env ) {
fputws( L"eval_form: ", stderr );
print( stderr, form );
fputws( L"\n", stderr );
struct cons_pointer result = NIL;
struct stack_frame *next = make_empty_frame( parent, env );
set_reg( next, 0, form );
result = lisp_eval( 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 );
}
return result;
}
/**
* eval all the forms in this `list` in the context of this stack `frame`
* and this `env`, and return a list of their values. If the arg passed as
* `list` is not in fact a list, return nil.
*/
struct cons_pointer eval_forms( struct stack_frame *frame,
struct cons_pointer list,
struct cons_pointer env ) {
return consp( list ) ?
make_cons( eval_form( frame, c_car( list ), env ),
eval_forms( frame, c_cdr( list ), env ) ) : NIL;
}
/**
* Return the object list (root namespace).
*
* (oblist)
*/
struct cons_pointer
lisp_oblist( struct stack_frame *frame, struct cons_pointer env ) {
return oblist;
}
/**
* used to construct the body for `lambda` and `nlambda` expressions.
*/
struct cons_pointer compose_body( struct stack_frame *frame ) {
struct cons_pointer body =
!nilp( frame->arg[args_in_frame - 1] ) ? frame->more : NIL;
for ( int i = args_in_frame - 1; i > 0; i-- ) {
if ( !nilp( body ) ) {
body = make_cons( frame->arg[i], body );
} else if ( !nilp( frame->arg[i] ) ) {
body = make_cons( frame->arg[i], body );
}
}
fputws( L"compose_body returning ", stderr );
print( stderr, body );
fputws( L"\n", stderr );
return body;
}
/**
* Construct an interpretable function.
*
* @param frame the stack frame in which the expression is to be interpreted;
* @param env the environment in which it is to be intepreted.
*/
struct cons_pointer
lisp_lambda( struct stack_frame *frame, struct cons_pointer env ) {
return make_lambda( frame->arg[0], compose_body( frame ) );
}
/**
* Construct an interpretable special form.
*
* @param frame the stack frame in which the expression is to be interpreted;
* @param env the environment in which it is to be intepreted.
*/
struct cons_pointer
lisp_nlambda( struct stack_frame *frame, struct cons_pointer 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 );
}
/**
* Evaluate a lambda or nlambda expression.
*/
struct cons_pointer
eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
struct cons_pointer env ) {
struct cons_pointer result = NIL;
fwprintf( stderr, L"eval_lambda called\n" );
struct cons_pointer new_env = env;
struct cons_pointer names = cell.payload.lambda.args;
struct cons_pointer body = cell.payload.lambda.body;
if ( consp( names ) ) {
/* if `names` is a list, bind successive items from that list
* to values of arguments */
for ( int i = 0; i < args_in_frame && consp( names ); i++ ) {
struct cons_pointer name = c_car( names );
struct cons_pointer val = frame->arg[i];
new_env = bind( name, val, new_env );
log_binding( name, val );
names = c_cdr( names );
}
} 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. */
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 );
if ( nilp( val ) && nilp( vals ) ) { /* nothing */
} else {
vals = make_cons( val, vals );
}
}
new_env = bind( names, vals, new_env );
}
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 );
}
return result;
}
/**
* Internal guts of apply.
* @param frame the stack frame, expected to have only one argument, a list
* comprising something that evaluates to a function and its arguments.
* @param env The evaluation environment.
* @return the result of evaluating the function with its arguments.
*/
struct cons_pointer
c_apply( struct stack_frame *frame, struct cons_pointer env ) {
struct cons_pointer result = NIL;
struct stack_frame *fn_frame = make_empty_frame( frame, env );
set_reg( fn_frame, 0, c_car( frame->arg[0] ) );
struct cons_pointer fn_pointer = lisp_eval( fn_frame, 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( fn_frame );
}
struct cons_space_object fn_cell = pointer2cell( fn_pointer );
struct cons_pointer args = c_cdr( frame->arg[0] );
switch ( fn_cell.tag.value ) {
case EXCEPTIONTV:
/* just pass exceptions straight back */
result = fn_pointer;
break;
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;
} else {
free_stack_frame( next );
}
}
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;
} else {
free_stack_frame( next );
}
}
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 );
}
}
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 );
}
}
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] );
struct cons_pointer message =
c_string_to_lisp_string( buffer );
free( buffer );
result = lisp_throw( message, frame );
}
}
return result;
}
/**
* Get the Lisp type of the single argument.
* @param pointer a pointer to the object whose type is requested.
* @return As a Lisp string, the tag of the object which is at that pointer.
*/
struct cons_pointer c_type( struct cons_pointer pointer ) {
char *buffer = malloc( TAGLENGTH + 1 );
memset( buffer, 0, TAGLENGTH + 1 );
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 );
return result;
}
/**
* (eval s_expr)
*
* function.
* If s_expr is a number, NIL, or T, returns s_expr.
* If s_expr is an unprotected string, returns the value that s_expr is bound
* to in the evaluation environment (env).
* If s_expr is a list, expects the car to be something that evaluates to a
* function or special form.
* If a function, evaluates all the other top level elements in s_expr and
* passes them in a stack frame as arguments to the function.
* 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 ) {
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 );
}
break;
case SYMBOLTV:
{
struct cons_pointer canonical =
internedp( frame->arg[0], env );
if ( nilp( canonical ) ) {
struct cons_pointer message =
make_cons( c_string_to_lisp_string
( "Attempt to take value of unbound symbol." ),
frame->arg[0] );
result = lisp_throw( message, frame );
} else {
result = c_assoc( canonical, env );
inc_ref( result );
}
}
break;
/*
* TODO:
* the Clojure practice of having a map serve in the function place of
* an s-expression is a good one and I should adopt it; also if the
* object is a consp it could be interpretable source code but in the
* long run I don't want an interpreter, and if I can get away without
* so much the better.
*/
default:
result = frame->arg[0];
break;
}
fputws( L"Eval returning ", stderr );
print( stderr, result );
fputws( L"\n", stderr );
return result;
}
/**
* (apply fn args)
*
* function. Apply the function which is the result of evaluating the
* first argoment to the list of arguments which is the result of evaluating
* the second argument
*/
struct cons_pointer
lisp_apply( struct stack_frame *frame, struct cons_pointer env ) {
fputws( L"Apply: ", stderr );
dump_frame( stderr, frame );
set_reg( frame, 0, make_cons( frame->arg[0], frame->arg[1] ) );
set_reg( frame, 1, NIL );
struct cons_pointer result = c_apply( frame, env );
fputws( L"Apply returning ", stderr );
print( stderr, result );
fputws( L"\n", stderr );
return result;
}
/**
* (quote a)
*
* Special form
* Returns its argument (strictly first argument - only one is expected but
* this isn't at this stage checked) unevaluated.
*/
struct cons_pointer
lisp_quote( struct stack_frame *frame, struct cons_pointer env ) {
return frame->arg[0];
}
/**
* (set name value)
* (set name value namespace)
*
* Function.
* `namespace` defaults to the oblist.
* Binds the value of `name` in the `namespace` to value of `value`, altering
* 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 ) {
struct cons_pointer result = NIL;
struct cons_pointer namespace =
nilp( frame->arg[2] ) ? oblist : frame->arg[2];
if ( symbolp( frame->arg[0] ) ) {
deep_bind( frame->arg[0], frame->arg[1] );
result = frame->arg[1];
} else {
result =
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 );
}
return result;
}
/**
* (set! symbol value)
* (set! symbol value namespace)
*
* Special form.
* `namespace` defaults to the oblist.
* Binds `symbol` in the `namespace` to value of `value`, altering
* 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 ) {
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 );
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 );
}
return result;
}
/**
* (cons a b)
*
* Function.
* Returns a cell constructed from a and b. If a is of type string but its
* cdr is nill, and b is of type string, then returns a new string cell;
* otherwise returns a new cons cell.
*/
struct cons_pointer
lisp_cons( struct stack_frame *frame, struct cons_pointer env ) {
struct cons_pointer car = frame->arg[0];
struct cons_pointer cdr = frame->arg[1];
struct cons_pointer result;
if ( nilp( car ) && nilp( cdr ) ) {
return NIL;
} else if ( stringp( car ) && stringp( cdr ) &&
nilp( pointer2cell( car ).payload.string.cdr ) ) {
result =
make_string( pointer2cell( car ).payload.string.character, cdr );
} else {
result = make_cons( car, cdr );
}
return result;
}
/**
* (car s_expr)
* Returns the first item (head) of a sequence. Valid for cons cells,
* strings, and TODO read streams and other things which can be considered as sequences.
*/
struct cons_pointer
lisp_car( struct stack_frame *frame, struct cons_pointer env ) {
struct cons_pointer result = NIL;
if ( consp( frame->arg[0] ) ) {
struct cons_space_object cell = pointer2cell( frame->arg[0] );
result = cell.payload.cons.car;
} else if ( stringp( frame->arg[0] ) ) {
struct cons_space_object cell = pointer2cell( frame->arg[0] );
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 );
}
return result;
}
/**
* (cdr s_expr)
* Returns the remainder of a sequence when the head is removed. Valid for cons cells,
* strings, and TODO read streams and other things which can be considered as sequences.
*/
struct cons_pointer
lisp_cdr( struct stack_frame *frame, struct cons_pointer env ) {
struct cons_pointer result = NIL;
if ( consp( frame->arg[0] ) ) {
struct cons_space_object cell = pointer2cell( frame->arg[0] );
result = cell.payload.cons.cdr;
} else if ( stringp( frame->arg[0] ) ) {
struct cons_space_object cell = pointer2cell( frame->arg[0] );
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 );
}
return result;
}
/**
* (assoc key store)
* 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 ) {
return c_assoc( frame->arg[0], frame->arg[1] );
}
/**
* (eq a b)
* 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 env ) {
return eq( frame->arg[0], frame->arg[1] ) ? TRUE : NIL;
}
/**
* (eq a b)
* 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 ) {
return equal( frame->arg[0], frame->arg[1] ) ? TRUE : NIL;
}
/**
* (read)
* (read read-stream)
* Read one complete lisp form and return it. If read-stream is specified and
* is a read stream, then read from that stream, else stdin.
*/
struct cons_pointer
lisp_read( struct stack_frame *frame, struct cons_pointer env ) {
FILE *input = stdin;
if ( readp( frame->arg[0] ) ) {
input = pointer2cell( frame->arg[0] ).payload.stream.stream;
}
return read( frame, input );
}
/**
* (print expr)
* (print expr write-stream)
* Print one complete lisp form and return NIL. If write-stream is specified and
* is a write stream, then print to that stream, else stdout.
*/
struct cons_pointer
lisp_print( struct stack_frame *frame, struct cons_pointer env ) {
struct cons_pointer result = NIL;
FILE *output = stdout;
if ( writep( frame->arg[1] ) ) {
output = pointer2cell( frame->arg[1] ).payload.stream.stream;
}
result = print( output, frame->arg[0] );
fputws( L"Print returning ", stderr );
print( stderr, result );
fputws( L"\n", stderr );
return result;
}
/**
* Function: Get the Lisp type of the single argument.
* @param frame My stack frame.
* @param env My environment (ignored).
* @return As a Lisp string, the tag of the object which is the argument.
*/
struct cons_pointer
lisp_type( struct stack_frame *frame, struct cons_pointer env ) {
return c_type( frame->arg[0] );
}
/**
* (progn forms...)
*
* Special form; evaluate the forms which are listed in my arguments
* sequentially and return the value of the last. This function is called 'do'
* in some dialects of Lisp.
*
* @param frame My stack frame.
* @param env My environment (ignored).
* @return the value of the last form on the sequence which is my single
* argument.
*/
struct cons_pointer
lisp_progn( struct stack_frame *frame, struct cons_pointer 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 );
}
while ( consp( remaining ) ) {
result = eval_form( frame, c_car( remaining ), env );
remaining = c_cdr( remaining );
}
return result;
}
/**
* Special form: conditional. Each arg is expected to be a list; if the first
* item in such a list evaluates to non-NIL, the remaining items in that list
* are evaluated in turn and the value of the last returned. If no arg (clause)
* has a first element which evaluates to non NIL, then NIL is returned.
* @param frame My stack frame.
* @param env My environment (ignored).
* @return the value of the last form of the first successful clause.
*/
struct cons_pointer
lisp_cond( struct stack_frame *frame, struct cons_pointer 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 );
if ( consp( clause_pointer ) ) {
struct cons_space_object cell = pointer2cell( clause_pointer );
result = eval_form( frame, c_car( clause_pointer ), env );
if ( !nilp( result ) ) {
struct cons_pointer vals =
eval_forms( frame, c_cdr( clause_pointer ), env );
while ( consp( vals ) ) {
result = c_car( vals );
vals = c_cdr( vals );
}
done = true;
}
} else if ( nilp( clause_pointer ) ) {
done = true;
} else {
result = lisp_throw( c_string_to_lisp_string
( "Arguments to `cond` must be lists" ),
frame );
}
}
/* TODO: if there are more than 8 clauses we need to continue into the
* remainder */
return result;
}
/**
* TODO: make this do something sensible somehow.
* This requires that a frame be a heap-space object with a cons-space
* 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 );
struct cons_pointer result = NIL;
struct cons_space_object cell = pointer2cell( message );
if ( cell.tag.value == EXCEPTIONTV ) {
result = message;
} else {
result = make_exception( message, frame );
}
return result;
}

163
src/ops/lispops.h Normal file
View file

@ -0,0 +1,163 @@
/**
* lispops.h
*
* List processing operations.
*
* The general idea here is that a list processing operation is a
* function which takes two arguments, both cons_pointers:
*
* 1. args, the argument list to this function;
* 2. env, the environment in which this function should be evaluated;
*
* and returns a cons_pointer, the result.
*
* They must all have the same signature so that I can call them as
* function pointers.
*
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
/*
* utilities
*/
/**
* Get the Lisp type of the single argument.
* @param pointer a pointer to the object whose type is requested.
* @return As a Lisp string, the tag of the object which is at that pointer.
*/
struct cons_pointer c_type( struct cons_pointer pointer );
/**
* Implementation of car in C. If arg is not a cons, does not error but returns nil.
*/
struct cons_pointer c_car( struct cons_pointer arg );
/**
* Implementation of cdr in C. If arg is not a cons, does not error but returns nil.
*/
struct cons_pointer c_cdr( struct cons_pointer arg );
/**
* Useful building block; evaluate this single form in the context of this
* parent stack frame and this environment.
* @param parent the parent stack frame.
* @param form the form to be evaluated.
* @param env the evaluation environment.
* @return the result of evaluating the form.
*/
struct cons_pointer eval_form( struct stack_frame *parent,
struct cons_pointer form,
struct cons_pointer env );
/**
* eval all the forms in this `list` in the context of this stack `frame`
* and this `env`, and return a list of their values. If the arg passed as
* `list` is not in fact a list, return nil.
*/
struct cons_pointer eval_forms( struct stack_frame *frame,
struct cons_pointer list,
struct cons_pointer env );
/*
* special forms
*/
struct cons_pointer lisp_eval( struct stack_frame *frame,
struct cons_pointer env );
struct cons_pointer lisp_apply( struct stack_frame *frame,
struct cons_pointer env );
struct cons_pointer
lisp_oblist( struct stack_frame *frame, struct cons_pointer env );
struct cons_pointer
lisp_set( struct stack_frame *frame, struct cons_pointer env );
struct cons_pointer
lisp_set_shriek( struct stack_frame *frame, struct cons_pointer env );
/**
* Construct an interpretable function.
*
* @param frame the stack frame in which the expression is to be interpreted;
* @param lexpr the lambda expression to be interpreted;
* @param env the environment in which it is to be intepreted.
*/
struct cons_pointer lisp_lambda( struct stack_frame *frame,
struct cons_pointer env );
/**
* Construct an interpretable special form.
*
* @param frame the stack frame in which the expression is to be interpreted;
* @param env the environment in which it is to be intepreted.
*/
struct cons_pointer
lisp_nlambda( struct stack_frame *frame, struct cons_pointer env );
struct cons_pointer lisp_quote( struct stack_frame *frame,
struct cons_pointer env );
/*
* functions
*/
struct cons_pointer lisp_cons( struct stack_frame *frame,
struct cons_pointer env );
struct cons_pointer lisp_car( struct stack_frame *frame,
struct cons_pointer env );
struct cons_pointer lisp_cdr( struct stack_frame *frame,
struct cons_pointer env );
struct cons_pointer lisp_assoc( struct stack_frame *frame,
struct cons_pointer env );
struct cons_pointer lisp_eq( struct stack_frame *frame,
struct cons_pointer env );
struct cons_pointer lisp_equal( struct stack_frame *frame,
struct cons_pointer env );
struct cons_pointer lisp_read( struct stack_frame *frame,
struct cons_pointer env );
struct cons_pointer lisp_print( struct stack_frame *frame,
struct cons_pointer env );
/**
* Function: Get the Lisp type of the single argument.
* @param frame My stack frame.
* @param env My environment (ignored).
* @return As a Lisp string, the tag of the object which is the argument.
*/
struct cons_pointer
lisp_type( struct stack_frame *frame, struct cons_pointer env );
/**
* Function; evaluate the forms which are listed in my single argument
* sequentially and return the value of the last. This function is called 'do'
* in some dialects of Lisp.
*
* @param frame My stack frame.
* @param env My environment (ignored).
* @return the value of the last form on the sequence which is my single
* argument.
*/
struct cons_pointer
lisp_progn( struct stack_frame *frame, struct cons_pointer env );
/**
* Special form: conditional. Each arg is expected to be a list; if the first
* item in such a list evaluates to non-NIL, the remaining items in that list
* are evaluated in turn and the value of the last returned. If no arg (clause)
* has a first element which evaluates to non NIL, then NIL is returned.
* @param frame My stack frame.
* @param env My environment (ignored).
* @return the value of the last form of the first successful clause.
*/
struct cons_pointer
lisp_cond( struct stack_frame *frame, struct cons_pointer env );
/*
* neither, at this stage, really
*/
struct cons_pointer lisp_throw( struct cons_pointer message,
struct stack_frame *frame );

206
src/ops/print.c Normal file
View file

@ -0,0 +1,206 @@
/*
* print.c
*
* First pass at a printer, for bootstrapping.
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <ctype.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
/*
* wide characters
*/
#include <wchar.h>
#include <wctype.h>
#include "conspage.h"
#include "consspaceobject.h"
#include "integer.h"
#include "print.h"
/**
* Whether or not we colorise output.
* TODO: this should be a Lisp symbol binding, not a C variable.
*/
int print_use_colours = 0;
/**
* print all the characters in the symbol or string indicated by `pointer`
* onto this `output`; if `pointer` does not indicate a string or symbol,
* don't print anything but just return.
*/
void print_string_contents( 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;
if ( c != '\0' ) {
fputwc( c, output );
}
pointer = cell->payload.string.cdr;
}
}
/**
* print all the characters in the string indicated by `pointer` onto
* the stream at this `output`, prepending and appending double quote
* characters.
*/
void print_string( FILE * output, struct cons_pointer pointer ) {
fputwc( btowc( '"' ), output );
print_string_contents( output, pointer );
fputwc( btowc( '"' ), output );
}
/**
* Print a single list cell (cons cell) indicated by `pointer` to the
* stream indicated by `output`. if `initial_space` is `true`, prepend
* a space character.
*/
void
print_list_contents( FILE * output, struct cons_pointer pointer,
bool initial_space ) {
struct cons_space_object *cell = &pointer2cell( pointer );
switch ( cell->tag.value ) {
case CONSTV:
if ( initial_space ) {
fputwc( btowc( ' ' ), output );
}
print( output, cell->payload.cons.car );
print_list_contents( output, cell->payload.cons.cdr, true );
break;
case NILTV:
break;
default:
fwprintf( output, L" . " );
print( output, pointer );
}
}
void print_list( FILE * output, struct cons_pointer pointer ) {
if ( print_use_colours ) {
fwprintf( output, L"%s(%s", "\x1B[31m", "\x1B[39m" );
} else {
fputws( L"(", output );
};
print_list_contents( output, pointer, false );
if ( print_use_colours ) {
fwprintf( output, L"%s)%s", "\x1B[31m", "\x1B[39m" );
} else {
fputws( L")", output );
}
}
/**
* Print the cons-space object indicated by `pointer` to the stream indicated
* by `output`.
*/
struct cons_pointer print( FILE * output, struct cons_pointer pointer ) {
struct cons_space_object cell = pointer2cell( pointer );
char *buffer;
/*
* Because tags have values as well as bytes, this if ... else if
* statement can ultimately be replaced by a switch, which will be neater.
*/
switch ( cell.tag.value ) {
case CONSTV:
print_list( output, pointer );
break;
case EXCEPTIONTV:
fwprintf( output, L"\n%sException: ",
print_use_colours ? "\x1B[31m" : "" );
print_string_contents( output, cell.payload.exception.message );
break;
case FUNCTIONTV:
fwprintf( output, L"(Function)" );
break;
case INTEGERTV:
if ( print_use_colours ) {
fputws( L"\x1B[34m", output );
}
fwprintf( output, L"%ld%", cell.payload.integer.value );
break;
case LAMBDATV:
print( output, make_cons( c_string_to_lisp_symbol( "lambda" ),
make_cons( cell.payload.lambda.args,
cell.payload.lambda.
body ) ) );
break;
case NILTV:
fwprintf( output, L"nil" );
break;
case NLAMBDATV:
print( output, make_cons( c_string_to_lisp_symbol( "nlambda" ),
make_cons( cell.payload.lambda.args,
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)" );
break;
case REALTV:
/* TODO: using the C heap is a bad plan because it will fragment.
* As soon as I have working vector space I'll use a special purpose
* vector space object */
buffer = ( char * ) malloc( 24 );
memset( buffer, 0, 24 );
/* format it really long, then clear the trailing zeros */
sprintf( buffer, "%-.23Lg", cell.payload.real.value );
if ( strchr( buffer, '.' ) != NULL ) {
for ( int i = strlen( buffer ) - 1; buffer[i] == '0'; i-- ) {
buffer[i] = '\0';
}
}
if ( print_use_colours ) {
fputws( L"\x1B[34m", output );
}
fwprintf( output, L"%s", buffer );
free( buffer );
break;
case STRINGTV:
if ( print_use_colours ) {
fputws( L"\x1B[36m", output );
}
print_string( output, pointer );
break;
case SYMBOLTV:
if ( print_use_colours ) {
fputws( L"\x1B[1;33m", output );
}
print_string_contents( output, pointer );
break;
case SPECIALTV:
fwprintf( output, L"(Special form)" );
break;
case TRUETV:
fwprintf( output, L"t" );
break;
default:
fwprintf( stderr,
L"%sError: Unrecognised tag value %d (%c%c%c%c)\n",
print_use_colours ? "\x1B[31m" : "",
cell.tag.value, cell.tag.bytes[0], cell.tag.bytes[1],
cell.tag.bytes[2], cell.tag.bytes[3] );
break;
}
if ( print_use_colours ) {
fputws( L"\x1B[39m", output );
}
return pointer;
}

20
src/ops/print.h Normal file
View file

@ -0,0 +1,20 @@
/**
* print.h
*
* First pass at a printer, for bootstrapping.
*
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <ctype.h>
#include <stdio.h>
#ifndef __print_h
#define __print_h
struct cons_pointer print( FILE * output, struct cons_pointer pointer );
extern int print_use_colours;
#endif

282
src/ops/read.c Normal file
View file

@ -0,0 +1,282 @@
/*
* read.c
*
* First pass at a reader, for bootstrapping.
*
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <math.h>
#include <stdbool.h>
#include <stdio.h>
/*
* wide characters
*/
#include <wchar.h>
#include <wctype.h>
#include "consspaceobject.h"
#include "integer.h"
#include "intern.h"
#include "lispops.h"
#include "print.h"
#include "read.h"
#include "real.h"
/*
* for the time being things which may be read are: strings numbers - either
* integer or real, but not yet including ratios or bignums lists Can't read
* atoms because I don't yet know what an atom is or how it's stored.
*/
struct cons_pointer read_number( struct stack_frame *frame, FILE * input,
wint_t initial, bool seen_period );
struct cons_pointer read_list( struct stack_frame *frame, 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 );
/**
* quote reader macro in C (!)
*/
struct cons_pointer c_quote( struct cons_pointer arg ) {
return make_cons( c_string_to_lisp_symbol( "quote" ),
make_cons( arg, NIL ) );
}
/**
* Read the next object on this input stream and return a cons_pointer to it,
* treating this initial character as the first character of the object
* representation.
*/
struct cons_pointer read_continuation( struct stack_frame *frame, FILE * input,
wint_t initial ) {
struct cons_pointer result = NIL;
wint_t c;
for ( c = initial;
c == '\0' || iswblank( c ) || iswcntrl( c ); c = fgetwc( input ) );
if ( feof( input ) ) {
result =
make_exception( c_string_to_lisp_string
( "End of file while reading" ), frame );
} else {
switch ( c ) {
case ';':
for ( c = fgetwc( input ); c != '\n'; c = fgetwc( 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 );
break;
case '\'':
result =
c_quote( read_continuation
( frame, input, fgetwc( input ) ) );
break;
case '(':
result = read_list( frame, input, fgetwc( input ) );
break;
case '"':
result = read_string( input, fgetwc( input ) );
break;
case '.':
{
wint_t next = fgetwc( input );
if ( iswdigit( next ) ) {
ungetwc( next, input );
result = read_number( frame, 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 ) );
} else {
read_symbol( input, c );
}
}
break;
default:
if ( iswdigit( c ) ) {
result = read_number( frame, 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 );
}
}
}
return result;
}
/**
* read a number from this input stream, given this initial character.
*/
struct cons_pointer read_number( struct stack_frame *frame, FILE * input,
wint_t initial, bool seen_period ) {
struct cons_pointer result = NIL;
long int accumulator = 0;
long int dividend = 0;
int places_of_decimals = 0;
wint_t c;
fwprintf( stderr, L"read_number starting '%c' (%d)\n", initial, initial );
for ( c = initial; iswdigit( c )
|| c == btowc( '.' ) || c == btowc( '/' ); c = fgetwc( input ) ) {
if ( c == btowc( '.' ) ) {
if ( seen_period || dividend > 0 ) {
return make_exception( c_string_to_lisp_string
( "Malformed number: too many periods" ),
frame );
} else {
seen_period = true;
}
} else if ( c == btowc( '/' ) ) {
if ( seen_period || dividend > 0 ) {
return make_exception( c_string_to_lisp_string
( "Malformed number: dividend must be integer" ),
frame );
} else {
dividend = accumulator;
accumulator = 0;
}
} else {
accumulator = accumulator * 10 + ( ( int ) c - ( int ) '0' );
fwprintf( stderr,
L"Added character %c, accumulator now %ld\n",
c, accumulator );
if ( seen_period ) {
places_of_decimals++;
}
}
}
/*
* push back the character read which was not a digit
*/
ungetwc( c, input );
if ( seen_period ) {
long double rv = ( long double )
( accumulator / pow( 10, places_of_decimals ) );
fwprintf( stderr, L"read_numer returning %Lf\n", rv );
result = make_real( rv );
} else if ( dividend > 0 ) {
result =
make_ratio( frame, make_integer( dividend ),
make_integer( accumulator ) );
} else {
result = make_integer( accumulator );
}
return result;
}
/**
* Read a list from this input stream, which no longer contains the opening
* left parenthesis.
*/
struct cons_pointer read_list( struct
stack_frame
*frame, FILE * input, wint_t initial ) {
struct cons_pointer result = NIL;
if ( initial != ')' ) {
fwprintf( stderr,
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 ) ) );
} else {
fwprintf( stderr, L"End of list detected\n" );
}
return result;
}
/**
* Read a string. This means either a string delimited by double quotes
* (is_quoted == true), in which case it may contain whitespace but may
* not contain a double quote character (unless escaped), or one not
* so delimited in which case it may not contain whitespace (unless escaped)
* but may contain a double quote character (probably not a good idea!)
*/
struct cons_pointer read_string( FILE * input, wint_t initial ) {
struct cons_pointer cdr = NIL;
struct cons_pointer result;
switch ( initial ) {
case '\0':
result = make_string( initial, NIL );
break;
case '"':
result = make_string( '\0', NIL );
break;
default:
result =
make_string( initial, read_string( input, fgetwc( input ) ) );
break;
}
return result;
}
struct cons_pointer read_symbol( FILE * input, wint_t initial ) {
struct cons_pointer cdr = NIL;
struct cons_pointer result;
switch ( initial ) {
case '\0':
result = make_symbol( initial, NIL );
break;
case '"':
/*
* THIS IS NOT A GOOD IDEA, but is legal
*/
result =
make_symbol( initial, read_symbol( input, fgetwc( input ) ) );
break;
case ')':
/*
* unquoted strings may not include right-parenthesis
*/
result = make_symbol( '\0', NIL );
/*
* push back the character read
*/
ungetwc( initial, input );
break;
default:
if ( iswprint( initial )
&& !iswblank( initial ) ) {
result =
make_symbol( initial,
read_symbol( input, fgetwc( input ) ) );
} else {
result = NIL;
/*
* push back the character read
*/
ungetwc( initial, input );
}
break;
}
fputws( L"Read symbol '", stderr );
print( stderr, result );
fputws( L"'\n", stderr );
return result;
}
/**
* Read the next object on this input stream and return a cons_pointer to it.
*/
struct cons_pointer read( struct
stack_frame
*frame, FILE * input ) {
return read_continuation( frame, input, fgetwc( input ) );
}

19
src/ops/read.h Normal file
View file

@ -0,0 +1,19 @@
/**
* read.c
*
* First pass at a reader, for bootstrapping.
*
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#ifndef __read_h
#define __read_h
/**
* 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 );
#endif