mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 03:40:34 +02:00
b8076ec6cc
* module/language/ghil.scm (unparse-ghil): Fix unparsing of quasiquoted expressions. * module/language/ghil/spec.scm (join): Define a joiner for GHIL. * module/language/scheme/compile-ghil.scm (cenv-ghil-env): Expand the definition of a CENV so it can have an actual ghil-env, if available. (compile-ghil): Return the actual ghil env in the cenv. * module/system/base/compile.scm (compile-file): Rewrite. `output-file' is now a keyword argument, along with the new kwargs `env' and `from'. We now allow exceptions to propagate up, and instead of printing the output file to the console, we return a string corresponding to its location. (compile-and-load): Use read-and-compile. (compile-fold): Thread around the cenv as well. Return all three values. (find-language-joint, read-and-compile): New exciting helpers. The idea is that compiling a file should be semantically equivalent to compiling each expression in it, one by one. Compilation can have side effects, e.g. affecting the current language or the current reader. So what we do is find a point in the compilation path at which different expressions of a given language can be joined into one. Expressions from the source language are compiled to the joint language, then joined and compiled to the target. (compile): Just return the first value from compile-fold. * module/system/base/language.scm (language-joiner): New optional field. * scripts/compile: Rework for changes to compile-file.
227 lines
7.5 KiB
Scheme
227 lines
7.5 KiB
Scheme
;;; High-level compiler interface
|
||
|
||
;; Copyright (C) 2001, 2009 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-module (system base syntax)
|
||
#:use-module (system base language)
|
||
#:use-module (system vm vm) ;; FIXME: there's a reason for this, can't remember why tho
|
||
#:use-module (ice-9 regex)
|
||
#:use-module (ice-9 optargs)
|
||
#:use-module (ice-9 receive)
|
||
#:export (syntax-error
|
||
*current-language*
|
||
compiled-file-name compile-file compile-and-load
|
||
compile compile-time-environment
|
||
decompile)
|
||
#:export-syntax (call-with-compile-error-catch))
|
||
|
||
;;;
|
||
;;; Compiler environment
|
||
;;;
|
||
|
||
(define (syntax-error loc msg exp)
|
||
(throw 'syntax-error-compile-time loc msg exp))
|
||
|
||
(define-macro (call-with-compile-error-catch thunk)
|
||
`(catch 'syntax-error-compile-time
|
||
,thunk
|
||
(lambda (key loc msg exp)
|
||
(if (pair? loc)
|
||
(let ((file (or (assq-ref loc 'filename) "unknown file"))
|
||
(line (assq-ref loc 'line))
|
||
(col (assq-ref loc 'column)))
|
||
(format (current-error-port)
|
||
"~A:~A:~A: ~A: ~A~%" file line col msg exp))
|
||
(format (current-error-port)
|
||
"unknown location: ~A: ~S~%" msg exp)))))
|
||
|
||
|
||
;;;
|
||
;;; Compiler
|
||
;;;
|
||
|
||
(define *current-language* (make-fluid))
|
||
(fluid-set! *current-language* 'scheme)
|
||
(define (current-language)
|
||
(fluid-ref *current-language*))
|
||
|
||
(define (call-once thunk)
|
||
(let ((entered #f))
|
||
(dynamic-wind
|
||
(lambda ()
|
||
(if entered
|
||
(error "thunk may only be entered once: ~a" thunk))
|
||
(set! entered #t))
|
||
thunk
|
||
(lambda () #t))))
|
||
|
||
(define (call-with-output-file/atomic filename proc)
|
||
(let* ((template (string-append filename ".XXXXXX"))
|
||
(tmp (mkstemp! template)))
|
||
(call-once
|
||
(lambda ()
|
||
(with-throw-handler #t
|
||
(lambda ()
|
||
(proc tmp)
|
||
(chmod tmp (logand #o0666 (lognot (umask))))
|
||
(close-port tmp)
|
||
(rename-file template filename))
|
||
(lambda args
|
||
(delete-file template)))))))
|
||
|
||
(define (ensure-language x)
|
||
(if (language? x)
|
||
x
|
||
(lookup-language x)))
|
||
|
||
(define* (compile-file file #:key
|
||
(output-file #f)
|
||
(env #f)
|
||
(from (current-language))
|
||
(to 'objcode)
|
||
(opts '()))
|
||
(let ((comp (or output-file (compiled-file-name file)))
|
||
(in (open-input-file file)))
|
||
(call-with-output-file/atomic comp
|
||
(lambda (port)
|
||
((language-printer (ensure-language to))
|
||
(read-and-compile in #:env env #:from from #:to to #:opts opts)
|
||
port)))
|
||
comp))
|
||
|
||
(define* (compile-and-load file #:key (to 'value) (opts '()))
|
||
(read-and-compile (open-input-port file)
|
||
#:from lang #:to to #:opts opts))
|
||
|
||
(define (compiled-file-name file)
|
||
(let ((base (basename file))
|
||
(cext (cond ((or (null? %load-compiled-extensions)
|
||
(string-null? (car %load-compiled-extensions)))
|
||
(warn "invalid %load-compiled-extensions"
|
||
%load-compiled-extensions)
|
||
".go")
|
||
(else (car %load-compiled-extensions)))))
|
||
(let lp ((exts %load-extensions))
|
||
(cond ((null? exts) (string-append file cext))
|
||
((string-null? (car exts)) (lp (cdr exts)))
|
||
((string-suffix? (car exts) base)
|
||
(string-append
|
||
(dirname file) "/"
|
||
(substring base 0
|
||
(- (string-length base) (string-length (car exts))))
|
||
cext))
|
||
(else (lp (cdr exts)))))))
|
||
|
||
|
||
;;;
|
||
;;; Compiler interface
|
||
;;;
|
||
|
||
(define (read-file-in file lang)
|
||
(call-with-input-file file
|
||
(or (language-read-file lang)
|
||
(error "language has no #:read-file" lang))))
|
||
|
||
(define (compile-passes from to opts)
|
||
(map cdr
|
||
(or (lookup-compilation-order from to)
|
||
(error "no way to compile" from "to" to))))
|
||
|
||
(define (compile-fold passes exp env opts)
|
||
(let lp ((passes passes) (x exp) (e env) (cenv env) (first? #t))
|
||
(if (null? passes)
|
||
(values x e cenv)
|
||
(receive (x e new-cenv) ((car passes) x e opts)
|
||
(lp (cdr passes) x e (if first? new-cenv cenv) #f)))))
|
||
|
||
(define (compile-time-environment)
|
||
"A special function known to the compiler that, when compiled, will
|
||
return a representation of the lexical environment in place at compile
|
||
time. Useful for supporting some forms of dynamic compilation. Returns
|
||
#f if called from the interpreter."
|
||
#f)
|
||
|
||
(define (find-language-joint from to)
|
||
(let lp ((in (reverse (or (lookup-compilation-order from to)
|
||
(error "no way to compile" from "to" to))))
|
||
(lang to))
|
||
(cond ((null? in)
|
||
(error "don't know how to join expressions" from to))
|
||
((language-joiner lang) lang)
|
||
(else
|
||
(lp (cdr in) (caar in))))))
|
||
|
||
(define* (read-and-compile port #:key
|
||
(env #f)
|
||
(from (current-language))
|
||
(to 'objcode)
|
||
(opts '()))
|
||
(let ((from (ensure-language from))
|
||
(to (ensure-language to)))
|
||
(let ((joint (find-language-joint from to)))
|
||
(with-fluids ((*current-language* from))
|
||
(let lp ((exps '()) (env #f) (cenv env))
|
||
(let ((x ((language-reader (current-language)) port)))
|
||
(cond
|
||
((eof-object? x)
|
||
(compile ((language-joiner joint) (reverse exps) env)
|
||
#:from joint #:to to #:env env #:opts opts))
|
||
(else
|
||
;; compile-fold instead of compile so we get the env too
|
||
(receive (jexp jenv jcenv)
|
||
(compile-fold (compile-passes (current-language) joint opts)
|
||
x cenv opts)
|
||
(lp (cons jexp exps) jenv jcenv))))))))))
|
||
|
||
(define* (compile x #:key
|
||
(env #f)
|
||
(from (current-language))
|
||
(to 'value)
|
||
(opts '()))
|
||
(receive (exp env cenv)
|
||
(compile-fold (compile-passes from to opts) x env opts)
|
||
exp))
|
||
|
||
|
||
;;;
|
||
;;; Decompiler interface
|
||
;;;
|
||
|
||
(define (decompile-passes from to opts)
|
||
(map cdr
|
||
(or (lookup-decompilation-order from to)
|
||
(error "no way to decompile" from "to" to))))
|
||
|
||
(define (decompile-fold passes exp env opts)
|
||
(if (null? passes)
|
||
(values exp env)
|
||
(receive (exp env) ((car passes) exp env opts)
|
||
(decompile-fold (cdr passes) exp env opts))))
|
||
|
||
(define* (decompile x #:key
|
||
(env #f)
|
||
(from 'value)
|
||
(to 'assembly)
|
||
(opts '()))
|
||
(decompile-fold (decompile-passes from to opts)
|
||
x
|
||
env
|
||
opts))
|