mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 03:40:34 +02:00
b6368dbbb9
* module/language/scheme/translate.scm (trans-pair): In the `set!' case, when a procedure-with-setter is passed, call `trans:pair' with an actual pair. This fixes a long-lasting bug which prevented compilation of `set!' statements with procedures-with-setter (this showed up when compiling `(system vm assemble)'). * module/system/base/compile.scm: Added `objcode->u8vector' to the `#:select' clause. * module/system/base/syntax.scm: Cosmetic changes. * module/system/vm/assemble.scm (preprocess): Removed debugging statements. * src/frames.c: Cosmetic changes. * src/frames.h (SCM_FRAME_SET_DYNAMIC_LINK): New. * src/objcodes.c: Use `scm_t_uint8' instead of `char' when relevant. * src/vm.c (vm_heapify_frames_1): Use `SCM_FRAME_SET_DYNAMIC_LINK ()'. * src/vm_loader.c: Added casts to mute GCC 4 warnings. * testsuite/run-vm-tests.scm (*scheme*): Renamed to `%scheme'. (run-test-from-file): Renamed to `compile/run-test-from-file'. (run-vm-tests): Run each test using both the VM and the interpreter; compare the results. * testsuite/t-proc-with-setter.scm: Try out `get/set'. * doc/Makefile.am (info_TEXINFOS): New. * doc/guile-vm.texi: Added index entries and indices. * doc/texinfo.tex: New file. git-archimport-id: lcourtes@laas.fr--2005-mobile/guile-vm--mobile--0.6--patch-5
159 lines
4.6 KiB
Scheme
159 lines
4.6 KiB
Scheme
;;; High-level compiler interface
|
||
|
||
;; 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 base compile)
|
||
:use-syntax (system base syntax)
|
||
:use-module (system base language)
|
||
:use-module (system il compile)
|
||
:use-module (system il glil)
|
||
:use-module ((system vm core)
|
||
#:select (the-vm vm-load objcode->u8vector))
|
||
:use-module (system vm assemble)
|
||
:use-module (ice-9 regex))
|
||
|
||
;;;
|
||
;;; Compiler environment
|
||
;;;
|
||
|
||
(define-record (<cenv> vm language module))
|
||
|
||
(define-public (make-cenv . rest)
|
||
(apply <cenv> rest))
|
||
|
||
(define-public (syntax-error loc msg exp)
|
||
(throw 'syntax-error loc msg exp))
|
||
|
||
(define-public (call-with-compile-error-catch thunk)
|
||
(catch 'syntax-error
|
||
(thunk)
|
||
(lambda (key loc msg exp)
|
||
(format #t "~A:~A: ~A: ~A" (car loc) (cdr loc) msg exp))))
|
||
|
||
|
||
;;;
|
||
;;; Compiler
|
||
;;;
|
||
|
||
(define scheme (lookup-language 'scheme))
|
||
|
||
(define-public (compile-file file . opts)
|
||
(let ((comp (compiled-file-name file)))
|
||
(catch #t
|
||
(lambda ()
|
||
; (call-with-compile-error-catch
|
||
; (lambda ()
|
||
(call-with-output-file comp
|
||
(lambda (port)
|
||
(let* ((source (read-file-in file scheme))
|
||
(objcode (apply compile-in source (current-module)
|
||
scheme opts)))
|
||
(if (memq :c opts)
|
||
(pprint-glil objcode port)
|
||
(uniform-vector-write (objcode->u8vector objcode) port)))))
|
||
(format #t "wrote ~A\n" comp))
|
||
(lambda (key . args)
|
||
(format #t "ERROR: during compilation of ~A:\n" file)
|
||
(display "ERROR: ")
|
||
(apply format #t (cadr args) (caddr args))
|
||
(newline)
|
||
(format #t "ERROR: ~A ~A ~A\n" key (car args) (cadddr args))
|
||
(delete-file comp)))))
|
||
|
||
; (let ((c-f compile-file))
|
||
; ;; XXX: Debugging output
|
||
; (set! compile-file
|
||
; (lambda (file . opts)
|
||
; (format #t "compile-file: ~a ~a~%" file opts)
|
||
; (let ((result (apply c-f (cons file opts))))
|
||
; (format #t "compile-file: returned ~a~%" result)
|
||
; result))))
|
||
|
||
(define-public (load-source-file file . opts)
|
||
(let ((source (read-file-in file scheme)))
|
||
(apply compile-in source (current-module) scheme opts)))
|
||
|
||
(define-public (load-file file . opts)
|
||
(let ((comp (compiled-file-name file)))
|
||
(if (file-exists? comp)
|
||
(load-objcode comp)
|
||
(apply load-source-file file opts))))
|
||
|
||
(define-public (compiled-file-name file)
|
||
(let ((m (string-match "\\.[^.]*$" file)))
|
||
(string-append (if m (match:prefix m) file) ".go")))
|
||
|
||
(define-public (scheme-eval x e)
|
||
(vm-load (the-vm) (compile-in x e scheme)))
|
||
|
||
|
||
;;;
|
||
;;; Scheme compiler interface
|
||
;;;
|
||
|
||
(define-public (read-file-in file lang)
|
||
(call-with-input-file file lang.read-file))
|
||
|
||
(define-public (compile-in x e lang . opts)
|
||
(catch 'result
|
||
(lambda ()
|
||
;; expand
|
||
(set! x (lang.expander x e))
|
||
(if (memq :e opts) (throw 'result x))
|
||
;; translate
|
||
(set! x (lang.translator x e))
|
||
(if (memq :t opts) (throw 'result x))
|
||
;; compile
|
||
(set! x (apply compile x e opts))
|
||
(if (memq :c opts) (throw 'result x))
|
||
;; assemble
|
||
(apply assemble x e opts))
|
||
(lambda (key val) val)))
|
||
|
||
;;;
|
||
;;;
|
||
;;;
|
||
|
||
(define (compile-and-load file . opts)
|
||
(let ((comp (object-file-name file)))
|
||
(if (or (not (file-exists? comp))
|
||
(> (stat:mtime (stat file)) (stat:mtime (stat comp))))
|
||
(compile-file file))
|
||
(load-compiled-file comp)))
|
||
|
||
(define (load/compile file . opts)
|
||
(let* ((file (file-full-name file))
|
||
(compiled (object-file-name file)))
|
||
(if (or (not (file-exists? compiled))
|
||
(> (stat:mtime (stat file)) (stat:mtime (stat compiled))))
|
||
(apply compile-file file #f opts))
|
||
(if (memq #:b opts)
|
||
(apply vm-trace (the-vm) (load-objcode compiled) opts)
|
||
((the-vm) (load-objcode compiled)))))
|
||
|
||
(define (file-full-name filename)
|
||
(let* ((port (current-load-port))
|
||
(oldname (and port (port-filename port))))
|
||
(if (and oldname
|
||
(> (string-length filename) 0)
|
||
(not (char=? (string-ref filename 0) #\/))
|
||
(not (string=? (dirname oldname) ".")))
|
||
(string-append (dirname oldname) "/" filename)
|
||
filename)))
|