commit 8e6fcdc06534b8ee2799737360f9e89473ef1ea5
parent 8039911be01ca79fc2c87fc646e276646605ad0c
Author: Tomas Hlavaty <tom@logand.com>
Date: Sun, 7 Aug 2011 23:08:27 +0200
compiler simplified
Diffstat:
| M | backend.lisp | | | 10 | +++++----- |
| M | compiler.lisp | | | 151 | ++++++++++++++++++++++--------------------------------------------------------- |
| M | orm.lisp | | | 36 | ++++++++++++++++++------------------ |
| M | packages.lisp | | | 2 | +- |
| M | test.lisp | | | 60 | +++++++++++++++++++++++++++++++----------------------------- |
5 files changed, 96 insertions(+), 163 deletions(-)
diff --git a/backend.lisp b/backend.lisp
@@ -14,7 +14,7 @@
(*query-to-name* (make-hash-table :test #'equal))
(*name-seq* 0)
(2sql:*backend* :postgresql)
- (2sql:*delayed-query-cache* (make-hash-table :test #'eq)))
+ (2sql:*compiled-query-lambda-cache* (make-hash-table :test #'equal)))
(unwind-protect (funcall fn)
(cl-postgres:close-database *database*))))
@@ -32,7 +32,7 @@
(*query-to-name* (make-hash-table :test #'equal))
(*name-seq* 0)
(2sql:*backend* :sqlite)
- (2sql:*delayed-query-cache* (make-hash-table :test #'eq)))
+ (2sql:*compiled-query-lambda-cache* (make-hash-table :test #'equal)))
(unwind-protect (funcall fn)
(sqlite:disconnect *database*))))
@@ -63,9 +63,9 @@
(sqlite:execute-to-list *database* q)))))
;; good for development, let *backend* in with-database, leave
-;; *delayed-query-cache* nil, then queries dont get cached; then you
-;; can recompile queries inside with-database, e.g. during an error
-;; without closing a transaction for example
+;; *compiled-query-lambda-cache* nil, then queries dont get cached;
+;; then you can recompile queries inside with-database, e.g. during an
+;; error without closing a transaction for example
;; (setq 2sql:*backend* :postgresql)
;; (setq 2sql:*backend* :sqlite)
diff --git a/compiler.lisp b/compiler.lisp
@@ -4,128 +4,59 @@
(in-package :2sql)
-(defparameter *delayed-query-cache* nil)
+(defparameter *compiled-query-lambda-cache* nil) ;; equal form->fn
+
+(defun execute (q qvars) ;; to be redefined in user code
+ (values q qvars))
+
+(defmacro qmacroexpand (form)
+ `(funcall (lambda () (macroexpand ',form))))
(defun process-qchunk (x)
`(pure-form-to-string (macroexpand (funcall (lambda () ,@x)))))
-(defun execute (q qvars)
- (values q qvars))
+(defun make-query-lambda (args form)
+ `(lambda ,args
+ , (multiple-value-bind (str qvars qchunks) (to-string (macroexpand form))
+ `(execute
+ ,(if qchunks
+ `(format nil ,str ,@(mapcar 'process-qchunk qchunks))
+ str)
+ (list ,@(mapcar #'car qvars))))))
-;; manual or automatic qvars?
-#+nil
-(defmacro query (form &rest qvars &environment env) ;; qvars for delayed compilation
- (declare (ignorable env))
- (if *backend*
- (multiple-value-bind (str qvars qchunks) (to-string (macroexpand form))
- (flet ((paste (x)
- (when x
- `(list ,@x))))
- `(execute
- ,(if qchunks
- `(format nil ,str ,@(mapcar 'process-qchunk qchunks))
- str)
- (list ,@(mapcar #'car qvars)))))
- ;; delay compilation until backend is known
- (progn
- #+sbcl ;; TODO conditional
- (unless qvars
- (setq qvars (remove-duplicates (lexical-variables env))))
- `(funcall
- (lambda ,qvars
- (assert *backend*)
- ;; TODO eq cache compiled query?
- (funcall (let ((fn '(lambda ,qvars (query ,form))))
- (print (list :@@@ fn))
- (or (when *delayed-query-cache*
- (or (when (gethash fn *delayed-query-cache*)
- (print (list :@@@-reusing (gethash fn *delayed-query-cache*)))
- (gethash fn *delayed-query-cache*))
- (setf (gethash fn *delayed-query-cache*)
- (compile nil fn))))
- (compile nil fn)))
- ,@qvars)
- #+nil(funcall (compile nil `(lambda ,',qvars (query ,',form))) ,@qvars))
- ,@qvars))))
+;;(make-query-lambda '(a b) '(q:+ (q:qvar a) (q:qvar b)))
-#+nil
-(defmacro query1 (form &rest qvars)
- `(caar (query ,form ,@qvars)))
-
-(defmacro cache-delayed-query (form qvars)
- `(let ((fn '(lambda ,qvars (query ,form))))
- (print (list :@@@ fn))
- (or (when *delayed-query-cache*
- (or (when (gethash fn *delayed-query-cache*)
- (print (list :@@@-reusing (gethash fn *delayed-query-cache*)))
- (gethash fn *delayed-query-cache*))
- (setf (gethash fn *delayed-query-cache*) (compile nil fn))))
- (compile nil fn))))
-
-(defun when-backend-known (form qvars action env)
- (cond
- (*backend* `(,action ,form))
- (t ;; delay compilation until backend is known
- #+sbcl ;; TODO conditional
- (unless qvars
- (setq qvars (remove-duplicates (lexical-variables env))))
- `(funcall
- (lambda ,qvars
- (assert *backend*)
- (funcall (cache-delayed-query ,form ,qvars) ,@qvars))
- ,@qvars))))
-
-(defmacro execute-action (form)
- (multiple-value-bind (str qvars qchunks) (to-string (macroexpand form))
- (flet ((paste (x)
- (when x
- `(list ,@x))))
- `(execute
- ,(if qchunks
- `(format nil ,str ,@(mapcar 'process-qchunk qchunks))
- str)
- (list ,@(mapcar #'car qvars))))))
-
-(defmacro query (form &rest qvars &environment env)
- (when-backend-known form qvars 'execute-action env))
-
-(defmacro qmacroexpand (form &rest qvars &environment env)
- (when-backend-known form qvars 'macroexpand env))
-
-;;(qmacroexpand (q:true-value))
-
-(defun quoted-query (q &rest qvars) ;; TODO defmacro?
- (funcall (compile nil `(lambda () (query ,q ,@qvars))))) ;; TODO cache
+(defun compiled-query-lambda (args form)
+ (or (when *compiled-query-lambda-cache*
+ (or (gethash form *compiled-query-lambda-cache*)
+ (setf (gethash form *compiled-query-lambda-cache*)
+ (compile nil (make-query-lambda args form)))))
+ (compile nil (make-query-lambda args form))))
-(defmacro qlambda (args &body body)
- `(lambda ,args
- ,@(mapcar (lambda (q) `(query ,q ,@args)) body)))
+;;(compiled-query-lambda '(a b) '(q:+ (q:qvar a) (q:qvar b)))
-(defmacro qdefun (name args &body body) ;; rename to defqfun?
- `(defun ,name ,args
- ,@(mapcar (lambda (q) `(query ,q ,@args)) body)))
+(defmacro query (args form)
+ `(funcall (compiled-query-lambda ',args ,form) ,@args))
-(defmacro qlet (args &body body) ;; rename to query-let?
- `(flet ,(mapcar (lambda (x) `(,(car x) ,(cadr x) (query ,@(cddr x)))) args)
- ,@body))
+;;(let ((a 1) (b 2)) (query (a b) '(q:+ (q:qvar a) (q:qvar b))))
-;;; TODO lexical-variables for many lisps? what symbol-macrolet etc?
+(defun queries (args forms)
+ (mapcar (lambda (form) `(query ,args ',form)) forms))
-#+sbcl ;; http://common-lisp.net/project/bese/repos/arnesi_dev/src/lexenv.lisp
-(defmethod lexical-variables ((environment sb-kernel:lexenv))
- (loop
- for var-spec in (sb-c::lexenv-vars environment)
- when (and (atom (cdr var-spec))
- (not (and (typep (cdr var-spec) 'sb-c::lambda-var)
- (sb-c::lambda-var-ignorep (cdr var-spec)))))
- collect (car var-spec)))
+(defmacro qlambda (args &body body)
+ `(lambda ,args ,@(queries args body)))
-#+nil
-(defmacro xxx (&environment env)
- `(print ',(lexical-variables env)))
+(defmacro qdefun (name args &body body)
+ `(defun ,name ,args ,@(queries args body)))
-;;(xxx)
-;;(let (a) (let (a b) (xxx)))
+#+nil
+(defmacro qlet (bindings &body body)
+ `(flet ,(mapcar (lambda (x)
+ (print `(,(car x) ,(cadr x) ,@(queries (cadr x) (cddr x))))
+ `(,(car x) ,(cadr x) ,@(queries (cadr x) (cddr x))))
+ bindings)
+ ,@body))
-(defun qmap (fn q) ;; TODO optimize properly using cl-postgres
+#+nil
+(defun qmap (fn q) ;; TODO optimize properly using cl-postgres, move to backend?
(mapcar (lambda (x) (apply fn x)) q))
diff --git a/orm.lisp b/orm.lisp
@@ -50,14 +50,14 @@
(expt 2 +class-id-bit-size+)))
(defun setup-pclass (class-name)
- (2sql:quoted-query
- `(q:create-table t1
- (q:columns
- (q:column oid (q:integer-type) nil
- (oid-exp (q:qchunk (class-name-to-class-id ',class-name))))
- ,@(loop
- for (name type nullable initarg default) in (list-pslots class-name)
- collect `(q:column ,name ,type ,nullable ,default))))))
+ (2sql:query ()
+ `(q:create-table t1
+ (q:columns
+ (q:column oid (q:integer-type) nil
+ (oid-exp (q:qchunk (class-name-to-class-id ',class-name))))
+ ,@(loop
+ for (name type nullable initarg default) in (list-pslots class-name)
+ collect `(q:column ,name ,type ,nullable ,default))))))
(defun make-pinstance (class-name &rest args)
(multiple-value-bind (known unknown)
@@ -74,27 +74,27 @@
appending (list initarg value))
(loop
for (name . initarg) in (cons (cons 'oid :oid) unknown)
- for value in (car (2sql:quoted-query
- `(q:insert-into t1 ,(mapcar #'car known)
- (q:values ,@(mapcar #'caddr known))
- (q:returning ,(cons 'oid (mapcar #'car unknown))))))
+ for value in (car (2sql:query ()
+ `(q:insert-into t1 ,(mapcar #'car known)
+ (q:values ,@(mapcar #'caddr known))
+ (q:returning ,(cons 'oid (mapcar #'car unknown))))))
appending (list initarg value))))))
(defmacro with-tables (names &body body)
`(progn
(mapcar 'setup-pclass ',names)
(unwind-protect (progn ,@body)
- ,@(mapcar (lambda (x) `(2sql:query (q:drop-table ,x t t))) names))))
+ ,@(mapcar (lambda (x) `(2sql:query () '(q:drop-table ,x t t))) names))))
(trace 2sql:execute)
(2sql-backend:with-postgresql-connection ("pokus" "tomas" "test123" "localhost")
- (2sql:query (q:drop-sequence oid-seq t))
- (2sql:query (q:create-sequence oid-seq))
+ (2sql:query () '(q:drop-sequence oid-seq t))
+ (2sql:query () '(q:create-sequence oid-seq))
(with-tables (t1)
(make-pinstance 't1 :c1 1 :c2 2 :c3 3)
(make-pinstance 't1 :c1 1 :c2 2)
- #+nil(query (q:select :* (q:from t1)))
+ (2sql:query () '(q:select :* (q:from t1)))
#+nil(x-query (q:select ((x-instance t1)) (q:from t1)))))
@@ -105,10 +105,10 @@
;; remember stuff, run instance reconstructor at the end
`(funcall (compile nil `(lambda ()
(let (((*x-alias-to-table* (make-hash-table))))
- (query ,,form ,,@qvars)))))
+ (%query ,,form ,,@qvars)))))
#+nil
`(let* ((*x-alias-to-table* (make-hash-table))
- #+nil(x (macroexpand `(query ,,form ,,@qvars))))
+ #+nil(x (macroexpand `(%query ,,form ,,@qvars))))
;;x
))
diff --git a/packages.lisp b/packages.lisp
@@ -14,7 +14,7 @@
#:to-string
;; compiler
#:*backend*
- #:*delayed-query-cache*
+ #:*compiled-query-lambda-cache*
#:execute
#:query
#:qlambda
diff --git a/test.lisp b/test.lisp
@@ -181,8 +181,8 @@
-;; *delayed-query-cache* test
-(with-postgresql-connection ("pokus" "tomas" "test123" "localhost")
+;; *compiled-query-lambda-cache* test
+(2sql-backend:with-postgresql-connection ("pokus" "tomas" "test123" "localhost")
(let ((a 2))
;;(EXECUTE "SELECT |/ $1::INTEGER" (LIST A))
;;(funcall (compile nil (lambda (a) (query (q:select ((q:sqrt (q:qvar a :integer))))))) a)
@@ -190,23 +190,22 @@
(let ((q (qlambda (a)
(q:select ((q:sqrt (q:qvar a :integer)))))))
(funcall q a)
- (funcall q a))))
-
-;; automatic lexvars
-(with-postgresql-connection ("pokus" "tomas" "test123" "localhost")
- (let ((a 2))
- ;;(EXECUTE "SELECT |/ $1::INTEGER" (LIST A))
- ;;(funcall (compile nil (lambda (a) (query (q:select ((q:sqrt (q:qvar a :integer))))))) a)
- (query (q:select ((q:sqrt (q:qvar a :integer)))))))
+ (funcall q a)))) ;; reusing from *compiled-query-lambda-cache*
;; explicit lexvars
-(with-postgresql-connection ("pokus" "tomas" "test123" "localhost")
+(2sql-backend:with-postgresql-connection ("pokus" "tomas" "test123" "localhost")
(let ((a 2))
;;(EXECUTE "SELECT |/ $1::INTEGER" (LIST A))
;;(funcall (compile nil (lambda (a) (query (q:select ((q:sqrt (q:qvar a :integer))))))) a)
- (query (q:select ((q:sqrt (q:qvar a :integer)))) a)))
+ (query (a) '(q:select ((q:sqrt (q:qvar a :integer)))))
+ (query (a) '(q:select ((q:sqrt (q:qvar a :integer)))))))
+(qdefun foo1 (a)
+ (q:select ((q:sqrt (q:qvar a :integer)))))
+(2sql-backend:with-postgresql-connection ("pokus" "tomas" "test123" "localhost")
+ (foo1 1)
+ (foo1 2))
;; suppress-qvar
@@ -242,7 +241,7 @@
(q:select ((q:+ (q:qvar a :integer)
(q:suppress-qvar (q:qvar b :integer))
(q:qchunk (mul a b)))))))
- (list :first (q 1 2) :second (q 2 3)))))
+ #+nil(list :first (q 1 2) :second (q 2 3)))))
cl-postgres:to-sql-string function value->type? would be handy
@@ -363,25 +362,28 @@ bytea (vector (unsigned-byte 8))
;; WHERE ((relkind = 'r') and (nspname NOT IN ('pg_catalog', 'pg_toast'))
;; and pg_catalog.pg_table_is_visible(pg_class.oid)))"
-(with-sqlite-connection (":memory:")
- (query (q:create-table t1 (q:columns
- (q:column c1 (q:integer-type))
- (q:column c2 (q:integer-type) 314)
- (q:column c3 (q:boolean-type))
- (q:column c4 (q:varchar-type)))
- nil nil :fts3))
+(2sql-backend:with-sqlite-connection (":memory:")
+ (query ()
+ '(q:create-table t1 (q:columns
+ (q:column c1 (q:integer-type))
+ (q:column c2 (q:integer-type) 314)
+ (q:column c3 (q:boolean-type))
+ (q:column c4 (q:varchar-type)))
+ nil nil :fts3))
(let ((tt (2sql:qmacroexpand (q:true-value)))
(ff (2sql:qmacroexpand (q:false-value))))
(loop
for (a b c d) in `((11 12 ,tt "Ivan Ivanovic Ivanov")
(21 22 ,ff "Ivan Ovic"))
- do (query (q:insert-into t1 (c1 c2 c3 c4)
- (q:values (q:qvar a) (q:qvar b) (q:qvar c) (q:qvar d))))))
+ do (query (a b c d)
+ '(q:insert-into t1 (c1 c2 c3 c4)
+ (q:values (q:qvar a) (q:qvar b) (q:qvar c) (q:qvar d))))))
;; my sqlite version supports word and prefix search only
- (query (q:select :*
- (q:from t1)
- ;;(q:where (q:infix " MATCH " c4 "ivan"))
- (q:where (q:infix " MATCH " c4 "ov*"))
- ;;(q:where (q:infix " MATCH " c4 "*ov")) ;; doesnt work
- ;;(q:where (q:infix " MATCH " c4 "ivan AND ivanov"))
- )))
+ (query ()
+ '(q:select :*
+ (q:from t1)
+ ;;(q:where (q:infix " MATCH " c4 "ivan"))
+ (q:where (q:infix " MATCH " c4 "ov*"))
+ ;;(q:where (q:infix " MATCH " c4 "*ov")) ;; doesnt work
+ ;;(q:where (q:infix " MATCH " c4 "ivan AND ivanov"))
+ )))
