Skip to content

Commit

Permalink
Prepare for new back-ends (gsc option -target). Replace compile-file-…
Browse files Browse the repository at this point in the history 
…to-c by compile-file-to-target. Preliminary version of a universal back-end to generate JavaScript, Python, PHP, etc.
  • Loading branch information
@feeley
feeley committed May 17, 2012
1 parent fbb1e78 commit 095a643
Show file tree
Hide file tree
Showing 11 changed files with 5,020 additions and 113 deletions.
24 changes: 12 additions & 12 deletions doc/gambit-c.txi
View file
Original file line number Original file line Diff line number Diff line change
Expand Up @@ -754,7 +754,7 @@ When no command line argument is present other than options the
compiler behaves like the interpreter in interactive mode. The only compiler behaves like the interpreter in interactive mode. The only
difference with the interpreter is that the compilation related difference with the interpreter is that the compilation related
procedures listed in this chapter are also available procedures listed in this chapter are also available
(i.e. @code{compile-file}, @code{compile-file-to-c}, etc). (i.e. @code{compile-file}, @code{compile-file-to-target}, etc).


@node GSC customization, GSC batch mode, GSC interactive mode, GSC @node GSC customization, GSC batch mode, GSC interactive mode, GSC
@section Customization @section Customization
Expand Down Expand Up @@ -1509,7 +1509,7 @@ which flag you need.
The Gambit Scheme compiler features the following procedures that The Gambit Scheme compiler features the following procedures that
are not available in the Gambit Scheme interpreter. are not available in the Gambit Scheme interpreter.


@deffn procedure compile-file-to-c @var{file} @r{[}@code{options:} @var{options}@r{]} @r{[}@code{output:} @var{output}@r{]} @r{[}@code{module-name:} @var{module-name}@r{]} @deffn procedure compile-file-to-target @var{file} @r{[}@code{options:} @var{options}@r{]} @r{[}@code{output:} @var{output}@r{]} @r{[}@code{module-name:} @var{module-name}@r{]}
@pindex gsc @pindex gsc


The @var{file} parameter must be a string naming an existing file The @var{file} parameter must be a string naming an existing file
Expand All @@ -1531,7 +1531,7 @@ which must be a list of symbols. Any combination of the following
options can be used: @samp{verbose}, @samp{report}, @samp{expansion}, options can be used: @samp{verbose}, @samp{report}, @samp{expansion},
@samp{gvm}, and @samp{debug}. @samp{gvm}, and @samp{debug}.


