Commit | Line | Data |
---|---|---|
17e90c5e KN |
1 | ;;; Guile VM core |
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 (system vm core)) | |
23 | ||
4bfb26f5 KN |
24 | ;;; |
25 | ;;; Core procedures | |
26 | ;;; | |
17e90c5e | 27 | |
4bfb26f5 | 28 | (dynamic-call "scm_init_vm" (dynamic-link "libguilevm.so")) |
17e90c5e KN |
29 | |
30 | (module-export! (current-module) | |
31 | (delq! '%module-public-interface | |
32 | (hash-fold (lambda (k v d) (cons k d)) '() | |
33 | (module-obarray (current-module))))) | |
4bfb26f5 KN |
34 | |
35 | ;;; | |
58995613 | 36 | ;;; Dumpcode interface |
4bfb26f5 KN |
37 | ;;; |
38 | ||
58995613 KN |
39 | (export make-dumpcode dumpcode? dumpcode-version |
40 | dumpcode-nlocs dumpcode-nexts dumpcode-bytecode | |
41 | load-dumpcode save-dumpcode) | |
4bfb26f5 | 42 | |
58995613 | 43 | (define *dumpcode-cookie* (string-append "\0GBC-" (vm-version))) |
4bfb26f5 | 44 | |
58995613 KN |
45 | (define (make-dumpcode nlocs nexts bytes) |
46 | (string-append *dumpcode-cookie* | |
4bfb26f5 KN |
47 | (integer->bytes nlocs) |
48 | (integer->bytes nexts) | |
49 | bytes)) | |
50 | ||
58995613 | 51 | (define (dumpcode? x) |
4bfb26f5 KN |
52 | (and (string? x) |
53 | (> (string-length x) 10) | |
54 | (string=? (substring x 1 4) "GBC"))) | |
55 | ||
58995613 | 56 | (define (dumpcode-version x) |
4bfb26f5 KN |
57 | (substring x 5 8)) |
58 | ||
58995613 | 59 | (define (dumpcode-nlocs x) |
4bfb26f5 KN |
60 | (bytes->integer x 8)) |
61 | ||
58995613 | 62 | (define (dumpcode-nexts x) |
4bfb26f5 KN |
63 | (bytes->integer x 9)) |
64 | ||
58995613 | 65 | (define (dumpcode-bytecode x) |
4bfb26f5 KN |
66 | (substring x 10)) |
67 | ||
58995613 KN |
68 | (define (load-dumpcode file) |
69 | (let ((bytes (make-uniform-vector (stat:size (stat file)) #\a))) | |
70 | (call-with-input-file file | |
71 | (lambda (p) (uniform-vector-read! bytes p))) | |
72 | bytes)) | |
73 | ||
74 | (define (save-dumpcode dump file) | |
75 | (call-with-output-file file | |
8710eba0 | 76 | (lambda (out) (uniform-vector-write dump out)))) |
58995613 | 77 | |
4bfb26f5 KN |
78 | (define (integer->bytes n) |
79 | (string (integer->char n))) | |
80 | ||
81 | (define (bytes->integer bytes start) | |
82 | (char->integer (string-ref bytes start))) | |
83 | ||
84 | ;;; | |
85 | ;;; Statistics interface | |
86 | ;;; | |
87 | ||
88 | (export vms:time vms:clock) | |
89 | ||
90 | (define (vms:time stat) (vector-ref stat 0)) | |
91 | (define (vms:clock stat) (vector-ref stat 1)) |