src/devvars.lisp

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