Update copyright year

[jscl.git] / ecmalisp.lisp

diff --git a/ecmalisp.lisp b/ecmalisp.lisp
index f9535ea..c060ffb 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,6 +71,12 @@
  (defun null (x)
    (eq x nil))
 
+ (defmacro return (&optional value)
+   `(return-from nil ,value))
+
+ (defmacro while (condition &body body)
+   `(block nil (%while ,condition ,@body)))
+
  (defun internp (name)
    (in name *package*))
 
@@ -378,22 +384,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)))
@@ -510,7 +514,8 @@
     x)
 
   (defun print (x)
-    (write-line (print-to-string x))))
+    (write-line (print-to-string x))
+    x))
 
 
 ;;;; Reader
@@ -675,7 +680,7 @@
   (setcar (cdddr b) t))
 
 (defun make-lexenv ()
-  (list nil nil))
+  (list nil nil nil))
 
 (defun copy-lexenv (lexenv)
   (copy-list lexenv))
@@ -685,7 +690,9 @@
     (variable
      (setcar lexenv (cons binding (car lexenv))))
     (function
-     (setcar (cdr lexenv) (cons binding (cadr lexenv))))))
+     (setcar (cdr lexenv) (cons binding (cadr lexenv))))
+    (block
+     (setcar (cddr lexenv) (cons binding (caddr lexenv))))))
 
 (defun extend-lexenv (binding lexenv namespace)
   (let ((env (copy-lexenv lexenv)))
@@ -694,15 +701,16 @@
 
 (defun lookup-in-lexenv (name lexenv namespace)
   (assoc name (ecase namespace
-                (variable (car lexenv))
-                (function (cadr lexenv)))))
+                (variable (first lexenv))
+                (function (second lexenv))
+                (block (third lexenv)))))
 
 (defvar *environment* (make-lexenv))
 
 (defun clear-undeclared-global-bindings ()
   (let ((variables (first *environment*))
         (functions (second *environment*)))
-    (list variables functions)))
+    (setq *environment* (list variables functions (third *environment*)))))
 
 
 (defvar *variable-counter* 0)
@@ -926,14 +934,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
@@ -975,6 +982,36 @@
                             ",")
                 ")")))))
 
+
+(defvar *block-counter* 0)
+
+(define-compilation block (name &rest body)
+  (let ((tr (integer-to-string (incf *block-counter*))))
+    (let ((b (make-binding name 'block tr t)))
+      (concat "(function(){" *newline*
+              (indent "try {" *newline*
+                      (indent "return " (ls-compile `(progn ,@body)
+                                                    (extend-lexenv b env 'block))) ";" *newline*
+                      "}" *newline*
+                      "catch (cf){" *newline*
+                      "    if (cf.type == 'block' && cf.id == " tr ")" *newline*
+                      "        return cf.value;" *newline*
+                      "    else" *newline*
+                      "        throw cf;" *newline*
+                      "}" *newline*)
+              "})()"))))
+
+(define-compilation return-from (name &optional value)
+  (let ((b (lookup-in-lexenv name env 'block)))
+    (if b
+        (concat "(function(){ throw ({"
+                "type: 'block', "
+                "id: " (binding-translation b) ", "
+                "value: " (ls-compile value env) ", "
+                "message: 'Return from unknown block " (symbol-name name) ".'"
+                "})})()")
+        (error (concat "Unknown block `" (symbol-name name) "'.")))))
+
 ;;; A little backquote implementation without optimizations of any
 ;;; kind for ecmalisp.
 (defun backquote-expand-1 (form)
@@ -1284,7 +1321,8 @@
                    (setq *variable-counter* ',*variable-counter*)
                    (setq *function-counter* ',*function-counter*)
                    (setq *literal-counter* ',*literal-counter*)
-                   (setq *gensym-counter* ',*gensym-counter*)))))
+                   (setq *gensym-counter* ',*gensym-counter*)
+                   (setq *block-counter* ',*block-counter*)))))
       (setq *toplevel-compilations*
             (append *toplevel-compilations* (list tmp)))))
 
@@ -1333,5 +1371,6 @@
     (setq *variable-counter* 0
           *gensym-counter* 0
           *function-counter* 0
-          *literal-counter* 0)
+          *literal-counter* 0
+          *block-counter* 0)
     (ls-compile-file "ecmalisp.lisp" "ecmalisp.js")))