Commit | Line | Data |
---|---|---|
e4ee1b86 DG |
1 | (in-package :parenscript) |
2 | ||
e4ee1b86 DG |
3 | (defun complex-js-expr? (expr) |
4 | (if (symbolp expr) | |
5 | (find #\. (symbol-name expr)) | |
6 | (consp expr))) | |
7 | ||
e4ee1b86 | 8 | (defvar *loop-keywords* |
a3939827 DG |
9 | '(:for :do :when :unless :initially :finally :first-time :last-time :while :until |
10 | :from :to :below :downto :above :by :in :across :index := :then :sum :collect)) | |
e4ee1b86 DG |
11 | |
12 | (defun normalize-loop-keywords (args) | |
512017c6 DG |
13 | (mapcar |
14 | (lambda (x) | |
15 | (or (find-if (lambda (key) (and (symbolp x) (equal (symbol-name x) (symbol-name key)))) | |
16 | *loop-keywords*) | |
17 | x)) | |
18 | args)) | |
e4ee1b86 | 19 | |
a3939827 | 20 | (defun parse-ps-loop (terms) |
e4ee1b86 DG |
21 | (let (prologue |
22 | init-step-forms end-test-forms | |
23 | initially finally | |
24 | first-time last-time | |
a3939827 | 25 | accum-var accum-kind |
512017c6 | 26 | destructurings body) |
e4ee1b86 DG |
27 | (macrolet ((with-local-var ((name expr) &body body) |
28 | (once-only (expr) | |
29 | `(let ((,name (aif (and (complex-js-expr? ,expr) (ps-gensym)) | |
30 | (progn (push (list 'var it ,expr) prologue) | |
31 | it) | |
32 | ,expr))) | |
33 | ,@body)))) | |
34 | (labels ((next () | |
35 | (car terms)) | |
36 | (next? (term) | |
37 | (eq (next) term)) | |
38 | (err (expected got) | |
512017c6 | 39 | (error "PS-LOOP expected ~a, got ~a." expected got)) |
e4ee1b86 DG |
40 | (consume (&optional what) |
41 | (let ((term (pop terms))) | |
42 | (when (and what (not (eq what term))) | |
43 | (err what term)) | |
44 | term)) | |
45 | (consume-atom () | |
46 | (if (atom (next)) | |
47 | (consume) | |
48 | (err "an atom" (next)))) | |
49 | (consume-progn () | |
50 | (cons 'progn (loop :collect (if (consp (next)) | |
51 | (consume) | |
52 | (err "a compound form" (next))) | |
53 | :until (atom (next))))) | |
54 | (consume-if (term) | |
55 | (when (next? term) | |
56 | (consume) | |
57 | (consume))) | |
a3939827 DG |
58 | (establish-accum-var (kind initial-val) |
59 | (if accum-var | |
60 | (error "PS-LOOP encountered illegal ~a: a ~a was previously declared, and there can only be one accumulation per loop." kind accum-kind) | |
61 | (progn | |
62 | (setf accum-var (ps-gensym kind) | |
63 | accum-kind kind) | |
64 | (push `(var ,accum-var ,initial-val) prologue)))) | |
e4ee1b86 DG |
65 | (body-clause (term) |
66 | (case term | |
67 | ((:when :unless) (list (intern (symbol-name term)) | |
68 | (consume) | |
69 | (body-clause (consume-atom)))) | |
a3939827 DG |
70 | (:sum (establish-accum-var :sum 0) |
71 | `(incf ,accum-var ,(consume))) | |
72 | (:collect (establish-accum-var :collect '(array)) | |
73 | `((@ ,accum-var :push) ,(consume))) | |
e4ee1b86 | 74 | (:do (consume-progn)) |
a3939827 | 75 | (otherwise (err "a PS-LOOP keyword" term)))) |
e4ee1b86 DG |
76 | (for-from (var) |
77 | (let ((start (consume)) | |
78 | (op '+) | |
79 | (test nil) | |
80 | (by nil) | |
81 | (end nil)) | |
82 | (loop while (member (next) '(:to :below :downto :above :by)) do | |
83 | (let ((term (consume))) | |
84 | (if (eq term :by) | |
85 | (setf by (consume)) | |
86 | (setf op (case term ((:downto :above) '-) (otherwise '+)) | |
87 | test (case term (:to '>) (:below '>=) (:downto '<) (:above '<=)) | |
88 | end (consume))))) | |
89 | (push `(,var ,start (,op ,var ,(or by 1))) init-step-forms) | |
90 | (when test | |
91 | (with-local-var (end-var end) | |
92 | (push (list test var end-var) end-test-forms))))) | |
93 | (for-= (var) | |
94 | (let ((start (consume)) | |
95 | (then (consume-if :then))) | |
96 | (push (list var start (or then start)) init-step-forms))) | |
97 | (for-in (var) | |
98 | (with-local-var (arr (consume)) | |
99 | (let* ((index (or (consume-if :index) (ps-gensym))) | |
100 | (equiv `(:for ,index :from 0 :below (length ,arr) | |
101 | :for ,var := (aref ,arr ,index)))) | |
102 | (setf terms (append equiv terms)) | |
103 | (clause) | |
104 | (clause)))) | |
105 | (for-clause () | |
512017c6 DG |
106 | (let* ((place (consume)) |
107 | (var (when (atom place) place)) | |
108 | (varlist (unless var place)) | |
109 | (term (consume-atom))) | |
110 | (when varlist | |
111 | (when (eq term :from) | |
112 | (err "an atom after FROM" varlist)) | |
113 | (setf var (ps-gensym)) | |
114 | (push (list varlist var) destructurings)) | |
e4ee1b86 DG |
115 | (case term |
116 | (:from (for-from var)) | |
117 | (:= (for-= var)) | |
118 | ((:in :across) (for-in var)) | |
a3939827 | 119 | (otherwise (error "FOR ~s ~s is not valid in PS-LOOP." var term))))) |
e4ee1b86 DG |
120 | (clause () |
121 | (let ((term (consume-atom))) | |
122 | (case term | |
123 | (:for (for-clause)) | |
124 | (:while (push `(unless ,(consume) break) body)) | |
125 | (:until (push `(when ,(consume) break) body)) | |
126 | (:initially (push (consume-progn) initially)) | |
127 | (:finally (push (consume-progn) finally)) | |
128 | (:first-time (push (consume-progn) first-time)) | |
129 | (:last-time (push (consume-progn) last-time)) | |
130 | (otherwise (push (body-clause term) body)))))) | |
131 | (if terms | |
132 | (loop :while terms :do (clause)) | |
512017c6 DG |
133 | (err "loop definition" nil))) |
134 | (flet ((end-test () | |
135 | (aif (nreverse end-test-forms) | |
136 | (if (cdr it) | |
137 | (list (cons 'or it)) | |
138 | it) | |
139 | (list nil))) | |
140 | (add-destructurings-to-body () | |
141 | (setf body (nreverse body)) | |
142 | (loop :for (list var) :in destructurings :do | |
143 | (setf body `((destructuring-bind ,list ,var ,@body)))) | |
144 | body)) | |
e4ee1b86 DG |
145 | (values (nreverse prologue) |
146 | (nreverse init-step-forms) | |
512017c6 | 147 | (end-test) |
e4ee1b86 DG |
148 | (nreverse initially) |
149 | (nreverse finally) | |
150 | (nreverse first-time) | |
151 | (nreverse last-time) | |
a3939827 | 152 | accum-var |
512017c6 | 153 | (add-destructurings-to-body)))))) |
e4ee1b86 DG |
154 | |
155 | (defpsmacro loop (&rest args) | |
156 | (multiple-value-bind (prologue | |
512017c6 | 157 | init-step-forms end-test |
e4ee1b86 DG |
158 | initially finally |
159 | first-time last-time | |
a3939827 | 160 | accum-var |
e4ee1b86 | 161 | body) |
a3939827 | 162 | (parse-ps-loop (normalize-loop-keywords args)) |
e4ee1b86 DG |
163 | (let ((first-guard (and first-time (ps-gensym))) |
164 | (last-guard (and last-time (ps-gensym)))) | |
a3939827 DG |
165 | `(,@(if accum-var '(with-lambda ()) '(progn)) |
166 | ,@(when first-time `((var ,first-guard t))) | |
167 | ,@(when last-time `((var ,last-guard nil))) | |
168 | ,@prologue | |
169 | ,@initially | |
170 | (do* ,init-step-forms | |
512017c6 | 171 | ,end-test |
a3939827 DG |
172 | ,@(when first-time |
173 | `((when ,first-guard | |
174 | ,@first-time | |
175 | (setf ,first-guard nil)))) | |
176 | ,@body | |
177 | ,@(when last-time | |
178 | `((setf ,last-guard t)))) | |
179 | ,@(when last-time `((when ,last-guard ,@last-time))) | |
180 | ,@finally | |
181 | ,@(when accum-var `((return ,accum-var))))))) |