Commit | Line | Data |
---|---|---|
07e56b27 AW |
1 | ;;; Guile VM program functions |
2 | ||
20d47c39 | 3 | ;;; Copyright (C) 2001, 2009 Free Software Foundation, Inc. |
07e56b27 | 4 | ;;; |
e1203ea0 LC |
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. | |
07e56b27 | 9 | ;;; |
e1203ea0 | 10 | ;;; This library is distributed in the hope that it will be useful, |
07e56b27 | 11 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
e1203ea0 LC |
12 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
13 | ;;; Lesser General Public License for more details. | |
07e56b27 | 14 | ;;; |
e1203ea0 LC |
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 | |
07e56b27 AW |
18 | |
19 | ;;; Code: | |
20 | ||
21 | (define-module (system vm program) | |
53e28ed9 AW |
22 | #:export (make-program |
23 | ||
476e3572 | 24 | arity:nargs arity:nrest arity:nlocs |
f580ec0f | 25 | |
476e3572 | 26 | make-binding binding:name binding:boxed? binding:index |
f580ec0f AW |
27 | binding:start binding:end |
28 | ||
53e28ed9 | 29 | source:addr source:line source:column source:file |
028e3d06 | 30 | program-bindings program-sources program-source |
53e28ed9 | 31 | program-properties program-property program-documentation |
0704c813 | 32 | program-name program-arguments |
07e56b27 | 33 | |
20d47c39 | 34 | program-arity program-meta |
53e28ed9 | 35 | program-objcode program? program-objects |
57ab0671 | 36 | program-module program-base program-free-variables)) |
07e56b27 | 37 | |
60ae5ca2 | 38 | (load-extension "libguile" "scm_init_programs") |
07e56b27 AW |
39 | |
40 | (define arity:nargs car) | |
41 | (define arity:nrest cadr) | |
42 | (define arity:nlocs caddr) | |
07e56b27 | 43 | |
476e3572 AW |
44 | (define (make-binding name boxed? index start end) |
45 | (list name boxed? index start end)) | |
f580ec0f | 46 | (define (binding:name b) (list-ref b 0)) |
476e3572 | 47 | (define (binding:boxed? b) (list-ref b 1)) |
f580ec0f AW |
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)) | |
07e56b27 | 51 | |
d0168f3d AW |
52 | (define (source:addr source) |
53 | (car source)) | |
028e3d06 AW |
54 | (define (source:file source) |
55 | (cadr source)) | |
d0168f3d | 56 | (define (source:line source) |
028e3d06 | 57 | (caddr source)) |
d0168f3d | 58 | (define (source:column source) |
028e3d06 | 59 | (cdddr source)) |
d0168f3d | 60 | |
07e56b27 AW |
61 | (define (program-property prog prop) |
62 | (assq-ref (program-properties proc) prop)) | |
63 | ||
64 | (define (program-documentation prog) | |
17d1b4bf | 65 | (assq-ref (program-properties prog) 'documentation)) |
07e56b27 | 66 | |
0704c813 AW |
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 | ||
e6fea618 AW |
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)))))) | |
2651e3c4 | 83 | (if (not bindings) |
e6fea618 | 84 | (if rest? (cons (1- nargs) 1) (list nargs)) |
02b1883e | 85 | (let ((args (map binding:name (list-head bindings nargs)))) |
e6fea618 | 86 | (if rest? |
02b1883e AW |
87 | (apply cons* args) |
88 | args))))) | |
e6fea618 AW |
89 | |
90 | (define (write-program prog port) | |
91 | (format port "#<program ~a ~a>" | |
92 | (or (program-name prog) | |
028e3d06 AW |
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)))) | |
e6fea618 AW |
99 | (number->string (object-address prog) 16)) |
100 | (program-bindings-as-lambda-list prog))) |