From 960847893e726dcc4fcaf1208e5b0453aa195932 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Erik=20Sved=C3=A4ng?= <erik.svedang@gmail.com>
Date: Thu, 17 Mar 2016 19:29:35 +0100
Subject: [PATCH] added stuff for doubles

---
 lisp/builder.carp    |  1 +
 lisp/builtins.carp   | 41 +++++++++++++++++++++++++--------
 lisp/core.carp       |  3 +++
 lisp/core_tests.carp |  6 +++++
 lisp/generics.carp   | 10 +++++++-
 src/eval.c           | 18 +++++++++++++++
 src/obj.c            |  3 +++
 src/obj.h            |  1 +
 src/primops.c        | 55 ++++++++++++++++++++++++++++++++++++++++++++
 src/repl.c           |  3 +++
 10 files changed, 130 insertions(+), 11 deletions(-)

diff --git a/lisp/builder.carp b/lisp/builder.carp
index ca652779..7fac6466 100644
--- a/lisp/builder.carp
+++ b/lisp/builder.carp
@@ -89,6 +89,7 @@
            (:ref r) (type-build-internal r star)
            (:Array a) (str "Array" (if star "*" "")) ;; TODO: case not needed
            :float "float"
+           :double "double"
            :int "int"
            :char "char"
            :bool "bool"
