Show More
@@ -0,0 +1,21 b'' | |||||
|
1 | ||||
|
2 | (in-package sugar-qsp) | |||
|
3 | ||||
|
4 | (eval-when (:compile-toplevel :load-toplevel :execute) | |||
|
5 | (defun src-file (filename) | |||
|
6 | (uiop/pathname:merge-pathnames* | |||
|
7 | filename | |||
|
8 | (asdf:system-source-directory :sugar-qsp))) | |||
|
9 | (defun compile-ps (filename) | |||
|
10 | (format nil "////// Parenscript file: ~A~%~%~A" | |||
|
11 | (file-namestring filename) (ps:ps-compile-file filename)))) | |||
|
12 | ||||
|
13 | (defclass compiler () | |||
|
14 | ((body :accessor body :initform #.(alexandria:read-file-into-string (src-file "extras/body.html"))) | |||
|
15 | (css :accessor css :initform (list #.(alexandria:read-file-into-string (src-file "extras/default.css")))) | |||
|
16 | (js :accessor js :initform (list #.(compile-ps (src-file "src/intrinsics.ps")) | |||
|
17 | #.(compile-ps (src-file "src/api.ps")) | |||
|
18 | #.(compile-ps (src-file "src/main.ps")))) | |||
|
19 | (compile :accessor compile-only :initarg :compile) | |||
|
20 | (target :accessor target :initarg :target) | |||
|
21 | (beautify :accessor beautify :initarg :beautify))) |
@@ -0,0 +1,137 b'' | |||||
|
1 | ||||
|
2 | (in-package sugar-qsp) | |||
|
3 | ||||
|
4 | ;;;; Macros implementing some intrinsics where it makes sense | |||
|
5 | ;;;; E.g. an equivalent JS function exists, or it's a direct API call | |||
|
6 | ||||
|
7 | ;;; 1loc | |||
|
8 | ||||
|
9 | ;;; 2var | |||
|
10 | ||||
|
11 | (ps:defpsmacro killvar (varname &optional (index :whole)) | |||
|
12 | `(api-call kill-var ,varname ,index)) | |||
|
13 | ||||
|
14 | (ps:defpsmacro killall () | |||
|
15 | `(api-call kill-all)) | |||
|
16 | ||||
|
17 | ;;; 3expr | |||
|
18 | ||||
|
19 | (ps:defpsmacro obj (name) | |||
|
20 | `(funcall (root objs includes) ,name)) | |||
|
21 | ||||
|
22 | (ps:defpsmacro loc (name) | |||
|
23 | `(funcall (root locs includes) ,name)) | |||
|
24 | ||||
|
25 | (ps:defpsmacro no (arg) | |||
|
26 | `(- -1 ,arg)) | |||
|
27 | ||||
|
28 | ;;; 4code | |||
|
29 | ||||
|
30 | (ps:defpsmacro qspver () | |||
|
31 | "0.0.1") | |||
|
32 | ||||
|
33 | (ps:defpsmacro curloc () | |||
|
34 | `(root current-location)) | |||
|
35 | ||||
|
36 | (ps:defpsmacro rnd () | |||
|
37 | `(funcall (root lib rand) 1 1000)) | |||
|
38 | ||||
|
39 | (ps:defpsmacro qspmax (&rest args) | |||
|
40 | `(max ,@args)) | |||
|
41 | ||||
|
42 | (ps:defpsmacro qspmin (&rest args) | |||
|
43 | `(min ,@args)) | |||
|
44 | ||||
|
45 | ;;; 5arrays | |||
|
46 | ||||
|
47 | (ps:defpsmacro arrsize (name) | |||
|
48 | `(api-call array-size ,name)) | |||
|
49 | ||||
|
50 | ;;; 6str | |||
|
51 | ||||
|
52 | (ps:defpsmacro len (s) | |||
|
53 | `(length ,s)) | |||
|
54 | ||||
|
55 | (ps:defpsmacro mid (s from &optional count) | |||
|
56 | `(ps:chain ,s (substring ,from ,count))) | |||
|
57 | ||||
|
58 | (ps:defpsmacro ucase (s) | |||
|
59 | `(ps:chain ,s (to-upper-case))) | |||
|
60 | ||||
|
61 | (ps:defpsmacro lcase (s) | |||
|
62 | `(ps:chain ,s (to-lower-case))) | |||
|
63 | ||||
|
64 | (ps:defpsmacro trim (s) | |||
|
65 | `(ps:chain ,s (trim))) | |||
|
66 | ||||
|
67 | (ps:defpsmacro replace (s from to) | |||
|
68 | `(ps:chain ,s (replace ,from ,to))) | |||
|
69 | ||||
|
70 | (ps:defpsmacro val (s) | |||
|
71 | `(parse-int ,s 10)) | |||
|
72 | ||||
|
73 | (ps:defpsmacro qspstr (n) | |||
|
74 | `(ps:chain ,n (to-string))) | |||
|
75 | ||||
|
76 | ;;; 7if | |||
|
77 | ||||
|
78 | ;;; 8sub | |||
|
79 | ||||
|
80 | ;;; 9loops | |||
|
81 | ||||
|
82 | ;; JUMP is in ps-macros.lisp (because it's a part of a huge kludge) | |||
|
83 | ||||
|
84 | (ps:defpsmacro exit () | |||
|
85 | `(return-from nil (values))) | |||
|
86 | ||||
|
87 | ;;; 10dynamic | |||
|
88 | ||||
|
89 | ;;; 11main | |||
|
90 | ||||
|
91 | (ps:defpsmacro desc (s) | |||
|
92 | (declare (ignore s)) | |||
|
93 | "") | |||
|
94 | ||||
|
95 | ;;; 12stat | |||
|
96 | ||||
|
97 | (ps:defpsmacro showstat (enable) | |||
|
98 | `(api-call enable-frame :stat ,enable)) | |||
|
99 | ||||
|
100 | ;;; 13diag | |||
|
101 | ||||
|
102 | (ps:defpsmacro msg (text) | |||
|
103 | `(alert ,text)) | |||
|
104 | ||||
|
105 | ;;; 14act | |||
|
106 | ||||
|
107 | (ps:defpsmacro showacts (enable) | |||
|
108 | `(api-call enable-frame :acts ,enable)) | |||
|
109 | ||||
|
110 | (ps:defpsmacro delact (name) | |||
|
111 | `(api-call del-act ,name)) | |||
|
112 | ||||
|
113 | (ps:defpsmacro cla () | |||
|
114 | `(api-call clear-act)) | |||
|
115 | ||||
|
116 | ;;; 15objs | |||
|
117 | ||||
|
118 | (ps:defpsmacro showobjs (enable) | |||
|
119 | `(api-call enable-frame :objs ,enable)) | |||
|
120 | ||||
|
121 | (ps:defpsmacro countobj () | |||
|
122 | `(length (root objs))) | |||
|
123 | ||||
|
124 | (ps:defpsmacro getobj (index) | |||
|
125 | `(or (elt (root objs) ,index) "")) | |||
|
126 | ||||
|
127 | ;;; 16menu | |||
|
128 | ||||
|
129 | ;;; 17sound | |||
|
130 | ||||
|
131 | ;;; 18img | |||
|
132 | ||||
|
133 | ;;; 19input | |||
|
134 | ||||
|
135 | ;;; 20time | |||
|
136 | ||||
|
137 | ;;; misc |
@@ -1,9 +1,6 b'' | |||||
1 |
|
1 | |||
2 | * Windows GUI |
|
2 | * Windows GUI (for the compiler) | |
3 | * Save-load game |
|
3 | * Save-load game in slots | |
4 | * Resizable frames |
|
4 | * Resizable frames | |
5 | * Build Istreblenie |
|
5 | * Build Istreblenie | |
6 | ** modifying it to suit compiler specifics |
|
6 | ** modifying it to suit compiler specifics No newline at end of file | |
7 | ** Implementing apis and intrinsics as needed |
|
|||
8 |
|
||||
9 | * Use real characters in cl-uglify-js No newline at end of file |
|
@@ -1,12 +1,15 b'' | |||||
1 |
|
1 | |||
2 | <div id="qsp"> |
|
2 | <div id="qsp"> | |
3 | <div class="qsp-col qsp-col1"> |
|
3 | <div class="qsp-col qsp-col1"> | |
4 | <div id="qsp-main" class="qsp-frame"> </div> |
|
4 | <div id="qsp-main" class="qsp-frame"> </div> | |
5 | <div id="qsp-acts" class="qsp-frame"> </div> |
|
5 | <div id="qsp-acts" class="qsp-frame"> </div> | |
6 | <input id="qsp-input" class="qsp-frame"> |
|
6 | <input id="qsp-input" class="qsp-frame"> | |
7 | </div> |
|
7 | </div> | |
8 | <div class="qsp-col qsp-col2"> |
|
8 | <div class="qsp-col qsp-col2"> | |
9 | <div id="qsp-stat" class="qsp-frame"> </div> |
|
9 | <div id="qsp-stat" class="qsp-frame"> </div> | |
10 | <div id="qsp-objs" class="qsp-frame"> </div> |
|
10 | <div id="qsp-objs" class="qsp-frame"> </div> | |
11 | </div> |
|
11 | </div> | |
12 | </div> |
|
12 | </div> | |
|
13 | ||||
|
14 | <div id="qsp-dropdown"> | |||
|
15 | </div> |
@@ -1,59 +1,84 b'' | |||||
1 |
|
1 | |||
2 | .qsp-frame { |
|
2 | .qsp-frame { | |
3 | border: 1px solid black; |
|
3 | border: 1px solid black; | |
4 | overflow: auto; |
|
4 | overflow: auto; | |
5 | padding: 5px; |
|
5 | padding: 5px; | |
6 | box-sizing: border-box; |
|
6 | box-sizing: border-box; | |
7 | } |
|
7 | } | |
8 |
|
8 | |||
9 | #qsp { |
|
9 | #qsp { | |
10 | position: absolute; |
|
10 | position: absolute; | |
11 | display: flex; |
|
11 | display: flex; | |
12 | flex-flow: row; |
|
12 | flex-flow: row; | |
13 | top: 0; |
|
13 | top: 0; | |
14 | left: 0; |
|
14 | left: 0; | |
15 | width: 100%; |
|
15 | width: 100%; | |
16 | height: 100%; |
|
16 | height: 100%; | |
17 | } |
|
17 | } | |
18 |
|
18 | |||
19 | .qsp-col { |
|
19 | .qsp-col { | |
20 | display: flex; |
|
20 | display: flex; | |
21 | flex-flow: column; |
|
21 | flex-flow: column; | |
22 | } |
|
22 | } | |
23 |
|
23 | |||
24 | .qsp-col1 { |
|
24 | .qsp-col1 { | |
25 | flex: 7 7 70px; |
|
25 | flex: 7 7 70px; | |
26 | } |
|
26 | } | |
27 |
|
27 | |||
28 | .qsp-col2 { |
|
28 | .qsp-col2 { | |
29 | flex: 3 3 30px; |
|
29 | flex: 3 3 30px; | |
30 | } |
|
30 | } | |
31 |
|
31 | |||
32 | #qsp-main { |
|
32 | #qsp-main { | |
33 | flex: 6 6 60px; |
|
33 | flex: 6 6 60px; | |
34 | } |
|
34 | } | |
35 |
|
35 | |||
36 | #qsp-acts { |
|
36 | #qsp-acts { | |
37 | flex: 4 4 40px; |
|
37 | flex: 4 4 40px; | |
38 | } |
|
38 | } | |
39 |
|
39 | |||
40 | #qsp-input { |
|
40 | #qsp-input { | |
41 | } |
|
41 | } | |
42 |
|
42 | |||
43 | #qsp-stat { |
|
43 | #qsp-stat { | |
44 | flex: 5 5 50px; |
|
44 | flex: 5 5 50px; | |
45 | } |
|
45 | } | |
46 |
|
46 | |||
47 | #qsp-objs { |
|
47 | #qsp-objs { | |
48 | flex: 5 5 50px; |
|
48 | flex: 5 5 50px; | |
49 | } |
|
49 | } | |
50 |
|
50 | |||
51 | .qsp-act { |
|
51 | .qsp-act { | |
52 | display: block; |
|
52 | display: block; | |
53 | padding: 2px; |
|
53 | padding: 2px; | |
54 | font-size: large; |
|
54 | font-size: large; | |
55 | } |
|
55 | } | |
56 |
|
56 | |||
57 | .qsp-act:hover { |
|
57 | .qsp-act:hover { | |
58 | outline: #9E9E9E outset 3px |
|
58 | outline: #9E9E9E outset 3px | |
59 | } |
|
59 | } | |
|
60 | ||||
|
61 | // Dropdown | |||
|
62 | ||||
|
63 | #qsp-dropdown { | |||
|
64 | display: none; | |||
|
65 | position: absolute; | |||
|
66 | background-color: #f1f1f1; | |||
|
67 | min-width: 160px; | |||
|
68 | overflow: auto; | |||
|
69 | box-shadow: 0px 8px 16px 0px rgba(0,0,0,0.2); | |||
|
70 | z-index: 1; | |||
|
71 | margin: auto; | |||
|
72 | top: 200; | |||
|
73 | } | |||
|
74 | ||||
|
75 | #qsp-dropdown a { | |||
|
76 | color: black; | |||
|
77 | padding: 12px 16px; | |||
|
78 | text-decoration: none; | |||
|
79 | display: block; | |||
|
80 | } | |||
|
81 | ||||
|
82 | #qsp-dropdown a:hover { | |||
|
83 | background-color: #ddd; | |||
|
84 | } |
@@ -1,150 +1,200 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) | |||
|
19 | (+ "<a href='#' onclick='SugarQSP.api.runMenu(" num ", \"" loc "\")();'>" | |||
|
20 | "<img src='" img "'>" | |||
|
21 | title | |||
|
22 | "</a>")) | |||
|
23 | ||||
18 | ;; To be used in saving game |
|
24 | ;; To be used in saving game | |
19 | (defm (root api stash-state) () |
|
25 | (defm (root api stash-state) () | |
20 | (setf (root state-stash) |
|
26 | (setf (root state-stash) | |
21 | (ps:create vars (root vars) |
|
27 | (*j-s-o-n.stringify | |
22 | objs (root objs) |
|
28 | (ps:create vars (root vars) | |
23 |
|
|
29 | objs (root objs) | |
|
30 | next-location (root current-location)))) | |||
24 | (values)) |
|
31 | (values)) | |
25 |
|
32 | |||
|
33 | (defm (root api state-to-base64) () | |||
|
34 | (btoa (encode-u-r-i-component (root state-stash)))) | |||
|
35 | ||||
|
36 | (defm (root api base64-to-state) (data) | |||
|
37 | (setf (root state-stash) (decode-u-r-i-component (atob data))) | |||
|
38 | (let ((data (*j-s-o-n.parse (root state-stash)))) | |||
|
39 | (api-call clear-act) | |||
|
40 | (setf (root vars) (ps:@ data vars)) | |||
|
41 | (setf (root objs) (ps:@ data objs)) | |||
|
42 | (setf (root current-location) (ps:@ data next-location)) | |||
|
43 | (funcall (root locs (root current-location))) | |||
|
44 | (api-call update-objs) | |||
|
45 | (values))) | |||
|
46 | ||||
26 | ;;; Misc |
|
47 | ;;; Misc | |
27 |
|
48 | |||
28 | (defm (root api clear-id) (id) |
|
49 | (defm (root api clear-id) (id) | |
29 | (setf (ps:chain document (get-element-by-id id) inner-text) "")) |
|
50 | (setf (ps:chain document (get-element-by-id id) inner-text) "")) | |
30 |
|
51 | |||
31 | (defm (root api get-id) (id) |
|
52 | (defm (root api get-id) (id) | |
32 | (if (var "USEHTML" 0) |
|
53 | (if (var "USEHTML" 0) | |
33 | (ps:chain (document.get-element-by-id id) inner-h-t-m-l) |
|
54 | (ps:chain (document.get-element-by-id id) inner-h-t-m-l) | |
34 | (ps:chain (document.get-element-by-id id) inner-text))) |
|
55 | (ps:chain (document.get-element-by-id id) inner-text))) | |
35 |
|
56 | |||
36 | (defm (root api set-id) (id contents) |
|
57 | (defm (root api set-id) (id contents) | |
37 | (if (var "USEHTML" 0) |
|
58 | (if (var "USEHTML" 0) | |
38 | (setf (ps:chain (document.get-element-by-id id) inner-h-t-m-l) contents) |
|
59 | (setf (ps:chain (document.get-element-by-id id) inner-h-t-m-l) contents) | |
39 | (setf (ps:chain (document.get-element-by-id id) inner-text) contents))) |
|
60 | (setf (ps:chain (document.get-element-by-id id) inner-text) contents))) | |
40 |
|
61 | |||
41 | (defm (root api append-id) (id contents) |
|
62 | (defm (root api append-id) (id contents) | |
42 | (if (var "USEHTML" 0) |
|
63 | (if (var "USEHTML" 0) | |
43 | (incf (ps:chain (document.get-element-by-id id) inner-h-t-m-l) contents) |
|
64 | (incf (ps:chain (document.get-element-by-id id) inner-h-t-m-l) contents) | |
44 | (incf (ps:chain (document.get-element-by-id id) inner-text) contents))) |
|
65 | (incf (ps:chain (document.get-element-by-id id) inner-text) contents))) | |
45 |
|
66 | |||
46 | ;;; Function calls |
|
67 | ;;; Function calls | |
47 |
|
68 | |||
48 | (defm (root api init-args) (args) |
|
69 | (defm (root api init-args) (args) | |
49 | (dotimes (i (length args)) |
|
70 | (dotimes (i (length args)) | |
50 | (if (numberp (elt args i)) |
|
71 | (if (numberp (elt args i)) | |
51 | (set (var args i) (elt args i)) |
|
72 | (set (var args i) (elt args i)) | |
52 | (set (var $args i) (elt args i))))) |
|
73 | (set (var $args i) (elt args i))))) | |
53 |
|
74 | |||
54 | (defm (root api get-result) () |
|
75 | (defm (root api get-result) () | |
55 | (if (not (equal "" (var $result 0))) |
|
76 | (if (not (equal "" (var $result 0))) | |
56 | (var $result 0) |
|
77 | (var $result 0) | |
57 | (var result 0))) |
|
78 | (var result 0))) | |
58 |
|
79 | |||
59 | ;;; Text windows |
|
80 | ;;; Text windows | |
60 |
|
81 | |||
61 | (defm (root api key-to-id) (key) |
|
82 | (defm (root api key-to-id) (key) | |
62 | (case key |
|
83 | (case key | |
63 | (:main "qsp-main") |
|
84 | (:main "qsp-main") | |
64 | (:stat "qsp-stat") |
|
85 | (:stat "qsp-stat") | |
|
86 | (:objs "qsp-objs") | |||
|
87 | (:acts "qsp-acts") | |||
|
88 | (:input "qsp-input") | |||
|
89 | (:dropdown "qsp-dropdown") | |||
65 | (t (report-error "Internal error!")))) |
|
90 | (t (report-error "Internal error!")))) | |
66 |
|
91 | |||
|
92 | (defm (root api get-frame) (key) | |||
|
93 | (document.get-element-by-id (api-call key-to-id key))) | |||
|
94 | ||||
67 | (defm (root api add-text) (key text) |
|
95 | (defm (root api add-text) (key text) | |
68 | (api-call append-id (api-call key-to-id key) text)) |
|
96 | (api-call append-id (api-call key-to-id key) text)) | |
69 |
|
97 | |||
70 | (defm (root api get-text) (key) |
|
98 | (defm (root api get-text) (key) | |
71 | (api-call get-id (api-call key-to-id key))) |
|
99 | (api-call get-id (api-call key-to-id key))) | |
72 |
|
100 | |||
73 | (defm (root api clear-text) (key) |
|
101 | (defm (root api clear-text) (key) | |
74 | (api-call clear-id (api-call key-to-id key))) |
|
102 | (api-call clear-id (api-call key-to-id key))) | |
75 |
|
103 | |||
76 | (defm (root api newline) (key) |
|
104 | (defm (root api newline) (key) | |
77 | (let ((div (document.get-element-by-id |
|
105 | (let ((div (api-call get-frame key))) | |
78 | (api-call key-to-id key)))) |
|
|||
79 | (ps:chain div (append-child (document.create-element "br"))))) |
|
106 | (ps:chain div (append-child (document.create-element "br"))))) | |
80 |
|
107 | |||
|
108 | (defm (root api enable-frame) (key enable) | |||
|
109 | (let ((clss (ps:getprop (api-call get-frame key) 'class-list))) | |||
|
110 | (setf clss.style.display (if enable "block" "none")) | |||
|
111 | (values))) | |||
|
112 | ||||
81 | ;;; Actions |
|
113 | ;;; Actions | |
82 |
|
114 | |||
83 | (defm (root api add-act) (title img act) |
|
115 | (defm (root api add-act) (title img act) | |
84 | (setf (ps:getprop (root acts) title) |
|
116 | (setf (ps:getprop (root acts) title) | |
85 |
(ps:create :img img :act act)) |
|
117 | (ps:create :img img :act act)) | |
|
118 | (api-call update-acts)) | |||
86 |
|
119 | |||
87 | (defm (root api del-act) (title) |
|
120 | (defm (root api del-act) (title) | |
88 | (delete (ps:getprop (root acts) title)) |
|
121 | (delete (ps:getprop (root acts) title)) | |
89 | (api-call update-acts)) |
|
122 | (api-call update-acts)) | |
90 |
|
123 | |||
91 | (defm (root api clear-act) () |
|
124 | (defm (root api clear-act) () | |
92 | (setf (root acts) (ps:create)) |
|
125 | (setf (root acts) (ps:create)) | |
93 | (api-call clear-id "qsp-acts")) |
|
126 | (api-call clear-id "qsp-acts")) | |
94 |
|
127 | |||
95 | (defm (root api update-acts) () |
|
128 | (defm (root api update-acts) () | |
96 | (api-call clear-id "qsp-acts") |
|
129 | (api-call clear-id "qsp-acts") | |
97 | (ps:for-in (title (root acts)) |
|
130 | (ps:for-in (title (root acts)) | |
98 | (let ((obj (ps:getprop (root acts) title))) |
|
131 | (let ((obj (ps:getprop (root acts) title))) | |
99 | (api-call append-id "qsp-acts" |
|
132 | (api-call append-id "qsp-acts" | |
100 | (api-call make-act-html title (ps:getprop obj :img)))))) |
|
133 | (api-call make-act-html title (ps:getprop obj :img)))))) | |
101 |
|
134 | |||
102 | ;;; Variables |
|
135 | ;;; Variables | |
103 |
|
136 | |||
104 | (defm (root api var-slot) (name) |
|
137 | (defm (root api var-slot) (name) | |
105 | (if (= (ps:@ name 0) #\$) |
|
138 | (if (= (ps:@ name 0) #\$) | |
106 | :str |
|
139 | :str | |
107 | :num)) |
|
140 | :num)) | |
108 |
|
141 | |||
109 | (defm (root api var-real-name) (name) |
|
142 | (defm (root api var-real-name) (name) | |
110 | (if (= (ps:@ name 0) #\$) |
|
143 | (if (= (ps:@ name 0) #\$) | |
111 | (ps:chain name (substr 1)) |
|
144 | (ps:chain name (substr 1)) | |
112 | name)) |
|
145 | name)) | |
113 |
|
146 | |||
114 | (defm (root api ensure-var) (name index) |
|
147 | (defm (root api ensure-var) (name index) | |
115 | (unless (in name (root vars)) |
|
148 | (unless (in name (root vars)) | |
116 | (setf (ps:getprop (root vars) name) |
|
149 | (setf (ps:getprop (root vars) name) | |
117 | (ps:create))) |
|
150 | (ps:create))) | |
118 | (unless (in index (ps:getprop (root vars) name)) |
|
151 | (unless (in index (ps:getprop (root vars) name)) | |
119 | (setf (ps:getprop (root vars) name index) |
|
152 | (setf (ps:getprop (root vars) name index) | |
120 | (ps:create :num 0 :str ""))) |
|
153 | (ps:create :num 0 :str ""))) | |
121 | (values)) |
|
154 | (values)) | |
122 |
|
155 | |||
123 | (defm (root api get-var) (name index) |
|
156 | (defm (root api get-var) (name index) | |
124 | (let ((var-name (api-call var-real-name name))) |
|
157 | (let ((var-name (api-call var-real-name name))) | |
125 | (api-call ensure-var var-name index) |
|
158 | (api-call ensure-var var-name index) | |
126 | (ps:getprop (root vars) var-name index |
|
159 | (ps:getprop (root vars) var-name index | |
127 | (api-call var-slot name)))) |
|
160 | (api-call var-slot name)))) | |
128 |
|
161 | |||
129 | (defm (root api set-var) (name index value) |
|
162 | (defm (root api set-var) (name index value) | |
130 | (let ((var-name (api-call var-real-name name))) |
|
163 | (let ((var-name (api-call var-real-name name))) | |
131 | (api-call ensure-var var-name index) |
|
164 | (api-call ensure-var var-name index) | |
132 | (setf (ps:getprop (root vars) var-name index |
|
165 | (setf (ps:getprop (root vars) var-name index | |
133 | (api-call var-slot name)) |
|
166 | (api-call var-slot name)) | |
134 | value) |
|
167 | value) | |
135 | (values))) |
|
168 | (values))) | |
136 |
|
169 | |||
|
170 | (defm (root api get-array) (name type) | |||
|
171 | (ps:getprop (root vars) (api-call var-real-name name))) | |||
|
172 | ||||
137 | (defm (root api kill-var) (name index) |
|
173 | (defm (root api kill-var) (name index) | |
138 | (if (eq index :whole) |
|
174 | (if (eq index :whole) | |
139 | (ps:delete (ps:getprop (root vars) name)) |
|
175 | (ps:delete (ps:getprop (root vars) name)) | |
140 | (ps:delete (ps:getprop (root vars) name index))) |
|
176 | (ps:delete (ps:getprop (root vars) name index))) | |
141 | (values)) |
|
177 | (values)) | |
142 |
|
178 | |||
|
179 | (defm (root api array-size) (name) | |||
|
180 | (ps:getprop (root vars) (api-call var-real-name name) 'length)) | |||
|
181 | ||||
143 | ;;; Objects |
|
182 | ;;; Objects | |
144 |
|
183 | |||
145 | (defm (root api update-objs) () |
|
184 | (defm (root api update-objs) () | |
146 | (let ((elt (document.get-element-by-id "qsp-objs"))) |
|
185 | (let ((elt (document.get-element-by-id "qsp-objs"))) | |
147 | (setf elt.inner-h-t-m-l "<ul>") |
|
186 | (setf elt.inner-h-t-m-l "<ul>") | |
148 | (loop :for obj :in (root objs) |
|
187 | (loop :for obj :in (root objs) | |
149 | :do (incf elt.inner-h-t-m-l (+ "<li>" obj))) |
|
188 | :do (incf elt.inner-h-t-m-l (+ "<li>" obj))) | |
150 | (incf elt.inner-h-t-m-l "</ul>"))) |
|
189 | (incf elt.inner-h-t-m-l "</ul>"))) | |
|
190 | ||||
|
191 | ;;; Menu | |||
|
192 | ||||
|
193 | (defm (root api menu) (menu-data) | |||
|
194 | (let ((elt (document.get-element-by-id "qsp-dropdown")) | |||
|
195 | (i 0)) | |||
|
196 | (setf elt.inner-h-t-m-l "") | |||
|
197 | (loop :for item :in menu-data | |||
|
198 | :do (incf i) | |||
|
199 | :do (incf elt.inner-h-t-m-l (api-call make-menu-item-html i item.text item.icon item.loc))) | |||
|
200 | (setf elt.style.display "block"))) |
@@ -1,299 +1,313 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 &rest args) |
|
12 | (defm (root lib goto) (target &rest args) | |
13 | (api-call clear-text :main) |
|
13 | (api-call clear-text :main) | |
14 | (apply (root lib xgoto) target args)) |
|
14 | (apply (root lib xgoto) target args)) | |
15 |
|
15 | |||
16 | (defm (root lib xgoto) (target &rest args) |
|
16 | (defm (root lib xgoto) (target &rest args) | |
17 | (api-call clear-act) |
|
17 | (api-call clear-act) | |
18 | (api-call init-args args) |
|
18 | (api-call init-args args) | |
19 | (setf (root current-location) target) |
|
19 | (setf (root current-location) (ps:chain target (to-upper-case))) | |
20 | (api-call stash-state) |
|
20 | (api-call stash-state) | |
21 | (funcall (ps:getprop (root locations) (ps:chain target (to-upper-case))))) |
|
21 | (funcall (ps:getprop (root locs) (root current-location)))) | |
22 |
|
22 | |||
23 | ;;; 2var |
|
23 | ;;; 2var | |
24 |
|
24 | |||
25 | (defm (root lib killvar) (varname &optional (index :whole)) |
|
|||
26 | (api-call kill-var varname index)) |
|
|||
27 |
|
||||
28 | (defm (root lib killall) () |
|
|||
29 | (api-call kill-all)) |
|
|||
30 |
|
||||
31 | ;;; 3expr |
|
25 | ;;; 3expr | |
32 |
|
26 | |||
33 | (defm (root lib obj) (name) |
|
|||
34 | (funcall (root objs includes) name)) |
|
|||
35 |
|
||||
36 | (defm (root lib loc) () |
|
|||
37 | (funcall (root locations includes) name)) |
|
|||
38 |
|
||||
39 | (defm (root lib no) (arg) |
|
|||
40 | (- -1 arg)) |
|
|||
41 |
|
||||
42 | ;;; 4code |
|
27 | ;;; 4code | |
43 |
|
28 | |||
44 |
(defm (root lib |
|
29 | (defm (root lib rand) (a &optional (b 1)) | |
45 | "0.0.1") |
|
|||
46 |
|
||||
47 | (defm (root lib curloc) () |
|
|||
48 | (root current-location)) |
|
|||
49 |
|
||||
50 | (defm (root lib rand) (a b) |
|
|||
51 | (let ((min (min a b)) |
|
30 | (let ((min (min a b)) | |
52 | (max (max a b))) |
|
31 | (max (max a b))) | |
53 | (+ min (ps:chain *math (random (- max min)))))) |
|
32 | (+ min (ps:chain *math (random (- max min)))))) | |
54 |
|
33 | |||
55 | (defm (root lib rnd) () |
|
|||
56 | (funcall (root lib rand) 1 1000)) |
|
|||
57 |
|
||||
58 | (defm (root lib qspmax) (&rest args) |
|
|||
59 | (apply (ps:@ *math max) args)) |
|
|||
60 |
|
||||
61 | (defm (root lib qspmin) (&rest args) |
|
|||
62 | (apply (ps:@ *math min) args)) |
|
|||
63 |
|
||||
64 | ;;; 5arrays |
|
34 | ;;; 5arrays | |
65 |
|
35 | |||
66 | (defm (root lib copyarr) (to from start count) |
|
36 | (defm (root lib copyarr) (to from start count) | |
67 | (ps:for ((i start)) |
|
37 | (ps:for ((i start)) | |
68 | ((< i (min (api-call array-size from) |
|
38 | ((< i (min (api-call array-size from) | |
69 | (+ start count)))) |
|
39 | (+ start count)))) | |
70 | ((incf i)) |
|
40 | ((incf i)) | |
71 | (api-call set-var to (+ start i) |
|
41 | (api-call set-var to (+ start i) | |
72 | (api-call get-var from (+ start i))))) |
|
42 | (api-call get-var from (+ start i))))) | |
73 |
|
43 | |||
74 | (defm (root lib arrsize) (name) |
|
|||
75 | (api-call array-size name)) |
|
|||
76 |
|
||||
77 | (defm (root lib arrpos) (name value &optional (start 0)) |
|
44 | (defm (root lib arrpos) (name value &optional (start 0)) | |
78 | (ps:for ((i start)) ((< i (api-call array-size name))) ((incf i)) |
|
45 | (ps:for ((i start)) ((< i (api-call array-size name))) ((incf i)) | |
79 | (when (eq (api-call get-var name i) value) |
|
46 | (when (eq (api-call get-var name i) value) | |
80 | (return i))) |
|
47 | (return i))) | |
81 | -1) |
|
48 | -1) | |
82 |
|
49 | |||
83 | (defm (root lib arrcomp) (name pattern &optional (start 0)) |
|
50 | (defm (root lib arrcomp) (name pattern &optional (start 0)) | |
84 | (ps:for ((i start)) ((< i (api-call array-size name))) ((incf i)) |
|
51 | (ps:for ((i start)) ((< i (api-call array-size name))) ((incf i)) | |
85 | (when (funcall (ps:getprop (api-call get-var name i) 'match) pattern) |
|
52 | (when (funcall (ps:getprop (api-call get-var name i) 'match) pattern) | |
86 | (return i))) |
|
53 | (return i))) | |
87 | -1) |
|
54 | -1) | |
88 |
|
55 | |||
89 | ;;; 6str |
|
56 | ;;; 6str | |
90 |
|
57 | |||
91 | (defm (root lib len) (s) |
|
|||
92 | (length s)) |
|
|||
93 |
|
||||
94 | (defm (root lib mid) (s from &optional count) |
|
|||
95 | (s.substring from count)) |
|
|||
96 |
|
||||
97 | (defm (root lib ucase) (s) |
|
|||
98 | (s.to-upper-case)) |
|
|||
99 |
|
||||
100 | (defm (root lib lcase) (s) |
|
|||
101 | (s.to-lower-case)) |
|
|||
102 |
|
||||
103 | (defm (root lib trim) (s) |
|
|||
104 | (s.trim)) |
|
|||
105 |
|
||||
106 | (defm (root lib replace) (s from to) |
|
|||
107 | (s.replace from to)) |
|
|||
108 |
|
||||
109 | (defm (root lib instr) (s subs &optional (start 1)) |
|
58 | (defm (root lib instr) (s subs &optional (start 1)) | |
110 | (+ start (ps:chain s (substring (- start 1)) (search subs)))) |
|
59 | (+ start (ps:chain s (substring (- start 1)) (search subs)))) | |
111 |
|
60 | |||
112 | (defm (root lib isnum) (s) |
|
61 | (defm (root lib isnum) (s) | |
113 | (if (is-na-n s) |
|
62 | (if (is-na-n s) | |
114 | 0 |
|
63 | 0 | |
115 | -1)) |
|
64 | -1)) | |
116 |
|
65 | |||
117 | (defm (root lib val) (s) |
|
|||
118 | (parse-int s 10)) |
|
|||
119 |
|
||||
120 | (defm (root lib qspstr) (n) |
|
|||
121 | (+ "" n)) |
|
|||
122 |
|
||||
123 | (defm (root lib strcomp) (s pattern) |
|
66 | (defm (root lib strcomp) (s pattern) | |
124 | (if (s.match pattern) |
|
67 | (if (s.match pattern) | |
125 | -1 |
|
68 | -1 | |
126 | 0)) |
|
69 | 0)) | |
127 |
|
70 | |||
128 | (defm (root lib strfind) (s pattern group) |
|
71 | (defm (root lib strfind) (s pattern group) | |
129 | (let* ((re (ps:new (*reg-exp pattern))) |
|
72 | (let* ((re (ps:new (*reg-exp pattern))) | |
130 | (match (re.exec s))) |
|
73 | (match (re.exec s))) | |
131 | (match.group group))) |
|
74 | (match.group group))) | |
132 |
|
75 | |||
133 | (defm (root lib strpos) (s pattern &optional (group 0)) |
|
76 | (defm (root lib strpos) (s pattern &optional (group 0)) | |
134 | (let* ((re (ps:new (*reg-exp pattern))) |
|
77 | (let* ((re (ps:new (*reg-exp pattern))) | |
135 | (match (re.exec s)) |
|
78 | (match (re.exec s)) | |
136 | (found (match.group group))) |
|
79 | (found (match.group group))) | |
137 | (if found |
|
80 | (if found | |
138 | (s.search found) |
|
81 | (s.search found) | |
139 | 0))) |
|
82 | 0))) | |
140 |
|
83 | |||
141 | ;;; 7if |
|
84 | ;;; 7if | |
142 |
|
85 | |||
|
86 | ;; Has to be a function because it always evaluates all three of its | |||
|
87 | ;; arguments | |||
143 | (defm (root lib iif) (cond-expr then-expr else-expr) |
|
88 | (defm (root lib iif) (cond-expr then-expr else-expr) | |
144 |
(if |
|
89 | (if cond-expr then-expr else-expr)) | |
145 |
|
90 | |||
146 | ;;; 8sub |
|
91 | ;;; 8sub | |
147 |
|
92 | |||
148 | (defm (root lib gosub) (target &rest args) |
|
93 | (defm (root lib gosub) (target &rest args) | |
149 | (conserving-vars (args result) |
|
94 | (conserving-vars (args result) | |
150 | (api-call init-args args) |
|
95 | (api-call init-args args) | |
151 |
(funcall (ps:getprop (root loc |
|
96 | (funcall (ps:getprop (root locs) target)) | |
152 | (values))) |
|
97 | (values))) | |
153 |
|
98 | |||
154 | (defm (root lib func) (target &rest args) |
|
99 | (defm (root lib func) (target &rest args) | |
155 | (conserving-vars (args result) |
|
100 | (conserving-vars (args result) | |
156 | (api-call init-args args) |
|
101 | (api-call init-args args) | |
157 |
(funcall (ps:getprop (root loc |
|
102 | (funcall (ps:getprop (root locs) target)) | |
158 | (api-call get-result))) |
|
103 | (api-call get-result))) | |
159 |
|
104 | |||
160 | ;;; 9loops |
|
105 | ;;; 9loops | |
161 |
|
106 | |||
162 | ;;; 10dynamic |
|
107 | ;;; 10dynamic | |
163 |
|
108 | |||
164 | (defm (root lib dyneval) (block &rest args) |
|
109 | (defm (root lib dyneval) (block &rest args) | |
165 | (conserving-vars (args result) |
|
110 | (conserving-vars (args result) | |
166 | (api-call init-args args) |
|
111 | (api-call init-args args) | |
167 | (funcall block) |
|
112 | (funcall block) | |
168 | (api-call get-result))) |
|
113 | (api-call get-result))) | |
169 |
|
114 | |||
170 | (defm (root lib dynamic) (&rest args) |
|
115 | (defm (root lib dynamic) (&rest args) | |
171 | (conserving-vars (args result) |
|
116 | (conserving-vars (args result) | |
172 | (api-call init-args args) |
|
117 | (api-call init-args args) | |
173 | (funcall block) |
|
118 | (funcall block) | |
174 | (values))) |
|
119 | (values))) | |
175 |
|
120 | |||
176 | ;;; 11main |
|
121 | ;;; 11main | |
177 |
|
122 | |||
178 | (defm (root lib main-p) (s) |
|
123 | (defm (root lib main-p) (s) | |
179 |
(api-call add-text :main s) |
|
124 | (api-call add-text :main s) | |
|
125 | (values)) | |||
180 |
|
126 | |||
181 | (defm (root lib main-pl) (s) |
|
127 | (defm (root lib main-pl) (s) | |
182 | (api-call add-text :main s) |
|
128 | (api-call add-text :main s) | |
183 |
(api-call newline :main) |
|
129 | (api-call newline :main) | |
|
130 | (values)) | |||
184 |
|
131 | |||
185 | (defm (root lib main-nl) (s) |
|
132 | (defm (root lib main-nl) (s) | |
186 | (api-call newline :main) |
|
133 | (api-call newline :main) | |
187 |
(api-call add-text :main s) |
|
134 | (api-call add-text :main s) | |
|
135 | (values)) | |||
188 |
|
136 | |||
189 | (defm (root lib maintxt) (s) |
|
137 | (defm (root lib maintxt) (s) | |
190 |
(api-call get-text :main) |
|
138 | (api-call get-text :main) | |
|
139 | (values)) | |||
191 |
|
140 | |||
|
141 | ;; For clarity (it leaves a lib.desc() call in JS) | |||
192 | (defm (root lib desc) (s) |
|
142 | (defm (root lib desc) (s) | |
193 | "") |
|
143 | "") | |
194 |
|
144 | |||
195 | (defm (root lib main-clear) () |
|
145 | (defm (root lib main-clear) () | |
196 |
(api-call clear-text :main) |
|
146 | (api-call clear-text :main) | |
|
147 | (values)) | |||
197 |
|
148 | |||
198 | ;;; 12stat |
|
149 | ;;; 12stat | |
199 |
|
150 | |||
200 |
(defm (root lib s |
|
151 | (defm (root lib stat-p) (s) | |
|
152 | (api-call add-text :stat s) | |||
|
153 | (values)) | |||
201 |
|
154 | |||
202 |
(defm (root lib stat-p) ( |
|
155 | (defm (root lib stat-pl) (s) | |
|
156 | (api-call add-text :stat s) | |||
|
157 | (api-call newline :stat) | |||
|
158 | (values)) | |||
203 |
|
159 | |||
204 |
(defm (root lib stat- |
|
160 | (defm (root lib stat-nl) (s) | |
|
161 | (api-call newline :stat) | |||
|
162 | (api-call add-text :stat s) | |||
|
163 | (values)) | |||
205 |
|
164 | |||
206 |
(defm (root lib stat |
|
165 | (defm (root lib stattxt) (s) | |
207 |
|
166 | (api-call get-text :stat) | ||
208 | (defm (root lib stattxt) ()) |
|
167 | (values)) | |
209 |
|
168 | |||
210 |
(defm (root lib clear) () |
|
169 | (defm (root lib stat-clear) () | |
|
170 | (api-call clear-text :stat) | |||
|
171 | (values)) | |||
211 |
|
172 | |||
212 |
(defm (root lib cls) () |
|
173 | (defm (root lib cls) () | |
|
174 | (funcall (root lib stat-clear)) | |||
|
175 | (funcall (root lib main-clear)) | |||
|
176 | (funcall (root lib cla)) | |||
|
177 | (funcall (root lib cmdclear)) | |||
|
178 | (values)) | |||
213 |
|
179 | |||
214 | ;;; 13diag |
|
180 | ;;; 13diag | |
215 |
|
181 | |||
216 | (defm (root lib msg) ()) |
|
|||
217 |
|
||||
218 | ;;; 14act |
|
182 | ;;; 14act | |
219 |
|
183 | |||
220 |
(defm (root lib |
|
184 | (defm (root lib curacts) () | |
221 |
|
185 | (let ((acts (root acts))) | ||
222 | (defm (root lib delact) (name) |
|
186 | (lambda () | |
223 | (api-call del-act name)) |
|
187 | (setf (root acts) acts) | |
224 |
|
188 | (values)))) | ||
225 | (defm (root lib curacts) ()) |
|
|||
226 |
|
||||
227 | (defm (root lib cla) ()) |
|
|||
228 |
|
189 | |||
229 | ;;; 15objs |
|
190 | ;;; 15objs | |
230 |
|
191 | |||
231 | (defm (root lib showobjs) ()) |
|
|||
232 |
|
||||
233 | (defm (root lib addobj) (name) |
|
192 | (defm (root lib addobj) (name) | |
234 | (ps:chain (root objs) (push name)) |
|
193 | (ps:chain (root objs) (push name)) | |
235 |
(api-call update-objs) |
|
194 | (api-call update-objs) | |
|
195 | (values)) | |||
236 |
|
196 | |||
237 | (defm (root lib delobj) (name) |
|
197 | (defm (root lib delobj) (name) | |
238 | (let ((index (ps:chain (root objs) (index-of name)))) |
|
198 | (let ((index (ps:chain (root objs) (index-of name)))) | |
239 | (when (> index -1) |
|
199 | (when (> index -1) | |
240 |
( |
|
200 | (funcall (root lib killobj) index))) | |
241 | (api-call update-objs)) |
|
201 | (values)) | |
242 |
|
202 | |||
243 |
(defm (root lib killobj) ( |
|
203 | (defm (root lib killobj) (&optional num) | |
244 |
|
204 | (if num | ||
245 | (defm (root lib countobj) ()) |
|
205 | (ps:chain (root objs) (splice (1+ num) 1)) | |
246 |
|
206 | (setf (root objs) (list))) | ||
247 | (defm (root lib getobj) ()) |
|
207 | (api-call update-objs) | |
|
208 | (values)) | |||
248 |
|
209 | |||
249 | ;;; 16menu |
|
210 | ;;; 16menu | |
250 |
|
211 | |||
251 |
(defm (root lib menu) ( |
|
212 | (defm (root lib menu) (menu-name) | |
|
213 | (let ((menu-data (list))) | |||
|
214 | (loop :for item :in (api-call get-array menu-name) | |||
|
215 | :do (cond ((string= item "") | |||
|
216 | (break)) | |||
|
217 | ((string= item "-:-") | |||
|
218 | (ps:chain menu-data (push :delimiter))) | |||
|
219 | (t | |||
|
220 | (let* ((tokens (ps:chain item (split ":")))) | |||
|
221 | (when (= (length tokens) 2) | |||
|
222 | (tokens.push "")) | |||
|
223 | (let* ((text (ps:chain tokens (splice 0 (- tokens.length 2)) (join ":"))) | |||
|
224 | (loc (ps:getprop tokens (- tokens.length 2))) | |||
|
225 | (icon (ps:getprop tokens (- tokens.length 1)))) | |||
|
226 | (ps:chain menu-data | |||
|
227 | (push (ps:create text text | |||
|
228 | loc loc | |||
|
229 | icon icon)))))))) | |||
|
230 | (api-call menu menu-data) | |||
|
231 | (values))) | |||
252 |
|
232 | |||
253 | ;;; 17sound |
|
233 | ;;; 17sound | |
254 |
|
234 | |||
255 | (defm (root lib play) ()) |
|
235 | (defm (root lib play) ()) | |
256 |
|
236 | |||
257 | (defm (root lib isplay) ()) |
|
237 | (defm (root lib isplay) ()) | |
258 |
|
238 | |||
259 | (defm (root lib close) ()) |
|
239 | (defm (root lib close) ()) | |
260 |
|
240 | |||
261 | (defm (root lib closeall) ()) |
|
241 | (defm (root lib closeall) ()) | |
262 |
|
242 | |||
263 | ;;; 18img |
|
243 | ;;; 18img | |
264 |
|
244 | |||
265 | (defm (root lib refint) ()) |
|
245 | (defm (root lib refint) ()) | |
266 |
|
246 | |||
267 | (defm (root lib view) ()) |
|
247 | (defm (root lib view) ()) | |
268 |
|
248 | |||
269 | ;;; 19input |
|
249 | ;;; 19input | |
270 |
|
250 | |||
271 | (defm (root lib showinput) ()) |
|
251 | (defm (root lib showinput) ()) | |
272 |
|
252 | |||
273 | (defm (root lib usertxt) ()) |
|
253 | (defm (root lib usertxt) ()) | |
274 |
|
254 | |||
275 | (defm (root lib cmdclear) ()) |
|
255 | (defm (root lib cmdclear) ()) | |
276 |
|
256 | |||
277 | (defm (root lib input) ()) |
|
257 | (defm (root lib input) ()) | |
278 |
|
258 | |||
279 | ;;; 20time |
|
259 | ;;; 20time | |
280 |
|
260 | |||
281 | (defm (root lib wait) ()) |
|
261 | ;; I wonder if there's a better solution than busy-wait | |
|
262 | (defm (root lib wait) (msec) | |||
|
263 | (let* ((now (ps:new (*date))) | |||
|
264 | (exit-time (+ (funcall now.get-time) msec))) | |||
|
265 | (loop :while (< (funcall now.get-time) exit-time)))) | |||
282 |
|
266 | |||
283 | (defm (root lib msecscount) ()) |
|
267 | (defm (root lib msecscount) ()) | |
284 |
|
268 | |||
285 | (defm (root lib settimer) ()) |
|
269 | (defm (root lib settimer) ()) | |
286 |
|
270 | |||
287 | ;;; misc |
|
271 | ;;; misc | |
288 |
|
272 | |||
289 | (defm (root lib rgb) ()) |
|
273 | (defm (root lib rgb) ()) | |
290 |
|
274 | |||
291 | (defm (root lib openqst) ()) |
|
275 | (defm (root lib openqst) ()) | |
292 |
|
276 | |||
293 | (defm (root lib addqst) ()) |
|
277 | (defm (root lib addqst) ()) | |
294 |
|
278 | |||
295 | (defm (root lib killqst) ()) |
|
279 | (defm (root lib killqst) ()) | |
296 |
|
280 | |||
297 |
(defm (root lib opengame) ( |
|
281 | (defm (root lib opengame) (&optional filename) | |
|
282 | (let ((element (document.create-element :input))) | |||
|
283 | (element.set-attribute :type :file) | |||
|
284 | (element.set-attribute :id :qsp-opengame) | |||
|
285 | (element.set-attribute :tabindex -1) | |||
|
286 | (element.set-attribute "aria-hidden" t) | |||
|
287 | (setf element.style.display :block) | |||
|
288 | (setf element.style.visibility :hidden) | |||
|
289 | (setf element.style.position :fixed) | |||
|
290 | (setf element.onchange | |||
|
291 | (lambda (event) | |||
|
292 | (let* ((file (elt event.target.files 0)) | |||
|
293 | (reader (ps:new (*file-reader)))) | |||
|
294 | (setf reader.onload | |||
|
295 | (lambda (ev) | |||
|
296 | (block nil | |||
|
297 | (let ((target ev.current-target)) | |||
|
298 | (unless target.result | |||
|
299 | (return)) | |||
|
300 | (api-call base64-to-state target.result))))) | |||
|
301 | (reader.read-as-text file)))) | |||
|
302 | (document.body.append-child element) | |||
|
303 | (element.click) | |||
|
304 | (document.body.remove-child element))) | |||
298 |
|
305 | |||
299 |
(defm (root lib savegame) ( |
|
306 | (defm (root lib savegame) (&optional filename) | |
|
307 | (let ((element (document.create-element :a))) | |||
|
308 | (element.set-attribute :href (+ "data:text/plain;charset=utf-8," (api-call state-to-base64))) | |||
|
309 | (element.set-attribute :download "savegame.sav") | |||
|
310 | (setf element.style.display :none) | |||
|
311 | (document.body.append-child element) | |||
|
312 | (element.click) | |||
|
313 | (document.body.remove-child element))) |
@@ -1,172 +1,153 b'' | |||||
1 |
|
1 | |||
2 | (in-package sugar-qsp) |
|
2 | (in-package sugar-qsp) | |
3 |
|
3 | |||
4 | (defun entry-point-no-args () |
|
4 | (defun entry-point-no-args () | |
5 | (entry-point uiop:*command-line-arguments*)) |
|
5 | (entry-point uiop:*command-line-arguments*)) | |
6 |
|
6 | |||
7 | (defun entry-point (args) |
|
7 | (defun entry-point (args) | |
8 | (catch :terminate |
|
8 | (catch :terminate | |
9 | (let ((compiler (apply #'make-instance 'compiler (parse-opts args)))) |
|
9 | (let ((compiler (apply #'make-instance 'compiler (parse-opts args)))) | |
10 | (write-compiled-file compiler))) |
|
10 | (write-compiled-file compiler))) | |
11 | (values)) |
|
11 | (values)) | |
12 |
|
12 | |||
13 | (defun parse-opts (args) |
|
13 | (defun parse-opts (args) | |
14 | (let ((mode :source) |
|
14 | (let ((mode :source) | |
15 | (data (list :source nil :target nil :js nil :css nil :body nil :compile nil :beautify nil))) |
|
15 | (data (list :source nil :target nil :js nil :css nil :body nil :compile nil :beautify nil))) | |
16 | (loop :for arg :in args |
|
16 | (loop :for arg :in args | |
17 | :do (alexandria:switch (arg :test #'string=) |
|
17 | :do (alexandria:switch (arg :test #'string=) | |
18 | ("-o" (setf mode :target)) |
|
18 | ("-o" (setf mode :target)) | |
19 | ("--js" (setf mode :js)) |
|
19 | ("--js" (setf mode :js)) | |
20 | ("--css" (setf mode :css)) |
|
20 | ("--css" (setf mode :css)) | |
21 | ("--body" (setf mode :body)) |
|
21 | ("--body" (setf mode :body)) | |
22 | ("-c" (setf (getf data :compile) t)) |
|
22 | ("-c" (setf (getf data :compile) t)) | |
23 | ("--beautify" (setf (getf data :beautify) t)) |
|
23 | ("--beautify" (setf (getf data :beautify) t)) | |
24 | (t (push arg (getf data mode))))) |
|
24 | (t (push arg (getf data mode))))) | |
25 | (unless (= 1 (length (getf data :source))) |
|
25 | (unless (= 1 (length (getf data :source))) | |
26 | (print-usage) |
|
26 | (print-usage) | |
27 | (report-error "There should be exactly one source")) |
|
27 | (report-error "There should be exactly one source")) | |
28 | (unless (> 1 (length (getf data :target))) |
|
28 | (unless (> 1 (length (getf data :target))) | |
29 | (print-usage) |
|
29 | (print-usage) | |
30 | (report-error "There should be no more than one target")) |
|
30 | (report-error "There should be no more than one target")) | |
31 | (unless (> 1 (length (getf data :body))) |
|
31 | (unless (> 1 (length (getf data :body))) | |
32 | (print-usage) |
|
32 | (print-usage) | |
33 | (report-error "There should be no more than one body")) |
|
33 | (report-error "There should be no more than one body")) | |
34 | (unless (getf data :target) |
|
34 | (unless (getf data :target) | |
35 | (setf (getf data :target) |
|
35 | (setf (getf data :target) | |
36 | (let* ((source (first (getf data :source))) |
|
36 | (let* ((source (first (getf data :source))) | |
37 | (tokens (uiop:split-string source :separator ".")) |
|
37 | (tokens (uiop:split-string source :separator ".")) | |
38 | (target (format nil "~{~A~^.~}.html" |
|
38 | (target (format nil "~{~A~^.~}.html" | |
39 | (butlast tokens)))) |
|
39 | (butlast tokens)))) | |
40 | (list target)))) |
|
40 | (list target)))) | |
41 | (list :source (first (getf data :source)) |
|
41 | (list :source (first (getf data :source)) | |
42 | :target (first (getf data :target)) |
|
42 | :target (first (getf data :target)) | |
43 | :js (getf data :js) |
|
43 | :js (getf data :js) | |
44 | :css (getf data :css) |
|
44 | :css (getf data :css) | |
45 | :body (first (getf data :body)) |
|
45 | :body (first (getf data :body)) | |
46 | :compile (getf data :compile) |
|
46 | :compile (getf data :compile) | |
47 | :beautify (getf data :beautify)))) |
|
47 | :beautify (getf data :beautify)))) | |
48 |
|
48 | |||
49 | (defun print-usage () |
|
49 | (defun print-usage () | |
50 | (format t "USAGE: ")) |
|
50 | (format t "USAGE: ")) | |
51 |
|
51 | |||
52 | (defun parse-file (filename) |
|
52 | (defun parse-file (filename) | |
53 | (p:parse 'sugar-qsp-grammar |
|
53 | (p:parse 'sugar-qsp-grammar | |
54 | (alexandria:read-file-into-string filename))) |
|
54 | (alexandria:read-file-into-string filename))) | |
55 |
|
55 | |||
56 | (defun make-javascript (locations) |
|
56 | (defun make-javascript (locations) | |
57 | (format nil "~{~A~^~%~%~}" |
|
57 | (format nil "////// THE GAME STARTS HERE~%~%~{~A~^~%~%~}" | |
58 | (mapcar #'ps:ps* locations))) |
|
58 | (mapcar #'ps:ps* locations))) | |
59 |
|
59 | |||
60 | (defun uglify-js::write-json-chars (quote s stream) |
|
60 | (defun uglify-js::write-json-chars (quote s stream) | |
61 | "Write JSON representations (chars or escape sequences) of |
|
61 | "Write JSON representations (chars or escape sequences) of | |
62 | characters in string S to STREAM. |
|
62 | characters in string S to STREAM. | |
63 | Monkey-patched to output plain utf-8 instead of escape-sequences." |
|
63 | Monkey-patched to output plain utf-8 instead of escape-sequences." | |
64 | (write-char quote stream) |
|
64 | (write-char quote stream) | |
65 | (loop :for ch :across s |
|
65 | (loop :for ch :across s | |
66 | :for code := (char-code ch) |
|
66 | :for code := (char-code ch) | |
67 | :with special |
|
67 | :with special | |
68 | :do (cond ((eq ch quote) |
|
68 | :do (cond ((eq ch quote) | |
69 | (write-char #\\ stream) (write-char ch stream)) |
|
69 | (write-char #\\ stream) (write-char ch stream)) | |
70 | ((setq special (car (rassoc ch uglify-js::+json-lisp-escaped-chars+))) |
|
70 | ((setq special (car (rassoc ch uglify-js::+json-lisp-escaped-chars+))) | |
71 | (write-char #\\ stream) (write-char special stream)) |
|
71 | (write-char #\\ stream) (write-char special stream)) | |
72 | (t |
|
72 | (t | |
73 | (write-char ch stream)))) |
|
73 | (write-char ch stream)))) | |
74 | (write-char quote stream)) |
|
74 | (write-char quote stream)) | |
75 |
|
75 | |||
76 | (defun preprocess-js (js beautify) |
|
76 | (defun preprocess-js (js beautify) | |
77 | (if beautify |
|
77 | (if beautify | |
78 | (cl-uglify-js:ast-gen-code |
|
78 | (cl-uglify-js:ast-gen-code | |
79 | (cl-uglify-js:ast-squeeze |
|
79 | (cl-uglify-js:ast-squeeze | |
80 | (parse-js:parse-js js) |
|
80 | (parse-js:parse-js js) | |
81 | :sequences nil) |
|
81 | :sequences nil) | |
82 | :beautify t) |
|
82 | :beautify t) | |
83 | (cl-uglify-js:ast-gen-code |
|
83 | (cl-uglify-js:ast-gen-code | |
84 | (cl-uglify-js:ast-mangle |
|
84 | (cl-uglify-js:ast-mangle | |
85 | (cl-uglify-js:ast-squeeze |
|
85 | (cl-uglify-js:ast-squeeze | |
86 | (parse-js:parse-js js))) |
|
86 | (parse-js:parse-js js))) | |
87 | :beautify nil))) |
|
87 | :beautify nil))) | |
88 |
|
88 | |||
89 | (defun report-error (fmt &rest args) |
|
89 | (defun report-error (fmt &rest args) | |
90 | (apply #'format t fmt args) |
|
90 | (apply #'format t fmt args) | |
91 | (throw :terminate nil)) |
|
91 | (throw :terminate nil)) | |
92 |
|
92 | |||
93 | ;;; JS |
|
93 | ;;; JS | |
94 |
|
94 | |||
95 | (defun src-file (filename) |
|
|||
96 | (uiop/pathname:merge-pathnames* |
|
|||
97 | filename |
|
|||
98 | (asdf:system-source-directory :sugar-qsp))) |
|
|||
99 |
|
||||
100 | (defmethod js-sources ((compiler compiler)) |
|
95 | (defmethod js-sources ((compiler compiler)) | |
101 | (format nil "~{~A~^~%~%~}" (reverse (js compiler)))) |
|
96 | (format nil "~{~A~^~%~%~}" (reverse (js compiler)))) | |
102 |
|
97 | |||
103 | (defun compile-ps (filename) |
|
|||
104 | (format nil "////// Parenscript file: ~A~%~%~A" |
|
|||
105 | (file-namestring filename) (ps:ps-compile-file filename))) |
|
|||
106 |
|
||||
107 | ;;; CSS |
|
98 | ;;; CSS | |
108 |
|
99 | |||
109 | (defmethod css-sources ((compiler compiler)) |
|
100 | (defmethod css-sources ((compiler compiler)) | |
110 | (format nil "~{~A~^~%~%~}" (css compiler))) |
|
101 | (format nil "~{~A~^~%~%~}" (css compiler))) | |
111 |
|
102 | |||
112 | ;;; HTML |
|
103 | ;;; HTML | |
113 |
|
104 | |||
114 | (defmethod html-sources ((compiler compiler)) |
|
105 | (defmethod html-sources ((compiler compiler)) | |
115 | (let ((flute:*escape-html* nil) |
|
106 | (let ((flute:*escape-html* nil) | |
116 | (body-template (body compiler)) |
|
107 | (body-template (body compiler)) | |
117 | (js (js-sources compiler)) |
|
108 | (js (js-sources compiler)) | |
118 | (css (css-sources compiler))) |
|
109 | (css (css-sources compiler))) | |
119 | (with-output-to-string (out) |
|
110 | (with-output-to-string (out) | |
120 | (write |
|
111 | (write | |
121 | (flute:h |
|
112 | (flute:h | |
122 | (html |
|
113 | (html | |
123 | (head |
|
114 | (head | |
124 | (title "SugarQSP")) |
|
115 | (title "SugarQSP")) | |
125 | (body |
|
116 | (body | |
126 | body-template |
|
117 | body-template | |
127 | (style css) |
|
118 | (style css) | |
128 | (script (preprocess-js js (beautify compiler)))))) |
|
119 | (script (preprocess-js js (beautify compiler)))))) | |
129 | :stream out |
|
120 | :stream out | |
130 | :pretty nil)))) |
|
121 | :pretty nil)))) | |
131 |
|
122 | |||
132 | (defclass compiler () |
|
|||
133 | ((body :accessor body :initform #.(alexandria:read-file-into-string (src-file "extras/body.html"))) |
|
|||
134 | (css :accessor css :initform (list #.(alexandria:read-file-into-string (src-file "extras/default.css")))) |
|
|||
135 | (js :accessor js :initform (list #.(compile-ps (src-file "src/intrinsics.ps")) |
|
|||
136 | #.(compile-ps (src-file "src/api.ps")) |
|
|||
137 | #.(compile-ps (src-file "src/main.ps")))) |
|
|||
138 | (compile :accessor compile-only :initarg :compile) |
|
|||
139 | (target :accessor target :initarg :target) |
|
|||
140 | (beautify :accessor beautify :initarg :beautify))) |
|
|||
141 |
|
||||
142 | (defmethod initialize-instance ((compiler compiler) &key source ((:js js-files)) ((:css css-files)) ((:body body-file)) compile &allow-other-keys) |
|
123 | (defmethod initialize-instance ((compiler compiler) &key source ((:js js-files)) ((:css css-files)) ((:body body-file)) compile &allow-other-keys) | |
143 | (call-next-method) |
|
124 | (call-next-method) | |
144 | (with-slots (body css js) |
|
125 | (with-slots (body css js) | |
145 | compiler |
|
126 | compiler | |
146 | ;; Compile the game's JS |
|
127 | ;; Compile the game's JS | |
147 | (push (make-javascript (parse-file source)) js) |
|
128 | (push (make-javascript (parse-file source)) js) | |
148 | ;; Does the user need us to do anything else |
|
129 | ;; Does the user need us to do anything else | |
149 | (unless compile |
|
130 | (unless compile | |
150 | ;; Read in body |
|
131 | ;; Read in body | |
151 | (when body-file |
|
132 | (when body-file | |
152 | (setf body |
|
133 | (setf body | |
153 | (alexandria:read-file-into-string body-file))) |
|
134 | (alexandria:read-file-into-string body-file))) | |
154 | ;; Include js files |
|
135 | ;; Include js files | |
155 | (dolist (js-file js-files) |
|
136 | (dolist (js-file js-files) | |
156 | (push (format nil "////// Included file ~A~%~A" js-file |
|
137 | (push (format nil "////// Included file ~A~%~A" js-file | |
157 | (alexandria:read-file-into-string js-file)) |
|
138 | (alexandria:read-file-into-string js-file)) | |
158 | js)) |
|
139 | js)) | |
159 | ;; Include css files |
|
140 | ;; Include css files | |
160 | (dolist (css-file css-files) |
|
141 | (dolist (css-file css-files) | |
161 | (push (format nil "////// Included file ~A~%~A" css-file |
|
142 | (push (format nil "////// Included file ~A~%~A" css-file | |
162 | (alexandria:read-file-into-string css-file)) |
|
143 | (alexandria:read-file-into-string css-file)) | |
163 | css))))) |
|
144 | css))))) | |
164 |
|
145 | |||
165 | (defmethod write-compiled-file ((compiler compiler)) |
|
146 | (defmethod write-compiled-file ((compiler compiler)) | |
166 | (alexandria:write-string-into-file |
|
147 | (alexandria:write-string-into-file | |
167 | (if (compile-only compiler) |
|
148 | (if (compile-only compiler) | |
168 | ;; Just the JS |
|
149 | ;; Just the JS | |
169 | (preprocess-js (js-sources compiler) (beautify compiler)) |
|
150 | (preprocess-js (js-sources compiler) (beautify compiler)) | |
170 | ;; All of it |
|
151 | ;; All of it | |
171 | (html-sources compiler)) |
|
152 | (html-sources compiler)) | |
172 | (target compiler) :if-exists :supersede)) |
|
153 | (target compiler) :if-exists :supersede)) |
@@ -1,15 +1,21 b'' | |||||
1 |
|
1 | |||
2 | (in-package sugar-qsp) |
|
2 | (in-package sugar-qsp) | |
3 |
|
3 | |||
4 | (setf (root) |
|
4 | (setf (root) | |
5 | (ps:create vars (ps:create) |
|
5 | (ps:create vars (ps:create) | |
6 | objs (list) |
|
6 | objs (list) | |
7 | state-stash (ps:create) |
|
7 | state-stash (ps:create) | |
8 | acts (ps:create) |
|
8 | acts (ps:create) | |
9 |
loc |
|
9 | locs (ps:create))) | |
10 |
|
10 | |||
|
11 | ;; Launch the game from the first location | |||
11 | (setf window.onload |
|
12 | (setf window.onload | |
12 | (lambda () |
|
13 | (lambda () | |
13 |
(funcall (ps:getprop (root loc |
|
14 | (funcall (ps:getprop (root locs) | |
14 |
(ps:chain *object (keys (root loc |
|
15 | (ps:chain *object (keys (root locs)) 0))) | |
15 | (values))) |
|
16 | (values))) | |
|
17 | ||||
|
18 | ;; Close the dropdown on any click | |||
|
19 | (setf window.onclick | |||
|
20 | (lambda (event) | |||
|
21 | (setf (ps:@ (api-call get-frame :dropdown) style display) "none"))) |
@@ -1,571 +1,571 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 |
|
74 | |||
75 | (p:defrule spaces? (* (or #\space #\tab line-continuation)) |
|
75 | (p:defrule spaces? (* (or #\space #\tab line-continuation)) | |
76 | (:constant nil)) |
|
76 | (:constant nil)) | |
77 |
|
77 | |||
78 | (p:defrule colon #\: |
|
78 | (p:defrule colon #\: | |
79 | (:constant nil)) |
|
79 | (:constant nil)) | |
80 |
|
80 | |||
81 | (p:defrule alphanumeric (alphanumericp character)) |
|
81 | (p:defrule alphanumeric (alphanumericp character)) | |
82 |
|
82 | |||
83 | (p:defrule not-newline (not-newline character)) |
|
83 | (p:defrule not-newline (not-newline character)) | |
84 |
|
84 | |||
85 | (p:defrule squote-esc "''" |
|
85 | (p:defrule squote-esc "''" | |
86 | (:lambda (list) |
|
86 | (:lambda (list) | |
87 | (p:text (elt list 0)))) |
|
87 | (p:text (elt list 0)))) | |
88 |
|
88 | |||
89 | (p:defrule dquote-esc "\"\"" |
|
89 | (p:defrule dquote-esc "\"\"" | |
90 | (:lambda (list) |
|
90 | (:lambda (list) | |
91 | (p:text (elt list 0)))) |
|
91 | (p:text (elt list 0)))) | |
92 |
|
92 | |||
93 | (p:defrule sstring-chars (+ (and (and (p:! "<<") (p:! (p:~ "\"exec:"))) |
|
93 | (p:defrule sstring-chars (+ (and (and (p:! "<<") (p:! (p:~ "\"exec:"))) | |
94 | (or squote-esc (not-quote character)))) |
|
94 | (or squote-esc (not-quote character)))) | |
95 | (:lambda (list) |
|
95 | (:lambda (list) | |
96 | (p:text (mapcar #'second list)))) |
|
96 | (p:text (mapcar #'second list)))) | |
97 |
|
97 | |||
98 | (p:defrule dstring-chars (+ (and (and (p:! "<<") (p:! (p:~ "'exec:"))) |
|
98 | (p:defrule dstring-chars (+ (and (and (p:! "<<") (p:! (p:~ "'exec:"))) | |
99 | (or dquote-esc (not-doublequote character)))) |
|
99 | (or dquote-esc (not-doublequote character)))) | |
100 | (:lambda (list) |
|
100 | (:lambda (list) | |
101 | (p:text (mapcar #'second list)))) |
|
101 | (p:text (mapcar #'second list)))) | |
102 |
|
102 | |||
103 | ;;; Identifiers |
|
103 | ;;; Identifiers | |
104 |
|
104 | |||
105 | ;; From the official docs |
|
105 | ;; From the official docs | |
106 | (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 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 $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 str strcomp strfind strpos trim ucase unsel unselect $usercom user_text usrtxt val view wait xgoto xgt)) |
|
106 | (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 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 $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 str strcomp strfind strpos trim ucase unsel unselect $usercom user_text usrtxt val view wait xgoto xgt)) | |
107 |
|
107 | |||
108 | (defun qsp-keyword-p (id) |
|
108 | (defun qsp-keyword-p (id) | |
109 | (member (intern (string-upcase id)) *keywords*)) |
|
109 | (member (intern (string-upcase id)) *keywords*)) | |
110 |
|
110 | |||
111 | (defun not-qsp-keyword-p (id) |
|
111 | (defun not-qsp-keyword-p (id) | |
112 | (not (member (intern (string-upcase id)) *keywords*))) |
|
112 | (not (member (intern (string-upcase id)) *keywords*))) | |
113 |
|
113 | |||
114 | (p:defrule qsp-keyword (qsp-keyword-p identifier-raw)) |
|
114 | (p:defrule qsp-keyword (qsp-keyword-p identifier-raw)) | |
115 |
|
115 | |||
116 | (p:defrule id-first (id-any-char character)) |
|
116 | (p:defrule id-first (id-any-char character)) | |
117 | (p:defrule id-next (or (id-any-char character) |
|
117 | (p:defrule id-next (or (id-any-char character) | |
118 | (digit-char-p character))) |
|
118 | (digit-char-p character))) | |
119 | (p:defrule identifier-raw (and id-first (* id-next)) |
|
119 | (p:defrule identifier-raw (and id-first (* id-next)) | |
120 | (:lambda (list) |
|
120 | (:lambda (list) | |
121 | (let ((id (p:text list))) |
|
121 | (let ((id (p:text list))) | |
122 | (when (member id *keywords*) |
|
122 | (when (member id *keywords*) | |
123 | (error "~A is a keyword" id)) |
|
123 | (error "~A is a keyword" id)) | |
124 | (intern (string-upcase id))))) |
|
124 | (intern (string-upcase id))))) | |
125 |
|
125 | |||
126 | (p:defrule identifier (not-qsp-keyword-p identifier-raw)) |
|
126 | (p:defrule identifier (not-qsp-keyword-p identifier-raw)) | |
127 |
|
127 | |||
128 | ;;; Strings |
|
128 | ;;; Strings | |
129 |
|
129 | |||
130 | (p:defrule qsp-string (or normal-string brace-string)) |
|
130 | (p:defrule qsp-string (or normal-string brace-string)) | |
131 |
|
131 | |||
132 | (p:defrule normal-string (or sstring dstring) |
|
132 | (p:defrule normal-string (or sstring dstring) | |
133 | (:lambda (str) |
|
133 | (:lambda (str) | |
134 | (list* 'str (or str (list ""))))) |
|
134 | (list* 'str (or str (list ""))))) | |
135 |
|
135 | |||
136 | (p:defrule sstring (and #\' (* (or string-interpol |
|
136 | (p:defrule sstring (and #\' (* (or string-interpol | |
137 | sstring-exec |
|
137 | sstring-exec | |
138 | sstring-chars)) |
|
138 | sstring-chars)) | |
139 | #\') |
|
139 | #\') | |
140 | (:function second)) |
|
140 | (:function second)) | |
141 |
|
141 | |||
142 | (p:defrule dstring (and #\" (* (or string-interpol |
|
142 | (p:defrule dstring (and #\" (* (or string-interpol | |
143 | dstring-exec |
|
143 | dstring-exec | |
144 | dstring-chars)) |
|
144 | dstring-chars)) | |
145 | #\") |
|
145 | #\") | |
146 | (:function second)) |
|
146 | (:function second)) | |
147 |
|
147 | |||
148 | (p:defrule string-interpol (and "<<" expression ">>") |
|
148 | (p:defrule string-interpol (and "<<" expression ">>") | |
149 | (:function second)) |
|
149 | (:function second)) | |
150 |
|
150 | |||
151 | (p:defrule sstring-exec-body (+ (or squote-esc (not-doublequote character))) |
|
151 | (p:defrule sstring-exec-body (+ (or squote-esc (not-doublequote character))) | |
152 | (:text t)) |
|
152 | (:text t)) | |
153 |
|
153 | |||
154 | (p:defrule dstring-exec-body (+ (or dquote-esc (not-quote character))) |
|
154 | (p:defrule dstring-exec-body (+ (or dquote-esc (not-quote character))) | |
155 | (:text t)) |
|
155 | (:text t)) | |
156 |
|
156 | |||
157 | (p:defrule sstring-exec (and (p:~ "\"exec:") sstring-exec-body #\") |
|
157 | (p:defrule sstring-exec (and (p:~ "\"exec:") sstring-exec-body #\") | |
158 | (:lambda (list) |
|
158 | (:lambda (list) | |
159 | (list* 'exec (p:parse 'exec-body (second list))))) |
|
159 | (list* 'exec (p:parse 'exec-body (second list))))) | |
160 |
|
160 | |||
161 | (p:defrule dstring-exec (and (p:~ "'exec:") dstring-exec-body #\') |
|
161 | (p:defrule dstring-exec (and (p:~ "'exec:") dstring-exec-body #\') | |
162 | (:lambda (list) |
|
162 | (:lambda (list) | |
163 | (list* 'exec (p:parse 'exec-body (second list))))) |
|
163 | (list* 'exec (p:parse 'exec-body (second list))))) | |
164 |
|
164 | |||
165 | (p:defrule brace-string (and #\{ before-statement block-body #\}) |
|
165 | (p:defrule brace-string (and #\{ before-statement block-body #\}) | |
166 | (:lambda (list) |
|
166 | (:lambda (list) | |
167 | (list* 'qspblock (third list)))) |
|
167 | (list* 'qspblock (third list)))) | |
168 |
|
168 | |||
169 | ;;; Location |
|
169 | ;;; Location | |
170 |
|
170 | |||
171 | (p:defrule sugar-qsp-grammar (and (* (or spaces #\newline)) |
|
171 | (p:defrule sugar-qsp-grammar (and (* (or spaces #\newline)) | |
172 | (* location)) |
|
172 | (* location)) | |
173 | (:function second)) |
|
173 | (:function second)) | |
174 |
|
174 | |||
175 | (p:defrule location (and location-header block-body location-end) |
|
175 | (p:defrule location (and location-header block-body location-end) | |
176 | (:destructure (header body end) |
|
176 | (:destructure (header body end) | |
177 | (declare (ignore end)) |
|
177 | (declare (ignore end)) | |
178 | `(location (,header) ,@body))) |
|
178 | `(location (,header) ,@body))) | |
179 |
|
179 | |||
180 | (p:defrule location-header (and #\# |
|
180 | (p:defrule location-header (and #\# | |
181 | (+ not-newline) |
|
181 | (+ not-newline) | |
182 | (and #\newline spaces? before-statement)) |
|
182 | (and #\newline spaces? before-statement)) | |
183 | (:destructure (spaces1 name spaces2) |
|
183 | (:destructure (spaces1 name spaces2) | |
184 | (declare (ignore spaces1 spaces2)) |
|
184 | (declare (ignore spaces1 spaces2)) | |
185 | (string-upcase (string-trim " " (p:text name))))) |
|
185 | (string-upcase (string-trim " " (p:text name))))) | |
186 |
|
186 | |||
187 | (p:defrule location-end (and #\- #\newline before-statement) |
|
187 | (p:defrule location-end (and #\- (* not-newline) #\newline before-statement) | |
188 | (:constant nil)) |
|
188 | (:constant nil)) | |
189 |
|
189 | |||
190 | ;;; Block body |
|
190 | ;;; Block body | |
191 |
|
191 | |||
192 | (p:defrule newline-block-body (and #\newline spaces? block-body) |
|
192 | (p:defrule newline-block-body (and #\newline spaces? block-body) | |
193 | (:function third)) |
|
193 | (:function third)) | |
194 |
|
194 | |||
195 | (p:defrule block-body (* statement) |
|
195 | (p:defrule block-body (* statement) | |
196 | (:function remove-nil)) |
|
196 | (:function remove-nil)) | |
197 |
|
197 | |||
198 | ;; Just for <a href="exec:...'> |
|
198 | ;; Just for <a href="exec:...'> | |
199 | ;; Explicitly called from that rule's production |
|
199 | ;; Explicitly called from that rule's production | |
200 | (p:defrule exec-body (and before-statement line-body) |
|
200 | (p:defrule exec-body (and before-statement line-body) | |
201 | (:function second)) |
|
201 | (:function second)) | |
202 |
|
202 | |||
203 | (p:defrule line-body (and inline-statement (* next-inline-statement)) |
|
203 | (p:defrule line-body (and inline-statement (* next-inline-statement)) | |
204 | (:lambda (list) |
|
204 | (:lambda (list) | |
205 | (list* (first list) (second list)))) |
|
205 | (list* (first list) (second list)))) | |
206 |
|
206 | |||
207 | (p:defrule before-statement (* (or #\newline spaces)) |
|
207 | (p:defrule before-statement (* (or #\newline spaces)) | |
208 | (:constant nil)) |
|
208 | (:constant nil)) | |
209 |
|
209 | |||
210 | (p:defrule statement-end (or statement-end-real statement-end-block-close)) |
|
210 | (p:defrule statement-end (or statement-end-real statement-end-block-close)) | |
211 |
|
211 | |||
212 | (p:defrule statement-end-real (and (or #\newline |
|
212 | (p:defrule statement-end-real (and (or #\newline | |
213 | (and #\& spaces? (p:& statement%))) |
|
213 | (and #\& spaces? (p:& statement%))) | |
214 | before-statement) |
|
214 | before-statement) | |
215 | (:constant nil)) |
|
215 | (:constant nil)) | |
216 |
|
216 | |||
217 | (p:defrule statement-end-block-close (or (p:& #\})) |
|
217 | (p:defrule statement-end-block-close (or (p:& #\})) | |
218 | (:constant nil)) |
|
218 | (:constant nil)) | |
219 |
|
219 | |||
220 | (p:defrule inline-statement (and statement% spaces?) |
|
220 | (p:defrule inline-statement (and statement% spaces?) | |
221 | (:function first)) |
|
221 | (:function first)) | |
222 |
|
222 | |||
223 | (p:defrule next-inline-statement (and #\& spaces? inline-statement) |
|
223 | (p:defrule next-inline-statement (and #\& spaces? inline-statement) | |
224 | (:function third)) |
|
224 | (:function third)) | |
225 |
|
225 | |||
226 | (p:defrule not-a-non-statement (and (p:! (p:~ "elseif")) |
|
226 | (p:defrule not-a-non-statement (and (p:! (p:~ "elseif")) | |
227 | (p:! (p:~ "else")) |
|
227 | (p:! (p:~ "else")) | |
228 | (p:! (p:~ "end")))) |
|
228 | (p:! (p:~ "end")))) | |
229 |
|
229 | |||
230 | (p:defrule statement (and inline-statement statement-end) |
|
230 | (p:defrule statement (and inline-statement statement-end) | |
231 | (:function first)) |
|
231 | (:function first)) | |
232 |
|
232 | |||
233 | (p:defrule statement% (and not-a-non-statement |
|
233 | (p:defrule statement% (and not-a-non-statement | |
234 | (or label comment string-output |
|
234 | (or label comment string-output | |
235 | block non-returning-intrinsic assignment |
|
235 | block non-returning-intrinsic assignment | |
236 | expression-output)) |
|
236 | expression-output)) | |
237 | (:function second)) |
|
237 | (:function second)) | |
238 |
|
238 | |||
239 | (p:defrule expr-stopper (or comment block non-returning-intrinsic)) |
|
239 | (p:defrule expr-stopper (or comment block non-returning-intrinsic)) | |
240 |
|
240 | |||
241 | (p:defrule string-output qsp-string |
|
241 | (p:defrule string-output qsp-string | |
242 | (:lambda (string) |
|
242 | (:lambda (string) | |
243 | (list 'main-pl string))) |
|
243 | (list 'main-pl string))) | |
244 |
|
244 | |||
245 | (p:defrule expression-output expression |
|
245 | (p:defrule expression-output expression | |
246 | (:lambda (list) |
|
246 | (:lambda (list) | |
247 | (list 'main-pl list))) |
|
247 | (list 'main-pl list))) | |
248 |
|
248 | |||
249 | (p:defrule label (and colon identifier) |
|
249 | (p:defrule label (and colon identifier) | |
250 | (:lambda (list) |
|
250 | (:lambda (list) | |
251 | (intern (string (second list)) :keyword))) |
|
251 | (intern (string (second list)) :keyword))) | |
252 |
|
252 | |||
253 | (p:defrule comment (and #\! (* (or text-spaces qsp-string brace-string not-newline))) |
|
253 | (p:defrule comment (and #\! (* (or text-spaces qsp-string brace-string not-newline))) | |
254 | (:constant nil)) |
|
254 | (:constant nil)) | |
255 |
|
255 | |||
256 | ;;; Blocks |
|
256 | ;;; Blocks | |
257 |
|
257 | |||
258 | (p:defrule block (or block-act block-if)) |
|
258 | (p:defrule block (or block-act block-if)) | |
259 |
|
259 | |||
260 | (p:defrule block-if (and block-if-head block-if-body) |
|
260 | (p:defrule block-if (and block-if-head block-if-body) | |
261 | (:destructure (head body) |
|
261 | (:destructure (head body) | |
262 | `(qspcond (,@head ,@(first body)) |
|
262 | `(qspcond (,@head ,@(first body)) | |
263 | ,@(rest body)))) |
|
263 | ,@(rest body)))) | |
264 |
|
264 | |||
265 | (p:defrule block-if-head (and (p:~ "if") spaces expression spaces? colon spaces?) |
|
265 | (p:defrule block-if-head (and (p:~ "if") spaces expression spaces? colon spaces?) | |
266 | (:function remove-nil) |
|
266 | (:function remove-nil) | |
267 | (:function cdr)) |
|
267 | (:function cdr)) | |
268 |
|
268 | |||
269 | (p:defrule block-if-body (or block-if-ml block-if-sl) |
|
269 | (p:defrule block-if-body (or block-if-ml block-if-sl) | |
270 | (:destructure (if-body elseifs else &rest ws) |
|
270 | (:destructure (if-body elseifs else &rest ws) | |
271 | (declare (ignore ws)) |
|
271 | (declare (ignore ws)) | |
272 | `(,(remove-nil if-body) ,@elseifs ,@(when else `((else ,@else)))))) |
|
272 | `(,(remove-nil if-body) ,@elseifs ,@(when else `((else ,@else)))))) | |
273 |
|
273 | |||
274 | (p:defrule block-if-sl (and line-body |
|
274 | (p:defrule block-if-sl (and line-body | |
275 | (p:? block-if-elseif-inline) |
|
275 | (p:? block-if-elseif-inline) | |
276 | (p:? block-if-else-inline) |
|
276 | (p:? block-if-else-inline) | |
277 | spaces?)) |
|
277 | spaces?)) | |
278 |
|
278 | |||
279 | (p:defrule block-if-ml (and (and #\newline spaces?) |
|
279 | (p:defrule block-if-ml (and (and #\newline spaces?) | |
280 | block-body |
|
280 | block-body | |
281 | (p:? block-if-elseif) |
|
281 | (p:? block-if-elseif) | |
282 | (p:? block-if-else) |
|
282 | (p:? block-if-else) | |
283 | block-if-end) |
|
283 | block-if-end) | |
284 | (:lambda (list) |
|
284 | (:lambda (list) | |
285 | (cdr list))) |
|
285 | (cdr list))) | |
286 |
|
286 | |||
287 | (p:defrule block-if-elseif-inline (and block-if-elseif-head line-body (p:? block-if-elseif-inline)) |
|
287 | (p:defrule block-if-elseif-inline (and block-if-elseif-head line-body (p:? block-if-elseif-inline)) | |
288 | (:destructure (head statements elseif) |
|
288 | (:destructure (head statements elseif) | |
289 | `((,@(rest head) ,@(remove-nil statements)) ,@elseif))) |
|
289 | `((,@(rest head) ,@(remove-nil statements)) ,@elseif))) | |
290 |
|
290 | |||
291 | (p:defrule block-if-elseif (and block-if-elseif-head statement-end block-body (p:? block-if-elseif)) |
|
291 | (p:defrule block-if-elseif (and block-if-elseif-head statement-end block-body (p:? block-if-elseif)) | |
292 | (:destructure (head ws statements elseif) |
|
292 | (:destructure (head ws statements elseif) | |
293 | (declare (ignore ws)) |
|
293 | (declare (ignore ws)) | |
294 | `((,@(rest head) ,@(remove-nil statements)) ,@elseif))) |
|
294 | `((,@(rest head) ,@(remove-nil statements)) ,@elseif))) | |
295 |
|
295 | |||
296 | (p:defrule block-if-elseif-head (and (p:~ "elseif") spaces expression spaces? colon spaces?) |
|
296 | (p:defrule block-if-elseif-head (and (p:~ "elseif") spaces expression spaces? colon spaces?) | |
297 | (:function remove-nil) |
|
297 | (:function remove-nil) | |
298 | (:function intern-first)) |
|
298 | (:function intern-first)) | |
299 |
|
299 | |||
300 | (p:defrule block-if-else-inline (and block-if-else-head line-body) |
|
300 | (p:defrule block-if-else-inline (and block-if-else-head line-body) | |
301 | (:function second)) |
|
301 | (:function second)) | |
302 |
|
302 | |||
303 | (p:defrule block-if-else (and block-if-else-head #\newline spaces? block-body) |
|
303 | (p:defrule block-if-else (and block-if-else-head #\newline spaces? block-body) | |
304 | (:function fourth)) |
|
304 | (:function fourth)) | |
305 |
|
305 | |||
306 | (p:defrule block-if-else-head (and (p:~ "else") spaces?) |
|
306 | (p:defrule block-if-else-head (and (p:~ "else") spaces?) | |
307 | (:constant nil)) |
|
307 | (:constant nil)) | |
308 |
|
308 | |||
309 | (p:defrule block-if-end (and (p:~ "end") |
|
309 | (p:defrule block-if-end (and (p:~ "end") | |
310 | (p:? (and spaces (p:~ "if")))) |
|
310 | (p:? (and spaces (p:~ "if")))) | |
311 | (:constant nil)) |
|
311 | (:constant nil)) | |
312 |
|
312 | |||
313 | (p:defrule block-act (and block-act-head (or block-act-ml block-act-sl)) |
|
313 | (p:defrule block-act (and block-act-head (or block-act-ml block-act-sl)) | |
314 | (:lambda (list) |
|
314 | (:lambda (list) | |
315 | (apply #'append list))) |
|
315 | (apply #'append list))) | |
316 |
|
316 | |||
317 | (p:defrule block-act-sl line-body) |
|
317 | (p:defrule block-act-sl line-body) | |
318 |
|
318 | |||
319 | (p:defrule block-act-ml (and newline-block-body block-act-end) |
|
319 | (p:defrule block-act-ml (and newline-block-body block-act-end) | |
320 | (:lambda (list) |
|
320 | (:lambda (list) | |
321 | (apply #'list* (butlast list)))) |
|
321 | (apply #'list* (butlast list)))) | |
322 |
|
322 | |||
323 | (p:defrule block-act-head (and (p:~ "act") spaces qsp-string spaces? |
|
323 | (p:defrule block-act-head (and (p:~ "act") spaces qsp-string spaces? | |
324 | (p:? block-act-head-img) |
|
324 | (p:? block-act-head-img) | |
325 | colon spaces?) |
|
325 | colon spaces?) | |
326 | (:lambda (list) |
|
326 | (:lambda (list) | |
327 | (intern-first (list (first list) |
|
327 | (intern-first (list (first list) | |
328 | (third list) |
|
328 | (third list) | |
329 | (or (fifth list) '(str "")))))) |
|
329 | (or (fifth list) '(str "")))))) | |
330 |
|
330 | |||
331 | (p:defrule block-act-head-img (and #\, spaces? qsp-string spaces?) |
|
331 | (p:defrule block-act-head-img (and #\, spaces? qsp-string spaces?) | |
332 | (:lambda (list) |
|
332 | (:lambda (list) | |
333 | (or (third list) ""))) |
|
333 | (or (third list) ""))) | |
334 |
|
334 | |||
335 | (p:defrule block-act-end (and (p:~ "end")) |
|
335 | (p:defrule block-act-end (and (p:~ "end")) | |
336 | (:constant nil)) |
|
336 | (:constant nil)) | |
337 |
|
337 | |||
338 | ;;; Calls |
|
338 | ;;; Calls | |
339 |
|
339 | |||
340 | (p:defrule first-argument (and expression spaces?) |
|
340 | (p:defrule first-argument (and expression spaces?) | |
341 | (:function first)) |
|
341 | (:function first)) | |
342 | (p:defrule next-argument (and "," spaces? expression) |
|
342 | (p:defrule next-argument (and "," spaces? expression) | |
343 | (:function third)) |
|
343 | (:function third)) | |
344 | (p:defrule arguments (or parenthesized-arguments plain-arguments no-arguments)) |
|
344 | (p:defrule arguments (or parenthesized-arguments plain-arguments no-arguments)) | |
345 | (p:defrule parenthesized-arguments (and spaces? #\( base-arguments #\)) |
|
345 | (p:defrule parenthesized-arguments (and spaces? #\( base-arguments #\)) | |
346 | (:function third)) |
|
346 | (:function third)) | |
347 | (p:defrule plain-arguments (and spaces base-arguments) |
|
347 | (p:defrule plain-arguments (and spaces base-arguments) | |
348 | (:function second)) |
|
348 | (:function second)) | |
349 | (p:defrule no-arguments (or spaces (p:& #\newline) (p:& #\&)) |
|
349 | (p:defrule no-arguments (or spaces (p:& #\newline) (p:& #\&)) | |
350 | (:constant nil)) |
|
350 | (:constant nil)) | |
351 | (p:defrule base-arguments (and first-argument (* next-argument)) |
|
351 | (p:defrule base-arguments (and first-argument (* next-argument)) | |
352 | (:destructure (first rest) |
|
352 | (:destructure (first rest) | |
353 | (list* first rest))) |
|
353 | (list* first rest))) | |
354 |
|
354 | |||
355 | ;;; Intrinsics |
|
355 | ;;; Intrinsics | |
356 |
|
356 | |||
357 | (defmacro defintrinsics ((rule-name returning-rule-name non-returning-rule-name) &body clauses) |
|
357 | (defmacro defintrinsics ((rule-name returning-rule-name non-returning-rule-name) &body clauses) | |
358 | `(progn |
|
358 | `(progn | |
359 | ,@(loop :for clause :in clauses |
|
359 | ,@(loop :for clause :in clauses | |
360 | :collect `(defintrinsic ,@clause)) |
|
360 | :collect `(defintrinsic ,@clause)) | |
361 | (p:defrule ,returning-rule-name (or ,@(remove-nil |
|
361 | (p:defrule ,returning-rule-name (or ,@(remove-nil | |
362 | (mapcar (lambda (clause) |
|
362 | (mapcar (lambda (clause) | |
363 | (when (second clause) |
|
363 | (when (second clause) | |
364 | (alexandria:symbolicate |
|
364 | (alexandria:symbolicate | |
365 | 'intrinsic- (first clause)))) |
|
365 | 'intrinsic- (first clause)))) | |
366 | clauses)))) |
|
366 | clauses)))) | |
367 | (p:defrule ,non-returning-rule-name (or ,@(remove-nil |
|
367 | (p:defrule ,non-returning-rule-name (or ,@(remove-nil | |
368 | (mapcar (lambda (clause) |
|
368 | (mapcar (lambda (clause) | |
369 | (unless (second clause) |
|
369 | (unless (second clause) | |
370 | (alexandria:symbolicate |
|
370 | (alexandria:symbolicate | |
371 | 'intrinsic- (first clause)))) |
|
371 | 'intrinsic- (first clause)))) | |
372 | clauses)))) |
|
372 | clauses)))) | |
373 | (p:defrule ,rule-name (or ,returning-rule-name ,non-returning-rule-name)))) |
|
373 | (p:defrule ,rule-name (or ,returning-rule-name ,non-returning-rule-name)))) | |
374 |
|
374 | |||
375 | (defmacro defintrinsic (sym returning &optional (min-arity 0) (max-arity 10) &rest names) |
|
375 | (defmacro defintrinsic (sym returning &optional (min-arity 0) (max-arity 10) &rest names) | |
376 | (declare (ignore returning)) |
|
376 | (declare (ignore returning)) | |
377 | (setf names |
|
377 | (setf names | |
378 | (if names |
|
378 | (if names | |
379 | (mapcar #'string-upcase names) |
|
379 | (mapcar #'string-upcase names) | |
380 | (list (string sym)))) |
|
380 | (list (string sym)))) | |
381 | `(p:defrule ,(alexandria:symbolicate 'intrinsic- sym) |
|
381 | `(p:defrule ,(alexandria:symbolicate 'intrinsic- sym) | |
382 | (and (p:? #\$) (or ,@(loop :for name :in names :collect `(p:~ ,name))) |
|
382 | (and (p:? #\$) (or ,@(loop :for name :in names :collect `(p:~ ,name))) | |
383 | arguments) |
|
383 | arguments) | |
384 | (:destructure (dollar name arguments) |
|
384 | (:destructure (dollar name arguments) | |
385 | (declare (ignore dollar)) |
|
385 | (declare (ignore dollar)) | |
386 | (unless (<= ,min-arity (length arguments) ,max-arity) |
|
386 | (unless (<= ,min-arity (length arguments) ,max-arity) | |
387 | (error "Intrinsic ~A expects between ~A and ~A arguments but ~A were provided:~%~S" |
|
387 | (error "Intrinsic ~A expects between ~A and ~A arguments but ~A were provided:~%~S" | |
388 | name ,min-arity ,max-arity (length arguments) arguments)) |
|
388 | name ,min-arity ,max-arity (length arguments) arguments)) | |
389 | (list* ',sym arguments)))) |
|
389 | (list* ',sym arguments)))) | |
390 |
|
390 | |||
391 | (defintrinsics (intrinsic returning-intrinsic non-returning-intrinsic) |
|
391 | (defintrinsics (intrinsic returning-intrinsic non-returning-intrinsic) | |
392 | ;; Transitions |
|
392 | ;; Transitions | |
393 | (goto nil 0 10 "gt" "goto") |
|
393 | (goto nil 0 10 "gt" "goto") | |
394 | (xgoto nil 0 10 "xgt" "xgoto") |
|
394 | (xgoto nil 0 10 "xgt" "xgoto") | |
395 | ;; Variables |
|
395 | ;; Variables | |
396 | (killvar nil 0 2) |
|
396 | (killvar nil 0 2) | |
397 | ;; Expressions |
|
397 | ;; Expressions | |
398 | (obj t 1 1) |
|
398 | (obj t 1 1) | |
399 | (loc t 1 1) |
|
399 | (loc t 1 1) | |
400 | (no t 1 1) |
|
400 | (no t 1 1) | |
401 | ;; Basic |
|
401 | ;; Basic | |
402 | (qspver t 0 0) |
|
402 | (qspver t 0 0) | |
403 | (curloc t 0 0) |
|
403 | (curloc t 0 0) | |
404 | (rand t 1 2) |
|
404 | (rand t 1 2) | |
405 | (rnd t 0 0) |
|
405 | (rnd t 0 0) | |
406 | (qspmax t 1 10 "max") |
|
406 | (qspmax t 1 10 "max") | |
407 | (qspmin t 1 10 "min") |
|
407 | (qspmin t 1 10 "min") | |
408 | ;; Arrays |
|
408 | ;; Arrays | |
409 | (killall nil 0 0) |
|
409 | (killall nil 0 0) | |
410 | (copyarr nil 2 4) |
|
410 | (copyarr nil 2 4) | |
411 | (arrsize t 1 1) |
|
411 | (arrsize t 1 1) | |
412 | (arrpos t 2 3) |
|
412 | (arrpos t 2 3) | |
413 | (arrcomp t 2 3) |
|
413 | (arrcomp t 2 3) | |
414 | ;; Strings |
|
414 | ;; Strings | |
415 | (len t 1 1) |
|
415 | (len t 1 1) | |
416 | (mid t 2 3) |
|
416 | (mid t 2 3) | |
417 | (ucase t 1 1) |
|
417 | (ucase t 1 1) | |
418 | (lcase t 1 1) |
|
418 | (lcase t 1 1) | |
419 | (trim t 1 1) |
|
419 | (trim t 1 1) | |
420 | (replace t 2 3) |
|
420 | (replace t 2 3) | |
421 | (instr t 2 3) |
|
421 | (instr t 2 3) | |
422 | (isnum t 1 1) |
|
422 | (isnum t 1 1) | |
423 | (val t 1 1) |
|
423 | (val t 1 1) | |
424 | (qspstr t 1 1 "str") |
|
424 | (qspstr t 1 1 "str") | |
425 | (strcomp t 2 2) |
|
425 | (strcomp t 2 2) | |
426 | (strfind t 2 3) |
|
426 | (strfind t 2 3) | |
427 | (strpos t 2 3) |
|
427 | (strpos t 2 3) | |
428 | ;; IF |
|
428 | ;; IF | |
429 | (iif t 2 3) |
|
429 | (iif t 2 3) | |
430 | ;; Subs |
|
430 | ;; Subs | |
431 | (gosub nil 1 10 "gosub" "gs") |
|
431 | (gosub nil 1 10 "gosub" "gs") | |
432 | (func t 1 10) |
|
432 | (func t 1 10) | |
433 | (exit nil 0 0) |
|
433 | (exit nil 0 0) | |
434 | ;; Jump |
|
434 | ;; Jump | |
435 | (jump nil 1 1) |
|
435 | (jump nil 1 1) | |
436 | ;; Dynamic |
|
436 | ;; Dynamic | |
437 | (dynamic nil 1 10) |
|
437 | (dynamic nil 1 10) | |
438 | (dyneval t 1 10) |
|
438 | (dyneval t 1 10) | |
439 | ;; Main window |
|
439 | ;; Main window | |
440 | (main-p nil 1 1 "*p") |
|
440 | (main-p nil 1 1 "*p") | |
441 | (main-pl nil 1 1 "*pl") |
|
441 | (main-pl nil 1 1 "*pl") | |
442 | (main-nl nil 0 1 "*nl") |
|
442 | (main-nl nil 0 1 "*nl") | |
443 | (maintxt t 0 0) |
|
443 | (maintxt t 0 0) | |
444 | (desc t 1 1) |
|
444 | (desc t 1 1) | |
445 | (main-clear nil 0 0 "*clear" "*clr") |
|
445 | (main-clear nil 0 0 "*clear" "*clr") | |
446 | ;; Aux window |
|
446 | ;; Aux window | |
447 | (showstat nil 1 1) |
|
447 | (showstat nil 1 1) | |
448 | (stat-p nil 1 1 "p") |
|
448 | (stat-p nil 1 1 "p") | |
449 | (stat-pl nil 1 1 "pl") |
|
449 | (stat-pl nil 1 1 "pl") | |
450 | (stat-nl nil 0 1 "nl") |
|
450 | (stat-nl nil 0 1 "nl") | |
451 | (stattxt t 0 0) |
|
451 | (stattxt t 0 0) | |
452 | (stat-clear nil 0 0 "clear" "clr") |
|
452 | (stat-clear nil 0 0 "clear" "clr") | |
453 | (cls nil 0 0) |
|
453 | (cls nil 0 0) | |
454 | ;; Dialog |
|
454 | ;; Dialog | |
455 | (msg nil 1 1) |
|
455 | (msg nil 1 1) | |
456 | ;; Acts |
|
456 | ;; Acts | |
457 | (showacts nil 1 1) |
|
457 | (showacts nil 1 1) | |
458 | (delact nil 1 1 "delact" "del act") |
|
458 | (delact nil 1 1 "delact" "del act") | |
459 | (curacts t 0 0) |
|
459 | (curacts t 0 0) | |
460 | (cla nil 0 0) |
|
460 | (cla nil 0 0) | |
461 | ;; Objects |
|
461 | ;; Objects | |
462 | (showobjs nil 1 1) |
|
462 | (showobjs nil 1 1) | |
463 | (addobj nil 1 3 "addobj" "add obj") |
|
463 | (addobj nil 1 3 "addobj" "add obj") | |
464 | (delobj nil 1 1 "delobj" "del obj") |
|
464 | (delobj nil 1 1 "delobj" "del obj") | |
465 | (killobj nil 0 1) |
|
465 | (killobj nil 0 1) | |
466 | (countobj t 0 0) |
|
466 | (countobj t 0 0) | |
467 | (getobj t 1 1) |
|
467 | (getobj t 1 1) | |
468 | ;; Menu |
|
468 | ;; Menu | |
469 | (menu nil 1 1) |
|
469 | (menu nil 1 1) | |
470 | ;; Sound |
|
470 | ;; Sound | |
471 | (play nil 1 2) |
|
471 | (play nil 1 2) | |
472 | (isplay t 1 1) |
|
472 | (isplay t 1 1) | |
473 | (close nil 1 1) |
|
473 | (close nil 1 1) | |
474 | (closeall nil 0 0 "close all") |
|
474 | (closeall nil 0 0 "close all") | |
475 | ;; Images |
|
475 | ;; Images | |
476 | (refint nil 0 0) |
|
476 | (refint nil 0 0) | |
477 | (view nil 0 1) |
|
477 | (view nil 0 1) | |
478 | ;; Fonts |
|
478 | ;; Fonts | |
479 | (rgb t 3 3) |
|
479 | (rgb t 3 3) | |
480 | ;; Input |
|
480 | ;; Input | |
481 | (showinput nil 1 1) |
|
481 | (showinput nil 1 1) | |
482 | (usertxt t 0 0 "user_text" "usrtxt") |
|
482 | (usertxt t 0 0 "user_text" "usrtxt") | |
483 | (cmdclear nil 0 0 "cmdclear" "cmdclr") |
|
483 | (cmdclear nil 0 0 "cmdclear" "cmdclr") | |
484 | (input t 1 1) |
|
484 | (input t 1 1) | |
485 | ;; Files |
|
485 | ;; Files | |
486 | (openqst nil 1 1) |
|
486 | (openqst nil 1 1) | |
487 | (addqst nil 1 1 "addqst" "addlib" "inclib") |
|
487 | (addqst nil 1 1 "addqst" "addlib" "inclib") | |
488 | (killqst nil 1 1 "killqst" "dellib" "freelib") |
|
488 | (killqst nil 1 1 "killqst" "dellib" "freelib") | |
489 |
(opengame nil 0 |
|
489 | (opengame nil 0 0) | |
490 |
(savegame nil 0 |
|
490 | (savegame nil 0 0) | |
491 | ;; Real time |
|
491 | ;; Real time | |
492 | (wait nil 1 1) |
|
492 | (wait nil 1 1) | |
493 | (msecscount t 0 0) |
|
493 | (msecscount t 0 0) | |
494 | (settimer nil 1 1)) |
|
494 | (settimer nil 1 1)) | |
495 |
|
495 | |||
496 | ;;; Expression |
|
496 | ;;; Expression | |
497 |
|
497 | |||
498 | (p:defrule expression or-expr) |
|
498 | (p:defrule expression or-expr) | |
499 |
|
499 | |||
500 | (p:defrule or-expr (and and-expr (* (and spaces? or-op spaces? and-expr))) |
|
500 | (p:defrule or-expr (and and-expr (* (and spaces? or-op spaces? and-expr))) | |
501 | (:function do-binop)) |
|
501 | (:function do-binop)) | |
502 |
|
502 | |||
503 | (p:defrule and-expr (and eq-expr (* (and spaces? and-op spaces? eq-expr))) |
|
503 | (p:defrule and-expr (and eq-expr (* (and spaces? and-op spaces? eq-expr))) | |
504 | (:function do-binop)) |
|
504 | (:function do-binop)) | |
505 |
|
505 | |||
506 | (p:defrule eq-expr (and cat-expr (* (and spaces? (or "<>" "<=" ">=" "=<" "=>" |
|
506 | (p:defrule eq-expr (and cat-expr (* (and spaces? (or "<>" "<=" ">=" "=<" "=>" | |
507 | #\= #\< #\> #\!) |
|
507 | #\= #\< #\> #\!) | |
508 | spaces? cat-expr))) |
|
508 | spaces? cat-expr))) | |
509 | (:function do-binop)) |
|
509 | (:function do-binop)) | |
510 |
|
510 | |||
511 | (p:defrule cat-expr (and sum-expr (* (and spaces? #\& spaces? (p:! expr-stopper) sum-expr))) |
|
511 | (p:defrule cat-expr (and sum-expr (* (and spaces? #\& spaces? (p:! expr-stopper) sum-expr))) | |
512 | (:lambda (list) |
|
512 | (:lambda (list) | |
513 | (do-binop (list (first list) (mapcar (lambda (l) |
|
513 | (do-binop (list (first list) (mapcar (lambda (l) | |
514 | (remove-nth l 3)) |
|
514 | (remove-nth l 3)) | |
515 | (second list)))))) |
|
515 | (second list)))))) | |
516 |
|
516 | |||
517 | (p:defrule sum-expr (and mod-expr (* (and spaces? (or #\+ #\-) spaces? mod-expr))) |
|
517 | (p:defrule sum-expr (and mod-expr (* (and spaces? (or #\+ #\-) spaces? mod-expr))) | |
518 | (:function do-binop)) |
|
518 | (:function do-binop)) | |
519 |
|
519 | |||
520 | (p:defrule mod-expr (and mul-expr (* (and spaces? (p:~ "mod") spaces? mul-expr))) |
|
520 | (p:defrule mod-expr (and mul-expr (* (and spaces? (p:~ "mod") spaces? mul-expr))) | |
521 | (:function do-binop)) |
|
521 | (:function do-binop)) | |
522 |
|
522 | |||
523 | (p:defrule mul-expr (and unary-expr (* (and spaces? (or #\* #\/) spaces? unary-expr))) |
|
523 | (p:defrule mul-expr (and unary-expr (* (and spaces? (or #\* #\/) spaces? unary-expr))) | |
524 | (:function do-binop)) |
|
524 | (:function do-binop)) | |
525 |
|
525 | |||
526 | (p:defrule unary-expr (and (p:? (or #\+ #\-)) atom-expr) |
|
526 | (p:defrule unary-expr (and (p:? (or #\+ #\-)) atom-expr) | |
527 | (:lambda (list) |
|
527 | (:lambda (list) | |
528 | (let ((expr (remove-nil list))) |
|
528 | (let ((expr (remove-nil list))) | |
529 | (if (= 1 (length expr)) |
|
529 | (if (= 1 (length expr)) | |
530 | (first expr) |
|
530 | (first expr) | |
531 | (intern-first expr))))) |
|
531 | (intern-first expr))))) | |
532 |
|
532 | |||
533 | (p:defrule atom-expr (and (or variable literal returning-intrinsic paren-expr) spaces?) |
|
533 | (p:defrule atom-expr (and (or variable literal returning-intrinsic paren-expr) spaces?) | |
534 | (:function first)) |
|
534 | (:function first)) | |
535 |
|
535 | |||
536 | (p:defrule paren-expr (and #\( spaces? expression spaces? #\)) |
|
536 | (p:defrule paren-expr (and #\( spaces? expression spaces? #\)) | |
537 | (:function third)) |
|
537 | (:function third)) | |
538 |
|
538 | |||
539 | (p:defrule or-op (p:~ "or") |
|
539 | (p:defrule or-op (p:~ "or") | |
540 | (:constant "or")) |
|
540 | (:constant "or")) | |
541 |
|
541 | |||
542 | (p:defrule and-op (p:~ "and") |
|
542 | (p:defrule and-op (p:~ "and") | |
543 | (:constant "and")) |
|
543 | (:constant "and")) | |
544 |
|
544 | |||
545 | ;;; Variables |
|
545 | ;;; Variables | |
546 |
|
546 | |||
547 | (p:defrule variable (and identifier (p:? array-index)) |
|
547 | (p:defrule variable (and identifier (p:? array-index)) | |
548 | (:destructure (id idx) |
|
548 | (:destructure (id idx) | |
549 | (list 'var id (or idx 0)))) |
|
549 | (list 'var id (or idx 0)))) | |
550 |
|
550 | |||
551 | (p:defrule array-index (and #\[ spaces? (p:? expression) spaces? #\]) |
|
551 | (p:defrule array-index (and #\[ spaces? (p:? expression) spaces? #\]) | |
552 | (:lambda (list) |
|
552 | (:lambda (list) | |
553 | (or (third list) :end))) |
|
553 | (or (third list) :end))) | |
554 |
|
554 | |||
555 | (p:defrule assignment (or kw-assignment plain-assignment) |
|
555 | (p:defrule assignment (or kw-assignment plain-assignment) | |
556 | (:destructure (var eq expr) |
|
556 | (:destructure (var eq expr) | |
557 | (declare (ignore eq)) |
|
557 | (declare (ignore eq)) | |
558 | (list 'set var expr))) |
|
558 | (list 'set var expr))) | |
559 |
|
559 | |||
560 | (p:defrule plain-assignment (and variable spaces? #\= spaces? expression) |
|
560 | (p:defrule plain-assignment (and variable spaces? #\= spaces? expression) | |
561 | (:function remove-nil)) |
|
561 | (:function remove-nil)) | |
562 | (p:defrule kw-assignment (and (or (p:~ "let") (p:~ "set")) spaces? plain-assignment) |
|
562 | (p:defrule kw-assignment (and (or (p:~ "let") (p:~ "set")) spaces? plain-assignment) | |
563 | (:function third)) |
|
563 | (:function third)) | |
564 |
|
564 | |||
565 | ;;; Non-string literals |
|
565 | ;;; Non-string literals | |
566 |
|
566 | |||
567 | (p:defrule literal (or qsp-string brace-string number)) |
|
567 | (p:defrule literal (or qsp-string brace-string number)) | |
568 |
|
568 | |||
569 | (p:defrule number (+ (or #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) |
|
569 | (p:defrule number (+ (or #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) | |
570 | (:lambda (list) |
|
570 | (:lambda (list) | |
571 | (parse-integer (p:text list)))) |
|
571 | (parse-integer (p:text list)))) |
@@ -1,192 +1,188 b'' | |||||
1 |
|
1 | |||
2 | (in-package sugar-qsp) |
|
2 | (in-package sugar-qsp) | |
3 |
|
3 | |||
4 | ;;;; Parenscript macros which make the parser's intermediate |
|
4 | ;;;; Parenscript macros which make the parser's intermediate | |
5 | ;;;; representation directly compilable by Parenscript |
|
5 | ;;;; representation directly compilable by Parenscript | |
6 | ;;;; Some utility macros for other .ps sources too. |
|
6 | ;;;; Some utility macros for other .ps sources too. | |
7 |
|
7 | |||
8 | ;;; Utils |
|
8 | ;;; Utils | |
9 |
|
9 | |||
10 | (ps:defpsmacro defm (path args &body body) |
|
10 | (ps:defpsmacro defm (path args &body body) | |
11 | `(setf ,path (lambda ,args ,@body))) |
|
11 | `(setf ,path (lambda ,args ,@body))) | |
12 |
|
12 | |||
13 | (ps:defpsmacro root (&rest path) |
|
13 | (ps:defpsmacro root (&rest path) | |
14 | `(ps:@ *sugar-q-s-p ,@path)) |
|
14 | `(ps:@ *sugar-q-s-p ,@path)) | |
15 |
|
15 | |||
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 conserving-vars (vars &body body) |
|
19 | (ps:defpsmacro conserving-vars (vars &body body) | |
20 | "Calls body with safely stored away VARS (whole arrays, both namespaces), and restores their values after that returning what BODY returns." |
|
20 | "Calls body with safely stored away VARS (whole arrays, both namespaces), and restores their values after that returning what BODY returns." | |
21 | `(let ((__conserved (list ,@(loop :for var :in vars |
|
21 | `(let ((__conserved (list ,@(loop :for var :in vars | |
22 | :collect `(root vars ,var))))) |
|
22 | :collect `(root vars ,var))))) | |
23 | ,@(loop :for var :in vars |
|
23 | ,@(loop :for var :in vars | |
24 | :collect `(setf (root vars ,var) (ps:create :num 0 :str ""))) |
|
24 | :collect `(setf (root vars ,var) (ps:create :num 0 :str ""))) | |
25 | (unwind-protect |
|
25 | (unwind-protect | |
26 | (progn ,@body) |
|
26 | (progn ,@body) | |
27 | (progn |
|
27 | (progn | |
28 | ,@(loop :for var :in vars |
|
28 | ,@(loop :for var :in vars | |
29 | :for i from 0 |
|
29 | :for i from 0 | |
30 | :collect `(setf (root vars ,var) (ps:@ __conserved ,i))))))) |
|
30 | :collect `(setf (root vars ,var) (ps:@ __conserved ,i))))))) | |
31 |
|
31 | |||
32 | ;;; Common |
|
32 | ;;; Common | |
33 |
|
33 | |||
34 | (defmacro defpsintrinsic (name) |
|
34 | (defmacro defpsintrinsic (name) | |
35 | `(ps:defpsmacro ,name (&rest args) |
|
35 | `(ps:defpsmacro ,name (&rest args) | |
36 | `(funcall (root lib ,',name) |
|
36 | `(funcall (root lib ,',name) | |
37 | ,@args))) |
|
37 | ,@args))) | |
38 |
|
38 | |||
39 | (defmacro defpsintrinsics (() &rest names) |
|
39 | (defmacro defpsintrinsics (() &rest names) | |
40 | `(progn ,@(loop :for name :in names |
|
40 | `(progn ,@(loop :for name :in names | |
41 | :collect `(defpsintrinsic ,name)))) |
|
41 | :collect `(defpsintrinsic ,name)))) | |
42 |
|
42 | |||
43 | (defpsintrinsics () |
|
43 | (defpsintrinsics () | |
44 | killvar obj loc no qspver curloc rand rnd qspmax qspmin killall copyarr arrsize arrpos arrcomp len mid ucase lcase trim replace instr isnum val qspstr strcomp strfind strpos iif gosub func dynamic dyneval main-p main-pl main-nl maintxt main-clear showstat stat-p stat-pl stat-nl stattxt stat-clear cls msg showacts delact curacts cla showobjs addobj delobj killobj countobj getobj menu play isplay close closeall refint view rgb showinput usertxt cmdclear input openqst addqst killqst opengame savegame wait msecscount settimer) |
|
44 | rand copyarr arrpos arrcomp instr isnum strcomp strfind strpos iif gosub func dynamic dyneval main-p main-pl main-nl maintxt main-clear stat-p stat-pl stat-nl stattxt stat-clear cls curacts addobj delobj killobj menu play isplay close closeall refint view rgb showinput usertxt cmdclear input openqst addqst killqst opengame savegame wait msecscount settimer) | |
45 |
|
45 | |||
46 | (ps:defpsmacro api-call (func &rest args) |
|
46 | (ps:defpsmacro api-call (func &rest args) | |
47 | `(funcall (root api ,func) ,@args)) |
|
47 | `(funcall (root api ,func) ,@args)) | |
48 |
|
48 | |||
49 | (ps:defpsmacro label-block (&body body) |
|
49 | (ps:defpsmacro label-block (&body body) | |
50 | `(block nil |
|
50 | `(block nil | |
51 | ,@(when (some #'keywordp body) |
|
51 | ,@(when (some #'keywordp body) | |
52 | '((defvar __labels))) |
|
52 | '((defvar __labels))) | |
53 | (tagbody |
|
53 | (tagbody | |
54 | ,@body) |
|
54 | ,@body) | |
55 | (values))) |
|
55 | (values))) | |
56 |
|
56 | |||
57 | (ps:defpsmacro str (&rest forms) |
|
57 | (ps:defpsmacro str (&rest forms) | |
58 | (cond ((zerop (length forms)) |
|
58 | (cond ((zerop (length forms)) | |
59 | "") |
|
59 | "") | |
60 | ((and (= 1 (length forms)) |
|
60 | ((and (= 1 (length forms)) | |
61 | (stringp (first forms))) |
|
61 | (stringp (first forms))) | |
62 | (first forms)) |
|
62 | (first forms)) | |
63 | (t |
|
63 | (t | |
64 | `(& ,@forms)))) |
|
64 | `(& ,@forms)))) | |
65 |
|
65 | |||
66 | ;;; 1loc |
|
66 | ;;; 1loc | |
67 |
|
67 | |||
68 | (ps:defpsmacro location ((name) &body body) |
|
68 | (ps:defpsmacro location ((name) &body body) | |
69 |
`(setf (root loc |
|
69 | `(setf (root locs ,name) | |
70 | (lambda () |
|
70 | (lambda () | |
71 | (label-block |
|
71 | (label-block | |
72 | ,@body |
|
72 | ,@body)))) | |
73 | (api-call update-acts))))) |
|
|||
74 |
|
73 | |||
75 | (ps:defpsmacro goto (target &rest args) |
|
74 | (ps:defpsmacro goto (target &rest args) | |
76 | `(progn |
|
75 | `(progn | |
77 | (funcall (root lib goto) ,target ,@args) |
|
76 | (funcall (root lib goto) ,target ,@args) | |
78 | (exit))) |
|
77 | (exit))) | |
79 |
|
78 | |||
80 | (ps:defpsmacro xgoto (target &rest args) |
|
79 | (ps:defpsmacro xgoto (target &rest args) | |
81 | `(progn |
|
80 | `(progn | |
82 | (funcall (root lib xgoto) ,target ,@args) |
|
81 | (funcall (root lib xgoto) ,target ,@args) | |
83 | (exit))) |
|
82 | (exit))) | |
84 |
|
83 | |||
85 | (ps:defpsmacro desc (target) |
|
84 | (ps:defpsmacro desc (target) | |
86 | (declare (ignore target)) |
|
85 | (declare (ignore target)) | |
87 | (report-error "DESC is not supported")) |
|
86 | (report-error "DESC is not supported")) | |
88 |
|
87 | |||
89 | ;;; 2var |
|
88 | ;;; 2var | |
90 |
|
89 | |||
91 | (ps:defpsmacro var (name index) |
|
90 | (ps:defpsmacro var (name index) | |
92 | `(api-call get-var ,(string name) ,index)) |
|
91 | `(api-call get-var ,(string name) ,index)) | |
93 |
|
92 | |||
94 | (ps:defpsmacro set ((var vname vindex) value) |
|
93 | (ps:defpsmacro set ((var vname vindex) value) | |
95 | (assert (eq var 'var)) |
|
94 | (assert (eq var 'var)) | |
96 | `(api-call set-var ,(string vname) ,vindex ,value)) |
|
95 | `(api-call set-var ,(string vname) ,vindex ,value)) | |
97 |
|
96 | |||
98 | ;;; 3expr |
|
97 | ;;; 3expr | |
99 |
|
98 | |||
100 | (ps:defpsmacro <> (op1 op2) |
|
99 | (ps:defpsmacro <> (op1 op2) | |
101 | `(not (equal ,op1 ,op2))) |
|
100 | `(not (equal ,op1 ,op2))) | |
102 |
|
101 | |||
103 | (ps:defpsmacro ! (op1 op2) |
|
102 | (ps:defpsmacro ! (op1 op2) | |
104 | `(not (equal ,op1 ,op2))) |
|
103 | `(not (equal ,op1 ,op2))) | |
105 |
|
104 | |||
106 | ;;; 4code |
|
105 | ;;; 4code | |
107 |
|
106 | |||
108 | (ps:defpsmacro exec (&body body) |
|
107 | (ps:defpsmacro exec (&body body) | |
109 | (format nil "javascript: ~{~A~^~%~}" (mapcar #'ps:ps* body))) |
|
108 | (format nil "javascript: ~{~A~^~%~}" (mapcar #'ps:ps* body))) | |
110 |
|
109 | |||
111 | ;;; 5arrays |
|
110 | ;;; 5arrays | |
112 |
|
111 | |||
113 | ;;; 6str |
|
112 | ;;; 6str | |
114 |
|
113 | |||
115 | (ps:defpsmacro & (&rest args) |
|
114 | (ps:defpsmacro & (&rest args) | |
116 | `(ps:chain "" (concat ,@args))) |
|
115 | `(ps:chain "" (concat ,@args))) | |
117 |
|
116 | |||
118 | ;;; 7if |
|
117 | ;;; 7if | |
119 |
|
118 | |||
120 | (ps:defpsmacro qspcond (&rest clauses) |
|
119 | (ps:defpsmacro qspcond (&rest clauses) | |
121 | `(cond ,@(loop :for clause :in clauses |
|
120 | `(cond ,@(loop :for clause :in clauses | |
122 | :collect (list (first clause) |
|
121 | :collect (list (first clause) | |
123 | `(tagbody ,@(rest clause)))))) |
|
122 | `(tagbody ,@(rest clause)))))) | |
124 |
|
123 | |||
125 | ;;; 8sub |
|
124 | ;;; 8sub | |
126 |
|
125 | |||
127 | ;;; 9loops |
|
126 | ;;; 9loops | |
128 | ;;; Yep, that's a huge kludge since Javascript doesn't support arbitrary labels |
|
127 | ;;; Yep, that's a huge kludge since Javascript doesn't support arbitrary labels | |
129 |
|
128 | |||
130 | (ps:defpsmacro jump (target) |
|
129 | (ps:defpsmacro jump (target) | |
131 | `(return-from ,(intern (string-upcase (second target))) |
|
130 | `(return-from ,(intern (string-upcase (second target))) | |
132 | (funcall (ps:getprop __labels ,target)))) |
|
131 | (funcall (ps:getprop __labels ,target)))) | |
133 |
|
132 | |||
134 | (ps:defpsmacro tagbody (&body body) |
|
133 | (ps:defpsmacro tagbody (&body body) | |
135 | (let ((funcs (list nil :__nil))) |
|
134 | (let ((funcs (list nil :__nil))) | |
136 | (dolist (form body) |
|
135 | (dolist (form body) | |
137 | (cond ((keywordp form) |
|
136 | (cond ((keywordp form) | |
138 | (setf (first funcs) (reverse (first funcs))) |
|
137 | (setf (first funcs) (reverse (first funcs))) | |
139 | (push form funcs) |
|
138 | (push form funcs) | |
140 | (push nil funcs)) |
|
139 | (push nil funcs)) | |
141 | (t |
|
140 | (t | |
142 | (push form (first funcs))))) |
|
141 | (push form (first funcs))))) | |
143 | (setf (first funcs) (reverse (first funcs))) |
|
142 | (setf (first funcs) (reverse (first funcs))) | |
144 | (setf funcs (reverse funcs)) |
|
143 | (setf funcs (reverse funcs)) | |
145 | (if (= 2 (length funcs)) |
|
144 | (if (= 2 (length funcs)) | |
146 | `(progn |
|
145 | `(progn | |
147 | ,@body) |
|
146 | ,@body) | |
148 | `(progn |
|
147 | `(progn | |
149 | (setf ,@(loop :for f :on funcs :by #'cddr |
|
148 | (setf ,@(loop :for f :on funcs :by #'cddr | |
150 | :append (list `(ps:@ __labels ,(first f)) |
|
149 | :append (list `(ps:@ __labels ,(first f)) | |
151 | `(block ,(intern (string-upcase (string (first f)))) |
|
150 | `(block ,(intern (string-upcase (string (first f)))) | |
152 | ,@(second f) |
|
151 | ,@(second f) | |
153 | ,@(when (third f) |
|
152 | ,@(when (third f) | |
154 | `((funcall |
|
153 | `((funcall | |
155 | (ps:getprop __labels ,(third f))))))))) |
|
154 | (ps:getprop __labels ,(third f))))))))) | |
156 | (jump (str "__nil")))))) |
|
155 | (jump (str "__nil")))))) | |
157 |
|
156 | |||
158 | (ps:defpsmacro exit () |
|
|||
159 | `(return-from nil (values))) |
|
|||
160 |
|
||||
161 | ;;; 10dynamic |
|
157 | ;;; 10dynamic | |
162 |
|
158 | |||
163 | (ps:defpsmacro qspblock (&body body) |
|
159 | (ps:defpsmacro qspblock (&body body) | |
164 | `(lambda () |
|
160 | `(lambda () | |
165 | (label-block |
|
161 | (label-block | |
166 | ,@body))) |
|
162 | ,@body))) | |
167 |
|
163 | |||
168 | ;;; 11main |
|
164 | ;;; 11main | |
169 |
|
165 | |||
170 | (ps:defpsmacro act (name img &body body) |
|
166 | (ps:defpsmacro act (name img &body body) | |
171 | `(api-call add-act ,name ,img |
|
167 | `(api-call add-act ,name ,img | |
172 | (lambda () |
|
168 | (lambda () | |
173 | (label-block |
|
169 | (label-block | |
174 | ,@body)))) |
|
170 | ,@body)))) | |
175 |
|
171 | |||
176 | ;;; 12aux |
|
172 | ;;; 12aux | |
177 |
|
173 | |||
178 | ;;; 13diag |
|
174 | ;;; 13diag | |
179 |
|
175 | |||
180 | ;;; 14act |
|
176 | ;;; 14act | |
181 |
|
177 | |||
182 | ;;; 15objs |
|
178 | ;;; 15objs | |
183 |
|
179 | |||
184 | ;;; 16menu |
|
180 | ;;; 16menu | |
185 |
|
181 | |||
186 | ;;; 17sound |
|
182 | ;;; 17sound | |
187 |
|
183 | |||
188 | ;;; 18img |
|
184 | ;;; 18img | |
189 |
|
185 | |||
190 | ;;; 19input |
|
186 | ;;; 19input | |
191 |
|
187 | |||
192 | ;;; 20time |
|
188 | ;;; 20time |
@@ -1,11 +1,13 b'' | |||||
1 |
|
1 | |||
2 | (defsystem sugar-qsp |
|
2 | (defsystem sugar-qsp | |
3 | :description "QSP compiler to monolithic HTML page" |
|
3 | :description "QSP compiler to monolithic HTML page" | |
4 | :depends-on (:alexandria :esrap |
|
4 | :depends-on (:alexandria :esrap | |
5 | :parenscript :parse-js :cl-uglify-js :flute) |
|
5 | :parenscript :parse-js :cl-uglify-js :flute) | |
6 | :pathname "src/" |
|
6 | :pathname "src/" | |
7 | :serial t |
|
7 | :serial t | |
8 | :components ((:file "package") |
|
8 | :components ((:file "package") | |
9 | (:file "ps-macros") |
|
9 | (:file "ps-macros") | |
|
10 | (:file "intrinsic-macros") | |||
|
11 | (:file "class") | |||
10 | (:file "main") |
|
12 | (:file "main") | |
11 | (:file "parser"))) |
|
13 | (:file "parser"))) |
General Comments 0
You need to be logged in to leave comments.
Login now