diff options
Diffstat (limited to 'module/system/base')
-rw-r--r-- | module/system/base/compile.scm | 222 | ||||
-rw-r--r-- | module/system/base/language.scm | 50 | ||||
-rw-r--r-- | module/system/base/syntax.scm | 14 |
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) |