When the compilation is successful, @code{compile-file-to-c} returns When the compilation is successful, @code{compile-file-to-target} returns
the name of the C file generated. When there is a compilation error, the name of the C file generated. When there is a compilation error,
@code{#f} is returned. @code{#f} is returned.


Expand All @@ -1541,7 +1541,7 @@ $ @b{cat h.scm}
$ @b{gsc} $ @b{gsc}
Gambit @value{VERSION} Gambit @value{VERSION}


> @b{(compile-file-to-c "h")} > @b{(compile-file-to-target "h")}
"/Users/feeley/gambit/doc/h.c" "/Users/feeley/gambit/doc/h.c"
@end smallexample @end smallexample
@end deffn @end deffn
Expand All @@ -1552,10 +1552,10 @@ Gambit @value{VERSION}
@cindex object file @cindex object file


The @var{file}, @var{options}, and @var{output} parameters have the The @var{file}, @var{options}, and @var{output} parameters have the
same meaning as for the @code{compile-file-to-c} procedure, except that same meaning as for the @code{compile-file-to-target} procedure, except that
@var{file} may be a Scheme source file or a @var{file} may be a Scheme source file or a
C file possibly generated by the Gambit Scheme compiler (for example C file possibly generated by the Gambit Scheme compiler (for example
with the @code{compile-file-to-c} procedure). The with the @code{compile-file-to-target} procedure). The
@var{cc-options} parameter is a string containing the options to pass @var{cc-options} parameter is a string containing the options to pass
to the C compiler and the @var{ld-options-prelude} and to the C compiler and the @var{ld-options-prelude} and
@var{ld-options} parameters are strings containing the options to pass @var{ld-options} parameters are strings containing the options to pass
Expand Down Expand Up @@ -1616,14 +1616,14 @@ Gambit @value{VERSION}
> @b{(load "h")} > @b{(load "h")}
hello hello
"/Users/feeley/gambit/doc/h.o1" "/Users/feeley/gambit/doc/h.o1"
> @b{(compile-file-to-c "h" output: "h.o99.c")} > @b{(compile-file-to-target "h" output: "h.o99.c")}
"/Users/feeley/gambit/doc/h.o99.c" "/Users/feeley/gambit/doc/h.o99.c"
> @b{(compile-file "h.o99.c")} > @b{(compile-file "h.o99.c")}
"/Users/feeley/gambit/doc/h.o99" "/Users/feeley/gambit/doc/h.o99"
> @b{(load "h.o99")} > @b{(load "h.o99")}
hello hello
"/Users/feeley/gambit/doc/h.o99" "/Users/feeley/gambit/doc/h.o99"
> @b{(compile-file-to-c "h")} > @b{(compile-file-to-target "h")}
"/Users/feeley/gambit/doc/h.c" "/Users/feeley/gambit/doc/h.c"
> @b{(compile-file "h.c" options: '(obj))} > @b{(compile-file "h.c" options: '(obj))}
"/Users/feeley/gambit/doc/h.o" "/Users/feeley/gambit/doc/h.o"
Expand Down Expand Up @@ -1668,9 +1668,9 @@ display("world"); newline();
$ @b{gsc} $ @b{gsc}
Gambit @value{VERSION} Gambit @value{VERSION}


> @b{(compile-file-to-c "h")} > @b{(compile-file-to-target "h")}
"/Users/feeley/gambit/doc/h.c" "/Users/feeley/gambit/doc/h.c"
> @b{(compile-file-to-c "w")} > @b{(compile-file-to-target "w")}
"/Users/feeley/gambit/doc/w.c" "/Users/feeley/gambit/doc/w.c"
> @b{(link-incremental '("h" "w") output: "hello.c")} > @b{(link-incremental '("h" "w") output: "hello.c")}
"/Users/feeley/gambit/doc/hello_.c" "/Users/feeley/gambit/doc/hello_.c"
Expand Down Expand Up @@ -1723,9 +1723,9 @@ $ @b{cat m7.scm}
$ @b{gsc} $ @b{gsc}
Gambit @value{VERSION} Gambit @value{VERSION}


> @b{(compile-file-to-c "m6")} > @b{(compile-file-to-target "m6")}
"/Users/feeley/gambit/doc/m6.c" "/Users/feeley/gambit/doc/m6.c"
> @b{(compile-file-to-c "m7")} > @b{(compile-file-to-target "m7")}
"/Users/feeley/gambit/doc/m7.c" "/Users/feeley/gambit/doc/m7.c"
> @b{(link-flat '("m6" "m7") output: "lib.o1.c")} > @b{(link-flat '("m6" "m7") output: "lib.o1.c")}
*** WARNING -- "*" is not defined, *** WARNING -- "*" is not defined,
Expand Down
24 changes: 16 additions & 8 deletions gsc/_back.scm
View file
Original file line number Original file line Diff line number Diff line change
Expand Up @@ -43,7 +43,7 @@
;; References to the other fields in the module should thus ;; References to the other fields in the module should thus
;; happen inside calls to 'begin!' and 'end!'. ;; happen inside calls to 'begin!' and 'end!'.
;; ;;
;; dump Procedure (lambda (procs output output-root c-intf script-line ;; dump Procedure (lambda (procs output c-intf script-line
;; options) ...) ;; options) ...)
;; This procedure takes a list of 'procedure objects' and dumps ;; This procedure takes a list of 'procedure objects' and dumps
;; the corresponding loader-compatible object file to the ;; the corresponding loader-compatible object file to the
Expand All @@ -61,10 +61,8 @@
;; will NOT produce the C interface file automatically as is ;; will NOT produce the C interface file automatically as is
;; normally the case (this is useful in the case of a back-end ;; normally the case (this is useful in the case of a back-end
;; generating C that will itself be creating this file). ;; generating C that will itself be creating this file).
;; The 'output' argument specifies the file name of the ;; The 'output' argument specifies the file name of the file
;; file to produce. If it is #f, 'output-root' concatenated ;; to produce. The 'script-line' argument indicates the text
;; with the appropriate extension should be used as a
;; file name. The 'script-line' argument indicates the text
;; on the first line of the source file (after the #! or @;) ;; on the first line of the source file (after the #! or @;)
;; if the source file is a script or #f if it is not a script. ;; if the source file is a script or #f if it is not a script.
;; ;;
Expand Down Expand Up @@ -102,20 +100,26 @@
;; task-return GVM location. ;; task-return GVM location.
;; This value is the GVM register where the task's return address ;; This value is the GVM register where the task's return address
;; is passed. ;; is passed.
;;
;; switch-testable? Function.
;; This function tests whether an object can be tested
;; in a GVM "switch" instruction.
;;
;; file-extension The file extension for generated files.


;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -


;;;; Target description object manipulation ;;;; Target description object manipulation


(define (make-target version name) (define (make-target version name)


(define current-target-version 6) ; number for this version of the module (define current-target-version 7) ; number for this version of the module


(if (not (= version current-target-version)) (if (not (= version current-target-version))
(compiler-internal-error (compiler-internal-error
"make-target, version of target module is not current" name)) "make-target, version of target module is not current" name))


(let ((x (make-vector 13))) (let ((x (make-vector 14)))
(vector-set! x 0 'target) (vector-set! x 0 'target)
(vector-set! x 1 name) (vector-set! x 1 name)
x)) x))
Expand Down Expand Up @@ -145,6 +149,8 @@
(define (target-task-return-set! x y) (vector-set! x 11 y)) (define (target-task-return-set! x y) (vector-set! x 11 y))
(define (target-switch-testable? x) (vector-ref x 12)) (define (target-switch-testable? x) (vector-ref x 12))
(define (target-switch-testable?-set! x y) (vector-set! x 12 y)) (define (target-switch-testable?-set! x y) (vector-set! x 12 y))
(define (target-file-extension x) (vector-ref x 13))
(define (target-file-extension-set! x y) (vector-set! x 13 y))


;;;; Frame constraints structure ;;;; Frame constraints structure


Expand Down Expand Up @@ -194,7 +200,8 @@
(set! target.frame-constraints (target-frame-constraints target)) (set! target.frame-constraints (target-frame-constraints target))
(set! target.proc-result (target-proc-result target)) (set! target.proc-result (target-proc-result target))
(set! target.task-return (target-task-return target)) (set! target.task-return (target-task-return target))
(set! target.switch-testable? (target-switch-testable? target)) (set! target.switch-testable? (target-switch-testable? target))
(set! target.file-extension (target-file-extension target))


(set! **not-proc-obj (set! **not-proc-obj
(target.prim-info **not-sym)) (target.prim-info **not-sym))
Expand Down Expand Up @@ -247,6 +254,7 @@
(define target.proc-result #f) (define target.proc-result #f)
(define target.task-return #f) (define target.task-return #f)
(define target.switch-testable? #f) (define target.switch-testable? #f)
(define target.file-extension #f)


;; procedures defined in back-end: ;; procedures defined in back-end:


Expand Down
70 changes: 35 additions & 35 deletions gsc/_front.scm
View file
Original file line number Original file line Diff line number Diff line change
Expand Up @@ -2,7 +2,7 @@


;;; File: "_front.scm" ;;; File: "_front.scm"


;;; Copyright (c) 1994-2011 by Marc Feeley, All Rights Reserved. ;;; Copyright (c) 1994-2012 by Marc Feeley, All Rights Reserved.


(include "fixnum.scm") (include "fixnum.scm")


Expand Down Expand Up @@ -52,22 +52,17 @@
(define cf #f) (define cf #f)


(set! cf (set! cf
(lambda (input opts output mod-name) (lambda (input opts output-filename-gen mod-name)
(let ((remaining-opts (let ((remaining-opts
(handle-options opts))) (handle-options opts)))


(set! warnings-requested? compiler-option-warnings) (set! warnings-requested? compiler-option-warnings)


(let* ((output-root (let* ((info-port
(if output
#f
(path-strip-directory
(path-strip-extension input))))
(info-port
(if compiler-option-verbose (if compiler-option-verbose
(current-output-port) (current-output-port)
#f)) #f))
(successful (result
(with-exception-handling (with-exception-handling
(lambda () (lambda ()
(if (not (null? remaining-opts)) (if (not (null? remaining-opts))
Expand All @@ -79,12 +74,11 @@
opts opts
(cons (list 'target (default-target)) opts)) (cons (list 'target (default-target)) opts))
remaining-opts remaining-opts
output output-filename-gen
output-root
mod-name mod-name
info-port))))) info-port)))))


successful)))) result))))


(define (handle-options opts) (define (handle-options opts)
(reset-options) (reset-options)
Expand Down Expand Up @@ -189,15 +183,35 @@
input input
opts opts
remaining-opts remaining-opts
output output-filename-gen
output-root
mod-name mod-name
info-port) info-port)


(define (compiler-body) (define (compiler-body)
(let* ((root
(or output-root (scheme-global-var-define!
(path-strip-extension output))) (scheme-global-var
(string->canonical-symbol "##compilation-options"))
opts)

(env.begin!)
(ptree.begin! info-port)
(virtual.begin!)

(let ((target-name (cadr (assq 'target opts))))
(target-select! target-name info-port))

(let* ((output-filename
(and output-filename-gen
(output-filename-gen)))
(root
(if output-filename
(path-strip-extension output-filename)
(path-strip-directory (path-strip-extension input))))
(output
(if output-filename
output-filename
(string-append root target.file-extension)))
(module-name (module-name
(or mod-name (or mod-name
(path-strip-directory root)))) (path-strip-directory root))))
Expand All @@ -207,19 +221,6 @@
"Invalid characters in file name (must be a symbol with no \"#\")") "Invalid characters in file name (must be a symbol with no \"#\")")
(begin (begin


(scheme-global-var-define!
(scheme-global-var
(string->canonical-symbol "##compilation-options"))
opts)

(env.begin!)
(ptree.begin! info-port)
(virtual.begin!)

(let ((target-name
(cadr (assq 'target opts))))
(target-select! target-name info-port))

(let ((x (read-source input #f #t))) (let ((x (read-source input #f #t)))
(parse-program (parse-program
(expand-source (wrap-program (##vector-ref x 1)));;;;;;;;;;;;;; (expand-source (wrap-program (##vector-ref x 1)));;;;;;;;;;;;;;
Expand Down Expand Up @@ -259,7 +260,6 @@
(target.dump (target.dump
module-procs module-procs
output output
output-root
c-intf c-intf
(##vector-ref x 0);;;;;;;;;;;;;;;;;;;; (##vector-ref x 0);;;;;;;;;;;;;;;;;;;;
opts) opts)
Expand All @@ -271,22 +271,22 @@
(ptree.end!) (ptree.end!)
(env.end!) (env.end!)


#t)))) output))))


(set! warnings-requested? compiler-option-warnings) (set! warnings-requested? compiler-option-warnings)


(let ((successful (with-exception-handling compiler-body))) (let ((result (with-exception-handling compiler-body)))


(if info-port (if info-port
(if successful (if result
(begin (begin
(display "Compilation finished." info-port) (display "Compilation finished." info-port)
(newline info-port)) (newline info-port))
(begin (begin
(display "Compilation terminated abnormally." info-port) (display "Compilation terminated abnormally." info-port)
(newline info-port)))) (newline info-port))))


successful)) result))


(define (valid-module-name? module-name) (define (valid-module-name? module-name)


Expand Down
Loading

0 comments on commit 095a643

Please sign in to comment.