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