From 208c73a2f0efe2a798ac6ea959687c613dc7d5e8 Mon Sep 17 00:00:00 2001
From: =?utf8?q?David=20V=C3=A1zquez?= <davazp@gmail.com>
Date: Wed, 1 May 2013 05:10:59 +0100
Subject: [PATCH] Move more functions to list.lisp and create package.lisp

---
 jscl.lisp        |    3 +-
 src/boot.lisp    |  291 +-----------------------------------------------------
 src/list.lisp    |  157 +++++++++++++++++++++++++++++
 src/package.lisp |  138 ++++++++++++++++++++++++++
 4 files changed, 299 insertions(+), 290 deletions(-)
 create mode 100644 src/package.lisp

diff --git a/jscl.lisp b/jscl.lisp
index a25f431..e0074eb 100644
--- a/jscl.lisp
+++ b/jscl.lisp
@@ -20,10 +20,11 @@
   '(("boot"      :target)
     ("compat"    :host)
     ("utils"     :both)
+    ("list"      :target)
     ("print"     :target)
+    ("package"   :target)
     ("read"      :both)
     ("compiler"  :both)
-    ("list"      :target)
     ("toplevel"  :target)))
 
 (defun source-pathname
diff --git a/src/boot.lisp b/src/boot.lisp
index 2dfadd7..ada5db9 100644
--- a/src/boot.lisp
+++ b/src/boot.lisp
@@ -79,16 +79,6 @@
      (fset ',name #'(named-lambda ,name ,args ,@body))
      ',name))
 
-(defun null (x)
-  (eq x nil))
-
-(defun endp (x)
-  (if (null x)
-      t
-      (if (consp x)
-          nil
-          (error "type-error"))))
-
 (defmacro return (&optional value)
   `(return-from nil ,value))
 
@@ -118,32 +108,6 @@
 
 (defun not (x) (if x nil t))
 
-(defun cons (x y ) (cons x y))
-(defun consp (x) (consp 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 cdar (x) (cdr (car x)))
-(defun cddr (x) (cdr (cdr x)))
-(defun cadar (x) (car (cdr (car x))))
-(defun caddr (x) (car (cdr (cdr x))))
-(defun cdddr (x) (cdr (cdr (cdr x))))
-(defun cadddr (x) (car (cdr (cdr (cdr x)))))
-(defun first (x) (car x))
-(defun second (x) (cadr x))
-(defun third (x) (caddr x))
-(defun fourth (x) (cadddr x))
-(defun rest (x) (cdr x))
-
-(defun list (&rest args) args)
-(defun atom (x)
-  (not (consp x)))
-
 ;; Basic macros
 
 (defmacro incf (place &optional (delta 1))
@@ -376,43 +340,16 @@
          ,@body)
        (cdr ,head))))
 
-(defun map1 (func list)
-  (with-collect
-    (while list
-      (collect (funcall func (car list)))
-      (setq list (cdr list)))))
 
 (defmacro loop (&body body)
   `(while t ,@body))
 
-(defun mapcar (func list &rest lists)
-  (let ((lists (cons list lists)))
-    (with-collect
-      (block loop
-        (loop
-           (let ((elems (map1 #'car lists)))
-             (do ((tail lists (cdr tail)))
-                 ((null tail))
-               (when (null (car tail)) (return-from loop))
-               (rplaca tail (cdar tail)))
-             (collect (apply func elems))))))))
-
 (defun identity (x) x)
 
 (defun constantly (x)
   (lambda (&rest args)
     x))
 
-(defun copy-list (x)
-  (mapcar #'identity x))
-
-(defun list* (arg &rest others)
-  (cond ((null others) arg)
-        ((null (cdr others)) (cons arg (car others)))
-        (t (do ((x others (cdr x)))
-               ((null (cddr x)) (rplacd x (cadr x))))
-           (cons arg others))))
-
 (defun code-char (x) x)
 (defun char-code (x) x)
 (defun char= (x y) (= x y))
@@ -426,32 +363,8 @@
 (defun plusp (x) (< 0 x))
 (defun minusp (x) (< x 0))
 
-(defun listp (x)
-  (or (consp x) (null x)))
-
-(defun nthcdr (n list)
-  (while (and (plusp n) list)
-    (setq n (1- n))
-    (setq list (cdr list)))
-  list)
-
-(defun nth (n list)
-  (car (nthcdr n list)))
-
-(defun last (x)
-  (while (consp (cdr x))
-    (setq x (cdr x)))
-  x)
-
-(defun butlast (x)
-  (and (consp (cdr x))
-       (cons (car x) (butlast (cdr x)))))
-
-(defun member (x list)
-  (while list
-    (when (eql x (car list))
-      (return list))
-    (setq list (cdr list))))
+(defun atom (x)
+  (not (consp x)))
 
 (defun find (item list &key key (test #'eql))
   (dolist (x list)
@@ -542,13 +455,6 @@
       (incf pos))
     pos))
 
-(defun assoc (x alist &key (test #'eql))
-  (while alist
-    (if (funcall test x (caar alist))
-        (return)
-        (setq alist (cdr alist))))
-  (car alist))
-
 (defun string (x)
   (cond ((stringp x) x)
         ((symbolp x) (symbol-name x))
@@ -657,24 +563,6 @@
               ((null pairs)
                (reverse result)))))))
 
-(define-setf-expander car (x)
-  (let ((cons (gensym))
-        (new-value (gensym)))
-    (values (list cons)
-            (list x)
-            (list new-value)
-            `(progn (rplaca ,cons ,new-value) ,new-value)
-            `(car ,cons))))
-
-(define-setf-expander cdr (x)
-  (let ((cons (gensym))
-        (new-value (gensym)))
-    (values (list cons)
-            (list x)
-            (list new-value)
-            `(progn (rplacd ,cons ,new-value) ,new-value)
-            `(car ,cons))))
-
 ;; Incorrect typecase, but used in NCONC.
 (defmacro typecase (x &rest clausules)
   (let ((value (gensym)))
@@ -696,185 +584,10 @@
                                  (list nil)))))
                    clausules)))))
 
