cgen/utils.scm

   1 ; Generic Utilities.
   2 ; Copyright (C) 2000-2005, 2006, 2007 Red Hat, Inc.
   3 ; This file is part of CGEN.
   4 ; See file COPYING.CGEN for details.
   5
   6 ; These utilities are neither object nor cgen centric.
   7 ; They're generic, non application-specific utilities.
   8 ; There are a few exceptions, keep them to a minimum.
   9 ;
  10 ; Conventions:
  11 ; - the prefix "gen-" comes from cgen's convention that procs that return C
  12 ;   code, and only those procs, are prefixed with "gen-"
  13
  14 (define nil '())
  15
  16 ; Hobbit support code; for when not using hobbit.
  17 ; FIXME: eliminate this stuff ASAP.
  18
  19 (defmacro /fastcall-make (proc) proc)
  20
  21 (defmacro fastcall4 (proc arg1 arg2 arg3 arg4)
  22   (list proc arg1 arg2 arg3 arg4)
  23 )
  24
  25 (defmacro fastcall5 (proc arg1 arg2 arg3 arg4 arg5)
  26   (list proc arg1 arg2 arg3 arg4 arg5)
  27 )
  28
  29 (defmacro fastcall6 (proc arg1 arg2 arg3 arg4 arg5 arg6)
  30   (list proc arg1 arg2 arg3 arg4 arg5 arg6)
  31 )
  32
  33 (defmacro fastcall7 (proc arg1 arg2 arg3 arg4 arg5 arg6 arg7)
  34   (list proc arg1 arg2 arg3 arg4 arg5 arg6 arg7)
  35 )
  36
  37 ; Value doesn't matter too much here, just ensure it's portable.
  38 (define *UNSPECIFIED* (if #f 1))
  39
  40 (define assert-fail-msg "assertion failure:")
  41
  42 (defmacro assert (expr)
  43   `(if (not ,expr)
  44        (error assert-fail-msg ',expr))
  45 )
  46
  47 (define verbose-level 0)
  48
  49 (define (verbose-inc!)
  50   (set! verbose-level (+ verbose-level 1))
  51 )
  52
  53 (define (verbose? level) (>= verbose-level level))
  54
  55 ; Print to stderr, takes an arbitrary number of strings, possibly nested.
  56
  57 (define message
  58   (lambda args
  59     (for-each (lambda (str)
  60                 (if (pair? str)
  61                     (begin
  62                       (message "(")
  63                       (for-each (lambda (s) (message s " ")) str)
  64                       (message ")"))
  65                     (display str (current-error-port))))
  66               args))
  67 )
  68
  69 ; Print a message if the verbosity level calls for it.
  70 ; This is a macro as a bit of cpu may be spent computing args,
  71 ; and we only want to spend it if the result will be printed.
  72
  73 (defmacro logit (level . args)
  74   `(if (>= verbose-level ,level) (message ,@args))
  75 )
  76
  77 ; Return a string of N spaces.
  78
  79 (define (spaces n) (make-string n #\space))
  80
  81 ; Write N spaces to PORT, or the current output port if elided.
  82
  83 (define (write-spaces n . port)
  84   (let ((port (if (null? port) (current-output-port) (car port))))
  85     (write (spaces n) port))
  86 )
  87
  88 ; Concatenate all the arguments and make a string.  Symbols are
  89 ; converted to strings.
  90 (define (string/symbol-append . sequences)
  91   (define (sequence->string o) (if (symbol? o) (symbol->string o) o))
  92   (apply string-append (map sequence->string sequences)))
  93
  94 ; Often used idiom.
  95
  96 (define (string-map fn . args) (apply string-append (apply map (cons fn args))))
  97
  98 ; Collect a flat list of returned sublists from the lambda fn applied over args.
  99
 100 (define (collect fn . args) (apply append (apply map (cons fn args))))
 101
 102 ; Map over value entries in an alist.
 103 ; 'twould be nice if this were a primitive.
 104
 105 (define (amap fn args)
 106   (map fn (map cdr args))
 107 )
 108
 109 ; Like map but accept a proper or improper list.
 110 ; An improper list is (a b c . d).
 111 ; FN must be a proc of one argument.
 112
 113 (define (map1-improper fn l)
 114   (let ((result nil))
 115     (let loop ((last #f) (l l))
 116       (cond ((null? l)
 117              result)
 118             ((pair? l)
 119              (if last
 120                  (begin
 121                    (set-cdr! last (cons (fn (car l)) nil))
 122                    (loop (cdr last) (cdr l)))
 123                  (begin
 124                    (set! result (cons (fn (car l)) nil))
 125                    (loop result (cdr l)))))
 126             (else
 127              (if last
 128                  (begin
 129                    (set-cdr! last (fn l))
 130                    result)
 131                  (fn l))))))
 132 )
 133
 134 ; Turn string or symbol STR into a proper C symbol.
 135 ; The result is a string.
 136 ; We assume STR has no leading digits.
 137 ; All invalid characters are turned into '_'.
 138 ; FIXME: Turn trailing "?" into "_p".
 139
 140 (define (gen-c-symbol str)
 141   (if (not (or (string? str) (symbol? str)))
 142       (error "gen-c-symbol: not symbol or string:" str))
 143   (map-over-string (lambda (c) (if (id-char? c) c #\_))
 144                    (->string str))
 145 )
 146
 147 ; Turn string or symbol STR into a proper file name, which is
 148 ; defined to be the same as gen-c-symbol except use -'s instead of _'s.
 149 ; The result is a string.
 150
 151 (define (gen-file-name str)
 152   (if (not (or (string? str) (symbol? str)))
 153       (error "gen-file-name: not symbol or string:" str))
 154   (map-over-string (lambda (c) (if (id-char? c) c #\-))
 155                    (->string str))
 156 )
 157
 158 ; Turn STR into lowercase.
 159
 160 (define (string-downcase str)
 161   (map-over-string (lambda (c) (char-downcase c)) str)
 162 )
 163
 164 ; Turn STR into uppercase.
 165
 166 (define (string-upcase str)
 167   (map-over-string (lambda (c) (char-upcase c)) str)
 168 )
 169
 170 ; Turn SYM into lowercase.
 171
 172 (define (symbol-downcase sym)
 173   (string->symbol (string-downcase (symbol->string sym)))
 174 )
 175
 176 ; Turn SYM into uppercase.
 177
 178 (define (symbol-upcase sym)
 179   (string->symbol (string-upcase (symbol->string sym)))
 180 )
 181
 182 ; Symbol sorter.
 183
 184 (define (symbol<? a b)
 185   (string<? (symbol->string a) (symbol->string b))
 186 )
 187
 188 ; Drop N chars from string S.
 189 ; If N is negative, drop chars from the end.
 190 ; It is ok to drop more characters than are in the string, the result is "".
 191
 192 (define (string-drop n s)
 193   (cond ((>= n (string-length s)) "")
 194         ((< n 0) (substring s 0 (+ (string-length s) n)))
 195         (else (substring s n (string-length s))))
 196 )
 197
 198 ; Drop the leading char from string S (assumed to have at least 1 char).
 199
 200 (define (string-drop1 s)
 201   (string-drop 1 s)
 202 )
 203
 204 ; Return the leading N chars from string STR.
 205 ; This has APL semantics:
 206 ; N > length: FILLER chars are appended
 207 ; N < 0: take from the end of the string and prepend FILLER if necessary
 208
 209 (define (string-take-with-filler n str filler)
 210   (let ((len (string-length str)))
 211     (if (< n 0)
 212         (let ((n (- n)))
 213           (string-append (if (> n len)
 214                              (make-string (- n len) filler)
 215                              "")
 216                          (substring str (max 0 (- len n)) len)))
 217         (string-append (substring str 0 (min len n))
 218                        (if (> n len)
 219                            (make-string (- n len) filler)
 220                            ""))))
 221 )
 222
 223 (define (string-take n str)
 224   (string-take-with-filler n str #\space)
 225 )
 226
 227 ; Return the leading char from string S (assumed to have at least 1 char).
 228
 229 (define (string-take1 s)
 230   (substring s 0 1)
 231 )
 232
 233 ; Return the index of char C in string S or #f if not found.
 234
 235 (define (string-index s c)
 236   (let loop ((i 0))
 237     (cond ((= i (string-length s)) #f)
 238           ((char=? c (string-ref s i)) i)
 239           (else (loop (1+ i)))))
 240 )
 241
 242 ; Cut string S into a list of strings using delimiter DELIM (a character).
 243
 244 (define (string-cut s delim)
 245   (let loop ((start 0)
 246              (end 0)
 247              (length (string-length s))
 248              (result nil))
 249     (cond ((= end length)
 250            (if (> end start)
 251                (reverse! (cons (substring s start end) result))
 252                (reverse! result)))
 253           ((char=? (string-ref s end) delim)
 254            (loop (1+ end) (1+ end) length (cons (substring s start end) result)))
 255           (else (loop start (1+ end) length result))))
 256 )
 257
 258 ; Convert a list of elements to a string, inserting DELIM (a string)
 259 ; between elements.
 260 ; L can also be a string or a number.
 261
 262 (define (stringize l delim)
 263   (cond ((string? l) l)
 264         ((number? l) (number->string l))
 265         ((symbol? l) (symbol->string l))
 266         ((list? l)
 267          (string-drop
 268           (string-length delim)
 269           (string-map (lambda (elm)
 270                         (string-append delim
 271                                        (stringize elm delim)))
 272                       l)))
 273         (else (error "stringize: can't handle:" l)))
 274 )
 275
 276 ; Same as string-append, but accepts symbols too.
 277 ; PERF: This implementation may be unacceptably slow.  Revisit.
 278
 279 (define stringsym-append
 280   (lambda args
 281     (apply string-append
 282            (map (lambda (s)
 283                   (if (symbol? s)
 284                       (symbol->string s)
 285                       s))
 286                 args)))
 287 )
 288
 289 ; Same as symbol-append, but accepts strings too.
 290
 291 (define symbolstr-append
 292   (lambda args
 293     (string->symbol (apply stringsym-append args)))
 294 )
 295
 296 ; Given a symbol or a string, return the string form.
 297
 298 (define (->string s)
 299   (if (symbol? s)
 300       (symbol->string s)
 301       s)
 302 )
 303
 304 ; Given a symbol or a string, return the symbol form.
 305
 306 (define (->symbol s)
 307   (if (string? s)
 308       (string->symbol s)
 309       s)
 310 )
 311 \f
 312 ; Output routines.
 313
 314 ;; Given some state that has a setter function (SETTER NEW-VALUE) and
 315 ;; a getter function (GETTER), call THUNK with the state set to VALUE,
 316 ;; and restore the original value when THUNK returns.  Ensure that the
 317 ;; original value is restored whether THUNK returns normally, throws
 318 ;; an exception, or invokes a continuation that leaves the call's
 319 ;; dynamic scope.
 320 (define (setter-getter-fluid-let setter getter value thunk)
 321   (let ((swap (lambda ()
 322                 (let ((temp (getter)))
 323                   (setter value)
 324                   (set! value temp)))))
 325     (dynamic-wind swap thunk swap)))
 326
 327
 328 ;; Call THUNK with the current input and output ports set to PORT, and
 329 ;; then restore the current ports to their original values.
 330 ;;
 331 ;; This ensures the current ports get restored whether THUNK exits
 332 ;; normally, throws an exception, or leaves the call's dynamic scope
 333 ;; by applying a continuation.
 334 (define (with-input-and-output-to port thunk)
 335   (setter-getter-fluid-let
 336    set-current-input-port current-input-port port
 337    (lambda ()
 338      (setter-getter-fluid-let
 339       set-current-output-port current-output-port port
 340       thunk))))
 341
 342
 343 ; Extension to the current-output-port.
 344 ; Only valid inside string-write.
 345
 346 (define -current-print-state #f)
 347
 348 ; Create a print-state object.
 349 ; This is written in portable Scheme so we don't use COS objects, etc.
 350
 351 (define (make-print-state)
 352   (vector 'print-state 0)
 353 )
 354
 355 ; print-state accessors.
 356
 357 (define (pstate-indent pstate) (vector-ref pstate 1))
 358 (define (pstate-set-indent! pstate indent) (vector-set! pstate 1 indent))
 359
 360 ; Special print commands (embedded in args).
 361
 362 (define (pstate-cmd? x) (and (vector? x) (eq? (vector-ref x 0) 'pstate)))
 363
 364 ;(define /endl (vector 'pstate '/endl)) ; ??? needed?
 365 (define /indent (vector 'pstate '/indent))
 366 (define (/indent-set n) (vector 'pstate '/indent-set n))
 367 (define (/indent-add n) (vector 'pstate '/indent-add n))
 368
 369 ; Process a pstate command.
 370
 371 (define (pstate-cmd-do pstate cmd)
 372   (assert (pstate-cmd? cmd))
 373   (case (vector-ref cmd 1)
 374     ((/endl)
 375      "\n")
 376     ((/indent)
 377      (let ((indent (pstate-indent pstate)))
 378        (string-append (make-string (quotient indent 8) #\tab)
 379                       (make-string (remainder indent 8) #\space))))
 380     ((/indent-set)
 381      (pstate-set-indent! pstate (vector-ref cmd 2))
 382      "")
 383     ((/indent-add)
 384      (pstate-set-indent! pstate (+ (pstate-indent pstate)
 385                                    (vector-ref cmd 2)))
 386      "")
 387     (else
 388      (error "unknown pstate command" (vector-ref cmd 1))))
 389 )
 390
 391 ; Write STRINGS to current-output-port.
 392 ; STRINGS is a list of things to write.  Supported types are strings, symbols,
 393 ; lists, procedures.  Lists are printed by applying string-write recursively.
 394 ; Procedures are thunks that return the string to write.
 395 ;
 396 ; The result is the empty string.  This is for debugging where this
 397 ; procedure is modified to return its args, rather than write them out.
 398
 399 (define string-write
 400   (lambda strings
 401     (let ((pstate (make-print-state)))
 402       (set! -current-print-state pstate)
 403       (for-each (lambda (elm) (-string-write pstate elm))
 404                 strings)
 405       (set! -current-print-state #f)
 406       ""))
 407 )
 408
 409 ; Subroutine of string-write and string-write-map.
 410
 411 (define (-string-write pstate expr)
 412   (cond ((string? expr) (display expr)) ; not write, we want raw text
 413         ((symbol? expr) (display expr))
 414         ((procedure? expr) (-string-write pstate (expr)))
 415         ((pstate-cmd? expr) (display (pstate-cmd-do pstate expr)))
 416         ((list? expr) (for-each (lambda (x) (-string-write pstate x)) expr))
 417         (else (error "string-write: bad arg:" expr)))
 418   *UNSPECIFIED*
 419 )
 420
 421 ; Combination of string-map and string-write.
 422
 423 (define (string-write-map proc arglist)
 424   (let ((pstate -current-print-state))
 425     (for-each (lambda (arg) (-string-write pstate (proc arg)))
 426               arglist))
 427   ""
 428 )
 429
 430 ; Build up an argument for string-write.
 431
 432 (define string-list list)
 433 (define string-list-map map)
 434
 435 ; Subroutine of string-list->string.  Does same thing -string-write does.
 436
 437 (define (-string-list-flatten pstate strlist)
 438   (cond ((string? strlist) strlist)
 439         ((symbol? strlist) strlist)
 440         ((procedure? strlist) (-string-list-flatten pstate (strlist)))
 441         ((pstate-cmd? strlist) (pstate-cmd-do pstate strlist))
 442         ((list? strlist) (apply string-append
 443                                 (map (lambda (str)
 444                                        (-string-list-flatten pstate str))
 445                                      strlist)))
 446         (else (error "string-list->string: bad arg:" strlist)))
 447 )
 448
 449 ; Flatten out a string list.
 450
 451 (define (string-list->string strlist)
 452   (-string-list-flatten (make-print-state) strlist)
 453 )
 454 \f
 455 ; Prefix CHARS, a string of characters, with backslash in STR.
 456 ; STR is either a string or list of strings (to any depth).
 457 ; ??? Quick-n-dirty implementation.
 458
 459 (define (backslash chars str)
 460   (if (string? str)
 461       ; quick check for any work to do
 462       (if (any-true? (map (lambda (c)
 463                             (string-index str c))
 464                           (string->list chars)))
 465           (let loop ((result "") (str str))
 466             (if (= (string-length str) 0)
 467                 result
 468                 (loop (string-append result
 469                                      (if (string-index chars (string-ref str 0))
 470                                          "\\"
 471                                          "")
 472                                      (substring str 0 1))
 473                       (substring str 1 (string-length str)))))
 474           str)
 475       ; must be a list
 476       (if (null? str)
 477           nil
 478           (cons (backslash chars (car str))
 479                 (backslash chars (cdr str)))))
 480 )
 481
 482 ; Return a boolean indicating if S is bound to a value.
 483 ;(define old-symbol-bound? symbol-bound?)
 484 ;(define (symbol-bound? s) (old-symbol-bound? #f s))
 485
 486 ; Return a boolean indicating if S is a symbol and is bound to a value.
 487
 488 (define (bound-symbol? s)
 489   (and (symbol? s)
 490        (or (symbol-bound? #f s)
 491            ;(module-bound? cgen-module s)
 492            ))
 493 )
 494
 495 ; Return X.
 496
 497 (define (identity x) x)
 498
 499 ; Test whether X is a `form' (non-empty list).
 500 ; ??? Is `form' the right word to use here?
 501 ; One can argue we should also test for a valid car.  If so, it's the
 502 ; name that's wrong not the code (because the code is what I want).
 503
 504 (define (form? x) (and (not (null? x)) (list? x)))
 505
 506 ; Return the number of arguments to ARG-SPEC, a valid argument list
 507 ; of `lambda'.
 508 ; The result is a pair: number of fixed arguments, varargs indicator (#f/#t).
 509
 510 (define (num-args arg-spec)
 511   (if (symbol? arg-spec)
 512       '(0 . #t)
 513       (let loop ((count 0) (arg-spec arg-spec))
 514         (cond ((null? arg-spec) (cons count #f))
 515               ((null? (cdr arg-spec)) (cons (+ count 1) #f))
 516               ((pair? (cdr arg-spec)) (loop (+ count 1) (cdr arg-spec)))
 517               (else (cons (+ count 1) #t)))))
 518 )
 519
 520 ; Return a boolean indicating if N args is ok to pass to a proc with
 521 ; an argument specification of ARG-SPEC (a valid argument list of `lambda').
 522
 523 (define (num-args-ok? n arg-spec)
 524   (let ((processed-spec (num-args arg-spec)))
 525     (and
 526      ; Ensure enough fixed arguments.
 527      (>= n (car processed-spec))
 528      ; If more args than fixed args, ensure varargs.
 529      (or (= n (car processed-spec))
 530          (cdr processed-spec))))
 531 )
 532
 533 ; Take N elements from list L.
 534 ; If N is negative, take elements from the end.
 535 ; If N is larger than the length, the extra elements are NIL.
 536 ; FIXME: incomplete
 537 ; FIXME: list-tail has args reversed (we should conform)
 538
 539 (define (list-take n l)
 540   (let ((len (length l)))
 541     (if (< n 0)
 542         (list-tail l (+ len n))
 543         (let loop ((result nil) (l l) (i 0))
 544           (if (= i n)
 545               (reverse! result)
 546               (loop (cons (car l) result) (cdr l) (+ i 1))))))
 547 )
 548
 549 ; Drop N elements from list L.
 550 ; FIXME: list-tail has args reversed (we should conform)
 551
 552 (define (list-drop n l)
 553   (let loop ((n n) (l l))
 554     (if (> n 0)
 555         (loop (- n 1) (cdr l))
 556         l))
 557 )
 558
 559 ; Drop N elements from the end of L.
 560 ; FIXME: list-tail has args reversed (we should conform)
 561
 562 (define (list-tail-drop n l)
 563   (reverse! (list-drop n (reverse l)))
 564 )
 565
 566 ;; left fold
 567 (define (foldl kons accum lis)
 568   (if (null? lis) accum
 569       (foldl kons (kons accum (car lis)) (cdr lis))))
 570
 571 ;; right fold
 572 (define (foldr kons knil lis)
 573   (if (null? lis) knil
 574       (kons (car lis) (foldr kons knil (cdr lis)))))
 575
 576 ;; filter list on predicate
 577 (define (filter p ls)
 578   (foldr (lambda (x a) (if (p x) (cons x a) a))
 579          '() ls))
 580
 581
 582 ; APL's +\ operation on a vector of numbers.
 583
 584 (define (plus-scan l)
 585   (letrec ((-plus-scan (lambda (l result)
 586                          (if (null? l)
 587                              result
 588                              (-plus-scan (cdr l)
 589                                          (cons (if (null? result)
 590                                                    (car l)
 591                                                    (+ (car l) (car result)))
 592                                                result))))))
 593     (reverse! (-plus-scan l nil)))
 594 )
 595
 596 ; Remove duplicate elements from sorted list L.
 597 ; Currently supported elements are symbols (a b c) and lists ((a) (b) (c)).
 598 ; NOTE: Uses equal? for comparisons.
 599
 600 (define (remove-duplicates l)
 601   (let loop ((l l) (result nil))
 602     (cond ((null? l) (reverse! result))
 603           ((null? result) (loop (cdr l) (cons (car l) result)))
 604           ((equal? (car l) (car result)) (loop (cdr l) result))
 605           (else (loop (cdr l) (cons (car l) result)))
 606           )
 607     )
 608 )
 609
 610 ; Return a boolean indicating if each element of list satisfies its
 611 ; corresponding predicates.  The length of L must be equal to the length
 612 ; of PREDS.
 613
 614 (define (list-elements-ok? l preds)
 615   (and (list? l)
 616        (= (length l) (length preds))
 617        (all-true? (map (lambda (pred elm) (pred elm)) preds l)))
 618 )
 619
 620 ; Remove duplicates from unsorted list L.
 621 ; KEY-GENERATOR is a lambda that takes a list element as input and returns
 622 ; an equal? key to use to determine duplicates.
 623 ; The first instance in a set of duplicates is always used.
 624 ; This is not intended to be applied to large lists with an expected large
 625 ; result (where sorting the list first would be faster), though one could
 626 ; add such support later.
 627 ;
 628 ; ??? Rename to follow memq/memv/member naming convention.
 629
 630 (define (nub l key-generator)
 631   (let loop ((l l) (keys (map key-generator l)) (result nil))
 632     (if (null? l)
 633         (reverse! (map cdr result))
 634         (if (assv (car keys) result)
 635             (loop (cdr l) (cdr keys) result)
 636             (loop (cdr l) (cdr keys) (acons (car keys) (car l)
 637                                              result)))))
 638 )
 639
 640 ; Return a boolean indicating if list L1 is a subset of L2.
 641 ; Uses memq.
 642
 643 (define (subset? l1 l2)
 644   (let loop ((l1 l1))
 645     (if (null? l1)
 646         #t
 647         (if (memq (car l1) l2)
 648             (loop (cdr l1))
 649             #f)))
 650 )
 651
 652 ; Return intersection of two lists.
 653
 654 (define (intersection a b)
 655   (foldl (lambda (l e) (if (memq e a) (cons e l) l)) '() b))
 656
 657 ; Return union of two lists.
 658
 659 (define (union a b)
 660   (foldl (lambda (l e) (if (memq e l) l (cons e l))) a b))
 661
 662 ; Return a count of the number of elements of list L1 that are in list L2.
 663 ; Uses memq.
 664
 665 (define (count-common l1 l2)
 666   (let loop ((result 0) (l1 l1))
 667     (if (null? l1)
 668         result
 669         (if (memq (car l1) l2)
 670             (loop (+ result 1) (cdr l1))
 671             (loop result (cdr l1)))))
 672 )
 673
 674 ; Remove duplicate elements from sorted alist L.
 675 ; L must be sorted by name.
 676
 677 (define (alist-nub l)
 678   (let loop ((l l) (result nil))
 679     (cond ((null? l) (reverse! result))
 680           ((null? result) (loop (cdr l) (cons (car l) result)))
 681           ((eq? (caar l) (caar result)) (loop (cdr l) result))
 682           (else (loop (cdr l) (cons (car l) result)))
 683           )
 684     )
 685 )
 686
 687 ; Return a copy of alist L.
 688
 689 (define (alist-copy l)
 690   ; (map cons (map car l) (map cdr l)) ; simple way
 691   ; presumably more efficient way (less cons cells created)
 692   (map (lambda (elm)
 693          (cons (car elm) (cdr elm)))
 694        l)
 695 )
 696
 697 ; Return the order in which to select elements of L sorted by SORT-FN.
 698 ; The result is origin 0.
 699
 700 (define (sort-grade l sort-fn)
 701   (let ((sorted (sort (map cons (iota (length l)) l)
 702                       (lambda (a b) (sort-fn (cdr a) (cdr b))))))
 703     (map car sorted))
 704 )
 705
 706 ; Return ALIST sorted on the name in ascending order.
 707
 708 (define (alist-sort alist)
 709   (sort alist
 710         (lambda (a b)
 711           (string<? (symbol->string (car a))
 712                     (symbol->string (car b)))))
 713 )
 714
 715 ; Return a boolean indicating if C is a leading id char.
 716 ; '@' is treated as an id-char as it's used to delimit something that
 717 ; sed will alter.
 718
 719 (define (leading-id-char? c)
 720   (or (char-alphabetic? c)
 721       (char=? c #\_)
 722       (char=? c #\@))
 723 )
 724
 725 ; Return a boolean indicating if C is an id char.
 726 ; '@' is treated as an id-char as it's used to delimit something that
 727 ; sed will alter.
 728
 729 (define (id-char? c)
 730   (or (leading-id-char? c)
 731       (char-numeric? c))
 732 )
 733
 734 ; Return the length of the identifier that begins S.
 735 ; Identifiers are any of letter, digit, _, @.
 736 ; The first character must not be a digit.
 737 ; ??? The convention is to use "-" between cgen symbols, not "_".
 738 ; Try to handle "-" here as well.
 739
 740 (define (id-len s)
 741   (if (leading-id-char? (string-ref s 0))
 742       (let ((len (string-length s)))
 743         (let loop ((n 0))
 744           (if (and (< n len)
 745                    (id-char? (string-ref s n)))
 746               (loop (1+ n))
 747               n)))
 748       0)
 749 )
 750
 751 ; Return number of characters in STRING until DELIMITER.
 752 ; Returns #f if DELIMITER not present.
 753 ; FIXME: Doesn't yet support \-prefixed delimiter (doesn't terminate scan).
 754
 755 (define (chars-until-delimiter string delimiter)
 756   (let loop ((str string) (result 0))
 757     (cond ((= (string-length str) 0)
 758            #f)
 759           ((char=? (string-ref str 0) delimiter)
 760            result)
 761           (else (loop (string-drop1 str) (1+ result)))))
 762 )
 763
 764 ; Apply FN to each char of STR.
 765
 766 (define (map-over-string fn str)
 767   (do ((tmp (string-copy (if (symbol? str) (symbol->string str) str)))
 768        (i (- (string-length str) 1) (- i 1)))
 769       ((< i 0) tmp)
 770     (string-set! tmp i (fn (string-ref tmp i)))
 771     )
 772 )
 773
 774 ; Return a range.
 775 ; It must be distinguishable from a list of numbers.
 776
 777 (define (minmax min max) (cons min max))
 778
 779 ; Move VALUE of LENGTH bits to position START in a word of SIZE bits.
 780 ; LSB0? is non-#f if bit numbering goes LSB->MSB.
 781 ; Otherwise it goes MSB->LSB.
 782 ; START-LSB? is non-#f if START denotes the least significant bit.
 783 ; Otherwise START denotes the most significant bit.
 784 ; N is assumed to fit in the field.
 785
 786 (define (word-value start length size lsb0? start-lsb? value)
 787   (if lsb0?
 788       (if start-lsb?
 789           (logsll value start)
 790           (logsll value (+ (- start length) 1)))
 791       (if start-lsb?
 792           (logsll value (- size start 1))
 793           (logsll value (- size (+ start length)))))
 794 )
 795
 796 ; Return a bit mask of LENGTH bits in a word of SIZE bits starting at START.
 797 ; LSB0? is non-#f if bit numbering goes LSB->MSB.
 798 ; Otherwise it goes MSB->LSB.
 799 ; START-LSB? is non-#f if START denotes the least significant bit.
 800 ; Otherwise START denotes the most significant bit.
 801
 802 (define (word-mask start length size lsb0? start-lsb?)
 803   (if lsb0?
 804       (if start-lsb?
 805           (logsll (mask length) start)
 806           (logsll (mask length) (+ (- start length) 1)))
 807       (if start-lsb?
 808           (logsll (mask length) (- size start 1))
 809           (logsll (mask length) (- size (+ start length)))))
 810 )
 811
 812 ; Extract LENGTH bits at bit number START in a word of SIZE bits from VALUE.
 813 ; LSB0? is non-#f if bit numbering goes LSB->MSB.
 814 ; Otherwise it goes MSB->LSB.
 815 ; START-LSB? is non-#f if START denotes the least significant bit.
 816 ; Otherwise START denotes the most significant bit.
 817 ;
 818 ; ??? bit-extract takes a big-number argument but still uses logand
 819 ; which doesn't so we don't use it
 820
 821 (define (word-extract start length size lsb0? start-lsb? value)
 822   (if lsb0?
 823       (if start-lsb?
 824           (remainder (logslr value start) (integer-expt 2 length))
 825           (remainder (logslr value (+ (- start length) 1)) (integer-expt 2 length)))
 826       (if start-lsb?
 827           (remainder (logslr value (- size start 1)) (integer-expt 2 length))
 828           (remainder (logslr value (- size (+ start length))) (integer-expt 2 length))))
 829 )
 830
 831 ; Return a bit mask of size SIZE beginning at the LSB.
 832
 833 (define (mask size)
 834   (- (logsll 1 size) 1)
 835 )
 836
 837 ; Split VAL into pieces of bit size LENGTHS.
 838 ; e.g. (split-bits '(8 2) 997) -> (229 3)
 839 ; There are as many elements in the result as there are in LENGTHS.
 840 ; Note that this can result in a loss of information.
 841
 842 (define (split-bits lengths val)
 843   (letrec ((split1
 844             (lambda (lengths val result)
 845               (if (null? lengths)
 846                   result
 847                   (split1 (cdr lengths)
 848                           (quotient val (integer-expt 2 (car lengths)))
 849                           (cons (remainder val (integer-expt 2 (car lengths)))
 850                                 result))))))
 851     (reverse! (split1 lengths val nil)))
 852 )
 853
 854 ; Generalized version of split-bits.
 855 ; e.g. (split-value '(10 10 10) 1234) -> (4 3 2 1) ; ??? -> (1 2 3 4) ?
 856 ; (split-value '(10 10) 1234) -> (4 3)
 857 ; There are as many elements in the result as there are in BASES.
 858 ; Note that this can result in a loss of information.
 859
 860 (define (split-value bases val)
 861   (letrec ((split1
 862             (lambda (bases val result)
 863               (if (null? bases)
 864                   result
 865                   (split1 (cdr bases)
 866                           (quotient val (car bases))
 867                           (cons (remainder val (car bases))
 868                                 result))))))
 869     (reverse! (split1 bases val nil)))
 870 )
 871
 872 ; Convert bits to bytes.
 873
 874 (define (bits->bytes bits) (quotient (+ 7 bits) 8))
 875
 876 ; Convert bytes to bits.
 877
 878 (define (bytes->bits bytes) (* bytes 8))
 879
 880 ; Return a list of integers.
 881 ; Usage:
 882 ; (.iota count)            ; start=0, incr=1
 883 ; (.iota count start)      ; incr=1
 884 ; (.iota count start incr)
 885
 886 (define (iota count . start-incr)
 887   (if (> (length start-incr) 2)
 888       (error "iota: wrong number of arguments:" start-incr))
 889   (if (< count 0)
 890       (error "iota: count must be non-negative:" n))
 891   (let ((start (if (pair? start-incr) (car start-incr) 0))
 892         (incr (if (= (length start-incr) 2) (cadr start-incr) 1)))
 893     (let loop ((i start) (count count) (result '()))
 894       (if (= count 0)
 895           (reverse! result)
 896           (loop (+ i incr) (- count 1) (cons i result)))))
 897 )
 898
 899 ; Return a list of the first N powers of 2.
 900
 901 (define (powers-of-2 n)
 902   (cond ((= n 0) nil)
 903         (else (cons (integer-expt 2 (1- n)) (powers-of-2 (1- n))))
 904         )
 905   ; Another way: (map (lambda (n) (ash 1 n)) (iota n))
 906 )
 907
 908 ; I'm tired of writing (not (= foo bar)).
 909
 910 (define (!= a b) (not (= a b)))
 911
 912 ; Return #t if BIT-NUM (which is starting from LSB), is set in the binary
 913 ; representation of non-negative integer N.
 914
 915 (define (bit-set? n bit-num)
 916   ; ??? Quick hack to work around missing bignum support.
 917   ;(= 1 (cg-logand (logslr n bit-num) 1))
 918   (if (>= n #x20000000)
 919       (if (>= bit-num 16)
 920           (logbit? (- bit-num 16) (logslr n 16))
 921           (logbit? bit-num (remainder n 65536)))
 922       (logbit? bit-num n))
 923 )
 924
 925 ; Return #t if each element of bools is #t.  Since Scheme considers any
 926 ; non-#f value as #t we do too.
 927 ; (all-true? '()) is #t since that is the identity element.
 928
 929 (define (all-true? bools)
 930   (cond ((null? bools) #t)
 931         ((car bools) (all-true? (cdr bools)))
 932         (else #f))
 933 )
 934
 935 ; Return #t if any element of BOOLS is #t.
 936 ; If BOOLS is empty, return #f.
 937
 938 (define (any-true? bools)
 939   (cond ((null? bools) #f)
 940         ((car bools) #t)
 941         (else (any-true? (cdr bools))))
 942 )
 943
 944 ; Return count of true values.
 945
 946 (define (count-true flags)
 947   (let loop ((result 0) (flags flags))
 948     (if (null? flags)
 949         result
 950         (loop (+ result (if (car flags) 1 0))
 951               (cdr flags))))
 952 )
 953
 954 ; Return count of all ones in BITS.
 955
 956 (define (count-bits bits)
 957   (let loop ((result 0) (bits bits))
 958     (if (= bits 0)
 959         result
 960         (loop (+ result (remainder bits 2)) (quotient bits 2))))
 961 )
 962
 963 ; Convert bits in N #f/#t.
 964 ; LENGTH is the length of N in bits.
 965
 966 (define (bits->bools n length)
 967   (do ((result (make-list length #f))
 968        (i 0 (+ i 1)))
 969       ((= i length) (reverse! result))
 970     (list-set! result i (if (bit-set? n i) #t #f))
 971     )
 972 )
 973
 974 ; Print a C integer.
 975
 976 (define (gen-integer val)
 977   (cond ((and (<= #x-80000000 val) (> #x80000000 val))
 978          (number->string val))
 979         ((and (<= #x80000000 val) (>= #xffffffff val))
 980          ; ??? GCC complains if not affixed with "U" but that's not k&r.
 981          ;(string-append (number->string val) "U"))
 982          (string-append "0x" (number->string val 16)))
 983         (else (error "Number too large for gen-integer:" val)))
 984 )
 985
 986 ; Return higher/lower part of double word integer.
 987
 988 (define (high-part val)
 989   (logslr val 32)
 990 )
 991 (define (low-part val)
 992   (remainder val #x100000000)
 993 )
 994
 995 ; Logical operations.
 996
 997 (define (logslr val shift) (ash val (- shift)))
 998 (define logsll ash) ; (logsll val shift) (ash val shift))
 999 ; logand, logior, logxor defined by guile so we don't need to
1000 ; (define (logand a b) ...)
1001 ; (define (logxor a b) ...)
1002 ; (define (logior a b) ...)
1003 ;
1004 ; On the other hand they didn't support bignums, so the cgen-binary
1005 ; defines cg-log* that does.  These are just a quick hack that only
1006 ; handle what currently needs handling.
1007
1008 (define (cg-logand a b)
1009   (if (or (>= a #x20000000)
1010           (>= b #x20000000))
1011       (+ (logsll (logand (logslr a 16) (logslr b 16)) 16)
1012          (logand (remainder a 65536) (remainder b 65536)))
1013       (logand a b))
1014 )
1015
1016 (define (cg-logxor a b)
1017   (if (or (>= a #x20000000)
1018           (>= b #x20000000))
1019       (+ (logsll (logxor (logslr a 16) (logslr b 16)) 16)
1020          (logxor (remainder a 65536) (remainder b 65536)))
1021       (logxor a b))
1022 )
1023
1024 ; Return list of bit values for the 1's in X.
1025
1026 (define (bit-vals x)
1027   (let loop ((result nil) (mask 65536))
1028     (cond ((= mask 0) result)
1029           ((> (logand x mask) 0) (loop (cons mask result) (logslr mask 1)))
1030           (else (loop result (logslr mask 1)))))
1031 )
1032
1033 ; Return bit representation of N in LEN bits.
1034 ; e.g. (bit-rep 6 3) -> (1 1 0)
1035
1036 (define (bit-rep n len)
1037   (cond ((= len 0) nil)
1038         ((> (logand n (logsll 1 (- len 1))) 0)
1039          (cons 1 (bit-rep n (- len 1))))
1040         (else (cons 0 (bit-rep n (- len 1))))))
1041
1042 ; Return list of all bit values from 0 to N.
1043 ; e.g. (bit-patterns 3) -> ((0 0 0) (0 0 1) (0 1 0) ... (1 1 1))
1044
1045 (define (bit-patterns len)
1046   (map (lambda (x) (bit-rep x len)) (iota (logsll 1 len)))
1047 )
1048
1049 ; Compute the list of all indices from bits missing in MASK.
1050 ; e.g. (missing-bit-indices #xff00 #xffff) -> (0 1 2 3 ... 255)
1051
1052 (define (missing-bit-indices mask full-mask)
1053   (let* ((bitvals (bit-vals (logxor mask full-mask)))
1054          (selectors (bit-patterns (length bitvals)))
1055          (map-star (lambda (sel) (map * sel bitvals)))
1056          (compute-indices (lambda (sel) (apply + (map-star sel)))))
1057     (map compute-indices selectors))
1058 )
1059
1060 ; Convert a list of numbers to a string, separated by SEP.
1061 ; The result is prefixed by SEP too.
1062
1063 (define (numbers->string nums sep)
1064   (string-map (lambda (elm) (string-append sep (number->string elm))) nums)
1065 )
1066
1067 ; Convert a number to a hex string.
1068
1069 (define (number->hex num)
1070   (number->string num 16)
1071 )
1072
1073 ; Given a list of numbers NUMS, generate text to pass them as arguments to a
1074 ; C function.  We assume they're not the first argument and thus have a
1075 ; leading comma.
1076
1077 (define (gen-int-args nums)
1078   (numbers->string nums ", ")
1079 )
1080
1081 ; Given a C expression or a list of C expressions, return a comma separated
1082 ; list of them.
1083 ; In the case of more than 0 elements the leading ", " is present so that
1084 ; there is no edge case in the case of 0 elements when the caller is appending
1085 ; the result to an initial set of arguments (the number of commas equals the
1086 ; number of elements).  The caller is responsible for dropping the leading
1087 ; ", " if necessary.  Note that `string-drop' can handle the case where more
1088 ; characters are dropped than are present.
1089
1090 (define (gen-c-args exprs)
1091   (cond ((null? exprs) "")
1092         ((pair? exprs) (string-map (lambda (elm) (string-append ", " elm))
1093                                    exprs))
1094         ((equal? exprs "") "")
1095         (else (string-append ", " exprs)))
1096 )
1097
1098 ; Return a list of N macro argument names.
1099
1100 (define (macro-args n)
1101   (map (lambda (i) (string-append "a" (number->string i)))
1102        (map 1+ (iota n)))
1103 )
1104
1105 ; Return C code for N macro argument names.
1106 ; (gen-macro-args 4) -> ", a1, a2, a3, a4"
1107
1108 (define (gen-macro-args n)
1109   (gen-c-args (macro-args n))
1110 )
1111
1112 ; Return a string to reference an array.
1113 ; INDICES is either a (possibly empty) list of indices or a single index.
1114 ; The values can either be numbers or strings (/symbols).
1115
1116 (define (gen-array-ref indices)
1117   (let ((gen-index (lambda (idx)
1118                      (string-append "["
1119                                     (cond ((number? idx) (number->string idx))
1120                                           (else idx))
1121                                     "]"))))
1122     (cond ((null? indices) "")
1123           ((pair? indices) ; list of indices?
1124            (string-map gen-index indices))
1125           (else (gen-index indices))))
1126 )
1127
1128 ; Return list element N or #f if list L is too short.
1129
1130 (define (list-maybe-ref l n)
1131   (if (> (length l) n)
1132       (list-ref l n)
1133       #f)
1134 )
1135
1136 ; Return list of index numbers of elements in list L that satisfy PRED.
1137 ; I is usually 0.
1138
1139 (define (find-index i pred l)
1140   (define (find1 i pred l result)
1141     (cond ((null? l) result)
1142           ((pred (car l)) (find1 (+ 1 i) pred (cdr l) (cons i result)))
1143           (else (find1 (+ 1 i) pred (cdr l) result))))
1144   (reverse! (find1 i pred l nil))
1145 )
1146
1147 ; Return list of elements of L that satisfy PRED.
1148
1149 (define (find pred l)
1150   (define (find1 pred l result)
1151     (cond ((null? l) result)
1152           ((pred (car l)) (find1 pred (cdr l) (cons (car l) result)))
1153           (else (find1 pred (cdr l) result))))
1154   (reverse! (find1 pred l nil))
1155 )
1156
1157 ; Return first element of L that satisfies PRED or #f if there is none.
1158
1159 (define (find-first pred l)
1160   (cond ((null? l) #f)
1161         ((pred (car l)) (car l))
1162         (else (find-first pred (cdr l))))
1163 )
1164
1165 ; Return list of FN applied to elements of L that satisfy PRED.
1166
1167 (define (find-apply fn pred l)
1168   (cond ((null? l) nil)
1169         ((pred (car l)) (cons (fn (car l)) (find-apply fn pred (cdr l))))
1170         (else (find-apply fn pred (cdr l))))
1171 )
1172
1173 ; Given a list L, look up element ELM and return its index.
1174 ; If not found, return #f.
1175 ; I is added to the result.
1176 ; (Yes, in one sense I is present to simplify the implementation.  Sue me.)
1177
1178 (define (eqv-lookup-index elm l i)
1179   (cond ((null? l) #f)
1180         ((eqv? elm (car l)) i)
1181         (else (eqv-lookup-index elm (cdr l) (1+ i))))
1182 )
1183
1184 ; Given an associative list L, look up entry for symbol S and return its index.
1185 ; If not found, return #f.
1186 ; Eg: (lookup 'element2 '((element1 1) (element2 2)))
1187 ; I is added to the result.
1188 ; (Yes, in one sense I is present to simplify the implementation.  Sue me.)
1189 ; NOTE: Uses eq? for comparisons.
1190
1191 (define (assq-lookup-index s l i)
1192   (cond ((null? l) #f)
1193         ((eqv? s (caar l)) i)
1194         (else (assq-lookup-index s (cdr l) (1+ i))))
1195 )
1196
1197 ; Return the index of element ELM in list L or #f if not found.
1198 ; If found, I is added to the result.
1199 ; (Yes, in one sense I is present to simplify the implementation.  Sue me.)
1200 ; NOTE: Uses equal? for comparisons.
1201
1202 (define (element-lookup-index elm l i)
1203   (cond ((null? l) #f)
1204         ((equal? elm (car l)) i)
1205         (else (element-lookup-index elm (cdr l) (1+ i))))
1206 )
1207
1208 ; Return #t if ELM is in ELM-LIST.
1209 ; NOTE: Uses equal? for comparisons (via `member').
1210
1211 (define (element? elm elm-list)
1212   (->bool (member elm elm-list))
1213 )
1214
1215 ; Return the set of all possible combinations of elements in list L
1216 ; according to the following rules:
1217 ; - each element of L is either an atom (non-list) or a list
1218 ; - each list element is (recursively) interpreted as a set of choices
1219 ; - the result is a list of all possible combinations of elements
1220 ;
1221 ; Example: (list-expand '(a b (1 2 (3 4)) c (5 6)))
1222 ; --> ((a b 1 c d 5)
1223 ;      (a b 1 c d 6)
1224 ;      (a b 2 c d 5)
1225 ;      (a b 2 c d 6)
1226 ;      (a b 3 c d 5)
1227 ;      (a b 3 c d 6)
1228 ;      (a b 4 c d 5)
1229 ;      (a b 4 c d 6))
1230
1231 (define (list-expand l)
1232   #f ; ??? wip
1233 )
1234
1235 ; Given X, a number or symbol, reduce it to a constant if possible.
1236 ; Numbers always reduce to themselves.
1237 ; Symbols are reduced to a number if they're defined as such,
1238 ; or to an enum constant if one exists; otherwise X is returned unchanged.
1239 ; Requires: symbol-bound? enum-lookup-val
1240
1241 (define (reduce x)
1242   (if (number? x)
1243       x
1244       ; A symbol bound to a number?
1245       (if (and (symbol? x) (symbol-bound? #f x) (number? (eval1 x)))
1246           (eval1 x)
1247           ; An enum value that has a known numeric value?
1248           (let ((e (enum-lookup-val x)))
1249             (if (number? (car e))
1250                 (car e)
1251                 ; Otherwise return X unchanged.
1252                 x))))
1253 )
1254
1255 ; If OBJ has a dump method call it, otherwise return OBJ untouched.
1256
1257 (define (dump obj)
1258   (if (method-present? obj 'dump)
1259       (send obj 'dump)
1260       obj)
1261 )
1262 \f
1263 ; Copyright messages.
1264
1265 ; Pair of header,trailer parts of copyright.
1266
1267 (define copyright-fsf
1268   (cons "\
1269 THIS FILE IS MACHINE GENERATED WITH CGEN.
1270
1271 Copyright 1996-2007 Free Software Foundation, Inc.
1272 "
1273         "\
1274    This file is free software; you can redistribute it and/or modify
1275    it under the terms of the GNU General Public License as published by
1276    the Free Software Foundation; either version 3, or (at your option)
1277    any later version.
1278
1279    It is distributed in the hope that it will be useful, but WITHOUT
1280    ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
1281    or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public
1282    License for more details.
1283
1284    You should have received a copy of the GNU General Public License along
1285    with this program; if not, write to the Free Software Foundation, Inc.,
1286    51 Franklin Street - Fifth Floor, Boston, MA 02110-1301, USA.
1287 "
1288 ))
1289
1290 ; Pair of header,trailer parts of copyright.
1291
1292 (define copyright-red-hat
1293   (cons "\
1294 THIS FILE IS MACHINE GENERATED WITH CGEN.
1295
1296 Copyright (C) 2000-2007 Red Hat, Inc.
1297 "
1298         "\
1299 "))
1300
1301 ; Set this to one of copyright-fsf, copyright-red-hat.
1302
1303 (define CURRENT-COPYRIGHT copyright-fsf)
1304
1305 ; Packages.
1306
1307 (define package-gnu-binutils-gdb "\
1308 This file is part of the GNU Binutils and/or GDB, the GNU debugger.
1309 ")
1310
1311 (define package-gnu-simulators "\
1312 This file is part of the GNU simulators.
1313 ")
1314
1315 (define package-red-hat-simulators "\
1316 This file is part of the Red Hat simulators.
1317 ")
1318
1319 (define package-cgen "\
1320 This file is part of CGEN.
1321 ")
1322
1323 ; Return COPYRIGHT, with FILE-DESC as the first line
1324 ; and PACKAGE as the name of the package which the file belongs in.
1325 ; COPYRIGHT is a pair of (header . trailer).
1326
1327 (define (gen-c-copyright file-desc copyright package)
1328   (string-append "/* " file-desc "\n\n"
1329                  (car copyright)
1330                  "\n" package "\n"
1331                  (cdr copyright)
1332                  "\n*/\n\n")
1333 )
1334 \f
1335 ; File operations.
1336
1337 ; Delete FILE, handling the case where it doesn't exist.
1338
1339 (define (delete-file-noerr file)
1340   ; This could also use file-exists?, but it's nice to have a few examples
1341   ; of how to use `catch' lying around.
1342   (catch 'system-error (lambda () (delete-file file))
1343          (lambda args #f))
1344 )
1345
1346 ; Create FILE, point current-output-port to it, and call WRITE-FN.
1347 ; FILE is always overwritten.
1348 ; GEN-FN either writes output to stdout or returns the text to write,
1349 ; the last thing we do is write the text returned by WRITE-FN to FILE.
1350
1351 (define (file-write file write-fn)
1352   (delete-file-noerr file)
1353   (let ((left-over-text (with-output-to-file file write-fn)))
1354     (let ((port (open-file file "a")))
1355       (display left-over-text port)
1356       (close-port port))
1357     #t)
1358 )
1359
1360 ; Return the size in bytes of FILE.
1361
1362 (define (file-size file)
1363   (let ((stat (%stat file)))
1364     (if stat
1365         (vector-ref (%stat file) 7)
1366         -1))
1367 )
1368 \f
1369 ; Time operations.
1370
1371 ; Return the current time.
1372 ; The result is a black box understood only by time-elapsed.
1373
1374 (define (time-current) (gettimeofday))
1375
1376 ; Return the elapsed time in milliseconds since START.
1377
1378 (define (time-elapsed start)
1379   (let ((now (gettimeofday)))
1380     (+ (* (- (car now) (car start)) 1000)
1381        (quotient (- (cdr now) (cdr start)) 1000)))
1382 )
1383
1384 ; Run PROC and return the number of milliseconds it took to execute it N times.
1385
1386 (define (time-proc n proc)
1387   (let ((now (time-current)))
1388     (do ((i 0 (+ i 1))) ((= i n) (time-elapsed now))
1389       (proc)))
1390 )