module/system/vm/program.scm

   1 ;;; Guile VM program functions
   2
   3 ;;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
   4 ;;;
   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
  18
  19 ;;; Code:
  20
  21 (define-module (system vm program)
  22   #:export (make-program
  23
  24             arity:nargs arity:nrest arity:nlocs
  25
  26             make-binding binding:name binding:boxed? binding:index
  27             binding:start binding:end
  28
  29             source:addr source:line source:column source:file
  30             program-bindings program-sources program-source
  31             program-properties program-property program-documentation
  32             program-name program-arguments
  33
  34             program-arity program-meta
  35             program-objcode program? program-objects
  36             program-module program-base program-free-variables))
  37
  38 (load-extension "libguile" "scm_init_programs")
  39
  40 (define arity:nargs car)
  41 (define arity:nrest cadr)
  42 (define arity:nlocs caddr)
  43
  44 (define (make-binding name boxed? index start end)
  45   (list name boxed? index start end))
  46 (define (binding:name b) (list-ref b 0))
  47 (define (binding:boxed? b) (list-ref b 1))
  48 (define (binding:index b) (list-ref b 2))
  49 (define (binding:start b) (list-ref b 3))
  50 (define (binding:end b) (list-ref b 4))
  51
  52 (define (source:addr source)
  53   (car source))
  54 (define (source:file source)
  55   (cadr source))
  56 (define (source:line source)
  57   (caddr source))
  58 (define (source:column source)
  59   (cdddr source))
  60
  61 (define (program-property prog prop)
  62   (assq-ref (program-properties proc) prop))
  63
  64 (define (program-documentation prog)
  65   (assq-ref (program-properties prog) 'documentation))
  66
  67 (define (program-arguments prog)
  68   (let ((bindings (program-bindings prog))
  69         (nargs (arity:nargs (program-arity prog)))
  70         (rest? (not (zero? (arity:nrest (program-arity prog))))))
  71     (if bindings
  72         (let ((args (map binding:name (list-head bindings nargs))))
  73           (if rest?
  74               `((required . ,(list-head args (1- (length args))))
  75                 (rest . ,(car (last-pair args))))
  76               `((required . ,args))))
  77         #f)))
  78
  79 (define (program-bindings-as-lambda-list prog)
  80   (let ((bindings (program-bindings prog))
  81         (nargs (arity:nargs (program-arity prog)))
  82         (rest? (not (zero? (arity:nrest (program-arity prog))))))
  83     (if (not bindings)
  84         (if rest? (cons (1- nargs) 1) (list nargs))
  85         (let ((args (map binding:name (list-head bindings nargs))))
  86           (if rest?
  87               (apply cons* args)
  88               args)))))
  89
  90 (define (write-program prog port)
  91   (format port "#<program ~a ~a>"
  92           (or (program-name prog)
  93               (and=> (program-source prog 0)
  94                      (lambda (s)
  95                        (format #f "~a at ~a:~a:~a"
  96                                (number->string (object-address prog) 16)
  97                                (or (source:file s) "<unknown port>")
  98                                (source:line s) (source:column s))))
  99               (number->string (object-address prog) 16))
 100           (program-bindings-as-lambda-list prog)))