374 lines
10 KiB
C
374 lines
10 KiB
C
/**
|
|
* 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_cond( struct cons_pointer args, struct cons_pointer env,
|
|
struct stack_frame* frame);
|
|
* 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)) {
|
|
result = pointer2cell(arg).payload.cons.cdr;
|
|
}
|
|
|
|
return result;
|
|
}
|
|
|
|
/**
|
|
* (apply fn args...)
|
|
*
|
|
* I'm now confused about whether at this stage I actually need an apply special form,
|
|
* and if so how it differs from eval.
|
|
*/
|
|
struct cons_pointer
|
|
lisp_apply(struct cons_pointer args, struct cons_pointer env,
|
|
struct stack_frame *frame)
|
|
{
|
|
struct cons_pointer result = args;
|
|
|
|
if (consp(args)) {
|
|
lisp_eval(args, env, frame);
|
|
}
|
|
|
|
return result;
|
|
}
|
|
|
|
struct cons_pointer
|
|
eval_cons(struct cons_pointer s_expr, struct cons_pointer env,
|
|
struct stack_frame *my_frame)
|
|
{
|
|
struct cons_pointer result = NIL;
|
|
struct cons_pointer fn_pointer = lisp_eval(c_car(s_expr), env, my_frame);
|
|
struct cons_space_object fn_cell = pointer2cell(fn_pointer);
|
|
struct cons_pointer args = c_cdr(s_expr);
|
|
|
|
switch (fn_cell.tag.value) {
|
|
case SPECIALTV:
|
|
{
|
|
struct cons_space_object special = pointer2cell(fn_pointer);
|
|
result =
|
|
(*special.payload.special.executable) (args, env, my_frame);
|
|
}
|
|
break;
|
|
|
|
case FUNCTIONTV:
|
|
/*
|
|
* actually, this is apply
|
|
*/
|
|
{
|
|
struct cons_space_object function = pointer2cell(fn_pointer);
|
|
struct stack_frame *frame = make_stack_frame(my_frame, args, env);
|
|
|
|
/*
|
|
* the trick: pass the remaining arguments and environment to the
|
|
* executable code which is the payload of the function object.
|
|
*/
|
|
result = (*function.payload.function.executable) (frame, env);
|
|
free_stack_frame(frame);
|
|
}
|
|
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, my_frame);
|
|
}
|
|
}
|
|
|
|
return result;
|
|
}
|
|
|
|
/**
|
|
* (eval s_expr)
|
|
*
|
|
* Special form.
|
|
* 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 cons_pointer s_expr, struct cons_pointer env,
|
|
struct stack_frame *previous)
|
|
{
|
|
struct cons_pointer result = s_expr;
|
|
struct cons_space_object cell = pointer2cell(s_expr);
|
|
struct stack_frame *my_frame =
|
|
make_stack_frame(previous, make_cons(s_expr, NIL), env);
|
|
|
|
switch (cell.tag.value) {
|
|
case CONSTV:
|
|
result = eval_cons(s_expr, env, my_frame);
|
|
break;
|
|
|
|
case SYMBOLTV:
|
|
{
|
|
struct cons_pointer canonical = internedp(s_expr, env);
|
|
if (nilp(canonical)) {
|
|
struct cons_pointer message =
|
|
c_string_to_lisp_string
|
|
("Attempt to take value of unbound symbol.");
|
|
result = lisp_throw(message, my_frame);
|
|
} else {
|
|
result = c_assoc(canonical, env);
|
|
}
|
|
}
|
|
break;
|
|
/*
|
|
* 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.
|
|
*/
|
|
}
|
|
|
|
free_stack_frame(my_frame);
|
|
|
|
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 cons_pointer args, struct cons_pointer env,
|
|
struct stack_frame *frame)
|
|
{
|
|
return c_car(args);
|
|
}
|
|
|
|
/**
|
|
* (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/CDR 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.car;
|
|
} 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 CAR/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(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)
|
|
{
|
|
FILE *output = stdout;
|
|
|
|
if (writep(frame->arg[1])) {
|
|
output = pointer2cell(frame->arg[1]).payload.stream.stream;
|
|
}
|
|
|
|
print(output, frame->arg[0]);
|
|
|
|
return NIL;
|
|
}
|
|
|
|
/**
|
|
* TODO: make this do something sensible somehow.
|
|
*/
|
|
struct cons_pointer
|
|
lisp_throw(struct cons_pointer message, struct stack_frame *frame)
|
|
{
|
|
fprintf(stderr, "\nERROR: ");
|
|
print(stderr, message);
|
|
fprintf(stderr,
|
|
"\n\nAn exception was thrown and I've no idea what to do now\n");
|
|
|
|
exit(1);
|
|
}
|