From af1f3a500cdae122530820952bb0a80d38f3b5f9 Mon Sep 17 00:00:00 2001 From: Andrey Kotlarski Date: Tue, 11 Sep 2018 02:20:16 +0300 Subject: [PATCH] Treat empty selection as select all and various refactorings. --- README.org | 8 ++-- fdbq.lisp | 12 ++++-- spec.lisp | 54 +++++++++++++++----------- storage-file.lisp | 58 +++++---------------------- utils.lisp | 99 ++++++++++++++++++++++++++++++----------------- 5 files changed, 115 insertions(+), 116 deletions(-) diff --git a/README.org b/README.org index 56ce44a..ce09d6c 100644 --- a/README.org +++ b/README.org @@ -68,9 +68,8 @@ Here's what has to be done: - implement appropriate *gen-do-lines* method over this new spec class -That is the minimum. You'll have to see if the default -implementations of *gen-select*, *gen-print-selection*, -*gen-list-selection* and *gen-cnt* suit your *gen-do-lines* +That is the minimum. You'll have to check if the default +implementations of *gen-select* and *gen-cnt* suit your *gen-do-lines* implementation. The default implementations expect fully populated string line. @@ -91,7 +90,8 @@ operations. Here's what's available: - *gen-where* translates WHERE tree to concrete code; it's meant to be used within the body of *gen-do-lines* -Look at *gen-select* for an example. +Look at *gen-cnt* for a simple example or *gen-select* for a more +complex one. * Future TODO diff --git a/fdbq.lisp b/fdbq.lisp index c69912f..adb318a 100644 --- a/fdbq.lisp +++ b/fdbq.lisp @@ -4,17 +4,21 @@ (defun select* (field-list db &key where print (jobs 1)) "Select FIELD-LIST from DB with WHERE filter." - (funcall (compile nil (gen-select (get-spec db) field-list where print jobs)))) + (let ((spec (get-spec db))) + (run-compiled (gen-select spec (get-select-fields spec field-list) + where print jobs)))) (defmacro select (field-list db &key where (print t) (jobs 1)) "Select FIELD-LIST from DB with WHERE filter." - `(funcall (compile nil ,(gen-select (get-spec db) field-list where print jobs)))) + `(run-compiled ,(let ((spec (get-spec db))) + (gen-select spec (get-select-fields spec field-list) + where print jobs)))) (defun cnt* (db &key where (jobs 1)) "Count FIELD-LIST from DB with WHERE filter." - (funcall (compile nil (gen-cnt (get-spec db) where jobs)))) + (run-compiled (gen-cnt (get-spec db) where jobs))) (defmacro cnt (db &key where (jobs 1)) "Count FIELD-LIST from DB with WHERE filter." - `(funcall (compile nil ,(gen-cnt (get-spec db) where jobs)))) + `(run-compiled ,(gen-cnt (get-spec db) where jobs))) diff --git a/spec.lisp b/spec.lisp index 8367723..32602f5 100644 --- a/spec.lisp +++ b/spec.lisp @@ -5,16 +5,18 @@ (defvar *dbs* (make-hash-table :test 'eq) "Registered DBs.") -(defclass db-field () - ((offset :type fixnum :reader db-field-offset :initarg :offset) - (size :type fixnum :reader db-field-size :initarg :size))) +(defclass spec-field () + ((name :type string :reader field-name :initarg :name) + (offset :type fixnum :reader field-offset :initarg :offset) + (size :type fixnum :reader field-size :initarg :size))) -(defclass operand-traits (db-field) +(defclass operand-traits (spec-field) ((filter :initarg :filter :initform nil))) (defclass spec () ((fields :type hash-table :accessor spec-fields :initform (make-hash-table :test 'eq)) + (field-list :type simple-array :accessor field-list) (size :type fixnum :accessor spec-size :initform 0)) (:documentation "DB specification base information. Contains named fields with offsets and sizes.")) @@ -22,28 +24,34 @@ Contains named fields with offsets and sizes.")) (defun get-spec (db) (gethash db *dbs*)) -(defun field-offset (field spec) - (db-field-offset (gethash field (spec-fields spec)))) - -(defun field-size (field spec) - (db-field-size (gethash field (spec-fields spec)))) - (defgeneric defspec (name type fields &key &allow-other-keys) (:documentation "Register db with NAME, TYPE and list of FIELDS. Additional ARGS depend on type.")) -(defun defspec-fields (spec fields) +(defun defspec-read-fields (spec fields) "Fill SPEC schema with FIELDS and inferred entry size." - (let ((spec-fields (spec-fields spec)) - (size 0)) - (dolist (field-spec fields) - (if (numberp field-spec) - (incf size field-spec) - (let ((field (make-instance 'db-field :offset size - :size (second field-spec)))) - (setf (gethash (first field-spec) spec-fields) field) - (incf size (db-field-size field))))) - (setf (spec-size spec) size))) + (let ((size 0) + (spec-fields (spec-fields spec))) + (setf (field-list spec) + (make-array (count-if #'consp fields) + :element-type 'spec-field + :initial-contents + (loop for field in fields + for field-size = (if (numberp field) + field + (second field)) + unless (numberp field) + collect (make-instance 'spec-field + :name (symbol-name (first field)) + :offset size :size field-size) + do (incf size field-size))) + (spec-size spec) size) + (let ((field-list (field-list spec))) + (loop for field in fields + with field-index = 0 + unless (numberp field) + do (setf (gethash (first field) spec-fields) (aref field-list field-index)) + (incf field-index))))) (defgeneric get-operand-traits (operand spec) (:documentation "Determine OPERAND dimensions according to SPEC.")) @@ -58,5 +66,5 @@ Additional ARGS depend on type.")) (defmethod get-operand-traits ((operand symbol) spec) "Get dimensions of field OPERAND according to SPEC." (let ((field (gethash operand (spec-fields spec)))) - (make-instance 'operand-traits :offset (db-field-offset field) - :size (db-field-size field)))) + (make-instance 'operand-traits :offset (field-offset field) + :size (field-size field)))) diff --git a/storage-file.lisp b/storage-file.lisp index 2e99f4e..856d959 100644 --- a/storage-file.lisp +++ b/storage-file.lisp @@ -11,33 +11,29 @@ (defmethod defspec (name (type (eql :file)) fields &key path) "Register file DB with NAME, list of FIELDS and file PATH." (let ((spec (make-instance 'spec-file :path (merge-pathnames path)))) - (defspec-fields spec fields) + (defspec-read-fields spec fields) (setf (gethash name *dbs*) spec))) (defmethod gen-select ((spec spec-file) field-list where print jobs) "Generate selection procedure for FIELD-LIST from DB with WHERE filter." - `(lambda () (declare (optimize (speed 3) (debug 0) (safety 0) (compilation-speed 0))) + `(lambda () (declare ,*optimize*) ,(cond ((and print (= 1 jobs)) (gen-do-lines spec 'line `((when ,(or (gen-where where 'line spec 'buffer 'offset) t) - ,(gen-print-selection spec field-list 'line - :buffer-var 'buffer - :offset-var 'offset))) + ,(gen-print-selection field-list 'buffer 'offset))) :buffer-var 'buffer :offset-var 'offset)) (print (alexandria:with-gensyms (reduce-print) `(flet ((,reduce-print (vec1 vec2) - (declare (optimize (speed 3) (debug 0) (safety 0) (compilation-speed 0)) + (declare ,*optimize* (type (vector (simple-array simple-base-string)) vec1 vec2)) ,(gen-print-select-results 'vec2 (length field-list)) vec1)) (declare (inline ,reduce-print)) ,(gen-do-lines spec 'line `((when ,(or (gen-where where 'line spec 'buffer 'offset) t) - ,(gen-list-selection spec field-list 'line 'result - :buffer-var 'buffer - :offset-var 'offset))) + ,(gen-list-selection field-list 'buffer 'result 'offset))) :buffer-var 'buffer :offset-var 'offset :reduce-fn reduce-print :jobs jobs :result-var 'result @@ -46,9 +42,7 @@ (,(length field-list)))))))) (t (gen-do-lines spec 'line `((when ,(or (gen-where where 'line spec 'buffer 'offset) t) - ,(gen-list-selection spec field-list 'line 'result - :buffer-var 'buffer - :offset-var 'offset))) + ,(gen-list-selection field-list 'buffer 'result 'offset))) :buffer-var 'buffer :offset-var 'offset :reduce-fn (if print 'reduce-print 'append-vec) :jobs jobs :result-var 'result @@ -56,43 +50,9 @@ :result-type `(vector (simple-array simple-base-string (,(length field-list))))))))) -(defmethod gen-print-selection ((spec spec-file) fields line-var - &key buffer-var offset-var) - "Unroll selected FIELDS' print statements. -BUFFER-VAR is symbol representing the db buffer. -OFFSET-VAR is symbol representing the current offset in the db buffer." - (declare (ignore line-var)) - `(progn - ,@(loop for field in fields ;collect print statements in list and splice them - collect '(write-char #\|) - collect `(loop for i fixnum from (+ ,offset-var - ,(field-offset field spec)) - below (+ ,offset-var ,(+ (field-offset field spec) - (field-size field spec))) - do (write-char (code-char (aref ,buffer-var i))))) - (format t "|~%"))) - -(defmethod gen-list-selection ((spec spec-file) fields line-var result - &key buffer-var offset-var) - "Unroll selected FIELDS' gather statements. -BUFFER-VAR is symbol representing the db buffer. -OFFSET-VAR is symbol representing the current offset in the db buffer." - (declare (ignore line-var)) - `(let ((res (make-array ,(length fields)))) - ,@(loop for field in fields - for i fixnum from 0 - collect `(setf (aref res ,i) - (let ((field-str (make-string ,(field-size field spec) - :element-type 'base-char))) - (loop for i fixnum from 0 below ,(field-size field spec) - for j fixnum from (+ ,offset-var ,(field-offset field spec)) - do (setf (aref field-str i) (code-char (aref ,buffer-var j)))) - field-str))) - (vector-push-extend res ,result))) - (defmethod gen-cnt ((spec spec-file) where jobs) "Generate count procedure over DB with WHERE filter over file." - `(lambda () (declare (optimize (speed 3) (debug 0) (safety 0) (compilation-speed 0))) + `(lambda () (declare ,*optimize*) ,(gen-do-lines spec 'line `((when ,(or (gen-where where 'line spec 'buffer 'offset) t) (incf result))) @@ -136,7 +96,7 @@ to raw byte buffer and current line offset within it respectively." (with-open-file (,ins ,(spec-path spec) :direction :input :element-type 'ascii:ub-char) (flet ((mapper (,job-id) - (declare (optimize (speed 3) (debug 0) (safety 0) (compilation-speed 0)) + (declare ,*optimize* (type fixnum ,job-id)) (let ((,line-var (aref ,line-array ,job-id)) (,result-var ,result-initform) @@ -246,7 +206,7 @@ to raw byte buffer and current line offset within it respectively." `((dynamic-extent ,line-array)) `((dynamic-extent ,buffer-array ,line-array)))) (flet ((mapper (,take-end ,job-id ,portion-id) - (declare (optimize (speed 3) (debug 0) (safety 0) (compilation-speed 0)) + (declare ,*optimize* (type fixnum ,take-end ,job-id) ,(if threading? `(type fixnum ,portion-id) diff --git a/utils.lisp b/utils.lisp index 1930236..2b65721 100644 --- a/utils.lisp +++ b/utils.lisp @@ -2,6 +2,9 @@ (in-package #:fdbq) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defvar *optimize* '(optimize (speed 3) (debug 0) (safety 0) (compilation-speed 0)))) + (defgeneric gen-do-lines (spec line-var body &key result-var result-type result-initform jobs reduce-fn &allow-other-keys) @@ -19,24 +22,24 @@ If PRINT is nil, return list of results otherwise pretty print selection.")) (defmethod gen-select (spec field-list where print jobs) "Generate selection procedure for FIELD-LIST from DB with WHERE filter. Default implementation using only string line." - `(lambda () (declare (optimize (speed 3) (debug 0) (safety 0) (compilation-speed 0))) + `(lambda () (declare ,*optimize*) ,(cond ((and print (= 1 jobs)) (gen-do-lines spec 'line ;; if where is empty, condition is considered always satisfied `((when ,(or (gen-where where 'line spec) t) - ,(gen-print-selection spec field-list 'line))))) + ,(gen-print-selection field-list 'line))))) (print (alexandria:with-gensyms (reduce-print) `(flet ((,reduce-print (vec1 vec2) - (declare (optimize (speed 3) (debug 0) (safety 0) (compilation-speed 0)) + (declare ,*optimize* (type (vector (simple-array simple-base-string)) vec1 vec2)) ,(gen-print-select-results 'vec2 (length field-list)) vec1)) (declare (inline ,reduce-print)) ,(gen-do-lines spec 'line `((when ,(or (gen-where where 'line spec) t) - ,(gen-list-selection spec field-list 'line 'result))) + ,(gen-list-selection field-list 'line 'result))) :reduce-fn reduce-print :jobs jobs :result-var 'result :result-initform '(make-array 0 :fill-pointer t :adjustable t) @@ -44,31 +47,68 @@ Default implementation using only string line." (,(length field-list)))))))) (t (gen-do-lines spec 'line `((when ,(or (gen-where where 'line spec) t) - ,(gen-list-selection spec field-list 'line 'result))) + ,(gen-list-selection field-list 'line 'result))) :reduce-fn 'append-vec :jobs jobs :result-var 'result :result-initform '(make-array 0 :fill-pointer t :adjustable t) :result-type `(vector (simple-array simple-base-string (,(length field-list))))))))) -(defgeneric gen-print-selection (spec fields line-var &key &allow-other-keys) - (:documentation "Generate printing of FIELDS selection over SPEC db code. -LINE-VAR is symbol representing the current line variable. -SPEC holds field offset details.")) +(defun get-select-fields (spec fields) + "Return array with field information for selected FIELDS. +If FIELDS is empty, return all SPEC fields." + (if fields + (let ((selection (make-array (length fields))) + (spec-fields (spec-fields spec))) + (loop for i fixnum from 0 below (length selection) + for field in fields + do (setf (aref selection i) (gethash field spec-fields))) + selection) + (field-list spec))) -(defmethod gen-print-selection (spec fields line-var &key &allow-other-keys) +(defun gen-print-selection (fields line-var &optional offset-var) "Unroll selected FIELDS' print statements. -LINE-VAR is symbol representing the current line variable. -SPEC holds field offset details." +LINE-VAR is symbol representing the current string line variable. +If OFFSET-VAR is non-nil, then it's a symbol representing the current offset within buffer, +LINE-VAR in this case is treated as the byte buffer." `(progn - ,@(loop for field in fields ;collect print statements in list and splice them + ,@(loop for field across fields collect '(write-char #\|) - collect `(write-string ,line-var nil - :start ,(field-offset field spec) - :end ,(+ (field-offset field spec) - (field-size field spec)))) + collect + (if offset-var + `(loop for i fixnum from (+ ,offset-var + ,(field-offset field)) + below (+ ,offset-var ,(+ (field-offset field) + (field-size field))) + do (write-char (code-char (aref ,line-var i)))) + `(write-string ,line-var nil + :start ,(field-offset field) + :end ,(+ (field-offset field) + (field-size field))))) (format t "|~%"))) +(defun gen-list-selection (fields line-var result &optional offset-var) + "Unroll selected FIELDS' gather-in RESULT statements. +LINE-VAR is symbol representing the current line variable. +If OFFSET-VAR is non-nil, then it's a symbol representing the current offset within buffer, +LINE-VAR in this case is treated as the byte buffer." + `(let ((res (make-array ,(length fields) + :element-type 'simple-base-string + :initial-contents + (list + ,@(loop for field across fields + collect (if offset-var + `(let ((field-str (make-string ,(field-size field) + :element-type 'base-char))) + (loop for i fixnum from 0 below ,(field-size field) + for j fixnum from (+ ,offset-var ,(field-offset field)) + do (setf (aref field-str i) (code-char (aref ,line-var j)))) + field-str) + `(subseq ,line-var ,(field-offset field) + :end ,(+ (field-offset field) + (field-size field))))))))) + (vector-push-extend res ,result))) + (defun gen-print-select-results (res-var field-count) "Pretty print list of results." `(loop for i fixnum from 0 below (length ,res-var) @@ -81,29 +121,12 @@ SPEC holds field offset details." `(format t ,fmt-str ,@(loop for i fixnum from 0 below field-count collect `(aref line ,i))))))) -(defgeneric gen-list-selection (spec fields line-var result &key &allow-other-keys) - (:documentation "Generate FIELDS selection to list over SPEC db code. -LINE-VAR is symbol representing the current line variable. -SPEC holds field offset details.")) - -(defmethod gen-list-selection (spec fields line-var result &key &allow-other-keys) - "Unroll selected FIELDS' gather statements. -LINE-VAR is symbol representing the current line variable. -SPEC holds field offset details." - `(let ((res (make-array ,(length fields) :element-type 'simple-base-string))) - ,@(loop for field in fields - for i fixnum from 0 - collect `(setf (aref res ,i) (subseq ,line-var ,(field-offset field spec) - :end ,(+ (field-offset field spec) - (field-size field spec))))) - (vector-push-extend res ,result))) - (defgeneric gen-cnt (spec where jobs) (:documentation "Generate count procedure for SPEC db with WHERE filter.")) (defmethod gen-cnt (spec where jobs) "Generate count procedure over DB with WHERE filter using string line." - `(lambda () (declare (optimize (speed 3) (debug 0) (safety 0) (compilation-speed 0))) + `(lambda () (declare ,*optimize*) ,(gen-do-lines spec 'line ;; if where is empty, condition is considered always satisfied `((when ,(or (gen-where where 'line spec) t) @@ -115,8 +138,12 @@ SPEC holds field offset details." (defun append-vec (vec1 vec2) "Append VEC2 to the end of VEC1." - (declare (optimize (speed 3) (debug 0) (safety 0) (compilation-speed 0)) + (declare #.*optimize* (type (vector (simple-array simple-base-string)) vec1 vec2)) (loop for el across vec2 do (vector-push-extend el vec1)) vec1) + +(defun run-compiled (proc) + "Compile and then run anonymous PROC." + (funcall (compile nil proc)))