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

pair hashing, work on generic-extend, Memory::reset works again

Browse Source
This commit is contained in:
FelixBrendel
2019-10-05 22:07:32 +02:00
parent 9cba9cafc0
commit b3023f259a
10 changed files with 150 additions and 57 deletions
Download Patch File Download Diff File Expand all files Collapse all files
bin/oo.slime
+1 -1
View File
@@ -15,7 +15,7 @@
(lambda args
"This is the docs for the handle"
(let ((op (eval (first args))))
(if (callable? op)
(if (procedure? op)
(eval args)
(eval (first args)))))
,(symbol->keyword name))))
bin/pre.slime
+73 -15
View File
@@ -1,6 +1,9 @@
(define hm/set! hash-map-set!)
(define hm/get hash-map-get)
(define (hm/get-or-nil hm key)
(mytry (hm/get hm key) ()))
(define-syntax (pe expr)
`(print ',expr "evaluates to" ,expr))
@@ -126,10 +129,10 @@ condition is false."
(rec body))
(define-syntax (apply fun seq)
:doc "Applies the function to the sequence, as in calls the function with
ithe sequence as arguemens."
`(eval (pair ,fun ,seq)))
;; (define-syntax (apply fun seq)
;; :doc "Applies the function to the sequence, as in calls the function with
;; ithe sequence as arguemens."
;; `(eval (pair ,fun ,seq)))
(define-syntax (define-typed args . body)
(define (get-arg-names args)
@@ -169,19 +172,39 @@ ithe sequence as arguemens."
(_type (first (rest params))))
(assert (symbol? _name))
(assert (keyword? _type))
;; (print (append types _type))
(break)
(set! types (append types _type))
;; (print types)
(set! names (append names _name))
(process-params (rest (rest params))))))
(process-params params)
(print fun-name)
(print names)
(print types)
;; we have the fun-name, the param names and the types, lets go:
;;
;; first check if there is already a generic-<name>-map
(let ((generic-map-name (string->symbol
(concat-strings "generic-" (symbol->string fun-name) "-map"))))
(unless (bound? generic-map-name)
(define generic-map-name (create-hash-map)))
(hm/set! generic-map-name types (eval `(,lambda ,names @body)))
;; now check if the generic procedure already exists
(if (bound? fun-name)
(let ((exisiting-fun (eval fun-name)))
(unless (type=? exisiting-fun :generic-procedure)
(unless (procedure? exisiting-fun)
(error :macro-expand-error "can only generic-extend procedures."))
(define orig-proc exisiting-fun)
(define fun-name (eval
`(,lambda args (let ((fun (hm/get (map type args))))
(if (procedure? fun)
(fun . args)
(,orig-proc . args))))
))
)
)
)
))
)
(define (null? x)
:doc "Checks if the argument is =nil=."
(= x ()))
@@ -245,13 +268,18 @@ ithe sequence as arguemens."
(define (built-in-function? x)
:doc "Checks if the argument is a built-in function."
(type=? x :built-in-function))
(type=? x :cfunction))
(define (callable? x)
(define (continuation? x)
:doc "Checks if the argument is a continuation."
(type=? x :continuation))
(define (procedure? x)
(or (lambda? x)
(special-lambda? x)
(macro? x)
(built-in-function? x)))
(built-in-function? x)
(continuation? x)))
(define (end seq)
:doc "Returns the last pair in the sqeuence.
@@ -436,5 +464,35 @@ added to a list, which in the end is returned."
(generic-extend (+ v1 :vector v2 :vector)
(body))
;; (generic-extend (+ v1 :vector v2 :vector)
;; (assert (= (vector-length v1)
;; (vector-length v2)))
;; (vector (+ (vector-ref v1 0)
;; (vector-ref v2 0))))
;; (unless (bound? generic-+-map)
;; (set! generic-+-map (create-hash-map)))
;; (hm/set! generic-+-map '(:vector :vector) (lambda (v1 v2)
;; (assert (= (vector-length v1)
;; (vector-length v2)))
;; (vector (+ (vector-ref v1 0)
;; (vector-ref v2 0)))))
;; (hm/set! generic-+-map '(:string :string) (lambda (v1 v2) (concat-strings v1 v2)))
;; (let ((define-it
;; (lambda (backup)
;; (set! + (set-type!
;; (lambda args (let ((fun (hm/get-or-nil generic-+-map (map type args))))
;; (if fun (apply fun args)
;; (backup args))))
;; :generic-procedure)))))
;; (if (bound? +)
;; (let ((exisiting-fun +))
;; (unless (type=? exisiting-fun :generic-procedure)
;; (unless (procedure? exisiting-fun)
;; (error :macro-expand-error "can only generic-extend procedures."))
;; (define orig-proc exisiting-fun)
;; (define-it (lambda (args) (apply orig-proc args)))))
;; (define-it (lambda (args) (error :generic-lookup "no overloads found")))))
bin/pre.slime.expanded
+7 -7
View File
@@ -2,6 +2,8 @@
(define hm/get hash-map-get)
(define (hm/get-or-nil hm key) (mytry (hm/get hm key) ()))
(define-syntax (pe expr) `(print ',expr "evaluates to" ,expr))
(define-syntax (when condition . body) :doc "Special form for when multiple actions should be done if a\ncondition is true.\n\n{{{example_start}}}\n(when (not ())\n (print "Hello ")\n (print "from ")\n (print "when!"))\n\n(when ()\n (print "Goodbye ")\n (print "World!"))\n{{{example_end}}}\n" (if (= (rest body) ()) `(if ,condition (unquote-splicing body) nil) `(if ,condition (begin (unquote-splicing body)) nil)))
@@ -20,13 +22,11 @@
(define-syntax (construct-list . body) :doc "\n{{{example_start}}}\n(construct-list\n i <- '(1 2 3 4 5)\n yield (* i i))\n{{{example_end}}}\n\n(construct-list\n i <- '(1 2 3 4)\n j <- '(A B)\n yield (pair i j))\n\n(construct-list\n i <- '(1 2 3 4 5 6 7 8)\n if (= 0 (% i 2))\n yield i)\n" (define (append-map f ll) (unless (= ll ()) (define val (f (first ll))) (if (= (first val) ()) (append-map f (rest ll)) (extend val (append-map f (rest ll)))))) (define (rec body) (cond ((= () body) ()) ((= () (rest body)) (first body)) ((= (first (rest body)) '<-) `(,append-map (lambda (,(first body)) (list ,(rec (rest (rest (rest body)))))) ,(first (rest (rest body))))) ((= (first body) 'if) `(when ,(first (rest body)) ,(rec (rest (rest body))))) ((= (first (rest body)) 'yield) (first (rest body))) (else (error :syntax-error "Not a do-able expression")))) (rec body))
(define-syntax (apply fun seq) :doc "Applies the function to the sequence, as in calls the function with\nithe sequence as arguemens." `(eval (pair ,fun ,seq)))
(define-syntax (define-typed args . body) (define (get-arg-names args) (when args (pair (first args) (get-arg-names (rest (rest args)))))) (let ((name (first args)) (lambda-list (rest args)) (arg-names (get-arg-names (rest args)))) `(define (,name (unquote-splicing arg-names)) (assert-types= (unquote-splicing lambda-list)) (unquote-splicing body))))
(define-syntax (define-module module-name (:imports ()) :exports . body) (let ((module-prefix (concat-strings (symbol->string module-name) "::"))) (eval `(begin (unquote-splicing (map (lambda (x) `(,import ,x)) imports)) (unquote-splicing 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 ,(mytry (eval orig-export-name) (error :module-error "The module does not contain a key it tries to export"))))) exports))))
(define-syntax (generic-extend args . body) (let ((fun-name (first args)) (params (rest args)) (types ()) (names ())) (define (process-params params) (when params (let ((_name (first params)) (_type (first (rest params)))) (assert (symbol? _name)) (assert (keyword? _type)) (break) (set! types (append types _type)) (set! names (append names _name)) (process-params (rest (rest params)))))) (process-params params) (print fun-name) (print names) (print types)))
(define-syntax (generic-extend args . body) (let ((fun-name (first args)) (params (rest args)) (types ()) (names ())) (define (process-params params) (when params (let ((_name (first params)) (_type (first (rest params)))) (assert (symbol? _name)) (assert (keyword? _type)) (set! types (append types _type)) (set! names (append names _name)) (process-params (rest (rest params)))))) (process-params params) (let ((generic-map-name (string->symbol (concat-strings "generic-" (symbol->string fun-name) "-map")))) (unless (bound? generic-map-name) (define generic-map-name (create-hash-map))) (hm/set! generic-map-name types (eval `(,lambda ,names (unquote-splicing body)))) (if (bound? fun-name) (let ((exisiting-fun (eval fun-name))) (unless (type=? exisiting-fun :generic-procedure) (unless (procedure? exisiting-fun) (error :macro-expand-error "can only generic-extend procedures.")) (define orig-proc exisiting-fun) (define fun-name (eval `(,lambda args (let ((fun (hm/get (map type args)))) (if (procedure? fun) (fun . args) (,orig-proc . args))))))))))))
(define (null? x) :doc "Checks if the argument is =nil=." (= x ()))
@@ -52,9 +52,11 @@
(define (special-lambda? x) :doc "Checks if the argument is a special-lambda." (type=? x :dynamic-macro))
(define (built-in-function? x) :doc "Checks if the argument is a built-in function." (type=? x :built-in-function))
(define (built-in-function? x) :doc "Checks if the argument is a built-in function." (type=? x :cfunction))
(define (callable? x) (or (lambda? x) (special-lambda? x) (macro? x) (built-in-function? x)))
(define (continuation? x) :doc "Checks if the argument is a continuation." (type=? x :continuation))
(define (procedure? x) (or (lambda? x) (special-lambda? x) (macro? x) (built-in-function? x) (continuation? x)))
(define (end seq) :doc "Returns the last pair in the sqeuence.\n\n{{{example_start}}}\n(define a (list 1 2 3 4))\n(print (end a))\n{{{example_end}}}\n" (if (or (null? seq) (not (pair? (rest seq)))) seq (end (rest seq))))
@@ -96,5 +98,3 @@
(define (enumerate seq) (define (enumerate-inner seq next-num) (when seq (pair (list (first seq) next-num) (enumerate-inner (rest seq) (+ 1 next-num))))) (enumerate-inner seq 0))
(generic-extend (+ v1 :vector v2 :vector) (body))
build.sh
Executable → Regular
View File
src/built_ins.cpp
+26 -6
View File
@@ -26,8 +26,11 @@ proc lisp_object_equal(Lisp_Object* n1, Lisp_Object* n2) -> bool {
case Lisp_Object_Type::Nil: return true;
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: {
return lisp_object_equal(n1->value.pair.first, n2->value.pair.first) &&
lisp_object_equal(n1->value.pair.rest, n2->value.pair.rest);
} break;
case Lisp_Object_Type::HashMap:
case Lisp_Object_Type::Pair:
case Lisp_Object_Type::Vector:
create_not_yet_implemented_error();
case Lisp_Object_Type::Symbol:
@@ -560,11 +563,6 @@ proc load_built_ins_into_environment() -> void {
push_environment(target_env);
{
printf("set!ing:: ");
print(sym);
printf(" to ");
print(val);
printf(" in %llu\n", (unsigned long long) target_env);
define_symbol(sym, val);
}
pop_environment();
@@ -607,6 +605,7 @@ proc load_built_ins_into_environment() -> void {
};
define_special((quasiquote expr), "TODO") {
fetch(expr);
Lisp_Object* quasiquote_sym = Memory::get_or_create_lisp_object_symbol("quasiquote");
Lisp_Object* unquote_sym = Memory::get_or_create_lisp_object_symbol("unquote");
Lisp_Object* unquote_splicing_sym = Memory::get_or_create_lisp_object_symbol("unquote-splicing");
/* recursive lambdas in lambdas yay!! */
@@ -621,6 +620,11 @@ proc load_built_ins_into_environment() -> void {
// it is a pair!
Lisp_Object* originalPair = expr->value.pair.first;
// if we find quasiquote, uhu
if (originalPair == quasiquote_sym)
return expr;
if (originalPair == unquote_sym || originalPair == unquote_splicing_sym)
{
// eval replace the stuff
@@ -791,6 +795,18 @@ proc load_built_ins_into_environment() -> void {
fun->value.function.body = maybe_wrap_body_in_begin(body);
return fun;
};
define((apply fun args), "TODO") {
fetch(fun, args);
Lisp_Object* result;
// try assert_type(args, Lisp_Object_Type::Pair);
// HACK(Felix): this is probably a really nasty hack:
fluid_let (fun->value.function.type, Function_Type::Special_Lambda) {
try result = apply_arguments_to_function(args, fun);
}
return result;
};
define((eval expr), "TODO") {
fetch(expr);
Lisp_Object* result;
@@ -1061,12 +1077,16 @@ proc load_built_ins_into_environment() -> void {
Lisp_Object* result;
in_caller_env {
ignore_logging {
dont_break_on_errors {
result = eval_expr(try_part);
if (Globals::error) {
delete_error();
try result = eval_expr(catch_part);
}
}
}
}
return result;
};
define((load file), "TODO") {
src/env.cpp
+4 -4
View File
@@ -16,7 +16,7 @@ proc find_binding_environment(Lisp_Object* sym, Environment* env) -> Environment
return env;
for_array_list (env->parents) {
if (Environment* ret = find_binding_environment(sym, it))
return it;
return ret;
}
return nullptr;
}
@@ -102,18 +102,18 @@ proc print_environment_indent(Environment* env, int indent) -> void {
print_indent(indent);
printf("-> %s :: ", &(((Lisp_Object*)key)->value.symbol.identifier->data));
print((Lisp_Object*)value);
printf(" (%lld)", (unsigned long long)value);
printf(" (0x%016llx)", (unsigned long long)value);
puts("");
}
for (int i = 0; i < env->parents.next_index; ++i) {
print_indent(indent);
printf("parent (%lld)", (long long)env->parents.data[i]);
printf("parent (0x%016llx)", (long long)env->parents.data[i]);
puts(":");
print_environment_indent(env->parents.data[i], indent+4);
}
}
proc print_environment(Environment* env) -> void {
printf("\n=== Environment === (%lld)\n", (long long)env);
printf("\n=== Environment === (0x%016llx)\n", (long long)env);
print_environment_indent(env, 0);
}
src/eval.cpp
+2 -1
View File
@@ -233,13 +233,14 @@ proc create_extended_environment_for_function_application(
proc apply_arguments_to_function(Lisp_Object* arguments, Lisp_Object* function) -> Lisp_Object* {
profile_this;
Environment* new_env;
Lisp_Object* result;
try new_env = create_extended_environment_for_function_application(arguments, function);
push_environment(new_env);
defer {
pop_environment();
};
Lisp_Object* result;
// if c function:
if (Memory::get_type(function) == Lisp_Object_Type::CFunction)
try result = function->value.cFunction->body();
src/forward_decls.cpp
+9 -1
View File
@@ -101,9 +101,17 @@ u32 hm_hash(Lisp_Object* obj) {
case Lisp_Object_Type::Pointer: return hm_hash((void*) obj->value.pointer);
case Lisp_Object_Type::Number: return hm_hash((void*) (unsigned long long)obj->value.number); // HACK(Felix): yes
case Lisp_Object_Type::String: return hm_hash((char*) &obj->value.string->data);
case Lisp_Object_Type::Pair: {
u32 hash = 1;
for_lisp_list (obj) {
hash <<= 1;
hash += hm_hash(it);
}
return hash;
} break;
case Lisp_Object_Type::Vector:
case Lisp_Object_Type::Pair:
case Lisp_Object_Type::HashMap:
default:
create_not_yet_implemented_error();
return 0;
}
src/memory.cpp
+12 -6
View File
@@ -18,7 +18,7 @@ namespace Memory {
// environments
// ------------------
int environment_memory_size;
Int_Array_List free_spots_in_environment_memory;
Environment_Array_List free_spots_in_environment_memory;
Environment* environment_memory;
int next_index_in_environment_memory = 0;
@@ -182,7 +182,7 @@ namespace Memory {
string_memory_size = sms;
free_spots_in_object_memory = create_Int_array_list();
free_spots_in_environment_memory = create_Int_array_list();
free_spots_in_environment_memory = create_Environment_array_list();
free_spots_in_string_memory = create_Void_Ptr_array_list();
object_memory = (Lisp_Object*)malloc(object_memory_size * sizeof(Lisp_Object));
@@ -203,6 +203,7 @@ namespace Memory {
Globals::Current_Execution::envi_stack.next_index = 0;
push_environment(create_built_ins_environment());
}
proc reset() -> void {
@@ -210,6 +211,11 @@ namespace Memory {
free_spots_in_environment_memory.next_index = 0;
free_spots_in_string_memory.next_index = 0;
global_symbol_table = create_String_hashmap();
global_keyword_table = create_String_hashmap();
try_void Parser::standard_in = create_string("stdin");
// because t and nil are always there we start the index at 2
next_index_in_object_memory = 2;
next_index_in_environment_memory = 0;
@@ -399,9 +405,10 @@ namespace Memory {
proc create_child_environment(Environment* parent) -> Environment* {
int index;
Environment* env;
// if we have no free spots then append at the end
if (free_spots_in_environment_memory.next_index == 0) {
int index;
// if we still have space
if (environment_memory_size == next_index_in_environment_memory) {
create_out_of_memory_error(
@@ -412,13 +419,12 @@ namespace Memory {
return nullptr;
}
index = next_index_in_environment_memory++;
env = environment_memory+index;
} else {
// else fill a free spot, and remove the free spot
index = free_spots_in_environment_memory.data[free_spots_in_environment_memory.next_index--];
env = free_spots_in_environment_memory.data[--free_spots_in_environment_memory.next_index];
}
Environment* env = environment_memory+index;
int start_capacity = 16;
env->parents = create_Environment_array_list();
src/testing.cpp
+11 -11
View File
@@ -212,7 +212,6 @@ proc test_eval_operands() -> testresult {
assert_equal_double(operands->value.pair.first->value.number, 3);
operands = operands->value.pair.rest;
assert_equal_type(operands, Lisp_Object_Type::Pair);
assert_equal_type(operands->value.pair.first, Lisp_Object_Type::String);
assert_equal_string(operands->value.pair.first->value.string, "okay");
@@ -585,17 +584,18 @@ proc test_singular_symbols() -> testresult {
}
proc test_file(const char* file) -> testresult {
// Memory::reset();
// assert_no_error();
// Environment* root_env = get_root_environment();
// Environment* user_env = Memory::create_child_environment(root_env);
// assert_no_error();
Memory::reset();
assert_no_error();
// push_environment(user_env);
// defer {
// pop_environment();
// };
Environment* root_env = get_root_environment();
Environment* user_env = Memory::create_child_environment(root_env);
assert_no_error();
push_environment(user_env);
defer {
pop_environment();
};
built_in_load(Memory::create_string(file));
assert_no_error();
@@ -607,7 +607,7 @@ proc run_all_tests() -> bool {
bool result = true;
Memory::init(200000, 10240, 409600);
Memory::init(200000, 102400, 409600);
Environment* root_env = get_root_environment();
Environment* user_env = Memory::create_child_environment(root_env);
push_environment(user_env);