module/system/vm/program.scm

   1 ;;; Guile VM program functions
   2
   3 ;;; Copyright (C) 2001 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 arity:nexts
  25
  26             make-binding binding:name binding:extp 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-external-set! program-meta
  35             program-objcode program? program-objects
  36             program-module program-base program-external))
  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 (define arity:nexts cadddr)
  44
  45 (define (make-binding name extp index start end)
  46   (list name extp index start end))
  47 (define (binding:name b) (list-ref b 0))
  48 (define (binding:extp b) (list-ref b 1))
  49 (define (binding:index b) (list-ref b 2))
  50 (define (binding:start b) (list-ref b 3))
  51 (define (binding:end b) (list-ref b 4))
  52
  53 (define (source:addr source)
  54   (car source))
  55 (define (source:file source)
  56   (cadr source))
  57 (define (source:line source)
  58   (caddr source))
  59 (define (source:column source)
  60   (cdddr source))
  61
  62 (define (program-property prog prop)
  63   (assq-ref (program-properties proc) prop))
  64
  65 (define (program-documentation prog)
  66   (assq-ref (program-properties prog) 'documentation))
  67
  68 (define (program-arguments prog)
  69   (let ((bindings (program-bindings prog))
  70         (nargs (arity:nargs (program-arity prog)))
  71         (rest? (not (zero? (arity:nrest (program-arity prog))))))
  72     (if bindings
  73         (let ((args (map binding:name (list-head bindings nargs))))
  74           (if rest?
  75               `((required . ,(list-head args (1- (length args))))
  76                 (rest . ,(car (last-pair args))))
  77               `((required . ,args))))
  78         #f)))
  79
  80 (define (program-bindings-as-lambda-list prog)
  81   (let ((bindings (program-bindings prog))
  82         (nargs (arity:nargs (program-arity prog)))
  83         (rest? (not (zero? (arity:nrest (program-arity prog))))))
  84     (if (not bindings)
  85         (if rest? (cons (1- nargs) 1) (list nargs))
  86         (let ((args (map binding:name (list-head bindings nargs))))
  87           (if rest?
  88               (apply cons* args)
  89               args)))))
  90
  91 (define (write-program prog port)
  92   (format port "#<program ~a ~a>"
  93           (or (program-name prog)
  94               (and=> (program-source prog 0)
  95                      (lambda (s)
  96                        (format #f "~a at ~a:~a:~a"
  97                                (number->string (object-address prog) 16)
  98                                (or (source:file s) "<unknown port>")
  99                                (source:line s) (source:column s))))
 100               (number->string (object-address prog) 16))
 101           (program-bindings-as-lambda-list prog)))