[MLton-commit] r5205

Wesley Terpstra wesley at mlton.org
Thu Feb 15 09:27:02 PST 2007


first stab at user defined functions
----------------------------------------------------------------------

A   mltonlib/trunk/ca/terpstra/sqlite3/buffer.sig
A   mltonlib/trunk/ca/terpstra/sqlite3/buffer.sml
U   mltonlib/trunk/ca/terpstra/sqlite3/demo.sml
U   mltonlib/trunk/ca/terpstra/sqlite3/function.sml
U   mltonlib/trunk/ca/terpstra/sqlite3/pointers.sml
U   mltonlib/trunk/ca/terpstra/sqlite3/prim.sig
U   mltonlib/trunk/ca/terpstra/sqlite3/prim.sml
U   mltonlib/trunk/ca/terpstra/sqlite3/query.sml
U   mltonlib/trunk/ca/terpstra/sqlite3/sql.sig
U   mltonlib/trunk/ca/terpstra/sqlite3/sql.sml
U   mltonlib/trunk/ca/terpstra/sqlite3/sqlite.mlb

----------------------------------------------------------------------

Added: mltonlib/trunk/ca/terpstra/sqlite3/buffer.sig
===================================================================
--- mltonlib/trunk/ca/terpstra/sqlite3/buffer.sig	2007-02-15 16:45:56 UTC (rev 5204)
+++ mltonlib/trunk/ca/terpstra/sqlite3/buffer.sig	2007-02-15 17:27:01 UTC (rev 5205)
@@ -0,0 +1,8 @@
+signature BUFFER =
+   sig
+      type 'a t
+      val empty: unit -> 'a t
+      val subOpt: 'a t * int -> 'a option
+      val sub: 'a t * int -> 'a
+      val push: 'a t * 'a -> int
+   end

Added: mltonlib/trunk/ca/terpstra/sqlite3/buffer.sml
===================================================================
--- mltonlib/trunk/ca/terpstra/sqlite3/buffer.sml	2007-02-15 16:45:56 UTC (rev 5204)
+++ mltonlib/trunk/ca/terpstra/sqlite3/buffer.sml	2007-02-15 17:27:01 UTC (rev 5205)
@@ -0,0 +1,18 @@
+structure Buffer :> BUFFER =
+   struct
+      type 'a t = 'a option array ref * int ref
+      
+      fun empty () = (ref (Array.tabulate (32, fn _ => NONE)), ref 0)
+      
+      fun subOpt ((a, s), i) = if i >= !s then NONE else Array.sub (!a, i)
+      fun sub (a, i) = valOf (subOpt (a, i))
+      
+      fun double (a, s) =
+         a := Array.tabulate (!s * 2, fn i => subOpt ((a, s), i))
+      
+      fun push ((a, s), v) = (
+         if !s = Array.length (!a) then double (a, s) else ();
+         Array.update (!a, !s, SOME v);
+         !s before s := !s + 1
+         )
+   end

Modified: mltonlib/trunk/ca/terpstra/sqlite3/demo.sml
===================================================================
--- mltonlib/trunk/ca/terpstra/sqlite3/demo.sml	2007-02-15 16:45:56 UTC (rev 5204)
+++ mltonlib/trunk/ca/terpstra/sqlite3/demo.sml	2007-02-15 17:27:01 UTC (rev 5205)
@@ -7,19 +7,30 @@
 val (dbname, query) = case CommandLine.arguments () of
      [x, y] => (x, y)
    | _ => die "Expecting: <database name> <query>\n"
-val arg = valOf (Int.fromString query)
 val db = SQL.openDB dbname handle SQL.Error x => die x
 
 local
+  open SQL.Function
+in
+  val M1 : t = fnS iS iS $ (fn (a & b) => a ^ b)
+  val () = SQL.registerFunction (db, "wes", M1)
+end
+
+local
   open SQL.Query
 in
   val Q1 = prepare db "select x, y from peanuts\n\
                       \where y="iI" or x="iS";" oS oI $
            handle SQL.Error x => die x
+  val Q2 = prepare db query oAS $
+           handle SQL.Error x => die x
 end
 
-fun dump (s & i) = print (s ^ " " ^ Int.toString i ^ "\n")
-val a  = SQL.app dump Q1 (arg & "hi") handle SQL.Error x => die x
+fun dumpP (s & i) = print (s ^ " " ^ Int.toString i ^ "\n")
+fun dumpV v = Vector.app (fn s => print (s ^ "\n")) v
+val () = SQL.app dumpP Q1 (4 & "hi") handle SQL.Error x => die x
+val () = SQL.app dumpV Q2 () handle SQL.Error x => die x
 
