-;;; Guile High Intermediate Language
-
-;; Copyright (C) 2001 Free Software Foundation, Inc.
-
-;; This program is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-;;
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with this program; see the file COPYING. If not, write to
-;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
-
-;;; Code:
-
-(define-module (system il ghil)
- :use-syntax (system base syntax)
- :use-module (ice-9 regex)
- :export
- (<ghil-void> make-ghil-void ghil-void?
- ghil-void-env ghil-void-loc
-
- <ghil-quote> make-ghil-quote ghil-quote?
- ghil-quote-env ghil-quote-loc ghil-quote-obj
-
- <ghil-quasiquote> make-ghil-quasiquote ghil-quasiquote?
- ghil-quasiquote-env ghil-quasiquote-loc ghil-quasiquote-exp
-
- <ghil-unquote> make-ghil-unquote ghil-unquote?
- ghil-unquote-env ghil-unquote-loc ghil-unquote-exp
-
- <ghil-unquote-splicing> make-ghil-unquote-splicing ghil-unquote-splicing?
- ghil-unquote-env ghil-unquote-loc ghil-unquote-exp
-
- <ghil-ref> make-ghil-ref ghil-ref?
- ghil-ref-env ghil-ref-loc ghil-ref-var
-
- <ghil-set> make-ghil-set ghil-set?
- ghil-set-env ghil-set-loc ghil-set-var ghil-set-val
-
- <ghil-define> make-ghil-define ghil-define?
- ghil-define-env ghil-define-loc ghil-define-var ghil-define-val
-
- <ghil-if> make-ghil-if ghil-if?
- ghil-if-env ghil-if-loc ghil-if-test ghil-if-then ghil-if-else
-
- <ghil-and> make-ghil-and ghil-and?
- ghil-and-env ghil-and-loc ghil-and-exps
-
- <ghil-or> make-ghil-or ghil-or?
- ghil-or-env ghil-or-loc ghil-or-exps
-
- <ghil-begin> make-ghil-begin ghil-begin?
- ghil-begin-env ghil-begin-loc ghil-begin-exps
-
- <ghil-bind> make-ghil-bind ghil-bind?
- ghil-bind-env ghil-bind-loc ghil-bind-vars ghil-bind-vals ghil-bind-body
-
- <ghil-lambda> make-ghil-lambda ghil-lambda?
- ghil-lambda-env ghil-lambda-loc ghil-lambda-vars ghil-lambda-rest ghil-lambda-body
-
- <ghil-inline> make-ghil-inline ghil-inline?
- ghil-inline-env ghil-inline-loc ghil-inline-inline ghil-inline-args
-
- <ghil-call> make-ghil-call ghil-call?
- ghil-call-env ghil-call-loc ghil-call-proc ghil-call-args
-
- <ghil-var> make-ghil-var ghil-var?
- ghil-var-env ghil-var-name ghil-var-kind ghil-var-type ghil-var-value
- ghil-var-index
-
- <ghil-mod> make-ghil-mod ghil-mod?
- ghil-mod-module ghil-mod-table ghil-mod-imports
-
- <ghil-env> make-ghil-env ghil-env?
- ghil-env-mod ghil-env-parent ghil-env-table ghil-env-variables
-
- ghil-primitive-macro? ghil-env-add! ghil-lookup ghil-define
- ghil-env-toplevel?
- call-with-ghil-environment call-with-ghil-bindings))
-
-\f
-;;;
-;;; Parse tree
-;;;
-
-(define-type <ghil>
- (|
- ;; Objects
- (<ghil-void> env loc)
- (<ghil-quote> env loc obj)
- (<ghil-quasiquote> env loc exp)
- (<ghil-unquote> env loc exp)
- (<ghil-unquote-splicing> env loc exp)
- ;; Variables
- (<ghil-ref> env loc var)
- (<ghil-set> env loc var val)
- (<ghil-define> env loc var val)
- ;; Controls
- (<ghil-if> env loc test then else)
- (<ghil-and> env loc exps)
- (<ghil-or> env loc exps)
- (<ghil-begin> env loc exps)
- (<ghil-bind> env loc vars vals body)
- (<ghil-lambda> env loc vars rest body)
- (<ghil-call> env loc proc args)
- (<ghil-inline> env loc inline args)))
-
-\f
-;;;
-;;; Procedures
-;;;
-
-(define *core-primitives*
- '(@void @quote @define @set! @if @begin @let @letrec @lambda))
-
-(define *macro-module* (resolve-module '(system il macros)))
-
-(define (ghil-primitive-macro? x)
- (and (module-defined? *macro-module* x)
- (procedure? (module-ref *macro-module* x))))
-
-(define (ghil-macro-expander x)
- (module-ref *macro-module* x))
-
-(define (ghil-primitive? x)
- (or (memq x *core-primitives*)
- (ghil-primitive-macro? x)))
-
-\f
-;;;
-;;; Variables
-;;;
-
-(define-record (<ghil-var> env name kind (type #f) (value #f) (index #f)))
-
-\f
-;;;
-;;; Modules
-;;;
-
-(define-record (<ghil-mod> module (table '()) (imports '())))
-
-\f
-;;;
-;;; Environments
-;;;
-
-(define-record (<ghil-env> mod parent (table '()) (variables '())))
-
-(define %make-ghil-env make-ghil-env)
-(define (make-ghil-env e)
- (record-case e
- ((<ghil-mod>) (%make-ghil-env :mod e :parent e))
- ((<ghil-env> mod) (%make-ghil-env :mod mod :parent e))))
-
-(define (ghil-env-toplevel? e)
- (eq? (ghil-env-mod e) (ghil-env-parent e)))
-
-(define (ghil-env-ref env sym)
- (assq-ref (ghil-env-table env) sym))
-
-(define-macro (push! item loc)
- `(set! ,loc (cons ,item ,loc)))
-(define-macro (apush! k v loc)
- `(set! ,loc (acons ,k ,v ,loc)))
-(define-macro (apopq! k loc)
- `(set! ,loc (assq-remove! ,loc ,k)))
-
-(define (ghil-env-add! env var)
- (apush! (ghil-var-name var) var (ghil-env-table env))
- (push! var (ghil-env-variables env)))
-
-(define (ghil-env-remove! env var)
- (apopq! (ghil-var-name var) (ghil-env-table env)))
-
-\f
-;;;
-;;; Public interface
-;;;
-
-(define (module-lookup module sym)
- (let ((iface (module-import-interface module sym)))
- (and iface
- (make-ghil-env (make-ghil-mod iface)))))
-
-(define (fix-ghil-mod! mod for-sym)
- ;;; So, these warnings happen for all instances of define-module.
- ;;; Rather than fixing the problem, I'm going to suppress the common
- ;;; warnings.
- (if (not (eq? for-sym 'process-define-module))
- (warn "during lookup of" for-sym ":"
- (ghil-mod-module mod) "!= current" (current-module)))
- (if (not (null? (ghil-mod-table mod)))
- (warn "throwing away old variable table"
- (ghil-mod-module) (ghil-mod-table mod)))
- (set! (ghil-mod-module mod) (current-module))
- (set! (ghil-mod-table mod) '())
- (set! (ghil-mod-imports mod) '()))
-
-;; looking up a var has side effects?
-(define (ghil-lookup env sym)
- (or (ghil-env-ref env sym)
- (let loop ((e (ghil-env-parent env)))
- (record-case e
- ((<ghil-mod> module table imports)
- (cond ((not (eq? module (current-module)))
- ;; FIXME: the primitive-eval in eval-case and/or macro
- ;; expansion can have side effects on the compilation
- ;; environment, for example changing the current
- ;; module. We probably need to add a special case in
- ;; compilation to handle define-module.
- (fix-ghil-mod! e sym)
- (loop e))
- ((assq-ref table sym)) ;; when does this hit?
- ((module-lookup module sym)
- => (lambda (found-env)
- (make-ghil-var found-env sym 'module)))
- (else
- ;; a free variable that we have not resolved
- (if (not (module-locally-bound? module sym))
- ;; For the benefit of repl compilation, that
- ;; doesn't compile modules all-at-once, don't warn
- ;; if we find the symbol locally.
- (warn "unresolved variable during compilation:" sym))
- (make-ghil-var #f sym 'module))))
- ((<ghil-env> mod parent table variables)
- (let ((found (assq-ref table sym)))
- (if found
- (begin (set! (ghil-var-kind found) 'external) found)
- (loop parent))))))))
-
-(define (ghil-define mod sym)
- (if (not (eq? (ghil-mod-module mod) (current-module)))
- (fix-ghil-mod! mod sym))
- (or (assq-ref (ghil-mod-table mod) sym)
- (let ((var (make-ghil-var (make-ghil-env mod) sym 'module)))
- (apush! sym var (ghil-mod-table mod))
- var)))
-
-(define (call-with-ghil-environment e syms func)
- (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)))
- (func e vars)))
-
-(define (call-with-ghil-bindings e syms func)
- (let* ((vars (map (lambda (s)
- (let ((v (make-ghil-var e s 'local)))
- (ghil-env-add! e v) v))
- syms))
- (ret (func vars)))
- (for-each (lambda (v) (ghil-env-remove! e v)) vars)
- ret))
-
-\f
-;;;
-;;; 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))))
+;;; Guile High Intermediate Language
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (system il ghil)
+ #:use-module (system base syntax)
+ #:use-module (system base pmatch)
+ #:use-module (ice-9 regex)
+ #:export
+ (<ghil-void> make-ghil-void ghil-void?
+ ghil-void-env ghil-void-loc
+
+ <ghil-quote> make-ghil-quote ghil-quote?
+ ghil-quote-env ghil-quote-loc ghil-quote-obj
+
+ <ghil-quasiquote> make-ghil-quasiquote ghil-quasiquote?
+ ghil-quasiquote-env ghil-quasiquote-loc ghil-quasiquote-exp
+
+ <ghil-unquote> make-ghil-unquote ghil-unquote?
+ ghil-unquote-env ghil-unquote-loc ghil-unquote-exp
+
+ <ghil-unquote-splicing> make-ghil-unquote-splicing ghil-unquote-splicing?
+ ghil-unquote-env ghil-unquote-loc ghil-unquote-exp
+
+ <ghil-ref> make-ghil-ref ghil-ref?
+ ghil-ref-env ghil-ref-loc ghil-ref-var
+
+ <ghil-set> make-ghil-set ghil-set?
+ ghil-set-env ghil-set-loc ghil-set-var ghil-set-val
+
+ <ghil-define> make-ghil-define ghil-define?
+ ghil-define-env ghil-define-loc ghil-define-var ghil-define-val
+
+ <ghil-if> make-ghil-if ghil-if?
+ ghil-if-env ghil-if-loc ghil-if-test ghil-if-then ghil-if-else
+
+ <ghil-and> make-ghil-and ghil-and?
+ ghil-and-env ghil-and-loc ghil-and-exps
+
+ <ghil-or> make-ghil-or ghil-or?
+ ghil-or-env ghil-or-loc ghil-or-exps
+
+ <ghil-begin> make-ghil-begin ghil-begin?
+ ghil-begin-env ghil-begin-loc ghil-begin-exps
+
+ <ghil-bind> make-ghil-bind ghil-bind?
+ ghil-bind-env ghil-bind-loc ghil-bind-vars ghil-bind-vals ghil-bind-body
+
+ <ghil-mv-bind> make-ghil-mv-bind ghil-mv-bind?
+ ghil-mv-bind-env ghil-mv-bind-loc ghil-mv-bind-producer ghil-mv-bind-vars ghil-mv-bind-rest ghil-mv-bind-body
+
+ <ghil-lambda> make-ghil-lambda ghil-lambda?
+ ghil-lambda-env ghil-lambda-loc ghil-lambda-vars ghil-lambda-rest
+ ghil-lambda-meta ghil-lambda-body
+
+ <ghil-inline> make-ghil-inline ghil-inline?
+ ghil-inline-env ghil-inline-loc ghil-inline-inline ghil-inline-args
+
+ <ghil-call> make-ghil-call ghil-call?
+ ghil-call-env ghil-call-loc ghil-call-proc ghil-call-args
+
+ <ghil-mv-call> make-ghil-mv-call ghil-mv-call?
+ ghil-mv-call-env ghil-mv-call-loc ghil-mv-call-producer ghil-mv-call-consumer
+
+ <ghil-values> make-ghil-values ghil-values?
+ ghil-values-env ghil-values-loc ghil-values-values
+
+ <ghil-values*> make-ghil-values* ghil-values*?
+ ghil-values*-env ghil-values*-loc ghil-values*-values
+
+ <ghil-var> make-ghil-var ghil-var?
+ ghil-var-env ghil-var-name ghil-var-kind ghil-var-index
+
+ <ghil-toplevel-env> make-ghil-toplevel-env ghil-toplevel-env?
+ ghil-toplevel-env-table
+
+ <ghil-env> make-ghil-env ghil-env?
+ ghil-env-parent ghil-env-table ghil-env-variables
+
+ <ghil-reified-env> make-ghil-reified-env ghil-reified-env?
+ ghil-reified-env-env ghil-reified-env-loc
+
+ ghil-env-add!
+ 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
+
+ parse-ghil unparse-ghil))
+
+\f
+;;;
+;;; Parse tree
+;;;
+
+(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)
+ (<ghil-quasiquote> env loc exp)
+ (<ghil-unquote> env loc exp)
+ (<ghil-unquote-splicing> env loc exp)
+ ;; Variables
+ (<ghil-ref> env loc var)
+ (<ghil-set> env loc var val)
+ (<ghil-define> env loc var val)
+ ;; Controls
+ (<ghil-if> env loc test then else)
+ (<ghil-and> env loc exps)
+ (<ghil-or> env loc exps)
+ (<ghil-begin> env loc exps)
+ (<ghil-bind> env loc vars vals body)
+ (<ghil-mv-bind> env loc producer vars rest body)
+ (<ghil-lambda> env loc vars rest meta body)
+ (<ghil-call> env loc proc args)
+ (<ghil-mv-call> env loc producer consumer)
+ (<ghil-inline> env loc inline args)
+ (<ghil-values> env loc values)
+ (<ghil-values*> env loc values)
+ (<ghil-reified-env> env loc))
+
+
+\f
+;;;
+;;; Variables
+;;;
+
+(define-record (<ghil-var> env name kind (index #f)))
+
+\f
+;;;
+;;; Modules
+;;;
+
+\f
+;;;
+;;; Environments
+;;;
+
+(define-record (<ghil-env> parent (table '()) (variables '())))
+(define-record (<ghil-toplevel-env> (table '())))
+
+(define (ghil-env-ref env sym)
+ (assq-ref (ghil-env-table env) sym))
+
+(define-macro (push! item loc)
+ `(set! ,loc (cons ,item ,loc)))
+(define-macro (apush! k v loc)
+ `(set! ,loc (acons ,k ,v ,loc)))
+(define-macro (apopq! k loc)
+ `(set! ,loc (assq-remove! ,loc ,k)))
+
+(define (ghil-env-add! env var)
+ (apush! (ghil-var-name var) var (ghil-env-table env))
+ (push! var (ghil-env-variables env)))
+
+(define (ghil-env-remove! env var)
+ (apopq! (ghil-var-name var) (ghil-env-table env)))
+
+(define (force-heap-allocation! var)
+ (set! (ghil-var-kind var) 'external))
+
+
+\f
+;;;
+;;; Public interface
+;;;
+
+;; The following four functions used to be one, in ghil-lookup. Now they
+;; are four, to reflect the different intents. A bit of duplication, but
+;; that's OK. The common current is to find out where a variable will be
+;; stored at runtime.
+;;
+;; These functions first search the lexical environments. If the
+;; variable is not in the innermost environment, make sure the variable
+;; is marked as being "external" so that it goes on the heap. If the
+;; variable is being modified (via a set!), also make sure it's on the
+;; heap, so that other continuations see the changes to the var.
+;;
+;; If the variable is not found lexically, it is a toplevel variable,
+;; which will be looked up at runtime with respect to the module that
+;; was current when the lambda was bound, at runtime. The variable will
+;; be resolved when it is first used.
+(define (ghil-var-is-bound? env sym)
+ (let loop ((e env))
+ (record-case e
+ ((<ghil-toplevel-env> table)
+ (let ((key (cons (module-name (current-module)) sym)))
+ (assoc-ref table key)))
+ ((<ghil-env> parent table variables)
+ (and (not (assq-ref table sym))
+ (loop parent))))))
+
+(define (ghil-var-for-ref! env sym)
+ (let loop ((e env))
+ (record-case e
+ ((<ghil-toplevel-env> table)
+ (let ((key (cons (module-name (current-module)) sym)))
+ (or (assoc-ref table key)
+ (let ((var (make-ghil-var (car key) (cdr key) 'toplevel)))
+ (apush! key var (ghil-toplevel-env-table e))
+ var))))
+ ((<ghil-env> parent table variables)
+ (cond
+ ((assq-ref table sym)
+ => (lambda (var)
+ (or (eq? e env)
+ (force-heap-allocation! var))
+ var))
+ (else
+ (loop parent)))))))
+
+(define (ghil-var-for-set! env sym)
+ (let loop ((e env))
+ (record-case e
+ ((<ghil-toplevel-env> table)
+ (let ((key (cons (module-name (current-module)) sym)))
+ (or (assoc-ref table key)
+ (let ((var (make-ghil-var (car key) (cdr key) 'toplevel)))
+ (apush! key var (ghil-toplevel-env-table e))
+ var))))
+ ((<ghil-env> parent table variables)
+ (cond
+ ((assq-ref table sym)
+ => (lambda (var)
+ (force-heap-allocation! var)
+ var))
+ (else
+ (loop parent)))))))
+
+(define (ghil-var-at-module! env modname sym interface?)
+ (let loop ((e env))
+ (record-case e
+ ((<ghil-toplevel-env> table)
+ (let ((key (list modname sym interface?)))
+ (or (assoc-ref table key)
+ (let ((var (make-ghil-var modname sym
+ (if interface? 'public 'private))))
+ (apush! key var (ghil-toplevel-env-table e))
+ var))))
+ ((<ghil-env> parent table variables)
+ (loop parent)))))
+
+(define (ghil-var-define! toplevel sym)
+ (let ((key (cons (module-name (current-module)) sym)))
+ (or (assoc-ref (ghil-toplevel-env-table toplevel) key)
+ (let ((var (make-ghil-var (car key) (cdr key) 'toplevel)))
+ (apush! key var (ghil-toplevel-env-table toplevel))
+ var))))
+
+(define (call-with-ghil-environment e syms func)
+ (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)))
+ (func e vars)))
+
+(define (call-with-ghil-bindings e syms func)
+ (let* ((vars (map (lambda (s)
+ (let ((v (make-ghil-var e s 'local)))
+ (ghil-env-add! e v) v))
+ syms))
+ (ret (func vars)))
+ (for-each (lambda (v) (ghil-env-remove! e v)) vars)
+ ret))
+
+(define (ghil-env-reify env)
+ (let loop ((e env) (out '()))
+ (record-case e
+ ((<ghil-toplevel-env> table)
+ (map (lambda (v)
+ (cons (ghil-var-name v)
+ (or (ghil-var-index v)
+ (error "reify called before indices finalized"))))
+ out))
+ ((<ghil-env> parent table variables)
+ (loop parent
+ (append out
+ (filter (lambda (v) (eq? (ghil-var-kind v) 'external))
+ variables)))))))
+
+(define (ghil-env-dereify name-index-alist)
+ (let* ((e (make-ghil-env (make-ghil-toplevel-env)))
+ (vars (map (lambda (pair)
+ (make-ghil-var e (car pair) 'external (cdr pair)))
+ name-index-alist)))
+ (set! (ghil-env-table e)
+ (map (lambda (v) (cons (ghil-var-name v) v)) vars))
+ (set! (ghil-env-variables e) vars)
+ e))
+
+\f
+;;;
+;;; Parser
+;;;
+
+(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))))
HCoop / bpt / guile.git / blobdiff