X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=ecmalisp.lisp;h=8cb2b9f8ef436a99eeaa7dec4c7269cd29cce767;hb=18e9b9400e56500abf7a05de3418aa9f569c2fbf;hp=adb316227d83c23ef5208d62cd261aedba00474f;hpb=111577f84281dc235f260f66548cedd41e9acf58;p=jscl.git

diff --git a/ecmalisp.lisp b/ecmalisp.lisp
index adb3162..8cb2b9f 100644
--- a/ecmalisp.lisp
+++ b/ecmalisp.lisp
@@ -36,6 +36,11 @@
                                                                  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)
 
@@ -47,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))
 
@@ -66,6 +70,7 @@
 
   (defmacro defun (name args &rest body)
     `(progn
+       (declaim (non-overridable ,name))
        (fset ',name
              (named-lambda ,(symbol-name name) ,args
                ,@(if (and (stringp (car body)) (not (null (cdr body))))
@@ -73,8 +78,6 @@
                      `((block ,name ,@body)))))
        ',name))
 
-  (defvar *package* (new))
-
   (defun null (x)
     (eq x nil))
 
@@ -84,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))
@@ -237,7 +229,6 @@
     `(prog1 (progn ,form1 ,result) ,@body)))
 
 
-
 ;;; This couple of helper functions will be defined in both Common
 ;;; Lisp and in Ecmalisp.
 (defun ensure-list (x)
@@ -429,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))
 
@@ -455,7 +451,118 @@
        (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
 ;;; not found in Common Lisp, for instance, while. So, we grow Common
@@ -580,7 +687,15 @@
 (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)
@@ -595,7 +710,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)
@@ -716,12 +833,48 @@
          (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
-      ((null ch)
+      ((or (null ch) (char= ch #\)))
        *eof*)
       ((char= ch #\()
        (%read-char stream)
@@ -746,7 +899,7 @@
        (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)))
@@ -841,18 +994,27 @@
         (push-to-lexenv b *environment* namespace)
         b)))
 
-(defun claims (symbol namespace)
-  (lookup-in-lexenv symbol *environment* namespace))
+(defun claimp (symbol namespace claim)
+  (let ((b (lookup-in-lexenv symbol *environment* namespace)))
+    (and b (member claim (binding-declarations b)))))
 
 (defun !proclaim (decl)
-  (unless (consp decl)
-    (error "Declaration must be a list"))
   (case (car decl)
     (notinline
-     (dolist (fname (cdr decl))
-       (let ((b (global-binding fname 'function 'function)))
-         (push-binding-declaration 'notinline b))))))
+     (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))))))
 
+#+ecmalisp
+(fset 'proclaim #'!proclaim)
 
 ;;; Special forms
 
@@ -1018,7 +1180,9 @@
      (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)))
@@ -1152,7 +1316,7 @@
     "        throw cf;" *newline*
     "}" *newline*))
 
-(define-compilation throw (id &optional value)
+(define-compilation throw (id value)
   (js!selfcall
     "throw ({"
     "type: 'catch', "
@@ -1415,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 string (x)
+(define-builtin char-to-string (x)
   (type-check (("x" "number" x))
     "String.fromCharCode(x)"))
 
@@ -1482,6 +1646,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*
@@ -1525,10 +1692,16 @@
         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
@@ -1542,9 +1715,13 @@
   (cond
     ((symbolp sexp)
      (let ((b (lookup-in-lexenv sexp *environment* 'variable)))
-       (if (eq (binding-type b) 'lexical-variable)
-           (binding-value 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)
@@ -1557,8 +1734,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
@@ -1601,6 +1777,29 @@
                (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)
@@ -1616,9 +1815,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*)