Add methods and pointers (#53)

* method calls and sorting

* add more tests and fix some alias stuff

common/type_system/TypeSystem.cpp

@@ -155,6 +155,10 @@ TypeSpec TypeSystem::make_typespec(const std::string& name) const {
   }
 }
 
+bool TypeSystem::fully_defined_type_exists(const std::string& name) const {
+  return m_types.find(name) != m_types.end();
+}
+
 /*!
  * Create a typespec for a function.  If the function doesn't return anything, use "none" as the
  * return type.
@@ -568,7 +572,7 @@ void TypeSystem::add_builtin_types() {
   add_method(obj_type, "print", make_function_typespec({"_type_"}, "_type_"));
   add_method(obj_type, "inspect", make_function_typespec({"_type_"}, "_type_"));
   add_method(obj_type, "length",
-             make_function_typespec({"_type_"}, "int32"));  // todo - this integer type?
+             make_function_typespec({"_type_"}, "int"));  // todo - this integer type?
   add_method(obj_type, "asize-of", make_function_typespec({"_type_"}, "int"));
   add_method(obj_type, "copy", make_function_typespec({"_type_", "symbol"}, "_type_"));
   add_method(obj_type, "relocate", make_function_typespec({"_type_", "int32"}, "_type_"));
@@ -972,4 +976,20 @@ TypeSpec TypeSystem::lowest_common_ancestor(const std::vector<TypeSpec>& types)
     result = lowest_common_ancestor(result, types.at(i));
   }
   return result;
+}
+
+TypeSpec coerce_to_reg_type(const TypeSpec& in) {
+  if (in.arg_count() == 0) {
+    if (in.base_type() == "int8" || in.base_type() == "int16" || in.base_type() == "int32" ||
+        in.base_type() == "int16") {
+      return TypeSpec("int");
+    }
+
+    if (in.base_type() == "uint8" || in.base_type() == "uint16" || in.base_type() == "uint32" ||
+        in.base_type() == "uint16") {
+      return TypeSpec("uint");
+    }
+  }
+
+  return in;
 }

common/type_system/TypeSystem.h

@@ -39,6 +39,7 @@ class TypeSystem {
 
   DerefInfo get_deref_info(const TypeSpec& ts);
 
+  bool fully_defined_type_exists(const std::string& name) const;
   TypeSpec make_typespec(const std::string& name) const;
   TypeSpec make_function_typespec(const std::vector<std::string>& arg_types,
                                   const std::string& return_type);
@@ -122,4 +123,6 @@ class TypeSystem {
   bool m_allow_redefinition = false;
 };
 
+TypeSpec coerce_to_reg_type(const TypeSpec& in);
+
 #endif  // JAK_TYPESYSTEM_H

game/kernel/kscheme.cpp

@@ -1093,7 +1093,7 @@ u64 sprint(u32 obj) {
  */
 u64 print_object(u32 obj) {
   if ((obj & OFFSET_MASK) == BINTEGER_OFFSET) {
-    return print_binteger(obj);
+    return print_binteger(s64(s32(obj)));
   } else {
     if ((obj < SymbolTable2.offset || 0x7ffffff < obj) &&  // not in normal memory
         (obj < 0x84000 || 0x100000 <= obj)) {              // not in kernel memory

goal_src/goal-lib.gc

@@ -195,6 +195,18 @@
     )
   )
 
+(defmacro when (condition &rest body)
+  `(if ,condition
+       (begin ,@body)
+       )
+  )
+
+(defmacro unless (condition &rest body)
+  `(if (not ,condition)
+     (begin ,@body)
+     )
+  )
+
 ;; TODO - these work but aren't very efficient.
 
 (defmacro and (&rest args)
@@ -278,6 +290,22 @@
   `(logand #xfffffff0 (+ (the-as integer ,value) 15))
   )
 
+(defmacro &+ (v1 &rest args)
+  (if (null? args)
+      `(the pointer ,v1)
+      `(&+ (+ (the-as int ,v1) (the-as int ,(first args))) ,@(cdr args))
+      )
+  )
+
+(defmacro &- (v1 v2)
+  `(the pointer (- (the-as int ,v1) (the-as int ,v2)))
+  )
+
+(defmacro &+! (v1 v2)
+  `(set! ,v1 (&+ ,v1 ,v2))
+  )
+
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; TYPE STUFF
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -317,4 +345,24 @@
     (quote '())
     `(cons ,(car args) (list ,@(cdr args)))
     )
-  )
+  )
+
+(defmacro null? (arg)
+  ;; todo, make this better
+  `(eq? ,arg '())
+  )
+(defmacro caar (arg)
+  `(car (car ,arg))
+  )
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; METHOD STUFF
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+(defmacro object-new (&rest sz)
+  (if (null? sz)
+    `(the ,(current-method-type) ((-> object method-table 0) allocation type-to-make (-> type-to-make asize)))
+    `(the ,(current-method-type) ((-> object method-table 0) allocation type-to-make ,@sz))
+    )
+  )

goal_src/kernel/gcommon.gc

@@ -357,4 +357,274 @@
   (dotimes (i idx (car obj))
     (set! obj (cdr obj))
     )
