[bpt/guile.git] / module / system / vm / load.scm

;;; Guile VM compiling loader

;; Copyright (C) 2001 Free Software Foundation, Inc.

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; 
;; This program 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 General Public License for more details.
;; 
;; You should have received a copy of the GNU General Public License
;; along with this program; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Code:

(define-module (system vm load)
  :use-module (system vm core)
  :autoload (system base language) (compile-file-in lookup-language)
  :use-module (ice-9 regex)
  :export (load/compile))

(define *the-vm* (make-vm))

(define (load/compile file)
  (let* ((file (file-name-full-name file))
	 (compiled (object-file-name file)))
    (if (or (not (file-exists? compiled))
	    (> (stat:mtime (stat file)) (stat:mtime (stat compiled))))
	(compile-file-in file #f (lookup-language 'gscheme)))
    (let ((bytes (make-uniform-vector (stat:size (stat compiled)) #\a)))
      (call-with-input-file compiled
	(lambda (p) (uniform-vector-read! bytes p)))
      (vm-load *the-vm* bytes))))

(define (file-name-full-name filename)
  (let ((oldname (and (current-load-port)
		      (port-filename (current-load-port)))))
    (if (and oldname
	     (> (string-length filename) 0)
	     (not (char=? (string-ref filename 0) #\/))
	     (not (string=? (dirname oldname) ".")))
	(string-append (dirname oldname) "/" filename)
	filename)))

(define (object-file-name file)
  (let ((m (string-match "\\.[^.]*$" file)))
    (string-append (if m (match:prefix m) file) ".go")))
Commit	Line	Data
d4ae3ae6 KN	1	;;; Guile VM compiling loader
	2
	3	;; Copyright (C) 2001 Free Software Foundation, Inc.
	4
	5	;; This program is free software; you can redistribute it and/or modify
	6	;; it under the terms of the GNU General Public License as published by
	7	;; the Free Software Foundation; either version 2, or (at your option)
	8	;; any later version.
	9	;;
	10	;; This program is distributed in the hope that it will be useful,
	11	;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	12	;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	13	;; GNU General Public License for more details.
	14	;;
	15	;; You should have received a copy of the GNU General Public License
	16	;; along with this program; see the file COPYING. If not, write to
	17	;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
	18	;; Boston, MA 02111-1307, USA.
	19
	20	;;; Code:
	21
	22	(define-module (system vm load)
	23	:use-module (system vm core)
d4ae3ae6 KN	24	:autoload (system base language) (compile-file-in lookup-language)
	25	:use-module (ice-9 regex)
	26	:export (load/compile))
	27
	28	(define the-vm (make-vm))
	29
	30	(define (load/compile file)
	31	(let* ((file (file-name-full-name file))
	32	(compiled (object-file-name file)))
	33	(if (or (not (file-exists? compiled))
	34	(> (stat:mtime (stat file)) (stat:mtime (stat compiled))))
ea9b4b29	35	(compile-file-in file #f (lookup-language 'gscheme)))
d4ae3ae6 KN	36	(let ((bytes (make-uniform-vector (stat:size (stat compiled)) #\a)))
	37	(call-with-input-file compiled
	38	(lambda (p) (uniform-vector-read! bytes p)))
bd098a1a	39	(vm-load the-vm bytes))))
d4ae3ae6 KN	40
	41	(define (file-name-full-name filename)
	42	(let ((oldname (and (current-load-port)
	43	(port-filename (current-load-port)))))
	44	(if (and oldname
	45	(> (string-length filename) 0)
	46	(not (char=? (string-ref filename 0) #\/))
	47	(not (string=? (dirname oldname) ".")))
	48	(string-append (dirname oldname) "/" filename)
	49	filename)))
	50
	51	(define (object-file-name file)
	52	(let ((m (string-match "\\.[^.]*$" file)))
	53	(string-append (if m (match:prefix m) file) ".go")))