1 ;;; Guile Scheme specification
3 ;; Copyright (C) 2001 Free Software Foundation, Inc.
5 ;; This program is free software; you can redistribute it and/or modify
6 ;; it under the terms of the GNU General Public License as published by
7 ;; the Free Software Foundation; either version 2, or (at your option)
10 ;; This program is distributed in the hope that it will be useful,
11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 ;; GNU General Public License for more details.
15 ;; You should have received a copy of the GNU General Public License
16 ;; along with this program; see the file COPYING. If not, write to
17 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
18 ;; Boston, MA 02111-1307, USA.
22 (define-module (language scheme compile-tree-il)
23 #:use-module (language tree-il)
24 #:export (compile-tree-il))
29 ;;; compile-env := (MODULE LEXICALS . EXTERNALS)
30 (define (cenv-module env)
33 ((and (pair? env) (module? (car env))) (car env))
34 (else (error "bad environment" env))))
36 (define (cenv-lexicals env)
39 ((pair? env) (cadr env))
40 (else (error "bad environment" env))))
42 (define (cenv-externals env)
45 ((pair? env) (cddr env))
46 (else (error "bad environment" env))))
48 (define (make-cenv module lexicals externals)
49 (cons module (cons lexicals externals)))
53 (let ((props (source-properties x)))
54 (and (not (null? props))
57 (define (compile-tree-il x e opts)
58 (save-module-excursion
60 (and=> (cenv-module e) set-current-module)
61 (let* ((x (sc-expand x 'c '(compile load eval)))
62 (cenv (make-cenv (current-module)
63 (cenv-lexicals e) (cenv-externals e))))
64 (values x cenv cenv)))))