1 ;;;; -*- encoding:utf-8 -*-
3 ;;; Copyright 2009-2013 Daniel Gackle
4 ;;; Copyright 2009-2012 Vladimir Sedach
5 ;;; Copyright 2012, 2015 Boris Smilga
6 ;;; Copyright 2018 Neil Lindquist
7 ;;; Copyright 2019, Philipp Marek
8 ;;; Copyright 2019, Jason Miller
10 ;;; SPDX-License-Identifier: BSD-3-Clause
12 ;;; Redistribution and use in source and binary forms, with or
13 ;;; without modification, are permitted provided that the following
14 ;;; conditions are met:
16 ;;; 1. Redistributions of source code must retain the above copyright
17 ;;; notice, this list of conditions and the following disclaimer.
19 ;;; 2. Redistributions in binary form must reproduce the above
20 ;;; copyright notice, this list of conditions and the following
21 ;;; disclaimer in the documentation and/or other materials provided
22 ;;; with the distribution.
24 ;;; 3. Neither the name of the copyright holder nor the names of its
25 ;;; contributors may be used to endorse or promote products derived
26 ;;; from this software without specific prior written permission.
28 ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND
29 ;;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
30 ;;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
31 ;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
32 ;;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS
33 ;;; BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
34 ;;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
35 ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
36 ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
37 ;;; ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
38 ;;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
39 ;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
40 ;;; POSSIBILITY OF SUCH DAMAGE.
42 (in-package #:parenscript
)
43 (named-readtables:in-readtable
:parenscript
)
45 ;;; bind and bind* - macros used for destructuring bindings in PS LOOP
49 ((not (listp (cdr x
))) ; dotted list
50 (list (dot->rest
(car x
)) '&rest
(dot->rest
(cdr x
))))
51 (t (cons (dot->rest
(car x
)) (dot->rest
(cdr x
))))))
53 (defun property-bindings-p (x)
56 (or (keywordp y
) ; standalone property name
57 (and (consp y
) ; var name paired with property name
60 (not (keywordp (car y
)))
61 (keywordp (cadr y
)))))
64 (defun extract-bindings (x)
65 ;; returns a pair of destructuring bindings and property bindings
66 (cond ((atom x
) (list x nil
))
67 ((property-bindings-p x
)
68 (let ((var (ps-gensym)))
69 (list var
(list x var
))))
71 :for
(d p
) = (extract-bindings (car y
))
73 :when p
:append p
:into ps
74 :finally
(return (list ds ps
))))))
76 (defun property-bindings (bindings expr body
)
77 `(let ,(loop :for b
:in bindings
78 :for
(var p
) = (cond ((consp b
) b
) ; var name paired with property name
79 (t (list (intern (string b
)) b
))) ; make var from prop
80 :collect
`(,var
(@ ,expr
,p
)))
83 (defpsmacro bind
(bindings expr
&body body
)
84 (let ((bindings (dot->rest bindings
)))
85 (destructuring-bind (d p
)
86 (extract-bindings bindings
)
88 (or (= (length bindings
) 1)
89 (atom (ps-macroexpand expr
))))
90 (property-bindings bindings expr body
))
92 (with-ps-gensyms (var)
94 (bind ,bindings
,var
,@body
))))
96 `(destructuring-bind ,bindings
,expr
,@body
))
97 (t `(destructuring-bind ,d
,expr
98 (bind* ,p
,@body
)))))))
100 (defpsmacro bind
* (bindings &body body
)
101 (cond ((= (length bindings
) 2)
102 `(bind ,(car bindings
) ,(cadr bindings
) ,@body
))
103 (t `(bind ,(car bindings
) ,(cadr bindings
)
104 (bind* ,(cddr bindings
) ,@body
)))))
106 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
107 (defvar *loop-keywords
*
108 '(:named
:for
:repeat
:with
:while
:until
:initially
:finally
109 :from
:downfrom
:to
:below
:downto
:above
:by
:in
:across
:on
:= :then
110 :when
:unless
:if
:else
:end
:do
:doing
:return
111 :sum
:summing
:collect
:collecting
:append
:appending
:count
:counting
112 :minimize
:minimizing
:maximize
:maximizing
:map
:mapping
115 (defun as-keyword (key)
116 (cond ((not (symbolp key
)) key
)
118 (t (intern (symbol-name key
) :keyword
)))))
120 (defmacro loop-case
(key &body forms
)
121 (loop :for
(match . nil
) :in forms
122 :for keys
= (if (listp match
) match
(list match
)) :do
123 (loop :for k
:in keys
:do
124 (assert (member k
(append *loop-keywords
* '(t otherwise
)))
125 nil
"~a isn't a recognized loop keyword." k
)))
126 `(case (as-keyword ,key
) ,@forms
))
128 (defun err (expected got
)
129 (error "PS-LOOP expected ~a, got ~a." expected got
))
131 (defclass loop-state
()
132 ((tokens :initarg
:tokens
:accessor tokens
)
133 (name :initform nil
:accessor name
)
134 ;; A clause is either (:BODY FORM) or (:ITER PLACE INIT STEP TEST &OPTIONAL JS-OBJ)
135 (clauses :initform nil
:accessor clauses
)
136 (prologue :initform nil
:accessor prologue
)
137 (finally :initform nil
:accessor finally
)
138 (accum-var :initform nil
:accessor accum-var
)
139 (accum-kind :initform nil
:accessor accum-kind
)))
141 (defun push-body-clause (clause state
)
142 (push (list :body clause
) (clauses state
)))
144 (defun push-iter-clause (clause state
)
145 (push (cons :iter clause
) (clauses state
)))
147 (defun push-tokens (state toks
)
148 (setf (tokens state
) (append toks
(tokens state
))))
151 (car (tokens state
)))
153 (defun eat (state &optional what tag
)
154 "Consumes the next meaningful chunk of loop for processing."
156 (:if
(when (eq (as-keyword (peek state
)) tag
)
158 (values (eat state
) t
)))
159 (:progn
(cons 'progn
(loop :collect
(if (consp (peek state
))
161 (err "a compound form" (peek state
)))
162 :until
(atom (peek state
)))))
163 (otherwise (let ((tok (pop (tokens state
))))
164 (when (and (eq what
:atom
) (not (atom tok
)))
166 (when (and (eq what
:symbol
) (not (symbolp tok
)))
167 (err "a symbol" tok
))
170 (defun maybe-hoist (expr state
)
171 (cond ((complex-js-expr? expr
)
172 (let ((var (ps-gensym)))
173 (push (list 'setf var expr
) (prologue state
))
177 (defun for-from (from-key var state
)
179 (err "an atom after FROM" var
))
180 (let ((start (eat state
))
181 (op (loop-case from-key
(:downfrom
'-
) (otherwise '+)))
185 (loop while
(member (as-keyword (peek state
)) '(:to
:below
:downto
:above
:by
)) do
186 (let ((term (eat state
)))
187 (if (eq (as-keyword term
) :by
)
188 (setf by
(eat state
))
189 (setf op
(loop-case term
((:downto
:above
) '-
) (otherwise op
))
190 test-op
(loop-case term
(:to
(loop-case from-key
(:downfrom
'>=) (otherwise '<=))) (:below
'<) (:downto
'>=) (:above
'>))
192 (let ((test (when test-op
193 (list test-op var
(maybe-hoist end state
)))))
194 (push-iter-clause `(,var
,start
(,op
,var
,(or by
1)) ,test
) state
))))
196 (defun for-= (place state
)
197 (let ((start (eat state
)))
198 (multiple-value-bind (then thenp
)
199 (eat state
:if
:then
)
200 (push-iter-clause (list place start
(if thenp then start
) nil
) state
))))
202 (defun for-in (place state
)
203 (let ((arr (maybe-hoist (eat state
) state
))
205 (push-tokens state
`(,index
:from
0 :below
(length ,arr
)
206 ,place
:= (aref ,arr
,index
)))
210 (defun for-on (place state
)
211 (let* ((arr (eat state
))
212 (by (or (eat state
:if
:by
) 1))
213 (var (if (atom place
) place
(ps-gensym)))
214 (then (if (numberp by
) `((@ ,var
:slice
) ,by
) `(,by
,var
))))
215 (push-tokens state
`(,var
:= ,arr
:then
,then
))
217 ;; set the end-test by snooping into the iteration clause we just added
218 (setf (fifth (car (clauses state
))) `(> (length ,var
) 0))
219 (unless (eq place var
)
220 (push-tokens state
`(,place
:= ,var
))
221 (for-clause state
))))
223 (defun for-keys-of (place state
)
224 (when (clauses state
)
225 (error "FOR..OF is only allowed as the first clause in a loop."))
227 (unless (<= (length place
) 2) ; length 1 is ok, treat (k) as (k nil)
228 (error "FOR..OF must be followed by a key variable or key-value pair."))
229 (unless (atom (first place
))
230 (error "The key in a FOR..OF clause must be a variable.")))
231 (let ((k (or (if (atom place
) place
(first place
)) (ps-gensym)))
232 (v (when (consp place
) (second place
))))
233 (let ((js-obj (eat state
)))
234 (when v
; assign JS-OBJ to a local var if we need to for value binding (otherwise inline it)
235 (setf js-obj
(maybe-hoist js-obj state
)))
236 (push-iter-clause (list k nil nil nil js-obj
) state
)
238 (let ((val `(getprop ,js-obj
,k
)))
239 (push-iter-clause (list v val val nil
) state
))))))
241 (defun for-clause (state)
242 (let ((place (eat state
))
243 (term (eat state
:atom
)))
245 ((:from
:downfrom
) (for-from term place state
))
246 (:= (for-= place state
))
247 ((:in
:across
) (for-in place state
))
248 (:on
(for-on place state
))
249 (:of
(for-keys-of place state
))
250 (otherwise (error "FOR ~s ~s is not valid in PS-LOOP." place term
)))))
252 (defun a-with-clause (state) ;; so named to avoid with-xxx macro convention
253 (let ((place (eat state
)))
254 (push (list 'setf place
(eat state
:if
:=)) (prologue state
))))
256 (defun accumulate (kind item var state
)
258 (when (and (accum-kind state
) (not (eq kind
(accum-kind state
))))
259 (error "PS-LOOP encountered illegal ~a: ~a was already declared, and there can only be one kind of implicit accumulation per loop." kind
(accum-kind state
)))
260 (unless (accum-var state
)
261 (setf (accum-var state
)
262 (ps-gensym (string (loop-case kind
263 ((:minimize
:minimizing
) 'min
)
264 ((:maximize
:maximizing
) 'max
)
266 (setf (accum-kind state
) kind
))
267 (setf var
(accum-var state
)))
268 (let ((initial (loop-case kind
269 ((:sum
:summing
:count
:counting
) 0)
270 ((:maximize
:maximizing
:minimize
:minimizing
) nil
)
271 ((:collect
:collecting
:append
:appending
) '[])
272 ((:map
:mapping
) '{}))))
273 (pushnew (list 'setf var initial
)
277 ((:sum
:summing
)`(incf ,var
,item
))
278 ((:count
:counting
)`(when ,item
(incf ,var
))) ;; note the JS semantics - neither 0 nor "" will count
279 ((:minimize
:minimizing
) `(setf ,var
(if (null ,var
) ,item
(min ,var
,item
))))
280 ((:maximize
:maximizing
) `(setf ,var
(if (null ,var
) ,item
(max ,var
,item
))))
281 ((:collect
:collecting
) `((@ ,var
'push
) ,item
))
282 ((:append
:appending
) `(setf ,var
(append ,var
,item
)))
283 ((:map
:mapping
) (destructuring-bind (key val
) item
284 `(setf (getprop ,var
,key
) ,val
)))))
286 (defun repeat-clause (state)
287 (let ((index (ps-gensym)))
288 (setf (tokens state
) (append `(,index
:from
0 :below
,(eat state
)) (tokens state
)))
291 (defun while-clause (state)
292 (push-iter-clause (list nil nil nil
(eat state
)) state
))
294 (defun until-clause (state)
295 (push-iter-clause (list nil nil nil
`(not ,(eat state
))) state
))
297 (defun body-clause (term state
)
300 (let* ((test-form (eat state
))
301 (seqs (list (body-clause (eat state
:atom
) state
)))
303 (loop while
(eq (as-keyword (peek state
)) :and
)
305 (push (body-clause (eat state
:atom
) state
) seqs
))
306 (when (eq (as-keyword (peek state
)) :else
)
308 (push (body-clause (eat state
:atom
) state
) alts
)
309 (loop while
(eq (as-keyword (peek state
)) :and
)
311 (push (body-clause (eat state
:atom
) state
) alts
)))
312 (when (eq (as-keyword (peek state
)) :end
)
315 `(,(loop-case term
((:unless
) 'unless
) (otherwise 'when
))
318 `(if ,(loop-case term
319 ((:unless
) `(not ,test-form
))
320 (otherwise test-form
))
321 (progn ,@(reverse seqs
))
322 (progn ,@(reverse alts
))))))
323 ((:sum
:summing
:collect
:collecting
:append
:appending
:count
:counting
324 :minimize
:minimizing
:maximize
:maximizing
)
325 (accumulate term
(eat state
) (eat state
:if
:into
) state
))
326 ((:map
:mapping
) (let ((key (eat state
)))
327 (multiple-value-bind (val valp
)
330 (error "MAP must be followed by a TO to specify value."))
331 (accumulate :map
(list key val
) (eat state
:if
:into
) state
))))
332 ((:do
:doing
) (eat state
:progn
))
333 (:return
`(return-from ,(name state
) ,(eat state
)))
334 (otherwise (err "a PS-LOOP keyword" term
))))
336 (defun clause (state)
337 (let ((term (eat state
:atom
)))
339 (:named
(setf (name state
) (eat state
:symbol
)))
340 (:with
(a-with-clause state
))
341 (:initially
(push (eat state
:progn
) (prologue state
)))
342 (:for
(for-clause state
))
343 (:repeat
(repeat-clause state
))
344 (:while
(while-clause state
))
345 (:until
(until-clause state
))
346 (:finally
(push (eat state
:progn
) (finally state
)))
347 (otherwise (push-body-clause (body-clause term state
) state
)))))
349 (defun parse-ps-loop (terms)
350 (cond ((null terms
) (err "loop definition" nil
))
351 (t (let ((state (make-instance 'loop-state
:tokens terms
)))
352 (loop :while
(tokens state
) :do
(clause state
))
355 (defun fold-iterations-where-possible (clauses)
357 (loop :for clause
:in clauses
:do
358 (assert (member (car clause
) '(:iter
:body
)))
360 (when (and (eq (car clause
) :iter
) (eq (caar folded
) :iter
))
361 (destructuring-bind (tag place init step test
&optional js-obj
) clause
362 (declare (ignore tag
))
363 (when (null place
) ;; can't combine two iterations that both have state
364 (assert (not (or init step js-obj
)) nil
"Invalid iteration ~a: PLACE should not be null." clause
)
365 (assert test nil
"Iteration ~a has neither PLACE nor TEST." clause
)
366 (unless (sixth (car folded
)) ;; js-obj means a for..in loop and those can't have tests
367 (let ((prev-test (fifth (car folded
))))
368 (setf (fifth (car folded
)) (if prev-test
`(and ,prev-test
,test
) test
))
369 (setf folded? t
))))))
371 (push clause folded
))))
374 (defun organize-iterations (clauses)
375 ;; we want clauses to start with a master loop to provide the
376 ;; skeleton for everything else. secondary iterations are ok but
377 ;; will be generated inside the body of this master loop
378 (unless (eq (caar clauses
) :iter
)
379 (push (list :iter nil nil nil t
) clauses
))
380 ;; unify adjacent test expressions by ANDing them together where possible
381 (setf clauses
(fold-iterations-where-possible clauses
))
382 ;; if leading iteration has a binding expression, replace it with a var
383 (destructuring-bind (tag place init step test
&optional js-obj
) (car clauses
)
384 (assert (eq tag
:iter
))
385 (when (complex-js-expr? place
)
386 (assert (null js-obj
) nil
"Invalid iteration ~a: FOR..IN can't have a binding expression." (car clauses
))
387 (let ((var (ps-gensym)))
389 (push (list :iter place var var nil
) clauses
)
390 (push (list :iter var init step test
) clauses
))))
393 (defun build-body (clauses firstvar
)
394 (cond ((null clauses
) nil
)
395 ((eq (caar clauses
) :body
)
396 (cons (second (car clauses
)) (build-body (cdr clauses
) firstvar
)))
397 (t (destructuring-bind (tag place init step test
) (car clauses
)
398 (assert (eq tag
:iter
))
399 (let ((body (build-body (cdr clauses
) firstvar
)))
401 (push `(unless ,test
(break)) body
))
403 (let ((expr (if (tree-equal init step
) init
`(if ,firstvar
,init
,step
))))
405 (cond ((and (atom place
) (eq expr init
))
406 `((let ((,place
,expr
)) ,@body
)))
407 ;; can't use LET because EXPR may reference PLACE
408 ((atom place
) `((var ,place
,expr
) ,@body
))
409 ;; BIND has scoping problems. For example,
410 ;; (loop :for (a b) = x :then b) doesn't work
411 ;; since EXPR is referencing part of PLACE.
412 ;; But the following is ok for known uses so far.
413 (t `((bind ,place
,expr
,@body
)))))))
416 (define-statement-operator loop-while
(test &rest body
)
417 `(ps-js:while
,(compile-expression test
)
418 ,(compile-loop-body () body
)))
420 (defun master-loop (master-iter body
)
421 (destructuring-bind (tag place init step test
&optional js-obj
) master-iter
422 (assert (eq tag
:iter
))
423 (cond ((null place
) `(loop-while ,test
,@body
))
425 (assert (not (or init step test
)) nil
"Unexpected iteration state in for..in loop: ~a" master-iter
)
426 `(for-in (,place
,js-obj
) ,@body
))
427 (t (assert (atom place
) nil
"Unexpected destructuring list ~a in master loop" place
)
428 `(for ((,place
,init
)) (,(or test t
)) ((setf ,place
,step
)) ,@body
)))))
430 (defun build-loop (clauses)
431 (destructuring-bind (master . rest
) clauses
432 (assert (eq (car master
) :iter
) nil
"First clause is not master loop: ~a" master
)
433 (let* ((firstvar (loop :for
(tag nil init step
) :in rest
434 :when
(and (eq tag
:iter
) (not (tree-equal init step
)))
435 :do
(return (ps-gensym 'FIRST
))))
436 (body (build-body rest firstvar
)))
438 (setf body
(append body
`((setf ,firstvar nil
)))))
439 (let ((form (master-loop master body
)))
440 (if firstvar
`(let ((,firstvar t
)) ,form
) form
)))))
442 (defun prologue-wrap (prologue body
)
443 (cond ((null prologue
) body
)
444 ((equal 'setf
(caar prologue
))
445 (destructuring-bind (place expr
) (cdr (car prologue
))
448 (cond ((atom place
) (cons `(var ,place
,expr
) body
))
449 (t `((bind ,place
,expr
,@body
)))))))
452 (cons (car prologue
) body
)))))
454 (defpsmacro loop
(&rest keywords-and-forms
)
455 (let ((state (parse-ps-loop keywords-and-forms
)))
456 (let* ((clauses (organize-iterations (reverse (clauses state
))))
457 (main `(,(build-loop (organize-iterations clauses
))
458 ,@(reverse (finally state
))
459 ,@(awhen (accum-var state
) (list it
))))
460 (full `(block ,(name state
) ,@(prologue-wrap (prologue state
) main
))))
461 (if (accum-var state
)
462 (with-lambda-scope full
)