X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=ecmalisp.lisp;h=562f1f80aa5c829dbf2405022022295c87dde221;hb=25fa7dc525c432ea68bdae231748b279a2ab65ef;hp=77f337ff859833afff1468b368094abf6918a113;hpb=adaa2ca564b08d889f1909d4012284b39a056475;p=jscl.git

diff --git a/ecmalisp.lisp b/ecmalisp.lisp
index 77f337f..562f1f8 100644
--- a/ecmalisp.lisp
+++ b/ecmalisp.lisp
@@ -71,17 +71,13 @@
   (defmacro while (condition &body body)
     `(block nil (%while ,condition ,@body)))
 
-  (defun internp (name)
-    (in name *package*))
-
-  (defun intern (name)
-    (if (internp name)
-        (oget *package* name)
-        (oset *package* name (make-symbol name))))
-
   (defun find-symbol (name)
     (oget *package* name))
 
+  (defun intern (name)
+    (let ((s (find-symbol name)))
+      (if s s (oset *package* name (make-symbol name)))))
+
   (defvar *gensym-counter* 0)
   (defun gensym (&optional (prefix "G"))
     (setq *gensym-counter* (+ *gensym-counter* 1))
@@ -416,7 +412,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
@@ -955,18 +964,12 @@
     ((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)) "\"}")))
 	   (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 +1209,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)
@@ -1309,7 +1313,18 @@
     "return value;" *newline*))
 
 (define-builtin symbol-function (x)
-  (concat "(" x ").function"))
+  (js!selfcall
+    "var symbol = " x ";" *newline*
+    "var func = symbol.function;" *newline*
+    "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 ")")))
@@ -1406,8 +1421,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))))
@@ -1416,19 +1431,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
@@ -1503,15 +1509,16 @@
                      `(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 *function-counter* ,*function-counter*)
          (setq *gensym-counter* ,*gensym-counter*)
          (setq *block-counter* ,*block-counter*)))))
 
   (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
@@ -1545,7 +1552,6 @@
     (setq *literal-symbols* nil)
     (setq *variable-counter* 0
           *gensym-counter* 0
-          *function-counter* 0
           *literal-counter* 0
           *block-counter* 0)
     (ls-compile-file "ecmalisp.lisp" "ecmalisp.js")))