git » jacl.git » commit 60054bb

diff --git a/boot.lisp b/boot.lisp
index d913cbd..ae00408 100644
--- a/boot.lisp
+++ b/boot.lisp
@@ -404,18 +404,38 @@
        (setq ,var nil)
        ,result-form)))
 
-;; (%debug 1 2 3 "foo" 'bar)
-
-;;(defun %designated-string (x)
-;;  (cond ((stringp x) x)
-;;        ((symbolp x)
-;;         (jacl:\. (jacl:%js "LispString") (|fromString| (jacl:\. x |name|))))
-;;        (t (%type-error "string or symbol"))))
-;;
-;;(defun %designated-symbols (x)
-;;  (cond ((symbolp x) (list x))
-;;        ((listp x) x)
-;;        (t (%type-error "symbol or list of symbols"))))
+;; designators
+
+(%export 'string=)
+(defun string= (string1 string2 &key start1 end1 start2 end2)
+  (when (or (not (stringp string1))
+            (not (stringp string2)))
+    (%type-error "string"))
+  (dolist (x (list start1 end1 start2 end2))
+    (when (and x (not (numberp x)))
+      (%type-error "number")))
+  ;; TODO DO would be good here
+  (let ((start1 (or start1 0))
+        (end1 (or end1 (1- (\. string1 |length|))))
+        (start2 (or start2 0))
+        (end2 (or end2 (1- (\. string2 |length|)))))
+    (%js "for (let i = ~{}, j = ~{}; i < ~{} && j < ~{}; i++, j++) {
+      if (~{}[i] !== ~{}[j]) return null;
+    }" start1 start2 end1 end2 string1 string2)
+    t))
+
+(defun %designated-string (x)
+  (cond ((stringp x) x)
+        ((symbolp x)
+         (\. (%js "LispString") (|fromString| (\. x |name|))))
+        (t (%type-error "string or symbol"))))
+
+(defun %designated-symbols (x &aux (err "symbol or list of symbols"))
+  (cond ((symbolp x) (list x))
+        ((listp x) (dolist (obj x x)
+                     (when (not (symbolp obj))
+                       (%type-error err))))
+        (t (%type-error err))))
 ;;
 ;;(%export 'let*)
 ;;(defmacro let* (bindings &rest body)
diff --git a/jacl-tests.lisp b/jacl-tests.lisp
index f9605a2..6292810 100644
--- a/jacl-tests.lisp
+++ b/jacl-tests.lisp
@@ -54,6 +54,9 @@
   (declare (ignore objects))
   (\. @|console| |log| (|apply| nil @|arguments|)))
 
+(defun start-tests ()
+  (\. @|QUnit| (|start|)))
+
 ;; Tests
 
 (in-module "Reader")
@@ -83,6 +86,14 @@
     (let ((sym '|Alan|))
       (assert= (\. sym |name|) @"Alan"))))
 
+(in-module "Internal")
+
+(deftest "Designators"
+  (with-label "string"
+    (dolist (obj '("a designator" |a designator|))
+      (assert= t (string= (cl::%designated-string obj)
+                          "a designator")))))
+
 (in-module "Numerics")
 
 (deftest "Numeric functions"
@@ -119,117 +130,118 @@
   (assert= (- 100 10 3 1) 86)
   (assert-throws (-))
   (assert-throws (- 'foo))
-  (assert-throws (- 1 'bar))
-  )
-
-(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))))
+  (assert-throws (- 1 'bar)))
+
+(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)