unit tests, fixed some compiler bugs, move functions to lib.l and gfx.l

sledge/compiler_new.c

@@ -278,6 +278,13 @@ int analyze_fn(Cell* expr, Cell* parent, int num_lets) {
   return num_lets;
 }
 
+int compatible_type(int given, int required) {
+  if (given == required) return 1;
+  if ((given == TAG_STR || given == TAG_BYTES) &&
+      (required == TAG_STR || required == TAG_BYTES)) return 1;
+  return 0;
+}
+
 int compile_expr(Cell* expr, Frame* frame, int return_type) {
   int compiled_type = TAG_ANY;
   Arg* fn_frame = frame->f;
@@ -480,7 +487,7 @@ int compile_expr(Cell* expr, Frame* frame, int return_type) {
           return 0;
         }
       }
-      else if (given_tag == sig_tag || sig_tag==TAG_ANY) {
+      else if (compatible_type(given_tag, sig_tag) || sig_tag==TAG_ANY) {
         argdefs[argi].cell = arg;
         argdefs[argi].slot = argi-1;
         argdefs[argi].type = ARGT_CELL;
@@ -659,6 +666,22 @@ int compile_expr(Cell* expr, Frame* frame, int return_type) {
       }
       break;
     }
+    case BUILTIN_EQ: {
+      load_int(ARGR0, argdefs[0], frame);
+      load_int(R2, argdefs[1], frame);
+      jit_movi(R3,1);
+      jit_subr(ARGR0,R2);
+      jit_movi(R2,0);
+      jit_cmpi(ARGR0,0);
+      jit_moveq(ARGR0,R3);
+      jit_movne(ARGR0,R2);
+      if (return_type == TAG_ANY) jit_call(alloc_int, "alloc_int");
+      else {
+        compiled_type = TAG_INT;
+        jit_movr(R0,ARGR0);
+      }
+      break;
+    }
     case BUILTIN_DEF: {
       // TODO in the future, we could pre-allocate symbols
       // and especially their types based on type inference
@@ -1041,9 +1064,7 @@ int compile_expr(Cell* expr, Frame* frame, int return_type) {
       
       load_cell(R1,argdefs[0], frame);
       load_int(R2,argdefs[1], frame); // offset -> R2
-
-      // init r3
-      jit_movi(R3, 0);
+      jit_movr(R0,R1); // save original cell in r0
 
       // todo: compile-time checking would be much more awesome
       // type check
@@ -1055,11 +1076,12 @@ int compile_expr(Cell* expr, Frame* frame, int return_type) {
       jit_je(label_ok);
 
       // wrong type
+      jit_movi(R3, 0);
       jit_jmp(label_skip);
 
       // good type
       jit_label(label_ok);
-      load_cell(R0,argdefs[0], frame);
+      jit_movr(R1,R0); // get original cell from r3
 
 #ifdef CHECK_BOUNDS
       // bounds check -----
@@ -1074,6 +1096,7 @@ int compile_expr(Cell* expr, Frame* frame, int return_type) {
       jit_movr(R1,R0);
       jit_ldr(R1); // string address
       jit_addr(R1,R2);
+      jit_movi(R3, 0);
       jit_ldrb(R1); // data in r3
 
       jit_label(label_skip);
@@ -1091,9 +1114,9 @@ int compile_expr(Cell* expr, Frame* frame, int return_type) {
       char label_skip[64];
       sprintf(label_skip,"Lskip_%d",++label_skip_count);
       
-      load_int(R3,argdefs[2], frame); // byte to store -> R3
-      load_int(R2,argdefs[1], frame); // offset -> R2
       load_cell(R0,argdefs[0], frame);
+      load_int(R2,argdefs[1], frame); // offset -> R2
+      load_int(R3,argdefs[2], frame); // byte to store -> R3
 
 #ifdef CHECK_BOUNDS
       // bounds check -----
@@ -1115,8 +1138,8 @@ int compile_expr(Cell* expr, Frame* frame, int return_type) {
       break;
     }
     case BUILTIN_GET32: {
-      load_cell(R3,argdefs[0], frame);
       load_int(R2,argdefs[1], frame); // offset -> R2
+      load_cell(R3,argdefs[0], frame);
       jit_ldr(R3); // string address
       jit_movi(R1,2); // offset * 4
       jit_shlr(R2,R1);
@@ -1132,9 +1155,9 @@ int compile_expr(Cell* expr, Frame* frame, int return_type) {
       char label_skip[64];
       sprintf(label_skip,"Lskip_%d",++label_skip_count);
     
-      load_int(R3,argdefs[2], frame); // word to store -> R3
-      load_int(R2,argdefs[1], frame); // offset -> R2
       load_cell(R1,argdefs[0], frame);
+      load_int(R2,argdefs[1], frame); // offset -> R2
+      load_int(R3,argdefs[2], frame); // word to store -> R3
 
 #ifdef CHECK_BOUNDS
       // bounds check -----
@@ -1368,6 +1391,7 @@ void init_compiler() {
   
   insert_symbol(alloc_sym("lt"), alloc_builtin(BUILTIN_LT, alloc_list(signature, 2)), &global_env);
   insert_symbol(alloc_sym("gt"), alloc_builtin(BUILTIN_GT, alloc_list(signature, 2)), &global_env);
+  insert_symbol(alloc_sym("eq"), alloc_builtin(BUILTIN_EQ, alloc_list(signature, 2)), &global_env);
   
   //printf("[compiler] compare\r\n");
   

sledge/os/editor.l

@@ -31,53 +31,6 @@
   (+ p 0)
 )))
 
-(def copy (fn buf from to num (do
-  (let i 0)
-  (let c 0)
-
-  ;(print (list "copy: " buf from to num))
-  
-  (if (lt from to)
-    (do 
-      (let i (- num 1)) 
-      (while (gt i -1) (do
-        (let c (get buf (+ from i)))
-        (put buf (+ to i) c)
-        (let i (- i 1))
-      )) 0)
-    (do
-      (let i 0)
-      (while (lt i num) (do
-        (let c (get buf (+ from i)))
-        (put buf (+ to i) c)
-        (let i (+ i 1))
-      )) 0)
-  )
-  num
-)))
-
-; fixme clobbered reg loading broken on x64?
-; fixme use substr instead of mutation
-
-(def remove (fn buf pos (do
-  (let p (+ pos 0))
-  (let from (+ pos 1))
-  (let num (- (size buf) pos))
-  (copy buf from p num)
-  (put buf (- (size buf) 1) 0)
-  buf
-)))
-
-(def insert (fn buf pos k (do
-  (let p (+ pos 0))
-  (let to (+ pos 1))
-  (let c (+ k 0))
-  (let num (- (size buf) (+ pos 1)))
-  (copy buf p to num)
-  (put buf p c)
-  buf
-)))
-
 (def buf-render-x 32)
 (def buf-render-y 32)
 (def cursor-char 32)
@@ -96,6 +49,8 @@
   (let nextpos 0)
   (let y buf-render-y)
   (let render-all 0)
+
+  (print (list "buf-render" cursor b lines last-num-lines))
   
   ; number of lines changed? then rerender
   (if (or scroll-dirty (not (eq last-num-lines (list-size lines)))) (do
@@ -232,11 +187,6 @@
     ) 0)
   
   ))))))
