Show More
@@ -1,6 +1,3 b'' | |||||
1 |
|
||||
2 | * string array keys as addition to number keys |
|
|||
3 | * arr[] notation (i.e. with empty index) |
|
|||
4 |
|
1 | |||
5 | * Windows GUI (for the compiler) |
|
2 | * Windows GUI (for the compiler) | |
6 | * Save-load game in slots |
|
3 | * Save-load game in slots |
@@ -22,29 +22,43 b'' | |||||
22 | "</a>")) |
|
22 | "</a>")) | |
23 |
|
23 | |||
24 | ;; To be used in saving game |
|
24 | ;; To be used in saving game | |
25 | (defm (root api stash-state) () |
|
25 | (defm (root api stash-state) (args) | |
26 | (setf (root state-stash) |
|
26 | (setf (root state-stash) | |
27 | (*j-s-o-n.stringify |
|
27 | (*j-s-o-n.stringify | |
28 | (ps:create vars (root vars) |
|
28 | (ps:create vars (root vars) | |
29 | objs (root objs) |
|
29 | objs (root objs) | |
|
30 | loc-args args | |||
|
31 | main-html (ps:@ | |||
|
32 | (document.get-element-by-id :qsp-main) | |||
|
33 | inner-h-t-m-l) | |||
|
34 | stat-html (ps:@ | |||
|
35 | (document.get-element-by-id :qsp-stat) | |||
|
36 | inner-h-t-m-l) | |||
30 | next-location (root current-location)))) |
|
37 | next-location (root current-location)))) | |
31 | (values)) |
|
38 | (values)) | |
32 |
|
39 | |||
|
40 | (defm (root api unstash-state) () | |||
|
41 | (let ((data (*j-s-o-n.parse (root state-stash)))) | |||
|
42 | (this.clear-act) | |||
|
43 | (setf (root vars) (ps:@ data vars)) | |||
|
44 | (loop :for k :in (*object.keys (root vars)) | |||
|
45 | :do (*object.set-prototype-of (ps:getprop (root vars) k) | |||
|
46 | (root api *var prototype))) | |||
|
47 | (setf (root objs) (ps:@ data objs)) | |||
|
48 | (setf (root current-location) (ps:@ data next-location)) | |||
|
49 | (setf (ps:@ (document.get-element-by-id :qsp-main) inner-h-t-m-l) | |||
|
50 | (ps:@ data main-html)) | |||
|
51 | (setf (ps:@ (document.get-element-by-id :qsp-stat) inner-h-t-m-l) | |||
|
52 | (ps:@ data stat-html)) | |||
|
53 | (funcall (root locs (root current-location)) (ps:@ data loc-args)) | |||
|
54 | (this.update-objs) | |||
|
55 | (values))) | |||
|
56 | ||||
33 | (defm (root api state-to-base64) () |
|
57 | (defm (root api state-to-base64) () | |
34 | (btoa (encode-u-r-i-component (root state-stash)))) |
|
58 | (btoa (encode-u-r-i-component (root state-stash)))) | |
35 |
|
59 | |||
36 | (defm (root api base64-to-state) (data) |
|
60 | (defm (root api base64-to-state) (data) | |
37 | (setf (root state-stash) (decode-u-r-i-component (atob data))) |
|
61 | (setf (root state-stash) (decode-u-r-i-component (atob data)))) | |
38 | (let ((data (*j-s-o-n.parse (root state-stash)))) |
|
|||
39 | (this.clear-id :qsp-main) |
|
|||
40 | (this.clear-id :qsp-stat) |
|
|||
41 | (this.clear-act) |
|
|||
42 | (setf (root vars) (ps:@ data vars)) |
|
|||
43 | (setf (root objs) (ps:@ data objs)) |
|
|||
44 | (setf (root current-location) (ps:@ data next-location)) |
|
|||
45 | (funcall (root locs (root current-location))) |
|
|||
46 | (this.update-objs) |
|
|||
47 | (values))) |
|
|||
48 |
|
62 | |||
49 | ;;; Misc |
|
63 | ;;; Misc | |
50 |
|
64 | |||
@@ -52,17 +66,17 b'' | |||||
52 | (setf (ps:chain document (get-element-by-id id) inner-text) "")) |
|
66 | (setf (ps:chain document (get-element-by-id id) inner-text) "")) | |
53 |
|
67 | |||
54 | (defm (root api get-id) (id) |
|
68 | (defm (root api get-id) (id) | |
55 | (if (var "USEHTML" 0) |
|
69 | (if (var "USEHTML" 0 :num) | |
56 | (ps:chain (document.get-element-by-id id) inner-h-t-m-l) |
|
70 | (ps:chain (document.get-element-by-id id) inner-h-t-m-l) | |
57 | (ps:chain (document.get-element-by-id id) inner-text))) |
|
71 | (ps:chain (document.get-element-by-id id) inner-text))) | |
58 |
|
72 | |||
59 | (defm (root api set-id) (id contents) |
|
73 | (defm (root api set-id) (id contents) | |
60 | (if (var "USEHTML" 0) |
|
74 | (if (var "USEHTML" 0 :num) | |
61 | (setf (ps:chain (document.get-element-by-id id) inner-h-t-m-l) contents) |
|
75 | (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-text) contents))) |
|
76 | (setf (ps:chain (document.get-element-by-id id) inner-text) contents))) | |
63 |
|
77 | |||
64 | (defm (root api append-id) (id contents) |
|
78 | (defm (root api append-id) (id contents) | |
65 | (if (var "USEHTML" 0) |
|
79 | (if (var "USEHTML" 0 :num) | |
66 | (incf (ps:chain (document.get-element-by-id id) inner-h-t-m-l) contents) |
|
80 | (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-text) contents))) |
|
81 | (incf (ps:chain (document.get-element-by-id id) inner-text) contents))) | |
68 |
|
82 | |||
@@ -70,14 +84,15 b'' | |||||
70 |
|
84 | |||
71 | (defm (root api init-args) (args) |
|
85 | (defm (root api init-args) (args) | |
72 | (dotimes (i (length args)) |
|
86 | (dotimes (i (length args)) | |
73 |
( |
|
87 | (let ((arg (elt args i))) | |
74 | (set (var args i) (elt args i)) |
|
88 | (if (numberp arg) | |
75 | (set (var $args i) (elt args i))))) |
|
89 | (this.set-var args i :num arg) | |
|
90 | (this.set-var args i :str arg))))) | |||
76 |
|
91 | |||
77 | (defm (root api get-result) () |
|
92 | (defm (root api get-result) () | |
78 |
(if (not (equal "" (var |
|
93 | (if (not (equal "" (var result 0 :str))) | |
79 |
(var |
|
94 | (var result 0 :str) | |
80 | (var result 0))) |
|
95 | (var result 0 :num))) | |
81 |
|
96 | |||
82 | ;;; Text windows |
|
97 | ;;; Text windows | |
83 |
|
98 | |||
@@ -134,61 +149,113 b'' | |||||
134 | (this.append-id "qsp-acts" |
|
149 | (this.append-id "qsp-acts" | |
135 | (this.make-act-html title (ps:getprop obj :img)))))) |
|
150 | (this.make-act-html title (ps:getprop obj :img)))))) | |
136 |
|
151 | |||
137 | ;;; Variables |
|
152 | ;;; Variable class | |
|
153 | ||||
|
154 | (defm (root api *var) (name) | |||
|
155 | ;; From strings to numbers | |||
|
156 | (setf this.indexes (ps:create)) | |||
|
157 | ;; From numbers to {num: 0, str: ""} objects | |||
|
158 | (setf this.values (list)) | |||
|
159 | (values)) | |||
|
160 | ||||
|
161 | (defm (root api *var prototype new-value) () | |||
|
162 | (ps:create :num 0 :str "")) | |||
138 |
|
163 | |||
139 |
(defm (root api |
|
164 | (defm (root api *var prototype index-num) (index) | |
140 | (if (= (ps:@ name 0) #\$) |
|
165 | (let ((num-index | |
141 | :str |
|
166 | (if (stringp index) | |
142 | :num)) |
|
167 | (if (in index this.indexes) | |
|
168 | (ps:getprop this.indexes index) | |||
|
169 | (let ((n (length this.values))) | |||
|
170 | (setf (ps:getprop this.indexes index) n) | |||
|
171 | n)) | |||
|
172 | index))) | |||
|
173 | (unless (in num-index this.values) | |||
|
174 | (setf (elt this.values num-index) (this.new-value))) | |||
|
175 | num-index)) | |||
|
176 | ||||
|
177 | (defm (root api *var prototype get) (index slot) | |||
|
178 | (unless (or index (= 0 index)) | |||
|
179 | (setf index (1- (length this.values)))) | |||
|
180 | (ps:getprop this.values (this.index-num index) slot)) | |||
|
181 | ||||
|
182 | (defm (root api *var prototype set) (index slot value) | |||
|
183 | (unless (or index (= 0 index)) | |||
|
184 | (setf index (length store))) | |||
|
185 | (case slot | |||
|
186 | (:num (setf value (ps:chain *number (parse-int value)))) | |||
|
187 | (:str (setf value (ps:chain value (to-string))))) | |||
|
188 | (setf (ps:getprop this.values (this.index-num index) slot) value) | |||
|
189 | (values)) | |||
|
190 | ||||
|
191 | (defm (root api *var prototype kill) (index) | |||
|
192 | (setf (elt this.values (this.index-num index)) (this.new-value))) | |||
|
193 | ||||
|
194 | ;;; Variables | |||
143 |
|
195 | |||
144 | (defm (root api var-real-name) (name) |
|
196 | (defm (root api var-real-name) (name) | |
145 | (if (= (ps:@ name 0) #\$) |
|
197 | (if (= (ps:@ name 0) #\$) | |
146 | (ps:chain name (substr 1)) |
|
198 | (values (ps:chain name (substr 1)) :str) | |
147 | name)) |
|
199 | (values name :num))) | |
148 |
|
200 | |||
149 |
(defm (root api ensure-var) (name |
|
201 | (defm (root api ensure-var) (name) | |
150 | (let ((store (this.var-ref name))) |
|
202 | (let ((store (this.var-ref name))) | |
151 | (unless store |
|
203 | (unless store | |
152 |
(setf store (ps: |
|
204 | (setf store (ps:new (this.-var name))) | |
153 |
(setf (ps:getprop (root vars) name) store)) |
|
205 | (setf (ps:getprop (root vars) name) store)) | |
154 | (unless (in index store) |
|
206 | store)) | |
155 | (setf (elt store index) (ps:create :num 0 :str ""))) |
|
|||
156 | (values)) |
|
|||
157 |
|
207 | |||
158 | (defm (root api var-ref) (name) |
|
208 | (defm (root api var-ref) (name) | |
159 |
(let (( |
|
209 | (let ((local-store (this.current-local-frame))) | |
160 | (local-store (this.current-local-frame))) |
|
210 | (cond ((in name local-store) | |
161 | (cond ((in var-name local-store) |
|
211 | (ps:getprop local-store name)) | |
162 | (ps:getprop local-store)) |
|
212 | ((in name (root vars)) | |
163 |
( |
|
213 | (ps:getprop (root vars) name)) | |
164 | (ps:getprop (root vars) var-name)) |
|
|||
165 | (t nil)))) |
|
214 | (t nil)))) | |
166 |
|
215 | |||
167 | (defm (root api get-var) (name index) |
|
216 | (defm (root api get-var) (name index slot) | |
168 | (this.ensure-var name index) |
|
217 | (ps:chain (this.ensure-var name) (get index slot))) | |
169 | (let ((store (this.var-ref name))) |
|
|||
170 | (ps:getprop store index (this.var-slot name)))) |
|
|||
171 |
|
218 | |||
172 | (defm (root api set-var) (name index value) |
|
219 | (defm (root api set-var) (name index slot value) | |
173 | (this.ensure-var name index) |
|
220 | (ps:chain (this.ensure-var name) (set index slot value)) | |
174 | (let ((store (this.var-ref name))) |
|
221 | (values)) | |
175 | (setf (ps:getprop store index (this.var-slot name)) value) |
|
|||
176 | (values))) |
|
|||
177 |
|
222 | |||
178 | (defm (root api get-array) (name) |
|
223 | (defm (root api get-array) (name) | |
179 | (ps:getprop (root vars) name)) |
|
224 | (this.var-ref name)) | |
180 |
|
225 | |||
181 | (defm (root api set-array) (name value) |
|
226 | (defm (root api set-array) (name value) | |
182 | (setf (ps:getprop (root vars) name) value)) |
|
227 | (let ((store (this.var-ref name))) | |
|
228 | (setf (ps:@ store values) (ps:@ value values)) | |||
|
229 | (setf (ps:@ store indexes) (ps:@ value indexes))) | |||
|
230 | (values)) | |||
183 |
|
231 | |||
184 | (defm (root api kill-var) (name &optional index) |
|
232 | (defm (root api kill-var) (name &optional index) | |
185 | (if index |
|
233 | (if (and index (not (= 0 index))) | |
186 |
(ps: |
|
234 | (ps:chain (ps:getprop (root vars) name) (kill index)) | |
187 | (ps:delete (ps:getprop (root vars) name))) |
|
235 | (ps:delete (ps:getprop (root vars) name))) | |
188 | (values)) |
|
236 | (values)) | |
189 |
|
237 | |||
190 | (defm (root api array-size) (name) |
|
238 | (defm (root api array-size) (name) | |
191 |
(ps:getprop ( |
|
239 | (ps:getprop (this.var-ref name) 'length)) | |
|
240 | ||||
|
241 | ;;; Locals | |||
|
242 | ||||
|
243 | (defm (root api push-local-frame) () | |||
|
244 | (ps:chain (root locals) (push (ps:create))) | |||
|
245 | (values)) | |||
|
246 | ||||
|
247 | (defm (root api pop-local-frame) () | |||
|
248 | (ps:chain (root locals) (pop)) | |||
|
249 | (values)) | |||
|
250 | ||||
|
251 | (defm (root api current-local-frame) () | |||
|
252 | (elt (root locals) (1- (length (root locals))))) | |||
|
253 | ||||
|
254 | (defm (root api new-local) (name) | |||
|
255 | (let ((frame (this.current-local-frame))) | |||
|
256 | (unless (in name frame) | |||
|
257 | (setf (ps:getprop frame name) (ps:create))) | |||
|
258 | (values))) | |||
192 |
|
259 | |||
193 | ;;; Objects |
|
260 | ;;; Objects | |
194 |
|
261 | |||
@@ -218,19 +285,3 b'' | |||||
218 | :do (when (ps:@ v ended) |
|
285 | :do (when (ps:@ v ended) | |
219 | (ps:delete (ps:@ (root playing) k))))) |
|
286 | (ps:delete (ps:@ (root playing) k))))) | |
220 |
|
287 | |||
221 | ;;; Locals |
|
|||
222 |
|
||||
223 | (defm (root api push-local-frame) () |
|
|||
224 | (ps:chain (root locals) (push (ps:create)))) |
|
|||
225 |
|
||||
226 | (defm (root api pop-local-frame) () |
|
|||
227 | (ps:chain (root locals) (pop))) |
|
|||
228 |
|
||||
229 | (defm (root api current-local-frame) () |
|
|||
230 | (elt (root locals) (1- (length (root locals))))) |
|
|||
231 |
|
||||
232 | (defm (root api new-local) (name) |
|
|||
233 | (let ((frame (this.current-local-frame)) |
|
|||
234 | (var-name (this.var-real-name name))) |
|
|||
235 | (unless (in var-name frame) |
|
|||
236 | (setf (ps:getprop frame var-name) (ps:create))))) |
|
@@ -9,16 +9,18 b'' | |||||
9 |
|
9 | |||
10 | ;;; 1loc |
|
10 | ;;; 1loc | |
11 |
|
11 | |||
12 |
(defm (root lib goto) (target |
|
12 | (defm (root lib goto) (target args) | |
13 | (api-call clear-text :main) |
|
13 | (api-call clear-text :main) | |
14 |
( |
|
14 | (funcall (root lib xgoto) target (or args (list))) | |
|
15 | (values)) | |||
15 |
|
16 | |||
16 |
(defm (root lib xgoto) (target |
|
17 | (defm (root lib xgoto) (target args) | |
17 | (api-call clear-act) |
|
18 | (api-call clear-act) | |
18 | (api-call init-args args) |
|
|||
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) |
|
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))) | |||
|
23 | (values)) | |||
22 |
|
24 | |||
23 | ;;; 2var |
|
25 | ;;; 2var | |
24 |
|
26 | |||
@@ -34,23 +36,31 b'' | |||||
34 | ;;; 5arrays |
|
36 | ;;; 5arrays | |
35 |
|
37 | |||
36 | (defm (root lib copyarr) (to from start count) |
|
38 | (defm (root lib copyarr) (to from start count) | |
37 | (ps:for ((i start)) |
|
39 | (multiple-value-bind (to-name to-slot) | |
38 |
|
|
40 | (api-call var-real-name to) | |
39 | (+ start count)))) |
|
41 | (multiple-value-bind (from-name from-slot) | |
40 | ((incf i)) |
|
42 | (api-call var-real-name from) | |
41 | (api-call set-var to (+ start i) |
|
43 | (ps:for ((i start)) | |
42 |
( |
|
44 | ((< i (min (api-call array-size from-name) | |
|
45 | (+ start count)))) | |||
|
46 | ((incf i)) | |||
|
47 | (api-call set-var to-name (+ start i) to-slot | |||
|
48 | (api-call get-var from-name (+ start i) from-slot)))))) | |||
43 |
|
49 | |||
44 | (defm (root lib arrpos) (name value &optional (start 0)) |
|
50 | (defm (root lib arrpos) (name value &optional (start 0)) | |
45 | (ps:for ((i start)) ((< i (api-call array-size name))) ((incf i)) |
|
51 | (multiple-value-bind (real-name slot) | |
46 |
( |
|
52 | (api-call var-real-name name) | |
47 | (return 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) | |||
|
55 | (return i)))) | |||
48 | -1) |
|
56 | -1) | |
49 |
|
57 | |||
50 | (defm (root lib arrcomp) (name pattern &optional (start 0)) |
|
58 | (defm (root lib arrcomp) (name pattern &optional (start 0)) | |
51 | (ps:for ((i start)) ((< i (api-call array-size name))) ((incf i)) |
|
59 | (multiple-value-bind (real-name slot) | |
52 | (when (funcall (ps:getprop (api-call get-var name i) 'match) pattern) |
|
60 | (api-call var-real-name name) | |
53 | (return 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) | |||
|
63 | (return i)))) | |||
54 | -1) |
|
64 | -1) | |
55 |
|
65 | |||
56 | ;;; 6str |
|
66 | ;;; 6str | |
@@ -91,32 +101,22 b'' | |||||
91 | ;;; 8sub |
|
101 | ;;; 8sub | |
92 |
|
102 | |||
93 | (defm (root lib gosub) (target &rest args) |
|
103 | (defm (root lib gosub) (target &rest args) | |
94 | (conserving-vars (__funcall args result) |
|
104 | (funcall (ps:getprop (root locs) target) args) | |
95 | (api-call init-args args) |
|
105 | (values)) | |
96 | (funcall (ps:getprop (root locs) target)) |
|
|||
97 | (values))) |
|
|||
98 |
|
106 | |||
99 | (defm (root lib func) (target &rest args) |
|
107 | (defm (root lib func) (target &rest args) | |
100 | (conserving-vars (__funcall args result) |
|
108 | (funcall (ps:getprop (root locs) target) args)) | |
101 | (api-call init-args args) |
|
|||
102 | (funcall (ps:getprop (root locs) target)) |
|
|||
103 | (api-call get-result))) |
|
|||
104 |
|
109 | |||
105 | ;;; 9loops |
|
110 | ;;; 9loops | |
106 |
|
111 | |||
107 | ;;; 10dynamic |
|
112 | ;;; 10dynamic | |
108 |
|
113 | |||
109 |
(defm (root lib dyn |
|
114 | (defm (root lib dynamic) (block &rest args) | |
110 | (conserving-vars (__funcall args result) |
|
115 | (funcall block args) | |
111 | (api-call init-args args) |
|
116 | (values)) | |
112 | (funcall block) |
|
|||
113 | (api-call get-result))) |
|
|||
114 |
|
117 | |||
115 |
(defm (root lib dyn |
|
118 | (defm (root lib dyneval) (block &rest args) | |
116 | (conserving-vars (__funcall args result) |
|
119 | (funcall block args)) | |
117 | (api-call init-args args) |
|
|||
118 | (funcall block) |
|
|||
119 | (values))) |
|
|||
120 |
|
120 | |||
121 | ;;; 11main |
|
121 | ;;; 11main | |
122 |
|
122 | |||
@@ -307,7 +307,8 b'' | |||||
307 | (let ((target ev.current-target)) |
|
307 | (let ((target ev.current-target)) | |
308 | (unless target.result |
|
308 | (unless target.result | |
309 | (return)) |
|
309 | (return)) | |
310 |
(api-call base64-to-state target.result) |
|
310 | (api-call base64-to-state target.result) | |
|
311 | (api-call unstash-state))))) | |||
311 | (reader.read-as-text file)))) |
|
312 | (reader.read-as-text file)))) | |
312 | (document.body.append-child element) |
|
313 | (document.body.append-child element) | |
313 | (element.click) |
|
314 | (element.click) |
@@ -25,7 +25,8 b'' | |||||
25 | (setf window.onload |
|
25 | (setf window.onload | |
26 | (lambda () |
|
26 | (lambda () | |
27 | (funcall (ps:getprop (root locs) |
|
27 | (funcall (ps:getprop (root locs) | |
28 |
(ps:chain *object (keys (root locs)) 0)) |
|
28 | (ps:chain *object (keys (root locs)) 0)) | |
|
29 | (list)) | |||
29 | (values))) |
|
30 | (values))) | |
30 |
|
31 | |||
31 | ;; Close the dropdown on any click |
|
32 | ;; Close the dropdown on any click |
@@ -555,11 +555,12 b'' | |||||
555 |
|
555 | |||
556 | (p:defrule variable (and identifier (p:? array-index)) |
|
556 | (p:defrule variable (and identifier (p:? array-index)) | |
557 | (:destructure (id idx) |
|
557 | (:destructure (id idx) | |
558 | (list 'var id (or idx 0)))) |
|
558 | (if (char= #\$ (elt (string id) 0)) | |
|
559 | (list 'var (intern (subseq (string-upcase id) 1)) (or idx 0) :str) | |||
|
560 | (list 'var id (or idx 0) :num)))) | |||
559 |
|
561 | |||
560 | (p:defrule array-index (and #\[ spaces? (p:? expression) spaces? #\]) |
|
562 | (p:defrule array-index (and #\[ spaces? (p:? expression) spaces? #\]) | |
561 | (:lambda (list) |
|
563 | (:function third)) | |
562 | (or (third list) :end))) |
|
|||
563 |
|
564 | |||
564 | (p:defrule assignment (or kw-assignment plain-assignment op-assignment) |
|
565 | (p:defrule assignment (or kw-assignment plain-assignment op-assignment) | |
565 | (:destructure (var eq expr) |
|
566 | (:destructure (var eq expr) |
@@ -16,6 +16,13 b'' | |||||
16 | (ps:defpsmacro in (key obj) |
|
16 | (ps:defpsmacro in (key obj) | |
17 | `(ps:chain ,obj (has-own-property ,key))) |
|
17 | `(ps:chain ,obj (has-own-property ,key))) | |
18 |
|
18 | |||
|
19 | (ps:defpsmacro with-frame (&body body) | |||
|
20 | `(progn | |||
|
21 | (api-call push-local-frame) | |||
|
22 | (unwind-protect | |||
|
23 | ,@body | |||
|
24 | (api-call pop-local-frame)))) | |||
|
25 | ||||
19 | ;;; Common |
|
26 | ;;; Common | |
20 |
|
27 | |||
21 | (defmacro defpsintrinsic (name) |
|
28 | (defmacro defpsintrinsic (name) | |
@@ -33,17 +40,17 b'' | |||||
33 | (ps:defpsmacro api-call (func &rest args) |
|
40 | (ps:defpsmacro api-call (func &rest args) | |
34 | `(funcall (root api ,func) ,@args)) |
|
41 | `(funcall (root api ,func) ,@args)) | |
35 |
|
42 | |||
36 | (ps:defpsmacro label-block (&body body) |
|
43 | (ps:defpsmacro label-block ((&key (locals t)) &body body) | |
37 | (let ((has-labels (some #'keywordp body))) |
|
44 | (let ((has-labels (some #'keywordp body))) | |
38 | `(block nil |
|
45 | `(block nil | |
39 | ,@(when has-labels |
|
46 | ,@(when has-labels | |
40 | '((defvar __labels))) |
|
47 | '((defvar __labels))) | |
41 | (api-call push-local-frame) |
|
48 | ,@(if locals | |
42 | (unwind-protect |
|
49 | `((with-frame | |
43 | (tagbody |
|
50 | (tagbody | |
44 | ,@body) |
|
51 | ,@body))) | |
45 | (api-call pop-local-frame)) |
|
52 | `((tagbody | |
46 | (values)))) |
|
53 | ,@body)))))) | |
47 |
|
54 | |||
48 | (ps:defpsmacro str (&rest forms) |
|
55 | (ps:defpsmacro str (&rest forms) | |
49 | (cond ((zerop (length forms)) |
|
56 | (cond ((zerop (length forms)) | |
@@ -58,18 +65,20 b'' | |||||
58 |
|
65 | |||
59 | (ps:defpsmacro location ((name) &body body) |
|
66 | (ps:defpsmacro location ((name) &body body) | |
60 | `(setf (root locs ,name) |
|
67 | `(setf (root locs ,name) | |
61 | (lambda () |
|
68 | (lambda (args) | |
62 | (label-block |
|
69 | (label-block () | |
63 | ,@body)))) |
|
70 | (api-call init-args args) | |
|
71 | ,@body | |||
|
72 | (api-call get-result))))) | |||
64 |
|
73 | |||
65 | (ps:defpsmacro goto (target &rest args) |
|
74 | (ps:defpsmacro goto (target &rest args) | |
66 | `(progn |
|
75 | `(progn | |
67 |
(funcall (root lib goto) ,target , |
|
76 | (funcall (root lib goto) ,target ,args) | |
68 | (exit))) |
|
77 | (exit))) | |
69 |
|
78 | |||
70 | (ps:defpsmacro xgoto (target &rest args) |
|
79 | (ps:defpsmacro xgoto (target &rest args) | |
71 | `(progn |
|
80 | `(progn | |
72 |
(funcall (root lib xgoto) ,target , |
|
81 | (funcall (root lib xgoto) ,target ,args) | |
73 | (exit))) |
|
82 | (exit))) | |
74 |
|
83 | |||
75 | (ps:defpsmacro desc (target) |
|
84 | (ps:defpsmacro desc (target) | |
@@ -78,12 +87,12 b'' | |||||
78 |
|
87 | |||
79 | ;;; 2var |
|
88 | ;;; 2var | |
80 |
|
89 | |||
81 | (ps:defpsmacro var (name index) |
|
90 | (ps:defpsmacro var (name index slot) | |
82 | `(api-call get-var ,(string name) ,index)) |
|
91 | `(api-call get-var ,(string name) ,index ,slot)) | |
83 |
|
92 | |||
84 | (ps:defpsmacro set ((var vname vindex) value) |
|
93 | (ps:defpsmacro set ((var vname vindex vslot) value) | |
85 | (assert (eq var 'var)) |
|
94 | (assert (eq var 'var)) | |
86 | `(api-call set-var ,(string vname) ,vindex ,value)) |
|
95 | `(api-call set-var ,(string vname) ,vindex ,vslot ,value)) | |
87 |
|
96 | |||
88 | ;;; 3expr |
|
97 | ;;; 3expr | |
89 |
|
98 | |||
@@ -110,7 +119,8 b'' | |||||
110 | (ps:defpsmacro qspcond (&rest clauses) |
|
119 | (ps:defpsmacro qspcond (&rest clauses) | |
111 | `(cond ,@(loop :for clause :in clauses |
|
120 | `(cond ,@(loop :for clause :in clauses | |
112 | :collect (list (first clause) |
|
121 | :collect (list (first clause) | |
113 |
`(tagbody |
|
122 | `(tagbody | |
|
123 | ,@(rest clause)))))) | |||
114 |
|
124 | |||
115 | ;;; 8sub |
|
125 | ;;; 8sub | |
116 |
|
126 | |||
@@ -137,27 +147,29 b'' | |||||
137 | ,@body) |
|
147 | ,@body) | |
138 | `(progn |
|
148 | `(progn | |
139 | (setf ,@(loop :for f :on funcs :by #'cddr |
|
149 | (setf ,@(loop :for f :on funcs :by #'cddr | |
140 |
:append ( |
|
150 | :append `((ps:@ __labels ,(first f)) | |
141 |
|
|
151 | (block ,(intern (string-upcase (string (first f)))) | |
142 |
|
|
152 | ,@(second f) | |
143 |
|
|
153 | ,@(when (third f) | |
144 |
|
|
154 | `((funcall | |
145 |
|
|
155 | (ps:getprop __labels ,(third f))))))))) | |
146 | (jump (str "__nil")))))) |
|
156 | (jump (str "__nil")))))) | |
147 |
|
157 | |||
148 | ;;; 10dynamic |
|
158 | ;;; 10dynamic | |
149 |
|
159 | |||
150 | (ps:defpsmacro qspblock (&body body) |
|
160 | (ps:defpsmacro qspblock (&body body) | |
151 | `(lambda () |
|
161 | `(lambda (args) | |
152 | (label-block |
|
162 | (label-block () | |
153 | ,@body))) |
|
163 | (api-call init-args args) | |
|
164 | ,@body | |||
|
165 | (api-call get-result)))) | |||
154 |
|
166 | |||
155 | ;;; 11main |
|
167 | ;;; 11main | |
156 |
|
168 | |||
157 | (ps:defpsmacro act (name img &body body) |
|
169 | (ps:defpsmacro act (name img &body body) | |
158 | `(api-call add-act ,name ,img |
|
170 | `(api-call add-act ,name ,img | |
159 | (lambda () |
|
171 | (lambda () | |
160 | (label-block |
|
172 | (label-block () | |
161 | ,@body)))) |
|
173 | ,@body)))) | |
162 |
|
174 | |||
163 | ;;; 12aux |
|
175 | ;;; 12aux |
General Comments 0
You need to be logged in to leave comments.
Login now