- elephant-cvs@lists.common-lisp.net - mailman3.common-lisp.net

[elephant-cvs] CVS elephant/src/db-clsql
by rread 06 Mar '07

06 Mar '07

Update of /project/elephant/cvsroot/elephant/src/db-clsql In directory clnet:/tmp/cvs-serv379 Modified Files: sql-controller.lisp Log Message: changed query to execute-command --- /project/elephant/cvsroot/elephant/src/db-clsql/sql-controller.lisp 2007/02/18 22:09:01 1.21 +++ /project/elephant/cvsroot/elephant/src/db-clsql/sql-controller.lisp 2007/03/06 04:43:02 1.22 @@ -370,7 +370,7 @@ (progn (clsql::create-sequence [serial] :database con) (sqlite3-harmless-read sc) - (clsql::query + (clsql::execute-command (format nil "create table keyvalue ( pk integer PRIMARY KEY DEFAULT nextval('serial'), clctn_id integer NOT NULL, @@ -378,7 +378,7 @@ value varchar )") :database con) - ) + ) (clsql::create-table [keyvalue] ;; This is most likely to work with any database system.. '(

1 0

[elephant-cvs] CVS elephant/src/contrib/eslick/query-sketch
by ieslick 06 Mar '07

06 Mar '07

Update of /project/elephant/cvsroot/elephant/src/contrib/eslick/query-sketch In directory clnet:/tmp/cvs-serv27507/eslick/query-sketch Added Files: constraint-parser.lisp query-algebra.lisp query-planner.lisp query-syntax.lisp scratch.lisp Log Message: Archive of various attacks on query system --- /project/elephant/cvsroot/elephant/src/contrib/eslick/query-sketch/constraint-parser.lisp 2007/03/06 04:17:14 NONE +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/query-sketch/constraint-parser.lisp 2007/03/06 04:17:14 1.1 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;; ;;; query-syntax.lisp -- Implement syntax for the elephant query engine ;;; ;;; Copyright (c) 2007 by Ian S. Eslick ;;; <ieslick at common-lisp.net> ;;; ;;; Elephant users are granted the rights to distribute and use this software ;;; as governed by the terms of the Lisp Limited General Public License ;;; (http://opensource.franz.com/preamble.html) also known as the LLGPL. ;;; (in-package :elephant) ;; ;; Constraint graph ;; (defclass constraint-graph () ((variables :accessor constraint-variables :initarg :vars :initform nil) (edges :accessor constraint-edges :initarg :edges :initform nil))) (defmethod find-constraint-variable ((graph constraint-graph) var-name) (find var-name (constraint-variables graph) :test #'variable-name)) (defmethod find-constraint-edge ((graph constraint-graph) var1 var2) (when (symbolp var1) (setf var1 (find-constraint-variable graph var1))) (when (symbolp var2) (setf var2 (find-constraint-variable graph var2))) (flet ((match-p (edge) (and (or (eq (edge-src edge) var1) (eq (edge-dst edge) var1)) (or (eq (edge-dst edge) var2) (eq (edge-src edge) var2))))) (find nil (constraint-edges graph) :test #'match-p))) (defmethod add-constraint ((graph constraint-graph) var constraint bindings) (unless (find-constraint-variable graph var) (make-instance 'constraint-variable :class (get-var-class bindings var) (push constraint (constraint-variables (find-constraint-variable graph var)))))) (defclass constraint-variable () ((name :accessor variable-name :initarg :name) (class :accessor variable-class :initarg :class) (constraints :accessor variable-constraints :initarg :constraints :initform nil))) (defclass edge () ((src :accessor edge-src :initarg :src) (dst :accessor edge-dst :initarg :dst) (constraint :accessor destination-constraint :initarg :constraint))) (defclass constraint () ((class :accessor constraint-class :initarg :class) (fn :accessor constraint-fn :initarg :test-fn :documentation "Predicate accepting an instance and returns whether it was accepted (t) or rejected (nil)") (expr :accessor constraint-expr :initarg :test-expr :documentation "Predicate expression for inline expansion"))) (defclass value-constraint (constraint) ((slot :accessor constraint-slot :initarg :slot :initform nil) (indexed-p :accessor indexed-p :initarg :indexed-p :initform nil) (index-type :accessor index-type :initarg :type :initform t) (range-p :accessor range-p :initarg :range-p :initform nil) (value :accessor constraint-value :initarg :value))) (defmethod initialize-index-info ((c value-constraint)) (when (constraint-slot c) (let ((idx (find-inverted-index (constraint-class c) (constraint-slot c) :null-on-fail t))) (when idx (setf (indexed-p c) t))))) (defclass range-constraint (constraint) ((range :accessor constraint-range :initarg :range))) (defclass and-constraint (constraint) ((constraints :accessor constraints :initarg :constraints))) (defclass or-constraint (constraint) ()) (defclass xor-constraint (constraint) ()) ;; ;; Constraint patterns for parsing ;; (defvar *constraint-dictionary* '((= parse-numeric) (< parse-numeric range) (> parse-numeric range) (>= parse-numeric range) (<= parse-numeric range) (string= parse-string) (string< parse-string range) (string> parse-string range) (string>= parse-string range) (string<= parse-string range) (member parse-member) (fn parse-function) (between parse-range) (or parse-or) (and parse-and) (eq parse-equiv))) (defun parse-constraint (expr bindings graph) (let ((op (first expr))) (multiple-value-bind (var constraint) (funcall (symbol-function (second (assoc op *constraint-dictionary*))) expr binding) (add-constraint graph var constraint bindings)))) (defun parse-numeric (expr bindings) (destructuring-bind (rel (slot var) value) expr (assert (numberp value)) (values var (make-instance 'value-constraint :slot slot :range-p nil :class (binding-class var) :value value :expr `((inst) (,rel (slot-value inst ,slot) ,value)))))) ;; ;; Bindings ;; (defun make-constraint-bindings () (make-hash-table :test #'equal)) (defun add-binding (name rec bindings) (setf (gethash name bindings) rec)) (defun get-binding (name bindings) (gethash name bindings)) (defun make-binding (type name) (list type name)) (defun binding-type (rec) (first rec)) (defun binding-target (rec) (second rec)) --- /project/elephant/cvsroot/elephant/src/contrib/eslick/query-sketch/query-algebra.lisp 2007/03/06 04:17:14 NONE +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/query-sketch/query-algebra.lisp 2007/03/06 04:17:14 1.1 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;; ;;; merge.lisp -- Implement efficient OID lists for merge-sort ;;; ;;; Copyright (c) 2007 by Ian S. Eslick ;;; <ieslick at common-lisp.net> ;;; ;;; Elephant users are granted the rights to distribute and use this software ;;; as governed by the terms of the Lisp Limited General Public License ;;; (http://opensource.franz.com/preamble.html) also known as the LLGPL. ;;; (in-package :elephant) --- /project/elephant/cvsroot/elephant/src/contrib/eslick/query-sketch/query-planner.lisp 2007/03/06 04:17:14 NONE +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/query-sketch/query-planner.lisp 2007/03/06 04:17:14 1.1 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;; ;;; query-planner.lisp -- Implement syntax for the elephant query engine ;;; ;;; Copyright (c) 2007 by Ian S. Eslick ;;; <ieslick at common-lisp.net> ;;; ;;; Elephant users are granted the rights to distribute and use this software ;;; as governed by the terms of the Lisp Limited General Public License ;;; (http://opensource.franz.com/preamble.html) also known as the LLGPL. ;;; (in-package :elephant) ;; ================================================================================ ;; Simple graph abstraction for keeping track of plan constraints ;; ================================================================================ (defclass edge () ((type :accessor edge-type :initarg :type :initform nil) (source :accessor edge-source :initarg :source :initform nil) (target :accessor edge-target :initarg :target :initform nil))) (defclass graph () ((edges :accessor edge-list :initarg :edges :initform nil) (nodes :accessor node-list :initarg :nodes :initform nil))) ;; ============================= ;; Query Plans ;; ============================= ;; These operations are the basis for estimating the cost ;; of different orderings of query operations. For simple ;; queries this is unnecessary, but for queries with constraints ;; between classes, this is very useful. (defclass query-op () ((set-size :accessor set-size :initarg :set-size :initform 0) (page-queries :accessor page-queries :initarg :page-queries :initform 0) (slot-queries :accessor slot-queries :initarg :slot-queries :initform 0))) (defclass instance-op () ((class :accessor op-class :initarg :cost) (constraints :accessor op-constraints :initarg :constraints))) (defclass index-op (instance-op) ((index :accessor query-index :initarg :cons))) (defclass scan-op (instance-op) () (:documentation "Scan the class applying the per-instance operator")) ;; intersection, unions (defclass merge-op (query-op) ((merge-type :accessor merge-type :initarg :type :initform :intersection))) (defun compute-constraint-graph (constraint-expr) "" (defun compute-query-plan (constraints) "Given a constraint graph, compute a query plan" --- /project/elephant/cvsroot/elephant/src/contrib/eslick/query-sketch/query-syntax.lisp 2007/03/06 04:17:14 NONE +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/query-sketch/query-syntax.lisp 2007/03/06 04:17:14 1.1 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;; ;;; query-syntax.lisp -- Implement syntax for the elephant query engine ;;; ;;; Copyright (c) 2007 by Ian S. Eslick ;;; <ieslick at common-lisp.net> ;;; ;;; Elephant users are granted the rights to distribute and use this software ;;; as governed by the terms of the Lisp Limited General Public License ;;; (http://opensource.franz.com/preamble.html) also known as the LLGPL. ;;; (in-package :elephant) ;; Want syntax such that we can recursively walk the definition and ;; produce a query graph that can be subject to algebraic optimization ;; How to handle nested queries? (string= (name (department inst)) "Marketing") ;; Name unique, no idx on dept inst := (class people) v1 := (lookup-select string= (name department) "marketing") s1 := (class-select ref= department people v1) s2 := (class-select < salary people 100k) s3 := (join s1 s2) s4 := (objects s3) ;; graph of instance sets and selections against them ;; ;; Constraint graph ;; (defclass constraint-graph () ((variables :accessor constraint-variables :initarg :vars :initform nil) (edges :accessor constraint-edges :initarg :edges :initform nil))) (defmethod find-constraint-variable ((graph constraint-graph) var-name) (find var-name (constraint-variables graph) :test #'variable-name)) (defmethod find-constraint-edge ((graph constraint-graph) var1 var2) (when (symbolp var1) (setf var1 (find-constraint-variable graph var1))) (when (symbolp var2) (setf var2 (find-constraint-variable graph var2))) (flet ((match-p (edge) (and (or (eq (edge-src edge) var1) (eq (edge-dst edge) var1)) (or (eq (edge-dst edge) var2) (eq (edge-src edge) var2))))) (find nil (constraint-edges graph) :test #'match-p))) (defmethod add-constraint ((graph constraint-graph) var constraint bindings) (unless (find-constraint-variable graph var) (make-instance 'constraint-variable :class (get-var-class bindings var) (push constraint (constraint-variables (find-constraint-variable graph var))) (defclass constraint-variable () ((name :accessor variable-name :initarg :name) (class :accessor variable-class :initarg :class) (constraints :accessor variable-constraints :initarg :constraints :initform nil))) (defclass edge () ((src :accessor edge-src :initarg :src) (dst :accessor edge-dst :initarg :dst) (constraint :accessor destination-constraint :initarg :constraint))) (defclass constraint () ((class :accessor constraint-class :initarg :class) (fn :accessor constraint-fn :initarg :test-fn :documentation "Predicate accepting an instance and returns whether it was accepted (t) or rejected (nil)") (expr :accessor constraint-expr :initarg :test-expr :documentation "Predicate expression for inline expansion"))) (defclass value-constraint (constraint) ((slot :accessor constraint-slot :initarg :slot :initform nil) (indexed-p :accessor indexed-p :initarg :indexed-p :initform nil) (index-type :accessor index-type :initarg :type :initform t) (range-p :accessor range-p :initarg :range-p :initform nil) (value :accessor constraint-value :initarg :value))) (defmethod initialize-index-info ((c value-constraint)) (when (constraint-slot c) (let ((idx (find-inverted-index (constraint-class c) (constraint-slot c) :null-on-fail t))) (when idx (setf (indexed-p c) t))))) (defclass range-constraint (constraint) ((range :accessor constraint-range :initarg :range))) (defclass and-constraint (constraint) ((constraints :accessor constraints :initarg :constraints))) (defclass or-constraint (constraint) ()) (defclass xor-constraint (constraint) ()) ;; ;; Constraint patterns for parsing ;; (defvar *constraint-dictionary* '((= parse-numeric) (< parse-numeric range) (> parse-numeric range) (>= parse-numeric range) (<= parse-numeric range) (string= parse-string) (string< parse-string range) (string> parse-string range) (string>= parse-string range) (string<= parse-string range) (member parse-member) (fn parse-function) (between parse-range) (or parse-or) (and parse-and) (eq parse-equiv))) (defun parse-constraint (expr bindings graph) (let ((op (first expr))) (multiple-value-bind (var constraint) (funcall (symbol-function (second (assoc op *constraint-dictionary*))) expr binding) (add-constraint graph var constraint bindings)))) (defun parse-numeric (expr bindings) (destructuring-bind (rel (slot var) value) expr (assert (numberp value)) (values var (make-instance 'value-constraint :slot slot :range-p nil :class (binding-class var) :value value :expr `((inst) (,rel (slot-value inst ,slot) ,value)))))) ;; ;; Bindings ;; (defun make-constraint-bindings () (make-hash-table :test #'equal)) (defun add-binding (name rec bindings) (setf (gethash name bindings) rec)) (defun get-binding (name bindings) (gethash name bindings)) (defun make-binding (type name) (list type name)) (defun binding-type (rec) (first rec)) (defun binding-target (rec) (second rec)) --- /project/elephant/cvsroot/elephant/src/contrib/eslick/query-sketch/scratch.lisp 2007/03/06 04:17:14 NONE +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/query-sketch/scratch.lisp 2007/03/06 04:17:14 1.1 ;; ;; Constraint definitions ;; ;; A constraint is an expression that requires the value of an object slot ;; to be one or more values or a reference to an object satisfying a constraint. ;; The object slot reference and the value slot reference can be complex. ;; (defvar *constraint-definitions* (make-hash-table :size 40)) (defmacro define-constraint (name &body body) `(progn (push ,(generate-constraint-pattern body) (gethash ',name *constraint-dispatch*)))) [276 lines skipped]

1 0

[elephant-cvs] CVS elephant/src/contrib/eslick/query-sketch
by ieslick 06 Mar '07

06 Mar '07

Update of /project/elephant/cvsroot/elephant/src/contrib/eslick/query-sketch In directory clnet:/tmp/cvs-serv27401/query-sketch Log Message: Directory /project/elephant/cvsroot/elephant/src/contrib/eslick/query-sketch added to the repository

1 0

[elephant-cvs] CVS elephant/src/elephant
by ieslick 06 Mar '07

06 Mar '07

Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv27096/elephant Modified Files: collections.lisp package.lisp Log Message: Placeholders and notes for query engine --- /project/elephant/cvsroot/elephant/src/elephant/collections.lisp 2007/02/20 20:03:45 1.11 +++ /project/elephant/cvsroot/elephant/src/elephant/collections.lisp 2007/03/06 04:15:27 1.12 @@ -164,6 +164,11 @@ (defgeneric make-cursor (bt) (:documentation "Construct a cursor for traversing BTrees.")) +(defgeneric make-simple-cursor (bt) + (:documentation "Allow users to walk secondary indices and only + get back primary keys rather than associated + primary values")) + (defgeneric cursor-close (cursor) (:documentation "Close the cursor. Make sure to close cursors before the --- /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/02/26 19:12:18 1.21 +++ /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/03/06 04:15:27 1.22 @@ -73,7 +73,7 @@ #:lookup-persistent-symbol-id #:int-byte-spec - #:cursor #:secondary-cursor #:make-cursor + #:cursor #:secondary-cursor #:make-cursor #:make-simple-cursor #:cursor-close #:cursor-init #:cursor-duplicate #:cursor-current #:cursor-first #:cursor-last #:cursor-next #:cursor-next-dup

1 0

[elephant-cvs] CVS elephant/src/query
by ieslick 06 Mar '07

06 Mar '07

Update of /project/elephant/cvsroot/elephant/src/query In directory clnet:/tmp/cvs-serv27096/query Added Files: algebra.lisp compile.lisp execute.lisp merge.lisp planning.lisp query.lisp syntax.lisp Log Message: Placeholders and notes for query engine --- /project/elephant/cvsroot/elephant/src/query/algebra.lisp 2007/03/06 04:15:27 NONE +++ /project/elephant/cvsroot/elephant/src/query/algebra.lisp 2007/03/06 04:15:27 1.1 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;; ;;; query.lisp -- Implement syntax for the elephant query engine ;;; ;;; Copyright (c) 2007 by Ian S. Eslick ;;; <ieslick at common-lisp.net> ;;; ;;; Elephant users are granted the rights to distribute and use this software ;;; as governed by the terms of the Lisp Limited General Public License ;;; (http://opensource.franz.com/preamble.html) also known as the LLGPL. ;;; (in-package :elephant) ;; ;; Relational algebra ;; (defparameter *relation-algebra-grammar* '((select <op> <attr> <attr or value> <nset>) (project <op> <attr-list> <nset>) (rename <attr> <attr> <nset>) (union <nset> <nset>) (intersection <nset> <nset>) (difference <nset> <nset>) (divide <nset> <nset>) (natural-join <attr> <nset> <attr> <nset>) (theta-join op <attr> <nset> <attr> <nset>) (semi-join <attr> <nset> <attr> <nset>) (anti-join <attr> <nset> <attr> <nset>))) ;; ;; Theorems ;; ;; (select op <attr> <nset>) = (select op <attr> (select op <attr> <nset>)) ;; idempotence ;; (select (and op1 op2) <attr> <nset>) = (select op1 <attr> (select op2 <attr> <nset>)) ;; commutivity ;; (select (or op1 op2) <attr> <nset>) = (union (select op1 <attr> <nset>) (select op1 <attr> <nset>)) ;; commutivity ;; (select op <attr1> <value> (union <nset1> <nset2>)) = (union (select op <attr1> <value> <nset1>) (select ...)) ;; distributivity ;; (select opA (intersection <nset1> <nset2>)) = (intersection <nset1> (select opA <nset2>))) ;; distributivity ;; (select opA (intersection <nset1> <nset2>)) = (intersection (select opA <nset1>) <nset2>) ;; (select opA (intersection <nset1> <nset2>)) = (intersection (select opA <nset1>) (select opA <nset1>)) ;; ;; Optimize/Rewrite - reduce estimated set sizes ;; ;; Exercise theorems to perform certain heuristic optimizations (push selects through joins) --- /project/elephant/cvsroot/elephant/src/query/compile.lisp 2007/03/06 04:15:27 NONE +++ /project/elephant/cvsroot/elephant/src/query/compile.lisp 2007/03/06 04:15:27 1.1 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;; ;;; query.lisp -- Implement syntax for the elephant query engine ;;; ;;; Copyright (c) 2007 by Ian S. Eslick ;;; <ieslick at common-lisp.net> ;;; ;;; Elephant users are granted the rights to distribute and use this software ;;; as governed by the terms of the Lisp Limited General Public License ;;; (http://opensource.franz.com/preamble.html) also known as the LLGPL. ;;; (in-package :elephant) ;; ;; Compilation ;; ;; Inline execution operators using interpetive plan as template ;; as part of a macro operation --- /project/elephant/cvsroot/elephant/src/query/execute.lisp 2007/03/06 04:15:27 NONE +++ /project/elephant/cvsroot/elephant/src/query/execute.lisp 2007/03/06 04:15:27 1.1 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;; ;;; query.lisp -- Implement syntax for the elephant query engine ;;; ;;; Copyright (c) 2007 by Ian S. Eslick ;;; <ieslick at common-lisp.net> ;;; ;;; Elephant users are granted the rights to distribute and use this software ;;; as governed by the terms of the Lisp Limited General Public License ;;; (http://opensource.franz.com/preamble.html) also known as the LLGPL. ;;; (in-package :elephant) ;; ;; Execution ;; ;; Generate interpretive template for execution of plan; execute so ;; internal map does not require more than one in-memory tuple at a time --- /project/elephant/cvsroot/elephant/src/query/merge.lisp 2007/03/06 04:15:27 NONE +++ /project/elephant/cvsroot/elephant/src/query/merge.lisp 2007/03/06 04:15:27 1.1 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;; ;;; merge.lisp -- Implement efficient OID lists for merge-sort ;;; ;;; Copyright (c) 2007 by Ian S. Eslick ;;; <ieslick at common-lisp.net> ;;; ;;; Elephant users are granted the rights to distribute and use this software ;;; as governed by the terms of the Lisp Limited General Public License ;;; (http://opensource.franz.com/preamble.html) also known as the LLGPL. ;;; (in-package :elephant) ;; ;; Quick and dirty oid-set abstraction ;; ;; Notes: ;; Add pool abstraction later to reuse tenured arrays ;; Use foreign memory? ;; Paged-to-disk approaches for when we blow out main memory? (defparameter *initial-set-size* 1000) (defparameter *set-growth-factor* 1.5) ;; ;; Create sets ;; (defun default-oid-set-elements () (make-array 1000 :element-type 'fixnum :initial-element 0 :fill-pointer 0 :adjustable t)) (defclass oid-set () ((elements :accessor set-elements :initarg :elements :initform (default-oid-set-elements)) (oid-order :accessor set-ordered-p :initarg :ordered-p :initform nil))) (defmethod push-oid (oid (set oid-set)) "If values are ascending, set is built in sorted order" (vector-push-extend oid (set-elements set) (floor (* *set-growth-factor* (length (set-elements set))))) (setf (set-ordered-p set) nil) oid) (defmethod pop-oid ((set oid-set)) (vector-pop (set-elements set))) ;; do we need remove/insert? ;; ;; Operations on sets ;; (defmethod sorted-elements ((set oid-set)) (if (set-ordered-p set) (set-elements set) (sort-set set))) (defmethod sort-set ((set oid-set)) "Sort the set elements and return the elements" (sort (set-elements set) #'<) (setf (set-ordered-p set) t) (set-elements set)) (defmethod sort-merge-sets ((set1 oid-set) (set2 oid-set) &optional (remove-duplicates t)) (let ((new-elements (merge '(array fixnum (*) :adjustable t :fill-pointer t) (sorted-elements set1) (sorted-elements set2) #'<))) (make-instance 'oid-set :elements (if remove-duplicates (delete-duplicates new-elements) new-elements) :ordered-p t))) (defmethod merge-sets ((set1 oid-set) (set2 oid-set) &optional (remove-duplicates t)) (let ((target (make-instance 'oid-set :ordered-p t))) (let ((elts1 (sorted-elements set1)) (elts2 (sorted-elements set2)) (offset1 0) (offset2 0) (last nil)) (loop until (or (= offset1 (fill-pointer elts1)) (= offset2 (fill-pointer elts2))) do (let ((elt1 (aref elts1 offset1)) (elt2 (aref elts2 offset2))) (cond ((= elt1 elt2) (incf offset1) (incf offset2) (unless (and remove-duplicates (eq last elt1)) (push-oid elt1 target) (setf last elt1))) ((< elt1 elt2) (push-oid elt1 target) (incf offset1)) ((< elt2 elt1) (push-oid elt2 target) (incf offset2)))))) target)) (defmethod intersect-sets ((set1 oid-set) (set2 oid-set)) (let ((target (make-instance 'oid-set :ordered-p t))) (let ((elts1 (sorted-elements set1)) (elts2 (sorted-elements set2)) (offset1 0) (offset2 0)) (loop until (or (= offset1 (fill-pointer elts1)) (= offset2 (fill-pointer elts2))) do (let ((elt1 (aref elts1 offset1)) (elt2 (aref elts2 offset2))) (cond ((= elt1 elt2) (incf offset1) (incf offset2) (push-oid elt1 target)) ((< elt1 elt2) (incf offset1)) ((< elt2 elt1) (incf offset2)))))) target)) ;; ;; Test code ;; (defun push-random-oids (set amount &optional (max 1000)) (loop for i from 0 upto amount do (push-oid (random max) set)) set) --- /project/elephant/cvsroot/elephant/src/query/planning.lisp 2007/03/06 04:15:27 NONE +++ /project/elephant/cvsroot/elephant/src/query/planning.lisp 2007/03/06 04:15:27 1.1 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;; ;;; query.lisp -- Implement syntax for the elephant query engine ;;; ;;; Copyright (c) 2007 by Ian S. Eslick ;;; <ieslick at common-lisp.net> ;;; ;;; Elephant users are granted the rights to distribute and use this software ;;; as governed by the terms of the Lisp Limited General Public License ;;; (http://opensource.franz.com/preamble.html) also known as the LLGPL. ;;; (in-package :elephant) ;; ;; Planner ;; ;; Generate all possible access plans to O-relations ;; Generate all possible joins of O-relations ;; Organize into equiv. classes ;; Evaluate the cost of options in equiv classes ;; Select best in each class ;; Roll cost upto whole join tree ;; Iterate each join tree to repeat with other joins ;; Do best-first through equiv classes? --- /project/elephant/cvsroot/elephant/src/query/query.lisp 2007/03/06 04:15:27 NONE +++ /project/elephant/cvsroot/elephant/src/query/query.lisp 2007/03/06 04:15:27 1.1 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;; ;;; query.lisp -- Implement syntax for the elephant query engine ;;; ;;; Copyright (c) 2007 by Ian S. Eslick ;;; <ieslick at common-lisp.net> ;;; ;;; Elephant users are granted the rights to distribute and use this software ;;; as governed by the terms of the Lisp Limited General Public License ;;; (http://opensource.franz.com/preamble.html) also known as the LLGPL. ;;; (in-package :elephant) ;; ;; User query API ;; (defmacro map-query (fn constraints) (let ((classes (constraint-expr-classes constraints)) (plan (compile-query-plan (parse-constraints constraints)))) `(map-query-plan ,fn ,plan))) ;;(defun map-constraints (fn classes plan) ;; (declare (dynamic-extent sc)) ;; ;; Wrappers and standard operations for map-constraints ;; (defmacro with-collector ((collector-var &key function init expr) &body body) "Instantiates a list collector to pass to a mapping function and the whole expression returns the result of the collector. For something other than list construction, expr can be used. If function is used, it is assumed to be the name of a function of two variables of two arguments where the first argument is the collector variable and the second is the current value being mapped. It should return the new value of the collector variable. Otherwise it is an expression containing a followed by a function body has the form of an flet entry with one parameter (name (arg) body). Init is the initial value of the result variable" (with-gensyms (result-var elt) `(let ((,result-var ,init)) (flet ((,collector-var ,@(cond ((and (null expr) (null function)) `((,elt) (push ,elt ,result-var))) (function `((,elt) (setf ,result-var (funcall ,function ,result-var ,elt)))) (expr (multiple-value-bind (arg &body body) expr `((,arg) ,@body)))))) (declare (dynamic-extent ,collector-var)) ,@body)))) --- /project/elephant/cvsroot/elephant/src/query/syntax.lisp 2007/03/06 04:15:27 NONE +++ /project/elephant/cvsroot/elephant/src/query/syntax.lisp 2007/03/06 04:15:27 1.1 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;; ;;; syntax.lisp -- Implement syntax for the elephant query engine ;;; ;;; Copyright (c) 2007 by Ian S. Eslick ;;; <ieslick at common-lisp.net> ;;; ;;; Elephant users are granted the rights to distribute and use this software ;;; as governed by the terms of the Lisp Limited General Public License ;;; (http://opensource.franz.com/preamble.html) also known as the LLGPL. ;;; (in-package :elephant) ;; ;; Operations and aggregators ;; (defvar *legal-operators* '(= /= < > <= >= string= string/= string< string> string>= string<= string-equalp string-not-equal string-lessp string-not-lessp string-greaterp string-not-greaterp map member type-p subtype-p)) (defun legal-operator-p (op) (member op *legal-operators*)) (defparameter *legal-aggregation-operators* '(and or xor)) (defun aggregation-operator-p (atom) (member op *legal-aggregation-operators*)) ;; ;; Parser ;; ;; Transform surface expressions to RA expressions with set object-relation closure property ;; (map-query fn (a b) ;; (:with ((mgr person) (job job))) ;; (:declare (type person emp) ;; (type project proj) ;; (type department (department person))) ;; (:constraints or :where ;; (between (start-date proj) (convert-date "July 5th 1996") (convert-date "November 1st 1996")) ;; (eq (project emp) proj) ;; (member (name (department emp)) '("Marketing" "Administration")) ;; (eq (supervisor emp) mgr) ;; (>= (slot salary mgr) 100000))) ;; Parser entry (defun get-clause (namelist clauses &optional error) (assert namelist) (setf namelist (mklist namelist)) (aif (assoc (car namelist) clauses) (cdr it) (if (null (cdr namelist)) (when error (error error)) (get-clause (cdr namelist) clauses error)))) (defun parse-query-syntax (query) (construct-ra-graph (parse-constraints (get-clause '(:constraints constraints :where where) query) (parse-declarations (get-clause '(:declare declare) query) (parse-targets (get-clause '(:with with) query) (make-relation-dictionary)))))) ;; Dictionary (defun make-relation-dictionary () (cons nil nil)) (defun add-set (name class stmt dictionary &optional annotations) (push (list name class stmt annotations) (car dictionary))) (defun lookup-set (name dict) (awhen (assoc name (car dict)) it)) (defun set-name (setrec) (first setrec)) (defun set-type (setrec) (second setrec)) (defun set-statement (setrec) (third setrec)) [145 lines skipped]

1 0

[elephant-cvs] CVS elephant/src/utils
by ieslick 06 Mar '07

06 Mar '07

Update of /project/elephant/cvsroot/elephant/src/utils In directory clnet:/tmp/cvs-serv27096/utils Modified Files: convenience.lisp package.lisp Log Message: Placeholders and notes for query engine --- /project/elephant/cvsroot/elephant/src/utils/convenience.lisp 2007/03/03 17:25:00 1.4 +++ /project/elephant/cvsroot/elephant/src/utils/convenience.lisp 2007/03/06 04:15:27 1.5 @@ -45,3 +45,27 @@ (let ((results (car list))) (dolist (elem (cdr list) results) (setq results (append results elem))))) + +(defmacro ifret (pred alt) + "If pred is non-null, return the value, otherwise return the alternate value" + (with-gensyms (res) + `(let ((,res ,pred)) + (if ,res ,res ,alt)))) + +(defmacro aif (pred default alt) + "Anaphoric if" + `(let ((it ,pred)) + (if it ,default ,alt))) + +(defmacro awhen (pred &rest body) + "Anaphoric when" + `(let ((it ,pred)) + (declare (ignorable it)) + (when it + ,@body))) + +(defun mklist (elts) + "Make sure the argument is a list or + make it a list if it's an atom" + (if (listp elts) elts (list elts))) + --- /project/elephant/cvsroot/elephant/src/utils/package.lisp 2007/02/24 14:52:00 1.4 +++ /project/elephant/cvsroot/elephant/src/utils/package.lisp 2007/03/06 04:15:27 1.5 @@ -32,4 +32,9 @@ #:do-subsets #:subsets #:remove-keywords - #:with-gensyms)) + #:with-gensyms + #:ifret + #:aif + #:awhen + #:mklist + #:it))

1 0

[elephant-cvs] CVS elephant/src/query
by ieslick 06 Mar '07

06 Mar '07

Update of /project/elephant/cvsroot/elephant/src/query In directory clnet:/tmp/cvs-serv26906/query Log Message: Directory /project/elephant/cvsroot/elephant/src/query added to the repository

1 0

[elephant-cvs] CVS elephant/src/db-bdb
by ieslick 04 Mar '07

04 Mar '07

Update of /project/elephant/cvsroot/elephant/src/db-bdb In directory clnet:/tmp/cvs-serv26542 Modified Files: bdb-transactions.lisp Log Message: Fixed bdb execute transations to properly return multiple values --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-transactions.lisp 2007/02/20 19:12:58 1.10 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-transactions.lisp 2007/03/04 20:22:47 1.11 @@ -40,21 +40,22 @@ :txn-sync txn-sync)))) (declare (type pointer-void txn)) (let ((result - (let ((*current-transaction* (make-transaction-record sc txn)) - (*store-controller* sc)) - (declare (special *current-transaction* *store-controller*)) - (catch 'transaction - (unwind-protect - (multiple-value-prog1 - (funcall txn-fn) - (db-transaction-commit txn - :txn-nosync txn-nosync - :txn-sync txn-sync) - (setq success t)) - (unless success - (db-transaction-abort txn))))))) + (multiple-value-list + (let ((*current-transaction* (make-transaction-record sc txn)) + (*store-controller* sc)) + (declare (special *current-transaction* *store-controller*)) + (catch 'transaction + (unwind-protect + (multiple-value-prog1 + (funcall txn-fn) + (db-transaction-commit txn + :txn-nosync txn-nosync + :txn-sync txn-sync) + (setq success t)) + (unless success + (db-transaction-abort txn)))))))) (unless (and (eq result txn) (not success)) - (return result)))) + (return (values-list result))))) finally (error "Too many retries in transaction")))) (defmethod controller-start-transaction ((sc bdb-store-controller)

1 0

[elephant-cvs] CVS elephant/tests
by ieslick 03 Mar '07

03 Mar '07

Update of /project/elephant/cvsroot/elephant/tests In directory clnet:/tmp/cvs-serv18095/tests Modified Files: testindexing.lisp Log Message: Fixes for Win32 allegro build; lispwork builds but fails to run; new test of :index class keyword which fails --- /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2007/02/26 19:55:13 1.31 +++ /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2007/03/03 17:25:01 1.32 @@ -102,6 +102,20 @@ )) 3 2 1 t 3) +(deftest indexing-class-opt + (progn + (when (class-indexedp-by-name 'idx-cslot) + (disable-class-indexing 'idx-cslot :errorp nil) + (setf (find-class 'idx-cslot) nil)) + + (defclass idx-cslot () + ((slot1 :initarg :slot1 :initform 0 :accessor slot1)) + (:metaclass persistent-metaclass :index t)) + + (values (class-indexedp-by-name 'idx-cslot))) + t) + + ;; test inherited slots (deftest indexing-inherit (progn

1 0

[elephant-cvs] CVS elephant/src/memutil
by ieslick 03 Mar '07

03 Mar '07

Update of /project/elephant/cvsroot/elephant/src/memutil In directory clnet:/tmp/cvs-serv18095/src/memutil Modified Files: memutil.lisp Log Message: Fixes for Win32 allegro build; lispwork builds but fails to run; new test of :index class keyword which fails --- /project/elephant/cvsroot/elephant/src/memutil/memutil.lisp 2007/02/26 19:12:19 1.24 +++ /project/elephant/cvsroot/elephant/src/memutil/memutil.lisp 2007/03/03 17:24:59 1.25 @@ -828,12 +828,13 @@ ;; This code is an attempt to allow compilation under bothe SBCL 8 and SBCL 9. ;; Thanks to Juho Snellman for this idiom. (eval-when (:compile-toplevel) - #+(and sbcl sb-unicode) (defun new-style-copy-p () + #+(and sbcl sb-unicode) (if (find-symbol "COPY-UB8-FROM-SYSTEM-AREA" "SB-KERNEL") '(:and) - '(:or))) - ) + '(:or)) + #-(and sbcl sb-unicode) + t)) (defun buffer-read-ucs1-string (bs byte-length) "Read a UCS1 string."

1 0