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,26 +1,26 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> | |
14 | <a id="qsp-btn-open"><img></a> |
|
14 | <a id="qsp-btn-open"><img></a> | |
15 | </div> |
|
15 | </div> | |
16 | </div> |
|
16 | </div> | |
17 |
|
17 | |||
18 | <div id="qsp-dropdown"> |
|
18 | <div id="qsp-dropdown"> | |
19 | </div> |
|
19 | </div> | |
20 |
|
20 | |||
21 | <div id="qsp-image-container" class="center-on-screen"> |
|
21 | <div id="qsp-image-container" class="center-on-screen"> | |
22 | <img id="qsp-image"> |
|
22 | <img id="qsp-image"> | |
23 | </div> |
|
23 | </div> | |
24 |
|
24 | |||
25 | <style id="qsp-style"> |
|
25 | <style id="qsp-style"> | |
26 | </style> |
|
26 | </style> |
@@ -1,551 +1,481 b'' | |||||
1 |
|
1 | |||
2 | (in-package sugar-qsp.api) |
|
2 | (in-package sugar-qsp.api) | |
3 |
|
3 | |||
4 | ;;; API deals with DOM manipulation and some bookkeeping for the |
|
4 | ;;; API deals with DOM manipulation and some bookkeeping for the | |
5 | ;;; intrinsics, namely variables |
|
5 | ;;; intrinsics, namely variables | |
6 | ;;; API is an implementation detail and has no QSP documentation. It |
|
6 | ;;; API is an implementation detail and has no QSP documentation. It | |
7 | ;;; doesn't call intrinsics |
|
7 | ;;; doesn't call intrinsics | |
8 |
|
8 | |||
9 | ;;; Utils |
|
9 | ;;; Utils | |
10 |
|
10 | |||
11 | (defun make-act-html (title img) |
|
11 | (defun make-act-html (title img) | |
12 | (+ "<a class='qsp-act' href='" (href-call call-act title) "' onmouseover='" (inline-call select-act title) "'>" |
|
12 | (+ "<a class='qsp-act' href='" (href-call call-act title) "' onmouseover='" (inline-call select-act title) "'>" | |
13 | (if img (+ "<img src='" img "'>") "") |
|
13 | (if img (+ "<img src='" img "'>") "") | |
14 | title |
|
14 | title | |
15 | "</a>")) |
|
15 | "</a>")) | |
16 |
|
16 | |||
17 | (defun make-menu-item-html (num title img loc) |
|
17 | (defun make-menu-item-html (num title img loc) | |
18 | (+ "<a href='" (href-call finish-menu loc) "'>" |
|
18 | (+ "<a href='" (href-call finish-menu loc) "'>" | |
19 | (if img (+ "<img src='" img "'>") "") |
|
19 | (if img (+ "<img src='" img "'>") "") | |
20 | title |
|
20 | title | |
21 | "</a>")) |
|
21 | "</a>")) | |
22 |
|
22 | |||
23 | (defun make-obj (title img selected) |
|
23 | (defun make-obj (title img selected) | |
24 | (+ "<li onclick='" (inline-call select-obj title img) "'>" |
|
24 | (+ "<li onclick='" (inline-call select-obj title img) "'>" | |
25 | "<a class='qsp-obj" (if selected " qsp-obj-selected" "") "'>" |
|
25 | "<a class='qsp-obj" (if selected " qsp-obj-selected" "") "'>" | |
26 | (if img (+ "<img src='" img "'>") "") |
|
26 | (if img (+ "<img src='" img "'>") "") | |
27 | title |
|
27 | title | |
28 | "</a>")) |
|
28 | "</a>")) | |
29 |
|
29 | |||
30 | (defun make-menu-delimiter () |
|
30 | (defun make-menu-delimiter () | |
31 | "<hr>") |
|
31 | "<hr>") | |
32 |
|
32 | |||
33 | (defun report-error (text) |
|
33 | (defun report-error (text) | |
34 | (alert text)) |
|
34 | (alert text)) | |
35 |
|
35 | |||
36 | (defun start-sleeping () |
|
36 | (defun start-sleeping () | |
37 | (chain (by-id "qsp") class-list (add "disable"))) |
|
37 | (chain (by-id "qsp") class-list (add "disable"))) | |
38 |
|
38 | |||
39 | (defun finish-sleeping () |
|
39 | (defun finish-sleeping () | |
40 | (chain (by-id "qsp") class-list (remove "disable"))) |
|
40 | (chain (by-id "qsp") class-list (remove "disable"))) | |
41 |
|
41 | |||
42 | (defun sleep (msec) |
|
42 | (defun sleep (msec) | |
43 | (with-sleep (resume) |
|
43 | (with-sleep (resume) | |
44 | (set-timeout resume msec))) |
|
44 | (set-timeout resume msec))) | |
45 |
|
45 | |||
46 | (defun init-dom () |
|
46 | (defun init-dom () | |
47 | ;; Save/load buttons |
|
47 | ;; Save/load buttons | |
48 | (let ((btn (by-id "qsp-btn-save"))) |
|
48 | (let ((btn (by-id "qsp-btn-save"))) | |
49 | (setf (@ btn onclick) savegame) |
|
49 | (setf (@ btn onclick) savegame) | |
50 | (setf (@ btn href) "#")) |
|
50 | (setf (@ btn href) "#")) | |
51 | (let ((btn (by-id "qsp-btn-open"))) |
|
51 | (let ((btn (by-id "qsp-btn-open"))) | |
52 | (setf (@ btn onclick) opengame) |
|
52 | (setf (@ btn onclick) opengame) | |
53 | (setf (@ btn href) "#")) |
|
53 | (setf (@ btn href) "#")) | |
54 | ;; Close image on click |
|
54 | ;; Close image on click | |
55 | (setf (@ (by-id "qsp-image-container") onclick) |
|
55 | (setf (@ (by-id "qsp-image-container") onclick) | |
56 | show-image) |
|
56 | show-image) | |
57 | ;; Enter in input field |
|
57 | ;; Enter in input field | |
58 | (setf (@ (get-frame :input) onkeyup) |
|
58 | (setf (@ (get-frame :input) onkeyup) | |
59 | on-input-key) |
|
59 | on-input-key) | |
60 | ;; Close the dropdown on any click |
|
60 | ;; Close the dropdown on any click | |
61 | (setf (@ window onclick) |
|
61 | (setf (@ window onclick) | |
62 | (lambda (event) |
|
62 | (lambda (event) | |
63 | (setf (@ window mouse) |
|
63 | (setf (@ window mouse) | |
64 | (list (@ event page-x) |
|
64 | (list (@ event page-x) | |
65 | (@ event page-y))) |
|
65 | (@ event page-y))) | |
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 | |
73 | (call-loc loc-name args)))))) |
|
73 | (call-loc loc-name args)))))) | |
74 |
|
74 | |||
75 | (defun filename-game (filename) |
|
75 | (defun filename-game (filename) | |
76 | (let ((game-name (chain filename (match "(.*/)?([^.]+)(\\.[a-zA-Z]+)?") 2)))) |
|
76 | (let ((game-name (chain filename (match "(.*/)?([^.]+)(\\.[a-zA-Z]+)?") 2)))) | |
77 | (getprop (root games) game-name)) |
|
77 | (getprop (root games) game-name)) | |
78 |
|
78 | |||
79 | (defun run-game (name) |
|
79 | (defun run-game (name) | |
80 | (let ((game (filename-game name))) |
|
80 | (let ((game (filename-game name))) | |
81 | (setf (root main-game) name) |
|
81 | (setf (root main-game) name) | |
82 | ;; Replace locations with the new game's |
|
82 | ;; Replace locations with the new game's | |
83 | (setf (root locs) game) |
|
83 | (setf (root locs) game) | |
84 | (funcall (getprop game |
|
84 | (funcall (getprop game | |
85 | (chain *object (keys game) 0)) |
|
85 | (chain *object (keys game) 0)) | |
86 | (list)))) |
|
86 | (list)))) | |
87 |
|
87 | |||
88 | ;;; Misc |
|
88 | ;;; Misc | |
89 |
|
89 | |||
90 | (defun newline (key) |
|
90 | (defun newline (key) | |
91 | (append-id (key-to-id key) "<br>" t)) |
|
91 | (append-id (key-to-id key) "<br>" t)) | |
92 |
|
92 | |||
93 | (defun clear-id (id) |
|
93 | (defun clear-id (id) | |
94 | (setf (inner-html (by-id id)) "")) |
|
94 | (setf (inner-html (by-id id)) "")) | |
95 |
|
95 | |||
96 | (defun escape-html (text) |
|
96 | (defun escape-html (text) | |
97 | (chain text |
|
97 | (chain text | |
98 | (replace (regex "/&/g") "&") |
|
98 | (replace (regex "/&/g") "&") | |
99 | (replace (regex "/</g") "<") |
|
99 | (replace (regex "/</g") "<") | |
100 | (replace (regex "/>/g") ">") |
|
100 | (replace (regex "/>/g") ">") | |
101 | (replace (regex "/\"/g") """) |
|
101 | (replace (regex "/\"/g") """) | |
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 | |||
109 | (defun get-id (id &optional force-html) |
|
110 | (defun get-id (id &optional force-html) | |
110 | (inner-html (by-id id))) |
|
111 | (inner-html (by-id id))) | |
111 |
|
112 | |||
112 | (defun set-id (id contents &optional force-html) |
|
113 | (defun set-id (id contents &optional force-html) | |
113 | (setf (inner-html (by-id id)) (prepare-contents contents force-html))) |
|
114 | (setf (inner-html (by-id id)) (prepare-contents contents force-html))) | |
114 |
|
115 | |||
115 | (defun append-id (id contents &optional force-html) |
|
116 | (defun append-id (id contents &optional force-html) | |
116 | (when contents |
|
117 | (when contents | |
117 | (incf (inner-html (by-id id)) (prepare-contents contents force-html)))) |
|
118 | (incf (inner-html (by-id id)) (prepare-contents contents force-html)))) | |
118 |
|
119 | |||
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 | |||
126 | (defun init-args (args) |
|
127 | (defun init-args (args) | |
127 | (dotimes (i (length args)) |
|
128 | (dotimes (i (length args)) | |
128 | (let ((arg (elt args i))) |
|
129 | (let ((arg (elt args i))) | |
129 | (if (numberp arg) |
|
130 | (if (numberp arg) | |
130 | (set-var args i :num arg) |
|
131 | (set-var args i :num arg) | |
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))) | |
140 | (with-frame |
|
140 | (with-frame | |
141 | (with-call-args args |
|
141 | (with-call-args args | |
142 | (funcall (getprop (root locs) name))))) |
|
142 | (funcall (getprop (root locs) name))))) | |
143 |
|
143 | |||
144 | (defun call-act (title) |
|
144 | (defun call-act (title) | |
145 | (with-frame |
|
145 | (with-frame | |
146 | (funcall (getprop (root acts) title :act)))) |
|
146 | (funcall (getprop (root acts) title :act)))) | |
147 |
|
147 | |||
148 | ;;; Text windows |
|
148 | ;;; Text windows | |
149 |
|
149 | |||
150 | (defun key-to-id (key) |
|
150 | (defun key-to-id (key) | |
151 | (case key |
|
151 | (case key | |
152 | (:all "qsp") |
|
152 | (:all "qsp") | |
153 | (:main "qsp-main") |
|
153 | (:main "qsp-main") | |
154 | (:stat "qsp-stat") |
|
154 | (:stat "qsp-stat") | |
155 | (:objs "qsp-objs") |
|
155 | (:objs "qsp-objs") | |
156 | (:acts "qsp-acts") |
|
156 | (:acts "qsp-acts") | |
157 | (:input "qsp-input") |
|
157 | (:input "qsp-input") | |
158 | (:image "qsp-image") |
|
158 | (:image "qsp-image") | |
159 | (:dropdown "qsp-dropdown") |
|
159 | (:dropdown "qsp-dropdown") | |
160 | (t (report-error "Internal error!")))) |
|
160 | (t (report-error "Internal error!")))) | |
161 |
|
161 | |||
162 | (defun get-frame (key) |
|
162 | (defun get-frame (key) | |
163 | (by-id (key-to-id key))) |
|
163 | (by-id (key-to-id key))) | |
164 |
|
164 | |||
165 | (defun add-text (key text) |
|
165 | (defun add-text (key text) | |
166 | (append-id (key-to-id key) text)) |
|
166 | (append-id (key-to-id key) text)) | |
167 |
|
167 | |||
168 | (defun get-text (key) |
|
168 | (defun get-text (key) | |
169 | (get-id (key-to-id key))) |
|
169 | (get-id (key-to-id key))) | |
170 |
|
170 | |||
171 | (defun clear-text (key) |
|
171 | (defun clear-text (key) | |
172 | (clear-id (key-to-id key))) |
|
172 | (clear-id (key-to-id key))) | |
173 |
|
173 | |||
174 | (defun enable-frame (key enable) |
|
174 | (defun enable-frame (key enable) | |
175 | (let ((obj (get-frame key))) |
|
175 | (let ((obj (get-frame key))) | |
176 | (setf (@ obj style display) (if enable "block" "none")) |
|
176 | (setf (@ obj style display) (if enable "block" "none")) | |
177 | (void))) |
|
177 | (void))) | |
178 |
|
178 | |||
179 | ;;; Actions |
|
179 | ;;; Actions | |
180 |
|
180 | |||
181 | (defun add-act (title img act) |
|
181 | (defun add-act (title img act) | |
182 | (setf (getprop (root acts) title) |
|
182 | (setf (getprop (root acts) title) | |
183 | (create :title title :img img :act act :selected nil)) |
|
183 | (create :title title :img img :act act :selected nil)) | |
184 | (update-acts)) |
|
184 | (update-acts)) | |
185 |
|
185 | |||
186 | (defun del-act (title) |
|
186 | (defun del-act (title) | |
187 | (delete (getprop (root acts) title)) |
|
187 | (delete (getprop (root acts) title)) | |
188 | (update-acts)) |
|
188 | (update-acts)) | |
189 |
|
189 | |||
190 | (defun clear-act () |
|
190 | (defun clear-act () | |
191 | (setf (root acts) (create)) |
|
191 | (setf (root acts) (create)) | |
192 | (update-acts)) |
|
192 | (update-acts)) | |
193 |
|
193 | |||
194 | (defun update-acts () |
|
194 | (defun update-acts () | |
195 | (clear-id "qsp-acts") |
|
195 | (clear-id "qsp-acts") | |
196 | (let ((elt (by-id "qsp-acts"))) |
|
196 | (let ((elt (by-id "qsp-acts"))) | |
197 | (for-in (title (root acts)) |
|
197 | (for-in (title (root acts)) | |
198 | (let ((obj (getprop (root acts) title))) |
|
198 | (let ((obj (getprop (root acts) title))) | |
199 | (incf (inner-html elt) (make-act-html title (getprop obj :img))))))) |
|
199 | (incf (inner-html elt) (make-act-html title (getprop obj :img))))))) | |
200 |
|
200 | |||
201 | (defun select-act (title) |
|
201 | (defun select-act (title) | |
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 | |||
209 | (defun qspfor (name index from to step body) |
|
209 | (defun qspfor (name index from to step body) | |
210 | (for ((i from)) |
|
210 | (for ((i from)) | |
211 | ((< i to)) |
|
211 | ((< i to)) | |
212 | ((incf i step)) |
|
212 | ((incf i step)) | |
213 | (set-var name index :num i) |
|
213 | (set-var name index :num i) | |
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)) | |
317 | (delete (getprop (root vars) name))) |
|
253 | (delete (getprop (root vars) name))) | |
318 | (void)) |
|
254 | (void)) | |
319 |
|
255 | |||
320 | (defun array-size (name) |
|
256 | (defun array-size (name) | |
321 | (@ (var-ref name) :values length)) |
|
257 | (@ (var-ref name) :values length)) | |
322 |
|
258 | |||
323 | ;;; Locals |
|
259 | ;;; Locals | |
324 |
|
260 | |||
325 | (defun push-local-frame () |
|
261 | (defun push-local-frame () | |
326 | (chain (root locals) (push (create))) |
|
262 | (chain (root locals) (push (create))) | |
327 | (void)) |
|
263 | (void)) | |
328 |
|
264 | |||
329 | (defun pop-local-frame () |
|
265 | (defun pop-local-frame () | |
330 | (chain (root locals) (pop)) |
|
266 | (chain (root locals) (pop)) | |
331 | (void)) |
|
267 | (void)) | |
332 |
|
268 | |||
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"))) | |
352 | (setf (inner-html elt) "<ul>") |
|
282 | (setf (inner-html elt) "<ul>") | |
353 | (loop :for (name obj) :of (root objs) |
|
283 | (loop :for (name obj) :of (root objs) | |
354 | :do (incf (inner-html elt) |
|
284 | :do (incf (inner-html elt) | |
355 | (make-obj name (@ obj :img) (@ obj :selected)))) |
|
285 | (make-obj name (@ obj :img) (@ obj :selected)))) | |
356 | (incf (inner-html elt) "</ul>"))) |
|
286 | (incf (inner-html elt) "</ul>"))) | |
357 |
|
287 | |||
358 | ;;; Menu |
|
288 | ;;; Menu | |
359 |
|
289 | |||
360 | (defun open-menu (menu-data) |
|
290 | (defun open-menu (menu-data) | |
361 | (let ((elt (get-frame :dropdown)) |
|
291 | (let ((elt (get-frame :dropdown)) | |
362 | (i 0)) |
|
292 | (i 0)) | |
363 | (loop :for item :in menu-data |
|
293 | (loop :for item :in menu-data | |
364 | :do (incf i) |
|
294 | :do (incf i) | |
365 | :do (incf (inner-html elt) |
|
295 | :do (incf (inner-html elt) | |
366 | (if (eq item :delimiter) |
|
296 | (if (eq item :delimiter) | |
367 | (make-menu-delimiter i) |
|
297 | (make-menu-delimiter i) | |
368 | (make-menu-item-html i |
|
298 | (make-menu-item-html i | |
369 | (@ item :text) |
|
299 | (@ item :text) | |
370 | (@ item :icon) |
|
300 | (@ item :icon) | |
371 | (@ item :loc))))) |
|
301 | (@ item :loc))))) | |
372 | (let ((mouse (@ window mouse))) |
|
302 | (let ((mouse (@ window mouse))) | |
373 | (setf (@ elt style left) (+ (elt mouse 0) "px")) |
|
303 | (setf (@ elt style left) (+ (elt mouse 0) "px")) | |
374 | (setf (@ elt style top) (+ (elt mouse 1) "px")) |
|
304 | (setf (@ elt style top) (+ (elt mouse 1) "px")) | |
375 | ;; Make sure it's inside the viewport |
|
305 | ;; Make sure it's inside the viewport | |
376 | (when (> (@ document body inner-width) |
|
306 | (when (> (@ document body inner-width) | |
377 | (+ (elt mouse 0) (@ elt inner-width))) |
|
307 | (+ (elt mouse 0) (@ elt inner-width))) | |
378 | (incf (@ elt style left) (@ elt inner-width))) |
|
308 | (incf (@ elt style left) (@ elt inner-width))) | |
379 | (when (> (@ document body inner-height) |
|
309 | (when (> (@ document body inner-height) | |
380 | (+ (elt mouse 0) (@ elt inner-height))) |
|
310 | (+ (elt mouse 0) (@ elt inner-height))) | |
381 | (incf (@ elt style top) (@ elt inner-height)))) |
|
311 | (incf (@ elt style top) (@ elt inner-height)))) | |
382 | (setf (@ elt style display) "block"))) |
|
312 | (setf (@ elt style display) "block"))) | |
383 |
|
313 | |||
384 | (defun finish-menu (loc) |
|
314 | (defun finish-menu (loc) | |
385 | (when (root menu-resume) |
|
315 | (when (root menu-resume) | |
386 | (let ((elt (get-frame :dropdown))) |
|
316 | (let ((elt (get-frame :dropdown))) | |
387 | (setf (inner-html elt) "") |
|
317 | (setf (inner-html elt) "") | |
388 | (setf (@ elt style display) "none") |
|
318 | (setf (@ elt style display) "none") | |
389 | (funcall (root menu-resume)) |
|
319 | (funcall (root menu-resume)) | |
390 | (setf (root menu-resume) nil)) |
|
320 | (setf (root menu-resume) nil)) | |
391 | (when loc |
|
321 | (when loc | |
392 | (call-loc loc))) |
|
322 | (call-loc loc))) | |
393 | (void)) |
|
323 | (void)) | |
394 |
|
324 | |||
395 | (defun menu (menu-data) |
|
325 | (defun menu (menu-data) | |
396 | (with-sleep (resume) |
|
326 | (with-sleep (resume) | |
397 | (open-menu menu-data) |
|
327 | (open-menu menu-data) | |
398 | (setf (root menu-resume) resume)) |
|
328 | (setf (root menu-resume) resume)) | |
399 | (void)) |
|
329 | (void)) | |
400 |
|
330 | |||
401 | ;;; Content |
|
331 | ;;; Content | |
402 |
|
332 | |||
403 | (defun clean-audio () |
|
333 | (defun clean-audio () | |
404 | (loop :for k :in (chain *object (keys (root playing))) |
|
334 | (loop :for k :in (chain *object (keys (root playing))) | |
405 | :for v := (getprop (root playing) k) |
|
335 | :for v := (getprop (root playing) k) | |
406 | :do (when (@ v ended) |
|
336 | :do (when (@ v ended) | |
407 | (delete (@ (root playing) k))))) |
|
337 | (delete (@ (root playing) k))))) | |
408 |
|
338 | |||
409 | (defun show-image (path) |
|
339 | (defun show-image (path) | |
410 | (let ((img (get-frame :image))) |
|
340 | (let ((img (get-frame :image))) | |
411 | (cond (path |
|
341 | (cond (path | |
412 | (setf (@ img src) path) |
|
342 | (setf (@ img src) path) | |
413 | (setf (@ img style display) "flex")) |
|
343 | (setf (@ img style display) "flex")) | |
414 | (t |
|
344 | (t | |
415 | (setf (@ img src) "") |
|
345 | (setf (@ img src) "") | |
416 | (setf (@ img style display) "hidden"))))) |
|
346 | (setf (@ img style display) "hidden"))))) | |
417 |
|
347 | |||
418 | (defun show-inline-images (frame-name images) |
|
348 | (defun show-inline-images (frame-name images) | |
419 | (let ((frame (get-frame frame-name)) |
|
349 | (let ((frame (get-frame frame-name)) | |
420 | (text "")) |
|
350 | (text "")) | |
421 | (incf text "<div style='position:relative; display: inline-block'>") |
|
351 | (incf text "<div style='position:relative; display: inline-block'>") | |
422 | (incf text (+ "<img src='" (@ images 0) "'>")) |
|
352 | (incf text (+ "<img src='" (@ images 0) "'>")) | |
423 | (loop :for image :in (chain images (slice 1)) |
|
353 | (loop :for image :in (chain images (slice 1)) | |
424 | :do (incf text |
|
354 | :do (incf text | |
425 | (+ "<img style='position:absolute' src='" image "'>"))) |
|
355 | (+ "<img style='position:absolute' src='" image "'>"))) | |
426 | (incf text "</div>") |
|
356 | (incf text "</div>") | |
427 | (incf (inner-html frame) text))) |
|
357 | (incf (inner-html frame) text))) | |
428 |
|
358 | |||
429 | (defun rgb-string (rgb) |
|
359 | (defun rgb-string (rgb) | |
430 | (let ((red (ps::>> rgb 16)) |
|
360 | (let ((red (ps::>> rgb 16)) | |
431 | (green (logand (ps::>> rgb 8) 255)) |
|
361 | (green (logand (ps::>> rgb 8) 255)) | |
432 | (blue (logand rgb 255))) |
|
362 | (blue (logand rgb 255))) | |
433 | (flet ((rgb-to-hex (comp) |
|
363 | (flet ((rgb-to-hex (comp) | |
434 | (let ((hex (chain (*number comp) (to-string 16)))) |
|
364 | (let ((hex (chain (*number comp) (to-string 16)))) | |
435 | (if (< (length hex) 2) |
|
365 | (if (< (length hex) 2) | |
436 | (+ "0" hex) |
|
366 | (+ "0" hex) | |
437 | hex)))) |
|
367 | hex)))) | |
438 | (+ "#" (rgb-to-hex red) (rgb-to-hex green) (rgb-to-hex red))))) |
|
368 | (+ "#" (rgb-to-hex red) (rgb-to-hex green) (rgb-to-hex red))))) | |
439 |
|
369 | |||
440 | ;;; Saves |
|
370 | ;;; Saves | |
441 |
|
371 | |||
442 | (defun opengame () |
|
372 | (defun opengame () | |
443 | (let ((element (chain document (create-element :input)))) |
|
373 | (let ((element (chain document (create-element :input)))) | |
444 | (chain element (set-attribute :type :file)) |
|
374 | (chain element (set-attribute :type :file)) | |
445 | (chain element (set-attribute :id :qsp-opengame)) |
|
375 | (chain element (set-attribute :id :qsp-opengame)) | |
446 | (chain element (set-attribute :tabindex -1)) |
|
376 | (chain element (set-attribute :tabindex -1)) | |
447 | (chain element (set-attribute "aria-hidden" t)) |
|
377 | (chain element (set-attribute "aria-hidden" t)) | |
448 | (setf (@ element style display) :block) |
|
378 | (setf (@ element style display) :block) | |
449 | (setf (@ element style visibility) :hidden) |
|
379 | (setf (@ element style visibility) :hidden) | |
450 | (setf (@ element style position) :fixed) |
|
380 | (setf (@ element style position) :fixed) | |
451 | (setf (@ element onchange) |
|
381 | (setf (@ element onchange) | |
452 | (lambda (event) |
|
382 | (lambda (event) | |
453 | (let* ((file (@ event target files 0)) |
|
383 | (let* ((file (@ event target files 0)) | |
454 | (reader (new (*file-reader)))) |
|
384 | (reader (new (*file-reader)))) | |
455 | (setf (@ reader onload) |
|
385 | (setf (@ reader onload) | |
456 | (lambda (ev) |
|
386 | (lambda (ev) | |
457 | (block nil |
|
387 | (block nil | |
458 | (let ((target (@ ev current-target))) |
|
388 | (let ((target (@ ev current-target))) | |
459 | (unless (@ target result) |
|
389 | (unless (@ target result) | |
460 | (return)) |
|
390 | (return)) | |
461 | (base64-to-state (@ target result)) |
|
391 | (base64-to-state (@ target result)) | |
462 | (unstash-state))))) |
|
392 | (unstash-state))))) | |
463 | (chain reader (read-as-text file))))) |
|
393 | (chain reader (read-as-text file))))) | |
464 | (chain document body (append-child element)) |
|
394 | (chain document body (append-child element)) | |
465 | (chain element (click)) |
|
395 | (chain element (click)) | |
466 | (chain document body (remove-child element)))) |
|
396 | (chain document body (remove-child element)))) | |
467 |
|
397 | |||
468 | (defun savegame () |
|
398 | (defun savegame () | |
469 | (let ((element (chain document (create-element :a)))) |
|
399 | (let ((element (chain document (create-element :a)))) | |
470 | (chain element (set-attribute :href (+ "data:text/plain;charset=utf-8," (state-to-base64)))) |
|
400 | (chain element (set-attribute :href (+ "data:text/plain;charset=utf-8," (state-to-base64)))) | |
471 | (chain element (set-attribute :download "savegame.sav")) |
|
401 | (chain element (set-attribute :download "savegame.sav")) | |
472 | (setf (@ element style display) :none) |
|
402 | (setf (@ element style display) :none) | |
473 | (chain document body (append-child element)) |
|
403 | (chain document body (append-child element)) | |
474 | (chain element (click)) |
|
404 | (chain element (click)) | |
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) | |
482 | :objs (root objs) |
|
412 | :objs (root objs) | |
483 | :loc-args args |
|
413 | :loc-args args | |
484 | :msecs (- (chain *date (now)) (root started-at)) |
|
414 | :msecs (- (chain *date (now)) (root started-at)) | |
485 | :timer-interval (root timer-interval) |
|
415 | :timer-interval (root timer-interval) | |
486 | :main-html (inner-html |
|
416 | :main-html (inner-html | |
487 | (get-frame :main)) |
|
417 | (get-frame :main)) | |
488 | :stat-html (inner-html |
|
418 | :stat-html (inner-html | |
489 | (get-frame :stat)) |
|
419 | (get-frame :stat)) | |
490 | :next-location (root current-location))))) |
|
420 | :next-location (root current-location))))) | |
491 | (void)) |
|
421 | (void)) | |
492 |
|
422 | |||
493 | (defun unstash-state () |
|
423 | (defun unstash-state () | |
494 | (let ((data (chain *j-s-o-n (parse (root state-stash))))) |
|
424 | (let ((data (chain *j-s-o-n (parse (root state-stash))))) | |
495 | (clear-act) |
|
425 | (clear-act) | |
496 | (setf (root vars) (@ data :vars)) |
|
426 | (setf (root vars) (@ data :vars)) | |
497 | (loop :for k :in (chain *object (keys (root vars))) |
|
427 | (loop :for k :in (chain *object (keys (root vars))) | |
498 | :do (chain *object (set-prototype-of (getprop (root vars) k) |
|
428 | :do (chain *object (set-prototype-of (getprop (root vars) k) | |
499 | (@ *var prototype)))) |
|
429 | (@ *var prototype)))) | |
500 | (setf (root started-at) (- (chain *date (now)) (@ data :msecs))) |
|
430 | (setf (root started-at) (- (chain *date (now)) (@ data :msecs))) | |
501 | (setf (root objs) (@ data :objs)) |
|
431 | (setf (root objs) (@ data :objs)) | |
502 | (setf (root current-location) (@ data :next-location)) |
|
432 | (setf (root current-location) (@ data :next-location)) | |
503 | (setf (inner-html (get-frame :main)) |
|
433 | (setf (inner-html (get-frame :main)) | |
504 | (@ data :main-html)) |
|
434 | (@ data :main-html)) | |
505 | (setf (inner-html (get-frame :stat)) |
|
435 | (setf (inner-html (get-frame :stat)) | |
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 | |||
513 | (defun state-to-base64 () |
|
443 | (defun state-to-base64 () | |
514 | (btoa (encode-u-r-i-component (root state-stash)))) |
|
444 | (btoa (encode-u-r-i-component (root state-stash)))) | |
515 |
|
445 | |||
516 | (defun base64-to-state (data) |
|
446 | (defun base64-to-state (data) | |
517 | (setf (root state-stash) (decode-u-r-i-component (atob data)))) |
|
447 | (setf (root state-stash) (decode-u-r-i-component (atob data)))) | |
518 |
|
448 | |||
519 | ;;; Timers |
|
449 | ;;; Timers | |
520 |
|
450 | |||
521 | (defun set-timer (interval) |
|
451 | (defun set-timer (interval) | |
522 | (setf (root timer-interval) interval) |
|
452 | (setf (root timer-interval) interval) | |
523 | (clear-interval (root timer-obj)) |
|
453 | (clear-interval (root timer-obj)) | |
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 | |
531 |
|
461 | |||
532 | (defvar serv-vars (create)) |
|
462 | (defvar serv-vars (create)) | |
533 |
|
463 | |||
534 | (define-serv-var backimage (:str path) |
|
464 | (define-serv-var backimage (:str path) | |
535 | (setf (@ (get-frame :main) style background-image) path)) |
|
465 | (setf (@ (get-frame :main) style background-image) path)) | |
536 |
|
466 | |||
537 | (define-serv-var bcolor (:num color) |
|
467 | (define-serv-var bcolor (:num color) | |
538 | (setf (@ (get-frame :all) style background-color) (rgb-string color))) |
|
468 | (setf (@ (get-frame :all) style background-color) (rgb-string color))) | |
539 |
|
469 | |||
540 | (define-serv-var fcolor (:num color) |
|
470 | (define-serv-var fcolor (:num color) | |
541 | (setf (@ (get-frame :all) style color) (rgb-string color))) |
|
471 | (setf (@ (get-frame :all) style color) (rgb-string color))) | |
542 |
|
472 | |||
543 | (define-serv-var lcolor (:num color) |
|
473 | (define-serv-var lcolor (:num color) | |
544 | (setf (@ (get-frame :style) inner-text) |
|
474 | (setf (@ (get-frame :style) inner-text) | |
545 | (+ "a { color: " (rgb-string color) ";}"))) |
|
475 | (+ "a { color: " (rgb-string color) ";}"))) | |
546 |
|
476 | |||
547 | (define-serv-var fsize (:num size) |
|
477 | (define-serv-var fsize (:num size) | |
548 | (setf (@ (get-frame :all) style font-size) size)) |
|
478 | (setf (@ (get-frame :all) style font-size) size)) | |
549 |
|
479 | |||
550 | (define-serv-var fname (:str font-name) |
|
480 | (define-serv-var fname (:str font-name) | |
551 | (setf (@ (get-frame :all) style font-family) (+ font-name ",serif"))) |
|
481 | (setf (@ (get-frame :all) style font-family) (+ font-name ",serif"))) |
@@ -1,99 +1,104 b'' | |||||
1 |
|
1 | |||
2 | (in-package cl-user) |
|
2 | (in-package cl-user) | |
3 |
|
3 | |||
4 | (defpackage :sugar-qsp.js) |
|
4 | (defpackage :sugar-qsp.js) | |
5 |
|
5 | |||
6 | (defpackage :sugar-qsp.main |
|
6 | (defpackage :sugar-qsp.main | |
7 | (:use :cl :ps :sugar-qsp.js) |
|
7 | (:use :cl :ps :sugar-qsp.js) | |
8 | (:export #:api-call #:by-id |
|
8 | (:export #:api-call #:by-id | |
9 | #:root #:in |
|
9 | #:root #:in | |
10 | #:vars #:objs #:current-location |
|
10 | #:vars #:objs #:current-location | |
11 | #:started-at #:timer-interval #:timer-obj |
|
11 | #:started-at #:timer-interval #:timer-obj | |
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) | |
18 | (:export #:with-frame #:with-call-args |
|
26 | (:export #:with-frame #:with-call-args | |
19 | #:stash-state |
|
27 | #:stash-state | |
20 |
|
28 | |||
21 | #:report-error #:sleep #:init-dom #:call-serv-loc |
|
29 | #:report-error #:sleep #:init-dom #:call-serv-loc | |
22 | #:newline #:clear-id #:prepare-contents #:get-id #:set-id #:append-id |
|
30 | #:newline #:clear-id #:prepare-contents #:get-id #:set-id #:append-id | |
23 | #:init-args #:get-result #:call-loc #:call-act |
|
31 | #:init-args #:get-result #:call-loc #:call-act | |
24 | #:get-frame #:add-text #:get-text #:clear-text #:enable-frame |
|
32 | #:get-frame #:add-text #:get-text #:clear-text #:enable-frame | |
25 | #:add-act #:del-act #:clear-act #:update-acts |
|
33 | #:add-act #:del-act #:clear-act #:update-acts | |
26 | #:qspfor |
|
34 | #:qspfor | |
27 | #:*var #:new-value #:index-num #:get #:set #:kill |
|
35 | #:*var #:new-value #:index-num #:get #:set #:kill | |
28 | #:var-real-name #:ensure-var #:var-ref #:get-var #:set-var |
|
36 | #:var-real-name #:ensure-var #:var-ref #:get-var #:set-var | |
29 | #:get-array #:set-array #:kill-var #:array-size |
|
37 | #:get-array #:set-array #:kill-var #:array-size | |
30 | #:push-local-frame #:pop-local-frame #:current-local-frame #:new-local |
|
38 | #:push-local-frame #:pop-local-frame #:current-local-frame #:new-local | |
31 | #:update-objs |
|
39 | #:update-objs | |
32 | #:menu |
|
40 | #:menu | |
33 | #:clean-audio |
|
41 | #:clean-audio | |
34 | #:show-image |
|
42 | #:show-image | |
35 | #:opengame #:savegame |
|
43 | #:opengame #:savegame | |
36 | )) |
|
44 | )) | |
37 |
|
45 | |||
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 | |||
45 | #:killvar #:killall |
|
54 | #:killvar #:killall | |
46 | #:obj #:loc #:no |
|
55 | #:obj #:loc #:no | |
47 | #:qspver #:curloc |
|
56 | #:qspver #:curloc | |
48 | #:rnd #:qspmax #:qspmin |
|
57 | #:rnd #:qspmax #:qspmin | |
49 | #:arrsize #:len |
|
58 | #:arrsize #:len | |
50 | #:mid #:ucase #:lcase #:trim #:replace #:val #:qspstr |
|
59 | #:mid #:ucase #:lcase #:trim #:replace #:val #:qspstr | |
51 | #:exit #:desc |
|
60 | #:exit #:desc | |
52 | #:showstat #:msg |
|
61 | #:showstat #:msg | |
53 | #:showacts #:delact #:cla |
|
62 | #:showacts #:delact #:cla | |
54 | #:showobjs #:countobj #:getobj |
|
63 | #:showobjs #:countobj #:getobj | |
55 | #:isplay |
|
64 | #:isplay | |
56 | #:view |
|
65 | #:view | |
57 | #:showinput |
|
66 | #:showinput | |
58 | #:wait #:settimer |
|
67 | #:wait #:settimer | |
59 | #:local |
|
68 | #:local | |
60 | #:opengame #:savegame |
|
69 | #:opengame #:savegame | |
61 |
|
70 | |||
62 | #:goto #:xgoto |
|
71 | #:goto #:xgoto | |
63 | #:rand |
|
72 | #:rand | |
64 | #:copyarr #:arrpos #:arrcomp |
|
73 | #:copyarr #:arrpos #:arrcomp | |
65 | #:instr #:isnum #:strcomp #:strfind #:strpos |
|
74 | #:instr #:isnum #:strcomp #:strfind #:strpos | |
66 | #:iif |
|
75 | #:iif | |
67 | #:gosub #:func |
|
76 | #:gosub #:func | |
68 | #:dynamic #:dyneval |
|
77 | #:dynamic #:dyneval | |
69 | #:main-p #:main-pl #:main-nl #:maintxt #:desc #:main-clear |
|
78 | #:main-p #:main-pl #:main-nl #:maintxt #:desc #:main-clear | |
70 | #:stat-p #:stat-pl #:stat-nl #:stattxt #:stat-clear #:cls |
|
79 | #:stat-p #:stat-pl #:stat-nl #:stattxt #:stat-clear #:cls | |
71 | #:curacts |
|
80 | #:curacts | |
72 | #:addobj #:delobj #:killobj |
|
81 | #:addobj #:delobj #:killobj | |
73 | #:menu |
|
82 | #:menu | |
74 | #:play #:close #:closeall |
|
83 | #:play #:close #:closeall | |
75 | #:refint |
|
84 | #:refint | |
76 | #:usertxt #:cmdclear #:input |
|
85 | #:usertxt #:cmdclear #:input | |
77 | #:msecscount |
|
86 | #:msecscount | |
78 | #:rgb |
|
87 | #:rgb | |
79 | #:openqst #:addqst #:killqst |
|
88 | #:openqst #:addqst #:killqst | |
80 | )) |
|
89 | )) | |
81 |
|
90 | |||
82 | (setf (ps:ps-package-prefix "SUGAR-QSP.MAIN") "qsp_") |
|
91 | (setf (ps:ps-package-prefix "SUGAR-QSP.MAIN") "qsp_") | |
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 |
@@ -1,627 +1,623 b'' | |||||
1 |
|
1 | |||
2 | (in-package sugar-qsp) |
|
2 | (in-package sugar-qsp) | |
3 |
|
3 | |||
4 | ;;;; Parses TXT source to an intermediate representation |
|
4 | ;;;; Parses TXT source to an intermediate representation | |
5 |
|
5 | |||
6 | (eval-when (:compile-toplevel :load-toplevel :execute) |
|
6 | (eval-when (:compile-toplevel :load-toplevel :execute) | |
7 | (defparameter *max-args* 10)) |
|
7 | (defparameter *max-args* 10)) | |
8 |
|
8 | |||
9 | ;;; Utility |
|
9 | ;;; Utility | |
10 |
|
10 | |||
11 | (defun remove-nth (list nth) |
|
11 | (defun remove-nth (list nth) | |
12 | (append (subseq list 0 nth) |
|
12 | (append (subseq list 0 nth) | |
13 | (subseq list (1+ nth)))) |
|
13 | (subseq list (1+ nth)))) | |
14 |
|
14 | |||
15 | (defun not-quote (char) |
|
15 | (defun not-quote (char) | |
16 | (not (eql #\' char))) |
|
16 | (not (eql #\' char))) | |
17 |
|
17 | |||
18 |
|
18 | |||
19 | (defun not-doublequote (char) |
|
19 | (defun not-doublequote (char) | |
20 | (not (eql #\" char))) |
|
20 | (not (eql #\" char))) | |
21 |
|
21 | |||
22 | (defun not-brace (char) |
|
22 | (defun not-brace (char) | |
23 | (not (eql #\} char))) |
|
23 | (not (eql #\} char))) | |
24 |
|
24 | |||
25 | (defun not-integer (string) |
|
25 | (defun not-integer (string) | |
26 | (when (find-if-not #'digit-char-p string) |
|
26 | (when (find-if-not #'digit-char-p string) | |
27 | t)) |
|
27 | t)) | |
28 |
|
28 | |||
29 | (defun not-newline (char) |
|
29 | (defun not-newline (char) | |
30 | (not (eql #\newline char))) |
|
30 | (not (eql #\newline char))) | |
31 |
|
31 | |||
32 | (defun id-any-char (char) |
|
32 | (defun id-any-char (char) | |
33 | (and |
|
33 | (and | |
34 | (not (digit-char-p char)) |
|
34 | (not (digit-char-p char)) | |
35 | (not (eql #\newline char)) |
|
35 | (not (eql #\newline char)) | |
36 | (not (find char " !:&=<>+-*/,'\"()[]{}")))) |
|
36 | (not (find char " !:&=<>+-*/,'\"()[]{}")))) | |
37 |
|
37 | |||
38 | (defun intern-first (list) |
|
38 | (defun intern-first (list) | |
39 | (list* (intern (string-upcase (first list)) :lib) |
|
39 | (list* (intern (string-upcase (first list)) :lib) | |
40 | (rest list))) |
|
40 | (rest list))) | |
41 |
|
41 | |||
42 | (eval-when (:compile-toplevel :load-toplevel :execute) |
|
42 | (eval-when (:compile-toplevel :load-toplevel :execute) | |
43 | (defun remove-nil (list) |
|
43 | (defun remove-nil (list) | |
44 | (remove nil list))) |
|
44 | (remove nil list))) | |
45 |
|
45 | |||
46 | (defun binop-rest (list) |
|
46 | (defun binop-rest (list) | |
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) | |
54 | left-op |
|
54 | left-op | |
55 | (destructuring-bind ((operator right-op) &rest rest-ops) |
|
55 | (destructuring-bind ((operator right-op) &rest rest-ops) | |
56 | other-ops |
|
56 | other-ops | |
57 | (if (and (listp left-op) |
|
57 | (if (and (listp left-op) | |
58 | (eq (first left-op) |
|
58 | (eq (first left-op) | |
59 | operator)) |
|
59 | operator)) | |
60 | (do-binop% (append left-op (list right-op)) rest-ops) |
|
60 | (do-binop% (append left-op (list right-op)) rest-ops) | |
61 | (do-binop% (list operator left-op right-op) rest-ops))))) |
|
61 | (do-binop% (list operator left-op right-op) rest-ops))))) | |
62 |
|
62 | |||
63 | (defun do-binop (list) |
|
63 | (defun do-binop (list) | |
64 | (destructuring-bind (left-op rest-ops) |
|
64 | (destructuring-bind (left-op rest-ops) | |
65 | list |
|
65 | list | |
66 | (do-binop% left-op |
|
66 | (do-binop% left-op | |
67 | (mapcar #'binop-rest rest-ops)))) |
|
67 | (mapcar #'binop-rest rest-ops)))) | |
68 |
|
68 | |||
69 | (p:defrule line-continuation (and #\_ #\newline) |
|
69 | (p:defrule line-continuation (and #\_ #\newline) | |
70 | (:constant nil)) |
|
70 | (:constant nil)) | |
71 |
|
71 | |||
72 | (p:defrule text-spaces (+ (or #\space #\tab line-continuation)) |
|
72 | (p:defrule text-spaces (+ (or #\space #\tab line-continuation)) | |
73 | (:text t)) |
|
73 | (:text t)) | |
74 |
|
74 | |||
75 | (p:defrule spaces (+ (or #\space #\tab line-continuation)) |
|
75 | (p:defrule spaces (+ (or #\space #\tab line-continuation)) | |
76 | (:constant nil) |
|
76 | (:constant nil) | |
77 | (:error-report nil)) |
|
77 | (:error-report nil)) | |
78 |
|
78 | |||
79 | (p:defrule spaces? (* (or #\space #\tab line-continuation)) |
|
79 | (p:defrule spaces? (* (or #\space #\tab line-continuation)) | |
80 | (:constant nil) |
|
80 | (:constant nil) | |
81 | (:error-report nil)) |
|
81 | (:error-report nil)) | |
82 |
|
82 | |||
83 | (p:defrule colon #\: |
|
83 | (p:defrule colon #\: | |
84 | (:constant nil)) |
|
84 | (:constant nil)) | |
85 |
|
85 | |||
86 | (p:defrule equal #\= |
|
86 | (p:defrule equal #\= | |
87 | (:constant nil)) |
|
87 | (:constant nil)) | |
88 |
|
88 | |||
89 | (p:defrule alphanumeric (alphanumericp character)) |
|
89 | (p:defrule alphanumeric (alphanumericp character)) | |
90 |
|
90 | |||
91 | (p:defrule not-newline (not-newline character)) |
|
91 | (p:defrule not-newline (not-newline character)) | |
92 |
|
92 | |||
93 | (p:defrule squote-esc "''" |
|
93 | (p:defrule squote-esc "''" | |
94 | (:lambda (list) |
|
94 | (:lambda (list) | |
95 | (p:text (elt list 0)))) |
|
95 | (p:text (elt list 0)))) | |
96 |
|
96 | |||
97 | (p:defrule dquote-esc "\"\"" |
|
97 | (p:defrule dquote-esc "\"\"" | |
98 | (:lambda (list) |
|
98 | (:lambda (list) | |
99 | (p:text (elt list 0)))) |
|
99 | (p:text (elt list 0)))) | |
100 |
|
100 | |||
101 | (p:defrule sstring-chars (+ (and (and (p:! "<<") (p:! (p:~ "\"exec:"))) |
|
101 | (p:defrule sstring-chars (+ (and (and (p:! "<<") (p:! (p:~ "\"exec:"))) | |
102 | (or squote-esc (not-quote character)))) |
|
102 | (or squote-esc (not-quote character)))) | |
103 | (:lambda (list) |
|
103 | (:lambda (list) | |
104 | (p:text (mapcar #'second list)))) |
|
104 | (p:text (mapcar #'second list)))) | |
105 |
|
105 | |||
106 | (p:defrule dstring-chars (+ (and (and (p:! "<<") (p:! (p:~ "'exec:"))) |
|
106 | (p:defrule dstring-chars (+ (and (and (p:! "<<") (p:! (p:~ "'exec:"))) | |
107 | (or dquote-esc (not-doublequote character)))) |
|
107 | (or dquote-esc (not-doublequote character)))) | |
108 | (:lambda (list) |
|
108 | (:lambda (list) | |
109 | (p:text (mapcar #'second list)))) |
|
109 | (p:text (mapcar #'second list)))) | |
110 |
|
110 | |||
111 | ;;; Identifiers |
|
111 | ;;; Identifiers | |
112 |
|
112 | |||
113 | (defparameter *keywords* '(act addlib addobj addqst and arrcomp arrpos arrsize cla clear *clear close clr *clr cls cmdclear cmdclr copyarr counter countobj curacts curloc debug delact dellib delobj desc disablescroll disablesubex dynamic dyneval else elseif end exit for freelib func getobj gosub goto gs gt if iif img *img inclib input instr isnum isplay jump killall killobj killqst killvar lcase lcolor len let loc local maintxt max menu mid min mod msecscount msg nl *nl no nosave obj opengame openqst or p *p pl *pl play qspver rand refint replace rgb rnd savegame selact selobj set settimer showacts showinput showobjs showstat stattxt step str strcomp strfind strpos to trim ucase unsel unselect usercom user_text usrtxt val view wait xgoto xgt)) |
|
113 | (defparameter *keywords* '(act addlib addobj addqst and arrcomp arrpos arrsize cla clear *clear close clr *clr cls cmdclear cmdclr copyarr counter countobj curacts curloc debug delact dellib delobj desc disablescroll disablesubex dynamic dyneval else elseif end exit for freelib func getobj gosub goto gs gt if iif img *img inclib input instr isnum isplay jump killall killobj killqst killvar lcase lcolor len let loc local maintxt max menu mid min mod msecscount msg nl *nl no nosave obj opengame openqst or p *p pl *pl play qspver rand refint replace rgb rnd savegame selact selobj set settimer showacts showinput showobjs showstat stattxt step str strcomp strfind strpos to trim ucase unsel unselect usercom user_text usrtxt val view wait xgoto xgt)) | |
114 |
|
114 | |||
115 | (defun trim-$ (str) |
|
115 | (defun trim-$ (str) | |
116 | (if (char= #\$ (elt str 0)) |
|
116 | (if (char= #\$ (elt str 0)) | |
117 | (subseq str 1) |
|
117 | (subseq str 1) | |
118 | str)) |
|
118 | str)) | |
119 |
|
119 | |||
120 | (defun qsp-keyword-p (id) |
|
120 | (defun qsp-keyword-p (id) | |
121 | (member (intern (trim-$ (string-upcase id))) *keywords*)) |
|
121 | (member (intern (trim-$ (string-upcase id))) *keywords*)) | |
122 |
|
122 | |||
123 | (defun not-qsp-keyword-p (id) |
|
123 | (defun not-qsp-keyword-p (id) | |
124 | (not (member (intern (trim-$ (string-upcase id))) *keywords*))) |
|
124 | (not (member (intern (trim-$ (string-upcase id))) *keywords*))) | |
125 |
|
125 | |||
126 | (p:defrule qsp-keyword (qsp-keyword-p identifier-raw)) |
|
126 | (p:defrule qsp-keyword (qsp-keyword-p identifier-raw)) | |
127 |
|
127 | |||
128 | (p:defrule id-first (id-any-char character)) |
|
128 | (p:defrule id-first (id-any-char character)) | |
129 | (p:defrule id-next (or (id-any-char character) |
|
129 | (p:defrule id-next (or (id-any-char character) | |
130 | (digit-char-p character))) |
|
130 | (digit-char-p character))) | |
131 | (p:defrule identifier-raw (and id-first (* id-next)) |
|
131 | (p:defrule identifier-raw (and id-first (* id-next)) | |
132 | (:lambda (list) |
|
132 | (:lambda (list) | |
133 | (intern (string-upcase (p:text list)) :lib))) |
|
133 | (intern (string-upcase (p:text list)) :lib))) | |
134 |
|
134 | |||
135 | (p:defrule identifier (not-qsp-keyword-p identifier-raw)) |
|
135 | (p:defrule identifier (not-qsp-keyword-p identifier-raw)) | |
136 |
|
136 | |||
137 | ;;; Strings |
|
137 | ;;; Strings | |
138 |
|
138 | |||
139 | (p:defrule qsp-string (or normal-string brace-string)) |
|
139 | (p:defrule qsp-string (or normal-string brace-string)) | |
140 |
|
140 | |||
141 | (p:defrule normal-string (or sstring dstring) |
|
141 | (p:defrule normal-string (or sstring dstring) | |
142 | (:lambda (str) |
|
142 | (:lambda (str) | |
143 | (list* 'lib:str (or str (list ""))))) |
|
143 | (list* 'lib:str (or str (list ""))))) | |
144 |
|
144 | |||
145 | (p:defrule sstring (and #\' (* (or string-interpol |
|
145 | (p:defrule sstring (and #\' (* (or string-interpol | |
146 | sstring-exec |
|
146 | sstring-exec | |
147 | sstring-chars)) |
|
147 | sstring-chars)) | |
148 | #\') |
|
148 | #\') | |
149 | (:function second)) |
|
149 | (:function second)) | |
150 |
|
150 | |||
151 | (p:defrule dstring (and #\" (* (or string-interpol |
|
151 | (p:defrule dstring (and #\" (* (or string-interpol | |
152 | dstring-exec |
|
152 | dstring-exec | |
153 | dstring-chars)) |
|
153 | dstring-chars)) | |
154 | #\") |
|
154 | #\") | |
155 | (:function second)) |
|
155 | (:function second)) | |
156 |
|
156 | |||
157 | (p:defrule string-interpol (and "<<" expression ">>") |
|
157 | (p:defrule string-interpol (and "<<" expression ">>") | |
158 | (:function second)) |
|
158 | (:function second)) | |
159 |
|
159 | |||
160 | (p:defrule sstring-exec-body (+ (or squote-esc (not-doublequote character))) |
|
160 | (p:defrule sstring-exec-body (+ (or squote-esc (not-doublequote character))) | |
161 | (:text t)) |
|
161 | (:text t)) | |
162 |
|
162 | |||
163 | (p:defrule dstring-exec-body (+ (or dquote-esc (not-quote character))) |
|
163 | (p:defrule dstring-exec-body (+ (or dquote-esc (not-quote character))) | |
164 | (:text t)) |
|
164 | (:text t)) | |
165 |
|
165 | |||
166 | (p:defrule sstring-exec (and (p:~ "\"exec:") sstring-exec-body #\") |
|
166 | (p:defrule sstring-exec (and (p:~ "\"exec:") sstring-exec-body #\") | |
167 | (:lambda (list) |
|
167 | (:lambda (list) | |
168 | (list* 'lib:exec (p:parse 'exec-body (second list))))) |
|
168 | (list* 'lib:exec (p:parse 'exec-body (second list))))) | |
169 |
|
169 | |||
170 | (p:defrule dstring-exec (and (p:~ "'exec:") dstring-exec-body #\') |
|
170 | (p:defrule dstring-exec (and (p:~ "'exec:") dstring-exec-body #\') | |
171 | (:lambda (list) |
|
171 | (:lambda (list) | |
172 | (list* 'lib:exec (p:parse 'exec-body (second list))))) |
|
172 | (list* 'lib:exec (p:parse 'exec-body (second list))))) | |
173 |
|
173 | |||
174 | (p:defrule brace-string (and #\{ before-statement block-body #\}) |
|
174 | (p:defrule brace-string (and #\{ before-statement block-body #\}) | |
175 | (:lambda (list) |
|
175 | (:lambda (list) | |
176 | (list* 'lib:qspblock (third list)))) |
|
176 | (list* 'lib:qspblock (third list)))) | |
177 |
|
177 | |||
178 | ;;; Location |
|
178 | ;;; Location | |
179 |
|
179 | |||
180 | (p:defrule sugar-qsp-grammar (and (* (or spaces #\newline)) |
|
180 | (p:defrule sugar-qsp-grammar (and (* (or spaces #\newline)) | |
181 | (* location)) |
|
181 | (* location)) | |
182 | (:lambda (list) |
|
182 | (:lambda (list) | |
183 | `(lib:game ,@(second list)))) |
|
183 | `(lib:game ,@(second list)))) | |
184 |
|
184 | |||
185 | (p:defrule location (and location-header block-body location-end) |
|
185 | (p:defrule location (and location-header block-body location-end) | |
186 | (:destructure (header body end) |
|
186 | (:destructure (header body end) | |
187 | (declare (ignore end)) |
|
187 | (declare (ignore end)) | |
188 | `(lib:location (,header) ,@body))) |
|
188 | `(lib:location (,header) ,@body))) | |
189 |
|
189 | |||
190 | (p:defrule location-header (and #\# |
|
190 | (p:defrule location-header (and #\# | |
191 | (+ not-newline) |
|
191 | (+ not-newline) | |
192 | (and #\newline spaces? before-statement)) |
|
192 | (and #\newline spaces? before-statement)) | |
193 | (:destructure (spaces1 name spaces2) |
|
193 | (:destructure (spaces1 name spaces2) | |
194 | (declare (ignore spaces1 spaces2)) |
|
194 | (declare (ignore spaces1 spaces2)) | |
195 | (string-upcase (string-trim " " (p:text name))))) |
|
195 | (string-upcase (string-trim " " (p:text name))))) | |
196 |
|
196 | |||
197 | (p:defrule location-end (and #\- (* not-newline) #\newline before-statement) |
|
197 | (p:defrule location-end (and #\- (* not-newline) #\newline before-statement) | |
198 | (:constant nil)) |
|
198 | (:constant nil)) | |
199 |
|
199 | |||
200 | ;;; Block body |
|
200 | ;;; Block body | |
201 |
|
201 | |||
202 | (p:defrule newline-block-body (and #\newline spaces? block-body) |
|
202 | (p:defrule newline-block-body (and #\newline spaces? block-body) | |
203 | (:function third)) |
|
203 | (:function third)) | |
204 |
|
204 | |||
205 | (p:defrule block-body (* statement) |
|
205 | (p:defrule block-body (* statement) | |
206 | (:function remove-nil)) |
|
206 | (:function remove-nil)) | |
207 |
|
207 | |||
208 | ;; Just for <a href="exec:...'> |
|
208 | ;; Just for <a href="exec:...'> | |
209 | ;; Explicitly called from that rule's production |
|
209 | ;; Explicitly called from that rule's production | |
210 | (p:defrule exec-body (and before-statement line-body) |
|
210 | (p:defrule exec-body (and before-statement line-body) | |
211 | (:function second)) |
|
211 | (:function second)) | |
212 |
|
212 | |||
213 | (p:defrule line-body (and inline-statement (* next-inline-statement)) |
|
213 | (p:defrule line-body (and inline-statement (* next-inline-statement)) | |
214 | (:lambda (list) |
|
214 | (:lambda (list) | |
215 | (list* (first list) (second list)))) |
|
215 | (list* (first list) (second list)))) | |
216 |
|
216 | |||
217 | (p:defrule before-statement (* (or #\newline spaces)) |
|
217 | (p:defrule before-statement (* (or #\newline spaces)) | |
218 | (:constant nil)) |
|
218 | (:constant nil)) | |
219 |
|
219 | |||
220 | (p:defrule statement-end (or statement-end-real statement-end-block-close)) |
|
220 | (p:defrule statement-end (or statement-end-real statement-end-block-close)) | |
221 |
|
221 | |||
222 | (p:defrule statement-end-real (and (or #\newline |
|
222 | (p:defrule statement-end-real (and (or #\newline | |
223 | (and #\& spaces? (p:& statement%))) |
|
223 | (and #\& spaces? (p:& statement%))) | |
224 | before-statement) |
|
224 | before-statement) | |
225 | (:constant nil)) |
|
225 | (:constant nil)) | |
226 |
|
226 | |||
227 | (p:defrule statement-end-block-close (or (p:& #\})) |
|
227 | (p:defrule statement-end-block-close (or (p:& #\})) | |
228 | (:constant nil)) |
|
228 | (:constant nil)) | |
229 |
|
229 | |||
230 | (p:defrule inline-statement (and statement% spaces?) |
|
230 | (p:defrule inline-statement (and statement% spaces?) | |
231 | (:function first)) |
|
231 | (:function first)) | |
232 |
|
232 | |||
233 | (p:defrule next-inline-statement (and #\& spaces? inline-statement) |
|
233 | (p:defrule next-inline-statement (and #\& spaces? inline-statement) | |
234 | (:function third)) |
|
234 | (:function third)) | |
235 |
|
235 | |||
236 | (p:defrule not-a-non-statement (and (p:! (p:~ "elseif")) |
|
236 | (p:defrule not-a-non-statement (and (p:! (p:~ "elseif")) | |
237 | (p:! (p:~ "else")) |
|
237 | (p:! (p:~ "else")) | |
238 | (p:! (p:~ "end")))) |
|
238 | (p:! (p:~ "end")))) | |
239 |
|
239 | |||
240 | (p:defrule statement (and inline-statement statement-end) |
|
240 | (p:defrule statement (and inline-statement statement-end) | |
241 | (:function first)) |
|
241 | (:function first)) | |
242 |
|
242 | |||
243 | (p:defrule statement% (and not-a-non-statement |
|
243 | (p:defrule statement% (and not-a-non-statement | |
244 | (or label comment string-output |
|
244 | (or label comment string-output | |
245 | block non-returning-intrinsic local |
|
245 | block non-returning-intrinsic local | |
246 | assignment expression-output)) |
|
246 | assignment expression-output)) | |
247 | (:function second)) |
|
247 | (:function second)) | |
248 |
|
248 | |||
249 | (p:defrule expr-stopper (or comment block non-returning-intrinsic)) |
|
249 | (p:defrule expr-stopper (or comment block non-returning-intrinsic)) | |
250 |
|
250 | |||
251 | (p:defrule string-output qsp-string |
|
251 | (p:defrule string-output qsp-string | |
252 | (:lambda (string) |
|
252 | (:lambda (string) | |
253 | (list 'lib:main-pl string))) |
|
253 | (list 'lib:main-pl string))) | |
254 |
|
254 | |||
255 | (p:defrule expression-output expression |
|
255 | (p:defrule expression-output expression | |
256 | (:lambda (list) |
|
256 | (:lambda (list) | |
257 | (list 'lib:main-pl list))) |
|
257 | (list 'lib:main-pl list))) | |
258 |
|
258 | |||
259 | (p:defrule label (and colon identifier) |
|
259 | (p:defrule label (and colon identifier) | |
260 | (:lambda (list) |
|
260 | (:lambda (list) | |
261 | (intern (string (second list)) :keyword))) |
|
261 | (intern (string (second list)) :keyword))) | |
262 |
|
262 | |||
263 | (p:defrule comment (and #\! (* (or qsp-string brace-comment text-spaces not-newline))) |
|
263 | (p:defrule comment (and #\! (* (or qsp-string brace-comment text-spaces not-newline))) | |
264 | (:constant nil)) |
|
264 | (:constant nil)) | |
265 |
|
265 | |||
266 | (p:defrule brace-comment (and #\{ (* (not-brace character)) #\}) |
|
266 | (p:defrule brace-comment (and #\{ (* (not-brace character)) #\}) | |
267 | (:constant nil)) |
|
267 | (:constant nil)) | |
268 |
|
268 | |||
269 | (p:defrule local (and (p:~ "local") spaces variable (p:? (and spaces? #\= spaces? expression))) |
|
269 | (p:defrule local (and (p:~ "local") spaces variable (p:? (and spaces? #\= spaces? expression))) | |
270 | (:lambda (list) |
|
270 | (:lambda (list) | |
271 | (list* 'lib:local (third list) |
|
271 | (list* 'lib:local (third list) | |
272 | (when (fourth list) |
|
272 | (when (fourth list) | |
273 | (list (fourth (fourth list))))))) |
|
273 | (list (fourth (fourth list))))))) | |
274 |
|
274 | |||
275 | ;;; Blocks |
|
275 | ;;; Blocks | |
276 |
|
276 | |||
277 | (p:defrule block (or block-act block-if block-for)) |
|
277 | (p:defrule block (or block-act block-if block-for)) | |
278 |
|
278 | |||
279 | (p:defrule block-if (and block-if-head block-if-body) |
|
279 | (p:defrule block-if (and block-if-head block-if-body) | |
280 | (:destructure (head body) |
|
280 | (:destructure (head body) | |
281 | `(lib:qspcond (,@head ,@(first body)) |
|
281 | `(lib:qspcond (,@head ,@(first body)) | |
282 | ,@(rest body)))) |
|
282 | ,@(rest body)))) | |
283 |
|
283 | |||
284 | (p:defrule block-if-head (and (p:~ "if") spaces expression spaces? colon spaces?) |
|
284 | (p:defrule block-if-head (and (p:~ "if") spaces expression spaces? colon spaces?) | |
285 | (:function remove-nil) |
|
285 | (:function remove-nil) | |
286 | (:function cdr)) |
|
286 | (:function cdr)) | |
287 |
|
287 | |||
288 | (p:defrule block-if-body (or block-if-ml block-if-sl) |
|
288 | (p:defrule block-if-body (or block-if-ml block-if-sl) | |
289 | (:destructure (if-body elseifs else &rest ws) |
|
289 | (:destructure (if-body elseifs else &rest ws) | |
290 | (declare (ignore ws)) |
|
290 | (declare (ignore ws)) | |
291 | `(,(remove-nil if-body) ,@elseifs ,@(when else `((else ,@else)))))) |
|
291 | `(,(remove-nil if-body) ,@elseifs ,@(when else `((else ,@else)))))) | |
292 |
|
292 | |||
293 | (p:defrule block-if-sl (and line-body |
|
293 | (p:defrule block-if-sl (and line-body | |
294 | (p:? block-if-elseif-inline) |
|
294 | (p:? block-if-elseif-inline) | |
295 | (p:? block-if-else-inline) |
|
295 | (p:? block-if-else-inline) | |
296 | spaces?)) |
|
296 | spaces?)) | |
297 |
|
297 | |||
298 | (p:defrule block-if-ml (and (and #\newline spaces?) |
|
298 | (p:defrule block-if-ml (and (and #\newline spaces?) | |
299 | block-body |
|
299 | block-body | |
300 | (p:? block-if-elseif) |
|
300 | (p:? block-if-elseif) | |
301 | (p:? block-if-else) |
|
301 | (p:? block-if-else) | |
302 | block-if-end) |
|
302 | block-if-end) | |
303 | (:lambda (list) |
|
303 | (:lambda (list) | |
304 | (cdr list))) |
|
304 | (cdr list))) | |
305 |
|
305 | |||
306 | (p:defrule block-if-elseif-inline (and block-if-elseif-head line-body (p:? block-if-elseif-inline)) |
|
306 | (p:defrule block-if-elseif-inline (and block-if-elseif-head line-body (p:? block-if-elseif-inline)) | |
307 | (:destructure (head statements elseif) |
|
307 | (:destructure (head statements elseif) | |
308 | `((,@(rest head) ,@(remove-nil statements)) ,@elseif))) |
|
308 | `((,@(rest head) ,@(remove-nil statements)) ,@elseif))) | |
309 |
|
309 | |||
310 | (p:defrule block-if-elseif (and block-if-elseif-head statement-end block-body (p:? block-if-elseif)) |
|
310 | (p:defrule block-if-elseif (and block-if-elseif-head statement-end block-body (p:? block-if-elseif)) | |
311 | (:destructure (head ws statements elseif) |
|
311 | (:destructure (head ws statements elseif) | |
312 | (declare (ignore ws)) |
|
312 | (declare (ignore ws)) | |
313 | `((,@(rest head) ,@(remove-nil statements)) ,@elseif))) |
|
313 | `((,@(rest head) ,@(remove-nil statements)) ,@elseif))) | |
314 |
|
314 | |||
315 | (p:defrule block-if-elseif-head (and (p:~ "elseif") spaces expression spaces? colon spaces?) |
|
315 | (p:defrule block-if-elseif-head (and (p:~ "elseif") spaces expression spaces? colon spaces?) | |
316 | (:function remove-nil) |
|
316 | (:function remove-nil) | |
317 | (:function intern-first)) |
|
317 | (:function intern-first)) | |
318 |
|
318 | |||
319 | (p:defrule block-if-else-inline (and block-if-else-head line-body) |
|
319 | (p:defrule block-if-else-inline (and block-if-else-head line-body) | |
320 | (:function second)) |
|
320 | (:function second)) | |
321 |
|
321 | |||
322 | (p:defrule block-if-else (and block-if-else-head #\newline spaces? block-body) |
|
322 | (p:defrule block-if-else (and block-if-else-head #\newline spaces? block-body) | |
323 | (:function fourth)) |
|
323 | (:function fourth)) | |
324 |
|
324 | |||
325 | (p:defrule block-if-else-head (and (p:~ "else") spaces?) |
|
325 | (p:defrule block-if-else-head (and (p:~ "else") spaces?) | |
326 | (:constant nil)) |
|
326 | (:constant nil)) | |
327 |
|
327 | |||
328 | (p:defrule block-if-end (and (p:~ "end") |
|
328 | (p:defrule block-if-end (and (p:~ "end") | |
329 | (p:? (and spaces (p:~ "if")))) |
|
329 | (p:? (and spaces (p:~ "if")))) | |
330 | (:constant nil)) |
|
330 | (:constant nil)) | |
331 |
|
331 | |||
332 | (p:defrule block-act (and block-act-head (or block-ml block-sl)) |
|
332 | (p:defrule block-act (and block-act-head (or block-ml block-sl)) | |
333 | (:lambda (list) |
|
333 | (:lambda (list) | |
334 | (apply #'append list))) |
|
334 | (apply #'append list))) | |
335 |
|
335 | |||
336 | (p:defrule block-act-head (and (p:~ "act") spaces? qsp-string spaces? |
|
336 | (p:defrule block-act-head (and (p:~ "act") spaces? qsp-string spaces? | |
337 | (p:? block-act-head-img) |
|
337 | (p:? block-act-head-img) | |
338 | colon spaces?) |
|
338 | colon spaces?) | |
339 | (:lambda (list) |
|
339 | (:lambda (list) | |
340 | (intern-first (list (first list) |
|
340 | (intern-first (list (first list) | |
341 | (third list) |
|
341 | (third list) | |
342 | (or (fifth list) '(lib:str "")))))) |
|
342 | (or (fifth list) '(lib:str "")))))) | |
343 |
|
343 | |||
344 | (p:defrule block-act-head-img (and #\, spaces? qsp-string spaces?) |
|
344 | (p:defrule block-act-head-img (and #\, spaces? qsp-string spaces?) | |
345 | (:lambda (list) |
|
345 | (:lambda (list) | |
346 | (or (third list) ""))) |
|
346 | (or (third list) ""))) | |
347 |
|
347 | |||
348 | (p:defrule block-for (and block-for-head (or block-ml block-sl)) |
|
348 | (p:defrule block-for (and block-for-head (or block-ml block-sl)) | |
349 | (:lambda (list) |
|
349 | (:lambda (list) | |
350 | (apply #'append list))) |
|
350 | (apply #'append list))) | |
351 |
|
351 | |||
352 | (p:defrule block-for-head (and (p:~ "for") spaces variable spaces? equal spaces? expression |
|
352 | (p:defrule block-for-head (and (p:~ "for") spaces variable spaces? equal spaces? expression | |
353 | (p:~ "to") spaces expression |
|
353 | (p:~ "to") spaces expression | |
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) | |
362 | (elt list 9) |
|
360 | (elt list 9) | |
363 | (elt list 10)))) |
|
361 | (elt list 10)))) | |
364 |
|
362 | |||
365 | (p:defrule block-for-head-step (p:? (and (p:~ "step") spaces expression spaces?)) |
|
363 | (p:defrule block-for-head-step (p:? (and (p:~ "step") spaces expression spaces?)) | |
366 | (:lambda (list) |
|
364 | (:lambda (list) | |
367 | (if list |
|
365 | (if list | |
368 | (third list) |
|
366 | (third list) | |
369 | 1))) |
|
367 | 1))) | |
370 |
|
368 | |||
371 | (p:defrule block-sl line-body) |
|
369 | (p:defrule block-sl line-body) | |
372 |
|
370 | |||
373 | (p:defrule block-ml (and newline-block-body block-end) |
|
371 | (p:defrule block-ml (and newline-block-body block-end) | |
374 | (:lambda (list) |
|
372 | (:lambda (list) | |
375 | (apply #'list* (butlast list)))) |
|
373 | (apply #'list* (butlast list)))) | |
376 |
|
374 | |||
377 | (p:defrule block-end (and (p:~ "end")) |
|
375 | (p:defrule block-end (and (p:~ "end")) | |
378 | (:constant nil)) |
|
376 | (:constant nil)) | |
379 |
|
377 | |||
380 | ;;; Calls |
|
378 | ;;; Calls | |
381 |
|
379 | |||
382 | (p:defrule first-argument (and expression spaces?) |
|
380 | (p:defrule first-argument (and expression spaces?) | |
383 | (:function first)) |
|
381 | (:function first)) | |
384 | (p:defrule next-argument (and "," spaces? expression) |
|
382 | (p:defrule next-argument (and "," spaces? expression) | |
385 | (:function third)) |
|
383 | (:function third)) | |
386 | (p:defrule arguments (or parenthesized-arguments plain-arguments no-arguments)) |
|
384 | (p:defrule arguments (or parenthesized-arguments plain-arguments no-arguments)) | |
387 | (p:defrule parenthesized-arguments (and spaces? #\( base-arguments #\)) |
|
385 | (p:defrule parenthesized-arguments (and spaces? #\( base-arguments #\)) | |
388 | (:function third)) |
|
386 | (:function third)) | |
389 | (p:defrule plain-arguments (and spaces? base-arguments) |
|
387 | (p:defrule plain-arguments (and spaces? base-arguments) | |
390 | (:function second)) |
|
388 | (:function second)) | |
391 | (p:defrule no-arguments (or (and spaces? (p:& #\newline)) |
|
389 | (p:defrule no-arguments (or (and spaces? (p:& #\newline)) | |
392 | (and spaces? (p:& #\&)) |
|
390 | (and spaces? (p:& #\&)) | |
393 | spaces?) |
|
391 | spaces?) | |
394 | (:constant nil)) |
|
392 | (:constant nil)) | |
395 | (p:defrule base-arguments (or (and first-argument (* next-argument)) spaces?) |
|
393 | (p:defrule base-arguments (or (and first-argument (* next-argument)) spaces?) | |
396 | (:lambda (list) |
|
394 | (:lambda (list) | |
397 | (if (null list) |
|
395 | (if (null list) | |
398 | nil |
|
396 | nil | |
399 | (list* (first list) (second list))))) |
|
397 | (list* (first list) (second list))))) | |
400 |
|
398 | |||
401 | ;;; Intrinsics |
|
399 | ;;; Intrinsics | |
402 |
|
400 | |||
403 | (defmacro defintrinsics ((rule-name returning-rule-name non-returning-rule-name) &body clauses) |
|
401 | (defmacro defintrinsics ((rule-name returning-rule-name non-returning-rule-name) &body clauses) | |
404 | `(progn |
|
402 | `(progn | |
405 | ,@(loop :for clause :in clauses |
|
403 | ,@(loop :for clause :in clauses | |
406 | :collect `(defintrinsic ,@clause)) |
|
404 | :collect `(defintrinsic ,@clause)) | |
407 | (p:defrule ,returning-rule-name (or ,@(remove-nil |
|
405 | (p:defrule ,returning-rule-name (or ,@(remove-nil | |
408 | (mapcar (lambda (clause) |
|
406 | (mapcar (lambda (clause) | |
409 | (when (second clause) |
|
407 | (when (second clause) | |
410 | (alexandria:symbolicate |
|
408 | (alexandria:symbolicate | |
411 | 'intrinsic- (first clause)))) |
|
409 | 'intrinsic- (first clause)))) | |
412 | clauses)))) |
|
410 | clauses)))) | |
413 | (p:defrule ,non-returning-rule-name (or ,@(remove-nil |
|
411 | (p:defrule ,non-returning-rule-name (or ,@(remove-nil | |
414 | (mapcar (lambda (clause) |
|
412 | (mapcar (lambda (clause) | |
415 | (unless (second clause) |
|
413 | (unless (second clause) | |
416 | (alexandria:symbolicate |
|
414 | (alexandria:symbolicate | |
417 | 'intrinsic- (first clause)))) |
|
415 | 'intrinsic- (first clause)))) | |
418 | clauses)))) |
|
416 | clauses)))) | |
419 | (p:defrule ,rule-name (or ,returning-rule-name ,non-returning-rule-name)))) |
|
417 | (p:defrule ,rule-name (or ,returning-rule-name ,non-returning-rule-name)))) | |
420 |
|
418 | |||
421 | (defmacro defintrinsic (sym returning &optional (min-arity 0) max-arity &rest names) |
|
419 | (defmacro defintrinsic (sym returning &optional (min-arity 0) max-arity &rest names) | |
422 | (declare (ignore returning)) |
|
420 | (declare (ignore returning)) | |
423 | (unless max-arity |
|
421 | (unless max-arity | |
424 | (setf max-arity *max-args*)) |
|
422 | (setf max-arity *max-args*)) | |
425 | (setf names |
|
423 | (setf names | |
426 | (if names |
|
424 | (if names | |
427 | (mapcar #'string-upcase names) |
|
425 | (mapcar #'string-upcase names) | |
428 | (list (string sym)))) |
|
426 | (list (string sym)))) | |
429 | `(p:defrule ,(alexandria:symbolicate 'intrinsic- sym) |
|
427 | `(p:defrule ,(alexandria:symbolicate 'intrinsic- sym) | |
430 | (and (p:? #\$) (or ,@(loop :for name :in names :collect `(p:~ ,name))) |
|
428 | (and (p:? #\$) (or ,@(loop :for name :in names :collect `(p:~ ,name))) | |
431 | arguments) |
|
429 | arguments) | |
432 | (:destructure (dollar name arguments) |
|
430 | (:destructure (dollar name arguments) | |
433 | (declare (ignore dollar)) |
|
431 | (declare (ignore dollar)) | |
434 | (unless (<= ,min-arity (length arguments) ,max-arity) |
|
432 | (unless (<= ,min-arity (length arguments) ,max-arity) | |
435 | (error "Intrinsic ~A expects between ~A and ~A arguments but ~A were provided:~%~S" |
|
433 | (error "Intrinsic ~A expects between ~A and ~A arguments but ~A were provided:~%~S" | |
436 | name ,min-arity ,max-arity (length arguments) arguments)) |
|
434 | name ,min-arity ,max-arity (length arguments) arguments)) | |
437 | (list* ',(intern (string sym) :lib) arguments)))) |
|
435 | (list* ',(intern (string sym) :lib) arguments)))) | |
438 |
|
436 | |||
439 | (defintrinsics (intrinsic returning-intrinsic non-returning-intrinsic) |
|
437 | (defintrinsics (intrinsic returning-intrinsic non-returning-intrinsic) | |
440 | ;; Transitions |
|
438 | ;; Transitions | |
441 | (goto% nil 0 nil "gt" "goto") |
|
439 | (goto% nil 0 nil "gt" "goto") | |
442 | (xgoto% nil 0 nil "xgt" "xgoto") |
|
440 | (xgoto% nil 0 nil "xgt" "xgoto") | |
443 | ;; Variables |
|
441 | ;; Variables | |
444 | (killvar nil 0 2) |
|
442 | (killvar nil 0 2) | |
445 | ;; Expressions |
|
443 | ;; Expressions | |
446 | (obj t 1 1) |
|
444 | (obj t 1 1) | |
447 | (loc t 1 1) |
|
445 | (loc t 1 1) | |
448 | (no t 1 1) |
|
446 | (no t 1 1) | |
449 | ;; Basic |
|
447 | ;; Basic | |
450 | (qspver t 0 0) |
|
448 | (qspver t 0 0) | |
451 | (curloc t 0 0) |
|
449 | (curloc t 0 0) | |
452 | (rand t 1 2) |
|
450 | (rand t 1 2) | |
453 | (rnd t 0 0) |
|
451 | (rnd t 0 0) | |
454 | (qspmax t 1 nil "max") |
|
452 | (qspmax t 1 nil "max") | |
455 | (qspmin t 1 nil "min") |
|
453 | (qspmin t 1 nil "min") | |
456 | ;; Arrays |
|
454 | ;; Arrays | |
457 | (killall nil 0 0) |
|
455 | (killall nil 0 0) | |
458 | (copyarr nil 2 4) |
|
456 | (copyarr nil 2 4) | |
459 | (arrsize t 1 1) |
|
457 | (arrsize t 1 1) | |
460 | (arrpos t 2 3) |
|
458 | (arrpos t 2 3) | |
461 | (arrcomp t 2 3) |
|
459 | (arrcomp t 2 3) | |
462 | ;; Strings |
|
460 | ;; Strings | |
463 | (len t 1 1) |
|
461 | (len t 1 1) | |
464 | (mid t 2 3) |
|
462 | (mid t 2 3) | |
465 | (ucase t 1 1) |
|
463 | (ucase t 1 1) | |
466 | (lcase t 1 1) |
|
464 | (lcase t 1 1) | |
467 | (trim t 1 1) |
|
465 | (trim t 1 1) | |
468 | (replace t 2 3) |
|
466 | (replace t 2 3) | |
469 | (instr t 2 3) |
|
467 | (instr t 2 3) | |
470 | (isnum t 1 1) |
|
468 | (isnum t 1 1) | |
471 | (val t 1 1) |
|
469 | (val t 1 1) | |
472 | (qspstr t 1 1 "str") |
|
470 | (qspstr t 1 1 "str") | |
473 | (strcomp t 2 2) |
|
471 | (strcomp t 2 2) | |
474 | (strfind t 2 3) |
|
472 | (strfind t 2 3) | |
475 | (strpos t 2 3) |
|
473 | (strpos t 2 3) | |
476 | ;; IF |
|
474 | ;; IF | |
477 | (iif t 2 3) |
|
475 | (iif t 2 3) | |
478 | ;; Subs |
|
476 | ;; Subs | |
479 | (gosub nil 1 nil "gosub" "gs") |
|
477 | (gosub nil 1 nil "gosub" "gs") | |
480 | (func t 1 nil) |
|
478 | (func t 1 nil) | |
481 | (exit nil 0 0) |
|
479 | (exit nil 0 0) | |
482 | ;; Jump |
|
480 | ;; Jump | |
483 | (jump nil 1 1) |
|
481 | (jump nil 1 1) | |
484 | ;; Dynamic |
|
482 | ;; Dynamic | |
485 | (dynamic nil 1 nil) |
|
483 | (dynamic nil 1 nil) | |
486 | (dyneval t 1 nil) |
|
484 | (dyneval t 1 nil) | |
487 | ;; Sound |
|
485 | ;; Sound | |
488 | (play nil 1 2) |
|
486 | (play nil 1 2) | |
489 | (isplay t 1 1) |
|
487 | (isplay t 1 1) | |
490 | (close nil 1 1) |
|
488 | (close nil 1 1) | |
491 | (closeall nil 0 0 "close all") |
|
489 | (closeall nil 0 0 "close all") | |
492 | ;; Main window |
|
490 | ;; Main window | |
493 | (main-pl nil 1 1 "*pl") |
|
491 | (main-pl nil 1 1 "*pl") | |
494 | (main-nl nil 0 1 "*nl") |
|
492 | (main-nl nil 0 1 "*nl") | |
495 | (main-p nil 1 1 "*p") |
|
493 | (main-p nil 1 1 "*p") | |
496 | (maintxt t 0 0) |
|
494 | (maintxt t 0 0) | |
497 | (desc t 1 1) |
|
495 | (desc t 1 1) | |
498 | (main-clear nil 0 0 "*clear" "*clr") |
|
496 | (main-clear nil 0 0 "*clear" "*clr") | |
499 | ;; Aux window |
|
497 | ;; Aux window | |
500 | (showstat nil 1 1) |
|
498 | (showstat nil 1 1) | |
501 | (stat-pl nil 1 1 "pl") |
|
499 | (stat-pl nil 1 1 "pl") | |
502 | (stat-nl nil 0 1 "nl") |
|
500 | (stat-nl nil 0 1 "nl") | |
503 | (stat-p nil 1 1 "p") |
|
501 | (stat-p nil 1 1 "p") | |
504 | (stattxt t 0 0) |
|
502 | (stattxt t 0 0) | |
505 | (stat-clear nil 0 0 "clear" "clr") |
|
503 | (stat-clear nil 0 0 "clear" "clr") | |
506 | (cls nil 0 0) |
|
504 | (cls nil 0 0) | |
507 | ;; Dialog |
|
505 | ;; Dialog | |
508 | (msg nil 1 1) |
|
506 | (msg nil 1 1) | |
509 | ;; Acts |
|
507 | ;; Acts | |
510 | (showacts nil 1 1) |
|
508 | (showacts nil 1 1) | |
511 | (delact nil 1 1 "delact" "del act") |
|
509 | (delact nil 1 1 "delact" "del act") | |
512 | (curacts t 0 0) |
|
510 | (curacts t 0 0) | |
513 | (cla nil 0 0) |
|
511 | (cla nil 0 0) | |
514 | ;; Objects |
|
512 | ;; Objects | |
515 | (showobjs nil 1 1) |
|
513 | (showobjs nil 1 1) | |
516 | (addobj nil 1 3 "addobj" "add obj") |
|
514 | (addobj nil 1 3 "addobj" "add obj") | |
517 | (delobj nil 1 1 "delobj" "del obj") |
|
515 | (delobj nil 1 1 "delobj" "del obj") | |
518 | (killobj nil 0 1) |
|
516 | (killobj nil 0 1) | |
519 | (countobj t 0 0) |
|
517 | (countobj t 0 0) | |
520 | (getobj t 1 1) |
|
518 | (getobj t 1 1) | |
521 | ;; Menu |
|
519 | ;; Menu | |
522 | (menu nil 1 1) |
|
520 | (menu nil 1 1) | |
523 | ;; Images |
|
521 | ;; Images | |
524 | (refint nil 0 0) |
|
522 | (refint nil 0 0) | |
525 | (view nil 0 1) |
|
523 | (view nil 0 1) | |
526 | (img nil 1) |
|
524 | (img nil 1) | |
527 | (*img nil 1) |
|
525 | (*img nil 1) | |
528 | ;; Fonts |
|
526 | ;; Fonts | |
529 | (rgb t 3 3) |
|
527 | (rgb t 3 3) | |
530 | ;; Input |
|
528 | ;; Input | |
531 | (showinput nil 1 1) |
|
529 | (showinput nil 1 1) | |
532 | (usertxt t 0 0 "user_text" "usrtxt") |
|
530 | (usertxt t 0 0 "user_text" "usrtxt") | |
533 | (cmdclear nil 0 0 "cmdclear" "cmdclr") |
|
531 | (cmdclear nil 0 0 "cmdclear" "cmdclr") | |
534 | (input t 1 1) |
|
532 | (input t 1 1) | |
535 | ;; Files |
|
533 | ;; Files | |
536 | (openqst nil 1 1) |
|
534 | (openqst nil 1 1) | |
537 | (addqst nil 1 1 "addqst" "addlib" "inclib") |
|
535 | (addqst nil 1 1 "addqst" "addlib" "inclib") | |
538 | (killqst nil 1 1 "killqst" "dellib" "freelib") |
|
536 | (killqst nil 1 1 "killqst" "dellib" "freelib") | |
539 | (opengame nil 0 0) |
|
537 | (opengame nil 0 0) | |
540 | (savegame nil 0 0) |
|
538 | (savegame nil 0 0) | |
541 | ;; Real time |
|
539 | ;; Real time | |
542 | (wait nil 1 1) |
|
540 | (wait nil 1 1) | |
543 | (msecscount t 0 0) |
|
541 | (msecscount t 0 0) | |
544 | (settimer nil 1 1)) |
|
542 | (settimer nil 1 1)) | |
545 |
|
543 | |||
546 | ;;; Expression |
|
544 | ;;; Expression | |
547 |
|
545 | |||
548 | (p:defrule expression or-expr) |
|
546 | (p:defrule expression or-expr) | |
549 |
|
547 | |||
550 | (p:defrule or-expr (and and-expr (* (and spaces? or-op spaces? and-expr))) |
|
548 | (p:defrule or-expr (and and-expr (* (and spaces? or-op spaces? and-expr))) | |
551 | (:function do-binop)) |
|
549 | (:function do-binop)) | |
552 |
|
550 | |||
553 | (p:defrule and-expr (and eq-expr (* (and spaces? and-op spaces? eq-expr))) |
|
551 | (p:defrule and-expr (and eq-expr (* (and spaces? and-op spaces? eq-expr))) | |
554 | (:function do-binop)) |
|
552 | (:function do-binop)) | |
555 |
|
553 | |||
556 | (p:defrule eq-expr (and sum-expr (* (and spaces? (or "<=" ">=" "=<" "=>" "<>" |
|
554 | (p:defrule eq-expr (and sum-expr (* (and spaces? (or "<=" ">=" "=<" "=>" "<>" | |
557 | "=" "<" ">" "!") |
|
555 | "=" "<" ">" "!") | |
558 | spaces? sum-expr))) |
|
556 | spaces? sum-expr))) | |
559 | (:function do-binop)) |
|
557 | (:function do-binop)) | |
560 |
|
558 | |||
561 | (p:defrule sum-expr (and mod-expr (* (and spaces? (or #\+ #\-) spaces? mod-expr))) |
|
559 | (p:defrule sum-expr (and mod-expr (* (and spaces? (or #\+ #\-) spaces? mod-expr))) | |
562 | (:function do-binop)) |
|
560 | (:function do-binop)) | |
563 |
|
561 | |||
564 | (p:defrule mod-expr (and mul-expr (* (and spaces? (p:~ "mod") spaces? mul-expr))) |
|
562 | (p:defrule mod-expr (and mul-expr (* (and spaces? (p:~ "mod") spaces? mul-expr))) | |
565 | (:function do-binop)) |
|
563 | (:function do-binop)) | |
566 |
|
564 | |||
567 | (p:defrule mul-expr (and unary-expr (* (and spaces? (or #\* #\/) spaces? unary-expr))) |
|
565 | (p:defrule mul-expr (and unary-expr (* (and spaces? (or #\* #\/) spaces? unary-expr))) | |
568 | (:function do-binop)) |
|
566 | (:function do-binop)) | |
569 |
|
567 | |||
570 | (p:defrule unary-expr (and (p:? (or #\+ #\-)) atom-expr) |
|
568 | (p:defrule unary-expr (and (p:? (or #\+ #\-)) atom-expr) | |
571 | (:lambda (list) |
|
569 | (:lambda (list) | |
572 | (let ((expr (remove-nil list))) |
|
570 | (let ((expr (remove-nil list))) | |
573 | (if (= 1 (length expr)) |
|
571 | (if (= 1 (length expr)) | |
574 | (first expr) |
|
572 | (first expr) | |
575 | (intern-first expr))))) |
|
573 | (intern-first expr))))) | |
576 |
|
574 | |||
577 | (p:defrule atom-expr (and (or variable literal returning-intrinsic paren-expr) spaces?) |
|
575 | (p:defrule atom-expr (and (or variable literal returning-intrinsic paren-expr) spaces?) | |
578 | (:function first)) |
|
576 | (:function first)) | |
579 |
|
577 | |||
580 | (p:defrule paren-expr (and #\( spaces? expression spaces? #\)) |
|
578 | (p:defrule paren-expr (and #\( spaces? expression spaces? #\)) | |
581 | (:function third)) |
|
579 | (:function third)) | |
582 |
|
580 | |||
583 | (p:defrule or-op (p:~ "or") |
|
581 | (p:defrule or-op (p:~ "or") | |
584 | (:constant "or")) |
|
582 | (:constant "or")) | |
585 |
|
583 | |||
586 | (p:defrule and-op (p:~ "and") |
|
584 | (p:defrule and-op (p:~ "and") | |
587 | (:constant "and")) |
|
585 | (:constant "and")) | |
588 |
|
586 | |||
589 | ;;; Variables |
|
587 | ;;; Variables | |
590 |
|
588 | |||
591 | (p:defrule variable (and identifier (p:? array-index)) |
|
589 | (p:defrule variable (and identifier (p:? array-index)) | |
592 | (:destructure (id idx-raw) |
|
590 | (:destructure (id idx-raw) | |
593 | (let ((idx (case idx-raw |
|
591 | (let ((idx (case idx-raw | |
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) | |
603 | (or (third list) :last))) |
|
599 | (or (third list) :last))) | |
604 |
|
600 | |||
605 | (p:defrule assignment (or kw-assignment plain-assignment op-assignment) |
|
601 | (p:defrule assignment (or kw-assignment plain-assignment op-assignment) | |
606 | (:destructure (qspvar eq expr) |
|
602 | (:destructure (qspvar eq expr) | |
607 | (declare (ignore eq)) |
|
603 | (declare (ignore eq)) | |
608 | (list 'lib:set qspvar expr))) |
|
604 | (list 'lib:set qspvar expr))) | |
609 |
|
605 | |||
610 | (p:defrule kw-assignment (and (or (p:~ "let") (p:~ "set")) spaces? (or op-assignment plain-assignment)) |
|
606 | (p:defrule kw-assignment (and (or (p:~ "let") (p:~ "set")) spaces? (or op-assignment plain-assignment)) | |
611 | (:function third)) |
|
607 | (:function third)) | |
612 |
|
608 | |||
613 | (p:defrule op-assignment (and variable spaces? (or "+" "-" "*" "/") #\= spaces? expression) |
|
609 | (p:defrule op-assignment (and variable spaces? (or "+" "-" "*" "/") #\= spaces? expression) | |
614 | (:destructure (qspvar ws1 op eq ws2 expr) |
|
610 | (:destructure (qspvar ws1 op eq ws2 expr) | |
615 | (declare (ignore ws1 ws2)) |
|
611 | (declare (ignore ws1 ws2)) | |
616 | (list qspvar eq (intern-first (list op qspvar expr))))) |
|
612 | (list qspvar eq (intern-first (list op qspvar expr))))) | |
617 |
|
613 | |||
618 | (p:defrule plain-assignment (and variable spaces? #\= spaces? expression) |
|
614 | (p:defrule plain-assignment (and variable spaces? #\= spaces? expression) | |
619 | (:function remove-nil)) |
|
615 | (:function remove-nil)) | |
620 |
|
616 | |||
621 | ;;; Non-string literals |
|
617 | ;;; Non-string literals | |
622 |
|
618 | |||
623 | (p:defrule literal (or qsp-string brace-string number)) |
|
619 | (p:defrule literal (or qsp-string brace-string number)) | |
624 |
|
620 | |||
625 | (p:defrule number (+ (or #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) |
|
621 | (p:defrule number (+ (or #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) | |
626 | (:lambda (list) |
|
622 | (:lambda (list) | |
627 | (parse-integer (p:text list)))) |
|
623 | (parse-integer (p:text list)))) |
@@ -1,188 +1,354 b'' | |||||
1 |
|
1 | |||
2 | (in-package sugar-qsp.lib) |
|
2 | (in-package sugar-qsp.lib) | |
3 |
|
3 | |||
4 | ;;;; Parenscript macros which make the parser's intermediate |
|
4 | ;;;; Parenscript macros which make the parser's intermediate | |
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 | |
11 |
|
19 | |||
12 | (defpsmacro label-block (() &body body) |
|
20 | (defpsmacro label-block (() &body body) | |
13 | (let ((has-labels (some #'keywordp body))) |
|
21 | (let ((has-labels (some #'keywordp body))) | |
14 | `(block nil |
|
22 | `(block nil | |
15 | ,@(when has-labels |
|
23 | ,@(when has-labels | |
16 | '((var _labels (list)))) |
|
24 | '((var _labels (list)))) | |
17 | (tagbody |
|
25 | (tagbody | |
18 | ,@body |
|
26 | ,@body | |
19 | (void))))) |
|
27 | (void))))) | |
20 |
|
28 | |||
21 | (defpsmacro str (&rest forms) |
|
29 | (defpsmacro str (&rest forms) | |
22 | (cond ((zerop (length forms)) |
|
30 | (cond ((zerop (length forms)) | |
23 | "") |
|
31 | "") | |
24 | ((and (= 1 (length forms)) |
|
32 | ((and (= 1 (length forms)) | |
25 | (stringp (first forms))) |
|
33 | (stringp (first forms))) | |
26 | (first forms)) |
|
34 | (first forms)) | |
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)))) | |
39 |
|
76 | |||
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 | |
49 | (goto ,target ,args) |
|
84 | (goto ,target ,args) | |
50 | (exit))) |
|
85 | (exit))) | |
51 |
|
86 | |||
52 | (defpsmacro xgoto% (target &rest args) |
|
87 | (defpsmacro xgoto% (target &rest args) | |
53 | `(progn |
|
88 | `(progn | |
54 | (xgoto ,target ,args) |
|
89 | (xgoto ,target ,args) | |
55 | (exit))) |
|
90 | (exit))) | |
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 | |||
68 | (defpsmacro <> (op1 op2) |
|
202 | (defpsmacro <> (op1 op2) | |
69 | `(not (equal ,op1 ,op2))) |
|
203 | `(not (equal ,op1 ,op2))) | |
70 |
|
204 | |||
71 | (defpsmacro ! (op1 op2) |
|
205 | (defpsmacro ! (op1 op2) | |
72 | `(not (equal ,op1 ,op2))) |
|
206 | `(not (equal ,op1 ,op2))) | |
73 |
|
207 | |||
74 | ;;; 4code |
|
208 | ;;; 4code | |
75 |
|
209 | |||
76 | (defpsmacro exec (&body body) |
|
210 | (defpsmacro exec (&body body) | |
77 | (format nil "javascript: ~{~A~^~%~}" (mapcar #'ps* body))) |
|
211 | (format nil "javascript: ~{~A~^~%~}" (mapcar #'ps* body))) | |
78 |
|
212 | |||
79 | ;;; 5arrays |
|
213 | ;;; 5arrays | |
80 |
|
214 | |||
81 | ;;; 6str |
|
215 | ;;; 6str | |
82 |
|
216 | |||
83 | (defpsmacro & (&rest args) |
|
217 | (defpsmacro & (&rest args) | |
84 | `(chain "" (concat ,@args))) |
|
218 | `(chain "" (concat ,@args))) | |
85 |
|
219 | |||
86 | ;;; 7if |
|
220 | ;;; 7if | |
87 |
|
221 | |||
88 | (defpsmacro qspcond (&rest clauses) |
|
222 | (defpsmacro qspcond (&rest clauses) | |
89 | `(cond ,@(loop :for clause :in clauses |
|
223 | `(cond ,@(loop :for clause :in clauses | |
90 | :collect (list (first clause) |
|
224 | :collect (list (first clause) | |
91 | `(tagbody |
|
225 | `(tagbody | |
92 | ,@(rest clause)))))) |
|
226 | ,@(rest clause)))))) | |
93 |
|
227 | |||
94 | ;;; 8sub |
|
228 | ;;; 8sub | |
95 |
|
229 | |||
96 | ;;; 9loops |
|
230 | ;;; 9loops | |
97 | ;;; Yep, that's a huge kludge since Javascript doesn't support arbitrary labels |
|
231 | ;;; Yep, that's a huge kludge since Javascript doesn't support arbitrary labels | |
98 |
|
232 | |||
99 | (defpsmacro jump (target) |
|
233 | (defpsmacro jump (target) | |
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) | |
|
237 | (let ((create-locals (if (eq (caar body) 'create-locals) | |||
|
238 | (list (car body)))) | |||
|
239 | (void (if (equal (car (last body)) '(void)) | |||
|
240 | '((void))))) | |||
|
241 | (when create-locals | |||
|
242 | (setf body (cdr body))) | |||
|
243 | (when void | |||
|
244 | (setf body (butlast body))) | |||
103 | (let ((funcs (list nil "_nil"))) |
|
245 | (let ((funcs (list nil "_nil"))) | |
104 | (dolist (form body) |
|
246 | (dolist (form body) | |
105 | (cond ((keywordp form) |
|
247 | (cond ((keywordp form) | |
106 | (setf (first funcs) (reverse (first funcs))) |
|
248 | (setf (first funcs) (reverse (first funcs))) | |
107 | (push (string-upcase form) funcs) |
|
249 | (push (string-upcase form) funcs) | |
108 | (push nil funcs)) |
|
250 | (push nil funcs)) | |
109 | (t |
|
251 | (t | |
110 | (push form (first funcs))))) |
|
252 | (push form (first funcs))))) | |
111 | (setf (first funcs) (reverse (first funcs))) |
|
253 | (setf (first funcs) (reverse (first funcs))) | |
112 | (setf funcs (reverse funcs)) |
|
254 | (setf funcs (reverse funcs)) | |
113 | (if (= 2 (length funcs)) |
|
255 | `(progn | |
|
256 | ,@create-locals | |||
|
257 | ,(if (= 2 (length funcs)) | |||
114 | `(progn |
|
258 | `(progn | |
115 | ,@body) |
|
259 | ,@body) | |
116 | `(progn |
|
260 | `(progn | |
117 | (tagbody-blocks ,funcs) |
|
261 | (tagbody-blocks ,funcs) | |
118 | (setf _nextblock :_nil) |
|
|||
119 | (loop |
|
262 | (loop | |
120 | :for _nextblock |
|
263 | :for _nextblock | |
121 | := :_nil |
|
264 | := :_nil | |
122 | :then (await (funcall (getprop _labels _nextblock))) |
|
265 | :then (await (funcall (getprop _labels _nextblock))) | |
123 |
:while _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 | |
|
283 | (tagbody-block-body ,label ,code | |||
|
284 | ,(first rest-labels)))))))) | |||
|
285 | ||||
|
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 | |||
130 |
|
|
293 | ,@code | |
131 |
|
|
294 | (break))) | |
132 | (list (first rest-labels)) |
|
295 | ,@(if next-label | |
133 | nil))))))) |
|
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))) | |
137 |
|
306 | |||
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))) | |
144 |
|
317 | |||
145 | ;;; 11main |
|
318 | ;;; 11main | |
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 | |||
155 | ;;; 13diag |
|
327 | ;;; 13diag | |
156 |
|
328 | |||
157 | ;;; 14act |
|
329 | ;;; 14act | |
158 |
|
330 | |||
159 | ;;; 15objs |
|
331 | ;;; 15objs | |
160 |
|
332 | |||
161 | ;;; 16menu |
|
333 | ;;; 16menu | |
162 |
|
334 | |||
163 | ;;; 17sound |
|
335 | ;;; 17sound | |
164 |
|
336 | |||
165 | ;;; 18img |
|
337 | ;;; 18img | |
166 |
|
338 | |||
167 | ;;; 19input |
|
339 | ;;; 19input | |
168 |
|
340 | |||
169 | ;;; 20time |
|
341 | ;;; 20time | |
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)))) |
@@ -1,19 +1,42 b'' | |||||
1 |
|
1 | |||
2 | (in-package code-walker) |
|
2 | (in-package code-walker) | |
3 |
|
3 | |||
4 | (defvar *transformers* (make-hash-table :test #'equal)) |
|
4 | (defvar *transformers* (make-hash-table :test #'equal)) | |
5 |
|
5 | |||
6 | (defmacro deftransform (transformer-name head args &body body) |
|
6 | (defmacro deftransform (transformer-name head args &body body) | |
7 | `(progn |
|
7 | `(progn | |
8 | (setf (gethash (list ',transformer-name ',head) *transformers*) |
|
8 | (setf (gethash (list ',transformer-name ',head) *transformers*) | |
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) | |
|
34 | (let ((*transformer-name* transformer-name) | |||
|
35 | (*whole* form)) | |||
13 | (if (listp form) |
|
36 | (if (listp form) | |
14 | (let ((transformer (gethash (list transformer-name (first form)) |
|
37 | (let ((transformer (gethash (list transformer-name (first form)) | |
15 | *transformers*))) |
|
38 | *transformers* nil))) | |
16 | (if transformer |
|
39 | (if transformer | |
17 | (apply transformer (rest form)) |
|
40 | (apply transformer (rest form)) | |
18 | (mapcar (lambda (subform) (walk transformer-name subform)) form))) |
|
41 | (walk-continue))) | |
19 | form)) |
|
42 | form))) |
General Comments 0
You need to be logged in to leave comments.
Login now