define-typed working;; parsing keywords in lambdalists correctly next

bin/alist.slime

@@ -113,9 +113,10 @@
 
 
 (define (alist-set! alist key value)
-  (mutate alist (pair (pair (pair key value)
-                       (car alist))
-                      ())))
+  (mutate alist (set-type (pair (pair (pair key value)
+                                      (car alist))
+                                ())
+                          :alist)))
 
 
 (define (alist-set-overwrite! alist key value)
@@ -141,7 +142,8 @@
     (plist-get-intern props prop)))
 
 (define (plist-set! plist prop value)
-  (mutate plist (pair (pair prop (pair value (first plist))) ())))
+  (mutate plist (set-type (pair (pair prop (pair value (first plist))) ())
+                          :plist)))
 
 (define (plist-set-overwrite! plist prop value)
   (let ((props (first plist)))

bin/pre.slime

@@ -141,9 +141,6 @@ ithe sequence as arguemens."
        (assert-types= @lambda-list)
        @body)))
 
-(define-typed (ttt a :number b :alist)
-  (printf a b))
-
 (define-syntax (define-package name :rest body)
   `(define ,(string->symbol (concat-strings (symbol->string name) "->"))
      ((lambda ()
@@ -157,7 +154,6 @@ ithe sequence as arguemens."
                           (eval op))))
           :package)))))
 
-
 (define (null? x)
   "Checks if the argument is =nil=."
   (= x ()))
@@ -167,19 +163,25 @@ ithe sequence as arguemens."
   (= (type obj) typ))
 
 (define (types=? :rest objs)
-  ;; TODO make inner rec functoin to avoid evalutating every time
-  (if objs
-      (begin
-       (assert (keyword? (first (rest objs))))
-       (if (type=? (first objs) (first (rest objs)))
-           (apply types=? (rest (rest objs)))
-         ()))
+  (define (inner objs)
+    (if objs
+        (let ((actual-type  (type (first objs)))
+              (desired-type (first (rest objs))))
+          (if (= actual-type desired-type)
+              (inner (rest (rest objs)))
+            ()))
       t))
+  (inner objs))
 
 (define (assert-types= :rest objs)
-  (break)
-  (unless (apply types=? objs)
-    (error "assert-types=: types do not match")))
+  (define (inner objs)
+    (when objs
+        (let ((actual-type  (type (first objs)))
+              (desired-type (first (rest objs))))
+          (if (= actual-type desired-type)
+              (inner (rest (rest objs)))
+            (error "type missmatch" actual-type desired-type)))))
+  (inner objs))
 
 (define (number? x)
   "Checks if the argument is a number."

bin/pre.slime.expanded

@@ -1,12 +1,10 @@
-(define-typed (ttt a :number b :alist) (printf a b))
-
 (define (null? x) "Checks if the argument is =nil=." (= x ()))
 
 (define (type=? obj typ) "Checks if the argument =obj= is of type =typ=" (= (type obj) typ))
 
-(define (types=? :rest objs) (if objs (begin (assert (keyword? (first (rest objs)))) (if (type=? (first objs) (first (rest objs))) (apply types=? (rest (rest objs))) ())) t))
+(define (types=? :rest objs) (define (inner objs) (if objs (let ((actual-type (type (first objs))) (desired-type (first (rest objs)))) (if (= actual-type desired-type) (inner (rest (rest objs))) ())) t)) (inner objs))
 
-(define (assert-types= :rest objs) (break) (unless (apply types=? objs) (error "assert-types=: types do not match")))
+(define (assert-types= :rest objs) (define (inner objs) (when objs (let ((actual-type (type (first objs))) (desired-type (first (rest objs)))) (if (= actual-type desired-type) (inner (rest (rest objs))) (error "type missmatch" actual-type desired-type))))) (inner objs))
 
 (define (number? x) "Checks if the argument is a number." (type=? x :number))
 

bin/test.slime

@@ -0,0 +1,16 @@
+(import "alist.slime")
+
+(define-typed (tf n :number a :alist)
+  (printf n)
+  (pprint-alist a))
+
+
+(define a (make-alist))
+(alist-set! a 'a 1)
+(alist-set! a 'b 2)
+(tf 1 a)
+
+(define (test a b)
+  (printf a b))
+
+(test :ij :yes)