Compile support for keywords

[jscl.git] / ecmalisp.lisp

diff --git a/ecmalisp.lisp b/ecmalisp.lisp
index 5ae918f..8cb2b9f 100644 (file)
--- a/ecmalisp.lisp
+++ b/ecmalisp.lisp
@@ -27,17 +27,20 @@
   (eval-when-compile
     (%compile-defmacro 'defmacro
                        '(lambda (name args &rest body)
   (eval-when-compile
     (%compile-defmacro 'defmacro
                        '(lambda (name args &rest body)

-                         `(progn
-                            (eval-when-compile
-                              (%compile-defmacro ',name
-                                                 '(lambda ,(mapcar (lambda (x)
-                                                                     (if (eq x '&body)
-                                                                         '&rest
-                                                                         x))
-                                                                   args)
-                                                   ,@body)))
-                            ',name))))
-
+                         `(eval-when-compile
+                            (%compile-defmacro ',name
+                                               '(lambda ,(mapcar (lambda (x)
+                                                                   (if (eq x '&body)
+                                                                       '&rest
+                                                                       x))
+                                                                 args)
+                                                 ,@body))))))
+
+  (defmacro declaim (&rest decls)
+    `(eval-when-compile
+       ,@(mapcar (lambda (decl) `(!proclaim ',decl)) decls)))
+
+  (declaim (constant nil t))

   (setq nil 'nil)
   (setq t 't)
 
   (setq nil 'nil)
   (setq t 't)
 

@@ -47,15 +50,16 @@
   (defmacro unless (condition &body body)
     `(if ,condition nil (progn ,@body)))
 
   (defmacro unless (condition &body body)
     `(if ,condition nil (progn ,@body)))
 

-  (defmacro defvar (name value)
+  (defmacro defvar (name value &optional docstring)

     `(progn
     `(progn

-       (unless (boundp ',name)
-        (setq ,name ,value))
+       (unless (boundp ',name) (setq ,name ,value))
+       ,@(when (stringp docstring) `((oset ',name "vardoc" ,docstring)))

        ',name))
 
        ',name))
 

-  (defmacro defparameter (name value)
+  (defmacro defparameter (name value &optional docstring)

     `(progn
        (setq ,name ,value)
     `(progn
        (setq ,name ,value)

+       ,@(when (stringp docstring) `((oset ',name "vardoc" ,docstring)))

        ',name))
 
   (defmacro named-lambda (name args &rest body)
        ',name))
 
   (defmacro named-lambda (name args &rest body)

@@ -66,14 +70,14 @@
 
   (defmacro defun (name args &rest body)
     `(progn
 
   (defmacro defun (name args &rest body)
     `(progn

+       (declaim (non-overridable ,name))

        (fset ',name
        (fset ',name

-             (named-lambda ,(symbol-name name)
-                 ,args
-               (block ,name ,@body)))
+             (named-lambda ,(symbol-name name) ,args
+               ,@(if (and (stringp (car body)) (not (null (cdr body))))
+                     `(,(car body) (block ,name ,@(cdr body)))
+                     `((block ,name ,@body)))))

        ',name))
 
        ',name))
 

-  (defvar *package* (new))
-

   (defun null (x)
     (eq x nil))
 
   (defun null (x)
     (eq x nil))
 

@@ -83,17 +87,6 @@
   (defmacro while (condition &body body)
     `(block nil (%while ,condition ,@body)))
 
   (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))
-

   (defvar *gensym-counter* 0)
   (defun gensym (&optional (prefix "G"))
     (setq *gensym-counter* (+ *gensym-counter* 1))
   (defvar *gensym-counter* 0)
   (defun gensym (&optional (prefix "G"))
     (setq *gensym-counter* (+ *gensym-counter* 1))

@@ -119,7 +112,11 @@
 
   (defun cons (x y ) (cons x y))
   (defun consp (x) (consp x))
 
   (defun cons (x y ) (cons x y))
   (defun consp (x) (consp x))

-  (defun car (x) (car x))
+
+  (defun car (x)
+    "Return the CAR part of a cons, or NIL if X is null."
+    (car x))
+

   (defun cdr (x) (cdr x))
   (defun caar (x) (car (car x)))
   (defun cadr (x) (car (cdr x)))
   (defun cdr (x) (cdr x))
   (defun caar (x) (car (car x)))
   (defun cadr (x) (car (cdr x)))

@@ -232,7 +229,6 @@
     `(prog1 (progn ,form1 ,result) ,@body)))
 
 
     `(prog1 (progn ,form1 ,result) ,@body)))
 
 

-

 ;;; This couple of helper functions will be defined in both Common
 ;;; Lisp and in Ecmalisp.
 (defun ensure-list (x)
 ;;; This couple of helper functions will be defined in both Common
 ;;; Lisp and in Ecmalisp.
 (defun ensure-list (x)

@@ -424,6 +420,11 @@
           (setq alist (cdr alist))))
     (car alist))
 
           (setq alist (cdr alist))))
     (car alist))
 

+  (defun string (x)
+    (cond ((stringp x) x)
+          ((symbolp x) (symbol-name x))
+          (t (char-to-string x))))
+

   (defun string= (s1 s2)
     (equal s1 s2))
 
   (defun string= (s1 s2)
     (equal s1 s2))
 

@@ -438,7 +439,129 @@
 
   (defun disassemble (function)
     (write-line (lambda-code (fdefinition function)))
 
   (defun disassemble (function)
     (write-line (lambda-code (fdefinition function)))

-    nil))
+    nil)
+
+  (defun documentation (x type)
+    "Return the documentation of X. TYPE must be the symbol VARIABLE or FUNCTION."
+    (ecase type
+      (function
+       (let ((func (fdefinition x)))
+         (oget func "docstring")))
+      (variable
+       (unless (symbolp x)
+         (error "Wrong argument type! it should be a symbol"))
+       (oget x "vardoc"))))
+
+  ;; Packages
+
+  (defvar *package-list* nil)
+
+  (defun list-all-packages ()
+    *package-list*)
+
+  (defun make-package (name &optional use)
+    (let ((package (new))
+          (use (mapcar #'find-package-or-fail use)))
+      (oset package "packageName" name)
+      (oset package "symbols" (new))
+      (oset package "exports" (new))
+      (oset package "use" use)
+      (push package *package-list*)
+      package))
+
+  (defun packagep (x)
+    (and (objectp x) (in "symbols" x)))
+
+  (defun find-package (package-designator)
+    (when (packagep package-designator)
+      (return-from find-package package-designator))
+    (let ((name (string package-designator)))
+      (dolist (package *package-list*)
+        (when (string= (package-name package) name)
+          (return package)))))
+
+  (defun find-package-or-fail (package-designator)
+    (or (find-package package-designator)
+        (error "Package unknown.")))
+
+  (defun package-name (package-designator)
+    (let ((package (find-package-or-fail package-designator)))
+      (oget package "packageName")))
+
+  (defun %package-symbols (package-designator)
+    (let ((package (find-package-or-fail package-designator)))
+      (oget package "symbols")))
+
+  (defun package-use-list (package-designator)
+    (let ((package (find-package-or-fail package-designator)))
+      (oget package "use")))
+
+  (defun %package-external-symbols (package-designator)
+    (let ((package (find-package-or-fail package-designator)))
+      (oget package "exports")))
+
+  (defvar *common-lisp-package*
+    (make-package "CL"))
+
+  (defvar *user-package*
+    (make-package "CL-USER" (list *common-lisp-package*)))
+
+  (defvar *keyword-package*
+    (make-package "KEYWORD"))
+
+  (defun keywordp (x)
+    (and (symbolp x) (eq (symbol-package x) *keyword-package*)))
+
+  (defvar *package* *common-lisp-package*)
+
+  (defmacro in-package (package-designator)
+    `(eval-when-compile
+       (setq *package* (find-package-or-fail ,package-designator))))
+
+  ;; This function is used internally to initialize the CL package
+  ;; with the symbols built during bootstrap.
+  (defun %intern-symbol (symbol)
+    (let ((symbols (%package-symbols *common-lisp-package*)))
+      (oset symbol "package" *common-lisp-package*)
+      (oset symbols (symbol-name symbol) symbol)))
+
+  (defun %find-symbol (name package)
+    (let ((package (find-package-or-fail package)))
+      (let ((symbols (%package-symbols package)))
+        (if (in name symbols)
+            (cons (oget symbols name) t)
+            (dolist (used (package-use-list package) (cons nil nil))
+              (let ((exports (%package-external-symbols used)))
+                (when (in name exports)
+                  (return-from %find-symbol
+                    (cons (oget exports name) t)))))))))
+
+  (defun find-symbol (name &optional (package *package*))
+    (car (%find-symbol name package)))
+
+  (defun intern (name &optional (package *package*))
+    (let ((package (find-package-or-fail package)))
+      (let ((result (%find-symbol name package)))
+        (if (cdr result)
+            (car result)
+            (let ((symbols (%package-symbols package)))
+              (oget symbols name)
+              (let ((symbol (make-symbol name)))
+                (oset symbol "package" package)
+                (when (eq package *keyword-package*)
+                  (oset symbol "value" symbol)
+                  (export (list symbol) package))
+                (oset symbols name symbol)))))))
+
+  (defun symbol-package (symbol)
+    (unless (symbolp symbol)
+      (error "it is not a symbol"))
+    (oget symbol "package"))
+
+  (defun export (symbols &optional (package *package*))
+    (let ((exports (%package-external-symbols package)))
+      (dolist (symb symbols t)
+        (oset exports (symbol-name symb) symb)))))

 
 
 ;;; The compiler offers some primitives and special forms which are
 
 
 ;;; The compiler offers some primitives and special forms which are

@@ -564,7 +687,15 @@
 (progn
   (defun prin1-to-string (form)
     (cond
 (progn
   (defun prin1-to-string (form)
     (cond

-      ((symbolp form) (symbol-name form))
+      ((symbolp form)
+       (if (cdr (%find-symbol (symbol-name form) *package*))
+           (symbol-name form)
+           (let ((package (symbol-package form))
+                 (name (symbol-name form)))
+             (concat (if (eq package (find-package "KEYWORD"))
+                         ""
+                         (package-name package))
+                     ":" name))))

       ((integerp form) (integer-to-string form))
       ((stringp form) (concat "\"" (escape-string form) "\""))
       ((functionp form)
       ((integerp form) (integer-to-string form))
       ((stringp form) (concat "\"" (escape-string form) "\""))
       ((functionp form)

@@ -579,7 +710,9 @@
                  (if (null (cdr last))
                      (prin1-to-string (car last))
                      (concat (prin1-to-string (car last)) " . " (prin1-to-string (cdr last)))))
                  (if (null (cdr last))
                      (prin1-to-string (car last))
                      (concat (prin1-to-string (car last)) " . " (prin1-to-string (cdr last)))))

-               ")"))))
+               ")"))
+      ((packagep form)
+       (concat "#<PACKAGE " (package-name form) ">"))))

 
   (defun write-line (x)
     (write-string x)
 
   (defun write-line (x)
     (write-string x)

@@ -700,12 +833,48 @@
          (t
           (error "Unknown reader form.")))))))
 
          (t
           (error "Unknown reader form.")))))))
 

-(defvar *eof* (make-symbol "EOF"))
+;;; Parse a string of the form NAME, PACKAGE:NAME or
+;;; PACKAGE::NAME and return the name. If the string is of the
+;;; form 1) or 3), but the symbol does not exist, it will be created
+;;; and interned in that package.
+(defun read-symbol (string)
+  (let ((size (length string))
+        package name internalp index)
+    (setq index 0)
+    (while (and (< index size)
+                (not (char= (char string index) #\:)))
+      (incf index))
+    (cond
+      ;; No package prefix
+      ((= index size)
+       (setq name string)
+       (setq package *package*)
+       (setq internalp t))
+      (t
+       ;; Package prefix
+       (if (zerop index)
+           (setq package "KEYWORD")
+           (setq package (string-upcase (subseq string 0 index))))
+       (incf index)
+       (when (char= (char string index) #\:)
+         (setq internalp t)
+         (incf index))
+       (setq name (subseq string index))))
+    ;; Canonalize symbol name and package
+    (setq name (string-upcase name))
+    (setq package (find-package package))
+    ;; TODO: PACKAGE:SYMBOL should signal error if SYMBOL is not an
+    ;; external symbol from PACKAGE.
+    (if (or internalp (eq package (find-package "KEYWORD")))
+        (intern name package)
+        (find-symbol name package))))
+
+(defvar *eof* (gensym))

 (defun ls-read (stream)
   (skip-whitespaces-and-comments stream)
   (let ((ch (%peek-char stream)))
     (cond
 (defun ls-read (stream)
   (skip-whitespaces-and-comments stream)
   (let ((ch (%peek-char stream)))
     (cond

-      ((null ch)
+      ((or (null ch) (char= ch #\)))

        *eof*)
       ((char= ch #\()
        (%read-char stream)
        *eof*)
       ((char= ch #\()
        (%read-char stream)

@@ -730,7 +899,7 @@
        (let ((string (read-until stream #'terminalp)))
          (if (every #'digit-char-p string)
              (parse-integer string)
        (let ((string (read-until stream #'terminalp)))
          (if (every #'digit-char-p string)
              (parse-integer string)

-             (intern (string-upcase string))))))))
+             (read-symbol string)))))))

 
 (defun ls-read-from-string (string)
   (ls-read (make-string-stream string)))
 
 (defun ls-read-from-string (string)
   (ls-read (make-string-stream string)))

@@ -745,16 +914,23 @@
 
 (defvar *compilation-unit-checks* '())
 
 
 (defvar *compilation-unit-checks* '())
 

-(defun make-binding (name type translation declared)
-  (list name type translation declared))
+(defun make-binding (name type value &optional declarations)
+  (list name type value declarations))

 
 (defun binding-name (b) (first b))
 (defun binding-type (b) (second b))
 
 (defun binding-name (b) (first b))
 (defun binding-type (b) (second b))

-(defun binding-translation (b) (third b))
-(defun binding-declared (b)
-  (and b (fourth b)))
-(defun mark-binding-as-declared (b)
-  (setcar (cdddr b) t))
+(defun binding-value (b) (third b))
+(defun binding-declarations (b) (fourth b))
+
+(defun set-binding-value (b value)
+  (setcar (cddr b) value))
+
+(defun set-binding-declarations (b value)
+  (setcar (cdddr b) value))
+
+(defun push-binding-declaration (decl b)
+  (set-binding-declarations b (cons decl (binding-declarations b))))
+

 
 (defun make-lexenv ()
   (list nil nil nil nil))
 
 (defun make-lexenv ()
   (list nil nil nil nil))

@@ -781,27 +957,19 @@
                 (block (third lexenv))
                 (gotag (fourth lexenv)))))
 
                 (block (third lexenv))
                 (gotag (fourth lexenv)))))
 

-(defvar *global-environment* (make-lexenv))

 (defvar *environment* (make-lexenv))
 
 (defvar *environment* (make-lexenv))
 

-(defun clear-undeclared-global-bindings ()
-  (setq *environment*
-       (mapcar (lambda (namespace)
-                 (remove-if-not #'binding-declared namespace))
-               *environment*)))
-
-

 (defvar *variable-counter* 0)
 (defun gvarname (symbol)
   (concat "v" (integer-to-string (incf *variable-counter*))))
 
 (defun translate-variable (symbol)
 (defvar *variable-counter* 0)
 (defun gvarname (symbol)
   (concat "v" (integer-to-string (incf *variable-counter*))))
 
 (defun translate-variable (symbol)

-  (binding-translation (lookup-in-lexenv symbol *environment* 'variable)))
+  (binding-value (lookup-in-lexenv symbol *environment* 'variable)))

 
 (defun extend-local-env (args)
   (let ((new (copy-lexenv *environment*)))
     (dolist (symbol args new)
 
 (defun extend-local-env (args)
   (let ((new (copy-lexenv *environment*)))
     (dolist (symbol args new)

-      (let ((b (make-binding symbol 'lexical-variable (gvarname symbol) t)))
+      (let ((b (make-binding symbol 'lexical-variable (gvarname symbol))))

         (push-to-lexenv b new 'variable)))))
 
 ;;; Toplevel compilations
         (push-to-lexenv b new 'variable)))))
 
 ;;; Toplevel compilations

@@ -818,17 +986,39 @@
 
 (defun %compile-defmacro (name lambda)
   (toplevel-compilation (ls-compile `',name))
 
 (defun %compile-defmacro (name lambda)
   (toplevel-compilation (ls-compile `',name))

-  (push-to-lexenv (make-binding name 'macro lambda t) *environment* 'function))
+  (push-to-lexenv (make-binding name 'macro lambda) *environment* 'function))
+
+(defun global-binding (name type namespace)
+  (or (lookup-in-lexenv name *environment* namespace)
+      (let ((b (make-binding name type nil)))
+        (push-to-lexenv b *environment* namespace)
+        b)))
+
+(defun claimp (symbol namespace claim)
+  (let ((b (lookup-in-lexenv symbol *environment* namespace)))
+    (and b (member claim (binding-declarations b)))))
+
+(defun !proclaim (decl)
+  (case (car decl)
+    (notinline
+     (dolist (name (cdr decl))
+       (let ((b (global-binding name 'function 'function)))
+         (push-binding-declaration 'notinline b))))
+    (constant
+     (dolist (name (cdr decl))
+       (let ((b (global-binding name 'variable 'variable)))
+         (push-binding-declaration 'constant b))))
+    (non-overridable
+     (dolist (name (cdr decl))
+       (let ((b (global-binding name 'function 'function)))
+         (push-binding-declaration 'non-overridable b))))))

 
 

-(defvar *compilations* nil)
+#+ecmalisp
+(fset 'proclaim #'!proclaim)

 
 

-(defun ls-compile-block (sexps &optional return-last-p)
-  (if return-last-p
-      (concat (ls-compile-block (butlast sexps))
-              "return " (ls-compile (car (last sexps))) ";")
-      (join-trailing
-       (remove-if #'null-or-empty-p (mapcar #'ls-compile sexps))
-       (concat ";" *newline*))))
+;;; Special forms
+
+(defvar *compilations* nil)

 
 (defmacro define-compilation (name args &body body)
   ;; Creates a new primitive `name' with parameters args and
 
 (defmacro define-compilation (name args &body body)
   ;; Creates a new primitive `name' with parameters args and

@@ -865,73 +1055,90 @@
       (error "Bad lambda-list"))
     (car rest)))
 
       (error "Bad lambda-list"))
     (car rest)))
 

+
+(defun lambda-docstring-wrapper (docstring &rest strs)
+  (if docstring
+      (js!selfcall
+        "var func = " (join strs) ";" *newline*
+        "func.docstring = '" docstring "';" *newline*
+        "return func;" *newline*)
+      (join strs)))
+

 (define-compilation lambda (lambda-list &rest body)
   (let ((required-arguments (lambda-list-required-arguments lambda-list))
         (optional-arguments (lambda-list-optional-arguments lambda-list))
 (define-compilation lambda (lambda-list &rest body)
   (let ((required-arguments (lambda-list-required-arguments lambda-list))
         (optional-arguments (lambda-list-optional-arguments lambda-list))

-        (rest-argument (lambda-list-rest-argument lambda-list)))
+        (rest-argument (lambda-list-rest-argument lambda-list))
+        documentation)
+    ;; Get the documentation string for the lambda function
+    (when (and (stringp (car body))
+               (not (null (cdr body))))
+      (setq documentation (car body))
+      (setq body (cdr body)))

     (let ((n-required-arguments (length required-arguments))
           (n-optional-arguments (length optional-arguments))
           (*environment* (extend-local-env
                           (append (ensure-list rest-argument)
                                   required-arguments
                                   optional-arguments))))
     (let ((n-required-arguments (length required-arguments))
           (n-optional-arguments (length optional-arguments))
           (*environment* (extend-local-env
                           (append (ensure-list rest-argument)
                                   required-arguments
                                   optional-arguments))))

-      (concat "(function ("
-              (join (mapcar #'translate-variable
-                            (append required-arguments optional-arguments))
-                    ",")
-              "){" *newline*
-              ;; Check number of arguments
-              (indent
-               (if required-arguments
-                   (concat "if (arguments.length < " (integer-to-string n-required-arguments)
-                           ") throw 'too few arguments';" *newline*)
-                   "")
-               (if (not rest-argument)
-                   (concat "if (arguments.length > "
-                           (integer-to-string (+ n-required-arguments n-optional-arguments))
-                           ") throw 'too many arguments';" *newline*)
-                   "")
-               ;; Optional arguments
-               (if optional-arguments
-                   (concat "switch(arguments.length){" *newline*
-                           (let ((optional-and-defaults
-                                  (lambda-list-optional-arguments-with-default lambda-list))
-                                 (cases nil)
-                                 (idx 0))
-                             (progn
-                               (while (< idx n-optional-arguments)
-                                 (let ((arg (nth idx optional-and-defaults)))
-                                   (push (concat "case "
-                                                 (integer-to-string (+ idx n-required-arguments)) ":" *newline*
-                                                 (translate-variable (car arg))
-                                                 "="
-                                                 (ls-compile (cadr arg))
-                                                 ";" *newline*)
-                                         cases)
-                                   (incf idx)))
-                               (push (concat "default: break;" *newline*) cases)
-                               (join (reverse cases))))
-                           "}" *newline*)
-                   "")
-               ;; &rest/&body argument
-               (if rest-argument
-                   (let ((js!rest (translate-variable rest-argument)))
-                     (concat "var " js!rest "= " (ls-compile nil) ";" *newline*
-                             "for (var i = arguments.length-1; i>="
-                             (integer-to-string (+ n-required-arguments n-optional-arguments))
-                             "; i--)" *newline*
-                             (indent js!rest " = "
-                                     "{car: arguments[i], cdr: ") js!rest "};"
-                             *newline*))
-                   "")
-               ;; Body
-               (ls-compile-block body t)) *newline*
-              "})"))))
+      (lambda-docstring-wrapper
+       documentation
+       "(function ("
+       (join (mapcar #'translate-variable
+                     (append required-arguments optional-arguments))
+             ",")
+       "){" *newline*
+       ;; Check number of arguments
+       (indent
+        (if required-arguments
+            (concat "if (arguments.length < " (integer-to-string n-required-arguments)
+                    ") throw 'too few arguments';" *newline*)
+            "")
+        (if (not rest-argument)
+            (concat "if (arguments.length > "
+                    (integer-to-string (+ n-required-arguments n-optional-arguments))
+                    ") throw 'too many arguments';" *newline*)
+            "")
+        ;; Optional arguments
+        (if optional-arguments
+            (concat "switch(arguments.length){" *newline*
+                    (let ((optional-and-defaults
+                           (lambda-list-optional-arguments-with-default lambda-list))
+                          (cases nil)
+                          (idx 0))
+                      (progn
+                        (while (< idx n-optional-arguments)
+                          (let ((arg (nth idx optional-and-defaults)))
+                            (push (concat "case "
+                                          (integer-to-string (+ idx n-required-arguments)) ":" *newline*
+                                          (translate-variable (car arg))
+                                          "="
+                                          (ls-compile (cadr arg))
+                                          ";" *newline*)
+                                  cases)
+                            (incf idx)))
+                        (push (concat "default: break;" *newline*) cases)
+                        (join (reverse cases))))
+                    "}" *newline*)
+            "")
+        ;; &rest/&body argument
+        (if rest-argument
+            (let ((js!rest (translate-variable rest-argument)))
+              (concat "var " js!rest "= " (ls-compile nil) ";" *newline*
+                      "for (var i = arguments.length-1; i>="
+                      (integer-to-string (+ n-required-arguments n-optional-arguments))
+                      "; i--)" *newline*
+                      (indent js!rest " = "
+                              "{car: arguments[i], cdr: ") js!rest "};"
+                      *newline*))
+            "")
+        ;; Body
+        (ls-compile-block body t)) *newline*
+       "})"))))

 
 (define-compilation setq (var val)
   (let ((b (lookup-in-lexenv var *environment* 'variable)))
     (if (eq (binding-type b) 'lexical-variable)
 
 (define-compilation setq (var val)
   (let ((b (lookup-in-lexenv var *environment* 'variable)))
     (if (eq (binding-type b) 'lexical-variable)

-        (concat (binding-translation b) " = " (ls-compile val))
+        (concat (binding-value b) " = " (ls-compile val))

         (ls-compile `(set ',var ,val)))))
 
 ;;; FFI Variable accessors
         (ls-compile `(set ',var ,val)))))
 
 ;;; FFI Variable accessors

@@ -973,7 +1180,9 @@
      (or (cdr (assoc sexp *literal-symbols*))
         (let ((v (genlit))
               (s #+common-lisp (concat "{name: \"" (escape-string (symbol-name sexp)) "\"}")
      (or (cdr (assoc sexp *literal-symbols*))
         (let ((v (genlit))
               (s #+common-lisp (concat "{name: \"" (escape-string (symbol-name sexp)) "\"}")

-                 #+ecmalisp (ls-compile `(intern ,(symbol-name sexp)))))
+                 #+ecmalisp (ls-compile
+                              `(intern ,(symbol-name sexp)
+                                       ,(package-name (symbol-package sexp))))))

           (push (cons sexp v) *literal-symbols*)
           (toplevel-compilation (concat "var " v " = " s))
           v)))
           (push (cons sexp v) *literal-symbols*)
           (toplevel-compilation (concat "var " v " = " s))
           v)))

@@ -1067,7 +1276,7 @@
 
 (define-compilation block (name &rest body)
   (let ((tr (integer-to-string (incf *block-counter*))))
 
 (define-compilation block (name &rest body)
   (let ((tr (integer-to-string (incf *block-counter*))))

-    (let ((b (make-binding name 'block tr t)))
+    (let ((b (make-binding name 'block tr)))

       (js!selfcall
         "try {" *newline*
         (let ((*environment* (extend-lexenv (list b) *environment* 'block)))
       (js!selfcall
         "try {" *newline*
         (let ((*environment* (extend-lexenv (list b) *environment* 'block)))

@@ -1086,7 +1295,7 @@
         (js!selfcall
           "throw ({"
           "type: 'block', "
         (js!selfcall
           "throw ({"
           "type: 'block', "

-          "id: " (binding-translation b) ", "
+          "id: " (binding-value b) ", "

           "value: " (ls-compile value) ", "
           "message: 'Return from unknown block " (symbol-name name) ".'"
           "})")
           "value: " (ls-compile value) ", "
           "message: 'Return from unknown block " (symbol-name name) ".'"
           "})")

@@ -1107,7 +1316,7 @@
     "        throw cf;" *newline*
     "}" *newline*))
 
     "        throw cf;" *newline*
     "}" *newline*))
 

-(define-compilation throw (id &optional value)
+(define-compilation throw (id value)

   (js!selfcall
     "throw ({"
     "type: 'catch', "
   (js!selfcall
     "throw ({"
     "type: 'catch', "

@@ -1127,7 +1336,7 @@
   (let ((bindings
          (mapcar (lambda (label)
                    (let ((tagidx (integer-to-string (incf *go-tag-counter*))))
   (let ((bindings
          (mapcar (lambda (label)
                    (let ((tagidx (integer-to-string (incf *go-tag-counter*))))

-                     (make-binding label 'gotag (list tbidx tagidx) t)))
+                     (make-binding label 'gotag (list tbidx tagidx))))

                  (remove-if-not #'go-tag-p body))))
     (extend-lexenv bindings *environment* 'gotag)))
 
                  (remove-if-not #'go-tag-p body))))
     (extend-lexenv bindings *environment* 'gotag)))
 

@@ -1145,7 +1354,7 @@
     (let ((*environment* (declare-tagbody-tags tbidx body))
           initag)
       (let ((b (lookup-in-lexenv (first body) *environment* 'gotag)))
     (let ((*environment* (declare-tagbody-tags tbidx body))
           initag)
       (let ((b (lookup-in-lexenv (first body) *environment* 'gotag)))

-        (setq initag (second (binding-translation b))))
+        (setq initag (second (binding-value b))))

       (js!selfcall
         "var tagbody_" tbidx " = " initag ";" *newline*
         "tbloop:" *newline*
       (js!selfcall
         "var tagbody_" tbidx " = " initag ";" *newline*
         "tbloop:" *newline*

@@ -1159,7 +1368,7 @@
                                       (if (not (go-tag-p form))
                                           (indent (ls-compile form) ";" *newline*)
                                           (let ((b (lookup-in-lexenv form *environment* 'gotag)))
                                       (if (not (go-tag-p form))
                                           (indent (ls-compile form) ";" *newline*)
                                           (let ((b (lookup-in-lexenv form *environment* 'gotag)))

-                                            (concat "case " (second (binding-translation b)) ":" *newline*)))))
+                                            (concat "case " (second (binding-value b)) ":" *newline*)))))

                                   "default:" *newline*
                                   "    break tbloop;" *newline*
                                   "}" *newline*)))
                                   "default:" *newline*
                                   "    break tbloop;" *newline*
                                   "}" *newline*)))

@@ -1182,8 +1391,8 @@
         (js!selfcall
           "throw ({"
           "type: 'tagbody', "
         (js!selfcall
           "throw ({"
           "type: 'tagbody', "

-          "id: " (first (binding-translation b)) ", "
-          "label: " (second (binding-translation b)) ", "
+          "id: " (first (binding-value b)) ", "
+          "label: " (second (binding-value b)) ", "

           "message: 'Attempt to GO to non-existing tag " n "'"
           "})" *newline*)
         (error (concat "Unknown tag `" n "'.")))))
           "message: 'Attempt to GO to non-existing tag " n "'"
           "})" *newline*)
         (error (concat "Unknown tag `" n "'.")))))

@@ -1237,9 +1446,18 @@
 
 ;;; Primitives
 
 
 ;;; Primitives
 

+(defvar *builtins* nil)
+
+(defmacro define-raw-builtin (name args &body body)
+  ;; Creates a new primitive function `name' with parameters args and
+  ;; @body. The body can access to the local environment through the
+  ;; variable *ENVIRONMENT*.
+  `(push (list ',name (lambda ,args (block ,name ,@body)))
+         *builtins*))
+

 (defmacro define-builtin (name args &body body)
   `(progn
 (defmacro define-builtin (name args &body body)
   `(progn

-     (define-compilation ,name ,args
+     (define-raw-builtin ,name ,args

        (let ,(mapcar (lambda (arg) `(,arg (ls-compile ,arg))) args)
          ,@body))))
 
        (let ,(mapcar (lambda (arg) `(,arg (ls-compile ,arg))) args)
          ,@body))))
 

@@ -1361,7 +1579,7 @@
 (define-builtin eq    (x y) (js!bool (concat "(" x " === " y ")")))
 (define-builtin equal (x y) (js!bool (concat "(" x  " == " y ")")))
 
 (define-builtin eq    (x y) (js!bool (concat "(" x " === " y ")")))
 (define-builtin equal (x y) (js!bool (concat "(" x  " == " y ")")))
 

-(define-builtin string (x)
+(define-builtin char-to-string (x)

   (type-check (("x" "number" x))
     "String.fromCharCode(x)"))
 
   (type-check (("x" "number" x))
     "String.fromCharCode(x)"))
 

@@ -1376,7 +1594,7 @@
   (type-check (("x" "string" x))
     "x.length"))
 
   (type-check (("x" "string" x))
     "x.length"))
 

-(define-compilation slice (string a &optional b)
+(define-raw-builtin slice (string a &optional b)

   (js!selfcall
     "var str = " (ls-compile string) ";" *newline*
     "var a = " (ls-compile a) ";" *newline*
   (js!selfcall
     "var str = " (ls-compile string) ";" *newline*
     "var a = " (ls-compile a) ";" *newline*

@@ -1396,13 +1614,13 @@
                ("string2" "string" string2))
     "string1.concat(string2)"))
 
                ("string2" "string" string2))
     "string1.concat(string2)"))
 

-(define-compilation funcall (func &rest args)
+(define-raw-builtin funcall (func &rest args)

   (concat "(" (ls-compile func) ")("
           (join (mapcar #'ls-compile args)
                 ", ")
           ")"))
 
   (concat "(" (ls-compile func) ")("
           (join (mapcar #'ls-compile args)
                 ", ")
           ")"))
 

-(define-compilation apply (func &rest args)
+(define-raw-builtin apply (func &rest args)

   (if (null args)
       (concat "(" (ls-compile func) ")()")
       (let ((args (butlast args))
   (if (null args)
       (concat "(" (ls-compile func) ")()")
       (let ((args (butlast args))

@@ -1428,6 +1646,9 @@
 
 (define-builtin new () "{}")
 
 
 (define-builtin new () "{}")
 

+(define-builtin objectp (x)
+  (js!bool (concat "(typeof (" x ") === 'object')")))
+

 (define-builtin oget (object key)
   (js!selfcall
     "var tmp = " "(" object ")[" key "];" *newline*
 (define-builtin oget (object key)
   (js!selfcall
     "var tmp = " "(" object ")[" key "];" *newline*

@@ -1455,31 +1676,71 @@
 (defun ls-macroexpand-1 (form)
   (let ((macro-binding (macro (car form))))
     (if macro-binding
 (defun ls-macroexpand-1 (form)
   (let ((macro-binding (macro (car form))))
     (if macro-binding

-        (apply (eval (binding-translation macro-binding)) (cdr form))
+        (let ((expander (binding-value macro-binding)))
+          (when (listp expander)
+            (let ((compiled (eval expander)))
+              ;; The list representation are useful while
+              ;; bootstrapping, as we can dump the definition of the
+              ;; macros easily, but they are slow because we have to
+              ;; evaluate them and compile them now and again. So, let
+              ;; us replace the list representation version of the
+              ;; function with the compiled one.
+              ;;
+              #+ecmalisp (set-binding-value macro-binding compiled)
+              (setq expander compiled)))
+          (apply expander (cdr form)))

         form)))
 
 (defun compile-funcall (function args)
         form)))
 
 (defun compile-funcall (function args)

-  (concat (ls-compile `#',function) "("
-          (join (mapcar #'ls-compile args)
-                ", ")
-          ")"))
+  (if (and (symbolp function)
+           (claimp function 'function 'non-overridable))
+      (concat (ls-compile `',function) ".function("
+              (join (mapcar #'ls-compile args)
+                    ", ")
+              ")")
+      (concat (ls-compile `#',function) "("
+              (join (mapcar #'ls-compile args)
+                    ", ")
+              ")")))
+
+(defun ls-compile-block (sexps &optional return-last-p)
+  (if return-last-p
+      (concat (ls-compile-block (butlast sexps))
+              "return " (ls-compile (car (last sexps))) ";")
+      (join-trailing
+       (remove-if #'null-or-empty-p (mapcar #'ls-compile sexps))
+       (concat ";" *newline*))))

 
 (defun ls-compile (sexp)
   (cond
     ((symbolp sexp)
      (let ((b (lookup-in-lexenv sexp *environment* 'variable)))
 
 (defun ls-compile (sexp)
   (cond
     ((symbolp sexp)
      (let ((b (lookup-in-lexenv sexp *environment* 'variable)))

-       (if (eq (binding-type b) 'lexical-variable)
-           (binding-translation b)
-           (ls-compile `(symbol-value ',sexp)))))
+       (cond
+         ((eq (binding-type b) 'lexical-variable)
+          (binding-value b))
+         ((or (keywordp sexp) (claimp sexp 'variable 'constant))
+          (concat (ls-compile `',sexp) ".value"))
+         (t
+          (ls-compile `(symbol-value ',sexp))))))

     ((integerp sexp) (integer-to-string sexp))
     ((stringp sexp) (concat "\"" (escape-string sexp) "\""))
     ((listp sexp)
     ((integerp sexp) (integer-to-string sexp))
     ((stringp sexp) (concat "\"" (escape-string sexp) "\""))
     ((listp sexp)

-     (if (assoc (car sexp) *compilations*)
-         (let ((comp (second (assoc (car sexp) *compilations*))))
-           (apply comp (cdr sexp)))
-         (if (macro (car sexp))
-             (ls-compile (ls-macroexpand-1 sexp))
-             (compile-funcall (car sexp) (cdr sexp)))))))
+     (let ((name (car sexp))
+           (args (cdr sexp)))
+       (cond
+         ;; Special forms
+         ((assoc name *compilations*)
+          (let ((comp (second (assoc name *compilations*))))
+            (apply comp args)))
+         ;; Built-in functions
+         ((and (assoc name *builtins*)
+               (not (claimp name 'function 'notinline)))
+          (let ((comp (second (assoc name *builtins*))))
+            (apply comp args)))
+         (t
+          (if (macro name)
+              (ls-compile (ls-macroexpand-1 sexp))
+              (compile-funcall name args))))))))

 
 (defun ls-compile-toplevel (sexp)
   (let ((*toplevel-compilations* nil))
 
 (defun ls-compile-toplevel (sexp)
   (let ((*toplevel-compilations* nil))

@@ -1506,7 +1767,6 @@
     `(prog1
          (progn
            (setq *compilation-unit-checks* nil)
     `(prog1
          (progn
            (setq *compilation-unit-checks* nil)

-           (clear-undeclared-global-bindings)

            ,@body)
        (dolist (check *compilation-unit-checks*)
          (funcall check))))
            ,@body)
        (dolist (check *compilation-unit-checks*)
          (funcall check))))

@@ -1517,6 +1777,29 @@
                (ls-compile-toplevel x))))
       (js-eval code)))
 
                (ls-compile-toplevel x))))
       (js-eval code)))
 

+  (export '(* *gensym-counter* *package* + - / 1+ 1- < <= = = > >= and append
+            apply assoc atom block boundp boundp butlast caar cadddr
+            caddr cadr car car case catch cdar cdddr cddr cdr cdr char
+            char-code char= code-char cond cons consp copy-list decf
+            declaim defparameter defun defvar digit-char-p disassemble
+            documentation dolist dotimes ecase eq eql equal error eval
+            every export fdefinition find-package find-symbol first
+            fourth fset funcall function functionp gensym go identity
+            in-package incf integerp integerp intern keywordp
+            lambda-code last length let list-all-packages list listp
+            make-package make-symbol mapcar member minusp mod nil not
+            nth nthcdr null numberp or package-name package-use-list
+            packagep plusp prin1-to-string print proclaim prog1 prog2
+            pron push quote remove remove-if remove-if-not return
+            return-from revappend reverse second set setq some
+            string-upcase string string= stringp subseq
+            symbol-function symbol-name symbol-package symbol-plist
+            symbol-value symbolp t tagbody third throw truncate unless
+            unwind-protect variable warn when write-line write-string
+            zerop))
+
+  (setq *package* *user-package*)
+

   (js-eval "var lisp")
   (js-vset "lisp" (new))
   (js-vset "lisp.read" #'ls-read-from-string)
   (js-eval "var lisp")
   (js-vset "lisp" (new))
   (js-vset "lisp.read" #'ls-read-from-string)

@@ -1532,9 +1815,7 @@
     (toplevel-compilation
      (ls-compile
       `(progn
     (toplevel-compilation
      (ls-compile
       `(progn

-         ,@(mapcar (lambda (s)
-                     `(oset *package* ,(symbol-name (car s))
-                            (js-vref ,(cdr s))))
+         ,@(mapcar (lambda (s) `(%intern-symbol (js-vref ,(cdr s))))

                    *literal-symbols*)
          (setq *literal-symbols* ',*literal-symbols*)
          (setq *environment* ',*environment*)
                    *literal-symbols*)
          (setq *literal-symbols* ',*literal-symbols*)
          (setq *environment* ',*environment*)