More work on drawing example.

examples/sysir/drawing.janet

@@ -5,11 +5,12 @@
 (use ./frontend)
 
 (defpointer p32 uint)
+(defpointer p16 u16)
 (defpointer cursor p32)
 (defn-external write:void [fd:int mem:pointer size:uint])
 (defn-external exit:void [x:int])
-(defn-external malloc:pointer [x:uint])
+(defn-external malloc:p32 [x:uint])
-(defn-external free:void [m:pointer])
+(defn-external free:void [m:p32])
 
 # assume 128x128 32 bit color image
 #   Size : 128 * 128 * 4 + align(14 + 40, 4) = 65592
@@ -31,6 +32,13 @@
   (store c (the p32 (pointer-add p 1)))
   (return))
 
+(defsys w16:void [c:cursor x:uint]
+  (def p:p16 (cast (the p32 (load c))))
+  (store p (the u16 (cast x)))
+  # Why so much inference...
+  (store c (the p32 (cast (the p16 (pointer-add p 1)))))
+  (return))
+
 (defsys write_header:void [w:uint h:uint]
   (write 1 "BM" 2)
   (def size:uint (+ 56 (* w h 4)))
@@ -52,12 +60,45 @@
   (write_16 0) # add "gap 1" to align pixel array to multiple of 4 bytes
   (return))
 
+(defsys makebmp:p32 [w:uint h:uint]
+  (def size:uint (+ 56 (* w h 4)))
+  (def mem:p32 (malloc size))
+  (def c:cursor (address mem))
+  (w16 c 0x424D) # ascii "BM"
+  (w32 c size)
+  (w32 c 56)
+  (w32 c 40)
+  (w32 c w)
+  (w32 c h)
+  (w32 c 0x20001)
+  (w32 c 0)
+  (w32 c 0)
+  (w32 c 4096)
+  (w32 c 4096)
+  (w32 c 0)
+  (w32 c 0)
+  (w16 c 0) # padding
+  # Draw
+  (def red:uint 0xFFFF0000)
+  (def blue:uint 0xFF0000FF)
+  (def size:uint (* w h 4))
+  (var y:uint 0)
+  (while (< y h)
+    (var x:uint 0)
+    (while (< x w)
+      #(write_32 (if (< y 32) blue red))
+      (if (> y 64)
+        (w32 c blue)
+        (w32 c red))
+      (set x (+ 1 x)))
+    (set y (+ y 1)))
+  (write 1 mem size)
+  (return mem))
+
 (defsys draw:void [w:uint h:uint]
   (def red:uint 0xFFFF0000)
   (def blue:uint 0xFF0000FF)
   (def size:uint (* w h 4))
-  (def mem:pointer (malloc size))
-  (store mem (the uint 10))
   (var y:uint 0)
   (while (< y h)
     (var x:uint 0)
@@ -75,6 +116,7 @@
   (def h:uint 128)
   (write_header w h)
   (draw w h)
+  #(makebmp w h)
   (return 0))
 
 ####

examples/sysir/frontend.janet

@@ -166,6 +166,18 @@
                 (array/push into ~(bind ,result ,xtype))
                 result)))
 
+          # Casting
+          'cast
+          (do
+            (assert (= 1 (length args)))
+            (assert type-hint) # should we add an explicit cast type?
+            (def [x] args)
+            (def slot (get-slot))
+            (def result (visit1 x into false))
+            (array/push into ~(bind ,slot ,type-hint))
+            (array/push into ~(cast ,slot ,result))
+            slot)
+
           # Named bindings
           'def
           (do
@@ -202,19 +214,20 @@
             (def [name tp] (type-extract thing 'int))
             (def result (visit1 thing into false tp))
             (def slot (get-slot))
-            #(assign-type name 'pointer)
+            # 
-            (array/push into ~(bind ,slot pointer))
+            (array/push into ~(bind ,slot ,type-hint))
             (array/push into ~(address ,slot ,result))
             slot)
 
           'load
           (do
             (assert (= 1 (length args)))
+            (assert type-hint)
             (def [thing] args)
             # (def [name tp] (type-extract thing 'pointer))
             (def result (visit1 thing into false))
             (def slot (get-slot))
-            (def ptype (or type-hint 'char))
+            (def ptype type-hint)
             (array/push into ~(bind ,slot ,ptype))
             (array/push into ~(load ,slot ,result))
             slot)

src/core/sysir.c

@@ -897,9 +897,8 @@ static void rcheck_pointer_equals(JanetSysIR *sysir, uint32_t preg, uint32_t elr
         janet_panicf("type failure in %p, expected pointer, got %p", sysir->error_ctx, tname(sysir, t1));
     }
     uint32_t tp = linkage->type_defs[t1].pointer.type;
-    JanetPrim tpprim = linkage->type_defs[tp].prim;
     uint32_t t2 = janet_sys_optype(sysir, elreg);
-    if (t2 != tp && tpprim != JANET_PRIM_VOID) { /* void pointer is compatible with everything TODO - can we get rid of this? */
+    if (t2 != tp) {
         janet_panicf("type failure in %p, %p is not compatible with a pointer to %p (%p)",
                      sysir->error_ctx,
                      tname(sysir, t2),
@@ -950,6 +949,9 @@ static int tcheck_cast(JanetSysIR *sysir, uint32_t td, uint32_t ts) {
         }
         return 0;
         */
+        if (primd == JANET_PRIM_POINTER) {
+            return 0;
+        }
         return -1; /* TODO */
     }
     /* Check that both src and dest are primitive numerics */