下拉刷新
OneFile
源码
minilisp用 C 语言写的 Lisp 解释器。实现了整数、符号、局部变量、条件语句、宏和垃圾回收等功能
作者 Rui Ueyama·主语言 C·无依赖·9k 次查看
访问复制
// This software is in the public domain. #include <assert.h> #include <ctype.h> #include <stdarg.h> #include <stdbool.h> #include <stddef.h> #include <stdint.h> #include <stdio.h> #include <stdlib.h> #include <string.h> #include <sys/mman.h> static __attribute((noreturn)) void error(char *fmt, ...) { va_list ap; va_start(ap, fmt); vfprintf(stderr, fmt, ap); fprintf(stderr, "\n"); va_end(ap); exit(1); } //====================================================================== // Lisp objects //====================================================================== // The Lisp object type enum { // Regular objects visible from the user TINT = 1, TCELL, TSYMBOL, TPRIMITIVE, TFUNCTION, TMACRO, TENV, // The marker that indicates the object has been moved to other location by GC. The new location // can be found at the forwarding pointer. Only the functions to do garbage collection set and // handle the object of this type. Other functions will never see the object of this type. TMOVED, // Const objects. They are statically allocated and will never be managed by GC. TTRUE, TNIL, TDOT, TCPAREN, }; // Typedef for the primitive function struct Obj; typedef struct Obj *Primitive(void *root, struct Obj **env, struct Obj **args); // The object type typedef struct Obj { // The first word of the object represents the type of the object. Any code that handles object // needs to check its type first, then access the following union members. int type; // The total size of the object, including "type" field, this field, the contents, and the // padding at the end of the object. int size; // Object values. union { // Int int value; // Cell struct { struct Obj *car; struct Obj *cdr; }; // Symbol char name[1]; // Primitive Primitive *fn; // Function or Macro struct { struct Obj *params; struct Obj *body; struct Obj *env; }; // Environment frame. This is a linked list of association lists // containing the mapping from symbols to their value. struct { struct Obj *vars; struct Obj *up; }; // Forwarding pointer void *moved; }; } Obj; // Constants static Obj *True = &(Obj){ TTRUE }; static Obj *Nil = &(Obj){ TNIL }; static Obj *Dot = &(Obj){ TDOT }; static Obj *Cparen = &(Obj){ TCPAREN }; // The list containing all symbols. Such data structure is traditionally called the "obarray", but I // avoid using it as a variable name as this is not an array but a list. static Obj *Symbols; //====================================================================== // Memory management //====================================================================== // The size of the heap in byte #define MEMORY_SIZE 65536 // The pointer pointing to the beginning of the current heap static void *memory; // The pointer pointing to the beginning of the old heap static void *from_space; // The number of bytes allocated from the heap static size_t mem_nused = 0; // Flags to debug GC static bool gc_running = false; static bool debug_gc = false; static bool always_gc = false; static void gc(void *root); // Currently we are using Cheney's copying GC algorithm, with which the available memory is split // into two halves and all objects are moved from one half to another every time GC is invoked. That // means the address of the object keeps changing. If you take the address of an object and keep it // in a C variable, dereferencing it could cause SEGV because the address becomes invalid after GC // runs. // // In order to deal with that, all access from C to Lisp objects will go through two levels of // pointer dereferences. The C local variable is pointing to a pointer on the C stack, and the // pointer is pointing to the Lisp object. GC is aware of the pointers in the stack and updates // their contents with the objects' new addresses when GC happens. // // The following is a macro to reserve the area in the C stack for the pointers. The contents of // this area are considered to be GC root. // // Be careful not to bypass the two levels of pointer indirections. If you create a direct pointer // to an object, it'll cause a subtle bug. Such code would work in most cases but fails with SEGV if // GC happens during the execution of the code. Any code that allocates memory may invoke GC. #define ROOT_END ((void *)-1) #define ADD_ROOT(size) \ void *root_ADD_ROOT_[size + 2]; \ root_ADD_ROOT_[0] = root; \ for (int i = 1; i <= size; i++) \ root_ADD_ROOT_[i] = NULL; \ root_ADD_ROOT_[size + 1] = ROOT_END; \ root = root_ADD_ROOT_ #define DEFINE1(var1) \ ADD_ROOT(1); \ Obj **var1 = (Obj **)(root_ADD_ROOT_ + 1) #define DEFINE2(var1, var2) \ ADD_ROOT(2); \ Obj **var1 = (Obj **)(root_ADD_ROOT_ + 1); \ Obj **var2 = (Obj **)(root_ADD_ROOT_ + 2) #define DEFINE3(var1, var2, var3) \ ADD_ROOT(3); \ Obj **var1 = (Obj **)(root_ADD_ROOT_ + 1); \ Obj **var2 = (Obj **)(root_ADD_ROOT_ + 2); \ Obj **var3 = (Obj **)(root_ADD_ROOT_ + 3) #define DEFINE4(var1, var2, var3, var4) \ ADD_ROOT(4); \ Obj **var1 = (Obj **)(root_ADD_ROOT_ + 1); \ Obj **var2 = (Obj **)(root_ADD_ROOT_ + 2); \ Obj **var3 = (Obj **)(root_ADD_ROOT_ + 3); \ Obj **var4 = (Obj **)(root_ADD_ROOT_ + 4) // Round up the given value to a multiple of size. Size must be a power of 2. It adds size - 1 // first, then zero-ing the least significant bits to make the result a multiple of size. I know // these bit operations may look a little bit tricky, but it's efficient and thus frequently used. static inline size_t roundup(size_t var, size_t size) { return (var + size - 1) & ~(size - 1); } // Allocates memory block. This may start GC if we don't have enough memory. static Obj *alloc(void *root, int type, size_t size) { // The object must be large enough to contain a pointer for the forwarding pointer. Make it // larger if it's smaller than that. size = roundup(size, sizeof(void *)); // Add the size of the type tag and size fields. size += offsetof(Obj, value); // Round up the object size to the nearest alignment boundary, so that the next object will be // allocated at the proper alignment boundary. Currently we align the object at the same // boundary as the pointer. size = roundup(size, sizeof(void *)); // If the debug flag is on, allocate a new memory space to force all the existing objects to // move to new addresses, to invalidate the old addresses. By doing this the GC behavior becomes // more predictable and repeatable. If there's a memory bug that the C variable has a direct // reference to a Lisp object, the pointer will become invalid by this GC call. Dereferencing // that will immediately cause SEGV. if (always_gc && !gc_running) gc(root); // Otherwise, run GC only when the available memory is not large enough. if (!always_gc && MEMORY_SIZE < mem_nused + size) gc(root); // Terminate the program if we couldn't satisfy the memory request. This can happen if the // requested size was too large or the from-space was filled with too many live objects. if (MEMORY_SIZE < mem_nused + size) error("Memory exhausted"); // Allocate the object. Obj *obj = memory + mem_nused; obj->type = type; obj->size = size; mem_nused += size; return obj; } //====================================================================== // Garbage collector //====================================================================== // Cheney's algorithm uses two pointers to keep track of GC status. At first both pointers point to // the beginning of the to-space. As GC progresses, they are moved towards the end of the // to-space. The objects before "scan1" are the objects that are fully copied. The objects between // "scan1" and "scan2" have already been copied, but may contain pointers to the from-space. "scan2" // points to the beginning of the free space. static Obj *scan1; static Obj *scan2; // Moves one object from the from-space to the to-space. Returns the object's new address. If the // object has already been moved, does nothing but just returns the new address. static inline Obj *forward(Obj *obj) { // If the object's address is not in the from-space, the object is not managed by GC nor it // has already been moved to the to-space. ptrdiff_t offset = (uint8_t *)obj - (uint8_t *)from_space; if (offset < 0 || MEMORY_SIZE <= offset) return obj; // The pointer is pointing to the from-space, but the object there was a tombstone. Follow the // forwarding pointer to find the new location of the object. if (obj->type == TMOVED) return obj->moved; // Otherwise, the object has not been moved yet. Move it. Obj *newloc = scan2; memcpy(newloc, obj, obj->size); scan2 = (Obj *)((uint8_t *)scan2 + obj->size); // Put a tombstone at the location where the object used to occupy, so that the following call // of forward() can find the object's new location. obj->type = TMOVED; obj->moved = newloc; return newloc; } static void *alloc_semispace() { return mmap(NULL, MEMORY_SIZE, PROT_READ | PROT_WRITE, MAP_PRIVATE | MAP_ANON, -1, 0); } // Copies the root objects. static void forward_root_objects(void *root) { Symbols = forward(Symbols); for (void **frame = root; frame; frame = *(void ***)frame) for (int i = 1; frame[i] != ROOT_END; i++) if (frame[i]) frame[i] = forward(frame[i]); } // Implements Cheney's copying garbage collection algorithm. // http://en.wikipedia.org/wiki/Cheney%27s_algorithm static void gc(void *root) { assert(!gc_running); gc_running = true; // Allocate a new semi-space. from_space = memory; memory = alloc_semispace(); // Initialize the two pointers for GC. Initially they point to the beginning of the to-space. scan1 = scan2 = memory; // Copy the GC root objects first. This moves the pointer scan2. forward_root_objects(root); // Copy the objects referenced by the GC root objects located between scan1 and scan2. Once it's // finished, all live objects (i.e. objects reachable from the root) will have been copied to // the to-space. while (scan1 < scan2) { switch (scan1->type) { case TINT: case TSYMBOL: case TPRIMITIVE: // Any of the above types does not contain a pointer to a GC-managed object. break; case TCELL: scan1->car = forward(scan1->car); scan1->cdr = forward(scan1->cdr); break; case TFUNCTION: case TMACRO: scan1->params = forward(scan1->params); scan1->body = forward(scan1->body); scan1->env = forward(scan1->env); break; case TENV: scan1->vars = forward(scan1->vars); scan1->up = forward(scan1->up); break; default: error("Bug: copy: unknown type %d", scan1->type); } scan1 = (Obj *)((uint8_t *)scan1 + scan1->size); } // Finish up GC. munmap(from_space, MEMORY_SIZE); size_t old_nused = mem_nused; mem_nused = (size_t)((uint8_t *)scan1 - (uint8_t *)memory); if (debug_gc) fprintf(stderr, "GC: %zu bytes out of %zu bytes copied.\n", mem_nused, old_nused); gc_running = false; } //====================================================================== // Constructors //====================================================================== static Obj *make_int(void *root, int value) { Obj *r = alloc(root, TINT, sizeof(int)); r->value = value; return r; } static Obj *cons(void *root, Obj **car, Obj **cdr) { Obj *cell = alloc(root, TCELL, sizeof(Obj *) * 2); cell->car = *car; cell->cdr = *cdr; return cell; } static Obj *make_symbol(void *root, char *name) { Obj *sym = alloc(root, TSYMBOL, strlen(name) + 1); strcpy(sym->name, name); return sym; } static Obj *make_primitive(void *root, Primitive *fn) { Obj *r = alloc(root, TPRIMITIVE, sizeof(Primitive *)); r->fn = fn; return r; } static Obj *make_function(void *root, Obj **env, int type, Obj **params, Obj **body) { assert(type == TFUNCTION || type == TMACRO); Obj *r = alloc(root, type, sizeof(Obj *) * 3); r->params = *params; r->body = *body; r->env = *env; return r; } struct Obj *make_env(void *root, Obj **vars, Obj **up) { Obj *r = alloc(root, TENV, sizeof(Obj *) * 2); r->vars = *vars; r->up = *up; return r; } // Returns ((x . y) . a) static Obj *acons(void *root, Obj **x, Obj **y, Obj **a) { DEFINE1(cell); *cell = cons(root, x, y); return cons(root, cell, a); } //====================================================================== // Parser // // This is a hand-written recursive-descendent parser. //====================================================================== #define SYMBOL_MAX_LEN 200 const char symbol_chars[] = "~!@#$%^&*-_=+:/?<>"; static Obj *read_expr(void *root); static int peek(void) { int c = getchar(); ungetc(c, stdin); return c; } // Destructively reverses the given list. static Obj *reverse(Obj *p) { Obj *ret = Nil; while (p != Nil) { Obj *head = p; p = p->cdr; head->cdr = ret; ret = head; } return ret; } // Skips the input until newline is found. Newline is one of \r, \r\n or \n. static void skip_line(void) { for (;;) { int c = getchar(); if (c == EOF || c == '\n') return; if (c == '\r') { if (peek() == '\n') getchar(); return; } } } // Reads a list. Note that '(' has already been read. static Obj *read_list(void *root) { DEFINE3(obj, head, last); *head = Nil; for (;;) { *obj = read_expr(root); if (!*obj) error("Unclosed parenthesis"); if (*obj == Cparen) return reverse(*head); if (*obj == Dot) { *last = read_expr(root); if (read_expr(root) != Cparen) error("Closed parenthesis expected after dot"); Obj *ret = reverse(*head); (*head)->cdr = *last; return ret; } *head = cons(root, obj, head); } } // May create a new symbol. If there's a symbol with the same name, it will not create a new symbol // but return the existing one. static Obj *intern(void *root, char *name) { for (Obj *p = Symbols; p != Nil; p = p->cdr) if (strcmp(name, p->car->name) == 0) return p->car; DEFINE1(sym); *sym = make_symbol(root, name); Symbols = cons(root, sym, &Symbols); return *sym; } // Reader marcro ' (single quote). It reads an expression and returns (quote <expr>). static Obj *read_quote(void *root) { DEFINE2(sym, tmp); *sym = intern(root, "quote"); *tmp = read_expr(root); *tmp = cons(root, tmp, &Nil); *tmp = cons(root, sym, tmp); return *tmp; } static int read_number(int val) { while (isdigit(peek())) val = val * 10 + (getchar() - '0'); return val; } static Obj *read_symbol(void *root, char c) { char buf[SYMBOL_MAX_LEN + 1]; buf[0] = c; int len = 1; while (isalnum(peek()) || strchr(symbol_chars, peek())) { if (SYMBOL_MAX_LEN <= len) error("Symbol name too long"); buf[len++] = getchar(); } buf[len] = '\0'; return intern(root, buf); } static Obj *read_expr(void *root) { for (;;) { int c = getchar(); if (c == ' ' || c == '\n' || c == '\r' || c == '\t') continue; if (c == EOF) return NULL; if (c == ';') { skip_line(); continue; } if (c == '(') return read_list(root); if (c == ')') return Cparen; if (c == '.') return Dot; if (c == '\'') return read_quote(root); if (isdigit(c)) return make_int(root, read_number(c - '0')); if (c == '-' && isdigit(peek())) return make_int(root, -read_number(0)); if (isalpha(c) || strchr(symbol_chars, c)) return read_symbol(root, c); error("Don't know how to handle %c", c); } } // Prints the given object. static void print(Obj *obj) { switch (obj->type) { case TCELL: printf("("); for (;;) { print(obj->car); if (obj->cdr == Nil) break; if (obj->cdr->type != TCELL) { printf(" . "); print(obj->cdr); break; } printf(" "); obj = obj->cdr; } printf(")"); return; #define CASE(type, ...) \ case type: \ printf(__VA_ARGS__); \ return CASE(TINT, "%d", obj->value); CASE(TSYMBOL, "%s", obj->name); CASE(TPRIMITIVE, "<primitive>"); CASE(TFUNCTION, "<function>"); CASE(TMACRO, "<macro>"); CASE(TMOVED, "<moved>"); CASE(TTRUE, "t"); CASE(TNIL, "()"); #undef CASE default: error("Bug: print: Unknown tag type: %d", obj->type); } } // Returns the length of the given list. -1 if it's not a proper list. static int length(Obj *list) { int len = 0; for (; list->type == TCELL; list = list->cdr) len++; return list == Nil ? len : -1; } //====================================================================== // Evaluator //====================================================================== static Obj *eval(void *root, Obj **env, Obj **obj); static void add_variable(void *root, Obj **env, Obj **sym, Obj **val) { DEFINE2(vars, tmp); *vars = (*env)->vars; *tmp = acons(root, sym, val, vars); (*env)->vars = *tmp; } // Returns a newly created environment frame. static Obj *push_env(void *root, Obj **env, Obj **vars, Obj **vals) { DEFINE3(map, sym, val); *map = Nil; for (; (*vars)->type == TCELL; *vars = (*vars)->cdr, *vals = (*vals)->cdr) { if ((*vals)->type != TCELL) error("Cannot apply function: number of argument does not match"); *sym = (*vars)->car; *val = (*vals)->car; *map = acons(root, sym, val, map); } if (*vars != Nil) *map = acons(root, vars, vals, map); return make_env(root, map, env); } // Evaluates the list elements from head and returns the last return value. static Obj *progn(void *root, Obj **env, Obj **list) { DEFINE2(lp, r); for (*lp = *list; *lp != Nil; *lp = (*lp)->cdr) { *r = (*lp)->car; *r = eval(root, env, r); } return *r; } // Evaluates all the list elements and returns their return values as a new list. static Obj *eval_list(void *root, Obj **env, Obj **list) { DEFINE4(head, lp, expr, result); *head = Nil; for (lp = list; *lp != Nil; *lp = (*lp)->cdr) { *expr = (*lp)->car; *result = eval(root, env, expr); *head = cons(root, result, head); } return reverse(*head); } static bool is_list(Obj *obj) { return obj == Nil || obj->type == TCELL; } static Obj *apply_func(void *root, Obj **env, Obj **fn, Obj **args) { DEFINE3(params, newenv, body); *params = (*fn)->params; *newenv = (*fn)->env; *newenv = push_env(root, newenv, params, args); *body = (*fn)->body; return progn(root, newenv, body); } // Apply fn with args. static Obj *apply(void *root, Obj **env, Obj **fn, Obj **args) { if (!is_list(*args)) error("argument must be a list"); if ((*fn)->type == TPRIMITIVE) return (*fn)->fn(root, env, args); if ((*fn)->type == TFUNCTION) { DEFINE1(eargs); *eargs = eval_list(root, env, args); return apply_func(root, env, fn, eargs); } error("not supported"); } // Searches for a variable by symbol. Returns null if not found. static Obj *find(Obj **env, Obj *sym) { for (Obj *p = *env; p != Nil; p = p->up) { for (Obj *cell = p->vars; cell != Nil; cell = cell->cdr) { Obj *bind = cell->car; if (sym == bind->car) return bind; } } return NULL; } // Expands the given macro application form. static Obj *macroexpand(void *root, Obj **env, Obj **obj) { if ((*obj)->type != TCELL || (*obj)->car->type != TSYMBOL) return *obj; DEFINE3(bind, macro, args); *bind = find(env, (*obj)->car); if (!*bind || (*bind)->cdr->type != TMACRO) return *obj; *macro = (*bind)->cdr; *args = (*obj)->cdr; return apply_func(root, env, macro, args); } // Evaluates the S expression. static Obj *eval(void *root, Obj **env, Obj **obj) { switch ((*obj)->type) { case TINT: case TPRIMITIVE: case TFUNCTION: case TTRUE: case TNIL: // Self-evaluating objects return *obj; case TSYMBOL: { // Variable Obj *bind = find(env, *obj); if (!bind) error("Undefined symbol: %s", (*obj)->name); return bind->cdr; } case TCELL: { // Function application form DEFINE3(fn, expanded, args); *expanded = macroexpand(root, env, obj); if (*expanded != *obj) return eval(root, env, expanded); *fn = (*obj)->car; *fn = eval(root, env, fn); *args = (*obj)->cdr; if ((*fn)->type != TPRIMITIVE && (*fn)->type != TFUNCTION) error("The head of a list must be a function"); return apply(root, env, fn, args); } default: error("Bug: eval: Unknown tag type: %d", (*obj)->type); } } //====================================================================== // Primitive functions and special forms //====================================================================== // 'expr static Obj *prim_quote(void *root, Obj **env, Obj **list) { if (length(*list) != 1) error("Malformed quote"); return (*list)->car; } // (cons expr expr) static Obj *prim_cons(void *root, Obj **env, Obj **list) { if (length(*list) != 2) error("Malformed cons"); Obj *cell = eval_list(root, env, list); cell->cdr = cell->cdr->car; return cell; } // (car <cell>) static Obj *prim_car(void *root, Obj **env, Obj **list) { Obj *args = eval_list(root, env, list); if (args->car->type != TCELL || args->cdr != Nil) error("Malformed car"); return args->car->car; } // (cdr <cell>) static Obj *prim_cdr(void *root, Obj **env, Obj **list) { Obj *args = eval_list(root, env, list); if (args->car->type != TCELL || args->cdr != Nil) error("Malformed cdr"); return args->car->cdr; } // (setq <symbol> expr) static Obj *prim_setq(void *root, Obj **env, Obj **list) { if (length(*list) != 2 || (*list)->car->type != TSYMBOL) error("Malformed setq"); DEFINE2(bind, value); *bind = find(env, (*list)->car); if (!*bind) error("Unbound variable %s", (*list)->car->name); *value = (*list)->cdr->car; *value = eval(root, env, value); (*bind)->cdr = *value; return *value; } // (setcar <cell> expr) static Obj *prim_setcar(void *root, Obj **env, Obj **list) { DEFINE1(args); *args = eval_list(root, env, list); if (length(*args) != 2 || (*args)->car->type != TCELL) error("Malformed setcar"); (*args)->car->car = (*args)->cdr->car; return (*args)->car; } // (while cond expr ...) static Obj *prim_while(void *root, Obj **env, Obj **list) { if (length(*list) < 2) error("Malformed while"); DEFINE2(cond, exprs); *cond = (*list)->car; while (eval(root, env, cond) != Nil) { *exprs = (*list)->cdr; eval_list(root, env, exprs); } return Nil; } // (gensym) static Obj *prim_gensym(void *root, Obj **env, Obj **list) { static int count = 0; char buf[10]; snprintf(buf, sizeof(buf), "G__%d", count++); return make_symbol(root, buf); } // (+ <integer> ...) static Obj *prim_plus(void *root, Obj **env, Obj **list) { int sum = 0; for (Obj *args = eval_list(root, env, list); args != Nil; args = args->cdr) { if (args->car->type != TINT) error("+ takes only numbers"); sum += args->car->value; } return make_int(root, sum); } // (- <integer> ...) static Obj *prim_minus(void *root, Obj **env, Obj **list) { Obj *args = eval_list(root, env, list); for (Obj *p = args; p != Nil; p = p->cdr) if (p->car->type != TINT) error("- takes only numbers"); if (args->cdr == Nil) return make_int(root, -args->car->value); int r = args->car->value; for (Obj *p = args->cdr; p != Nil; p = p->cdr) r -= p->car->value; return make_int(root, r); } // (< <integer> <integer>) static Obj *prim_lt(void *root, Obj **env, Obj **list) { Obj *args = eval_list(root, env, list); if (length(args) != 2) error("malformed <"); Obj *x = args->car; Obj *y = args->cdr->car; if (x->type != TINT || y->type != TINT) error("< takes only numbers"); return x->value < y->value ? True : Nil; } static Obj *handle_function(void *root, Obj **env, Obj **list, int type) { if ((*list)->type != TCELL || !is_list((*list)->car) || (*list)->cdr->type != TCELL) error("Malformed lambda"); Obj *p = (*list)->car; for (; p->type == TCELL; p = p->cdr) if (p->car->type != TSYMBOL) error("Parameter must be a symbol"); if (p != Nil && p->type != TSYMBOL) error("Parameter must be a symbol"); DEFINE2(params, body); *params = (*list)->car; *body = (*list)->cdr; return make_function(root, env, type, params, body); } // (lambda (<symbol> ...) expr ...) static Obj *prim_lambda(void *root, Obj **env, Obj **list) { return handle_function(root, env, list, TFUNCTION); } static Obj *handle_defun(void *root, Obj **env, Obj **list, int type) { if ((*list)->car->type != TSYMBOL || (*list)->cdr->type != TCELL) error("Malformed defun"); DEFINE3(fn, sym, rest); *sym = (*list)->car; *rest = (*list)->cdr; *fn = handle_function(root, env, rest, type); add_variable(root, env, sym, fn); return *fn; } // (defun <symbol> (<symbol> ...) expr ...) static Obj *prim_defun(void *root, Obj **env, Obj **list) { return handle_defun(root, env, list, TFUNCTION); } // (define <symbol> expr) static Obj *prim_define(void *root, Obj **env, Obj **list) { if (length(*list) != 2 || (*list)->car->type != TSYMBOL) error("Malformed define"); DEFINE2(sym, value); *sym = (*list)->car; *value = (*list)->cdr->car; *value = eval(root, env, value); add_variable(root, env, sym, value); return *value; } // (defmacro <symbol> (<symbol> ...) expr ...) static Obj *prim_defmacro(void *root, Obj **env, Obj **list) { return handle_defun(root, env, list, TMACRO); } // (macroexpand expr) static Obj *prim_macroexpand(void *root, Obj **env, Obj **list) { if (length(*list) != 1) error("Malformed macroexpand"); DEFINE1(body); *body = (*list)->car; return macroexpand(root, env, body); } // (println expr) static Obj *prim_println(void *root, Obj **env, Obj **list) { DEFINE1(tmp); *tmp = (*list)->car; print(eval(root, env, tmp)); printf("\n"); return Nil; } // (if expr expr expr ...) static Obj *prim_if(void *root, Obj **env, Obj **list) { if (length(*list) < 2) error("Malformed if"); DEFINE3(cond, then, els); *cond = (*list)->car; *cond = eval(root, env, cond); if (*cond != Nil) { *then = (*list)->cdr->car; return eval(root, env, then); } *els = (*list)->cdr->cdr; return *els == Nil ? Nil : progn(root, env, els); } // (= <integer> <integer>) static Obj *prim_num_eq(void *root, Obj **env, Obj **list) { if (length(*list) != 2) error("Malformed ="); Obj *values = eval_list(root, env, list); Obj *x = values->car; Obj *y = values->cdr->car; if (x->type != TINT || y->type != TINT) error("= only takes numbers"); return x->value == y->value ? True : Nil; } // (eq expr expr) static Obj *prim_eq(void *root, Obj **env, Obj **list) { if (length(*list) != 2) error("Malformed eq"); Obj *values = eval_list(root, env, list); return values->car == values->cdr->car ? True : Nil; } static void add_primitive(void *root, Obj **env, char *name, Primitive *fn) { DEFINE2(sym, prim); *sym = intern(root, name); *prim = make_primitive(root, fn); add_variable(root, env, sym, prim); } static void define_constants(void *root, Obj **env) { DEFINE1(sym); *sym = intern(root, "t"); add_variable(root, env, sym, &True); } static void define_primitives(void *root, Obj **env) { add_primitive(root, env, "quote", prim_quote); add_primitive(root, env, "cons", prim_cons); add_primitive(root, env, "car", prim_car); add_primitive(root, env, "cdr", prim_cdr); add_primitive(root, env, "setq", prim_setq); add_primitive(root, env, "setcar", prim_setcar); add_primitive(root, env, "while", prim_while); add_primitive(root, env, "gensym", prim_gensym); add_primitive(root, env, "+", prim_plus); add_primitive(root, env, "-", prim_minus); add_primitive(root, env, "<", prim_lt); add_primitive(root, env, "define", prim_define); add_primitive(root, env, "defun", prim_defun); add_primitive(root, env, "defmacro", prim_defmacro); add_primitive(root, env, "macroexpand", prim_macroexpand); add_primitive(root, env, "lambda", prim_lambda); add_primitive(root, env, "if", prim_if); add_primitive(root, env, "=", prim_num_eq); add_primitive(root, env, "eq", prim_eq); add_primitive(root, env, "println", prim_println); } //====================================================================== // Entry point //====================================================================== // Returns true if the environment variable is defined and not the empty string. static bool getEnvFlag(char *name) { char *val = getenv(name); return val && val[0]; } int main(int argc, char **argv) { // Debug flags debug_gc = getEnvFlag("MINILISP_DEBUG_GC"); always_gc = getEnvFlag("MINILISP_ALWAYS_GC"); // Memory allocation memory = alloc_semispace(); // Constants and primitives Symbols = Nil; void *root = NULL; DEFINE2(env, expr); *env = make_env(root, &Nil, &Nil); define_constants(root, env); define_primitives(root, env); // The main loop for (;;) { *expr = read_expr(root); if (!*expr) return 0; if (*expr == Cparen) error("Stray close parenthesis"); if (*expr == Dot) error("Stray dot"); print(eval(root, env, expr)); printf("\n"); } }