module/language/objcode/spec.scm

   1 ;;; Guile Lowlevel Intermediate Language
   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 objcode spec)
  23   #:use-module (system base language)
  24   #:use-module (system vm objcode)
  25   #:use-module (system vm program)
  26   #:export (objcode make-objcode-env))
  27
  28 (define (make-objcode-env module externals)
  29   (cons module externals))
  30
  31 (define (objcode-env-module env)
  32   (if env (car env) (current-module)))
  33
  34 (define (objcode-env-externals env)
  35   (if env (cdr env) '()))
  36
  37 (define (objcode->value x e opts)
  38   (let ((thunk (make-program x #f (objcode-env-externals e))))
  39     (if e
  40         (save-module-excursion
  41          (lambda ()
  42            (set-current-module (objcode-env-module e))
  43            (values (thunk) #f)))
  44         (values (thunk) #f))))
  45
  46 ;; since locals are allocated on the stack and can have limited scope,
  47 ;; in many cases we use one local for more than one lexical variable. so
  48 ;; the returned locals set is a list, where element N of the list is
  49 ;; itself a list of bindings for local variable N.
  50 (define (collapse-locals locs)
  51   (let lp ((ret '()) (locs locs))
  52     (if (null? locs)
  53         (map cdr (sort! ret
  54                         (lambda (x y) (< (car x) (car y)))))
  55         (let ((b (car locs)))
  56           (cond
  57            ((assv-ref ret (binding:index b))
  58             => (lambda (bindings)
  59                  (append! bindings (list b))
  60                  (lp ret (cdr locs))))
  61            (else
  62             (lp (acons (binding:index b) (list b) ret)
  63                 (cdr locs))))))))
  64
  65 (define (decompile-value x env opts)
  66   (cond
  67    ((program? x)
  68     (let ((objs  (program-objects x))
  69           (meta  (program-meta x))
  70           (exts  (program-external x))
  71           (binds (program-bindings x))
  72           (srcs  (program-sources x))
  73           (nargs (arity:nargs (program-arity x))))
  74       (let ((blocs (and binds
  75                         (collapse-locals
  76                          (append (list-head binds nargs)
  77                                  (filter (lambda (x) (not (binding:extp x)))
  78                                          (list-tail binds nargs))))))
  79             (bexts (and binds
  80                         (filter binding:extp binds))))
  81         (values (program-objcode x)
  82                 `((objects . ,objs)
  83                   (meta    . ,(and meta (meta)))
  84                   (exts    . ,exts)
  85                   (blocs   . ,blocs)
  86                   (bexts   . ,bexts)
  87                   (sources . ,srcs))))))
  88    ((objcode? x)
  89     (values x #f))
  90    (else
  91     (error "can't decompile ~A: not a program or objcode" x))))
  92
  93 (define-language objcode
  94   #:title       "Guile Object Code"
  95   #:version     "0.3"
  96   #:reader      #f
  97   #:printer     write-objcode
  98   #:compilers   `((value . ,objcode->value))
  99   #:decompilers `((value . ,decompile-value))
 100   )