Use def!struct

[jscl.git] / src / compiler.lisp

diff --git a/src/compiler.lisp b/src/compiler.lisp
index 49ea708..3dc2f1c 100644 (file)
--- a/src/compiler.lisp
+++ b/src/compiler.lisp
@@ -30,7 +30,7 @@
                  ((integerp arg) (integer-to-string arg))
                  ((floatp arg) (float-to-string arg))
                  ((stringp arg) arg)
                  ((integerp arg) (integer-to-string arg))
                  ((floatp arg) (float-to-string arg))
                  ((stringp arg) arg)

-                 (t (error "Unknown argument."))))
+                 (t (error "Unknown argument `~S'." arg))))

              args))
 
 ;;; Wrap X with a Javascript code to convert the result from
              args))
 
 ;;; Wrap X with a Javascript code to convert the result from

@@ -87,62 +87,6 @@
 ;;; function call.
 (defvar *multiple-value-p* nil)
 
 ;;; function call.
 (defvar *multiple-value-p* nil)
 

-;; A very simple defstruct built on lists. It supports just slot with
-;; an optional default initform, and it will create a constructor,
-;; predicate and accessors for you.
-(defmacro def!struct (name &rest slots)
-  (unless (symbolp name)
-    (error "It is not a full defstruct implementation."))
-  (let* ((name-string (symbol-name name))
-         (slot-descriptions
-          (mapcar (lambda (sd)
-                    (cond
-                      ((symbolp sd)
-                       (list sd))
-                      ((and (listp sd) (car sd) (cddr sd))
-                       sd)
-                      (t
-                       (error "Bad slot accessor."))))
-                  slots))
-         (predicate (intern (concat name-string "-P"))))
-    `(progn
-       ;; Constructor
-       (defun ,(intern (concat "MAKE-" name-string)) (&key ,@slot-descriptions)
-         (list ',name ,@(mapcar #'car slot-descriptions)))
-       ;; Predicate
-       (defun ,predicate (x)
-         (and (consp x) (eq (car x) ',name)))
-       ;; Copier
-       (defun ,(intern (concat "COPY-" name-string)) (x)
-         (copy-list x))
-       ;; Slot accessors
-       ,@(with-collect
-          (let ((index 1))
-            (dolist (slot slot-descriptions)
-              (let* ((name (car slot))
-                     (accessor-name (intern (concat name-string "-" (string name)))))
-                (collect
-                    `(defun ,accessor-name (x)
-                       (unless (,predicate x)
-                         (error ,(concat "The object is not a type " name-string)))
-                       (nth ,index x)))
-                ;; TODO: Implement this with a higher level
-                ;; abstraction like defsetf or (defun (setf ..))
-                (collect
-                    `(define-setf-expander ,accessor-name (x)
-                       (let ((object (gensym))
-                             (new-value (gensym)))
-                         (values (list object)
-                                 (list x)
-                                 (list new-value)
-                                 `(progn
-                                    (rplaca (nthcdr ,',index ,object) ,new-value) 
-                                    ,new-value)
-                                 `(,',accessor-name ,object)))))
-                (incf index)))))
-       ',name)))
-
-

 ;;; Environment
 
 (def!struct binding
 ;;; Environment
 
 (def!struct binding

@@ -291,7 +235,7 @@
 (defun ll-rest-argument (ll)
   (let ((rest (ll-section '&rest ll)))
     (when (cdr rest)
 (defun ll-rest-argument (ll)
   (let ((rest (ll-section '&rest ll)))
     (when (cdr rest)

-      (error "Bad lambda-list"))
+      (error "Bad lambda-list `~S'." ll))

     (car rest)))
 
 (defun ll-keyword-arguments-canonical (ll)
     (car rest)))
 
 (defun ll-keyword-arguments-canonical (ll)

@@ -433,7 +377,7 @@
                            " && ")
                      ")" *newline*
                      (indent
                            " && ")
                      ")" *newline*
                      (indent

-                      "throw 'Unknown keyword argument ' + arguments[i].name;" *newline*))
+                      "throw 'Unknown keyword argument ' + xstring(arguments[i].name);" *newline*))

              "}" *newline*)))))
 
 (defun parse-lambda-list (ll)
              "}" *newline*)))))
 
 (defun parse-lambda-list (ll)

@@ -528,7 +472,7 @@
       (cond
        ((null pairs) (return))
        ((null (cdr pairs))
       (cond
        ((null pairs) (return))
        ((null (cdr pairs))

-        (error "Odd paris in SETQ"))
+        (error "Odd pairs in SETQ"))

        (t
         (concatf result
           (concat (setq-pair (car pairs) (cadr pairs))
        (t
         (concatf result
           (concat (setq-pair (car pairs) (cadr pairs))

@@ -537,7 +481,8 @@
     (code "(" result ")")))
 
 
     (code "(" result ")")))
 
 

-;;; Literals
+;;; Compilation of literals an object dumping
+

 (defun escape-string (string)
   (let ((output "")
         (index 0)
 (defun escape-string (string)
   (let ((output "")
         (index 0)

@@ -553,10 +498,19 @@
       (incf index))
     output))
 
       (incf index))
     output))
 

-

 (defvar *literal-table* nil)
 (defvar *literal-counter* 0)
 
 (defvar *literal-table* nil)
 (defvar *literal-counter* 0)
 

+;;; BOOTSTRAP MAGIC: During bootstrap, we record the macro definitions
+;;; as lists. Once everything is compiled, we want to dump the whole
+;;; global environment to the output file to reproduce it in the
+;;; run-time. However, the environment must contain expander functions
+;;; rather than lists. We do not know how to dump function objects
+;;; itself, so we mark the definitions with this object and the
+;;; compiler will be called when this object has to be dumped.
+;;; Backquote/unquote does a similar magic, but this use is exclusive.
+(defvar *magic-unquote-marker* (gensym "MAGIC-UNQUOTE"))
+

 (defun genlit ()
   (code "l" (incf *literal-counter*)))
 
 (defun genlit ()
   (code "l" (incf *literal-counter*)))
 

@@ -564,13 +518,13 @@
   #+common-lisp
   (let ((package (symbol-package symbol)))
     (if (eq package (find-package "KEYWORD"))
   #+common-lisp
   (let ((package (symbol-package symbol)))
     (if (eq package (find-package "KEYWORD"))

-        (code "{name: \"" (escape-string (symbol-name symbol))
-              "\", 'package': '" (package-name package) "'}")
-        (code "{name: \"" (escape-string (symbol-name symbol)) "\"}")))
+        (code "(new Symbol(" (dump-string (symbol-name symbol)) ", "
+              (dump-string (package-name package)) "))")
+        (code "(new Symbol(" (dump-string (symbol-name symbol)) "))")))

   #+jscl
   (let ((package (symbol-package symbol)))
     (if (null package)
   #+jscl
   (let ((package (symbol-package symbol)))
     (if (null package)

-        (code "{name: \"" (escape-string (symbol-name symbol)) "\"}")
+        (code "(new Symbol(" (dump-string (symbol-name symbol)) "))")

         (ls-compile `(intern ,(symbol-name symbol) ,(package-name package))))))
 
 (defun dump-cons (cons)
         (ls-compile `(intern ,(symbol-name symbol) ,(package-name package))))))
 
 (defun dump-cons (cons)

@@ -587,17 +541,23 @@
   (let ((elements (vector-to-list array)))
     (concat "[" (join (mapcar #'literal elements) ", ") "]")))
 
   (let ((elements (vector-to-list array)))
     (concat "[" (join (mapcar #'literal elements) ", ") "]")))
 

+(defun dump-string (string)
+  (code "make_lisp_string(\"" (escape-string string) "\")"))
+

 (defun literal (sexp &optional recursive)
   (cond
     ((integerp sexp) (integer-to-string sexp))
     ((floatp sexp) (float-to-string sexp))
     ((characterp sexp) (code "\"" (escape-string (string sexp)) "\""))
 (defun literal (sexp &optional recursive)
   (cond
     ((integerp sexp) (integer-to-string sexp))
     ((floatp sexp) (float-to-string sexp))
     ((characterp sexp) (code "\"" (escape-string (string sexp)) "\""))

-    ((stringp sexp) (code "\"" (escape-string sexp) "\""))

     (t
     (t

-     (or (cdr (assoc sexp *literal-table*))
+     (or (cdr (assoc sexp *literal-table* :test #'equal))

          (let ((dumped (typecase sexp
                          (symbol (dump-symbol sexp))
          (let ((dumped (typecase sexp
                          (symbol (dump-symbol sexp))

-                         (cons (dump-cons sexp))
+                         (string (dump-string sexp))
+                         (cons
+                          (if (eq (car sexp) *magic-unquote-marker*)
+                              (ls-compile (cdr sexp))
+                              (dump-cons sexp)))

                          (array (dump-array sexp)))))
            (if (and recursive (not (symbolp sexp)))
                dumped
                          (array (dump-array sexp)))))
            (if (and recursive (not (symbolp sexp)))
                dumped

@@ -606,6 +566,7 @@
                  (toplevel-compilation (code "var " jsvar " = " dumped))
                  jsvar)))))))
 
                  (toplevel-compilation (code "var " jsvar " = " dumped))
                  jsvar)))))))
 

+

 (define-compilation quote (sexp)
   (literal sexp))
 
 (define-compilation quote (sexp)
   (literal sexp))
 

@@ -830,7 +791,7 @@
   (let* ((b (lookup-in-lexenv name *environment* 'block))
          (multiple-value-p (member 'multiple-value (binding-declarations b))))
     (when (null b)
   (let* ((b (lookup-in-lexenv name *environment* 'block))
          (multiple-value-p (member 'multiple-value (binding-declarations b))))
     (when (null b)

-      (error (concat "Unknown block `" (symbol-name name) "'.")))
+      (error "Return from unknown block `~S'." (symbol-name name)))

     (push 'used (binding-declarations b))
     ;; The binding value is the name of a variable, whose value is the
     ;; unique identifier of the block as exception. We can't use the
     (push 'used (binding-declarations b))
     ;; The binding value is the name of a variable, whose value is the
     ;; unique identifier of the block as exception. We can't use the

@@ -934,7 +895,7 @@
              ((symbolp label) (symbol-name label))
              ((integerp label) (integer-to-string label)))))
     (when (null b)
              ((symbolp label) (symbol-name label))
              ((integerp label) (integer-to-string label)))))
     (when (null b)

-      (error (concat "Unknown tag `" n "'.")))
+      (error "Unknown tag `~S'" label))

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

@@ -978,24 +939,6 @@
     "return args;" *newline*))
 
 
     "return args;" *newline*))
 
 

-;;; Javascript FFI
-
-(define-compilation %js-vref (var) var)
-
-(define-compilation %js-vset (var val)
-  (code "(" var " = " (ls-compile val) ")"))
-
-(define-setf-expander %js-vref (var)
-  (let ((new-value (gensym)))
-    (unless (stringp var)
-      (error "a string was expected"))
-    (values nil
-            (list var)
-            (list new-value)
-            `(%js-vset ,var ,new-value)
-            `(%js-vref ,var))))
-
-

 ;;; Backquote implementation.
 ;;;
 ;;;    Author: Guy L. Steele Jr.     Date: 27 December 1985
 ;;; Backquote implementation.
 ;;;
 ;;;    Author: Guy L. Steele Jr.     Date: 27 December 1985

@@ -1071,8 +1014,7 @@
          (bq-process (bq-completely-process (cadr x))))
         ((eq (car x) *comma*) (cadr x))
         ((eq (car x) *comma-atsign*)
          (bq-process (bq-completely-process (cadr x))))
         ((eq (car x) *comma*) (cadr x))
         ((eq (car x) *comma-atsign*)

-         ;; (error ",@~S after `" (cadr x))
-         (error "ill-formed"))
+         (error ",@~S after `" (cadr x)))

         ;; ((eq (car x) *comma-dot*)
         ;;  ;; (error ",.~S after `" (cadr x))
         ;;  (error "ill-formed"))
         ;; ((eq (car x) *comma-dot*)
         ;;  ;; (error ",.~S after `" (cadr x))
         ;;  (error "ill-formed"))

@@ -1083,13 +1025,11 @@
                       (nreconc q (list (list *bq-quote* p)))))
              (when (eq (car p) *comma*)
                (unless (null (cddr p))
                       (nreconc q (list (list *bq-quote* p)))))
              (when (eq (car p) *comma*)
                (unless (null (cddr p))

-                 ;; (error "Malformed ,~S" p)
-                 (error "Malformed"))
+                 (error "Malformed ,~S" p))

                (return (cons *bq-append*
                              (nreconc q (list (cadr p))))))
              (when (eq (car p) *comma-atsign*)
                (return (cons *bq-append*
                              (nreconc q (list (cadr p))))))
              (when (eq (car p) *comma-atsign*)

-               ;; (error "Dotted ,@~S" p)
-               (error "Dotted"))
+               (error "Dotted ,@~S" p))

              ;; (when (eq (car p) *comma-dot*)
              ;;   ;; (error "Dotted ,.~S" p)
              ;;   (error "Dotted"))
              ;; (when (eq (car p) *comma-dot*)
              ;;   ;; (error "Dotted ,.~S" p)
              ;;   (error "Dotted"))

@@ -1310,7 +1250,7 @@
 
 (defmacro variable-arity (args &body body)
   (unless (symbolp args)
 
 (defmacro variable-arity (args &body body)
   (unless (symbolp args)

-    (error "Bad usage of VARIABLE-ARITY, you must pass a symbol"))
+    (error "`~S' is not a symbol." args))

   `(variable-arity-call ,args
                         (lambda (,args)
                           (code "return " ,@body ";" *newline*))))
   `(variable-arity-call ,args
                         (lambda (,args)
                           (code "return " ,@body ";" *newline*))))

@@ -1385,7 +1325,7 @@
 
 (define-builtin float-to-string (x)
   (type-check (("x" "number" x))
 
 (define-builtin float-to-string (x)
   (type-check (("x" "number" x))

-    "x.toString()"))
+    "make_lisp_string(x.toString())"))

 
 (define-builtin cons (x y)
   (code "({car: " x ", cdr: " y "})"))
 
 (define-builtin cons (x y)
   (code "({car: " x ", cdr: " y "})"))

@@ -1419,14 +1359,10 @@
     (code "(x.cdr = " new ", x)")))
 
 (define-builtin symbolp (x)
     (code "(x.cdr = " new ", x)")))
 
 (define-builtin symbolp (x)

-  (js!bool
-   (js!selfcall
-     "var tmp = " x ";" *newline*
-     "return (typeof tmp == 'object' && 'name' in tmp);" *newline*)))
+  (js!bool (code "(" x " instanceof Symbol)")))

 
 (define-builtin make-symbol (name)
 
 (define-builtin make-symbol (name)

-  (type-check (("name" "string" name))
-    "({name: name})"))
+  (code "(new Symbol(" name "))"))

 
 (define-builtin symbol-name (x)
   (code "(" x ").name"))
 
 (define-builtin symbol-name (x)
   (code "(" x ").name"))

@@ -1444,21 +1380,21 @@
   (js!selfcall
     "var symbol = " x ";" *newline*
     "var value = symbol.value;" *newline*
   (js!selfcall
     "var symbol = " x ";" *newline*
     "var value = symbol.value;" *newline*

-    "if (value === undefined) throw \"Variable `\" + symbol.name + \"' is unbound.\";" *newline*
+    "if (value === undefined) throw \"Variable `\" + xstring(symbol.name) + \"' is unbound.\";" *newline*

     "return value;" *newline*))
 
 (define-builtin symbol-function (x)
   (js!selfcall
     "var symbol = " x ";" *newline*
     "var func = symbol.fvalue;" *newline*
     "return value;" *newline*))
 
 (define-builtin symbol-function (x)
   (js!selfcall
     "var symbol = " x ";" *newline*
     "var func = symbol.fvalue;" *newline*

-    "if (func === undefined) throw \"Function `\" + symbol.name + \"' is undefined.\";" *newline*
+    "if (func === undefined) throw \"Function `\" + xstring(symbol.name) + \"' is undefined.\";" *newline*

     "return func;" *newline*))
 
 (define-builtin symbol-plist (x)
   (code "((" x ").plist || " (ls-compile nil) ")"))
 
 (define-builtin lambda-code (x)
     "return func;" *newline*))
 
 (define-builtin symbol-plist (x)
   (code "((" x ").plist || " (ls-compile nil) ")"))
 
 (define-builtin lambda-code (x)

-  (code "(" x ").toString()"))
+  (code "make_lisp_string((" x ").toString())"))

 
 (define-builtin eq (x y)
   (js!bool (code "(" x " === " y ")")))
 
 (define-builtin eq (x y)
   (js!bool (code "(" x " === " y ")")))

@@ -1478,37 +1414,45 @@
      "return (typeof(" x ") == \"string\") && x.length == 1;")))
 
 (define-builtin char-to-string (x)
      "return (typeof(" x ") == \"string\") && x.length == 1;")))
 
 (define-builtin char-to-string (x)

-  (type-check (("x" "string" x))
-    "(x)"))
+  (js!selfcall
+    "var r = [" x "];" *newline*
+    "r.type = 'character';"
+    "return r"))
+
+(define-builtin char-upcase (x)
+  (code x ".toUpperCase()"))
+
+(define-builtin char-downcase (x)
+  (code x ".toLowerCase()"))

 
 (define-builtin stringp (x)
 
 (define-builtin stringp (x)

-  (js!bool (code "(typeof(" x ") == \"string\")")))
+  (js!bool
+   (js!selfcall
+     "var x = " x ";" *newline*
+     "return typeof(x) == 'object' && 'length' in x && x.type == 'character';")))

 
 (define-builtin string-upcase (x)
 
 (define-builtin string-upcase (x)

-  (type-check (("x" "string" x))
-    "x.toUpperCase()"))
+  (code "make_lisp_string(xstring(" x ").toUpperCase())"))

 
 (define-builtin string-length (x)
 
 (define-builtin string-length (x)

-  (type-check (("x" "string" x))
-    "x.length"))
+  (code x ".length"))

 
 

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

   (js!selfcall
   (js!selfcall

-    "var str = " (ls-compile string) ";" *newline*
+    "var vector = " (ls-compile vector) ";" *newline*

     "var a = " (ls-compile a) ";" *newline*
     "var b;" *newline*
     (when b (code "b = " (ls-compile b) ";" *newline*))
     "var a = " (ls-compile a) ";" *newline*
     "var b;" *newline*
     (when b (code "b = " (ls-compile b) ";" *newline*))

-    "return str.slice(a,b);" *newline*))
+    "return vector.slice(a,b);" *newline*))

 
 (define-builtin char (string index)
 
 (define-builtin char (string index)

-  (type-check (("string" "string" string)
-               ("index" "number" index))
-    "string.charAt(index)"))
+  (code string "[" index "]"))

 
 (define-builtin concat-two (string1 string2)
 
 (define-builtin concat-two (string1 string2)

-  (type-check (("string1" "string" string1)
-               ("string2" "string" string2))
-    "string1.concat(string2)"))
+  (js!selfcall
+    "var r = " string1 ".concat(" string2 ");" *newline*
+    "r.type = 'character';"
+    "return r;" *newline*))

 
 (define-raw-builtin funcall (func &rest args)
   (js!selfcall
 
 (define-raw-builtin funcall (func &rest args)
   (js!selfcall

@@ -1541,14 +1485,13 @@
           "return (typeof f === 'function'? f : f.fvalue).apply(this, args);" *newline*))))
 
 (define-builtin js-eval (string)
           "return (typeof f === 'function'? f : f.fvalue).apply(this, args);" *newline*))))
 
 (define-builtin js-eval (string)

-  (type-check (("string" "string" string))
-    (if *multiple-value-p*
-        (js!selfcall
-          "var v = globalEval(string);" *newline*
-          "return values.apply(this, forcemv(v));" *newline*)
-        "globalEval(string)")))
+  (if *multiple-value-p*
+      (js!selfcall
+        "var v = globalEval(xstring(" string "));" *newline*
+        "return values.apply(this, forcemv(v));" *newline*)
+      (code "globalEval(xstring(" string "))")))

 
 

