git » jacl.git » commit f36139e

diff --git a/boot.lisp b/boot.lisp
index 4e1350a..a5d6f5e 100644
--- a/boot.lisp
+++ b/boot.lisp
@@ -20,8 +20,10 @@
 ;;;; SOFTWARE.
 
 ;; in JACL package; use JACL from COMMON-LISP and switch to COMMON-LISP
+
+(%setq jacl-pkg cl:*package*)
 (%let ((cl-pkg (\. (%js "Package") (|get| (\. '#:common-lisp |name|)))))
-  (\. cl-pkg (|usePackage| cl:*package*))
+  (\. cl-pkg (|usePackage| jacl-pkg))
   (%setq cl:*package* cl-pkg))
 
 (%js "(~{}.fvalue = ~{})"
@@ -504,6 +506,24 @@
                      (when (not (symbolp obj))
                        (%type-error err))))
         (t (%type-error err))))
+
+(%export 'use-package)
+(defun use-package (packages-to-use &optional (package *package*))
+  ;; TODO Accepts more than one packages-to-use
+  (let* ((pkg (\. (%js "Package")
+                  (|get| (\. (%designated-string packages-to-use)
+                             (|toString|))))))
+    (\. package (|usePackage| pkg))))
+
+(setq *package* (\. (%js "Package") (|get| (\. '#:jacl |name|))))
+(\. cl:*package* (|usePackage| (\. (%js "Package") (|get| (\. '#:common-lisp |name|)))))
+
+(cl::%export 'fetch-load)
+(defun fetch-load (src &aux (src (\. src (|toString|))))
+  (%js "fetchLoad(~{})" src))
+
+(cl:setq cl:*package* (\. (%js "Package") (|get| (\. '#:common-lisp |name|))))
+
 ;;
 ;;(%export 'let*)
 ;;(defmacro let* (bindings &rest body)
diff --git a/favicon.ico b/favicon.ico
new file mode 100755
index 0000000..f1743be
Binary files /dev/null and b/favicon.ico differ
diff --git a/jacl-tests.lisp b/jacl-tests.lisp
index b147b55..b0baa7d 100644
--- a/jacl-tests.lisp
+++ b/jacl-tests.lisp
@@ -19,43 +19,11 @@
 ;;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
 ;;;; SOFTWARE.
 
-;; Test framework
-
 (jacl:enable-js-syntax)
 
-(let* ((jpkg (jacl:\. (jacl:%js "Package") (|get| @"JACL"))))
-  (jacl:\. *package* (|usePackage| jpkg)))
-
-(defvar *is*)
-(defvar *label* @"")
-
-(defun in-module (label)
-  (\. @|QUnit| (|module| (\. label (|toString|)))))
-
-(defmacro deftest (label &body body)
-  (let ((is# (gensym)))
-    `(\. @|QUnit| (|test| (\. ,label (|toString|))
-                   (lambda (,is#)
-                     (declare (jacl:async))
-                     (let ((*is* ,is#))
-                       ,@body))))))
-
-(defmacro with-label (label &body body)
-  `(let ((*label* (\. ,label (|toString|))))
-     ,@body))
-
-(defun assert= (x y &optional (label *label*))
-  (\. *is* (|strictEqual| x y label)))
-
-(defmacro assert-throws (&body body)
-  `(\. *is* (|throws| (lambda () ,@body) *label*)))
-
-(defun log (&rest objects)
-  (declare (ignore objects))
-  (\. @|console| |log| (|apply| nil @|arguments|)))
+(use-package '#:jacl)
 
-(defun start-tests ()
-  (\. @|QUnit| (|start|)))
+(fetch-load "test.lisp")
 
 ;; Tests
 
@@ -134,120 +102,120 @@
 
 (start-tests)
 
-;; (in-module "Control operators")
-
-;; (deftest "JACL:%IF and CL:IF"
-;;   (assert= (jacl:%if t 1) 1)
-;;   (assert= (jacl:%if nil 1 123) 123)
-;;   (assert= (jacl:%if nil 1) nil)
-;;   (assert= (if t 1) 1)
-;;   (assert= (if nil 1 123) 123)
-;;   (assert= (if nil 1) nil))
-
-;; (deftest "Local TAGBODY"
-;;   (let ((x 10)
-;;         (y 0))
-;;     (tagbody
-;;      begin
-;;      (when (> x 0)
-;;        (setq x (1- x) y (1+ y))
-;;        (go begin))
-;;      end)
-;;     (assert= x 0)
-;;     (assert= y 10)))
-
-;; (deftest "GO in TAGBODY prelude"
-;;   (let ((x 0))
-;;     (tagbody
-;;      (go end)
-;;      start                              ;skipped
-;;      (setq x (1+ x))                    ;skipped
-;;      end)
-;;     (assert= x 0)))
-
-;; (defun countdown (from)
-;;   (tagbody
-;;    start
-;;    (when (> from 0)
-;;      (setq from (1- from))
-;;      (go start))))
-
-;; (countdown 3)
-
-;; (in-module "Iteration operators")
-
-;; (deftest "CL:DOLIST"
-;;   (let ((sum 0)
-;;         (ones '(1 1 1)))
-;;     (dolist (x ones)
-;;       (setq sum (1+ sum)))
-;;     (assert= sum 3 "without result-form")
-;;     (setq sum 0)
-;;     (assert= (dolist (x ones sum)
-;;                (setq sum (1+ sum)))
-;;              3
-;;              "with result-form")
-;;     (setq sum 0)
-;;     (dolist (x ones)
-;;       start
-;;       (when (< x 2)
-;;         (setq x (1+ x))
-;;         (go start))
-;;       (setq sum (+ sum x)))
-;;     (assert= sum 6 "with tags in body")))
-
-;; (\. @|QUnit| (|start|))
-
-;; (in-module "Functions")
-
-;; (deftest "Named JACL:%LAMBDA"
-;;   (let* ((invocations 0)
-;;          (f (jacl:%lambda self nil (x y)
-;;                           (let ((self nil))
-;;                             (when (< x y)
-;;                               (setq invocations (1+ invocations))
-;;                               (self (1+ x) y))))))
-;;     (funcall f 0 10)
-;;     (assert= invocations 10)))
-
-;; (defun tak (x y z)
-;;   (if (not (< y x))
-;;       z
-;;     (tak
-;;      (tak (1- x) y z)
-;;      (tak (1- y) z x)
-;;      (tak (1- z) x y))))
-
-;; (defun now ()
-;;   (\. (%js "performance") (|now|)))
-
-;; ;; (defmacro with-profile (memo &rest body)
-;; ;;   (let ((memo# (gensym)))
-;; ;;     `(let ((,memo# (\. ,memo (|toString|))))
-;; ;;        (\. (%js "console") (|profile| ,memo#))
-;; ;;        (prog1 (progn ,@body)
-;; ;;          )
-;; ;;        )))
-
-;; (defmacro time (memo &body body)
-;;   (let ((start# (gensym))
-;;         (ret# (gensym)))
-;;     `(let ((,start# (progn
-;;                      (\. (%js "console") (|profile| ,memo))
-;;                      (now)))
-;;            (,ret# (progn ,@body)))
-;;        (\. @|console| (|profileEnd| ,memo))
-;;        (log ,memo (- (now) ,start#))
-;;        ,ret#)))
-
-;; (deftest "Recursion"
-;;   (assert= 7 (time @"tak" (tak 18 12 6))))
-
-;; Local Variables:
-;; eval: (put 'with-label 'lisp-indent-function 1)
-;; eval: (put 'with-read 'lisp-indent-function 1)
-;; End:
-
-(defun snoob (&rest rest &aux (x "snoob"))
-  (log x))
-(snoob)
+;; ;; (in-module "Control operators")
+
+;; ;; (deftest "JACL:%IF and CL:IF"
+;; ;;   (assert= (jacl:%if t 1) 1)
+;; ;;   (assert= (jacl:%if nil 1 123) 123)
+;; ;;   (assert= (jacl:%if nil 1) nil)
+;; ;;   (assert= (if t 1) 1)
+;; ;;   (assert= (if nil 1 123) 123)
+;; ;;   (assert= (if nil 1) nil))
+
+;; ;; (deftest "Local TAGBODY"
+;; ;;   (let ((x 10)
+;; ;;         (y 0))
+;; ;;     (tagbody
+;; ;;      begin
+;; ;;      (when (> x 0)
+;; ;;        (setq x (1- x) y (1+ y))
+;; ;;        (go begin))
+;; ;;      end)
+;; ;;     (assert= x 0)
+;; ;;     (assert= y 10)))
+
+;; ;; (deftest "GO in TAGBODY prelude"
+;; ;;   (let ((x 0))
+;; ;;     (tagbody
+;; ;;      (go end)
+;; ;;      start                              ;skipped
+;; ;;      (setq x (1+ x))                    ;skipped
+;; ;;      end)
+;; ;;     (assert= x 0)))
+
+;; ;; (defun countdown (from)
+;; ;;   (tagbody
+;; ;;    start
+;; ;;    (when (> from 0)
+;; ;;      (setq from (1- from))
+;; ;;      (go start))))
+
+;; ;; (countdown 3)
+
+;; ;; (in-module "Iteration operators")
+
+;; ;; (deftest "CL:DOLIST"
+;; ;;   (let ((sum 0)
+;; ;;         (ones '(1 1 1)))
+;; ;;     (dolist (x ones)
+;; ;;       (setq sum (1+ sum)))
+;; ;;     (assert= sum 3 "without result-form")
+;; ;;     (setq sum 0)
+;; ;;     (assert= (dolist (x ones sum)
+;; ;;                (setq sum (1+ sum)))
+;; ;;              3
+;; ;;              "with result-form")
+;; ;;     (setq sum 0)
+;; ;;     (dolist (x ones)
+;; ;;       start
+;; ;;       (when (< x 2)
+;; ;;         (setq x (1+ x))
+;; ;;         (go start))
+;; ;;       (setq sum (+ sum x)))
+;; ;;     (assert= sum 6 "with tags in body")))
+
+;; ;; (\. @|QUnit| (|start|))
+
+;; ;; (in-module "Functions")
+
+;; ;; (deftest "Named JACL:%LAMBDA"
+;; ;;   (let* ((invocations 0)
+;; ;;          (f (jacl:%lambda self nil (x y)
+;; ;;                           (let ((self nil))
+;; ;;                             (when (< x y)
+;; ;;                               (setq invocations (1+ invocations))
+;; ;;                               (self (1+ x) y))))))
+;; ;;     (funcall f 0 10)
+;; ;;     (assert= invocations 10)))
+
+;; ;; (defun tak (x y z)
+;; ;;   (if (not (< y x))
+;; ;;       z
+;; ;;     (tak
+;; ;;      (tak (1- x) y z)
+;; ;;      (tak (1- y) z x)
+;; ;;      (tak (1- z) x y))))
+
+;; ;; (defun now ()
+;; ;;   (\. (%js "performance") (|now|)))
+
+;; ;; ;; (defmacro with-profile (memo &rest body)
+;; ;; ;;   (let ((memo# (gensym)))
+;; ;; ;;     `(let ((,memo# (\. ,memo (|toString|))))
+;; ;; ;;        (\. (%js "console") (|profile| ,memo#))
+;; ;; ;;        (prog1 (progn ,@body)
+;; ;; ;;          )
+;; ;; ;;        )))
+
+;; ;; (defmacro time (memo &body body)
+;; ;;   (let ((start# (gensym))
+;; ;;         (ret# (gensym)))
+;; ;;     `(let ((,start# (progn
+;; ;;                      (\. (%js "console") (|profile| ,memo))
+;; ;;                      (now)))
+;; ;;            (,ret# (progn ,@body)))
+;; ;;        (\. @|console| (|profileEnd| ,memo))
+;; ;;        (log ,memo (- (now) ,start#))
+;; ;;        ,ret#)))
+
+;; ;; (deftest "Recursion"
+;; ;;   (assert= 7 (time @"tak" (tak 18 12 6))))
+
+;; ;; Local Variables:
+;; ;; eval: (put 'with-label 'lisp-indent-function 1)
+;; ;; eval: (put 'with-read 'lisp-indent-function 1)
+;; ;; End:
+
+;; (defun snoob (&rest rest &aux (x "snoob"))
+;;   (log x))
+;; (snoob)
diff --git a/jacl.js b/jacl.js
index 6ac96a9..83e02b6 100644
--- a/jacl.js
+++ b/jacl.js
@@ -2365,37 +2365,35 @@ const startRepl = async () => {
   }
 };
 
+const fetchLoad = async (src) => {
+  const code = await (await fetch(src, {cache: "reload"})).text(),
+        ss = new StringStream(code),
+        rdr = new Reader(ss);
+  for await(const obj of rdr) {
+    if (obj === EOF) break;
+    const node = optimize(analyze(emptyEnv.withContext('return'), null, obj)),
+          sb = new StringBuffer();
+    emitNode(sb.append.bind(sb), node);
+    await (new Function(sb.toString())());
+  }
+};
+
 const loadLispScripts = async () => {
-  let urlParams = new URLSearchParams(window.location.search),
-      deliverAs = urlParams.get("deliver"),
-      compiledCode = "";
+  let urlParams = new URLSearchParams(window.location.search);
   for (let i = 0; i < document.head.childNodes.length; i++) {
     const child = document.head.childNodes[i];
     if (child.nodeName === 'SCRIPT' && child.src.endsWith('.lisp')) {
-      const code = await (await fetch(child.src, {cache: "reload"})).text();
       const start = new Date();
-      const ss = new StringStream(code);
-      const rdr = new Reader(ss);
-      for await(const obj of rdr) {
-        if (obj === EOF) break;
-        const node = optimize(analyze(emptyEnv.withContext('stmt'), null, obj));
-        const sb = new StringBuffer();
-        emitNode(sb.append.bind(sb), node);
-        if (deliverAs !== null) {
-          compiledCode += `\n${sb.toString()}`;
-        }
-        // console.log(sb.toString());
-        eval(sb.toString());
-      }
+      await fetchLoad(child.src);
       console.log(`;Loaded ${child.src} in ${(new Date())-start} ms`);
     }
   }
-  if (deliverAs !== null) {
-    let selfsrc = document.querySelector('script[data-name="jacl"]').src,
-        prelude = await (await fetch(selfsrc, {cache: "reload"})).text(),
-        file = new File([prelude + '\n' + compiledCode], deliverAs || "app.js", {type: "application/javascript;charset=utf-8"});
-    saveAs(file);
-  }
+  // if (deliverAs !== null) {
+  //   let selfsrc = document.querySelector('script[data-name="jacl"]').src,
+  //       prelude = await (await fetch(selfsrc, {cache: "reload"})).text(),
+  //       file = new File([prelude + '\n' + compiledCode], deliverAs || "app.js", {type: "application/javascript;charset=utf-8"});
+  //   saveAs(file);
+  // }
 
 };
 
diff --git a/test.lisp b/test.lisp
new file mode 100644
index 0000000..4795397
--- /dev/null
+++ b/test.lisp
@@ -0,0 +1,53 @@
+;;;; Copyright (c) 2020 Alan Dipert <alan@dipert.org>
+;;;; Part of the JACL project: https://tailrecursion.com/JACL/
+;;;;
+;;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;;; of this software and associated documentation files (the "Software"), to deal
+;;;; in the Software without restriction, including without limitation the rights
+;;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;;; copies of the Software, and to permit persons to whom the Software is
+;;;; furnished to do so, subject to the following conditions:
+;;;;
+;;;; The above copyright notice and this permission notice shall be included in all
+;;;; copies or substantial portions of the Software.
+;;;;
+;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+;;;; SOFTWARE.
+
+;; Test framework
+
+(defvar *is*)
+(defvar *label* @"")
+
+(defun in-module (label)
+  (\. @|QUnit| (|module| (\. label (|toString|)))))
+
+(defmacro deftest (label &body body)
+  (let ((is# (gensym)))
+    `(\. @|QUnit| (|test| (\. ,label (|toString|))
+                   (lambda (,is#)
+                     (declare (jacl:async))
+                     (let ((*is* ,is#))
+                       ,@body))))))
+
+(defmacro with-label (label &body body)
+  `(let ((*label* (\. ,label (|toString|))))
+     ,@body))
+
+(defun assert= (x y &optional (label *label*))
+  (\. *is* (|strictEqual| x y label)))
+
+(defmacro assert-throws (&body body)
+  `(\. *is* (|throws| (lambda () ,@body) *label*)))
+
+(defun log (&rest objects)
+  (declare (ignore objects))
+  (\. @|console| |log| (|apply| nil @|arguments|)))
+
+(defun start-tests ()
+  (\. @|QUnit| (|start|)))