ffi.l (4764B)
1 # TODO double & float 2 3 # *Mod *ModFn 4 5 (put 'ctype 'cstr 'char*) 6 (put 'ctype 'bool 'int) 7 (put 'ctype 'null 'void*) 8 (put 'ctype 'uchar "unsigned char") 9 10 (de ctype (Type) 11 (or (get 'ctype Type) Type)) 12 13 (put 'cwrap 'void '((Name) "Nil")) 14 (put 'cwrap 'int '((Name) (pack "box(" Name ")"))) 15 (put 'cwrap 'cstr '((Name) (pack "mkStr(" Name ")"))) 16 (put 'cwrap 'bool '((Name) (pack Name " == 0 ? T : Nil"))) 17 (put 'cwrap 'null '((Name) "(void*) 0")) 18 (put 'cwrap 'double '((Name) (pack "box(" Name " * 10000)"))) 19 20 (put 'cwrap 'uchar (get 'cwrap 'int)) 21 (put 'cwrap 'uint (get 'cwrap 'int)) 22 (put 'cwrap 'long (get 'cwrap 'int)) 23 (put 'cwrap 'ulong (get 'cwrap 'int)) 24 (put 'cwrap 'void* (get 'cwrap 'int)) 25 (put 'cwrap 'float (get 'cwrap 'double)) 26 27 (de cwrap (Type Name) 28 (if (get 'cwrap Type) 29 (apply @ (list Name)) 30 Name)) 31 32 (put 'cbody 'int 33 '((N Type) 34 (prinl " NeedNum(ex, y);") 35 (prinl " " (ctype Type) " b" N " = (" (ctype Type) ") unBox(y);"))) 36 (put 'cbody 'cstr 37 '((N Type) 38 (prinl " any y" N "s = xSym(y);") 39 (prinl " char b" N "[bufSize(y" N "s)];") 40 (prinl " bufString(y" N "s, b" N ");"))) 41 (put 'cbody 'bool 42 '((N Type) 43 (prinl " " (ctype Type) " b" N " = y == Nil ? 0 : 1;"))) 44 (put 'cbody 'null 45 '((N Type) 46 (prinl " " (ctype Type) " b" N " = (" (ctype Type) ") 0;"))) 47 (put 'cbody 'double 48 '((N Type) 49 (prinl " NeedNum(ex, y);") 50 (prinl " " (ctype Type) " b" N " = (" (ctype Type) ") unBox(y) / 10000;"))) 51 # (double 52 # (prinl " NeedDouble(ex, y);") 53 # (prinl " " (ctype Type) " b" N " = (" (ctype Type) ") unBox(y);")) 54 (put 'cbody 'lfun 55 '((N Type Name) 56 (prinl " lcb_" Name " = y;") 57 (prinl " void* b" N " = (void*) lfun_" Name ";"))) 58 59 (put 'cbody 'uchar (get 'cbody 'int)) 60 (put 'cbody 'uint (get 'cbody 'int)) 61 (put 'cbody 'long (get 'cbody 'int)) 62 (put 'cbody 'ulong (get 'cbody 'int)) 63 (put 'cbody 'void* (get 'cbody 'int)) 64 (put 'cbody 'float (get 'cbody 'double)) 65 (put 'cbody 'lprg (get 'cbody 'lfun)) 66 67 (de cbody (N Type Name) 68 (apply (get 'cbody Type) (list N Type Name))) 69 70 (de module (Name Fn) 71 (setq *Mod Name) 72 (setq *ModFn (or Fn '((X) X))) 73 (out (pack *Mod ".ffi.c") 74 (prinl "/* Generated from " (pack *Mod ".ffi") " */") 75 (prinl) 76 (prinl "#include \"../pico.h\"")) 77 (out (pack *Mod ".ffi.h")) 78 (out (pack *Mod ".ffi.fn"))) 79 80 (de include @ 81 (out (pack "+" *Mod ".ffi.c") 82 (prinl) 83 (while (args) 84 (prinl "#include \"" (next) "\"")))) 85 86 (de cscale (scale) 87 (out (pack "+" *Mod ".ffi.c") 88 (prinl) 89 (prinl "#define SCL " scale ".0"))) 90 91 (de cfun Lst 92 (let (Fn (cadr Lst) Ret (car Lst) Args (cddr Lst)) 93 (out (pack "+" *Mod ".ffi.c") 94 (prinl) 95 (prin "any cfun_" Fn "(any ex") 96 (unless Args 97 (prin " __attribute__((unused))")) 98 (prinl ") {") 99 (when Args 100 (prinl " any x = ex, y;") 101 (for (N . I) Args 102 (prinl " x = cdr(x);") 103 (prinl " y = EVAL(car(x));") 104 (if (atom I) 105 (cbody N I) 106 (cbody N (car I) (cadr I))))) 107 (if (= 'void (ctype Ret)) 108 (prin " " Fn "(") 109 (prin " " (ctype Ret) " z = " Fn "(")) 110 (for (N . I) Args 111 (when (< 1 N) 112 (prin ", ")) 113 (prin "b" N)) 114 (prinl ");") 115 (prinl " return " (cwrap Ret "z") ";") 116 (prinl "}")) 117 (out (pack "+" *Mod ".ffi.h") 118 (prinl "any cfun_" Fn "(any ex);")) 119 (out (pack "+" *Mod ".ffi.fn") 120 (prinl " {cfun_" Fn ", \"" (apply *ModFn (list Fn)) "\"},")))) 121 122 (de lfun Lst 123 (let (Fn (cadr Lst) Ret (car Lst) Args (cddr Lst) NArgs (length Args)) 124 (out (pack "+" *Mod ".ffi.c") 125 (prinl) 126 (prinl "static any lcb_" Fn ";") 127 (prinl) 128 (prin "static any lfun_" Fn "(") 129 (for (N . I) Args 130 (when (< 1 N) 131 (prin ", ")) 132 (if (atom I) 133 (prin I " arg" N) 134 (prin (ctype (car I)) " " (cadr I)))) 135 (prinl ") {") 136 (prinl " cell c[" NArgs "];") 137 (for (N . I) Args 138 (prinl " Push(c[" (- N 1) "], " (cwrap (car I) (cadr I)) ");")) 139 (prinl " apply(NULL, lcb_" Fn ", NO, " NArgs ", c);") 140 (prinl " drop(c[0]);") 141 (prinl " return Nil;") # TODO return value 142 (prinl "}")))) 143 144 (de lprg Lst 145 (let (Fn (cadr Lst) Ret (car Lst)) 146 (out (pack "+" *Mod ".ffi.c") 147 (prinl) 148 (prinl "static any lcb_" Fn ";") 149 (prinl) 150 (prinl "static any lfun_" Fn "() {") 151 (prinl " prog(lcb_" Fn ");") 152 (prinl " return Nil;") # TODO return value 153 (prinl "}"))))