summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2008-11-11 22:52:24 +0100
committerAndy Wingo <wingo@pobox.com>2008-11-11 22:52:24 +0100
commitf38624b349c29e3e5b3e6518959f33803af45558 (patch)
tree3c7cc7f464ed1696964ebdb07d6d613399ff31a2
parentf698d111b4e6cc763c01e157c291358152a18ec3 (diff)
downloadguile-f38624b349c29e3e5b3e6518959f33803af45558.tar.gz
add parsers and unparser for ghil; ,language ghil works now
* module/system/repl/common.scm (repl-print): Slightly refine the meaning of "language-printer": a language printer prints an expression of a language, not the result of evaluation. `write' prints values. * module/language/ghil/spec.scm (ghil): Define a language printer, and a translator for turning s-expressions (not scheme, mind you) into GHIL. * module/language/scheme/translate.scm (quote, quasiquote): Add some #:keyword action, so that we can (quote #:keywords). * module/system/base/language.scm (<language>): * module/system/base/compile.scm (read-file-in): Don't require that a language have a read-file; instead error when read-file is called. (compile-passes, compile-in): Refactor to call a helper method to turn the language + set of options into a set of compiler passes. * module/system/base/syntax.scm (define-type): Allow the type to be a list, with the car being the name and the cdr being keyword options. Interpret #:printer as a printer, and pass it down to... (define-record): Here. * module/system/il/ghil.scm (print-ghil, <ghil>): New printer for GHIL, yay! (parse-ghil, unparse-ghil): New lovely functions. Will document them in the manual.
-rw-r--r--module/language/ghil/spec.scm13
-rw-r--r--module/language/scheme/translate.scm4
-rw-r--r--module/system/base/compile.scm43
-rw-r--r--module/system/base/language.scm7
-rw-r--r--module/system/base/syntax.scm12
-rw-r--r--module/system/il/ghil.scm324
-rw-r--r--module/system/repl/common.scm6
7 files changed, 225 insertions, 184 deletions
diff --git a/module/language/ghil/spec.scm b/module/language/ghil/spec.scm
index 6afdf0e17..6e07f0265 100644
--- a/module/language/ghil/spec.scm
+++ b/module/language/ghil/spec.scm
@@ -21,12 +21,21 @@
(define-module (language ghil spec)
#:use-module (system base language)
+ #:use-module (system il ghil)
#:export (ghil))
+(define (write-ghil exp . port)
+ (apply write (unparse-ghil exp) port))
+
+(define (translate x e)
+ (call-with-ghil-environment e '()
+ (lambda (env vars)
+ (make-ghil-lambda env #f vars #f '() (parse-ghil env x)))))
+
(define-language ghil
#:title "Guile High Intermediate Language (GHIL)"
#:version "0.3"
#:reader read
- #:printer write
-;; #:environment (make-vmodule)
+ #:printer write-ghil
+ #:translator translate
)
diff --git a/module/language/scheme/translate.scm b/module/language/scheme/translate.scm
index c5671260d..b191ff296 100644
--- a/module/language/scheme/translate.scm
+++ b/module/language/scheme/translate.scm
@@ -136,11 +136,11 @@
(define-scheme-translator quote
;; (quote OBJ)
- ((,obj) (make-ghil-quote e l obj)))
+ ((,obj) (make-ghil-quote e l #:obj obj)))
(define-scheme-translator quasiquote
;; (quasiquote OBJ)
- ((,obj) (make-ghil-quasiquote e l (trans-quasiquote e l obj 0))))
+ ((,obj) (make-ghil-quasiquote e l #:exp (trans-quasiquote e l obj 0))))
(define-scheme-translator define
;; (define NAME VAL)
diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm
index d75dc3dcd..1b8183edf 100644
--- a/module/system/base/compile.scm
+++ b/module/system/base/compile.scm
@@ -30,6 +30,7 @@
#:use-module (system vm vm) ;; for compile-time evaluation
#: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
*current-language*
compiled-file-name
@@ -197,27 +198,35 @@ time. Useful for supporting some forms of dynamic compilation. Returns
;;;
(define (read-file-in file lang)
- (call-with-input-file file (language-read-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))
+ (out '()))
+ (if (or (null? keys)
+ (and (car keys) (memq (car keys) opts)))
+ (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 ()
- (catch 'result
- (lambda ()
- (and=> (cenv-module e) set-current-module)
- (set! e (cenv-ghil-env e))
- ;; expand
- (set! x ((language-expander lang) x e))
- (if (memq #:e opts) (throw 'result x))
- ;; translate
- (set! x ((language-translator lang) x e))
- (if (memq #:t opts) (throw 'result x))
- ;; compile
- (set! x (apply compile-il x e opts))
- (if (memq #:c opts) (throw 'result x))
- ;; assemble
- (apply assemble x e opts))
- (lambda (key val) val)))))
+ (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))))))
;;;
;;;
diff --git a/module/system/base/language.scm b/module/system/base/language.scm
index 609db7df0..50de15a7d 100644
--- a/module/system/base/language.scm
+++ b/module/system/base/language.scm
@@ -31,9 +31,10 @@
;;; Language class
;;;
-(define-record (<language> name title version reader printer read-file
- (expander (lambda (x e) x))
- (translator (lambda (x e) x))
+(define-record (<language> name title version reader printer
+ (read-file #f)
+ (expander #f)
+ (translator #f)
(evaluator #f)
(environment #f)
))
diff --git a/module/system/base/syntax.scm b/module/system/base/syntax.scm
index 8b0ba5969..0e02ba06a 100644
--- a/module/system/base/syntax.scm
+++ b/module/system/base/syntax.scm
@@ -29,7 +29,12 @@
;;;
(define-macro (define-type name . rest)
- `(begin ,@(map (lambda (def) `(define-record ,def)) rest)))
+ (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) '())))
+ rest)))))
;;;
@@ -39,13 +44,14 @@
(define (symbol-trim-both sym pred)
(string->symbol (string-trim-both (symbol->string sym) pred)))
-(define-macro (define-record def)
+(define-macro (define-record def . printer)
(let* ((name (car def)) (slots (cdr def))
(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))
+ (define ,name (make-record-type ,(symbol->string name) ',slot-names
+ ,@printer))
(define ,(symbol-append 'make- stem)
(let ((slots (list ,@(map (lambda (slot)
(if (pair? slot)
diff --git a/module/system/il/ghil.scm b/module/system/il/ghil.scm
index 5823ffb62..24368f4e4 100644
--- a/module/system/il/ghil.scm
+++ b/module/system/il/ghil.scm
@@ -20,7 +20,8 @@
;;; Code:
(define-module (system il ghil)
- #:use-syntax (system base syntax)
+ #:use-module (system base syntax)
+ #:use-module (system base pmatch)
#:use-module (ice-9 regex)
#:export
(<ghil-void> make-ghil-void ghil-void?
@@ -100,14 +101,19 @@
ghil-env-reify ghil-env-dereify
ghil-var-is-bound? ghil-var-for-ref! ghil-var-for-set! ghil-var-define!
ghil-var-at-module!
- call-with-ghil-environment call-with-ghil-bindings))
+ call-with-ghil-environment call-with-ghil-bindings
+
+ parse-ghil unparse-ghil))
;;;
;;; Parse tree
;;;
-(define-type <ghil>
+(define (print-ghil x port)
+ (format port "#<ghil ~s>" (unparse-ghil x)))
+
+(define-type (<ghil> #:printer print-ghil)
;; Objects
(<ghil-void> env loc)
(<ghil-quote> env loc obj)
@@ -309,156 +315,162 @@
;;; Parser
;;;
-;;; (define-public (parse-ghil x e)
-;;; (parse `(@lambda () ,x) (make-ghil-mod e)))
-;;;
-;;; (define (parse x e)
-;;; (cond ((pair? x) (parse-pair x e))
-;;; ((symbol? x)
-;;; (let ((str (symbol->string x)))
-;;; (case (string-ref str 0)
-;;; ((#\@) (error "Invalid use of IL primitive" x))
-;;; ((#\:) (let ((sym (string->symbol (substring str 1))))
-;;; (<ghil-quote> (symbol->keyword sym))))
-;;; (else (<ghil-ref> e (ghil-lookup e x))))))
-;;; (else (<ghil-quote> x))))
-;;;
-;;; (define (map-parse x e)
-;;; (map (lambda (x) (parse x e)) x))
-;;;
-;;; (define (parse-pair x e)
-;;; (let ((head (car x)) (tail (cdr x)))
-;;; (if (and (symbol? head) (eq? (string-ref (symbol->string head) 0) #\@))
-;;; (if (ghil-primitive-macro? head)
-;;; (parse (apply (ghil-macro-expander head) tail) e)
-;;; (parse-primitive head tail e))
-;;; (<ghil-call> e (parse head e) (map-parse tail e)))))
-;;;
-;;; (define (parse-primitive prim args e)
-;;; (case prim
-;;; ;; (@ IDENTIFIER)
-;;; ((@)
-;;; (match args
-;;; (()
-;;; (<ghil-ref> e (make-ghil-var '@ '@ 'module)))
-;;; ((identifier)
-;;; (receive (module name) (identifier-split identifier)
-;;; (<ghil-ref> e (make-ghil-var module name 'module))))))
-;;;
-;;; ;; (@@ OP ARGS...)
-;;; ((@@)
-;;; (match args
-;;; ((op . args)
-;;; (<ghil-inline> op (map-parse args e)))))
-;;;
-;;; ;; (@void)
-;;; ((@void)
-;;; (match args
-;;; (() (<ghil-void>))))
-;;;
-;;; ;; (@quote OBJ)
-;;; ((@quote)
-;;; (match args
-;;; ((obj)
-;;; (<ghil-quote> obj))))
-;;;
-;;; ;; (@define NAME VAL)
-;;; ((@define)
-;;; (match args
-;;; ((name val)
-;;; (let ((v (ghil-lookup e name)))
-;;; (<ghil-set> e v (parse val e))))))
-;;;
-;;; ;; (@set! NAME VAL)
-;;; ((@set!)
-;;; (match args
-;;; ((name val)
-;;; (let ((v (ghil-lookup e name)))
-;;; (<ghil-set> e v (parse val e))))))
-;;;
-;;; ;; (@if TEST THEN [ELSE])
-;;; ((@if)
-;;; (match args
-;;; ((test then)
-;;; (<ghil-if> (parse test e) (parse then e) (<ghil-void>)))
-;;; ((test then else)
-;;; (<ghil-if> (parse test e) (parse then e) (parse else e)))))
-;;;
-;;; ;; (@begin BODY...)
-;;; ((@begin)
-;;; (parse-body args e))
-;;;
-;;; ;; (@let ((SYM INIT)...) BODY...)
-;;; ((@let)
-;;; (match args
-;;; ((((sym init) ...) body ...)
-;;; (let* ((vals (map-parse init e))
-;;; (vars (map (lambda (s)
-;;; (let ((v (make-ghil-var e s 'local)))
-;;; (ghil-env-add! e v) v))
-;;; sym))
-;;; (body (parse-body body e)))
-;;; (for-each (lambda (v) (ghil-env-remove! e v)) vars)
-;;; (<ghil-bind> e vars vals body)))))
-;;;
-;;; ;; (@letrec ((SYM INIT)...) BODY...)
-;;; ((@letrec)
-;;; (match args
-;;; ((((sym init) ...) body ...)
-;;; (let* ((vars (map (lambda (s)
-;;; (let ((v (make-ghil-var e s 'local)))
-;;; (ghil-env-add! e v) v))
-;;; sym))
-;;; (vals (map-parse init e))
-;;; (body (parse-body body e)))
-;;; (for-each (lambda (v) (ghil-env-remove! e v)) vars)
-;;; (<ghil-bind> e vars vals body)))))
-;;;
-;;; ;; (@lambda FORMALS BODY...)
-;;; ((@lambda)
-;;; (match args
-;;; ((formals . body)
-;;; (receive (syms rest) (parse-formals formals)
-;;; (let* ((e (make-ghil-env e))
-;;; (vars (map (lambda (s)
-;;; (let ((v (make-ghil-var e s 'argument)))
-;;; (ghil-env-add! e v) v))
-;;; syms)))
-;;; (<ghil-lambda> e vars rest (parse-body body e)))))))
-;;;
-;;; ;; (@eval-case CLAUSE...)
-;;; ((@eval-case)
-;;; (let loop ((clauses args))
-;;; (cond ((null? clauses) (<ghil-void>))
-;;; ((or (eq? (caar clauses) '@else)
-;;; (and (memq 'load-toplevel (caar clauses))
-;;; (ghil-env-toplevel? e)))
-;;; (parse-body (cdar clauses) e))
-;;; (else
-;;; (loop (cdr clauses))))))
-;;;
-;;; (else (error "Unknown primitive:" prim))))
-;;;
-;;; (define (parse-body x e)
-;;; (<ghil-begin> (map-parse x e)))
-;;;
-;;; (define (parse-formals formals)
-;;; (cond
-;;; ;; (@lambda x ...)
-;;; ((symbol? formals) (values (list formals) #t))
-;;; ;; (@lambda (x y z) ...)
-;;; ((list? formals) (values formals #f))
-;;; ;; (@lambda (x y . z) ...)
-;;; ((pair? formals)
-;;; (let loop ((l formals) (v '()))
-;;; (if (pair? l)
-;;; (loop (cdr l) (cons (car l) v))
-;;; (values (reverse! (cons l v)) #t))))
-;;; (else (error "Invalid formals:" formals))))
-;;;
-;;; (define (identifier-split identifier)
-;;; (let ((m (string-match "::([^:]*)$" (symbol->string identifier))))
-;;; (if m
-;;; (values (string->symbol (match:prefix m))
-;;; (string->symbol (match:substring m 1)))
-;;; (values #f identifier))))
+(define (location x)
+ (and (pair? x)
+ (let ((props (source-properties x)))
+ (and (not (null? props))
+ (vector (assq-ref props 'line)
+ (assq-ref props 'column)
+ (assq-ref props 'filename))))))
+
+(define (parse-quasiquote e x level)
+ (cond ((not (pair? x)) x)
+ ((memq (car x) '(unquote unquote-splicing))
+ (let ((l (location x)))
+ (pmatch (cdr x)
+ ((,obj)
+ (cond
+ ((zero? level)
+ (if (eq? (car x) 'unquote)
+ (make-ghil-unquote e l (parse-ghil e obj))
+ (make-ghil-unquote-splicing e l (parse-ghil e obj))))
+ (else
+ (list (car x) (parse-quasiquote e obj (1- level))))))
+ (else (syntax-error l (format #f "bad ~A" (car x)) x)))))
+ ((eq? (car x) 'quasiquote)
+ (let ((l (location x)))
+ (pmatch (cdr x)
+ ((,obj) (list 'quasiquote (parse-quasiquote e obj (1+ level))))
+ (else (syntax-error l (format #f "bad ~A" (car x)) x)))))
+ (else (cons (parse-quasiquote e (car x) level)
+ (parse-quasiquote e (cdr x) level)))))
+
+(define (parse-ghil env exp)
+ (let ((loc (location exp))
+ (retrans (lambda (x) (parse-ghil env x))))
+ (pmatch exp
+ (,exp (guard (symbol? exp))
+ (make-ghil-ref env #f (ghil-var-for-ref! env exp)))
+
+ (,exp (guard (not (pair? exp)))
+ (make-ghil-quote #:env env #:loc #f #:obj exp))
+
+ (('quote ,exp) (make-ghil-quote #:env env #:loc loc #:obj exp))
+
+ ((void) (make-ghil-void env loc))
+
+ ((lambda ,syms ,rest ,meta . ,body)
+ (call-with-ghil-environment env syms
+ (lambda (env vars)
+ (make-ghil-lambda env loc vars rest meta
+ (parse-ghil env `(begin ,@body))))))
+
+ ((begin . ,body)
+ (make-ghil-begin env loc (map retrans body)))
+
+ ((bind ,syms ,exprs . ,body)
+ (let ((vals (map retrans exprs)))
+ (call-with-ghil-bindings env syms
+ (lambda (vars)
+ (make-ghil-bind env loc vars vals (retrans `(begin ,@body)))))))
+
+ ((bindrec ,syms ,exprs . ,body)
+ (call-with-ghil-bindings env syms
+ (lambda (vars)
+ (let ((vals (map (lambda (exp) (parse-ghil env exp)) exprs)))
+ (make-ghil-bind env loc vars vals (retrans `(begin ,@body)))))))
+
+ ((set! ,sym ,val)
+ (make-ghil-set env loc (ghil-var-for-set! env sym) (retrans val)))
+
+ ((define ,sym ,val)
+ (make-ghil-define env loc (ghil-var-define! env sym) (retrans val)))
+
+ ((if ,test ,then ,else)
+ (make-ghil-if env loc (retrans test) (retrans then) (retrans else)))
+
+ ((and . ,exps)
+ (make-ghil-and env loc (map retrans exps)))
+
+ ((or . ,exps)
+ (make-ghil-or env loc (map retrans exps)))
+
+ ((mv-bind ,syms ,rest ,producer . ,body)
+ (call-with-ghil-bindings env syms
+ (lambda (vars)
+ (make-ghil-mv-bind env loc (retrans producer) vars rest
+ (map retrans body)))))
+
+ ((call ,proc . ,args)
+ (make-ghil-call env loc (retrans proc) (map retrans args)))
+
+ ((mv-call ,producer . ,consumer)
+ (make-ghil-mv-call env loc (retrans producer) (retrans consumer)))
+
+ ((inline ,op . ,args)
+ (make-ghil-inline env loc op (map retrans args)))
+
+ ((values . ,values)
+ (make-ghil-values env loc (map retrans values)))
+
+ ((values* . ,values)
+ (make-ghil-values env loc (map retrans values)))
+
+ ((compile-time-environment)
+ (make-ghil-reified-env env loc))
+
+ ((quasiquote ,exp)
+ (make-ghil-quasiquote env loc #:exp (parse-quasiquote env exp 0)))
+
+ (else
+ (error "unrecognized GHIL" exp)))))
+
+(define (unparse-ghil ghil)
+ (record-case ghil
+ ((<ghil-void> env loc)
+ '(void))
+ ((<ghil-quote> env loc obj)
+ `(quote ,obj))
+ ((<ghil-quasiquote> env loc exp)
+ `(quasiquote ,(map unparse-ghil exp)))
+ ((<ghil-unquote> env loc exp)
+ `(unquote ,(unparse-ghil exp)))
+ ((<ghil-unquote-splicing> env loc exp)
+ `(unquote-splicing ,(unparse-ghil exp)))
+ ;; Variables
+ ((<ghil-ref> env loc var)
+ (ghil-var-name var))
+ ((<ghil-set> env loc var val)
+ `(set! ,(ghil-var-name var) ,(unparse-ghil val)))
+ ((<ghil-define> env loc var val)
+ `(define ,(ghil-var-name var) ,(unparse-ghil val)))
+ ;; Controls
+ ((<ghil-if> env loc test then else)
+ `(if ,(unparse-ghil test) ,(unparse-ghil then) ,(unparse-ghil else)))
+ ((<ghil-and> env loc exps)
+ `(and ,@(map unparse-ghil exps)))
+ ((<ghil-or> env loc exps)
+ `(or ,@(map unparse-ghil exps)))
+ ((<ghil-begin> env loc exps)
+ `(begin ,@(map unparse-ghil exps)))
+ ((<ghil-bind> env loc vars vals body)
+ `(bind ,(map ghil-var-name vars) ,(map unparse-ghil vals)
+ ,@(map unparse-ghil body)))
+ ((<ghil-mv-bind> env loc producer vars rest body)
+ `(mv-bind ,(map ghil-var-name vars) ,rest
+ ,(unparse-ghil producer) ,@(map unparse-ghil body)))
+ ((<ghil-lambda> env loc vars rest meta body)
+ `(lambda ,(map ghil-var-name vars) ,rest ,meta
+ ,(unparse-ghil body)))
+ ((<ghil-call> env loc proc args)
+ `(call ,(unparse-ghil proc) ,@(map unparse-ghil args)))
+ ((<ghil-mv-call> env loc producer consumer)
+ `(mv-call ,(unparse-ghil producer) ,(unparse-ghil consumer)))
+ ((<ghil-inline> env loc inline args)
+ `(inline ,inline (map unparse-ghil args)))
+ ((<ghil-values> env loc values)
+ `(values (map unparse-ghil values)))
+ ((<ghil-values*> env loc values)
+ `(values* (map unparse-ghil values)))
+ ((<ghil-reified-env> env loc)
+ `(compile-time-environment))))
diff --git a/module/system/repl/common.scm b/module/system/repl/common.scm
index 608c38577..7aa322e05 100644
--- a/module/system/repl/common.scm
+++ b/module/system/repl/common.scm
@@ -78,7 +78,11 @@
(define (repl-print repl val)
(if (not (eq? val *unspecified*))
(begin
- ((language-printer (repl-language repl)) val)
+ ;; The result of an evaluation is representable in scheme, and
+ ;; should be printed with the generic printer, `write'. The
+ ;; language-printer is something else: it prints expressions of
+ ;; a given language, not the result of evaluation.
+ (write val)
(newline))))
(define (repl-option-ref repl key)