From d57aa02287a70777193e629a4593efd62437a953 Mon Sep 17 00:00:00 2001
From: Alex Klinkhamer <grencez@gmail.com>
Date: Wed, 23 Jul 2008 23:56:54 -0400
Subject: [PATCH] +Most files' packages determined in src/devvars

---
 src/devvars.lisp              |  84 ++++++++++++++++--------------
 src/infix-parser.lisp         |   2 -
 src/math/counting.lisp        |   2 -
 src/math/format.lisp          |   2 -
 src/math/matrices.lisp        |   2 -
 src/math/row-operns.lisp      |   2 -
 src/math/tuples.lisp          |   2 -
 src/overload/client-fns.lisp  |   2 -
 src/overload/concatenate.lisp | 109 ---------------------------------------
 src/overload/crop.lisp        |  15 +++++-
 src/overload/format.lisp      |   2 -
 src/overload/matrices.lisp    |   2 -
 src/overload/numbers.lisp     |   2 -
 src/overload/row-operns.lisp  |   2 -
 src/overload/tuples.lisp      |   2 -
 src/prefix-parser.lisp        |   2 -
 src/save-restore.lisp         |   2 -
 src/util/tails-do.lisp        | 116 ++++++++++++++++++++++++++++++++++++++++++
 18 files changed, 175 insertions(+), 177 deletions(-)
 create mode 100644 src/util/tails-do.lisp

diff --git a/src/devvars.lisp b/src/devvars.lisp
index 60416b0..7716c08 100644
--- a/src/devvars.lisp
+++ b/src/devvars.lisp
@@ -7,14 +7,20 @@
 
 ;;; When extending lineal, add files to this list.
 (defparameter *file-tree*
-  '(("math" "math" "counting" "tuples" "matrices" "row-operns" "format")
-    ("overload" "overload" "numbers" "tuples"
-     "matrices" "concatenate" "crop" "row-operns" "format")
-    "globals"
+  '(("math" "math";<  :lineal.math
+     :lineal.math "counting" "tuples"
+     "matrices" "row-operns" "format")
+    ("overload" "overload";<  :lineal.overload
+     :lineal.overload "numbers" "tuples" "matrices")
+    :lineal.overload
+    ("util" "tails-do")
+    ("overload" "concatenate" "crop" "row-operns" "format")
+    "globals";<  :lineal
+    :lineal
     "prefix-parser"
     "infix-parser"
     "save-restore"
