From b3023f259abc25fe9276d0575ea85fded02afa03 Mon Sep 17 00:00:00 2001 From: FelixBrendel Date: Sat, 5 Oct 2019 22:07:32 +0200 Subject: [PATCH] pair hashing, work on generic-extend, Memory::reset works again --- bin/oo.slime | 2 +- bin/pre.slime | 90 ++++++++++++++++++++++++++++++++++-------- bin/pre.slime.expanded | 14 +++---- build.sh | 0 src/built_ins.cpp | 40 ++++++++++++++----- src/env.cpp | 8 ++-- src/eval.cpp | 3 +- src/forward_decls.cpp | 10 ++++- src/memory.cpp | 18 ++++++--- src/testing.cpp | 22 +++++------ 10 files changed, 150 insertions(+), 57 deletions(-) mode change 100755 => 100644 build.sh diff --git a/bin/oo.slime b/bin/oo.slime index b66ce54..c35b866 100644 --- a/bin/oo.slime +++ b/bin/oo.slime @@ -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)))) diff --git a/bin/pre.slime b/bin/pre.slime index 1d64633..20f9267 100644 --- a/bin/pre.slime +++ b/bin/pre.slime @@ -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,17 +172,37 @@ 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--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) @@ -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 (continuation? x) + :doc "Checks if the argument is a continuation." + (type=? x :continuation)) -(define (callable? x) +(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"))))) diff --git a/bin/pre.slime.expanded b/bin/pre.slime.expanded index 5697e3f..67a5f2d 100644 --- a/bin/pre.slime.expanded +++ b/bin/pre.slime.expanded @@ -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)) - diff --git a/build.sh b/build.sh old mode 100755 new mode 100644 diff --git a/src/built_ins.cpp b/src/built_ins.cpp index d1655a8..71f00f0 100644 --- a/src/built_ins.cpp +++ b/src/built_ins.cpp @@ -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,10 +1077,14 @@ proc load_built_ins_into_environment() -> void { Lisp_Object* result; in_caller_env { - result = eval_expr(try_part); - if (Globals::error) { - delete_error(); - try result = eval_expr(catch_part); + ignore_logging { + dont_break_on_errors { + result = eval_expr(try_part); + if (Globals::error) { + delete_error(); + try result = eval_expr(catch_part); + } + } } } return result; diff --git a/src/env.cpp b/src/env.cpp index adc28c8..812d6ad 100644 --- a/src/env.cpp +++ b/src/env.cpp @@ -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); } diff --git a/src/eval.cpp b/src/eval.cpp index 17c6ff3..a712bd4 100644 --- a/src/eval.cpp +++ b/src/eval.cpp @@ -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(); diff --git a/src/forward_decls.cpp b/src/forward_decls.cpp index be6e941..f211a1d 100644 --- a/src/forward_decls.cpp +++ b/src/forward_decls.cpp @@ -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; } diff --git a/src/memory.cpp b/src/memory.cpp index da04cda..442ca30 100644 --- a/src/memory.cpp +++ b/src/memory.cpp @@ -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(); diff --git a/src/testing.cpp b/src/testing.cpp index 19dc0be..31ca7e6 100644 --- a/src/testing.cpp +++ b/src/testing.cpp @@ -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);