vm/utils.scm

   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