Implement CATCH and THROW

[jscl.git] / ecmalisp.lisp

diff --git a/ecmalisp.lisp b/ecmalisp.lisp
index a8eb572..ebfe885 100644 (file)
--- a/ecmalisp.lisp
+++ b/ecmalisp.lisp
@@ -1,6 +1,6 @@
 ;;; ecmalisp.lisp ---
 
-;; Copyright (C) 2012 David Vazquez
+;; Copyright (C) 2012, 2013 David Vazquez
 ;; Copyright (C) 2012 Raimon Grau
 
 ;; This program is free software: you can redistribute it and/or
@@ -55,7 +55,7 @@
        (eval-when-compile
          (%compile-defun ',name))
        (fsetq ,name (named-lambda ,(symbol-name name) ,args
-                      ,@body))))
+                      (block ,name ,@body)))))
 
   (defmacro defun (name args &rest body)
     `(%defun ,name ,args ,@body))
@@ -71,9 +71,12 @@
  (defun null (x)
    (eq x nil))
 
- (defmacro return (value)
+ (defmacro return (&optional value)
    `(return-from nil ,value))
 
+ (defmacro while (condition &body body)
+   `(block nil (%while ,condition ,@body)))
+
  (defun internp (name)
    (in name *package*))
 
@@ -145,25 +148,27 @@
  (defmacro dolist (iter &body body)
    (let ((var (first iter))
          (g!list (gensym)))
-     `(let ((,g!list ,(second iter))
-            (,var nil))
-        (while ,g!list
-          (setq ,var (car ,g!list))
-          ,@body
-          (setq ,g!list (cdr ,g!list)))
-        ,(third iter))))
+     `(block nil
+        (let ((,g!list ,(second iter))
+              (,var nil))
+          (%while ,g!list
+            (setq ,var (car ,g!list))
+            ,@body
+            (setq ,g!list (cdr ,g!list)))
+          ,(third iter)))))
 
  (defmacro dotimes (iter &body body)
    (let ((g!to (gensym))
          (var (first iter))
          (to (second iter))
          (result (third iter)))
-     `(let ((,var 0)
-            (,g!to ,to))
-        (while (< ,var ,g!to)
-          ,@body
-          (incf ,var))
-        ,result)))
+     `(block nil
+        (let ((,var 0)
+              (,g!to ,to))
+          (%while (< ,var ,g!to)
+                  ,@body
+                  (incf ,var))
+          ,result))))
 
  (defmacro cond (&rest clausules)
    (if (null clausules)
@@ -381,22 +386,20 @@
 
   (defun every (function seq)
     ;; string
-    (let ((ret t)
-          (index 0)
+    (let ((index 0)
           (size (length seq)))
-      (while (and ret (< index size))
+      (while (< index size)
         (unless (funcall function (char seq index))
-          (setq ret nil))
+          (return-from every nil))
         (incf index))
-      ret))
+      t))
 
   (defun assoc (x alist)
-    (let ((found nil))
-      (while (and alist (not found))
-        (if (eql x (caar alist))
-            (setq found t)
-            (setq alist (cdr alist))))
-      (car alist)))
+    (while alist
+      (if (eql x (caar alist))
+          (return)
+          (setq alist (cdr alist))))
+    (car alist))
 
   (defun string= (s1 s2)
     (equal s1 s2)))
@@ -933,14 +936,13 @@
 (define-compilation quote (sexp)
   (literal sexp))
 
-(define-compilation while (pred &rest body)
+(define-compilation %while (pred &rest body)
   (concat "(function(){" *newline*
-          (indent "while("
-                  (ls-compile pred env)
-                  " !== "
-                  (ls-compile nil) "){" *newline*
-                  (indent (ls-compile-block body env)))
-          "}})()"))
+          (indent "while(" (ls-compile pred env) " !== " (ls-compile nil) "){" *newline*
+                  (indent (ls-compile-block body env))
+                  "}"
+                  "return " (ls-compile nil) ";" *newline*)
+          "})()"))
 
 (define-compilation function (x)
   (cond
@@ -991,7 +993,8 @@
       (concat "(function(){" *newline*
               (indent "try {" *newline*
                       (indent "return " (ls-compile `(progn ,@body)
-                                                    (extend-lexenv b env 'block))) ";" *newline*
+                                                    (extend-lexenv b env 'block))
+                              ";" *newline*)
                       "}" *newline*
                       "catch (cf){" *newline*
                       "    if (cf.type == 'block' && cf.id == " tr ")" *newline*
@@ -999,7 +1002,7 @@
                       "    else" *newline*
                       "        throw cf;" *newline*
                       "}" *newline*)
-              "})()" *newline*))))
+              "})()"))))
 
 (define-compilation return-from (name &optional value)
   (let ((b (lookup-in-lexenv name env 'block)))
@@ -1012,6 +1015,31 @@
                 "})})()")
         (error (concat "Unknown block `" (symbol-name name) "'.")))))
 
+
+(define-compilation catch (id &rest body)
+  (concat "(function(){" *newline*
+          (indent "var id = " (ls-compile id env) ";" *newline*
+                  "try {" *newline*
+                  (indent "return " (ls-compile `(progn ,@body))
+                          ";" *newline*)
+                  "}" *newline*
+                  "catch (cf){" *newline*
+                  "    if (cf.type == 'catch' && cf.id == id)" *newline*
+                  "        return cf.value;" *newline*
+                  "    else" *newline*
+                  "        throw cf;" *newline*
+                  "}" *newline*)
+          "})()"))
+
+(define-compilation throw (id &optional value)
+  (concat "(function(){ throw ({"
+          "type: 'catch', "
+          "id: " (ls-compile id env) ", "
+          "value: " (ls-compile value env) ", "
+          "message: 'Throw uncatched.'"
+          "})})()"))
+
+
 ;;; A little backquote implementation without optimizations of any
 ;;; kind for ecmalisp.
 (defun backquote-expand-1 (form)