((<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)
(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))
)
;;; 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)
(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)
(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)))))))
\f
;;;
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))
(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
#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))
\f
;;;
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!))
(read-file #f)
(compilers '())
(decompilers '())
- (evaluator #f))
+ (evaluator #f)
+ (joiner #f))
(define-macro (define-language name . spec)
`(begin
;; Usage: compile [ARGS]
;;
-;; PROGRAM does something.
-;;
-;; TODO: Write it!
+;; A command-line interface to the Guile compiler.
;;; Code:
(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
(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
HCoop / bpt / guile.git / commitdiff