Skip to content

Instantly share code, notes, and snippets.

@cellularmitosis
Last active January 13, 2020 22:37
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save cellularmitosis/64d1d5aa073336ff87ac9b30a21c5058 to your computer and use it in GitHub Desktop.
Save cellularmitosis/64d1d5aa073336ff87ac9b30a21c5058 to your computer and use it in GitHub Desktop.
A Lisp interpreter in C, part 11: apply

Blog 2020/1/12

<- previous | index | next ->

A Lisp interpreter in C, part 11: apply

Let's learn how to write a Lisp interpreter in C!

In this part, we implement funcion application.

Lisp stands for "list processing", which means that every list is treated like a function call. The first element of the list is assumed to be the operator, and the rest of the elements are the operands. The operator is applied to the operands, and thus (+ 1 1) evaluates to 2.

Built-ins

When a list is evaluated, the first element must be one of three things:

  • a special-form,
  • (something which evaluates to) a user-defined function (also called a lambda),
  • (something which evaluates to) a built-in function (also called a primitive function).

Our first built-in function is bi_add() (bi being a bit of Hungarian notation), which we will bind to the symbol +:

builtins.c (error handling elided):

/* Built-in addition, i.e. `(+ 1 2 3)`.
Calculates the sum of argsp into resultp.
Promotes CLong to CDouble where needed.
Returns 0 or error. */
int bi_add(List* argsp, Form** resultpp, List* envp) {
    long accuml = 0;
    double accumd = 0.0;
    bool long_mode = true;
    bool double_mode = false;
    bool mode = long_mode;
    while (!is_list_empty(argsp)) {
        Form* argp = argsp->datap;
        if (is_clong(argp)) {
            long l = ((CLong*)argp)->value;
            if (mode == long_mode) {
                accuml += l;
            } else {
                accumd += (double)l;
            }
        } else if (is_cdouble(argp)) {
            double d = ((CDouble*)argp)->value;
            if (mode == double_mode) {
                accumd += d;
            } else {
                /* switch to double-mode. */
                mode = double_mode;
                accumd = (double)accuml + d;
            }
        } else {
            return E_bi_add__unsupported_arg_type;
        }
        argsp = argsp->nextp;
        continue;
    }

    if (mode == long_mode) {
        CLong* clp;
        new_clong(&clp, accuml);
        *resultpp = (Form*)clp;
        return 0;
    } else {
        CDouble* cdp;
        new_cdouble(&cdp, accumd);
        *resultpp = (Form*)cdp;
        return 0;
    }
}

Note that bi_add() promotes integers to doubles when it is given mixed-type arguments. Thus (+ 1 3.14159) evaluates to 4.14159.

Lisp forms

In order to bind a built-in function in the environment, we need to be able to represent it as a Lisp form. For this, we add another struct:

forms.c:

struct CFunc_ {
    FormType type;
    int (*f)(List*, Form**, List*);
};
typedef struct CFunc_ CFunc;

In the above, f is a pointer to a function which takes a List*, a Form**, and another List*, and returns an int. I use cdecl.org to deal with function pointers in C.

Notice that this matches the function signature of bi_add(). That's no coincidence: all of our built-in functions will need to share a common signature.

We update form_eq() to handle CFunc. All we have to do is compare the two C-function pointers:

forms.c:

         return a == b;
     } else if (is_nil(a)) {
         return true;
+    } else if (is_cfunc(a)) {
+        CFunc* af = (CFunc*)a;
+        CFunc* bf = (CFunc*)b;
+        return af->f == bf->f;
     } else {
         assert(false);
     }

The evaluator

We update eval_list() to perform function application: it evaluates the operator, evaluates the operands, then calls apply().

eval.c (error handling elided):

     }
 
     /* this is a regular function call. */
-    /* for now, we just return the list. */
-    *resultpp = (Form*)lp;
-    return 0;
+    Form* op_evaledp;
+    List* args_evaledp;
+    eval_form(op_formp, &op_evaledp, envp);
+    eval_forms(argsp, &args_evaledp, envp);
+    return apply(op_evaledp, args_evaledp, resultpp, envp);
 }
 
 

Our initial implementation of apply() is very simple: it calls the C function with the supplied arguments:

eval.c:

/* Function application: apply the operator to the arguments.
Returns 0 or error. */
static int apply(Form* opp, List* argsp, Form** resultpp, List* envp) {
    if (is_cfunc(opp)) {
        CFunc* cfp = (CFunc*)opp;
        return (cfp->f)(argsp, resultpp, envp);
    } else {
        return E_apply__bad_op_type;
    }
}

And eval_forms() is simply a convenience loop around eval_form():

eval.c (error handling elided):

/* Evaluate a list of forms.
Returns 0 or error. */
static int eval_forms(List* formsp, List** resultspp, List* envp) {
    List* resultsp = g_emptylist;
    while (!is_list_empty(formsp)) {
        Form* resultp;
        eval_form(formsp->datap, &resultp, envp);
        list_push(&resultsp, resultp);
        formsp = formsp->nextp;
        continue;
    }
    *resultspp = resultsp;
    return 0;
}

main

We update new_default_env() to bind + to our bi_add() built-in:

main.c:

     assert(env_bind_nil(envp, "nil") == 0);
     assert(env_bind_cbool(envp, "true", g_true) == 0);
     assert(env_bind_cbool(envp, "false", g_false) == 0);
+    assert(env_bind_cfunc(envp, "+", bi_add) == 0);
     return envp;
 }
 

forms.c (error handling elided):

/* Convenience function to push a built-in C function into the env.
Returns 0 or error. */
int env_bind_cfunc(List* envp, char* key, int (*f)(List*, Form**, List*)) {
    Symbol* keyp;
    new_symbol(&keyp, key);
    CFunc* valuep;
    new_cfunc(&valuep, f);
    return env_bind(envp, keyp, (Form*)valuep);
}

The printer

We update print_form() to handle CFunc:

printer.c:

         return print_cbool(cbp, fp);
     } else if (is_nil(formp)) {
         return print_nil(fp);
+    } else if (is_cfunc(formp)) {
+        CFunc* cfp = (CFunc*)formp;
+        return print_cfunc(cfp, fp);
     } else {
         assert(false);
     }

printer.c (error handling elided):

/* Prints the CFunc in cfp into fp.
Returns 0 or errno. */
static int print_cfunc(CFunc* cfp, FILE* fp) {
    fprintf(fp, "<C function @%p>", cfp->f);
    return 0;
}

Try it out

Finally, we can call functions!

$ ./lisp
> (+ 1 1)
2
>

Glorious!

$ ./lisp
> (bind a 2)
> (bind b 3)
> (+ a b)
5
>

We also have a printable representation for CFunc values:

$ ./lisp 
> +
<C function @0x1038c4060>
> 

Next time

In part 12, we'll implement the quote special form.

