mirror of
https://github.com/janet-lang/janet
synced 2024-12-24 23:40:27 +00:00
Add classes to core library.
This commit is contained in:
parent
d4ee760b3e
commit
b2a1a4ec9b
4
Makefile
4
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 #####
|
||||
|
@ -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)))
|
||||
|
@ -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}
|
||||
};
|
||||
|
||||
|
@ -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);
|
||||
|
@ -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
|
||||
|
@ -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 {
|
||||
|
@ -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));
|
||||
|
50
test/suite3.janet
Normal file
50
test/suite3.janet
Normal file
@ -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)
|
||||
|
Loading…
Reference in New Issue
Block a user