diff --git a/examples/library.lisp b/examples/library.lisp index 454a642..03f67c8 100644 --- a/examples/library.lisp +++ b/examples/library.lisp @@ -5,7 +5,9 @@ (defun list (x . y) (cons x y)) - +(defmacro progn (expr . rest) + (list (cons 'lambda (cons () (cons expr rest))))) + ;; (and e1 e2 ...) ;; => (if e1 (and e2 ...)) ;; (and e1) diff --git a/examples/test b/examples/test new file mode 100644 index 0000000..193a362 --- /dev/null +++ b/examples/test @@ -0,0 +1,74 @@ +; test include +(load "examples/library.lisp") + +; Make a set (remove duplicates) +(println(reduce (lambda (acc x) + (if (member acc x) + acc + (cons x acc))) + '(1 2 2 3 1 4 3 5) + ())) + +; sort + +(println(quicksort '(3 1 4 1 5 9 2 8 5 3 5 8 9 8))) +(println(quicksort '(3 1 4 1 5 9 2 8 5 3 5 8 9 8 12 35 48 453 75 90 53 90 456785 785 789))) +(println(quicksort (iota 100))) +(println(quicksort '(3 1 4 1 5 9 2 8 5 3 5 8 9 8))) +(println(quicksort '(3 1 4 1 5 9 2 8 5 3 5 8 9 8 12 35 48 453 75 90 53 90 456785 785 789))) +(println(quicksort (iota 100))) +(println(quicksort '(3 1 4 1 5 9 2 8 5 3 5 8 9 8))) +(println(quicksort '(3 1 4 1 5 9 2 8 5 3 5 8 9 8 12 35 48 453 75 90 53 90 456785 785 789))) +(println(quicksort (reverse (iota 100)))) +(println(quicksort '(3 1 4 1 5 9 2 8 5 3 5 8 9 8))) +(println(quicksort '(3 1 4 1 5 9 2 8 5 3 5 8 9 8 12 35 48 453 75 90 53 90 456785 785 789))) +(println(reverse (iota 100))) +(println(quicksort (reverse (iota 100)))) + +(println(reduce (lambda (acc x) + (if (member acc x) + acc + (cons x acc))) + '(1 2 2 3 1 4 3 5) + ())) + +(println(quicksort '(3 1 4 1 5 9 2 8 5 3 5 8 9 8))) +(println(quicksort '(3 1 4 1 5 9 2 8 5 3 5 8 9 8 12 35 48 453 75 90 53 90 456785 785 789))) +(println(quicksort (iota 100))) +(println(quicksort '(3 1 4 1 5 9 2 8 5 3 5 8 9 8))) +(println(quicksort '(3 1 4 1 5 9 2 8 5 3 5 8 9 8 12 35 48 453 75 90 53 90 456785 785 789))) +(println(quicksort (iota 100))) +(println(quicksort '(3 1 4 1 5 9 2 8 5 3 5 8 9 8))) +(println(quicksort '(3 1 4 1 5 9 2 8 5 3 5 8 9 8 12 35 48 453 75 90 53 90 456785 785 789))) +(println(quicksort (reverse (iota 100)))) +(println(quicksort '(3 1 4 1 5 9 2 8 5 3 5 8 9 8))) +(println(quicksort '(3 1 4 1 5 9 2 8 5 3 5 8 9 8 12 35 48 453 75 90 53 90 456785 785 789))) +(println(quicksort (reverse (iota 100)))) + +(println(reduce (lambda (acc x) + (if (member acc x) + acc + (cons x acc))) + '(1 2 2 3 1 4 3 5) + ())) + (println(quicksort (iota 100))) +(println(quicksort '(3 1 4 1 5 9 2 8 5 3 5 8 9 8))) +(println(quicksort '(3 1 4 1 5 9 2 8 5 3 5 8 9 8 12 35 48 453 75 90 53 90 456785 785 789))) +(println(quicksort (iota 100))) +(println(quicksort '(3 1 4 1 5 9 2 8 5 3 5 8 9 8))) +(println(quicksort '(3 1 4 1 5 9 2 8 5 3 5 8 9 8 12 35 48 453 75 90 53 90 456785 785 789))) +(println(quicksort (iota 100))) +(println(quicksort '(3 1 4 1 5 9 2 8 5 3 5 8 9 8))) +(println(quicksort '(3 1 4 1 5 9 2 8 5 3 5 8 9 8 12 35 48 453 75 90 53 90 456785 785 789))) +(println(quicksort (reverse (iota 100)))) +(println(quicksort '(3 1 4 1 5 9 2 8 5 3 5 8 9 8))) +(println(quicksort '(3 1 4 1 5 9 2 8 5 3 5 8 9 8 12 35 48 453 75 90 53 90 456785 785 789))) +(println(quicksort (reverse (iota 100)))) + +(println(reduce (lambda (acc x) + (if (member acc x) + acc + (cons x acc))) + '(1 2 2 3 1 4 3 5) + ())) + \ No newline at end of file diff --git a/src/gc.c b/src/gc.c index e2c4ab5..f44787a 100644 --- a/src/gc.c +++ b/src/gc.c @@ -6,7 +6,7 @@ #include #include "gc.h" -extern __attribute((noreturn)) void error(char *fmt, ...); +extern void error(char *fmt, ...); // The pointer pointing to the beginning of the current heap void *memory; @@ -18,32 +18,30 @@ static void *from_space; 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; + bool gc_running = false; + bool debug_gc = false; + bool always_gc = false; // 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. -extern Obj *Symbols; - -static void gc(void *root); // forward decl +Obj *Symbols; // 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); // 傳回的大小必須是 2 的次方 + return (var + size - 1) & ~(size - 1); } // Allocates memory block. This may start GC if we don't have enough memory. -Obj *alloc(void *root, int type, size_t size) { // 分配比 size 大的記憶體給 type 的物件 +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); // offsetof 的功能 -- 參考 https://en.cppreference.com/w/cpp/types/offsetof + 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 @@ -55,20 +53,20 @@ Obj *alloc(void *root, int type, size_t size) { // 分配比 size 大的記憶 // 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) // 每次分配前都做垃圾收集 + 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) // 只有記憶體不足時才做垃圾收集 + 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) // heap 記憶體用完了 + if (MEMORY_SIZE < mem_nused + size) error("Memory exhausted"); // Allocate the object. - Obj *obj = memory + mem_nused; // memory: heap 起點 men_nused: 目前用掉的大小。 + Obj *obj = memory + mem_nused; obj->type = type; obj->size = size; mem_nused += size; @@ -84,12 +82,12 @@ Obj *alloc(void *root, int type, size_t size) { // 分配比 size 大的記憶 // 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; // Cheney 算法請參考 -- https://blog.csdn.net/MrLiii/article/details/113521913 -static Obj *scan2; // scan1, scan2 就是上文中的 SCAN 與 Free +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) { // 將 obj 從 from 區移到 to 區 +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; @@ -98,29 +96,29 @@ static inline Obj *forward(Obj *obj) { // 將 obj 從 from 區移到 to 區 // 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) // 已經移過去了，不用再移 + 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); // 將 scan2 往後移動 + // 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; // 傳回該物件的新位址 + obj->type = TMOVED; + obj->moved = newloc; + return newloc; } void *alloc_semispace() { return mmap(NULL, MEMORY_SIZE, PROT_READ | PROT_WRITE, MAP_PRIVATE | MAP_ANON, -1, 0); } -// Copies the root objects. // 移動 root 環境的物件 +// Copies the root objects. static void forward_root_objects(void *root) { - Symbols = forward(Symbols); // 移動符號表到新記憶體區 - for (void **frame = root; frame; frame = *(void ***)frame) // 移動 frame 到新記憶體區 + 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]); @@ -135,14 +133,14 @@ static bool getEnvFlag(char *name) { // Implements Cheney's copying garbage collection algorithm. // http://en.wikipedia.org/wiki/Cheney%27s_algorithm -static void gc(void *root) { +void gc(void *root) { assert(!gc_running); gc_running = true; // 開始垃圾蒐集 // Debug flags debug_gc = getEnvFlag("MINILISP_DEBUG_GC"); always_gc = getEnvFlag("MINILISP_ALWAYS_GC"); - + // Allocate a new semi-space. from_space = memory; memory = alloc_semispace(); @@ -151,40 +149,40 @@ static void gc(void *root) { scan1 = scan2 = memory; // Copy the GC root objects first. This moves the pointer scan2. - forward_root_objects(root); // 移動 root 環境的物件 + 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) { // 將 root 指向的物件從 scan1 (FROM) 搬到 scan2 (to) 去 + while (scan1 < scan2) { switch (scan1->type) { case TINT: - case TSTRING: case TSYMBOL: case TPRIMITIVE: + case TSTRING: // Any of the above types does not contain a pointer to a GC-managed object. break; case TCELL: - scan1->car = forward(scan1->car); // 每個 list 的 car, cdr 都搬到新位址 + scan1->car = forward(scan1->car); scan1->cdr = forward(scan1->cdr); break; case TFUNCTION: case TMACRO: - scan1->params = forward(scan1->params); // 每個 macro 的 params, body, env 都搬到新位址 + scan1->params = forward(scan1->params); scan1->body = forward(scan1->body); scan1->env = forward(scan1->env); break; case TENV: - scan1->vars = forward(scan1->vars); // 每個 env 的 vars, up 都搬到新位址 + 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); // 前進到下一個物件 + scan1 = (Obj *)((uint8_t *)scan1 + scan1->size); } - // Finish up GC. // 結束垃圾蒐集 + // Finish up GC. munmap(from_space, MEMORY_SIZE); size_t old_nused = mem_nused; mem_nused = (size_t)((uint8_t *)scan1 - (uint8_t *)memory); diff --git a/src/gc.h b/src/gc.h index 094c0f1..a2c1022 100644 --- a/src/gc.h +++ b/src/gc.h @@ -10,9 +10,9 @@ //====================================================================== // The size of the heap in byte -#define MEMORY_SIZE 262144 +#define MEMORY_SIZE 65536 * 4 -extern void *root; // root of memory +extern void *gc_root; // root of memory // 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 @@ -34,35 +34,43 @@ extern void *root; // root of memory #define ROOT_END ((void *)-1) -// 初始化 frame (env) 陣列 -#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_ -// 新增 1 個變數物件 -#define DEFINE1(var1) \ - ADD_ROOT(1); \ - Obj **var1 = (Obj **)(root_ADD_ROOT_ + 1) -// 新增 2 個變數物件 -#define DEFINE2(var1, var2) \ - ADD_ROOT(2); \ - Obj **var1 = (Obj **)(root_ADD_ROOT_ + 1); \ - Obj **var2 = (Obj **)(root_ADD_ROOT_ + 2) -// 新增 3 個變數物件 -#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) -// 新增 4 個變數物件 -#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) - -#endif +static inline void** add_root_frame(void **prev_frame, int size, void *frame[]) { + frame[0] = prev_frame; + for (int i = 1; i <= size; i++) + frame[i] = NULL; + frame[size + 1] = ROOT_END; + return frame; +} + +#define DEFINE1(prev_frame, var1) \ + void *root_frame[3]; \ + prev_frame = add_root_frame(prev_frame, 1, root_frame); \ + Obj **var1 = (Obj **)(root_frame + 1); + +#define DEFINE2(prev_frame, var1, var2) \ + void *root_frame[4]; \ + prev_frame = add_root_frame(prev_frame, 2, root_frame); \ + Obj **var1 = (Obj **)(root_frame + 1); \ + Obj **var2 = (Obj **)(root_frame + 2); + +#define DEFINE3(prev_frame, var1, var2, var3) \ + void *root_frame[5]; \ + prev_frame = add_root_frame(prev_frame, 3, root_frame); \ + Obj **var1 = (Obj **)(root_frame + 1); \ + Obj **var2 = (Obj **)(root_frame + 2); \ + Obj **var3 = (Obj **)(root_frame + 3); + +#define DEFINE4(prev_frame, var1, var2, var3, var4) \ + void *root_frame[6]; \ + prev_frame = add_root_frame(prev_frame, 4, root_frame); \ + Obj **var1 = (Obj **)(root_frame + 1); \ + Obj **var2 = (Obj **)(root_frame + 2); \ + Obj **var3 = (Obj **)(root_frame + 3); \ + Obj **var4 = (Obj **)(root_frame + 4); + + +void *alloc_semispace(); +Obj *alloc(void *root, int type, size_t size); +void gc(void *root); + +#endif \ No newline at end of file diff --git a/src/minilisp.c b/src/minilisp.c index f769aea..f732906 100644 --- a/src/minilisp.c +++ b/src/minilisp.c @@ -16,10 +16,12 @@ jmp_buf context; extern filepos_t filepos; -void error(char *fmt, int line_num, ...) { +void error(char *fmt, ...) { va_list ap; - va_start(ap, line_num); - fprintf(stderr, "%s[%d]: ", filepos.filename, line_num); + va_start(ap, fmt); +// fprintf(stderr, "%s[%d]: ", filepos.filename, line_num); +// vfprintf(stderr, fmt, ap); + fprintf(stderr, " "); vfprintf(stderr, fmt, ap); fprintf(stderr, "\n"); va_end(ap); @@ -37,19 +39,17 @@ static Obj *Cparen = &(Obj){ TCPAREN }; // Constructors //====================================================================== - // 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. -Obj *Symbols; +extern Obj *Symbols; -void *root; // root of memory +void *gc_root = NULL; // root of memory extern Obj *alloc(void *root, int type, size_t size); -static Obj *make_int(void *root, long long value) { - Obj *r = alloc(root, TINT, sizeof(long long)); +static Obj *make_int(void *root, int value) { + Obj *r = alloc(root, TINT, sizeof(int)); r->value = value; - r->line_num = filepos.line_num; return r; } @@ -57,21 +57,18 @@ static Obj *cons(void *root, Obj **car, Obj **cdr) { Obj *cell = alloc(root, TCELL, sizeof(Obj *) * 2); cell->car = *car; cell->cdr = *cdr; - cell->line_num = filepos.line_num; return cell; } static Obj *make_symbol(void *root, char *name) { Obj *sym = alloc(root, TSYMBOL, strlen(name) + 1); strcpy(sym->name, name); - sym->line_num = filepos.line_num; return sym; } static Obj *make_primitive(void *root, Primitive *fn) { Obj *r = alloc(root, TPRIMITIVE, sizeof(Primitive *)); r->fn = fn; - r->line_num = filepos.line_num; return r; } @@ -81,7 +78,6 @@ static Obj *make_function(void *root, Obj **env, int type, Obj **params, Obj **b r->params = *params; r->body = *body; r->env = *env; - r->line_num = filepos.line_num; return r; } @@ -92,9 +88,16 @@ struct Obj *make_env(void *root, Obj **vars, Obj **up) { return r; } +static Obj *make_string(void *root, const char *str) { + size_t len = strlen(str); + Obj *r = alloc(root, TSTRING, len + 1); + strcpy(r->name, str); // We can reuse the name field for string data + return r; +} + // Returns ((x . y) . a) static Obj *acons(void *root, Obj **x, Obj **y, Obj **a) { - DEFINE1(cell); + DEFINE1(root, cell); *cell = cons(root, x, y); return cons(root, cell, a); } @@ -108,37 +111,20 @@ static Obj *acons(void *root, Obj **x, Obj **y, Obj **a) { #define SYMBOL_MAX_LEN 200 const char symbol_chars[] = "~!@#$%^&*-_=+:/?<>"; +void swap(char *left, char *right) { + char tmp = *left; + *left = *right; + *right = tmp; +} + static Obj *read_expr(void *root); static int peek(void) { - char c = getchar(); - ungetc(c, stdin); - return c; -} - -static int read_char(void) { int c = getchar(); - if (c == '\n') { - filepos.line_num++; - if (peek() == '\r') { - getchar(); - } - } else if (c == '\r') { - filepos.line_num++; - if (peek() == '\n') { - getchar(); - } - } + ungetc(c, stdin); return c; } - -void swap(char *left, char *right) { - char tmp = *left; - *left = *right; - *right = tmp; -} - // Destructively reverses the given list. static Obj *reverse(Obj *p) { Obj *ret = Nil; @@ -154,11 +140,9 @@ static Obj *reverse(Obj *p) { // Skips the input until newline is found. Newline is one of \r, \r\n or \n. static void skip_line(void) { for (;;) { - char c = getchar(); - if (c == EOF || c == '\n'){ - filepos.line_num++; + int c = getchar(); + if (c == EOF || c == '\n') return; - } if (c == '\r') { if (peek() == '\n') getchar(); @@ -169,18 +153,18 @@ static void skip_line(void) { // Reads a list. Note that '(' has already been read. static Obj *read_list(void *root) { - DEFINE3(obj, head, last); + DEFINE3(root, obj, head, last); *head = Nil; for (;;) { *obj = read_expr(root); if (!*obj) - error("Unclosed parenthesis", filepos.line_num); + 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", filepos.line_num); + error("Closed parenthesis expected after dot"); Obj *ret = reverse(*head); (*head)->cdr = *last; return ret; @@ -195,7 +179,7 @@ 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); + DEFINE1(root, sym); *sym = make_symbol(root, name); Symbols = cons(root, sym, &Symbols); return *sym; @@ -203,7 +187,7 @@ static Obj *intern(void *root, char *name) { // Reader marcro ' (single quote). It reads an expression and returns (quote ). static Obj *read_quote(void *root) { - DEFINE2(sym, tmp); + DEFINE2(root, sym, tmp); *sym = intern(root, "quote"); *tmp = read_expr(root); *tmp = cons(root, tmp, &Nil); @@ -211,9 +195,9 @@ static Obj *read_quote(void *root) { return *tmp; } -static long long read_number(int val) { +static int read_number(int val) { while (isdigit(peek())) - val = val * 10 + (read_char() - '0'); + val = val * 10 + (getchar() - '0'); return val; } @@ -223,38 +207,31 @@ static Obj *read_symbol(void *root, char c) { int len = 1; while (isalnum(peek()) || strchr(symbol_chars, peek())) { if (SYMBOL_MAX_LEN <= len) - error("Symbol name too long", filepos.line_num); - buf[len++] = read_char(); + error("Symbol name too long"); + buf[len++] = getchar(); } buf[len] = '\0'; return intern(root, buf); } -static Obj *make_string(void *root, const char *str) { - size_t len = strlen(str); - Obj *r = alloc(root, TSTRING, len + 1); - strcpy(r->name, str); // We can reuse the name field for string data - return r; -} - static Obj *read_string(void *root) { char buf[1024]; - int i = 0; + size_t i = 0; while (1) { - int c = read_char(); + int c = getchar(); if (c == EOF) - error("Unclosed string literal", filepos.line_num); + error("Unclosed string literal"); if (c == '"') break; if (c == '\\') { - c = read_char(); + c = getchar(); if (c == 'n') c = '\n'; else if (c == 't') c = '\t'; else if (c == 'r') c = '\r'; } if (i >= sizeof(buf) - 1) - error("String too long", filepos.line_num); + error("String too long"); buf[i++] = c; } buf[i] = '\0'; @@ -263,14 +240,8 @@ static Obj *read_string(void *root) { static Obj *read_expr(void *root) { for (;;) { - char c = getchar(); - if (c == '\n') { - filepos.line_num++; - if (peek() == '\r'); - continue; - } - - if (c == ' ' || c == '\r' || c == '\t') + int c = getchar(); + if (c == ' ' || c == '\n' || c == '\r' || c == '\t') continue; if (c == EOF) return NULL; @@ -294,7 +265,7 @@ static Obj *read_expr(void *root) { 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", filepos.line_num, c); + error("Don't know how to handle %c", c); } } @@ -316,24 +287,21 @@ static void print(Obj *obj) { obj = obj->cdr; } fputc(')', stdout); - break; - - case TINT : printf("%lld", obj->value); - break; - case TSYMBOL: fputs(obj->name, stdout); - break; - case TPRIMITIVE: fputs("", stdout); - break; - case TFUNCTION: fputs("", stdout); - break; - case TMACRO : fputs("", stdout); - break; - case TMOVED : fputs("", stdout); - break; - case TTRUE : fputc('t', stdout); - break; - case TNIL : fputs("()", stdout); - break; + return; + +#define CASE(type, ...) \ + case type: \ + printf(__VA_ARGS__); \ + return + CASE(TINT, "%lld", obj->value); + CASE(TSYMBOL, "%s", obj->name); + CASE(TPRIMITIVE, ""); + CASE(TFUNCTION, ""); + CASE(TMACRO, ""); + CASE(TMOVED, ""); + CASE(TTRUE, "t"); + CASE(TNIL, "()"); +#undef CASE case TSTRING: for (char *p = obj->name; *p; p++) { if (*p == '"') fputs("\\\"", stdout); @@ -344,9 +312,8 @@ static void print(Obj *obj) { } break; default: - error("Bug: print: Unknown tag type: %d", obj->line_num, obj->type); + error("Bug: print: Unknown tag type: %d", obj->type); } - //puts(""); } // Returns the length of the given list. -1 if it's not a proper list. @@ -364,7 +331,7 @@ static int length(Obj *list) { static Obj *eval(void *root, Obj **env, Obj **obj); static void add_variable(void *root, Obj **env, Obj **sym, Obj **val) { - DEFINE2(vars, tmp); + DEFINE2(root, vars, tmp); *vars = (*env)->vars; *tmp = acons(root, sym, val, vars); (*env)->vars = *tmp; @@ -372,12 +339,11 @@ static void add_variable(void *root, Obj **env, Obj **sym, Obj **val) { // Returns a newly created environment frame. static Obj *push_env(void *root, Obj **env, Obj **vars, Obj **vals) { - DEFINE3(map, sym, val); + DEFINE3(root, 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", - (*vars)->line_num); + error("Cannot apply function: number of argument does not match"); *sym = (*vars)->car; *val = (*vals)->car; *map = acons(root, sym, val, map); @@ -389,7 +355,7 @@ static Obj *push_env(void *root, Obj **env, Obj **vars, Obj **vals) { // Evaluates the list elements from head and returns the last return value. static Obj *progn(void *root, Obj **env, Obj **list) { - DEFINE2(lp, r); + DEFINE2(root, lp, r); for (*lp = *list; *lp != Nil; *lp = (*lp)->cdr) { *r = (*lp)->car; *r = eval(root, env, r); @@ -399,7 +365,7 @@ static Obj *progn(void *root, Obj **env, Obj **list) { // 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); + DEFINE4(root, head, lp, expr, result); *head = Nil; for (lp = list; *lp != Nil; *lp = (*lp)->cdr) { *expr = (*lp)->car; @@ -414,7 +380,7 @@ static bool is_list(Obj *obj) { } static Obj *apply_func(void *root, Obj **env, Obj **fn, Obj **args) { - DEFINE3(params, newenv, body); + DEFINE3(root, params, newenv, body); *params = (*fn)->params; *newenv = (*fn)->env; *newenv = push_env(root, newenv, params, args); @@ -425,40 +391,21 @@ static Obj *apply_func(void *root, Obj **env, Obj **fn, Obj **args) { // 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", (*args)->line_num); + error("argument must be a list"); if ((*fn)->type == TPRIMITIVE) return (*fn)->fn(root, env, args); if ((*fn)->type == TFUNCTION) { - DEFINE1(eargs); + DEFINE1(root, eargs); *eargs = eval_list(root, env, args); return apply_func(root, env, fn, eargs); } - error("not supported", (*args)->line_num); - return Nil; //fix warning + error("not supported"); + return Nil; // remove warning } // Searches for a variable by symbol. Returns null if not found. -/* 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 - */ static Obj *find(Obj **env, Obj *sym) { - for (Obj *p = *env; p != Nil; p = p->up) { // search all environments + 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) @@ -472,7 +419,7 @@ static Obj *find(Obj **env, Obj *sym) { static Obj *macroexpand(void *root, Obj **env, Obj **obj) { if ((*obj)->type != TCELL || (*obj)->car->type != TSYMBOL) return *obj; - DEFINE3(bind, macro, args); + DEFINE3(root, bind, macro, args); *bind = find(env, (*obj)->car); if (!*bind || (*bind)->cdr->type != TMACRO) return *obj; @@ -485,24 +432,23 @@ static Obj *macroexpand(void *root, Obj **env, Obj **obj) { static Obj *eval(void *root, Obj **env, Obj **obj) { switch ((*obj)->type) { case TINT: - case TSTRING: case TPRIMITIVE: case TFUNCTION: case TTRUE: + case TSTRING: case TNIL: // Self-evaluating objects return *obj; case TSYMBOL: { // Variable Obj *bind = find(env, *obj); - if (!bind) { - error("Undefined symbol: %s", (*obj)->line_num, (*obj)->name); - } + if (!bind) + error("Undefined symbol: %s", (*obj)->name); return bind->cdr; } case TCELL: { // Function application form - DEFINE3(fn, expanded, args); + DEFINE3(root, fn, expanded, args); *expanded = macroexpand(root, env, obj); if (*expanded != *obj) return eval(root, env, expanded); @@ -510,13 +456,13 @@ static Obj *eval(void *root, Obj **env, Obj **obj) { *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", (*obj)->line_num); + 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)->line_num, (*obj)->type); + error("Bug: eval: Unknown tag type: %d", (*obj)->type); } - return Nil; // fix warning + return Nil; // remove warning } //====================================================================== @@ -526,20 +472,14 @@ static Obj *eval(void *root, Obj **env, Obj **obj) { // 'expr static Obj *prim_quote(void *root, Obj **env, Obj **list) { if (length(*list) != 1) - error("Malformed quote", (*list)->line_num); + error("Malformed quote"); return (*list)->car; } -static Obj *prim_atom(void *root, Obj **env, Obj **list) { - if (length(*list) != 1) - error("atom takes ontly 1 argument", (*list)->line_num); - return ((*list)->car->type != TCELL) ? True : Nil; -} - // (cons expr expr) static Obj *prim_cons(void *root, Obj **env, Obj **list) { if (length(*list) != 2) - error("Malformed cons", (*list)->line_num); + error("Malformed cons"); Obj *cell = eval_list(root, env, list); cell->cdr = cell->cdr->car; return cell; @@ -549,7 +489,7 @@ static Obj *prim_cons(void *root, Obj **env, Obj **list) { 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", (*list)->line_num); + error("Malformed car"); return args->car->car; } @@ -557,18 +497,18 @@ static Obj *prim_car(void *root, Obj **env, Obj **list) { 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", (*list)->line_num); + error("Malformed cdr"); return args->car->cdr; } // (setq expr) static Obj *prim_setq(void *root, Obj **env, Obj **list) { if (length(*list) != 2 || (*list)->car->type != TSYMBOL) - error("Malformed setq", (*list)->line_num); - DEFINE2(bind, value); + error("Malformed setq"); + DEFINE2(root, bind, value); *bind = find(env, (*list)->car); if (!*bind) - error("Unbound variable %s", (*list)->line_num, (*list)->car->name); + error("Unbound variable %s", (*list)->car->name); *value = (*list)->cdr->car; *value = eval(root, env, value); (*bind)->cdr = *value; @@ -577,10 +517,10 @@ static Obj *prim_setq(void *root, Obj **env, Obj **list) { // (setcar expr) static Obj *prim_setcar(void *root, Obj **env, Obj **list) { - DEFINE1(args); + DEFINE1(root, args); *args = eval_list(root, env, list); if (length(*args) != 2 || (*args)->car->type != TCELL) - error("Malformed setcar", (*list)->line_num); + error("Malformed setcar"); (*args)->car->car = (*args)->cdr->car; return (*args)->car; } @@ -588,8 +528,8 @@ static Obj *prim_setcar(void *root, Obj **env, Obj **list) { // (while cond expr ...) static Obj *prim_while(void *root, Obj **env, Obj **list) { if (length(*list) < 2) - error("Malformed while", (*list)->line_num); - DEFINE2(cond, exprs); + error("Malformed while"); + DEFINE2(root, cond, exprs); *cond = (*list)->car; while (eval(root, env, cond) != Nil) { *exprs = (*list)->cdr; @@ -606,58 +546,12 @@ static Obj *prim_gensym(void *root, Obj **env, Obj **list) { return make_symbol(root, buf); } -// (length | length | length ...) -static Obj *prim_length(void *root, Obj **env, Obj **list) { - Obj *args = eval_list(root, env, list); - int len = length(args); - if (len == 1) { - Obj *car = args->car; - if (car != Nil) { - if (car->type == TSTRING) { - len = strlen(car->name); - } - else if (car->type == TCELL) { - for (len = 0; car != Nil && car->type == TCELL; car = car->cdr) - len++; - } - else { - error("When length has a single argument, it must be a list or a string", - (*list)->line_num); - } - } - } - - return make_int(root, len); -} - -// (reverse ... | reverse ) -static Obj *prim_reverse(void *root, Obj **env, Obj **list) { - Obj *args = eval_list(root, env, list); - int len = length(args); - if (len != 1) { - return reverse(args); - } - else { - Obj *car = args->car; - if (car != Nil) { - if (car->type == TCELL) { - return reverse(car); - } - else if(car->type == TSTRING){ - char *left = car->name, - *right = left + strlen(car->name) - 1; - while (left <= right) { - swap(left, right); - left++, right--; - } - } - else { - error("When reverse has a single argument, it must be a list", - (*list)->line_num); - } - } - return car; - } +// (not ) +static Obj *prim_not(void *root, Obj **env, Obj **list) { + if (length(*list) != 1) + error("not accepts 1 argument"); + Obj *values = eval_list(root, env, list); + return values->car == Nil ? True : Nil; } #define PRIM_ARITHMETIC_OP(PRIM_OP, OP, OPEQ) \ @@ -666,7 +560,7 @@ static Obj *PRIM_OP(void *root, Obj **env, Obj **list) { \ long long r = args->car->value; \ for (Obj *p = args->cdr; p != Nil; p = p->cdr) { \ if (p->car->type != TINT) \ - error(#OP " takes only numbers", (*list)->line_num); \ + error(#OP " takes only numbers"); \ r OPEQ p->car->value; \ } \ return make_int(root, r); \ @@ -683,10 +577,10 @@ 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", (*list)->line_num); + error("- takes only numbers"); if (args->cdr == Nil) return make_int(root, -args->car->value); - long long r = 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); @@ -697,11 +591,11 @@ static Obj *prim_minus(void *root, Obj **env, Obj **list) { static Obj *PRIM_OP(void *root, Obj **env, Obj **list) { \ Obj *args = eval_list(root, env, list); \ if (length(args) != 2) \ - error(#OP " takes only 2 number", (*list)->line_num); \ + error(#OP " takes only 2 number"); \ Obj *x = args->car; \ Obj *y = args->cdr->car; \ if (x->type != TINT || y->type != TINT) \ - error(#OP " takes only 2 numbers", (*list)->line_num); \ + error(#OP " takes only 2 numbers"); \ return x->value OP y->value ? True : Nil; \ } @@ -711,77 +605,16 @@ PRIM_COMPARISON_OP(prim_lte, <=) PRIM_COMPARISON_OP(prim_gt, >) PRIM_COMPARISON_OP(prim_gte, >=) -// (not ) -static Obj *prim_not(void *root, Obj **env, Obj **list) { - if (length(*list) != 1) - error("not accepts 1 argument", (*list)->line_num); - Obj *values = eval_list(root, env, list); - return values->car == Nil ? True : Nil; -} - -// (and ...) -static Obj *prim_and(void *root, Obj **env, Obj **list) { - Obj *car = True; // by default, return True if no args - for (Obj *args = eval_list(root, env, list); args != Nil; args = args->cdr) { - car = eval(root, env, &args->car); - if (car == Nil) break; - } - return car; -} - -// (or ...) -static Obj *prim_or(void *root, Obj **env, Obj **list) { - Obj *car = Nil; - for (Obj *args = eval_list(root, env, list); args != Nil; args = args->cdr) { - car = eval(root, env, &args->car); - if (car != Nil) break; - } - return car; -} - -extern void process_file(char *fname, Obj **env, Obj **expr); - -static Obj *prim_load(void *root, Obj **env, Obj **list) { - DEFINE1(expr); - Obj *args = eval_list(root, env, list); - if (args->car->type != TSTRING){ - error("load: filename must be a string", (*list)->line_num); - } - char *name = args->car->name; - - // Save old context and set up new one for error handling - jmp_buf old_context; - memcpy(&old_context, &context, sizeof(jmp_buf)); - - if (setjmp(context) == 0) { - process_file(name, env, expr); - } - - // Restore old context - memcpy(&context, &old_context, sizeof(jmp_buf)); - return Nil; -} - -static Obj *prim_exit(void *root, Obj **env, Obj **list) { - if (length(*list) != 1) - error("exit accepts 1 argument", (*list)->line_num); - Obj *values = eval_list(root, env, list); - Obj *first = values->car; - if (first->type != TINT) - error("* must be an integer", (*list)->line_num); - exit(first->value); -} - 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", (*list)->line_num); + 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", (*list)->line_num); + error("Parameter must be a symbol"); if (p != Nil && p->type != TSYMBOL) - error("Parameter must be a symbol", (*list)->line_num); - DEFINE2(params, body); + error("Parameter must be a symbol"); + DEFINE2(root, params, body); *params = (*list)->car; *body = (*list)->cdr; return make_function(root, env, type, params, body); @@ -793,10 +626,9 @@ static Obj *prim_lambda(void *root, Obj **env, Obj **list) { } static Obj *handle_defun(void *root, Obj **env, Obj **list, int type) { - if (length(*list) < 3 || (*list)->car->type != TSYMBOL || (*list)->cdr->type != TCELL) - error("Malformed defun: correct form is (defun ( ...) expr ...)" - , (*list)->line_num); - DEFINE3(fn, sym, rest); + if ((*list)->car->type != TSYMBOL || (*list)->cdr->type != TCELL) + error("Malformed defun"); + DEFINE3(root, fn, sym, rest); *sym = (*list)->car; *rest = (*list)->cdr; *fn = handle_function(root, env, rest, type); @@ -812,8 +644,8 @@ static Obj *prim_defun(void *root, Obj **env, Obj **list) { // (define expr) static Obj *prim_define(void *root, Obj **env, Obj **list) { if (length(*list) != 2 || (*list)->car->type != TSYMBOL) - error("Malformed define", (*list)->line_num); - DEFINE2(sym, value); + error("Malformed define"); + DEFINE2(root, sym, value); *sym = (*list)->car; *value = (*list)->cdr->car; *value = eval(root, env, value); @@ -829,37 +661,31 @@ static Obj *prim_defmacro(void *root, Obj **env, Obj **list) { // (macroexpand expr) static Obj *prim_macroexpand(void *root, Obj **env, Obj **list) { if (length(*list) != 1) - error("Malformed macroexpand", (*list)->line_num); - DEFINE1(body); + error("Malformed macroexpand"); + DEFINE1(root, body); *body = (*list)->car; return macroexpand(root, env, body); } -// (print ...) static Obj *prim_print(void *root, Obj **env, Obj **list) { - for (Obj *args = *list; args != Nil; args = args->cdr) { - print(eval(root, env, &(args->car))); - } + DEFINE1(root, tmp); + *tmp = (*list)->car; + print(eval(root, env, tmp)); return Nil; } - -// (println ...) +// (println expr) static Obj *prim_println(void *root, Obj **env, Obj **list) { prim_print(root, env, list); fputc('\n', stdout); return Nil; } -static Obj *prim_progn(void *root, Obj **env, Obj **list) { - return progn(root, env, list); -} - // (if expr expr expr ...) static Obj *prim_if(void *root, Obj **env, Obj **list) { if (length(*list) < 2) - error("Malformed if", (*list)->line_num); - DEFINE3(cond, then, els); + error("Malformed if"); + DEFINE3(root, cond, then, els); *cond = (*list)->car; *cond = eval(root, env, cond); if (*cond != Nil) { @@ -870,10 +696,62 @@ static Obj *prim_if(void *root, Obj **env, Obj **list) { return *els == Nil ? Nil : progn(root, env, els); } +// (length | length | length ...) +static Obj *prim_length(void *root, Obj **env, Obj **list) { + Obj *args = eval_list(root, env, list); + int len = length(args); + if (len == 1) { + Obj *car = args->car; + if (car != Nil) { + if (car->type == TSTRING) { + len = strlen(car->name); + } + else if (car->type == TCELL) { + for (len = 0; car != Nil && car->type == TCELL; car = car->cdr) + len++; + } + else { + error("When length has a single argument, it must be a list or a string"); + } + } + } + + return make_int(root, len); +} + +// (reverse ... | reverse ) +static Obj *prim_reverse(void *root, Obj **env, Obj **list) { + Obj *args = eval_list(root, env, list); + int len = length(args); + if (len != 1) { + return reverse(args); + } + else { + Obj *car = args->car; + if (car != Nil) { + if (car->type == TCELL) { + return reverse(car); + } + else if(car->type == TSTRING){ + char *left = car->name, + *right = left + strlen(car->name) - 1; + while (left <= right) { + swap(left, right); + left++, right--; + } + } + else { + error("When reverse has a single argument, it must be a list"); + } + } + return car; + } +} + // (eq expr expr) static Obj *prim_eq(void *root, Obj **env, Obj **list) { if (length(*list) != 2) - error("eq takes 2 arguments only", (*list)->line_num); + error("eq takes 2 arguments only"); Obj *values = eval_list(root, env, list); Obj *first = values->car; Obj *second = values->cdr->car; @@ -881,7 +759,7 @@ static Obj *prim_eq(void *root, Obj **env, Obj **list) { if (second->type == TSTRING) return strcmp(first->name, second->name) == 0 ? True : Nil; else - error("The 2 arguments of eq must be of the same type", (*list)->line_num); + error("The 2 arguments of eq must be of the same type"); } return first == second ? True : Nil; } @@ -894,8 +772,7 @@ static Obj *prim_string_concat(void *root, Obj **env, Obj **list) { size_t total_len = 1; // Start with 1 for null terminator for (Obj *p = args; p != Nil; p = p->cdr) { if (p->car->type != TSTRING && p->car->type != TINT) - error("string-concat arguments must be strings or numbers", - (*list)->line_num); + error("string-concat arguments must be strings or numbers"); if (p->car->type == TINT) { long long val = p->car->value; char var[22]; @@ -909,7 +786,7 @@ static Obj *prim_string_concat(void *root, Obj **env, Obj **list) { char *buf = malloc(total_len); if (!buf) - error("Out of memory in string-concat", (*list)->line_num); + error("Out of memory in string-concat"); buf[0] = '\0'; // Second pass: concatenate all strings @@ -933,10 +810,10 @@ static Obj *prim_string_concat(void *root, Obj **env, Obj **list) { static Obj *prim_symbol_to_string(void *root, Obj **env, Obj **list) { Obj *args = eval_list(root, env, list); if (length(args) != 1) - error("symbol->string requires 1 argument", (*list)->line_num); + error("symbol->string requires 1 argument"); if (args->car->type != TSYMBOL) - error("symbol->string argument must be a symbol", (*list)->line_num); + error("symbol->string argument must be a symbol"); return make_string(root, args->car->name); } @@ -944,27 +821,123 @@ static Obj *prim_symbol_to_string(void *root, Obj **env, Obj **list) { static Obj *prim_string_to_symbol(void *root, Obj **env, Obj **list) { Obj *args = eval_list(root, env, list); if (length(args) != 1) - error("string->symbol requires 1 argument", (*list)->line_num); + error("string->symbol requires 1 argument"); if (args->car->type != TSTRING) - error("string->symbol argument must be a string", (*list)->line_num); + error("string->symbol argument must be a string"); return intern(root, args->car->name); } +static Obj *prim_exit(void *root, Obj **env, Obj **list) { + if (length(*list) != 1) + error("exit accepts 1 argument"); + Obj *values = eval_list(root, env, list); + Obj *first = values->car; + if (first->type != TINT) + error("* must be an integer"); + exit(first->value); +} + +static Obj *prim_load(void *root, Obj **env, Obj **list) { + DEFINE1(root, expr); + Obj *args = eval_list(root, env, list); + if (args->car->type != TSTRING){ + error("load: filename must be a string"); + } + char *name = args->car->name; + + // Save old context and set up new one for error handling + jmp_buf old_context; + memcpy(&old_context, &context, sizeof(jmp_buf)); + + // forward decl + void process_file(char *fname, Obj **env, Obj **expr); + if (setjmp(context) == 0) { + process_file(name, env, expr); + } + + // Restore old context + memcpy(&context, &old_context, sizeof(jmp_buf)); + return Nil; +} + static void add_primitive(void *root, Obj **env, char *name, Primitive *fn) { - DEFINE2(sym, prim); + DEFINE2(root, 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); + DEFINE1(root, sym); *sym = intern(root, "t"); add_variable(root, env, sym, &True); } +static size_t read_file(char *fname, char **text) { + size_t length = 0; + FILE *f = fopen(fname, "r"); + if (!f) { + error("Failed to load file %s", fname); + return 0; + } + + fseek(f, 0, SEEK_END); + length = ftell(f); + fseek(f, 0, SEEK_SET); + + *text = malloc(length + 1); + if (!*text) { + error("Out of memory."); + fclose(f); + return 0; + } + + size_t read = fread(*text, 1, length, f); + if (read != length) { + error("Failed to read entire file"); + free(*text); + *text = NULL; + fclose(f); + return 0; + } + + (*text)[length] = '\0'; + fclose(f); + return length; +} + +void process_file(char *fname, Obj **env, Obj **expr) { + char *text = NULL; + size_t len = read_file(fname, &text); + if (len == 0) return; + + // Save old stdin + FILE *old_stdin = stdin; + // Create a single stream for the entire file + FILE *stream = fmemopen(text, len, "r"); + if (!stream) { + free(text); + error("Failed to create memory stream for %s", fname); + return; + } + + // Redirect stdin to the memory stream + stdin = stream; + + int eval_input(void *root, Obj **env, Obj **expr); + // Process expressions until we reach end of file + while (!feof(stream)) { + eval_input(gc_root, env, expr); + } + + // Cleanup + stdin = old_stdin; + fclose(stream); + free(text); +} + static void define_primitives(void *root, Obj **env) { add_primitive(root, env, "quote", prim_quote); add_primitive(root, env, "cons", prim_cons); @@ -974,30 +947,27 @@ static void define_primitives(void *root, Obj **env) { 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, "length", prim_length); - add_primitive(root, env, "reverse", prim_reverse); + add_primitive(root, env, "not", prim_not); add_primitive(root, env, "+", prim_plus); add_primitive(root, env, "-", prim_minus); add_primitive(root, env, "*", prim_mult); add_primitive(root, env, "/", prim_div); add_primitive(root, env, "mod", prim_modulo); - add_primitive(root, env, "=", prim_num_eq); - add_primitive(root, env, "eq", prim_eq); + add_primitive(root, env, "length", prim_length); + add_primitive(root, env, "reverse", prim_reverse); + add_primitive(root, env, "<", prim_lt); add_primitive(root, env, "<", prim_lt); add_primitive(root, env, ">", prim_gt); add_primitive(root, env, "<=", prim_lte); add_primitive(root, env, ">=", prim_gte); - add_primitive(root, env, "not", prim_not); - add_primitive(root, env, "and", prim_and); - add_primitive(root, env, "or", prim_or); 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, "atom", prim_atom); add_primitive(root, env, "if", prim_if); - add_primitive(root, env, "progn", prim_progn); + add_primitive(root, env, "=", prim_num_eq); + add_primitive(root, env, "eq", prim_eq); add_primitive(root, env, "print", prim_print); add_primitive(root, env, "println", prim_println); add_primitive(root, env, "string-concat", prim_string_concat); @@ -1011,42 +981,34 @@ static void define_primitives(void *root, Obj **env) { // Entry point //====================================================================== +extern void *memory; + void init_minilisp(Obj **env) { // Memory allocation - extern void *memory; extern void *alloc_semispace(); memory = alloc_semispace(); // Constants and primitives Symbols = Nil; - root = NULL; - *env = make_env(root, &Nil, &Nil); - define_constants(root, env); - define_primitives(root, env); + *env = make_env(NULL, &Nil, &Nil); + define_constants(NULL, env); + define_primitives(NULL, env); } -int eval_input(char *input, Obj **env, Obj **expr) { - if (setjmp(context) == 0){ - Obj *result = NULL; + +int eval_input(void *root, Obj **env, Obj **expr) { + if (setjmp(context) == 0) { while (true) { *expr = read_expr(root); if (!*expr) - break; - + return 0; if (*expr == Cparen) - error("Stray close parenthesis", (*expr)->line_num); + error("Stray close parenthesis"); if (*expr == Dot) - error("Stray dot", (*expr)->line_num); - - result = eval(root, env, expr); - } - - if (result) { - print(result); + error("Stray dot"); + print(eval(root, env, expr)); putc('\n', stdout); } - - return 0; } - else return 1; + return 0; } diff --git a/src/minilisp.h b/src/minilisp.h index 72751b6..dd6e479 100644 --- a/src/minilisp.h +++ b/src/minilisp.h @@ -44,7 +44,7 @@ typedef struct Obj { // The total size of the object, including "type" field, this field, the contents, and the // padding at the end of the object. - int size; + unsigned int size; int line_num; // The Lisp line where object was created @@ -85,6 +85,6 @@ typedef struct { } filepos_t; void init_minilisp(Obj **env); -int eval_input(char *input, Obj **env, Obj **expr); +int eval_input(void *input, Obj **env, Obj **expr); #endif // _MINILISP_H_ diff --git a/src/repl.c b/src/repl.c index 437142b..6b1991b 100644 --- a/src/repl.c +++ b/src/repl.c @@ -104,73 +104,6 @@ void minilisp(char *text, size_t length, bool with_repl, Obj **env, Obj **expr) void error(char *fmt, ...); -static size_t read_file(char *fname, char **text) { - size_t length = 0; - FILE *f = fopen(fname, "r"); - if (!f) { - error("Failed to load file %s", filepos.line_num, fname); - return 0; - } - - fseek(f, 0, SEEK_END); - length = ftell(f); - fseek(f, 0, SEEK_SET); - - *text = malloc(length + 1); - if (!*text) { - error("Out of memory.", filepos.line_num); - fclose(f); - return 0; - } - - size_t read = fread(*text, 1, length, f); - if (read != length) { - error("Failed to read entire file", filepos.line_num); - free(*text); - *text = NULL; - fclose(f); - return 0; - } - - (*text)[length] = '\0'; - fclose(f); - return length; -} - -void process_file(char *fname, Obj **env, Obj **expr) { - char *text; - size_t len = read_file(fname, &text); - if (len == 0) return; - - filepos.filename = strdup(fname); - filepos.file_len = len; - filepos.line_num = 1; - - // Save old stdin - FILE *old_stdin = stdin; - // Create a single stream for the entire file - FILE *stream = fmemopen(text, len, "r"); - if (!stream) { - free(text); - error("Failed to create memory stream for %s", filepos.line_num, fname); - return; - } - - // Redirect stdin to the memory stream - stdin = stream; - - // Process expressions until we reach end of file - while (!feof(stream)) { - eval_input(text, env, expr); - } - - // Cleanup - stdin = old_stdin; - fclose(stream); - free(text); - //if (filepos.filename) free(filepos.filename); -} - static bool no_history = false; static char *one_liner = NULL; static int num_files = 0; @@ -266,7 +199,7 @@ int main(int argc, char **argv) { parse_args(argc, argv); - DEFINE2(env, expr); + DEFINE2(gc_root, env, expr); init_minilisp(env); for (int i = 0; i < num_files; i++) { diff --git a/test.sh b/test.sh index f4c2991..5e47517 100755 --- a/test.sh +++ b/test.sh @@ -7,13 +7,13 @@ function fail() { } function do_run() { - error=$(./minilisp -r -x "$3" 2>&1 > /dev/null) + error=$(echo "$3" | ./minilisp 2>&1 > /dev/null) if [ -n "$error" ]; then echo FAILED fail "$error" fi - result=$(./minilisp -r -x "$3" 2> /dev/null | tail -1) + result=$(echo "$3" | ./minilisp 2> /dev/null | tail -1) if [ "$result" != "$2" ]; then echo FAILED fail "$2 expected, but got $result" @@ -48,20 +48,9 @@ run 'unary -' -3 '(- 3)' run '-' -2 '(- 3 5)' run '-' -9 '(- 3 5 7)' -run 'not' '()' '(not t)' -run 'not' '()' '(not 1)' -run 'not' 't' '(not ())' - -run 'and' 't' '(and)' -run 'and' '2' '(and 1 2)' -run 'and' '()' '(and 1 ())' -run 'and' '()' '(and () ())' -run 'and' '()' '(and 1 () 2)' - -run 'or' '()' '(or)' -run 'or' '1' '(or 1 2)' -run 'or' '2' '(or () 2)' -run 'or' '()' '(or () ())' +run '<' t '(< 2 3)' +run '<' '()' '(< 3 3)' +run '<' '()' '(< 4 3)' run 'literal list' '(a b c)' "'(a b c)" run 'literal list' '(a b . c)' "'(a b . c)" @@ -75,30 +64,11 @@ run cdr "(b c)" "(cdr '(a b c))" run setcar "(x . b)" "(define obj (cons 'a 'b)) (setcar obj 'x) obj" -run length 0 "(length)" -run length 1 "(length '())" -run length 2 "(length '(()t))" -run length 3 "(length '(1 () 3))" -run length 0 "(length \"\")" -run length 5 "(length \"1 2 3\")" -run length 3 "(length '(a) t 42)" - -run reverse "()" "(reverse)" -run reverse "(c b a)" "(reverse '(a b c))" -run reverse "(t c (a . b))" "(reverse '((a . b) c t))" -run reverse "4321" "(reverse \"1234\")" -run reverse "(c b a)" "(reverse \"a\" \"b\" \"c\")" - # Comments run comment 5 " ; 2 5 ; 3" -# Introspection -run atom '()' "(atom '(a b))" -run atom t "(atom \"\")" -run atom t "(atom ())" - # Global variables run define 7 '(define x 7) x' run define 10 '(define x 7) (+ x 3)' @@ -146,8 +116,6 @@ run eq t "(eq 'foo 'foo)" run eq t "(eq + +)" run eq '()' "(eq 'foo 'bar)" run eq '()' "(eq + 'bar)" -run eq '()' '(eq "hello" "Hello")' -run eq t '(eq "hello" "hello")' # gensym run gensym G__0 '(gensym)' @@ -167,9 +135,10 @@ run restargs '(3 5 7)' '(defun f (x . y) (cons x y)) (f 3 5 7)' run restargs '(3)' '(defun f (x . y) (cons x y)) (f 3)' # strings -run 'symbol->string' 'twelve' " - (define twelve 12) - (symbol->string 'twelve)" +run 'string-concat' 'one & two and 3' '(string-concat "one" " & " "two" " and " 3)' +#run 'symbol->string' 'twelve' " +# (define twelve 12) +# (symbol->string 'twelve)" run 'string->symbol' 'twelve' '(string->symbol "twelve")' # Lexical closures @@ -177,13 +146,13 @@ run closure 3 '(defun call (f) ((lambda (var) (f)) 5)) ((lambda (var) (call (lambda () var))) 3)' run counter 3 ' -(define counter - ((lambda (val) - (lambda () (setq val (+ val 1)) val)) - 0)) -(counter) -(counter) -(counter)' + (define counter + ((lambda (val) + (lambda () (setq val (+ val 1)) val)) + 0)) + (counter) + (counter) + (counter)' #run progn 'I own 10 cents' '(progn (print "I own ") # (defun add(x y)(+ x y)) @@ -213,4 +182,4 @@ run macroexpand '(if (= x 0) (print x))' " # Sum from 0 to 10 -run recursion 55 '(defun f (x) (if (= x 0) 0 (+ (f (+ x -1)) x))) (f 10)' +run recursion 55 '(defun f (x) (if (= x 0) 0 (+ (f (+ x -1)) x))) (f 10)' \ No newline at end of file