mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-11 06:20:23 +02:00
345 lines
10 KiB
Scheme
345 lines
10 KiB
Scheme
;;; 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 match)
|
||
:use-module (ice-9 regex)
|
||
:export
|
||
(
|
||
<ghil-void> <ghil-void>? <ghil-void>-1 <ghil-void>-2
|
||
<ghil-quote> <ghil-quote>? <ghil-quote>-1 <ghil-quote>-2 <ghil-quote>-3
|
||
<ghil-quasiquote> <ghil-quasiquote>?
|
||
<ghil-quasiquote>-1 <ghil-quasiquote>-2 <ghil-quasiquote>-3
|
||
<ghil-unquote> <ghil-unquote>?
|
||
<ghil-unquote>-1 <ghil-unquote>-2 <ghil-unquote>-3
|
||
<ghil-unquote-splicing> <ghil-unquote-splicing>?
|
||
<ghil-unquote-splicing>-1 <ghil-unquote-splicing>-2
|
||
<ghil-unquote-splicing>-3
|
||
|
||
<ghil-ref> <ghil-ref>? <ghil-ref>-1 <ghil-ref>-2 <ghil-ref>-3
|
||
<ghil-set> <ghil-set>? <ghil-set>-1 <ghil-set>-2 <ghil-set>-3 <ghil-set>-4
|
||
<ghil-define> <ghil-define>?
|
||
<ghil-define>-1 <ghil-define>-2 <ghil-define>-3 <ghil-define>-4
|
||
|
||
<ghil-if> <ghil-if>?
|
||
<ghil-if>-1 <ghil-if>-2 <ghil-if>-3 <ghil-if>-4 <ghil-if>-5
|
||
<ghil-and> <ghil-and>? <ghil-and>-1 <ghil-and>-2 <ghil-and>-3
|
||
<ghil-or> <ghil-or>? <ghil-or>-1 <ghil-or>-2 <ghil-or>-3
|
||
<ghil-begin> <ghil-begin>? <ghil-begin>-1 <ghil-begin>-2 <ghil-begin>-3
|
||
<ghil-bind> <ghil-bind>?
|
||
<ghil-bind>-1 <ghil-bind>-2 <ghil-bind>-3 <ghil-bind>-4 <ghil-bind>-5
|
||
<ghil-lambda> <ghil-lambda>? <ghil-lambda>-1 <ghil-lambda>-2
|
||
<ghil-lambda>-3 <ghil-lambda>-4 <ghil-lambda>-5
|
||
<ghil-inline> <ghil-inline>?
|
||
<ghil-inline>-1 <ghil-inline>-2 <ghil-inline>-3 <ghil-inline>-4
|
||
<ghil-call> <ghil-call>?
|
||
<ghil-call>-1 <ghil-call>-2 <ghil-call>-3 <ghil-call>-4
|
||
))
|
||
|
||
|
||
;;;
|
||
;;; 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)))
|
||
|
||
(define-public ghil-env %slot-1)
|
||
(define-public ghil-loc %slot-2)
|
||
|
||
|
||
;;;
|
||
;;; Procedures
|
||
;;;
|
||
|
||
(define *core-primitives*
|
||
'(@void @quote @define @set! @if @begin @let @letrec @lambda))
|
||
|
||
(define *macro-module* (resolve-module '(system il macros)))
|
||
|
||
(define-public (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)))
|
||
|
||
|
||
;;;
|
||
;;; Variables
|
||
;;;
|
||
|
||
(define-record (<ghil-var> env name kind (type #f) (value #f) (index #f)))
|
||
|
||
(define-public (make-ghil-var env name kind)
|
||
(<ghil-var> :env env :name name :kind kind))
|
||
|
||
|
||
;;;
|
||
;;; Modules
|
||
;;;
|
||
|
||
(define-record (<ghil-mod> module (table '()) (imports '())))
|
||
|
||
(define-public (make-ghil-mod module)
|
||
(<ghil-mod> :module module))
|
||
|
||
|
||
;;;
|
||
;;; Environments
|
||
;;;
|
||
|
||
(define-record (<ghil-env> mod parent (table '()) (variables '())))
|
||
|
||
(define-public (make-ghil-env e)
|
||
(match e
|
||
(($ <ghil-mod>) (<ghil-env> :mod e :parent e))
|
||
(($ <ghil-env> m) (<ghil-env> :mod m :parent e))))
|
||
|
||
(define (ghil-env-toplevel? e)
|
||
(eq? e.mod e.parent))
|
||
|
||
(define (ghil-env-ref env sym)
|
||
(assq-ref env.table sym))
|
||
|
||
(define-public (ghil-env-add! env var)
|
||
(set! env.table (acons var.name var env.table))
|
||
(set! env.variables (cons var env.variables)))
|
||
|
||
(define (ghil-env-remove! env var)
|
||
(set! env.table (assq-remove! env.table var.name)))
|
||
|
||
|
||
;;;
|
||
;;; Public interface
|
||
;;;
|
||
|
||
(define-public (ghil-lookup env sym)
|
||
(or (ghil-env-ref env sym)
|
||
(let loop ((e env.parent))
|
||
(cond ((<ghil-mod>? e)
|
||
(or (assq-ref e.table sym)
|
||
(let ((var (make-ghil-var #f sym 'module)))
|
||
(set! e.table (acons sym var e.table))
|
||
var)))
|
||
((ghil-env-ref e sym) =>
|
||
(lambda (var) (set! var.kind 'external) var))
|
||
(else (loop e.parent))))))
|
||
|
||
(define-public (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-public (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))
|
||
|
||
|
||
;;;
|
||
;;; 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))))
|