1 ;;;============================================================================
3 ;;; File: "_utils.scm", Time-stamp: <2008-01-10 15:50:42 feeley>
5 ;;; Copyright (c) 1994-2007 by Marc Feeley, All Rights Reserved.
9 (include-adt "_envadt.scm")
10 (include-adt "_gvmadt.scm")
11 (include-adt "_ptreeadt.scm")
12 (include-adt "_sourceadt.scm")
15 ;;;----------------------------------------------------------------------------
20 (define (make-counter next)
23 (set! next (+ next 1))
26 (define (for-each-index proc lst)
27 (let loop ((lst lst) (i 0))
31 (loop (cdr lst) (+ i 1))))))
33 (define (pos-in-list x l)
34 (let loop ((l l) (i 0))
35 (cond ((not (pair? l)) #f)
37 (else (loop (cdr l) (+ i 1))))))
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))))))
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))))))
52 (let loop ((l l) (n n))
54 (cons (car l) (loop (cdr l) (- n 1)))
58 (let loop ((l l) (n n))
60 (loop (cdr l) (- n 1))
63 (define (pair-up l1 l2)
66 (cons (cons (car l1) (car l2)) (pair (cdr l1) (cdr l2)))
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)))))
81 (define (every? pred? lst)
83 (and (pred? (car lst))
84 (every? pred? (cdr lst)))))
87 (cond ((null? lst) '())
88 ((eq? (car lst) x) (cdr lst))
89 (else (cons (car lst) (remq x (cdr lst))))))
91 (define (sort-list l <?)
99 (let ((e1 (car l1)) (e2 (car l2)))
101 (cons e1 (merge (cdr l1) l2))
102 (cons e2 (merge l1 (cdr l2))))))))
105 (if (or (null? l) (null? (cdr l)))
107 (cons (car l) (split (cddr l)))))
109 (if (or (null? l) (null? (cdr l)))
111 (let* ((l1 (mergesort (split l)))
112 (l2 (mergesort (split (cdr l)))))
117 (define (list->vect l)
118 (let* ((n (list-length l))
120 (let loop ((l l) (i 0))
123 (vector-set! v i (car l))
124 (loop (cdr l) (+ i 1)))
127 (define (vect->list v)
128 (let loop ((l '()) (i (- (vector-length v) 1)))
131 (loop (cons (vector-ref v i) l) (- i 1)))))
133 (define (list->str l)
134 (let* ((n (list-length l))
136 (let loop ((l l) (i 0))
139 (string-set! s i (car l))
140 (loop (cdr l) (+ i 1)))
143 (define (str->list s)
144 (let loop ((l '()) (i (- (string-length s) 1)))
147 (loop (cons (string-ref s i) l) (- i 1)))))
149 (define (make-stretchable-vector init)
152 (define (stretchable-vector-length sv)
153 (vector-length (vector-ref sv 0)))
155 (define (stretchable-vector-ref sv i)
156 (let* ((v (vector-ref sv 0))
157 (len (vector-length v)))
162 (define (stretchable-vector-set! sv i x)
163 (let* ((v (vector-ref sv 0))
164 (len (vector-length v)))
170 (+ (max i (quotient (* len 3) 2)) 1) ; make 50% bigger at least
172 (vector-set! sv 0 new-v)
173 (vector-set! new-v i x)))))
175 (define (stretch-vector v n init)
176 (let ((len (vector-length v))
177 (new-v (make-vector n)))
181 (vector-set! new-v i (vector-ref v i))
186 (vector-set! new-v i init)
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)))
197 (vector-set! v2 i (vector-ref v1 i))
199 (vector v2 (vector-ref sv 1))))))
201 (define (stretchable-vector-for-each proc sv)
202 (let* ((v (vector-ref sv 0))
203 (n (vector-length v)))
207 (proc (vector-ref v i) i)
210 (define (bits-and x y) ; bitwise and of x and y, assumes x and y >= 0
216 (let ((z (* (band (quotient x 2) (quotient y 2)) 2)))
217 (if (and (odd? x) (odd? y))
223 (define (bits-or x y) ; bitwise or of x and y, assumes x and y >= 0
229 (let ((z (* (bor (quotient x 2) (quotient y 2)) 2)))
230 (if (or (odd? x) (odd? y))
236 (define (bits-shl x y) ; shift x left by y bits, assumes x>=0 and y>=0
240 (shl (* x 2) (- y 1))
245 (define (bits-shr x y) ; shift x right by y bits, assumes x>=0 and y>=0
249 (shr (quotient x 2) (- y 1))
254 ;;;----------------------------------------------------------------------------
256 ;; Exception processing
257 ;; --------------------
259 (define (with-exception-handling proc)
260 (let ((old-exception-handler throw-to-exception-handler))
262 (call-with-current-continuation
264 (set! throw-to-exception-handler cont)
266 (set! throw-to-exception-handler old-exception-handler)
269 (define (throw-to-exception-handler val)
270 (fatal-err "Internal error, no exception handler at this point" val))
272 ;;;----------------------------------------------------------------------------
274 ;; Compiler error processing
275 ;; -------------------------
277 (define (compiler-error msg . args)
278 (display "*** ERROR -- ")
280 (for-each (lambda (x) (display " ") (write x)) args)
284 (define (compiler-user-error loc msg . args)
285 (display "*** ERROR") (locat-show " IN " loc) (display " -- ")
287 (for-each (lambda (x) (display " ") (write x)) args)
291 (define (compiler-user-warning loc msg . args)
292 (if warnings-requested?
294 (display "*** WARNING") (locat-show " IN " loc) (display " -- ")
296 (for-each (lambda (x) (display " ") (write x)) args)
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)
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)
313 (define (compiler-abort)
314 (throw-to-exception-handler #f))
316 (define warnings-requested? #f)
317 (set! warnings-requested? #t)
319 ;;;----------------------------------------------------------------------------
321 ;; Transitive closure and topological sorting.
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))
327 (define (transitive-closure graph)
329 (define (closure depvars)
332 (map (lambda (var) (gnode-find-depvars var graph))
333 (varset->list depvars)))))
336 (let ((new-depvars (closure (gnode-depvars x))))
337 (if (not (= (varset-size new-depvars)
338 (varset-size (gnode-depvars x))))
340 (make-gnode (gnode-var x) new-depvars)))
343 (transitive-closure new-graph)
346 (define (gnode-find-depvars var graph)
349 (let ((node (car graph)))
350 (if (eq? (gnode-var node) var)
352 (gnode-find-depvars var (cdr graph))))))
354 (define (gnodes-remove graph gnodes)
357 (let ((node (car graph)))
358 (if (memq node gnodes)
359 (gnodes-remove (cdr graph) gnodes)
360 (cons node (gnodes-remove (cdr graph) gnodes))))))
362 (define (topological-sort graph) ; topological sort fixed to handle cycles
365 (let ((to-remove (or (remove-no-depvars graph) (remove-cycle graph))))
366 (let ((vars (list->varset (map gnode-var to-remove))))
372 (varset-difference (gnode-depvars x) vars)))
373 (gnodes-remove graph to-remove))))))))
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)
380 nodes-with-no-depvars)))
382 (define (remove-cycle graph)
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)
396 ;;;----------------------------------------------------------------------------
398 ;; SET manipulation stuff
399 ;; ----------------------
403 (define (ptset-empty) ; return the empty set
406 (define (ptset->list set) ; convert set to list
409 (define (ptset-size set) ; return cardinality of set
412 (define (ptset-empty? set) ; is 'x' the empty set?
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)))))
420 (define (ptset-adjoin set x) ; add the element 'x' to the 'set'
421 (if (ptset-member? x set) set (cons x set)))
423 (define (ptset-every? pred? set) ; is 'pred?' true of every element
425 (and (pred? (car set))
426 (ptset-every? pred? (cdr set)))))
428 (define (ptset-remove set x) ; remove the element 'x' from 'set'
434 (cons (car set) (ptset-remove (cdr set) x)))))
438 (define (varset-empty) ; return the empty set
441 (define (varset-singleton x) ; create a set containing only 'x'
444 (define (list->varset lst) ; convert list to set
447 (define (varset->list set) ; convert set to list
450 (define (varset-size set) ; return cardinality of set
453 (define (varset-empty? set) ; is 'x' the empty set?
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)))))
461 (define (varset-adjoin set x) ; add the element 'x' to the 'set'
462 (if (varset-member? x set) set (cons x set)))
464 (define (varset-remove set x) ; remove the element 'x' from 'set'
470 (cons (car set) (varset-remove (cdr set) x)))))
472 (define (varset-equal? s1 s2) ; are 's1' and 's2' equal sets?
473 (and (varset-subset? s1 s2)
474 (varset-subset? s2 s1)))
476 (define (varset-subset? s1 s2) ; is 's1' a subset of 's2'?
479 ((varset-member? (car s1) s2)
480 (varset-subset? (cdr s1) s2))
484 (define (varset-difference set1 set2) ; return difference of sets
487 ((varset-member? (car set1) set2)
488 (varset-difference (cdr set1) set2))
490 (cons (car set1) (varset-difference (cdr set1) set2)))))
492 (define (varset-union set1 set2) ; return union of sets
493 (define (union s1 s2)
496 ((varset-member? (car s1) s2)
499 (cons (car s1) (union (cdr s1) s2)))))
500 (if (varset-smaller? set1 set2)
504 (define (varset-intersection set1 set2) ; return intersection of sets
505 (define (intersection s1 s2)
508 ((varset-member? (car s1) s2)
509 (cons (car s1) (intersection (cdr s1) s2)))
511 (intersection (cdr s1) s2))))
512 (if (varset-smaller? set1 set2)
513 (intersection set1 set2)
514 (intersection set2 set1)))
516 (define (varset-intersects? set1 set2) ; do sets 'set1' and 'set2' intersect?
517 (not (varset-empty? (varset-intersection set1 set2))))
519 (define (varset-smaller? set1 set2)
524 (varset-smaller? (cdr set1) (cdr set2)))))
526 (define (varset-union-multi sets)
529 (n-ary varset-union (car sets) (cdr sets))))
531 (define (n-ary function first rest)
534 (n-ary function (function first (car rest)) (cdr rest))))
536 ;;;----------------------------------------------------------------------------
538 ;; QUEUE manipulation stuff
539 ;; ------------------------
541 (define (list->queue list) ; convert list to queue
542 (cons list (if (pair? list) (last-pair list) '())))
544 (define (queue->list queue) ; convert queue to list
547 (define (queue-empty) ; the empty queue
550 (define (queue-empty? queue) ; is the queue empty?
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 '()))
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)
569 ;;;============================================================================
572 (define (append-lists lst)
574 (define (append1 lst)
575 (if (pair? (cdr lst))
576 (append2 (car lst) (append1 (cdr lst)))
579 (define (append2 lst1 lst2)
581 (let ((result (cons (car lst1) '())))
583 (let loop ((end result) (lst1 (cdr lst1)))
585 (let ((tail (cons (car lst1) '())))
587 (loop tail (cdr lst1)))
597 (begin;**************brad
598 ;(##include "../gsc/_ptree1adt.scm")
599 ;(##include "../gsc/_envadt.scm")
601 ;;;----------------------------------------------------------------------------
606 (define (reverse-append! xrev y)
609 (let ((temp (cdr xrev)))
611 (reverse-append! temp xrev))))
613 (define (list-length lst)
614 (let loop ((n 0) (lst lst))
616 (loop (+ n 1) (cdr lst))
619 (define (make-counter next)
622 (set! next (+ next 1))
625 (define (for-each-index proc lst)
626 (let loop ((lst lst) (i 0))
630 (loop (cdr lst) (+ i 1))))))
632 (define (pos-in-list x l)
633 (let loop ((l l) (i 0))
634 (cond ((not (pair? l)) #f)
636 (else (loop (cdr l) (+ i 1))))))
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))))))
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))))))
651 (let loop ((l l) (n n))
653 (cons (car l) (loop (cdr l) (- n 1)))
657 (let loop ((l l) (n n))
659 (loop (cdr l) (- n 1))
662 (define (pair-up l1 l2)
665 (cons (cons (car l1) (car l2)) (pair (cdr l1) (cdr l2)))
669 (define (last-pair l)
675 (define (keep keep? lst)
676 (let loop ((lst lst) (head '()))
678 (reverse-append! head lst))
680 (loop (cdr lst) (cons (car lst) head)))
682 (loop (cdr lst) head)))))
684 (define (every? pred? lst)
686 (and (pred? (car lst))
687 (every? pred? (cdr lst)))))
690 (let loop ((l lst) (head '()))
691 (cond ((null? l) ; didn't find x, so just return lst
694 (reverse-append! head (cdr l)))
696 (loop (cdr l) (cons (car l) head))))))
698 (define (sort-list l <?)
700 (define (mergesort l)
702 (define (merge l1 l2)
703 (cond ((null? l1) l2)
706 (let ((e1 (car l1)) (e2 (car l2)))
708 (cons e1 (merge (cdr l1) l2))
709 (cons e2 (merge l1 (cdr l2))))))))
712 (if (or (null? l) (null? (cdr l)))
714 (cons (car l) (split (cddr l)))))
716 (if (or (null? l) (null? (cdr l)))
718 (let* ((l1 (mergesort (split l)))
719 (l2 (mergesort (split (cdr l)))))
724 (define (list->vect l)
725 (let* ((n (list-length l))
727 (let loop ((l l) (i 0))
730 (vector-set! v i (car l))
731 (loop (cdr l) (+ i 1)))
734 (define (vect->list v)
735 (let loop ((l '()) (i (- (vector-length v) 1)))
738 (loop (cons (vector-ref v i) l) (- i 1)))))
740 (define (list->str l)
741 (let* ((n (list-length l))
743 (let loop ((l l) (i 0))
746 (string-set! s i (car l))
747 (loop (cdr l) (+ i 1)))
750 (define (str->list s)
751 (let loop ((l '()) (i (- (string-length s) 1)))
754 (loop (cons (string-ref s i) l) (- i 1)))))
756 ;;;----------------------------------------------------------------------------
758 ;; Strechable vectors
759 ;; ------------------
761 (define (make-stretchable-vector init)
764 (define (stretchable-vector-length sv)
765 (vector-length (vector-ref sv 0)))
767 (define (stretchable-vector-ref sv i)
768 (let* ((v (vector-ref sv 0))
769 (len (vector-length v)))
774 (define (stretchable-vector-set! sv i x)
775 (let* ((v (vector-ref sv 0))
776 (len (vector-length v)))
782 (+ (max i (quotient (* len 3) 2)) 1) ; make 50% bigger at least
784 (vector-set! sv 0 new-v)
785 (vector-set! new-v i x)))))
787 (define (stretch-vector v n init)
788 (let ((len (vector-length v))
789 (new-v (make-vector n)))
793 (vector-set! new-v i (vector-ref v i))
798 (vector-set! new-v i init)
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)))
809 (vector-set! v2 i (vector-ref v1 i))
811 (vector v2 (vector-ref sv 1))))))
813 (define (stretchable-vector-for-each proc sv)
814 (let* ((v (vector-ref sv 0))
815 (n (vector-length v)))
819 (proc (vector-ref v i) i)
822 ;;;----------------------------------------------------------------------------
827 (define (make-ordered-table test)
828 (vector (make-table 'test: test)
829 (make-stretchable-vector #f)
832 (define (ordered-table-length ot)
835 (define (ordered-table-index ot key)
836 (table-ref (vector-ref ot 0) key #f))
838 (define (ordered-table-lookup ot key)
839 (let ((i (table-ref (vector-ref ot 0) key #f)))
841 (cdr (stretchable-vector-ref (vector-ref ot 1) i))
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))
852 (define (ordered-table->list ot)
853 (let loop ((i (- (vector-ref ot 2) 1)) (lst '()))
857 (cons (stretchable-vector-ref (vector-ref ot 1) i) lst)))))
859 ;;;----------------------------------------------------------------------------
861 ;; Bitwise operations
862 ;; ------------------
864 (define (bits-and x y) ; bitwise and of x and y, assumes x and y >= 0
870 (let ((z (* (band (quotient x 2) (quotient y 2)) 2)))
871 (if (and (odd? x) (odd? y))
877 (define (bits-or x y) ; bitwise or of x and y, assumes x and y >= 0
883 (let ((z (* (bor (quotient x 2) (quotient y 2)) 2)))
884 (if (or (odd? x) (odd? y))
890 (define (bits-shl x y) ; shift x left by y bits, assumes x>=0 and y>=0
894 (shl (* x 2) (- y 1))
899 (define (bits-shr x y) ; shift x right by y bits, assumes x>=0 and y>=0
903 (shr (quotient x 2) (- y 1))
908 ;;;----------------------------------------------------------------------------
910 ;; Exception processing
911 ;; --------------------
913 (define (with-exception-handling proc)
914 (let ((old-exception-handler throw-to-exception-handler))
916 (call-with-current-continuation
918 (set! throw-to-exception-handler cont)
920 (set! throw-to-exception-handler old-exception-handler)
923 (define (throw-to-exception-handler val)
924 (fatal-err "Internal error, no exception handler at this point" val))
926 ;;;----------------------------------------------------------------------------
928 ;; Compiler error processing
929 ;; -------------------------
931 (define (compiler-error msg . args)
932 (display "*** ERROR -- ")
934 (for-each (lambda (x) (display " ") (write x)) args)
938 (define (compiler-user-error loc msg . args)
939 (display "*** ERROR") (locat-show " IN " loc) (display " -- ")
941 (for-each (lambda (x) (display " ") (write x)) args)
945 (define (compiler-user-warning loc msg . args)
946 (if warnings-requested?
948 (display "*** WARNING") (locat-show " IN " loc) (display " -- ")
950 (for-each (lambda (x) (display " ") (write x)) args)
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)
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)
967 (define (compiler-abort)
968 (throw-to-exception-handler #f))
970 (define warnings-requested? #f)
971 (set! warnings-requested? #t)
973 ;;;----------------------------------------------------------------------------
975 ;; Transitive closure and topological sorting.
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))
981 (define (transitive-closure graph)
985 (lambda (x y) (varset-< (gnode-var x) (gnode-var y))))))
987 (vector-length graph-vector)))
988 (let loop ((graph-vector graph-vector))
991 (define (closure depvars)
994 (map (lambda (var) (gnode-find-depvars var graph-vector))
995 (varset->list depvars)))))
997 (let ((new-graph-vector
998 (let ((result (make-vector graph-size)))
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))))
1009 (make-gnode (gnode-var x) new-depvars))))))))
1011 (loop new-graph-vector)
1012 (vect->list new-graph-vector)))))))
1014 (define (gnode-find-depvars var graph-vector)
1015 (let loop ((f 0) (l (- (vector-length graph-vector) 1)))
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))
1025 (loop (+ i 1) l)))))))
1029 (define (transitive-closure graph)
1030 (define changed? #f)
1031 (define (closure depvars)
1034 (map (lambda (var) (gnode-find-depvars var graph))
1035 (varset->list depvars)))))
1038 (let ((new-depvars (closure (gnode-depvars x))))
1039 (if (not (= (varset-size new-depvars)
1040 (varset-size (gnode-depvars x))))
1042 (make-gnode (gnode-var x) new-depvars)))
1045 (transitive-closure new-graph)
1048 (define (gnode-find-depvars var graph)
1051 (let ((node (car graph)))
1052 (if (eq? (gnode-var node) var)
1053 (gnode-depvars node)
1054 (gnode-find-depvars var (cdr graph))))))
1057 (define (gnodes-remove graph gnodes)
1060 (let ((node (car graph)))
1061 (if (memq node gnodes)
1062 (gnodes-remove (cdr graph) gnodes)
1063 (cons node (gnodes-remove (cdr graph) gnodes))))))
1065 (define (topological-sort graph) ; topological sort fixed to handle cycles
1068 (let ((to-remove (or (remove-no-depvars graph) (remove-cycle graph))))
1069 (let ((vars (list->varset (map gnode-var to-remove))))
1075 (varset-difference (gnode-depvars x) vars)))
1076 (gnodes-remove graph to-remove))))))))
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)
1083 nodes-with-no-depvars)))
1085 (define (remove-cycle graph)
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)
1099 ;;;----------------------------------------------------------------------------
1101 ;; SET manipulation stuff
1102 ;; ----------------------
1106 (define ptset-empty-set
1107 (vector '() '() '() '() '() '() '() '() '() '() '()))
1109 (define (ptset-empty) ; return the empty set
1110 (vector '() '() '() '() '() '() '() '() '() '() '()))
1112 (define (ptset->list set) ; convert set to list
1113 (apply append (vect->list set)))
1115 (define (ptset-size set) ; return cardinality of set
1116 (apply + (map list-length (vect->list set))))
1118 (define (ptset-empty? set) ; is 'x' the empty set?
1119 (equal? set ptset-empty-set))
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)))
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)))
1133 (define (ptset-every? pred? set) ; is 'pred?' true of every element
1135 (define (every? pred? lst)
1137 (and (pred? (car lst))
1138 (every? pred? (cdr lst)))))
1140 (every? (lambda (lst) (every? pred? lst)) (vect->list set)))
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)
1147 (vector-set! set hash-entry (cdr lst))
1150 (let loop ((lst lst) (rest (cdr lst)))
1154 (set-cdr! lst (cdr rest))
1157 (loop rest (cdr rest)))))))))
1161 (define (varset-reverse-append! xrev y)
1164 (let ((temp (cdr xrev)))
1166 (varset-reverse-append! temp xrev))))
1168 (define (varset-wrap lst) ; when we know it is a sorted list
1171 (define (varset-unwrap set)
1174 (define (varset-empty) ; return the empty set
1177 (define (varset-singleton x) ; create a set containing only 'x'
1178 (varset-wrap (list x)))
1180 (define (list->varset lst) ; convert list to set
1183 (let loop ((last (car lst)) (next (cdr lst)))
1185 (varset-wrap lst)) ; sorted
1186 ((varset-< last (car next))
1187 (loop (car next) (cdr next))) ; OK so far
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
1193 (define (varset->list set) ; convert set to list
1194 (varset-unwrap set))
1196 (define (varset-size set) ; return cardinality of set
1197 (let ((v (car set)))
1200 (list-length (varset-unwrap set)))))
1202 (define (varset-empty? set) ; is 'x' the empty set?
1203 (null? (varset-unwrap set)))
1205 (define (varset-< x y)
1206 (< (var-stamp x) (var-stamp y)))
1208 (define (varset-member? x set) ; is 'x' a member of the 'set'?
1210 (set-car! set (list->vect (cdr set))))
1211 (let ((v (car set)))
1212 (let loop ((f 0) (l (- (vector-length v) 1)))
1214 (let* ((index (quotient (+ f l) 2))
1215 (y (vector-ref v index)))
1218 (loop f (- index 1))
1219 (loop (+ index 1) l))))))))
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)))
1229 (loop (cdr s) (cons (car s) rev))))))
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)))
1237 (varset-reverse-append! rev (cdr s)))
1239 (loop (cdr s) (cons (car s) rev))))))
1241 (define (varset-equal? s1 s2) ; are 's1' and 's2' equal sets?
1242 (let loop ((s1 (varset-unwrap s1)) (s2 (varset-unwrap s2)))
1248 (and (eq? (car s1) (car s2))
1249 (loop (cdr s1) (cdr s2)))))))
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)
1257 (cond ((varset-< x y)
1258 (loop (cdr s1) s2 (cons x revresult)))
1260 (loop (cdr s1) (cdr s2) revresult))
1262 (loop s1 (cdr s2) revresult)))))))
1264 (define (varset-union s1 s2) ; return union of sets
1265 (let loop ((s1 (varset-unwrap s1)) (s2 (varset-unwrap s2)) (revresult '()))
1267 (varset-reverse-append! revresult s2))
1269 (varset-reverse-append! revresult s1))
1274 (loop (cdr s1) (cdr s2) (cons x revresult)))
1276 (loop (cdr s1) s2 (cons x revresult)))
1278 (loop s1 (cdr s2) (cons y revresult)))))))))
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 '())
1287 (loop (cdr s1) (cdr s2) (cons x revresult)))
1289 (loop (cdr s1) s2 revresult))
1291 (loop s1 (cdr s2) revresult)))))))
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))
1297 (let ((x (car s1)) (y (car s2)))
1303 (loop s1 (cdr s2))))))))
1305 (define (varset-union-multi sets)
1311 (let loop ((sets sets) (newsets '()))
1313 (varset-union-multi newsets))
1315 (varset-union-multi (cons (car sets) newsets)))
1317 (loop (cddr sets) (cons (varset-union (car sets) (cadr sets)) newsets))))))))
1319 (define (n-ary function first rest)
1322 (n-ary function (function first (car rest)) (cdr rest))))
1324 ;;;----------------------------------------------------------------------------
1326 ;; QUEUE manipulation stuff
1327 ;; ------------------------
1329 (define (list->queue list) ; convert list to queue
1330 (cons list (if (pair? list) (last-pair list) '())))
1332 (define (queue->list queue) ; convert queue to list
1335 (define (queue-empty) ; the empty queue
1338 (define (queue-empty? queue) ; is the queue empty?
1339 (null? (car queue)))
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 '()))
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)
1357 ;;;============================================================================