Commit | Line | Data |
---|---|---|
e4ee1b86 DG |
1 | (in-package :parenscript) |
2 | ||
e4ee1b86 DG |
3 | (defun complex-js-expr? (expr) |
4 | (if (symbolp expr) | |
70c34384 DG |
5 | (or (find #\. (symbol-name expr)) |
6 | (not (eq (ps-macroexpand expr) expr))) | |
e4ee1b86 DG |
7 | (consp expr))) |
8 | ||
e4ee1b86 | 9 | (defvar *loop-keywords* |
a3939827 | 10 | '(:for :do :when :unless :initially :finally :first-time :last-time :while :until |
70c34384 | 11 | :from :to :below :downto :above :by :in :across :on :index := :then :sum :collect |
578e8565 | 12 | :count :minimize :maximize :into :repeat)) |
e4ee1b86 DG |
13 | |
14 | (defun normalize-loop-keywords (args) | |
512017c6 DG |
15 | (mapcar |
16 | (lambda (x) | |
17 | (or (find-if (lambda (key) (and (symbolp x) (equal (symbol-name x) (symbol-name key)))) | |
18 | *loop-keywords*) | |
19 | x)) | |
20 | args)) | |
e4ee1b86 | 21 | |
70c34384 DG |
22 | (defun reduce-function-symbol (sym) |
23 | (if (and (consp sym) (eq 'function (first sym))) | |
24 | (second sym) | |
25 | sym)) | |
26 | ||
2100b87b DG |
27 | (defun err (expected got) |
28 | (error "PS-LOOP expected ~a, got ~a." expected got)) | |
29 | ||
30 | (defclass loop-state () | |
31 | ((tokens :initarg :tokens :accessor tokens) | |
32 | (iterations :initform nil :accessor iterations) | |
33 | (prologue :initform nil :accessor prologue) | |
34 | (destructurings :initform nil :accessor destructurings) | |
35 | (initially :initform nil :accessor initially) | |
36 | (finally :initform nil :accessor finally) | |
37 | (during-first :initform nil :accessor during-first) | |
38 | (during-last :initform nil :accessor during-last) | |
39 | (default-accum-var :initform nil :accessor default-accum-var) | |
40 | (default-accum-kind :initform nil :accessor default-accum-kind) | |
41 | (body :initform nil :accessor body))) | |
42 | ||
43 | (defun nreverse-loop-state (state) | |
44 | (macrolet ((rev% (&rest accs) | |
45 | (cons 'progn (loop :for a :in accs :collect `(setf (,a state) (nreverse (,a state))))))) | |
46 | (rev% iterations prologue initially finally during-first during-last) | |
47 | (let ((body (nreverse (body state)))) | |
48 | (loop :for (list var) :in (destructurings state) :do | |
49 | (setf body `((destructuring-bind ,list ,var ,@body)))) | |
50 | (setf (body state) body))) | |
51 | state) | |
52 | ||
53 | (defun push-tokens (state toks) | |
54 | (setf (tokens state) (append toks (tokens state)))) | |
55 | ||
56 | (defun peek (state) | |
57 | (car (tokens state))) | |
58 | ||
59 | (defun eat (state &optional what tag) | |
60 | (case what | |
61 | (:if (when (eq (peek state) tag) | |
62 | (eat state) | |
63 | (eat state))) | |
64 | (:progn (cons 'progn (loop :collect (if (consp (peek state)) | |
65 | (eat state) | |
66 | (err "a compound form" (peek state))) | |
67 | :until (atom (peek state))))) | |
68 | (otherwise (let ((tok (pop (tokens state)))) | |
69 | (when (and (eq what :atom) (not (atom tok))) | |
70 | (err "an atom" tok)) | |
71 | tok)))) | |
72 | ||
73 | (defmacro with-local-var ((name expr state) &body body) | |
74 | (once-only (expr) | |
75 | `(let ((,name (aif (and (complex-js-expr? ,expr) (ps-gensym)) | |
76 | (progn (push (list 'var it ,expr) (prologue ,state)) | |
77 | it) | |
78 | ,expr))) | |
79 | ,@body))) | |
80 | ||
81 | (defun for-from (var state) | |
82 | (let ((start (eat state)) | |
83 | (op '+) | |
84 | (test-op nil) | |
85 | (by nil) | |
86 | (end nil)) | |
87 | (loop while (member (peek state) '(:to :below :downto :above :by)) do | |
88 | (let ((term (eat state))) | |
89 | (if (eq term :by) | |
90 | (setf by (eat state)) | |
91 | (setf op (case term ((:downto :above) '-) (otherwise '+)) | |
92 | test-op (case term (:to '>) (:below '>=) (:downto '<) (:above '<=)) | |
93 | end (eat state))))) | |
94 | (let ((test (when test-op | |
95 | (with-local-var (v end state) | |
96 | (list test-op var v))))) | |
97 | (push `(,var ,start (,op ,var ,(or by 1)) ,test) (iterations state))))) | |
98 | ||
99 | (defun for-= (var state) | |
100 | (let ((start (eat state)) | |
101 | (then (eat state :if :then))) | |
102 | (push (list var start (or then start) nil) (iterations state)))) | |
103 | ||
104 | (defun for-in (var state) | |
105 | (with-local-var (arr (eat state) state) | |
106 | (let ((index (or (eat state :if :index) (ps-gensym)))) | |
107 | (push-tokens state `(,index :from 0 :below (length ,arr) | |
108 | ,var := (aref ,arr ,index))) | |
109 | (for-clause state) | |
110 | (for-clause state)))) | |
111 | ||
112 | (defun for-on (var state) | |
113 | (with-local-var (arr (eat state) state) | |
114 | (let ((by (aif (eat state :if :by) | |
115 | `(,(reduce-function-symbol it) ,var) | |
116 | `((@ ,var :slice) 1)))) | |
117 | (push-tokens state `(,var := ,arr :then ,by)) | |
118 | (for-clause state) | |
119 | ;; set the end-test | |
120 | (setf (fourth (car (iterations state))) `(or (null ,var) (= (length ,var) 0)))))) | |
121 | ||
122 | (defun for-clause (state) | |
123 | (let* ((place (eat state)) | |
124 | (var (when (atom place) place)) | |
125 | (varlist (unless var place)) | |
126 | (term (eat state :atom))) | |
127 | (when varlist | |
128 | (when (eq term :from) | |
129 | (err "an atom after FROM" varlist)) | |
130 | (setf var (ps-gensym)) | |
131 | (push (list varlist var) (destructurings state))) | |
132 | (case term | |
133 | (:from (for-from var state)) | |
134 | (:= (for-= var state)) | |
135 | ((:in :across) (for-in var state)) | |
136 | (:on (for-on var state)) | |
137 | (otherwise (error "FOR ~s ~s is not valid in PS-LOOP." var term))))) | |
138 | ||
139 | (defun accumulate (kind term var state) | |
140 | (when (null var) | |
141 | (when (and (default-accum-kind state) (not (eq kind (default-accum-kind state)))) | |
142 | (error "PS-LOOP encountered illegal ~a: ~a was already declared, and there can only be one kind of default accumulation per loop." kind (default-accum-kind state))) | |
143 | (unless (default-accum-var state) | |
144 | (setf (default-accum-var state) | |
145 | (ps-gensym (case kind | |
146 | (:minimize 'min) | |
147 | (:maximize 'max) | |
148 | (t kind)))) | |
149 | (setf (default-accum-kind state) kind)) | |
150 | (setf var (default-accum-var state))) | |
151 | (let ((initial (case kind | |
152 | ((:sum :count) 0) | |
153 | ((:maximize :minimize) nil) | |
154 | (:collect '(array))))) | |
155 | (pushnew `(var ,var ,initial) (prologue state) :key #'second)) | |
156 | (case kind | |
157 | (:sum `(incf ,var ,term)) | |
158 | (:count `(unless (null ,term) (incf ,var))) | |
159 | (:minimize `(setf ,var (if (null ,var) ,term (min ,var ,term)))) | |
160 | (:maximize `(setf ,var (if (null ,var) ,term (max ,var ,term)))) | |
161 | (:collect `((@ ,var :push) ,term)))) | |
162 | ||
163 | (defun repeat-clause (state) | |
164 | (let ((index (ps-gensym))) | |
165 | (setf (tokens state) (append `(,index :from 0 :below ,(eat state)) (tokens state))) | |
166 | (for-clause state))) | |
167 | ||
168 | (defun body-clause (term state) | |
169 | (case term | |
170 | ((:when :unless) (list (intern (symbol-name term)) | |
171 | (eat state) | |
172 | (body-clause (eat state :atom) state))) | |
173 | ((:sum :collect :count :minimize :maximize) (accumulate term (eat state) (eat state :if :into) state)) | |
174 | (:do (eat state :progn)) | |
175 | (otherwise (err "a PS-LOOP keyword" term)))) | |
176 | ||
177 | (defun clause (state) | |
178 | (let ((term (eat state :atom))) | |
179 | (case term | |
180 | (:for (for-clause state)) | |
181 | (:repeat (repeat-clause state)) | |
182 | (:while (push `(unless ,(eat state) break) (body state))) | |
183 | (:until (push `(when ,(eat state) break) (body state))) | |
184 | (:initially (push (eat state :progn) (initially state))) | |
185 | (:finally (push (eat state :progn) (finally state))) | |
186 | (:first-time (push (eat state :progn) (during-first state))) | |
187 | (:last-time (push (eat state :progn) (during-last state))) | |
188 | (otherwise (push (body-clause term state) (body state)))))) | |
189 | ||
a3939827 | 190 | (defun parse-ps-loop (terms) |
2100b87b DG |
191 | (if (null terms) |
192 | (err "loop definition" nil) | |
193 | (let ((state (make-instance 'loop-state :tokens terms))) | |
194 | (loop :while (tokens state) :do (clause state)) | |
195 | (nreverse-loop-state state)))) | |
196 | ||
197 | (defun init-forms (loop) | |
198 | (mapcar (lambda (x) (subseq x 0 2)) (iterations loop))) | |
199 | ||
200 | (defun step-forms (loop) | |
201 | (mapcar (lambda (x) `(setf ,(first x) ,(third x))) (iterations loop))) | |
202 | ||
203 | (defun end-test (loop) | |
204 | (aif (loop :for (nil nil nil test) :in (iterations loop) :when test :collect test) | |
205 | (if (cdr it) | |
206 | (list 'not (cons 'or it)) | |
207 | (cons 'not it)) | |
208 | '(not nil))) | |
e4ee1b86 DG |
209 | |
210 | (defpsmacro loop (&rest args) | |
2100b87b DG |
211 | (let* ((loop (parse-ps-loop (normalize-loop-keywords args))) |
212 | (first-guard (and (during-first loop) (ps-gensym))) | |
213 | (last-guard (and (during-last loop) (ps-gensym)))) | |
214 | `(,@(if (default-accum-var loop) '(with-lambda ()) '(progn)) | |
215 | ,@(when (during-first loop) `((var ,first-guard t))) | |
216 | ,@(when (during-last loop) `((var ,last-guard nil))) | |
217 | ,@(prologue loop) | |
218 | ,@(initially loop) | |
219 | (for ,(init-forms loop) | |
220 | (,(end-test loop)) | |
221 | ,(step-forms loop) | |
222 | ,@(when (during-first loop) | |
223 | `((when ,first-guard | |
224 | ,@(during-first loop) | |
225 | (setf ,first-guard nil)))) | |
226 | ,@(body loop) | |
227 | ,@(when (during-last loop) | |
228 | `((setf ,last-guard t)))) | |
229 | ,@(when (during-last loop) | |
230 | `((when ,last-guard ,@(during-last loop)))) | |
231 | ,@(finally loop) | |
232 | ,@(when (default-accum-var loop) `((return ,(default-accum-var loop))))))) |