Commit | Line | Data |
---|---|---|
b0b180d5 AW |
1 | ;;; Guile Lowlevel Intermediate Language |
2 | ||
20d47c39 | 3 | ;; Copyright (C) 2001, 2009 Free Software Foundation, Inc. |
b0b180d5 | 4 | |
53befeb7 NJ |
5 | ;;;; This library is free software; you can redistribute it and/or |
6 | ;;;; modify it under the terms of the GNU Lesser General Public | |
7 | ;;;; License as published by the Free Software Foundation; either | |
8 | ;;;; version 3 of the License, or (at your option) any later version. | |
9 | ;;;; | |
10 | ;;;; This library 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 GNU | |
13 | ;;;; Lesser General Public License for more details. | |
14 | ;;;; | |
15 | ;;;; You should have received a copy of the GNU Lesser General Public | |
16 | ;;;; License along with this library; if not, write to the Free Software | |
17 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA | |
b0b180d5 AW |
18 | |
19 | ;;; Code: | |
20 | ||
21 | (define-module (language objcode spec) | |
22 | #:use-module (system base language) | |
b0b180d5 | 23 | #:use-module (system vm objcode) |
53e28ed9 | 24 | #:use-module (system vm program) |
b0b180d5 AW |
25 | #:export (objcode make-objcode-env)) |
26 | ||
27 | (define (make-objcode-env module externals) | |
28 | (cons module externals)) | |
29 | ||
30 | (define (objcode-env-module env) | |
31 | (if env (car env) (current-module))) | |
32 | ||
33 | (define (objcode-env-externals env) | |
20d47c39 | 34 | (and env (vector? (cdr env)) (cdr env))) |
b0b180d5 AW |
35 | |
36 | (define (objcode->value x e opts) | |
53e28ed9 | 37 | (let ((thunk (make-program x #f (objcode-env-externals e)))) |
b0b180d5 AW |
38 | (if e |
39 | (save-module-excursion | |
40 | (lambda () | |
41 | (set-current-module (objcode-env-module e)) | |
b41b92c9 AW |
42 | (values (thunk) #f e))) |
43 | (values (thunk) #f e)))) | |
b0b180d5 | 44 | |
594d9d4c AW |
45 | ;; since locals are allocated on the stack and can have limited scope, |
46 | ;; in many cases we use one local for more than one lexical variable. so | |
47 | ;; the returned locals set is a list, where element N of the list is | |
48 | ;; itself a list of bindings for local variable N. | |
49 | (define (collapse-locals locs) | |
50 | (let lp ((ret '()) (locs locs)) | |
51 | (if (null? locs) | |
52 | (map cdr (sort! ret | |
53 | (lambda (x y) (< (car x) (car y))))) | |
54 | (let ((b (car locs))) | |
55 | (cond | |
56 | ((assv-ref ret (binding:index b)) | |
57 | => (lambda (bindings) | |
58 | (append! bindings (list b)) | |
59 | (lp ret (cdr locs)))) | |
60 | (else | |
61 | (lp (acons (binding:index b) (list b) ret) | |
62 | (cdr locs)))))))) | |
63 | ||
7b107cce AW |
64 | (define (decompile-value x env opts) |
65 | (cond | |
66 | ((program? x) | |
d7236899 AW |
67 | (let ((objs (program-objects x)) |
68 | (meta (program-meta x)) | |
69 | (exts (program-external x)) | |
70 | (binds (program-bindings x)) | |
71 | (srcs (program-sources x)) | |
72 | (nargs (arity:nargs (program-arity x)))) | |
73 | (let ((blocs (and binds | |
594d9d4c AW |
74 | (collapse-locals |
75 | (append (list-head binds nargs) | |
76 | (filter (lambda (x) (not (binding:extp x))) | |
77 | (list-tail binds nargs)))))) | |
d7236899 AW |
78 | (bexts (and binds |
79 | (filter binding:extp binds)))) | |
80 | (values (program-objcode x) | |
81 | `((objects . ,objs) | |
82 | (meta . ,(and meta (meta))) | |
83 | (exts . ,exts) | |
84 | (blocs . ,blocs) | |
85 | (bexts . ,bexts) | |
86 | (sources . ,srcs)))))) | |
7b107cce AW |
87 | ((objcode? x) |
88 | (values x #f)) | |
89 | (else | |
90 | (error "can't decompile ~A: not a program or objcode" x)))) | |
91 | ||
b0b180d5 AW |
92 | (define-language objcode |
93 | #:title "Guile Object Code" | |
94 | #:version "0.3" | |
95 | #:reader #f | |
53e28ed9 | 96 | #:printer write-objcode |
5d6fb8bb | 97 | #:compilers `((value . ,objcode->value)) |
7b107cce | 98 | #:decompilers `((value . ,decompile-value)) |
b0b180d5 | 99 | ) |