123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113 |
- ;;; Copyright 2010 by Christian Jaeger <chrjae@gmail.com>
- ;;; This file is part of GIT System.
- ;;;
- ;;; GIT System is free software: you can redistribute it and/or modify
- ;;; it under the terms of the GNU Lesser General Public License as published by
- ;;; the Free Software Foundation, either version 3 of the License, or
- ;;; (at your option) any later version.
- ;;;
- ;;; GIT System is distributed in the hope that it will be useful,
- ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
- ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ;;; GNU Lesser General Public License for more details.
- ;;;
- ;;; You should have received a copy of the GNU Lesser General Public License
- ;;; along with GIT System. If not, see <http://www.gnu.org/licenses/>.
- ;; possibly-compile and load
- ;; BUGS:
- ;; - sometimes when loading compiled object, editing file, reloading
- ;; into running system it will compile and load, then on subsequent
- ;; load give the 'cannot load multiple times' error
- ;; - sometimes, with (define compile-mode 'c), a file that has been
- ;; compiled, when edited, will not get reloaded into the running
- ;; system from source, neither freshly compiled. strange. Only time
- ;; this happened was with Serialization-Deserialization.scm
- (define-macro (compile-time-define-if-not-defined name expr)
- (with-exception-catcher
- (lambda (e)
- (eval `(define ,name ,expr)))
- (lambda ()
- (eval name) ;; if it doesn't exist, will define it
- '(begin))))
- (compile-time-define-if-not-defined objects-loaded (make-table)) ;; name to [file mtime,no,] index
- (define (object-load-if-changed name i)
- (define (load+set)
- (load name)
- (table-set! objects-loaded name i))
- (if (eq? compile-mode 's)
- (error "BUG"))
- (cond ((table-ref objects-loaded name #f)
- => (lambda (oldi)
- (if (> i oldi)
- (load+set)
- #f)))
- (else
- (load+set))))
- (define (i/load name)
- (let ((sourcefile (string-append name ".scm")))
- (load sourcefile)))
- (define (set-compiler:perhaps-add lis key val) ;; ignore if val is false
- (if val
- (cons key (cons val lis))
- lis))
- (define mod:compiled? (make-parameter #f))
- (define (c/load name #!key ld-options cc-options)
- ;; possibly compile and load:
- (let* ((compile-options (set-compiler:perhaps-add
- (set-compiler:perhaps-add
- compile-options
- ld-options: ld-options)
- cc-options: cc-options))
- (sourcefile (string-append name ".scm")))
- (case compile-mode
- ((s) ;; always source
- (load sourcefile))
- (else
- (let* ((sourceinf (file-info sourcefile))
- (evtl-compile+load
- (lambda (i)
- (case compile-mode
- ((l) ;; load binary or source, whatever is newer (left up to Gambit)
- (error "not yet implemented"))
- ((c) ;; compile
- (println (list "compiling: " name))
- (parameterize
- ((mod:compiled? #t))
- (apply compile-file sourcefile compile-options))
- ;; gives #f on failure; but, we want to go to the debugger
- ;; maybe?, or at least stop the process, so:
- (object-load-if-changed name i))
- (else
- (error "invalid compile-mode value:" compile-mode))))))
- (cond ((let lp ((i 1)
- (obinf #f))
- (let ((obp (string-append name ".o"
- (number->string i))))
- (if (file-exists? obp)
- (lp (+ i 1)
- (file-info obp))
- (and obinf
- (cons obinf (- i 1))))))
- =>
- (lambda (obinf+i)
- (if (> (time->seconds (file-info-last-modification-time sourceinf))
- (time->seconds (file-info-last-modification-time (car obinf+i))))
- (evtl-compile+load (cdr obinf+i))
- ;; assuming macros haven't changed
- (object-load-if-changed name (cdr obinf+i)))))
- (else
- ;; no binary
- (evtl-compile+load 1))))))))
|