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

fixed let not coying the initial value nodes

Browse Source
This commit is contained in:
FelixBrendel
2019-03-15 01:14:45 +01:00
parent 6734ee2258
commit 31a833b5c9
10 changed files with 237 additions and 34 deletions
Download Patch File Download Diff File Expand all files Collapse all files
.dir-locals.el
+1 -1
View File
@@ -34,7 +34,7 @@
(define-key context-mode-map (kbd "<f2>") 'hydra-context/body)
(font-lock-add-keywords 'c++-mode
'(("\\<\\(if_debug\\|if_windows\\|if_linux\\)\\>" .
'(("\\<\\(if_debug\\|if_windows\\|if_linux\\|defer\\|proc\\)\\>" .
font-lock-keyword-face)))))))
(c++-mode . ((eval . (company-clang-set-prefix "main.cpp"))
(eval . (flycheck-mode 0))
.gitignore
+1
View File
@@ -7,3 +7,4 @@
*.psess
*.vspx
todo.html
*.expanded
bin/tests/class_macro.slime
+111
View File
@@ -0,0 +1,111 @@
(define (type-wrap obj type)
(set-type obj type)
obj)
(define-syntax defclass (name members :rest body)
"Macro for creatating classes."
(define (underscore sym)
(string->symbol (concat-strings "_" (symbol->string sym))))
(define underscored-members (map underscore members))
;; the wrapping let environment
(define let-body (list 'let (zip members underscored-members)))
;; the body
(map (lambda (fun) (append let-body fun)) body)
;; the dispatch function
(append let-body '(special-lambda
(message :rest args)
"This is the docs for the handle"
(eval (extend (list message) args))))
;; stuff it all in the constructor function
(list 'define
(pair (string->symbol (concat-strings "make-" (symbol->string name))) underscored-members)
"This is the handle to an object of the class "
let-body))
(define (make-vector3 _x _y _z)
"This is the handle to an object of the class "
(let ((x _x)
(y _y)
(z _z))
(define (get-x) x)
(define (get-y) y)
(define (get-z) z)
(define (set-x new-x) (mutate x new-x))
(define (set-y new-y) (mutate y new-y))
(define (set-z new-z) (mutate z new-z))
(define (length) (** (+ (* x x) (* y y) (* z z)) 0.500000))
(define (scale fac) (mutate x (* fac x)) (mutate y (* fac y)) (mutate z (* fac z)) fac)
(define (add other) (make-vector3 (+ x (other get-x)) (+ y (other get-y)) (+ z (other get-z))))
(define (subtract other) (make-vector3 (- x (other get-x)) (- y (other get-y)) (- z (other get-z))))
(define (scalar-product other) (+ (* x (other get-x)) (* y (other get-y)) (* z (other get-z))))
(define (cross-product other) (make-vector3 (- (* y (other get-z)) (* z (other get-y))) (- (* z (other get-x)) (* x (other get-z))) (- (* x (other get-y)) (* y (other get-x)))))
(define (printout) (printf "[vector3] (" x y z ")"))
(special-lambda
(message :rest args)
"This is the docs for the handle"
(eval (extend (list message) args)))))
;; (v1 print)
;; (v1 length)
;; (v1 get-x)
;; (v1 set-x 10)
(defclass vector3 (x y z)
(define (get-x) x)
(define (get-y) y)
(define (get-z) z)
(define (set-x new-x) (mutate x new-x))
(define (set-y new-y) (mutate y new-y))
(define (set-z new-z) (mutate z new-z))
(define (length)
(** (+ (* x x) (* y y) (* z z)) 0.5))
(define (scale fac)
(mutate x (* fac x))
(mutate y (* fac y))
(mutate z (* fac z))
fac)
(define (add other)
(make-vector3
(+ x (other get-x))
(+ y (other get-y))
(+ z (other get-z))))
(define (subtract other)
(make-vector3
(- x (other get-x))
(- y (other get-y))
(- z (other get-z))))
(define (scalar-product other)
(+ (* x (other get-x))
(* y (other get-y))
(* z (other get-z))))
(define (cross-product other)
(make-vector3
(- (* y (other get-z)) (* z (other get-y)))
(- (* z (other get-x)) (* x (other get-z)))
(- (* x (other get-y)) (* y (other get-x)))))
(define (printout)
(printf "[vector3] (" x y z ")"))
)
(define v1 (make-vector3 1 2 3))
(define v2 (make-vector3 3 2 1))
(assert (= (v1 scalar-product v2) 10))
bin/tests/class_macro.slime.expanded
+12
View File
@@ -0,0 +1,12 @@
(define (type-wrap obj type) (set-type obj type) obj)
(define (make-vector3 _x _y _z) "This is the handle to an object of the class " (let ((x _x) (y _y) (z _z)) (define (get-x) x) (define (get-y) y) (define (get-z) z) (define (set-x new-x) (mutate x new-x)) (define (set-y new-y) (mutate y new-y)) (define (set-z new-z) (mutate z new-z)) (define (length) (** (+ (* x x) (* y y) (* z z)) 0.500000)) (define (scale fac) (mutate x (* fac x)) (mutate y (* fac y)) (mutate z (* fac z)) fac) (define (add other) (make-vector3 (+ x (other get-x)) (+ y (other get-y)) (+ z (other get-z)))) (define (subtract other) (make-vector3 (- x (other get-x)) (- y (other get-y)) (- z (other get-z)))) (define (scalar-product other) (+ (* x (other get-x)) (* y (other get-y)) (* z (other get-z)))) (define (cross-product other) (make-vector3 (- (* y (other get-z)) (* z (other get-y))) (- (* z (other get-x)) (* x (other get-z))) (- (* x (other get-y)) (* y (other get-x))))) (define (printout) (printf "[vector3] (" x y z ")")) (special-lambda (message :rest args) "This is the docs for the handle" (eval (extend (list message) args)))))
(define (make-vector3 _x _y _z) "This is the handle to an object of the class " (let ((x _x) (y _y) (z _z)) (define (get-x) x) (define (get-y) y) (define (get-z) z) (define (set-x new-x) (mutate x new-x)) (define (set-y new-y) (mutate y new-y)) (define (set-z new-z) (mutate z new-z)) (define (length) (** (+ (* x x) (* y y) (* z z)) 0.500000)) (define (scale fac) (mutate x (* fac x)) (mutate y (* fac y)) (mutate z (* fac z)) fac) (define (add other) (make-vector3 (+ x (other get-x)) (+ y (other get-y)) (+ z (other get-z)))) (define (subtract other) (make-vector3 (- x (other get-x)) (- y (other get-y)) (- z (other get-z)))) (define (scalar-product other) (+ (* x (other get-x)) (* y (other get-y)) (* z (other get-z)))) (define (cross-product other) (make-vector3 (- (* y (other get-z)) (* z (other get-y))) (- (* z (other get-x)) (* x (other get-z))) (- (* x (other get-y)) (* y (other get-x))))) (define (printout) (printf "[vector3] (" x y z ")")) (special-lambda (message :rest args) "This is the docs for the handle" (eval (extend (list message) args)))))
(define v1 (make-vector3 1.000000 2.000000 3.000000))
(define v2 (make-vector3 3.000000 2.000000 1.000000))
(assert (= (v1 scalar-product v2) 10.000000))
bin/tests/lexical_scope.slime
+16
View File
@@ -0,0 +1,16 @@
(define (make-counter)
(let ((var 0))
(lambda ()
(mutate var (+ 1 var))
var)))
(define counter1 (make-counter))
(assert (= (counter1) 1))
(define counter2 (make-counter))
(assert (= (counter2) 1))
(assert (= (counter2) 2))
(assert (= (counter1) 2))
(assert (= (counter1) 3))
(assert (= (counter2) 3))
bin/tests/lexical_scope.slime.expanded
+18
View File
@@ -0,0 +1,18 @@
(define (make-counter) (let ((var 0.000000)) (lambda nil (mutate var (+ 1.000000 var)) var)))
(define counter1 (make-counter))
(assert (= (counter1) 1.000000))
(define counter2 (make-counter))
(assert (= (counter2) 1.000000))
(assert (= (counter2) 2.000000))
(assert (= (counter1) 2.000000))
(assert (= (counter1) 3.000000))
(assert (= (counter2) 3.000000))
src/built_ins.cpp
+10 -5
View File
@@ -65,10 +65,12 @@ proc load_built_ins_into_environment(Environment* env) -> void {
Lisp_Object* evaluated_arguments;
#define cLambda [=](Lisp_Object* arguments, Environment* env) mutable -> Lisp_Object*
#define report_error(_type) { \
printf("Error occurred\nin %s:%d\n", __FILE__, __LINE__); \
create_error(_type, current_source_code_location); \
return nullptr; \
#define report_error(_type) { \
if (log_level == Log_Level::Debug) { \
printf("Error occurred\nin %s:%d\n", __FILE__, __LINE__); \
} \
create_error(_type, current_source_code_location); \
return nullptr; \
}
proc defun = [&](const char* name, auto fun) {
@@ -682,7 +684,10 @@ proc load_built_ins_into_environment(Environment* env) -> void {
Lisp_Object* value = eval_expr(rest_sym->value.pair->first, env);
define_symbol(sym, value, let_env);
// NOTE(Felix): We have to copy the value here because
// if the let body modifies the value, it would bake
// in... bad bad...
define_symbol(sym, Memory::copy_lisp_object(value), let_env);
bindings = bindings->value.pair->rest;
}
src/defines.cpp
+62 -25
View File
@@ -23,39 +23,45 @@ constexpr bool is_debug_build = false;
#define assert(cond) \
if_debug { \
if (!cond) { \
printf("Assertion failed: %s %d", __FILE__, __LINE__); \
if (log_level == Log_Level::Debug) { \
printf("Assertion failed: %s %d", __FILE__, __LINE__); \
} \
debug_break(); \
} \
} else {} \
#define concat_( a, b) a##b
#define label(prefix, lnum) concat_(prefix,lnum)
#define try \
if (1) \
goto label(body,__LINE__); \
else \
while (1) \
if (1) { \
if(error) { \
printf("in %s:%d\n", __FILE__, __LINE__); \
return 0; \
} \
break; \
} \
#define try \
if (1) \
goto label(body,__LINE__); \
else \
while (1) \
if (1) { \
if(error) { \
if (log_level == Log_Level::Debug) { \
printf("in %s:%d\n", __FILE__, __LINE__); \
} \
return 0; \
} \
break; \
} \
else label(body,__LINE__):
#define try_void \
if (1) \
goto label(body,__LINE__); \
else \
while (1) \
if (1) { \
if(error) { \
printf("in %s:%d\n", __FILE__, __LINE__); \
return; \
} \
break; \
} \
#define try_void \
if (1) \
goto label(body,__LINE__); \
else \
while (1) \
if (1) { \
if(error) { \
if (log_level == Log_Level::Debug) { \
printf("in %s:%d\n", __FILE__, __LINE__); \
} \
return; \
} \
break; \
} \
else label(body,__LINE__):
@@ -85,6 +91,37 @@ constexpr bool is_debug_build = false;
return ret; \
}
template<typename F>
class defer_finalizer {
F f;
bool moved;
public:
template<typename T>
defer_finalizer(T && f_) : f(std::forward<T>(f_)), moved(false) { }
defer_finalizer(const defer_finalizer &) = delete;
defer_finalizer(defer_finalizer && other) : f(std::move(other.f)), moved(other.moved) {
other.moved = true;
}
~defer_finalizer() {
if (!moved) f();
}
};
struct {
template<typename F>
defer_finalizer<F> operator<<(F && f) {
return defer_finalizer<F>(std::forward<F>(f));
}
} deferrer;
#define TOKENPASTE(x, y) x ## y
#define TOKENPASTE2(x, y) TOKENPASTE(x, y)
#define defer auto TOKENPASTE2(__deferred_lambda_call, __COUNTER__) = deferrer << [&]
#define console_normal "\x1B[0m"
#define console_red "\x1B[31m"
#define console_green "\x1B[32m"
src/error.cpp
-2
View File
@@ -39,10 +39,8 @@ proc Error_Type_to_string(Error_Type type) -> const char* {
}
proc assert_type(Lisp_Object* node, Lisp_Object_Type type) -> void {
if_debug {
if (!node)
create_error(Error_Type::Unknown_Error, nullptr);
if (node->type == type) return;
create_error(Error_Type::Type_Missmatch, node->sourceCodeLocation);
}
}
src/testing.cpp
+6 -1
View File
@@ -486,7 +486,12 @@ proc test_lexical_scope() -> testresult {
}
proc run_all_tests() -> bool {
// log_level = Log_Level::None;
Log_Level log_level_before = log_level;
log_level = Log_Level::None;
defer {
log_level = log_level_before;
};
Memory::init();
Parser::init(Memory::create_built_ins_environment());