import

original commit: f06c1626f7d4154a72427096b2993d49db72ceb1

collects/mrdemo/keymap.ss

@@ -0,0 +1,16 @@
+; We'll use the same function as both a keyboard and mouse event
+;  handler. If it's a mouse event, we only want to insert something
+;  on the button-down part
+(define insert-star
+  (lambda (edit event)
+    (if (or (not (is-a? event wx:mouse-event%))
+	    (send event button-down?))
+	(send edit insert "*"))
+    #t))
+
+(let ((kmap (send mred:console-edit get-keymap)))
+	(send kmap add-key-function "insert-star" insert-star)	
+	(send kmap add-mouse-function "insert-star" insert-star)	
+	(send kmap map-function "c:." "insert-star")
+	(send kmap map-function "ESC;rightbutton" "insert-star"))
+

collects/mrdemo/load.ss

@@ -0,0 +1,2 @@
+
+(load "demo.ss")

collects/mrdemo/mines.ss

@@ -0,0 +1,379 @@
+
+(require-library "macro.ss")
+
+(define TILE-HW 24)
+(define WIDTH 16)
+(define HEIGHT 16)
+(define BOMB-COUNT 30)
+
+; Temporary
+(define FRDW 12)
+(define FRDH 39)
+(define PANEL-HEIGHT 50)
+(define TIME-WIDTH 600)
+(define COUNT-WIDTH 600)
+
+(define DIGIT-COLOR-NAMES
+  ; 0th is background; 8th is foreground
+  (vector "LIGHT GREY" "BLUE" "GREEN" "RED" "PURPLE" "ORANGE" "YELLOW" "BROWN" "BLACK"))
+
+(define DIGIT-COLORS
+  (build-vector 9 (lambda (i)
+		    (send wx:the-colour-database find-colour 
+			  (vector-ref DIGIT-COLOR-NAMES i)))))
+
+(define BG-COLOR (vector-ref DIGIT-COLORS 0))
+(define FG-COLOR (vector-ref DIGIT-COLORS 8))
+(define EXPLODE-COLOR (send wx:the-colour-database find-colour "RED"))
+
+(define BG-PEN (send wx:the-pen-list find-or-create-pen BG-COLOR 1 wx:const-solid))
+(define FG-PEN (send wx:the-pen-list find-or-create-pen FG-COLOR 1 wx:const-solid))
+
+(define step-while
+  (opt-lambda (first test until step f [accum void] [init (void)])
+    (let loop ([n first][a init])
+      (if (test n until)
+	  (loop (step n) (accum a (f n)))
+	  a))))
+
+(define tile:plain%
+  (class null ()
+    (private
+      [state 'covered]
+      [neighbor-bomb-count 0])
+    (public
+      [set-state
+       (lambda (newstate)
+	 (set! state newstate))]
+      [get-state
+       (lambda ()
+	 state)]
+      [set-neighbor-bomb-count
+       (lambda (c)
+	 (set! neighbor-bomb-count c))]
+      [get-neighbor-bomb-count
+       (lambda ()
+	 neighbor-bomb-count)]
+      [draw-text-tile
+       (lambda (dc x y w h hilite? border? str color)
+	 (if border?
+	     (send dc set-pen FG-PEN)
+	     (send dc set-pen BG-PEN))
+	 (send dc draw-rectangle x y w h)
+	 (when hilite?
+	   (send dc draw-rectangle 
+		 (add1 x) (add1 y) 
+		 (- w 2) (- h 2)))
+	 (when str
+	   (if color
+	       (send dc set-text-foreground color)
+	       (send dc set-text-foreground FG-COLOR))
+	   (let ([tw (box 0)][th (box 0)])
+	     (send dc get-text-extent str tw th)
+	     (send dc draw-text str 
+		   (+ x (/ (- w (unbox tw)) 2))
+		   (+ y (/ (- h (unbox th)) 2))))))]
+      [draw
+       (lambda (dc x y w h hilite?)
+	 (case state
+	   [(covered) (draw-text-tile dc x y w h hilite? #t #f #f)]
+	   [(flagged) (draw-text-tile dc x y w h hilite? #t "X" #f)]
+	   [(semi-flagged) (draw-text-tile dc x y w h hilite? #t "?" #f)]
+	   [(uncovered) (draw-text-tile 
+			 dc x y w h #f #f
+			 (if (zero? neighbor-bomb-count)
+			     #f
+			     (number->string neighbor-bomb-count))
+			 (vector-ref DIGIT-COLORS neighbor-bomb-count))]))])))
+
+(define tile:bomb%
+  (class tile:plain% ()
+    (inherit get-state draw-text-tile)
+    (rename [super-draw draw])
+    (private
+      [explode-source? #f])
+    (public
+      [set-explode-source
+       (lambda (s?)
+	 (set! explode-source? s?))]
+      [draw
+       (lambda (dc x y w h hilite?)
+	 (if (eq? (get-state) 'uncovered)
+	     (draw-text-tile dc x y w h #f #f "*"
+			     (and explode-source? EXPLODE-COLOR))
+	     (super-draw dc x y w h hilite?)))])
+    (sequence
+      (super-init))))
+
+(define (get-tile b x y)
+  (vector-ref (vector-ref b x) y))
+
+(define (set-tile! b x y t)
+  (vector-set! (vector-ref b x) y t))
+
+(define (do-surrounding b x y accum start default f)
+  (step-while -1 <= 1 add1
+	      (lambda (dx)
+		(step-while -1 <= 1 add1
+			   (lambda (dy)
+			     (if (and (not (and (zero? dx) (zero? dy)))
+				      (< -1 (+ x dx) WIDTH)
+				      (< -1 (+ y dy) HEIGHT))
+				 (f dx dy)
+				 default))
+			   accum start))
+	      accum start))
+
+(define (is-bomb? x)
+  (is-a? x tile:bomb%))
+
+(define (count-surrounding-bombs b x y)
+  (do-surrounding 
+   b x y + 0 0
+   (lambda (dx dy)
+     (if (is-bomb? (get-tile b (+ x dx) (+ y dy)))
+	 1
+	 0))))
+
+(define (for-each-tile b f)
+  (step-while 0 < WIDTH add1
+	      (lambda (x)
+		(step-while 0 < HEIGHT add1
+			    (lambda (y)
+			      (f (get-tile b x y) x y))))))
+
+(define (make-board)
+  (let ([b (build-vector WIDTH
+			 (lambda (i)
+			   (build-vector HEIGHT
+					 (lambda (j)
+					   (make-object tile:plain%)))))])
+    (let loop ([n BOMB-COUNT])
+      (unless (zero? n)
+	(let rloop ()
+	  (let* ([x (random WIDTH)]
+		 [y (random HEIGHT)]
+		 [t (get-tile b x y)])
+	    (if (is-a? t tile:bomb%)
+		(rloop)
+		(begin
+		  (set-tile! b x y (make-object tile:bomb%))
+		  (loop (sub1 n))))))))
+    (for-each-tile b (lambda (t x y)
+		       (send t
+			     set-neighbor-bomb-count
+			     (count-surrounding-bombs b x y))))
+    b))
+
+(define f (make-object mred:frame% null "Minesweeper"))
+(define vpanel (make-object mred:vertical-panel% f))
+
+(define ms:canvas%
+  (class mred:canvas% args
+    (inherit get-dc clear 
+	     set-min-width set-min-height 
+	     stretchable-in-x stretchable-in-y)
+    (private
+      [panel (make-object mred:horizontal-panel% vpanel)])
+    (sequence
+      (send panel stretchable-in-y #f))
+    (private
+      [lspace (make-object mred:vertical-panel% panel)]
+      [time (make-object mred:message% panel "Time: 00000")]
+      [lmspace (make-object mred:vertical-panel% panel)]
+      [button (make-object mred:button% panel (lambda (b e) (reset)) "Reset")]
+      [rmspace (make-object mred:vertical-panel% panel)]
+      [count (make-object mred:message% panel "Count: 000")]
+      [rspace (make-object mred:vertical-panel% panel)]
+
+      [set-time
+       (lambda (t)
+	 (send time set-label (string-append "Time: " (number->string t))))]
+      [set-count
+       (lambda (c)
+	 (send count set-label (string-append "Bombs: " (number->string c))))]
+      
+      [clicking #f]
+      [clicking-x 0]
+      [clicking-y 0]
+      [ready? #t]
+      [start-time #f]
+      [elapsed-time 0]
+      [timer #f]
+      [bomb-count BOMB-COUNT]
+      [cover-count (* HEIGHT WIDTH)]
+      [board null])
+    (public
+      (stop-timer
+       (lambda ()
+	 (when timer
+	   (send timer stop)
+	   (set! timer #f))))
+      (start-timer
+       (lambda ()
+	 (set! start-time (current-seconds))
+	 (set! timer
+	       (make-object
+		(class-asi wx:timer%
+		  (public
+		    [notify
+		     (lambda ()
+		       (let ([e (- (current-seconds) start-time)])
+			 (when (> e elapsed-time)
+			   (set! elapsed-time e)
+			   (set-time e))))]))))
+	 (send timer start 100 #f)))
+      (end-of-game
+       (lambda (win?)
+	 (stop-timer)
+	 (set! ready? #f)
+	 (set! start-time #f)
+	 (unless win?
+	   (show-all-bombs))
+	 (set-count BOMB-COUNT)))
+      (explode
+       (lambda ()
+	 (end-of-game #f)))
+      (win
+       (lambda ()
+	 (end-of-game #t)))
+      (reset
+       (lambda ()
+	 (stop-timer)
+	 (set! ready? #t)
+	 (set! start-time #f)
+	 (set! elapsed-time 0)
+	 (set! cover-count (* HEIGHT WIDTH))
+	 (clear)
+	 (set-time 0)
+	 (set! bomb-count BOMB-COUNT)
+	 (set-count BOMB-COUNT)
+	 (set! board (make-board))
+	 (on-paint)))
+      (show-all-bombs
+       (lambda ()
+	 (for-each-tile board
+			(lambda (t x y)
+			  (when (is-bomb? t)
+			    (change-state t (send t get-state) 'uncovered #f)
+			    (paint-one t x y))))))
+      (autoclick-surrounding 
+       (lambda (x y)
+	 (do-surrounding 
+	  board x y void (void) (void)
+	  (lambda (dx dy)
+	    (let* ([x2 (+ x dx)]
+		   [y2 (+ y dy)]
+		   [t (get-tile board x2 y2)]
+		   [state (send t get-state)]
+		   [nc (send t get-neighbor-bomb-count)])
+	      (unless (eq? state 'uncovered)
+		(change-state t state 'uncovered #t)
+		(paint-one t x2 y2)
+		(when (zero? nc)
+		  (autoclick-surrounding x2 y2))))))))
+      (change-state
+       (lambda (t old-state new-state update-count?)
+	 (send t set-state new-state)
+	 (when (and update-count? (not (eq? new-state old-state)))
+	   (when (eq? new-state 'uncovered)
+	     (set! cover-count (sub1 cover-count)))
+	   (when (eq? old-state 'uncovered)
+	     (set! cover-count (add1 cover-count)))
+	   (when (eq? new-state 'flagged)
+	     (set! bomb-count (sub1 bomb-count))
+	     (set-count bomb-count))
+	   (when (eq? old-state 'flagged)
+	     (set! bomb-count (add1 bomb-count))
+	     (set-count bomb-count)))))
+      (do-select
+       (lambda (x y flag?)
+	 (let* ([t (get-tile board x y)]
+		[state (send t get-state)]
+		[new-state
+		 (case state
+		   [(covered)
+		    (if flag? 'flagged 'uncovered)]
+		   [(flagged)
+		    (if flag? 'semi-flagged state)]
+		   [(semi-flagged)
+		    (if flag? 'covered 'uncovered)]
+		   [else state])]
+		[nc (send t get-neighbor-bomb-count)]
+		[new-uncover? (and (eq? new-state 'uncovered)
+				   (not (eq? state 'uncovered)))]
+		[bomb? (is-bomb? t)])
+	   (change-state t state new-state #t)
+	   (when (and new-uncover? bomb?)
+	     (send t set-explode-source #t))
+	   (paint-one t x y)
+	   (when new-uncover?
+	     (if bomb?
+		 (explode)
+		 (begin
+		   (when (zero? nc)
+		     (autoclick-surrounding x y))))
+	     (when (and ready? (= cover-count BOMB-COUNT))
+	       (win))))))
+      (on-event
+       (lambda (e)
+	 (when ready?
+	   (unless start-time
+	     (when (send e button-down?)
+	       (start-timer)))
+	   (let* ([x (quotient (inexact->exact (floor (send e get-x))) TILE-HW)]
+		  [y (quotient (inexact->exact (floor (send e get-y))) TILE-HW)]
+		  [t (if (and (< -1 x WIDTH)
+			      (< -1 y HEIGHT))
+			 (get-tile board x y)
+			 #f)])
+	     (cond
+	       [(and clicking (or (not (eq? t clicking))
+				  (not (or (send e button-up?)
+					   (send e dragging?)))))
+		(let ([old clicking])
+		  (set! clicking #f)
+		  (paint-one old clicking-x clicking-y))]
+	       [(and t
+		     (not (eq? (send t get-state) 'uncovered))
+		     (or (send e button-down?)
+			 (and (send e dragging?)
+			      (= x clicking-x)
+			      (= y clicking-y))))
+		(set! clicking t)
+		(set! clicking-x x)
+		(set! clicking-y y)
+		(paint-one t x y)]
+	       [(send e button-down?) ; click not on a tile
+		(set! clicking-x -1)]
+	       [(and clicking (send e button-up?))
+		(set! clicking #f)
+		(do-select x y (send e button-up? 3))]
+	       [else 'ok])))))
+      (paint-one
+       (lambda (t x y)
+	 (let ([xloc (* x TILE-HW)]
+	       [yloc (* y TILE-HW)])
+	   (send t draw dc xloc yloc TILE-HW TILE-HW
+		 (eq? t clicking)))))
+      (on-paint
+       (lambda ()
+	 (for-each-tile board (lambda (t x y)
+				(paint-one t x y))))))
+    (sequence
+      (apply super-init args)
+      (set-min-width (* TILE-HW WIDTH))
+      (set-min-height (* TILE-HW HEIGHT))
+      (stretchable-in-x #f)
+      (stretchable-in-y #f))
+    (private
+      [dc (get-dc)])
+    (sequence
+      (reset)
+      (send dc set-text-background BG-COLOR)
+      (send dc set-brush (send wx:the-brush-list find-or-create-brush 
+			       BG-COLOR wx:const-solid)))))
+
+(define c (make-object ms:canvas% vpanel))
+
+(send f show #t)

collects/mrdemo/morph.ss

@@ -0,0 +1 @@
+(load-relative (build-path "morph" "load.ss"))

collects/mrdemo/morph/2darray.ss

@@ -0,0 +1,57 @@
+(define 2d-vector%
+  (make-class ()
+    (private
+     [default? #f]
+     [default (void)]
+     [vec (void)]
+     [found-error
+      (lambda (x w h)
+	(error '2d-vector% "~s out of bounds: ~s ~s; array size ~sx~s"
+	       x w h width height))]
+     [index (lambda (w h) (+ (* h width) w))])
+    (public
+     [height (void)]
+     [width (void)]
+     [set-default
+      (lambda (d)
+	(set! default? #t)
+	(set! default d))]
+     [no-default (lambda () (set! default? #f))]
+     [straighten (lambda () vec)]
+     [bend (lambda (list)
+	     (when (not (list? list))
+	       (error '2d-vector%
+		      "bend expected a list, found: ~s" list))
+	     (when (not (= (length list) (* height width)))
+	       (error '2d-vector%
+		      (string-append "attempted to bend a list of length ~s,"
+				     " should have length ~s")
+		      (length list) (* height width)))
+	     (set! vec (list->vector list)))]
+     [update (lambda (w h v)
+	       (let ([w (floor w)]
+		     [h (floor h)])
+		 (debug-print 2d-vector% 'width width 'height height w h
+			      'index (index w h))
+		 (if (and (<= 0 w) (< w width) (<= 0 h) (< h height))
+		     (vector-set! vec (index w h) v)
+		     (found-error 'update w h))))]
+     [lookup (lambda (w h)
+	       (let ([w (floor w)]
+		     [h (floor h)])
+		 (debug-print 2d-vector% 'width width 'height height w h
+			      'index (index w h))
+		 (if (and (<= 0 w) (< w width) (<= 0 h) (< h height))
+		     (vector-ref vec (index w h))
+		     (if default?
+			 default
+			 (found-error 'lookup w h)))))])
+    (lambda (w h v)
+      (if (and (integer? w) (integer? h))
+	  (begin 
+	    (set! width w)
+	    (set! height h)
+	    (set! vec (make-vector (* w h) v)))
+	  (error '2d-vector%
+		 "received w = ~s and h = ~s; both must should be integral" 
+		 w h)))))

collects/mrdemo/morph/coord.ss

@@ -0,0 +1,96 @@
+;;; this file sets up coordinates 
+
+;; bary represents just a three tuple of coordinates, not necessarily
+;; with respect to some triangle.
+(define-struct bary (a b c))
+(define show-bary
+  (let ([shorten (lambda (x) (/ (floor (* x 100)) 100))])
+    (lambda (p)
+      (printf "#<str:bary ~s ~s ~s>"
+	      (shorten (bary-a p))
+	      (shorten (bary-b p))
+	      (shorten (bary-c p))))))
+
+(define-struct posn (x y))
+(define show-posn 
+  (let ([shorten (lambda (x) (/ (floor (* x 10)) 10))])
+    (lambda (p)
+      (printf "#<str:posn ~s ~s>"
+	      (shorten (posn-x p))
+	      (shorten (posn-y p))))))
+
+(define-struct tri (a b c area))
+(define build-tri
+  (lambda (a b c)
+    (make-tri a b c (find-area a b c))))
+
+(define posn-minus
+  (lambda (p q)
+    (make-posn (- (posn-x p) (posn-x q))
+	       (- (posn-y p) (posn-y q)))))
+
+(define bary-minus
+  (lambda (p1 p2)
+    (make-bary (- (bary-a p1) (bary-a p2))
+	       (- (bary-b p1) (bary-b p2))
+	       (- (bary-c p1) (bary-c p2)))))
+
+(define square (lambda (x) (* x x)))
+
+(define norm
+  (lambda (b)
+    (+ (square (bary-a b))
+       (square (bary-b b))
+       (square (bary-c a)))))
+
+(define find-area
+  (let ([helper
+	 (lambda (p q)
+	   (let ([sroot (- (* (posn-y p) (posn-x q))
+			   (* (posn-x p) (posn-y q)))])
+	     (/ (abs sroot) 2)))])
+    (lambda (p1 p2 p3)
+      (helper (posn-minus p1 p2) (posn-minus p1 p3)))))
+
+(define find-barycentric
+  (lambda (p1 p2 p3 p)
+    (find-barycentric-area (build-tri p1 p2 p3) p)))
+
+(define find-barycentric-area
+  (lambda (tri p)
+    (let* ([p1 (tri-a tri)]
+	   [p2 (tri-b tri)]
+	   [p3 (tri-c tri)]
+	   [area (tri-area tri)]
+	   [little-area/big-area
+	    (lambda (p q)
+	      (let ([sroot (- (* (posn-y p) (posn-x q))
+			      (* (posn-x p) (posn-y q)))])
+		(/ sroot area 2)))]
+	   [p1-p (posn-minus p1 p)]
+	   [p2-p (posn-minus p2 p)]
+	   [p3-p (posn-minus p3 p)])
+      (make-bary (little-area/big-area p2-p p3-p)
+		 (little-area/big-area p3-p p1-p)
+		 (little-area/big-area p1-p p2-p)))))
+
+(define find-euclid
+  (lambda (tri b)
+    (let ([p1 (tri-a tri)]
+	  [p2 (tri-b tri)]
+	  [p3 (tri-c tri)]
+	  [a (bary-a b)]
+	  [b (bary-b b)]
+	  [c (bary-c b)])
+      (make-posn (+ (* a (posn-x p1))
+		    (* b (posn-x p2))
+		    (* c (posn-x p3)))
+		 (+ (* a (posn-y p1))
+		    (* b (posn-y p2))
+		    (* c (posn-y p3)))))))
+
+(define distance-sq
+  (lambda (p q)
+    (let ([x-delta (- (posn-x p) (posn-x q))]
+	  [y-delta (- (posn-y p) (posn-y q))])
+      (+ (* x-delta x-delta) (* y-delta y-delta)))))

collects/mrdemo/morph/debug.ss

@@ -0,0 +1,57 @@
+(define debug-on? (lambda (type) #f))
+
+(define debug-on? (lambda (type) #t))
+
+(define debug-on?
+  (lambda (type)
+    (case type
+      [(2d-vector%) #f]
+      [(engine) #t]
+      [(graph) #f]
+      [(main) #t]
+      [(mesh%) #t]
+      [(pager%) #t]
+      [else #t])))
+
+(defmacro debug-print (type . args)
+  (if (debug-on? type)
+      `(begin
+	 (display (quote ,type))
+	 (display ": ")
+	 (debug-print-function ,@args))
+      '(void)))
+
+(define debug-print-function
+  (letrec ([debug-print-one
+	    (lambda (x)
+		(cond
+		 [(list? x) (debug-print-list x)]
+		 [(pair? x) (display "(")
+			    (debug-print-one (car x))
+			    (display " . ")
+			    (debug-print-one (cdr x))
+			    (display ")")]
+		 [(posn? x) (show-posn x)]
+		 [(bary? x) (show-bary x)]
+;		 [(3vector? x) (show-3vector x)]
+;		 [(intersection? x) (show-intersection x)]
+		 [else (display x)]))]
+	   [debug-print-list-innards
+	    (lambda (list)
+	      (cond
+	       [(null? list) (void)]
+	       [(null? (cdr list)) (debug-print-one (car list))]
+	       [else (debug-print-one (car list))
+		     (display " ")
+		     (debug-print-list-innards (cdr list))]))]
+	   [debug-print-list
+	    (lambda (x)
+	      (display "(")
+	      (debug-print-list-innards x)
+	      (display ")"))])
+    (lambda args
+      (debug-print-list-innards args)
+      (newline)
+      (flush-output)
+      (void))))
+

collects/mrdemo/morph/engine.ss

@@ -0,0 +1,154 @@
+
+;; a mesh is a graph of the connectivities of the points. 
+(define-struct mesh (index children))
+
+;; an image is a 2d array of color values, all of which are between
+;; one and zero.
+
+
+;; input:
+;; src-verticies: the positions in the mesh where the
+;;                verticies are in the src image.
+;; src-img: the source image
+;; dest-verticies: the positions in the mesh where the
+;;                 verticies are in the dest image.
+;; src-img: the destination image
+;; w: a constant between zero and one indicating how far the morph between
+;;    the images. 
+;; 
+;; It returns a function which computes the color value for the pixel
+;; x and y, which should be a number between one and zero.
+
+
+
+(define engine-simple
+  (lambda (mesh src-lookup dest-lookup w)
+    (lambda (x y)
+      (let ([scale-pt (+ (* w (src-lookup x y))
+			 (* (- 1 w) (dest-lookup x y)))]
+	    [x (- (/ (random 101) 400) 1/8)])
+	(max 0 (min 1 (+ scale-pt x)))))))
+
+(define ormap-count 'uhoh)
+
+(define ormap-debug
+  (lambda (f list)
+    (letrec ([helper
+	      (lambda (i l)
+		(cond
+		 [(null? l) (set! ormap-count 'not-there)
+			    #f]
+		 [else (let ([w (f (car l))])
+			 (if w
+			     (begin
+			       (set! ormap-count (cons i w))
+			       w)
+			     (helper (1+ i) (cdr l))))]))])
+      (helper 1 list))))
+
+(define engine
+  (lambda (mesh src-lookup dest-lookup w)
+    (let* ([tmp-triangles (build-triangles w mesh)]
+	   [triangles (cons (car tmp-triangles) tmp-triangles)]
+	   [1-w (- 1 w)])
+      (lambda (x y)
+	(let* ([bc-tri (ormap (point-in-triangle? (make-posn x y)) triangles)])
+	  (if bc-tri
+	      (let* ([bc (car bc-tri)]
+		     [triangle-triple (cdr bc-tri)]
+		     [to-p (find-euclid (triangles-to triangle-triple) bc)]
+		     [to-x (posn-x to-p)]
+		     [to-y (posn-y to-p)]
+		     [from-p (find-euclid (triangles-from triangle-triple) bc)]
+		     [from-x (posn-x from-p)]
+		     [from-y (posn-y from-p)])
+		(set-car! triangles triangle-triple)
+		(values (+ (* w from-x) (* 1-w to-x))
+			(+ (* w from-y) (* 1-w to-y))
+			(+ (* w (src-lookup from-x from-y))
+			   (* 1-w (dest-lookup to-x to-y)))))
+	      (values x
+		      y
+		      (begin '(/ (+ (src-lookup x y) (dest-lookup x y)) 2)
+			     1))))))))
+
+'(define engine engine-simple)
+
+(define get-points
+  (lambda (node)
+    (let ([value (graph:value node)])
+      (values (car value) (cdr value)))))
+
+;; this returns either #f or a pair, the triangle and the barycentric
+;; coordinates of (x,y) with respect to that triangle.
+(define point-in-triangle?
+  (lambda (posn)
+    (lambda (triangle-triple)
+      (let* ([intermediate-triangle (triangles-intermediate triangle-triple)]
+	     [bary (find-barycentric-area intermediate-triangle posn)])
+	(if (and (<= 0 (bary-a bary))
+		 (<= 0 (bary-b bary))
+		 (<= 0 (bary-c bary)))
+	    (cons bary triangle-triple)
+	    #f)))))
+
+;; This maps over a list pairwise, e.g.
+;; (for-each-pairwise (list 1 2 3) f)
+;; =
+;; (begin (f 1 2) (f 2 3) (f 3 1))
+
+(define for-each-pairwise
+  (lambda (l f)
+    (cond
+     [(<= (length l) 1) (void)]
+     [(= 2 (length l)) (f (first l) (second l))]
+     [else (letrec ([first-ele (car l)]
+		    [helper 
+		     (lambda (l)
+		       (cond 
+			[(null? (cdr l)) (begin '(f (first l) first-ele)
+						(void))]
+			[else (f (first l) (second l))
+			      (helper (cdr l))]))])
+	     (helper l))])))
+
+(define-struct triangles (from intermediate to))
+
+(define build-triangles
+  (lambda (w mesh)
+    (let* ([triangles null]
+	   [1-w (- 1 w)]
+	   [combine
+	    (lambda (p q)
+	      (make-posn (+ (* w (posn-x p)) (* 1-w (posn-x q)))
+			 (+ (* w (posn-y p)) (* 1-w (posn-y q)))))])
+      (graph:traverse
+       mesh
+       (lambda (node)
+	 (let-values ([(left right) (get-points node)])
+	   (let ([children (graph:children node)])
+	     (when (= (length children) 3)
+	       (let ([one (first children)]
+		     [two (second children)]
+		     [three (third children)])
+		 (let-values ([(left-one right-one) (get-points one)]
+			      [(left-two right-two) (get-points two)]
+			      [(left-three right-three) (get-points three)])
+		   (let* ([int (combine left right)]
+			  [int-one (combine left-one right-one)]
+			  [int-two (combine left-two right-two)]
+			  [int-three (combine left-three right-three)]
+			  [left-tri1 (build-tri left left-one left-two)]
+			  [int-tri1 (build-tri int int-one int-two)]
+			  [right-tri1 (build-tri right right-one right-two)]
+			  [left-tri2 (build-tri left left-three left-one)]
+			  [int-tri2 (build-tri int int-three int-one)]
+			  [right-tri2 (build-tri right right-three right-one)])
+		     (set! triangles
+			   (list*
+			    (make-triangles left-tri1 int-tri1 right-tri1)
+			    (make-triangles left-tri2 int-tri2 right-tri2)
+			    triangles))))))))))
+      (if (null? triangles)
+	  (error 'build-triangles "empty mesh")
+	  triangles))))

collects/mrdemo/morph/load.ss

@@ -0,0 +1,15 @@
+(for-each (lambda (x)
+	    (printf "loading ~s...~n" x)
+	    (flush-output)
+	    (load-relative x))
+	  '("setup.ss"
+	    "debug.ss"
+	    "2darray.ss"
+	    "coord.ss"
+	    "mesh.ss"
+	    "utils.ss"
+	    "ui.ss"
+	    "pager.ss"
+	    "engine.ss"
+	    "main.ss"))
+(printf "done loading~n")

collects/mrdemo/morph/main.ss

@@ -0,0 +1,76 @@
+(define main
+  (lambda (mesh src-mem-dc dest-mem-dc src-2dvec dest-2dvec total)
+    (letrec* ([width (max (ivar src-2dvec width) (ivar dest-2dvec width))]
+	      [dummy-name-width width]
+	      [height (max (ivar src-2dvec height) (ivar dest-2dvec height))]
+
+	      [src-lookup (ivar src-2dvec lookup)]
+	      [dest-lookup (ivar dest-2dvec lookup)]
+
+	      [build-w
+	       (lambda (w)
+		 (debug-print main "building image percent" w)
+		 (let* ([new-point (engine mesh
+					   src-lookup
+					   dest-lookup
+					   w)]
+			[memory-dc (make-object wx:memory-dc%)]
+			[set-pixel (ivar memory-dc set-pixel)]
+			[bitmap (make-object wx:bitmap% width height)]
+			[scale (1- num-colors)])
+		   (send memory-dc select-object bitmap)
+		   (send memory-dc begin-set-pixel)
+		   (let loop ([x width] [y height])
+		     (let-values ([(draw-x draw-y color) (new-point x y)])
+		       (set-pixel draw-x draw-y 
+				  (vector-ref colors
+					      (floor (* color
+							scale))))
+		       (cond
+			[(and (zero? y) (zero? x)) (void)]
+			[(zero? x) (begin (when (= 0 (modulo y 15))
+					    (debug-print main 'y y))
+					  (loop width (1- y)))]
+			[else (loop (1- x) y)])))
+		   (send memory-dc end-set-pixel)
+		   memory-dc))]
+
+	      [memory-dcs1
+	       '(list->vector
+		(reverse
+		 (cons dest-mem-dc
+		       (let loop ([i 1])
+			 (if (= i (- total 1)) (list src-mem-dc)
+			     (cons (build-w (/ i (1- total)))
+				   (loop (1+ i))))))))]
+
+	      [memory-dcs2
+	       '(list->vector
+		 (let loop ([i total])
+		   (if (zero? i)
+		       (list (build-w (/ i (1- total))))
+		       (cons (build-w (/ i (1- total)))
+			     (loop (1- i))))))]
+
+	      [sub-pager%
+	       (make-class pager%
+		 (public
+		  [width dummy-name-width]
+		  [picture-height height]
+		  [memory-dcs
+		   (list->vector
+		    (reverse
+		     (cons dest-mem-dc
+			   (let loop ([i 1])
+			     (if (= i (- total 1)) (list src-mem-dc)
+				 (cons (build-w (/ i (1- total)))
+				       (loop (1+ i))))))))])
+		 (lambda ()
+		   (super-init)))])
+      '(debug-print main memory-dcs)
+      (send src-2dvec set-default 1)
+      (send dest-2dvec set-default 1)
+      (mred:show-busy-cursor
+       (lambda ()
+	 (make-object sub-pager%))))))
+

collects/mrdemo/morph/mesh.ss

@@ -0,0 +1,138 @@
+;; graph:node takes a value to be stored on a node and creates a new node.
+;; graph:edge takes two edges and joins them
+;; graph:value takes a node and returns it's value
+
+(define-values (graph:node
+		graph:edge
+		graph:value
+		graph:children
+		graph:parents
+		graph:connections
+		graph:traverse
+		graph:fprintf
+		graph:read
+		graph:id
+		find-closest)
+  (local
+    [(define counter 0)
+     
+     (define-struct node (value children parents visited? id))
+     
+     (define graph:id node-id)
+     
+     (define graph:node
+       (lambda (value)
+	 (make-node value null null #f
+		    (begin0 counter
+			    (set! counter (add1 counter))))))
+     ; from n1 to n2. n1 is n2's parent
+     (define graph:edge
+       (lambda (n1 n2)
+	 (set-node-children! n1 (cons n2 (node-children n1)))
+	 (set-node-parents! n2 (cons n1 (node-parents n2)))))
+     (define graph:value node-value)
+     (define graph:children node-children)
+     (define graph:parents node-parents)
+     (define graph:connections (lambda (x)
+				 (append (graph:parents x)
+					 (graph:children x))))
+     (define graph:traverse
+       (lambda (node f)
+	 (unless (node? node)
+	   (error 'graph:traverse "expected a node, found ~s" node))
+	 (letrec ([to-reset null]
+		  [helper
+		   (lambda (node)
+		     (when (not (node-visited? node))
+		       (f node)
+		       (set! to-reset (cons node to-reset))
+		       (set-node-visited?! node #t)
+		       (for-each helper (node-children node))))])
+	   (helper node)
+	   (for-each (lambda (node)
+		       (set-node-visited?! node #f))
+		     to-reset))))
+     
+     (define graph:fprintf
+       (lambda (port node fprintf-node-value)
+	 (unless (node? node)
+	   (error 'graph:fprintf "expected a node, found ~s" node))
+	 (let ([min (node-id node)] [max (node-id node)])
+	   (graph:traverse
+	    node (lambda (x)
+		   (when (< max (node-id x))
+		     (set! max (node-id x)))
+		   (when (< (node-id x) min)
+		     (set! min (node-id x)))))
+	   (fprintf port "~s ; min~n~s ; max~n; nodes~n" min max))
+	 (graph:traverse
+	  node
+	  (lambda (node)
+	    (fprintf port "~s	~s	~s	" (node-id node)
+		     (map node-id (node-children node))
+		     (map node-id (node-parents node)))
+	    (fprintf-node-value port (node-value node))
+	    (fprintf port "~n")))
+	 (fprintf port "~s~n" 'double-check)
+	 (fprintf port "~s~n" (node-id node))))
+     
+     (define graph:read
+       (opt-lambda (read-value [port (current-input-port)])
+	 (let* ([min (read port)]
+		[max (read port)]
+		[v (tabulate (add1 (- max min)) (lambda (x)
+						(graph:node x)))])
+	   (let loop ([i (- max min)])
+	     (when (<= 0 i)
+	       (let* ([index (- (read port) min)]
+		      [node (vector-ref v index)]
+		      [chili (lambda (i) (vector-ref v (- i min)))]
+		      [children (read port)]
+		      [parents (read port)])
+		 (set-node-children! node (map chili children))
+		 (set-node-parents! node (map chili parents))
+		 (set-node-value! node (read-value port))
+		 (debug-print graph (+ index min) 'children children
+			      'parents parents
+			      'node node))
+	       (loop (sub1 i))))
+	   (when (not (eq? 'double-check (read port)))
+	     (error 'graph:read "input corrupted"))
+	   (let ([node-count (read port)])
+	     (debug-print graph 'important-node node-count
+			  'min min
+			  (vector-ref v (- node-count min)))
+	     (vector-ref v (- node-count min))))))
+     
+     (define find-closest
+       (lambda (node x y node-value-get)
+	 (let* ([mouse-posn (make-posn x y)]
+		[closest node]
+		[value (graph:value node)]
+		[posn (node-value-get value)]
+		[current-dist-sq (distance-sq mouse-posn posn)])
+	   (graph:traverse node
+			   (lambda (node)
+			     (let* ([value (graph:value node)]
+				    [this-posn (node-value-get value)]
+				    [this-dist-sq
+				     (distance-sq mouse-posn this-posn)])
+			       (when (< this-dist-sq current-dist-sq)
+				 (set! posn this-posn)
+				 (set! current-dist-sq this-dist-sq)
+				 (set! closest node)))))
+	   closest)))]
+         
+
+
+     (values graph:node
+	     graph:edge
+	     graph:value
+	     graph:children
+	     graph:parents
+	     graph:connections
+	     graph:traverse
+	     graph:fprintf
+	     graph:read
+	     graph:id
+	     find-closest)))

collects/mrdemo/morph/pager.ss

@@ -0,0 +1,120 @@
+(define pager%
+  (make-class ()
+    (public
+     [x-pos 650]
+     [y-pos 60]
+     [width 300]
+     [picture-height 300]
+     [slider-height 50]
+     [button-width 30]
+     [slider-width (- width button-width)]
+     [memory-dcs (vector)]
+     [save-images
+      (lambda (fn)
+	(let loop ([i (1- (vector-length memory-dcs))])
+	  (when (<= 0 i)
+	    (let* ([this-name (string-append
+			       fn (number->string (1+ i)) ".pgm")]
+		   [port (open-output-file this-name 'replace)]
+		   [memory-dc (vector-ref memory-dcs i)]
+		   [get-pixel (ivar memory-dc get-pixel)]
+		   [color (make-object wx:colour% "white")]
+		   [get-colors (ivar color get)]
+		   [bgreen (box 0)]
+		   [bred (box 0)]
+		   [bblue (box 0)])
+	      (debug-print pager% 'writing 'image this-name)
+	      (fprintf port
+		       "P2~n# Robby's Morpher via MrEd~n~s ~s~n255~n"
+		       width picture-height)
+	      (let loop ([x 0] [y 0])
+		(if (get-pixel x y color)
+		    (get-colors bred bgreen bblue)
+		    (set-box! bgreen 255))
+		(fprintf port "~s" (unbox bgreen))
+		(fprintf port (if (= x width) "~n" " "))
+		(cond [(and (= x (1- width)) (= y (1- picture-height))) (void)]
+		      [(= x (1- width)) (loop 0 (1+ y))]
+		      [else (loop (1+ x) y)]))
+	      (debug-print pager% 'wrote this-name)
+	      (close-output-port port))
+	    (loop (1- i)))))]
+     [frame%
+      (make-class mred:menu-frame%
+	(rename [super-make-menu-bar make-menu-bar])
+	(inherit make-menu show)
+	(public
+	 [make-menu-bar
+	  (lambda ()
+	    (let ([bar (super-make-menu-bar)]
+		  [file-menu (make-menu)])
+	      (send file-menu append-item "Save"
+		    (lambda ()
+		      (let ([fn (mred:common-put-file '()
+				 "Please Specify a prefix for the images.")])
+			(debug-print pager% 'fn fn)
+			(when fn
+			  (debug-print pager% 'fn fn)
+			  (save-images fn)))))
+	      (send file-menu append-item "Close" (lambda () (show #f)))
+	      (send bar append file-menu "File")
+	      bar))]))]
+     [frame (make-object frame% '() "Morph")]
+     [panel (ivar frame panel)]
+     [canvas%
+      (make-class mred:canvas%
+	(inherit clear set-background)
+        (public
+	 [w-brush (make-object wx:brush% "white" wx:const-solid)]
+	 [on-paint
+	  (lambda ()
+	    '(send dc destroy-clipping-region)
+	    '(send dc set-clipping-region 0 0 (1+ width) (1+ picture-height))
+	    (set-background w-brush)
+	    (clear)
+	    (when slider
+	      (send dc blit 0 0 width picture-height
+		    (vector-ref memory-dcs (send slider get-value))
+		    0 0 wx:const-copy)))]))]
+     [canvas (make-object canvas% panel)]
+     [s-panel (make-object mred:horizontal-panel% panel)]
+     [slider
+      (let ([show-arg
+	     (lambda (s e)
+	       (send canvas on-paint))])
+	(if (> (vector-length memory-dcs) 1)
+	    (make-object mred:slider% s-panel show-arg ""
+			 0 0 (sub1 (vector-length memory-dcs)) slider-width)
+	    #f))]
+     [button-click
+      (lambda args
+	(mred:show-busy-cursor
+	 (lambda ()
+	   (let ([old-slider-pos (send slider get-value)])
+	     (let loop ([img 0])
+	       (when (< img (vector-length memory-dcs))
+		 (send slider set-value img)
+		 (send canvas on-paint)
+		 (wx:flush-display)
+		 (sleep 0.5)
+		 (loop (1+ img))))
+	     '(send slider set-value old-slider-pos)
+	     (send canvas on-paint)))))]
+     [button
+      (when (> (vector-length memory-dcs) 1)
+	    (make-object mred:button% s-panel button-click "Play"))]
+     [dc (send canvas get-dc)]
+     [shutdown (lambda () (send frame show #f))])
+    (lambda ()
+      (send panel stretchable-in-y #f)
+      (let ([w (box 0)]
+	    [h (box 0)])
+	(send canvas get-client-size w h)
+	(let ([diff (- (send canvas get-width) (unbox w))])
+	  (send canvas user-min-width (+ diff width))
+	  (send canvas user-min-height (+ diff picture-height))))
+      (send canvas stretchable-in-x #f)
+      (send canvas stretchable-in-y #f)
+      (send frame show #t)
+      (send canvas on-paint))))
+

collects/mrdemo/morph/setup.ss

@@ -0,0 +1,46 @@
+(print-struct #t)
+(print-graph #t)
+(define last
+  (lambda (x)
+    (cond
+     [(null? x) (error 'last "empty list")]
+     [(null? (cdr x)) (car x)]
+     [else (last (cdr x))])))
+
+(define foldl2
+  (lambda (f init l)
+    (letrec ([helper
+	      (lambda (l sofar)
+		(cond
+		 [(null? l) sofar]
+		 [else (helper (cdr l) (f (car l) sofar))]))])
+      (helper l init))))
+
+(define tabulate
+  (lambda (n f)
+    (letrec ([build (lambda (i)
+		      (cond
+		       [(= i n) null]
+		       [else (cons (f i) (build (1+ i)))]))])
+      (list->vector (build 0)))))
+
+(define vector-for-each
+  (lambda (f v)
+    (let ([size (vector-length v)])
+      (let loop ([n 0])
+	(when (< n size)
+	  (f i (vector-ref v i))
+	  (loop))))))
+
+'(define remove
+  (lambda (list f)
+    (letrec ([helper
+	      (lambda (l)
+		(cond [(null? l) null]
+		      [(f (car l)) (helper (cdr l))]
+		      [else (cons (car l) (helper (cdr l)))]))])
+      (helper list))))
+
+(define-macro package
+  (lambda (x . args)
+    (car 'package)))

collects/mrdemo/morph/ui.ss

@@ -0,0 +1,407 @@
+(define num-colors 200)
+(define mesh-color (make-object wx:colour% 50 155 50))
+(define mesh-pen (make-object wx:pen% mesh-color 1 wx:const-solid))
+
+(define black-pen (make-object wx:pen% "BLACK" 1 wx:const-solid))
+
+(define colors
+  (tabulate num-colors
+	    (lambda (i)
+	      (make-object wx:colour%
+			   (* 255 (expt (/ i (1- num-colors)) 1/2))
+			   (* 255 (/ i (1- num-colors)))
+			   (* 255 (expt (/ i (1- num-colors)) 1/2))))))
+
+(define mesh%
+  (make-class mred:menu-frame%
+    (rename [super-make-menu-bar make-menu-bar]
+;	    [super-on-paint on-paint]
+	    )
+    (inherit make-menu show panel)
+    (public
+     [mesh #f]
+     
+     [filename #f]
+     [margin 10]
+
+     [on-paint
+      (lambda ()
+	(send left-canvas on-paint)
+	(send right-canvas on-paint))]
+
+     [canvas%
+      (make-class mred:canvas%
+	(inherit set-background get-dc clear get-client-size)
+	(rename [super-on-event on-event])
+	(private
+	 [w-brush (make-object wx:brush% "white" wx:const-solid)])
+        (public
+	 [node-value-get (void)]
+	 [node-value-update (void)]
+	 [memory-dc (make-object wx:memory-dc%)]
+	 [set-memory-dc! (lambda (mdc) (set! memory-dc mdc))]
+	 [draw-line (void)]
+	 [dc (void)]
+	 [on-event
+	  (let* ([dragging-node (void)]
+		 [connections null]
+		 [orig-x (void)]
+		 [orig-y (void)]
+		 [last-x -1]
+		 [last-y -1]
+		 [lines (lambda ()
+			  (for-each
+			   (lambda (x)
+			     (let ([p (node-value-get (graph:value x))])
+			       (draw-line (posn-x p) (posn-y p)
+					  last-x last-y)))
+			   connections))])
+	    (lambda (event)
+	      (cond
+	       [(send event dragging?)
+		(let ([x (send event get-x)]
+		      [y (send event get-y)])
+		  (when (and (not (and (= x last-x)
+				       (= x last-y)))
+			     '(inside-triangles dragging-node x y))
+		    (lines)
+		    (set! last-x x)
+		    (set! last-y y)
+		    (lines)))]
+		[(send event button-down?)
+		 (let ([x (send event get-x)]
+		       [y (send event get-y)])
+		   (send dc set-logical-function wx:const-xor)
+		   (when mesh
+			 (set! dragging-node (find-closest mesh x y node-value-get))
+			 (set! connections (graph:connections dragging-node)))
+		   (set! last-x x)
+		   (set! last-y y)
+		   (set! orig-x x)
+		   (set! orig-y y)
+		   (lines))]
+		[(send event button-up?)
+		 (lines)
+		 (send dc set-logical-function wx:const-copy)
+		 (unless (void? dragging-node)
+			 (node-value-update (graph:value dragging-node)
+					    (make-posn last-x last-y)))
+		 (let* ([posns (cons (make-posn last-x last-y)
+				     (map (lambda (x)
+					    (node-value-get (graph:value x)))
+					  connections))]
+			[box-width (box 0)]
+			[box-height (box 0)]
+			[min-x orig-x]
+			[min-y orig-y]
+			[max-x orig-x]
+			[max-y orig-y])
+		   (for-each (lambda (p)
+			       (let ([x (posn-x p)]
+				     [y (posn-y p)])
+				 (when (< max-x x) (set! max-x x))
+				 (when (< max-y y) (set! max-y y))
+				 (when (< x min-x) (set! min-x x))
+				 (when (< y min-y) (set! min-y y))))
+			     posns)
+		   '(send dc set-clipping-region min-x min-y
+			 (1+ (- max-x min-x))
+			 (1+ (- max-y min-y)))
+		   (on-paint)
+		   (get-client-size box-width box-height)
+		   (send dc set-clipping-region
+			 0 0 (unbox box-width) (unbox box-height)))
+		 (set! dragging-node (void))
+		 (set! connections (void))
+		 (set! orig-x (void))
+		 (set! orig-y (void))
+		 (set! last-x (void))
+		 (set! last-y (void))]
+		[else (super-on-event event)])))]
+	 [on-paint
+	  (lambda ()
+	    (let* ([get-points
+		    (lambda (node)
+		      (let* ([value (graph:value node)]
+			     [p (node-value-get value)])
+			(values (posn-x p)(posn-y p))))]
+		   [traverse
+		    (lambda (node)
+		      (let-values ([(b-x b-y) (get-points node)])
+			(let* ([children (graph:children node)]
+			       [chili
+				(lambda (child)
+				  (let-values ([(e-x e-y) (get-points child)])
+				    (draw-line b-x b-y e-x e-y)))])
+			  (for-each chili children))))]
+		   [dc (get-dc)]
+		   [by (box 0)]
+		   [bx (box 0)])
+	      (get-client-size bx by)
+	      (set-background w-brush)
+	      (clear)
+	      (send dc set-pen black-pen)
+	      (send dc blit 0 0 (unbox bx) (unbox by)
+		    memory-dc 0 0 wx:const-copy)
+	      (when mesh
+		(send dc set-pen mesh-pen)
+		'(send dc set-logical-function wx:const-xor)
+		(graph:traverse mesh traverse)
+		'(send dc set-logical-function wx:const-copy))))])
+	(lambda (get update . args)
+	  (apply super-init args)
+	  (set! dc (get-dc))
+	  (set! draw-line (ivar dc draw-line))
+	  (set! node-value-get get)
+	  (set! node-value-update update)))]
+
+     [left-filename #f]
+     [right-filename #f]
+     [left-2dvec #f]
+     [right-2dvec #f]
+     [left-canvas #f]
+     [right-canvas #f]
+     [default-size 200]
+
+     [canvas-size-diff 0]
+
+     [get-sizes
+      (lambda ()
+	(let* ([left-width (if left-2dvec
+			       (ivar left-2dvec width)
+			       default-size)]
+	       [left-height (if left-2dvec
+				(ivar left-2dvec height)
+				default-size)]
+	       [right-width (if right-2dvec
+				(ivar right-2dvec width)
+				default-size)]
+	       [right-height (if right-2dvec
+				 (ivar right-2dvec height)
+				 default-size)])
+	  (values left-width left-height right-width right-height)))]
+     [resize-panels
+      (lambda ()
+	(let-values ([(left-width left-height right-width right-height)
+		      (get-sizes)])
+	  (send left-canvas user-min-width (+ canvas-size-diff left-width))
+	  (send left-canvas user-min-height (+ canvas-size-diff left-height))
+	  (send right-canvas user-min-width (+ canvas-size-diff right-width))
+	  (send right-canvas user-min-height (+ canvas-size-diff right-height))))]
+     [open
+      (lambda (fn)
+	(mred:show-busy-cursor
+	 (lambda ()
+	   (let* ([port (open-input-file fn)]
+		  [local-mesh #f]
+		  [read-value
+		   (lambda (port)
+		     (let ([left (read port)]
+			   [right (read port)])
+		       (cons (apply make-posn left)
+			     (apply make-posn right))))])
+	     (set! left-filename (read port))
+	     (set! right-filename (read port))
+	     (when (read port)
+		 (set! local-mesh (graph:read read-value port)))
+	     (close-input-port port)
+	     (debug-print mesh% 'read 'file)
+	     (set! left-2dvec (build-image left-filename))
+	     (set! right-2dvec (build-image right-filename))
+	     (debug-print mesh% 'built-2dvecs)
+	     (send left-canvas set-memory-dc! (build-memory-dc left-2dvec))
+	     (send right-canvas set-memory-dc! (build-memory-dc right-2dvec))
+	     (debug-print mesh% 'updated 'canvases)
+	     (set! mesh local-mesh)
+	     (set! filename fn)
+	     (resize-panels)
+	     (on-paint)))))]
+     [save
+      (lambda ()
+	(if filename
+	    (begin
+	      (let ([port (open-output-file filename 'replace)]
+		    [print-value
+		     (lambda (port v)
+		       (let ([left (car v)]
+			     [right (cdr v)])
+			 (fprintf port "~s ~s"
+				  (list (posn-x left) (posn-y left))
+				  (list (posn-x right) (posn-y right)))))])
+		(fprintf port ";;; data req'd to setup a morph~n~n")
+		(fprintf port "~s ; source filename~n" left-filename)
+		(fprintf port "~s ; destination filename~n" right-filename)
+		(fprintf port "~n;; mesh~n")
+		(if mesh
+		    (begin
+		      (fprintf port "#t ; mesh is setup~n")
+		      (graph:fprintf port mesh print-value))
+		    (fprintf port "#f ; mesh is not setup~n"))
+		(close-output-port port)))
+	    (save-as)))]
+     [save-as
+      (lambda ()
+	(let ([fn (mred:common-put-file)])
+	  (when fn
+	    (set! filename fn)
+	    (save))))]
+
+     [make-menu-bar
+      (lambda ()
+	(let ([bar (super-make-menu-bar)]
+	      [file-menu (make-menu)]
+	      [picture-menu (make-menu)]
+	      [mesh-menu (make-menu)]
+	      [morph-menu (make-menu)])
+	  (send file-menu append-item "Open..."
+		(lambda ()
+		  (let ([fn (mred:common-get-file)])
+		    (when fn (open fn)))))
+	  (send file-menu append-item "Save..." save)
+	  (send file-menu append-item "Save As..." save-as)
+	  (send file-menu append-separator)
+	  (send file-menu append-item "Close" (lambda () (show #f)))
+	  (send picture-menu append-item "Select Source Image..."
+		(lambda () 
+		  (let ([fn (mred:common-get-file
+			     '() "Please choose an image.")])
+		    (when fn
+		      (mred:show-busy-cursor
+		       (lambda ()
+			 (set! left-filename fn)
+			 (time (set! left-2dvec (build-image fn)))
+			 (time (send left-canvas set-memory-dc!
+				     (build-memory-dc left-2dvec)))
+			 (set! mesh #f)
+			 (resize-panels)
+			 (on-paint)))))))
+	  (send picture-menu append-item "Select Destination Image..."
+		(lambda ()
+		  (let ([fn (mred:common-get-file
+			     '() "Please choose an image.")])
+		    (when fn
+		      (mred:show-busy-cursor
+		       (lambda ()
+			 (set! right-filename fn)
+			 (set! right-2dvec (build-image fn))
+			 (send right-canvas set-memory-dc!
+			       (build-memory-dc right-2dvec))
+			 (set! mesh #f)
+			 (resize-panels)
+			 (on-paint)))))))
+	  (send picture-menu append-item "Exchange Images"
+		(lambda ()
+		  (let ([left-mdc (ivar left-canvas memory-dc)]
+			[right-mdc (ivar right-canvas memory-dc)]
+			[tmp left-2dvec]
+			[exchange
+			 (lambda (node)
+			   (let* ([value (graph:value node)]
+				  [left (car value)])
+			     (set-car! value (cdr value))
+			     (set-cdr! value left)))])
+		    (set! left-2dvec right-2dvec)
+		    (set! right-2dvec tmp)
+		    (send right-canvas set-memory-dc! left-mdc)
+		    (send left-canvas set-memory-dc! right-mdc)
+		    (graph:traverse mesh exchange)
+		    (resize-panels)
+		    (on-paint))))
+	  (send mesh-menu append-item "Fresh Mesh..."
+		(lambda ()
+		  (fresh-mesh (get-number-from-user
+			       "How large should the mesh be?"
+			       "Mesh Size" "5"))
+		  (on-paint)))
+	  (send morph-menu append-item "Morph..."
+		(lambda () (morph (get-number-from-user
+				   "How many steps in the morph?"
+				   "Morph Size" "3"))))
+	  (send bar append file-menu "File")
+	  (send bar append picture-menu "Images")
+	  (send bar append mesh-menu "Mesh")
+	  (send bar append morph-menu "Morph")
+	  bar))]
+     [morph
+      (lambda (steps)
+	(if (and left-2dvec right-2dvec mesh)
+	    (main mesh (ivar left-canvas memory-dc)
+		  (ivar right-canvas memory-dc)
+		  left-2dvec right-2dvec steps)
+	    (wx:message-box "Please choose images and mesh.")))]
+     [fresh-mesh
+      (lambda (n)
+	(let-values ([(left-width left-height right-width right-height)
+		      (get-sizes)])
+	  (let* ([nodes
+		  (let loop ([row (1- n)] [column (1- n)])
+		    (let ([row-percent (/ row (1- n))]
+			  [column-percent (/ column (1- n))])
+		      (cons 
+		       (graph:node
+			(cons (make-posn (* left-width row-percent)
+					 (* left-height column-percent))
+			      (make-posn (* right-width row-percent)
+					 (* right-height column-percent))))
+		       (cond
+			[(and (= row 0) (= column 0)) null]
+			[(= row 0) (loop (1- n) (1- column))]
+			[else (loop (1- row) column)]))))]
+		 [2dvec (make-object 2d-vector% n n 0)]
+		 [lookup (ivar 2dvec lookup)]
+		 [update (ivar 2dvec update)])
+	    (send 2dvec bend (reverse nodes))
+
+	    (if (< 2 n)
+		(begin
+		  '(graph:edge (lookup 0 (1- n)) (lookup 1 (1- n)))
+		  (let loop ([x (- n 2)] [y (- n 2)])
+		    (graph:edge (lookup x y) (lookup x (1+ y)))
+		    (graph:edge (lookup x y) (lookup (1+ x) y))
+		    (graph:edge (lookup x y) (lookup (1+ x) (1+ y)))
+		    (cond [(and (= x 0) (= y 0)) (void)]
+			  [(= x 0) (loop (- n 2) (1- y))]
+			  [else (loop (1- x) y)]))
+		  (let loop ([i (- n 2)])
+		    (when (<= 0 i)
+		      (graph:edge (lookup (1- n) i) (lookup (1- n) (1+ i)))
+		      (graph:edge (lookup i (1- n)) (lookup (1+ i) (1- n)))
+		      (loop (1- i)))))
+		(begin
+		  (graph:edge (lookup 0 0) (lookup 0 1))
+		  (graph:edge (lookup 0 0) (lookup 1 0))
+		  (graph:edge (lookup 0 0) (lookup 1 1))
+		  (graph:edge (lookup 1 0) (lookup 1 1))
+		  (graph:edge (lookup 0 1) (lookup 1 1))))
+
+	    (set! mesh (lookup 0 0)))))])
+
+    (lambda ()
+      (super-init '() "Mesh Construction")
+      (send panel stretchable-in-x #f)
+      (send panel stretchable-in-y #f)
+      (let ([p (make-object mred:horizontal-panel% panel)]
+	    [init
+	     (lambda (c)
+	       (send c user-min-height default-size)
+	       (send c user-min-width default-size)
+	       (send c stretchable-in-x #f)
+	       (send c stretchable-in-y #f))])
+	(send p stretchable-in-x #f)
+	(send p stretchable-in-y #f)
+	(set! left-canvas (make-object canvas% car set-car! p))
+	(init left-canvas)
+	(set! right-canvas (make-object canvas% cdr set-cdr! p))
+	(init right-canvas))
+      (let ([w (box 0)]
+	    [h (box 0)])
+	(send right-canvas get-client-size w h)
+	(set! canvas-size-diff (- (send right-canvas get-width) (unbox w))))
+      (show #t))))
+
+(define mesh
+  (begin (when (defined? 'mesh)
+	   (send mesh show #f))
+	 (make-object mesh%)))
+'(send mesh open "/home/robby/class/graphics/lab5/test/rd.morph")
+'(send mesh morph 3)

collects/mrdemo/morph/utils.ss

@@ -0,0 +1,114 @@
+(define build-pgm-image
+  (lambda (filename)
+    (let* ([comment #\#]
+	   [coords
+	    (call-with-input-file
+	     filename
+	     (lambda (p)
+	       (let ([tmp null])
+		 (let loop ([line (read-line p)])
+		   (unless (eof-object? line)
+		     (unless (char=? comment (string-ref line 0))
+		       (let ([sp (open-input-string line)])
+			 (let loop ([object (read sp)])
+			   (unless (eof-object? object)
+			     (set! tmp (cons object tmp))
+			     (loop (read sp))))))
+		     (loop (read-line p))))
+		 (reverse tmp))))])
+      (when (< (length coords) 4)
+	(error 'build-image "found less than four numbers in file: ~s"
+	       filename))
+      (let* ([tag (first coords)]
+	     [width (second coords)]
+	     [height (third coords)]
+	     [top-value (exact->inexact (fourth coords))]
+	     [data (list-tail coords 4)]
+	     [2dvec (make-object 2d-vector% width height top-value)]
+	     [normalized-data 
+	      (map (lambda (x) (/ x top-value))
+			      data)])
+	(when (not (= (* width height) (length data)))
+	  (error 'build-image
+		 "data sizes incorrect in file ~s, found ~s expected ~s"
+		 filename (length data) (* width height)))
+	(send 2dvec bend normalized-data)			      
+	2dvec))))
+
+(define build-image
+  (lambda (filename)
+    (let ([error
+	   (lambda ()
+	     (error 'build-image "The file \"~a\" could not be loaded." 
+		    filename)
+	     #f)])
+      (if (regexp-match "\\.gif" filename)
+	  (let ([b (make-object wx:bitmap% filename wx:const-bitmap-type-gif)])
+	    (if (send b ok?)
+		(let ([m (make-object wx:memory-dc%)])
+		  (send m select-object b)
+		  (if (send m ok?)
+		      (let* ([w (send b get-width)]
+			     [h (send b get-height)]
+			     [2dvec (make-object 2d-vector% w h 255)]
+			     [update (ivar 2dvec update)]
+			     [c (make-object wx:colour%)]
+			     [r (ivar c red)]
+			     [g (ivar c green)]
+			     [b (ivar c blue)])
+			(let iloop ([i (sub1 w)])
+			  (let jloop ([j (sub1 h)])
+			    (send m get-pixel i j c)
+			    (let ([r (exact->inexact (r))]
+				  [g (exact->inexact (g))]
+				  [b (exact->inexact (b))])
+			      (update i j (/ (sqrt (/ (+ (* r r) (* g g) (* b b)) 3)) 255)))
+			    (unless (zero? j)
+				    (jloop (sub1 j))))
+			  (unless (zero? i)
+				  (iloop (sub1 i))))
+			2dvec)
+		      (error)))
+		(error)))
+	  (build-pgm-image filename)))))
+
+(define build-memory-dc
+  (lambda (2dvec)
+    (let* ([memory-dc (make-object wx:memory-dc%)]
+	   [set-pixel (ivar memory-dc set-pixel)]
+	   [lookup (ivar 2dvec lookup)]
+	   [width (ivar 2dvec width)]
+	   [height (ivar 2dvec height)]
+	   [bitmap (make-object wx:bitmap% width height)]
+	   [scale (1- num-colors)])
+      (send memory-dc select-object bitmap)
+      (send memory-dc begin-set-pixel)
+      (let loop ([x (1- width)] [y (1- height)])
+	(let* ([l (lookup x y)])
+	  (set-pixel x y (vector-ref colors (floor (* scale l)))))
+	(cond
+	 [(and (zero? y) (zero? x)) (void)]
+	 [(zero? x) (loop (1- width) (1- y))]
+	 [else (loop (1- x) y)]))
+      (send memory-dc end-set-pixel)
+      memory-dc)))
+
+(define get-number-from-user
+  (lambda (message title default)
+    (let* ([input (wx:get-text-from-user message title default)]
+	   [read-in
+	    (read-string
+	     input
+	     (lambda (debug string . rest)
+	       (wx:message-box 
+		(string-append
+		 string
+		 (apply
+		  string-append
+		  (map expr->string rest))))
+	       (apply reg-error debug string rest)))])
+      (if (and (number? read-in)
+	       (positive? read-in)
+	       (integer? read-in))
+	  read-in
+	  (wx:message-box "Expected a positive integer")))))

collects/mrdemo/phone.ss

@@ -0,0 +1,163 @@
+
+(define lookup-number
+  (let ([phonebook '(("Mr. Bumpy" "555-BUMP" "555-SNOT")
+		     ("Squishington" "555-SQSH" "555-BOWL")
+		     ("Miss Molly" "555-MOLL" "555-COMF"))])
+    (lambda (name home?)
+      (sleep 2) ; artificial database delay
+      (let loop ([pb phonebook])
+	(cond
+	 [(null? pb) #f]
+	 [(regexp-match name (caar pb))
+	  ((if home? cadar caddar) pb)]
+	 [else (loop (cdr pb))])))))
+
+(define a-frame 
+  (make-object mred:frame% 
+	       null ; No parent frame 
+	       "Phone Book")) ; The frame's title 
+
+(define a-panel 
+  (make-object mred:vertical-panel% 
+	       a-frame)) ; Panel is in a-frame 
+
+(define h-panel 
+  (make-object mred:horizontal-panel% 
+	       a-panel)) ; Panel is in a-frame 
+
+(define name-text  
+  (make-object mred:text%  
+	       h-panel  
+	       (lambda (self event) (refresh-number-info)) 
+	       "Name"  ; label
+	       ""))    ; initial value
+(define quit-button 
+  (make-object mred:button% 
+	       h-panel 
+	       (lambda (self event)  
+		 (send a-frame show #f)) 
+	       "Quit")) ; Button label
+
+(define number-selector 
+  (make-object mred:radio-box% 
+	       a-panel 
+	       (lambda (self event) (refresh-number-info)) 
+	       "" ; No label 
+	       -1 -1 -1 -1  ; Default position and size 
+	       (list "Home Number" "Office Number")))
+
+(define number-text 
+  (make-object mred:text% 
+	       a-panel 
+	       (lambda (self event) #f) ; No event-handling 
+	       "Number" 
+	       "(Unknown)"))
+(send number-text set-editable #f)
+
+;; First revision: unthreaded
+
+(define refresh-number-info 
+  (lambda () 
+    (let* ([name (send name-text get-value)] 
+	   [home? (zero? (send number-selector get-selection))] 
+	   [number (lookup-number name home?)] 
+	   [number-string (if number 
+			      number 
+			      "(Unknown)")]) 
+      (send number-text set-value number-string))))
+
+;; Second revision: threaded
+
+(define refresh-number-info
+  (let ([adj-cancel-sema (make-semaphore 1)]
+	[previous-cancel (box #f)])
+    (lambda ()
+      (let ([this-cancel (box #f)])
+	(semaphore-wait adj-cancel-sema)
+	(set-box! previous-cancel #t)
+	(set! previous-cancel this-cancel)
+	(semaphore-post adj-cancel-sema)
+	(thread
+	 (lambda ()
+	   (send number-text set-value "(Searching...)")
+	   (let* ([name (send name-text get-value)]
+		  [home? (zero? (send number-selector get-selection))]
+		  [number (lookup-number name home?)] ; May take a while...
+		  [number-string (if number
+				     number
+				     "(Unknown)")])
+	     (semaphore-wait adj-cancel-sema)
+	     (unless (unbox this-cancel)
+		     (send number-text set-value number-string))
+	     (semaphore-post adj-cancel-sema))))))))
+
+;; Make a class:
+
+(define pb-session%
+  (class null ()
+    (public
+      [refresh-number-info
+       (let ([adj-cancel-sema (make-semaphore 1)]
+	     [previous-cancel (box #f)])
+	 (lambda ()
+	   (let ([this-cancel (box #f)])
+	     (semaphore-wait adj-cancel-sema)
+	     (set-box! previous-cancel #t)
+	     (set! previous-cancel this-cancel)
+	     (semaphore-post adj-cancel-sema)
+	     (thread
+	      (lambda ()
+		(send number-text set-value "(Searching...)")
+		(let* ([name (send name-text get-value)]
+		       [home? (zero? (send number-selector get-selection))]
+		       [number (lookup-number name home?)] ; May take a while...
+		       [number-string (if number
+					  number
+					  "(Unknown)")])
+		  (semaphore-wait adj-cancel-sema)
+		  (unless (unbox this-cancel)
+			  (send number-text set-value number-string))
+		  (semaphore-post adj-cancel-sema)))))))])
+    (public
+      (a-frame (make-object mred:frame% null "Phonebook"))
+      (a-panel (make-object mred:vertical-panel% a-frame)))
+    (private
+      (h-panel (make-object mred:horizontal-panel% a-panel))
+      (name-text (make-object mred:text% h-panel
+			      (lambda (self event) (refresh-number-info))
+			      "Name" ""))
+      (quit-button (make-object mred:button% h-panel
+				(lambda (self event) (send a-frame show #f))
+				"Quit"))
+      (number-selector (make-object mred:radio-box% a-panel
+				    (lambda (self event) (refresh-number-info))
+				    "" -1 -1 -1 -1 (list "Home Number" "Office Number")))
+      (number-text (make-object mred:text% a-panel
+				(lambda (self event) #f)
+				"Number" "(Unknown)")))
+    (sequence
+      (send a-frame show #t)
+      (send number-text set-editable #f))))
+
+
+
+(define pb-counted-session%
+  (class pb-session% ()
+    (inherit a-frame a-panel) ; We need to access the panel object...
+    (rename [basic-refresh-number-info refresh-number-info]) ; and old refresh
+    (private [search-counter 0]) ; Counter value
+    (public
+      [refresh-number-info ; Increment the counter and call old refresh
+       (lambda ()
+         (set! search-counter (add1 search-counter))
+         (send counter-text set-value (number->string search-counter))
+         (basic-refresh-number-info))])
+    (sequence
+      (super-init))  ; Do base class initialization
+    (private
+     (counter-text (make-object mred:text% a-panel
+				(lambda (self event) #f)
+				"Number of Searches Started"
+				"0")))
+    (sequence
+     (send counter-text set-editable #f))))

collects/mrdemo/sig.ss

@@ -0,0 +1 @@
+(require-library "sig.ss" "system")

collects/mrdemo/toyproof.ss

@@ -0,0 +1,377 @@
+;; Toy proof checkers implemented with MrEd and units
+;; Kathi Fisler
+;; September 3, 1996
+
+;; This code demonstrates the combined use of MrEd and units to
+;; implement a collection of simple proof checkers.
+
+;; Proof Checker Architecture:
+;;
+;; A proof checker consists of two main components: a list of
+;; operations supported by the checker and the interface through which
+;; the user invokes the checker.  Each of these components is
+;; implemented as a unit in the code below.
+;;
+;; The "operations" unit, (signature prover-core^) provides a list
+;; containing the names of the operations, a list containing the
+;; operations corresponding to the names, and a default operation.
+;;
+;; The "interface" unit (signature interface^) is a compound unit with
+;; subunits corresponding to the various pieces of the interface.
+;; Subunits exist for how the user inputs data to the checker, how the
+;; checker displays results to the user, how the user selects from
+;; among the possible operations, how the user instructs the checker
+;; to check the current data against the selected operation, and how
+;; the user exits the checker.  The interface unit combines these
+;; subunits into a main interface and provides a function
+;; (create-interface) that can be invoked to create a checker with the
+;; specified interface components and the specified operations from
+;; the operations unit.
+
+;; The Collection of Checkers
+;;
+;; Each of the implemented checkers contains three objects into which
+;; the user can enter data and one object through which the checker
+;; displays results.  Two operations units are provided:
+;; proof-core-calculator@ and proof-core-tester@.  The former computes
+;; simple arithmetic functions over the three inputs and the latter
+;; tests boolean-valued relationships between the three inputs.  The
+;; checker displays the values returned by either type of operation.
+;;
+;; Two types of interfaces are possible: one in which the operations
+;; are selected through radio boxes and the other in which the
+;; operations are selected through menu options.
+;;
+;; Three checkers are defined explicitly at the end of the code:
+;; make-calculator/radio, make-checker/radio, and make-checker/menu,
+;; each taking the appropriate combination of the described interface
+;; and operations units.
+
+;;;;; The Implementation ;;;;;
+
+(require-library "trigger.ss")
+
+;;;;; Signature Definitions ;;;;;
+
+(define-signature prover-core^
+  (proof-rule-names proof-rule-checkers default-rule-checker))
+
+(define-signature num-entry-interface^
+  (create-num-entry-interface get-numbers))
+
+(define-signature result-display-interface^
+  (create-result-display-interface show-result))
+
+(define-signature rule-select-interface^
+  (create-rule-select-interface
+   current-proof-rule set-current-proof-rule))
+
+(define-signature compute-interface^
+  (create-compute-interface))
+
+(define-signature quit-interface^
+  (create-quit-interface))
+
+(define-signature main-interface^
+  (create-interface quit-prover))
+
+(define-signature interface^
+  ((open main-interface^)))
+
+;;;;; Compound Unit Definitions ;;;;;
+
+(define interface@
+  (lambda (numentry resdisplay ruleselect compute quit main)
+    (compound-unit/sig
+     (import (MRED : mred^) (CORE : prover-core^))
+     (link
+      (NUMENTRY : num-entry-interface^ (numentry MRED))
+      (RESDISPLAY : result-display-interface^ (resdisplay MRED))
+      (RULESELECT : rule-select-interface^ (ruleselect CORE MRED))
+      (COMPUTE : compute-interface^ (compute RESDISPLAY RULESELECT
+				      NUMENTRY MRED))
+      (QUIT : quit-interface^ (quit MAIN MRED))
+      (MAIN : main-interface^ (main NUMENTRY RESDISPLAY
+				    RULESELECT COMPUTE QUIT MRED))
+      )
+     (export (open MAIN)))))
+
+(define prover@
+  (lambda (core interface)
+    (compound-unit/sig
+     (import (MRED : mred^))
+     (link
+      (CORE : prover-core^ (core))
+      (INTERFACE : interface^ (interface MRED CORE)))
+     (export (open INTERFACE)))))
+
+;;;;; Primitive Unit Definitions ;;;;;
+
+;;;;;;;; Interface Units ;;;;;;;;
+
+(define main-interface-no-menus@
+  (unit/sig main-interface^
+    (import num-entry-interface^ result-display-interface^
+	    rule-select-interface^ compute-interface^
+	    quit-interface^ (mred : mred^))
+    (define outer-frame
+      (make-object mred:frame% `() "Toy Prover"))
+    (define v-panel
+      (make-object mred:vertical-panel% outer-frame))
+    (define upper-hpanel
+      (make-object mred:horizontal-panel% v-panel))
+    (define lower-hpanel
+      (make-object mred:horizontal-panel% v-panel))
+    (define create-interface
+      (lambda ()
+	(create-num-entry-interface upper-hpanel)
+	(create-result-display-interface lower-hpanel)
+	(create-compute-interface upper-hpanel)
+	(create-quit-interface upper-hpanel outer-frame)
+	(create-rule-select-interface lower-hpanel)
+	(send outer-frame show #t)))
+    (define quit-prover
+      (lambda ()
+	(send outer-frame show #f)))
+    ))
+
+(define main-interface-menus@
+  (unit/sig main-interface^
+    (import num-entry-interface^ result-display-interface^
+	    rule-select-interface^ compute-interface^
+	    quit-interface^ (mred : mred^))
+    (define myframe%
+      (class mred:standard-menus-frame% args
+	     (rename [super-make-menu-bar make-menu-bar])
+	     (public
+	      [make-menu-bar
+	       (lambda ()
+		 (let ([mb (super-make-menu-bar)])
+		   (create-rule-select-interface mb)
+		   mb))]
+	      [panel% mred:vertical-panel%]
+	      )
+	     (sequence (apply super-init args))))
+    (define outer-frame
+      (make-object myframe% null "Toy Prover"))
+    (define v-panel (ivar outer-frame panel))
+    (define upper-hpanel
+      (make-object mred:horizontal-panel% v-panel))
+    (define lower-hpanel
+      (make-object mred:horizontal-panel% v-panel))
+    (define create-interface
+      (lambda ()
+	(create-num-entry-interface upper-hpanel)
+	(create-result-display-interface lower-hpanel)
+	(create-compute-interface upper-hpanel)
+	(create-quit-interface upper-hpanel outer-frame)
+	(send outer-frame show #t)))
+    (define quit-prover
+      (lambda ()
+	(send outer-frame show #f)))
+    ))
+
+(define num-entry-interface-3text@
+  (unit/sig num-entry-interface^
+    (import (mred : mred^))
+
+    (define num1 (void))
+    (define num2 (void))
+    (define num3 (void))
+
+    (define create-num-entry-interface
+      (lambda (panel)
+	(set! num1
+	  (make-object mred:text% panel (lambda (self event) #f)
+		       "" ""))
+	(set! num2
+	  (make-object mred:text% panel (lambda (self event) #f)
+		       "" ""))
+	(set! num3
+	  (make-object mred:text% panel (lambda (self event) #f)
+		       "" ""))))
+    
+    (define get-numbers
+      (lambda () 
+	(map string->number
+	     (list (send num1 get-value) 
+		   (send num2 get-value)
+		   (send num3 get-value)))))
+    ))
+
+(define result-display-interface-text@
+  (unit/sig result-display-interface^
+    (import (mred : mred^))
+    
+    (define resdisplay (void))
+
+    (define create-result-display-interface
+      (lambda (panel)
+	(set! resdisplay
+	  (make-object mred:text% panel (lambda (self event) #f) "Result"))
+	))
+    
+    (define show-result
+      (lambda (res)
+	(send resdisplay set-value
+	      (cond ((string? res) res)
+		    ((number? res) (number->string res))
+		    ((boolean? res) (if res "True" "False"))
+		    (error "Argument of Unknown Type")))))
+    ))
+
+(define rule-select-interface-radio@
+  (unit/sig rule-select-interface^
+    (import prover-core^ (mred : mred^))
+    
+    (define current-proof-rule default-rule-checker)
+    
+    (define set-current-proof-rule
+      (lambda (rule)
+	(set! current-proof-rule rule)))
+    
+    (define create-rule-select-interface
+      (lambda (panel)
+	(make-object mred:radio-box%
+		     panel
+		     (lambda (self event)
+		       (set-current-proof-rule
+			(list-ref proof-rule-checkers
+				  (send self get-selection))))
+		     "" -1 -1 -1 -1
+		     proof-rule-names)))
+    ))
+
+(define rule-select-interface-menus@
+  (unit/sig rule-select-interface^
+	    (import prover-core^ (mred : mred^))
+	    (define current-proof-rule default-rule-checker)
+	    
+	    (define set-current-proof-rule
+	      (lambda (rule)
+		(set! current-proof-rule rule)))
+    
+	    (define create-rule-select-interface
+	      (lambda (mb)
+		(let ([rules-menu (make-object mred:menu%)])
+		  (map
+		   (lambda (name checker)
+		     (send rules-menu append-item name
+			   (lambda ()
+			     (set-current-proof-rule checker))))
+		   proof-rule-names
+		   proof-rule-checkers)
+		  (send mb append rules-menu "Rules"))))
+	    ))
+
+(define compute-interface-button@
+  (unit/sig compute-interface^
+    (import result-display-interface^ rule-select-interface^
+      num-entry-interface^ (mred : mred^))
+    (define create-compute-interface
+      (lambda (panel)
+	(make-object mred:button%
+		     panel
+		     (lambda (self event)
+		       (show-result 
+			(apply current-proof-rule (get-numbers))))
+		     "Apply Rule")))))
+
+(define quit-interface-button@
+  (unit/sig quit-interface^
+    (import main-interface^ (mred : mred^))
+    (define create-quit-interface
+      (lambda (panel outer-frame)
+	(make-object mred:button% 
+		     panel
+		     (lambda (self event) (quit-prover))
+		     "Quit")))))
+
+;;;;;;;; Prover Core Units ;;;;;;;;
+
+(define proof-core-calculator@
+  (unit/sig prover-core^
+    (import)
+    (define-struct proof-rule (name checker))
+
+    (define proof-rules
+      (list
+	(make-proof-rule "Add" +)
+	(make-proof-rule "Mult" *)
+	(make-proof-rule "Max" max)))
+
+    (define proof-rule-names (map proof-rule-name proof-rules))
+    (define proof-rule-checkers (map proof-rule-checker proof-rules))
+    (define default-rule-checker (car proof-rule-checkers))))
+
+(define proof-core-tester@
+  (unit/sig prover-core^
+    (import)
+    (define-struct proof-rule (name checker))
+    
+    (define square
+      (lambda (num)
+	(* num num)))
+    
+    (define proof-rules
+      (list
+       (make-proof-rule "Test Add"
+			(lambda (num-1 num-2 num-3)
+			  (= num-3 (+ num-1 num-2))))
+       (make-proof-rule "Test Mult"
+			(lambda (num-1 num-2 num-3)
+			  (= num-3 (* num-1 num-2))))
+       (make-proof-rule "Test Increasing"
+			(lambda (num-1 num-2 num-3)
+			  (and (< num-1 num-2)
+			       (< num-2 num-3))))
+       (make-proof-rule "Test Triangle"
+			(lambda (num-1 num-2 num-3)
+			  (= (square num-3)
+			     (+ (square num-1) (square num-2)))))
+	))
+
+    (define proof-rule-names (map proof-rule-name proof-rules))
+    (define proof-rule-checkers (map proof-rule-checker proof-rules))
+    (define default-rule-checker (car proof-rule-checkers))))
+
+;;;;; Creating Provers ;;;;;
+
+(define make-calculator/radio
+  (lambda ()
+    (invoke-open-unit/sig
+     (prover@ proof-core-calculator@
+	    (interface@ num-entry-interface-3text@
+		      result-display-interface-text@
+		      rule-select-interface-radio@
+		      compute-interface-button@
+		      quit-interface-button@ 
+		      main-interface-no-menus@))
+     #f (mred : mred^))
+    (create-interface)))
+
+(define make-checker/radio
+  (lambda ()
+    (invoke-open-unit/sig
+     (prover@ proof-core-tester@
+	    (interface@ num-entry-interface-3text@
+		      result-display-interface-text@
+		      rule-select-interface-radio@
+		      compute-interface-button@
+		      quit-interface-button@ 
+		      main-interface-no-menus@))
+     #f (mred : mred^))
+    (create-interface)))
+
+(define make-checker/menu
+  (lambda ()
+    (invoke-open-unit/sig
+     (prover@ proof-core-tester@
+	    (interface@ num-entry-interface-3text@
+		      result-display-interface-text@
+		      rule-select-interface-menus@
+		      compute-interface-button@
+		      quit-interface-button@ 
+		      main-interface-menus@))
+     #f (mred : mred^))
+    (create-interface)))

collects/mrdemo/turtles.ss

@@ -0,0 +1,5 @@
+
+(require-library "turtle.ss" "graphics")
+(require-library "turex.ss" "graphics")
+
+(turtles)

collects/mrspidey/Gui/Tframe.ss

@@ -0,0 +1,343 @@
+;; Tframe.ss - creates MrSpidey frames
+; ----------------------------------------------------------------------
+; Copyright (C) 1995-97 Cormac Flanagan
+;
+; This program is free software; you can redistribute it and/or
+; modify it under the terms of the GNU General Public License
+; version 2 as published by the Free Software Foundation.
+; 
+; This program is distributed in the hope that it will be useful,
+; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+; GNU General Public License for more details.
+; 
+; You should have received a copy of the GNU General Public License
+; along with this program; if not, write to the Free Software
+; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
+; ----------------------------------------------------------------------
+
+; Global variable to record the most-recently created frame
+(define tf (void))
+
+(define shake-it-repetitions 25)
+
+(define spidey:frame%
+  (class 
+    (mred:make-searchable-frame% mred:simple-menu-frame%)
+    (arg-main arg-filename summary-edit . init-locs)
+
+    (inherit show get-canvas ;; get-canvas%
+      make-menu create-status-line set-status-text
+      get-position get-size set-icon panel
+      set-title file-menu set-title-prefix
+      set-size)
+
+    ;; ----------
+
+    (rename
+      [super-on-close on-close]
+      [super-make-menu-bar make-menu-bar])
+
+    ;; ----------
+      
+    (public
+
+      [get-edit (lambda () program-edit)]
+      [auto-set-wrap #f]
+      [edit% flow-arrow:media-edit%]    
+      [get-canvas% (lambda () mred:wrapping-canvas%)]
+      [on-close
+        (lambda ignored
+          (send main on-frame-close filename)
+          (send this show #f)
+          (remq-callback-sdl-alg-changed! flush-type-cache)
+          (super-on-close))]
+
+      [set-show-mode
+        (lambda (which)
+          (pretty-debug-gui `(set-show-mode ,which))
+          (unless (eq? which canvas-show-mode)
+            (set! canvas-show-mode which)
+            (send summary-canvas stretchable-in-y (eq? which 'summary))
+            (send panel change-children
+              (lambda (ignore)
+                (filter
+                  (lambda (x) x)
+                  (list 
+                    (and (or (eq? which 'program) (eq? which 'both))
+                      program-canvas)
+                    (and (or (eq? which 'summary) (eq? which 'both))
+                      summary-canvas)))))))]
+
+      ;; ---------- Set up the menus
+      [file-menu:new #f]
+      [file-menu:open #f]
+      [file-menu:revert #f]
+      [file-menu:save #f]
+      [file-menu:save-as #f]
+      ;;[file-menu:print #f]
+      ;;[file-menu:between-print-and-close (lambda args (void))]
+      [file-menu:between-save-and-print (lambda args (void))]
+
+      [edit-menu:undo #f]   
+      [edit-menu:redo #f]
+      [edit-menu:cut #f]
+      [edit-menu:paste #f]
+      [edit-menu:delete #f]
+      ;;[edit-menu:find #f]
+      [edit-menu:replace #f]
+      [edit-menu:between-replace-and-preferences (lambda args (void))]
+
+      [file-menu:close on-close]
+      [file-menu:between-open-and-save
+        (lambda (file-menu)
+          (send file-menu
+            append-item
+            "Open ..."
+            (lambda () (send main open-analyzed-file-choice)))
+          (send file-menu
+            append-item
+            "Open All"
+            (lambda () (wrap-busy-cursor (lambda () (send main open-all #t)))))
+          (send file-menu
+            append-item
+            "Load All"
+            (lambda () (wrap-busy-cursor (lambda () (send main open-all #f)))))
+          (send file-menu
+            append-item
+            "Reanalyze"
+            (lambda () (wrap-busy-cursor (lambda () (send main reanalyze)))))
+          (send file-menu append-separator))]
+      [file-menu:between-close-and-quit
+        (lambda (file-menu)
+          (send file-menu
+            append-item
+            "Close All"
+            ;;(format "Close ~a" st:name)
+            (lambda () 
+              (wrap-busy-cursor 
+                (lambda () 
+                  (send main close-all-frames))))))]
+
+      [flush-type-cache (lambda () (void))]
+
+      [calc-show
+        (lambda ()
+          (set-show-mode 'program)
+          (when (and 
+                  summary-canvas
+                  ;; Show summary only if some real content
+                  (> (send summary-edit last-line) 3))
+            ;;(printf "Summary-edit size ~s~n" (send summary-edit last-line))
+            (set-show-mode 'both)))]
+
+      [make-menu-bar
+        (lambda ()
+          (let ([menu-bar (super-make-menu-bar)])
+            (let ([show-menu (make-menu)])
+              (send menu-bar append show-menu "Show")
+              (set! init-show-menu
+                (lambda ()
+                  (send show-menu
+                    append-check-set
+                    (list 
+                      (cons "Program Only" 'program)
+                      (cons "Summary Only" 'summary)
+                      (cons "Both"         'both))
+                    set-show-mode
+                    (case canvas-show-mode
+                      [(program) 0]
+                      [(summary) 1]
+                      [(both) 2]
+                      [else 0]))))
+                          
+              '(send show-menu append-separator)
+              '(send show-menu
+                 append-check-set
+                 (map (lambda (mode) (cons (mode-name mode) mode))
+                   modes)
+                 set-display-mode))
+
+            (let ([clear-menu (make-menu)])
+              (send menu-bar append clear-menu "Clear")
+              (send* clear-menu
+                (append-item 
+                  "Arrows+Types" 
+                  (lambda () 
+                    (wrap-busy-cursor 
+                      (lambda () 
+                        (send* program-edit 
+                          (delete-arrows)
+                          (delete-types))))
+                    "Removes both types and arrows from the window"))
+                (append-item
+                  "Arrows" 
+                  (lambda () 
+                    (wrap-busy-cursor 
+                      (lambda () 
+                        (send program-edit delete-arrows))))
+                  "Removes all arrows from the window")
+                (append-item
+                  "Types" 
+                  (lambda () 
+                    (wrap-busy-cursor 
+                      (lambda () 
+                        (send program-edit delete-types))))
+                  "Removes all types from the window"))
+              (unless st:restricted
+                (send clear-menu append-item
+                  "Shake Buffer" 
+                  (lambda () (for i 0 shake-it-repetitions (shake-it)))
+                  "Sends random inputs to buffer")
+                (send clear-menu append-item
+                  "Rewrite Buffer" 
+                  (lambda () 
+                    (wrap-busy-cursor 
+                      (lambda () 
+                        (set-display-mode display-mode))))
+                  "Removes all types and arrows from the window")))    
+
+            (let ([filter-menu (make-menu)])
+              (send menu-bar append filter-menu "Filter")
+              (send filter-menu
+                append-check-set
+                (analysis-get-filters)
+                analysis-set-arrow-filter!)
+              (analysis-set-arrow-filter! #f))
+
+            
+
+            menu-bar))]
+
+      [init-show-menu #f]
+      )
+    
+    ;; ----------
+
+    (public
+      [main arg-main]                   ; parent containing the global state
+      program-canvas
+      program-edit
+      summary-canvas                    ; or #f if no summary
+      [filename arg-filename]
+
+      [canvas-show-mode 'none]          ; 'program, 'summary, or 'both
+      [display-mode  (car modes)]       ; which display mode
+
+      [set-display-mode
+        (lambda (which)
+          (set! display-mode which)
+          (pretty-debug-gui `(set-display-mode ,display-mode ,filename))
+          ;; Call main to create a new edit buffer,
+          ;; and to load and annotate file
+          (set! program-edit 
+            (send main annotated-edit display-mode filename program-canvas))
+          (send program-canvas set-media program-edit))]
+
+      [focus-def
+        (lambda (pos)
+          (unless (memq display-mode '(program both))
+            (set-show-mode 'both))
+          (let* ( [real-pos (send program-edit real-start-position pos)]
+                  [end (mred:scheme-forward-match 
+                         program-edit real-pos 
+                         (send program-edit last-position))])
+            (thread
+              (lambda ()
+                (sleep)
+                (send program-canvas set-focus)
+                (send program-edit
+                  set-position-bias-scroll -1 real-pos end)))))]
+
+      [shake-it
+        (lambda ()
+          (send program-edit shake-it))]
+
+      ;; ----------
+
+      )
+	
+    (sequence 
+      (pretty-debug-gui
+        `(Tframe ,arg-main ,arg-filename ,summary-edit ,@init-locs))
+      (match init-locs
+        [(w h x y) 
+          (pretty-debug-gui `(send this set-size ,(+ x 15) ,(+ y 15) ,w ,h))
+          (set-size x y w h)]
+        [() (void)])
+      (pretty-debug-gui `(Tframe super-init))
+      (let ([t (format "~a: ~a" 
+                 st:name (file-name-from-path arg-filename))]) 
+        (super-init t)
+        (pretty-debug-gui `(Tframe super-init done))
+        (set-title-prefix t)))
+
+    	
+    ;; ---------------------------------------------------------
+
+    (sequence
+      (set! flush-type-cache
+        (lambda ()
+          (pretty-debug-gui '(Tframe flush-type-cache))
+          (unless (void? program-edit) 
+            (send program-edit flush-type-cache))))
+
+      (add-callback-sdl-alg-changed! flush-type-cache)
+
+      (pretty-debug-gui
+        `(Tframe ,arg-main ,arg-filename ,summary-edit ,@init-locs))
+      (set! tf this)
+
+      ;; ------------------------------------------------------------
+      ;; build the canvases
+
+      (pretty-debug-gui '(setting summary-canvas))
+      (set! summary-canvas
+        (and summary-edit
+          (let ([c 
+                  ;(make-object (get-canvas%) panel)
+                  (make-object (class-asi mred:one-line-canvas%
+                                 (public
+                                   [lines 5]
+                                   [style-flags 0]))
+                    panel) 
+                  ])
+            ;;(send c set-lines 2)
+            (send c set-media summary-edit)
+            c)))
+      (assert (is-a? summary-canvas mred:connections-media-canvas%))
+      (pretty-debug-gui '(setting program-canvas))
+      (set! program-canvas (get-canvas))
+      (set-display-mode (car modes))
+      (pretty-debug-gui '(done setting canvases))
+
+      ;; ------------------------------------------------------------
+      ;; install the icon
+      
+      '(let ([icon (make-object wx:icon% 
+                     (build-absolute-path 
+                       (collection-path "mrspidey") ; MATTHEW: got rid of plt-home
+                       "icon.gif")
+                     wx:const-bitmap-type-gif
+                     )])
+         (when (send icon ok?) (set-icon icon)))
+
+      ;; ------------------------------------------------------------
+      ;; status help line 
+
+      ;;(unless (eq? mred:platform 'macintosh)
+      ;;  (create-status-line))
+
+      ;;(set-status-text 
+      ;; "Mouse: Left-type/parents  Midde-Ancestors  Right-Close")
+
+      ;; ------------------------------------------------------------
+
+      ;;(set-display-mode display-mode)
+      (calc-show)
+      (init-show-menu)
+      (show #t)
+      
+      )))
+
+

collects/mrspidey/Gui/arrow.ss

@@ -0,0 +1,137 @@
+; arrow.ss
+; defines arrow:media-edit%, an extention of graphics:media-edit% with arrows
+; ----------------------------------------------------------------------
+; Copyright (C) 1995-97 Cormac Flanagan
+;
+; This program is free software; you can redistribute it and/or
+; modify it under the terms of the GNU General Public License
+; version 2 as published by the Free Software Foundation.
+; 
+; This program is distributed in the hope that it will be useful,
+; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+; GNU General Public License for more details.
+; 
+; You should have received a copy of the GNU General Public License
+; along with this program; if not, write to the Free Software
+; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
+; ----------------------------------------------------------------------
+
+(define arrow:media-edit%
+  (let* ([pi (* 2 (asin 1))]
+         [arrow-head-angle (/ pi 8)]
+         [cos-angle (cos arrow-head-angle)]
+         [sin-angle (sin arrow-head-angle)]
+         [arrow-head-size 10]
+         [arrow-root-radius 3.5]
+         [cursor-arrow (make-object wx:cursor% wx:const-cursor-arrow)])
+
+    (class-asi graphics:media-edit%
+      (inherit delete-graphic draw-graphics add-graphic set-cursor)
+      (public
+        [delete-arrow (lambda (arrow) (delete-graphic arrow))]
+        [draw-arrows  (lambda () (draw-graphics))]
+        [add-arrow
+         (lambda (start-pos start-dx start-dy 
+                   end-pos end-dx end-dy
+                   delta brush pen
+                   clickback-head clickback-root)
+           (pretty-debug-gui (list 'add-arrow 
+                               start-pos start-dx start-dy
+                               end-pos end-dx end-dy
+                               delta clickback-head clickback-root))
+           (add-graphic 
+            (list start-pos end-pos)
+            (match-lambda
+             [((start-x . start-y) (end-x . end-y))
+               (pretty-debug-gui
+                 `(locs ,start-x ,start-y ,end-x ,end-y
+                    ,start-dx ,start-dy ,end-dx ,end-dy))
+              (let* 
+                  ([start-x (+ start-x start-dx)]
+                   [start-y (+ start-y start-dy)]
+                   [end-x   (+ end-x end-dx)]
+                   [end-y   (+ end-y end-dy)]
+                   [ofs-x   (- start-x end-x)]
+                   [ofs-y   (- start-y end-y)]
+                   [len     (sqrt (+ (* ofs-x ofs-x) (* ofs-y ofs-y)))]
+                   [ofs-x   (/ ofs-x len)]
+                   [ofs-y   (/ ofs-y len)]
+                   [head-x  (* ofs-x arrow-head-size)]
+                   [head-y  (* ofs-y arrow-head-size)]
+                   [end-x   (+ end-x (* ofs-x delta))]
+                   [end-y   (+ end-y (* ofs-y delta))]
+                   [pt1     (make-object wx:point% end-x end-y)]
+                   [pt2     (make-object 
+                             wx:point%
+                             (+ end-x (* cos-angle head-x) 
+                                (* sin-angle head-y))
+                             (+ end-y (- (* sin-angle head-x))
+                                (* cos-angle head-y)))]
+                   [pt3     (make-object 
+                             wx:point%
+                             (+ end-x (* cos-angle head-x)
+                                (- (* sin-angle head-y)))
+                             (+ end-y (* sin-angle head-x)
+                                (* cos-angle head-y)))]
+                   [pts (list pt1 pt2 pt3)]
+                   [draw-fn
+                    (lambda (dc dx dy)
+                      '(pretty-debug-gui
+                        (list 'draw-line (+ start-x dx) (+ start-y dy)
+                              (+ end-x dx) (+ end-y dy)))
+                      (let ([old-brush (send dc get-brush)]
+                            [old-pen   (send dc get-pen)]
+                            [old-logfn (send dc get-logical-function)])
+                        (send dc set-brush brush)
+                        (send dc set-pen pen)
+                        ;; (send dc set-logical-function wx:const-or)
+                        (send dc draw-line
+                              (+ start-x dx) (+ start-y dy)
+                              (+ end-x dx) (+ end-y dy))
+                        (send dc draw-polygon pts dx dy)
+                        (send dc draw-ellipse 
+                              (- (+ start-x dx) arrow-root-radius)
+                              (- (+ start-y dy) arrow-root-radius)
+                              (* 2 arrow-root-radius)
+                              (* 2 arrow-root-radius))
+                        (send dc set-brush old-brush)
+                        (send dc set-pen old-pen)                    
+                        (send dc set-logical-function old-logfn)))]
+                   [on-head?
+                    (lambda (x y)
+                      (let*
+                          ([xs (map (lambda (pt) (send pt get-x)) pts)]
+                           [ys (map (lambda (pt) (send pt get-y)) pts)]
+                           [min-x (apply min xs)]
+                           [min-y (apply min ys)]
+                           [max-x (apply max xs)]
+                           [max-y (apply max ys)])
+                        (and (>= x min-x)
+                             (<= x max-x)
+                             (>= y min-y)
+                             (<= y max-y))))]
+                   [on-root?
+                    (lambda (x y)
+                      (and (>= x (- start-x arrow-root-radius))
+                           (<= x (+ start-x arrow-root-radius))
+                           (>= y (- start-y arrow-root-radius))
+                           (<= y (+ start-y arrow-root-radius))))]
+                   [event-fn
+                    (lambda (event x y)
+                      (cond
+                       [(on-head? x y)
+                        (set-cursor cursor-arrow)
+                        (clickback-head event)]
+                       [(on-root? x y)
+                        (set-cursor cursor-arrow)
+                        (clickback-root event)]
+                       [else 
+                         ;; Back to default cursor
+                         ;; (set-cursor '())
+                        #f]))])
+
+                ;; Return draw-thunk and event function
+                (cons draw-fn event-fn))])))]))))
+
+;; ----------------------------------------

collects/mrspidey/Gui/deltas.ss

@@ -0,0 +1,108 @@
+; deltas.ss
+; Loads configuration from .Xresources
+; ----------------------------------------------------------------------
+; Copyright (C) 1995-97 Cormac Flanagan
+;
+; This program is free software; you can redistribute it and/or
+; modify it under the terms of the GNU General Public License
+; version 2 as published by the Free Software Foundation.
+; 
+; This program is distributed in the hope that it will be useful,
+; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+; GNU General Public License for more details.
+; 
+; You should have received a copy of the GNU General Public License
+; along with this program; if not, write to the Free Software
+; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
+; ----------------------------------------------------------------------
+
+;; Given a resource name, this returns a style delta corresponding to the 
+;; attributes of the file or the default if there are none.
+
+(define (get-resource-maybe s2 default)
+  (let ([val-box (box default)])
+    (wx:get-resource 
+     (if (wx:colour-display?) "mrspidey" "mrspidey-bw")
+     s2 
+     val-box)
+    (unbox val-box)))
+
+(define delta-eval-namespace (make-namespace))
+(parameterize ([current-namespace delta-eval-namespace])
+    (invoke-open-unit/sig wx@ wx))
+
+(define delta-add-string! 
+  (lambda (delta string)
+  (let ([p (open-input-string string)])
+    (recur loop ()
+      (let ([e (read p)])
+        (unless (eof-object? e)
+          (apply (uq-ivar delta (car e)) (eval `(list ,@(cdr e)) delta-eval-namespace))
+          (loop)))))))
+
+(define set-resource-delta
+  (lambda (name default-string default-string-bw delta)
+    (delta-add-string! delta 
+                       (if (wx:colour-display?) 
+                           default-string 
+                           default-string-bw))
+    (delta-add-string! delta (get-resource-maybe name ""))))
+
+(define make-resource-delta
+  (lambda (name default-string default-string-bw)
+    (let ([delta (make-object wx:style-delta% 
+                              wx:const-change-alignment wx:const-align-top)])
+      '(set-resource-delta "base-delta"
+                          "(set-delta wx:const-change-normal) \
+                           (set-delta wx:const-change-family wx:const-modern) \
+                           (set-alignment-on wx:const-align-top) "
+                          "(set-delta wx:const-change-normal) \
+                           (set-delta wx:const-change-family wx:const-modern) \
+                           (set-alignment-on wx:const-align-top)"
+                          delta)
+      (set-resource-delta name default-string default-string-bw delta)
+      delta)))
+
+;; ----------------------------------------------------------------------
+;; These deltas are defined when the application starts, either from defaults
+;; or from resources, their names and their strings agree.
+
+(define base-delta
+  (make-resource-delta "base-delta" 
+                       "(set-delta wx:const-change-normal) \
+                           (set-delta wx:const-change-family wx:const-modern) \
+                           (set-alignment-on wx:const-align-top) "
+                          "(set-delta wx:const-change-normal) \
+                           (set-delta wx:const-change-family wx:const-modern) \
+                           (set-alignment-on wx:const-align-top)"))
+
+(define normal-delta
+  (make-resource-delta "normal-delta"
+                       "" ""))
+
+(define type-link-delta 
+  (make-resource-delta "type-link-delta"
+                       "(set-delta wx:const-change-bold)"
+                       "(set-delta wx:const-change-bold)"))
+(define type-delta
+  (make-resource-delta "type-link-delta"
+                       ""
+                       ""))
+
+(define check-delta 
+  (make-resource-delta "check-delta"
+                       "(set-delta-foreground \"RED\")"
+                       "(set-delta wx:const-change-underline 1)"))
+(define uncheck-delta
+  (make-resource-delta "uncheck-delta"
+                       "(set-delta-foreground \"FORESTGREEN\")"
+                       ""))
+
+(define check-link-delta
+  (make-resource-delta "check-link-delta" 
+                       "(set-delta-foreground \"BLUE\") \
+                        (set-delta wx:const-change-underline 1)"
+                       "(set-delta wx:const-change-underline 1)"))
+
+;; ----------------------------------------------------------------------

collects/mrspidey/Gui/dyn-edit.ss

@@ -0,0 +1,193 @@
+; dyn-edit
+;
+; Defines spidey:dynamic+margin-edit%, a subclass of spidey:static-edit%
+; with an insert-line method that also inserts a margin
+; and it handles adding and deleting snips
+; while still allowing static positions in the buffer
+;
+; ----------------------------------------------------------------------
+; Copyright (C) 1995-97 Cormac Flanagan
+;
+; This program is free software; you can redistribute it and/or
+; modify it under the terms of the GNU General Public License
+; version 2 as published by the Free Software Foundation.
+; 
+; This program is distributed in the hope that it will be useful,
+; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+; GNU General Public License for more details.
+; 
+; You should have received a copy of the GNU General Public License
+; along with this program; if not, write to the Free Software
+; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
+; ----------------------------------------------------------------------
+
+(define spidey:dynamic+margin-edit%
+  (class spidey:static-edit% (arg-margin . init-args)
+    (inherit 
+      set-auto-set-wrap
+      load-file last-position position-line
+      lock get-style-list 
+      begin-edit-sequence end-edit-sequence edit-sequence
+      
+      change-style
+      set-clickback
+      flash-on
+      set-position
+      scroll-to-position
+      get-text
+      insert
+      delete
+      set-tabs
+      )
+
+    (public
+      ;; ----------
+      margin 
+      margin-length
+      ;[margin "  "]
+      ;[margin-length 2]
+
+      ;; keeps a list of all the snips in their source-locations
+      [sniplist ()]
+
+      [insert-line
+        (lambda (s)
+          (insert margin)
+          (insert s)
+          (insert (string #\newline)))]
+
+      ;; ----------
+
+      [account-for-margin
+        (lambda (pos) 
+          (recur loop ([try pos])
+            ;;(pretty-debug-gui `(accout-for-margin ,pos ,try))
+            (let ([better
+                    (+ pos 
+                      (* margin-length (add1 (position-line (+ try 0)))))])
+              (if (= better try)
+                try
+                (loop better)))))]
+      [real-start-position
+        (lambda (pos)
+          (account-for-margin
+            (let loop ([l sniplist])
+              (cond
+                [(null? l) pos]
+                [(> pos (car l)) (add1 (loop (cdr l)))]
+                [else (loop (cdr l))]))))]
+      [real-end-position
+        (lambda (pos)
+          (account-for-margin
+            (let loop ([l sniplist])
+              (cond
+                [(null? l) pos]
+                [(>= pos (car l)) (add1 (loop (cdr l)))]
+                [else (loop (cdr l))]))))]
+      [old-real-end-position
+        (lambda (pos)
+          (let ([pos pos])
+            (let loop ([l sniplist][pos pos])
+              (cond
+                [(null? l) (account-for-margin pos)]
+                [(>= pos (car l))  
+                  (loop (cdr l) (add1 pos))]
+                [else (loop (cdr l) pos)]))))]
+      [frame-pos->source-pos
+        (lambda (pos)
+          (assert (number? pos) 'frame-pos->source-pos)
+          (let ([pos (- pos (* margin-length (add1 (position-line pos))))])
+            (let loop ([l sniplist])
+              (cond
+                [(null? l) pos]
+                [(> pos (car l))
+                  (sub1 (loop (cdr l)))]
+                [else (loop (cdr l))]))))]
+
+      ;; ----------
+
+      [relocate-change-style
+        (lambda (delta src-start src-end)
+          (let ([s (real-start-position src-start)]
+                 [e (real-end-position src-end)])
+            (pretty-debug-gui `(change-style ,src-start ,src-end ,s ,e))
+            (change-style delta s e)))]
+			
+      [relocate-set-clickback
+        (lambda (src-start src-end . args)
+          (apply set-clickback
+            (real-start-position src-start)
+            (real-end-position src-end)
+            args))]
+      [relocate-flash-on
+        (lambda (src-start src-end a b c)
+          (flash-on (real-start-position src-start)
+            (real-end-position src-end) a b c))]
+      [relocate-scroll-to-position
+        (lambda (pos)
+          (let ([real-pos (real-start-position pos)])
+            '(pretty-print `(scroll-to-position ,pos ,real-pos))
+            (set-position real-pos)
+            (scroll-to-position real-pos)))]
+      ;;
+      ;; watch this function......
+      [relocate-set-position
+        (opt-lambda
+          (pos [end -1][eol #f][scroll #t])
+          (let ([end (if (= end -1) -1 (real-end-position end))])
+            (set-position (real-start-position pos) end
+              eol scroll)))]
+      [match-paren-forward
+        (lambda (source-start)
+          (frame-pos->source-pos (mred:scheme-forward-match
+                                   this (real-start-position source-start)
+                                   (last-position))))]
+	       
+      [relocate-get-text
+        (opt-lambda ([start -1][end -1][flat #f])
+          (get-text (real-start-position start)
+            (real-end-position end) flat))]
+      [select-snip
+        (lambda (pos snip)
+          (edit-sequence
+            (lambda ()
+              (send (send snip get-this-media) own-caret #f)
+              (set-position 
+                (real-end-position pos) (real-start-position pos)))))]
+      [relocate-insert-snip
+        (lambda (snip pos)
+          ;;(lock #f)
+          (when (member pos sniplist)
+            (error "Cannot put two snips in the same position~n"))
+          (let ([real-pos (real-start-position pos)])
+            (set! sniplist (cons pos sniplist))
+            (insert snip real-pos))
+          ;;(lock #t)
+          )]
+      [relocate-delete-snip
+        (lambda (pos)
+          (unless (member pos sniplist)
+            (error  "Cannot remove snip from ~s" pos))
+          (set! sniplist (remv pos sniplist))
+          (let ([pos (real-start-position pos)])
+            (delete pos (add1 pos))))]
+      )
+
+    (sequence
+      (apply super-init init-args)
+      (set! margin arg-margin)
+      (set! margin-length (string-length margin))
+
+      (set-auto-set-wrap #f)
+      ;; set-tabs doesn't work right past list of specified tabs
+      ;; so specify all tabs to column 200
+      (set-tabs 
+        (recur loop ([p margin-length])
+          (if (< p 200) 
+            (cons p (loop (+ p 8)))
+            '()))
+        8
+        #f)
+      )))
+

collects/mrspidey/Gui/graphics.ss

@@ -0,0 +1,147 @@
+; graphics.ss
+; Defines graphics:media-edit%, a subclass of spidey:dynamic+margin-edit%
+; with facilities for graphics on top of text
+;
+; ----------------------------------------------------------------------
+; Copyright (C) 1995-97 Cormac Flanagan
+;
+; This program is free software; you can redistribute it and/or
+; modify it under the terms of the GNU General Public License
+; version 2 as published by the Free Software Foundation.
+; 
+; This program is distributed in the hope that it will be useful,
+; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+; GNU General Public License for more details.
+; 
+; You should have received a copy of the GNU General Public License
+; along with this program; if not, write to the Free Software
+; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
+; ----------------------------------------------------------------------
+
+(define-structure (graphic pos* locs->thunks draw-fn click-fn))
+
+(define graphics:media-edit%
+  (class spidey:dynamic+margin-edit% args
+    (inherit set-cursor)
+    (rename
+      [super-after-insert after-insert]
+      [super-after-delete after-delete]
+      [super-on-paint on-paint]
+      [super-on-event on-event]
+      [super-resized resized]
+      [super-size-cache-invalid size-cache-invalid])
+
+    (public
+      [graphics-list ()]
+      [pos->locs
+       (lambda (pos)
+         (let* ([xb (box 0)]
+                [yb (box 0)]
+                [real-pos (send this real-start-position pos)] )
+           (send this position-location real-pos xb yb #t)
+           (pretty-debug-gui 
+             `(pos->locs ,pos ,real-pos ,(unbox xb) ,(unbox yb)))
+           (cons (unbox xb) (unbox yb))))]
+      [calc-graphic-thunks!
+       (lambda (graphic)
+         (match-let*
+             ([locs (map pos->locs (graphic-pos* graphic))]
+              [locs->thunks (graphic-locs->thunks graphic)]
+              [(draw-fn . click-fn) (locs->thunks locs)])
+           (set-graphic-draw-fn! graphic draw-fn)
+           (set-graphic-click-fn! graphic click-fn)))]
+      [recalc-graphics
+       (lambda ()
+         '(pretty-debug-gui `(recalc-graphics ,@graphics-list))
+         (for-each calc-graphic-thunks! graphics-list))]
+      [add-graphic
+       (lambda (pos* locs->thunks)
+         (pretty-debug-gui (list 'add-graphic pos* locs->thunks))
+         (let ([graphic (make-graphic pos* locs->thunks 0 0)])
+           (calc-graphic-thunks! graphic)
+           (set! graphics-list (cons graphic graphics-list))
+           graphic))]
+      [delete-graphic
+       (lambda (graphic)
+         '(pretty-debug-gui `(delete-graphic ,graphic))
+         (set! graphics-list (remv graphic graphics-list)))]
+      [draw-graphics
+       (lambda ()
+         (let ([admin (send this get-admin)])
+           (pretty-debug-gui `(draw-graphics))
+           (send this invalidate-bitmap-cache)
+
+           ;; Kludge to get redrawing right
+           ;;(send super before-insert 0 1)
+           ;;(send super after-insert 0 1)
+
+           '(unless (null? admin)
+              (send admin needs-update 0 0 100000 100000))
+           '(pretty-debug-gui `(draw-graphics-done))))]
+
+      ;; overwritten methods
+      [resized
+       (lambda (snip redraw-now)
+         '(pretty-debug-gui `(resized ,snip ,redraw-now))
+         (super-resized snip redraw-now)
+         (recalc-graphics)
+         (when redraw-now (draw-graphics)))]
+
+      [after-delete
+       (lambda (start len)
+         '(pretty-debug-gui `(after-delete ,start ,len))
+         (super-after-delete start len)
+         (recalc-graphics)
+         (draw-graphics))]
+
+      [after-insert
+       (lambda (start len)
+         '(pretty-debug-gui `(after-insert ,start ,len))
+         (super-after-insert start len)
+         (recalc-graphics)
+         (draw-graphics))]
+      [size-cache-invalid
+        (lambda ()
+          (super-size-cache-invalid)
+          (recalc-graphics))]          
+
+      [on-paint
+       (lambda (before dc left top right bottom dx dy draw-caret)
+         (super-on-paint
+          before dc left top right bottom 
+          dx dy draw-caret)
+         (unless before 
+             '(pretty-debug-gui `(on-paint))
+           (for-each
+            (match-lambda
+             [($ graphic pos* locs->thunks draw-fn click-fn)
+              '(pretty-debug-gui (list 'on-paint-graphic pos*))
+              (draw-fn dc dx dy)])
+            graphics-list)))]
+
+      [on-event
+       (lambda (event)
+         (set-cursor '())
+         (let* ([admin (send this get-admin)]
+                [root-x (box 0)]
+                [root-y (box 0)])
+           (send admin get-dc root-x root-y)
+           (let ([actual-x (+ (send event get-x) (unbox root-x))]
+                 [actual-y (+ (send event get-y) (unbox root-y))])
+
+             ;; Now try to find a clickback to handle it
+             (let loop ([graphics graphics-list])
+               (match graphics
+                 [() (super-on-event event)]
+                 [(($ graphic _ _ _ click-fn) . rest-graphics) 
+                  (or (click-fn event actual-x actual-y)
+                      ;; Otherwise try next graphic
+                      (loop rest-graphics))])))))]
+      ) 
+    (sequence
+      ;;(pretty-debug-gui `(init graphic:media-edit% ,@init))
+      (apply super-init args)
+      )))
+
+;; ----------------------------------------

collects/mrspidey/Gui/load.ss

@@ -0,0 +1,29 @@
+;; load.ss - loads gui files
+; ----------------------------------------------------------------------
+; Copyright (C) 1995-97 Cormac Flanagan
+;
+; This program is free software; you can redistribute it and/or
+; modify it under the terms of the GNU General Public License
+; version 2 as published by the Free Software Foundation.
+; 
+; This program is distributed in the hope that it will be useful,
+; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+; GNU General Public License for more details.
+; 
+; You should have received a copy of the GNU General Public License
+; along with this program; if not, write to the Free Software
+; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
+; ----------------------------------------------------------------------
+
+(load-relative "deltas.ss")
+(load-relative "statedit.ss")
+(load-relative "dyn-edit.ss")
+(load-relative "graphics.ss")
+(load-relative "arrow.ss")
+(load-relative "annotat.ss")
+;(load-relative "paramenu.ss")
+;(load-relative "option.ss")
+(load-relative "prefs.ss")
+(load-relative "Tframe.ss")
+(load-relative "main.ss")

collects/mrspidey/Gui/loadu.ss

@@ -0,0 +1,42 @@
+;; loadu.ss - loads graphic files into a unit
+; ----------------------------------------------------------------------
+; Copyright (C) 1995-97 Cormac Flanagan
+;
+; This program is free software; you can redistribute it and/or
+; modify it under the terms of the GNU General Public License
+; version 2 as published by the Free Software Foundation.
+; 
+; This program is distributed in the hope that it will be useful,
+; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+; GNU General Public License for more details.
+; 
+; You should have received a copy of the GNU General Public License
+; along with this program; if not, write to the Free Software
+; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
+; ----------------------------------------------------------------------
+
+(define-signature mrspidey-gui^ (spidey))
+
+(define mrspidey-gui@
+  (unit/sig mrspidey-gui^
+    (import
+      [wx : wx^]
+      [mred : mred^]
+      mzlib:unprefixed-core^
+      mrspidey:sba^
+      mrspidey:interaction^)
+
+    (include "deltas.ss")
+    (include "statedit.ss")
+    (include "dyn-edit.ss")
+    (include "graphics.ss")
+    (include "arrow.ss")
+    (include "annotat.ss")
+    ;(include "paramenu.ss")
+    ;(include "option.ss")
+    (include "prefs.ss")
+    (include "Tframe.ss")
+    (include "main.ss")
+
+    ))

collects/mrspidey/Gui/main.ss

@@ -0,0 +1,553 @@
+; main.ss
+; Defines main MrSpidey class
+; ----------------------------------------------------------------------
+; Copyright (C) 1995-97 Cormac Flanagan
+;
+; This program is free software; you can redistribute it and/or
+; modify it under the terms of the GNU General Public License
+; version 2 as published by the Free Software Foundation.
+; 
+; This program is distributed in the hope that it will be useful,
+; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+; GNU General Public License for more details.
+; 
+; You should have received a copy of the GNU General Public License
+; along with this program; if not, write to the Free Software
+; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
+; ----------------------------------------------------------------------
+
+(define-structure (fileinfo filename frame thunk-port annotations))
+;; annotations may also be (-> zodiac:parsed)
+
+(define NUM-EXTRA-LINES 20)
+
+(define-struct exn:flow-arrow-exists ())
+
+(define (wrap-busy-cursor thunk)
+  (dynamic-wind
+    (lambda () (wx:begin-busy-cursor))
+    thunk
+    (lambda () (wx:end-busy-cursor))))
+
+; ----------------------------------------------------------------------
+(define tm (void))
+
+(define MrSpidey%
+  (class null ()
+
+    (public 
+
+      [fileinfo* '()]
+      [multiple-files
+        (lambda ()
+          (not (= (length fileinfo*) 1)))]
+      ;; ------------------------------
+      ;; Progress frame
+
+      [progress-frame 'progress-frame]
+      [progress-canvas 'progress-canvas]
+      [progress-edit 'progress-edit]
+
+      [init-progress-frame!
+       (lambda ()
+         (pretty-debug-gui `(init-progress-frame))
+         (let* ( [f (parameterize
+                      ([wx:current-eventspace (wx:make-eventspace)])
+                      (make-object mred:frame% '() 
+                        (format "~a Progress" st:name)))]
+                 [p (make-object mred:vertical-panel% f)]
+                 [c (make-object mred:wrapping-canvas% p)]
+                 [ph (make-object mred:horizontal-panel% p)]
+                 [_ (send ph stretchable-in-y #f)]
+                 [_ (make-object mred:horizontal-panel% ph)]
+                 [b (make-object mred:button% ph 
+                      (lambda _ (send f show #f))
+                      "Hide")]
+                 [e (make-object mred:media-edit%)])
+           (set! progress-frame f)
+           (set! progress-canvas c)
+           (set! progress-edit e)
+           (send p add-child c)
+           ;;(send c set-media e)
+           (send progress-frame set-size -1 -1 400 200);; ht was 130
+           (send progress-frame show #f)))]
+
+      [new-progress-frame!
+       (lambda ()
+         (pretty-debug-gui `(new-progress-frame))
+         (set! progress-edit (make-object mred:media-edit%))
+         (send progress-edit lock #t)
+         (send progress-canvas set-media progress-edit)
+         (send progress-frame show #t)
+         (send progress-frame iconize #f)
+         (pretty-debug-gui `(new-progress-frame-done)))]
+
+      [with-progress-frame
+       (lambda (thunk)
+           (let*
+               ( [old-progress-handler (mrspidey:progress-handler)]
+                 [current '()]
+
+                 [current-start-time 0]
+                 [width 6]
+                 [total-width 18])
+             (letrec
+                 ([insert-numbers
+                    (lambda (n)
+                      (send progress-edit insert
+                        (format "~a    ~ams" 
+                          (padl 
+                            (if (eq? n 'done) "" (format "~a" n))
+                             width)
+                          (padl (- (current-process-milliseconds) 
+                                  (current-gc-milliseconds)
+                                  current-start-time)
+                            width))
+                        (send progress-edit last-position)))]
+                   [f (match-lambda*
+                      [((? string? name) line)
+                       (if (equal? name current)
+                         (let ([end (send progress-edit last-position)])
+                           (send progress-edit delete 
+                             (- end total-width) end)
+                           (insert-numbers line))
+                         (begin
+                           (f 'fresh-line)
+                           (set! current name)
+                           (set! current-start-time
+                             (- (current-process-milliseconds) 
+                               (current-gc-milliseconds)))
+                           (send progress-edit insert 
+                             (padr name 30))
+                           (insert-numbers line)))]
+                      [((? string? str)) 
+                       (f 'fresh-line)
+                       (send progress-edit insert str)
+                       (f #\newline)]
+                      [(#\newline)
+                       (send progress-edit  insert (format "~n"))
+                       (set! current '())]
+                      [('fresh-line)
+                       (unless (null? current) (f #\newline))])]
+                  [g (lambda args
+                       (send progress-edit lock #f)
+                       (apply f args)
+                       (send progress-edit lock #t))])
+               (parameterize 
+                 ([mrspidey:progress-handler 
+                    (lambda args
+                      ;;(apply old-progress-handler args)
+                      (apply g args)
+                      (wx:flush-display))])
+                 (send progress-frame show #t)
+                 (begin0 
+                   (thunk)
+                   (mrspidey:progress
+                     "=Done======================================"))))))]
+
+      ;; ------------------------------
+
+      [filename->fileinfo
+       (lambda (file)
+         (pretty-debug-gui `(filename->fileinfo ,file))
+         (or
+           (ormap
+             (match-lambda
+               [(and fi ($ fileinfo filename frame))
+                 (and (string? file)
+                   (string=? filename file)
+                   fi)])
+             fileinfo*)
+           (assert #f 'filename->fileinfo file)))]
+
+      [filename->frame
+       (lambda (file)
+         (let ([x (filename->fileinfo file)])
+           (and x (fileinfo-frame x))))]
+
+      [filename->edit
+       (lambda (file)
+         (let ([x (filename->frame file)])
+           (and x (ivar x program-edit))))]
+
+      [for-each-frame
+       (lambda (f)
+         (for-each
+          (match-lambda
+           [($ fileinfo filename frame)
+            (when frame (f frame))])
+          fileinfo*))]
+
+      [focus-def
+       (lambda (loc)
+         (assert (zodiac:location? loc) 'focus-def loc)
+         (let* ([file (zodiac:location-file loc)]
+                [frame (filename->frame file)])
+           (if frame
+               (send frame focus-def (zodiac:location-offset loc))
+               (wx:message-box
+                (format "File ~s is not loaded" (file-name-from-path file))
+                "Error"
+                (bitwise-ior wx:const-ok)))))]
+
+      ;; ------------------------------
+
+      [open-analyzed-file-choice
+        (lambda ()
+          (let ([choice
+                  (wx:get-single-choice
+                    "Select referenced unit file to open"
+                    "Open Unit"
+                    (sort string<? (map fileinfo-filename fileinfo*))
+                    '() -1 -1 #t 500 300)])
+            (when (string? choice)
+              (open-fileinfo (filename->fileinfo choice) #t))))]
+
+      [open-fileinfo
+       (match-lambda*
+        [((and fi ($ fileinfo filename frame)) show)
+         (if frame
+             (when show
+               (send frame show #t)
+               (send frame iconize #f))
+             (add-frame fi show))])]
+
+      [open-all
+       (lambda (show) 
+         (for-each 
+           (lambda (fi) (open-fileinfo fi show))
+           fileinfo*))]
+
+      [add-frame
+       (match-lambda*
+        [( (and fi ($ fileinfo filename frame thunk-port thunk-expression))
+           show
+           . first-frame-locs)
+         (pretty-debug-gui
+           `(add-no-show-frame ,filename ,fi ,@first-frame-locs))
+         (assert (not frame))
+         (let ([summary-edit (make-object mred:media-edit%)])
+           (initialize-summary summary-edit)
+           (pretty-debug-gui `(summary-initialized))
+           (parameterize
+            ([mrspidey:add-summary-handler (add-summary summary-edit)])
+            (with-progress-frame
+             (lambda ()
+               (pretty-debug-gui '(progress-frame-initialized))
+               (mrspidey:progress
+                 "===========================================")
+               '(mrspidey:progress 
+                  (format "Analyzing ~a" (file-name-from-path filename)))
+               (let* ([annotations 
+                        (calc-annotations (thunk-expression))]
+                      [_ (set-fileinfo-annotations! fi annotations)]
+                      [_ (pretty-debug-gui `(calling-Tframe ,filename))]
+                      [frame (apply make-object spidey:frame% 
+                               ;; only use margin
+                               this 
+                               filename summary-edit 
+                               first-frame-locs)])
+                 (pretty-debug-gui `(Have-Tframe ,filename))
+                 (when show (send frame show #t))
+                 (unless show (send frame show #t) (send frame show #f))
+                 (set-fileinfo-frame! fi frame)
+                 (update-arrows)
+                 )))))])]
+
+      [initialize-summary
+        (lambda (edit)
+          (let* ([delta (make-object wx:style-delta%
+                          wx:const-change-family
+                          wx:const-decorative)]
+                  [click-delta (make-object wx:style-delta%)])
+            (send delta set-delta wx:const-change-size 10)
+            (send click-delta copy delta)
+            (send click-delta set-delta-foreground "BLUE")
+            (send click-delta set-delta wx:const-change-underline 1)
+
+            (let ( [insert
+                     (lambda (s)
+                       (let ([before (send edit get-end-position)])
+                         (send edit insert s)
+                         (let ([after (send edit get-end-position)])
+                           (values before after))))])
+              (let*-values
+                ( [(s1 e1) (insert "Welcome to ")]
+                  [(s2 e2) (insert "MrSpidey")]
+                  [(s3 e3) (insert (format ", version ~a." (mred:version)))]
+                  [(s4 e4) (insert (format "~n"))])
+                (send edit change-style delta s1 e1)
+                (send edit change-style click-delta s2 e2)
+                (send edit change-style delta s3 e3)
+                (send edit set-clickback s2 e2
+		  (lambda args
+                    (make-object mred:hyper-view-frame% 
+                      (string-append 
+                        "file:"
+                        (build-path
+			  (collection-path "mrspidey") ; MATTHEW: got rid of plt-home
+                          "about.html"))))
+                  click-delta)))))]
+
+      [local-record-analyzed-file
+        (lambda (filename thunk-port thunk-expression)
+          (pretty-debug-gui
+            `(local-record-analyzed-file ,filename 
+               ,thunk-port
+               ,thunk-expression))
+          (set! fileinfo*
+            (append fileinfo*
+              (list (make-fileinfo filename #f 
+                      thunk-port 
+                      thunk-expression)))))]
+
+      ;; ------------------------------
+
+      [add-summary
+       (lambda (summary-edit)
+         (lambda line
+           (send summary-edit lock #f)
+           (match line
+             [(str loc word-ofs)
+               (cond
+                 [(zodiac:zodiac? loc)
+                   ((add-summary summary-edit) str 
+                     (zodiac:zodiac-start loc) word-ofs)]
+                 [(zodiac:location? loc)
+                   (let* ( [click (lambda ignore (focus-def loc))]
+                           [init-pos-box (box 0)]
+                           [_ (send summary-edit get-position init-pos-box)]
+                           [_ (send summary-edit insert str)]
+                           [_ (send summary-edit insert 
+                                (format " in file ~s line ~s"
+                                  (file-name-from-path
+                                    (zodiac:location-file loc))
+                                  (zodiac:location-line loc)))]
+                           [_ (send summary-edit insert #\newline)]
+                           ;; Find start and end of word
+                           [end (unbox init-pos-box)]
+                           [_ 
+                             (for i 0 (add1 word-ofs)
+                               (set! end (mred:scheme-forward-match 
+                                           summary-edit end 
+                                           (send summary-edit last-position))))]
+                           [start (mred:scheme-backward-match summary-edit end 0)])
+             
+                     '(pretty-debug-gui 
+                        `(send summary-edit change-style check-link-delta
+                           ,(send check-link-delta get-underlined-on)
+                           ,start ,end))
+                     ;; Paranoia - check have proper locations
+                     (if (and start end)
+                       (begin
+                         (send summary-edit set-clickback start end click)
+                         (send summary-edit change-style check-link-delta 
+                           start end))
+                       ;; Error
+                       (pretty-print 
+                         `(Error: annotate-summary 
+                            ,str ,loc ,word-ofs ,start ,end))))]
+                 [else
+                   (begin
+                     (printf 
+                       "Bad location in main:add-summary-handler ~s~n"
+                       loc)
+                     (mrspidey:add-summary str))])]
+             [(str)
+              (send summary-edit insert str) 
+              (send summary-edit insert #\newline)]
+             [x (printf "add-summary, can't handle ~s~n" x)])
+           (send summary-edit lock #t)))]
+
+      ;; ------------------------------
+
+      [on-frame-close
+       (lambda (filename)
+         (void))]
+
+      [close-all-frames
+       (lambda ()
+         (send progress-frame show #f)
+         (close-all-frames-except-progress)
+         )]
+
+      [close-all-frames-except-progress
+       (lambda ()
+         (for-each-frame (lambda (frame) (send frame on-close)))
+         )]
+
+      ;; ------------------------------
+      
+      [annotated-edit
+        (lambda (mode filename canvas)
+          ;; create edit buffer, load file and add annotations
+          (pretty-debug-gui `(annotate-edit ,mode ,filename))
+          (match (filename->fileinfo filename)
+            [($ fileinfo filename frame thunk-port annotations)
+              (let* ( [port (thunk-port)]
+                      [edit (make-object 
+                              (mode-edit-class mode)
+                              (if (multiple-files) "  " "")
+                              this canvas)])
+                (send edit set-filename filename)
+                (send edit edit-sequence
+                  (lambda ()
+                    (pretty-debug-gui "loading!")
+                    (let ([s (format "Loading   ~a: "
+                               (file-name-from-path filename))])
+                      (recur loop ([n 1])
+                        (when (zero? (modulo n 50))
+                          (mrspidey:progress s n))
+                        (let ([r (read-line port)])
+                          ;;(pretty-debug-gui `(inserting ,r))
+                          (if (eof-object? r)
+                            (mrspidey:progress s (sub1 n))
+                            (begin
+                              (send edit insert-line r)
+                              (loop (add1 n))))))
+                      (when (multiple-files)
+                        (for i 0 NUM-EXTRA-LINES (send edit insert-line ""))))
+                    (close-input-port port)
+                    (pretty-debug-gui `(last-line ,(send edit last-line)))
+                    (send edit change-style base-delta 
+                      0 (send edit last-position))
+
+                    (pretty-debug-gui "annotating!")
+                    (annotate! filename edit mode annotations)
+
+                    (send edit set-position 0)
+                    (pretty-debug-gui `(annotate-buffer done))))
+
+                edit)]))]
+
+      [annotate!
+        (lambda (filename edit mode annotations)
+          (let ([s (format "Annotating ~a:" (file-name-from-path filename))])
+            (mrspidey:progress s '...)
+            (pretty-debug-gui `(annotate! ,filename ,edit ,mode ,annotations))
+            (let ([annotation-fn-list (mode-annotation-fn-list mode)])
+              (for-each
+                (lambda (annotation-fn annotations)
+                  (when annotation-fn
+                    (for-each
+                      (let ([fn (uq-ivar edit annotation-fn)])
+                        (match-lambda
+                          [(and annotation ($ annotation loc))
+                            (when (string=? (zodiac:location-file loc)
+                                    filename)
+                              ;; Call the method named func to annotate etc.
+                              (fn annotation))]))
+                      annotations)))
+                annotation-fn-list 
+                (vector->list annotations)))
+            (mrspidey:progress s 'done)))]
+      
+      ;; ------------------------------
+
+      [shake-it
+       '(lambda ()
+          (let* ([n (random (vector-length fileinfo*))]
+                 [fi (vector-ref fileinfo* n)]
+                 [frame (fileinfo-frame fi)])
+            (send frame shake-it)))]
+
+      ;; ------------------------------
+      ;; Arrows
+
+      [list-flow-arrows '()]
+      [add-flow-arrow 
+        (lambda (src dest)
+          (assert (and (FlowType? src) (FlowType? dest)))
+          (pretty-debug-gui
+            `(main:add-flow-arrow
+               ,(FlowType->pretty src) ,(FlowType->pretty dest)))
+          (with-handlers
+            ([exn:flow-arrow-exists? (lambda (exn) (void))])
+            (let ([flow-arrow (make-object flow-arrow% this src dest)])
+              (when flow-arrow
+                (set! list-flow-arrows (cons flow-arrow list-flow-arrows))))))]
+      [draw-arrows
+        (lambda ()
+          (pretty-debug-gui `(main:draw-arrows))
+          (for-each-frame
+            (lambda (frame)
+              (send (ivar frame program-edit) draw-arrows))))]
+      [update-arrows
+        (lambda ()
+          (pretty-debug-gui `(main:update-arrows))
+          (for-each 
+            (lambda (arrow) (send arrow update))
+            list-flow-arrows)
+          (draw-arrows))]
+      [delete-arrow
+        (lambda (arrow)
+          (send arrow delete-local)
+          (set! list-flow-arrows (remv arrow list-flow-arrows)))]
+      [delete-arrow-refresh
+        (lambda (arrow)
+          (delete-arrow arrow)
+          (draw-arrows))]
+      [delete-arrows
+        (lambda ()
+          (for-each 
+            (lambda (arrow) (send arrow delete-local))
+            list-flow-arrows)
+          (set! list-flow-arrows '())
+          (draw-arrows))]
+
+      ;; ------------------------------
+
+      [reanalyze 'reanalyze]
+
+      [run-mrspidey
+
+       (lambda (file . first-frame-locs)
+         
+         (pretty-debug-gui `(run-mrspidey ,file))
+         (set! reanalyze 
+             (lambda () (apply run-mrspidey file first-frame-locs)))
+
+         (close-all-frames-except-progress)
+         (pretty-debug-gui `(frames-closed))
+         (set! fileinfo* '())
+         (new-progress-frame!)
+
+         (let ([file (normalize-path (normalize-path file))])
+           ;; Following calls record-anlyzed-file
+           (st:analyze-and-make-annotations file)
+           (apply add-frame (filename->fileinfo file) #t first-frame-locs)
+
+           ))])
+
+    ;; ----------------------------------------------------------------------
+
+    (sequence
+      (set! tm this)
+      (record-analyzed-file-hook local-record-analyzed-file)
+      (init-progress-frame!))))
+
+(define spidey (make-object MrSpidey%))
+
+;; ----------------------------------------------------------------------
+;; mode says for each set of annotations,
+;; either #f or fn to handle annotation.
+
+(define-const-structure (mode name edit-class annotation-fn-list))
+
+(define modes
+  (list 
+    (make-mode
+      "Types and Checks" 
+      flow-arrow:media-edit%
+      (list 
+        'add-type-annotation 
+        'add-check-annotation
+        'add-uncheck-annotation))
+    (make-mode "Normal"
+      spidey:static-edit%
+      (list #f #f #f))))
+
+;; ----------------------------------------------------------------------
+
+

collects/mrspidey/Gui/prefs.ss

@@ -0,0 +1,330 @@
+;; prefs.ss - loads preferences
+; ----------------------------------------------------------------------
+; Copyright (C) 1995-97 Cormac Flanagan
+;
+; This program is free software; you can redistribute it and/or
+; modify it under the terms of the GNU General Public License
+; version 2 as published by the Free Software Foundation.
+; 
+; This program is distributed in the hope that it will be useful,
+; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+; GNU General Public License for more details.
+; 
+; You should have received a copy of the GNU General Public License
+; along with this program; if not, write to the Free Software
+; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
+; ----------------------------------------------------------------------
+
+(define parameter-radio-boxes
+  (lambda (name param sym p major-dim direction)
+    (mred:set-preference-default sym (param) 
+      (lambda (x)
+        (with-handlers ((exn? (lambda (exn) #f)))
+          (param x)
+          #t)))
+    (param (mred:get-preference sym))
+    (let* ([o
+             (make-object
+               mred:radio-box% p 
+               (lambda (bx event)
+                 ;;(printf "~s~n" (param '?))
+                 (match
+                   (list-ref (param '?)
+                     (send event get-command-int))
+                   [(tag . _) 
+                     (param tag)
+                     (mred:set-preference sym tag)]))
+               name 
+               -1 -1 -1 -1 
+               (map cadr (param '?))
+               major-dim
+               direction)]
+            [pairs
+              (map
+                (match-lambda [(tag name . _) (cons name tag)])
+                (param '?))]
+            [default-ndx
+              (recur loop ([n 0][pairs pairs])
+                (cond 
+                  [(null? pairs)
+                    (error 'make-parameter-menu 
+                      "Can't find para in pairs ~s" (param))]
+                  [(equal? (param) (cdar pairs)) n]
+                  [else (loop (add1 n) (cdr pairs))]))])
+      (send o stretchable-in-x #t)
+      (send o set-selection default-ndx)
+      o
+      )))
+
+(define parameter-check-box
+  (lambda (name param sym p)
+    (mred:set-preference-default sym (param) 
+      (lambda (x)
+        (with-handlers ((exn? (lambda (exn) #f)))
+          (param x)
+          #t)))
+    (param (mred:get-preference sym))
+    (let* ( [hp (make-object mred:horizontal-panel% p)]
+            [o
+              (make-object
+                mred:check-box% hp 
+                (lambda (bx event)
+                  ;;(printf "~s~n" (param '?))
+                  (match
+                    (list-ref (param '?)
+                      (send event get-command-int))
+                    [(tag . _) 
+                      (param tag)
+                      (mred:set-preference sym tag)]))
+                name 
+                -1 -1 -1 -1)]
+            [_ (make-object mred:horizontal-panel% hp)])
+      (send o set-value (param))
+      o
+      )))
+
+;; ======================================================================
+;; MrSpidey Type Display
+
+(define callbacks-sdl-alg-changed '())
+
+(define (add-callback-sdl-alg-changed! fn)
+  (set! callbacks-sdl-alg-changed (cons fn callbacks-sdl-alg-changed)))
+
+(define (remq-callback-sdl-alg-changed! fn)
+  (set! callbacks-sdl-alg-changed (remq fn callbacks-sdl-alg-changed)))
+
+(define (sdl-alg-changed)
+  (for-each 
+    (lambda (f) (f)) 
+    callbacks-sdl-alg-changed))
+
+(define (param-ctrls-sdl-alg param)
+  (lambda args
+    (sdl-alg-changed)
+    (apply param args)))
+
+;; ======================================================================
+
+(mred:set-preference-default 'st:const-merge-size (st:const-merge-size) 
+  (lambda (x)
+    (with-handlers ((exn? (lambda (exn) #f)))
+      (st:const-merge-size x)
+      #t)))
+(st:const-merge-size (mred:get-preference 'st:const-merge-size))
+
+(define mrspidey-mk-analysis-pref-panel
+  (lambda (panel)
+    (let*
+      ( [p (make-object mred:vertical-panel% panel)]
+        
+        [vp (make-object mred:vertical-panel% p -1 -1 -1 -1)]
+        [_ (parameter-check-box
+             "Accurate constant types"
+             st:constants 'st:constants
+             vp)]
+        [g (make-object mred:slider% vp 
+             (lambda (slider event)
+               (st:const-merge-size (send event get-command-int))
+               (mred:set-preference 'st:const-merge-size 
+                 (send event get-command-int)))
+             "Constant merge size"
+             (st:const-merge-size)
+             1 100 
+             100)]
+        [_ (send g enable #t)]
+        [_ (parameter-check-box
+             "If splitting"
+             st:if-split 'st:if-split
+             vp)]
+        [_ (parameter-check-box
+             "Flow sensitivity"
+             st:flow-sensitive 'st:flow-sensitive
+             vp)]
+        [_ (parameter-check-box
+             "Accurate analysis of numeric operations"
+             st:numops 'st:numops
+             vp)]
+        [_2 (parameter-radio-boxes
+              "Polymorphism:"
+              st:polymorphism
+              'st:polymorphism
+              p 0 wx:const-horizontal)]
+
+        [vp (make-object mred:vertical-panel% p -1 -1 -1 -1)]
+        [vphp (make-object mred:horizontal-panel% vp)]
+        [_0 (make-object mred:message% vphp
+              "Polymorphism simplification algorithms:")]
+        [vphphp (make-object mred:horizontal-panel% vphp)]
+        [_1 (parameter-radio-boxes
+              "        "
+              st:constraint-simplification-poly
+              'st:constraint-simplification-poly
+              vp 0 wx:const-vertical)]
+
+        [_ (parameter-radio-boxes
+             "Save .za files in:"
+             st:save-za-in
+             'st:save-za-in
+             p
+             0 wx:const-horizontal)]
+        )
+        
+      p)))
+
+(mred:add-preference-panel
+  "MrSpidey Analysis"
+  mrspidey-mk-analysis-pref-panel)
+
+(mrspidey-mk-analysis-pref-panel
+  (make-object mred:horizontal-panel%
+    (make-object mred:frame% '() "dummy")))
+
+;; ======================================================================
+
+;(mred:set-preference-default 'st:sdl-size-k (st:sdl-size-k))
+;(st:sdl-size-k (mred:get-preference 'st:sdl-size-k))
+
+(define (indented-vertical-radio-box p name param sym)
+  (let*
+    ( [vp (make-object mred:vertical-panel% p -1 -1 -1 -1)]
+      [vphp1 (make-object mred:horizontal-panel% vp)]
+      [_0 (make-object mred:message% vphp1 name)]
+      [vphp2 (make-object mred:horizontal-panel% vp)]
+      [spc (make-object mred:horizontal-panel% vphp2)]
+      [_ (send spc user-min-width 20)]
+      [_ (send spc stretchable-in-x #f)]
+      [radio-box
+        (parameter-radio-boxes
+          '()
+          param sym
+          vphp2 0 wx:const-vertical)]
+      [_ (send radio-box stretchable-in-x #t)]
+      [_ (make-object mred:horizontal-panel% vphp2)])
+    (void)))
+
+(define mrspidey-mk-type-display-prefs-panel
+  (lambda (panel)
+    (let*
+      ( [p (make-object mred:vertical-panel% panel )])
+
+      (let* 
+        (
+          [sdl-fo-container-panel
+            (make-object mred:horizontal-panel% p)]
+          [sdl-fo-sub-panel
+            (make-object mred:horizontal-panel% p)]
+          [spc (make-object mred:horizontal-panel% sdl-fo-sub-panel)]
+          [_ (send spc user-min-width 20)]
+          [_ (send spc stretchable-in-x #f)]
+          [sdl-fo-sub-sub-panel
+            (make-object mred:vertical-panel% sdl-fo-sub-panel)]
+          [see-ivars-panel
+            (parameter-check-box
+              "Show instance variables"
+              (param-ctrls-sdl-alg st:sdl-fo-ivars)
+              'st:sdl-fo-ivars
+              sdl-fo-sub-sub-panel)]
+          [see-struct-fields-panel
+            (parameter-check-box
+              "Show structure fields"
+              (param-ctrls-sdl-alg st:sdl-fo-struct-fields)
+              'st:sdl-fo-struct-fields
+              sdl-fo-sub-sub-panel)] 
+          [_ (parameter-radio-boxes
+                "Show types as:"
+               (match-lambda*
+                 [('?) (st:sdl-fo '?)]
+                 [() (st:sdl-fo)]
+                 [(x)
+                   (sdl-alg-changed)
+                   (let ([enable-sub-controls (eq? x 'basic-types)])
+                     (for-each
+                       (lambda (control)
+                         (send control enable enable-sub-controls))
+                       (list 
+                         see-ivars-panel
+                         see-struct-fields-panel)))
+                   (st:sdl-fo x)])
+               'st:sdl-fo
+                sdl-fo-container-panel
+               0 wx:const-horizontal)])
+        (void))
+        
+      (indented-vertical-radio-box p 
+        "Constraint simplification algorithms:" 
+        (param-ctrls-sdl-alg st:sdl-constraint-simplification)
+        'st:sdl-constraint-simplification)
+
+      (parameter-radio-boxes
+        "Type naming:"
+        (param-ctrls-sdl-alg st:naming-strategy)
+        'st:naming-strategy
+        p 0 wx:const-horizontal)
+      (parameter-radio-boxes
+        "Primitive types:"
+        (param-ctrls-sdl-alg st:primitive-types)
+        'st:primitive-types
+        p 0 wx:const-horizontal)
+
+      (let* 
+        (
+          [st:expand-output-type-container-panel
+            (make-object mred:horizontal-panel% p)]
+          [st:expand-output-type-sub-panel
+            (make-object mred:horizontal-panel% p)]
+          [spc (make-object mred:horizontal-panel% 
+                 st:expand-output-type-sub-panel)]
+          [_ (send spc user-min-width 20)]
+          [_ (send spc stretchable-in-x #f)]
+          [sdl-tidy-object
+            (parameter-check-box
+              "Uses equivalences that make types tidy"
+              (param-ctrls-sdl-alg st:sdl-tidy)
+              'st:sdl-tidy
+              st:expand-output-type-sub-panel)] 
+          [_ (parameter-check-box
+               "Use equivalences to simplify types"
+               (match-lambda*
+                 [('?) (st:expand-output-type '?)]
+                 [() (st:expand-output-type)]
+                 [(x)
+                   (sdl-alg-changed)
+                   (send sdl-tidy-object enable x)
+                   (st:expand-output-type x)])
+               'st:expand-output-type
+               st:expand-output-type-container-panel)])
+        (void))
+
+      p)))
+
+(mred:add-preference-panel
+  "MrSpidey Type Display"
+  mrspidey-mk-type-display-prefs-panel)
+
+(mrspidey-mk-type-display-prefs-panel
+  (make-object mred:horizontal-panel%
+    (make-object mred:frame% '() "dummy")))
+
+;; ======================================================================
+
+'(define (make-parameter-menu parameter)
+   (let* ([pairs
+            (map
+              (match-lambda [(tag name . _) (cons name tag)])
+              (parameter '?))]
+           [default-ndx
+             (recur loop ([n 0][pairs pairs])
+               (cond 
+                 [(null? pairs)
+                   (error 'make-parameter-menu "Can't find para in pairs")]
+                 [(equal? (parameter) (cdar pairs)) n]
+                 [else (loop (add1 n) (cdr pairs))]))])
+     (let ([menu (make-object mred:menu%)])
+       (send menu append-check-set pairs parameter default-ndx)
+       ;;(parameter (cdar pairs))
+       menu)))
+
+
+

collects/mrspidey/Gui/progress.ss

@@ -0,0 +1,168 @@
+; progress.ss - not used
+; ----------------------------------------------------------------------
+; Copyright (C) 1995-97 Cormac Flanagan
+;
+; This program is free software; you can redistribute it and/or
+; modify it under the terms of the GNU General Public License
+; version 2 as published by the Free Software Foundation.
+; 
+; This program is distributed in the hope that it will be useful,
+; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+; GNU General Public License for more details.
+; 
+; You should have received a copy of the GNU General Public License
+; along with this program; if not, write to the Free Software
+; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
+; ----------------------------------------------------------------------
+
+(define progress-box%
+  (class mred:frame% (title arg-bar-names . top-left-loc)
+
+    (inherit show set-size)
+
+    (public
+     num-bars
+     bar-names
+     bar-fractions
+     the-canvas 
+     [top-margin   12]
+     [bot-margin   24]
+     [right-margin 20]
+     [left-margin  10]
+     [middle-margin 20]
+     [bar-length  150]
+     [line-spacing 8]
+     [barname-width  58]
+     [barname-height 12]
+     [bar-margin     2]
+     [solid-brush (make-object wx:brush% "DARKGREEN" wx:const-solid)]
+     [trans-brush (make-object wx:brush% "DARKGREEN" wx:const-transparent)]
+     [border-pen  (make-object wx:pen% "BLACK" 1 wx:const-solid)]
+     [in-pen      (make-object wx:pen% "DARKGREEN" 1 wx:const-solid)]
+
+     [mark-progress
+      (lambda (bar-num fraction)
+        (vector-set! bar-fractions bar-num fraction)
+        (send the-canvas on-paint))]
+     )
+
+    (sequence
+      
+      (super-init '() title -1 -1 200 200)
+
+      (set! num-bars (length arg-bar-names))
+      (set! bar-names (list->vector arg-bar-names))
+      (set! bar-fractions (make-vector num-bars 0))
+
+      (set! the-canvas
+          (make-object 
+           (class wx:canvas% args
+             (inherit get-dc)
+             (public
+               [on-paint
+                (lambda ()
+                  (let ([the-dc (send the-canvas get-dc)])
+                    ;; Draw the text
+                    (for i 0 num-bars
+                         '(pretty-print
+                           `(send the-dc draw-text
+                                  ,(vector-ref bar-names i)
+                                  ,left-margin
+                                  ,(+ top-margin 
+                                      (* (+ barname-height line-spacing) i))))
+                         (send the-dc draw-text
+                               (vector-ref bar-names i)
+                               left-margin
+                               (+ top-margin
+                                  (* (+ barname-height line-spacing) i))))
+
+                    ; Draw the bar borders
+                    (send the-dc set-pen border-pen)
+                    (send the-dc set-brush trans-brush)
+                    (for i 0 num-bars
+                         '(pretty-print `(send the-dc draw-rectangle
+                                              ,(+ left-margin barname-width middle-margin)
+                                              ,(+ top-margin 
+                                                  (* (+ barname-height line-spacing) i))
+                                              ,(+ (* bar-length 1) (* 2 bar-margin))
+                                              ,barname-height))
+                         (send the-dc draw-rectangle
+                               (+ left-margin barname-width middle-margin)
+                               (+ top-margin 
+                                  (* (+ barname-height line-spacing) i))
+                               (+ (* bar-length 1) (* 2 bar-margin))
+                               barname-height))
+
+                    ;; Draw the bars
+                    (send the-dc set-pen in-pen)
+                    (send the-dc set-brush solid-brush)
+                    (for i 0 num-bars
+                         (unless (zero? (vector-ref bar-fractions i))
+                           '(pretty-print `(send the-dc draw-rectangle
+                                 ,(+ left-margin barname-width middle-margin
+                                    bar-margin)
+                                 ,(+ top-margin 
+                                    (* (+ barname-height line-spacing) i)
+                                    bar-margin)
+                                 ,(vector-ref bar-fractions i)
+                                 ,(* bar-length (vector-ref bar-fractions i))
+                                 ,(- barname-height (* 2 bar-margin))))
+                           (send the-dc draw-rectangle
+                                 (+ left-margin barname-width middle-margin
+                                    bar-margin)
+                                 (+ top-margin 
+                                    (* (+ barname-height line-spacing) i)
+                                    bar-margin)
+                                 (* bar-length (vector-ref bar-fractions i))
+                                 (- barname-height (* 2 bar-margin)))))
+                    )
+                  (wx:flush-display))])
+
+             (sequence
+               (apply super-init args)
+               (let ([the-dc (get-dc)])
+                 (send the-dc set-font
+                       (make-object wx:font% 12 wx:const-modern 
+                                    wx:const-normal wx:const-normal #f))
+                 )))
+
+             this))
+
+      '(let* ([sizes 
+               (map 
+                (lambda (name)
+                  (let ([wb (box 0)]
+                        [hb (box 0)])
+                    (printf ".") (flush-output)
+                    (send (send the-canvas get-dc) get-text-extent name wb hb)
+                    (printf ".") (flush-output)
+                    (cons (unbox wb) (unbox hb))))
+                arg-bar-names)])
+
+         (pretty-print `(sizes ,sizes))
+         (set! barname-width  (apply max (map car sizes)))
+         (set! barname-height (apply max (map cdr sizes))))
+        
+      ;; Set the frame size + position
+      (let ([w (+ left-margin barname-width middle-margin 
+                  bar-length (* 2 bar-margin) right-margin)]
+            [h (+ top-margin
+                  (* (+ barname-height line-spacing) num-bars)
+                  bot-margin)])
+        (match top-left-loc
+          [(x y) (set-size (- x w) y w h)]
+          [() (void)])
+      (set-size w h))
+      ;; We're ready
+      (show #t)
+      (wx:flush-display)
+      (wx:yield)
+      )))
+         
+'(begin
+  (define p (make-object progress-box% "title" '("bar-name-1" "bar-name-2")))
+  (send p mark-progress 0 0.3)
+  (send p mark-progress 1 0.6)
+  )
+

collects/mrspidey/Gui/statedit.ss

@@ -0,0 +1,72 @@
+; statedit.ss
+; Defines spidey:static-edit%, a subclass of mred:media-edit%
+; ----------------------------------------------------------------------
+; Copyright (C) 1995-97 Cormac Flanagan
+;
+; This program is free software; you can redistribute it and/or
+; modify it under the terms of the GNU General Public License
+; version 2 as published by the Free Software Foundation.
+; 
+; This program is distributed in the hope that it will be useful,
+; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+; GNU General Public License for more details.
+; 
+; You should have received a copy of the GNU General Public License
+; along with this program; if not, write to the Free Software
+; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
+; ----------------------------------------------------------------------
+
+(define spidey:static-edit%
+  (class mred:searching-edit% init-args
+    (inherit 
+      insert delete flash-on flash-off get-text
+      set-clickback change-style lock
+      set-position load-file
+      get-keymap scroll-to-position
+      last-position get-style-list
+      set-mode
+      begin-edit-sequence end-edit-sequence
+      )
+
+    (public
+      [begin-edit-sequence-and-unlock
+        (lambda ()
+          (wx:begin-busy-cursor)
+          (lock #f)
+          (begin-edit-sequence))]
+      [end-edit-sequence-and-lock
+        (lambda ()
+          (end-edit-sequence)
+          (lock #t)        
+          (wx:end-busy-cursor))]
+      [edit-sequence
+        (lambda (thunk)
+          (dynamic-wind
+            begin-edit-sequence-and-unlock
+            thunk
+            end-edit-sequence-and-lock))]
+      [match-paren-forward
+        (lambda (source-start)
+          (mred:scheme-forward-match
+            this source-start (last-position)))]
+      )
+	      
+    (sequence
+		
+      (apply super-init init-args)
+
+      (set-mode (make-object mred:scheme-mode%))
+      ;; disable paste for errant right mouse clicks
+      (let ([ k (get-keymap)])
+        (send k add-mouse-function "nothing" (lambda l (void)))
+        (send k map-function "middlebutton" "nothing")
+        (send k map-function "rightbutton" "nothing"))
+
+      ;; make snips go down instead of up
+      ;; oops - can't do this :-(
+      '(let ([stan (send (get-style-list) find-named-style "Standard")])
+         (when stan (send stan set-delta normal-delta)))
+
+      (lock #t)
+      )))

collects/mrspidey/Gui/test-gui.ss

@@ -0,0 +1,23 @@
+;; test-gui.ss
+;; ----------------------------------------------------------------------
+
+(define test-gui-shake-reps 25)
+
+(define (shake-test-files) test-files)
+
+;; ----------------------------------------------------------------------
+
+(define (test-gui-file f)
+  (printf "FILE: ~s~n" f)
+  (let* ([ftd (list f (lambda () (open-input-file f)) #t)]
+         [ftd* (list ftd)])
+    (send spidey do-and-show-analysis ftd*)
+    (for i 0  test-gui-shake-reps
+         (printf "Iteration ~s/~s~n" i  test-gui-shake-reps)
+         (send spidey shake-it))
+    (send spidey close-all-frames)))
+
+(define (test-gui)
+  (for-each test-gui-file (shake-test-files)))
+
+

collects/mrspidey/Sba/atenv.ss

@@ -0,0 +1,307 @@
+;; atenv.ss
+;; Section for handling environment
+; ----------------------------------------------------------------------
+; Copyright (C) 1995-97 Cormac Flanagan
+;
+; This program is free software; you can redistribute it and/or
+; modify it under the terms of the GNU General Public License
+; version 2 as published by the Free Software Foundation.
+; 
+; This program is distributed in the hope that it will be useful,
+; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+; GNU General Public License for more details.
+; 
+; You should have received a copy of the GNU General Public License
+; along with this program; if not, write to the Free Software
+; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
+; ----------------------------------------------------------------------
+
+(define-const-typed-structure
+  atenv ( (: immut     (listof (cons zodiac:binding FlowType)))
+          (: notcap    (listof (cons zodiac:binding mutable-binding)))
+          (: cap       (listof (cons zodiac:binding mutable-binding)))
+          (: flushed   (listof (cons zodiac:binding mutable-binding)))
+          (: unflushed (listof (cons zodiac:binding mutable-binding)))
+          (: both      (listof (cons zodiac:binding mutable-binding)))))
+
+(define-const-typed-structure 
+  mutable-binding ( (: current FlowType)
+                    (: at-transfer Tvar)
+                    (: flushed bool)))
+
+;; ----------------------------------------------------------------------
+
+(define atenv:empty (make-atenv '() '() '() '() '() '()))
+
+(define (atenv:extend-mutated env name ftype tvar)
+  (pretty-debug-atenv `(atenv:extend-mutated ,(atenv->pretty env)))
+  (assert (zodiac:binding? name) 'atenv:extend name)
+  (let ([ftype (link-parsed-ftype! name ftype)])
+    (match env
+      [($ atenv i n c f u b)
+        (make-atenv 
+          i
+          (extend-env n name 
+            (make-mutable-binding 
+              ftype tvar
+              #f))
+          c f u b)])))
+
+(define (atenv:extend env name ftype)
+  (pretty-debug-atenv `(atenv:extend ,(atenv->pretty env)))
+  (assert (zodiac:binding? name) 'atenv:extend name)
+  (let ([ftype (link-parsed-ftype! name ftype)])
+    (match env
+      [($ atenv i n c f u b)
+        (if (zodiac:binding-mutated name)
+          (make-atenv 
+            i
+            (extend-env n name 
+              (make-mutable-binding 
+                ftype 
+                (mk-Tvar 'mut-var
+                  ;;(symbol-append 'mut-var- (zodiac:binding-var name))
+                  )
+                #f))
+            c f u b)
+          (make-atenv
+            (extend-env i name ftype)
+            n c f u b))])))
+
+(define (atenv:extend* env names ftypes)
+  (foldr2 (lambda (name ftype env) (atenv:extend env name ftype))
+          env names ftypes))
+
+(define (atenv:extend-voids env names)
+  (atenv:extend* env names (map (lambda (x) (mk-tvar-void)) names)))
+
+(define (atenv:extend-undefineds env names)
+  (atenv:extend* env names (map (lambda (x) (mk-tvar-undefined)) names)))
+
+(define (atenv:lookup env name)
+  (pretty-debug-atenv `(atenv:lookup ,(atenv->pretty env)))
+  (if (zodiac:binding-mutated name)
+    (match (or 
+             (lookup-or-#f (atenv-notcap env)    name)
+             (lookup-or-#f (atenv-cap env)       name)
+             (lookup-or-#f (atenv-flushed env)   name)
+             (lookup-or-#f (atenv-unflushed env) name)
+             (lookup-or-#f (atenv-both env)      name))
+      [($ mutable-binding cur) cur]
+      [x x])
+    (lookup-or-#f (atenv-immut env) name)))
+
+(define (atenv:change-binding env name ftype)
+  (pretty-debug-atenv
+    `(->atenv:change-binding
+       ,(zodiac:binding-var name) ,(FlowType->pretty ftype)
+       ,(atenv->pretty env)))
+  (match env
+    [($ atenv i n c f u b)
+      (let/cc k
+        (let* 
+          ([err
+             (lambda ()
+               (pretty-debug-atenv
+                 `(atenv:change-binding
+                    ,(zodiac:binding-var name)
+                    ,(map zodiac:binding-var (map car env))))
+               (mrspidey:warning
+                 (format "Unbound variable ~s" (zodiac:binding-var name))
+                 (zodiac:zodiac-start name)
+                 2)
+               (k env))]
+            [result-env
+              (if (zodiac:binding-mutated name)
+                (let ([chg-fn
+                        (match-lambda
+                          [($ mutable-binding cur at-transfer)
+                            (make-mutable-binding ftype at-transfer #f)])])
+                  (if (lookup-or-#f n name)
+                    (make-atenv
+                      i
+                      (env:change-binding n name chg-fn err)
+                      c f u b)
+                    ;; Must be in one of c f u b
+                    ;; Lift out to captured
+                    (if (lookup-or-#f c name)
+                      (make-atenv
+                        i n
+                        (env:change-binding c name chg-fn err)
+                        f u b)
+                      (let*-vals
+                        ([(bind f u b)
+                           (cond
+                             [(lookup-or-#f f name)
+                               (let*-vals ([(bind f) (env:remove f name)])
+                                 (values bind f u b))]
+                             [(lookup-or-#f u name)
+                               (let*-vals ([(bind u) (env:remove u name)])
+                                 (values bind f u b))]
+                             [(lookup-or-#f b name)
+                               (let*-vals ([(bind b) (env:remove b name)])
+                                 (values bind f u b))]
+                             [else (err)])])
+                        (make-atenv
+                          i n
+                          (extend-env c name (chg-fn bind))
+                          f u b)))))
+                (make-atenv 
+                  (env:change-binding i name (lambda (old) ftype) err)
+                  n c f u b))])
+          (pretty-debug-atenv
+            `(->atenv:change-binding-returns ,(atenv->pretty result-env)))
+          result-env))]))
+
+(define (atenv:change-bindings env bindings ftypes)
+  (foldr2
+   (lambda (binding ftype env)
+     (atenv:change-binding env binding ftype))
+   env bindings ftypes))
+
+;; ------------------------------
+
+(define (atenv:capture-locs env bindings)
+  (pretty-debug-atenv 
+    `(atenv:capture-locs ,(atenv->pretty env) ,(map zodiac:binding-var bindings)))
+  (match env
+    [($ atenv i n c f u b)
+      (recur loop ([n n][n-ok '()][c c])
+        (if (null? n)
+          (make-atenv i n-ok c f u b)
+          (if (and 
+                (memq (caar n) bindings)
+                ;; ### KLUDGE FOR DECENT, BUT POSSIBLY WRONG, POLYMORPHISM
+                (not (poly-atype? (FlowType->Atype 
+                                    (mutable-binding-current (cdar n))))))
+            (loop (cdr n) n-ok (cons (car n) c))
+            (loop (cdr n) (cons (car n) n-ok) c))))]))
+
+(define (atenv:unflush env)
+  (pretty-debug-atenv `(atenv:unflush ,(atenv->pretty env)))
+  (match env
+    [($ atenv i n c f u b)
+      (let ([upd
+              (match-lambda
+                [(name . ($ mutable-binding cur trans))
+                  (cons name (make-mutable-binding trans trans #t))])])
+        (make-atenv
+          i n '() '()
+          (append (map upd c) u)
+          (append (map upd f) b)))]))
+
+(define (atenv:flush! env)
+  (pretty-debug-atenv `(atenv:flush! ,(atenv->pretty env)))
+  (match env
+    [($ atenv i n c f u b)
+      (let ([upd
+              (match-lambda
+                [(name . (and bind ($ mutable-binding cur trans flushed)))
+                  (unless flushed
+                    (new-edge! (FlowType->Tvar cur) trans)
+                    (set-mutable-binding-flushed! bind #t))])])
+        (for-each upd c)
+        (for-each upd u)
+        (make-atenv i n '() (append c f) '() (append u b)))]))
+
+(define (atenv->pretty env)
+  (match env
+    [($ atenv i n c f u b)
+      (let ([p (match-lambda
+                 [(name . ($ mutable-binding cur trans))
+                   (list (zodiac:binding-var name) 
+                     (list
+                       (FlowType->pretty cur)
+                       (FlowType->pretty trans)))])])
+              
+        (list
+          (map (match-lambda
+                 [(name . ftype)
+                   (list 
+                     (zodiac:binding-var name) 
+                     (FlowType->pretty ftype))])
+            i)
+          (map p n) 
+          (map p c)
+          (map p f)
+          (map p u)
+          (map p b)))]))
+
+(define (atenv:domain env)
+  (match env
+    [($ atenv i n c f u b)
+      (map car (append i n c f u b))]))
+
+(define (atenv:ok? e)
+  (and
+    (atenv? e)
+    (match e
+      [($ atenv i n c f u b)
+        (and
+          (list? i)
+          (andmap
+            (match-lambda
+              [(($ zodiac:binding) . ($ FlowType)) #t]
+              [_ #f])
+            i)
+          (andmap
+            (lambda (n)
+              (and
+                (list? n)
+                (andmap
+                  (match-lambda
+                    [(($ zodiac:binding) . ($ mutable-binding)) #t]
+                    [_ #f])
+                  n)))
+            (list n c f u b)))])))
+
+'(defmacro check-atenv-fn-ok (fn)
+  (let ( [old-fn (gensym)])
+    `(begin
+       (define ,old-fn ,fn)
+       (define ,fn
+         (let ([env-ok atenv:ok?])
+           (lambda (env . rest)
+             ;;(printf "Entering ~s~n" (quote ,fn))
+             (unless (env-ok env)
+               (pretty-print env)
+               (error (quote ,fn) "Bad env on entry"))
+             (let ([r (apply ,old-fn env rest)])
+               ;;(printf "exiting ~s~n" (quote ,fn))
+               (unless (env-ok env)
+                 (error (quote ,fn) "Bad env on exit"))
+               r)))))))
+
+;(check-atenv-fn-ok atenv:extend)
+;(check-atenv-fn-ok atenv:extend*)
+;(check-atenv-fn-ok atenv:extend-voids)
+;(check-atenv-fn-ok atenv:change-binding)
+;(check-atenv-fn-ok atenv:change-bindings)
+;(check-atenv-fn-ok atenv:capture-locs)
+;(check-atenv-fn-ok atenv:unflush)
+;(check-atenv-fn-ok atenv:flush!)
+
+;; ======================================================================
+
+(define (link-parsed-ftype! parsed ftype)
+  (assert (FlowType? ftype) 'link-parsed-ftype! ftype)
+  (if need-label-types
+    (let ([nu-ftype
+            (if (and need-explanation (FlowType-expr ftype))
+              (copy-ftype ftype)
+              ftype)])
+      (pretty-debug-object 
+        `(link-parsed-ftype! 
+           ,(zodiac:stripper parsed)
+           ,(zodiac:location-offset (zodiac:zodiac-start parsed))
+           ,(FlowType-name ftype)))
+      (zodiac:set-parsed-ftype! parsed nu-ftype)
+      (set-FlowType-expr! nu-ftype #t) ;parsed
+      nu-ftype)
+    ftype))
+
+;; ======================================================================
+
+
+

collects/mrspidey/Sba/atlunit.ss

@@ -0,0 +1,765 @@
+;; atlunit.ss
+;; Handles annotated lazy units - units, cmpd-units and reference-units
+; ----------------------------------------------------------------------
+; Copyright (C) 1995-97 Cormac Flanagan
+;
+; This program is free software; you can redistribute it and/or
+; modify it under the terms of the GNU General Public License
+; version 2 as published by the Free Software Foundation.
+; 
+; This program is distributed in the hope that it will be useful,
+; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+; GNU General Public License for more details.
+; 
+; You should have received a copy of the GNU General Public License
+; along with this program; if not, write to the Free Software
+; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
+; ----------------------------------------------------------------------
+;; The structures ...
+
+(define-const-typed-structure
+  (atlunit-unit struct:atlunit)
+  ((: env (listof (cons zodiac:binding FlowType)))
+   (: exp zodiac:unit-form)))
+
+(define (create-atlunit-unit env exp)
+  (make-atlunit-unit #f env exp))
+
+;; -----
+
+(define-const-typed-structure
+  (atlunit-cmpd struct:atlunit)
+  ((: cmpd-unit zodiac:compound-unit-form)
+   (: times (listof num))
+   (: ftype* (listof FlowType))))
+
+(define (create-atlunit-cmpd cmpd-unit time* ftype*)
+  (make-atlunit-cmpd #f cmpd-unit time* ftype*))
+
+;; -----
+
+(define-const-typed-structure
+  (atlunit-reference struct:atlunit)
+  ((: exp zodiac:sexp)))
+
+(define (create-atlunit-reference exp)
+  (assert (zodiac:reference-unit-form? exp))
+  (make-atlunit-reference #f exp))
+
+;; ----------------------------------------------------------------------
+;; (: partial-import-list 
+;;    (union false (listof (cons (union FlowType false) time))))
+
+(define (pretty-partial-import-list pil)
+  (and pil
+    (map (match-lambda
+           [(ftype . itime)
+             (cons (and ftype (FlowType->pretty ftype)) itime)])
+      pil)))
+
+;; ----------------------------------------------------------------------
+
+(define (apply-unit unit partial-import-list)
+  (: unit FlowType)
+  ;; returns (union atunit Tvar)
+  (match (FlowType->Atype unit)
+    [(? atlunit? atlunit) (apply-atlunit atlunit partial-import-list)]
+    [($ atunit imports exports result expr)
+      (let ([imports
+              (cond
+                [(eq? partial-import-list #f) imports]
+                [(= (length imports) (length partial-import-list))
+                  (map (match-lambda*
+                         [((sym . tvars) (ftype . _))
+                           (if ftype
+                             (begin
+                               (for-each 
+                                 (lambda (tvar)
+                                   (new-edge! (FlowType->Tvar ftype) tvar)) 
+                                 tvars)
+                               (list sym))
+                             (cons sym tvars))])
+                    imports partial-import-list)]
+                [else
+                  (let ([msg (format "Unit takes ~s imports, given ~s"
+                               (length imports) (length partial-import-list))])
+                    (if (zodiac:parsed? expr)
+                      (mrspidey:warning msg expr 0)
+                      (mrspidey:warning msg)))
+                  imports])])
+        (make-atunit imports exports result expr))]
+    [(? Tvar? tvar-u)
+      (for-each-with-n
+        (match-lambda*
+          [((ftype . _) n)
+            (new-con! tvar-u
+              (create-con (get-unit-import-template n)
+                0 (FlowType->Tvar ftype) #f))])
+        partial-import-list)
+      tvar-u]))
+
+;; ----------------------------------------------------------------------
+
+(define (atlunit->atunit atlunit) 
+  ;; returns atunit
+  (apply-atlunit atlunit #f))
+
+(define gatlunit (void))
+
+(define (apply-atlunit atlunit partial-import-list)
+  (: partial-import-list (listof (cons (union FlowType false) num)))
+  ;; (returns atunit)
+  (set! gatlunit atlunit)
+  (match atlunit
+    [(and atlunit ($ atlunit ui))
+      (assert (or (eq? ui #f) (atunit? ui)))
+      (when (and ui partial-import-list)
+        (pretty-debug-unit `(ui ,ui partial-import-list ,partial-import-list))
+        (mrspidey:error 
+          "Annotated lazy unit invoked more than once"
+          (match atlunit
+            [($ atlunit-unit _ _ exp) exp]
+            [($ atlunit-cmpd _ exp) exp]
+            [($ atlunit-reference _ exp) exp])))
+      (or ui
+        (let* ( [fn
+                  (cond
+                    [(atlunit-unit? atlunit)  apply-atlunit-unit]
+                    [(atlunit-cmpd? atlunit)  apply-atlunit-cmpd]
+                    [(atlunit-reference? atlunit) apply-atlunit-reference]
+                    [else (mrspidey:internal-error
+                            'apply-atlunit->atunit "Not a lazy unit")])]
+                [ui (fn atlunit partial-import-list)])
+          (set-atlunit-ui! atlunit ui)
+          ui))]))
+
+;; ----------------------------------------------------------------------
+
+(define (apply-atlunit-unit atlunit partial-import-list)
+  (match atlunit
+    [($ atlunit-unit _ env 
+        (and unit-exp ($ zodiac:unit-form _ s _ _ imports exports body)))
+     (pretty-debug-unit
+      `(apply-atlunit-unit
+        ,(zodiac:stripper unit-exp)
+        ,(and partial-import-list
+              (map FlowType->pretty (map car partial-import-list))))
+      7)
+
+     (let*-vals
+       ( [free-names (zodiac:free-vars-defs body)]
+         [free-names2 (setdiff2 free-names imports)]
+         [init-env (get-default-bindings free-names2)]
+         [env1 (cond
+                 [(eq? partial-import-list #f) init-env]
+                 [(not (= (length imports) (length partial-import-list)))
+                   (mrspidey:error 
+                     (format 
+                       "Bad number of imports for unit, expected ~s, given ~s"
+                       (length imports)
+                       (length partial-import-list)))]
+                 [else (foldr2
+                         (lambda (name ftype env)
+                           (if ftype
+                             (atenv:extend env name ftype)
+                             env))
+                         init-env
+                         imports
+                         (map car partial-import-list))])]
+         [(env2 refs result) (traverse-defs body env1)]
+         ;;[_ (pretty-print `(env2 ,(atenv->pretty env2)))]
+         [env3 (atenv:unflush (atenv:flush! env2))]
+         ;;[_ (pretty-print `(env3 ,(atenv->pretty env2)))]
+         [exports 
+           (map 
+             (match-lambda
+               [(lvr . z-sym)
+                 (let* ( [binding (zodiac:varref-binding lvr)]
+                         [ftype (atenv:lookup env3 binding)]
+                         [_ (assert (FlowType? ftype) 'atlunit-unit->atunit 
+                              binding)]
+                         [ftype (link-parsed-ftype! lvr ftype)])
+                   (cons (zodiac:read-object z-sym) ftype))])
+             exports)]
+         [imports
+           (map (lambda (name)
+                  (cons (zodiac:binding-var name)
+                    (filter-map
+                      (match-lambda
+                        [(name2 . tvar)
+                          (and (eq? name name2) tvar)])
+                      refs)))
+             imports)])
+       (make-atunit imports exports result unit-exp))]))
+
+;; ----------------------------------------------------------------------
+
+(define (apply-atlunit-cmpd atlunit partial-import-list)
+  (match atlunit
+    [($ atlunit-cmpd _
+       (and cmpd-unit
+         ($ zodiac:compound-unit-form _ start _ _ 
+           import-bindings links exports))
+       times ftype*)
+      (: import-bindings (listof zodiac:lexical-binding))
+      (: links
+        (listof (list sym zodiac:parsed (listof (cons (union sym #f) sym)))))
+      (: times (listof num))
+      (: ftype* (listof FlowType))
+      (: exports (listof (list sym sym sym)))
+    
+      (pretty-debug-unit
+        `(apply-atlunit-cmpd
+           ,(map zodiac:binding-orig-name import-bindings)
+           ,(zodiac:stripper cmpd-unit)
+           ,(map FlowType->pretty ftype*)
+           ,exports
+           ,(and partial-import-list
+              (map FlowType->pretty (map car partial-import-list)))))
+
+      (letrec*
+        ( [time-N (zodiac-time cmpd-unit)]
+          [saved-refs '()]              ; forward refs and refs to some imports
+          [imports (map zodiac:binding-orig-name import-bindings)]
+          [import-env 
+            (cond
+              [(eq? partial-import-list #f) '()]
+              [(not (= (length imports) (length partial-import-list)))
+                (mrspidey:warning 
+                  (format "Compound-unit requires ~s imports, given ~s"
+                    (length imports) (length partial-import-list))
+                  start 0)
+                '()]
+              [else 
+                (map
+                  (lambda (import-binding import ftype-time)
+                    (let* ( [ftype (car ftype-time)]
+                            [_ (assert (FlowType? ftype) 'atlunit-3 ftype)]
+                            [ftype (link-parsed-ftype! import-binding ftype)]
+                            [ftype-time (cons ftype (cdr ftype-time))])
+                      (cons import ftype-time)))
+                  import-bindings
+                  imports
+                  partial-import-list)])]
+          [import-refs (make-vector (length imports) '())]
+          [access-import
+            (lambda (sym)
+              (match (lookup-or-fail import-env sym (lambda () (cons #f 0)))
+                [(ftype . itime)
+                  (values
+                    (or ftype
+                      (let ([tvar (mk-Tvar 'get-export)]
+                             [n (index imports sym)])
+                        (if n 
+                          (vector-set! import-refs n
+                            (cons tvar (vector-ref import-refs n)))
+                          (mrspidey:warning
+                            (format
+                              "Symbol ~s not in import list of compound-unit" 
+                              sym)
+                            (zodiac:zodiac-start cmpd-unit) 7))
+                        tvar))
+                    (max time-N itime))]))]
+          ;; alist of tags and function to access exports
+          [tag->access (list (cons #f access-import))]
+          [tag.sym->ftype.time
+            (lambda (tag sym)
+              (assert (or (not tag) (symbol? tag)) tag 'tag.sym->ftype.time2)
+              (assert (symbol? sym) sym 'tag.sym->ftype.time2)
+              (match (lookup-or-#f tag->access tag)
+                [(? procedure? access) (access sym)]
+                [#f (let ([tvar (mk-Tvar 'forward-get-export)])
+                      (set! saved-refs (cons (list tag sym tvar) saved-refs))
+                      (values tvar time-N))]))]
+          [last-invoked-unit #f]
+          [_ 
+            (for-each
+              (lambda (link time-U ftype)
+                (match-let*
+                  ( [(tag _ . i*) link]
+                    ;; [_ (pretty-print `(i* ,i* tag ,tag link ,link))]
+                    ;; tag is not a zodiac:parsed, so cant hang type off it
+                    ;; [ftype (link-parsed-ftype! tag ftype)]
+                    [tag (zodiac:read-object tag)]
+                    ;; Figure out imports
+                    [import-ftype.times
+                      (map 
+                        (lambda (i)
+                          (let*-vals
+                            ([(tag sym)
+                               (match i
+                                 [(tag . sym) 
+                                   (values
+                                     (zodiac:read-object tag)
+                                     (zodiac:read-object sym))]
+                                 [($ zodiac:lexical-varref)
+                                   (values #f 
+                                     (zodiac:binding-orig-name
+                                       (zodiac:varref-binding i)))])]
+                              [_ (assert (or (not tag) (symbol? tag)) 1)]
+                              [(ftype itime) (tag.sym->ftype.time tag sym)]
+                              ;;#[ftype (link-parsed-ftype! i ftype)]
+                              )
+                            (cons ftype itime)))
+                        i*)]
+                    [time-export (apply max time-N time-U
+                                   (map cdr import-ftype.times))]
+                    [_ (pretty-debug-unit
+                         `(apply-atlunit-cmpd 
+                            invoking ,tag ,ftype ,import-ftype.times))]
+                    [invoked-unit (apply-unit ftype import-ftype.times)]
+                    [_ (pretty-debug-unit
+                         `(apply-atlunit-cmpd result tag ,tag ,invoked-unit))]
+                    [_ (set! last-invoked-unit invoked-unit)]
+                    [access-exports
+                      (match invoked-unit
+                        [($ atunit imports exports)
+                          (lambda (sym)
+                            (match (lookup-or-#f exports sym)
+                              [#f (mrspidey:warning
+                                    (format 
+                                      "Exported var ~s not in unit tagged ~s in compound-unit" 
+                                      sym tag)
+                                    cmpd-unit 9)
+                                (values (mk-tvar-void) 0)]
+                              [ftype (values ftype time-export)]))]
+                        [(? Tvar? tvar-u)
+                          (lambda (sym)
+                            (let ([tvar (mk-Tvar 'get-export)])
+                              (new-con! tvar-u 
+                                (create-con (get-unit-export-template sym)
+                                  0 tvar #t))
+                              (values tvar time-export)))])])
+
+                  (set! tag->access (cons (cons tag access-exports) tag->access))
+                  (set! saved-refs
+                    (filter
+                      (match-lambda
+                        [(tag2 sym tvar)
+                          (if (eq? tag tag2)
+                            (let-values ([(ftype _) (access-exports sym)])
+                              (new-edge! (FlowType->Tvar ftype) tvar)
+                              #f)
+                            #t)])
+                      saved-refs))))
+              links times ftype*)]
+
+          [unit-imports (map cons imports (vector->list import-refs))]
+          [unit-exports 
+            (map 
+              (match-lambda
+                [(and export (tag id . e-id))
+                  (let*-vals
+                    ([(ftype _) 
+                       (tag.sym->ftype.time 
+                         (zodiac:read-object tag)
+                         (zodiac:read-object id))]
+                      ;;#[ftype (link-parsed-ftype! export ftype)]
+                      )
+                    (cons (zodiac:read-object e-id) ftype))])
+              exports)]
+          [result
+            (match last-invoked-unit
+              [#f (wrap-value (mk-tvar-void))]
+              [($ atunit _ _ result) result]
+              [(? Tvar? tvar-u)
+                (let ([tvar (mk-Tvar 'cmpd-unit-result)])
+                  (new-con! tvar-u (create-con template-unit 0 tvar #t))
+                  tvar)])])
+
+        (make-atunit unit-imports
+          unit-exports
+          result
+          cmpd-unit))]))
+
+;; ----------------------------------------------------------------------
+(define regenerating-ftype (void))
+
+(define (apply-atlunit-reference atlunit partial-import-list)
+  (match atlunit
+    [($ atlunit-reference _ 
+       (and N ($ zodiac:reference-unit-form _ _ _ _ file kind)))
+
+      (pretty-debug-unit 
+        `(apply-atlunit-reference
+           ,(zodiac:location-line (zodiac:zodiac-start N))
+           pil ,(pretty-partial-import-list partial-import-list)))
+
+        (let*-vals
+          ( [_ (unless (zodiac:string? file)
+                 (mrspidey:error
+                   "reference-unit requires a string argument, given ~s"
+                   file))]
+            [file (zodiac:read-object file)]
+            [path+file
+              (if (relative-path? file)
+                (build-path (current-directory) file)
+                file)]
+            [file-directory (path-only path+file)]
+            [(_ file _) (split-path path+file)]
+            [za (regexp-replace ".ss$" file ".za")]
+            [_ (when (eq? za file) 
+                 (mrspidey:error
+                   (format "Invalid extension on ~s, requires .ss"
+                     file)))]
+            [t-N (zodiac-time* N)]
+            [za (case (st:save-za-in)
+                  [(source-directory)
+                    (build-path file-directory za)]
+                  [(tmp-directory) 
+                    (build-path 
+                      (wx:find-path 'temp-dir)
+                      (file-name-from-path za))])]
+            [t-za (file-modify-seconds za)]
+            
+            ;; restrict imports to prims, closed schemas, and atstructs
+            [partial-import-list-restricted
+              (and partial-import-list
+                (map
+                  (match-lambda
+                    [(ftype . itime)
+                      (cons
+                        (and (fo-FlowType? ftype)
+                          (match (fo-FlowType-def ftype)
+                            [(or ($ schema _ _ ()) (? atprim?) (? atstruct?))
+                              ftype]
+                            [_ #f]))
+                        itime)])
+                  partial-import-list))]
+            [_ (pretty-debug-unit 
+                 `(pil-restricted 
+                    ,(pretty-partial-import-list
+                       partial-import-list-restricted)))]
+
+            [port-for-included-unit
+              (lambda ()
+                (dynamic-let ([current-directory file-directory])
+                  (open-code-file file)))]
+
+            [traverse-included-unit
+              ;; (zodiac:parsed -> (union atunit atlunit))
+              (lambda ()
+                (let*-vals
+                  ([_ (mrspidey:progress 
+                        (format "Analyzing referenced unit ~a" file))]
+                    [_ (extend-file-time-cache! path+file t-N)]
+                    [exps (zodiac:read* (port-for-included-unit) path+file)]
+                    [(parsed-exps free-names) 
+                      (dynamic-let
+                        ([current-directory file-directory])
+                        (my-scheme-expand-program exps))]
+                    [_ (unless (= (length parsed-exps) 1)
+                         (mrspidey:error 
+                           (format
+                             "reference-unit file ~s not a single exp" 
+                             path+file)))]
+                    [parsed-exp (car parsed-exps)]
+                    [_ (pretty-debug
+                         `(traverse-included-unit
+                            ,(zodiac:stripper parsed-exp)))]
+                    [gtr global-tref-env]
+                    [gtd global-tdef-env]
+                    [gtb global-tbang-env]
+                    [init-env (get-default-bindings free-names)]
+                    [(ftype env refs) (traverse-exp parsed-exp init-env)]
+                    [ftype (extract-1st-value ftype)]
+                    [ftype 
+                      (case kind
+                        [(exp) ftype]
+                        [(imp) (create-fo-FlowType
+                                 (apply-unit ftype
+                                   partial-import-list-restricted))])]
+                    [savable-ftype (make-savable-ftype ftype)]
+                    [atunit (FlowType->Atype savable-ftype)]
+                    [_ (unless (atunit? atunit)
+                         (mrspidey:error 
+                           (format 
+                             "reference-unit file did not produce an annotated unit ~s"
+                             atunit)
+                           N))]
+                    [nu-tref (get-prefix global-tref-env gtr)]
+                    [nu-tdef (get-prefix global-tdef-env gtd)]
+                    [nu-tbang (get-prefix global-tbang-env gtb)]
+                    )
+                  (init-global-tenv! gtr gtd gtb)
+                  (pretty-debug-unit `(nu-tbang ,nu-tbang))
+                  (for-each 
+                    (match-lambda 
+                      [(binding . _)
+                        (mrspidey:warning 
+                          (format
+                            "Unit refs imported var ~s of enclosing unit"
+                            (zodiac:binding-orig-name binding)))])
+                    refs) 
+                  (values
+                    exps parsed-exp
+                    savable-ftype nu-tref nu-tdef nu-tbang)))]
+
+            [l-start list-ftype]
+            [(ftype tref tdef tbang regenerate)
+              (if (and (st:unit-read-za) t-za (< t-N t-za))
+
+                ;; ------
+                ;; Just load from the file for delta-min
+                (let*-vals
+                  ( [s (format "Loading ~a" (file-name-from-path za))]
+                    [_ (mrspidey:progress s '...)]
+                    [(delta-min tref tdef tbang) (read-za za)]
+                    [_ (mrspidey:progress s 'done)])
+
+                  (values delta-min tref tdef tbang traverse-included-unit))
+
+                ;; ------
+                ;; Regenerate
+                (let*-vals 
+                  ( [separate-S
+                      (and 
+                        (st:unit-separate-S)
+                        (not (memq (st:unit-simplify) '(none nonempty))))]
+                    [s "Saving kernel state:"]
+                    [kernel-state 
+                      (when separate-S 
+                        (begin
+                          (mrspidey:progress s '...)
+                          (begin0
+                            (save-kernel-state)
+                            (init-kernel!)
+                            (mrspidey:progress s 'done))))]
+                    [l2 list-ftype]
+                    [(exps parsed-exp ftype nu-tref nu-tdef nu-tbang)
+                      ;; we don't consider indirectly included files
+                      ;; to be included
+                      (parameterize ([record-analyzed-file-hook
+                                       (lambda (filename . _)
+                                         (void))])
+                        (traverse-included-unit))]
+                    [l1 list-ftype]
+                    ;;[_ (close-constraints (filter Tvar? (get-prefix l1 l2)))]
+                    [E (append 
+                         (savable-ftype-external-vars ftype)
+                         (map cdr nu-tref)
+                         (map cdr nu-tdef)
+                         (map cdr nu-tbang))]
+                    [_ (pretty-debug-unit
+                         `(external vars 
+                            ,(map FlowType-name E)
+                            ,(FlowType-name ftype)
+                            ,(map FlowType-name 
+                               (savable-ftype-external-vars ftype))
+                            ,(map FlowType-name (map cdr nu-tref))
+                            ,(map FlowType-name (map cdr nu-tdef))
+                            ,(map FlowType-name (map cdr nu-tbang))))]
+
+                    ;;[_ (show-stat-small)]
+                    ;; Restore state
+                    [s "Restoring kernel state"]
+                    [new-kernel-state
+                      (when separate-S 
+                        (mrspidey:progress s '...)
+                        (begin0
+                          (save-kernel-state)
+                          (restore-kernel-state! kernel-state)
+                          (mrspidey:progress s 'done)))]
+
+                    [s "Simplifying constraints"]
+                    [_ (mrspidey:progress s '...)]
+                    [l3 list-ftype]
+                    [(list-tvar tvar->nu) 
+                      (minimize-constraints-&-compare
+                        (st:unit-simplify) E E l1 l2)]
+                    [_ (mrspidey:progress s 'done)]
+
+                    ;; debugging test
+                    [_ '(mrspidey:progress "debugging-test" '...)]
+                    [_ '(check-unreachable
+                         (get-prefix l1 l2)
+                         (get-prefix list-ftype l3))]
+                    [_ '(really-check-kernel-ok)]
+                    [_ '(mrspidey:progress "debugging-test" 'done)]
+
+
+                    [ftype2 (update-ftype ftype tvar->nu)]
+                    [upd-binding 
+                      (match-lambda
+                        [(sym . tvar) (cons sym (tvar->nu tvar))])]
+                    [upd-tref (map upd-binding nu-tref)]
+                    [upd-tdef (map upd-binding nu-tdef)]
+                    [upd-tbang (map upd-binding nu-tbang)])
+
+                  (when separate-S
+                    (when (st:zero-old-constraint-sets)
+                      (free-kernel-state! new-kernel-state))
+                    (when (st:zero-old-asts)
+                      (zodiac:zero! exps)
+                      (zodiac:zero! parsed-exp)))
+                  ;;(show-stat-small)
+
+                  ;; Stuff to save in list-tvar, ftype2, 
+                  ;; upd-tref, upd-tdef, upd-tbang
+
+                  (when (st:unit-write-za)
+                    (write-za
+                      za list-tvar ftype2
+                      upd-tref upd-tdef upd-tbang))
+
+                  (values ftype2 upd-tref upd-tdef upd-tbang
+                    (if separate-S
+                      traverse-included-unit
+                      (lambda () 
+                        (values 
+                          exps parsed-exp
+                          ftype nu-tref nu-tdef nu-tbang))))))]
+            [_ (ok-ftype ftype)]
+            [l-end list-ftype]
+            [_
+              ;; Mark new ftypes as from .za file
+              (for-each
+                (lambda (ftype)
+                  (set-FlowType-type-annotation! ftype path+file))
+                (get-prefix l-end l-start))]
+            [atunit (apply-unit ftype partial-import-list)])
+
+          (pretty-debug-unit `(tbang ,tbang))
+                  
+          (begin
+            (for-each (match-lambda [(s . t) (add-global-tref! s t)]) tref)
+            (for-each (match-lambda [(s . t) (add-global-tdef! s t)]) tdef)
+            (for-each (match-lambda [(s . t) (add-global-tbang! s t)]) tbang))
+
+          (ok-ftype ftype)
+
+          (record-analyzed-file 
+            path+file
+            (lambda () (port-for-included-unit))
+            (lambda ()
+              (set! regenerating-ftype ftype)
+              (ok-ftype ftype)
+              
+              (let*-vals 
+                ( [s (format "Regenerating included unit ~a" 
+                       (file-name-from-path file))]
+                  [_ (mrspidey:progress s)]
+                  [(exps parsed-exp ftype2 tref2 tdef2 tbang2) 
+                    ((lambda () (regenerate)))])
+                (ok-ftype ftype)
+                (flow-d! ftype2 ftype)
+                (flow-e! tdef2 tdef)
+                (flow-e! tbang2 tbang)
+                (flow-e! tref tref2)
+                (list parsed-exp))))
+
+          (unless (atunit? atunit)
+            (mrspidey:error 
+              (format
+                "reference-unit file did not produce an annotated unit ~s" 
+                atunit)))
+
+          atunit)]))
+ 
+;; ----------------------------------------------------------------------
+
+(define (make-savable-ftype ftype)
+  ;; Converts an ftype to a "savable" ftype
+  ;; ie a tvar, a closed schema, a primitive, an atstruct
+  ;; or an atunit with savable exports and result
+  ;; atvalues could also be made savable, if there is any need
+  (if (Tvar? ftype)
+      ftype
+      (match (fo-FlowType-def ftype)
+        [($ schema tvar tvar* '()) ftype]
+        [($ atunit imports exports result exp)
+         (create-fo-FlowType
+          (make-atunit imports
+                       (map (match-lambda
+                             [(sym . ftype) 
+                              (cons sym (make-savable-ftype ftype))])
+                            exports)
+                       (make-savable-ftype result)
+                       exp))]
+        [(and atlunit ($ atlunit)) 
+         (make-savable-ftype (create-fo-FlowType (atlunit->atunit atlunit)))]
+        [(and pi ($ atprim name type)) ftype]
+        [(? atstruct?) ftype]
+        [_ (FlowType->Tvar ftype)])))
+
+;; --------------------
+        
+(define (savable-ftype-external-vars ftype)
+  (if (Tvar? ftype)
+      (list ftype)
+      (match (fo-FlowType-def ftype)
+        [($ schema tvar tvar* '()) (list tvar)]
+        [($ atprim) '()]
+        [($ atunit imports exports result exp)
+         (apply append 
+                (append (map cdr imports)
+                        (map savable-ftype-external-vars (map cdr exports))
+                        (list (savable-ftype-external-vars result))))]
+        [($ atstruct) '()]
+        [x (mrspidey:internal-error 'savable-ftype-external-vars
+                                    "Bad Atype ~s" x)])))
+
+;; --------------------
+
+(define (update-ftype ftype tvar->nu)
+  ;; Creates a copy of ftype with new type variables
+  (if (Tvar? ftype)
+      (tvar->nu ftype)
+      (create-fo-FlowType
+       (match (fo-FlowType-def ftype)
+         [($ schema tvar tvar* '())
+          (make-schema (tvar->nu tvar) (filter-map tvar->nu tvar*) '())]
+         [(? atprim? atprim) atprim]
+         [($ atunit imports exports result exp)
+          (make-atunit
+           (map (match-lambda
+                 [(sym . tvar*) (cons sym (map tvar->nu tvar*))])
+                imports)
+           (map (match-lambda
+                 [(sym . ftype) 
+                  (cons sym (update-ftype ftype tvar->nu))])
+                exports)
+            (update-ftype result tvar->nu)
+            exp)]
+         [(? atstruct? atstruct) atstruct]))))
+
+;; --------------------
+        
+(define (flow-d! ftype2 ftype)
+  (let ([E2 (savable-ftype-external-vars ftype2)]
+        [E  (savable-ftype-external-vars ftype)])
+    (pretty-debug-unit
+      `(E ,(map FlowType-name E) E2 ,(map FlowType-name E2)))
+    (unless (= (length E) (length E2))
+      (mrspidey:error
+        (format "The .za file is incompatible, and may be of date (~s ~s)"
+          (length E) (length E2))))
+    (for-each new-bidir-edge! E E2)))
+
+;; --------------------
+
+(define (ok-ftype ftype)
+  (pretty-debug-unit `(ok-ftype ,(FlowType-name ftype)))
+  (let ([E  (savable-ftype-external-vars ftype)])
+    (pretty-debug-unit `(E ,(map FlowType-name E)))
+    (for-each
+      (lambda (tvar)
+        (assert (list? (FlowType-arrowto tvar)) 
+          'ok-ftype (FlowType-num ftype)))
+      E)))
+
+;; --------------------
+        
+(define (flow-e! env env2)
+    (assert (= (length env) (length env2)) 'flow-e! env env2)
+    (for-each new-bidir-edge! (map cdr env) (map cdr env2)))
+
+;; ----------------------------------------------------------------------
+
+;(trace apply-unit)
+;(trace apply-atlunit)
+;(trace apply-atlunit-unit)
+;(trace apply-atlunit-cmpd)
+;(trace apply-atlunit-reference)
+;(trace atlunit->atunit)

collects/mrspidey/Sba/atype.ss

@@ -0,0 +1,343 @@
+;; atype.ss - handles annotated types
+; ----------------------------------------------------------------------
+; Copyright (C) 1995-97 Cormac Flanagan
+;
+; This program is free software; you can redistribute it and/or
+; modify it under the terms of the GNU General Public License
+; version 2 as published by the Free Software Foundation.
+; 
+; This program is distributed in the hope that it will be useful,
+; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+; GNU General Public License for more details.
+; 
+; You should have received a copy of the GNU General Public License
+; along with this program; if not, write to the Free Software
+; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
+; ----------------------------------------------------------------------
+
+;; ----------------------------------------------------------------------
+;; FlowType      - expr, edgeto, edgefrom, type-annotation
+;; Tvar          - sub-structure of FlowType, is type variable
+;; fo-FlowType   - FlowType with def field containing fo-Atype
+;; fo-Atype      - atprim etc, see below
+;; Atype         - Tvar or fo-Atype
+;; ----------------------------------------------------------------------
+
+(define-const-typed-structure (fo-FlowType struct:FlowType)
+  ( (: def fo-Atype)
+    (: tvar Tvar)))
+
+(define (FlowType->Atype ftype)
+  (cond
+    [(Tvar? ftype) ftype]
+    [(fo-FlowType? ftype) (fo-FlowType-def ftype)]
+    [else
+      (mrspidey:internal-error 'FlowType->Atype "Bad ftype ~s" ftype)]))
+
+(define (create-fo-FlowType fo-atype)
+  (assert (fo-Atype? fo-atype) 'create-fo-FlowType fo-atype)
+  (if (and 
+        (not (st:use-fo-ftype))
+        (or
+          (atconst? fo-atype)
+          (and (atvalues? fo-atype)
+            (andmap Tvar? (atvalues-values fo-atype)))))
+    (Atype->Tvar fo-atype)
+    (add-FlowType! 
+      (make-fo-FlowType num-ftype #f '() '() #f '() #f fo-atype #f))))
+  
+;; ----------
+
+(define-type fo-Atype
+  (union atconst schema atprim atthunk atstruct atvalues
+         atunit atlunit))
+
+(define (fo-Atype? x)
+  (or (atconst? x) 
+      (schema? x)
+      (atprim? x)
+      (atthunk? x)
+      (atstruct? x)
+      (atvalues? x)
+      (atunit? x)
+      (atlunit? x)))
+
+(define (poly-atype? x)
+  (or (schema? x)
+      (atthunk? x)))
+
+;; --------------------
+;; atconst
+
+(define-const-typed-structure
+  atconst ((: c (union num bool))))
+
+;; --------------------
+;; schema
+
+(define-const-typed-structure
+  schema ((: tvar Tvar)
+          (: tvar* (listof Tvar))
+          (: edges (listof (cons Tvar Tvar)))))
+
+;; --------------------
+;; atprim
+
+(define-const-typed-structure
+  atprim ((: sym sym)
+           (: type sexp)
+           (: domain-filters (listof filter))
+           predicate-fn
+           attrs
+           orig-type
+           ))
+
+;; filter-domains is a list of filters for various args,
+;; if no error raised
+;; inj-predicate is a fn : list-tvar x list-tvar x tvar x bool -> Tvar 
+;; used for (if (pred ... x ...) ...)
+
+;; --------------------
+;; atthunk
+
+(define-const-typed-structure
+  atthunk ((: thunk (-> FlowType))))
+
+;; --------------------
+;; atstruct
+
+(define-const-typed-structure
+  atstruct ((: struct:sym sym)
+            (: super-constructors (listof sym))
+            parent-gen-args
+            parent-match-args
+            parent-field-types
+            parent-list-mutable))
+
+;; ----------------------------------------------------------------------
+;; atvalues
+
+(define-const-typed-structure
+  atvalues ((: values (listof FlowType))))
+
+(define (wrap-value x) 
+  (let* ([ftype (cond 
+                  [(FlowType? x) x]
+                  [(fo-Atype? x) (create-fo-FlowType x)]
+                  [else (mrspidey:internal-error 
+                          'wrap-value "Bad x ~s" x)])]
+          [ftype (if (or (FlowType-expr ftype)
+                         (FlowType-values-ftype ftype))
+                   (copy-ftype ftype)
+                   ftype)]
+          [r (create-fo-FlowType (make-atvalues (list ftype)))])
+    (set-FlowType-values-ftype! ftype r)
+    (pretty-debug-atype
+      `(wrap-value ,(FlowType-name ftype) ,(FlowType-name r)))
+    r))
+
+(define (extract-1st-value ftype)
+  (car (multiple-value-components ftype 1)))
+
+(define (multiple-value-components ftype n)
+  ;; returns list of n value components
+  (assert (integer? n) 'multiple-value-components)
+  (cond
+   [(zero? n) '()]
+   [(fo-FlowType? ftype)
+    (match (fo-FlowType-def ftype)
+      [($ atvalues l) 
+       (recur loop ([n n][l l])
+         (cond [(zero? n) '()]
+               [(null? l) (cons (mk-tvar-empty) (loop (sub1 n) '()))]
+               [else (let* ( [a (car l)]
+                             [b (copy-ftype a) ])
+                       ;(if (FlowType-expr a) (copy-ftype a) a)
+                       (when need-explanation (add-FlowType-arrow! ftype b))
+                       (cons b (loop (sub1 n) (cdr l))))]))]
+      [_ #f])]
+   [else
+     (let ( [tvar-mv (FlowType->Tvar ftype)]
+            [tvar (mk-Tvar 'get-mvalues)])
+       (new-con! tvar-mv (create-con template-mvalues 0 tvar #t))
+       (recur loop ([tvar tvar][n n])
+         (let ([a (mk-Tvar 'car-value)])
+           (new-con! tvar (make-con-car a))
+           (when need-explanation (add-FlowType-arrow! tvar-mv a))
+           (cons a
+             (if (= n 1)
+               '()
+               (let ([d (mk-Tvar 'cdr-value)])
+                 (new-con! tvar (make-con-cdr d))
+                 (loop d (sub1 n))))))))]))
+
+;; ----------------------------------------------------------------------
+;; Annotated (lazy) unit types
+
+(define-const-typed-structure
+  atunit
+  ((: imports (listof (cons sym (listof Tvar))))
+   (: exports (listof (cons sym FlowType)))
+   (: result FlowType)
+   (: expr zodiac:parsed)))
+
+(define-const-typed-structure
+  atlunit ((! ui (union false atunit))))
+
+;; ----------------------------------------------------------------------
+
+;; (: FlowType->Tvar (FlowType -> Tvar))
+
+(define (FlowType->Tvar ftype)
+  (let ([tvar
+          (cond
+            [(Tvar? ftype) ftype]
+            [(fo-FlowType? ftype)
+              (or (fo-FlowType-tvar ftype)
+                (let ([tvar (Atype->Tvar (fo-FlowType-def ftype))])
+                  (when need-explanation (add-FlowType-arrow! ftype tvar))
+                  ;(set-fo-FlowType-tvar! ftype tvar)
+                  tvar))]
+            [else
+              (mrspidey:internal-error 'FlowType->Tvar "Bad FlowType ~s" ftype)])])
+    (pretty-debug-atype
+      `(FlowType->Tvar ,(FlowType-name ftype) ,(Tvar-name tvar)))
+    tvar
+))
+
+(define Atype->Tvar 
+  (lambda (atype)
+    (let ([tvar
+            (match atype
+              [(? Tvar? tvar) tvar]
+              [($ atconst c)
+                (let ([tvar (mk-Tvar 'atconst->tvar)])
+                  (new-AV! tvar (traverse-const-exact c))
+                  tvar)]
+              [($ atstruct) (mk-tvar-void)]
+              [($ atthunk thunk) (thunk)]
+              [(and pi ($ atprim name type))
+                (let ([tvar (mk-Tvar name)])
+                  (tschema->con type tvar name pi)
+                  tvar)]
+              [($ schema tvar tvar* edges)
+                (copy-constraint-set tvar tvar* edges)]
+              [($ atunit imports exports result)
+                (pretty-debug-atype
+                  `(Atype->Tvar (atunit ,imports ,exports ,result)))
+                (let ([tvar-u (mk-Tvar 'inst-unit)])
+                  (for-each-with-n
+                    (lambda (import n)
+                      (map (lambda (tvar)
+                             (new-AV! tvar-u
+                               (create-AV (get-unit-import-template n)
+                                 '() (vector) (vector tvar))))
+                        (cdr import)))
+                    imports)
+                  (for-each
+                    (match-lambda
+                      [(sym . ftype)
+                        (new-AV! tvar-u
+                          (create-AV (get-unit-export-template sym)
+                            '() (vector (FlowType->Tvar ftype)) (vector)))])
+                    exports)
+                  (new-AV! tvar-u
+                    (create-AV template-unit '() 
+                      (vector (FlowType->Tvar result)) 
+                      (vector)))
+                  tvar-u)]
+              [(and atlunit ($ atlunit))
+                (Atype->Tvar (atlunit->atunit atlunit))]
+              [($ atvalues ftype*)
+                (let ([tvar-list
+                        (foldr
+                          (lambda (ftype tvar-rest)
+                            (let* ([tvar (mk-Tvar 'atvalues->tvar)])
+                              (new-AV! tvar 
+                                (make-AV-cons (FlowType->Tvar ftype)
+                                  tvar-rest))
+                              tvar))
+                          (mk-tvar-nil)
+                          ftype*)]
+                       [tvar (mk-Tvar 'atvalues->values)])
+                  (new-AV! tvar 
+                    (create-AV template-mvalues '() 
+                      (vector tvar-list) (vector)))
+                  tvar)]
+              [x (mrspidey:internal-error 'Atype->Tvar "Bad Atype ~s" x)])])
+      (pretty-debug-atype
+        `(atype->tvar ,(Atype->pretty atype) ,(Tvar-name tvar)))
+      tvar)))
+
+;; ----------------------------------------------------------------------
+
+(define FlowType->pretty
+  (lambda (ftype)
+    (cond
+     [(Tvar? ftype) (Tvar-name ftype)]
+     [(fo-FlowType? ftype)
+       (Atype->pretty (fo-FlowType-def ftype))])))
+
+(define Atype->pretty
+  (match-lambda
+    [($ atconst c) `(const ,c)]
+    [($ atthunk thunk) 'thunk]
+    [(and pi ($ atprim name _ _ _ attrs type)) `(prim ,name ,type)]
+    [($ schema tvar tvar* edges) 
+      `(schema ,(Tvar-name tvar) ,(map Tvar-name tvar*))]
+    [($ atunit imports exports result)
+      `(atunit 
+         (imports ,@(map (match-lambda
+                           [(sym . tvar*)
+                             (cons sym (map Tvar-name tvar*))])
+                      imports))
+         (exports ,@(map (match-lambda
+                           [(sym . ftype)
+                             (list sym (FlowType->pretty ftype))])
+                      exports))
+         (result ,(FlowType->pretty result)))]
+    [($ atlunit thunk) `(lazy-unit)]
+    [($ atstruct A B C D E F) (list 'struct: A B C D E F)]
+    [($ atvalues ftype*) `(values ,@(map FlowType->pretty ftype*))]
+    [x
+      (mrspidey:internal-error 'Atype->pretty "Bad fo-Atype ~s" x)]))
+
+(define FlowType->SDL
+  (lambda (ftype)
+    (pretty-debug-sdl2
+      `(FlowType->SDL ,(FlowType-name ftype) ,(FlowType->pretty ftype)))
+    (cond
+     [(Tvar? ftype) (Tvar->SDL ftype)]
+     [(fo-FlowType? ftype)
+      (match (fo-FlowType-def ftype)
+        [($ atconst c) `(const ,c)]
+        [($ atthunk thunk) `(thunk ,(Tvar->SDL (thunk)))]
+        [($ atprim name _ _ _ _ type) `(prim ,type)]
+        [($ schema tvar tvar* edges) `(schema ,(Tvar->SDL tvar))]
+        [(and def ($ atunit imports exports result))
+         `(unit ,(Tvar->SDL (FlowType->Tvar ftype)))]
+        [(and ($ atlunit thunk) lui)
+         `(lazy ,(FlowType->SDL (create-fo-FlowType (atlunit->atunit lui))))]
+        [($ atstruct) 'struct:]
+        [($ atvalues (ftype)) (FlowType->SDL ftype)]
+        [($ atvalues ftype*) `(values ,@(map FlowType->SDL ftype*))]
+        [x (mrspidey:internal-error 'FlowType->SDL "Bad fo-Atype ~s" x)])]
+     [else (mrspidey:internal-error 'FlowType->SDL "Bad ftype ~s" ftype)])))
+
+(define (copy-ftype ftype)
+  (cond
+    [(Tvar? ftype)
+      (let ([tvar (mk-Tvar 'copy)])
+        (new-edge! ftype tvar)
+        tvar)]
+    [(fo-FlowType? ftype)
+      (let ([nu-ftype (create-fo-FlowType (fo-FlowType-def ftype))])
+        (when need-explanation (add-FlowType-arrow! ftype nu-ftype))
+        nu-ftype)]
+    [else (mrspidey:internal-error 'link-parsed-ftype!
+            "Bad ftype ~s, maybe old language" ftype)]))
+
+;; ----------------------------------------------------------------------
+
+

collects/mrspidey/Sba/checks.ss

@@ -0,0 +1,716 @@
+;; smart-checks.ss - identifies unsafe operations
+; ----------------------------------------------------------------------
+; Copyright (C) 1995-97 Cormac Flanagan
+;
+; This program is free software; you can redistribute it and/or
+; modify it under the terms of the GNU General Public License
+; version 2 as published by the Free Software Foundation.
+; 
+; This program is distributed in the hope that it will be useful,
+; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+; GNU General Public License for more details.
+; 
+; You should have received a copy of the GNU General Public License
+; along with this program; if not, write to the Free Software
+; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
+; ----------------------------------------------------------------------
+
+
+;;-------------------------------------------
+
+(define-struct annotation (loc))
+(define-struct (check-annotation struct:annotation) (text num rest))
+(define-struct (uncheck-annotation struct:annotation) (text))
+(define-struct (type-annotation struct:annotation) (end-first finish FlowType))
+
+;; ------------------------------
+
+(define check-annotations   '())        ; store away checks for mred
+(define uncheck-annotations '())        ; store away unchecked prims
+
+;;-------------------------------
+;; Counters
+
+(define prim-count  (void))
+(define lam-count   (void))
+(define prim-apps   (void))
+(define user-apps   (void))
+(define ivar-count  (void))
+(define type-assert-count (void))
+(define type-assert-failed-total (void))
+
+(define prim-checks-def (void))
+(define lam-checks-def  (void))
+(define ap-checks-def   (void))
+(define ivar-checks-def (void))
+(define type-assert-failed-def (void))
+
+(define total-checks (void))
+
+;; --------------------
+
+(define init-counts
+  (lambda ()
+    (set! prim-count (make-counter))
+    (set! lam-count  (make-counter))
+    (set! prim-apps  (make-counter))
+    (set! user-apps  (make-counter))
+    (set! ivar-count  (make-counter))
+    (set! type-assert-count (make-counter))
+    (set! type-assert-failed-total (make-counter))
+    (set! total-checks (make-counter))
+    (reset-counts)))
+
+;; These three count per expression 
+;; need to be reset with every definition traversed.
+
+(define reset-counts
+  (lambda ()
+    (set! prim-checks-def (make-counter))
+    (set! lam-checks-def  (make-counter))
+    (set! ap-checks-def   (make-counter))
+    (set! ivar-checks-def (make-counter))
+    (set! type-assert-failed-def (make-counter))))
+
+ (define make-counter
+   (lambda ()
+     (let ([num 0])
+       (lambda (n)
+         (set! num (+ n num))
+         num))))
+
+;; ----------------------------------------
+
+(define calc-checks
+  (lambda (defs)
+    (mrspidey:add-summary (format "CHECKS:"))
+    (init-counts)
+    (set! check-annotations   '()) 
+    (set! uncheck-annotations '()) 
+    (for-each-with-n
+     (lambda (def n)
+       (mrspidey:zprogress "Checking" (zodiac:zodiac-start def))
+       (match def
+         [($ zodiac:define-values-form _ open _ _ 
+            ($ zodiac:list _ _ _ ($ zodiac:varref _ _ _ _ sym))
+            _)
+          (reset-counts)
+          ((zodiac:compat check-fn) def)
+           ;;(make-check-summary-line sym open)
+           ]
+         [_
+          (reset-counts)
+          ((zodiac:compat check-fn) def)
+          '(make-check-summary-line 
+             (format "<expr> at line ~s" 
+               (zodiac:location-line 
+                 (zodiac:zodiac-start def)))
+             (zodiac:zodiac-start def))
+           ]))
+     defs)
+    (unless (null? defs)
+      (mrspidey:zprogress "Checking" (zodiac:zodiac-finish (rac defs))))
+    (make-check-summary "")
+    (list check-annotations uncheck-annotations)))
+
+;; ----------
+
+(define check-fn
+  (lambda (M unp)
+    (pretty-debug-check `(check-fn ,(zodiac:stripper M)))
+    (match M
+      ;; ivars
+      [($ zodiac:app _ _ _ _
+         ($ zodiac:varref _ open _ _ (and ivar-sym (or '#%uq-ivar 'uq-ivar)))
+         (obj-exp ivar-arg))
+        (=> fail)
+        (pretty-debug-check `(ivar ,ivar-sym))
+
+        ;; Check the ivar is ok
+        (let*-vals
+          ( [ftype (zodiac:parsed-ftype obj-exp)]
+            [ftype (and ftype (extract-1st-value ftype))]
+            [(tvars-ivarset-ok? set-tvar-ivarset-ok!) 
+              (alloc-Tvar-field)])
+          (letrec
+            ([check-ivarset-ok?
+               (lambda (tvar sym)
+                 (pretty-debug-check `(check-ivarset-ok? ,(Tvar-name tvar)))
+                 (set-tvar-ivarset-ok! tvar #t)
+                 (andmap
+                   (match-lambda
+                     [($ AV _ (? (lambda (t) (eq? t template-ivarset)))
+                        misc fields+)
+                       (assert (list? misc) 'ivar-check)
+                       (or 
+                         (memq sym misc)
+                         (let ([parent (vector-ref fields+ 0)])
+                           (and (not (null? (get-Tvar-objs parent)))
+                             (check-ivarset-ok? parent sym)))
+                         (begin
+                           (pretty-debug-check
+                             `(ivar-failure ,sym ,misc ,(Tvar-name tvar)))
+                           #f)
+                         )]
+                     [_ #t])
+                   (get-Tvar-objs tvar)))])
+            (if 
+              (match ivar-arg
+                [($ zodiac:quote-form _ _ _ _ ($ zodiac:symbol _ _ _ sym))
+                  (and (Tvar? ftype) (check-ivarset-ok? ftype sym))]
+                [_ #f])
+              (begin
+                (ivar-count 1)
+                (add-uncheck! open (symbol->string ivar-sym)))
+              (begin
+                (ivar-count 1)
+                (ivar-checks-def 1)
+                (mrspidey:add-summary "ivar check" open 0)
+                (add-check! open (symbol->string ivar-sym))))))
+
+        ;; Check the primitive application - NOT!
+        '(match ivar-arg
+           [($ zodiac:quote-form _ _ _ _ ($ zodiac:symbol _ open _ sym))
+             (let* ([ftype (zodiac:parsed-ftype M)])
+               (when ftype
+                 (let ([ftype (extract-1st-value ftype)])
+                   (when (Tvar? ftype)
+                     (pretty-debug-check '(ivar-tvar))
+                     (match (get-Tvar-objs ftype)
+                       [(($ AV _ (? (lambda (t) (eq? t template-lam)))
+                           (and pi ($ atprim name type))))
+                         (pretty-debug-check '(ivar-lam-AV))
+                         (case (check-prim pi (zodiac:parsed-ftype M))
+                           [(#t)
+                             (prim-count 1)
+                             (add-uncheck! open (symbol->string sym))]
+                           [(#f)
+                             (prim-count 1)
+                             (mrspidey:add-summary "Method check" open 0)
+                             (prim-checks-def 1)
+                             (add-check! open (symbol->string sym) ftype)
+                             (pretty-debug `(CHECK-fo-prim ,(zodiac:stripper M)))
+                             (zodiac:set-parsed-check! ivar-arg #t)]
+                           [(not-function-type) 
+                             (pretty-debug-check '(ivar-not-fn-type))]
+                           [(not-function-AV) (printf "ivar:not-function-AV~n")])]
+                       [_ (void)])))))]
+           [_ (void)])
+        (fail)]
+      [($ zodiac:app _ _ _ _ fn args)
+        (unless (atprim? (zodiac:parsed-atprim fn))
+          (check-ap M))
+        #f]
+      [($ zodiac:case-lambda-form) 
+       (check-lambda M)
+       #f]
+      [($ zodiac:top-level-varref)
+       (if (zodiac:parsed-atprim M)
+           (check-ho-prim M)
+           ;; Otherwise should do bound? check, but don't
+           (void))
+       #f]
+      [($ zodiac::-form)
+       (check-type-assertion M)
+       #f]
+      [_ #f])))
+
+;;-------------------------------------------
+
+(define (parsed-Tvar x) 
+  ;;(pretty-print `(parsed-Tvar ,(zodiac:stripper x)))
+  (if (zodiac:parsed-ftype x)
+    (let* ( [ftype (zodiac:parsed-ftype x)]
+            [tvar (FlowType->Tvar ftype)])
+      (pretty-debug-check
+        `(parsed-Tvar ,(zodiac:stripper x) ,(FlowType-name ftype) 
+           ,(Tvar-name tvar)))
+      tvar)
+    (mk-tvar-empty)))
+
+(define check-ap
+  (match-lambda
+    [(and app ($ zodiac:app _ open _ _ fun args))
+      (pretty-debug-check
+        `(check-ap,(zodiac:stripper fun) ,(zodiac:parsed-ftype fun)))
+      (let ([ftype-fn (zodiac:parsed-ftype fun)]) 
+        (match (and (FlowType? ftype-fn) (FlowType->Atype ftype-fn))
+          [($ atprim) (prim-apps 1)]
+          [_ (user-apps 1)]))
+      (let ([tvar (parsed-Tvar fun)])
+        (unless 
+          (or
+            (st:all-checks)
+            (Tvar-in-type? tvar 
+              '(mvalues (cons (lambda _ _) (nil)))
+              '()
+              (lambda (a)
+                (mrspidey:error 'check-ap 
+                  "Reference to unbound type var ~s" a))))
+          ;; Check the application
+          (ap-checks-def 1)
+          (mrspidey:add-summary "Application check" open 0)
+          (add-check! open "(" tvar)
+          (pretty-debug `(CHECK-ap ,(zodiac:stripper app)))
+          (zodiac:set-parsed-check! app #t)))]))
+
+(define check-lambda
+  (match-lambda
+    [(and lam ($ zodiac:case-lambda-form _ open _ _ arglists bodies))
+      (pretty-debug-check `(check-lam ,(zodiac:stripper lam)))
+      ;; put arity check on lambda 
+      (lam-count 1)
+      (let* ( [tvar (parsed-Tvar lam)]
+              [tvar (extract-1st-value tvar)])
+        (match (get-Tvar-objs tvar)
+          [(($ AV _ (? (lambda (t) (eq? t template-lam))) misc _ #(domain))
+             . _) 
+            ;; rest may be other AV-lam's for this case-lambda
+            (let* ([arglist->ilist
+                     (match-lambda
+                       [($ zodiac:sym-arglist)
+                         '_]
+                       [($ zodiac:list-arglist vars) 
+                         (map (lambda (_) '_) vars)]
+                       [($ zodiac:ilist-arglist vars)
+                         (recur loop ([vars vars])
+                           (match vars
+                             [(x) '_]
+                             [(a . b) `(_ . ,(loop b))]))])]
+                    [type
+                      (recur loop ([ilists (map arglist->ilist arglists)])
+                        (pretty-debug-check `(ilists ,ilists))
+                        (if (memq '_ ilists)
+                          '_
+                          (let ( [nils 
+                                   (filter null? ilists)]
+                                 [non-nils
+                                   (filter 
+                                     (lambda (x) (not (null? x)))
+                                     ilists)])
+                            (cond
+                              [(null? non-nils)
+                                'nil]
+                              [(null? nils) 
+                                `(cons _ ,(loop (map cdr non-nils)))]
+                              [else
+                                `(union
+                                   nil
+                                   (cons _ ,(loop (map cdr non-nils))))]))))])
+              (pretty-debug-check `(type ,type))
+                    
+              (when
+                (or
+                  (st:all-checks)
+                  (not (Tvar-in-type? 
+                         domain (expand-input-type type) '()
+                         (lambda (a)
+                           (mrspidey:internal-error 'check-lambda
+                             "unbound tvar")))))
+                ;; Check it
+                (lam-checks-def 1)
+                (mrspidey:add-summary "Arity check" open 0)
+                (add-check! open "lambda" domain)
+                (zodiac:set-parsed-check! lam #t)))]
+          [_;; never analyzed
+            (void)]))]))
+
+(define (check-ho-prim M)
+  ;; name : name-structure of prim
+  ;; open: source location for primitive
+  ;; returns correct primitive and either 1 or 0
+
+  (pretty-debug-check `(check-ho-prim ,(zodiac:stripper M)))
+
+  (match-let*
+    ( [($ zodiac:varref _ open _ _ sym) M]
+      [(and atprim ($ atprim sym tschema _ _ _)) (zodiac:parsed-atprim M)])
+
+    (match (parsed-Tvar M)
+      [(? Tvar? tvar)
+
+        (case (check-prim atprim tvar)
+          [(#t)
+            (prim-count 1)
+            (add-uncheck! open (symbol->string sym))]
+          [(#f)
+            (prim-count 1)
+            (mrspidey:add-summary (format "~s check" sym) open 0)
+            (prim-checks-def 1)
+            (add-check! open (symbol->string sym) tvar)
+            (pretty-debug `(CHECK-fo-prim ,(zodiac:stripper M)))
+            (zodiac:set-parsed-check! M #t)]
+          [(not-function-type) (void)]
+          [(not-function-AV) 
+            ;(printf "check-hoo-prim: not-function-AV~n")
+            (void)])])))
+
+;; ----------------------------------------------------------------------
+
+(define (check-prim atprim tvar)
+
+  (pretty-debug-check `(check-prim ,atprim ,(Tvar-name tvar) ))
+
+  (match (get-Tvar-objs (extract-1st-value tvar))
+    [(($ AV _ template misc _ #(domain))) 
+      (check-prim-domain atprim domain)]
+    [_ 'not-function-AV]))
+
+(define (check-prim-domain atprim domain)
+  (pretty-debug-check `(check-prim-domain ,atprim ,(Tvar-name domain) ))
+  (match-let*
+    ( [($ atprim sym tschema _ _ _) atprim]
+      [schemas (match tschema
+                 [('case-> . schemas) schemas]
+                 [schema (list schema)])])
+
+    (ormap
+      (lambda (schema)
+
+        (let-values ([(forall type) (split-schema schema)])
+          (match type
+            [('lambda expected-domain _)
+              (pretty-debug-check `(check-prim domain ,(Tvar-name domain)))
+              (if (and 
+                    (Tvar-in-type? 
+                      domain expected-domain forall
+                      (lambda (a)
+                        (mrspidey:warning
+                          (format
+                            "Reference to unbound type var ~s in domain of ho primitive ~s" 
+                            a sym))
+                        (lambda (AV) #f)))
+                    (not (st:all-checks)))
+                #t
+                (begin
+                  (pretty-debug-check 
+                    `(check-prim-domain failed on ,sym
+                       ,(FlowType-name domain)
+                       ,expected-domain))
+                  #f))]
+            [_
+              ;; Not a primitive function
+              (pretty-debug-check `(Not a prim fn ,type))
+              'not-function-type])))
+
+      schemas)))
+
+;; ----------------------------------------------------------------------
+
+(define check-type-assertion
+  (match-lambda
+   [(and M ($ zodiac::-form _ open _ _ exp type))
+    (pretty-debug-check `(check-type-assertion ,(zodiac:stripper M)))
+    (type-assert-count 1)
+    (let* ([tvar (extract-1st-value (parsed-Tvar exp))]
+           [in-type?
+            (lambda (type) 
+              (Tvar-in-type? 
+               tvar (expand-input-type type) '()
+               (lambda (a)
+                   (mrspidey:warning
+                     (format "Unbound type variable ~s" a)
+                     open 3)
+                 (lambda (AV) #f))))])
+      (unless 
+          (match type
+            [('exact type) 
+             ;; Can't do exact yet - best is nonempty
+             (and (not (null? (get-Tvar-objs tvar))) (in-type? type))]
+            [_ (in-type? type)])
+        ;; Is bad
+        (type-assert-failed-def 1)
+        (type-assert-failed-total 1)
+        (add-check! open "(")
+        (mrspidey:warning
+         (format "Type assertion ~s failed"
+                 (list ': '... ;;(zodiac:stripper exp)
+                       type))
+         (zodiac:zodiac-start M) 
+         2)))]))
+
+;; ----------------------------------------------------------------------
+
+'(define (Tvar-in-global-type? ftype type where)
+  (Tvar-in-type? 
+   Tvar 
+   (expand-input-type type)
+   (lambda (fv)
+     (lookup-or-fail 
+      global-tdef-env fv
+      (lambda ()
+        (mrspidey:error
+         (format 
+          "Reference to unbound type var ~s in ~a ~s"
+          fv where type)))))))
+
+;; ----------------------------------------------------------------------
+
+(define (add-check! open text . rest)
+  (set! check-annotations 
+      (cons (make-check-annotation open text (total-checks 0) rest)
+            check-annotations))
+  (total-checks 1))
+
+(define (add-uncheck! open text)
+  (set! uncheck-annotations 
+      (cons (make-uncheck-annotation open text) uncheck-annotations)))
+
+(define (show-checks)
+  (for-each
+   (match-lambda
+    [($ annotation ($ zodiac:location l c o f) text)
+     (printf "File: ~s offset ~s text ~s~n"
+             (file-name-from-path f) o text)])
+   check-annotations))
+
+;; ----------------------------------------------------------------------
+
+(define (file-wrapper-start outport)
+  ;; Writes prefix to file
+  ;(fprintf outport ";; Generated by SBA Soft Scheme ~a~%" st:version)
+  (fprintf outport ";; Control string ")
+  (for-each (lambda (x) (fprintf outport" '~a" x)) (mrspidey:control-fn))
+  (fprintf outport "~n~n"))
+
+(define (file-wrapper-end outport)
+  (newline outport)
+  '(for-each (lambda (s) (fprintf outport ";; ~a" s))
+             (reverse summary))
+  (void)
+  )
+
+;; ----------------------------------------------------------------------
+
+'(define (write-soft-file outfile)
+   ;; Writes soft typed file - macro expanded with checks - executable
+   (when (file-exists? outfile) (delete-file outfile))
+   (let ([outport (open-output-file outfile)])
+    
+     (file-wrapper-start outport)
+     (for-each
+      (lambda (def)
+        (pretty-print 
+         ((zodiac:unparse-dynamic-letd
+           (lambda (exp cl-fn)
+             (if (zodiac:parsed-check exp)
+                 (match exp
+                   [($ zodiac:app _ open close back fun args)
+                    `(CHECK-ap ,(cl-fn fun) ,@(map cl-fn args))]
+                   [($ zodiac:lambda-form _  open close back 
+                       args body level)
+                    (let* ([args (map-ilist cl-fn args)])
+                      `(CHECK-lambda ,args ,(cl-fn body)))]
+                   [($ zodiac:lexical-varref
+                       _ open close _
+                       ($ zodiac:bound _ _ _ _ sym) 
+                       Tvar-box)
+                    (symbol-append 'CHECK- sym)])
+                 #f)))
+          def)
+         outport)
+        (newline outport))
+      defs-bind)
+     (file-wrapper-end outport)))      
+
+;; ----------------------------------------------------------------------
+
+'(define (write-annotated-file outfile source-thunk)
+   ;; As source file, but with checks
+   (when (file-exists? outfile) (delete-file outfile))
+   (let* ([inport (source-thunk)]
+          [outport (open-output-file outfile)]
+          [checks (map
+                   (match-lambda
+                    [($ annotation loc)
+                     (cons (zodiac:location-offset loc) rest)])
+                   check-annotations)]
+          [checks (sort
+                   (match-lambda*
+                    [((ofs1 . _) (ofs2 . _)) (< ofs1 ofs2)])
+                   checks)])
+    
+     (file-wrapper-start outport)
+     (recur loop ([pos 0][checks checks])
+       (let ([c (read-char inport)])
+         (unless (eof-object? c)
+           (match checks
+             [(( (? (lambda (p) (= p pos)))
+                 num name . _) 
+               . _) 
+              (let ([to-drop
+                     (match name
+                       ["("
+                        ;; Is an application check
+                        (assert (char=? c #\())
+                        (display (format "(CHECK-ap ~s " num)
+                                 outport)
+                        ""]
+                       ["lambda"
+                           ;; Is a lambda check
+                           (assert (char=? c #\())
+                         (display (format "(CHECK-lambda ~s " num)
+                                  outport)
+                         "lambda"]
+                       [prim
+                        ;; Is a primitive check
+                        (assert (char=? c (string-ref prim 0)))
+                        (display (format "(CHECK-~a ~s)" name num)
+                                 outport)
+                        (substring prim 1 (string-length prim))])])
+                (recur loop2 ([pos (add1 pos)]
+                              [s (string->list to-drop)])
+                  (cond
+                   [(null? s) (loop pos (cdr checks))]
+                   [(char=? (read-char inport) (car s))
+                    (loop2 (add1 pos) (cdr s))]
+                   [else
+                    (error 'write-annotated-file
+                           "File not as expected")])))]
+             [_                       
+              (write-char c outport)
+              (loop (add1 pos) checks)]))))
+    
+     (close-input-port inport)
+     (file-wrapper-end outport)
+     (close-output-port outport)))
+
+;; --------------------
+
+(define make-check-summary-line
+  (lambda (name src)
+    (let ([total (+ (prim-checks-def 0) (lam-checks-def 0) 
+                    (ap-checks-def 0) (type-assert-failed-def 0))])
+      (unless (= 0 total)
+        (let* ((s (format "~a~a " (padr name 19) (padl total 3)))
+               (s (if (< 0 (prim-checks-def 0))
+                      (format "~a (~a prim)" s (prim-checks-def 0))
+                      s))
+               (s (if (< 0 (lam-checks-def 0))
+                      (format "~a (~a lambda)" s (lam-checks-def 0))
+                      s))
+               (s (if (< 0 (ap-checks-def 0))
+                      (format "~a (~a ap)" s (ap-checks-def 0))
+                      s))
+               (s (if (< 0 (type-assert-failed-def 0))
+                      (format "~a (~a type assertions)" 
+                              s (type-assert-failed-def 0))
+                      s)))
+          (mrspidey:add-summary s src 0))))))
+
+;; --------------------
+
+(define make-check-summary
+  (lambda (hdr)
+    (let* ([f (lambda (s) (mrspidey:add-summary s))]
+           [total-possible 
+            (+ (user-apps 0) (prim-count 0) (lam-count 0)
+               (type-assert-count 0))]
+           [percentage
+            (if (= 0 total-possible)
+                0
+                (string->number
+                 (chop-number
+                  (exact->inexact (* (/ (total-checks 0)
+                                        total-possible) 100))
+                  4)))])
+      
+      (f (format "~a~a~a~a" 
+                 hdr
+                 (padr "TOTAL CHECKS:" 19)
+                 (padl (total-checks 0) 3)
+                 (format "  (of ~s possible checks is ~s%)"
+                         total-possible percentage)))
+      
+      (unless (zero? (type-assert-failed-total 0))
+        (f (format "~a~a~a~a" 
+                   hdr
+                   (padr "FAILED ASSERTIONS:" 19)
+                   (padl (type-assert-failed-total 0) 3)
+                   (format "  (of ~s total type assertions)" 
+                           (type-assert-count 0)))))
+      
+      )))
+
+;;----------------------------------------------------------------------
+
+(define (calc-type-annotations defs)
+  (let* ( [type-annotations '()]
+          [locs-done-table-size 2048]
+          [locs-done-mask 2047]
+          [loc->ndx (lambda (loc)
+                      (bitwise-and (zodiac:location-offset loc)
+                        locs-done-mask))]
+          [locs-done-table (make-vector locs-done-table-size '())]
+          [fn 
+            (lambda (exp cl-fn)
+              (match exp
+                [($ zodiac:parsed origin start finish)
+                  (let* ([ftype (zodiac:parsed-ftype exp)]
+                          [end-first (zodiac:determine-end-first-token exp)])
+
+                    (pretty-debug 
+                      `(ftype ,(and (FlowType? ftype) (FlowType-name ftype))
+                         start ,(zodiac:location-offset start)))
+
+                    (when 
+                      (and
+                        (FlowType? ftype)
+                        ;;(memq (zodiac:origin-who origin) '(source reader))
+                        )
+
+                      ;; Don't add type-annotation if something else has this
+                      ;; start location
+                      (let ([ndx (loc->ndx start)])
+                        (when (not (find
+                                     (lambda (l) 
+                                       (= (zodiac:location-offset l)
+                                         (zodiac:location-offset start)))
+                                     (vector-ref locs-done-table ndx)))
+                          ;; Check FlowType points to exp
+                          (assert (or (eq? (FlowType-expr ftype) exp)
+                                    (eq? (FlowType-expr ftype) #t))
+                            'calc-type-annotation ftype
+                            (FlowType-expr ftype) exp)
+                          '(set-FlowType-expr! ftype exp)
+                          (set! type-annotations 
+                            (cons 
+                              (make-type-annotation 
+                                start end-first finish ftype) 
+                              type-annotations))
+                          (vector-set! 
+                            locs-done-table ndx
+                            (cons start (vector-ref locs-done-table ndx)))))))
+                  #f]
+                [_ #f]))])
+
+    (map-with-n
+     (lambda (exp n)
+       (begin
+         (mrspidey:zprogress "Typing" (zodiac:zodiac-start exp))
+         ((zodiac:compat fn) exp)))
+     defs)
+    (unless (null? defs)
+      (mrspidey:zprogress "Typing" (zodiac:zodiac-finish (rac defs))))
+
+    type-annotations))
+
+;; ----------------------------------------------------------------------
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

collects/mrspidey/Sba/config.ss

@@ -0,0 +1,312 @@
+;; config.ss
+;; Lots of parameters for analysis
+; ----------------------------------------------------------------------
+; Copyright (C) 1995-97 Cormac Flanagan
+;
+; This program is free software; you can redistribute it and/or
+; modify it under the terms of the GNU General Public License
+; version 2 as published by the Free Software Foundation.
+; 
+; This program is distributed in the hope that it will be useful,
+; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+; GNU General Public License for more details.
+; 
+; You should have received a copy of the GNU General Public License
+; along with this program; if not, write to the Free Software
+; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
+; ----------------------------------------------------------------------
+
+(define st:restricted 
+  (not (string? (current-load-relative-directory))))
+(define st:name    "MrSpidey")
+(define st:version (lambda () "49s1"))
+
+;; ----------------------------------------------------------------------
+;; Front end parameters
+
+(define st:fake-reader      (make-parameter-boolean #f))
+(define st:system-expand    (make-parameter-boolean #f))
+
+;; ----------------------------------------------------------------------
+;; Analysis parameters
+
+(define st:constants        (make-parameter-boolean #f))
+(define st:const-merge-size (make-parameter-integer 7))
+
+(define st:if-split       (make-parameter-boolean #t))
+; If #t, then knowledgeable about if's
+
+(define st:flow-sensitive (make-parameter-boolean #t))
+; If #t, then in (begin (car x) (cdr x)), cdr is never checked
+
+(define st:fo-units         (make-parameter-boolean #t))
+;; If #t, then first-order units treated specially
+
+(define st:lazy-fo-units         (make-parameter-boolean #t))
+;; If #t, then first-order units treated specially
+
+(define st:cache-units      (make-parameter-boolean #t))
+;; If #t, then first-order units treated specially
+
+(define st:whole-program    (make-parameter-boolean #t))
+
+(define st:special-fo-prims (make-parameter-boolean #t))
+(define st:see-void         (make-parameter-boolean #t))
+(define st:cons-mutable     (make-parameter-boolean #t))
+(define st:use-fo-ftype     (make-parameter-boolean #t))
+
+(define need-label-types #t)
+(define need-explanation #t)
+
+(define st:zero-old-constraint-sets (make-parameter-boolean #t))
+(define st:zero-old-asts            (make-parameter-boolean #t))
+
+;; ----------------------------------------------------------------------
+;; Simplification parameters
+
+(define constraint-simplification-list
+  (if st:restricted
+    '( 
+       (none            "No simplification")
+       (nonempty        "Remove empty constraints")
+       (live            "Remove empty and unreachable constraints")
+       (live-few-e      "As above, and also remove epsilon constraints")
+       ((live-few-e dfa-min-glb dfa-min-lub) 
+         "Live, few epsilon, DFA min")
+       )
+    '( 
+       (none            "No simplification")
+       (nonempty        "Remove empty constraints")
+       (nonempty-copy   "Copy nonempty")
+       (live            "Remove empty and unreachable constraints")
+       (live-few-e-L    "Live, few lower epsilon")
+       (live-few-e-U    "Live, few upper epsilon")
+       (live-few-e      "Live, few epsilon")
+       ((live-few-e dfa-min-lub)
+         "Live, few epsilon, DFA min LUB")
+       ((live-few-e dfa-min-glb)
+         "Live, few epsilon, DFA min GLB")
+       ((live-few-e  dfa-min-lub dfa-min-glb) 
+         "Live, few epsilon, DFA min")
+       )))
+
+(define make-constraint-simplification-para
+  (case-lambda
+    [() (make-constraint-simplification-para 'live-few-e)]
+    [(default)
+      (make-parameter-list
+        default
+        constraint-simplification-list
+        (lambda (_) (void))
+        ;; also-ok?
+        (lambda (x)
+          (and (list? x)
+            (andmap 
+              (lambda (y) (member y (map car constraint-simplification-list)))
+              x))))]))
+
+(define st:minimize-respect-assignable-part-of-fields 
+  (make-parameter-boolean #t))
+
+;; ----------------------------------------------------------------------
+;; Polymorphism parameters
+
+(define st:constraint-simplification-poly (make-constraint-simplification-para))
+
+(define st:polymorphism
+  (make-parameter-list 'compress
+                       `((none      "No polymorphism")
+                         (compress  "Simplify constraints")
+                         ;;(copy-con  "") 
+                         (reanalyze "Reanalyze")
+                         )))
+
+;; ----------------------------------------------------------------------
+;; Unit parameters 
+
+(define st:unit-read-za            (make-parameter-boolean #t))
+(define st:unit-write-za           (make-parameter-boolean #t))
+(define st:unit-simplify           
+  (make-constraint-simplification-para 'live-few-e))
+(define st:unit-separate-S         (make-parameter-boolean #t))
+(define st:save-za-in
+  (make-parameter-list
+    'source-directory
+    `( (source-directory "Source file directory" "")
+       (tmp-directory    
+         ,(string-append 
+            (if (defined? 'wx:find-path)
+              (wx:find-path 'temp-dir) " directory"))
+         ""))))
+
+;; ----------------------------------------------------------------------
+;; Type Viewing parameters 
+
+;; --- copying
+
+(define st:sdl-fo
+  (make-parameter-list
+    'basic-types
+    '( (basic-types  "Basic Types"     "ie (1 -> 1)")
+       (type-schemas   "Type Schemas"  "ie (X1 -> X1)"))))
+
+(define st:sdl-fo-ivars (make-parameter-boolean #t))
+(define st:sdl-fo-struct-fields (make-parameter-boolean #t))
+(define st:sdl-fo-depth-limit? (make-parameter-boolean #t))
+(define st:sdl-fo-depth-limit (make-parameter-integer 50))
+(define st:sdl-fo-size-limit? (make-parameter-boolean #t))
+(define st:sdl-fo-size-limit (make-parameter-integer 50))
+
+;; --- simplification
+
+(define st:sdl-constraint-simplification 
+  (make-constraint-simplification-para 'live-few-e))
+
+(define st:show-assignable-part-of-fields 
+  (make-parameter-boolean #f))
+
+;; --- to SDL
+
+(define st:listify-etc (make-parameter-boolean #t))
+
+(define st:sdl-constructor/selector
+  (make-parameter-list 
+    'constructor
+    '((constructor "Show types as constructors" "")
+      (selector    "Show types as selectors"    ""))))
+
+(define st:naming-strategy 
+  (make-parameter-list
+   'multiple
+   (if st:restricted
+       '((recursive "Recursive" "Name types on cycles")
+         (multiple  "Multiple"  "Name types referenced more than once")
+         (nontrivial  "Non-Trivial"  "Name non-trivial types")
+         (all       "All"       "Name all types"))
+       '((recursive "Recursive" "Name types on cycles")
+         (multiple  "Multiple"  "Name types referenced more than once")
+         (nontrivial  "Non-Trivial"  "Name non-trivial types")
+         (all       "All"       "Name all types")))))
+
+(define st:primitive-types 
+  (make-parameter-list
+   'inferred
+   '((prim      "(prim ...)"     "ie (prim car)")
+     (given     "Given types"    "ie ((cons a b) -> a)")
+     (inferred  "Inferred types" "ie ((cons 'a-symbol 4) -> 'a-symbol)"))))
+
+;; --- simplifying SDL
+
+(define st:expand-output-type (make-parameter-boolean #t))
+(define st:sdl-tidy (make-parameter-boolean #t))
+
+;; ---
+
+(define st:pretty-type-width (make-parameter-integer 60))
+
+;; ----------------------------------------------------------------------
+
+(define st:check-kernel (make-parameter-boolean #f))
+(define st:compare-min-algs (make-parameter-boolean #f))
+
+;; ----------------------------------------------------------------------
+;; Checking parameters
+
+(define st:all-checks     (make-parameter-boolean #f))
+
+;; ----------------------------------------------------------------------
+;; control - interface to all parameters
+
+(define mrspidey:control-fn
+  (let ([paras 
+          (begin-elaboration-time
+            (cons 'list
+              (map 
+                (lambda (x) (list 'cons (list 'quote x) x))
+                '(;; --- Analysis time
+                   st:constants 
+                   st:const-merge-size
+                   st:fo-units
+                   st:if-split 
+                   st:flow-sensitive 
+                   st:special-fo-prims
+                   st:system-expand
+                   st:see-void
+                   st:unit-read-za
+                   st:unit-write-za
+                   st:save-za-in
+                   ;; --- Polymorphism
+                   st:polymorphism
+                   st:constraint-simplification-poly
+                   ;;st:library-prims
+                   ;;st:topo-sort
+                   ;; --- Seperate analysis
+                   st:unit-simplify
+                   ;; --- Type viewing
+                   st:sdl-fo
+                   st:sdl-fo-ivars 
+                   st:sdl-fo-struct-fields
+                   st:sdl-fo-depth-limit? 
+                   st:sdl-fo-depth-limit
+                   st:sdl-fo-size-limit?
+                   st:sdl-fo-size-limit
+                   st:sdl-constraint-simplification
+                   st:show-assignable-part-of-fields
+                   st:listify-etc
+                   st:sdl-constructor/selector
+                   st:naming-strategy
+                   st:primitive-types
+                   st:expand-output-type
+                   st:sdl-tidy
+                   st:pretty-type-width
+
+                   ;; --- checking parameters
+                   st:all-checks 
+                   ))))])
+    (match-lambda*
+     [()
+      ;; Return list of all settings
+       (map
+         (match-lambda [(sym . para) (list sym (para))])
+         paras)
+       ]
+     [(para-name)
+      ;; Return one setting
+       (match (assq para-name paras)
+         [(_ . para) (para)]
+         [#f (error 'mrspidey:control "Unknown parameter ~s" para-name)])]
+     [(para-name nu-val)
+       ;; Return one setting
+       (match (assq para-name paras)
+         [(_ . para)
+           (if (memq nu-val (map car (para '?)))
+             (para nu-val)
+             (error 'mrspidey:control "Value ~s invalid for parameter ~s" 
+               nu-val para-name))]
+         [#f
+           (error 'mrspidey:control "Unknown parameter ~s" para-name)])]
+     [_ (error 'mrspidey:control "Bad # arguments")])))
+     
+;======================================================================
+ 
+(when st:restricted
+  ;; . special configuration, if necy
+  (void)
+  )
+
+ 
+
+
+
+
+
+
+
+
+
+
+
+
+
+

collects/mrspidey/Sba/contain.ss

@@ -0,0 +1,155 @@
+;; contained.ss
+;;
+;; Check if one Tvar is contained in another
+;; Doesn't work for contravariant fields
+;; Not currently used
+; ----------------------------------------------------------------------
+; Copyright (C) 1995-97 Cormac Flanagan
+;
+; This program is free software; you can redistribute it and/or
+; modify it under the terms of the GNU General Public License
+; version 2 as published by the Free Software Foundation.
+; 
+; This program is distributed in the hope that it will be useful,
+; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+; GNU General Public License for more details.
+; 
+; You should have received a copy of the GNU General Public License
+; along with this program; if not, write to the Free Software
+; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
+; ----------------------------------------------------------------------
+
+;; ----------------------------------------------------------------------
+;; NOTE: Tvar2 must be tidy!!!
+
+(define stack '())
+(define fail-stack '())
+
+(define Tvar-containment?
+  (lambda (tvar1 tvar2)
+    (let*-vals 
+      ( [calc-reached
+          (lambda (tvar)
+            (let*-vals 
+              ([(reached? set-reached! get-reached) 
+                 (field->set alloc-Tvar-field)])
+              (recur traverse ([tvar tvar])
+                (unless (reached? tvar)
+                  (set-reached! tvar)
+                  (for-each
+                    (match-lambda
+                      [($ AV _ ($ template _ _ _ ref) _ fields+ field-)
+                        (vector-for-each traverse fields+)])
+                    (get-Tvar-objs tvar))))
+              (get-reached)))]
+        [list-reached-1 (calc-reached tvar1)]
+        [list-reached-2 (calc-reached tvar2)]
+        [num-reached-1 (length list-reached-1)]
+        [(get-num set-num!) (alloc-Tvar-field)]
+        [(get-reached-vec set-reached-vec!) (alloc-Tvar-field)]
+        )
+
+        (for-each-with-n (lambda (tvar n) (set-num! tvar n))
+          list-reached-1)
+
+      (for-each
+        (lambda (tvar) (set-reached-vec! tvar (make-vector num-reached-1 #f)))
+        list-reached-2)
+
+      ;; Tidyness check
+      '(for-each
+        (lambda (tvar) 
+          (let* ([objs (get-Tvar-objs tvar)]
+                 [templates (map AV-template objs)]
+                 [types (map template-type templates)]
+                 [types2 (list->set types)])
+            (unless (= (length types) (length types2))
+              (mrspidey:error
+               (format "Upper bound of containment is not tidy, types are ~s"
+                       types)))))
+        list-reached-2)       
+
+      (begin0
+       (let/cc 
+        fail
+
+        (recur ensure-contained ([tvar1 tvar1][tvar2 tvar2])
+          (fluid-let ([stack (cons (cons tvar1 tvar2) stack)])
+            (let ([n (get-num tvar1)]
+                  [reached (get-reached-vec tvar2)])
+              (unless (vector-ref reached n)
+                ;; Need to search - record true to detect loops
+                (vector-set! reached n #t)
+                (for-each
+                 (match-lambda
+                  [($ AV _ (and template ($ template _ _ ref)) _ fields+)
+                   (or 
+
+                    ;; More than one matching => not tidy => say contained.
+                    (> (count (match-lambda
+                               [($ AV _ template2)
+                                (eq? (template-type template)
+                                     (template-type template2))])
+                              (get-Tvar-objs tvar2))
+                       1)
+
+                    (ormap
+                      (match-lambda
+                        [($ AV _ template2 _ fields2+)
+                          (and          ;(eq? template template2)
+                            (or
+                              (eq? 
+                                (template-type template)
+                                (template-type template2))
+                              (memq
+                                template2 
+                                (template-super-templates template)))
+                            (begin
+                              (for i 0 
+                                (min
+                                  (vector-length fields+)
+                                  (vector-length fields2+))
+                                (ensure-contained 
+                                  (vector-ref fields+ i)
+                                  (vector-ref fields2+ i)))
+                                #t))])
+                      (get-Tvar-objs tvar2))
+
+                    ;; No match
+                    (begin
+                      '(printf
+                         "~s ~s not in ~s ~s~n"
+                         (map (lambda (AV) (template-type (AV-template AV)))
+                           (get-Tvar-objs tvar1))
+                         (Tvar-name tvar1)
+                         (map (lambda (AV) (template-type (AV-template AV)))
+                           (get-Tvar-objs tvar2))
+                         (Tvar-name tvar2))
+                      (set! fail-stack stack)
+                      (fail #f)))])
+                 (get-Tvar-objs tvar1))))))
+
+        ;; Did not fail => succeed
+        #t)
+
+        ))))
+
+'(define (show-fail-stack-sdl)
+   (map
+    (match-lambda
+     [(a . d)
+      (list (Tvar->SDL a)
+            (Tvar->SDL d))])
+    fail-stack))
+
+'(define (show-fail-stack)
+   (for-each
+    (match-lambda
+     [(a . d)
+      (printf "============~n")
+      (show-Tvar a)
+      (show-Tvar d)])
+    fail-stack))
+
+

collects/mrspidey/Sba/contained.ss

@@ -0,0 +1,129 @@
+;; contained.ss
+;;
+;; Check if one Tvar is contained in another
+;; Doesn't work for contravariant fields
+;; ----------------------------------------------------------------------
+;; NOTE: Tvar2 must be tidy!!!
+
+(define stack '())
+(define fail-stack '())
+
+(define Tvar-containment?
+  (lambda (tvar1 tvar2)
+    (let*-vals 
+      ( [calc-reached
+          (lambda (tvar)
+            (let*-vals 
+              ([(reached? set-reached! get-reached) 
+                 (field->set alloc-Tvar-field)])
+              (recur traverse ([tvar tvar])
+                (unless (reached? tvar)
+                  (set-reached! tvar)
+                  (for-each
+                    (match-lambda
+                      [($ AV _ ($ template _ _ ref) _ fields)
+                        (for i 0 (vector-length ref)
+                          (traverse 
+                            (vector-ref fields (vector-ref ref i))))])
+                    (get-Tvar-objs tvar))))
+              (get-reached)))]
+        [list-reached-1 (calc-reached tvar1)]
+        [list-reached-2 (calc-reached tvar2)]
+        [num-reached-1 (length list-reached-1)]
+        [(get-num set-num!) (alloc-Tvar-field)]
+        [(get-reached-vec set-reached-vec!) (alloc-Tvar-field)]
+        )
+
+        (for-each-with-n (lambda (tvar n) (set-num! tvar n))
+          list-reached-1)
+
+      (for-each
+        (lambda (tvar) (set-reached-vec! tvar (make-vector num-reached-1 #f)))
+        list-reached-2)
+
+      ;; Tidyness check
+      '(for-each
+        (lambda (tvar) 
+          (let* ([objs (get-Tvar-objs tvar)]
+                 [templates (map AV-template objs)]
+                 [types (map template-type templates)]
+                 [types2 (list->set types)])
+            (unless (= (length types) (length types2))
+              (mrspidey:error
+               (format "Upper bound of containment is not tidy, types are ~s"
+                       types)))))
+        list-reached-2)       
+
+      (begin0
+       (let/cc 
+        fail
+
+        (recur ensure-contained ([tvar1 tvar1][tvar2 tvar2])
+          (fluid-let ([stack (cons (cons tvar1 tvar2) stack)])
+            (let ([n (get-num tvar1)]
+                  [reached (get-reached-vec tvar2)])
+              (unless (vector-ref reached n)
+                ;; Need to search - record true to detect loops
+                (vector-set! reached n #t)
+                (for-each
+                 (match-lambda
+                  [($ AV _ (and template ($ template _ _ ref)) _ fields)
+                   (or 
+
+                    ;; More than one matching => not tidy => say contained.
+                    (> (count (match-lambda
+                               [($ AV _ template2 _ fields2)
+                                (eq? (template-type template)
+                                     (template-type template2))])
+                              (get-Tvar-objs tvar2))
+                       1)
+
+                    (ormap
+                     (match-lambda
+                      [($ AV _ template2 _ fields2)
+                       (and             ;(eq? template template2)
+                        (eq? (template-type template)
+                             (template-type template2))
+                        (begin
+                          (for i 0 (vector-length ref)
+                               (let ([r (vector-ref ref i)])
+                                 (ensure-contained
+                                  (vector-ref fields r)
+                                  (vector-ref fields2 r))))
+                          #t))])
+                     (get-Tvar-objs tvar2))
+                    ;; No match
+                    (begin
+                      (printf
+                       "~s ~s not in ~s ~s~n"
+                       (map (lambda (AV) (template-type (AV-template AV)))
+                            (get-Tvar-objs tvar1))
+                       (Tvar-name tvar1)
+                       (map (lambda (AV) (template-type (AV-template AV)))
+                            (get-Tvar-objs tvar2))
+                       (Tvar-name tvar2))
+                      (set! fail-stack stack)
+                      (fail #f)))])
+                 (get-Tvar-objs tvar1))))))
+
+        ;; Did not fail => succeed
+        #t)
+
+        ))))
+
+'(define (show-fail-stack-sdl)
+   (map
+    (match-lambda
+     [(a . d)
+      (list (Tvar->SDL a)
+            (Tvar->SDL d))])
+    fail-stack))
+
+'(define (show-fail-stack)
+   (for-each
+    (match-lambda
+     [(a . d)
+      (printf "============~n")
+      (show-Tvar a)
+      (show-Tvar d)])
+    fail-stack))

collects/mrspidey/Sba/debug.ss

@@ -0,0 +1,37 @@
+;; debugging.ss
+
+(define debugging #f)
+(define debugging-front #f)
+(define debugging-traverse #f)
+(define debugging-object #f)
+(define debugging-unit #f)
+(define debugging-check #f)
+(define debugging-atenv #f)
+(define debugging-atype #f)
+(define debugging-sdl #f)
+(define debugging-sdl2 #f)
+(define debugging-gui #t)
+
+(define debugging-min #f)
+(define debugging-min2 #f)
+(define debugging-few #f)
+(define debugging-gram #f)
+(define debugging-dfa-min #f)
+(define debugging-min-table #f)
+
+(define timing-min #f)
+
+(define pretty-print-debug pretty-print)
+
+(define (set-debug-flag which val)
+  (case which
+    [(general)  (set! debugging val)]
+    [(min)      (set! debugging-min val)]
+    [(front)    (set! debugging-front val)]
+    [(traverse) (set! debugging-traverse val)]))
+
+;(set! debugging #t)
+;(set! debugging-min #t)
+;(set! debugging-gram #t)
+;(set! debugging-min-table #t)
+;(set! timing-min #t)

collects/mrspidey/Sba/driver.ss

@@ -0,0 +1,93 @@
+;; driver.ss - driver file for text version
+; ----------------------------------------------------------------------
+; Copyright (C) 1995-97 Cormac Flanagan
+;
+; This program is free software; you can redistribute it and/or
+; modify it under the terms of the GNU General Public License
+; version 2 as published by the Free Software Foundation.
+; 
+; This program is distributed in the hope that it will be useful,
+; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+; GNU General Public License for more details.
+; 
+; You should have received a copy of the GNU General Public License
+; along with this program; if not, write to the Free Software
+; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
+; ----------------------------------------------------------------------
+
+;; ----------------------------------------------------------------------
+
+'(define st:defconstructor add-default-constructor!)
+'(define st:defprim add-default-primitive!)
+'(define st:type-alias default-constructor-alias!)
+'(define (st:deftype name nutype) 
+   (install-input-type-expander!
+    (lambda (type)
+      (if (eq? type name) nutype type))))
+
+(define st:set-debug set-debug-flag)
+
+; ----------------------------------------------------------------------
+
+(define st:analyze
+  (lambda (file)
+    (analyze-program file)
+    (void)))
+
+(define st:
+  (lambda (file)
+    (let ([defs (analyze-program file)])
+      (calc-checks defs)
+      (void))))
+
+
+; ----------------------------------------------------------------------
+
+(define (st:type-fn . args)
+  ;;(when (null? defs-bind)
+  ;;  (error 'st:type "Checking not done yet, use st:"))
+  (let* ([show
+           (lambda (name)
+             (list (zodiac:binding-var name)
+               ':
+               (FlowType->SDL (atenv:lookup global-def-env name))))]
+          [show*
+            (lambda (b*)
+              (map show b*)
+              ;;(for-each (lambda (b) (pretty-print (show b))) b*)
+              )])
+
+    (if (null? args)
+      ;; Show all
+      (show* (atenv:domain global-def-env))
+      ;; Show selectively
+      (show*
+        (filter
+          (lambda (name) (memq (zodiac:binding-var name) args))
+          (atenv:domain global-def-env))))))
+
+;; ----------------------------------------------------------------------
+
+(define st:help
+  (lambda ()
+    ;(printf "Commands for SBA Soft Scheme Version ~a~%" st:version)
+    (printf "  (st:analyze file)          analyze file~n")
+    (printf "  (st:check file)                 type check file~%")
+;    (printf "  (st:write file [output])       type check file and write it~%")
+    (printf "  (st:type [definition ...])     show type of top level defs~n")
+;    (printf "  (st:ltype var)                 show type of internal vars~n")
+;    (printf "  (st:why N)                     prints cause of check N~n")
+    (printf "  (st:control [param [value]])   show or change parameters~n")
+    (printf "  (st:help)                      prints this message~%")))
+
+; ----------------------------------------------------------------------
+;  (st:check    file (output))    type check file
+;  (st:bench    file)             execute type checked file fast
+;  (st:run      file)             execute type checked file
+; ----------------------------------------------------------------------
+
+(st:language 'DrScheme)
+;(st:language 'MrEd)
+
+;(printf "DrScheme selected~n")

collects/mrspidey/Sba/exn-hierarchy.ss

@@ -0,0 +1,105 @@
+(define-struct exn (message debug-info))
+(define-struct (exn:user struct:exn) ())
+(define-struct (exn:syntax struct:exn) (expr))
+(define-struct (exn:variable struct:exn) (id))
+(define-struct (exn:application struct:exn) (value))
+(define-struct (exn:application:non-procedure struct:exn:application) ())
+(define-struct (exn:application:arity struct:exn:application) (expected))
+(define-struct (exn:application:type struct:exn:application) (expected))
+(define-struct (exn:application:range struct:exn:application) ())
+(define-struct (exn:application:range:bounds struct:exn:application:range) (min max))
+(define-struct (exn:application:range:bounds:vector struct:exn:application:range:bounds) ())
+(define-struct (exn:application:range:bounds:string struct:exn:application:range:bounds) ())
+(define-struct (exn:application:range:bounds:struct struct:exn:application:range:bounds) ())
+(define-struct (exn:application:range:list struct:exn:application:range) ())
+(define-struct (exn:application:list-sizes struct:exn:application) ())
+(define-struct (exn:application:map-arity struct:exn:application) (provided))
+(define-struct (exn:application:integer struct:exn:application) ())
+(define-struct (exn:application:list struct:exn:application) ())
+(define-struct (exn:application:math struct:exn:application) ())
+(define-struct (exn:application:math:zero struct:exn:application:math) ())
+(define-struct (exn:application:math:infinity struct:exn:application:math) ())
+(define-struct (exn:application:math:negative struct:exn:application:math) ())
+(define-struct (exn:application:math:radix struct:exn:application:math) ())
+(define-struct (exn:application:mode-conflict struct:exn:application) (filename))
+(define-struct (exn:application:file-position struct:exn:application) ())
+(define-struct (exn:application:fprintf struct:exn:application) ())
+(define-struct (exn:application:fprintf:extra-arguments struct:exn:application:fprintf) (extras))
+(define-struct (exn:application:fprintf:no-argument struct:exn:application:fprintf) ())
+(define-struct (exn:application:fprintf:argument-type struct:exn:application:fprintf) (expected))
+(define-struct (exn:else struct:exn) ())
+(define-struct (exn:struct struct:exn) ())
+(define-struct (exn:struct:struct-type struct:exn:struct) (value))
+(define-struct (exn:object struct:exn) ())
+(define-struct (exn:object:class-type struct:exn:object) (value))
+(define-struct (exn:object:interface-type struct:exn:object) (value))
+(define-struct (exn:object:generic struct:exn:object) (object))
+(define-struct (exn:object:inherit struct:exn:object) (ivar))
+(define-struct (exn:object:implement struct:exn:object) (ivar))
+(define-struct (exn:object:class-ivar struct:exn:object) (class ivar))
+(define-struct (exn:object:interface-ivar struct:exn:object) (interface ivar))
+(define-struct (exn:object:ivar struct:exn:object) (object ivar))
+(define-struct (exn:object:private-class struct:exn:object) (class))
+(define-struct (exn:object:init struct:exn:object) (object class))
+(define-struct (exn:object:init:multiple struct:exn:object:init) ())
+(define-struct (exn:object:init:never struct:exn:object:init) ())
+(define-struct (exn:unit struct:exn) ())
+(define-struct (exn:unit:non-unit struct:exn:unit) (value))
+(define-struct (exn:unit:arity struct:exn:unit) (unit))
+(define-struct (exn:unit:import struct:exn:unit) (in-unit out-unit in-tag out-tag name))
+(define-struct (exn:unit:export struct:exn:unit) (unit tag name))
+(define-struct (exn:unit:invoke struct:exn:unit) ())
+(define-struct (exn:unit:invoke:variable struct:exn:unit:invoke) (name))
+(define-struct (exn:unit:signature struct:exn:unit) ())
+(define-struct (exn:unit:signature:non-signed-unit struct:exn:unit:signature) (value))
+(define-struct (exn:unit:signature:arity struct:exn:unit:signature) (unit))
+(define-struct (exn:unit:signature:match struct:exn:unit:signature) (dest-context src-context variable))
+(define-struct (exn:unit:signature:match:missing struct:exn:unit:signature:match) ())
+(define-struct (exn:unit:signature:match:extra struct:exn:unit:signature:match) ())
+(define-struct (exn:unit:signature:match:kind struct:exn:unit:signature:match) ())
+(define-struct (exn:read struct:exn) (port))
+(define-struct (exn:read:paren struct:exn:read) ())
+(define-struct (exn:read:number struct:exn:read) (input))
+(define-struct (exn:read:char struct:exn:read) (input))
+(define-struct (exn:read:eof struct:exn:read) (expected))
+(define-struct (exn:read:dot struct:exn:read) ())
+(define-struct (exn:read:unsupported struct:exn:read) (input))
+(define-struct (exn:read:vector-length struct:exn:read) (input))
+(define-struct (exn:read:compiled struct:exn:read) ())
+(define-struct (exn:read:graph struct:exn:read) ())
+(define-struct (exn:i/o struct:exn) ())
+(define-struct (exn:i/o:read struct:exn:i/o) (port))
+(define-struct (exn:i/o:write struct:exn:i/o) (port))
+(define-struct (exn:i/o:filesystem struct:exn:i/o) (pathname))
+(define-struct (exn:i/o:filesystem:path struct:exn:i/o:filesystem) ())
+(define-struct (exn:i/o:filesystem:path:username struct:exn:i/o:filesystem:path) ())
+(define-struct (exn:i/o:filesystem:file struct:exn:i/o:filesystem) ())
+(define-struct (exn:i/o:filesystem:directory struct:exn:i/o:filesystem) ())
+(define-struct (exn:i/o:filesystem:collection struct:exn:i/o:filesystem) ())
+(define-struct (exn:i/o:filesystem:file-exists struct:exn:i/o:filesystem) ())
+(define-struct (exn:i/o:port-closed struct:exn:i/o) (port))
+(define-struct (exn:i/o:user-port struct:exn:i/o) (port))
+(define-struct (exn:i/o:tcp struct:exn:i/o) ())
+(define-struct (exn:i/o:tcp:connect struct:exn:i/o:tcp) (address port-id))
+(define-struct (exn:i/o:tcp:listen struct:exn:i/o:tcp) (port-id))
+(define-struct (exn:i/o:tcp:accept struct:exn:i/o:tcp) (listener))
+(define-struct (exn:i/o:tcp:listener-closed struct:exn:i/o:tcp) (listener))
+(define-struct (exn:misc struct:exn) ())
+(define-struct (exn:misc:unsupported struct:exn:misc) ())
+(define-struct (exn:misc:user-break struct:exn:misc) ())
+(define-struct (exn:misc:out-of-memory struct:exn:misc) ())
+(define-struct (exn:misc:parameterization struct:exn:misc) (value))
+(define-struct (exn:misc:defmacro struct:exn:misc) (value))
+(define-struct (exn:misc:expansion-time struct:exn:misc) ())
+(define-struct (exn:misc:constant struct:exn:misc) (id))
+(define-struct (exn:misc:continuation struct:exn:misc) ())
+(define-struct (exn:misc:thread struct:exn:misc) ())
+(define-struct (exn:misc:thread:kill struct:exn:misc:thread) ())
+(define-struct (exn:misc:semaphore struct:exn:misc) ())
+(define-struct (exn:misc:hash-table struct:exn:misc) (key))
+(define-struct (exn:misc:regexp struct:exn:misc) ())
+(define-struct (exn:misc:process struct:exn:misc) ())
+(define-struct (exn:misc:dynamic-extension struct:exn:misc) (name))
+(define-struct (exn:misc:dynamic-extension:open struct:exn:misc:dynamic-extension) ())
+(define-struct (exn:misc:dynamic-extension:version struct:exn:misc:dynamic-extension) ())
+(define-struct (exn:misc:dynamic-extension:initialize struct:exn:misc:dynamic-extension) ())

collects/mrspidey/Sba/expander-boot.ss

@@ -0,0 +1,105 @@
+;; expander-boot.ss
+; ----------------------------------------------------------------------
+; Copyright (C) 1995-97 Cormac Flanagan
+;
+; This program is free software; you can redistribute it and/or
+; modify it under the terms of the GNU General Public License
+; version 2 as published by the Free Software Foundation.
+; 
+; This program is distributed in the hope that it will be useful,
+; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+; GNU General Public License for more details.
+; 
+; You should have received a copy of the GNU General Public License
+; along with this program; if not, write to the Free Software
+; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
+; ----------------------------------------------------------------------
+(printf "Loading expander-boot.ss~n")
+
+(define __keep-mrspidey-annotations #t)
+(load "~cormac/scheme/mzschemerc.ss")
+(match:set-error-control 'error)
+
+(defmacro assert args '(void))
+(defmacro begin-test-case args  `(begin ,@args))
+;(defmacro type: args `(type:-quote (quote ,args)))
+(defmacro primitive: args `(type: ,@args))
+
+(defmacro include-exp (f) 
+  (let ([p (open-input-file f)])
+    (begin0 
+      (read p)
+      (close-input-port p))))
+
+;; ---------- structures --------------------------------------------------
+;; field = (: sym type) | (! sym type) | sym
+;; field-name = sym
+
+(define (struct-expander-fn struct: const?)
+  (#%let ([make-exn make-exn:syntax]
+          [debug debug-info-handler])
+  (#%lambda body
+     (#%let* ([syntax-error
+               (#%lambda (s)
+                         (#%raise
+                          (make-exn
+                           (#%format "define-struct: ~a" s)
+                           ((debug))
+                           (#%cons 'define-struct body))))]
+              [field->field-name
+               (match-lambda
+                [((or ': '!) sym _) sym]
+                [(? symbol? sym) sym]
+                [x (syntax-error (format "Bad field ~s" x))])]
+              [field-mutable?
+               (match-lambda
+                [('! sym _) #t]
+                [_ (not const?)])]
+              [build-struct-names
+               (#%lambda (name fields)
+                         (#%let ([name (#%symbol->string name)]
+                                 [+ #%string-append])
+                                (#%map #%string->symbol
+                                       (#%append
+                                        (#%list 
+                                         (+ "struct:" name)
+                                         (+ "make-" name)
+                                         (+ name "?"))
+                                        (#%apply
+                                         #%append
+                                         (#%map
+                                          (#%lambda (field) 
+                                                    (let ([f
+                                                           (symbol->string
+                                                            (field->field-name field))])
+                                                      (cons
+                                                       (+ name "-" f)
+                                                       (if (field-mutable? field)
+                                                           (list (+ "set-" name "-" f "!"))
+                                                           '()))))
+                                          fields))))))])
+	    (#%or (#%pair? body)
+		  (syntax-error "empty declaration"))
+	    (#%or (#%= 2 (#%length body))
+		  (syntax-error "wrong number of parts"))
+	    (#%or (#%symbol? (#%car body))
+		  (#%and (#%pair? (#%car body))
+			 (#%symbol? (#%caar body))
+			 (#%pair? (#%cdar body))
+			 (#%null? (#%cddar body)))
+		  (syntax-error "first part must be an identifier or identifier-expression pair"))
+	    (#%or (#%list? (#%cadr body))
+		  (syntax-error "improper field list"))
+	    (#%let* ([name (#%if (#%symbol? (#%car body))
+			      (#%car body)
+			      (#%caar body))]
+		  [fields (#%cadr body)])
+	      `(#%define-values ,(build-struct-names name fields)
+                                (,struct: ,@body)))))))
+
+;(#%define-macro define-const-typed-structure (struct-expander-fn '#%const-typed-structure #t))
+(#%define-macro define-const-typed-structure (struct-expander-fn '#%typed-structure #f))
+(#%define-macro define-typed-structure (struct-expander-fn '#%typed-structure #f))
+
+(printf "expander-boot.ss done~n")

collects/mrspidey/Sba/gram.ss

@@ -0,0 +1,322 @@
+;; gram.ss
+
+; ======================================================================
+
+(define debugging-gram #f)
+(defmacro pretty-debug-gram args `(when debugging-gram (pretty-print ,@args)))
+
+; ======================================================================
+; VIEWING CONSTRAINTS AS GRAMMARS
+; ======================================================================
+; Non-Terminals
+
+(define-structure (NT AVS type) 
+  ([rhs* '()][prop #f][tag #f][sources #f][num #f][edgefrom '()]))
+
+(define mk-AVS-NTs!
+  (lambda (AVS)
+    (set-AVS-L!  AVS (make-NT AVS 'L ))
+    (set-AVS-U!  AVS (make-NT AVS 'U ))
+    (set-AVS-LI! AVS (make-NT AVS 'LI))
+    (set-AVS-UI! AVS (make-NT AVS 'UI))))
+
+(define same-nt-type?
+  (match-lambda*
+   [(($ NT _ t1) ($ NT _ t2)) (eq? t1 t2)]))
+
+(define nt-chg-AVS
+  (match-lambda*
+   [(f ($ NT x type)) (make-NT (f x) type)]))
+
+(define drop-I
+  (match-lambda
+   [(and nt ($ NT AVS type _))
+    (case type
+      [(or 'L 'U) nt]
+      [LI (AVS-L AVS)]
+      [UI (AVS-U AVS)])]))
+
+(define invert-nt
+  (match-lambda
+   [($ NT AVS 'L)  (AVS-UI AVS)]
+   [($ NT AVS 'LI) (AVS-U  AVS)]
+   [($ NT AVS 'U)  (AVS-LI AVS)]
+   [($ NT AVS 'UI) (AVS-L  AVS)]))
+
+; ======================================================================
+; Right hand side of a production
+
+(define-structure (rhs* grsym misc nts))
+(define (make-rhs grsym nt) (make-rhs* grsym '() (list nt)))
+
+(define-structure (grsym ineq fn sign template field-no))
+;; ineq is '<= or '>=
+;; fn   is 'inj, 'inj-tst or 'ext
+;; sign is #t (monotonic) or #f (antimonotonic)
+;; field-no may be #f
+
+(define (make-grsym->=inj+     t f) (make-grsym '>= 'inj     #t t f))
+(define (make-grsym->=inj-     t f) (make-grsym '>= 'inj     #f t f))
+(define (make-grsym->=inj?     t f) (make-grsym '>= 'inj     '? t f))
+
+(define (make-grsym-<=inj-tst+ t f) (make-grsym '<= 'inj-tst #t t f))
+(define (make-grsym-<=inj-tst- t f) (make-grsym '<= 'inj-tst #f t f))
+
+(define (make-grsym-<=ext+     t f) (make-grsym '<= 'ext     #t t f))
+(define (make-grsym->=ext-     t f) (make-grsym '>= 'ext     #f t f))
+
+(define (make-grsym->=ext+     t f) (make-grsym '>= 'ext     #t t f))
+(define (make-grsym-<=ext-     t f) (make-grsym '<= 'ext     #f t f))
+
+;;(define (make-grsym-filter  filter) (make-grsym '<= 'filter #t filter #f))
+(define (make-grsym-filter  filter) (make-grsym '>= 'filter #t filter #f))
+(define grsym-crossover             '>=crossover)
+   
+;; a grsym can also be '>=epsilon or '<=epsilon
+
+(define grsym-eq?
+  (match-lambda*
+   [(($ grsym i1 f1 s1 t1 n1) ($ grsym i2 f2 s2 t2 n2))
+    (and (eq? i1 i2) (eq? f1 f2) (eq? t1 t2) (eqv? n1 n2))]
+   [(x y) (eq? x y)]))
+
+(define invert-grsym
+  (match-lambda
+   [($ grsym '>= 'inj sign template field-no)
+    (make-grsym '<= 'ext sign template field-no)]
+   [($ grsym '<= 'inj-tst sign template field-no)
+    (make-grsym '>= 'ext sign template field-no)]
+   [($ grsym '>= 'filter #t filter #f)
+    (make-grsym '<= 'unfilter #t filter #f)]
+   ['>=crossover '<=crossover]
+   [(and g ($ grsym))
+    (error 'invert-grsym "Bad grsym ~s" (grsym->rep g))]))
+
+(define grsym-epsilon-or-filter?
+  (match-lambda
+   [(? symbol?) #t]
+   [($ grsym _ 'filter) #t]
+   [_ #f]))
+
+; ======================================================================
+; Parameters for creating grammar
+
+(define-structure 
+  (parameters-grammar 
+   interp-sign                          ; applied to sign of each field
+   prims                                ; #t => treat prims as constants
+   filters                              ; #t => filters are not epsilon edges
+   assignable-fields                    ; #t => assignable fields in grammar
+   structure-opaque                     ; #t => structures are constants
+   ))
+
+; ======================================================================
+;; Prepare for creating grammar
+
+(define (prep-gram!)
+  (for-each mk-AVS-NTs! list-AVS))
+
+; ======================================================================
+;; Initializing the NT fields of an AVS
+
+(define (add-rhs! NT rhs)
+  (pretty-debug-gram
+    (match rhs
+      [($ rhs* grsym _ nts)
+       (assert (list? nts))
+       (list `(add-rhs! ,(nt->sym NT) ,(grsym->rep grsym) 
+                        ,(map nt->sym nts)))]))
+ (set-NT-rhs*! NT (cons rhs (NT-rhs* NT))))
+
+; ----------------------------------------------------------------------
+
+(define (for-each-calc-prods-L L paras fn)
+  (match L
+    [($ NT AVS 'L)
+     (for-each
+      (match-lambda
+       [($ AV _ (and template ($ template _ signs _ _ _ _ structure?))
+           misc fields)
+        (if (or (zero? (vector-length fields))
+                (and structure?
+                     (parameters-grammar-structure-opaque paras)))
+            (fn (make-rhs* (make-grsym '>= 'inj #t template '?) misc '()))
+            (for i 0 (vector-length fields)
+                 (let ([field (vector-ref fields i)]
+                       [interp-sign (parameters-grammar-interp-sign paras)]
+                       [sign (interp-sign (vector-ref signs i))])
+                   (fn (make-rhs*
+                        (make-grsym '>= 'inj (eq? sign '>=inj+) template i)
+                        misc
+                        (case sign
+                          [>=inj+ (list (AVS-L field))]
+                          [>=inj-
+                           (if (or #f ;; mk-assignable-part-fields?
+                                   (eq? template template-lam))
+                               (map AVS-U (AVS-transitive-edgeto field))
+                               '())]))))))])
+      (get-AVS-objs AVS))]))
+
+; ----------------------------------------------------------------------
+
+(define (for-each-calc-prods-U U paras fn)
+  (match U
+    [($ NT AVS 'U)
+     (let ([interp-sign (parameters-grammar-interp-sign paras)])
+       (for-each
+        (match-lambda
+         [($ con _ (and template ($ template type signs)) field-no AVS2 misc)
+          (case (interpret-sign (vector-ref signs field-no))
+            [>=inj+
+             (fn (make-rhs*
+                  (make-grsym-<=inj-tst+ template field-no)
+                  misc
+                  (list (AVS-U AVS2))))]
+            [>=inj-
+             (fn (make-rhs*
+                  (make-grsym-<=inj-tst- template field-no)
+                  misc
+                  (list (AVS-U AVS2))))])]
+         [($ con-filter _ the-filter AVS2)
+          (fn (make-rhs*
+               (make-grsym-filter the-filter)
+               '()
+               (list (AVS-U AVS2))))])
+        (AVS-constraints AVS)))
+     (for-each
+      (lambda (AVS2) (fn (make-rhs* '<=epsilon '() (list (AVS-U AVS2)))))
+      (AVS-transitive-edgeto AVS))]))
+
+; ----------------------------------------------------------------------
+
+(define (for-each-calc-prods nt paras fn)
+  (match nt
+    [($ NT AVS 'L) (for-each-calc-prods-L nt paras fn)]
+    [($ NT AVS 'U) (for-each-calc-prods-U nt paras fn)]))
+
+; ======================================================================
+
+
+
+
+
+
+(define (calc-productions! 
+         live-nts live-nt?
+         mk-L? mk-U? mk-LI? mk-UI?
+         L->LI
+         mk-assignable-part-fields?
+         treat-all-mono)
+
+  ;; live-AVS, crossover-AVS, live-nt and live-nt? 
+  ;;    all come from calc-live-AVS-nt
+  ;; mk-...     : bool -- controls which NTs to produce
+  ;; L->LI, ... : bool -- controls L->LI production rule
+
+  (let ([interpret-sign
+         (if treat-all-mono
+             (lambda (x) '>=inj+)
+             (lambda (x) x))])
+
+    (for-each (lambda (nt) (set-NT-rhs*! nt '()))
+              live-nts)
+
+    ;; ------ Now fill NTs from AV, constraints and edges
+
+    (for-each
+     (lambda (AVS)
+       (pretty-debug-gram `(Prods for AVS ,(name-for-AVS AVS)))
+
+       ;; ------ Invert AV
+       (when (and mk-L? (live-nt? (AVS-L AVS)))
+         (AVs->prods AVS interpret-sign live-nt?))
+
+       ;; ------ Invert constraints
+       (when (and mk-U? (live-nt? (AVS-U AVS)))
+         (for-each
+          (match-lambda
+           [($ con _ (and template ($ template type signs)) field-no AVS2 misc)
+            (case (interpret-sign (vector-ref signs field-no))
+              [>=inj+
+               (add-rhs! (AVS-U AVS)
+                         (make-rhs*
+                          (make-grsym-<=inj-tst+ template field-no)
+                          misc
+                          (filter live-nt? 
+                                  (map AVS-U (AVS-transitive-edgeto AVS2)))))]
+              [>=inj-
+               (add-rhs! (AVS-U AVS)
+                         (make-rhs*
+                          (make-grsym-<=inj-tst- template field-no)
+                          misc
+                          (filter live-nt? (list (AVS-L AVS2)))))])]
+           [($ con-filter _ the-filter AVS2)
+            (add-rhs! (AVS-U AVS)
+                      (make-rhs*
+                       (make-grsym-filter the-filter)
+                       '()
+                       (filter live-nt? 
+                               (map AVS-U (AVS-transitive-edgeto AVS2)))))
+            '(for-each
+              (lambda (to)
+                (when (live-nt? (AVS-L to))
+                  (add-rhs! (AVS-L to)
+                            (make-rhs*
+                             (make-grsym-filter the-filter)
+                             '()
+                             (list (AVS-L AVS))))))
+              (AVS-transitive-edgeto AVS2))
+            ])
+          (AVS-constraints AVS)))
+       )
+     live-AVS)
+
+    ;; ------ Add L->LI productions
+    (when L->LI
+      (for-each
+       (lambda (AVS)
+         (for-each 
+          (lambda (to)
+            (when (and (NT? (AVS-L to)) (live-nt? (AVS-L to)))
+              (add-rhs! (AVS-L to)
+                        (make-rhs* grsym-crossover '() (list (AVS-LI AVS))))))
+          (AVS-transitive-edgeto AVS)))
+       crossover-AVS))
+
+    ;; ------ convert L, U productions into LI, UI productions
+    (pretty-debug '(inverting productions))
+
+    (for-each
+     (lambda (nt)
+       (for-each
+        (match-lambda
+         [($ rhs* grsym misc to-nts)
+          (unless (eq? grsym '<=crossover)
+            (let* ([inv-grsym (invert-grsym grsym)]
+                   [inv-nt (invert-nt nt)]
+                   [inv-rhs (make-rhs* inv-grsym misc (list inv-nt))])
+              (for-each (lambda (to) (add-rhs! (invert-nt to) inv-rhs))
+                        to-nts)))])
+        (NT-rhs* nt)))
+     live-nts)
+
+    (let ([live-nts
+           (apply append
+                  (map
+                   (match-lambda
+                    [($ NT AVS 'L) (list (AVS-L AVS) (AVS-UI AVS))]
+                    [($ NT AVS 'U) (list (AVS-U AVS) (AVS-LI AVS))])
+                   live-nts))])
+
+      ;; Now group together all productions for given NT with given grsym
+      (for-each
+       (lambda (nt)
+         (let ([rhs* (NT-rhs* nt)])
+           (set-NT-rhs*! nt '())
+           (for-each (lambda (rhs) 
+                       (assert (list? (rhs*-nts rhs)))
+                       (add-rhs! nt rhs))
+                     (group-rhs* rhs*))))
+       live-nts)
+
+      (list live-nts))))

collects/mrspidey/Sba/hash.ss

@@ -0,0 +1,147 @@
+;; hash.ss
+; ----------------------------------------------------------------------
+; Copyright (C) 1995-97 Cormac Flanagan
+;
+; This program is free software; you can redistribute it and/or
+; modify it under the terms of the GNU General Public License
+; version 2 as published by the Free Software Foundation.
+; 
+; This program is distributed in the hope that it will be useful,
+; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+; GNU General Public License for more details.
+; 
+; You should have received a copy of the GNU General Public License
+; along with this program; if not, write to the Free Software
+; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
+; ----------------------------------------------------------------------
+
+(define-struct hash-table-state 
+  (hash-table-size entries-in-table
+    resize-table-size entry->hash-fn
+    hash-table))
+
+ ;;------------------------------------------------------------
+
+ (define prime1 83)
+ (define prime2 1789)
+ (define default-hash-table-size (* 32 1024)) 
+ (define resize-table-fraction 0.6)
+
+ ;;------------------------------------------------------------
+
+ (define hash-table-size   0)
+ (define entries-in-table  0)
+ (define resize-table-size 0)
+ (define entry->hash-fn    (void))
+ (define hash-table        (void))
+
+ ;;------------------------------------------------------------
+
+ (define (init-hash-table entry->hash size)
+   (set! hash-table-size (if (zero? size) default-hash-table-size size))
+   (set! entries-in-table 0)
+   (set! resize-table-size 
+       (inexact->exact 
+         (round (* hash-table-size resize-table-fraction))))
+   (set! entry->hash-fn entry->hash)
+   (set! hash-table (make-vector hash-table-size '())))
+
+ (define (capture-hash-table-state)
+   (make-hash-table-state hash-table-size entries-in-table
+                          resize-table-size entry->hash-fn
+                          hash-table))
+
+(define restore-hash-table-state!
+   (match-lambda
+    [($ hash-table-state t1 t2 t3 t4 t5)
+     (set! hash-table-size t1)
+     (set! entries-in-table t2)
+     (set! resize-table-size t3)
+     (set! entry->hash-fn t4)
+     (set! hash-table t5)]))
+
+(define free-hash-table-state!
+  (match-lambda
+    [($ hash-table-state t1 t2 t3 t4 t5)
+      (assert (not (eq? t5 hash-table)))
+      (vector-zero! t5)]))
+
+(define (prompt-hash-table-state)
+  (list (capture-hash-table-state)
+    (vector-length hash-table)
+    (recur loop ([i (sub1 (vector-length hash-table))])
+      (if (< i 0)
+        '()
+        (if (null? (vector-ref hash-table i))
+          (loop (sub1 i))
+          (cons (cons i (vector-ref hash-table i)) (loop (sub1 i))))))))
+
+(define unprompt-hash-table-state!
+  (match-lambda
+    [(state vec-size vec-entries)
+      (restore-hash-table-state! state)
+      (for i 0 (vector-length hash-table) (vector-set! hash-table i '()))
+      (for-each
+        (match-lambda
+          [(i . elem) (vector-set! hash-table i elem)])
+        vec-entries)]))
+
+ ;;------------------------------------------------------------
+
+
+ ;; (define (hash-fn n1 n2)
+ ;;  (fxlogand (+ (* n1 prime1) (* n2 prime2)) (sub1 hash-table-size)))
+
+ (define (hash-fn n1 n2)
+   (modulo (+ (* n1 prime1) (* n2 prime2)) hash-table-size))
+
+ (define (hash-fn* n*) (foldl hash-fn 0 n*))
+
+ (define (add-entry h entry)
+   (vector-set! hash-table h (cons entry (vector-ref hash-table h)))
+   (set! entries-in-table (add1 entries-in-table))
+   '(if (zero? (mod entries-in-table 10000))
+        (printf "Entries ~s~n" entries-in-table))
+   (when (>= entries-in-table resize-table-size)
+     (resize-hash-table)))
+
+ (define (resize-hash-table)
+   (set! hash-table-size (* 2 hash-table-size))
+   (let ( [old hash-table]
+          [s (format "Resizing hash table to ~s" hash-table-size)])
+     (mrspidey:progress s '...)
+     (flush-output)
+     (set! hash-table (make-vector hash-table-size '()))
+     (set! resize-table-size 
+         (inexact->exact 
+          (round (* hash-table-size resize-table-fraction))))
+     (for i 0 (vector-length old)
+          (map 
+           (lambda (entry)
+             (let ([h (entry->hash-fn entry)])
+               (vector-set! hash-table h
+                            (cons entry (vector-ref hash-table h)))))
+           (vector-ref old i)))
+     (mrspidey:progress s 'done)
+     ;;(show-stat-small)
+     ))
+
+ (define (hash-table-list h) (vector-ref hash-table h))
+
+ (define (hash-find h ok?)
+   (recur loop ([l (vector-ref hash-table h)])
+     (cond [(null? l) #f]
+           [(ok? (car l)) (car l)]
+           [else (loop (cdr l))])))
+
+ (define (hash-table-info)
+   (list hash-table-size entries-in-table
+         (recur loop ([i 0][c 0])
+           (if (= i hash-table-size) c
+               (let ([l (length (vector-ref hash-table i))])
+                 (loop (add1 i)
+                       (+ c (max 0 (- l 1)))))))))
+
+ ;;------------------------------------------------------------
+

collects/mrspidey/Sba/hyper.ss

@@ -0,0 +1,601 @@
+; hyper.ss - interface to GUI
+; ----------------------------------------------------------------------
+; Copyright (C) 1995-97 Cormac Flanagan
+;
+; This program is free software; you can redistribute it and/or
+; modify it under the terms of the GNU General Public License
+; version 2 as published by the Free Software Foundation.
+; 
+; This program is distributed in the hope that it will be useful,
+; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+; GNU General Public License for more details.
+; 
+; You should have received a copy of the GNU General Public License
+; along with this program; if not, write to the Free Software
+; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
+; ----------------------------------------------------------------------
+;;----------------------------------------------------------------------
+
+(define (st:analyze-and-make-annotations filename)
+  (analysis-set-arrow-filter! #f)
+  (record-analyzed-file
+   filename
+   (lambda () (open-code-file filename))
+   (lambda () (analyze-program filename))))
+
+(define (calc-annotations defs)
+  (match-let*
+      ([type-annotations (calc-type-annotations defs)]
+       [(check-annotations uncheck-annotations) (calc-checks defs)]
+       [all-annotations 
+        (vector type-annotations check-annotations uncheck-annotations)])
+    ;;(pretty-debug `(links ,all-annotations))
+    all-annotations))
+	          
+;;----------------------------------------------------------------------
+    
+(define arrow-filter #f)          ; if not #f, then a list of templates
+; only show pred with matching AV
+
+(define (analysis-set-arrow-filter! C)
+  (set! arrow-filter
+      (if C 
+          (map lookup-template (list C))
+          #f)))
+
+(define (analysis-filter-on?)
+  (and arrow-filter (symbol->string (template-type (car arrow-filter)))))
+
+(define (analysis-get-filters)
+  (cons 
+    (cons "No filter" #f)
+    (map 
+      (lambda (C) (cons (symbol->string C) C))
+      (append
+        `( nil num sym str void undefined true false 
+           box cons vec eof iport oport
+           promise unit thread hash-table regexp parameterization semaphore)
+        (filter
+          (lambda (x) x)
+          (hash-table-map
+            constructor-env
+            (lambda (c template)
+              (and
+                (memq template-structure (template-super-templates template))
+                c))))))))
+
+;; ------------------------------
+
+(define (objs-contain-filter? objs)
+  (or 
+    (and
+      (eq? arrow-filter #f)
+      (not (null? objs)))
+    (ormap 
+      (lambda (AV)
+        (memq (AV-template AV) arrow-filter))
+      objs)))
+
+(define (tvar-contain-filter-mvalues? get-Tvar-objs tvar)
+  (or
+    (objs-contain-filter? (get-Tvar-objs tvar))
+    (ormap
+      (match-lambda
+        [($ AV _ (? (eqc? template-mvalues)) _ #(tvar-mvlist))
+          ;;(pretty-debug `(tvar-mvlist ,(Tvar-name tvar-mvlist)))
+          (ormap
+            (match-lambda
+              [($ AV _ (? (eqc? template-cons)) _ #(tvar-car-mvlist _))
+                (objs-contain-filter? (get-Tvar-objs tvar-car-mvlist))]
+              [_ #f])
+            (get-Tvar-objs tvar-mvlist))]
+        [_ #f])
+      (get-Tvar-objs tvar))))
+
+(define (FlowType-contains-filter? ftype)
+  ;(pretty-debug `(FlowType-contains-filter? ,(FlowType-name ftype)))
+  (or
+    (not arrow-filter)
+    (match (FlowType->Atype ftype)
+      [(or (? atconst?) (? atprim?) (? Tvar?))
+        (tvar-contain-filter-mvalues? Tvar-objs (FlowType->Tvar ftype))]
+      [($ atvalues (val1 . _))
+        (FlowType-contains-filter? val1)]
+      ;; other atypes are atschema atthunk, atstruct, atunit, atlunit
+      ;; all are too expensive to convert.
+      [x
+        (pretty-debug  `(FlowType-contains-filter? unhandled-atype x))
+        #f])))
+
+(define (FlowType-orig-objs-contains-filter? ftype)
+  ;;(pretty-debug `(FlowType-orig-contains-filter? ,(FlowType-name ftype)))
+  (match (FlowType->Atype ftype)
+    [(or (? Tvar?))
+      (tvar-contain-filter-mvalues? Tvar-orig-objs (FlowType->Tvar ftype))]
+    [($ atvalues (val1 . _))
+      (FlowType-orig-objs-contains-filter? val1)]
+    ;; other atypes are atschema atthunk, atstruct, atunit, atlunit
+    ;; all are too expensive to convert.
+    [x
+      (pretty-debug  `(FlowType-orig-objs-contains-filter? unhandled-atype x))
+      #f]))
+
+;;----------------------------------------------------------------------
+;; Abstracts over parents and children
+
+(define analysis-walk1
+  (lambda (start in-get-edges file-visable?)
+    (assert (FlowType? start))
+    (pretty-debug `(analysis-walk1 ,(FlowType-name start)))
+    (if (string? (FlowType-type-annotation start))
+      ;; start from .za file, show no edges
+      '()
+      (letrec*
+        ( [traversed '()]               ; list of FlowType's
+          [preds '()]                   ; visable FlowType's
+          [get-edges
+            (lambda (ftype)
+              (let ([r (in-get-edges ftype)])
+                (pretty-debug `(get-edges ,(map FlowType-name (cons ftype r))))
+                r))]
+          [traverse 
+            (lambda (ftype)
+              (pretty-debug `(traverse ,(FlowType-name ftype)))
+              (when 
+                (and
+                  (FlowType-contains-filter? ftype)
+                  (not (memq ftype traversed)))
+                (set! traversed (cons ftype traversed))
+                (let* 
+                  ( [ftype-w/-ta (get-ftype-w/-ta ftype)]
+                    [ta (and ftype-w/-ta 
+                          (FlowType-type-annotation ftype-w/-ta))])
+                  (pretty-debug
+                    `(traverse-ftype-w/-ta 
+                       ,(and ftype-w/-ta (FlowType-name ftype-w/-ta))))
+                 
+                  (cond
+                    [(not ta)
+                      ;; invisable
+                       ;; Go back to parents
+                      (for-each traverse (get-edges ftype))]
+
+                    [(string? ta)
+                      (if (file-visable? ta)
+                        
+                        ;; ftype from .za file, source file is loaded
+                        ;; can follow this edge unless dest is from same file
+                        (for-each
+                          (lambda (ftype2)
+                            (let ([ta2 (FlowType-type-annotation ftype2)])
+                              (unless (and (string? ta2) (string=? ta ta2))
+                                (traverse ftype2))))
+                          (get-edges ftype))
+                        
+                        ;; .za file, source file not loaded
+                        (set! preds (cons ftype-w/-ta preds)))]
+
+                    [(and 
+                       (not (string? ta))
+                       (not (eq? ftype-w/-ta start)))
+
+                      ;; visable
+                      ;; add to preds unless src and dest are single value
+                      (set! preds (cons ftype-w/-ta preds))]
+
+                    [else
+                      ;; Invisable
+                      ;; Go back to parents
+                      (for-each traverse (get-edges ftype))]))))])
+
+        (for-each traverse (get-edges start))
+               
+        (pretty-debug `(traversed ,(map FlowType-name traversed)))
+        (pretty-debug 
+          `(preds ,(map
+                     (lambda (i) (and (FlowType? i) (FlowType-name i)))
+                     preds)))
+        
+        (remq start preds)))))
+
+(define (get-ftype-w/-ta ftype)
+  (if (FlowType-type-annotation ftype)
+      ftype
+      (and (FlowType-values-ftype ftype)
+           (get-ftype-w/-ta (FlowType-values-ftype ftype)))))
+
+(define (single-value-ftype ftype)
+  (let ([r
+          (match (FlowType->Atype ftype)
+            [(? Tvar? tvar)
+                (ormap
+                  (lambda (AV) (not (eq? (AV-template AV) template-mvalues)))
+                  (get-Tvar-objs tvar))]
+            [($ atvalues) #f]
+            [_ #t])])
+    (pretty-debug `(single-value-ftype ,(FlowType-name ftype) ,r))
+    r))
+
+;;----------------------------------------------------------------------
+;; Returns the preds in the Tvar graph of a given ftype
+;; format is a list of Tvars of predecessors that are visable
+
+(define analysis-parents
+  (lambda (ftype file-visable?)
+    (pretty-debug `(analysis-parents ,(FlowType-name ftype) ,(print-struct)))
+    (let ([r (analysis-walk1 ftype get-arrowfrom file-visable?)])
+    (pretty-debug `(analysis-parents-returns ,(map FlowType-name r)))
+      r)))
+
+(define (get-arrowfrom to)
+  (append
+    (if (Tvar? to)
+      (append
+        (get-mvalue-components to)
+        (Tvar-edgefrom to))
+      '())
+    (match (FlowType->Atype to)
+      [($ atvalues ftypes)
+        ftypes]
+      [_ '()])
+    (FlowType-arrowfrom to)))
+
+(define (get-mvalue-components tvar)
+  '(pretty-debug `(get-mvalue-components ,(Tvar-name tvar)))
+  (filter-map
+    (lambda (AV)
+      (if (eq? (AV-template AV) template-mvalues)
+        ;; get-nth
+        (let ( [p (mk-Tvar 'p)]
+               [l (mk-Tvar 'l)])
+          (new-edge! (vector-ref (AV-fields+ AV) 0) p)
+          (new-con! p (make-con-cdr p))
+          (new-con! p (make-con-car l))
+          '(pretty-debug
+             `(get-mvalue-components
+                ,(Tvar-name tvar) ,(Tvar-name p) ,(Tvar-name l)))
+          l)
+        #f))
+    (get-Tvar-objs tvar))) 
+
+;; ----------------------------------------------------------------------
+
+(define analysis-children
+  (lambda (ftype file-visable?)
+    (analysis-walk1
+      ftype
+      FlowType-alledgeto
+      file-visable?)))
+
+(define FlowType-alledgeto
+  (lambda (ftype)
+    (append
+      ;; Direct successors
+      (FlowType-arrowto ftype)
+      (if (FlowType-values-ftype ftype)
+        (list (FlowType-values-ftype ftype))
+        '())
+      ;; For filter successors, make sure some same values
+      (if (Tvar? ftype)
+        (append
+          (Tvar-edgeto ftype)
+          (filter-map
+            (match-lambda
+              [($ con-filter _ _ tvar) tvar]
+              [_ #f])
+            (Tvar-constraints ftype)))
+        '()))))
+
+;;----------------------------------------------------------------------
+;; Returns all ancestor/descendant arrows of a given ftype
+;; as (listof (list from to))
+
+(define analysis-walkn
+  (lambda (ftype get-edges file-visable?)
+    (assert (FlowType? ftype))
+    (pretty-debug `(analysis-walkn ,(FlowType-name ftype)))
+    ;;(error)
+    (let ( [done '()]                   ; list of FlowType's
+           [arrows '()])                ; visable arrows
+      (recur traverse ([ftype ftype])
+        (unless (memq ftype done)
+          (set! done (cons ftype done))
+          (let ([parents (analysis-walk1 ftype get-edges  file-visable?)])
+            (for-each 
+              (lambda (p)
+                (set! arrows (cons (list p ftype) arrows))
+                (traverse p))
+              parents))))
+
+      arrows)))
+
+;;----------------------------------------------------------------------
+;; Returns all ancestor arrows of a given ftype
+;; as (listof (list from to))
+
+(define analysis-ancestors
+  (lambda (ftype file-visable?)
+    (analysis-walkn ftype get-arrowfrom file-visable?)))
+
+(define analysis-descendants
+  (lambda (ftype file-visable?)
+    (map reverse
+      (analysis-walkn ftype FlowType-alledgeto file-visable?))))
+
+;;----------------------------------------------------------------------
+;; Calcs the shortest path to a source FlowType with
+;; orig-objs matching filter via breadth-first search
+;; Returns a list of FlowTypes
+;; or nil if no path to visable source
+;; or #f if ftype does not contain filter
+
+(define analysis-shortest-path
+  (lambda (ftype file-visable?)
+    (assert (FlowType? ftype))
+    (if (FlowType-contains-filter? ftype)
+      (let ([visited (list ftype)])
+        (letrec 
+          ([traverse
+             (lambda (list-paths)
+               (pretty-debug 
+                 `(list-paths
+                    ,(map (lambda (p) (map FlowType-name p)) list-paths)
+                    ,(map FlowType-name visited)))
+               (match list-paths
+                 [() 
+                   ;; No paths -> return the empty path
+                   '()]
+                 [((and path (ftype . rest-path)) . rest-paths)
+                   (pretty-debug 
+                     `(path ,(map FlowType-name path)
+                        rest-paths 
+                        ,(map (lambda (p) (map FlowType-name p)) rest-paths)))
+                   (let* ( [parents1 (analysis-parents ftype file-visable?)]
+                           [parents2
+                             (filter
+                               (lambda (p)
+                                 (if (memq p visited) 
+                                   #f
+                                   (begin
+                                     (set! visited (cons p visited))
+                                     #t)))
+                               parents1)])
+                     (set! visited (cons ftype visited))
+                     (if (and (null? parents2)
+                           (or (null? parents1)
+                             (null? rest-paths)))
+                       ;; either this path has terminated,
+                       ;; or went to cycle and is only one left.
+                       ;; either way, return it
+                       (reverse path)
+                       (traverse
+                         (append rest-paths
+                           (filter-map
+                             (lambda (parent) (cons parent path))
+                             parents2)))))]))])
+
+          (let ([path (traverse
+                        (map list (analysis-parents ftype file-visable?)))])
+
+            (pretty-debug `(traverse-path ,(map FlowType-name path)))
+
+            path)))
+      #f)))
+
+'(define analysis-shortest-path
+  (lambda (ftype file-visable?)
+    (assert (FlowType? ftype))
+    (if (FlowType-contains-filter? ftype)
+      (let ([visited '()])
+        (letrec 
+          ([traverse
+             (lambda (list-paths)
+               (pretty-debug 
+                 `(list-paths
+                    ,(map (lambda (p) (map FlowType-name p)) list-paths)
+                    ,(map FlowType-name visited)))
+               (match list-paths
+                 [() 
+                   ;; No paths -> return the empty path
+                   '()]
+                 [((and path (ftype . rest-path)) . rest-paths)
+                   (pretty-debug 
+                     `(path ,(map FlowType-name path)
+                        rest-paths 
+                        ,(map (lambda (p) (map FlowType-name p)) rest-paths)))
+                   (if (memq ftype visited)
+                     ;; going around a loop
+                     (traverse rest-paths)
+                     (let* ( [parents (analysis-parents ftype file-visable?)])
+                       (set! visited (cons ftype visited))
+                       (if (and (null? parents) (null? rest-paths))
+                         ;; this path has terminated, and is the only one left, 
+                         ;; and hence the longest, so return it
+                         (reverse path)
+                         (traverse
+                           (append rest-paths
+                             (filter-map
+                               (lambda (parent) (cons parent path))
+                               parents))))))]))])
+
+          (let ([path (traverse
+                        (map list (analysis-parents ftype file-visable?)))])
+
+            (pretty-debug `(traverse-path ,(map FlowType-name path)))
+
+            path)))
+      #f)))
+
+
+
+'(define analysis-shortest-path
+  (lambda (ftype file-visable?)
+    (assert (FlowType? ftype))
+    (let ([visited '()])
+      (letrec 
+        ([traverse
+           (lambda (list-paths)
+             (pretty-debug 
+               `(list-paths
+                  ,(map (lambda (p) (map FlowType-name p)) list-paths)
+                  ,(map FlowType-name visited)))
+             (match list-paths
+               [() 
+                 ;; No paths -> return the empty path
+                 '()]
+               [((and path (ftype . rest-path)) . rest-paths)
+                 (if (memq ftype visited)
+
+                   ;; Visited on a shorter path
+                   (traverse rest-paths)
+
+                   (begin
+                     (pretty-print 
+                       `(path ,(map FlowType-name path)
+                          rest-paths 
+                          ,(map (lambda (p) (map FlowType-name p)) rest-paths)))
+                     (set! visited (cons ftype visited))
+                     (cond
+                       [(FlowType-orig-objs-contains-filter? ftype)
+                         ;; Has orig-objs that match the filter 
+                         ;; => return this path
+                         (reverse path)]
+                       [(FlowType-contains-filter? ftype)
+                         ;; Has propogated objs that match the filter
+                         ;; => go back to parent
+                         (let* ([new-paths
+                                  (map 
+                                    (lambda (parent) (cons parent path))
+                                    (get-arrowfrom ftype))])
+                           (pretty-print 
+                             `(rest-paths ,(map (lambda (p) (map FlowType-name p)) rest-paths)
+                                new-paths
+                                ,(map (lambda (p) (map FlowType-name p)) new-paths)))
+                           (traverse (append rest-paths new-paths)))]
+                       [else
+                         ;; This FlowType no good
+                         (traverse rest-paths)])))]))])
+        (let ([path (traverse (list (list ftype)))])
+
+          (pretty-print `(traverse-path ,(map FlowType-name path)))
+          ;; Drop first FlowType - it is us
+          ;; Remove invisable FlowType's
+          ;; NO LONGER Add '() as last tag if last FlowType invisable
+          (assert (or (null? path) (eq? (car path) ftype)))
+          (if (null? path)
+            '()
+            (recur loop ([path (cdr path)])
+              (match path
+                [(ftype . rest)
+                  (cond
+                    [(FlowType-type-annotation ftype) (cons ftype (loop rest))]
+                    [(null? rest) '()]
+                    [else (loop rest)])]
+                [()
+                  ;; No path
+                  '()]))))))))
+
+;; ======================================================================
+;; Returns a string representation of the the type
+      
+(define (FlowType->SDL-text ftype)
+  (let ([type-port (open-output-string)])
+    (dynamic-let
+     ([pretty-print-columns (st:pretty-type-width)])
+     (pretty-print (FlowType->SDL ftype) type-port))
+    (begin0
+     (get-output-string type-port)
+     (close-output-port type-port))))
+      
+(define analysis-callback
+  (lambda (ftype)
+    (assert (FlowType? ftype) 'analysis-callback ftype)
+    (pretty-debug `(analysis-callback ,(FlowType->pretty ftype)))
+    (FlowType->SDL-text ftype)))
+      
+;;----------------------------------------------------------------------
+
+'(define test-hyper
+   (lambda (files)
+     (initialize-analysis!)
+     (match-let* 
+       ([(defs in out) 
+          (sba-analyze-file (files->file-thunk* files))])
+       (set! global-in-env in-env)
+       (set! global-out-env out-env)
+       (report-unbound-vars)
+       (hyper defs)
+       (printf "Testing parents~n")
+       (pretty-print (mapLR analysis-parents list-ftype))
+       (printf "Testing analysis-shortest-path~n")
+       (pretty-print (mapLR analysis-shortest-path list-ftype))
+       (printf "Testing children~n")
+       (pretty-print (mapLR analysis-children list-ftype list-ftype))
+       (void))))
+
+;; (trace analysis-parents analysis-shortest-path analysis-children)
+
+;;----------------------------------------------------------------------
+;; zodiac-based source-correlating pretty-printer
+
+'(define (correlate-pretty-print sexp)
+   (let* ([p (open-output-string)]
+           [_ (pretty-print sexp p)]
+           [s (get-output-string p)]
+           [_ (close-output-port p)]
+           [p (open-input-string p)]
+           [r (zodiac:read p)]
+           [zexp (r)])
+     (values s
+       (recur loop ([sexp sexp][zexp zexp])
+         (match (list sexp zexp)
+           [((? list? sl) ($ zodiac:list _ s f (? list? zl)))
+             (list
+               (zodiac:location-offset s)
+               (zodiac:location-offset f)
+               (map loop sl zl))]
+           [(sexp ($ zodiac:zodiac _ s f))
+             (list
+               (zodiac:location-offset s)
+               (zodiac:location-offset f)
+               sexp)])))))
+
+;; ----------------------------------------------------------------------
+
+'(define analysis-get-pred-filter-list
+   (lambda ()
+     (cons (cons "All sources" #f)
+       (reverse 
+         (map
+           (match-lambda
+             [(con . constructor) (cons (symbol->string con) (list con))])
+           (append constructor-env default-constructor-env))))))
+
+(define analysis-get-param
+  (lambda (param)
+    ((eval param))))
+
+(define analysis-set-param!
+  (lambda (param val)
+    ((eval param) val)))
+
+;; ----------------------------------------------------------------------
+
+;; ----------
+
+'(define (contains-some-same-vals? ftype value-from-ftypes)
+   ;; Returns #t if ftype contains at least some values from
+   ;; each of value-from-ftypes
+   (andmap
+     (lambda (value-from-ftype)
+       (match (list
+                (FlowType->Atype ftype)
+                (FlowType->Atype value-from-ftype))
+         [((? fo-Atype? x) (? fo-Atype? y)) (eq? x y)]
+         [((? Tvar? x) (? Tvar? y))
+           (ormap 
+             (lambda (AV) (memq AV (get-Tvar-objs y)))
+             (get-Tvar-objs x))]
+         [_ #t]))
+     value-from-ftypes))

collects/mrspidey/Sba/kern-aux.ss

@@ -0,0 +1,378 @@
+;; kernel-aux.ss
+;; Helper functions for building constraints
+; ----------------------------------------------------------------------
+; Copyright (C) 1995-97 Cormac Flanagan
+;
+; This program is free software; you can redistribute it and/or
+; modify it under the terms of the GNU General Public License
+; version 2 as published by the Free Software Foundation.
+; 
+; This program is distributed in the hope that it will be useful,
+; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+; GNU General Public License for more details.
+; 
+; You should have received a copy of the GNU General Public License
+; along with this program; if not, write to the Free Software
+; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
+; ----------------------------------------------------------------------
+;; ----------------------------------------------------------------------
+;;
+(define (make-constructed-AV-template template . args)
+  (match-let* ( [($ template type num+ num- ref assign) template]
+                [fields+ (make-vector num+)]
+                [fields- (make-vector num-)])
+    (for-each-with-n
+      (lambda (arg n)
+        (if (vector-ref assign n)
+          ;; Mutable - fill next two fields
+          (let ([tvar (mk-Tvar 'mut-field)])
+            (new-edge! arg tvar)
+            (vector-set! fields- (vector-ref assign n) tvar)
+            (when (vector-ref ref n)
+              (vector-set! fields+ (vector-ref ref n) tvar)))
+          ;; Immutable - fill one field
+          (when (vector-ref ref n)
+              (vector-set! fields+ (vector-ref ref n) arg))))
+      args)
+    (create-AV template '() fields+ fields-)))
+
+(define (make-constructed-AV C . args)
+  (apply make-constructed-AV-template (lookup-template C) args))
+
+(define (make-constructed-Tvar C . args)
+  (let ([tvar (mk-Tvar 'constructed-Tvar)]
+        [AV (apply make-constructed-AV C args)])
+    (new-AV! tvar AV)
+    tvar))
+
+;; ----------------------------------------------------------------------
+
+(define (make-AV-cons a d)
+  (if (st:cons-mutable)
+    (let* ( [fields+ (make-vector 2)]
+            [fields- (make-vector 2)])
+      (let ([tvar (mk-Tvar 'mut-field)])
+        (new-edge! a tvar)
+        (vector-set! fields+ 0 tvar)
+        (vector-set! fields- 0 tvar))
+      (let ([tvar (mk-Tvar 'mut-field)])
+        (new-edge! d tvar)
+        (vector-set! fields+ 1 tvar)
+        (vector-set! fields- 1 tvar))
+      (create-AV template-cons '() fields+ fields-))
+    (create-AV template-cons '() (vector a d) (vector))))
+
+
+(define (make-con-car tvar) (create-con template-cons 0 tvar #t))
+(define (make-con-cdr tvar) (create-con template-cons 1 tvar #t))
+(define (make-con-dom tvar) (create-con template-lam 0 tvar #f))
+(define (make-con-rng tvar) (create-con template-lam 0 tvar #t))
+
+(define (make-AV-vec a) 
+  (cond
+    [(lookup-template 'vect)
+      =>
+      (lambda (template-vect)
+        (make-constructed-AV-template template-vect a AV-numb))]
+    [(lookup-template 'vec)
+      =>
+      (lambda (template-vec)
+        (make-constructed-AV-template template-vec a))]))
+
+(define (make-AV-lam dom rng nargs restarg)
+  (create-AV 
+    template-lam 
+    (list 'lam-info nargs restarg)
+    (vector rng) 
+    (vector dom)))
+
+(define AV-nil   (void))
+(define AV-numb  (void))
+(define AV-sym   (void))
+(define AV-str   (void))
+(define AV-char  (void))
+(define AV-true  (void))
+(define AV-false (void))
+(define AV-void  (void))
+(define AV-undefined (void))
+(define AV-top-s (void))
+
+(define (mk-tvar-nil)   (mk-Tvar-init-AV 'nil   AV-nil))
+(define (mk-tvar-numb)  (mk-Tvar-init-AV 'num   AV-numb))
+(define (mk-tvar-sym)   (mk-Tvar-init-AV 'sym   AV-sym))
+(define (mk-tvar-str)   (mk-Tvar-init-AV 'str   AV-str))
+(define (mk-tvar-char)  (mk-Tvar-init-AV 'char  AV-char))
+(define (mk-tvar-true)  (mk-Tvar-init-AV 'true  AV-true))
+(define (mk-tvar-false) (mk-Tvar-init-AV 'false AV-false))
+(define (mk-tvar-empty) (mk-Tvar 'empty))
+(define (mk-tvar-void)
+  (if (st:see-void) 
+    (mk-Tvar-init-AV 'void  AV-void)
+    (mk-Tvar 'void)))
+(define (mk-tvar-undefined) (mk-Tvar-init-AV 'undefined AV-undefined))
+
+(define (init-common-AV!)
+  (unless (template? template-nil)
+    (mrspidey:internal-error
+      "template-nil not a template, language probably not specified"))
+  (set! AV-nil    (make-constructed-AV-template template-nil))
+  (set! AV-numb   (make-constructed-AV-template template-num))
+  (set! AV-sym    (make-constructed-AV-template template-sym))
+  (set! AV-str    (make-constructed-AV-template template-str))
+  (set! AV-char   (make-constructed-AV-template template-char))
+  (set! AV-true   (make-constructed-AV-template template-true))
+  (set! AV-false  (make-constructed-AV-template template-false))
+  (set! AV-void   (make-constructed-AV-template template-void))
+  (set! AV-undefined (make-constructed-AV-template template-undefined))
+  (set! AV-top-s  (make-constructed-AV-template template-top-s))
+  )
+
+;; ======================================================================
+
+(define traverse-simple-const
+  ;; Returns an AV, or #f
+  (match-lambda
+   [(or ($ zodiac:char _ _ _ c) (? char? c))
+    (if (st:constants)
+        (create-AV template-char c (vector) (vector))
+        AV-char)]
+   [(or ($ zodiac:symbol _ _ _ sym) (? symbol? sym))
+    (if (st:constants)
+        (create-AV template-sym sym (vector) (vector))
+        AV-sym)]
+   [(or ($ zodiac:number _ _ _ num) (? number? num))
+    (if (st:constants)
+        (create-AV template-num num (vector) (vector))
+        AV-numb)]
+   [(or ($ zodiac:string _ _ _ str) (? string? str)) AV-str]
+   [(or ($ zodiac:boolean _ _ _ #t) #t) AV-true]
+   [(or ($ zodiac:boolean _ _ _ #f) #f) AV-false]
+   [(or ($ zodiac:list _ _ _ ()) ()) AV-nil]
+   [_ #f]))
+
+(define traverse-const-exact
+  ;; Returns an AV
+  (lambda (V)
+    (or (traverse-simple-const V)
+        (match V
+          [(or ($ zodiac:list _ _ _ l)
+               (? pair? l)
+               (? null? l))
+           (recur loop ([l l])
+             (match l
+               [(a . d)
+                (let ([tvar-a (mk-Tvar 'car)]
+                      [tvar-d (mk-Tvar 'cdr)])
+                  (new-AV! tvar-a (traverse-const-exact a))
+                  (new-AV! tvar-d (loop d))
+                  (make-AV-cons tvar-a tvar-d))]
+               [() AV-nil]
+               [x (traverse-const-exact x)]))]
+          [($ zodiac:improper-list _ _ _ l)
+           (recur loop ([l l])
+             (match l
+               [(x) (traverse-const-exact x)]
+               [(a . d)
+                (let ([tvar-a (mk-Tvar 'car)]
+                      [tvar-d (mk-Tvar 'cdr)])
+                  (new-AV! tvar-a (traverse-const-exact a))
+                  (new-AV! tvar-d (loop d))
+                  (make-AV-cons tvar-a tvar-d))]))]
+          [($ zodiac:vector _ _ _ v)
+           (let ([tvar-e (mk-Tvar 'vec-field)])
+             (for-each
+              (lambda (e) (new-AV! tvar-e (traverse-const-exact e)))
+              v)
+             (make-AV-vec tvar-e))]
+          [(? vector? v)
+           (let ([tvar-e (mk-Tvar 'vec-field)])
+             (for-each
+              (lambda (e) (new-AV! tvar-e (traverse-const-exact e)))
+              (vector->list v))
+             (make-AV-vec tvar-e))]
+          [($ zodiac:box _ _ _ b)
+           (let ([tvar-e (mk-Tvar 'box-field)])
+             (new-AV! tvar-e (traverse-const-exact b))
+             (make-constructed-AV 'box tvar-e))]
+          [(? box? b)
+           (let ([tvar-e (mk-Tvar 'box-field)])
+             (new-AV! tvar-e (traverse-const-exact (unbox b)))
+             (make-constructed-AV 'box tvar-e)) ]
+          [(? void?) 
+            (make-constructed-AV 'void)]
+          [obj (error 'traverse-const-exact "Bad const ~s" obj)]))))
+
+;; ======================================================================
+;; Transitive closure of edgeto
+;; Could use faster algorithm here
+
+(define (Tvar-transitive-edgeto Tvar)
+  (let*-vals ( [(reached? set-reached!) (alloc-Tvar-field)]
+               [edgeto '()])
+    (recur loop ([Tvar Tvar])
+      (unless (reached? Tvar)
+        (set-reached! Tvar #t)
+        (set! edgeto (cons Tvar edgeto))
+        (for-each loop (Tvar-edgeto Tvar))
+        (for-each
+          (match-lambda
+            [($ con-filter _ _ to) (loop to)]
+            [_ (void)])
+          (Tvar-constraints Tvar))))
+    (pretty-debug 
+      `(Tvar-trans-edgeto ,(Tvar-name Tvar) ,(map Tvar-name edgeto)))
+    edgeto))
+
+(define (Tvar-transitive-edgefrom Tvar)
+  (let*-vals ( [(reached? set-reached!) (alloc-Tvar-field)]
+               [edgefrom '()])
+    (recur loop ([Tvar Tvar])
+      (unless (reached? Tvar)
+        (set-reached! Tvar #t)
+        (set! edgefrom (cons Tvar edgefrom))
+        (for-each loop (Tvar-edgefrom Tvar))))
+    (pretty-debug 
+      `(Tvar-trans-edgefrom ,(Tvar-name Tvar) ,(map Tvar-name edgefrom)))
+    edgefrom))
+
+;; ======================================================================
+
+(define (copy-constraint-set tvar tvar* edges)
+  ;; copies all Tvars in list tvar*
+  ;; edges: (listof (cons Tvar Tvar))
+
+  (pretty-debug
+    `(copy-constraint-set ,(Tvar-name (car tvar*)) ,(Tvar-name (rac tvar*))))
+
+  (let*-vals
+    ( [(tvar-nutvar set-tvar-nutvar!) (alloc-Tvar-field)]
+      [(AV-nuAV set-AV-nuAV!) (alloc-AV-field)]
+      [Tvar->nuTvar (lambda (tvar) (or (tvar-nutvar tvar) tvar))]
+      [copy-AV 
+        (lambda (AV)
+          (or 
+            (AV-nuAV AV)
+            (match AV
+              [(and AV ($ AV _ template misc fields+ fields-))
+                (if (or 
+                      (vector-ormap tvar-nutvar fields+)
+                      (vector-ormap tvar-nutvar fields-))
+                  (let* ( [nu-AV (create-AV 
+                                   template misc 
+                                   (vector-map Tvar->nuTvar fields+)
+                                   (vector-map Tvar->nuTvar fields-))])
+                    (set-AV-nuAV! AV nu-AV)
+                    nu-AV)
+                  (begin
+                    (set-AV-nuAV! AV AV)
+                    AV))])))])
+
+    (for-each 
+      (lambda (Tvar) (set-tvar-nutvar! Tvar (mk-Tvar 'copy-constraint-set)))
+      tvar*)
+
+    (for-each 
+      (lambda (source)
+        (let ([dest (Tvar->nuTvar source)])
+          ;; --- AV
+          (for-each
+            (lambda (AV) (new-AV! dest (copy-AV AV)))
+            (Tvar-objs source))
+          ;; --- Constraints
+          (for-each
+            (match-lambda
+              [($ con _ template field-no Tvar sign)
+                (new-con! dest 
+                  (create-con template field-no (Tvar->nuTvar Tvar) sign))]
+              [($ con-filter _ filter Tvar)
+                (new-con! dest
+                  (create-con-filter filter (Tvar->nuTvar Tvar)))])
+            (Tvar-constraints source))
+          ;; --- Edges
+          (for-each
+            (lambda (Tvar2) (new-edge! dest (Tvar->nuTvar Tvar2)))
+            (Tvar-edgeto source))))
+      tvar*)
+
+    (for-each
+      (match-lambda
+        [(from . to)
+          (new-edge! (Tvar->nuTvar from) (Tvar->nuTvar to))])
+      edges)
+
+    (Tvar->nuTvar tvar)))
+
+; ======================================================================
+; Non-Terminals
+
+(define-typed-structure NT (tvar type rhs*))
+
+(define mk-Tvar-NTs!
+  (lambda (Tvar)
+    (set-Tvar-L!  Tvar (make-NT Tvar 'L '()))
+    (set-Tvar-U!  Tvar (make-NT Tvar 'U '()))
+    ))
+
+(define mk-AV-NTs!
+  (lambda (AV)
+    (set-AV-U!  AV (make-NT AV 'U '()))
+    ))
+
+(define (chk-Tvar-L tvar)
+  (or (Tvar-L tvar)
+    (begin
+      (mk-Tvar-NTs! tvar)
+      (Tvar-L tvar))))
+
+(define (chk-Tvar-U tvar)
+  (or (Tvar-U tvar)
+    (begin
+      (mk-Tvar-NTs! tvar)
+      (Tvar-U tvar))))
+
+(define (chk-AV-U AV)
+  (or (AV-U AV)
+    (begin
+      (mk-AV-NTs! AV)
+      (AV-U AV))))
+
+(define (alloc-NT-field)
+  (let* ( [table (make-hash-table)]
+          [get-info
+            (lambda (nt)
+              (hash-table-get table nt (lambda () #f)))]
+          [set-info!
+            (lambda (nt v)
+              (hash-table-put! table nt v))])
+    (values get-info set-info!)))
+
+(define nt->sym
+  (match-lambda
+    [($ NT x type) 
+      (symbol-append type ': 
+        (if (Tvar? x) (Tvar-name x)
+          (symbol-append 'AV ': (AV-num x))))]
+    [x `(BAD-NT!!!! ,x)]))
+
+(define (AV->rep AV) (symbol-append 'AV ': (AV-num AV)))
+
+; ======================================================================
+
+(define select-L
+  (lambda (nt*)
+    (filter-map (match-lambda [($ NT x 'L) x][_ #f]) nt*)))
+
+'(define select-LI
+  (lambda (nt*)
+    (filter-map (match-lambda [($ NT x 'LI) x][_ #f]) nt*)))
+
+(define select-U
+  (lambda (nt*)
+    (filter-map (match-lambda [($ NT x 'U) x][_ #f]) nt*)))
+
+'(define select-UI
+  (lambda (nt*)
+    (filter-map (match-lambda [($ NT x 'UI) x][_ #f]) nt*)))
+
+;; ======================================================================

collects/mrspidey/Sba/kernel.ss

@@ -0,0 +1,785 @@
+;; kernel.ss
+; ----------------------------------------------------------------------
+; Copyright (C) 1995-97 Cormac Flanagan
+;
+; This program is free software; you can redistribute it and/or
+; modify it under the terms of the GNU General Public License
+; version 2 as published by the Free Software Foundation.
+; 
+; This program is distributed in the hope that it will be useful,
+; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+; GNU General Public License for more details.
+; 
+; You should have received a copy of the GNU General Public License
+; along with this program; if not, write to the Free Software
+; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
+; ----------------------------------------------------------------------
+;; ----------------------------------------------------------------------=
+;; FlowType == value flow graph node
+
+(define-const-typed-structure
+  FlowType
+  ( (: num num)
+    (! expr (union zodiac:parsed string false symbol))
+    (! arrowto (listof FlowType))
+    (! arrowfrom (listof FlowType))
+    (! type-annotation any) ;; type-annotation% or file.ss (if from .za file)
+    (! proplist (listof (cons sym any)))
+    (! values-ftype (union false FlowType))
+    ))
+
+ (define num-ftype  0)
+ (define list-ftype '())
+ (define num-edge 0)
+
+ (define (init-FlowType!)
+   (set! num-ftype  0)
+   (set! list-ftype '())
+   (set! num-edge 0))
+
+ ;;------------------------------------------------------------
+;; Extension functions
+
+(define (add-FlowType-arrow! from to)
+  (set-FlowType-arrowto! from (cons to (FlowType-arrowto from)))
+  (set-FlowType-arrowfrom! to (cons from (FlowType-arrowfrom to))))
+
+(define (add-FlowType! ftype)
+  (set! num-ftype (add1 num-ftype))
+  (set! list-ftype (cons ftype list-ftype))
+  ftype)
+
+;;------------------------------------------------------------
+;; Property list stuff
+      
+(define (add-FlowType-prop! ftype prop val)
+  (set-FlowType-proplist! ftype 
+                          (cons (cons prop val) (FlowType-proplist ftype))))
+
+(define (get-FlowType-prop ftype prop default)
+  (recur loop ([l (FlowType-proplist ftype)])
+    (match l
+      [() default]
+      [((a . d) . rest)
+       (if (eq? a prop)
+           d
+           (loop rest))]
+      [_ default])))
+
+(define (FlowType-name ftype)
+  (symbol-append (get-FlowType-prop ftype 'symbol 'anon)
+    ':
+    (FlowType-num ftype)))
+
+;; ======================================================================
+;; ======================================================================
+
+(define-typed-structure (Tvar struct:FlowType) 
+  ( (: objs (listof AV))
+    (: orig-objs (listof AV))
+    (: constraints (listof (union con con-filter)))
+    (: leq-top-s bool)
+    (: edgeto (listof Tvar))
+    (: edgefrom (listof Tvar))
+    (: L NT)
+    (: U NT)
+    (: PL NT)
+    (: PU NT)
+    ))
+
+(define-const-typed-structure AV 
+  ((: num num)
+   (: template template)
+   misc
+   (: fields+ (vec Tvar))
+   (: fields- (vec Tvar))
+   (! U NT)
+   (! PU any)
+    wb
+))
+
+(define-const-typed-structure template
+  ( (: type   sym)
+    (: num+ int)
+    (: num- int)
+    (: ref (vec num))
+    (: assign (vec num))
+    (! super-templates (listof template))
+    (: misc-eq? (any -> any))))
+
+ ;; ref and assign are for constructors
+ ;; ref maps a constructor-field to the AV-field+ to get value from
+ ;; assign maps a constructor-field to the AV-field- to add value to,
+ ;; or #f if immutable
+ ;; super-templates field records that eg num is a supertype of apply+
+ ;; misc-eq? is an equality function on the misc field of AVs
+ ;; sym-ndx maps symbols to the index for that symbol
+ ;;  eg. map ivar names
+
+
+ ;; Each elem of AV-fields is an Tvar
+
+(define-const-typed-structure con
+  ( (: num      num)
+    (: template template)
+    (: field-no num)
+    (: tvar     Tvar)
+    (: sign     bool)
+    misc))
+
+(define-const-typed-structure con-filter
+  ((: num    num)
+   (: filter filter)
+   (: tvar    Tvar)))
+
+(define-const-typed-structure filter
+  ((: sign      bool)
+   (: templates (listof template))))
+
+(define (create-filter sign templates)
+  (assert (and (boolean? sign)
+            (list? templates)
+            (andmap template? templates))
+    'create-filter sign templates)
+  (make-filter sign templates))
+
+;; Says whether to include or exclude certain templates
+
+(define-const-typed-structure con-top-s
+  ())
+
+(define con-top-s (make-con-top-s))
+
+(define mt-vector (vector))
+;----------------------------------------------------------------------
+
+ (define num-con  0)  
+ (define num-AV   0)
+ (define num-AV-in-Tvar 0)
+ (define max-constraint-system-size 0)
+ (define (constraint-system-size) (+ num-edge num-con num-AV-in-Tvar))
+
+ (define (SBA-entry->hash entry)
+   (hash-fn (FlowType-num (car entry))
+            (let ([d (cdr entry)])
+              (if (Tvar? d)
+                  (FlowType-num d)
+                  (AV-num d)))))
+
+ (define (init-kernel!)
+   (init-FlowType!)
+   (set! num-con  0)
+   (set! num-AV   0)
+   (set! num-AV-in-Tvar 0)
+   (set! max-constraint-system-size 0)
+   (init-hash-table SBA-entry->hash 0)
+   )
+
+ ;;------------------------------------------------------------
+ ;; Creation functions
+
+ (define (create-AV template misc fields+ fields-) 
+   (assert (and 
+             (template? template)
+             (vector? fields+)
+             (vector? fields-)
+             (vector-andmap Tvar? fields+)
+             (vector-andmap Tvar? fields-))
+           `(create-AV ,template ,misc ,fields+ ,fields-))
+   (let ([AV (make-AV num-AV template misc fields+ fields- #f #f (make-weak-box 1))])
+     (set! num-AV (add1 num-AV))
+     AV))
+
+ (define mk-Tvar-nolist
+   (lambda (sym)
+     (let ([tvar (make-Tvar
+                   ;; FlowType fields
+                   num-ftype #f '() '() #f `((symbol . ,sym)) #f 
+                   ;; Tvar fields
+                   '() '() '() #f '() '()
+                   #f #f #f #f
+                   )])
+       (set! num-ftype (add1 num-ftype))
+       tvar)))
+
+ (define mk-Tvar
+   (lambda (sym)
+     (let ([tvar (mk-Tvar-nolist sym)])
+       (set! list-ftype (cons tvar list-ftype))
+       tvar)))
+
+ (define (create-con template field-no tvar sign) 
+   (create-con-misc template field-no tvar sign '()))
+
+ (define (create-con-misc template field-no tvar sign misc) 
+   (make-con num-con template field-no tvar sign misc))
+
+ (define (create-con-filter filter tvar) 
+   (assert (filter? filter))
+   (make-con-filter num-con filter tvar))
+      
+;; ----------------------------------------------------------------------
+;; Functions for extending graph
+;; the add-* functions extend the data structures, but don't propogate
+;; the check-add-* only adds if item not in data structure, but don't propogate
+;; the extend-* functions also propogate values & constraints appropriately
+;; the new-* functions are normally bound to extend-*, but sometines add-*
+;; ----------------------------------------------------------------------
+
+(define add-edge!
+   (lambda (from to)
+     (assert (and (Tvar? from) (Tvar? to)) 'add-edge! from to)
+     (set-Tvar-edgeto! from (cons to (Tvar-edgeto from)))
+     (set-Tvar-edgefrom! to (cons from (Tvar-edgefrom to)))
+     (set! num-edge (add1 num-edge))
+     (add-entry (hash-fn (FlowType-num from) (FlowType-num to))
+                (cons from to))))
+      
+(define add-AV!
+  (lambda (tvar AV)
+    (set! num-AV-in-Tvar (add1 num-AV-in-Tvar))
+    (set-Tvar-objs! tvar (cons AV (Tvar-objs tvar)))
+    (add-entry (hash-fn (FlowType-num tvar) (AV-num AV))
+      (cons tvar AV))))
+
+(define add-con!
+  (lambda (tvar con)
+    (set! num-con (add1 num-con))
+    (set-Tvar-constraints! tvar (cons con (Tvar-constraints tvar)))))
+
+'(define add-nohash-con! add-con!)
+
+;; ----------------------------------------------------------------------
+;; the check-add-* functions check if a constraint is present,
+;; and if not, add it, but do not propogate
+ 
+(define check-add-edge!
+   (lambda (from to)
+     (assert (and (Tvar? from) (Tvar? to)) 'extend-edge! from to)
+     (unless
+       (or (Tvar-edge? from to) (eq? from to))
+       (add-edge! from to))))
+
+ (define check-add-AV!
+   (lambda (tvar AV)
+     (assert (AV? AV) `(extend-AV! ,tvar ,AV))
+     (set-Tvar-orig-objs! tvar (cons AV (Tvar-orig-objs tvar)))))
+
+ (define check-add-con!
+   (lambda (tvar con)
+     (set! num-con (add1 num-con))
+     (set-Tvar-constraints! tvar (cons con (Tvar-constraints tvar)))
+     (match con
+       [($ con-filter _ _ dest)
+         (set-Tvar-edgefrom! dest (cons tvar (Tvar-edgefrom dest)))]
+       [_ (void)])))
+
+;; ----------------------------------------------------------------------
+;; the extend-* functions also propogate values & constraints appropriately
+ 
+(define extend-edge!
+   (lambda (from to)
+     (assert (and (Tvar? from) (Tvar? to)) 'extend-edge! from to)
+     (unless
+       (or (Tvar-edge? from to) (eq? from to))
+       (add-edge! from to)
+       ;; Propogate all AV's
+       (for-each (lambda (AV) (prop-AV! to AV))
+                 (Tvar-objs from)))))
+
+(define extend-AV!
+  (lambda (tvar AV)
+    (assert (AV? AV) `(extend-AV! ,tvar ,AV))
+    (set-Tvar-orig-objs! tvar (cons AV (Tvar-orig-objs tvar)))
+    (prop-AV! tvar AV)))
+
+(define prop-AV!
+  (lambda (tvar AV)
+    (assert (and (Tvar? tvar) (AV? AV)) `(prop-AV! ,tvar ,AV))
+    (unless (Tvar-AV-mem? tvar AV)
+      (add-AV! tvar AV)
+      ;; Apply all constraints
+      (for-each 
+        (lambda (con) (SBA-constraint tvar con AV))
+        (Tvar-constraints tvar))
+      ;; Propogate
+      (for-each
+        (lambda (to) (prop-AV! to AV))
+        (Tvar-edgeto tvar)))))
+
+ (define extend-con!
+   (lambda (tvar con)
+     (set! num-con (add1 num-con))
+     (set-Tvar-constraints! tvar (cons con (Tvar-constraints tvar)))
+     (match con
+       [($ con-filter _ _ dest)
+         (set-Tvar-edgefrom! dest (cons tvar (Tvar-edgefrom dest)))]
+       [_ (void)])
+     ;; Apply to all AV's
+     (for-each (lambda (AV) (SBA-constraint tvar con AV))
+               (get-Tvar-objs tvar))))
+
+;; ----------------------------------------------------------------------
+;; the new-* functions are normally equiv to extend-*,
+;; but can be set to add-* via a parameter 
+
+(define new-edge! extend-edge!)
+(define new-AV!   extend-AV!)
+(define new-con!  extend-con!)
+
+(define (new-leq-top-s! tvar)
+  ;; tvar <= top-s, is constraint
+  (unless (Tvar-leq-top-s tvar)
+    (set-Tvar-leq-top-s! tvar #t)
+    (new-con! tvar con-top-s)))
+
+(define (new-geq-top-s! tvar)
+  ;; top-s <= tvar, is AV
+  (new-AV! tvar AV-top-s))
+
+;; ----------------------------------------------------------------------
+
+(define keep-S-closed
+  (let ([closed #t])
+    (case-lambda
+      [() closed]
+      [(x)
+        (set! closed x)
+        (if x
+          (begin
+            (set! new-edge! extend-edge!)
+            (set! new-AV! extend-AV!)
+            (set! new-con! extend-con!))
+          (begin
+            (set! new-edge! check-add-edge!)
+            (set! new-AV! check-add-AV!)
+            (set! new-con! check-add-con!)))])))
+    
+(define new-create-AV!
+  (lambda (tvar template misc fields)
+    (new-AV! tvar (create-AV template misc fields))))
+
+(define new-bidir-edge! 
+  (lambda (from to)
+    (new-edge! from to)
+    (new-edge! to from)))
+
+(define new-edge-para
+  (case-lambda
+    [() new-edge!]
+    [(x) (set! new-edge! x)]))
+
+(define (close-constraints tvars)
+  (pretty-debug `(close-constraints ,(map Tvar-name tvars)))
+  (for-each
+    (lambda (tvar)
+      (for-each
+        (lambda (AV)
+          (for-each
+            (lambda (to) (prop-AV! to AV))
+            (Tvar-edgeto tvar))
+          (for-each
+            (lambda (con) (SBA-constraint tvar con AV))
+            (Tvar-constraints tvar)))
+        (get-Tvar-objs tvar)))
+    tvars))
+
+ ;;------------------------------------------------------------
+ ;; Handling constraints
+
+(define gSBA-constraint (void))
+
+(define SBA-constraint
+  (lambda (tvar con AV)
+    (set! gSBA-constraint (list tvar con AV))
+    (match con
+      ;; Regular constraints
+      [($ con _ template field-no tvar-con sign)
+        (match AV
+          [($ AV _ template2 misc fields+ fields-)
+            (when (or 
+                    (eq? template template2)
+                    (memq template (template-super-templates template2)))
+              ;;(pretty-print `(,con ,AV))
+              (if sign
+                (when (< field-no (vector-length fields+))
+                  ;; Propogate field from AV into tvar-con
+                  (new-edge! (vector-ref fields+ field-no) tvar-con))
+                (when (< field-no (vector-length fields-))
+                  ;; Propogate field from tvar-con into AV
+                  (new-edge! tvar-con (vector-ref fields- field-no)))))
+            (when (eq? template2 template-top-s)
+              (if sign
+                (new-geq-top-s! tvar-con)
+                (new-leq-top-s! tvar-con)))])]
+
+      ;; Filter constraints
+      [($ con-filter _ ($ filter bool templates) tvar-con)
+        '(printf "template ~s templates ~s memq ~s bool ~s add ~s~n" 
+           (template-type (AV-template AV))
+           (map template-type templates)
+           (memq (AV-template AV) templates)
+           bool
+           (case (memq (AV-template AV) templates)
+             [#f (not bool)]
+             [else bool]))
+        (let* ( [AV-t (AV-template AV)]
+                [found (ormap
+                         (lambda (t2)
+                           (or 
+                             (eq? AV-t t2)
+                             (memq t2 (template-super-templates AV-t))))
+                         templates)])
+          '(pretty-print-debug
+             `(con-filter found ,found 
+                memq ,(memq AV-t templates)
+                AV-t ,(template-type AV-t)
+                ,(map template-type templates)))
+          (when (or (case found
+                      [(#f) (not bool)]
+                      [else bool])
+                  (eq? AV-t template-top-s))
+            ;; Add AV to tvar-con
+            (prop-AV! tvar-con AV)))]
+      [($ con-top-s)
+        (match AV
+          [($ AV _ template2 misc fields+ fields-)
+            (vector-for-each new-leq-top-s! fields+)
+            (vector-for-each new-geq-top-s! fields-)])])))
+      
+ ;;------------------------------------------------------------
+ ;; Functions/predicates for examining the graph
+
+ (define (Tvar-AV-mem? tvar AV)
+   (hash-find (hash-fn (FlowType-num tvar) (AV-num AV))
+              (lambda (entry) 
+                (and (eq? (car entry) tvar)
+                     (eq? (cdr entry) AV)))))
+
+ (define (Tvar-edge? from to)
+   (hash-find (hash-fn (FlowType-num from) (FlowType-num to))
+              (lambda (entry)
+                (and (eq? (car entry) from)
+                     (eq? (cdr entry) to)))))
+      
+ (define get-Tvar-objs Tvar-objs)
+      
+;; ------------------------------------------------------------
+
+(define (really-check-kernel-ok)
+  (dynamic-let 
+    ([st:check-kernel #t]) 
+    (check-kernel-ok)))
+
+(define check-kernel-ok:tvar #f)
+
+(define (check-kernel-ok)
+  ;; Sanity check
+  (when (st:check-kernel)
+    (assert (= num-ftype (length list-ftype)))
+    (let ([Tvar-edge?
+            (lambda (a b)
+              (or (eq? a b)
+                (Tvar-edge? a b)))])
+
+      (printf "check-kernel-ok: Consistency tests~n")
+      (for-each
+        (lambda (tvar)
+          (when (Tvar? tvar)
+            (assert (= (length (Tvar-objs tvar))
+                      (length (list->set (Tvar-objs tvar)))))
+            (assert (= (length (Tvar-edgeto tvar))
+                      (length (list->set (Tvar-edgeto tvar)))))
+            (assert (= (length (Tvar-constraints tvar))
+                      (length (list->set (Tvar-constraints tvar)))))
+            (for-each (lambda (AV) (assert (Tvar-AV-mem? tvar AV) (Tvar-name tvar)))
+              (Tvar-objs tvar))
+            (for-each (lambda (to) (assert (Tvar-edge? tvar to)))
+              (Tvar-edgeto tvar))))
+        list-ftype)
+   
+      ;; Now check kernel is closed under S
+      (printf "check-kernel-ok: Closure tests~n")
+      (for-each
+        (lambda (tvar)
+          (when (Tvar? tvar)
+            (for-each 
+              (lambda (AV)
+                ;; First check AV prop'd
+                (for-each 
+                  (lambda (to)
+                    (when (Tvar? to)
+                      (assert (Tvar-AV-mem? to AV)
+                        (Tvar-name tvar) (Tvar-name to)
+                        (template-type (AV-template AV)))))
+                  (Tvar-edgeto tvar))
+                ;; Check AV applied to all constraints
+                (for-each
+                  (match-lambda
+                    [($ con _  template field-no tvar-con sign)
+                      (match AV
+                        [($ AV _ template2 misc fields+ fields-)
+                          (when 
+                            (or 
+                              (eq? template template2)
+                              (memq template (template-super-templates template2)))
+                            (if sign
+                              (when (< field-no (vector-length fields+))
+                                ;; Propogate field from AV into tvar-con
+                                (assert
+                                  (Tvar-edge?
+                                    (vector-ref fields+ field-no) tvar-con)
+                                  `(Tvar-edge?
+                                     ,(Tvar-name (vector-ref fields+ field-no))
+                                     ,(Tvar-name tvar-con))
+                                  (Tvar-name tvar) field-no
+                                  (template-type template)))
+                              (when (< field-no (vector-length fields-))
+                                ;; Propogate field from tvar-con into AV
+                                (assert
+                                  (Tvar-edge?
+                                    tvar-con (vector-ref fields- field-no))
+                                  (Tvar-name tvar) 
+                                  field-no
+                                  (Tvar-name tvar-con)
+                                  sign
+                                  (template-type template)))))]
+
+                        [_ 
+                          ;; Constraint does not apply to this AV
+                          (void)])]
+                    [($ con-filter _ ($ filter bool templates) tvar-con)
+                      ;; ignore for now
+                      (void)])
+                  (Tvar-constraints tvar)))
+              (get-Tvar-objs tvar))))
+        (reverse list-ftype))
+
+      ;; Now check all reachable tvars are in list-ftype
+      (printf "check-kernel-ok: list-ftype tests~n")
+      (let*-vals 
+        ( [(get set) (alloc-Tvar-field (lambda () #f))]
+          [ok-tvar? (lambda (tvar)
+                      (unless (get tvar)
+                        (printf
+                          "Tvar ~s reachable from ~s but not in list-ftype ~s~n"
+                          (FlowType-num tvar)
+                          (FlowType-num check-kernel-ok:tvar)
+                          (memq tvar list-ftype))))]
+          [ok-AV? 
+            (match-lambda
+              [($ AV _ _ _ fields+ fields-)
+                (vector-for-each ok-tvar? fields+)
+                (vector-for-each ok-tvar? fields-)])])
+
+        (for-each
+          (lambda (ftype)
+            (when (Tvar? ftype) (set ftype #t)))
+          list-ftype)
+
+        (for-each
+          (lambda (ftype)
+            (when (Tvar? ftype)
+              (set! check-kernel-ok:tvar ftype)
+              (for-each ok-tvar? (Tvar-edgeto ftype))
+              (for-each ok-tvar? (Tvar-edgefrom ftype))
+              (for-each ok-AV?   (Tvar-objs ftype))
+              (for-each ok-AV?   (Tvar-orig-objs ftype))
+              (for-each
+                (match-lambda
+                  [($ con _ _ _ tvar) (ok-tvar? tvar)]
+                  [($ con-filter _ _ tvar) (ok-tvar? tvar)])
+                (Tvar-constraints ftype))))
+          list-ftype))
+
+      )))
+
+(define (check-unreachable ftypes unreachable)
+  (let* ( [check-ok
+            (lambda (ftype) 
+              (when (memq ftype unreachable)
+                (error 'check-unreachable "Ftype ~s in old ~s"
+                  (FlowType-name ftype)
+                  (map FlowType-name unreachable))))])
+    (for-each
+      (lambda (ftype)
+        (when (Tvar? ftype)
+          (for-each check-ok (Tvar-edgeto ftype))
+          (for-each check-ok (Tvar-edgefrom ftype))
+          (for-each
+            (match-lambda
+              [($ AV _ _ _ fields+ fields-)
+                (vector-for-each check-ok fields+)
+                (vector-for-each check-ok fields-)])
+            (Tvar-objs ftype))
+          (for-each
+            (match-lambda
+              [($ con _ _ _ tvar) (check-ok tvar)]
+              [($ con-filter _ _ tvar) (check-ok tvar)])
+            (Tvar-constraints ftype))))
+      ftypes)))
+
+ ;; ------------------------------------------------------------
+
+(define-structure (kernel-state
+                    num-ftype list-ftype num-edge 
+                    num-con num-AV num-AV-in-Tvar 
+                    closed? new-edge! hash-table-state))
+                    
+(define (save-kernel-state)
+  (make-kernel-state
+    num-ftype list-ftype num-edge 
+    num-con num-AV num-AV-in-Tvar 
+    (keep-S-closed) new-edge! 
+    (capture-hash-table-state)))
+
+(define restore-kernel-state!
+  (match-lambda
+    [($ kernel-state
+       saved-num-ftype saved-list-ftype saved-num-edge 
+       saved-num-con saved-num-AV saved-num-AV-in-Tvar 
+       closed? saved-new-edge! 
+       hash-table-state)
+      (let ([old-size (constraint-system-size)])
+        (set! num-ftype saved-num-ftype)
+        (set! list-ftype saved-list-ftype)
+        (set! num-edge saved-num-edge)
+        (set! num-con saved-num-con)
+        (set! num-AV saved-num-AV)
+        (set! num-AV-in-Tvar saved-num-AV-in-Tvar)
+        (keep-S-closed closed?)
+        (set! new-edge! saved-new-edge!)
+        (restore-hash-table-state! hash-table-state)
+
+        (set! max-constraint-system-size
+          (max max-constraint-system-size
+            (+ (constraint-system-size) old-size)))
+        )]))
+
+(define free-kernel-state!
+  (match-lambda
+    [($ kernel-state
+       saved-num-ftype saved-list-ftype saved-num-edge 
+       saved-num-con saved-num-AV saved-num-AV-in-Tvar 
+       closed? saved-new-edge! 
+       hash-table-state)
+
+      (free-hash-table-state! hash-table-state)
+      (for-each 
+        (lambda (ftype)
+          (set-FlowType-expr! ftype 'zerod1!)
+          (set-FlowType-arrowto! ftype 'zerod2!)
+          (set-FlowType-arrowfrom! ftype 'zerod3!)
+          (set-FlowType-type-annotation! ftype 'zerod4!)
+          (set-FlowType-proplist! ftype 'zerod5!)
+          (set-FlowType-values-ftype! ftype 'zerod6!)
+          (when (Tvar? ftype) 
+            (set-Tvar-objs! ftype 'zerod7!)
+            (set-Tvar-orig-objs! ftype 'zerod8!)
+            (set-Tvar-constraints! ftype 'zerod9!)
+            (set-Tvar-edgeto! ftype 'zeroda!)
+            (set-Tvar-edgefrom! ftype 'zerodb!)
+            (set-Tvar-L! ftype 'zerodc!)
+            (set-Tvar-U! ftype 'zerodd!)
+            (set-Tvar-PL! ftype 'zerode!)
+            (set-Tvar-PU! ftype 'zerodf!)))
+        saved-list-ftype)]))
+
+;; ----------------------------------------------------------------------
+
+(define-structure (prompt-kernel-state saved-state prompt-hash-state ftypes))
+
+(define (prompt-kernel-state)
+  (make-prompt-kernel-state
+    (save-kernel-state)
+    (prompt-hash-table-state)
+    (map
+      (lambda (ftype)
+        (list 
+          ftype
+          (match ftype
+            [($ FlowType _ _ arrowto arrowfrom _ _ values-ftype)
+              (list arrowto arrowfrom values-ftype)])
+          (match ftype
+            [($ Tvar _ _ _ _ _ _ _
+               objs orig-objs con edgeto edgefrom)
+              (list objs orig-objs con edgeto edgefrom)]
+            [_ #f])))
+      list-ftype)))
+
+(define unprompt-kernel-state!
+  (match-lambda
+    [($ prompt-kernel-state saved-state prompt-hash-state ftypes)
+      (restore-kernel-state! saved-state)
+      (unprompt-hash-table-state! prompt-hash-state)
+      (for-each
+        (match-lambda
+          [(ftype (arrowto arrowfrom values-ftype) tvar-info)
+            (set-FlowType-arrowto! ftype arrowto)
+            (set-FlowType-arrowfrom! ftype arrowfrom)
+            (set-FlowType-values-ftype! ftype values-ftype)
+            (match tvar-info
+              [#f (void)]
+              [(objs orig-objs con edgeto edgefrom)
+                (set-Tvar-objs! ftype objs)
+                (set-Tvar-orig-objs! ftype orig-objs)
+                (set-Tvar-constraints! ftype con)
+                (set-Tvar-edgeto! ftype edgeto)
+                (set-Tvar-edgefrom! ftype edgefrom)])])
+        ftypes)]))
+
+;; ------------------------------------------------------------
+;; Auxiliary info on Tvars
+
+(define alloc-Tvar-field
+  (case-lambda
+    [(default-fn)
+      (let* ( [table (make-hash-table)]
+              [get-info
+                (lambda (tvar) 
+                  (assert (FlowType? tvar) tvar 'get-info)
+                  (hash-table-get table tvar default-fn))]
+              [set-info!
+                (lambda (tvar v)
+                  (assert (FlowType? tvar) tvar 'set-info!)
+                  (hash-table-put! table tvar v))])
+        (values get-info set-info!))]
+    [() (alloc-Tvar-field (lambda () #f))]))
+
+(define alloc-AV-field
+  (case-lambda
+    [(default-fn)
+      (let* ( [table (make-hash-table)]
+              [get-info
+                (lambda (AV) 
+                  (hash-table-get table AV default-fn))]
+              [set-info!
+                (lambda (AV v)
+                  (hash-table-put! table AV v))])
+        (values get-info set-info!))]
+    [() (alloc-AV-field (lambda () #f))]))
+
+(define (field->set alloc-field)
+  (let*-vals ( [(get-info set-info!) (alloc-field)]
+               [list-obj '()]
+               [in? (lambda (obj) (get-info obj))]
+               [add! (lambda (obj) 
+                       (unless (in? obj)
+                         (set-info! obj #t)
+                         (set! list-obj (cons obj list-obj))))]
+               [get-list (lambda () list-obj)])
+    (values in? add! get-list)))
+
+;; ----------------------------------------------------------------------
+ 
+(define mk-Tvar-init-AV
+  (lambda (sym AV)
+    (let ([r (mk-Tvar sym)])
+      (new-AV! r AV)
+      r)))
+
+(define (Tvar-name tvar) (FlowType-name tvar))
+
+;; ======================================================================
+

collects/mrspidey/Sba/languages-abstract.ss

@@ -0,0 +1,15 @@
+;; ======================================================================
+
+(define (init-R4RS!)
+  ;; Also extends it with void
+
+  (apply add-default-constructor! (type: sym) (type: (listof bool)))
+  (add-default-primitive! (type: (list sym sexp))))
+
+;; ======================================================================
+
+(define (init-Chez-on-R4RS!) (void))
+(define (init-Rice-on-Chez!) (void))
+(define (init-MzScheme-on-R4RS!) (void))
+(define (init-DrScheme-on-MzScheme!) (void))
+(define (init-smart-numops!) (void))

collects/mrspidey/Sba/ldexpand.ss

@@ -0,0 +1,371 @@
+; ldexpand.ss - loads and macro expands source files
+; ----------------------------------------------------------------------
+; Copyright (C) 1995-97 Cormac Flanagan
+;
+; This program is free software; you can redistribute it and/or
+; modify it under the terms of the GNU General Public License
+; version 2 as published by the Free Software Foundation.
+; 
+; This program is distributed in the hope that it will be useful,
+; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+; GNU General Public License for more details.
+; 
+; You should have received a copy of the GNU General Public License
+; along with this program; if not, write to the Free Software
+; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
+; ----------------------------------------------------------------------
+
+(define (open-code-file filename)
+  (let ([filename (normalize-path filename)]
+         [cd (current-directory)])
+    (dynamic-let 
+      ([current-directory (path-only filename)])
+      (unless (file-exists? filename)
+        (mrspidey:error (format "Can't open file ~s, current directory ~s"
+                          filename (current-directory))))
+      (let* ( [p (open-input-file filename 'text)]
+              [p (system-expand-if-necy p)])
+        p))))
+
+(define (zodiac:read* port filename)
+  (let* ( [default-loc (zodiac:make-location 1 1 0 filename)]                      
+            
+         [reader (if (st:fake-reader)
+                     (fake-zodiac-reader port default-loc)
+                     (zodiac:read port default-loc))]
+         [sexps
+          (recur loop ()
+            (let* ([expr (reader)])
+              (if (or (zodiac:eof? expr) (eof-object? expr))
+                  '()
+                  (begin
+                    (when (zodiac:zodiac? expr)
+                      (mrspidey:zprogress "Reading" 
+                                          (zodiac:zodiac-start expr)))
+                    (cons expr (loop))))))])
+    (unless (null? sexps)
+      (mrspidey:zprogress "Reading" (zodiac:zodiac-finish (rac sexps))))
+    (close-input-port port)
+    (when debugging-front
+      (printf "~n--Loaded file---------------------~n")
+      (for-each (lambda (sexp) (pretty-print (zodiac:stripper sexp))) sexps)
+      (printf "----------------------------------~n"))
+    sexps))
+
+(define mrspidey:zprogress
+  (let ( [cur-phase '()]
+         [cur-line -100]
+         [cur-file ""])
+    (lambda (phase loc)
+      (let ( [file (zodiac:location-file loc)]
+             [line (zodiac:location-line loc)])
+        (unless (and 
+                  (equal? file cur-file)
+                  (eq? phase cur-phase)
+                  ;;(>= line cur-line)
+                  (< line (+ cur-line 10)))
+          (set! cur-phase phase)
+          (set! cur-line line)
+          (set! cur-file file)
+          (mrspidey:progress
+            (format "~a ~a: "
+              (padr phase 10)
+              (file-name-from-path file))
+            line))))))
+
+; ----------------------------------------------------------------------
+
+(define fake-zodiac-reader
+  (case-lambda
+   [(p) (fake-zodiac-reader p (zodiac:make-location 1 1 0 "filename"))]
+   [(p loc)
+    (lambda ()
+      (let ([x (read p)])
+        (recur loop ([x x])
+          (match x
+            [(? string?)  (zodiac:make-string loc loc loc x)]
+            [(? boolean?) (zodiac:make-boolean loc loc loc x)]
+            [(? number?)  (zodiac:make-number loc loc loc x)]
+            [(? symbol?)  (zodiac:make-symbol loc loc loc x x x)]
+            [(? char?)    (zodiac:make-char loc loc loc x)]
+            [(? vector?)  (zodiac:make-vector loc loc loc
+                                              (map loop (vector->list x))
+                                              (vector-length x))]
+            [(? list?)    (zodiac:make-list loc loc loc
+                                            (map loop x)
+                                            (length x)
+                                            'marks)]
+            [(? pair?)    (zodiac:make-improper-list 
+                           loc loc loc
+                           (recur loop2 ([x x])
+                             (match x
+                               [(a . d) (cons (loop a) (loop2 d))]
+                               [r (list (loop r))]))
+                           0
+                           'period 'marks)]
+            [_ (if (eof-object? x)
+                   (zodiac:make-eof loc)
+                   (mrspidey:internal-error 
+                    'fake-zodiac-reader
+                    "Bad object ~s" x))]))))]))
+
+; ----------------------------------------------------------------------
+
+(define (expand-zexp->port exp)
+  (let* ( [exp (zodiac:stripper exp)]
+          [s (format "~s" exp)]
+          [p (open-input-string s)]
+          [p (system-expand-if-necy p)])
+    p))
+
+; ----------------------------------------------------------------------
+
+(define (system-expand-if-necy p)
+  (if (st:system-expand)
+      (system-expand-port p)
+      p))
+
+(define system-macros
+  '(;; --- r4rs
+    case cond do recur rec let* letrec let and or define
+    ;; --- Chez things
+         parameterize fluid-let case-lambda let-values #%let-values
+    ;; --- Rice things
+    match match-lambda match-lambda* match-let match-let*
+    ;; --- My things
+    define-module global assert for 
+    ;; --- Misc
+    defmacro
+    ;; Units w/ signatures
+    define-signature 
+    unit-with-signature unit/sig 
+    compound-unit/sig compound-unit-with-signature
+    invoke-unit/sig invoke-unit-with-signature
+    unit->unit/sig
+    ))
+
+
+(define (expander-eval e)
+  (parameterize ([current-namespace expander-namespace])
+                (eval e)))
+(when (st:system-expand)
+  (expander-eval '(load "/home/cormac/Spidey/Code/Sba/expander-boot.ss")))
+(define (my-expand e) (expander-eval `(expand-defmacro ',e)))
+(define (my-expand-once e) (expander-eval `(expand-defmacro-once ',e)))
+
+(define unchanged-list
+  '( define-constructor
+     define-type
+     primitive:
+     type:))
+
+(define system-expanded-exp (void))
+
+(define (system-expand-exp exp)
+  (set! system-expanded-exp exp)
+  (match exp
+    [((? (lambda (x) (memq x unchanged-list))) . _) 
+     exp]
+    [_ (match (my-expand exp)
+         [(and e ((or '#%define-expansion-time '#%define-macro) . _))
+          (expander-eval e)
+          '(void)]
+         [e e])]))
+
+(define (remove-signature-stuff e)
+  (recur loop ([e e])
+    (match e
+      [('#%make-unit-with-signature x _ _) (loop x)]
+      [('#%verify-signed-compound-sub-units . _) '(void)]
+      [('#%verify-linkage-signature-match . _) '(void)]
+      [('#%unit-with-signature-unit x) x]
+      [('#%invoke-open-unit expr name-specifier . imports)
+        `(#%invoke-unit ,(loop expr) ,@imports)]
+      [('#%invoke-open-unit expr)
+        `(#%invoke-unit ,(loop expr))]
+      [(('#%global-defined-value ('#%quote match:error)) . args)
+        '(error 'match "Match error")]
+      [(a . d) (cons (loop a) (loop d))]
+      [x x])))
+
+(define (system-expand-port p)
+  (pretty-debug `(system-expand-port ,p ,(current-directory)))
+  (let* ([o (open-output-string)])
+    (parameterize 
+      ([pretty-print-depth #f])
+      (recur loop ([p p])
+        (let ([e (read p)])
+          (printf ".") (flush-output)
+          (unless (eof-object? e)
+            (recur process ([e e])
+              (match (system-expand-exp e)
+                [('#%begin . e*)
+                  (for-each process e*)]
+                [e
+                  (let* ([e (remove-signature-stuff e)])
+                    (match e
+                      [((or 'load '#%load '#%load/cd 'load/cd) exp)
+                        (let ([filename (normalize-path (expander-eval exp))])
+                          (unless (file-exists? filename)
+                            (mrspidey:error (format "Can't load ~s" filename)))
+                          (dynamic-let 
+                            ([current-directory 
+                               (if (memq (car e) '(load/cd #%load/cd))
+                                 (path-only filename)
+                                 (current-directory))])
+                            (let* ([p (open-input-file filename 'text)])
+                              (printf "[File:~s " (file-name-from-path filename))
+                              (loop p)
+                              (printf "done]")
+                              (close-input-port p))))]
+                      [('load-recent s) 
+                        (process `(load ,(string-append s ".ss")))]
+                      [(or '(void) (? void?)) (void)]
+                      [e (pretty-print (strip-hash-percent e) o)]))]))
+            (loop p)))))
+    (begin0
+      (open-input-string (get-output-string o))
+      (close-output-port o)
+      (close-input-port p))))
+
+(define (strip-hash-percent expr)
+  (recur loop ([expr expr])
+    (match expr
+      [('|#primitive| prim) prim]
+      [(a . d) (cons (loop a) (loop d))]
+      [(? symbol? x)
+       (let* ([s (symbol->string x)]
+              [l (string-length s)])
+         (if (and (> l 2)
+                  (string=? (substring s 0 2) "#%"))
+             (string->symbol (substring s 2 l))
+             x))]
+      [x x])))
+
+; ----------------------------------------------------------------------
+
+(define expand-file
+  (case-lambda
+    [(infile)
+      (let ([infile (normalize-path infile)])
+        (let ([outfile (regexp-replace ".ss$" infile ".expanded")])
+          (when (eq? outfile infile)  
+            (error 'expand-file "Bad suffix on ~s" infile))
+          (expand-file infile outfile)))]
+    [(infile outfile)
+      (when (file-exists? outfile) (delete-file outfile))
+      (dynamic-let ( [st:system-expand #t]
+                     [current-directory (path-only  (normalize-path infile))])
+        (let* ( [p (open-input-file infile 'text)]
+                [p2 (system-expand-if-necy p)]
+                [p3 (open-output-file outfile 'text)])
+          (printf "~nCopying:")
+          (recur loop ()
+            (let ([e (read p2)])
+              (unless (eof-object? e)
+                (pretty-print e p3)
+                (printf ".") (flush-output)
+                (loop))))
+          (newline)
+          (close-input-port p2)
+          (close-output-port p3)
+          outfile))]))
+
+; ----------------------------------------------------------------------
+
+(define file-time-cache '())
+
+(define (clear-file-time-cache!)
+  (set! file-time-cache '()))
+
+(define (extend-file-time-cache! file n)
+  (set! file-time-cache (cons (cons file n) file-time-cache)))
+
+(define (file-time file)
+  (or (lookup-or-#f file-time-cache file)
+      (let* ([n (file-modify-seconds file)])
+        (unless (number? n) 
+          (error 'file-time "file-modify-seconds failed on ~a" file))
+        (extend-file-time-cache! file n)
+        n)))
+
+(define (zodiac-time x)
+  (let* ([start (zodiac:zodiac-start x)]
+         [file (zodiac:location-file start)])
+    (file-time file)))
+
+(define (zodiac-time* x)
+  ;; ## should be either current time, or file time of any imported file
+  ;; is in right directory
+  (let* ([t (zodiac-time x)]
+          [fn (lambda (exp cl-fn)
+                (match exp
+                  [($ zodiac:reference-unit-form _ _ _ _ file cd)
+                    (let*-vals
+                      ( [_ (unless (zodiac:string? file)
+                             (mrspidey:error
+                               (format "reference-unit requires a string argument, given ~s" file)))]
+                        [file (zodiac:read-object file)]
+                        [file (if (relative-path? file)
+                                (build-path cd file)
+                                file)])
+                      (when (file-exists? file)
+                        (pretty-debug `(zodiac:time* includes ,file))
+                        (set! t (max t (file-time file))))
+                      #f)]
+                  [_ #f]))])
+    ((zodiac:compat fn) x)
+    t))
+
+;; ======================================================================
+
+(define attributes #f)
+(define expander-namespace #f)
+
+(define (init-expand!)
+  (set! attributes (zodiac:make-attributes))
+  (set! expander-namespace (make-expander-namespace)))
+
+;; ----------------------------------------------------------------------
+
+(define g:prog #f)
+
+(define (my-scheme-expand-program defs)
+  ;;(printf "my-scheme-expand-program cd=~s~n" (cd))
+  (let* ( [p (make-parameterization)]
+          [_ (with-parameterization p
+               (lambda () 
+                 (current-namespace 
+                   expander-namespace
+                                        ;(make-expander-namespace)
+                   ) 
+                 (reference-library "core.ss")
+                 (reference-library "macro.ss")
+                 '(reference 
+                    (begin-elaboration-time
+                      (build-path
+                        mred:plt-home-directory "mred" "system" "sig.ss")))
+                 '(eval '(unit/sig () (import  mred^) 1))
+                 ;;(printf "np=~s~n" normalize-path)
+                 ))]
+          ;          [defs2 (zodiac:expand-program
+          ;                   defs attributes zodiac:mrspidey-vocabulary p)]
+          [defs2 (call/nal
+                   zodiac:expand-program/nal
+                   zodiac:expand-program
+                   (expressions: defs)
+                   (attributes: attributes)
+                   (vocabulary:  zodiac:mrspidey-vocabulary))]
+                   ; (parameterization: p))]
+          [defs2 (zodiac:inline-begins defs2)]
+          [_ (zodiac:initialize-mutated defs2)]
+          [free (zodiac:free-vars-defs defs2)])
+    (set! g:prog defs2)
+    ;;(pretty-print defs2)
+    '(when debugging
+       (pretty-print (map zodiac:stripper defs2)))
+    (values defs2 free)))
+
+;; ----------------------------------------------------------------------
+

collects/mrspidey/Sba/lib/env.ss

@@ -0,0 +1,69 @@
+;; env.ss
+;; ----------------------------------------------------------------------
+;; Environments
+
+    (define empty-env '())
+
+    (define lookup-or-fail
+      (lambda (env x fail-thunk)
+	(match (assq x env)
+	  [#f (fail-thunk)]
+	  [(_ . b) b])))
+
+    (define lookup-or-#f
+      (lambda (env x)
+	(match (assq x env)
+	  [#f #f]
+	  [(_ . b) b])))
+
+    (define lookup
+      (lambda (env x)
+	(match (assq x env)
+	  [#f (mrspidey:internal-error 'lookup "no binding for ~a" x)]
+	  [(_ . b) b])))
+
+    (define bound-in-env?
+      (lambda (env x)
+	(match (assq x env)
+	  [#f #f]
+	  [_ #t])))
+
+    (define extend-env
+      (lambda (env x v)
+	(cons (cons x v) env)))
+
+    (define extend-env*
+      (lambda (env xs vs)
+	(append (map cons xs vs) env)))
+
+    (define join-env
+      (lambda (env newenv)
+	(append newenv env)))
+
+    (define bang-env!
+      (lambda (env x nu-v)
+        (let ([binding (assq x env)])
+          (if binding
+              (set-cdr! binding nu-v)
+              (mrspidey:internal-error 'lookup "no binding for ~a" x)))))	
+	
+(define (env:change-binding env x f err)
+  (recur loop ([env env])
+    (if (null? env)
+      (err)
+      (if (eq? x (caar env))
+        (cons (cons x (f (cdar env))) (cdr env))
+        (cons (car env) (loop (cdr env)))))))
+
+(define (env:remove env x)
+  (let* ([bind #f]
+         [env
+           (recur loop ([env env])
+             (if (null? env)
+               '()
+               (if (eq? x (caar env))
+                 (begin
+                   (set! bind (cdar env))
+                   (cdr env))
+                 (cons (car env) (loop (cdr env))))))])
+    (values bind env)))

collects/mrspidey/Sba/lib/lib-list.ss

@@ -0,0 +1,247 @@
+;; library-list.ss
+;; ----------------------------------------------------------------------
+
+;; map from left to right
+(define mapLR
+  (lambda (f l)
+    (match l
+      [() '()]
+      [(x . y) (let ([v (f x)]) (cons v (mapLR f y)))]
+      [l (error 'mapLR "Bad list ~s" l)])))
+
+;; map from right to left
+(define mapRL
+  (lambda (f l)
+    (match l
+      [() '()]
+      [(x . y) (let ([v (mapRL f y)]) (cons (f x) v))])))
+
+(define foldl-with-n
+  (lambda (f i l)
+    (recur loop ([l l][acc i][n 0])
+      (match l
+        [() acc]
+        [(x . y) (loop y (f x n acc) (add1 n))]))))
+
+;; fold for a 2-argument function
+;; right operand of f is accumulator
+(define foldr2
+  (lambda (f i l1 l2)
+    (recur loop ([l1 l1][l2 l2])
+      (match (list l1 l2)
+        [(() ()) i]
+        [((x1 . y1) (x2 . y2)) (f x1 x2 (loop y1 y2))]))))
+
+;; filter elements out of a list by a predicate
+(define filter
+  (lambda (p l)
+    (match l
+      [() '()]
+      [(x . y) (if (p x) (cons x (filter p y)) (filter p y))])))
+
+;; filter and map left to right
+(define filter-map
+  (lambda (p l)
+    (match l
+      [() '()]
+      [(x . y)
+       (match (p x)
+         [#f (filter-map p y)]
+         [x (cons x (filter-map p y))])])))
+
+;; filter and map left to right, and return (filtered-list . unfiltered)
+
+(define filter-map-split
+  (lambda (p l)
+    (recur loop ([done-filtered '()][done-unfiltered '()][l l])
+      (match l
+        [() (values done-filtered done-unfiltered)]
+        [(x . y)
+         (match (p x)
+           [#f (loop done-filtered (cons x done-unfiltered) y)]
+           [x  (loop (cons x done-filtered) done-unfiltered y)])]))))
+
+;; last element of a list
+(define rac
+  (lambda (l)
+    (match l
+      [(last) last]
+      [(_ . rest) (rac rest)])))
+
+;; all but the last element of a list
+(define rdc
+  (lambda (l)
+    (match l
+      [(_) '()]
+      [(x . rest) (cons x (rdc rest))])))
+
+;; map left to right over a list, but also pass f a 0-based index
+(define map-with-n
+  (lambda (f l)
+    (recur loop ([l l][n 0])
+      (match l
+        [() '()]
+        [(x . y) (let ([v (f x n)]) (cons v (loop y (+ 1 n))))]
+        [l (error 'map-with-n "Bad list ~s" l)]))))
+
+;; for-each, but also pass f a 0-based index
+(define for-each-with-n
+  (lambda (f l)
+    (recur loop ([l l][n 0])
+      (match l
+        [() '()]
+        [(x . y) (f x n) (loop y (+ 1 n))]))))
+
+;; map on a (possibly improper) list
+(define map-ilist
+  (lambda (f l)
+    (recur loop ([l l])
+      (match l
+        [() '()]
+        [(x . y) (cons (f x) (loop y))]
+        [x (f x)]))))
+
+;; length on a (possibly improper) list
+(define length-ilist
+  (match-lambda
+    [(x . y) (add1 (length-ilist y))]
+    [_ 0]))
+
+(define improper?
+  (match-lambda
+    [(x . y) (improper? y)]
+    [() #f]
+    [_ #t]))
+
+(define (flatten-ilist l)
+  (cond [(null? l) '()]
+        [(pair? l) (cons (car l) (flatten-ilist (cdr l)))]
+        [else (list l)]))
+
+;; map a binary function down 2 lists, left to right
+(define map2
+  (lambda (f a b)
+    (match (cons a b)
+      [(() . ())
+       '()]
+      [((ax . ay) . (bx . by))
+       (let ([v (f ax bx)]) (cons v (map2 f ay by)))]
+      [else (error 'map2 "lists differ in length")])))
+
+; map over a list of lists
+
+(define (mapmap f ll) (map (lambda (l) (map f l)) ll))
+
+;; interate a binary function down 2 lists, left to right
+(define for-each2
+  (lambda (f a b)
+    (match (cons a b)
+      [(() . ())
+       (void)]
+      [((ax . ay) . (bx . by))
+       (f ax bx)
+       (for-each2 f ay by)]
+      [else (error 'for-each2 "lists differ in length")])))
+
+;; andmap for 2 lists
+(define andmap2
+  (lambda (f a b)
+    (match (cons a b)
+      [(() . ())
+       #t]
+      [((ax) . (bx))
+       (f ax bx)]
+      [((ax . ay) . (bx . by))
+       (and (f ax bx) (andmap2 f ay by))]
+      [else (error 'andmap2 "lists differ in length")])))
+
+;; andmap for 2 lists, fail on inequal lengths
+(define andmap2len
+  (lambda (f a b)
+    (match (cons a b)
+      [(() . ()) 
+       #t]
+      [((ax) . (bx))
+       (f ax bx)]
+      [((ax . ay) . (bx . by))
+       (and (f ax bx) (andmap2len f ay by))]
+      [else #f])))
+;(define andmap andmap2)
+
+;; ormap for 2 lists
+(define ormap2
+  (lambda (f a b)
+    (match (cons a b)
+      [(() . ())
+       #f]
+      [((ax) . (bx))
+       (f ax bx)]
+      [((ax . ay) . (bx . by))
+       (or (f ax bx) (ormap2 f ay by))]
+      [else (error 'ormap2 "lists differ in length")])))
+
+;; make a list containing n copies of e
+(define list-n-copies
+  (lambda (n e)
+    (if (zero? n)
+	'()
+	(cons e (list-n-copies (sub1 n) e)))))
+
+(define (count p l)
+  (recur loop ([c 0][l l])
+    (cond
+     [(null? l) c]
+     [(p (car l)) (loop (add1 c) (cdr l))]
+     [else (loop c (cdr l))])))
+
+(define (index l x)
+  (recur loop ([l l][i 0])
+    (cond
+     [(null? l) #f]
+     [(eq? x (car l)) i]
+     [else (loop (cdr l) (add1 i))])))
+
+(define (get-prefix l1 l2)
+    (if (eq? l1 l2)
+        '()
+        (cons (car l1) (get-prefix (cdr l1) l2))))
+
+(define (mklist n)
+  (if (zero? n)
+      '()
+      (cons n (mklist (sub1 n)))))
+
+(define (nth l n)
+  (if (zero? n)
+      (car l)
+      (nth (cdr l) (sub1 n))))
+
+
+; Takes an atom and a list and returns the position of the atom in the list
+(define list-pos
+  (lambda (a l)
+    (recur loop ([l l][i 0])
+      (cond                               
+       [(null? l) #f]
+       [(eqv? a (car l)) i]
+       [else (loop (cdr l) (add1 i))]))))
+
+; Takes an atom and a list and returns the position of the atom in the list
+; uses equal?, returns #f if no match
+(define list-pos-equal
+  (lambda (a l)
+    (recur loop ([l l][n 0])
+      (cond
+       [(null? l) #f]
+       [(equal? a (car l)) n]
+       [else (loop (cdr l) (add1 n))]))))
+
+;; Returns first element in set satisfying a predicate, or #f
+(define (find p l)
+  (recur loop ([l l])
+    (cond
+     [(null? l) #f]
+     [(p (car l)) (car l)]
+     [else (loop (cdr l))])))
+
+

collects/mrspidey/Sba/lib/lib-misc.ss

@@ -0,0 +1,150 @@
+; library-misc.ss
+; ----------------------------------------------------------------------
+; Copyright (C) 1995-97 Cormac Flanagan
+;
+; This program is free software; you can redistribute it and/or
+; modify it under the terms of the GNU General Public License
+; version 2 as published by the Free Software Foundation.
+; 
+; This program is distributed in the hope that it will be useful,
+; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+; GNU General Public License for more details.
+; 
+; You should have received a copy of the GNU General Public License
+; along with this program; if not, write to the Free Software
+; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
+; ----------------------------------------------------------------------
+
+ (define symbol-append
+   (lambda l
+     (string->symbol
+      (apply string-append (map (lambda (x) (#%format "~a" x)) l)))))
+
+ (define (get-cpu-time str thunk)
+   (match-let
+       ([(t . r) (get&return-cpu-time thunk)])
+     (printf "~a ~ss~n" str (/ t 1000.0))
+     r))
+
+ (define (get&return-cpu-time thunk)
+   (let* ([s1 (- (current-process-milliseconds) (current-gc-milliseconds))]
+          [r  (thunk)]
+          [s2 (- (current-process-milliseconds) (current-gc-milliseconds))]
+          [t (- s2 s1)])
+     (cons t r)))
+
+ (define (make-timer) (cons 0 0))
+ (define (clear-timer! c) (set-car! c 0) (set-cdr! c 0))
+
+ (define (record-time timer thunk)
+   (match-let
+       ([(t . r) (get&return-cpu-time (lambda () (call-with-values thunk list)))])
+     (set-car! timer (add1 (car timer)))
+     (set-cdr! timer (+ t (cdr timer)))
+     (apply #%values r)))
+
+ (define (strip-string s c)
+   ;; Strips leading chars off s, up to and including c
+   (recur loop ([s (string->list s)])
+     (cond
+      [(null? s) ""]
+      [(char=? (car s) c) (list->string (cdr s))]
+      [else (loop (cdr s))])))
+
+ ;; pad on left
+ (define padl
+   (lambda (arg n)
+     (let ((s (format "~a" arg)))
+       (recur loop ((s s))
+         (if (< (string-length s) n)
+             (loop (string-append " " s))
+             s)))))
+
+ ;; pad on right
+ (define padr
+   (lambda (arg n)
+     (let ((s (format "~a" arg)))
+       (recur loop ((s s))
+         (if (< (string-length s) n)
+             (loop (string-append s " "))
+             s)))))
+
+ (define chop-number
+   (lambda (x n)
+     (substring (format "~s00000000000000000000" x) 0 (- n 1))))
+
+ ;; Is the first string a substring of the second string?
+ ;; 
+ (define substring?
+   (lambda (s1 s2)
+     (let ([l1 (string-length s1)][l2 (string-length s2)])
+       (let loop ([i 0])
+         (cond
+          [(>= (+ i l1) l2)  #f]
+          [(string=? (substring s2 i (+ i l1)) s1) #t]
+          [else (loop (add1 i))])))))
+
+                                        ; Returns the part of the string after the last slash
+                                        ;
+ (define get-base-name
+   (lambda (filename)
+     (let ([len (string-length filename)])
+       (let loop ([i 0][fname-start 0])
+         (cond
+          [(= i len) (substring filename fname-start len)]
+          [(char=? (string-ref filename i) #\/)
+           (loop (add1 i) (add1 i))]
+          [else (loop (add1 i) fname-start)])))))
+
+                                        ; removes an object fro a list destructively using eqv?
+                                        ;
+(define remv!
+  (lambda (obj l)
+    (let ([head l])
+      (if (eqv? obj (car l))
+        (if (pair? l)
+          (cdr l)
+          '())
+        (let loop ([l l])
+          (cond
+            [(null? l) head]
+            [(null? (cdr l)) head]
+            [(eqv? obj (cadr l))
+              (if (pair? (cdr l))
+                (set-cdr! l (cddr l))
+                (set-cdr! l '()))
+              head]
+            [ else (loop (cdr l))]))))))
+
+                                        ; takes a string, a position (i) and a char and resturns a substring of the characters
+                                        ; from the position to the char
+                                        ;
+(define (char-find str i  char)
+  (apply string 
+         (let loop ([i i])
+           (if (< i (string-length str))
+               (let ([c (string-ref str i)]) 
+                 (if (char=?  c char)
+                     '()
+                     (cons c (loop (add1 i)))))
+               '()))))
+ ;;
+
+(define (file-newer f1 f2)
+  (let ([s1 (file-modify-seconds f1)]
+        [s2 (file-modify-seconds f2)])
+    (and (number? s1) 
+         (number? s2)
+         (> s1 s2))))
+    
+
+;; curried eq?
+
+(define eqc?
+  (lambda (x)
+    (lambda (y)
+      (eq? x y))))
+
+;; ----------------------------------------------------------------------
+

collects/mrspidey/Sba/lib/lib-para.ss

@@ -0,0 +1,71 @@
+;; library-paras.ss
+; ----------------------------------------------------------------------
+; Copyright (C) 1995-97 Cormac Flanagan
+;
+; This program is free software; you can redistribute it and/or
+; modify it under the terms of the GNU General Public License
+; version 2 as published by the Free Software Foundation.
+; 
+; This program is distributed in the hope that it will be useful,
+; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+; GNU General Public License for more details.
+; 
+; You should have received a copy of the GNU General Public License
+; along with this program; if not, write to the Free Software
+; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
+; ----------------------------------------------------------------------
+;; ----------------------------------------------------------------------
+
+(define make-parameter-list
+  (case-lambda
+   [(default list-opt)
+    (make-parameter-list default list-opt 
+                         (lambda (x) (void))
+                         (lambda (x) #f))]
+   [(default list-opt call)
+    (make-parameter-list default list-opt call
+                         (lambda (x) #f))]
+   [(default list-opt call also-ok?)
+    (let* ([list-opt
+            (map
+             (match-lambda
+              [(tag (? string? name) (? string? help)) (list tag name help)]
+              [(tag (? string? name)) (list tag name "")]
+              [(or (tag) (tag "") tag) (list tag (format "~a" tag) "")])
+             list-opt)]
+           [list-tag (map car list-opt)])
+                                        ;(assert (memq default list-tag))
+      (let ([current default])
+        (call current)
+        (match-lambda*
+         [() current]
+         [('?) list-opt]
+         [(x)
+          (unless (or (member x list-tag) (also-ok? x))
+            (error 
+              'parameter
+              "Parameter argument ~s is not one of ~s" x list-tag))
+          (set! current x)
+          (call current)])))]))
+
+(define (make-parameter-boolean x)
+  (make-parameter-list x 
+    (list
+      (list #f "Off" "")
+      (list #t "On" ""))))
+
+'(define (make-parameter-integer x)
+  (make-parameter x
+                  (lambda (x)
+                    (unless (integer? x)
+                      (error 'parameter "Must be an integer"))
+                    x)))
+
+(define (make-parameter-integer x)
+  (unless (integer? x) (error 'parameter "Must be an integer"))
+  (case-lambda
+    [() x]
+    [(y)
+      (unless (integer? y) (error 'parameter "Must be an integer"))
+      (set! x y)]))

collects/mrspidey/Sba/lib/lib-set.ss

@@ -0,0 +1,111 @@
+;; library-set.ss
+; ----------------------------------------------------------------------
+; Copyright (C) 1995-97 Cormac Flanagan
+;
+; This program is free software; you can redistribute it and/or
+; modify it under the terms of the GNU General Public License
+; version 2 as published by the Free Software Foundation.
+; 
+; This program is distributed in the hope that it will be useful,
+; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+; GNU General Public License for more details.
+; 
+; You should have received a copy of the GNU General Public License
+; along with this program; if not, write to the Free Software
+; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
+; ----------------------------------------------------------------------
+;;
+;; Set operations implemented by lists.
+;; Identity of elements is based on eq?.
+;; These should probably be sped up some day.
+;; ----------------------------------------------------------------------
+
+ (define empty-set '())
+
+ (define empty-set? null?)
+
+ ;; construct a set
+ (define set
+   (lambda l
+     (list->set l)))
+
+ ;; construct a set from a list by removing duplicates
+ (define list->set
+   (match-lambda
+    [() '()]
+    [(x . y) (if (memq x y)
+                 (list->set y)
+                 (cons x (list->set y)))]))
+
+ (define list->set-equal?
+   (match-lambda
+    [() '()]
+    [(x . y) (if (member x y)
+                 (list->set y)
+                 (cons x (list->set y)))]))
+
+ ;; test for membership
+ (define element-of?
+   (lambda (x set)
+     (and (memq x set) #t)))
+
+ (define (set-add x set)
+   (if (memq x set) set (cons x set)))
+
+ (define cardinality length)
+
+ ;; does s2 contain s1?
+ (define set<=
+   (lambda (a b)
+     (and (andmap (lambda (x) (memq x b)) a) #t)))
+
+ ;; are two sets equal? (mutually containing)
+ (define set-eq?
+   (lambda (a b)
+     (and (= (cardinality a) (cardinality b)) (set<= a b))))
+
+ ;; unite two sets
+ (define union2
+   (lambda (a b)
+     (if (null? b)
+         a
+         (foldr (lambda (x b)
+                  (if (memq x b)
+                      b
+                      (cons x b)))
+                b
+                a))))
+
+ ;; unite any number of sets
+ (define union
+   (lambda l
+     (foldr union2 '() l)))
+
+ (define setdiff2
+   (lambda (a b)
+     (if (or (null? a) (null? b))
+         a
+       (if (memq (car a) b)
+         (setdiff2 (cdr a) b)
+         (cons (car a) (setdiff2 (cdr a) b))))))
+
+ (define setdiff
+   (lambda l
+     (if (null? l)
+         '()
+         (setdiff2 (car l) (foldr union2 '() (cdr l))))))
+
+ (define intersect2
+   (lambda (a b)
+     (cond [(or (null? a) (null? b)) '()]
+           [(memq (car b) a) (cons (car b) (intersect2 a (cdr b)))]
+           [else (intersect2 a (cdr b))])))
+
+ (define intersect
+   (lambda l
+     (if (null? l)
+         '()
+         (foldl intersect2 (car l) l))))
+
+

collects/mrspidey/Sba/lib/lib-vec.ss

@@ -0,0 +1,106 @@
+;; library-vec.ss
+; ----------------------------------------------------------------------
+; Copyright (C) 1995-97 Cormac Flanagan
+;
+; This program is free software; you can redistribute it and/or
+; modify it under the terms of the GNU General Public License
+; version 2 as published by the Free Software Foundation.
+; 
+; This program is distributed in the hope that it will be useful,
+; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+; GNU General Public License for more details.
+; 
+; You should have received a copy of the GNU General Public License
+; along with this program; if not, write to the Free Software
+; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
+; ----------------------------------------------------------------------
+;; ----------------------------------------------------------------------
+
+(define (vector-copy v)
+  (let* ( [l (vector-length v)]
+          [w (make-vector l)])
+    (for i 0 l (vector-set! w i (vector-ref v i)))
+  w))
+
+;; vector map
+(define vector-map1
+  (lambda (f v)
+    (let* ([l (vector-length v)]
+           [w (make-vector l)])
+      (for i 0 l
+           (vector-set! w i (f (vector-ref v i))))
+      w)))
+
+(define vector-map2
+  (lambda (f v1 v2)
+    (let* ([l (vector-length v1)]
+           [w (make-vector l)])
+      (assert (= l (vector-length v2)))
+      (for i 0 l
+           (vector-set! w i (f (vector-ref v1 i) (vector-ref v2 i))))
+      w)))
+
+(define vector-map
+  (case-lambda
+   [(f v) (vector-map1 f v)]
+   [(f v1 v2) (vector-map2 f v1 v2)]))
+
+;; for-each over a vector, but also pass f a 0-based index
+(define vector-for-each-with-n
+  (lambda (f v)
+    (for i 0 (vector-length v)
+         (f (vector-ref v i) i))))
+
+(define vector-for-each
+  (case-lambda
+    [(f v)
+      (for i 0 (vector-length v)
+        (f (vector-ref v i)))]
+    [(f v1 v2)
+      (assert (= (vector-length v1) (vector-length v2)) 'vector-for-each)
+      (for i 0 (vector-length v1)
+        (f (vector-ref v1 i) (vector-ref v2 i)))]))
+
+(define (vector-andmap1 f v)
+  (let ([l (vector-length v)])
+    (recur loop ([i 0])
+      (or (= i l)
+          (and (f (vector-ref v i)) (loop (add1 i)))))))
+
+(define (vector-andmap2 f v1 v2)
+  (let ([l (vector-length v1)])
+    (assert (= l (vector-length v2)))
+    (recur loop ([i 0])
+      (or (= i l)
+          (and (f (vector-ref v1 i) (vector-ref v2 i))
+               (loop (add1 i)))))))
+
+(define vector-andmap
+  (match-lambda*
+   [(f v) (vector-andmap1 f v)]
+   [(f v1 v2) (vector-andmap2 f v1 v2)]))
+
+
+(define (vector-ormap1 f v)
+  (let ([l (vector-length v)])
+    (recur loop ([i 0])
+      (and (not (= i l))
+           (or (f (vector-ref v i)) (loop (add1 i)))))))
+
+(define (vector-ormap2 f v1 v2)
+  (let ([l (vector-length v1)])
+    (assert (= l (vector-length v2)))
+    (recur loop ([i 0])
+      (and (not (= i l))
+           (or (f (vector-ref v1 i) (vector-ref v2 i))
+               (loop (add1 i)))))))
+
+(define vector-ormap
+  (match-lambda*
+   [(f v) (vector-ormap1 f v)]
+   [(f v1 v2) (vector-ormap2 f v1 v2)]))
+
+
+(define (vector-zero! p)
+  (for i 0 (vector-length p) (vector-set! p i 'zerod!)))

collects/mrspidey/Sba/lib/main.ss

@@ -0,0 +1,29 @@
+;; Sba/lib/main.ss
+; ----------------------------------------------------------------------
+; Copyright (C) 1995-97 Cormac Flanagan
+;
+; This program is free software; you can redistribute it and/or
+; modify it under the terms of the GNU General Public License
+; version 2 as published by the Free Software Foundation.
+; 
+; This program is distributed in the hope that it will be useful,
+; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+; GNU General Public License for more details.
+; 
+; You should have received a copy of the GNU General Public License
+; along with this program; if not, write to the Free Software
+; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
+; ----------------------------------------------------------------------
+
+;; elaboration-time context:
+;; mrspidey signatures
+
+(unit/sig mrspidey:library^
+  (import mrspidey:interaction^ mzlib:unprefixed-core^)
+  (include "lib-para.ss")
+  (include "lib-list.ss")
+  (include "lib-vec.ss")
+  (include "lib-set.ss")
+  (include "lib-misc.ss")
+  (include "env.ss"))

collects/mrspidey/Sba/link.ss

@@ -0,0 +1,132 @@
+;; link.ss
+; ----------------------------------------------------------------------
+; Copyright (C) 1995-97 Cormac Flanagan
+;
+; This program is free software; you can redistribute it and/or
+; modify it under the terms of the GNU General Public License
+; version 2 as published by the Free Software Foundation.
+; 
+; This program is distributed in the hope that it will be useful,
+; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+; GNU General Public License for more details.
+; 
+; You should have received a copy of the GNU General Public License
+; along with this program; if not, write to the Free Software
+; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
+; ----------------------------------------------------------------------
+
+(define mrspidey:sba@
+  (compound-unit/sig
+    (import
+      (INTERACTION : mrspidey:interaction^)
+      (MZLIB : mzlib:unprefixed-core^)
+      (WX : wx^)
+      )
+    (link
+      [CDL :
+        mrspidey:CDL^ 
+        (mrspidey:CDL@ INTERACTION MZLIB WX)]
+      [ZODIAC :
+        mrspidey:zodiac^
+        (mrspidey:zodiac@ CDL INTERACTION)]        
+      [LOADEXPAND :
+        mrspidey:loadexpand^
+        (mrspidey:loadexpand@ CDL INTERACTION LANGUAGES ZODIAC MZLIB)]
+      [HASH : 
+        mrspidey:hash^
+        (mrspidey:hash@ CDL INTERACTION MZLIB)]
+      [KERNEL :
+        mrspidey:kernel^ 
+        (mrspidey:kernel@ CDL HASH KERNEL-AUX TEMPLATES)]
+      [MIN :
+        mrspidey:min^
+        (mrspidey:all-min@ CDL INTERACTION KERNEL KERNEL-AUX 
+          TEMPLATES MZLIB)]
+      [TEMPLATES :
+        mrspidey:templates^
+        (mrspidey:templates@ CDL INTERACTION KERNEL)]
+      [KERNEL-AUX :
+        mrspidey:kernel-aux^
+        (mrspidey:kernel-aux@ CDL INTERACTION KERNEL TEMPLATES ZODIAC)]
+      [ATYPE :
+        mrspidey:atype^
+        (mrspidey:atype@ CDL INTERACTION KERNEL KERNEL-AUX
+          MIN TYPELANG TEMPLATES
+          TYPE-ENV SDL ATLUNIT MZLIB)]
+      [TYPELANG :
+        mrspidey:typelang^
+        (mrspidey:typelang@ CDL INTERACTION KERNEL KERNEL-AUX
+          TEMPLATES TYPE-ENV ATYPE CONTAINED MZLIB ZODIAC)]
+      [CONTAINED :
+        mrspidey:contained^
+        (mrspidey:contained@ CDL KERNEL SDL)]
+      [TYPE-ENV :
+        mrspidey:type-env^
+        (mrspidey:type-env@ CDL INTERACTION KERNEL KERNEL-AUX
+          TEMPLATES MIN ATYPE ZODIAC)]
+      [SDL :
+        mrspidey:sdl^ 
+        (mrspidey:sdl@ 
+          CDL KERNEL MIN TYPELANG KERNEL-AUX TEMPLATES ATYPE
+          MZLIB)]
+      [LANGUAGES :
+        mrspidey:languages^
+        (mrspidey:languages@ CDL INTERACTION KERNEL
+          TEMPLATES KERNEL-AUX 
+          ATYPE TYPE-ENV TYPELANG ATENV LOADEXPAND TRAVERSE
+          MZLIB ZODIAC )]
+      [ATENV :
+        mrspidey:atenv^
+        (mrspidey:atenv@ CDL INTERACTION KERNEL KERNEL-AUX ATYPE
+          ZODIAC MZLIB)]
+      [TRAVERSE :
+        mrspidey:traverse^
+        (mrspidey:traverse@ CDL INTERACTION KERNEL MIN
+          LOADEXPAND
+          TEMPLATES KERNEL-AUX TYPELANG TYPE-ENV
+          LANGUAGES ATYPE ATLUNIT ATENV
+          ZODIAC MZLIB)]
+      [ATLUNIT :
+        mrspidey:atlunit^
+        (mrspidey:atlunit@ CDL INTERACTION KERNEL KERNEL-AUX
+          MIN LOADEXPAND TYPE-ENV
+          TEMPLATES LANGUAGES ATYPE ATENV TRAVERSE
+          ZA ZODIAC MZLIB WX)]
+      [ZA :
+        mrspidey:za^ 
+        (mrspidey:za@ CDL INTERACTION KERNEL TEMPLATES 
+          TYPE-ENV TYPELANG ATYPE MZLIB)]
+      [PROGRAM :
+        mrspidey:program^
+        (mrspidey:program@ CDL INTERACTION 
+          KERNEL KERNEL-AUX TYPE-ENV
+          LOADEXPAND TRAVERSE
+          TEMPLATES ATENV ATYPE LANGUAGES
+          ZODIAC MZLIB)]
+      [CHECKS :
+        mrspidey:calc-checks^
+        (mrspidey:calc-checks@ CDL INTERACTION LOADEXPAND 
+          KERNEL KERNEL-AUX
+          TYPELANG TEMPLATES ATYPE SDL
+          ZODIAC MZLIB)]
+      [DRIVER :
+        mrspidey:driver^
+        (mrspidey:driver@ CDL INTERACTION KERNEL
+          TEMPLATES TYPELANG TYPE-ENV ATYPE ATENV
+          PROGRAM CHECKS LANGUAGES ZODIAC)]
+      [HYPER :
+        mrspidey:hyper^
+        (mrspidey:hyper@ CDL INTERACTION LOADEXPAND
+          PROGRAM CHECKS TEMPLATES KERNEL KERNEL-AUX ATYPE MZLIB)]
+      )
+    (export 
+      (open DRIVER)
+      (open CDL)
+      (open ATYPE)
+      (open HYPER)
+      (open KERNEL)
+      (open CHECKS)
+      (open LANGUAGES)
+      (unit ZODIAC zodiac))))
+

collects/mrspidey/Sba/load.ss

@@ -0,0 +1,92 @@
+;; Sba/load.ss
+;; Loads analysis, assumes zodiac, ../aux.ss, ../macros.ss already loaded
+; ----------------------------------------------------------------------
+; Copyright (C) 1995-97 Cormac Flanagan
+;
+; This program is free software; you can redistribute it and/or
+; modify it under the terms of the GNU General Public License
+; version 2 as published by the Free Software Foundation.
+; 
+; This program is distributed in the hope that it will be useful,
+; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+; GNU General Public License for more details.
+; 
+; You should have received a copy of the GNU General Public License
+; along with this program; if not, write to the Free Software
+; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
+; ----------------------------------------------------------------------
+
+(load-relative "sigs.ss")
+
+;; ----------------------------------------------------------------------
+;; Library stuff
+
+(load-relative (build-path "lib" "lib-para.ss"))
+(load-relative (build-path "lib" "lib-list.ss"))
+(load-relative (build-path "lib" "lib-vec.ss"))
+(load-relative (build-path "lib" "lib-set.ss"))
+(load-relative (build-path "lib" "lib-misc.ss"))
+(load-relative (build-path "lib" "env.ss"))
+(load-relative "config.ss")
+(load-relative "debug.ss")
+
+;; ----------------------------------------------------------------------
+;; Extended Zodiac
+
+(load-relative "zod-extra.ss")
+(invoke-open-unit/sig
+ mrspidey:zodiac@ 
+ zodiac
+ mrspidey:CDL^ mrspidey:interaction^)
+
+;; ---------------------------------------------------------------------
+;; Front End Stuff
+
+(load-relative "ldexpand.ss")
+
+;; ======================================================================
+;; Kernel stuff
+
+(load-relative "hash.ss")
+(load-relative "kernel.ss")
+(load-relative (build-path "min" "min.ss"))
+(load-relative (build-path "min" "nonempty.ss"))
+(load-relative (build-path "min" "min-live.ss"))
+(load-relative (build-path "min" "livefewe.ss"))
+(load-relative (build-path "min" "hopcroft.ss"))
+(load-relative (build-path "min" "min-dfa.ss"))
+
+;; ----------------------------------------------------------------------
+;; top level stuff
+
+(load-relative "template.ss")
+(load-relative "kern-aux.ss")
+(load-relative "typelang.ss")
+(load-relative "contain.ss")
+(load-relative "type-env.ss")
+(load-relative "sdl.ss")
+(load-relative "language.ss")
+
+;; ----------------------------------------------------------------------
+;; Traversal
+
+(load-relative "atype.ss")
+(load-relative "atenv.ss")
+(load-relative "atlunit.ss")
+(load-relative "traverse.ss")
+
+;; ----------------------------------------------------------------------
+
+(load-relative "za.ss")
+(load-relative "program.ss")
+(load-relative "checks.ss")
+(load-relative "driver.ss")
+(load-relative "results.ss")
+
+;; ----------------------------------------------------------------------
+
+(define (t) (st: "../test/t.ss"))
+;(load "test-sba.ss")
+;(load "devel.ss")
+;(load "poly.ss")

collects/mrspidey/Sba/loadu.ss

@@ -0,0 +1,489 @@
+;; sba-unit.ss
+;; Defines all the units in SBA
+;; ----------------------------------------------------------------------
+;; elaboration-time context:
+;; sparams.ss Spidey/Code/macros.ss 
+
+(load-relative "sigs.ss")
+
+;; ----------------------------------------------------------------------
+;; Library
+
+(define mrspidey:library@ 
+  (reference (build-path "lib" "main.ss")))
+
+;; ----------------------------------------------------------------------
+
+(define mrspidey:config@
+  (unit/sig mrspidey:config^
+    (import mrspidey:library^ mzlib:unprefixed-core^ [wx : wx^])
+    (include "config.ss")))
+
+(define mrspidey:debugging@
+  (unit/sig mrspidey:debugging^
+    (import
+      mrspidey:library^
+      mzlib:unprefixed-core^)
+    (include "debug.ss")))
+
+(define mrspidey:CDL@
+  (compound-unit/sig
+    (import 
+      (I : mrspidey:interaction^)
+      (MZLIB : mzlib:unprefixed-core^)
+      (WX : wx^))
+    (link
+      [L :
+        mrspidey:library^
+        (mrspidey:library@ I MZLIB)]
+      [C :
+        mrspidey:config^
+        (mrspidey:config@ L MZLIB WX)]
+      [D : 
+        mrspidey:debugging^
+        (mrspidey:debugging@ L MZLIB)])
+    (export (open C) (open D) (open L))))
+
+;; ---------------------------------------------------------------------
+;; Front End Stuff
+
+(define mrspidey:loadexpand@
+  (unit/sig mrspidey:loadexpand^
+    (import
+      mrspidey:CDL^
+      mrspidey:interaction^
+      mrspidey:languages^
+      (zodiac : mrspidey:zodiac^)
+      mzlib:unprefixed-core^)
+    (include "ldexpand.ss")))
+
+;; ======================================================================
+;; Kernel stuff
+
+(define mrspidey:hash@
+  (unit/sig mrspidey:hash^
+    (import
+      mrspidey:CDL^
+      mrspidey:interaction^
+      mzlib:unprefixed-core^)
+    (include "hash.ss")))
+
+(define mrspidey:kernel@
+  (unit/sig mrspidey:kernel^
+    (import
+      mrspidey:CDL^
+      mrspidey:hash^
+      mrspidey:kernel-aux^
+      mrspidey:templates^)
+    (include "kernel.ss")))
+
+;; ----------------------------------------------------------------------
+;; Minimization
+
+(define mrspidey:min-live@
+  (unit/sig
+    mrspidey:min-live^
+    (import
+      mrspidey:CDL^
+      mrspidey:kernel^
+      mrspidey:kernel-aux^
+      mrspidey:min^
+      mrspidey:templates^)
+    (include (begin-elaboration-time (build-path "min" "min-live.ss")))))
+
+(define mrspidey:find-nonempty-tvars@
+  (unit/sig
+    mrspidey:find-nonempty-tvars^
+    (import
+      mrspidey:CDL^
+      mrspidey:kernel^
+      mrspidey:kernel-aux^
+      mrspidey:min-live^
+      mrspidey:templates^)
+    (include (begin-elaboration-time (build-path "min" "nonempty.ss")))))
+
+(define mrspidey:min-live-few-e@
+  (unit/sig
+    mrspidey:min-live-few-e^
+    (import
+      mrspidey:CDL^
+      mrspidey:kernel^
+      mrspidey:kernel-aux^
+      mrspidey:min^
+      mrspidey:min-live^)
+    (include (begin-elaboration-time (build-path "min" "livefewe.ss")))))
+
+(define mrspidey:hopcroft@
+  (unit/sig
+    mrspidey:hopcroft^
+    (import
+      mrspidey:CDL^
+      mzlib:unprefixed-core^
+      mrspidey:min^)
+    (include (begin-elaboration-time (build-path "min" "hopcroft.ss")))))
+
+'(define-signature mrspidey:min-dfa^ (minimize-constraints-dfa-min))
+'(mrspidey:load-unit "min/" min-dfa-old ( mrspidey:CDL^
+                                          mrspidey:kernel^
+                                          mrspidey:kernel-aux^
+                                          mrspidey:min^
+                                          mrspidey:find-nonempty-tvars^
+                                          mrspidey:min-live^
+                                          mrspidey:hopcroft^))
+
+'(define-signature mrspidey:min-dfa-inv^ (minimize-constraints-dfa-min-inv))
+'(mrspidey:load-unit "min/" min-dfa-inv ( mrspidey:CDL^
+                                         mrspidey:kernel^
+                                         mrspidey:kernel-aux^
+                                         mrspidey:min^
+                                         mrspidey:min-live^
+                                         mrspidey:hopcroft^))
+
+'(define-signature mrspidey:min-dfa-strange ( minimize-constraints-dfa-min-1 
+                                             minimize-constraints-dfa-min-2))
+'(mrspidey:load-unit "min/" min-dfa-strange ( mrspidey:CDL^
+                                             mrspidey:kernel^
+                                             mrspidey:kernel-aux^
+                                             mrspidey:min-live^
+                                             mrspidey:hopcroft^))
+
+(define mrspidey:min-dfa-fast@
+  (unit/sig
+    mrspidey:min-dfa-fast^
+    (import
+      mrspidey:CDL^
+      mrspidey:kernel^
+      mrspidey:kernel-aux^
+      mrspidey:min^
+      mrspidey:min-live^
+      mrspidey:min-live-few-e^
+      mrspidey:hopcroft^)
+    (include (begin-elaboration-time (build-path "min" "min-dfa.ss")))))
+
+(define mrspidey:min@
+  (unit/sig
+    mrspidey:min^
+    (import
+      mrspidey:CDL^
+      mrspidey:interaction^
+      mrspidey:kernel^
+      mrspidey:find-nonempty-tvars^
+      mrspidey:min-live^
+      mrspidey:min-live-few-e^
+                                        ;mrspidey:min-dfa^
+                                        ;mrspidey:min-dfa-inv^
+                                        ;mrspidey:min-dfa-strange^
+      mrspidey:min-dfa-fast^
+      )
+    (include (begin-elaboration-time (build-path "min" "min.ss")))
+    (define minimize-constraints-dfa-min 1)
+    (define minimize-constraints-dfa-min-inv 1)
+    (define minimize-constraints-dfa-min-1 1)
+    (define minimize-constraints-dfa-min-2 1)
+    (define min-table 1)
+    ))
+
+(define mrspidey:all-min@
+  (compound-unit/sig
+    (import
+      (CDL : mrspidey:CDL^)
+      (INTERACTION : mrspidey:interaction^)
+      (KERNEL : mrspidey:kernel^)
+      (KERNEL-AUX : mrspidey:kernel-aux^)
+      (TEMPLATES : mrspidey:templates^)
+      (MZLIB : mzlib:unprefixed-core^)
+      )
+    (link
+      [MIN : mrspidey:min^ 
+        (mrspidey:min@ CDL INTERACTION KERNEL 
+          FIND LIVE FEW FAST)]
+      [FIND : mrspidey:find-nonempty-tvars^
+        (mrspidey:find-nonempty-tvars@ CDL KERNEL KERNEL-AUX LIVE TEMPLATES)]
+      [LIVE : mrspidey:min-live^
+        (mrspidey:min-live@ CDL KERNEL KERNEL-AUX MIN TEMPLATES)]
+      [FEW : mrspidey:min-live-few-e^
+        (mrspidey:min-live-few-e@ CDL KERNEL KERNEL-AUX MIN LIVE)]
+      [HOPCROFT : mrspidey:hopcroft^
+        (mrspidey:hopcroft@ CDL MZLIB MIN)]
+      ;;[DFA : mrspidey:min-dfa^
+      ;;  (mrspidey:min-dfa@ CDL KERNEL KERNEL-AUX LIVE HOPCROFT)]
+      ;;[INV : mrspidey:min-dfa-inv^
+      ;;  (mrspidey:min-dfa-inv@ CDL KERNEL KERNEL-AUX LIVE HOPCROFT)]
+      ;;[STRANGE : mrspidey:min-dfa-strange^
+      ;;  (mrspidey:min-dfa-strange^@ CDL KERNEL KERNEL-AUX LIVE HOPCROFT)]
+      [FAST : mrspidey:min-dfa-fast^
+        (mrspidey:min-dfa-fast@ CDL KERNEL KERNEL-AUX MIN LIVE FEW HOPCROFT)])
+    (export (open MIN))))
+
+;; ----------------------------------------------------------------------
+;; top level stuff
+
+(define mrspidey:templates@
+  (unit/sig
+    mrspidey:templates^
+    (import
+      mrspidey:CDL^
+      mrspidey:interaction^
+      mrspidey:kernel^)
+    (include "template.ss")))
+
+(define mrspidey:kernel-aux@
+  (unit/sig
+    mrspidey:kernel-aux^
+    (import
+      mrspidey:CDL^
+      mrspidey:interaction^
+      mrspidey:kernel^
+      mrspidey:templates^
+      (zodiac : mrspidey:zodiac^))
+    (include "kern-aux.ss")))
+
+(define mrspidey:typelang@
+  (unit/sig
+    mrspidey:typelang^
+    (import
+      mrspidey:CDL^
+      mrspidey:interaction^
+      mrspidey:kernel^
+      mrspidey:kernel-aux^
+      mrspidey:templates^
+      mrspidey:type-env^
+      mrspidey:atype^
+      mrspidey:contained^
+      mzlib:unprefixed-core^
+      (zodiac : mrspidey:zodiac^))
+    (include "typelang.ss")))
+
+(define mrspidey:contained@
+  (unit/sig
+    mrspidey:contained^
+    (import
+      mrspidey:CDL^
+      mrspidey:kernel^
+      mrspidey:sdl^)
+    (include "contain.ss")))
+
+(define mrspidey:type-env@
+  (unit/sig
+    mrspidey:type-env^
+    (import
+      mrspidey:CDL^
+      mrspidey:interaction^
+      mrspidey:kernel^
+      mrspidey:kernel-aux^
+      mrspidey:templates^
+      mrspidey:min^
+      mrspidey:atype^
+      (zodiac : mrspidey:zodiac^))
+    (include "type-env.ss")))
+
+(define mrspidey:sdl@
+  (unit/sig
+    mrspidey:sdl^
+    (import
+      mrspidey:CDL^
+      mrspidey:kernel^
+      mrspidey:min^
+      mrspidey:typelang^
+      mrspidey:kernel-aux^
+      mrspidey:templates^
+      mrspidey:atype^
+      mzlib:unprefixed-core^)
+    (include "sdl.ss")))
+
+(define mrspidey:languages@
+  (unit/sig
+    mrspidey:languages^
+    (import
+      mrspidey:CDL^
+      mrspidey:interaction^
+      mrspidey:kernel^
+      mrspidey:templates^
+      mrspidey:kernel-aux^
+      mrspidey:atype^
+      mrspidey:type-env^
+      mrspidey:typelang^
+      mrspidey:atenv^
+      mrspidey:loadexpand^
+      mrspidey:traverse^
+      mzlib:unprefixed-core^
+      (zodiac : mrspidey:zodiac^))
+    (include "language.ss")))
+
+(define mrspidey:za@
+  (unit/sig
+    mrspidey:za^
+    (import
+      mrspidey:CDL^
+      mrspidey:interaction^
+      mrspidey:kernel^
+      mrspidey:templates^
+      mrspidey:type-env^
+      mrspidey:typelang^
+      mrspidey:atype^
+      mzlib:unprefixed-core^)
+    (include "za.ss")))
+
+;; ----------------------------------------------------------------------
+;; Traversal
+
+(define mrspidey:atype@
+  (unit/sig
+    mrspidey:atype^
+    (import
+      mrspidey:CDL^
+      mrspidey:interaction^
+      mrspidey:kernel^
+      mrspidey:kernel-aux^
+      mrspidey:min^
+      mrspidey:typelang^
+      mrspidey:templates^
+      mrspidey:type-env^
+      mrspidey:sdl^
+      mrspidey:atlunit^
+      mzlib:unprefixed-core^)
+    (include "atype.ss")))
+
+(define mrspidey:atenv@
+  (unit/sig
+    mrspidey:atenv^
+    (import
+      mrspidey:CDL^
+      mrspidey:interaction^
+      mrspidey:kernel^
+      mrspidey:kernel-aux^
+      mrspidey:atype^
+      (zodiac : mrspidey:zodiac^)
+      mzlib:unprefixed-core^)
+    (include "atenv.ss")))
+
+(define mrspidey:atlunit@
+  (unit/sig
+    mrspidey:atlunit^
+    (import
+      mrspidey:CDL^
+      mrspidey:interaction^
+      mrspidey:kernel^
+      mrspidey:kernel-aux^
+      mrspidey:min^
+      mrspidey:loadexpand^
+      mrspidey:type-env^
+      mrspidey:templates^
+      mrspidey:languages^
+      mrspidey:atype^
+      mrspidey:atenv^
+      mrspidey:traverse^
+      mrspidey:za^
+      (zodiac : mrspidey:zodiac^)
+      mzlib:unprefixed-core^
+      [wx : wx^])
+    (include "atlunit.ss")))
+
+(define mrspidey:traverse@
+  (unit/sig
+    mrspidey:traverse^
+    (import
+      mrspidey:CDL^
+      mrspidey:interaction^
+      mrspidey:kernel^
+      mrspidey:min^
+      mrspidey:loadexpand^
+      mrspidey:templates^
+      mrspidey:kernel-aux^
+      mrspidey:typelang^
+      mrspidey:type-env^
+      mrspidey:languages^
+      mrspidey:atype^
+      mrspidey:atlunit^
+      mrspidey:atenv^
+      (zodiac : mrspidey:zodiac^)
+      mzlib:unprefixed-core^)
+    (include "traverse.ss")))
+
+;; ----------------------------------------------------------------------
+
+(define mrspidey:program@
+  (unit/sig
+    mrspidey:program^
+    (import
+      mrspidey:CDL^
+      mrspidey:interaction^
+      mrspidey:kernel^
+      mrspidey:kernel-aux^
+      mrspidey:type-env^
+      mrspidey:loadexpand^
+      mrspidey:traverse^
+      mrspidey:templates^
+      mrspidey:atenv^
+      mrspidey:atype^
+      mrspidey:languages^
+      (zodiac : mrspidey:zodiac^)
+      mzlib:unprefixed-core^)
+    (include "program.ss")))
+
+(define mrspidey:calc-checks@
+  (unit/sig
+    mrspidey:calc-checks^
+    (import
+      mrspidey:CDL^
+      mrspidey:interaction^
+      mrspidey:loadexpand^
+      mrspidey:kernel^
+      mrspidey:kernel-aux^
+      mrspidey:typelang^
+      mrspidey:templates^
+      mrspidey:atype^
+      mrspidey:sdl^
+      (zodiac : mrspidey:zodiac^)
+      mzlib:unprefixed-core^)
+    (include "checks.ss")))
+
+(define mrspidey:driver@
+  (unit/sig
+    mrspidey:driver^
+    (import
+      mrspidey:CDL^
+      mrspidey:interaction^
+      mrspidey:kernel^
+      mrspidey:templates^
+      mrspidey:typelang^
+      mrspidey:type-env^
+      mrspidey:atype^
+      mrspidey:atenv^
+      mrspidey:program^
+      mrspidey:calc-checks^
+      mrspidey:languages^
+      (zodiac : mrspidey:zodiac^))
+    (include "driver.ss")))
+
+(define mrspidey:hyper@
+  (unit/sig
+    mrspidey:hyper^
+    (import
+      mrspidey:CDL^
+      mrspidey:interaction^
+      mrspidey:loadexpand^
+      mrspidey:program^
+      mrspidey:calc-checks^
+      mrspidey:templates^
+      mrspidey:kernel^
+      mrspidey:kernel-aux^
+      mrspidey:atype^
+      mzlib:unprefixed-core^)
+    (include "hyper.ss")))
+
+(load-relative "zod-extra.ss")
+
+;; ----------------------------------------------------------------------
+;; Put it all together
+
+(load-relative "link.ss")
+
+;; ----------------------------------------------------------------------
+
+
+
+
+
+
+

collects/mrspidey/Sba/make-exn-hierarchy.ss

@@ -0,0 +1,35 @@
+
+(define src "/home/mflatt/proj/mred/mzscheme/src/exnsrc.ss")
+(define dest "/home/cormac/plt/mrspidey/Sba/exn-hierarchy.ss")
+(when (file-exists? dest) (delete-file dest))
+
+(with-input-from-file src
+  (lambda ()
+    (let ([x (read)])
+      (with-output-to-file dest
+        (lambda ()
+          (letrec
+            ([trav
+               (lambda (tree parent)
+                 (match tree
+                   [(name fields+strings . subtrees)
+                     (let* ( [fields (filter symbol? fields+strings)]
+                             [s (symbol->string name)]
+                             [name (if (memq (string-ref s 0) '(#\* #\+))
+                                     (string->symbol
+                                       (substring s 1 (string-length s)))
+                                     name)]
+                             [name (if parent (symbol-append parent ': name) name)])
+                       (display 
+                         `(define-struct
+                            ,(if parent 
+                               `(,name ,(symbol-append 'struct: parent))
+                               name)
+                            ,fields))
+                       (newline)
+                       (for-each
+                         (lambda (subtree) (trav subtree name))
+                         subtrees))]
+                   ['- (void)]
+                   [(? string?) (void)]))])
+            (trav x #f)))))))

collects/mrspidey/Sba/min/hopcroft.ss

@@ -0,0 +1,246 @@
+;; dfa-min.ss
+; ----------------------------------------------------------------------
+; Copyright (C) 1995-97 Cormac Flanagan
+;
+; This program is free software; you can redistribute it and/or
+; modify it under the terms of the GNU General Public License
+; version 2 as published by the Free Software Foundation.
+; 
+; This program is distributed in the hope that it will be useful,
+; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+; GNU General Public License for more details.
+; 
+; You should have received a copy of the GNU General Public License
+; along with this program; if not, write to the Free Software
+; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
+; ----------------------------------------------------------------------
+;; ======================================================================
+;; CHANGES
+;; 01.11.96: Commented out hack to put all partitions on worklist initially
+;; ======================================================================
+
+(define-typed-structure state-aux (eqvcl prev next touched))
+(define-typed-structure dfa-eqvcl (states count on-worklist touched))
+
+;(define inv-delta-traversal-timer (make-timer))
+;(define Fn-a-timer     (make-timer))
+;(define finish-a-timer (make-timer))
+
+;; ======================================================================
+
+(define (Hopcroft-calc-equivalences States seperate
+                                    inv-delta-traversal
+                                    state-aux set-state-aux! state->rep)
+
+  ;; states must have an aux field with set-state-aux! and state-aux fns
+  ;; seperate is a list of list of States
+  ;; any partition must be included in some element of seperate
+  
+  ;; inv-delta-traversal: P(states) (Sigma P(states) -> void) -> void
+  ;; inv-delta-traversal(X, Fn)
+  ;; => Fn is called with all pairs (a,C) where C = { s | delta(s,sigma) in X}
+
+  (pretty-debug-dfa-min 
+   `(States ,(map state->rep States)))
+  (pretty-debug-dfa-min
+   `(seperate ,(map (lambda (c) (map state->rep c)) seperate)))
+
+  (for-each 
+   (lambda (s) (set-state-aux! s (make-state-aux (void) (void) (void) #f)))
+   States)
+  
+  (for-each
+   (lambda (c)
+     (for-each
+       (lambda (s) (assert (state-aux? (state-aux s)) 1 (state->rep s)))
+       c))
+   seperate)
+
+  (let* 
+      ( [t (lambda (s) 
+          (when timing-min (min-record-progress (cons 'hopcroft s))))]
+        [_ (t 0)]
+        [state-prev  (lambda (s) (state-aux-prev  (state-aux s)))]
+        [state-next  (lambda (s) (state-aux-next  (state-aux s)))]
+        [state-eqvcl (lambda (s) (state-aux-eqvcl (state-aux s)))]
+        [state-touched (lambda (s) (state-aux-touched (state-aux s)))]
+        [set-state-prev! (lambda (s p) (set-state-aux-prev!  (state-aux s) p))]
+        [set-state-next! (lambda (s p) (set-state-aux-next!  (state-aux s) p))]
+        [set-state-eqvcl! (lambda (s p) (set-state-aux-eqvcl! (state-aux s) p))]
+        [set-state-touched! 
+          (lambda (s p) (set-state-aux-touched! (state-aux s) p))]
+
+        [partition '()]
+        [mk-empty-eqvcl 
+          (lambda () 
+            (let ([X (make-dfa-eqvcl '() 0 #f '())])
+              (set! partition (cons X partition))
+              X))]
+
+        [add-to-eqvcl!
+          (lambda (X s)
+            (let ([first (dfa-eqvcl-states X)])
+              (set-state-next! s first)
+              (unless (null? first) (set-state-prev! first s))
+              (set-dfa-eqvcl-states! X s)
+              (set-state-prev! s X)
+              (set-state-eqvcl! s X)
+              (set-dfa-eqvcl-count! X (add1 (dfa-eqvcl-count X)))))]
+        [remove-from-eqvcl!
+          (lambda (X s)
+            (assert (eq? (state-eqvcl s) X))
+            (let ([prev (state-prev s)]
+                   [next (state-next s)])
+              (unless (null? next) (set-state-prev! next prev))
+              (if (dfa-eqvcl? prev)
+                (set-dfa-eqvcl-states! prev next)
+                (set-state-next! prev next))
+              (set-dfa-eqvcl-count! X (sub1 (dfa-eqvcl-count X)))))]
+        [eqvcl->list
+          (lambda (c)
+            (recur loop ([state (dfa-eqvcl-states c)])
+              (if (null? state)
+                '()
+                (cons state (loop (state-next state))))))]
+
+        [worklist '()]
+        [add-to-worklist!
+          (lambda (X)
+            (assert (not (dfa-eqvcl-on-worklist X)))
+            (set! worklist (cons X worklist))
+            (set-dfa-eqvcl-on-worklist! X #t))]
+
+        [split
+          (lambda (generate-split-states)
+
+            ;; Change so each partition totally included or excluded in states
+            ;; See Cliff Click's thesis, page ~40.
+             
+            (pretty-debug-dfa-min `(split))
+ 
+            (let* ([touched '()])
+              (begin0
+                (generate-split-states
+                  (lambda (s)
+                    (pretty-debug-dfa-min
+                      `(add-split ,(state->rep s) ,(state-aux s)))
+                    (assert (state-aux? (state-aux s))
+                      2 (state->rep s) (state-aux s))
+                    (let* ([s-eqvcl (state-eqvcl s)])
+                      (when (null? (dfa-eqvcl-touched s-eqvcl))
+                        (set! touched (cons s-eqvcl touched))
+                        (assert (not (state-touched s))))
+                      (unless (state-touched s)
+                        ;;(assert (not (memq s (dfa-eqvcl-touched s-eqvcl))))
+                        (set-dfa-eqvcl-touched!
+                          s-eqvcl 
+                          (cons s (dfa-eqvcl-touched s-eqvcl)))
+                        (set-state-touched! s #t)))))
+                (for-each
+                  (lambda (Z)    
+
+                    (pretty-debug-dfa-min
+                      `(touched
+                         ,(map state->rep (eqvcl->list Z))
+                         ,(map state->rep (dfa-eqvcl-touched Z))
+                         ,(= (dfa-eqvcl-count Z) 
+                            (length (dfa-eqvcl-touched Z)))))
+                    (if (= (dfa-eqvcl-count Z) 
+                          (length (dfa-eqvcl-touched Z)))
+
+                      ;; No need to change, just clear touched
+                      (for-each (lambda (s) (set-state-touched! s #f))
+                        (dfa-eqvcl-touched Z))
+
+                      ;; Need to make new eqvcl 
+                      (let ([nu (mk-empty-eqvcl)])
+                        ;;(printf ".") (flush-output)
+                        (for-each
+                          (lambda (s) 
+                            (remove-from-eqvcl! Z s)
+                            (set-state-touched! s #f)
+                            (add-to-eqvcl! nu s))
+                          (dfa-eqvcl-touched Z))
+                        (assert (not (null? (dfa-eqvcl-states Z))))
+                        (assert (not (null? (dfa-eqvcl-states nu))))
+                        (cond
+                          [(dfa-eqvcl-on-worklist Z)
+                            (add-to-worklist! nu)]
+                          [(< (dfa-eqvcl-count nu) (dfa-eqvcl-count Z))
+                            (add-to-worklist! nu)
+                            ;; Kludge cause not complete grammar
+                            (add-to-worklist! Z)
+                            ]
+                          [else
+                            (add-to-worklist! Z)
+                            ;; Kludge cause not complete grammar
+                            (add-to-worklist! nu)
+                            ])))
+                    (set-dfa-eqvcl-touched! Z '()))
+                  touched))))])
+
+    (t 1)
+    (let ([base-eqvcl (mk-empty-eqvcl)])
+      (for-each (lambda (s) (add-to-eqvcl! base-eqvcl s))
+                States))
+
+    (t 2)
+    (for-each
+      (lambda (nts) (split (lambda (add-split!) (for-each add-split! nts))))
+      seperate)
+
+    
+    (t 3)
+    ;; ### HACK ###
+    ;; Put all partitions on the worklist 
+    '(for-each
+       (lambda (eqvcl)
+         (unless (dfa-eqvcl-on-worklist eqvcl)
+           (add-to-worklist! eqvcl)))
+       partition)
+    ;; ### END HACK ###
+
+    (t 4)
+    (recur loop ()
+      ;; partition a partition of States union Final
+      ;; All equiv states in same eqvcl
+      ;; If s1,s2 in eqvcl B with si->a.si', and si' in Bi
+      ;; then either B1=B2, or (Bi,a) in worklist for one of i=1,2
+
+      (unless (null? worklist)
+        (let* ([X (car worklist)])
+          (set! worklist (cdr worklist))
+          (set-dfa-eqvcl-on-worklist! X #f)
+          (inv-delta-traversal (eqvcl->list X) split)
+          (loop))))
+    (t 5)
+
+    ;; All done
+    ;; Return mapping from states to representative states,
+    ;; and a mapping from states to a list of equiv states
+    ;; and an equiv predicate on states
+    ;; and a list of representative states
+
+    (values
+     (lambda (s) (dfa-eqvcl-states (state-eqvcl s)))
+     (lambda (s) (eqvcl->list (state-eqvcl s)))
+     (lambda (s1 s2) (eq? (state-eqvcl s1) (state-eqvcl s2)))
+     (filter-map (lambda (X) 
+                   (let ([rep (dfa-eqvcl-states X)])
+                     (if (null? rep) #f rep)))
+                 partition))))
+
+;; ----------------------------------------------------------------------
+;; Prototypical inputs
+
+'(define-type dfa-state (box void))
+'(MrSpidey-test
+  (calc-equivalences (type: (listof dfa-state))
+                     (type: (listof dfa-state))
+                     (type: (_ (-> (list (dfa-state -> void) (-> void)))
+                               -> void))
+                     unbox
+                     set-box!))
+;(trace calc-equivalences)
+

collects/mrspidey/Sba/min/livefewe.ss

@@ -0,0 +1,215 @@
+;; File: min-live-few-e.ss
+;; Can optimize later when sure only want min-live-few-e-L
+;; ======================================================================
+; ----------------------------------------------------------------------
+; Copyright (C) 1995-97 Cormac Flanagan
+;
+; This program is free software; you can redistribute it and/or
+; modify it under the terms of the GNU General Public License
+; version 2 as published by the Free Software Foundation.
+; 
+; This program is distributed in the hope that it will be useful,
+; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+; GNU General Public License for more details.
+; 
+; You should have received a copy of the GNU General Public License
+; along with this program; if not, write to the Free Software
+; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
+; ----------------------------------------------------------------------
+;; CHANGES:
+;;
+;; (null? (Tvar-constraints tvar)) 
+;; -> (andmap con-filter? (Tvar-constraints tvar))
+;;
+;; rhs-nts not filter w/ live-nt?
+;;
+;; ======================================================================
+(define-typed-structure Tvar-class (parent L-unif U-unif children))
+
+;; tvars is binary tree w/ tvar at leaves 
+
+; ======================================================================
+; minimize-constraints-live-few-e
+;
+; Input:  lower : list Tvar
+;         upper : list Tvar
+
+(define (copy-live-constraints-few-e L-unif U-unif)
+  (lambda (lower upper)
+
+    (pretty-debug-few 
+      `(copy-live-constraints-few-e
+         lower ,(map Tvar-name lower)
+         upper ,(map Tvar-name upper)))
+
+    ;; Calc edgefrom
+    ;; Calculate live Tvar and live NT
+    ;; Only use Tvar-orig-objs
+    ;; Flag NTs with non-epsilon edges
+
+    (let*-vals
+      ( [t (lambda (s) 
+             (when timing-min
+               (min-record-progress (cons 'copy-live-constraints-few-e s))))]
+        [_ (t 0)]
+       
+        ;; --- Calc empty and live
+        ;; not empty == reached
+        [(live-nts live-nt? live-tvars live-tvar? _ _ rhs-nts)
+          (calc-live-tvars-nts lower upper #f)]
+        [_ (t 1)]
+        [_ (pretty-debug-few `(live-nts ,(map nt->sym live-nts)))]
+        [_ (pretty-debug-few `(live-tvars ,(map Tvar-name live-tvars)))]
+        [rhs-nts
+          (lambda (nt)
+            (filter (lambda (x) (or (eq? x #t) (live-nt? x))) (rhs-nts nt)))]
+
+        ;; Now unify to equiv classes.
+        ;; Define AV `a' to be L-unifiable iff 
+        ;;     con(a) = 0     and 
+        ;;     #outedge(a)=1  and
+        ;;     # prods for LaU = 1
+        ;;  But aU -> bU is not counted in rhs-nts(aU)
+        ;;     => require rhs-nts(aU) = 0
+        ;;
+        ;; Define AV `b' to be U-unifiable iff
+        ;;     AV(a) = AV(b) for all predecessors a of b
+        ;;     #inedge(b)<=1  and
+        ;;     # prods for LbL = 1
+        ;;
+        ;; If a <= b and either a L-unif or b U-unif, then unify
+
+        ;; Unify to equivalence classes
+        [(tvar-class set-tvar-class!) (alloc-Tvar-field)]
+        [_ (t 3)]
+        [_ (for-each 
+             (lambda (tvar)
+               (pretty-debug-few `(Tvar ,(Tvar-name tvar)))
+               (let* ([pretty-and
+                        (lambda args
+                          (let ([r (andmap (lambda (x) x) args)])
+                            (pretty-debug-few `((and ,@args) ,r))
+                            r))]
+                       [L-u (pretty-and
+                              L-unif
+                              (andmap
+                                (match-lambda
+                                  [($ con _ _ _ tvar) (not (live-tvar? tvar))]
+                                  [($ con-filter) #t])
+                                (Tvar-constraints tvar))
+                              (let ([out 
+                                      (append
+                                        (filter-map
+                                          (match-lambda
+                                            [($ con) #f]
+                                            [($ con-filter _ _ tvar)
+                                              (and (live-tvar? tvar) tvar)])
+                                          (Tvar-constraints tvar))
+                                        (filter live-tvar? 
+                                          (Tvar-edgeto tvar)))])
+                                (or (null? out) (null? (cdr out))))
+                              (let ([nt (Tvar-U tvar)])
+                                (or (not (live-nt? nt))
+                                  (let ([s (rhs-nts nt)])
+                                    (pretty-debug-few
+                                      `(rhs-nts 
+                                         ,(map
+                                            (lambda (nt)
+                                              (or (eq? nt #t) (nt->sym nt)))
+                                            s)))
+                                    (null? s)
+                                    ;;(or (null? s) (null? (cdr s)))
+                                    )))
+                              ; Ignore lower, upper
+                              ; Already counted in rhs-nts
+                              ;(not (memq tvar lower))
+                              ;(not (memq tvar upper))
+                              )]
+                       [U-u 
+                         (let ( [in (Tvar-edgefrom tvar)])
+                           (pretty-and
+                             U-unif
+                             (or (null? in)
+                               (and (null? (cdr in))
+                                 (<= (length (Tvar-objs tvar))
+                                   (length (Tvar-objs (car in))))))
+                             (let ([nt (Tvar-L tvar)])
+                               (or (not (live-nt? nt))
+                                 (let ([s (rhs-nts nt)])
+                                   (pretty-debug-few
+                                     `(rhs-nts 
+                                        ,(map
+                                           (lambda (nt)
+                                             (or (eq? nt #t) (nt->sym nt)))
+                                           s)))
+                                   (or (null? s) (null? (cdr s)))
+                                   )))
+                                        ;(not (memq tvar lower))
+                                        ;(not (memq tvar upper))
+                             ))])
+                   
+                 (set-tvar-class! tvar (make-Tvar-class #f L-u U-u tvar))))
+             live-tvars)]
+        [_ (t 4)]
+        [get-class
+          (lambda (tvar)
+            (recur loop ([c (tvar-class tvar)])
+              (assert (or (Tvar-class? (Tvar-class-parent c))
+                        (eq? #f (Tvar-class-parent c))))
+              (if (Tvar-class-parent c)
+                (loop (Tvar-class-parent c))
+                c)))]
+        [_ (for-each
+             (lambda (b)
+               (for-each
+                 (lambda (a)
+                   (when (live-tvar? a)
+                     (match (get-class a)
+                       [(and cl-a
+                          ($ Tvar-class _ L-unif-a U-unif-a kids-a))
+                         (assert (eq? (Tvar-class-parent cl-a) #f) 
+                           (Tvar-class-parent cl-a))
+                         (match (get-class b)
+                           [(and cl-b 
+                              ($ Tvar-class _ L-unif-b U-unif-b kids-b))
+                             (pretty-debug-few
+                               `(epsilon ,(Tvar-name a)
+                                  ,(Tvar-name b)
+                                  ,L-unif-a
+                                  ,L-unif-b
+                                  ,U-unif-a
+                                  ,U-unif-b))
+                             (when (or L-unif-a U-unif-b)
+                               ;; Unify
+                               (let ([nu-cl
+                                       (make-Tvar-class #f
+                                         (and L-unif-a L-unif-b)
+                                         (and U-unif-a U-unif-b)
+                                         (cons kids-a kids-b))])
+
+                                 (assert (eq? (Tvar-class-parent cl-a) #f) 2)
+                                 (assert (eq? (Tvar-class-parent cl-b) #f))
+                                 (set-Tvar-class-parent! cl-a nu-cl)
+                                 (set-Tvar-class-parent! cl-b nu-cl)
+                                 (assert (eq? (get-class a) (get-class b)))
+                                 ))])])))
+                 (Tvar-edgefrom b)))
+             live-tvars)]
+        [_ (t 4.5)]
+        )
+      ;; --- Have equiv classes, now copy
+      ;; --- return arguments for copy-constraints-equiv!
+      (values
+        (append lower upper live-tvars)
+        live-tvar?
+        live-nts
+        (lambda (tvar)
+          (recur loop ([k (Tvar-class-children (get-class tvar))][a '()])
+            (if (Tvar? k)
+              (cons k a)
+              (loop (car k) (loop (cdr k) a)))))
+        (lambda (AV) (list AV))))))
+
+;; ======================================================================
+

collects/mrspidey/Sba/min/min-dfa.ss

@@ -0,0 +1,490 @@
+; ======================================================================
+; minimize-constraints-dfa-min-fast
+;
+; Input:  lower : list Tvar
+;         upper : list Tvar
+;
+; see practical.tex
+; ======================================================================
+; ----------------------------------------------------------------------
+; Copyright (C) 1995-97 Cormac Flanagan
+;
+; This program is free software; you can redistribute it and/or
+; modify it under the terms of the GNU General Public License
+; version 2 as published by the Free Software Foundation.
+; 
+; This program is distributed in the hope that it will be useful,
+; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+; GNU General Public License for more details.
+; 
+; You should have received a copy of the GNU General Public License
+; along with this program; if not, write to the Free Software
+; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
+; ----------------------------------------------------------------------
+
+(define (minimize-constraints-dfa-min-fast
+          lower upper 
+          helper-fn)
+
+  (pretty-debug-dfa-min 
+    `(minimize-constraints-dfa-min-fast
+       lower ,(map Tvar-name lower)
+       upper ,(map Tvar-name upper)))
+
+  (let*-vals
+    ([t (lambda (s) 
+          (when timing-min 
+            (min-record-progress 
+              (cons 'minimize-constraints-dfa-min-fast s))))]
+      [_ (t 0)]
+
+      [(live-tvars live-tvar? live-nts tvar->equiv AV->equiv)
+        ((copy-live-constraints-few-e #t #t) lower upper)]
+      [_ (t 1)]
+
+      ;; Figure out representative elements for Tvars,
+      ;; and live AV
+      [(tvar->rep set-tvar-rep!) (alloc-Tvar-field)]
+      [(is-rep? add-rep! get-list-rep) (field->set alloc-Tvar-field)]
+      [(live-AV? set-live-AV! get-live-AVs) (field->set alloc-AV-field)]
+      [_ (for-each
+           (lambda (tvar)
+             (for-each set-live-AV! (get-Tvar-objs tvar))
+             (unless (tvar->rep tvar)
+               (add-rep! tvar)
+               (for-each 
+                 (lambda (eq) (set-tvar-rep! eq tvar))
+                 (tvar->equiv tvar))
+               (assert (tvar->rep tvar))))
+           live-tvars)]
+      [live-AVs (get-live-AVs)]
+      [rep-tvars (get-list-rep)]
+      [_ (t 2)]
+
+      ;; states = rep-tvars + live-AVs + dummy-tvar
+      [dummy-tvar (mk-Tvar 'Grammar-dummy)]
+      [all-states (append rep-tvars (list dummy-tvar) live-AVs)]
+      [state->sym (lambda (state) 
+                    (cond
+                      [(Tvar? state) (Tvar-name state)]
+                      [(AV? state) (AV->rep state)]
+                      [else (error 'state->sym "Bad state ~s" state)]))]
+
+      [grsym-eq?
+        (lambda (g1 g2)
+          ;; (andmap eq? g1 g2)
+          (recur loop ([g1 g1][g2 g2])
+            (if (null? g1)
+              (null? g2)
+              (if (null? g2)
+                #f
+                (and (eq? (car g1) (car g2))
+                  (loop (cdr g1) (cdr g2)))))))]
+
+      ;; mapping from grsyms to numbers
+      [num-grsym 0]
+      [grsym-table '()]
+      [grsym->number
+        (lambda (g1)
+          (or
+            (ormap
+              (match-lambda
+                [(n . g2) (and (grsym-eq? g1 g2) n)]
+                [_ #f])
+              grsym-table)
+            (begin
+              (set! grsym-table (cons (cons num-grsym g1) grsym-table))
+              (begin0
+                num-grsym
+                (set! num-grsym (add1 num-grsym))))))]
+
+      [(tvar-EF-epsilon set-tvar-EF-epsilon!)
+        (alloc-Tvar-field (lambda () '()))]
+      [(tvar-EF set-tvar-EF!)
+        (alloc-Tvar-field (lambda () '()))]
+      [(AV-EF-epsilon set-AV-EF-epsilon!)
+        (alloc-AV-field (lambda () '()))]
+      [(AV-EF set-AV-EF!)
+        (alloc-AV-field (lambda () '()))]
+
+      [add-tvar-EF! 
+        (lambda (tvar g1 s1)
+          (let* ( [tvar (tvar->rep tvar)]
+                  [n1 (grsym->number g1)]
+                  [x (tvar-EF tvar)])
+            (unless (ormap 
+                      (match-lambda [(n2 . s2) (and (= n1 n2) (eq? s1 s2))])
+                      x)
+              (set-tvar-EF! tvar (cons (cons n1 s1) x)))))]
+      [add-AV-EF! 
+        (lambda (AV g1 s1)
+          (let ( [x (AV-EF AV)]
+                 [n1 (grsym->number g1)])
+            (unless (ormap 
+                      (match-lambda [(n2 . s2) (and (= n1 n1) (eq? s1 s2))])
+                      x)
+              (set-AV-EF! AV (cons (cons n1 s1) x)))))]
+      [add-tvar-EF-epsilon!
+        (lambda (tvar s1)
+          (let* ( [tvar (tvar->rep tvar)]
+                  [x (tvar-EF-epsilon tvar)])
+            (unless (memq s1 x)
+              (set-tvar-EF-epsilon! tvar (cons s1 x)))))]
+      [add-AV-EF-epsilon!
+        (lambda (AV s1)
+          (let ([x (AV-EF-epsilon AV)])
+            (unless (memq s1 x)
+              (set-AV-EF-epsilon! AV (cons s1 x)))))]
+      [state-EF-epsilon
+        (lambda (state)
+          (if (AV? state) 
+            (AV-EF-epsilon state)
+            (tvar-EF-epsilon state)))]
+      [state-EF
+        (lambda (state)
+          (if (AV? state) 
+            (AV-EF state)
+            (tvar-EF state)))]
+      [_ (t 2.1)]
+
+      ;; helper-fn sets things up for inv-delta-traversal
+      ;; Sets U field of each state to:
+      ;;     (listof (cons (listof any) state))
+
+      [extra-seperate (helper-fn live-tvars live-tvar? tvar->rep live-AVs
+                        add-tvar-EF! add-tvar-EF-epsilon!
+                        add-AV-EF! add-AV-EF-epsilon!)]
+      [_ (t 3)]
+
+      ;; Show productions
+      [_ (pretty-debug-dfa-min
+           `(productions
+              ,(map 
+                 (lambda (state)
+                   (list (state->sym state)
+                     (map state->sym (state-EF-epsilon state))
+                     (map
+                       (match-lambda [(g . s) (cons g (state->sym s))])
+                       (state-EF state))))
+                 all-states)))]
+
+      ;; Vector of buckets for productions
+      [buckets (make-vector num-grsym '())]
+      [_ (min-record-progress (cons 'num-buckets num-grsym))]
+
+      ;; inv-delta-traversal: 
+      ;;          P(states) x (P(states) -> void) -> void
+      ;; inv-delta-traversal(X, split)
+      ;; => no equiv class partially in X
+      ;; => Call split with each "partition of equiv classes" ...
+      ;; For effeciency, we call split with a "generator" for the set C_a
+      ;; The generator is passed a function add-split!, and then
+      ;; calls add-split! on each state in C_a
+
+      ;; --- Set things up for Hopcrofts Algorithm
+
+      ;; Condition 1, thms hopcroft lub and glb
+      ;; Also, to make up for grammar being "incomplete",
+      ;; seperate states into equiv classes so states in same equiv class
+      ;; have productions on same grammar symbols
+
+      [seperate-grsyms (make-vector num-grsym '())]
+      [seperate-epsilon '()]
+      [_ (for-each
+           (lambda (state)
+             (when (not (null? (state-EF-epsilon state)))
+               (set! seperate-epsilon (cons state seperate-epsilon)))
+             (for-each
+               (match-lambda
+                 [(g . s)
+                   (vector-set! seperate-grsyms g
+                     (cons s (vector-ref seperate-grsyms g)))])
+               (state-EF state)))
+           all-states)]
+      [_ (pretty-debug-dfa-min
+           `(seperate-epsilon ,(map state->sym seperate-epsilon)))]
+      [_ (pretty-debug-dfa-min
+           `(seperate-grsyms 
+              ,(map 
+                 (lambda (s) (map state->sym s))
+                 (vector->list seperate-grsyms))))]
+      [seperate (append
+                  (list rep-tvars)
+                  (list live-AVs)
+                  extra-seperate
+                  ;(map list lower)
+                  ;(map list upper)
+                  (list seperate-epsilon)
+                  (vector->list seperate-grsyms))]
+      [seperate (filter 
+                  (lambda (l) (not (null? l)))
+                  seperate)]
+      [_ (pretty-debug-dfa-min
+           `(seperate ,(map (lambda (s) (map state->sym s)) seperate)))]
+      [_ (t 4)]
+
+      [inv-delta-traversal
+        (lambda (states split)
+          (pretty-debug-dfa-min 
+            `(inv-delta-trav 
+               ,(map (lambda (state)
+                       `(,(state->sym state)
+                          (epsilon 
+                            ,(map state->sym (state-EF-epsilon state)))
+                          ,(map
+                             (match-lambda [(g . s) (cons g (state->sym s))])
+                             (state-EF state))))
+                  states)))
+          ;; Do epsilons
+          (split 
+            (lambda (add-split!)
+              (for-each
+                (lambda (state)
+                  (for-each 
+                    add-split!
+                    (state-EF-epsilon state)))
+                states)))
+
+          ;; Put rest into buckets
+          (let ([bucket-ndxs '()])
+            (for-each
+              (lambda (state)
+                (for-each
+                  (match-lambda
+                    [(n . s)
+                      (let ([old (vector-ref buckets n)])
+                        (vector-set! buckets n (cons s old))
+                        (when (null? old)
+                          (set! bucket-ndxs (cons n bucket-ndxs))))])
+                  (state-EF state)))
+              states)
+            ;; Run thru buckets ...
+            (for-each
+              (lambda (i)
+                (let ([s* (vector-ref buckets i)])
+                  (split (lambda (add-split!) (for-each add-split! s*)))
+                  (vector-set! buckets i '())))
+              bucket-ndxs)))]
+
+      [(state-aux set-state-aux!) (alloc-NT-field)]
+      [(state->rep state->equiv equiv-state? list-rep-states)
+        (Hopcroft-calc-equivalences 
+          all-states
+          seperate
+          inv-delta-traversal
+          state-aux set-state-aux! state->sym)]
+      [_ (t 5)]
+
+      [_ (begin
+           (pretty-debug-dfa-min
+             `(list-rep-state ,(map state->sym list-rep-states)))
+           (pretty-debug-dfa-min
+             `(state->equiv
+                ,(map (lambda (state) 
+                        (map state->sym (state->equiv state)))
+                   list-rep-states))))]
+
+      ;; ----------------------------------------
+      ;; Have equivalence relation on states
+      ;; Combine w/ previous relation on Tvars
+      ;; Convert to equivalence relation on Tvars
+
+      [tvar->equiv
+        (lambda (tvar)
+          (let ([r (apply append (map tvar->equiv (state->equiv tvar)))])
+            (pretty-debug-dfa-min 
+              `(tvar->equiv ,(state->sym tvar) = ,(map state->sym r)))
+            r))]
+
+      [AV->equiv
+        (lambda (x)
+          (pretty-debug-dfa-min `(AV->equiv ,(state->sym x)))
+          (let ([e (state->equiv x)])
+            (pretty-debug-dfa-min 
+              `(AV->equiv ,(state->sym x) = ,(map state->sym e)))
+            e))]
+      [_ (t 6)])
+
+    (copy-constraints-equiv!
+      live-tvars
+      live-tvar?
+      live-nts
+      tvar->equiv
+      AV->equiv)))
+
+;; ======================================================================
+
+(define (minimize-constraints-dfa-min-lub lower upper)
+  (minimize-constraints-dfa-min-fast lower upper 
+
+    ;; helper-fn
+    ;; helper-fn sets things up for inv-delta-traversal
+    ;; Sets U field of each state to:
+    ;;     (listof (cons (listof any) state))
+
+    (lambda (live-tvars live-tvar? tvar->rep live-AVs
+              add-tvar-EF! add-tvar-EF-epsilon!
+              add-AV-EF! add-AV-EF-epsilon!)
+
+      (for-each
+        (lambda (tvar)
+
+          ;; --- Condition 2
+          ;; If [a <= b] => forall a'~a exists b'~b st [a' <= b']
+          (for-each
+            (lambda (from) 
+              (when (live-tvar? from)
+                (add-tvar-EF-epsilon! tvar (tvar->rep from))))
+            (Tvar-edgefrom tvar))
+          (for-each
+            (lambda (AV) (add-tvar-EF-epsilon! tvar AV))
+            (get-Tvar-objs tvar))
+
+          ;; --- Conditions 4 and 5
+          (for-each
+            (match-lambda
+              [($ con _ template field alpha sign)
+                (when (live-tvar? alpha)
+                  (if sign
+                    ;; [rng(tvar) <= alpha]
+                    (add-tvar-EF! alpha
+                      (list 'R4 template field) (tvar->rep tvar))
+                    (when #t ;; (follow-antimono-fields template)
+                      ;; Condition 5
+                      ;; At bottom we put beta (or tvar) in own equiv class
+                      ;; [alpha <= dom(tvar)]
+                      (add-tvar-EF! tvar 
+                        (list 'R5 template field) (tvar->rep alpha)))))]
+              [_ (void)])
+            (Tvar-constraints tvar)))
+        live-tvars)
+
+      (for-each
+        (match-lambda
+          [(and AV ($ AV _ template _ fields+ fields-))
+            ;; --- Condition 3
+            (for i 0 (vector-length fields+)
+              (let ([field (vector-ref fields+ i)])
+                (when (live-tvar? field)
+                  (add-AV-EF! AV
+                    (list 'R3 template i) (tvar->rep field)))))])
+        live-AVs)
+
+      ;; extra partitions
+      (append
+        ;; Put each beta st [alpha <= dom(beta)] in separate equiv class
+        (map list
+          (map tvar->rep
+            (filter
+              (lambda (tvar)
+                (ormap
+                  (match-lambda
+                    [($ con _ template field alpha #f)
+                      (live-tvar? alpha)]
+                    [_ #f])
+                  (Tvar-constraints tvar)))
+              live-tvars)))
+
+        ;; put AVs into equiv class according to templates
+        ;; h maps templates to list of AVs
+        (let ([h (make-hash-table)])
+          (for-each
+            (lambda (AV)
+              (let ([t (AV-template AV)])
+                (hash-table-put! h t
+                  (cons AV (hash-table-get h t (lambda () ()))))))
+            live-AVs)
+          (hash-table-map h
+            (lambda (t AVs) AVs))))
+        
+      )))
+
+;; ======================================================================
+
+(define (minimize-constraints-dfa-min-glb lower upper)
+  (minimize-constraints-dfa-min-fast lower upper 
+
+    ;; helper-fn
+    ;; helper-fn sets things up for inv-delta-traversal
+    ;; Sets U field of each state to:
+    ;;     (listof (cons (listof any) state))
+
+    (lambda (live-tvars live-tvar? tvar->rep live-AVs
+              add-tvar-EF! add-tvar-EF-epsilon!
+              add-AV-EF! add-AV-EF-epsilon!)
+
+        (for-each
+          (lambda (tvar)
+
+            ;; --- Condition 2
+            ;; If [a <= b] => forall b'~b exists a'~a st [a' <= b']
+            (for-each
+              (lambda (from) 
+                (when (live-tvar? from)
+                  (add-tvar-EF-epsilon! from (tvar->rep tvar))))
+              (Tvar-edgefrom tvar))
+            (for-each
+              (lambda (AV) (add-AV-EF-epsilon! AV (tvar->rep tvar)))
+              (get-Tvar-objs tvar))
+
+            ;; --- Condition 4
+            (for-each
+              (match-lambda
+                [($ con _ template field alpha #t)
+                  (when (live-tvar? alpha)
+                    ;; [rng(tvar) <= alpha]
+                    (add-tvar-EF! tvar
+                      (list 'R4 template field) (tvar->rep alpha)))]
+                [_ (void)])
+              (Tvar-constraints tvar)))
+          live-tvars)
+
+        (for-each
+          (match-lambda
+            [(and AV ($ AV _ template _ fields+ fields-))
+              ;; --- Condition 3
+              (for i 0 (vector-length fields+)
+                (let ([field (vector-ref fields+ i)])
+                  (when (live-tvar? field)
+                    (add-tvar-EF! field (list 'R3 template i) AV))))
+              ;; --- Condition 5
+              (when (follow-antimono-fields template)
+                (for i 0 (vector-length fields-)
+                  (let ([field (vector-ref fields- i)])
+                    (when (live-tvar? field)
+                      ;; [dom(AV) <= field]
+                      ;; At bottom we put AV in own equiv class
+                      (add-AV-EF! AV 
+                        (list 'R5 template i) (tvar->rep field))))))])
+          live-AVs)
+
+        ;; Conditions 5,6, thm 1.2
+        ;; extra partitioning
+      (append
+        ;; Conditions 5, thm 1.2
+        (filter-map
+          (match-lambda
+            [(and AV ($ AV _ template _ _ fields-))
+              (and 
+                (follow-antimono-fields template)
+                (> (vector-length fields-) 0)
+                (list AV))])
+          live-AVs)
+        ;; Conditions 6, thm 1.2
+        (let ([h (make-hash-table)])
+          (for-each
+            (match-lambda
+              [(and AV ($ AV _ template))
+                (hash-table-put! h template
+                  (cons AV 
+                    (hash-table-get h template (lambda () '()))))])
+            live-AVs)
+          (hash-table-map h
+            (lambda (template AVs) AVs)))))))
+
+;; ======================================================================
+
+
+
+

collects/mrspidey/Sba/min/min-live.ss

@@ -0,0 +1,580 @@
+; ======================================================================
+; copy-live-constraints
+;
+; Input:  lower : list Tvar
+;         upper : list Tvar
+;
+; Copies live constraints
+; returns list-nu Tvar->nu
+; ======================================================================
+; ----------------------------------------------------------------------
+; Copyright (C) 1995-97 Cormac Flanagan
+;
+; This program is free software; you can redistribute it and/or
+; modify it under the terms of the GNU General Public License
+; version 2 as published by the Free Software Foundation.
+; 
+; This program is distributed in the hope that it will be useful,
+; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+; GNU General Public License for more details.
+; 
+; You should have received a copy of the GNU General Public License
+; along with this program; if not, write to the Free Software
+; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
+; ----------------------------------------------------------------------
+
+(define (copy-live-constraints lower upper)
+
+  (pretty-debug-min 
+    `(copy-live-constraints ,(map Tvar-name lower) ,(map Tvar-name upper)))
+
+  (let*-vals 
+    ( [(live-nts live-nt? live-tvars live-tvar? _ _ _)
+        (calc-live-tvars-nts lower upper #f)])
+
+    (copy-constraints-equiv! 
+      (append lower upper live-tvars)
+      live-tvar? live-nts
+      (lambda (tvar) (list tvar))
+      (lambda (AV) (list AV)))))
+
+; ======================================================================
+
+(define (copy-live-constraints-noe lower upper)
+
+  (pretty-debug-min 
+    `(copy-live-constraints-noe 
+       ,(map Tvar-name lower) ,(map Tvar-name upper)))
+
+  (let*-vals 
+    ( [(live-nts live-nt? live-tvars live-tvar? _ _ _)
+        (calc-live-tvars-nts lower upper #t)]
+      [(get-nu-Tvar set-nu-Tvar!) (alloc-Tvar-field)]
+      [list-nuTvar
+        (map (lambda (Tvar) 
+               (let ([nu (mk-Tvar 'min-live)])
+                 (set-nu-Tvar! Tvar nu)
+                 nu))
+          live-tvars)]
+      [dummy-tvars
+        (copy-constraints-noe! live-tvar? live-nts get-nu-Tvar lower)])
+
+    (values
+      (append dummy-tvars list-nuTvar)
+      get-nu-Tvar)))
+
+;; ======================================================================
+; calc-live-tvars-nts
+;
+; Calculates live Tvars and NTs
+; Input:  lower : list Tvar
+;         upper : list Tvar
+;
+; Uses find-nonempty-nts-rhs-nts to find nonempty nts and sources
+; Walk "forward" in grammar using rhs-nts from crossover and AV-w/-const
+; to calculate live
+;
+; Returns (values live-nts live-nt? live-tvars live-tvar? 
+;          AV-w/-const crossover rhs-nts)
+
+(define (calc-live-tvars-nts lower upper inline-epsilon)
+
+  (pretty-debug-min 
+    `(calc-live-tvars-nts  ,inline-epsilon
+       ,(map Tvar-name lower) ,(map Tvar-name upper)))
+
+  (let*-vals 
+    ( [t (lambda (s) 
+           (when timing-min 
+             (min-record-progress (cons 'calc-live-tvars-nts s))))]
+      [_ (t 0)]
+      [(rhs-nts crossover AV-w/-const) 
+        (find-nonempty-nts-rhs-nts lower upper inline-epsilon)]
+      [_ (t 1)]
+      [(live-nt? set-live-nt! get-live-nts) (field->set alloc-NT-field)]
+      [_ (t 2)]
+        
+      ;; --------------------------------------------------
+      ;; Walk forward from crossover and AV-w/-const, recording nts
+        
+      [_ (letrec ([mark-live
+                    (lambda (nt)
+                      (unless (eq? nt #t)
+                        ;;(pretty-print `(mark-live ,(nt->sym nt)))
+                        (unless (live-nt? nt)
+                          (set-live-nt! nt)
+                          (when (rhs-nts nt)
+                            (for-each mark-live (rhs-nts nt))))))])
+
+           (for-each
+             (lambda (Tvar)
+               (mark-live (Tvar-U Tvar))
+               (mark-live (Tvar-L Tvar)))
+             crossover)
+
+           (for-each 
+             (lambda (AV) (mark-live (AV-U AV)))
+             AV-w/-const)
+
+           (pretty-debug-min `(live-nt ,(map nt->sym (get-live-nts)))))]
+      [_ (t 3)]
+
+      ;; --------------------------------------------------
+      ;; Have in (get-live-nts) all nts that are reached and non-empty
+      ;; Calc live Tvar
+
+      [(live-tvar? set-live-tvar! get-live-tvars) 
+        (field->set alloc-Tvar-field)]
+      [_ (t 4)]
+      [_ (begin
+           (for-each
+             (match-lambda
+               [($ NT tvar) (when (Tvar? tvar) (set-live-tvar! tvar))])
+             (get-live-nts))
+           (for-each set-live-tvar! lower)
+           (for-each set-live-tvar! upper))]
+      [_ (t 5)]
+      [_ (pretty-debug-min `(live-Tvar ,(map Tvar-name (get-live-tvars))))])
+
+    (pretty-debug-min
+      `(calc-live-tvars-nts-results
+         ,(map (lambda (nt)
+                 `(nt-rhs ,(nt->sym nt)
+                    ,(map (lambda (nt) (or (eq? nt #t) (nt->sym nt)))
+                       (rhs-nts nt))))
+            (get-live-nts))))
+
+    (values
+      (get-live-nts) live-nt?
+      (get-live-tvars) live-tvar? 
+      AV-w/-const
+      crossover
+      rhs-nts
+      )))
+
+;; ======================================================================
+
+(define (follow-antimono-fields template)
+  (or 
+    (eq? template template-lam)
+    (eq? template template-unit)
+    (eq? template template-internal-class)
+    (st:minimize-respect-assignable-part-of-fields)))
+
+;; ======================================================================
+; find-nonempty-nts-rhs-nts
+;
+; Calculates non-empty Tvars, NTs.
+; For each non-empty NT, finds all rhs-nts NT' such that NT -> x.NT'
+
+; Input:  lower : (listof Tvar)
+;         upper : (listof Tvar)
+;
+; Returns (values rhs-nts crossover-tvars AV-w/-const)
+;
+; Walks "backwards" in grammer to find nonempty NTs
+; Keeps track of rhs-nts on the way
+;
+; crossover is the set of Tvars tvar such that 
+; both L(tvar_L) and L(tvar_U) are nonempty
+
+;; #### Always looks at assignable fields ...
+
+(define (find-nonempty-nts-rhs-nts lower upper inline-epsilon)
+  (pretty-debug-min
+    `(find-nonempty-tvars-nts-rhs-nts ,inline-epsilon
+       ,(map Tvar-name lower) ,(map Tvar-name upper)))
+
+  (let*-vals ( [(reached-tvar? set-reached-tvar!) (alloc-Tvar-field)]
+               [(reached-AV? set-reached-AV!)     (alloc-AV-field)]
+               [(rhs-nts set-rhs-nts!)            (alloc-NT-field)]
+               [add-rhs-nt! 
+                 (lambda (nt src) (set-rhs-nts! nt (cons src (rhs-nts nt))))]
+               [crossover '()]
+               ;; crossover is set of tvars with tvar_L and tvar_U nonempty
+               [AV-w/-const '()]
+               )
+    (letrec
+      ( [add-crossover! 
+          (lambda (tvar)
+            (set! crossover (cons tvar crossover)))]
+        [walk-AV
+          (lambda (AV src)
+            (pretty-debug-min `(walk-AV ,(AV-num AV) ,(nt->sym src)))
+            (if (reached-AV? AV)
+              (add-rhs-nt! (AV-U AV) src)
+              ;; Walk it
+              (begin
+                (set-reached-AV! AV #t)
+                (mk-AV-NTs! AV)
+                (let ([nt (AV-U AV)])
+                  (set-rhs-nts! nt (list src))
+                  (match AV
+                    [($ AV _ (and template ($ template _ _ _ ref))
+                       misc fields+ fields-)
+                      (when (or 
+                              (zero? (vector-length ref))
+                              ;; the following are lazy
+                              ;; ie (box empty) = empty
+                              ;; but (empty -> empty) != empty
+                              (eq? template template-lam)
+                              (eq? template template-unit)
+                              (eq? template template-internal-class)
+                              (eq? template template-ivarset)
+                              )
+                        (set! AV-w/-const (cons AV AV-w/-const)))
+                      (vector-for-each
+                        (lambda (f) (walk-U f nt))
+                        fields+)
+                      (when (follow-antimono-fields template)
+                        (pretty-debug-min
+                          `(walking-U 
+                             ,(eq? template template-lam)
+                             ,(st:minimize-respect-assignable-part-of-fields)))
+                        (vector-for-each 
+                          (lambda (f) (walk-L f nt))
+                          fields-))])))))]
+        [reach-tvar
+          (lambda (tvar)
+            (unless (reached-tvar? tvar) 
+              (set-reached-tvar! tvar #t)
+              (mk-Tvar-NTs! tvar)))]
+        [walk-U
+          (lambda (tvar src)
+            (let 
+              ([f
+                 (lambda (tvar)
+                   (reach-tvar tvar)
+                   (pretty-debug-min `(walk-U ,(Tvar-name tvar) ,(nt->sym src)))
+                   (let ([nt (Tvar-U tvar)])
+                     (if (rhs-nts nt)
+                       (add-rhs-nt! nt src)
+                       ;; Walk it
+                       (begin
+                         (set-rhs-nts! nt (list src))
+                         (when (rhs-nts (Tvar-L tvar)) (add-crossover! tvar))
+                         (pretty-debug-min `(walk-U ,(Tvar-name tvar)))
+                         (for-each
+                           (lambda (AV) (walk-AV AV nt))
+                           (get-Tvar-objs tvar))
+                         '(unless inline-epsilon
+                            (for-each
+                              (lambda (from)
+                                (walk-U from nt))
+                              (Tvar-edgefrom tvar)))))))])
+
+              '(if inline-epsilon
+                 ;; really want to walk all tvar2 st tvar2_U -> tvar_U
+                 (for-each f (Tvar-transitive-edgefrom tvar))
+                 (f tvar))
+              (f tvar)))]
+
+        [walk-L
+          (lambda (tvar src)
+            (let 
+              ([f (lambda (tvar)
+                    (reach-tvar tvar)
+                    (pretty-debug-min
+                      `(walk-L ,(Tvar-name tvar) ,(nt->sym src)))
+                    (let ([nt (Tvar-L tvar)])
+                      (if (rhs-nts nt)
+                        (add-rhs-nt! nt src)
+                        ;; Walk it
+                        (begin
+                          (set-rhs-nts! nt (list src))
+                          (when (rhs-nts (Tvar-U tvar)) (add-crossover! tvar))
+                          (pretty-debug-min `(walk-L ,(Tvar-name tvar)))
+
+                          (unless inline-epsilon
+                            (for-each
+                              (lambda (to)
+                                ;; Have to_L -> tvar_L
+                                (walk-L to nt))
+                              (Tvar-edgeto tvar)))
+                          (for-each
+                            (match-lambda
+                              [($ con _ _ field-no tvar2 sign misc)
+                                ;; Have tvar2_L -> rng(tvar_L)
+                                ;; or   tvar2_U -> dom(tvar_L)
+                                (if sign
+                                  (walk-L tvar2 nt)
+                                  (walk-U tvar2 nt))]
+                              [($ con-filter _ filter tvar2)
+                                ;; Have tvar2_L -> tvar_L
+                                (unless inline-epsilon (walk-L tvar2 nt))])
+                            (Tvar-constraints tvar))))))])
+              '(if inline-epsilon
+                 ;; really want to walk all tvar2 st tvar2_L -> tvar_L
+                 (for-each f (Tvar-transitive-edgeto tvar))
+                 (f tvar))
+              (f tvar)))])
+
+      (for-each (lambda (tvar) (walk-U tvar #t)) upper)
+      (for-each (lambda (tvar) (walk-L tvar #t)) lower)
+
+      (min-record-progress 'find-nonempty-nts-rhs-nts-done)
+      (: rhs-nts (NT -> (union NT true)))
+
+      (pretty-debug-min
+        `(find-nonempty-nts-rhs-nts-returns
+           ,(map AV-num AV-w/-const)
+           ,(map Tvar-name crossover)))
+
+      (values
+        (lambda (nt) 
+          (let ([r (rhs-nts nt)])
+            (pretty-debug-min
+              `(rhs-nts ,(nt->sym nt)
+                 ,(map (lambda (nt) (or (eq? nt #t) (nt->sym nt))) r)))
+            r))
+        crossover 
+        AV-w/-const))))
+        
+;; ======================================================================
+; copy-constraints!
+; 
+; tvar->equiv and AV->equiv describe an equivalence relation on tvars and AVs
+;
+; Copies the contents of a set of Tvars
+; Takes care not to duplicate AVs
+; returns (values nu-tvars tvar->nu-tvar)
+; live-tvars should include lower and upper, and may contain duplicates
+
+(define (copy-constraints-equiv!
+          live-tvars live-tvar? live-nts 
+          tvar->equiv AV->equiv)
+
+  (pretty-debug-min `(copy-constraints-equiv! ,(map nt->sym live-nts)))
+  (let*-vals 
+    ( [t (lambda (s) 
+           (when timing-min 
+             (min-record-progress (cons 'copy-constraint-equivs! s))))]
+      [_ (t 0)]
+
+      ;; --- Allocate new tvar
+      [(Tvar-nuTvar set-Tvar-nuTvar!) (alloc-Tvar-field)]
+      [list-nu-tvars '()]
+      [_ (for-each
+           (lambda (tvar)
+             (unless (Tvar-nuTvar tvar)
+               (let ([nu (mk-Tvar 'copy-constraints!)])
+                 (set! list-nu-tvars (cons nu list-nu-tvars))
+                 (for-each
+                   (lambda (tvar2) (set-Tvar-nuTvar! tvar2 nu))
+                   (tvar->equiv tvar)))))
+           live-tvars)]
+      [_ (t 1)]
+
+      [Tvar->nuTvar 
+        (lambda (Tvar)
+          (if (live-tvar? Tvar)
+            (let ([nu (Tvar-nuTvar Tvar)])
+              (assert (Tvar? nu) 'Tvar->nuTvar 
+                nu (live-tvar? Tvar) (memq Tvar live-tvars))
+              nu)
+            (let ([dummy (mk-Tvar 'dummy)])
+              (set! list-nu-tvars (cons dummy list-nu-tvars))
+              dummy)))]
+
+      [(AV-nuAV set-AV-nuAV!) (alloc-AV-field)]
+      [copy-AV 
+        (lambda (AV)
+          (or 
+            (AV-nuAV AV)
+            (match AV
+              [(and AV ($ AV _ template misc fields+ fields-))
+                (let* 
+                  ( [nu-fields+ (vector-map Tvar->nuTvar fields+)]
+                    [nu-fields- (vector-map Tvar->nuTvar fields-)]
+                    [nu-AV (create-AV template misc nu-fields+ nu-fields-)])
+                  (set-AV-nuAV! AV nu-AV)
+                  (for-each
+                    (lambda (eq-AV) 
+                      (when (and
+                              (not (AV-nuAV eq-AV))
+                              (eq? (AV-template eq-AV) template)
+                              (vector-andmap2 eq? nu-fields+ 
+                                (vector-map Tvar->nuTvar (AV-fields+ eq-AV)))
+                              '(vector-andmap2 eq? nu-fields-
+                                 (vector-map Tvar->nuTvar (AV-fields- eq-AV))))
+                        (set-AV-nuAV! eq-AV nu-AV)))
+                    (AV->equiv AV))
+                  nu-AV)])))]
+      [_ (t 1.1)])
+
+    (for-each
+      (match-lambda
+        [($ NT source LU)
+          (when (Tvar? source)
+            (let ([dest (Tvar->nuTvar source)])
+              (case LU
+                [(U)
+                  ;; --- AVs
+                  (for-each (lambda (AV) (new-AV! dest (copy-AV AV)))
+                    (Tvar-objs source))]
+                [(L)
+                  ;; --- Constraints
+                  (for-each
+                    (match-lambda
+                      [($ con _ template field-no Tvar sign)
+                        (when (live-tvar? Tvar)
+                          (new-con! dest 
+                            (create-con template field-no 
+                              (Tvar->nuTvar Tvar) sign)))]
+                      [($ con-filter _ filter Tvar)
+                        (when (live-tvar? Tvar)
+                          ;; (new-con! dest
+                          ;;  (create-con-filter filter (Tvar->nuTvar Tvar))
+                          (new-edge! dest (Tvar->nuTvar Tvar)))])
+                    (Tvar-constraints source))
+
+                  ;; --- Edges
+                  (for-each
+                    (lambda (Tvar2)
+                      (when (live-tvar? Tvar2)
+                        (let ([nu (Tvar->nuTvar Tvar2)])
+                          (unless (eq? dest nu)
+                            (new-edge! dest nu)))))
+                    (Tvar-edgeto source))])))])
+      live-nts)
+    (t 2)
+
+    (pretty-debug-min
+      `(copy-constraints-equiv!
+         old->new
+         ,(map 
+            (lambda (tvar) 
+              (list (Tvar-name tvar) (Tvar-name (Tvar-nuTvar tvar))))
+            live-tvars)))
+
+
+    (values list-nu-tvars Tvar-nuTvar))) 
+
+;; ======================================================================
+; copy-constraints-noe!
+; 
+; Copies the contents of a set of Tvars
+; Does closure under epsilon
+; Takes care not to add duplicate AVs
+; But may make many copies of the same AV in different Tvar
+
+(define (copy-constraints-noe! live-tvar? live-nts Tvar-nuTvar lower)
+  (pretty-debug-min
+    `(copy-constraints-noe!
+       live-nts
+       ,(map nt->sym live-nts)
+       lower
+       ,(map Tvar-name lower)
+       conversion
+       ,(map 
+          (lambda (tvar) 
+            (list (Tvar-name tvar) (Tvar-name (Tvar-nuTvar tvar))))
+          (filter Tvar? (map NT-tvar live-nts)))))
+  '(let*-vals
+    ( [(AV-nuAV set-AV-nuAV!) (alloc-AV-field)]
+      [dummy-tvars '()]
+      [mk-dummy-tvar
+        (lambda ()
+          (let ([dummy (mk-Tvar 'dummy)])
+            (set! dummy-tvars (cons dummy dummy-tvars))
+            dummy))]
+      [Tvar->nuTvar 
+        (lambda (Tvar)
+          (if (live-tvar? Tvar)
+            (Tvar-nuTvar Tvar)
+            (mk-dummy-tvar)))]
+      [table '()]
+      [Tvar*->nuTvar
+        (lambda (Tvar*)
+          (let* ( [Tvar* (if (Tvar? Tvar*) (list Tvar*) Tvar*)]
+                  [nu-Tvar* 
+                    (list->set 
+                      (filter-map
+                        (lambda (Tvar)
+                          (if (live-tvar? Tvar) (Tvar->nuTvar Tvar) #f))
+                        Tvar*))])
+            (match nu-Tvar*
+              [() (mk-dummy-tvar)]
+              [(Tvar) Tvar]
+              [_ (or (ormap
+                       (match-lambda
+                         [(Tvar2* . nu) 
+                           (if (set-eq? Tvar2* nu-Tvar*) nu #f)])
+                       table)
+                   (let ([nu (mk-Tvar 'multiple)])
+                     (set! table (cons (cons nu-Tvar* nu) table))
+                     (for-each (lambda (to) (new-edge! nu to)) nu-Tvar*)
+                     nu))])))]
+      [tag-reached-AV (gensym)])
+
+    (for-each
+      (match-lambda
+        [($ NT source LU)
+          (when (Tvar? source)
+            (pretty-debug-min `(copying ,(Tvar-name source)))
+            (let ([dest (Tvar->nuTvar source)])
+              (case LU
+                [(U)
+                  ;; --- AVs
+                  (for-each
+                    (match-lambda
+                      [(and AV 
+                         ($ AV _ 
+                           (and template ($ template _ signs)) misc fields))
+
+                        (pretty-debug-min `(AV ,(Tvar-name dest)
+                                             ,(vector-map Tvar-name fields)))
+
+                        (new-AV! dest
+                          (or (AV-nuAV AV)
+                            (let* ([nu-fields
+                                     (vector-map
+                                       (lambda (sign field)
+                                         (if sign
+                                           (Tvar->nuTvar field)
+                                           (Tvar*->nuTvar 
+                                             (Tvar-transitive-edgeto field))))
+                                       signs fields)]
+                                    [nu-AV (create-AV template misc nu-fields)])
+                              (set-AV-nuAV! AV nu-AV)
+                              nu-AV)))])
+                    (Tvar-objs source))]
+
+                [(L)
+                  ;; --- Constraints
+                  (for-each
+                    (match-lambda
+                      [($ con _ template field-no Tvar)
+                        (for-each
+                          (lambda (Tvar)
+                            (when (live-tvar? Tvar)
+                              (new-con! dest
+                                (create-con template field-no
+                                  (Tvar->nuTvar Tvar)))))
+                          (if (vector-ref (template-signs template) field-no)
+                            (Tvar-transitive-edgeto Tvar)
+                            (list Tvar)
+                            ;;(Tvar-transitive-edgefrom Tvar)
+                            ))]
+                      [($ con-filter _ filter Tvar) 
+                        ;; Was treated as edge
+                        (void)])
+                    (Tvar-constraints source))])))])
+      live-nts)
+
+    (for-each 
+      (lambda (L)
+        (let ([nu-L (Tvar->nuTvar L)])
+          (for-each
+            (lambda (to)
+              (when (live-tvar? to)
+                (let ([nu-to (Tvar->nuTvar to)])
+                  (unless (eq? nu-L nu-to)
+                    (new-edge! nu-L nu-to)))))
+            (Tvar-transitive-edgeto L))))
+      lower)
+
+    (append dummy-tvars (map cdr table))))
+
+;; ======================================================================

collects/mrspidey/Sba/min/min.ss

@@ -0,0 +1,236 @@
+; min.ss
+; Purpose: Minimize a set of constraints.
+; ======================================================================
+; ----------------------------------------------------------------------
+; Copyright (C) 1995-97 Cormac Flanagan
+;
+; This program is free software; you can redistribute it and/or
+; modify it under the terms of the GNU General Public License
+; version 2 as published by the Free Software Foundation.
+; 
+; This program is distributed in the hope that it will be useful,
+; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+; GNU General Public License for more details.
+; 
+; You should have received a copy of the GNU General Public License
+; along with this program; if not, write to the Free Software
+; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
+; ----------------------------------------------------------------------
+; minimize-constraints-&-compare
+; minimizes a constraint system
+; Input:  which : 'live or 'dfa-min
+;         lower : list Tvar
+;         upper : list Tvar
+;         l1 ... l2 : ftypes in uncompresssed set of constraints
+
+; Returns (list-ftype Tvar->nuTvar)
+;; ----------------------------------------
+
+(define global-lower (void))
+(define global-upper (void))
+(define global-all-which (void))
+
+(define (minimize-constraints-&-compare all-which lower upper l1 l2)
+  (set! global-lower lower)
+  (set! global-upper upper)
+  (set! global-all-which all-which)
+  (when (st:compare-min-algs)
+    ;; Compare algorithms
+    (let* ( [alg-width 32]
+            [calc-sizes
+             (lambda (rep)
+               (pretty-debug-min2 `(calc-sizes ,(map Tvar-name rep)))
+               (let*-vals
+                 ( [n-f (length rep)]
+                   [AV-added (apply append (map get-Tvar-objs rep))]
+                   [n-AV-added (length AV-added)]
+                   [n-AV (length (list->set AV-added))]
+                   [n-edge (length (apply append (map Tvar-edgeto rep)))]
+                   [n-con (length (apply append (map Tvar-constraints rep)))]
+                   [size (+ n-edge n-con n-AV-added)])
+                 (list size n-f n-AV n-AV-added n-edge n-con)))]
+            [show-sizes
+              (lambda (alg orig-size t size n-f n-AV n-AV-added n-edge n-con)
+                (if (zero? size)
+                  (error 'minimize-constraints-&-compare
+                     "Algorithm ~s returns empty constraint system~n" alg)
+                  (printf 
+                    "~a: ~a ~a ~a ~a ~a ~a ~a ~a~n"
+                    (padr alg alg-width)
+                    (padl
+                      (/ (round (* (exact->inexact (/ orig-size size)) 10)) 10)
+                      6)
+                    (padl size 5)
+                    (padl n-f 5)
+                    (padl n-AV 3)
+                    (padl n-AV-added 5)
+                    (padl n-edge 5)
+                    (padl n-con 4)
+                    (padl t 5))))]
+            [orig-sizes (calc-sizes (filter Tvar? (get-prefix l1 l2)))]
+            [orig-size (car orig-sizes)])
+      '(pretty-debug `(minimize-constraints-&-compare 
+                        ,(map Tvar-name lower) ,(map Tvar-name upper)))
+      (printf "~n~a:  factor  size  Tvar  AV  AV-a  edge  con time~n" 
+        (padr "Algorithm" alg-width))
+      (apply show-sizes "" orig-size 0 orig-sizes)
+      (for-each
+        (lambda (p)
+          (let*-vals
+            ( [thunk 
+                (lambda ()
+                  (let-values
+                    ([(rep _) 
+                       (minimize-constraints p lower upper l1 l2)])
+                    rep))]
+              [(rep t real-t) (time-apply thunk)]
+              [sizes (calc-sizes rep)])
+            (apply show-sizes p orig-size t sizes)))
+        min-algs-to-compare)))
+
+  (minimize-constraints all-which lower upper l1 l2))
+
+;; ----------
+
+(define min-algs-to-compare
+  '(                                    ;(none)
+     (nonempty)
+     (nonempty live)
+     (live)
+     ;(live-no-epsilon)
+     (live-few-e)
+                                        ;(live-few-e-L)
+                                        ;(live-few-e-U)
+     ;(live-no-epsilon dfa-min)
+     ;(live-no-epsilon dfa-min-inv)
+     ;(live-few-e dfa-min)
+     ;(live-few-e dfa-min-inv)
+     ;(live-few-e dfa-min-inv dfa-min)
+     ;(live-few-e dfa-min dfa-min-inv)
+
+     ;(live-no-epsilon dfa-min-1)
+     ;(live-no-epsilon dfa-min-2)
+
+     ;(live-few-e dfa-min-1)
+     ;(live-few-e dfa-min-2)
+     ;(live-few-e dfa-min-1 live-few-e dfa-min-2)
+     ;(live-few-e dfa-min-2 live-few-e dfa-min-1)
+
+     (dfa-min-lub)
+     (dfa-min-glb)
+     (dfa-min-lub dfa-min-glb)
+     (dfa-min-glb dfa-min-lub)
+     (dfa-min-lub dfa-min-glb dfa-min-lub)
+     (dfa-min-glb dfa-min-lub dfa-min-glb)
+     ;(live-few-e dfa-min-1 live-no-epsilon dfa-min-2 live-no-epsilon dfa-min-1)
+     ;(live-few-e dfa-min-2 live-no-epsilon dfa-min-1 live-no-epsilon dfa-min-2)
+                                        ;(live-no-epsilon min-table)
+     ))
+
+;; ----------------------------------------------------------------------
+
+(define min-time-base 0)
+(define min-time-record '())
+(define (min-record-progress what)
+  (set! min-time-record
+    (cons (cons what (current-process-milliseconds)) min-time-record)))
+(define (show-record-progress)
+  (pretty-debug
+    (map (match-lambda
+           [(what . when) (list what (- when min-time-base))])
+      (reverse min-time-record))))
+;; ----------
+
+(define (minimize-constraints all-which lower upper l1 l2)
+  (pretty-debug-min2
+    `(input 
+       all-which ,all-which
+       lower ,(map Tvar-name lower)
+       upper ,(map Tvar-name upper)))
+
+  (set! min-time-record '())
+  (set! min-time-base (current-process-milliseconds))
+  (recur loop ( [which all-which]
+                [lower lower]
+                [upper upper]
+                [Tvar->nuTvar (lambda (x) x)])
+    (match which
+      [(which . (and rest (_ . _)))
+        (let*-vals
+          ([(rep-Tvar1 Tvar->nuTvar1)
+             (minimize-constraints-nocount which lower upper l1 l2)])
+          (loop rest 
+            (map Tvar->nuTvar1 lower)
+            (map Tvar->nuTvar1 upper)
+            (lambda (Tvar) (Tvar->nuTvar1 (Tvar->nuTvar Tvar)))))]
+      [(or (which) (? symbol? which))
+        (let*-vals
+          ([(rep-Tvar Tvar-nuTvar1) 
+             (minimize-constraints-nocount which lower upper l1 l2)])
+
+          (when timing-min (show-record-progress))
+
+          (pretty-debug-min2
+            `(output lower ,(map Tvar-name (map Tvar-nuTvar1 lower))
+               upper ,(map Tvar-name (map Tvar-nuTvar1 upper))))
+
+          (values 
+            rep-Tvar
+            (lambda (Tvar) (Tvar-nuTvar1 (Tvar->nuTvar Tvar)))))])))
+
+;; ----------------------------------------------------------------------
+
+(define (minimize-constraints-nocount which lower upper l1 l2)
+  (pretty-debug-min
+    `(minimize-constraints-nocount which ,which
+       lower ,(map Tvar-name lower)
+       upper ,(map Tvar-name upper)))
+  (check-kernel-ok)
+  (pretty-debug-min `(minimize-constraints-nocount kernel-ok))
+  (let*-values
+    ([(A B)
+       (case which
+         [(none)             (values
+                             (filter Tvar? (get-prefix l1 l2))
+                             (lambda (Tvar) Tvar))]
+         [(nonempty)         (let*-vals
+                             ([(live-tvars _ _) 
+                                (find-nonempty-tvars lower upper)])
+                             (values 
+                               live-tvars                             
+                               (lambda (tvar) tvar)))]
+         [(nonempty-copy)    (copy-nonempty-tvars lower upper)]
+         [(live)             (copy-live-constraints lower upper)]
+         [(live-no-epsilon)  (copy-live-constraints-noe lower upper)]
+
+         [(live-few-e)
+           (call-with-values
+             (lambda () ((copy-live-constraints-few-e #t #t) lower upper))
+             copy-constraints-equiv!)]
+         [(live-few-e-L)
+           (call-with-values
+             (lambda () ((copy-live-constraints-few-e #t #f) lower upper))
+             copy-constraints-equiv!)]
+         [(live-few-e-U)
+           (call-with-values
+             (lambda () ((copy-live-constraints-few-e #f #t) lower upper))
+             copy-constraints-equiv!)]
+         ;[dfa-min          (minimize-constraints-dfa-min lower upper)]
+         ;[dfa-min-inv      (minimize-constraints-dfa-min-inv lower upper)]
+         ;[dfa-min-1        (minimize-constraints-dfa-min-1 lower upper)]
+         ;[dfa-min-2        (minimize-constraints-dfa-min-2 lower upper)]
+         [(dfa-min-lub)      (minimize-constraints-dfa-min-lub lower upper)]
+         [(dfa-min-glb)      (minimize-constraints-dfa-min-glb lower upper)]
+         ;[min-table        (min-table lower upper)]
+         [else (error 'minimize-constraints-nocount "Bad which ~s" which)])])
+    (check-kernel-ok)
+    (pretty-debug-min `(minimize-constraints-nocount kernel-ok2))
+    (min-record-progress 'minimize-constraints-nocount-returning)
+    (values A B)))
+
+;; ======================================================================
+
+
+
+

collects/mrspidey/Sba/min/nonempty.ss

@@ -0,0 +1,105 @@
+; ======================================================================
+; find-nonempty-tvars
+;
+; Input:  lower : (listof Tvar) with non-empty Tvar_L
+;         upper : (listof Tvar) with non-empty Tvar_U
+;
+; Finds non-empty non-terminals
+; returns (listof Tvar)
+; ======================================================================
+; ----------------------------------------------------------------------
+; Copyright (C) 1995-97 Cormac Flanagan
+;
+; This program is free software; you can redistribute it and/or
+; modify it under the terms of the GNU General Public License
+; version 2 as published by the Free Software Foundation.
+; 
+; This program is distributed in the hope that it will be useful,
+; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+; GNU General Public License for more details.
+; 
+; You should have received a copy of the GNU General Public License
+; along with this program; if not, write to the Free Software
+; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
+; ----------------------------------------------------------------------
+
+(define (find-nonempty-tvars lower upper)
+  (pretty-debug-min
+    `(find-nonempty-tvars ,(map Tvar-name lower) ,(map Tvar-name upper)))
+
+  (let*-vals ( [(reached-U? set-reached-U!) (alloc-Tvar-field)]
+               [(reached-L? set-reached-L!) (alloc-Tvar-field)]
+               [(reached-AV set-reached-AV!) (alloc-AV-field)]
+               [num-AV 0]
+               [list-tvar '()])
+    (letrec
+      ( [add-Tvar!
+          (lambda (tvar)
+            (set! list-tvar (cons tvar list-tvar)))]
+        [walk-AV
+          (lambda (AV)
+            (unless (reached-AV AV)
+              ;; Walk it
+              (set-reached-AV! AV #t)
+              (match AV
+                [($ AV _ template _ fields+ fields-)
+                  (vector-for-each walk-U fields+)
+                  (when (follow-antimono-fields template)
+                    (pretty-debug-min
+                      `(walking-U 
+                         ,(eq? template template-lam)
+                         ,(st:minimize-respect-assignable-part-of-fields)))
+                    (vector-for-each walk-U fields-))])))]
+        [walk-U
+          (lambda (tvar)
+            (unless (reached-U? tvar)
+              (unless (reached-L? tvar) (add-Tvar! tvar))
+              (set-reached-U! tvar #t)
+              (pretty-debug-min `(walk-U ,(Tvar-name tvar)))
+              (for-each walk-AV (get-Tvar-objs tvar))
+              (for-each walk-U (Tvar-edgefrom tvar))))]
+        [walk-L
+          (lambda (tvar)
+            (unless (reached-L? tvar)
+              (unless (reached-U? tvar) (add-Tvar! tvar))
+              (set-reached-L! tvar #t)
+              (pretty-debug-min `(walk-L ,(Tvar-name tvar)))
+              ;; Have to_L -> tvar_L
+              (for-each walk-L (Tvar-edgeto tvar))
+
+              (for-each
+                (match-lambda
+                  [($ con _ _ field-no tvar2 sign misc)
+                    ;; Have tvar2_L -> rng(tvar_L)
+                    ;; or   tvar2_U -> dom(tvar_L)
+                    (if sign
+                      (walk-L tvar2)
+                      (walk-U tvar2))]
+                  [($ con-filter _ filter tvar2)
+                    ;; Have tvar2_L -> tvar_L
+                    (walk-L tvar2)])
+                (Tvar-constraints tvar))))])
+      (for-each walk-U upper)
+      (for-each walk-L lower)
+      '(printf "walk-reachable-constraints allocated ~s tvar, ~s AV~n"
+         (length list-tvar) num-AV)
+
+      (values list-tvar reached-L? reached-U?))))
+
+; ======================================================================
+
+(define (copy-nonempty-tvars lower upper)
+  (let*-vals
+    ( [(live-tvars _ _) (find-nonempty-tvars lower upper)]
+      [(tvar-live? set-tvar-live!) (alloc-Tvar-field)])
+    (for-each mk-Tvar-NTs! live-tvars)
+    (for-each (lambda (tvar) (set-tvar-live! tvar #t)) live-tvars)
+    (copy-constraints-equiv! 
+      (append lower upper live-tvars)
+      tvar-live?
+      (append 
+        (map Tvar-L live-tvars)
+        (map Tvar-U live-tvars))
+      (lambda (tvar) (list tvar))
+      (lambda (AV) (list AV)))))

collects/mrspidey/Sba/mod-env3.ss

@@ -0,0 +1,46 @@
+(let ([gen:477:join-env (void)]
+      [gen:473:extend-env* (void)]
+      [gen:476:extend-env (void)]
+      [gen:474:lookup (void)]
+      [gen:475:empty-env (void)])
+  (begin (set! gen:475:empty-env '())
+         (begin (set! gen:474:lookup
+                  (lambda (gen:493:env gen:492:x)
+                    (let ([gen:494:r (assq gen:492:x gen:493:env)])
+                      (if (eq? gen:494:r '#f)
+                          (error 'lookup '"no binding for ~a" gen:492:x)
+                          (cdr gen:494:r)))))
+                (begin (set! gen:476:extend-env
+                         (lambda (gen:491:env gen:489:x gen:490:v)
+                           (cons (cons gen:489:x gen:490:v) gen:491:env)))
+                       (begin (set! gen:473:extend-env*
+                                (lambda (gen:488:env gen:486:xs gen:487:vs)
+                                  (append (map2 cons gen:486:xs gen:487:vs) gen:488:env)))
+                              (begin (set! gen:477:join-env
+                                       (lambda (gen:485:env gen:484:newenv)
+                                         (append gen:484:newenv gen:485:env)))
+                                     (make-rs:module
+                                       (lambda (gen:478:msg)
+                                         (let ([gen:479:%%tmp gen:478:msg])
+                                           (if (memv gen:479:%%tmp '(empty-env))
+                                               gen:475:empty-env
+                                               (let ([gen:480:%%tmp gen:478:msg])
+                                                 (if (memv gen:480:%%tmp '(lookup))
+                                                     gen:474:lookup
+                                                     (let ([gen:481:%%tmp gen:478:msg])
+                                                       (if (memv gen:481:%%tmp '(extend-env))
+                                                           gen:476:extend-env
+                                                           (let ([gen:482:%%tmp gen:478:msg])
+                                                             (if (memv gen:482:%%tmp '(extend-env*))
+                                                                 gen:473:extend-env*
+                                                                 (let ([gen:483:%%tmp gen:478:msg])
+                                                                   (if (memv gen:483:%%tmp '(join-env))
+                                                                       gen:477:join-env
+                                                                       (error 'import
+                                                                         '"attempting to import ~s~n        from module with signature ~s"
+                                                                         gen:478:msg
+                                                                         '(empty-env
+                                                                            lookup
+                                                                            extend-env
+                                                                            extend-env*
+                                                                            join-env))))))))))))))))))))

collects/mrspidey/Sba/nfa-dfa.ss

@@ -0,0 +1,59 @@
+; ======================================================================
+;; NFA->DFA
+;; roots: (list nt)
+;; final: (list nt)
+;; returns (list (list AVS) (list AVS))
+
+(define (NFA->DFA for-each-prod roots final)
+  ;; n is an old nt
+  ;; d is new nt
+  (letrec
+      ([n*->d '()]                    ; Maps set of NFA nts to a DFA nt
+       [n*<=
+        (lambda (n1* n2*)
+          (andmap (lambda (n1) (mem-nt? n1 n2*)) n1*))]        
+       [n*=
+        (lambda (n1* n2*)
+          (and (n*<= n1* n2*) (n*<= n2* n1*)))]
+       [lookup
+        (lambda (n*)
+          (recur loop ([l n*->d])
+            (cond
+             [(null? l) #f]
+             [(n*= n* (caar l)) (cdar l)]
+             [else (loop (cdr l))])))]
+       [traverse
+        (lambda (n*)
+          (or (lookup n*)
+              ;; Need to traverse
+              ;; think about epsilon-closure
+              (let* ([rhs* '()]
+                     [_ (for-each
+                         (lambda (n)
+                           (for-each-prod
+                            (lambda (rhs) (set! rhs* (cons rhs rhs*)))
+                            n))
+                         n*)]
+                     [d (mk-AVS-nolist 'dfa)])
+                (set! n*->d (cons (cons n* d) n*->d))
+                (recur loop ([rhs* rhs*])
+                  (match rhs*
+                    [() (void)]
+                    [(($ rhs grsym nt) . _)
+                     ;; Merge all with same grsym 
+                     (match-let* 
+                         ([(nt* . rest) 
+                           (filter-map-split
+                            (match-lambda
+                             [($ rhs grsym2 nt2)
+                              (if (grsym-eq? grsym grsym2)
+                                  nt2
+                                  #f)])
+                            rhs*)])
+                       (add-prod! d (make-rhs grsym (traverse nt*)))
+                       (loop rest))]))
+                d)))])
+    (traverse (list AVS))
+    (list (map (lambda (r) (lookup (list r))) roots)
+          (map (lambda (r) (lookup (list r))) final))))
+

collects/mrspidey/Sba/parser.ss

@@ -0,0 +1,489 @@
+;; parser.ss
+;;
+;; Takes a zodiac:sexp, and an env: sym -> zodiac:bound,
+;; and produces a zodiac:ast and a list of unbound zodiac:bounds
+;; Only handles R4RS primitive syntax
+;; ======================================================================
+
+(define keywords
+  '(begin cond delay if set! set!-values quote begin lambda case-lambda 
+     poly
+     let-values letrec*-values
+     unit compound-unit invoke-unit
+     : type:-quote
+     cache-exp-quote cache-inv-quote
+     struct typed-structure const-typed-structure
+     ))
+
+(define define-keywords
+  '(define-values
+     define-type 
+     define-constructor 
+     ))
+
+;; ----------------------------------------------------------------------
+
+(define (top-level-parse-defs defs)
+  (set! unbound-env '())
+  (let-values ([(defs nuenv) (parse-defs defs empty-env)])
+    (values defs (map cdr unbound-env))))
+
+(define (top-level-parse-exp exp)
+  (set! unbound-env '())
+  (let ([ast (parse exp empty-env)])
+    (values ast (map cdr unbound-env))))
+
+(define unbound-env '())
+
+;; ----------------------------------------------------------------------
+
+(define syntax-error
+  (case-lambda
+   [(exp) (syntax-error exp "Bad syntax")]
+   [(exp s)
+    (mrspidey:error
+     (format "File ~s, Line ~s: ~a ~s" 
+             (file-name-from-path
+              (zodiac:location-file (zodiac:zodiac-start exp)))
+             (zodiac:location-line (zodiac:zodiac-start exp))
+             s (zodiac:stripper exp)))]))
+
+(define syntax-error-no-exp
+  (case-lambda
+   [(exp) (syntax-error-no-exp exp "Bad syntax")]
+   [(exp s)
+    (mrspidey:error
+     (format "File ~s, Line ~s: ~as" 
+             (file-name-from-path
+              (zodiac:location-file (zodiac:zodiac-start exp)))
+             (zodiac:location-line (zodiac:zodiac-start exp))
+             s))]))
+
+(define assert-syn
+  (case-lambda
+   [(exp x) (assert-syn exp x "Bad syntax")]
+   [(exp x s) (unless x (syntax-error exp s))]))
+
+(define parse-body
+  (lambda (o s f body env)
+    (assert (list? body))
+    (recur loop ([rest body])
+      (match rest
+        [(exp) (parse exp env)]
+        [(exp . rest)
+         (zodiac:make-begin-form o s f (box 0)
+                                 (parse exp env)
+                                 (loop rest))]))))
+
+(define do-bindings
+  (lambda (env syms)
+    (assert (list? syms))
+    (let* ([bindings
+            (map 
+             (match-lambda
+              [($ zodiac:symbol o s f sym)
+               (let ([bound (zodiac:make-bound o s f (box 0) sym sym)])
+                 (cons sym bound))]
+              [exp (syntax-error exp "Bad binding syntax")])
+             syms)]
+           [syms (map car bindings)]
+           [bounds (map cdr bindings)]
+           [nuenv (extend-env* env syms bounds)])
+      (values bounds nuenv))))
+
+(define do-bindingss
+  (lambda (env symss)
+    (recur loop ([env env][symss symss][boundss '()])
+      (if (null? symss)
+          (values (reverse boundss) env)
+          (let-values 
+           ([(bounds env) (do-bindings env (car symss))])
+           (loop env (cdr symss) (cons bounds boundss)))))))
+
+(define parse
+  ;; parses an expression
+  (lambda (exp env)
+    (pretty-debug-front `(parse ,(zodiac:stripper exp)))
+    (letrec ([lookup-sym
+              (lambda (sym s f env)
+                (let ([bound
+                        (or (lookup-or-#f env sym)
+                          (lookup-or-#f unbound-env sym)
+                          ;; Add to unbound-env
+                          (let ([n (zodiac:my-create-bound sym s f)])
+                            (set! unbound-env (cons (cons sym n) unbound-env))
+                            n))])
+                  ;;(set-bound-refs! bound (add1 (bound-refs bound)))
+                  bound))]
+             [parse-sym-env
+              (lambda (env)
+                (match-lambda
+                 [($ zodiac:symbol o s f sym)
+                  ;;(printf "ref sym ~s~n" sym)
+                  (zodiac:make-lexical-varref o s f (box 0) 
+                                              sym (lookup-sym sym s f env))]
+                 [exp (syntax-error exp "Expected a variable:")]))]
+             [parse-sym (parse-sym-env env)]
+             [call-void
+              (lambda (o s f)
+                (zodiac:make-app 
+                 o s f (box 0) 
+                 (zodiac:make-lexical-varref o s f (box 0) 
+                                             'void (lookup-sym 'void s f '()))
+                 '()))]
+             [parse-exps
+              (lambda (exps env)
+                (map (lambda (e) (parse e env)) exps))]
+             [handle-args
+              (lambda (args env)
+                (match args
+                  [($ zodiac:list _ _ _ args) (do-bindings env args)]
+                  [($ zodiac:symbol)          
+                   (let-values
+                       ([(bounds nuenv) (do-bindings env (list args))])
+                     (values (car bounds) nuenv))]
+                  [($ zodiac:improper-list _ _ _ l)
+                   (recur loop ([args '()][l l])
+                     (match l
+                       [(arg)
+                        (let-values
+                            ([(bounds nuenv) 
+                              (do-bindings env (cons arg args))])
+                          (values (append (reverse (cdr bounds)) (car bounds))
+                                  nuenv))]
+                       [(arg . rest) (loop (cons arg args) rest)]))]))])
+
+      (pretty-debug-front `(parse ,(zodiac:stripper exp)))
+      (match exp
+        ;; Identifiers
+        [($ zodiac:symbol o s f sym) (parse-sym exp)]
+
+        ;; Scalars, vectors
+        [(or ($ zodiac:scalar o s f) ($ zodiac:vector o s f))
+         (zodiac:make-quote-form o s f (box 0) exp)]
+
+        ;; Special forms
+        [($ zodiac:list o s f 
+            (and l (($ zodiac:symbol _ _ _ sym) . body)))
+         (=> fail)
+         (let ([sym (strip-hash-percent sym)])
+           (cond
+            [(memq sym keywords) 
+             (match (cons sym body)
+               [('cond)
+                (call-void o s f)]
+               [('delay exp)
+                (zodiac:make-delay-form o s f (box 0) (parse exp env))]
+               [('if test then else)
+                (zodiac:make-if-form o s f (box 0) 
+                                     (parse test env)
+                                     (parse then env)
+                                     (parse else env))]
+               [('if test then)
+                (zodiac:make-if-form o s f (box 0) 
+                                     (parse test env)
+                                     (parse then env)
+                                     (call-void o s f))]
+               [(or 
+                  ('set! var exp)
+                  ('set!-values ($ zodiac:list _ _ _ (var)) exp))
+
+                (let ([var (parse-sym var)])
+                  (when (zodiac:lexical-varref? var) 
+                    (zodiac:set-bound-mutated!
+                     (zodiac:lexical-varref-binding var)
+                     #t))
+                  (zodiac:make-set!-form o s f (box 0)
+                                         var (parse exp env)))]
+               [('quote sexp)
+                (assert-syn exp (= (length body) 1))
+                (zodiac:make-quote-form o s f (box 0) sexp)]
+               [('begin . exps)
+                (recur loop ([exps exps])
+                  (match exps
+                    [() (call-void o s f)]
+                    [(exp) (parse exp env)]
+                    [(exp . exps)
+                     (zodiac:make-begin-form o s f (box 0)
+                                             (parse exp env)
+                                             (loop exps))]))]
+               [('lambda args . bodies)
+                (let-values
+                 ([(bounds nuenv) (handle-args args env)])
+                 (zodiac:make-lambda-form o s f (box 0) 
+                                          bounds 
+                                          (parse-body o s f bodies nuenv)))]
+               [('case-lambda . cases)
+                (zodiac:make-case-lambda-form
+                 o s f (box 0)
+                 (mapLR
+                  (match-lambda
+                   [($ zodiac:list _ _ _ (args . body))
+                    (let-values
+                     ([(bounds nuenv) (handle-args args env)])
+                     (cons bounds (parse-body o s f body nuenv)))]
+                   [_ (syntax-error-no-exp exp "Bad case lambda")])
+                  cases))]
+
+               [('let-values
+                 ($ zodiac:list _ _ _
+                    (($ zodiac:list _ _ _ 
+                        (($ zodiac:list _ _ _ varss)
+                         exps))
+                     ...))
+                 . bodies)
+                (let-values
+                 ([(boundss nuenv) (do-bindingss env varss)])
+                 (zodiac:make-let-values-form 
+                  o s f (box 0)
+                  boundss
+                  (parse-exps exps env)
+                  (parse-body o s f  bodies nuenv)))]
+
+               [('letrec*-values
+                 ($ zodiac:list _ _ _
+                    (($ zodiac:list _ _ _ 
+                        (($ zodiac:list _ _ _ varss)
+                         exps))
+                     ...))
+                 . bodies)
+                (let-values
+                 ([(boundss nuenv) (do-bindingss env varss)])
+                  (for-each 
+                    (lambda (name) (zodiac:set-bound-mutated! name #t))
+                    (apply append boundss))
+                 (zodiac:make-letrec-values-form 
+                  o s f (box 0)
+                  boundss
+                  (parse-exps exps nuenv)
+                  (parse-body o s f  bodies nuenv)))]
+
+               ;; ---------------------------------------------------------
+               ;; MzScheme specific code
+
+               ;; --- units ---
+               [('unit ($ zodiac:list _ _ _ 
+                          (($ zodiac:symbol _ _ _ 'import) 
+                           i-ids ...))
+                       ($ zodiac:list _ _ _
+                          (($ zodiac:symbol _ _ _ 'export) 
+                           (or ($ zodiac:list _ _ _ 
+                                  (i-eids
+                                   ($ zodiac:symbol _ _ _ e-eids)))
+                               (and i-eids
+                                    ($ zodiac:symbol _ _ _ e-eids)))
+                           ...))
+                       . body)
+                (let*-vals ([(i-names env1) (do-bindings env i-ids)]
+                            [(defs env2) (parse-defs body env1)]
+                            [e-vars 
+                             (map (parse-sym-env env2) i-eids)]
+                            [exports (map cons e-vars e-eids)])
+                           (zodiac:make-unit-form o s f (box 0)
+                                                  i-names exports defs))]
+
+               ;; --- compound-units ---
+               [('compound-unit
+                 ($ zodiac:list _ _ _ 
+                    (($ zodiac:symbol _ _ _ 'import) 
+                     ($ zodiac:symbol _ _ _ imports) ...))
+                 ($ zodiac:list _ _ _ 
+                    (($ zodiac:symbol _ _ _ 'link) . links))
+                 ($ zodiac:list _ _ _ 
+                    (($ zodiac:symbol _ _ _ 'export) . exports))) 
+                (let*-vals 
+                 ([links
+                   (map
+                    (match-lambda
+                     [($ zodiac:list _ _ _
+                         (($ zodiac:symbol _ _ _ tag)
+                          ($ zodiac:list _ _ _ (exp . imports))))
+                      (list tag
+                            (parse exp env)
+                            (apply append
+                                   (map
+                                    (match-lambda
+                                     [($ zodiac:symbol _ _ _ sym)
+                                      (list (cons #f sym))]
+                                     [($ zodiac:list _ _ _
+                                         (($ zodiac:symbol _ _ _ tag)
+                                          ($ zodiac:symbol _ _ _ syms)
+                                          ...))
+                                      (map (lambda (sym) (cons tag sym))
+                                           syms)]
+                                     [_ (syntax-error exp "Bad link imp")])
+                                    imports)))]
+                     [_ (syntax-error exp "Bad link")])
+                    links)]
+                  [exports
+                   (apply 
+                    append
+                    (map
+                     (match-lambda
+                      [($ zodiac:list _ _ _
+                          (($ zodiac:symbol _ _ _ tag) 
+                           (or ($ zodiac:list _ _ _ 
+                                  (($ zodiac:symbol _ _ _ i-eids)
+                                   ($ zodiac:symbol _ _ _ e-eids)))
+                               (and ($ zodiac:symbol _ _ _ i-eids)
+                                    ($ zodiac:symbol _ _ _ e-eids))) ...))
+                       (map 
+                        (lambda (i-eid e-eid) (list tag i-eid e-eid))
+                        i-eids e-eids)]
+                      [_ (syntax-error exp "Bad link export")])
+                     exports))])
+                 (zodiac:make-compound-unit-form
+                  o s f (box 0) imports links exports))]
+
+               ;; --- invoke-unit ---
+               [('invoke-unit exp . ((and vars ($ zodiac:symbol)) ...))
+                (zodiac:make-invoke-unit-form
+                 o s f (box 0)
+                 (parse exp env) 
+                 (map (lambda (var) (parse-sym var env)) vars))]
+
+               ;; --- structures ---
+               [((or 'struct 'typed-structure 'const-typed-structure) 
+                 first
+                 ($ zodiac:list _ _ _ fields))
+                (let*-vals
+                 ([(tag parent)
+                   (match first
+                     [($ zodiac:symbol _ _ _ tag) (values tag #f)]
+                     [($ zodiac:list _ _ _
+                         (($ zodiac:symbol _ _ _ tag) parent))
+                      (values tag (parse parent env))])]
+                  [fields (map zodiac:stripper fields)])
+                 (zodiac:make-struct-form
+                  o s f (box 0)
+                  tag (eq? sym 'const-typed-structure) parent fields))]
+
+               ;; -------------------------------------------------------
+               ;; MrSpidey specific code
+
+               [('poly exp)
+                (zodiac:make-poly-form 
+                 o s f (box 0) (parse exp env))]
+               [(': exp type)
+                (zodiac:make-:-form o s f (box 0) 
+                                    (parse exp env)
+                                    (zodiac:stripper type))]
+
+               [('type:-quote
+                  ($ zodiac:list _ _ _ 
+                    (($ zodiac:symbol _ _ _ (or 'quote '#%quote))
+                      ($ zodiac:list _ _ _ (type  . attrs)))))
+                 (zodiac:make-type:-form o s f (box 0) 
+                   (zodiac:stripper type)
+                   (map zodiac:stripper attrs))]
+
+               [('st:control para val)
+                (zodiac:make-st:control-form o s f (box 0)
+                                             (zodiac:stripper para)
+                                             (zodiac:stripper val))]
+
+               [((or 'cache-exp-quote 'cache-inv-quote)
+                 ($ zodiac:list _ _ _ 
+                    (($ zodiac:symbol _ _ _ (or 'quote '#%quote)) exp))
+                 ($ zodiac:string _ _ _ za))
+                (when (string=? za (regexp-replace ".za$" za ""))
+                  (syntax-error exp "Cache filename must end in .za"))
+                (zodiac:make-cache-form 
+                 o s f (box 0) exp 
+                 (normalize-path za)
+                 (case sym
+                   [cache-exp-quote 'exp]
+                   [cache-inv-quote 'inv]
+                   [else 
+                    (mrspidey:internal-error 'parser "Bad sym ~s" sym)])
+                 (current-directory))]
+               
+               ;; -------------------------------------------------------
+               [else (syntax-error exp)])]
+            [(memq sym define-keywords) 
+             (syntax-error-no-exp exp "Defines not allowed")]
+            [else (fail)]))]
+
+        ;; Don't handle vectors or improper lists
+        ;; Applications
+              
+        [($ zodiac:list o s f (and l (fn . exps)))
+         (zodiac:make-app o s f (box 0) 
+                          (parse fn env)
+                          (parse-exps exps env))]
+        [($ zodiac:list o s f ())
+         (zodiac:make-quote-form o s f (box 0) '())]
+        [_ (syntax-error exp)]))))
+
+
+
+
+(define (parse-defs defs env)
+  (let*-vals
+    ([varss (mapLR 
+              (match-lambda
+                [($ zodiac:list _ _ _ 
+                   (($ zodiac:symbol _ _ _ '#%define-values)
+                     ($ zodiac:list _ _ _ vars)
+                     exp))
+                  vars]
+                [_ '()])
+              defs)]
+      [(boundss nuenv) (do-bindingss env varss)]
+      [_ (for-each 
+           (lambda (name) (zodiac:set-bound-mutated! name #t))
+           (apply append boundss))]
+      [defs
+        (map
+          (lambda (def bounds)
+            (pretty-debug-front `(parse-def ,(zodiac:stripper def)))
+            (mrspidey:zprogress "Parsing" (zodiac:zodiac-start def))
+            (match def
+              ;; Special forms
+              [($ zodiac:list o s f 
+                 (and l (($ zodiac:symbol _ _ _ sym) . body)))
+                (=> fail)
+                (let ([sym (strip-hash-percent sym)])
+                  (cond
+                    [(not (memq sym define-keywords)) (fail)]
+                    [else
+                      (match (cons sym body)
+
+                        [('define-values ($ zodiac:list _ _ _ vars) exp)
+                          (zodiac:make-define-values-form 
+                            o s f (box 0)
+                            (map 
+                              (match-lambda
+                                [(and bound ($ zodiac:bound o s f _ sym))
+                                  (zodiac:make-lexical-varref o s f (box 0) 
+                                    sym bound)])
+                              bounds)
+                            (parse exp nuenv))]
+
+                        ;; ----------------------------------------------------
+                        ;; MrSpidey specific code
+
+                        [('define-type ($ zodiac:symbol _ _ _ sym) type)
+                          (zodiac:make-define-type-form 
+                            o s f (box 0) 
+                            sym (zodiac:stripper type))]
+
+                        [('define-constructor ($ zodiac:symbol _ _ _ sym) 
+                           . modes)
+                          (let ([modes (map zodiac:stripper modes)])
+                            (assert-syn def (andmap boolean? modes))
+                            (zodiac:make-define-constructor-form o s f (box 0) 
+                              sym modes))]
+
+                        ;; ----------------------------------------------------
+                        [else (fail)])]))]
+
+              [exp (parse exp nuenv)]))
+          defs boundss)])
+    (unless (null? defs)
+      (mrspidey:zprogress "Parsing" (zodiac:zodiac-finish (rac defs))))
+    (values defs nuenv)))
+
+;; ----------------------------------------------------------------------
+
+

collects/mrspidey/Sba/poly.ss

@@ -0,0 +1,626 @@
+;; poly.ss
+;; ----------------------------------------------------------------------
+;; Preprocesses the program
+
+
+;; ----------------------------------------------------------------------
+
+(define debugging-topo #f)
+(defmacro pretty-debug-topo args
+  `(when debugging-topo (pretty-print ,@args)))
+
+; ======================================================================
+
+(define (st:poly file)
+  (st: (topo-file file)))
+  
+; ======================================================================
+
+(define-struct def-info (def out in to from color))
+
+(define (topo-file file)
+  (let ([file (normalize-path file)])
+    (let*-vals 
+      ( [sexps (zodiac:read* (open-code-file file) file)]
+        [(defs free-names)
+          (dynamic-let ([current-directory (path-only file)])
+            (top-level-parse-defs sexps))]
+        [prims-refd (map zodiac:bound-var free-names)]
+        [_ (pretty-debug-topo `(prims-refd ,prims-refd))]
+        [prim-sexps
+          (filter-map
+            (lambda (name)
+              (or
+                (ormap
+                  (match-lambda
+                    [(and d ('define (? (lambda (n) (eq? n name))) _))
+                      (let* ( [p (open-output-string)]
+                              [_ (pretty-print d p)]
+                              [_ (close-output-port p)]
+                              [p (open-input-string (get-output-string p))]
+                              [p (system-expand-if-necy p)]
+                              [d (zodiac:read p 
+                                   (zodiac:make-location 1 1 0 "prim-file"))])
+                        (d))]
+                    [_ #f])
+                  r4rs-prims)
+                (begin
+                  (unless (memq name real-primitives)
+                    (printf "Warning: Bad primitive ~s~n" name))
+                  #f)))
+            prims-refd)]
+        [_ (pretty-debug-topo `(prim-sexps ,(map zodiac:stripper prim-sexps)))]
+        [all-sexps (append prim-sexps sexps)]
+        [(defs free-names)
+          (dynamic-let ([current-directory (path-only file)])
+            (top-level-parse-defs all-sexps))]
+        [def->di
+          (lambda (def)
+            (let ([di (make-def-info def '() '() '() '() #f)])
+              (match def
+                [($ zodiac:define-values-form _ _ _ _ lvrs exp)
+                  (set-def-info-out! di 
+                    (map zodiac:lexical-varref-binding lvrs))
+                  (set-def-info-in! di (zodiac:free-refs exp))]
+                [exp (set-def-info-in! di (zodiac:free-refs exp))])
+              di))]
+        [di* (mapLR def->di defs)]
+        [_ (for-each
+             (lambda (di)
+               (pretty-debug-topo
+                 `(DEF ,(zodiac:stripper (def-info-def di))
+                    ,(map zodiac:bound-var (def-info-out di))
+                    ,(map zodiac:bound-var (def-info-in di)))))
+             di*)]
+
+        [_ (for-each
+             (lambda (di1)
+               (for-each
+                 (lambda (sym)
+                   (for-each
+                     (lambda (di2)
+                       (when (memq sym (def-info-out di2))
+                         (set-def-info-to! di1 
+                           (cons di2 (def-info-to di1)))
+                         (set-def-info-from! di2
+                           (cons di1 (def-info-from di2)))))
+                     di*))
+                 (def-info-in di1)))
+             di*)]
+           [_ (pretty-debug-topo "to/from fields filled")]
+                      
+           [dfs (lambda (di* field-sel)
+                  (for-each (lambda (di) (set-def-info-color! di 'white)) di*)
+                  (let ([done '()])
+                    (letrec ([visit 
+                              (lambda (di)
+                                (when (eq? (def-info-color di) 'white)
+                                  (set-def-info-color! di 'black)
+                                  (for-each visit (field-sel di))
+                                  (set! done (cons di done))))])
+                      (for-each visit di*)
+                      done)))]
+
+           ;; do topological sort. See "Intro to Algs", p. 489
+
+           [di*1 (dfs di* def-info-to)]
+           ;; di*1 contains definitions before references
+           [show-di
+            (lambda (di)
+              `(DEF
+                 ,(map zodiac:bound-var (def-info-out di))
+                 ,(map zodiac:bound-var (def-info-in di))))]
+           [show (lambda (str di*) 
+                   (pretty-debug-topo str)
+                   (pretty-debug-topo (map show-di di*)))]
+           [_ (show "di*1" di*1)]
+           [di*2 (dfs di*1 def-info-from)]
+           [_ (show "di*2" di*2)]
+           
+           ;; Calculate list of strongly connected components
+
+           [_ (for-each (lambda (di) (set-def-info-color! di 'white)) di*)]
+           [sccs
+            (mapLR
+             (lambda (di)
+               (let ([scc '()])
+                 (recur loop ([di di])
+                   (when (eq? (def-info-color di) 'white)
+                     (set-def-info-color! di 'black)                     
+                     (set! scc (cons di scc))
+                     (for-each loop (def-info-to di))))
+                 scc))
+             di*2)]
+           [sccs (filter (lambda (x) (not (null? x))) sccs)]
+
+           [_ (begin
+                (pretty-debug-topo 'SCCS)
+                (for-each (lambda (scc) (show "scc" scc)) sccs))]
+
+           [my-begin 
+            (lambda (first rest)
+              (make-zodiac:begin-form 
+               first rest
+               (zodiac:no-location)(zodiac:no-location) (box #f)))]
+         
+           [value-def?
+            (match-lambda
+             [($ zodiac:define-values-form _ _ _ _ _ exp)
+              (zodiac:value? exp)]
+             [_ #f])]
+           
+           ;; --- Figure out which are polymorphic
+           ;; Go from end up to know if multiple refs for each var
+           ;; A ref inside a polymorphic def counts as multiple refs
+
+           [vars-single-ref '()]
+           [vars-multi-ref '()]
+           [add-multi-ref!
+            (lambda (var)
+                (set! vars-multi-ref (set-add var vars-multi-ref)))]
+           [add-single-ref!
+            (lambda (var)
+              (if (element-of? var vars-single-ref)
+                  (add-multi-ref! var)
+                  (set! vars-single-ref (set-add var vars-single-ref))))]
+
+           [sccs2 ;; include polymorphism flag
+            (mapRL
+             (lambda (scc)
+               (let* ( [values?
+                         (andmap 
+                           (match-lambda 
+                             [($ def-info def out) (value-def? def)])
+                           scc)]
+                       [mutable? 
+                         '(ormap 
+                            (match-lambda
+                              [($ def-info def out)
+                                (ormap (lambda (o) (memq o mutable-syms)) out)])
+                            scc)]
+                       [mutable? #f]
+                       [defs (apply append (map def-info-out scc))]
+                       [refs (apply append (map def-info-in scc))]
+                       [multi-refs
+                         (match defs
+                           [(def) (element-of? def vars-multi-ref)]
+                           [() #f]
+                           [defs #t])]
+                       [poly-flag 
+                         (if (and values? (not mutable?))
+                           (if multi-refs 'poly 'poly1ref)
+                           #f)])
+
+                 (pretty-debug-topo
+                   `( defs  ,(map zodiac:bound-var defs) 
+                      refs ,(map zodiac:bound-var refs)
+                      values? ,values? mutable? ,mutable?
+                      multi-refs ,multi-refs poly-flag ,poly-flag))
+
+                 (if (eq? poly-flag 'poly)
+                   (for-each add-multi-ref! refs)
+                   (for-each add-single-ref! refs))
+
+                 (cons poly-flag scc)))
+             sccs)]
+
+        [_ (pretty-print
+             `(SCCS
+                ,(map
+                   (match-lambda
+                     [(poly . di*)
+                       (let* ( [o (apply append (map def-info-out di*))]
+                               [ov (map zodiac:bound-var o)])
+                         (case poly
+                           [poly (cons '-->POLY ov)]
+                           [poly1ref (cons '-->POLY1REF ov)]
+                           [#f ov]))])
+                   sccs2)))]
+
+        [nu-program
+          ;; Return new program
+          (apply append
+            (map
+              (match-lambda
+                [('poly .
+                   (($ def-info ($ zodiac:define-values-form _ _ _ _ 
+                                  (lvrs) exps))
+                     ...))
+                  (let ([syms
+                          (map (lambda (lvr)
+                                 (zodiac:bound-var 
+                                   (zodiac:lexical-varref-binding lvr)))
+                            lvrs)])
+                    (if (= (length syms) 1)
+                    `((define ,(car syms)
+                        (poly (letrec
+                                ([,(car syms) ,(zodiac:stripper (car exps))])
+                                ,(car syms)))))
+                      `((define-values ,syms
+                          (poly (letrec*-values 
+                                  ([,syms
+                                     (values 
+                                       ,@(map zodiac:stripper exps))])
+                                (values ,@syms)))))))]
+                [(_ . di*)
+                  (map zodiac:stripper (map def-info-def di*))])
+              sccs2))]
+
+        [outfile (regexp-replace ".ss$" file ".poly.ss")]
+        [_ (when (eq? outfile file)  
+             (error 'topo-file "Bad suffix on ~s" file))]
+        [_ (delete-file outfile)]
+        [p3 (open-output-file outfile)])
+
+      (printf "----------PROGRAM----------~n")
+      (for-each
+        (lambda (def)
+          (pretty-debug-topo def)
+          (pretty-print def p3))
+        nu-program)
+      
+      (close-output-port p3)
+      outfile)))
+
+; ======================================================================
+
+(define zodiac:value?
+  (match-lambda
+    [(or
+       ($ zodiac:quote-form)
+       ($ zodiac:lambda-form)
+       ($ zodiac:case-lambda-form)
+       ($ zodiac:lexical-varref)) #t]
+    [($ zodiac:letrec-values-form 
+       _ _ _ _ vars 
+       ((? zodiac:value?) ...)
+       (? zodiac:value?)) #t]
+    [_ #f]))
+
+;; ----------------------------------------------------------------------
+
+(define r4rs-prims
+  `((define caar (lambda (x) (car (car x))))
+    (define cadr (lambda (x) (car (cdr x))))
+    (define cdar (lambda (x) (cdr (car x))))
+    (define cddr (lambda (x) (cdr (cdr x))))
+    (define caaar (lambda (x) (car (car (car x)))))
+    (define caadr (lambda (x) (car (car (cdr x)))))
+    (define cadar (lambda (x) (car (cdr (car x)))))
+    (define caddr (lambda (x) (car (cdr (cdr x)))))
+    (define cdaar (lambda (x) (cdr (car (car x)))))
+    (define cdadr (lambda (x) (cdr (car (cdr x)))))
+    (define cddar (lambda (x) (cdr (cdr (car x)))))
+    (define cdddr (lambda (x) (cdr (cdr (cdr x)))))
+    (define caaaar (lambda (x) (car (car (car (car x))))))
+    (define caaadr (lambda (x) (car (car (car (cdr x))))))
+    (define caadar (lambda (x) (car (car (cdr (car x))))))
+    (define caaddr (lambda (x) (car (car (cdr (cdr x))))))
+    (define cadaar (lambda (x) (car (cdr (car (car x))))))
+    (define cadadr (lambda (x) (car (cdr (car (cdr x))))))
+    (define caddar (lambda (x) (car (cdr (cdr (car x))))))
+    (define cadddr (lambda (x) (car (cdr (cdr (cdr x))))))
+    (define cdaaar (lambda (x) (cdr (car (car (car x))))))
+    (define cdaadr (lambda (x) (cdr (car (car (cdr x))))))
+    (define cdadar (lambda (x) (cdr (car (cdr (car x))))))
+    (define cdaddr (lambda (x) (cdr (car (cdr (cdr x))))))
+    (define cddaar (lambda (x) (cdr (cdr (car (car x))))))
+    (define cddadr (lambda (x) (cdr (cdr (car (cdr x))))))
+    (define cdddar (lambda (x) (cdr (cdr (cdr (car x))))))
+    (define cddddr (lambda (x) (cdr (cdr (cdr (cdr x))))))
+    (define list (lambda a a))
+    (define length
+      (lambda (a)
+        (recur loop ((a a) (len 0))
+          (if (null? a)
+              len
+              (loop (cdr a) (+ 1 len))))))
+    (define append
+      (lambda a
+        (letrec ((app2 (lambda (a b)
+                         (if (null? a)
+                             b
+                             (cons (car a) (app2 (cdr a) b))))))
+          (recur loop ((a a))
+            (cond ((null? a) '())
+                  ((null? (cdr a)) (car a))
+                  (else (app2 (car a) (loop (cdr a)))))))))
+    (define reverse
+      (lambda (a)
+        (recur loop ((a a) (acc '()))
+          (if (null? a)
+              acc
+              (loop (cdr a) (cons (car a) acc))))))
+    (define list-tail
+      (lambda (a n)
+        (if (zero? n)
+            a
+            (list-tail (cdr a) (- n 1)))))
+    (define list-ref
+      (lambda (a n)
+        (if (zero? n)
+            (car a)
+            (list-ref (cdr a) (- n 1)))))
+    (define memq
+      (lambda (x a)
+        (cond ((null? a) #f)
+              ((eq? x (car a)) a)
+              (else (memq x (cdr a))))))
+    (define memv
+      (lambda (x a)
+        (cond ((null? a) #f)
+              ((eqv? x (car a)) a)
+              (else (memv x (cdr a))))))
+    (define member
+      (lambda (x a)
+        (cond ((null? a) #f)
+              ((equal? x (car a)) a)
+              (else (member x (cdr a))))))
+    (define assq
+      (lambda (x a)
+        (cond ((null? a) #f)
+              ((eq? x (car (car a))) (car a))
+              (else (assq x (cdr a))))))
+    (define assv
+      (lambda (x a)
+        (cond ((null? a) #f)
+              ((eqv? x (car (car a))) (car a))
+              (else (assv x (cdr a))))))
+    (define assoc
+      (lambda (x a)
+        (cond ((null? a) #f)
+              ((equal? x (car (car a))) (car a))
+              (else (assoc x (cdr a))))))
+    (define string->list
+      (lambda (s)
+        (recur loop ((n (- (string-length s) 1)) (acc '()))
+          (if (negative? n)
+              acc
+              (loop (- n 1) (cons (string-ref s n) acc))))))
+;    (define list->string
+;      (lambda (a)
+;        (apply string a)))
+    (define list->string
+      (lambda (a)
+        (letrec ([length
+                  (lambda (a)
+                    (recur loop ((a a) (len 0))
+                      (if (null? a)
+                          len
+                          (loop (cdr a) (+ 1 len)))))])
+          (let ((s (make-string (length a))))
+            (recur loop ((i 0) (a a))
+              (if (null? a)
+                  s
+                  (begin
+                    (string-set! s i (car a))
+                    (loop (+ 1 i) (cdr a)))))))))
+    (define vector->list
+      (lambda (v)
+        (recur loop ((n (- (vector-length v) 1)) (acc '()))
+          (if (negative? n)
+              acc
+              (loop (- n 1) (cons (vector-ref v n) acc))))))
+;    (define list->vector
+;      (lambda (a)
+;        (apply vector a)))
+    (define list->vector
+      (lambda (a)
+        (letrec ([length
+                  (lambda (a)
+                    (recur loop ((a a) (len 0))
+                      (if (null? a)
+                          len
+                          (loop (cdr a) (+ 1 len)))))])
+          (if (null? a)
+              (vector)
+              (let ((v (make-vector (length a) (car a))))
+                (recur loop ((i 1) (a (cdr a)))
+                  (if (null? a)
+                      v
+                      (begin
+                        (vector-set! v i (car a))
+                        (loop (+ 1 i) (cdr a))))))))))
+    (define map
+      (lambda (f a . args)
+        (letrec ((map1 (lambda (f l)
+                         (if (null? l)
+                             '()
+                             (cons (f (car l))
+                                   (map1 f (cdr l))))))
+                 (map2 (lambda (f l1 l2)
+                         (cond ((null? l1)
+                                '())
+                               ((null? l2)
+                                (error 'map "lists differ in length"))
+                               (else
+                                 (cons (f (car l1) (car l2))
+                                       (map2 f (cdr l1) (cdr l2)))))))
+                 (map* (lambda (f l*)
+                         (if (null? (car l*))
+                             '()
+                             (cons (let ((l (map1 car l*)))
+                                     (if (null? l)
+                                         (f)
+                                         (apply f l)))
+                                   (map* f (map1 cdr l*)))))))
+          (cond ((null? args)
+                 (map1 f a))
+                ((null? (cdr args))
+                 (map2 f a (car args)))
+                (else
+                  (map* f (cons a args)))))))
+    (define for-each
+      (lambda (f a . args)
+        (letrec ((map (lambda (f l)
+                         (if (null? l)
+                             '()
+                             (cons (f (car l))
+                                   (map f (cdr l)))))))
+          (letrec ((for-each1 (lambda (f l)
+                                (if (null? l)
+                                    (void)
+                                    (begin
+                                      (f (car l))
+                                      (for-each1 f (cdr l))))))
+                   (for-each2 (lambda (f l1 l2)
+                                (cond ((null? l1)
+                                       (void))
+                                      ((null? l2)
+                                       (error 'for-each "lists differ in length"))
+                                      (else
+                                        (f (car l1) (car l2))
+                                        (for-each2 f (cdr l1) (cdr l2))))))
+                   (for-each* (lambda (f l*)
+                                (if (null? (car l*))
+                                    (void)
+                                    (begin
+                                      (let ((l (map car l*)))
+                                        (if (null? l)
+                                            (f)
+                                            (apply f l)))
+                                      (for-each* f (map cdr l*)))))))
+            (cond ((null? args)
+                   (for-each1 f a))
+                  ((null? (cdr args))
+                   (for-each2 f a (car args)))
+                  (else
+                    (for-each* f (cons a args))))))))
+    (define call-with-input-file
+      (lambda (s f)
+        (let* ((p (open-input-file s))
+               (v (f p)))
+          (close-input-port p)
+          v)))
+    (define call-with-output-file
+      (lambda (s f)
+        (let* ((p (open-output-file s))
+               (v (f p)))
+          (close-output-port p)
+          v)))
+    (define with-input-from-file
+      (lambda (s f)
+        ; no way to switch current input in R4RS Scheme
+        (error 'with-input-from-file "not supported")
+        (f)))
+    (define with-output-to-file
+      (lambda (s f)
+        ; no way to switch current output in R4RS Scheme
+        (error 'with-output-to-file "not supported")
+        (f)))
+    
+    (define make-promise
+      (lambda (thunk)
+        (let ([first #t]
+              [val #f])
+          (lambda ()
+            (cond
+             [(eq? first 'forcing)
+              (error 'force "recursive force")]
+             [(eq? first #t)
+              (set! first 'forcing)
+              (set! val (thunk))
+              (set! first #f)
+              val]
+             [else val])))))
+    (define force (lambda (promise) (promise)))
+    (define make-list
+      (lambda (n val)
+        (recur loop ((n n))
+          (if (< n 1)
+              '()
+              (cons val (loop (- n 1)))))))
+    (define andmap
+      (lambda (f list0 . lists)
+        (if (null? list0)
+            (and)
+            (recur loop ((lists (cons list0 lists)))
+              (if (null? (cdr (car lists)))
+                  (apply f (map car lists))
+                  (and (apply f (map car lists))
+                       (loop (map cdr lists))))))))
+    (define ormap
+      (lambda (f list0 . lists)
+        (if (null? list0)
+            (or)
+            (recur loop ((lists (cons list0 lists)))
+              (if (null? (cdr (car lists)))
+                  (apply f (map car lists))
+                  (or (apply f (map car lists))
+                      (loop (map cdr lists))))))))
+    (define dynamic-wind
+      (lambda (in doit out)
+        (let* ([a (in)]
+               [b (doit)]
+               [c (out)])
+          b)))
+    (define not (lambda (x) (if x #f #t)))
+    (define add1 (lambda (x) (+ x 1)))
+    (define sub1 (lambda (x) (- x 1)))
+    (define equal? 
+      (lambda (x y)
+        (or (eqv? x y)
+            (and (pair? x) (pair? y) 
+                 (equal? (car x) (car y))
+                 (equal? (cdr x) (cdr y)))
+            (and (vector? x) (vector? y)
+                 (= (vector-length x) (vector-length y))
+                 (recur loop ([i (vector-length x)])
+                   (or (zero? i)
+                       (let ([i (- i 1)])
+                         (and (equal? (vector-ref x i) (vector-ref y i))
+                              (loop i)))))))))
+    (define negative? (lambda (x) (< x 0)))
+    (define list? (lambda (x) (or (null? x)
+                                  (and (pair? x) (list? (cdr x))))))
+    (define reverse!
+      (lambda (x)
+        (recur loop ([x x][p '()])
+          (let ([q (cdr x)])
+            (set-cdr! x p)
+            (if (null? q)
+                x
+                (loop q x))))))
+  (define even? (lambda (x) (or (zero? x) (odd? (sub1 x)))))
+  (define odd? (lambda (x) (even? (sub1 x))))
+))
+
+(define real-primitives
+  '(car cdr zero? null? nil null + - * / apply
+        number? cons pair? 
+        < > <= >= = <>
+        vector make-vector vector-length vector-ref vector-set!
+        void error display newline remainder quotient modulo abs expt min 
+        real-part even sqrt cos integer? exact?
+        eq? eqv?
+        call-with-values 
+        boolean? procedure? symbol? gensym
+        set-cdr! set-car! printf random 
+        string-ref symbol->string number->string symbol? char=? 
+        char? string? vector?
+     #%eqv #%void 
+     string->symbol string-append string<? #%global-defined-value
+))
+
+;; ----------------------------------------------------------------------
+
+(define (do-topo-files files)
+  (let* ([file-thunk* (files->file-thunk* files)]
+         [defs1 (load-parse-expand file-thunk*)]
+         [_ (set! defs-expanded defs1)]
+         [defs2 (map bind-def defs1)]
+         [_ (set! defs-bind defs2)]
+         [def (topological-sort defs2)])
+    (zodiac:expr-stripper def)))
+
+(define (test-topo files out)
+  (when (file-exists? out) (delete-file out))
+  (let* ([file-thunk* (files->file-thunk* files)]
+         [defs1 (load-parse-expand file-thunk*)]
+         [_ (set! defs-expanded defs1)]
+         [defs2 (map bind-def defs1)]
+         [_ (set! defs-bind defs2)]
+         [def (topological-sort defs2)])
+    (pretty-print (zodiac:expr-stripper def))))
+
+;; ----------------------------------------------------------------------

collects/mrspidey/Sba/program.ss

@@ -0,0 +1,127 @@
+;; program.ss
+;; Handles cormac's program first-order structure for units
+; ----------------------------------------------------------------------
+; Copyright (C) 1995-97 Cormac Flanagan
+;
+; This program is free software; you can redistribute it and/or
+; modify it under the terms of the GNU General Public License
+; version 2 as published by the Free Software Foundation.
+; 
+; This program is distributed in the hope that it will be useful,
+; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+; GNU General Public License for more details.
+; 
+; You should have received a copy of the GNU General Public License
+; along with this program; if not, write to the Free Software
+; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
+; ----------------------------------------------------------------------
+;; Global environment stuff
+
+(define global-def-env '())
+(define global-result (void))
+(define global-defs-parsed (void))
+
+;; ----------------------------------------------------------------------
+
+(define (analyze-program file)
+  ;; file should be normalized
+  (let ([file (normalize-path file)])
+    (pretty-debug `(analyze-program ,file , (path-only (normalize-path file))))
+    (init-constructor-env!)
+    (initialize-language!)
+    (init-expand!)
+    (clear-file-time-cache!)
+    (let*-vals 
+      ( [sexps (zodiac:read* (open-code-file file) file)]
+        [_ (when debugging-front
+             (printf "~n--Loaded program------------------~n")
+             (for-each 
+               (lambda (sexp) (pretty-print-debug (zodiac:stripper sexp)))
+               sexps)
+             (printf "----------------------------------~n"))]
+        [(defs free-names)
+          (parameterize ([current-load-relative-directory (path-only file)])
+            (my-scheme-expand-program sexps))]
+        [_ (set! global-defs-parsed defs)]
+        [_ (when debugging-front
+             (printf "~n--Parsed program------------------~n")
+             (for-each
+               (lambda (def) (pretty-print-debug (zodiac:stripper def)))
+               defs)
+             (printf "----------------------------------~n"))]
+        [init-env (get-default-bindings free-names)])
+
+      (pretty-debug `(init-env ,(atenv->pretty init-env)))
+      ;; Now do analyis 
+
+      (let-values ([(env refs result) (top-level-traverse-defs defs init-env)])
+
+        (pretty-debug '(fixing up envs))
+        (set! global-def-env env)
+        (set! global-result result)
+        ;;(assert (null? refs) refs (map zodiac:binding-var (map car refs)))
+        '(for-each
+           (lambda (ref)
+             (mrspidey:warning 
+               (format "Unbound variable ~s" (zodiac:binding-var (car ref)))))
+           refs)
+
+        ;; --- Fix up type variables
+        ;;(set! global-def-env (append global-def-env global-tdef-env))
+        (report-duplicate-defs global-tdef-env)
+        (report-unbound-vars 
+          (connect-refs-defs global-tref-env global-tdef-env))
+        (connect-bangs-defs global-tbang-env global-tdef-env)
+
+        (when (not (st:whole-program))
+          (put-context-top-s defs env result))
+
+        ;;(show-stat-small)
+
+        defs))))
+
+;; ----------------------------------------------------------------------
+
+(define (put-context-top-s defs env result)
+  (mrspidey:progress "Partial program analysis")
+  ;;(show-stat-small)
+  (when result (new-leq-top-s! (FlowType->Tvar result)))
+  (when (and defs env)
+    (for-each
+      (match-lambda
+        [($ zodiac:define-values-form _ _ _ _ refs)
+          (for-each
+            (lambda (ref)
+              (new-leq-top-s! 
+                (FlowType->Tvar
+                  (atenv:lookup env (zodiac:varref-binding ref)))))
+            refs)]
+        [_ (void)])
+      defs)))
+
+;; ---------------------------------------------------------------------- 
+;; initialize-analysis!
+
+(define (initialize-analysis!)
+  (pretty-debug '(initialize-analysis!))
+  (init-constructor-env!)
+  (let ([old-kernel (save-kernel-state)])
+    (init-kernel!)
+    ;; First free old stuff
+    (when (st:zero-old-constraint-sets) (free-kernel-state! old-kernel)))
+  (init-global-tenv! '() '() '())
+  (init-common-AV!)
+  (pretty-debug '(analysis-initialized)))
+
+;; ======================================================================
+
+(define (show-global)
+  (list 'DEF (atenv->pretty global-def-env)
+        ;;'TDEF (atenv->pretty global-tdef-env)
+    ))
+
+;; ----------------------------------------------------------------------
+
+
+

collects/mrspidey/Sba/results.ss

@@ -0,0 +1,289 @@
+; results.ss
+; Shows results of set-based analysis
+; ----------------------------------------------------------------------
+; Copyright (C) 1995-97 Cormac Flanagan
+;
+; This program is free software; you can redistribute it and/or
+; modify it under the terms of the GNU General Public License
+; version 2 as published by the Free Software Foundation.
+; 
+; This program is distributed in the hope that it will be useful,
+; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+; GNU General Public License for more details.
+; 
+; You should have received a copy of the GNU General Public License
+; along with this program; if not, write to the Free Software
+; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
+; ----------------------------------------------------------------------
+
+;--------------------------------------------------------------------
+; Configuration
+
+(define show-val-args #t)
+(define show-elements #t)
+(define show-AV #t)
+(define show-edgeto #t)
+(define show-constraint #t)
+
+;--------------------------------------------------------------------
+; Showing results
+
+(define st:show (lambda l (for-each show-ftype (apply select l))))
+
+(define show-ftype
+                                        ; Show value of ftype
+  (lambda (ftype)
+    (let* ([num (FlowType-num ftype)]
+            [arrowto (FlowType-arrowto ftype)]
+            [arrowfrom (FlowType-arrowfrom ftype)]
+            [var (FlowType-name ftype)]
+            [done #f]
+            [makespaces
+              (lambda (s)
+                (if done
+                  (printf "~a [~a]" (padr "" 20) s)
+                  (begin
+                    (set! done #t)
+                    (printf 
+                      "~a [~a]" 
+                      (padr (symbol->string var) 20)
+                      s))))])
+      (when (not (null? arrowto))
+        (makespaces "arrowto")
+        (for-each
+          (lambda (to) (printf "| ~a " (FlowType-name to)))
+          arrowto)
+        (newline))
+      (when (not (null? arrowfrom))
+        (makespaces "arrowfrom")
+        (for-each
+          (lambda (from) (printf "| ~a " (FlowType-name from)))
+          arrowfrom)
+        (newline))
+      (when (FlowType-type-annotation ftype)
+        (makespaces "visable")
+        (if (string? (FlowType-type-annotation ftype))
+          (display (FlowType-type-annotation ftype)))
+        (newline))
+      (when (FlowType-values-ftype ftype)
+        (makespaces "values-type")
+        (printf "~s~n" (FlowType-name (FlowType-values-ftype ftype))))
+
+      (if (Tvar? ftype)
+        (let* ( [Tvar ftype]
+                [objs (Tvar-objs Tvar)]
+                [constraints (Tvar-constraints Tvar)]
+                [edgeto (Tvar-edgeto Tvar)]
+                [edgefrom (Tvar-edgefrom Tvar)])
+
+          (if (and show-AV (not (null? (get-Tvar-objs Tvar))))
+            (begin
+              (makespaces "AV    ")
+              (begin0
+                (show-sba-objs (get-Tvar-objs Tvar))
+                (newline)))
+            '()) 
+          (if (and show-AV (not (null? (Tvar-orig-objs Tvar))))
+            (begin
+              (makespaces "origAV")
+              (begin0
+                (show-sba-objs (Tvar-orig-objs Tvar))
+                (newline)))
+            '())
+          (if #t
+            (begin
+              (makespaces "num   ")
+              (printf "~s~n" (FlowType-num Tvar)))
+            '())
+          (if (and show-constraint (not (null? (Tvar-constraints Tvar))))
+            (begin
+              (makespaces "constr")
+              ;; Show each constraint
+              (map 
+                (match-lambda 
+                  [($ con num template field-no Tvar sign)
+                    (printf "[~s ~s ~s -> ~s] "
+                      (if (template? template)
+                        (template-type template)
+                        template)
+                      field-no sign
+                      (Tvar-name Tvar))]
+                  [($ con-filter num ($ filter bool templates) Tvar)
+                    (printf "[filter ~s ~s -> ~s] "
+                      (map template-type templates)
+                      bool (Tvar-name Tvar))]
+                  [($ con-top-s)
+                    (printf "[top-s] ")])
+                (Tvar-constraints Tvar))
+              (newline)
+              '())
+            '())
+              
+          (if (and show-edgeto (not (null? edgeto)))
+            (begin
+              (makespaces "edgeto")
+              (map (lambda (to) 
+                     (printf "| ~a " (Tvar-name to)))
+                edgeto)
+              (newline)
+              edgeto)
+            '())
+          (if (and show-edgeto (not (null? edgefrom)))
+            (begin
+              (makespaces "edgefr")
+              (map (lambda (from) 
+                     (printf "| ~a " (Tvar-name from)))
+                edgefrom)
+              (newline)
+              edgefrom)
+            '())
+          (for-each
+            (lambda (name get-nt)
+              (if (and (get-nt Tvar)
+                    (not (null? (get-nt Tvar)))
+                    (not (null? (NT-rhs* (get-nt Tvar)))))
+                (begin
+                  (makespaces name)
+                  (for-each (match-lambda
+                              [($ rhs grsym nt)
+                                (printf "| ~a ~a "
+                                  (grsym->rep grsym)
+                                  (if (null? nt)
+                                    '()
+                                    (nt->sym nt)))])
+                    (NT-rhs* (get-nt Tvar)))
+                  (newline))
+                '()))
+            (list "L     " "U     " "PL    " "PU    "
+              )
+            (list Tvar-L Tvar-U Tvar-PL Tvar-PU
+              )))
+
+        (begin
+          (makespaces "fo-Atype")
+          (printf "~s~n" (FlowType->pretty ftype)))))))
+
+(define show-sba-objs
+  (lambda (objs)
+    (recur loop2 ([objs objs][dep '()])
+      (match objs
+        [()  dep]
+        [(AV . rest)
+          (match-let
+            ([(print-representation . new-dep)
+               (print-rep-AV AV)])
+            (printf "| ~s ~a " (AV-num AV) print-representation)
+            (loop2 rest (append new-dep dep)))]))))
+
+(define print-rep-AV
+  (match-lambda
+    [($ AV _ template misc fields+ fields-)
+      (cons
+        (list
+          (template-type template)
+          misc
+          (map Tvar-name (vector->list fields+))
+          (map Tvar-name (vector->list fields-)))
+        '())]))
+
+; ----------------------------------------------------------------------
+
+(define select
+  (lambda l
+    (if (null? l)
+      list-ftype
+      ;; list of names and nums
+      (apply append
+        (map
+          (lambda (v)
+            (filter-map
+              (lambda (Tvar)
+                (if (or (and (number? v) 
+                          (= (FlowType-num Tvar) v)))
+                  Tvar
+                  #f))
+              list-ftype))
+          l)))))
+
+; ----------------------------------------------------------------------
+
+(define (prods-NT nt)
+  (let ([named #f])
+    (for-each
+      (match-lambda
+        [($ rhs* grsym nt)
+          (printf "~a ->  ~a ~s~n" 
+            (padr (if named 
+                    ""
+                    (begin
+                      (set! named #t)
+                      (symbol->string (nt->sym nt))))
+              20)
+            (padr (grsym->rep grsym) 25)
+            (nt->sym nt))])
+      (NT-rhs* nt))))
+
+(define (prods-Tvar Tvar)
+  ;;(printf "Tvar: ~s~n" (Tvar-name Tvar))
+  (for-each
+    (lambda (nt) 
+      (if (NT? nt) 
+        (prods-NT nt)
+        (unless (null? nt)
+          (printf "Warning: Bad nt ~s~n" nt))))
+    (list (Tvar-L Tvar) (Tvar-LI Tvar) (Tvar-U Tvar) (Tvar-UI AVS))))
+
+(define (st:prods . l) (for-each prods-Tvar (apply select l)))
+
+; ----------------------------------------------------------------------
+
+(define show-stat
+  (lambda ()
+    (printf "STATISTICS:~n")
+    (let*
+      ( [list-ftype (filter Tvar? list-ftype)]
+        [numTvar (length list-ftype)]
+        [avg (lambda (x) (/ (truncate (* (/ x numTvar) 100)) 100.0))]
+        [show (lambda (name f)
+                (let* ([l (map f list-ftype)]
+                        [num (apply + l)]
+                        [avg (avg num)]
+                        [min (apply min l)]
+                        [max (apply max l)])
+                  (printf "   ~a: Total ~s Avg ~s min ~s max ~s~n"
+                    name num avg min max)))])
+      (show "edgeto  " (lambda (Tvar) (length (Tvar-edgeto Tvar))))
+      ;;(show "edgefrom" (lambda (Tvar) (length (Tvar-edgefrom Tvar))))
+      (show "con     " (lambda (Tvar) (length (Tvar-constraints Tvar))))
+      (show "AV      " 
+        (lambda (Tvar)
+          (let ([objs (Tvar-objs Tvar)])
+            (if (Tvar? objs) 0 (length (Tvar-objs Tvar))))))
+      (printf "num-AV  : ~s~n" num-AV)
+      (printf "num-Tvar : ~s~n" num-ftype)
+      (printf "num-AV-a: ~s~n" num-AV-in-Tvar)
+      ;;(printf "Tvar-tmp : ~s~n" counter-Tvar-tmp)
+      (match (hash-table-info)
+        [(size entries clashes)
+          (printf "Hashtbl : size ~s entries ~s clashes ~s~n" 
+            size entries clashes)])
+      )))
+
+(define show-stat-small
+  (lambda ()
+    (printf 
+      "STATS: Size ~s HWM ~s num-Tvar ~s num-AV ~s num-con ~s num-edge ~s num-AV-a ~s~n"
+      (constraint-system-size) 
+      max-constraint-system-size
+      num-ftype num-AV num-con
+      num-edge num-AV-in-Tvar)
+    (constraint-system-size)))
+
+(define (empty-vars)
+  (filter
+    (lambda (Tvar)
+      (if (null? (get-Tvar-objs Tvar))
+        (Tvar-name Tvar)
+        #f))
+    list-ftype))

collects/mrspidey/Sba/sdl.ss

@@ -0,0 +1,804 @@
+;; sdl.ss
+; ----------------------------------------------------------------------
+; Copyright (C) 1995-97 Cormac Flanagan
+;
+; This program is free software; you can redistribute it and/or
+; modify it under the terms of the GNU General Public License
+; version 2 as published by the Free Software Foundation.
+; 
+; This program is distributed in the hope that it will be useful,
+; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+; GNU General Public License for more details.
+; 
+; You should have received a copy of the GNU General Public License
+; along with this program; if not, write to the Free Software
+; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
+; ----------------------------------------------------------------------
+; ======================================================================
+; Tvar->SDL compresses, calcs prods and creates sdl
+
+;(define Tvar 'dummy-Tvar)
+
+(define sdl-tvar (void))
+
+(define (Tvar->SDL Tvar)
+  (set! sdl-tvar Tvar)
+  (pretty-debug-sdl2 `(Tvar->SDL ,(Tvar-name Tvar)))
+  (let*-vals
+    ( [(Tvar approximated)
+        (if (eq? (st:sdl-fo) 'basic-types)
+          (copy-constraint-fo-w/-limits Tvar)
+          (values Tvar #f))]
+      [_ (pretty-debug-sdl2 `(Tvar->SDL copied ,(Tvar-name Tvar)))]
+      [nuTvar
+        (let*-vals
+          ([(live-Tvar cvt) 
+             (dynamic-let
+               ([st:minimize-respect-assignable-part-of-fields
+                  (st:show-assignable-part-of-fields)])
+               (pretty-debug-sdl2
+                 `(st:minimize-respect-assignable-part-of-fields
+                    ,(st:minimize-respect-assignable-part-of-fields)))
+               (minimize-constraints 
+                 (st:sdl-constraint-simplification)
+                 '() (list Tvar)
+                 list-ftype '()))]
+            [nuTvar (cvt Tvar)])
+          (pretty-debug-sdl2 `(nuTvar ,(Tvar-name nuTvar)))
+          nuTvar)]
+      [sdl (raw-Tvar->SDL nuTvar #f)])
+    (if approximated
+      `(approx ,sdl)
+      sdl)))
+
+;; (define (Tvar->SDL tvar) (Tvar-name tvar))
+
+;; ----------------------------------------------------------------------
+
+(define (copy-constraint-fo-w/-limits tvar)
+
+  (let*-vals
+    ( [mk-tvar-dots  
+        (lambda ()
+          (mk-Tvar-init-AV 'dots
+            (create-AV template-dots '() mt-vector mt-vector)))]
+      [tvar-L-dots (mk-tvar-dots)]
+      [tvar-U-dots (mk-tvar-dots)]
+      [approximated #f]
+      [ref-tvar-L-dots (lambda () (set! approximated #t) tvar-L-dots)]
+      [ref-tvar-U-dots (lambda () tvar-U-dots)]
+      [(tvar-reached? tvar-reached! list-tvar-reached)
+        (field->set alloc-Tvar-field)]
+      [(AV-reached? AV-reached! list-AV-reached)
+        (field->set alloc-AV-field)]
+      [(tvar-nu tvar-nu!) (alloc-Tvar-field)]
+      [(AV-nu AV-nu!)     (alloc-AV-field)]
+      [stack (list tvar)]
+      )
+
+    ;; doesn't do st:sdl-fo-depth-limit or st:sdl-fo-size-limit
+     
+    (recur reach ([tvar tvar])
+      (unless (tvar-reached? tvar)
+        (tvar-reached! tvar)
+        (for-each
+          (match-lambda
+            [(and AV ($ AV _ template _ fields+ fields-))
+              (unless (AV-reached? AV)
+                (AV-reached! AV)
+                (unless
+                  (or 
+                    (and
+                      (not (st:sdl-fo-ivars))
+                      (memq template-all-ivars
+                        (template-super-templates template)))
+                    (and
+                      (not (st:sdl-fo-struct-fields))
+                      (memq template-structure
+                        (template-super-templates template))))
+                  (vector-for-each reach fields+)
+                  (when (eq? template template-lam)
+                    (vector-for-each reach fields-))))])
+          (get-Tvar-objs tvar))))
+
+    (for-each
+      (lambda (tvar) (tvar-nu! tvar (mk-Tvar 'copy-constraint-fo-w/-limits)))
+      (list-tvar-reached))
+    (for-each
+      (match-lambda
+        [(and AV ($ AV _ (? (eqc? template-lam)) misc #(rng) #(dom)))
+          (AV-nu! AV 
+            (create-AV template-lam++ misc
+              (vector-map
+                (lambda (tvar) 
+                  (if (tvar-reached? tvar) (tvar-nu tvar) (ref-tvar-L-dots)))
+                (vector dom rng))
+              (vector)))]
+        [(and AV ($ AV _ template misc fields+ fields-))
+          (AV-nu! AV 
+            (create-AV template misc
+              (vector-map
+                (lambda (tvar) 
+                  (if (tvar-reached? tvar) (tvar-nu tvar) (ref-tvar-L-dots)))
+                fields+)
+              (vector-map
+                (lambda (_) (ref-tvar-U-dots))
+                fields-)))])
+      (list-AV-reached))
+    (for-each
+      (lambda (tvar) 
+        (let ([nu (tvar-nu tvar)])
+          (for-each
+            (lambda (AV)
+              (new-AV! nu (AV-nu AV)))
+            (get-Tvar-objs tvar))))
+      (list-tvar-reached))
+    (assert (tvar-reached? tvar) 'copy-sdl-size-k)
+    (pretty-debug-sdl2
+      `(copy-constraint-fo-w/-limits 
+         src ,(Tvar-name tvar)
+         result ,(Tvar-name (tvar-nu tvar))
+         size ,(length (list-AV-reached)) ,(length (list-tvar-reached))))
+    (values
+      (tvar-nu tvar)
+      approximated)))
+
+;; ----------------------------------------------------------------------
+; raw-Tvar->SDL calcs prods and creates sdl
+;
+; We use that Tvar-L, Tvar-U and AV-U fields for eq?-ness.
+; But by Tvar-L, we really mean prefixes of Tvar-L, etc.
+
+(define (raw-Tvar->SDL tvar mono)
+  ;; All reachable tvars are shown
+  (pretty-debug-sdl2 `(raw-Tvar->SDL ,(Tvar-name tvar)))
+  ;;(find-nonempty-tvars '() (list tvar))
+  (let*-vals
+    ( [mono-convert
+        (if mono
+          (match-lambda
+            [($ NT tvar 'L) (chk-Tvar-U tvar)]
+            [nt nt])
+          (lambda (nt) nt))]
+      [(env-crossover env-named-lfp) 
+        (choose-named-nts (chk-Tvar-U tvar) mono-convert)])
+    (letrec
+      ([sdl-ref
+         (lambda (nt) 
+           (let ([nt (mono-convert nt)])
+             (or (ormap
+                   (match-lambda [(z . Y) (and (eq? nt z) Y)])
+                   env-named-lfp)
+               (mk-sdl nt))))]
+        [mk-sdl
+          (lambda (nt)
+            (let ([sdl (NT->SDL nt sdl-ref #t)])
+              (if (bound-in-env? env-crossover (NT-tvar nt))
+                ((if (eq? (NT-type nt) 'U) absunion absintersect)
+                  sdl
+                  (lookup env-crossover (NT-tvar nt)))
+                sdl)))])
+      (let* ([binds
+               (map
+                 (match-lambda 
+                   [(y . name) (list name (mk-sdl y))])
+                 env-named-lfp)]
+              [body (sdl-ref (chk-Tvar-U tvar))]
+              [result (expand-output-type `(rec ,binds ,body))])
+        result))))
+
+;; ======================================================================
+ 
+(define choose-named-nts
+  ;; Returns (values env-crossover env-named-lfp)
+  ;; env-crossover maps Tvar to Xn
+  ;; env-named-lfp maps NT to Yn
+
+  (lambda (nt mono-convert)
+    (let* ( [traversed '()]
+            [named-lfp '()]
+            [stack '()])
+
+      (letrec
+        ( [traverse-convert
+            (lambda (nt)
+              (let* ( [nt (mono-convert nt)])
+                (unless (memq nt named-lfp)
+                  (let* ( [children '()]
+                          [ref (lambda (nt)
+                                 (set! children (cons nt children))
+                                 'blah)])
+                    (NT->SDL nt ref #f)
+                    (pretty-debug-sdl 
+                      `(traversing ,(nt->sym nt) 
+                         children ,(map nt->sym children)
+                         traversed  ,(map nt->sym traversed)
+                         stack  ,(map nt->sym stack)
+                         ))
+
+                    (let ([trivial 
+                            (or (null? children)
+                              (match nt
+                                [($ NT tvar 'U)
+                                  (and (Tvar? tvar)
+                                    (match (Tvar-objs tvar)
+                                      [() #t]
+                                      [(($ AV _ _ _ fields+)) 
+                                        (zero? (vector-length fields+))]
+                                      [_ #f]))]
+                                [_ #f]))])
+                      (pretty-debug `(trivial ,(nt->sym nt) ,trivial))
+                      (when (case (st:naming-strategy)  
+                              [(recursive) (memq nt stack)]
+                              [(multiple)  (and (memq nt traversed)
+                                             (not trivial))]
+                              [(nontrivial) (not trivial)]
+                              [(all) #t])
+                        ;; Name this element
+                        (pretty-debug-sdl
+                          `(naming ,(nt->sym nt) 
+                             ,(if (memq nt traversed) #t #f)
+                             children ,(map nt->sym children)
+                             ,trivial))
+                        (set! named-lfp (cons nt named-lfp))))
+                  (unless (memq nt traversed)
+                    (set! traversed (cons nt traversed))
+                    ;;(pretty-print '(traversing children))
+                    (let ([oldstk stack])
+                      (set! stack (cons nt stack))
+                      (for-each
+                        traverse-convert 
+                        children)
+                      (set! stack oldstk)))))))])
+        (traverse-convert nt)
+        (pretty-debug-sdl '(Traversed))
+
+        (let* ([crossover
+                 (intersect (select-L traversed) (select-U traversed))]
+                [env-crossover
+                  (map-with-n
+                    (lambda (y n) (cons y (symbol-append 'X (add1 n))))
+                    (reverse crossover))]
+                [env-named-lfp
+                  (map-with-n
+                    (lambda (y n) 
+                      (cons y (symbol-append 'Y (add1 n) ;;(nt->sym y)
+                                )))
+                    named-lfp)])
+
+          (pretty-debug-sdl
+            `(choose-named-nts
+               select-L ,(map Tvar-name (select-L traversed))
+               select-U ,(map (lambda (x) (and (Tvar? x) (Tvar-name x)))
+                           (select-U traversed))
+               crossover ,(map Tvar-name crossover)
+               named-lfp ,(map nt->sym named-lfp)
+               traversed ,(map nt->sym traversed)))
+
+          (values env-crossover env-named-lfp))))))
+
+; ======================================================================
+ 
+(define (NT->SDL nt ref-nt show?)
+  (pretty-debug-sdl `(NT->SDL ,(nt->sym nt) ,show?))
+  (let ([r
+          (match nt
+            [($ NT (? Tvar? tvar) 'U)
+              (when (st:listify-etc)
+                (listify-Tvar! tvar)
+                (boolify-Tvar! tvar)
+                (atomify-Tvar! tvar)
+                (sexpify-Tvar! tvar)
+                (classify-objectify-Tvar! tvar))
+              (absUnion
+                (map
+                  (lambda (AV) (ref-nt (chk-AV-U AV)))
+                  (get-Tvar-objs tvar)))]
+            [($ NT (? Tvar? tvar) 'L)
+              (absintersect
+                (absIntersect
+                  (recur loop ([con* (filter con? (Tvar-constraints tvar))])
+                    (match con*
+                      [() '()]
+                      [(($ con _ (and template ($ template _ _ _ ref assign))
+                          _ _ sign)
+                         . _)
+                        (let*-vals
+                          ([ (i-s-tvar* rest)
+                             (filter-map-split
+                               (match-lambda
+                                 [($ con _ 
+                                    (? (lambda (t) (eq? t template)))
+                                    f tvar s)
+                                   (cons (cons f s) tvar)]
+                                 [_ #f])
+                               con*)]
+                            [ref-i+
+                              (lambda (i)
+                                (absIntersect
+                                  (filter-map
+                                    (match-lambda
+                                      [(j-s . tvar2) 
+                                        (and 
+                                          (equal? (car j-s) i)
+                                          (cdr j-s)
+                                          (ref-nt (chk-Tvar-L tvar2)))])
+                                    i-s-tvar*)))]
+                            [ref-i-
+                              (lambda (i)
+                                (absUnion
+                                  (filter-map
+                                    (match-lambda
+                                      [(j-s . tvar2) 
+                                        (and 
+                                          (equal? (car j-s) i)
+                                          (cdr j-s)
+                                          (ref-nt (chk-Tvar-U tvar2)))])
+                                    i-s-tvar*)))]
+                            [this 
+
+                              (cond
+                                [(eq? template template-lam)
+                                  (list (ref-i- 0) '*->* (ref-i+ 1))]
+                                [(eq? template template-lam++)
+                                  (list (ref-i+ 0) '*->* (ref-i+ 1))]
+                                [(st:show-assignable-part-of-fields)
+                                  (list
+                                    (template-type template)
+                                    (map ref-i+ 
+                                      (filter number? (vector->list ref)))
+                                    (map ref-i-
+                                      (filter number? (vector->list assign))))]
+                                [(and 
+                                   (eq? (vector-length ref) 1)
+                                   (not (vector-ref ref 0)))
+                                  ;; Show single antimono field
+                                  (list (template-type template) (ref-i- 0))]
+                                [else
+                                  ;; Only show ref'able fields
+                                  (cons
+                                    (template-type template)
+                                    (map ref-i+
+                                      (filter number? (vector->list ref))))])])
+
+                          (cons this (loop rest)))])))
+                (absIntersect
+                  (filter-map
+                    (match-lambda
+                      [($ con-filter _ _ tvar2)
+                        (ref-nt (chk-Tvar-L tvar2))]
+                      [_ #f])
+                    (Tvar-constraints tvar)))
+                (absIntersect
+                  (map
+                    (lambda (tvar2) (ref-nt (chk-Tvar-L tvar2)))
+                    (Tvar-edgeto tvar))))]
+
+            [($ NT
+               (and AV ($ AV _ (and template ($ template _ _ _ ref assign)) 
+                         misc fields+ fields-))
+               'U)
+              (let ([ref-i+
+                      (lambda (i)
+                        (ref-nt (chk-Tvar-U (vector-ref fields+ i))))]
+                     [ref-i-
+                       (lambda (i)
+                         (ref-nt (chk-Tvar-L (vector-ref fields- i))))])
+
+                (cond 
+                  [(or 
+                     (eq? template template-lam)
+                     (eq? template template-lam++))
+
+                    (if (and 
+                          (atprim? misc) 
+                          (not (eq? (st:primitive-types) 'inferred)))
+
+                      ;; Is a primitive
+                      (when show?
+                        (case (st:primitive-types)
+                          [(prim) `(prim ,(atprim-sym misc))]
+                          [(given) (atprim-orig-type misc)]))
+
+                      ;; Print as lambda
+                      (let*-vals ( [(dom rng)
+                                     (if (eq? template template-lam)
+                                       (values (ref-i- 0) (ref-i+ 0))
+                                       (values (ref-i+ 0) (ref-i+ 1)))])
+                        (when show?
+                          (match
+                            (match misc
+                              [('lam-info nargs restarg)
+                                (pretty-domain-list dom nargs restarg)]
+                              [_ (pretty-domain-list dom 0 #t)])
+                            [(args ())
+                              (append args (list '->* rng))]
+                            [(args restarg)
+                              (append args (list restarg '*->* rng))]))))]
+
+                  ;; Not a lambda
+                  [(memq (template-type template) '(object class))
+                    (cons 
+                      (template-type template)
+                      (map-with-n
+                        (lambda (ivar-sym n) (list ivar-sym (ref-i+ n)))
+                        misc))]
+
+                  [(st:show-assignable-part-of-fields)
+                    (list
+                      (template-type template)
+                      (map ref-i+ (filter number? (vector->list ref)))
+                      (map ref-i- (filter number? (vector->list assign))))]
+                  [(and 
+                     (eq? (vector-length ref) 1)
+                     (not (vector-ref ref 0)))
+                    (list (template-type template) (ref-i- 0))]
+                  [(and 
+                     (eq? (vector-length ref) 0)
+                     (eq? (vector-length assign) 0)
+                     (st:constants)
+                     (or (number? misc) (symbol? misc) (char? misc)))
+                    (if (symbol? misc) (list 'quote misc) misc)]
+                  [else
+                    (cons 
+                      (template-type template)
+                      (map ref-i+ (filter number? (vector->list ref))))]))])])
+
+    (pretty-debug-sdl `(NT->SDL ,(nt->sym nt) = ,r))
+    r))
+
+;; ----------------------------------------------------------------------
+
+(define (pretty-domain-list dom nargs restarg)
+  (recur loop ([args '()][dom dom][nargs nargs])
+    (match dom
+      [('cons arg restarg)
+       (loop (cons arg args) restarg (sub1 nargs))]
+      [('nil)
+       (list (reverse args) '())]
+      ['_
+       (cond
+        [(> nargs 0)
+         (loop (cons '_ args) '_ (sub1 nargs))]
+        [restarg 
+         (list (reverse args) '_)]
+        [else
+         (list (reverse args) '())])]
+      [dom (list (reverse args) dom)])))
+
+(define (pretty-range-list rng nrngs)
+  (list '() rng))
+
+; ======================================================================
+
+(define template-listof (constructor->template 'listof #f))
+
+(define template-bool (constructor->template 'bool))
+
+(define template-atom (constructor->template 'atom))
+
+(define template-sexp (constructor->template 'sexp))
+
+; ----------------------------------------------------------------------
+
+(define (listify-Tvar! tvar)
+  ;; If Tvar contains (union nil (cons x tvar))
+  ;; then replace by (list x)
+  ;;(pretty-print (get-Tvar-objs tvar))
+  ;; (show-sba-Tvar tvar)
+  (match (get-Tvar-objs tvar)
+    [(or 
+       ( ($ AV _ (? (is-template? 'nil)))
+         ($ AV _ (? (is-template? 'cons)) _ 
+           #(a (? (lambda (d) (eq? d tvar))))))
+       ( ($ AV _ (? (is-template? 'cons)) _ 
+           #(a (? (lambda (d) (eq? d tvar)))))
+         ($ AV _ (? (is-template? 'nil)))))
+      (set-Tvar-objs! tvar '())
+      (new-AV! tvar (create-AV template-listof '() (vector a) (vector)))]
+    [_ (void)]))
+
+(define (boolify-Tvar! tvar)
+  ;; If Tvar contains (union true false)
+  ;; then replace those by bool
+  (let* ([bool-things '(true false)])
+    (when
+      (andmap
+        (lambda (bool-thing)
+          (ormap
+            (lambda (AV) (eq? (template-type (AV-template AV)) bool-thing))
+            (get-Tvar-objs tvar)))
+        bool-things)
+      ;; Do substitution
+      (set-Tvar-objs! tvar
+        (filter
+          (lambda (AV) 
+            (not (memq (template-type (AV-template AV)) bool-things)))
+          (get-Tvar-objs tvar)))
+      (new-AV! tvar (create-AV template-bool '() (vector) (vector))))))
+
+(define (atomify-Tvar! tvar)
+  ;; If Tvar contains (union nil num sym str char bool)
+  ;; then replace those by atom
+  (let* ([atom-things '(nil num sym str char bool)])
+    (when
+      (andmap
+        (lambda (atom-thing)
+          (ormap
+            (lambda (AV) (eq? (template-type (AV-template AV)) atom-thing))
+            (get-Tvar-objs tvar)))
+        atom-things)
+      ;; Do substitution
+      (set-Tvar-objs! tvar
+        (filter
+          (lambda (AV) 
+            (not (memq (template-type (AV-template AV)) atom-things)))
+          (get-Tvar-objs tvar)))
+      (new-AV! tvar (create-AV template-atom '() (vector) (vector))))))
+
+(define (sexpify-Tvar! tvar)
+  ;; If Tvar l contains (union atom (box l) (vec l) (cons l l)), 
+  ;; then replace those by sexp
+  (let* ([sexp-things '(atom box cons vec)])
+    (when
+      (andmap
+        (lambda (sexp-thing)
+          (ormap
+            (match-lambda
+              [($ AV _ ($ template type _ ref) _ fields+)
+                (and (eq? type sexp-thing)
+                  (or (zero? (vector-length fields+))
+                    (eq?  (vector-ref fields+ 0) tvar)))])
+            (get-Tvar-objs tvar)))
+        sexp-things)
+      ;; Do substitution
+      (printf "Do substitution")
+      (set-Tvar-objs! tvar
+        (filter
+          (lambda (AV) 
+            (not (memq (template-type (AV-template AV)) sexp-things)))
+          (get-Tvar-objs tvar)))
+      (new-AV! tvar (create-AV template-sexp '() (vector) (vector))))))
+
+(define (classify-objectify-Tvar! tvar)
+  ;; For each ivarset in tvar,
+  ;; build an object AV 
+
+  (pretty-debug-sdl `(classify-objectify-Tvar! ,(FlowType-name tvar)))
+
+  (letrec
+    ([make-thingy
+       (lambda (tvar-get-ivars tvar-put-thingy name 
+                 ivar-syms parent-ivars)
+         (recur loop ([ivar-syms ivar-syms][parent-ivars parent-ivars])
+           ;; to ivar parents
+           (for-each
+             (match-lambda
+               [($ AV _ 
+                  (? (lambda (t) (eq? t template-ivarset)))
+                  ivar-extra-syms
+                  #(parent-parent-ivars))                
+                 (loop
+                   (append ivar-syms ivar-extra-syms)
+                   parent-parent-ivars)]
+               [_ (void)])
+             (Tvar-objs parent-ivars))
+           ;; make thingy for this
+           (when (or 
+                   (null? (Tvar-objs parent-ivars))
+                   (ormap
+                     (lambda (AV)
+                       (not (eq? (AV-template AV) template-ivarset)))
+                     (Tvar-objs parent-ivars)))
+             (pretty-debug-sdl2 `(all-ivars ,name ,ivar-syms))
+             (let* 
+               ( [ivar-syms (list->set ivar-syms)]
+                 [ivar-syms
+                   (sort 
+                     (lambda (s1 s2)
+                       (string<? 
+                         (symbol->string s1)
+                         (symbol->string s2)))
+                     ivar-syms)]
+                 [n+ (length ivar-syms)]
+                 [template-thingy
+                   (make-template 
+                     name n+ 0
+                     (list->vector
+                       (recur loop ([n 0])
+                         (if (= n n+) '() (cons n (loop (add1 n))))))
+                     (vector)
+                     '()
+                     eq?)]
+                 [fields+
+                   (list->vector
+                     (map
+                       (lambda (ivar-sym)
+                         (let ([tvar-field (mk-Tvar 'object-field)])
+                           (new-con! tvar-get-ivars
+                             (create-con
+                               (get-ivar-template ivar-sym)
+                               0 tvar-field #t))
+                           tvar-field))
+                       ivar-syms))])
+               (pretty-debug-sdl2 `(ivarset ,ivar-syms))
+               (new-AV! tvar-put-thingy
+                 (create-AV template-thingy 
+                   ivar-syms fields+ (vector)))))))])
+
+    (for-each
+      (match-lambda
+        [($ AV _
+           (? (lambda (t) (eq? t template-internal-class)))
+           misc
+           #(_ alpha_o _ _ alpha_v))
+
+          (make-thingy alpha_o tvar 'class '() alpha_v)]
+          
+        [($ AV _ 
+           (? (lambda (t) (eq? t template-ivarset)))
+           ivar-syms
+           #(parent-ivars))
+
+          (make-thingy tvar tvar 'object ivar-syms parent-ivars)]
+
+        [_ (void)])
+      (Tvar-objs tvar))
+
+    ;; Now drop any ivar, ivarset and class from the tvar
+    (set-Tvar-objs! tvar
+      (filter
+        (lambda (AV)
+          (let ([t (AV-template AV)])
+            (not
+              (or
+                (memq template-all-ivars (template-super-templates t))
+                (eq? t template-ivarset)
+                (eq? t template-internal-class)))))
+        (Tvar-objs tvar)))))
+
+; ----------------------------------------------------------------------
+
+'(define (copy-depth-k tvar k)
+  (let*-vals
+    ( [tvar-dots 
+        (mk-Tvar-init-AV 'dots
+          (create-AV template-dots '() mt-vector mt-vector))]
+      [tvar-empty
+        (mk-Tvar 'depth-k-empty)]
+      [(tvar-reached? tvar-reached! list-tvar-reached)
+        (field->set alloc-Tvar-field)]
+      [(AV-reached? AV-reached! list-AV-reached)
+        (field->set alloc-AV-field)]
+      [(tvar-nu tvar-nu!) (alloc-Tvar-field)]
+      [(AV-nu AV-nu!)     (alloc-AV-field)]
+      )
+
+    (recur loop ([tvar tvar][k k])
+      (when
+        (and 
+          (not (zero? k))
+          (not (tvar-reached? tvar)))
+        (tvar-reached! tvar)
+        (for-each
+          (match-lambda
+            [(and AV ($ AV _ _ _ fields+))
+              (AV-reached! AV)
+              (vector-for-each
+                (lambda (tvar2) (loop tvar2 (sub1 k)))
+                fields+)])
+          (get-Tvar-objs tvar))))
+
+    (for-each
+      (lambda (tvar) (tvar-nu! tvar (mk-Tvar 'copy-depth-k)))
+      (list-tvar-reached))
+    (for-each
+      (match-lambda
+        [(and AV ($ AV _ template misc fields+ fields-))
+          (AV-nu! AV 
+            (create-AV template misc
+              (vector-map
+                (lambda (tvar) 
+                  (if (tvar-reached? tvar) (tvar-nu tvar) tvar-dots))
+                fields+)
+              (vector-map
+                (lambda (_) tvar-empty)
+                fields-)))])
+      (list-AV-reached))
+    (for-each
+      (lambda (tvar) 
+        (let ([nu (tvar-nu tvar)])
+          (for-each
+            (lambda (AV)
+              (new-AV! nu (AV-nu AV)))
+            (get-Tvar-objs tvar))))
+      (list-tvar-reached))
+    (pretty-debug-sdl2
+      `(copy-depth-k 
+         src ,(Tvar-name tvar)
+         depth ,k
+         result ,(Tvar-name (tvar-nu tvar))
+         size ,(length (list-AV-reached)) ,(length (list-tvar-reached))))
+    (tvar-nu tvar)))
+
+;; ----------------------------------------------------------------------
+    
+'(define (copy-sdl-size-k tvar k)
+
+   (let*-vals
+     ( [tvar-dots 
+         (mk-Tvar-init-AV 'dots
+           (create-AV template-dots '() mt-vector mt-vector))]
+       [tvar-empty
+         (mk-Tvar 'depth-k-empty)]
+       [(tvar-reached? tvar-reached! list-tvar-reached)
+         (field->set alloc-Tvar-field)]
+       [(AV-reached? AV-reached! list-AV-reached)
+         (field->set alloc-AV-field)]
+       [(tvar-nu tvar-nu!) (alloc-Tvar-field)]
+       [(AV-nu AV-nu!)     (alloc-AV-field)]
+       [stack (list tvar)]
+       )
+
+     (recur loop ()
+       (unless (>= 0 k)
+         (match stack
+           [(tvar . rest)
+             (set! stack rest)
+             (if (tvar-reached? tvar)
+               (loop)
+               (begin
+                 (set! k (sub1 k))
+                 (tvar-reached! tvar)
+                 (for-each
+                   (match-lambda
+                     [(and AV ($ AV _ _ _ fields+))
+                       (unless (AV-reached? AV)
+                         (set! k (sub1 k))
+                         (AV-reached! AV)
+                         (set! stack 
+                           (append stack (reverse (vector->list fields+)))))])
+                   (get-Tvar-objs tvar))
+                 (loop)))]
+           [() (void)])))
+
+     (for-each
+       (lambda (tvar) (tvar-nu! tvar (mk-Tvar 'copy-depth-k)))
+       (list-tvar-reached))
+     (for-each
+       (match-lambda
+         [(and AV ($ AV _ template misc fields+ fields-))
+           (AV-nu! AV 
+             (create-AV template misc
+               (vector-map
+                 (lambda (tvar) 
+                   (if (tvar-reached? tvar) (tvar-nu tvar) tvar-dots))
+                 fields+)
+               (vector-map
+                 (lambda (_) tvar-empty)
+                 fields-)))])
+       (list-AV-reached))
+     (for-each
+       (lambda (tvar) 
+         (let ([nu (tvar-nu tvar)])
+           (for-each
+             (lambda (AV)
+               (new-AV! nu (AV-nu AV)))
+             (get-Tvar-objs tvar))))
+       (list-tvar-reached))
+     (assert (tvar-reached? tvar) 'copy-sdl-size-k k)
+     (pretty-debug-sdl2
+       `(copy-depth-k 
+          src ,(Tvar-name tvar)
+          depth ,k
+          result ,(Tvar-name (tvar-nu tvar))
+          size ,(length (list-AV-reached)) ,(length (list-tvar-reached))))
+     (tvar-nu tvar)))
+
+
+
+;; ----------------------------------------------------------------------
+    
+        
+      

collects/mrspidey/Sba/seperate.ss

@@ -0,0 +1,110 @@
+;; seperate.ss
+;; Handles seperate compilation part
+;; ----------------------------------------------------------------------
+
+(define (seperately-analyze-file file-thunk* out-file)
+  ;; Prepare language
+  (when (eq? (select-language) 'none) (mrspidey:error "No language selected"))
+  (init-input-type-expander!)
+  (init-current-constructor-env!)
+
+  (match-let*
+      ([defs1 (load-parse-expand file-thunk*)]
+       [_ (set! defs-expanded defs1)]
+       [_ (init-kernel!)]
+       [_ (init-misc-analysis)]
+       [((out-env* in-env*) ...) 
+        (map-with-n
+         (lambda (def n)
+           (mrspidey:progress 'analyze (/ (add1 n) (length defs1)))
+           (traverse-def def))
+         defs1)]
+       [instantiate-env*
+        (lambda (env*)
+          (apply append 
+                 (map (lambda (env)
+                        (map
+                         (match-lambda
+                          [(and b (_ . (? AVS? AVS))) b]
+                          [(sym . (? procedure? thunk)) (cons sym (thunk))])
+                         env))
+                      env*)))]
+       [out-env (instantiate-env* out-env*)]
+       [in-env  (instantiate-env* in-env*)]
+       [extract-AVS (lambda (env) (map cdr env))]
+       [AVS-out (extract-AVS out-env)]
+       [AVS-in  (extract-AVS in-env)]
+       [(AVS-live AVS->nu) (minimize-constraints AVS-out AVS-in)]
+       [convert-env
+        (lambda (env) 
+          (map
+           (match-lambda
+            [(sym . AVS) (cons sym (AVS->nu AVS))])
+           env))]
+       [out-env (convert-env out-env)]
+       [in-env  (convert-env in-env)])
+
+    (write-constraint-set out-file AVS-live out-env in-env)))
+
+;; ----------------------------------------------------------------------
+
+(define (write-constraint-set file AVS-live out-env in-env)
+  (let* ([p (open-output-port file)]
+         [disp (lambda (x) (display x p) (newline p))]
+         [tag (gensym)]
+         [rep-constraint
+          (match-lambda
+           [($ con _ ($ template type) field-no ($ AVS num))
+            (list 'con type field-no num)]
+           [($ con-filter _ ($ filter sign (($ template types) ...)) 
+               ($ AVS num))
+            (list 'con-filter sign types num)])])
+
+    ;; --- write AV and AVS's
+    (disp num-AVS)
+    (disp num-AV) 
+    ;; --- write constructor-env
+    (disp constructor-env)
+    ;; --- write AV
+    (for-each
+     (lambda (AVS)
+       (for-each
+        (match-lambda 
+         [(and AV ($ AV num ($ template type) misc fields))
+          (unless (eq? (AV-aux AV) tag)
+            (disp (list 'AV num type misc (map AVS-num fields)))
+            (set-AV-aux! AV tag))])
+        (AVS-orig-objs AVS)))
+     list-AVS)
+    ;; --- write AVS
+    (for-each
+     (match-lambda 
+      [($ AVS num orig-objs _ constraints edgeto)
+       (disp (list `AVS num
+                   (map AVS-num orig-objs)
+                   (map rep-constraint constraints)
+                   (map AVS-num edgeto)))])
+     AVS-live)
+    ;; --- write out-env, in-env
+    (disp `(out-env ,@(map AVS-nu out-env)))
+    (disp `(in-env  ,@(map AVS-nu in-env)))
+    ;; --- all done
+    (close-output-port p)))
+
+;; ----------------------------------------------------------------------
+
+(define (read-constraint-set file)
+  ;; returns AVS-live out-env in-env
+1
+)
+
+;; ----------------------------------------------------------------------
+
+(define (ts file)
+  (parameterize 
+   ([mrspidey:progress-handler (mrspidey:text-progress)]
+    [mrspidey:error-handler    mrspidey:text-error])
+   (seperately-analyze-file (files->file-thunk* file) "test/out.za")))
+
+              
+       

collects/mrspidey/Sba/sigs.ss

@@ -0,0 +1,685 @@
+;; sba-sigs.ss
+; ----------------------------------------------------------------------
+; Copyright (C) 1995-97 Cormac Flanagan
+;
+; This program is free software; you can redistribute it and/or
+; modify it under the terms of the GNU General Public License
+; version 2 as published by the Free Software Foundation.
+; 
+; This program is distributed in the hope that it will be useful,
+; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+; GNU General Public License for more details.
+; 
+; You should have received a copy of the GNU General Public License
+; along with this program; if not, write to the Free Software
+; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
+; ----------------------------------------------------------------------
+;; ----------------------------------------------------------------------
+
+(define-signature mzlib:unprefixed-core^
+  ( (open mzlib:pretty-print^)
+    (open mzlib:file^)
+    (open mzlib:function^)
+    (open mzlib:compat^) 
+    (open mzlib:string^)))
+
+(define-signature mrspidey:library-paras^ 
+  (make-parameter-boolean
+   make-parameter-integer
+   make-parameter-list))
+
+(define-signature mrspidey:library-list^
+  (mapLR
+   mapRL
+   foldl-with-n
+   foldr2
+   filter
+   filter-map
+   filter-map-split
+   rac
+   rdc
+   map-with-n
+   for-each-with-n
+   map-ilist
+   length-ilist
+   improper?
+   flatten-ilist
+   map2
+   for-each2
+   andmap2
+   andmap2len
+   ormap2
+   list-n-copies
+   count
+   get-prefix
+   mklist
+   nth
+   list-pos
+   list-pos-equal
+   find
+   index
+))
+
+(define-signature mrspidey:library-vec^
+  ( vector-copy
+    vector-map1
+    vector-map2
+    vector-map
+    vector-for-each-with-n
+    vector-for-each
+    vector-andmap1
+    vector-andmap2
+    vector-andmap
+    vector-ormap1
+    vector-ormap2
+    vector-ormap
+    vector-zero!))
+
+(define-signature mrspidey:library-set^
+  (empty-set
+   empty-set? 
+   set
+   list->set
+   list->set-equal?
+   element-of?
+   cardinality
+   set<=
+   set-eq?
+   union2
+   union
+   setdiff2
+   setdiff
+   intersect2
+   intersect))
+
+(define-signature mrspidey:library-misc^
+  (symbol-append
+    get-cpu-time
+    get&return-cpu-time
+    make-timer
+    clear-timer!
+    record-time
+    strip-string
+    padl
+    padr
+    chop-number
+    substring?
+    char-find
+    file-newer
+    eqc?
+    ))
+
+(define-signature
+  mrspidey:env^
+  ( empty-env lookup-or-fail lookup-or-#f lookup bound-in-env?
+    extend-env extend-env* join-env bang-env!
+    env:change-binding env:remove
+    ))
+
+(define-signature mrspidey:library^
+  ((open mrspidey:library-paras^)
+   (open mrspidey:library-list^)
+   (open mrspidey:library-vec^)
+   (open mrspidey:library-set^)
+   (open mrspidey:library-misc^)
+   (open mrspidey:env^)))
+
+;; ----------------------------------------------------------------------
+
+(define-signature mrspidey:interaction^
+  (mrspidey:error 
+   mrspidey:warning 
+   mrspidey:internal-error
+   mrspidey:add-summary
+   mrspidey:add-summary-handler
+   mrspidey:progress
+   mrspidey:progress-handler
+   record-analyzed-file
+   record-analyzed-file-hook
+    
+))
+
+(define-signature mrspidey:config^
+  ( st:restricted
+    st:name
+    st:version
+
+    st:fake-reader
+    st:system-expand
+
+    st:constants
+    st:const-merge-size
+    st:if-split
+    st:flow-sensitive
+    st:fo-units
+    st:lazy-fo-units
+    st:cache-units
+    st:whole-program
+    st:special-fo-prims
+    st:see-void
+    st:cons-mutable
+    st:use-fo-ftype
+    need-label-types
+    need-explanation
+    st:zero-old-constraint-sets
+    st:zero-old-asts
+
+    st:minimize-respect-assignable-part-of-fields
+
+    st:constraint-simplification-poly
+    st:polymorphism
+
+    st:unit-read-za
+    st:unit-write-za
+    st:unit-simplify
+    st:unit-separate-S
+    st:save-za-in
+
+    ;; --- Type Viewing Parameters
+    st:sdl-fo
+    st:sdl-fo-ivars 
+    st:sdl-fo-struct-fields
+    st:sdl-fo-depth-limit? 
+    st:sdl-fo-depth-limit
+    st:sdl-fo-size-limit?
+    st:sdl-fo-size-limit
+    st:sdl-constraint-simplification
+    st:show-assignable-part-of-fields
+    st:listify-etc
+    st:sdl-constructor/selector
+    st:naming-strategy
+    st:primitive-types
+    st:expand-output-type
+    st:sdl-tidy
+    st:pretty-type-width
+
+    st:check-kernel
+    st:compare-min-algs
+
+    ;; --- Checking Parameters
+    st:all-checks
+ 
+    ;; st:show-filters
+    ;; st:add-hyper-links
+    ;; st:dont-combine-definitions
+    ;; st:structure-opaque
+    ;; st:library-prims
+    ;; st:topo-sort
+
+    mrspidey:control-fn
+
+    ))
+
+(define-signature mrspidey:debugging^
+  (debugging
+    debugging-front
+    debugging-traverse
+    debugging-unit
+    debugging-check
+    debugging-atenv
+    debugging-atype
+    debugging-sdl
+    debugging-sdl2
+    debugging-gui
+
+    debugging-min
+    debugging-min2
+    debugging-few
+    debugging-gram
+    debugging-dfa-min
+    debugging-min-table
+    debugging-object
+
+    timing-min
+
+    pretty-print-debug
+    set-debug-flag
+    ))
+
+(define-signature mrspidey:CDL^
+  ((open mrspidey:config^)
+   (open mrspidey:debugging^)
+   (open mrspidey:library^)))
+
+;; ----------------------------------------------------------------------
+;; Kernel analysis stuff
+
+(define-signature mrspidey:hash^ 
+  ( init-hash-table 
+    hash-fn hash-fn* 
+    add-entry hash-find hash-table-info
+    capture-hash-table-state restore-hash-table-state!
+    prompt-hash-table-state unprompt-hash-table-state!
+    free-hash-table-state!
+    ))
+
+(define-signature
+  mrspidey:kernel^
+  (;; --- Structures
+    (struct FlowType
+      (num expr arrowto arrowfrom type-annotation proplist values-ftype))
+    num-ftype list-ftype num-edge 
+    add-FlowType-arrow! add-FlowType! 
+    add-FlowType-prop! get-FlowType-prop FlowType-name
+
+    (struct Tvar (objs orig-objs constraints edgeto edgefrom L U))
+
+    (struct AV (num template misc fields+ fields- U PU))
+    (struct template
+      (type num+ num- ref assign super-templates misc-eq?))
+    (struct con (num template field-no tvar misc sign))
+    (struct con-filter (num filter tvar))
+    (struct filter (sign templates))
+    create-filter
+    mt-vector
+
+    ;; --- Values
+    num-con    
+    num-AV   
+    num-AV-in-Tvar
+
+    ;; --- Functions
+    init-kernel!
+    create-AV
+    mk-Tvar
+    create-con create-con-misc create-con-filter
+    new-edge! new-bidir-edge! new-edge-para new-AV! new-create-AV! new-con!
+    new-leq-top-s! new-geq-top-s!
+    mk-Tvar-init-AV
+    constraint-system-size
+    get-Tvar-objs
+    add-AV! add-con! add-edge!
+    Tvar-name
+
+    save-kernel-state restore-kernel-state!
+    prompt-kernel-state unprompt-kernel-state!
+    free-kernel-state!
+
+    alloc-Tvar-field alloc-AV-field field->set
+    check-kernel-ok
+    really-check-kernel-ok
+    check-unreachable
+    ))
+
+(define-signature
+  mrspidey:gram^
+  ( ;; --- grsyms
+    (struct grsym (fn mono))
+    (struct grsym-normal (template misc field-no))
+    (struct grsym-misc ())
+    grsym-eq?
+
+    ;; --- rhs
+    (struct rhs (grsym nt))
+    add-rhs!
+
+    calc-productions!
+    ))
+
+;; ----------------------------------------------------------------------
+;; Front end stuff
+
+(define-signature mrspidey:loadexpand^ 
+  (open-code-file
+   zodiac:read*
+   mrspidey:zprogress
+   strip-hash-percent
+   system-expand-if-necy
+    expand-zexp->port
+
+   clear-file-time-cache!
+   extend-file-time-cache!
+   zodiac-time
+   zodiac-time*
+
+    init-expand!
+    my-scheme-expand-program
+))
+
+;;(define-signature mrspidey:parser^ (top-level-parse-defs top-level-parse-exp))
+
+;; ----------------------------------------------------------------------
+
+(define-signature mrspidey:atenv^
+  ( atenv:empty
+    atenv:extend
+    atenv:extend-mutated
+    atenv:extend*
+    atenv:extend-voids
+    atenv:extend-undefineds
+    atenv:lookup
+    atenv:change-binding
+    atenv:change-bindings
+    atenv:capture-locs
+    atenv:unflush
+    atenv:flush!
+    atenv->pretty
+    atenv:domain
+    atenv:ok?
+    link-parsed-ftype!
+    ))
+
+(define-signature mrspidey:traverse^
+  ( top-level-traverse-defs
+    traverse-defs
+    ;;traverse-def
+    traverse-exp
+    ))
+
+(define-signature mrspidey:atype^
+  ((struct fo-FlowType (def))
+   FlowType->Atype
+   create-fo-FlowType
+   fo-Atype? poly-atype?
+
+   (struct atconst (c))
+   (struct schema (tvar tvar* edges))
+   (struct atprim (sym type domain-filters predicate-fn attrs orig-type))
+   (struct atthunk (thunk))
+   (struct atstruct (struct:sym super-constructors 
+                                     parent-gen-args
+                                     parent-match-args
+                                     parent-field-types
+                                     parent-list-mutable))
+   (struct atvalues (values))
+   wrap-value extract-1st-value multiple-value-components
+
+   (struct atunit (imports exports result expr))
+   (struct atlunit (ui))
+
+   FlowType->Tvar
+   Atype->Tvar
+   FlowType->pretty
+   FlowType->SDL
+    copy-ftype
+   ))
+
+(define-signature mrspidey:atlunit^
+  (create-atlunit-unit
+   create-atlunit-cmpd
+   create-atlunit-reference
+
+   apply-unit
+   atlunit->atunit
+   apply-atlunit
+
+   ))
+
+
+(define-signature mrspidey:type-env^
+  (global-tref-env
+   global-tdef-env 
+   global-tbang-env
+
+   add-global-tref!
+   add-global-tdef!
+   add-global-tbang!
+   init-global-tenv!
+
+   connect-bangs-defs
+   report-duplicate-defs
+   connect-refs-defs
+   report-unbound-vars
+   ))
+
+;; ----------------------------------------------------------------------
+;; ???
+
+(define-signature mrspidey:templates^
+  ( constructor->template
+    constructor-env
+    set-constructor-env!
+    extend-constructor-env!
+    add-constructor!
+    constructor-alias!
+    record-super-constructor!
+    record-super-constructor-of-template!
+    record-super-template!
+
+    lam-misc-eq?
+    template-lam
+    template-lam++
+    filter-not-lam
+    template-cons  
+    template-nil   
+    template-num   
+    template-sym   
+    template-str   
+    template-char  
+    template-void 
+    template-undefined
+    template-true  
+    template-false 
+    template-promise 
+    template-unit        
+    template-structure
+    template-mvalues
+    template-internal-class
+    template-all-ivars
+    template-dots
+    ;;template-ivar-box
+    template-top-s
+    template-ivarset
+
+    init-default-constructor-env!
+
+    saved-constructor-env
+    init-constructor-env!
+
+    get-unit-import-template
+    get-unit-export-template
+    get-ivar-template
+   
+    type-constructor?
+    lookup-template
+    lookup-template-or-error
+    is-template?
+    ))
+
+(define-signature mrspidey:kernel-aux^
+  ( make-constructed-AV-template
+    make-constructed-AV
+    make-constructed-Tvar
+
+    make-AV-cons
+    make-con-car
+    make-con-cdr
+    make-con-dom
+    make-con-rng
+                                        ;make-con-arg-car
+                                        ;make-con-arg-cdr
+    make-AV-vec
+    make-AV-lam
+
+    AV-nil   
+    AV-numb  
+    AV-sym   
+    AV-str   
+    AV-char  
+    AV-true  
+    AV-false 
+    AV-void  
+    AV-undefined
+    AV-top-s
+
+    mk-tvar-nil   
+    mk-tvar-numb  
+    mk-tvar-sym   
+    mk-tvar-str   
+    mk-tvar-char  
+    mk-tvar-void  
+    mk-tvar-undefined
+    mk-tvar-true  
+    mk-tvar-false 
+    mk-tvar-empty
+
+    init-common-AV!
+    traverse-simple-const
+    traverse-const-exact
+
+    Tvar-transitive-edgeto
+    copy-constraint-set
+    AV->rep
+
+    ;; --- NTs
+    (struct NT (tvar type rhs*))
+    mk-Tvar-NTs! mk-AV-NTs! 
+    alloc-NT-field
+    nt->sym
+    select-L
+    select-U
+    chk-Tvar-U
+    chk-Tvar-L
+    chk-AV-U
+    ))
+
+(define-signature mrspidey:sdl^
+  (Tvar->SDL))
+
+(define-signature mrspidey:languages^
+  ( st:language 
+    initialize-language!
+    st:numops
+    get-default-bindings
+    make-expander-namespace
+))
+
+; ----------------------------------------------------------------------
+
+(define-signature mrspidey:typelang^
+  ( absUnion absunion absIntersect absintersect
+    init-output-type-expander! install-output-type-expander!
+    init-input-type-expander! 
+    install-input-type-expander!
+    expand-input-type expand-input-type-err expand-output-type
+    typevar?
+
+    type->templates
+    split-schema
+    schema->con
+    tschema->con
+    tschema->con-for-nargs
+    ;;dom+rng-for-nargs
+    Tvar-in-type?
+    primitive->atprim))
+
+(define-signature mrspidey:contained^
+  (Tvar-containment?))
+; ----------------------------------------------------------------------
+
+(define-signature mrspidey:min^
+  ( minimize-constraints-&-compare
+    minimize-constraints
+    min-record-progress))
+
+(define-signature mrspidey:min-live^ 
+  ( copy-live-constraints
+    copy-live-constraints-noe
+    calc-live-tvars-nts
+    copy-constraints-equiv!
+    follow-antimono-fields))
+
+(define-signature mrspidey:find-nonempty-tvars^ 
+  ( copy-nonempty-tvars
+    find-nonempty-tvars))
+
+(define-signature mrspidey:min-live-few-e^ 
+  (copy-live-constraints-few-e))
+
+(define-signature mrspidey:hopcroft^ 
+  (Hopcroft-calc-equivalences))
+
+(define-signature mrspidey:min-dfa-fast^
+  ( minimize-constraints-dfa-min-lub 
+    minimize-constraints-dfa-min-glb))
+
+; ----------------------------------------------------------------------
+
+(define-signature mrspidey:calc-checks^
+  ( calc-checks
+    calc-type-annotations
+    (struct annotation (loc))
+    (struct check-annotation (text num rest))
+    (struct uncheck-annotation (text))
+    (struct type-annotation (end-first finish FlowType))
+    ))
+
+(define-signature mrspidey:za^
+  (read-za write-za))
+
+; ----------------------------------------------------------------------
+
+(define-signature mrspidey:program^
+  (analyze-program global-def-env initialize-analysis!))
+
+(define-signature mrspidey:driver^
+  (st:analyze st: st:type-fn st:help st:set-debug))
+
+;; ----------------------------------------------------------------------
+
+(define-signature
+  mrspidey:zodiac-aux^
+  ( compat compat*
+    ast-size const-size
+    unparse-dynamic-letd
+    stripper
+
+    parsed-ftype set-parsed-ftype!
+    parsed-check set-parsed-check!
+    parsed-atprim set-parsed-atprim!
+    app-tvar-args set-app-tvar-args!
+    binding-refs set-binding-refs! 
+    binding-mutated set-binding-mutated!
+    varref-binding
+    my-create-binding
+
+    lambda-flatten-arglist
+
+    no-location
+    location-inc
+    determine-end-first-token
+
+    parsed-value?
+    free-refs
+    free-vars
+    initialize-mutated
+    free-vars-defs
+    zero!
+    inline-begins
+    ))
+
+(define-signature mrspidey:zodiac^
+  ((open zodiac:system^) (open mrspidey:zodiac-aux^)))
+
+; ----------------------------------------------------------------------
+
+(define-signature mrspidey:hyper^
+  ( analysis-set-arrow-filter!
+    analysis-filter-on?
+    analysis-get-filters
+    analysis-shortest-path
+    analysis-parents
+    analysis-children
+    analysis-ancestors
+    analysis-descendants
+    analysis-callback
+    analysis-get-param
+    analysis-set-param!
+    calc-annotations
+    st:analyze-and-make-annotations
+
+    ))
+
+(define-signature mrspidey:sba^
+  ( (open mrspidey:driver^)
+    (open mrspidey:CDL^)
+    (open mrspidey:atype^)
+    (open mrspidey:hyper^)
+    (open mrspidey:kernel^)
+    (open mrspidey:calc-checks^)
+    (open mrspidey:languages^)
+    (unit zodiac : mrspidey:zodiac^)
+))
+
+; ----------------------------------------------------------------------

collects/mrspidey/Sba/template.ss

@@ -0,0 +1,303 @@
+;; templates.ss
+;; Handles the constructor environment,
+; ----------------------------------------------------------------------
+; Copyright (C) 1995-97 Cormac Flanagan
+;
+; This program is free software; you can redistribute it and/or
+; modify it under the terms of the GNU General Public License
+; version 2 as published by the Free Software Foundation.
+; 
+; This program is distributed in the hope that it will be useful,
+; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+; GNU General Public License for more details.
+; 
+; You should have received a copy of the GNU General Public License
+; along with this program; if not, write to the Free Software
+; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
+; ----------------------------------------------------------------------
+;;
+;; ======================================================================
+;; Constructor environments: symbol -> template
+;; First a helper function
+
+(define (constructor->template con . modes)
+  (let* ( [n (length modes)]
+          [assign (make-vector n #f)]
+          [ref (make-vector n #f)])
+    (recur loop ([i 0][n 0][modes modes])
+      (match modes
+        [() (make-template con n i ref assign '() eqv?)]
+        [(#t . rest)
+          (vector-set! ref n n)
+          (vector-set! assign n i)
+          (loop (add1 i) (add1 n) rest)]
+        [(#f . rest)
+          (vector-set! ref n n)
+          (vector-set! assign n #f)
+          (loop i (add1 n) rest)]))))
+
+;; ======================================================================
+;; The constructor environment
+
+(define constructor-env (void))
+
+(define (set-constructor-env! c)
+  (set! constructor-env (make-hash-table))
+  (hash-table-for-each c
+    (lambda (key val)
+      (hash-table-put! constructor-env key val))))
+
+(define (extend-constructor-env! template)
+  (let* ( [type (template-type template)]
+          [old (hash-table-get constructor-env type (lambda () #f))])
+    (if old
+      (match (list template old)
+        [( ($ template _ n+1 n-1 ref1 assign1 super1 _) 
+           ($ template _ n+2 n-2 ref2 assign2 super2 _))
+          (unless (and (= n+1 n+2)
+                    (= n-1 n-2)
+                    (equal? assign1 assign2)
+                    (equal? ref1 ref2)
+                    (equal? super1 super2))
+            (pretty-print-debug
+              `( (,n+1 ,n-1 ,ref1 ,assign1 ,(map template-type super1))
+                 (,n+2 ,n-2 ,ref2 ,assign2 ,(map template-type super2))))
+            (mrspidey:error 
+              (format "New definition of template ~s does not match old" 
+                type)))
+          old])
+      (begin
+        (hash-table-put! constructor-env type template)
+        template))))
+
+(define (add-constructor! con . modes)
+  (extend-constructor-env! (apply constructor->template con modes)))
+
+(define (constructor-alias! new-con old-con)
+  (hash-table-put! constructor-env new-con 
+    (lookup-template-or-error old-con)))
+
+(define (record-super-constructor! super-C C)
+  (record-super-constructor-of-template! 
+    super-C (lookup-template-or-error C)))
+
+(define (record-super-constructor-of-template! super-C T)
+  (record-super-template! (lookup-template-or-error super-C) T))
+
+(define (record-super-template! super-T T)
+  (set-template-super-templates! 
+    T
+    (cons super-T (template-super-templates T))))
+
+;; ======================================================================
+;; Default templates
+
+;(define-typed-structure (lam-info nargs restarg))
+
+(define lam-misc-eq?
+  (match-lambda*
+   [(('lam-info nargs1 restarg1) ('lam-info nargs2 restarg2))
+    (and (= nargs1 nargs2) (eqv? restarg1 restarg2))
+    #t]
+   [(x y) (eq? x y)]))
+
+(define template-lam
+  (make-template
+   'lambda
+    1
+    1
+    (vector #f 0)
+    (vector 0 #f)
+    '()
+    lam-misc-eq?))
+
+(define filter-not-lam
+  (create-filter #f (list template-lam)))
+
+(define template-lam++ ;; monotonic in both positions
+  (make-template
+   'lambda
+    2
+    0
+    (vector 0 1)
+    (vector)
+    '()
+    lam-misc-eq?))
+
+;; ----------------------------------------------------------------------
+
+(define template-top-s (void))
+(define template-cons  (void))
+(define template-nil   (void))
+(define template-num   (void))
+(define template-sym   (void))
+(define template-str   (void))
+(define template-char  (void))
+(define template-void  (void))
+(define template-undefined (void))
+(define template-true  (void))
+(define template-false (void))
+(define template-promise (void))
+(define template-unit    (void))
+(define template-structure (void))
+(define template-mvalues (void))
+(define template-internal-class   (void))
+(define template-all-ivars (void))
+(define template-dots   (void))
+(define template-ivarset (void))
+
+(define (init-default-constructor-env!)
+  (pretty-debug ' (init-default-constructor-env!))
+  ;; These are things needed by the analysis
+  (set! constructor-env (make-hash-table))
+  (hash-table-put! constructor-env 'lambda template-lam)
+  (set! template-top-s (add-constructor! 'top-s))
+  (set! template-cons  
+    (if (st:cons-mutable)
+      (add-constructor! 'cons #t #t)
+      (add-constructor! 'cons #f #f)))
+  (set! template-nil   (add-constructor! 'nil  ))
+  (set! template-num   (add-constructor! 'num  ))
+  (set! template-sym   (add-constructor! 'sym  ))
+  (set! template-str   (add-constructor! 'str  ))
+  (set! template-char  (add-constructor! 'char ))
+  (set! template-void  (add-constructor! 'void ))
+  (set! template-undefined (add-constructor! 'undefined))
+  (set! template-true  (add-constructor! 'true ))
+  (set! template-false (add-constructor! 'false))
+  (set! template-promise   (add-constructor! 'promise #f))
+  (set! template-unit      (add-constructor! 'unit-result* #f))
+  (set! template-structure (add-constructor! 'structure:))
+  (set! template-mvalues   (add-constructor! 'mvalues #f))
+  (set! template-internal-class 
+    (extend-constructor-env! 
+      (make-template
+        'internal-class
+        4 4
+        (vector 0  1  2  #f #f  3 #f #f 4)
+        (vector #f #f #f  0  1 #f  2  3 #f)
+        '() eq?)))
+  (set! template-all-ivars
+    (extend-constructor-env!
+      (make-template
+        'all-ivars
+        1
+        0
+        (vector 0)
+        (vector #f)
+        '()
+        eq?)))
+  (set! template-dots   (add-constructor! '...))
+  (set! template-ivarset (add-constructor! 'ivarset #t))
+  )
+
+; ======================================================================
+; The "template-prompt"
+
+(define saved-constructor-env (make-hash-table))
+
+(define (init-constructor-env!)
+  (set! constructor-env saved-constructor-env)
+  (set! unit-import-export-env (vector (make-hash-table) (make-hash-table)))
+  (set! object-ivar-template-env (make-hash-table))
+  )
+
+; ======================================================================
+; Unit templates
+
+(define unit-import-export-env (vector (make-hash-table) (make-hash-table)))
+
+(define (get-unit-import-export-template ndx sym thunk)
+  (hash-table-get
+   (vector-ref unit-import-export-env ndx)
+   sym
+   (lambda ()
+     (let ([template (thunk)])
+       (hash-table-put!
+         (vector-ref unit-import-export-env ndx)
+         sym template)
+       template))))
+
+(define (get-unit-import-template sym)
+  (get-unit-import-export-template 
+   0 sym
+   (lambda ()
+     (extend-constructor-env!
+       (make-template
+         (symbol-append 'unit-import- sym)
+         0
+         1
+         (vector #f)
+         (vector 0)
+         '()
+         eq?)))))
+
+(define (get-unit-export-template sym)
+  (assert (symbol? sym) 'get-unit-export-template)
+  (get-unit-import-export-template 
+   1 sym
+   (lambda ()
+     (extend-constructor-env!
+       (make-template
+         (symbol-append 'unit-export- sym)
+         1
+         0
+         (vector 0)
+         (vector #f)
+         '()
+         eq?)))))
+
+; ======================================================================
+; Object templates
+
+(define object-ivar-template-env (make-hash-table))
+
+(define (get-ivar-template sym)
+  (assert (symbol? sym) 'get-ivar-template sym)
+  (hash-table-get
+    object-ivar-template-env
+    sym
+    (lambda ()
+      (let ([template (make-template
+                        (symbol-append 'ivar- sym)
+                        1
+                        0
+                        (vector 0)
+                        (vector #f)
+                        '()
+                        eq?)])
+        (hash-table-put! object-ivar-template-env sym template)
+        (record-super-template! template-all-ivars template)
+        (extend-constructor-env! template)
+        template))))
+
+;; ======================================================================
+
+(define (type-constructor? C)
+  (if 
+    (hash-table-get constructor-env C (lambda () #f))
+    #t #f))
+
+(define (lookup-template C) 
+  (hash-table-get constructor-env C (lambda () #f)))
+
+(define (lookup-template-or-error C) 
+  (or (lookup-template C)
+    (mrspidey:error (format "Unknown type constructor ~s" C))))
+
+(define is-template?
+  (lambda (name)
+    (lambda (t)
+      (eq? t (lookup-template name)))))
+
+;; ======================================================================
+
+
+
+
+
+
+
+
+

collects/mrspidey/Sba/test-sba.ss

@@ -0,0 +1,775 @@
+;; test-suite1.ss
+;; Development helper file
+; ----------------------------------------------------------------------
+; Copyright (C) 1995-97 Cormac Flanagan
+;
+; This program is free software; you can redistribute it and/or
+; modify it under the terms of the GNU General Public License
+; version 2 as published by the Free Software Foundation.
+; 
+; This program is distributed in the hope that it will be useful,
+; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+; GNU General Public License for more details.
+; 
+; You should have received a copy of the GNU General Public License
+; along with this program; if not, write to the Free Software
+; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
+; ----------------------------------------------------------------------
+;; ----------------------------------------------------------------------
+
+;; Testing files:
+
+(define (run-test-suites fn)
+  (letrec ([doit
+             (case-lambda
+               [(s) (doit s 0 #f)]
+               [(s a) (doit s a #f)]
+               [(s a c)
+                 (fn (string-append "~/Spidey/test-suite/" s))
+                 (when a
+                   (unless (= (type-assert-failed-total 0) a)
+                     (error 'run-test-suites "Wrong # failed assertions!")))
+                 (when c
+                   (unless (= (total-checks 0) c)
+                     (error 'run-test-suites "Wrong # checks!")))])])
+
+    ;; --- Core Scheme
+    (doit "testall.ss" 1)
+    (doit "test-const.ss")
+    (doit "test-exprs.ss")
+    (doit "test-if-split.ss")
+    (doit "test-flow.ss")
+    (doit "test-box.ss")
+    (doit "test-user-prims.ss")
+    (doit "test-struct.ss")
+    (doit "test-mvalues.ss")
+    (doit "test-checks.ss" 0 6)
+    (doit "test-no-checks.ss" 0 0)
+
+    ;; --- Objects
+    (doit "test-obj-syntax.ss")
+    (doit "test-obj-simple.ss")
+    (doit "test-obj-thread.ss")
+    (doit "test-obj-derive.ss")
+    (doit "mflatt.ss" 0 3)
+    (doit "../test/trivia/trivia-unit.ss" 0 1)
+
+    ;; --- Units
+    (dynamic-let ([st:system-expand #t])
+      (dynamic-let ([st:fo-units #t]) (doit "test-unit.ss" 0))
+      (dynamic-let ([st:fo-units #f]) (doit "test-unit.ss" 0))
+      ;;(doit  "test-fo-units.ss" 0)
+      )
+    (doit "../test/trivia/trivia-unit.ss" 0 1)
+
+    "MrSpidey passes the test suite :-)"
+    ))
+
+;; ----------------------------------------------------------------------
+
+(define mred-system 
+  '(
+     "autoload.ss"
+     "autosave.ss"
+     "canvas.ss"
+     "connect.ss"
+     "console.ss"
+     "containr.ss"
+     "contfram.ss"
+     "contkids.ss"
+     "contpanl.ss"
+     "cparens.ss"
+     "cppmode.ss"
+     "edframe.ss"
+     "edit.ss"
+     "exit.ss"
+     "exn.ss"
+     "fileutil.ss"
+     "finder.ss"
+     "findstr.ss"
+     "frame.ss"
+     "group.ss"
+     "guiutils.ss"
+     "handler.ss"
+     "html.ss"
+     "hyper.ss"
+     "hypersig.ss"
+     "hyprdial.ss"
+     "hypredit.ss"
+     "hyprfram.ss"
+     "icon.ss"
+     "include.ss"
+     "keys.ss"
+     "link.ss"
+     "macros.ss"
+     "mcache.ss"
+     "menu.ss"
+     "mode.ss"
+     "mrsystem.ss"
+     "noconsle.ss"
+     "panel.ss"
+     "paren.ss"
+     "prefs.ss"
+     "project.ss"
+     "sig.ss"
+     "sparen.ss"
+     "ssmode.ss"
+     "url.ss"
+     "version.ss"
+     ))
+;; ----------------------------------------------------------------------
+
+(define benchmark-files
+  (append
+   (map (lambda (x) (string-append "~/Spidey/benchmarks/" x ".ss"))
+        '(
+          "one"
+          "const"
+          "sum"
+          "qsort"
+          ;; Programs from experiment
+          "gauss"
+          "du"
+          "hanoi"
+          "merge"
+          "np"
+          "tc"
+
+          "taut"
+
+          ;; Misc others
+          "sba"
+          "bignum"
+          ;;"TC"
+          "elev"
+          "dfs-bfs"
+          "checks"
+          "gauss-imp"
+          "gauss-fn"
+          "Cannibals-sba"
+          "mst"
+          ;;"gab-boyer"
+          ;;"nucleic"  -- internal defines, etc
+          ;;"nucleic2" -- internal defines, etc
+          ;;"slatex"   -- too large
+          ))
+
+   (map (lambda (x) (string-append "~/Spidey/wright/" x ".scm"))
+        '(
+          "boyer"
+          "browse"
+          "check"
+          "nbody"
+          "graphs1"
+          "graphs2"
+          "lattice-cormac"
+          ;;"dynamic"
+          ))))
+
+(define test-files 
+  (append
+   (list "~/Spidey/test/sum.ss")
+   (list "~/Spidey/test-suite/testall.ss")
+   ;; Can't use testnumeric as general test 
+   ;; type annotations require accurate numeric constants
+   ;; (list "~/Spidey/test-suite/testnumeric.ss")
+   (map (lambda (x) (string-append "~/Spidey/test/" x ".ss"))
+        '(
+          "defstruct"
+          "defstruct2"))
+   benchmark-files))
+
+'(define test-files 
+   '("~/Spidey/test/one.ss"
+     "~/Spidey/test/sum.ss"
+     "~/Spidey/sba/testall.ss"
+     "~/Spidey/test/du.ss"))
+
+
+;(define test-files '("test/one.ss" "test/test.ss" "test/readlot.ss"))
+
+;; ======================================================================
+;; Helper functions
+
+(define (exec-mzscheme exps)
+  (recur loop ( [s "mzscheme -x -g -a -f /home/cormac/scheme/mzschemerc.ss"]
+                [exps exps])
+    (if (null? exps)
+      (begin
+        (printf "Command: ") (display s) (newline)
+        (system s))
+      (loop 
+        (string-append s (format " -e '~s'" (car exps)))
+        (cdr exps)))))
+
+(define (for-each-parameter para thunk)
+  (for-each
+   (lambda (p) (dynamic-let ([para p]) (thunk p)))
+   (map car (para '?))))
+
+(define (for-each-parameters para-list thunk)
+  (if (null? para-list)
+      (thunk)
+      (for-each-parameter
+       (car para-list)
+       (lambda (x)
+         (for-each-parameters (cdr para-list) thunk)))))
+
+(define (for-each-quoted-parameters para-list thunk)
+  (recur loop ([l para-list][d '()])
+    (match l
+      [()
+       (printf "CONFIGURATION: ~s~n" d)
+       (thunk)]
+      [(p . rest)
+       (for-each-parameter
+        (eval p)
+        (lambda (x) (loop (cdr l) (cons `(,p ,x) d))))])))
+
+(define (smart-for-each-quoted-parameters para-list limit thunk)
+  (for num-chgs 0 (add1 (min limit (length para-list)))
+       ;; Try changing num-chgs parameters
+       (recur loop ([l para-list][d '()][n num-chgs])
+         (match l
+           [()
+            (when (zero? n)
+              ;; run the test
+              (printf "CONFIGURATION: num-chgs=~s ~s~n" num-chgs d)
+              (thunk))]
+           [(p . rest)
+            (let* ([para (eval p)]
+                   [options (map car (para '?))]
+                   [default (car options)])
+              ;; --- First don't change
+              (dynamic-let 
+               ([para default])
+               (loop rest (cons `(,p ,default) d) n))
+              ;; Now change
+              (unless (zero? n)
+                (for-each
+                 (lambda (v) 
+                   (dynamic-let
+                    ([para v]) 
+                    (loop rest (cons `(,p ,v) d) (sub1 n))))
+                 (cdr options))))]))))
+
+(define (for-every-nth f l n)
+  (recur loop ([i (random (inexact->exact n))][l l])
+    (unless (null? l)
+      (if (zero? i)
+        (begin
+          (f (car l))
+          (loop n (cdr l)))
+        (loop (sub1 i) (cdr l))))))
+
+; ======================================================================
+; Check minimization algorithms preserve meaning
+
+(define min-algs-to-check
+  '( none
+     nonempty
+     nonempty-copy
+     live
+     live-few-e
+     ;live-few-e-L
+     ;live-few-e-U
+     ;(live-few-e dfa-min)
+     ;(live-few-e dfa-min-inv)
+     ;(live-few-e dfa-min-inv dfa-min)
+     ;(live-few-e dfa-min dfa-min-inv)
+
+     ;(live-few-e dfa-min-1)
+     ;(live-few-e dfa-min-1)
+     ;(live-few-e dfa-min-2)
+     ;(live-few-e dfa-min-2)
+     ;(live-few-e dfa-min-1 live dfa-min-2)
+     ;(live-few-e dfa-min-2 live dfa-min-1)
+
+     (dfa-min-lub)
+     (dfa-min-glb)
+     (dfa-min-lub dfa-min-glb)
+     (dfa-min-glb dfa-min-lub)
+
+     ;(live-few-e min-table)
+     ))
+
+(define (check-min-ok-file file)
+  (let* 
+    ( [defs (analyze-program file)]
+      [type-annotations (calc-type-annotations defs)]
+      [tvar* (filter Tvar? (map type-annotation-FlowType type-annotations))]
+      ;;[_ (pretty-print `(Tvar* ,(map Tvar-name tvar*)))]
+      [min-algs min-algs-to-check]
+      [p (make-parameter-list 
+           (car min-algs) 
+           (map (lambda (x) (list x "")) min-algs))]
+      [min-con-1
+        (lambda (which Tvar)
+          (let*-vals
+            ([(_ Tvar->nutvar) 
+               (minimize-constraints which '() (list Tvar) '() '())])
+            (Tvar->nutvar Tvar)))])
+
+    (printf "Testing ~s, ~s Tvar~n" file (length tvar*))
+    ;; Compression algorithms don't preserve filters,
+    ;; so turn all filters into edges
+    (for-each
+      (lambda (tvar)
+        (when (Tvar? tvar)
+          (set-Tvar-constraints!
+            tvar
+            (filter
+              (match-lambda
+                [($ con) #t]
+                [($ con-filter _ _ to)
+                  (new-edge! tvar to)
+                  #f])
+              (Tvar-constraints tvar)))))
+      list-ftype)
+
+    (for-each-parameter 
+      p
+      (lambda (v)
+        (printf "Minimization strategy ~s~n" v)
+        (for-each
+          (lambda (Tvar)
+            (printf ".") (flush-output)
+            (let* ( [live-copy (min-con-1 'none Tvar)]
+                    [p-copy    (min-con-1 (p)   Tvar)])
+              (Tvar-equiv?
+                (lambda ()
+                  (printf "Original is:~n")
+                  (pretty-print (Tvar-name Tvar)))
+                "Live copy" live-copy
+                (format "~s p-copy" (p)) p-copy)))
+          tvar*)
+        (newline)))))
+
+(define (Tvar-equiv? fail-thunk name-A A name-B B)
+  (let* ( [c1 (Tvar-containment? A B)]
+          [c2 (Tvar-containment? B A)])
+    (unless (and c1 c2)
+      (fail-thunk)
+      (printf "~a is:~n" name-A) 
+      (pretty-print (Tvar-name A))
+      (printf "~a is:~n" name-B)
+      (pretty-print (Tvar-name B))
+      (if c1
+        (printf "~s is larger!~n" name-B)
+        (printf "~s is smaller!~n" name-B))
+      (error 'Tvar-equiv? "Failure!"))))
+
+(define (check-min-ok-all)
+  (for-each check-min-ok-file benchmark-files))
+
+;; ======================================================================
+
+(define (check-type-file f)
+  (printf "==================================================~n")
+  (printf "File: ~s~n" f)
+  (st: f)
+  (pretty-print (st:type)))
+
+; ======================================================================
+  
+(define (check-SDL-file f)
+  (printf "==================================================~n")
+  (printf "File: ~s~n" f)
+  (st: f)
+  (let* ([l list-ftype])
+    (for-each-parameter
+      st:type-compression
+      (lambda (t)
+          (printf "----------------------------------------~n")
+          (printf "Type compression: ~s~n" t)
+          (for-each
+            (lambda (Tvar) 
+              (when (Tvar? Tvar)
+                (printf "~s~n" (Tvar-name Tvar))
+                (flush-output)
+                (let ([sdl (Tvar->SDL Tvar)])
+                  (void))))
+            l)))))
+
+;; ----------------------------------------------------------------------
+
+(define (check-SDL2-file f)
+  (printf "==================================================~n")
+  (printf "File: ~s~n" f)
+  (st: f)
+  (let* ([l list-ftype]
+         [len (length l)])
+    (smart-for-each-quoted-parameters
+      '(st:type-compression
+         st:primitive-types 
+         st:naming-strategy )
+      2
+      (lambda () 
+        (for-every-nth
+          (lambda (Tvar) 
+            (when (Tvar? Tvar)
+              (printf "~s " (FlowType-num Tvar))
+              (flush-output)
+              (let ([sdl (Tvar->SDL Tvar)])
+                (void))))
+          l 
+          ;; do (* 3 (sqrt len)) cases
+          (truncate (/ len (* 3 (sqrt len)))))
+        (newline)))))
+
+;; ----------------------------------------------------------------------
+
+
+;; ### DOESNT WORK CAUSE LISTIFY ETC
+(define (check-SDL3-file f)
+  (printf "==================================================~n")
+  (printf "File: ~s~n" f)
+  (st: f)
+  (let* ([l list-ftype]
+          [len (length l)])
+    (dynamic-let ([st:primitive-types 'inferred])
+      (smart-for-each-quoted-parameters
+        '(st:type-compression
+           st:naming-strategy )
+        1
+        (lambda () 
+          (for-every-nth
+            (lambda (Tvar) 
+              (when (Tvar? Tvar)
+                (printf "~s " (FlowType-num Tvar))
+                (flush-output)
+                (let*-vals
+                  (;; minimize w/ live
+                    [(_ Tvar->nutvar)
+                      (minimize-constraints 'live '() (list Tvar))]
+                    [tvar-live (Tvar->nutvar Tvar)]
+                    [sdl (dynamic-let
+                           ([st:listify-etc #f])
+                           (Tvar->SDL tvar-live))]
+                    [tvar2 (mk-Tvar 'check-SDL3)])
+                  (pretty-print sdl)
+                  (tschema->con
+                    (expand-input-type sdl)
+                    tvar2 'check-SDL3: '())
+                  (Tvar-equiv? 
+                    (lambda ()
+                      (pretty-print 
+                        `( st:type-compression ,(st:type-compression)
+                           st:naming-strategy ,(st:naming-strategy)
+                           sdl ,sdl)))
+                    "Live" tvar-live
+                    "Regenerated" tvar2))))
+            l
+            ;; do (* 3 (sqrt len)) cases
+            (truncate (/ len (* 3 (sqrt len)))))
+          (newline))))))
+
+;; ======================================================================
+
+(define (acid-test-analysis sub-test)
+  (lambda (f)
+    (smart-for-each-quoted-parameters
+     '(st:constants
+       st:if-split
+       st:flow-sensitive
+       st:numops
+       st:special-fo-prims
+       ;;st:system-expand
+       st:see-void)
+     3
+     (lambda () (sub-test f)))))
+
+(define (acid-acid-test-analysis f)
+  ((acid-test-analysis acid-test-SDL) f))
+
+;; ----------------------------------------------------------------------
+
+(define (all-test-sba-terminates)
+  (for-each acid-test-SDL test-files)
+  (for-each acid-acid-test-analysis test-files))
+
+;; ======================================================================
+
+(define compare-min-file-results (void)) 
+(define (compare-min-file file)
+  (set! compare-min-file-results '())
+  (for-each-parameter
+    st:unit-simplify
+    (lambda (p)
+      (unless (eq? p 'none)
+        (pretty-print `(st:unit-simplify ,p))
+        (let*-vals
+          ( [(_ t real-t) (time-apply (lambda () (st: file)))])
+          (set! compare-min-file-results
+            (cons (list p t) compare-min-file-results))
+          (pretty-print 
+            `(compare-min-file-results ,compare-min-file-results))))))
+  compare-min-file-results)
+
+;; ======================================================================
+;; EXPERIMENT A
+;;
+;; Figure describing Behavior of Constraint Compression Algorithms
+
+(define compress-files
+  (map (lambda (x) (string-append "~/papers/compress/bench/compress/" x ".ss"))
+    '(
+       "t"
+       "map"
+       "reverse2"
+       "substring"
+       "qsortmod"
+       "unify"
+       "hopcroft"
+       "check-mod"
+       "escher"
+       "scanner"
+       )))
+
+(define (fig6-file file)
+  (dynamic-let ( [st:compare-min-algs #t]
+                 [st:unit-read-za #f]
+                 [st:unit-write-za #f]
+                 [st:use-fo-ftype #f]
+                 [st:polymorphism 'compress]
+                 [st:if-split #f]
+                 [st:flow-sensitive #f]
+                 [st:unit-separate-S #f]
+                 )
+    (st:analyze file)))
+
+(define (fig6)
+  (for-each fig6-file compress-files))
+
+;; ======================================================================
+;; EXPERIMENT B
+;;
+;; Polymorphic analysis times
+
+(define wright-files
+  (map (lambda (x) (string-append "~/papers/compress/bench/poly/" x ".ss"))
+    '(
+       "t"
+       "lattice"
+       "browse"
+       "splay"
+       "check"
+       "graphs"
+       "boyer"
+       "matrix"
+       "maze"
+       "nbody"
+       "nucleic-3"
+       ;; "dynamic"
+
+       )))
+
+;(define wright-poly-files 
+;  (map (lambda (file) (regexp-replace ".ss$" file ".poly.ss"))
+;    wright-files))
+
+(define fig7-algs
+  '( (traverse none)
+     (none none)
+     (compress (dfa-min-lub))
+     (compress (dfa-min-glb))
+     (compress live-few-e)
+     (compress live)
+     (compress nonempty)
+     (compress none)
+     ;;(copy-con none)
+     (reanalyze none)))
+
+(define (fig7-file-alg a b file)
+  (dynamic-let ( [st:polymorphism (if (eq? a 'traverse) 'none a)]
+                 [st:type-compression-poly b]
+                 [st:use-fo-ftype #f]
+                 [st:if-split #f]
+                 [st:flow-sensitive #f]
+                 [keep-S-closed (if (eq? a 'traverse) #f (keep-S-closed))])
+    (printf "--------------------------------------------------------~n")
+    (printf "FILE: ~s ANALYSIS ~s~n" file (list a b))
+    (clear-counters!)
+    (set! need-label-types #t)
+    (st: file)
+    (printf "FILE: ~s ANALYSIS ~s~n" file (list a b))
+    (show-counters)
+    (show-stat-small)
+    (list a b (get-counter 'top-level-traverse-defs))))
+
+(define (fig7-file file)
+  (let* ( [file (topo-file file)]
+          [r (map
+               (match-lambda [(a b) (fig7-file-alg a b file)])
+               fig7-algs)])
+    (pretty-print `(RESULTS-FOR ,file ,r))
+    (list file r)))
+
+(define (fig7)
+  (recur loop ([files wright-files][r* '()])
+    (unless (null? files)
+      (let* ( [r (fig7-file (car files))]
+              [r* (append r* (list r))])
+        (pretty-print `(RESULTS-TO-DATE ,r*))
+        (loop (cdr files) r*)))))
+
+(define (fig7s-file file)
+  ;; Spawns nu mzscheme each time
+  (let* ( [file (topo-file file)])
+    (for-each
+      (match-lambda 
+        [(and analyze (a b))
+          (printf "--------------------------------------------------------~n")
+          (printf "FILE: ~s ANALYSIS ~s~n" file analyze)
+          (exec-mzscheme
+            `( (define __NO_DEBUGGING 1)
+               (ST)
+               (set! mrspidey:zprogress (lambda x 1))
+               (fig7-file-alg (quote ,a) (quote ,b) ,file)
+               (exit)))])
+      fig7-algs)))
+
+(define (fig7s)
+  (for-each fig7s-file (cdr wright-files)))
+
+;; ======================================================================
+;; EXPERIMENT C
+;; Test how analysis scales to large programs
+;; Have: 
+;;  analyze-scanner.ss
+;;  analyze-zodiac.ss
+;;  analyze-small.ss  - part of sba analysis
+;;  analyze-no-min.ss - sba except minimization
+;;  analyze.ss        - all of sba
+;;
+;;  analyze-CDL.ss    - usless, units never used
+;;  analyze-min.ss    - useless, units never used
+
+(define (test-scalable-alg alg file)
+  (printf "--------------------------------------------------------~n")
+  (printf "FILE: ~s SIMPLIFICATION ~s~n" file alg)
+  (dynamic-let ( [st:unit-simplify (if (eq? alg 'traverse) 'none alg)]
+                 [st:use-fo-ftype #f]
+                 [st:if-split #f]
+                 [st:flow-sensitive #f]
+                 [keep-S-closed (if (eq? alg 'traverse) #f (keep-S-closed))]
+                 [st:unit-read-za #f]
+                 [st:unit-write-za #f]
+                 [st:unit-separate-S #t])
+    (clear-counters!)
+    (st:analyze file)
+    (printf "FILE: ~s SIMPLIFICATION ~s~n" file alg)
+    (show-counters)
+    (pretty-print (st:control))
+    (show-stat-small)))
+
+(define (bad-alg-for-file? alg file)
+  (cond
+    [(equal? file "analyze-small.ss")
+      ;; none ran to 404M
+      (memq alg '(none nonempty))]
+    [(equal? file "analyze-no-min.ss")
+      (memq alg '(none nonempty))]
+    [(equal? file "analyze.ss")
+      (memq alg '(none nonempty nonempty-copy))]
+    [(equal? file "~/papers/compress/bench/separate/nucleic/nucleic.ss")
+      (memq alg '())]
+    [else #f]))
+
+(define (test-scalable-file file)
+  (for-each
+    (lambda (t)
+      (unless (bad-alg-for-file? t file)
+        (exec-mzscheme 
+          `( (define __NO_DEBUGGING 1)
+             (ST)
+             ;;(expander-eval (quote (defmacro cache-exp (exp za) exp)))
+             ;;(expander-eval (quote (defmacro cache-inv (exp za) exp)))
+             (set! mrspidey:zprogress (lambda x 1))
+             (test-scalable-alg (quote ,t) ,file)
+             (exit)))))
+    '(traverse none nonempty live live-few-e dfa-min-lub dfa-min-glb)))
+
+(define (test-scalable-all)
+  (for-each test-scalable-file
+    '( "analyze-scanner.ss"
+       "analyze-zodiac.ss" 
+       "analyze-small.ss"       
+       "analyze-no-min.ss"
+       "analyze.ss")))
+
+;; ======================================================================
+;; EXPERIMENT D
+;; Test separate analysis
+
+(define (test-separate-analyze alg read-za file)
+  (printf "--------------------------------------------------------~n")
+  (printf "FILE: ~s SIMPLIFICATION ~s ~s~n" file alg read-za)
+  (let ([files '()])
+    (dynamic-let 
+      ( [st:unit-simplify (if (eq? alg 'traverse) 'none alg)]
+        [st:use-fo-ftype #f]
+        [st:if-split #f]
+        [st:flow-sensitive #f]
+        [keep-S-closed (if (eq? alg 'traverse) #f (keep-S-closed))]
+        [st:unit-separate-S #t]
+        [st:unit-read-za read-za]
+        [st:unit-write-za #t]
+        [st:unit-separate-S #t]
+        [record-analyzed-file-hook
+          (lambda (filename . _)
+            (printf "Record-analyzed-file ~s~n" filename)
+            (set! files (cons filename files)))])
+      (clear-counters!)
+      (st:analyze file)
+      (printf "FILE: ~s SIMPLIFICATION ~s ~s~n" file alg read-za)
+      (show-counters)
+      (pretty-print (st:control))
+      (show-stat-small)
+      (printf "ZA FILES:~n")
+      (system
+        (foldr
+          (lambda (file acc)
+            (string-append acc " " (regexp-replace "-source$" file "")))
+          "wc "
+          files)))))
+
+(define (test-separate-alg alg file module-file)
+  (assert (file-exists? module-file))
+  (exec-mzscheme 
+    `( (define __NO_DEBUGGING 1)
+       (ST)
+       ;(set! mrspidey:zprogress (lambda x 1))
+       (test-separate-analyze (quote ,alg) (= 0 1) ,file)
+       (exit)))
+  (system (format "touch ~a" module-file))
+  (exec-mzscheme 
+    `( (define __NO_DEBUGGING 1)
+       (ST)
+       ;(set! mrspidey:zprogress (lambda x 1))
+       (test-separate-analyze (quote ,alg) (= 1 1) ,file)
+       (exit))))
+
+(define (test-separate-file file module-file)
+  (for-each
+    (lambda (t)
+      (unless (bad-alg-for-file? t file)
+        (test-separate-alg t file module-file)))
+    '(none nonempty-copy live live-few-e dfa-min-lub)))
+
+(define (test-separate-all)
+  '(test-separate-file 
+     "~/Spidey/Unit/mod/test-separate.ss"
+     "/home/cormac/Spidey/Unit/mod/test-separate-1.ss")    
+  (test-separate-file "analyze-scanner.ss" "zodiac/scanner-parameters.ss")
+  (test-separate-file "analyze-zodiac.ss"  "zodiac/corelate.ss")
+  (test-separate-file 
+    "~/papers/compress/bench/separate/nucleic/nucleic.ss"
+    "/home/cormac/papers/compress/bench/separate/nucleic/search.ss")
+  (test-separate-file "analyze-small.ss"   "hash.ss")
+  (test-separate-file "analyze-no-min.ss"  "hash.ss")
+  (test-separate-file "analyze.ss"         "hash.ss"))
+
+;; ======================================================================
+       

collects/mrspidey/Sba/testall.ss

@@ -0,0 +1,187 @@
+; testall.ss
+; Tries to test all of Teiresias's type inference algorithm
+; and uses type assertions to detect when it fails
+
+; ----------------------------------------------------------------------
+; Constants
+
+(: 1   (exact num))
+(: 'a  (exact sym))
+(: #\a (exact char))
+(: #t  (exact true))
+(: #f  (exact false))
+(: nil (exact nil))
+(: '()  (exact nil))
+(: "Cormac" (exact str))
+(: '(a b c) (exact (listof sym)))
+(: '(a b 1) (exact (listof (union sym num))))
+(: #(1 2 3) (exact (vec num)))
+(: #(1 2 "abc") (exact (vec (union num str))))
+;;;(: #&4      (exact (box num)))
+
+; ----------------------------------------------------------------------
+; misc kinds of exprs
+
+; top-level def
+(define x 'a-symbol)
+(: x (exact sym))
+
+
+; lexical binding -various sorts
+(let ([y 4][z 'a]) 
+  (: y (exact num))
+  (: z (exact sym)))
+(letrec ([y 4][z 'a]) 
+  (: y (exact num))
+  (: z (exact sym)))
+(let* ([y 4][z 'a]) 
+  (: y (exact num))
+  (: z (exact sym)))
+
+; if - one and two armed
+(: (if (read) 1 'a) (exact (union num sym)))
+(: (if (read) 1)    (exact (union num void)))
+
+; set!
+(let ([z 4]) 
+  (set! z 'a) 
+  (: z (exact (union num sym))))
+
+; begin
+(: (begin 'a 1) (exact num))
+
+; now various lambdas and applications
+((lambda (x y) (: x (exact num)) (: y (exact sym))) 
+ 4 'a)
+((lambda x (: x (exact (cons num (cons num nil))))) 1 2)
+(apply (lambda (x) (: x (exact num))) (list 1))
+(apply (lambda x (: x (exact (cons num (cons num nil))))) (cons 1 (cons 2 nil)))
+(: (lambda (x) x) (_ -> _))
+(: ((lambda (x) 'a) 3) (exact sym))
+
+;; Multiple calls, merged returns
+(let ([I (lambda (x) (: x (exact (union num sym))))])
+  (: (I 3) (exact (union num sym)))
+  (: (I 'a) (exact (union num sym))))
+
+; ----------------------------------------------------------------------
+; if-splitting
+
+; (if (pred arg) ...)
+(let ([x (if (read) 1 'a)])
+  (: x (exact (union num sym)))
+  (if (number? x)
+      (: x (exact num))
+      (: x (exact sym))))
+
+; assigned arg
+(let ([x (if (read) 1 'a)])
+  (set! x 2)
+  (if (number? x)
+      (: x (exact (union num sym)))
+      (: x (exact (union num sym)))))
+
+; (if x ...)
+(let ([x (if (read) #t #f)])
+  (if x 
+      (: x (exact true))
+      (: x (exact false))))
+(let ([x (if (read) 5 #f)])
+  (if x 
+      (: x (exact num))
+      (: x (exact false))))
+
+; (if (not x) ...)
+(let ([x (if (read) #t #f)])
+  (if (not x)
+      (: x (exact false))
+      (: x (exact true))))
+(let ([x (if (read) 5 #f)])
+  (if (not x)
+      (: x (exact false))
+      (: x (exact num))))
+
+; (if (not (pred arg)) ...)
+(let ([x (if (read) 1 'a)])
+  (if (not (number? x))
+      (: x (exact sym))
+      (: x (exact num))))
+
+; ----------------------------------------------------------------------
+; Flow sensitive
+
+(let ([x (if 1 (cons 1 2) 'a)])
+  (: x (exact (union (cons num num) sym)))
+  (car x)
+  (: x (exact (cons num num)))
+  (cdr x))
+
+; not on assigned vars
+(let ([x (if (read) (cons 1 2) 'a)])
+  (set! x 'b)
+  (: x (exact (union (cons num num) sym)))
+  (car x)
+  (: x (exact (union (cons num num) sym)))
+  (cdr x))
+
+; ----------------------------------------------------------------------
+; Boxes
+
+(let ([x (: (box 1) (exact (box num)))])
+  (: (unbox x) (exact num)))
+(let ([x (: (box 1) (exact (box (union num sym))))])
+  (set-box! x 'a)
+  (: (unbox x) (exact (union num sym))))
+(let ([x (if (read) (box 'a) #f)])
+  (if (box? x) (: x (exact (box sym)))))
+
+; ----------------------------------------------------------------------
+; User primitives and types
+
+(define-constructor Box #t)
+
+(define-primitive Box? (_ -> bool) (predicate Box))
+(define-primitive Box (a -> (Box a)))
+(define-primitive unBox ((Box a) -> a))
+(define-primitive set-Box! ((Box (! a)) a -> void))
+
+(let ([x (: (Box 1) (exact (Box num)))])
+  (: (unBox x) (exact num)))
+(let ([x (: (Box 1) (exact (Box (union num sym))))])
+  (set-Box! x 'a)
+  (: (unBox x) (exact (union num sym))))
+(let ([x (if (read) (Box 'a) #f)])
+  (if (Box? x) (: x (exact (Box sym)))))
+
+(define-type env (listof (list sym num)))
+(define-primitive mk-env (-> env))
+(: (mk-env) (exact (listof (list sym num))))
+
+; ----------------------------------------------------------------------
+; define-structure
+
+(define-structure (Triple a b c))
+
+(let ([x (: (make-Triple 1 'a #\c) (exact (structure:Triple num sym char)))])
+  (: (Triple-a x) (exact num))
+  (: (Triple-1 x) (exact num)))
+(let ([x (: (make-Triple 1 'a #\c) (exact (structure:Triple (union num sym) sym char)))])
+  (set-Triple-a! x 'a)
+  (: (Triple-a x) (exact (union num sym))))
+(let ([x (if (read) (make-Triple 1 'a #\c) #f)])
+  (if (Triple? x) (: x (exact (structure:Triple num sym char)))))
+
+; ----------------------------------------------------------------------
+; loops
+
+(define Map
+  (lambda (f l)
+    (if (null? l)
+        '()
+        (cons (f (car l)) (Map f (cdr l))))))
+
+(: (Map add1 '(1 2 3)) (exact (listof num)))
+
+; ----------------------------------------------------------------------
+; Could test all the primitives ...
+

collects/mrspidey/Sba/text-interaction.ss

@@ -0,0 +1,60 @@
+;; text-interaction
+; ----------------------------------------------------------------------
+; Copyright (C) 1995-97 Cormac Flanagan
+;
+; This program is free software; you can redistribute it and/or
+; modify it under the terms of the GNU General Public License
+; version 2 as published by the Free Software Foundation.
+; 
+; This program is distributed in the hope that it will be useful,
+; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+; GNU General Public License for more details.
+; 
+; You should have received a copy of the GNU General Public License
+; along with this program; if not, write to the Free Software
+; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
+; ----------------------------------------------------------------------
+;; ----------------------------------------------------------------------
+
+   (define (mrspidey:error msg . obj-list)
+     (error 'Mrspidey msg))
+   (define mrspidey:warning
+     (case-lambda
+      [(str . _) (printf "Warning: ~a~n" str)]
+      ;[(str loc . _) (printf "Warning: file ~s, line ~s: ~a~n" 
+      ;                       (file-name-from-path (zodiac:location-file loc))
+     ;                        (zodiac:location-line loc)
+       ;                      str)]
+      ))
+   (define mrspidey:internal-error error)
+   (define (mrspidey:add-summary str . _)
+     (printf "~a~n" str))
+   (define mrspidey:progress
+     (let ([current ()]
+           [fresh-line #t])
+       (letrec 
+           ([f (match-lambda*
+                [((? symbol? name) (? number? fraction))
+                 (unless (eq? name current)
+                   (f 'fresh-line)
+                   (set! current name)
+                   (mrspidey:progress-output (format "~s: " name)))
+                 (mrspidey:progress-output ".") 
+                 (flush-output)
+                 (set! fresh-line #f)
+                 (when (= fraction 1) (f #\newline))]
+                [((? string? str)) 
+                 (f 'fresh-line)
+                 (mrspidey:progress-output str)
+                 (when (char=? (string-ref str (sub1 (string-length str)))
+                               #\newline)
+                   (set! fresh-line #t))]
+                [(#\newline)
+                 (mrspidey:progress-output (format "~n"))
+                 (set! fresh-line #t)]
+                [('fresh-line)
+                 (unless fresh-line (f #\newline))])])
+         f)))
+   (define mrspidey:progress-output
+     (lambda (str) (display str) (flush-output)))

collects/mrspidey/Sba/toplevelenv.ss

@@ -0,0 +1,212 @@
+;; toplevelenv.ss
+;; Handles the default top level environment
+;;
+;; ======================================================================
+;; Primitive environments: symbol -> priminfo
+;; First a helper fn
+
+(define-structure (priminfo sym type domain-filters predicate-fn))
+
+;; filter-domains is a list of filters for various args,
+;; if no error raised
+
+;; inj-predicate is a fn : list-AVS x list-AVS x AVS x bool -> AVS 
+;; used for (if (pred ... x ...) ...)
+
+(define (primitive->priminfo name type . attrs)
+  (let ([type (expand-type type)])
+    (make-priminfo
+     name 
+     type
+
+     ;; Calculate filter-domains
+     (match type
+       [(domain '->* _)
+        ;; Now walk domain and args
+        (recur loop ([domain domain])
+          (match domain
+            [('cons domain domain-rest)
+             (cons
+              (let ([templates (con-exp->templates domain)])
+                (if templates
+                    (make-filter #t templates)
+                    #f))
+              (loop domain-rest))]
+            [_ '()]))]
+       [_ '()])
+
+     ;; Calculate predicate-fn
+     (foldl
+      (lambda (attr predicate-fn)
+        (let* 
+            ([mk-predicate-fn
+              (lambda (filter-then filter-else)
+                (lambda (b a AVS sign)
+                  (let ([filter (if sign filter-then filter-else)])
+                    (if filter
+                        (let ([nu-AVS (mk-AVS-tmp 'filter)])
+                          (new-con! AVS
+                                    (create-con-filter filter
+                                                       nu-AVS))
+                          nu-AVS)
+                        AVS))))]
+             [get-templates
+              (lambda (C*) (map lookup-template C*))]
+             [nu-fn
+              (match attr
+                [('predicate-fn exp) exp]
+                [('predicate . C*)
+                 (let ([templates (get-templates C*)])
+                   (mk-predicate-fn (make-filter #t templates)
+                                    (make-filter #f templates)))]
+                [('predicate* true-info false-info)
+                 (apply 
+                  mk-predicate-fn
+                  (map
+                   (match-lambda
+                    ['_ #f]
+                    [(bool . C*)
+                     (let ([templates (get-templates C*)])
+                       (make-filter bool templates))]
+                    [_ (error 'predicate* "Bad syntax")])
+                   (list true-info false-info)))]
+                [_ #f])])
+          (if nu-fn
+              ;; compose
+              (lambda (b a AVS sign)
+                (nu-fn b a
+                       (predicate-fn b a AVS sign)
+                       sign))
+              predicate-fn)))
+      (lambda (b a AVS bool) AVS)                 
+      attrs))))
+
+;; ----------------------------------------------------------------------
+;; Now the default environment
+
+(define default-primitive-env (void))
+;; type: symbol -> priminfo
+
+;; ======================================================================
+
+(define output-type-expander (void))
+(define (init-output-type-expander!)
+  (set! output-type-expander (lambda (x) x)))
+
+(define (install-output-type-expander! expander)
+  (let ([old-expander output-type-expander])
+    (set! output-type-expander
+        (lambda (type) 
+          (old-expander (recur loop ([type type])
+                          (let ([t (expander type)])
+                            (if (eq? t type) type (loop t)))))))))
+
+;; ======================================================================
+;; For input-type-expander, recursion is done in expand-type
+
+(define default-input-type-expander (void))
+(define input-type-expander (void))
+
+(define (init-input-type-expander!)
+  (set! input-type-expander default-input-type-expander))
+
+(define (init-empty-input-type-expander!)
+  (set! input-type-expander (lambda (x) x)))
+
+(define (capture-input-type-expander!)
+  (set! default-input-type-expander input-type-expander))
+
+(define (install-input-type-expander! expander)
+  (let ([old-expander input-type-expander])
+    (set! input-type-expander
+        (lambda (type) 
+          ;;(pretty-print `(input-type-expander ,type))
+          (old-expander (expander type))))))
+
+;; ======================================================================
+
+(define (extend-env-w/-define-structure env tag . args)
+  ;; env: sym -> priminfo
+  (let ([add! 
+         (lambda (name type . attrs)
+           (set! env
+               (extend-env env name
+                           (apply primitive->priminfo name type attrs))))]
+        [type (symbol-append 'structure: tag)]
+        [gen-args (map (lambda (_) (gensym)) args)]
+        [gen-arg (gensym)])
+    (apply add-constructor! type (map (lambda (a) #t) args))
+    (add! (symbol-append 'make- tag) `(,@gen-args -> (,type ,@gen-args)))
+    (add! (symbol-append tag '?) `(_ -> bool) `(predicate ,type))
+    (for-each-with-n
+     (lambda (arg n)
+       (let ([type-ref
+              `((,type ,@(map (lambda (a)
+                                (if (eq? a arg) gen-arg '_))
+                              args))
+                -> ,gen-arg)]
+             [type-bang 
+              `((,type ,@(map (lambda (a)
+                                (if (eq? a arg) `(! ,gen-arg) '_))
+                              args))
+                ,gen-arg
+                -> void)])
+         (add! (symbol-append tag '- arg) type-ref)
+         (add! (symbol-append tag '- (add1 n)) type-ref)
+         (add! (symbol-append 'set- tag '- arg '!) type-bang)
+         (add! (symbol-append 'set- tag '- (add1 n) '!) type-bang)))
+     args)
+    env))
+
+;; ======================================================================
+
+(define (add-default-primitive! name type . attrs)
+  ;; working w/ default primitive env => use default constructor env
+  (init-current-constructor-env!)
+  (set! default-primitive-env
+      (extend-env default-primitive-env 
+                  name
+                  (apply primitive->priminfo name type attrs))))
+
+(define (add-default-primitives! l)
+  (for-each 
+   (lambda (args) (apply add-default-primitive! args))
+   l))
+
+(define
+  select-language
+  (make-parameter-list
+   'none
+   '((DrScheme  "DrScheme")
+     (MzScheme  "MzScheme")
+     (R4RS      "R4RS")
+     (Chez      "Chez Scheme")
+     (Rice      "Rice Scheme")
+     (none      "None"))
+   (lambda (scheme)
+     (unless (eq? scheme 'none)
+       (init-default-constructor-env!)
+       (init-empty-input-type-expander!)
+       (init-output-type-expander!)
+       (set! default-primitive-env empty-env)
+       (init-R4RS!)
+       (case scheme
+         [MzScheme (init-MzScheme-on-R4RS!)]
+         [DrScheme (init-MzScheme-on-R4RS!) 
+                   (init-DrScheme-on-MzScheme!)]
+         [R4RS     (void)]
+         [Chez     (init-Chez-on-R4RS!)]
+         [Rice     (init-Chez-on-R4RS!)
+                   (init-Rice-on-Chez!)]
+         [none     (void)])
+       (when (st:numops) (init-smart-numops!))
+       ;; Load .spideyrc file and .spidey-system-rc files
+       (when (file-exists? "~/.spideyrc") (load "~/.spideyrc"))
+       (let ([systemrc (string-append "~/.spidey-" 
+                                      (symbol->string scheme)
+                                      "-rc")])
+         (when (file-exists? systemrc) (load systemrc)))
+       (capture-input-type-expander!)))))
+
+;; ======================================================================
+

collects/mrspidey/Sba/type-con.ss

@@ -0,0 +1,419 @@
+;; type-con.ss
+;; 
+;; Parses a type to produce a set of constraints
+;; Also tests an AVS for membership in a type
+; ----------------------------------------------------------------------
+; Copyright (C) 1995-97 Cormac Flanagan
+;
+; This program is free software; you can redistribute it and/or
+; modify it under the terms of the GNU General Public License
+; version 2 as published by the Free Software Foundation.
+; 
+; This program is distributed in the hope that it will be useful,
+; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+; GNU General Public License for more details.
+; 
+; You should have received a copy of the GNU General Public License
+; along with this program; if not, write to the Free Software
+; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
+; ----------------------------------------------------------------------
+;; ----------------------------------------------------------------------
+
+(define typevar?
+  (lambda (v)
+    (and (symbol? v)
+         (not (type-constructor? v))
+         (not (memq v '(_ union rec ->*))))))
+
+(define (compat-type-once type cl-fn)
+  (match type
+    [(and c (or (? number?) (? char?) ('quote (? symbol?)))) c]
+    [('rec bind t2)
+     `(rec ,(map (match-lambda [(a t) (list a (cl-fn t))]) bind) 
+           ,(cl-fn t2))]
+    [('forall vars type)
+     `(forall ,vars ,(cl-fn type))]
+    [('case-> . (and types (? list?) (_ . _))) 
+     `(case-> ,@(map cl-fn types))]
+    [('union . (? list? union)) `(union ,@(map cl-fn union))]
+    [(? symbol? a) a]
+    [(arg '->* res) (list (cl-fn arg) '->* (cl-fn res))]
+    ;; check constructors
+    [((? type-constructor? C) . args)
+     `(,C ,@(map (match-lambda
+                  [('! arg) (list '! (cl-fn arg))]
+                  [arg (cl-fn arg)])
+                 args))]
+    [_ #f]))
+
+(define (expand-input-type type)
+  ;; Do rewriting transformations
+  ;;(pretty-print `(expand-type ,type))
+  (let ([t2 (input-type-expander type)])
+    (if (eq? type t2)
+        (or (compat-type-once type expand-input-type)
+            (mrspidey:error 
+             (format "Bad input type ~s" type)))
+        (expand-input-type t2))))
+
+(define (expand-output-type type)
+  ;; Do rewriting transformations
+  ;;(pretty-print `(expand-type ,type))
+  (let* ([type (or (compat-type-once type expand-output-type)
+                   type
+                   (mrspidey:error (format "Bad output type ~s" type)))])
+    (recur fn ([type type])
+      (let ([t2 (output-type-expander type)])
+        (if (eq? type t2)
+            type 
+            (fn t2))))))
+
+;; ----------------------------------------------------------------------
+
+(define (con-exp->templates con-exp)
+  ;; Assumes con-exp already expanded
+  (match con-exp
+    [('union . E*)
+     (let ([T* (map con-exp->templates E*)])
+       (and (andmap (lambda (x) x) T*)
+            (apply append T*)))]
+    [('forall _ type) (con-exp->templates type)]
+    [(_ '->* _) (list template-lam)]
+    [(or (C . _) C)
+     (if (type-constructor? C)
+         (list (lookup-template C))
+         #f)]))
+
+;; ----------------------------------------------------------------------
+
+(define (generic-type->con type prefix forall-env sign)
+  ;; Assumes type->con is already expanded
+  (letrec
+      ([mk-AVS-tmp (lambda () (mk-AVS (symbol-append prefix ':tc)))]
+       [parse-type-generic
+        (lambda (t env sign)
+          ;; sign is #t for +ive, #f for -ive
+          (let ([new-sign-edge!
+                 (lambda (from to)
+                   (if sign
+                       (new-edge! from to)
+                       (new-edge! to from)))]
+                [parse-type 
+                 (lambda (t) 
+                   (parse-type-generic t env sign))])
+            (match t
+
+              ;; Recursive definitions
+              [('rec bind t2)
+               (let* ([a* (map car bind)]
+                      [AVS* (map 
+                             (lambda (a) 
+                               (mk-AVS (symbol-append prefix ': a)))
+                             a*)]
+                      [env  (extend-env* env a* AVS*)])
+                 (for-each
+                  (match-lambda
+                   [(a t)
+                    (new-sign-edge! (parse-type-generic t env sign)
+                                    (lookup env a))])
+                  bind)
+                 (parse-type-generic t2 env sign))]
+
+              ;; Unions
+              [('union . (? list? union))
+               (let ([AVS (mk-AVS-tmp)])
+                 (for-each
+                  (lambda (t)
+                    (new-sign-edge! (parse-type-generic t env sign)
+                                    AVS))
+                  union)
+                 AVS)]
+
+              ;; case->
+              [('case-> . (? list? types)) 
+               (parse-type-generic (rac types) env sign)]
+
+              ;; type variables
+              ['_ (mk-AVS-tmp)]
+              [(? symbol? a)
+               (lookup-or-fail 
+                env a
+                (lambda () 
+                  (lookup-or-fail
+                   forall-env a
+                   (lambda ()
+                     ;; reference type named a
+                     ;; if sign +ive, use this type
+                     ;; if sign -ive, return dummy AVS
+                     (let ([AVS (mk-AVS (symbol-append prefix ': a))])
+                       (set! global-in-type-env 
+                           (cons (list a AVS (box #f)) global-in-type-env))
+                       (if sign
+                           AVS
+                           (mk-AVS (symbol-append prefix ': a))))))))]
+
+              [(arg '->* res)
+               (let ([AVS (mk-AVS-tmp)])
+                 (if sign
+                     ;; make the AV
+                     (new-AV! AVS
+                              (make-AV-lam 
+                               (parse-type-generic arg env #f)
+                               (parse-type-generic res env #t)
+                               0 #t))
+                     ;; extract the various components
+                     (begin
+                       (new-con! AVS 
+                                 (create-con 
+                                  template-lam 0 
+                                  (parse-type-generic arg env #t)))
+                       (new-con! AVS 
+                                 (create-con
+                                  template-lam 1 
+                                  (parse-type-generic res env #f)))))
+                 AVS)]
+
+              ;; constants
+              [(or (? number? c) (? char? c) ('quote (? symbol? c)))
+               (let ([AVS (mk-AVS-tmp)])
+                 (if sign (new-AV! AVS (traverse-const c)))
+                 AVS)]
+
+              ;; check constructors
+              [((? type-constructor? C) . args)
+               (match-let*
+                   ([(and template ($ template type signs ref assign))
+                     (lookup-template C)]
+                    [AVS (mk-AVS-tmp)])
+                 (unless (= (vector-length ref) (length args))
+                   (mrspidey:error
+                    (format "Constructor ~s given ~s arg(s), expected ~s" 
+                            C (length args) (vector-length ref))))
+                 (if sign
+                     ;; make the AV, unless void and (st:see-void) is false
+                     (unless (and (eq? C 'void) (not (st:see-void)))
+                       (new-AV! 
+                        AVS
+                        (apply
+                         make-constructed-AV C 
+                         (map 
+                          (lambda (a)
+                            (parse-type-generic a env sign)) 
+                          args)
+                         ;; DO SOMETHING FOR NULL ARGS
+                         )))
+
+                     ;; extract the various components
+                     ;; need to do unification on mutable fields,
+                     ;; unless pattern matching arg is (! a)
+                     (for-each-with-n
+                      (lambda (arg n)
+                        (match arg
+                          ['_ (void)]
+                          [('! a)
+                           (unless (vector-ref assign n)
+                             (mrspidey:error
+                              "! used on immutable field in type"))
+                           ;; Inject only
+                           (new-con!
+                            AVS
+                            (create-con template (vector-ref assign n)
+                                        (parse-type-generic a env #t)))]
+                          [arg
+                           ;; Extract 
+                           (new-con!
+                            AVS
+                            (create-con template (vector-ref ref n)
+                                        (parse-type-generic arg env #f)))]))
+                      args))
+                 AVS)]
+              [_
+               ;; Didn't match any type
+               (mrspidey:error (format "invalid type syntax ~s" t))])))])
+
+    (let ([AVS (parse-type-generic type empty-env sign)])
+      AVS)))
+
+;; ----------------------------------------------------------------------
+
+(define (type->con type AVS prefix top-misc)
+  ;; Assumes type is already expanded
+  (new-edge! (generic-type->con type prefix empty-env #t) AVS)
+
+  ;; Put top-misc in misc field of each AV
+  (for-each
+   (lambda (AV) (set-AV-misc! AV top-misc))
+   (get-AVS-objs AVS)))
+
+;; ----------------------------------------------------------------------
+
+(define (split-schema type)
+  (match type
+    [('forall vars type)
+     (list
+      (map (lambda (v) (cons v (mk-AVS-tmp v))) vars)
+      type)]
+    [type (list '() type)]))
+
+(define (type-schema->con type AVS prefix top-misc)
+  ;; Assumes type is already expanded
+  (match-let ([(forall-env type) (split-schema type)])
+    (new-edge! (generic-type->con type prefix forall-env #t) AVS)
+
+    ;; Put top-misc in misc field of each AV
+    (for-each
+     (lambda (AV) (set-AV-misc! AV top-misc))
+     (get-AVS-objs AVS))))
+
+;; ----------------------------------------------------------------------
+
+(define (type-schema->con-for-nargs type prefix n)
+  ;; Assumes type is already expanded
+  ;; Puts top-misc in misc field of top AV
+  ;; returns ((AVS-para ...) . AVS-result) if possible
+  ;; otherwise returns #f
+
+  (match-let ([(forall-env type) (split-schema type)])
+    (match (dom+rng-for-nargs type n)
+      [#f #f]
+      [(forall-env para* rng)
+       (recur loop ([para* para*]
+                    [AVS-para* '()])
+         (match para*
+           [()
+            (cons (reverse AVS-para*) 
+                  (generic-type->con rng prefix forall-env #t))]
+           [(para . rest)
+            (let* ([AVS-para (generic-type->con para prefix forall-env #f)])
+              (loop rest (cons AVS-para AVS-para*)))]))])))
+
+;; ----------------------------------------------------------------------
+
+(define (dom+rng-for-nargs type nargs)
+  ;; extracts appropriate type from top-level case->.
+  ;; returns (forall-env (para ...) result) if matching case
+  ;; o/w returns #f
+
+  (let* ([try1 
+          (lambda (type forall)
+            ;; See if type has the right # args
+            (match type
+              [(dom '->* rng)
+               (recur loop ([dom dom][para* '()][n nargs])
+                 (match dom
+                   [('nil) 
+                    (if (zero? n)
+                        (list (map (lambda (v) (cons v (mk-AVS-tmp 'dr)))
+                                   forall)
+                              (reverse para*)
+                              rng)
+                        #f)]
+                   [('cons para rest) (loop rest (cons para para*) (sub1 n))]
+                   [_ #f]))])
+            [_ #f])]
+         [try2
+          (lambda (type forall)
+            (match type
+              [('case-> . types)
+               (ormap (lambda (t) (try1 t forall)) types)]
+              [type (try1 type forall)]))])
+    (match type
+      [('forall vars type) (try2 type vars)]
+      [type (try2 type '())])))
+
+;; ----------------------------------------------------------------------
+
+(define AVS-in-type?
+  (lambda (AVS type)
+    ;; Checks if AVS is contained in the type
+    ;; Assumes type is already expanded
+    
+    (letrec
+        ([visit-alloc (lambda () (make-vector num-AV #f))]
+         [add-visit! 
+          (lambda (v AV)
+            (vector-set! v (AV-num AV) #t))]
+         [visited?
+          (lambda (v AV) 
+            (vector-ref v (AV-num AV)))]
+         [AVS-in-type?
+          (lambda (AVS type env)
+            ;; env maps type vars to AV-membership test function
+            (andmap (lambda (AV) (AV-in-type? AV type env))
+                    (get-AVS-objs AVS)))]
+         [AV-in-type?
+          (lambda (AV type env)
+            ;; env maps type vars to AV-membership test function
+            (match type
+
+              ;; Recursive definitions
+              [('rec bind t2)
+               (let* 
+                   ([a* (map car bind)]
+                    [t* (map cadr bind)]
+                    [envbox (box #f)]
+                    [nuenv
+                     (extend-env*
+                      env a*
+                      (map (lambda (t)
+                             (let ([v (visit-alloc)])
+                               (lambda (AV)
+                                 (or (visited? v AV)
+                                     (begin
+                                       (add-visit! v AV)
+                                       (AV-in-type? AV t (unbox envbox)))))))
+                           t*))])
+                 (set-box! envbox nuenv)
+                 (AV-in-type? AV t2 nuenv))]
+
+              [('case-> . types) (AV-in-type? AV (rac types) env)]
+
+              [('union . (? list? union))
+               (ormap (lambda (type) (AV-in-type? AV type env))
+                      union)]
+              ['_ #t]
+              [(? symbol? a) 
+               ((lookup-or-fail env a (lambda () (lambda (AV) #t)))
+                AV)]
+              [(arg '->* res) (eq? (AV-template AV) template-lam)]
+
+              [(? number? n)
+               (and (eq? (template-type (AV-template AV)) 'num)
+                    (= (AV-misc AV) n))]
+              [(? char? c)
+               (and (eq? (template-type (AV-template AV)) 'char)
+                    (char=? (AV-misc AV) c))]
+              [('quote (? symbol? s))
+               (and (eq? (template-type (AV-template AV)) 'sym)
+                    (eq? (AV-misc AV) s))]
+
+              [((? type-constructor? C) . args)
+               (match-let 
+                   ([(and template ($ template type signs ref assign))
+                     (lookup-template C)])
+                 (cond
+                  [(eq? (AV-template AV) template)
+                   (recur loop ([args args][n 0])
+                     (if (null? args)
+                         #t
+                         (and 
+                          (AVS-in-type? 
+                           (vector-ref (AV-fields AV) (vector-ref ref n))
+                           (match args
+                             [(('! a) . _) a]
+                             [(a . _) a])
+                           env)
+                          (loop (cdr args) (add1 n)))))]
+                  [(memq (AV-template AV) (template-sub-templates template))
+                   #t]
+                  [else #f]))]
+              [_ 
+               ;; Didn't match any type
+               (mrspidey:error (format "Invalid type syntax ~s" type))]))])
+      (AVS-in-type? AVS type empty-env))))
+
+;(trace AVS-in-type?)
+
+
+

collects/mrspidey/Sba/type-env.ss

@@ -0,0 +1,116 @@
+;; type-env.ss
+;; Handles the type environment (env for type inference)
+; ----------------------------------------------------------------------
+; Copyright (C) 1995-97 Cormac Flanagan
+;
+; This program is free software; you can redistribute it and/or
+; modify it under the terms of the GNU General Public License
+; version 2 as published by the Free Software Foundation.
+; 
+; This program is distributed in the hope that it will be useful,
+; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+; GNU General Public License for more details.
+; 
+; You should have received a copy of the GNU General Public License
+; along with this program; if not, write to the Free Software
+; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
+; ----------------------------------------------------------------------
+;; ----------------------------------------------------------------------
+
+;; ======================================================================
+;; Global type env
+
+(define global-tref-env '())
+(define global-tdef-env '())
+(define global-tbang-env '())
+
+(define (add-global-tref! sym tvar)
+  (set! global-tref-env (cons (cons sym tvar) global-tref-env)))
+(define (add-global-tdef! sym tvar)
+  (set! global-tdef-env (cons (cons sym tvar) global-tdef-env)))
+(define (add-global-tbang! sym tvar)
+  (set! global-tbang-env (cons (cons sym tvar) global-tbang-env)))
+(define (init-global-tenv! r d b)
+  (set! global-tref-env r)
+  (set! global-tdef-env d)
+  (set! global-tbang-env b))
+
+;; ----------------------------------------------------------------------
+;; find-matching-def
+
+(define (find-matching-def sym defs)
+  (ormap (match-lambda
+          [(sym2 . def) (and (eq? sym sym2) def)])
+         defs))
+
+;; ----------------------------------------------------------------------
+;; report-duplicate-defs
+;; Report duplicate definitions
+
+(define (report-duplicate-defs env)
+  (pretty-debug `(report-duplicate-defs ,@(map car env)))
+  (recur loop ([env env][dupls '()])
+    (match env
+      [() (void)]
+      [((sym1 . _) . rest)
+       (if (and (find-matching-def sym1 rest)
+                (not (memq sym1 dupls)))
+           (begin
+             (mrspidey:warning
+              (format "Duplicate definition of variable ~s" sym1))
+             (loop rest (cons sym1 dupls)))
+           (loop rest dupls))])))
+
+;;----------------------------------------------------------------------
+;; report-unbound-vars-env
+
+(define report-unbound-vars
+  (case-lambda
+   [(ref-env) (report-unbound-vars ref-env "")]
+   [(ref-env msg)
+    (for-each
+     (match-lambda
+      [(sym . _) 
+        (mrspidey:warning (format "Unbound type variable ~s~a" sym msg))])
+     ref-env)]))
+
+;; ----------------------------------------------------------------------
+;; connect-refs-defs
+;; Connects refs to defs, returns list of unbound refs
+
+(define (connect-refs-defs ref-env def-env)
+  (pretty-debug
+   `(connect-refs-defs ,(map car ref-env) ,(map car def-env)))
+  (filter
+   (match-lambda
+    [(and r (sym . tvar))
+     (match (find-matching-def sym def-env)
+       [#f #t]
+       [ftype
+         (new-edge! (FlowType->Tvar ftype) tvar)
+        #f])])
+   ref-env))
+
+;; ----------------------------------------------------------------------
+;; combine-def-bang
+;; Connects each bang to def, and reports bangs to undefd vars
+
+(define (connect-bangs-defs bang-env def-env)
+  (pretty-debug 
+   `(connect-bangs-defs ,(map car bang-env) ,(map car def-env)))
+  (for-each
+   (match-lambda
+    [(s2 . tvar2)
+     (match (find-matching-def s2 def-env)
+       [#f (mrspidey:warning
+            (format "Assignment to undefined variable ~s" s2))]
+       [tvar1
+         (unless (Tvar? tvar1) 
+           (mrspidey:error "Assignment to annotated type"))
+         (assert (Tvar? tvar2))
+         (new-edge! tvar2 tvar1)])])
+   bang-env))
+
+
+

collects/mrspidey/Sba/typelang.ss

@@ -0,0 +1,878 @@
+;; typelang.ss
+;; Parses a type to produce a set of constraints
+;; Also tests an Tvar for membership in a type
+; ----------------------------------------------------------------------
+; Copyright (C) 1995-97 Cormac Flanagan
+;
+; This program is free software; you can redistribute it and/or
+; modify it under the terms of the GNU General Public License
+; version 2 as published by the Free Software Foundation.
+; 
+; This program is distributed in the hope that it will be useful,
+; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+; GNU General Public License for more details.
+; 
+; You should have received a copy of the GNU General Public License
+; along with this program; if not, write to the Free Software
+; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
+; ----------------------------------------------------------------------
+;; type ::= ...
+;; schema ::= type | (forall vars type)
+;; tschema ::= schema | (case-> schema ...) 
+;; lambda types are
+;;      (a b c -> d e f)
+;;      (a b c rest *-> d e f)
+;;      (a b c ->* results)
+;;      (a b c rest *->* results)
+;;      (lambda domain range)
+;; ======================================================================
+; Union, Intersect etc
+
+(define absUnion
+  (lambda (exps)
+    (match 
+        (apply append
+               (map
+                (match-lambda
+                 ['empty '()]
+                 [('union . exps) exps]
+                 [exp (list exp)])
+                ;;(list->set-equal? exps)
+                exps
+                ))
+      [() 'empty]
+      [(e) e]
+      [exps `(union ,@exps)])))
+
+(define absunion (lambda exps (absUnion exps)))
+
+(define absIntersect
+  (lambda (exps)
+    (match 
+        (apply append
+               (map
+                (match-lambda
+                 ['_ '()]
+                 [('intersect . exps) exps]
+                 [exp (list exp)])
+                (list->set-equal? exps)))
+      [() '_]
+      [(e) e]
+      [exps `(intersect ,@exps)])))
+
+(define absintersect (lambda exps (absIntersect exps)))
+
+;; ======================================================================
+
+(define (output-type-constructor? C)
+  (or
+    (memq C '(bool listof list atom sexp values))
+    (type-constructor? C)))
+
+(define (output-type-expander type)
+  (all-output-type-expanders
+    (or
+      (compat-type-once type output-type-expander)
+      type)))
+
+;---
+(define output-type-expanders '())
+
+(define (all-output-type-expanders type)
+  (foldl
+    (lambda (expander type) (expander type))
+    type
+    output-type-expanders))
+
+;---
+
+(define (install-output-type-expander! expander)
+  (set! output-type-expanders (cons expander output-type-expanders)))
+
+(define (init-output-type-expander!)
+  
+  (install-output-type-expander!
+    (match-lambda 
+      [((? output-type-constructor? C)) C]
+      [('cons t 'nil) `(list ,t)]
+      [('cons t ('list . t*)) `(list ,t ,@t*)]
+      [('lambda dom rng) (list dom '*->* rng)]
+      [('unit-result* ('values rng)) `(unit-result ,rng)]
+      [('union X) X]
+      [(? list? t)
+        (=> fail)
+        (match (reverse t)
+          [( ('values x) 
+             (and arrow (or '*->* '->*))
+             . domains)
+            (append (reverse domains) 
+              (list (case arrow
+                      [(*->*) '*->]
+                      [(->*) '->])
+                x))]
+          [_ (fail)])]
+      [(('list . args) '*-> . results) `(,@args -> . ,results)]
+      [(('list . args) '*->* . results) `(,@args ->* . ,results)]
+      [('union . X)
+        (=> fail)
+        (cond
+          [(and (memq 'true X) (memq 'false X))
+            `(union bool ,@(remq 'true (remq 'false X)))]
+          [(and (memq 'bool X)
+             (or (memq 'true X) (memq 'false X)))
+            `(union ,@(remq 'true (remq 'false X)))]
+          [else (fail)])]
+      [(or ('union 'true 'false) ('union 'false 'true)) 'bool]
+      
+      [('mvalues ('list . x)) `(values ,@x)]
+      [('rec () body) body]
+      [(or 
+         ('union 'nil ('cons X ('listof Y)))
+         ('union ('cons X ('listof Y)) 'nil))
+        (=> fail)
+        (if (equal? X Y) `(listof ,Y) (fail))]
+      [('epsilon X) X]
+      [((and combine (or 'union 'intersect)) . parts)
+        (=> fail)
+        (if (not (st:sdl-tidy))
+          (fail)
+          (let ([combine-fn (case combine
+                              [(intersect) absintersect]
+                              [(union) absunion])])
+            (pretty-debug-sdl `(combine ,combine parts ,parts))
+            (apply combine-fn
+              (recur loop ([parts parts])
+                (match parts
+                  [(a . d)
+                    (let ([d (loop d)])
+                      (if (member a d)
+                        d
+                        (match a
+                          [((? output-type-constructor? C) . C-args)
+                            (let*-vals
+                              ( [len-C-args (length C-args)]
+                                [(args* rest)
+                                 (filter-map-split
+                                   (match-lambda
+                                     [(C2 . args)
+                                       (and 
+                                         (eq? C C2)
+                                         (= len-C-args (length args))
+                                         args)]
+                                     [_ #f])
+                                   parts)])
+                              (pretty-debug-sdl `(args* ,args* rest ,rest))
+                              (if (null? (cdr args*))
+                                (cons a d)
+                                (cons (cons C (apply map
+                                                combine-fn
+                                                args*)) 
+                                  rest)))]
+                          [_ (cons a d)])))]
+                  [() '()])))))]
+      [type type]))
+  )
+
+
+
+;; ======================================================================
+;; For input-type-expander, recursion is done in expand-input-type
+
+(define input-type-expander 'input-type-expander)
+
+(define (init-input-type-expander!)
+  (set! input-type-expander (lambda (x) x))
+  (let ([loop (lambda (x) x)])
+    (install-input-type-expander!
+      (match-lambda
+        ['atom      (loop '(union nil num sym str char true false))]
+        ['sexp      (let ([u (gensym)])
+                      (loop `(MU ,u (union atom (box ,u) (cons ,u ,u) (vec ,u)))))]
+        ['bool      (loop '(union false true))]
+        [('arg a b) (loop (list 'cons a b))]
+        ['noarg     (loop 'nil)]
+        ['null      (loop 'nil)]
+        [('arglistof t)
+          (let ((u (gensym)))
+            (loop `(MU ,u (union noarg (arg ,t ,u)))))]
+        [('arglist) (loop 'noarg)]
+        [('arglist t . t*) (loop `(arg ,t (list ,@t*)))]
+        [('listof t)
+          (let ((u (gensym)))
+            (loop `(MU ,u (union nil (cons ,t ,u)))))]
+        [('list) (loop 'nil)]
+        [('list t . t*) (loop `(cons ,t (list ,@t*)))]
+
+        [('MU (? typevar? a) t)
+          (loop `(rec ([,a ,t]) ,a))]
+        [(? type-constructor? C) (loop (list C))]
+        [(? (lambda (t) (and (list? t) (memq '-> t)))
+           t)
+          ;; Make the *-> function
+          (recur loop2 ([wrapper-fn (lambda (x) x)]
+                         [t t])
+            (match t
+              [('-> . results)
+                (loop `(,(wrapper-fn 'noarg) *-> ,@results))]
+              [('optional y . rest)
+                (loop2 (lambda (x) (wrapper-fn `(union noarg (arg ,y ,x))))
+                  rest)]
+              [(y . rest)
+                (loop2 (lambda (x) (wrapper-fn `(arg ,y ,x)))
+                  rest)]))]
+        [(? (lambda (t) (and (list? t) (memq '*-> t)))
+           t)
+          ;; Make the *->* function
+          (recur loop2 ( [wrapper-fn (lambda (x) x)]
+                         [t t])
+            (match t
+              [('*-> . _) (mrspidey:error "*-> type w/o domain")]
+              [(rest '*-> . results)
+                (loop `(,(wrapper-fn rest) 
+                         *->*
+                         (mvalues
+                           ,(foldr (lambda (arg rest) `(cons ,arg ,rest))
+                              '(nil)
+                              results))))]
+              [(y . rest)
+                (loop2 (lambda (x) (wrapper-fn `(arg ,y ,x)))
+                  rest)]))]
+        [(? (lambda (t) (and (list? t) (memq '->* t))) t)
+          (match (reverse t)
+            [(result '->* . domain)
+              `( (list ,@(reverse domain)) *->* ,result)]
+            [_ (mrspidey:error "Bad type ~s" t)])]
+        [(dom '*->* rng) (loop `(lambda ,dom ,rng))]
+        [type type]))))
+
+(define (install-input-type-expander! expander)
+  (let ([old-expander input-type-expander])
+    (set! input-type-expander
+        (lambda (type) 
+          ;;(pretty-print-debug `(input-type-expander ,type))
+          (old-expander (expander type))))))
+
+;; ======================================================================
+
+(define typevar?
+  (lambda (v)
+    (and (symbol? v)
+         (not (output-type-constructor? v))
+         (not (memq v '(_ union rec -> *-> ->* *->*))))))
+
+(define (compat-type-once type cl-fn)
+  (match type
+    [(and c (or (? number?) (? char?) ((or 'quote '#%quote) (? symbol?)))) c]
+    [('rec bind t2)
+      `(rec ,(map (match-lambda [(a t) (list a (cl-fn t))]) bind) 
+         ,(cl-fn t2))]
+    [('forall vars type)
+      `(forall ,vars ,(cl-fn type))]
+    [('case-> . (and types (? list?) (_ . _))) 
+      `(case-> ,@(map cl-fn types))]
+    [('union . (? list? union)) `(union ,@(map cl-fn union))]
+    [('scheme: E) type]
+    [('intersect . (? list? union)) `(intersect ,@(map cl-fn union))]
+    [(? symbol? a) a]
+    [((? (lambda (t) (memq t '(object class))) t) . ivar-types)
+      (cons t
+        (map
+          (match-lambda
+            [(ivar type) (list ivar (cl-fn type))])
+          ivar-types))]
+    ;; check constructors
+    [((? output-type-constructor? C)  . args)
+      `(,C ,@(map (match-lambda
+                    [('! arg) (list '! (cl-fn arg))]
+                    [arg (cl-fn arg)])
+               args))]
+    [(? (lambda (t) 
+          (and (list? t)
+            (or (memq '-> t) (memq '*-> t) (memq '->* t) (memq '*->* t)))) 
+       t)
+      (map cl-fn t)]
+    [_ #f]))
+
+(define (expand-input-type type)
+  ;; Do rewriting transformations
+  ;; (pretty-print-debug `(expand-type ,type))
+  (let ([t2 (input-type-expander type)])
+    (if (eq? type t2)
+        (or (compat-type-once type expand-input-type)
+            (mrspidey:error (format "Invalid type syntax ~s" type)))
+        (expand-input-type t2))))
+
+(define (expand-input-type-err type at)
+  ;; Do rewriting transformations
+  ;; (pretty-print-debug `(expand-type ,type))
+  (let ([t2 (input-type-expander type)])
+    (if (eq? type t2)
+        (or (compat-type-once type 
+              (lambda (type) (expand-input-type-err type at)))
+            (mrspidey:error (format "Invalid type syntax ~s" type) at))
+        (expand-input-type-err t2 at))))
+
+(define (expand-output-type type)
+  ;; Do rewriting transformations
+  (pretty-debug `(expand-output-type ,type))
+  (letrec
+    ([local-expand-output-type
+       (lambda (type)
+         (let* ([type (or (compat-type-once type local-expand-output-type)
+                        type
+                        (mrspidey:error (format "Bad output type ~s" type)))])
+           (let ([t2 (output-type-expander type)])
+             (if (equal? type t2)
+               type 
+               (local-expand-output-type t2)))))])
+    (if (st:expand-output-type)
+      (match (local-expand-output-type type)
+        [('values x) x]
+        [('rec bindings ('values x)) `(rec ,bindings ,x)]
+        [x x])
+      type)))
+
+;; ----------------------------------------------------------------------
+
+(define (type->templates con-exp)
+  ;; Assumes con-exp already expanded
+  (match con-exp
+    [('union . E*)
+     (let* ([T* (map type->templates E*)])
+       (if (andmap (lambda (x) x) T*)
+           (apply union T*)
+           #f))]
+    [('intersect . E*)
+     (let* ([T* (map type->templates E*)]
+            [T* (filter (lambda (x) x) T*)])
+       (apply intersect T*))]
+    [('forall _ type) (type->templates type)]
+    [(or (C . _) C)
+     (if (type-constructor? C)
+         (list (lookup-template C))
+         #f)]))
+
+;; ----------------------------------------------------------------------
+
+(define ( generic-type->con type prefix forall-env sign)
+  ;; Assumes type is already expanded
+  (letrec
+      ([mk-Tvar-tmp (lambda () (mk-Tvar (symbol-append prefix ':tc)))]
+       [parse-type-generic
+        (lambda (t env sign)
+          ;; sign is #t for +ive, #f for -ive
+          ;; (pretty-print-debug `(parse-type-generic ,t ,env ,sign))
+          (let ([new-sign-edge!
+                 (lambda (from to)
+                   (if sign
+                       (new-edge! from to)
+                       (new-edge! to from)))]
+                [parse-type 
+                 (lambda (t) 
+                   (let ([r (parse-type-generic t env sign)])
+                     ;;(pretty-print-debug `(parse-type-generic ,t ,(Tvar-name r)))
+                     r))])
+            (match t
+
+              ;; Recursive definitions
+              [('rec bind t2)
+                (let* ( [a* (map car bind)]
+                        [env env]
+                        [mk-tvar*
+                          (map 
+                            (lambda (a rhs) 
+                              (letrec
+                                ([f (lambda (sign)
+                                      (pretty-debug `(rec ,a ,sign))
+                                      (let* 
+                                        ( [sym (symbol-append prefix ': a)]
+                                          [tvar (mk-Tvar sym)]
+                                          [_ (set! f
+                                               (lambda (sign2)
+                                                 (unless (eq? sign sign2)
+                                                   (mrspidey:error
+                                                     (format "rec-bound variable ~s referenced in covariant and contravariant positions in type ~s" a type)))
+                                                 tvar))]
+                                          [tvar2
+                                            (parse-type-generic rhs env sign)])
+                                        (if sign
+                                          (new-edge! tvar2 tvar)
+                                          (new-edge! tvar tvar2))
+                                        tvar))])
+                                (lambda (sign) (f sign))))
+                            a* (map cadr bind))])
+                  (set! env (extend-env* env a* mk-tvar*))
+                  (parse-type-generic t2 env sign))]
+
+              ;; Unions
+              [('union . (? list? union))
+               (let ([Tvar (mk-Tvar-tmp)])
+                 (for-each
+                  (lambda (t)
+                    (new-sign-edge! (parse-type-generic t env sign) Tvar))
+                  union)
+                 Tvar)]
+
+              ;; Scheme
+              ;[('scheme: E)
+              ;  (assert (eq? sign #t) 'scheme:)
+              ;  (let*-vals
+              ;    ( [p (open-output-string)]
+              ;      [_ '(pretty-print E p)]
+              ;      [p (close-output-port)]
+              ;      [s (get-output-string p)]
+              ;      [p (open-input-string s)]
+              ;      [E ((zodiac:read p))]
+              ;      [defs (my-scheme-expand-program (list E))]
+              ;      [(ftype _ _) (traverse-exp (car defs) atenv:empty)]
+              ;      [tvar (FlowType->Tvar ftype)])
+              ;    tvar)]
+
+              [('intersect . (? list? intersect))
+               (when sign
+                 (mrspidey:error "Intersection in covariant position"))
+               (let ([Tvar (mk-Tvar-tmp)])
+                 (for-each
+                  (lambda (t)
+                    (new-edge! Tvar (parse-type-generic t env sign)))
+                  intersect)
+                 Tvar)]
+
+              ;; type variables
+              ['_ 
+               (when sign 
+                 (mrspidey:error "_ type in covariant position"))
+               (mk-Tvar-tmp)]
+
+              ['empty
+               (unless sign
+                   (mrspidey:error 
+                    (format "empty in contravariant position in ~s" type)))
+               (mk-Tvar-tmp)]
+
+              [(? symbol? a)
+                (cond
+                  [(lookup-or-#f env a) 
+                    => (lambda (mk-tvar) (mk-tvar sign))]
+                  [else
+                    (or
+                      (lookup-or-#f forall-env a)
+                      (let ([Tvar (mk-Tvar a)])
+                        (if sign 
+                          (add-global-tref! a Tvar)
+                          (add-global-tbang! a Tvar))
+                        Tvar))])]
+
+              [('lambda arg res)
+               (let ([Tvar (mk-Tvar-tmp)])
+                 (if sign
+                     ;; make the AV
+                     (new-AV! Tvar
+                              (make-AV-lam 
+                               (parse-type-generic arg env #f)
+                               (parse-type-generic res env #t)
+                               0 #t))
+                     ;; extract the various components
+                     (begin
+                       (new-con! Tvar
+                         (make-con-dom (parse-type-generic arg env #t)))
+                       (new-con! Tvar
+                         (make-con-rng
+                           (parse-type-generic res env #f)))))
+                 Tvar)]
+
+              ;; constants
+              [(or (? number? c) (? char? c) 
+                   ((or 'quote '#%quote) (? symbol? c)))
+               (let ([Tvar (mk-Tvar-tmp)])
+                 (if sign (new-AV! Tvar (traverse-simple-const c)))
+                 Tvar)]
+
+              ;; check constructors
+              [((? type-constructor? C) . args)
+               (match-let*
+                   ([(and template ($ template type n+ n- ref assign))
+                     (lookup-template C)]
+                    [Tvar (mk-Tvar-tmp)])
+                 (unless (= (vector-length ref) (length args))
+                   (mrspidey:error
+                    (format "Constructor ~s given ~s arg(s), expected ~s" 
+                            C (length args) (vector-length ref))))
+                 (if sign
+                     ;; make the AV, unless void and (st:see-void) is false
+                     (unless (and (eq? C 'void) (not (st:see-void)))
+                       (let ([args 
+                              (map 
+                               (lambda (a) (parse-type-generic a env sign)) 
+                               args)])
+                         ;;(pretty-print-debug `(,C ,@(map Tvar-name args)))
+                         (new-AV! 
+                          Tvar
+                          (apply make-constructed-AV C args))))
+                     ;; DO SOMETHING FOR NULL ARGS
+
+                     ;; extract the various components
+                     ;; need to do unification on mutable fields,
+                     ;; unless pattern matching arg is (! a)
+                     (for-each-with-n
+                      (lambda (arg n)
+                        (match arg
+                          [(or '_ 'top)(void)]
+                          [('! a)
+                            (match (vector-ref assign n)
+                              [#f
+                                (mrspidey:error
+                                  "! used on immutable field in type")]
+                              [n
+                                ;; Inject only
+                                (new-con!
+                                  Tvar
+                                  (create-con template n
+                                    (parse-type-generic a env #t) #f))])]
+                          [arg
+                            ;; Extract 
+                            (new-con!
+                              Tvar
+                              (create-con template (vector-ref ref n)
+                                (parse-type-generic arg env #f) #t))]))
+                      args))
+                 Tvar)]
+              [_
+               ;; Didn't match any type
+               (mrspidey:error (format "invalid type syntax ~s" t))])))])
+
+    (let ([Tvar (parse-type-generic type empty-env sign)])
+      Tvar)))
+
+;; ----------------------------------------------------------------------
+
+(define (split-schema type)
+  (match type
+    [('forall vars type)
+     (values vars type)]
+    [type (values '() type)]))
+
+(define (schema->env+type type)
+  (let-values ([(vars type) (split-schema type)])
+    (values
+     (map (lambda (v) (cons v (mk-Tvar v))) vars)
+     type)))
+
+(define (schema->con schema Tvar prefix top-misc)
+  (let-values ([(forall-env type) (schema->env+type schema)])
+
+    (new-edge! (generic-type->con type prefix forall-env #t) Tvar)
+
+    ;; Put top-misc in misc field of each AV
+    (for-each
+     (lambda (AV) (set-AV-misc! AV top-misc))
+     (get-Tvar-objs Tvar))))
+
+;; ----------------------------------------------------------------------
+
+(define (tschema->con tschema Tvar prefix top-misc)
+  (schema->con
+   (match tschema
+     [('case-> . schema*) (rac schema*)]
+     [schema schema])
+   Tvar prefix top-misc))
+
+;; ----------------------------------------------------------------------
+
+(define (tschema->con-for-nargs tschema Tvar prefix top-misc n)
+  ;; Assumes type is already expanded
+
+  (match tschema
+    [('case-> . schema*)
+      (or
+        (ormap
+          (lambda (schema) 
+            (let-values ([(forall-env type) (schema->env+type schema)])
+              (if (function-takes-nargs? type n)
+                (schema->con schema Tvar prefix top-misc)
+                #f)))
+          schema*)
+        (schema->con (rac schema*) Tvar prefix top-misc))]
+    [schema 
+      (schema->con schema Tvar prefix top-misc)]))
+
+;; ----------------------------------------------------------------------
+
+(define (function-takes-nargs? type nargs)
+  (match type
+    [('lambda dom rng)
+      (recur loop ([dom dom][n nargs])
+        (match dom
+          [('nil) (zero? n)]
+          [('cons para rest) (loop rest (sub1 n))]
+          [_ #f]))]
+    [_ #f]))
+ 
+;; ----------------------------------------------------------------------
+
+'(define (Tvar-in-type? ftype type)
+  (let* ([o (old-Tvar-in-type? ftype type)]
+         [Tvar2 (mk-Tvar 'in-type?)]
+         [_ (tschema->con type Tvar 'in-type? '())]
+         [n (Tvar-containment? ftype ftype2)])
+    (unless (eq? o n)
+      (mrspidey:warning
+       (format "Tvar-in-type old ~s new ~s type ~s"     o n type))
+      o)))
+
+(define Tvar-in-type?
+  (lambda (Tvar type forall-vars unbound)
+
+    ;; (pretty-print `(Tvar-in-type? ,(Tvar-name Tvar) ,type ,forall-vars))
+    ;; Checks if Tvar is contained in the type
+    ;; Assumes type is already expanded
+    
+    (letrec
+        ([visit-alloc (lambda () (make-vector num-AV #f))]
+         [add-visit! 
+          (lambda (v AV)
+            (vector-set! v (AV-num AV) #t))]
+         [visited?
+          (lambda (v AV) 
+            (vector-ref v (AV-num AV)))]
+          [Tvar-in-type?
+           (lambda (Tvar type env)
+            ;; env maps type vars to AV-membership test function
+            (andmap (lambda (AV) (AV-in-type? AV type env))
+                    (get-Tvar-objs Tvar)))]
+         [AV-in-type?
+          (lambda (AV type env)
+            ;; env maps type vars to AV-membership test function
+            (match type
+
+              ;; Recursive definitions
+              [('rec bind t2)
+               (let* 
+                   ([a* (map car bind)]
+                    [t* (map cadr bind)]
+                    [envbox (box #f)]
+                    [nuenv
+                     (extend-env*
+                      env a*
+                      (map (lambda (t)
+                             (let ([v (visit-alloc)])
+                               (lambda (AV)
+                                 (or (visited? v AV)
+                                     (begin
+                                       (add-visit! v AV)
+                                       (AV-in-type? AV t (unbox envbox)))))))
+                           t*))])
+                 (set-box! envbox nuenv)
+                 (AV-in-type? AV t2 nuenv))]
+
+              [('case-> . types) (AV-in-type? AV (rac types) env)]
+
+              [('union . (? list? union))
+               (ormap (lambda (type) (AV-in-type? AV type env))
+                      union)]
+              [('intersect . (? list? intersect))
+               (andmap (lambda (type) (AV-in-type? AV type env))
+                       intersect)]
+              ['_ #t]
+              [(? symbol? a) 
+               (let ([fn (or (lookup-or-#f env a)
+                             (and (memq a forall-vars) (lambda (AV) #t))
+                             (let ([type:a a])
+                               (ormap
+                                (match-lambda
+                                 [(sym . Tvar)
+                                  (if (eq? sym type:a)
+                                      (lambda (AV)
+                                        (let ([Tvar-t (mk-Tvar 'in-type?)])
+                                          (new-AV! Tvar-t AV)
+                                          (Tvar-containment? Tvar-t Tvar)))
+                                      #f)])
+                                global-tdef-env))
+                             (unbound a))])
+                 (fn AV))]
+              [('lambda arg res)
+                (and (eq? (AV-template AV) template-lam)
+                  (Tvar-in-type?
+                    (vector-ref (AV-fields+ AV) 0)
+                    res
+                    env))]
+              [(? number? n)
+               (and (eq? (template-type (AV-template AV)) 'num)
+                    (number? (AV-misc AV))
+                    (= (AV-misc AV) n))]
+              [(? char? c)
+               (and (eq? (template-type (AV-template AV)) 'char)
+                    (char=? (AV-misc AV) c))]
+              [((or 'quote '#%quote) (? symbol? s))
+               (and (eq? (template-type (AV-template AV)) 'sym)
+                    (eq? (AV-misc AV) s))]
+
+              [((? type-constructor? C) . args)
+                (match-let 
+                  ([(and template ($ template type n+ n- ref assign))
+                     (lookup-template C)])
+                  (cond
+                    [(or (eq? (AV-template AV) template)
+                       (memq template 
+                         (template-super-templates (AV-template AV)))) 
+                      (recur loop ([args args][n 0])
+                        (if (null? args)
+                          #t
+                          (and 
+                            (or
+                              (not (vector-ref ref n));; Can't reference
+                              (Tvar-in-type? 
+                                (vector-ref (AV-fields+ AV) (vector-ref ref n))
+                                (match args
+                                  [(('! a) . _) a]
+                                  [(a . _) a])
+                                env))
+                            (loop (cdr args) (add1 n)))))]
+                    [else
+                      '(pretty-print-debug
+                         `(fail ,(AV-template AV)
+                            ,C
+                            ,template
+                            ,(template-super-templates (AV-template AV))
+                            ,(memq template 
+                               (template-super-templates (AV-template AV)))))
+                      #f]))]
+              [_ 
+               ;; Didn't match any type
+               (mrspidey:error (format "Invalid type syntax ~s" type))]))])
+      (Tvar-in-type? Tvar type empty-env))))
+
+; ======================================================================
+
+'(define (FV-tschema tschema)
+  ;; returns (FV-ref FV-bang)
+  (let ([FV-ref '()]
+        [FV-bang '()])
+    (letrec 
+        ([FV-type
+          (lambda (type env sign)
+            (match type
+              [('rec bind t2)
+               (let ([env (append (map car bind) env)])
+                 (FV-type* (map cadr bind) env sign)
+                 (FV-type t2 env sing))]
+              [((or 'union 'intersect (? type-constructor?)) . (? list? args))
+               (FV-type* args env sign)]
+              [(or '_ 'empty (? number?) (? char?) 
+                 ((or 'quote '#%quote) (? symbol?)))
+               (void)]
+              [(or (? symbol? a) ('! (? symbol? a)))
+               (if sign
+                   (set! FV-ref (set-add a FV-ref))
+                   (set! FV-bang (set-add a FV-bang)))]
+              [x
+               ;; Didn't match any type
+               (mrspidey:internal-error 'FV-type 
+                                        "invalid type syntax ~s" x)]))]
+         [FV-type*
+          (lambda (types env sign)
+            (for-each (lambda (t) (FV-type t env sign)) types))]
+         [FV-schema
+          (match-lambda
+           [('forall vars type)
+            (setdiff2 (FV-type type) vars)]
+           [type (FV-type type vars #t)])]
+         [FV-tschema
+          (match-lambda
+           [('case-> . schemas)
+            (apply union (map FV-schema schemas))]
+           [schema (FV-schema schema)])])
+      (FV-tschema tschema)
+      (list FV-ref FV-bang))))
+
+; ======================================================================
+
+(define (primitive->atprim name orig-type-schema . attrs)
+  ;;(pretty-debug `(primitive->atprim ,name))
+  (match-let*
+    ( [type-schema (expand-input-type orig-type-schema)]
+      [type (match type-schema
+              [('forall _ type) type]
+              [type type])])
+
+    (make-atprim
+      name 
+      type-schema
+
+      ;; Calculate filter-domains
+      (match type
+        [('lambda domain _)
+          ;; Now walk domain and args
+          (recur loop ([domain domain])
+            (match domain
+              [('cons domain d-rest)
+                (cons
+                  (let ([templates (type->templates domain)])
+                    (if templates
+                      (create-filter #t templates)
+                      #f))
+                  (loop d-rest))]
+              [_ '()]))]
+        [_ '()])
+
+      ;; Calculate predicate-fn
+      (foldl
+        (lambda (attr predicate-fn)
+          (let* 
+            ([mk-predicate-fn
+               (lambda (filter-then filter-else)
+                 (lambda (b a Tvar sign)
+                   '(printf "mk-predicate-fn ~s ~s ~s ~s ~s ~s~n"
+                      filter-then filter-else b a Tvar sign)
+                   (let ([filter (if sign filter-then filter-else)])
+                     (if filter
+                       (let ([nu-Tvar (mk-Tvar 'filter)])
+                         (new-con! Tvar
+                           (create-con-filter filter
+                             nu-Tvar))
+                         nu-Tvar)
+                       Tvar))))]
+              [get-templates
+                (lambda (C*) 
+                  (map
+                    (lambda (C)
+                      (or (lookup-template C)
+                        (mrspidey:error 
+                          (format "Unknown constructor ~s in primitive def" C))))
+                    C*))]
+              [nu-fn
+                (match attr
+                  [('predicate-fn exp) exp]
+                  [('predicate . C*)
+                    (let ([templates (get-templates C*)])
+                      (mk-predicate-fn (create-filter #t templates)
+                        (create-filter #f templates)))]
+                  [('predicate* true-info false-info)
+                    (apply 
+                      mk-predicate-fn
+                      (map
+                        (match-lambda
+                          ['_ #f]
+                          [(bool . C*)
+                            (let ([templates (get-templates C*)])
+                              (create-filter bool templates))]
+                          [_ (error 'predicate* "Bad syntax")])
+                        (list true-info false-info)))]
+                  [_ #f])])
+            (if nu-fn
+              ;; compose
+              (lambda (b a Tvar sign)
+                (nu-fn b a
+                  (predicate-fn b a Tvar sign)
+                  sign))
+              predicate-fn)))
+        (lambda (b a Tvar bool) Tvar)                 
+        attrs)
+     
+      attrs
+      orig-type-schema)))
+
+; ======================================================================
+
+

collects/mrspidey/Sba/za.ss

@@ -0,0 +1,328 @@
+;; za.ss
+;; Reads and writes .za files
+; ----------------------------------------------------------------------
+; Copyright (C) 1995-97 Cormac Flanagan
+;
+; This program is free software; you can redistribute it and/or
+; modify it under the terms of the GNU General Public License
+; version 2 as published by the Free Software Foundation.
+; 
+; This program is distributed in the hope that it will be useful,
+; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+; GNU General Public License for more details.
+; 
+; You should have received a copy of the GNU General Public License
+; along with this program; if not, write to the Free Software
+; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
+; ----------------------------------------------------------------------
+
+;; ======================================================================
+;; za handling stuff
+;; ======================================================================
+
+;; ----------------------------------------------------------------------
+;; read-unit-za
+;; Returns (values ftype tref-env tdef-env tbang-env)
+
+(define (read-za za)
+  (let*-vals
+   ([(Tvar envs lookup-Tvar) (read-constraint-set za)]
+    [cvt-env (match-lambda
+              [(sym num) (cons sym (lookup-Tvar num))])])
+   (match envs
+     [('ftype sexp
+              'tref-env tref-env
+              'tdef-env tdef-env
+              'tbang-env tbang-env)
+      (values
+       (recur sexp->ftype ([sexp sexp])
+         ;;(pretty-print `(sexp->ftype ,sexp))
+         (match sexp
+           [(? number? n) (lookup-Tvar n)]
+           [('schema n n*)
+            (create-fo-FlowType
+             (make-schema (lookup-Tvar n)
+                          (map lookup-Tvar n*)
+                          '()))]
+           [('atunit imports exports result)
+            (create-fo-FlowType
+             (make-atunit (map (match-lambda
+                                [(sym . n*)
+                                 (cons sym (map lookup-Tvar n*))])
+                               imports)
+                          (map (match-lambda
+                                [(sym sexp)
+                                 (cons sym (sexp->ftype sexp))])
+                               exports)
+                          (sexp->ftype result)
+                          #f))]
+           [('atstruct A B C D E F)
+             (create-fo-FlowType (make-atstruct A B C D E F))]
+           [('prim sym type attrs)
+             (create-fo-FlowType (apply primitive->atprim sym type attrs))]
+           [x (mrspidey:internal-error 'read-za 
+                "Bad ftype-sexp in za: ~s" x)]))
+       (map cvt-env tref-env)
+       (map cvt-env tdef-env)
+       (map cvt-env tbang-env))])))
+
+;; ----------------------------------------------------------------------
+;; write-za
+
+(define (write-za za tvar-live ftype tref-env tdef-env tbang-env)
+  (write-constraint-set 
+   za tvar-live
+   (lambda (Tvar->nu-num)
+     (let ([cvt-env
+            (match-lambda
+             [(sym . tvar) (list sym (Tvar->nu-num tvar))])])
+       (list 
+        'ftype
+        (recur ftype->sexp ([ftype ftype])
+          (pretty-debug-unit `(ftype->sexp ,(FlowType->pretty ftype)))
+          (if (Tvar? ftype)
+              (Tvar->nu-num ftype)
+              (match (fo-FlowType-def ftype)
+                [($ schema tvar tvar* '()) 
+                 (list 'schema
+                       (Tvar->nu-num tvar) 
+                       (map Tvar->nu-num tvar*))]
+                [($ atunit imports exports result exp)
+                 (list 'atunit
+                       (map (match-lambda
+                             [(sym . tvar*)
+                              (cons sym (map Tvar->nu-num tvar*))])
+                            imports)
+                       (map (match-lambda
+                             [(sym . ftype)
+                              (list sym (ftype->sexp ftype))])
+                            exports)
+                       (ftype->sexp result))]
+                [($ atstruct A B C D E F) `(atstruct ,A ,B ,C ,D ,E ,F)]
+                [($ atprim sym type _ _ attrs orig-type-schema)
+                  (list 'prim sym orig-type-schema attrs)]
+                [x (mrspidey:internal-error 'ftype->sexp "Bad Atype ~s" x)])))
+
+        'tref-env (map cvt-env tref-env)
+        'tdef-env (map cvt-env tdef-env)      
+        'tbang-env (map cvt-env tbang-env))))))
+
+;; ======================================================================
+
+(define (write-constraint-set file Tvar-live mk-envs)
+  
+  (with-handlers
+    ([void 
+       (lambda (exn) 
+         (when (file-exists? file) (delete-file file))
+         (raise exn))])
+
+    (let*-vals
+      ( [s (format "Saving ~a" (file-name-from-path file))]
+        [_ (mrspidey:progress s '...)]
+        [_ (when (file-exists? file) (delete-file file))]
+        [p (open-output-file file 'text)]
+        [disp (lambda (x) (write x p) (newline p))]
+        [num-Tvar-live (length Tvar-live)]
+        [(get-Tvar-ndx set-Tvar-ndx!) (alloc-Tvar-field)]
+        [Tvar-ndx
+          (lambda (tvar)
+            (let ([ndx (get-Tvar-ndx tvar)])
+              '(unless (number? ndx)
+                 (error 'write-constraint-set::Tvar-ndx
+                   "Tvar ~s not live ~s"
+                   (Tvar-name tvar) (map Tvar-name Tvar-live)))
+              ndx))]
+        [(AV-ndx set-AV-ndx!) (alloc-AV-field)]
+        [num-nu-AV 0])
+
+      ;; --- assign number to each live Tvar
+      (for-each-with-n
+        (lambda (Tvar n)
+          (assert (eq? (Tvar-ndx Tvar) #f))
+          (set-Tvar-ndx! Tvar n))
+        Tvar-live)
+
+      ;; --- write version
+      (disp `(st:version ,(st:version)))
+
+      ;; --- write configuration
+      (pretty-print (mrspidey:control-fn) p)
+
+      ;; --- write num Tvars
+      (disp `(num-Tvar ,num-Tvar-live))
+
+      ;; --- write constructor-env
+      (disp `START-constructor-env)
+      (hash-table-for-each
+        constructor-env
+        (lambda (sym template)
+          (unless 
+            (hash-table-get saved-constructor-env sym (lambda () #f))
+            (match template
+              [($ template type n+ n- ref assign super-templates)
+                (disp (list type n+ n- ref assign 
+                        (map template-type super-templates)))]))))
+        ;; reverse it so defns in file occur before references ???
+      (disp 'END-constructor-env)
+
+      ;; --- write AV
+      (disp `START-AV)
+      (for-each
+        (lambda (Tvar)
+          ;;(pretty-print (Tvar-name Tvar))
+          (for-each
+            (match-lambda 
+              [(and AV ($ AV num ($ template type) misc fields+ fields-))
+                (unless (AV-ndx AV)
+                  (set-AV-ndx! AV num-nu-AV)
+                  (set! num-nu-AV (add1 num-nu-AV))
+                  (disp (list type
+                          (if (or (number? misc) (char? misc) (symbol? misc)
+                                (pair? misc))
+                            misc
+                            '())
+                          (map Tvar-ndx (vector->list fields+))
+                          (map Tvar-ndx (vector->list fields-)))))])
+            (Tvar-objs Tvar)))
+        Tvar-live)
+      (disp 'END-AV)
+
+      ;; --- write Tvar
+      (disp 'START-Tvar)
+      (for-each
+        (lambda (Tvar)
+          (disp 
+            (append (map AV-ndx (Tvar-objs Tvar))
+              (map 
+                (match-lambda
+                  [($ con _ ($ template type) field-no Tvar sign)
+                    (list type field-no (Tvar-ndx Tvar) sign)]
+                  [($ con-filter _ ($ filter sign (($ template types) ...)) 
+                     Tvar)
+                    (list sign types (Tvar-ndx Tvar))])
+                (Tvar-constraints Tvar))
+              (let ([edgeto (Tvar-edgeto Tvar)])
+                (if (null? edgeto)
+                  '()
+                  (cons 'T (map Tvar-ndx edgeto)))))))
+        Tvar-live)
+      (disp 'END-Tvar)
+
+      ;; --- write in-env, out-env
+      (let ([rep-envs (mk-envs Tvar-ndx)])
+        (pretty-print `(envs  ,@rep-envs)  p)
+        ;; --- all done
+        (close-output-port p))
+      (mrspidey:progress s 'done))))
+
+;; ----------------------------------------------------------------------
+
+(define (read-constraint-set file)
+  (match-let*
+    ([p (open-input-file file 'text)]
+      [('st:version save-st:version) (read p)]
+      [configuration (read p)]
+      [('num-Tvar save-num-Tvar) (read p)]
+      [vec-Tvar (make-vector save-num-Tvar #f)]
+      [vec-AV  (void)]
+      [lookup-Tvar
+        (lambda (n)
+          (if (number? n)
+            (vector-ref vec-Tvar n)
+            (let ([Tvar (mk-Tvar 'load-empty)])
+              Tvar)))]
+      [lookup-AV
+        (lambda (n)
+          (let ([AV (vector-ref vec-AV n)])
+            (assert (AV? AV) 'lookup-AV)
+            AV))])
+
+    (unless (equal? save-st:version (st:version))
+      (mrspidey:error ".za file from previous MrSpidey release"))
+
+    (for i 0 save-num-Tvar (vector-set! vec-Tvar i (mk-Tvar 'load)))
+
+    ;; --- constructors
+
+    (match (read p) ['START-constructor-env (void)])
+    (recur loop ()
+      (match (read p)
+        [(type n+ n- ref assign super)
+          (let ([t (make-template type n+ n- ref assign '() eqv?)])
+            (for-each
+              (lambda (s) (record-super-constructor-of-template! s t))
+              (reverse super))
+            (extend-constructor-env! t)
+            (loop))]
+        ['END-constructor-env (void)]))
+
+    ;; --- AV's
+
+    (match (read p) ['START-AV (void)])
+    (set! vec-AV
+      (list->vector
+        (recur loop ()
+          (match (read p)
+            [(C misc tvar-num+* tvar-num-*)
+              (cons 
+                (create-AV (lookup-template C)
+                  misc
+                  (list->vector (map lookup-Tvar tvar-num+*))
+                  (list->vector (map lookup-Tvar tvar-num-*)))
+                (loop))]
+            ['END-AV '()]))))
+
+    ;; --- Tvar's
+
+    (match (read p) ['START-Tvar (void)])
+    (let ([new-AV!  add-AV!]
+           [new-con! add-con!]
+           [new-edge! add-edge!])
+      (recur loop ([n 0])
+        (match (read p)
+          ['END-Tvar (void)]
+          [in 
+            (let ([Tvar (lookup-Tvar n)])
+              (recur loop2 ([in in])
+                (match in
+                  [() (void)]
+                  [((? integer? n) . rest)
+                    (new-AV! Tvar (lookup-AV n))
+                    (loop2 rest)]
+                  [(((? boolean? sign) C* tvar-num) . rest)
+                    (new-con! 
+                      Tvar
+                      (create-con-filter
+                        (create-filter sign (map lookup-template C*))
+                        (lookup-Tvar tvar-num)))
+                    (loop2 rest)]
+                  [((C n tvar-num sign) . rest)
+                    (new-con! 
+                      Tvar
+                      (create-con 
+                        (lookup-template C) n 
+                        (lookup-Tvar tvar-num) sign))
+                    (loop2 rest)]
+                  [('T . edgeto*)
+                    (for-each
+                      (lambda (tvar-num)
+                        (new-edge! Tvar (lookup-Tvar tvar-num)))
+                      edgeto*)])))
+            (loop (add1 n))])))
+
+    ;; --- in-env and out-env
+
+    (match-let*
+      ([('envs  . envs)  (read p)])
+
+      (close-input-port p)
+      
+      (values
+        (vector->list vec-Tvar)
+        envs
+        lookup-Tvar))))
+
+;; ----------------------------------------------------------------------
+

collects/mrspidey/Sba/zod-aux.ss

@@ -0,0 +1,622 @@
+; zodiac-aux.ss
+; Helper functions for zodiac structures
+; ----------------------------------------------------------------------
+; Copyright (C) 1995-97 Cormac Flanagan
+;
+; This program is free software; you can redistribute it and/or
+; modify it under the terms of the GNU General Public License
+; version 2 as published by the Free Software Foundation.
+; 
+; This program is distributed in the hope that it will be useful,
+; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+; GNU General Public License for more details.
+; 
+; You should have received a copy of the GNU General Public License
+; along with this program; if not, write to the Free Software
+; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
+; ----------------------------------------------------------------------
+; ----------------------------------------------------------------------
+
+(define compat
+  (lambda (fn)
+    (letrec
+        ([cl-fn
+          (lambda (exp)
+            ;;(pretty-print-debug `(compat ,(stripper exp)))
+            (let ([r (fn exp cl-fn)])
+              (if r
+                  r
+                  (match exp
+                    [($ zodiac:if-form o s f b test then else)
+                     (zodiac:make-if-form o s f b
+                      (cl-fn test) (cl-fn then) (cl-fn else))]
+                    ;;[($ zodiac:lambda-form  o s f b args body)
+                    ;; (let* ([args (map-ilist cl-fn args)])
+                    ;;   (zodiac:make-lambda-form o s f b args (cl-fn body)))]
+
+                    [($ zodiac:case-lambda-form  o s f b arglists bodies)
+                     (zodiac:make-case-lambda-form 
+                      o s f b
+                       (map cl-fn arglists)
+                       (map cl-fn bodies))]
+                    [($ zodiac:arglist vars)
+                      (zodiac:make-arglist (map cl-fn vars))]
+                    [($ zodiac:set!-form o s f b  var val)
+                     (zodiac:make-set!-form o s f b (cl-fn var) (cl-fn val))]
+                    [($ zodiac:begin-form o s f b bodies)
+                     (zodiac:make-begin-form o s f b (map cl-fn bodies))]
+                    [($ zodiac:let-values-form o s f b  varss vals body)
+                     (let ([varss (map (lambda (vars) (map cl-fn vars))
+                                       varss)])
+                       (zodiac:make-let-values-form 
+                        o s f b
+                        varss (map cl-fn vals) (cl-fn body)))]
+                    [($ zodiac:letrec*-values-form o s f b  varss vals body)
+                     (let ([varss (map (lambda (vars) (map cl-fn vars))
+                                       varss)])
+                       (zodiac:make-letrec*-values-form 
+                        o s f b
+                        varss (map cl-fn vals) (cl-fn body)))]
+                    [($ zodiac:define-values-form o s f b vars value)
+                     (zodiac:make-define-values-form o s f b 
+                                                     (map cl-fn vars)
+                                                     (cl-fn value))]
+                    [($ zodiac:poly-form o s f b exp)
+                     (zodiac:make-poly-form o s f b (cl-fn exp))]
+
+                    [($ zodiac:app o s f b fun args)
+                     (zodiac:make-app o s f b
+                                      (cl-fn fun) (map cl-fn args))]
+                    ;;[($ zodiac:delay-form o s f b expr)
+                    ;; (zodiac:make-delay-form o s f b (cl-fn expr))]
+                    
+                    [($ zodiac::-form o s f b exp type)
+                     (zodiac:make-:-form o s f b (cl-fn exp) type)]
+
+                    [($ zodiac:type:-form o s f b type attrs) 
+                      exp]
+
+                    [($ zodiac:unit-form o s f b imports exports body)
+                     (zodiac:make-unit-form o s f b 
+                       (map cl-fn imports)
+                       (map 
+                         (match-lambda
+                           [(varref . sym)
+                             (cons (cl-fn varref) sym)])
+                         exports)
+                       (map cl-fn body))]
+                    [($ zodiac:compound-unit-form o s f b
+                        imports links exports)
+                     ;;(pretty-print-debug `compound-unit)
+                     (zodiac:make-compound-unit-form
+                      o s f b 
+                       (map cl-fn imports)
+                      (map (match-lambda
+                            [(tag exp . imports)
+                              ;;(pretty-print-debug `compound-unit-link)
+                              (list*
+                                tag
+                                (cl-fn exp)
+                                (map 
+                                  (lambda (import)
+                                    (if (zodiac:lexical-varref? import)
+                                      (cl-fn import)
+                                      import))
+                                  imports))])
+                           links)
+                      exports)]
+                    [($ zodiac:reference-unit-form o s f b file kind signed?)
+                      (zodiac:make-reference-unit-form o s f b 
+                        file kind signed?)]
+
+                    [($ zodiac:invoke-unit-form o s f b exp vars)
+                     (zodiac:make-invoke-unit-form 
+                      o s f b 
+                      (cl-fn exp) (map cl-fn vars))]
+
+                    ;; ---------- objects! ----------
+                    [($ zodiac:class*/names-form o s f b
+                       this super-init super-expr interfaces init-vars 
+                       inst-clauses)
+                      (zodiac:make-class*/names-form o s f b
+                        (cl-fn this)
+                        (cl-fn super-init)
+                        (cl-fn super-expr)
+                        interfaces
+                        (cl-fn init-vars)
+                        (map cl-fn inst-clauses))]
+                    [($ zodiac:public-clause exports internals exprs)
+                      (zodiac:make-public-clause 
+                        exports
+                        (map cl-fn internals)
+                        (map cl-fn exprs))]
+                    [($ zodiac:private-clause internals exprs)
+                      (zodiac:make-private-clause 
+                        (map cl-fn internals)
+                        (map cl-fn exprs))]
+                    [($ zodiac:inherit-clause internals imports)
+                      (zodiac:make-inherit-clause 
+                        (map cl-fn internals) imports)]
+                    [($ zodiac:rename-clause internals inheriteds)
+                      (zodiac:make-rename-clause 
+                        (map cl-fn internals)
+                        (map cl-fn inheriteds))]
+                    [($ zodiac:sequence-clause exprs)
+                      (zodiac:make-sequence-clause (map cl-fn exprs))]
+
+                    ;; ---------- sexps ----------
+                    [($ zodiac:list o s f l len marks)
+                     (zodiac:make-list o s f (map cl-fn l) len marks)]
+
+                    [_ exp]))))])
+      cl-fn)))
+
+(define compat*
+  (lambda (fn)
+    (let ([cl-fn (compat fn)])
+      (lambda (exp*) (map cl-fn exp*)))))
+
+; ----------------------------------------------------------------------
+
+(define (ast-size defs)
+  (let* ([size 0]
+         [fn (lambda (x f)
+               (set! size
+                   (+ size
+                      (match x
+                        [($ zodiac:quote-form 0 s f b expr)
+                         (const-size expr)]
+                        [_ 1])))
+               #f)])
+    ((compat* fn) defs)
+    size))
+
+; ----------------------------------------------------------------------
+;; const-size
+;; Gives the size of a zodiac constant
+
+(define const-size
+  (match-lambda
+   [(a . d) (+ 1 (const-size a) (const-size d))]
+   [(or ($ zodiac:list _ _ _ l) ($ zodiac:improper-list _ _ _ l))
+    (const-size l)]
+   [(or (? vector? v) ($ zodiac:vector _ _ _ v))
+    (+ 1 (apply + (map const-size v)))]
+   [else 1]))
+
+; ----------------------------------------------------------------------
+
+(define unparse-dynamic-letd
+  (lambda (fn)
+    (letrec
+        ([cl-fn
+          (lambda  (exp)
+            (let ([r (fn exp cl-fn)])
+              (if r
+                  r
+                  (match exp
+                    [($ zodiac:varref _ _ _ _ sym) sym]
+                    [($ zodiac:binding _ _ _ _ sym) sym]
+                    [($ zodiac:if-form _ _ _ _ test then else)
+                     `(if ,(cl-fn test) ,(cl-fn then) ,(cl-fn else))]
+                    ;;[($ zodiac:lambda-form _ _ _ _ args body)
+                    ;; (let* ([args (map-ilist cl-fn args)])
+                    ;;   `(lambda ,args ,(cl-fn body)))]
+                    [($ zodiac:case-lambda-form _ _ _ _ arglists bodies)
+                     `(case-lambda
+                       ,@(map
+                          (lambda (arglist body)
+                            (list (cl-fn arglist) (cl-fn body)))
+                           arglists bodies))]
+                    [($ zodiac:sym-arglist (var)) (cl-fn var)]
+                    [($ zodiac:list-arglist vars) (map cl-fn vars)]
+                    [($ zodiac:ilist-arglist vars) 
+                      (cons (map cl-fn (rdc vars)) (cl-fn (rac vars)))]
+                    [($ zodiac:set!-form _ _ _ _ var val)
+                     `(set! ,(cl-fn var) ,(cl-fn val))]
+                    [($ zodiac:begin-form _ _ _ _ bodies)
+                      `(begin ,@(map cl-fn bodies))]
+                    [($ zodiac:let-values-form _ _ _ _ varss vals body)
+                     (let ([varss (map (lambda (vars) (map cl-fn vars))
+                                       varss)])
+                       `(let-values ,(map list varss (map cl-fn vals))
+                          ,(cl-fn body)))]
+                    [($ zodiac:letrec*-values-form _ _ _ _ varss vals body)
+                     (let ([varss (map (lambda (vars) (map cl-fn vars))
+                                       varss)])
+                       `(letrec*-values ,(map list varss (map cl-fn vals))
+                          ,(cl-fn body)))]
+                    [($ zodiac:define-values-form _ _ _ _ vars value)
+                     `(define-values ,(map cl-fn vars) ,(cl-fn value))]
+                    [($ zodiac:poly-form _ _ _ _ exp)
+                     `(poly ,(cl-fn exp))]
+                    [($ zodiac:app _ _ _ _ fun args)
+                     `(,(cl-fn fun) ,@(map cl-fn args))]
+                    [($ zodiac:quote-form _ _ _ _ expr)
+                     (list 'quote (cl-fn expr))]
+                    [($ zodiac::-form _ _ _ _ exp type)
+                     (list ': (cl-fn exp) type)]
+                    [($ zodiac:st:control-form o s f b para val)
+                     (list 'st:control para val)]
+
+                    ;; [($ zodiac:unchanged _ _ _ _ expr) (cl-fn expr)]
+                    [($ zodiac:unit-form o s f b imports exports body)
+                     `(unit (import ,@(map cl-fn imports))
+                            (export 
+                             ,@(map (match-lambda 
+                                     [(i . e) (list (cl-fn i) (zodiac:read-object e))])
+                                    exports))
+                            ,@(map cl-fn body))]
+                    [($ zodiac:compound-unit-form _ _ _ _ 
+                        imports links exports)
+                     `(compound-unit
+                       (import ,@(map cl-fn imports))
+                       (link 
+                        ,@(map 
+                            (match-lambda
+                              [(tag exp . imports)
+                                (list tag
+                                  (cons 
+                                    (cl-fn exp) 
+                                    (map (match-lambda
+                                           [(tag . sym) (list tag sym)]
+                                           [(? zodiac:varref? lvr)
+                                             (zodiac:varref-var lvr)])
+                                      imports)))])
+                               links))
+                       (export ,@(map
+                                  (match-lambda
+                                   [(tag i . e) (list tag (list i e))])
+                                  exports)))]
+                    [($ zodiac:invoke-unit-form _ _ _ _ exp)
+                     `(invoke-unit ,(cl-fn exp))]
+                    [($ zodiac:reference-unit-form _ _ _ _ file kind signed?)
+                      (list 
+                        (if signed?
+                          'reference-unit
+                          'reference-unit/sig)
+                        file)]
+                    [($ zodiac:struct-form _ _ _ _ 
+                       ($ zodiac:symbol _ _ _ tag)
+                       parent 
+                       (($ zodiac:symbol _ _ _ fields) ...))
+                     `(struct
+                        ,(if parent (list tag (cl-fn parent)) tag)
+                        ,fields)]
+                    [($ zodiac:string  _ _ _ text) text]
+                    [($ zodiac:boolean _ _ _ text) text]
+                    [($ zodiac:char    _ _ _ text) text]
+                    [($ zodiac:symbol  _ _ _ text) text]
+                    [($ zodiac:number  _ _ _ text) text]
+                    [($ zodiac:list    _ _ _ contents) 
+                     (map cl-fn contents)]
+                    [($ zodiac:improper-list _ _ _ contents)
+                     (map-ilist cl-fn contents)]
+                    [($ zodiac:vector  _ _ _ contents)
+                     (list->vector (map cl-fn contents))]
+                    [($ zodiac:define-type-form _ _ _ _ sym type)
+                     `(define-type ,sym ,type)]
+                    [($ zodiac:define-constructor-form _ _ _ _ sym modes)
+                     `(define-constructor ,sym ,@modes)]
+                    [x x]
+                    ;;[_ (error 'unparse "Bad exp ~s" exp)]
+                    ))))])
+      cl-fn)))
+
+'(define (stripper exp)
+   ((unparse-dynamic-letd (lambda (x cl-fn) #f))
+     exp))
+
+(define (stripper exp)
+  (if (zodiac:parsed? exp)
+    (zodiac:parsed->raw exp)
+    'stripper:not-a-parsed))
+
+; ======================================================================
+;; Routines to add fields to each zodiac structure
+;; mutated and refs fields are only for binding structures
+
+(define (myzodiac:register-client name init-fn)
+  (let*-vals
+    ([(getter setter) (zodiac:register-client name init-fn)])
+    (values
+      (lambda (parsed) (getter (zodiac:parsed-back parsed)))
+      (lambda (parsed val) (setter (zodiac:parsed-back parsed) val)))))
+
+(define-values
+  (parsed-ftype set-parsed-ftype!)
+  (myzodiac:register-client 'ftype (lambda () #f)))
+
+(define-values
+  (parsed-check set-parsed-check!)
+  (myzodiac:register-client 'check (lambda () #f)))
+
+(define-values
+  (parsed-atprim set-parsed-atprim!)
+  (myzodiac:register-client 'atprim (lambda () #f)))
+
+(define-values
+  (app-tvar-args set-app-tvar-args!)
+  (myzodiac:register-client 'app-args (lambda () #f)))
+
+(define-values
+  (binding-refs set-binding-refs!)
+  (myzodiac:register-client 'refs (lambda () 0)))
+
+(define-values
+  (binding-mutated set-binding-mutated!)
+  (myzodiac:register-client 'mutated (lambda () #f)))
+
+;;(trace binding-mutated)
+;;(trace set-binding-mutated!)
+
+;; ----------------------------------------------------------------------
+;; Info on varrefs
+
+(define (get-top-level-varref-binding x) 
+  (let* ( [b (zodiac:top-level-varref/bind-slot x)]
+          [u (unbox b)])
+    (if (zodiac:binding? u)
+      u
+      (let ([u (my-create-binding 
+                 (zodiac:varref-var x)
+                 (zodiac:zodiac-start x)
+                 (zodiac:zodiac-finish x))])
+        (set-box! b u)
+        u))))
+
+(define (varref-binding varref)
+  (match varref
+    [($ zodiac:bound-varref) (zodiac:bound-varref-binding varref)]
+    [($ zodiac:top-level-varref/bind) (get-top-level-varref-binding varref)]
+    [x (error 'varref-backinfo "Bad varref ~s" x)]))
+
+(define my-create-binding
+  (case-lambda
+    [(name) (my-create-binding name (no-location) (no-location))]
+    [(name open close)
+      (zodiac:make-binding
+        (zodiac:make-origin 'non-source 'spidey)
+        open close (zodiac:make-empty-back-box) name name)]))
+
+;; ----------------------------------------------------------------------
+
+(define lambda-flatten-arglist
+  (match-lambda
+   [($ zodiac:list _ _ _ l) l]
+   [($ zodiac:improper-list _ _ _ l x) (append l (list x))]
+   [(? zodiac:binding? b) (list b)]
+   [() '()]
+   [(a . b) (cons a (lambda-flatten-arglist b))]))
+
+; ----------------------------------------------------------------------
+
+(define (no-location) (zodiac:make-location 0 0 0 "no-file"))
+
+(define (location-inc loc)
+  (zodiac:make-location 
+   0 0
+   (add1 (zodiac:location-offset loc))
+   (zodiac:location-file loc)))
+
+(define determine-end-first-token
+  (lambda (object)
+    (cond
+      [(or (zodiac:scalar? object)
+         (zodiac:varref? object)
+         (zodiac:binding?  object)
+         (and (zodiac:quote-form? object)
+           (or
+             (zodiac:boolean? (zodiac:quote-form-expr object))
+             (zodiac:char? (zodiac:quote-form-expr object))
+             (zodiac:symbol? (zodiac:quote-form-expr object))
+             (zodiac:number? (zodiac:quote-form-expr object)))))
+        (location-inc (zodiac:zodiac-finish object))]
+      [(or (zodiac:sequence? object)
+         (zodiac:parsed?     object)
+         (zodiac:app?      object))
+        (location-inc (zodiac:zodiac-start object))]
+      [else (error 'zodiac:determine-end-first-token
+              "shouldn't be here ~s" object)])))
+
+; ----------------------------------------------------------------------
+
+(define parsed-value?
+  (match-lambda
+    [(or
+       ($ zodiac:quote-form)
+       ;;($ zodiac:lambda-form)
+       ($ zodiac:case-lambda-form)
+       ($ zodiac:lexical-varref)) #t]
+    [($ zodiac:letrec*-values-form 
+       _ _ _ _ vars 
+       ((? parsed-value?) ...)
+       (? parsed-value?)) #t]
+    [_ #t]))
+      
+; ----------------------------------------------------------------------
+
+(define free-refs
+  (lambda (exp bindings)
+    (let* ( [hash-bindings (make-hash-table)]
+            [_ (for-each
+                 (lambda (bind) (hash-table-put! hash-bindings bind #t))
+                 bindings)]
+            [refs '()]
+            [fn
+              (lambda (exp cl-fn)
+                (match exp
+                  [($ zodiac:varref)
+                    (let ([bind (varref-binding exp)])
+                      (when 
+                        (hash-table-get hash-bindings bind (lambda () #f))
+                        (set! refs (cons bind refs))))
+                    #f]
+                  [($ zodiac:unit-form) 'do-not-traverse]
+                  [_ #f]))])
+      ((compat fn) exp)
+      refs)))
+               
+(define (free-vars exp bindings) (list->set (free-refs exp bindings)))
+
+;; ----------------------------------------------------------------------
+
+(define (initialize-mutated defs)
+  (let* (;; set binding of mutated variables
+          [_ (for-each
+               (match-lambda
+                 [($ zodiac:define-values-form _ _ _ _ varrefs expr) 
+                   (match expr
+                     ;; kludge - don't consider define-struct variables
+                     ;; to be mutable
+                     [($ zodiac:struct-form) (void)]
+                     [_
+                       (for-each
+                         (lambda (varref) 
+                           (set-binding-mutated!
+                             (get-top-level-varref-binding varref)
+                             #t))
+                         varrefs)])]
+                 [_ (void)])
+               defs)]
+          [free '()]
+          [fn
+            (lambda (def cl-fn)
+              ;;(display `(initialize-mutated ,(stripper def))) (newline)
+              (match def
+                [($ zodiac:letrec*-values-form _ _ _ _ varss)
+                  (for-each 
+                    (lambda (vars)
+                      (for-each
+                        (lambda (var) (set-binding-mutated! var #t))
+                        vars))
+                    varss)
+                  #f]
+                [($ zodiac:set!-form _ _ _ _ var) 
+                  ;;(display `(initialize-mutated! ,(stripper var))) (newline)
+                  (set-binding-mutated! (varref-binding var) #t)
+                  #f]
+                [_ #f]))])
+    ((compat* fn) defs)
+    free))
+
+(define (free-vars-defs defs)
+  (let* ( ;; Put binding on slot field of variables that are defined
+          ;; and set to mutated
+          [_ (for-each
+               (match-lambda
+                 [($ zodiac:define-values-form _ _ _ _ varrefs expr) 
+                   (match expr
+                     ;; kludge - don't consider define-struct variables
+                     ;; to be mutable
+                     [($ zodiac:struct-form) 
+                       (for-each
+                         (lambda (varref) 
+                           (get-top-level-varref-binding varref))
+                         varrefs)]
+                     [_
+                       (for-each
+                         (lambda (varref) 
+                           (set-binding-mutated!
+                             (get-top-level-varref-binding varref)
+                             #t))
+                         varrefs)])]
+                 [_ (void)])
+               defs)]
+          [free '()]
+          [fn
+            (lambda (def cl-fn)
+              ;;(pretty-debug `(get-tlvr ,(stripper def)))
+              (match def
+                [($ zodiac:top-level-varref/bind)
+                  (when
+                    (not 
+                      (zodiac:binding?
+                        (unbox (zodiac:top-level-varref/bind-slot def))))
+                    (set! free 
+                      (cons (get-top-level-varref-binding def) free)))
+                  #f]
+                [($ zodiac:unit-form) 'do-not-traverse]
+                [($ zodiac:letrec*-values-form _ _ _ _ varss)
+                  (for-each 
+                    (lambda (vars)
+                      (for-each
+                        (lambda (var) (set-binding-mutated! var #t))
+                        vars))
+                    varss)
+                  #f]
+                ;; struct-ref in function posn is not a free variable
+                [($ zodiac:app _ _ _ _ 
+                   ($ zodiac:top-level-varref/bind _ _ _ _ 'struct-ref)
+                   args)
+                  (for-each cl-fn args)
+                  #t]
+                [_ #f]))])
+    ((compat* fn) defs)
+    free))
+
+;; ----------------------------------------------------------------------
+
+(define (zero! p)
+  '(let-macro 
+     zerostruct
+     (lambda (name . fields)
+       `(begin
+          ;;(display ',(symbol-append 'zodiac: name))
+          (when (,(symbol-append 'zodiac: name '?) p)
+            ,@(map
+                (lambda (field)
+                  `(begin
+                     ;;(display ',(symbol-append 'zodiac: name '- field))
+                     (zero! 
+                       (begin0
+                         (,(symbol-append 'zodiac: name '- field) p)
+                         (,(symbol-append 'zodiac:set- name '- field '!) p 'zro)))))
+                fields))))
+
+     (zerostruct parsed back)
+     (zerostruct app fun args)
+     (zerostruct varref var)
+     (zerostruct bound-varref binding)
+     (zerostruct binding var orig-name)
+     (zerostruct top-level-varref/bind slot)
+     (zerostruct arglist vars)
+     (zerostruct paroptarglist vars)
+     (zerostruct set!-form var val)
+     (zerostruct begin-form bodies)
+     (zerostruct begin0-form bodies)
+     (zerostruct define-values-form vars val)
+     (zerostruct let-values-form vars vals body)
+     (zerostruct letrec*-values-form vars vals body)
+     (zerostruct if-form test then else)
+     (zerostruct quote-form expr)
+     (zerostruct case-lambda-form args bodies)
+     (zerostruct struct-form type super fields)
+     (zerostruct unit-form imports exports clauses)
+     (zerostruct compound-unit-form imports links exports)
+     (zerostruct invoke-unit-form unit variables)
+     (zerostruct invoke-open-unit-form unit name-specifier variables)
+     (zerostruct class*-form this super-names super-exprs init-vars inst-clauses)
+     (zerostruct public-clause exports internals exprs)
+     (zerostruct private-clause internals exprs)
+     (zerostruct inherit-clause internals imports)
+     (zerostruct rename-clause internals imports)
+     (zerostruct sequence-clause exprs)
+     (when (pair? p)
+       (zero! (begin0 (car p) (set-car! p 'zro)))
+       (zero! (begin0 (cdr p) (set-cdr! p 'zro))))
+
+     ))
+
+;; ----------------------------------------------------------------------
+
+(define (inline-begins defs)
+  (recur loop ([defs defs])
+    (match defs
+      [() '()]
+      [(($ zodiac:begin-form _ _ _ _ bodies) . rest)
+        (append (loop bodies) (loop rest))]
+      [(def . rest)
+        (cons def (loop rest))])))
+

collects/mrspidey/Sba/zod-extra.ss

@@ -0,0 +1,75 @@
+; zod-extra.ss
+; ----------------------------------------------------------------------
+; Copyright (C) 1995-97 Cormac Flanagan
+;
+; This program is free software; you can redistribute it and/or
+; modify it under the terms of the GNU General Public License
+; version 2 as published by the Free Software Foundation.
+; 
+; This program is distributed in the hope that it will be useful,
+; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+; GNU General Public License for more details.
+; 
+; You should have received a copy of the GNU General Public License
+; along with this program; if not, write to the Free Software
+; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
+; ----------------------------------------------------------------------
+
+(define mrspidey:zodiac:parameters@
+  (unit/sig plt:parameters^
+            (import)
+            (define case-sensitive? #t)
+            (define unmatched-cond/case-is-error? #t)
+            (define allow-set!-on-undefined? #t)
+            (define allow-improper-lists? #t)
+            (define check-syntax-level 'advanced)
+            ;(define allow-internal-defines? #f)
+            ))
+
+(define mrspidey:zodiac:interface@
+  (unit/sig zodiac:interface^
+    (import mrspidey:interaction^)
+    (define default-error-handler
+      (lambda (keyword)
+        (lambda (where fmt-spec . args)
+          (apply mrspidey:internal-error
+            keyword fmt-spec args))))
+    (define internal-error
+      (lambda (where fmt-spec . args)
+        (let ([msg 
+                (parameterize ([print-struct #t])
+                  (string-append "Syntax error: " 
+                    (apply format fmt-spec args)))])
+          (if #t                        ;(zodiac:zodiac? where)
+            (mrspidey:error msg where)                    
+            (mrspidey:error msg)))))
+    (define static-error
+      (lambda (where fmt-spec . args)
+        (let ([msg
+                (parameterize ([print-struct #t])
+                  (string-append "Syntax error: " 
+                    (apply format fmt-spec args)))])
+          (if #t                        ;(zodiac:zodiac? where)
+            (mrspidey:error msg where)                    
+            (mrspidey:error msg)))))
+    (define dynamic-error
+      (default-error-handler 'zodiac-run-time))))
+
+;; ----------------------------------------------------------------------
+
+(define mrspidey:zodiac-aux@
+  (unit/sig
+    mrspidey:zodiac-aux^
+    (import
+      mrspidey:CDL^
+      (zodiac : zodiac:system^))
+    (include "zod-aux.ss")))
+
+;; ----------------------------------------------------------------------
+
+(load-relative "zod-link.ss")
+
+
+
+

collects/mrspidey/Sba/zod-link.ss

@@ -0,0 +1,22 @@
+;; zod-link.ss
+
+(define mrspidey:zodiac@;; mrspidey:zodiac^
+  (compound-unit/sig
+    (import 
+      (CDL : mrspidey:CDL^)
+      (INTERACTION : mrspidey:interaction^))
+    (link
+      [PARAMETERS : 
+        plt:parameters^
+        (mrspidey:zodiac:parameters@)]
+      [INTERFACE : 
+        zodiac:interface^
+        (mrspidey:zodiac:interface@ INTERACTION)]
+      [Z : 
+        zodiac:system^
+        (zodiac:system@ INTERFACE PARAMETERS (CORE pretty-print@) (CORE file@))]
+      [CORE : 
+        mzlib:core^
+        ((reference-library-unit/sig "corer.ss"))]
+      [AUX : mrspidey:zodiac-aux^ (mrspidey:zodiac-aux@ CDL Z)])
+    (export (open Z) (open AUX))))

collects/mrspidey/about.html

@@ -0,0 +1,36 @@
+<HTML>
+<HEAD>
+<TITLE>About MrSpidey</TITLE>
+</HEAD>
+
+<body>
+<H1>
+<img align=left src="logo.gif" border=0 alt="[logo]">
+MrSpidey</H1>
+<P>
+MrSpidey version 49s1, Copyright (C) 1995-97 Cormac Flanagan
+<p>
+MrSpidey is an interactive, graphical static debugger for Scheme. For more information, visit the 
+<A HREF="http://www.cs.rice.edu/CS/PLT/packages/mrspidey/index.html"> MrSpidey home page</A>
+<P>
+Thanks to Matthew Flatt and Robby Findler for MrEd, and to Shriram
+Krishnamurthi for his source-correlating macro-expander. Thanks also
+to Stephanie Weirich for work on the first implementation of MrSpidey,
+and to Matthias Felleisen and Corky Cartwright for their feedback and
+help.
+<p>
+This program is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public License
+version 2 as published by the Free Software Foundation.
+<p>
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+<p>
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
+
+
+</body>