src/devvars.lisp

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