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