mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 11:50:28 +02:00
53befeb700
(Not quite finished, the following will be done tomorrow. module/srfi/*.scm module/rnrs/*.scm module/scripts/*.scm testsuite/*.scm guile-readline/* )
478 lines
15 KiB
Scheme
478 lines
15 KiB
Scheme
;;; Guile High Intermediate Language
|
||
|
||
;; Copyright (C) 2001 Free Software Foundation, Inc.
|
||
|
||
;;;; This library is free software; you can redistribute it and/or
|
||
;;;; modify it under the terms of the GNU Lesser General Public
|
||
;;;; License as published by the Free Software Foundation; either
|
||
;;;; version 3 of the License, or (at your option) any later version.
|
||
;;;;
|
||
;;;; This library 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
|
||
;;;; Lesser General Public License for more details.
|
||
;;;;
|
||
;;;; You should have received a copy of the GNU Lesser General Public
|
||
;;;; License along with this library; if not, write to the Free Software
|
||
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
|
||
|
||
;;; Code:
|
||
|
||
(define-module (language ghil)
|
||
#:use-module (system base syntax)
|
||
#:use-module (system base pmatch)
|
||
#:use-module (ice-9 regex)
|
||
#:export
|
||
(ghil-env ghil-loc
|
||
|
||
<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-splicing-env ghil-unquote-splicing-loc ghil-unquote-splicing-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))
|
||
|
||
|
||
;;;
|
||
;;; Parse tree
|
||
;;;
|
||
|
||
(define (print-ghil x port)
|
||
(format port "#<ghil ~s>" (unparse-ghil x)))
|
||
|
||
(define-type (<ghil> #:printer print-ghil
|
||
#:common-slots (env loc))
|
||
;; Objects
|
||
(<ghil-void>)
|
||
(<ghil-quote> obj)
|
||
(<ghil-quasiquote> exp)
|
||
(<ghil-unquote> exp)
|
||
(<ghil-unquote-splicing> exp)
|
||
;; Variables
|
||
(<ghil-ref> var)
|
||
(<ghil-set> var val)
|
||
(<ghil-define> var val)
|
||
;; Controls
|
||
(<ghil-if> test then else)
|
||
(<ghil-and> exps)
|
||
(<ghil-or> exps)
|
||
(<ghil-begin> exps)
|
||
(<ghil-bind> vars vals body)
|
||
(<ghil-mv-bind> producer vars rest body)
|
||
(<ghil-lambda> vars rest meta body)
|
||
(<ghil-call> proc args)
|
||
(<ghil-mv-call> producer consumer)
|
||
(<ghil-inline> inline args)
|
||
(<ghil-values> values)
|
||
(<ghil-values*> values)
|
||
(<ghil-reified-env>))
|
||
|
||
|
||
|
||
;;;
|
||
;;; Variables
|
||
;;;
|
||
|
||
(define-record <ghil-var> env name kind (index #f))
|
||
|
||
|
||
;;;
|
||
;;; Modules
|
||
;;;
|
||
|
||
|
||
;;;
|
||
;;; 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))
|
||
|
||
|
||
|
||
;;;
|
||
;;; 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))
|
||
|
||
|
||
;;;
|
||
;;; 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
|
||
((ref ,sym) (guard (symbol? sym))
|
||
(make-ghil-ref env #f (ghil-var-for-ref! env sym)))
|
||
|
||
(('quote ,exp) (make-ghil-quote env loc 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 (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 ,(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)
|
||
`(,'unquote-splicing ,(unparse-ghil exp)))
|
||
;; Variables
|
||
((<ghil-ref> env loc var)
|
||
`(ref ,(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)
|
||
,(unparse-ghil body)))
|
||
((<ghil-mv-bind> env loc producer vars rest body)
|
||
`(mv-bind ,(map ghil-var-name vars) ,rest
|
||
,(unparse-ghil producer) ,(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))))
|