-;;; 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)
- :export (syntax-error compile-file load-source-file load-file
- compiled-file-name
- scheme-eval read-file-in compile-in))
-
-;;;
-;;; Compiler environment
-;;;
-
-(define (syntax-error loc msg exp)
- (throw 'syntax-error loc msg exp))
-
-(define-macro (call-with-compile-error-catch thunk)
- `(catch 'syntax-error
- ,thunk
- (lambda (key loc msg exp)
- (if (pair? loc)
- (format #t "~A:~A: ~A: ~A~%" (car loc) (cdr loc) msg exp)
- (format #t "unknown location: ~A: ~A~%" msg exp)))))
-
-(export-syntax call-with-compile-error-catch)
-
-
-\f
-;;;
-;;; Compiler
-;;;
-
-(define scheme (lookup-language 'scheme))
-
-(define (compile-file file . opts)
- (let ((comp (compiled-file-name file)))
- (catch 'nothing-at-all
- (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 (load-source-file file . opts)
- (let ((source (read-file-in file scheme)))
- (apply compile-in source (current-module) scheme opts)))
-
-(define (load-file file . opts)
- (let ((comp (compiled-file-name file)))
- (if (file-exists? comp)
- (load-objcode comp)
- (apply load-source-file file opts))))
-
-(define (compiled-file-name file)
- (let ((m (string-match "\\.[^.]*$" file)))
- (string-append (if m (match:prefix m) file) ".go")))
-
-(define (scheme-eval x e)
- (vm-load (the-vm) (compile-in x e scheme)))
-
-\f
-;;;
-;;; Scheme compiler interface
-;;;
-
-(define (read-file-in file lang)
- (call-with-input-file file (language-read-file lang)))
-
-(define (compile-in x e lang . opts)
- (catch 'result
- (lambda ()
- ;; expand
- (set! x ((language-expander lang) x e))
- (if (memq :e opts) (throw 'result x))
- ;; translate
- (set! x ((language-translator lang) 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)))
+;;; 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
+ load-ensuring-compiled
+ compile
+ 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)))))
+
+\f
+;;;
+;;; 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 (ensure-directory dir)
+ (or (file-exists? dir)
+ (begin
+ (ensure-directory (dirname dir))
+ (mkdir dir))))
+
+(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)))
+ (ensure-directory (dirname comp))
+ (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 (from 'scheme) (to 'value) (opts '()))
+ (read-and-compile (open-input-file file)
+ #:from from #:to to #:opts opts))
+
+(define* (load-ensuring-compiled source #:key (from 'scheme)
+ (to 'value) (opts '()))
+ (let ((compiled (compiled-file-name source #:readable #t)))
+ (load-compiled
+ (if (and compiled
+ (>= (stat:mtime (stat compiled)) (stat:mtime (stat source))))
+ compiled
+ (let ((to-compile (compiled-file-name source #:writable #t)))
+ (if compiled
+ (warn "source file" source "newer than" compiled))
+ (if (and compiled
+ (not (string-equal? compiled to-compile))
+ (file-exists? to-compile)
+ (>= (stat:mtime (stat to-compile))
+ (stat:mtime (stat compiled))))
+ (warn "using local compiled copy" to-compile)
+ (begin
+ (format (current-error-port) ";;; Compiling ~s\n" source)
+ (compile-file source #:output-file to-compile)
+ (format (current-error-port) ";;; Success: ~s\n" to-compile)))
+ to-compile)))))
+
+(define (ensure-fallback-path)
+ (let ((home (or (getenv "HOME")
+ (false-if-exception
+ (passwd:dir (getpwuid (getuid)))))))
+ (and home
+ (let ((cache (in-vicinity home ".guile-ccache")))
+ (cond
+ ((and (access? cache (logior W_OK X_OK))
+ (file-is-directory? cache))
+ cache)
+ ((not (file-exists? cache))
+ (and (false-if-exception (mkdir cache))
+ cache))
+ (else #f))))))
+
+(define load-compiled-path
+ (let ((fallback-path #f))
+ (lambda ()
+ (if (not fallback-path)
+ (let ((cache-path (ensure-fallback-path)))
+ (set! fallback-path
+ (if cache-path
+ (list cache-path)
+ '()))))
+ (append %load-path fallback-path))))
+
+(define* (compiled-file-name file #:key (writable #f) (readable #f))
+ (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)))))
+ (define (strip-source-extension base)
+ (let lp ((exts %load-extensions))
+ (cond ((null? exts) (string-append file cext))
+ ((string-null? (car exts)) (lp (cdr exts)))
+ ((string-suffix? (car exts) base)
+ (substring source 0
+ (- (string-length source)
+ (string-length (car exts)))))
+ (else (lp (cdr exts))))))
+ (define (strip-path file paths)
+ (let lp ((paths paths))
+ (cond ((null? paths) file)
+ ((string-prefix? (car paths) file)
+ (substring file (1+ (string-length (car paths)))))
+ (else (lp (cdr paths))))))
+ (let ((sibling (string-append (strip-source-extension file) cext)))
+ (cond
+ (writable
+ ;; either put it right beside the original file, or in our
+ ;; ccache. other things wind up not making sense.
+ (cond
+ ((or (not (file-exists? sibling)) (access? sibling W_OK))
+ sibling)
+ ((ensure-fallback-path)
+ => (lambda (p)
+ (string-append p "/" (strip-path sibling))))
+ (else #f)))
+ (readable
+ (if (access? sibling R_OK)
+ sibling
+ (search-path (load-compiled-path)
+ (strip-path (strip-source-extension file))
+ %load-compiled-extensions #t)))
+ (else
+ sibling)))))
+
+
+\f
+;;;
+;;; Compiler interface
+;;;
+
+(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 (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))
+
+\f
+;;;
+;;; 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))
HCoop / bpt / guile.git / blobdiff