diff options
Diffstat (limited to 'work-in-progress/liblali.c')
| -rw-r--r-- | work-in-progress/liblali.c | 1339 |
1 files changed, 0 insertions, 1339 deletions
diff --git a/work-in-progress/liblali.c b/work-in-progress/liblali.c deleted file mode 100644 index d399822..0000000 --- a/work-in-progress/liblali.c +++ /dev/null @@ -1,1339 +0,0 @@ -/* - * 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 <sys/mman.h> -#include <sys/stat.h> -#include <ctype.h> -#include <errno.h> -#include <fcntl.h> -#include <setjmp.h> -#include <stdarg.h> -#include <stdbool.h> -#include <stdio.h> -#include <stdlib.h> -#include <string.h> -#include <unistd.h> - -#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" }; - -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->closure = gcMoveObject(object->closure); - 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 '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 **closure, 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->closure = *closure; - object->params = *params; - object->body = *body; - object->env = *env; - return object; -} - -Object *newLambda(Object **closure, Object **params, Object **body, Object **env, GC_PARAM) { - return newObjectWithClosure(TYPE_LAMBDA, closure, params, body, env, GC_ROOTS); -} - -Object *newMacro(Object **closure, Object **params, Object **body, Object **env, GC_PARAM) { - return newObjectWithClosure(TYPE_MACRO, closure, 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 '\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: - case TYPE_LAMBDA: - case TYPE_MACRO: - if (readably) - fputc('(', file); - writeObject(object->car, readably, file); - while (object->cdr != nil) { - object = object->cdr; - if (object->type == TYPE_CONS) { - fputc(' ', file); - writeObject(object->car, readably, file); - } else { - fputs(" . ", file); - writeObject(object, readably, 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_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 || first->type == TYPE_LAMBDA) */ - 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); -} - -#define DEFINE_PRIMITIVE_ARITHMETIC(name, op, init) \ - 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 = object->number op rest->car->number; \ - } \ - \ - return object; \ - } \ - } - -DEFINE_PRIMITIVE_ARITHMETIC(primitiveAdd, +, 0) -DEFINE_PRIMITIVE_ARITHMETIC(primitiveSubtract, -, 0) -DEFINE_PRIMITIVE_ARITHMETIC(primitiveMultiply, *, 1) -DEFINE_PRIMITIVE_ARITHMETIC(primitiveDivide, /, 1) - -#define DEFINE_PRIMITIVE_RELATIONAL(name, op) \ - 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 = true; \ - \ - for (; result && rest->cdr != nil; rest = rest->cdr) { \ - if (rest->cdr->car->type != TYPE_NUMBER) \ - exceptionWithObject(rest->cdr->car, "is not a number"); \ - \ - result &= rest->car->number op rest->cdr->car->number; \ - } \ - \ - return result ? t : f; \ - } \ - } - -/* DEFINE_PRIMITIVE_RELATIONAL(primitiveEqual, ==) */ -DEFINE_PRIMITIVE_RELATIONAL(primitiveDifferent, !=) -DEFINE_PRIMITIVE_RELATIONAL(primitiveLess, < ) -/* DEFINE_PRIMITIVE_RELATIONAL(primitiveLessEqual, <=) */ -DEFINE_PRIMITIVE_RELATIONAL(primitiveGreater, > ) -/* DEFINE_PRIMITIVE_RELATIONAL(primitiveGreaterEqual, >=) */ - -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 */ }, - { "test", 0, -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 }, - { "+", 0, -1, primitiveAdd }, - { "-", 1, -1, primitiveSubtract }, - { "*", 0, -1, primitiveMultiply }, - { "/", 1, -1, primitiveDivide }, - /* { "=", 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, - PRIMITIVE_TEST -}; - -// 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. - */ - -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 ((*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) { - if (*args == nil) - return n; - else if ((*args)->cdr == nil) - return (*args)->car; - else { - GC_TRACE(gcObject, (*args)->car); - GC_TRACE(gcCdr, (*args)->cdr); - - evalExpr(gcObject, env, GC_ROOTS); - return evalProg(gcCdr, env, GC_ROOTS); - } -} - -Object *progs1(Object **stop, Object **body, Object **env, GC_PARAM) { - if (*body == nil) - return *stop; - else if ((*body)->cdr == nil) - return (*body)->car; - else { - GC_TRACE(gcObject, (*body)->car); - GC_TRACE(gcCdr, (*body)->cdr); - - *gcObject = evalExpr(gcObject, env, GC_ROOTS); - if (*gcObject == *stop) - return *stop; - - 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(gcClosure, (*args)->car); - GC_TRACE(gcParams, (*args)->cdr->car); - GC_TRACE(gcBody, (*args)->cdr->cdr); - - return newLambda(gcClosure, gcParams, gcBody, env, GC_ROOTS); -} - -Object *evalMacro(Object **args, Object **env, GC_PARAM) { - GC_TRACE(gcClosure, (*args)->car); - GC_TRACE(gcParams, (*args)->cdr->car); - GC_TRACE(gcBody, (*args)->cdr->cdr); - - return newMacro(gcClosure, 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(gcObject, gcEnv, GC_ROOTS); - case PRIMITIVE_MACRO: return evalMacro(gcObject, gcEnv, GC_ROOTS); - case PRIMITIVE_TEST: return *gcObject; - 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; -} |