Localization. Renamed to txt2web

qsp-txt2web.asd

@@ -0,0 +1,24 b''
+
+(defsystem qsp-txt2web
+  :description "QSP compiler to monolithic HTML page"
+  :depends-on (:alexandria :system-locale ;; General
+               :esrap ;; Parsing
+               :parenscript :flute ;; Codegening
+               )
+  :pathname "src/"
+  :serial t
+  :components ((:file "package")
+               (:file "utils")
+               (:file "l10n")
+               (:file "walker")
+
+               (:file "patches")
+               (:file "js-syms")
+               (:file "main-macros")
+               (:file "ps-macros")
+               (:file "api-macros")
+               (:file "intrinsic-macros")
+
+               (:file "class")
+               (:file "main")
+               (:file "parser")))

src/l10n.lisp

@@ -0,0 +1,19 b''
+
+(in-package txt2web)
+
+(defparameter *languages* (list "en" "ru"))
+
+(defparameter *l10n-strings*
+  (mapcan (lambda (lang)
+            (cons (intern (string-upcase lang) :keyword)
+                  (read-code-from-string
+                   (load-src
+                    (concatenate 'string "strings/" lang ".sexp")))))
+          *languages*))
+
+(defun lformat (target key &rest args)
+  (let* ((lang (intern (string-upcase (first (system-locale:languages)))
+                      :keyword))
+         (strings (or (getf *l10n-strings* lang)
+                      (getf *l10n-strings* :en))))
+    (apply #'format target (getf strings key) args)))

src/utils.lisp

@@ -0,0 +1,24 b''
+
+(in-package txt2web)
+
+(defun src-file (filename)
+  (uiop/pathname:merge-pathnames*
+   filename
+   (asdf:system-source-directory :txt2web)))
+
+(defun read-progn-from-string (string)
+  `(progn
+     ,@(read-code-from-string string)))
+
+(defun read-code-from-string (string)
+  (with-input-from-string (in string)
+    (let ((*package* *package*))
+      (loop :for form := (read in nil :eof)
+         :until (eq form :eof)
+         :when (eq (first form) 'cl:in-package)
+         :do (setf *package* (find-package (second form)))
+         :else
+         :collect form))))
+
+(defun load-src (filename)
+  (alexandria:read-file-into-string (src-file filename)))

strings/en.sexp

@@ -0,0 +1,12 b''
+(:usage "Usage: ~A <source> [options]
+Options:
+  -o <filename>         - Output filename
+  --js <filenames...>   - List of extra .js files to include in the game
+  --css <filenames...>  - List of .css files to include in the game. Default is in extras/default.css
+  --body <filename>     - Alternative page body. Default is in extras/body.html
+
+  -c                    - Just compile the game to a .js file without making it a full web page
+  --beautify            - Make the JS content pretty. By default it gets minified.
+
+Note that the files in extras/ are not actually used. They're just there for the reference~%")
+

strings/ru.sexp

@@ -0,0 +1,12 b''
+(:usage "Использование: ~A <source> [options]
+Опции:
+  -o <имя файла>          - Имя .html файла для записи скомпилированной игры
+  --js <имена файлов...>  - Список дополнительных .js файлов
+  --css <имена файлов...> - Список .css файлов. Стиль по-умолчанию - в файле extras/default.css
+  --body <имя файла>      - Альтернативное тело страницы. Тело по-умолчанию - в файле extras/body.html
+
+  -c                      - Просто скомпилировать игру в .js файл, не компонуя полную .html страницу
+  --beautify              - Не минифицировать .js скрипты
+
+Файлы в extras на самом деле компилятором не используются. Используйте только как образец.~%")
+

Makefile

@@ -1,39 +1,46 b''
 
-BIN = sugar-qsp
+BIN = txt2web
+PKG = $(BIN)
+DIST = txt2web.tar.xz
 
 LISP = sbcl
 
 all: $(BIN)
 
+dist: $(DIST)
+
 graphs: diagrams.png
 
-$(BIN): src/*.lisp src/*.ps
+$(BIN): *.asd src/*.lisp src/*.ps strings/*.sexp
 	buildapp.$(LISP) --asdf-path .\
 		--asdf-tree .qlot/dists\
-		--load-system sugar-qsp\
-		--entry sugar-qsp:entry-point\
-		--compress-core\
+		--load-system $(PKG)\
+		--entry $(PKG):entry-point\
 		--output $(BIN)
 
 install-deps:
 	sbcl --load install-deps.lisp
 
 update-deps:
 	sbcl --load update-deps.lisp
 
 %.png: %.dot
 	dot $< -T png -o $@
 
-dist: $(BIN)
-	tar cfvJ sugar-qsp.tar.xz $(BIN) extras
+$(DIST): $(BIN) extras/*
+	tar cfvJ $@ $< extras
+
+upload: $(DIST)
+	curl --upload-file $(DIST) https://transfer.sh/$(DIST)
+	@echo
 
 distclean: clean clean-deps
 
 clean:
-	-rm sugar-qsp
+	rm -f $(BIN) $(DIST)
 
 clean-deps:
-	-rm qlfile.lock
-	-rm -rf .qlot
+	rm qlfile.lock
+	rm -rf .qlot
 
-.PHONY: all graphs install-deps update-deps clean
+.PHONY: all graphs install-deps update-deps clean upload

README.md

@@ -1,44 +1,44 b''
 (инструкции на Русском - внизу)
 
-# sugar-qsp
+# txt2web
 Compiler for QSP games which creates monolithic HTML pages.
 
 ## Usage
 
 There are three mastery levels
 
 1. Just build me the game:<br/>
-`sugar-qsp game.txt`<br/>
+`txt2web game.txt`<br/>
 And it will create the game in game.html
 
 2. I know what I'm doing:<br/>
-`sugar-qsp game.txt -o game.html --body body.html --js jquery.js my-js-library.js --css styles/*.css`<br/>
+`txt2web game.txt -o game.html --body body.html --js jquery.js my-js-library.js --css styles/*.css`<br/>
 All options are self-explanatory. The result is a monolithic html specified
 with the `-o` option. Default `body.html` (used by the first mastery level) can
 be found in `extas` directory.
 
 3. I'm a frontend developer!<br/>
-`sugar-qsp game.txt -c -o game.js`<br/>
+`txt2web game.txt -c -o game.js`<br/>
 It just builds the game script into a js you can put on your website. To run
 the game execute `SugarQSP.start()`
 
-# sugar-qsp
+# txt2web
 Компилятор для игр на QSP создающий монолитные страницы на HTML.
 
 ## Инструкции
 
 Есть три уровня мастерства.
 
 1. **Просто собери мне игру**:<br/>
-`sugar-qsp game.txt`<br/>
+`txt2web game.txt`<br/>
 Создаст игру в game.html
 
 2. **Я знаю что делаю**:<br/>
-`sugar-qsp game.txt -o game.html --body body.html --js jquery.js my-js-library.js --css styles/*.css`<br/>
+`txt2web game.txt -o game.html --body body.html --js jquery.js my-js-library.js --css styles/*.css`<br/>
 Если вы знаете что делаете, то для вас смысл опций очевиден. `body.html` и `default.css`
 лежат в каталоге `extras`.
 
 3. **Я - фронтендер!**<br/>
-`sugar-qsp game.txt -c -o game.js`<br/>
+`txt2web game.txt -c -o game.js`<br/>
 Просто соберёт игру в Javascript файл который вы можете разместить на своём
 сайте как вам угодно.

TODO

@@ -1,15 +1,17 b''
 
+* Localization
 * Save-load game in slots
 
 * CLI build for Windows
 
 * Reporting error lines in the parser
 * Report duplicate label (in the parser)
 * reporting error lines at runtime (by storing them in every form in the parser
 * Report JUMP with missing label (in tagbody)
+* Localizing parser errors...
 
 * Build Istreblenie
 * Build Цветохимия
 
 * Windows GUI (for the compiler)
 * Resizable frames

qlfile

@@ -1,10 +1,13 b''
 ql alexandria
+ql system-locale
 ql esrap
 ql parenscript
 ql flute
 
 ql cl-ppcre
 ql anaphora
 ql named-readtables
 ql assoc-utils
 ql let-over-lambda
+ql documentation-utils
+ql trivial-indent

qlfile.lock

@@ -1,40 +1,52 b''
 ("quicklisp" .
  (:class qlot/source/dist:source-dist
   :initargs (:distribution "http://beta.quicklisp.org/dist/quicklisp.txt" :%version :latest)
   :version "2020-04-27"))
 ("alexandria" .
  (:class qlot/source/ql:source-ql
   :initargs (:%version :latest)
   :version "ql-2020-04-27"))
+("system-locale" .
+ (:class qlot/source/ql:source-ql
+  :initargs (:%version :latest)
+  :version "ql-2020-04-27"))
 ("esrap" .
  (:class qlot/source/ql:source-ql
   :initargs (:%version :latest)
   :version "ql-2020-04-27"))
 ("parenscript" .
  (:class qlot/source/ql:source-ql
   :initargs (:%version :latest)
   :version "ql-2020-04-27"))
 ("flute" .
  (:class qlot/source/ql:source-ql
   :initargs (:%version :latest)
   :version "ql-2020-04-27"))
 ("cl-ppcre" .
  (:class qlot/source/ql:source-ql
   :initargs (:%version :latest)
   :version "ql-2020-04-27"))
 ("anaphora" .
  (:class qlot/source/ql:source-ql
   :initargs (:%version :latest)
   :version "ql-2020-04-27"))
 ("named-readtables" .
  (:class qlot/source/ql:source-ql
   :initargs (:%version :latest)
   :version "ql-2020-04-27"))
 ("assoc-utils" .
  (:class qlot/source/ql:source-ql
   :initargs (:%version :latest)
   :version "ql-2020-04-27"))
 ("let-over-lambda" .
  (:class qlot/source/ql:source-ql
   :initargs (:%version :latest)
   :version "ql-2020-04-27"))
+("documentation-utils" .
+ (:class qlot/source/ql:source-ql
+  :initargs (:%version :latest)
+  :version "ql-2020-04-27"))
+("trivial-indent" .
+ (:class qlot/source/ql:source-ql
+  :initargs (:%version :latest)
+  :version "ql-2020-04-27"))

src/class.lisp

@@ -1,32 +1,14 b''
 
 (in-package sugar-qsp)
 
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (defun src-file (filename)
-    (uiop/pathname:merge-pathnames*
-     filename
-     (asdf:system-source-directory :sugar-qsp)))
-  (defun read-code-from-string (string)
-    (with-input-from-string (in string)
-      (let ((*package* *package*))
-        `(progn
-           ,@(loop :for form := (read in nil :eof)
-                :until (eq form :eof)
-                :when (eq (first form) 'cl:in-package)
-                :do (setf *package* (find-package (second form)))
-                :else
-                :collect form)))))
-  (defun load-src (filename)
-    (alexandria:read-file-into-string (src-file filename))))
-
 (defclass compiler ()
   ((body :accessor body :initform #.(load-src "extras/body.html"))
    (css  :accessor css  :initform (list #.(load-src "extras/default.css")))
    (js   :accessor js   :initform (reverse
                                    (list
-                                    '#.(read-code-from-string (load-src "src/main.ps"))
-                                    '#.(read-code-from-string (load-src "src/api.ps"))
-                                    '#.(read-code-from-string (load-src "src/intrinsics.ps")))))
+                                    '#.(read-progn-from-string (load-src "src/main.ps"))
+                                    '#.(read-progn-from-string (load-src "src/api.ps"))
+                                    '#.(read-progn-from-string (load-src "src/intrinsics.ps")))))
    (compile :accessor compile-only :initarg :compile)
    (target  :accessor target :initarg :target)
    (beautify :accessor beautify :initarg :beautify)))

src/main-macros.lisp

@@ -1,8 +1,8 b''
 
-(in-package sugar-qsp.main)
+(in-package txt2web.main)
 
 (defmacro+ps api-call (name &rest args)
-  `(,(intern (string-upcase name) "SUGAR-QSP.API") ,@args))
+  `(,(intern (string-upcase name) "TXT2WEB.API") ,@args))
 
 (defpsmacro has (key obj)
   `(chain ,obj (has-own-property ,key)))

src/main.lisp

@@ -1,163 +1,153 b''
 
-(in-package sugar-qsp)
+(in-package txt2web)
 
 (defvar *app-name* "")
 
 (defun entry-point-no-args ()
   (entry-point uiop:*command-line-arguments*))
 
 (defun entry-point (args)
   (setf *app-name* (first args))
-  (let ((*package* (find-package :sugar-qsp)))
+  (let ((*package* (find-package :txt2web)))
     (catch :terminate
       (let ((compiler (apply #'make-instance 'compiler (parse-opts (rest args)))))
         (write-compiled-file compiler))))
   (values))
 
 (defun parse-opts (args)
   (let ((mode :sources)
         (data (list :sources nil :target nil :js nil :css nil :body nil :compile nil :beautify nil)))
     (loop :for arg :in args
        :do (alexandria:switch (arg :test #'string=)
              ("-o" (setf mode :target))
              ("--js" (setf mode :js))
              ("--css" (setf mode :css))
              ("--body" (setf mode :body))
              ("-c" (setf (getf data :compile) t))
              ("--beautify" (setf (getf data :beautify) t))
              (t (push arg (getf data mode)))))
     (unless (< 0 (length (getf data :sources)))
       (report-error "There should be at least one source"))
     (unless (> 1 (length (getf data :target)))
       (report-error "There should be no more than one target"))
     (unless (> 1 (length (getf data :body)))
       (report-error "There should be no more than one body"))
     (unless (getf data :target)
       (setf (getf data :target)
             (let* ((sources (first (getf data :sources)))
                    (tokens (uiop:split-string sources :separator "."))
                    (target (format nil "~{~A~^.~}.html"
                                    (butlast tokens))))
               (list target))))
     (list :sources (getf data :sources)
           :target (first (getf data :target))
           :js (getf data :js)
           :css (getf data :css)
           :body (first (getf data :body))
           :compile (getf data :compile)
           :beautify (getf data :beautify))))
 
 (defun print-usage ()
-  (format t "Usage: ~A <source> [options]~%" *app-name*)
-  (format t "Options:~%")
-  (format t "  -o <filename>         - Output filename~%")
-  (format t "  --js <filenames...>   - List of extra .js files to include in the game~%")
-  (format t "  --css <filenames...>  - List of .css files to include in the game. Default is in extras/default.css~%")
-  (format t "  --body <filename>     - Alternative page body. Default is in extras/body.html~%")
-  (format t "~%")
-  (format t "  -c                    - Just compile the game to a .js file without making it a full web page~%")
-  (format t "  --beautify            - Make the JS content pretty. By default it gets minified.~%")
-  (format t "~%")
-  (format t "Note that the files in extras/ are not actually used. They're just there for the reference"))
+  (lformat t :usage *app-name*))
 
 (defun parse-file (filename)
-  (p:parse 'sugar-qsp-grammar
+  (p:parse 'txt2web-grammar
            (alexandria:read-file-into-string filename)))
 
 (defun report-error (fmt &rest args)
   (format t "ERROR: ~A~%" (apply #'format nil fmt args))
   (print-usage)
   (throw :terminate nil))
 
 ;;; JS
 
 (defun minify-package (package-designator minify prefix)
   (setf (ps:ps-package-prefix package-designator) prefix)
   (if minify
       (ps:obfuscate-package package-designator)
       (ps:unobfuscate-package package-designator)))
 
 (defmethod js-sources ((compiler compiler))
   (let ((ps:*ps-print-pretty* (beautify compiler)))
     (cond ((beautify compiler)
-           (minify-package "SUGAR-QSP.MAIN" nil "qsp_")
-           (minify-package "SUGAR-QSP.API"  nil "qsp_api_")
-           (minify-package "SUGAR-QSP.LIB"  nil "qsp_lib_"))
+           (minify-package "TXT2WEB.MAIN" nil "qsp_")
+           (minify-package "TXT2WEB.API"  nil "qsp_api_")
+           (minify-package "TXT2WEB.LIB"  nil "qsp_lib_"))
           (t
-           (minify-package "SUGAR-QSP.MAIN" t   "_")
-           (minify-package "SUGAR-QSP.API"  t   "a_")
-           (minify-package "SUGAR-QSP.LIB"  t   "l_")))
+           (minify-package "TXT2WEB.MAIN" t   "_")
+           (minify-package "TXT2WEB.API"  t   "a_")
+           (minify-package "TXT2WEB.LIB"  t   "l_")))
     (format nil "~{~A~^~%~%~}" (mapcar #'ps:ps* (reverse (js compiler))))))
 
 ;;; CSS
 
 (defmethod css-sources ((compiler compiler))
   (format nil "~{~A~^~%~%~}" (css compiler)))
 
 ;;; HTML
 
 (defmethod html-sources ((compiler compiler))
   (let ((flute:*escape-html* nil)
         (body-template (body compiler))
         (js (js-sources compiler))
         (css (css-sources compiler)))
     (with-output-to-string (out)
       (write
        (flute:h
          (html
           (head
            (title "SugarQSP"))
           (body
            body-template
            (style css)
            (script js))))
        :stream out
        :pretty nil))))
 
 (defun filename-game (filename)
   (let ((filename (alexandria:lastcar (uiop:split-string filename :separator "/"))))
     (format nil "~{~A~^.~}" (butlast (uiop:split-string filename :separator ".")))))
 
 (defmethod initialize-instance ((compiler compiler) &key sources ((:js js-files)) ((:css css-files)) ((:body body-file)) compile &allow-other-keys)
   (call-next-method)
   (with-slots (body css js)
       compiler
     ;; Compile the game's JS
     (dolist (source sources)
       (let ((ps (parse-file source))
             (game-name (filename-game source)))
         (destructuring-bind (kw &rest locations)
             ps
           (unless (eq kw 'lib:game)
             (report-error "Internal error!"))
           (push 
            `(lib:game (,game-name) ,@locations)
            js))))
     ;; Does the user need us to do anything else
     (unless compile
       ;; Read in body
       (when body-file
         (setf body
               (alexandria:read-file-into-string body-file)))
       ;; Include js files
       (dolist (js-file js-files)
         (push (format nil "////// Included file ~A~%~A" js-file
                       (alexandria:read-file-into-string js-file))
               js))
       ;; Include css files
       (when css-files
         ;; User option overrides the default css
         (setf css nil)
         (dolist (css-file css-files)
           (push (format nil "////// Included file ~A~%~A" css-file
                         (alexandria:read-file-into-string css-file))
                 css))))))
 
 (defmethod write-compiled-file ((compiler compiler))
   (alexandria:write-string-into-file
    (if (compile-only compiler)
        ;; Just the JS
        (js-sources compiler)
        ;; All of it
        (html-sources compiler))
    (target compiler) :if-exists :supersede))

src/main.ps

@@ -1,54 +1,54 b''
 
-(in-package sugar-qsp.main)
+(in-package txt2web.main)
 
 ;;; Game session state (saved in savegames)
 ;; Variables
 (var *globals (create))
 ;; Inventory (objects)
 (var *objs (create))
 (var *current-location nil)
 ;; Game time
 (var *started-at (chain *date (now)))
 ;; Timers
 (var *timer-interval 500)
 (var *timer-obj nil)
 ;; Games
 (var *loaded-games (list))
 
 ;;; Transient state
 ;; ACTions
 (var *acts (create))
 ;; Savegame data
 (var *state-stash (create))
 ;; List of audio files being played
 (var *playing (create))
 ;; Local variables stack (starts with an empty frame)
 (var *locals (list))
 ;; Promise to continue running the game after menu
 (var *menu-resume nil)
 
 ;;; Game data
 ;; Games (filename -> [locations])
 (var *games (list))
 ;; The main (non library) game. Updated by openqst
 (var *main-game nil)
 ;; Active locations
 (var *locs (create))
 
 (setf (@ window onload)
       (lambda ()
-        (#.(intern "INIT-DOM" "SUGAR-QSP.API"))
+        (#.(intern "INIT-DOM" "TXT2WEB.API"))
         ;; For MSECCOUNT
         (setf *started-at (chain *date (now)))
         ;; For $COUNTER and SETTIMER
-        (#.(intern "SET-TIMER" "SUGAR-QSP.API")
+        (#.(intern "SET-TIMER" "TXT2WEB.API")
            *timer-interval)
         ;; Start the first game
-        (#.(intern "RUN-GAME" "SUGAR-QSP.API")
+        (#.(intern "RUN-GAME" "TXT2WEB.API")
            (chain *object (keys *games) 0))
         (values)))
 
 ;;; Some very common utilities (for both api and lib)
 
 (defun by-id (id)
   (chain document (get-element-by-id id)))

src/package.lisp

@@ -1,108 +1,108 b''
 
 (in-package cl-user)
 
-(defpackage :sugar-qsp.js)
+(defpackage :txt2web.js)
 
-(defpackage :sugar-qsp.main
-  (:use :cl :ps :sugar-qsp.js)
+(defpackage :txt2web.main
+  (:use :cl :ps :txt2web.js)
   (:export #:api-call #:by-id
            #:has
 
            #:*globals #:*objs #:*current-location
            #:*started-at #:*timer-interval #:*timer-obj #:*loaded-games
 
            #:*acts #:*state-stash #:*playing #:*locals
 
            #:*games #:*main-game #:*locs #:*menu-resume
            ))
 
 (defpackage :code-walker
   (:use :cl)
   (:export #:deftransform
            #:deftransform-stop
            #:walk
            #:whole
            #:walk-continue))
 
 ;;; API functions
-(defpackage :sugar-qsp.api
-  (:use :cl :ps :sugar-qsp.main :sugar-qsp.js)
+(defpackage :txt2web.api
+  (:use :cl :ps :txt2web.main :txt2web.js)
   (:export #:with-frame #:with-call-args
            #:stash-state
 
            #:report-error #:sleep #:init-dom #:call-serv-loc #:*serv-vars*
            #:newline #:clear-id #:prepare-contents #:get-id #:set-id #:append-id
            #:init-args #:get-result #:call-loc #:call-act
            #:get-frame #:add-text #:get-text #:clear-text #:enable-frame
            #:add-act #:del-act #:clear-act #:update-acts
            #:set-str-element #:set-any-element #:set-serv-var
            #:*var #:new-value #:index-num #:get #:set #:kill
            #:var-real-name #:ensure-var #:var-ref #:get-var #:set-var
            #:get-array #:set-array #:kill-var #:array-size
            #:push-local-frame #:pop-local-frame #:current-local-frame #:new-local
            #:update-objs
            #:menu
            #:clean-audio
            #:show-image
            #:opengame #:savegame
            ))
 
 ;;; QSP library functions and macros
-(defpackage :sugar-qsp.lib
-  (:use :cl :ps :sugar-qsp.main :sugar-qsp.js)
-  (:local-nicknames (#:api :sugar-qsp.api)
+(defpackage :txt2web.lib
+  (:use :cl :ps :txt2web.main :txt2web.js)
+  (:local-nicknames (#:api :txt2web.api)
                     (#:walker :code-walker))
   (:export #:str #:exec #:qspblock #:qspfor #:game #:location
            #:qspcond #:qspvar #:set #:local #:jump
 
            #:killvar #:killall
            #:obj #:loc #:no
            #:qspver #:curloc
            #:rnd #:qspmax #:qspmin
            #:arrsize #:len
            #:mid #:ucase #:lcase #:trim #:replace #:val #:qspstr
            #:exit #:desc
            #:showstat #:msg
            #:showacts #:delact #:cla
            #:showobjs #:countobj #:getobj
            #:isplay
            #:view
            #:showinput
            #:wait #:settimer
            #:local
            #:opengame #:savegame
 
            #:goto #:xgoto
            #:rand
            #:copyarr #:arrpos #:arrcomp
            #:instr #:isnum #:strcomp #:strfind #:strpos
            #:iif
            #:gosub #:func
            #:dynamic #:dyneval
            #:main-p #:main-pl #:main-nl #:maintxt #:desc #:main-clear
            #:stat-p #:stat-pl #:stat-nl #:stattxt #:stat-clear #:cls
            #:curacts
            #:addobj #:delobj #:killobj
            #:menu
            #:play #:close #:closeall
            #:refint
            #:usertxt #:cmdclear #:input
            #:msecscount
            #:rgb
            #:openqst #:addqst #:killqst
            ))
 
-(setf (ps:ps-package-prefix "SUGAR-QSP.MAIN") "qsp_")
-(setf (ps:ps-package-prefix "SUGAR-QSP.API") "qsp_api_")
-(setf (ps:ps-package-prefix "SUGAR-QSP.LIB") "qsp_lib_")
+(setf (ps:ps-package-prefix "TXT2WEB.MAIN") "qsp_")
+(setf (ps:ps-package-prefix "TXT2WEB.API") "qsp_api_")
+(setf (ps:ps-package-prefix "TXT2WEB.LIB") "qsp_lib_")
 
 ;;; The compiler
-(defpackage :sugar-qsp
+(defpackage :txt2web
   (:use :cl)
   (:local-nicknames (#:p #:esrap)
-                    (#:lib :sugar-qsp.lib)
-                    (#:api :sugar-qsp.api)
-                    (#:main :sugar-qsp.main)
+                    (#:lib :txt2web.lib)
+                    (#:api :txt2web.api)
+                    (#:main :txt2web.main)
                     (#:walker :code-walker))
   (:export #:parse-file #:entry-point))
 

src/parser.lisp

@@ -1,624 +1,624 b''
 
-(in-package sugar-qsp)
+(in-package txt2web)
 
 ;;;; Parses TXT source to an intermediate representation
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defparameter *max-args* 10))
 
 ;;; Utility
 
 (defun remove-nth (list nth)
   (append (subseq list 0 nth)
           (subseq list (1+ nth))))
 
 (defun not-quote (char)
   (not (eql #\' char)))
 
 (defun not-doublequote (char)
   (not (eql #\" char)))
 
 (defun not-brace (char)
   (not (eql #\} char)))
 
 (defun not-integer (string)
   (when (find-if-not #'digit-char-p string)
     t))
 
 (defun not-newline (char)
   (not (eql #\newline char)))
 
 (defun id-any-char (char)
   (and
    (not (digit-char-p char))
    (not (eql #\newline char))
    (not (find char " 	!:&=<>+-*/,'\"()[]{}"))))
 
 (defun intern-first (list)
-  (list* (intern (string-upcase (first list)) "SUGAR-QSP.LIB")
+  (list* (intern (string-upcase (first list)) "TXT2WEB.LIB")
          (rest list)))
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defun remove-nil (list)
     (remove nil list)))
 
 (defun binop-rest (list)
   (destructuring-bind (ws1 operator ws2 operand2)
       list
     (declare (ignore ws1 ws2))
-    (list (intern (string-upcase operator) "SUGAR-QSP.LIB") operand2)))
+    (list (intern (string-upcase operator) "TXT2WEB.LIB") operand2)))
 
 (defun do-binop% (left-op other-ops)
   (if (null other-ops)
       left-op
       (destructuring-bind ((operator right-op) &rest rest-ops)
           other-ops
         (if (and (listp left-op)
                  (eq (first left-op)
                      operator))
             (do-binop% (append left-op (list right-op)) rest-ops)
             (do-binop% (list operator left-op right-op) rest-ops)))))
 
 (defun do-binop (list)
   (destructuring-bind (left-op rest-ops)
       list
     (do-binop% left-op
       (mapcar #'binop-rest rest-ops))))
 
 (p:defrule line-continuation (and #\_ #\newline)
   (:constant nil))
 
 (p:defrule text-spaces (+ (or #\space #\tab line-continuation))
   (:text t))
 
 (p:defrule spaces (+ (or #\space #\tab line-continuation))
   (:constant nil)
   (:error-report nil))
 
 (p:defrule spaces? (* (or #\space #\tab line-continuation))
   (:constant nil)
   (:error-report nil))
 
 (p:defrule colon #\:
   (:constant nil))
 
 (p:defrule equal #\=
   (:constant nil))
 
 (p:defrule alphanumeric (alphanumericp character))
 
 (p:defrule not-newline (not-newline character))
 
 (p:defrule squote-esc "''"
   (:lambda (list)
     (p:text (elt list 0))))
 
 (p:defrule dquote-esc "\"\""
   (:lambda (list)
     (p:text (elt list 0))))
 
 (p:defrule sstring-chars (+ (and (and (p:! "<<") (p:! (p:~ "\"exec:")))
                                  (or squote-esc (not-quote character))))
   (:lambda (list)
     (p:text (mapcar #'second list))))
 
 (p:defrule dstring-chars (+ (and (and (p:! "<<") (p:! (p:~ "'exec:")))
                                  (or dquote-esc (not-doublequote character))))
   (:lambda (list)
     (p:text (mapcar #'second list))))
 
 ;;; Identifiers
 
 (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))
 
 (defun trim-$ (str)
   (if (char= #\$ (elt str 0))
       (subseq str 1)
       str))
 
 (defun qsp-keyword-p (id)
   (member (intern (trim-$ (string-upcase id))) *keywords*))
 
 (defun not-qsp-keyword-p (id)
   (not (member (intern (trim-$ (string-upcase id))) *keywords*)))
 
 (p:defrule qsp-keyword (qsp-keyword-p identifier-raw))
 
 (p:defrule id-first (id-any-char character))
 (p:defrule id-next (or (id-any-char character)
                        (digit-char-p character)))
 (p:defrule identifier-raw (and id-first (* id-next))
   (:lambda (list)
-    (intern (string-upcase (p:text list)) "SUGAR-QSP.LIB")))
+    (intern (string-upcase (p:text list)) "TXT2WEB.LIB")))
 
 (p:defrule identifier (not-qsp-keyword-p identifier-raw))
 
 ;;; Strings
 
 (p:defrule qsp-string (or normal-string brace-string))
 
 (p:defrule normal-string (or sstring dstring)
   (:lambda (str)
     (list* 'lib:str (or str (list "")))))
 
 (p:defrule sstring (and #\' (* (or string-interpol
                                    sstring-exec
                                    sstring-chars))
                         #\')
   (:function second))
 
 (p:defrule dstring (and #\" (* (or string-interpol
                                    dstring-exec
                                    dstring-chars))
                         #\")
   (:function second))
 
 (p:defrule string-interpol (and "<<" expression ">>")
   (:function second))
 
 (p:defrule sstring-exec-body (+ (or squote-esc (not-doublequote character)))
   (:text t))
 
 (p:defrule dstring-exec-body (+ (or dquote-esc (not-quote character)))
   (:text t))
 
 (p:defrule sstring-exec (and (p:~ "\"exec:") sstring-exec-body #\")
   (:lambda (list)
     (list* 'lib:exec (p:parse 'exec-body (second list)))))
 
 (p:defrule dstring-exec (and (p:~ "'exec:") dstring-exec-body #\')
   (:lambda (list)
     (list* 'lib:exec (p:parse 'exec-body (second list)))))
 
 (p:defrule brace-string (and #\{ before-statement block-body #\})
   (:lambda (list)
     (list* 'lib:qspblock (third list))))
 
 ;;; Location
 
-(p:defrule sugar-qsp-grammar (and (* (or spaces #\newline))
+(p:defrule txt2web-grammar (and (* (or spaces #\newline))
                                   (* location))
   (:lambda (list)
     `(lib:game ,@(second list))))
 
 (p:defrule location (and location-header block-body location-end)
   (:destructure (header body end)
     (declare (ignore end))
     `(lib:location (,header) ,@body)))
 
 (p:defrule location-header (and #\#
                                 (+ not-newline)
                                 (and #\newline spaces? before-statement))
   (:destructure (spaces1 name spaces2)
     (declare (ignore spaces1 spaces2))
     (string-upcase (string-trim " " (p:text name)))))
 
 (p:defrule location-end (and #\- (* not-newline) #\newline before-statement)
   (:constant nil))
 
 ;;; Block body
 
 (p:defrule newline-block-body (and #\newline spaces? block-body)
   (:function third))
 
 (p:defrule block-body (* statement)
   (:function remove-nil))
 
 ;; Just for <a href="exec:...'>
 ;; Explicitly called from that rule's production
 (p:defrule exec-body (and before-statement line-body)
   (:function second))
 
 (p:defrule line-body (and inline-statement (* next-inline-statement))
   (:lambda (list)
     (list* (first list) (second list))))
 
 (p:defrule before-statement (* (or #\newline spaces))
   (:constant nil))
 
 (p:defrule statement-end (or statement-end-real statement-end-block-close))
 
 (p:defrule statement-end-real (and (or #\newline
                                        (and #\& spaces? (p:& statement%)))
                                    before-statement)
   (:constant nil))
 
 (p:defrule statement-end-block-close (or (p:& #\}))
   (:constant nil))
 
 (p:defrule inline-statement (and statement% spaces?)
   (:function first))
 
 (p:defrule next-inline-statement (and #\& spaces? inline-statement)
   (:function third))
 
 (p:defrule not-a-non-statement (and (p:! (p:~ "elseif"))
                                     (p:! (p:~ "else"))
                                     (p:! (p:~ "end"))))
 
 (p:defrule statement (and inline-statement statement-end)
   (:function first))
 
 (p:defrule statement% (and not-a-non-statement
                            (or label comment string-output
                                block non-returning-intrinsic local
                                assignment expression-output))
   (:function second))
 
 (p:defrule expr-stopper (or comment block non-returning-intrinsic))
 
 (p:defrule string-output qsp-string
   (:lambda (string)
     (list 'lib:main-pl string)))
 
 (p:defrule expression-output expression
   (:lambda (list)
     (list 'lib:main-pl list)))
 
 (p:defrule label (and colon identifier)
   (:lambda (list)
     (intern (string (second list)) :keyword)))
 
 (p:defrule comment (and #\! (* (or qsp-string brace-comment text-spaces not-newline)))
   (:constant nil))
 
 (p:defrule brace-comment (and #\{ (* (not-brace character)) #\})
   (:constant nil))
 
 (p:defrule local (and (p:~ "local") spaces variable (p:? (and spaces? #\= spaces? expression)))
   (:lambda (list)
     (list* 'lib:local (third list)
            (when (fourth list)
              (list (fourth (fourth list)))))))
 
 ;;; Blocks
 
 (p:defrule block (or block-act block-if block-for))
 
 (p:defrule block-if (and block-if-head block-if-body)
   (:destructure (head body)
     `(lib:qspcond (,@head ,@(first body))
                   ,@(rest body))))
 
 (p:defrule block-if-head (and (p:~ "if") spaces expression spaces? colon spaces?)
   (:function remove-nil)
   (:function cdr))
 
 (p:defrule block-if-body (or block-if-ml block-if-sl)
   (:destructure (if-body elseifs else &rest ws)
     (declare (ignore ws))
     `(,(remove-nil if-body) ,@elseifs ,@(when else `((else ,@else))))))
 
 (p:defrule block-if-sl (and line-body
                             (p:? block-if-elseif-inline)
                             (p:? block-if-else-inline)
                             spaces?))
 
 (p:defrule block-if-ml (and (and #\newline spaces?)
                             block-body
                             (p:? block-if-elseif)
                             (p:? block-if-else)
                             block-if-end)
   (:lambda (list)
     (cdr list)))
 
 (p:defrule block-if-elseif-inline (and block-if-elseif-head line-body (p:? block-if-elseif-inline))
   (:destructure (head statements elseif)
     `((,@(rest head) ,@(remove-nil statements)) ,@elseif)))
 
 (p:defrule block-if-elseif (and block-if-elseif-head statement-end block-body (p:? block-if-elseif))
   (:destructure (head ws statements elseif)
     (declare (ignore ws))
     `((,@(rest head) ,@(remove-nil statements)) ,@elseif)))
 
 (p:defrule block-if-elseif-head (and (p:~ "elseif") spaces expression spaces? colon spaces?)
   (:function remove-nil)
   (:function intern-first))
 
 (p:defrule block-if-else-inline (and block-if-else-head line-body)
   (:function second))
 
 (p:defrule block-if-else (and block-if-else-head #\newline spaces? block-body)
   (:function fourth))
 
 (p:defrule block-if-else-head (and (p:~ "else") spaces?)
   (:constant nil))
 
 (p:defrule block-if-end (and (p:~ "end") 
                              (p:? (and spaces (p:~ "if"))))
   (:constant nil))
 
 (p:defrule block-act (and block-act-head (or block-ml block-sl))
   (:lambda (list)
     (apply #'append list)))
 
 (p:defrule block-act-head (and (p:~ "act") spaces? qsp-string spaces?
                                (p:? block-act-head-img)
                                colon spaces?)
   (:lambda (list)
     (intern-first (list (first list)
                         (third list)
                         (or (fifth list) '(lib:str ""))))))
 
 (p:defrule block-act-head-img (and #\, spaces? qsp-string spaces?)
   (:lambda (list)
     (or (third list) "")))
 
 (p:defrule block-for (and block-for-head (or block-ml block-sl))
   (:lambda (list)
     (apply #'append list)))
 
 (p:defrule block-for-head (and (p:~ "for") spaces variable spaces? equal spaces? expression 
                                (p:~ "to") spaces expression
                                block-for-head-step
                                colon spaces?)
   (:lambda (list)
     (list 'lib:qspfor
           (elt list 2)
           (elt list 6)
           (elt list 9)
           (elt list 10))))
 
 (p:defrule block-for-head-step (p:? (and (p:~ "step") spaces expression spaces?))
   (:lambda (list)
     (if list
         (third list)
         1)))
 
 (p:defrule block-sl line-body)
 
 (p:defrule block-ml (and newline-block-body block-end)
   (:lambda (list)
     (apply #'list* (butlast list))))
 
 (p:defrule block-end (and (p:~ "end"))
   (:constant nil))
 
 ;;; Calls
 
 (p:defrule first-argument (and expression spaces?)
   (:function first))
 (p:defrule next-argument (and "," spaces? expression)
   (:function third))
 (p:defrule arguments (or parenthesized-arguments plain-arguments no-arguments))
 (p:defrule parenthesized-arguments (and spaces? #\( base-arguments #\))
   (:function third))
 (p:defrule plain-arguments (and spaces? base-arguments)
   (:function second))
 (p:defrule no-arguments (or (and spaces? (p:& #\newline))
                             (and spaces? (p:& #\&))
                             spaces?)
   (:constant nil))
 (p:defrule base-arguments (or (and first-argument (* next-argument)) spaces?)
   (:lambda (list)
     (if (null list)
         nil
         (list* (first list) (second list)))))
 
 ;;; Intrinsics
 
 (defmacro defintrinsics ((rule-name returning-rule-name non-returning-rule-name) &body clauses)
   `(progn
      ,@(loop :for clause :in clauses
           :collect `(defintrinsic ,@clause))
      (p:defrule ,returning-rule-name (or ,@(remove-nil
                                             (mapcar (lambda (clause)
                                                       (when (second clause)
                                                         (alexandria:symbolicate
                                                          'intrinsic- (first clause))))
                                                     clauses))))
      (p:defrule ,non-returning-rule-name (or ,@(remove-nil
                                                 (mapcar (lambda (clause)
                                                           (unless (second clause)
                                                             (alexandria:symbolicate
                                                              'intrinsic- (first clause))))
                                                         clauses))))
      (p:defrule ,rule-name (or ,returning-rule-name ,non-returning-rule-name))))
 
 (defmacro defintrinsic (sym returning &optional (min-arity 0) max-arity &rest names)
   (declare (ignore returning))
   (unless max-arity
     (setf max-arity *max-args*))
   (setf names 
         (if names
             (mapcar #'string-upcase names)
             (list (string sym))))
   `(p:defrule ,(alexandria:symbolicate 'intrinsic- sym)
        (and (p:? #\$) (or ,@(loop :for name :in names :collect `(p:~ ,name)))
             arguments)
      (:destructure (dollar name arguments)
        (declare (ignore dollar))
        (unless (<= ,min-arity (length arguments) ,max-arity)
          (error "Intrinsic ~A expects between ~A and ~A arguments but ~A were provided:~%~S"
                 name ,min-arity ,max-arity (length arguments) arguments))
-       (list* ',(intern (string sym) "SUGAR-QSP.LIB") arguments))))
+       (list* ',(intern (string sym) "TXT2WEB.LIB") arguments))))
 
 (defintrinsics (intrinsic returning-intrinsic non-returning-intrinsic)
   ;; Transitions
   (goto%    nil 0 nil "gt" "goto")
   (xgoto%   nil 0 nil "xgt" "xgoto")
   ;; Variables
   (killvar  nil 0 2)
   ;; Expressions
   (obj      t   1 1)
   (loc      t   1 1)
   (no       t   1 1)
   ;; Basic
   (qspver   t   0 0)
   (curloc   t   0 0)
   (rand     t   1 2)
   (rnd      t   0 0)
   (qspmax   t   1 nil "max")
   (qspmin   t   1 nil "min")
   ;; Arrays
   (killall  nil 0 0)
   (copyarr  nil 2 4)
   (arrsize  t   1 1)
   (arrpos   t   2 3)
   (arrcomp  t   2 3)
   ;; Strings
   (len      t   1 1)
   (mid      t   2 3)
   (ucase    t   1 1)
   (lcase    t   1 1)
   (trim     t   1 1)
   (replace  t   2 3)
   (instr    t   2 3)
   (isnum    t   1 1)
   (val      t   1 1)
   (qspstr   t   1 1 "str")
   (strcomp  t   2 2)
   (strfind  t   2 3)
   (strpos   t   2 3)
   ;; IF
   (iif      t   2 3)
   ;; Subs
   (gosub    nil 1 nil "gosub" "gs")
   (func     t   1 nil)
   (exit     nil 0 0)
   ;; Jump
   (jump     nil 1 1)
   ;; Dynamic
   (dynamic  nil 1 nil)
   (dyneval  t   1 nil)
   ;; Sound
   (play     nil 1 2)
   (isplay   t   1 1)
   (close    nil 1 1)
   (closeall nil 0 0 "close all")
   ;; Main window
   (main-pl  nil 1 1 "*pl")
   (main-nl  nil 0 1 "*nl")
   (main-p   nil 1 1 "*p")
   (maintxt  t   0 0)
   (desc     t   1 1)
   (main-clear   nil 0 0 "*clear" "*clr")
   ;; Aux window
   (showstat nil 1 1)
   (stat-pl  nil 1 1 "pl")
   (stat-nl  nil 0 1 "nl")
   (stat-p   nil 1 1 "p")
   (stattxt  t   0 0)
   (stat-clear    nil 0 0 "clear" "clr")
   (cls      nil 0 0)
   ;; Dialog
   (msg      nil 1 1)
   ;; Acts
   (showacts nil 1 1)
   (delact   nil 1 1 "delact" "del act")
   (curacts  t   0 0)
   (selact   t   0 0)
   (cla      nil 0 0)
   ;; Objects
   (showobjs nil 1 1)
   (addobj   nil 1 3 "addobj" "add obj")
   (delobj   nil 1 1 "delobj" "del obj")
   (killobj  nil 0 1)
   (countobj t   0 0)
   (getobj   t   1 1)
   (selobj   t   0 0)
   ;; Menu
   (menu     nil 1 1)
   ;; Images
   (refint   nil 0 0)
   (view     nil 0 1)
   (img      nil 1)
   (*img     nil 1)
   ;; Fonts
   (rgb      t   3 3)
   ;; Input
   (showinput nil 1 1)
   (usertxt  t   0 0 "user_text" "usrtxt")
   (cmdclear nil 0 0 "cmdclear" "cmdclr")
   (input    t   1 1)
   ;; Files
   (openqst  nil 1 1)
   (addqst   nil 1 1 "addqst" "addlib" "inclib")
   (killqst  nil 1 1 "killqst" "dellib" "freelib")
   (opengame nil 0 0)
   (savegame nil 0 0)
   ;; Real time
   (wait     nil 1 1)
   (msecscount t 0 0)
   (settimer nil 1 1))
 
 ;;; Expression
 
 (p:defrule expression or-expr)
 
 (p:defrule or-expr (and and-expr (* (and spaces? or-op spaces? and-expr)))
   (:function do-binop))
 
 (p:defrule and-expr (and eq-expr (* (and spaces? and-op spaces? eq-expr)))
   (:function do-binop))
 
 (p:defrule eq-expr (and sum-expr (* (and spaces? (or "<=" ">=" "=<" "=>" "<>"
                                                      "=" "<" ">" "!")
                                          spaces? sum-expr)))
   (:function do-binop))
 
 (p:defrule sum-expr (and mod-expr (* (and spaces? (or #\+ #\-) spaces? mod-expr)))
   (:function do-binop))
 
 (p:defrule mod-expr (and mul-expr (* (and spaces? (p:~ "mod") spaces? mul-expr)))
   (:function do-binop))
 
 (p:defrule mul-expr (and unary-expr (* (and spaces? (or #\* #\/) spaces? unary-expr)))
   (:function do-binop))
 
 (p:defrule unary-expr (and (p:? (or #\+ #\-)) atom-expr)
   (:lambda (list)
     (let ((expr (remove-nil list)))
       (if (= 1 (length expr))
           (first expr)
           (intern-first expr)))))
 
 (p:defrule atom-expr (and (or variable literal returning-intrinsic paren-expr) spaces?)
   (:function first))
 
 (p:defrule paren-expr (and #\( spaces? expression spaces? #\))
   (:function third))
 
 (p:defrule or-op (p:~ "or")
   (:constant "or"))
 
 (p:defrule and-op (p:~ "and")
   (:constant "and"))
 
 ;;; Variables
 
 (p:defrule variable (and identifier (p:? array-index))
   (:destructure (id idx-raw)
     (let ((idx (case idx-raw
                  ((nil) 0)
                  (:last nil)
                  (t idx-raw))))
       (list 'lib:qspvar id idx))))
 
 (p:defrule array-index (and #\[ spaces? (p:? expression) spaces? #\])
   (:lambda (list)
     (or (third list) :last)))
 
 (p:defrule assignment (or kw-assignment plain-assignment op-assignment)
   (:destructure (qspvar eq expr)
     (declare (ignore eq))
     (list 'lib:set qspvar expr)))
 
 (p:defrule kw-assignment (and (or (p:~ "let") (p:~ "set")) spaces? (or op-assignment plain-assignment))
   (:function third))
 
 (p:defrule op-assignment (and variable spaces? (or "+" "-" "*" "/") #\= spaces? expression)
   (:destructure (qspvar ws1 op eq ws2 expr)
                 (declare (ignore ws1 ws2))
                 (list qspvar eq (intern-first (list op qspvar expr)))))
 
 (p:defrule plain-assignment (and variable spaces? #\= spaces? expression)
   (:function remove-nil))
 
 ;;; Non-string literals
 
 (p:defrule literal (or qsp-string brace-string number))
 
 (p:defrule number (+ (or #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))
   (:lambda (list)
     (parse-integer (p:text list))))

src/ps-macros.lisp

@@ -1,377 +1,377 b''
 
-(in-package sugar-qsp.lib)
+(in-package txt2web.lib)
 
 ;;;; Parenscript macros which make the parser's intermediate
 ;;;; representation directly compilable by Parenscript
 ;;;; Some utility macros for other .ps sources too.
 
 ;;;; Block type | Has own locals | Has labels | async
 ;;;  Location   | TRUE           | TRUE       | TRUE
 ;;;  Act        | TRUE           | TRUE       | TRUE
 ;;;  {}         | TRUE           | TRUE       | TRUE
 ;;;  IF         | FALSE          | TRUE       | TRUE
 ;;;  FOR        | FALSE          | TRUE       | TRUE
 ;;;  
 ;;; IF and FOR are actually not blocks at all. They're implemented as Javascript's if and for loops.
 ;;; Jumps back are also optimized to Javascript's while loops.
 
 ;;; Utils
 
 ;;; Common
 
 (defpsmacro label-block (() &body body)
   (let ((has-labels (some #'keywordp body)))
     `(block nil
        ,@(when has-labels
            '((var _labels (list))))
        (tagbody
           ,@body
           (void)))))
 
 (defpsmacro str (&rest forms)
   (cond ((zerop (length forms))
          "")
         ((and (= 1 (length forms))
               (stringp (first forms)))
          (first forms))
         (t
          `(& ,@forms))))
 
 (defpsmacro locals-block (&body body)
   "Includes labels too (through qsp-lambda)"
   (let ((*locals* nil))
     (walker:walk 'locals body)
     `(qsp-lambda
       (create-locals ,*locals*)
       ,@(walker:walk 'apply-vars body))))
 
 ;;; 1loc
 
 (defparameter *special-variables*
   '((usehtml 0)
     (result 0)
     ($result 0)
     ($ongload 0)
     ($ongsave 0)
     ($onobjadd 0)
     ($onobjdel 0)
     ($onobjsel 0)
     ($onnewloc 0)
     ($onactsel 0)
     ($counter 0)
     ($usercom 0)))
 
 (defpsmacro game ((name) &body body)
   (setf body (walker:walk 'for-transform body))
   (setf *globals* *special-variables*)
   (walker:walk 'globals body)
   `(progn
      ;; Game object
      (setf (@ *games ,name)
            (create))
      ;; Global variables from this game
      (create-globals ,*globals*)
      ;; Locations
      ,@(loop :for location :in body
           :collect `(setf (@ *games ,name ,(caadr location))
                           ,location))))
 
 (defpsmacro location ((name) &body body)
   (declare (ignore name))
   "Name is used by the game macro above"
   `(locals-block ,@body))
 
 (defpsmacro goto% (target &rest args)
   `(progn
      (goto ,target ,args)
      (exit)))
 
 (defpsmacro xgoto% (target &rest args)
   `(progn
      (xgoto ,target ,args)
      (exit)))
 
 ;;; 2var
 
 (defvar *globals* nil)
 (defvar *locals* nil)
 
 (defpsmacro create-globals (globals)
   (flet ((indexes (name)
            (remove nil
                    (remove-if #'listp
                               (mapcar #'second
                                       (remove name globals
                                               :key #'first
                                               :test-not #'eq))))))
     (let ((names (remove-duplicates (mapcar #'first globals))))
       `(chain *object
               (assign *globals
                       (create
                        ,@(loop :for sym :in names
                             :for indexes := (indexes sym)
                             :for name := (string-upcase sym)
                             :append `(,name
                                       (api-call new-var ,name ,@indexes)))))))))
 
 (walker:deftransform globals qspvar (&rest var)
   (pushnew var *globals* :test #'equal)
   (walker:walk-continue))
 
 (walker:deftransform globals local (var &rest expr)
   (declare (ignore var))
   (walker:walk 'globals expr))
 
 (defpsmacro create-locals (locals)
   (when locals
     `(progn
        (var locals (create
                     ,@(loop :for (sym index) :in locals
                          :for name := (string-upcase sym)
                          :append `(,name (api-call new-var ,name))))))))
 
 ;; locations, blocks, and acts all have their own locals namespace
 (walker:deftransform-stop locals qspblock)
 (walker:deftransform-stop locals act)
 
 (walker:deftransform locals local (var &optional expr)
   (declare (ignore expr))
   (pushnew (rest var) *locals* :test #'equal)
   nil)
 
 ;; index types:
 ;; literal number
 ;; literal string
 ;; variable number
 ;; variable string
 ;; expression (may be possible to determine if it's a string or a number)
 
 (defun $-var-p (sym)
   (char= #\$ (elt (string-upcase (symbol-name sym)) 0)))
 
 (defun literal-string-p (form)
   (and (listp form)
        (= 2 (length form))
        (eq 'str (first form))
        (stringp (second form))))
 
 (defun variable-number-p (form)
   (and (listp form)
        (eq 'qspvar (first form))
        (not ($-var-p (second form)))))
 
 (defun variable-string-p (form)
   (and (listp form)
        (eq 'qspvar (first form))
        ($-var-p (second form))))
 
 (walker:deftransform apply-vars set (var expr)
   (destructuring-bind (qspvar name index)
       var
     (declare (ignore qspvar))
     (setf name (string-upcase name))
     (let ((slot `(getprop
                   ,(if (member name *locals* :key #'first)
                        'locals '*globals)
                   ,name))
           (index (walker:walk 'apply-vars index))
           (value (walker:walk 'apply-vars expr)))
       (cond
         ((member name api:*serv-vars* :test #'equalp)
          `(api:set-serv-var ,name ,index ,value))
         ((null index)
          `(chain (elt ,slot) (push ,value)))
         ((or (numberp index)
              (variable-number-p index))
          `(setf (elt ,slot ,index) ,value))
         ((or (literal-string-p index)
              (variable-string-p index))
          `(api:set-str-element ,slot ,index ,value))
         (t
          `(api:set-any-element ,slot ,index ,value))))))
 
 (walker:deftransform apply-vars local (var &optional expr)
                      ;; TODO: var can't be a service variable
   (when expr
     (walker:walk 'apply-vars (list 'set var expr))))
 
 (walker:deftransform apply-vars qspvar (name index)
   (let ((slot `(getprop
                 ,(if (member name *locals* :key #'first) 'locals '*globals)
                 ,(string-upcase name))))
     (cond
       ((null index)
        `(elt ,slot (1- (length ,slot))))
       ((or (numberp index)
            (variable-number-p index))
        `(elt ,slot ,(walker:walk-continue index)))
       ((or (literal-string-p index)
            (variable-string-p index))
        `(elt ,slot (@ ,slot :indexes ,(walker:walk-continue index))))
       (t
        `(get-element ,slot ,(walker:walk-continue index))))))
 
 (walker:deftransform apply-vars qspblock (&rest block)
   (declare (ignore block))
   (walker:whole))
 (walker:deftransform apply-vars act (&rest block)
   (declare (ignore block))
   (walker:whole))
 (walker:deftransform apply-vars qspfor (var from to step body)
   (list* 'qspfor var (mapcar #'walker:walk-continue (list from to step body))))
 
 ;;; 3expr
 
 (defpsmacro <> (op1 op2)
   `(not (equal ,op1 ,op2)))
 
 (defpsmacro ! (op1 op2)
   `(not (equal ,op1 ,op2)))
 
 ;;; 4code
 
 (defpsmacro exec (&body body)
   (format nil "javascript: ~{~A~^~%~}" (mapcar #'ps* body)))
 
 ;;; 5arrays
 
 ;;; 6str
 
 (defpsmacro & (&rest args)
   `(chain "" (concat ,@args)))
 
 ;;; 7if
 
 (defpsmacro qspcond (&rest clauses)
   `(cond ,@(loop :for clause :in clauses
               :collect (list (first clause)
                              `(tagbody
                                  ,@(rest clause))))))
 
 ;;; 8sub
 
 ;;; 9loops
 ;;; Yep, that's a huge kludge since Javascript doesn't support arbitrary labels
 
 (defpsmacro jump (target)
   `(return-from label-body ,(string-upcase (second target))))
 
 (defpsmacro tagbody (&body body)
   (let ((create-locals (if (eq (caar body) 'create-locals)
                            (list (car body))))
         (void (if (equal (car (last body)) '(void))
                   '((void)))))
     (when create-locals
       (setf body (cdr body)))
     (when void
       (setf body (butlast body)))
     (let ((funcs (list nil "_nil")))
       (dolist (form body)
         (cond ((keywordp form)
                (setf (first funcs) (reverse (first funcs)))
                (push (string-upcase form) funcs)
                (push nil funcs))
               (t
                (push form (first funcs)))))
       (setf (first funcs) (reverse (first funcs)))
       (setf funcs (reverse funcs))
       `(progn
          ,@create-locals
          ,(if (= 2 (length funcs))
               `(progn
                  ,@body)
               `(progn
                  (tagbody-blocks ,funcs)
                  (loop
                     :for _nextblock
                       := :_nil
                     :then (await (funcall (getprop _labels _nextblock)))
                     :while _nextblock)))
          ,@void))))
 
 (defvar *current-label*)
 (defvar *has-jump-back*)
 (walker:deftransform optimize-jump jump (target)
   (cond ((string= (string-upcase (second target)) *current-label*)
          (setf *has-jump-back* t)
          '(continue))
         (t
          (walker:walk-continue))))
 
 (defpsmacro tagbody-blocks (funcs)
   `(setf ,@(loop :for (label code . rest-labels) :on funcs :by #'cddr
               :append `((@ _labels ,label)
                         (async-lambda ()
                           (block label-body
                             (tagbody-block-body ,label ,code
                                                 ,(first rest-labels))))))))
 
 (defpsmacro tagbody-block-body (label code next-label)
   (let ((*current-label* label)
         (*has-jump-back* nil))
     (let ((code (walker:walk 'optimize-jump code)))
       (if *has-jump-back*
           `(progn
              (loop :do (progn
                          ,@code
                          (break)))
              ,@(if next-label
                    (list next-label)
                    nil))
           `(progn
              ,@code
              ,@(if next-label
                    (list next-label)
                    nil))))))
 
 (defpsmacro exit ()
   '(return-from nil (values)))
 
 ;;; 10dynamic
 
 (defpsmacro qspblock (&body body)
   `(locals-block
     ,@body))
 
 (defpsmacro qsp-lambda (&body body)
   `(async-lambda (args)
      (label-block ()
        ,@body)))
 
 ;;; 11main
 
 (defpsmacro act (name img &body body)
   `(api-call add-act ,name ,img
              (locals-block
                ,@body)))
 
 ;;; 12aux
 
 ;;; 13diag
 
 ;;; 14act
 
 ;;; 15objs
 
 ;;; 16menu
 
 ;;; 17sound
 
 ;;; 18img
 
 ;;; 19input
 
 ;;; 20time
 
 ;;; 21local
 
 ;;; 22for
 
 ;; Transform because it creates a (set ...) hence it has to be processed
 ;; before the apply-vars transform. And macros are processed after all
 ;; the transforms
 (walker:deftransform for-transform qspfor (var from to step &rest body)
   `(loop :for i :from ,from :to ,to :by ,step
       :do (set ,var i)
       :do (block nil
             ,@(walker:walk-continue body))))

src/writer.lisp

@@ -1,9 +1,9 b''
 
-(in-package sugar-qsp)
+(in-package txt2web)
 
 ;;; 1. Generates parenscript source to write to js
 ;;; 2. Collects everything into complete file, leaving a neatly marked
 ;;; place to customize page layout and styles.
 
 (defun make-javascript (locations)
   (mapcar #'ps:ps* locations))