X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=ecmalisp.lisp;h=53b54901c6e93f12086ff1a25cc645f20fa8e1e0;hb=f9c561d081a1dda0da989db182dc9b50f2ecc208;hp=d417a870feec9d17a1c5126b50917becf1aead93;hpb=84d4526bebde9bfdae9cb932aad8e0e4cde4cebf;p=jscl.git

diff --git a/ecmalisp.lisp b/ecmalisp.lisp
index d417a87..53b5490 100644
--- a/ecmalisp.lisp
+++ b/ecmalisp.lisp
@@ -52,8 +52,7 @@
 
   (defmacro defvar (name value &optional docstring)
     `(progn
-       (unless (boundp ',name)
-	 (setq ,name ,value))
+       (unless (boundp ',name) (setq ,name ,value))
        ,@(when (stringp docstring) `((oset ',name "vardoc" ,docstring)))
        ',name))
 
@@ -79,8 +78,6 @@
                      `((block ,name ,@body)))))
        ',name))
 
-  (defvar *package* (new))
-
   (defun null (x)
     (eq x nil))
 
@@ -90,17 +87,6 @@
   (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))
@@ -434,6 +420,11 @@
           (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))
 
@@ -460,7 +451,104 @@
        (unless (symbolp x)
          (error "Wrong argument type! it should be a symbol"))
        (oget x "vardoc"))))
-  )
+
+  ;; Packages
+
+  (defvar *package-list* nil)
+
+  (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 *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 (cons (oget exports name) t)))))))))
+
+  (defun find-symbol (name &optional (package *package*))
+    (car (%find-symbol name package)))
+
+  (defun intern (name &optional (package *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)
+              (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
 ;;; not found in Common Lisp, for instance, while. So, we grow Common
@@ -600,7 +688,9 @@
                  (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)
@@ -846,9 +936,9 @@
         (push-to-lexenv b *environment* namespace)
         b)))
 
-(defun claims (symbol namespace)
+(defun claimp (symbol namespace claim)
   (let ((b (lookup-in-lexenv symbol *environment* namespace)))
-    (and b (binding-declarations b))))
+    (and b (member claim (binding-declarations b)))))
 
 (defun !proclaim (decl)
   (case (car decl)
@@ -865,6 +955,8 @@
        (let ((b (global-binding name 'function 'function)))
          (push-binding-declaration 'non-overridable b))))))
 
+#+ecmalisp
+(fset 'proclaim #'!proclaim)
 
 ;;; Special forms
 
@@ -1427,7 +1519,7 @@
 (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)"))
 
@@ -1494,6 +1586,9 @@
 
 (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*
@@ -1538,7 +1633,7 @@
 
 (defun compile-funcall (function args)
   (if (and (symbolp function)
-           (member 'non-overridable (claims function 'function)))
+           (claimp function 'function 'non-overridable))
       (concat (ls-compile `',function) ".function("
               (join (mapcar #'ls-compile args)
                     ", ")
@@ -1563,7 +1658,7 @@
        (cond
          ((eq (binding-type b) 'lexical-variable)
           (binding-value b))
-         ((member 'constant (binding-declarations b))
+         ((claimp sexp 'variable 'constant)
           (concat (ls-compile `',sexp) ".value"))
          (t
           (ls-compile `(symbol-value ',sexp))))))
@@ -1579,8 +1674,7 @@
             (apply comp args)))
          ;; Built-in functions
          ((and (assoc name *builtins*)
-               (or (not (lookup-in-lexenv name *environment* 'function))
-                   (member 'notinline (claims name 'function))))
+               (not (claimp name 'function 'notinline)))
           (let ((comp (second (assoc name *builtins*))))
             (apply comp args)))
          (t
@@ -1623,6 +1717,28 @@
                (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 lambda-code last
+            length let 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)
@@ -1638,9 +1754,7 @@
     (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*)