even closer to array bliss

lisp/builder.carp

@@ -46,6 +46,7 @@
 
 (defn type-build (t)
   (if (string? t)
+    ;;(error (str "Can't build type from unresolved typevar '" t "'"))
     "typevar"
     (match t
            :? "unknown"

lisp/compiler.carp

@@ -127,6 +127,8 @@
           (do
             (meta-set! func-def :generic true)
             (meta-set! func-def :signature (:type ast-annotated))
+            (def ast ast-annotated)
+            (def s (pretty-signature (:type ast-annotated)))
             :generic)))
       (bake-internal-common ast-annotated builder func-name func-code external-deps exe))))
 

lisp/core.carp

@@ -248,4 +248,4 @@
 ;; Set type signatures for primops
 (meta-set! nth :signature '(:fn ((:Array "T") :int) "T"))
 (meta-set! array-of-size :signature '(:fn (:int) (:Array "T")))
-
+(meta-set! array-set :signature '(:fn ((:Array "T") :int "T") (:Array "T")))

lisp/generics.carp

@@ -1,9 +1,9 @@
 
 (defn generic-safe-name (t)
   (match t
-         (:fn args ret) (str "FUNC" (join "" (map pretty-signature args)) "->" (pretty-signature ret))
-         (:ref r) (str "REF" (pretty-signature r) "")
-         (:Array a) (str "ARR" (pretty-signature a) "")
+         (:fn args ret) (str "Fn" (join "" (map pretty-signature args)) "->" (pretty-signature ret))
+         (:ref r) (str "Ref" (pretty-signature r) "")
+         (:Array a) (str "Array" (pretty-signature a) "")
          x (if (keyword? t) (name t)
                (error (str "generic-safe-name can't handle type signature: " t)))))
 
@@ -127,4 +127,11 @@
                                                    " return a;"
                                                    "; }")
                       _ (error "Invalid type for call to 'array-of-size'"))
+    "array-set" (match signature
+                  (:fn ((:Array t) :int t) (:Array t)) (str (type-build '(:Array t)) " " c-func-name
+                                                            "(Array *a, int index, " (type-build t) " value) {"
+                                                            " ((" (type-build t) "*)(a->data))[index] = value;"
+                                                            " return a;"
+                                                            " }")
+                  _ (error "Invalid type for call to 'array-set'"))
     x (error (str "Can't build generic primop for '" x "'"))))

out/project.carp

@@ -82,6 +82,22 @@
 (defn test-int-array []
   (+ 100 (nth (array-of-size 3) 0)))
 
+(defn small-array []
+  (let [a (array-of-size 3)
+        b (array-set a 0 10)
+        c (array-set b 1 20)
+        d (array-set c 2 30)]
+    d))
+
+(defn print-small-array []
+  (let [a (small-array)]
+    (do (print "[")
+        (print (itos (nth a 0)))
+        (print ", ")
+        (print (itos (nth a 1)))
+        (print ", ")
+        (print (itos (nth a 2)))
+        (println "]"))))
 
 (defn array-literal []
   [10 20 30])

src/primops.c

@@ -622,20 +622,34 @@ Obj *p_concat(Obj** args, int arg_count) {
 
 Obj *p_nth(Obj** args, int arg_count) {
   if(arg_count != 2) { printf("Wrong argument count to 'nth'\n"); return nil; }
-  if(args[0]->tag != 'C') { set_error_return_nil("'nth' requires arg 0 to be a list\n", nil); }
   if(args[1]->tag != 'I') { set_error_return_nil("'nth' requires arg 1 to be an integer\n", args[1]); }
-  int i = 0;
-  int n = args[1]->i;
-  Obj *p = args[0];
-  while(p && p->car) {
-    if(i == n) {
-      return p->car;
+  if(args[0]->tag == 'C') {
+    int i = 0;
+    int n = args[1]->i;
+    Obj *p = args[0];
+    while(p && p->car) {
+      if(i == n) {
+	return p->car;
+      }
+      p = p->cdr;
+      i++;
     }
-    p = p->cdr;
-    i++;
+    printf("Index %d out of bounds in %s\n", n, obj_to_string(args[0])->s);
+    return nil;
+  }
+  else if(args[0]->tag == 'A') {
+    Obj *a = args[0];
+    int index = args[1]->i;
+    if(index < 0 || index >= a->count) {
+      set_error_return_nil("Index out of bounds in ", a);
+    }
+    else {
+      return a->array[index];
+    }
+  }
+  else {
+    set_error_return_nil("'nth' requires arg 0 to be a list or array\n", args[0]);
   }
-  printf("Index %d out of bounds in %s\n", n, obj_to_string(args[0])->s);
-  return nil;
 }
 
 Obj *p_count(Obj** args, int arg_count) {
@@ -1426,6 +1440,33 @@ Obj *p_array_to_list(Obj** args, int arg_count) {
 /* } */
 
 Obj *p_array_of_size(Obj** args, int arg_count) {
-  Obj *new_array = obj_new_array(args[0]->i);
+  int array_count = args[0]->i;
+  Obj *new_array = obj_new_array(array_count);
+  for(int i = 0; i < array_count; i++) {
+    new_array->array[i] = nil;
+  }
+  return new_array;
+}
+
+Obj *p_array_set_BANG(Obj** args, int arg_count) {
+  assert_or_set_error_return_nil(arg_count == 3, "array-set! must take 3 arguments: ", args[0]);
+  Obj *a = args[0];
+  assert_or_set_error_return_nil(a->tag == 'A', "array-set! must take an array as first arg: ", args[0]);
+  Obj *i = args[1];
+  assert_or_set_error_return_nil(i->tag == 'I', "array-set! must take an int as second arg: ", args[1]);
+  Obj *o = args[2];
+  a->array[i->i] = o;
+  return nil;
+}
+
+Obj *p_array_set(Obj** args, int arg_count) {
+  assert_or_set_error_return_nil(arg_count == 3, "array-set must take 3 arguments: ", args[0]);
+  Obj *a = args[0];
+  assert_or_set_error_return_nil(a->tag == 'A', "array-set must take an array as first arg: ", args[0]);
+  Obj *i = args[1];
+  assert_or_set_error_return_nil(i->tag == 'I', "array-set must take an int as second arg: ", args[1]);
+  Obj *o = args[2];
+  Obj *new_array = obj_copy(a);
+  new_array->array[i->i] = o;
   return new_array;
 }

src/primops.h

@@ -66,6 +66,8 @@ Obj *p_array_to_list(Obj** args, int arg_count);
 Obj *p_spork(Obj** args, int arg_count);
 Obj *p_array_of_size(Obj** args, int arg_count);
 //Obj *p_array(Obj** args, int arg_count);
+Obj *p_array_set_BANG(Obj** args, int arg_count);
+Obj *p_array_set(Obj** args, int arg_count);
 
 Obj *register_ffi_internal(char *name, VoidFn funptr, Obj *args, Obj *return_type_obj, bool builtin);
 

src/repl.c

@@ -210,6 +210,8 @@ void env_new_global() {
   register_primop("meta-get", p_meta_get);
   register_primop("array-to-list", p_array_to_list);
   register_primop("array-of-size", p_array_of_size);
+  register_primop("array-set!", p_array_set_BANG);
+  register_primop("array-set", p_array_set);
   
   Obj *abs_args = obj_list(type_int);
   register_ffi_internal("abs", (VoidFn)abs, abs_args, type_int, true);