mbutterick
/
br-parser-tools
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

import

Browse Source 
original commit: f06c1626f7d4154a72427096b2993d49db72ceb1
tokens
Matthew Flatt 27 years ago
parent 5c82f510da
commit 94e3de51bd
1025 changed files with 378763 additions and 0 deletions
Show Stats Download Patch File Download Diff File

16
collects/mrdemo/keymap.ss
Unescape Escape View File

@ -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"))

2
collects/mrdemo/load.ss
Unescape Escape View File

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

BIN
collects/mrdemo/mines.mre
View File

Binary file not shown.

379
collects/mrdemo/mines.ss
Unescape Escape View File

@ -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)

BIN
collects/mrdemo/morph.mre
View File

Binary file not shown.

1
collects/mrdemo/morph.ss
Unescape Escape View File

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

57
collects/mrdemo/morph/2darray.ss
Unescape Escape View File

@ -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)))))

96
collects/mrdemo/morph/coord.ss
Unescape Escape View File

@ -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)))))

57
collects/mrdemo/morph/debug.ss
Unescape Escape View File

@ -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))))

154
collects/mrdemo/morph/engine.ss
Unescape Escape View File

@ -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))))

15
collects/mrdemo/morph/load.ss
Unescape Escape View File

@ -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")

76
collects/mrdemo/morph/main.ss
Unescape Escape View File

@ -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%))))))

138
collects/mrdemo/morph/mesh.ss
Unescape Escape View File

@ -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)))

120
collects/mrdemo/morph/pager.ss
Unescape Escape View File

@ -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))))

46
collects/mrdemo/morph/setup.ss
Unescape Escape View File

@ -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)))

407
collects/mrdemo/morph/ui.ss
Unescape Escape View File

@ -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)

114
collects/mrdemo/morph/utils.ss
Unescape Escape View File

@ -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")))))

BIN
collects/mrdemo/ncad.mre
View File

Binary file not shown.

1395
collects/mrdemo/ncad02x.ss
View File

File diff suppressed because it is too large Load Diff

BIN
collects/mrdemo/phone.mre
View File

Binary file not shown.

163
collects/mrdemo/phone.ss
Unescape Escape View File

@ -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))))

1
collects/mrdemo/sig.ss
Unescape Escape View File

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

BIN
collects/mrdemo/toyproof.mre
View File

Binary file not shown.

377
collects/mrdemo/toyproof.ss
Unescape Escape View File

@ -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)))

BIN
collects/mrdemo/turtles.mre
View File

Binary file not shown.

5
collects/mrdemo/turtles.ss
Unescape Escape View File

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

343
collects/mrspidey/Gui/Tframe.ss
Unescape Escape View File

@ -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)
)))

1073
collects/mrspidey/Gui/annotat.ss
View File

File diff suppressed because it is too large Load Diff

137
collects/mrspidey/Gui/arrow.ss
Unescape Escape View File

@ -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))])))]))))
;; ----------------------------------------

108
collects/mrspidey/Gui/deltas.ss
Unescape Escape View File

@ -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)"))
;; ----------------------------------------------------------------------

193
collects/mrspidey/Gui/dyn-edit.ss
Unescape Escape View File

@ -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)
)))

147
collects/mrspidey/Gui/graphics.ss
Unescape Escape View File

@ -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)
)))
;; ----------------------------------------

29
collects/mrspidey/Gui/load.ss
Unescape Escape View File

@ -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")

42
collects/mrspidey/Gui/loadu.ss
Unescape Escape View File

@ -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")
))

553
collects/mrspidey/Gui/main.ss
Unescape Escape View File

@ -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))))
;; ----------------------------------------------------------------------

330
collects/mrspidey/Gui/prefs.ss
Unescape Escape View File

@ -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)))

168
collects/mrspidey/Gui/progress.ss
Unescape Escape View File

@ -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)
)

72
collects/mrspidey/Gui/statedit.ss
Unescape Escape View File

@ -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)
)))

23
collects/mrspidey/Gui/test-gui.ss
Unescape Escape View File

@ -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)))

307
collects/mrspidey/Sba/atenv.ss
Unescape Escape View File

@ -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))
;; ======================================================================

765
collects/mrspidey/Sba/atlunit.ss
Unescape Escape View File

@ -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)

343
collects/mrspidey/Sba/atype.ss
Unescape Escape View File

@ -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)]))
;; ----------------------------------------------------------------------

716
collects/mrspidey/Sba/checks.ss
Unescape Escape View File

@ -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))
;; ----------------------------------------------------------------------

312
collects/mrspidey/Sba/config.ss
Unescape Escape View File

@ -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)
)

155
collects/mrspidey/Sba/contain.ss
Unescape Escape View File

@ -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))

129
collects/mrspidey/Sba/contained.ss
Unescape Escape View File

@ -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))

37
collects/mrspidey/Sba/debug.ss
Unescape Escape View File

@ -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)

1081
collects/mrspidey/Sba/devel.ss
View File

File diff suppressed because it is too large Load Diff

93
collects/mrspidey/Sba/driver.ss
Unescape Escape View File

@ -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")

105
collects/mrspidey/Sba/exn-hierarchy.ss
Unescape Escape View File

@ -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) ())

105
collects/mrspidey/Sba/expander-boot.ss
Unescape Escape View File

@ -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")

322
collects/mrspidey/Sba/gram.ss
Unescape Escape View File

@ -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))))

147
collects/mrspidey/Sba/hash.ss
Unescape Escape View File

