cl-2sql

commit 6ed211c0fc72b6bf3f6f732fddf0664bf1b93efb
parent b249207fe33654e4b28a04c0b59783c3f203a214
Author: Tomas Hlavaty <tom@logand.com>
Date:   Mon,  1 Aug 2011 22:08:10 +0200

qvars and qchunks introduced

Diffstat:
M
core.lisp
 | 
52
++++++++++++++++++++++++++--------------------------
M
macros.lisp
 | 
8
++++----
M
packages.lisp
 | 
6
+++++-

3 files changed, 35 insertions(+), 31 deletions(-)
diff --git a/core.lisp b/core.lisp
@@ -10,7 +10,7 @@
           (split-sequence:split-sequence #\. (symbol-name x))))
 
 (defun 2sql (form stream &optional (princ-symbol 'princ-symbol))
-  (let (lvars lforms)
+  (let (qvars qchunks)
     (labels ((rec (x)
                (if (atom x)
                    (etypecase x
@@ -19,11 +19,11 @@
                      (symbol (funcall princ-symbol x stream))
                      (integer (princ x stream)))
                    (ecase (car x)
-                     (:lvar
-                      (push (cdr x) lvars)
-                      (format stream ":~d" (length lvars)))
-                     (:lform
-                      (push (cdr x) lforms)
+                     (:qvar
+                      (push (cdr x) qvars)
+                      (format stream ":~d" (length qvars)))
+                     (:qchunk
+                      (push (cdr x) qchunks)
                       (princ "~a" stream))
                      (:par
                        (write-char #\( stream)
@@ -38,33 +38,33 @@
                              (rec x)
                              (incf i))))))))
       (rec form))
-    (values (nreverse lvars) (nreverse lforms))))
+    (values (nreverse qvars) (nreverse qchunks))))
 
 (defun 2sql-string (form &optional (princ-symbol 'princ-symbol))
-  (let (lvars lforms)
+  (let (qvars qchunks)
     (values
      (with-output-to-string (s)
-       (multiple-value-setq (lvars lforms)
+       (multiple-value-setq (qvars qchunks)
          (2sql (macroexpand form) s princ-symbol)))
-     lvars
-     lforms)))
+     qvars
+     qchunks)))
 
-(defun 2sql-lambda (form) ;; TODO lforms
-  (multiple-value-bind (str lvars lforms) (2sql-string form)
+(defmacro 2sql-query (form)
+  (multiple-value-bind (str qvars qchunks) (2sql-string form)
     (flet ((paste (x)
              (when x
                `(list ,@x))))
-      (let ((vars (mapcar #'car lvars)))
-        (values
-         `(lambda (,@vars)
-            (values
-             ,str
-             ,(paste vars)
-             ,(paste (mapcar #'cdr lvars))
-             #+nil
-             ,(paste (mapcar (lambda (x) `(funcall (lambda () ,@x))) lforms))))
-         vars)))))
+      `(values ;; execute
+        ,(if qchunks
+             `(format nil ,str ,@(mapcar (lambda (x) `(progn ,@x)) qchunks))
+             str)
+        ,(paste (mapcar #'car qvars))
+        ,(paste (mapcar #'cdr qvars))))))
 
-(defmacro 2sql-query (form)
-  (multiple-value-bind (fn vars) (2sql-lambda form)
-    `(funcall ,fn ,@vars)))
+(defmacro 2sql-lambda (args &body body)
+  `(lambda ,args
+     ,@(mapcar (lambda (q) `(2sql-query ,q)) body)))
+
+(defmacro define-2sql-function (name args &body body)
+  `(defun ,name ,args
+     ,@(mapcar (lambda (q) `(2sql-query ,q)) body)))
diff --git a/macros.lisp b/macros.lisp
@@ -174,11 +174,11 @@
 ;; order-by group-by having
 ;; min max avg sum
 
-(defsyntax lvar (name &optional type)
-  `(:lvar ,name ,@(cl:when type (cl:list type))))
+(defsyntax qvar (name &optional type)
+  `(:qvar ,name ,@(cl:when type (cl:list type))))
 
 ;; (defsyntax type (&body body)
 ;;   `(:type ,@body))
 
-(defsyntax lform (lform)
-  `(:lform ,lform))
+(defsyntax qchunk (qchunk)
+  `(:qchunk ,qchunk))
diff --git a/packages.lisp b/packages.lisp
@@ -2,7 +2,11 @@
 
 (defpackage 2sql
   (:use :cl)
-  (:export #:2sql #:2sql-string #:2sql-lambda))
+  (:export #:2sql
+           #:2sql-string
+           #:2sql-query
+           #:2sql-lambda
+           #:define-2sql-function))
 
 (defpackage 2sql-macros
   (:use)