Allow to use keywords in the compiler

[jscl.git] / ecmalisp.lisp

diff --git a/ecmalisp.lisp b/ecmalisp.lisp
index d705668..ac6f02b 100644 (file)
--- a/ecmalisp.lisp
+++ b/ecmalisp.lisp
@@ -587,25 +587,25 @@
   ;; 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*)
+    (let* ((package
+            (if (in "package" symbol)
+                (find-package-or-fail (oget symbol "package"))
+                *common-lisp-package*))
+           (symbols (%package-symbols package)))
+      (oset symbol "package" package)
+      (when (eq package *keyword-package*)
+        (oset symbol "value" symbol))
       (oset symbols (symbol-name symbol) symbol)))
 
-  (defun %find-symbol (name package)
+  (defun find-symbol (name &optional (package *package*))
     (let* ((package (find-package-or-fail package))
            (symbols (%package-symbols package)))
       (if (in name symbols)
-          (cons (oget symbols name) t)
-          (dolist (used (package-use-list package) (cons nil nil))
+          (values (oget symbols name) t)
+          (dolist (used (package-use-list package) (values nil nil))
             (let ((exports (%package-external-symbols used)))
               (when (in name exports)
-                (return (cons (oget exports name) t))))))))
-
-  (defun find-symbol (name &optional (package *package*))
-    (let ((x (%find-symbol name package)))
-      (if (cdr x)
-          (values (car x) t)
-          (values nil nil))))
+                (return (values (oget exports name) t))))))))
 
   (defun intern (name &optional (package *package*))
     (let ((package (find-package-or-fail package)))
@@ -780,15 +780,17 @@
   (defun prin1-to-string (form)
     (cond
       ((symbolp form)
-       (if (cdr (%find-symbol (symbol-name form) *package*))
-           (symbol-name form)
-           (let ((package (symbol-package form))
-                 (name (symbol-name form)))
-             (concat (cond
-                       ((null package) "#")
-                       ((eq package (find-package "KEYWORD")) "")
-                       (t (package-name package)))
-                     ":" name))))
+       (multiple-value-bind (symbol foundp)
+           (find-symbol (symbol-name form) *package*)
+         (if (and foundp (eq symbol form))
+             (symbol-name form)
+             (let ((package (symbol-package form))
+                   (name (symbol-name form)))
+               (concat (cond
+                         ((null package) "#")
+                         ((eq package (find-package "KEYWORD")) "")
+                         (t (package-name package)))
+                       ":" name)))))
       ((integerp form) (integer-to-string form))
       ((stringp form) (concat "\"" (escape-string form) "\""))
       ((functionp form)
@@ -1348,12 +1350,17 @@
     ((symbolp sexp)
      (or (cdr (assoc sexp *literal-symbols*))
         (let ((v (genlit))
-              (s #+common-lisp (concat "{name: \"" (escape-string (symbol-name sexp)) "\"}")
-                 #+ecmalisp
-                  (let ((package (symbol-package sexp)))
-                    (if (null package)
-                        (concat "{name: \"" (escape-string (symbol-name sexp)) "\"}")
-                        (ls-compile `(intern ,(symbol-name sexp) ,(package-name package)))))))
+              (s #+common-lisp
+                 (let ((package (symbol-package sexp)))
+                   (if (eq package (find-package "KEYWORD"))
+                       (concat "{name: \"" (escape-string (symbol-name sexp))
+                               "\", 'package': '" (package-name package) "'}")
+                       (concat "{name: \"" (escape-string (symbol-name sexp)) "\"}")))
+                 #+ecmalisp
+                 (let ((package (symbol-package sexp)))
+                   (if (null package)
+                       (concat "{name: \"" (escape-string (symbol-name sexp)) "\"}")
+                       (ls-compile `(intern ,(symbol-name sexp) ,(package-name package)))))))
           (push (cons sexp v) *literal-symbols*)
           (toplevel-compilation (concat "var " v " = " s))
           v)))