-
-  (if buf-dirty (do
-    (buf-render cursor buf)
-    (def buf-dirty 0)
-  ) 0)
   0
 )))
 
@@ -260,10 +210,15 @@
     (let k (get str 0))
 
     (handle-editor-key k)
-
+    
     (if (lt cursor 0) (def cursor 0) 0)
     (if (gt cursor (size buf)) (def cursor (size buf)) 0)
 
+    (if buf-dirty (do
+      (buf-render cursor buf)
+      (def buf-dirty 0)
+    ) 0)
+    
     ; (print (list "term-x/y" term-x term-y))
     (if (gt blink 9)
       (blit-char 0x2588 term-x term-y)

sledge/os/gfx.l

@@ -0,0 +1,310 @@
+(
+(def fb (mmap "/framebuffer"))
+(def scr (open "/framebuffer"))
+(def screen-pitch (* screen-width screen-bpp)) ; // TODO read from framebuffer
+
+(def stroke-color 0x0000)
+
+(if (gt screen-bpp 1)
+; 16 bit
+(def set-pixel (fn x y c (do
+  (let ofs (+ (* y screen-pitch) (shl x 1)))
+  (put fb ofs (shr c 8))
+  (put fb (+ 1 ofs) c)
+  c
+)))
+; 8 bit
+(def set-pixel (fn x y c (do
+  (let ofs (+ (* y screen-pitch) x))
+  (put fb ofs c)
+  c
+)))
+)
+
+(def pt list)
+
+(def line (fn a b (do
+  (let xa (car a))
+  (let ya (car (cdr a)))
+  (let xb (car b))
+  (let yb (car (cdr b)))
+  
+  (let dx (abs (- xb xa)))
+  (let dy (abs (- yb ya)))
+  (let sx (if (lt xa xb) 1 -1))
+  (let sy (if (lt ya yb) 1 -1))
+
+  (let err (if (gt dx dy) dx (- 0 dy)))
+  (let err (/ err 2))
+  (let e2 0)
+
+  (while (not (and (eq xa xb) (eq ya yb))) (do
+    (set-pixel xa ya stroke-color)
+    (let e2 err)
+    (if (gt e2 (- 0 dx)) (do (let err (- err dy)) (let xa (+ xa sx))) 0)
+    (if (lt e2       dy) (do (let err (+ err dx)) (let ya (+ ya sy))) 0)
+  ))
+  0
+)))
+
+(def f (open "/sd/unifont.bin"))
+(def unifont (recv f))
+(def unifont-pitch 4096)
+
+(def font unifont)
+(def font-pitch unifont-pitch)
+
+(def rune-w 16)
+(def rune-spacing 8)
+(def rune-h 16)
+(def rune-mod 256)
+
+(def set-unifont (fn (do
+  (def font unifont)
+  (def font-pitch unifont-pitch)
+  (def rune-w 16)
+  (def rune-spacing 8)
+  (def rune-h 16)
+  (def rune-mod 256)
+)))
+
+(def blit-char16 (fn rune x y (do
+  (let sx 0)
+  (let sy 0)
+  (let so 0)
+  (let do 0)
+  (let iy 0)
+  (let rune-ww 0)
+  (let c 0)
+  (let d 0)
+  
+  (let sx (* rune-w (% rune rune-mod)))
+  (let sy (* rune-h (/ rune rune-mod)))
+  (let so (+ (* sx 2) (* sy font-pitch)))
+  (let do (+ (*  x 2) (*  y screen-pitch)))
+
+  (let rune-ww (+ rune-spacing rune-spacing))
+  
+  (while (lt iy rune-h) (do
+    (let ix 0)
+    (while (lt ix rune-ww) (do
+      (let c (get font (+ so ix)))
+      (let d (get font (+ 1 (+ so ix))))
+      (put fb (+ do ix) c)
+      (put fb (+ (+ do ix) 1) d)
+      (let ix (+ ix 2))
+    ))
+    (let so (+ so font-pitch))
+    (let do (+ do screen-pitch))
+    (let iy (+ iy 1))
+  ))
+  0
+)))
+
+(def blit-char (fn rune x y (do
+  (let sx 0)
+  (let sy 0)
+  (let so 0)
+  (let do 0)
+  (let iy 0)
+  (let rune-ww 0)
+  (let c 0)
+  (let d 0)
+  
+  (let sx (* rune-w (% rune rune-mod)))
+  (let sy (* rune-h (/ rune rune-mod)))
+  (let so (+ sx (* sy font-pitch)))
+  (let do (+ (*  x 2) (*  y screen-pitch)))
+
+  (let rune-ww rune-spacing)
+  
+  (while (lt iy rune-h) (do
+    (let ix 0)
+    (let dx 0)
+    (while (lt ix rune-ww) (do
+      (let c (get font (+ so ix)))
+      (let dx (+ do (shl ix 1)))
+      (put fb dx c)
+      (put fb (+ dx 1) c)
+      (let ix (+ ix 1))
+    ))
+    (let so (+ so font-pitch))
+    (let do (+ do screen-pitch))
+    (let iy (+ iy 1))
+  ))
+  0
+)))
+
+(def blit-char8 (fn rune x y (do
+  (let sx 0)
+  (let sy 0)
+  (let so 0)
+  (let do 0)
+  (let iy 0)
+  (let rune-ww 0)
+  (let c 0)
+  (let d 0)
+  
+  (let sx (* rune-w (% rune rune-mod)))
+  (let sy (* rune-h (/ rune rune-mod)))
+  (let so (+ sx (* sy font-pitch)))
+  (let do (+ x (*  y screen-pitch)))
+
+  (let rune-ww rune-spacing)
+  
+  (while (lt iy rune-h) (do
+    (let ix 0)
+    (let dx 0)
+    (while (lt ix rune-ww) (do
+      (let c (get font (+ so ix)))
+      (let dx (+ do ix))
+      (put fb dx c)
+      (let ix (+ ix 1))
+    ))
+    (let so (+ so font-pitch))
+    (let do (+ do screen-pitch))
+    (let iy (+ iy 1))
+  ))
+  0
+)))
+
+(if (eq screen-bpp 1) (def blit-char blit-char8) 0)
+
+(def grab-from fb)
+(def grab-pitch screen-pitch)
+(def grab (fn x y w h (do
+  (let xx 0)
+  (let yy 0)
+  (let di 0)
+  (let yy (+ y 0))
+  (let xw (+ x w))
+  (let yh (+ y h)) 
+  (let res (alloc (* (shl w 1) h)))
+  (let from grab-from)
+  (let pitch grab-pitch)
+  (while (lt yy yh) (do
+    (let xx (+ x 0))
+    (while (lt xx xw) (do
+      (put res di (get from (+ xx (* pitch yy))))
+      (let di (+ di 1))
+      (put res di (get from (+ (+ xx (* pitch yy)) 1)))
+      (let di (+ di 1))
+      (let xx (+ xx 1))
+    ))
+    (let yy (+ yy 1))
+  ))
+  res
+)))
+
+(def paste (fn from x y w h (do
+  (let xx 0)
+  (let yy 0)
+  (let di 0)
+  (let si 0)
+  (let yy (+ y 0))
+  (let xw (+ x w))
+  (let yh (+ y h))
+  (let to grab-from)
+  (let pitch (+ grab-pitch 0))
+  (while (lt yy yh) (do
+    (let xx (+ x 0))
+    (while (lt xx xw) (do
+      (let di (+ xx (* pitch yy)))
+      (put to di (get from si))
+      (put to (+ di 1) (get from (+ si 1)))
+      (let si (+ si 2))
+      (let di (+ di 2))
+      (let xx (+ xx 1))
+    ))
+    (let yy (+ yy 1))
+  ))
+  1
+)))
+
+(def maxx (- screen-width 32))
+(def maxy (- screen-height 32))
+(def minx 32)
+(def miny 32)
+
+(def blit-str (fn str x y (do
+  (let i 0)
+  (let xx 0)
+  (let yy 0)
+  (let xx (+ x 0))
+  (let yy (+ y 0))
+  (let sz (+ (size str) 0))
+  (let c 0)
+  (while (lt i sz) (do
+    (let c (get str i))
+    (blit-char c xx yy)
+    (let xx (+ xx rune-spacing))
+    ; newline
+    (if (or (eq c 10) (gt xx maxx)) (do
+      (let xx minx)
+      (let yy (+ yy rune-h))
+      (if (gt yy maxy) (do
+        (let yy miny)) 0)
+    ) 0)
+    (let i (+ i 1))
+    (if (get str i) 0 (let i sz)) ; stop at 0
+  ))
+  yy
+)))
+
+(def boxfill (fn x y w h color (do
+  (let ofs 0)
+  (let xi 0)
+  (let yi 0)
+  (let xi (+ x 0))
+  (let yi (+ y 0))
+  (let xx (+ x w))
+  (let yy (+ y h))
+  (let chi 0)
+  (let clo 0)
+  (let chi (shr color 8))
+  (let clo (bitand color 0xff))
+  (let ofs (+ (* y screen-pitch) (shl x 1)))
+  (let ww (shl w 1))
+
+  (while (lt yi yy) (do
+    (let xi (+ x 0))
+    (while (lt xi xx) (do
+      (put fb ofs chi)
+      (put fb (+ 1 ofs) clo)
+      (let xi (+ xi 1))
+      (let ofs (+ ofs 2))
+    ))
+    (let ofs (- (+ ofs screen-pitch) ww))
+    (let yi (+ yi 1))
+  ))
+  0 ; crashes x64 if this is not here
+)))
+
+(def triangle (fn a b c (do
+  (line a b)
+  (line b c)
+  (line a c)
+)))
+
+(def box (fn tl br (do
+  (let tr (list (car br) (car (cdr tl))))
+  (let bl (list (car tl) (car (cdr br))))
+  
+  (line tl tr)
+  (line bl br)
+  (line tr br)
+  (line tl bl)
+)))
+
+(def circle (fn cx cy r (do
+  (let x 0)
+  (while (lt x 359) (do
+    (set-pixel (+ cx (* (sin x) r)) (+ cy (* (cos x) r)) stroke-color)
+    (let x (+ x 1))
+  ))
+  x
+)))
+
+(def clear (fn (boxfill 0 0 maxx maxy 0xffff)))
+
+)

sledge/os/lib.l

@@ -0,0 +1,112 @@
+(
+(def load (fn path (recv (open path))))
+(def import (fn path (eval (read (recv (open path))))))
+
+(def and (fn a b (if a (if b 1 0) 0)))
+(def or  (fn a b (if a a b)))
+(def not (fn a (if a 0 1)))
+
+(def item (fn lst idx (do
+  (let i 0)
+  (let l lst)
+  (while (gt idx i) (do
+    (let l (cdr l))
+    (let i (+ i 1))))
+  (car l)
+)))
+
+(def list-size (fn lst (do
+  (let i 0)
+  (let l lst)
+  (while (car l) (do
+    (let l (cdr l))
+    (let i (+ i 1))))
+  i
+)))
+
+(def split (fn str sepstr (do
+  (let sep (get sepstr 0))
+  (let result (quote ()))
+  (let sz (size str))
+  (let i 0)
+  (let i (- sz 1))
+  (let last-i 0)
+  (let last-i (+ i 1))
+  (let partsize 0)
+  
+  (while (gt i -2) (do
+    (if (or (eq (get str i) sep) (eq i -1)) (do
+      (let partsize (- (- last-i i) 1))
+  
+      (if (gt partsize -1)
+        (let result (cons (substr str (+ i 1) partsize) result)) 0)
+      (let last-i i)
+    ) 0)
+    (let i (- i 1))
+  ))
+  result
+)))
+
+(def copy (fn buf from to num (do
+  (let i 0)
+  (let c 0)
+
+  ;(print (list "copy: " buf from to num))
+  
+  (if (lt from to)
+    (do 
+      (let i (- num 1)) 
+      (while (gt i -1) (do
+        (let c (get buf (+ from i)))
+        (put buf (+ to i) c)
+        (let i (- i 1))
+      )) 0)
+    (do
+      (let i 0)
+      (while (lt i num) (do
+        (let c (get buf (+ from i)))
+        (put buf (+ to i) c)
+        (let i (+ i 1))
+      )) 0)
+  )
+  num
+)))
+
+; fixme use substr + concat instead of mutation
+
+(def remove (fn buf pos (do
+  (let p (+ pos 0))
+  (let from (+ pos 1))
+  (let num (- (size buf) pos))
+  (copy buf from p num)
+  (put buf (- (size buf) 1) 0)
+  buf
+)))
+
+(def insert (fn buf pos k (do
+  (let p (+ pos 0))
+  (let to (+ pos 1))
+  (let c (+ k 0))
+  (let num (- (size buf) (+ pos 1)))
+  (copy buf p to num)
+  (put buf p c)
+  buf
+)))
+
+(def strlen (fn s (if s (do
+  (let i 0)
+  (let sz (size s))
+  (let c (get s 0))
+  (while (* (gt c 0) (lt i sz)) (do
+    (let i (+ i 1))
+    (let c (get s i))
+  ))
+  i) 0)
+))
+
+(def sintab [80828486888b8d8f919496989a9c9ea1a3a5a7a9abadafb2b4b6b8babcbec0c1c3c5c7c9cbcdced0d2d3d5d7d8dadcdddfe0e2e3e4e6e7e8eaebecedeeeff1f2f3f4f4f5f6f7f8f9f9fafbfbfcfcfdfdfefefefffffffffffffffffffffffffffffffefefefdfdfcfcfbfbfaf9f9f8f7f6f5f4f4f3f2f1efeeedecebeae8e7e6e4e3e2e0dfdddcdad8d7d5d3d2d0cecdcbc9c7c5c3c1c0bebcbab8b6b4b2afadaba9a7a5a3a19e9c9a989694918f8d8b88868482807d7b79777472706e6b69676563615e5c5a58565452504d4b49474543413f3e3c3a38363432312f2d2c2a2827252322201f1d1c1b1918171514131211100e0d0c0b0b0a0908070606050404030302020101010000000000000000000000000000000101010202030304040506060708090a0b0b0c0d0e1011121314151718191b1c1d1f2022232527282a2c2d2f31323436383a3c3e3f41434547494b4d50525456585a5c5e61636567696b6e70727477797b7d])
+
+(def sin (fn deg (get sintab (% deg 360))))
+(def cos (fn deg (get sintab (% (+ deg 90) 360))))
+(def abs (fn a (if (lt a 0) (- 0 a) a)))
+)

sledge/os/shell.l

@@ -1,109 +1,7 @@
 (
-(def and (fn a b (if a (if b 1 0) 0)))
-(def or (fn a b (+ a b)))
-(def not (fn a (if a 0 1)))
-(def eq (fn a b (lt (+ (lt a b) (gt a b)) 1)))
-
-(def item (fn lst idx (do
-  (let i 0)
-  (let l lst)
-  (while (gt idx i) (do
-    (let l (cdr l))
-    (let i (+ i 1))))
-  (car l)
-)))
-
-(def list-size (fn lst (do
-  (let i 0)
-  (let l lst)
-  (while (car l) (do
-    (let l (cdr l))
-    (let i (+ i 1))))
-  i
-)))
-
-(def split (fn str sepstr (do
-  (let sep (get sepstr 0))
-  (let result (quote ()))
-  (let sz (size str))
-  (let i 0)
-  (let i (- sz 1))
-  (let last-i 0)
-  (let last-i (+ i 1))
-  (let partsize 0)
-  
-  (while (gt i -2) (do
-    (if (or (eq (get str i) sep) (eq i -1)) (do
-      (let partsize (- (- last-i i) 1))
-  
-      (if (gt partsize -1)
-        (let result (cons (substr str (+ i 1) partsize) result)) 0)
-      (let last-i i)
-    ) 0)
-    (let i (- i 1))
-  ))
-  result
-)))
-
-(def sintab [80828486888b8d8f919496989a9c9ea1a3a5a7a9abadafb2b4b6b8babcbec0c1c3c5c7c9cbcdced0d2d3d5d7d8dadcdddfe0e2e3e4e6e7e8eaebecedeeeff1f2f3f4f4f5f6f7f8f9f9fafbfbfcfcfdfdfefefefffffffffffffffffffffffffffffffefefefdfdfcfcfbfbfaf9f9f8f7f6f5f4f4f3f2f1efeeedecebeae8e7e6e4e3e2e0dfdddcdad8d7d5d3d2d0cecdcbc9c7c5c3c1c0bebcbab8b6b4b2afadaba9a7a5a3a19e9c9a989694918f8d8b88868482807d7b79777472706e6b69676563615e5c5a58565452504d4b49474543413f3e3c3a38363432312f2d2c2a2827252322201f1d1c1b1918171514131211100e0d0c0b0b0a0908070606050404030302020101010000000000000000000000000000000101010202030304040506060708090a0b0b0c0d0e1011121314151718191b1c1d1f2022232527282a2c2d2f31323436383a3c3e3f41434547494b4d50525456585a5c5e61636567696b6e70727477797b7d])
-
-(def sin (fn deg (get sintab (% deg 360))))
-(def cos (fn deg (get sintab (% (+ deg 90) 360))))
-(def abs (fn a (if (lt a 0) (- 0 a) a)))
-
-(def load (fn path (recv (open path))))
 (def ls (fn (do
   (split (load "/sd/") [0a])
 )))
-(def import (fn path (eval (read (recv (open path))))))
-
-(def fb (mmap "/framebuffer"))
-(def scr (open "/framebuffer"))
-(def screen-pitch (* screen-width screen-bpp)) ; // TODO read from framebuffer
-
-(def stroke-color 0x0000)
-
-(if (gt screen-bpp 1)
-; 16 bit
-(def set-pixel (fn x y c (do
-  (let ofs (+ (* y screen-pitch) (shl x 1)))
-  (put fb ofs (shr c 8))
-  (put fb (+ 1 ofs) c)
-  c
-)))
-; 8 bit
-(def set-pixel (fn x y c (do
-  (let ofs (+ (* y screen-pitch) x))
-  (put fb ofs c)
-  c
-)))
-)
-
-(def pt list)
-
-(def line (fn a b (do
-  (let xa (car a))
-  (let ya (car (cdr a)))
-  (let xb (car b))
-  (let yb (car (cdr b)))
-  
-  (let dx (abs (- xb xa)))
-  (let dy (abs (- yb ya)))
-  (let sx (if (lt xa xb) 1 -1))
-  (let sy (if (lt ya yb) 1 -1))
-
-  (let err (if (gt dx dy) dx (- 0 dy)))
-  (let err (/ err 2))
-  (let e2 0)
-
-  (while (not (and (eq xa xb) (eq ya yb))) (do
-    (set-pixel xa ya stroke-color)
-    (let e2 err)
-    (if (gt e2 (- 0 dx)) (do (let err (- err dy)) (let xa (+ xa sx))) 0)
-    (if (lt e2       dy) (do (let err (+ err dx)) (let ya (+ ya sy))) 0)
-  ))
-  0
-)))
 
 (def draw-logo (fn ox oy (do
   (def stroke-color 0xff8e)
@@ -120,251 +18,7 @@
 (draw-logo (- (/ screen-width 2) 140) (/ screen-height 2))
 (draw-logo (- (/ screen-width 2) 139) (/ screen-height 2))
 (draw-logo (- (/ screen-width 2) 140) (+ 1 (/ screen-height 2)))
-
-(def f (open "/sd/unifont.bin"))
-(def unifont (recv f))
-(def unifont-pitch 4096)
-
-(def font unifont)
-(def font-pitch unifont-pitch)
-
-(def rune-w 16)
-(def rune-spacing 8)
-(def rune-h 16)
-(def rune-mod 256)
-
-(def set-unifont (fn (do
-  (def font unifont)
-  (def font-pitch unifont-pitch)
-  (def rune-w 16)
-  (def rune-spacing 8)
-  (def rune-h 16)
-  (def rune-mod 256)
-)))
-
-(def fghi 0xff)
-(def fglo 0x00)
-
-(def blit-char16 (fn rune x y (do
-  (let sx 0)
-  (let sy 0)
-  (let so 0)
-  (let do 0)
-  (let iy 0)
-  (let rune-ww 0)
-  (let c 0)
-  (let d 0)
-  
-  (let sx (* rune-w (% rune rune-mod)))
-  (let sy (* rune-h (/ rune rune-mod)))
-  (let so (+ (* sx 2) (* sy font-pitch)))
-  (let do (+ (*  x 2) (*  y screen-pitch)))
-
-  (let rune-ww (+ rune-spacing rune-spacing))
-  
-  (while (lt iy rune-h) (do
-    (let ix 0)
-    (while (lt ix rune-ww) (do
-      (let c (get font (+ so ix)))
-      (let d (get font (+ 1 (+ so ix))))
-      (put fb (+ do ix) c)
-      (put fb (+ (+ do ix) 1) d)
-      (let ix (+ ix 2))
-    ))
-    (let so (+ so font-pitch))
-    (let do (+ do screen-pitch))
-    (let iy (+ iy 1))
-  ))
-  0
-)))
-
-(def blit-char (fn rune x y (do
-  (let sx 0)
-  (let sy 0)
-  (let so 0)
-  (let do 0)
-  (let iy 0)
-  (let rune-ww 0)
-  (let c 0)
-  (let d 0)
-  
-  (let sx (* rune-w (% rune rune-mod)))
-  (let sy (* rune-h (/ rune rune-mod)))
-  (let so (+ sx (* sy font-pitch)))
-  (let do (+ (*  x 2) (*  y screen-pitch)))
-
-  (let rune-ww rune-spacing)
-  
-  (while (lt iy rune-h) (do
-    (let ix 0)
-    (let dx 0)
-    (while (lt ix rune-ww) (do
-      (let c (get font (+ so ix)))
-      (let dx (+ do (shl ix 1)))
-      (put fb dx c)
-      (put fb (+ dx 1) c)
-      (let ix (+ ix 1))
-    ))
-    (let so (+ so font-pitch))
-    (let do (+ do screen-pitch))
-    (let iy (+ iy 1))
-  ))
-  0
-)))
-
-(def blit-char8 (fn rune x y (do
-  (let sx 0)
-  (let sy 0)
-  (let so 0)
-  (let do 0)
-  (let iy 0)
-  (let rune-ww 0)
-  (let c 0)
-  (let d 0)
-  
-  (let sx (* rune-w (% rune rune-mod)))
-  (let sy (* rune-h (/ rune rune-mod)))
-  (let so (+ sx (* sy font-pitch)))
-  (let do (+ x (*  y screen-pitch)))
-
-  (let rune-ww rune-spacing)
-  
-  (while (lt iy rune-h) (do
-    (let ix 0)
-    (let dx 0)
-    (while (lt ix rune-ww) (do
-      (let c (get font (+ so ix)))
-      (let dx (+ do ix))
-      (put fb dx c)
-      (let ix (+ ix 1))
-    ))
-    (let so (+ so font-pitch))
-    (let do (+ do screen-pitch))
-    (let iy (+ iy 1))
-  ))
-  0
-)))
-
-(if (eq screen-bpp 1) (def blit-char blit-char8) 0)
-
-(def grab-from fb)
-(def grab-pitch screen-pitch)
-(def grab (fn x y w h (do
-  (let xx 0)
-  (let yy 0)
-  (let di 0)
-  (let yy (+ y 0))
-  (let xw (+ x w))
-  (let yh (+ y h)) 
-  (let res (alloc (* (shl w 1) h)))
-  (let from grab-from)
-  (let pitch grab-pitch)
-  (while (lt yy yh) (do
-    (let xx (+ x 0))
-    (while (lt xx xw) (do
-      (put res di (get from (+ xx (* pitch yy))))
-      (let di (+ di 1))
-      (put res di (get from (+ (+ xx (* pitch yy)) 1)))
-      (let di (+ di 1))
-      (let xx (+ xx 1))
-    ))
-    (let yy (+ yy 1))
-  ))
-  res
-)))
-
-(def paste (fn from x y w h (do
-  (let xx 0)
-  (let yy 0)
-  (let di 0)
-  (let si 0)
-  (let yy (+ y 0))
-  (let xw (+ x w))
-  (let yh (+ y h))
-  (let to grab-from)
-  (let pitch (+ grab-pitch 0))
-  (while (lt yy yh) (do
-    (let xx (+ x 0))
-    (while (lt xx xw) (do
-      (let di (+ xx (* pitch yy)))
-      (put to di (get from si))
-      (put to (+ di 1) (get from (+ si 1)))
-      (let si (+ si 2))
-      (let di (+ di 2))
-      (let xx (+ xx 1))
-    ))
-    (let yy (+ yy 1))
-  ))
-  1
-)))
-
-; 112 x 30 chars at scale 2
-
-(def scale 2)
-(def maxx (/ 1847 scale))
-(def maxy 1015)
-(def minx 32)
-(def miny 32)
-
-(def blit-str (fn str x y (do
-  (let i 0)
-  (let xx 0)
-  (let yy 0)
-  (let xx (+ x 0))
-  (let yy (+ y 0))
-  (let sz (+ (size str) 0))
-  (let c 0)
-  (while (lt i sz) (do
-    (let c (get str i))
-    (blit-char c xx yy)
-    (let xx (+ xx rune-spacing))
-    ; newline
-    (if (or (eq c 10) (gt xx maxx)) (do
-      (let xx minx)
-      (let yy (+ yy rune-h))
-      (if (gt yy maxy) (do
-        (let yy miny)) 0)
-    ) 0)
-    (let i (+ i 1))
-    (if (get str i) 0 (let i sz)) ; stop at 0
-  ))
-  yy
-)))
-
-(def boxfill (fn x y w h color (do
-  (let ofs 0)
-  (let xi 0)
-  (let yi 0)
-  (let xi (+ x 0))
-  (let yi (+ y 0))
-  (let xx (+ x w))
-  (let yy (+ y h))
-  (let chi 0)
-  (let clo 0)
-  (let chi (shr color 8))
-  (let clo (bitand color 0xff))
-  (let ofs (+ (* y screen-pitch) (shl x 1)))
-  (let ww (shl w 1))
-
-  (while (lt yi yy) (do
-    (let xi (+ x 0))
-    (while (lt xi xx) (do
-      (put fb ofs chi)
-      (put fb (+ 1 ofs) clo)
-      (let xi (+ xi 1))
-      (let ofs (+ ofs 2))
-    ))
-    (let ofs (- (+ ofs screen-pitch) ww))
-    (let yi (+ yi 1))
-  ))
-  0 ; crashes x64 if this is not here
-)))
-
-(def clear (fn (do
-  (boxfill 0 0 maxx maxy 0xffff)
-  (def term-x minx)
-  (def term-y miny)
-0)))
+(send scr 0)
 
 (blit-str "Welcome to Interim OS." 32 32)
 (send scr 0)
@@ -377,17 +31,6 @@
 
 (def keyboard (open "/keyboard"))
 
-(def strlen (fn s (if s (do
-  (let i 0)
-  (let sz (size s))
-  (let c (get s 0))
-  (while (* (gt c 0) (lt i sz)) (do
-    (let i (+ i 1))
-    (let c (get s i))
-  ))
-  i) 0)
-))
-
 (def term-x minx)
 (def term-y (+ miny 32))
 
@@ -543,32 +186,7 @@
   ))
 )))
 
