src/devvars.lisp

   1
   2 ;;; Just in case.
   3 (setq *read-default-float-format* 'double-float)
   4
   5 (defpackage :lineal.devvars
   6   (:use :cl)
   7   (:export *file-tree* compile-if-new compile-lineal))
   8
   9 (in-package :lineal.devvars)
  10
  11 ;;; When extending lineal, add files to this list.
  12 (defparameter *file-tree*
  13   '(("math" "math";<  :lineal.math
  14      :lineal.math "counting" "tuples"
  15      "matrices" "row-operns" "format")
  16     ("overload" "overload";<  :lineal.overload
  17      :lineal.overload "numbers" "tuples" "matrices")
  18     :lineal.overload
  19     ("util" "tails-do")
  20     ("overload" "concatenate" "crop" "row-operns" "format")
  21     "globals";<  :lineal
  22     :lineal
  23     "prefix-parser"
  24     "infix-parser"
  25     "save-restore"
  26     ("overload" :lineal.overload "client-fns")
  27     ))
  28
  29 (defun compile-if-new
  30   (name src-dir &key (fasl-dir src-dir)
  31         compile-all (load-all t) ensure-dirs
  32         &aux
  33         (src-file
  34           (make-pathname :directory src-dir
  35                          :name name :type "lisp"))
  36         (fasl-file
  37           (make-pathname :directory fasl-dir
  38                          :name name :type "fasl")))
  39   (if (and (not compile-all)
  40            (probe-file fasl-file)
  41            (< (file-write-date src-file)
  42               (file-write-date fasl-file)))
  43     (when load-all (load fasl-file))
  44     (progn
  45       (when ensure-dirs
  46         (ensure-directories-exist fasl-dir))
  47       (with-open-file
  48         (fasl-strm fasl-file :direction :output
  49                    :if-exists :supersede)
  50         (compile-file src-file :output-file fasl-strm))
  51       (load fasl-file))))
  52
  53 (defun compile-tree
  54   (file-tree src-dir fasl-dir
  55              &key compile-all (load-all t)
  56              &aux (src-tail (last src-dir))
  57              (fasl-tail (last fasl-dir)))
  58   (labels
  59     ((ensure-first
  60        (in-dir)
  61        (ensure-directories-exist
  62          (make-pathname :directory fasl-dir))
  63        (let ((*package* *package*))
  64          (dolist (x in-dir)
  65            (recurse x))))
  66      (recurse
  67        (file-tree)
  68        (ctypecase file-tree
  69          (cons
  70            ;; We have a new directory to recurse.
  71            (let ((tmp-src-tail src-tail)
  72                  (tmp-fasl-tail fasl-tail)
  73                  (dirtail (list (car file-tree))))
  74              (setq src-tail (setf (cdr src-tail) dirtail)
  75                    fasl-tail (setf (cdr fasl-tail) dirtail))
  76              (ensure-first (cdr file-tree))
  77              (setq src-tail (rplacd tmp-src-tail nil)
  78                    fasl-tail (rplacd tmp-fasl-tail nil))))
  79          (symbol
  80            ;; Use a different package
  81            ;; for loading subsequent files.
  82            (setq *package* (find-package file-tree)))
  83          (string
  84            ;; /file-tree/ is a file's name,
  85            ;; compile it if necessary.
  86            (compile-if-new
  87              file-tree src-dir
  88              :fasl-dir fasl-dir
  89              :compile-all compile-all
  90              :load-all load-all)))))
  91     (ensure-first file-tree)))
  92
  93 ;;; Just compile the whole program.
  94 (defun compile-lineal (&key compile-all (load-all t))
  95   (compile-tree
  96     *file-tree* '(:relative "src")
  97     '(:relative "fasl")
  98     :compile-all compile-all
  99     :load-all load-all))
 100