diff --git a/README.md b/README.md index f727edc..14de649 100644 --- a/README.md +++ b/README.md @@ -78,6 +78,18 @@ CTRL-Z SUSPEND PROCESS ``` The REPL also saves the history of commands in the file history.txt +<<<<<<< HEAD +======= + +Known bugs: +* Operators "and" and "or" do not work like their typical Lisp counterpart +because they evaluate all their operands at the same time instead of one +by one. + + +Original README +======= +>>>>>>> 0822c20 (Update README) This file is loaded at startup, so one can recall previous commands. Future improvements: @@ -260,22 +272,23 @@ exhaustion error. `(progn expr expr ...)` executes several expressions in sequence. - (progn (print "I own ") - (defun add(x y)(+ x y)) - (println (add 3 7) " cents")) ; -> prints "I own 10 cents" + ( progn (print "I own ") + (defun add(x y)(+ x y)) + (println (add 3 7) " cents") ) ; -> prints "I own 10 cents" ### Equivalence test operators `eq` takes two arguments and returns `t` if the objects are the same. What `eq` really does is a pointer comparison, so two objects happened to have the same contents but actually different are considered to not be the same by `eq`. +`eq` can also compare two strings. ### String functions -`string=` compares two strings. +`eq` compares two strings. - (string= "Hello" "Hello") ; -> t - (string= "Hello" "World") ; -> () + (eq "Hello" "Hello") ; -> t + (eq "Hello" "hello") ; -> () `string-concat` concatenates strings. diff --git a/examples/hanoi.lisp b/examples/hanoi.lisp index 0e1c680..cc37abe 100644 --- a/examples/hanoi.lisp +++ b/examples/hanoi.lisp @@ -1,4 +1,4 @@ -(defun list (x . y) (cons x y)) +(load "examples/library.lisp") (defun hanoi-print (disk from to) (println (string-concat "Move disk " disk @@ -16,4 +16,4 @@ (defun hanoi (n) (hanoi-move n 'L 'M 'R)) -(hanoi 5) \ No newline at end of file +(hanoi 5) diff --git a/examples/library.lisp b/examples/library.lisp new file mode 100644 index 0000000..454a642 --- /dev/null +++ b/examples/library.lisp @@ -0,0 +1,146 @@ +;; +;; Simple library of useful functions and macros +;; + +(defun list (x . y) + (cons x y)) + + +;; (and e1 e2 ...) +;; => (if e1 (and e2 ...)) +;; (and e1) +;; => e1 +(defmacro and (expr . rest) + (if rest + (list 'if expr (cons 'and rest)) + expr)) + +;; (or e1 e2 ...) +;; => (let e1 +;; (if (or e2 ...))) +;; (or e1) +;; => e1 +;; +;; The reason to use the temporary variables is to avoid evaluating the +;; arguments more than once. +(defmacro or (expr . rest) + (if rest + (let var (gensym) + (list 'let var expr + (list 'if var var (cons 'or rest)))) + expr)) + +;; (let var val body ...) +;; => ((lambda (var) body ...) val) +(defmacro let (var val . body) + (cons (cons 'lambda (cons (list var) body)) + (list val))) + +;; (when expr body ...) +;; => (if expr (progn body ...)) +(defmacro when (expr . body) + (cons 'if (cons expr (list (cons 'progn body))))) + +;; (unless expr body ...) +;; => (if expr () body ...) +(defmacro unless (expr . body) + (cons 'if (cons expr (cons () body)))) + +;;; +;;; List operators +;;; + +;;; Applies each element of lis to fn, and returns their return values as a list. +(defun map (lis fn) + (when lis + (cons (fn (car lis)) + (map (cdr lis) fn)))) + +(defun reduce (fn lst init) + (if (eq () lst) + init + (reduce fn + (cdr lst) + (fn init (car lst))))) + +;; Applies each element of lis to pred. If pred returns a true value, terminate +;; the evaluation and returns pred's return value. If all of them return (), +;; returns (). +(defun any (lis pred) + (when lis + (or (pred (car lis)) + (any (cdr lis) pred)))) + +;; returns t if elem exists in list l +(defun member (l elem) + (any l (lambda (x) (or (eq x elem) (= x elem))))) + +;; Returns nth element of lis. +(defun nth (lis n) + (if (= n 0) + (car lis) + (nth (cdr lis) (- n 1)))) + +;; Returns the nth tail of lis. +(defun nth-tail (lis n) + (if (= n 0) + lis + (nth-tail (cdr lis) (- n 1)))) + +;; Returns a list consists of m .. n-1 integers. +(defun %iota (m n) + (unless (<= n m) + (cons m (%iota (+ m 1) n)))) + +;; Returns a list consists of 0 ... n-1 integers. +(defun iota (n) (%iota 0 n)) + +;; Returns a new list whose length is len and all members are init. +(defun make-list (len init) + (unless (= len 0) + (cons init (make-list (- len 1) init)))) + +;; Applies fn to each element of lis. +(defun for-each (lis fn) + (or (not lis) + (progn (fn (car lis)) + (for-each (cdr lis) fn)))) + +; Concatenates and flattens lists into a single list +(defun append (first . rest) + (if (eq () rest) + first + (append2 first + (append-reduce rest)))) + +(defun append2 (x y) + (if (eq () x) + y + (cons (car x) + (append2 (cdr x) y)))) + +(defun append-reduce (lists) + (if (eq () (cdr lists)) + (car lists) + (append2 (car lists) + (append-reduce (cdr lists))))) + +(defun filter (pred lst) + (if (eq () lst) + () + (if (pred (car lst)) + (cons (car lst) + (filter pred (cdr lst))) + (filter pred (cdr lst))))) + +(defun quicksort (lst) + (if (eq () lst) + () + (if (eq () (cdr lst)) + lst + (let pivot (car lst) + (append + (quicksort (filter (lambda(x) (< x pivot)) (cdr lst))) + (cons pivot ()) + (quicksort (filter (lambda(x) (>= x pivot)) (cdr lst)))) )))) + \ No newline at end of file diff --git a/examples/life.lisp b/examples/life.lisp index f6f2968..72b2b03 100644 --- a/examples/life.lisp +++ b/examples/life.lisp @@ -2,100 +2,7 @@ ;;; Conway's game of life ;;; -;; (progn expr ...) -;; => ((lambda () expr ...)) -;(defmacro progn (expr . rest) -; (list (cons 'lambda (cons () (cons expr rest))))) - -(defun list (x . y) - (cons x y)) - - -;(defun not (x) -; (if x () t)) - -;; (let var val body ...) -;; => ((lambda (var) body ...) val) -(defmacro let (var val . body) - (cons (cons 'lambda (cons (list var) body)) - (list val))) - -;; (and e1 e2 ...) -;; => (if e1 (and e2 ...)) -;; (and e1) -;; => e1 -(defmacro and (expr . rest) - (if rest - (list 'if expr (cons 'and rest)) - expr)) - -;; (or e1 e2 ...) -;; => (let e1 -;; (if (or e2 ...))) -;; (or e1) -;; => e1 -;; -;; The reason to use the temporary variables is to avoid evaluating the -;; arguments more than once. -(defmacro or (expr . rest) - (if rest - (let var (gensym) - (list 'let var expr - (list 'if var var (cons 'or rest)))) - expr)) - -;; (when expr body ...) -;; => (if expr (progn body ...)) -(defmacro when (expr . body) - (cons 'if (cons expr (list (cons 'progn body))))) - -;; (unless expr body ...) -;; => (if expr () body ...) -(defmacro unless (expr . body) - (cons 'if (cons expr (cons () body)))) - -;;; -;;; Numeric operators -;;; - -;(defun <= (e1 e2) -; (or (< e1 e2) -; (= e1 e2))) - -;;; -;;; List operators -;;; - -;;; Applies each element of lis to fn, and returns their return values as a list. -(defun map (lis fn) - (when lis - (cons (fn (car lis)) - (map (cdr lis) fn)))) - -;; Returns nth element of lis. -(defun nth (lis n) - (if (= n 0) - (car lis) - (nth (cdr lis) (- n 1)))) - -;; Returns the nth tail of lis. -(defun nth-tail (lis n) - (if (= n 0) - lis - (nth-tail (cdr lis) (- n 1)))) - -;; Returns a list consists of m .. n-1 integers. -(defun %iota (m n) - (unless (<= n m) - (cons m (%iota (+ m 1) n)))) - -;; Returns a list consists of 0 ... n-1 integers. -(defun iota (n) - (%iota 0 n)) - -;;; -;;; Main -;;; +(load "examples/library.lisp") (define width 10) (define height 10) diff --git a/examples/nqueens.lisp b/examples/nqueens.lisp index 3795e87..c1d6220 100644 --- a/examples/nqueens.lisp +++ b/examples/nqueens.lisp @@ -8,119 +8,7 @@ ;;; This program solves N-queens puzzle by depth-first backtracking. ;;; -;;; -;;; Basic macros -;;; -;;; Because the language does not have quasiquote, we need to construct an -;;; expanded form using cons and list. -;;; - -;; (progn expr ...) -;; => ((lambda () expr ...)) -;(defmacro progn (expr . rest) -; (list (cons 'lambda (cons () (cons expr rest))))) - -(defun list (x . y) (cons x y)) - -;(defun not (x) (if x () t)) - -;; (let1 var val body ...) -;; => ((lambda (var) body ...) val) -(defmacro let1 (var val . body) - (cons (cons 'lambda (cons (list var) body)) - (list val))) - -;; (and e1 e2 ...) -;; => (if e1 (and e2 ...)) -;; (and e1) -;; => e1 -(defmacro and (expr . rest) - (if rest - (list 'if expr (cons 'and rest)) - expr)) - -;; (or e1 e2 ...) -;; => (let1 e1 -;; (if (or e2 ...))) -;; (or e1) -;; => e1 -;; -;; The reason to use the temporary variables is to avoid evaluating the -;; arguments more than once. -(defmacro or (expr . rest) - (if rest - (let1 var (gensym) - (list 'let1 var expr - (list 'if var var (cons 'or rest)))) - expr)) - -;; (when expr body ...) -;; => (if expr (progn body ...)) -(defmacro when (expr . body) - (cons 'if (cons expr (list (cons 'progn body))))) - -;; (unless expr body ...) -;; => (if expr () body ...) -(defmacro unless (expr . body) - (cons 'if (cons expr (cons () body)))) - -;;; -;;; Numeric operators -;;; - -;(defun <= (e1 e2) -; (or (< e1 e2) -; (= e1 e2))) - -;;; -;;; List operators -;;; - -;; Applies each element of lis to pred. If pred returns a true value, terminate -;; the evaluation and returns pred's return value. If all of them return (), -;; returns (). -(defun any (lis pred) - (when lis - (or (pred (car lis)) - (any (cdr lis) pred)))) - -;;; Applies each element of lis to fn, and returns their return values as a list. -(defun map (lis fn) - (when lis - (cons (fn (car lis)) - (map (cdr lis) fn)))) - -;; Returns nth element of lis. -(defun nth (lis n) - (if (= n 0) - (car lis) - (nth (cdr lis) (- n 1)))) - -;; Returns the nth tail of lis. -(defun nth-tail (lis n) - (if (= n 0) - lis - (nth-tail (cdr lis) (- n 1)))) - -;; Returns a list consists of m .. n-1 integers. -(defun %iota (m n) - (unless (<= n m) - (cons m (%iota (+ m 1) n)))) - -;; Returns a list consists of 0 ... n-1 integers. -(defun iota (n) - (%iota 0 n)) - -;; Returns a new list whose length is len and all members are init. -(defun make-list (len init) - (unless (= len 0) - (cons init (make-list (- len 1) init)))) - -;; Applies fn to each element of lis. -(defun for-each (lis fn) - (or (not lis) - (progn (fn (car lis)) - (for-each (cdr lis) fn)))) +(load "examples/library.lisp") ;;; ;;; N-queens solver @@ -136,17 +24,17 @@ (defun get (board x y) (nth (nth board x) y)) -;; Set symbol "@" to location (x, y). +;; Set symbol "Q" to location (x, y). (defun set (board x y) - (setcar (nth-tail (nth board x) y) '@)) + (setcar (nth-tail (nth board x) y) 'Q)) ;; Set symbol "x" to location (x, y). (defun clear (board x y) (setcar (nth-tail (nth board x) y) 'x)) -;; Returns true if location (x, y)'s value is "@". +;; Returns true if location (x, y)'s value is "Q". (defun set? (board x y) - (eq (get board x y) '@)) + (eq (get board x y) 'Q)) ;; Print out the given board. (defun print (board) @@ -164,11 +52,11 @@ ;; Check if there's no conflicting queen upward (set? board n y) ;; Upper left - (let1 z (+ y (- n x)) + (let z (+ y (- n x)) (and (<= 0 z) (set? board n z))) ;; Upper right - (let1 z (+ y (- x n)) + (let z (+ y (- x n)) (and (< z board-size) (set? board n z))))))) @@ -179,7 +67,7 @@ ;; Problem solved (progn (print board) (println '$)) - (for-each (iota board-size) + (map (iota board-size) (lambda (y) (unless (conflict? board x y) (set board x y) diff --git a/src/minilisp.c b/src/minilisp.c index 2dac0eb..f769aea 100644 --- a/src/minilisp.c +++ b/src/minilisp.c @@ -174,13 +174,13 @@ static Obj *read_list(void *root) { for (;;) { *obj = read_expr(root); if (!*obj) - error("Unclosed parenthesis", (*obj)->line_num); + error("Unclosed parenthesis", filepos.line_num); 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)->line_num); + error("Closed parenthesis expected after dot", filepos.line_num); Obj *ret = reverse(*head); (*head)->cdr = *last; return ret; @@ -377,7 +377,7 @@ static Obj *push_env(void *root, Obj **env, Obj **vars, Obj **vals) { for (; (*vars)->type == TCELL; *vars = (*vars)->cdr, *vals = (*vals)->cdr) { if ((*vals)->type != TCELL) error("Cannot apply function: number of argument does not match", - (*vals)->line_num); + (*vars)->line_num); *sym = (*vars)->car; *val = (*vals)->car; *map = acons(root, sym, val, map); @@ -660,51 +660,23 @@ static Obj *prim_reverse(void *root, Obj **env, Obj **list) { } } -// (+ ...) -static Obj *prim_plus(void *root, Obj **env, Obj **list) { - long long sum = 0; - for (Obj *args = eval_list(root, env, list); args != Nil; args = args->cdr) { - if (args->car->type != TINT) - error("+ takes only numbers", (*list)->line_num); - sum += args->car->value; - } - return make_int(root, sum); -} - -// (* ...) -static Obj *prim_mult(void *root, Obj **env, Obj **list) { - long long prod = 1; - for (Obj *args = eval_list(root, env, list); args != Nil; args = args->cdr) { - if (args->car->type != TINT) - error("* takes only numbers", (*list)->line_num); - prod *= args->car->value; - } - return make_int(root, prod); -} - -// (/ ...) -static Obj *prim_div(void *root, Obj **env, Obj **list) { - Obj *args = eval_list(root, env, list); - long long r = args->car->value; - for (Obj *p = args->cdr; p != Nil; p = p->cdr){ - if (p->car->type != TINT) - error("/ takes only numbers", (*list)->line_num); - r /= p->car->value; - } - return make_int(root, r); +#define PRIM_ARITHMETIC_OP(PRIM_OP, OP, OPEQ) \ +static Obj *PRIM_OP(void *root, Obj **env, Obj **list) { \ + Obj *args = eval_list(root, env, 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); \ + r OPEQ p->car->value; \ + } \ + return make_int(root, r); \ } -// (% ...) -static Obj *prim_modulo(void *root, Obj **env, Obj **list) { - Obj *args = eval_list(root, env, list); - long long r = args->car->value; - for (Obj *p = args->cdr; p != Nil; p = p->cdr){ - if (p->car->type != TINT) - error("mod takes only numbers", (*list)->line_num); - r %= p->car->value; - } - return make_int(root, r); -} +// (+ ...) +PRIM_ARITHMETIC_OP(prim_plus, +, += ) +PRIM_ARITHMETIC_OP(prim_mult, *, *= ) +PRIM_ARITHMETIC_OP(prim_div , /, /= ) +PRIM_ARITHMETIC_OP(prim_modulo, %, %= ) // (- ...) static Obj *prim_minus(void *root, Obj **env, Obj **list) { @@ -721,16 +693,16 @@ static Obj *prim_minus(void *root, Obj **env, Obj **list) { } // (op ) -#define PRIM_COMPARISON_OP(PRIM_OP, OP) \ -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);\ - 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); \ - return x->value OP y->value ? True : Nil; \ +#define PRIM_COMPARISON_OP(PRIM_OP, OP) \ +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); \ + 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); \ + return x->value OP y->value ? True : Nil; \ } PRIM_COMPARISON_OP(prim_num_eq, ==) @@ -901,9 +873,17 @@ static Obj *prim_if(void *root, Obj **env, Obj **list) { // (eq expr expr) static Obj *prim_eq(void *root, Obj **env, Obj **list) { if (length(*list) != 2) - error("Malformed eq", (*list)->line_num); + error("eq takes 2 arguments only", (*list)->line_num); Obj *values = eval_list(root, env, list); - return values->car == values->cdr->car ? True : Nil; + Obj *first = values->car; + Obj *second = values->cdr->car; + if (first->type == TSTRING){ + 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); + } + return first == second ? True : Nil; } // String primitives @@ -972,18 +952,6 @@ static Obj *prim_string_to_symbol(void *root, Obj **env, Obj **list) { return intern(root, args->car->name); } -// String comparison -static Obj *prim_string_eq(void *root, Obj **env, Obj **list) { - Obj *args = eval_list(root, env, list); - if (length(args) != 2) - error("string= requires 2 arguments", (*list)->line_num); - - if (args->car->type != TSTRING || args->cdr->car->type != TSTRING) - error("string= arguments must be strings", (*list)->line_num); - - return strcmp(args->car->name, args->cdr->car->name) == 0 ? True : Nil; -} - static void add_primitive(void *root, Obj **env, char *name, Primitive *fn) { DEFINE2(sym, prim); *sym = intern(root, name); @@ -1035,7 +1003,6 @@ static void define_primitives(void *root, Obj **env) { add_primitive(root, env, "string-concat", prim_string_concat); add_primitive(root, env, "symbol->string", prim_symbol_to_string); add_primitive(root, env, "string->symbol", prim_string_to_symbol); - add_primitive(root, env, "string=", prim_string_eq); add_primitive(root, env, "load", prim_load); add_primitive(root, env, "exit", prim_exit); } diff --git a/src/repl.c b/src/repl.c index 14ea0e8..437142b 100644 --- a/src/repl.c +++ b/src/repl.c @@ -108,7 +108,7 @@ 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); + error("Failed to load file %s", filepos.line_num, fname); return 0; } @@ -118,14 +118,14 @@ static size_t read_file(char *fname, char **text) { *text = malloc(length + 1); if (!*text) { - error("Out of memory."); + 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"); + error("Failed to read entire file", filepos.line_num); free(*text); *text = NULL; fclose(f); @@ -152,7 +152,7 @@ void process_file(char *fname, Obj **env, Obj **expr) { FILE *stream = fmemopen(text, len, "r"); if (!stream) { free(text); - error("Failed to create memory stream"); + error("Failed to create memory stream for %s", filepos.line_num, fname); return; } diff --git a/test.sh b/test.sh index deff59d..f4c2991 100755 --- a/test.sh +++ b/test.sh @@ -146,6 +146,8 @@ 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)' @@ -164,6 +166,12 @@ run args 15 '(defun f (x y z) (+ x y z)) (f 3 5 7)' 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->symbol' 'twelve' '(string->symbol "twelve")' + # Lexical closures run closure 3 '(defun call (f) ((lambda (var) (f)) 5)) ((lambda (var) (call (lambda () var))) 3)'