Add classes to core library.

Makefile

@@ -159,15 +159,17 @@ test: $(JANET_TARGET) $(TEST_PROGRAMS)
 	./$(JANET_TARGET) test/suite0.janet
 	./$(JANET_TARGET) test/suite1.janet
 	./$(JANET_TARGET) test/suite2.janet
+	./$(JANET_TARGET) test/suite3.janet
 
 valtest: $(JANET_TARGET) $(TEST_PROGRAMS)
-	valgrind --leak-check=full -b ctest/system_test.out
+	valgrind --leak-check=full -v ctest/system_test.out
 	valgrind --leak-check=full -v ctest/array_test.out
 	valgrind --leak-check=full -v ctest/buffer_test.out
 	valgrind --leak-check=full -v ctest/table_test.out
 	valgrind --leak-check=full -v ./$(JANET_TARGET) test/suite0.janet
 	valgrind --leak-check=full -v ./$(JANET_TARGET) test/suite1.janet
 	valgrind --leak-check=full -v ./$(JANET_TARGET) test/suite2.janet
+	valgrind --leak-check=full -v ./$(JANET_TARGET) test/suite3.janet
 
 ###################
 ##### Natives #####

examples/classes.janet

@@ -1,9 +1,31 @@
-# Classes need to:
-# 1. Construct Objects
-# 2. Keep metadata of objects
-# 3. Support Method Lookup given a method signature
-# 4. Add Methods
-# 5. Keep around state
+#
+# A simple OO implementation similar to that of the Self language.
+# Objects are just tables in which the class is the prototype table.
+# This means that classes themselves are also objects.
+#
+# Create a new class
+#   (defclass Car)
+# or
+#   (def Car @{})
+#
+# Define a constructor
+#   (defm Car:init [color]
+#     (put self :color color))
+#
+# Define a method
+#   (defm Car:honk []
+#     (print "I am a " (get self :color) " car!"))
+#
+# Create an instance
+#   (def mycar (new Car :red))
+#
+# Call a method
+#   (mcall mycar:honk)
+# or
+#   ($ mycar:honk)
+# If the method declaration is in scope, one can also
+# invoke the method directly.
+#   (Car:honk mycar)
 
 (defn- parse-signature
   "Turn a signature into a (method, object) pair."
@@ -23,45 +45,60 @@
   (put bodya args-index (tuple.prepend (get bodya args-index) 'self))
   bodya)
 
-(defmacro call
+#
+# Public API
+#
+
+(def class 
+  "(class obj)\n\nGets the class of an object."
+  table.getproto)
+
+(defn instance-of?
+  "Checks if an object is an instance of a class."
+  [class obj]
+  (if obj (or 
+            (= class obj) 
+            (instance-of? class (table.getproto obj)))))
+
+(defmacro mcall
   "Call a method."
   [signature & args]
   (def [method self] (parse-signature signature))
   (apply tuple (tuple get self method) self args))
 
-(def :macro $ call)
+(def $ :macro mcall)
 
-(defn class
-  "Create a new class."
-  [& args]
-  (def classobj (apply table args))
-
-  # Set up super class
-  (def super (get classobj :super))
-  (when super
-    (put classobj :super nil)
-    (table.setproto classobj super))
-
-  classobj)
+(defmacro wrap-mcall
+  "Wrap a method call in a function."
+  [signature & args]
+  (def [method self] (parse-signature signature))
+  (def $m (gensym))
+  (def $args (gensym))
+  (tuple 'do
+         (tuple 'def $m (tuple get self method))
+         (tuple 'fn (symbol "wrapped-" signature) [tuple '& $args]
+                (tuple apply $m self $args))))
 
 (defn new
-  "Create a new instance of a class."
+  "Create a new instance of a class by creating a new
+  table whose prototype is class. If class has an init method,
+  that will be called on the new object. Returns the new object."
   [class & args]
   (def obj (table.setproto @{} class))
   (def init (get class 'init))
   (when init (apply init obj args))
   obj)
 
-(defmacro defmethod
+(defmacro defm
   "Defines a method for a class."
   [signature & args]
   (def [method self] (parse-signature signature))
   (def newargs (add-self-to-body args))
-  (tuple put self method (tuple.prepend newargs signature 'fn)))
+  (tuple put self method (apply defn signature newargs)))
 
 (defmacro defclass
   "Defines a new class."
-  [name & body]
+  [name & args]
+  (if (not name) (error "expected a name"))
   (tuple 'def name
-         (tuple.prepend body class)))
-
+         (apply tuple table :name (tuple 'quote name) args)))

src/core/array.c

@@ -193,6 +193,8 @@ static int cfun_slice(JanetArgs args) {
     }
     if (start < 0) start = len + start;
     if (end < 0) end = len + end + 1;
+    if (end < 0 || start < 0 || end > len || start > len)
+        JANET_THROW(args, "slice range out of bounds");
     if (end >= start) {
         ret = janet_array(end - start);
         memcpy(ret->data, vals + start, sizeof(Janet) * (end - start));
@@ -228,6 +230,29 @@ static int cfun_concat(JanetArgs args) {
     JANET_RETURN_ARRAY(args, array);
 }
 
+static int cfun_insert(JanetArgs args) {
+    int32_t at;
+    size_t chunksize, restsize;
+    JanetArray *array;
+    JANET_MINARITY(args, 2);
+    JANET_ARG_ARRAY(array, args, 0);
+    JANET_ARG_INTEGER(at, args, 1);
+    if (at < 0) {
+        at = array->count + at + 1; 
+    }
+    if (at < 0 || at > array->count)
+        JANET_THROW(args, "insertion index out of bounds");
+    chunksize = (args.n - 2) * sizeof(Janet);
+    restsize = (array->count - at) * sizeof(Janet);
+    janet_array_ensure(array, array->count + args.n - 2, 2);
+    memmove(array->data + at + args.n - 2,
+            array->data + at,
+            restsize);
+    memcpy(array->data + at, args.v + 2, chunksize);
+    array->count += (args.n - 2);
+    JANET_RETURN_ARRAY(args, array);
+}
+
 static const JanetReg cfuns[] = {
     {"array.new", cfun_new,
         "(array.new capacity)\n\n"
@@ -273,6 +298,13 @@ static const JanetReg cfuns[] = {
         "be inserted into the array. Otherwise, each part in parts will be appended to arr in order. "
         "Return the modified array arr."
     },
+    {"array.insert", cfun_insert,
+        "(array.insert arr at & xs)\n\n"
+        "Insert all of xs into array arr at index at. at should be an integer "
+        "0 and the length of the array. A negative value for at will index from "
+        "the end of the array, such that inserting at -1 appends to the array. "
+        "Returns the array."
+    },
     {NULL, NULL, NULL}
 };
 

src/core/buffer.c

@@ -257,6 +257,8 @@ static int cfun_slice(JanetArgs args) {
     }
     if (start < 0) start = len + start;
     if (end < 0) end = len + end + 1;
+    if (end < 0 || start < 0 || end > len || start > len)
+        JANET_THROW(args, "slice range out of bounds");
     if (end >= start) {
         ret = janet_buffer(end - start);
         memcpy(ret->data, data + start, end - start);

src/core/core.janet

@@ -1062,6 +1062,79 @@ value, one key will be ignored."
     (:= current (macroexpand-1 current)))
   current)
 
+
+###
+###
+### Classes
+###
+###
+
+(defn- parse-signature
+  "Turn a signature into a (method, object) pair."
+  [signature]
+  (when (not (symbol? signature)) (error "expected method signature"))
+  (def parts (string.split ":" signature))
+  (def self (symbol (get parts 0)))
+  (def method (apply symbol (tuple.slice parts 1)))
+  (tuple (tuple 'quote method) self))
+
+(def class 
+  "(class obj)\n\nGets the class of an object."
+  table.getproto)
+
+(defn instance-of?
+  "Checks if an object is an instance of a class."
+  [class obj]
+  (if obj (or 
+            (= class obj) 
+            (instance-of? class (table.getproto obj)))))
+
+(defmacro call
+  "Call a method."
+  [signature & args]
+  (def [method self] (parse-signature signature))
+  (apply tuple (tuple get self method) self args))
+
+(def $ :macro call)
+
+(defmacro wrap-call
+  "Wrap a method call in a function."
+  [signature & args]
+  (def [method self] (parse-signature signature))
+  (def $m (gensym))
+  (def $args (gensym))
+  (tuple 'do
+         (tuple 'def $m (tuple get self method))
+         (tuple 'fn (symbol "wrapped-" signature) [tuple '& $args]
+                (tuple apply $m self $args))))
+
+(defmacro defm
+  "Defines a method for a class."
+  [signature & args]
+  (def [method self] (parse-signature signature))
+  (def i (find-index tuple? args))
+  (def newargs (array.slice args))
+  (put newargs i (tuple.prepend (get newargs i) 'self))
+  (tuple put self method (apply defn signature newargs)))
+
+(defmacro defnew
+  "Defines the constructor for a class."
+  [class & args]
+  (def newargs (array.slice args))
+  (def i (find-index tuple? args))
+  (array.insert newargs (+ i 1) (tuple 'def 'self (tuple table.setproto @{} class)))
+  (array.push newargs 'self)
+  (tuple put class ''new (apply defn (symbol class :new)  newargs)))
+
+(defmacro defclass
+  "Defines a new prototype class."
+  [name & args]
+  (if (not name) (error "expected a name"))
+  (tuple 'def name
+         (apply tuple table :name (tuple 'quote name) args)))
+
+(put _env 'parse-signature nil)
+
 ###
 ###
 ### Evaluation and Compilation

src/core/string.c

@@ -801,6 +801,8 @@ static int cfun_slice(JanetArgs args) {
     }
     if (start < 0) start = len + start;
     if (end < 0) end = len + end + 1;
+    if (end < 0 || start < 0 || end > len || start > len)
+        JANET_THROW(args, "slice range out of bounds");
     if (end >= start) {
         ret = janet_string(data + start, end - start);
     } else {

src/core/tuple.c

@@ -116,6 +116,8 @@ static int cfun_slice(JanetArgs args) {
     }
     if (start < 0) start = len + start;
     if (end < 0) end = len + end + 1;
+    if (end < 0 || start < 0 || end > len || start > len)
+        JANET_THROW(args, "slice range out of bounds");
     if (end >= start) {
         ret = janet_tuple_begin(end - start);
         memcpy(ret, vals + start, sizeof(Janet) * (end - start));

test/suite3.janet

@@ -0,0 +1,50 @@
+# Copyright (c) 2018 Calvin Rose
+#
+# Permission is hereby granted, free of charge, to any person obtaining a copy
+# of this software and associated documentation files (the "Software"), to
+# deal in the Software without restriction, including without limitation the
+# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+# sell copies of the Software, and to permit persons to whom the Software is
+# furnished to do so, subject to the following conditions:
+#
+# The above copyright notice and this permission notice shall be included in
+# all copies or substantial portions of the Software.
+#
+# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+# IN THE SOFTWARE.
+
+(import test.helper :prefix "" :exit true)
+(start-suite 3)
+
+# Class stuff
+(defclass Car)
+
+(defnew Car
+  "Make a new car."
+  [color]
+  (put self :color color))
+
+(defm Car:honk
+  "Honk the horn."
+  []
+  (string "Honk! from a " (get self :color) " car!"))
+
+(def redcar (Car:new :red))
+(def greencar (Car:new :green))
+
+(assert (= (call redcar:honk) ($ redcar:honk)) "$ alias for call 1")
+(assert (= (call greencar:honk) ($ greencar:honk)) "$ alias for call 2")
+
+(assert (= (call redcar:honk) "Honk! from a :red car!") "method call 1")
+(assert (= (call greencar:honk) "Honk! from a :green car!") "method call 2")
+
+(def wrapper (wrap-call redcar:honk))
+(assert (= (call redcar:honk) (wrapper)) "wrap-call")
+
+(end-suite)
+