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
+74 -16
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,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-<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)
(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))