[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