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