-
Notifications
You must be signed in to change notification settings - Fork 1
/
Copy pathutils.lisp
151 lines (137 loc) · 7.52 KB
/
utils.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
;;;; utils.lisp
(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)
(:documentation "Generator of generic entry iteration code over BODY
with LINE-VAR bound to current line string.
RESULT-VAR with optionally specified RESULT-TYPE and initial value
RESULT-INITFORM can be used to gather information over the whole iteration.
Number of parallel JOBS may be specified.
REDUCE-FN can be used to reduce results over 2 jobs."))
(defgeneric gen-select (spec field-list where print jobs)
(:documentation "Generate selection procedure for FIELD-LIST from SPEC db with WHERE filter.
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*)
,(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 field-list 'line)))))
(print
(alexandria:with-gensyms (reduce-print)
`(flet ((,reduce-print (vec1 vec2)
(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 field-list 'line 'result)))
:reduce-fn reduce-print :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))))))))
(t (gen-do-lines spec 'line
`((when ,(or (gen-where where 'line spec) t)
,(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)))))))))
(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)))
(defun gen-print-selection (fields line-var &optional offset-var)
"Unroll selected FIELDS' print statements.
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 across fields
collect '(write-char #\|)
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 line across ,res-var
do (locally (declare (type (simple-array simple-base-string (,field-count)) line))
,@(loop for i fixnum from 0 below field-count
collect '(write-char #\|)
collect `(write-string (aref line ,i))))
(write-char #\|)
(terpri)))
(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*)
,(gen-do-lines spec 'line
;; if where is empty, condition is considered always satisfied
`((when ,(or (gen-where where 'line spec) t)
(incf result)))
:reduce-fn '+ :jobs jobs
:result-var 'result :result-initform 0 :result-type 'fixnum)))
(declaim (inline append-vec)
(type (function ((vector (simple-array simple-base-string))
(vector (simple-array simple-base-string)))
(vector (simple-array simple-base-string)))
append-vec))
(defun append-vec (vec1 vec2)
"Append VEC2 to the end of VEC1."
(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)))