+  )
+
+(defmethod length pair ((obj pair))
+  "Get the number of elements in a proper list"
+  (if (eq? obj '())
+    (return-from #f 0)
+    )
+
+  (let ((lst (cdr obj))
+        (len 1))
+    (while (and (not (eq? lst '()))
+                (pair? lst)
+                )
+           (+1! len)
+           (set! lst (cdr lst))
+           )
+    len)
+  )
+
+
+
+(defmethod asize-of pair ((obj pair))
+  "Get the asize of a pair"
+  (the-as int (-> pair size))
+  )
+
+(defun last ((obj object))
+  "Get the last pair in a list."
+  (while (not (eq? (cdr obj) '()))
+         (set! obj (cdr obj))
+         )
+  obj
+  )
+
+(defun member ((obj object) (lst object))
+  "if obj is a member of the list, return the pair containing obj as its car.
+  if not, return #f."
+  (while (and (not (eq? lst '()))
+              (not (eq? (car lst) obj)))
+         (set! lst (cdr lst))
+         )
+
+  (if (eq? lst '())
+    #f
+    lst
+    )
+  )
+
+(define-extern name= (function basic basic symbol))
+
+(defun nmember ((obj basic) (lst object))
+  "If obj is a member of the list, return the pair containing obj as its car.
+   If not, return #f.  Use name= (see gstring.gc) to check equality."
+   (while (and (not (eq? lst '()))
+               (not (name= (the basic (car lst)) obj))
+               )
+     (set! lst (cdr lst))
+     )
+   
+   (if (eq? lst '())
+       #f
+       lst
+       )
+  )
+
+(defun assoc ((item object) (alst object))
+  "Get a pair with car of item from the association list (list of pairs) alst."
+  (while (and (not (null? alst))
+              (not (eq? (caar alst) item)))
+         (set! alst (cdr alst))
+         )
+  (if (not (null? alst))
+    (car alst)
+    #f
+    )
+  )
+
+(defun assoce ((item object) (alst object))
+  "Like assoc, but a pair with car of 'else will match anything"
+  (while (and (not (null? alst))
+              (not (eq? (caar alst) item))
+              (not (eq? (caar alst) 'else))
+              )
+         (set! alst (cdr alst))
+         )
+  (if (not (null? alst))
+    (car alst)
+    #f
+    )
+  )
+
+;; todo
+;; nassoc
+;; nassce
+
+(defun append! ((front object) (back object))
+  "Append back to front."
+  (if (null? front)
+    (return-from #f back)
+    )
+
+  (let ((lst front))
+    ;; seek to the end of front
+    (while (not (null? (cdr lst)))
+           (set! lst (cdr lst))
+           )
+
+    ;; this check seems not needed
+    (if (not (null? lst))
+      (set! (cdr lst) back)
+      )
+
+    front
+    )
+  )
+
+(defun delete! ((item object) (lst object))
+  "Delete the first occurance of item from a list and return the list.
+  Does nothing if the item isn't in the list."
+  (if (eq? (car lst) item)
+    (return-from #f (cdr lst))
+    )
+
+  (let ((iter (cdr lst))
+        (rep lst))
+
+    (while (and (not (null? iter))
+                (not (eq? (car iter) item)))
+           (set! rep iter)
+           (set! iter (cdr iter))
+           )
+
+    (if (not (null? iter))
+      (set! (cdr rep) (cdr iter))
+      )
+    )
+  (the pair lst)
+  )
+
+(defun delete-car! ((item object) (lst object))
+  "Like delete, but will delete if (car item-from-list) is equal to item.  Useful for deleting from association list by key."
+  ;(format #t "call to delete car: ~A ~A~%" item lst)
+  (if (eq? (caar lst) item)
+    (return-from #f (cdr lst))
+    )
+
+  (let ((rep lst)
+        (iter (cdr lst)))
+    (while (and (not (null? iter))
+                (not (eq? (caar iter) item)))
+           (set! rep iter)
+           (set! iter (cdr iter))
+           )
+
+    (if (not (null? iter))
+      (set! (cdr rep) (cdr iter))
+      )
+    )
+  lst
+  )
+
+(defun insert-cons! ((kv object) (alst object))
+  "Insert key-value pair into an association list.  Also removes the old one if it was there."
+  (cons kv (delete-car! (car kv) alst))
+  )
+
+(defun sort ((lst object) (compare function))
+  "Sort the given list in place.  Uses the given comparison function. The comparison function can 
+  either return #t/#f or an integer, in which case the sign of the integer determines lt/gt."
+  ;; in each iteration, we count how many changes we make. Once we make no changes, the list is sorted.
+  (let ((changes -1)) 
+    
+    (while (not (zero? changes)) ;; outer loop
+      (set! changes 0)      ;; reset changes for this iteration
+      (let ((iter lst))     ;; iterate through list
+        (while (and (not (null? (cdr iter)))
+                    (pair? (cdr iter)))
+          ;; L221
+          (let* ((val1 (car iter))        ;; value at iterator
+                 (val2 (car (cdr iter)))  ;; value after iterator
+                 (c-result (compare val1 val2))) ;; run comparison function
+            ;; check if val1 and val2 are in order. The compare function may either return #t
+            ;; or it may return val1 - val2.  There is an issue if val1 - val2 happens to equal #t or #f.
+            (unless (or
+                      (and c-result (<= (the integer c-result) 0)) ;; not #f, and negative, we're sorted!
+                      (eq? c-result #t) ;; explictly return #t, we're sorted!
+                      )
+              ;; these two aren't sorted! so we swap them and increment changes.
+              (+1! changes)
+              (set! (car iter) val2)
+              (set! (car (cdr iter)) val1)
+              )
+            ;; move on to the next thing in the list.
+            (set! iter (cdr iter))
+            )
+          )
+        )
+      )
+    )
+  lst
+  )
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;; inline array
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; a parent class for boxed "inline arrays" classes, 
+;; An inline-array is an array with a bunch of objects back-to-back, as opposed to a bunch of
+;; references back to back.
+;; Most inline-arrays are unboxed and are just data - this is a somewhat rarely used container parent
+;; class for a class that wraps an unboxed inline-array.
+;; the "heap-base" field of the type is used to store the indexing scale.
+
+(deftype inline-array-class (basic)
+  ((length int32 :offset-assert 4)
+   (allocated-length int32 :offset-assert 8)
+   (data uint8 :dynamic)
+   ;; ??
+   )
+  )
+
+(defmethod new inline-array-class ((allocation symbol) (type-to-make type) (cnt integer))
+  "Create a new inline-array.  Sets the length, allocated-length to cnt.  Uses the mysterious heap-base field
+  of the type-to-make to determine the element size"
+  (let* ((sz (+ (-> type-to-make size) (* (-> type-to-make heap-base) cnt)))
+         (new-object (object-new sz)))
+    ;;(format 0 "create sz ~d at #x~X~%" sz new-object)
+    (unless (zero? new-object)
+      (set! (-> new-object length) cnt)
+      (set! (-> new-object allocated-length) cnt)
+      )
+    new-object
+    )
+  )
+
+(defmethod length inline-array-class ((obj inline-array-class))
+  ;"Get the length of an inline-array"
+  (-> obj length)
+  )
+
+(defmethod asize-of inline-array-class ((obj inline-array-class))
+  ;"Get the size in memory of an inline-array-class"
+  (+ (the-as int (-> obj type size))
+     (* (-> obj allocated-length) (-> obj type heap-base))
+     )
+  )
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; array (todo)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; memcpy and similar
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defun mem-copy! ((dst pointer) (src pointer) (size integer))
+  "Copy memory from src to dst.  Size is in bytes.  This is not an efficient implementation,
+  however, there are _no restrictions_ on size, alignment etc. Increasing address copy."
+  (let ((i 0)
+        (d (the pointer dst))
+        (s (the pointer src))
+        )
+    
+    (while (< i size)
+           (set! (-> (the (pointer uint8) d) 0) (-> (the (pointer uint8) s) 0))
+           (&+! d 1)
+           (&+! s 1)
+           (+1! i)
+           )
+    )
+  dst
   )

goal_src/test/test-append.gc

@@ -0,0 +1,4 @@
+(format #t "~A~%"
+        (append! (list 'a 'b) (list 'c 'd 'e)))
+
+        0

goal_src/test/test-assoc-1.gc

@@ -0,0 +1,3 @@
+(format #t "~A~%"
+        (cdr (assoc 'e (list (cons 'a 'b) (cons 'e 'w) (cons 'x 'x)))))
+        0

goal_src/test/test-assoc-2.gc

@@ -0,0 +1,3 @@
+(format #t "~A~%"
+        (assoc 'r (list (cons 'a 'b) (cons 'e 'w) (cons 'x 'x))))
+        0

goal_src/test/test-assoce-1.gc

@@ -0,0 +1,3 @@
+(format #t "~A~%"
+        (cdr (assoce 'r (list (cons 'a 'b) (cons 'e 'w) (cons 'else 'x)))))
+        0

goal_src/test/test-assoce-2.gc

@@ -0,0 +1,3 @@
+(format #t "~A~%"
+        (cdr (assoce 'r (list (cons 'a 'b) (cons 'r 'x) (cons 'else 'w)))))
+        0

goal_src/test/test-delete-car.gc

@@ -0,0 +1,10 @@
+(let ((my-list (list (cons 'a 'b)
+                     (cons 'c 'd)
+                     (cons 'e 'f)
+                     )
+               ))
+  (delete-car! 'c my-list)
+  (format #t "~A~%" my-list)
+  (format #t "~A~%" (assoc 'c my-list))
+  )
+0

goal_src/test/test-delete-list.gc

@@ -0,0 +1,3 @@
+(format #t "~A~%"
+        (delete! 'c (list 'a 'b 'c 'd 'e)))
+        0

goal_src/test/test-insert-cons.gc

@@ -0,0 +1,7 @@
+(let ((alist (list (cons 'a 'b)
+                   (cons 'c 'd)
+                   (cons 'e 'f))))
+  (set! alist (insert-cons! (cons 'c 'w) alist))
+  (format #t "~A~%" alist)
+  )
+  0

goal_src/test/test-last.gc

@@ -0,0 +1,4 @@
+(format #t "~A~%"
+        (car (last (list 'a 'b 'c 'd)))
+        )
+        0

goal_src/test/test-member-1.gc

@@ -0,0 +1,3 @@
+(format #t "~A~%"
+        (member 'c (list 'a 'b 'c 'd)))
+        0

goal_src/test/test-member-2.gc

@@ -0,0 +1,3 @@
+(format #t "~A~%"
+        (member 1234 (list 'a 'b 'c 'd))
+        )

goal_src/test/test-memcpy.gc

@@ -0,0 +1,11 @@
+(let* ((base-addr #x6000000)
+       (offset #x123)
+       (ptr-int32 (the (pointer int32) base-addr))
+       (ptr-int16 (the (pointer int16) #x6000123))
+       )
+  (set! (-> ptr-int32 1) #x00070006)
+  (mem-copy! ptr-int16 ptr-int32 8)
+  (+ (-> ptr-int16 2)
+     (-> ptr-int16 3)
+     )
+  )

goal_src/test/test-methods.gc

@@ -0,0 +1,4 @@
+(format #t "~A~A~%" (eq? (-> process method-table 2) (method process print))
+                    (eq? (-> string method-table 3) (method "test" inspect))
+                    )
+0

goal_src/test/test-new-inline-array-class.gc

@@ -0,0 +1,14 @@
+(deftype my-inline-array-type (inline-array-class)
+  ()
+  )
+
+(set! (-> my-inline-array-type heap-base) 12)
+
+(let ((my-inline-array-obj
+        (the my-inline-array-type
+             (new
+              'debug
+              'my-inline-array-type
+              234))))
+  (asize-of my-inline-array-obj)
+  )

goal_src/test/test-pair-asize.gc

@@ -0,0 +1,3 @@
+(let ((lst (list 5 4)))
+  (asize-of (the pair lst))
+  )

goal_src/test/test-pair-length.gc

@@ -0,0 +1,3 @@
+(let ((lst (list 5 4 3 2 1 0)))
+  (length (the pair lst))
+  )

goal_src/test/test-pointers-1.gc

@@ -0,0 +1,9 @@
+(let* ((base-addr #x6000000)
+      (ptr-int32 (the (pointer int32) base-addr))
+      (ptr-int16 (the (pointer int16) base-addr))
+      )
+  (set! (-> ptr-int32 1) #x00070006)
+  (+ (-> ptr-int16 2)
+     (-> ptr-int16 3)
+     )
+  )

goal_src/test/test-sort-2.gc

@@ -0,0 +1,14 @@
+(defmacro blist (&rest args)
+  (if (null? args)
+      (quote '())
+      `(cons (ash ,(car args) 3) (blist ,@(cdr args)))
+      )
+   )
+
+(let ((my-list
+        (blist 24 16 32 56 72 1234 -34 25 654)
+        ))
+         (format #t "~A~%" my-list)
+  (sort my-list -)
+  (format #t "~A~%" my-list)
+  )

goal_src/test/test-sort-3.gc

@@ -0,0 +1,12 @@
+(defmacro blist (&rest args)
+  (if (null? args)
+      (quote '())
+      `(cons (ash ,(car args) 3) (blist ,@(cdr args)))
+      )
+   )
+
+(let ((my-list (blist 24 16 32 56 72 1234 -34 25 654)))
+  (format #t "~A~%" my-list)
+  (sort my-list (lambda ((x int) (y int)) (< x y)))
+  (format #t "~A~%" my-list)
+  )

goal_src/test/test-sort.gc

@@ -0,0 +1,14 @@
+(defmacro blist (&rest args)
+  (if (null? args)
+      (quote '())
+      `(cons (ash ,(car args) 3) (blist ,@(cdr args)))
+      )
+   )
+
+(let ((my-list
+        (blist 24 16 32 56 72 1234 -34 25 654)
+        ))
+         (format #t "~A~%" my-list)
+  (sort my-list (lambda ((x int) (y int)) (- y x)))
+  (format #t "~A~%" my-list)
+  )

goalc/compiler/Compiler.h

@@ -66,6 +66,7 @@ class Compiler {
   std::string as_string(const goos::Object& o);
   std::string symbol_string(const goos::Object& o);
   std::string quoted_sym_as_string(const goos::Object& o);
+  bool is_basic(const TypeSpec& ts);
   const goos::Object& pair_car(const goos::Object& o);
   const goos::Object& pair_cdr(const goos::Object& o);
   void expect_empty_list(const goos::Object& o);
@@ -80,7 +81,8 @@ class Compiler {
   Val* compile_real_function_call(const goos::Object& form,
                                   RegVal* function,
                                   const std::vector<RegVal*>& args,
-                                  Env* env);
+                                  Env* env,
+                                  std::string method_type_name = "");
 
   TypeSystem m_ts;
   std::unique_ptr<GlobalEnv> m_global_env = nullptr;
@@ -109,6 +111,7 @@ class Compiler {
   RegVal* compile_get_method_of_type(const TypeSpec& type,
                                      const std::string& method_name,
                                      Env* env);
+  RegVal* compile_get_method_of_object(RegVal* object, const std::string& method_name, Env* env);
 
  public:
   // Atoms
@@ -179,6 +182,7 @@ class Compiler {
   Val* compile_new(const goos::Object& form, const goos::Object& rest, Env* env);
   Val* compile_car(const goos::Object& form, const goos::Object& rest, Env* env);
   Val* compile_cdr(const goos::Object& form, const goos::Object& rest, Env* env);
+  Val* compile_method(const goos::Object& form, const goos::Object& rest, Env* env);
 };
 
 #endif  // JAK_COMPILER_H

goalc/compiler/Env.cpp

@@ -39,12 +39,12 @@ BlockEnv* Env::find_block(const std::string& name) {
   return m_parent->find_block(name);
 }
 
-RegVal* Env::make_gpr(TypeSpec ts) {
+RegVal* Env::make_gpr(const TypeSpec& ts) {
-  return make_ireg(std::move(ts), emitter::RegKind::GPR);
+  return make_ireg(coerce_to_reg_type(ts), emitter::RegKind::GPR);
 }
 
-RegVal* Env::make_xmm(TypeSpec ts) {
+RegVal* Env::make_xmm(const TypeSpec& ts) {
-  return make_ireg(std::move(ts), emitter::RegKind::XMM);
+  return make_ireg(coerce_to_reg_type(ts), emitter::RegKind::XMM);
 }
 
 std::unordered_map<std::string, Label>& Env::get_label_map() {
@@ -233,7 +233,7 @@ RegVal* FunctionEnv::make_ireg(TypeSpec ts, emitter::RegKind kind) {
   IRegister ireg;
   ireg.kind = kind;
   ireg.id = m_iregs.size();
-  auto rv = std::make_unique<RegVal>(ireg, ts);
+  auto rv = std::make_unique<RegVal>(ireg, coerce_to_reg_type(ts));
   m_iregs.push_back(std::move(rv));
   assert(kind != emitter::RegKind::INVALID);
   return m_iregs.back().get();

goalc/compiler/Env.h

@@ -36,8 +36,8 @@ class Env {
   virtual RegVal* lexical_lookup(goos::Object sym);
   virtual BlockEnv* find_block(const std::string& name);
   virtual std::unordered_map<std::string, Label>& get_label_map();
-  RegVal* make_gpr(TypeSpec ts);
+  RegVal* make_gpr(const TypeSpec& ts);
-  RegVal* make_xmm(TypeSpec ts);
+  RegVal* make_xmm(const TypeSpec& ts);
   virtual ~Env() = default;
 
   Env* parent() { return m_parent; }

goalc/compiler/Util.cpp

@@ -180,4 +180,8 @@ emitter::RegKind Compiler::get_preferred_reg_kind(const TypeSpec& ts) {
 
 bool Compiler::is_none(Val* in) {
   return dynamic_cast<None*>(in);
+}
+
+bool Compiler::is_basic(const TypeSpec& ts) {
+  return m_ts.typecheck(m_ts.make_typespec("basic"), ts, "", false, false);
 }

goalc/compiler/Val.cpp

@@ -11,7 +11,7 @@ RegVal* Val::to_gpr(Env* fe) {
   if (rv->ireg().kind == emitter::RegKind::GPR) {
     return rv;
   } else {
-    auto re = fe->make_gpr(m_ts);
+    auto re = fe->make_gpr(coerce_to_reg_type(m_ts));
     fe->emit(std::make_unique<IR_RegSet>(re, rv));
     return re;
   }
@@ -39,7 +39,7 @@ RegVal* RegVal::to_gpr(Env* fe) {
   if (m_ireg.kind == emitter::RegKind::GPR) {
     return this;
   } else {
-    auto re = fe->make_gpr(m_ts);
+    auto re = fe->make_gpr(coerce_to_reg_type(m_ts));
     fe->emit(std::make_unique<IR_RegSet>(re, this));
     return re;
   }
@@ -50,58 +50,58 @@ RegVal* RegVal::to_xmm(Env* fe) {
   if (m_ireg.kind == emitter::RegKind::XMM) {
     return this;
   } else {
-    auto re = fe->make_xmm(m_ts);
+    auto re = fe->make_xmm(coerce_to_reg_type(m_ts));
     fe->emit(std::make_unique<IR_RegSet>(re, this));
     return re;
   }
 }
 
 RegVal* IntegerConstantVal::to_reg(Env* fe) {
-  auto rv = fe->make_gpr(m_ts);
+  auto rv = fe->make_gpr(coerce_to_reg_type(m_ts));
   fe->emit(std::make_unique<IR_LoadConstant64>(rv, m_value));
   return rv;
 }
 
 RegVal* SymbolVal::to_reg(Env* fe) {
-  auto re = fe->make_gpr(m_ts);
+  auto re = fe->make_gpr(coerce_to_reg_type(m_ts));
   fe->emit(std::make_unique<IR_LoadSymbolPointer>(re, m_name));
   return re;
 }
 
 RegVal* SymbolValueVal::to_reg(Env* fe) {
-  auto re = fe->make_gpr(m_ts);
+  auto re = fe->make_gpr(coerce_to_reg_type(m_ts));
   fe->emit(std::make_unique<IR_GetSymbolValue>(re, m_sym, m_sext));
   return re;
 }
 
 RegVal* StaticVal::to_reg(Env* fe) {
-  auto re = fe->make_gpr(m_ts);
+  auto re = fe->make_gpr(coerce_to_reg_type(m_ts));
   fe->emit(std::make_unique<IR_StaticVarAddr>(re, obj));
   return re;
 }
 
 RegVal* LambdaVal::to_reg(Env* fe) {
-  auto re = fe->make_gpr(m_ts);
+  auto re = fe->make_gpr(coerce_to_reg_type(m_ts));
   assert(func);
   fe->emit(std::make_unique<IR_FunctionAddr>(re, func));
   return re;
 }
 
 RegVal* FloatConstantVal::to_reg(Env* fe) {
-  auto re = fe->make_xmm(m_ts);
+  auto re = fe->make_xmm(coerce_to_reg_type(m_ts));
   fe->emit(std::make_unique<IR_StaticVarLoad>(re, m_value));
   return re;
 }
 
 RegVal* MemoryOffsetConstantVal::to_reg(Env* fe) {
-  auto re = fe->make_gpr(m_ts);
+  auto re = fe->make_gpr(coerce_to_reg_type(m_ts));
   fe->emit(std::make_unique<IR_LoadConstant64>(re, int64_t(offset)));
   fe->emit(std::make_unique<IR_IntegerMath>(IntegerMathKind::ADD_64, re, base->to_gpr(fe)));
   return re;
 }
 
 RegVal* MemoryOffsetVal::to_reg(Env* fe) {
-  auto re = fe->make_gpr(m_ts);
+  auto re = fe->make_gpr(coerce_to_reg_type(m_ts));
   fe->emit(std::make_unique<IR_RegSet>(re, offset->to_gpr(fe)));
   fe->emit(std::make_unique<IR_IntegerMath>(IntegerMathKind::ADD_64, re, base->to_gpr(fe)));
   return re;
@@ -110,12 +110,12 @@ RegVal* MemoryOffsetVal::to_reg(Env* fe) {
 RegVal* MemoryDerefVal::to_reg(Env* fe) {
   auto base_as_co = dynamic_cast<MemoryOffsetConstantVal*>(base);
   if (base_as_co) {
-    auto re = fe->make_gpr(m_ts);
+    auto re = fe->make_gpr(coerce_to_reg_type(m_ts));
     fe->emit(std::make_unique<IR_LoadConstOffset>(re, base_as_co->offset,
                                                   base_as_co->base->to_gpr(fe), info));
     return re;
   } else {
-    auto re = fe->make_gpr(m_ts);
+    auto re = fe->make_gpr(coerce_to_reg_type(m_ts));
     auto addr = base->to_gpr(fe);
     fe->emit(std::make_unique<IR_LoadConstOffset>(re, 0, addr, info));
     return re;
@@ -123,8 +123,9 @@ RegVal* MemoryDerefVal::to_reg(Env* fe) {
 }
 
 RegVal* AliasVal::to_reg(Env* fe) {
-  auto result = base->to_reg(fe);
+  auto as_old_type = base->to_reg(fe);
-  result->set_type(m_ts);
+  auto result = fe->make_ireg(m_ts, as_old_type->ireg().kind);
+  fe->emit(std::make_unique<IR_RegSet>(result, as_old_type));
   return result;
 }
 
@@ -138,7 +139,7 @@ std::string PairEntryVal::print() const {
 
 RegVal* PairEntryVal::to_reg(Env* fe) {
   int offset = is_car ? -2 : 2;
-  auto re = fe->make_gpr(m_ts);
+  auto re = fe->make_gpr(coerce_to_reg_type(m_ts));
   MemLoadInfo info;
   info.reg = RegKind::GPR_64;
   info.sign_extend = true;

goalc/compiler/Val.h

@@ -64,7 +64,7 @@ class None : public Val {
  */
 class RegVal : public Val {
  public:
-  RegVal(IRegister ireg, TypeSpec ts) : Val(std::move(ts)), m_ireg(ireg) {}
+  RegVal(IRegister ireg, const TypeSpec& ts) : Val(coerce_to_reg_type(ts)), m_ireg(ireg) {}
   bool is_register() const override { return true; }
   IRegister ireg() const override { return m_ireg; }
   std::string print() const override { return m_ireg.to_string(); };

goalc/compiler/compilation/Atoms.cpp

@@ -67,6 +67,7 @@ static const std::unordered_map<
         {"new", &Compiler::compile_new},
         {"car", &Compiler::compile_car},
         {"cdr", &Compiler::compile_cdr},
+        {"method", &Compiler::compile_method},
         //
         //
         //        // LAMBDA
@@ -88,7 +89,7 @@ static const std::unordered_map<
         //        // OBJECT
         //        {"current-method-type", &Compiler::compile_current_method_type},
         //
-        //        {"method", &Compiler::compile_method},
+        //
 
         //        // IT IS MATH
         {"+", &Compiler::compile_add},

goalc/compiler/compilation/Block.cpp

@@ -53,7 +53,7 @@ Val* Compiler::compile_block(const goos::Object& form, const goos::Object& _rest
   auto& return_types = block_env->return_types;
   return_types.push_back(result->type());
   auto return_type = m_ts.lowest_common_ancestor(return_types);
-  block_env->return_value->set_type(return_type);
+  block_env->return_value->set_type(coerce_to_reg_type(return_type));
 
   // an IR to move the result of the block into the block's return register (if no return-from's are
   // taken)

goalc/compiler/compilation/ControlFlow.cpp

@@ -216,7 +216,7 @@ Val* Compiler::compile_cond(const goos::Object& form, const goos::Object& rest,
     env->emit(std::move(get_false));
   }
 
-  result->set_type(m_ts.lowest_common_ancestor(case_result_types));
+  result->set_type(coerce_to_reg_type(m_ts.lowest_common_ancestor(case_result_types)));
 
   // PATCH END
   end_label->idx = fenv->code().size();

goalc/compiler/compilation/Define.cpp

@@ -109,6 +109,10 @@ Val* Compiler::compile_set(const goos::Object& form, const goos::Object& rest, E
             source, base_as_mco->offset, base_as_mco->base->to_gpr(env), ti->get_load_size()));
         return source;
       } else {
+        auto ti = m_ts.lookup_type(base->type());
+        env->emit(std::make_unique<IR_StoreConstOffset>(source, 0, base->to_gpr(env),
+                                                        ti->get_load_size()));
+        return source;
         throw_compile_error(form, "Set not implemented for this (non-mco) yet");
       }
     } else if (as_pair) {

goalc/compiler/compilation/Function.cpp

@@ -284,21 +284,23 @@ Val* Compiler::compile_function_or_method_call(const goos::Object& form, Env* en
   } else {
     // not an inline call
     if (is_method_call) {
-      throw_compile_error(form, "Unrecognized symbol " + uneval_head.print() + " as head of form");
+      if (eval_args.empty()) {
-      //      // determine the method to call by looking at the type of first argument
+        throw_compile_error(form,
-      //      if (eval_args.empty()) {
+                            "Unrecognized symbol " + uneval_head.print() + " as head of form");
-      //
+      }
-      //      }
+      head = compile_get_method_of_object(eval_args.front(), symbol_string(uneval_head), env);
-      //      printf("BAD %s\n", uneval_head.print().c_str());
-      //      assert(false);  // nyi
-      // head = compile_get_method_of_object(eval_args.front(), symbol_string(uneval_head), env);
     }
 
     // convert the head to a GPR
-    auto head_as_gpr =
+    auto head_as_gpr = head->to_gpr(env);
-        head->to_gpr(env);  // std::dynamic_pointer_cast<GprPlace>(resolve_to_gpr(head, env));
     if (head_as_gpr) {
-      return compile_real_function_call(form, head_as_gpr, eval_args, env);
+      if (is_method_call) {
+        return compile_real_function_call(form, head_as_gpr, eval_args, env,
+                                          eval_args.front()->type().base_type());
+      } else {
+        return compile_real_function_call(form, head_as_gpr, eval_args, env);
+      }
+
     } else {
       throw_compile_error(form, "can't figure out this function call!");
     }
@@ -311,7 +313,8 @@ Val* Compiler::compile_function_or_method_call(const goos::Object& form, Env* en
 Val* Compiler::compile_real_function_call(const goos::Object& form,
                                           RegVal* function,
                                           const std::vector<RegVal*>& args,
-                                          Env* env) {
+                                          Env* env,
+                                          std::string method_type_name) {
   auto fe = get_parent_env_of_type<FunctionEnv>(env);
   fe->require_aligned_stack();
   TypeSpec return_ts;
@@ -341,14 +344,18 @@ Val* Compiler::compile_real_function_call(const goos::Object& form,
   // check arg count:
   if (function->type().arg_count()) {
     if (function->type().arg_count() - 1 != args.size()) {
-      printf("got type %s\n", function->type().print().c_str());
       throw_compile_error(form, "invalid number of arguments to function call: got " +
                                     std::to_string(args.size()) + " and expected " +
                                     std::to_string(function->type().arg_count() - 1) + " for " +
                                     function->type().print());
     }
     for (uint32_t i = 0; i < args.size(); i++) {
-      typecheck(form, function->type().get_arg(i), args.at(i)->type(), "function argument");
+      if (method_type_name.empty()) {
+        typecheck(form, function->type().get_arg(i), args.at(i)->type(), "function argument");
+      } else {
+        typecheck(form, function->type().get_arg(i).substitute_for_method_call(method_type_name),
+                  args.at(i)->type(), "function argument");
+      }
     }
   }
 

goalc/compiler/compilation/Type.cpp

@@ -1,11 +1,19 @@
 #include "goalc/compiler/Compiler.h"
 #include "common/type_system/deftype.h"
 
+namespace {
+int get_offset_of_method(int id) {
+  // todo - something that looks at the type system?
+  // this will need changing if the layout of type ever changes.
+  return 16 + 4 * id;
+}
+}  // namespace
+
 RegVal* Compiler::compile_get_method_of_type(const TypeSpec& type,
                                              const std::string& method_name,
                                              Env* env) {
   auto info = m_ts.lookup_method(type.base_type(), method_name);
-  auto offset_of_method = 16 + 4 * info.id;  // todo, something more flexible?
+  auto offset_of_method = get_offset_of_method(info.id);
 
   auto fe = get_parent_env_of_type<FunctionEnv>(env);
   auto typ = compile_get_symbol_value(type.base_type(), env)->to_gpr(env);
@@ -25,6 +33,43 @@ RegVal* Compiler::compile_get_method_of_type(const TypeSpec& type,
   return deref->to_reg(env);
 }
 
+RegVal* Compiler::compile_get_method_of_object(RegVal* object,
+                                               const std::string& method_name,
+                                               Env* env) {
+  auto& compile_time_type = object->type();
+  auto method_info = m_ts.lookup_method(compile_time_type.base_type(), method_name);
+  auto fe = get_parent_env_of_type<FunctionEnv>(env);
+
+  RegVal* runtime_type = nullptr;
+  if (is_basic(compile_time_type)) {
+    runtime_type = fe->make_gpr(m_ts.make_typespec("type"));
+    MemLoadInfo info;
+    info.size = 4;
+    info.sign_extend = false;
+    info.reg = RegKind::GPR_64;
+    env->emit(std::make_unique<IR_LoadConstOffset>(runtime_type, -4, object, info));
+  } else {
+    // can't look up at runtime
+    runtime_type = compile_get_symbol_value(compile_time_type.base_type(), env)->to_gpr(env);
+  }
+
+  auto offset_of_method = get_offset_of_method(method_info.id);
+  MemLoadInfo load_info;
+  load_info.sign_extend = false;
+  load_info.size = POINTER_SIZE;
+
+  auto loc_type = m_ts.make_pointer_typespec(method_info.type);
+  auto loc = fe->alloc_val<MemoryOffsetConstantVal>(loc_type, runtime_type, offset_of_method);
+  auto di = m_ts.get_deref_info(loc_type);
+  assert(di.can_deref);
+  assert(di.mem_deref);
+  assert(di.sign_extend == false);
+  assert(di.load_size == 4);
+
+  auto deref = fe->alloc_val<MemoryDerefVal>(di.result_type, loc, MemLoadInfo(di));
+  return deref->to_reg(env);
+}
+
 Val* Compiler::compile_deftype(const goos::Object& form, const goos::Object& rest, Env* env) {
   (void)form;
   (void)env;
@@ -100,6 +145,7 @@ Val* Compiler::compile_defmethod(const goos::Object& form, const goos::Object& _
 
   auto new_func_env = std::make_unique<FunctionEnv>(env, lambda.debug_name);
   new_func_env->set_segment(MAIN_SEGMENT);  // todo, how do we set debug?
+  new_func_env->method_of_type_name = symbol_string(type_name);
 
   // set up arguments
   assert(lambda.params.size() < 8);  // todo graceful error
@@ -138,6 +184,8 @@ Val* Compiler::compile_defmethod(const goos::Object& form, const goos::Object& _
   if (result) {
     auto final_result = result->to_gpr(new_func_env.get());
     new_func_env->emit(std::make_unique<IR_Return>(return_reg, final_result));
+    printf("return type is %s from %s from %s\n", final_result->type().print().c_str(),
+           final_result->print().c_str(), result->print().c_str());
     lambda_ts.add_arg(final_result->type());
   } else {
     lambda_ts.add_arg(m_ts.make_typespec("none"));
@@ -336,4 +384,22 @@ Val* Compiler::compile_cdr(const goos::Object& form, const goos::Object& rest, E
   auto fe = get_parent_env_of_type<FunctionEnv>(env);
   return fe->alloc_val<PairEntryVal>(m_ts.make_typespec("object"),
                                      compile_error_guard(args.unnamed.at(0), env), false);
-}
+}
+
+// todo, consider splitting into method-of-object and method-of-type?
+Val* Compiler::compile_method(const goos::Object& form, const goos::Object& rest, Env* env) {
+  auto args = get_va(form, rest);
+  va_check(form, args, {{}, {goos::ObjectType::SYMBOL}}, {});
+
+  auto arg = args.unnamed.at(0);
+  auto method_name = symbol_string(args.unnamed.at(1));
+
+  if (arg.is_symbol()) {
+    if (m_ts.fully_defined_type_exists(symbol_string(arg))) {
+      return compile_get_method_of_type(m_ts.make_typespec(symbol_string(arg)), method_name, env);
+    }
+  }
+
+  auto obj = compile_error_guard(arg, env)->to_gpr(env);
+  return compile_get_method_of_object(obj, method_name, env);
+}

test/test_compiler_and_runtime.cpp

@@ -136,6 +136,27 @@ TEST(CompilerAndRuntime, BuildGameAndTest) {
   runner.run_test("test-access-inline-array.gc", {"1.2345\n0\n"});
   runner.run_test("test-find-parent-method.gc", {"\"test pass!\"\n0\n"});
   runner.run_test("test-ref.gc", {"83\n"});
+  runner.run_test("test-pair-asize.gc", {"8\n"});
+  runner.run_test("test-last.gc", {"d\n0\n"});
+  runner.run_test("test-sort.gc",
+                  {"(24 16 32 56 72 1234 -34 25 654)\n(1234 654 72 56 32 25 24 16 -34)\n0\n"});
+  runner.run_test("test-sort-2.gc",
+                  {"(24 16 32 56 72 1234 -34 25 654)\n(-34 16 24 25 32 56 72 654 1234)\n0\n"});
+  runner.run_test("test-sort-3.gc",
+                  {"(24 16 32 56 72 1234 -34 25 654)\n(-34 16 24 25 32 56 72 654 1234)\n0\n"});
+  runner.run_test("test-pair-length.gc", {"6\n"});
+  runner.run_test("test-member-1.gc", {"(c d)\n0\n"});
+  runner.run_test("test-member-2.gc", {"#f\n0\n"});
+  runner.run_test("test-assoc-1.gc", {"w\n0\n"});
+  runner.run_test("test-assoc-2.gc", {"#f\n0\n"});
+  runner.run_test("test-assoce-1.gc", {"x\n0\n"});
+  runner.run_test("test-assoce-2.gc", {"x\n0\n"});
+  runner.run_test("test-append.gc", {"(a b c d e)\n0\n"});
+  runner.run_test("test-delete-list.gc", {"(a b d e)\n0\n"});
+  runner.run_test("test-delete-car.gc", {"((a . b) (e . f))\n#f\n0\n"});
+  runner.run_test("test-insert-cons.gc", {"((c . w) (a . b) (e . f))\n0\n"});
+  runner.run_test("test-new-inline-array-class.gc", {"2820\n"});
+  runner.run_test("test-memcpy.gc", {"13\n"});
 
   runner.print_summary();
 
@@ -307,6 +328,8 @@ TEST(CompilerAndRuntime, CompilerTests) {
   runner.run_test("test-car-cdr-set.gc", {"(c . d)\n0\n"});
   runner.run_test("test-nested-car-cdr-set.gc", {"efgh\n((e . g) f . h)\n0\n"});
   runner.run_test("test-dotimes.gc", {"4950\n"});
+  runner.run_test("test-methods.gc", {"#t#t\n0\n"});
+  runner.run_test("test-pointers-1.gc", {"13\n"});
 
   compiler.shutdown_target();
   runtime_thread.join();