src/webui/devvars.lisp

   1
   2 (defpackage :lineal.devvars
   3   (:use :cl)
   4   (:export *file-tree* compile-tree 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
  21                                 &optional (fasl-dir src-dir)
  22                                 compile-all 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         (unless (and (not compile-all)
  31                                                          (probe-file fasl-file)
  32                                                          (< (file-write-date src-file)
  33                                                                         (file-write-date fasl-file)))
  34                 (when ensure-dirs
  35                         (ensure-directories-exist fasl-file))
  36                 (with-open-file
  37                         (fasl-strm fasl-file :direction :output
  38                                                                  :if-exists :supersede)
  39                         (compile-file src-file :output-file fasl-strm)))
  40         (load fasl-file))
  41
  42 (defun compile-tree
  43         (file-tree src-base fasl-base
  44                                                  &optional compile-all
  45                                                  &aux src-dir fasl-dir)
  46         (labels
  47                 ((ensure-first
  48                          (in-dir set-dirs-fn)
  49                          (funcall set-dirs-fn nil)
  50                          (recurse (car in-dir) set-dirs-fn t)
  51                          (dolist (x (cdr in-dir))
  52                                  (recurse x set-dirs-fn nil)))
  53                  (recurse
  54                          (file-tree set-dirs-fn ensure-dirs)
  55                          (if (consp file-tree)
  56                                  (let ((tmp-src src-dir)
  57                                                          (tmp-fasl fasl-dir)
  58                                                          (dir (car file-tree)))
  59                                          (ensure-first
  60                                                  (cdr file-tree)
  61                                                  (lambda (rootless)
  62                                                          (funcall set-dirs-fn
  63                                                                                                 (cons dir rootless))))
  64                                          (setq src-dir tmp-src
  65                                                                  fasl-dir tmp-fasl))
  66                                  ;V /file-tree/ is a file's name, V
  67                                  ;V compile it if necessary.      V
  68                                  (compile-if-new
  69                                          file-tree src-dir fasl-dir
  70                                          compile-all ensure-dirs))))
  71                 (ensure-first
  72                         file-tree
  73                         (lambda (rootless)
  74                                 (setq src-dir (append src-base rootless)
  75                                                         fasl-dir (append fasl-base rootless))))))
  76
  77 (defun compile-lineal ()
  78         (compile-tree
  79                 *file-tree* '(:relative "src")
  80                 '(:relative "fasl")))
  81