-(def triangle (fn a b c (do
-  (line a b)
-  (line b c)
-  (line a c)
-)))
-
-(def box (fn tl br (do
-  (let tr (list (car br) (car (cdr tl))))
-  (let bl (list (car tl) (car (cdr br))))
-  
-  (line tl tr)
-  (line bl br)
-  (line tr br)
-  (line tl bl)
-)))
-
-(def circle (fn cx cy r (do
-  (let x 0)
-  (while (lt x 359) (do
-    (set-pixel (+ cx (* (sin x) r)) (+ cy (* (cos x) r)) stroke-color)
-    (let x (+ x 1))
-  ))
-  x
-)))
-
-(def ed (fn (import "/sd/tests/editlite.l") ))
+(def ed (fn (import "/sd/os/editor.l") ))
 
 (def buffer-read (list))
 

sledge/sledge.c

@@ -92,7 +92,7 @@ int main(int argc, char *argv[])
   }
 
   while (1) {
-    printf("sledge> ");
+    if (in_f == stdin) printf("sledge> ");
     expr = NULL;
     len = 0;
 
@@ -119,14 +119,14 @@ int main(int argc, char *argv[])
       in_buffer[in_offset+i+1]=0;
     
       if (parens>0) {
-        //printf("...\r\n");
+        if (in_f == stdin) printf("...\r\n");
         in_offset+=i;
       } else {
         in_offset=0;
         if (len>1) {
           expr = (Cell*)read_string(in_buffer);
         } else {
-          printf("\r\n");
+          //printf("\r\n");
         }
       }
     }
