1 ;;; Guile Lowlevel Intermediate Language
3 ;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
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.
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.
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
21 (define-module (language objcode spec)
22 #:use-module (system base language)
23 #:use-module (system vm objcode)
24 #:use-module (system vm program)
25 #:export (objcode make-objcode-env))
27 (define (make-objcode-env module externals)
28 (cons module externals))
30 (define (objcode-env-module env)
31 (if env (car env) (current-module)))
33 (define (objcode-env-externals env)
34 (and env (vector? (cdr env)) (cdr env)))
36 (define (objcode->value x e opts)
37 (let ((thunk (make-program x #f (objcode-env-externals e))))
39 (save-module-excursion
41 (set-current-module (objcode-env-module e))
42 (values (thunk) #f e)))
43 (values (thunk) #f e))))
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))
53 (lambda (x y) (< (car x) (car y)))))
56 ((assv-ref ret (binding:index b))
58 (append! bindings (list b))
61 (lp (acons (binding:index b) (list b) ret)
64 (define (decompile-value x env opts)
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
75 (append (list-head binds nargs)
76 (filter (lambda (x) (not (binding:extp x)))
77 (list-tail binds nargs))))))
79 (filter binding:extp binds))))
80 (values (program-objcode x)
82 (meta . ,(and meta (meta)))
86 (sources . ,srcs))))))
90 (error "can't decompile ~A: not a program or objcode" x))))
92 (define-language objcode
93 #:title "Guile Object Code"
96 #:printer write-objcode
97 #:compilers `((value . ,objcode->value))
98 #:decompilers `((value . ,decompile-value))