Show More
@@ -1,8 +1,15 b'' | |||||
1 |
|
1 | |||
2 | # locals |
|
2 | # locals | |
3 |
|
3 | |||
|
4 | local variable | |||
|
5 | variable = 5 | |||
|
6 | *pl variable | |||
|
7 | global = 42 | |||
|
8 | ||||
4 | var = 1 |
|
9 | var = 1 | |
5 | dynamic { local var = 2 & *pl var } |
|
10 | dynamic { local var = 2 & *pl var } | |
6 | *pl var |
|
11 | *pl var | |
7 |
|
12 | |||
|
13 | dynamic { *pl 'ΠΠ΄Π΅ΡΡ Π½Π΅Ρ Π»ΠΎΠΊΠ°Π»ΡΠ½ΡΡ ΠΏΠ΅ΡΠ΅ΠΌΠ΅Π½Π½ΡΡ ' } | |||
|
14 | ||||
8 | ----- locals --------------- |
|
15 | ----- locals --------------- |
@@ -1,22 +1,37 b'' | |||||
1 |
|
1 | |||
2 | # start |
|
2 | # start | |
|
3 | act 'ΠΡΠΎΡΠ΅ΡΡΠΈΡΠΎΠ²Π°ΡΡ ΡΠΈΠΊΠ» Π½Π° ΠΌΠ΅ΡΠΊΠ°Ρ ': | |||
|
4 | gs 'test_jump' | |||
|
5 | end | |||
|
6 | act 'ΠΡΠΎΡΠ΅ΡΡΠΈΡΠΎΠ²Π°ΡΡ ΡΠΈΠΊΠ» for': | |||
|
7 | gs 'test_for' | |||
|
8 | end | |||
|
9 | - | |||
|
10 | ||||
|
11 | # test_jump | |||
|
12 | *nl | |||
3 | i = 0 |
|
13 | i = 0 | |
|
14 | local start_time = MSECSCOUNT | |||
4 | :loop |
|
15 | :loop | |
5 | if i < 10000000: |
|
16 | if i < 10000000: | |
6 | i += 1 |
|
17 | i += 1 | |
7 | if (i MOD 100000) = 0: |
|
18 | if (i MOD 100000) = 0: | |
8 | *p '.' |
|
19 | *p '.' | |
9 | end |
|
20 | end | |
10 | jump loop |
|
21 | jump 'loop' | |
11 | end |
|
22 | end | |
12 | looptime = MSECSCOUNT |
|
23 | local looptime = MSECSCOUNT - start_time | |
13 | *nl 'JUMP: ΠΡΠΏΠΎΠ»Π½Π΅Π½ΠΎ Π·Π° <<looptime>> ΠΌΠΈΠ»Π»ΠΈΡΠ΅ΠΊΡΠ½Π΄' |
|
24 | *nl 'JUMP: ΠΡΠΏΠΎΠ»Π½Π΅Π½ΠΎ Π·Π° <<looptime>> ΠΌΠΈΠ»Π»ΠΈΡΠ΅ΠΊΡΠ½Π΄' | |
|
25 | - | |||
|
26 | ||||
|
27 | # test_for | |||
14 | *nl |
|
28 | *nl | |
|
29 | local start_time = MSECSCOUNT | |||
15 | for i = 0 to 10000000: |
|
30 | for i = 0 to 10000000: | |
16 | if (i MOD 100000) = 0: |
|
31 | if (i MOD 100000) = 0: | |
17 | *p '.' |
|
32 | *p '.' | |
18 | end |
|
33 | end | |
19 | end |
|
34 | end | |
20 |
|
|
35 | local looptime = MSECSCOUNT - start_time | |
21 |
*nl 'FOR: ΠΡΠΏΠΎΠ»Π½Π΅Π½ΠΎ Π·Π° << |
|
36 | *nl 'FOR: ΠΡΠΏΠΎΠ»Π½Π΅Π½ΠΎ Π·Π° <<looptime>> ΠΌΠΈΠ»Π»ΠΈΡΠ΅ΠΊΡΠ½Π΄' | |
22 | - |
|
37 | - |
@@ -1,13 +1,13 b'' | |||||
1 |
|
1 | |||
2 | <div id="qsp"> |
|
2 | <div id="qsp"> | |
3 | <div class="qsp-col qsp-col1"> |
|
3 | <div class="qsp-col qsp-col1"> | |
4 |
<div id="qsp-main" class="qsp-frame">& |
|
4 | <div id="qsp-main" class="qsp-frame">‌</div> | |
5 |
<div id="qsp-acts" class="qsp-frame">& |
|
5 | <div id="qsp-acts" class="qsp-frame">‌</div> | |
6 | <input id="qsp-input" class="qsp-frame"> |
|
6 | <input id="qsp-input" class="qsp-frame"> | |
7 | </div> |
|
7 | </div> | |
8 | <div class="qsp-col qsp-col2"> |
|
8 | <div class="qsp-col qsp-col2"> | |
9 |
<div id="qsp-stat" class="qsp-frame">& |
|
9 | <div id="qsp-stat" class="qsp-frame">‌</div> | |
10 |
<div id="qsp-objs" class="qsp-frame">& |
|
10 | <div id="qsp-objs" class="qsp-frame">‌</div> | |
11 | </div> |
|
11 | </div> | |
12 | <div class="qsp-col qsp-col3"> |
|
12 | <div class="qsp-col qsp-col3"> | |
13 | <a id="qsp-btn-save"><img></a> |
|
13 | <a id="qsp-btn-save"><img></a> |
@@ -66,7 +66,7 b'' | |||||
66 | (finish-menu nil)))) |
|
66 | (finish-menu nil)))) | |
67 |
|
67 | |||
68 | (defun call-serv-loc (var-name &rest args) |
|
68 | (defun call-serv-loc (var-name &rest args) | |
69 |
(let ((loc-name (get- |
|
69 | (let ((loc-name (get-global var-name 0))) | |
70 | (when loc-name |
|
70 | (when loc-name | |
71 | (let ((loc (getprop (root locs) loc-name))) |
|
71 | (let ((loc (getprop (root locs) loc-name))) | |
72 | (when loc |
|
72 | (when loc | |
@@ -102,7 +102,8 b'' | |||||
102 | (replace (regex "/'/g") "'"))) |
|
102 | (replace (regex "/'/g") "'"))) | |
103 |
|
103 | |||
104 | (defun prepare-contents (s &optional force-html) |
|
104 | (defun prepare-contents (s &optional force-html) | |
105 | (if (or force-html (get-var "USEHTML" 0 :num)) |
|
105 | (setf s (chain s (to-string))) | |
|
106 | (if (or force-html (get-global "USEHTML" 0)) | |||
106 | s |
|
107 | s | |
107 | (escape-html s))) |
|
108 | (escape-html s))) | |
108 |
|
109 | |||
@@ -119,7 +120,7 b'' | |||||
119 | (defun on-input-key (ev) |
|
120 | (defun on-input-key (ev) | |
120 | (when (= 13 (@ ev key-code)) |
|
121 | (when (= 13 (@ ev key-code)) | |
121 | (chain ev (prevent-default)) |
|
122 | (chain ev (prevent-default)) | |
122 | (call-serv-loc "USERCOM"))) |
|
123 | (call-serv-loc "$USERCOM"))) | |
123 |
|
124 | |||
124 | ;;; Function calls |
|
125 | ;;; Function calls | |
125 |
|
126 | |||
@@ -131,9 +132,8 b'' | |||||
131 | (set-var args i :str arg))))) |
|
132 | (set-var args i :str arg))))) | |
132 |
|
133 | |||
133 | (defun get-result () |
|
134 | (defun get-result () | |
134 | (if (not (equal "" (get-var "RESULT" 0 :str))) |
|
135 | (or (get-global "$RESULT" 0) | |
135 |
(get- |
|
136 | (get-global "RESULT" 0))) | |
136 | (get-var "RESULT" 0 :num))) |
|
|||
137 |
|
137 | |||
138 | (defun call-loc (name args) |
|
138 | (defun call-loc (name args) | |
139 | (setf name (chain name (to-upper-case))) |
|
139 | (setf name (chain name (to-upper-case))) | |
@@ -202,7 +202,7 b'' | |||||
202 | (loop :for (k v) :of (root acts) |
|
202 | (loop :for (k v) :of (root acts) | |
203 | :do (setf (getprop v :selected) nil)) |
|
203 | :do (setf (getprop v :selected) nil)) | |
204 | (setf (getprop (root acts) title :selected) t) |
|
204 | (setf (getprop (root acts) title :selected) t) | |
205 | (call-serv-loc "ONACTSEL")) |
|
205 | (call-serv-loc "$ONACTSEL")) | |
206 |
|
206 | |||
207 | ;;; "Syntax" |
|
207 | ;;; "Syntax" | |
208 |
|
208 | |||
@@ -214,103 +214,39 b'' | |||||
214 | (unless (await (funcall body)) |
|
214 | (unless (await (funcall body)) | |
215 | (return-from qspfor)))) |
|
215 | (return-from qspfor)))) | |
216 |
|
216 | |||
217 | ;;; Variable class |
|
|||
218 |
|
||||
219 | (defun *var (name) |
|
|||
220 | ;; From strings to numbers |
|
|||
221 | (setf (@ this :indexes) (create)) |
|
|||
222 | ;; From numbers to {num: 0, str: ""} objects |
|
|||
223 | (setf (@ this :values) (list)) |
|
|||
224 | (void)) |
|
|||
225 |
|
||||
226 | (defun new-value () |
|
|||
227 | (create :num 0 :str "")) |
|
|||
228 |
|
||||
229 | (setf (@ *var prototype index-num) |
|
|||
230 | (lambda (index) |
|
|||
231 | (let ((num-index |
|
|||
232 | (if (stringp index) |
|
|||
233 | (if (in index (@ this :indexes)) |
|
|||
234 | (getprop (@ this :indexes) index) |
|
|||
235 | (let ((n (length (@ this :values)))) |
|
|||
236 | (setf (getprop (@ this :indexes) index) n) |
|
|||
237 | n)) |
|
|||
238 | index))) |
|
|||
239 | (unless (in num-index (@ this :values)) |
|
|||
240 | (setf (elt (@ this :values) num-index) (new-value))) |
|
|||
241 | num-index))) |
|
|||
242 |
|
||||
243 | (setf (@ *var prototype get) |
|
|||
244 | (lambda (index slot) |
|
|||
245 | (unless (or index (= 0 index)) |
|
|||
246 | (setf index (1- (length (@ this :values))))) |
|
|||
247 | (getprop (@ this :values) (chain this (index-num index)) slot))) |
|
|||
248 |
|
||||
249 | (setf (@ *var prototype set) |
|
|||
250 | (lambda (index slot value) |
|
|||
251 | (unless (or index (= 0 index)) |
|
|||
252 | (setf index (length (@ this :values)))) |
|
|||
253 | (case slot |
|
|||
254 | (:num (setf value (chain *number (parse-int value)))) |
|
|||
255 | (:str (setf value (chain value (to-string))))) |
|
|||
256 | (setf (getprop (@ this :values) |
|
|||
257 | (chain this (index-num index)) |
|
|||
258 | slot) value) |
|
|||
259 | (void))) |
|
|||
260 |
|
||||
261 | (setf (@ *var prototype kill) |
|
|||
262 | (lambda (index) |
|
|||
263 | (setf (elt (@ this :values) (chain this (index-num index))) |
|
|||
264 | (new-value)) |
|
|||
265 | (delete (getprop 'this :indexes index)))) |
|
|||
266 |
|
||||
267 | ;;; Variables |
|
217 | ;;; Variables | |
268 |
|
218 | |||
269 | (defun var-real-name (name) |
|
219 | (defun new-var (&optional index) | |
270 | (if (= (@ name 0) #\$) |
|
220 | (let ((v (list))) | |
271 | (values (chain name (substr 1)) :str) |
|
221 | (when index | |
272 | (values name :num))) |
|
222 | (setf (elt v index) (if (eq #\$ (elt slot 0)) "" 0))) | |
273 |
|
223 | (setf (@ v indexes) (create)) | ||
274 | (defun ensure-var (name) |
|
224 | v)) | |
275 | (setf name (chain name (to-upper-case))) |
|
|||
276 | (let ((store (var-ref name))) |
|
|||
277 | (unless store |
|
|||
278 | (setf store (new (*var name))) |
|
|||
279 | (setf (getprop (root vars) name) store)) |
|
|||
280 | store)) |
|
|||
281 |
|
||||
282 | (defun var-ref (name) |
|
|||
283 | (let ((local-store (current-local-frame))) |
|
|||
284 | (cond ((and local-store (in name local-store)) |
|
|||
285 | (getprop local-store name)) |
|
|||
286 | ((in name (root vars)) |
|
|||
287 | (getprop (root vars) name)) |
|
|||
288 | (t nil)))) |
|
|||
289 |
|
225 | |||
290 |
(defun |
|
226 | (defun set-str-element (slot index value) | |
291 | (chain (ensure-var name) (get index slot))) |
|
227 | (if (in index (getprop slot :indexes)) | |
292 |
|
228 | (setf (elt (getprop slot) | ||
293 | (defun set-var (name index slot value) |
|
229 | (getprop slot :indexes index)) | |
294 | (chain (ensure-var name) (set index slot value)) |
|
230 | value) | |
295 | (let ((serv-var (getprop serv-vars name))) |
|
231 | (progn | |
296 | (when serv-var |
|
232 | (chain slot (push value)) | |
297 | (funcall (@ serv-var :body) |
|
233 | (setf (elt slot index) | |
298 | (get-var name index (@ serv-var :slot)) |
|
234 | (length slot))))) | |
299 | index))) |
|
|||
300 | (void)) |
|
|||
301 |
|
235 | |||
302 | (defun get-array (name) |
|
236 | (defun set-any-element (slot index value) | |
303 | (setf name (chain name (to-upper-case))) |
|
237 | (if (numberp index) | |
304 | (ensure-var name)) |
|
238 | (setf (elt slot index) value) | |
|
239 | (set-str-element slot index value))) | |||
305 |
|
240 | |||
306 | (defun set-array (name value) |
|
241 | (defun get-element (slot index) | |
307 | (setf name (chain name (to-upper-case))) |
|
242 | (if (numberp index) | |
308 | (let ((store (ensure-var name))) |
|
243 | (elt slot index) | |
309 | (setf (@ store :values) (@ value :values)) |
|
244 | (elt slot (getprop slot :indexes index)))) | |
310 | (setf (@ store :indexes) (@ value :indexes))) |
|
|||
311 | (void)) |
|
|||
312 |
|
245 | |||
313 |
(defun |
|
246 | (defun get-global (name index) | |
|
247 | (elt (getprop (root vars) name) index)) | |||
|
248 | ||||
|
249 | (defun kill-var (store name &optional index) | |||
314 | (setf name (chain name (to-upper-case))) |
|
250 | (setf name (chain name (to-upper-case))) | |
315 | (if (and index (not (= 0 index))) |
|
251 | (if (and index (not (= 0 index))) | |
316 | (chain (getprop (root vars) name) (kill index)) |
|
252 | (chain (getprop (root vars) name) (kill index)) | |
@@ -333,19 +269,13 b'' | |||||
333 | (defun current-local-frame () |
|
269 | (defun current-local-frame () | |
334 | (elt (root locals) (1- (length (root locals))))) |
|
270 | (elt (root locals) (1- (length (root locals))))) | |
335 |
|
271 | |||
336 | (defun new-local (name) |
|
|||
337 | (let ((frame (current-local-frame))) |
|
|||
338 | (unless (in name frame) |
|
|||
339 | (setf (getprop frame name) (create))) |
|
|||
340 | (void))) |
|
|||
341 |
|
||||
342 | ;;; Objects |
|
272 | ;;; Objects | |
343 |
|
273 | |||
344 | (defun select-obj (title img) |
|
274 | (defun select-obj (title img) | |
345 | (loop :for (k v) :of (root objs) |
|
275 | (loop :for (k v) :of (root objs) | |
346 | :do (setf (getprop v :selected) nil)) |
|
276 | :do (setf (getprop v :selected) nil)) | |
347 | (setf (getprop (root objs) title :selected) t) |
|
277 | (setf (getprop (root objs) title :selected) t) | |
348 | (call-serv-loc "ONOBJSEL" title img)) |
|
278 | (call-serv-loc "$ONOBJSEL" title img)) | |
349 |
|
279 | |||
350 | (defun update-objs () |
|
280 | (defun update-objs () | |
351 | (let ((elt (by-id "qsp-objs"))) |
|
281 | (let ((elt (by-id "qsp-objs"))) | |
@@ -475,7 +405,7 b'' | |||||
475 | (chain document body (remove-child element)))) |
|
405 | (chain document body (remove-child element)))) | |
476 |
|
406 | |||
477 | (defun stash-state (args) |
|
407 | (defun stash-state (args) | |
478 | (call-serv-loc "ONGSAVE") |
|
408 | (call-serv-loc "$ONGSAVE") | |
479 | (setf (root state-stash) |
|
409 | (setf (root state-stash) | |
480 | (chain *j-s-o-n (stringify |
|
410 | (chain *j-s-o-n (stringify | |
481 | (create :vars (root vars) |
|
411 | (create :vars (root vars) | |
@@ -506,7 +436,7 b'' | |||||
506 | (@ data :stat-html)) |
|
436 | (@ data :stat-html)) | |
507 | (update-objs) |
|
437 | (update-objs) | |
508 | (set-timer (@ data :timer-interval)) |
|
438 | (set-timer (@ data :timer-interval)) | |
509 | (call-serv-loc "ONGLOAD") |
|
439 | (call-serv-loc "$ONGLOAD") | |
510 | (call-loc (root current-location) (@ data :loc-args)) |
|
440 | (call-loc (root current-location) (@ data :loc-args)) | |
511 | (void))) |
|
441 | (void))) | |
512 |
|
442 | |||
@@ -524,7 +454,7 b'' | |||||
524 | (setf (root timer-obj) |
|
454 | (setf (root timer-obj) | |
525 | (set-interval |
|
455 | (set-interval | |
526 | (lambda () |
|
456 | (lambda () | |
527 | (call-serv-loc "COUNTER")) |
|
457 | (call-serv-loc "$COUNTER")) | |
528 | interval))) |
|
458 | interval))) | |
529 |
|
459 | |||
530 | ;;; Special variables |
|
460 | ;;; Special variables |
@@ -12,6 +12,14 b'' | |||||
12 | #:state-stash #:playing #:locals |
|
12 | #:state-stash #:playing #:locals | |
13 | #:acts #:locs #:games)) |
|
13 | #:acts #:locs #:games)) | |
14 |
|
14 | |||
|
15 | (defpackage :code-walker | |||
|
16 | (:use :cl) | |||
|
17 | (:export #:deftransform | |||
|
18 | #:deftransform-stop | |||
|
19 | #:walk | |||
|
20 | #:whole | |||
|
21 | #:walk-continue)) | |||
|
22 | ||||
15 | ;;; API functions |
|
23 | ;;; API functions | |
16 | (defpackage :sugar-qsp.api |
|
24 | (defpackage :sugar-qsp.api | |
17 | (:use :cl :ps :sugar-qsp.main :sugar-qsp.js) |
|
25 | (:use :cl :ps :sugar-qsp.main :sugar-qsp.js) | |
@@ -38,7 +46,8 b'' | |||||
38 | ;;; QSP library functions and macros |
|
46 | ;;; QSP library functions and macros | |
39 | (defpackage :sugar-qsp.lib |
|
47 | (defpackage :sugar-qsp.lib | |
40 | (:use :cl :ps :sugar-qsp.main :sugar-qsp.js) |
|
48 | (:use :cl :ps :sugar-qsp.main :sugar-qsp.js) | |
41 |
(:local-nicknames (#:api :sugar-qsp.api) |
|
49 | (:local-nicknames (#:api :sugar-qsp.api) | |
|
50 | (#:walker :code-walker)) | |||
42 | (:export #:str #:exec #:qspblock #:qspfor #:game #:location |
|
51 | (:export #:str #:exec #:qspblock #:qspfor #:game #:location | |
43 | #:qspcond #:qspvar #:set #:local #:jump |
|
52 | #:qspcond #:qspvar #:set #:local #:jump | |
44 |
|
53 | |||
@@ -83,17 +92,13 b'' | |||||
83 | (setf (ps:ps-package-prefix "SUGAR-QSP.API") "qsp_api_") |
|
92 | (setf (ps:ps-package-prefix "SUGAR-QSP.API") "qsp_api_") | |
84 | (setf (ps:ps-package-prefix "SUGAR-QSP.LIB") "qsp_lib_") |
|
93 | (setf (ps:ps-package-prefix "SUGAR-QSP.LIB") "qsp_lib_") | |
85 |
|
94 | |||
86 | (defpackage :code-walker |
|
|||
87 | (:use :cl) |
|
|||
88 | (:export #:deftransform |
|
|||
89 | #:walk)) |
|
|||
90 |
|
||||
91 | ;;; The compiler |
|
95 | ;;; The compiler | |
92 | (defpackage :sugar-qsp |
|
96 | (defpackage :sugar-qsp | |
93 | (:use :cl) |
|
97 | (:use :cl) | |
94 | (:local-nicknames (#:p #:esrap) |
|
98 | (:local-nicknames (#:p #:esrap) | |
95 | (#:lib :sugar-qsp.lib) |
|
99 | (#:lib :sugar-qsp.lib) | |
96 | (#:api :sugar-qsp.api) |
|
100 | (#:api :sugar-qsp.api) | |
97 |
(#:main :sugar-qsp.main) |
|
101 | (#:main :sugar-qsp.main) | |
|
102 | (#:walker :code-walker)) | |||
98 | (:export #:parse-file #:entry-point)) |
|
103 | (:export #:parse-file #:entry-point)) | |
99 |
|
104 |
@@ -47,7 +47,7 b'' | |||||
47 | (destructuring-bind (ws1 operator ws2 operand2) |
|
47 | (destructuring-bind (ws1 operator ws2 operand2) | |
48 | list |
|
48 | list | |
49 | (declare (ignore ws1 ws2)) |
|
49 | (declare (ignore ws1 ws2)) | |
50 |
(list (intern (string-upcase operator) |
|
50 | (list (intern (string-upcase operator) "SUGAR-QSP.LIB") operand2))) | |
51 |
|
51 | |||
52 | (defun do-binop% (left-op other-ops) |
|
52 | (defun do-binop% (left-op other-ops) | |
53 | (if (null other-ops) |
|
53 | (if (null other-ops) | |
@@ -354,8 +354,6 b'' | |||||
354 | block-for-head-step |
|
354 | block-for-head-step | |
355 | colon spaces?) |
|
355 | colon spaces?) | |
356 | (:lambda (list) |
|
356 | (:lambda (list) | |
357 | (unless (eq (fourth (third list)) :num) |
|
|||
358 | (error "For counter variable must be numeric.")) |
|
|||
359 | (list 'lib:qspfor |
|
357 | (list 'lib:qspfor | |
360 | (elt list 2) |
|
358 | (elt list 2) | |
361 | (elt list 6) |
|
359 | (elt list 6) | |
@@ -594,9 +592,7 b'' | |||||
594 | ((nil) 0) |
|
592 | ((nil) 0) | |
595 | (:last nil) |
|
593 | (:last nil) | |
596 | (t idx-raw)))) |
|
594 | (t idx-raw)))) | |
597 | (if (char= #\$ (elt (string id) 0)) |
|
595 | (list 'lib:qspvar id idx)))) | |
598 | (list 'lib:qspvar (intern (subseq (string-upcase id) 1) :lib) idx :str) |
|
|||
599 | (list 'lib:qspvar id idx :num))))) |
|
|||
600 |
|
596 | |||
601 | (p:defrule array-index (and #\[ spaces? (p:? expression) spaces? #\]) |
|
597 | (p:defrule array-index (and #\[ spaces? (p:? expression) spaces? #\]) | |
602 | (:lambda (list) |
|
598 | (:lambda (list) |
@@ -5,6 +5,14 b'' | |||||
5 | ;;;; representation directly compilable by Parenscript |
|
5 | ;;;; representation directly compilable by Parenscript | |
6 | ;;;; Some utility macros for other .ps sources too. |
|
6 | ;;;; Some utility macros for other .ps sources too. | |
7 |
|
7 | |||
|
8 | ;;;; Block type | Has own locals | Has labels | async | |||
|
9 | ;;; Location | TRUE | TRUE | TRUE | |||
|
10 | ;;; Act | TRUE | TRUE | TRUE | |||
|
11 | ;;; {} | TRUE | TRUE | TRUE | |||
|
12 | ;;; IF | FALSE | TRUE | TRUE | |||
|
13 | ;;; FOR | FALSE | TRUE | TRUE | |||
|
14 | ;;; | |||
|
15 | ||||
8 | ;;; Utils |
|
16 | ;;; Utils | |
9 |
|
17 | |||
10 | ;;; Common |
|
18 | ;;; Common | |
@@ -27,12 +35,41 b'' | |||||
27 | (t |
|
35 | (t | |
28 | `(& ,@forms)))) |
|
36 | `(& ,@forms)))) | |
29 |
|
37 | |||
|
38 | (defpsmacro locals-block (&body body) | |||
|
39 | "Includes labels too (through qsp-lambda)" | |||
|
40 | (let ((*locals* nil)) | |||
|
41 | (walker:walk 'locals body) | |||
|
42 | `(qsp-lambda | |||
|
43 | (create-locals ,*locals*) | |||
|
44 | ,@(walker:walk 'apply-vars body)))) | |||
|
45 | ||||
30 | ;;; 1loc |
|
46 | ;;; 1loc | |
31 |
|
47 | |||
|
48 | (defparameter *service-variables* | |||
|
49 | '((usehtml 0) | |||
|
50 | (result 0) | |||
|
51 | ($result "") | |||
|
52 | ($ongload "") | |||
|
53 | ($ongsave "") | |||
|
54 | ($onobjadd "") | |||
|
55 | ($onobjdel "") | |||
|
56 | ($onobjsel "") | |||
|
57 | ($onnewloc "") | |||
|
58 | ($onactsel "") | |||
|
59 | ($counter "") | |||
|
60 | ($usercom ""))) | |||
|
61 | ||||
32 | (defpsmacro game ((name) &body body) |
|
62 | (defpsmacro game ((name) &body body) | |
|
63 | (setf body (walker:walk 'for-transform body)) | |||
|
64 | (setf *globals* *service-variables*) | |||
|
65 | (walker:walk 'globals body) | |||
33 | `(progn |
|
66 | `(progn | |
|
67 | ;; Game object | |||
34 | (setf (root games ,name) |
|
68 | (setf (root games ,name) | |
35 | (create)) |
|
69 | (create)) | |
|
70 | ;; Global variables from this game | |||
|
71 | (create-globals ,*globals*) | |||
|
72 | ;; Locations | |||
36 | ,@(loop :for location :in body |
|
73 | ,@(loop :for location :in body | |
37 | :collect `(setf (root games ,name ,(caadr location)) |
|
74 | :collect `(setf (root games ,name ,(caadr location)) | |
38 | ,location)))) |
|
75 | ,location)))) | |
@@ -40,9 +77,7 b'' | |||||
40 | (defpsmacro location ((name) &body body) |
|
77 | (defpsmacro location ((name) &body body) | |
41 | (declare (ignore name)) |
|
78 | (declare (ignore name)) | |
42 | "Name is used by the game macro above" |
|
79 | "Name is used by the game macro above" | |
43 | `(async-lambda () |
|
80 | `(locals-block ,@body)) | |
44 | (label-block () |
|
|||
45 | ,@body))) |
|
|||
46 |
|
81 | |||
47 | (defpsmacro goto% (target &rest args) |
|
82 | (defpsmacro goto% (target &rest args) | |
48 | `(progn |
|
83 | `(progn | |
@@ -56,12 +91,111 b'' | |||||
56 |
|
91 | |||
57 | ;;; 2var |
|
92 | ;;; 2var | |
58 |
|
93 | |||
59 | (defpsmacro qspvar (name index slot) |
|
94 | (defvar *globals* nil) | |
60 | `(api-call get-var ,(string name) ,index ,slot)) |
|
95 | (defvar *locals* nil) | |
|
96 | ||||
|
97 | (defpsmacro create-globals (globals) | |||
|
98 | `(chain *object | |||
|
99 | (assign (root vars) | |||
|
100 | (create ,@(loop :for (name index slot) | |||
|
101 | :in globals | |||
|
102 | :append `(,(string-upcase name) (api-call new-var ,index))))))) | |||
|
103 | ||||
|
104 | (walker:deftransform globals qspvar (&rest var) | |||
|
105 | (pushnew var *globals* :test #'equal) | |||
|
106 | (walker:walk-continue)) | |||
|
107 | ||||
|
108 | (walker:deftransform globals local (var &rest expr) | |||
|
109 | (declare (ignore var)) | |||
|
110 | (walker:walk 'globals expr)) | |||
|
111 | ||||
|
112 | (defpsmacro create-locals (locals) | |||
|
113 | (when locals | |||
|
114 | `(progn | |||
|
115 | (var locals (create | |||
|
116 | ,@(loop :for (name index) :in locals | |||
|
117 | :append `(,(string-upcase name) (api-call new-var)))))))) | |||
|
118 | ||||
|
119 | ;; locations, blocks, and acts all have their own locals namespace | |||
|
120 | (walker:deftransform-stop locals qspblock) | |||
|
121 | (walker:deftransform-stop locals act) | |||
|
122 | ||||
|
123 | (walker:deftransform locals local (var &optional expr) | |||
|
124 | (declare (ignore expr)) | |||
|
125 | (pushnew (rest var) *locals* :test #'equal) | |||
|
126 | nil) | |||
|
127 | ||||
|
128 | ;; index types: | |||
|
129 | ;; literal number | |||
|
130 | ;; literal string | |||
|
131 | ;; variable number | |||
|
132 | ;; variable string | |||
|
133 | ;; expression (may be possible to determine if it's a string or a number) | |||
|
134 | ||||
|
135 | (defun $-var-p (sym) | |||
|
136 | (char= #\$ (elt (string-upcase (symbol-name sym)) 0))) | |||
|
137 | ||||
|
138 | (defun literal-string-p (form) | |||
|
139 | (and (listp form) | |||
|
140 | (eq 'str (first form)))) | |||
|
141 | ||||
|
142 | (defun variable-number-p (form) | |||
|
143 | (and (listp form) | |||
|
144 | (eq 'qspvar (first form)) | |||
|
145 | (not ($-var-p (second form))))) | |||
61 |
|
146 | |||
62 | (defpsmacro set ((var vname vindex vslot) value) |
|
147 | (defun variable-string-p (form) | |
63 | (assert (eq var 'qspvar)) |
|
148 | (and (listp form) | |
64 | `(api-call set-var ,(string vname) ,vindex ,vslot ,value)) |
|
149 | (eq 'qspvar (first form)) | |
|
150 | ($-var-p (second form)))) | |||
|
151 | ||||
|
152 | (walker:deftransform apply-vars set (var expr) | |||
|
153 | (destructuring-bind (qspvar name index) | |||
|
154 | var | |||
|
155 | (declare (ignore qspvar)) | |||
|
156 | (let ((slot `(getprop | |||
|
157 | ,(if (member name *locals* :key #'first) | |||
|
158 | 'locals '(root vars)) | |||
|
159 | ,(string-upcase name)))) | |||
|
160 | (cond | |||
|
161 | ((or (numberp index) | |||
|
162 | (variable-number-p index)) | |||
|
163 | `(setf (elt ,slot ,index) | |||
|
164 | ,(walker:walk 'apply-vars expr))) | |||
|
165 | ((or (literal-string-p index) | |||
|
166 | (variable-string-p index)) | |||
|
167 | `(set-str-element ,slot ,(walker:walk 'apply-vars index) | |||
|
168 | (walker:walk 'apply-vars ,expr))) | |||
|
169 | (t | |||
|
170 | `(set-any-element ,slot ,index | |||
|
171 | (walker:walk 'apply-vars ,expr))))))) | |||
|
172 | ||||
|
173 | (walker:deftransform apply-vars local (var &optional expr) | |||
|
174 | (when expr | |||
|
175 | (walker:walk 'apply-vars (list 'set var expr)))) | |||
|
176 | ||||
|
177 | (walker:deftransform apply-vars qspvar (name index) | |||
|
178 | (let ((slot `(getprop | |||
|
179 | ,(if (member name *locals* :key #'first) 'locals '(root vars)) | |||
|
180 | ,(string-upcase name)))) | |||
|
181 | (cond | |||
|
182 | ((or (numberp index) | |||
|
183 | (variable-number-p index)) | |||
|
184 | `(elt ,slot ,index)) | |||
|
185 | ((or (literal-string-p index) | |||
|
186 | (variable-string-p index)) | |||
|
187 | `(elt ,slot (@ ,slot :indexes ,index))) | |||
|
188 | (t | |||
|
189 | `(get-element ,slot ,index))))) | |||
|
190 | ||||
|
191 | (walker:deftransform apply-vars qspblock (&rest block) | |||
|
192 | (declare (ignore block)) | |||
|
193 | (walker:whole)) | |||
|
194 | (walker:deftransform apply-vars act (&rest block) | |||
|
195 | (declare (ignore block)) | |||
|
196 | (walker:whole)) | |||
|
197 | (walker:deftransform apply-vars qspfor (var from to step body) | |||
|
198 | (list* 'qspfor var (mapcar #'walker:walk-continue (list from to step body)))) | |||
65 |
|
199 | |||
66 | ;;; 3expr |
|
200 | ;;; 3expr | |
67 |
|
201 | |||
@@ -100,37 +234,72 b'' | |||||
100 | `(return-from label-body ,(string-upcase (second target)))) |
|
234 | `(return-from label-body ,(string-upcase (second target)))) | |
101 |
|
235 | |||
102 | (defpsmacro tagbody (&body body) |
|
236 | (defpsmacro tagbody (&body body) | |
103 | (let ((funcs (list nil "_nil"))) |
|
237 | (let ((create-locals (if (eq (caar body) 'create-locals) | |
104 | (dolist (form body) |
|
238 | (list (car body)))) | |
105 | (cond ((keywordp form) |
|
239 | (void (if (equal (car (last body)) '(void)) | |
106 | (setf (first funcs) (reverse (first funcs))) |
|
240 | '((void))))) | |
107 | (push (string-upcase form) funcs) |
|
241 | (when create-locals | |
108 | (push nil funcs)) |
|
242 | (setf body (cdr body))) | |
109 | (t |
|
243 | (when void | |
110 | (push form (first funcs))))) |
|
244 | (setf body (butlast body))) | |
111 | (setf (first funcs) (reverse (first funcs))) |
|
245 | (let ((funcs (list nil "_nil"))) | |
112 | (setf funcs (reverse funcs)) |
|
246 | (dolist (form body) | |
113 | (if (= 2 (length funcs)) |
|
247 | (cond ((keywordp form) | |
114 | `(progn |
|
248 | (setf (first funcs) (reverse (first funcs))) | |
115 | ,@body) |
|
249 | (push (string-upcase form) funcs) | |
116 | `(progn |
|
250 | (push nil funcs)) | |
117 | (tagbody-blocks ,funcs) |
|
251 | (t | |
118 | (setf _nextblock :_nil) |
|
252 | (push form (first funcs))))) | |
119 | (loop |
|
253 | (setf (first funcs) (reverse (first funcs))) | |
120 | :for _nextblock |
|
254 | (setf funcs (reverse funcs)) | |
121 | := :_nil |
|
255 | `(progn | |
122 | :then (await (funcall (getprop _labels _nextblock))) |
|
256 | ,@create-locals | |
123 | :while _nextblock))))) |
|
257 | ,(if (= 2 (length funcs)) | |
|
258 | `(progn | |||
|
259 | ,@body) | |||
|
260 | `(progn | |||
|
261 | (tagbody-blocks ,funcs) | |||
|
262 | (loop | |||
|
263 | :for _nextblock | |||
|
264 | := :_nil | |||
|
265 | :then (await (funcall (getprop _labels _nextblock))) | |||
|
266 | :while _nextblock))) | |||
|
267 | ,@void)))) | |||
|
268 | ||||
|
269 | (defvar *current-label*) | |||
|
270 | (defvar *has-jump-back*) | |||
|
271 | (walker:deftransform optimize-jump jump (target) | |||
|
272 | (cond ((string= (string-upcase (second target)) *current-label*) | |||
|
273 | (setf *has-jump-back* t) | |||
|
274 | '(continue)) | |||
|
275 | (t | |||
|
276 | (walker:walk-continue)))) | |||
124 |
|
277 | |||
125 | (defpsmacro tagbody-blocks (funcs) |
|
278 | (defpsmacro tagbody-blocks (funcs) | |
126 | `(setf ,@(loop :for (label code . rest-labels) :on funcs :by #'cddr |
|
279 | `(setf ,@(loop :for (label code . rest-labels) :on funcs :by #'cddr | |
127 | :append `((@ _labels ,label) |
|
280 | :append `((@ _labels ,label) | |
128 | (async-lambda () |
|
281 | (async-lambda () | |
129 | (block label-body |
|
282 | (block label-body | |
130 |
|
|
283 | (tagbody-block-body ,label ,code | |
131 |
, |
|
284 | ,(first rest-labels)))))))) | |
132 | (list (first rest-labels)) |
|
285 | ||
133 | nil))))))) |
|
286 | (defpsmacro tagbody-block-body (label code next-label) | |
|
287 | (let ((*current-label* label) | |||
|
288 | (*has-jump-back* nil)) | |||
|
289 | (let ((code (walker:walk 'optimize-jump code))) | |||
|
290 | (if *has-jump-back* | |||
|
291 | `(progn | |||
|
292 | (loop :do (progn | |||
|
293 | ,@code | |||
|
294 | (break))) | |||
|
295 | ,@(if next-label | |||
|
296 | (list next-label) | |||
|
297 | nil)) | |||
|
298 | `(progn | |||
|
299 | ,@code | |||
|
300 | ,@(if next-label | |||
|
301 | (list next-label) | |||
|
302 | nil)))))) | |||
134 |
|
303 | |||
135 | (defpsmacro exit () |
|
304 | (defpsmacro exit () | |
136 | '(return-from nil (values))) |
|
305 | '(return-from nil (values))) | |
@@ -138,6 +307,10 b'' | |||||
138 | ;;; 10dynamic |
|
307 | ;;; 10dynamic | |
139 |
|
308 | |||
140 | (defpsmacro qspblock (&body body) |
|
309 | (defpsmacro qspblock (&body body) | |
|
310 | `(locals-block | |||
|
311 | ,@body)) | |||
|
312 | ||||
|
313 | (defpsmacro qsp-lambda (&body body) | |||
141 | `(async-lambda (args) |
|
314 | `(async-lambda (args) | |
142 | (label-block () |
|
315 | (label-block () | |
143 | ,@body))) |
|
316 | ,@body))) | |
@@ -146,9 +319,8 b'' | |||||
146 |
|
319 | |||
147 | (defpsmacro act (name img &body body) |
|
320 | (defpsmacro act (name img &body body) | |
148 | `(api-call add-act ,name ,img |
|
321 | `(api-call add-act ,name ,img | |
149 |
( |
|
322 | (locals-block | |
150 |
|
|
323 | ,@body))) | |
151 | ,@body)))) |
|
|||
152 |
|
324 | |||
153 | ;;; 12aux |
|
325 | ;;; 12aux | |
154 |
|
326 | |||
@@ -170,19 +342,13 b'' | |||||
170 |
|
342 | |||
171 | ;;; 21local |
|
343 | ;;; 21local | |
172 |
|
344 | |||
173 | (defpsmacro local (var &optional expr) |
|
|||
174 | `(progn |
|
|||
175 | (api-call new-local ,(string (second var))) |
|
|||
176 | ,@(when expr |
|
|||
177 | `((set ,var ,expr))))) |
|
|||
178 |
|
||||
179 | ;;; 22for |
|
345 | ;;; 22for | |
180 |
|
346 | |||
181 | (defpsmacro qspfor (var from to step &body body) |
|
347 | ;; Transform because it creates a (set ...) hence it has to be processed | |
182 | `(,(intern "QSPFOR" "API") |
|
348 | ;; before the apply-vars transform. And macros are processed *after* all | |
183 | ,(string (second var)) ,(third var) ;; name and index |
|
349 | ;; the transforms | |
184 | ,from ,to ,step |
|
350 | (walker:deftransform for-transform qspfor (var from to step &rest body) | |
185 | (async-lambda () |
|
351 | `(loop :for i :from ,from :to ,to :by ,step | |
186 | (block nil |
|
352 | :do (set ,var i) | |
187 | ,@body |
|
353 | :do (block nil | |
188 | t)))) |
|
354 | ,@(walker:walk-continue body)))) |
@@ -9,11 +9,34 b'' | |||||
9 | (lambda ,args ,@body)) |
|
9 | (lambda ,args ,@body)) | |
10 | (list ',transformer-name ',head))) |
|
10 | (list ',transformer-name ',head))) | |
11 |
|
11 | |||
|
12 | (defmacro deftransform-stop (transformer-name head) | |||
|
13 | `(progn | |||
|
14 | (setf (gethash (list ',transformer-name ',head) *transformers*) | |||
|
15 | (lambda (&rest args) | |||
|
16 | (declare (ignore args)) | |||
|
17 | nil)) | |||
|
18 | (list ',transformer-name ',head))) | |||
|
19 | ||||
|
20 | (defvar *whole*) | |||
|
21 | (defvar *transformer-name*) | |||
|
22 | ||||
|
23 | (defun whole () | |||
|
24 | *whole*) | |||
|
25 | ||||
|
26 | (defun walk-continue (&optional subform) | |||
|
27 | (if subform | |||
|
28 | (walk *transformer-name* subform) | |||
|
29 | (mapcar (lambda (subform) | |||
|
30 | (walk *transformer-name* subform)) | |||
|
31 | *whole*))) | |||
|
32 | ||||
12 | (defun walk (transformer-name form) |
|
33 | (defun walk (transformer-name form) | |
13 | (if (listp form) |
|
34 | (let ((*transformer-name* transformer-name) | |
14 | (let ((transformer (gethash (list transformer-name (first form)) |
|
35 | (*whole* form)) | |
15 | *transformers*))) |
|
36 | (if (listp form) | |
16 | (if transformer |
|
37 | (let ((transformer (gethash (list transformer-name (first form)) | |
17 | (apply transformer (rest form)) |
|
38 | *transformers* nil))) | |
18 | (mapcar (lambda (subform) (walk transformer-name subform)) form))) |
|
39 | (if transformer | |
19 | form)) |
|
40 | (apply transformer (rest form)) | |
|
41 | (walk-continue))) | |||
|
42 | form))) |
General Comments 0
You need to be logged in to leave comments.
Login now