-;; The NCONC function is based on the SBCL's one.
-(defun nconc (&rest lists)
-  (flet ((fail (object)
-           (error "type-error in nconc")))
-    (do ((top lists (cdr top)))
-        ((null top) nil)
-      (let ((top-of-top (car top)))
-        (typecase top-of-top
-          (cons
-           (let* ((result top-of-top)
-                  (splice result))
-             (do ((elements (cdr top) (cdr elements)))
-                 ((endp elements))
-               (let ((ele (car elements)))
-                 (typecase ele
-                   (cons (rplacd (last splice) ele)
-                         (setf splice ele))
-                   (null (rplacd (last splice) nil))
-                   (atom (if (cdr elements)
-                             (fail ele)
-                             (rplacd (last splice) ele))))))
-             (return result)))
-          (null)
-          (atom
-           (if (cdr top)
-               (fail top-of-top)
-               (return top-of-top))))))))
-
-(defun nreconc (x y)
-  (do ((1st (cdr x) (if (endp 1st) 1st (cdr 1st)))
-       (2nd x 1st)                ; 2nd follows first down the list.
-       (3rd y 2nd))               ;3rd follows 2nd down the list.
-      ((atom 2nd) 3rd)
-    (rplacd 2nd 3rd)))
-
 (defun notany (fn seq)
   (not (some fn seq)))
 
 
