Commit | Line | Data |
---|---|---|
b81d329e AW |
1 | ;;; Guile Scheme specification |
2 | ||
3 | ;; Copyright (C) 2001 Free Software Foundation, Inc. | |
4 | ||
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) | |
8 | ;; any later version. | |
9 | ;; | |
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. | |
14 | ;; | |
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. | |
19 | ||
20 | ;;; Code: | |
21 | ||
22 | (define-module (language scheme compile-tree-il) | |
23 | #:use-module (language tree-il) | |
24 | #:export (compile-tree-il)) | |
25 | ||
26 | ;;; environment := #f | |
27 | ;;; | MODULE | |
28 | ;;; | COMPILE-ENV | |
29 | ;;; compile-env := (MODULE LEXICALS . EXTERNALS) | |
30 | (define (cenv-module env) | |
31 | (cond ((not env) #f) | |
32 | ((module? env) env) | |
33 | ((and (pair? env) (module? (car env))) (car env)) | |
34 | (else (error "bad environment" env)))) | |
35 | ||
36 | (define (cenv-lexicals env) | |
37 | (cond ((not env) '()) | |
38 | ((module? env) '()) | |
39 | ((pair? env) (cadr env)) | |
40 | (else (error "bad environment" env)))) | |
41 | ||
42 | (define (cenv-externals env) | |
43 | (cond ((not env) '()) | |
44 | ((module? env) '()) | |
45 | ((pair? env) (cddr env)) | |
46 | (else (error "bad environment" env)))) | |
47 | ||
48 | (define (make-cenv module lexicals externals) | |
49 | (cons module (cons lexicals externals))) | |
50 | ||
51 | (define (location x) | |
52 | (and (pair? x) | |
53 | (let ((props (source-properties x))) | |
54 | (and (not (null? props)) | |
55 | props)))) | |
56 | ||
57 | (define (compile-tree-il x e opts) | |
58 | (save-module-excursion | |
59 | (lambda () | |
60 | (and=> (cenv-module e) set-current-module) | |
a1a482e0 AW |
61 | (let* ((x (sc-expand x 'c '(compile load eval))) |
62 | (cenv (make-cenv (current-module) | |
63 | (cenv-lexicals e) (cenv-externals e)))) | |
b81d329e | 64 | (values x cenv cenv))))) |