gsc/_utils.scm

   1 ;;;============================================================================
   2
   3 ;;; File: "_utils.scm", Time-stamp: <2008-01-10 15:50:42 feeley>
   4
   5 ;;; Copyright (c) 1994-2007 by Marc Feeley, All Rights Reserved.
   6
   7 (include "fixnum.scm")
   8
   9 (include-adt "_envadt.scm")
  10 (include-adt "_gvmadt.scm")
  11 (include-adt "_ptreeadt.scm")
  12 (include-adt "_sourceadt.scm")
  13
  14 '(begin ; old code
  15 ;;;----------------------------------------------------------------------------
  16 ;;
  17 ;; Utilities:
  18 ;; ---------
  19
  20 (define (make-counter next)
  21   (lambda ()
  22     (let ((result next))
  23       (set! next (+ next 1))
  24       result)))
  25
  26 (define (for-each-index proc lst)
  27   (let loop ((lst lst) (i 0))
  28     (if (pair? lst)
  29       (begin
  30         (proc (car lst) i)
  31         (loop (cdr lst) (+ i 1))))))
  32
  33 (define (pos-in-list x l)
  34   (let loop ((l l) (i 0))
  35     (cond ((not (pair? l)) #f)
  36           ((eq? (car l) x) i)
  37           (else            (loop (cdr l) (+ i 1))))))
  38
  39 (define (object-pos-in-list x l)
  40   (let loop ((l l) (i 0))
  41     (cond ((not    (pair? l)) #f)
  42           ((equal? (car l) x) i)
  43           (else               (loop (cdr l) (+ i 1))))))
  44
  45 (define (string-pos-in-list x l)
  46   (let loop ((l l) (i 0))
  47     (cond ((not (pair? l))      #f)
  48           ((string=? (car l) x) i)
  49           (else                 (loop (cdr l) (+ i 1))))))
  50
  51 (define (take l n)
  52   (let loop ((l l) (n n))
  53     (if (> n 0)
  54       (cons (car l) (loop (cdr l) (- n 1)))
  55       '())))
  56
  57 (define (drop l n)
  58   (let loop ((l l) (n n))
  59     (if (> n 0)
  60       (loop (cdr l) (- n 1))
  61       l)))
  62
  63 (define (pair-up l1 l2)
  64   (define (pair l1 l2)
  65     (if (pair? l1)
  66       (cons (cons (car l1) (car l2)) (pair (cdr l1) (cdr l2)))
  67       '()))
  68   (pair l1 l2))
  69
  70 (define (last-pair l)
  71   (let loop ((l l))
  72     (if (pair? (cdr l))
  73       (loop (cdr l))
  74       l)))
  75
  76 (define (keep keep? lst)
  77   (cond ((null? lst)       '())
  78         ((keep? (car lst)) (cons (car lst) (keep keep? (cdr lst))))
  79         (else              (keep keep? (cdr lst)))))
  80
  81 (define (every? pred? lst)
  82   (or (null? lst)
  83       (and (pred? (car lst))
  84            (every? pred? (cdr lst)))))
  85
  86 (define (remq x lst)
  87   (cond ((null? lst)       '())
  88         ((eq? (car lst) x) (cdr lst))
  89         (else              (cons (car lst) (remq x (cdr lst))))))
  90
  91 (define (sort-list l <?)
  92
  93   (define (mergesort l)
  94
  95     (define (merge l1 l2)
  96       (cond ((null? l1) l2)
  97             ((null? l2) l1)
  98             (else
  99              (let ((e1 (car l1)) (e2 (car l2)))
 100                (if (<? e1 e2)
 101                  (cons e1 (merge (cdr l1) l2))
 102                  (cons e2 (merge l1 (cdr l2))))))))
 103
 104     (define (split l)
 105       (if (or (null? l) (null? (cdr l)))
 106         l
 107         (cons (car l) (split (cddr l)))))
 108
 109     (if (or (null? l) (null? (cdr l)))
 110       l
 111       (let* ((l1 (mergesort (split l)))
 112              (l2 (mergesort (split (cdr l)))))
 113         (merge l1 l2))))
 114
 115   (mergesort l))
 116
 117 (define (list->vect l)
 118   (let* ((n (list-length l))
 119          (v (make-vector n)))
 120     (let loop ((l l) (i 0))
 121       (if (pair? l)
 122         (begin
 123           (vector-set! v i (car l))
 124           (loop (cdr l) (+ i 1)))
 125         v))))
 126
 127 (define (vect->list v)
 128   (let loop ((l '()) (i (- (vector-length v) 1)))
 129     (if (< i 0)
 130       l
 131       (loop (cons (vector-ref v i) l) (- i 1)))))
 132
 133 (define (list->str l)
 134   (let* ((n (list-length l))
 135          (s (make-string n)))
 136     (let loop ((l l) (i 0))
 137       (if (pair? l)
 138         (begin
 139           (string-set! s i (car l))
 140           (loop (cdr l) (+ i 1)))
 141         s))))
 142
 143 (define (str->list s)
 144   (let loop ((l '()) (i (- (string-length s) 1)))
 145     (if (< i 0)
 146       l
 147       (loop (cons (string-ref s i) l) (- i 1)))))
 148
 149 (define (make-stretchable-vector init)
 150   (vector '#() init))
 151
 152 (define (stretchable-vector-length sv)
 153   (vector-length (vector-ref sv 0)))
 154
 155 (define (stretchable-vector-ref sv i)
 156   (let* ((v (vector-ref sv 0))
 157          (len (vector-length v)))
 158     (if (< i len)
 159       (vector-ref v i)
 160       (vector-ref sv 1))))
 161
 162 (define (stretchable-vector-set! sv i x)
 163   (let* ((v (vector-ref sv 0))
 164          (len (vector-length v)))
 165     (if (< i len)
 166       (vector-set! v i x)
 167       (let ((new-v
 168               (stretch-vector
 169                 v
 170                 (+ (max i (quotient (* len 3) 2)) 1) ; make 50% bigger at least
 171                 (vector-ref sv 1))))
 172         (vector-set! sv 0 new-v)
 173         (vector-set! new-v i x)))))
 174
 175 (define (stretch-vector v n init)
 176   (let ((len (vector-length v))
 177         (new-v (make-vector n)))
 178     (let loop1 ((i 0))
 179       (if (< i len)
 180         (begin
 181           (vector-set! new-v i (vector-ref v i))
 182           (loop1 (+ i 1)))))
 183     (let loop2 ((i len))
 184       (if (< i n)
 185         (begin
 186           (vector-set! new-v i init)
 187           (loop2 (+ i 1)))))
 188     new-v))
 189
 190 (define (stretchable-vector-copy sv)
 191   (let* ((v1 (vector-ref sv 0))
 192          (n (vector-length v1))
 193          (v2 (make-vector n)))
 194     (let loop ((i (- n 1)))
 195       (if (>= i 0)
 196         (begin
 197           (vector-set! v2 i (vector-ref v1 i))
 198           (loop (- i 1)))
 199         (vector v2 (vector-ref sv 1))))))
 200
 201 (define (stretchable-vector-for-each proc sv)
 202   (let* ((v (vector-ref sv 0))
 203          (n (vector-length v)))
 204     (let loop ((i 0))
 205       (if (< i n)
 206         (begin
 207           (proc (vector-ref v i) i)
 208           (loop (+ i 1)))))))
 209
 210 (define (bits-and x y) ; bitwise and of x and y, assumes x and y >= 0
 211
 212   (define (band x y)
 213     (cond ((= x 0) 0)
 214           ((= y 0) 0)
 215           (else
 216            (let ((z (* (band (quotient x 2) (quotient y 2)) 2)))
 217              (if (and (odd? x) (odd? y))
 218                (+ z 1)
 219                z)))))
 220
 221   (band x y))
 222
 223 (define (bits-or x y) ; bitwise or of x and y, assumes x and y >= 0
 224
 225   (define (bor x y)
 226     (cond ((= x 0) y)
 227           ((= y 0) x)
 228           (else
 229            (let ((z (* (bor (quotient x 2) (quotient y 2)) 2)))
 230              (if (or (odd? x) (odd? y))
 231                (+ z 1)
 232                z)))))
 233
 234   (bor x y))
 235
 236 (define (bits-shl x y) ; shift x left by y bits, assumes x>=0 and y>=0
 237
 238   (define (shl x y)
 239     (if (> y 0)
 240       (shl (* x 2) (- y 1))
 241       x))
 242
 243   (shl x y))
 244
 245 (define (bits-shr x y) ; shift x right by y bits, assumes x>=0 and y>=0
 246
 247   (define (shr x y)
 248     (if (> y 0)
 249       (shr (quotient x 2) (- y 1))
 250       x))
 251
 252   (shr x y))
 253
 254 ;;;----------------------------------------------------------------------------
 255 ;;
 256 ;; Exception processing
 257 ;; --------------------
 258
 259 (define (with-exception-handling proc)
 260   (let ((old-exception-handler throw-to-exception-handler))
 261     (let ((val
 262             (call-with-current-continuation
 263               (lambda (cont)
 264                 (set! throw-to-exception-handler cont)
 265                 (proc)))))
 266     (set! throw-to-exception-handler old-exception-handler)
 267     val)))
 268
 269 (define (throw-to-exception-handler val)
 270   (fatal-err "Internal error, no exception handler at this point" val))
 271
 272 ;;;----------------------------------------------------------------------------
 273 ;;
 274 ;; Compiler error processing
 275 ;; -------------------------
 276
 277 (define (compiler-error msg . args)
 278   (display "*** ERROR -- ")
 279   (display msg)
 280   (for-each (lambda (x) (display " ") (write x)) args)
 281   (newline)
 282   (compiler-abort))
 283
 284 (define (compiler-user-error loc msg . args)
 285   (display "*** ERROR") (locat-show " IN " loc) (display " -- ")
 286   (display msg)
 287   (for-each (lambda (x) (display " ") (write x)) args)
 288   (newline)
 289   (compiler-abort))
 290
 291 (define (compiler-user-warning loc msg . args)
 292   (if warnings-requested?
 293     (begin
 294       (display "*** WARNING") (locat-show " IN " loc) (display " -- ")
 295       (display msg)
 296       (for-each (lambda (x) (display " ") (write x)) args)
 297       (newline))))
 298
 299 (define (compiler-internal-error msg . args)
 300   (display "*** ERROR -- Compiler internal error detected") (newline)
 301   (display "*** in procedure ") (display msg)
 302   (for-each (lambda (x) (display " ") (write x)) args)
 303   (newline)
 304   (compiler-abort))
 305
 306 (define (compiler-limitation-error msg . args)
 307   (display "*** ERROR -- Compiler limit reached") (newline)
 308   (display "*** ") (display msg)
 309   (for-each (lambda (x) (display " ") (write x)) args)
 310   (newline)
 311   (compiler-abort))
 312
 313 (define (compiler-abort)
 314   (throw-to-exception-handler #f))
 315
 316 (define warnings-requested? #f)
 317 (set! warnings-requested? #t)
 318
 319 ;;;----------------------------------------------------------------------------
 320 ;;
 321 ;; Transitive closure and topological sorting.
 322
 323 (define (make-gnode var depvars) (vector var depvars)) ; graph node
 324 (define (gnode-var x) (vector-ref x 0))
 325 (define (gnode-depvars x) (vector-ref x 1))
 326
 327 (define (transitive-closure graph)
 328   (define changed? #f)
 329   (define (closure depvars)
 330     (varset-union-multi
 331       (cons depvars
 332             (map (lambda (var) (gnode-find-depvars var graph))
 333                  (varset->list depvars)))))
 334   (let ((new-graph
 335           (map (lambda (x)
 336                  (let ((new-depvars (closure (gnode-depvars x))))
 337                    (if (not (= (varset-size new-depvars)
 338                                (varset-size (gnode-depvars x))))
 339                      (set! changed? #t))
 340                    (make-gnode (gnode-var x) new-depvars)))
 341                graph)))
 342     (if changed?
 343       (transitive-closure new-graph)
 344       new-graph)))
 345
 346 (define (gnode-find-depvars var graph)
 347   (if (null? graph)
 348     (varset-empty)
 349     (let ((node (car graph)))
 350       (if (eq? (gnode-var node) var)
 351         (gnode-depvars node)
 352         (gnode-find-depvars var (cdr graph))))))
 353
 354 (define (gnodes-remove graph gnodes)
 355   (if (null? graph)
 356     '()
 357     (let ((node (car graph)))
 358       (if (memq node gnodes)
 359         (gnodes-remove (cdr graph) gnodes)
 360         (cons node (gnodes-remove (cdr graph) gnodes))))))
 361
 362 (define (topological-sort graph) ; topological sort fixed to handle cycles
 363   (if (null? graph)
 364     '()
 365     (let ((to-remove (or (remove-no-depvars graph) (remove-cycle graph))))
 366       (let ((vars (list->varset (map gnode-var to-remove))))
 367         (cons vars
 368               (topological-sort
 369                 (map (lambda (x)
 370                        (make-gnode
 371                          (gnode-var x)
 372                          (varset-difference (gnode-depvars x) vars)))
 373                      (gnodes-remove graph to-remove))))))))
 374
 375 (define (remove-no-depvars graph)
 376   (let ((nodes-with-no-depvars
 377          (keep (lambda (x) (varset-empty? (gnode-depvars x))) graph)))
 378     (if (null? nodes-with-no-depvars)
 379       #f
 380       nodes-with-no-depvars)))
 381
 382 (define (remove-cycle graph)
 383   (define (remove l)
 384     (let* ((node (car l))
 385            (depvars (gnode-depvars node)))
 386       (define (equal-depvars? x) (varset-equal? (gnode-depvars x) depvars))
 387       (define (member-depvars? x) (varset-member? (gnode-var x) depvars))
 388       (if (member-depvars? node)
 389         (let ((depvar-graph (keep member-depvars? graph)))
 390           (if (every? equal-depvars? depvar-graph)
 391             depvar-graph
 392             (remove (cdr l))))
 393         (remove (cdr l)))))
 394   (remove graph))
 395
 396 ;;;----------------------------------------------------------------------------
 397 ;;
 398 ;; SET manipulation stuff
 399 ;; ----------------------
 400
 401 ;; Parse tree sets
 402
 403 (define (ptset-empty)              ; return the empty set
 404   '())
 405
 406 (define (ptset->list set)          ; convert set to list
 407   set)
 408
 409 (define (ptset-size set)           ; return cardinality of set
 410   (list-length set))
 411
 412 (define (ptset-empty? set)         ; is 'x' the empty set?
 413   (null? set))
 414
 415 (define (ptset-member? x set)      ; is 'x' a member of the 'set'?
 416   (and (not (null? set))
 417        (or (eq? x (car set))
 418            (ptset-member? x (cdr set)))))
 419
 420 (define (ptset-adjoin set x)       ; add the element 'x' to the 'set'
 421   (if (ptset-member? x set) set (cons x set)))
 422
 423 (define (ptset-every? pred? set)   ; is 'pred?' true of every element
 424   (or (null? set)
 425       (and (pred? (car set))
 426            (ptset-every? pred? (cdr set)))))
 427
 428 (define (ptset-remove set x)       ; remove the element 'x' from 'set'
 429   (cond ((null? set)
 430          '())
 431         ((eq? (car set) x)
 432          (cdr set))
 433         (else
 434          (cons (car set) (ptset-remove (cdr set) x)))))
 435
 436 ;; Variable sets
 437
 438 (define (varset-empty)              ; return the empty set
 439   '())
 440
 441 (define (varset-singleton x)        ; create a set containing only 'x'
 442   (list x))
 443
 444 (define (list->varset lst)          ; convert list to set
 445   lst)
 446
 447 (define (varset->list set)          ; convert set to list
 448   set)
 449
 450 (define (varset-size set)           ; return cardinality of set
 451   (list-length set))
 452
 453 (define (varset-empty? set)         ; is 'x' the empty set?
 454   (null? set))
 455
 456 (define (varset-member? x set)      ; is 'x' a member of the 'set'?
 457   (and (not (null? set))
 458        (or (eq? x (car set))
 459            (varset-member? x (cdr set)))))
 460
 461 (define (varset-adjoin set x)       ; add the element 'x' to the 'set'
 462   (if (varset-member? x set) set (cons x set)))
 463
 464 (define (varset-remove set x)       ; remove the element 'x' from 'set'
 465   (cond ((null? set)
 466          '())
 467         ((eq? (car set) x)
 468          (cdr set))
 469         (else
 470          (cons (car set) (varset-remove (cdr set) x)))))
 471
 472 (define (varset-equal? s1 s2)       ; are 's1' and 's2' equal sets?
 473   (and (varset-subset? s1 s2)
 474        (varset-subset? s2 s1)))
 475
 476 (define (varset-subset? s1 s2)      ; is 's1' a subset of 's2'?
 477   (cond ((null? s1)
 478          #t)
 479         ((varset-member? (car s1) s2)
 480          (varset-subset? (cdr s1) s2))
 481         (else
 482          #f)))
 483
 484 (define (varset-difference set1 set2) ; return difference of sets
 485   (cond ((null? set1)
 486          '())
 487         ((varset-member? (car set1) set2)
 488          (varset-difference (cdr set1) set2))
 489         (else
 490          (cons (car set1) (varset-difference (cdr set1) set2)))))
 491
 492 (define (varset-union set1 set2)    ; return union of sets
 493   (define (union s1 s2)
 494     (cond ((null? s1)
 495            s2)
 496           ((varset-member? (car s1) s2)
 497            (union (cdr s1) s2))
 498           (else
 499            (cons (car s1) (union (cdr s1) s2)))))
 500   (if (varset-smaller? set1 set2)
 501     (union set1 set2)
 502     (union set2 set1)))
 503
 504 (define (varset-intersection set1 set2) ; return intersection of sets
 505   (define (intersection s1 s2)
 506     (cond ((null? s1)
 507            '())
 508           ((varset-member? (car s1) s2)
 509            (cons (car s1) (intersection (cdr s1) s2)))
 510           (else
 511            (intersection (cdr s1) s2))))
 512   (if (varset-smaller? set1 set2)
 513     (intersection set1 set2)
 514     (intersection set2 set1)))
 515
 516 (define (varset-intersects? set1 set2) ; do sets 'set1' and 'set2' intersect?
 517   (not (varset-empty? (varset-intersection set1 set2))))
 518
 519 (define (varset-smaller? set1 set2)
 520   (if (null? set1)
 521     (not (null? set2))
 522     (if (null? set2)
 523       #f
 524       (varset-smaller? (cdr set1) (cdr set2)))))
 525
 526 (define (varset-union-multi sets)
 527   (if (null? sets)
 528     (varset-empty)
 529     (n-ary varset-union (car sets) (cdr sets))))
 530
 531 (define (n-ary function first rest)
 532   (if (null? rest)
 533     first
 534     (n-ary function (function first (car rest)) (cdr rest))))
 535
 536 ;;;----------------------------------------------------------------------------
 537 ;;
 538 ;; QUEUE manipulation stuff
 539 ;; ------------------------
 540
 541 (define (list->queue list)    ; convert list to queue
 542   (cons list (if (pair? list) (last-pair list) '())))
 543
 544 (define (queue->list queue)   ; convert queue to list
 545   (car queue))
 546
 547 (define (queue-empty)         ; the empty queue
 548   (cons '() '()))
 549
 550 (define (queue-empty? queue)  ; is the queue empty?
 551   (null? (car queue)))
 552
 553 (define (queue-get! queue)    ; remove the first element of the queue
 554   (if (null? (car queue))
 555     (compiler-internal-error "queue-get!, queue is empty")
 556     (let ((x (caar queue)))
 557       (set-car! queue (cdar queue))
 558       (if (null? (car queue)) (set-cdr! queue '()))
 559       x)))
 560
 561 (define (queue-put! queue x)  ; add an element to the end of the queue
 562   (let ((entry (cons x '())))
 563     (if (null? (car queue))
 564       (set-car! queue entry)
 565       (set-cdr! (cdr queue) entry))
 566     (set-cdr! queue entry)
 567     x))
 568
 569 ;;;============================================================================
 570 )
 571
 572 (define (append-lists lst)
 573
 574   (define (append1 lst)
 575     (if (pair? (cdr lst))
 576       (append2 (car lst) (append1 (cdr lst)))
 577       (car lst)))
 578
 579   (define (append2 lst1 lst2)
 580     (if (pair? lst1)
 581       (let ((result (cons (car lst1) '())))
 582         (set-cdr!
 583           (let loop ((end result) (lst1 (cdr lst1)))
 584             (if (pair? lst1)
 585               (let ((tail (cons (car lst1) '())))
 586                 (set-cdr! end tail)
 587                 (loop tail (cdr lst1)))
 588               end))
 589           lst2)
 590         result)
 591       lst2))
 592
 593   (if (pair? lst)
 594     (append1 lst)
 595     '()))
 596
 597 (begin;**************brad
 598 ;(##include "../gsc/_ptree1adt.scm")
 599 ;(##include "../gsc/_envadt.scm")
 600
 601 ;;;----------------------------------------------------------------------------
 602 ;;
 603 ;; Utilities:
 604 ;; ---------
 605
 606 (define (reverse-append! xrev y)
 607   (if (null? xrev)
 608       y
 609       (let ((temp (cdr xrev)))
 610         (set-cdr! xrev y)
 611         (reverse-append! temp xrev))))
 612
 613 (define (list-length lst)
 614   (let loop ((n 0) (lst lst))
 615     (if (pair? lst)
 616         (loop (+ n 1) (cdr lst))
 617         n)))
 618
 619 (define (make-counter next)
 620   (lambda ()
 621     (let ((result next))
 622       (set! next (+ next 1))
 623       result)))
 624
 625 (define (for-each-index proc lst)
 626   (let loop ((lst lst) (i 0))
 627     (if (pair? lst)
 628       (begin
 629         (proc (car lst) i)
 630         (loop (cdr lst) (+ i 1))))))
 631
 632 (define (pos-in-list x l)
 633   (let loop ((l l) (i 0))
 634     (cond ((not (pair? l)) #f)
 635           ((eq? (car l) x) i)
 636           (else            (loop (cdr l) (+ i 1))))))
 637
 638 (define (object-pos-in-list x l)
 639   (let loop ((l l) (i 0))
 640     (cond ((not    (pair? l)) #f)
 641           ((equal? (car l) x) i)
 642           (else               (loop (cdr l) (+ i 1))))))
 643
 644 (define (string-pos-in-list x l)
 645   (let loop ((l l) (i 0))
 646     (cond ((not (pair? l))      #f)
 647           ((string=? (car l) x) i)
 648           (else                 (loop (cdr l) (+ i 1))))))
 649
 650 (define (take l n)
 651   (let loop ((l l) (n n))
 652     (if (> n 0)
 653       (cons (car l) (loop (cdr l) (- n 1)))
 654       '())))
 655
 656 (define (drop l n)
 657   (let loop ((l l) (n n))
 658     (if (> n 0)
 659       (loop (cdr l) (- n 1))
 660       l)))
 661
 662 (define (pair-up l1 l2)
 663   (define (pair l1 l2)
 664     (if (pair? l1)
 665       (cons (cons (car l1) (car l2)) (pair (cdr l1) (cdr l2)))
 666       '()))
 667   (pair l1 l2))
 668
 669 (define (last-pair l)
 670   (let loop ((l l))
 671     (if (pair? (cdr l))
 672       (loop (cdr l))
 673       l)))
 674
 675 (define (keep keep? lst)
 676   (let loop ((lst lst) (head '()))
 677     (cond ((null? lst)
 678            (reverse-append! head lst))
 679           ((keep? (car lst))
 680            (loop (cdr lst) (cons (car lst) head)))
 681           (else
 682            (loop (cdr lst) head)))))
 683
 684 (define (every? pred? lst)
 685   (or (null? lst)
 686       (and (pred? (car lst))
 687            (every? pred? (cdr lst)))))
 688
 689 (define (remq x lst)
 690   (let loop ((l lst) (head '()))
 691     (cond ((null? l) ; didn't find x, so just return lst
 692            lst)
 693           ((eq? (car l) x)
 694            (reverse-append! head (cdr l)))
 695           (else
 696            (loop (cdr l) (cons (car l) head))))))
 697
 698 (define (sort-list l <?)
 699
 700   (define (mergesort l)
 701
 702     (define (merge l1 l2)
 703       (cond ((null? l1) l2)
 704             ((null? l2) l1)
 705             (else
 706              (let ((e1 (car l1)) (e2 (car l2)))
 707                (if (<? e1 e2)
 708                  (cons e1 (merge (cdr l1) l2))
 709                  (cons e2 (merge l1 (cdr l2))))))))
 710
 711     (define (split l)
 712       (if (or (null? l) (null? (cdr l)))
 713         l
 714         (cons (car l) (split (cddr l)))))
 715
 716     (if (or (null? l) (null? (cdr l)))
 717       l
 718       (let* ((l1 (mergesort (split l)))
 719              (l2 (mergesort (split (cdr l)))))
 720         (merge l1 l2))))
 721
 722   (mergesort l))
 723
 724 (define (list->vect l)
 725   (let* ((n (list-length l))
 726          (v (make-vector n)))
 727     (let loop ((l l) (i 0))
 728       (if (pair? l)
 729         (begin
 730           (vector-set! v i (car l))
 731           (loop (cdr l) (+ i 1)))
 732         v))))
 733
 734 (define (vect->list v)
 735   (let loop ((l '()) (i (- (vector-length v) 1)))
 736     (if (< i 0)
 737       l
 738       (loop (cons (vector-ref v i) l) (- i 1)))))
 739
 740 (define (list->str l)
 741   (let* ((n (list-length l))
 742          (s (make-string n)))
 743     (let loop ((l l) (i 0))
 744       (if (pair? l)
 745         (begin
 746           (string-set! s i (car l))
 747           (loop (cdr l) (+ i 1)))
 748         s))))
 749
 750 (define (str->list s)
 751   (let loop ((l '()) (i (- (string-length s) 1)))
 752     (if (< i 0)
 753       l
 754       (loop (cons (string-ref s i) l) (- i 1)))))
 755
 756 ;;;----------------------------------------------------------------------------
 757
 758 ;; Strechable vectors
 759 ;; ------------------
 760
 761 (define (make-stretchable-vector init)
 762   (vector '#() init))
 763
 764 (define (stretchable-vector-length sv)
 765   (vector-length (vector-ref sv 0)))
 766
 767 (define (stretchable-vector-ref sv i)
 768   (let* ((v (vector-ref sv 0))
 769          (len (vector-length v)))
 770     (if (< i len)
 771       (vector-ref v i)
 772       (vector-ref sv 1))))
 773
 774 (define (stretchable-vector-set! sv i x)
 775   (let* ((v (vector-ref sv 0))
 776          (len (vector-length v)))
 777     (if (< i len)
 778       (vector-set! v i x)
 779       (let ((new-v
 780               (stretch-vector
 781                 v
 782                 (+ (max i (quotient (* len 3) 2)) 1) ; make 50% bigger at least
 783                 (vector-ref sv 1))))
 784         (vector-set! sv 0 new-v)
 785         (vector-set! new-v i x)))))
 786
 787 (define (stretch-vector v n init)
 788   (let ((len (vector-length v))
 789         (new-v (make-vector n)))
 790     (let loop1 ((i 0))
 791       (if (< i len)
 792         (begin
 793           (vector-set! new-v i (vector-ref v i))
 794           (loop1 (+ i 1)))))
 795     (let loop2 ((i len))
 796       (if (< i n)
 797         (begin
 798           (vector-set! new-v i init)
 799           (loop2 (+ i 1)))))
 800     new-v))
 801
 802 (define (stretchable-vector-copy sv)
 803   (let* ((v1 (vector-ref sv 0))
 804          (n (vector-length v1))
 805          (v2 (make-vector n)))
 806     (let loop ((i (- n 1)))
 807       (if (>= i 0)
 808         (begin
 809           (vector-set! v2 i (vector-ref v1 i))
 810           (loop (- i 1)))
 811         (vector v2 (vector-ref sv 1))))))
 812
 813 (define (stretchable-vector-for-each proc sv)
 814   (let* ((v (vector-ref sv 0))
 815          (n (vector-length v)))
 816     (let loop ((i 0))
 817       (if (< i n)
 818         (begin
 819           (proc (vector-ref v i) i)
 820           (loop (+ i 1)))))))
 821
 822 ;;;----------------------------------------------------------------------------
 823
 824 ;; Ordered table
 825 ;; -------------
 826
 827 (define (make-ordered-table test)
 828   (vector (make-table 'test: test)
 829           (make-stretchable-vector #f)
 830           0))
 831
 832 (define (ordered-table-length ot)
 833   (vector-ref ot 2))
 834
 835 (define (ordered-table-index ot key)
 836   (table-ref (vector-ref ot 0) key #f))
 837
 838 (define (ordered-table-lookup ot key)
 839   (let ((i (table-ref (vector-ref ot 0) key #f)))
 840     (if i
 841       (cdr (stretchable-vector-ref (vector-ref ot 1) i))
 842       #f)))
 843
 844 (define (ordered-table-enter ot key proc)
 845   (let ((i (vector-ref ot 2)))
 846     (vector-set! ot 2 (+ i 1))
 847     (table-set! (vector-ref ot 0) key i)
 848     (let ((result (proc key i)))
 849       (stretchable-vector-set! (vector-ref ot 1) i (cons key result))
 850       result)))
 851
 852 (define (ordered-table->list ot)
 853   (let loop ((i (- (vector-ref ot 2) 1)) (lst '()))
 854     (if (< i 0)
 855       lst
 856       (loop (- i 1)
 857             (cons (stretchable-vector-ref (vector-ref ot 1) i) lst)))))
 858
 859 ;;;----------------------------------------------------------------------------
 860
 861 ;; Bitwise operations
 862 ;; ------------------
 863
 864 (define (bits-and x y) ; bitwise and of x and y, assumes x and y >= 0
 865
 866   (define (band x y)
 867     (cond ((= x 0) 0)
 868           ((= y 0) 0)
 869           (else
 870            (let ((z (* (band (quotient x 2) (quotient y 2)) 2)))
 871              (if (and (odd? x) (odd? y))
 872                (+ z 1)
 873                z)))))
 874
 875   (band x y))
 876
 877 (define (bits-or x y) ; bitwise or of x and y, assumes x and y >= 0
 878
 879   (define (bor x y)
 880     (cond ((= x 0) y)
 881           ((= y 0) x)
 882           (else
 883            (let ((z (* (bor (quotient x 2) (quotient y 2)) 2)))
 884              (if (or (odd? x) (odd? y))
 885                (+ z 1)
 886                z)))))
 887
 888   (bor x y))
 889
 890 (define (bits-shl x y) ; shift x left by y bits, assumes x>=0 and y>=0
 891
 892   (define (shl x y)
 893     (if (> y 0)
 894       (shl (* x 2) (- y 1))
 895       x))
 896
 897   (shl x y))
 898
 899 (define (bits-shr x y) ; shift x right by y bits, assumes x>=0 and y>=0
 900
 901   (define (shr x y)
 902     (if (> y 0)
 903       (shr (quotient x 2) (- y 1))
 904       x))
 905
 906   (shr x y))
 907
 908 ;;;----------------------------------------------------------------------------
 909 ;;
 910 ;; Exception processing
 911 ;; --------------------
 912
 913 (define (with-exception-handling proc)
 914   (let ((old-exception-handler throw-to-exception-handler))
 915     (let ((val
 916             (call-with-current-continuation
 917               (lambda (cont)
 918                 (set! throw-to-exception-handler cont)
 919                 (proc)))))
 920     (set! throw-to-exception-handler old-exception-handler)
 921     val)))
 922
 923 (define (throw-to-exception-handler val)
 924   (fatal-err "Internal error, no exception handler at this point" val))
 925
 926 ;;;----------------------------------------------------------------------------
 927 ;;
 928 ;; Compiler error processing
 929 ;; -------------------------
 930
 931 (define (compiler-error msg . args)
 932   (display "*** ERROR -- ")
 933   (display msg)
 934   (for-each (lambda (x) (display " ") (write x)) args)
 935   (newline)
 936   (compiler-abort))
 937
 938 (define (compiler-user-error loc msg . args)
 939   (display "*** ERROR") (locat-show " IN " loc) (display " -- ")
 940   (display msg)
 941   (for-each (lambda (x) (display " ") (write x)) args)
 942   (newline)
 943   (compiler-abort))
 944
 945 (define (compiler-user-warning loc msg . args)
 946   (if warnings-requested?
 947     (begin
 948       (display "*** WARNING") (locat-show " IN " loc) (display " -- ")
 949       (display msg)
 950       (for-each (lambda (x) (display " ") (write x)) args)
 951       (newline))))
 952
 953 (define (compiler-internal-error msg . args)
 954   (display "*** ERROR -- Compiler internal error detected") (newline)
 955   (display "*** in procedure ") (display msg)
 956   (for-each (lambda (x) (display " ") (write x)) args)
 957   (newline)
 958   (compiler-abort))
 959
 960 (define (compiler-limitation-error msg . args)
 961   (display "*** ERROR -- Compiler limit reached") (newline)
 962   (display "*** ") (display msg)
 963   (for-each (lambda (x) (display " ") (write x)) args)
 964   (newline)
 965   (compiler-abort))
 966
 967 (define (compiler-abort)
 968   (throw-to-exception-handler #f))
 969
 970 (define warnings-requested? #f)
 971 (set! warnings-requested? #t)
 972
 973 ;;;----------------------------------------------------------------------------
 974 ;;
 975 ;; Transitive closure and topological sorting.
 976
 977 (define (make-gnode var depvars) (vector var depvars)) ; graph node
 978 (define (gnode-var x) (vector-ref x 0))
 979 (define (gnode-depvars x) (vector-ref x 1))
 980
 981 (define (transitive-closure graph)
 982   (let* ((graph-vector
 983           (list->vect
 984            (sort-list graph
 985                       (lambda (x y) (varset-< (gnode-var x) (gnode-var y))))))
 986          (graph-size
 987           (vector-length graph-vector)))
 988     (let loop ((graph-vector graph-vector))
 989       (let ((changed? #f))
 990
 991         (define (closure depvars)
 992           (varset-union-multi
 993            (cons depvars
 994                  (map (lambda (var) (gnode-find-depvars var graph-vector))
 995                       (varset->list depvars)))))
 996
 997         (let ((new-graph-vector
 998                (let ((result (make-vector graph-size)))
 999                  (do ((i 0 (+ i 1)))
1000                      ((= i graph-size) result)
1001                    (let ((x (vector-ref graph-vector i)))
1002                      (let ((new-depvars (closure (gnode-depvars x))))
1003                        (if (not (= (varset-size new-depvars)
1004                                    (varset-size (gnode-depvars x))))
1005                          (set! changed? #t))
1006                        (vector-set!
1007                         result
1008                         i
1009                         (make-gnode (gnode-var x) new-depvars))))))))
1010           (if changed?
1011             (loop new-graph-vector)
1012             (vect->list new-graph-vector)))))))
1013
1014 (define (gnode-find-depvars var graph-vector)
1015   (let loop ((f 0) (l (- (vector-length graph-vector) 1)))
1016     (if (< l f)
1017       (varset-empty)
1018       (let* ((i (quotient (+ l f) 2))
1019              (node (vector-ref graph-vector i)))
1020         (cond ((eq? (gnode-var node) var)
1021                (gnode-depvars node))
1022               ((varset-< var (gnode-var node))
1023                (loop f (- i 1)))
1024               (else
1025                (loop (+ i 1) l)))))))
1026
1027 '(begin ; old code
1028
1029 (define (transitive-closure graph)
1030   (define changed? #f)
1031   (define (closure depvars)
1032     (varset-union-multi
1033       (cons depvars
1034             (map (lambda (var) (gnode-find-depvars var graph))
1035                  (varset->list depvars)))))
1036   (let ((new-graph
1037           (map (lambda (x)
1038                  (let ((new-depvars (closure (gnode-depvars x))))
1039                    (if (not (= (varset-size new-depvars)
1040                                (varset-size (gnode-depvars x))))
1041                      (set! changed? #t))
1042                    (make-gnode (gnode-var x) new-depvars)))
1043                graph)))
1044     (if changed?
1045       (transitive-closure new-graph)
1046       new-graph)))
1047
1048 (define (gnode-find-depvars var graph)
1049   (if (null? graph)
1050     (varset-empty)
1051     (let ((node (car graph)))
1052       (if (eq? (gnode-var node) var)
1053         (gnode-depvars node)
1054         (gnode-find-depvars var (cdr graph))))))
1055 )
1056
1057 (define (gnodes-remove graph gnodes)
1058   (if (null? graph)
1059     '()
1060     (let ((node (car graph)))
1061       (if (memq node gnodes)
1062         (gnodes-remove (cdr graph) gnodes)
1063         (cons node (gnodes-remove (cdr graph) gnodes))))))
1064
1065 (define (topological-sort graph) ; topological sort fixed to handle cycles
1066   (if (null? graph)
1067     '()
1068     (let ((to-remove (or (remove-no-depvars graph) (remove-cycle graph))))
1069       (let ((vars (list->varset (map gnode-var to-remove))))
1070         (cons vars
1071               (topological-sort
1072                 (map (lambda (x)
1073                        (make-gnode
1074                          (gnode-var x)
1075                          (varset-difference (gnode-depvars x) vars)))
1076                      (gnodes-remove graph to-remove))))))))
1077
1078 (define (remove-no-depvars graph)
1079   (let ((nodes-with-no-depvars
1080          (keep (lambda (x) (varset-empty? (gnode-depvars x))) graph)))
1081     (if (null? nodes-with-no-depvars)
1082       #f
1083       nodes-with-no-depvars)))
1084
1085 (define (remove-cycle graph)
1086   (define (remove l)
1087     (let* ((node (car l))
1088            (depvars (gnode-depvars node)))
1089       (define (equal-depvars? x) (varset-equal? (gnode-depvars x) depvars))
1090       (define (member-depvars? x) (varset-member? (gnode-var x) depvars))
1091       (if (member-depvars? node)
1092         (let ((depvar-graph (keep member-depvars? graph)))
1093           (if (every? equal-depvars? depvar-graph)
1094             depvar-graph
1095             (remove (cdr l))))
1096         (remove (cdr l)))))
1097   (remove graph))
1098
1099 ;;;----------------------------------------------------------------------------
1100 ;;
1101 ;; SET manipulation stuff
1102 ;; ----------------------
1103
1104 ;; Parse tree sets
1105
1106 (define ptset-empty-set
1107   (vector '() '() '() '() '() '() '() '() '() '() '()))
1108
1109 (define (ptset-empty)              ; return the empty set
1110   (vector '() '() '() '() '() '() '() '() '() '() '()))
1111
1112 (define (ptset->list set)          ; convert set to list
1113   (apply append (vect->list set)))
1114
1115 (define (ptset-size set)           ; return cardinality of set
1116   (apply + (map list-length (vect->list set))))
1117
1118 (define (ptset-empty? set)         ; is 'x' the empty set?
1119   (equal? set ptset-empty-set))
1120
1121 (define (ptset-member? x set)      ; is 'x' a member of the 'set'?
1122   (let* ((hash-entry (modulo (node-stamp x) 11))
1123          (lst (vector-ref set hash-entry)))
1124     (memq x lst)))
1125
1126 (define (ptset-adjoin set x)       ; add the element 'x' to the 'set'
1127   (let* ((hash-entry (modulo (node-stamp x) 11))
1128          (lst (vector-ref set hash-entry)))
1129     (if (not (memq x lst))
1130       (vector-set! set hash-entry (cons x lst)))
1131     set))
1132
1133 (define (ptset-every? pred? set)   ; is 'pred?' true of every element
1134
1135   (define (every? pred? lst)
1136     (or (null? lst)
1137         (and (pred? (car lst))
1138              (every? pred? (cdr lst)))))
1139
1140   (every? (lambda (lst) (every? pred? lst)) (vect->list set)))
1141
1142 (define (ptset-remove set x)       ; remove the element 'x' from 'set'
1143   (let* ((hash-entry (modulo (node-stamp x) 11))
1144          (lst (vector-ref set hash-entry)))
1145     (cond ((null? lst) set)
1146           ((eq? x (car lst))
1147            (vector-set! set hash-entry (cdr lst))
1148            set)
1149           (else
1150            (let loop ((lst lst) (rest (cdr lst)))
1151              (cond ((null? rest)
1152                     set)
1153                    ((eq? (car rest) x)
1154                     (set-cdr! lst (cdr rest))
1155                     set)
1156                    (else
1157                     (loop rest (cdr rest)))))))))
1158
1159 ;; Variable sets
1160
1161 (define (varset-reverse-append! xrev y)
1162   (if (null? xrev)
1163     (varset-wrap y)
1164     (let ((temp (cdr xrev)))
1165       (set-cdr! xrev y)
1166       (varset-reverse-append! temp xrev))))
1167
1168 (define (varset-wrap lst) ; when we know it is a sorted list
1169   (cons #f lst))
1170
1171 (define (varset-unwrap set)
1172   (cdr set))
1173
1174 (define (varset-empty)              ; return the empty set
1175   (varset-wrap '()))
1176
1177 (define (varset-singleton x)        ; create a set containing only 'x'
1178   (varset-wrap (list x)))
1179
1180 (define (list->varset lst)          ; convert list to set
1181   (if (null? lst)
1182     (varset-empty)
1183     (let loop ((last (car lst)) (next (cdr lst)))
1184       (cond ((null? next)
1185              (varset-wrap lst))             ; sorted
1186             ((varset-< last (car next))
1187              (loop (car next) (cdr next)))  ; OK so far
1188             (else
1189              (do ((lst lst (cdr lst))
1190                   (result '() (cons (varset-singleton (car lst)) result)))
1191                  ((null? lst) (varset-union-multi result))))))))   ; crude but effective sort
1192
1193 (define (varset->list set)          ; convert set to list
1194   (varset-unwrap set))
1195
1196 (define (varset-size set)           ; return cardinality of set
1197   (let ((v (car set)))
1198     (if v
1199       (vector-length v)
1200       (list-length (varset-unwrap set)))))
1201
1202 (define (varset-empty? set)         ; is 'x' the empty set?
1203   (null? (varset-unwrap set)))
1204
1205 (define (varset-< x y)
1206   (< (var-stamp x) (var-stamp y)))
1207
1208 (define (varset-member? x set)  ; is 'x' a member of the 'set'?
1209   (if (not (car set))
1210     (set-car! set (list->vect (cdr set))))
1211   (let ((v (car set)))
1212     (let loop ((f 0) (l (- (vector-length v) 1)))
1213       (and (<= f l)
1214            (let* ((index (quotient (+ f l) 2))
1215                   (y (vector-ref v index)))
1216              (or (eq? x y)
1217                  (if (varset-< x y)
1218                    (loop f (- index 1))
1219                    (loop (+ index 1) l))))))))
1220
1221 (define (varset-adjoin set x)       ; add the element 'x' to the 'set'
1222   (let loop ((s (varset-unwrap set)) (rev '()))
1223     (cond ((or (null? s)
1224                (varset-< x (car s)))
1225            (varset-reverse-append! rev (cons x s)))
1226           ((eq? (car s) x)
1227            set)
1228           (else
1229            (loop (cdr s) (cons (car s) rev))))))
1230
1231 (define (varset-remove set x)       ; remove the element 'x' from 'set'
1232   (let loop ((s (varset-unwrap set)) (rev '()))
1233     (cond ((or (null? s)
1234                (varset-< x (car s)))
1235            set)
1236           ((eq? (car s) x)
1237            (varset-reverse-append! rev (cdr s)))
1238           (else
1239            (loop (cdr s) (cons (car s) rev))))))
1240
1241 (define (varset-equal? s1 s2)       ; are 's1' and 's2' equal sets?
1242   (let loop ((s1 (varset-unwrap s1)) (s2 (varset-unwrap s2)))
1243     (cond ((null? s1)
1244            (null? s2))
1245           ((null? s2)
1246            #f)
1247           (else
1248            (and (eq? (car s1) (car s2))
1249                 (loop (cdr s1) (cdr s2)))))))
1250
1251 (define (varset-difference s1 s2)
1252   (let loop ((s1 (varset-unwrap s1)) (s2 (varset-unwrap s2)) (revresult '()))
1253     (if (or (null? s1) (null? s2))
1254       (varset-reverse-append! revresult s1)
1255       (let ((x (car s1))
1256             (y (car s2)))
1257         (cond ((varset-< x y)
1258                (loop (cdr s1) s2 (cons x revresult)))
1259               ((eq? x y)
1260                (loop (cdr s1) (cdr s2) revresult))
1261               (else
1262                (loop s1 (cdr s2) revresult)))))))
1263
1264 (define (varset-union s1 s2)    ; return union of sets
1265   (let loop ((s1 (varset-unwrap s1)) (s2 (varset-unwrap s2)) (revresult '()))
1266     (cond ((null? s1)
1267            (varset-reverse-append! revresult s2))
1268           ((null? s2)
1269            (varset-reverse-append! revresult s1))
1270           (else
1271            (let ((x (car s1))
1272                  (y (car s2)))
1273              (cond ((eq? x y)
1274                     (loop (cdr s1) (cdr s2) (cons x revresult)))
1275                    ((varset-< x y)
1276                     (loop (cdr s1) s2 (cons x revresult)))
1277                    (else
1278                     (loop s1 (cdr s2) (cons y revresult)))))))))
1279
1280 (define (varset-intersection s1 s2) ; return intersection of sets
1281   (let loop ((s1 (varset-unwrap s1)) (s2 (varset-unwrap s2)) (revresult '()))
1282     (if (or (null? s1) (null? s2))
1283       (varset-reverse-append! revresult '())
1284       (let ((x (car s1))
1285             (y (car s2)))
1286         (cond ((eq? x y)
1287                (loop (cdr s1) (cdr s2) (cons x revresult)))
1288               ((varset-< x y)
1289                (loop (cdr s1) s2 revresult))
1290               (else
1291                (loop s1 (cdr s2) revresult)))))))
1292
1293 (define (varset-intersects? s1 s2) ; do sets 's1' and 's2' intersect?
1294   (let loop ((s1 (varset-unwrap s1)) (s2 (varset-unwrap s2)))
1295     (if (or (null? s1) (null? s2))
1296       #f
1297       (let ((x (car s1)) (y (car s2)))
1298         (cond ((eq? x y)
1299                #t)
1300               ((varset-< x y)
1301                (loop (cdr s1) s2))
1302               (else
1303                (loop s1 (cdr s2))))))))
1304
1305 (define (varset-union-multi sets)
1306   (cond ((null? sets)
1307          (varset-empty))
1308         ((null? (cdr sets))
1309          (car sets))
1310         (else
1311          (let loop ((sets sets) (newsets '()))
1312            (cond ((null? sets)
1313                   (varset-union-multi newsets))
1314                  ((null? (cdr sets))
1315                   (varset-union-multi (cons (car sets) newsets)))
1316                  (else
1317                   (loop (cddr sets) (cons (varset-union (car sets) (cadr sets)) newsets))))))))
1318
1319 (define (n-ary function first rest)
1320   (if (null? rest)
1321     first
1322     (n-ary function (function first (car rest)) (cdr rest))))
1323
1324 ;;;----------------------------------------------------------------------------
1325 ;;
1326 ;; QUEUE manipulation stuff
1327 ;; ------------------------
1328
1329 (define (list->queue list)    ; convert list to queue
1330   (cons list (if (pair? list) (last-pair list) '())))
1331
1332 (define (queue->list queue)   ; convert queue to list
1333   (car queue))
1334
1335 (define (queue-empty)         ; the empty queue
1336   (cons '() '()))
1337
1338 (define (queue-empty? queue)  ; is the queue empty?
1339   (null? (car queue)))
1340
1341 (define (queue-get! queue)    ; remove the first element of the queue
1342   (if (null? (car queue))
1343     (compiler-internal-error "queue-get!, queue is empty")
1344     (let ((x (caar queue)))
1345       (set-car! queue (cdar queue))
1346       (if (null? (car queue)) (set-cdr! queue '()))
1347       x)))
1348
1349 (define (queue-put! queue x)  ; add an element to the end of the queue
1350   (let ((entry (cons x '())))
1351     (if (null? (car queue))
1352       (set-car! queue entry)
1353       (set-cdr! (cdr queue) entry))
1354     (set-cdr! queue entry)
1355     x))
1356
1357 ;;;============================================================================
1358 )