-    ("overload" "client-fns")
+    ("overload" :lineal.overload "client-fns")
     ))
 
 (defun compile-if-new
@@ -34,7 +40,7 @@
     (when load-all (load fasl-file))
     (progn
       (when ensure-dirs
-        (ensure-directories-exist fasl-file))
+        (ensure-directories-exist fasl-dir))
       (with-open-file
         (fasl-strm fasl-file :direction :output 
                    :if-exists :supersede)
@@ -42,42 +48,44 @@
       (load fasl-file))))
 
 (defun compile-tree
-  (file-tree src-base fasl-base
+  (file-tree src-dir fasl-dir
              &key compile-all (load-all t)
-             &aux src-dir fasl-dir)
+             &aux (src-tail (last src-dir))
+             (fasl-tail (last fasl-dir)))
   (labels
     ((ensure-first
-       (in-dir set-dirs-fn)
-       (funcall set-dirs-fn nil)
-       (recurse (car in-dir) set-dirs-fn t)
-       (dolist (x (cdr in-dir))
-         (recurse x set-dirs-fn nil)))
+       (in-dir)
+       (ensure-directories-exist
+         (make-pathname :directory fasl-dir))
+       (let ((*package* *package*))
+         (dolist (x in-dir)
+           (recurse x))))
      (recurse
-       (file-tree set-dirs-fn ensure-dirs)
-       (if (consp file-tree)
-         (let ((tmp-src src-dir)
-               (tmp-fasl fasl-dir)
-               (dir (car file-tree)))
-           (ensure-first
-             (cdr file-tree)
-             (lambda (rootless)
-               (funcall set-dirs-fn
-                        (cons dir rootless))))
-           (setq src-dir tmp-src
-                 fasl-dir tmp-fasl))
-         ;V /file-tree/ is a file's name, V
-         ;V compile it if necessary.      V
-         (compile-if-new
-           file-tree src-dir
-           :fasl-dir fasl-dir
-           :compile-all compile-all
-           :load-all load-all
-           :ensure-dirs ensure-dirs))))
-    (ensure-first
-      file-tree
-      (lambda (rootless)
-        (setq src-dir (append src-base rootless)
-              fasl-dir (append fasl-base rootless))))))
+       (file-tree)
+       (ctypecase file-tree
+         (cons
+           ;; We have a new directory to recurse.
+           (let ((tmp-src-tail src-tail)
+                 (tmp-fasl-tail fasl-tail)
+                 (dirtail (list (car file-tree))))
+             (setq src-tail (setf (cdr src-tail) dirtail)
+                   fasl-tail (setf (cdr fasl-tail) dirtail))
+             (ensure-first (cdr file-tree))
+             (setq src-tail (rplacd tmp-src-tail nil)
+                   fasl-tail (rplacd tmp-fasl-tail nil))))
+         (symbol
+           ;; Use a different package
+           ;; for loading subsequent files.
+           (setq *package* (find-package file-tree)))
+         (string
+           ;; /file-tree/ is a file's name,
+           ;; compile it if necessary.
+           (compile-if-new
+             file-tree src-dir
+             :fasl-dir fasl-dir
+             :compile-all compile-all
+             :load-all load-all)))))
+    (ensure-first file-tree)))
 
 ;;; Just compile the whole program.
 (defun compile-lineal (&key compile-all (load-all t))
diff --git a/src/infix-parser.lisp b/src/infix-parser.lisp
index 971dd61..9b652aa 100644
--- a/src/infix-parser.lisp
+++ b/src/infix-parser.lisp
@@ -23,8 +23,6 @@
 ; complex because I don't require ONE function parameter to be
 ; enclosed in parentheses, multiple parameters require them.
 
-(in-package :lineal)
-
 ;;; Define variables as constant integers
 (defmacro enumerate-constants (&rest syms &aux (v 0))
   (declare (integer v))
diff --git a/src/math/counting.lisp b/src/math/counting.lisp
index 93f159f..b1191ff 100644
--- a/src/math/counting.lisp
+++ b/src/math/counting.lisp
@@ -1,6 +1,4 @@
 
-(in-package :lineal.math)
-
 ;V factorial V
 ;V    n!     V
 (defun factorial (n)
diff --git a/src/math/format.lisp b/src/math/format.lisp
index 2bd2379..6a133d1 100644
--- a/src/math/format.lisp
+++ b/src/math/format.lisp
@@ -1,6 +1,4 @@
 
-(in-package :lineal.math)
-
 (defun max-width (&rest nums)
   (loop :for x :in nums
         :maximize (length (princ-to-string x))))
diff --git a/src/math/matrices.lisp b/src/math/matrices.lisp
index 485bed0..787b186 100644
--- a/src/math/matrices.lisp
+++ b/src/math/matrices.lisp
@@ -1,6 +1,4 @@
 
-(in-package :lineal.math)
-
 (defun mtrix-transpose (mtrix)
   (apply #'mapcar #'list mtrix))
 
diff --git a/src/math/row-operns.lisp b/src/math/row-operns.lisp
index a57293a..1858b48 100644
--- a/src/math/row-operns.lisp
+++ b/src/math/row-operns.lisp
@@ -1,6 +1,4 @@
 
-(in-package :lineal.math)
-
 ; u - kv
 (defun tuple-multiple-nsubtrn (u k v)
   "Vector /u/ minus scalar /k/ times vector /v/"
diff --git a/src/math/tuples.lisp b/src/math/tuples.lisp
index d2b7167..cea9ad8 100644
--- a/src/math/tuples.lisp
+++ b/src/math/tuples.lisp
@@ -1,6 +1,4 @@
 
-(in-package :lineal.math)
-
 ;V Basic vector/tuple operations, V
 ;V they behave like the normal    V
 ;V lisp math functions.           V
diff --git a/src/overload/client-fns.lisp b/src/overload/client-fns.lisp
index 5d70d36..1f8e729 100644
--- a/src/overload/client-fns.lisp
+++ b/src/overload/client-fns.lisp
@@ -1,6 +1,4 @@
 
-(in-package :lineal.overload)
-
 (mapc (lambda (kvpair)
         (destructuring-bind (k v) kvpair
           (set (intern k :lineal.client-vars) v)))
diff --git a/src/overload/concatenate.lisp b/src/overload/concatenate.lisp
index 7c256c6..e27b541 100644
--- a/src/overload/concatenate.lisp
+++ b/src/overload/concatenate.lisp
@@ -1,6 +1,4 @@
 
-(in-package :lineal.overload)
-
 (defun over-cat (&rest args)
   (if args
     (if (cdr args)
@@ -27,113 +25,6 @@
 (defmethod vcat2 (u (v list))
   (vcat2 u (tuple-list v)))
 
-;V The do* macro with tails.V
-(defmacro tails-do*
-  (((&body tails-args) . do-args)
-   (s-pred . s-cleanup) . s-proc)
-  (let ((begin-loop-tag (gensym))
-        (end-loop-tag (gensym))
-        pre-inits post-inits
-        do-setqs tail-setqs
-        s-conditail-setqs
-        s-declarations
-        var-init-p)
-    (loop
-      :for (v a ta condit) :in tails-args
-      ;V See if /v/ has an initial value.V
-      :for init-v = (when (consp v)
-                      (setq var-init-p t)
-                      (prog1 (cadr v)
-                        (setq v (car v))))
-      ;V Find if the tail should be V
-      ;V initialized as something.  V
-      :for tadef =
-      (if ta
-        (if (consp ta)
-          (cadr (shiftf ta (car ta)))
-          (if a nil ta))
-        ;V No tail mentioned by user, set /ta/ V
-        ;V as a symbol name and return nil.    V
-        (shiftf ta (gensym)))
-      ;> /ta/ is now strictly the variable name referring to the
-      ;> accum-list's tail. There is always a tail at this point. 
-      ;V Find what the accum-list is initialized with     V
-      ;V and what its part of the /post-inits/ looks like.V
-      :for (adef a-init-part) =
-      (if (listp a)
-        (list (when a (cadr (shiftf a (car a))))
-              ;^ If /a/ is a cons, set it to its symbol  ^
-              ;^ name and return its initialization form.^
-              (if tadef `(list ,v) 
-                `(if ,a (cdr (rplacd (last ,a) (cons ,v nil)))
-                   (setq ,a (list ,v)))))
-        ;V The accum-list does not have an init value,  V
-        ;V but will be initialized in the beginning let.V
-        `(nil (setq ,a (cons ,v nil))))
-      ;> /a/ is now strictly the variable name referring to the
-      ;> accum-list or nil if the list exists before this macro.
-      :for default-val-setq =
-      (when condit
-        (if (consp condit)
-          (when (cdr condit)
-            (cons v (cdr condit)))
-          (list v nil)))
-      ;V Collect variables and initializations V
-      ;V to be used in the outer let form.     V
-      :collect (if init-v (list v init-v) v) :into vlist
-      :when a
-      :collect (if adef (list a adef) a) :into vlist
-      :collect (if tadef (list ta tadef) ta) :into vlist
-      ;V The stuff for /post-inits/.V
-      :nconc
-      `(,ta ,(if tadef `(cdr (rplacd ,ta ,a-init-part))
-               a-init-part))
-      :into ilist
-      :if condit
-      :nconc default-val-setq :into ilist
-      :and :collect
-      `(if ,(if (consp condit) (car condit) v)
-         (setq ,ta (cdr (rplacd ,ta (cons ,v nil)))
-               ,@default-val-setq))
-      :into condlist
-      :else :nconc
-      `(,ta (cdr (rplacd ,ta (cons ,v nil))))
-      :into qlist
-      :finally (setq pre-inits vlist
-                     post-inits ilist
-                     s-conditail-setqs condlist
-                     tail-setqs qlist))
-    ;V Handle regular do arguments.V
-    (loop :for (v i a) :in do-args
-          :collect (if i (list v i) v) :into vlist
-          :when a :collect v :into alist
-          :and :collect a :into alist
-          :finally (nconc pre-inits vlist)
-          (setq do-setqs alist))
-    (loop :while (and (consp (car s-proc))
-                      (eq 'declare (caar s-proc)))
-          :collect (pop s-proc) :into decl
-          :finally (setq s-declarations decl))
-    `(let* (,@pre-inits);< All variable initializations.
-       ,@s-declarations
-       (unless ,s-pred
-         ;V Run loop contents here only if the first V
-         ;V value to accumulate is not specified.    V
-         ,@(unless var-init-p s-proc)
-         ;V Give all tails a value if they don't have one, V
-         (setq ,@post-inits);< update some nil lists too.
-         (tagbody
-           ,begin-loop-tag
-           (setq ,@do-setqs);< Normal do-loop updates.
-           (if ,s-pred (go ,end-loop-tag))
-           ,@s-proc;< Run inner loop.
-           ,@s-conditail-setqs;< Conditional tail updates.
-           (setq ,@tail-setqs);< Update all tails.
-           (go ,begin-loop-tag)
-           ,end-loop-tag))
-       ;V Loop is over, run user's cleanup forms.V
-       ,@s-cleanup)))
-
 (defmacro cat2-fill
   (((arow s-arows)
     (brow s-brows)
diff --git a/src/overload/crop.lisp b/src/overload/crop.lisp
index 4a03535..f7091b4 100644
--- a/src/overload/crop.lisp
+++ b/src/overload/crop.lisp
@@ -1,11 +1,14 @@
 
-(in-package :lineal.overload)
-
 (defmethod over-crop ((n integer) (u tuple))
   (declare (ignore n)) u)
 (defmethod over-crop ((u tuple) (n integer))
   (declare (ignore n)) u)
 
+(defmethod over-crop ((u list) n)
+  (declare (ignore n)) u)
+(defmethod over-crop (n (u list))
+  (declare (ignore n)) u)
+
 (defmethod over-vcrop ((n integer) (u tuple))
   (if (= 1 n)
     (car (tuple-elems u))
@@ -16,6 +19,10 @@
           :finally
           (return (make-tuple :dim dim :elems elems)))))
 
+(defmethod over-vcrop (n (u list))
+  (over-vcrop n (tuple-list u)))
+
+
 (defmethod over-vcrop ((u tuple) (n integer))
   (if (= 1 n)
     (car (last (tuple-elems u)))
@@ -24,6 +31,10 @@
                   :elems (nthcdr (- (tuple-dim u) dim)
                                  (tuple-elems u))))))
 
+(defmethod over-vcrop ((u list) n)
+  (over-vcrop (tuple-list u) n))
+
+
 (defmethod over-crop ((n integer) (a mtrix))
   (if (= n 1)
     (make-tuple
diff --git a/src/overload/format.lisp b/src/overload/format.lisp
index 5ecd732..f3e80d2 100644
--- a/src/overload/format.lisp
+++ b/src/overload/format.lisp
@@ -1,6 +1,4 @@
 
-(in-package :lineal.overload)
-
 (defgeneric over-format (a strm))
 
 (defmethod over-format ((n float) s)
diff --git a/src/overload/matrices.lisp b/src/overload/matrices.lisp
index 36420ab..68e73c1 100644
--- a/src/overload/matrices.lisp
+++ b/src/overload/matrices.lisp
@@ -1,6 +1,4 @@
 
-(in-package :lineal.overload)
-
 (defstruct mtrix
   (dimdom 0 :type integer)
   (dimcodom 0 :type integer)
diff --git a/src/overload/numbers.lisp b/src/overload/numbers.lisp
index bd57112..dae611c 100644
--- a/src/overload/numbers.lisp
+++ b/src/overload/numbers.lisp
@@ -1,6 +1,4 @@
 
-(in-package :lineal.overload)
-
 (defmethod over-multv-inverse ((a number)) (/ a))
 (defmethod expt2n (a b) (expt a b))
 
diff --git a/src/overload/row-operns.lisp b/src/overload/row-operns.lisp
index 5d848e4..2e2f8bc 100644
--- a/src/overload/row-operns.lisp
+++ b/src/overload/row-operns.lisp
@@ -1,6 +1,4 @@
 
-(in-package :lineal.overload)
-
 (defun over-det (a)
   (if (= (mtrix-dimdom a) (mtrix-dimcodom a))
     (det (mtrix-elems a))
diff --git a/src/overload/tuples.lisp b/src/overload/tuples.lisp
index 90c3c2f..075198c 100644
--- a/src/overload/tuples.lisp
+++ b/src/overload/tuples.lisp
@@ -1,6 +1,4 @@
 
-(in-package :lineal.overload)
-
 (defstruct tuple
   (dim 0 :type (integer 0 *))
   (elems nil :type list))
diff --git a/src/prefix-parser.lisp b/src/prefix-parser.lisp
index aac90d7..7a791ee 100644
--- a/src/prefix-parser.lisp
+++ b/src/prefix-parser.lisp
@@ -1,6 +1,4 @@
 
-(in-package :lineal)
-
 (defun fail (arg)
   (format nil "What is this \"~A\" of which you speak?~%" arg))
 
diff --git a/src/save-restore.lisp b/src/save-restore.lisp
index 602e5bd..d18c796 100644
--- a/src/save-restore.lisp
+++ b/src/save-restore.lisp
@@ -1,6 +1,4 @@
 
-(in-package :lineal)
-
 (defgeneric persist-to (v strm))
 (defmethod persist-to ((k number) strm)
   (format strm " ~S" k))
diff --git a/src/util/tails-do.lisp b/src/util/tails-do.lisp
new file mode 100644
index 0000000..87e51d8
--- /dev/null
+++ b/src/util/tails-do.lisp
@@ -0,0 +1,116 @@
+
+; by Alex Klinkhamer  (:handle grencez)
+; Update: 2008.07.19
+;
+;  Legal info:
+; You may exploit this code,
+;    and it may exploit you.
+; I am not responsible for either.
+
+;;; The do* macro with tails.
+(defmacro tails-do*
+  (((&body tails-args) . do-args)
+   (s-pred . s-cleanup) . s-proc)
+  (let ((begin-loop-tag (gensym))
+        (end-loop-tag (gensym))
+        pre-inits post-inits
+        do-setqs tail-setqs
+        s-conditail-setqs
+        s-declarations
+        var-init-p)
+    (loop
+      :for (v a ta condit) :in tails-args
+      ;V See if /v/ has an initial value.V
+      :for init-v = (when (consp v)
+                      (setq var-init-p t)
+                      (prog1 (cadr v)
+                        (setq v (car v))))
+      ;V Find if the tail should be V
+      ;V initialized as something.  V
+      :for tadef =
+      (if ta
+        (if (consp ta)
+          (cadr (shiftf ta (car ta)))
+          (if a nil ta))
+        ;V No tail mentioned by user, set /ta/ V
+        ;V as a symbol name and return nil.    V
+        (shiftf ta (gensym)))
+      ;> /ta/ is now strictly the variable name referring to the
+      ;> accum-list's tail. There is always a tail at this point. 
+      ;V Find what the accum-list is initialized with     V
+      ;V and what its part of the /post-inits/ looks like.V
+      :for (adef a-init-part) =
+      (if (listp a)
+        (list (when a (cadr (shiftf a (car a))))
+              ;^ If /a/ is a cons, set it to its symbol  ^
+              ;^ name and return its initialization form.^
+              (if tadef `(list ,v) 
+                `(if ,a (setf (cdr (last ,a)) (cons ,v nil))
+                   (setq ,a (list ,v)))))
+        ;V The accum-list does not have an init value,  V
+        ;V but will be initialized in the beginning let.V
+        `(nil (setq ,a (cons ,v nil))))
+      ;> /a/ is now strictly the variable name referring to the
+      ;> accum-list or nil if the list exists before this macro.
+      :for default-val-setq =
+      (when condit
+        (if (consp condit)
+          (when (cdr condit)
+            (cons v (cdr condit)))
+          (list v nil)))
+      ;V Collect variables and initializations V
+      ;V to be used in the outer let form.     V
+      :collect (if init-v (list v init-v) v) :into vlist
+      :when a
+      :collect (if adef (list a adef) a) :into vlist
+      :collect (if tadef (list ta tadef) ta) :into vlist
+      ;V The stuff for /post-inits/.V
+      :nconc
+      `(,ta ,(if tadef `(setf (cdr ,ta) ,a-init-part)
+               a-init-part))
+      :into ilist
+      :if condit
+      :nconc default-val-setq :into ilist
+      :and :collect
+      `(if ,(if (consp condit) (car condit) v)
+         (setq ,ta (setf (cdr ,ta) (cons ,v nil))
+               ,@default-val-setq))
+      :into condlist
+      :else :nconc
+      `(,ta (setf (cdr ,ta) (cons ,v nil)))
+      :into qlist
+      :finally (setq pre-inits vlist
+                     post-inits ilist
+                     s-conditail-setqs condlist
+                     tail-setqs qlist))
+    ;V Handle regular do arguments.V
+    (loop :for (v i a) :in do-args
+          :collect (if i (list v i) v) :into vlist
+          :when a :collect v :into alist
+          :and :collect a :into alist
+          :finally (nconc pre-inits vlist)
+          (setq do-setqs alist))
+    (loop :while (and (consp (car s-proc))
+                      (eq 'declare (caar s-proc)))
+          :collect (pop s-proc) :into decl
+          :finally (setq s-declarations decl))
+    `(let* (,@pre-inits);< All variable initializations.
+       ,@s-declarations
+       (unless ,s-pred
+         ;V Run loop contents here only if the first V
+         ;V value to accumulate is not specified.    V
+         ,@(unless var-init-p s-proc)
+         ;V Give all tails a value if they don't have one, V
+         (setq ,@post-inits);< update some nil lists too.
+         (tagbody
+           ,begin-loop-tag
+           (setq ,@do-setqs);< Normal do-loop updates.
+           (if ,s-pred (go ,end-loop-tag))
+           ,@s-proc;< Run inner loop.
+           ,@s-conditail-setqs;< Conditional tail updates.
+           (setq ,@tail-setqs);< Update all tails.
+           (go ,begin-loop-tag)
+           ,end-loop-tag))
+       ;V Loop is over, run user's cleanup forms.V
+       ,@s-cleanup)))
+
-- 
2.11.4.GIT