Benchmark, bugfixes, code walker

examples/bench.txt

@@ -0,0 +1,22 b''
+
+# start
+i = 0
+:loop
+if i < 10000000:
+  i += 1
+  if (i MOD 100000) = 0:
+    *p '.'
+  end
+  jump loop
+end
+looptime = MSECSCOUNT
+*nl 'JUMP: Выполнено за <<looptime>> миллисекунд'
+*nl
+for i = 0 to 10000000:
+  if (i MOD 100000) = 0:
+    *p '.'
+  end
+end
+fortime = MSECSCOUNT - looptime
+*nl 'FOR: Выполнено за <<fortime>> миллисекунд'
+-

src/walker.lisp

@@ -0,0 +1,19 b''
+
+(in-package code-walker)
+
+(defvar *transformers* (make-hash-table :test #'equal))
+
+(defmacro deftransform (transformer-name head args &body body)
+  `(progn
+     (setf (gethash (list ',transformer-name ',head) *transformers*)
+           (lambda ,args ,@body))
+     (list ',transformer-name ',head)))
+
+(defun walk (transformer-name form)
+  (if (listp form)
+      (let ((transformer (gethash (list transformer-name (first form))
+                                  *transformers*)))
+        (if transformer
+            (apply transformer (rest form))
+            (mapcar (lambda (subform) (walk transformer-name subform)) form)))
+      form))

TODO

@@ -1,4 +1,5 b''
 
+* Optimize variables
 * CLI build for Linux
 * CLI build for Windows
 

src/api.ps

@@ -93,14 +93,18 b''
 (defun clear-id (id)
   (setf (inner-html (by-id id)) ""))
 
-(defvar text-escaper (chain document (create-element :textarea)))
+(defun escape-html (text)
+  (chain text
+         (replace (regex "/&/g") "&")
+         (replace (regex "/</g") "&lt;")
+         (replace (regex "/>/g") "&gt;")
+         (replace (regex "/\"/g") "&quot;")
+         (replace (regex "/'/g") "&apos;")))
 
 (defun prepare-contents (s &optional force-html)
   (if (or force-html (get-var "USEHTML" 0 :num))
       s
-      (progn
-        (setf (@ text-escaper text-content) s)
-        (inner-html text-escaper))))
+      (escape-html s)))
 
 (defun get-id (id &optional force-html)
   (inner-html (by-id id)))
@@ -207,7 +211,7 b''
        ((< i to))
        ((incf i step))
        (set-var name index :num i)
-       (unless (funcall body)
+       (unless (await (funcall body))
          (return-from qspfor))))
 
 ;;; Variable class

src/package.lisp

@@ -79,6 +79,15 b''
            #: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_")
+
+(defpackage :code-walker
+  (:use :cl)
+  (:export #:deftransform
+           #:walk))
+
 ;;; The compiler
 (defpackage :sugar-qsp
   (:use :cl)
@@ -88,6 +97,3 b''
                     (#:main :sugar-qsp.main))
   (:export #:parse-file #:entry-point))
 
-(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_")

src/parser.lisp

@@ -589,11 +589,11 b''
 ;;; Variables
 
 (p:defrule variable (and identifier (p:? array-index))
-  (:destructure (id idx)
-    (let ((idx (case idx
-                 (nil 0)
+  (:destructure (id idx-raw)
+    (let ((idx (case idx-raw
+                 ((nil) 0)
                  (:last nil)
-                 (t idx))))
+                 (t idx-raw))))
       (if (char= #\$ (elt (string id) 0))
           (list 'lib:qspvar (intern (subseq (string-upcase id) 1) :lib) idx :str)
           (list 'lib:qspvar id idx :num)))))

src/ps-macros.lisp

@@ -13,7 +13,7 b''
   (let ((has-labels (some #'keywordp body)))
     `(block nil
        ,@(when has-labels
-           '((defvar _labels)))
+           '((var _labels (list))))
        (tagbody
           ,@body
           (void)))))
@@ -97,8 +97,7 b''
 ;;; Yep, that's a huge kludge since Javascript doesn't support arbitrary labels
 
 (defpsmacro jump (target)
-  `(return-from label-body
-     (funcall (getprop _labels ,(string-upcase (second target))))))
+  `(return-from label-body ,(string-upcase (second target))))
 
 (defpsmacro tagbody (&body body)
   (let ((funcs (list nil "_nil")))
@@ -115,15 +114,23 b''
         `(progn
            ,@body)
         `(progn
-           (setf ,@(loop :for (label code . rest-labels) :on funcs :by #'cddr
-                      :append `((@ _labels ,label)
-                                (block label-body
-                                  (block ,(intern label)
-                                    ,@code
-                                    ,@(when rest-labels
-                                        `((funcall
-                                           (getprop _labels ,(first rest-labels))))))))))
-           (funcall (getprop _labels "_nil"))))))
+           (tagbody-blocks ,funcs)
+           (setf _nextblock :_nil)
+           (loop
+              :for _nextblock
+                := :_nil
+                :then (await (funcall (getprop _labels _nextblock)))
+              :while _nextblock)))))
+
+(defpsmacro tagbody-blocks (funcs)
+  `(setf ,@(loop :for (label code . rest-labels) :on funcs :by #'cddr
+              :append `((@ _labels ,label)
+                        (async-lambda ()
+                          (block label-body
+                            ,@code
+                            ,@(if rest-labels
+                                  (list (first rest-labels))
+                                  nil)))))))
 
 (defpsmacro exit ()
   '(return-from nil (values)))
@@ -172,10 +179,10 b''
 ;;; 22for
 
 (defpsmacro qspfor (var from to step &body body)
-  `((intern "QSPFOR" "API")
+  `(,(intern "QSPFOR" "API")
     ,(string (second var)) ,(third var) ;; name and index
     ,from ,to ,step
-    (lambda ()
+    (async-lambda ()
       (block nil
         ,@body
         t))))

sugar-qsp.asd

@@ -8,6 +8,7 b''
   :pathname "src/"
   :serial t
   :components ((:file "package")
+               (:file "walker")
                (:file "patches")
                (:file "js-syms")
                (:file "main-macros")