Commit | Line | Data |
---|---|---|
a98cef7e KN |
1 | ;;; utils.scm --- |
2 | ||
3 | ;; Copyright (C) 2000 Free Software Foundation, Inc. | |
4 | ||
5 | ;; This file is part of Guile VM. | |
6 | ||
7 | ;; Guile VM is free software; you can redistribute it and/or modify | |
8 | ;; it under the terms of the GNU General Public License as published by | |
9 | ;; the Free Software Foundation; either version 2, or (at your option) | |
10 | ;; any later version. | |
11 | ;; | |
12 | ;; Guile VM is distributed in the hope that it will be useful, | |
13 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
14 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
15 | ;; GNU General Public License for more details. | |
16 | ;; | |
17 | ;; You should have received a copy of the GNU General Public License | |
18 | ;; along with Guile VM; see the file COPYING. If not, write to | |
19 | ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
20 | ;; Boston, MA 02111-1307, USA. | |
21 | ||
22 | ;;; Code: | |
23 | ||
24 | (define-module (vm utils) | |
25 | :use-module (ice-9 and-let*) | |
26 | :use-module (ice-9 format)) | |
27 | ||
28 | (export and-let*) | |
29 | ||
30 | (define-public (assert predicate obj) | |
31 | (if (not (predicate obj)) | |
32 | (scm-error 'wrong-type-arg #f | |
33 | "Wrong type argument: ~S, ~S" | |
34 | (list (procedure-name predicate) obj) #f))) | |
35 | ||
36 | (define-public (assert-for-each predicate list) | |
37 | (for-each (lambda (x) (assert predicate x)) list)) | |
38 | ||
39 | (define-public (check-nargs args pred n) | |
40 | (if (not (pred (length args) n)) | |
41 | (error "Too many or few arguments"))) | |
42 | ||
43 | (define-public (last list) | |
44 | (car (last-pair list))) | |
45 | ||
46 | (define-public (rassq key alist) | |
47 | (let loop ((alist alist)) | |
48 | (cond ((null? alist) #f) | |
49 | ((eq? key (cdar alist)) (car alist)) | |
50 | (else (loop (cdr alist)))))) | |
51 | ||
52 | (define-public (rassq-ref alist key) | |
53 | (let ((obj (rassq key alist))) | |
54 | (if obj (car obj) #f))) | |
55 | ||
56 | (define-public (map-if pred func list) | |
57 | (let loop ((list list) (result '())) | |
58 | (if (null? list) | |
59 | (reverse! result) | |
60 | (if (pred (car list)) | |
61 | (loop (cdr list) (cons (func (car list)) result)) | |
62 | (loop (cdr list) result))))) | |
63 | ||
64 | (define-public (map-tree func tree) | |
65 | (cond ((null? tree) '()) | |
66 | ((pair? tree) | |
67 | (cons (map-tree func (car tree)) (map-tree func (cdr tree)))) | |
68 | (else (func tree)))) | |
69 | ||
70 | (define-public (filter pred list) | |
71 | (let loop ((list list) (result '())) | |
72 | (if (null? list) | |
73 | (reverse! result) | |
74 | (if (pred (car list)) | |
75 | (loop (cdr list) (cons (car list) result)) | |
76 | (loop (cdr list) result))))) | |
77 | ||
78 | (define-public (uniq! list) | |
79 | (do ((rest list (begin (set-cdr! rest (delq! (car rest) (cdr rest))) | |
80 | (cdr rest)))) | |
81 | ((null? rest) list))) | |
82 | ||
83 | (define-public (finalize obj) | |
84 | (if (promise? obj) (force obj) obj)) | |
85 | ||
86 | (export time) | |
87 | (define-macro (time form) | |
88 | `(let* ((gc-start (gc-run-time)) | |
89 | (tms-start (times)) | |
90 | (result ,form) | |
91 | (tms-end (times)) | |
92 | (gc-end (gc-run-time)) | |
93 | (get (lambda (proc start end) | |
94 | (/ (- (proc end) (proc start)) | |
95 | internal-time-units-per-second)))) | |
96 | (display "clock utime stime cutime cstime gc\n") | |
97 | (format #t "~5a ~5a ~5a ~6a ~6a ~a~%" | |
98 | (get tms:clock tms-start tms-end) | |
99 | (get tms:utime tms-start tms-end) | |
100 | (get tms:stime tms-start tms-end) | |
101 | (get tms:cutime tms-start tms-end) | |
102 | (get tms:cstime tms-start tms-end) | |
103 | (get id gc-start gc-end)) | |
104 | result)) | |
105 | ||
106 | ;;; utils.scm ends here |