felix/slime
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

implement vectors

Browse Source
This commit is contained in:
Felix Brendel
2019-08-08 14:21:30 +02:00
parent 5fa2c1bbf9
commit 4f2793b7ef
13 changed files with 279 additions and 1125 deletions
Download Patch File Download Diff File Expand all files Collapse all files
bin/automata.slime
+9 -35
View File
@@ -1,36 +1,10 @@
(import "sets.slime")
(define-module automata
:exports (make-dfa)
(import "sets.slime")
(define (make-dfa Q S delta q0 F)
(let ((q q0))
(lambda (s)
(mutate q (delta q s))
`(,(if (set-contains? F q) :accept :fail) ,q))))
(define (delta q s)
(cond (s (case q
(("q0") (case s (("M") "q1")))
(("q1") (case s (("A") "q0")
(("G") "q2")))
(("q2") (case s (("E") "q0")))))
(else q)))
;; (make-delta
;; ("q0" :: "M" -> "q1")
;; ("q1" :: "A" -> "q0"
;; "G" -> "q1")
;; ("q2" :: "E" -> "q0"))
(define aut (make-dfa (make-set "q0" "q1" "q2")
(make-set "M" "A" "G" "E")
delta
"q0"
(make-set "q0")))
(printf (aut "M"))
(printf (aut "A"))
(printf (aut "M"))
(printf (aut "G"))
(printf (aut "E"))
(define (make-dfa Q S delta q0 F)
(let ((q q0))
(lambda (s)
(set! q (delta q s))
(list (if (set::contains? F q) :accept :fail) q))))
)
bin/interpolation.slime
+6 -3
View File
@@ -1,5 +1,8 @@
(define-package interpolation
(define-module interpolation
:exports (lerp lerper stepped-lerper
point-lerp point-lerper
bezier2 bezierer2)
(define-typed (lerp a :number b :number t :number)
(+ (* t (- b a)) a))
@@ -43,5 +46,5 @@
)
(define sl1 (interpolation-> stepped-lerper 0 1 5))
(define sl2 (interpolation-> stepped-lerper 10 -10 20))
(define sl1 (interpolation::stepped-lerper 0 1 5))
(define sl2 (interpolation::stepped-lerper 10 -10 20))
bin/math.slime
+3 -2
View File
@@ -1,6 +1,7 @@
(import "oo.slime")
(define-module math
:exports (pi abs sqrt make-vector3)
(define-package math
(import "oo.slime")
(define pi
"Tha famous circle constant."
bin/pre.slime
+29 -12
View File
@@ -1,3 +1,5 @@
(define-syntax (pe expr)
`(printf ',expr "evaluates to" ,expr))
@@ -141,18 +143,33 @@ ithe sequence as arguemens."
(assert-types= @lambda-list)
@body)))
(define-syntax (define-package name :rest body)
`(define ,(string->symbol (concat-strings (symbol->string name) "->"))
((lambda ()
@body
(set-type
(special-lambda (:rest args)
(let ((op (first args))
(args (rest args)))
(if (callable? (eval op))
(apply op args)
(eval op))))
:package)))))
(define-syntax (define-module module-name :keys exports :rest body)
(let ((module-prefix (concat-strings (symbol->string module-name) "::")))
(eval `(begin @body))
(pair 'begin
(map (lambda (orig-export-name)
(let ((export-name (string->symbol
(concat-strings module-prefix
(symbol->string orig-export-name)))))
`(define ,export-name
,(try (eval orig-export-name)
(error "The module does not contain" orig-export-name)))))
exports))))
;; (define-syntax (define-package name :rest body)
;; `(define ,(string->symbol (concat-strings (symbol->string name) "->"))
;; ((lambda ()
;; @body
;; (set-type
;; (special-lambda (:rest args)
;; (let ((op (first args))
;; (args (rest args)))
;; (if (callable? (eval op))
;; (apply op args)
;; (eval op))))
;; :package)))))
(define (null? x)
"Checks if the argument is =nil=."
bin/sets.slime
+27 -22
View File
@@ -1,28 +1,33 @@
(import "cxr.slime")
(define-module set
:exports (make find contains? insert!)
(define key-not-found-index -1)
(import "cxr.slime")
(define (make-set :rest vals)
(set-type
(if vals
(list vals)
'(()))
:set))
(define key-not-found-index -1)
(define (set-find set val)
(let ((values (car set)))
(define (inner values current-index)
(cond ((null? values) key-not-found-index)
((= (car values) val) current-index)
(else (inner (cdr values) (+ 1 current-index)))))
(inner values 0)))
(define (make :rest vals)
(set-type
(if vals
(list vals)
'(()))
:set))
(define (set-contains? set val)
(unless (= (set-find set val) key-not-found-index)
(define (find set val)
(let ((values (car set)))
(define (inner values current-index)
(cond ((null? values) key-not-found-index)
((= (car values) val) current-index)
(else (inner (cdr values) (+ 1 current-index)))))
(inner values 0)))
(define (contains? set val)
(unless (= (find set val) key-not-found-index)
t))
(define (set-insert! set value)
(unless (set-contains? set value)
(mutate set (pair (pair value (first set)) ()))
(set-type set :set))
set)
(define (insert! set value)
(unless (contains? set value)
(set! set (pair (pair value (first set)) ()))
(set-type set :set))
set)
)
bin/tests/automata.slime
+46
View File
@@ -0,0 +1,46 @@
(import "sets.slime")
(import "automata.slime")
;; (make-delta
;; ("q0" :: "M" -> "q1")
;; ("q1" :: "A" -> "q0"
;; "G" -> "q1")
;; ("q2" :: "E" -> "q0"))
(define (delta q s)
(cond (s (case q
(("q0") (case s (("M") "q1")))
(("q1") (case s (("A") "q0")
(("G") "q2")))
(("q2") (case s (("E") "q0")))))
(else q)))
(define aut (automata::make-dfa (set::make "q0" "q1" "q2")
(set::make "M" "A" "G" "E")
delta
"q0"
(set::make "q0")))
(let ((state (aut ())))
(assert (= (first state) :accept))
(assert (= (first (rest state)) "q0")))
(let ((state (aut "M")))
(assert (= (first state) :fail))
(assert (= (first (rest state)) "q1")))
(let ((state (aut "A")))
(assert (= (first state) :accept))
(assert (= (first (rest state)) "q0")))
(let ((state (aut "M")))
(assert (= (first state) :fail))
(assert (= (first (rest state)) "q1")))
(let ((state (aut "G")))
(assert (= (first state) :fail))
(assert (= (first (rest state)) "q2")))
(let ((state (aut "E")))
(assert (= (first state) :accept))
(assert (= (first (rest state)) "q0")))
manual/built-in-docs.org
+65 -1050
View File
File diff suppressed because it is too large Load Diff
src/built_ins.cpp
+31 -1
View File
@@ -22,6 +22,7 @@ proc lisp_object_equal(Lisp_Object* n1, Lisp_Object* n2) -> bool {
case Lisp_Object_Type::Number: return n1->value.number == n2->value.number;
case Lisp_Object_Type::String: return string_equal(n1->value.string, n2->value.string);
case Lisp_Object_Type::Pair:
case Lisp_Object_Type::Vector:
create_not_yet_implemented_error();
return false;
}
@@ -456,7 +457,7 @@ proc load_built_ins_into_environment() -> void {
try assert_type(target_symbol, Lisp_Object_Type::Symbol);
Environment* target_env = find_binding_environment(target_symbol->value.symbol.identifier, get_current_environment());
assert(target_env);
try assert(target_env);
push_environment(target_env);
defer {
@@ -465,6 +466,28 @@ proc load_built_ins_into_environment() -> void {
define_symbol(target_symbol, source);
return source;
});
defun("set-car!", "TODO", __LINE__, cLambda {
try evaluated_arguments = eval_arguments(arguments, &arguments_length);
try assert_arguments_length(2, arguments_length);
Lisp_Object* target = evaluated_arguments->value.pair.first;
Lisp_Object* source = evaluated_arguments->value.pair.rest->value.pair.first;
assert_type(target, Lisp_Object_Type::Pair);
*target->value.pair.first = *source;
return source;
});
defun("set-cdr!", "TODO", __LINE__, cLambda {
try evaluated_arguments = eval_arguments(arguments, &arguments_length);
try assert_arguments_length(2, arguments_length);
Lisp_Object* target = evaluated_arguments->value.pair.first;
Lisp_Object* source = evaluated_arguments->value.pair.rest->value.pair.first;
assert_type(target, Lisp_Object_Type::Pair);
*target->value.pair.rest = *source;
return source;
});
defun("if", "TODO", __LINE__, cLambda {
@@ -750,6 +773,12 @@ proc load_built_ins_into_environment() -> void {
try evaluated_arguments = eval_arguments(arguments, &arguments_length);
return evaluated_arguments;
});
defun("vector", "TODO", __LINE__, cLambda {
try evaluated_arguments = eval_arguments(arguments, &arguments_length);
Lisp_Object* ret;
try ret = Memory::create_lisp_object_vector(arguments_length, evaluated_arguments);
return ret;
});
defun("pair", "TODO", __LINE__, cLambda {
try evaluated_arguments = eval_arguments(arguments, &arguments_length);
try assert_arguments_length(2, arguments_length);
@@ -829,6 +858,7 @@ proc load_built_ins_into_environment() -> void {
case Lisp_Object_Type::T: return Memory::get_or_create_lisp_object_keyword("t");
case Lisp_Object_Type::Number: return Memory::get_or_create_lisp_object_keyword("number");
case Lisp_Object_Type::Pair: return Memory::get_or_create_lisp_object_keyword("pair");
case Lisp_Object_Type::Vector: return Memory::get_or_create_lisp_object_keyword("vector");
case Lisp_Object_Type::String: return Memory::get_or_create_lisp_object_keyword("string");
case Lisp_Object_Type::Symbol: return Memory::get_or_create_lisp_object_keyword("symbol");
}
src/io.cpp
+8
View File
@@ -294,6 +294,14 @@ proc print(Lisp_Object* node, bool print_repr = false, FILE* file = stdout) -> v
else
fputs(Memory::get_c_str(node->value.string), file);
} break;
case (Lisp_Object_Type::Vector): {
fputs("[vector", file);
for (int i = 0; i < node->value.vector.length; ++i) {
fputs(" ", file);
print(node->value.vector.data+i);
}
fputs("]", file);
} break;
case (Lisp_Object_Type::Function): {
if (node->userType) {
fprintf(file, "[%s]", Memory::get_c_str(node->userType->value.symbol.identifier));
src/lisp_object.cpp
+1
View File
@@ -21,6 +21,7 @@ proc Lisp_Object_Type_to_string(Lisp_Object_Type type) -> const char* {
case(Lisp_Object_Type::CFunction): return "C-function";
case(Lisp_Object_Type::Continuation): return "continuation";
case(Lisp_Object_Type::Pair): return "pair";
case(Lisp_Object_Type::Vector): return "vector";
}
return "unknown";
}
src/memory.cpp
+44
View File
@@ -226,6 +226,50 @@ namespace Memory {
return node;
}
proc allocate_vector(int size) -> Lisp_Object* {
/*
int object_memory_size;
Int_Array_List* free_spots_in_object_memory;
Lisp_Object* object_memory;
int next_index_in_object_memory = 0;
*/
if (object_memory_size - next_index_in_object_memory < size) {
create_out_of_memory_error(
"There is not enough space in the lisp object "
"memory to allocate additional lisp objects. "
"Maybe try increasing the Memory size when "
"calling Memory::init()");
return nullptr;
}
int start = next_index_in_object_memory;
next_index_in_object_memory += size;
return object_memory+start;
}
proc create_lisp_object_vector(int length, Lisp_Object* element_list) -> Lisp_Object* {
try assert_type(element_list, Lisp_Object_Type::Pair);
Lisp_Object* node;
try node = create_lisp_object();
set_type(node, Lisp_Object_Type::Vector);
node->value.vector.length = length;
try node->value.vector.data = allocate_vector(length);
Lisp_Object* head = element_list;
int i = 0;
while (head != Memory::nil) {
node->value.vector.data[i] = *head->value.pair.first;
head = head->value.pair.rest;
++i;
}
return node;
}
proc get_or_create_lisp_object_symbol(String* identifier) -> Lisp_Object* {
// TODO(Felix): if we already have it stored somewhere then
// reuse it and dont create new one
src/structs.cpp
+8
View File
@@ -16,6 +16,7 @@ enum struct Lisp_Object_Type {
Number,
String,
Pair,
Vector,
Continuation,
// Pointer,
// OwningPointer,
@@ -76,6 +77,11 @@ struct Pair {
Lisp_Object* rest;
};
struct Vector {
int length;
Lisp_Object* data;
};
struct Positional_Arguments {
Lisp_Object** symbols; // Array of Pointers to Lisp_Object<Symbol>
int next_index;
@@ -87,6 +93,7 @@ struct Keyword_Arguments {
// NOTE(Felix): values[i] will be nullptr if no defalut value was
// declared for key identifiers[i]
Lisp_Object_Array_List* values;
// TODO(Felix): Why do we use a Array list here??
int next_index;
int length;
};
@@ -116,6 +123,7 @@ struct Lisp_Object {
double number;
String* string;
Pair pair;
Vector vector;
Function function;
cFunction* cFunction;
Continuation continuation;
src/testing.cpp
+2
View File
@@ -639,6 +639,8 @@ proc run_all_tests() -> bool {
invoke_test_script("import_and_load");
invoke_test_script("sicp");
invoke_test_script("macro_expand");
invoke_test_script("automata");
return result;
}