@@ -146,11 +146,13 @@ int main(int argc, char *argv[])
       int success = compile_for_platform(expr, &res);
       
       if (success) {
-        if (!res) {
-          printf("invalid cell (%p)\r\n",res);
-        } else {
-          lisp_write(res, out_buf, 1024);
-          printf("\r\n%s\r\n",out_buf);
+        if (in_f == stdin) {
+          if (!res) {
+            printf("invalid cell (%p)\r\n",res);
+          } else {
+            lisp_write(res, out_buf, 1024);
+            printf("%s\r\n",out_buf);
+          }
         }
       } else {
         printf("<compilation failed>\n");

sledge/tests/boot2.l

@@ -1 +1,4 @@
-(eval (read (recv (open "/sd/os/shell.l"))))
+(eval (read (recv (open "/sd/os/lib.l"))))
+(import "/sd/os/gfx.l")
+(import "/sd/os/shell.l")
+

sledge/tests/test.l

@@ -1,14 +1,14 @@
 (def demo (fn
-(do (mut c 0)
-    (def a 1024)
+(do (let c 0)
+    (let a 1024)
   (while 1 (do
-    (mut c (+ 1 (% (+ c 1) 256)))
-    (mut b 768)
-    (while (mut b (- b 1))
+    (let c (+ 1 (% (+ c 1) 256)))
+    (let b 768)
+    (while (let b (- b 1))
       (do
-        (mut a 512)
-        (mut c (+ 1 c))
-        (while (mut a (- a 1))
-          (pixel (+ a 512) b (* (+ c a) (/ (* a b) c))))))
-    (flip))))
+        (let a 512)
+        (let c (+ 1 c))
+        (while (let a (- a 1))
+          (set-pixel (+ a 512) b (* (+ c a) (/ (* a b) c))))))
+    (send scr 0))))
 ))

