Some more functions

lisp/kernel.gl

@@ -23,8 +23,6 @@
   (princ datum print-char-fun)
   (funcall (or print-char-fun 'write-byte) ?\n))
 
-(let ((t1 (make-hash-table))
+(let ((a [0]))
-      (t2 (make-hash-table)))
+  (aset a 1 'a)
-  (puthash t1 'a 'b)
+  (princln a))
-  (puthash t2 'a 'b)
-  (princln (equal t1 t2)))

src/base.c

@@ -3,6 +3,7 @@
 #include "function.h"
 #include "gc.h"
 #include "hashtable.h"
+#include "io.h"
 #include "lisp.h"
 #include "list.h"
 #include "stack.h"
@@ -166,6 +167,23 @@ DEFUN(equal, "equal", (LispVal * obj1, LispVal *obj2), "(obj1 obj2)", "") {
     }
 }
 
+DEFUN(length, "length", (LispVal * seq), "(seq)", "") {
+    if (LISTP(seq)) {
+        intptr_t len = list_length(seq);
+        if (len == -1) {
+            lisp_signal(Qcircular_list_error, Qnil);
+        }
+        return MAKE_FIXNUM(len);
+    } else if (VECTORP(seq)) {
+        return MAKE_FIXNUM(((LispVector *) seq)->length);
+    } else if (STRINGP(seq)) {
+        return MAKE_FIXNUM(((LispString *) seq)->length);
+    } else if (HASH_TABLE_P(seq)) {
+        return MAKE_FIXNUM(((LispHashTable *) seq)->count);
+    }
+    signal_type_error(seq, LIST(Qlist, Qvector, Qstring, Qhash_table));
+}
+
 // ################
 // # Constructors #
 // ################
@@ -291,6 +309,51 @@ DEFUN(put, "put", (LispVal * sym, LispVal *key, LispVal *val), "(sym key val)",
     return Fsetplist(sym, Fplist_put(Fsymbol_plist(sym), key, val));
 }
 
+static size_t check_index_in_range(LispVal *val, size_t size) {
+    if (FIXNUMP(val)) {
+        fixnum_t fn = XFIXNUM(val);
+        if (fn < 0 || fn >= size) {
+            goto out_of_bounds;
+        }
+        return fn;
+    } else if (LISP_GMP_P(val)) {
+        if (mpz_sgn(((LispGmp *) val)->val) < 0) {
+            goto out_of_bounds;
+        }
+        size_t out = mpz_get_ui(((LispGmp *) val)->val);
+        if (out >= size) {
+            goto out_of_bounds;
+        }
+        return out;
+    }
+    signal_type_error(val, Qinteger);
+out_of_bounds:
+    lisp_signal(Qout_of_bounds_error, LIST(val, make_number_unsigned(size)));
+}
+
+DEFUN(aref, "aref", (LispVal * arr, LispVal *idx), "(arr idx)", "") {
+    if (VECTORP(arr)) {
+        LispVector *v = arr;
+        size_t i = check_index_in_range(idx, v->length);
+        return v->data[i];
+    } else if (STRINGP(arr)) {
+        LispString *s = arr;
+        size_t i = check_index_in_range(idx, s->length);
+        return MAKE_FIXNUM(s->data[i]);
+    }
+    signal_type_error(arr, LIST(Qstring, Qvector));
+}
+
+DEFUN(aset, "aset", (LispVal * arr, LispVal *idx, LispVal *data),
+      "(arr idx data)", "") {
+    CHECK_TYPE(arr, TYPE_VECTOR);
+    CHECK_TYPE(idx, TYPE_FIXNUM, TYPE_GMP);
+    LispVector *v = arr;
+    size_t i = check_index_in_range(idx, v->length);
+    v->data[i] = data;
+    return data;
+}
+
 noreturn void signal_value_constant(LispVal *value) {
     lisp_signal(Qvalue_constant_error, LIST(value));
 }
@@ -298,7 +361,7 @@ noreturn void signal_value_constant(LispVal *value) {
 DEFINE_SYMBOL(fixnum, "fixnum");
 DEFINE_SYMBOL(float, "float");
 // cons defined in list.c
-DEFINE_SYMBOL(string, "strin");
+DEFINE_SYMBOL(string, "string");
 DEFINE_SYMBOL(symbol, "symbol");
 // vector defined above
 DEFINE_SYMBOL(hash_table, "hash-table");
@@ -434,6 +497,9 @@ DEFINE_CONDITION_CLASS(type_error, error);
 DEFINE_SYMBOL(value_constant_error, "value-constant-error");
 DEFINE_CONDITION_CLASS(value_constant_error, error);
 
+DEFINE_SYMBOL(out_of_bounds_error, "out-of-bounds-error");
+DEFINE_CONDITION_CLASS(out_of_bounds_error, error);
+
 DEFINE_SYMBOL(backquote, "`");
 DEFINE_SYMBOL(comma, ",");
 DEFINE_SYMBOL(comma_at, ",@");

src/base.h

@@ -374,6 +374,7 @@ DECLARE_FUNCTION(quote, (LispVal * form));
 DECLARE_FUNCTION(function, (LispVal * form));
 
 DECLARE_FUNCTION(equal, (LispVal * obj1, LispVal *obj2));
+DECLARE_FUNCTION(length, (LispVal * seq));
 
 // TODO probably move these to another file
 LispVal *make_vector(LispVal **data, size_t length, bool take);
@@ -391,6 +392,9 @@ DECLARE_FUNCTION(setplist, (LispVal * sym, LispVal *plist));
 DECLARE_FUNCTION(get, (LispVal * sym, LispVal *key, LispVal *def));
 DECLARE_FUNCTION(put, (LispVal * sym, LispVal *key, LispVal *val));
 
+DECLARE_FUNCTION(aref, (LispVal * arr, LispVal *idx));
+DECLARE_FUNCTION(aset, (LispVal * arr, LispVal *idx, LispVal *data));
+
 noreturn void signal_value_constant(LispVal *value);
 
 static ALWAYS_INLINE LispVal *SYMBOL_VALUE(LispVal *sym) {
@@ -472,6 +476,9 @@ MAKE_CONDITION_CLASS(type_error);
 DECLARE_SYMBOL(value_constant_error);
 MAKE_CONDITION_CLASS(value_constant_error);
 
+DECLARE_SYMBOL(out_of_bounds_error);
+MAKE_CONDITION_CLASS(out_of_bounds_error);
+
 // Defined in lisp code (eventually) but used in read.c
 DECLARE_SYMBOL(backquote);
 DECLARE_SYMBOL(comma);

src/list.c

@@ -53,15 +53,6 @@ DEFUN(cdr, "cdr", (LispVal * list), "(list)", "") {
     return NILP(list) ? Qnil : XCDR(list);
 }
 
-DEFUN(length, "length", (LispVal * list), "(list)", "") {
-    CHECK_LISTP(list);
-    intptr_t len = list_length(list);
-    if (len == -1) {
-        lisp_signal(Qcircular_list_error, Qnil);
-    }
-    return MAKE_FIXNUM(len);
-}
-
 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,7 +125,6 @@ DECLARE_FUNCTION(atom, (LispVal * val));
 DECLARE_FUNCTION(cons, (LispVal * car, LispVal *cdr));
 DECLARE_FUNCTION(car, (LispVal * list));
 DECLARE_FUNCTION(cdr, (LispVal * list));
-DECLARE_FUNCTION(length, (LispVal * list));
 DECLARE_FUNCTION(length_eq, (LispVal * list, LispVal *length));
 DECLARE_FUNCTION(nreverse, (LispVal * list));
 DECLARE_FUNCTION(last, (LispVal * list));