diff options
Diffstat (limited to 'liblali.c')
| -rw-r--r-- | liblali.c | 1404 |
1 files changed, 1404 insertions, 0 deletions
diff --git a/liblali.c b/liblali.c new file mode 100644 index 0000000..e2239dd --- /dev/null +++ b/liblali.c @@ -0,0 +1,1404 @@ +/* + * lali (Lali Another Lisp Implementation) + * + * Author: Daniel Cerqueira (dan.git@lispclub.com) + * Maintainer: Daniel Cerqueira (dan.git@lispclub.com) + * Version: 0.0 + * Keywords: lali, lisp, implementation, interpreter, lisp1.5, + * computer programming language + * Homepage: https://gitlab.com/alexandre1985/lali + * SPDX-License-Identifier: GPL-3.0-or-later + * + * Copyright (C) 2025 Daniel Cerqueira + * + * This file is part of lali. + * + * lali is free software; you can redistribute it and/or modify it under + * the terms of the GNU General Public License as published by the Free Software + * Foundation; either version 3 of the License, or (at your option) any later + * version. + * + * This program is distributed in the hope that it will be useful, but WITHOUT ANY + * WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A + * PARTICULAR PURPOSE. See the GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License along with + * this program; if not, see <https://www.gnu.org/licenses/>. + * + * + * lali software is based on tiny-lisp <https://github.com/matp/tiny-lisp/> + * version from 2016, written by Matthias Pirstitz, which is released to public + * domain under Unlicense <https://unlicense.org/>. + */ + + +#include "liblali.h" + +#define MEMORY_SIZE 3000000UL + +static Memory *memory = &(Memory){ MEMORY_SIZE }; + +Object *symbols = NULL; +Object *nil = &(Object){ TYPE_SYMBOL, .string = "()" }; +Object *n = &(Object){ TYPE_SYMBOL, .string = "n" }; +Object *t = &(Object){ TYPE_SYMBOL, .string = "t" }; +Object *f = &(Object){ TYPE_SYMBOL, .string = "f" }; + +static unsigned int seed = 1; + +jmp_buf exceptionEnv; + + +// EXCEPTION HANDLING ///////////////////////////////////////////////////////// + +void exceptionWithObject(Object *object, char *format, ...) { + fputs("error: ", stderr); + + if (object) { + writeObject(object, true, stderr); + fputc(' ', stderr); + } + + va_list args; + va_start(args, format); + vfprintf(stderr, format, args); + va_end(args); + fputc('\n', stderr); + + longjmp(exceptionEnv, 1); +} + +// GARBAGE COLLECTION ///////////////////////////////////////////////////////// + +/* This implements Cheney's copying garbage collector, with which memory is + * divided into two equal halves (semispaces): from- and to-space. From-space + * is where new objects are allocated, whereas to-space is used during garbage + * collection. + * + * When garbage collection is performed, objects that are still in use (live) + * are copied from from-space to to-space. To-space then becomes the new + * from-space and vice versa, thereby discarding all objects that have not + * been copied. + * + * Our garbage collector takes as input a list of root objects. Objects that + * can be reached by recursively traversing this list are considered live and + * will be moved to to-space. When we move an object, we must also update its + * pointer within the list to point to the objects new location in memory. + * + * However, this implies that our interpreter cannot use raw pointers to + * objects in any function that might trigger garbage collection (or risk + * causing a SEGV when accessing an object that has been moved). Instead, + * objects must be added to the list and then only accessed through the + * pointer inside the list. + * + * Thus, whenever we would have used a raw pointer to an object, we use a + * pointer to the pointer inside the list instead: + * + * function: pointer to pointer inside list (Object **) + * | + * v + * list of root objects: pointer to object (Object *) + * | + * v + * semispace: object in memory + * + * GC_ROOTS and GC_PARAM are used to pass the list from function to function. + * + * GC_TRACE adds an object to the list and declares a variable which points to + * the objects pointer inside the list. + * + * GC_TRACE(gcX, X): add object X to the list and declare Object **gcX + * to point to the pointer to X inside the list. + */ + +Object *gcMoveObject(Object *object) { + // skip object if it is not within from-space (i.e. on the stack) + if (object < (Object *)memory->fromSpace + || object >= (Object *)((char *)memory->fromSpace + memory->fromOffset)) + return object; + + // if the object has already been moved, return its new location + if (object->type == (Type)-1) + return object->forward; + + // copy object to to-space + Object *forward = (Object *)((char *)memory->toSpace + memory->toOffset); + memcpy(forward, object, object->size); + memory->toOffset += object->size; + + // mark object as moved and set forwarding pointer + object->type = (Type)-1; + object->forward = forward; + + return object->forward; +} + +void gc(GC_PARAM) { + memory->toOffset = 0; + + // move symbols and root objects + symbols = gcMoveObject(symbols); + + for (Object *object = GC_ROOTS; object != nil; object = object->cdr) + object->car = gcMoveObject(object->car); + + // iterate over objects in to-space and move all objects they reference + for (Object *object = memory->toSpace; + object < (Object *)((char *)memory->toSpace + memory->toOffset); + object = (Object *)((char *)object + object->size)) { + + switch (object->type) { + case TYPE_NUMBER: + case TYPE_STRING: + case TYPE_SYMBOL: + case TYPE_PRIMITIVE: + break; + case TYPE_CONS: + object->car = gcMoveObject(object->car); + object->cdr = gcMoveObject(object->cdr); + break; + case TYPE_LAMBDA: + case TYPE_MACRO: + object->params = gcMoveObject(object->params); + object->body = gcMoveObject(object->body); + object->env = gcMoveObject(object->env); + break; + case TYPE_ENV: + object->parent = gcMoveObject(object->parent); + object->vars = gcMoveObject(object->vars); + object->vals = gcMoveObject(object->vals); + break; + } + } + + // swap from- and to-space + void *swap = memory->fromSpace; + memory->fromSpace = memory->toSpace; + memory->toSpace = swap; + memory->fromOffset = memory->toOffset; +} + +// MEMORY MANAGEMENT ////////////////////////////////////////////////////////// + +size_t memoryAlign(size_t size, size_t alignment) { + return (size + alignment - 1) & ~(alignment - 1); +} + +Object *memoryAllocObject(Type type, size_t size, GC_PARAM) { + size = memoryAlign(size, sizeof (void *)); + + // allocate from- and to-space + if (!memory->fromSpace) { + if (!(memory->fromSpace = mmap(NULL, memory->capacity * 2, + PROT_READ | PROT_WRITE, MAP_PRIVATE | MAP_ANONYMOUS, -1, 0))) + exception("mmap() failed, %s", strerror(errno)); + + memory->toSpace = (char *)memory->fromSpace + memory->capacity; + } + + // run garbage collection if capacity exceeded + if (memory->fromOffset + size >= memory->capacity) + gc(GC_ROOTS); + if (memory->fromOffset + size >= memory->capacity) + exception("out of memory, %lu bytes", (unsigned long)size); + + // allocate object in from-space + Object *object = (Object *)((char *)memory->fromSpace + memory->fromOffset); + object->type = type; + object->size = size; + memory->fromOffset += size; + + return object; +} + +// CONSTRUCTING OBJECTS /////////////////////////////////////////////////////// + +Object *newObject(Type type, GC_PARAM) { + return memoryAllocObject(type, sizeof (Object), GC_ROOTS); +} + +Object *newObjectFrom(Object **from, GC_PARAM) { + Object *object = memoryAllocObject((*from)->type, (*from)->size, GC_ROOTS); + memcpy(object, *from, (*from)->size); + return object; +} + +Object *newNumber(double number, GC_PARAM) { + Object *object = newObject(TYPE_NUMBER, GC_ROOTS); + object->number = number; + return object; +} + +Object *newObjectWithString(Type type, size_t size, GC_PARAM) { + size = (size > sizeof (((Object *)NULL)->string)) + ? size - sizeof (((Object *)NULL)->string) + : 0; + return memoryAllocObject(type, sizeof (Object) + size, GC_ROOTS); +} + +Object *newStringWithLength(char *string, size_t length, GC_PARAM) { + int nEscapes = 0; + + for (int i = 1; i < length; ++i) + if (string[i - 1] == '\\' && strchr("\\\"trn", string[i])) + ++i, ++nEscapes; + + Object *object = newObjectWithString(TYPE_STRING, + length - nEscapes + 1, GC_ROOTS); + + for (int r = 1, w = 0; r <= length; ++r) { + if (string[r - 1] == '\\' && r < length) { + switch (string[r]) { + case '\\': object->string[w++] = '\\'; r++; break; + case '"': object->string[w++] = '"'; r++; break; + case 't': object->string[w++] = '\t'; r++; break; + case 'r': object->string[w++] = '\r'; r++; break; + case 'b': object->string[w++] = '\b'; r++; break; + case 'n': object->string[w++] = '\n'; r++; break; + default: object->string[w++] = '\\'; break; + } + } else + object->string[w++] = string[r - 1]; + } + + object->string[length - nEscapes] = '\0'; + return object; +} + +Object *newString(char *string, GC_PARAM) { + return newStringWithLength(string, strlen(string), GC_ROOTS); +} + +Object *newCons(Object **car, Object **cdr, GC_PARAM) { + Object *object = newObject(TYPE_CONS, GC_ROOTS); + object->car = *car; + object->cdr = *cdr; + return object; +} + +Object *newSymbolWithLength(char *string, size_t length, GC_PARAM) { + for (Object *object = symbols; object != nil; object = object->cdr) + if (memcmp(object->car->string, string, length) == 0 + && object->car->string[length] == '\0') + return object->car; + + GC_TRACE(gcObject, newObjectWithString(TYPE_SYMBOL, length + 1, GC_ROOTS)); + memcpy((*gcObject)->string, string, length); + (*gcObject)->string[length] = '\0'; + + symbols = newCons(gcObject, &symbols, GC_ROOTS); + + return *gcObject; +} + +Object *newSymbol(char *string, GC_PARAM) { + return newSymbolWithLength(string, strlen(string), GC_ROOTS); +} + +Object *newObjectWithClosure(Type type, Object **params, Object **body, Object **env, GC_PARAM) { + Object *list; + + for (list = *params; list->type == TYPE_CONS; list = list->cdr) { + if (list->car->type != TYPE_SYMBOL) + exceptionWithObject(list->car, "is not a symbol"); + if (list->car == nil || list->car == n || list->car == t || list->car == f) + exceptionWithObject(list->car, "cannot be used as a parameter"); + } + + if (list != nil && list->type != TYPE_SYMBOL) + exceptionWithObject(list, "is not a symbol"); + + Object *object = newObject(type, GC_ROOTS); + + object->params = *params; + object->body = *body; + object->env = *env; + return object; +} + +Object *newLambda(Object **params, Object **body, Object **env, GC_PARAM) { + return newObjectWithClosure(TYPE_LAMBDA, params, body, env, GC_ROOTS); +} + +Object *newMacro(Object **params, Object **body, Object **env, GC_PARAM) { + return newObjectWithClosure(TYPE_MACRO, params, body, env, GC_ROOTS); +} + +Object *newPrimitive(int primitive, char *name, GC_PARAM) { + Object *object = newObject(TYPE_PRIMITIVE, GC_ROOTS); + object->primitive = primitive; + object->name = name; + return object; +} + +Object *newEnv(Object **func, Object **vals, GC_PARAM) { + Object *object = newObject(TYPE_ENV, GC_ROOTS); + + if ((*func) == nil) + object->parent = object->vars = object->vals = nil; + else { + Object *param = (*func)->params, *val = *vals; + + for (int nArgs = 0;; param = param->cdr, val = val->cdr, ++nArgs) { + if (param == nil && val == nil) + break; + else if (param != nil && param->type == TYPE_SYMBOL) + break; + else if (val != nil && val->type != TYPE_CONS) + exceptionWithObject(val, "is not a list"); + else if (param == nil && val != nil) + exceptionWithObject(*func, "expects at most %d arguments", nArgs); + else if (param != nil && val == nil) { + for (; param->type == TYPE_CONS; param = param->cdr, ++nArgs); + exceptionWithObject(*func, "expects at least %d arguments", nArgs); + } + } + + object->parent = (*func)->env; + object->vars = (*func)->params; + object->vals = *vals; + } + + return object; +} + +// STREAM INPUT /////////////////////////////////////////////////////////////// + +/* The purpose of the stream functions is to provide an abstraction over file + * and string inputs. In order to accommodate the REPL, we need to be able to + * process character special files (such as stdin) character by character and + * evaluate expressions as they are being entered. + */ + +int streamGetc(Stream *stream) { + if (stream->offset >= stream->length) { + switch (stream->type) { + case STREAM_TYPE_STRING: + // set length if a string was given but its length has not been set + if (!stream->length && stream->buffer && *stream->buffer) { + stream->length = strlen(stream->buffer); + return streamGetc(stream); + } + + return EOF; + + case STREAM_TYPE_FILE: + // if this is the first read, try to find the size of the file + if (!stream->buffer) { + struct stat st; + + if (fstat(stream->fd, &st) == -1) + exception("fstat() failed, %s", strerror(errno)); + + if (S_ISREG(st.st_mode)) { + stream->size = st.st_size; + + if (!(stream->buffer = malloc(stream->size))) + exception("out of memory, %ld bytes", (long)stream->size); + + stream->capacity = stream->size; + } else + stream->size = -1; + } + + // resize buffer to nearest multiple of BUFSIZ if capacity exceeded + if (stream->offset >= stream->capacity) { + char *buffer; + size_t capacity = stream->offset + ? (stream->offset / BUFSIZ + 1) * BUFSIZ + : BUFSIZ; + + if (!(buffer = realloc(stream->buffer, capacity))) + exception("out of memory, %ld bytes", (long)capacity); + + stream->buffer = buffer; + stream->capacity = capacity; + } + + // read until offset reached + while (stream->length <= stream->offset) { + ssize_t nbytes = read(stream->fd, stream->buffer + stream->length, + stream->capacity - stream->length); + + if (nbytes > 0) + stream->length += nbytes; + else if (nbytes < 0 && errno != EINTR) + exception("read() failed, %s", strerror(errno)); + + if (nbytes == 0 || stream->length == stream->size) { + stream->type = STREAM_TYPE_STRING; + return streamGetc(stream); + } + } + + break; + } + } + + return (unsigned char)stream->buffer[stream->offset++]; +} + +Stream *streamSeek(Stream *stream, int offset) { + if (offset < 0 && -offset >= stream->offset) + stream->offset = 0; + else + stream->offset += offset; + return stream; +} + +int streamPeek(Stream *stream) { + int ch = streamGetc(stream); + if (ch != EOF) + streamSeek(stream, -1); + return ch; +} + +// READING S-EXPRESSIONS ////////////////////////////////////////////////////// + +int readNext(Stream *stream) { + for (;;) { + int ch = streamGetc(stream); + if (ch == ';') + while ((ch = streamGetc(stream)) != EOF && ch != '\n'); + if (isspace(ch)) + continue; + return ch; + } +} + +int initialReadNext(Stream *stream) { + for (;;) { + int ch = streamGetc(stream); + if (ch == ';' || ch == '#') + while ((ch = streamGetc(stream)) != EOF && ch != '\n'); + if (isspace(ch)) + continue; + return ch; + } +} + +int peekForward(Stream *stream, bool shebang) { + int ch = (shebang) ? initialReadNext(stream) : readNext(stream); + if (ch != EOF) + streamSeek(stream, -1); + return ch; +} + +int peekNext(Stream *stream) { + return peekForward(stream, false); +} + +int readWhile(Stream *stream, int (*predicate)(int ch)) { + for (;;) { + int ch = streamPeek(stream); + if (!predicate(ch)) + return ch; + streamGetc(stream); + } +} + +Object *readUnary(Stream *stream, char *symbol, GC_PARAM) { + if (peekNext(stream) == EOF) + exception("unexpected end of stream in %s", symbol); + + GC_TRACE(gcSymbol, newSymbol(symbol, GC_ROOTS)); + GC_TRACE(gcObject, readExpr(stream, GC_ROOTS)); + + *gcObject = newCons(gcObject, &nil, GC_ROOTS); + *gcObject = newCons(gcSymbol, gcObject, GC_ROOTS); + + return *gcObject; +} + +Object *readString(Stream *stream, GC_PARAM) { + size_t offset = stream->offset; + + for (bool isEscaped = false;;) { + int ch = streamGetc(stream); + if (ch == EOF) + exception("unexpected end of stream in string literal \"%.*s\"", + (int)(stream->offset - offset), stream->buffer + offset); + if (ch == '"' && !isEscaped) + return newStringWithLength(stream->buffer + offset, + stream->offset - offset - 1, GC_ROOTS); + + isEscaped = (ch == '\\' && !isEscaped); + } +} + +int isSymbolChar(int ch) { + static const char *valid = "!#$%&*+-./:<=>?@^_~"; + return isalnum(ch) || strchr(valid, ch); +} + +Object *readNumberOrSymbol(Stream *stream, GC_PARAM) { + size_t offset = stream->offset; + int ch = streamPeek(stream); + + // skip optional leading sign + if (ch == '+' || ch == '-') { + streamGetc(stream); + ch = streamPeek(stream); + } + + // try to read a number in integer or decimal format + if (ch == '.' || isdigit(ch)) { + if (isdigit(ch)) + ch = readWhile(stream, isdigit); + if (!isSymbolChar(ch)) + return newNumber(strtol(stream->buffer + offset, NULL, 10), GC_ROOTS); + if (ch == '.') { + ch = streamGetc(stream); + if (isdigit(streamPeek(stream))) { + ch = readWhile(stream, isdigit); + if (!isSymbolChar(ch)) + return newNumber(strtod(stream->buffer + offset, NULL), GC_ROOTS); + } + } + } + + // non-numeric character encountered, read a symbol + readWhile(stream, isSymbolChar); + return newSymbolWithLength(stream->buffer + offset, + stream->offset - offset, GC_ROOTS); +} + +Object *reverseList(Object *list) { + Object *object = nil; + + while (list != nil) { + Object *swap = list; + list = list->cdr; + swap->cdr = object; + object = swap; + } + + return object; +} + +Object *readList(Stream *stream, GC_PARAM) { + GC_TRACE(gcList, nil); + GC_TRACE(gcLast, nil); + + for (;;) { + int ch = readNext(stream); + if (ch == EOF) + exception("unexpected end of stream in list"); + else if (ch == ')') + return reverseList(*gcList); + else if (ch == '.' && !isSymbolChar(streamPeek(stream))) { + if (*gcLast == nil) + exception("unexpected dot at start of list"); + if ((ch = peekNext(stream)) == ')') + exception("expected object at end of dotted list"); + if (!(*gcLast = readExpr(stream, GC_ROOTS))) + exception("unexpected end of stream in dotted list"); + if ((ch = peekNext(stream)) != ')') + exception("unexpected object at end of dotted list"); + + readNext(stream); + Object *list = reverseList(*gcList); + (*gcList)->cdr = *gcLast; + + return list; + } else { + *gcLast = readExpr(streamSeek(stream, -1), GC_ROOTS); + *gcList = newCons(gcLast, gcList, GC_ROOTS); + } + } +} + +Object *readExpr(Stream *stream, GC_PARAM) { + for (;;) { + int ch = readNext(stream); + if (ch == EOF) + return NULL; + else if (ch == '\'') + return readUnary(stream, "quote", GC_ROOTS); + else if (ch == '\\') + return readUnary(stream, "say", GC_ROOTS); + else if (ch == '"') + return readString(stream, GC_ROOTS); + else if (ch == '(') + return readList(stream, GC_ROOTS); + else if (isSymbolChar(ch) + && (ch != '.' || isSymbolChar(streamPeek(stream)))) + return readNumberOrSymbol(streamSeek(stream, -1), GC_ROOTS); + else + exception("unexpected character, `%c'", ch); + } +} + +// WRITING OBJECTS //////////////////////////////////////////////////////////// + +void writeObject(Object *object, bool readably, FILE *file) { + switch (object->type) { +#define CASE(type, ...) \ + case type: \ + fprintf(file, __VA_ARGS__); \ + break + CASE(TYPE_NUMBER, "%g", object->number); + CASE(TYPE_SYMBOL, "%s", object->string); + CASE(TYPE_PRIMITIVE, "#<Primitive %s>", object->name); +#undef CASE + case TYPE_STRING: + if (readably) { + fputc('"', file); + for (char *string = object->string; *string; ++string) { + switch (*string) { + case '"': fputs("\\\"", file); break; + case '\t': fputs("\\t", file); break; + case '\r': fputs("\\r", file); break; + case '\b': fputs("\\b", file); break; + case '\n': fputs("\\n", file); break; + case '\\': fputs("\\\\", file); break; + default: fputc(*string, file); break; + } + } + fputc('"', file); + } else + fprintf(file, "%s", object->string); + break; + case TYPE_CONS: + if (readably) + fputc('(', file); + writeObject(object->car, true, file); + while (object->cdr != nil) { + object = object->cdr; + if (object->type == TYPE_CONS) { + fputc(' ', file); + writeObject(object->car, true, file); + } else { + fputs(" . ", file); + writeObject(object, true, file); + break; + } + } + if (readably) + fputc(')', file); + break; +#define CASE(type, name, object) \ + case type: \ + fprintf(file, "#<%s ", name); \ + writeObject(object, readably, file); \ + fprintf(file, ">"); \ + break + CASE(TYPE_LAMBDA, "Lambda", object->params); + CASE(TYPE_MACRO, "Macro", object->params); + CASE(TYPE_ENV, "Env", object->vars); +#undef CASE + } +} + +// ENVIRONMENT //////////////////////////////////////////////////////////////// + +/* An environment consists of a pointer to its parent environment (if any) and + * two parallel lists - vars and vals. + * + * Case 1 - vars is a regular list: + * vars: (a b c), vals: (1 2 3) ; a = 1, b = 2, c = 3 + * + * Case 2 - vars is a dotted list: + * vars: (a b . c), vals: (1 2) ; a = 1, b = 2, c = nil + * vars: (a b . c), vals: (1 2 3) ; a = 1, b = 2, c = (3) + * vars: (a b . c), vals: (1 2 3 4 5) ; a = 1, b = 2, c = (3 4 5) + * + * Case 3 - vars is a symbol: + * vars: a, vals: nil ; a = nil + * vars: a, vals: (1) ; a = (1) + * vars: a, vals: (1 2 3) ; a = (1 2 3) + * + * Case 4 - vars and vals are both nil: + * vars: nil, vals: nil + */ + +Object *envLookup(Object *var, Object *env) { + for (; env != nil; env = env->parent) { + Object *vars = env->vars, *vals = env->vals; + + for (; vars->type == TYPE_CONS; vars = vars->cdr, vals = vals->cdr) + if (vars->car == var) + return vals->car; + + if (vars == var) + return vals; + } + + exceptionWithObject(var, "has no value"); +} + +Object *envAdd(Object **var, Object **val, Object **env, GC_PARAM) { + GC_TRACE(gcVars, newCons(var, &nil, GC_ROOTS)); + GC_TRACE(gcVals, newCons(val, &nil, GC_ROOTS)); + + (*gcVars)->cdr = (*env)->vars, (*env)->vars = *gcVars; + (*gcVals)->cdr = (*env)->vals, (*env)->vals = *gcVals; + + return *val; +} + +Object *envSet(Object **var, Object **val, Object **env, GC_PARAM) { + GC_TRACE(gcEnv, *env); + + for (;;) { + Object *vars = (*gcEnv)->vars, *vals = (*gcEnv)->vals; + + for (; vars->type == TYPE_CONS; vars = vars->cdr, vals = vals->cdr) { + if (vars->car == *var) + return vals->car = *val; + if (vars->cdr == *var) + return vals->cdr = *val; + } + + if ((*gcEnv)->parent == nil) + return envAdd(var, val, gcEnv, GC_ROOTS); + else + *gcEnv = (*gcEnv)->parent; + } +} + +// PRIMITIVES ///////////////////////////////////////////////////////////////// + +Object *primitiveSpace(Object **args, GC_PARAM) { + return ((*args)->car == nil) ? t : f; +} + +Object *primitiveAtom(Object **args, GC_PARAM) { + Object *first = (*args)->car; + + return (first != nil && first->type != TYPE_CONS) ? t : f; +} + +/* Object *primitiveEq(Object **args, GC_PARAM) { + * Object *first = (*args)->car, *second = (*args)->cdr->car; + * + * if (first->type == TYPE_NUMBER && second->type == TYPE_NUMBER) + * return (first->number == second->number) ? t : f; + * else if (first->type == TYPE_STRING && second->type == TYPE_STRING) + * return !strcmp(first->string, second->string) ? t : f; + * else + * return (first == second) ? t : f; + * } + */ + +Object *primitiveDif(Object **args, GC_PARAM) { + Object *first = (*args)->car, *second = (*args)->cdr->car; + + if (first->type == TYPE_NUMBER && second->type == TYPE_NUMBER) + return (first->number != second->number) ? t : f; + else if (first->type == TYPE_STRING && second->type == TYPE_STRING) + return strcmp(first->string, second->string) ? t : f; + else + return (first != second) ? t : f; +} + +Object *primitiveCar(Object **args, GC_PARAM) { + Object *first = (*args)->car; + + if (first == nil) + return nil; + else if (first->type == TYPE_CONS) + return first->car; + else + exceptionWithObject(first, "is not a list"); +} + +Object *primitiveCdr(Object **args, GC_PARAM) { + Object *first = (*args)->car; + + if (first == nil) + return nil; + else if (first->type == TYPE_CONS) + return first->cdr; + else + exceptionWithObject(first, "is not a list"); +} + +Object *primitiveCons(Object **args, GC_PARAM) { + GC_TRACE(gcFirst, (*args)->car); + GC_TRACE(gcSecond, (*args)->cdr->car); + + return newCons(gcFirst, gcSecond, GC_ROOTS); +} + +Object *primitivePrint(Object **args, GC_PARAM) { + writeObject((*args)->car, true, stdout); + fputc(' ', stdout); + return (*args)->car; +} + +Object *primitivePrinc(Object **args, GC_PARAM) { + writeObject((*args)->car, false, stdout); + fputc(' ', stdout); + return (*args)->car; +} + +Object *primitiveNewline(Object **args, GC_PARAM) { + fputc('\n', stdout); + return n; +} + +Object *primitiveRead(Object **args, GC_PARAM) { + Stream stream = { STREAM_TYPE_FILE, .fd = STDIN_FILENO }; + + fflush(stdout); + if (peekNext(&stream) == EOF) { + fputc('\n', stdout); + return n; + } + return readExpr(&stream, GC_ROOTS); +} + +Object *primitiveTime(Object **args, GC_PARAM) { + time_t secs; + struct tm *today; + + time(&secs); + today = localtime(&secs); + + GC_TRACE(gcSymbol, nil); + GC_TRACE(gcCons, nil); + + *gcSymbol = newNumber(today->tm_gmtoff, GC_ROOTS); + *gcCons = newCons(gcSymbol, gcCons, GC_ROOTS); + *gcCons = newCons(today->tm_isdst ? &t : &f, gcCons, GC_ROOTS); + + int tmp [7] = { + today->tm_wday, today->tm_year+1900, today->tm_mon+1, today->tm_mday, + today->tm_hour, today->tm_min, today->tm_sec + }; + + for (int i = 0; i < 7; i++) { + *gcSymbol = newNumber(tmp[i], GC_ROOTS); + *gcCons = newCons(gcSymbol, gcCons, GC_ROOTS); + } + + return *gcCons; +} + +Object *primitiveRandom(Object **args, GC_PARAM) { + srandom((unsigned int)(seed + time(NULL))); + double number = (double)random(); + seed = (unsigned int)number; + + if (*args == nil) + return newNumber(number, GC_ROOTS); + else + return + newNumber(((unsigned int)number % (unsigned int)(*args)->car->number), + GC_ROOTS); +} + +#define DEFINE_PRIMITIVE_ARITHMETIC(name, op, init, datatype) \ + Object *name(Object **args, GC_PARAM) { \ + if (*args == nil) \ + return newNumber(init, GC_ROOTS); \ + else if ((*args)->car->type != TYPE_NUMBER) \ + exceptionWithObject((*args)->car, "is not a number"); \ + else { \ + Object *object, *rest; \ + \ + if ((*args)->cdr == nil) { \ + object = newNumber(init, GC_ROOTS); \ + rest = *args; \ + } else { \ + GC_TRACE(gcFirst, (*args)->car); \ + object = newObjectFrom(gcFirst, GC_ROOTS); \ + rest = (*args)->cdr; \ + } \ + \ + for (; rest != nil; rest = rest->cdr) { \ + if (rest->car->type != TYPE_NUMBER) \ + exceptionWithObject(rest->car, "is not a number"); \ + \ + object->number = \ + (datatype)object->number op (datatype)rest->car->number; \ + } \ + \ + return object; \ + } \ + } + +DEFINE_PRIMITIVE_ARITHMETIC(primitiveAdd, +, 0, double) +DEFINE_PRIMITIVE_ARITHMETIC(primitiveSubtract, -, 0, double) +DEFINE_PRIMITIVE_ARITHMETIC(primitiveMultiply, *, 1, double) +DEFINE_PRIMITIVE_ARITHMETIC(primitiveDivide, /, 1, double) +DEFINE_PRIMITIVE_ARITHMETIC(primitiveRemainder, %, 1, int ) + +#define DEFINE_PRIMITIVE_RELATIONAL(name, op, until_the_end) \ + Object *name(Object **args, GC_PARAM) { \ + if ((*args)->car->type != TYPE_NUMBER) \ + exceptionWithObject((*args)->car, "is not a number"); \ + else { \ + Object *rest = *args; \ + bool result = until_the_end; \ + \ + for (; (result == until_the_end) && rest->cdr != nil; \ + rest = rest->cdr) { \ + if (rest->cdr->car->type != TYPE_NUMBER) \ + exceptionWithObject(rest->cdr->car, "is not a number"); \ + else if (until_the_end) \ + result &= rest->car->number op rest->cdr->car->number; \ + else \ + result = rest->car->number op rest->cdr->car->number; \ + } \ + return result ? t : f; \ + } \ + } + +DEFINE_PRIMITIVE_RELATIONAL(primitiveDifferent, !=, false) +/* DEFINE_PRIMITIVE_RELATIONAL(primitiveEqual, ==, true) */ +DEFINE_PRIMITIVE_RELATIONAL(primitiveLess, < , true) +/* DEFINE_PRIMITIVE_RELATIONAL(primitiveLessEqual, <=, true) */ +DEFINE_PRIMITIVE_RELATIONAL(primitiveGreater, > , true) +/* DEFINE_PRIMITIVE_RELATIONAL(primitiveGreaterEqual, >=, true) */ + +typedef struct Primitive { + char *name; + int nMinArgs, nMaxArgs; + Object *(* eval)(Object **args, GC_PARAM); +} Primitive; + +Primitive primitives[] = { + { "eval", 1, 1 /* special form */ }, + { "quote", 1, 1 /* special form */ }, + { "say", 1, 1 /* special form */ }, + { "set", 0, -2 /* special form */ }, + { "prog", 0, -1 /* special form */ }, + { "progs", 1, -1 /* special form */ }, + /* { "if", 2, 3 /\* special form *\/ }, */ + { "cond", 0, -1 /* special form */ }, + { "fill", 0, -1 /* special form */ }, + { "lambda", 1, -1 /* special form */ }, + { "macro", 1, -1 /* special form */ }, + { "space", 1, 1, primitiveSpace }, + { "atom", 1, 1, primitiveAtom }, + /* { "eq", 2, 2, primitiveEq }, */ + { "dif", 2, 2, primitiveDif }, + { "car", 1, 1, primitiveCar }, + { "cdr", 1, 1, primitiveCdr }, + { "cons", 2, 2, primitiveCons }, + { "print", 1, 1, primitivePrint }, + { "princ", 1, 1, primitivePrinc }, + { "newline", 0, 0, primitiveNewline }, + { "read", 0, 0, primitiveRead }, + { "time", 0, 0, primitiveTime }, + { "random", 0, 1, primitiveRandom }, + { "+", 0, -1, primitiveAdd }, + { "-", 1, -1, primitiveSubtract }, + { "*", 0, -1, primitiveMultiply }, + { "/", 1, -1, primitiveDivide }, + { "%", 1, -1, primitiveRemainder }, + /* { "=", 1, -1, primitiveEqual }, */ + { "!", 1, -1, primitiveDifferent }, + { "<", 1, -1, primitiveLess }, + /* { "<=", 1, -1, primitiveLessEqual }, */ + { ">", 1, -1, primitiveGreater }, + /* { ">=", 1, -1, primitiveGreaterEqual } */ +}; + +// Special forms handled by evalExpr. Must be in the same order as above. +enum { + PRIMITIVE_EVAL, + PRIMITIVE_QUOTE, + PRIMITIVE_SAY, + PRIMITIVE_SET, + PRIMITIVE_PROG, + PRIMITIVE_PROGS, + /* PRIMITIVE_IF, */ + PRIMITIVE_COND, + PRIMITIVE_FILL, + PRIMITIVE_LAMBDA, + PRIMITIVE_MACRO +}; + +// EVALUATION ///////////////////////////////////////////////////////////////// + +/* Scheme-style tail recursive evaluation. evalProg, evalProgs, evalCond, and + * PRIMITIVE_EVAL, return the object in the tail recursive position to be + * evaluated by evalExpr. Macros are expanded in-place the first time they are + * evaluated. + */ + +bool isSymbolAPrimitive(Object *symbol) { + int nPrimitives = sizeof (primitives) / sizeof (primitives[0]); + for (int i = 0; i < nPrimitives; ++i) + if (!strcmp(primitives[i].name, symbol->string)) return true; + + return false; +} + +Object *evalSet(Object **args, Object **env, GC_PARAM) { + if (*args == nil) + return n; + else { + GC_TRACE(gcVar, (*args)->car); + GC_TRACE(gcVal, (*args)->cdr->car); + + *gcVar = evalExpr(gcVar, env, GC_ROOTS); + + if (*gcVar == nil || *gcVar == n || *gcVar == t || *gcVar == f) + exceptionWithObject(*gcVar, "is a constant and cannot be set"); + else if (isSymbolAPrimitive(*gcVar)) + exceptionWithObject(*gcVar, "is a primitive name and cannot be set"); + else if ((*gcVar)->type != TYPE_SYMBOL) + exceptionWithObject(*gcVar, "is not an atom and cannot be set"); + + *gcVal = evalExpr(gcVal, env, GC_ROOTS); + envSet(gcVar, gcVal, env, GC_ROOTS); + + if ((*args)->cdr->cdr == nil) + return *gcVal; + else { + GC_TRACE(gcArgs, (*args)->cdr->cdr); + return evalSet(gcArgs, env, GC_ROOTS); + } + } +} + +Object *evalProg(Object **args, Object **env, GC_PARAM) { + GC_TRACE(gcObject, nil); + GC_TRACE(gcCdr, nil); + + for (;;) { + if (*args == nil) + return n; + else if ((*args)->cdr == nil) + return (*args)->car; + else { + *gcObject = (*args)->car; + *gcCdr = (*args)->cdr; + + evalExpr(gcObject, env, GC_ROOTS); + *args = *gcCdr; + /* return evalProg(gcCdr, env, GC_ROOTS); */ + } + } +} + +Object *progs1(Object **stop, Object **body, Object **env, GC_PARAM) { + GC_TRACE(gcObject, nil); + GC_TRACE(gcCdr, nil); + + for (;;) { + if (*body == nil) + return *stop; + else if ((*body)->cdr == nil) + return (*body)->car; + else { + /* GC_TRACE(gcEnv, *env); */ + /* GC_TRACE(gcBody, nil); */ + /* GC_TRACE(gcStop, nil); */ + + /* if ((*stop)->type == TYPE_LAMBDA) { */ + /* *gcBody = (*stop)->body; */ + /* *gcEnv = newEnv(stop, gcBody, GC_ROOTS); */ + /* *gcStop = evalExpr(gcBody, gcEnv, GC_ROOTS); */ + + /* if (*gcStop == t) */ + /* return *gcObject; */ + /* } */ + + *gcObject = (*body)->car; + *gcCdr = (*body)->cdr; + + *gcObject = evalExpr(gcObject, env, GC_ROOTS); + + if (*gcObject == *stop) + return *gcObject; + + *body = *gcCdr; + /* return progs1(stop, gcCdr, env, GC_ROOTS); */ + } + } +} + +Object *evalProgs(Object **args, Object **env, GC_PARAM) { + GC_TRACE(gcStop, (*args)->car); + GC_TRACE(gcBody, (*args)->cdr); + + *gcStop = evalExpr(gcStop, env, GC_ROOTS); + + if ((*gcStop)->type != TYPE_SYMBOL) + exceptionWithObject(*gcStop, "is not a symbol"); + + return progs1(gcStop, gcBody, env, GC_ROOTS); +} + +/* Object *evalIf(Object **args, Object **env, GC_PARAM) { + * GC_TRACE(gcObject, (*args)->car); + * + * if (evalExpr(gcObject, env, GC_ROOTS) != nil) + * return (*args)->cdr->car; + * else if ((*args)->cdr->cdr != nil) + * return (*args)->cdr->cdr->car; + * else + * return n; + * } + */ + +Object *evalCond(Object **args, Object **env, GC_PARAM) { + if (*args == nil) + return n; + else if ((*args)->car->type != TYPE_CONS) + exceptionWithObject((*args)->car, "is not a list"); + else { + GC_TRACE(gcCar, (*args)->car->car); + GC_TRACE(gcCdr, (*args)->car->cdr); + + if (*gcCdr == nil) return *gcCar; + + *gcCar = evalExpr(gcCar, env, GC_ROOTS); + if (*gcCar == n) + return n; + else if (*gcCar != f) + return evalProg(gcCdr, env, GC_ROOTS); + else { + GC_TRACE(gcArgs, (*args)->cdr); + return evalCond(gcArgs, env, GC_ROOTS); + } + } +} + +Object *evalFill(Object **args, Object **env, GC_PARAM) { + if (*args == nil) + return n; + else if ((*args)->car->type != TYPE_CONS) + exceptionWithObject((*args)->car, "is not a list"); + else { + GC_TRACE(gcCar, (*args)->car->car); + GC_TRACE(gcCdr, (*args)->car->cdr); + + if (*gcCdr == nil) return *gcCar; + + *gcCar = evalExpr(gcCar, env, GC_ROOTS); + if (*gcCar == n) + return n; + else if (*gcCar == f) + return evalProg(gcCdr, env, GC_ROOTS); + else { + GC_TRACE(gcArgs, (*args)->cdr); + return evalFill(gcArgs, env, GC_ROOTS); + } + } +} + +Object *evalLambda(Object **args, Object **env, GC_PARAM) { + GC_TRACE(gcParams, (*args)->car); + GC_TRACE(gcBody, (*args)->cdr); + + return newLambda(gcParams, gcBody, env, GC_ROOTS); +} + +Object *evalMacro(Object **args, Object **env, GC_PARAM) { + GC_TRACE(gcParams, (*args)->car); + GC_TRACE(gcBody, (*args)->cdr); + + return newMacro(gcParams, gcBody, env, GC_ROOTS); +} + +Object *expandMacro(Object **macro, Object **args, GC_PARAM) { + GC_TRACE(gcEnv, newEnv(macro, args, GC_ROOTS)); + GC_TRACE(gcBody, (*macro)->body); + + GC_TRACE(gcObject, evalProg(gcBody, gcEnv, GC_ROOTS)); + *gcObject = evalExpr(gcObject, gcEnv, GC_ROOTS); + + return *gcObject; +} + +Object *expandMacroTo(Object **macro, Object **args, Object **cons, GC_PARAM) { + GC_TRACE(gcObject, expandMacro(macro, args, GC_ROOTS)); + + if ((*gcObject)->type == TYPE_CONS) { + (*cons)->car = (*gcObject)->car; + (*cons)->cdr = (*gcObject)->cdr; + } else { + (*cons)->car = newSymbol("prog", GC_ROOTS); + (*cons)->cdr = newCons(gcObject, &nil, GC_ROOTS); + } + + return *cons; +} + +Object *evalList(Object **args, Object **env, GC_PARAM) { + if ((*args)->type != TYPE_CONS) + return evalExpr(args, env, GC_ROOTS); + else { + GC_TRACE(gcObject, (*args)->car); + GC_TRACE(gcArgs, (*args)->cdr); + + *gcObject = evalExpr(gcObject, env, GC_ROOTS); + *gcArgs = evalList(gcArgs, env, GC_ROOTS); + + return newCons(gcObject, gcArgs, GC_ROOTS); + } +} + +Object *evalExpr(Object **object, Object **env, GC_PARAM) { + GC_TRACE(gcObject, *object); + GC_TRACE(gcEnv, *env); + + GC_TRACE(gcFunc, nil); + GC_TRACE(gcArgs, nil); + GC_TRACE(gcBody, nil); + + for (;;) { + if ((*gcObject)->type == TYPE_SYMBOL) + return envLookup(*gcObject, *gcEnv); + if ((*gcObject)->type != TYPE_CONS) + return *gcObject; + + *gcFunc = (*gcObject)->car; + *gcArgs = (*gcObject)->cdr; + + *gcFunc = evalExpr(gcFunc, gcEnv, GC_ROOTS); + *gcBody = nil; + + if ((*gcFunc)->type == TYPE_LAMBDA) { + *gcBody = (*gcFunc)->body; + *gcArgs = evalList(gcArgs, gcEnv, GC_ROOTS); + *gcEnv = newEnv(gcFunc, gcArgs, GC_ROOTS); + *gcObject = evalProg(gcBody, gcEnv, GC_ROOTS); + } else if ((*gcFunc)->type == TYPE_MACRO) { + *gcObject = expandMacroTo(gcFunc, gcArgs, gcObject, GC_ROOTS); + } else if ((*gcFunc)->type == TYPE_PRIMITIVE) { + Primitive *primitive = &primitives[(*gcFunc)->primitive]; + int nArgs = 0; + + for (Object *args = *gcArgs; args != nil; args = args->cdr, nArgs++) + if (args->type != TYPE_CONS) + exceptionWithObject(args, "is not a list"); + + if (nArgs < primitive->nMinArgs) + exceptionWithObject(*gcFunc, "expects at least %d arguments", + primitive->nMinArgs); + if (nArgs > primitive->nMaxArgs && primitive->nMaxArgs >= 0) + exceptionWithObject(*gcFunc, "expects at most %d arguments", + primitive->nMaxArgs); + if (primitive->nMaxArgs < 0 && nArgs % -primitive->nMaxArgs) + exceptionWithObject(*gcFunc, "expects a multiple of %d arguments", + -primitive->nMaxArgs); + + switch ((*gcFunc)->primitive) { + case PRIMITIVE_EVAL: *gcArgs = (*gcArgs)->car; + *gcObject = evalExpr(gcArgs, gcEnv, GC_ROOTS); + break; + case PRIMITIVE_QUOTE: return (*gcArgs)->car; + case PRIMITIVE_SAY: *gcArgs = (*gcArgs)->car; + return newCons(&nil, gcArgs, GC_ROOTS); + case PRIMITIVE_SET: return evalSet(gcArgs, gcEnv, GC_ROOTS); + case PRIMITIVE_PROG: *gcObject = evalProg(gcArgs, gcEnv, GC_ROOTS); + break; + case PRIMITIVE_PROGS: *gcObject = evalProgs(gcArgs, gcEnv, GC_ROOTS); + break; + /* case PRIMITIVE_IF: *gcObject = evalIf(gcArgs, gcEnv, GC_ROOTS); + * break; + */ + case PRIMITIVE_COND: *gcObject = evalCond(gcArgs, gcEnv, GC_ROOTS); + break; + case PRIMITIVE_FILL: *gcObject = evalFill(gcArgs, gcEnv, GC_ROOTS); + break; + case PRIMITIVE_LAMBDA: return evalLambda(gcArgs, gcEnv, GC_ROOTS); + case PRIMITIVE_MACRO: return evalMacro(gcArgs, gcEnv, GC_ROOTS); + default: *gcArgs = evalList(gcArgs, gcEnv, GC_ROOTS); + return primitive->eval(gcArgs, GC_ROOTS); + } + } else + exceptionWithObject(*gcFunc, "is not a function"); + } +} + +// STANDARD LIBRARY /////////////////////////////////////////////////////////// + +#define LISP(...) #__VA_ARGS__ + +static char *stdlib = LISP( + (set (quote list) (lambda args args)) + + (set (quote defmacro) (macro (name params . body) + (list (quote set) (list quote name) (list (quote macro) params . body)))) + + (defmacro defun (name params . body) + (list (quote set) (list quote name) (list (quote lambda) params . body))) + + (defun not (x) (fill ((dif x n) n) + (x t) + (f f))) + + (defun ap (x) (not (space x))) + + (defun listp (x) (not (atom x))) + + (defun zerop (x) (not (! x 0))) + + (defmacro and args + (fill ((ap args) t) + ((ap (cdr args)) (car args)) + (f (list (quote fill) + (list (list (quote not) (car args)) + (cons (quote and) (cdr args))) + (list (quote f) (quote f)))))) + + (defun map (func xs) + (fill ((ap xs) ()) + (f (cons (func (car xs)) (map func (cdr xs)))))) + + (defmacro or args + (fill ((ap args) f) + (f (cons (quote fill) + (append (map (lambda (x) (list (list (quote not) x) x)) + args) + (list (list f f))))))) + + (defun consp (x) (and (listp x) (ap x))) + + (defun differ (x y) + (fill ((or (consp x) (consp y)) (dif x y)) + (f (or (differ (car x) (car y)) + (differ (cdr x) (cdr y)))))) + + (defun nth (num xs) + (fill ((dif num 0) (car xs)) + (f (nth (- num 1) (cdr xs))))) + + (defun append (xs y) + (fill ((ap xs) y) + (f (cons (car xs) (append (cdr xs) y))))) +); + +// MAIN /////////////////////////////////////////////////////////////////////// + +Object *newRootEnv(GC_PARAM) { + GC_TRACE(gcEnv, newEnv(&nil, &nil, GC_ROOTS)); + GC_TRACE(gcVar, nil); + GC_TRACE(gcVal, nil); + + // add constants + envSet(&nil, &nil, gcEnv, GC_ROOTS); + envSet(&n, &n, gcEnv, GC_ROOTS); + envSet(&t, &t, gcEnv, GC_ROOTS); + envSet(&f, &f, gcEnv, GC_ROOTS); + + // add primitives + int nPrimitives = sizeof (primitives) / sizeof (primitives[0]); + + for (int i = 0; i < nPrimitives; ++i) { + *gcVar = newSymbol(primitives[i].name, GC_ROOTS); + *gcVal = newPrimitive(i, primitives[i].name, GC_ROOTS); + + envSet(gcVar, gcVal, gcEnv, GC_ROOTS); + } + + // add standard library + Stream stream = { STREAM_TYPE_STRING, .buffer = stdlib }; + GC_TRACE(gcObject, nil); + + while (peekNext(&stream) != EOF) { + *gcObject = nil; + *gcObject = readExpr(&stream, GC_ROOTS); + evalExpr(gcObject, gcEnv, GC_ROOTS); + } + + return *gcEnv; +} |