sledge/tests/tests.l

@@ -1,3 +1,6 @@
+(def import (fn path (eval (read (recv (open path))))))
+(import "/sd/os/lib.l")
+
 (def foo (fn "foo"))
 (foo)
 (cons 1 2)
@@ -5,15 +8,14 @@
 (cons 1 "foo")
 (cons "a" (cons "b" "c"))
 
-(def test (fn tn tx (cons (cons "test " tn) (if tx "OK" "FAIL"))))  
-(def = (fn a b (if (- a b) 0 1)))
+(def test (fn tn tx (print (list "test " tn (if tx "OK" "FAIL")))))  
+(def = eq)
 (def not (fn a (if a 0 1)))
 
 (test 1 (= 1 1))
 (test 2 (= 2 2))
 (test 3 (not (= 1 0)))
 (test 4 (not (= 0 1)))
-(test 5 (not (= "hello" "hello")))
 (test 6 (= + +))
 (test 7 (= (+ 1 2) (+ 2 1)))
 (test 8 (def a 1))
@@ -24,9 +26,9 @@
 (test 12 (= 4 (do 1 2 "foo" 4)))
 (test 13 (= 3 (size (do 1 2 "foo"))))
 
-;(def fib (fn n (if (lt n 3)
-;                   1
-;                 (+ (fib (- n 1)) (fib (- n 2))) )))
+(def fib (fn n 0))
+(def fib (fn n (if (lt n 3) 1
+                 (+ (fib (- n 1)) (fib (- n 2))) )))
 
 (test 14 (= (fib 10) 55))
 
