Update of /project/elephant/cvsroot/elephant/src/query In directory clnet:/tmp/cvs-serv17545/src/query
Modified Files: syntax.lisp Log Message: A few details to go green on sbcl and acl on mac32
--- /project/elephant/cvsroot/elephant/src/query/syntax.lisp 2007/03/06 04:15:27 1.1 +++ /project/elephant/cvsroot/elephant/src/query/syntax.lisp 2007/03/08 21:29:53 1.2 @@ -72,13 +72,18 @@ ;; Dictionary
(defun make-relation-dictionary () - (cons nil nil)) + (cons nil 0))
(defun add-set (name class stmt dictionary &optional annotations) (push (list name class stmt annotations) (car dictionary)))
+(defun add-anonymous-set (class dict) + (let ((name (format nil "?class~A" (incf (cdr dict))))) + (add-set name class nil dict) + name)) + (defun lookup-set (name dict) - (awhen (assoc name (car dict)) + (awhen (assoc name (car dict) :test #'equal) it))
(defun set-name (setrec) @@ -94,6 +99,7 @@ (fourth setrec))
+ ;; Constraints
(defun parse-constraints (exprs dictionary) @@ -212,18 +218,68 @@ ,(reference-slot-or-value rec2)) ,(setname))))
-(defun make-join-statement (op rec1 rec2) +(defun make-join-statement (op rec1 rec2 dictionary) (cond ((and (simple-record-p rec1) (simple-record-p rec2)) - ;; An explicit join (assuming op is '=') `(theta-join ,op ,(reference-slot rec1) ,(reference-setname rec1) ,(reference-slot rec2) ,(reference-setname rec2))) ((and (nested-record-p rec1) (value-record-p rec2)) - `(theta-join ,op - ) + (make-nested-join op rec1 rec2)) ((and (value-record-p rec1) (nested-record-p rec1)) - ) + (make-nested-join op rec2 rec1 :reverse t)) + (t (error "Cannot construct complex join statement with ~A and ~A" rec1 rec2))))
+(defun make-nested-join (op rec-nest rec-value dict &key reverse) + (let* ((slot (reference-slot rec-nest)) + (sc-list (assign-join-types nil (reference-form rec-nest))) + (select `(select (,op ,@(when reverse + (list value slot) + (list slot value)) + ,(second (first sc-list)))))) + (nest-joins (rest sc-list) select))) + +(defun nest-joins (sc-list inner-stmt) + "Wraps a cascade of joins with anonymous classes" + (if (null sc-list) + inner-stmt + (let ((slot-class (first sc-list))) + (nest-joins (cdr sc-list) + `(join ,(first slot-class) ,(second slot-class) oid ,inner-stmt))))) + +(defun assign-join-types (accessor nested-form dict) + (if (simple-reference-form-p nested-form dict) + (list nested-form) + (let* ((list (assign-join-types (first nested-form) (second nested-form) dict)) + (type-form (first list))) + (cons (list accessor + (get-set-type (list (first type-form) (get-set-type (second type-form) dict)) dict)) + list)))) + +(defun get-set-type (form dict) + (let ((setrec (lookup-set form dict))) + (if setrec (set-type setrec) + (ifret (infer-type (first form) (second form)) nil)))) + + + +(defun infer-type (slot class) + "Determine the type " + + ((nil namerec) + (name person) + (manager department) + (department emp)) + + + +(= (name (manager (department emp))) "George") +(department emp) = foo +(manager foo) = foo1 +(name foo1) + +(join department emp oid + (project (oid) (join manager ?class1 oid + (project oid (select (= name "George") ?class2)))))
(defun reference-slot-or-value (rec) (cond ((value-record-p rec)