diff options
-rw-r--r-- | module/language/ghil.scm | 5 | ||||
-rw-r--r-- | module/language/ghil/spec.scm | 19 | ||||
-rw-r--r-- | module/language/scheme/compile-ghil.scm | 18 | ||||
-rw-r--r-- | module/system/base/compile.scm | 87 | ||||
-rw-r--r-- | module/system/base/language.scm | 4 | ||||
-rwxr-xr-x | scripts/compile | 61 |
6 files changed, 119 insertions, 75 deletions
diff --git a/module/language/ghil.scm b/module/language/ghil.scm index 00a2c9afd..273d0aa20 100644 --- a/module/language/ghil.scm +++ b/module/language/ghil.scm @@ -432,7 +432,10 @@ ((<ghil-quote> env loc obj) `(,'quote ,obj)) ((<ghil-quasiquote> env loc exp) - `(,'quasiquote ,(map unparse-ghil exp))) + `(,'quasiquote ,(let lp ((x exp)) + (cond ((struct? x) (unparse-ghil x)) + ((pair? x) (cons (lp (car x)) (lp (cdr x)))) + (else x))))) ((<ghil-unquote> env loc exp) `(,'unquote ,(unparse-ghil exp))) ((<ghil-unquote-splicing> env loc exp) diff --git a/module/language/ghil/spec.scm b/module/language/ghil/spec.scm index ee574b50b..c9d38aa69 100644 --- a/module/language/ghil/spec.scm +++ b/module/language/ghil/spec.scm @@ -34,11 +34,30 @@ (lambda (env vars) (make-ghil-lambda env #f vars #f '() (parse-ghil env x))))) +(define (join exps env) + (if (or-map (lambda (x) + (or (not (ghil-lambda? x)) + (ghil-lambda-rest x) + (memq 'argument + (map ghil-var-kind + (ghil-env-variables (ghil-lambda-env x)))))) + exps) + (error "GHIL expressions to join must be thunks")) + + (let ((env (make-ghil-env env '() + (apply append + (map ghil-env-variables + (map ghil-lambda-env exps)))))) + (make-ghil-lambda env #f '() #f '() + (make-ghil-begin env #f + (map ghil-lambda-body exps))))) + (define-language ghil #:title "Guile High Intermediate Language (GHIL)" #:version "0.3" #:reader read #:printer write-ghil #:parser parse + #:joiner join #:compilers `((glil . ,compile-glil)) ) diff --git a/module/language/scheme/compile-ghil.scm b/module/language/scheme/compile-ghil.scm index f1816e18c..fcca8a940 100644 --- a/module/language/scheme/compile-ghil.scm +++ b/module/language/scheme/compile-ghil.scm @@ -36,7 +36,7 @@ ;;; environment := #f ;;; | MODULE ;;; | COMPILE-ENV -;;; compile-env := (MODULE LEXICALS . EXTERNALS) +;;; compile-env := (MODULE LEXICALS|GHIL-ENV . EXTERNALS) (define (cenv-module env) (cond ((not env) #f) ((module? env) env) @@ -47,7 +47,9 @@ (cond ((not env) (make-ghil-toplevel-env)) ((module? env) (make-ghil-toplevel-env)) ((pair? env) - (ghil-env-dereify (cadr env))) + (if (struct? (cadr env)) + (cadr env) + (ghil-env-dereify (cadr env)))) (else (error "bad environment" env)))) (define (cenv-externals env) @@ -68,13 +70,11 @@ (call-with-ghil-environment (cenv-ghil-env e) '() (lambda (env vars) (let ((x (make-ghil-lambda env #f vars #f '() - (translate-1 env #f x)))) - (values x - (and e - (cons* (cenv-module e) - (ghil-env-parent env) - (cenv-externals e))) - (make-cenv (current-module) '() '())))))))) + (translate-1 env #f x))) + (cenv (make-cenv (current-module) + (ghil-env-parent env) + (if e (cenv-externals e) '())))) + (values x cenv cenv))))))) ;;; diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm index 99c80b2fd..7d54947e3 100644 --- a/module/system/base/compile.scm +++ b/module/system/base/compile.scm @@ -92,33 +92,24 @@ x (lookup-language x))) -(define* (compile-file file #:optional output-file - #:key (to 'objcode) (opts '())) +(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))) - (lang (ensure-language (current-language))) - (to (ensure-language to))) - (catch 'nothing-at-all - (lambda () - (call-with-compile-error-catch - (lambda () - (call-with-output-file/atomic comp - (lambda (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) - (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))))) + (in (open-input-file file))) + (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 (to 'value) (opts '())) - (let ((lang (ensure-language (current-language)))) - (compile (read-file-in file lang) #:to 'value #:opts opts))) + (read-and-compile (open-input-port file) + #:from lang #:to to #:opts opts)) (define (compiled-file-name file) (let ((base (basename file)) @@ -155,10 +146,11 @@ (error "no way to compile" from "to" to)))) (define (compile-fold passes exp env opts) - (if (null? passes) - exp - (receive (exp env cenv) ((car passes) exp env opts) - (compile-fold (cdr 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 (compile-time-environment) "A special function known to the compiler that, when compiled, will @@ -167,15 +159,46 @@ time. Useful for supporting some forms of dynamic compilation. Returns #f if called from the interpreter." #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 '())) - (compile-fold (compile-passes from to opts) - x - env - opts)) + (receive (exp env cenv) + (compile-fold (compile-passes from to opts) x env opts) + exp)) ;;; diff --git a/module/system/base/language.scm b/module/system/base/language.scm index 70000c551..649137c4d 100644 --- a/module/system/base/language.scm +++ b/module/system/base/language.scm @@ -25,6 +25,7 @@ language-name language-title language-version language-reader language-printer language-parser language-read-file language-compilers language-decompilers language-evaluator + language-joiner lookup-compilation-order lookup-decompilation-order invalidate-compilation-cache!)) @@ -44,7 +45,8 @@ (read-file #f) (compilers '()) (decompilers '()) - (evaluator #f)) + (evaluator #f) + (joiner #f)) (define-macro (define-language name . spec) `(begin diff --git a/scripts/compile b/scripts/compile index 6651722f0..41f542c1d 100755 --- a/scripts/compile +++ b/scripts/compile @@ -28,9 +28,7 @@ exec ${GUILE-guile} -e '(@ (scripts compile) compile)' -s $0 "$@" ;; Usage: compile [ARGS] ;; -;; PROGRAM does something. -;; -;; TODO: Write it! +;; A command-line interface to the Guile compiler. ;;; Code: @@ -67,15 +65,16 @@ exec ${GUILE-guile} -e '(@ (scripts compile) compile)' -s $0 "$@" (option '(#\O "optimize") #f #f (lambda (opt name arg result) (alist-cons 'optimize? #t result))) - (option '(#\e "expand-only") #f #f - (lambda (opt name arg result) - (alist-cons 'expand-only? #t result))) - (option '(#\t "translate-only") #f #f + (option '(#\f "from") #t #f (lambda (opt name arg result) - (alist-cons 'translate-only? #t result))) - (option '(#\c "compile-only") #f #f + (if (assoc-ref result 'from) + (fail "`--from' option cannot be specified more than once") + (alist-cons 'from (string->symbol arg) result)))) + (option '(#\t "to") #t #f (lambda (opt name arg result) - (alist-cons 'compile-only? #t result))))) + (if (assoc-ref result 'to) + (fail "`--to' option cannot be specified more than once") + (alist-cons 'to (string->symbol arg) result)))))) (define (parse-args args) "Parse argument list @var{args} and return an alist with all the relevant @@ -97,46 +96,44 @@ options." (define (compile args) (let* ((options (parse-args (cdr args))) (help? (assoc-ref options 'help?)) - (optimize? (assoc-ref options 'optimize?)) - (expand-only? (assoc-ref options 'expand-only?)) - (translate-only? (assoc-ref options 'translate-only?)) - (compile-only? (assoc-ref options 'compile-only?)) + (compile-opts (if (assoc-ref options 'optimize?) '(#:O) '())) + (from (or (assoc-ref options 'from) 'scheme)) + (to (or (assoc-ref options 'to) 'objcode)) (input-files (assoc-ref options 'input-files)) (output-file (assoc-ref options 'output-file)) (load-path (assoc-ref options 'load-path))) (if (or help? (null? input-files)) (begin (format #t "Usage: compile [OPTION] FILE... -Compile each Guile Scheme source file FILE into a Guile object. +Compile each Guile source file FILE into a Guile object. -h, --help print this help message -L, --load-path=DIR add DIR to the front of the module load path -o, --output=OFILE write output to OFILE - -O, --optimize turn on optimizations - -e, --expand-only only go through the code expansion stage - -t, --translate-only stop after the translation to GHIL - -c, --compile-only stop after the compilation to GLIL + -f, --from=LANG specify a source language other than `scheme' + -t, --to=LANG specify a target language other than `objcode' Report bugs to <guile-user@gnu.org>.~%") (exit 0))) (set! %load-path (append load-path %load-path)) - (let ((compile-opts (append (if optimize? '(#:O) '()) - (if expand-only? '(#:e) '()) - (if translate-only? '(#:t) '()) - (if compile-only? '(#:c) '())))) - (if output-file - (if (and (not (null? input-files)) - (null? (cdr input-files))) - (compile-file (car input-files) output-file) - (fail "`-o' option can only be specified " - "when compiling a single file")) - (for-each (lambda (file) - (apply compile-file file compile-opts)) - input-files))))) + (if (and output-file + (or (null? input-files) + (not (null? (cdr input-files))))) + (fail "`-o' option can only be specified " + "when compiling a single file")) + + (for-each (lambda (file) + (format #t "wrote `~A'\n" + (compile-file file + #:output-file output-file + #:from from + #:to to + #:opts compile-opts))) + input-files))) ;;; Local Variables: ;;; coding: latin-1 |