summaryrefslogtreecommitdiff
path: root/module/system/base
diff options
context:
space:
mode:
Diffstat (limited to 'module/system/base')
-rw-r--r--module/system/base/compile.scm222
-rw-r--r--module/system/base/language.scm50
-rw-r--r--module/system/base/syntax.scm14
3 files changed, 114 insertions, 172 deletions
diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm
index 1b8183edf..4f1546025 100644
--- a/module/system/base/compile.scm
+++ b/module/system/base/compile.scm
@@ -20,23 +20,18 @@
;;; Code:
(define-module (system base compile)
- #:use-syntax (system base syntax)
+ #:use-module (system base syntax)
#:use-module (system base language)
- #:use-module ((system il compile) #:select ((compile . compile-il)))
- #:use-module (system il ghil)
- #:use-module (system il glil)
- #:use-module (system vm objcode)
- #:use-module (system vm assemble)
- #:use-module (system vm vm) ;; for compile-time evaluation
+ #:use-module (language objcode spec)
+ #:use-module (language value spec)
+ #: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 ((srfi srfi-1) #:select (fold))
- #:export (syntax-error compile-file load-source-file load-file
+ #:use-module (ice-9 receive)
+ #:export (syntax-error
*current-language*
- compiled-file-name
- compile-time-environment
- compile read-file-in compile-in
- load/compile)
+ compiled-file-name compile-file compile-and-load
+ compile compile-time-environment)
#:export-syntax (call-with-compile-error-catch))
;;;
@@ -62,48 +57,47 @@
;;;
(define *current-language* (make-fluid))
+(define (current-language)
+ (or (fluid-ref *current-language*)
+ (begin (fluid-set! *current-language* (lookup-language 'scheme))
+ (current-language))))
-;; This is basically to avoid mucking with the backtrace.
-(define (call-with-nonlocal-exit-protect thunk on-nonlocal-exit)
- (let ((success #f) (entered #f))
+(define (call-once thunk)
+ (let ((entered #f))
(dynamic-wind
(lambda ()
(if entered
(error "thunk may only be entered once: ~a" thunk))
(set! entered #t))
- (lambda ()
- (thunk)
- (set! success #t))
- (lambda ()
- (if (not success)
- (on-nonlocal-exit))))))
-
+ thunk
+ (lambda () #t))))
+
(define (call-with-output-file/atomic filename proc)
(let* ((template (string-append filename ".XXXXXX"))
(tmp (mkstemp! template)))
- (call-with-nonlocal-exit-protect
- (lambda ()
- (with-output-to-port tmp
- (lambda () (proc (current-output-port))))
- (rename-file template filename))
+ (call-once
(lambda ()
- (delete-file template)))))
+ (with-throw-handler #t
+ (lambda ()
+ (with-output-to-port tmp
+ (lambda () (proc (current-output-port))))
+ (rename-file template filename))
+ (lambda args
+ (delete-file template)))))))
-(define (compile-file file . opts)
+(define* (compile-file file #:key (to objcode) (opts '()))
(let ((comp (compiled-file-name file))
- (lang (fluid-ref *current-language*)))
+ (lang (current-language)))
(catch 'nothing-at-all
(lambda ()
(call-with-compile-error-catch
(lambda ()
(call-with-output-file/atomic comp
(lambda (port)
- (let* ((source (read-file-in file lang))
- (objcode (apply compile-in source (current-module)
- lang opts)))
- (if (memq #:c opts)
- (pprint-glil objcode port)
- (uniform-vector-write (objcode->u8vector objcode) port)))))
+ (let ((print (language-printer to)))
+ (print (compile (read-file-in file lang)
+ #:from lang #:to to #:opts opts)
+ port))))
(format #t "wrote `~A'\n" comp))))
(lambda (key . args)
(format #t "ERROR: during compilation of ~A:\n" file)
@@ -113,25 +107,9 @@
(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 ((lang (fluid-ref *current-language*)))
- (let ((source (read-file-in file lang)))
- (apply compile-in source (current-module) lang 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* (compile-and-load file #:key (to value) (opts '()))
+ (let ((lang (current-language)))
+ (compile (read-file-in file lang) #:to value #:opts opts)))
(define (compiled-file-name file)
(let ((base (basename file))
@@ -151,112 +129,46 @@
cext))
(else (lp (cdr exts)))))))
-;;; environment := #f
-;;; | MODULE
-;;; | COMPILE-ENV
-;;; compile-env := (MODULE LEXICALS . EXTERNALS)
-(define (cenv-module env)
- (cond ((not env) #f)
- ((module? env) env)
- ((and (pair? env) (module? (car env))) (car env))
- (else (error "bad environment" env))))
-
-(define (cenv-ghil-env env)
- (cond ((not env) (make-ghil-toplevel-env))
- ((module? env) (make-ghil-toplevel-env))
- ((pair? env)
- (ghil-env-dereify (cadr env)))
- (else (error "bad environment" env))))
-
-(define (cenv-externals env)
- (cond ((not env) '())
- ((module? env) '())
- ((pair? env) (cddr env))
- (else (error "bad environment" env))))
-
-(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* (compile x #:optional env)
- (let ((thunk (objcode->program
- (compile-in x env (fluid-ref *current-language*))
- (cenv-externals env))))
- (if (not env)
- (thunk)
- (save-module-excursion
- (lambda ()
- (set-current-module (cenv-module env))
- (thunk))))))
-
;;;
-;;; Scheme compiler interface
+;;; 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))))
-
-;;; FIXME: fold run-pass x (compile-passes lang opts)
-(define (compile-passes lang opts)
- (let lp ((passes (list
- (language-expander lang)
- (language-translator lang)
- (lambda (x e) (apply compile-il x e opts))
- (lambda (x e) (apply assemble x e opts))))
- (keys '(#f #:e #:t #:c))
+ (call-with-input-file file
+ (or (language-read-file lang)
+ (error "language has no #:read-file" lang))))
+
+(define (compile-passes from to opts)
+ (let lp ((langs (or (lookup-compilation-order from to)
+ (error "no way to compile" (language-name from)
+ "to" (language-name to))))
(out '()))
- (if (or (null? keys)
- (and (car keys) (memq (car keys) opts)))
+ (if (null? (cdr langs))
(reverse! out)
- (lp (cdr passes) (cdr keys)
- (if (car passes)
- (cons (car passes) out)
- out)))))
-
-(define (compile-in x e lang . opts)
- (save-module-excursion
- (lambda ()
- (and=> (cenv-module e) set-current-module)
- (let ((env (cenv-ghil-env e)))
- (fold (lambda (pass exp)
- (pass exp env))
- x
- (compile-passes lang opts))))))
-
-;;;
-;;;
-;;;
-
-(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)))
+ (lp (cdr langs)
+ (cons (assq-ref (language-compilers (car langs)) (cadr langs))
+ out)))))
-(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 (compile-fold passes exp env opts)
+ (if (null? passes)
+ exp
+ (receive (exp env) ((car passes) exp env opts)
+ (compile-fold (cdr passes) exp env opts))))
-(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)))
+(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)
-(fluid-set! *current-language* (lookup-language 'scheme))
+(define* (compile x #:key
+ (env #f)
+ (from (current-language))
+ (to value)
+ (opts '()))
+ (compile-fold (compile-passes from to opts)
+ x
+ env
+ opts))
diff --git a/module/system/base/language.scm b/module/system/base/language.scm
index 50de15a7d..208e0e128 100644
--- a/module/system/base/language.scm
+++ b/module/system/base/language.scm
@@ -20,30 +20,56 @@
;;; Code:
(define-module (system base language)
- #:use-syntax (system base syntax)
+ #:use-module (system base syntax)
#:export (define-language lookup-language make-language
- language-name language-title language-version language-reader
- language-printer language-read-file language-expander
- language-translator language-evaluator language-environment))
+ language-name language-title language-version language-reader
+ language-printer language-parser language-read-file
+ language-compilers language-evaluator
+
+ lookup-compilation-order invalidate-compilation-cache!))
;;;
;;; Language class
;;;
-(define-record (<language> name title version reader printer
- (read-file #f)
- (expander #f)
- (translator #f)
- (evaluator #f)
- (environment #f)
- ))
+(define-record <language>
+ name
+ title
+ version
+ reader
+ printer
+ (parser #f)
+ (read-file #f)
+ (compilers '())
+ (evaluator #f))
(define-macro (define-language name . spec)
- `(define ,name (make-language #:name ',name ,@spec)))
+ `(begin
+ (invalidate-compilation-cache!)
+ (define ,name (make-language #:name ',name ,@spec))))
(define (lookup-language name)
(let ((m (resolve-module `(language ,name spec))))
(if (module-bound? m name)
(module-ref m name)
(error "no such language" name))))
+
+(define *compilation-cache* '())
+
+(define (invalidate-compilation-cache!)
+ (set! *compilation-cache* '()))
+
+(define (compute-compilation-order from to)
+ (let lp ((from from) (seen '()))
+ (cond ((eq? from to) (reverse! (cons from seen)))
+ ((memq from seen) #f)
+ (else (or-map (lambda (lang) (lp lang (cons from seen)))
+ (map car (language-compilers from)))))))
+
+(define (lookup-compilation-order from to)
+ (or (assoc-ref *compilation-cache* (cons from to))
+ (let ((order (compute-compilation-order from to)))
+ (set! *compilation-cache*
+ (acons (cons from to) order *compilation-cache*))
+ order)))
diff --git a/module/system/base/syntax.scm b/module/system/base/syntax.scm
index 0e02ba06a..b7b995034 100644
--- a/module/system/base/syntax.scm
+++ b/module/system/base/syntax.scm
@@ -32,8 +32,11 @@
(let ((name (if (pair? name) (car name) name))
(opts (if (pair? name) (cdr name) '())))
(let ((printer (kw-arg-ref opts #:printer)))
- `(begin ,@(map (lambda (def) `(define-record ,def
- ,@(if printer (list printer) '())))
+ `(begin ,@(map (lambda (def)
+ `(define-record ,(if printer
+ `(,(car def) ,printer)
+ (car def))
+ ,@(cdr def)))
rest)))))
@@ -44,14 +47,15 @@
(define (symbol-trim-both sym pred)
(string->symbol (string-trim-both (symbol->string sym) pred)))
-(define-macro (define-record def . printer)
- (let* ((name (car def)) (slots (cdr def))
+(define-macro (define-record name-form . slots)
+ (let* ((name (if (pair? name-form) (car name-form) name-form))
+ (printer (and (pair? name-form) (cadr name-form)))
(slot-names (map (lambda (slot) (if (pair? slot) (car slot) slot))
slots))
(stem (symbol-trim-both name (list->char-set '(#\< #\>)))))
`(begin
(define ,name (make-record-type ,(symbol->string name) ',slot-names
- ,@printer))
+ ,@(if printer (list printer) '())))
(define ,(symbol-append 'make- stem)
(let ((slots (list ,@(map (lambda (slot)
(if (pair? slot)