cl-2sql

Lisp to SQL compiler for Common Lisp
git clone https://logand.com/git/cl-2sql.git/
Log | Files | Refs | README | LICENSE

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

qvars and qchunks introduced

Diffstat:
Mcore.lisp | 52++++++++++++++++++++++++++--------------------------
Mmacros.lisp | 8++++----
Mpackages.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)