@ -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)))))))))
;;------------------------------------------------------------

601
collects/mrspidey/Sba/hyper.ss
Unescape Escape View File

@ -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))

378
collects/mrspidey/Sba/kern-aux.ss
Unescape Escape View File

@ -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*)))
;; ======================================================================

785
collects/mrspidey/Sba/kernel.ss
Unescape Escape View File

@ -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))
;; ======================================================================

1482
collects/mrspidey/Sba/language.ss
View File

File diff suppressed because it is too large Load Diff

15
collects/mrspidey/Sba/languages-abstract.ss
Unescape Escape View File

@ -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))

371
collects/mrspidey/Sba/ldexpand.ss
Unescape Escape View File

@ -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)))
;; ----------------------------------------------------------------------

69
collects/mrspidey/Sba/lib/env.ss
Unescape Escape View File

@ -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)))

247
collects/mrspidey/Sba/lib/lib-list.ss
Unescape Escape View File

@ -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))])))

150
collects/mrspidey/Sba/lib/lib-misc.ss
Unescape Escape View File

@ -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))))
;; ----------------------------------------------------------------------

71
collects/mrspidey/Sba/lib/lib-para.ss
Unescape Escape View File

@ -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)]))

111
collects/mrspidey/Sba/lib/lib-set.ss
Unescape Escape View File

@ -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))))

106
collects/mrspidey/Sba/lib/lib-vec.ss
Unescape Escape View File

@ -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!)))

29
collects/mrspidey/Sba/lib/main.ss
Unescape Escape View File

@ -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"))

132
collects/mrspidey/Sba/link.ss
Unescape Escape View File

@ -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))))

92
collects/mrspidey/Sba/load.ss
Unescape Escape View File

@ -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")

489
collects/mrspidey/Sba/loadu.ss
Unescape Escape View File

@ -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")
;; ----------------------------------------------------------------------

35
collects/mrspidey/Sba/make-exn-hierarchy.ss
Unescape Escape View File

@ -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)))))))

1555
collects/mrspidey/Sba/min-test.ss
View File

File diff suppressed because it is too large Load Diff

246
collects/mrspidey/Sba/min/hopcroft.ss
Unescape Escape View File

@ -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)

215
collects/mrspidey/Sba/min/livefewe.ss
Unescape Escape View File

@ -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))))))
;; ======================================================================

490
collects/mrspidey/Sba/min/min-dfa.ss
Unescape Escape View File

@ -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)))))))
;; ======================================================================

580
collects/mrspidey/Sba/min/min-live.ss
Unescape Escape View File

@ -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))))
;; ======================================================================

236
collects/mrspidey/Sba/min/min.ss
Unescape Escape View File

@ -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)))
;; ======================================================================

105
collects/mrspidey/Sba/min/nonempty.ss
Unescape Escape View File

@ -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)))))

46
collects/mrspidey/Sba/mod-env3.ss
Unescape Escape View File

@ -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))))))))))))))))))))

59
collects/mrspidey/Sba/nfa-dfa.ss
Unescape Escape View File

@ -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))))

489
collects/mrspidey/Sba/parser.ss
Unescape Escape View File

@ -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)))
;; ----------------------------------------------------------------------

626
collects/mrspidey/Sba/poly.ss
Unescape Escape View File

@ -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))))
;; ----------------------------------------------------------------------

127
collects/mrspidey/Sba/program.ss
Unescape Escape View File

@ -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)
))
;; ----------------------------------------------------------------------

289
collects/mrspidey/Sba/results.ss
Unescape Escape View File

@ -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))

804
collects/mrspidey/Sba/sdl.ss
Unescape Escape View File

@ -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)))
;; ----------------------------------------------------------------------

110
collects/mrspidey/Sba/seperate.ss
Unescape Escape View File

@ -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")))

685
collects/mrspidey/Sba/sigs.ss
Unescape Escape View File

@ -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^)
))
; ----------------------------------------------------------------------

303
collects/mrspidey/Sba/template.ss
Unescape Escape View File

@ -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)))))
;; ======================================================================

775
collects/mrspidey/Sba/test-sba.ss
Unescape Escape View File

@ -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"))
;; ======================================================================

187
collects/mrspidey/Sba/testall.ss
Unescape Escape View File

@ -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 ...

60
collects/mrspidey/Sba/text-interaction.ss
Unescape Escape View File

@ -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)))

212
collects/mrspidey/Sba/toplevelenv.ss
Unescape Escape View File

@ -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!)))))
;; ======================================================================

1469
collects/mrspidey/Sba/traverse.ss
View File

File diff suppressed because it is too large Load Diff

419
collects/mrspidey/Sba/type-con.ss
Unescape Escape View File

@ -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?)

116
collects/mrspidey/Sba/type-env.ss
Unescape Escape View File

@ -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))

878
collects/mrspidey/Sba/typelang.ss
Unescape Escape View File

@ -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)))
; ======================================================================

328
collects/mrspidey/Sba/za.ss
Unescape Escape View File

@ -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))))
;; ----------------------------------------------------------------------

622
collects/mrspidey/Sba/zod-aux.ss
Unescape Escape View File

@ -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))])))

75
collects/mrspidey/Sba/zod-extra.ss
Unescape Escape View File

@ -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")

22
collects/mrspidey/Sba/zod-link.ss
Unescape Escape View File

@ -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))))

36
collects/mrspidey/about.html
Unescape Escape View File

@ -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>

Some files were not shown because too many files have changed in this diff Show More

Write Preview
Loading…
Cancel
Save