diff --git a/lisp/builtins.carp b/lisp/builtins.carp
index 43ee0a22..930dbc8a 100644
--- a/lisp/builtins.carp
+++ b/lisp/builtins.carp
@@ -1,28 +1,49 @@
+;; Int math
 (register-builtin "srand" '(:int) :void)
 (register-builtin "rand" '() :int)
 (register-builtin "max" '(:int :int) :int)
 (register-builtin "inc" '(:int) :int)
 (register-builtin "dec" '(:int) :int)
+(register-builtin "mod" '(:int :int) :int)
+
+;; Double math
+(register-builtin "sin" '(:double) :double)
+(register-builtin "cos" '(:double) :double)
+(register-builtin "sqrt" '(:double) :double)
+
+;; Float math
 (register-builtin "sinf" '(:float) :float)
 (register-builtin "cosf" '(:float) :float)
 (register-builtin "sqrtf" '(:float) :float)
+
+;; Conversions
 (register-builtin "itof" '(:int) :float)
 (register-builtin "itos" '(:int) :string)
-(register-builtin "panic" '((:ref :string)) :void)
-(register-builtin "printf" '((:ref :string)) :void)
-(register-builtin "print" '((:ref :string)) :void)
-(register-builtin "println" '((:ref :string)) :void)
-(register-builtin "sleep" '(:int) :void)
-(register-builtin "nullQMARK" '(:any) :bool)
-(register-builtin "not" '(:bool) :bool)
+
+;; Strings
 (register-builtin "strlen" '((:ref :string)) :int)
 (register-builtin "string_append" '((:ref :string) (:ref :string)) :string)
-(register-builtin "file_existsQMARK" '((:ref :string)) :bool)
 (register-builtin "eat_string" '(:string) :void)
 (register-builtin "string_copy" '((:ref :string)) :string)
-(register-builtin "async" '((:fn () :void)) :void)
 (register-builtin "last_index_of" '(:string :char) :int)
 (register-builtin "substring" '(:string :int) :string)
 (register-builtin "file_path_component" '(:string) :string)
+
+;; IO
+(register-builtin "printf" '((:ref :string)) :void)
+(register-builtin "print" '((:ref :string)) :void)
+(register-builtin "println" '((:ref :string)) :void)
 (register-builtin "get_input" '() :string)
-(register-builtin "mod" '(:int :int) :int)
+
+;; Files
+(register-builtin "file_existsQMARK" '((:ref :string)) :bool)
+
+;; System
+(register-builtin "panic" '((:ref :string)) :void)
+(register-builtin "sleep" '(:int) :void)
+(register-builtin "async" '((:fn () :void)) :void)
+
+;;Misc
+(register-builtin "nullQMARK" '(:any) :bool)
+(register-builtin "not" '(:bool) :bool)
+
diff --git a/lisp/core.carp b/lisp/core.carp
index ef3fdd9b..92866402 100644
--- a/lisp/core.carp
+++ b/lisp/core.carp
@@ -62,6 +62,9 @@
 ;; (defmacro quasiquote (form)
 ;;   (list 'quote (map replace-dequotes form)))
 
+(defmacro assert (x)
+  (list 'assert-eq true x))
+
 (defn assert-approx-eq (target x)
   (do
     (assert-eq true (< x (+ target 0.1)))
diff --git a/lisp/core_tests.carp b/lisp/core_tests.carp
index 9f833069..6fa99fc1 100644
--- a/lisp/core_tests.carp
+++ b/lisp/core_tests.carp
@@ -1,4 +1,9 @@
 
+(defn test-doubles []
+  (let [x 3.0d
+        y 5.0d]
+    (assert (< 14.0d (* x y) 16.0d))))
+
 (defn test-bind-to-function-in-let []
   (do (defn misbind []
         (let [(fn [] nil) 123]
@@ -400,6 +405,7 @@
     (test-match-array)
     (test-template)
     (test-bind-to-function-in-let)
+    (test-doubles)
     ))
 
 (run-core-tests)
diff --git a/lisp/generics.carp b/lisp/generics.carp
index 82ea4aea..7f1fb80e 100644
--- a/lisp/generics.carp
+++ b/lisp/generics.carp
@@ -229,7 +229,7 @@
                  x (error (str "Invalid type for call to 'map-copy': " x)))
     
     "str" (do
-            ;;(println (str "Calling str for signature: " signature))
+            (println (str "Calling str for signature: " signature))
             (match signature
 
               (:fn ((:ref (:Array t))) :string) (instantiate-str-for-array c-func-name t)
@@ -254,6 +254,14 @@
                                                   "}")]
                                        {:proto proto :c c :deps ()})
 
+              (:fn (:double) :string) (let [proto (str "API string " c-func-name "(double x)")
+                                           c (str proto " { "
+                                                  " char output[50];"
+                                                  " snprintf(output, 50, \"%f\", x);"
+                                                  " return strdup(output);"
+                                                  "}")]
+                                       {:proto proto :c c :deps ()})
+
               (:fn ((:ref :string)) :string) (instantiate-str-for-string c-func-name)
 
               (:fn ((:ref maybe-struct-type)) :string) (instantiate-str-for-struct c-func-name maybe-struct-type)
diff --git a/src/eval.c b/src/eval.c
index eca91380..d3e9300f 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -320,6 +320,10 @@ void call_lambda_from_ffi(ffi_cif *cif, void *ret, void* args[], LambdaAndItsTyp
       float *x = args[i];
       obj_args[i] = obj_new_float(*x);
     }
+    else if(cif->arg_types[i] == &ffi_type_double) {
+      double *x = args[i];
+      obj_args[i] = obj_new_double(*x);
+    }
     else if(cif->arg_types[i] == &ffi_type_schar) {
       char *x = args[i];
       obj_args[i] = obj_new_char(*x);
@@ -378,6 +382,11 @@ void call_lambda_from_ffi(ffi_cif *cif, void *ret, void* args[], LambdaAndItsTyp
     float *x = ret;
     *x = result->f32;
   }
+  else if(obj_eq(lambda_return_type, type_double)) {
+    assert_or_set_error(result->tag == 'W', "Invalid type of return value ", result);
+    double *x = ret;
+    *x = result->f64;
+  }
   else if(obj_eq(lambda_return_type, type_string)) {
     assert_or_set_error(result->tag == 'S', "Invalid type of return value ", result);
     char **s = ret;
@@ -475,6 +484,10 @@ void apply(Obj *function, Obj **args, int arg_count) {
           assert_or_free_values_and_set_error(args[i]->tag == 'V', "Invalid (expected float) type of arg: ", args[i]);
           values[i] = &args[i]->f32;
         }
+        else if(obj_eq(type_obj, type_double)) {
+          assert_or_free_values_and_set_error(args[i]->tag == 'W', "Invalid (expected double) type of arg: ", args[i]);
+          values[i] = &args[i]->f64;
+        }
         else if(obj_eq(type_obj, type_string)) {
           assert_or_free_values_and_set_error(args[i]->tag == 'S', "Invalid (expected string) type of arg: ", args[i]);
           //args[i]->s = strdup(args[i]->s); // OBS! Duplicating string here. TODO: Think about if this is the correct thing to do!
@@ -606,6 +619,11 @@ void apply(Obj *function, Obj **args, int arg_count) {
       ffi_call(function->cif, function->funptr, &result, values);
       obj_result = obj_new_float(result);
     }
+    else if(obj_eq(return_type, type_double)) { 
+      double result;
+      ffi_call(function->cif, function->funptr, &result, values);
+      obj_result = obj_new_double(result);
+    }
     else if(obj_eq(return_type, type_void)) { 
       //printf("Returning void.\n");
       ffi_sarg result;
diff --git a/src/obj.c b/src/obj.c
index aa38f395..5fd0617f 100644
--- a/src/obj.c
+++ b/src/obj.c
@@ -218,6 +218,9 @@ Obj *obj_copy(Obj *o) {
   else if(o->tag == 'V') {
     return obj_new_float(o->f32);
   }
+  else if(o->tag == 'W') {
+    return obj_new_float(o->f64);
+  }
   else if(o->tag == 'S') {
     return obj_new_string(strdup(o->s));
   }
diff --git a/src/obj.h b/src/obj.h
index ea9fcc41..fa6be449 100644
--- a/src/obj.h
+++ b/src/obj.h
@@ -168,6 +168,7 @@ Obj *type_symbol;
 Obj *type_macro;
 Obj *type_void;
 Obj *type_float;
+Obj *type_double;
 Obj *type_ptr;
 Obj *type_ref;
 Obj *type_char;
diff --git a/src/primops.c b/src/primops.c
index 703811f2..61f6bdee 100644
--- a/src/primops.c
+++ b/src/primops.c
@@ -96,6 +96,17 @@ Obj *p_add(Obj** args, int arg_count) {
     }
     return obj_new_float(sum);
   }
+  else if(args[0]->tag == 'W') {
+    double sum = 0;
+    for(int i = 0; i < arg_count; i++) {
+      if(args[i]->tag != 'W') {
+        eval_error = obj_new_string("Args to add must be doubles.\n");
+        return nil;
+      }
+      sum += args[i]->f64;
+    }
+    return obj_new_double(sum);
+  }
   else {
     eval_error = obj_new_string("Can't add non-numbers together.");
     return nil;
@@ -121,6 +132,16 @@ Obj *p_sub(Obj** args, int arg_count) {
     }
     return obj_new_float(sum);
   }
+  else if(args[0]->tag == 'W') {
+    if(arg_count == 1) {
+      return obj_new_int((int)-args[0]->f64);
+    }
+    double sum = args[0]->f64;
+    for(int i = 1; i < arg_count; i++) {
+      sum -= args[i]->f64;
+    }
+    return obj_new_double(sum);
+  }
   else {
     eval_error = obj_new_string("Can't subtract non-numbers.");
     return nil;
@@ -146,6 +167,13 @@ Obj *p_mul(Obj** args, int arg_count) {
     }
     return obj_new_float(prod);
   }
+  else if(args[0]->tag == 'W') {
+    double prod = args[0]->f64;
+    for(int i = 1; i < arg_count; i++) {
+      prod *= args[i]->f64;
+    }
+    return obj_new_double(prod);
+  }
   else {
     eval_error = obj_new_string("Can't multiply non-numbers.");
     return nil;
@@ -171,6 +199,13 @@ Obj *p_div(Obj** args, int arg_count) {
     }
     return obj_new_float(prod);
   }
+  else if(args[0]->tag == 'W') {
+    double prod = args[0]->f64;
+    for(int i = 1; i < arg_count; i++) {
+      prod /= args[i]->f64;
+    }
+    return obj_new_double(prod);
+  }
   else {
     eval_error = obj_new_string("Can't divide non-numbers.");
     return nil;
@@ -757,6 +792,9 @@ Obj *p_map(Obj** args, int arg_count) {
         else if(obj_eq(inner_type, type_float)) {
           arg[0] = obj_new_float(((float*)(a->data))[i]);
         }
+        else if(obj_eq(inner_type, type_double)) {
+          arg[0] = obj_new_double(((float*)(a->data))[i]);
+        }
         else if(obj_eq(inner_type, type_int)) {
           arg[0] = obj_new_int(((int*)(a->data))[i]);
         }
@@ -1031,6 +1069,9 @@ Obj *p_type(Obj** args, int arg_count) {
   else if(args[0]->tag == 'V') {
     return type_float;
   }
+  else if(args[0]->tag == 'W') {
+    return type_double;
+  }
   else if(args[0]->tag == 'C') {
     return type_list;
   }
@@ -1079,6 +1120,7 @@ Obj *p_lt(Obj** args, int arg_count) {
   if(args[0]->tag == 'I') {
     int smallest = args[0]->i;
     for(int i = 1; i < arg_count; i++) {
+      assert_or_set_error_return_nil(args[i]->tag == 'I', "< for ints called with non-int: ", args[0]);
       if(smallest >= args[i]->i) { return lisp_false; }
       smallest = args[i]->i;
     }
@@ -1087,11 +1129,21 @@ Obj *p_lt(Obj** args, int arg_count) {
   else if(args[0]->tag == 'V') {
     float smallest = args[0]->f32;
     for(int i = 1; i < arg_count; i++) {
+      assert_or_set_error_return_nil(args[i]->tag == 'V', "< for floats called with non-float: ", args[0]);
       if(smallest >= args[i]->f32) { return lisp_false; }
       smallest = args[i]->f32;
     }
     return lisp_true;
   }
+  else if(args[0]->tag == 'W') {
+    double smallest = args[0]->f64;
+    for(int i = 1; i < arg_count; i++) {
+      assert_or_set_error_return_nil(args[i]->tag == 'W', "< for doubles called with non-double: ", args[0]);
+      if(smallest >= args[i]->f64) { return lisp_false; }
+      smallest = args[i]->f64;
+    }
+    return lisp_true;
+  }
   else {
     eval_error = obj_new_string("Can't call < on non-numbers.");
     return lisp_false;
@@ -1287,6 +1339,9 @@ ffi_type *lisp_type_to_ffi_type(Obj *type_obj) {
   else if(obj_eq(type_obj, type_float)) {
     return &ffi_type_float;
   }
+  else if(obj_eq(type_obj, type_double)) {
+    return &ffi_type_double;
+  }
   else if(obj_eq(type_obj, type_void)) {
     return &ffi_type_uint;
   }
diff --git a/src/repl.c b/src/repl.c
index 50756535..2615fdff 100755
--- a/src/repl.c
+++ b/src/repl.c
@@ -114,6 +114,9 @@ void env_new_global() {
 
   type_float = obj_new_keyword("float");
   define("type-float", type_float);
+
+  type_double = obj_new_keyword("double");
+  define("type-double", type_double);
   
   type_string = obj_new_keyword("string");
   define("type-string", type_string);