100% parser, 100% macros, 50% intrinsics, 10% api, 0% misc

.hgignore

@@ -0,0 +1,2 b''
+.*~
+.qlot

Makefile

@@ -0,0 +1,17 b''
+
+all: diagrams.png $(BIN)
+
+$(BIN): src/*.lisp src/*.ps
+	buildapp.sbcl
+
+install-deps:
+	sbcl --load install-deps.lisp
+
+update-deps:
+	sbcl --load update-deps.lisp
+
+diagrams.png: diagrams.dot
+	dot $< -T png -o $@
+
+clean:
+	rm sugar-qsp

TODO

@@ -0,0 +1,9 b''
+
+* API
+* Sample
+* html
+* bundle it all
+* Qlot
+* make a binary
+
+* Finish intrinsics and api
  No newline at end of file

diagrams.dot

@@ -0,0 +1,18 b''
+
+digraph diagrams {
+    rankdir = LR
+    subgraph cluster_code {
+        label = "Code Transformations"
+        QSP -> intermediate [label="parser.lisp (esrap)"]
+        intermediate -> Parenscript [label="ps-macros.lisp"]
+        Parenscript -> Javascript [label="main.lisp"]
+    }
+    subgraph cluster_js {
+        label = "Javascript modules call hierarchy"
+        user -> "ps-macros"
+        user -> intrinsics
+        "ps-macros" -> intrinsics
+        "ps-macros" -> api
+        intrinsics -> api
+    }
+}

examples/10dynamic.txt

@@ -0,0 +1,22 b''
+
+# dynamic
+DYNAMIC {$a=0}
+DYNAMIC {if $a="string":'text!'}
+DYNAMIC {
+    $args[0]
+    addobj $args[1]
+},'Текст','Вилка'
+
+DYNEVAL({result = 3+4})
+PL DYNEVAL({$result = mid("abcd",2,1)+"qwerty"})
+PL DYNEVAL({$test + $args[0]}, val($test))
+проход=DYNEVAL({result = ($args[0] <> 'текст')}, 'строка')
+
+$code = {
+  *pl "<<$args[0]>>"
+  *pl $args[0]
+}
+ 
+DYNAMIC $code,'asdfg'
+! будет выведено две строки 'asdfg'
+-

examples/11main.txt

@@ -0,0 +1,8 b''
+
+# main
+*P '1'
+$txt = $MAINTXT
+*PL '23'
+*NL '456'
+'78'
+-

examples/12aux.txt

@@ -0,0 +1,7 b''
+
+# aux
+P '1'
+$txt = $STATTXT
+PL '23'
+NL '456'
+-

examples/13diag.txt

@@ -0,0 +1,18 b''
+
+# diag
+! простой вывод сообщения.
+MSG 'Много спелых груш'
+! получим окно с сообщением 'Много спелых груш'
+ 
+! Пример сообщения в действии ACT.
+ACT 'Поесть груш':
+   MSG 'Ммм груши очень вкусные'
+END
+! Получим вывод сообщения при клике по действию "Поесть груш"
+ 
+!Пример с условием.
+IF $hlebgotov = 1:
+MSG 'Похоже хлеб уже готов'
+END
+! Получаем вывод сообщения когда условие $hlebgotov = 1
+-

examples/14act.txt

@@ -0,0 +1,8 b''
+
+# act
+act 'test', 'img':
+	act 'test2':
+		'omg'
+	end
+end
+-

examples/15objs.txt

@@ -0,0 +1,21 b''
+
+# objs
+OBJECTS['деньги'] = 12
+OBJECTS['патроны'] = 137
+ 
+'Количество: <<OBJECTS[$getobj(countobj)]>>'
+
+!Первый предмет в списке
+GETOBJ(1) 
+ 
+!Последний предмет в списке
+GETOBJ(COUNTOBJ)
+
+i = 1
+:loop
+IF i <= COUNTOBJ:
+  OBJECTS[$GETOBJ(i)] = OBJECTS[$GETOBJ(i)] + 1
+  i = i + 1
+  JUMP 'loop'
+END
+-

examples/16menu.txt

@@ -0,0 +1,13 b''
+
+# menu
+! нет иконки
+$usr_menu[0] = 'Взять предмет:take_item'
+! иконка задана gif-файлом
+$usr_menu[1] = 'Положить предмет:put_item:images/put_item.gif'
+! иконка задана значением $icon_file
+$usr_menu[2] = 'Осмотреть предмет:look_item:<<$icon_file>>'
+! пункт меню задан 3-мя переменными
+$usr_menu[3] = '<<$name>>:<<$loc>>:<<$file>>'
+ 
+menu 'usr_menu' &! покажет меню из 4-х пунктов
+-

examples/17sound.txt

@@ -0,0 +1,15 b''
+
+# sound
+!Громкость 100%
+PLAY 'sound/music.mp3'
+!Громкость 50%
+PLAY 'sound/music.mp3',50
+!Громкость 0% (без звука)
+PLAY 'sound/music.mp3',0
+ 
+!Проигрывание файла по адресу из переменной $file
+! с расширением 'mid'
+! и громкостью volume
+PLAY '<<$file>>.mid',volume
+PLAY $file,volume &! аналогично
+-

examples/18img.txt

@@ -0,0 +1,14 b''
+
+# img
+$BACKIMAGE = 'content/back.png'
+
+VIEW 'content/monster.png'
+
+! Включаем режим HTML. Если во всей игре используется HTML, 
+! то достаточно включить его на самой первой локации.
+USEHTML = 1
+! Выводим картинку в основное описание
+'<img src="content/room.jpg">'
+! Выводим картинку в доп. описание
+PL '<img src="content/map.jpg">'
+-

examples/19input.txt

@@ -0,0 +1,20 b''
+
+# input
+$text = $USER_TEXT
+CMDCLEAR
+SHOWINPUT 0
+
+$name = INPUT('Как звать тебя, герой?')
+
+! Вопрос с одним правильным ответом. 
+if input ('Что приходит после тьмы?') = 'свет':
+    msg 'Все верно.'
+    else
+    msg 'Ответ не верный.'
+end
+
+! Пример реализации вопроса с несколькими вариантами ответа из которых любой будет правильным.
+$answer = TRIM(LCASE(input('Ответить')))
+if INSTR($answer, 'красный') OR INSTR($answer, 'желтый') OR INSTR($answer, 'зеленый'): gt 'win'
+! Введя красный или зеленый ил желтый произойдет переход на локацию 'win'
+-

examples/1loc.txt

@@ -0,0 +1,9 b''
+
+# loc
+GT 'локация'
+GT 'локация',1,'данные'
+-
+
+# локация
+
+-

examples/20time.txt

@@ -0,0 +1,44 b''
+
+# time
+! устанавливает период выполнения кода
+! на локации-счётчике в 100 миллисекунд
+SETTIMER 100
+
+settimer 20
+if стихотворение=0:
+    if время_первая_строка=0:
+        время_первая_строка=msecscount+1500
+    end
+    if msecscount>=время_первая_строка:
+        *pl 'Веленью совести, о Муза, будь послушна!'
+        стихотворение=1
+    end
+end
+if стихотворение=1:
+    if время_вторая_строка=0:
+        время_вторая_строка=msecscount+1500
+    end
+    if msecscount>=время_вторая_строка:
+        *pl 'Обиды не страшась, не требуя венца,'
+        стихотворение=2
+    end
+end
+if стихотворение=2:
+    if время_третья_строка=0:
+        время_третья_строка=msecscount+1500
+    end
+    if msecscount>=время_третья_строка:
+        *pl 'Хвалу и клевету приемли равнодушно'
+        стихотворение=3
+    end
+end
+if стихотворение=3:
+    if время_четвёртая_строка=0:
+        время_четвёртая_строка=msecscount+1500
+    end
+    if msecscount>=время_четвёртая_строка:
+        *pl 'И не оспаривай глупца.'
+        стихотворение=4
+    end
+end
+-

examples/2var.txt

@@ -0,0 +1,7 b''
+
+# var
+var1 = 42
+SET var2 = 42
+LET var3 = 42
+KILLVAR 'var1'
+-

examples/3expr.txt

@@ -0,0 +1,16 b''
+
+# expr
+x=5
+y=6
+tmp=(x ! y) OR (x <> y)
+tmp=x OR y
+tmp=x AND y
+tmp=y MOD x
+tmp=OBJ 'стул'
+tmp=LOC 'дом'
+tmp=res = x*y + y*-x/2
+tmp=res = NO x = y
+ 
+tmp=15*5/2
+tmp=15/2*5
+-

examples/4code.txt

@@ -0,0 +1,56 b''
+
+# code
+яблоко = 1
+груша = 1
+ 
+*pl 'Яблок' + яблоко
+*pl 'Груш' + груша
+
+'<a href="EXEC: яблоко += 1 & GT $CURLOC">яблоко</a>'
+!При нажатии на ссылку выполнится код:
+яблоко += 1
+GT $CURLOC
+
+  !Однострочный комментарий
+  яблоки = 0
+!'Многострочный
+комментарий'
+яблоки = 1
+  сыр = 5 &  ! А здесь"комментарий начинается
+  в той же строке, но" заканчивается 'сильно
+  позже'. Во всём виноваты {кавычки и скобки
+  }Кстати:
+  яблоки=0
+ !'Комментарии рекомендуется писать всё-таки
+в отдельных строках, а не как с "сыром"'
+
+!'Общий вид вызова оператора
+    имя_оператора аргумент1, аргумент2, ...
+или
+    имя_оператора (аргумент1, аргумент2, ...)
+'
+!Примеры вызовов операторов:
+ADDOBJ 'ключ','pics/key.png'
+ADDOBJ ('ключ','pics/key.png')
+PL ('текст')
+CLEAR()
+
+!Примеры вызовов функций:
+X = MAX(1, 2, 4)
+A = RAND(4)
+B = COUNTOBJ
+PL STR(43)
+PL $STR(43)
+!Последние два выражения эквивалентны
+
+RAND(1,4) &! вернёт случайное значение от 1 до 4
+RAND(4,1) &! вернёт случайное значение от 1 до 4
+RAND(1000) &! вернёт случайное значение от 0(1) до 1000
+RAND 1000 &! вернёт случайное значение от 0(1) до 1000
+
+MAX(1,2,5,2,0) &! вернёт 5
+MAX(a,b,c) &! вернёт максимальное из значений переменных a,b,c
+MAX('aa','ab','zz') &! вернёт 'zz'
+MAX('a') &! вернёт максимальное из значений элементов массива "a"
+MAX('$b') &! вернёт максимальное из значений элементов массива "$b"
+-

examples/5arrays.txt

@@ -0,0 +1,25 b''
+
+# arrays
+$яблоки[0]='антоновка'
+$яблоки[1]='белый налив'
+$яблоки[2]='астраханское'
+$яблоки[3]='ранетка'
+$яблоки[4]='симиренко'
+ 
+сорт_яблока[0] = 1
+сорт_яблока[1] = 2
+сорт_яблока[2] = 4
+ 
+*pl $яблоки[сорт_яблока[номер_яблока]]
+
+$любимый_сорт['иван'] = $яблоки[2]
+любимое_число['Алексей'] = 5
+$item_loc['палка'] = 'лес'
+
+$objs[] = 'Напильник' &! Если массив был пустой, то
+$objs[] = 'Топор'     &! [0] = 'Напильник',
+$objs[] = 'Доска'     &! [1] = 'Топор', [2] = 'Доска'
+
+$a = $objs[] &! 'Доска' из примера выше
+a = сорт_яблока[] &! 4 из примера выше
+-

examples/6str.txt

@@ -0,0 +1,19 b''
+
+# str
+*PL 'Byte Soft''s "QSP"'
+*PL "Byte Soft's ""QSP"""
+
+'Данный текст
+будет расположен на
+нескольких строках'
+ 
+$a='И этот
+текст
+также'
+ 
+a=2 & act 'Многострочное
+название':gt 'next' & GoTo 'next'
+
+$res = ('x=' & x & ' y=' & y)
+$res = 'x=' & x
+-

examples/7if.txt

@@ -0,0 +1,56 b''
+
+
+# if-elseif
+IF a=1:
+  !операторы
+ELSEIF a=2:
+  !операторы
+ELSEIF a=3:
+  !операторы
+END
+
+-
+
+# if-iif
+!Модуль числа
+abs_x = IIF(x > 0, x, -x)
+ 
+!А следующая конструкция вызовет ошибку деления на ноль:
+x = 0
+y = IIF(x = 0, 0, 1/x)
+-
+
+# if-inline
+if ((a+b)/c)=45+54 or (b<5 or c>45) and no obj 'лопата' and $f=$vvv+'RRRRR': p 'OK' & goto 'Next'
+if был_здесь[$curloc]: exit
+if a<3: jump 'sss'
+if $имя = '': msg 'Введите имя!' & jump 'ввод'
+if a+b=2:c=30 & gt 'next' else c=10 & d=11
+-
+
+# if-lines
+if a+b<3 or y=8:
+  p 'A+B<3 или Y=8'
+  nl 
+  if j=88: nl & p 'NEXT' 
+  if $h='ooo':
+    p 'loo' & jump 'lll'
+  end
+end
+ 
+if a=0:
+  'abc1234'
+  if b=0: '0' else '1'
+  if j=88:nl & p 'NEXT'
+  if $h='ooo':
+    p 'loo' & jump 'lll'
+  else
+    p 'sample text'
+    v=8
+  end
+  '1234'
+else
+  '01234'
+  g=78
+end
+-

examples/8sub.txt

@@ -0,0 +1,18 b''
+
+# sub
+GS 'переход', 'локация'
+GS 'ход'
+GS $loc,1
+GS 'ход',$var,2,'данные'
+яблоки = FUNC('функция')
+PL FUNC($name, 1) * 78
+MSG "text" + FUNC($name, "строка", 2)
+if args[0] = 0: exit
+-
+
+#переход
+*PL $ARGS[0]  &! На экран выведется 'локация'
+ACT 'Перейти':
+  GT $ARGS[0] &! Работать не будет, т.к. массив ARGS пуст
+END
+-

examples/9loops.txt

@@ -0,0 +1,27 b''
+
+# loops
+jump 'КонеЦ'
+p 'Это сообщение не будет выведено'
+:конец
+p 'А это сообщение пользователь увидит'
+
+s=0
+:loop
+if s<9:
+  s=s+1
+  pl s
+  jump 'loop'
+end
+p 'Всё!'
+
+:loop
+if y<y0:
+  if x<x0:
+    x=x+1
+    jump 'loop'
+  end
+  y=y+1
+  x=0
+  jump 'loop'
+end
+-

install-deps.lisp

@@ -0,0 +1,3 b''
+(ql:quickload :qlot)
+(asdf:load-system :qlot/cli)
+(qlot/cli:install)

qlfile

@@ -0,0 +1,4 b''
+ql alexandria
+ql esrap
+ql parenscript
+ql cl-uglify-js

qlfile.lock

@@ -0,0 +1,24 b''
+("quicklisp" .
+ (:class qlot/source/dist:source-dist
+  :initargs (:distribution "http://beta.quicklisp.org/dist/quicklisp.txt" :%version :latest)
+  :version "2020-02-18"))
+("alexandria" .
+ (:class qlot/source/ql:source-ql
+  :initargs (:%version :latest)
+  :version "ql-2020-02-18"))
+("esrap" .
+ (:class qlot/source/ql:source-ql
+  :initargs (:%version :latest)
+  :version "ql-2020-02-18"))
+("parenscript" .
+ (:class qlot/source/ql:source-ql
+  :initargs (:%version :latest)
+  :version "ql-2020-02-18"))
+("cl-uglify-js" .
+ (:class qlot/source/ql:source-ql
+  :initargs (:%version :latest)
+  :version "ql-2020-02-18"))
+("adopt" .
+ (:class qlot/source/github:source-github
+  :initargs (:repos "sjl/adopt" :ref nil :branch nil :tag nil)
+  :version "github-b594120fec8a15c68cae5040f8db6658"))

src/api.ps

@@ -0,0 +1,39 b''
+
+(in-package sugar-qsp)
+
+;;; API deals with DOM manipulation and some bookkeeping for the
+;;; intrinsics, namely variables
+;;; API is an implementation detail and has no QSP documentation. It
+;;; doesn't call intrinsics
+
+(setf (root api) (ps:create))
+
+;;; Function calls
+
+(defm (root api init-args) (args)
+  (dotimes (i (length args))
+    (if (numberp (elt args i))
+        (set (var args i) (elt args i))
+        (set (var $args i) (elt args i)))))
+
+(defm (root api get-result) ()
+  (if (not (equal "" (var $result 0)))
+      (var $result 0)
+      (var result 0)))
+
+;;; Text windows
+
+(defm (root api add-text) ())
+(defm (root api get-text) ())
+(defm (root api clear-text) ())
+
+;;; Actions
+
+(defm (root api add-act) ())
+(defm (root api clear-act) ())
+
+;;; Variables
+
+(defm (root api get-var) ())
+(defm (root api set-var) ())
+(defm (root api kill-var) ())

src/intrinsics.ps

@@ -0,0 +1,289 b''
+
+(in-package sugar-qsp)
+
+;;;; Intrinsics are functions and procedures defined by the language.
+;;;; They can call api and deal with locations and other data directly.
+;;;; Except vars. Use VAR and SET or GET-VAR and SET-VAR api calls.
+
+(setf (root intrinsics) (ps:create))
+
+;;; 1loc
+
+(defm (root intrinsics goto) (target &rest args)
+  (api-call clear-text :main)
+  (apply (root intrinsics xgoto) target args))
+
+(defm (root intrinsics xgoto) (target &rest args)
+  (api-call clear-act)
+  (api-call init-args args)
+  (setf (root current-location) target)
+  (funcall (ps:getprop (root locations) target)))
+
+;;; 2var
+
+(defm (root intrinsics killvar) (varname &optional (index :whole))
+  (api-call kill-var varname index))
+
+(defm (root intrinsics killall) ()
+  (api-call kill-all))
+
+;;; 3expr
+
+(defm (root intrinsics obj) (name)
+  (funcall (root objs includes) name))
+
+(defm (root intrinsics loc) ()
+  (funcall (root locations includes) name))
+
+(defm (root intrinsics no) (arg)
+  (- -1 arg))
+
+;;; 4code
+
+(defm (root intrinsics qspver) ()
+  "0.0.1")
+
+(defm (root intrinsics curloc) ()
+  (root current-location))
+
+(defm (root intrinsics rand) (a b)
+  (let ((min (min a b))
+        (max (max a b)))
+    (+ min (ps:chain *math (random (- max min))))))
+
+(defm (root intrinsics rnd) ()
+  (funcall (root intrinsics rand) 1 1000))
+
+(defm (root intrinsics qspmax) (&rest args)
+  (apply (ps:@ *math max) args))
+
+(defm (root intrinsics qspmin) (&rest args)
+  (apply (ps:@ *math min) args))
+
+;;; 5arrays
+
+(defm (root intrinsics copyarr) (to from start count)
+  (ps:for ((i start))
+          ((< i (min (api-call array-size from)
+                     (+ start count))))
+          ((incf i))
+    (api-call set-var to (+ start i)
+              (api-call get-var from (+ start i)))))
+
+(defm (root intrinsics arrsize) (name)
+  (api-call array-size name))
+
+(defm (root intrinsics arrpos) (name value &optional (start 0))
+  (ps:for ((i start)) ((< i (api-call array-size name))) ((incf i))
+    (when (eq (api-call get-var name i) value)
+      (return i)))
+  -1)
+
+(defm (root intrinsics arrcomp) (name pattern &optional (start 0))
+  (ps:for ((i start)) ((< i (api-call array-size name))) ((incf i))
+    (when (funcall (ps:getprop (api-call get-var name i) 'match) pattern)
+      (return i)))
+  -1)
+
+;;; 6str
+
+(defm (root intrinsics len) (s)
+  (length s))
+
+(defm (root intrinsics mid) (s from &optional count)
+  (s.substring from count))
+
+(defm (root intrinsics ucase) (s)
+  (s.to-upper-case))
+
+(defm (root intrinsics lcase) (s)
+  (s.to-lower-case))
+
+(defm (root intrinsics trim) (s)
+  (s.trim))
+
+(defm (root intrinsics replace) (s from to)
+  (s.replace from to))
+
+(defm (root intrinsics instr) (s subs &optional (start 1))
+  (+ start (ps:chain s (substring (- start 1)) (search subs))))
+
+(defm (root intrinsics isnum) (s)
+  (if (is-na-n s)
+      0
+      -1))
+
+(defm (root intrinsics val) (s)
+  (parse-int s 10))
+
+(defm (root intrinsics qspstr) (n)
+  (+ "" n))
+
+(defm (root intrinsics strcomp) (s pattern)
+  (if (s.match pattern)
+      -1
+      0))
+
+(defm (root intrinsics strfind) (s pattern group)
+  (let* ((re (ps:new (*reg-exp pattern)))
+         (match (re.exec s)))
+    (match.group group)))
+
+(defm (root intrinsics strpos) (s pattern &optional (group 0))
+  (let* ((re (ps:new (*reg-exp pattern)))
+         (match (re.exec s))
+         (found (match.group group)))
+    (if found
+        (s.search found)
+        0)))
+
+;;; 7if
+
+(defm (root intrinsics iif) (cond then else)
+  (if (= -1 cond) then else))
+
+;;; 8sub
+
+(defm (root intrinsics gosub) (target &rest args)
+  (conserving-vars (args $args result $result)
+    (api-call init-args args)
+    (funcall (ps:getprop (root locations) target))
+    (values)))
+
+(defm (root intrinsics func) (target &rest args)
+  (conserving-vars (args $args result $result)
+    (api-call init-args args)
+    (funcall (ps:getprop (root locations) target))
+    (api-call get-result)))
+
+;;; 9loops
+
+;;; 10dynamic
+
+(defm (root intrinsics dyneval) (block &rest args)
+  (conserving-vars (args $args result $result)
+    (api-call init-args args)
+    (funcall block)
+    (api-call get-result)))
+
+(defm (root intrinsics dynamic) (&rest args)
+  (conserving-vars (args $args result $result)
+    (api-call init-args args)
+    (funcall block)
+    (values)))
+
+;;; 11main
+
+(defm (root intrinsics main-p) (s)
+  (api-call add-text :main s))
+
+(defm (root intrinsics main-pl) ()
+  (api-call add-text :main (+ s "\n")))
+
+(defm (root intrinsics main-nl) ()
+  (api-call add-text :main (+ "\n" s)))
+
+(defm (root intrinsics maintxt) (s)
+  (api-call get-text :main))
+
+(defm (root intrinsics desc) (s)
+  (api-call report-error "DESC is not supported"))
+
+(defm (root intrinsics main-clear) ()
+  (api-call clear-text :main))
+
+;;; 12aux
+
+(defm (root intrinsics showstat) ())
+
+(defm (root intrinsics aux-p) ())
+
+(defm (root intrinsics aux-pl) ())
+
+(defm (root intrinsics aux-nl) ())
+
+(defm (root intrinsics stattxt) ())
+
+(defm (root intrinsics clear) ())
+
+(defm (root intrinsics cls) ())
+
+;;; 13diag
+
+(defm (root intrinsics msg) ())
+
+;;; 14act
+
+(defm (root intrinsics showacts) ())
+
+(defm (root intrinsics delact) ())
+
+(defm (root intrinsics curacts) ())
+
+(defm (root intrinsics cla) ())
+
+;;; 15objs
+
+(defm (root intrinsics showobjs) ())
+
+(defm (root intrinsics addobj) ())
+
+(defm (root intrinsics delobj) ())
+
+(defm (root intrinsics killobj) ())
+
+(defm (root intrinsics countobj) ())
+
+(defm (root intrinsics getobj) ())
+
+;;; 16menu
+
+(defm (root intrinsics menu) ())
+
+;;; 17sound
+
+(defm (root intrinsics play) ())
+
+(defm (root intrinsics isplay) ())
+
+(defm (root intrinsics close) ())
+
+(defm (root intrinsics closeall) ())
+
+;;; 18img
+
+(defm (root intrinsics refint) ())
+
+(defm (root intrinsics view) ())
+
+;;; 19input
+
+(defm (root intrinsics showinput) ())
+
+(defm (root intrinsics usertxt) ())
+
+(defm (root intrinsics cmdclear) ())
+
+(defm (root intrinsics input) ())
+
+;;; 20time
+
+(defm (root intrinsics wait) ())
+
+(defm (root intrinsics msecscount) ())
+
+(defm (root intrinsics settimer) ())
+
+;;; misc
+
+(defm (root intrinsics rgb) ())
+
+(defm (root intrinsics openqst) ())
+
+(defm (root intrinsics addqst) ())
+
+(defm (root intrinsics killqst) ())
+
+(defm (root intrinsics opengame) ())
+
+(defm (root intrinsics savegame) ())

src/main.lisp

@@ -0,0 +1,17 b''
+
+(in-package sugar-qsp)
+
+(defun entry-point (&rest args)
+  (catch :terminate
+    (make-javascript (parse-file (first args)))))
+
+(defun parse-file (filename)
+  (p:parse 'sugar-qsp-grammar
+           (alexandria:read-file-into-string filename)))
+
+(defun make-javascript (locations)
+  (mapcar #'make-javascript locations))
+
+(defun report-error (fmt &rest args)
+  (apply #'format t fmt args)
+  (throw :terminate nil))

src/model.lisp

@@ -0,0 +1,2 b''
+
+(in-package sugar-qsp)

src/package.lisp

@@ -0,0 +1,7 b''
+
+(in-package cl-user)
+
+(defpackage :sugar-qsp
+  (:use :cl)
+  (:local-nicknames (#:p #:esrap))
+  (:export #:parse-file #:entry-point))

src/parser.lisp

@@ -0,0 +1,568 b''
+
+(in-package sugar-qsp)
+
+;;;; Parses TXT source to an intermediate representation
+
+;;; 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)))
+         (rest list)))
+
+(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)) 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 (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))
+
+(p:defrule spaces? (* (or #\space #\tab line-continuation))
+  (:constant nil))
+
+(p:defrule colon #\:
+  (: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
+
+;; From the official docs
+(defparameter *keywords* '(act addlib addobj addqst and arrcomp arrpos arrsize $backimage bcolor cla clear *clear close clr *clr cls cmdclear cmdclr copyarr $counter countobj $curacts curloc debug delact dellib delobj desc disablescroll disablesubex dynamic dyneval else elseif end exit fcolor $fname freelib fsize func getobj gosub goto gs gt if iif inclib input instr isnum isplay jump killall killobj killqst killvar lcase lcolor len let loc $maintxt max menu mid min mod msecscount msg nl *nl no nosave obj $onactsel $ongload $ongsave $onnewloc $onobjadd $onobjdel $onobjsel opengame openqst or p *p pl *pl play qspver rand refint replace rgb rnd savegame selact selobj set settimer showacts showinput showobjs showstat $stattxt str strcomp strfind strpos trim ucase unsel unselect usehtml $usercom user_text usrtxt val view wait xgoto xgt))
+
+(defun qsp-keyword-p (id)
+  (member (intern (string-upcase id)) *keywords*))
+
+(defun not-qsp-keyword-p (id)
+  (not (member (intern (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)
+    (let ((id (p:text list)))
+      (when (member id *keywords*)
+        (error "~A is a keyword" id))
+      (intern (string-upcase id)))))
+
+(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* '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* 'exec (p:parse 'exec-body (second list)))))
+
+(p:defrule dstring-exec (and (p:~ "'exec:") dstring-exec-body #\')
+  (:lambda (list)
+    (list* 'exec (p:parse 'exec-body (second list)))))
+
+(p:defrule brace-string (and #\{ before-statement block-body #\})
+  (:lambda (list)
+    (list* 'qspblock (third list))))
+
+;;; Location
+
+(p:defrule sugar-qsp-grammar (and (* (or spaces #\newline))
+                                  (* location))
+  (:function second))
+
+(p:defrule location (and location-header block-body location-end)
+  (:destructure (header body end)
+    (declare (ignore end))
+    `(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 #\- #\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 assignment
+                               expression-output))
+  (:function second))
+
+(p:defrule expr-stopper (or comment block non-returning-intrinsic))
+
+(p:defrule string-output qsp-string
+  (:lambda (string)
+    (list 'main-pl string)))
+
+(p:defrule expression-output expression
+  (:lambda (list)
+    (list 'main-pl list)))
+
+(p:defrule label (and colon identifier)
+  (:lambda (list)
+    (intern (string (second list)) :keyword)))
+
+(p:defrule comment (and #\! (* (or text-spaces qsp-string brace-string not-newline)))
+  (:constant nil))
+
+;;; Blocks
+
+(p:defrule block (or block-act block-if))
+
+(p:defrule block-if (and block-if-head block-if-body)
+  (:destructure (head body)
+    `(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-act-ml block-act-sl))
+  (:lambda (list)
+    (apply #'append list)))
+
+(p:defrule block-act-sl (and line-body #\newline spaces?)
+  (:function first))
+
+(p:defrule block-act-ml (and newline-block-body block-act-end)
+  (:lambda (list)
+    (apply #'list* (butlast list))))
+
+(p:defrule block-act-head (and (p:~ "act") spaces qsp-string spaces?
+                               (p:? block-act-head-img)
+                               colon spaces?)
+  (:lambda (list)
+    (intern-first (remove-nil list))))
+
+(p:defrule block-act-head-img (and #\, spaces? qsp-string spaces?)
+  (:lambda (list)
+    (or (third list) "")))
+
+(p:defrule block-act-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 spaces (p:& #\newline) (p:& #\&))
+  (:constant nil))
+(p:defrule base-arguments (and first-argument (* next-argument))
+  (:destructure (first rest)
+    (list* first rest)))
+
+;;; 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 10) &rest names)
+  (declare (ignore returning))
+  (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* ',sym arguments))))
+
+(defintrinsics (intrinsic returning-intrinsic non-returning-intrinsic)
+  ;; Transitions
+  (goto     nil 0 10 "gt" "goto")
+  (xgoto    nil 0 10 "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 10 "max")
+  (qspmin   t   1 10 "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 10 "gosub" "gs")
+  (func     t   1 10)
+  (exit     nil 0 0)
+  ;; Jump
+  (jump     nil 1 1)
+  ;; Dynamic
+  (dynamic  nil 1 10)
+  (dyneval  t   1 10)
+  ;; Main window
+  (main-p   nil 1 1 "*p")
+  (main-pl  nil 1 1 "*pl")
+  (main-nl  nil 0 1 "*nl")
+  (maintxt  t   0 0)
+  (desc     t   1 1)
+  (main-clear   nil 0 0 "*clear" "*clr")
+  ;; Aux window
+  (showstat nil 1 1)
+  (stat-p    nil 1 1 "p")
+  (stat-pl   nil 1 1 "pl")
+  (stat-nl   nil 0 1 "nl")
+  (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)
+  (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)
+  ;; Menu
+  (menu     nil 1 1)
+  ;; Sound
+  (play     nil 1 2)
+  (isplay   t   1 1)
+  (close    nil 1 1)
+  (closeall nil 0 0 "close all")
+  ;; Images
+  (refint   nil 0 0)
+  (view     nil 0 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 1)
+  (savegame nil 0 1)
+  ;; 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 cat-expr (* (and spaces? (or "<>" "<=" ">=" "=<" "=>"
+                                                          #\= #\< #\> #\!)
+                                         spaces? cat-expr)))
+  (:function do-binop))
+
+(p:defrule cat-expr (and sum-expr (* (and spaces? #\& spaces? (p:! expr-stopper) sum-expr)))
+  (:lambda (list)
+    (do-binop (list (first list) (mapcar (lambda (l)
+                                           (remove-nth l 3))
+                                         (second list))))))
+
+(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 exists-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)
+    (list 'var id (or idx 0))))
+
+(p:defrule array-index (and #\[ spaces? (p:? expression) spaces? #\])
+  (:lambda (list)
+    (or (third list) :end)))
+
+(p:defrule assignment (or kw-assignment plain-assignment)
+  (:destructure (var eq expr)
+    (declare (ignore eq))
+    (list 'set var expr)))
+
+(p:defrule plain-assignment (and variable spaces? #\= spaces? expression)
+  (:function remove-nil))
+(p:defrule kw-assignment (and (or (p:~ "let") (p:~ "set")) spaces? plain-assignment)
+  (:function third))
+
+;;; 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

@@ -0,0 +1,194 b''
+
+(in-package sugar-qsp)
+
+;;;; Parenscript macros which make the parser's intermediate
+;;;; representation directly compilable by Parenscript
+;;;; Some utility macros for other .ps sources too.
+
+;;; Utils
+
+(ps:defpsmacro defm (path args &body body)
+  `(setf ,path (lambda ,args ,@body)))
+
+(ps:defpsmacro root (&rest path)
+  `(ps:@ *sugar-q-s-p ,@path))
+
+(ps:defpsmacro conserving-vars (vars &body body)
+  "Calls body with safely stored away VARS, and restores their values after that returning what BODY returns."
+  `(let ((__conserved (list ,@(loop :for var :in vars
+                                 :collect `(var ,var 0)))))
+     ,@(loop :for var :in vars
+          :collect `(set (var ,var 0) ,(if (char= #\$ (elt (string var) 0))
+                                           "" 0)))
+     (unwind-protect
+          (progn ,@body)
+       (progn
+         ,@(loop :for var :in vars
+                :for i from 0
+              :collect `(set (var ,var 0) (ps:@ __conserved ,i)))))))
+
+;;; Common
+
+(defmacro defpsintrinsic (name)
+  `(ps:defpsmacro ,name (&rest args)
+     `(funcall (root intrinsics ,',name)
+               ,@args)))
+
+(defmacro defpsintrinsics (() &rest names)
+  `(progn ,@(loop :for name :in names
+                 :collect `(defpsintrinsic ,name))))
+
+(defpsintrinsics ()
+    killvar obj loc no qspver curloc rand rnd qspmax qspmin killall copyarr arrsize arrpos arrcomp len mid ucase lcase trim replace instr isnum val qspstr strcomp strfind strpos iif gosub func dynamic dyneval main-p main-pl main-nl maintxt main-clear showstat stat-p stat-pl stat-nl stattxt stat-clear cls msg showacts delact curacts cla showobjs addobj delobj killobj countobj getobj menu play isplay close closeall refint view rgb showinput usertxt cmdclear input openqst addqst killqst opengame savegame wait msecscount settimer)
+
+(ps:defpsmacro api-call (func &rest args)
+  `(funcall (root api ,func) ,@args))
+
+(ps:defpsmacro label-block (&body body)
+  `(progn
+     (defvar __labels)
+     ,@body
+     (values)))
+
+(ps:defpsmacro big-block (&body body)
+  `(ps:try
+    (label-block
+     ,@body)
+    (:catch (exit-p)
+            (unless (eq exit-p :exit)
+              (throw exit-p)))))
+
+(ps:defpsmacro str (&rest forms)
+  (cond ((zerop (length forms))
+         "")
+        ((and (= 1 (length forms))
+              (stringp (first forms)))
+         (first forms))
+        (t
+         `(& ,@forms))))
+
+;;; 1loc
+
+(ps:defpsmacro location ((name) &body body)
+  `(setf (root locations ,name)
+         (big-block
+          (tagbody ,@body))))
+
+(ps:defpsmacro goto (target &rest args)
+  `(progn
+     (funcall (root intrinsics goto) ,target ,@args)
+     (exit)))
+
+(ps:defpsmacro xgoto (target &rest args)
+  `(progn
+     (funcall (root intrinsics xgoto) ,target ,@args)
+     (exit)))
+
+(ps:defpsmacro desc (target)
+  (report-error "DESC is not supported"))
+
+;;; 2var
+
+(ps:defpsmacro var (name index)
+  `(api-call get-var ,(string name) ,index))
+
+(ps:defpsmacro set ((var vname vindex) value)
+  (assert (eq var 'var))
+  `(api-call set-var ,(string vname) ,vindex ,value))
+
+;;; 3expr
+
+(ps:defpsmacro <> (op1 op2)
+  `(not (equal ,op1 ,op2)))
+
+(ps:defpsmacro ! (op1 op2)
+  `(not (equal ,op1 ,op2)))
+
+;;; 4code
+
+(ps:defpsmacro exec (&body body)
+  (format nil "javascript: ~{~A~^~%~}" (mapcar #'ps:ps* body)))
+
+;;; 5arrays
+
+;;; 6str
+
+(ps:defpsmacro & (&rest args)
+  `(ps:chain "" (concat ,@args)))
+
+;;; 7if
+
+(ps: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
+
+(ps:defpsmacro jump (target)
+  `(return-from ,(intern (string-upcase (second target)))
+     (funcall (ps:getprop __labels ,target))))
+
+(ps:defpsmacro tagbody (&body body)
+  (let ((funcs (list nil :__nil)))
+    (dolist (form body)
+      (cond ((keywordp form)
+             (setf (first funcs) (reverse (first funcs)))
+             (push form funcs)
+             (push nil funcs))
+            (t
+             (push form (first funcs)))))
+    (setf (first funcs) (reverse (first funcs)))
+    (setf funcs (reverse funcs))
+    (if (= 2 (length funcs))
+        `(progn
+           ,@body)
+        `(progn
+           (setf ,@(loop :for f :on funcs :by #'cddr
+                      :append (list `(ps:@ __labels ,(first f))
+                                    `(block ,(intern (string-upcase (string (first f))))
+                                       ,@(second f)
+                                       ,@(when (third f)
+                                           `((funcall
+                                              (ps:getprop __labels ,(third f)))))))))
+           (jump (str "__nil"))))))
+
+(ps:defpsmacro exit ()
+  `(throw :exit))
+
+;;; 10dynamic
+
+(ps:defpsmacro qspblock (&body body)
+  `(lambda ()
+     (defvar __labels)
+     ,@body
+     (values)))
+
+;;; 11main
+
+(ps:defpsmacro act (name &body body)
+  `(api-call add-act ,name (lambda ()
+                             (big-block
+                               (tagbody
+                                  ,@body)))))
+
+;;; 12aux
+
+;;; 13diag
+
+;;; 14act
+
+;;; 15objs
+
+;;; 16menu
+
+;;; 17sound
+
+;;; 18img
+
+;;; 19input
+
+;;; 20time

src/writer.lisp

@@ -0,0 +1,9 b''
+
+(in-package sugar-qsp)
+
+;;; 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))

sugar-qsp.asd

@@ -0,0 +1,10 b''
+
+(defsystem sugar-qsp
+  :description "QSP compiler to monolithic HTML page"
+  :depends-on (:alexandria :esrap :parenscript :cl-uglify-js)
+  :pathname "src/"
+  :serial t
+  :components ((:file "package")
+               (:file "main")
+               (:file "ps-macros")
+               (:file "parser")))

update-deps.lisp

@@ -0,0 +1,3 b''
+(ql:quickload :qlot)
+(asdf:load-system :qlot/cli)
+(qlot/cli:update)

README.md

@@ -1,2 +1,44 b''
+(Russian readme below)
 # sugar-qsp
 Compiler for QSP games which creates monolithic HTML pages.
+
+## Usage
+
+There are three mastery levels
+
+1. Just build me the game:
+
+`sugar-qsp game.txt`
+And it will create the game in game.html
+
+2. I know what I'm doing:
+`sugar-qsp game.txt -o game.html --body body.html --js jquery.js my-js-library.js --css styles/*.css`
+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!
+`sugar-qsp game.txt -c -o game.js`
+It just builds the game script into a js you can put on your website. To run
+the game execute `SugarQSP.start()`
+
+# sugar-qsp
+Компилятор для игр на QSP создающий монолитные страницы на HTML.
+
+## Инструкции
+
+Есть три уровня мастерства.
+
+1. Просто собери мне игру:
+`sugar-qsp game.txt`
+Создаст игру в game.html
+
+2. Я знаю что делаю:
+`sugar-qsp game.txt -o game.html --body body.html --js jquery.js my-js-library.js --css styles/*.css`
+Если вы знаете что делаете, то для вас смысл опций очевиден. `body.html`
+по-умолчанию лежит в каталоге `extras`.
+
+3. Я - фронтендер!
+`sugar-qsp game.txt -c -o game.js`
+Просто соберёт игру в Javascript файл который вы можете разместить на своём
+сайте как вам угодно. Для запуска игры вызовите `SugarQSP.start()`.