@@ -36,4 +38,13 @@
 (def func-a (fn xx yy (* (+ xx 1) (+ yy 1))))
 (def func-b (fn x y (func-a x y)))
 
-(def tst (fn a b (blit-mono unifont a b 0 0 0 0 0 0)))
+(test 16 (= 12 (strlen (concat "hello" "worlden"))))
+
+(test 17 (= (get [65] 0) (get "beef" 1)))
+(test 18 (= (get [66] 0) (get "beef" 3)))
+
+(test 19 (lt 4 500))
+(test 20 (gt -2 -4))
+(test 21 (eq 666 (* -1 -666)))
+
+(test 22 (= (get (substr "hellaz" 1 3) 0) 101))

sledge/writer.c

@@ -73,15 +73,18 @@ char* write_(Cell* cell, char* buffer, int in_list, int bufsize) {
   } else if (cell->tag == TAG_BIGNUM) {
     snprintf(buffer, bufsize, "%s", (char*)cell->ar.addr);
   } else if (cell->tag == TAG_LAMBDA) {
+    char tmp_args[TMP_BUF_SIZE];
     char tmp_body[TMP_BUF_SIZE*2];
+    tmp_args[0]=0;
+    tmp_body[0]=0;
     Cell* args = car(cell->ar.addr);
     int ai = 0;
-    /*while (args && args->addr && args->next) {
-      ai += snprintf(tmp_args+ai, TMP_BUF_SIZE-ai, "%s ", (char*)(car(car(args)))->addr);
+    while (args && car(car(args))) {
+      ai += snprintf(tmp_args+ai, TMP_BUF_SIZE-ai, "%s ", (char*)(car(car(args)))->ar.addr);
       args = cdr(args);
-    }*/
+    }
     write_(cdr(cell->ar.addr), tmp_body, 0, TMP_BUF_SIZE);
-    snprintf(buffer, bufsize, "(fn %s %s)", "", tmp_body);
+    snprintf(buffer, bufsize, "(fn %s %s)", tmp_args, tmp_body);
   } else if (cell->tag == TAG_BUILTIN) {
     snprintf(buffer, bufsize, "(op "INTFORMAT")", cell->ar.value);
   } else if (cell->tag == TAG_ERROR) {