Show More
@@ -0,0 +1,15 b'' | |||||
|
1 | ||||
|
2 | (in-package sugar-qsp.api) | |||
|
3 | ||||
|
4 | (defpsmacro with-call-args (args &body body) | |||
|
5 | `(progn | |||
|
6 | (init-args ,args) | |||
|
7 | ,@body | |||
|
8 | (get-result))) | |||
|
9 | ||||
|
10 | (defpsmacro with-frame (&body body) | |||
|
11 | `(progn | |||
|
12 | (push-local-frame) | |||
|
13 | (unwind-protect | |||
|
14 | ,@body | |||
|
15 | (pop-local-frame)))) |
@@ -0,0 +1,37 b'' | |||||
|
1 | ||||
|
2 | (in-package sugar-qsp.js) | |||
|
3 | ||||
|
4 | ;;; Contains symbols from standard JS library to avoid obfuscating | |||
|
5 | ;;; and/or namespacing them | |||
|
6 | ||||
|
7 | (cl:defmacro syms (cl:&rest syms) | |||
|
8 | `(cl:progn | |||
|
9 | ,@(cl:loop :for sym :in syms | |||
|
10 | :collect `(cl:export ',sym)))) | |||
|
11 | ||||
|
12 | (syms | |||
|
13 | ;; main | |||
|
14 | window | |||
|
15 | *object | |||
|
16 | now | |||
|
17 | onload | |||
|
18 | keys includes | |||
|
19 | has-own-property | |||
|
20 | ;; api | |||
|
21 | document get-element-by-id | |||
|
22 | onclick onchange | |||
|
23 | atob btoa | |||
|
24 | alert prompt | |||
|
25 | set-timeout set-interval clear-interval | |||
|
26 | *promise *j-s-o-n | |||
|
27 | href parse | |||
|
28 | set-prototype-of | |||
|
29 | body append-child remove-child | |||
|
30 | create-element set-attribute | |||
|
31 | *file-reader read-as-text | |||
|
32 | style display src | |||
|
33 | ;; lib | |||
|
34 | *number parse-int | |||
|
35 | to-upper-case concat | |||
|
36 | click target current-target files index-of | |||
|
37 | ) |
@@ -0,0 +1,15 b'' | |||||
|
1 | ||||
|
2 | (in-package sugar-qsp.main) | |||
|
3 | ||||
|
4 | ||||
|
5 | (defpsmacro by-id (id) | |||
|
6 | `(chain document (get-element-by-id ,id))) | |||
|
7 | ||||
|
8 | (defmacro+ps api-call (name &rest args) | |||
|
9 | `(,(intern (string-upcase name) "API") ,@args)) | |||
|
10 | ||||
|
11 | (defpsmacro root (&rest path) | |||
|
12 | `(@ data ,@path)) | |||
|
13 | ||||
|
14 | (defpsmacro in (key obj) | |||
|
15 | `(chain ,obj (has-own-property ,key))) |
@@ -1,396 +1,405 b'' | |||||
1 |
|
1 | |||
2 | (in-package sugar-qsp) |
|
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 | (setf (root api) (ps:create)) |
|
|||
10 |
|
||||
11 | ;;; Utils |
|
9 | ;;; Utils | |
12 |
|
10 | |||
13 |
(def |
|
11 | (defun make-act-html (title img) | |
14 |
(+ "<a class='qsp-act' href=' |
|
12 | (+ "<a class='qsp-act' href='" (ps-inline call-act) "(\"" title "\");'>" | |
15 | title |
|
13 | title | |
16 | "</a>")) |
|
14 | "</a>")) | |
17 |
|
15 | |||
18 |
(def |
|
16 | (defun make-menu-item-html (num title img loc) | |
19 |
(+ "<a href=' |
|
17 | (+ "<a href='" (ps-inline run-menu) "(" num ", \"" loc "\")();'>" | |
20 | "<img src='" img "'>" |
|
18 | "<img src='" img "'>" | |
21 | title |
|
19 | title | |
22 | "</a>")) |
|
20 | "</a>")) | |
23 |
|
21 | |||
24 |
(def |
|
22 | (defun report-error (text) | |
25 | (alert text)) |
|
23 | (alert text)) | |
26 |
|
24 | |||
27 |
(def |
|
25 | (defun sleep (msec) | |
28 |
( |
|
26 | (new (*promise (=> resolve (set-timeout resolve msec))))) | |
29 |
|
27 | |||
30 |
(def |
|
28 | (defun init-dom () | |
31 | ;; Save/load buttons |
|
29 | ;; Save/load buttons | |
32 |
(let ((btn ( |
|
30 | (let ((btn (by-id "qsp-btn-save"))) | |
33 |
(setf ( |
|
31 | (setf (@ btn onclick) savegame) | |
34 |
(setf ( |
|
32 | (setf (@ btn href) "#")) | |
35 |
(let ((btn ( |
|
33 | (let ((btn (by-id "qsp-btn-open"))) | |
36 |
(setf ( |
|
34 | (setf (@ btn onclick) opengame) | |
37 |
(setf ( |
|
35 | (setf (@ btn href) "#")) | |
38 | ;; Close image on click |
|
36 | ;; Close image on click | |
39 |
(setf ( |
|
37 | (setf (@ (by-id "qsp-image-container") onclick) | |
40 |
( |
|
38 | (show-image nil)) | |
41 | ;; Close the dropdown on any click |
|
39 | ;; Close the dropdown on any click | |
42 |
(setf window |
|
40 | (setf (@ window onclick) | |
43 | (lambda (event) |
|
41 | (lambda (event) | |
44 |
(setf ( |
|
42 | (setf (@ (get-frame :dropdown) style display) "none")))) | |
45 |
|
43 | |||
46 |
(def |
|
44 | (defun call-serv-loc (var-name &rest args) | |
47 |
(let ((loc-name ( |
|
45 | (let ((loc-name (get-var var-name 0 :str))) | |
48 | (when loc-name |
|
46 | (when loc-name | |
49 |
(let ((loc ( |
|
47 | (let ((loc (getprop (root locs) loc-name))) | |
50 | (when loc |
|
48 | (when loc | |
51 | (funcall loc args)))))) |
|
49 | (funcall loc args)))))) | |
52 |
|
50 | |||
53 | ;;; Misc |
|
51 | ;;; Misc | |
54 |
|
52 | |||
55 |
(def |
|
53 | (defun newline (key) | |
56 |
( |
|
54 | (append-id (key-to-id key) "<br>" t)) | |
57 |
|
55 | |||
58 |
(def |
|
56 | (defun clear-id (id) | |
59 |
(setf ( |
|
57 | (setf (inner-html (by-id id)) "")) | |
60 |
|
58 | |||
61 |
( |
|
59 | (defvar text-escaper (chain document (create-element :textarea))) | |
62 |
|
60 | |||
63 |
(def |
|
61 | (defun prepare-contents (s &optional force-html) | |
64 | (if (or force-html (var "USEHTML" 0 :num)) |
|
62 | (if (or force-html (get-var "USEHTML" 0 :num)) | |
65 | s |
|
63 | s | |
66 | (progn |
|
64 | (progn | |
67 |
(setf ( |
|
65 | (setf (@ text-escaper text-content) s) | |
68 |
( |
|
66 | (inner-html text-escaper)))) | |
69 |
|
67 | |||
70 |
(def |
|
68 | (defun get-id (id &optional force-html) | |
71 |
( |
|
69 | (inner-html (by-id id))) | |
72 |
|
70 | |||
73 |
(def |
|
71 | (defun set-id (id contents &optional force-html) | |
74 |
(setf ( |
|
72 | (setf (inner-html (by-id id)) (prepare-contents contents force-html))) | |
75 |
|
73 | |||
76 |
(def |
|
74 | (defun append-id (id contents &optional force-html) | |
77 | (when contents |
|
75 | (when contents | |
78 |
(incf ( |
|
76 | (incf (inner-html (by-id id)) (prepare-contents contents force-html)))) | |
79 |
|
77 | |||
80 | ;;; Function calls |
|
78 | ;;; Function calls | |
81 |
|
79 | |||
82 |
(def |
|
80 | (defun init-args (args) | |
83 | (dotimes (i (length args)) |
|
81 | (dotimes (i (length args)) | |
84 | (let ((arg (elt args i))) |
|
82 | (let ((arg (elt args i))) | |
85 | (if (numberp arg) |
|
83 | (if (numberp arg) | |
86 |
( |
|
84 | (set-var args i :num arg) | |
87 |
( |
|
85 | (set-var args i :str arg))))) | |
88 |
|
86 | |||
89 |
(def |
|
87 | (defun get-result () | |
90 | (if (not (equal "" (var result 0 :str))) |
|
88 | (if (not (equal "" (get-var result 0 :str))) | |
91 | (var result 0 :str) |
|
89 | (get-var result 0 :str) | |
92 | (var result 0 :num))) |
|
90 | (get-var result 0 :num))) | |
93 |
|
91 | |||
94 |
(def |
|
92 | (defun call-loc (name args) | |
95 | (with-frame |
|
93 | (with-frame | |
96 | (funcall (ps:getprop (root locs) name) args))) |
|
94 | (with-call-args args | |
|
95 | (funcall (getprop (root locs) name) args)))) | |||
97 |
|
96 | |||
98 |
(def |
|
97 | (defun call-act (title) | |
99 | (with-frame |
|
98 | (with-frame | |
100 |
(funcall ( |
|
99 | (funcall (getprop (root acts) title 'act)))) | |
101 |
|
100 | |||
102 | ;;; Text windows |
|
101 | ;;; Text windows | |
103 |
|
102 | |||
104 |
(def |
|
103 | (defun key-to-id (key) | |
105 | (case key |
|
104 | (case key | |
106 | (:main "qsp-main") |
|
105 | (:main "qsp-main") | |
107 | (:stat "qsp-stat") |
|
106 | (:stat "qsp-stat") | |
108 | (:objs "qsp-objs") |
|
107 | (:objs "qsp-objs") | |
109 | (:acts "qsp-acts") |
|
108 | (:acts "qsp-acts") | |
110 | (:input "qsp-input") |
|
109 | (:input "qsp-input") | |
111 | (:dropdown "qsp-dropdown") |
|
110 | (:dropdown "qsp-dropdown") | |
112 |
(t ( |
|
111 | (t (report-error "Internal error!")))) | |
113 |
|
112 | |||
114 |
(def |
|
113 | (defun get-frame (key) | |
115 |
( |
|
114 | (by-id (key-to-id key))) | |
116 |
|
115 | |||
117 |
(def |
|
116 | (defun add-text (key text) | |
118 |
( |
|
117 | (append-id (key-to-id key) text)) | |
119 |
|
118 | |||
120 |
(def |
|
119 | (defun get-text (key) | |
121 |
( |
|
120 | (get-id (key-to-id key))) | |
122 |
|
121 | |||
123 |
(def |
|
122 | (defun clear-text (key) | |
124 |
( |
|
123 | (clear-id (key-to-id key))) | |
125 |
|
124 | |||
126 |
(def |
|
125 | (defun enable-frame (key enable) | |
127 |
(let ((obj ( |
|
126 | (let ((obj (get-frame key))) | |
128 |
(setf |
|
127 | (setf (@ obj style display) (if enable "block" "none")) | |
129 | (values))) |
|
128 | (values))) | |
130 |
|
129 | |||
131 | ;;; Actions |
|
130 | ;;; Actions | |
132 |
|
131 | |||
133 |
(def |
|
132 | (defun add-act (title img act) | |
134 |
(setf ( |
|
133 | (setf (getprop (root acts) title) | |
135 |
( |
|
134 | (create img img act act)) | |
136 |
( |
|
135 | (update-acts)) | |
137 |
|
136 | |||
138 |
(def |
|
137 | (defun del-act (title) | |
139 |
(delete ( |
|
138 | (delete (getprop (root acts) title)) | |
140 |
( |
|
139 | (update-acts)) | |
141 |
|
140 | |||
142 |
(def |
|
141 | (defun clear-act () | |
143 |
(setf (root acts) ( |
|
142 | (setf (root acts) (create)) | |
144 |
( |
|
143 | (clear-id "qsp-acts")) | |
145 |
|
144 | |||
146 |
(def |
|
145 | (defun update-acts () | |
147 |
( |
|
146 | (clear-id "qsp-acts") | |
148 |
(let ((elt ( |
|
147 | (let ((elt (by-id "qsp-acts"))) | |
149 |
( |
|
148 | (for-in (title (root acts)) | |
150 |
(let ((obj ( |
|
149 | (let ((obj (getprop (root acts) title))) | |
151 |
(incf ( |
|
150 | (incf (inner-html elt) (make-act-html title (getprop obj :img))))))) | |
152 |
|
151 | |||
153 |
|
152 | |||
154 | ;;; "Syntax" |
|
153 | ;;; "Syntax" | |
155 |
|
154 | |||
156 |
(def |
|
155 | (defun qspfor (name index from to step body) | |
157 | (block nil |
|
156 | (for ((i from)) | |
158 | (ps:for ((i from)) |
|
157 | ((< i to)) | |
159 |
|
|
158 | ((incf i step)) | |
160 | ((incf i step)) |
|
159 | (set-var name index :num i) | |
161 | (this.set-var name index :num i) |
|
160 | (unless (funcall body) | |
162 | (unless (funcall body) |
|
161 | (return-from qspfor)))) | |
163 | (return))))) |
|
|||
164 |
|
162 | |||
165 | ;;; Variable class |
|
163 | ;;; Variable class | |
166 |
|
164 | |||
167 |
(def |
|
165 | (defun *var (name) | |
168 | ;; From strings to numbers |
|
166 | ;; From strings to numbers | |
169 |
(setf |
|
167 | (setf (@ this indexes) (create)) | |
170 | ;; From numbers to {num: 0, str: ""} objects |
|
168 | ;; From numbers to {num: 0, str: ""} objects | |
171 |
(setf |
|
169 | (setf (@ this values) (list)) | |
172 | (values)) |
|
170 | (values)) | |
173 |
|
171 | |||
174 | (defm (root api *var prototype new-value) () |
|
172 | (defun new-value () | |
175 |
( |
|
173 | (create :num 0 :str "")) | |
176 |
|
174 | |||
177 |
( |
|
175 | (setf (@ *var prototype index-num) | |
178 | (let ((num-index |
|
176 | (lambda (index) | |
179 |
|
|
177 | (let ((num-index | |
180 |
(if ( |
|
178 | (if (stringp index) | |
181 |
( |
|
179 | (if (in index (@ this indexes)) | |
182 |
( |
|
180 | (getprop (@ this indexes) index) | |
183 | (setf (ps:getprop this.indexes index) n) |
|
181 | (let ((n (length (@ this values)))) | |
184 | n)) |
|
182 | (setf (getprop (@ this indexes) index) n) | |
185 |
|
|
183 | n)) | |
186 | (unless (in num-index this.values) |
|
184 | index))) | |
187 |
( |
|
185 | (unless (in num-index (@ this values)) | |
188 | num-index)) |
|
186 | (setf (elt (@ this values) num-index) (new-value))) | |
|
187 | num-index))) | |||
189 |
|
188 | |||
190 |
( |
|
189 | (setf (@ *var prototype get) | |
191 | (unless (or index (= 0 index)) |
|
190 | (lambda (index slot) | |
192 | (setf index (1- (length this.values)))) |
|
191 | (unless (or index (= 0 index)) | |
193 | (ps:getprop this.values (this.index-num index) slot)) |
|
192 | (setf index (1- (length (@ this values))))) | |
|
193 | (getprop (@ this values) (chain this (index-num index)) slot))) | |||
194 |
|
194 | |||
195 |
( |
|
195 | (setf (@ *var prototype set) | |
196 | (unless (or index (= 0 index)) |
|
196 | (lambda (index slot value) | |
197 | (setf index (length store))) |
|
197 | (unless (or index (= 0 index)) | |
198 | (case slot |
|
198 | (setf index (length (@ this values)))) | |
199 | (:num (setf value (ps:chain *number (parse-int value)))) |
|
199 | (case slot | |
200 |
(: |
|
200 | (:num (setf value (chain *number (parse-int value)))) | |
201 | (setf (ps:getprop this.values (this.index-num index) slot) value) |
|
201 | (:str (setf value (chain value (to-string))))) | |
202 | (values)) |
|
202 | (setf (getprop (@ this values) | |
|
203 | (chain this (index-num index)) | |||
|
204 | slot) value) | |||
|
205 | (values))) | |||
203 |
|
206 | |||
204 |
( |
|
207 | (setf (@ *var prototype kill) | |
205 | (setf (elt this.values (this.index-num index)) (this.new-value))) |
|
208 | (lambda (index) | |
|
209 | (setf (elt (@ this values) (chain this (index-num index))) | |||
|
210 | (new-value)) | |||
|
211 | (delete (getprop 'this 'indexes index)))) | |||
206 |
|
212 | |||
207 | ;;; Variables |
|
213 | ;;; Variables | |
208 |
|
214 | |||
209 |
(def |
|
215 | (defun var-real-name (name) | |
210 |
(if (= ( |
|
216 | (if (= (@ name 0) #\$) | |
211 |
(values ( |
|
217 | (values (chain name (substr 1)) :str) | |
212 | (values name :num))) |
|
218 | (values name :num))) | |
213 |
|
219 | |||
214 |
(def |
|
220 | (defun ensure-var (name) | |
215 |
(let ((store ( |
|
221 | (let ((store (var-ref name))) | |
216 | (unless store |
|
222 | (unless store | |
217 |
(setf store ( |
|
223 | (setf store (new (-var name))) | |
218 |
(setf ( |
|
224 | (setf (getprop (root vars) name) store)) | |
219 | store)) |
|
225 | store)) | |
220 |
|
226 | |||
221 |
(def |
|
227 | (defun var-ref (name) | |
222 |
(let ((local-store ( |
|
228 | (let ((local-store (current-local-frame))) | |
223 | (cond ((and local-store (in name local-store)) |
|
229 | (cond ((and local-store (in name local-store)) | |
224 |
( |
|
230 | (getprop local-store name)) | |
225 | ((in name (root vars)) |
|
231 | ((in name (root vars)) | |
226 |
( |
|
232 | (getprop (root vars) name)) | |
227 | (t nil)))) |
|
233 | (t nil)))) | |
228 |
|
234 | |||
229 |
(def |
|
235 | (defun get-var (name index slot) | |
230 |
( |
|
236 | (chain (ensure-var name) (get index slot))) | |
231 |
|
237 | |||
232 |
(def |
|
238 | (defun set-var (name index slot value) | |
233 |
( |
|
239 | (chain (ensure-var name) (set index slot value)) | |
234 | (values)) |
|
240 | (values)) | |
235 |
|
241 | |||
236 |
(def |
|
242 | (defun get-array (name) | |
237 |
( |
|
243 | (var-ref name)) | |
238 |
|
244 | |||
239 |
(def |
|
245 | (defun set-array (name value) | |
240 |
(let ((store ( |
|
246 | (let ((store (var-ref name))) | |
241 |
(setf ( |
|
247 | (setf (@ store values) (@ value values)) | |
242 |
(setf ( |
|
248 | (setf (@ store indexes) (@ value indexes))) | |
243 | (values)) |
|
249 | (values)) | |
244 |
|
250 | |||
245 |
(def |
|
251 | (defun kill-var (name &optional index) | |
246 | (if (and index (not (= 0 index))) |
|
252 | (if (and index (not (= 0 index))) | |
247 |
( |
|
253 | (chain (getprop (root vars) name) (kill index)) | |
248 |
( |
|
254 | (delete (getprop (root vars) name))) | |
249 | (values)) |
|
255 | (values)) | |
250 |
|
256 | |||
251 |
(def |
|
257 | (defun array-size (name) | |
252 |
( |
|
258 | (getprop (var-ref name) 'length)) | |
253 |
|
259 | |||
254 | ;;; Locals |
|
260 | ;;; Locals | |
255 |
|
261 | |||
256 |
(def |
|
262 | (defun push-local-frame () | |
257 |
( |
|
263 | (chain (root locals) (push (create))) | |
258 | (values)) |
|
264 | (values)) | |
259 |
|
265 | |||
260 |
(def |
|
266 | (defun pop-local-frame () | |
261 |
( |
|
267 | (chain (root locals) (pop)) | |
262 | (values)) |
|
268 | (values)) | |
263 |
|
269 | |||
264 |
(def |
|
270 | (defun current-local-frame () | |
265 | (elt (root locals) (1- (length (root locals))))) |
|
271 | (elt (root locals) (1- (length (root locals))))) | |
266 |
|
272 | |||
267 |
(def |
|
273 | (defun new-local (name) | |
268 |
(let ((frame ( |
|
274 | (let ((frame (current-local-frame))) | |
269 | (unless (in name frame) |
|
275 | (unless (in name frame) | |
270 |
(setf ( |
|
276 | (setf (getprop frame name) (create))) | |
271 | (values))) |
|
277 | (values))) | |
272 |
|
278 | |||
273 | ;;; Objects |
|
279 | ;;; Objects | |
274 |
|
280 | |||
275 |
(def |
|
281 | (defun update-objs () | |
276 |
(let ((elt ( |
|
282 | (let ((elt (by-id "qsp-objs"))) | |
277 |
(setf ( |
|
283 | (setf (inner-html elt) "<ul>") | |
278 | (loop :for obj :in (root objs) |
|
284 | (loop :for obj :in (root objs) | |
279 |
:do (incf ( |
|
285 | :do (incf (inner-html elt) (+ "<li>" obj))) | |
280 |
(incf ( |
|
286 | (incf (inner-html elt) "</ul>"))) | |
281 |
|
287 | |||
282 | ;;; Menu |
|
288 | ;;; Menu | |
283 |
|
289 | |||
284 |
(def |
|
290 | (defun menu (menu-data) | |
285 |
(let ((elt ( |
|
291 | (let ((elt (by-id "qsp-dropdown")) | |
286 | (i 0)) |
|
292 | (i 0)) | |
287 |
(setf ( |
|
293 | (setf (inner-html elt) "") | |
288 | (loop :for item :in menu-data |
|
294 | (loop :for item :in menu-data | |
289 | :do (incf i) |
|
295 | :do (incf i) | |
290 |
:do (incf ( |
|
296 | :do (incf (inner-html elt) (make-menu-item-html i | |
291 | (setf elt.style.display "block"))) |
|
297 | (@ item text) | |
|
298 | (@ item icon) | |||
|
299 | (@ item loc)))) | |||
|
300 | (setf (@ elt style display) "block"))) | |||
292 |
|
301 | |||
293 | ;;; Content |
|
302 | ;;; Content | |
294 |
|
303 | |||
295 |
(def |
|
304 | (defun clean-audio () | |
296 |
(loop :for k :in (*object |
|
305 | (loop :for k :in (chain *object (keys (root playing))) | |
297 |
:for v := ( |
|
306 | :for v := (getprop (root playing) k) | |
298 |
:do (when ( |
|
307 | :do (when (@ v ended) | |
299 |
( |
|
308 | (delete (@ (root playing) k))))) | |
300 |
|
309 | |||
301 |
(def |
|
310 | (defun show-image (path) | |
302 |
(let ((img ( |
|
311 | (let ((img (by-id "qsp-image"))) | |
303 | (cond (path |
|
312 | (cond (path | |
304 |
(setf |
|
313 | (setf (@ img src) path) | |
305 |
(setf |
|
314 | (setf (@ img style display) "flex")) | |
306 | (t |
|
315 | (t | |
307 |
(setf |
|
316 | (setf (@ img src) "") | |
308 |
(setf |
|
317 | (setf (@ img style display) "hidden"))))) | |
309 |
|
318 | |||
310 | ;;; Saves |
|
319 | ;;; Saves | |
311 |
|
320 | |||
312 |
(def |
|
321 | (defun opengame () | |
313 |
(let ((element (document |
|
322 | (let ((element (chain document (create-element :input)))) | |
314 |
(element |
|
323 | (chain element (set-attribute :type :file)) | |
315 |
(element |
|
324 | (chain element (set-attribute :id :qsp-opengame)) | |
316 |
(element |
|
325 | (chain element (set-attribute :tabindex -1)) | |
317 |
(element |
|
326 | (chain element (set-attribute "aria-hidden" t)) | |
318 |
(setf element |
|
327 | (setf (@ element style display) :block) | |
319 |
(setf element |
|
328 | (setf (@ element style visibility) :hidden) | |
320 |
(setf element |
|
329 | (setf (@ element style position) :fixed) | |
321 |
(setf element |
|
330 | (setf (@ element onchange) | |
322 | (lambda (event) |
|
331 | (lambda (event) | |
323 |
(let* ((file ( |
|
332 | (let* ((file (@ event target files 0)) | |
324 |
(reader ( |
|
333 | (reader (new (*file-reader)))) | |
325 |
(setf reader |
|
334 | (setf (@ reader onload) | |
326 | (lambda (ev) |
|
335 | (lambda (ev) | |
327 | (block nil |
|
336 | (block nil | |
328 |
|
|
337 | (let ((target (@ ev current-target))) | |
329 |
|
|
338 | (unless (@ target result) | |
330 |
|
|
339 | (return)) | |
331 |
|
|
340 | (base64-to-state (@ target result)) | |
332 |
|
|
341 | (unstash-state))))) | |
333 |
(reader |
|
342 | (chain reader (read-as-text file))))) | |
334 |
(document |
|
343 | (chain document body (append-child element)) | |
335 |
(element |
|
344 | (chain element (click)) | |
336 |
(document |
|
345 | (chain document body (remove-child element)))) | |
337 |
|
346 | |||
338 |
(def |
|
347 | (defun savegame () | |
339 |
(let ((element (document |
|
348 | (let ((element (chain document (create-element :a)))) | |
340 |
(element |
|
349 | (chain element (set-attribute :href (+ "data:text/plain;charset=utf-8," (state-to-base64)))) | |
341 |
(element |
|
350 | (chain element (set-attribute :download "savegame.sav")) | |
342 |
(setf element |
|
351 | (setf (@ element style display) :none) | |
343 |
(document |
|
352 | (chain document body (append-child element)) | |
344 |
(element |
|
353 | (chain element (click)) | |
345 |
(document |
|
354 | (chain document body (remove-child element)))) | |
346 |
|
355 | |||
347 |
(def |
|
356 | (defun stash-state (args) | |
348 |
( |
|
357 | (call-serv-loc "ONGSAVE") | |
349 | (setf (root state-stash) |
|
358 | (setf (root state-stash) | |
350 |
(*j-s-o-n |
|
359 | (chain *j-s-o-n (stringify | |
351 |
( |
|
360 | (create vars (root vars) | |
352 | objs (root objs) |
|
361 | objs (root objs) | |
353 | loc-args args |
|
362 | loc-args args | |
354 |
msecs (- ( |
|
363 | msecs (- (chain *date (now)) (root started-at)) | |
355 |
main-html ( |
|
364 | main-html (inner-html | |
356 |
( |
|
365 | (by-id :qsp-main)) | |
357 |
stat-html ( |
|
366 | stat-html (inner-html | |
358 |
( |
|
367 | (by-id :qsp-stat)) | |
359 | next-location (root current-location)))) |
|
368 | next-location (root current-location))))) | |
360 | (values)) |
|
369 | (values)) | |
361 |
|
370 | |||
362 |
(def |
|
371 | (defun unstash-state () | |
363 |
(let ((data (*j-s-o-n |
|
372 | (let ((data (chain *j-s-o-n (parse (root state-stash))))) | |
364 |
( |
|
373 | (clear-act) | |
365 |
(setf (root vars) ( |
|
374 | (setf (root vars) (@ data vars)) | |
366 |
(loop :for k :in (*object |
|
375 | (loop :for k :in (chain *object (keys (root vars))) | |
367 |
:do (*object |
|
376 | :do (chain *object (set-prototype-of (getprop (root vars) k) | |
368 |
( |
|
377 | (@ *var prototype)))) | |
369 |
(setf (root started-at) (- ( |
|
378 | (setf (root started-at) (- (chain *date (now)) (@ data msecs))) | |
370 |
(setf (root objs) ( |
|
379 | (setf (root objs) (@ data objs)) | |
371 |
(setf (root current-location) ( |
|
380 | (setf (root current-location) (@ data next-location)) | |
372 |
(setf ( |
|
381 | (setf (inner-html (by-id :qsp-main)) | |
373 |
( |
|
382 | (@ data main-html)) | |
374 |
(setf ( |
|
383 | (setf (inner-html (by-id :qsp-stat)) | |
375 |
( |
|
384 | (@ data stat-html)) | |
376 |
( |
|
385 | (update-objs) | |
377 |
( |
|
386 | (call-serv-loc "ONGLOAD") | |
378 |
( |
|
387 | (call-loc (root current-location) (@ data loc-args)) | |
379 | (values))) |
|
388 | (values))) | |
380 |
|
389 | |||
381 |
(def |
|
390 | (defun state-to-base64 () | |
382 | (btoa (encode-u-r-i-component (root state-stash)))) |
|
391 | (btoa (encode-u-r-i-component (root state-stash)))) | |
383 |
|
392 | |||
384 |
(def |
|
393 | (defun base64-to-state (data) | |
385 | (setf (root state-stash) (decode-u-r-i-component (atob data)))) |
|
394 | (setf (root state-stash) (decode-u-r-i-component (atob data)))) | |
386 |
|
395 | |||
387 | ;;; Timers |
|
396 | ;;; Timers | |
388 |
|
397 | |||
389 |
(def |
|
398 | (defun set-timer (interval) | |
390 | (setf (root timer-interval) interval) |
|
399 | (setf (root timer-interval) interval) | |
391 | (clear-interval (root timer-obj)) |
|
400 | (clear-interval (root timer-obj)) | |
392 | (setf (root timer-obj) |
|
401 | (setf (root timer-obj) | |
393 | (set-interval |
|
402 | (set-interval | |
394 | (lambda () |
|
403 | (lambda () | |
395 |
( |
|
404 | (call-serv-loc "COUNTER")) | |
396 | interval))) |
|
405 | interval))) |
@@ -1,28 +1,32 b'' | |||||
1 |
|
1 | |||
2 | (in-package sugar-qsp) |
|
2 | (in-package sugar-qsp) | |
3 |
|
3 | |||
4 | (eval-when (:compile-toplevel :load-toplevel :execute) |
|
4 | (eval-when (:compile-toplevel :load-toplevel :execute) | |
5 | (defun src-file (filename) |
|
5 | (defun src-file (filename) | |
6 | (uiop/pathname:merge-pathnames* |
|
6 | (uiop/pathname:merge-pathnames* | |
7 | filename |
|
7 | filename | |
8 | (asdf:system-source-directory :sugar-qsp))) |
|
8 | (asdf:system-source-directory :sugar-qsp))) | |
9 | (defun read-code-from-string (string) |
|
9 | (defun read-code-from-string (string) | |
10 | (with-input-from-string (in string) |
|
10 | (with-input-from-string (in string) | |
11 | `(progn |
|
11 | (let ((*package* *package*)) | |
12 | ,@(loop :for form := (read in nil :eof) |
|
12 | `(progn | |
13 | :until (eq form :eof) |
|
13 | ,@(loop :for form := (read in nil :eof) | |
14 |
|
|
14 | :until (eq form :eof) | |
|
15 | :when (eq (first form) 'cl:in-package) | |||
|
16 | :do (setf *package* (find-package (second form))) | |||
|
17 | :else | |||
|
18 | :collect form))))) | |||
15 | (defun load-src (filename) |
|
19 | (defun load-src (filename) | |
16 | (alexandria:read-file-into-string (src-file filename)))) |
|
20 | (alexandria:read-file-into-string (src-file filename)))) | |
17 |
|
21 | |||
18 | (defclass compiler () |
|
22 | (defclass compiler () | |
19 | ((body :accessor body :initform #.(load-src "extras/body.html")) |
|
23 | ((body :accessor body :initform #.(load-src "extras/body.html")) | |
20 | (css :accessor css :initform (list #.(load-src "extras/default.css"))) |
|
24 | (css :accessor css :initform (list #.(load-src "extras/default.css"))) | |
21 |
(js :accessor js :initform |
|
25 | (js :accessor js :initform (reverse | |
22 |
|
|
26 | (list | |
23 |
|
|
27 | '#.(read-code-from-string (load-src "src/main.ps")) | |
24 |
|
|
28 | '#.(read-code-from-string (load-src "src/api.ps")) | |
25 |
|
|
29 | '#.(read-code-from-string (load-src "src/intrinsics.ps"))))) | |
26 | (compile :accessor compile-only :initarg :compile) |
|
30 | (compile :accessor compile-only :initarg :compile) | |
27 | (target :accessor target :initarg :target) |
|
31 | (target :accessor target :initarg :target) | |
28 | (beautify :accessor beautify :initarg :beautify))) |
|
32 | (beautify :accessor beautify :initarg :beautify))) |
@@ -1,174 +1,174 b'' | |||||
1 |
|
1 | |||
2 | (in-package sugar-qsp) |
|
2 | (in-package sugar-qsp.lib) | |
3 |
|
3 | |||
4 | ;;;; Macros implementing some intrinsics where it makes sense |
|
4 | ;;;; Macros implementing some intrinsics where it makes sense | |
5 | ;;;; E.g. an equivalent JS function exists, or it's a direct API call |
|
5 | ;;;; E.g. an equivalent JS function exists, or it's a direct API call | |
6 |
|
6 | |||
7 | ;;; 1loc |
|
7 | ;;; 1loc | |
8 |
|
8 | |||
9 | ;;; 2var |
|
9 | ;;; 2var | |
10 |
|
10 | |||
11 |
( |
|
11 | (defpsmacro killvar (varname &optional index) | |
12 |
`( |
|
12 | `(kill-var ,varname ,index)) | |
13 |
|
13 | |||
14 |
( |
|
14 | (defpsmacro killall () | |
15 | `(api-call kill-all)) |
|
15 | `(api-call kill-all)) | |
16 |
|
16 | |||
17 | ;;; 3expr |
|
17 | ;;; 3expr | |
18 |
|
18 | |||
19 |
( |
|
19 | (defpsmacro obj (name) | |
20 | `(funcall (root objs includes) ,name)) |
|
20 | `(funcall (root objs includes) ,name)) | |
21 |
|
21 | |||
22 |
( |
|
22 | (defpsmacro loc (name) | |
23 | `(funcall (root locs includes) ,name)) |
|
23 | `(funcall (root locs includes) ,name)) | |
24 |
|
24 | |||
25 |
( |
|
25 | (defpsmacro no (arg) | |
26 | `(- -1 ,arg)) |
|
26 | `(- -1 ,arg)) | |
27 |
|
27 | |||
28 | ;;; 4code |
|
28 | ;;; 4code | |
29 |
|
29 | |||
30 |
( |
|
30 | (defpsmacro qspver () | |
31 | "0.0.1") |
|
31 | "0.0.1") | |
32 |
|
32 | |||
33 |
( |
|
33 | (defpsmacro curloc () | |
34 | `(root current-location)) |
|
34 | `(root current-location)) | |
35 |
|
35 | |||
36 |
( |
|
36 | (defpsmacro rnd () | |
37 |
`(funcall |
|
37 | `(funcall rand 1 1000)) | |
38 |
|
38 | |||
39 |
( |
|
39 | (defpsmacro qspmax (&rest args) | |
40 | (if (= 1 (length args)) |
|
40 | (if (= 1 (length args)) | |
41 | `(*math.max.apply nil ,@args) |
|
41 | `(*math.max.apply nil ,@args) | |
42 | `(*math.max ,@args))) |
|
42 | `(*math.max ,@args))) | |
43 |
|
43 | |||
44 |
( |
|
44 | (defpsmacro qspmin (&rest args) | |
45 | (if (= 1 (length args)) |
|
45 | (if (= 1 (length args)) | |
46 | `(*math.min.apply nil ,@args) |
|
46 | `(*math.min.apply nil ,@args) | |
47 | `(*math.min ,@args))) |
|
47 | `(*math.min ,@args))) | |
48 |
|
48 | |||
49 | ;;; 5arrays |
|
49 | ;;; 5arrays | |
50 |
|
50 | |||
51 |
( |
|
51 | (defpsmacro arrsize (name) | |
52 | `(api-call array-size ,name)) |
|
52 | `(api-call array-size ,name)) | |
53 |
|
53 | |||
54 | ;;; 6str |
|
54 | ;;; 6str | |
55 |
|
55 | |||
56 |
( |
|
56 | (defpsmacro len (s) | |
57 | `(length ,s)) |
|
57 | `(length ,s)) | |
58 |
|
58 | |||
59 |
( |
|
59 | (defpsmacro mid (s from &optional count) | |
60 |
`( |
|
60 | `(chain ,s (substring ,from ,count))) | |
61 |
|
61 | |||
62 |
( |
|
62 | (defpsmacro ucase (s) | |
63 |
`( |
|
63 | `(chain ,s (to-upper-case))) | |
64 |
|
64 | |||
65 |
( |
|
65 | (defpsmacro lcase (s) | |
66 |
`( |
|
66 | `(chain ,s (to-lower-case))) | |
67 |
|
67 | |||
68 |
( |
|
68 | (defpsmacro trim (s) | |
69 |
`( |
|
69 | `(chain ,s (trim))) | |
70 |
|
70 | |||
71 |
( |
|
71 | (defpsmacro replace (s from to) | |
72 |
`( |
|
72 | `(chain ,s (replace ,from ,to))) | |
73 |
|
73 | |||
74 |
( |
|
74 | (defpsmacro val (s) | |
75 | `(parse-int ,s 10)) |
|
75 | `(parse-int ,s 10)) | |
76 |
|
76 | |||
77 |
( |
|
77 | (defpsmacro qspstr (n) | |
78 |
`( |
|
78 | `(chain ,n (to-string))) | |
79 |
|
79 | |||
80 | ;;; 7if |
|
80 | ;;; 7if | |
81 |
|
81 | |||
82 | ;;; 8sub |
|
82 | ;;; 8sub | |
83 |
|
83 | |||
84 | ;;; 9loops |
|
84 | ;;; 9loops | |
85 |
|
85 | |||
86 | ;; JUMP is in ps-macros.lisp (because it's a part of a huge kludge) |
|
86 | ;; JUMP is in ps-macros.lisp (because it's a part of a huge kludge) | |
87 |
|
87 | |||
88 |
( |
|
88 | (defpsmacro exit () | |
89 | `(return-from nil (values))) |
|
89 | `(return-from nil (values))) | |
90 |
|
90 | |||
91 | ;;; 10dynamic |
|
91 | ;;; 10dynamic | |
92 |
|
92 | |||
93 | ;;; 11main |
|
93 | ;;; 11main | |
94 |
|
94 | |||
95 |
( |
|
95 | (defpsmacro desc (s) | |
96 | (declare (ignore s)) |
|
96 | (declare (ignore s)) | |
97 | "") |
|
97 | "") | |
98 |
|
98 | |||
99 | ;;; 12stat |
|
99 | ;;; 12stat | |
100 |
|
100 | |||
101 |
( |
|
101 | (defpsmacro showstat (enable) | |
102 | `(api-call enable-frame :stat ,enable)) |
|
102 | `(api-call enable-frame :stat ,enable)) | |
103 |
|
103 | |||
104 | ;;; 13diag |
|
104 | ;;; 13diag | |
105 |
|
105 | |||
106 |
( |
|
106 | (defpsmacro msg (text) | |
107 | `(alert ,text)) |
|
107 | `(alert ,text)) | |
108 |
|
108 | |||
109 | ;;; 14act |
|
109 | ;;; 14act | |
110 |
|
110 | |||
111 |
( |
|
111 | (defpsmacro showacts (enable) | |
112 | `(api-call enable-frame :acts ,enable)) |
|
112 | `(api-call enable-frame :acts ,enable)) | |
113 |
|
113 | |||
114 |
( |
|
114 | (defpsmacro delact (name) | |
115 | `(api-call del-act ,name)) |
|
115 | `(api-call del-act ,name)) | |
116 |
|
116 | |||
117 |
( |
|
117 | (defpsmacro cla () | |
118 | `(api-call clear-act)) |
|
118 | `(api-call clear-act)) | |
119 |
|
119 | |||
120 | ;;; 15objs |
|
120 | ;;; 15objs | |
121 |
|
121 | |||
122 |
( |
|
122 | (defpsmacro showobjs (enable) | |
123 | `(api-call enable-frame :objs ,enable)) |
|
123 | `(api-call enable-frame :objs ,enable)) | |
124 |
|
124 | |||
125 |
( |
|
125 | (defpsmacro countobj () | |
126 | `(length (root objs))) |
|
126 | `(length (root objs))) | |
127 |
|
127 | |||
128 |
( |
|
128 | (defpsmacro getobj (index) | |
129 | `(or (elt (root objs) ,index) "")) |
|
129 | `(or (elt (root objs) ,index) "")) | |
130 |
|
130 | |||
131 | ;;; 16menu |
|
131 | ;;; 16menu | |
132 |
|
132 | |||
133 | ;;; 17sound |
|
133 | ;;; 17sound | |
134 |
|
134 | |||
135 |
( |
|
135 | (defpsmacro isplay (filename) | |
136 | `(funcall (root playing includes) ,filename)) |
|
136 | `(funcall (root playing includes) ,filename)) | |
137 |
|
137 | |||
138 | ;;; 18img |
|
138 | ;;; 18img | |
139 |
|
139 | |||
140 |
( |
|
140 | (defpsmacro view (&optional path) | |
141 | `(api-call show-image ,path)) |
|
141 | `(api-call show-image ,path)) | |
142 |
|
142 | |||
143 | ;;; 19input |
|
143 | ;;; 19input | |
144 |
|
144 | |||
145 |
( |
|
145 | (defpsmacro showinput (enable) | |
146 | `(api-call enable-frame :input ,enable)) |
|
146 | `(api-call enable-frame :input ,enable)) | |
147 |
|
147 | |||
148 | ;;; 20time |
|
148 | ;;; 20time | |
149 |
|
149 | |||
150 |
( |
|
150 | (defpsmacro wait (msec) | |
151 | `(await (api-call sleep ,msec))) |
|
151 | `(await (api-call sleep ,msec))) | |
152 |
|
152 | |||
153 |
( |
|
153 | (defpsmacro settimer (interval) | |
154 | `(api-call set-timer ,interval)) |
|
154 | `(api-call set-timer ,interval)) | |
155 |
|
155 | |||
156 | ;;; 21local |
|
156 | ;;; 21local | |
157 |
|
157 | |||
158 |
( |
|
158 | (defpsmacro local (var &optional expr) | |
159 | `(progn |
|
159 | `(progn | |
160 | (api-call new-local ,(string (second var))) |
|
160 | (api-call new-local ,(string (second var))) | |
161 | ,@(when expr |
|
161 | ,@(when expr | |
162 | `((set ,var ,expr))))) |
|
162 | `((set ,var ,expr))))) | |
163 |
|
163 | |||
164 | ;;; 22for |
|
164 | ;;; 22for | |
165 |
|
165 | |||
166 | ;;; misc |
|
166 | ;;; misc | |
167 |
|
167 | |||
168 |
( |
|
168 | (defpsmacro opengame (&optional filename) | |
169 | (declare (ignore filename)) |
|
169 | (declare (ignore filename)) | |
170 | `(api-call opengame)) |
|
170 | `(api-call opengame)) | |
171 |
|
171 | |||
172 |
( |
|
172 | (defpsmacro savegame (&optional filename) | |
173 | (declare (ignore filename)) |
|
173 | (declare (ignore filename)) | |
174 | `(api-call savegame)) |
|
174 | `(api-call savegame)) |
@@ -1,301 +1,301 b'' | |||||
1 |
|
1 | |||
2 | (in-package sugar-qsp) |
|
2 | (in-package sugar-qsp.lib) | |
3 |
|
3 | |||
4 | ;;;; Functions and procedures defined by the QSP language. |
|
4 | ;;;; Functions and procedures defined by the QSP language. | |
5 | ;;;; They can call api and deal with locations and other data directly. |
|
5 | ;;;; They can call api and deal with locations and other data directly. | |
6 | ;;;; Except vars. Use VAR and SET or GET-VAR and SET-VAR api calls. |
|
6 | ;;;; Except vars. Use VAR and SET or GET-VAR and SET-VAR api calls. | |
7 |
|
7 | |||
8 | (setf (root lib) (ps:create)) |
|
|||
9 |
|
||||
10 | ;;; 1loc |
|
8 | ;;; 1loc | |
11 |
|
9 | |||
12 |
(def |
|
10 | (defun goto (target args) | |
13 |
(api |
|
11 | (api:clear-text :main) | |
14 |
(funcall |
|
12 | (funcall xgoto target (or args (list))) | |
15 | (values)) |
|
13 | (values)) | |
16 |
|
14 | |||
17 |
(def |
|
15 | (defun xgoto (target args) | |
18 |
(api |
|
16 | (api:clear-act) | |
19 |
(setf (root current-location) ( |
|
17 | (setf (root current-location) (chain target (to-upper-case))) | |
20 |
(api |
|
18 | (api:stash-state args) | |
21 |
(funcall ( |
|
19 | (funcall (getprop (root locs) (root current-location)) | |
22 | (or args (list))) |
|
20 | (or args (list))) | |
23 | (values)) |
|
21 | (values)) | |
24 |
|
22 | |||
25 | ;;; 2var |
|
23 | ;;; 2var | |
26 |
|
24 | |||
27 | ;;; 3expr |
|
25 | ;;; 3expr | |
28 |
|
26 | |||
29 | ;;; 4code |
|
27 | ;;; 4code | |
30 |
|
28 | |||
31 |
(def |
|
29 | (defun rand (a &optional (b 1)) | |
32 | (let ((min (min a b)) |
|
30 | (let ((min (min a b)) | |
33 | (max (max a b))) |
|
31 | (max (max a b))) | |
34 |
(+ min ( |
|
32 | (+ min (chain *math (random (- max min)))))) | |
35 |
|
33 | |||
36 | ;;; 5arrays |
|
34 | ;;; 5arrays | |
37 |
|
35 | |||
38 |
(def |
|
36 | (defun copyarr (to from start count) | |
39 | (multiple-value-bind (to-name to-slot) |
|
37 | (multiple-value-bind (to-name to-slot) | |
40 |
(api |
|
38 | (api:var-real-name to) | |
41 | (multiple-value-bind (from-name from-slot) |
|
39 | (multiple-value-bind (from-name from-slot) | |
42 |
(api |
|
40 | (api:var-real-name from) | |
43 |
( |
|
41 | (for ((i start)) | |
44 |
|
|
42 | ((< i (min (api:array-size from-name) | |
45 |
|
|
43 | (+ start count)))) | |
46 |
|
|
44 | ((incf i)) | |
47 |
|
|
45 | (api:set-var to-name (+ start i) to-slot | |
48 |
(api |
|
46 | (api:get-var from-name (+ start i) from-slot)))))) | |
49 |
|
47 | |||
50 |
(def |
|
48 | (defun arrpos (name value &optional (start 0)) | |
51 | (multiple-value-bind (real-name slot) |
|
49 | (multiple-value-bind (real-name slot) | |
52 |
(api |
|
50 | (api:var-real-name name) | |
53 |
( |
|
51 | (for ((i start)) ((< i (api:array-size name))) ((incf i)) | |
54 |
(when (eq (api |
|
52 | (when (eq (api:get-var real-name i slot) value) | |
55 | (return i)))) |
|
53 | (return-from arrpos i)))) | |
56 | -1) |
|
54 | -1) | |
57 |
|
55 | |||
58 |
(def |
|
56 | (defun arrcomp (name pattern &optional (start 0)) | |
59 | (multiple-value-bind (real-name slot) |
|
57 | (multiple-value-bind (real-name slot) | |
60 |
(api |
|
58 | (api:var-real-name name) | |
61 |
( |
|
59 | (for ((i start)) ((< i (api:array-size name))) ((incf i)) | |
62 |
(when (funcall ( |
|
60 | (when (funcall (getprop (api:get-var real-name i slot) 'match) pattern) | |
63 | (return i)))) |
|
61 | (return-from arrcomp i)))) | |
64 | -1) |
|
62 | -1) | |
65 |
|
63 | |||
66 | ;;; 6str |
|
64 | ;;; 6str | |
67 |
|
65 | |||
68 |
(def |
|
66 | (defun instr (s subs &optional (start 1)) | |
69 |
(+ start ( |
|
67 | (+ start (chain s (substring (- start 1)) (search subs)))) | |
70 |
|
68 | |||
71 |
(def |
|
69 | (defun isnum (s) | |
72 | (if (is-na-n s) |
|
70 | (if (is-na-n s) | |
73 | 0 |
|
71 | 0 | |
74 | -1)) |
|
72 | -1)) | |
75 |
|
73 | |||
76 |
(def |
|
74 | (defun strcomp (s pattern) | |
77 |
(if ( |
|
75 | (if (chain s (match pattern)) | |
78 | -1 |
|
76 | -1 | |
79 | 0)) |
|
77 | 0)) | |
80 |
|
78 | |||
81 |
(def |
|
79 | (defun strfind (s pattern group) | |
82 |
(let* ((re ( |
|
80 | (let* ((re (new (*reg-exp pattern))) | |
83 |
(match ( |
|
81 | (match (chain re (exec s)))) | |
84 |
( |
|
82 | (chain match (group group)))) | |
85 |
|
83 | |||
86 |
(def |
|
84 | (defun strpos (s pattern &optional (group 0)) | |
87 |
(let* ((re ( |
|
85 | (let* ((re (new (*reg-exp pattern))) | |
88 |
(match ( |
|
86 | (match (chain re (exec s))) | |
89 |
(found ( |
|
87 | (found (chain match (group group)))) | |
90 | (if found |
|
88 | (if found | |
91 |
( |
|
89 | (chain s (search found)) | |
92 | 0))) |
|
90 | 0))) | |
93 |
|
91 | |||
94 | ;;; 7if |
|
92 | ;;; 7if | |
95 |
|
93 | |||
96 | ;; Has to be a function because it always evaluates all three of its |
|
94 | ;; Has to be a function because it always evaluates all three of its | |
97 | ;; arguments |
|
95 | ;; arguments | |
98 |
(def |
|
96 | (defun iif (cond-expr then-expr else-expr) | |
99 | (if cond-expr then-expr else-expr)) |
|
97 | (if cond-expr then-expr else-expr)) | |
100 |
|
98 | |||
101 | ;;; 8sub |
|
99 | ;;; 8sub | |
102 |
|
100 | |||
103 |
(def |
|
101 | (defun gosub (target &rest args) | |
104 |
(funcall ( |
|
102 | (funcall (getprop (root locs) target) args) | |
105 | (values)) |
|
103 | (values)) | |
106 |
|
104 | |||
107 |
(def |
|
105 | (defun func (target &rest args) | |
108 |
(funcall ( |
|
106 | (funcall (getprop (root locs) target) args)) | |
109 |
|
107 | |||
110 | ;;; 9loops |
|
108 | ;;; 9loops | |
111 |
|
109 | |||
112 | ;;; 10dynamic |
|
110 | ;;; 10dynamic | |
113 |
|
111 | |||
114 |
(def |
|
112 | (defun dynamic (block &rest args) | |
115 | (when (stringp block) |
|
113 | (when (stringp block) | |
116 |
(api |
|
114 | (api:report-error "DYNAMIC can't evaluate arbitrary strings.\nUse {braces} to create blocks for DYNAMIC.")) | |
117 | (funcall block args) |
|
115 | (api:with-call-args args | |
|
116 | (funcall block args)) | |||
118 | (values)) |
|
117 | (values)) | |
119 |
|
118 | |||
120 |
(def |
|
119 | (defun dyneval (block &rest args) | |
121 | (when (stringp block) |
|
120 | (when (stringp block) | |
122 |
(api |
|
121 | (api:report-error "DYNEVAL can't evaluate arbitrary strings.\nUse {braces} to create blocks for DYNEVAL.")) | |
123 | (funcall block args)) |
|
122 | (api:with-call-args args | |
|
123 | (funcall block args))) | |||
124 |
|
124 | |||
125 | ;;; 11main |
|
125 | ;;; 11main | |
126 |
|
126 | |||
127 |
(def |
|
127 | (defun main-p (s) | |
128 |
(api |
|
128 | (api:add-text :main s) | |
129 | (values)) |
|
129 | (values)) | |
130 |
|
130 | |||
131 |
(def |
|
131 | (defun main-pl (s) | |
132 |
(api |
|
132 | (api:add-text :main s) | |
133 |
(api |
|
133 | (api:newline :main) | |
134 | (values)) |
|
134 | (values)) | |
135 |
|
135 | |||
136 |
(def |
|
136 | (defun main-nl (s) | |
137 |
(api |
|
137 | (api:newline :main) | |
138 |
(api |
|
138 | (api:add-text :main s) | |
139 | (values)) |
|
139 | (values)) | |
140 |
|
140 | |||
141 |
(def |
|
141 | (defun maintxt (s) | |
142 |
(api |
|
142 | (api:get-text :main) | |
143 | (values)) |
|
143 | (values)) | |
144 |
|
144 | |||
145 | ;; For clarity (it leaves a lib.desc() call in JS) |
|
145 | ;; For clarity (it leaves a lib.desc() call in JS) | |
146 |
(def |
|
146 | (defun desc (s) | |
147 | "") |
|
147 | "") | |
148 |
|
148 | |||
149 |
(def |
|
149 | (defun main-clear () | |
150 |
(api |
|
150 | (api:clear-text :main) | |
151 | (values)) |
|
151 | (values)) | |
152 |
|
152 | |||
153 | ;;; 12stat |
|
153 | ;;; 12stat | |
154 |
|
154 | |||
155 |
(def |
|
155 | (defun stat-p (s) | |
156 |
(api |
|
156 | (api:add-text :stat s) | |
157 | (values)) |
|
157 | (values)) | |
158 |
|
158 | |||
159 |
(def |
|
159 | (defun stat-pl (s) | |
160 |
(api |
|
160 | (api:add-text :stat s) | |
161 |
(api |
|
161 | (api:newline :stat) | |
162 | (values)) |
|
162 | (values)) | |
163 |
|
163 | |||
164 |
(def |
|
164 | (defun stat-nl (s) | |
165 |
(api |
|
165 | (api:newline :stat) | |
166 |
(api |
|
166 | (api:add-text :stat s) | |
167 | (values)) |
|
167 | (values)) | |
168 |
|
168 | |||
169 |
(def |
|
169 | (defun stattxt (s) | |
170 |
(api |
|
170 | (api:get-text :stat) | |
171 | (values)) |
|
171 | (values)) | |
172 |
|
172 | |||
173 |
(def |
|
173 | (defun stat-clear () | |
174 |
(api |
|
174 | (api:clear-text :stat) | |
175 | (values)) |
|
175 | (values)) | |
176 |
|
176 | |||
177 |
(def |
|
177 | (defun cls () | |
178 | (funcall (root lib stat-clear)) |
|
178 | (stat-clear) | |
179 | (funcall (root lib main-clear)) |
|
179 | (main-clear) | |
180 | (funcall (root lib cla)) |
|
180 | (cla) | |
181 | (funcall (root lib cmdclear)) |
|
181 | (cmdclear) | |
182 | (values)) |
|
182 | (values)) | |
183 |
|
183 | |||
184 | ;;; 13diag |
|
184 | ;;; 13diag | |
185 |
|
185 | |||
186 | ;;; 14act |
|
186 | ;;; 14act | |
187 |
|
187 | |||
188 |
(def |
|
188 | (defun curacts () | |
189 | (let ((acts (root acts))) |
|
189 | (let ((acts (root acts))) | |
190 | (lambda () |
|
190 | (lambda () | |
191 | (setf (root acts) acts) |
|
191 | (setf (root acts) acts) | |
192 | (values)))) |
|
192 | (values)))) | |
193 |
|
193 | |||
194 | ;;; 15objs |
|
194 | ;;; 15objs | |
195 |
|
195 | |||
196 |
(def |
|
196 | (defun addobj (name) | |
197 |
( |
|
197 | (chain (root objs) (push name)) | |
198 |
(api |
|
198 | (api:update-objs) | |
199 | (values)) |
|
199 | (values)) | |
200 |
|
200 | |||
201 |
(def |
|
201 | (defun delobj (name) | |
202 |
(let ((index ( |
|
202 | (let ((index (chain (root objs) (index-of name)))) | |
203 | (when (> index -1) |
|
203 | (when (> index -1) | |
204 |
( |
|
204 | (killobj (1+ index)))) | |
205 | (values)) |
|
205 | (values)) | |
206 |
|
206 | |||
207 |
(def |
|
207 | (defun killobj (&optional (num nil)) | |
208 | (if (eq nil num) |
|
208 | (if (eq nil num) | |
209 | (setf (root objs) (list)) |
|
209 | (setf (root objs) (list)) | |
210 |
( |
|
210 | (chain (root objs) (splice (1- num) 1))) | |
211 |
(api |
|
211 | (api:update-objs) | |
212 | (values)) |
|
212 | (values)) | |
213 |
|
213 | |||
214 | ;;; 16menu |
|
214 | ;;; 16menu | |
215 |
|
215 | |||
216 |
(def |
|
216 | (defun menu (menu-name) | |
217 | (let ((menu-data (list))) |
|
217 | (let ((menu-data (list))) | |
218 |
(loop :for item :in (api |
|
218 | (loop :for item :in (api:get-array (api:var-real-name menu-name)) | |
219 | :do (cond ((string= item "") |
|
219 | :do (cond ((string= item "") | |
220 | (break)) |
|
220 | (break)) | |
221 | ((string= item "-:-") |
|
221 | ((string= item "-:-") | |
222 |
( |
|
222 | (chain menu-data (push :delimiter))) | |
223 | (t |
|
223 | (t | |
224 |
(let* ((tokens ( |
|
224 | (let* ((tokens (chain item (split ":")))) | |
225 | (when (= (length tokens) 2) |
|
225 | (when (= (length tokens) 2) | |
226 |
(tokens |
|
226 | (chain tokens (push ""))) | |
227 |
(let* ((text ( |
|
227 | (let* ((text (chain tokens (splice 0 (- (length tokens) 2)) (join ":"))) | |
228 |
(loc ( |
|
228 | (loc (getprop tokens (- (length tokens) 2))) | |
229 |
(icon ( |
|
229 | (icon (getprop tokens (- (length tokens) 1)))) | |
230 |
( |
|
230 | (chain menu-data | |
231 |
|
|
231 | (push (create text text | |
232 |
|
|
232 | loc loc | |
233 |
|
|
233 | icon icon)))))))) | |
234 |
(api |
|
234 | (api:menu menu-data) | |
235 | (values))) |
|
235 | (values))) | |
236 |
|
236 | |||
237 | ;;; 17sound |
|
237 | ;;; 17sound | |
238 |
|
238 | |||
239 |
(def |
|
239 | (defun play (filename &optional (volume 100)) | |
240 |
(let ((audio ( |
|
240 | (let ((audio (new (*audio filename)))) | |
241 |
(setf ( |
|
241 | (setf (getprop (root playing) filename) audio) | |
242 |
(setf ( |
|
242 | (setf (@ audio volume) (* volume 0.01)) | |
243 |
( |
|
243 | (chain audio (play)))) | |
244 |
|
244 | |||
245 |
(def |
|
245 | (defun close (filename) | |
246 | (funcall (root playing filename) stop) |
|
246 | (funcall (root playing filename) stop) | |
247 |
( |
|
247 | (delete (root playing filename))) | |
248 |
|
248 | |||
249 |
(def |
|
249 | (defun closeall () | |
250 |
(loop :for k :in (*object |
|
250 | (loop :for k :in (chain *object (keys (root playing))) | |
251 |
:for v := ( |
|
251 | :for v := (getprop (root playing) k) | |
252 | :do (funcall v stop)) |
|
252 | :do (funcall v stop)) | |
253 |
(setf (root playing) ( |
|
253 | (setf (root playing) (create))) | |
254 |
|
254 | |||
255 | ;;; 18img |
|
255 | ;;; 18img | |
256 |
|
256 | |||
257 |
(def |
|
257 | (defun refint () | |
258 | ;; "Force interface update" Uh... what exactly do we do here? |
|
258 | ;; "Force interface update" Uh... what exactly do we do here? | |
259 |
(api |
|
259 | (api:report-error "REFINT is not supported") | |
260 | ) |
|
260 | ) | |
261 |
|
261 | |||
262 | ;;; 19input |
|
262 | ;;; 19input | |
263 |
|
263 | |||
264 |
(def |
|
264 | (defun usertxt () | |
265 |
(let ((input ( |
|
265 | (let ((input (by-id "qsp-input"))) | |
266 |
( |
|
266 | (@ input value))) | |
267 |
|
267 | |||
268 |
(def |
|
268 | (defun cmdclear () | |
269 |
(let ((input ( |
|
269 | (let ((input (by-id "qsp-input"))) | |
270 |
(setf ( |
|
270 | (setf (@ input value) ""))) | |
271 |
|
271 | |||
272 |
(def |
|
272 | (defun input (text) | |
273 |
(window |
|
273 | (chain window (prompt text))) | |
274 |
|
274 | |||
275 | ;;; 20time |
|
275 | ;;; 20time | |
276 |
|
276 | |||
277 |
(def |
|
277 | (defun msecscount () | |
278 |
(- ( |
|
278 | (- (chain *date (now)) (root started-at))) | |
279 |
|
279 | |||
280 | ;;; 21local |
|
280 | ;;; 21local | |
281 |
|
281 | |||
282 | ;;; 22for |
|
282 | ;;; 22for | |
283 |
|
283 | |||
284 | ;;; misc |
|
284 | ;;; misc | |
285 |
|
285 | |||
286 |
(def |
|
286 | (defun rgb (red green blue) | |
287 | (flet ((rgb-to-hex (comp) |
|
287 | (flet ((rgb-to-hex (comp) | |
288 |
(let ((hex ( |
|
288 | (let ((hex (chain (*number comp) (to-string 16)))) | |
289 | (if (< (length hex) 2) |
|
289 | (if (< (length hex) 2) | |
290 | (+ "0" hex) |
|
290 | (+ "0" hex) | |
291 | hex)))) |
|
291 | hex)))) | |
292 | (+ "#" (rgb-to-hex red) (rgb-to-hex green) (rgb-to-hex red)))) |
|
292 | (+ "#" (rgb-to-hex red) (rgb-to-hex green) (rgb-to-hex red)))) | |
293 |
|
293 | |||
294 |
(def |
|
294 | (defun openqst () | |
295 |
(api |
|
295 | (api:report-error "OPENQST is not supported.")) | |
296 |
|
296 | |||
297 |
(def |
|
297 | (defun addqst () | |
298 |
(api |
|
298 | (api:report-error "ADDQST is not supported. Bundle the library with the main game.")) | |
299 |
|
299 | |||
300 |
(def |
|
300 | (defun killqst () | |
301 |
(api |
|
301 | (api:report-error "KILLQST is not supported.")) |
@@ -1,121 +1,135 b'' | |||||
1 |
|
1 | |||
2 | (in-package sugar-qsp) |
|
2 | (in-package sugar-qsp) | |
3 |
|
3 | |||
4 | (defun entry-point-no-args () |
|
4 | (defun entry-point-no-args () | |
5 | (entry-point uiop:*command-line-arguments*)) |
|
5 | (entry-point uiop:*command-line-arguments*)) | |
6 |
|
6 | |||
7 | (defun entry-point (args) |
|
7 | (defun entry-point (args) | |
8 | (catch :terminate |
|
8 | (catch :terminate | |
9 | (let ((compiler (apply #'make-instance 'compiler (parse-opts args)))) |
|
9 | (let ((compiler (apply #'make-instance 'compiler (parse-opts args)))) | |
10 | (write-compiled-file compiler))) |
|
10 | (write-compiled-file compiler))) | |
11 | (values)) |
|
11 | (values)) | |
12 |
|
12 | |||
13 | (defun parse-opts (args) |
|
13 | (defun parse-opts (args) | |
14 | (let ((mode :source) |
|
14 | (let ((mode :source) | |
15 | (data (list :source nil :target nil :js nil :css nil :body nil :compile nil :beautify nil))) |
|
15 | (data (list :source nil :target nil :js nil :css nil :body nil :compile nil :beautify nil))) | |
16 | (loop :for arg :in args |
|
16 | (loop :for arg :in args | |
17 | :do (alexandria:switch (arg :test #'string=) |
|
17 | :do (alexandria:switch (arg :test #'string=) | |
18 | ("-o" (setf mode :target)) |
|
18 | ("-o" (setf mode :target)) | |
19 | ("--js" (setf mode :js)) |
|
19 | ("--js" (setf mode :js)) | |
20 | ("--css" (setf mode :css)) |
|
20 | ("--css" (setf mode :css)) | |
21 | ("--body" (setf mode :body)) |
|
21 | ("--body" (setf mode :body)) | |
22 | ("-c" (setf (getf data :compile) t)) |
|
22 | ("-c" (setf (getf data :compile) t)) | |
23 | ("--beautify" (setf (getf data :beautify) t)) |
|
23 | ("--beautify" (setf (getf data :beautify) t)) | |
24 | (t (push arg (getf data mode))))) |
|
24 | (t (push arg (getf data mode))))) | |
25 | (unless (= 1 (length (getf data :source))) |
|
25 | (unless (= 1 (length (getf data :source))) | |
26 | (print-usage) |
|
26 | (print-usage) | |
27 | (report-error "There should be exactly one source")) |
|
27 | (report-error "There should be exactly one source")) | |
28 | (unless (> 1 (length (getf data :target))) |
|
28 | (unless (> 1 (length (getf data :target))) | |
29 | (print-usage) |
|
29 | (print-usage) | |
30 | (report-error "There should be no more than one target")) |
|
30 | (report-error "There should be no more than one target")) | |
31 | (unless (> 1 (length (getf data :body))) |
|
31 | (unless (> 1 (length (getf data :body))) | |
32 | (print-usage) |
|
32 | (print-usage) | |
33 | (report-error "There should be no more than one body")) |
|
33 | (report-error "There should be no more than one body")) | |
34 | (unless (getf data :target) |
|
34 | (unless (getf data :target) | |
35 | (setf (getf data :target) |
|
35 | (setf (getf data :target) | |
36 | (let* ((source (first (getf data :source))) |
|
36 | (let* ((source (first (getf data :source))) | |
37 | (tokens (uiop:split-string source :separator ".")) |
|
37 | (tokens (uiop:split-string source :separator ".")) | |
38 | (target (format nil "~{~A~^.~}.html" |
|
38 | (target (format nil "~{~A~^.~}.html" | |
39 | (butlast tokens)))) |
|
39 | (butlast tokens)))) | |
40 | (list target)))) |
|
40 | (list target)))) | |
41 | (list :source (first (getf data :source)) |
|
41 | (list :source (first (getf data :source)) | |
42 | :target (first (getf data :target)) |
|
42 | :target (first (getf data :target)) | |
43 | :js (getf data :js) |
|
43 | :js (getf data :js) | |
44 | :css (getf data :css) |
|
44 | :css (getf data :css) | |
45 | :body (first (getf data :body)) |
|
45 | :body (first (getf data :body)) | |
46 | :compile (getf data :compile) |
|
46 | :compile (getf data :compile) | |
47 | :beautify (getf data :beautify)))) |
|
47 | :beautify (getf data :beautify)))) | |
48 |
|
48 | |||
49 | (defun print-usage () |
|
49 | (defun print-usage () | |
50 | (format t "USAGE: ")) |
|
50 | (format t "USAGE: ")) | |
51 |
|
51 | |||
52 | (defun parse-file (filename) |
|
52 | (defun parse-file (filename) | |
53 | (p:parse 'sugar-qsp-grammar |
|
53 | (p:parse 'sugar-qsp-grammar | |
54 | (alexandria:read-file-into-string filename))) |
|
54 | (alexandria:read-file-into-string filename))) | |
55 |
|
55 | |||
56 | (defun report-error (fmt &rest args) |
|
56 | (defun report-error (fmt &rest args) | |
57 | (apply #'format t fmt args) |
|
57 | (apply #'format t fmt args) | |
58 | (throw :terminate nil)) |
|
58 | (throw :terminate nil)) | |
59 |
|
59 | |||
60 | ;;; JS |
|
60 | ;;; JS | |
61 |
|
61 | |||
|
62 | (defun minify-package (package-designator minify prefix) | |||
|
63 | (setf (ps:ps-package-prefix package-designator) prefix) | |||
|
64 | (if minify | |||
|
65 | (ps:obfuscate-package package-designator) | |||
|
66 | (ps:unobfuscate-package package-designator))) | |||
|
67 | ||||
62 | (defmethod js-sources ((compiler compiler)) |
|
68 | (defmethod js-sources ((compiler compiler)) | |
63 | (let ((ps:*ps-print-pretty* (beautify compiler))) |
|
69 | (let ((ps:*ps-print-pretty* (beautify compiler))) | |
|
70 | (cond ((beautify compiler) | |||
|
71 | (minify-package "SUGAR-QSP.MAIN" nil "qsp_") | |||
|
72 | (minify-package "SUGAR-QSP.API" nil "qsp_api_") | |||
|
73 | (minify-package "SUGAR-QSP.LIB" nil "qsp_lib_")) | |||
|
74 | (t | |||
|
75 | (minify-package "SUGAR-QSP.MAIN" t "_") | |||
|
76 | (minify-package "SUGAR-QSP.API" t "a_") | |||
|
77 | (minify-package "SUGAR-QSP.LIB" t "l_"))) | |||
64 | (format nil "~{~A~^~%~%~}" (mapcar #'ps:ps* (reverse (js compiler)))))) |
|
78 | (format nil "~{~A~^~%~%~}" (mapcar #'ps:ps* (reverse (js compiler)))))) | |
65 |
|
79 | |||
66 | ;;; CSS |
|
80 | ;;; CSS | |
67 |
|
81 | |||
68 | (defmethod css-sources ((compiler compiler)) |
|
82 | (defmethod css-sources ((compiler compiler)) | |
69 | (format nil "~{~A~^~%~%~}" (css compiler))) |
|
83 | (format nil "~{~A~^~%~%~}" (css compiler))) | |
70 |
|
84 | |||
71 | ;;; HTML |
|
85 | ;;; HTML | |
72 |
|
86 | |||
73 | (defmethod html-sources ((compiler compiler)) |
|
87 | (defmethod html-sources ((compiler compiler)) | |
74 | (let ((flute:*escape-html* nil) |
|
88 | (let ((flute:*escape-html* nil) | |
75 | (body-template (body compiler)) |
|
89 | (body-template (body compiler)) | |
76 | (js (js-sources compiler)) |
|
90 | (js (js-sources compiler)) | |
77 | (css (css-sources compiler))) |
|
91 | (css (css-sources compiler))) | |
78 | (with-output-to-string (out) |
|
92 | (with-output-to-string (out) | |
79 | (write |
|
93 | (write | |
80 | (flute:h |
|
94 | (flute:h | |
81 | (html |
|
95 | (html | |
82 | (head |
|
96 | (head | |
83 | (title "SugarQSP")) |
|
97 | (title "SugarQSP")) | |
84 | (body |
|
98 | (body | |
85 | body-template |
|
99 | body-template | |
86 | (style css) |
|
100 | (style css) | |
87 | (script js)))) |
|
101 | (script js)))) | |
88 | :stream out |
|
102 | :stream out | |
89 | :pretty nil)))) |
|
103 | :pretty nil)))) | |
90 |
|
104 | |||
91 | (defmethod initialize-instance ((compiler compiler) &key source ((:js js-files)) ((:css css-files)) ((:body body-file)) compile &allow-other-keys) |
|
105 | (defmethod initialize-instance ((compiler compiler) &key source ((:js js-files)) ((:css css-files)) ((:body body-file)) compile &allow-other-keys) | |
92 | (call-next-method) |
|
106 | (call-next-method) | |
93 | (with-slots (body css js) |
|
107 | (with-slots (body css js) | |
94 | compiler |
|
108 | compiler | |
95 | ;; Compile the game's JS |
|
109 | ;; Compile the game's JS | |
96 | (push (list* 'progn (parse-file source)) js) |
|
110 | (push (list* 'progn (parse-file source)) js) | |
97 | ;; Does the user need us to do anything else |
|
111 | ;; Does the user need us to do anything else | |
98 | (unless compile |
|
112 | (unless compile | |
99 | ;; Read in body |
|
113 | ;; Read in body | |
100 | (when body-file |
|
114 | (when body-file | |
101 | (setf body |
|
115 | (setf body | |
102 | (alexandria:read-file-into-string body-file))) |
|
116 | (alexandria:read-file-into-string body-file))) | |
103 | ;; Include js files |
|
117 | ;; Include js files | |
104 | (dolist (js-file js-files) |
|
118 | (dolist (js-file js-files) | |
105 | (push (format nil "////// Included file ~A~%~A" js-file |
|
119 | (push (format nil "////// Included file ~A~%~A" js-file | |
106 | (alexandria:read-file-into-string js-file)) |
|
120 | (alexandria:read-file-into-string js-file)) | |
107 | js)) |
|
121 | js)) | |
108 | ;; Include css files |
|
122 | ;; Include css files | |
109 | (dolist (css-file css-files) |
|
123 | (dolist (css-file css-files) | |
110 | (push (format nil "////// Included file ~A~%~A" css-file |
|
124 | (push (format nil "////// Included file ~A~%~A" css-file | |
111 | (alexandria:read-file-into-string css-file)) |
|
125 | (alexandria:read-file-into-string css-file)) | |
112 | css))))) |
|
126 | css))))) | |
113 |
|
127 | |||
114 | (defmethod write-compiled-file ((compiler compiler)) |
|
128 | (defmethod write-compiled-file ((compiler compiler)) | |
115 | (alexandria:write-string-into-file |
|
129 | (alexandria:write-string-into-file | |
116 | (if (compile-only compiler) |
|
130 | (if (compile-only compiler) | |
117 | ;; Just the JS |
|
131 | ;; Just the JS | |
118 | (preprocess-js (js-sources compiler) (beautify compiler)) |
|
132 | (preprocess-js (js-sources compiler) (beautify compiler)) | |
119 | ;; All of it |
|
133 | ;; All of it | |
120 | (html-sources compiler)) |
|
134 | (html-sources compiler)) | |
121 | (target compiler) :if-exists :supersede)) |
|
135 | (target compiler) :if-exists :supersede)) |
@@ -1,41 +1,43 b'' | |||||
1 |
|
1 | |||
2 | (in-package sugar-qsp) |
|
2 | (in-package sugar-qsp.main) | |
3 |
|
3 | |||
4 | (setf (root) |
|
4 | (setf (root) | |
5 |
( |
|
5 | (create | |
6 | ;;; Game session state |
|
6 | ;;; Game session state | |
7 | ;; Variables |
|
7 | ;; Variables | |
8 |
vars ( |
|
8 | vars (create) | |
9 | ;; Inventory (objects) |
|
9 | ;; Inventory (objects) | |
10 | objs (list) |
|
10 | objs (list) | |
|
11 | current-location nil | |||
11 | ;; Game time |
|
12 | ;; Game time | |
12 |
started-at ( |
|
13 | started-at (chain *date (now)) | |
13 | ;; Timers |
|
14 | ;; Timers | |
14 | timer-interval 500 |
|
15 | timer-interval 500 | |
15 | timer-obj nil |
|
16 | timer-obj nil | |
16 | ;;; Transient state |
|
17 | ;;; Transient state | |
17 | ;; Savegame data |
|
18 | ;; Savegame data | |
18 |
state-stash ( |
|
19 | state-stash (create) | |
19 | ;; List of audio files being played |
|
20 | ;; List of audio files being played | |
20 |
playing ( |
|
21 | playing (create) | |
21 | ;; Local variables stack (starts with an empty frame) |
|
22 | ;; Local variables stack (starts with an empty frame) | |
22 | locals (list) |
|
23 | locals (list) | |
23 | ;;; Game data |
|
24 | ;;; Game data | |
24 | ;; ACTions |
|
25 | ;; ACTions | |
25 |
acts ( |
|
26 | acts (create) | |
26 | ;; Locations |
|
27 | ;; Locations | |
27 |
locs ( |
|
28 | locs (create))) | |
28 |
|
29 | |||
29 | ;; Launch the game from the first location |
|
30 | ;; Launch the game from the first location | |
30 |
(setf window |
|
31 | (setf (@ window onload) | |
31 | (lambda () |
|
32 | (lambda () | |
32 | (api-call init-dom) |
|
33 | (#.(intern "INIT-DOM" "SUGAR-QSP.API")) | |
33 | ;; For MSECCOUNT |
|
34 | ;; For MSECCOUNT | |
34 |
(setf (root started-at) ( |
|
35 | (setf (root started-at) (chain *date (now))) | |
35 | ;; For $COUNTER and SETTIMER |
|
36 | ;; For $COUNTER and SETTIMER | |
36 | (api-call set-timer (root timer-interval)) |
|
37 | (#.(intern "SET-TIMER" "SUGAR-QSP.API") | |
37 | (funcall (ps:getprop (root locs) |
|
38 | (root timer-interval)) | |
38 | (ps:chain *object (keys (root locs)) 0)) |
|
39 | (funcall (getprop (root locs) | |
|
40 | (chain *object (keys (root locs)) 0)) | |||
39 | (list)) |
|
41 | (list)) | |
40 | (values))) |
|
42 | (values))) | |
41 |
|
43 |
@@ -1,7 +1,93 b'' | |||||
1 |
|
1 | |||
2 | (in-package cl-user) |
|
2 | (in-package cl-user) | |
3 |
|
3 | |||
|
4 | (defpackage :sugar-qsp.js) | |||
|
5 | ||||
|
6 | (defpackage :sugar-qsp.main | |||
|
7 | (:use :cl :ps :sugar-qsp.js) | |||
|
8 | (:export #:api-call #:by-id | |||
|
9 | #:root #:in | |||
|
10 | #:vars #:objs #:current-location | |||
|
11 | #:started-at #:timer-interval #:timer-obj | |||
|
12 | #:state-stash #:playing #:locals | |||
|
13 | #:acts #:locs)) | |||
|
14 | ||||
|
15 | ;;; API functions | |||
|
16 | (defpackage :sugar-qsp.api | |||
|
17 | (:use :cl :ps :sugar-qsp.main :sugar-qsp.js) | |||
|
18 | (:export #:with-frame #:with-call-args | |||
|
19 | #:stash-state | |||
|
20 | ||||
|
21 | #:report-error #:sleep #:init-dom #:call-serv-loc | |||
|
22 | #:newline #:clear-id #:prepare-contents #:get-id #:set-id #:append-id | |||
|
23 | #:init-args #:get-result #:call-loc #:call-act | |||
|
24 | #:get-frame #:add-text #:get-text #:clear-text #:enable-frame | |||
|
25 | #:add-act #:del-act #:clear-act #:update-acts | |||
|
26 | #:qspfor | |||
|
27 | #:*var #:new-value #:index-num #:get #:set #:kill | |||
|
28 | #:var-real-name #:ensure-var #:var-ref #:get-var #:set-var | |||
|
29 | #:get-array #:set-array #:kill-var #:array-size | |||
|
30 | #:push-local-frame #:pop-local-frame #:current-local-frame #:new-local | |||
|
31 | #:update-objs | |||
|
32 | #:menu | |||
|
33 | #:clean-audio | |||
|
34 | #:show-image | |||
|
35 | #:opengame #:savegame | |||
|
36 | )) | |||
|
37 | ||||
|
38 | ;;; QSP library functions and macros | |||
|
39 | (defpackage :sugar-qsp.lib | |||
|
40 | (:use :cl :ps :sugar-qsp.main :sugar-qsp.js) | |||
|
41 | (:local-nicknames (#:api :sugar-qsp.api)) | |||
|
42 | (:export #:str #:exec #:qspblock #:qspfor #:location | |||
|
43 | #:qspcond #:qspvar #:set #:local | |||
|
44 | ||||
|
45 | #:killvar #:killall | |||
|
46 | #:obj #:loc #:no | |||
|
47 | #:qspver #:curloc | |||
|
48 | #:rnd #:qspmax #:qspmin | |||
|
49 | #:arrsize #:len | |||
|
50 | #:mid #:ucase #:lcase #:trim #:replace #:val #:qspstr | |||
|
51 | #:exit #:desc | |||
|
52 | #:showstat #:msg | |||
|
53 | #:showacts #:delact #:cla | |||
|
54 | #:showobjs #:countobj #:getobj | |||
|
55 | #:isplay | |||
|
56 | #:view | |||
|
57 | #:showinput | |||
|
58 | #:wait #:settimer | |||
|
59 | #:local | |||
|
60 | #:opengame #:savegame | |||
|
61 | ||||
|
62 | #:goto #:xgoto | |||
|
63 | #:rand | |||
|
64 | #:copyarr #:arrpos #:arrcomp | |||
|
65 | #:instr #:isnum #:strcomp #:strfind #:strpos | |||
|
66 | #:iif | |||
|
67 | #:gosub #:func | |||
|
68 | #:dynamic #:dyneval | |||
|
69 | #:main-p #:main-pl #:main-nl #:maintxt #:desc #:main-clear | |||
|
70 | #:stat-p #:stat-pl #:stat-nl #:stattxt #:stat-clear #:cls | |||
|
71 | #:curacts | |||
|
72 | #:addobj #:delobj #:killobj | |||
|
73 | #:menu | |||
|
74 | #:play #:close #:closeall | |||
|
75 | #:refint | |||
|
76 | #:usertxt #:cmdclear #:input | |||
|
77 | #:msecscount | |||
|
78 | #:rgb | |||
|
79 | #:openqst #:addqst #:killqst | |||
|
80 | )) | |||
|
81 | ||||
|
82 | ;;; The compiler | |||
4 | (defpackage :sugar-qsp |
|
83 | (defpackage :sugar-qsp | |
5 | (:use :cl) |
|
84 | (:use :cl) | |
6 |
(:local-nicknames (#:p #:esrap) |
|
85 | (:local-nicknames (#:p #:esrap) | |
|
86 | (#:lib :sugar-qsp.lib) | |||
|
87 | (#:api :sugar-qsp.api) | |||
|
88 | (#:main :sugar-qsp.main)) | |||
7 | (:export #:parse-file #:entry-point)) |
|
89 | (:export #:parse-file #:entry-point)) | |
|
90 | ||||
|
91 | (setf (ps:ps-package-prefix "SUGAR-QSP.MAIN") "qsp_") | |||
|
92 | (setf (ps:ps-package-prefix "SUGAR-QSP.API") "qsp_api_") | |||
|
93 | (setf (ps:ps-package-prefix "SUGAR-QSP.LIB") "qsp_lib_") |
@@ -1,614 +1,614 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 | ;;; Utility |
|
6 | ;;; Utility | |
7 |
|
7 | |||
8 | (defun remove-nth (list nth) |
|
8 | (defun remove-nth (list nth) | |
9 | (append (subseq list 0 nth) |
|
9 | (append (subseq list 0 nth) | |
10 | (subseq list (1+ nth)))) |
|
10 | (subseq list (1+ nth)))) | |
11 |
|
11 | |||
12 | (defun not-quote (char) |
|
12 | (defun not-quote (char) | |
13 | (not (eql #\' char))) |
|
13 | (not (eql #\' char))) | |
14 |
|
14 | |||
15 |
|
15 | |||
16 | (defun not-doublequote (char) |
|
16 | (defun not-doublequote (char) | |
17 | (not (eql #\" char))) |
|
17 | (not (eql #\" char))) | |
18 |
|
18 | |||
19 | (defun not-brace (char) |
|
19 | (defun not-brace (char) | |
20 | (not (eql #\} char))) |
|
20 | (not (eql #\} char))) | |
21 |
|
21 | |||
22 | (defun not-integer (string) |
|
22 | (defun not-integer (string) | |
23 | (when (find-if-not #'digit-char-p string) |
|
23 | (when (find-if-not #'digit-char-p string) | |
24 | t)) |
|
24 | t)) | |
25 |
|
25 | |||
26 | (defun not-newline (char) |
|
26 | (defun not-newline (char) | |
27 | (not (eql #\newline char))) |
|
27 | (not (eql #\newline char))) | |
28 |
|
28 | |||
29 | (defun id-any-char (char) |
|
29 | (defun id-any-char (char) | |
30 | (and |
|
30 | (and | |
31 | (not (digit-char-p char)) |
|
31 | (not (digit-char-p char)) | |
32 | (not (eql #\newline char)) |
|
32 | (not (eql #\newline char)) | |
33 | (not (find char " !:&=<>+-*/,'\"()[]{}")))) |
|
33 | (not (find char " !:&=<>+-*/,'\"()[]{}")))) | |
34 |
|
34 | |||
35 | (defun intern-first (list) |
|
35 | (defun intern-first (list) | |
36 | (list* (intern (string-upcase (first list))) |
|
36 | (list* (intern (string-upcase (first list)) :lib) | |
37 | (rest list))) |
|
37 | (rest list))) | |
38 |
|
38 | |||
39 | (eval-when (:compile-toplevel :load-toplevel :execute) |
|
39 | (eval-when (:compile-toplevel :load-toplevel :execute) | |
40 | (defun remove-nil (list) |
|
40 | (defun remove-nil (list) | |
41 | (remove nil list))) |
|
41 | (remove nil list))) | |
42 |
|
42 | |||
43 | (defun binop-rest (list) |
|
43 | (defun binop-rest (list) | |
44 | (destructuring-bind (ws1 operator ws2 operand2) |
|
44 | (destructuring-bind (ws1 operator ws2 operand2) | |
45 | list |
|
45 | list | |
46 | (declare (ignore ws1 ws2)) |
|
46 | (declare (ignore ws1 ws2)) | |
47 | (list (intern (string-upcase operator)) operand2))) |
|
47 | (list (intern (string-upcase operator) :lib) operand2))) | |
48 |
|
48 | |||
49 | (defun do-binop% (left-op other-ops) |
|
49 | (defun do-binop% (left-op other-ops) | |
50 | (if (null other-ops) |
|
50 | (if (null other-ops) | |
51 | left-op |
|
51 | left-op | |
52 | (destructuring-bind ((operator right-op) &rest rest-ops) |
|
52 | (destructuring-bind ((operator right-op) &rest rest-ops) | |
53 | other-ops |
|
53 | other-ops | |
54 | (if (and (listp left-op) |
|
54 | (if (and (listp left-op) | |
55 | (eq (first left-op) |
|
55 | (eq (first left-op) | |
56 | operator)) |
|
56 | operator)) | |
57 | (do-binop% (append left-op (list right-op)) rest-ops) |
|
57 | (do-binop% (append left-op (list right-op)) rest-ops) | |
58 | (do-binop% (list operator left-op right-op) rest-ops))))) |
|
58 | (do-binop% (list operator left-op right-op) rest-ops))))) | |
59 |
|
59 | |||
60 | (defun do-binop (list) |
|
60 | (defun do-binop (list) | |
61 | (destructuring-bind (left-op rest-ops) |
|
61 | (destructuring-bind (left-op rest-ops) | |
62 | list |
|
62 | list | |
63 | (do-binop% left-op |
|
63 | (do-binop% left-op | |
64 | (mapcar #'binop-rest rest-ops)))) |
|
64 | (mapcar #'binop-rest rest-ops)))) | |
65 |
|
65 | |||
66 | (p:defrule line-continuation (and #\_ #\newline) |
|
66 | (p:defrule line-continuation (and #\_ #\newline) | |
67 | (:constant nil)) |
|
67 | (:constant nil)) | |
68 |
|
68 | |||
69 | (p:defrule text-spaces (+ (or #\space #\tab line-continuation)) |
|
69 | (p:defrule text-spaces (+ (or #\space #\tab line-continuation)) | |
70 | (:text t)) |
|
70 | (:text t)) | |
71 |
|
71 | |||
72 | (p:defrule spaces (+ (or #\space #\tab line-continuation)) |
|
72 | (p:defrule spaces (+ (or #\space #\tab line-continuation)) | |
73 | (:constant nil) |
|
73 | (:constant nil) | |
74 | (:error-report nil)) |
|
74 | (:error-report nil)) | |
75 |
|
75 | |||
76 | (p:defrule spaces? (* (or #\space #\tab line-continuation)) |
|
76 | (p:defrule spaces? (* (or #\space #\tab line-continuation)) | |
77 | (:constant nil) |
|
77 | (:constant nil) | |
78 | (:error-report nil)) |
|
78 | (:error-report nil)) | |
79 |
|
79 | |||
80 | (p:defrule colon #\: |
|
80 | (p:defrule colon #\: | |
81 | (:constant nil)) |
|
81 | (:constant nil)) | |
82 |
|
82 | |||
83 | (p:defrule equal #\= |
|
83 | (p:defrule equal #\= | |
84 | (:constant nil)) |
|
84 | (:constant nil)) | |
85 |
|
85 | |||
86 | (p:defrule alphanumeric (alphanumericp character)) |
|
86 | (p:defrule alphanumeric (alphanumericp character)) | |
87 |
|
87 | |||
88 | (p:defrule not-newline (not-newline character)) |
|
88 | (p:defrule not-newline (not-newline character)) | |
89 |
|
89 | |||
90 | (p:defrule squote-esc "''" |
|
90 | (p:defrule squote-esc "''" | |
91 | (:lambda (list) |
|
91 | (:lambda (list) | |
92 | (p:text (elt list 0)))) |
|
92 | (p:text (elt list 0)))) | |
93 |
|
93 | |||
94 | (p:defrule dquote-esc "\"\"" |
|
94 | (p:defrule dquote-esc "\"\"" | |
95 | (:lambda (list) |
|
95 | (:lambda (list) | |
96 | (p:text (elt list 0)))) |
|
96 | (p:text (elt list 0)))) | |
97 |
|
97 | |||
98 | (p:defrule sstring-chars (+ (and (and (p:! "<<") (p:! (p:~ "\"exec:"))) |
|
98 | (p:defrule sstring-chars (+ (and (and (p:! "<<") (p:! (p:~ "\"exec:"))) | |
99 | (or squote-esc (not-quote character)))) |
|
99 | (or squote-esc (not-quote character)))) | |
100 | (:lambda (list) |
|
100 | (:lambda (list) | |
101 | (p:text (mapcar #'second list)))) |
|
101 | (p:text (mapcar #'second list)))) | |
102 |
|
102 | |||
103 | (p:defrule dstring-chars (+ (and (and (p:! "<<") (p:! (p:~ "'exec:"))) |
|
103 | (p:defrule dstring-chars (+ (and (and (p:! "<<") (p:! (p:~ "'exec:"))) | |
104 | (or dquote-esc (not-doublequote character)))) |
|
104 | (or dquote-esc (not-doublequote character)))) | |
105 | (:lambda (list) |
|
105 | (:lambda (list) | |
106 | (p:text (mapcar #'second list)))) |
|
106 | (p:text (mapcar #'second list)))) | |
107 |
|
107 | |||
108 | ;;; Identifiers |
|
108 | ;;; Identifiers | |
109 |
|
109 | |||
110 | (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 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)) |
|
110 | (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 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)) | |
111 |
|
111 | |||
112 | (defun trim-$ (str) |
|
112 | (defun trim-$ (str) | |
113 | (if (char= #\$ (elt str 0)) |
|
113 | (if (char= #\$ (elt str 0)) | |
114 | (subseq str 1) |
|
114 | (subseq str 1) | |
115 | str)) |
|
115 | str)) | |
116 |
|
116 | |||
117 | (defun qsp-keyword-p (id) |
|
117 | (defun qsp-keyword-p (id) | |
118 | (member (intern (trim-$ (string-upcase id))) *keywords*)) |
|
118 | (member (intern (trim-$ (string-upcase id))) *keywords*)) | |
119 |
|
119 | |||
120 | (defun not-qsp-keyword-p (id) |
|
120 | (defun not-qsp-keyword-p (id) | |
121 | (not (member (intern (trim-$ (string-upcase id))) *keywords*))) |
|
121 | (not (member (intern (trim-$ (string-upcase id))) *keywords*))) | |
122 |
|
122 | |||
123 | (p:defrule qsp-keyword (qsp-keyword-p identifier-raw)) |
|
123 | (p:defrule qsp-keyword (qsp-keyword-p identifier-raw)) | |
124 |
|
124 | |||
125 | (p:defrule id-first (id-any-char character)) |
|
125 | (p:defrule id-first (id-any-char character)) | |
126 | (p:defrule id-next (or (id-any-char character) |
|
126 | (p:defrule id-next (or (id-any-char character) | |
127 | (digit-char-p character))) |
|
127 | (digit-char-p character))) | |
128 | (p:defrule identifier-raw (and id-first (* id-next)) |
|
128 | (p:defrule identifier-raw (and id-first (* id-next)) | |
129 | (:lambda (list) |
|
129 | (:lambda (list) | |
130 | (intern (string-upcase (p:text list))))) |
|
130 | (intern (string-upcase (p:text list)) :lib))) | |
131 |
|
131 | |||
132 | (p:defrule identifier (not-qsp-keyword-p identifier-raw)) |
|
132 | (p:defrule identifier (not-qsp-keyword-p identifier-raw)) | |
133 |
|
133 | |||
134 | ;;; Strings |
|
134 | ;;; Strings | |
135 |
|
135 | |||
136 | (p:defrule qsp-string (or normal-string brace-string)) |
|
136 | (p:defrule qsp-string (or normal-string brace-string)) | |
137 |
|
137 | |||
138 | (p:defrule normal-string (or sstring dstring) |
|
138 | (p:defrule normal-string (or sstring dstring) | |
139 | (:lambda (str) |
|
139 | (:lambda (str) | |
140 | (list* 'str (or str (list ""))))) |
|
140 | (list* 'lib:str (or str (list ""))))) | |
141 |
|
141 | |||
142 | (p:defrule sstring (and #\' (* (or string-interpol |
|
142 | (p:defrule sstring (and #\' (* (or string-interpol | |
143 | sstring-exec |
|
143 | sstring-exec | |
144 | sstring-chars)) |
|
144 | sstring-chars)) | |
145 | #\') |
|
145 | #\') | |
146 | (:function second)) |
|
146 | (:function second)) | |
147 |
|
147 | |||
148 | (p:defrule dstring (and #\" (* (or string-interpol |
|
148 | (p:defrule dstring (and #\" (* (or string-interpol | |
149 | dstring-exec |
|
149 | dstring-exec | |
150 | dstring-chars)) |
|
150 | dstring-chars)) | |
151 | #\") |
|
151 | #\") | |
152 | (:function second)) |
|
152 | (:function second)) | |
153 |
|
153 | |||
154 | (p:defrule string-interpol (and "<<" expression ">>") |
|
154 | (p:defrule string-interpol (and "<<" expression ">>") | |
155 | (:function second)) |
|
155 | (:function second)) | |
156 |
|
156 | |||
157 | (p:defrule sstring-exec-body (+ (or squote-esc (not-doublequote character))) |
|
157 | (p:defrule sstring-exec-body (+ (or squote-esc (not-doublequote character))) | |
158 | (:text t)) |
|
158 | (:text t)) | |
159 |
|
159 | |||
160 | (p:defrule dstring-exec-body (+ (or dquote-esc (not-quote character))) |
|
160 | (p:defrule dstring-exec-body (+ (or dquote-esc (not-quote character))) | |
161 | (:text t)) |
|
161 | (:text t)) | |
162 |
|
162 | |||
163 | (p:defrule sstring-exec (and (p:~ "\"exec:") sstring-exec-body #\") |
|
163 | (p:defrule sstring-exec (and (p:~ "\"exec:") sstring-exec-body #\") | |
164 | (:lambda (list) |
|
164 | (:lambda (list) | |
165 | (list* 'exec (p:parse 'exec-body (second list))))) |
|
165 | (list* 'lib:exec (p:parse 'exec-body (second list))))) | |
166 |
|
166 | |||
167 | (p:defrule dstring-exec (and (p:~ "'exec:") dstring-exec-body #\') |
|
167 | (p:defrule dstring-exec (and (p:~ "'exec:") dstring-exec-body #\') | |
168 | (:lambda (list) |
|
168 | (:lambda (list) | |
169 | (list* 'exec (p:parse 'exec-body (second list))))) |
|
169 | (list* 'lib:exec (p:parse 'exec-body (second list))))) | |
170 |
|
170 | |||
171 | (p:defrule brace-string (and #\{ before-statement block-body #\}) |
|
171 | (p:defrule brace-string (and #\{ before-statement block-body #\}) | |
172 | (:lambda (list) |
|
172 | (:lambda (list) | |
173 | (list* 'qspblock (third list)))) |
|
173 | (list* 'lib:qspblock (third list)))) | |
174 |
|
174 | |||
175 | ;;; Location |
|
175 | ;;; Location | |
176 |
|
176 | |||
177 | (p:defrule sugar-qsp-grammar (and (* (or spaces #\newline)) |
|
177 | (p:defrule sugar-qsp-grammar (and (* (or spaces #\newline)) | |
178 | (* location)) |
|
178 | (* location)) | |
179 | (:function second)) |
|
179 | (:function second)) | |
180 |
|
180 | |||
181 | (p:defrule location (and location-header block-body location-end) |
|
181 | (p:defrule location (and location-header block-body location-end) | |
182 | (:destructure (header body end) |
|
182 | (:destructure (header body end) | |
183 | (declare (ignore end)) |
|
183 | (declare (ignore end)) | |
184 | `(location (,header) ,@body))) |
|
184 | `(lib:location (,header) ,@body))) | |
185 |
|
185 | |||
186 | (p:defrule location-header (and #\# |
|
186 | (p:defrule location-header (and #\# | |
187 | (+ not-newline) |
|
187 | (+ not-newline) | |
188 | (and #\newline spaces? before-statement)) |
|
188 | (and #\newline spaces? before-statement)) | |
189 | (:destructure (spaces1 name spaces2) |
|
189 | (:destructure (spaces1 name spaces2) | |
190 | (declare (ignore spaces1 spaces2)) |
|
190 | (declare (ignore spaces1 spaces2)) | |
191 | (string-upcase (string-trim " " (p:text name))))) |
|
191 | (string-upcase (string-trim " " (p:text name))))) | |
192 |
|
192 | |||
193 | (p:defrule location-end (and #\- (* not-newline) #\newline before-statement) |
|
193 | (p:defrule location-end (and #\- (* not-newline) #\newline before-statement) | |
194 | (:constant nil)) |
|
194 | (:constant nil)) | |
195 |
|
195 | |||
196 | ;;; Block body |
|
196 | ;;; Block body | |
197 |
|
197 | |||
198 | (p:defrule newline-block-body (and #\newline spaces? block-body) |
|
198 | (p:defrule newline-block-body (and #\newline spaces? block-body) | |
199 | (:function third)) |
|
199 | (:function third)) | |
200 |
|
200 | |||
201 | (p:defrule block-body (* statement) |
|
201 | (p:defrule block-body (* statement) | |
202 | (:function remove-nil)) |
|
202 | (:function remove-nil)) | |
203 |
|
203 | |||
204 | ;; Just for <a href="exec:...'> |
|
204 | ;; Just for <a href="exec:...'> | |
205 | ;; Explicitly called from that rule's production |
|
205 | ;; Explicitly called from that rule's production | |
206 | (p:defrule exec-body (and before-statement line-body) |
|
206 | (p:defrule exec-body (and before-statement line-body) | |
207 | (:function second)) |
|
207 | (:function second)) | |
208 |
|
208 | |||
209 | (p:defrule line-body (and inline-statement (* next-inline-statement)) |
|
209 | (p:defrule line-body (and inline-statement (* next-inline-statement)) | |
210 | (:lambda (list) |
|
210 | (:lambda (list) | |
211 | (list* (first list) (second list)))) |
|
211 | (list* (first list) (second list)))) | |
212 |
|
212 | |||
213 | (p:defrule before-statement (* (or #\newline spaces)) |
|
213 | (p:defrule before-statement (* (or #\newline spaces)) | |
214 | (:constant nil)) |
|
214 | (:constant nil)) | |
215 |
|
215 | |||
216 | (p:defrule statement-end (or statement-end-real statement-end-block-close)) |
|
216 | (p:defrule statement-end (or statement-end-real statement-end-block-close)) | |
217 |
|
217 | |||
218 | (p:defrule statement-end-real (and (or #\newline |
|
218 | (p:defrule statement-end-real (and (or #\newline | |
219 | (and #\& spaces? (p:& statement%))) |
|
219 | (and #\& spaces? (p:& statement%))) | |
220 | before-statement) |
|
220 | before-statement) | |
221 | (:constant nil)) |
|
221 | (:constant nil)) | |
222 |
|
222 | |||
223 | (p:defrule statement-end-block-close (or (p:& #\})) |
|
223 | (p:defrule statement-end-block-close (or (p:& #\})) | |
224 | (:constant nil)) |
|
224 | (:constant nil)) | |
225 |
|
225 | |||
226 | (p:defrule inline-statement (and statement% spaces?) |
|
226 | (p:defrule inline-statement (and statement% spaces?) | |
227 | (:function first)) |
|
227 | (:function first)) | |
228 |
|
228 | |||
229 | (p:defrule next-inline-statement (and #\& spaces? inline-statement) |
|
229 | (p:defrule next-inline-statement (and #\& spaces? inline-statement) | |
230 | (:function third)) |
|
230 | (:function third)) | |
231 |
|
231 | |||
232 | (p:defrule not-a-non-statement (and (p:! (p:~ "elseif")) |
|
232 | (p:defrule not-a-non-statement (and (p:! (p:~ "elseif")) | |
233 | (p:! (p:~ "else")) |
|
233 | (p:! (p:~ "else")) | |
234 | (p:! (p:~ "end")))) |
|
234 | (p:! (p:~ "end")))) | |
235 |
|
235 | |||
236 | (p:defrule statement (and inline-statement statement-end) |
|
236 | (p:defrule statement (and inline-statement statement-end) | |
237 | (:function first)) |
|
237 | (:function first)) | |
238 |
|
238 | |||
239 | (p:defrule statement% (and not-a-non-statement |
|
239 | (p:defrule statement% (and not-a-non-statement | |
240 | (or label comment string-output |
|
240 | (or label comment string-output | |
241 | block non-returning-intrinsic local |
|
241 | block non-returning-intrinsic local | |
242 | assignment expression-output)) |
|
242 | assignment expression-output)) | |
243 | (:function second)) |
|
243 | (:function second)) | |
244 |
|
244 | |||
245 | (p:defrule expr-stopper (or comment block non-returning-intrinsic)) |
|
245 | (p:defrule expr-stopper (or comment block non-returning-intrinsic)) | |
246 |
|
246 | |||
247 | (p:defrule string-output qsp-string |
|
247 | (p:defrule string-output qsp-string | |
248 | (:lambda (string) |
|
248 | (:lambda (string) | |
249 | (list 'main-pl string))) |
|
249 | (list 'lib:main-pl string))) | |
250 |
|
250 | |||
251 | (p:defrule expression-output expression |
|
251 | (p:defrule expression-output expression | |
252 | (:lambda (list) |
|
252 | (:lambda (list) | |
253 | (list 'main-pl list))) |
|
253 | (list 'lib:main-pl list))) | |
254 |
|
254 | |||
255 | (p:defrule label (and colon identifier) |
|
255 | (p:defrule label (and colon identifier) | |
256 | (:lambda (list) |
|
256 | (:lambda (list) | |
257 | (intern (string (second list)) :keyword))) |
|
257 | (intern (string (second list)) :keyword))) | |
258 |
|
258 | |||
259 | (p:defrule comment (and #\! (* (or qsp-string brace-comment text-spaces not-newline))) |
|
259 | (p:defrule comment (and #\! (* (or qsp-string brace-comment text-spaces not-newline))) | |
260 | (:constant nil)) |
|
260 | (:constant nil)) | |
261 |
|
261 | |||
262 | (p:defrule brace-comment (and #\{ (* (not-brace character)) #\}) |
|
262 | (p:defrule brace-comment (and #\{ (* (not-brace character)) #\}) | |
263 | (:constant nil)) |
|
263 | (:constant nil)) | |
264 |
|
264 | |||
265 | (p:defrule local (and (p:~ "local") spaces variable (p:? (and spaces? #\= spaces? expression))) |
|
265 | (p:defrule local (and (p:~ "local") spaces variable (p:? (and spaces? #\= spaces? expression))) | |
266 | (:lambda (list) |
|
266 | (:lambda (list) | |
267 | (list* 'local (third list) |
|
267 | (list* 'lib:local (third list) | |
268 | (when (fourth list) |
|
268 | (when (fourth list) | |
269 | (list (fourth (fourth list))))))) |
|
269 | (list (fourth (fourth list))))))) | |
270 |
|
270 | |||
271 | ;;; Blocks |
|
271 | ;;; Blocks | |
272 |
|
272 | |||
273 | (p:defrule block (or block-act block-if block-for)) |
|
273 | (p:defrule block (or block-act block-if block-for)) | |
274 |
|
274 | |||
275 | (p:defrule block-if (and block-if-head block-if-body) |
|
275 | (p:defrule block-if (and block-if-head block-if-body) | |
276 | (:destructure (head body) |
|
276 | (:destructure (head body) | |
277 | `(qspcond (,@head ,@(first body)) |
|
277 | `(lib:qspcond (,@head ,@(first body)) | |
278 | ,@(rest body)))) |
|
278 | ,@(rest body)))) | |
279 |
|
279 | |||
280 | (p:defrule block-if-head (and (p:~ "if") spaces expression spaces? colon spaces?) |
|
280 | (p:defrule block-if-head (and (p:~ "if") spaces expression spaces? colon spaces?) | |
281 | (:function remove-nil) |
|
281 | (:function remove-nil) | |
282 | (:function cdr)) |
|
282 | (:function cdr)) | |
283 |
|
283 | |||
284 | (p:defrule block-if-body (or block-if-ml block-if-sl) |
|
284 | (p:defrule block-if-body (or block-if-ml block-if-sl) | |
285 | (:destructure (if-body elseifs else &rest ws) |
|
285 | (:destructure (if-body elseifs else &rest ws) | |
286 | (declare (ignore ws)) |
|
286 | (declare (ignore ws)) | |
287 | `(,(remove-nil if-body) ,@elseifs ,@(when else `((else ,@else)))))) |
|
287 | `(,(remove-nil if-body) ,@elseifs ,@(when else `((else ,@else)))))) | |
288 |
|
288 | |||
289 | (p:defrule block-if-sl (and line-body |
|
289 | (p:defrule block-if-sl (and line-body | |
290 | (p:? block-if-elseif-inline) |
|
290 | (p:? block-if-elseif-inline) | |
291 | (p:? block-if-else-inline) |
|
291 | (p:? block-if-else-inline) | |
292 | spaces?)) |
|
292 | spaces?)) | |
293 |
|
293 | |||
294 | (p:defrule block-if-ml (and (and #\newline spaces?) |
|
294 | (p:defrule block-if-ml (and (and #\newline spaces?) | |
295 | block-body |
|
295 | block-body | |
296 | (p:? block-if-elseif) |
|
296 | (p:? block-if-elseif) | |
297 | (p:? block-if-else) |
|
297 | (p:? block-if-else) | |
298 | block-if-end) |
|
298 | block-if-end) | |
299 | (:lambda (list) |
|
299 | (:lambda (list) | |
300 | (cdr list))) |
|
300 | (cdr list))) | |
301 |
|
301 | |||
302 | (p:defrule block-if-elseif-inline (and block-if-elseif-head line-body (p:? block-if-elseif-inline)) |
|
302 | (p:defrule block-if-elseif-inline (and block-if-elseif-head line-body (p:? block-if-elseif-inline)) | |
303 | (:destructure (head statements elseif) |
|
303 | (:destructure (head statements elseif) | |
304 | `((,@(rest head) ,@(remove-nil statements)) ,@elseif))) |
|
304 | `((,@(rest head) ,@(remove-nil statements)) ,@elseif))) | |
305 |
|
305 | |||
306 | (p:defrule block-if-elseif (and block-if-elseif-head statement-end block-body (p:? block-if-elseif)) |
|
306 | (p:defrule block-if-elseif (and block-if-elseif-head statement-end block-body (p:? block-if-elseif)) | |
307 | (:destructure (head ws statements elseif) |
|
307 | (:destructure (head ws statements elseif) | |
308 | (declare (ignore ws)) |
|
308 | (declare (ignore ws)) | |
309 | `((,@(rest head) ,@(remove-nil statements)) ,@elseif))) |
|
309 | `((,@(rest head) ,@(remove-nil statements)) ,@elseif))) | |
310 |
|
310 | |||
311 | (p:defrule block-if-elseif-head (and (p:~ "elseif") spaces expression spaces? colon spaces?) |
|
311 | (p:defrule block-if-elseif-head (and (p:~ "elseif") spaces expression spaces? colon spaces?) | |
312 | (:function remove-nil) |
|
312 | (:function remove-nil) | |
313 | (:function intern-first)) |
|
313 | (:function intern-first)) | |
314 |
|
314 | |||
315 | (p:defrule block-if-else-inline (and block-if-else-head line-body) |
|
315 | (p:defrule block-if-else-inline (and block-if-else-head line-body) | |
316 | (:function second)) |
|
316 | (:function second)) | |
317 |
|
317 | |||
318 | (p:defrule block-if-else (and block-if-else-head #\newline spaces? block-body) |
|
318 | (p:defrule block-if-else (and block-if-else-head #\newline spaces? block-body) | |
319 | (:function fourth)) |
|
319 | (:function fourth)) | |
320 |
|
320 | |||
321 | (p:defrule block-if-else-head (and (p:~ "else") spaces?) |
|
321 | (p:defrule block-if-else-head (and (p:~ "else") spaces?) | |
322 | (:constant nil)) |
|
322 | (:constant nil)) | |
323 |
|
323 | |||
324 | (p:defrule block-if-end (and (p:~ "end") |
|
324 | (p:defrule block-if-end (and (p:~ "end") | |
325 | (p:? (and spaces (p:~ "if")))) |
|
325 | (p:? (and spaces (p:~ "if")))) | |
326 | (:constant nil)) |
|
326 | (:constant nil)) | |
327 |
|
327 | |||
328 | (p:defrule block-act (and block-act-head (or block-ml block-sl)) |
|
328 | (p:defrule block-act (and block-act-head (or block-ml block-sl)) | |
329 | (:lambda (list) |
|
329 | (:lambda (list) | |
330 | (apply #'append list))) |
|
330 | (apply #'append list))) | |
331 |
|
331 | |||
332 | (p:defrule block-act-head (and (p:~ "act") spaces? qsp-string spaces? |
|
332 | (p:defrule block-act-head (and (p:~ "act") spaces? qsp-string spaces? | |
333 | (p:? block-act-head-img) |
|
333 | (p:? block-act-head-img) | |
334 | colon spaces?) |
|
334 | colon spaces?) | |
335 | (:lambda (list) |
|
335 | (:lambda (list) | |
336 | (intern-first (list (first list) |
|
336 | (intern-first (list (first list) | |
337 | (third list) |
|
337 | (third list) | |
338 | (or (fifth list) '(str "")))))) |
|
338 | (or (fifth list) '(lib:str "")))))) | |
339 |
|
339 | |||
340 | (p:defrule block-act-head-img (and #\, spaces? qsp-string spaces?) |
|
340 | (p:defrule block-act-head-img (and #\, spaces? qsp-string spaces?) | |
341 | (:lambda (list) |
|
341 | (:lambda (list) | |
342 | (or (third list) ""))) |
|
342 | (or (third list) ""))) | |
343 |
|
343 | |||
344 | (p:defrule block-for (and block-for-head (or block-ml block-sl)) |
|
344 | (p:defrule block-for (and block-for-head (or block-ml block-sl)) | |
345 | (:lambda (list) |
|
345 | (:lambda (list) | |
346 | (apply #'append list))) |
|
346 | (apply #'append list))) | |
347 |
|
347 | |||
348 | (p:defrule block-for-head (and (p:~ "for") spaces variable spaces? equal spaces? expression |
|
348 | (p:defrule block-for-head (and (p:~ "for") spaces variable spaces? equal spaces? expression | |
349 | (p:~ "to") spaces expression |
|
349 | (p:~ "to") spaces expression | |
350 | block-for-head-step |
|
350 | block-for-head-step | |
351 | colon spaces?) |
|
351 | colon spaces?) | |
352 | (:lambda (list) |
|
352 | (:lambda (list) | |
353 | (unless (eq (fourth (third list)) :num) |
|
353 | (unless (eq (fourth (third list)) :num) | |
354 | (error "For counter variable must be numeric.")) |
|
354 | (error "For counter variable must be numeric.")) | |
355 | (list 'qspfor |
|
355 | (list 'lib:qspfor | |
356 | (elt list 2) |
|
356 | (elt list 2) | |
357 | (elt list 6) |
|
357 | (elt list 6) | |
358 | (elt list 9) |
|
358 | (elt list 9) | |
359 | (elt list 10)))) |
|
359 | (elt list 10)))) | |
360 |
|
360 | |||
361 | (p:defrule block-for-head-step (p:? (and (p:~ "step") spaces expression spaces?)) |
|
361 | (p:defrule block-for-head-step (p:? (and (p:~ "step") spaces expression spaces?)) | |
362 | (:lambda (list) |
|
362 | (:lambda (list) | |
363 | (if list |
|
363 | (if list | |
364 | (third list) |
|
364 | (third list) | |
365 | 1))) |
|
365 | 1))) | |
366 |
|
366 | |||
367 | (p:defrule block-sl line-body) |
|
367 | (p:defrule block-sl line-body) | |
368 |
|
368 | |||
369 | (p:defrule block-ml (and newline-block-body block-end) |
|
369 | (p:defrule block-ml (and newline-block-body block-end) | |
370 | (:lambda (list) |
|
370 | (:lambda (list) | |
371 | (apply #'list* (butlast list)))) |
|
371 | (apply #'list* (butlast list)))) | |
372 |
|
372 | |||
373 | (p:defrule block-end (and (p:~ "end")) |
|
373 | (p:defrule block-end (and (p:~ "end")) | |
374 | (:constant nil)) |
|
374 | (:constant nil)) | |
375 |
|
375 | |||
376 | ;;; Calls |
|
376 | ;;; Calls | |
377 |
|
377 | |||
378 | (p:defrule first-argument (and expression spaces?) |
|
378 | (p:defrule first-argument (and expression spaces?) | |
379 | (:function first)) |
|
379 | (:function first)) | |
380 | (p:defrule next-argument (and "," spaces? expression) |
|
380 | (p:defrule next-argument (and "," spaces? expression) | |
381 | (:function third)) |
|
381 | (:function third)) | |
382 | (p:defrule arguments (or parenthesized-arguments plain-arguments no-arguments)) |
|
382 | (p:defrule arguments (or parenthesized-arguments plain-arguments no-arguments)) | |
383 | (p:defrule parenthesized-arguments (and spaces? #\( base-arguments #\)) |
|
383 | (p:defrule parenthesized-arguments (and spaces? #\( base-arguments #\)) | |
384 | (:function third)) |
|
384 | (:function third)) | |
385 | (p:defrule plain-arguments (and spaces? base-arguments) |
|
385 | (p:defrule plain-arguments (and spaces? base-arguments) | |
386 | (:function second)) |
|
386 | (:function second)) | |
387 | (p:defrule no-arguments (or (and spaces? (p:& #\newline)) |
|
387 | (p:defrule no-arguments (or (and spaces? (p:& #\newline)) | |
388 | (and spaces? (p:& #\&)) |
|
388 | (and spaces? (p:& #\&)) | |
389 | spaces?) |
|
389 | spaces?) | |
390 | (:constant nil)) |
|
390 | (:constant nil)) | |
391 | (p:defrule base-arguments (or (and first-argument (* next-argument)) spaces?) |
|
391 | (p:defrule base-arguments (or (and first-argument (* next-argument)) spaces?) | |
392 | (:lambda (list) |
|
392 | (:lambda (list) | |
393 | (if (null list) |
|
393 | (if (null list) | |
394 | nil |
|
394 | nil | |
395 | (list* (first list) (second list))))) |
|
395 | (list* (first list) (second list))))) | |
396 |
|
396 | |||
397 | ;;; Intrinsics |
|
397 | ;;; Intrinsics | |
398 |
|
398 | |||
399 | (defmacro defintrinsics ((rule-name returning-rule-name non-returning-rule-name) &body clauses) |
|
399 | (defmacro defintrinsics ((rule-name returning-rule-name non-returning-rule-name) &body clauses) | |
400 | `(progn |
|
400 | `(progn | |
401 | ,@(loop :for clause :in clauses |
|
401 | ,@(loop :for clause :in clauses | |
402 | :collect `(defintrinsic ,@clause)) |
|
402 | :collect `(defintrinsic ,@clause)) | |
403 | (p:defrule ,returning-rule-name (or ,@(remove-nil |
|
403 | (p:defrule ,returning-rule-name (or ,@(remove-nil | |
404 | (mapcar (lambda (clause) |
|
404 | (mapcar (lambda (clause) | |
405 | (when (second clause) |
|
405 | (when (second clause) | |
406 | (alexandria:symbolicate |
|
406 | (alexandria:symbolicate | |
407 | 'intrinsic- (first clause)))) |
|
407 | 'intrinsic- (first clause)))) | |
408 | clauses)))) |
|
408 | clauses)))) | |
409 | (p:defrule ,non-returning-rule-name (or ,@(remove-nil |
|
409 | (p:defrule ,non-returning-rule-name (or ,@(remove-nil | |
410 | (mapcar (lambda (clause) |
|
410 | (mapcar (lambda (clause) | |
411 | (unless (second clause) |
|
411 | (unless (second clause) | |
412 | (alexandria:symbolicate |
|
412 | (alexandria:symbolicate | |
413 | 'intrinsic- (first clause)))) |
|
413 | 'intrinsic- (first clause)))) | |
414 | clauses)))) |
|
414 | clauses)))) | |
415 | (p:defrule ,rule-name (or ,returning-rule-name ,non-returning-rule-name)))) |
|
415 | (p:defrule ,rule-name (or ,returning-rule-name ,non-returning-rule-name)))) | |
416 |
|
416 | |||
417 | (defmacro defintrinsic (sym returning &optional (min-arity 0) (max-arity 10) &rest names) |
|
417 | (defmacro defintrinsic (sym returning &optional (min-arity 0) (max-arity 10) &rest names) | |
418 | (declare (ignore returning)) |
|
418 | (declare (ignore returning)) | |
419 | (setf names |
|
419 | (setf names | |
420 | (if names |
|
420 | (if names | |
421 | (mapcar #'string-upcase names) |
|
421 | (mapcar #'string-upcase names) | |
422 | (list (string sym)))) |
|
422 | (list (string sym)))) | |
423 | `(p:defrule ,(alexandria:symbolicate 'intrinsic- sym) |
|
423 | `(p:defrule ,(alexandria:symbolicate 'intrinsic- sym) | |
424 | (and (p:? #\$) (or ,@(loop :for name :in names :collect `(p:~ ,name))) |
|
424 | (and (p:? #\$) (or ,@(loop :for name :in names :collect `(p:~ ,name))) | |
425 | arguments) |
|
425 | arguments) | |
426 | (:destructure (dollar name arguments) |
|
426 | (:destructure (dollar name arguments) | |
427 | (declare (ignore dollar)) |
|
427 | (declare (ignore dollar)) | |
428 | (unless (<= ,min-arity (length arguments) ,max-arity) |
|
428 | (unless (<= ,min-arity (length arguments) ,max-arity) | |
429 | (error "Intrinsic ~A expects between ~A and ~A arguments but ~A were provided:~%~S" |
|
429 | (error "Intrinsic ~A expects between ~A and ~A arguments but ~A were provided:~%~S" | |
430 | name ,min-arity ,max-arity (length arguments) arguments)) |
|
430 | name ,min-arity ,max-arity (length arguments) arguments)) | |
431 | (list* ',sym arguments)))) |
|
431 | (list* ',(intern (string sym) :lib) arguments)))) | |
432 |
|
432 | |||
433 | (defintrinsics (intrinsic returning-intrinsic non-returning-intrinsic) |
|
433 | (defintrinsics (intrinsic returning-intrinsic non-returning-intrinsic) | |
434 | ;; Transitions |
|
434 | ;; Transitions | |
435 |
(goto |
|
435 | (goto% nil 0 10 "gt" "goto") | |
436 |
(xgoto |
|
436 | (xgoto% nil 0 10 "xgt" "xgoto") | |
437 | ;; Variables |
|
437 | ;; Variables | |
438 | (killvar nil 0 2) |
|
438 | (killvar nil 0 2) | |
439 | ;; Expressions |
|
439 | ;; Expressions | |
440 | (obj t 1 1) |
|
440 | (obj t 1 1) | |
441 | (loc t 1 1) |
|
441 | (loc t 1 1) | |
442 | (no t 1 1) |
|
442 | (no t 1 1) | |
443 | ;; Basic |
|
443 | ;; Basic | |
444 | (qspver t 0 0) |
|
444 | (qspver t 0 0) | |
445 | (curloc t 0 0) |
|
445 | (curloc t 0 0) | |
446 | (rand t 1 2) |
|
446 | (rand t 1 2) | |
447 | (rnd t 0 0) |
|
447 | (rnd t 0 0) | |
448 | (qspmax t 1 10 "max") |
|
448 | (qspmax t 1 10 "max") | |
449 | (qspmin t 1 10 "min") |
|
449 | (qspmin t 1 10 "min") | |
450 | ;; Arrays |
|
450 | ;; Arrays | |
451 | (killall nil 0 0) |
|
451 | (killall nil 0 0) | |
452 | (copyarr nil 2 4) |
|
452 | (copyarr nil 2 4) | |
453 | (arrsize t 1 1) |
|
453 | (arrsize t 1 1) | |
454 | (arrpos t 2 3) |
|
454 | (arrpos t 2 3) | |
455 | (arrcomp t 2 3) |
|
455 | (arrcomp t 2 3) | |
456 | ;; Strings |
|
456 | ;; Strings | |
457 | (len t 1 1) |
|
457 | (len t 1 1) | |
458 | (mid t 2 3) |
|
458 | (mid t 2 3) | |
459 | (ucase t 1 1) |
|
459 | (ucase t 1 1) | |
460 | (lcase t 1 1) |
|
460 | (lcase t 1 1) | |
461 | (trim t 1 1) |
|
461 | (trim t 1 1) | |
462 | (replace t 2 3) |
|
462 | (replace t 2 3) | |
463 | (instr t 2 3) |
|
463 | (instr t 2 3) | |
464 | (isnum t 1 1) |
|
464 | (isnum t 1 1) | |
465 | (val t 1 1) |
|
465 | (val t 1 1) | |
466 | (qspstr t 1 1 "str") |
|
466 | (qspstr t 1 1 "str") | |
467 | (strcomp t 2 2) |
|
467 | (strcomp t 2 2) | |
468 | (strfind t 2 3) |
|
468 | (strfind t 2 3) | |
469 | (strpos t 2 3) |
|
469 | (strpos t 2 3) | |
470 | ;; IF |
|
470 | ;; IF | |
471 | (iif t 2 3) |
|
471 | (iif t 2 3) | |
472 | ;; Subs |
|
472 | ;; Subs | |
473 | (gosub nil 1 10 "gosub" "gs") |
|
473 | (gosub nil 1 10 "gosub" "gs") | |
474 | (func t 1 10) |
|
474 | (func t 1 10) | |
475 | (exit nil 0 0) |
|
475 | (exit nil 0 0) | |
476 | ;; Jump |
|
476 | ;; Jump | |
477 | (jump nil 1 1) |
|
477 | (jump nil 1 1) | |
478 | ;; Dynamic |
|
478 | ;; Dynamic | |
479 | (dynamic nil 1 10) |
|
479 | (dynamic nil 1 10) | |
480 | (dyneval t 1 10) |
|
480 | (dyneval t 1 10) | |
481 | ;; Sound |
|
481 | ;; Sound | |
482 | (play nil 1 2) |
|
482 | (play nil 1 2) | |
483 | (isplay t 1 1) |
|
483 | (isplay t 1 1) | |
484 | (close nil 1 1) |
|
484 | (close nil 1 1) | |
485 | (closeall nil 0 0 "close all") |
|
485 | (closeall nil 0 0 "close all") | |
486 | ;; Main window |
|
486 | ;; Main window | |
487 | (main-pl nil 1 1 "*pl") |
|
487 | (main-pl nil 1 1 "*pl") | |
488 | (main-nl nil 0 1 "*nl") |
|
488 | (main-nl nil 0 1 "*nl") | |
489 | (main-p nil 1 1 "*p") |
|
489 | (main-p nil 1 1 "*p") | |
490 | (maintxt t 0 0) |
|
490 | (maintxt t 0 0) | |
491 | (desc t 1 1) |
|
491 | (desc t 1 1) | |
492 | (main-clear nil 0 0 "*clear" "*clr") |
|
492 | (main-clear nil 0 0 "*clear" "*clr") | |
493 | ;; Aux window |
|
493 | ;; Aux window | |
494 | (showstat nil 1 1) |
|
494 | (showstat nil 1 1) | |
495 | (stat-pl nil 1 1 "pl") |
|
495 | (stat-pl nil 1 1 "pl") | |
496 | (stat-nl nil 0 1 "nl") |
|
496 | (stat-nl nil 0 1 "nl") | |
497 | (stat-p nil 1 1 "p") |
|
497 | (stat-p nil 1 1 "p") | |
498 | (stattxt t 0 0) |
|
498 | (stattxt t 0 0) | |
499 | (stat-clear nil 0 0 "clear" "clr") |
|
499 | (stat-clear nil 0 0 "clear" "clr") | |
500 | (cls nil 0 0) |
|
500 | (cls nil 0 0) | |
501 | ;; Dialog |
|
501 | ;; Dialog | |
502 | (msg nil 1 1) |
|
502 | (msg nil 1 1) | |
503 | ;; Acts |
|
503 | ;; Acts | |
504 | (showacts nil 1 1) |
|
504 | (showacts nil 1 1) | |
505 | (delact nil 1 1 "delact" "del act") |
|
505 | (delact nil 1 1 "delact" "del act") | |
506 | (curacts t 0 0) |
|
506 | (curacts t 0 0) | |
507 | (cla nil 0 0) |
|
507 | (cla nil 0 0) | |
508 | ;; Objects |
|
508 | ;; Objects | |
509 | (showobjs nil 1 1) |
|
509 | (showobjs nil 1 1) | |
510 | (addobj nil 1 3 "addobj" "add obj") |
|
510 | (addobj nil 1 3 "addobj" "add obj") | |
511 | (delobj nil 1 1 "delobj" "del obj") |
|
511 | (delobj nil 1 1 "delobj" "del obj") | |
512 | (killobj nil 0 1) |
|
512 | (killobj nil 0 1) | |
513 | (countobj t 0 0) |
|
513 | (countobj t 0 0) | |
514 | (getobj t 1 1) |
|
514 | (getobj t 1 1) | |
515 | ;; Menu |
|
515 | ;; Menu | |
516 | (menu nil 1 1) |
|
516 | (menu nil 1 1) | |
517 | ;; Images |
|
517 | ;; Images | |
518 | (refint nil 0 0) |
|
518 | (refint nil 0 0) | |
519 | (view nil 0 1) |
|
519 | (view nil 0 1) | |
520 | ;; Fonts |
|
520 | ;; Fonts | |
521 | (rgb t 3 3) |
|
521 | (rgb t 3 3) | |
522 | ;; Input |
|
522 | ;; Input | |
523 | (showinput nil 1 1) |
|
523 | (showinput nil 1 1) | |
524 | (usertxt t 0 0 "user_text" "usrtxt") |
|
524 | (usertxt t 0 0 "user_text" "usrtxt") | |
525 | (cmdclear nil 0 0 "cmdclear" "cmdclr") |
|
525 | (cmdclear nil 0 0 "cmdclear" "cmdclr") | |
526 | (input t 1 1) |
|
526 | (input t 1 1) | |
527 | ;; Files |
|
527 | ;; Files | |
528 | (openqst nil 1 1) |
|
528 | (openqst nil 1 1) | |
529 | (addqst nil 1 1 "addqst" "addlib" "inclib") |
|
529 | (addqst nil 1 1 "addqst" "addlib" "inclib") | |
530 | (killqst nil 1 1 "killqst" "dellib" "freelib") |
|
530 | (killqst nil 1 1 "killqst" "dellib" "freelib") | |
531 | (opengame nil 0 0) |
|
531 | (opengame nil 0 0) | |
532 | (savegame nil 0 0) |
|
532 | (savegame nil 0 0) | |
533 | ;; Real time |
|
533 | ;; Real time | |
534 | (wait nil 1 1) |
|
534 | (wait nil 1 1) | |
535 | (msecscount t 0 0) |
|
535 | (msecscount t 0 0) | |
536 | (settimer nil 1 1)) |
|
536 | (settimer nil 1 1)) | |
537 |
|
537 | |||
538 | ;;; Expression |
|
538 | ;;; Expression | |
539 |
|
539 | |||
540 | (p:defrule expression or-expr) |
|
540 | (p:defrule expression or-expr) | |
541 |
|
541 | |||
542 | (p:defrule or-expr (and and-expr (* (and spaces? or-op spaces? and-expr))) |
|
542 | (p:defrule or-expr (and and-expr (* (and spaces? or-op spaces? and-expr))) | |
543 | (:function do-binop)) |
|
543 | (:function do-binop)) | |
544 |
|
544 | |||
545 | (p:defrule and-expr (and eq-expr (* (and spaces? and-op spaces? eq-expr))) |
|
545 | (p:defrule and-expr (and eq-expr (* (and spaces? and-op spaces? eq-expr))) | |
546 | (:function do-binop)) |
|
546 | (:function do-binop)) | |
547 |
|
547 | |||
548 | (p:defrule eq-expr (and sum-expr (* (and spaces? (or "<=" ">=" "=<" "=>" "<>" |
|
548 | (p:defrule eq-expr (and sum-expr (* (and spaces? (or "<=" ">=" "=<" "=>" "<>" | |
549 | "=" "<" ">" "!") |
|
549 | "=" "<" ">" "!") | |
550 | spaces? sum-expr))) |
|
550 | spaces? sum-expr))) | |
551 | (:function do-binop)) |
|
551 | (:function do-binop)) | |
552 |
|
552 | |||
553 | (p:defrule sum-expr (and mod-expr (* (and spaces? (or #\+ #\-) spaces? mod-expr))) |
|
553 | (p:defrule sum-expr (and mod-expr (* (and spaces? (or #\+ #\-) spaces? mod-expr))) | |
554 | (:function do-binop)) |
|
554 | (:function do-binop)) | |
555 |
|
555 | |||
556 | (p:defrule mod-expr (and mul-expr (* (and spaces? (p:~ "mod") spaces? mul-expr))) |
|
556 | (p:defrule mod-expr (and mul-expr (* (and spaces? (p:~ "mod") spaces? mul-expr))) | |
557 | (:function do-binop)) |
|
557 | (:function do-binop)) | |
558 |
|
558 | |||
559 | (p:defrule mul-expr (and unary-expr (* (and spaces? (or #\* #\/) spaces? unary-expr))) |
|
559 | (p:defrule mul-expr (and unary-expr (* (and spaces? (or #\* #\/) spaces? unary-expr))) | |
560 | (:function do-binop)) |
|
560 | (:function do-binop)) | |
561 |
|
561 | |||
562 | (p:defrule unary-expr (and (p:? (or #\+ #\-)) atom-expr) |
|
562 | (p:defrule unary-expr (and (p:? (or #\+ #\-)) atom-expr) | |
563 | (:lambda (list) |
|
563 | (:lambda (list) | |
564 | (let ((expr (remove-nil list))) |
|
564 | (let ((expr (remove-nil list))) | |
565 | (if (= 1 (length expr)) |
|
565 | (if (= 1 (length expr)) | |
566 | (first expr) |
|
566 | (first expr) | |
567 | (intern-first expr))))) |
|
567 | (intern-first expr))))) | |
568 |
|
568 | |||
569 | (p:defrule atom-expr (and (or variable literal returning-intrinsic paren-expr) spaces?) |
|
569 | (p:defrule atom-expr (and (or variable literal returning-intrinsic paren-expr) spaces?) | |
570 | (:function first)) |
|
570 | (:function first)) | |
571 |
|
571 | |||
572 | (p:defrule paren-expr (and #\( spaces? expression spaces? #\)) |
|
572 | (p:defrule paren-expr (and #\( spaces? expression spaces? #\)) | |
573 | (:function third)) |
|
573 | (:function third)) | |
574 |
|
574 | |||
575 | (p:defrule or-op (p:~ "or") |
|
575 | (p:defrule or-op (p:~ "or") | |
576 | (:constant "or")) |
|
576 | (:constant "or")) | |
577 |
|
577 | |||
578 | (p:defrule and-op (p:~ "and") |
|
578 | (p:defrule and-op (p:~ "and") | |
579 | (:constant "and")) |
|
579 | (:constant "and")) | |
580 |
|
580 | |||
581 | ;;; Variables |
|
581 | ;;; Variables | |
582 |
|
582 | |||
583 | (p:defrule variable (and identifier (p:? array-index)) |
|
583 | (p:defrule variable (and identifier (p:? array-index)) | |
584 | (:destructure (id idx) |
|
584 | (:destructure (id idx) | |
585 | (if (char= #\$ (elt (string id) 0)) |
|
585 | (if (char= #\$ (elt (string id) 0)) | |
586 | (list 'var (intern (subseq (string-upcase id) 1)) (or idx 0) :str) |
|
586 | (list 'lib:qspvar (intern (subseq (string-upcase id) 1) :lib) (or idx 0) :str) | |
587 | (list 'var id (or idx 0) :num)))) |
|
587 | (list 'lib:qspvar id (or idx 0) :num)))) | |
588 |
|
588 | |||
589 | (p:defrule array-index (and #\[ spaces? (p:? expression) spaces? #\]) |
|
589 | (p:defrule array-index (and #\[ spaces? (p:? expression) spaces? #\]) | |
590 | (:function third)) |
|
590 | (:function third)) | |
591 |
|
591 | |||
592 | (p:defrule assignment (or kw-assignment plain-assignment op-assignment) |
|
592 | (p:defrule assignment (or kw-assignment plain-assignment op-assignment) | |
593 | (:destructure (var eq expr) |
|
593 | (:destructure (qspvar eq expr) | |
594 | (declare (ignore eq)) |
|
594 | (declare (ignore eq)) | |
595 | (list 'set var expr))) |
|
595 | (list 'lib:set qspvar expr))) | |
596 |
|
596 | |||
597 | (p:defrule kw-assignment (and (or (p:~ "let") (p:~ "set")) spaces? (or op-assignment plain-assignment)) |
|
597 | (p:defrule kw-assignment (and (or (p:~ "let") (p:~ "set")) spaces? (or op-assignment plain-assignment)) | |
598 | (:function third)) |
|
598 | (:function third)) | |
599 |
|
599 | |||
600 | (p:defrule op-assignment (and variable spaces? (or "+" "-" "*" "/") #\= spaces? expression) |
|
600 | (p:defrule op-assignment (and variable spaces? (or "+" "-" "*" "/") #\= spaces? expression) | |
601 | (:destructure (var ws1 op eq ws2 expr) |
|
601 | (:destructure (qspvar ws1 op eq ws2 expr) | |
602 | (declare (ignore ws1 ws2)) |
|
602 | (declare (ignore ws1 ws2)) | |
603 | (list var eq (intern-first (list op var expr))))) |
|
603 | (list qspvar eq (intern-first (list op qspvar expr))))) | |
604 |
|
604 | |||
605 | (p:defrule plain-assignment (and variable spaces? #\= spaces? expression) |
|
605 | (p:defrule plain-assignment (and variable spaces? #\= spaces? expression) | |
606 | (:function remove-nil)) |
|
606 | (:function remove-nil)) | |
607 |
|
607 | |||
608 | ;;; Non-string literals |
|
608 | ;;; Non-string literals | |
609 |
|
609 | |||
610 | (p:defrule literal (or qsp-string brace-string number)) |
|
610 | (p:defrule literal (or qsp-string brace-string number)) | |
611 |
|
611 | |||
612 | (p:defrule number (+ (or #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) |
|
612 | (p:defrule number (+ (or #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) | |
613 | (:lambda (list) |
|
613 | (:lambda (list) | |
614 | (parse-integer (p:text list)))) |
|
614 | (parse-integer (p:text list)))) |
@@ -1,203 +1,164 b'' | |||||
1 |
|
1 | |||
2 | (in-package sugar-qsp) |
|
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 | ;;; Utils |
|
8 | ;;; Utils | |
9 |
|
9 | |||
10 | (ps:defpsmacro defm (path args &body body) |
|
|||
11 | `(setf ,path (lambda ,args ,@body))) |
|
|||
12 |
|
||||
13 | (ps:defpsmacro root (&rest path) |
|
|||
14 | `(ps:@ *sugar-q-s-p ,@path)) |
|
|||
15 |
|
||||
16 | (ps:defpsmacro in (key obj) |
|
|||
17 | `(ps:chain ,obj (has-own-property ,key))) |
|
|||
18 |
|
||||
19 | (ps:defpsmacro with-frame (&body body) |
|
|||
20 | `(progn |
|
|||
21 | (api-call push-local-frame) |
|
|||
22 | (unwind-protect |
|
|||
23 | ,@body |
|
|||
24 | (api-call pop-local-frame)))) |
|
|||
25 |
|
||||
26 | ;;; Common |
|
10 | ;;; Common | |
27 |
|
11 | |||
28 | (defmacro defpsintrinsic (name) |
|
12 | (defpsmacro label-block ((&key (locals t)) &body body) | |
29 | `(ps:defpsmacro ,name (&rest args) |
|
|||
30 | `(funcall (root lib ,',name) |
|
|||
31 | ,@args))) |
|
|||
32 |
|
||||
33 | (defmacro defpsintrinsics (() &rest names) |
|
|||
34 | `(progn ,@(loop :for name :in names |
|
|||
35 | :collect `(defpsintrinsic ,name)))) |
|
|||
36 |
|
||||
37 | (defpsintrinsics () |
|
|||
38 | rand copyarr arrpos arrcomp instr isnum strcomp strfind strpos iif gosub func dynamic dyneval main-p main-pl main-nl maintxt main-clear stat-p stat-pl stat-nl stattxt stat-clear cls curacts addobj delobj killobj menu play isplay close closeall refint view rgb showinput usertxt cmdclear input openqst addqst killqst opengame savegame wait msecscount settimer) |
|
|||
39 |
|
||||
40 | (ps:defpsmacro api-call (func &rest args) |
|
|||
41 | `(funcall (root api ,func) ,@args)) |
|
|||
42 |
|
||||
43 | (ps:defpsmacro label-block ((&key (locals t)) &body body) |
|
|||
44 | (let ((has-labels (some #'keywordp body))) |
|
13 | (let ((has-labels (some #'keywordp body))) | |
45 | `(block nil |
|
14 | `(block nil | |
46 | ,@(when has-labels |
|
15 | ,@(when has-labels | |
47 | '((defvar __labels))) |
|
16 | '((defvar __labels))) | |
48 | ,@(if locals |
|
17 | ,@(if locals | |
49 | `((tagbody |
|
18 | `((tagbody | |
50 | ,@body)) |
|
19 | ,@body)) | |
51 | `((tagbody |
|
20 | `((tagbody | |
52 | ,@body)))))) |
|
21 | ,@body)))))) | |
53 |
|
22 | |||
54 |
( |
|
23 | (defpsmacro str (&rest forms) | |
55 | (cond ((zerop (length forms)) |
|
24 | (cond ((zerop (length forms)) | |
56 | "") |
|
25 | "") | |
57 | ((and (= 1 (length forms)) |
|
26 | ((and (= 1 (length forms)) | |
58 | (stringp (first forms))) |
|
27 | (stringp (first forms))) | |
59 | (first forms)) |
|
28 | (first forms)) | |
60 | (t |
|
29 | (t | |
61 | `(& ,@forms)))) |
|
30 | `(& ,@forms)))) | |
62 |
|
31 | |||
63 | ;;; 1loc |
|
32 | ;;; 1loc | |
64 |
|
33 | |||
65 |
( |
|
34 | (defpsmacro location ((name) &body body) | |
66 | `(setf (root locs ,name) |
|
35 | `(setf (root locs ,name) | |
67 |
( |
|
36 | (async-lambda (args) | |
68 | (label-block () |
|
37 | (label-block () | |
69 | (api-call init-args args) |
|
38 | ,@body)))) | |
70 | ,@body |
|
|||
71 | (api-call get-result))))) |
|
|||
72 |
|
39 | |||
73 |
( |
|
40 | (defpsmacro goto% (target &rest args) | |
74 | `(progn |
|
41 | `(progn | |
75 |
( |
|
42 | (goto ,target ,args) | |
76 | (exit))) |
|
43 | (exit))) | |
77 |
|
44 | |||
78 |
( |
|
45 | (defpsmacro xgoto% (target &rest args) | |
79 | `(progn |
|
46 | `(progn | |
80 |
( |
|
47 | (xgoto ,target ,args) | |
81 | (exit))) |
|
48 | (exit))) | |
82 |
|
49 | |||
83 | (ps:defpsmacro desc (target) |
|
|||
84 | (declare (ignore target)) |
|
|||
85 | (report-error "DESC is not supported")) |
|
|||
86 |
|
||||
87 | ;;; 2var |
|
50 | ;;; 2var | |
88 |
|
51 | |||
89 |
( |
|
52 | (defpsmacro qspvar (name index slot) | |
90 | `(api-call get-var ,(string name) ,index ,slot)) |
|
53 | `(api-call get-var ,(string name) ,index ,slot)) | |
91 |
|
54 | |||
92 |
( |
|
55 | (defpsmacro set ((var vname vindex vslot) value) | |
93 | (assert (eq var 'var)) |
|
56 | (assert (eq var 'qspvar)) | |
94 | `(api-call set-var ,(string vname) ,vindex ,vslot ,value)) |
|
57 | `(api-call set-var ,(string vname) ,vindex ,vslot ,value)) | |
95 |
|
58 | |||
96 | ;;; 3expr |
|
59 | ;;; 3expr | |
97 |
|
60 | |||
98 |
( |
|
61 | (defpsmacro <> (op1 op2) | |
99 | `(not (equal ,op1 ,op2))) |
|
62 | `(not (equal ,op1 ,op2))) | |
100 |
|
63 | |||
101 |
( |
|
64 | (defpsmacro ! (op1 op2) | |
102 | `(not (equal ,op1 ,op2))) |
|
65 | `(not (equal ,op1 ,op2))) | |
103 |
|
66 | |||
104 | ;;; 4code |
|
67 | ;;; 4code | |
105 |
|
68 | |||
106 |
( |
|
69 | (defpsmacro exec (&body body) | |
107 |
(format nil "javascript: ~{~A~^~%~}" (mapcar #' |
|
70 | (format nil "javascript: ~{~A~^~%~}" (mapcar #'ps* body))) | |
108 |
|
71 | |||
109 | ;;; 5arrays |
|
72 | ;;; 5arrays | |
110 |
|
73 | |||
111 | ;;; 6str |
|
74 | ;;; 6str | |
112 |
|
75 | |||
113 |
( |
|
76 | (defpsmacro & (&rest args) | |
114 |
`( |
|
77 | `(chain "" (concat ,@args))) | |
115 |
|
78 | |||
116 | ;;; 7if |
|
79 | ;;; 7if | |
117 |
|
80 | |||
118 |
( |
|
81 | (defpsmacro qspcond (&rest clauses) | |
119 | `(cond ,@(loop :for clause :in clauses |
|
82 | `(cond ,@(loop :for clause :in clauses | |
120 | :collect (list (first clause) |
|
83 | :collect (list (first clause) | |
121 | `(tagbody |
|
84 | `(tagbody | |
122 | ,@(rest clause)))))) |
|
85 | ,@(rest clause)))))) | |
123 |
|
86 | |||
124 | ;;; 8sub |
|
87 | ;;; 8sub | |
125 |
|
88 | |||
126 | ;;; 9loops |
|
89 | ;;; 9loops | |
127 | ;;; Yep, that's a huge kludge since Javascript doesn't support arbitrary labels |
|
90 | ;;; Yep, that's a huge kludge since Javascript doesn't support arbitrary labels | |
128 |
|
91 | |||
129 |
( |
|
92 | (defpsmacro jump (target) | |
130 | `(return-from ,(intern (string-upcase (second target))) |
|
93 | `(return-from ,(intern (string-upcase (second target))) | |
131 |
(funcall ( |
|
94 | (funcall (getprop __labels ,target)))) | |
132 |
|
95 | |||
133 |
( |
|
96 | (defpsmacro tagbody (&body body) | |
134 | (let ((funcs (list nil :__nil))) |
|
97 | (let ((funcs (list nil :__nil))) | |
135 | (dolist (form body) |
|
98 | (dolist (form body) | |
136 | (cond ((keywordp form) |
|
99 | (cond ((keywordp form) | |
137 | (setf (first funcs) (reverse (first funcs))) |
|
100 | (setf (first funcs) (reverse (first funcs))) | |
138 | (push form funcs) |
|
101 | (push form funcs) | |
139 | (push nil funcs)) |
|
102 | (push nil funcs)) | |
140 | (t |
|
103 | (t | |
141 | (push form (first funcs))))) |
|
104 | (push form (first funcs))))) | |
142 | (setf (first funcs) (reverse (first funcs))) |
|
105 | (setf (first funcs) (reverse (first funcs))) | |
143 | (setf funcs (reverse funcs)) |
|
106 | (setf funcs (reverse funcs)) | |
144 | (if (= 2 (length funcs)) |
|
107 | (if (= 2 (length funcs)) | |
145 | `(progn |
|
108 | `(progn | |
146 | ,@body) |
|
109 | ,@body) | |
147 | `(progn |
|
110 | `(progn | |
148 | (setf ,@(loop :for f :on funcs :by #'cddr |
|
111 | (setf ,@(loop :for f :on funcs :by #'cddr | |
149 |
:append `(( |
|
112 | :append `((@ __labels ,(first f)) | |
150 | (block ,(intern (string-upcase (string (first f)))) |
|
113 | (block ,(intern (string-upcase (string (first f)))) | |
151 | ,@(second f) |
|
114 | ,@(second f) | |
152 | ,@(when (third f) |
|
115 | ,@(when (third f) | |
153 | `((funcall |
|
116 | `((funcall | |
154 |
( |
|
117 | (getprop __labels ,(third f))))))))) | |
155 | (jump (str "__nil")))))) |
|
118 | (jump (str "__nil")))))) | |
156 |
|
119 | |||
157 | ;;; 10dynamic |
|
120 | ;;; 10dynamic | |
158 |
|
121 | |||
159 |
( |
|
122 | (defpsmacro qspblock (&body body) | |
160 | `(lambda (args) |
|
123 | `(async-lambda (args) | |
161 | (label-block () |
|
124 | (label-block () | |
162 | (api-call init-args args) |
|
125 | ,@body))) | |
163 | ,@body |
|
|||
164 | (api-call get-result)))) |
|
|||
165 |
|
126 | |||
166 | ;;; 11main |
|
127 | ;;; 11main | |
167 |
|
128 | |||
168 |
( |
|
129 | (defpsmacro act (name img &body body) | |
169 | `(api-call add-act ,name ,img |
|
130 | `(api-call add-act ,name ,img | |
170 | (lambda () |
|
131 | (async-lambda () | |
171 | (label-block () |
|
132 | (label-block () | |
172 | ,@body)))) |
|
133 | ,@body)))) | |
173 |
|
134 | |||
174 | ;;; 12aux |
|
135 | ;;; 12aux | |
175 |
|
136 | |||
176 | ;;; 13diag |
|
137 | ;;; 13diag | |
177 |
|
138 | |||
178 | ;;; 14act |
|
139 | ;;; 14act | |
179 |
|
140 | |||
180 | ;;; 15objs |
|
141 | ;;; 15objs | |
181 |
|
142 | |||
182 | ;;; 16menu |
|
143 | ;;; 16menu | |
183 |
|
144 | |||
184 | ;;; 17sound |
|
145 | ;;; 17sound | |
185 |
|
146 | |||
186 | ;;; 18img |
|
147 | ;;; 18img | |
187 |
|
148 | |||
188 | ;;; 19input |
|
149 | ;;; 19input | |
189 |
|
150 | |||
190 | ;;; 20time |
|
151 | ;;; 20time | |
191 |
|
152 | |||
192 | ;;; 21local |
|
153 | ;;; 21local | |
193 |
|
154 | |||
194 | ;;; 22for |
|
155 | ;;; 22for | |
195 |
|
156 | |||
196 |
( |
|
157 | (defpsmacro qspfor (var from to step &body body) | |
197 | `(api-call qspfor |
|
158 | `((intern "QSPFOR" "API") | |
198 |
|
|
159 | ,(string (second var)) ,(third var) ;; name and index | |
199 |
|
|
160 | ,from ,to ,step | |
200 |
|
|
161 | (lambda () | |
201 |
|
|
162 | (block nil | |
202 |
|
|
163 | ,@body | |
203 |
|
|
164 | t)))) |
@@ -1,16 +1,19 b'' | |||||
1 |
|
1 | |||
2 | (defsystem sugar-qsp |
|
2 | (defsystem sugar-qsp | |
3 | :description "QSP compiler to monolithic HTML page" |
|
3 | :description "QSP compiler to monolithic HTML page" | |
4 | :depends-on (:alexandria ;; General |
|
4 | :depends-on (:alexandria ;; General | |
5 | :esrap ;; Parsing |
|
5 | :esrap ;; Parsing | |
6 | :parenscript :flute ;; Codegening |
|
6 | :parenscript :flute ;; Codegening | |
7 | ) |
|
7 | ) | |
8 | :pathname "src/" |
|
8 | :pathname "src/" | |
9 | :serial t |
|
9 | :serial t | |
10 | :components ((:file "package") |
|
10 | :components ((:file "package") | |
11 | (:file "patches") |
|
11 | (:file "patches") | |
|
12 | (:file "js-syms") | |||
|
13 | (:file "main-macros") | |||
12 | (:file "ps-macros") |
|
14 | (:file "ps-macros") | |
|
15 | (:file "api-macros") | |||
13 | (:file "intrinsic-macros") |
|
16 | (:file "intrinsic-macros") | |
14 | (:file "class") |
|
17 | (:file "class") | |
15 | (:file "main") |
|
18 | (:file "main") | |
16 | (:file "parser"))) |
|
19 | (:file "parser"))) |
General Comments 0
You need to be logged in to leave comments.
Login now