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

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