Add: DEFPARAMETER

[jscl.git] / ecmalisp.lisp

diff --git a/ecmalisp.lisp b/ecmalisp.lisp
index cd831bf..6c173b9 100644 (file)
--- a/ecmalisp.lisp
+++ b/ecmalisp.lisp
@@ -24,8 +24,6 @@
 
 #+ecmalisp
 (progn
-
-  'defmacro
   (eval-when-compile
     (%compile-defmacro 'defmacro
                        '(lambda (name args &rest body)
@@ -40,8 +38,23 @@
                                                    ,@body)))
                             ',name))))
 
+  (setq nil 'nil)
+  (setq t 't)
+
+  (defmacro when (condition &body body)
+    `(if ,condition (progn ,@body) nil))
+
+  (defmacro unless (condition &body body)
+    `(if ,condition nil (progn ,@body)))
+
   (defmacro defvar (name value)
     `(progn
+       (unless (boundp ',name)
+        (setq ,name ,value))
+       ',name))
+
+  (defmacro defparameter (name value)
+    `(progn
        (setq ,name ,value)
        ',name))
 
@@ -59,9 +72,6 @@
 
   (defvar *package* (new))
 
-  (defvar nil 'nil)
-  (defvar t 't)
-
   (defun null (x)
     (eq x nil))
 
@@ -133,12 +143,6 @@
   (defmacro push (x place)
     `(setq ,place (cons ,x ,place)))
 
-  (defmacro when (condition &body body)
-    `(if ,condition (progn ,@body) nil))
-
-  (defmacro unless (condition &body body)
-    `(if ,condition nil (progn ,@body)))
-
   (defmacro dolist (iter &body body)
     (let ((var (first iter))
           (g!list (gensym)))
@@ -416,7 +420,20 @@
     (car alist))
 
   (defun string= (s1 s2)
-    (equal s1 s2)))
+    (equal s1 s2))
+
+  (defun fdefinition (x)
+    (cond
+      ((functionp x)
+       x)
+      ((symbolp x)
+       (symbol-function x))
+      (t
+       (error "Invalid function"))))
+
+  (defun disassemble (function)
+    (write-line (lambda-code (fdefinition function)))
+    nil))
 
 
 ;;; The compiler offers some primitives and special forms which are
@@ -798,6 +815,7 @@
   (reverse (remove-if #'null-or-empty-p *toplevel-compilations*)))
 
 (defun %compile-defmacro (name lambda)
+  (toplevel-compilation (ls-compile `',name))
   (push-to-lexenv (make-binding name 'macro lambda t) *environment* 'function))
 
 (defvar *compilations* nil)
@@ -955,18 +973,13 @@
     ((integerp sexp) (integer-to-string sexp))
     ((stringp sexp) (concat "\"" (escape-string sexp) "\""))
     ((symbolp sexp)
-     #+common-lisp
      (or (cdr (assoc sexp *literal-symbols*))
         (let ((v (genlit))
-              (s (concat "{name: \"" (escape-string (symbol-name sexp)) "\"}")))
+              (s #+common-lisp (concat "{name: \"" (escape-string (symbol-name sexp)) "\"}")
+                 #+ecmalisp (ls-compile `(intern ,(symbol-name sexp)))))
           (push (cons sexp v) *literal-symbols*)
           (toplevel-compilation (concat "var " v " = " s))
-          v))
-     #+ecmalisp
-     (let ((v (genlit))
-           (s (ls-compile `(intern ,(symbol-name sexp)))))
-       (toplevel-compilation (concat "var " v " = " s))
-       v))
+          v)))
     ((consp sexp)
      (let ((c (concat "{car: " (literal (car sexp) t) ", "
                      "cdr: " (literal (cdr sexp) t) "}")))
@@ -1206,9 +1219,10 @@
 ;;; Primitives
 
 (defmacro define-builtin (name args &body body)
-  `(define-compilation ,name ,args
-     (let ,(mapcar (lambda (arg) `(,arg (ls-compile ,arg env))) args)
-       ,@body)))
+  `(progn
+     (define-compilation ,name ,args
+       (let ,(mapcar (lambda (arg) `(,arg (ls-compile ,arg env))) args)
+         ,@body))))
 
 ;;; DECLS is a list of (JSVARNAME TYPE LISPFORM) declarations.
 (defmacro type-check (decls &body body)
@@ -1296,10 +1310,13 @@
   (concat "(" x ").name"))
 
 (define-builtin set (symbol value)
-  (concat "(" symbol ").value =" value))
+  (concat "(" symbol ").value = " value))
 
 (define-builtin fset (symbol value)
-  (concat "(" symbol ").function =" value))
+  (concat "(" symbol ").function = " value))
+
+(define-builtin boundp (x)
+  (js!bool (concat "(" x ".value !== undefined)")))
 
 (define-builtin symbol-value (x)
   (js!selfcall
@@ -1315,6 +1332,13 @@
     "if (func === undefined) throw \"Function `\" + symbol.name + \"' is undefined.\";" *newline*
     "return func;" *newline*))
 
+(define-builtin symbol-plist (x)
+  (concat "((" x ").plist || " (ls-compile nil) ")"))
+
+(define-builtin lambda-code (x)
+  (concat "(" x ").toString()"))
+
+
 (define-builtin eq    (x y) (js!bool (concat "(" x " === " y ")")))
 (define-builtin equal (x y) (js!bool (concat "(" x  " == " y ")")))
 
@@ -1410,8 +1434,8 @@
 (defun macro (x)
   (and (symbolp x)
        (let ((b (lookup-in-lexenv x *environment* 'function)))
-         (eq (binding-type b) 'macro)
-         b)))
+         (and (eq (binding-type b) 'macro)
+              b))))
 
 (defun ls-macroexpand-1 (form)
   (let ((macro-binding (macro (car form))))
@@ -1420,19 +1444,10 @@
         form)))
 
 (defun compile-funcall (function args env)
-  (cond
-    ((symbolp function)
-     (concat (ls-compile `(quote ,function)) ".function("
-             (join (mapcar (lambda (x) (ls-compile x env)) args)
-                   ", ")
-             ")"))
-    ((and (listp function) (eq (car function) 'lambda))
-     (concat "(" (ls-compile function env) ")("
-             (join (mapcar (lambda (x) (ls-compile x env)) args)
-                   ", ")
-             ")"))
-    (t
-     (error (concat "Invalid function designator " (symbol-name function))))))
+  (concat (ls-compile `#',function) "("
+          (join (mapcar (lambda (x) (ls-compile x env)) args)
+                ", ")
+          ")"))
 
 (defun ls-compile (sexp &optional (env (make-lexenv)))
   (cond
@@ -1507,6 +1522,7 @@
                      `(oset *package* ,(symbol-name (car s))
                             (js-vref ,(cdr s))))
                    *literal-symbols*)
+         (setq *literal-symbols* ',*literal-symbols*)
          (setq *environment* ',*environment*)
          (setq *variable-counter* ,*variable-counter*)
          (setq *gensym-counter* ,*gensym-counter*)
@@ -1514,7 +1530,8 @@
 
   (eval-when-compile
     (toplevel-compilation
-     (ls-compile `(setq *literal-counter* ,*literal-counter*)))))
+     (ls-compile
+      `(setq *literal-counter* ,*literal-counter*)))))
 
 
 ;;; Finally, we provide a couple of functions to easily bootstrap