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