Show More
@@ -0,0 +1,24 b'' | |||||
|
1 | ||||
|
2 | (defsystem qsp-txt2web | |||
|
3 | :description "QSP compiler to monolithic HTML page" | |||
|
4 | :depends-on (:alexandria :system-locale ;; General | |||
|
5 | :esrap ;; Parsing | |||
|
6 | :parenscript :flute ;; Codegening | |||
|
7 | ) | |||
|
8 | :pathname "src/" | |||
|
9 | :serial t | |||
|
10 | :components ((:file "package") | |||
|
11 | (:file "utils") | |||
|
12 | (:file "l10n") | |||
|
13 | (:file "walker") | |||
|
14 | ||||
|
15 | (:file "patches") | |||
|
16 | (:file "js-syms") | |||
|
17 | (:file "main-macros") | |||
|
18 | (:file "ps-macros") | |||
|
19 | (:file "api-macros") | |||
|
20 | (:file "intrinsic-macros") | |||
|
21 | ||||
|
22 | (:file "class") | |||
|
23 | (:file "main") | |||
|
24 | (:file "parser"))) |
@@ -0,0 +1,19 b'' | |||||
|
1 | ||||
|
2 | (in-package txt2web) | |||
|
3 | ||||
|
4 | (defparameter *languages* (list "en" "ru")) | |||
|
5 | ||||
|
6 | (defparameter *l10n-strings* | |||
|
7 | (mapcan (lambda (lang) | |||
|
8 | (cons (intern (string-upcase lang) :keyword) | |||
|
9 | (read-code-from-string | |||
|
10 | (load-src | |||
|
11 | (concatenate 'string "strings/" lang ".sexp"))))) | |||
|
12 | *languages*)) | |||
|
13 | ||||
|
14 | (defun lformat (target key &rest args) | |||
|
15 | (let* ((lang (intern (string-upcase (first (system-locale:languages))) | |||
|
16 | :keyword)) | |||
|
17 | (strings (or (getf *l10n-strings* lang) | |||
|
18 | (getf *l10n-strings* :en)))) | |||
|
19 | (apply #'format target (getf strings key) args))) |
@@ -0,0 +1,24 b'' | |||||
|
1 | ||||
|
2 | (in-package txt2web) | |||
|
3 | ||||
|
4 | (defun src-file (filename) | |||
|
5 | (uiop/pathname:merge-pathnames* | |||
|
6 | filename | |||
|
7 | (asdf:system-source-directory :txt2web))) | |||
|
8 | ||||
|
9 | (defun read-progn-from-string (string) | |||
|
10 | `(progn | |||
|
11 | ,@(read-code-from-string string))) | |||
|
12 | ||||
|
13 | (defun read-code-from-string (string) | |||
|
14 | (with-input-from-string (in string) | |||
|
15 | (let ((*package* *package*)) | |||
|
16 | (loop :for form := (read in nil :eof) | |||
|
17 | :until (eq form :eof) | |||
|
18 | :when (eq (first form) 'cl:in-package) | |||
|
19 | :do (setf *package* (find-package (second form))) | |||
|
20 | :else | |||
|
21 | :collect form)))) | |||
|
22 | ||||
|
23 | (defun load-src (filename) | |||
|
24 | (alexandria:read-file-into-string (src-file filename))) |
@@ -0,0 +1,12 b'' | |||||
|
1 | (:usage "Usage: ~A <source> [options] | |||
|
2 | Options: | |||
|
3 | -o <filename> - Output filename | |||
|
4 | --js <filenames...> - List of extra .js files to include in the game | |||
|
5 | --css <filenames...> - List of .css files to include in the game. Default is in extras/default.css | |||
|
6 | --body <filename> - Alternative page body. Default is in extras/body.html | |||
|
7 | ||||
|
8 | -c - Just compile the game to a .js file without making it a full web page | |||
|
9 | --beautify - Make the JS content pretty. By default it gets minified. | |||
|
10 | ||||
|
11 | Note that the files in extras/ are not actually used. They're just there for the reference~%") | |||
|
12 |
@@ -0,0 +1,12 b'' | |||||
|
1 | (:usage "Использование: ~A <source> [options] | |||
|
2 | Опции: | |||
|
3 | -o <имя файла> - Имя .html файла для записи скомпилированной игры | |||
|
4 | --js <имена файлов...> - Список дополнительных .js файлов | |||
|
5 | --css <имена файлов...> - Список .css файлов. Стиль по-умолчанию - в файле extras/default.css | |||
|
6 | --body <имя файла> - Альтернативное тело страницы. Тело по-умолчанию - в файле extras/body.html | |||
|
7 | ||||
|
8 | -c - Просто скомпилировать игру в .js файл, не компонуя полную .html страницу | |||
|
9 | --beautify - Не минифицировать .js скрипты | |||
|
10 | ||||
|
11 | Файлы в extras на самом деле компилятором не используются. Используйте только как образец.~%") | |||
|
12 |
@@ -1,39 +1,46 b'' | |||||
1 |
|
1 | |||
2 | BIN = sugar-qsp |
|
2 | BIN = txt2web | |
|
3 | PKG = $(BIN) | |||
|
4 | DIST = txt2web.tar.xz | |||
3 |
|
5 | |||
4 | LISP = sbcl |
|
6 | LISP = sbcl | |
5 |
|
7 | |||
6 | all: $(BIN) |
|
8 | all: $(BIN) | |
7 |
|
9 | |||
|
10 | dist: $(DIST) | |||
|
11 | ||||
8 | graphs: diagrams.png |
|
12 | graphs: diagrams.png | |
9 |
|
13 | |||
10 | $(BIN): src/*.lisp src/*.ps |
|
14 | $(BIN): *.asd src/*.lisp src/*.ps strings/*.sexp | |
11 | buildapp.$(LISP) --asdf-path .\ |
|
15 | buildapp.$(LISP) --asdf-path .\ | |
12 | --asdf-tree .qlot/dists\ |
|
16 | --asdf-tree .qlot/dists\ | |
13 |
--load-system |
|
17 | --load-system $(PKG)\ | |
14 |
--entry |
|
18 | --entry $(PKG):entry-point\ | |
15 | --compress-core\ |
|
|||
16 | --output $(BIN) |
|
19 | --output $(BIN) | |
17 |
|
20 | |||
18 | install-deps: |
|
21 | install-deps: | |
19 | sbcl --load install-deps.lisp |
|
22 | sbcl --load install-deps.lisp | |
20 |
|
23 | |||
21 | update-deps: |
|
24 | update-deps: | |
22 | sbcl --load update-deps.lisp |
|
25 | sbcl --load update-deps.lisp | |
23 |
|
26 | |||
24 | %.png: %.dot |
|
27 | %.png: %.dot | |
25 | dot $< -T png -o $@ |
|
28 | dot $< -T png -o $@ | |
26 |
|
29 | |||
27 | dist: $(BIN) |
|
30 | $(DIST): $(BIN) extras/* | |
28 |
tar cfvJ |
|
31 | tar cfvJ $@ $< extras | |
|
32 | ||||
|
33 | upload: $(DIST) | |||
|
34 | curl --upload-file $(DIST) https://transfer.sh/$(DIST) | |||
|
35 | @echo | |||
29 |
|
36 | |||
30 | distclean: clean clean-deps |
|
37 | distclean: clean clean-deps | |
31 |
|
38 | |||
32 | clean: |
|
39 | clean: | |
33 | -rm sugar-qsp |
|
40 | rm -f $(BIN) $(DIST) | |
34 |
|
41 | |||
35 | clean-deps: |
|
42 | clean-deps: | |
36 |
|
|
43 | rm qlfile.lock | |
37 |
|
|
44 | rm -rf .qlot | |
38 |
|
45 | |||
39 | .PHONY: all graphs install-deps update-deps clean |
|
46 | .PHONY: all graphs install-deps update-deps clean upload |
@@ -1,44 +1,44 b'' | |||||
1 | (инструкции на Русском - внизу) |
|
1 | (инструкции на Русском - внизу) | |
2 |
|
2 | |||
3 | # sugar-qsp |
|
3 | # txt2web | |
4 | Compiler for QSP games which creates monolithic HTML pages. |
|
4 | Compiler for QSP games which creates monolithic HTML pages. | |
5 |
|
5 | |||
6 | ## Usage |
|
6 | ## Usage | |
7 |
|
7 | |||
8 | There are three mastery levels |
|
8 | There are three mastery levels | |
9 |
|
9 | |||
10 | 1. Just build me the game:<br/> |
|
10 | 1. Just build me the game:<br/> | |
11 |
` |
|
11 | `txt2web game.txt`<br/> | |
12 | And it will create the game in game.html |
|
12 | And it will create the game in game.html | |
13 |
|
13 | |||
14 | 2. I know what I'm doing:<br/> |
|
14 | 2. I know what I'm doing:<br/> | |
15 |
` |
|
15 | `txt2web game.txt -o game.html --body body.html --js jquery.js my-js-library.js --css styles/*.css`<br/> | |
16 | All options are self-explanatory. The result is a monolithic html specified |
|
16 | All options are self-explanatory. The result is a monolithic html specified | |
17 | with the `-o` option. Default `body.html` (used by the first mastery level) can |
|
17 | with the `-o` option. Default `body.html` (used by the first mastery level) can | |
18 | be found in `extas` directory. |
|
18 | be found in `extas` directory. | |
19 |
|
19 | |||
20 | 3. I'm a frontend developer!<br/> |
|
20 | 3. I'm a frontend developer!<br/> | |
21 |
` |
|
21 | `txt2web game.txt -c -o game.js`<br/> | |
22 | It just builds the game script into a js you can put on your website. To run |
|
22 | It just builds the game script into a js you can put on your website. To run | |
23 | the game execute `SugarQSP.start()` |
|
23 | the game execute `SugarQSP.start()` | |
24 |
|
24 | |||
25 | # sugar-qsp |
|
25 | # txt2web | |
26 | Компилятор для игр на QSP создающий монолитные страницы на HTML. |
|
26 | Компилятор для игр на QSP создающий монолитные страницы на HTML. | |
27 |
|
27 | |||
28 | ## Инструкции |
|
28 | ## Инструкции | |
29 |
|
29 | |||
30 | Есть три уровня мастерства. |
|
30 | Есть три уровня мастерства. | |
31 |
|
31 | |||
32 | 1. **Просто собери мне игру**:<br/> |
|
32 | 1. **Просто собери мне игру**:<br/> | |
33 |
` |
|
33 | `txt2web game.txt`<br/> | |
34 | Создаст игру в game.html |
|
34 | Создаст игру в game.html | |
35 |
|
35 | |||
36 | 2. **Я знаю что делаю**:<br/> |
|
36 | 2. **Я знаю что делаю**:<br/> | |
37 |
` |
|
37 | `txt2web game.txt -o game.html --body body.html --js jquery.js my-js-library.js --css styles/*.css`<br/> | |
38 | Если вы знаете что делаете, то для вас смысл опций очевиден. `body.html` и `default.css` |
|
38 | Если вы знаете что делаете, то для вас смысл опций очевиден. `body.html` и `default.css` | |
39 | лежат в каталоге `extras`. |
|
39 | лежат в каталоге `extras`. | |
40 |
|
40 | |||
41 | 3. **Я - фронтендер!**<br/> |
|
41 | 3. **Я - фронтендер!**<br/> | |
42 |
` |
|
42 | `txt2web game.txt -c -o game.js`<br/> | |
43 | Просто соберёт игру в Javascript файл который вы можете разместить на своём |
|
43 | Просто соберёт игру в Javascript файл который вы можете разместить на своём | |
44 | сайте как вам угодно. |
|
44 | сайте как вам угодно. |
@@ -1,15 +1,17 b'' | |||||
1 |
|
1 | |||
|
2 | * Localization | |||
2 | * Save-load game in slots |
|
3 | * Save-load game in slots | |
3 |
|
4 | |||
4 | * CLI build for Windows |
|
5 | * CLI build for Windows | |
5 |
|
6 | |||
6 | * Reporting error lines in the parser |
|
7 | * Reporting error lines in the parser | |
7 | * Report duplicate label (in the parser) |
|
8 | * Report duplicate label (in the parser) | |
8 | * reporting error lines at runtime (by storing them in every form in the parser |
|
9 | * reporting error lines at runtime (by storing them in every form in the parser | |
9 | * Report JUMP with missing label (in tagbody) |
|
10 | * Report JUMP with missing label (in tagbody) | |
|
11 | * Localizing parser errors... | |||
10 |
|
12 | |||
11 | * Build Istreblenie |
|
13 | * Build Istreblenie | |
12 | * Build Цветохимия |
|
14 | * Build Цветохимия | |
13 |
|
15 | |||
14 | * Windows GUI (for the compiler) |
|
16 | * Windows GUI (for the compiler) | |
15 | * Resizable frames |
|
17 | * Resizable frames |
@@ -1,10 +1,13 b'' | |||||
1 | ql alexandria |
|
1 | ql alexandria | |
|
2 | ql system-locale | |||
2 | ql esrap |
|
3 | ql esrap | |
3 | ql parenscript |
|
4 | ql parenscript | |
4 | ql flute |
|
5 | ql flute | |
5 |
|
6 | |||
6 | ql cl-ppcre |
|
7 | ql cl-ppcre | |
7 | ql anaphora |
|
8 | ql anaphora | |
8 | ql named-readtables |
|
9 | ql named-readtables | |
9 | ql assoc-utils |
|
10 | ql assoc-utils | |
10 | ql let-over-lambda |
|
11 | ql let-over-lambda | |
|
12 | ql documentation-utils | |||
|
13 | ql trivial-indent |
@@ -1,40 +1,52 b'' | |||||
1 | ("quicklisp" . |
|
1 | ("quicklisp" . | |
2 | (:class qlot/source/dist:source-dist |
|
2 | (:class qlot/source/dist:source-dist | |
3 | :initargs (:distribution "http://beta.quicklisp.org/dist/quicklisp.txt" :%version :latest) |
|
3 | :initargs (:distribution "http://beta.quicklisp.org/dist/quicklisp.txt" :%version :latest) | |
4 | :version "2020-04-27")) |
|
4 | :version "2020-04-27")) | |
5 | ("alexandria" . |
|
5 | ("alexandria" . | |
6 | (:class qlot/source/ql:source-ql |
|
6 | (:class qlot/source/ql:source-ql | |
7 | :initargs (:%version :latest) |
|
7 | :initargs (:%version :latest) | |
8 | :version "ql-2020-04-27")) |
|
8 | :version "ql-2020-04-27")) | |
|
9 | ("system-locale" . | |||
|
10 | (:class qlot/source/ql:source-ql | |||
|
11 | :initargs (:%version :latest) | |||
|
12 | :version "ql-2020-04-27")) | |||
9 | ("esrap" . |
|
13 | ("esrap" . | |
10 | (:class qlot/source/ql:source-ql |
|
14 | (:class qlot/source/ql:source-ql | |
11 | :initargs (:%version :latest) |
|
15 | :initargs (:%version :latest) | |
12 | :version "ql-2020-04-27")) |
|
16 | :version "ql-2020-04-27")) | |
13 | ("parenscript" . |
|
17 | ("parenscript" . | |
14 | (:class qlot/source/ql:source-ql |
|
18 | (:class qlot/source/ql:source-ql | |
15 | :initargs (:%version :latest) |
|
19 | :initargs (:%version :latest) | |
16 | :version "ql-2020-04-27")) |
|
20 | :version "ql-2020-04-27")) | |
17 | ("flute" . |
|
21 | ("flute" . | |
18 | (:class qlot/source/ql:source-ql |
|
22 | (:class qlot/source/ql:source-ql | |
19 | :initargs (:%version :latest) |
|
23 | :initargs (:%version :latest) | |
20 | :version "ql-2020-04-27")) |
|
24 | :version "ql-2020-04-27")) | |
21 | ("cl-ppcre" . |
|
25 | ("cl-ppcre" . | |
22 | (:class qlot/source/ql:source-ql |
|
26 | (:class qlot/source/ql:source-ql | |
23 | :initargs (:%version :latest) |
|
27 | :initargs (:%version :latest) | |
24 | :version "ql-2020-04-27")) |
|
28 | :version "ql-2020-04-27")) | |
25 | ("anaphora" . |
|
29 | ("anaphora" . | |
26 | (:class qlot/source/ql:source-ql |
|
30 | (:class qlot/source/ql:source-ql | |
27 | :initargs (:%version :latest) |
|
31 | :initargs (:%version :latest) | |
28 | :version "ql-2020-04-27")) |
|
32 | :version "ql-2020-04-27")) | |
29 | ("named-readtables" . |
|
33 | ("named-readtables" . | |
30 | (:class qlot/source/ql:source-ql |
|
34 | (:class qlot/source/ql:source-ql | |
31 | :initargs (:%version :latest) |
|
35 | :initargs (:%version :latest) | |
32 | :version "ql-2020-04-27")) |
|
36 | :version "ql-2020-04-27")) | |
33 | ("assoc-utils" . |
|
37 | ("assoc-utils" . | |
34 | (:class qlot/source/ql:source-ql |
|
38 | (:class qlot/source/ql:source-ql | |
35 | :initargs (:%version :latest) |
|
39 | :initargs (:%version :latest) | |
36 | :version "ql-2020-04-27")) |
|
40 | :version "ql-2020-04-27")) | |
37 | ("let-over-lambda" . |
|
41 | ("let-over-lambda" . | |
38 | (:class qlot/source/ql:source-ql |
|
42 | (:class qlot/source/ql:source-ql | |
39 | :initargs (:%version :latest) |
|
43 | :initargs (:%version :latest) | |
40 | :version "ql-2020-04-27")) |
|
44 | :version "ql-2020-04-27")) | |
|
45 | ("documentation-utils" . | |||
|
46 | (:class qlot/source/ql:source-ql | |||
|
47 | :initargs (:%version :latest) | |||
|
48 | :version "ql-2020-04-27")) | |||
|
49 | ("trivial-indent" . | |||
|
50 | (:class qlot/source/ql:source-ql | |||
|
51 | :initargs (:%version :latest) | |||
|
52 | :version "ql-2020-04-27")) |
@@ -1,32 +1,14 b'' | |||||
1 |
|
1 | |||
2 | (in-package sugar-qsp) |
|
2 | (in-package sugar-qsp) | |
3 |
|
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 read-code-from-string (string) |
|
|||
10 | (with-input-from-string (in string) |
|
|||
11 | (let ((*package* *package*)) |
|
|||
12 | `(progn |
|
|||
13 | ,@(loop :for form := (read in nil :eof) |
|
|||
14 | :until (eq form :eof) |
|
|||
15 | :when (eq (first form) 'cl:in-package) |
|
|||
16 | :do (setf *package* (find-package (second form))) |
|
|||
17 | :else |
|
|||
18 | :collect form))))) |
|
|||
19 | (defun load-src (filename) |
|
|||
20 | (alexandria:read-file-into-string (src-file filename)))) |
|
|||
21 |
|
||||
22 | (defclass compiler () |
|
4 | (defclass compiler () | |
23 | ((body :accessor body :initform #.(load-src "extras/body.html")) |
|
5 | ((body :accessor body :initform #.(load-src "extras/body.html")) | |
24 | (css :accessor css :initform (list #.(load-src "extras/default.css"))) |
|
6 | (css :accessor css :initform (list #.(load-src "extras/default.css"))) | |
25 | (js :accessor js :initform (reverse |
|
7 | (js :accessor js :initform (reverse | |
26 | (list |
|
8 | (list | |
27 |
'#.(read- |
|
9 | '#.(read-progn-from-string (load-src "src/main.ps")) | |
28 |
'#.(read- |
|
10 | '#.(read-progn-from-string (load-src "src/api.ps")) | |
29 |
'#.(read- |
|
11 | '#.(read-progn-from-string (load-src "src/intrinsics.ps"))))) | |
30 | (compile :accessor compile-only :initarg :compile) |
|
12 | (compile :accessor compile-only :initarg :compile) | |
31 | (target :accessor target :initarg :target) |
|
13 | (target :accessor target :initarg :target) | |
32 | (beautify :accessor beautify :initarg :beautify))) |
|
14 | (beautify :accessor beautify :initarg :beautify))) |
@@ -1,8 +1,8 b'' | |||||
1 |
|
1 | |||
2 |
(in-package |
|
2 | (in-package txt2web.main) | |
3 |
|
3 | |||
4 | (defmacro+ps api-call (name &rest args) |
|
4 | (defmacro+ps api-call (name &rest args) | |
5 |
`(,(intern (string-upcase name) " |
|
5 | `(,(intern (string-upcase name) "TXT2WEB.API") ,@args)) | |
6 |
|
6 | |||
7 | (defpsmacro has (key obj) |
|
7 | (defpsmacro has (key obj) | |
8 | `(chain ,obj (has-own-property ,key))) |
|
8 | `(chain ,obj (has-own-property ,key))) |
@@ -1,163 +1,153 b'' | |||||
1 |
|
1 | |||
2 |
(in-package |
|
2 | (in-package txt2web) | |
3 |
|
3 | |||
4 | (defvar *app-name* "") |
|
4 | (defvar *app-name* "") | |
5 |
|
5 | |||
6 | (defun entry-point-no-args () |
|
6 | (defun entry-point-no-args () | |
7 | (entry-point uiop:*command-line-arguments*)) |
|
7 | (entry-point uiop:*command-line-arguments*)) | |
8 |
|
8 | |||
9 | (defun entry-point (args) |
|
9 | (defun entry-point (args) | |
10 | (setf *app-name* (first args)) |
|
10 | (setf *app-name* (first args)) | |
11 |
(let ((*package* (find-package : |
|
11 | (let ((*package* (find-package :txt2web))) | |
12 | (catch :terminate |
|
12 | (catch :terminate | |
13 | (let ((compiler (apply #'make-instance 'compiler (parse-opts (rest args))))) |
|
13 | (let ((compiler (apply #'make-instance 'compiler (parse-opts (rest args))))) | |
14 | (write-compiled-file compiler)))) |
|
14 | (write-compiled-file compiler)))) | |
15 | (values)) |
|
15 | (values)) | |
16 |
|
16 | |||
17 | (defun parse-opts (args) |
|
17 | (defun parse-opts (args) | |
18 | (let ((mode :sources) |
|
18 | (let ((mode :sources) | |
19 | (data (list :sources nil :target nil :js nil :css nil :body nil :compile nil :beautify nil))) |
|
19 | (data (list :sources nil :target nil :js nil :css nil :body nil :compile nil :beautify nil))) | |
20 | (loop :for arg :in args |
|
20 | (loop :for arg :in args | |
21 | :do (alexandria:switch (arg :test #'string=) |
|
21 | :do (alexandria:switch (arg :test #'string=) | |
22 | ("-o" (setf mode :target)) |
|
22 | ("-o" (setf mode :target)) | |
23 | ("--js" (setf mode :js)) |
|
23 | ("--js" (setf mode :js)) | |
24 | ("--css" (setf mode :css)) |
|
24 | ("--css" (setf mode :css)) | |
25 | ("--body" (setf mode :body)) |
|
25 | ("--body" (setf mode :body)) | |
26 | ("-c" (setf (getf data :compile) t)) |
|
26 | ("-c" (setf (getf data :compile) t)) | |
27 | ("--beautify" (setf (getf data :beautify) t)) |
|
27 | ("--beautify" (setf (getf data :beautify) t)) | |
28 | (t (push arg (getf data mode))))) |
|
28 | (t (push arg (getf data mode))))) | |
29 | (unless (< 0 (length (getf data :sources))) |
|
29 | (unless (< 0 (length (getf data :sources))) | |
30 | (report-error "There should be at least one source")) |
|
30 | (report-error "There should be at least one source")) | |
31 | (unless (> 1 (length (getf data :target))) |
|
31 | (unless (> 1 (length (getf data :target))) | |
32 | (report-error "There should be no more than one target")) |
|
32 | (report-error "There should be no more than one target")) | |
33 | (unless (> 1 (length (getf data :body))) |
|
33 | (unless (> 1 (length (getf data :body))) | |
34 | (report-error "There should be no more than one body")) |
|
34 | (report-error "There should be no more than one body")) | |
35 | (unless (getf data :target) |
|
35 | (unless (getf data :target) | |
36 | (setf (getf data :target) |
|
36 | (setf (getf data :target) | |
37 | (let* ((sources (first (getf data :sources))) |
|
37 | (let* ((sources (first (getf data :sources))) | |
38 | (tokens (uiop:split-string sources :separator ".")) |
|
38 | (tokens (uiop:split-string sources :separator ".")) | |
39 | (target (format nil "~{~A~^.~}.html" |
|
39 | (target (format nil "~{~A~^.~}.html" | |
40 | (butlast tokens)))) |
|
40 | (butlast tokens)))) | |
41 | (list target)))) |
|
41 | (list target)))) | |
42 | (list :sources (getf data :sources) |
|
42 | (list :sources (getf data :sources) | |
43 | :target (first (getf data :target)) |
|
43 | :target (first (getf data :target)) | |
44 | :js (getf data :js) |
|
44 | :js (getf data :js) | |
45 | :css (getf data :css) |
|
45 | :css (getf data :css) | |
46 | :body (first (getf data :body)) |
|
46 | :body (first (getf data :body)) | |
47 | :compile (getf data :compile) |
|
47 | :compile (getf data :compile) | |
48 | :beautify (getf data :beautify)))) |
|
48 | :beautify (getf data :beautify)))) | |
49 |
|
49 | |||
50 | (defun print-usage () |
|
50 | (defun print-usage () | |
51 |
(format t |
|
51 | (lformat t :usage *app-name*)) | |
52 | (format t "Options:~%") |
|
|||
53 | (format t " -o <filename> - Output filename~%") |
|
|||
54 | (format t " --js <filenames...> - List of extra .js files to include in the game~%") |
|
|||
55 | (format t " --css <filenames...> - List of .css files to include in the game. Default is in extras/default.css~%") |
|
|||
56 | (format t " --body <filename> - Alternative page body. Default is in extras/body.html~%") |
|
|||
57 | (format t "~%") |
|
|||
58 | (format t " -c - Just compile the game to a .js file without making it a full web page~%") |
|
|||
59 | (format t " --beautify - Make the JS content pretty. By default it gets minified.~%") |
|
|||
60 | (format t "~%") |
|
|||
61 | (format t "Note that the files in extras/ are not actually used. They're just there for the reference")) |
|
|||
62 |
|
52 | |||
63 | (defun parse-file (filename) |
|
53 | (defun parse-file (filename) | |
64 |
(p:parse ' |
|
54 | (p:parse 'txt2web-grammar | |
65 | (alexandria:read-file-into-string filename))) |
|
55 | (alexandria:read-file-into-string filename))) | |
66 |
|
56 | |||
67 | (defun report-error (fmt &rest args) |
|
57 | (defun report-error (fmt &rest args) | |
68 | (format t "ERROR: ~A~%" (apply #'format nil fmt args)) |
|
58 | (format t "ERROR: ~A~%" (apply #'format nil fmt args)) | |
69 | (print-usage) |
|
59 | (print-usage) | |
70 | (throw :terminate nil)) |
|
60 | (throw :terminate nil)) | |
71 |
|
61 | |||
72 | ;;; JS |
|
62 | ;;; JS | |
73 |
|
63 | |||
74 | (defun minify-package (package-designator minify prefix) |
|
64 | (defun minify-package (package-designator minify prefix) | |
75 | (setf (ps:ps-package-prefix package-designator) prefix) |
|
65 | (setf (ps:ps-package-prefix package-designator) prefix) | |
76 | (if minify |
|
66 | (if minify | |
77 | (ps:obfuscate-package package-designator) |
|
67 | (ps:obfuscate-package package-designator) | |
78 | (ps:unobfuscate-package package-designator))) |
|
68 | (ps:unobfuscate-package package-designator))) | |
79 |
|
69 | |||
80 | (defmethod js-sources ((compiler compiler)) |
|
70 | (defmethod js-sources ((compiler compiler)) | |
81 | (let ((ps:*ps-print-pretty* (beautify compiler))) |
|
71 | (let ((ps:*ps-print-pretty* (beautify compiler))) | |
82 | (cond ((beautify compiler) |
|
72 | (cond ((beautify compiler) | |
83 |
(minify-package " |
|
73 | (minify-package "TXT2WEB.MAIN" nil "qsp_") | |
84 |
(minify-package " |
|
74 | (minify-package "TXT2WEB.API" nil "qsp_api_") | |
85 |
(minify-package " |
|
75 | (minify-package "TXT2WEB.LIB" nil "qsp_lib_")) | |
86 | (t |
|
76 | (t | |
87 |
(minify-package " |
|
77 | (minify-package "TXT2WEB.MAIN" t "_") | |
88 |
(minify-package " |
|
78 | (minify-package "TXT2WEB.API" t "a_") | |
89 |
(minify-package " |
|
79 | (minify-package "TXT2WEB.LIB" t "l_"))) | |
90 | (format nil "~{~A~^~%~%~}" (mapcar #'ps:ps* (reverse (js compiler)))))) |
|
80 | (format nil "~{~A~^~%~%~}" (mapcar #'ps:ps* (reverse (js compiler)))))) | |
91 |
|
81 | |||
92 | ;;; CSS |
|
82 | ;;; CSS | |
93 |
|
83 | |||
94 | (defmethod css-sources ((compiler compiler)) |
|
84 | (defmethod css-sources ((compiler compiler)) | |
95 | (format nil "~{~A~^~%~%~}" (css compiler))) |
|
85 | (format nil "~{~A~^~%~%~}" (css compiler))) | |
96 |
|
86 | |||
97 | ;;; HTML |
|
87 | ;;; HTML | |
98 |
|
88 | |||
99 | (defmethod html-sources ((compiler compiler)) |
|
89 | (defmethod html-sources ((compiler compiler)) | |
100 | (let ((flute:*escape-html* nil) |
|
90 | (let ((flute:*escape-html* nil) | |
101 | (body-template (body compiler)) |
|
91 | (body-template (body compiler)) | |
102 | (js (js-sources compiler)) |
|
92 | (js (js-sources compiler)) | |
103 | (css (css-sources compiler))) |
|
93 | (css (css-sources compiler))) | |
104 | (with-output-to-string (out) |
|
94 | (with-output-to-string (out) | |
105 | (write |
|
95 | (write | |
106 | (flute:h |
|
96 | (flute:h | |
107 | (html |
|
97 | (html | |
108 | (head |
|
98 | (head | |
109 | (title "SugarQSP")) |
|
99 | (title "SugarQSP")) | |
110 | (body |
|
100 | (body | |
111 | body-template |
|
101 | body-template | |
112 | (style css) |
|
102 | (style css) | |
113 | (script js)))) |
|
103 | (script js)))) | |
114 | :stream out |
|
104 | :stream out | |
115 | :pretty nil)))) |
|
105 | :pretty nil)))) | |
116 |
|
106 | |||
117 | (defun filename-game (filename) |
|
107 | (defun filename-game (filename) | |
118 | (let ((filename (alexandria:lastcar (uiop:split-string filename :separator "/")))) |
|
108 | (let ((filename (alexandria:lastcar (uiop:split-string filename :separator "/")))) | |
119 | (format nil "~{~A~^.~}" (butlast (uiop:split-string filename :separator "."))))) |
|
109 | (format nil "~{~A~^.~}" (butlast (uiop:split-string filename :separator "."))))) | |
120 |
|
110 | |||
121 | (defmethod initialize-instance ((compiler compiler) &key sources ((:js js-files)) ((:css css-files)) ((:body body-file)) compile &allow-other-keys) |
|
111 | (defmethod initialize-instance ((compiler compiler) &key sources ((:js js-files)) ((:css css-files)) ((:body body-file)) compile &allow-other-keys) | |
122 | (call-next-method) |
|
112 | (call-next-method) | |
123 | (with-slots (body css js) |
|
113 | (with-slots (body css js) | |
124 | compiler |
|
114 | compiler | |
125 | ;; Compile the game's JS |
|
115 | ;; Compile the game's JS | |
126 | (dolist (source sources) |
|
116 | (dolist (source sources) | |
127 | (let ((ps (parse-file source)) |
|
117 | (let ((ps (parse-file source)) | |
128 | (game-name (filename-game source))) |
|
118 | (game-name (filename-game source))) | |
129 | (destructuring-bind (kw &rest locations) |
|
119 | (destructuring-bind (kw &rest locations) | |
130 | ps |
|
120 | ps | |
131 | (unless (eq kw 'lib:game) |
|
121 | (unless (eq kw 'lib:game) | |
132 | (report-error "Internal error!")) |
|
122 | (report-error "Internal error!")) | |
133 | (push |
|
123 | (push | |
134 | `(lib:game (,game-name) ,@locations) |
|
124 | `(lib:game (,game-name) ,@locations) | |
135 | js)))) |
|
125 | js)))) | |
136 | ;; Does the user need us to do anything else |
|
126 | ;; Does the user need us to do anything else | |
137 | (unless compile |
|
127 | (unless compile | |
138 | ;; Read in body |
|
128 | ;; Read in body | |
139 | (when body-file |
|
129 | (when body-file | |
140 | (setf body |
|
130 | (setf body | |
141 | (alexandria:read-file-into-string body-file))) |
|
131 | (alexandria:read-file-into-string body-file))) | |
142 | ;; Include js files |
|
132 | ;; Include js files | |
143 | (dolist (js-file js-files) |
|
133 | (dolist (js-file js-files) | |
144 | (push (format nil "////// Included file ~A~%~A" js-file |
|
134 | (push (format nil "////// Included file ~A~%~A" js-file | |
145 | (alexandria:read-file-into-string js-file)) |
|
135 | (alexandria:read-file-into-string js-file)) | |
146 | js)) |
|
136 | js)) | |
147 | ;; Include css files |
|
137 | ;; Include css files | |
148 | (when css-files |
|
138 | (when css-files | |
149 | ;; User option overrides the default css |
|
139 | ;; User option overrides the default css | |
150 | (setf css nil) |
|
140 | (setf css nil) | |
151 | (dolist (css-file css-files) |
|
141 | (dolist (css-file css-files) | |
152 | (push (format nil "////// Included file ~A~%~A" css-file |
|
142 | (push (format nil "////// Included file ~A~%~A" css-file | |
153 | (alexandria:read-file-into-string css-file)) |
|
143 | (alexandria:read-file-into-string css-file)) | |
154 | css)))))) |
|
144 | css)))))) | |
155 |
|
145 | |||
156 | (defmethod write-compiled-file ((compiler compiler)) |
|
146 | (defmethod write-compiled-file ((compiler compiler)) | |
157 | (alexandria:write-string-into-file |
|
147 | (alexandria:write-string-into-file | |
158 | (if (compile-only compiler) |
|
148 | (if (compile-only compiler) | |
159 | ;; Just the JS |
|
149 | ;; Just the JS | |
160 | (js-sources compiler) |
|
150 | (js-sources compiler) | |
161 | ;; All of it |
|
151 | ;; All of it | |
162 | (html-sources compiler)) |
|
152 | (html-sources compiler)) | |
163 | (target compiler) :if-exists :supersede)) |
|
153 | (target compiler) :if-exists :supersede)) |
@@ -1,54 +1,54 b'' | |||||
1 |
|
1 | |||
2 |
(in-package |
|
2 | (in-package txt2web.main) | |
3 |
|
3 | |||
4 | ;;; Game session state (saved in savegames) |
|
4 | ;;; Game session state (saved in savegames) | |
5 | ;; Variables |
|
5 | ;; Variables | |
6 | (var *globals (create)) |
|
6 | (var *globals (create)) | |
7 | ;; Inventory (objects) |
|
7 | ;; Inventory (objects) | |
8 | (var *objs (create)) |
|
8 | (var *objs (create)) | |
9 | (var *current-location nil) |
|
9 | (var *current-location nil) | |
10 | ;; Game time |
|
10 | ;; Game time | |
11 | (var *started-at (chain *date (now))) |
|
11 | (var *started-at (chain *date (now))) | |
12 | ;; Timers |
|
12 | ;; Timers | |
13 | (var *timer-interval 500) |
|
13 | (var *timer-interval 500) | |
14 | (var *timer-obj nil) |
|
14 | (var *timer-obj nil) | |
15 | ;; Games |
|
15 | ;; Games | |
16 | (var *loaded-games (list)) |
|
16 | (var *loaded-games (list)) | |
17 |
|
17 | |||
18 | ;;; Transient state |
|
18 | ;;; Transient state | |
19 | ;; ACTions |
|
19 | ;; ACTions | |
20 | (var *acts (create)) |
|
20 | (var *acts (create)) | |
21 | ;; Savegame data |
|
21 | ;; Savegame data | |
22 | (var *state-stash (create)) |
|
22 | (var *state-stash (create)) | |
23 | ;; List of audio files being played |
|
23 | ;; List of audio files being played | |
24 | (var *playing (create)) |
|
24 | (var *playing (create)) | |
25 | ;; Local variables stack (starts with an empty frame) |
|
25 | ;; Local variables stack (starts with an empty frame) | |
26 | (var *locals (list)) |
|
26 | (var *locals (list)) | |
27 | ;; Promise to continue running the game after menu |
|
27 | ;; Promise to continue running the game after menu | |
28 | (var *menu-resume nil) |
|
28 | (var *menu-resume nil) | |
29 |
|
29 | |||
30 | ;;; Game data |
|
30 | ;;; Game data | |
31 | ;; Games (filename -> [locations]) |
|
31 | ;; Games (filename -> [locations]) | |
32 | (var *games (list)) |
|
32 | (var *games (list)) | |
33 | ;; The main (non library) game. Updated by openqst |
|
33 | ;; The main (non library) game. Updated by openqst | |
34 | (var *main-game nil) |
|
34 | (var *main-game nil) | |
35 | ;; Active locations |
|
35 | ;; Active locations | |
36 | (var *locs (create)) |
|
36 | (var *locs (create)) | |
37 |
|
37 | |||
38 | (setf (@ window onload) |
|
38 | (setf (@ window onload) | |
39 | (lambda () |
|
39 | (lambda () | |
40 |
(#.(intern "INIT-DOM" " |
|
40 | (#.(intern "INIT-DOM" "TXT2WEB.API")) | |
41 | ;; For MSECCOUNT |
|
41 | ;; For MSECCOUNT | |
42 | (setf *started-at (chain *date (now))) |
|
42 | (setf *started-at (chain *date (now))) | |
43 | ;; For $COUNTER and SETTIMER |
|
43 | ;; For $COUNTER and SETTIMER | |
44 |
(#.(intern "SET-TIMER" " |
|
44 | (#.(intern "SET-TIMER" "TXT2WEB.API") | |
45 | *timer-interval) |
|
45 | *timer-interval) | |
46 | ;; Start the first game |
|
46 | ;; Start the first game | |
47 |
(#.(intern "RUN-GAME" " |
|
47 | (#.(intern "RUN-GAME" "TXT2WEB.API") | |
48 | (chain *object (keys *games) 0)) |
|
48 | (chain *object (keys *games) 0)) | |
49 | (values))) |
|
49 | (values))) | |
50 |
|
50 | |||
51 | ;;; Some very common utilities (for both api and lib) |
|
51 | ;;; Some very common utilities (for both api and lib) | |
52 |
|
52 | |||
53 | (defun by-id (id) |
|
53 | (defun by-id (id) | |
54 | (chain document (get-element-by-id id))) |
|
54 | (chain document (get-element-by-id id))) |
@@ -1,108 +1,108 b'' | |||||
1 |
|
1 | |||
2 | (in-package cl-user) |
|
2 | (in-package cl-user) | |
3 |
|
3 | |||
4 |
(defpackage : |
|
4 | (defpackage :txt2web.js) | |
5 |
|
5 | |||
6 |
(defpackage : |
|
6 | (defpackage :txt2web.main | |
7 |
(:use :cl :ps : |
|
7 | (:use :cl :ps :txt2web.js) | |
8 | (:export #:api-call #:by-id |
|
8 | (:export #:api-call #:by-id | |
9 | #:has |
|
9 | #:has | |
10 |
|
10 | |||
11 | #:*globals #:*objs #:*current-location |
|
11 | #:*globals #:*objs #:*current-location | |
12 | #:*started-at #:*timer-interval #:*timer-obj #:*loaded-games |
|
12 | #:*started-at #:*timer-interval #:*timer-obj #:*loaded-games | |
13 |
|
13 | |||
14 | #:*acts #:*state-stash #:*playing #:*locals |
|
14 | #:*acts #:*state-stash #:*playing #:*locals | |
15 |
|
15 | |||
16 | #:*games #:*main-game #:*locs #:*menu-resume |
|
16 | #:*games #:*main-game #:*locs #:*menu-resume | |
17 | )) |
|
17 | )) | |
18 |
|
18 | |||
19 | (defpackage :code-walker |
|
19 | (defpackage :code-walker | |
20 | (:use :cl) |
|
20 | (:use :cl) | |
21 | (:export #:deftransform |
|
21 | (:export #:deftransform | |
22 | #:deftransform-stop |
|
22 | #:deftransform-stop | |
23 | #:walk |
|
23 | #:walk | |
24 | #:whole |
|
24 | #:whole | |
25 | #:walk-continue)) |
|
25 | #:walk-continue)) | |
26 |
|
26 | |||
27 | ;;; API functions |
|
27 | ;;; API functions | |
28 |
(defpackage : |
|
28 | (defpackage :txt2web.api | |
29 |
(:use :cl :ps : |
|
29 | (:use :cl :ps :txt2web.main :txt2web.js) | |
30 | (:export #:with-frame #:with-call-args |
|
30 | (:export #:with-frame #:with-call-args | |
31 | #:stash-state |
|
31 | #:stash-state | |
32 |
|
32 | |||
33 | #:report-error #:sleep #:init-dom #:call-serv-loc #:*serv-vars* |
|
33 | #:report-error #:sleep #:init-dom #:call-serv-loc #:*serv-vars* | |
34 | #:newline #:clear-id #:prepare-contents #:get-id #:set-id #:append-id |
|
34 | #:newline #:clear-id #:prepare-contents #:get-id #:set-id #:append-id | |
35 | #:init-args #:get-result #:call-loc #:call-act |
|
35 | #:init-args #:get-result #:call-loc #:call-act | |
36 | #:get-frame #:add-text #:get-text #:clear-text #:enable-frame |
|
36 | #:get-frame #:add-text #:get-text #:clear-text #:enable-frame | |
37 | #:add-act #:del-act #:clear-act #:update-acts |
|
37 | #:add-act #:del-act #:clear-act #:update-acts | |
38 | #:set-str-element #:set-any-element #:set-serv-var |
|
38 | #:set-str-element #:set-any-element #:set-serv-var | |
39 | #:*var #:new-value #:index-num #:get #:set #:kill |
|
39 | #:*var #:new-value #:index-num #:get #:set #:kill | |
40 | #:var-real-name #:ensure-var #:var-ref #:get-var #:set-var |
|
40 | #:var-real-name #:ensure-var #:var-ref #:get-var #:set-var | |
41 | #:get-array #:set-array #:kill-var #:array-size |
|
41 | #:get-array #:set-array #:kill-var #:array-size | |
42 | #:push-local-frame #:pop-local-frame #:current-local-frame #:new-local |
|
42 | #:push-local-frame #:pop-local-frame #:current-local-frame #:new-local | |
43 | #:update-objs |
|
43 | #:update-objs | |
44 | #:menu |
|
44 | #:menu | |
45 | #:clean-audio |
|
45 | #:clean-audio | |
46 | #:show-image |
|
46 | #:show-image | |
47 | #:opengame #:savegame |
|
47 | #:opengame #:savegame | |
48 | )) |
|
48 | )) | |
49 |
|
49 | |||
50 | ;;; QSP library functions and macros |
|
50 | ;;; QSP library functions and macros | |
51 |
(defpackage : |
|
51 | (defpackage :txt2web.lib | |
52 |
(:use :cl :ps : |
|
52 | (:use :cl :ps :txt2web.main :txt2web.js) | |
53 |
(:local-nicknames (#:api : |
|
53 | (:local-nicknames (#:api :txt2web.api) | |
54 | (#:walker :code-walker)) |
|
54 | (#:walker :code-walker)) | |
55 | (:export #:str #:exec #:qspblock #:qspfor #:game #:location |
|
55 | (:export #:str #:exec #:qspblock #:qspfor #:game #:location | |
56 | #:qspcond #:qspvar #:set #:local #:jump |
|
56 | #:qspcond #:qspvar #:set #:local #:jump | |
57 |
|
57 | |||
58 | #:killvar #:killall |
|
58 | #:killvar #:killall | |
59 | #:obj #:loc #:no |
|
59 | #:obj #:loc #:no | |
60 | #:qspver #:curloc |
|
60 | #:qspver #:curloc | |
61 | #:rnd #:qspmax #:qspmin |
|
61 | #:rnd #:qspmax #:qspmin | |
62 | #:arrsize #:len |
|
62 | #:arrsize #:len | |
63 | #:mid #:ucase #:lcase #:trim #:replace #:val #:qspstr |
|
63 | #:mid #:ucase #:lcase #:trim #:replace #:val #:qspstr | |
64 | #:exit #:desc |
|
64 | #:exit #:desc | |
65 | #:showstat #:msg |
|
65 | #:showstat #:msg | |
66 | #:showacts #:delact #:cla |
|
66 | #:showacts #:delact #:cla | |
67 | #:showobjs #:countobj #:getobj |
|
67 | #:showobjs #:countobj #:getobj | |
68 | #:isplay |
|
68 | #:isplay | |
69 | #:view |
|
69 | #:view | |
70 | #:showinput |
|
70 | #:showinput | |
71 | #:wait #:settimer |
|
71 | #:wait #:settimer | |
72 | #:local |
|
72 | #:local | |
73 | #:opengame #:savegame |
|
73 | #:opengame #:savegame | |
74 |
|
74 | |||
75 | #:goto #:xgoto |
|
75 | #:goto #:xgoto | |
76 | #:rand |
|
76 | #:rand | |
77 | #:copyarr #:arrpos #:arrcomp |
|
77 | #:copyarr #:arrpos #:arrcomp | |
78 | #:instr #:isnum #:strcomp #:strfind #:strpos |
|
78 | #:instr #:isnum #:strcomp #:strfind #:strpos | |
79 | #:iif |
|
79 | #:iif | |
80 | #:gosub #:func |
|
80 | #:gosub #:func | |
81 | #:dynamic #:dyneval |
|
81 | #:dynamic #:dyneval | |
82 | #:main-p #:main-pl #:main-nl #:maintxt #:desc #:main-clear |
|
82 | #:main-p #:main-pl #:main-nl #:maintxt #:desc #:main-clear | |
83 | #:stat-p #:stat-pl #:stat-nl #:stattxt #:stat-clear #:cls |
|
83 | #:stat-p #:stat-pl #:stat-nl #:stattxt #:stat-clear #:cls | |
84 | #:curacts |
|
84 | #:curacts | |
85 | #:addobj #:delobj #:killobj |
|
85 | #:addobj #:delobj #:killobj | |
86 | #:menu |
|
86 | #:menu | |
87 | #:play #:close #:closeall |
|
87 | #:play #:close #:closeall | |
88 | #:refint |
|
88 | #:refint | |
89 | #:usertxt #:cmdclear #:input |
|
89 | #:usertxt #:cmdclear #:input | |
90 | #:msecscount |
|
90 | #:msecscount | |
91 | #:rgb |
|
91 | #:rgb | |
92 | #:openqst #:addqst #:killqst |
|
92 | #:openqst #:addqst #:killqst | |
93 | )) |
|
93 | )) | |
94 |
|
94 | |||
95 |
(setf (ps:ps-package-prefix " |
|
95 | (setf (ps:ps-package-prefix "TXT2WEB.MAIN") "qsp_") | |
96 |
(setf (ps:ps-package-prefix " |
|
96 | (setf (ps:ps-package-prefix "TXT2WEB.API") "qsp_api_") | |
97 |
(setf (ps:ps-package-prefix " |
|
97 | (setf (ps:ps-package-prefix "TXT2WEB.LIB") "qsp_lib_") | |
98 |
|
98 | |||
99 | ;;; The compiler |
|
99 | ;;; The compiler | |
100 |
(defpackage : |
|
100 | (defpackage :txt2web | |
101 | (:use :cl) |
|
101 | (:use :cl) | |
102 | (:local-nicknames (#:p #:esrap) |
|
102 | (:local-nicknames (#:p #:esrap) | |
103 |
(#:lib : |
|
103 | (#:lib :txt2web.lib) | |
104 |
(#:api : |
|
104 | (#:api :txt2web.api) | |
105 |
(#:main : |
|
105 | (#:main :txt2web.main) | |
106 | (#:walker :code-walker)) |
|
106 | (#:walker :code-walker)) | |
107 | (:export #:parse-file #:entry-point)) |
|
107 | (:export #:parse-file #:entry-point)) | |
108 |
|
108 |
@@ -1,624 +1,624 b'' | |||||
1 |
|
1 | |||
2 |
(in-package |
|
2 | (in-package txt2web) | |
3 |
|
3 | |||
4 | ;;;; Parses TXT source to an intermediate representation |
|
4 | ;;;; Parses TXT source to an intermediate representation | |
5 |
|
5 | |||
6 | (eval-when (:compile-toplevel :load-toplevel :execute) |
|
6 | (eval-when (:compile-toplevel :load-toplevel :execute) | |
7 | (defparameter *max-args* 10)) |
|
7 | (defparameter *max-args* 10)) | |
8 |
|
8 | |||
9 | ;;; Utility |
|
9 | ;;; Utility | |
10 |
|
10 | |||
11 | (defun remove-nth (list nth) |
|
11 | (defun remove-nth (list nth) | |
12 | (append (subseq list 0 nth) |
|
12 | (append (subseq list 0 nth) | |
13 | (subseq list (1+ nth)))) |
|
13 | (subseq list (1+ nth)))) | |
14 |
|
14 | |||
15 | (defun not-quote (char) |
|
15 | (defun not-quote (char) | |
16 | (not (eql #\' char))) |
|
16 | (not (eql #\' char))) | |
17 |
|
17 | |||
18 | (defun not-doublequote (char) |
|
18 | (defun not-doublequote (char) | |
19 | (not (eql #\" char))) |
|
19 | (not (eql #\" char))) | |
20 |
|
20 | |||
21 | (defun not-brace (char) |
|
21 | (defun not-brace (char) | |
22 | (not (eql #\} char))) |
|
22 | (not (eql #\} char))) | |
23 |
|
23 | |||
24 | (defun not-integer (string) |
|
24 | (defun not-integer (string) | |
25 | (when (find-if-not #'digit-char-p string) |
|
25 | (when (find-if-not #'digit-char-p string) | |
26 | t)) |
|
26 | t)) | |
27 |
|
27 | |||
28 | (defun not-newline (char) |
|
28 | (defun not-newline (char) | |
29 | (not (eql #\newline char))) |
|
29 | (not (eql #\newline char))) | |
30 |
|
30 | |||
31 | (defun id-any-char (char) |
|
31 | (defun id-any-char (char) | |
32 | (and |
|
32 | (and | |
33 | (not (digit-char-p char)) |
|
33 | (not (digit-char-p char)) | |
34 | (not (eql #\newline char)) |
|
34 | (not (eql #\newline char)) | |
35 | (not (find char " !:&=<>+-*/,'\"()[]{}")))) |
|
35 | (not (find char " !:&=<>+-*/,'\"()[]{}")))) | |
36 |
|
36 | |||
37 | (defun intern-first (list) |
|
37 | (defun intern-first (list) | |
38 |
(list* (intern (string-upcase (first list)) " |
|
38 | (list* (intern (string-upcase (first list)) "TXT2WEB.LIB") | |
39 | (rest list))) |
|
39 | (rest list))) | |
40 |
|
40 | |||
41 | (eval-when (:compile-toplevel :load-toplevel :execute) |
|
41 | (eval-when (:compile-toplevel :load-toplevel :execute) | |
42 | (defun remove-nil (list) |
|
42 | (defun remove-nil (list) | |
43 | (remove nil list))) |
|
43 | (remove nil list))) | |
44 |
|
44 | |||
45 | (defun binop-rest (list) |
|
45 | (defun binop-rest (list) | |
46 | (destructuring-bind (ws1 operator ws2 operand2) |
|
46 | (destructuring-bind (ws1 operator ws2 operand2) | |
47 | list |
|
47 | list | |
48 | (declare (ignore ws1 ws2)) |
|
48 | (declare (ignore ws1 ws2)) | |
49 |
(list (intern (string-upcase operator) " |
|
49 | (list (intern (string-upcase operator) "TXT2WEB.LIB") operand2))) | |
50 |
|
50 | |||
51 | (defun do-binop% (left-op other-ops) |
|
51 | (defun do-binop% (left-op other-ops) | |
52 | (if (null other-ops) |
|
52 | (if (null other-ops) | |
53 | left-op |
|
53 | left-op | |
54 | (destructuring-bind ((operator right-op) &rest rest-ops) |
|
54 | (destructuring-bind ((operator right-op) &rest rest-ops) | |
55 | other-ops |
|
55 | other-ops | |
56 | (if (and (listp left-op) |
|
56 | (if (and (listp left-op) | |
57 | (eq (first left-op) |
|
57 | (eq (first left-op) | |
58 | operator)) |
|
58 | operator)) | |
59 | (do-binop% (append left-op (list right-op)) rest-ops) |
|
59 | (do-binop% (append left-op (list right-op)) rest-ops) | |
60 | (do-binop% (list operator left-op right-op) rest-ops))))) |
|
60 | (do-binop% (list operator left-op right-op) rest-ops))))) | |
61 |
|
61 | |||
62 | (defun do-binop (list) |
|
62 | (defun do-binop (list) | |
63 | (destructuring-bind (left-op rest-ops) |
|
63 | (destructuring-bind (left-op rest-ops) | |
64 | list |
|
64 | list | |
65 | (do-binop% left-op |
|
65 | (do-binop% left-op | |
66 | (mapcar #'binop-rest rest-ops)))) |
|
66 | (mapcar #'binop-rest rest-ops)))) | |
67 |
|
67 | |||
68 | (p:defrule line-continuation (and #\_ #\newline) |
|
68 | (p:defrule line-continuation (and #\_ #\newline) | |
69 | (:constant nil)) |
|
69 | (:constant nil)) | |
70 |
|
70 | |||
71 | (p:defrule text-spaces (+ (or #\space #\tab line-continuation)) |
|
71 | (p:defrule text-spaces (+ (or #\space #\tab line-continuation)) | |
72 | (:text t)) |
|
72 | (:text t)) | |
73 |
|
73 | |||
74 | (p:defrule spaces (+ (or #\space #\tab line-continuation)) |
|
74 | (p:defrule spaces (+ (or #\space #\tab line-continuation)) | |
75 | (:constant nil) |
|
75 | (:constant nil) | |
76 | (:error-report nil)) |
|
76 | (:error-report nil)) | |
77 |
|
77 | |||
78 | (p:defrule spaces? (* (or #\space #\tab line-continuation)) |
|
78 | (p:defrule spaces? (* (or #\space #\tab line-continuation)) | |
79 | (:constant nil) |
|
79 | (:constant nil) | |
80 | (:error-report nil)) |
|
80 | (:error-report nil)) | |
81 |
|
81 | |||
82 | (p:defrule colon #\: |
|
82 | (p:defrule colon #\: | |
83 | (:constant nil)) |
|
83 | (:constant nil)) | |
84 |
|
84 | |||
85 | (p:defrule equal #\= |
|
85 | (p:defrule equal #\= | |
86 | (:constant nil)) |
|
86 | (:constant nil)) | |
87 |
|
87 | |||
88 | (p:defrule alphanumeric (alphanumericp character)) |
|
88 | (p:defrule alphanumeric (alphanumericp character)) | |
89 |
|
89 | |||
90 | (p:defrule not-newline (not-newline character)) |
|
90 | (p:defrule not-newline (not-newline character)) | |
91 |
|
91 | |||
92 | (p:defrule squote-esc "''" |
|
92 | (p:defrule squote-esc "''" | |
93 | (:lambda (list) |
|
93 | (:lambda (list) | |
94 | (p:text (elt list 0)))) |
|
94 | (p:text (elt list 0)))) | |
95 |
|
95 | |||
96 | (p:defrule dquote-esc "\"\"" |
|
96 | (p:defrule dquote-esc "\"\"" | |
97 | (:lambda (list) |
|
97 | (:lambda (list) | |
98 | (p:text (elt list 0)))) |
|
98 | (p:text (elt list 0)))) | |
99 |
|
99 | |||
100 | (p:defrule sstring-chars (+ (and (and (p:! "<<") (p:! (p:~ "\"exec:"))) |
|
100 | (p:defrule sstring-chars (+ (and (and (p:! "<<") (p:! (p:~ "\"exec:"))) | |
101 | (or squote-esc (not-quote character)))) |
|
101 | (or squote-esc (not-quote character)))) | |
102 | (:lambda (list) |
|
102 | (:lambda (list) | |
103 | (p:text (mapcar #'second list)))) |
|
103 | (p:text (mapcar #'second list)))) | |
104 |
|
104 | |||
105 | (p:defrule dstring-chars (+ (and (and (p:! "<<") (p:! (p:~ "'exec:"))) |
|
105 | (p:defrule dstring-chars (+ (and (and (p:! "<<") (p:! (p:~ "'exec:"))) | |
106 | (or dquote-esc (not-doublequote character)))) |
|
106 | (or dquote-esc (not-doublequote character)))) | |
107 | (:lambda (list) |
|
107 | (:lambda (list) | |
108 | (p:text (mapcar #'second list)))) |
|
108 | (p:text (mapcar #'second list)))) | |
109 |
|
109 | |||
110 | ;;; Identifiers |
|
110 | ;;; Identifiers | |
111 |
|
111 | |||
112 | (defparameter *keywords* '(act addlib addobj addqst and arrcomp arrpos arrsize cla clear *clear close clr *clr cls cmdclear cmdclr copyarr counter countobj curact curacts curloc debug delact dellib delobj desc disablescroll disablesubex dynamic dyneval else elseif end exit for freelib func getobj gosub goto gs gt if iif img *img inclib input instr isnum isplay jump killall killobj killqst killvar lcase lcolor len let loc local maintxt max menu mid min mod msecscount msg nl *nl no nosave obj opengame openqst or p *p pl *pl play qspver rand refint replace rgb rnd savegame selact selobj set settimer showacts showinput showobjs showstat stattxt step str strcomp strfind strpos to trim ucase unsel unselect usercom user_text usrtxt val view wait xgoto xgt)) |
|
112 | (defparameter *keywords* '(act addlib addobj addqst and arrcomp arrpos arrsize cla clear *clear close clr *clr cls cmdclear cmdclr copyarr counter countobj curact curacts curloc debug delact dellib delobj desc disablescroll disablesubex dynamic dyneval else elseif end exit for freelib func getobj gosub goto gs gt if iif img *img inclib input instr isnum isplay jump killall killobj killqst killvar lcase lcolor len let loc local maintxt max menu mid min mod msecscount msg nl *nl no nosave obj opengame openqst or p *p pl *pl play qspver rand refint replace rgb rnd savegame selact selobj set settimer showacts showinput showobjs showstat stattxt step str strcomp strfind strpos to trim ucase unsel unselect usercom user_text usrtxt val view wait xgoto xgt)) | |
113 |
|
113 | |||
114 | (defun trim-$ (str) |
|
114 | (defun trim-$ (str) | |
115 | (if (char= #\$ (elt str 0)) |
|
115 | (if (char= #\$ (elt str 0)) | |
116 | (subseq str 1) |
|
116 | (subseq str 1) | |
117 | str)) |
|
117 | str)) | |
118 |
|
118 | |||
119 | (defun qsp-keyword-p (id) |
|
119 | (defun qsp-keyword-p (id) | |
120 | (member (intern (trim-$ (string-upcase id))) *keywords*)) |
|
120 | (member (intern (trim-$ (string-upcase id))) *keywords*)) | |
121 |
|
121 | |||
122 | (defun not-qsp-keyword-p (id) |
|
122 | (defun not-qsp-keyword-p (id) | |
123 | (not (member (intern (trim-$ (string-upcase id))) *keywords*))) |
|
123 | (not (member (intern (trim-$ (string-upcase id))) *keywords*))) | |
124 |
|
124 | |||
125 | (p:defrule qsp-keyword (qsp-keyword-p identifier-raw)) |
|
125 | (p:defrule qsp-keyword (qsp-keyword-p identifier-raw)) | |
126 |
|
126 | |||
127 | (p:defrule id-first (id-any-char character)) |
|
127 | (p:defrule id-first (id-any-char character)) | |
128 | (p:defrule id-next (or (id-any-char character) |
|
128 | (p:defrule id-next (or (id-any-char character) | |
129 | (digit-char-p character))) |
|
129 | (digit-char-p character))) | |
130 | (p:defrule identifier-raw (and id-first (* id-next)) |
|
130 | (p:defrule identifier-raw (and id-first (* id-next)) | |
131 | (:lambda (list) |
|
131 | (:lambda (list) | |
132 |
(intern (string-upcase (p:text list)) " |
|
132 | (intern (string-upcase (p:text list)) "TXT2WEB.LIB"))) | |
133 |
|
133 | |||
134 | (p:defrule identifier (not-qsp-keyword-p identifier-raw)) |
|
134 | (p:defrule identifier (not-qsp-keyword-p identifier-raw)) | |
135 |
|
135 | |||
136 | ;;; Strings |
|
136 | ;;; Strings | |
137 |
|
137 | |||
138 | (p:defrule qsp-string (or normal-string brace-string)) |
|
138 | (p:defrule qsp-string (or normal-string brace-string)) | |
139 |
|
139 | |||
140 | (p:defrule normal-string (or sstring dstring) |
|
140 | (p:defrule normal-string (or sstring dstring) | |
141 | (:lambda (str) |
|
141 | (:lambda (str) | |
142 | (list* 'lib:str (or str (list ""))))) |
|
142 | (list* 'lib:str (or str (list ""))))) | |
143 |
|
143 | |||
144 | (p:defrule sstring (and #\' (* (or string-interpol |
|
144 | (p:defrule sstring (and #\' (* (or string-interpol | |
145 | sstring-exec |
|
145 | sstring-exec | |
146 | sstring-chars)) |
|
146 | sstring-chars)) | |
147 | #\') |
|
147 | #\') | |
148 | (:function second)) |
|
148 | (:function second)) | |
149 |
|
149 | |||
150 | (p:defrule dstring (and #\" (* (or string-interpol |
|
150 | (p:defrule dstring (and #\" (* (or string-interpol | |
151 | dstring-exec |
|
151 | dstring-exec | |
152 | dstring-chars)) |
|
152 | dstring-chars)) | |
153 | #\") |
|
153 | #\") | |
154 | (:function second)) |
|
154 | (:function second)) | |
155 |
|
155 | |||
156 | (p:defrule string-interpol (and "<<" expression ">>") |
|
156 | (p:defrule string-interpol (and "<<" expression ">>") | |
157 | (:function second)) |
|
157 | (:function second)) | |
158 |
|
158 | |||
159 | (p:defrule sstring-exec-body (+ (or squote-esc (not-doublequote character))) |
|
159 | (p:defrule sstring-exec-body (+ (or squote-esc (not-doublequote character))) | |
160 | (:text t)) |
|
160 | (:text t)) | |
161 |
|
161 | |||
162 | (p:defrule dstring-exec-body (+ (or dquote-esc (not-quote character))) |
|
162 | (p:defrule dstring-exec-body (+ (or dquote-esc (not-quote character))) | |
163 | (:text t)) |
|
163 | (:text t)) | |
164 |
|
164 | |||
165 | (p:defrule sstring-exec (and (p:~ "\"exec:") sstring-exec-body #\") |
|
165 | (p:defrule sstring-exec (and (p:~ "\"exec:") sstring-exec-body #\") | |
166 | (:lambda (list) |
|
166 | (:lambda (list) | |
167 | (list* 'lib:exec (p:parse 'exec-body (second list))))) |
|
167 | (list* 'lib:exec (p:parse 'exec-body (second list))))) | |
168 |
|
168 | |||
169 | (p:defrule dstring-exec (and (p:~ "'exec:") dstring-exec-body #\') |
|
169 | (p:defrule dstring-exec (and (p:~ "'exec:") dstring-exec-body #\') | |
170 | (:lambda (list) |
|
170 | (:lambda (list) | |
171 | (list* 'lib:exec (p:parse 'exec-body (second list))))) |
|
171 | (list* 'lib:exec (p:parse 'exec-body (second list))))) | |
172 |
|
172 | |||
173 | (p:defrule brace-string (and #\{ before-statement block-body #\}) |
|
173 | (p:defrule brace-string (and #\{ before-statement block-body #\}) | |
174 | (:lambda (list) |
|
174 | (:lambda (list) | |
175 | (list* 'lib:qspblock (third list)))) |
|
175 | (list* 'lib:qspblock (third list)))) | |
176 |
|
176 | |||
177 | ;;; Location |
|
177 | ;;; Location | |
178 |
|
178 | |||
179 |
(p:defrule |
|
179 | (p:defrule txt2web-grammar (and (* (or spaces #\newline)) | |
180 | (* location)) |
|
180 | (* location)) | |
181 | (:lambda (list) |
|
181 | (:lambda (list) | |
182 | `(lib:game ,@(second list)))) |
|
182 | `(lib:game ,@(second list)))) | |
183 |
|
183 | |||
184 | (p:defrule location (and location-header block-body location-end) |
|
184 | (p:defrule location (and location-header block-body location-end) | |
185 | (:destructure (header body end) |
|
185 | (:destructure (header body end) | |
186 | (declare (ignore end)) |
|
186 | (declare (ignore end)) | |
187 | `(lib:location (,header) ,@body))) |
|
187 | `(lib:location (,header) ,@body))) | |
188 |
|
188 | |||
189 | (p:defrule location-header (and #\# |
|
189 | (p:defrule location-header (and #\# | |
190 | (+ not-newline) |
|
190 | (+ not-newline) | |
191 | (and #\newline spaces? before-statement)) |
|
191 | (and #\newline spaces? before-statement)) | |
192 | (:destructure (spaces1 name spaces2) |
|
192 | (:destructure (spaces1 name spaces2) | |
193 | (declare (ignore spaces1 spaces2)) |
|
193 | (declare (ignore spaces1 spaces2)) | |
194 | (string-upcase (string-trim " " (p:text name))))) |
|
194 | (string-upcase (string-trim " " (p:text name))))) | |
195 |
|
195 | |||
196 | (p:defrule location-end (and #\- (* not-newline) #\newline before-statement) |
|
196 | (p:defrule location-end (and #\- (* not-newline) #\newline before-statement) | |
197 | (:constant nil)) |
|
197 | (:constant nil)) | |
198 |
|
198 | |||
199 | ;;; Block body |
|
199 | ;;; Block body | |
200 |
|
200 | |||
201 | (p:defrule newline-block-body (and #\newline spaces? block-body) |
|
201 | (p:defrule newline-block-body (and #\newline spaces? block-body) | |
202 | (:function third)) |
|
202 | (:function third)) | |
203 |
|
203 | |||
204 | (p:defrule block-body (* statement) |
|
204 | (p:defrule block-body (* statement) | |
205 | (:function remove-nil)) |
|
205 | (:function remove-nil)) | |
206 |
|
206 | |||
207 | ;; Just for <a href="exec:...'> |
|
207 | ;; Just for <a href="exec:...'> | |
208 | ;; Explicitly called from that rule's production |
|
208 | ;; Explicitly called from that rule's production | |
209 | (p:defrule exec-body (and before-statement line-body) |
|
209 | (p:defrule exec-body (and before-statement line-body) | |
210 | (:function second)) |
|
210 | (:function second)) | |
211 |
|
211 | |||
212 | (p:defrule line-body (and inline-statement (* next-inline-statement)) |
|
212 | (p:defrule line-body (and inline-statement (* next-inline-statement)) | |
213 | (:lambda (list) |
|
213 | (:lambda (list) | |
214 | (list* (first list) (second list)))) |
|
214 | (list* (first list) (second list)))) | |
215 |
|
215 | |||
216 | (p:defrule before-statement (* (or #\newline spaces)) |
|
216 | (p:defrule before-statement (* (or #\newline spaces)) | |
217 | (:constant nil)) |
|
217 | (:constant nil)) | |
218 |
|
218 | |||
219 | (p:defrule statement-end (or statement-end-real statement-end-block-close)) |
|
219 | (p:defrule statement-end (or statement-end-real statement-end-block-close)) | |
220 |
|
220 | |||
221 | (p:defrule statement-end-real (and (or #\newline |
|
221 | (p:defrule statement-end-real (and (or #\newline | |
222 | (and #\& spaces? (p:& statement%))) |
|
222 | (and #\& spaces? (p:& statement%))) | |
223 | before-statement) |
|
223 | before-statement) | |
224 | (:constant nil)) |
|
224 | (:constant nil)) | |
225 |
|
225 | |||
226 | (p:defrule statement-end-block-close (or (p:& #\})) |
|
226 | (p:defrule statement-end-block-close (or (p:& #\})) | |
227 | (:constant nil)) |
|
227 | (:constant nil)) | |
228 |
|
228 | |||
229 | (p:defrule inline-statement (and statement% spaces?) |
|
229 | (p:defrule inline-statement (and statement% spaces?) | |
230 | (:function first)) |
|
230 | (:function first)) | |
231 |
|
231 | |||
232 | (p:defrule next-inline-statement (and #\& spaces? inline-statement) |
|
232 | (p:defrule next-inline-statement (and #\& spaces? inline-statement) | |
233 | (:function third)) |
|
233 | (:function third)) | |
234 |
|
234 | |||
235 | (p:defrule not-a-non-statement (and (p:! (p:~ "elseif")) |
|
235 | (p:defrule not-a-non-statement (and (p:! (p:~ "elseif")) | |
236 | (p:! (p:~ "else")) |
|
236 | (p:! (p:~ "else")) | |
237 | (p:! (p:~ "end")))) |
|
237 | (p:! (p:~ "end")))) | |
238 |
|
238 | |||
239 | (p:defrule statement (and inline-statement statement-end) |
|
239 | (p:defrule statement (and inline-statement statement-end) | |
240 | (:function first)) |
|
240 | (:function first)) | |
241 |
|
241 | |||
242 | (p:defrule statement% (and not-a-non-statement |
|
242 | (p:defrule statement% (and not-a-non-statement | |
243 | (or label comment string-output |
|
243 | (or label comment string-output | |
244 | block non-returning-intrinsic local |
|
244 | block non-returning-intrinsic local | |
245 | assignment expression-output)) |
|
245 | assignment expression-output)) | |
246 | (:function second)) |
|
246 | (:function second)) | |
247 |
|
247 | |||
248 | (p:defrule expr-stopper (or comment block non-returning-intrinsic)) |
|
248 | (p:defrule expr-stopper (or comment block non-returning-intrinsic)) | |
249 |
|
249 | |||
250 | (p:defrule string-output qsp-string |
|
250 | (p:defrule string-output qsp-string | |
251 | (:lambda (string) |
|
251 | (:lambda (string) | |
252 | (list 'lib:main-pl string))) |
|
252 | (list 'lib:main-pl string))) | |
253 |
|
253 | |||
254 | (p:defrule expression-output expression |
|
254 | (p:defrule expression-output expression | |
255 | (:lambda (list) |
|
255 | (:lambda (list) | |
256 | (list 'lib:main-pl list))) |
|
256 | (list 'lib:main-pl list))) | |
257 |
|
257 | |||
258 | (p:defrule label (and colon identifier) |
|
258 | (p:defrule label (and colon identifier) | |
259 | (:lambda (list) |
|
259 | (:lambda (list) | |
260 | (intern (string (second list)) :keyword))) |
|
260 | (intern (string (second list)) :keyword))) | |
261 |
|
261 | |||
262 | (p:defrule comment (and #\! (* (or qsp-string brace-comment text-spaces not-newline))) |
|
262 | (p:defrule comment (and #\! (* (or qsp-string brace-comment text-spaces not-newline))) | |
263 | (:constant nil)) |
|
263 | (:constant nil)) | |
264 |
|
264 | |||
265 | (p:defrule brace-comment (and #\{ (* (not-brace character)) #\}) |
|
265 | (p:defrule brace-comment (and #\{ (* (not-brace character)) #\}) | |
266 | (:constant nil)) |
|
266 | (:constant nil)) | |
267 |
|
267 | |||
268 | (p:defrule local (and (p:~ "local") spaces variable (p:? (and spaces? #\= spaces? expression))) |
|
268 | (p:defrule local (and (p:~ "local") spaces variable (p:? (and spaces? #\= spaces? expression))) | |
269 | (:lambda (list) |
|
269 | (:lambda (list) | |
270 | (list* 'lib:local (third list) |
|
270 | (list* 'lib:local (third list) | |
271 | (when (fourth list) |
|
271 | (when (fourth list) | |
272 | (list (fourth (fourth list))))))) |
|
272 | (list (fourth (fourth list))))))) | |
273 |
|
273 | |||
274 | ;;; Blocks |
|
274 | ;;; Blocks | |
275 |
|
275 | |||
276 | (p:defrule block (or block-act block-if block-for)) |
|
276 | (p:defrule block (or block-act block-if block-for)) | |
277 |
|
277 | |||
278 | (p:defrule block-if (and block-if-head block-if-body) |
|
278 | (p:defrule block-if (and block-if-head block-if-body) | |
279 | (:destructure (head body) |
|
279 | (:destructure (head body) | |
280 | `(lib:qspcond (,@head ,@(first body)) |
|
280 | `(lib:qspcond (,@head ,@(first body)) | |
281 | ,@(rest body)))) |
|
281 | ,@(rest body)))) | |
282 |
|
282 | |||
283 | (p:defrule block-if-head (and (p:~ "if") spaces expression spaces? colon spaces?) |
|
283 | (p:defrule block-if-head (and (p:~ "if") spaces expression spaces? colon spaces?) | |
284 | (:function remove-nil) |
|
284 | (:function remove-nil) | |
285 | (:function cdr)) |
|
285 | (:function cdr)) | |
286 |
|
286 | |||
287 | (p:defrule block-if-body (or block-if-ml block-if-sl) |
|
287 | (p:defrule block-if-body (or block-if-ml block-if-sl) | |
288 | (:destructure (if-body elseifs else &rest ws) |
|
288 | (:destructure (if-body elseifs else &rest ws) | |
289 | (declare (ignore ws)) |
|
289 | (declare (ignore ws)) | |
290 | `(,(remove-nil if-body) ,@elseifs ,@(when else `((else ,@else)))))) |
|
290 | `(,(remove-nil if-body) ,@elseifs ,@(when else `((else ,@else)))))) | |
291 |
|
291 | |||
292 | (p:defrule block-if-sl (and line-body |
|
292 | (p:defrule block-if-sl (and line-body | |
293 | (p:? block-if-elseif-inline) |
|
293 | (p:? block-if-elseif-inline) | |
294 | (p:? block-if-else-inline) |
|
294 | (p:? block-if-else-inline) | |
295 | spaces?)) |
|
295 | spaces?)) | |
296 |
|
296 | |||
297 | (p:defrule block-if-ml (and (and #\newline spaces?) |
|
297 | (p:defrule block-if-ml (and (and #\newline spaces?) | |
298 | block-body |
|
298 | block-body | |
299 | (p:? block-if-elseif) |
|
299 | (p:? block-if-elseif) | |
300 | (p:? block-if-else) |
|
300 | (p:? block-if-else) | |
301 | block-if-end) |
|
301 | block-if-end) | |
302 | (:lambda (list) |
|
302 | (:lambda (list) | |
303 | (cdr list))) |
|
303 | (cdr list))) | |
304 |
|
304 | |||
305 | (p:defrule block-if-elseif-inline (and block-if-elseif-head line-body (p:? block-if-elseif-inline)) |
|
305 | (p:defrule block-if-elseif-inline (and block-if-elseif-head line-body (p:? block-if-elseif-inline)) | |
306 | (:destructure (head statements elseif) |
|
306 | (:destructure (head statements elseif) | |
307 | `((,@(rest head) ,@(remove-nil statements)) ,@elseif))) |
|
307 | `((,@(rest head) ,@(remove-nil statements)) ,@elseif))) | |
308 |
|
308 | |||
309 | (p:defrule block-if-elseif (and block-if-elseif-head statement-end block-body (p:? block-if-elseif)) |
|
309 | (p:defrule block-if-elseif (and block-if-elseif-head statement-end block-body (p:? block-if-elseif)) | |
310 | (:destructure (head ws statements elseif) |
|
310 | (:destructure (head ws statements elseif) | |
311 | (declare (ignore ws)) |
|
311 | (declare (ignore ws)) | |
312 | `((,@(rest head) ,@(remove-nil statements)) ,@elseif))) |
|
312 | `((,@(rest head) ,@(remove-nil statements)) ,@elseif))) | |
313 |
|
313 | |||
314 | (p:defrule block-if-elseif-head (and (p:~ "elseif") spaces expression spaces? colon spaces?) |
|
314 | (p:defrule block-if-elseif-head (and (p:~ "elseif") spaces expression spaces? colon spaces?) | |
315 | (:function remove-nil) |
|
315 | (:function remove-nil) | |
316 | (:function intern-first)) |
|
316 | (:function intern-first)) | |
317 |
|
317 | |||
318 | (p:defrule block-if-else-inline (and block-if-else-head line-body) |
|
318 | (p:defrule block-if-else-inline (and block-if-else-head line-body) | |
319 | (:function second)) |
|
319 | (:function second)) | |
320 |
|
320 | |||
321 | (p:defrule block-if-else (and block-if-else-head #\newline spaces? block-body) |
|
321 | (p:defrule block-if-else (and block-if-else-head #\newline spaces? block-body) | |
322 | (:function fourth)) |
|
322 | (:function fourth)) | |
323 |
|
323 | |||
324 | (p:defrule block-if-else-head (and (p:~ "else") spaces?) |
|
324 | (p:defrule block-if-else-head (and (p:~ "else") spaces?) | |
325 | (:constant nil)) |
|
325 | (:constant nil)) | |
326 |
|
326 | |||
327 | (p:defrule block-if-end (and (p:~ "end") |
|
327 | (p:defrule block-if-end (and (p:~ "end") | |
328 | (p:? (and spaces (p:~ "if")))) |
|
328 | (p:? (and spaces (p:~ "if")))) | |
329 | (:constant nil)) |
|
329 | (:constant nil)) | |
330 |
|
330 | |||
331 | (p:defrule block-act (and block-act-head (or block-ml block-sl)) |
|
331 | (p:defrule block-act (and block-act-head (or block-ml block-sl)) | |
332 | (:lambda (list) |
|
332 | (:lambda (list) | |
333 | (apply #'append list))) |
|
333 | (apply #'append list))) | |
334 |
|
334 | |||
335 | (p:defrule block-act-head (and (p:~ "act") spaces? qsp-string spaces? |
|
335 | (p:defrule block-act-head (and (p:~ "act") spaces? qsp-string spaces? | |
336 | (p:? block-act-head-img) |
|
336 | (p:? block-act-head-img) | |
337 | colon spaces?) |
|
337 | colon spaces?) | |
338 | (:lambda (list) |
|
338 | (:lambda (list) | |
339 | (intern-first (list (first list) |
|
339 | (intern-first (list (first list) | |
340 | (third list) |
|
340 | (third list) | |
341 | (or (fifth list) '(lib:str "")))))) |
|
341 | (or (fifth list) '(lib:str "")))))) | |
342 |
|
342 | |||
343 | (p:defrule block-act-head-img (and #\, spaces? qsp-string spaces?) |
|
343 | (p:defrule block-act-head-img (and #\, spaces? qsp-string spaces?) | |
344 | (:lambda (list) |
|
344 | (:lambda (list) | |
345 | (or (third list) ""))) |
|
345 | (or (third list) ""))) | |
346 |
|
346 | |||
347 | (p:defrule block-for (and block-for-head (or block-ml block-sl)) |
|
347 | (p:defrule block-for (and block-for-head (or block-ml block-sl)) | |
348 | (:lambda (list) |
|
348 | (:lambda (list) | |
349 | (apply #'append list))) |
|
349 | (apply #'append list))) | |
350 |
|
350 | |||
351 | (p:defrule block-for-head (and (p:~ "for") spaces variable spaces? equal spaces? expression |
|
351 | (p:defrule block-for-head (and (p:~ "for") spaces variable spaces? equal spaces? expression | |
352 | (p:~ "to") spaces expression |
|
352 | (p:~ "to") spaces expression | |
353 | block-for-head-step |
|
353 | block-for-head-step | |
354 | colon spaces?) |
|
354 | colon spaces?) | |
355 | (:lambda (list) |
|
355 | (:lambda (list) | |
356 | (list 'lib:qspfor |
|
356 | (list 'lib:qspfor | |
357 | (elt list 2) |
|
357 | (elt list 2) | |
358 | (elt list 6) |
|
358 | (elt list 6) | |
359 | (elt list 9) |
|
359 | (elt list 9) | |
360 | (elt list 10)))) |
|
360 | (elt list 10)))) | |
361 |
|
361 | |||
362 | (p:defrule block-for-head-step (p:? (and (p:~ "step") spaces expression spaces?)) |
|
362 | (p:defrule block-for-head-step (p:? (and (p:~ "step") spaces expression spaces?)) | |
363 | (:lambda (list) |
|
363 | (:lambda (list) | |
364 | (if list |
|
364 | (if list | |
365 | (third list) |
|
365 | (third list) | |
366 | 1))) |
|
366 | 1))) | |
367 |
|
367 | |||
368 | (p:defrule block-sl line-body) |
|
368 | (p:defrule block-sl line-body) | |
369 |
|
369 | |||
370 | (p:defrule block-ml (and newline-block-body block-end) |
|
370 | (p:defrule block-ml (and newline-block-body block-end) | |
371 | (:lambda (list) |
|
371 | (:lambda (list) | |
372 | (apply #'list* (butlast list)))) |
|
372 | (apply #'list* (butlast list)))) | |
373 |
|
373 | |||
374 | (p:defrule block-end (and (p:~ "end")) |
|
374 | (p:defrule block-end (and (p:~ "end")) | |
375 | (:constant nil)) |
|
375 | (:constant nil)) | |
376 |
|
376 | |||
377 | ;;; Calls |
|
377 | ;;; Calls | |
378 |
|
378 | |||
379 | (p:defrule first-argument (and expression spaces?) |
|
379 | (p:defrule first-argument (and expression spaces?) | |
380 | (:function first)) |
|
380 | (:function first)) | |
381 | (p:defrule next-argument (and "," spaces? expression) |
|
381 | (p:defrule next-argument (and "," spaces? expression) | |
382 | (:function third)) |
|
382 | (:function third)) | |
383 | (p:defrule arguments (or parenthesized-arguments plain-arguments no-arguments)) |
|
383 | (p:defrule arguments (or parenthesized-arguments plain-arguments no-arguments)) | |
384 | (p:defrule parenthesized-arguments (and spaces? #\( base-arguments #\)) |
|
384 | (p:defrule parenthesized-arguments (and spaces? #\( base-arguments #\)) | |
385 | (:function third)) |
|
385 | (:function third)) | |
386 | (p:defrule plain-arguments (and spaces? base-arguments) |
|
386 | (p:defrule plain-arguments (and spaces? base-arguments) | |
387 | (:function second)) |
|
387 | (:function second)) | |
388 | (p:defrule no-arguments (or (and spaces? (p:& #\newline)) |
|
388 | (p:defrule no-arguments (or (and spaces? (p:& #\newline)) | |
389 | (and spaces? (p:& #\&)) |
|
389 | (and spaces? (p:& #\&)) | |
390 | spaces?) |
|
390 | spaces?) | |
391 | (:constant nil)) |
|
391 | (:constant nil)) | |
392 | (p:defrule base-arguments (or (and first-argument (* next-argument)) spaces?) |
|
392 | (p:defrule base-arguments (or (and first-argument (* next-argument)) spaces?) | |
393 | (:lambda (list) |
|
393 | (:lambda (list) | |
394 | (if (null list) |
|
394 | (if (null list) | |
395 | nil |
|
395 | nil | |
396 | (list* (first list) (second list))))) |
|
396 | (list* (first list) (second list))))) | |
397 |
|
397 | |||
398 | ;;; Intrinsics |
|
398 | ;;; Intrinsics | |
399 |
|
399 | |||
400 | (defmacro defintrinsics ((rule-name returning-rule-name non-returning-rule-name) &body clauses) |
|
400 | (defmacro defintrinsics ((rule-name returning-rule-name non-returning-rule-name) &body clauses) | |
401 | `(progn |
|
401 | `(progn | |
402 | ,@(loop :for clause :in clauses |
|
402 | ,@(loop :for clause :in clauses | |
403 | :collect `(defintrinsic ,@clause)) |
|
403 | :collect `(defintrinsic ,@clause)) | |
404 | (p:defrule ,returning-rule-name (or ,@(remove-nil |
|
404 | (p:defrule ,returning-rule-name (or ,@(remove-nil | |
405 | (mapcar (lambda (clause) |
|
405 | (mapcar (lambda (clause) | |
406 | (when (second clause) |
|
406 | (when (second clause) | |
407 | (alexandria:symbolicate |
|
407 | (alexandria:symbolicate | |
408 | 'intrinsic- (first clause)))) |
|
408 | 'intrinsic- (first clause)))) | |
409 | clauses)))) |
|
409 | clauses)))) | |
410 | (p:defrule ,non-returning-rule-name (or ,@(remove-nil |
|
410 | (p:defrule ,non-returning-rule-name (or ,@(remove-nil | |
411 | (mapcar (lambda (clause) |
|
411 | (mapcar (lambda (clause) | |
412 | (unless (second clause) |
|
412 | (unless (second clause) | |
413 | (alexandria:symbolicate |
|
413 | (alexandria:symbolicate | |
414 | 'intrinsic- (first clause)))) |
|
414 | 'intrinsic- (first clause)))) | |
415 | clauses)))) |
|
415 | clauses)))) | |
416 | (p:defrule ,rule-name (or ,returning-rule-name ,non-returning-rule-name)))) |
|
416 | (p:defrule ,rule-name (or ,returning-rule-name ,non-returning-rule-name)))) | |
417 |
|
417 | |||
418 | (defmacro defintrinsic (sym returning &optional (min-arity 0) max-arity &rest names) |
|
418 | (defmacro defintrinsic (sym returning &optional (min-arity 0) max-arity &rest names) | |
419 | (declare (ignore returning)) |
|
419 | (declare (ignore returning)) | |
420 | (unless max-arity |
|
420 | (unless max-arity | |
421 | (setf max-arity *max-args*)) |
|
421 | (setf max-arity *max-args*)) | |
422 | (setf names |
|
422 | (setf names | |
423 | (if names |
|
423 | (if names | |
424 | (mapcar #'string-upcase names) |
|
424 | (mapcar #'string-upcase names) | |
425 | (list (string sym)))) |
|
425 | (list (string sym)))) | |
426 | `(p:defrule ,(alexandria:symbolicate 'intrinsic- sym) |
|
426 | `(p:defrule ,(alexandria:symbolicate 'intrinsic- sym) | |
427 | (and (p:? #\$) (or ,@(loop :for name :in names :collect `(p:~ ,name))) |
|
427 | (and (p:? #\$) (or ,@(loop :for name :in names :collect `(p:~ ,name))) | |
428 | arguments) |
|
428 | arguments) | |
429 | (:destructure (dollar name arguments) |
|
429 | (:destructure (dollar name arguments) | |
430 | (declare (ignore dollar)) |
|
430 | (declare (ignore dollar)) | |
431 | (unless (<= ,min-arity (length arguments) ,max-arity) |
|
431 | (unless (<= ,min-arity (length arguments) ,max-arity) | |
432 | (error "Intrinsic ~A expects between ~A and ~A arguments but ~A were provided:~%~S" |
|
432 | (error "Intrinsic ~A expects between ~A and ~A arguments but ~A were provided:~%~S" | |
433 | name ,min-arity ,max-arity (length arguments) arguments)) |
|
433 | name ,min-arity ,max-arity (length arguments) arguments)) | |
434 |
(list* ',(intern (string sym) " |
|
434 | (list* ',(intern (string sym) "TXT2WEB.LIB") arguments)))) | |
435 |
|
435 | |||
436 | (defintrinsics (intrinsic returning-intrinsic non-returning-intrinsic) |
|
436 | (defintrinsics (intrinsic returning-intrinsic non-returning-intrinsic) | |
437 | ;; Transitions |
|
437 | ;; Transitions | |
438 | (goto% nil 0 nil "gt" "goto") |
|
438 | (goto% nil 0 nil "gt" "goto") | |
439 | (xgoto% nil 0 nil "xgt" "xgoto") |
|
439 | (xgoto% nil 0 nil "xgt" "xgoto") | |
440 | ;; Variables |
|
440 | ;; Variables | |
441 | (killvar nil 0 2) |
|
441 | (killvar nil 0 2) | |
442 | ;; Expressions |
|
442 | ;; Expressions | |
443 | (obj t 1 1) |
|
443 | (obj t 1 1) | |
444 | (loc t 1 1) |
|
444 | (loc t 1 1) | |
445 | (no t 1 1) |
|
445 | (no t 1 1) | |
446 | ;; Basic |
|
446 | ;; Basic | |
447 | (qspver t 0 0) |
|
447 | (qspver t 0 0) | |
448 | (curloc t 0 0) |
|
448 | (curloc t 0 0) | |
449 | (rand t 1 2) |
|
449 | (rand t 1 2) | |
450 | (rnd t 0 0) |
|
450 | (rnd t 0 0) | |
451 | (qspmax t 1 nil "max") |
|
451 | (qspmax t 1 nil "max") | |
452 | (qspmin t 1 nil "min") |
|
452 | (qspmin t 1 nil "min") | |
453 | ;; Arrays |
|
453 | ;; Arrays | |
454 | (killall nil 0 0) |
|
454 | (killall nil 0 0) | |
455 | (copyarr nil 2 4) |
|
455 | (copyarr nil 2 4) | |
456 | (arrsize t 1 1) |
|
456 | (arrsize t 1 1) | |
457 | (arrpos t 2 3) |
|
457 | (arrpos t 2 3) | |
458 | (arrcomp t 2 3) |
|
458 | (arrcomp t 2 3) | |
459 | ;; Strings |
|
459 | ;; Strings | |
460 | (len t 1 1) |
|
460 | (len t 1 1) | |
461 | (mid t 2 3) |
|
461 | (mid t 2 3) | |
462 | (ucase t 1 1) |
|
462 | (ucase t 1 1) | |
463 | (lcase t 1 1) |
|
463 | (lcase t 1 1) | |
464 | (trim t 1 1) |
|
464 | (trim t 1 1) | |
465 | (replace t 2 3) |
|
465 | (replace t 2 3) | |
466 | (instr t 2 3) |
|
466 | (instr t 2 3) | |
467 | (isnum t 1 1) |
|
467 | (isnum t 1 1) | |
468 | (val t 1 1) |
|
468 | (val t 1 1) | |
469 | (qspstr t 1 1 "str") |
|
469 | (qspstr t 1 1 "str") | |
470 | (strcomp t 2 2) |
|
470 | (strcomp t 2 2) | |
471 | (strfind t 2 3) |
|
471 | (strfind t 2 3) | |
472 | (strpos t 2 3) |
|
472 | (strpos t 2 3) | |
473 | ;; IF |
|
473 | ;; IF | |
474 | (iif t 2 3) |
|
474 | (iif t 2 3) | |
475 | ;; Subs |
|
475 | ;; Subs | |
476 | (gosub nil 1 nil "gosub" "gs") |
|
476 | (gosub nil 1 nil "gosub" "gs") | |
477 | (func t 1 nil) |
|
477 | (func t 1 nil) | |
478 | (exit nil 0 0) |
|
478 | (exit nil 0 0) | |
479 | ;; Jump |
|
479 | ;; Jump | |
480 | (jump nil 1 1) |
|
480 | (jump nil 1 1) | |
481 | ;; Dynamic |
|
481 | ;; Dynamic | |
482 | (dynamic nil 1 nil) |
|
482 | (dynamic nil 1 nil) | |
483 | (dyneval t 1 nil) |
|
483 | (dyneval t 1 nil) | |
484 | ;; Sound |
|
484 | ;; Sound | |
485 | (play nil 1 2) |
|
485 | (play nil 1 2) | |
486 | (isplay t 1 1) |
|
486 | (isplay t 1 1) | |
487 | (close nil 1 1) |
|
487 | (close nil 1 1) | |
488 | (closeall nil 0 0 "close all") |
|
488 | (closeall nil 0 0 "close all") | |
489 | ;; Main window |
|
489 | ;; Main window | |
490 | (main-pl nil 1 1 "*pl") |
|
490 | (main-pl nil 1 1 "*pl") | |
491 | (main-nl nil 0 1 "*nl") |
|
491 | (main-nl nil 0 1 "*nl") | |
492 | (main-p nil 1 1 "*p") |
|
492 | (main-p nil 1 1 "*p") | |
493 | (maintxt t 0 0) |
|
493 | (maintxt t 0 0) | |
494 | (desc t 1 1) |
|
494 | (desc t 1 1) | |
495 | (main-clear nil 0 0 "*clear" "*clr") |
|
495 | (main-clear nil 0 0 "*clear" "*clr") | |
496 | ;; Aux window |
|
496 | ;; Aux window | |
497 | (showstat nil 1 1) |
|
497 | (showstat nil 1 1) | |
498 | (stat-pl nil 1 1 "pl") |
|
498 | (stat-pl nil 1 1 "pl") | |
499 | (stat-nl nil 0 1 "nl") |
|
499 | (stat-nl nil 0 1 "nl") | |
500 | (stat-p nil 1 1 "p") |
|
500 | (stat-p nil 1 1 "p") | |
501 | (stattxt t 0 0) |
|
501 | (stattxt t 0 0) | |
502 | (stat-clear nil 0 0 "clear" "clr") |
|
502 | (stat-clear nil 0 0 "clear" "clr") | |
503 | (cls nil 0 0) |
|
503 | (cls nil 0 0) | |
504 | ;; Dialog |
|
504 | ;; Dialog | |
505 | (msg nil 1 1) |
|
505 | (msg nil 1 1) | |
506 | ;; Acts |
|
506 | ;; Acts | |
507 | (showacts nil 1 1) |
|
507 | (showacts nil 1 1) | |
508 | (delact nil 1 1 "delact" "del act") |
|
508 | (delact nil 1 1 "delact" "del act") | |
509 | (curacts t 0 0) |
|
509 | (curacts t 0 0) | |
510 | (selact t 0 0) |
|
510 | (selact t 0 0) | |
511 | (cla nil 0 0) |
|
511 | (cla nil 0 0) | |
512 | ;; Objects |
|
512 | ;; Objects | |
513 | (showobjs nil 1 1) |
|
513 | (showobjs nil 1 1) | |
514 | (addobj nil 1 3 "addobj" "add obj") |
|
514 | (addobj nil 1 3 "addobj" "add obj") | |
515 | (delobj nil 1 1 "delobj" "del obj") |
|
515 | (delobj nil 1 1 "delobj" "del obj") | |
516 | (killobj nil 0 1) |
|
516 | (killobj nil 0 1) | |
517 | (countobj t 0 0) |
|
517 | (countobj t 0 0) | |
518 | (getobj t 1 1) |
|
518 | (getobj t 1 1) | |
519 | (selobj t 0 0) |
|
519 | (selobj t 0 0) | |
520 | ;; Menu |
|
520 | ;; Menu | |
521 | (menu nil 1 1) |
|
521 | (menu nil 1 1) | |
522 | ;; Images |
|
522 | ;; Images | |
523 | (refint nil 0 0) |
|
523 | (refint nil 0 0) | |
524 | (view nil 0 1) |
|
524 | (view nil 0 1) | |
525 | (img nil 1) |
|
525 | (img nil 1) | |
526 | (*img nil 1) |
|
526 | (*img nil 1) | |
527 | ;; Fonts |
|
527 | ;; Fonts | |
528 | (rgb t 3 3) |
|
528 | (rgb t 3 3) | |
529 | ;; Input |
|
529 | ;; Input | |
530 | (showinput nil 1 1) |
|
530 | (showinput nil 1 1) | |
531 | (usertxt t 0 0 "user_text" "usrtxt") |
|
531 | (usertxt t 0 0 "user_text" "usrtxt") | |
532 | (cmdclear nil 0 0 "cmdclear" "cmdclr") |
|
532 | (cmdclear nil 0 0 "cmdclear" "cmdclr") | |
533 | (input t 1 1) |
|
533 | (input t 1 1) | |
534 | ;; Files |
|
534 | ;; Files | |
535 | (openqst nil 1 1) |
|
535 | (openqst nil 1 1) | |
536 | (addqst nil 1 1 "addqst" "addlib" "inclib") |
|
536 | (addqst nil 1 1 "addqst" "addlib" "inclib") | |
537 | (killqst nil 1 1 "killqst" "dellib" "freelib") |
|
537 | (killqst nil 1 1 "killqst" "dellib" "freelib") | |
538 | (opengame nil 0 0) |
|
538 | (opengame nil 0 0) | |
539 | (savegame nil 0 0) |
|
539 | (savegame nil 0 0) | |
540 | ;; Real time |
|
540 | ;; Real time | |
541 | (wait nil 1 1) |
|
541 | (wait nil 1 1) | |
542 | (msecscount t 0 0) |
|
542 | (msecscount t 0 0) | |
543 | (settimer nil 1 1)) |
|
543 | (settimer nil 1 1)) | |
544 |
|
544 | |||
545 | ;;; Expression |
|
545 | ;;; Expression | |
546 |
|
546 | |||
547 | (p:defrule expression or-expr) |
|
547 | (p:defrule expression or-expr) | |
548 |
|
548 | |||
549 | (p:defrule or-expr (and and-expr (* (and spaces? or-op spaces? and-expr))) |
|
549 | (p:defrule or-expr (and and-expr (* (and spaces? or-op spaces? and-expr))) | |
550 | (:function do-binop)) |
|
550 | (:function do-binop)) | |
551 |
|
551 | |||
552 | (p:defrule and-expr (and eq-expr (* (and spaces? and-op spaces? eq-expr))) |
|
552 | (p:defrule and-expr (and eq-expr (* (and spaces? and-op spaces? eq-expr))) | |
553 | (:function do-binop)) |
|
553 | (:function do-binop)) | |
554 |
|
554 | |||
555 | (p:defrule eq-expr (and sum-expr (* (and spaces? (or "<=" ">=" "=<" "=>" "<>" |
|
555 | (p:defrule eq-expr (and sum-expr (* (and spaces? (or "<=" ">=" "=<" "=>" "<>" | |
556 | "=" "<" ">" "!") |
|
556 | "=" "<" ">" "!") | |
557 | spaces? sum-expr))) |
|
557 | spaces? sum-expr))) | |
558 | (:function do-binop)) |
|
558 | (:function do-binop)) | |
559 |
|
559 | |||
560 | (p:defrule sum-expr (and mod-expr (* (and spaces? (or #\+ #\-) spaces? mod-expr))) |
|
560 | (p:defrule sum-expr (and mod-expr (* (and spaces? (or #\+ #\-) spaces? mod-expr))) | |
561 | (:function do-binop)) |
|
561 | (:function do-binop)) | |
562 |
|
562 | |||
563 | (p:defrule mod-expr (and mul-expr (* (and spaces? (p:~ "mod") spaces? mul-expr))) |
|
563 | (p:defrule mod-expr (and mul-expr (* (and spaces? (p:~ "mod") spaces? mul-expr))) | |
564 | (:function do-binop)) |
|
564 | (:function do-binop)) | |
565 |
|
565 | |||
566 | (p:defrule mul-expr (and unary-expr (* (and spaces? (or #\* #\/) spaces? unary-expr))) |
|
566 | (p:defrule mul-expr (and unary-expr (* (and spaces? (or #\* #\/) spaces? unary-expr))) | |
567 | (:function do-binop)) |
|
567 | (:function do-binop)) | |
568 |
|
568 | |||
569 | (p:defrule unary-expr (and (p:? (or #\+ #\-)) atom-expr) |
|
569 | (p:defrule unary-expr (and (p:? (or #\+ #\-)) atom-expr) | |
570 | (:lambda (list) |
|
570 | (:lambda (list) | |
571 | (let ((expr (remove-nil list))) |
|
571 | (let ((expr (remove-nil list))) | |
572 | (if (= 1 (length expr)) |
|
572 | (if (= 1 (length expr)) | |
573 | (first expr) |
|
573 | (first expr) | |
574 | (intern-first expr))))) |
|
574 | (intern-first expr))))) | |
575 |
|
575 | |||
576 | (p:defrule atom-expr (and (or variable literal returning-intrinsic paren-expr) spaces?) |
|
576 | (p:defrule atom-expr (and (or variable literal returning-intrinsic paren-expr) spaces?) | |
577 | (:function first)) |
|
577 | (:function first)) | |
578 |
|
578 | |||
579 | (p:defrule paren-expr (and #\( spaces? expression spaces? #\)) |
|
579 | (p:defrule paren-expr (and #\( spaces? expression spaces? #\)) | |
580 | (:function third)) |
|
580 | (:function third)) | |
581 |
|
581 | |||
582 | (p:defrule or-op (p:~ "or") |
|
582 | (p:defrule or-op (p:~ "or") | |
583 | (:constant "or")) |
|
583 | (:constant "or")) | |
584 |
|
584 | |||
585 | (p:defrule and-op (p:~ "and") |
|
585 | (p:defrule and-op (p:~ "and") | |
586 | (:constant "and")) |
|
586 | (:constant "and")) | |
587 |
|
587 | |||
588 | ;;; Variables |
|
588 | ;;; Variables | |
589 |
|
589 | |||
590 | (p:defrule variable (and identifier (p:? array-index)) |
|
590 | (p:defrule variable (and identifier (p:? array-index)) | |
591 | (:destructure (id idx-raw) |
|
591 | (:destructure (id idx-raw) | |
592 | (let ((idx (case idx-raw |
|
592 | (let ((idx (case idx-raw | |
593 | ((nil) 0) |
|
593 | ((nil) 0) | |
594 | (:last nil) |
|
594 | (:last nil) | |
595 | (t idx-raw)))) |
|
595 | (t idx-raw)))) | |
596 | (list 'lib:qspvar id idx)))) |
|
596 | (list 'lib:qspvar id idx)))) | |
597 |
|
597 | |||
598 | (p:defrule array-index (and #\[ spaces? (p:? expression) spaces? #\]) |
|
598 | (p:defrule array-index (and #\[ spaces? (p:? expression) spaces? #\]) | |
599 | (:lambda (list) |
|
599 | (:lambda (list) | |
600 | (or (third list) :last))) |
|
600 | (or (third list) :last))) | |
601 |
|
601 | |||
602 | (p:defrule assignment (or kw-assignment plain-assignment op-assignment) |
|
602 | (p:defrule assignment (or kw-assignment plain-assignment op-assignment) | |
603 | (:destructure (qspvar eq expr) |
|
603 | (:destructure (qspvar eq expr) | |
604 | (declare (ignore eq)) |
|
604 | (declare (ignore eq)) | |
605 | (list 'lib:set qspvar expr))) |
|
605 | (list 'lib:set qspvar expr))) | |
606 |
|
606 | |||
607 | (p:defrule kw-assignment (and (or (p:~ "let") (p:~ "set")) spaces? (or op-assignment plain-assignment)) |
|
607 | (p:defrule kw-assignment (and (or (p:~ "let") (p:~ "set")) spaces? (or op-assignment plain-assignment)) | |
608 | (:function third)) |
|
608 | (:function third)) | |
609 |
|
609 | |||
610 | (p:defrule op-assignment (and variable spaces? (or "+" "-" "*" "/") #\= spaces? expression) |
|
610 | (p:defrule op-assignment (and variable spaces? (or "+" "-" "*" "/") #\= spaces? expression) | |
611 | (:destructure (qspvar ws1 op eq ws2 expr) |
|
611 | (:destructure (qspvar ws1 op eq ws2 expr) | |
612 | (declare (ignore ws1 ws2)) |
|
612 | (declare (ignore ws1 ws2)) | |
613 | (list qspvar eq (intern-first (list op qspvar expr))))) |
|
613 | (list qspvar eq (intern-first (list op qspvar expr))))) | |
614 |
|
614 | |||
615 | (p:defrule plain-assignment (and variable spaces? #\= spaces? expression) |
|
615 | (p:defrule plain-assignment (and variable spaces? #\= spaces? expression) | |
616 | (:function remove-nil)) |
|
616 | (:function remove-nil)) | |
617 |
|
617 | |||
618 | ;;; Non-string literals |
|
618 | ;;; Non-string literals | |
619 |
|
619 | |||
620 | (p:defrule literal (or qsp-string brace-string number)) |
|
620 | (p:defrule literal (or qsp-string brace-string number)) | |
621 |
|
621 | |||
622 | (p:defrule number (+ (or #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) |
|
622 | (p:defrule number (+ (or #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) | |
623 | (:lambda (list) |
|
623 | (:lambda (list) | |
624 | (parse-integer (p:text list)))) |
|
624 | (parse-integer (p:text list)))) |
@@ -1,377 +1,377 b'' | |||||
1 |
|
1 | |||
2 |
(in-package |
|
2 | (in-package txt2web.lib) | |
3 |
|
3 | |||
4 | ;;;; Parenscript macros which make the parser's intermediate |
|
4 | ;;;; Parenscript macros which make the parser's intermediate | |
5 | ;;;; representation directly compilable by Parenscript |
|
5 | ;;;; representation directly compilable by Parenscript | |
6 | ;;;; Some utility macros for other .ps sources too. |
|
6 | ;;;; Some utility macros for other .ps sources too. | |
7 |
|
7 | |||
8 | ;;;; Block type | Has own locals | Has labels | async |
|
8 | ;;;; Block type | Has own locals | Has labels | async | |
9 | ;;; Location | TRUE | TRUE | TRUE |
|
9 | ;;; Location | TRUE | TRUE | TRUE | |
10 | ;;; Act | TRUE | TRUE | TRUE |
|
10 | ;;; Act | TRUE | TRUE | TRUE | |
11 | ;;; {} | TRUE | TRUE | TRUE |
|
11 | ;;; {} | TRUE | TRUE | TRUE | |
12 | ;;; IF | FALSE | TRUE | TRUE |
|
12 | ;;; IF | FALSE | TRUE | TRUE | |
13 | ;;; FOR | FALSE | TRUE | TRUE |
|
13 | ;;; FOR | FALSE | TRUE | TRUE | |
14 | ;;; |
|
14 | ;;; | |
15 | ;;; IF and FOR are actually not blocks at all. They're implemented as Javascript's if and for loops. |
|
15 | ;;; IF and FOR are actually not blocks at all. They're implemented as Javascript's if and for loops. | |
16 | ;;; Jumps back are also optimized to Javascript's while loops. |
|
16 | ;;; Jumps back are also optimized to Javascript's while loops. | |
17 |
|
17 | |||
18 | ;;; Utils |
|
18 | ;;; Utils | |
19 |
|
19 | |||
20 | ;;; Common |
|
20 | ;;; Common | |
21 |
|
21 | |||
22 | (defpsmacro label-block (() &body body) |
|
22 | (defpsmacro label-block (() &body body) | |
23 | (let ((has-labels (some #'keywordp body))) |
|
23 | (let ((has-labels (some #'keywordp body))) | |
24 | `(block nil |
|
24 | `(block nil | |
25 | ,@(when has-labels |
|
25 | ,@(when has-labels | |
26 | '((var _labels (list)))) |
|
26 | '((var _labels (list)))) | |
27 | (tagbody |
|
27 | (tagbody | |
28 | ,@body |
|
28 | ,@body | |
29 | (void))))) |
|
29 | (void))))) | |
30 |
|
30 | |||
31 | (defpsmacro str (&rest forms) |
|
31 | (defpsmacro str (&rest forms) | |
32 | (cond ((zerop (length forms)) |
|
32 | (cond ((zerop (length forms)) | |
33 | "") |
|
33 | "") | |
34 | ((and (= 1 (length forms)) |
|
34 | ((and (= 1 (length forms)) | |
35 | (stringp (first forms))) |
|
35 | (stringp (first forms))) | |
36 | (first forms)) |
|
36 | (first forms)) | |
37 | (t |
|
37 | (t | |
38 | `(& ,@forms)))) |
|
38 | `(& ,@forms)))) | |
39 |
|
39 | |||
40 | (defpsmacro locals-block (&body body) |
|
40 | (defpsmacro locals-block (&body body) | |
41 | "Includes labels too (through qsp-lambda)" |
|
41 | "Includes labels too (through qsp-lambda)" | |
42 | (let ((*locals* nil)) |
|
42 | (let ((*locals* nil)) | |
43 | (walker:walk 'locals body) |
|
43 | (walker:walk 'locals body) | |
44 | `(qsp-lambda |
|
44 | `(qsp-lambda | |
45 | (create-locals ,*locals*) |
|
45 | (create-locals ,*locals*) | |
46 | ,@(walker:walk 'apply-vars body)))) |
|
46 | ,@(walker:walk 'apply-vars body)))) | |
47 |
|
47 | |||
48 | ;;; 1loc |
|
48 | ;;; 1loc | |
49 |
|
49 | |||
50 | (defparameter *special-variables* |
|
50 | (defparameter *special-variables* | |
51 | '((usehtml 0) |
|
51 | '((usehtml 0) | |
52 | (result 0) |
|
52 | (result 0) | |
53 | ($result 0) |
|
53 | ($result 0) | |
54 | ($ongload 0) |
|
54 | ($ongload 0) | |
55 | ($ongsave 0) |
|
55 | ($ongsave 0) | |
56 | ($onobjadd 0) |
|
56 | ($onobjadd 0) | |
57 | ($onobjdel 0) |
|
57 | ($onobjdel 0) | |
58 | ($onobjsel 0) |
|
58 | ($onobjsel 0) | |
59 | ($onnewloc 0) |
|
59 | ($onnewloc 0) | |
60 | ($onactsel 0) |
|
60 | ($onactsel 0) | |
61 | ($counter 0) |
|
61 | ($counter 0) | |
62 | ($usercom 0))) |
|
62 | ($usercom 0))) | |
63 |
|
63 | |||
64 | (defpsmacro game ((name) &body body) |
|
64 | (defpsmacro game ((name) &body body) | |
65 | (setf body (walker:walk 'for-transform body)) |
|
65 | (setf body (walker:walk 'for-transform body)) | |
66 | (setf *globals* *special-variables*) |
|
66 | (setf *globals* *special-variables*) | |
67 | (walker:walk 'globals body) |
|
67 | (walker:walk 'globals body) | |
68 | `(progn |
|
68 | `(progn | |
69 | ;; Game object |
|
69 | ;; Game object | |
70 | (setf (@ *games ,name) |
|
70 | (setf (@ *games ,name) | |
71 | (create)) |
|
71 | (create)) | |
72 | ;; Global variables from this game |
|
72 | ;; Global variables from this game | |
73 | (create-globals ,*globals*) |
|
73 | (create-globals ,*globals*) | |
74 | ;; Locations |
|
74 | ;; Locations | |
75 | ,@(loop :for location :in body |
|
75 | ,@(loop :for location :in body | |
76 | :collect `(setf (@ *games ,name ,(caadr location)) |
|
76 | :collect `(setf (@ *games ,name ,(caadr location)) | |
77 | ,location)))) |
|
77 | ,location)))) | |
78 |
|
78 | |||
79 | (defpsmacro location ((name) &body body) |
|
79 | (defpsmacro location ((name) &body body) | |
80 | (declare (ignore name)) |
|
80 | (declare (ignore name)) | |
81 | "Name is used by the game macro above" |
|
81 | "Name is used by the game macro above" | |
82 | `(locals-block ,@body)) |
|
82 | `(locals-block ,@body)) | |
83 |
|
83 | |||
84 | (defpsmacro goto% (target &rest args) |
|
84 | (defpsmacro goto% (target &rest args) | |
85 | `(progn |
|
85 | `(progn | |
86 | (goto ,target ,args) |
|
86 | (goto ,target ,args) | |
87 | (exit))) |
|
87 | (exit))) | |
88 |
|
88 | |||
89 | (defpsmacro xgoto% (target &rest args) |
|
89 | (defpsmacro xgoto% (target &rest args) | |
90 | `(progn |
|
90 | `(progn | |
91 | (xgoto ,target ,args) |
|
91 | (xgoto ,target ,args) | |
92 | (exit))) |
|
92 | (exit))) | |
93 |
|
93 | |||
94 | ;;; 2var |
|
94 | ;;; 2var | |
95 |
|
95 | |||
96 | (defvar *globals* nil) |
|
96 | (defvar *globals* nil) | |
97 | (defvar *locals* nil) |
|
97 | (defvar *locals* nil) | |
98 |
|
98 | |||
99 | (defpsmacro create-globals (globals) |
|
99 | (defpsmacro create-globals (globals) | |
100 | (flet ((indexes (name) |
|
100 | (flet ((indexes (name) | |
101 | (remove nil |
|
101 | (remove nil | |
102 | (remove-if #'listp |
|
102 | (remove-if #'listp | |
103 | (mapcar #'second |
|
103 | (mapcar #'second | |
104 | (remove name globals |
|
104 | (remove name globals | |
105 | :key #'first |
|
105 | :key #'first | |
106 | :test-not #'eq)))))) |
|
106 | :test-not #'eq)))))) | |
107 | (let ((names (remove-duplicates (mapcar #'first globals)))) |
|
107 | (let ((names (remove-duplicates (mapcar #'first globals)))) | |
108 | `(chain *object |
|
108 | `(chain *object | |
109 | (assign *globals |
|
109 | (assign *globals | |
110 | (create |
|
110 | (create | |
111 | ,@(loop :for sym :in names |
|
111 | ,@(loop :for sym :in names | |
112 | :for indexes := (indexes sym) |
|
112 | :for indexes := (indexes sym) | |
113 | :for name := (string-upcase sym) |
|
113 | :for name := (string-upcase sym) | |
114 | :append `(,name |
|
114 | :append `(,name | |
115 | (api-call new-var ,name ,@indexes))))))))) |
|
115 | (api-call new-var ,name ,@indexes))))))))) | |
116 |
|
116 | |||
117 | (walker:deftransform globals qspvar (&rest var) |
|
117 | (walker:deftransform globals qspvar (&rest var) | |
118 | (pushnew var *globals* :test #'equal) |
|
118 | (pushnew var *globals* :test #'equal) | |
119 | (walker:walk-continue)) |
|
119 | (walker:walk-continue)) | |
120 |
|
120 | |||
121 | (walker:deftransform globals local (var &rest expr) |
|
121 | (walker:deftransform globals local (var &rest expr) | |
122 | (declare (ignore var)) |
|
122 | (declare (ignore var)) | |
123 | (walker:walk 'globals expr)) |
|
123 | (walker:walk 'globals expr)) | |
124 |
|
124 | |||
125 | (defpsmacro create-locals (locals) |
|
125 | (defpsmacro create-locals (locals) | |
126 | (when locals |
|
126 | (when locals | |
127 | `(progn |
|
127 | `(progn | |
128 | (var locals (create |
|
128 | (var locals (create | |
129 | ,@(loop :for (sym index) :in locals |
|
129 | ,@(loop :for (sym index) :in locals | |
130 | :for name := (string-upcase sym) |
|
130 | :for name := (string-upcase sym) | |
131 | :append `(,name (api-call new-var ,name)))))))) |
|
131 | :append `(,name (api-call new-var ,name)))))))) | |
132 |
|
132 | |||
133 | ;; locations, blocks, and acts all have their own locals namespace |
|
133 | ;; locations, blocks, and acts all have their own locals namespace | |
134 | (walker:deftransform-stop locals qspblock) |
|
134 | (walker:deftransform-stop locals qspblock) | |
135 | (walker:deftransform-stop locals act) |
|
135 | (walker:deftransform-stop locals act) | |
136 |
|
136 | |||
137 | (walker:deftransform locals local (var &optional expr) |
|
137 | (walker:deftransform locals local (var &optional expr) | |
138 | (declare (ignore expr)) |
|
138 | (declare (ignore expr)) | |
139 | (pushnew (rest var) *locals* :test #'equal) |
|
139 | (pushnew (rest var) *locals* :test #'equal) | |
140 | nil) |
|
140 | nil) | |
141 |
|
141 | |||
142 | ;; index types: |
|
142 | ;; index types: | |
143 | ;; literal number |
|
143 | ;; literal number | |
144 | ;; literal string |
|
144 | ;; literal string | |
145 | ;; variable number |
|
145 | ;; variable number | |
146 | ;; variable string |
|
146 | ;; variable string | |
147 | ;; expression (may be possible to determine if it's a string or a number) |
|
147 | ;; expression (may be possible to determine if it's a string or a number) | |
148 |
|
148 | |||
149 | (defun $-var-p (sym) |
|
149 | (defun $-var-p (sym) | |
150 | (char= #\$ (elt (string-upcase (symbol-name sym)) 0))) |
|
150 | (char= #\$ (elt (string-upcase (symbol-name sym)) 0))) | |
151 |
|
151 | |||
152 | (defun literal-string-p (form) |
|
152 | (defun literal-string-p (form) | |
153 | (and (listp form) |
|
153 | (and (listp form) | |
154 | (= 2 (length form)) |
|
154 | (= 2 (length form)) | |
155 | (eq 'str (first form)) |
|
155 | (eq 'str (first form)) | |
156 | (stringp (second form)))) |
|
156 | (stringp (second form)))) | |
157 |
|
157 | |||
158 | (defun variable-number-p (form) |
|
158 | (defun variable-number-p (form) | |
159 | (and (listp form) |
|
159 | (and (listp form) | |
160 | (eq 'qspvar (first form)) |
|
160 | (eq 'qspvar (first form)) | |
161 | (not ($-var-p (second form))))) |
|
161 | (not ($-var-p (second form))))) | |
162 |
|
162 | |||
163 | (defun variable-string-p (form) |
|
163 | (defun variable-string-p (form) | |
164 | (and (listp form) |
|
164 | (and (listp form) | |
165 | (eq 'qspvar (first form)) |
|
165 | (eq 'qspvar (first form)) | |
166 | ($-var-p (second form)))) |
|
166 | ($-var-p (second form)))) | |
167 |
|
167 | |||
168 | (walker:deftransform apply-vars set (var expr) |
|
168 | (walker:deftransform apply-vars set (var expr) | |
169 | (destructuring-bind (qspvar name index) |
|
169 | (destructuring-bind (qspvar name index) | |
170 | var |
|
170 | var | |
171 | (declare (ignore qspvar)) |
|
171 | (declare (ignore qspvar)) | |
172 | (setf name (string-upcase name)) |
|
172 | (setf name (string-upcase name)) | |
173 | (let ((slot `(getprop |
|
173 | (let ((slot `(getprop | |
174 | ,(if (member name *locals* :key #'first) |
|
174 | ,(if (member name *locals* :key #'first) | |
175 | 'locals '*globals) |
|
175 | 'locals '*globals) | |
176 | ,name)) |
|
176 | ,name)) | |
177 | (index (walker:walk 'apply-vars index)) |
|
177 | (index (walker:walk 'apply-vars index)) | |
178 | (value (walker:walk 'apply-vars expr))) |
|
178 | (value (walker:walk 'apply-vars expr))) | |
179 | (cond |
|
179 | (cond | |
180 | ((member name api:*serv-vars* :test #'equalp) |
|
180 | ((member name api:*serv-vars* :test #'equalp) | |
181 | `(api:set-serv-var ,name ,index ,value)) |
|
181 | `(api:set-serv-var ,name ,index ,value)) | |
182 | ((null index) |
|
182 | ((null index) | |
183 | `(chain (elt ,slot) (push ,value))) |
|
183 | `(chain (elt ,slot) (push ,value))) | |
184 | ((or (numberp index) |
|
184 | ((or (numberp index) | |
185 | (variable-number-p index)) |
|
185 | (variable-number-p index)) | |
186 | `(setf (elt ,slot ,index) ,value)) |
|
186 | `(setf (elt ,slot ,index) ,value)) | |
187 | ((or (literal-string-p index) |
|
187 | ((or (literal-string-p index) | |
188 | (variable-string-p index)) |
|
188 | (variable-string-p index)) | |
189 | `(api:set-str-element ,slot ,index ,value)) |
|
189 | `(api:set-str-element ,slot ,index ,value)) | |
190 | (t |
|
190 | (t | |
191 | `(api:set-any-element ,slot ,index ,value)))))) |
|
191 | `(api:set-any-element ,slot ,index ,value)))))) | |
192 |
|
192 | |||
193 | (walker:deftransform apply-vars local (var &optional expr) |
|
193 | (walker:deftransform apply-vars local (var &optional expr) | |
194 | ;; TODO: var can't be a service variable |
|
194 | ;; TODO: var can't be a service variable | |
195 | (when expr |
|
195 | (when expr | |
196 | (walker:walk 'apply-vars (list 'set var expr)))) |
|
196 | (walker:walk 'apply-vars (list 'set var expr)))) | |
197 |
|
197 | |||
198 | (walker:deftransform apply-vars qspvar (name index) |
|
198 | (walker:deftransform apply-vars qspvar (name index) | |
199 | (let ((slot `(getprop |
|
199 | (let ((slot `(getprop | |
200 | ,(if (member name *locals* :key #'first) 'locals '*globals) |
|
200 | ,(if (member name *locals* :key #'first) 'locals '*globals) | |
201 | ,(string-upcase name)))) |
|
201 | ,(string-upcase name)))) | |
202 | (cond |
|
202 | (cond | |
203 | ((null index) |
|
203 | ((null index) | |
204 | `(elt ,slot (1- (length ,slot)))) |
|
204 | `(elt ,slot (1- (length ,slot)))) | |
205 | ((or (numberp index) |
|
205 | ((or (numberp index) | |
206 | (variable-number-p index)) |
|
206 | (variable-number-p index)) | |
207 | `(elt ,slot ,(walker:walk-continue index))) |
|
207 | `(elt ,slot ,(walker:walk-continue index))) | |
208 | ((or (literal-string-p index) |
|
208 | ((or (literal-string-p index) | |
209 | (variable-string-p index)) |
|
209 | (variable-string-p index)) | |
210 | `(elt ,slot (@ ,slot :indexes ,(walker:walk-continue index)))) |
|
210 | `(elt ,slot (@ ,slot :indexes ,(walker:walk-continue index)))) | |
211 | (t |
|
211 | (t | |
212 | `(get-element ,slot ,(walker:walk-continue index)))))) |
|
212 | `(get-element ,slot ,(walker:walk-continue index)))))) | |
213 |
|
213 | |||
214 | (walker:deftransform apply-vars qspblock (&rest block) |
|
214 | (walker:deftransform apply-vars qspblock (&rest block) | |
215 | (declare (ignore block)) |
|
215 | (declare (ignore block)) | |
216 | (walker:whole)) |
|
216 | (walker:whole)) | |
217 | (walker:deftransform apply-vars act (&rest block) |
|
217 | (walker:deftransform apply-vars act (&rest block) | |
218 | (declare (ignore block)) |
|
218 | (declare (ignore block)) | |
219 | (walker:whole)) |
|
219 | (walker:whole)) | |
220 | (walker:deftransform apply-vars qspfor (var from to step body) |
|
220 | (walker:deftransform apply-vars qspfor (var from to step body) | |
221 | (list* 'qspfor var (mapcar #'walker:walk-continue (list from to step body)))) |
|
221 | (list* 'qspfor var (mapcar #'walker:walk-continue (list from to step body)))) | |
222 |
|
222 | |||
223 | ;;; 3expr |
|
223 | ;;; 3expr | |
224 |
|
224 | |||
225 | (defpsmacro <> (op1 op2) |
|
225 | (defpsmacro <> (op1 op2) | |
226 | `(not (equal ,op1 ,op2))) |
|
226 | `(not (equal ,op1 ,op2))) | |
227 |
|
227 | |||
228 | (defpsmacro ! (op1 op2) |
|
228 | (defpsmacro ! (op1 op2) | |
229 | `(not (equal ,op1 ,op2))) |
|
229 | `(not (equal ,op1 ,op2))) | |
230 |
|
230 | |||
231 | ;;; 4code |
|
231 | ;;; 4code | |
232 |
|
232 | |||
233 | (defpsmacro exec (&body body) |
|
233 | (defpsmacro exec (&body body) | |
234 | (format nil "javascript: ~{~A~^~%~}" (mapcar #'ps* body))) |
|
234 | (format nil "javascript: ~{~A~^~%~}" (mapcar #'ps* body))) | |
235 |
|
235 | |||
236 | ;;; 5arrays |
|
236 | ;;; 5arrays | |
237 |
|
237 | |||
238 | ;;; 6str |
|
238 | ;;; 6str | |
239 |
|
239 | |||
240 | (defpsmacro & (&rest args) |
|
240 | (defpsmacro & (&rest args) | |
241 | `(chain "" (concat ,@args))) |
|
241 | `(chain "" (concat ,@args))) | |
242 |
|
242 | |||
243 | ;;; 7if |
|
243 | ;;; 7if | |
244 |
|
244 | |||
245 | (defpsmacro qspcond (&rest clauses) |
|
245 | (defpsmacro qspcond (&rest clauses) | |
246 | `(cond ,@(loop :for clause :in clauses |
|
246 | `(cond ,@(loop :for clause :in clauses | |
247 | :collect (list (first clause) |
|
247 | :collect (list (first clause) | |
248 | `(tagbody |
|
248 | `(tagbody | |
249 | ,@(rest clause)))))) |
|
249 | ,@(rest clause)))))) | |
250 |
|
250 | |||
251 | ;;; 8sub |
|
251 | ;;; 8sub | |
252 |
|
252 | |||
253 | ;;; 9loops |
|
253 | ;;; 9loops | |
254 | ;;; Yep, that's a huge kludge since Javascript doesn't support arbitrary labels |
|
254 | ;;; Yep, that's a huge kludge since Javascript doesn't support arbitrary labels | |
255 |
|
255 | |||
256 | (defpsmacro jump (target) |
|
256 | (defpsmacro jump (target) | |
257 | `(return-from label-body ,(string-upcase (second target)))) |
|
257 | `(return-from label-body ,(string-upcase (second target)))) | |
258 |
|
258 | |||
259 | (defpsmacro tagbody (&body body) |
|
259 | (defpsmacro tagbody (&body body) | |
260 | (let ((create-locals (if (eq (caar body) 'create-locals) |
|
260 | (let ((create-locals (if (eq (caar body) 'create-locals) | |
261 | (list (car body)))) |
|
261 | (list (car body)))) | |
262 | (void (if (equal (car (last body)) '(void)) |
|
262 | (void (if (equal (car (last body)) '(void)) | |
263 | '((void))))) |
|
263 | '((void))))) | |
264 | (when create-locals |
|
264 | (when create-locals | |
265 | (setf body (cdr body))) |
|
265 | (setf body (cdr body))) | |
266 | (when void |
|
266 | (when void | |
267 | (setf body (butlast body))) |
|
267 | (setf body (butlast body))) | |
268 | (let ((funcs (list nil "_nil"))) |
|
268 | (let ((funcs (list nil "_nil"))) | |
269 | (dolist (form body) |
|
269 | (dolist (form body) | |
270 | (cond ((keywordp form) |
|
270 | (cond ((keywordp form) | |
271 | (setf (first funcs) (reverse (first funcs))) |
|
271 | (setf (first funcs) (reverse (first funcs))) | |
272 | (push (string-upcase form) funcs) |
|
272 | (push (string-upcase form) funcs) | |
273 | (push nil funcs)) |
|
273 | (push nil funcs)) | |
274 | (t |
|
274 | (t | |
275 | (push form (first funcs))))) |
|
275 | (push form (first funcs))))) | |
276 | (setf (first funcs) (reverse (first funcs))) |
|
276 | (setf (first funcs) (reverse (first funcs))) | |
277 | (setf funcs (reverse funcs)) |
|
277 | (setf funcs (reverse funcs)) | |
278 | `(progn |
|
278 | `(progn | |
279 | ,@create-locals |
|
279 | ,@create-locals | |
280 | ,(if (= 2 (length funcs)) |
|
280 | ,(if (= 2 (length funcs)) | |
281 | `(progn |
|
281 | `(progn | |
282 | ,@body) |
|
282 | ,@body) | |
283 | `(progn |
|
283 | `(progn | |
284 | (tagbody-blocks ,funcs) |
|
284 | (tagbody-blocks ,funcs) | |
285 | (loop |
|
285 | (loop | |
286 | :for _nextblock |
|
286 | :for _nextblock | |
287 | := :_nil |
|
287 | := :_nil | |
288 | :then (await (funcall (getprop _labels _nextblock))) |
|
288 | :then (await (funcall (getprop _labels _nextblock))) | |
289 | :while _nextblock))) |
|
289 | :while _nextblock))) | |
290 | ,@void)))) |
|
290 | ,@void)))) | |
291 |
|
291 | |||
292 | (defvar *current-label*) |
|
292 | (defvar *current-label*) | |
293 | (defvar *has-jump-back*) |
|
293 | (defvar *has-jump-back*) | |
294 | (walker:deftransform optimize-jump jump (target) |
|
294 | (walker:deftransform optimize-jump jump (target) | |
295 | (cond ((string= (string-upcase (second target)) *current-label*) |
|
295 | (cond ((string= (string-upcase (second target)) *current-label*) | |
296 | (setf *has-jump-back* t) |
|
296 | (setf *has-jump-back* t) | |
297 | '(continue)) |
|
297 | '(continue)) | |
298 | (t |
|
298 | (t | |
299 | (walker:walk-continue)))) |
|
299 | (walker:walk-continue)))) | |
300 |
|
300 | |||
301 | (defpsmacro tagbody-blocks (funcs) |
|
301 | (defpsmacro tagbody-blocks (funcs) | |
302 | `(setf ,@(loop :for (label code . rest-labels) :on funcs :by #'cddr |
|
302 | `(setf ,@(loop :for (label code . rest-labels) :on funcs :by #'cddr | |
303 | :append `((@ _labels ,label) |
|
303 | :append `((@ _labels ,label) | |
304 | (async-lambda () |
|
304 | (async-lambda () | |
305 | (block label-body |
|
305 | (block label-body | |
306 | (tagbody-block-body ,label ,code |
|
306 | (tagbody-block-body ,label ,code | |
307 | ,(first rest-labels)))))))) |
|
307 | ,(first rest-labels)))))))) | |
308 |
|
308 | |||
309 | (defpsmacro tagbody-block-body (label code next-label) |
|
309 | (defpsmacro tagbody-block-body (label code next-label) | |
310 | (let ((*current-label* label) |
|
310 | (let ((*current-label* label) | |
311 | (*has-jump-back* nil)) |
|
311 | (*has-jump-back* nil)) | |
312 | (let ((code (walker:walk 'optimize-jump code))) |
|
312 | (let ((code (walker:walk 'optimize-jump code))) | |
313 | (if *has-jump-back* |
|
313 | (if *has-jump-back* | |
314 | `(progn |
|
314 | `(progn | |
315 | (loop :do (progn |
|
315 | (loop :do (progn | |
316 | ,@code |
|
316 | ,@code | |
317 | (break))) |
|
317 | (break))) | |
318 | ,@(if next-label |
|
318 | ,@(if next-label | |
319 | (list next-label) |
|
319 | (list next-label) | |
320 | nil)) |
|
320 | nil)) | |
321 | `(progn |
|
321 | `(progn | |
322 | ,@code |
|
322 | ,@code | |
323 | ,@(if next-label |
|
323 | ,@(if next-label | |
324 | (list next-label) |
|
324 | (list next-label) | |
325 | nil)))))) |
|
325 | nil)))))) | |
326 |
|
326 | |||
327 | (defpsmacro exit () |
|
327 | (defpsmacro exit () | |
328 | '(return-from nil (values))) |
|
328 | '(return-from nil (values))) | |
329 |
|
329 | |||
330 | ;;; 10dynamic |
|
330 | ;;; 10dynamic | |
331 |
|
331 | |||
332 | (defpsmacro qspblock (&body body) |
|
332 | (defpsmacro qspblock (&body body) | |
333 | `(locals-block |
|
333 | `(locals-block | |
334 | ,@body)) |
|
334 | ,@body)) | |
335 |
|
335 | |||
336 | (defpsmacro qsp-lambda (&body body) |
|
336 | (defpsmacro qsp-lambda (&body body) | |
337 | `(async-lambda (args) |
|
337 | `(async-lambda (args) | |
338 | (label-block () |
|
338 | (label-block () | |
339 | ,@body))) |
|
339 | ,@body))) | |
340 |
|
340 | |||
341 | ;;; 11main |
|
341 | ;;; 11main | |
342 |
|
342 | |||
343 | (defpsmacro act (name img &body body) |
|
343 | (defpsmacro act (name img &body body) | |
344 | `(api-call add-act ,name ,img |
|
344 | `(api-call add-act ,name ,img | |
345 | (locals-block |
|
345 | (locals-block | |
346 | ,@body))) |
|
346 | ,@body))) | |
347 |
|
347 | |||
348 | ;;; 12aux |
|
348 | ;;; 12aux | |
349 |
|
349 | |||
350 | ;;; 13diag |
|
350 | ;;; 13diag | |
351 |
|
351 | |||
352 | ;;; 14act |
|
352 | ;;; 14act | |
353 |
|
353 | |||
354 | ;;; 15objs |
|
354 | ;;; 15objs | |
355 |
|
355 | |||
356 | ;;; 16menu |
|
356 | ;;; 16menu | |
357 |
|
357 | |||
358 | ;;; 17sound |
|
358 | ;;; 17sound | |
359 |
|
359 | |||
360 | ;;; 18img |
|
360 | ;;; 18img | |
361 |
|
361 | |||
362 | ;;; 19input |
|
362 | ;;; 19input | |
363 |
|
363 | |||
364 | ;;; 20time |
|
364 | ;;; 20time | |
365 |
|
365 | |||
366 | ;;; 21local |
|
366 | ;;; 21local | |
367 |
|
367 | |||
368 | ;;; 22for |
|
368 | ;;; 22for | |
369 |
|
369 | |||
370 | ;; Transform because it creates a (set ...) hence it has to be processed |
|
370 | ;; Transform because it creates a (set ...) hence it has to be processed | |
371 | ;; before the apply-vars transform. And macros are processed after all |
|
371 | ;; before the apply-vars transform. And macros are processed after all | |
372 | ;; the transforms |
|
372 | ;; the transforms | |
373 | (walker:deftransform for-transform qspfor (var from to step &rest body) |
|
373 | (walker:deftransform for-transform qspfor (var from to step &rest body) | |
374 | `(loop :for i :from ,from :to ,to :by ,step |
|
374 | `(loop :for i :from ,from :to ,to :by ,step | |
375 | :do (set ,var i) |
|
375 | :do (set ,var i) | |
376 | :do (block nil |
|
376 | :do (block nil | |
377 | ,@(walker:walk-continue body)))) |
|
377 | ,@(walker:walk-continue body)))) |
@@ -1,9 +1,9 b'' | |||||
1 |
|
1 | |||
2 |
(in-package |
|
2 | (in-package txt2web) | |
3 |
|
3 | |||
4 | ;;; 1. Generates parenscript source to write to js |
|
4 | ;;; 1. Generates parenscript source to write to js | |
5 | ;;; 2. Collects everything into complete file, leaving a neatly marked |
|
5 | ;;; 2. Collects everything into complete file, leaving a neatly marked | |
6 | ;;; place to customize page layout and styles. |
|
6 | ;;; place to customize page layout and styles. | |
7 |
|
7 | |||
8 | (defun make-javascript (locations) |
|
8 | (defun make-javascript (locations) | |
9 | (mapcar #'ps:ps* locations)) |
|
9 | (mapcar #'ps:ps* locations)) |
1 | NO CONTENT: file was removed |
|
NO CONTENT: file was removed |
1 | NO CONTENT: file was removed |
|
NO CONTENT: file was removed |
General Comments 0
You need to be logged in to leave comments.
Login now