git » jacl.git » commit d5bc345

diff --git a/boot.lisp b/boot.lisp
index 27db87d..140bb28 100644
--- a/boot.lisp
+++ b/boot.lisp
@@ -161,7 +161,7 @@
 
 (%export 'symbolp)
 (defun symbolp (x)
-  (jacl:%js "~{} instanceof LispSymbol ? true : null" x))
+  (jacl:%js "(~{} === null || ~{} instanceof LispSymbol) ? true : null" x x))
 
 (%export 'consp)
 (defun consp (x)
@@ -383,6 +383,42 @@
      end)
     ret))
 
+(%export 'symbol-name)
+(defun symbol-name (symbol)
+  (when (not (symbolp symbol))
+    (%type-error "symbol"))
+  (if (null symbol)
+      "NIL"
+      (\. symbol |name|)))
+
+(defun %internal-name (prefix-string name)
+  (\.
+   (%js "Package")
+   (|get| (\. "JACL" (|toString|)))
+   (|intern| (%js "('INTERNAL-' + ~{}.toString() + '-' + ~{})"
+                  prefix-string
+                  (symbol-name name)))))
+
+(%export 'return-from)
+(defmacro return-from (block-name expr)
+  (let ((vname# (%internal-name "BLOCK-VALUE" block-name))
+        (labelname# (%internal-name "BLOCK-LABEL" block-name)))
+    `(progn (setq ,vname# ,expr)
+            (go ,labelname#))))
+
+(%export 'return)
+(defmacro return (expr)
+  `(return-from nil ,expr))
+
+(%export 'block)
+(defmacro block (block-name &body forms)
+  (let ((vname# (%internal-name "BLOCK-VALUE" block-name))
+        (labelname# (%internal-name "BLOCK-LABEL" block-name)))
+    `(let ((,vname# nil))
+       (tagbody (setq ,vname# (progn ,@forms))
+                ,labelname#)
+       ,vname#)))
+
 (%export 'dolist)
 (defmacro dolist (binding &rest body)
   (let ((var (car binding))
@@ -390,18 +426,19 @@
         (result-form (caddr binding))
         (begin# (gensym "begin"))
         (end# (gensym "end")))
-    `(let ((,var nil)
-           (,list# ,(cadr binding)))
-       (tagbody
-        ,begin#
-        (if (null ,list#) (go ,end#))
-        (setq ,var (car ,list#))
-        ,@body
-        (setq ,list# (cdr ,list#))
-        (go ,begin#)
-        ,end#)
-       (setq ,var nil)
-       ,result-form)))
+    `(block nil
+       (let ((,var nil)
+             (,list# ,(cadr binding)))
+         (tagbody
+          ,begin#
+          (if (null ,list#) (go ,end#))
+          (setq ,var (car ,list#))
+          ,@body
+          (setq ,list# (cdr ,list#))
+          (go ,begin#)
+          ,end#)
+         (setq ,var nil)
+         ,result-form))))
 
 ;; designators