/* This file is Copyright (C) 2019 Jason Pepas. */
/* This file is released under the terms of the MIT License. */
/* See https://opensource.org/licenses/MIT */
#include "builtins.h"
#include "errors.h"
/* Built-in addition, i.e. `(+ 1 2 3)`.
Calculates the sum of argsp into resultp.
Promotes CLong to CDouble where needed.
Returns 0 or error. */
int bi_add(List* argsp, Form** resultpp, List* envp) {
long accuml = 0;
double accumd = 0.0;
bool long_mode = true;
bool double_mode = false;
bool mode = long_mode;
while (!is_list_empty(argsp)) {
Form* argp = argsp->datap;
if (is_clong(argp)) {
long l = ((CLong*)argp)->value;
if (mode == long_mode) {
accuml += l;
} else {
accumd += (double)l;
}
} else if (is_cdouble(argp)) {
double d = ((CDouble*)argp)->value;
if (mode == double_mode) {
accumd += d;
} else {
/* switch to double-mode. */
mode = double_mode;
accumd = (double)accuml + d;
}
} else {
return E_bi_add__unsupported_arg_type;
}
argsp = argsp->nextp;
continue;
}
if (mode == long_mode) {
CLong* clp;
int err = new_clong(&clp, accuml);
if (err) {
return err;
} else {
*resultpp = (Form*)clp;
return 0;
}
} else {
CDouble* cdp;
int err = new_cdouble(&cdp, accumd);
if (err) {
return err;
} else {
*resultpp = (Form*)cdp;
return 0;
}
}
}
/* This file is Copyright (C) 2019 Jason Pepas. */
/* This file is released under the terms of the MIT License. */
/* See https://opensource.org/licenses/MIT */
#ifndef _BUILTINS_H_
#define _BUILTINS_H_
#include "forms.h"
int bi_add(List* argsp, Form** resultpp, List* envp);
#endif
/* This file is Copyright (C) 2019 Jason Pepas. */
/* This file is released under the terms of the MIT License. */
/* See https://opensource.org/licenses/MIT */
#ifndef _ERRCODE_H_
#define _ERRCODE_H_
enum ErrCode_ {
/* not an error. */
E_success = 0,
/* A catch-all "unknown" error. */
/* Note: we start at 10,000 to skip past the errno range. */
E_unknown = 10000,
/* certain special-forms do not return a value. */
E_did_not_produce_a_value = 10001,
/* We ran out of buffer while reading a token. */
E_file_get_token__buff_overflow = 10010,
/* We tried to parse an invalid string. */
E_parse_string__invalid_string_1 = 10020,
E_parse_string__invalid_string_2 = 10021,
E_parse_string__invalid_string_3 = 10022,
E_parse_string__invalid_string_4 = 10023,
E_read_list__premature_eof_1 = 10030,
E_read_list__premature_eof_2 = 10031,
E_read_list__premature_eof_3 = 10032,
E_read_list__missing_ws = 10040,
E_read_form__unexpected_list_closer = 10050,
E_read_form__comment = 10051,
E_eval_symbol__unbound = 10060,
E_sf_bind__bad_arg_count = 10070,
E_bi_add__unsupported_arg_type = 10080,
E_apply__bad_op_type = 10100,
};
typedef enum ErrCode_ ErrCode;
#endif
/* This file is Copyright (C) 2019 Jason Pepas. */
/* This file is released under the terms of the MIT License. */
/* See https://opensource.org/licenses/MIT */
#include "eval.h"
#include "errors.h"
#include "printer.h"
#include <assert.h>
#include <string.h>
/* Evaluates symp into resultpp.
Returns 0 or error. */
static int eval_symbol(Symbol* symp, Form** resultpp, List* envp) {
/* symbols evaluate to their corresponding value from the env. */
Form* valuep = env_lookup(envp, symp);
if (valuep == NULL) {
return E_eval_symbol__unbound;
} else {
*resultpp = valuep;
return 0;
}
}
/* The 'bind' special-form.
Binds a value to a symbol in the environment.
Returns E_did_not_produce_a_value or error. */
static int sf_bind(List* argsp, Form** resultpp, List* envp) {
if (list_len(argsp) != 2) {
return E_sf_bind__bad_arg_count;
}
/* arg1 is the symbol. */
Symbol* keyp = (Symbol*)argsp->datap;
/* arg2 is the form to be evaluated and associated with the symbol. */
Form* arg2p = argsp->nextp->datap;
Form* valuep;
int err = eval_form(arg2p, &valuep, envp);
if (err) {
return err;
}
err = env_bind(envp, keyp, valuep);
if (err) {
return err;
} else {
/* this is our success-case. */
return E_did_not_produce_a_value;
}
}
/* Evaluate a list of forms.
Returns 0 or error. */
static int eval_forms(List* formsp, List** resultspp, List* envp) {
List* resultsp = g_emptylist;
while (!is_list_empty(formsp)) {
Form* resultp;
int err = eval_form(formsp->datap, &resultp, envp);
if (err) {
return err;
}
err = list_push(&resultsp, resultp);
if (err) {
return err;
}
formsp = formsp->nextp;
continue;
}
*resultspp = resultsp;
return 0;
}
/* Function application: apply the operator to the arguments.
Returns 0 or error. */
static int apply(Form* opp, List* argsp, Form** resultpp, List* envp) {
if (is_cfunc(opp)) {
CFunc* cfp = (CFunc*)opp;
return (cfp->f)(argsp, resultpp, envp);
} else {
return E_apply__bad_op_type;
}
}
/* Evaluates lp into resultpp.
Returns 0 or error. */
static int eval_list(List* lp, Form** resultpp, List* envp) {
/* the empty list evaluates to itself. */
if (is_list_empty(lp)) {
*resultpp = (Form*)lp;
return 0;
}
/* special-forms are handled as special cases. */
Form* op_formp = lp->datap;
List* argsp = lp->nextp;
if (is_symbol(op_formp)) {
Symbol* op_symp = (Symbol*)op_formp;
if (strcmp(op_symp->valuep, "bind") == 0) {
return sf_bind(argsp, resultpp, envp);
}
}
/* this is a regular function call. */
Form* op_evaledp;
List* args_evaledp;
int err = eval_form(op_formp, &op_evaledp, envp);
if (err) {
return err;
}
err = eval_forms(argsp, &args_evaledp, envp);
if (err) {
return err;
}
return apply(op_evaledp, args_evaledp, resultpp, envp);
}
/* Evaluates formp into resultpp.
Returns 0 or E_did_not_produce_a_value or error. */
int eval_form(Form* formp, Form** resultpp, List* envp) {
/* literals evaluate to themselves. */
if (is_clong(formp) || is_cdouble(formp) || is_cstring(formp)) {
*resultpp = formp;
return 0;
/* symbols. */
} else if (is_symbol(formp)) {
Symbol* symp = (Symbol*)formp;
return eval_symbol(symp, resultpp, envp);
/* lists. */
} else if (is_list(formp)) {
List* lp = (List*)formp;
return eval_list(lp, resultpp, envp);
/* unsupported form. */
} else {
assert(false);
}
}
/* This file is Copyright (C) 2019 Jason Pepas. */
/* This file is released under the terms of the MIT License. */
/* See https://opensource.org/licenses/MIT */
#ifndef _EVAL_H_
#define _EVAL_H_
#include "forms.h"
int eval_form(Form* formp, Form** resultpp, List* envp);
#endif
/* This file is Copyright (C) 2019 Jason Pepas. */
/* This file is released under the terms of the MIT License. */
/* See https://opensource.org/licenses/MIT */
/* All of the Lisp forms. */
#include "forms.h"
#include <stdlib.h>
#include <sys/errno.h>
#include <assert.h>
#include <string.h>
/* Form */
/* Are a and b equal? */
bool form_eq(Form* a, Form* b) {
if (a->type != b->type) {
return false;
} else if (is_clong(a)) {
CLong* al = (CLong*)a;
CLong* bl = (CLong*)b;
return al->value == bl->value;
} else if (is_cdouble(a)) {
CDouble* ad = (CDouble*)a;
CDouble* bd = (CDouble*)b;
return ad->value == bd->value;
} else if (is_cstring(a)) {
CString* as = (CString*)a;
CString* bs = (CString*)b;
return (strcmp(as->valuep, bs->valuep) == 0);
} else if (is_symbol(a)) {
Symbol* as = (Symbol*)a;
Symbol* bs = (Symbol*)b;
return (strcmp(as->valuep, bs->valuep) == 0);
} else if (is_list(a)) {
List* al = (List*)a;
List* bl = (List*)b;
while (true) {
if (is_list_empty(al) && is_list_empty(bl)) {
return true;
} else if (!is_list_empty(al) && !is_list_empty(bl)) {
if (form_eq(al->datap, bl->datap)) {
al = al->nextp;
bl = bl->nextp;
continue;
} else {
return false;
}
} else {
return false;
}
}
} else if (is_cbool(a)) {
/* CBool's are singletons, so we can just use pointer comparison. */
return a == b;
} else if (is_nil(a)) {
return true;
} else if (is_cfunc(a)) {
CFunc* af = (CFunc*)a;
CFunc* bf = (CFunc*)b;
return af->f == bf->f;
} else {
assert(false);
}
}
/* Is formp truthy? */
bool is_form_truthy(Form* formp) {
return !is_form_falsey(formp);
}
/* Is formp falsey? */
bool is_form_falsey(Form* formp) {
return formp == (Form*)g_false || is_nil(formp);
}
/* Symbol */
/* Malloc's a Symbol into sympp and copies sp into it. */
int new_symbol(Symbol** sympp, const char* sp) {
Symbol* symp = malloc(sizeof(Symbol));
if (symp == NULL) {
int err = errno;
errno = 0;
return err;
}
symp->type = TypeSymbol;
size_t len = strlen(sp);
symp->valuep = malloc(len + 1);
if (symp->valuep == NULL) {
free(symp);
int err = errno;
errno = 0;
return err;
}
strcpy(symp->valuep, sp);
*sympp = symp;
return 0;
}
/* Is formp a Symbol? */
bool is_symbol(Form* formp) {
return formp->type == TypeSymbol;
}
/* CLong */
/* Malloc's a CLong into clpp, initializing it with l.
Returns 0 or errno. */
int new_clong(CLong** clpp, long l) {
CLong* clp = malloc(sizeof(CLong));
if (clp == NULL) {
int err = errno;
errno = 0;
return err;
}
clp->type = TypeCLong;
clp->value = l;
*clpp = clp;
return 0;
}
/* Is formp a CLong? */
bool is_clong(Form* formp) {
return formp->type == TypeCLong;
}
/* CDouble */
/* Malloc's a CDouble into cdpp, initializing it with d.
Returns 0 or errno. */
int new_cdouble(CDouble** cdpp, double d) {
CDouble* cdp = malloc(sizeof(CDouble));
if (cdp == NULL) {
int err = errno;
errno = 0;
return err;
}
cdp->type = TypeCDouble;
cdp->value = d;
*cdpp = cdp;
return 0;
}
/* Is formp a CDouble? */
bool is_cdouble(Form* formp) {
return formp->type == TypeCDouble;
}
/* CString */
/* Malloc's a CString into cspp and places sp into it.
Note: sp is not copied; cspp assumes ownership of it.
Returns 0 or errno. */
int new_cstring(CString** cspp, char* sp) {
CString* csp = malloc(sizeof(CString));
if (csp == NULL) {
int err = errno;
errno = 0;
return err;
}
csp->type = TypeCString;
csp->valuep = sp;
*cspp = csp;
return 0;
}
/* Is formp a CString? */
bool is_cstring(Form* formp) {
return formp->type == TypeCString;
}
/* CBool */
CBool* g_true = NULL;
CBool* g_false = NULL;
/* Initialize the global boolean singletons.
Asserts on failure.
Call this function once from main(). */
void cbool_main() {
g_true = malloc(sizeof(CBool));
assert(g_true != NULL);
g_true->type = TypeCBool;
g_true->value = true;
g_false = malloc(sizeof(CBool));
assert(g_false != NULL);
g_false->type = TypeCBool;
g_false->value = false;
}
/* Is formp a CBool? */
bool is_cbool(Form* formp) {
return formp->type == TypeCBool;
}
/* Nil */
Nil* g_nil = NULL;
/* Initialize the global nil singleton.
Asserts on failure.
Call this function once from main(). */
void nil_main() {
g_nil = malloc(sizeof(Nil));
g_nil->type = TypeNil;
assert(g_nil != NULL);
}
/* Is formp nil? */
bool is_nil(Form* formp) {
return formp == (Form*)g_nil;
}
/* List */
List* g_emptylist = NULL;
/* Initialize the global empty list singleton.
Asserts on failure.
Call this function once from main(). */
void list_main() {
assert(g_emptylist == NULL);
g_emptylist = malloc(sizeof(List));
assert(g_emptylist != NULL);
g_emptylist->type = TypeList;
g_emptylist->nextp = g_emptylist;
g_emptylist->datap = (Form*)g_emptylist;
}
/* Malloc's a List intp lpp, initializing it with datap.
Returns 0 or errno. */
int new_list(List** lpp, Form* datap) {
List* lp;
if (datap == NULL) {
lp = g_emptylist;
} else {
lp = malloc(sizeof(List));
if (lp == NULL) {
int err = errno;
errno = 0;
return err;
}
lp->type = TypeList;
lp->datap = datap;
lp->nextp = g_emptylist;
}
*lpp = lp;
return 0;
}
/* Is formp a List? */
bool is_list(Form* formp) {
return formp->type == TypeList;
}
/* Is listp the empty list? */
bool is_list_empty(List* lp) {
return lp == g_emptylist;
}
/* Push formp as the new head of listpp.
Returns 0 or errno. */
int list_push(List** listpp, Form* formp) {
List* list2p;
int err = new_list(&list2p, formp);
if (err) {
return err;
}
list2p->nextp = *listpp;
*listpp = list2p;
return 0;
}
/* Returns the length of the list. */
size_t list_len(List* listp) {
size_t len = 0;
while (!is_list_empty(listp)) {
listp = listp->nextp;
len++;
continue;
}
return len;
}
/* Association List */
/* Creates a new key-value pair and pushes it onto the A-list.
Returns 0 or error. */
int alist_push(List** alistpp, Symbol* keyp, Form* valuep) {
List* alistp = *alistpp;
/* construct a key-value "pair" (list) */
List* vlp;
int err = new_list(&vlp, valuep);
if (err) {
return err;
}
List* kvlp;
err = new_list(&kvlp, (Form*)keyp);
if (err) {
return err;
}
kvlp->nextp = vlp;
List* newheadp;
err = new_list(&newheadp, (Form*)kvlp);
if (err) {
return err;
}
newheadp->nextp = alistp;
*alistpp = newheadp;
return 0;
}
/* Returns the value which corresponds to keyp.
Returns a Form or NULL. */
Form* alist_lookup(List* alistp, Symbol* keyp) {
while (true) {
if (is_list_empty(alistp)) {
return NULL;
} else {
List* kvlp = (List*)(alistp->datap);
if (form_eq(kvlp->datap, (Form*)keyp)) {
return kvlp->nextp->datap;
} else {
alistp = alistp->nextp;
continue;
}
}
}
}
/* Environment */
/* Pushes a new scope onto envpp.
Returns 0 or error. */
int env_push_scope(List** envpp) {
List* envp = *envpp;
List* alistp = g_emptylist;
List* newheadp;
int err = new_list(&newheadp, (Form*)alistp);
if (err) {
return err;
}
newheadp->nextp = envp;
*envpp = newheadp;
return 0;
}
/* Push a new key-value pair onto the environment.
Returns 0 or error. */
int env_bind(List* envp, Symbol* keyp, Form* valuep) {
assert(!is_list_empty(envp));
List* alistp = (List*)(envp->datap);
int err = alist_push(&alistp, keyp, valuep);
if (err) {
return err;
} else {
envp->datap = (Form*)alistp;
return 0;
}
}
/* Recursively looks up the value from the environment stack.
Returns a Form or NULL. */
Form* env_lookup(List* envp, Symbol* keyp) {
List* alistp;
while (!is_list_empty(envp)) {
alistp = (List*)(envp->datap);
Form* valuep = alist_lookup(alistp, keyp);
if (valuep) {
return valuep;
} else {
envp = envp->nextp;
continue;
}
}
return NULL;
}
/* Convenience function to push a long into the env.
Returns 0 or error. */
int env_bind_clong(List* envp, char* key, long value) {
Symbol* keyp;
int err = new_symbol(&keyp, key);
if (err) {
return err;
}
CLong* valuep;
err = new_clong(&valuep, value);
if (err) {
return err;
}
return env_bind(envp, keyp, (Form*)valuep);
}
/* Convenience function to push a double into the env.
Returns 0 or error. */
int env_bind_cdouble(List* envp, char* key, double value) {
Symbol* keyp;
int err = new_symbol(&keyp, key);
if (err) {
return err;
}
CDouble* valuep;
err = new_cdouble(&valuep, value);
if (err) {
return err;
}
return env_bind(envp, keyp, (Form*)valuep);
}
/* Convenience function to push a string into the env.
Returns 0 or error. */
int env_bind_cstring(List* envp, char* key, char* value) {
Symbol* keyp;
int err = new_symbol(&keyp, key);
if (err) {
return err;
}
CString* valuep;
err = new_cstring(&valuep, value);
if (err) {
return err;
}
return env_bind(envp, keyp, (Form*)valuep);
}
/* Convenience function to push nil into the env.
Returns 0 or error. */
int env_bind_nil(List* envp, char* key) {
Symbol* keyp;
int err = new_symbol(&keyp, key);
if (err) {
return err;
}
return env_bind(envp, keyp, (Form*)g_nil);
}
/* Convenience function to push a boolean into the env.
Returns 0 or error. */
int env_bind_cbool(List* envp, char* key, CBool* value) {
Symbol* keyp;
int err = new_symbol(&keyp, key);
if (err) {
return err;
}
return env_bind(envp, keyp, (Form*)value);
}
/* Convenience function to push a built-in C function into the env.
Returns 0 or error. */
int env_bind_cfunc(List* envp, char* key, int (*f)(List*, Form**, List*)) {
Symbol* keyp;
int err = new_symbol(&keyp, key);
if (err) {
return err;
}
CFunc* valuep;
err = new_cfunc(&valuep, f);
if (err) {
return err;
}
return env_bind(envp, keyp, (Form*)valuep);
}
/* CFunc */
/* Malloc's a CFunc into cfpp and places f into it.
Returns 0 or errno. */
int new_cfunc(CFunc** cfpp, int (*f)(List*, Form**, List*)) {
CFunc* cfp = malloc(sizeof(CFunc));
if (cfp == NULL) {
int err = errno;
errno = 0;
return err;
}
cfp->type = TypeCFunc;
cfp->f = f;
*cfpp = cfp;
return 0;
}
/* Is formp a CFunc? */
bool is_cfunc(Form* formp) {
return formp->type == TypeCFunc;
}
/* This file is Copyright (C) 2019 Jason Pepas. */
/* This file is released under the terms of the MIT License. */
/* See https://opensource.org/licenses/MIT */
/* All of the Lisp forms. */
#ifndef _FORM_H_
#define _FORM_H_
#include <stdlib.h>
#include <stdbool.h>
/* The list of Lisp form types. */
enum FormType_ {
_Type_UNINITIALIZED = 0,
TypeSymbol = 10,
TypeCLong = 20,
TypeCDouble = 30,
TypeCString = 40,
TypeCBool = 50,
TypeNil = 60,
TypeList = 100,
TypeCFunc = 200,
};
typedef enum FormType_ FormType;
/* A type-erased Lisp form. */
struct Form_ {
FormType type;
};
typedef struct Form_ Form;
bool form_eq(Form* a, Form* b);
bool is_form_truthy(Form* formp);
bool is_form_falsey(Form* formp);
/* Symbol */
struct Symbol_ {
FormType type;
char* valuep;
};
typedef struct Symbol_ Symbol;
int new_symbol(Symbol** sympp, const char* sp);
bool is_symbol(Form* formp);
/* CLong */
struct CLong_ {
FormType type;
long value;
};
typedef struct CLong_ CLong;
int new_clong(CLong** clpp, long l);
bool is_clong(Form* formp);
/* CDouble */
struct CDouble_ {
FormType type;
double value;
};
typedef struct CDouble_ CDouble;
int new_cdouble(CDouble** cdpp, double d);
bool is_cdouble(Form* formp);
/* CString */
struct CString_ {
FormType type;
char* valuep;
};
typedef struct CString_ CString;
int new_cstring(CString** cspp, char* sp);
bool is_cstring(Form* formp);
/* CBool */
struct CBool_ {
FormType type;
bool value;
};
typedef struct CBool_ CBool;
void cbool_main();
bool is_cbool(Form* formp);
extern CBool* g_true;
extern CBool* g_false;
/* Nil */
struct Nil_ {
FormType type;
};
typedef struct Nil_ Nil;
void nil_main();
bool is_nil(Form* formp);
extern Nil* g_nil;
/* List */
struct List_ {
FormType type;
Form* datap;
struct List_* nextp;
};
typedef struct List_ List;
extern List* g_emptylist;
int new_list(List** lpp, Form* datap);
bool is_list(Form* formp);
int list_push(List** listpp, Form* formp);
bool is_list_empty(List* listp);
size_t list_len(List* listp);
void list_main();
/* Association List */
int alist_push(List** alistpp, Symbol* keyp, Form* valuep);
Form* alist_lookup(List* alistp, Symbol* keyp);
/* Environment */
int env_push_scope(List** envpp);
int env_bind(List* envp, Symbol* keyp, Form* valuep);
Form* env_lookup(List* envp, Symbol* keyp);
int env_bind_clong(List* envp, char* key, long value);
int env_bind_cdouble(List* envp, char* key, double value);
int env_bind_cstring(List* envp, char* key, char* value);
int env_bind_nil(List* envp, char* key);
int env_bind_cbool(List* envp, char* key, CBool* value);
int env_bind_cfunc(List* envp, char* key, int (*f)(List*, Form**, List*));
/* CFunc */
struct CFunc_ {
FormType type;
int (*f)(List*, Form**, List*);
};
typedef struct CFunc_ CFunc;
int new_cfunc(CFunc** cfpp, int (*f)(List*, Form**, List*));
bool is_cfunc(Form* formp);
#endif
/* This file is Copyright (C) 2019 Jason Pepas. */
/* This file is released under the terms of the MIT License. */
/* See https://opensource.org/licenses/MIT */
#include "repl.h"
#include "forms.h"
#include "builtins.h"
#include <stdlib.h>
#include <stdio.h>
#include <assert.h>
/* Creates a default environment.
Asserts on error. */
List* new_default_env() {
List* envp = g_emptylist;
assert(env_push_scope(&envp) == 0);
assert(env_bind_clong(envp, "the-answer", 42) == 0);
assert(env_bind_cdouble(envp, "pi", 3.14159) == 0);
assert(env_bind_cstring(envp, "greeting", "Hello, world!") == 0);
assert(env_bind_nil(envp, "nil") == 0);
assert(env_bind_cbool(envp, "true", g_true) == 0);
assert(env_bind_cbool(envp, "false", g_false) == 0);
assert(env_bind_cfunc(envp, "+", bi_add) == 0);
return envp;
}
/* The entrypoint of this program. */
int main() {
list_main();
cbool_main();
nil_main();
List* envp = new_default_env();
int err = repl(envp);
if (err) {
fprintf(stderr, "Error %d.\n", err);
return err;
} else {
return EXIT_SUCCESS;
}
}
CC=gcc -g -std=c99 -Wall -Werror -D_POSIX_C_SOURCE=200809L
lisp: main.o forms.o reader.o eval.o printer.o repl.o builtins.o
$(CC) -o lisp *.o
main.o: main.c
$(CC) -c main.c
forms.o: forms.h forms.c
$(CC) -c forms.c
reader.o: reader.h reader.c
$(CC) -c reader.c
eval.o: eval.h eval.c
$(CC) -c eval.c
printer.o: printer.h printer.c
$(CC) -c printer.c
repl.o: repl.h repl.c
$(CC) -c repl.c
builtins.o: builtins.h builtins.c
$(CC) -c builtins.c
clean:
rm -f *.o lisp
test: lisp
./run_tests.sh
.PHONY: clean
/* This file is Copyright (C) 2019 Jason Pepas. */
/* This file is released under the terms of the MIT License. */
/* See https://opensource.org/licenses/MIT */
#include "printer.h"
#include <assert.h>
#include <sys/errno.h>
#include <stdlib.h>
#include <string.h>
/* Prints the Symbol in symp into fp.
Returns 0 or errno. */
static int print_symbol(Symbol* symp, FILE* fp) {
int err = fprintf(fp, "%s", symp->valuep);
if (err < 0) {
return err;
} else {
return 0;
}
}
/* Prints the CLong in lp into fp.
Returns 0 or errno. */
static int print_clong(CLong* lp, FILE* fp) {
int err = fprintf(fp, "%li", lp->value);
if (err < 0) {
return err;
} else {
return 0;
}
}
/* Prints the CDouble in dp into fp.
Returns 0 or errno. */
static int print_cdouble(CDouble* dp, FILE* fp) {
int err = fprintf(fp, "%f", dp->value);
if (err < 0) {
return err;
} else {
return 0;
}
}
/* Is ch an unescaped char? */
bool is_unescaped(char ch) {
char* found = strchr("\a\b\e\f\n\r\t\v\\\"", (int)ch);
return found != NULL;
}
/* Returns the escaped version of unesc.
For example, if unesc is a newline, 'n' is returned.
Asserts false if unesc is not a valid escape char. */
static char escape_char(char unesc) {
if (unesc == '\a') {
return 'a';
} else if (unesc == '\b') {
return 'b';
} else if (unesc == '\e') {
return 'e';
} else if (unesc == '\f') {
return 'f';
} else if (unesc == '\n') {
return 'n';
} else if (unesc == '\r') {
return 'r';
} else if (unesc == '\t') {
return 't';
} else if (unesc == '\v') {
return 'v';
} else if (unesc == '\\') {
return '\\';
} else if (unesc == '"') {
return '"';
} else {
assert(false);
}
}
/* Escapes srcp into a malloc'ed dstpp.
Returns 0 or errno. */
static int escape_str(char* srcp, char** dstpp) {
size_t src_len = strlen(srcp);
size_t src_size = src_len + 1;
/* dst will be worst-case twice as large (every byte becomes two bytes),
so start there, then shrink to fit at the end. */
size_t dst_size = src_size * 2;
char* dstp = malloc(dst_size);
if (dstp == NULL) {
int err = errno;
errno = 0;
return err;
}
char* src_cursor = srcp;
char* src_last = srcp + src_len - 1;
char* dst_cursor = dstp;
size_t dst_len = 0;
while(src_cursor <= src_last) {
char ch = *src_cursor;
if (is_unescaped(ch)) {
*dst_cursor = '\\';
dst_cursor++;
*dst_cursor = escape_char(ch);
} else {
*dst_cursor = ch;
}
src_cursor++;
dst_cursor++;
dst_len++;
}
/* shrink-to-fit. */
size_t newdst_size = dst_len + 1;
char* newdstp = realloc(dstp, newdst_size);
if (newdstp == NULL) {
free(dstp);
int err = errno;
errno = 0;
return err;
} else {
dstp = newdstp;
}
*dstpp = dstp;
return 0;
}
/* Prints the CString in csp into fp.
Returns 0 or errno. */
static int print_cstring(CString* csp, FILE* fp) {
char* esc;
int err = escape_str(csp->valuep, &esc);
if (err) {
return err;
}
err = fprintf(fp, "\"%s\"", esc);
if (err < 0) {
return err;
} else {
return 0;
}
}
/* Prints the List in lp into fp.
Returns 0 or errno. */
static int print_list(List* lp, FILE* fp) {
int err = fputs("(", fp);
if (err == EOF) {
err = errno;
errno = 0;
return err;
}
List* i = lp;
while (!is_list_empty(i)) {
if (i != lp) {
err = fputs(" ", fp);
if (err == EOF) {
err = errno;
errno = 0;
return err;
}
}
err = print_form(i->datap, fp);
if (err) {
return err;
}
i = i->nextp;
}
err = fputs(")", fp);
if (err == EOF) {
err = errno;
errno = 0;
return err;
}
return 0;
}
/* Prints the CBool in cbp into fp.
Returns 0 or errno. */
static int print_cbool(CBool* cbp, FILE* fp) {
int err;
if (cbp == g_true) {
err = fputs("true", fp);
} else if (cbp == g_false) {
err = fputs("false", fp);
} else {
assert(false);
}
if (err == EOF) {
err = errno;
errno = 0;
return err;
}
return 0;
}
/* Prints nil into fp.
Returns 0 or errno. */
static int print_nil(FILE* fp) {
int err = fputs("nil", fp);
if (err == EOF) {
err = errno;
errno = 0;
return err;
}
return 0;
}
/* Prints the CFunc in cfp into fp.
Returns 0 or errno. */
static int print_cfunc(CFunc* cfp, FILE* fp) {
int err = fprintf(fp, "<C function @%p>", cfp->f);
if (err < 0) {
return err;
} else {
return 0;
}
}
/* Prints the Form in formp into fp.
Returns 0 or errno. */
int print_form(Form* formp, FILE* fp) {
if (is_symbol(formp)) {
Symbol* symp = (Symbol*)formp;
return print_symbol(symp, fp);
} else if (is_clong(formp)) {
CLong* lp = (CLong*)formp;
return print_clong(lp, fp);
} else if (is_cdouble(formp)) {
CDouble* dp = (CDouble*)formp;
return print_cdouble(dp, fp);
} else if (is_cstring(formp)) {
CString* csp = (CString*)formp;
return print_cstring(csp, fp);
} else if (is_list(formp)) {
List* lp = (List*)formp;
return print_list(lp, fp);
} else if (is_cbool(formp)) {
CBool* cbp = (CBool*)formp;
return print_cbool(cbp, fp);
} else if (is_nil(formp)) {
return print_nil(fp);
} else if (is_cfunc(formp)) {
CFunc* cfp = (CFunc*)formp;
return print_cfunc(cfp, fp);
} else {
assert(false);
}
}
/* This file is Copyright (C) 2019 Jason Pepas. */
/* This file is released under the terms of the MIT License. */
/* See https://opensource.org/licenses/MIT */
#ifndef _PRINT_H_
#define _PRINT_H_
#include "forms.h"
#include <stdio.h>
int print_form(Form* formp, FILE* fp);
#endif
/* This file is Copyright (C) 2019 Jason Pepas. */
/* This file is released under the terms of the MIT License. */
/* See https://opensource.org/licenses/MIT */
#include "reader.h"
#include "errors.h"
#include <stdlib.h>
#include <sys/errno.h>
#include <assert.h>
#include <stdbool.h>
#include <ctype.h>
#include <string.h>
#include <stdio.h>
/* Creates a new FBuff.
Returns 0 or errno. */
int new_fbuff(FBuff** fbpp, FILE* fp) {
FBuff* fbp = malloc(sizeof(FBuff));
if (fbp == NULL) {
int err = errno;
errno = 0;
return err;
}
fbp->fp = fp;
fbp->buffp = NULL;
fbp->nextp = NULL;
fbp->size = 0;
fbp->len = 0;
*fbpp = fbp;
return 0;
}
/* Frees fbp. */
void free_fbuff(FBuff* fbp) {
free(fbp->buffp);
free(fbp);
}
/* Reads the next line into fbp.
Returns 0, EOF, or errno. */
static int fbuff_getline(FBuff* fbp) {
ssize_t result = getline(&(fbp->buffp), &(fbp->size), fbp->fp);
if (result == -1) {
if (feof(fbp->fp)) {
return EOF;
} else {
result = errno;
errno = 0;
return result;
}
} else {
fbp->len = result;
fbp->nextp = fbp->buffp;
return 0;
}
}
/* Is fbp at the end of the current line? */
bool is_fbuff_eol(FBuff* fbp) {
return fbp->len == 0 || fbp->nextp == fbp->buffp + fbp->len;
}
/* Reads and consumes the next character into chp from fbp.
Returns 0, EOF, or errno. */
static int fbuff_getch(FBuff* fbp, char* chp) {
if (is_fbuff_eol(fbp)) {
int err = fbuff_getline(fbp);
if (err) {
return err;
}
}
char ch = *(fbp->nextp);
(fbp->nextp)++;
*chp = ch;
return 0;
}
/* Pushes ch back into fbp.
Asserts if used incorrectly. */
static void fbuff_ungetch(FBuff* fbp, char ch) {
assert(fbp->nextp > fbp->buffp);
fbp->nextp--;
*(fbp->nextp) = ch;
}
/* Is ch considered whitespace?
Note: commas are considered whitespace. */
static bool is_ch_ws(char ch) {
return isspace(ch) || ch == ',';
}
/* Does ch indicate the end of a token? */
static bool is_ch_delim(char ch) {
return is_ch_ws(ch) || ch == '(' || ch == ')' || ch == ';';
}
/* Does ch constitute a token on its own? */
static bool is_ch_single_character_token(char ch) {
char* p = strchr("()", (int)ch);
return (p != NULL);
}
/* Advances fbp past any leading whitespace.
Note: commas are considered whitespace.
Returns 0, EOF, or errno. */
static int fbuff_discard_ws(FBuff* fbp, int* countp) {
int err;
char ch;
int count = 0;
while (true) {
err = fbuff_getch(fbp, &ch);
if (err) {
return err;
} else if (is_ch_ws(ch)) {
count++;
continue;
} else {
fbuff_ungetch(fbp, ch);
if (countp != NULL) {
*countp = count;
}
break;
}
}
return 0;
}
/* Advances fbp past any whitespace in the current line. */
void fbuff_skip_buffered_ws(FBuff* fbp) {
while (!is_fbuff_eol(fbp) && is_ch_ws(*(fbp->nextp))) {
fbp->nextp++;
}
}
/* Is u even? */
static bool is_even(unsigned int u) {
/* if the LSB isn't set, u is even. */
return !(u & 0x1);
}
/* Advances fbp far enough to read one token (which is a string literal).
Points buffpp to a malloc'ed buffer containing the string.
Returns 0, EOF, errno, or an error code. */
static int fbuff_get_token_str(FBuff* fbp, char** buffpp) {
int err;
char ch;
/* allocate the initial buffer. */
size_t buffsize = 1000;
size_t bufflen = buffsize - 1;
char* buffp = malloc(buffsize);
if (buffp == NULL) {
err = errno;
errno = 0;
return err;
}
char* cursor = buffp;
/* the first char must be the opening quote. */
err = fbuff_getch(fbp, &ch);
if (err) {
free(buffp);
return err;
} else {
assert(ch == '"');
*cursor = ch;
cursor++;
}
unsigned int backslash_count = 0;
while (true) {
size_t len = cursor - buffp;
/* time to grow the buffer. */
if (len == bufflen) {
buffsize *= 2;
bufflen = buffsize - 1;
char* newbuffp = realloc(buffp, buffsize);
if (newbuffp == NULL) {
free(buffp);
err = errno;
errno = 0;
return err;
} else {
buffp = newbuffp;
}
}
err = fbuff_getch(fbp, &ch);
if (err) {
free(buffp);
return err;
/* this is the end of the string. */
} else if (ch == '"' && is_even(backslash_count)) {
*cursor = ch;
cursor++;
*cursor = '\0';
/* shrink buffp to fit the size of the string. */
size_t finalbuffsize = buffp - cursor + 1;
if (finalbuffsize < buffsize) {
char* finalbuffp = realloc(buffp, finalbuffsize);
if (finalbuffp == NULL) {
free(buffp);
err = errno;
errno = 0;
return err;
} else {
buffp = finalbuffp;
}
}
break;
/* this is a regular char. */
} else {
/* track the number of consecutive backslashes so we can
disambiguate the closing quote. */
if (ch == '\\') {
backslash_count++;
} else {
backslash_count = 0;
}
*cursor = ch;
cursor++;
}
}
*buffpp = buffp;
return 0;
}
/* Advances fbp far enough to read one token of input.
Writes the token contents to *buffpp.
In the case of a string literal, points buffpp to a malloc'ed string buffer.
Returns 0, EOF, errno, or an error code. */
static int fbuff_get_token(FBuff* fbp, char** buffpp, size_t buffsize) {
int err;
char ch;
size_t bufflen = buffsize - 1;
char* cursor = *buffpp;
/* discard any leading whitespace. */
err = fbuff_discard_ws(fbp, NULL);
if (err) {
return err;
}
/* a token must be at least one char in length. */
err = fbuff_getch(fbp, &ch);
if (err) {
return err;
/* this is a string literal. */
} else if (ch == '"') {
fbuff_ungetch(fbp, ch);
return fbuff_get_token_str(fbp, buffpp);
} else {
*cursor = ch;
cursor++;
}
/* this is a single-character token. */
if (is_ch_single_character_token(ch)) {
*cursor = '\0';
/* this is a multi-character token. read the rest of the chars. */
} else {
bool is_comment = (ch == ';');
while (true) {
size_t len = cursor - *buffpp;
/* we have run out of room. */
if (len == bufflen) {
return E_file_get_token__buff_overflow;
}
err = fbuff_getch(fbp, &ch);
/* we've reached EOF. return what we have so far. */
if (err == EOF) {
*cursor = '\0';
break;
/* there was an error reading from fp. */
} else if (err != 0) {
return err;
/* we've reached the end of this regular token. */
} else if (!is_comment && is_ch_delim(ch)) {
fbuff_ungetch(fbp, ch);
*cursor = '\0';
break;
/* we've reached the end of this comment token. */
} else if (is_comment && ch == '\n') {
/* we leave the trailing '\n' to ensure the list args are
still whitespace-separated. */
fbuff_ungetch(fbp, ch);
*cursor = '\0';
break;
/* this char is part of the token. */
} else {
*cursor = ch;
cursor++;
continue;
}
}
}
return 0;
}
/* Tries to parse a long from buffp into lp.
Returns true or false. */
static bool try_parse_long(const char* buffp, long* lp) {
char* endptr;
long l = strtol(buffp, &endptr, 10);
if (errno != 0) {
errno = 0;
return false;
} else if (endptr == buffp || *endptr != '\0') {
return false;
} else {
*lp = l;
return true;
}
}
/* Tries to parse a double from buffp intp dp.
Returns true or false. */
static bool try_parse_double(const char* buffp, double* dp) {
char* endptr;
double d = strtod(buffp, &endptr);
if (errno != 0) {
errno = 0;
return false;
} else if (endptr == buffp || *endptr != '\0') {
return false;
} else {
*dp = d;
return true;
}
}
/* Is ch in the list of escapable chars? */
static bool is_escapechar(char ch) {
char* found = strchr("abefnrtv?'\"\\", (int)ch);
return found != NULL;
}
/* Returns the "unescaped" char corresponding to the given escape char.
E.g. if esc is 'n', a newline character is returned.
Asserts false if esc is not a valid escape char. */
static char unescape_char(char esc) {
if (esc == 'a') {
return '\a';
} else if (esc == 'b') {
return '\b';
} else if (esc == 'e') {
return '\e';
} else if (esc == 'f') {
return '\f';
} else if (esc == 'n') {
return '\n';
} else if (esc == 'r') {
return '\r';
} else if (esc == 't') {
return '\t';
} else if (esc == 'v') {
return '\v';
} else if (esc == '\\') {
return '\\';
} else if (esc == '\'') {
return '\'';
} else if (esc == '"') {
return '"';
} else if (esc == '?') {
return '?';
} else {
assert(false);
}
}
/* Parses a string from buffp.
*spp is malloc'ed with a copy of the parsed string.
Returns 0 or errno or error. */
static int parse_string(const char* buffp, char** spp) {
size_t src_len = strlen(buffp);
size_t src_size = src_len + 1;
/* minimum buffp is an opening and closing quote, so we know len >= 2. */
assert(src_len >= 2);
/* first and last char must be '"'. */
if (*buffp != '"') {
return E_parse_string__invalid_string_1;
}
if (*(buffp + src_len - 1) != '"') {
return E_parse_string__invalid_string_2;
}
size_t dst_size = src_size - 2;
char* dst = malloc(dst_size);
if (dst == NULL) {
int err = errno;
errno = 0;
return err;
}
/* skip the opening quote. */
const char* src_first = buffp + 1;
/* skip the closing quote. */
const char* src_last = buffp + src_len - 2;
const char* src_cursor = src_first;
char* dst_cursor = dst;
while (src_cursor <= src_last) {
/* this is possibly an escape sequence. */
if (*src_cursor == '\\') {
src_cursor++;
/* the last char of the string is a backslash, which is invalid. */
if (src_cursor > src_last) {
free(dst);
return E_parse_string__invalid_string_3;
/* this is an escape sequence. */
} else if (is_escapechar(*src_cursor)) {
*dst_cursor = unescape_char(*src_cursor);
src_cursor++;
dst_cursor++;
continue;
/* this is an invalid escape sequence. */
} else {
free(dst);
return E_parse_string__invalid_string_4;
}
/* this is just a regular char. */
} else {
*dst_cursor = *src_cursor;
src_cursor++;
dst_cursor++;
continue;
}
}
*dst_cursor = '\0';
*spp = dst;
return 0;
}
/* Read all of the forms in this Lisp list.
Returns 0 or error. */
static int read_list(FBuff* fbp, Form** formpp) {
/* note: the leading '(' has already been consumed. */
int err;
int i = 0;
int ws_count;
char ch1;
List* headp = g_emptylist;
List* tailp = g_emptylist;
while (true) {
err = fbuff_discard_ws(fbp, &ws_count);
if (err) {
/* reaching EOF before ')' is an error. */
if (err == EOF) {
return E_read_list__premature_eof_1;
} else {
return err;
}
}
err = fbuff_getch(fbp, &ch1);
if (err) {
/* reaching EOF before ')' is an error. */
if (err == EOF) {
return E_read_list__premature_eof_2;
} else {
return err;
}
/* we've reached the end of the list. */
} else if (ch1 == ')') {
*formpp = (Form*)headp;
return 0;
} else {
fbuff_ungetch(fbp, ch1);
/* no space between atoms is an error. */
if (i > 0 && ws_count == 0 && is_ch_delim(ch1) == false) {
return E_read_list__missing_ws;
}
/* read the next form in the list. */
Form* formp;
err = read_form(fbp, &formp);
if (err) {
if (err == E_read_form__comment) {
continue;
} else {
/* reaching EOF before ')' is an error. */
if (err == EOF) {
return E_read_list__premature_eof_3;
} else {
return err;
}
}
/* append the form onto the list. */
} else {
List* newp;
int err = new_list(&newp, formp);
if (err) {
return err;
}
if (headp == g_emptylist) {
headp = newp;
tailp = newp;
} else {
tailp->nextp = newp;
tailp = newp;
}
}
}
i++;
}
}
/* Read one Lisp form from fp intp formpp.
Returns 0 or E_read_form__comment or EOF or errno or error. */
int read_form(FBuff* fbp, Form** formpp) {
int err;
int buffsize = 100;
char buff[buffsize];
char* buffp = buff;
char ch1;
/* read a token. */
err = fbuff_get_token(fbp, &buffp, buffsize);
if (err) {
return err;
}
ch1 = *buffp;
/* we've reached the end of input. */
if (ch1 == '\0') {
return EOF;
/* this is a comment. */
} else if (ch1 == ';') {
return E_read_form__comment;
/* a list. */
} else if (ch1 == '(') {
return read_list(fbp, formpp);
/* a list closer at this point is a syntax error. */
} else if (ch1 == ')') {
return E_read_form__unexpected_list_closer;
/* string literal. */
} else if (ch1 == '"') {
assert(buffp != buff);
char* sp;
err = parse_string(buffp, &sp);
if (err) {
free(buffp);
return err;
}
CString* csp;
err = new_cstring(&csp, sp);
if (err) {
free(buffp);
return err;
} else {
*formpp = (Form*)csp;
return 0;
}
/* the form type can't be determined from ch1 alone. */
} else {
bool success;
/* an integer literal. */
long l;
success = try_parse_long(buffp, &l);
if (success) {
CLong* clp;
err = new_clong(&clp, l);
if (err) {
return err;
} else {
*formpp = (Form*)clp;
return 0;
}
}
/* a floating-point literal. */
double d;
success = try_parse_double(buffp, &d);
if (success) {
CDouble* cdp;
err = new_cdouble(&cdp, d);
if (err) {
return err;
} else {
*formpp = (Form*)cdp;
return 0;
}
}
/* assume anything else is a symbol. */
Symbol* symp;
err = new_symbol(&symp, buffp);
if (err) {
return err;
} else {
*formpp = (Form*)symp;
return 0;
}
}
}
/* This file is Copyright (C) 2019 Jason Pepas. */
/* This file is released under the terms of the MIT License. */
/* See https://opensource.org/licenses/MIT */
#ifndef _READ_H_
#define _READ_H_
#include "forms.h"
#include <stdio.h>
/* A line-oriented FILE* buffer. */
struct FBuff_ {
FILE* fp;
char* buffp;
size_t size;
size_t len;
char* nextp;
};
typedef struct FBuff_ FBuff;
int new_fbuff(FBuff** fbpp, FILE* fp);
void free_fbuff(FBuff* fbp);
bool is_fbuff_eol(FBuff* fbp);
void fbuff_skip_buffered_ws(FBuff* fbp);
int read_form(FBuff* fbp, Form** formpp);
#endif
/* This file is Copyright (C) 2019 Jason Pepas. */
/* This file is released under the terms of the MIT License. */
/* See https://opensource.org/licenses/MIT */
#include "repl.h"
#include "errors.h"
#include "reader.h"
#include "printer.h"
#include "eval.h"
#include <stdbool.h>
#include <sys/errno.h>
#include <stdio.h>
#include <unistd.h>
#include <assert.h>
/* Is fp a tty? */
bool is_file_tty(FILE* fp) {
int result = isatty(fileno(fp));
if (result == 0) {
errno = 0;
return false;
} else {
return true;
}
}
/* Should the REPL prompt be displayed? */
bool should_display_prompt(FBuff* fbp) {
if (!is_file_tty(fbp->fp)) {
return false;
} else {
return is_fbuff_eol(fbp);
}
}
/* Starts a read-eval-print loop.
Loops until EOF or I/O error.
Returns 0 or error. */
int repl(List* envp) {
FBuff* fbp;
int err = new_fbuff(&fbp, stdin);
if (err) {
return err;
}
while (true) {
fbuff_skip_buffered_ws(fbp);
if (should_display_prompt(fbp)) {
/* display the prompt. */
int err = fputs("> ", stdout);
if (err == EOF) {
free_fbuff(fbp);
err = errno;
errno = 0;
return err;
}
}
/* read the next Lisp form. */
Form* formp;
err = read_form(fbp, &formp);
if (err) {
if (err == EOF) {
break;
} else if (err == E_read_form__comment) {
continue;
} else {
int err2 = fprintf(stderr, "Error %d.\n", err);
if (err2 < 0) {
free_fbuff(fbp);
return err2;
}
continue;
}
}
/* evaluate the form. */
Form* resultp;
err = eval_form(formp, &resultp, envp);
if (err == E_did_not_produce_a_value) {
/* certain special-forms do not produce a value. */
continue;
} else if (err) {
int err2 = fprintf(stderr, "Error %d.\n", err);
if (err2 < 0) {
free_fbuff(fbp);
return err2;
}
continue;
}
/* print the result. */
err = print_form(resultp, stdout);
if (err) {
free_fbuff(fbp);
return err;
}
err = fputs("\n", stdout);
if (err == EOF) {
free_fbuff(fbp);
err = errno;
errno = 0;
return err;
}
/* loop. */
continue;
}
free_fbuff(fbp);
return 0;
}
/* This file is Copyright (C) 2019 Jason Pepas. */
/* This file is released under the terms of the MIT License. */
/* See https://opensource.org/licenses/MIT */
#ifndef _REPL_H_
#define _REPL_H_
#include "forms.h"
int repl(List* envp);
#endif
#!/bin/bash
set -e -o pipefail
for f in `ls test*.input`
do
base=$(basename $f .input)
echo $base
cat ${base}.input | ./lisp > /tmp/${base}.out
diff -urN ${base}.expected /tmp/${base}.out
done
echo "all tests passed"
1
1
2
3
1.200000
"foo"
"line one\nline two"
1
1 2 3
1.2
"foo"
"line one
line two"
()
(
)
(+ 1 2)
(+ 1
2)
(+ 1(+ 2))
;comment
; comment
1;comment
1 ; comment
(+ 1(+;comment
2;comment
))
42
3.141590
"Hello, world!"
nil
true
false
the-answer
pi
greeting
nil
true
false
1
2.300000
"foo"
true
nil
1
(bind a 1)
a
(bind b 2.3)
b
(bind c "foo")
c
(bind d true)
d
(bind e nil)
e
(bind f a)
f
(+ 1 1)
(bind x 2)
(+ (+ x x) (+ x x x))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment