;;; 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
(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))
(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*))
(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)
(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)))
(setcar (cdddr b) t))
(defun make-lexenv ()
- (list nil nil))
+ (list nil nil nil))
(defun copy-lexenv (lexenv)
(copy-list lexenv))
(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)))
(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)
(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
",")
")")))))
+
+(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) "'.")))))
+
+
+(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)
(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)))))
(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")))