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

.gitignore

@@ -17,3 +17,4 @@ todo.html
 /manual/manual.pdf
 /manual/manual.tex
 *.out
+/bin/slime

bin/alist.slime

@@ -113,9 +113,10 @@
 
 
 (define (alist-set! alist key value)
-  (mutate alist (pair (pair (pair key value)
+  (mutate alist (set-type (pair (pair (pair key value)
-                       (car alist))
+                                      (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
+  (define (inner objs)
-  (if objs
+    (if objs
-      (begin
+        (let ((actual-type  (type (first objs)))
-       (assert (keyword? (first (rest objs))))
+              (desired-type (first (rest objs))))
-       (if (type=? (first objs) (first (rest objs)))
+          (if (= actual-type desired-type)
-           (apply types=? (rest (rest objs)))
+              (inner (rest (rest objs)))
-         ()))
+            ()))
       t))
+  (inner objs))
 
 (define (assert-types= :rest objs)
-  (break)
+  (define (inner objs)
-  (unless (apply types=? objs)
+    (when objs
-    (error "assert-types=: types do not match")))
+        (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)

build.sh

@@ -3,7 +3,7 @@ SCRIPTPATH="$( cd "$(dirname "$0")" ; pwd -P )"
 pushd $SCRIPTPATH > /dev/null
 
 #  _DEBUG
-time clang++ src/main.cpp -g -o ./bin/slime --std=c++17 || exit 1
+time g++ -fpermissive src/main.cpp -g -o ./bin/slime --std=c++17 || exit 1
 
 echo ""
 pushd ./bin > /dev/null

manual/built-in-docs.org

@@ -591,20 +591,13 @@ ithe sequence as arguemens.
 \hrule
 * =define-package= 
 
- - defined in ::  =pre.slime:158:24=
+ - defined in ::  =pre.slime:155:24=
  - type :: =:macro=
  - arguments :: :
     - postitional :: =name=:
     - rest :: =body=
  - docu :: none
 \hrule
-* =ttt= 
-
- - type :: =:lambda=
- - arguments :: :
-    - postitional :: =a=, =b=
- - docu :: none
-\hrule
 * =null?= 
 
  - type :: =:lambda=

src/visualization.cpp

@@ -199,7 +199,7 @@ proc visualize_lisp_machine() -> void {
         case Lisp_Object_Type::Function:  return draw_text("Function", "#aa1100");
         case Lisp_Object_Type::CFunction: return draw_text("CFunction", "#11aa00");
         default:
-            fprintf(stderr, "Do not know hot to visualize type %d\n", Memory::get_type(obj));
+        fprintf(stderr, "Do not know hot to visualize type %d\n", (int)Memory::get_type(obj));
             return {0};
         }
     };