-;; Packages
-
-(defvar *package-list* nil)
-
-(defun list-all-packages ()
-  *package-list*)
-
-(defun make-package (name &key 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 *js-package*
-  (make-package "JS"))
-
-(defvar *user-package*
-  (make-package "CL-USER" :use (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* ((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 &optional (package *package*))
-  (let* ((package (find-package-or-fail package))
-         (externals (%package-external-symbols package))
-         (symbols (%package-symbols package)))
-    (cond
-      ((in name externals)
-       (values (oget externals name) :external))
-      ((in name symbols)
-       (values (oget symbols name) :internal))
-      (t
-       (dolist (used (package-use-list package) (values nil nil))
-         (let ((exports (%package-external-symbols used)))
-           (when (in name exports)
-             (return (values (oget exports name) :inherit)))))))))
-
-(defun intern (name &optional (package *package*))
-  (let ((package (find-package-or-fail package)))
-    (multiple-value-bind (symbol foundp)
-        (find-symbol name package)
-      (if foundp
-          (values symbol foundp)
-          (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))
-              (when (eq package *js-package*)
-                (let ((sym-name (symbol-name symbol))
-                      (args (gensym)))
-                  ;; Generate a trampoline to call the JS function
-                  ;; properly. This trampoline is very inefficient,
-                  ;; but it still works. Ideas to optimize this are
-                  ;; provide a special lambda keyword
-                  ;; cl::&rest-vector to avoid list argument
-                  ;; consing, as well as allow inline declarations.
-                  (fset symbol
-                        (eval `(lambda (&rest ,args)
-                                 (let ((,args (list-to-vector ,args)))
-                                   (%js-call (%js-vref ,sym-name) ,args)))))
-                  ;; Define it as a symbol macro to access to the
-                  ;; Javascript variable literally.
-                  (%define-symbol-macro symbol `(%js-vref ,(string symbol)))))
-              (oset symbols name symbol)
-              (values symbol nil)))))))
-
-(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))))
-
-
 (defconstant internal-time-units-per-second 1000) 
 
 (defun get-internal-real-time ()
diff --git a/src/list.lisp b/src/list.lisp
index 15a433f..d2b0247 100644
--- a/src/list.lisp
+++ b/src/list.lisp
@@ -15,8 +15,63 @@
 
 ;;;; Various list functions
 
+(defun cons (x y ) (cons x y))
+(defun consp (x) (consp x))
+
+(defun listp (x)
+  (or (consp x) (null x)))
+
+(defun null (x)
+  (eq x nil))
+
+(defun endp (x)
+  (if (null x)
+      t
+      (if (consp x)
+          nil
+          (error "type-error"))))
+
+(defun car (x)
+  "Return the CAR part of a cons, or NIL if X is null."
+  (car x))
+
+(defun cdr (x) (cdr x))
+
+(defun first (x) (car x))
+(defun second (x) (cadr x))
+(defun third (x) (caddr x))
+(defun fourth (x) (cadddr x))
+(defun rest (x) (cdr x))
+
+(defun list (&rest args)
+  args)
+
+(defun list* (arg &rest others)
+  (cond ((null others) arg)
+        ((null (cdr others)) (cons arg (car others)))
+        (t (do ((x others (cdr x)))
+               ((null (cddr x)) (rplacd x (cadr x))))
+           (cons arg others))))
+
+(defun nthcdr (n list)
+  (while (and (plusp n) list)
+    (setq n (1- n))
+    (setq list (cdr list)))
+  list)
+
+(defun nth (n list)
+  (car (nthcdr n list)))
 
 ;;; The rest of the C[AD]*R functions; only a few were defined in boot.lisp
+(defun caar (x) (car (car x)))
+(defun cadr (x) (car (cdr x)))
+(defun cdar (x) (cdr (car x)))
+(defun cddr (x) (cdr (cdr x)))
+(defun cadar (x) (car (cdr (car x))))
+(defun caddr (x) (car (cdr (cdr x))))
+(defun cdddr (x) (cdr (cdr (cdr x))))
+(defun cadddr (x) (car (cdr (cdr (cdr x)))))
+
 (defun cadar  (x) (car (cdar  x)))
 (defun caaar  (x) (car (caar  x)))
 (defun caadr  (x) (car (cadr  x)))
@@ -40,6 +95,9 @@
 (defun cddddr (x) (cdr (cdddr x)))
 
 
+(defun copy-list (x)
+  (mapcar #'identity x))
+
 (defun copy-tree (tree)
   (if (consp tree)
     (cons (copy-tree (car tree))
@@ -65,3 +123,102 @@
               ,@(cdr newval)) 
          ,setter
          (car ,head)))))
+
+
+(defun map1 (func list)
+  (with-collect
+    (while list
+      (collect (funcall func (car list)))
+      (setq list (cdr list)))))
+
+(defun mapcar (func list &rest lists)
+  (let ((lists (cons list lists)))
+    (with-collect
+      (block loop
+        (loop
+           (let ((elems (map1 #'car lists)))
+             (do ((tail lists (cdr tail)))
+                 ((null tail))
+               (when (null (car tail)) (return-from loop))
+               (rplaca tail (cdar tail)))
+             (collect (apply func elems))))))))
+
+(defun last (x)
+  (while (consp (cdr x))
+    (setq x (cdr x)))
+  x)
+
+(defun butlast (x)
+  (and (consp (cdr x))
+       (cons (car x) (butlast (cdr x)))))
+
+(defun member (x list)
+  (while list
+    (when (eql x (car list))
+      (return list))
+    (setq list (cdr list))))
+
+
+(defun assoc (x alist &key (test #'eql))
+  (while alist
+    (if (funcall test x (caar alist))
+        (return)
+        (setq alist (cdr alist))))
+  (car alist))
+
+
+
+(define-setf-expander car (x)
+  (let ((cons (gensym))
+        (new-value (gensym)))
+    (values (list cons)
+            (list x)
+            (list new-value)
+            `(progn (rplaca ,cons ,new-value) ,new-value)
+            `(car ,cons))))
+
+(define-setf-expander cdr (x)
+  (let ((cons (gensym))
+        (new-value (gensym)))
+    (values (list cons)
+            (list x)
+            (list new-value)
+            `(progn (rplacd ,cons ,new-value) ,new-value)
+            `(car ,cons))))
+
+
+;; The NCONC function is based on the SBCL's one.
+(defun nconc (&rest lists)
+  (flet ((fail (object)
+           (error "type-error in nconc")))
+    (do ((top lists (cdr top)))
+        ((null top) nil)
+      (let ((top-of-top (car top)))
+        (typecase top-of-top
+          (cons
+           (let* ((result top-of-top)
+                  (splice result))
+             (do ((elements (cdr top) (cdr elements)))
+                 ((endp elements))
+               (let ((ele (car elements)))
+                 (typecase ele
+                   (cons (rplacd (last splice) ele)
+                         (setf splice ele))
+                   (null (rplacd (last splice) nil))
+                   (atom (if (cdr elements)
+                             (fail ele)
+                             (rplacd (last splice) ele))))))
+             (return result)))
+          (null)
+          (atom
+           (if (cdr top)
+               (fail top-of-top)
+               (return top-of-top))))))))
+
+
+(defun nreconc (x y)
+  (do ((1st (cdr x) (if (endp 1st) 1st (cdr 1st)))
+       (2nd x 1st)                ; 2nd follows first down the list.
+       (3rd y 2nd))               ;3rd follows 2nd down the list.
+      ((atom 2nd) 3rd)
+    (rplacd 2nd 3rd)))
diff --git a/src/package.lisp b/src/package.lisp
new file mode 100644
index 0000000..615d1e4
--- /dev/null
+++ b/src/package.lisp
@@ -0,0 +1,138 @@
+;; Packages
+
+(defvar *package-list* nil)
+
+(defun list-all-packages ()
+  *package-list*)
+
+(defun make-package (name &key 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 *js-package*
+  (make-package "JS"))
+
+(defvar *user-package*
+  (make-package "CL-USER" :use (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* ((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 &optional (package *package*))
+  (let* ((package (find-package-or-fail package))
+         (externals (%package-external-symbols package))
+         (symbols (%package-symbols package)))
+    (cond
+      ((in name externals)
+       (values (oget externals name) :external))
+      ((in name symbols)
+       (values (oget symbols name) :internal))
+      (t
+       (dolist (used (package-use-list package) (values nil nil))
+         (let ((exports (%package-external-symbols used)))
+           (when (in name exports)
+             (return (values (oget exports name) :inherit)))))))))
+
+(defun intern (name &optional (package *package*))
+  (let ((package (find-package-or-fail package)))
+    (multiple-value-bind (symbol foundp)
+        (find-symbol name package)
+      (if foundp
+          (values symbol foundp)
+          (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))
+              (when (eq package *js-package*)
+                (let ((sym-name (symbol-name symbol))
+                      (args (gensym)))
+                  ;; Generate a trampoline to call the JS function
+                  ;; properly. This trampoline is very inefficient,
+                  ;; but it still works. Ideas to optimize this are
+                  ;; provide a special lambda keyword
+                  ;; cl::&rest-vector to avoid list argument
+                  ;; consing, as well as allow inline declarations.
+                  (fset symbol
+                        (eval `(lambda (&rest ,args)
+                                 (let ((,args (list-to-vector ,args)))
+                                   (%js-call (%js-vref ,sym-name) ,args)))))
+                  ;; Define it as a symbol macro to access to the
+                  ;; Javascript variable literally.
+                  (%define-symbol-macro symbol `(%js-vref ,(string symbol)))))
+              (oset symbols name symbol)
+              (values symbol nil)))))))
+
+(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))))
-- 
1.7.10.4