-val () = SQL.Query.close Q1
-val () = SQL.closeDB db
+val () = SQL.Query.close Q1 handle SQL.Error x => die x
+val () = SQL.Query.close Q2 handle SQL.Error x => die x
+val () = SQL.closeDB db handle SQL.Error x => die x

Modified: mltonlib/trunk/ca/terpstra/sqlite3/function.sml
===================================================================
--- mltonlib/trunk/ca/terpstra/sqlite3/function.sml	2007-02-15 16:45:56 UTC (rev 5204)
+++ mltonlib/trunk/ca/terpstra/sqlite3/function.sml	2007-02-15 17:27:01 UTC (rev 5205)
@@ -1,3 +1,41 @@
 structure Function =
    struct
+      type t = (Prim.context * Prim.value vector -> unit) * int
+      
+      type 'a oF = Prim.value vector -> 'a
+      type ('b, 'c) oN = Prim.value vector * (unit -> 'b) -> 'c
+      type ('a, 'b, 'c) acc = int * 'a oF * ('b, 'c) oN
+      
+      type ('v, 'a, 'b, 'c, 'd, 'e, 'f) input = 
+          (('a, 'v, 'b) acc, ('b, 'c, ('b, 'c) pair) acc, 'd, 'e, 'f) Fold.step0
+      type ('v, 'a, 'b, 'c, 'd, 'e) fnX = 
+          ((unit, 'a, 'a) acc, ('b, 'c, 'd) acc, ('b -> 'v) -> t, 'e) Fold.t 
+      
+      val iI0 = 0
+      fun iF0 _ = ()
+      fun iN0 (_, n) = n ()
+      
+      fun fnMap r = Fold.fold ((iI0, iF0, iN0),
+                               fn (iI, iF, _) => fn f => 
+                               (fn (c, v) => r (c, f (iF v)), iI))
+      fun fnB z = fnMap Prim.resultB z
+      fun fnR z = fnMap Prim.resultR z
+      fun fnI z = fnMap Prim.resultI z
+      fun fnZ z = fnMap Prim.resultZ z
+      fun fnS z = fnMap Prim.resultS z
+      fun fnX z = fnMap Prim.resultX z
+      
+      (* terminate an expression with this: *)
+      val $ = $
+      
+      fun iFx f (iN, iI) v = iN (v, fn () => f (Vector.sub (v, iI)))
+      fun iNx f (iN, iI) (v, n) = iN (v, fn () => f (Vector.sub (v, iI))) & n ()
+      fun iMap f = Fold.step0 (fn (iI, iF, iN) => 
+                                  (iI+1, iFx f (iN, iI), iNx f (iN, iI)))
+      fun iB z = iMap Prim.valueB z
+      fun iR z = iMap Prim.valueR z
+      fun iI z = iMap Prim.valueI z
+      fun iZ z = iMap Prim.valueZ z
+      fun iS z = iMap Prim.valueS z
+      fun iX z = iMap Prim.valueX z
    end

Modified: mltonlib/trunk/ca/terpstra/sqlite3/pointers.sml
===================================================================
--- mltonlib/trunk/ca/terpstra/sqlite3/pointers.sml	2007-02-15 16:45:56 UTC (rev 5204)
+++ mltonlib/trunk/ca/terpstra/sqlite3/pointers.sml	2007-02-15 17:27:01 UTC (rev 5205)
@@ -2,11 +2,13 @@
    sig
       type t
       val null: t
+      val fromPtr: MLton.Pointer.t -> t
    end
 structure Ptr =
    struct
       type t = MLton.Pointer.t
       val null = MLton.Pointer.null
+      fun fromPtr x = x
    end
 signature CSTR =
    sig

Modified: mltonlib/trunk/ca/terpstra/sqlite3/prim.sig
===================================================================
--- mltonlib/trunk/ca/terpstra/sqlite3/prim.sig	2007-02-15 16:45:56 UTC (rev 5204)
+++ mltonlib/trunk/ca/terpstra/sqlite3/prim.sig	2007-02-15 17:27:01 UTC (rev 5205)
@@ -79,7 +79,7 @@
       val resultS: context * string -> unit
       val resultX: context * storage -> unit
       
-      val createFunction: db * string * (context * value vector -> unit) option -> unit
+      val createFunction: db * string * (context * value vector -> unit) * int -> unit
 (*
       val createCollation: db * string * (string * string -> order) option -> unit
       val createAggregate: db * string * ((context * value vector -> unit) *

Modified: mltonlib/trunk/ca/terpstra/sqlite3/prim.sml
===================================================================
--- mltonlib/trunk/ca/terpstra/sqlite3/prim.sml	2007-02-15 16:45:56 UTC (rev 5204)
+++ mltonlib/trunk/ca/terpstra/sqlite3/prim.sml	2007-02-15 17:27:01 UTC (rev 5205)
@@ -259,10 +259,32 @@
         | resultX (c, BLOB b) = resultB (c, b)
         | resultX (c, NULL) = resultN c
       
-      fun createFunction (db, name, NONE) = 
+      type callback = Context.t * Value.t vector -> unit
+      
+      (* !!! Space leak !!! *)
+      val cfns = Buffer.empty ()
+      
+      fun fnCallback (context, numargs, args) =
+         let
+            val cfn = Buffer.sub (cfns, Word.toInt (Puser_data context))
+            fun get i = Value.fromPtr (MLton.Pointer.getPointer (args, i))
+            val args = Vector.tabulate (numargs, get)
+         in
+            cfn (context, args)
+         end
+      val () = _export "mlton_sqlite3_ufnhook" : (Context.t * int * MLton.Pointer.t -> unit) -> unit;
+                  fnCallback
+      val fnCallbackPtr = _address "mlton_sqlite3_ufnhook" : FnPtr.t;
+      
+(*
+      fun createFunction (db, name, NONE, _) = 
              code (db, Pcreate_function (db, CStr.fromString name, 0, 1, 0w0,
                                          FnPtr.null, FnPtr.null, FnPtr.null))
-        | createFunction (db, name, SOME f) = ()
+*)
+      fun createFunction (db, name, f, n) =
+             code (db, Pcreate_function (db, CStr.fromString name, n, 1, 
+                                         Word.fromInt (Buffer.push (cfns, f)),
+                                         fnCallbackPtr, FnPtr.null, FnPtr.null))
       
       type db = DB.t
       type query = Query.t

Modified: mltonlib/trunk/ca/terpstra/sqlite3/query.sml
===================================================================
--- mltonlib/trunk/ca/terpstra/sqlite3/query.sml	2007-02-15 16:45:56 UTC (rev 5204)
+++ mltonlib/trunk/ca/terpstra/sqlite3/query.sml	2007-02-15 17:27:01 UTC (rev 5205)
@@ -82,8 +82,9 @@
       val $ = $
       
       fun close { db, query, pool, used, iF, oF } =
-         if !used = 0 then raise Prim.Error "Query is being processed; cannot close" else
-         (List.app Prim.finalize (!pool); pool := [] ; used := ~1)
+         if !used = 0 
+         then (List.app Prim.finalize (!pool); pool := [] ; used := ~1)
+         else raise Prim.Error "Query is being processed; cannot close"
       
       fun iFx f iN (q, a) = case iN (q, a) of (i, x) => f (q, i, x)
       fun iNx f iN (q, a & y) = case iN (q, a) of (i, x) => (f (q, i, x); (i+1, y))

Modified: mltonlib/trunk/ca/terpstra/sqlite3/sql.sig
===================================================================
--- mltonlib/trunk/ca/terpstra/sqlite3/sql.sig	2007-02-15 16:45:56 UTC (rev 5204)
+++ mltonlib/trunk/ca/terpstra/sqlite3/sql.sig	2007-02-15 17:27:01 UTC (rev 5205)
@@ -116,34 +116,43 @@
        *   val g = fnX $ fn () => SQL.NULL
        * end
        *)
-(*
       structure Function:
          sig
             type t
             
+            (* don't look at this: *)
+            type ('a, 'b, 'c) acc
+            type ('v, 'a, 'b, 'c, 'd, 'e, 'f) input = 
+               (('a, 'v, 'b) acc, ('b, 'c, ('b, 'c) pair) acc, 'd, 'e, 'f) Fold.step0
+            type ('v, 'a, 'b, 'c, 'd, 'e) fnX = 
+               ((unit, 'a, 'a) acc, ('b, 'c, 'd) acc, ('b -> 'v) -> t, 'e) Fold.t 
+            
             (* Return types of the function *)
-            val fnB: (Word8Vector.vector, 'i, 'o, 'p, 'q, 'a, 'b, 'x, 'y, 'z) input
-            val fnR: (real,               'i, 'o, 'p, 'q, 'a, 'b, 'x, 'y, 'z) input
-            val fnI: (int,                'i, 'o, 'p, 'q, 'a, 'b, 'x, 'y, 'z) input
-            val fnZ: (Int64.int,          'i, 'o, 'p, 'q, 'a, 'b, 'x, 'y, 'z) input
-            val fnS: (string,             'i, 'o, 'p, 'q, 'a, 'b, 'x, 'y, 'z) input
-            val fnX: (storage,            'i, 'o, 'p, 'q, 'a, 'b, 'x, 'y, 'z) input
+            val fnB: (Word8Vector.vector, 'a, 'b, 'c, 'd, 'e) fnX
+            val fnR: (real,               'a, 'b, 'c, 'd, 'e) fnX
+            val fnI: (int,                'a, 'b, 'c, 'd, 'e) fnX
+            val fnZ: (Int64.int,          'a, 'b, 'c, 'd, 'e) fnX
+            val fnS: (string,             'a, 'b, 'c, 'd, 'e) fnX
+            val fnX: (storage,            'a, 'b, 'c, 'd, 'e) fnX
             
             val $ : 'a * ('a -> 'b) -> 'b
             
             (* Input parameters to the function *)
-            val iB: (Word8Vector.vector, 'i, 'o, 'p, 'q, 'a, 'b, 'x, 'y, 'z) input
-            val iR: (real,               'i, 'o, 'p, 'q, 'a, 'b, 'x, 'y, 'z) input
-            val iI: (int,                'i, 'o, 'p, 'q, 'a, 'b, 'x, 'y, 'z) input
-            val iZ: (Int64.int,          'i, 'o, 'p, 'q, 'a, 'b, 'x, 'y, 'z) input
-            val iS: (string,             'i, 'o, 'p, 'q, 'a, 'b, 'x, 'y, 'z) input
-            val iX: (storage,            'i, 'o, 'p, 'q, 'a, 'b, 'x, 'y, 'z) input
+            val iB: (Word8Vector.vector, 'a, 'b, 'c, 'd, 'e, 'f) input
+            val iR: (real,               'a, 'b, 'c, 'd, 'e, 'f) input
+            val iI: (int,                'a, 'b, 'c, 'd, 'e, 'f) input
+            val iZ: (Int64.int,          'a, 'b, 'c, 'd, 'e, 'f) input
+            val iS: (string,             'a, 'b, 'c, 'd, 'e, 'f) input
+            val iX: (storage,            'a, 'b, 'c, 'd, 'e, 'f) input
             
+(*
             (* Variadic functions *)
             val iAB: ...
+*)      
          end
       
-      val registerFunction:  string * Function.t option -> unit
-      val registerCollation: string * (string * string -> order) option -> unit
+      val registerFunction:  db * string * Function.t -> unit
+(*
+      val registerCollation: db * string * (string * string -> order) -> unit
 *)
    end

Modified: mltonlib/trunk/ca/terpstra/sqlite3/sql.sml
===================================================================
--- mltonlib/trunk/ca/terpstra/sqlite3/sql.sml	2007-02-15 16:45:56 UTC (rev 5204)
+++ mltonlib/trunk/ca/terpstra/sqlite3/sql.sml	2007-02-15 17:27:01 UTC (rev 5205)
@@ -95,4 +95,6 @@
                exec Q () before close Q
             end
       end
+      
+      fun registerFunction (db, s, (f, i)) = Prim.createFunction (db, s, f, i)
    end

Modified: mltonlib/trunk/ca/terpstra/sqlite3/sqlite.mlb
===================================================================
--- mltonlib/trunk/ca/terpstra/sqlite3/sqlite.mlb	2007-02-15 16:45:56 UTC (rev 5204)
+++ mltonlib/trunk/ca/terpstra/sqlite3/sqlite.mlb	2007-02-15 17:27:01 UTC (rev 5205)
@@ -2,6 +2,8 @@
    $(SML_LIB)/basis/basis.mlb
    $(SML_LIB)/basis/mlton.mlb
    
+   buffer.sig
+   buffer.sml
    prim.sig
    ann
       "allowFFI true"




More information about the MLton-commit mailing list