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