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

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))))

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)
+;; (define-syntax (apply fun seq)
-  :doc "Applies the function to the sequence, as in calls the function with
+;;   :doc "Applies the function to the sequence, as in calls the function with
-ithe sequence as arguemens."
+;; ithe sequence as arguemens."
-  `(eval (pair ,fun ,seq)))
+;;   `(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)
+    ;; we have the fun-name, the param names and the types, lets go:
-    (print names)
+    ;;
-    (print types)
+    ;; 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)
@@ -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)
+;; (generic-extend (+ v1 :vector v2 :vector)
-   (body))
+;;    (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

@@ -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))
-

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);
+            ignore_logging {
-            if (Globals::error) {
+                dont_break_on_errors {
-                delete_error();
+                    result = eval_expr(try_part);
-                try result = eval_expr(catch_part);
+                    if (Globals::error) {
+                        delete_error();
+                        try result = eval_expr(catch_part);
+                    }
+                }
             }
         }
         return result;

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);
 }

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();

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;
     }

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();

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();
+    Memory::reset();
-    // Environment* user_env = Memory::create_child_environment(root_env);
+    assert_no_error();
-    // assert_no_error();
 
-    // push_environment(user_env);
+    Environment* root_env = get_root_environment();
-    // defer {
+    Environment* user_env = Memory::create_child_environment(root_env);
-        // pop_environment();
+    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);