summaryrefslogtreecommitdiff
path: root/module/system/base
diff options
context:
space:
mode:
Diffstat (limited to 'module/system/base')
-rw-r--r--module/system/base/.cvsignore1
-rw-r--r--module/system/base/compile.scm130
-rw-r--r--module/system/base/language.scm51
3 files changed, 116 insertions, 66 deletions
diff --git a/module/system/base/.cvsignore b/module/system/base/.cvsignore
new file mode 100644
index 000000000..e796b66a8
--- /dev/null
+++ b/module/system/base/.cvsignore
@@ -0,0 +1 @@
+*.go
diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm
index 686931948..32c36c892 100644
--- a/module/system/base/compile.scm
+++ b/module/system/base/compile.scm
@@ -20,29 +20,125 @@
;;; Code:
(define-module (system base compile)
+ :use-module (oop goops)
+ :use-syntax (system base syntax)
:use-module (system base language)
- :use-module (ice-9 regex)
- :export (compile-file object-file-name))
+ :use-module (system il compile)
+ :use-module (system vm core)
+ :use-module (system vm assemble)
+ :use-module (ice-9 regex))
+
+;;;
+;;; Compiler environment
+;;;
+
+(define-vm-class <cenv> ()
+ vm language module optimize)
+
+(define-public (make-cenv . rest)
+ (apply make <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 (compile-file file)
- (let ((comp (object-file-name file)))
- (call-with-compile-error-catch
- (lambda ()
- (catch #t
+(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)
- (uniform-array-write (compile-file-in file scheme) port))))
- (lambda (key . args)
- (format #t "ERROR: In ~A:\n" file)
- (display "ERROR: ")
- (format #t (cadr args) (caddr args))
- (newline)
- (delete-file comp)))))
- (format #t "Wrote ~A\n" comp)))
-
-(define (object-file-name file)
+ (let* ((source (read-file-in file scheme))
+ (objcode (apply compile-in source (current-module)
+ scheme opts)))
+ (uniform-array-write (objcode->string objcode) port))))
+ (format #t "Wrote ~A\n" comp))))
+ (lambda (key . args)
+ (format #t "ERROR: In ~A:\n" file)
+ (display "ERROR: ")
+ (format #t (cadr args) (caddr args))
+ (newline)
+ (delete-file comp)))))
+
+(define-public (load-source-file file . opts)
+ (let ((source (read-file-in file scheme)))
+ (vm-load (the-vm) (apply compile-in source (current-module) scheme opts))))
+
+(define-public (load-file file . opts)
+ (let ((comp (compiled-file-name file)))
+ (if (file-exists? comp)
+ (vm-load (the-vm) (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")))
+
+
+;;;
+;;; 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)))
diff --git a/module/system/base/language.scm b/module/system/base/language.scm
index 83014584e..5ac1eb3ee 100644
--- a/module/system/base/language.scm
+++ b/module/system/base/language.scm
@@ -22,12 +22,7 @@
(define-module (system base language)
:use-module (oop goops)
:use-syntax (system base syntax)
- :use-module (system il compile)
- :use-module (system vm core)
- :use-module (system vm assemble)
- :use-module (ice-9 regex)
- :export (define-language lookup-language read-in compile-in print-in
- compile-file-in))
+ :export (define-language lookup-language))
;;;
@@ -36,12 +31,10 @@
(define-vm-class <language> ()
name title version environment
- (reader)
+ reader printer read-file
(expander (lambda (x e) x))
(translator (lambda (x e) x))
(evaluator #f)
- (printer)
- (compiler)
)
(define-method (write (lang <language>) port)
@@ -57,43 +50,3 @@
(if (module-bound? m name)
(module-ref m name)
(error "No such language:" name))))
-
-
-;;;
-;;; Evaluation interface
-;;;
-
-(define (read-in lang . port)
- (lang.reader (if (null? port) (current-input-port) (car port))))
-
-(define (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 (print-in val lang . port)
- (lang.printer val (if (null? port) (current-output-port) (car port))))
-
-(define (compile-file-in file lang . opts)
- (call-with-input-file file
- (lambda (port) (apply lang.compiler port (current-module) opts))))
-
-(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))))