Fix some bugs

lisp/kernel.gl

@@ -1,5 +1,6 @@
 ;; -*- mode: lisp-data -*-
 
+;; Defining macros and functions
 (fset 'defmacro (cons 'macro
                       (lambda (name lambda-list &rest body)
                         "Define NAME to be a macro."
@@ -18,11 +19,99 @@
                (list 'declare (list 'name name))
                body)))
 
-(defun princln (datum &optional print-char-fun)
+;; List indicies
-  "`princ' DATUM to PRINT-CHAR-FUN. Then print a newline."
+(defun first (list)
-  (princ datum print-char-fun)
+  "Return the first element of LIST."
-  (funcall (or print-char-fun 'write-byte) ?\n))
+  (car list))
+(defun second (list)
+  "Return the second element of LIST."
+  (car (cdr list)))
+(defun third (list)
+  "Return the third element of LIST."
+  (car (cdr (cdr list))))
+(defun fourth (list)
+  "Return the fourth element of LIST."
+  (car (cdr (cdr (cdr list)))))
+(defun fifth (list)
+  "Return the fifth element of LIST."
+  (car (cdr (cdr (cdr (cdr list))))))
+(defun sixth (list)
+  "Return the sixth element of LIST."
+  (car (cdr (cdr (cdr (cdr (cdr list)))))))
+(defun seventh (list)
+  "Return the seventh element of LIST."
+  (car (cdr (cdr (cdr (cdr (cdr (cdr list))))))))
+(defun eighth (list)
+  "Return the eighth element of LIST."
+  (car (cdr (cdr (cdr (cdr (cdr (cdr (cdr list)))))))))
+(defun ninth (list)
+  "Return the ninth element of LIST."
+  (car (cdr (cdr (cdr (cdr (cdr (cdr (cdr (cdr list))))))))))
+(defun tenth (list)
+  "Return the tenth element of LIST."
+  (car (cdr (cdr (cdr (cdr (cdr (cdr (cdr (cdr (cdr list)))))))))))
 
-(let ((a [0]))
+;; Utility macros
-  (aset a 1 'a)
+(defmacro when (cond &rest body)
-  (princln a))
+  "Evaluate BODY if COND evaluates to non-nil."
+  (list 'if cond
+        (cons 'progn body)))
+
+(defmacro unless (cond &rest body)
+  "Evaluate BODY if COND evaluates to nil."
+  (list* 'if cond
+        nil
+        body))
+
+(defmacro dolist (spec &rest body)
+  "Evaluate BODY for each element of a list.
+Spec is of the form (VARIABLE LIST &optional RETURN-FORM)."
+  (unless (and (or (length= spec 2) (length= spec 3))
+               (symbolp (car spec)))
+    (signal 'error (list spec)))
+  (let ((list-var (make-symbol "--dolist-list--"))
+        (cur-var (make-symbol "--dolist-cur--")))
+    (list 'let (list (list list-var (second spec))
+                     cur-var)
+          (list 'while list-var
+                (list 'setq cur-var (list 'car list-var))
+                (list* 'let (list (list (first spec) cur-var))
+                       body)
+                (list 'setq list-var (list 'cdr list-var)))
+          (when (third spec)
+            (list 'let (list (list (first spec) cur-var))
+                  (third spec))))))
+
+;; List functions
+(defun mapcar (function list)
+  "Apply FUNCTION to each element of LIST and return a list of the results."
+  (let (start end)
+    (dolist (elt list)
+      (let ((res (funcall function elt)))
+        (if (null start)
+            (progn
+              (setq start (list res)
+                    end start))
+          (rplacd end (list res))
+          (setq end (cdr end)))))
+    start))
+
+(defun mapc (function list)
+  "Apply FUNCTION to each element of LIST, then return LIST."
+  (dolist (elt list list)
+    (funcall function elt)))
+
+;; Some other functions
+(defun terpri (&optional print-char-fun)
+  "Print a newline to PRINT-CHAR-FUN, then flush it."
+  (let ((fun (or print-char-fun #'write-byte)))
+    (funcall fun ?\n)
+    (funcall fun nil)))
+
+(defun princln (datum &optional print-char-fun)
+  "`princ' DATUM to PRINT-CHAR-FUN, then do a `terpri'."
+  (princ datum print-char-fun)
+  (terpri print-char-fun))
+
+(princln (mapc (lambda (x) (+ x 1))
+                 '(1 2 3)))

src/function.c

@@ -245,6 +245,7 @@ enum ProcessArgsResult {
     PROCESS_ARGS_TOO_MANY,
     PROCESS_ARGS_NO_KEY_VALUE,
     PROCESS_ARGS_BAD_KEY,
+    PROCESS_ARGS_DOTTED,
     PROCESS_ARGS_N_ERRORS,
 };
 
@@ -255,6 +256,7 @@ static const char *process_args_strerror(enum ProcessArgsResult status) {
         [PROCESS_ARGS_TOO_MANY] = "Too many arguments",
         [PROCESS_ARGS_NO_KEY_VALUE] = "Key without a value",
         [PROCESS_ARGS_BAD_KEY] = "Unknown key",
+        [PROCESS_ARGS_DOTTED] = "Dotted argument list",
     };
     return MSGS[status];
 }
@@ -276,6 +278,8 @@ process_complex_native_args(LispFunction *fobj, LispVal *args,
     while (rem_req--) {
         if (NILP(args)) {
             return PROCESS_ARGS_TOO_FEW;
+        } else if (!CONSP(args)) {
+            return PROCESS_ARGS_DOTTED;
         }
         out[idx++] = XCAR(args);
         args = XCDR(args);
@@ -283,6 +287,8 @@ process_complex_native_args(LispFunction *fobj, LispVal *args,
     while (rem_opt--) {
         if (NILP(args)) {
             return PROCESS_ARGS_OK;
+        } else if (!CONSP(args)) {
+            return PROCESS_ARGS_DOTTED;
         }
         out[idx++] = XCAR(args);
         args = XCDR(args);
@@ -291,6 +297,9 @@ process_complex_native_args(LispFunction *fobj, LispVal *args,
         return PROCESS_ARGS_TOO_MANY;
     }
     if (!NILP(fobj->args.rest)) {
+        if (!LISTP(args) || !NILP(Fdotted_list_p(args))) {
+            return PROCESS_ARGS_DOTTED;
+        }
         *rest_idx = idx;
         out[idx++] = args;
     } else {
@@ -300,7 +309,9 @@ process_complex_native_args(LispFunction *fobj, LispVal *args,
         return PROCESS_ARGS_OK;
     }
     while (!NILP(args)) {
-        if (NILP(XCDR(args))) {
+        if (!CONSP(args)) {
+            return PROCESS_ARGS_DOTTED;
+        } else if (NILP(XCDR(args))) {
             return PROCESS_ARGS_NO_KEY_VALUE;
         }
         LispVal *entry = Fgethash(fobj->args.kw, XCAR(args), Qnil);
@@ -390,12 +401,17 @@ push_interpreted_args_to_lexenv(LispFunction *fobj, LispVal *args) {
     while (!NILP(rem_req)) {
         if (NILP(args)) {
             return PROCESS_ARGS_TOO_FEW;
+        } else if (!CONSP(args)) {
+            return PROCESS_ARGS_DOTTED;
         }
         new_lexical_variable(XCAR(rem_req), XCAR(args));
         args = XCDR(args);
         rem_req = XCDR(rem_req);
     }
     while (!NILP(rem_opt) && !NILP(args)) {
+        if (!CONSP(args)) {
+            return PROCESS_ARGS_DOTTED;
+        }
         push_optional_argument_to_lexenv(XCAR(rem_opt), XCAR(args));
         args = XCDR(args);
         rem_opt = XCDR(rem_opt);
@@ -405,6 +421,9 @@ push_interpreted_args_to_lexenv(LispFunction *fobj, LispVal *args) {
         rem_opt = XCDR(rem_opt);
     }
     if (!NILP(fobj->args.rest)) {
+        if (!LISTP(args) || !NILP(Fdotted_list_p(args))) {
+            return PROCESS_ARGS_DOTTED;
+        }
         new_lexical_variable(fobj->args.rest, args);
     }
     if (NILP(fobj->args.kw)) {
@@ -413,6 +432,9 @@ push_interpreted_args_to_lexenv(LispFunction *fobj, LispVal *args) {
     }
     LispVal *seen_kw = make_hash_table_no_gc(Qnil, Qnil);
     while (!NILP(args)) {
+        if (!CONSP(args)) {
+            return PROCESS_ARGS_DOTTED;
+        }
         if (NILP(XCDR(args))) {
             release_hash_table_no_gc(seen_kw);
             return PROCESS_ARGS_NO_KEY_VALUE;
@@ -494,7 +516,7 @@ DEFUN(apply, "apply", (LispVal * func, LispVal *args), "(func &rest args)",
     if (NILP(args)) {
         return CALL0(func);
     }
-    if (NILP(Fproper_list_p(XCDR(Flast(args))))) {
+    if (NILP(Fproper_list_p(XCAR(Flast(args))))) {
         signal_type_error(args, Qlist);
     }
     return Ffuncall(func, Flist_star(XCAR(args), XCDR(args)));

src/interp.c

@@ -105,8 +105,7 @@ DEFSPECIAL(setq, "setq", (LispVal * bindings), "(&rest bindings)", "") {
                     LIST(LISP_LITSTR("Wrong number of arguments.")));
     }
     LispVal *value = Qnil;
-    for (LispVal *rest = bindings; !NILP(bindings);
+    for (LispVal *rest = bindings; !NILP(rest); rest = XCDR(XCDR(rest))) {
-         bindings = XCDR(XCDR(bindings))) {
         LispVal *name = FIRST(rest);
         value = eval(SECOND(rest));
         set_lexical_variable(name, value);
@@ -118,14 +117,16 @@ DEFSPECIAL(let, "let", (LispVal * bindings, LispVal *body),
            "(bindings &rest body)", "") {
     CHECK_LISTP(bindings);
     StackFrame *stack_ref = LISP_STACK_REF();
-    DOLIST(binding, bindings) {
+    bindings = Fcopy_list(bindings);
+    DOTAILS(rest, bindings) {
+        LispVal *binding = XCAR(rest);
         if (CONSP(binding) && list_length_eq(binding, 2)) {
-            if (!SYMBOLP(XCAR(binding))) {
+            CHECK_TYPE(XCAR(binding), TYPE_SYMBOL);
-                signal_type_error(XCAR(binding), LIST(Qsymbol));
+            binding = Fcopy_list(binding);
-            }
+            RPLACA(rest, binding);
             RPLACA(XCDR(binding), eval(SECOND(binding)));
         } else if (!SYMBOLP(binding)) {
-            signal_type_error(binding, LIST(Qsymbol));
+            signal_type_error(binding, LIST(Qsymbol, Qlist));
         }
     }
     push_copy_lexenv();
@@ -140,6 +141,23 @@ DEFSPECIAL(let, "let", (LispVal * bindings, LispVal *body),
     return UNWIND_AND_RETURN(stack_ref, Fprogn(body));
 }
 
+DEFSPECIAL(let_star, "let*", (LispVal * bindings, LispVal *body),
+           "(bindings &rest body)", "") {
+    CHECK_LISTP(bindings);
+    StackFrame *stack_ref = LISP_STACK_REF();
+    DOLIST(binding, bindings) {
+        if (CONSP(binding) && list_length_eq(binding, 2)) {
+            CHECK_TYPE(XCAR(binding), TYPE_SYMBOL);
+            new_lexical_variable(FIRST(binding), eval(SECOND(binding)));
+        } else if (SYMBOLP(binding)) {
+            new_lexical_variable(binding, Qnil);
+        } else {
+            signal_type_error(binding, LIST(Qsymbol, Qlist));
+        }
+    }
+    return UNWIND_AND_RETURN(stack_ref, Fprogn(body));
+}
+
 DEFSPECIAL(if, "if", (LispVal * cond, LispVal *then, LispVal *otherwise),
            "(cond then &rest else)", "") {
     StackFrame *stack_ref = LISP_STACK_REF();
@@ -180,6 +198,14 @@ DEFUN(not, "not", (LispVal * datum), "(datum)", "") {
     return NILP(datum) ? Qt : Qnil;
 }
 
+DEFSPECIAL(while, "while", (LispVal * cond, LispVal *body), "(cond &rest body)",
+           "") {
+    while (!NILP(eval(cond))) {
+        Fprogn(body);
+    }
+    return Qnil;
+}
+
 DEFSPECIAL(block, "block", (LispVal * name, LispVal *body), "(name &rest body)",
            "") {
     CHECK_TYPE(name, TYPE_SYMBOL);

src/interp.h

@@ -8,11 +8,13 @@ DECLARE_FUNCTION(eval, (LispVal * form, LispVal *lexenv));
 DECLARE_FUNCTION(progn, (LispVal * forms));
 DECLARE_FUNCTION(setq, (LispVal * bindings));
 DECLARE_FUNCTION(let, (LispVal * bindings, LispVal *body));
+DECLARE_FUNCTION(let_star, (LispVal * bindings, LispVal *body));
 DECLARE_FUNCTION(if, (LispVal * cond, LispVal *then, LispVal *otherwise));
 DECLARE_FUNCTION(and, (LispVal * forms));
 DECLARE_FUNCTION(or, (LispVal * forms));
 DECLARE_FUNCTION(null, (LispVal * datum));
 DECLARE_FUNCTION(not, (LispVal * datum));
+DECLARE_FUNCTION(while, (LispVal * cond, LispVal *body));
 
 DECLARE_FUNCTION(block, (LispVal * name, LispVal *body));
 DECLARE_FUNCTION(return_from, (LispVal * name, LispVal *value));

src/list.c

@@ -53,6 +53,20 @@ DEFUN(cdr, "cdr", (LispVal * list), "(list)", "") {
     return NILP(list) ? Qnil : XCDR(list);
 }
 
+DEFUN(rplaca, "rplaca", (LispVal * cons, LispVal *newcar), "(cons newcar)",
+      "") {
+    CHECK_TYPE(cons, TYPE_CONS);
+    RPLACA(cons, newcar);
+    return newcar;
+}
+
+DEFUN(rplacd, "rplacd", (LispVal * cons, LispVal *newcdr), "(cons newcdr)",
+      "") {
+    CHECK_TYPE(cons, TYPE_CONS);
+    RPLACD(cons, newcdr);
+    return newcdr;
+}
+
 DEFUN(length_eq, "length=", (LispVal * list, LispVal *length), "(list length)",
       "Return non-nil if LIST's length is LENGTH.") {
     CHECK_LISTP(list);

src/list.h

@@ -125,6 +125,8 @@ DECLARE_FUNCTION(atom, (LispVal * val));
 DECLARE_FUNCTION(cons, (LispVal * car, LispVal *cdr));
 DECLARE_FUNCTION(car, (LispVal * list));
 DECLARE_FUNCTION(cdr, (LispVal * list));
+DECLARE_FUNCTION(rplaca, (LispVal * cons, LispVal *newcar));
+DECLARE_FUNCTION(rplacd, (LispVal * cons, LispVal *newcdr));
 DECLARE_FUNCTION(length_eq, (LispVal * list, LispVal *length));
 DECLARE_FUNCTION(nreverse, (LispVal * list));
 DECLARE_FUNCTION(last, (LispVal * list));

src/macro.c

@@ -52,6 +52,9 @@ DEFUN(macroexpand_toplevel, "macroexpand-toplevel",
 }
 
 LispVal *macroexpand_list(LispVal *list, LispVal *lexical_macros) {
+    if (!CONSP(list)) {
+        return list;
+    }
     LispVal *start = Qnil;
     LispVal *end = NULL;
     DOTAILS(rest, list) {
@@ -103,7 +106,7 @@ static LispVal *macroexpand_special_form(LispVal *fobj, LispVal *form,
         return macroexpand_lambda_form(form, lexical_macros);
     } else if (IS(quote) || IS(function)) {
         return form;
-    } else if (IS(progn) || IS(if) || IS(and) || IS(or)) {
+    } else if (IS(progn) || IS(if) || IS(and) || IS(or) || IS(while)) {
         if (LISTP(XCDR(form))) {
             return CONS(XCAR(form),
                         macroexpand_list(XCDR(form), lexical_macros));
@@ -119,7 +122,7 @@ static LispVal *macroexpand_special_form(LispVal *fobj, LispVal *form,
             expand = !expand;
         }
         return CONS(XCAR(form), args);
-    } else if (IS(let)) {
+    } else if (IS(let) || IS(let_star)) {
         if (!CONSP(XCDR(form))) {
             return form;
         }