-(define-builtin error (string)
+(define-builtin %throw (string)

   (js!selfcall "throw " string ";" *newline*))
 
 (define-builtin new () "{}")
   (js!selfcall "throw " string ";" *newline*))
 
 (define-builtin new () "{}")

@@ -1558,21 +1501,20 @@
 
 (define-builtin oget (object key)
   (js!selfcall
 
 (define-builtin oget (object key)
   (js!selfcall

-    "var tmp = " "(" object ")[" key "];" *newline*
+    "var tmp = " "(" object ")[xstring(" key ")];" *newline*

     "return tmp == undefined? " (ls-compile nil) ": tmp ;" *newline*))
 
 (define-builtin oset (object key value)
     "return tmp == undefined? " (ls-compile nil) ": tmp ;" *newline*))
 
 (define-builtin oset (object key value)

-  (code "((" object ")[" key "] = " value ")"))
+  (code "((" object ")[xstring(" key ")] = " value ")"))

 
 (define-builtin in (key object)
 
 (define-builtin in (key object)

-  (js!bool (code "((" key ") in (" object "))")))
+  (js!bool (code "(xstring(" key ") in (" object "))")))

 
 (define-builtin functionp (x)
   (js!bool (code "(typeof " x " == 'function')")))
 
 (define-builtin write-string (x)
 
 (define-builtin functionp (x)
   (js!bool (code "(typeof " x " == 'function')")))
 
 (define-builtin write-string (x)

-  (type-check (("x" "string" x))
-    "lisp.write(x)"))
+  (code "lisp.write(" x ")"))

 
 (define-builtin make-array (n)
   (js!selfcall
 
 (define-builtin make-array (n)
   (js!selfcall

@@ -1613,51 +1555,66 @@
       (code "values(" (join (mapcar #'ls-compile args) ", ") ")")
       (code "pv(" (join (mapcar #'ls-compile args) ", ") ")")))
 
       (code "values(" (join (mapcar #'ls-compile args) ", ") ")")
       (code "pv(" (join (mapcar #'ls-compile args) ", ") ")")))
 

-;; Receives the JS function as first argument as a literal string. The
-;; second argument is compiled and should evaluate to a vector of
-;; values to apply to the the function. The result returned.
-(define-builtin %js-call (fun args)
-  (code fun ".apply(this, " args ")"))

 
 

-(defun macro (x)
-  (and (symbolp x)
-       (let ((b (lookup-in-lexenv x *environment* 'function)))
-         (if (and b (eq (binding-type b) 'macro))
-             b
-             nil))))
+;;; Javascript FFI
+
+(define-compilation %js-vref (var)
+  (code "js_to_lisp(" var ")"))
+
+(define-compilation %js-vset (var val)
+  (code "(" var " = lisp_to_js(" (ls-compile val) "))"))
+
+(define-setf-expander %js-vref (var)
+  (let ((new-value (gensym)))
+    (unless (stringp var)
+      (error "`~S' is not a string." var))
+    (values nil
+            (list var)
+            (list new-value)
+            `(%js-vset ,var ,new-value)
+            `(%js-vref ,var))))
+

 
 #+common-lisp
 (defvar *macroexpander-cache*
   (make-hash-table :test #'eq))
 
 
 #+common-lisp
 (defvar *macroexpander-cache*
   (make-hash-table :test #'eq))
 

-(defun ls-macroexpand-1 (form)
+(defun !macro-function (symbol)
+  (unless (symbolp symbol)
+    (error "`~S' is not a symbol." symbol))
+  (let ((b (lookup-in-lexenv symbol *environment* 'function)))
+    (if (and b (eq (binding-type b) 'macro))
+        (let ((expander (binding-value b)))
+          (cond
+            #+common-lisp
+            ((gethash b *macroexpander-cache*)
+             (setq expander (gethash b *macroexpander-cache*)))
+            ((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.
+               ;;
+               #+jscl (setf (binding-value b) compiled)
+               #+common-lisp (setf (gethash b *macroexpander-cache*) compiled)
+               (setq expander compiled))))
+          expander)
+        nil)))
+
+(defun !macroexpand-1 (form)

   (cond
     ((symbolp form)
      (let ((b (lookup-in-lexenv form *environment* 'variable)))
        (if (and b (eq (binding-type b) 'macro))
            (values (binding-value b) t)
            (values form nil))))
   (cond
     ((symbolp form)
      (let ((b (lookup-in-lexenv form *environment* 'variable)))
        (if (and b (eq (binding-type b) 'macro))
            (values (binding-value b) t)
            (values form nil))))

-    ((consp form)
-     (let ((macro-binding (macro (car form))))
-       (if macro-binding
-           (let ((expander (binding-value macro-binding)))
-             (cond
-               #+common-lisp
-               ((gethash macro-binding *macroexpander-cache*)
-                (setq expander (gethash macro-binding *macroexpander-cache*)))
-               ((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.
-                  ;;
-                  #+jscl (setf (binding-value macro-binding) compiled)
-                  #+common-lisp (setf (gethash macro-binding *macroexpander-cache*) compiled)
-                  (setq expander compiled))))
-             (values (apply expander (cdr form)) t))
+    ((and (consp form) (symbolp (car form)))
+     (let ((macrofun (!macro-function (car form))))
+       (if macrofun
+           (values (apply macrofun (cdr form)) t)

            (values form nil))))
     (t
      (values form nil))))
            (values form nil))))
     (t
      (values form nil))))

@@ -1670,7 +1627,7 @@
     (unless (or (symbolp function)
                 (and (consp function)
                      (eq (car function) 'lambda)))
     (unless (or (symbolp function)
                 (and (consp function)
                      (eq (car function) 'lambda)))

-      (error "Bad function"))
+      (error "Bad function designator `~S'" function))

     (cond
       ((translate-function function)
        (concat (translate-function function) arglist))
     (cond
       ((translate-function function)
        (concat (translate-function function) arglist))

@@ -1690,7 +1647,7 @@
        (concat ";" *newline*))))
 
 (defun ls-compile (sexp &optional multiple-value-p)
        (concat ";" *newline*))))
 
 (defun ls-compile (sexp &optional multiple-value-p)

-  (multiple-value-bind (sexp expandedp) (ls-macroexpand-1 sexp)
+  (multiple-value-bind (sexp expandedp) (!macroexpand-1 sexp)

     (when expandedp
       (return-from ls-compile (ls-compile sexp multiple-value-p)))
     ;; The expression has been macroexpanded. Now compile it!
     (when expandedp
       (return-from ls-compile (ls-compile sexp multiple-value-p)))
     ;; The expression has been macroexpanded. Now compile it!

@@ -1706,11 +1663,8 @@
               (code (ls-compile `',sexp) ".value"))
              (t
               (ls-compile `(symbol-value ',sexp))))))
               (code (ls-compile `',sexp) ".value"))
              (t
               (ls-compile `(symbol-value ',sexp))))))

-        ((integerp sexp) (integer-to-string sexp))
-        ((floatp sexp) (float-to-string sexp))
-        ((characterp sexp) (code "\"" (escape-string (string sexp)) "\""))
-        ((stringp sexp) (code "\"" (escape-string sexp) "\""))
-        ((arrayp sexp) (literal sexp))
+        ((or (integerp sexp) (floatp sexp) (characterp sexp) (stringp sexp) (arrayp sexp))
+         (literal sexp))

         ((listp sexp)
          (let ((name (car sexp))
                (args (cdr sexp)))
         ((listp sexp)
          (let ((name (car sexp))
                (args (cdr sexp)))

@@ -1727,7 +1681,7 @@
              (t
               (compile-funcall name args)))))
         (t
              (t
               (compile-funcall name args)))))
         (t

-         (error (concat "How should I compile " (prin1-to-string sexp) "?")))))))
+         (error "How should I compile `~S'?" sexp))))))

 
 
 (defvar *compile-print-toplevels* nil)
 
 
 (defvar *compile-print-toplevels* nil)

@@ -1748,10 +1702,7 @@
       (t
        (when *compile-print-toplevels*
          (let ((form-string (prin1-to-string sexp)))
       (t
        (when *compile-print-toplevels*
          (let ((form-string (prin1-to-string sexp)))

-           (write-string "Compiling ")
-           (write-string (truncate-string form-string))
-           (write-line "...")))
-
+           (format t "Compiling ~a..." (truncate-string form-string))))

        (let ((code (ls-compile sexp multiple-value-p)))
          (code (join-trailing (get-toplevel-compilations)
                               (code ";" *newline*))
        (let ((code (ls-compile sexp multiple-value-p)))
          (code (join-trailing (get-toplevel-compilations)
                               (code ";" *newline*))