diff --git a/collects/mrflow/assoc-set-exn.ss b/collects/mrflow/assoc-set-exn.ss deleted file mode 100644 index 99ded81e80..0000000000 --- a/collects/mrflow/assoc-set-exn.ss +++ /dev/null @@ -1,33 +0,0 @@ -; Exceptions for associative sets -; This file is required by both assoc-set-hash.ss and assoc-set-list.ss -; so we can't use contracts here because the assoc-sets are not always the same. - -(module assoc-set-exn mzscheme - (provide - (struct exn:assoc-set:key-not-found (assoc-set key)) - (struct exn:assoc-set:duplicate-key (assoc-set key)) - exn:assoc-set - exn:assoc-set? - raise-key-not-found-exn - raise-duplicate-key-exn - ) - - (define-struct (exn:assoc-set exn) ()) - (define-struct (exn:assoc-set:key-not-found exn:assoc-set) (assoc-set key)) - (define-struct (exn:assoc-set:duplicate-key exn:assoc-set) (assoc-set key)) - - ; string assoc-set value -> void - (define (raise-key-not-found-exn fct-name assoc-set key) - (raise (make-exn:assoc-set:key-not-found - (format "~a: key ~a not found in associative set ~a" fct-name key assoc-set) - (current-continuation-marks) - assoc-set key))) - - ; string assoc-set value -> void - (define (raise-duplicate-key-exn fct-name assoc-set key) - (raise (make-exn:assoc-set:duplicate-key - (format "~a: key ~a already in associative set ~a" fct-name key assoc-set) - (current-continuation-marks) - assoc-set key))) - - ) diff --git a/collects/mrflow/assoc-set-hash.ss b/collects/mrflow/assoc-set-hash.ss deleted file mode 100644 index 47305d0e37..0000000000 --- a/collects/mrflow/assoc-set-hash.ss +++ /dev/null @@ -1,274 +0,0 @@ -; associative sets implementation, using hash tables. -; - key equality based on eq? by default, uses equal? if given the 'equal flag -; - raises exn:assoc-set:key-not-found if key not in associative set when trying -; to remove a key or when trying to get a value and no default thunk is given. -; - raise exn:assoc-set:duplicate-key by default when trying to add a key to a -; set where it already exists -; - strange things might happen if you use assoc-set-union, assoc-set-intersection, -; or assoc-set-difference with two sets that don't use the same comparaison -; function: you might end up with duplicate keys in some sets. - -(module assoc-set-hash (lib "mrflow.ss" "mrflow") - (require - mzlib/etc ; for opt-lambda - "assoc-set-exn.ss" ; no prefix so we can re-provide - (prefix cst: "constants.ss") - ) - - ; table = (hashtableof value value) - (define-struct assoc-set (cardinality table)) - - (provide/contract - (exn:assoc-set? (any/c . -> . boolean?)) - (struct (exn:assoc-set:key-not-found exn:assoc-set) ((message (and/c string? immutable?)) - (continuation-marks continuation-mark-set?) - (assoc-set assoc-set?) - (key any/c))) - (struct (exn:assoc-set:duplicate-key exn:assoc-set) ((message (and/c string? immutable?)) - (continuation-marks continuation-mark-set?) - (assoc-set assoc-set?) - (key any/c))) - (assoc-set-make (() ((symbols 'equal)) . opt-> . assoc-set?)) - (assoc-set-reset (assoc-set? . -> . assoc-set?)) - (assoc-set? (any/c . -> . boolean?)) - (assoc-set-set ((assoc-set? any/c any/c) (boolean?) . opt-> . assoc-set?)) - (assoc-set-get ((assoc-set? any/c) ((-> any)) . opt-> . any)) - (assoc-set-in? (assoc-set? any/c . -> . boolean?)) - (assoc-set-remove ((assoc-set? any/c) (boolean?) . opt-> . assoc-set?)) - (assoc-set-cardinality (assoc-set? . -> . non-negative-exact-integer?)) - (assoc-set-empty? (assoc-set? . -> . boolean?)) - (assoc-set-copy (assoc-set? . -> . assoc-set?)) - (assoc-set-map (assoc-set? (any/c any/c . -> . any) . -> . (listof any/c))) - (assoc-set-fold (assoc-set? (any/c any/c any/c . -> . any) any/c . -> . any)) - (assoc-set-for-each (assoc-set? (any/c any/c . -> . any) . -> . assoc-set?)) - (assoc-set-for-each! (assoc-set? (any/c any/c . -> . any) . -> . assoc-set?)) - (assoc-set-filter ((assoc-set? (any/c any/c . -> . boolean?)) ((symbols 'new 'same)) . opt-> . assoc-set?)) - (assoc-set-union ((assoc-set? assoc-set? (any/c any/c . -> . any)) ((symbols 'new 'first 'second)) . opt-> . assoc-set?)) - (assoc-set-intersection ((assoc-set? assoc-set? (any/c any/c . -> . any)) ((symbols 'new 'first 'second)) . opt-> . assoc-set?)) - (assoc-set-difference ((assoc-set? assoc-set?) ((symbols 'new 'first 'second)) . opt-> . assoc-set?)) - (assoc-set-subset? (assoc-set? assoc-set? . -> . boolean?)) - ) - - ; (opt 'equal) -> assoc-set - ; we test the optional argument ourselves to preserve data abstraction even in the - ; presence of an exception - (define assoc-set-make - (case-lambda - [() (make-assoc-set 0 (make-hash-table))] - [(flag) (make-assoc-set 0 (make-hash-table 'equal))])) - - ; assoc-set -> assoc-set - (define (assoc-set-reset assoc-set) - (set-assoc-set-table! assoc-set (make-hash-table)) - (set-assoc-set-cardinality! assoc-set 0) - assoc-set) - - ; value -> boolean - ; assoc-set? comes from the structure definition - - ; assoc-set value value (opt boolean) -> assoc-set - (define assoc-set-set - (opt-lambda (assoc-set key value (exn? #t)) - (if (assoc-set-in? assoc-set key) - (if exn? - (raise-duplicate-key-exn "assoc-set-set" assoc-set key) - ; silently replace - (hash-table-put! (assoc-set-table assoc-set) key value)) - (begin - (set-assoc-set-cardinality! assoc-set (add1 (assoc-set-cardinality assoc-set))) - (hash-table-put! (assoc-set-table assoc-set) key value))) - assoc-set)) - - ; assoc-set value (-> value) -> value - (define assoc-set-get - (opt-lambda (assoc-set key (not-found-thunk (lambda () (raise-key-not-found-exn "assoc-set-get" assoc-set key)))) - (hash-table-get (assoc-set-table assoc-set) key not-found-thunk))) - - ; assoc-set value -> boolean - (define assoc-set-in? - (let ([sym (gensym)]) - (lambda (assoc-set key) - (not (eq? sym (hash-table-get (assoc-set-table assoc-set) key (lambda () sym))))))) - - ; assoc-set value (opt boolean) -> assoc-set - (define assoc-set-remove - (opt-lambda (assoc-set key (exn? #t)) - (if (assoc-set-in? assoc-set key) - (begin - (set-assoc-set-cardinality! assoc-set (sub1 (assoc-set-cardinality assoc-set))) - (hash-table-remove! (assoc-set-table assoc-set) key)) - (when exn? - (raise-key-not-found-exn "assoc-set-remove" assoc-set key))) - assoc-set)) - - ; assoc-set -> exact-non-negative-integer - ; assoc-set-cardinality comes from the structure definition - - ; assoc-set -> boolean - (define (assoc-set-empty? assoc-set) - (= 0 (assoc-set-cardinality assoc-set))) - - ; assoc-set -> assoc-set - (define (assoc-set-copy assoc-set) - (let ([new-table (make-hash-table)]) - (hash-table-for-each (assoc-set-table assoc-set) - (lambda (key value) - (hash-table-put! new-table key value))) - (make-assoc-set (assoc-set-cardinality assoc-set) - new-table))) - - ; assoc-set (value value -> value) -> (listof value) - (define (assoc-set-map assoc-set f) - (hash-table-map (assoc-set-table assoc-set) f)) - - ; assoc-set (value value value -> value) value -> value - (define (assoc-set-fold assoc-set f acc) - (let ([acc acc]) - (hash-table-for-each (assoc-set-table assoc-set) - (lambda (key value) - (set! acc (f key value acc)))) - acc)) - - ; assoc-set (value value -> value) -> assoc-set - (define (assoc-set-for-each assoc-set f) - (hash-table-for-each (assoc-set-table assoc-set) f) - assoc-set) - - ; assoc-set (value value -> value) -> assoc-set - ; we need a new table because of the "Caveat concerning concurrent access" for hash tables - ; in the help desk. - (define (assoc-set-for-each! assoc-set f) - (let ([new-table (make-hash-table)]) - (hash-table-for-each (assoc-set-table assoc-set) - (lambda (key value) - (hash-table-put! new-table key (f key value)))) - (set-assoc-set-table! assoc-set new-table)) - assoc-set) - - ; assoc-set (value value -> boolean) (opt (union 'new 'same)) -> assoc-set - (define assoc-set-filter - (let (; assoc-set (value value -> boolean) -> assoc-set - [filter-set-into-new-assoc-set - (lambda (assoc-set tester) - (let ([table (make-hash-table)] - [count 0]) - (hash-table-for-each (assoc-set-table assoc-set) - (lambda (key value) - (when (tester key value) - (hash-table-put! table key value) - (set! count (add1 count))))) - (make-assoc-set count table)))]) - (opt-lambda (assoc-set tester (which-set 'new)) - (let ([new-assoc-set (filter-set-into-new-assoc-set assoc-set tester)]) - (case which-set - [(new) new-assoc-set] - [(same) - (set-assoc-set-table! assoc-set (assoc-set-table new-assoc-set)) - (set-assoc-set-cardinality! assoc-set (assoc-set-cardinality new-assoc-set)) - assoc-set] - ;[else (argexn:raise-arg-mismatch-exn "assoc-set-filter" '(union new same) which-set)] - ))))) - - ; assoc-set assoc-set (value value -> value) (opt (union 'new 'first 'second)) -> assoc-set - (define assoc-set-union - (let (; assoc-set assoc-set (value value -> value) -> assoc-set - [union-second-set-into-first - (lambda (assoc-set1 assoc-set2 merge-values) - (let ([table (assoc-set-table assoc-set1)] - [count (assoc-set-cardinality assoc-set1)]) - (hash-table-for-each (assoc-set-table assoc-set2) - (lambda (key value) - (if (assoc-set-in? assoc-set1 key) - (hash-table-put! table key - (merge-values (hash-table-get table key cst:dummy) - value)) - (begin - (set! count (add1 count)) - (hash-table-put! table key value))))) - (set-assoc-set-cardinality! assoc-set1 count)) - assoc-set1)]) - (opt-lambda (assoc-set1 assoc-set2 merge-values (which-set 'new)) - (case which-set - [(new) - ; copying is presumably faster than testing - (if (< (assoc-set-cardinality assoc-set1) (assoc-set-cardinality assoc-set2)) - (union-second-set-into-first (assoc-set-copy assoc-set2) assoc-set1) - (union-second-set-into-first (assoc-set-copy assoc-set1) assoc-set2))] - [(first) (union-second-set-into-first assoc-set1 assoc-set2)] - [(second) (union-second-set-into-first assoc-set2 assoc-set1)] - ;[else (argexn:raise-arg-mismatch-exn "assoc-set-union" '(union new first second) which-set)] - )))) - - ; assoc-set assoc-set (value value -> value) (opt (union 'new 'first 'second)) -> assoc-set - (define assoc-set-intersection - (let (; assoc-set assoc-set (value value -> value) -> assoc-set - [intersect-into-new-assoc-set - (lambda (assoc-set1 assoc-set2 merge-values) - (let ([assoc-set2-table (assoc-set-table assoc-set2)] - [table (make-hash-table)] - [count 0]) - (hash-table-for-each (assoc-set-table assoc-set1) - (lambda (key value) - (when (assoc-set-in? assoc-set2 key) - (hash-table-put! table key - (merge-values value - (hash-table-get assoc-set2-table key cst:dummy))) - (set! count (add1 count))))) - (make-assoc-set count table)))]) - (opt-lambda (assoc-set1 assoc-set2 merge-values (which-set 'new)) - (let ([new-assoc-set - (if (< (assoc-set-cardinality assoc-set1) (assoc-set-cardinality assoc-set2)) - (intersect-into-new-assoc-set assoc-set1 assoc-set2 merge-values) - (intersect-into-new-assoc-set assoc-set2 assoc-set1 merge-values))]) - (case which-set - [(new) new-assoc-set] - [(first) - (set-assoc-set-table! assoc-set1 (assoc-set-table new-assoc-set)) - (set-assoc-set-cardinality! assoc-set1 (assoc-set-cardinality new-assoc-set)) - assoc-set1] - [(second) - (set-assoc-set-table! assoc-set2 (assoc-set-table new-assoc-set)) - (set-assoc-set-cardinality! assoc-set2 (assoc-set-cardinality new-assoc-set)) - assoc-set2] - ;[else (argexn:raise-arg-mismatch-exn "assoc-set-intersection" '(union new first second) which-set)] - ))))) - - ; assoc-set assoc-set (opt (union 'new 'first 'second)) -> assoc-set - (define assoc-set-difference - (let (; assoc-set assoc-set -> assoc-set - [difference-into-new-assoc-set - (lambda (assoc-set1 assoc-set2) - (let ([table (make-hash-table)] - [count 0]) - (hash-table-for-each (assoc-set-table assoc-set1) - (lambda (key value) - (unless (assoc-set-in? assoc-set2 key) - (hash-table-put! table key value) - (set! count (add1 count))))) - (make-assoc-set count table)))]) - (opt-lambda (assoc-set1 assoc-set2 (which-set 'new)) - (let ([new-assoc-set (difference-into-new-assoc-set assoc-set1 assoc-set2)]) - (case which-set - [(new) new-assoc-set] - [(first) - (set-assoc-set-table! assoc-set1 (assoc-set-table new-assoc-set)) - (set-assoc-set-cardinality! assoc-set1 (assoc-set-cardinality new-assoc-set)) - assoc-set1] - [(second) - (set-assoc-set-table! assoc-set2 (assoc-set-table new-assoc-set)) - (set-assoc-set-cardinality! assoc-set2 (assoc-set-cardinality new-assoc-set)) - assoc-set2] - ;[else (argexn:raise-arg-mismatch-exn "assoc-set-difference" '(union new first second) which-set)] - ))))) - - ; assoc-set assoc-set -> boolean - ; compares keys only - (define (assoc-set-subset? assoc-set1 assoc-set2) - (let/ec k - (hash-table-for-each (assoc-set-table assoc-set1) - (lambda (key value) - (unless (assoc-set-in? assoc-set2 key) - (k #f)))) - #t)) - - ) diff --git a/collects/mrflow/assoc-set-list.ss b/collects/mrflow/assoc-set-list.ss deleted file mode 100644 index 0e0efe4929..0000000000 --- a/collects/mrflow/assoc-set-list.ss +++ /dev/null @@ -1,368 +0,0 @@ -; associative sets implementation, using lists. -; - key equality based on eq? by default, uses equal? if given the 'equal flag -; - raises exn:assoc-set:key-not-found if key not in associative set when trying -; to remove a key or when trying to get a value and no default thunk is given. -; - raise exn:assoc-set:duplicate-key by default when trying to add a key to a -; set where it already exists -; - strange things might happen if you use assoc-set-union, assoc-set-intersection, -; or assoc-set-difference with two sets that don't use the same comparaison -; function: you might end up with duplicate keys in some sets. -; -; Note: lots of set! and tail-recursive loops in this code, for speed - -(module assoc-set-list (lib "mrflow.ss" "mrflow") - (require - mzlib/list ; for foldr - mzlib/etc ; for opt-lambda - "assoc-set-exn.ss" ; no prefix so we can re-provide - ) - - ; table = (listof (cons value value)) - (define-struct assoc-set (=? cardinality table)) - - (provide/contract - (exn:assoc-set? (any/c . -> . boolean?)) - (struct (exn:assoc-set:key-not-found exn:assoc-set) ((message (and/c string? immutable?)) - (continuation-marks continuation-mark-set?) - (assoc-set assoc-set?) - (key any/c))) - (struct (exn:assoc-set:duplicate-key exn:assoc-set) ((message (and/c string? immutable?)) - (continuation-marks continuation-mark-set?) - (assoc-set assoc-set?) - (key any/c))) - (assoc-set-make (() ((symbols 'equal)) . opt-> . assoc-set?)) - (assoc-set-reset (assoc-set? . -> . assoc-set?)) - (assoc-set? (any/c . -> . boolean?)) - (assoc-set-set ((assoc-set? any/c any/c) (boolean?) . opt-> . assoc-set?)) - (assoc-set-get ((assoc-set? any/c) ((-> any)) . opt-> . any)) - (assoc-set-in? (assoc-set? any/c . -> . boolean?)) - (assoc-set-remove ((assoc-set? any/c) (boolean?) . opt-> . assoc-set?)) - (assoc-set-cardinality (assoc-set? . -> . non-negative-exact-integer?)) - (assoc-set-empty? (assoc-set? . -> . boolean?)) - (assoc-set-copy (assoc-set? . -> . assoc-set?)) - (assoc-set-map (assoc-set? (any/c any/c . -> . any) . -> . (listof any/c))) - (assoc-set-fold (assoc-set? (any/c any/c any/c . -> . any) any/c . -> . any)) - (assoc-set-for-each (assoc-set? (any/c any/c . -> . any) . -> . assoc-set?)) - (assoc-set-for-each! (assoc-set? (any/c any/c . -> . any) . -> . assoc-set?)) - (assoc-set-filter ((assoc-set? (any/c any/c . -> . boolean?)) ((symbols 'new 'same)) . opt-> . assoc-set?)) - (assoc-set-union ((assoc-set? assoc-set? (any/c any/c . -> . any)) ((symbols 'new 'first 'second)) . opt-> . assoc-set?)) - (assoc-set-intersection ((assoc-set? assoc-set? (any/c any/c . -> . any)) ((symbols 'new 'first 'second)) . opt-> . assoc-set?)) - (assoc-set-difference ((assoc-set? assoc-set?) ((symbols 'new 'first 'second)) . opt-> . assoc-set?)) - (assoc-set-subset? (assoc-set? assoc-set? . -> . boolean?)) - ) - - ; (opt 'equal) -> assoc-set - ; we test the optional argument ourselves to preserve data abstraction even in the - ; presence of an exception - (define assoc-set-make - (case-lambda - [() (make-assoc-set eq? 0 '())] - [(flag) (make-assoc-set equal? 0 '())])) - - ; assoc-set -> assoc-set - ; doesn't change =? - (define (assoc-set-reset assoc-set) - (set-assoc-set-table! assoc-set '()) - (set-assoc-set-cardinality! assoc-set 0) - assoc-set) - - ; value -> boolean - ; assoc-set? comes from the structure definition - - ; assoc-set value value (opt boolean) -> assoc-set - (define assoc-set-set - (opt-lambda (assoc-set key value (exn? #t)) - (let ([=? (assoc-set-=? assoc-set)] - [original-table (assoc-set-table assoc-set)]) - (set-assoc-set-table! assoc-set (let loop ([table original-table]) - (if (null? table) - (begin - (set-assoc-set-cardinality! assoc-set (add1 (assoc-set-cardinality assoc-set))) - (cons (cons key value) original-table)) - (let ([key-value-pair (car table)]) - (if (=? (car key-value-pair) key) - (if exn? - (raise-duplicate-key-exn "assoc-set-set" assoc-set key) - (begin - ; silently replace - (set-cdr! key-value-pair value) - original-table)) - (loop (cdr table))))))) - assoc-set))) - - ; assoc-set value (-> value) -> value - (define assoc-set-get - (opt-lambda (assoc-set key (not-found-thunk (lambda () (raise-key-not-found-exn "assoc-set-get" assoc-set key)))) - (let ([=? (assoc-set-=? assoc-set)]) - (let loop ([table (assoc-set-table assoc-set)]) - (if (null? table) - (not-found-thunk) - (let ([key-value-pair (car table)]) - (if (=? (car key-value-pair) key) - (cdr key-value-pair) - (loop (cdr table))))))))) - - ; assoc-set value -> boolean - (define (assoc-set-in? assoc-set key) - (let ([=? (assoc-set-=? assoc-set)]) - (ormap (lambda (key-value-pair) - (=? (car key-value-pair) key)) - (assoc-set-table assoc-set)))) - - ; assoc-set value (opt boolean) -> assoc-set - (define assoc-set-remove - (opt-lambda (assoc-set key (exn? #t)) - (let ([=? (assoc-set-=? assoc-set)] - [original-table (assoc-set-table assoc-set)]) - (set-assoc-set-table! assoc-set - (let loop ([table original-table] - [previous #f]) - (if (null? table) - (if exn? - (raise-key-not-found-exn "assoc-set-remove" assoc-set key) - ; silently ignore - original-table) - (let ([key-value-pair (car table)]) - (if (=? (car key-value-pair) key) - (begin - (set-assoc-set-cardinality! assoc-set (sub1 (assoc-set-cardinality assoc-set))) - (if previous - (begin - ; return shortened table - (set-cdr! previous (cdr table)) - original-table) - (cdr original-table))) - (loop (cdr table) table))))))) - assoc-set)) - - ; assoc-set -> exact-non-negative-integer - ; assoc-set-cardinality comes from the structure definition - - ; assoc-set -> boolean - (define (assoc-set-empty? assoc-set) - (= 0 (assoc-set-cardinality assoc-set))) - - ; (listof (cons value value)) (listof (cons value value)) -> (listof (cons value value)) - ; creates a (reversed) copy of l1 (to prevent list sharing between sets) and prefixes l2 with it - (define (copy-reverse-and-prefix-assoc-lists l1 l2) - (let loop ([l1 l1] - [l2 l2]) - (if (null? l1) - l2 - (loop (cdr l1) (cons (cons (caar l1) (cdar l1)) l2))))) - - ; (listof (cons value value)) -> (listof (cons value value)) - (define (copy-assoc-list l) - (copy-reverse-and-prefix-assoc-lists l '())) - - ; assoc-set -> assoc-set - (define (assoc-set-copy assoc-set) - (make-assoc-set (assoc-set-=? assoc-set) - (assoc-set-cardinality assoc-set) - (copy-assoc-list (assoc-set-table assoc-set)))) - - ; assoc-set (value value -> value) -> (listof value) - (define (assoc-set-map assoc-set f) - (let ([unary-f (lambda (key-value-pair) - (f (car key-value-pair) (cdr key-value-pair)))]) - (map unary-f (assoc-set-table assoc-set)))) - - ; assoc-set (value value value -> value) value -> value - (define (assoc-set-fold assoc-set f acc) - (foldr (lambda (key-value-pair acc) - (f (car key-value-pair) (cdr key-value-pair) acc)) - acc - (assoc-set-table assoc-set))) - - ; assoc-set (value value -> value) -> assoc-set - (define (assoc-set-for-each assoc-set f) - (let ([unary-f (lambda (key-value-pair) - (f (car key-value-pair) (cdr key-value-pair)))]) - (for-each unary-f (assoc-set-table assoc-set))) - assoc-set) - - ; assoc-set (value value -> value) -> assoc-set - ; we know lists are never shared between sets, so we can set-cdr! - (define (assoc-set-for-each! assoc-set f) - (for-each (lambda (key-value-pair) - (set-cdr! key-value-pair (f (car key-value-pair) (cdr key-value-pair)))) - (assoc-set-table assoc-set)) - assoc-set) - - ; assoc-set (value value -> boolean) (opt (union 'new 'same)) -> assoc-set - (define assoc-set-filter - (let (; assoc-set (value value -> boolean) -> assoc-set - [filter-into-new-assoc-set - (lambda (assoc-set tester) - (let ([table '()] - [count 0]) - (for-each (lambda (key value) - (when (tester key value) - (set! table (cons (cons key value) table)) - (set! count (add1 count)))) - (assoc-set-table assoc-set)) - (make-assoc-set (assoc-set-=? assoc-set) count table)))]) - (opt-lambda (assoc-set tester (which-assoc-set 'new)) - (let ([new-assoc-set (filter-into-new-assoc-set assoc-set tester)]) - (case which-assoc-set - [(new) new-assoc-set] - [(same) - (set-assoc-set-table! assoc-set (assoc-set-table new-assoc-set)) - (set-assoc-set-cardinality! assoc-set (assoc-set-cardinality new-assoc-set)) - assoc-set]))))) - - ; assoc-set assoc-set (value value -> value) (opt (union 'new 'first 'second)) -> assoc-set - (define assoc-set-union - (opt-lambda (assoc-set1 assoc-set2 merge-values (which-assoc-set 'new)) - (let* ([=? (assoc-set-=? assoc-set1)] - [new-assoc-set - (let loop ([table1 (assoc-set-table assoc-set1)] - ; we shouldn't modify the original list - [table2 (copy-assoc-list (assoc-set-table assoc-set2))] - [count1 (assoc-set-cardinality assoc-set1)] - [count2 (assoc-set-cardinality assoc-set2)] - [acc '()] - [count 0]) - (if (null? table1) - ; we have already copied table2, so we can destructively modify it - (make-assoc-set =? (+ count count2) - (append! table2 acc)) - (if (null? table2) - (make-assoc-set =? (+ count count1) - (copy-reverse-and-prefix-assoc-lists table1 acc)) - (let ([key1 (caar table1)]) - ; search table2 for same key - (let loop-assoc-set2 ([t2 table2] - [previous #f]) - (if (null? t2) - (begin - (set! acc (cons (cons key1 (cdar table1)) acc)) - (set! count (add1 count)) - (set! table1 (cdr table1)) - (set! count1 (sub1 count1))) - (if (=? key1 (caar t2)) - (begin - (set! acc (cons (cons key1 (merge-values (cdar table1) (cdar t2))) acc)) - (set! count (add1 count)) - (set! table1 (cdr table1)) - (set! count1 (sub1 count1)) - (if previous - (set-cdr! previous (cdr t2)) - (set! table2 (cdr table2))) - (set! count2 (sub1 count2))) - (loop-assoc-set2 (cdr t2) t2)))) - (loop table1 table2 count1 count2 acc count)))))]) - (case which-assoc-set - [(new) new-assoc-set] - [(first) - (set-assoc-set-cardinality! assoc-set1 (assoc-set-cardinality new-assoc-set)) - (set-assoc-set-table! assoc-set1 (assoc-set-table new-assoc-set)) - assoc-set1] - [(second) - (set-assoc-set-cardinality! assoc-set2 (assoc-set-cardinality new-assoc-set)) - (set-assoc-set-table! assoc-set2 (assoc-set-table new-assoc-set)) - assoc-set2])))) - - ; assoc-set assoc-set (value value -> value) (opt (union 'new 'first 'second)) -> assoc-set - (define assoc-set-intersection - (opt-lambda (assoc-set1 assoc-set2 merge-values (which-assoc-set 'new)) - (let* ([=? (assoc-set-=? assoc-set1)] - [new-assoc-set - (let loop ([table1 (assoc-set-table assoc-set1)] - ; we shouldn't modify the original list - [table2 (copy-assoc-list (assoc-set-table assoc-set2))] - [count1 (assoc-set-cardinality assoc-set1)] - [count2 (assoc-set-cardinality assoc-set2)] - [acc '()] - [count 0]) - (if (null? table1) - (make-assoc-set =? count acc) - (if (null? table2) - (make-assoc-set =? count acc) - (let ([key1 (caar table1)]) - ; search table2 for same key - (let loop-assoc-set2 ([t2 table2] - [previous #f]) - (if (null? t2) - (begin - (set! table1 (cdr table1)) - (set! count1 (sub1 count1))) - (if (=? key1 (caar t2)) - (begin - (set! acc (cons (cons key1 (merge-values (cdar table1) (cdar t2))) acc)) - (set! count (add1 count)) - (set! table1 (cdr table1)) - (set! count1 (sub1 count1)) - (if previous - (set-cdr! previous (cdr t2)) - (set! table2 (cdr table2))) - (set! count2 (sub1 count2))) - (loop-assoc-set2 (cdr t2) t2)))) - (loop table1 table2 count1 count2 acc count)))))]) - (case which-assoc-set - [(new) new-assoc-set] - [(first) - (set-assoc-set-cardinality! assoc-set1 (assoc-set-cardinality new-assoc-set)) - (set-assoc-set-table! assoc-set1 (assoc-set-table new-assoc-set)) - assoc-set1] - [(second) - (set-assoc-set-cardinality! assoc-set2 (assoc-set-cardinality new-assoc-set)) - (set-assoc-set-table! assoc-set2 (assoc-set-table new-assoc-set)) - assoc-set2])))) - - ; assoc-set assoc-set (opt (union 'new 'first 'second)) -> assoc-set - (define assoc-set-difference - (opt-lambda (assoc-set1 assoc-set2 (which-assoc-set 'new)) - (let* ([=? (assoc-set-=? assoc-set1)] - [new-assoc-set - (let loop ([table1 (assoc-set-table assoc-set1)] - ; we shouldn't modify the original list - [table2 (copy-assoc-list (assoc-set-table assoc-set2))] - [count1 (assoc-set-cardinality assoc-set1)] - [count2 (assoc-set-cardinality assoc-set2)] - [acc '()] - [count 0]) - (if (null? table1) - (make-assoc-set =? count acc) - (if (null? table2) - (make-assoc-set =? (+ count count1) - (copy-reverse-and-prefix-assoc-lists table1 acc)) - (let ([key1 (caar table1)]) - ; search table2 for same key - (let loop-assoc-set2 ([t2 table2] - [previous #f]) - (if (null? t2) - (begin - (set! acc (cons (cons key1 (cdar table1)) acc)) - (set! count (add1 count)) - (set! table1 (cdr table1)) - (set! count1 (sub1 count1))) - (if (=? key1 (caar t2)) - (begin - (set! table1 (cdr table1)) - (set! count1 (sub1 count1)) - (if previous - (set-cdr! previous (cdr t2)) - (set! table2 (cdr table2))) - (set! count2 (sub1 count2))) - (loop-assoc-set2 (cdr t2) t2)))) - (loop table1 table2 count1 count2 acc count)))))]) - (case which-assoc-set - [(new) new-assoc-set] - [(first) - (set-assoc-set-cardinality! assoc-set1 (assoc-set-cardinality new-assoc-set)) - (set-assoc-set-table! assoc-set1 (assoc-set-table new-assoc-set)) - assoc-set1] - [(second) - (set-assoc-set-cardinality! assoc-set2 (assoc-set-cardinality new-assoc-set)) - (set-assoc-set-table! assoc-set2 (assoc-set-table new-assoc-set)) - assoc-set2])))) - - ; assoc-set assoc-set -> boolean - ; compares keys only - (define (assoc-set-subset? assoc-set1 assoc-set2) - (andmap (lambda (key value) - (assoc-set-in? assoc-set2 key)) - (assoc-set-table assoc-set1))) - - ) diff --git a/collects/mrflow/constants.ss b/collects/mrflow/constants.ss deleted file mode 100644 index fa42218b47..0000000000 --- a/collects/mrflow/constants.ss +++ /dev/null @@ -1,36 +0,0 @@ - -(module constants mzscheme - (provide - dummy - dummy-thunk - undefined - thunk-empty - thunk-false - test-true - test-false - id - (rename void-cst void) - select-right - select-left - ;car! - ;cdr! - ) - - (define dummy (void)) - (define dummy-thunk (lambda () dummy)) - (define undefined (letrec ([x x]) x)) - (define thunk-empty (lambda () '())) - (define thunk-false (lambda () #f)) - (define test-true (lambda (x) #t)) - (define test-false (lambda (x) #f)) - (define id (lambda (x) x)) - (define void-cst (void)) - (define select-right (lambda (x y) y)) - (define select-left (lambda (x y) x)) - ;(define car! (case-lambda - ; [(pair) (car pair)] - ; [(pair val) (set-car! pair val)])) - ;(define cdr! (case-lambda - ; [(pair) (cdr pair)] - ; [(pair val) (set-cdr! pair val)])) - ) diff --git a/collects/mrflow/constraints-gen-and-prop.ss b/collects/mrflow/constraints-gen-and-prop.ss deleted file mode 100644 index 0361f216e1..0000000000 --- a/collects/mrflow/constraints-gen-and-prop.ss +++ /dev/null @@ -1,5018 +0,0 @@ -; The first label is the origin label (the origin of the arrow), the second label in the one -; flowing along the arrow. The destination of the arrow is embedded in the edge. The third -; label is used for tunneling (see create-simple-edge below). -; (define-type edge (label label label -> boolean)) - -(module constraints-gen-and-prop (lib "mrflow.ss" "mrflow") - (require (prefix kern: syntax/kerncase) - (prefix list: mzlib/list) - (prefix etc: mzlib/etc) - - mzlib/match - - "labels.ss" - "types.ss" - "set-hash.ss" - "assoc-set-hash.ss" - (prefix util: "util.ss") - (prefix hc: "hashcons.ss") - (prefix cst: "constants.ss") - ;(prefix types: "types.ss") - (prefix err: "sba-errors.ss") - ) - (provide - make-sba-state - initialize-primitive-type-schemes - create-label-from-term - check-primitive-types - get-type-from-label - pp-type - - get-mzscheme-position-from-label - is-label-atom? - get-span-from-label - get-errors-from-label - get-source-from-label - get-parents-from-label - get-children-from-label - get-arrows-from-labels - ) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; MISC - - (define-struct arrows (in out tunnel) (make-inspector)) - - ; type-scheme label - (define-struct prim-data (type-scheme label)) - - (define-struct sba-state (; label -> void - register-label-with-gui - ; error-table - errors - ; (hash-tableof symbol label) - top-level-name->label - ; (hash-tableof label (cons type (hash-table-of type-flow-var (cons label type)))) - label->types - ; non-negative-exact-integer - type-var-counter - ; (hash-tableof (cons symbol type-scheme)) - primitive-types-table - ; hashcons-table - hashcons-tbl - )) - - ; label -> boolean - ; is the term associated with a label registerable (i.e. does it have - ; an actual term associated with it in the user's code)? - (define (gui-registerable? label) - (let ([term (label-term label)]) - (or (syntax-original? term) - (syntax-property term 'origin)))) - - (set! make-sba-state - (let ([real-make-sba-state make-sba-state]) - (lambda (register-label-with-gui) - (real-make-sba-state (lambda (label) - (when (gui-registerable? label) - (register-label-with-gui label))) - (err:error-table-make) - (make-hash-table) - (make-hash-table) - 0 - (make-hash-table) - (hc:make-hashcons-table))))) - - - ; length of list composed of label-cons - (define (label-list-length start-label) - (letrec ([count-length - (lambda (label count) - (if (label-cons? label) - (count-length (label-cons-cdr label) (add1 count)) - (if (and (label-cst? label) - (null? (label-cst-value label))) - count - ;(error 'label-list-length - ; "not a label list: ~a ~a ~a" - ; (syntax-object->datum - ; (label-term start-label)) - ; (pp-type sba-state (get-type-from-label sba-state start-label) 'label-list-length) - ; label))))]) - ; the assumption is that we'll never call this function - ; for something not a list. So if what we have doesn't - ; look like a list, then it's an infinite list. - +inf.0)))]) - (count-length start-label 0))) - - ; transform a label-based list into a cons-based list - ; sba-state (label-listof top) -> (listof top) - (define (label-list->list sba-state start-label) - (letrec ([ll->l - (lambda (label) - (cond - [(label-cons? label) (cons (label-cons-car label) (ll->l (label-cons-cdr label)))] - [(and (label-cst? label) (null? (label-cst-value label))) '()] - [else (error 'label-list->list - "not a label list: ~a" - (pp-type sba-state (get-type-from-label sba-state start-label) 'label-list->list))]))]) - (ll->l start-label))) - - ; like ormap, except that it continues processing the list even after the first non-#f - ; is encountered - (define ormap-strict - (letrec ([ormap-strict-1-acc - (lambda (f l acc) - (if (null? l) - acc - (if (f (car l)) - (ormap-strict-1-acc f (cdr l) #t) - (ormap-strict-1-acc f (cdr l) acc))))]) - (lambda (f l) - (if (null? l) - #t - (ormap-strict-1-acc f (cdr l) (f (car l))))))) - - (define ormap2-strict - (letrec ([ormap-strict-1-acc - (lambda (f l1 l2 acc) - (if (null? l1) - acc - (if (f (car l1) (car l2)) - (ormap-strict-1-acc f (cdr l1) (cdr l2) #t) - (ormap-strict-1-acc f (cdr l1) (cdr l2) acc))))]) - (lambda (f l1 l2) - (if (null? l1) - #t - (ormap-strict-1-acc f (cdr l1) (cdr l2) (f (car l1) (car l2))))))) - - ; like ormap, except that it continues processing the list even after the first non-#f - ; is encountered - ; l1 is a label-cons based list, l1 and l2 have the same length - (define label-ormap-strict - (letrec ([ormap-strict-2-acc - (lambda (f l1 l2 acc) - (if (null? l2) - acc - (if (f (label-cons-car l1) (car l2)) - (ormap-strict-2-acc f (label-cons-cdr l1) (cdr l2) #t) - (ormap-strict-2-acc f (label-cons-cdr l1) (cdr l2) acc))))]) - (lambda (f l1 l2) - (if (null? l2) - #t - (ormap-strict-2-acc f (label-cons-cdr l1) (cdr l2) (f (label-cons-car l1) (car l2))))))) - - ; (listof top) (listof top) -> (listof top) - ; This is O(n^2) but we expect the lists to be small, otherwise use a hash table... It's only - ; used in the GUI part anyway. - ; Note that neither l1 nor l2 contains duplicates, because of the test in create-simple-edge - (define (merge-lists l1 l2) - (cond - [(null? l1) l2] - [else (let ([elt-l1 (car l1)]) - (if (memq elt-l1 l2) - (merge-lists (cdr l1) l2) - (cons elt-l1 (merge-lists (cdr l1) l2))))])) - - ; pretty-print code (represented as sexp) - (define (unexpand t) - (if (pair? t) - (let ([kw (car t)]) - (if (list? t) - (cond - [(eq? kw '#%app) (map unexpand (cdr t))] - [else (map unexpand t)]) - (cond - [(eq? kw '#%datum) (cdr t)] - [(eq? kw '#%top) (cdr t)] - [else t]))) - t)) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; LOCAL ENVIRONMENT - - ; (listof (cons symbol label)) (listof syntax-objects) (listof label) - ; -> (listof (cons symbol label)) - ; the syntax objects in args are all atomic syntax objects for argument names - ; the labels in args-labels are all simple labels (not pseudo-labels) - (define (extend-env env args args-labels) - ; doesn't matter whether we foldl or foldr - (list:foldl - (lambda (arg arg-label env) - (cons (cons (syntax-e arg) arg-label) - env)) - env args args-labels)) - - ; syntax-object (listof (cons symbol label)) -> (or/c label #f) - (define (lookup-env var env) - (let ([name-label-pair (assq (syntax-e var) env)]) - (if name-label-pair - (cdr name-label-pair) - #f))) - - ; (listof (cons symbol label)) symbol label -> boolean - (define (search-and-replace env arg label) - (if (null? env) - #f - (if (eq? arg (caar env)) - (begin - (set-cdr! (car env) label) - #t) - (search-and-replace (cdr env) arg label)))) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; TOP LEVEL ENVIRONMENT - - ; sba-state syntax-object label -> void - (define (add-top-level-name sba-state term label) - (hash-table-put! (sba-state-top-level-name->label sba-state) (syntax-object->datum term) label)) - - ; sba-state symbol -> (or/c label #f) - ; finds the label for a top level var. - (define (lookup-top-level-name sba-state name) - (hash-table-get (sba-state-top-level-name->label sba-state) name cst:thunk-false)) - - ; sba-state (listof label) term -> boolean - ; Note that we make sure that all free variables are bound before - ; creating the edges, and we check all free variables even if we - ; already know some of them are unbound. - ; Note also that a free variable can not be captured by a lexical - ; binding, it has to be a top level binding. - (define (lookup-and-bind-top-level-vars sba-state free-vars-labels-in term) - (for-each - (lambda (free-var-label-in) - ; we do the top level lookup first, so we allow primitives to be redefined - (let* ([free-var-name-in (syntax-e (label-term free-var-label-in))] - [free-var-edge (extend-edge-for-values sba-state (create-simple-edge free-var-label-in))] - [binding-label-in - (let ([top-label (lookup-top-level-name sba-state free-var-name-in)]) - (if top-label - top-label - (let ([primitive-data (lookup-primitive-data sba-state free-var-name-in)]) - (if primitive-data - ; no polyvariance for primitives here... - ; but we need to make sure set! works for primitives by having - ; a flow from a label simulating the primitive's definition - (let* ([result-label (reconstruct-graph-from-type-scheme - sba-state - (prim-data-type-scheme primitive-data) (make-hash-table) - free-var-label-in)] - [prim-def-label (prim-data-label primitive-data)] - [result-edge (create-simple-edge result-label)]) - (add-edge-and-propagate-set-through-edge prim-def-label result-edge) - result-label) - (cond - [(eq? free-var-name-in 'make-struct-type) - (create-make-struct-type-label sba-state term)] - ; we will process these two after the one above, for a given struct - ; definition, because, after program expansion, - ; make-struct-field-accessor/mutator appear in the body of a letrec-values - ; with make-struct-type being used in one of the letrec-values clauses. - [(eq? free-var-name-in 'make-struct-field-accessor) - (create-make-struct-field-accessor-label sba-state term)] - [(eq? free-var-name-in 'make-struct-field-mutator) - (create-make-struct-field-mutator-label sba-state term)] - [(eq? free-var-name-in 'set-car!) - (create-2args-mutator sba-state - label-cons? - cst:test-true - label-cons-car - cst:id - "pair" - "internal error 1: all types must be a subtype of top" - term)] - [(eq? free-var-name-in 'set-cdr!) - (create-2args-mutator sba-state - label-cons? - cst:test-true - label-cons-cdr - cst:id - "pair" - "internal error 2: all types must be a subtype of top" - term)] - ; we just inject the string type into the first arg - [(eq? free-var-name-in 'string-set!) - (create-3args-mutator sba-state - (lambda (inflowing-label) - (subtype-type sba-state - (get-type-from-label sba-state inflowing-label) - (make-type-cst 'string) - 'lookup-and-bind-top-level-vars1 - #f #f)) - (lambda (inflowing-label) - (subtype-type sba-state - (get-type-from-label sba-state inflowing-label) - (make-type-cst 'exact-integer) - 'lookup-and-bind-top-level-vars2 - #f #f)) - (lambda (inflowing-label) - (subtype-type sba-state - (get-type-from-label sba-state inflowing-label) - (make-type-cst 'char) - 'lookup-and-bind-top-level-vars3 - #f #f)) - cst:id - (lambda (inflowing-label) - (let ([label (make-label-cst - #f #f #f #f #f - (label-term inflowing-label) - (make-hash-table) - (make-hash-table) - 'string)]) - (initialize-label-set-for-value-source label) - label)) - "string" - "exact-integer" - "char" - term)] - [(eq? free-var-name-in 'string-fill!) - (create-2args-mutator sba-state - (lambda (inflowing-label) - (subtype-type sba-state - (get-type-from-label sba-state inflowing-label) - (make-type-cst 'string) - 'lookup-and-bind-top-level-vars4 - #f #f)) - (lambda (inflowing-label) - (subtype-type sba-state - (get-type-from-label sba-state inflowing-label) - (make-type-cst 'char) - 'lookup-and-bind-top-level-vars5 - #f #f)) - cst:id - (lambda (inflowing-label) - (let ([label (make-label-cst - #f #f #f #f #f - (label-term inflowing-label) - (make-hash-table) - (make-hash-table) - 'string)]) - (initialize-label-set-for-value-source label) - label)) - "string" - "char" - term)] - ; inject third arg into first - [(eq? free-var-name-in 'vector-set!) - (create-3args-mutator sba-state - (lambda (inflowing-label) - (subtype-type sba-state - (get-type-from-label sba-state inflowing-label) - (make-type-vector (make-type-cst 'top)) - 'lookup-and-bind-top-level-vars6 - #f #f)) - (lambda (inflowing-label) - (subtype-type sba-state - (get-type-from-label sba-state inflowing-label) - (make-type-cst 'exact-integer) - 'lookup-and-bind-top-level-vars7 - #f #f)) - cst:test-true - label-vector-element - cst:id - "vector" - "exact-integer" - "internal error 3: all types must be a subtype of top" - term)] - [(eq? free-var-name-in 'vector-fill!) - (create-2args-mutator sba-state - (lambda (inflowing-label) - (subtype-type sba-state - (get-type-from-label sba-state inflowing-label) - (make-type-vector (make-type-cst 'top)) - 'lookup-and-bind-top-level-vars8 - #f #f)) - cst:test-true - label-vector-element - cst:id - "vector" - "internal error 4: all types must be a subtype of top" - term)] - [else - (begin - (set-error-for-label sba-state - free-var-label-in - 'red - ;(format "reference to undefined identifier: ~a in function ~a" - ; free-var-name-in - ; (unexpand (syntax-object->datum term)))) - (format "reference to undefined identifier: ~a" - (syntax-object->datum (label-term free-var-label-in)))) - #f)])))))]) - (when binding-label-in - (add-edge-and-propagate-set-through-edge - binding-label-in - (extend-edge-for-values sba-state (create-simple-edge free-var-label-in)))))) - free-vars-labels-in) - ; we act as if all the lookups always work, so we propagate as much as possible - ; and find as many errors as possible. - #t) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; PROPAGATION - - ; label boolean -> edge - ; creates simple edge function that just propagates labels into in-label's set - ; and propagates down the flow, taking cycles into account. - ; note that the out-label is not a parameter of create-simple-edge, but a parameter of - ; the resulting edge. This is both because it makes for nicer edges and edge creation code - ; (since the edges are origin independant), and for historical reasons (because we used to - ; create fake top level variables for lambdas and the edges that were added to these fake - ; labels were moved to the label for the actual lambda when the enclosing lambda was applied - ; - having to move edges meant they had to be origin independant). This also means that we - ; can nicely re-use the same edge over and over when dealing with multiple values (see - ; extend-edge-for-values below). - (define (create-simple-edge in-label) - (let ([in-set (label-set in-label)]) - (cons - (if (label-prim? in-label) - (lambda (out-label inflowing-label tunnel-label) - ; entering tunnel => initialize tunnel entrance - (unless tunnel-label - ;(when (or (label-cons? inflowing-label) - ; (and (label-cst? inflowing-label) - ; (number? (label-cst-value inflowing-label)) - ; (or (= 1 (label-cst-value inflowing-label)) - ; (= 2 (label-cst-value inflowing-label))))) - ; (printf "starting tunnel for ~a: ~a~n" inflowing-label out-label);) - (set! tunnel-label out-label)) - ; Note: we assume that primitives don't have internal cycles, so we - ; don't have to keep track of in/out edges. We still have to put the - ; inflowing-label in the set, because otherwise nothing is going to be - ; propagated when we add a new edge to the in-label. - (let ([arrows (hash-table-get in-set inflowing-label cst:thunk-false)]) - (if arrows - (if (memq tunnel-label (arrows-tunnel arrows)) - ; we have seen this inflowing-label before, and we already know about - ; this tunnel entrance => do nothing. - #t - ; we have seen this inflowing label before, but not from the same tunnel - ; entrance, so add the new entrance and propagate further down, so other - ; labels down the flow will know about the new tunnel entrance too... - (begin - (set-arrows-tunnel! arrows (cons tunnel-label (arrows-tunnel arrows))) - (ormap-strict (lambda (edge) - (edge in-label inflowing-label tunnel-label)) - (hash-table-map (label-edges in-label) - cst:select-right)))) - ; first time we see this inflowing-label - (begin - (hash-table-put! in-set inflowing-label (make-arrows '() '() (list tunnel-label))) - (ormap-strict (lambda (edge) - (edge in-label inflowing-label tunnel-label)) - (hash-table-map (label-edges in-label) - cst:select-right)))))) - ;(when (or (label-cons? inflowing-label) - ; (and (label-cst? inflowing-label) - ; (number? (label-cst-value inflowing-label)) - ; (or (= 1 (label-cst-value inflowing-label)) - ; (= 1 (label-cst-value inflowing-label))))) - ;(printf "propagate ~a from ~a to ~a (type ~a)~n" - ; (pp-type sba-state (get-type-from-label sba-state inflowing-label) 'create-simpled-edge1) - ; (syntax-object->datum (label-term out-label)) - ; (syntax-object->datum (label-term in-label)) - ; (label-type-var in-label)) - ; ) - ;(ormap-strict (lambda (edge) - ; (edge in-label inflowing-label tunnel-label)) - ; (hash-table-map (label-edges in-label) - ; cst:select-right))) - (lambda (out-label inflowing-label tunnel-label) - (when tunnel-label - ; coming out of tunnel, so set the out-label to the entrance of tunnel, - ; and reset tunneling. - ;(when (or (label-cons? inflowing-label) - ; (and (label-cst? inflowing-label) - ; (number? (label-cst-value inflowing-label)) - ; (or (= 1 (label-cst-value inflowing-label)) - ; (= 2 (label-cst-value inflowing-label))))) - ; (printf "resetting tunnel for ~a: ~a~n" inflowing-label out-label);) - (set! out-label tunnel-label)) - (let* ([out-set (label-set out-label)] - [arrows-in-set - (hash-table-get in-set inflowing-label cst:thunk-false)] - [arrows-out-set - (hash-table-get out-set inflowing-label cst:thunk-false)]) - (if arrows-in-set - ; the value has already flown before into this set, which means it has - ; already been propagated further down. So we just need to update the - ; in/out edges. Note that a side effect of this is that we never loop - ; indefinitely inside a cycle, which is mandatory if we generate things - ; like (listof number) as a recursive type. - (begin - (hash-table-put! in-set inflowing-label - (make-arrows (cons out-label (arrows-in arrows-in-set)) - (arrows-out arrows-in-set) - (list #f))) - (hash-table-put! out-set inflowing-label - (make-arrows (arrows-in arrows-out-set) - (cons in-label (arrows-out arrows-out-set)) - (list #f))) - #t) - ; first time this inflowing label is propagated to in-label, so update the - ; in/out edges and propagate further down. - (begin - (hash-table-put! in-set inflowing-label - (make-arrows (list out-label) - '() - (list #f))) - (hash-table-put! out-set inflowing-label - (make-arrows (arrows-in arrows-out-set) - (cons in-label (arrows-out arrows-out-set)) - (list #f))) - ;(when (or (label-cons? inflowing-label) - ; (and (label-cst? inflowing-label) - ; (number? (label-cst-value inflowing-label)) - ; (or (= 1 (label-cst-value inflowing-label)) - ; (= 2 (label-cst-value inflowing-label))))) - ; (printf "propagate ~a from ~a to ~a (type ~a)~n" - ; (pp-type sba-state (get-type-from-label sba-state inflowing-label) 'create-simple-edge2) - ; (syntax-object->datum (label-term out-label)) - ; (syntax-object->datum (label-term in-label)) - ; (label-type-var in-label)) - ; ) - (ormap-strict (lambda (edge) - (edge in-label inflowing-label #f)) - (hash-table-map (label-edges in-label) - cst:select-right))))))) - in-label))) - - ; label edge -> void - ; creates an edge from out-label to in-label and start the propagation for all the labels - ; in out-label's set. - ; Note: an edge is a function that updates the set of the in-label (and propagates further down - ; the flow), so there's no need to have the in-label appear here explicitely as an argument. - ; Note: if a function refers to a top level variable, and the function is applied twice and - ; the top level variable refers both times to the same binding, we dont' want to end up with - ; two parallel edges, so we have to test that. - (define (add-edge-and-propagate-set-through-edge out-label new-edge) - (let ([existing-edges-table (label-edges out-label)] - [edge-func (car new-edge)] - [in-label (cdr new-edge)]) - (unless (hash-table-get existing-edges-table in-label cst:thunk-false) - (hash-table-put! existing-edges-table in-label edge-func) - ; note: no need to return a boolean, because we never check this result in union- - (hash-table-for-each (label-set out-label) - (lambda (label arrows) - (for-each (lambda (tunnel-label) - (edge-func out-label label tunnel-label)) - (arrows-tunnel arrows))))))) - - ; sba-state edge label -> edge - ; We must be able to take care of all the following different cases: - ; (define-values (x) a) - ; (define-values (x) (values a)) - ; (define-values (x) (values (values a))) - ; (define-values (x) (values (values (values a)))) - ; ... - ; with all the call to "values" being possibly inside functions... - ; So we define extend-edge-for-values that recursively unpacks nested "values" by adding new - ; unpacking edges on the fly when a label-values flows into a label that has an unpacking edge. - ; The unpacking edge is created as a wrapper around a simple label-to-label edge simple-edge that - ; we use for direct propagation of non-values labels. - ; This is used in processing all values related forms (define-values, let-values, etc...) - ; Note that for values, we only ever wrap the in-edges, not the out-edges (i.e. the edges - ; that point towards a subexpression, not towards a context). - (define (extend-edge-for-values sba-state simple-edge) - (cons - (lambda (out-label inflowing-label tunnel-label) - (if (label-values? inflowing-label) - ; we have something like (values a) flowing in. Now what flows into a is a list - ; that contains the labels for the multiples values, so we have to extract that. - (let ([label-list (hash-table-map (label-set (label-values-label inflowing-label)) - (lambda (label arrows) - label))]) - (if (= (length label-list) 1) - (let ([values-label (car label-list)]) - ; we do not expect an infinite list here, and even if we receive one it's - ; okay to flag an error and not propagate (even if originally the list - ; was of length one and we lost that information through, say, using apply) - ; because we try to prevent values from flowing in, not flowing out - ; (unlike what happens when we check for the number of values in the case - ; define-values, let-values, or letrec-values). - (if (= (label-list-length values-label) 1) - ; we have something like (define-values (x) (... (values a) ...)), so we add a - ; new direct edge from a to x. Of course this new edge has to be itself a recursive - ; unpacking edge, since some (values b) could later flow into a. Note that, since - ; our edges are independant of their origin, we can re-use the same simple edge. - ; Watch then the nice infinitely-looking recursion. We are just creating a - ; potentialy infinite number of unpacking edges, lazily. Also, since our edges - ; are closures already containing the target label (the one for x), - ; extend-edge-for-values doesn't need the target label as an explicit parameter. - ; Only the origin label (the one corresponding to some use of "values") ever - ; changes. This is just plain beautiful. - (let ([new-origin-label (label-cons-car values-label)]) - (add-edge-and-propagate-set-through-edge - new-origin-label - (extend-edge-for-values sba-state simple-edge))) - ; (define-values (x) (... (values a b ...) ...)) - (begin - (set-error-for-label sba-state - inflowing-label - 'red - (format "context expected 1 value, received ~a values" - (label-list-length values-label))) - #f))) - ; values contains more than one thing. This is either an internal error, - ; or we have somehow ended up with an infinite list. Since we trust ourselves, - ; we decide that it's an infinite list, and since we can't determine the - ; original length of the list we have to signal an error. - ; Question: do we still propagate or not? After all, the length of the original - ; list might have been 1, in which case it would be correct to propagate. On - ; the other hand most of the cases here can be expected to be error cases - ; (things like (apply values (list 1)) are not very common...) so propagating - ; would just trigger many more errors... We flag an error anyway so we should - ; be fine. - (set-error-for-label sba-state - inflowing-label - 'red - (format "context expected 1 value, can't determine how many received")) - ;(error 'extend-edge-for-values "values didn't contain list: ~a" - ; (pp-type sba-state (get-type-from-label sba-state inflowing-label) 'extend-edge-for-values) - ; ;(map (lambda (label) - ; ; (list (pp-type sba-state (get-type-from-label sba-state label) 'extend-edge-for-values) - ; ; (syntax-position (label-term label)) - ; ; (syntax-object->datum (label-term label)))) - ; ; label-list) - ; ) - )) - ; (define-values (x) a) or equivalent (e.g. the result of analysing something like - ; (define-values (x) (values (values (values a)))), after three levels of recursion). - ((car simple-edge) out-label inflowing-label tunnel-label))) - (cdr simple-edge))) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; DERIVATION - - ; sba-state syntax-object -> label - ; create simple, basic label. Used directly during graph reconstruction for primitives, since - ; only the outer label will be associated with the term position, not all the internal labels. - (define (create-simple-label sba-state term) - (let ([label (make-label #f #f #f #f #f term (make-hash-table) (make-hash-table))]) - ((sba-state-register-label-with-gui sba-state) label) - label)) - - (define (create-dummy-label term) - (make-label #f #f #f #f #f term (make-hash-table) (make-hash-table))) - - ; create-simple-label is seldom used in the graph reconstruction from primitive type part - ; of the code but used a lot in the graph derivation code, so rather than add a second - ; argument to create-simple-label everywhere, it's easier to have this little specialized - ; function for primitives... - ; Note that such a label has prim? set to #t and that the associated term will, in practice, - ; be the term into which the primitive label will initially flow. - (define (create-simple-prim-label term) - (make-label #f #f #f #f #t term (make-hash-table) (make-hash-table))) - - ; label -> void - ; put a label in it's own set, for terms that are value sources - (define (initialize-label-set-for-value-source label) - (hash-table-put! (label-set label) label (make-arrows '() '() (list #f)))) - - ; sba-state (listof booleans) (listof integer) (listof (listof label)) (listof label) label boolean -> edge - ; The four first parameters simulate the surrounding case-lambda specification. We could - ; wrap it inside a real case-lambda label, but we would have to create fake values for the - ; other components of the structure... - ; Note: we always create the args edges from left to right. We *need* this when we do - ; the black magic for structures (see the create-make-struct-type-label function) - (define (create-case-lambda-edge sba-state - rest-arg?s-around req-args-around - argss-labelss-around exps-labels-around - label contra-union?) - (cons - (lambda (out-label inflowing-case-lambda-label tunnel-label) - ; inflowing-case-lambda-label doesn't go anywhere, it's components are just connected to - ; the rest of the graph (around), so out-label (which will be the op-label from which - ; the case-lambda label is flowing out) is not used. I.e. op-label (out-label) - ; is a sink for functions. - (if (label-case-lambda? inflowing-case-lambda-label) - (let ([top-around-thunk - (let loop-clauses-around - (; one thunk wrapped around this one for each around clause that's been - ; matched. If there's a matchinf error, it will be #f, and the test below - ; will be false, stopping the loop-clauses-around loop. - [around-thunk cst:dummy-thunk] - [rest-arg?s-around rest-arg?s-around] - [req-args-around req-args-around] - [argss-labelss-around argss-labelss-around] - [exps-labels-around exps-labels-around]) - (if (null? rest-arg?s-around) - around-thunk - (let ([top-in-thunk - ; search match for current around clause, returning a thunk that - ; creates all the right edges, or #f. - (let loop-clauses-in - ([rest-arg?s-in (label-case-lambda-rest-arg?s inflowing-case-lambda-label)] - [req-args-in (label-case-lambda-req-args inflowing-case-lambda-label)] - [argss-labelss-in (label-case-lambda-argss inflowing-case-lambda-label)] - [exps-labels-in (label-case-lambda-exps inflowing-case-lambda-label)] - [effects-in (label-case-lambda-effects inflowing-case-lambda-label)]) - (if (null? rest-arg?s-in) - ; No match found. - (begin - (set-error-for-label - sba-state - label - 'red - (format "procedure application: arity mismatch, given: ~a; ~a required arguments were given" - (if (label-prim? inflowing-case-lambda-label) - ; this won't work if we use a primitive - ; in a higer-order way, but they can - ; always trace the case-lambda back, - ; so that should be good enough. - (unexpand (syntax-object->datum (label-term label))) - (unexpand - (syntax-object->datum - (label-term inflowing-case-lambda-label)))) - (car req-args-around))) - #f) - (let ([rest-arg?-in (car rest-arg?s-in)] - [req-arg-in (car req-args-in)] - [rest-arg?-around (car rest-arg?s-around)] - [req-arg-around (car req-args-around)]) - ; case 2 is similiar to case 5 and case 3 similar to case 4, - ; except that both case 4 and 5 don't go till they reach null. - (cond - [(and (or (and (not rest-arg?-in) (not rest-arg?-around)) - (and rest-arg?-in rest-arg?-around)) - (= req-arg-in req-arg-around)) - ; exact one-to-one match between in and around, with or without - ; rest args, it's the same - (lambda () - ;(when (lookup-and-bind-top-level-vars - ; (car effects-in) (label-term term)) - ; make internal apps flow and top level vars looked up - ((car effects-in)) - ;(set-car! app-thunks-in *dummy-thunk*) - (let args-loop-in - ([args-labels-in (car argss-labelss-in)] - [args-labels-around (car argss-labelss-around)]) - (unless (null? args-labels-in) - (add-edge-and-propagate-set-through-edge - (car args-labels-around) - (extend-edge-for-values - sba-state - (create-simple-edge (car args-labels-in)))) - (args-loop-in (cdr args-labels-in) - (cdr args-labels-around)))) - ; edge from body of clause to app term itself - ; note that we do not detect multiple values here - (add-edge-and-propagate-set-through-edge - (car exps-labels-in) - (create-simple-edge (car exps-labels-around))))] - [(and rest-arg?-in (not rest-arg?-around) - (<= req-arg-in req-arg-around)) - ; fixed number of args around and the in function can - ; take them all. So we just have to create a label list for - ; the rest argument. - (lambda () - ;(when (lookup-and-bind-top-level-vars - ; (car effects-in) (label-term term)) - ; make internal apps flow - ((car effects-in)) - ;(set-car! app-thunks-in *dummy-thunk*) - (let args-loop-in - ([args-labels-in (car argss-labelss-in)] - [args-labels-around (car argss-labelss-around)]) - ; we know we have a rest arg, so the list is not null - (if (null? (cdr args-labels-in)) - ; create list for rest arg - (let* ([rest-arg-label (car args-labels-in)] - [rest-arg-term (label-term rest-arg-label)] - [args-labels-around-in-labellist - (let rest-loop-around ([args-labels-around - args-labels-around]) - (if (null? args-labels-around) - (let ([null-label - (make-label-cst - #f #f #f #f #t - rest-arg-term - (make-hash-table) - (make-hash-table) - '())]) - (initialize-label-set-for-value-source - null-label) - ;(register-label-with-gui - ; null-label) - null-label) - (let ([cons-label - (make-label-cons - #f #f #f #f #t - rest-arg-term - (make-hash-table) - (make-hash-table) - (car args-labels-around) - (rest-loop-around - (cdr args-labels-around)))]) - (initialize-label-set-for-value-source - cons-label) - ;(register-label-with-gui - ; cons-label) - cons-label)))]) - ; we know args-label-around-inlabellist is not - ; a multiple value... - (add-edge-and-propagate-set-through-edge - args-labels-around-in-labellist - (create-simple-edge rest-arg-label))) - ; normal args - (begin - (add-edge-and-propagate-set-through-edge - (car args-labels-around) - (extend-edge-for-values - sba-state - (create-simple-edge (car args-labels-in)))) - (args-loop-in (cdr args-labels-in) - (cdr args-labels-around))))) - ; edge from body of clause to app term itself - ; note that we do not detect multiple values here - (add-edge-and-propagate-set-through-edge - (car exps-labels-in) - (create-simple-edge (car exps-labels-around))))] - [(and (not rest-arg?-in) rest-arg?-around - (>= req-arg-in req-arg-around)) - ; in fct takes a fixed number of args and there's some of - ; them around in the rest argument => distribute what - ; is in the rest arg around by creating cons-distributing - ; labels/edges. The problem is that we don't want to add - ; any edges between in and around as long as we aren't sure - ; we have the right number of arguments flowing into the - ; rest argument. So we use a separate inner thunk to delay - ; the creation of the edges for the regular arguments - ; until we know the right number of args is actually flowing - ; into the rest arg... - (let ([inner-thunk - ; edge from body of clause to app term itself - ; note that we do not detect multiple values here - (lambda () - (add-edge-and-propagate-set-through-edge - (car exps-labels-in) - (create-simple-edge (car exps-labels-around))))]) - (let args-loop-around - ([args-labels-in (car argss-labelss-in)] - [args-labels-around (car argss-labelss-around)]) - ; we know we have a rest arg, so the list is not null - (if (null? (cdr args-labels-around)) - ; distribute list for rest arg, if we can - ; note: we can create all the edges here in the let - ; directly, because nothing will flow into them - ; unless we add the arg-number-checking-edge to - ; rest-arg-label, i.e. not until the lambda in the - ; body of this let is applied (which will itself - ; only happen when the top level loop terminates). - (let* ([rest-arg-label (car args-labels-around)] - [rest-arg-term (label-term rest-arg-label)] - [splitting-rest-arg-label - (let rest-loop-in - ([args-labels-in args-labels-in]) - (if (null? args-labels-in) - (let ([null-label - (make-label-cst - #f #f #f #f #t - rest-arg-term - (make-hash-table) - (make-hash-table) - '())]) - ; note that there's no need to type - ; check here, because the only thing - ; that ever flows in is '(), since we - ; already checked the length below. - ; (except in the case of an infinite - ; list flowing in, in which case we don't - ; want to type check anything anyway). - ;(associate-label-with-type - ; null-checking-label - ; (make-type-cst '())) - null-label) - (let* ([car-label (car args-labels-in)] - [car-edge (create-simple-edge car-label)] - [cdr-label (rest-loop-in (cdr args-labels-in))] - [cdr-edge (create-simple-edge cdr-label)] - [cons-label (create-simple-prim-label (label-term label))] - [cons-edge - (cons - (lambda (out-label inflowing-label tunnel-label) - ; cons sink => no use for - ; out-label here. - ; Note: we still have to test - ; that we actually have a - ; label-cons, in case the - ; inflowing list is infinite, - ; because then '() will flow in - ; too. - (when (label-cons? inflowing-label) - (and - (add-edge-and-propagate-set-through-edge - (label-cons-car inflowing-label) - car-edge) - (add-edge-and-propagate-set-through-edge - (label-cons-cdr inflowing-label) - cdr-edge)))) - ; cons sink - (gensym))]) - ;(associate-label-with-type cons-label - ; (make-type-cons - ; (make-type-cst 'top) - ; (make-type-cst 'top))) - (add-edge-and-propagate-set-through-edge - cons-label cons-edge) - cons-label)))] - [splitting-rest-arg-edge - (create-simple-edge splitting-rest-arg-label)] - [arg-number-checking-edge - (let ([inner-thunk inner-thunk]) - (cons - (lambda (out-label inflowing-label tunnel-label) - (let ([rest-list-length (label-list-length inflowing-label)]) - (if (or (= rest-list-length +inf.0) ; infinite list - (= (+ rest-list-length req-arg-around) - req-arg-in)) - (begin - ;(when (lookup-and-bind-top-level-vars - ; (car effects-in) (label-term term)) - ; make internal apps flow - ((car effects-in)) - ;(set-car! app-thunks-in *dummy-thunk*) - (add-edge-and-propagate-set-through-edge - inflowing-label - splitting-rest-arg-edge) - (inner-thunk)) - (begin - (set-error-for-label - sba-state - inflowing-case-lambda-label - 'red - (format "possible arity error (might be a side effect of generating an infinite list): function ~a expected ~a arguments, received ~a" - ; this would underline the primitive that generated the list - ;(syntax-object->datum - ; (label-term - ; inflowing-label)) - (syntax-object->datum - (label-term - inflowing-case-lambda-label)) - req-arg-in - (+ rest-list-length req-arg-around) - )) - #f)))) - ; sink - (gensym)))]) - (lambda () - ; that's the only thing the top level loop will - ; have to do for this clause if all the clauses are - ; matched. Everything else will be done when args - ; flow into the rest arg. - (add-edge-and-propagate-set-through-edge - rest-arg-label - arg-number-checking-edge))) - ; normal args - (begin - (set! inner-thunk - (let ([inner-thunk inner-thunk]) - (lambda () - (add-edge-and-propagate-set-through-edge - (car args-labels-around) - (extend-edge-for-values - sba-state - (create-simple-edge (car args-labels-in)))) - (inner-thunk)))) - (args-loop-around (cdr args-labels-in) - (cdr args-labels-around))))))] - [(and rest-arg?-in rest-arg?-around - (> req-arg-in req-arg-around)) - ; same problem here as in the previous case... - (let ([inner-thunk - ; edge from body of clause to app term itself - ; note that we do not detect multiple values here - (lambda () - (add-edge-and-propagate-set-through-edge - (car exps-labels-in) - (create-simple-edge (car exps-labels-around))))]) - (let args-loop-around - ([args-labels-in (car argss-labelss-in)] - [args-labels-around (car argss-labelss-around)]) - ; we know we have a rest arg, so the list is not null - (if (null? (cdr args-labels-around)) - ; distribute list for rest arg, if we can - ; note: we can create all the edges here in the let - ; directly, because nothing will flow into them - ; unless we add the arg-number-checking-edge to - ; rest-arg-label, i.e. not until the lambda in the - ; body of this let is applied (which will itself - ; only happen when the top level loop terminates). - (let* ([rest-arg-label (car args-labels-around)] - [rest-arg-term (label-term rest-arg-label)] - [splitting-rest-arg-label - (let rest-loop-in - ([args-labels-in args-labels-in]) - (if (null? (cdr args-labels-in)) - ; all the remaining values in the list of rest-arg-around - ; flow into rest-arg-in - (car args-labels-in) - (let* ([car-label (car args-labels-in)] - [car-edge (create-simple-edge car-label)] - [cdr-label (rest-loop-in (cdr args-labels-in))] - [cdr-edge (create-simple-edge cdr-label)] - [cons-label (create-simple-prim-label (label-term label))] - [cons-edge - (cons - (lambda (out-label inflowing-label tunnel-label) - ; cons sink => no use for - ; out-label here. - ; Note: we still have to test - ; that we actually have a - ; label-cons, in case the - ; inflowing list is infinite. - ; because then '() will flow in - ; too. - (when (label-cons? inflowing-label) - (and - (add-edge-and-propagate-set-through-edge - (label-cons-car inflowing-label) - car-edge) - (add-edge-and-propagate-set-through-edge - (label-cons-cdr inflowing-label) - cdr-edge)))) - ; cons sink - (gensym))]) - ;(associate-label-with-type cons-label - ; (make-type-cons - ; (make-type-cst 'top) - ; (make-type-cst 'top))) - (add-edge-and-propagate-set-through-edge - cons-label cons-edge) - cons-label)))] - [splitting-rest-arg-edge - (create-simple-edge splitting-rest-arg-label)] - [arg-number-checking-edge - (let ([inner-thunk inner-thunk]) - (cons - (lambda (out-label inflowing-label tunnel-label) - (let ([rest-list-length (label-list-length inflowing-label)]) - (if (or (= rest-list-length +inf.0) ; infinite list - (= (+ rest-list-length req-arg-around) - req-arg-in)) - (begin - ;(when (lookup-and-bind-top-level-vars - ; (car effects-in) (label-term term)) - ; make internal apps flow - ((car effects-in)) - ;(set-car! app-thunks-in *dummy-thunk*) - (add-edge-and-propagate-set-through-edge - inflowing-label - splitting-rest-arg-edge) - (inner-thunk)) - (begin - (set-error-for-label - sba-state - inflowing-case-lambda-label - 'red - (format "possible arity error (might be a side effect of generating an infinite list): function ~a expected ~a arguments, received ~a" - ; this would underline the primitive that generated the list - ;(syntax-object->datum - ; (label-term - ; inflowing-label)) - (syntax-object->datum - (label-term - inflowing-case-lambda-label)) - req-arg-in - (+ rest-list-length req-arg-around) - )) - #f)))) - ; sink - (gensym)))]) - (lambda () - ; that's the only thing the top level loop will - ; have to do for this clause if all the clauses are - ; matched. Everything else will be done when args - ; flow into the rest arg. - (add-edge-and-propagate-set-through-edge - rest-arg-label - arg-number-checking-edge))) - ; normal args - (begin - (set! inner-thunk - (let ([inner-thunk inner-thunk]) - (lambda () - (add-edge-and-propagate-set-through-edge - (car args-labels-around) - (extend-edge-for-values - sba-state - (create-simple-edge (car args-labels-in)))) - (inner-thunk)))) - (args-loop-around (cdr args-labels-in) - (cdr args-labels-around))))))] - [(and rest-arg?-in rest-arg?-around - (< req-arg-in req-arg-around)) - (lambda () - ;(when (lookup-and-bind-top-level-vars - ; (car effects-in) (label-term term)) - ; make internal apps flow - ((car effects-in)) - ;(set-car! app-thunks-in *dummy-thunk*) - (let args-loop-in - ([args-labels-in (car argss-labelss-in)] - [args-labels-around (car argss-labelss-around)]) - ; we know we have a rest arg, so the list is not null - (if (null? (cdr args-labels-in)) - ; create list for rest arg - (let* ([rest-arg-label (car args-labels-in)] - [rest-arg-term (label-term rest-arg-label)] - [args-labels-around-in-labellist - (let rest-loop-around ([args-labels-around - args-labels-around]) - (if (null? (cdr args-labels-around)) - ; everything in rest-arg-around will flow - ; into rest-arg-in, plus some other stuff - ; around the list. - (car args-labels-around) - (let ([cons-label - (make-label-cons - #f #f #f #f #t - rest-arg-term - (make-hash-table) - (make-hash-table) - (car args-labels-around) - (rest-loop-around - (cdr args-labels-around)))]) - (initialize-label-set-for-value-source - cons-label) - ;(register-label-with-gui - ; cons-label) - cons-label)))]) - ; we know args-label-around-inlabellist is not - ; a multiple value... - (add-edge-and-propagate-set-through-edge - args-labels-around-in-labellist - (create-simple-edge rest-arg-label))) - ; normal args - (begin - (add-edge-and-propagate-set-through-edge - (car args-labels-around) - (extend-edge-for-values - sba-state - (create-simple-edge (car args-labels-in)))) - (args-loop-in (cdr args-labels-in) - (cdr args-labels-around))))) - ; edge from body of clause to app term itself - ; note that we do not detect multiple values here - (add-edge-and-propagate-set-through-edge - (car exps-labels-in) - (create-simple-edge (car exps-labels-around))))] - [else ; keep looking for a matching clause - (loop-clauses-in - (cdr rest-arg?s-in) (cdr req-args-in) - (cdr argss-labelss-in) (cdr exps-labels-in) - (cdr effects-in))]))))]) - (if top-in-thunk - (loop-clauses-around (lambda () - ; connect the current around clause - (top-in-thunk) - ; and all the other ones before it - (around-thunk)) - (cdr rest-arg?s-around) - (cdr req-args-around) - (cdr argss-labelss-around) - (cdr exps-labels-around)) - #f))))]) - (when top-around-thunk - (top-around-thunk))) - ; trying to apply something not a function - ; Note: nothing was done, so there's nothing to undo - (begin - (set-error-for-label sba-state - label - 'red - (format "procedure application: expected procedure, given: ~a" - (unexpand (syntax-object->datum - (label-term inflowing-case-lambda-label))))) - #f))) - ; function value sink => unique, fake destination - (gensym))) - - - ; (label -> boolean) label label edge -> edge - ; The returned edge simulates an "if" based on the result of pred. - ; our edges are origin-independant, so we can use the same one for both true and false. - (define (create-self-modifying-edge pred true-label false-label join-edge) - (letrec ([edge-fake-destination (gensym)] - [dummy-edge (cons - (lambda (out-label inflowing-label tunnel-label) - ; sink edge, so no need for out-label - #t) - ; test value sink - edge-fake-destination)] - [self-modifying-edge - (cons - (lambda (out-label inflowing-label tunnel-label) - ; sink edge, so no need for out-label - (if (pred inflowing-label) - (begin - (set! self-modifying-edge - (cons - (lambda (out-label inflowing-label tunnel-label) - ; sink edge, so no need for out-label - (when (not (pred inflowing-label)) - ; it would be more efficient to directly remove the edge. - (set! self-modifying-edge dummy-edge) - (add-edge-and-propagate-set-through-edge - false-label join-edge))) - ; test value sink - edge-fake-destination)) - (add-edge-and-propagate-set-through-edge - true-label join-edge)) - (begin - (set! self-modifying-edge - (cons - (lambda (out-label inflowing-label tunnel-label) - ; sink edge, so no need for out-label - (when (pred inflowing-label) - ; it would be more efficient to directly remove the edge. - (set! self-modifying-edge dummy-edge) - (add-edge-and-propagate-set-through-edge - true-label join-edge))) - ; test value sink - edge-fake-destination)) - (add-edge-and-propagate-set-through-edge - false-label join-edge)))) - ; test value sink - edge-fake-destination)]) - self-modifying-edge)) - - ; label label-struct-type -> boolean - ; is a struct value a subtype of a struct type ? - (define (is-subtype? label struct-type-label) - (and (label-struct-value? label) - (let loop ([type (label-struct-value-type label)]) - (if type - (if (eq? type struct-type-label) - #t - (loop (label-struct-type-parent type))) - ; no more parent - #f)))) - - ; sba-state syntax-object -> label - ; create a label in which a case-lambda label flows, which, when applied, creates - ; struct function labels of the right type. - ; Note that we will return a case-lambda label that does strange things when something - ; flows into it, in the sense that it will gather its different arguments using - ; struct-label, and then create new case-lambda labels on the fly. - ; Note also that we know that no multiple values can flow into the case-lambda label - ; for make-struct-type, or any other for that matter, so we don't have to worry about that. - ; (define-struct (bar foo) (d e f)) expands into - ; (begin - ; (define-values - ; (struct:bar make-bar bar? bar-d set-bar-d! bar-e set-bar-e! bar-f set-bar-f!) - ; (let-values - ; (((type maker pred access mutate) - ; (#%app make-struct-type - ; 'bar - ; (#%top . struct:foo) - ; (#%datum . 3) - ; (#%datum . 0) - ; (#%datum . #f) - ; null - ; (#%datum . #f)))) - ; (#%app values - ; type - ; maker - ; pred - ; (#%app make-struct-field-accessor access (#%datum . 0) 'd) - ; (#%app make-struct-field-mutator mutate (#%datum . 0) 'd) - ; (#%app make-struct-field-accessor access (#%datum . 1) 'e) - ; (#%app make-struct-field-mutator mutate (#%datum . 1) 'e) - ; (#%app make-struct-field-accessor access (#%datum . 2) 'f) - ; (#%app make-struct-field-mutator mutate (#%datum . 2) 'f)))) - ; (define-syntaxes ...)) - ; which explains most of the names below... - ; We only explicitely deal here with the - ; (#%app make-struct-type - ; 'bar - ; (#%top . struct:foo) - ; (#%datum . 3) - ; (#%datum . 0) - ; (#%datum . #f) - ; null - ; (#%datum . #f)))) - ; part, and let the rest of the anlysis deal with values, let-values, variable bindings, etc... - (define (create-make-struct-type-label sba-state term) - (let* (; We really use this label as a type shared between the different instances - ; of the structure. It's also what we use to differentiate between two kinds of - ; structures with the same name. The only reason it's a label instead of a type - ; is because mzscheme treats it as a first class value and have it bound - ; to struct:blablabla, so it needs to be a label to be able to flow... - [struct-type-label (make-label-struct-type - #f #f #f #f #t - term - (make-hash-table) - (make-hash-table) - 'uninitialized ; struct has no name (yet) - #f ; no parent by default - 0 ; parent has no fields by default - 0 ; struct has no fields by default - #f)] - [maker-label (create-simple-prim-label term)] - [maker-edge (create-simple-edge maker-label)] - [pred-label (create-simple-prim-label term)] - [pred-edge (create-simple-edge pred-label)] - [access-label (create-simple-prim-label term)] - [access-edge (create-simple-edge access-label)] - [mutate-label (create-simple-prim-label term)] - [mutate-edge (create-simple-edge mutate-label)] - [null-label (make-label-cst #f #f #f #f #t term (make-hash-table) (make-hash-table) '())] - [cons-label1 (make-label-cons #f #f #f #f #t term (make-hash-table) (make-hash-table) - mutate-label null-label)] - [cons-label2 (make-label-cons #f #f #f #f #t term (make-hash-table) (make-hash-table) - access-label cons-label1)] - [cons-label3 (make-label-cons #f #f #f #f #t term (make-hash-table) (make-hash-table) - pred-label cons-label2)] - [cons-label4 (make-label-cons #f #f #f #f #t term (make-hash-table) (make-hash-table) - maker-label cons-label3)] - [cons-label5 (make-label-cons #f #f #f #f #t term (make-hash-table) (make-hash-table) - struct-type-label cons-label4)] - [values-label (make-label-values #f #f #f #f #t term (make-hash-table) (make-hash-table) - cons-label5)] - [name-label (create-simple-prim-label term)] - [name-edge - (cons - (lambda (out-label inflowing-label tunnel-label) - ; name sink => no use for out-label - ; only symbol should flow in here - (if (and (label-cst? inflowing-label) - (symbol? (label-cst-value inflowing-label))) - (begin - (set-label-struct-type-name! struct-type-label - (label-cst-value inflowing-label)) - #t) - (begin - (set-error-for-label sba-state - inflowing-label - 'red - "make-struct-type expected symbol") - (set-label-struct-type-error?! struct-type-label #t) - #f))) - (gensym))] - [parent-label (create-simple-prim-label term)] - [parent-edge - (cons - (lambda (out-label inflowing-label tunnel-label) - ; name sink => no use for out-label - ; if anything flows in here, it should be the struct label for the - ; parent struct, or #f - (if (or (label-struct-type? inflowing-label) - (and (label-cst? inflowing-label) - (not (label-cst-value inflowing-label)))) - (begin - (when (label-struct-type? inflowing-label) - (set-label-struct-type-parent! struct-type-label - inflowing-label)) - #t) - (begin - (set-error-for-label sba-state - inflowing-label - 'red - "make-struct-type expected structure type") - (set-label-struct-type-error?! struct-type-label #t) - #f))) - (gensym))] - [field-label (create-simple-prim-label term)] - [field-edge - (cons - (lambda (out-label inflowing-label tunnel-label) - ; name sink => no use for out-label - ; inflowing label will tell use how many fields the struct will have - (if (and (label-cst? inflowing-label) - (number? (label-cst-value inflowing-label))) - (begin - (let* ([parent (label-struct-type-parent struct-type-label)] - [parent-fields-nbr (if parent - (label-struct-type-total-fields-nbr - (label-struct-type-parent struct-type-label)) - 0)]) - (set-label-struct-type-parent-fields-nbr! struct-type-label parent-fields-nbr) - (set-label-struct-type-total-fields-nbr! struct-type-label - (+ (label-cst-value inflowing-label) - parent-fields-nbr))) - #t) - (begin - (set-error-for-label sba-state - inflowing-label - 'red - "make-struct-type expected number") - (set-label-struct-type-error?! struct-type-label #t) - #f))) - (gensym))] - [auto-field-label (create-simple-prim-label term)] - [auto-field-edge - (cons - (lambda (out-label inflowing-label tunnel-label) - ; name sink => no use for out-label - ; only 0 should flow in here - (if (and (label-cst? inflowing-label) - (let ([value (label-cst-value inflowing-label)]) - (and (number? value) (zero? value)))) - #t - (begin - (set-error-for-label sba-state - inflowing-label - 'red - "auto-initialized structure fields not yet supported: expected 0") - (set-label-struct-type-error?! struct-type-label #t) - #f))) - (gensym))] - [auto-field-value-label (create-simple-prim-label term)] - [auto-field-value-edge - (cons - (lambda (out-label inflowing-label tunnel-label) - ; name sink => no use for out-label - ; only #f should flow in here - (if (and (label-cst? inflowing-label) - (not (label-cst-value inflowing-label))) - #t - (begin - (set-error-for-label sba-state - inflowing-label - 'red - "auto-initialized structure fields not yet supported: expected #f") - (set-label-struct-type-error?! struct-type-label #t) - #f))) - (gensym))] - [properties-label (create-simple-prim-label term)] - [properties-edge - (cons - (lambda (out-label inflowing-label tunnel-label) - ; name sink => no use for out-label - ; only '() should flow in here - (if (and (label-cst? inflowing-label) - (null? (label-cst-value inflowing-label))) - #t - (begin - (set-error-for-label sba-state - inflowing-label - 'red - "structure properties not yet supported: expected ()") - (set-label-struct-type-error?! struct-type-label #t) - #f))) - (gensym))] - [inspector-label (create-simple-prim-label term)] - [inspector-edge - (cons - (lambda (out-label inflowing-label tunnel-label) - ; name sink => no use for out-label - ; only #f should flow in here - (if (and (label-cst? inflowing-label) - (not (label-cst-value inflowing-label))) - ; now, at this point, and since edges from actual to formal arguments - ; are created left to right when a function is applied, we know struct-label - ; has been complitely filled out. So we can do the black magic part, which - ; consists in creating case-lambdas on the fly, that will become the maker, - ; pred, access and mutate functions, and gather them in the multiple value - ; label. - (if (label-struct-type-error? struct-type-label) - ; nothing created, so nothing ever propagates down to - ; make-struct-field-accessor or make-struct-field-mutator - #f - (let* ([total-fields-nbr (label-struct-type-total-fields-nbr struct-type-label)] - ; maker - [maker-body-label (make-label-struct-value - #f #f #f #f #t - term - (make-hash-table) - (make-hash-table) - struct-type-label - (etc:build-list total-fields-nbr - (lambda (_) - (create-simple-prim-label term))))] - [maker-case-lambda-label (make-label-case-lambda - #f #f #f #f #t - term - (make-hash-table) - (make-hash-table) - struct-type-label ; never used - (list #f) - (list total-fields-nbr) - (list (label-struct-value-fields - maker-body-label)) - (list maker-body-label) - (list cst:dummy-thunk))] - ; pred - [pred-true-label (make-label-cst #f #f #f #f #t - term - (make-hash-table) - (make-hash-table) - #t)] - [pred-false-label (make-label-cst #f #f #f #f #t - term - (make-hash-table) - (make-hash-table) - #f)] - [pred-body-label (create-simple-prim-label term)] - [pred-body-edge (create-simple-edge pred-body-label)] - [pred-arg-label (create-simple-prim-label term)] - [pred-arg-edge - (create-self-modifying-edge (lambda (label) - (is-subtype? label struct-type-label)) - pred-true-label pred-false-label - pred-body-edge)] - [pred-case-lambda-label (make-label-case-lambda - #f #f #f #f #t - term - (make-hash-table) - (make-hash-table) - struct-type-label ; never used - (list #f) - (list 1) - (list (list pred-arg-label)) - (list pred-body-label) - (list cst:dummy-thunk))] - ; access is a bit tricky: make-struct-field-accessor will - ; manually link access's second arg and wrap access inside another - ; case-lambda with one arg less. We just have to remember which - ; structure type access is about by setting the struct field to - ; struct-type-label (something we didn't really have to do for the - ; maker and pred, because the maker-body-label and pred-arg-edge - ; already explicitely refer to it, but we did it anyway, above, - ; just for consistency). - ; Note: no error checking on the input is done here. It will be done - ; by the wrapper. - [access-first-arg-label (create-simple-prim-label term)] - [access-second-arg-label (create-simple-prim-label term)] - [access-case-lambda-label (make-label-case-lambda - #f #f #f #f #t - term - (make-hash-table) - (make-hash-table) - struct-type-label - (list #f) - (list 2) - (list (list access-first-arg-label - access-second-arg-label)) - (list (create-simple-prim-label term)) - (list cst:dummy-thunk))] - ; same problem with mutate - [mutate-first-arg-label (create-simple-prim-label term)] - [mutate-second-arg-label (create-simple-prim-label term)] - [mutate-third-arg-label (create-simple-prim-label term)] - [mutate-case-lambda-label (make-label-case-lambda - #f #f #f #f #t - term - (make-hash-table) - (make-hash-table) - struct-type-label - (list #f) - (list 2) - (list (list mutate-first-arg-label - mutate-second-arg-label - mutate-third-arg-label)) - (list (create-simple-prim-label term)) - (list cst:dummy-thunk))]) - ; XXX should all the add-edge-and-propagate-set-through-edge be and-ed ? - ; maker - (initialize-label-set-for-value-source maker-body-label) - (initialize-label-set-for-value-source maker-case-lambda-label) - (add-edge-and-propagate-set-through-edge - maker-case-lambda-label maker-edge) - ; pred - (initialize-label-set-for-value-source pred-true-label) - (initialize-label-set-for-value-source pred-false-label) - (add-edge-and-propagate-set-through-edge - pred-arg-label pred-arg-edge) - (initialize-label-set-for-value-source pred-case-lambda-label) - (add-edge-and-propagate-set-through-edge - pred-case-lambda-label pred-edge) - ; access - (initialize-label-set-for-value-source access-case-lambda-label) - (add-edge-and-propagate-set-through-edge - access-case-lambda-label access-edge) - ; mutate - (initialize-label-set-for-value-source mutate-case-lambda-label) - (add-edge-and-propagate-set-through-edge - mutate-case-lambda-label mutate-edge) - #t)) - (begin - (set-error-for-label sba-state - inflowing-label - 'red - "structure inspectors not yet supported: expected #f") - (set-label-struct-type-error?! struct-type-label #t) - #f))) - (gensym))] - [make-struct-type-label (make-label-case-lambda - #f #f #f #f #t term (make-hash-table) (make-hash-table) #f - (list #f) - (list 7) - (list (list name-label - parent-label - field-label - auto-field-label - auto-field-value-label - properties-label - inspector-label)) - (list values-label) - (list cst:dummy-thunk))]) - ; make-struct-type args - (add-edge-and-propagate-set-through-edge name-label name-edge) - (add-edge-and-propagate-set-through-edge parent-label parent-edge) - (add-edge-and-propagate-set-through-edge field-label field-edge) - (add-edge-and-propagate-set-through-edge auto-field-label auto-field-edge) - (add-edge-and-propagate-set-through-edge auto-field-value-label auto-field-value-edge) - (add-edge-and-propagate-set-through-edge properties-label properties-edge) - (add-edge-and-propagate-set-through-edge inspector-label inspector-edge) - (initialize-label-set-for-value-source struct-type-label) - ; multiple values list - (initialize-label-set-for-value-source null-label) - (initialize-label-set-for-value-source cons-label1) - (initialize-label-set-for-value-source cons-label2) - (initialize-label-set-for-value-source cons-label3) - (initialize-label-set-for-value-source cons-label4) - (initialize-label-set-for-value-source cons-label5) - (initialize-label-set-for-value-source values-label) - (initialize-label-set-for-value-source make-struct-type-label) - make-struct-type-label)) - - ; sba-state syntax-object -> label - ; Here again we rely heavily on the order in which actual arguments are connected - ; to formal arguments (i.e. left to right). Note that the first arg of - ; make-struct-field-accessor will be access, which is bound to the access defined - ; by make-struct-type. This means that, if the define-struct is inside a lambda, - ; we should make sure that, when the lambda is applied, make-struct-type is applied - ; before make-struct-field-accessor. Hence the order in which the thunks are built - ; in the #%app rule of create-label-from-term. - (define (create-make-struct-field-accessor-label sba-state term) - (let* (; WARNING: we assume that each occurence of make-struct-field-accessor is - ; only used once in the program being analyzed, so set!-ing struct-label, access, - ; and field-index is ok. This *will* break if the user starts using a - ; function like: - ; (lambda (index name) - ; (make-struct-field-accessor access index name)) - ; to create the different accessors, because the state will then be shared - ; between several call places. - ; Note that we could get back the struct-label and field-index when needed - ; by fishing them out of the sets of the first and second args, but it's - ; less painful to do it that way, and doing the fishing would still break - ; the same way anyway... - [struct-type-label #f] - [access #f] - [field-index #f] - [body-label (create-simple-prim-label term)] - [body-edge (create-simple-edge body-label)] - [first-arg-label (create-simple-prim-label term)] - [first-arg-edge - (cons - (lambda (out-label inflowing-label tunnel-label) - ; name sink => no use for out-label - ; only a case-lambda for a struct with a single arity-2 clause - ; should flow in here. Note that, as in create-make-struct-type-label, - ; we do the type checking as stuff flows in, instead of doing it - ; post-analysis, just to make sure we don't screw our invariants when - ; we finally run third-arg-edge... - (if (and (label-case-lambda? inflowing-label) - (label-case-lambda-struct inflowing-label) - (= (length (label-case-lambda-rest-arg?s inflowing-label)) 1) - (= (length (car (label-case-lambda-argss inflowing-label))) 2)) - (begin - (set! struct-type-label (label-case-lambda-struct inflowing-label)) - (set! access inflowing-label) - #t) - (begin - (set-error-for-label sba-state - inflowing-label - 'red - (format "make-struct-field-accessor: expects type as 1st argument, given: ~a" - (pp-type sba-state (get-type-from-label sba-state inflowing-label) 'create-make-struct-field-accessor-label1))) - #f))) - (gensym))] - [second-arg-label (create-simple-prim-label term)] - [second-arg-edge - (cons - (lambda (out-label inflowing-label tunnel-label) - ; name sink => no use for out-label - ; only a number in the right range should flow in here - (if struct-type-label - (if (and (label-cst? inflowing-label) - (let ([value (label-cst-value inflowing-label)]) - (and (number? value) - (exact? value) - (<= 0 value)))) - (let ([value (label-cst-value inflowing-label)]) - (if (< value (- (label-struct-type-total-fields-nbr struct-type-label) - (label-struct-type-parent-fields-nbr struct-type-label))) - (begin - (set! field-index - (+ value (label-struct-type-parent-fields-nbr struct-type-label))) - #t) - (begin - (set-error-for-label - sba-state - inflowing-label - 'red - (format "make-struct-field-accessor: slot index for ~a not in [0, ~a]: ~a" - (pp-type sba-state (get-type-from-label sba-state struct-type-label) 'create-make-struct-field-accessor-label2) - (- (label-struct-type-total-fields-nbr struct-type-label) - (label-struct-type-parent-fields-nbr struct-type-label)) - (pp-type sba-state (get-type-from-label sba-state inflowing-label) 'create-make-struct-field-accessor-label3))) - #f))) - (begin - (set! struct-type-label #f) - (set! access #f) - (set-error-for-label - sba-state - inflowing-label - 'red - (format "make-struct-field-accessor: expects type as 2nd argument, given: ~a" - (pp-type sba-state (get-type-from-label sba-state inflowing-label) 'create-make-struct-field-accessor-label4))) - #f)) - #f)) - (gensym))] - [third-arg-label (create-simple-prim-label term)] - [third-arg-edge - (cons - (lambda (out-label inflowing-label tunnel-label) - ; name sink => no use for out-label - ; only a symbol should flow in here - (if field-index ; is not set if struct-label is not set... - (if (and (label-cst? inflowing-label) - (symbol? (label-cst-value inflowing-label))) - ; ready to wrap access... accessor is the result of applying - ; make-struct-field-accessor to access (i.e. it's the accessor - ; that will be bound to foo-a...) - (let* ([access-args (car (label-case-lambda-argss access))] - [access-body-edge (create-simple-edge (car (label-case-lambda-exps access)))] - [accessor-body-label (create-simple-prim-label term)] - [accessor-body-edge (create-simple-edge accessor-body-label)] - [accessor-arg-label (create-simple-prim-label term)] - [accessor-arg-edge - (cons - (lambda (out-label inflowing-label tunnel-label) - ; name sink => no use for out-label - (if (is-subtype? inflowing-label struct-type-label) - (let ([result-label - (list-ref (label-struct-value-fields - inflowing-label) - field-index)]) - ; we make the result flow into both the result of access and the result - ; of the accessor - (add-edge-and-propagate-set-through-edge - result-label access-body-edge) - (add-edge-and-propagate-set-through-edge - result-label accessor-body-edge) - #t) - (begin - (set-error-for-label - sba-state - ; we know we are inside a primitive, so we - ; flag the entrance of the tunnel as the error. - tunnel-label - 'red - (format "accessor expects type ~a as 1st argument, given: ~a" - (pp-type sba-state (get-type-from-label sba-state struct-type-label) 'create-make-struct-field-accessor-label5) - (pp-type sba-state (get-type-from-label sba-state inflowing-label) 'create-make-struct-field-accessor-label6))) - #f))) - (gensym))] - [accessor-case-lambda-label (make-label-case-lambda - #f #f #f #f #t term (make-hash-table) (make-hash-table) #f - (list #f) - (list 1) - (list (list accessor-arg-label)) - (list accessor-body-label) - (list cst:dummy-thunk))]) - ; this is just to get the type for access right... - ; the structure flowing into the accessor flows into access's first arg - (add-edge-and-propagate-set-through-edge - accessor-arg-label - (create-simple-edge (car access-args))) - ; the index given to make-struct-field-accessor flows into the second arg - (add-edge-and-propagate-set-through-edge - second-arg-label - (create-simple-edge (cadr access-args))) - ; accessor - (add-edge-and-propagate-set-through-edge accessor-arg-label accessor-arg-edge) - (initialize-label-set-for-value-source accessor-case-lambda-label) - (add-edge-and-propagate-set-through-edge - accessor-case-lambda-label body-edge) - #t) - (begin - (set! struct-type-label #f) - (set! access #f) - (set! field-index #f) - (set-error-for-label - sba-state - inflowing-label - 'red - (format "make-struct-field-accessor: expects type as 3rd argument, given: ~a" - (pp-type sba-state (get-type-from-label sba-state inflowing-label) 'create-make-struct-field-accessor-label7))) - #f)) - #f)) - (gensym))] - [make-struct-field-accessor-label (make-label-case-lambda - #f #f #f #f #t term (make-hash-table) (make-hash-table) #f - (list #f) - (list 3) - (list (list first-arg-label - second-arg-label - third-arg-label)) - (list body-label) - (list cst:dummy-thunk))]) - (add-edge-and-propagate-set-through-edge first-arg-label first-arg-edge) - (add-edge-and-propagate-set-through-edge second-arg-label second-arg-edge) - (add-edge-and-propagate-set-through-edge third-arg-label third-arg-edge) - (initialize-label-set-for-value-source make-struct-field-accessor-label) - make-struct-field-accessor-label)) - - ; sba-state syntax-object -> label - ; Here again we rely heavily on the order in which actual arguments are connected - ; to formal arguments (i.e. left to right) - (define (create-make-struct-field-mutator-label sba-state term) - (let* (; WARNING: we assume that each occurence of make-struct-field-mutator is - ; only used once in the program being analyzed, so set!-ing struct-label - ; and field-index is ok. This *will* break if the user starts using a - ; function like: - ; (lambda (index name) - ; (make-struct-field-mutator mutate index name)) - ; to create the different mutators... - ; Note that we could get back the struct-label and field-index when needed - ; by fishing them out of the sets of the first and second args, but it's - ; less painful to do it that way, and doing the fishing would still break - ; the same way anyway... - [struct-type-label #f] - [mutate #f] - [field-index #f] - [body-label (create-simple-prim-label term)] - [body-edge (create-simple-edge body-label)] - [first-arg-label (create-simple-prim-label term)] - [first-arg-edge - (cons - (lambda (out-label inflowing-label tunnel-label) - ; name sink => no use for out-label - ; only a case-lambda for a struct with a single arity-3 clause - ; should flow in here. Note that, as in create-make-struct-type-label, - ; we do the type checking as stuff flows in, instead of doing it - ; post-analysis, just to make sure we don't screw our invariants when - ; we finally run third-arg-edge... - (if (and (label-case-lambda? inflowing-label) - (label-case-lambda-struct inflowing-label) - (= (length (label-case-lambda-rest-arg?s inflowing-label)) 1) - (= (length (car (label-case-lambda-argss inflowing-label))) 3)) - (begin - (set! struct-type-label (label-case-lambda-struct inflowing-label)) - (set! mutate inflowing-label) - #t) - (begin - (set-error-for-label - sba-state - inflowing-label - 'red - (format "make-struct-field-mutator: expects type as 1st argument, given: ~a" - (pp-type sba-state (get-type-from-label sba-state inflowing-label) 'create-make-struct-field-mutator-label1))) - #f))) - (gensym))] - [second-arg-label (create-simple-prim-label term)] - [second-arg-edge - (cons - (lambda (out-label inflowing-label tunnel-label) - ; name sink => no use for out-label - ; only a number in the right range should flow in here - (if struct-type-label - (if (and (label-cst? inflowing-label) - (let ([value (label-cst-value inflowing-label)]) - (and (number? value) - (exact? value) - (<= 0 value)))) - (let ([value (label-cst-value inflowing-label)]) - (if (< value (- (label-struct-type-total-fields-nbr struct-type-label) - (label-struct-type-parent-fields-nbr struct-type-label))) - (begin - (set! field-index - (+ value (label-struct-type-parent-fields-nbr struct-type-label))) - #t) - (begin - (set-error-for-label - sba-state - inflowing-label - 'red - (format "make-struct-field-mutator: slot index for ~a not in [0, ~a]: ~a" - (pp-type sba-state (get-type-from-label sba-state (struct-type-label)) 'create-make-struct-field-mutator-label2) - (- (label-struct-type-total-fields-nbr struct-type-label) - (label-struct-type-parent-fields-nbr struct-type-label)) - (pp-type sba-state (get-type-from-label sba-state inflowing-label) 'create-make-struct-field-mutator-label3))) - #f))) - (begin - (set! struct-type-label #f) - (set! mutate #f) - (set-error-for-label - sba-state - inflowing-label - 'red - (format "make-struct-field-mutator: expects type as 2nd argument, given: ~a" - (pp-type sba-state (get-type-from-label sba-state inflowing-label) 'create-make-struct-field-mutator-label4))) - #f)) - #f)) - (gensym))] - [third-arg-label (create-simple-prim-label term)] - [third-arg-edge - (cons - (lambda (out-label inflowing-label tunnel-label) - ; name sink => no use for out-label - ; only a symbol should flow in here - (if field-index ; is not set if struct-label is not set... - (if (and (label-cst? inflowing-label) - (symbol? (label-cst-value inflowing-label))) - ; ready to wrap mutate... mutator is the result of applying - ; make-struct-field-mutator to mutate (i.e. it's the mutator - ; that will be bound to set-foo-a!...) - (let* ([mutate-args (car (label-case-lambda-argss mutate))] - [mutate-body-edge (create-simple-edge (car (label-case-lambda-exps mutate)))] - [mutator-case-lambda-label - (create-2args-mutator - sba-state - (lambda (inflowing-label) - (is-subtype? inflowing-label struct-type-label)) - cst:test-true - (lambda (inflowing-label) - (list-ref (label-struct-value-fields - inflowing-label) - field-index)) - cst:id - (pp-type sba-state (get-type-from-label sba-state struct-type-label) 'create-make-struct-field-mutator-label5) - "internal error 5: all types must be a subtype of top" - term)] - ; a mutator has only one clause - [mutator-args (car (label-case-lambda-argss mutator-case-lambda-label))]) - ; this is just to get the type for mutate right... - ; the structure flowing into the mutator's first arg flows into - ; mutate's first arg - (add-edge-and-propagate-set-through-edge - (car mutator-args) - (create-simple-edge (car mutate-args))) - ; the index given to make-struct-field-mutator flows into mutate's second arg - (add-edge-and-propagate-set-through-edge - second-arg-label - (create-simple-edge (cadr mutate-args))) - ; the value flowing into the mutator's second args flows into - ; mutate's third arg - (add-edge-and-propagate-set-through-edge - (cadr mutator-args) - (create-simple-edge (caddr mutate-args))) - ; body - (add-edge-and-propagate-set-through-edge - (car (label-case-lambda-exps mutator-case-lambda-label)) - mutate-body-edge) - ; mutator - (add-edge-and-propagate-set-through-edge - mutator-case-lambda-label body-edge) - #t) - (begin - (set! struct-type-label #f) - (set! mutate #f) - (set! field-index #f) - (set-error-for-label - sba-state - inflowing-label - 'red - (format "make-struct-field-mutator: expects type as 3rd argument, given: ~a" - (pp-type sba-state (get-type-from-label sba-state inflowing-label) 'create-make-struct-field-mutator-label7))) - #f)) - #f)) - (gensym))] - [make-struct-field-mutator-label (make-label-case-lambda - #f #f #f #f #t term (make-hash-table) (make-hash-table) #f - (list #f) - (list 3) - (list (list first-arg-label - second-arg-label - third-arg-label)) - (list body-label) - (list cst:dummy-thunk))]) - (add-edge-and-propagate-set-through-edge first-arg-label first-arg-edge) - (add-edge-and-propagate-set-through-edge second-arg-label second-arg-edge) - (add-edge-and-propagate-set-through-edge third-arg-label third-arg-edge) - (initialize-label-set-for-value-source make-struct-field-mutator-label) - make-struct-field-mutator-label)) - - ; sba-state (label -> boolean) (label -> boolean) (label -> label) (label -> label) string string - ; -> case-lambda-label - ; creates a case-lambda label for a 2 args mutator. - (define (create-2args-mutator sba-state - pred-first-arg pred-second-arg - accessor-first-arg accessor-second-arg - error-first-arg error-second-arg - term) - (let* ([void-label (make-label-cst #f #f #f #f #f - term - (make-hash-table) - (make-hash-table) - cst:void)] - [state-label (create-simple-prim-label term)] - [state-edge (create-simple-edge state-label)] - [mutator-body-label (create-simple-prim-label term)] - [mutator-body-edge (create-simple-edge mutator-body-label)] - [mutator-first-arg-label (create-simple-prim-label term)] - [mutator-second-arg-label (create-simple-prim-label term)] - [mutator-first-arg-edge - (cons - (lambda (out-label inflowing-label tunnel-label) - ; name sink => no use for out-label - (if (pred-first-arg inflowing-label) - (add-edge-and-propagate-set-through-edge - state-label - (create-simple-edge (accessor-first-arg inflowing-label))) - (begin - (set-error-for-label - sba-state - ; we know we are inside a primitive, so we - ; flag the entrance of the tunnel as the error. - tunnel-label - 'red - (format "mutator expects type ~a as 1st argument, given: ~a" - error-first-arg - (pp-type sba-state (get-type-from-label sba-state inflowing-label) 'create-2args-mutator1))) - #f))) - (gensym))] - [mutator-second-arg-edge - (cons - (lambda (out-label inflowing-label tunnel-label) - ; name sink => no use for out-label - (if (pred-second-arg inflowing-label) - (add-edge-and-propagate-set-through-edge - (accessor-second-arg inflowing-label) - state-edge) - (begin - (set-error-for-label - sba-state - ; we know we are inside a primitive, so we - ; flag the entrance of the tunnel as the error. - tunnel-label - 'red - (format "mutator expects type ~a as 2nd argument, given: ~a" - error-second-arg - (pp-type sba-state (get-type-from-label sba-state inflowing-label) 'create-2args-mutator2))) - #f))) - (gensym))] - [mutator-case-lambda-label (make-label-case-lambda - #f #f #f #f #t term (make-hash-table) (make-hash-table) #f - (list #f) - (list 2) - (list (list mutator-first-arg-label - mutator-second-arg-label)) - (list mutator-body-label) - (list cst:dummy-thunk))]) - (initialize-label-set-for-value-source void-label) - (add-edge-and-propagate-set-through-edge void-label mutator-body-edge) - (add-edge-and-propagate-set-through-edge - mutator-first-arg-label mutator-first-arg-edge) - (add-edge-and-propagate-set-through-edge - mutator-second-arg-label mutator-second-arg-edge) - (initialize-label-set-for-value-source mutator-case-lambda-label) - mutator-case-lambda-label)) - - ; sba-state (label -> boolean) (label -> boolean) (label -> label) (label -> label) string string string - ; -> case-lambda-label - ; creates a case-lambda label for a 3 args mutator. - (define (create-3args-mutator sba-state - pred-first-arg pred-second-arg pred-third-arg - accessor-first-arg accessor-third-arg - error-first-arg error-second-arg error-third-arg - term) - (let* ([void-label (make-label-cst #f #f #f #f #f - term - (make-hash-table) - (make-hash-table) - cst:void)] - [state-label (create-simple-prim-label term)] - [state-edge (create-simple-edge state-label)] - [mutator-body-label (create-simple-prim-label term)] - [mutator-body-edge (create-simple-edge mutator-body-label)] - [mutator-first-arg-label (create-simple-prim-label term)] - [mutator-second-arg-label (create-simple-prim-label term)] - [mutator-third-arg-label (create-simple-prim-label term)] - [mutator-first-arg-edge - (cons - (lambda (out-label inflowing-label tunnel-label) - ; name sink => no use for out-label - (if (pred-first-arg inflowing-label) - (add-edge-and-propagate-set-through-edge - state-label - (create-simple-edge (accessor-first-arg inflowing-label))) - (begin - (set-error-for-label - sba-state - ; we know we are inside a primitive, so we - ; flag the entrance of the tunnel as the error. - tunnel-label - 'red - (format "mutator expects type ~a as 1st argument, given: ~a" - error-first-arg - (pp-type sba-state (get-type-from-label sba-state inflowing-label) 'create-3args-mutator1))) - #f))) - (gensym))] - [mutator-second-arg-edge - (cons - (lambda (out-label inflowing-label tunnel-label) - ; name sink => no use for out-label - (if (pred-second-arg inflowing-label) - #t - (begin - (set-error-for-label - sba-state - ; we know we are inside a primitive, so we - ; flag the entrance of the tunnel as the error. - tunnel-label - 'red - (format "mutator expects type ~a as 2nd argument, given: ~a" - error-second-arg - (pp-type sba-state (get-type-from-label sba-state inflowing-label) 'create-3args-mutator2))) - #f))) - (gensym))] - [mutator-third-arg-edge - (cons - (lambda (out-label inflowing-label tunnel-label) - ; name sink => no use for out-label - (if (pred-third-arg inflowing-label) - (add-edge-and-propagate-set-through-edge - (accessor-third-arg inflowing-label) - state-edge) - (begin - (set-error-for-label - sba-state - ; we know we are inside a primitive, so we - ; flag the entrance of the tunnel as the error. - tunnel-label - 'red - (format "mutator expects type ~a as 3rd argument, given: ~a" - error-third-arg - (pp-type sba-state (get-type-from-label sba-state inflowing-label) 'create-3args-mutator3))) - #f))) - (gensym))] - [mutator-case-lambda-label (make-label-case-lambda - #f #f #f #f #t term (make-hash-table) (make-hash-table) #f - (list #f) - (list 3) - (list (list mutator-first-arg-label - mutator-second-arg-label - mutator-third-arg-label)) - (list mutator-body-label) - (list cst:dummy-thunk))]) - (initialize-label-set-for-value-source void-label) - (add-edge-and-propagate-set-through-edge void-label mutator-body-edge) - (add-edge-and-propagate-set-through-edge - mutator-first-arg-label mutator-first-arg-edge) - (add-edge-and-propagate-set-through-edge - mutator-second-arg-label mutator-second-arg-edge) - (add-edge-and-propagate-set-through-edge - mutator-third-arg-label mutator-third-arg-edge) - (initialize-label-set-for-value-source mutator-case-lambda-label) - mutator-case-lambda-label)) - - ; sba-state (listof (syntax-object-listof syntax-object)) (listof (syntax-object-listof syntax-object)) - ; syntax-object (listof (cons symbol label)) -> case-lambda-label - (define (create-case-lambda-label sba-state argss expss term gamma) - (let* ([label (make-label-case-lambda - #f #f #f #f #f - term - (make-hash-table) - (make-hash-table) - #f - cst:dummy - cst:dummy - cst:dummy - cst:dummy - '())] - [all-labels - (list:foldr - (lambda (args exps other-clauses-labels) - (let ([rest-arg?s (vector-ref other-clauses-labels 0)] - [req-args (vector-ref other-clauses-labels 1)] - [argss-labels (vector-ref other-clauses-labels 2)] - [exps-labels (vector-ref other-clauses-labels 3)] - ; scheme list of syntax objects for body exps - [exps (syntax-e exps)]) - ; we add one new element to each list each time we process a new clause, - ; so that the element for the current clause is always at the start of the - ; list, so we know where to find this element when we need it (we need to - ; update the top free vars for the current clause in the #%top case, and - ; the application thunk for the current clause in the #%app case). - (set-label-case-lambda-effects! - label - (cons cst:dummy-thunk (label-case-lambda-effects label))) - (kern:kernel-syntax-case - args #f - [(args ...) - (let* (; proper scheme list of syntax objects for arguments - [args (syntax-e (syntax (args ...)))] - [args-labels (map (lambda (term) (create-simple-label sba-state term)) args)] - [gamma-extended (extend-env gamma args args-labels)]) - (vector (cons #f rest-arg?s) - (cons (length args) req-args) - (cons args-labels argss-labels) - (cons (list:foldl - (lambda (exp _) - (create-label-from-term sba-state exp gamma-extended label)) - cst:dummy - exps) - exps-labels)))] - [(first-arg . other-args-including-rest-arg) - (let* (; (syntax other-args-including-rest-arg) is either a (syntax - ; version of a) list of syntax objects (if there's strictly more - ; than one required argument), or a single syntax object (if - ; there's only one required argument). In both cases we want to - ; construct an improper list of syntax objects. syntax-e takes - ; care of that in the list case, cons takes care of that in the - ; other case. - [args (cons (syntax first-arg) - (let* ([syntax-obj (syntax other-args-including-rest-arg)] - [symbol-or-list-of-syntax-obj (syntax-e syntax-obj)]) - (if (symbol? symbol-or-list-of-syntax-obj) - syntax-obj - symbol-or-list-of-syntax-obj)))] - ; convert the improper list into a proper one. - [args (let loop ([args args]) - (if (pair? args) - (cons (car args) - (loop (cdr args))) - (list args)))] - [args-labels (map (lambda (term) (create-simple-label sba-state term)) args)] - [gamma-extended (extend-env gamma args args-labels)]) - (vector (cons #t rest-arg?s) - (cons (sub1 (length args)) req-args) - (cons args-labels argss-labels) - (cons (list:foldl - (lambda (exp _) - (create-label-from-term sba-state exp gamma-extended label)) - cst:dummy - exps) - exps-labels)))] - [rest-arg - (let* (; one syntax object for rest-arg - [rest-arg (syntax rest-arg)] - [rest-arg-label-list (list (create-simple-label sba-state rest-arg))] - [gamma-extended (extend-env gamma (list rest-arg) rest-arg-label-list)]) - (vector (cons #t rest-arg?s) - (cons 0 req-args) - (cons rest-arg-label-list argss-labels) - (cons (list:foldl - (lambda (exp _) - (create-label-from-term sba-state exp gamma-extended label)) - cst:dummy - exps) - exps-labels)))] - ))) - (vector '()'()'()'()) - argss - expss - )]) - (set-label-case-lambda-rest-arg?s! label (vector-ref all-labels 0)) - (set-label-case-lambda-req-args! label (vector-ref all-labels 1)) - (set-label-case-lambda-argss! label (vector-ref all-labels 2)) - (set-label-case-lambda-exps! label (vector-ref all-labels 3)) - (initialize-label-set-for-value-source label) - ((sba-state-register-label-with-gui sba-state) label) - label)) - - ; sba-state syntax-object (listof (cons symbol label)) label (listof label) -> label - (define (create-top-level-label sba-state identifier gamma enclosing-lambda-label) - (let* ([identifier-name (syntax-e identifier)] - ; note that bound-label doesn't contain the #%top, but they have the same - ; syntax source/line/column/position, so arrows and underlining will work - ; the same, but it will make things a little bit simpler when doing a - ; lookup-top-level-name in the #%app case (if we have to). - [bound-label (create-simple-label sba-state identifier)]) - (if enclosing-lambda-label - ; free var inside a lambda, so add it to the list of free variables, don't do - ; any lookup now (will be done when the enclosing lambda is applied) - (let* ([enclosing-lambda-effects (label-case-lambda-effects enclosing-lambda-label)] - [current-thunk (car enclosing-lambda-effects)]) - (set-car! enclosing-lambda-effects - (lambda () - (current-thunk) - (lookup-and-bind-top-level-vars sba-state (list bound-label) identifier) - ))) - ; top level - (lookup-and-bind-top-level-vars sba-state (list bound-label) identifier)) - bound-label)) - - - ; (label -> void) syntax-object (assoc-setof location-info label) -> label - ; We must take sharing into account. We can't count on using syntax-e and eq? - ; because they don't preserve sharing (see the MzScheme manual) and using - ; syntax-object->datum and eq? might mistakenly result in too much sharing, since - ; some values like intergers, symbols, and '() are always eq?. So we have to rely - ; on source locations and so on. And the reason we must take sharing into account - ; is because otherwise things like '#0=(1 . #0#) will make this code fail to - ; terminate. Try the foolowing code in DrScheme to see why syntax-e and - ; syntax-object->datum are not what we want: - ; (define-syntax lst - ; (syntax-rules () - ; [(_ a b) #'(a a b)])) - ; (lst 1 1) - ; (define w1 #`#,(lst 1 1)) - ; w1 - ; (define w2 (syntax-e w1)) - ; w2 - ; (define w3 w2) - ; w3 - ; (eq? (car w3) (cadr w3)) - ; (eq? (car w3) (caddr w3)) - ; (define w4 (syntax-object->datum w1)) - ; w4 - ; (eq? (car w4) (cadr w4)) - ; (eq? (car w4) (caddr w4)) - ; - ; '(1 1 1) - ; (define x1 #''(1 1 1)) - ; x1 - ; (define x2 (syntax-e x1)) - ; x2 - ; (define x3 (syntax-e (cadr x2))) - ; x3 - ; (eq? (car x3) (cadr x3)) - ; (eq? (car x3) (caddr x3)) - ; (define x4 (syntax-object->datum (cadr x2))) - ; x4 - ; (eq? (car x4) (cadr x4)) - ; (eq? (car x4) (caddr x4)) - ; - ; '(#0=1 #0# 1) - ; (define y1 #''(#0=1 #0# 1)) - ; y1 - ; (define y2 (syntax-e y1)) - ; y2 - ; (define y3 (syntax-e (cadr y2))) - ; y3 - ; (eq? (car y3) (cadr y3)) - ; (eq? (car y3) (caddr y3)) - ; (define y4 (syntax-object->datum (cadr y2))) - ; y4 - ; (eq? (car y4) (cadr y4)) - ; (eq? (car y4) (caddr y4)) - ; - ; '(#0=(1) #0# (1)) - ; (define z1 #''(#0=(1) #0# (1))) - ; z1 - ; (define z2 (syntax-e z1)) - ; z2 - ; (define z3 (syntax-e (cadr z2))) - ; z3 - ; (eq? (car z3) (cadr z3)) - ; (eq? (car z3) (caddr z3)) - ; (define z4 (syntax-object->datum (cadr z2))) - ; z4 - ; (eq? (car z4) (cadr z4)) - ; (eq? (car z4) (caddr z4)) - ; - (define (create-label-from-quote register-label-with-gui term-stx assoc-set) - (let ([term-loc-info (list (syntax-source term-stx) - (syntax-position term-stx) - (syntax-span term-stx))]) - ;(printf "Q: ~a ~a ~a ~a~n" (syntax-object->datum term-stx) (syntax-e term-stx) term-stx (assoc-set-in? assoc-set term-loc-info)) - ;(printf "L: ~a~n" term-loc-info) - (if (assoc-set-in? assoc-set term-loc-info) - (assoc-set-get assoc-set term-loc-info) - (let ([sexp-e (syntax-e term-stx)]) - (cond - [(list? sexp-e) - (let loop ([sexp-e sexp-e] - [top-label? #t]) - (if (null? sexp-e) - (let ([null-label - (make-label-cst - #f #f #f #f #t - term-stx - (make-hash-table) - (make-hash-table) - sexp-e)]) - (initialize-label-set-for-value-source null-label) - (register-label-with-gui null-label) - null-label) - (let ([cons-label - (make-label-cons - #f #f #f #f (not top-label?) - term-stx - (make-hash-table) - (make-hash-table) - #f - #f)]) - ; the top-most cons-label in the list is the only one in - ; the list that might be associated with a #n name and - ; therefore the only one that might have a #n# sharing - ; reference somewhere else, so we need to remember it so - ; sharing is dealt with correctly. We need to memoize it - ; before any recursive call so that we close the loop - ; correctly. - (when top-label? - (assoc-set-set assoc-set term-loc-info cons-label) - (register-label-with-gui cons-label)) - (set-label-cons-car! - cons-label - (create-label-from-quote register-label-with-gui - (car sexp-e) assoc-set)) - (set-label-cons-cdr! - cons-label - (loop (cdr sexp-e) #f)) - (initialize-label-set-for-value-source cons-label) - cons-label)))] - [(pair? sexp-e) - (let ([cons-label - (make-label-cons - #f #f #f #f #f - term-stx - (make-hash-table) - (make-hash-table) - #f - #f)]) - (assoc-set-set assoc-set term-loc-info cons-label) - (register-label-with-gui cons-label) - (set-label-cons-car! - cons-label - (create-label-from-quote register-label-with-gui - (car sexp-e) assoc-set)) - (set-label-cons-cdr! - cons-label - (create-label-from-quote register-label-with-gui - (cdr sexp-e) assoc-set)) - (initialize-label-set-for-value-source cons-label) - cons-label)] - [else (let ([label (make-label-cst - #f #f #f #f #f - term-stx - (make-hash-table) - (make-hash-table) - sexp-e)]) - (assoc-set-set assoc-set term-loc-info label) - (initialize-label-set-for-value-source label) - (register-label-with-gui label) - label)]))))) - - ; Builds a list of labels of length n, with all labels being the same. - ; This function should be seldom called, so it's not being made tail recursive... - (define (build-label-list label n) - (if (<= n 0) - '() - (cons label (build-label-list label (sub1 n))))) - - ; given a label representing multiple values, connect the label for the different - ; values to the different variables. The tricky part is that the multiple values - ; are potentially infinite, because of approximations. E.g. - ; (let-values ([(a b) (apply values (list 1 2))]) b) - ; Because of the "apply", we can't actually determine how many multiple values - ; we receive, so we have to try our best. - ; sba-state label (listof label) integer symbol -> void - (define (connect-value-labels-to-var-labels sba-state inflowing-label vars-labels vars-length term-name) - (let ([values-labels - (let* ([value-label-list (hash-table-map (label-set (label-values-label inflowing-label)) - (lambda (label arrows) label))] - [value-label-list-length (length value-label-list)]) - (cond - [(= value-label-list-length 1) (label-list->list sba-state (car value-label-list))] - ; check for infinite list. If we have an infinite list, then it's something - ; like x = (union null (cons y x)) or x = (union (cons y x) null). In either - ; case (this case and the one below), we find y and create a list (list y y ...) - ; with the right length so y (most likely a union of all the possible multiple - ; values that flowed together when we lost track of the exact length of the - ; list of multiple values) will flow in all vars-labels (therefore being *very* - ; conservative since all possible values will flow into all possible bindings). - ; Note that we don't actually check that the list is infinite (i.e. that the - ; cons labels form a loop). We could check that the cdr of the cons is eq? to - ; (label-values-label inflowing-label) for example, but that doesn't always - ; work because of loop unfolding (we does occur in practice). So we just check - ; that we have something vaguely resembling a loop at the outermost level and - ; then we trust that the rest of the analysis and the primitive type - ; descriptions are correct enough that we never end up here with something that - ; resembles a list without being one. In fact if the analysis is correct we - ; should only ever see finite lists and infinite lists and nothing else, so - ; since the first case above takes care of finite lists we can normally - ; safely assume that in the two cases below we are dealing with infinite lists, - ; even though we have no simple way to check that. The last case is for extra - ; checking so that if something goes really wrong we might at least learn about it... - ; One good question is: should we propagate at all when we don't know whether - ; we have an error or not? - ; Note that we also assume that the car we get from the infinite list is all - ; the possible cars we'll ever get, even in the presence of other cars in the - ; infinite list that might come from loop unrolling! - [(and (= value-label-list-length 2) - (let ([first-value-label (car value-label-list)] - [second-value-label (cadr value-label-list)]) - (and (label-cst? first-value-label) - (null? (label-cst-value first-value-label)) - (label-cons? second-value-label)))) - (set-error-for-label - sba-state - inflowing-label - 'red - (format "~a: context expected ~a values, can't determine how many received" - term-name - vars-length)) - (build-label-list (label-cons-car (cadr value-label-list)) vars-length)] - [(and (= value-label-list-length 2) - (let ([first-value-label (car value-label-list)] - [second-value-label (cadr value-label-list)]) - (and (label-cst? second-value-label) - (null? (label-cst-value second-value-label)) - (label-cons? first-value-label)))) - (set-error-for-label - sba-state - inflowing-label - 'red - (format "~a: context expected ~a values, can't determine how many received" - term-name - vars-length)) - (build-label-list (label-cons-car (car value-label-list)) vars-length)] - [else (error term-name "values didn't contain list: ~a" - (pp-type sba-state (get-type-from-label sba-state inflowing-label) 'let-values) - ;(map (lambda (label) - ; (pp-type sba-state (get-type-from-label sba-state label) - ; term-name)) - ; label-list) - )]))]) - (if (= (length values-labels) vars-length) - ; we have something like - ; (let-values ([(x y) (... (values a b) ...)]...) ...), - ; so we add a new direct edge from a to x and b to y. - ; Of course these new edges have to be themselves - ; recursive unpacking edges, since some (values c) - ; could later flow into either a or b. - (ormap2-strict - (lambda (new-origin-label var-label) - (add-edge-and-propagate-set-through-edge - new-origin-label - (extend-edge-for-values - sba-state - (create-simple-edge var-label))) - #t) - values-labels vars-labels) - ; (let-values ([(x y) (... (values a b c ...) ...)] - ; ...) ...) - (begin - (set-error-for-label - sba-state - inflowing-label - 'red - (format "~a: context expected ~a values, received ~a values" - term-name - vars-length - (length values-labels))) - #f)))) - - ; sba-state syntax-object (listof (cons symbol label)) label -> label - ; gamma is the binding-variable-name-to-label environment - ; enclosing-lambda-label is the label for the enclosing lambda, if any. We - ; need it to update its list of free variables if we find any. This means - ; we have to create the label for a lambda before analyzing its body... - (define (create-label-from-term sba-state term gamma enclosing-lambda-label) - (kern:kernel-syntax-case - term #f - ; lambda and case-lambda are currently both core forms. This might change (dixit Matthew) - [(#%plain-lambda args exps ...) - (let (; scheme lists of syntax object lists of syntax objects - [argss (list (syntax args))] - [expss (list (syntax (exps ...)))]) - (create-case-lambda-label sba-state argss expss term gamma))] - [(case-lambda . ((args exps ...) ...)) - (let (; scheme lists of syntax object lists of syntax objects - [argss (syntax-e (syntax (args ...)))] - [expss (syntax-e (syntax ((exps ...) ...)))]) - (create-case-lambda-label sba-state argss expss term gamma))] - [(#%plain-app op actual-args ...) - (let* ([app-label (create-simple-label sba-state term)] - [op-term (syntax op)] - [op-label (create-label-from-term sba-state op-term gamma enclosing-lambda-label)] - [stx-actual-args (syntax (actual-args ...))] - [actual-args-labels - (map (lambda (actual-arg) - (create-label-from-term sba-state actual-arg gamma enclosing-lambda-label)) - (syntax-e stx-actual-args))] - [actual-args-length (length actual-args-labels)] - [edge (create-case-lambda-edge - sba-state - (list #f) - (list actual-args-length) - (list actual-args-labels) - (list app-label) - op-label - #f)]) - ; If the app is inside a lambda, we delay the addition of the edge until the enclosing - ; lambda is itself applied. - (if enclosing-lambda-label - (let* ([enclosing-lambda-effects (label-case-lambda-effects enclosing-lambda-label)] - ; has to be evaluated now, not inside the thunk, otherwise we might have an - ; infinite loop (if there's only one clause in the lambda) or complete - ; non-sense (if there's several clauses). - [current-thunk (car enclosing-lambda-effects)]) - (set-car! enclosing-lambda-effects - (lambda () - ; the order in which we evaluate the thunks here is normally - ; insignificant, but it is *very* important to have it in this - ; order when we start having structs. Otherwise, if a define-struct - ; is inside a lambda, the application of make-struct-type might - ; occur after the application of make-struct-field-accessor, which - ; means access won't have been created by the time - ; make-struct-field-accessor is applied, which will make the - ; assumption (that args flow into make-struct-field-accessor in order, - ; from left to right) we made in create-make-struct-field-accessor-label - ; break. - (current-thunk) - (add-edge-and-propagate-set-through-edge op-label edge) - ))) - (add-edge-and-propagate-set-through-edge op-label edge)) - app-label)] - [(quote sexp) - (create-label-from-quote (sba-state-register-label-with-gui sba-state) - (syntax sexp) (assoc-set-make 'equal))] - [(define-values vars exp) - (let* (; scheme list of syntax objects - [vars (syntax-e (syntax vars))] - [vars-length (length vars)] - [exp-label (create-label-from-term sba-state (syntax exp) gamma enclosing-lambda-label)] - [vars-labels (map (lambda (term) (create-simple-label sba-state term)) vars)] - [define-label (make-label-cst - #f #f #f #f #f - term - (make-hash-table) - (make-hash-table) - 'dummy-define-values)]) - ; don't add to top level before analysing exp-label, otherwise (define x x) will work. - (for-each (lambda (var var-label) - (add-top-level-name sba-state var var-label)) - vars vars-labels) - ; We must be able to take care of all the following different cases: - ; (define-values (x) a) - ; (define-values (x) (values a)) - ; (define-values (x) (values (values a))) - ; (define-values (x) (values (values (values a)))) - ; ... - ; (define-values (x y) (values a b)) - ; (define-values (x y) (values (values a) (values b))) - ; (define-values (x y) (values (values (values a)) (values (values b)))) - ; ... - ; with all the call to "values" being possibly inside functions... - ; So we use extend-edge-for-values that recursively unpacks nested "values" by adding - ; new unpacking edges on the fly when a label-values flows into a label that has an - ; unpacking edge. - ; Note that when define-values defines more than one variable, we must first unpack - ; the top level of "values", then start the recursion for each variable separately. - (if (= vars-length 1) - ; we have something like (define-values (x) (values (values (values a)))) so we - ; can directly start the recursion. - (let ([var-label (car vars-labels)]) - (add-edge-and-propagate-set-through-edge - exp-label - (extend-edge-for-values sba-state (create-simple-edge var-label)))) - ; we have something like (define-values (x y) (values (values (values a)) - ; (values (values b)))) so we first have to manually unpack the top-most "values", - ; then start a recursion for each of the defined variables. So in effect we end - ; up doing something equivalent to analysing - ; (define-values (x) (values (values a))) - ; (define-values (y) (values (values b))) - ; in parallel. - (let ([distributive-unpacking-edge - (cons - (lambda (out-label inflowing-label tunnel-label) - ; inflowing-label (the label corresponding to the top "values") doesn't - ; flow anywhere, it's just taken apart and its elements are connected to - ; the different variables. I.e. it's a sink for multiple values. So we - ; have no need for out-label here. - (if (label-values? inflowing-label) - (connect-value-labels-to-var-labels sba-state inflowing-label vars-labels vars-length 'define-values) - ; (define-values (x y) (... 1 ...)) - (begin - (set-error-for-label - sba-state - define-label - 'red - (format "define-values: context expected ~a values, received 1 non-multiple-values value" - vars-length)) - #f))) - ; multiple values sink => unique, fake destination - (gensym))]) - (add-edge-and-propagate-set-through-edge - exp-label - distributive-unpacking-edge))) - ;(initialize-label-set-for-value-source define-label) - ((sba-state-register-label-with-gui sba-state) define-label) - define-label)] - [(let-values ((vars exp) ...) body-exps ...) - (let* ([let-values-label (create-simple-label sba-state term)] - [gamma-extended - (list:foldl - ; syntax-obj syntax-obj -> (listof (cons symbol label)) - ; loop on each binding clause of the let-values, returning the corresponding - ; extended environment - (lambda (vars exp new-gamma) - (let* (; scheme list of syntax objects - [vars (syntax-e vars)] - [vars-length (length vars)] - [vars-labels (map (lambda (term) (create-simple-label sba-state term)) vars)] - ; analyse exp of clause in gamma, not gamma-extended... - [exp-label (create-label-from-term sba-state exp gamma enclosing-lambda-label)]) - ; We must be able to take care of all the following different cases: - ; (let-values ([(x) a] ...) ...) - ; (let-values ([(x) (values a)] ...) ...) - ; (let-values ([(x) (values (values a))] ...) ...) - ; (let-values ([(x) (values (values (values a)))] ...) ...) - ; ... - ; (let-values ([(x y) (values a b)] ...) ...) - ; (let-values ([(x y) (values (values a) (values b))] ...) ...) - ; (let-values ([(x y) (values (values (values a)) (values (values b)))] ...) ...) - ; ... - ; with all the call to "values" being possibly inside functions... - ; So we use extend-edge-for-values that recursively unpacks nested "values" by - ; adding new unpacking edges on the fly when a label-values flows into a label - ; that has an unpacking edge. - ; Note that when let-values defines more than one variable, we must first - ; unpack the top level of "values", then start the recursion for each - ; variable separately. - (if (= vars-length 1) - ; we have something like - ; (let-values ([(x) (values (values (values a)))]) ...) so we can - ; directly start the recursion. - (let ([var-label (car vars-labels)]) - (add-edge-and-propagate-set-through-edge - exp-label - (extend-edge-for-values sba-state (create-simple-edge var-label)))) - ; we have something like - ; (let-values ([(x y) (values (values (values a)) (values (values b)))] ...) ...) - ; so we first have to manually unpack the top-most "values", then start a - ; recursion for each of the defined variables. So in effect we end up - ; doing something equivalent to analysing - ; (let-values ([(x) (values (values a))] - ; (y) (values (values b))] ...) ...) - ; in parallel. - (let ([distributive-unpacking-edge - (cons - (lambda (out-label inflowing-label tunnel-label) - ; inflowing-label (the label corresponding to the top "values") - ; doesn't flow anywhere, it's just taken apart and its elements - ; are connected to the different variables. I.e. it's a sink for - ; multiple values. So we have no need for out-label here. - (if (label-values? inflowing-label) - (connect-value-labels-to-var-labels sba-state inflowing-label vars-labels vars-length 'let-values) - ; (let-values ([(x y) (... 1 ...)] ...) ...) - (begin - (set-error-for-label - sba-state - let-values-label - 'red - (format "let-values: context expected ~a values, received 1 non-multiple-values value" - vars-length)) - #f))) - ; multiple values sink - (gensym))]) - (add-edge-and-propagate-set-through-edge - exp-label - distributive-unpacking-edge))) - (extend-env new-gamma vars vars-labels))) - gamma - ; Scheme lists of syntax objects, one for each list of vars and one for each exp - (syntax-e (syntax (vars ...))) - (syntax-e (syntax (exp ...))))] - [last-body-exp-label - (list:foldl - (lambda (exp _) - (create-label-from-term sba-state exp gamma-extended enclosing-lambda-label)) - cst:dummy - (syntax-e (syntax (body-exps ...))))]) - (add-edge-and-propagate-set-through-edge - last-body-exp-label - (create-simple-edge let-values-label)) - let-values-label)] - [(letrec-values ((vars exp) ...) body-exps ...) - ; we simulate letrec by doing a let followed by a set!, except that we have to do that - ; clause after clause. - (let* ([letrec-values-label (create-simple-label sba-state term)] - [varss-stx (map syntax-e (syntax-e (syntax (vars ...))))] - [varss-labelss (map (lambda (single-clause-vars-stx) - (map (lambda (var-stx) - (let ([undefined-label (make-label-cst #f #f #f #f #f - var-stx - (make-hash-table) - (make-hash-table) - cst:undefined)] - ;[binding-label (create-simple-label sba-state var-stx)] - ) - (initialize-label-set-for-value-source undefined-label) - ;(add-edge-and-propagate-set-through-edge - ; undefined-label - ; (create-simple-edge binding-label)) - ;binding-label - undefined-label)) - single-clause-vars-stx)) - varss-stx)] - [gamma-extended (list:foldl - (lambda (vars-stx vars-labels current-gamma) - (extend-env current-gamma vars-stx vars-labels)) - gamma - varss-stx - varss-labelss)] - [_ - ; process the clauses expressions, creating new labels for the vars and set!-ing - ; gamma-extended as we go along, since the current labels for var contain the - ; undefined value. We need to do that before analyzing the body. - (let loop ([varss-stx varss-stx] - [exps (syntax-e (syntax (exp ...)))]) - (unless (null? exps) - ; process current clause - (let* ([exp-label (create-label-from-term sba-state (car exps) gamma-extended enclosing-lambda-label)] - [vars-stx (car varss-stx)] - [vars-length (length vars-stx)]) - (if (= vars-length 1) - ; we have a clause like [(x) (values (values (values a)))] so we - ; can directly start the recursion. - (let* ([var-stx (car vars-stx)] - [var-label (create-simple-label sba-state var-stx)] - [var-name (syntax-e var-stx)]) - (add-edge-and-propagate-set-through-edge - exp-label - (extend-edge-for-values sba-state (create-simple-edge var-label))) - (search-and-replace gamma-extended var-name var-label)) - ; we have a clause like [(x y) (values (values (values a)) (values (values b)))] - ; so we first have to manually unpack the top-most "values", then start a - ; recursion for each of the defined variables. So in effect we end up doing - ; something equivalent to analysing the clauses - ; [(x) (values (values a))] - ; [(y) (values (values b))] - ; in parallel. - (let ([distributive-unpacking-edge - (cons - (lambda (out-label inflowing-label tunnel-label) - ; inflowing-label (the label corresponding to the top "values") doesn't - ; flow anywhere, it's just taken apart and its elements are connected to - ; the different variables. I.e. it's a sink for multiple values. So we - ; have no need for out-label here. - (if (label-values? inflowing-label) - (let ([vars-labels (map (lambda (var-stx) (create-simple-label sba-state var-stx)) vars-stx)]) - (connect-value-labels-to-var-labels sba-state inflowing-label vars-labels vars-length 'let-values) - (for-each (lambda (var-stx var-label) - (search-and-replace gamma-extended (syntax-e var-stx) var-label)) - vars-stx vars-labels)) - ; [(x y) (... 1 ...))] - (begin - (set-error-for-label - sba-state - letrec-values-label - 'red - (format "letrec-values: context expected ~a values, received 1 non-multiple-values value" - vars-length)) - #f))) - ; multiple values sink => unique, fake destination - (gensym))]) - (add-edge-and-propagate-set-through-edge - exp-label - distributive-unpacking-edge)))) - ; process remaining clauses - (loop (cdr varss-stx) (cdr exps))))] - [last-body-exp-label - (list:foldl - (lambda (exp _) - (create-label-from-term sba-state exp gamma-extended enclosing-lambda-label)) - cst:dummy - (syntax-e (syntax (body-exps ...))))]) - (add-edge-and-propagate-set-through-edge - last-body-exp-label - (create-simple-edge letrec-values-label)) - letrec-values-label)] - [(if test then else) - (let*-values - ([(test) (syntax test)] - [(test-label) (create-label-from-term sba-state test gamma enclosing-lambda-label)] - [(then-label else-label) - (if (symbol? (syntax-e test)) - (let* ([test-name (syntax-e test)] - [binding-label (lookup-env test gamma)] - [new-then-binding-label (create-simple-prim-label term)] - [new-else-binding-label (create-simple-prim-label term)] - [new-then-gamma (extend-env gamma (list test) (list new-then-binding-label))] - [new-else-gamma (extend-env gamma (list test) (list new-else-binding-label))] - [then-normal-edge (create-simple-edge new-then-binding-label)] - [else-normal-edge (create-simple-edge new-else-binding-label)] - ; discards #f, passes the rest to then-normal-edge - [then-filtering-edge - (cons - (lambda (out-label inflowing-label tunnel-label) - (when (or (not (label-cst? inflowing-label)) - (label-cst-value inflowing-label)) - ((car then-normal-edge) out-label inflowing-label tunnel-label))) - (cdr then-normal-edge))] - ; discards everything but #f and passes it to else-normal-edge - [else-filtering-edge - (cons - (lambda (out-label inflowing-label tunnel-label) - (when (and (label-cst? inflowing-label) - (not (label-cst-value inflowing-label))) - ((car else-normal-edge) out-label inflowing-label tunnel-label))) - (cdr else-normal-edge))]) - (if binding-label - (begin - (add-edge-and-propagate-set-through-edge binding-label then-filtering-edge) - (add-edge-and-propagate-set-through-edge binding-label else-filtering-edge) - (values - (create-label-from-term sba-state (syntax then) new-then-gamma enclosing-lambda-label) - (create-label-from-term sba-state (syntax else) new-else-gamma enclosing-lambda-label))) - (values - (create-label-from-term sba-state (syntax then) gamma enclosing-lambda-label) - (create-label-from-term sba-state (syntax else) gamma enclosing-lambda-label)))) - (values - (create-label-from-term sba-state (syntax then) gamma enclosing-lambda-label) - (create-label-from-term sba-state (syntax else) gamma enclosing-lambda-label)))] - ; because of the (if test then) case below, else-label might be associated with - ; the same position as the whole term, so we have to create the if-label after - ; the else-label, so that the wrong label/position association created by the - ; else-label is overwritten. - [(if-label) (create-simple-label sba-state term)] - [(if-edge) (create-simple-edge if-label)] - ; that does the outgoing flow sensitivity - [(test-edge) (create-self-modifying-edge (lambda (label) - ; XXX subtping should be used here - (or (not (label-cst? label)) - (label-cst-value label))) - then-label else-label if-edge)]) - (add-edge-and-propagate-set-through-edge test-label test-edge) - if-label)] - [(if test then) - (let* ([test (syntax test)] - [test-label (create-label-from-term sba-state test gamma enclosing-lambda-label)] - [then-label - (if (symbol? (syntax-e test)) - (let* ([test-name (syntax-e test)] - [binding-label (lookup-env test gamma)] - [new-then-binding-label (create-simple-prim-label term)] - [new-then-gamma (extend-env gamma (list test) (list new-then-binding-label))] - [then-normal-edge (create-simple-edge new-then-binding-label)] - ; discards #f, passes the rest to then-normal-edge - [then-filtering-edge - (cons - (lambda (out-label inflowing-label tunnel-label) - (when (or (not (label-cst? inflowing-label)) - (label-cst-value inflowing-label)) - ((car then-normal-edge) out-label inflowing-label tunnel-label))) - (cdr then-normal-edge))]) - (if binding-label - (begin - (add-edge-and-propagate-set-through-edge binding-label then-filtering-edge) - (create-label-from-term sba-state (syntax then) new-then-gamma enclosing-lambda-label)) - (create-label-from-term sba-state (syntax then) gamma enclosing-lambda-label))) - (create-label-from-term sba-state (syntax then) gamma enclosing-lambda-label))] - [else-label (let ([void-label (make-label-cst - #f #f #f #f #t - term - (make-hash-table) - (make-hash-table) - cst:void)]) - (initialize-label-set-for-value-source void-label) - ;(register-label-with-gui void-label) - void-label)] - ; because of the (if test then) case below, else-label might be associated with - ; the same position as the whole term, so we have to create the if-label after - ; the else-label, so that the wrong label/position association created by the - ; else-label is overwritten. - [if-label (create-simple-label sba-state term)] - [if-edge (create-simple-edge if-label)] - [test-edge (create-self-modifying-edge (lambda (label) - (or (not (label-cst? label)) - (label-cst-value label))) - then-label else-label if-edge)]) - (add-edge-and-propagate-set-through-edge test-label test-edge) - if-label)] - [(begin exp exps ...) - (let ([begin-label (create-simple-label sba-state term)] - [last-body-exp-label (list:foldl - (lambda (exp _) - (create-label-from-term sba-state exp gamma enclosing-lambda-label)) - cst:dummy - (cons (syntax exp) (syntax-e (syntax (exps ...)))))]) - (add-edge-and-propagate-set-through-edge - last-body-exp-label - (create-simple-edge begin-label)) - begin-label)] - [(begin0 exp exps ...) - (let ([begin0-label (create-simple-label sba-state term)] - [first-body-exp-label - (create-label-from-term sba-state (syntax exp) gamma enclosing-lambda-label)]) - (for-each (lambda (exp) - (create-label-from-term sba-state exp gamma enclosing-lambda-label)) - (syntax-e (syntax (exps ...)))) - (add-edge-and-propagate-set-through-edge - first-body-exp-label - (create-simple-edge begin0-label)) - begin0-label)] - [(#%top . identifier) - (let ([identifier (syntax identifier)]) - (create-top-level-label sba-state identifier gamma enclosing-lambda-label))] - [(set! var exp) - (let* ([var-stx (syntax var)] - [var-name (syntax-e var-stx)] - [var-label (create-simple-label sba-state var-stx)] - [var-edge (create-simple-edge var-label)] - [binding-label (lookup-env var-stx gamma)] - [exp-label - (create-label-from-term sba-state (syntax exp) gamma enclosing-lambda-label)] - [set!-label (create-simple-label sba-state term)] - [set!-edge (create-simple-edge set!-label)] - [void-label (make-label-cst #f #f #f #f #f - term - (make-hash-table) - (make-hash-table) - cst:void)]) - (initialize-label-set-for-value-source void-label) - (if binding-label - ; lexical variable - (let* ([binding-edge (create-simple-edge binding-label)] - [effect - (lambda () - ;(search-and-replace gamma var-name var-label) - (add-edge-and-propagate-set-through-edge - exp-label var-edge) - (add-edge-and-propagate-set-through-edge - var-label binding-edge) - (add-edge-and-propagate-set-through-edge - void-label set!-edge) - )]) - (if enclosing-lambda-label - (let* ([enclosing-lambda-effects (label-case-lambda-effects enclosing-lambda-label)] - [current-thunk (car enclosing-lambda-effects)]) - (set-car! enclosing-lambda-effects - (lambda () - (current-thunk) - (effect)))) - (effect))) - (let ([effect - (lambda () - ; delay the lookup until the effect takes place - ; if the name we want to set! is a primitive, we set! the label that - ; simulates the primitive's definition. - (let ([binding-label (or (lookup-top-level-name sba-state var-name) - (let ([primitive-data - (lookup-primitive-data sba-state var-name)]) - (if primitive-data - (prim-data-label primitive-data) - #f)))]) - (if (or binding-label - (eq? var-name 'make-struct-type) - (eq? var-name 'make-struct-field-accessor) - (eq? var-name 'make-struct-field-mutator) - (eq? var-name 'set-car!) - (eq? var-name 'set-cdr!) - (eq? var-name 'string-set!) - (eq? var-name 'string-fill!) - (eq? var-name 'vector-set!) - (eq? var-name 'vector-fill!)) - ; top level var - (let ([binding-edge (create-simple-edge binding-label)]) - ;(add-top-level-name var-stx var-label) - (add-edge-and-propagate-set-through-edge - exp-label var-edge) - (add-edge-and-propagate-set-through-edge - var-label binding-edge) - (add-edge-and-propagate-set-through-edge - void-label set!-edge) - ) - (set-error-for-label sba-state - set!-label - 'red - (format "set!: cannot set undefined identifier: ~a" var-name)))))]) - (if enclosing-lambda-label - (let* ([enclosing-lambda-effects (label-case-lambda-effects enclosing-lambda-label)] - [current-thunk (car enclosing-lambda-effects)]) - (set-car! enclosing-lambda-effects - (lambda () - (current-thunk) - (effect)))) - (effect)))) - set!-label)] - [(quote-syntax foo ...) - (let ([label (create-simple-label sba-state term)]) - (set-error-for-label sba-state - label - 'red - (format "quote-syntax not yet implemented")) - label)] - [(with-continuation-mark foo ...) - (let ([label (create-simple-label sba-state term)]) - (set-error-for-label sba-state - label - 'red - (format "with-continuation-mark not yet implemented")) - label)] - [(define-syntaxes foo ...) - (let ([label (create-simple-label sba-state term)]) - (set-error-for-label sba-state - label - 'red - (format "define-syntaxes not yet implemented")) - label)] - [(module foo ...) - (let ([label (create-simple-label sba-state term)]) - (set-error-for-label sba-state - label - 'red - (format "module not yet implemented")) - label)] - [(require foo ...) - (let ([label (create-simple-label sba-state term)]) - (set-error-for-label sba-state - label - 'red - (format "require not yet implemented")) - label)] - [(require-for-syntax foo ...) - (let ([label (create-simple-label sba-state term)]) - (set-error-for-label sba-state - label - 'red - (format "require-for-syntax not yet implemented")) - label)] - [(provide foo ...) - (let ([label (create-simple-label sba-state term)]) - (set-error-for-label sba-state - label - 'red - (format "provide not yet implemented")) - label)] - [(#%plain-module-begin foo ...) - (let ([label (create-simple-label sba-state term)]) - (set-error-for-label sba-state - label - 'red - (format "#%plain-module-begin not yet implemented")) - label)] - [var - ; we cannot directly return the binding label, because, even though it makes for a - ; simpler graph and simpler types, it screws up the arrows - (let* ([var-stx (syntax var)] - ;[var-name (syntax-e var-stx)] - [binding-label (lookup-env var-stx gamma)]) - (if binding-label - ; lexical variable - (let ([bound-label (create-simple-label sba-state term)]) - (if enclosing-lambda-label - ; we have to delay the binding, because there might be a set! in between the - ; analysis of the enclosing lambda and the time the lambda is applied. - ; Note that this means we have to redo a lookup later to get the right binder, - ; which will have changed if a set! has occured (explicitely, or because - ; the lambda is in a letrec clause (see letrec)) - (let* ([enclosing-lambda-effects - (label-case-lambda-effects enclosing-lambda-label)] - [current-thunk (car enclosing-lambda-effects)]) - (set-car! enclosing-lambda-effects - (lambda () - (current-thunk) - (let ([binding-label (lookup-env var-stx gamma)]) - (add-edge-and-propagate-set-through-edge - binding-label - (extend-edge-for-values sba-state (create-simple-edge bound-label))))))) - (add-edge-and-propagate-set-through-edge - binding-label - (extend-edge-for-values sba-state (create-simple-edge bound-label)))) - bound-label) - ; probably a top level var (like a primitive name) but without #%top (if it comes - ; from a macro, or some strange stuff like that. - (create-top-level-label sba-state var-stx gamma enclosing-lambda-label) - ))] - )) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; TYPES - - ; each entry is of the form (type-name (listof direct-subtypes) scheme-predicate) - ; top should appear first (see the subtype function below) - ; note also that exact? and inexact? can only be used for numbers, so we have to do - ; tests like complex? first. - (define *basic-types* `((top (undefined void null boolean char symbol string eof-object env number port) - ,(lambda (_) #t)) - (undefined () ,(lambda (v) (eq? v cst:undefined))) - (void () ,void?) - (null () ,null?) - (boolean () ,boolean?) - (char (letter) ,char?) - ; approximation - (letter () ,char?) - (symbol () ,symbol?) - (string () ,string?) - (eof-object () ,eof-object?) - ; no r5rs predicate, but no subtype anyway... - (env () ,(lambda (_) #f)) - (number (exact-number inexact-number complex) ,number?) - (exact-number (exact-complex) ,(lambda (n) (and (number? n) (exact? n)))) - (inexact-number (inexact-complex) ,(lambda (n) (and (number? n) (inexact? n)))) - (complex (exact-complex inexact-complex real) ,complex?) - (exact-complex (exact-real) ,(lambda (n) (and (complex? n) (exact? n)))) - (inexact-complex (inexact-real) ,(lambda (n) (and (complex? n) (inexact? n)))) - (real (exact-real inexact-real rational) ,real?) - (exact-real (exact-rational) ,(lambda (n) (and (real? n) (exact? n)))) - (inexact-real (inexact-rational) ,(lambda (n) (and (real? n) (inexact? n)))) - (rational (exact-rational inexact-rational integer) ,rational?) - (exact-rational (exact-integer) ,(lambda (n) (and (rational? n) (exact? n)))) - (inexact-rational (inexact-integer) ,(lambda (n) (and (rational? n) (inexact? n)))) - (integer (exact-integer inexact-integer) ,integer?) - (exact-integer () ,(lambda (n) (and (integer? n) (exact? n)))) - (inexact-integer () ,(lambda (n) (and (integer? n) (inexact? n)))) - (port (input-port) ,port?) - (input-port () ,input-port?) - (output-port () ,output-port?) - (bottom () ,(lambda (_) #f)) - )) - - (define *type-constructors* '(forall - cons listof - vector union values - case-lambda -> *-> rest - promise - rec-type - )) - (define *all-type-keywords* (append (map car *basic-types*) *type-constructors*)) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; PRIMITIVE TYPE PARSER AND LOOKUP - - ; sba-state symbol -> (or/c prim-data #f) - (define (lookup-primitive-data sba-state name) - (hash-table-get (sba-state-primitive-types-table sba-state) name cst:thunk-false)) - - ; sba-state string -> void - (define (initialize-primitive-type-schemes sba-state filename) - ; XXX should check for errors - (let ([sexp (call-with-input-file filename read 'text)] - [primitive-types-table (sba-state-primitive-types-table sba-state)]) - (unless (list? sexp) - (raise-syntax-error - 'initialize-primitive-type-schemes - (format "expected list at top level in file ~a, got: ~a" - filename sexp))) - (for-each (lambda (prim-entry) - (unless (and (list? prim-entry) - (= 2 (length prim-entry)) - (symbol? (car prim-entry))) - (raise-syntax-error - 'initialize-primitive-type-schemes - (format "expected `(,symbol type-scheme) entry in file ~a, got: ~a" - filename prim-entry)))) - sexp) - (for-each (lambda (prim-entry) - (let ([primitive-name (car prim-entry)] - [primitive-type (cadr prim-entry)]) - (when (hash-table-get primitive-types-table - primitive-name cst:thunk-false) - (raise-syntax-error - 'initialize-primitive-type-schemes - (format "found duplicate for primitive ~a in file ~a" - primitive-name filename))) - (hash-table-put! primitive-types-table primitive-name - (make-prim-data (parse&check-type-scheme - primitive-type primitive-name filename) - (create-simple-prim-label #f))))) - sexp))) - - ; sexp symbol tring -> type - (define (parse&check-type-scheme sexp primitive-name filename) - (if (and (list? sexp) - (not (null? sexp)) - (eq? (car sexp) 'forall)) - (if (= (length sexp) 3) - (let ([delta-flow (make-hash-table)] - [flow-vars&type^cs (cadr sexp)] - [type (caddr sexp)]) - (for-each - (lambda (flow-var&type^C) - (if (and (list? flow-var&type^C) - (= (length flow-var&type^C) 2) - (symbol? (car flow-var&type^C))) - (let ([flow-var (car flow-var&type^C)] - [type^C (cadr flow-var&type^C)]) - (when (memq flow-var *all-type-keywords*) - (raise-syntax-error - 'parse&check-type-scheme - (format "flow variable ~a is already the name of a basic type or type constructor, in type scheme for primitive ~a in file ~a" - flow-var primitive-name filename))) - (when (hash-table-get delta-flow flow-var cst:thunk-false) - (raise-syntax-error - 'parse&check-type-scheme - (format "duplicate flow variable ~a in type scheme for primitive ~a in file ~a" - flow-var primitive-name filename))) - (hash-table-put! delta-flow - flow-var - (cons (list #t #t (make-type-flow-var flow-var)) - ; type^cs do not contain flow vars, so we give an - ; empty delta. If this function returns, we know - ; the result is a constant type. - (parse&check-type type^C - (make-hash-table) - '() - #t - primitive-name filename)))) - (raise-syntax-error - 'parse&check-type-scheme - (format "malformed type scheme clause for primitive ~a in file ~a: expected (symbol type), got ~a" - primitive-name filename flow-var&type^C)))) - flow-vars&type^cs) - (let ([type (parse&check-type type delta-flow '() #t primitive-name filename)]) - (hash-table-for-each - delta-flow - (lambda (flow-var type-info) - (let ([no-contra-use (caar type-info)] - [no-co-use (cadar type-info)]) - (cond - [(and no-contra-use no-co-use) - (raise-syntax-error - 'parse&check-type-scheme - (format "unused flow variable ~a in type scheme for primitive ~a in file ~a" - flow-var primitive-name filename))] - [no-contra-use - (raise-syntax-error - 'parse&check-type-scheme - (format "no contravariant in-flow for flow variable ~a in type scheme for primitive ~a in file ~a" - flow-var primitive-name filename))] - [no-co-use - (raise-syntax-error - 'parse&check-type-scheme - (format "no covariant out-flow for flow variable ~a in type scheme for primitive ~a in file ~a" - flow-var primitive-name filename))] - [else #t])))) - (if (null? flow-vars&type^cs) - type - (make-type-scheme - (hash-table-map delta-flow (lambda (flow-var type-info) (caddar type-info))) - (hash-table-map delta-flow (lambda (flow-var type-info) (cdr type-info))) - type)))) - (raise-syntax-error 'parse&check-type-scheme - (format "malformed type scheme for primitive ~a in file ~a: expected (forall (flow-var-clause ...) type), got ~a" - primitive-name filename sexp))) - (parse&check-type sexp (make-hash-table) '() #t primitive-name filename))) - - ; sexp (hash-table-of symbol (cons (list boolean boolean type-var) type)) - ; (listof (cons symbol type-var))) boolean symbol string -> type - (define (parse&check-type sexp delta-flow delta-type covariant? primitive-name filename) - (if (list? sexp) - (if (null? sexp) - (make-type-cst '()) - (let ([type-kw (car sexp)]) - (cond - [(eq? type-kw 'forall) - (raise-syntax-error - 'parse&check-type - (format "type scheme inside type or other type scheme for primitive ~a in file ~a: ~a" - primitive-name filename sexp))] - [(eq? type-kw 'case-lambda) - (let ([all-types - (list:foldr - (lambda (clause other-clauses-types) - (if (and (list? clause) - (= (length clause) 2)) - (let* ([args (car clause)] - [exp (cadr clause)] - [exp-type (parse&check-type exp delta-flow delta-type - covariant? - primitive-name filename)] - [rest-arg?s (vector-ref other-clauses-types 0)] - [req-args (vector-ref other-clauses-types 1)] - [argss-typess (vector-ref other-clauses-types 2)] - [exps-types (vector-ref other-clauses-types 3)]) - (if (list? args) - (let ([args-length (length args)]) - (if (and (pair? args) ; could be empty - (eq? (car args) 'rest)) - ; list of (possibly complex) args with (possibly complex) rest arg - (if (> args-length 1) - (vector (cons #t rest-arg?s) - (cons (- args-length 2) req-args) - (cons (map (lambda (arg) - (parse&check-type arg delta-flow delta-type - (not covariant?) - primitive-name filename)) - (cdr args)) - argss-typess) - (cons exp-type exps-types)) - (raise-syntax-error - 'parse&check-type - (format "missing rest argument in argument list for clause in case-lambda type in type scheme for primitive ~a in file ~a: expected (rest arg-type args-types ...), got ~a" - primitive-name filename args))) - ; normal (possibly empty) list of (possibly complex) args - (vector (cons #f rest-arg?s) - (cons args-length req-args) - (cons (map (lambda (arg) - (parse&check-type arg delta-flow delta-type - (not covariant?) - primitive-name filename)) - args) - argss-typess) - (cons exp-type exps-types)))) - (raise-syntax-error - 'parse&check-type - (format "malformed argument list for clause in case-lambda type in type scheme for primitive ~a in file ~a: expected (args-types ...), got ~a" - primitive-name filename args)))) - (raise-syntax-error - 'parse&check-type - (format "malformed clause in case-lambda type in type scheme for primitive ~a in file ~a: expected (args-types exp-type), got ~a" - primitive-name filename clause)))) - (vector '()'()'()'()) - (cdr sexp))]) - (make-type-case-lambda (vector-ref all-types 0) - (vector-ref all-types 1) - (vector-ref all-types 2) - (vector-ref all-types 3)))] - [(eq? type-kw 'cons) - (if (= (length sexp) 3) - (make-type-cons (parse&check-type (cadr sexp) delta-flow delta-type covariant? - primitive-name filename) - (parse&check-type (caddr sexp) delta-flow delta-type covariant? - primitive-name filename)) - (raise-syntax-error - 'parse&check-type - (format "malformed cons type in type scheme for primitive ~a in file ~a: ~a" - primitive-name filename sexp)))] - [(eq? type-kw 'union) - (make-type-union (map (lambda (elt-sexp) - (parse&check-type - elt-sexp delta-flow delta-type covariant? - primitive-name filename)) - (cdr sexp)))] - [(eq? type-kw 'values) - (if (= (length sexp) 2) - (make-type-values (parse&check-type - (cadr sexp) delta-flow delta-type covariant? - primitive-name filename)) - (raise-syntax-error - 'parse&check-type - (format "malformed values type in type scheme for primitive ~a in file ~a: expected (values type), got ~a" - primitive-name filename sexp)))] - [(eq? type-kw 'rec-type) - (if (= (length sexp) 3) - (let* ([clauses (cadr sexp)] - [clauses-type-vars-names&types - (map - (lambda (clause) - (if (and (list? clause) - (= (length clause) 2)) - (let ([type-var-name (car clause)]) - (if (or (assq type-var-name delta-type) - (hash-table-get delta-flow sexp cst:thunk-false)) - (raise-syntax-error - 'parse&check-type - (format "recursive type variable ~a used twice or conflicts with flow variable name in type scheme for primitive ~a in file ~a" - type-var-name primitive-name filename)) - (cons type-var-name (make-type-var type-var-name #f #f)))))) - clauses)] - [all-type-vars (append clauses-type-vars-names&types delta-type)] - [clauses-types - (map - (lambda (clause) - (parse&check-type - (cadr clause) delta-flow all-type-vars covariant? - primitive-name filename)) - clauses)]) - (make-type-rec (map cdr clauses-type-vars-names&types) clauses-types - (parse&check-type - (caddr sexp) delta-flow all-type-vars covariant? - primitive-name filename))) - (raise-syntax-error - 'parse&check-type - (format "malformed recursive type in type scheme primitive ~a in file ~a: ~a" - primitive-name filename sexp)))] - [(eq? type-kw 'listof) - (if (= (length sexp) 2) - ; (listof T) = (rec ([alpha (union '() (cons T alpha))]) alpha) - (let ([listof-type-var (gensym)]) - (parse&check-type - `(rec-type ([,listof-type-var (union () (cons ,(cadr sexp) ,listof-type-var))]) - ,listof-type-var) - delta-flow delta-type - covariant? - primitive-name filename)) - (raise-syntax-error - 'parse&check-type - (format "malformed listof type in type scheme for primitive ~a in file ~a: expected (listof type), got ~a" - primitive-name filename sexp)))] - [(eq? type-kw 'vector) - (if (= (length sexp) 2) - (make-type-vector (parse&check-type - (cadr sexp) delta-flow delta-type covariant? - primitive-name filename)) - (raise-syntax-error - 'parse&check-type - (format "malformed vector type in type scheme for primitive ~a in file ~a: expected (vector type), got ~a" - primitive-name filename sexp)))] - [(eq? type-kw 'promise) - (if (= (length sexp) 2) - (make-type-promise (parse&check-type - (cadr sexp) delta-flow delta-type covariant? - primitive-name filename)) - (raise-syntax-error - 'parse&check-type - (format "malformed promise type in type scheme for primitive ~a in file ~a: expected (promise type), got ~a" - primitive-name filename sexp)))] - [(eq? type-kw 'rest) - (raise-syntax-error - 'parse&check-type - (format "illegal use of rest in type scheme for primitive ~a in file ~a: ~a" - primitive-name filename sexp))] - [else - (let* ([sexp-length (length sexp)] - [sexp-length-1 (sub1 sexp-length)] - [sexp-length-2 (sub1 sexp-length-1)] - [sexp-length-3 (sub1 sexp-length-2)]) - (cond - [(and (>= sexp-length-2 0) - (eq? (list-ref sexp sexp-length-2) '->)) - (let ([exp-sexp (list-ref sexp sexp-length-1)] - [list-head (list-head! sexp sexp-length-2 - primitive-name filename)]) - (parse&check-type - `(case-lambda [,list-head ,exp-sexp]) - delta-flow delta-type covariant? primitive-name filename))] - [(and (>= sexp-length-3 0) - (eq? (list-ref sexp sexp-length-2) '*->)) - (let ([exp-sexp (list-ref sexp sexp-length-1)] - [rest-sexp (list `(listof ,(list-ref sexp sexp-length-3)))] - [list-head (list-head! sexp sexp-length-3 - primitive-name filename)]) - (parse&check-type - `(case-lambda [,(cons 'rest (set-list-tail-cdr! list-head rest-sexp)) - ,exp-sexp]) - delta-flow delta-type covariant? primitive-name filename))] - [else - (raise-syntax-error - 'parse&check-type - (format "malformed constructed type in type scheme for primitive ~a in file ~a: ~a" - primitive-name filename sexp))]))] - ))) - (cond - [(pair? sexp) - ; improper list - (raise-syntax-error - 'parse&check-type - (format "improper list found in type scheme for primitive ~a in file ~a: ~a" - primitive-name filename sexp))] - [(memq sexp *type-constructors*) - => - (lambda (_) - (raise-syntax-error - 'parse&check-type-scheme - (format "type variable ~a is already the name of a type constructor, in type scheme for primitive ~a in file ~a" - sexp primitive-name filename)))] - [(hash-table-get delta-flow sexp cst:thunk-false) - => - (lambda (type-info) - (if covariant? - (set-car! (cdar type-info) #f) - (if (caar type-info) - (set-car! (car type-info) #f) - ; already used this flow variable in contravariant position - (raise-syntax-error - 'parse&check-type - (format "flow variable ~a used several times in contravariant position in type scheme for primitive ~a in file ~a" - sexp primitive-name filename)))) - (caddar type-info))] - [(assq sexp delta-type) - => - ; gets (cons type-var-name type-var) => returns type-var - cdr] - ; [(memq sexp *basic-types*);XXX definition of *basic-types* has changed... - ; (make-type-cst sexp)] - ; the following works for both basic types and any atomic value (which is - ; then considered a basic type too). We know that flow var names and basic - ; type names are disjoint, so there's no confusion between this case and - ; the previous one. - [else - (cond - [(eq? sexp 'boolean) - (make-type-union (list (make-type-cst #t) (make-type-cst #f)))] - [(eq? sexp 'void) - (make-type-cst cst:void)] - [(eq? sexp 'bottom) - (make-type-empty)] - [(eq? sexp 'undefined) - (make-type-cst cst:undefined)] - [else (make-type-cst sexp)])]))) - - ; (listof alpha) number sexp symbol string -> (listof alpha) - ; returns first n elements of l. We know from the way the function is called that we - ; must always have n >= 0 and (length l) >= n. - (define (list-head! l n primitive-name filename) - (letrec ([chop (lambda (l n) - (if (= n 1) - (set-cdr! l '()) - (chop (cdr l) (sub1 n))))]) - (cond - [(zero? n) '()] - [(>= n 1) (chop l n) l] - [else (raise-syntax-error - 'list-head! - (format "internal error 6 in type scheme for primitive ~a in file ~a" - primitive-name filename))]))) - - ; (listof top) top -> improper-list - ; glues rest-sexp as the cdr of the last element of list-head - (define (set-list-tail-cdr! list-head rest-sexp) - (letrec ([glue (lambda (l) - (if (null? (cdr l)) - (set-cdr! l rest-sexp) - (glue (cdr l))))]) - (if (null? list-head) - rest-sexp - (begin - (glue list-head) - list-head)))) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; TYPE ENVIRONMENT & MISC - - ; (hash-table-of symbol label) type-flow-var label -> label - (define (add-flow-var-to-env env flow-var label) - (hash-table-put! env flow-var label) - env) - - ; (hash-table-of symbol label) type-flow-var -> label - ; the type parser guarantees that the lookup will be succesfull - (define (lookup-flow-var-in-env env flow-var) - (hash-table-get env flow-var)) - - ; like map, but over a list made of label-cons instead of cons - (define (type-list-map f tl) - (if (type-cons? tl) - (cons (f (type-cons-car tl)) - (type-list-map f (type-cons-cdr tl))) - (if (and (type-cst? tl) - (eq? (type-cst-type tl) '())) - '() - (error 'type-list-map "not a type list: ~a" tl)))) - - ; symmetric of list-tail - (define (list-head l n) - (if (zero? n) - '() - (if (null? l) - (error 'list-head "list too short") - (cons (car l) - (list-head (cdr l) (sub1 n)))))) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; GRAPH RECONSTRUCTION FROM TYPE - - ; sba-state type (hash-table-of symbol label) label -> label - ; analyse type scheme and creates flow var environment - ; label is the label into which the final result will flow into. We need that - ; mainly to report errors correctly. - (define (reconstruct-graph-from-type-scheme sba-state type delta-flow label) - (let ([term (label-term label)]) - (if (type-scheme? type) - (begin - (for-each (lambda (flow-var type^C) - (let ([label (create-simple-prim-label term)]) - ;(associate-label-with-type label type^C) - (add-flow-var-to-env delta-flow flow-var (cons label type^C)))) - (type-scheme-flow-vars type) - (type-scheme-type^cs type)) - (reconstruct-graph-from-type sba-state (type-scheme-type type) delta-flow '() label term #t #f)) - (reconstruct-graph-from-type sba-state type delta-flow '() label term #t #f)))) - - ; sba-state type (hash-table-of type-flow-var (cons label type)) (listof (cons type-var label)) - ; label term boolean label -> label - ; reconstructs a graph from type representing the primitive represented by label, - ; using environment delta. - ; delta-flow is the flow-var->label environment, delta-type is the type-var->label one. - ; label is the label for the primitive whose type we are analyzing. It's just used for underlining - ; errors. Same for term. covariant? is self-explanatory... - ; contra-union? is a boolean telling whether the parent label we are dealing - ; with is a union in contravariant position: since the flows are not filtered by types, - ; everything that flows into a union will normally flow into the different componants - ; of the union. We don't want that, because then things might flow into a label were they - ; should flow into and trigger a false error. The best example is this is with lists: it's - ; a recursive type that contains a union of the empty list and of a recursive cons. If a - ; cons flows into a list label, the cons will flow in both parts of the union, and trigger - ; an error when it flows into the empty label. So we have to do some filtering. This means - ; that we are not going to create a simple edge between the union label and the empty label - ; when we analyze the union type, but we are going to create a filtering edge between the - ; union label and the empty label when we analyze the empty type. To do that we need to - ; keep track of the parent union label. - ; Note how we use associate-label-with-type to memorize type checking only in the contravariant - ; case. The type to check in the covariant case is always top, since we assume internal - ; correctness of the graph generation from a primitive type. - (define (reconstruct-graph-from-type sba-state type delta-flow delta-type label term covariant? contra-union?) - (if covariant? - ; covariant cases - (cond - [(type-case-lambda? type) - (let* ([all-labels - (list:foldr - (lambda (args-types exp-type other-clauses-labels) - (let ([argss-labelss (car other-clauses-labels)] - [exps-labels (cdr other-clauses-labels)]) - (cons (cons (map (lambda (arg-type) - (reconstruct-graph-from-type - sba-state - arg-type delta-flow delta-type label term #f #f)) - args-types) - argss-labelss) - (cons (reconstruct-graph-from-type - sba-state - exp-type delta-flow delta-type label term #t #f) - exps-labels)))) - (cons '()'()) - (type-case-lambda-argss type) - (type-case-lambda-exps type))] - [label (make-label-case-lambda - #f #f #f #f #t - term - (make-hash-table) - (make-hash-table) - #f - (type-case-lambda-rest-arg?s type) - (type-case-lambda-req-args type) - (car all-labels) - (cdr all-labels) - ;(map (lambda (_) '()) all-labels) - (map (lambda (_) cst:dummy-thunk) all-labels))]) - (initialize-label-set-for-value-source label) - label)] - [(type-cons? type) - (let ([label (make-label-cons - #f #f #f #f #t - term - (make-hash-table) - (make-hash-table) - (reconstruct-graph-from-type - sba-state - (type-cons-car type) delta-flow delta-type label term #t #f) - (reconstruct-graph-from-type - sba-state - (type-cons-cdr type) delta-flow delta-type label term #t #f))]) - (initialize-label-set-for-value-source label) - label)] - [(type-vector? type) - (let ([label (make-label-vector - #f #f #f #f #t - term - (make-hash-table) - (make-hash-table) - (reconstruct-graph-from-type - sba-state - (type-vector-element type) delta-flow delta-type label term #t #f))]) - (initialize-label-set-for-value-source label) - label)] - [(type-promise? type) - (let ([label (make-label-promise - #f #f #f #f #t - term - (make-hash-table) - (make-hash-table) - (reconstruct-graph-from-type - sba-state - (type-promise-value type) delta-flow delta-type label term #t #f))]) - (initialize-label-set-for-value-source label) - label)] - [(type-flow-var? type) - (car (lookup-flow-var-in-env delta-flow type))] - [(type-var? type) - (cdr (assq type delta-type))] - [(type-cst? type) - (let ([label (make-label-cst - #f #f #f #f #t - term - (make-hash-table) - (make-hash-table) - ; the type parser ensures that type-cst is only created for - ; non-list (i.e. atomic) types => 3, 'foo, 'int - (type-cst-type type))]) - (initialize-label-set-for-value-source label) - label)] - [(type-union? type) - (let* ([elt-labels (map (lambda (elt-type) - (reconstruct-graph-from-type - sba-state - elt-type delta-flow delta-type label term #t #f)) - (type-union-elements type))] - [union-label (create-simple-prim-label term)] - ; can return multiple values - [union-edge (create-simple-edge union-label)]) - (for-each (lambda (elt-label) - (add-edge-and-propagate-set-through-edge elt-label union-edge)) - elt-labels) - union-label)] - [(type-values? type) - (let* ([values-content-label (reconstruct-graph-from-type - sba-state - (type-values-type type) delta-flow delta-type label term #t #f)] - [values-label (make-label-values - #f #f #f #f #t - term - (make-hash-table) - (make-hash-table) - values-content-label)]) - (initialize-label-set-for-value-source values-label) - values-label)] - [(type-rec? type) - (let* ([clauses-vars-types&labels (map (lambda (type-var) - (cons type-var (create-simple-prim-label term))) - (type-rec-vars type))] - [all-var-labels (append clauses-vars-types&labels delta-type)] - [clauses-types-labels (map (lambda (clause-type) - (reconstruct-graph-from-type - sba-state - clause-type delta-flow all-var-labels label term #t #f)) - (type-rec-types type))]) - ; note: we never check whether all clauses are used. If they are not, they'll be - ; garbage collected after we return from here. - (for-each (lambda (clause-var-type&label clause-type-label) - (add-edge-and-propagate-set-through-edge - clause-type-label - (create-simple-edge (cdr clause-var-type&label)))) - clauses-vars-types&labels clauses-types-labels) - (reconstruct-graph-from-type sba-state (type-rec-body type) delta-flow all-var-labels label term #t #f))] - [(type-empty? type) - (create-simple-prim-label term)] - [else (error 'reconstruct-graph-from-type "unknown covariant type for primitive ~a: ~a" - (syntax-e term) type)] - ) - ; - ; contravariant cases - ; - (cond - [(type-case-lambda? type) - (let* ([rest-arg?s-around (type-case-lambda-rest-arg?s type)] - [req-args-around (type-case-lambda-req-args type)] - [argss-labelss-around (map (lambda (args-types) - (map (lambda (arg-type) - (reconstruct-graph-from-type - sba-state - arg-type delta-flow delta-type label term #t #f)) - args-types)) - (type-case-lambda-argss type))] - [exps-labels-around (map (lambda (exp-type) - (reconstruct-graph-from-type - sba-state - exp-type delta-flow delta-type label term #f #f)) - (type-case-lambda-exps type))] - [case-lambda-label (create-simple-prim-label term)] - [case-lambda-edge (create-case-lambda-edge - sba-state - rest-arg?s-around - req-args-around - argss-labelss-around - exps-labels-around - case-lambda-label - contra-union?)]) - (unless contra-union? - (associate-label-with-type - sba-state - case-lambda-label - (make-type-case-lambda - rest-arg?s-around - req-args-around - (map (lambda (args-labels rest-arg?) - (if rest-arg? - (list:foldr - (lambda (arg-label other-args) - (if (null? other-args) - ; rest arg => listof - (let ([fake-type-var (make-type-var (gensym) #f #f)]) - (cons (make-type-rec - (list fake-type-var) - (list (make-type-union - (list - (make-type-cst '()) - (make-type-cons - (make-type-empty) - fake-type-var)))) - fake-type-var) - '())) - (cons (make-type-empty) - other-args))) - '() - args-labels) - (map (lambda (arg-label) - (make-type-empty)) - args-labels))) - argss-labelss-around rest-arg?s-around) - (map (lambda (exp-label) - (make-type-cst 'top)) - exps-labels-around)) - delta-flow)) - (add-edge-and-propagate-set-through-edge case-lambda-label case-lambda-edge) - case-lambda-label)] - [(type-cons? type) - (let* ([car-label (reconstruct-graph-from-type - sba-state - (type-cons-car type) delta-flow delta-type label term #f #f)] - [car-edge (create-simple-edge car-label)] - [cdr-label (reconstruct-graph-from-type - sba-state - (type-cons-cdr type) delta-flow delta-type label term #f #f)] - [cdr-edge (create-simple-edge cdr-label)] - [cons-label (create-simple-prim-label term)] - [cons-edge - (cons - (if contra-union? - ; non-error-checking edge - (lambda (out-label inflowing-label tunnel-label) - ; cons sink => no use for out-label here - (if (label-cons? inflowing-label) - (and (add-edge-and-propagate-set-through-edge - (label-cons-car inflowing-label) - car-edge) - (add-edge-and-propagate-set-through-edge - (label-cons-cdr inflowing-label) - cdr-edge)) - #f)) - ; error checking edge - (lambda (out-label inflowing-label tunnel-label) - ; cons sink => no use for out-label here - (if (label-cons? inflowing-label) - (and (add-edge-and-propagate-set-through-edge - (label-cons-car inflowing-label) - car-edge) - (add-edge-and-propagate-set-through-edge - (label-cons-cdr inflowing-label) - cdr-edge)) - ; XXX should we do this here because we can, or in check-primitive-types - ; because that's where it should be done... ? We don't have access to - ; term anymore in check-primitive-types (yet)... See the commented call to - ; associate-label-with-type below. - (begin - (set-error-for-label sba-state - label - 'red - (format "primitive expects argument of type ; given ~a" - (pp-type sba-state (get-type-from-label - sba-state - inflowing-label) - 'type-cons))) - #f)))) - ; cons sink - (gensym))]) - (unless contra-union? - (associate-label-with-type sba-state - cons-label - (make-type-cons - (make-type-cst 'top) - (make-type-cst 'top)) - delta-flow)) - (add-edge-and-propagate-set-through-edge cons-label cons-edge) - cons-label)] - [(type-vector? type) - (let* ([element-label (reconstruct-graph-from-type - sba-state - (type-vector-element type) delta-flow delta-type label term #f #f)] - [element-edge (create-simple-edge element-label)] - [vector-label (create-simple-prim-label term)] - [vector-edge - (cons - (if contra-union? - ; non-error-checking edge - (lambda (out-label inflowing-label tunnel-label) - ; vector sink => no use for out-label here - (if (label-vector? inflowing-label) - (add-edge-and-propagate-set-through-edge - (label-vector-element inflowing-label) - element-edge) - #f)) - ; error checking edge - (lambda (out-label inflowing-label tunnel-label) - ; vector sink => no use for out-label here - (if (label-vector? inflowing-label) - (add-edge-and-propagate-set-through-edge - (label-vector-element inflowing-label) - element-edge) - ; XXX should we do this here because we can, or in check-primitive-types - ; because that's where it should be done... ? We don't have access to - ; term anymore in check-primitive-types (yet)... See the commented call to - ; associate-label-with-type below. - (begin - (set-error-for-label sba-state - label - 'red - (format "primitive expects argument of type ; given ~a" - (pp-type sba-state (get-type-from-label - sba-state inflowing-label) - 'type-vector))) - #f)))) - ; vector sink - (gensym))]) - (unless contra-union? - (associate-label-with-type sba-state - vector-label - (make-type-vector (make-type-cst 'top)) - delta-flow)) - (add-edge-and-propagate-set-through-edge vector-label vector-edge) - vector-label)] - [(type-promise? type) - (let* ([element-label (reconstruct-graph-from-type - sba-state - (type-promise-value type) delta-flow delta-type label term #f #f)] - [element-edge (create-simple-edge element-label)] - [promise-label (create-simple-prim-label term)] - [promise-edge - (cons - (if contra-union? - ; non-error-checking edge - (lambda (out-label inflowing-label tunnel-label) - ; promise sink => no use for out-label here - (if (label-promise? inflowing-label) - (add-edge-and-propagate-set-through-edge - (label-promise-value inflowing-label) - element-edge) - #f)) - ; error checking edge - (lambda (out-label inflowing-label tunnel-label) - ; promise sink => no use for out-label here - (if (label-promise? inflowing-label) - (add-edge-and-propagate-set-through-edge - (label-promise-value inflowing-label) - element-edge) - ; XXX should we do this here because we can, or in check-primitive-types - ; because that's where it should be done... ? We don't have access to - ; term anymore in check-primitive-types (yet)... See the commented call to - ; associate-label-with-type below. - (begin - (set-error-for-label sba-state - label - 'red - (format "primitive expects argument of type ; given ~a" - (pp-type sba-state (get-type-from-label - sba-state inflowing-label) - 'type-promise))) - #f)))) - ; promise sink - (gensym))]) - (unless contra-union? - (associate-label-with-type sba-state - promise-label - (make-type-promise (make-type-cst 'top)) - delta-flow)) - (add-edge-and-propagate-set-through-edge promise-label promise-edge) - promise-label)] - [(type-flow-var? type) - (let* ([label&type^C (lookup-flow-var-in-env delta-flow type)] - [label (car label&type^C)]) - (unless contra-union? - (associate-label-with-type sba-state label (cdr label&type^C) delta-flow)) - label)] - [(type-var? type) - (cdr (assq type delta-type))] - [(type-cst? type) - (let* ([cst-label (make-label-cst - #f #f #f #f #t - term - (make-hash-table) - (make-hash-table) - ; the type parser ensures that type-cst is only created for - ; non-list (i.e. atomic) types => 3, 'foo, 'int - (type-cst-type type))]) - ; propagation to such a label always works, so post checking is necessary - ; note that propagation always works because we don't do any type-based - ; filtering. This means that if the cst is inside a union, the propagation to - ; the union will always work, and the error detection will only happen after - ; the fact (which might be ok, since a label flowing into a cst doesn't go - ; anywhere else) XXX ? - (unless contra-union? - (associate-label-with-type sba-state cst-label type delta-flow)) - cst-label)] - [(type-values? type) - (let* ([values-content-label (reconstruct-graph-from-type - sba-state - (type-values-type type) delta-flow delta-type label term #f #f)] - [values-content-edge (create-simple-edge values-content-label)] - [values-label (create-simple-prim-label term)] - [values-edge - (cons - (if contra-union? - ; non-error-checking edge - (lambda (out-label inflowing-label tunnel-label) - ; values sink => no use for out-label here - (if (label-values? inflowing-label) - ; the label-list of multiple values that might flow in might contain - ; more than one value, but that's ok. - (add-edge-and-propagate-set-through-edge - (label-values-label inflowing-label) - values-content-edge) - ; we are in contravariant position, so the value x that flows out - ; is unique and equivalent to (values x). So we simulate that. Note - ; that multiple values are in fact label-lists of labels inside a - ; values label, so we have to simulate the label-list part... - (let* ([null-label (make-label-cst #f #f #f #f #t - term - (make-hash-table) - (make-hash-table) - '())] - [cons-label (make-label-cons #f #f #f #f #t - term - (make-hash-table) - (make-hash-table) - inflowing-label - null-label)]) - (initialize-label-set-for-value-source null-label) - (initialize-label-set-for-value-source cons-label) - (add-edge-and-propagate-set-through-edge - cons-label - values-content-edge)))) - ; error checking edge - (lambda (out-label inflowing-label tunnel-label) - ; values sink => no use for out-label here - (if (label-values? inflowing-label) - (add-edge-and-propagate-set-through-edge - (label-values-label inflowing-label) - values-content-edge) - (let* ([null-label (make-label-cst #f #f #f #f #t - term - (make-hash-table) - (make-hash-table) - '())] - [cons-label (make-label-cons #f #f #f #f #t - term - (make-hash-table) - (make-hash-table) - inflowing-label - null-label)]) - (initialize-label-set-for-value-source null-label) - (initialize-label-set-for-value-source cons-label) - (add-edge-and-propagate-set-through-edge - cons-label - values-content-edge))))) - ; vector sink - (gensym))]) - ; useless, when you think about it... - ;(unless contra-union? - ; (associate-label-with-type values-label - ; (make-type-values (make-type-cst 'top)) - ; delta-flow)) - (add-edge-and-propagate-set-through-edge values-label values-edge) - values-label)] - [(type-union? type) - (let* ([elt-labels (map (lambda (elt-type) - ; reconstruct without error checking - ; XXX this does not work in the case of a flow var, - ; because associate-label-with-type has already been done. - (reconstruct-graph-from-type - sba-state - elt-type delta-flow delta-type label term #f #t)) - (type-union-elements type))] - [union-label (create-simple-prim-label term)] - [union-label-in-between (create-simple-prim-label term)] - [simple-non-error-checking-edge (create-simple-edge union-label-in-between)] - [error-checking-edge - (cons - (lambda (out-label inflowing-label tunnel-label) - (if ((car simple-non-error-checking-edge) out-label inflowing-label tunnel-label) - (begin - #t) - (begin - (set-error-for-label sba-state - label - 'red - (format "value ~a not a subtype of union ~a inside application of ~a" - (pp-type sba-state (get-type-from-label - sba-state inflowing-label) - 'type-union1) - ;(syntax-object->datum - ; (label-term inflowing-label)) - (pp-type sba-state type 'type-union2) - (syntax-object->datum term))) - ; stop error up-propagation - #t))) - (cdr simple-non-error-checking-edge))]) - ; edges can't propagate multiple values - (for-each (lambda (elt-label) - (add-edge-and-propagate-set-through-edge - union-label-in-between - (extend-edge-for-values sba-state (create-simple-edge elt-label)))) - elt-labels) - (if contra-union? - ; union inside a union, so forget about checking at this level - union-label-in-between - (begin - (add-edge-and-propagate-set-through-edge - union-label - (extend-edge-for-values sba-state error-checking-edge)) - union-label)))] - [(type-rec? type) - (let* ([clauses-vars&labels (map (lambda (type-var) - (cons type-var (create-simple-prim-label term))) - (type-rec-vars type))] - [all-var-labels (append clauses-vars&labels delta-type)] - [clauses-types-labels (map (lambda (clause-type) - (reconstruct-graph-from-type - sba-state - clause-type delta-flow all-var-labels label term #f #f)) - (type-rec-types type))] - [rec-body-label (reconstruct-graph-from-type - sba-state - (type-rec-body type) delta-flow all-var-labels label term #f #f)] - [rec-label (create-simple-prim-label term)]) - ; note: we never check whether all clauses are used. If they are not, they'll be - ; garbage collected after we return from here. - (for-each (lambda (clause-var-type&label clause-type-label) - (add-edge-and-propagate-set-through-edge - (cdr clause-var-type&label) - (create-simple-edge clause-type-label))) - clauses-vars&labels clauses-types-labels) - (unless contra-union? - (associate-label-with-type sba-state rec-body-label type delta-flow)) - ; note: if type is the type corresponding, say, to a list, then if (list 1 2 3) - ; flows into rec-label, then rec-body-label will contain (list 1 2 3), (list 2 3), - ; (list 3), and (). - (add-edge-and-propagate-set-through-edge - rec-label - (extend-edge-for-values sba-state (create-simple-edge rec-body-label))) - rec-label)] - [(type-empty? type) - (let ([empty-label (create-simple-prim-label term)]) - ; propagation to such a label always works, so post checking is necessary - ; note that propagation always works because we don't do any type-based - ; filtering. - (unless contra-union? - (associate-label-with-type sba-state empty-label type delta-flow)) - empty-label)] - [else (error 'reconstruct-graph-from-type "unknown contravariant type for primitive ~a: ~a" - (syntax-e term) type)] - ))) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; POST ANALYSIS TYPE CHECKING FOR PRIMITIVES - - ; sba-state label type (hash-table-of type-flow-var (cons label type)) -> void - ; Note that we don't store the type but only the handle. - (define (associate-label-with-type sba-state label type delta-flow) - (hash-table-put! (sba-state-label->types sba-state) - label - (cons (hc:hashcons-type (sba-state-hashcons-tbl sba-state) - (subst-vals/flow-vars type delta-flow)) - delta-flow))) - - ; sba-state -> void - ; post analysis checking of primitives inputs and outputs - (define (check-primitive-types sba-state) - (hash-table-for-each - (sba-state-label->types sba-state) - (lambda (label expected-type&delta) - (subtype sba-state - (get-type-from-label sba-state label) - (car expected-type&delta) - (cdr expected-type&delta) #t label)))) - - ; (hashtableof symbol (cons (listof symbol) (top -> boolean)) symbol -> (listof symbol) - ; computes the complete (closed) list of subtypes for type-entry - (define (close-subtypes table type-name) - (let ([new-type-entry (hash-table-get table type-name cst:thunk-false)]) - (if new-type-entry - (car new-type-entry) - (let* ([original-type-entry (cdr (assq type-name *basic-types*))] - [new-type-entry - (cons (list:foldl - (lambda (type-name type-names-list-so-far) - (merge-lists (close-subtypes table type-name) - type-names-list-so-far)) - ; not strickly necessary for the way we use the function later - (list type-name) - (car original-type-entry)) - (cadr original-type-entry))]) - (hash-table-put! table type-name new-type-entry) - (car new-type-entry))))) - - (define/contract subt - (sba-state? hc:hashcons-table? handle? handle? any/c set? ;(listof (cons/p handle? handle?)) - . -> . boolean?) - (let ([subtyping-table - (let ([table (make-hash-table)]) - ; the entry for 'top should appear first. Everything will get - ; put into the table as we process this one. - (close-subtypes table (caar *basic-types*)) - table)] - [memo-table (make-hash-table 'equal)]) - (lambda (sba-state hashcons-tbl t1-handle t2-handle delta-flow trace) - (let* ([t1 (hc:get-type hashcons-tbl t1-handle)] - [t2 (hc:get-type hashcons-tbl t2-handle)] - [subt (lambda (handle1 handle2) - (set-set trace (cons t1-handle t2-handle)) - ; (subt sba-state hashcons-tbl handle1 handle2 delta-flow (cons (cons t1-handle t2-handle) trace))) - (let ([v (subt sba-state hashcons-tbl handle1 handle2 delta-flow trace)]) - (set-remove trace (cons t1-handle t2-handle)) - v))] - [get-list-of-handle - (lambda (handle) - (let* ([fake-type-var (make-type-var (gensym) #f #f)] - [type (make-type-rec (list fake-type-var) - (list (make-type-union (list (make-type-cst '()) - (make-type-cons handle fake-type-var)))) - fake-type-var)]) - (hc:hashcons-type hashcons-tbl type)))]) - (if (hash-table-get memo-table (cons t1-handle t2-handle) cst:thunk-false) - (hash-table-get memo-table (cons t1-handle t2-handle) cst:thunk-false) - (let ([subtype-value - (or - ; basic cases - (or (= t1-handle t2-handle) - (and (type-cst? t2) (eq? (type-cst-type t2) 'top)) - ;(and (type-cst? t1) (eq? (type-cst-type t1) 'bottom)) - (type-empty? t1) ; bottom - (set-in? trace (cons t1-handle t2-handle))) - ; constants - (and (type-cst? t1) (type-cst? t2) - (let* ([t1 (type-cst-type t1)] - [t2 (type-cst-type t2)] - [t2-entry (hash-table-get subtyping-table t2 cst:thunk-false)]) - (if t2-entry - ; t2 is a symbolic type (like number) - (if (or (memq t1 (car t2-entry)) ; for symbolic t1: real <= number - ((cdr t2-entry) t1)) ; for scheme t1: 3 <= number - #t #f) - ; t2 is an immediate type (like 5), and we already know t1 is not bottom - ; so t1 and t2 have to be equal - (eq? t1 t2)))) - ; cons - (and (type-cons? t1) (type-cons? t2) - (subt (type-cons-car t1) (type-cons-car t2)) - (subt (type-cons-cdr t1) (type-cons-cdr t2))) - ; vector - (and (type-vector? t1) (type-vector? t2) - (subt (type-vector-element t1) (type-vector-element t2))) - ; case-lambda - (and (type-case-lambda? t1) (type-case-lambda? t2) - (util:ormap4-vector - (lambda (t1-rest-arg? t1-req-arg t1-args t1-exp) - (if t1-rest-arg? - (util:andmap4-vector - (lambda (t2-rest-arg? t2-req-arg t2-args t2-exp) - (if t2-rest-arg? - ; both t1 and t2 have rest args - (or (and (< t1-req-arg t2-req-arg) - (subt t1-exp t2-exp) - ; contravariant - (util:andmap2-vector-interval subt t2-args t1-args 0 t1-req-arg) - (let ([t1-rest-arg (vector-ref t1-args t1-req-arg)]) - (and - (util:andmap-vector-interval - (lambda (t2-arg) - ; contravariant - (subt (get-list-of-handle t2-arg) t1-rest-arg)) - t2-args t1-req-arg t2-req-arg) - (subt (vector-ref t2-args t2-req-arg) ; t2-rest-arg - t1-rest-arg)))) - (and (= t1-req-arg t2-req-arg) - (subt t1-exp t2-exp) - ; contravariant - (util:andmap2-vector subt t2-args t1-args)) - (and (> t1-req-arg t2-req-arg) - (subt t1-exp t2-exp) - ; contravariant - (util:andmap2-vector-interval subt t2-args t1-args 0 t2-req-arg) - (let ([t2-rest-arg (vector-ref t2-args t2-req-arg)]) - (and - (util:andmap-vector-interval - (lambda (t1-arg) - (subt t2-rest-arg (get-list-of-handle t1-arg))) - t1-args t2-req-arg t1-req-arg) - (subt t2-rest-arg - (vector-ref t1-args t1-req-arg) ; t1-rest-arg - ))))) - ;; t1 has rest-args, t2 has NO rest-args - (and (<= t1-req-arg t2-req-arg) - (subt t1-exp t2-exp) - ; t1 has a rest arg, t2 has a fixed number of args - ; so we need to check all the required args, and - ; check the rest arg specially, since the rest arg - ; of t1 is automatically wrapped inside a list. - ; contravariant - (util:andmap2-vector-interval subt t2-args t1-args 0 t1-req-arg) - ; contravariant - (subt (hc:hashcons-type hashcons-tbl - (list:foldr make-type-cons - (make-type-cst '()) - (util:interval->list t2-args t1-req-arg - (vector-length t2-args)))) - (vector-ref t1-args t1-req-arg) ; rest arg - )))) - (type-case-lambda-rest-arg?s t2) - (type-case-lambda-req-args t2) - (type-case-lambda-argss t2) - (type-case-lambda-exps t2)) - ; t1 has no rest-args - (util:andmap4-vector - (lambda (t2-rest-arg? t2-req-arg t2-args t2-exp) - (if t2-rest-arg? - (and (>= t1-req-arg t2-req-arg) - (subt t1-exp t2-exp) - ; t1 has a fixed number of args, t2 has a rest arg - ; so we need to check all the required args, and - ; check the rest arg specially, since the rest arg - ; of t2 is automatically wrapped inside a list. - ; contravariant - (util:andmap2-vector-interval subt t2-args t1-args 0 t2-req-arg) - ; contravariant - (let ([t2-rest-arg (vector-ref t2-args t2-req-arg)]) - (util:andmap-vector-interval - (lambda (t1-arg) - (subt t2-rest-arg (get-list-of-handle t1-arg))) - t1-args t2-req-arg (vector-length t1-args)))) - ; t1 and t2 have a fixed number of args - (and (= t1-req-arg t2-req-arg) - (subt t1-exp t2-exp) - ; contravariant - (util:andmap2-vector subt t2-args t1-args)))) - (type-case-lambda-rest-arg?s t2) - (type-case-lambda-req-args t2) - (type-case-lambda-argss t2) - (type-case-lambda-exps t2)))) - (type-case-lambda-rest-arg?s t1) - (type-case-lambda-req-args t1) - (type-case-lambda-argss t1) - (type-case-lambda-exps t1))) - ; the order of the following two rules matters, because, for - ; example: (union 1 2) is a subtype of (union 1 2 3), but is - ; not a subtype of either 1, 2 or 3. On the other hand both 1 - ; and 2 are subtypes of (union 1 2 3), so if both t1 and t2 - ; are unions, we have to split t1 first. - (and (type-union? t1) - (andmap (lambda (t1-elt) (subt t1-elt t2-handle)) (type-union-elements t1))) - (and (type-union? t2) - (ormap (lambda (t2-elt) (subt t1-handle t2-elt)) (type-union-elements t2))) - ; multiple values - (and (type-values? t1) (type-values? t2) - (subt (type-values-type t1) (type-values-type t2))) - (and (type-promise? t1) (type-promise? t2) - (subt (type-promise-value t1) (type-promise-value t2))) - (and (type-struct-type? t1) (type-struct-type? t2) - ; can't use strutural equivalence here because of genericity - (or (eq? (type-struct-type-type-label t1) (type-struct-type-type-label t2)) - (let ([t1-parent-label (label-struct-type-parent - (type-struct-type-type-label t1))]) - (if t1-parent-label - (subt (get-type-from-label sba-state t1-parent-label) - t2-handle) - #f)))) - (and (type-struct-value? t1) (type-struct-type? t2) - (subt (get-type-from-label sba-state (type-struct-value-type-label t1)) - t2-handle)) - (and (type-flow-var? t2) - (let ([label&type (lookup-flow-var-in-env delta-flow t2)]) - (subt t1 (hc:hashcons-type hashcons-tbl (cdr label&type))))) - ;; Subt works on previously hashcons values, - ;; i.e. all cycles are implicit in the table - (and (or (type-flow-var? t1) (type-flow-var? t2) - (type-var? t1) (type-var? t2) - (type-rec? t1) (type-rec? t2) - (type-scheme? t1) (type-scheme? t2)) - (error 'subt "Unexpected non-hashconsed types: ~a ~a" t1 t2)))]) - (hash-table-put! memo-table (cons t1-handle t2-handle) subtype-value) - subtype-value)))))) - - ; called when t2 is a (flow var free) type instead of a handle - (define/contract subtype-type - (sba-state? handle? hc:hashcons-type? any/c boolean? (or/c false/c label?) . -> . boolean?) - (lambda (sba-state t1-handle t2 delta-flow error? label) - (subtype sba-state t1-handle - (hc:hashcons-type (sba-state-hashcons-tbl sba-state) t2) - delta-flow error? label))) - - (define/contract subtype - (sba-state? handle? handle? any/c boolean? (or/c false/c label?) . -> . boolean?) - (lambda (sba-state t1-handle t2-handle delta-flow error? label) - (if (subt sba-state (sba-state-hashcons-tbl sba-state) t1-handle t2-handle delta-flow (set-make 'equal)) - #t - (begin - (when error? - (set-error-for-label sba-state - label - 'red - (format "~a not a subtype of ~a" - (pp-type sba-state t1-handle 'subtype) - (pp-type sba-state t2-handle delta-flow)))) - #f)))) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; GUI INTERFACE - - ; sba-state -> symbol - (define (create-type-var-name sba-state) - (let ([new-counter (sba-state-type-var-counter sba-state)]) - (set-sba-state-type-var-counter! sba-state (add1 new-counter)) - (string->symbol (string-append "a" (number->string new-counter))))) - - ; label -> positive-int - ; returns start location of term associated with label - (define (get-mzscheme-position-from-label label) - (syntax-position (label-term label))) - - ; label -> boolean - (define (is-label-atom? label) - (let ([stx-l (syntax-e (label-term label))]) - (or (not (pair? stx-l)) ; identifier - (let ([term-type (syntax-e (car stx-l))]) - (or (eq? term-type '#%datum) - (eq? term-type '#%top) - (eq? term-type 'quote)))))) - - ; label -> (or/c number #f) - (define (get-span-from-label label) - (syntax-span (label-term label))) - - ; sba-state label (or/c 'red 'green 'orange) string -> void - (define (set-error-for-label sba-state label gravity message) - (err:error-table-set (sba-state-errors sba-state) - (list label) - gravity - message)) - - ; sba-state label -> (listof sba-error) - ; extracts error messages. - (define (get-errors-from-label sba-state label) - (err:error-table-get (sba-state-errors sba-state) label)) - - ; label -> exact-non-negative-integer - (define (get-source-from-label label) - (syntax-source (label-term label))) - - ; label sba-state -> void - (define (add-type-var-to-label label sba-state) - (unless (label-type-var label) - (set-label-type-var! label (make-type-var (create-type-var-name sba-state) #f #f)))) - - ; label set -> void - ; if the reachable set has already been computed, re-use it, otherwise compute it - ; (unless we detected a cycle). - (define (reachL label set) - (if (and (label-type-var label) - (type-var-reach (label-type-var label))) - (set-union set (type-var-reach (label-type-var label)) 'first) - (unless (set-in? set label) - (set-set set label) - (reachU label set)))) - - ; label set -> void - ; a label for a value constructor has itself in its own value set, so reachL above might - ; already have put that label in set, but a simple label does not appear in its own set - ; so we still have to add the content of its set to set. Hence the #f below. - (define (reachU label set) - (hash-table-for-each (label-set label) - (lambda (value-label arrows) - (set-set set value-label #f) - (reachT value-label set)))) - ; label set -> void - (define (reachT label set) - (cond - ;[(label-cst? label) cst:void] - [(label-cons? label) (begin (reachL (label-cons-car label) set) - (reachL (label-cons-cdr label) set))] - [(label-vector? label) (reachL (label-vector-element label) set)] - [(label-promise? label) (reachL (label-promise-value label) set)] - [(label-values? label) (reachL (label-values-label label) set)] - [(label-case-lambda? label) (for-each (lambda (args-labels exp-label) - (for-each (lambda (l) (reachL l set)) args-labels) - (reachL exp-label set)) - (label-case-lambda-argss label) - (label-case-lambda-exps label))] - [(label-struct-value? label) (begin (reachL (label-struct-value-type label) set) - (for-each (lambda (l) (reachL l set)) (label-struct-value-fields label)))] - ;[(label-struct-type? label) cst:void] - ;[else cst:void] - )) - - ; label sba-state -> (set-of label) - ; reachable lables from a given label - ; we know the label has a type var because add-type-var-to-label has been called - ; already in get-type-from-label. - ; Note that this is the only place where we set the type-var-reach, so if reachL above - ; find a set, we know that set already contains everything we need. - (define (reachable-labels-from-label label) - (let ([set (type-var-reach (label-type-var label))]) - (if set - set - (let ([set (set-make)]) - (reachL label set) - (set-type-var-reach! (label-type-var label) set) - set)))) - - ; label -> (or/c type-var handle) - ; the label better have a type-var... - (define (get-handle-or-type-var label) - (let* ([type-var (label-type-var label)] - [handle (type-var-handle type-var)]) - (if handle - ;(begin (printf ".") - handle - ;) - type-var))) - - ; label (listof labels) -> type-rec - (define (typeL label reachable-labels) - (make-type-rec (map label-type-var reachable-labels) - (map typeU reachable-labels) - (get-handle-or-type-var label))) - - ; label -> type-union - ; label-set should move from a hash-table to an assoc-set, then we can use - ; assoc-set-cardinality instead of going through the list twice. - (define (typeU label) - (let* ([union-content (hash-table-map (label-set label) (lambda (label arrows) (typeT label)))] - [union-length (length union-content)]) - (cond - [(= union-length 0) (make-type-empty)] - [(= union-length 1) (car union-content)] - [else (make-type-union union-content)]))) - - ; label -> type - (define (typeT label) - (cond - [(label-cst? label) (make-type-cst (label-cst-value label))] - [(label-cons? label) (make-type-cons (get-handle-or-type-var (label-cons-car label)) - (get-handle-or-type-var (label-cons-cdr label)))] - [(label-vector? label) (make-type-vector (get-handle-or-type-var (label-vector-element label)))] - [(label-promise? label) (make-type-promise (get-handle-or-type-var (label-promise-value label)))] - [(label-values? label) (make-type-values (get-handle-or-type-var (label-values-label label)))] - [(label-case-lambda? label) (make-type-case-lambda (label-case-lambda-rest-arg?s label) - (label-case-lambda-req-args label) - (map (lambda (args) - (map get-handle-or-type-var args)) - (label-case-lambda-argss label)) - (map get-handle-or-type-var (label-case-lambda-exps label)))] - [(label-struct-value? label) (make-type-struct-value (label-struct-value-type label) - (map get-handle-or-type-var (label-struct-value-fields label)))] - [(label-struct-type? label) (make-type-struct-type label)] - [else (error 'typeT "unknown label: ~a" label)])) - - ; sba-state label -> type - ; computes type for label, computes the corresponding handle, and memoize it - (define (get-type-from-label sba-state label) - (add-type-var-to-label label sba-state) - (or (type-var-handle (label-type-var label)) - (let* (;[_ (begin (print-struct #t)(printf "T: ~a ~a ~a " (type-var-name (label-type-var label)) - ; (syntax-position (label-term label)) - ; (syntax-object->datum (label-term label))))] - ;[start (current-milliseconds)] - [reachable-labels (set-map (reachable-labels-from-label label) - (lambda (l) (add-type-var-to-label l sba-state) l))] - ;[_ (begin (print-struct #t)(printf "R: ~a~n" (map (lambda (l) (type-var-name (label-type-var l))) reachable-labels)))] - ;[_ (printf "~a " (- (current-milliseconds) start))] - ;[start (current-milliseconds)] - [reconstructed-type (typeL label reachable-labels)] - ;[_ (begin (print-struct #t)(printf "T: ~a~n" (ppp-type reconstructed-type 'blah)))] - ;[_ (printf " ~a~n" (- (current-milliseconds) start))] - ;[start (current-milliseconds)] - [handle (hc:hashcons-type (sba-state-hashcons-tbl sba-state) reconstructed-type)] - ;[_ (printf "HC-Time= ~a~n" (- (current-milliseconds) start))] - ) - ; XXX memoization - (set-type-var-handle! (label-type-var label) handle) - handle))) - - ; type (or/c (hash-table-of type-flow-var (cons label type)) symbol) -> string - ; type pretty printer - ; delta-flow is the flow variable environment, or a symbol if no flow environment - ; was available at the time of the call. - (define (pp-type sba-state type delta-flow) - (let ([pretty-string (hc:handle->string (sba-state-hashcons-tbl sba-state) type - (lambda (h1 h2) - (subtype sba-state h1 h2 #f #f #f))) - ]) - ;(printf "H: ~a~nP: ~a~n~n" type foo) - pretty-string)) - - ; (require (prefix string: mzlib/string)) - ; (define (ppp-type type delta-flow) - ; (cond - ; [(type-empty? type) "_"] - ; [(type-cst? type) - ; ; can be a complex sexp if (quote sexp) is in the input - ; (string:expr->string (type-cst-type type))] - ; ; (let ([val (type-cst-type type)]) - ; ; (cond - ; ; [(number? val) (number->string val)] - ; ; [(symbol? val) (symbol->string val)] - ; ; [(string? val) (string-append "\"" val "\"")] - ; ; [(void? val) "void"] - ; ; [else (error 'ppp-type "unknown datum: ~a" val)]))] - ; [(type-cons? type) - ; (string-append "(cons " - ; (ppp-type (type-cons-car type) delta-flow) " " - ; (ppp-type (type-cons-cdr type) delta-flow) ")")] - ; [(type-vector? type) - ; (string-append "(vector " (ppp-type (type-vector-element type) delta-flow) ")")] - ; [(type-promise? type) - ; (string-append "(promise " - ; ; skipping the thunk inside the promise (we know it's always a - ; ; thunk because delay is a macro...) Note that the promise might - ; ; be empty, for now, so we have to test that... - ; (let ([promise-value-type (type-promise-value type)]) - ; (if (type-case-lambda? promise-value-type) - ; (ppp-type (car (type-case-lambda-exps promise-value-type)) delta-flow) - ; (ppp-type promise-value-type delta-flow))) - ; ")")] - ; [(type-case-lambda? type) - ; (string-append - ; "(case-lambda " - ; (list:foldr - ; (lambda (rest-arg? formal-args-types body-exp-type str) - ; (string-append - ; "[" - ; (list:foldr - ; (lambda (formal-arg-type str) - ; (string-append - ; (ppp-type formal-arg-type delta-flow) - ; " " - ; str)) - ; "" - ; formal-args-types) - ; (if rest-arg? - ; "*-> " - ; "-> ") - ; (ppp-type body-exp-type delta-flow) - ; "]" - ; ;(if (string=? str "") - ; ; "" - ; ; " ") - ; str)) - ; "" - ; (type-case-lambda-rest-arg?s type) - ; (type-case-lambda-argss type) - ; (type-case-lambda-exps type)) - ; ")")] - ; [(type-var? type) - ; (symbol->string (type-var-name type))] - ; [(type-flow-var? type) - ; (error 'ppp-type "flow var: ~a~n" (type-flow-var-name type)) - ; (ppp-type (cdr (lookup-flow-var-in-env delta-flow type)) delta-flow)] - ; [(type-union? type) - ; (string-append - ; "(union " - ; (list:foldr - ; (lambda (union-element str) - ; (string-append - ; (ppp-type union-element delta-flow) - ; (if (string=? str ")") - ; "" - ; " ") - ; str)) - ; ")" - ; (type-union-elements type)))] - ; [(type-values? type) - ; (let ([values-type (type-values-type type)]) - ; (cond - ; [(type-empty? values-type) - ; (ppp-type values-type delta-flow)] - ; [(and (type-cst? values-type) (eq? (type-cst-type values-type) 'top)) - ; (ppp-type values-type delta-flow)] - ; [else - ; (let* ([values-types-list (type-list-map cst:id (type-values-type type))] - ; [values-types-list-length (length values-types-list)]) - ; (cond - ; [(zero? values-types-list-length) - ; (ppp-type (make-type-empty) delta-flow)] - ; [(= values-types-list-length 1) - ; (ppp-type (car values-types-list) delta-flow)] - ; [else (string-append - ; "(values " - ; (list:foldr - ; (lambda (type str) - ; (string-append (ppp-type type delta-flow) - ; (if (string=? str ")") - ; "" - ; " ") - ; str)) - ; ")" - ; values-types-list))]))]))] - ; [(type-rec? type) - ; (string-append - ; "(rec-type (" - ; (list:foldr - ; (lambda (var type str) - ; (string-append - ; "[" - ; (symbol->string (type-var-name var)) - ; " " - ; ; poor man's type beautifier - ; (if (and (type-union? type) - ; (= (length (type-union-elements type)) 2) - ; (or (and (type-cst? (car (type-union-elements type))) - ; (null? (type-cst-type (car (type-union-elements type)))) - ; (type-cons? (cadr (type-union-elements type))) - ; (type-var? (type-cons-cdr (cadr (type-union-elements type)))) - ; (eq? (type-var-name (type-cons-cdr (cadr (type-union-elements type)))) - ; (type-var-name var))) - ; (and (type-cst? (cadr (type-union-elements type))) - ; (null? (type-cst-type (cadr (type-union-elements type)))) - ; (type-cons? (car (type-union-elements type))) - ; (type-var? (type-cons-cdr (car (type-union-elements type)))) - ; (eq? (type-var-name (type-cons-cdr (car (type-union-elements type)))) - ; (type-var-name var))))) - ; (string-append - ; "(listof " - ; (ppp-type (if (type-cst? (car (type-union-elements type))) - ; (type-cons-car (cadr (type-union-elements type))) - ; (type-cons-car (car (type-union-elements type)))) - ; delta-flow) - ; ")") - ; (ppp-type type delta-flow)) - ; (if (string=? str ") ") - ; "]" - ; "] ") - ; str)) - ; ") " - ; (type-rec-vars type) - ; (type-rec-types type)) - ; (ppp-type (type-rec-body type) delta-flow) - ; ")")] - ; [(type-struct-value? type) - ; (string-append - ; "#(struct:" - ; (symbol->string (label-struct-type-name (type-struct-value-type-label type))) - ; " " - ; (list:foldr - ; (lambda (elt-type str) - ; (string-append - ; (ppp-type elt-type delta-flow) - ; (if (string=? str ")") - ; "" - ; " ") - ; str)) - ; ")" - ; (type-struct-value-types type)))] - ; [(type-struct-type? type) - ; (string-append - ; "#string (label-struct-type-name (type-struct-type-type-label type))) - ; ">")] - ; [else (error 'ppp-type "unknown type: ~a" type)])) - - - ; label (listof label) -> (listof label) - ; returns list of labels from which labels in label's set went in - ; the trace is necessary to prevent the search for original parents to loop forever when - ; inside recursive code generated by a macro. Despite that the search might still use - ; exponential time when only using the trace because it explores all possibles paths at - ; all possible labels when exploring the graph recursively. The running time is tremendously - ; helped by adding the memoization: we compute the result set for a given label only once - ; and always reuse that result in the future without ever searching the piece of graph - ; behind the label again. - ; Note: could probably be made even faster if the trace was a set and we kept it around - ; until the final result is computed, so as not to re-explore pieces of graphs we have - ; just seen but are reaching through another path. Should be good enough for noe since - ; we memoize the final result anyway. - (define (get-parents-from-label label trace) - (if (label-parents label) - (label-parents label) - (if (memq label trace) - '() - (let ([result (set-make)]) - (for-each - (lambda (unfiltered-parents-for-current-set-element) - (let* ([direct-parents-without-primitive-labels - (list:filter (lambda (label) - (not (label-prim? label))) - unfiltered-parents-for-current-set-element)] - [direct-or-indirect-original-parents - (list:foldr - (lambda (direct-parent original-parents-so-far) - (if (gui-registerable? direct-parent) - (cons direct-parent original-parents-so-far) - (merge-lists (get-parents-from-label direct-parent (cons label trace)) - original-parents-so-far))) - '() - direct-parents-without-primitive-labels)]) - (for-each (lambda (parent) - (set-set result parent #f)) - direct-or-indirect-original-parents))) - (hash-table-map (label-set label) - (lambda (label arrows) - (arrows-in arrows)))) - (let ([final-result (set-map result cst:id)]) - (set-label-parents! label final-result) - final-result))))) - - ; label (listof label) -> (listof label) - ; should be abstracted with the above... - ; differences are arrows-in vs arrows-out and - ; label-parents/set-label-parents! vs label-children/set-label-children! - (define (get-children-from-label label trace) - (if (label-children label) - (label-children label) - (if (memq label trace) - '() - (let ([result (set-make)]) - (for-each - (lambda (unfiltered-children-for-current-set-element) - (let* ([direct-children-without-primitive-labels - (list:filter (lambda (label) - (not (label-prim? label))) - unfiltered-children-for-current-set-element)] - [direct-or-indirect-original-children - (list:foldr - (lambda (direct-child original-children-so-far) - (if (gui-registerable? direct-child) - (cons direct-child original-children-so-far) - (merge-lists (get-children-from-label direct-child (cons label trace)) - original-children-so-far))) - '() - direct-children-without-primitive-labels)]) - (for-each (lambda (child) - (set-set result child #f)) - direct-or-indirect-original-children))) - (hash-table-map (label-set label) - (lambda (label arrows) - (arrows-out arrows)))) - (let ([final-result (set-map result cst:id)]) - (set-label-children! label final-result) - final-result))))) - - - ; (listof label) -> (listof (list label label string)) - ; not really fast but good enough for now. - ; XXX should combine this with the above get-parents/children - (define (get-arrows-from-labels labels) - (delete-duplicates - (append! (apply append! (map (lambda (label) - (map (lambda (parent) - (list parent label "blue")) - (list:filter (lambda (parent) - (not (memq parent labels))) - (get-parents-from-label label '())))) - labels)) - (apply append! (map (lambda (label) - (map (lambda (child) - (list label child "blue")) - (list:filter (lambda (child) - (not (memq child labels))) - (get-children-from-label label '())))) - labels))))) - - ; (listof (cons top (cons top (listof top)))) -> (listof (cons top (cons top (listof top)))) - (define (delete-duplicates l) - (if (null? l) - l - (let ([elt (car l)]) - (cons elt - (delete-duplicates - (let ([elt-s (car elt)] - [elt-e (cadr elt)]) - (list:filter (lambda (other-elt) - (or (not (eq? elt-s (car other-elt))) - (not (eq? elt-e (cadr other-elt))))) - (cdr l)))))))) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; DRIVER - - ; ; port value -> void - ; (define (sba-driver port source) - ; (let ([start (current-milliseconds)]) - ; (read-and-analyze port source) - ; (check-primitive-types) - ; (printf "time: ~a ms~n" (- (current-milliseconds) start))) - ; ) - ; - ; ; port value -> void - ; ; read and analyze, one syntax object at a time - ; (define (read-and-analyze port source) - ; (let ([stx-obj (read-syntax source port)]) - ; ;(unless (eof-object? stx-obj) - ; ; (begin (printf "sba-driver in: ~a~n" (syntax-object->datum stx-obj)) - ; ; (printf "sba-driver analyzed: ~a~n~n" (syntax-object->datum (expand stx-obj))) - ; ; (printf "sba-driver out: ~a~n~n" (create-label-from-term sba-state (expand stx-obj) '() #f))) - ; ; (read-and-analyze port source)))) - ; (if (eof-object? stx-obj) - ; '() - ; (cons (create-label-from-term sba-state (expand stx-obj) '() #f) - ; (read-and-analyze port source))))) - ; - ; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; PERFORMANCE TEST - ; - ; ; (: test-i (nothing -> void)) - ; ; parse expression interactively - ; (define (test-i) - ; (sba-driver (current-input-port) 'interactive)) - ; - ; ; (: test-f (string -> (listof Ast))) - ; (define (test-f filename) - ; (let ([port (open-input-file filename)]) - ; (sba-driver port filename) - ; (close-input-port port))) - ; - ; (let* ([path (build-path (collection-path "mrflow") "tests")] - ; [files (list:filter (lambda (file) - ; (and (> (string-length file) 3) - ; (string=? "test-real" - ; (substring file 0 9)) - ; (string=? "test-realbig" - ; (substring file 0 12)))) - ; (list:sort (directory-list path) string<=?) - ; )] - ; ) - ; (initialize-primitive-type-schemes XXX) - ; (for-each (lambda (file) - ; (printf "~a: " file) - ; (test-f (build-path path file)) - ; ; (test-f file) - ; ) - ; files)) - - (define/contract subst-vals/flow-vars (type? any/c . -> . type?) - (lambda (type delta-flow) - (let subst ([type type]) - (match type - [(? handle? type) type] - [($ type-case-lambda rest-arg?s req-args argss exps) - (let* ([argss ((if (list? argss) util:map2deep util:for-each-vov!) subst argss)] - [exps ((if (list? exps) map util:for-each-vector!) subst exps)]) - (make-type-case-lambda rest-arg?s req-args argss exps))] - [($ type-cons hd tl) - (make-type-cons (subst hd) (subst tl))] - [($ type-cst ty) type] - [($ type-empty) type] - [($ type-promise value) - (make-type-promise (subst value))] - [($ type-rec vars types body) - (make-type-rec vars (map subst types) (subst body))] - [($ type-struct-type label) type] - [($ type-struct-value label types) - (make-type-struct-value label (map subst types))] - [($ type-union elements) - (make-type-union (map subst elements))] - [($ type-values type) - (make-type-values (subst type))] - [($ type-var name reach handle) type] - [($ type-vector element) - (make-type-vector (subst element))] - [($ type-flow-var name) (cdr (lookup-flow-var-in-env delta-flow type))] - [_ (error 'subst-vals/flow-vars "Unmatched type ~a" type)])))) - - ) ; end module constraints-gen-and-prop diff --git a/collects/mrflow/dfa.ss b/collects/mrflow/dfa.ss deleted file mode 100644 index 73e8d9ca09..0000000000 --- a/collects/mrflow/dfa.ss +++ /dev/null @@ -1,1024 +0,0 @@ -(module dfa (lib "mrflow.ss" "mrflow") - (require mzlib/match - mzlib/pretty - mzlib/etc - (prefix list: mzlib/list) - (prefix cst: "constants.ss") - - "set-hash.ss" - "types.ss" - "util.ss" - "env.ss" - - mzlib/class) - - (provide - (struct dfa (stnum->state)) - - (struct state (number)) - - ;; All base types i.e. type-cst, type-empty, struct-type-states are always handle states - (struct handle-state (handle)) - (struct cons-state (car cdr)) - (struct case-lambda-state (rest-arg?s req-args argss exps)) - (struct promise-state (value)) - (struct struct-value-state (label types)) - (struct union-state (elements)) - (struct values-state (type)) - (struct vector-state (element)) - - state-number? - dfa-state->list - dfa->list - - greatest-handle - get-ordered-states - get-state-numbers - get-states - get-dfa-size - - create-dfa-from-type - minimize-dfa - - ;; debug - all-handles-referenced? - ) - - ;; - ;; States - ;; - (define state-number? natural?) - - (define-struct state (number) (make-inspector)) - - ;; All base types i.e. type-cst, type-empty, struct-type-states are always handle states - (define-struct (handle-state state) (handle) (make-inspector)) - (define-struct (cons-state state) (car cdr) (make-inspector)) - ; case-lambda-states has vectors for all fields, in contrast union-states and - ; struct-value-states both use lists. - (define-struct (case-lambda-state state) - (rest-arg?s ; (vectorof boolean) - req-args ; (vectorof natural) - argss ; (vectorof (vectorof any)) - exps) ; (vectorof any) - (make-inspector)) - (define-struct (promise-state state) (value) (make-inspector)) - (define-struct (struct-value-state state) (label types) (make-inspector)) - (define-struct (union-state state) (elements) (make-inspector)) - (define-struct (values-state state) (type) (make-inspector)) - (define-struct (vector-state state) (element) (make-inspector)) - - ;; - ;; DFAs - ;; - (define-struct dfa (stnum->state canonical-ordering)) - (set! make-dfa - (let ([old-make-dfa make-dfa]) - (opt-lambda ([ordering #f]) (old-make-dfa (make-hash-table) ordering)))) - - (define/contract make-ordered-dfa ((listof state?) . -> . dfa?) - (lambda (states) - (let* ([dfa (make-dfa)] - [stnum->state (dfa-stnum->state dfa)] - [ordered-stnums (map (lambda (state) - (let ([stnum (state-number state)]) - (hash-table-put! stnum->state stnum state) - stnum)) - states)]) - (set-dfa-canonical-ordering! dfa ordered-stnums) - dfa))) - - (define/contract get-dfa-size (dfa? . -> . natural?) - (lambda (dfa) - (let ([size 0]) - (hash-table-for-each (dfa-stnum->state dfa) (lambda (stnum state) (set! size (add1 size)))) - size))) - - (define/contract has-state-number? (dfa? state-number? . -> . boolean?) - (lambda (dfa state-number) - (if (hash-table-get (dfa-stnum->state dfa) state-number cst:thunk-false) #t #f))) - - (define/contract maybe-add-state! (dfa? state? . -> . void?) - (lambda (dfa state) - (let ([stnum->state (dfa-stnum->state dfa)] - [stnum (state-number state)]) - (unless (hash-table-has-key? stnum->state stnum) - (hash-table-put! stnum->state stnum state))))) - - (define/contract lookup (dfa? state-number? . -> . state?) - (lambda (dfa state-number) - (hash-table-get (dfa-stnum->state dfa) state-number))) - - (define/contract greatest-handle (dfa? . -> . (or/c false/c handle?)) - (lambda (dfa) - (let ([greatest-handle -1]) - (hash-table-for-each (dfa-stnum->state dfa) - (lambda (stnum state) - (when (and (handle-state? state) (> (handle-state-handle state) greatest-handle)) - (set! greatest-handle (handle-state-handle state))))) - (if (= greatest-handle -1) #f greatest-handle)))) - - (define/contract get-ordered-states (dfa? . -> . (listof state?)) - (lambda (dfa) - (map (lambda (stnum) (lookup dfa stnum)) (dfa-canonical-ordering dfa)))) - - (define/contract get-states (dfa? . -> . (listof state?)) - (lambda (dfa) - (hash-table-map (dfa-stnum->state dfa) (lambda (stnum state) state)))) - - (define/contract get-state-numbers (dfa? . -> . (listof state-number?)) - (lambda (dfa) - (hash-table-map (dfa-stnum->state dfa) (lambda (stnum state) stnum)))) - - ;; When this function is called all of the label types in present - ;; must belong to a strongly connected graph. This works by first - ;; annotating all label types with a state number, variables and - ;; base types are not given a state number. Then the graph is - ;; traversed again with a type environment. When a rec-type is - ;; encountered the variable/state bindings are added to the type - ;; environment. When a variable is encountered its state looked up. - ;; Labeled states are created w/ the states of their children and - ;; added to the DFA. - ;; - ;; tenv : tvar -> handle ... if have a handle it may not have a state in the dfa - ;; senv : tvar -> state - (define/contract create-dfa-from-type - ((type-rec? tenv?) . ->d* . - (lambda (type tenv) - (unless (type-var? (type-rec-body type)) - (error 'create-dfa-from-type - "type-rec should have type-var for body")) - (for-each (lambda (type) - (when (type-var? type) - (error 'create-dfa-from-type "DFA has variable on right side of binder")) - (when (and (type-union? type) (andmap type-var? (type-union-elements type))) - (error 'create-dfa-from-type "DFA has union with only variables on right side of binder"))) - (type-rec-types type)) - (values dfa? (listof state-number?)))) - (lambda (type var->handle) - (let* ([dfa (make-dfa)] - [annotations (make-hash-table 'equal)] - [add-annotation! - (let ([ann -1]) - (lambda (type) - (set! ann (add1 ann)) - (hash-table-put! annotations type ann)))] - [add-state! (lambda (state) - (maybe-add-state! dfa state) - (state-number state))] - [get-annotation - (lambda (type) (hash-table-get annotations type))] - [maybe-get-annotation - (lambda (type) (hash-table-get annotations type cst:thunk-false))]) - (letrec ([annotate - (lambda (type) - (unless (maybe-get-annotation type) - (cond - [(handle? type) - (add-annotation! type)] - [(type-cons? type) - (annotate (type-cons-car type)) - (annotate (type-cons-cdr type)) - (add-annotation! type)] - [(type-case-lambda? type) - (for-each-vov (lambda (ty) (annotate ty)) (type-case-lambda-argss type)) - (for-each-vector (lambda (ty) (annotate ty)) (type-case-lambda-exps type)) - (add-annotation! type)] - [(type-promise? type) - (annotate (type-promise-value type)) - (add-annotation! type)] - [(type-rec? type) - (for-each (lambda (var ty) - (or (maybe-lookup-symbol var->handle (type-var-name var)) (annotate ty))) - (type-rec-vars type) (type-rec-types type)) - (annotate (type-rec-body type))] - [(type-struct-value? type) - (for-each annotate (type-struct-value-types type)) - (add-annotation! type)] - [(type-union? type) - (for-each annotate (type-union-elements type)) - (add-annotation! type)] - [(type-var? type) - (let ([handle (maybe-lookup-symbol var->handle (type-var-name type))]) - (when handle - (add-annotation! type)))] - [(type-values? type) - (annotate (type-values-type type)) - (add-annotation! type)] - [(type-vector? type) - (annotate (type-vector-element type)) - (add-annotation! type)] - [else - (error 'create-dfa-from-type "Type ~a should already have been hashconsed" type)])))] - [create-dfa - (lambda (type var->state) - (cond - [(handle? type) - (add-state! (make-handle-state (get-annotation type) type))] - [(type-cons? type) - (let* ([hd (create-dfa (type-cons-car type) var->state)] - [tl (create-dfa (type-cons-cdr type) var->state)] - [state (make-cons-state (get-annotation type) hd tl)]) - (add-state! state))] - [(type-case-lambda? type) ; rest-arg?s req-args argss exps) - (let* ([argss (map-vector-of-vector (lambda (type) (create-dfa type var->state)) (type-case-lambda-argss type))] - [exps (map-vector (lambda (type) (create-dfa type var->state)) (type-case-lambda-exps type))] - [state-number (get-annotation type)] - [state (make-case-lambda-state state-number - (type-case-lambda-rest-arg?s type) - (type-case-lambda-req-args type) - argss exps)]) - (add-state! state) - state-number)] - [(type-promise? type) - (let* ([value (create-dfa (type-promise-value type) var->state)] - [state-number (get-annotation type)]) - (add-state! (make-promise-state state-number value)))] - [(type-rec? type) ; vars types body) - (let* ([vars (type-rec-vars type)] - [types (type-rec-types type)] - [body (type-rec-body type)] - [binder-states (map (lambda (v ty) - (or (maybe-get-annotation v) - (get-annotation ty))) - vars types)] - [new-env (extend-tenv var->state (map type-var-name vars) binder-states)]) - (for-each (lambda (var type) - (if (maybe-get-annotation var) - (create-dfa var new-env) - (create-dfa type new-env))) - vars types) - binder-states)] - [(type-struct-value? type) - (let ([types (map (lambda (ty) (create-dfa ty var->state)) (type-struct-value-types type))] - [label (type-struct-value-type-label type)]) - (add-state! (make-struct-value-state (get-annotation type) label types)))] - [(type-union? type) - (let* ([elements (map (lambda (ty) (create-dfa ty var->state)) (type-union-elements type))]) - (add-state! (make-union-state (get-annotation type) (min-list-numbers elements))))] - [(type-vector? type) - (let ([element (create-dfa (type-vector-element type) var->state)]) - (add-state! (make-vector-state (get-annotation type) element)))] - [(type-var? type) - (let ([state-number (maybe-get-annotation type)] - [name (type-var-name type)]) - (if state-number - (add-state! (make-handle-state state-number (lookup-symbol var->state name))) - (lookup-symbol var->state name)))] - [(type-values? type) - (let ([ty (create-dfa (type-values-type type) var->state)]) - (add-state! (make-values-state (get-annotation type) ty)))] - [else - (error 'create-dfa-from-type "Type ~a should already have been hashconsed" type)]))]) - (annotate type) - (values dfa (create-dfa type (create-tenv))))))) - - ;; - ;; Printing functions - ;; - - (define/contract dfa-state-number->list (opt-> (state-number?) (dfa?) list?) - (opt-lambda (stnum [dfa #f]) - (dfa-state->list (lookup dfa stnum) dfa))) - - (define/contract dfa-state->list (opt-> (state?) (dfa?) list?) - (opt-lambda (dfa-state [dfa #f]) - (letrec - ([state->var (make-hash-table)] - [state->binding (make-hash-table)] - [get-next-var! (let ([i 0]) (lambda (state) - (let ([str (string->symbol (format "a~a" i))]) - (set! i (add1 i)) - (hash-table-put! state->var state str) - str)))] - [statify - (lambda (sym state) ;((or/c symbol? list?) state-number? . -> . (or/c symbol? list?)) - (let* ([first (if (list? sym) (car sym) sym)] - [first (string->symbol - (string-append (symbol->string first) ":" (number->string state)))]) - (if (list? sym) (cons-immutable first (cdr sym)) first)))] - [to-list - (lambda (dfa-state ancest) ;(state? (listof state-number?) . -> . list?) - (letrec ([expand - (if dfa - (lambda (x) (loop x ancest)) - (lambda (x) x))]) - (match dfa-state - [($ handle-state state handle) - (list 'handle handle)] - [($ cons-state state car cdr) - (list 'cons (expand car) (expand cdr))] - [($ case-lambda-state state rest-arg?s req-args argss exps) - (list 'case-lambda - (foldr-case-lambda-vector - (lambda (rest-arg? req-arg args exp acc) - (cons (list (map expand (vector->list args)) - (if rest-arg? '*-> '->) - (expand exp)) - acc)) - null - rest-arg?s req-args argss exps))] - [($ promise-state state value) - (list 'promise (expand value))] - [($ struct-value-state state label types) - (list 'struct (map expand types))] - [($ union-state state elements) - (cons 'union (map expand elements))] - [($ values-state state type) - (list 'values (expand type))] - [($ vector-state state type) - (list 'vector (expand type))] - [x (error 'dfa-state->string "Unmatched type ~a\n" x)])))] - [loop (lambda (stnum ancest) - (if (memq stnum ancest) - (if (hash-table-has-key? state->var stnum) - (hash-table-get state->var stnum) - (get-next-var! stnum)) - (let* ([state (lookup dfa stnum)] - [l (to-list state (cons stnum ancest))]) - (if (hash-table-has-key? state->var stnum) - (begin - (hash-table-put! state->binding stnum (statify l stnum)) - (hash-table-get state->var stnum)) - (statify l stnum)))))]) - (if dfa (let ([rec-body (loop (state-number dfa-state) null)] - [var-bindings - (hash-table-map state->var (lambda (s v) - (list v (hash-table-get state->binding s))))]) - (if (null? var-bindings) rec-body - (list (statify 'rec-state (state-number dfa-state)) - var-bindings - rec-body))) - (statify (to-list dfa-state null) (state-number dfa-state)))))) - - - (define/contract dfa->list (dfa? . -> . any) - (lambda (dfa) - (list - (list:sort (hash-table-map (dfa-stnum->state dfa) (lambda (k v) (list k '-> (dfa-state->list v dfa)))) - (lambda (x y) (> (car x) (car y)))) - (dfa-canonical-ordering dfa) - ))) - - (define print-dfa - (lambda (dfa) - (pretty-display (dfa->list dfa)))) - - ;; - ;; Minimization - ;; - - ;; Should equiv-class and block should be merged - (define-struct equiv-class (type number length classes) (make-inspector)) - - ;; A non-empty list of dfa-states, representing an equivalence class - (define block? (listof state?)) - - ;; A list of disjoint blocks - (define partition? (listof block?)) - - (define make-state->equiv-class - (lambda (num-states) - (make-vector num-states #f))) - - ;; Used only for debugging, make each handle state in the dfa is - ;; referenced by a label state - (define all-handles-referenced? - (lambda (dfa) - (letrec - ([tbl (make-hash-table)] - [seen (make-hash-table)] - [loop - (lambda (stnum) - (unless (hash-table-get seen stnum cst:thunk-false) - (hash-table-put! seen stnum #t) - (match (lookup dfa stnum) - [($ handle-state state handle) - (hash-table-put! tbl handle #t)] - [($ cons-state state car cdr) - (loop car) (loop cdr)] - [($ case-lambda-state state rest-arg?s req-args argss exps) - (for-each-vov loop argss) - (for-each-vector loop exps)] - [($ promise-state state value) - (loop value)] - [($ struct-value-state state label types) - (for-each loop types)] - [($ union-state state elements) - (for-each loop elements)] - [($ values-state state type) - (loop type)] - [($ vector-state state type) - (loop type)])))] - [state (car (list:filter (lambda (x) (not (handle-state? x))) (get-ordered-states dfa)))] - [handle-states (list:filter handle-state? (get-ordered-states dfa))]) - (loop (state-number state)) - (andmap (lambda (hs) (hash-table-get tbl (handle-state-handle hs) cst:thunk-false)) handle-states)))) - - ; Minimize DFA sets up the partition table and the gross equivalence - ; classes for hopcrofts algorithm, as well as replacing the states - ; numbers with their equivalence classes after minimization. - (define/contract minimize-dfa ((dfa? (listof state-number?)) . ->* . - (dfa? (listof state-number?))) - (lambda (dfa original-states) - (let* ([highest-equiv-class (new counter%)] - [get-matching-states - (let ([states (get-states dfa)]) - (lambda (pred) - (list:filter pred states)))] - [state-numbers (get-state-numbers dfa)] - [stnum->ecnum (make-stnum->ecnum% (apply max state-numbers))] - [partitions (make-partitions% (get-dfa-size dfa))] - - [add-minimum-dfa-state! - (let ([min '()]) - (lambda (state) - (when (member state min) - (error 'add-minimum-dfa-state! "Should never add the same state ~a to minimal DFA" state)) - (set! min (cons-immutable state min))))] - - [make-minimized-state - (match-lambda - [($ handle-state state handle) - (make-handle-state (send stnum->ecnum lookup state) handle)] - [($ case-lambda-state state rest-arg?s req-args argss exps) - (make-case-lambda-state (send stnum->ecnum lookup state) - rest-arg?s req-args - (for-each-vov! (lambda (arg) (send stnum->ecnum lookup arg)) argss) - (for-each-vector! (lambda (exp) (send stnum->ecnum lookup exp)) exps))] - [($ cons-state state car cdr) - (make-cons-state (send stnum->ecnum lookup state) - (send stnum->ecnum lookup car) - (send stnum->ecnum lookup cdr))] - [($ promise-state state value) - (make-promise-state (send stnum->ecnum lookup state) - (send stnum->ecnum lookup value))] - [($ struct-value-state state label types) - (make-struct-value-state (send stnum->ecnum lookup state) - label - (map (lambda (ty) (send stnum->ecnum lookup ty)) types))] - [($ union-state state elements) - (make-union-state (send stnum->ecnum lookup state) - (min-list-numbers (map (lambda (el) - (send stnum->ecnum lookup el)) - elements)))] - [($ values-state state type) - (make-values-state (send stnum->ecnum lookup state) - (send stnum->ecnum lookup type))] - [($ vector-state state element) - (make-vector-state (send stnum->ecnum lookup state) - (send stnum->ecnum lookup element))] - [x (error 'make-minimized-state "Unmatched type ~a" x)])] - [case-lambda-partition - (split-case-lambda-states (get-matching-states case-lambda-state?))] - [struct-value-partition - (split-struct-value-states (get-matching-states struct-value-state?))] - [union-partition - (split-union-states (get-matching-states union-state?))] - [handle-partition - (map list (list:sort (get-matching-states handle-state?) - (lambda (x y) (< (handle-state-handle x) (handle-state-handle y)))))] - [setup-equiv-class - (lambda (type) - (lambda(states) - (if (null? states) #f - (let* ([equiv-class-number (send highest-equiv-class next!)] - [equiv-class (make-equiv-class type equiv-class-number (length states) states)]) - (send partitions place-new-equiv-class equiv-class) - (send stnum->ecnum set-states! equiv-class states) - equiv-class-number))))] - - [handle-partition-numbers (map (setup-equiv-class 'handle) handle-partition)] - [cl-partition-numbers (map (setup-equiv-class 'case-lambda) case-lambda-partition)] - [struct-value-numbers (map (setup-equiv-class 'struct-value) struct-value-partition)] - [union-numbers (map (setup-equiv-class 'union) union-partition)] - - [cons-number ((setup-equiv-class 'cons) (get-matching-states cons-state?))] - [promise-number ((setup-equiv-class 'promise) (get-matching-states promise-state?))] - [values-number ((setup-equiv-class 'values) (get-matching-states values-state?))] - [vector-number ((setup-equiv-class 'vector) (get-matching-states vector-state?))]) - ;; There is no position ordering on the elements of a union so we - ;; impose one on the equivalence classes of the elements - (for-each (lambda (block) - (for-each (lambda (state) - (set-union-state-elements! - state - (list:sort (union-state-elements state) - (lambda (a b) - (> (send stnum->ecnum lookup a) - (send stnum->ecnum lookup b)))))) - block)) - union-partition) - (hopcroft state-numbers - (list:filter cst:id - (append handle-partition-numbers cl-partition-numbers struct-value-numbers union-numbers - (list cons-number promise-number values-number vector-number))) - partitions stnum->ecnum highest-equiv-class) - (let* ([_ ; (void) - ;; ensure unions with only one state when minimized are not added to the dfa - (send partitions for-each - (lambda (partition) - (when (and partition (eq? (equiv-class-type partition) 'union)) - (let* ([block (equiv-class-classes partition)] - [representative (car block)] - [elements (union-state-elements representative)] - [min-stnums (min-list-numbers (map (lambda (stnum) - (send stnum->ecnum lookup stnum)) - elements))]) - (when (length-one? min-stnums) - (for-each (lambda (state) - (send stnum->ecnum set! - (send partitions get-equiv-class (car min-stnums)) - state)) - block))))))] - - [states (send partitions fold - (lambda (p acc) - (let ([min-state (make-minimized-state (car (equiv-class-classes p)))]) - (if (and (union-state? min-state) (length-one? (union-state-elements min-state))) - acc - (cons-immutable min-state acc)))) - null)] - [min-binder-states - (map (lambda (stnum) (send stnum->ecnum lookup stnum)) original-states)] - [min-dfa (make-ordered-dfa states)] - [has-useless-union (ormap (lambda (state) (and (union-state? state) - (length-one? (union-state-elements state)))) - states)]) - (if has-useless-union - (minimize-dfa min-dfa min-binder-states) - (values min-dfa min-binder-states))) - ))) - - (define stnum->ecnum% - (class object% - (init-field highest-state) - - (define stnum->ecnum (make-vector (add1 highest-state) #f)) - - (define/public lookup - (lambda (stnum) - (vector-ref stnum->ecnum stnum))) - - (define/public set! - (lambda (equiv-class state) - (vector-set! stnum->ecnum - (if (state? state) - (state-number state) state) - (equiv-class-number equiv-class)))) - - (define/public set-states! - (lambda (equiv-class states) - (for-each (lambda (state) - (vector-set! stnum->ecnum - (state-number state) - (equiv-class-number equiv-class))) - states))) - - (super-new))) - - (define make-stnum->ecnum% - (lambda (k) - (let () - (define/contract stnum->ecnum - (object-contract (lookup (natural? . -> . natural?)) - (set! (equiv-class? (union state? natural?) . -> . void?)) - (set-states! (equiv-class? (listof state?) . -> . void?))) - (new stnum->ecnum% (highest-state k))) - stnum->ecnum))) - - (define partitions% - (class object% - (init-field number-states) - - ; Each element of the partitions table contains either an equivalence class, - ; or false if it has not been used or the equivalence class it contains has - ; been split. - ; - ; We split at most num-states - 1 times, but we never reuse the - ; states in an old partition so allocate twice the number of states. - (define partitions (make-vector (* 2 number-states) #f)) - - (define/public place-new-equiv-class - (lambda (eq-class) - (vector-set! partitions (equiv-class-number eq-class) eq-class))) - - (define/public split - (lambda (k) - (vector-set! partitions k #f))) - - (define/public get-equiv-class - (lambda (i) (vector-ref partitions i))) - - (define/public fold - (lambda (f init) - (foldr-vector (lambda (x acc) - (if x (f x acc) acc)) - init partitions))) - - (define/public for-each - (lambda (f) - (send this fold (lambda (x acc) (f x)) (void)))) - - (super-new) - )) - - (define make-partitions% - (lambda (k) - (let () - (define/contract p - (object-contract (place-new-equiv-class (equiv-class? . -> . any)) - (split (natural? . -> . void?)) - (get-equiv-class (natural? . -> . equiv-class?)) - (fold ((equiv-class? any/c . -> . any) any/c . -> . any)) - (for-each ((equiv-class? . -> . any) . -> . any))) - (new partitions% (number-states k))) - p))) - - - - ; Hopcrofts DFA minimization algorithm. First generate letters for each - ; partition individually as the have different types and shapes. Next while - ; there are still letters which may split an equivalence class, try to split - ; each equivalence class by the letter. Most times the split will fail, but if - ; it succeeds then replace the old equivalence class with the new split - ; equivalence classes. The letter/equiv class pairs will need to be changed - ; to point to the new equivalence classes - (define/contract hopcroft - ((listof natural?) (listof natural?) (is-a?/c partitions%) (is-a?/c stnum->ecnum%) (is-a?/c counter%) . -> . any) - (lambda (states - partition-nums - partitions - state->equiv-class - get-next-equiv-class) - (if (null? partition-nums) (void) - (let* ([l (set-make 'equal)] - [largest-number-cl-exps -1] - [largest-number-cl-args -1] - [largest-number-union-elements -1] - [largest-number-struct-value-types -1] - [_ (send partitions for-each - (lambda (ec) - (cond [(eq? 'case-lambda (equiv-class-type ec)) - (let* ([cl (car (equiv-class-classes ec))] - [argss (case-lambda-state-argss cl)] - [exps (case-lambda-state-exps cl)]) - (when (> (vector-length exps) largest-number-cl-exps) - (set! largest-number-cl-exps (vector-length exps))) - (when (> (foldr-vector (lambda (c acc) (max (vector-length c) acc)) -1 argss) - largest-number-cl-args) - (set! largest-number-cl-args (vector-length exps))))] - [(eq? 'union (equiv-class-type ec)) - (let* ([union (car (equiv-class-classes ec))] - [len (length (union-state-elements union))]) - (when (> len largest-number-union-elements) - (set! largest-number-union-elements len)))] - [(eq? 'struct-value (equiv-class-type ec)) - (let* ([struct-value (car (equiv-class-classes ec))] - [len (length (struct-value-state-types struct-value))]) - (when (> len largest-number-struct-value-types) - (set! largest-number-struct-value-types len)))])))] - [letters - (let* ([letters - (list:foldr - (lambda (equiv-class-num letters) - (let* ([equiv-class (send partitions get-equiv-class equiv-class-num)] - [state (car (equiv-class-classes equiv-class))]) - (cond [(cons-state? state) - (cons '(cons car) (cons '(cons cdr) letters))] - [(promise-state? state) - (cons '(promise) letters)] - [(values-state? state) - (cons '(values) letters)] - [(vector-state? state) - (cons '(vector) letters)] - [else - letters]))) - '() partition-nums)] - [letters ;; add letters for case-lambda - (if (= largest-number-cl-args -1) letters - (let ([w-argss - (list:foldr (lambda (row acc) - (coalesce-lists (list:foldr (lambda (col acc) - (cons (list 'case-lambda 'argss row col) acc)) - '() - (iota largest-number-cl-args)) - acc)) - letters - (iota largest-number-cl-exps))]) - (coalesce-lists - (map (lambda (row) (list 'case-lambda 'exps row)) (iota largest-number-cl-exps)) - w-argss)))] - [letters ;; add letters for unions - (if (= largest-number-union-elements -1) letters - ;(unfold-onto (lambda (x) (= x largest-number-union-elements)) - ; (lambda (i) (list 'union i)) - ; add1 - ; 0 - (cons '(union) letters))]) - (if (= largest-number-struct-value-types -1) letters - (coalesce-lists - (map (lambda (i) (list 'struct-value i)) (iota largest-number-struct-value-types)) - letters)))] - ; This is a cheesy way to remove a random element from the set. XXX ? - [get-next! (lambda () - (let ([eq&letter (let/ec return (set-for-each l (lambda (elem) (return elem))) #f)]) - (when eq&letter - (set-remove l eq&letter)) - eq&letter))] - [add-to-L! - (lambda (eq letter) - (set-set l (cons eq letter)))] - [print-L - (lambda () - (printf "(L=") (set-for-each l display)(printf ")"))] - [remove! (lambda (eq-class-num letter) - (set-remove l (cons eq-class-num letter)))] - [number-states (length states)] - [eq&letter-present? (lambda (eq-class-num letter) - (set-in? l (cons eq-class-num letter)))]) - (for-each (lambda (eq&letter) - (set-set l eq&letter)) - (cross2 partition-nums letters)) - (let while-letters ([eq&letter (get-next!)] [partition-nums partition-nums]) - (when eq&letter - (let* ([q1 (car eq&letter)] - [a (cdr eq&letter)] - [number-partitions 0] - [new-partition-nums '()] - [add-equiv-class (lambda (ec) - (begin - (set! new-partition-nums (cons ec new-partition-nums)) - (set! number-partitions (add1 number-partitions))))]) - (for-each - (lambda (q0) - (let-values ([(equiv-class-a equiv-class-b) - (split q0 q1 a partitions state->equiv-class get-next-equiv-class)]) - (if equiv-class-a ;; when the split is successful - (begin - (add-equiv-class equiv-class-b) - (add-equiv-class equiv-class-a) - (for-each (lambda (b) - (if (eq&letter-present? q0 b) - (begin - (remove! q0 b) - (add-to-L! equiv-class-a b) - (add-to-L! equiv-class-b b)) - (begin - (add-to-L! - (if (< (equiv-class-length (send partitions get-equiv-class equiv-class-a)) - (equiv-class-length (send partitions get-equiv-class equiv-class-b))) - equiv-class-a - equiv-class-b) - b)))) - letters)) - (add-equiv-class q0)))) - partition-nums) - (when (< number-partitions number-states) - (while-letters (get-next!) new-partition-nums))))))))) - - ;; - ;; Utility functions - ;; - - (define cross2 - (lambda (xs ys) - (list:foldl (lambda (x xacc) - (list:foldl (lambda (y yacc) (cons-immutable (cons-immutable x y) yacc)) xacc ys)) - null xs))) - - (define coalesce-lists - (lambda xs - (letrec ([reverse-onto - (lambda (xs ys) - (if (null? xs) ys - (reverse-onto (cdr xs) (cons (car xs) ys))))]) - (if (null? xs) '() - (list:foldl reverse-onto (car xs) (cdr xs)))))) - - - ;; - ;; Equivalence class utilities - ;; - - (define/contract set-equiv-class-of-state-number! - ((vectorof (or/c false/c natural?)) equiv-class? state-number? . -> . void?) - (lambda (classes equiv-class stnum) - (vector-set! classes stnum (equiv-class-number equiv-class)))) - - ;; A function extracting some value from a dfa-state. Discriminators - ;; are used when comparing two states - (define discriminator? (state? . -> . (or/c integer? boolean?))) - - (define/contract block->partition (block? . -> . partition?) - list-immutable) - - ; split q0 into 2 equivalence classes, those which transitions to q1 from - ; letter b and those which don't transition to q1 - ; - ; The 'letter' b depends on the type of partiton we're splitting. A letter - ; consists of a place within the type E.g. A type-cons letter has a 'position' - ; indicator of 'car or 'cdr to distinguish which position in a partition of - ; type-cons we're going to split by. - (define/contract split - (natural? natural? list? (is-a?/c partitions%) (is-a?/c stnum->ecnum%) (is-a?/c counter%) . -> . any) - (lambda (q0-num q1-num b partitions stnum->ecnum highest-equiv-class) - (let* ([q0 (send partitions get-equiv-class q0-num)] - [type1 (equiv-class-type q0)] - [transition-on-letter - (lambda (q0 b) - (cond - [(eq? b 'handle) #f] - [(and (eq? (car b) 'case-lambda) - (eq? (cadr b) 'exps)) - (let ([row (caddr b)]) - (and (case-lambda-state? q0) - (< row (vector-length (case-lambda-state-exps q0))) - (send stnum->ecnum lookup - (vector-ref (case-lambda-state-exps q0) row))))] - [(and (eq? (car b) 'case-lambda) (eq? (cadr b) 'argss)) - (let ([row (caddr b)] - [col (cadddr b)]) - (and (case-lambda-state? q0) - (let ([argss (case-lambda-state-argss q0)]) - (and (< row (vector-length argss)) - (< col (vector-length (vector-ref argss row))) - (send stnum->ecnum lookup - (vector-ref (vector-ref argss row) col))))))] - [(eq? 'cons (car b)) - (let ([pos (cadr b)]) - (and (cons-state? q0) - (send stnum->ecnum lookup - ((if (eq? pos 'car) cons-state-car cons-state-cdr) q0))))] - [(eq? 'promise (car b)) - (and (promise-state? q0) - (send stnum->ecnum lookup (promise-state-value q0)))] - [(eq? 'struct-value (car b)) - (let ([pos (cadr b)]) - (and (struct-value-state? q0) - (< (length (struct-value-state-types q0)) pos) - (send stnum->ecnum lookup (list-ref (struct-value-state-types q0) pos))))] - [(eq? 'union (car b)) - (error 'transition-on-letter "Should have already handled union case")] - [(eq? 'values (car b)) - (and (type-values? q0) - (send stnum->ecnum lookup (type-values-type q0)))] - [(eq? 'vector (car b)) - (and (type-vector? q0) - (send stnum->ecnum lookup (type-vector-element q0)))]))] - [any-union-element-transitions-to - (lambda (q0 q1-num) - (and (union-state? q0) - (ormap (lambda (x) - (= (send stnum->ecnum lookup x) q1-num)) - (union-state-elements q0))))]) - ; this always makes a new list, even if not splittable. probably - ; faster to switch to new list midway through - (if (eq? (equiv-class-type q0) (car b)) - (let loop ([q0 (equiv-class-classes q0)] - [to-q1 '()] [to-q1-length 0] - [not-to-q1 '()] [not-to-q1-length 0]) - (cond [(null? q0) - (if (and (not (null? to-q1)) (not (null? not-to-q1))) - (let* ([to-q1-num (send highest-equiv-class next!)] - [to-q1 (make-equiv-class type1 to-q1-num to-q1-length to-q1)] - [not-to-q1-num (send highest-equiv-class next!)] - [not-to-q1 (make-equiv-class type1 not-to-q1-num - not-to-q1-length not-to-q1)]) - (send partitions place-new-equiv-class to-q1) - (send partitions place-new-equiv-class not-to-q1) - (send stnum->ecnum set-states! to-q1 (equiv-class-classes to-q1)) - (send stnum->ecnum set-states! not-to-q1 (equiv-class-classes not-to-q1)) - (send partitions split q0-num) - (values to-q1-num not-to-q1-num)) - (values #f #f))] - [(eq? 'union (car b)) - (if (any-union-element-transitions-to (car q0) q1-num) - (loop (cdr q0) (cons (car q0) to-q1) (add1 to-q1-length) not-to-q1 not-to-q1-length) - (loop (cdr q0) to-q1 to-q1-length (cons (car q0) not-to-q1) (add1 not-to-q1-length)))] - [(eq? (transition-on-letter (car q0) b) q1-num) - (loop (cdr q0) (cons (car q0) to-q1) (add1 to-q1-length) not-to-q1 not-to-q1-length)] - ;; q0 does not transition on b - [else - (loop (cdr q0) to-q1 to-q1-length (cons (car q0) not-to-q1) (add1 not-to-q1-length))])) - (values #f #f))))) - - ;; To split a block of dfa-states, use the value projected from a - ;; dfa-state as a hashtable-key which is associated with the list of - ;; dfa-states with identical values - (define/contract split-set (discriminator? block? . -> . partition?) - (lambda (f xs) - (if (length-one? xs) (block->partition xs) - (let ([accs (make-hash-table)]) - (for-each (lambda (x) (hash-table-prepend! accs (f x) x)) xs) - (let ([keys (hash-table-map accs (lambda (k v) k))]) - (if (null? keys) '() - (let* ([gt (cond [(boolean? (car keys)) - (lambda (a b) (cond [(eq? a b) #f] [a #f] [b #t]))] - [(integer? (car keys)) >] - [else (error 'split-set "Unknown type ~a" (car keys))])] - [keys (list:sort keys gt)]) - (map (lambda (k) (hash-table-get accs k)) keys)))))))) - - ;; list list list -> list list - (define unnest - (lambda (xsss) ;; there is probably a better way of doing this, but its not a big time hit - (let loop ([xsss xsss] [acc '()]) - (if (null? xsss) acc (loop (cdr xsss) (append acc (car xsss))))))) - - ; Split each a partition by a block splitter - (define/contract split-partition-by - ((block? . -> . partition?) partition? . -> . partition?) - (lambda (partition-block partition) - (unnest (map (lambda (block) (partition-block block)) partition)))) - - ; Split each a partition by a discriminator - (define/contract split-partition (discriminator? partition? . -> . partition?) - (lambda (f xss) - (unnest (map (lambda (xs) (split-set f xs)) xss)))) - - ; Split a block by the values - (define/contract split-by-vector-values - ((state? . -> . vector?) (integer? . -> . discriminator?) . -> . (block? . -> . partition?)) - (lambda (list-accessor discriminator) - (lambda (block) - (list:foldr (lambda (i xss) (split-partition (discriminator i) xss)) - (block->partition block) ; initial partition - (iota (vector-length (list-accessor (car block)))))))) ; split for each member in the list - - (define/contract split-by-vector-vector-values - ((state? . -> . (vectorof vector?)) - (state? . -> . vector?) - (integer? integer? . -> . discriminator?) - . -> . (block? . -> . partition?)) - (lambda (vector-accessor vector-vector-accessor discriminator) - (lambda (type-list) - (list:foldr (lambda (row acc) - (list:foldr (lambda (col acc2) - (split-partition (discriminator row col) acc2)) - acc - (iota (vector-length (vector-vector-accessor (car type-list)))))) - (list type-list) - (iota (vector-length (vector-accessor (car type-list)))))))) - - ;; Split a block of unions into a paritions with each union in a - ;; block has the same number of elements. - (define/contract split-union-states ((listof union-state?) . -> . (listof (listof union-state?))) - (lambda (unions) - (let* ([number-elements-discriminator - (lambda (union) (length (type-union-elements union)))]) - ;; TBD Spliting by number of elements in a union cannot possibly be right - ;(split-set number-elements-discriminator unions)))) - (list unions)))) - - (define/contract split-struct-value-states ((listof struct-value-state?) . -> . (listof (listof struct-value-state?))) - (lambda (structs) - (let ([number-elements-discriminator - (lambda (struct) (length (type-struct-value-types struct)))]) - ; a total ordering must be imposed on labels - (split-partition (lambda (sv) (eq-hash-code (type-struct-value-type-label sv))) - (split-set number-elements-discriminator structs))))) - - ;; Split a block of case-lambda-states into a partition with each - ;; block having the same number of expressions, each parameter list - ;; having the same length, each rest and req arg lists have the same - ;; length and values. - (define/contract split-case-lambda-states - ((listof case-lambda-state?) . -> . (listof (listof case-lambda-state?))) - (lambda (cls) - (letrec - ([get-number-args - ;(lambda (i) (lambda (cl) (vector-length (vector-ref (type-case-lambda-argss cl) i))))] - (lambda (i) (lambda (cl) (vector-length (vector-ref (case-lambda-state-argss cl) i))))] - [get-number-exps - ;(lambda (cl) (vector-length (type-case-lambda-exps cl)))] - (lambda (cl) (vector-length (case-lambda-state-exps cl)))] - [get-rest-arg - ;(lambda (i) (lambda (cl) (vector-ref (type-case-lambda-rest-arg?s cl) i)))] - (lambda (i) (lambda (cl) (vector-ref (case-lambda-state-rest-arg?s cl) i)))] - [get-req-arg - ;(lambda (i) (lambda (cl) (vector-ref (type-case-lambda-req-args cl) i)))] - (lambda (i) (lambda (cl) (vector-ref (case-lambda-state-req-args cl) i)))] - [req-arg-gt (lambda (xs ys) - (cond [(and (null? xs) (null? ys)) #f] - [(= (car xs) (car ys)) (req-arg-gt (cdr xs) (cdr ys))] - [(> (car xs) (car ys)) #t] - [(< (car xs) (car ys)) #f] - [else (error 'lex "Differing lengths")]))] - [rest-arg-gt (lambda (xs ys) - (cond [(and (null? xs) (null? ys)) #f] - [(= (car xs) (car ys)) (rest-arg-gt (cdr xs) (cdr ys))] - [(car xs) #t] - [else #f]))]) - (split-partition-by - (split-by-vector-values case-lambda-state-req-args get-req-arg) - (split-partition-by - (split-by-vector-values case-lambda-state-rest-arg?s get-rest-arg) - (split-partition-by - (split-by-vector-values ; block -> partition - case-lambda-state-argss ; (any/c . -> . list?) ; case-lambda -> args - get-number-args) ; (integer? . -> . (any/c . -> . any)) - (split-set get-number-exps cls)))) ))) - - ) - diff --git a/collects/mrflow/doc.txt b/collects/mrflow/doc.txt deleted file mode 100644 index 0ff0c79e4c..0000000000 --- a/collects/mrflow/doc.txt +++ /dev/null @@ -1,325 +0,0 @@ - -[index entries: _snip_ _arrow_ _label_ ] - -_snips_ and _arrows_ library -============================ - -Collection: mrflow -Files: snips-and-arrows.ss snips-and-arrows-view.ss snips-and-arrows-model.ss - -This library allows a programmer to display information about terms in -a DrScheme text editor and its embedded sub-editors. Textual -information about a given term can be displayed using snips inserted -in the editor next to the term. Each snip is colored according to a -programmer specified type. Several snips can exist for a given term -and type. A relation between two terms can be displayed by drawing an -arrow between the two terms. Each arrow is colored using a programmer -specified color. Arrows do not carry any textual information with -them. - -The library is fundamentally based on terms. It is not possible to -display snips or arrows that are not directly related to terms. -However the library does not require terms to be represented by -MzScheme syntax objects. Terms can be represented by any user-defined -data structure, called hereafter _labels_. A label represents exactly -one term and the library user is responsible for keeping track of -which term is represented by a given label (by, say, keeping a -reference to the syntax object in the label's data structure), but a -term in an editor can be represented by one or more labels and the -user doesn't have to keep track of that. This asymmetry between terms -and labels is necessary because macro expansions might duplicate some -terms. - -With each label can be associated a number of snips containing textual -information. Each snip has a user-defined type that determines the -color of the snip. A label can have several snips for a given type, -and snips of different types associated with it. Mouse menus are -available to show or hide all snips of a given type for all labels -corresponding to a given term. The snips are inserted on the left of -the corresponding term, in an order that is determined by the user -(see the snip-types-and-colors argument of the -init-snips-and-arrows-gui function below for details). - -The library defines two mixins that augment the text editors with -various methods, and two functions that are used to initialize the -library. Both functions return one function to register labels with -the library and one function to change terms in the editors. A term -in an editor will be recognized and colored by the library only if at -least one of its corresponding labels has been registered with the -library. - -All terms corresponding to registered labels must, either directly or -indirectly through embedded sub-editors, be contained in a single -editor called hereafter the top editor. In the case of the DrScheme -definitions window and its embedded sub-editors (if any), the top -editor will be the definitions window itself. - - -Usage -===== - -(require (lib "snips-and-arrows.ss" "mrflow")) - -This will import two mixins: - -extend-all-editors-mixin and -extend-top-editor-mixin - -and two functions: - -init-snips-and-arrows-gui and -init-snips-and-arrows-gui-for-syntax-objects - -See the example at the end of this document for a quick how-to. - - -All text% classes that will be used to create editors that will -contain, either directly or indirectly through embedded editors, terms -to be colored by the library, must be extended using the -_extend-all-editors-mixin_ mixin. In the case of the DrScheme -definitions window and its embedded sub-editors (if any) this is -simply done by giving this mixin as argument to the -drscheme:unit:add-to-program-editor-mixin function during phase1 of -DrScheme. - -The text% class that will be used to create the top editor that will -contain, either directly or indirectly through embedded sub-editors, -all the terms to be colored must be extended using the -_extend-top-editor-mixin_ mixin. This must be done even if all the -terms to be colored are contained in embedded sub-editors and the top -editor doesn't itself directly contain any terms to be colored. The -mixin extends that text% class with two methods of no arguments: -- _color-registered-labels_, to be called once all labels have been - registered (see below) in order to color the corresponding terms, to - start the automatic display of arrows as well as to make the snips - and arrows related mouse menus available to the user. -- _remove-all-snips-and-arrows-and-colors_, to be called to terminate - the automatic display of arrows, make the snips and arrows related - mouse menus unavailable to the user, remove all inserted snips, and - optionally clear all colors (see below the last argument to - init-snips-and-arrows-gui and the last optional argument to - init-snips-and-arrows-gui-for-syntax-objects for details about this - last point). -In the case of the DrScheme definitions window, using this mixin is -simply done by giving it as argument to the -drscheme:get/extend:extend-definitions-text function. - - -The init-snips-and-arrows-gui and -init-snips-and-arrows-gui-for-syntax-objects functions are used to -initialize the library. Exactly one of them must be called before -trying to use the library. The -init-snips-and-arrows-gui-for-syntax-objects function is a simplified -version of init-snips-and-arrows-gui. - -The _init-snips-and-arrows-gui_ function has eleven arguments in the -following order (with a mnemonic name and a type between parenthesis): -1) the top editor (top-editor: text%), the editor that, either - directly or indirectly through embedded sub-editors, contains all - terms that are to be colored by the library. -2) a function from label to editor (get-editor-from-label: label -> - text%) returning the editor that directly contains the term - corresponding to the label. This function must return the same - editor for all the labels corresponding to a given term. -3) a function from label to term position - (get-mzscheme-position-from-label: label -> - non-negative-exact-integer) returning the MzScheme position of the - term corresponding to the label in the editor that directly - contains it (the editor that would be returned by the - get-editor-from-label function described just above). This - function must return the same position for all the labels - corresponding to a given term. -4) a function from label to term color span (get-span-from-label: - label -> non-negative-exact-integer) indicating the number of - characters of the term corresponding to the label that should be - colored. Coloring of a term starts with the leftmost character of - the term and continues towards the right for that number of - characters. This applies to all terms for which at least one - label has been registered with the library, regardless of whether - they are atomic or not, so care must be exercised when computing - the span for a term containing sub-terms that also have to be - colored. Arrows starting or ending at a given term will be - anchored at half the span of the term, so again care must be taken - when specifying the span of non-atomic terms. This function must - return the same span for all labels corresponding to a given term. -5) a function from label to a list of arrows data - (get-arrows-from-label: label -> (listof (list label label - string))) indicating what arrows should be drawn when the mouse - pointer is placed over the term corresponding to the label. Each - sublist in the list represents one arrow, and must contain, in - that order, a label corresponding to the starting term for the - arrow, a label corresponding to the ending term for the arrow, and - a string representing the arrow color (see color-database<%> in - the help-desk for a list of color names). -6) a function from label to style delta (get-style-delta-from-label: - label -> style-delta%) indicating how the term corresponding to - the label should be colored. This function must return the same - style delta for all the labels corresponding to a given term. -7) a function from popup menu and a list of labels to void - (extend-menu-for-labels: popup-menu% (listof label) -> void) that - can be used to add menu-item% objects to the menu that pops up - when the user clicks with the right mouse button on a term. All - the labels in the list correspond to that term (there might be - several labels in the list because of macro expansions). The - callbacks for the added menu items must not directly modify the - content of any editor that directly contains colored terms but - must instead use a function like the first one returned by the - call to init-snips-and-arrows-gui (see below for details). -8) a function from snip type (see snip-types-and-colors below) and - action symbol to string (get-menu-text-from-snip-type: symbol - symbol -> string) that takes as input a snip type represented as a - symbol as well as one of the two symbols 'show or 'hide - representing a user command and returns a string that will be used - as the text for the menu entry that will allow the user to perform - said command for the snips of that given type. -9) a function from snip type and label to a list of strings - (get-snip-text-from-snip-type-and-label: symbol label -> (listof - string)) that returns the content of all the snips of the given - type that will be inserted next to the term corresponding to the - label when the user uses the snip-related mouse menu entries - described just above. -10) a list of snip types and colors (snip-types-and-colors: (listof - (cons symbol string))) that describes all possible types of snips - and their associated color. Each sub-list in the list must - contain two elements: a snip type name represented as a symbol, - and a corresponding snip color (see color-database<%> in the - help-desk for a list of color names). For a given term, snips of - different types will be inserted from left to right on the left of - the corresponding term in the order in which their types appear in - this list. -11) a boolean (clear-colors-immediately?: (union #t #f)) that - indicates whether, once the user starts modifying the content of - the editors, the terms colored by the library should be uncolored - immediately or should be uncolored only the next time a DrScheme - tool is run or the program executed. -The init-snips-and-arrows-gui then returns two values: a function to -change terms and a function to register a label. The function to -change terms has type ((listof (cons label string)) -> void). Each -pair in the function's argument consists of a label representing a -term to be changed and a string that will be used to replace that -term. It is only necessary to give one label per term to be changed. -It is an error to give two pairs with labels representing the same -term but with different strings. The function to register a label has -type (label -> void) and is used to indicate to the library that the -corresponding term has to be colored. The same label can safely be -registered several times. Unspeakable things involving nasty crawling -bugs will happen to you, and your descendants will be cursed to the -seventh generation if you dare to call this function after having -already called the color-registered-labels method described above. - -The init-snips-and-arrows-gui-for-syntax-objects function is a -simplified (yes, really) version of init-snips-and-arrows-gui that -assumes labels are in fact MzScheme syntax objects, and also provides -default values for all the menu and snip related functions that simply -assume that no snips are used at all. Also, the terms represented by -the syntax objects are assumed to be atomic, meaning they will be -colored in whole and arrows will be anchored at half the terms' spans. -Seemingly unanchored arrows and overlapping colors may result if you -try to use this function with non-atomic terms (i.e. terms containing -sub-terms). The function has only three required arguments, and five -optional arguments. The three required arguments are, in that order, -using the mnemonic names from the description of -init-snips-and-arrows-gui above, and with updated types in -parenthesis: -- top-editor (text%) -- get-arrows-from-label (syntax-object -> (listof (list syntax-object - syntax-object string))) -- get-style-delta-from-label (syntax-object -> style-delta%) -The five optional arguments are as follows, in that order, with their -default value in brackets: -- extend-menu-for-labels (popup-menu% (listof syntax-object) -> void) - [(lambda (m l) (void)))] -- get-menu-text-from-snip-type (symbol symbol -> string) [internal - error function] -- get-snip-text-from-snip-type-and-label (symbol syntax-object -> - (listof string)) [internal error function] -- snip-types-and-colors (listof (cons symbol string)) ['()] -- clear-colors-immediately? (union #t #f) [#f] -The init-snips-and-arrows-gui-for-syntax-objects returns the same two -functions as the init-snips-and-arrows-gui function. - - -Example -======= - -This example assumes that this library is used by a DrScheme tool. -The skeleton for the tool would then look like this: - -(module my-tool - ... - (require (lib "snips-and-arrows.ss" "mrflow")) - ... - (define tool@ - (unit/sig drscheme:tool-exports^ - (import drscheme:tool^) - ... - (define (phase1) - ... - (drscheme:unit:add-to-program-editor-mixin extend-all-editors-mixin) - ...) - ... - (drscheme:get/extend:extend-definitions-text extend-top-editor-mixin) - ... - (drscheme:get/extend:extend-unit-frame - (lambda (super%) - (class super% - (inherit get-definitions-text) - (rename [super-clear-annotations clear-annotations]) - ; -> void - (define/override (clear-annotations) - ... - (super-clear-annotations) - (send (get-definitions-text) remove-all-snips-and-arrows-and-colors) - ...) - ... - (define my-tool-button - (instantiate button% - ... - (callback - (lambda (button event) - ... - (letrec-values ([(user-change-terms register-label-with-gui) - ; use init-snips-and-arrows-gui-for-syntax-objects - ; if you only deal with syntax objects - (init-snips-and-arrows-gui - (get-definitions-text) - ... - ; for extend-menu-for-labels, if necessary - - ; basically a callback to library-user code - (lambda (popup-menu labels) - ... - (make-object menu-item% - "change stuff" - popup-menu - ; menu callback - (lambda (item event) - ... - (let ([label-and-new-term-pairs - (my-tool-get-stuff-to-change labels)]) - ... - ; callback to the library from within callback to - ; library-user code - (user-change-terms label-and-new-term-pairs) - ...) - ...) - ...) - ...) - ...)]) - ... - ; call to super's method to clean other tools' annotations - (super-clear-annotations) - ... - (drscheme:eval:expand-program - ... - (lambda (syntax-object-or-eof iter) - (if (eof-object? syntax-object-or-eof) - (begin - ... - (send definitions-text color-registered-labels) - ...) - (begin - ... - (my-tool-process-syntax-object ... register-label-with-gui ...) - ... - (iter))))))))))))))) - ...) diff --git a/collects/mrflow/env.ss b/collects/mrflow/env.ss deleted file mode 100644 index 485a862d07..0000000000 --- a/collects/mrflow/env.ss +++ /dev/null @@ -1,56 +0,0 @@ -(module env (lib "mrflow.ss" "mrflow") - (require "util.ss") - - (provide (all-defined)) - - (define create-env (lambda () '())) - (define create-tenv (lambda () '())) - - (define (env-of? domain range) - (list-immutable/c (cons-immutable/c (list-immutable/c domain) - (vector-immutable/c range)))) - (define tenv? (listof (cons/c (listof symbol?) (vectorof any/c)))) - - (define/contract extend-tenv - (tenv? (listof symbol?) (listof any/c) . ->d . - (lambda (env vars binders) - (unless (= (length vars) (length binders)) - (error 'extend-tenv "Must have one handle for each var~n~a~n~a" vars binders)) - tenv?)) - (lambda (env vars binders) - (cons (cons vars (list->vector binders)) env))) - - (define/contract extend-env - ((env-of? symbol? any/c) (list-immutable/c symbol?) (list-immutable/c any/c) . ->d . - (lambda (env vars binders) - (unless (= (length vars) (length binders)) - (error 'extend-tenv "Must have one handle for each var~n~a~n~a" vars binders)) - tenv?)) - (lambda (env vars binders) - (cons (cons vars (list->immutable-vector binders)) env))) - - (define/contract generic-lookup-symbol - ((any/c . -> . any) . -> . (tenv? any/c . -> . any)) - (lambda (not-found-function) - (lambda (tenv var) - (let loop-env ([env tenv]) - (if (null? env) - (not-found-function var) - (let* ([rib (car env)] - [syms (car rib)] - [types (cdr rib)]) - (let loop-rib ([syms syms] [i 0]) - (cond - [(null? syms) (loop-env (cdr env))] - [(equal? (car syms) var) (vector-ref types i)] - [else - (loop-rib (cdr syms) (+ i 1))])))))))) - - (define/contract lookup-symbol (tenv? symbol? . -> . any) - (generic-lookup-symbol - (lambda (var) - (error 'get-state "Unknown type variable in environment: ~a " var)))) - - (define/contract maybe-lookup-symbol (tenv? symbol? . -> . any) - (generic-lookup-symbol (lambda (_) #f))) - ) diff --git a/collects/mrflow/gui.ss b/collects/mrflow/gui.ss deleted file mode 100644 index 499b9562cf..0000000000 --- a/collects/mrflow/gui.ss +++ /dev/null @@ -1,323 +0,0 @@ - -(module gui mzscheme - - (require - (lib "tool.ss" "drscheme") - mzlib/unit - mzlib/list - mzlib/class - mred - (prefix fw: framework) - (prefix strcst: string-constants) - (prefix bit: (lib "bitmap-label.ss" "mrlib")) - - (prefix cst: "constants.ss") - (prefix sba: "constraints-gen-and-prop.ss") - (prefix err: "sba-errors.ss") - (prefix saa: "snips-and-arrows.ss") - ) - - (provide tool@) - - (define tool@ - (unit - (import drscheme:tool^) - (export drscheme:tool-exports^) - ; INTERFACE WITH LANGUAGES - (define mrflow-language-extension-interface<%> - (interface () - render-value-set - get-mrflow-primitives-filename)) - - (define (mrflow-default-implementation-mixin super%) - (class* super% (mrflow-language-extension-interface<%>) - - ; type -> string - ; Language implementors are responsible for providing a type pretty-printer. - ; XXX NOT CURRENTLY USED - (define/public (render-value-set val) "render-value-set-mixin not implemented") - - ; -> string - ; Language implementors are responsible for providing the name of the file - ; that contains the types of the primitives for their language. If they don't, - ; we give a warning, use R5RS, and hope for the best. - (define/public (get-mrflow-primitives-filename) - (message-box (strcst:string-constant mrflow-using-default-language-title) - (strcst:string-constant mrflow-using-default-language) - #f '(ok)) - (build-path (collection-path "mrflow") - "primitives" - "r5rs.ss")) - - (super-instantiate ()))) - - (define (phase1) - (drscheme:language:extend-language-interface mrflow-language-extension-interface<%> - mrflow-default-implementation-mixin) - (drscheme:unit:add-to-program-editor-mixin saa:extend-all-editors-mixin)) - - (define (phase2) cst:void) - - - (define mrflow-bitmap - (bit:bitmap-label-maker - (strcst:string-constant mrflow-button-title) - (build-path (collection-path "icons") "mrflow-small.bmp"))) - - - ; TERM AND SNIP STYLES - (define can-click-style-delta (make-object style-delta% 'change-weight 'bold)) - (send can-click-style-delta set-delta-foreground "purple") - - (define green-style-delta (make-object style-delta% 'change-weight 'bold)) - (send green-style-delta set-delta-foreground "green") - (send green-style-delta set-underlined-on #t) - - (define orange-style-delta (make-object style-delta% 'change-weight 'bold)) - (send orange-style-delta set-delta-foreground "orange") - (send orange-style-delta set-underlined-on #t) - - (define red-style-delta (make-object style-delta% 'change-weight 'bold)) - (send red-style-delta set-delta-foreground "red") - (send red-style-delta set-underlined-on #t) - - ; symbol style-delta% -> style-delta% - ; compares two style-deltas (one represented as a color/severity name, the other one as - ; an actual style-delta) and returns the most "urgent" one. - ; red > orange > green - (define (max-style-delta-by-name style-delta-name style-delta) - (case style-delta-name - [(red) red-style-delta] - [(orange) (if (eq? style-delta red-style-delta) style-delta orange-style-delta)] - [(green) style-delta] - [else (error 'max-style-delta-by-name - "MrFlow internal error; incomparable style-delta ~a" - style-delta-name)])) - - ; sba-state label -> style-delta% - ; If the label has errors associated with it, we color the term with the color - ; of the worst error, otherwise we color it with the normal clickable style-delta. - (define (get-style-delta-from-label sba-state label) - (let ([errors (sba:get-errors-from-label sba-state label)]) - (if (null? errors) - can-click-style-delta - (foldl (lambda (sba-error current-max-style-delta) - (max-style-delta-by-name (err:sba-error-gravity sba-error) current-max-style-delta)) - green-style-delta - errors)))) - - ; sba-state label -> exact-non-negative-integer - ; span conversation: for all graphical purposes, the span of a compound expression is 1, - ; to highlight only the opening parenthesis. Otherwise we might highlight subexpressions - ; with the wrong color. - (define (get-span-from-label sba-state label) - (if (or (sba:is-label-atom? label) - );(not (null? (sba:get-errors-from-label sba-state label)))) - (sba:get-span-from-label label) - 1)) - - ; (listof (cons symbol string)) - ; Lists the possible snip types and their corresponding colors. - ; For a given term that has snips of several different types, the snips will be - ; ordered from left to right in the editor in the same order as their types appear - ; in this list. - (define snip-types-and-colors - '((type . "blue") - (error . "red"))) - - - ; INTERFACE FOR MENUS - ; symbol symbol -> string - ; given a snip type and a menu action for snips (show/hide), return the corresponding - ; menu text - (define (get-menu-text-from-snip-type type action) - (case type - [(type) - (case action - [(show) (strcst:string-constant mrflow-popup-menu-show-type)] - [(hide) (strcst:string-constant mrflow-popup-menu-hide-type)] - [else (error 'get-menu-text-from-type "MrFlow internal error; unknown type action: ~a" action)])] - [(error) - (case action - [(show) (strcst:string-constant mrflow-popup-menu-show-errors)] - [(hide) (strcst:string-constant mrflow-popup-menu-hide-errors)] - [else (error 'get-menu-text-from-type "MrFlow internal error; unknown error action: ~a" action)])] - [else (error 'get-menu-text-from-type "MrFlow internal error; unknown type: ~a" type)])) - - ; sba-state symbol label -> (listof string) - ; given a snip type and a lable, returns the content of the snips to be - ; added for that type and label. - (define (get-snip-text-from-snip-type sba-state type label) - (case type - [(type) (list (sba:pp-type sba-state (sba:get-type-from-label sba-state label) 'gui))] - [(error) (map err:sba-error-message (sba:get-errors-from-label sba-state label))])) - - - ; DEFINITION WINDOW MIXIN - (drscheme:get/extend:extend-definitions-text saa:extend-top-editor-mixin) - - (drscheme:get/extend:extend-tab - (mixin (drscheme:rep:context<%> drscheme:unit:tab<%>) () - (inherit get-defs) - (define/augment (clear-annotations) - (inner (void) clear-annotations) - (send (get-defs) remove-all-snips-and-arrows-and-colors)) - (super-new))) - - ; UNIT FRAME MIXIN - (drscheme:get/extend:extend-unit-frame - (lambda (super%) - (class super% - ; -> void - (define/augment (enable-evaluation) - (inner cst:void enable-evaluation) - (send analyze-button enable #t)) - - ; -> void - (define/augment (disable-evaluation) - (inner cst:void disable-evaluation) - (send analyze-button enable #f)) - - (super-instantiate ()) - - - (inherit get-button-panel get-definitions-text get-interactions-text get-current-tab) - (define analyze-button - (instantiate - button% () - (label (mrflow-bitmap this)) - (parent (get-button-panel)) - (callback - (lambda (button event) - (let ([start-time (current-milliseconds)] - [definitions-text (get-definitions-text)] - [current-tab (get-current-tab)] - [drs-eventspace (current-eventspace)] - [interactions-text (get-interactions-text)] - [language-settings - (fw:preferences:get - (drscheme:language-configuration:get-settings-preferences-symbol))]) - (letrec-values - ([(user-change-terms register-label-with-gui) - (saa:init-snips-and-arrows-gui - definitions-text - sba:get-source-from-label - sba:get-mzscheme-position-from-label - (lambda (label) (get-span-from-label sba-state label)) - sba:get-arrows-from-labels - (lambda (label) (get-style-delta-from-label sba-state label)) - (lambda (menu labels) cst:void) - get-menu-text-from-snip-type - (lambda (type label) (get-snip-text-from-snip-type sba-state type label)) - snip-types-and-colors - #t) - ; snips-and-arrows library testing... -; (saa:init-snips-and-arrows-gui -; definitions-text -; sba:get-source-from-label -; sba:get-mzscheme-position-from-label -; (lambda (label) (get-span-from-label sba-state label)) -; sba:get-arrows-from-label -; (lambda (label) (get-style-delta-from-label sba-state label)) -; (lambda (menu labels) -; (let* ([new-name-callback -; (lambda (item event) -; (let ([new-name -; (fw:keymap:call/text-keymap-initializer -; (lambda () -; (get-text-from-user -; "rename" -; "rename")))] -; [terms (append -; (map -; (lambda (arrow-info) -; (cons (car arrow-info) "foo")) -; (sba:get-arrows-from-labels labels)) -; (map -; (lambda (arrow-info) -; (cons (cadr arrow-info) "foo")) -; (sba:get-arrows-from-labels labels)) -; )]) -; (user-change-terms terms)))]) -; (make-object menu-item% -; (strcst:string-constant cs-rename-id) -; menu -; new-name-callback))) -; get-menu-text-from-snip-type -; (lambda (type label) (get-snip-text-from-snip-type sba-state type label)) -; snip-types-and-colors -; #f) - ] - [(sba-state) (sba:make-sba-state register-label-with-gui)]) - ; disable-evaluation will lock the editor, so hopefully all the other tools - ; unlock the editor to clear their crap (note that the second call below - ; is a call to the superclass, so remove-all-snips-and-arrows-and-colors - ; is not called here, but is called internally inside - ; init-snips-and-arrows-gui - (disable-evaluation) - ;(send current-tab clear-annotations) - - ; note: we have to do this each time, because the user might have changed - ; the language between analyses. - (let* ([language-object (drscheme:language-configuration:language-settings-language - language-settings)] - [primitive-table-file (send language-object get-mrflow-primitives-filename)]) - (if (file-exists? primitive-table-file) - (begin - (sba:initialize-primitive-type-schemes sba-state primitive-table-file) - (drscheme:eval:expand-program - (drscheme:language:make-text/pos definitions-text - 0 - (send definitions-text last-position)) - language-settings - #t - ; set current-directory and current-load-relative-directory before expansion - (lambda () - (let* ([tmp-b (box #f)] - [fn (send definitions-text get-filename tmp-b)]) - (unless (unbox tmp-b) - (when fn - (let-values ([(base name dir?) (split-path fn)]) - (current-directory base) - (current-load-relative-directory base)))))) - void - (lambda (syntax-object-or-eof iter) - (if (eof-object? syntax-object-or-eof) - (parameterize ([current-eventspace drs-eventspace]) - (queue-callback - (lambda () ; =drs= - (let ([sba-end-time (current-milliseconds)]) - ;(printf "sba time: ~a ms~n" (- (current-milliseconds) start-time)) - (sba:check-primitive-types sba-state) - ;(printf "check time: ~a ms~n" (- (current-milliseconds) sba-end-time)) - ) - ; color everything right before re-enabling buttons - (send definitions-text color-registered-labels) - (enable-evaluation) - ))) - (begin - (parameterize ([current-eventspace drs-eventspace]) - (queue-callback - (lambda () ; =drs= - ;(printf "syntax: ~a~n" (syntax-object->datum syntax-object-or-eof)) - (sba:create-label-from-term sba-state syntax-object-or-eof '() #f)))) - ; must be outside the parameterize so the next expansion occurs - ; in the right eventspace... - (iter)))))) - ; get-mrflow-primitives-filename defaults to R5RS - ; (see mrflow-default-implementation-mixin above), so if we arrive here, - ; we know we are in trouble because it means no primitive table is - ; defined for the current language and we couldn't even find the table - ; for the R5RS primitives. - (error 'analyze-button-callback - "MrFlow internal error; R5RS primitive types file ~a doesn't exist." - primitive-table-file))))))))) - - (send (get-button-panel) change-children - (lambda (button-list) - (cons analyze-button (remq analyze-button button-list)))) - ) ; class - )) ; drscheme:get/extend:extend-unit-frame - - )) ; tool@ unit/sig - ); module diff --git a/collects/mrflow/hashcons.ss b/collects/mrflow/hashcons.ss deleted file mode 100644 index d2257a3273..0000000000 --- a/collects/mrflow/hashcons.ss +++ /dev/null @@ -1,1322 +0,0 @@ -(module hashcons (lib "mrflow.ss" "mrflow") - (require (prefix list: mzlib/list) - mzlib/match - mzlib/pretty - mzlib/etc - (prefix string: mzlib/string) - - (prefix cst: "constants.ss") - "dfa.ss" - "trie.ss" - "labels.ss" - "types.ss" - "set-hash.ss" - "env.ss" - "util.ss") - - (provide - ;; Create a new hashcons table - make-hashcons-table - - ;; Convert a type to a handle - hashcons-type - ;; Get the type of a handle - get-type - - ;; Get a pretty string from a handle - handle->string - handle->list - - hashcons-table->list - hashcons-table->dot - handles->dot - - ;; contract functions - hashcons-table? - hashcons-type? - - ;; functions used in testing - ;hashcons-table-size - - ;; debug functions - ;hashcons-acyclic-subtrees - ) - - ;; Debugging settings - ;(print-struct #t) - ;(print-hash-table #t) - ;(pretty-print-columns 105) - - ;; Some predicates for contracts - (define label-type? (or/c type-case-lambda? type-cons? type-promise? - type-struct-value? type-union? type-values? type-vector?)) - (define base-type? (or/c type-empty? type-cst? type-struct-type?)) - (define hashcons-type? (or/c label-type? base-type? type-rec?)) - - ;; - ;; Hashcons tables - ;; - (define-struct hashcons-table - (from-handle ;; handle -> (or/c dfa label base-type) - from-dfa ;; dfa -> handle - from-label ;; label -> handle - from-base-type ;; base-type -> handle - dfa-trie ;; type -> trie, handle -> handle - number-handles) - (make-inspector)) - - (set! make-hashcons-table - (let ([old-make-hashcons-table make-hashcons-table]) - (lambda () - (old-make-hashcons-table - (make-hash-table) - (make-hash-table 'equal) - (make-hash-table 'equal) - (make-hash-table 'equal) - (make-trie) - 0)))) - - (define list-of-handles? (lambda (xs) (and (list? xs) (andmap handle? xs)))) - - (define get-next-handle - (lambda (tbl) - (let ([x (hashcons-table-number-handles tbl)]) - (set-hashcons-table-number-handles! tbl (+ x 1)) - x))) - - (define hashcons-table-size - (lambda (tbl) - (hashcons-table-number-handles tbl))) - - (define get-type-handle - (lambda (tbl type) - (hash-table-get - (hashcons-table-from-base-type tbl) type - (lambda () - (hash-table-get - (hashcons-table-from-label tbl) type - (lambda () (hash-table-get (hashcons-table-from-dfa tbl) type - (lambda () - (error 'get-type-handle "Type ~a not in hashcons table: ~a" - type (hashcons-table->list tbl)))))))))) - - (define/contract get-type (hashcons-table? handle? . -> . hashcons-type?) - (lambda (tbl handle) - (hash-table-get (hashcons-table-from-handle tbl) handle - (lambda () (error 'get-type "Handle: ~a not in hashcons table" handle))))) - - (define has-handle? - (lambda (tbl handle) - (hash-table-get (hashcons-table-from-handle tbl) handle cst:thunk-false))) - - (define has-base-type? - (lambda (tbl base-type) - (hash-table-get (hashcons-table-from-base-type tbl) base-type cst:thunk-false))) - - (define has-label-type? - (lambda (tbl label-type) - (hash-table-get (hashcons-table-from-label tbl) label-type cst:thunk-false))) - - (define has-dfa-type? - (lambda (tbl dfa-type) - (hash-table-get (hashcons-table-from-dfa tbl) dfa-type cst:thunk-false))) - - (define has-type? - (lambda (tbl type) - (or (has-base-type? tbl type) (has-label-type? tbl type) (has-dfa-type? tbl type)))) - - (define/contract add-base-type - (hashcons-table? base-type? . ->d . - (lambda (tbl base-type) - (when (has-base-type? tbl base-type) - (error 'add-base-type "Already have hashconsed ~a" base-type)) - handle?)) - (lambda (tbl base-type) - (let ([h (get-next-handle tbl)]) - (hash-table-put! (hashcons-table-from-handle tbl) h base-type) - (hash-table-put! (hashcons-table-from-base-type tbl) base-type h) - h))) - - (define/contract add-label-type - (hashcons-table? label-type? . ->d . - (lambda (tbl label-type) - (when (has-label-type? tbl label-type) - (error 'add-label-type "Label Type ~a already present in hashcons table" label-type)) - (when (has-dfa-type? tbl label-type) - (error 'add-label-type "Label Type ~a is equivalent to DFA type" label-type)) - handle?)) - (lambda (tbl label-type) - (let ([h (get-next-handle tbl)]) - (hash-table-put! (hashcons-table-from-handle tbl) h label-type) - (hash-table-put! (hashcons-table-from-label tbl) label-type h) - h))) - - ;; add-dfa-type is slightly different from add-label-type and - ;; and-base-type in that it needs to take its handle as an argument. - ;; This is because we need to substitute all state numbers for - ;; handle numbers in all states of the DFA prior to adding it to - ;; them hashcons table. - (define/contract add-dfa-type - (hashcons-table? label-type? handle? . ->d . - (lambda (tbl dfa-type handle) - (when (has-dfa-type? tbl dfa-type) - (error 'add-dfa-type "DFA Type ~a already present in ~a" dfa-type (hashcons-table->list tbl))) - handle?)) - (lambda (tbl dfa-type handle) - (hash-table-put! (hashcons-table-from-handle tbl) handle dfa-type) - (hash-table-put! (hashcons-table-from-dfa tbl) dfa-type handle) - handle)) - - (define/contract recall-base-type (hashcons-table? type? . -> . handle?) - (lambda (tbl base-type) - (if (has-base-type? tbl base-type) - (hash-table-get (hashcons-table-from-base-type tbl) base-type) - (add-base-type tbl base-type)))) - - (define/contract recall-label-type (hashcons-table? label-type? . -> . handle?) - (lambda (tbl label-type) - (cond - [(has-dfa-type? tbl label-type) (hash-table-get (hashcons-table-from-dfa tbl) label-type)] - [(has-label-type? tbl label-type) (hash-table-get (hashcons-table-from-label tbl) label-type)] - [else (add-label-type tbl label-type)]))) - - ; Hashcons-type is the main function. - ; - ; Hashconsing proceedings in two main stages. We first hashcons as - ; much as possible in a straight forward, bottom up fashion. If - ; there is no recursive types, then we are done and just return the - ; handle. If there is a recursive type, then it is necessary to - ; hashcons the recursive type in a bottom up fashion whenever a - ; type has no free variables. - (define/contract hashcons-type (hashcons-table? hashcons-type? . -> . handle?) - (lambda (tbl type) - (let ([size (hashcons-table-size tbl)] - [v (let ([type (hashcons-acyclic-subtrees tbl type)]) - (if (handle? type) type - (bottom-up-hashcons tbl type)))]) - v))) - - ; Hashcons all subtrees in a type containing no variables. Returns - ; a type where all subtrees w/o variables are replaced by the - ; corresponding handle. All label types which remain, have at least - ; one children which contain a variable. - ; - ; After hashconsing all of the children of a type, if there is a - ; child which has not been replaced by a handle then we have a - ; recursive type and we do not hashcons the label. If the children - ; are all handles, we hashcons this label and return its handle in - ; place of the label. - (define hashcons-acyclic-subtrees - (lambda (tbl type) - ((fold-type - (lambda (handle) handle) ;; handle :: handle -> b - (lambda (rest-args req-args argss exps) ;; case-lambda :: [bool] [nat] [[b]] [b] -> b - (let ([new-case-lambda (make-type-case-lambda - (if (list? rest-args) (list->vector rest-args) rest-args) - (if (list? req-args) (list->vector req-args) req-args) - argss exps)]) - (if (and (vector-of-vector-of? handle? argss) (vector-of? handle? exps)) - (recall-label-type tbl new-case-lambda) - new-case-lambda))) - (lambda (hd tl) ;; cons :: b b -> b - (let ([new-type-cons (make-type-cons hd tl)]) - (if (and (handle? hd) (handle? tl)) - (recall-label-type tbl new-type-cons) - new-type-cons))) - (lambda (ty) ;; cst :: any/c -> b - (recall-base-type tbl (make-type-cst ty))) - (let ((empty (make-type-empty))) ;; empty :: -> b - (lambda () - (recall-base-type tbl empty))) - (lambda (type) ;; promise :: b -> b - (let ([new-type-promise (make-type-promise type)]) - (if (handle? type) - (recall-label-type tbl new-type-promise) - new-type-promise))) - (lambda (vars types body) ;; rec :: [b] [b] b -> b - (let* ([new-type-rec (make-type-rec vars types body)]) - (if (and (list-of-handles? types) (handle? body)) - body - new-type-rec))) - (lambda (label) ;; struct-type :: label -> b - (recall-base-type tbl (make-type-struct-type label))) - (lambda (label types) ;; label :: [b] -> b - (let ([new-type (make-type-struct-value label types)]) - (if (list-of-handles? types) - (recall-label-type tbl new-type) - new-type))) - (lambda (elements) ;; union :: [b] -> b - (cond [(null? elements) (recall-base-type tbl (make-type-empty))] - [(length-one? elements) (car elements)] - [(list-of-handles? elements) - (let* ([elements (min-list-numbers elements)]) - (cond - [(length-one? elements) (car elements)] - [else - (recall-label-type tbl (make-type-union elements))]))] - [else (make-type-union elements)])) - (lambda (type) ;; values :: b -> b - (let ([new-type-values (make-type-values type)]) - (if (handle? type) - (recall-label-type tbl new-type-values) - new-type-values))) - make-type-var ;; var :: name boolean boolean -> b - (lambda (type) ;; vector :: b -> b - (let ([new-type-vector (make-type-vector type)]) - (if (handle? type) - (recall-label-type tbl new-type-vector) - new-type-vector)))) - type))) - - ;; After we've hashconsed a recursive type this does the final job - ;; of adding it to the hashcons table. - (define/contract hashcons-rec-type-body (hashcons-table? (or/c type? handle?) . -> . (or/c type? handle?)) - (lambda (tbl type) - (let ([recall-type (lambda (type) (if (has-type? tbl type) - (get-type-handle tbl type) - (recall-label-type tbl type)))]) - ((fold-type - (lambda (handle) handle) ;; handle :: handle -> b - (lambda (rest-args req-args argss exps) ;; case-lambda :: [bool] [bool] [[b]] [b] -> b - (recall-type (make-type-case-lambda rest-args req-args argss exps))) - (lambda (hd tl) ;; cons :: b b -> b - (recall-type (make-type-cons hd tl))) - (lambda (ty) ;; cst :: any/c -> b - (error 'hashcons-rec-type-body "type-cst should have been previously hashconsed")) - (lambda () ;; empty :: -> b - (error 'hashcons-rec-type-body "type-empty should have been previously hashconsed")) - (lambda (type) ;; promise :: b -> b - (recall-type (make-type-promise type))) - (lambda (vars types body) ;; rec :: [b] [b] b -> b - (error 'hashcons-rec-type-body "Should not have a type-rec DFA at this point")) - (lambda (label) ;; struct-type - (error 'hashcons-rec-type-body "struct-type should have been hashcons already")) - (lambda (label types) ;; struct-value - (recall-type (make-type-struct-value label types))) - (lambda (elements) ;; type-union [b] -> b - (let ([elements (min-list-numbers elements)]) - (cond [(length-one? elements) - ;; TBD seems suspiscious - ;; if there is only one element then the union - ;; containing it was redundant and perhaps the - ;; type should be reconsidered - (car elements)] - [else - (recall-type (make-type-union elements))]))) - (lambda (type) ;; type-values ;; b -> b - (recall-type (make-type-values type))) - (lambda (name reach handle) ;; type-var ;; b -> b - (error 'hashcons-rec-type-body "Should not have type-var at this point")) - (lambda (type) ;; type-vector ;; b -> b - (recall-type (make-type-vector type)))) - type)))) - - ;; Almost the same as acyclic hashcons except when we reach a - ;; rec-type with no free variables we hashcons it. - ;; - ;; Perhaps this could be merged w/ acyclic hashcons. The code is - ;; almost identical - (define/contract bottom-up-hashcons - (hashcons-table? hashcons-type? . ->d . (lambda (tbl type) handle?)) - (lambda (tbl type) - (let - ([hashcons - (fold-type - (lambda (handle) handle) ;; handle :: handle -> b - (lambda (rest-args req-args argss exps) ;; case-lambda :: [bool] [bool] [[b]] [b] -> b - (let ([new-case-lambda (make-type-case-lambda rest-args req-args argss exps)]) - (if (and (vector-of-vector-of? handle? argss) - (vector-of? handle? exps)) - (recall-label-type tbl new-case-lambda) - new-case-lambda))) - (lambda (hd tl) ;; cons :: b b -> b - (let ([new-type-cons (make-type-cons hd tl)]) - (if (and (handle? hd) (handle? tl)) - (recall-label-type tbl new-type-cons) - new-type-cons))) - (lambda (type) ;; cst :: any/c -> b - (recall-base-type tbl type)) - (lambda () ;; empty :: -> b - (recall-base-type tbl (make-type-empty))) - (lambda (value) ;; promise :: b -> b - (let ((new-type-promise (make-type-promise value))) - (if (handle? value) - (recall-label-type tbl new-type-promise) - new-type-promise))) - (bottom-up-hashcons-rec-type tbl) - (lambda (label) ;; type-struct-type - (recall-base-type tbl (make-type-struct-type label))) - (lambda (label types) ;; type-struct-value - (let ([new-type (make-type-struct-value label types)]) - (if (list-of-handles? types) - (recall-label-type tbl new-type) - new-type))) - (lambda (elements) ;; type-union [b] -> b - (if (list-of-handles? elements) - (let* ([elements (min-list-numbers elements)]) - (cond - [(null? elements) (recall-base-type tbl (make-type-empty))] - [(length-one? elements) (car elements)] - [else - (recall-label-type tbl (make-type-union elements))])) - (make-type-union elements))) - (lambda (type) ;; type-values ;; b -> b - (let ((new-type-values (make-type-values type))) - (if (handle? type) - (recall-label-type tbl new-type-values) - new-type-values))) - make-type-var - (lambda (element) ;; type-vector ;; b -> b - (let ((new-type-vector (make-type-vector element))) - (if (handle? element) - (recall-label-type tbl new-type-vector) - new-type-vector))))]) - (hashcons type)))) - - (define/contract bottom-up-hashcons-rec-type - (hashcons-table? . -> . ((listof type-var?) (listof (or/c type? handle?)) (or/c type? handle?) . ->d . - (lambda (vars types body) - (when (has-free-vars? (make-type-rec vars types body)) - (error 'bottom-up-hashcons "~a has free type variables~n" (make-type-rec vars types body))) - handle?))) - (lambda (tbl) - (lambda (vars types body) ;; rec :: [b] [b] b -> b - (let*-values - ([(vars types body) - (if (type-var? body) - (values vars types body) - (let ([newvar (make-type-var (gensym) #f #f)]) - (values (cons newvar vars) (cons body types) newvar)))] - [(graph bindings) - (let ([graph (make-hash-table)] - [bindings (make-hash-table)]) - (for-each (lambda (var type) - (hash-table-put! graph (type-var-name var) (get-referenced-vars type)) - (hash-table-put! bindings (type-var-name var) type)) - vars types) - (values graph bindings))] - [(sccs) (strongly-connected-components graph)] - [(env) - (list:foldl (lambda (scc env) - (hashcons-scc tbl scc graph bindings env)) - (create-tenv) - sccs)]) - (lookup-symbol env (type-var-name body)))))) - - (define/contract hashcons-scc (hashcons-table? (listof any/c) hash-table? hash-table? tenv? . -> . tenv?) - (lambda (tbl scc graph bindings env) - (cond - ;; The SCC is actually a recursive type - [(and (length-one? scc) (memq (car scc) (hash-table-get graph (car scc)))) - (let*-values ([(ty) (make-type-rec (list (make-type-var (car scc) #f #f)) - (list (hash-table-get bindings (car scc))) - (make-type-var (car scc) #f #f))] - [(ty) (subst-handles/vars-if-possible ty env)] - [(ty) (hashcons-acyclic-subtrees tbl ty)] - [(dfa binder-states) (create-dfa-from-type ty env)] - [(min-dfa min-binder-stnums) (minimize-dfa dfa binder-states)] - [(min-stnum->handle) - (let ([greatest-handle (greatest-handle min-dfa)]) - (if greatest-handle - (recursive-with-handle tbl min-dfa - (map state-number - (list:filter - (lambda (s) - (not (handle-state? s))) - (get-ordered-states min-dfa))) - greatest-handle) - #f))] - [(binder-handles) - (if min-stnum->handle - (map (lambda (stnum) - (hash-table-get min-stnum->handle stnum)) - min-binder-stnums) - (let ([min-stnum->handle (recall-entire-dfa tbl min-dfa)]) - (map (lambda (minstnum) - (hash-table-get min-stnum->handle minstnum)) - min-binder-stnums)))] - ;(let* ([min-states (get-ordered-states min-dfa)] - ; [all-handles (recall-entire-dfa tbl min-dfa)]) - ; (let loop ([all-states min-states] - ; [all-handles all-handles]) - ; (if (= (state-number (car all-states)) (car min-binder-stnums)) - ; (list (car all-handles)) - ; (loop (cdr all-states) (cdr all-handles))))))] - ) - (extend-tenv env scc binder-handles))] - - [(length-one? scc) - (let* ([var (car scc)] - [ty (hash-table-get bindings var)] - [ty-no-vars (subst-handles/vars ty env)] - [handle (hashcons-rec-type-body tbl ty-no-vars)]) - (extend-tenv env (list var) (list handle)))] - - [else - (let*-values - ([(ty) (make-type-rec (map (lambda (v) (make-type-var v #f #f)) scc) - (map (lambda (v) (hash-table-get bindings v)) scc) - (make-type-var (car scc) #f #f))] - [(ty) (subst-handles/vars-if-possible ty env)] - [(ty) (hashcons-acyclic-subtrees tbl ty)] - [(dfa binder-stnums) (create-dfa-from-type ty env)] - [(min-dfa min-binder-stnums) (minimize-dfa dfa binder-stnums)] - [(min-states) (get-ordered-states min-dfa)] - [(stnum->handle) - (let* ([greatest-handle (greatest-handle min-dfa)]) - (if greatest-handle - (recursive-with-handle tbl min-dfa - (map state-number - (list:filter - (lambda (s) - (not (handle-state? s))) - min-states)) - greatest-handle) - #f))] - [(binder-handles) (if stnum->handle - (map (lambda (stnum) (hash-table-get stnum->handle stnum)) min-binder-stnums) - (let ([stnum->handle (recall-entire-dfa tbl min-dfa)]) - (map (lambda (stnum) - (hash-table-get stnum->handle stnum)) - min-binder-stnums)))] - ;[(handles) (if stnum->handle #f (recall-entire-dfa tbl min-dfa))] - ;[(binder-handles) - ; (if handles - ; (letrec ([position - ; (lambda (state-num xs counter) - ; (cond [(null? xs) (error 'not-found)] - ; [(= (state-number (car xs)) state-num) counter] - ; [else (position state-num (cdr xs) (add1 counter))]))]) - ; (map (lambda (pos) (list-ref handles pos)) - ; (map (lambda (state) (position state min-states 0)) min-binder-stnums))) - ; (map (lambda (stnum) (hash-table-get stnum->handle stnum)) min-binder-stnums))] - ) - (extend-tenv env scc binder-handles))]))) - - ;; If this DFA has been hashconsed return its handle, otherwise add it to the - ;; hashcons table and the trie. - (define/contract recall-entire-dfa - (hashcons-table? dfa? . ->d . - (lambda (tbl dfa) - (lambda (ht) - (when (hash-table? ht) - (unless (= (get-dfa-size dfa) (hash-table-size ht)) - (error 'recall-entire-dfa "Missing or extra states in state->handle map~ndfa=~a~nstate->handle=~a" dfa ht)) - (for-each (lambda (st) (unless (hash-table-get ht (state-number st) cst:thunk-false) - (error 'recall-entire-dfa - "No matching state ~s map~ndfa=~a~nstate->handle=~a" st (dfa->list dfa) - (hash-table-map ht (lambda (k v) (cons k v)))))) - (get-ordered-states dfa))) - #t))) - (lambda (hashcons-table dfa) - (let* ([states (get-ordered-states dfa)] - [trie (hashcons-table-dfa-trie hashcons-table)] - [maybe-handles (dfa-present? trie states)]) - (or (and maybe-handles - (make-immutable-hash-table (map (lambda (state handle) - (cons-immutable (state-number state) handle)) - states maybe-handles))) - (let* ([new-handles - (map (lambda (state) (if (handle-state? state) - (handle-state-handle state) - (get-next-handle hashcons-table))) - states)] - [stnum->handle - (letrec ([tbl (make-hash-table)] - [stnum->state (dfa-stnum->state dfa)] - [close (lambda (st ancest) - (if (and (union-state? st) - (length-one? (union-state-elements st))) - (if (memq (state-number st) ancest) - (error 'cycle-of-empty-unions-detected) - (close (hash-table-get stnum->state (car (union-state-elements st))) - (cons (state-number st) ancest))) - st))]) - (for-each (lambda (state handle) - (hash-table-put! tbl (state-number state) handle)) - states new-handles) - (for-each (lambda (state) - (hash-table-put! tbl (state-number state) - (hash-table-get tbl (state-number (close state null))))) - states) - - ;; This is mildly funky, if there is a union of length one, we will close it - ;; and the state will point to the handle of its single element, but the union - ;; will still be a state in the dfa (and therefore a key in the trie, although - ;; it will never be refered to in the types representing the dfa i.e. an - ;; unused handle) - - tbl)] - [lookup - (lambda (stnum) (hash-table-get stnum->handle stnum))] - [subst-handle/state - (match-lambda - [($ cons-state state hd tl) - (make-type-cons (lookup hd) (lookup tl))] - [($ case-lambda-state state rest-arg?s req-args argss exps) - (make-type-case-lambda rest-arg?s - req-args - (map-vector-of-vector lookup argss) - (map-vector lookup exps))] - [($ union-state state elements) - (let ([handles (min-list-numbers (map lookup elements))]) - (if (length-one? handles) (car handles) - (make-type-union handles)))] ;; double check this - [($ promise-state state value) - (make-type-promise (lookup value))] - [($ struct-value-state state label types) - (make-type-struct-value label (map lookup types))] - [($ values-state state types) - (make-type-values (lookup types))] - [($ vector-state state element) - (make-type-vector (lookup element))] - [x (error 'recall-entire-dfa "Unmatched type ~a" x)])]) - (add-dfa-states trie states new-handles) - (for-each (lambda (dfa-state handle) - (unless (handle-state? dfa-state) - (let ([handle-or-state (subst-handle/state dfa-state)]) - (unless (handle? handle-or-state) - (add-dfa-type hashcons-table handle-or-state handle))))) - states new-handles) - stnum->handle))))) - - ;; Almost a fold, with the exception of the type-rec-type binding variables which we do not - ;; recurse on. - (define fold-type - (lambda (handlef ;; handle -> b - case-lambdaf ;; [bool] [int] [[b]] [b] -> b - consf ;; b b -> b - cstf ;; any/c -> b - emptyf ;; -> b - promisef ;; b -> b - recf ;; [b] [b] b -> b - struct-typef ;; label -> b - struct-valuef ;; label [b] -> b - unionf ;; [b] -> b - valuesf ;; b -> b - varf ;; name bool -> b - vectorf) ;; b -> b - (lambda (type) - (letrec ([foldt (fold-type handlef case-lambdaf consf cstf emptyf - promisef recf struct-typef struct-valuef - unionf valuesf varf vectorf)]) - (cond - [(handle? type) - (handlef type)] - [(type-case-lambda? type) - ;; When we first get a case-lambda its arguments may be lists, - ;; so convert them to vectors once and for all here. This is - ;; a hack until case-lambda uses vectors in all cases. - (let* ([rest-arg?s (type-case-lambda-rest-arg?s type)] - [req-args (type-case-lambda-req-args type)] - [argss (type-case-lambda-argss type)] - [exps (type-case-lambda-exps type)] - [argss (if (list? argss) (lol->vov argss) argss)] - [exps (if (list? exps) (list->vector exps) exps)] - [argss (for-each-vov! foldt argss)] - [exps (for-each-vector! foldt exps)]) - (case-lambdaf rest-arg?s req-args argss exps))] - [(type-cons? type) - (consf (foldt (type-cons-car type)) (foldt (type-cons-cdr type)))] - [(type-cst? type) - (cstf (type-cst-type type))] - [(type-empty? type) - (emptyf)] - [(type-promise? type) - (promisef (foldt (type-promise-value type)))] - [(type-rec? type) - (let ([vars (type-rec-vars type)] ; <-- Do not recur on variables being bound - [types (map foldt (type-rec-types type))] - [body (foldt (type-rec-body type))]) - (recf vars types body))] - [(type-struct-type? type) - (struct-typef (type-struct-type-type-label type))] - [(type-struct-value? type) - (let ([label (type-struct-value-type-label type)] - [types (map foldt (type-struct-value-types type))]) - (struct-valuef label types))] - [(type-union? type) - (unionf (map foldt (type-union-elements type)))] - [(type-values? type) - (valuesf (foldt (type-values-type type)))] - [(type-var? type) - (varf (type-var-name type) (type-var-reach type) (type-var-handle type))] - [(type-vector? type) - (vectorf (foldt (type-vector-element type)))] - [else (error 'fold-type "Unmatched type ~a" type)]))))) - - ;; Return a type with handles replacing variables - (define/contract subst-handles/vars ((or/c label-type? handle? type-var?) tenv? . -> . (or/c type? handle?)) - (lambda (type tenv) - (let subst ([type type]) - (cond - [(handle? type) type] - [(type-case-lambda? type); rest-arg?s req-args argss exps) - (let* ([rest-arg?s (type-case-lambda-rest-arg?s type)] - [req-args (type-case-lambda-req-args type)] - [argss (for-each-vov! subst (type-case-lambda-argss type))] - [exps (for-each-vector! subst (type-case-lambda-exps type))]) - (make-type-case-lambda rest-arg?s req-args argss exps))] - [(type-cons? type) - (make-type-cons (subst (type-cons-car type)) (subst (type-cons-cdr type)))] - [(type-promise? type) - (make-type-promise (subst (type-promise-value type)))] - [(type-rec? type) ; vars handle-list body) - (let ([vars (type-rec-vars type)] - [handle-list (type-rec-types type)] - [body (type-rec-body type)]) - (for-each (lambda (handle) (unless (handle? handle) - (pretty-print (make-type-rec vars handle-list body)) - (error 'type-rec-var-no-handle))) - handle-list) - (subst-handles/vars body - (extend-tenv tenv (map type-var-name vars) handle-list)))] - [(type-struct-value? type) - (make-type-struct-value (type-struct-value-type-label type) (map subst (type-struct-value-types type)))] - [(type-union? type) - (make-type-union (map subst (type-union-elements type)))] - [(type-values? type) - (make-type-values (subst (type-values-type type)))] - [(type-var? type) - (lookup-symbol tenv (type-var-name type))] - [(type-vector? type) - (make-type-vector (subst (type-vector-element type)))] - [else (error 'subst-handles/vars "Unmatched type ~a" type)])))) - - (define/contract subst-handles/vars-if-possible - ((or/c hashcons-type? handle? type-var?) tenv? . -> . (or/c type? handle?)) - (lambda (type tenv) - (let subst ([type type]) - (match type - [(? handle? type) type] - [($ type-case-lambda rest-arg?s req-args argss exps) - (let* ([argss (for-each-vov! subst argss)] - [exps (for-each-vector! subst exps)]) - ; for-each-vector set! args and exps in place - type)] - [($ type-cons hd tl) - (set-type-cons-car! type (subst hd)) - (set-type-cons-cdr! type (subst tl)) - type] - [($ type-promise value) - (set-type-promise-value! type (subst value)) - type] - [($ type-rec vars types body) - ;; maybe we should add the vars/types to the scope iff the type is a handle - (set-type-rec-types! type (map subst types)) - (set-type-rec-body! type (subst body)) - type] - [($ type-struct-value label types) - (set-type-struct-value-types! type (map subst types)) - type] - [($ type-union elements) - (set-type-union-elements! type (map subst elements)) - type] - [($ type-values ty) - (set-type-values-type! type (subst ty)) - type] - [($ type-var name reach handle) - (or (maybe-lookup-symbol tenv name) type)] - [($ type-vector element) - (set-type-vector-element! type (subst element)) - type]) - ))) - - (define/contract has-free-vars? ((or/c type? handle?) . -> . boolean?) - (lambda (type) - (let* ([bound-vars (make-hash-table)] - [bind (lambda (var) - (let ([cv (hash-table-get bound-vars var cst:thunk-false)]) - (hash-table-put! bound-vars var (if cv (add1 cv) 1))))] - [unbind (lambda (var) - (let ([cv (hash-table-get bound-vars var - (lambda () (error 'unbind "Cannot unbind unbound variable ~a" var)))]) - (when (= cv 0) - (error 'unbind "Cannot unbind variable ~a more times than its bound" var)) - (hash-table-put! bound-vars var (sub1 cv))))] - [bound? (lambda (var) - (let ([cv (hash-table-get bound-vars var cst:thunk-false)]) - (and cv (> cv 0))))]) - (let/ec k - (letrec - ([list-has-free-vars? (lambda (args) (ormap has-free-vars? args))] - [has-free-vars? - (match-lambda - [(? handle? type) #f] - [($ type-case-lambda rest-arg?s req-args argss exps) - (or (vector-of-vector-has? has-free-vars? argss) - (vector-has? has-free-vars? exps))] - [($ type-cons hd tl) - (or (has-free-vars? hd) (has-free-vars? tl))] - [($ type-promise value) - (has-free-vars? value)] - [($ type-rec vars types body) - (let* ([vnames (map type-var-name vars)] - [_ (for-each bind vnames)] - [fv (or (list-has-free-vars? types) (has-free-vars? body))]) - (for-each unbind vnames) - fv)] - [($ type-struct-value label types) - (list-has-free-vars? types)] - [($ type-union elements) - (list-has-free-vars? elements)] - [($ type-values type) - (has-free-vars? type)] - [($ type-var name reach handle) - (if (bound? name) #f (k #t))] - [($ type-vector element) - (has-free-vars? element)] - [_ (error 'has-free-vars? "Unmatched type ~a" type)])]) - (has-free-vars? type)))))) - - (define/contract get-referenced-vars ((or/c type? handle?) . -> . (listof symbol?)) - (lambda (type) - (let ([refed (make-hash-table)]) - (let loop ([type type]) - (match type - [(? handle? type) cst:void] - [($ type-case-lambda rest-arg?s req-args argss exps) - (for-each-vov loop argss) - (for-each-vector loop exps)] - [($ type-cons hd tl) - (loop hd) (loop tl)] - [($ type-promise value) - (loop value)] - [($ type-rec vars handle-list body) - (error 'get-referenced-vars "Nested type-rec found")] - [($ type-struct-value label types) - (for-each loop types)] - [($ type-union elements) - (for-each loop elements)] - [($ type-values type) - (loop type)] - [($ type-var name reach handle) - (hash-table-put! refed name #t)] - [($ type-vector element) - (loop element)]) - (hash-table-map refed (lambda (v _) v)))))) - - (define/contract same-label-type? - (hashcons-table? state? (or/c type? handle?) . -> . boolean?) - (lambda (tbl state type) - (or (and (handle-state? state) (handle? type) (= (handle-state-handle state) type)) - (and (handle-state? state) (equal? (get-type tbl (handle-state-handle state)) type)) - - (and (cons-state? state) (type-cons? type)) - (and (union-state? state) (type-union? type)) - (and (vector-state? state) (type-vector? type)) - (and (case-lambda-state? state) (type-case-lambda? type)) - (and (union-state? state) (type-union? type)) - (and (promise-state? state) (type-promise? type)) - (and (struct-value-state? state) (type-struct-value? type)) - ))) - - (define/contract for-each-child - (any/c state? type? . -> . any) - (lambda (f state type) - (cond [(handle-state? state) - (void)] - [(cons-state? state) - (f (cons-state-car state) (type-cons-car type)) - (f (cons-state-cdr state) (type-cons-cdr type))] - [(case-lambda-state? state) - (let* ([sargss (case-lambda-state-argss state)] - [targss (type-case-lambda-argss type)] - [argss-length (vector-length sargss)]) - (let argss-loop ([argss-i 0]) - (when (< argss-i argss-length) - (let* ([sargs (vector-ref sargss argss-i)] - [targs (vector-ref targss argss-i)] - [args-length (vector-length sargs )]) - (let args-loop ([i 0]) - (when (< i args-length) - (f (vector-ref sargs i) (vector-ref targs i)) - (args-loop (add1 i))))) - (argss-loop (add1 argss-i))))) - (let* ([texps (type-case-lambda-exps type)] - [sexps (case-lambda-state-exps state)] - [len (vector-length texps)]) - (let loop ([i 0]) - (when (< i len) - (f (vector-ref sexps i) (vector-ref texps i)) - (loop (add1 i)))))] - [(promise-state? state) - (f (promise-state-value state) (type-promise-value type))] - [(struct-value-state? state) - (for-each f (struct-value-state-types state) (type-struct-value-types type))] - [(union-state? state) - (error 'union-states-not-sequential)] - [(values-state? state) - (f (values-state-type state) (type-values-type type))] - [(vector-state? state) - (f (vector-state-element state) (type-vector-element type))] - [else - (error 'for-each-child "Unmatched type")]))) - - ;; See if any of the states in a minimized DFA is recursive with the - ;; greatest handle in the DFA. - (define/contract recursive-with-handle - (hashcons-table? dfa? (nonempty-list-of? state-number?) handle? . ->d . - (lambda (hc dfa dfa-stnums handle) - (lambda (state->handle) - (when state->handle - (if (= (hash-table-size state->handle) (length (get-state-numbers dfa))) - (or (hash-table? state->handle) (boolean? state->handle)) - (pretty-error 'missing-state->handles - (list (cons 'dfa->list (dfa->list dfa)) - (cons 'dfa-stnums dfa-stnums) - (cons 'handle handle) - (cons 'state->handle state->handle)))))))) - (lambda (hc dfa dfa-stnums handle) - (define stnum->state (dfa-stnum->state dfa)) - - (define/contract state-number->state (state-number? . -> . state?) - (lambda (stnum) - (hash-table-get stnum->state stnum))) - - ;; Return the handle a state is recursive with or false - (define (state-recursive-with-handle stnum handle acc return-with stnum->handle) - (if (member (cons stnum handle) acc) stnum->handle - (let* ([type (get-type hc handle)] - [state (state-number->state stnum)] - ;; TBD new - ; [state (if (and (union-state? state) (length-one? (union-state-elements state))) - ; (state-number->state (car (union-state-elements state))) - ; state)] - ) - (if (or - (and (same-label-type? hc state type) - (let ([acc (cons (cons stnum handle) acc)]) - (if (union-state? state) - ;; return #f is there exists a dfa state w/o a union element - ;; should this be checked for all elements in both the - ;; type-union-elements and the union-state-elements? - (unless (andmap - (lambda (stnum) - (ormap (lambda (handle) - (state-recursive-with-handle stnum handle acc return-with stnum->handle)) - (type-union-elements type))) - (union-state-elements state)) - (return-with #f)) - (for-each-child - (lambda (state handle) - (unless (state-recursive-with-handle state handle acc return-with stnum->handle) - (return-with #f))) - state type)) - #t)) - ;; imagine we have a case like - ;; (rec-type:1 ((a0 (cons:1 _ a0)))) - ;; (rec-state ((a0 (union:A handle:1 (cons:B a0))))) - ;; the graphs are the same modulo the union, the - ;; following makes sure the state is recursive - ;; with the union - (and (union-state? state) - (andmap (lambda (stnum) (state-recursive-with-handle stnum handle - (cons (cons (state-number state) handle) acc) - return-with stnum->handle)) - (union-state-elements state)))) - (begin - (hash-table-put! stnum->handle stnum handle) - stnum->handle) - #f)))) - - (ormap (lambda (stnum) - (let/ec escape - (state-recursive-with-handle stnum handle null escape (make-hash-table)))) - dfa-stnums))) - - ;; - ;; Printing Functions - ;; - - (define hashcons-table->list - (lambda (tbl) - (list 'hashcons-table - (list:sort - (hash-table-map (hashcons-table-from-handle tbl) - (lambda (h _) (list 'Handle: h '-> (handle->list tbl h void #t)))) - (lambda (x y) (> (cadr x) (cadr y))))))) - - (define/contract hashcons-table->dot (hashcons-table? output-port? . -> . void?) - (lambda (tbl out) - (handles->dot tbl - (hash-table-map (hashcons-table-from-handle tbl) (lambda (handle type) handle)) - out))) - - (define/contract handles->dot (hashcons-table? (listof handle?) output-port? . -> . void?) - (lambda (tbl handles out) - (letrec - ([type->dot - (lambda (handle type ancest) - (match type - [($ type-empty) - (fprintf out "node~a[label = \"mt ~a\"];\n" handle handle)] - [($ type-cst type) - (fprintf out "node~a[label = \"~a ~a\"];\n" handle (string:expr->string type) handle)] - [($ type-struct-type label) - (fprintf out "node~a[label = \"struct ~a\"];\n" handle handle)] - [($ type-cons hd tl) - (fprintf out "node~a[label = \"cons~a | | \"];\n" handle handle) - (fprintf out "node~a:f1 -> node~a;\n" handle hd) - (fprintf out "node~a:f2 -> node~a;\n" handle tl) - (loop hd ancest) - (loop tl ancest)] - [($ type-case-lambda rest-arg?s req-args argss exps) - (fprintf out "node~a[label = \"lambda ~a | {" handle handle) - (for-each-vector (lambda (rest-arg) (fprintf out "| ~a" rest-arg)) rest-arg?s) - (fprintf out "} | {") - (for-each-vector (lambda (req-arg) (fprintf out "| ~a" req-arg)) req-args) - (fprintf out "} | {") - (for-each (lambda (args i) - (fprintf out "| {") - (for-each (lambda (arg j) - (fprintf out "| ~a" i j arg)) - (vector->list args) (iota (vector-length args))) - (fprintf out "}")) - (vector->list argss) (iota (vector-length argss))) - (fprintf out "} | {") - (for-each (lambda (exp i) (fprintf out "| ~a" i exp)) (vector->list exps) (iota (vector-length exps))) - (fprintf out "}\"];\n") - - (for-each (lambda (args i) - (for-each (lambda (arg j) - (fprintf out "node~a:argr~ac~a -> node~a;\n" handle i j arg)) - (vector->list args) (iota (vector-length args)))) - (vector->list argss) (iota (vector-length argss))) - (for-each (lambda (exp i) - (fprintf out "node~a:exp~a -> node~a;\n" handle i exp)) - (vector->list exps) (iota (vector-length exps))) - - (for-each-vov (lambda (arg) (loop arg ancest)) argss) - (for-each-vector (lambda (exp) (loop exp ancest)) exps)] - [($ type-promise value) - (fprintf out "node~a:[label = promise ~a];\n" handle handle) - (fprintf out "node~a:f0 -> node~a;\n" handle value) - (loop value ancest)] - [($ type-struct-value label types) - (fprintf out "node~a[label = \"struct-value ~a\"];\n" handle handle) - (for-each (lambda (i) - (fprintf out "node~a:f -> node~a;\n" handle i)) types) - (for-each (lambda (i) - (loop i ancest)) types)] - [($ type-values values-type) - (fprintf out "node~a[label = \"values ~a\"];\n" handle handle) - (fprintf out "node~a:f -> node~a;\n" handle values-type) - (loop values-type ancest)] - [($ type-vector element) - (fprintf out "node~a[label = \"vector ~a\"];\n" handle handle) - (fprintf out "node~a:f -> node~a;\n" handle element) - (loop element ancest)] - [($ type-union elements) - (fprintf out "node~a[label = \"union ~a\"];\n" handle handle) - (for-each (lambda (el i) - (fprintf out "node~a:f~a -> node~a;\n" handle i el)) elements (iota (length elements))) - (for-each (lambda (el) - (loop el ancest)) elements)] - [else (error 'hashcons-type-string "~a Not implemented yet" type)]))] - [loop (lambda (handle ancest) - (unless (set-in? ancest handle) ;; if we've already come across this node - (let* ([type (get-type tbl handle)] - [str (type->dot handle type (set-set ancest handle))]) - str - ; (set-remove ancest handle) ;; imperative sets - )))]) - (fprintf out "digraph g {\n") - (fprintf out "node[shape = record];\n") - (fprintf out "/* Hashtable size = ~a */\n" (hashcons-table-size tbl)) - (let ([set (set-make)]) (for-each (lambda (h) (loop h set)) handles)) - (fprintf out "}\n")))) - - (define/contract handle->string - (hashcons-table? handle? (handle? handle? . -> . boolean?) . -> . string?) - (lambda (tbl handle union-elements-equal?) - (let ([out (open-output-string)]) - ; the following gets rid of the newline at the end of the type, but - ; it also prevents newlines *inside* the type... This can probably be - ; fixed using a custom pretty-print-print-line that uses the default - ; liner except for the last line. Should be good enough for now. - (pretty-print-columns 'infinity) - (pretty-display (handle->list tbl handle union-elements-equal? - #f) ;; #t to show handles - out) - (get-output-string out)))) - - (define/contract handle->string-old - (hashcons-table? handle? (handle? handle? . -> . boolean?) . -> . string?) - (lambda (tbl handle union-elements-equal?) - (letrec - ([handle->var (make-hash-table)] - [handle->binding (make-hash-table)] - [get-next-var! (let ([*i* 0]) (lambda (handle) - (let ([new-i (+ *i* 1)] - [str (format "a~a" *i*)]) - (set! *i* (+ *i* 1)) - (hash-table-put! handle->var handle str) - str)))] - [type->string - (lambda (type ancest) - (match type - [($ type-empty) - "_"] - [($ type-cst type) - (string:expr->string type)] - [($ type-struct-type label) - (string-append "#string (label-struct-type-name label)) ">")] - [($ type-cons hd tl) - (string-append "(cons " (loop hd ancest) " " (loop tl ancest) ")")] - [($ type-case-lambda rest-arg?s req-args argss exps) - (string-append "(case-lambda " - (foldr-case-lambda-vector (lambda (rest-arg? req-arg args exp acc) - (string-append - "[" - (foldr-vector (lambda (arg acc) - (string-append (loop arg ancest) " " acc)) - (if rest-arg? "*-> " "-> ") - args) - (loop exp ancest) "]" acc)) - ")" - rest-arg?s req-args argss exps))] - [($ type-promise value) - (string-append "(promise " (loop value ancest) ")")] - [($ type-struct-value label types) - (string-append "#(struct:" - (symbol->string (if (label-struct-type? label) (label-struct-type-name label) label)) - " " - (list:foldr - (lambda (elt-type str) - (string-append - (loop elt-type ancest) - (if (string=? str ")") "" " ") - str)) - ")" - types))] - [($ type-values values-type) - (cond - [(type-empty? values-type) - (loop values-type ancest)] - [(and (type-cst? values-type) (eq? (type-cst-type values-type) 'top)) - (loop values-type ancest)] - [else - (string-append "(values " (loop values-type ancest) ")")])] - [($ type-vector element) - (string-append "(vector " (loop element ancest) ")")] - [($ type-union elements) - (let* ([els (list:foldr (lambda (x ys) - (if (ormap (lambda (y) - (union-elements-equal? x y)) ys) - ys - (cons x ys))) - '() - elements)] - [els (list:foldl (lambda (x ys) - (if (ormap (lambda (y) - (union-elements-equal? x y)) ys) - ys - (cons x ys))) - '() - els)]) - (if (length-one? els) - (loop (car els) ancest) - (string-append "(union" - (list:foldr (lambda (el acc) - (string-append " " (loop el ancest) acc)) - ")" - elements))))] - [else (error 'hashcons-type-string "~a Not implemented yet" type)]))] - [loop (lambda (handle ancest) - (if (set-in? ancest handle) ;; if we've already come across this node - ;; Add a back reference - (if (hash-table-get handle->var handle cst:thunk-false) - (hash-table-get handle->var handle) - (get-next-var! handle)) - (let* ([type (get-type tbl handle)] - [str (type->string type (set-set ancest handle))]) - (set-remove ancest handle) ;; imperative sets - (if (hash-table-has-key? handle->var handle) - (begin - (hash-table-put! handle->binding handle str) - (hash-table-get handle->var handle)) - str))))]) - (let* ([rec-body (loop handle (set-make))] - [var-bindings - (list:foldr - (lambda (cur acc) (string-append cur (if (string=? acc "") "" "\n") acc)) "" - (hash-table-map handle->var - (lambda (handle var) - (string-append (number->string handle) "[" var " " - (hash-table-get handle->binding handle - (lambda () (error 'handle->string - "No binding for var handle ~a" handle))) - "]"))))]) - (format "~s:~a" handle - (if (string=? "" var-bindings) rec-body - (string-append "(rec-type (" var-bindings ") " rec-body ")"))))))) - - (define handle->list - (opt-lambda (tbl handle union-elements-equal? [show-handles #t]) - (letrec - ([handle->var (make-hash-table)] - [handle->binding (make-hash-table)] - [get-next-var! (let ([i 0]) (lambda (handle) - (let ([str (string->symbol (format "a~a" i))]) - (set! i (add1 i)) - (hash-table-put! handle->var handle str) - str)))] - [handlify - (lambda (str handle) ;(any/c handle? . -> . (or/c symbol? (cons/p symbol? any/c))) - (let* ([first (if (list? str) (car str) str)] - [first-handle - (string->symbol - (let ([str (cond [(string? first) first] - [else (string:expr->string first)])]) - (if show-handles - (string-append str ":" (string:expr->string handle)) - str)))]) - (if (list? str) (cons first-handle (cdr str)) first-handle)))] - [type->list - (lambda (type ancest) - (match type - [($ type-empty) '_] - [($ type-cst type) - (cond [(null? type) 'null] - [(symbol? type) type] - [(boolean? type) type] - [(number? type) type] - [else (string->symbol (string:expr->string type))])] - [($ type-struct-type label) - (string->symbol (string-append - "#string (label-struct-type-name label)) ">"))] - [($ type-cons hd tl) - (list 'cons (loop hd ancest) (loop tl ancest))] - [($ type-case-lambda rest-arg?s req-args argss exps) - (list 'case-lambda - (foldr-case-lambda-vector - (lambda (rest-arg? req-arg args exp acc) - (cons - (append - (map (lambda (arg) (loop arg ancest)) (vector->list args)) - (list (if rest-arg? '*-> '->) - (loop exp ancest))) - acc)) - null - rest-arg?s req-args argss exps))] - [($ type-promise value) - (list 'promise (loop value ancest))] - [($ type-struct-value label types) - (list (string->symbol - (string-append - "#(struct:" - (symbol->string - (if (label-struct-type? label) (label-struct-type-name label) label)))) - (map (lambda (ty) (loop ty ancest)) types))] - [($ type-values values-type) - (cond - [(type-empty? values-type) - (loop values-type ancest)] - [(and (type-cst? values-type) (eq? (type-cst-type values-type) 'top)) - (loop values-type ancest)] - [else - (list 'values (loop values-type ancest))])] - [($ type-vector element) - (list 'vector (loop element ancest))] - [($ type-union elements) - (let* ([simplify - (lambda (x ys) - (let ([can-drop-x-for? - (lambda (y) - (if (= x y) - #f - (union-elements-equal? x y)))]) - (if (ormap can-drop-x-for? ys) ys (cons x ys))))] - [els (list:foldr simplify null elements)] - [els (list:foldl simplify null els)]) - (let ([retme - (cond - [show-handles - (cons 'union (map (lambda (x) (loop x ancest)) els))] - [(> (length els) 1) - (cons 'union (map (lambda (x) (loop x ancest)) els))] - [(= 1 (length els)) - (loop (car els) ancest)] - [else (error 'union-without-elemetns - "elements=~a els=~a" elements els)])]) - retme) - )] - [else (error 'handle->list "Unmatched type: ~a" type)]))] - [loop (lambda (handle ancest) ;(handle? any/c . -> . any) - (if (memq handle ancest) ;; if we've already come across this node - ;; Add a back reference - (if (hash-table-has-key? handle->var handle) - (hash-table-get handle->var handle) - (get-next-var! handle)) - (let* ([type (get-type tbl handle)] - [str (type->list type (cons handle ancest))]) - (if (hash-table-has-key? handle->var handle) - (begin - (hash-table-put! handle->binding handle (handlify str handle)) - (hash-table-get handle->var handle)) - (handlify str handle)))))]) ;; changed here - (let* ([rec-body (loop handle null)] - [var-bindings - (hash-table-map handle->var - (lambda (handle var) - (list var (hash-table-get handle->binding handle))))]) - (if (null? var-bindings) rec-body - (list (handlify 'rec-type handle) var-bindings rec-body)))))) - - - ;; - ;; Graph algorithms - ;; - - ;; get a list of strongly connected components in reverse - ;; topological order, taken from CLR - (define/contract strongly-connected-components - (hash-table? . ->d . - (lambda (h) - (lambda (list-of-sccs) - (= (hash-table-size h) (apply + (map length list-of-sccs)))))) - (lambda (graph) - (letrec - ;; finished nodes from most recently finished to first finished - ([finished-nodes (box ())] - [color (make-hash-table)] - - [transpose-graph - (lambda (graph) - (let ([new-graph (make-hash-table)]) - (hash-table-for-each graph (lambda (node adj-list) - (hash-table-put! new-graph node null))) - (hash-table-for-each graph (lambda (node adj-list) - (for-each (lambda (adj-node) - (hash-table-put! new-graph adj-node - (cons node (hash-table-get new-graph adj-node)))) - adj-list))) - new-graph))] - [dfs-visit (lambda (graph u visited-nodes) - (hash-table-put! color u 'gray) - (let* ([adj (hash-table-get graph u)] - [new-nodes - (list:foldl (lambda (v visited) - (if (eq? (hash-table-get color v) 'white) - (dfs-visit graph v visited) - visited)) - visited-nodes - adj)]) - (hash-table-put! color u 'black) - (set-box! finished-nodes (cons u (unbox finished-nodes))) - (cons u new-nodes)))] - [dfs (lambda (graph nodes-to-visit) - (hash-table-for-each graph - (lambda (u _) (hash-table-put! color u 'white))) - (let ([sccs (list:foldl (lambda (u sccs) - (if (eq? (hash-table-get color u) 'white) - (cons (dfs-visit graph u null) sccs) - sccs)) - '() - nodes-to-visit)]) - sccs))]) - (dfs graph (hash-table-map graph (lambda (k adj) k))) - (dfs (transpose-graph graph) (unbox finished-nodes))))) - ) diff --git a/collects/mrflow/labels.ss b/collects/mrflow/labels.ss deleted file mode 100644 index 2f87c22be0..0000000000 --- a/collects/mrflow/labels.ss +++ /dev/null @@ -1,91 +0,0 @@ - -(module labels mzscheme - - ; XXX labels contain types and types contain labels, so we will need another layer for - ; the contracts once the types are extracted from cgp.ss - - (provide - (struct label (parents children type-var trace prim? term set edges)) - (struct label-cst (value)) - (struct label-cons (car cdr)) - (struct label-vector (element)) - (struct label-promise (value)) - (struct label-case-lambda (struct rest-arg?s req-args argss exps effects)) - (struct label-values (label)) - (struct label-struct-value (type fields)) - (struct label-struct-type (name parent parent-fields-nbr total-fields-nbr error?)) - ) - - ; parents = children = (listof label) - ; type-var = (union type-var #f), trace = boolean, prim? = boolean - ; term = syntax-object, set = (hash-table-of label (make-arrows (listof label) (listof label) (listof label)), - ; edges = (hashtableof symbol edge)) - ; a flow graph label/node type-var is a type variable name used when reconstructing recursive - ; types. - ; trace is used to detect cycles in the graph during type reconstruction. - ; prim? tells whether the label was created during graph reconstruction from a primitive - ; type. We need this to detect the entrance of a tunnel. - ; Note that the only reason we need to have this tunneling stuff is to keep the GUI arrows right. - ; term: the source program term (or a fake version of it, in the case of "null" when we have - ; a rest argument) - ; set: contains label structures (see below) for all the values that flow into this term. - ; Each label in the set has two lists of in and out edges pointing back and forth to the nodes - ; from which this label has flowed in (or '() if the label is the source of the label) and - ; flowed out to. The in edges (which need to be checked each time a propagation is done, to - ; revent cycles) are in a list, and not in an hash-table, because we assume that the same - ; label is not going to flow very often into this term through several paths. The out-edge - ; list is only used to draw arrows, so it doesn't have to be implemented very efficiently. - ; Note that, since constants are represented by label structs, the same constant can appear - ; several times in the set, even symbols. - ; edges: functions that take two labels as argument and either propagate the second one to - ; another label, using the first label as the source, or transform the graph accordingly (if - ; the inflowing label is a function pseudo-label and the label into which it flows corresponds - ; to the operator in an application, for example). - ; parent and children are used to memoize the parent and children arrows for all the values - ; in the label's value set. Computing these when the code contains huge amounts of macro- - ; generated recurisve code is quite expensive. - (define-struct label (parents children type-var trace prim? term set edges)) - - ; a constant... - (define-struct (label-cst label) (value)) - - ; car = label, cdr = label - (define-struct (label-cons label) (car cdr)) - - (define-struct (label-vector label) (element)) - (define-struct (label-promise label) (value)) - - ; struct = label-struct - ; rest-arg?s = (listof boolean), req-args = (listof number), argss = (listof (listof label)), - ; exps = (listof label), app-thunks = (listof (-> void)) - ; Each "level" of the six lists represents the args and body labels of a given clause in the - ; case-lambda. At a given level, rest-arg? tells whether this clause has a rest argument, - ; and req-args gives the number of required arguments, so it only has to be computed once. - ; top-free-varss are the labels of the top level free variables in the corresponding clause. - ; This field is updated as a side effect when analyzing top level variable references inside - ; the body of a lambda. Edges flowing into these free variables must be created when the - ; clause is applied. app-thunk is a thunk that is used to delay the transformation of the - ; graph when a function flows into an application, until the clause around the application - ; is itself applied. The two are merged, because one of the delayed app could set! a top level - ; variable, and the top level variable can be referenced both before and after the application, - ; so lookups and applications have to be done in exactly the right order. - ; struct is just a placeholder to tell the type of structure a given structure-processing - ; function is supposed to deal with. - (define-struct (label-case-lambda label) - (struct rest-arg?s req-args argss exps effects)) - - ; label = label (a label-cons based list of labels) - ; used to simulate multiple values. So this label is going to flow around and work pretty - ; much like a cons label. the problem is that multiple values are not first-class in Scheme, - ; so we have to be careful to only propagate them through edges that correspond to the result - ; of applications, never through edges that correspond to arguments of applications. Hence - ; the reason for the complication in create-simple-edge. Note that define-struct expands - ; into a define-values, so we need all that stuff. - (define-struct (label-values label) (label)) - - ; symbol symbol label number (listof label) - (define-struct (label-struct-value label) (type fields)) - (define-struct (label-struct-type label) - (name parent parent-fields-nbr total-fields-nbr error?)) - - ) diff --git a/collects/mrflow/mrflow.ss b/collects/mrflow/mrflow.ss deleted file mode 100644 index 27433c3a5a..0000000000 --- a/collects/mrflow/mrflow.ss +++ /dev/null @@ -1,49 +0,0 @@ -(module mrflow mzscheme - (require mzlib/pretty - mzlib/contract - mred) - - (provide (all-from mzscheme) - ;(all-from-except mzscheme vector-ref) - ;(rename dbg-vector-ref vector-ref) - - (all-from-except mzlib/contract provide/contract define/contract) - ; one or the other - provide/contract define/contract - ;(rename dbg-provide/contract provide/contract)(rename dbg-define-contract define/contract) - - non-negative-exact-integer? - text%? - style-delta%? - ) - - (define-syntax (dbg-provide/contract stx) - (syntax-case stx (struct) - [(_) #'(provide)] - [(_ (id contract) other ...) - #'(begin (provide id) (dbg-provide/contract other ...))] - [(_ (struct id ((field contract) ...)) other ...) - #'(begin (provide (struct id (field ...))) (dbg-provide/contract other ...))]) - ) - - (define-syntax (dbg-define/contract stx) - (syntax-case stx () - [(_ name contract body) #'(define name body)])) - - (define-syntax dbg-vector-ref - (lambda (stx) - (syntax-case stx () - [(_ args ...) - #`(begin - (printf "~a ~a ~a ~a~n" - #,(syntax-source stx) - #,(syntax-line stx) - #,(syntax-column stx) - #,(syntax-original? stx)) - (#,#'vector-ref args ...))]))) - - (define non-negative-exact-integer? (and/c integer? exact? (>=/c 0))) - (define text%? (is-a?/c text%)) - (define style-delta%? (is-a?/c style-delta%)) - - ) diff --git a/collects/mrflow/primitives/algol60.ss b/collects/mrflow/primitives/algol60.ss deleted file mode 100644 index 5d05e98588..0000000000 --- a/collects/mrflow/primitives/algol60.ss +++ /dev/null @@ -1,87 +0,0 @@ -; Algol 60 primitives and runtime support -( - ; primitives - - (!= (number number -> boolean)) - (! (boolean -> boolean)) - (& (boolean boolean -> boolean)) - (\| (boolean boolean -> boolean)) - (=> (boolean boolean -> boolean)) - (== (boolean boolean -> boolean)) - - (sign (forall ([a top]) - ((real -> a) (-> real) -> a))) - (entier (forall ([a top]) - ((real -> a) (-> real) -> a))) - - (a60:sin (forall ([a top]) - ((real -> a) (-> real) -> a))) - (a60:cos (forall ([a top]) - ((real -> a) (-> real) -> a))) - (a60:arctan (forall ([a top]) - ((real -> a) (-> real) -> a))) - (a60:sqrt (forall ([a top]) - ((real -> a) (-> real) -> a))) - (a60:abs (forall ([a top]) - ((real -> a) (-> real) -> a))) - (a60:ln (forall ([a top]) - ((real -> a) (-> real) -> a))) - (a60:exp (forall ([a top]) - ((real -> a) (-> real) -> a))) - - (prints (forall ([a top]) - ((void -> a) (-> top) -> a))) - (printn (forall ([a top]) - ((void -> a) (-> top) -> a))) - (printsln (forall ([a top]) - ((void -> a) (-> top) -> a))) - (printnln (forall ([a top]) - ((void -> a) (-> top) -> a))) - - ; Algol60 runtime support - - ;(a60:array (struct a60:array (dependant type))) - ;(a60:switch (struct a60:switch (choices)) - - (undefined undefined) - - (check-boolean (forall ([a top]) (a -> a))) - (goto (forall ([a top]) ((-> a) -> a))) - (get-value (forall ([a top]) ((-> a) -> a))) - (set-target! (forall ([a top][b top]) - ((a -> b) a -> b))) - ;make-array - ;array-ref - ;array-set! - ;make-switch - ;switch-ref - - (coerce (forall ([a top]) - (symbol a -> a))) - - - ; R5RS runtime support - - (void (-> void)) - - (= (real real -> boolean)) - (< (real real -> boolean)) - (> (real real -> boolean)) - (<= (real real -> boolean)) - (>= (real real -> boolean)) - - (+ (real real -> real)) - (* (real real -> real)) - (- (real real -> real)) - (/ (real real -> real)) - - (quotient (integer integer -> integer)) - (remainder (integer integer -> integer)) - (modulo (integer integer -> integer)) - - (values (forall ([a_values top]) - (case-lambda - [(rest a_values) (values a_values)] - ))) - - ) diff --git a/collects/mrflow/primitives/r5rs.ss b/collects/mrflow/primitives/r5rs.ss deleted file mode 100644 index d9ad5014b0..0000000000 --- a/collects/mrflow/primitives/r5rs.ss +++ /dev/null @@ -1,884 +0,0 @@ -; R5RS -; When are we going to be able to compute all this directly from an S-exp version of R5RS ? -( - ; 4.2.6 quasiquotation - - ; not part of r5rs, but the expansion of ,@ uses qq-append - (qq-append (forall ([b_append top][c_append top]) - (case-lambda - [((listof b_append) c_append) - (union c_append - (rec-type - ([improper-list - (union () - (cons b_append - (union c_append improper-list)))]) - improper-list))]))) - - ; 6.1 Equivalence predicates - - (eqv? (top top -> boolean)) - (eq? (top top -> boolean)) - (equal? (top top -> boolean)) - - - ; 6.2.5 Numerical operations - - ; in Scheme it seems that positive = strictly positive and - ; negative = strictly negative - - (number? (top -> boolean)) - (complex? (top -> boolean)) - (real? (top -> boolean)) - (rational? (top -> boolean)) - (integer? (top -> boolean)) - - (exact? (complex -> boolean)) - (inexact? (complex -> boolean)) - - (= (complex complex complex *-> boolean)) - (< (real real real *-> boolean)) - (> (real real real *-> boolean)) - (<= (real real real *-> boolean)) - (>= (real real real *-> boolean)) - - (zero? (complex -> boolean)) - (positive? (real -> boolean)) - (negative? (real -> boolean)) - (odd? (integer -> boolean)) - (even? (integer -> boolean)) - - ; if any arg inexact => result inexact - (max (forall ([x_max real]) - (case-lambda - [(x_max) x_max] - [(rest real (listof real)) real]))) - ; if any arg inexact => result inexact - (min (forall ([x_min real]) - (case-lambda - [(x_min) x_min] - [(rest real (listof real)) real]))) - - ; no arg => 0 - ; z => z - (+ (forall ([z_+ complex]) - (case-lambda - [(rest complex complex (listof complex)) complex] - [() 0] - [(z_+) z_+] - ))) - ; no arg => 1 - ; z => z - (* (forall ([z_* complex]) - (case-lambda - [(rest complex complex (listof complex)) complex] - [() 1] - [(z_*) z_*] - ))) - - ; z => -z - (- (complex complex *-> complex)) - ; z => 1/z - (/ (complex complex *-> complex)) - - ; returns non-negative real - (abs (real -> real)) - - ; second arg non-zero - (quotient (integer integer -> integer)) - ; second arg non-zero - ; result has same sign as first arg - (remainder (integer integer -> integer)) - ; second arg non-zero - ; result has same sign as second arg - (modulo (integer integer -> integer)) - - ; no arg => 0 - ; n => n (from math) - ; result is non-negative integer - (gcd (forall ([n_gcd integer]) - (case-lambda - [(rest integer integer (listof integer)) integer] - [() 0] - [(n_gcd) n_gcd] - ))) - ; no arg => 1 - ; n => n (from math) - ; result is non-negative integer - (lcm (forall ([n_lcm integer]) - (case-lambda - [(rest integer integer (listof integer)) integer] - [() 1] - [(n_lcm) n_lcm] - ))) - - (numerator (rational -> integer)) - ; result always positive - ; 0 => 1 - (denominator (rational -> integer)) - - (floor (real -> integer)) - (ceiling (real -> integer)) - (truncate (real -> integer)) - (round (real -> integer)) - - (rationalize (real real -> rational)) - - (exp (complex -> complex)) - (log (complex -> complex)) - (sin (complex -> complex)) - (cos (complex -> complex)) - (tan (complex -> complex)) - (asin (complex -> complex)) - (acos (complex -> complex)) - (atan (case-lambda - [(complex) complex] - [(real real) complex])) - - ; positive real part, or zero real part and non-negative imaginary part - (sqrt (complex -> complex)) - - ; (expt 0 0) = 1 - ; (expt 0 z) = 0 - (expt (complex complex -> complex)) - - (make-rectangular (real real -> complex)) - (make-polar (real real -> complex)) - (real-part (complex -> real)) - (imag-part (complex -> real)) - ; returns non-negative real - (magnitude (complex -> real)) - (angle (complex -> real)) - - (exact->inexact (complex -> inexact-complex)) - (inexact->exact (complex -> exact-complex)) - - - ; 6.2.6 Numerical input and output - - ; this really ougth to be called complex->string and string->complex, - ; especially since R5RS explicitely uses a "z" as the first argument - ; name... R5RS seems to actually confuse complex and number quite a lot, - ; despite the second note in section 6.2.5, page 21. - - ; radix is either 2, 8, 10, or 16 - (number->string (case-lambda - [(complex) string] - [(complex exact-integer) string])) - - ; radix is either 2, 8, 10, or 16 - (string->number (case-lambda - [(string) (union complex #f)] - [(string exact-integer) (union complex #f)])) - - - ; 6.3.1 Booleans - - (not (boolean -> boolean)) - - (boolean? (top -> boolean)) - - - ; 6.3.2 Pairs and lists - - (pair? (top -> boolean)) - - (cons (forall ([a_cons top] - [b_cons top]) - (a_cons b_cons -> (cons a_cons b_cons)))) - - (car (forall ([a_car top]) - ((cons a_car top) -> a_car))) - - (cdr (forall ([a_cdr top]) - ((cons top a_cdr) -> a_cdr))) - - ; b can't be twice in contra-variant position... - ;(set-car! (forall ([a top][b top][c top]) - ; (cons (union a b) c) b -> void - - ;(set-cdr! (forall ([a top][b top][c top]) - ; (cons a (union b c)) b -> void - - (caar (forall ([a_caar top]) - ((cons (cons a_caar top) top) -> a_caar))) - (cdar (forall ([a_cdar top]) - ((cons (cons top a_cdar) top) -> a_cdar))) - (cadr (forall ([a_cadr top]) - ((cons top (cons a_cadr top)) -> a_cadr))) - (cddr (forall ([a_cddr top]) - ((cons top (cons top a_cddr)) -> a_cddr))) - (caaar (forall ([a_caaar top]) - ((cons (cons (cons a_caaar top) top) top) -> a_caaar))) - (cdaar (forall ([a_cdaar top]) - ((cons (cons (cons top a_cdaar) top) top) -> a_cdaar))) - (cadar (forall ([a_cadar top]) - ((cons (cons top (cons a_cadar top)) top) -> a_cadar))) - (cddar (forall ([a_cddar top]) - ((cons (cons top (cons top a_cddar)) top) -> a_cddar))) - (caadr (forall ([a_caadr top]) - ((cons top (cons (cons a_caadr top) top)) -> a_caadr))) - (cdadr (forall ([a_cdadr top]) - ((cons top (cons (cons top a_cdadr) top)) -> a_cdadr))) - (caddr (forall ([a_caddr top]) - ((cons top (cons top (cons a_caddr top))) -> a_caddr))) - (cdddr (forall ([a_cdddr top]) - ((cons top (cons top (cons top a_cdddr))) -> a_cdddr))) - (caaaar (forall ([a_caaaar top]) - ((cons (cons (cons (cons a_caaaar top) top) top) top) -> a_caaaar))) - (cdaaar (forall ([a_cdaaar top]) - ((cons (cons (cons (cons top a_cdaaar) top) top) top) -> a_cdaaar))) - (cadaar (forall ([a_cadaar top]) - ((cons (cons (cons top (cons a_cadaar top)) top) top) -> a_cadaar))) - (cddaar (forall ([a_cddaar top]) - ((cons (cons (cons top (cons top a_cddaar)) top) top) -> a_cddaar))) - (caadar (forall ([a_caadar top]) - ((cons (cons top (cons (cons a_caadar top) top)) top) -> a_caadar))) - (cdadar (forall ([a_cdadar top]) - ((cons (cons top (cons (cons top a_cdadar) top)) top) -> a_cdadar))) - (caddar (forall ([a_caddar top]) - ((cons (cons top (cons top (cons a_caddar top))) top) -> a_caddar))) - (cdddar (forall ([a_cdddar top]) - ((cons (cons top (cons top (cons top a_cdddar))) top) -> a_cdddar))) - (caaadr (forall ([a_caaadr top]) - ((cons top (cons (cons (cons a_caaadr top) top) top)) -> a_caaadr))) - (cdaadr (forall ([a_cdaadr top]) - ((cons top (cons (cons (cons top a_cdaadr) top) top)) -> a_cdaadr))) - (cadadr (forall ([a_cadadr top]) - ((cons top (cons (cons top (cons a_cadadr top)) top)) -> a_cadadr))) - (cddadr (forall ([a_cddadr top]) - ((cons top (cons (cons top (cons top a_cddadr)) top)) -> a_cddadr))) - (caaddr (forall ([a_caaddr top]) - ((cons top (cons top (cons (cons a_caaddr top) top))) -> a_caaddr))) - (cdaddr (forall ([a_cdaddr top]) - ((cons top (cons top (cons (cons top a_cdaddr) top))) -> a_cdaddr))) - (cadddr (forall ([a_cadddr top]) - ((cons top (cons top (cons top (cons a_cadddr top)))) -> a_cadddr))) - (cddddr (forall ([a_cddddr top]) - ((cons top (cons top (cons top (cons top a_cddddr)))) -> a_cddddr))) - - (null? (top -> boolean)) - - (list? (top -> boolean)) - - ; the rest argument does all the work - (list (forall ([a_list top]) - (case-lambda - [(rest a_list) a_list]))) - - (length ((listof top) -> exact-integer)) - - (append (forall ([a_append top] - [b_append top][c_append top] - [d_append top][e_append top][f_append top] - [g_append top][h_append top][i_append top][j_append top] - [k_append top][l_append top][m_append top][n_append top][o_append top] - [p_append top][q_append top][r_append top][s_append top][t_append top][u_append top]) - (case-lambda - [() ()] - [(a_append) a_append] - [((listof b_append) c_append) - (union c_append - (rec-type - ([improper-list - (union () - (cons b_append - (union c_append improper-list)))]) - improper-list))] - [((listof d_append) (listof e_append) f_append) - (union f_append - (rec-type - ([improper-list - (union () - (cons (union d_append e_append) - (union f_append improper-list)))]) - improper-list))] - [((listof g_append) (listof h_append) (listof i_append) j_append) - (union j_append - (rec-type - ([improper-list - (union () - (cons (union g_append h_append i_append) - (union j_append improper-list)))]) - improper-list))] - [((listof k_append) (listof l_append) (listof m_append) (listof n_append) o_append) - (union o_append - (rec-type - ([improper-list - (union () - (cons (union k_append l_append m_append n_append) - (union o_append improper-list)))]) - improper-list))] - [((listof p_append) (listof q_append) (listof r_append) (listof s_append) (listof t_append) u_append) - (union u_append - (rec-type - ([improper-list - (union () - (cons (union p_append q_append r_append s_append t_append) - (union u_append improper-list)))]) - improper-list))]))) - ; the last element could be not a list => improper list - ; this doesn't work because it doesn't enforce the listness of args beyond - ; the first one but before the last one... - ;[(rest (listof b_append) (listof c_append)) - ; (rec-type ([improper-list (union () - ; (cons (union b_append c_append) - ; (union c_append improper-list)))]) - ; improper-list)] - ;(union c_append (listof b_append))] - ;))) - - (reverse (forall ([a_reverse top]) - ((listof a_reverse) -> (listof a_reverse)))) - - ; exact-integer should be non-negative... - (list-tail (forall ([a_list-tail top]) - ((listof a_list-tail) exact-integer -> (listof a_list-tail)))) - - (list-ref (forall ([a_list-ref top]) - ((listof a_list-ref) exact-integer -> a_list-ref))) - - (memq (forall ([a_memq top] - [b_memq top]) - (a_memq (listof b_memq) -> (union #f (cons a_memq (listof b_memq)))))) - (memv (forall ([a_memv top] - [b_memv top]) - (a_memv (listof b_memv) -> (union #f (cons a_memv (listof b_memv)))))) - (member (forall ([a_member top] - [b_member top]) - (a_member (listof b_member) -> (union #f (cons a_member (listof b_member)))))) - - (assq (forall ([a_assq top] - [b_assq top]) - (a_assq (listof (cons top b_assq)) -> (union #f (cons a_assq b_assq))))) - (assv (forall ([a_assv top] - [b_assv top]) - (a_assv (listof (cons top b_assv)) -> (union #f (cons a_assv b_assv))))) - (assoc (forall ([a_assoc top] - [b_assoc top]) - (a_assoc (listof (cons top b_assoc)) -> (union #f (cons a_assoc b_assoc))))) - - - ; 6.3.3. Symbols - - (symbol? (top -> boolean)) - - (symbol->string (symbol -> string)) - - (string->symbol (string -> symbol)) - - - ; 6.3.4 Characters - - (char? (top -> boolean)) - - (char=? (char char -> boolean)) - (char boolean)) - (char>? (char char -> boolean)) - (char<=? (char char -> boolean)) - (char>=? (char char -> boolean)) - - (char-ci=? (char char -> boolean)) - (char-ci boolean)) - (char-ci>? (char char -> boolean)) - (char-ci<=? (char char -> boolean)) - (char-ci>=? (char char -> boolean)) - - (char-alphabetic? (char -> boolean)) - (char-numeric? (char -> boolean)) - (char-whitespace? (char -> boolean)) - (char-upper-case? (letter -> boolean)) - (char-lower-case? (letter -> boolean)) - - ; R5RS doesn't say the integer has to be positive... - (char->integer (char -> exact-integer)) - (integer->char (exact-integer -> char)) - - (char-upcase (char -> char)) - (char-downcase (char -> char)) - - - ; 6.3.5 Strings - - (string? (top -> boolean)) - - ; integer should be non-negative - (make-string (case-lambda - [(exact-integer) string] - [(exact-integer char) string])) - - (string (case-lambda - [(rest char (listof char)) string] - [() ""] - )) - - ; exact positive integer ? exact integer ? integer ? - (string-length (string -> exact-integer)) - - (string-ref (string exact-integer -> char)) - - ; should inject string into the first arg - ;(string-set! (string exact-integer char -> void)) - - (string=? (string string -> boolean)) - (string-ci=? (string string -> boolean)) - - (string boolean)) - (string>? (string string -> boolean)) - (string<=? (string string -> boolean)) - (string>=? (string string -> boolean)) - (string-ci boolean)) - (string-ci>? (string string -> boolean)) - (string-ci<=? (string string -> boolean)) - (string-ci>=? (string string -> boolean)) - - (substring (string exact-integer exact-integer -> string)) - - (string-append (forall ([a_string-append string]) - (case-lambda - [(rest string string (listof string)) string] - [() ""] - [(a_string-append) a_string-append] - ))) - - (string->list (string -> (listof char))) - (list->string ((listof char) -> string)) - - ; (string-copy (forall ([a string]) (a -> a))) works only if we don't have string-set! - (string-copy (string -> string)) - - ; should inject string into first arg - ;(string-fill! (string char -> void)) - - - ; 6.3.6 Vectors - - (vector? (top -> boolean)) - - ; integer should be non-negative - (make-vector (forall ([a_make-vector top]) - (case-lambda - [(exact-integer) (vector top)] - [(exact-integer a_make-vector) (vector a_make-vector)]))) - - (vector (forall ([a_vector top]) - (a_vector *-> (vector a_vector)))) - - (vector-length ((vector top) -> exact-integer)) - - (vector-ref (forall ([a_vector-ref top]) - ((vector a_vector-ref) exact-integer -> a_vector-ref))) - - ; should inject third arg into first - ;(vector-set! (vector exact-integer top -> void)) - - (vector->list (forall ([a_vector->list top]) - ((vector a_vector->list) -> (listof a_vector->list)))) - (list->vector (forall ([a_list->vector top]) - ((listof a_list->vector) -> (vector a_list->vector)))) - - ; second arg shoould flow into first - ;(vector-fill! (vector top -> void)) - - - ; 6.4 Control features - - (procedure? (top -> boolean)) - - (apply (forall ([a_apply top][b_apply top] - [c_apply top][d_apply top][e_apply top] - [f_apply top][g_apply top][h_apply top][i_apply top] - [j_apply top][k_apply top][l_apply top][m_apply top][n_apply top] - [o_apply top][p_apply top][q_apply top][r_apply top][s_apply top][t_apply top] - [u_apply top][v_apply top][w_apply top][x_apply top][y_apply top][z_apply top][aa_apply top] - ;[ab_apply top][ac_apply top] - ) - (case-lambda - [((case-lambda [(rest (listof a_apply)) b_apply]) - (listof a_apply)) b_apply] - [((case-lambda [(rest (listof (union c_apply d_apply))) e_apply]) - c_apply (listof d_apply)) e_apply] - [((case-lambda [(rest (listof (union f_apply g_apply h_apply))) i_apply]) - f_apply g_apply (listof h_apply)) i_apply] - [((case-lambda [(rest (listof (union j_apply k_apply l_apply m_apply))) n_apply]) - j_apply k_apply l_apply (listof m_apply)) n_apply] - [((case-lambda [(rest (listof (union o_apply p_apply q_apply r_apply s_apply))) t_apply]) - o_apply p_apply q_apply r_apply (listof s_apply)) t_apply] - [((case-lambda [(rest (listof (union u_apply v_apply w_apply x_apply y_apply z_apply))) aa_apply]) - u_apply v_apply w_apply x_apply y_apply (listof z_apply)) aa_apply] - ; this would almost work, except for the last argument, that would - ; show up as a list in the result - ;[(rest (case-lambda - ; [(rest a) b]) - ; a) - ; b]))) - ; so we have to deconstruct everything, and be *very* conservative. - ; This *will* raise errors about possible infinite lists, but that's the - ; best we can if we want to cover all the possible cases. - ; this will not work because it doesn't allow for the first args to not - ; be lists - ;[(rest (case-lambda - ; [(rest (listof ab_apply)) ac_apply]) - ; (listof (listof ab_apply))) - ; ac_apply]))) - ; and this doesn't work either because it allows for the last arg - ; to not be a list - ;[(rest (case-lambda - ; [(rest (listof (union a_apply (listof b_apply)))) c_apply]) - ; (listof (union a_apply (listof b_apply)))) - ; c_apply]))) - ))) - - (map (forall ([a_map top][b_map top] - [c_map top][d_map top][e_map top] - [f_map top][g_map top][h_map top][i_map top] - [j_map top][k_map top][l_map top][m_map top][n_map top] - [o_map top][p_map top][q_map top][r_map top][s_map top][t_map top] - ) - (case-lambda - [((a_map -> b_map) (listof a_map)) - (listof b_map)] - [((c_map d_map -> e_map) (listof c_map) (listof d_map)) - (listof e_map)] - [((f_map g_map h_map -> i_map) (listof f_map) (listof g_map) (listof h_map)) - (listof i_map)] - [((j_map k_map l_map m_map -> n_map) (listof j_map) (listof k_map) (listof l_map) (listof m_map)) - (listof n_map)] - [((o_map p_map q_map r_map s_map -> t_map) (listof o_map) (listof p_map) (listof q_map) (listof r_map) (listof s_map)) - (listof t_map)] - ; use at your own risks: you'll loose arity checking and get spurious errors - ; about '() not being a pair or about infinite lists (but the result of map - ; will be properly conservative, so if you ignore the errors for map itself - ; and make sure the arity of the function given to map is correct, then you - ; might be able to use the output of map to detect errors down the flow - except - ; that the output of map will be a list => using car on it or stuff like that - ; will trigger another error...) - ; The whole problem is that map needs a dependent type... - ;[(rest - ; (case-lambda - ; [(rest o p q r (listof s)) t]) - ; (listof o) (listof p) (listof q) (listof r) (listof (listof s))) - ; (listof t)] - ))) - - (for-each (forall ([a_for-each top];[b top] - [c_for-each top][d_for-each top];[e top] - [f_for-each top][g_for-each top][h_for-each top];[i top] - [j_for-each top][k_for-each top][l_for-each top][m_for-each top];[n top] - [o_for-each top][p_for-each top][q_for-each top][r_for-each top][s_for-each top];[t top] - ) - (case-lambda - [((a_for-each -> top) (listof a_for-each)) - void] - [((c_for-each d_for-each -> top) (listof c_for-each) (listof d_for-each)) - void] - [((f_for-each g_for-each h_for-each -> top) (listof f_for-each) (listof g_for-each) (listof h_for-each)) - void] - [((j_for-each k_for-each l_for-each m_for-each -> top) (listof j_for-each) (listof k_for-each) (listof l_for-each) (listof m_for-each)) - void] - [((o_for-each p_for-each q_for-each r_for-each s_for-each -> top) (listof o_for-each) (listof p_for-each) (listof q_for-each) (listof r_for-each) (listof s_for-each)) - void] - ; use at your own risks: you'll loose arity checking and get spurious errors - ; about '() not being a pair or about infinite lists (but the result of for-each - ; will be properly conservative) - ; The whole problem is that for-each needs a dependent type... - ;[(rest - ; (case-lambda - ; [(rest o p q r (listof s)) top]) - ; (listof o) (listof p) (listof q) (listof r) (listof (listof s))) - ; void] - ))) - - ; (delay expr) => (#%app make-promise (lambda () expr)) - ; if we have the arrow type in the argument of make-promise, then the application - ; will happen immediately, which we don't want. So instead - ; a will be the thunk, and having the arrow type for this thunk in the type for force - ; will force the application of the thunk inside force. - ; pp-type for promises just "forgets" to show the enclosing thunk part of the type. - ; It's ugly, but it works, and it works well enough to approximate memoization. - (make-promise (forall ([a_make-promise top]) - (a_make-promise -> (promise a_make-promise)))) - (force (forall ([a_force top]) - ((promise (-> a_force)) -> a_force))) - - (call-with-current-continuation (forall ([a_call/cc top] - [b_call/cc top]) - (((a_call/cc -> bottom) -> b_call/cc) - -> (union a_call/cc b_call/cc)))) - - ; correct, but currently triggers a bug. - ;(call-with-current-continuation (forall ([a top] - ; [b top]) - ; ((; continuation - ; (case-lambda [(rest a) bottom]) - ; ;result of body of lambda that - ; ;receives the continuation - ; -> b) - ; ; result of call/cc - ; -> (union (values a) b)))) - - ; multiple values are simulated internally as a list... - (values (forall ([a_values top]) - (case-lambda - [(rest a_values) (values a_values)] - ))) - - (call-with-values (forall ([a_call/vals top] ; one or multiple values - [b_call/vals top]) - (case-lambda - [((case-lambda - [() (values a_call/vals)]) - (case-lambda - [(rest a_call/vals) b_call/vals])) - b_call/vals]))) - - ; this limited values works fine, but then call-with-values doesnt', because all the clauses - ; in call-with-values would have only two arguments, making discrimination between the different - ; cases impossible. - ;(values (forall ([a top] - ; [b top][c top] - ; [d top][e top][f top] - ; [g top][h top][i top][j top] - ; [k top][l top][m top][n top][o top]) - ; (case-lambda - ; [() (values)] - ; [(a) (values a)] - ; [(b c) (values b c)] - ; [(d e f) (values d e f)] - ; [(g h i j) (values g h i j)] - ; [(k l m n o) (values k l m n o)]))) - ; - ;(call-with-values (forall ([a top][b top] - ; [c top][d top][e top]) - ; (case-lambda - ; [((case-lambda [() (values a)]) (case-lambda [(a) b])) b] - ; [((case-lambda [() (values c d)]) (case-lambda [(c d) e])) e] - ; ))) - - (dynamic-wind (forall ([a_dyn/w top]) - ((-> top) (-> a_dyn/w) (-> top) -> a_dyn/w))) - - - ; 6.5 Eval - - ; letter is a subtype of char, all the number types are subtypes of number - ; see section 7.1.2 of R5RS for the complete definition of datum - (eval ((rec-type ([datum (union simple-datum compound-datum)] - [simple-datum (union boolean number char string symbol)] - ;[compound-datum (union list-datum vector-datum)] - [compound-datum (union list-datum (vector datum))] - [list-datum (union () - (cons datum list-datum) - (cons datum datum))] - ;[vector-datum (vector datum)] - ) - datum) env -> (union top #f))) - - (scheme-report-environment (5 -> env)) - (null-environment (5 -> env)) - - (interaction-environment (-> env)) - - - ; 6.6.1 Ports - - ; R5RS doesn't always explicitely differentiate between input and output ports... - - (call-with-input-file (forall ([a_call/if top]) - (string (input-port -> a_call/if) -> a_call/if))) - (call-with-output-file (forall ([a_call/of top]) - (string (output-port -> a_call/of) -> a_call/of))) - - (input-port? (top -> boolean)) - (output-port? (top -> boolean)) - - (current-input-port (-> input-port)) - (current-output-port (-> output-port)) - - (with-input-from-file (forall ([a_with/if top]) - (string (-> a_with/if) -> a_with/if))) - (with-output-to-file (forall ([a_with/of top]) - (string (-> a_with/of) -> a_with/of))) - - (open-input-file (string -> input-port)) - - (open-output-file (string -> output-port)) - - (close-input-port (input-port -> void)) - (close-output-port (output-port -> void)) - - - ; 6.6.2 Input - - ; eof is included in top, but #f needs to be included explicitely - ; because of the simplistic way if-dependency is done - (read (case-lambda - [() (union top #f)] - [(input-port) (union top #f)])) - - (read-char (case-lambda - [() char] - [(input-port) char])) - - (peek-char (case-lambda - [() char] - [(input-port) char])) - - (eof-object? (top -> boolean)) - - (char-ready? (case-lambda - [() boolean] - [(input-port) boolean])) - - - ; 6.6.3 Output - - (write (case-lambda - [(top) void] - [(top output-port) void])) - - (display (case-lambda - [(top) void] - [(top output-port) void])) - - (newline (case-lambda - [() void] - [(output-port) void])) - - (write-char (case-lambda - [(char) void] - [(char output-port) void])) - - - ; 6.6.4 System interface - - (load (string -> (union top #f))) - - (transcript-on (string -> void)) - (transcript-off (-> void)) - - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; not R5RS, just for testing - - ; (if test then) macro-expanded into (if test then (void)) - (void (-> void)) - - (null ()) - -; (id (forall ([a_id top]) (a_id -> a_id))) -; (make-func (-> (-> 1))) -; (foo (cons 1 2)) -; (pi 3.1) -; ; one required argument that has to be a list, the elements are then extracted -; (gather-one1 (forall ([a_go1 top]) -; ((listof a_go1) -> a_go1))) -; (gather-one2 (forall ([a_go2 top]) -; (case-lambda -; [((listof a_go2)) a_go2]))) -; ; unknown number of arguments that are converted into a list by the rest argument, -; ; then extracted -; (gather-many1 (forall ([a_gm1 top]) -; (a_gm1 *-> a_gm1))) -; (gather-many2 (forall ([a_gm2 top]) -; (case-lambda -; [(rest (listof a_gm2)) a_gm2]))) -; ; don't try this at home -; ;(gather-other (forall ([a top]) -; ; ((a) *-> a))) -; -; (gen-nums (-> (listof number))) -; -; (apply-gen (forall ([a_app/gen top] -; [b_app/gen top]) -; (case-lambda -; [((case-lambda [(rest a_app/gen) b_app/gen]) a_app/gen) b_app/gen]))) -; -; (lnum (forall ([a_lnum top]) -; ((listof a_lnum) -> a_lnum))) - -; ; ALGOL60 primitives and runtime, to be able to analyze the expanded version -; -; (!= (number number -> boolean)) -; (! (boolean -> boolean)) -; (& (boolean boolean -> boolean)) -; (\| (boolean boolean -> boolean)) -; (=> (boolean boolean -> boolean)) -; (== (boolean boolean -> boolean)) -; -; (sign (forall ([a top]) -; ((real -> a) (-> real) -> a))) -; (entier (forall ([a top]) -; ((real -> a) (-> real) -> a))) -; -; (a60:sin (forall ([a top]) -; ((real -> a) (-> real) -> a))) -; (a60:cos (forall ([a top]) -; ((real -> a) (-> real) -> a))) -; (a60:arctan (forall ([a top]) -; ((real -> a) (-> real) -> a))) -; (a60:sqrt (forall ([a top]) -; ((real -> a) (-> real) -> a))) -; (a60:abs (forall ([a top]) -; ((real -> a) (-> real) -> a))) -; (a60:ln (forall ([a top]) -; ((real -> a) (-> real) -> a))) -; (a60:exp (forall ([a top]) -; ((real -> a) (-> real) -> a))) -; -; (prints (forall ([a top]) -; ((void -> a) (-> top) -> a))) -; (printn (forall ([a top]) -; ((void -> a) (-> top) -> a))) -; (printsln (forall ([a top]) -; ((void -> a) (-> top) -> a))) -; (printnln (forall ([a top]) -; ((void -> a) (-> top) -> a))) -; -; ; Algol60 runtime support -; -; ;(a60:array (struct a60:array (dependant type))) -; ;(a60:switch (struct a60:switch (choices)) -; -; (undefined undefined) -; -; (check-boolean (forall ([a top]) (a -> a))) -; (goto (forall ([a top]) ((-> a) -> a))) -; (get-value (forall ([a top]) ((-> a) -> a))) -; (set-target! (forall ([a top][b top]) -; ((a -> b) a -> b))) -; ;make-array -; ;array-ref -; ;array-set! -; ;make-switch -; ;switch-ref -; -; (coerce (forall ([a top]) -; (symbol a -> a))) -; -; -; ; R5RS runtime support -; -; (void (-> void)) -; -; (= (real real -> boolean)) -; (< (real real -> boolean)) -; (> (real real -> boolean)) -; (<= (real real -> boolean)) -; (>= (real real -> boolean)) -; -; (+ (real real -> real)) -; (* (real real -> real)) -; (- (real real -> real)) -; (/ (real real -> real)) -; -; (quotient (integer integer -> integer)) -; (remainder (integer integer -> integer)) -; (modulo (integer integer -> integer)) -; -; (values (forall ([a_values top]) -; (case-lambda -; [(rest a_values) (values a_values)] -; ))) - - - ) diff --git a/collects/mrflow/sba-errors.ss b/collects/mrflow/sba-errors.ss deleted file mode 100644 index 0472965835..0000000000 --- a/collects/mrflow/sba-errors.ss +++ /dev/null @@ -1,61 +0,0 @@ - -(module sba-errors (lib "mrflow.ss" "mrflow") - (require - (prefix cst: "constants.ss") - (prefix lab: "labels.ss") - ;"assoc-set-list.ss" - "assoc-set-hash.ss" - ) - - ; (listof label) symbol string - ; need this before the contracts because of sba-error? - (define-struct sba-error (labels gravity message) (make-inspector)) - - ; (assoc-setof label (listof sba-error)) - ; we use a list instead of a set for the sba-errors, because that's what error-table-get - ; has to return anyway - (define-struct error-table (assoc-set)) - - (provide/contract - (sba-error-gravity (sba-error? . -> . (symbols 'red 'orange 'green))) - (sba-error-message (sba-error? . -> . string?)) - (error-table-make (-> error-table?)) - (error-table? (any/c . -> . boolean?)) - (error-table-set (error-table? (listof lab:label?) (symbols 'red 'orange 'green) string? . -> . void?)) - (error-table-get (error-table? lab:label? . -> . (listof sba-error?))) - ) - - ; -> error-table - (define (error-table-make) - (make-error-table (assoc-set-make))) - - ; top -> boolean - ; error-table? comes from the structure definition - - ; error-table (listof label) (union 'red 'orange 'green) string -> void - ; adds error to the error list for each label - ; we use terms instead of labels as the key, because a primitive will have several labels - ; associated with it (one created from the program text, and at least one created from the - ; type for that primitive), so we need to use as key something unique about the primitive. - (define (error-table-set error-table labels gravity message) - (let ([assoc-set (error-table-assoc-set error-table)] - [error (make-sba-error labels gravity message)]) - (for-each (lambda (label) - (let ([term (lab:label-term label)]) - (if (syntax-position term) - (assoc-set-set - assoc-set - term - (cons error (assoc-set-get assoc-set term cst:thunk-empty)) - #f) - (printf "~a error detected for term ~a: ~a~n" - gravity - (syntax-object->datum term) - message)))) - labels))) - - ; error-table label -> (listof sba-error) - (define (error-table-get error-table label) - (assoc-set-get (error-table-assoc-set error-table) (lab:label-term label) cst:thunk-empty)) - - ) diff --git a/collects/mrflow/set-exn.ss b/collects/mrflow/set-exn.ss deleted file mode 100644 index f13c4e35a7..0000000000 --- a/collects/mrflow/set-exn.ss +++ /dev/null @@ -1,33 +0,0 @@ -; exceptions for sets -; This file is required by both set-hash.ss and set-list.ss -; so we can't use contracts here because the sets are not always the same. - -(module set-exn mzscheme - (provide - (struct exn:set:value-not-found (set value)) - (struct exn:set:duplicate-value (set value)) - exn:set - exn:set? - raise-value-not-found-exn - raise-duplicate-value-exn - ) - - (define-struct (exn:set exn) ()) - (define-struct (exn:set:value-not-found exn:set) (set value)) - (define-struct (exn:set:duplicate-value exn:set) (set value)) - - ; string set value -> void - (define (raise-value-not-found-exn fct-name set value) - (raise (make-exn:set:value-not-found - (format "~a: value ~a not found in set ~a" fct-name value set) - (current-continuation-marks) - set value))) - - ; string set value -> void - (define (raise-duplicate-value-exn fct-name set value) - (raise (make-exn:set:duplicate-value - (format "~a: value ~a already in set ~a" fct-name value set) - (current-continuation-marks) - set value))) - - ) diff --git a/collects/mrflow/set-hash.ss b/collects/mrflow/set-hash.ss deleted file mode 100644 index 499e4bc12b..0000000000 --- a/collects/mrflow/set-hash.ss +++ /dev/null @@ -1,255 +0,0 @@ -; sets implementation, using hash tables. -; - value equality based on eq? by default, uses equal? if given the 'equal flag -; - raises exn:set:value-not-found if value not in set when trying -; to remove a value. -; - raise exn:set:duplicate-value by default when trying to add a value to a -; set where it already exists -; - strange things might happen if you use set-union, set-intersection, -; or set-difference with two sets that don't use the same comparaison -; function: you might end up with duplicate values in some sets. - -(module set-hash (lib "mrflow.ss" "mrflow") - (require - mzlib/etc ; for opt-lambda - "set-exn.ss" ; no prefix so we can re-provide - ) - - ; table = (hashtableof value value) - (define-struct set (cardinality table)) - - (provide/contract - (exn:set? (any/c . -> . boolean?)) - (struct (exn:set:value-not-found exn:set) ((message (and/c string? immutable?)) - (continuation-marks continuation-mark-set?) - (set set?) - (value any/c))) - (struct (exn:set:duplicate-value exn:set) ((message (and/c string? immutable?)) - (continuation-marks continuation-mark-set?) - (set set?) - (value any/c))) - (set-make (() ((symbols 'equal)) . opt-> . set?)) - (set-reset (set? . -> . set?)) - (set? (any/c . -> . boolean?)) - (set-set ((set? any/c) (boolean?) . opt-> . set?)) - (set-in? (set? any/c . -> . boolean?)) - (set-remove ((set? any/c) (boolean?) . opt-> . set?)) - (set-cardinality (set? . -> . non-negative-exact-integer?)) - (set-empty? (set? . -> . boolean?)) - (set-copy (set? . -> . set?)) - (set-map (set? (any/c . -> . any) . -> . (listof any/c))) - (set-fold (set? (any/c any/c . -> . any) any/c . -> . any)) - (set-for-each (set? (any/c . -> . any) . -> . set?)) - (set-for-each! (set? (any/c . -> . any) . -> . set?)) - (set-filter ((set? (any/c . -> . boolean?)) ((symbols 'new 'same)) . opt-> . set?)) - (set-union ((set? set?) ((symbols 'new 'first 'second)) . opt-> . set?)) - (set-intersection ((set? set?) ((symbols 'new 'first 'second)) . opt-> . set?)) - (set-difference ((set? set?) ((symbols 'new 'first 'second)) . opt-> . set?)) - (set-subset? (set? set? . -> . boolean?)) - ) - - ; (opt 'equal) -> set - ; we test the optional argument ourselves to preserve data abstraction even in the - ; presence of an exception - (define set-make - (case-lambda - [() (make-set 0 (make-hash-table))] - [(flag) (make-set 0 (make-hash-table 'equal))])) - - ; set -> set - (define (set-reset set) - (set-set-table! set (make-hash-table)) - (set-set-cardinality! set 0) - set) - - ; value -> boolean - ; set? comes from the structure definition - - ; set value (opt boolean) -> set - (define set-set - (let ([dummy (gensym)]) - (opt-lambda (set value (exn? #t)) - (if (set-in? set value) - (when exn? - (raise-duplicate-value-exn "set-set" set value)) - (begin - (set-set-cardinality! set (add1 (set-cardinality set))) - (hash-table-put! (set-table set) value dummy))) - set))) - - ; set value -> boolean - (define set-in? - (let* ([sym (gensym)] - [sym-thunk (lambda () sym)]) - (lambda (set value) - (not (eq? sym (hash-table-get (set-table set) value sym-thunk)))))) - - ; set value (opt boolean) -> set - (define set-remove - (opt-lambda (set value (exn? #t)) - (if (set-in? set value) - (begin - (set-set-cardinality! set (sub1 (set-cardinality set))) - (hash-table-remove! (set-table set) value)) - (when exn? - (raise-value-not-found-exn "set-remove" set value))) - set)) - - ; set -> exact-non-negative-integer - ; set-cardinality comes from the structure definition - - ; set -> boolean - (define (set-empty? set) - (= 0 (set-cardinality set))) - - ; set -> set - (define (set-copy set) - (let ([new-table (make-hash-table)]) - (hash-table-for-each (set-table set) - (lambda (key value) - (hash-table-put! new-table key value))) - (make-set (set-cardinality set) - new-table))) - - ; set (value -> value) -> (listof value) - (define (set-map set f) - (let ([binary-f (lambda (value dummy) - (f value))]) - (hash-table-map (set-table set) binary-f))) - - ; set (value value -> value) value -> value - (define (set-fold set f acc) - (let ([acc acc]) - (hash-table-for-each (set-table set) - (lambda (value dummy) - (set! acc (f value acc)))) - acc)) - - ; set (value -> value) -> set - (define (set-for-each set f) - (let ([binary-f (lambda (value dummy) - (f value))]) - (hash-table-for-each (set-table set) binary-f)) - set) - - ; set (value -> value) -> set - ; it's up to the user to make sure f is injective. Otherwise we might end up with - ; a smaller set and the wrong cardinality. - (define (set-for-each! set f) - (let ([new-table (make-hash-table)]) - (hash-table-for-each (set-table set) - (lambda (value dummy) - (hash-table-put! new-table (f value) dummy))) - (set-set-table! set new-table)) - set) - - ; set (value -> boolean) (opt (union 'new 'same)) -> set - (define set-filter - (let (; set (value -> boolean) -> set - [filter-into-new-set - (lambda (set tester) - (let ([table (make-hash-table)] - [count 0]) - (hash-table-for-each (set-table set) - (lambda (value dummy) - (when (tester value) - (hash-table-put! table value dummy) - (set! count (add1 count))))) - (make-set count table)))]) - (opt-lambda (set tester (which-set 'new)) - (let ([new-set (filter-into-new-set set tester)]) - (case which-set - [(new) new-set] - [(same) - (set-set-table! set (set-table new-set)) - (set-set-cardinality! set (set-cardinality new-set)) - set]))))) - - ; set set (opt (union 'new 'first 'second)) -> set - (define set-union - (let (; set set -> set - [union-second-set-into-first - (lambda (set1 set2) - (let ([table (set-table set1)] - [count (set-cardinality set1)]) - (hash-table-for-each (set-table set2) - (lambda (value dummy) - (unless (set-in? set1 value) - (hash-table-put! table value dummy) - (set! count (add1 count))))) - (set-set-cardinality! set1 count)) - set1)]) - (opt-lambda (set1 set2 (which-set 'new)) - (case which-set - [(new) - ; copying is presumably faster than testing - (if (< (set-cardinality set1) (set-cardinality set2)) - (union-second-set-into-first (set-copy set2) set1) - (union-second-set-into-first (set-copy set1) set2))] - [(first) (union-second-set-into-first set1 set2)] - [(second) (union-second-set-into-first set2 set1)])))) - - ; set set (opt (union 'new 'first 'second)) -> set - (define set-intersection - (let (; set set -> set - [intersect-into-new-set - (lambda (set1 set2) - (let ([table (make-hash-table)] - [count 0]) - (hash-table-for-each (set-table set1) - (lambda (value dummy) - (when (set-in? set2 value) - (hash-table-put! table value dummy) - (set! count (add1 count))))) - (make-set count table)))]) - (opt-lambda (set1 set2 (which-set 'new)) - (let ([new-set - (if (< (set-cardinality set1) (set-cardinality set2)) - (intersect-into-new-set set1 set2) - (intersect-into-new-set set2 set1))]) - (case which-set - [(new) new-set] - [(first) - (set-set-table! set1 (set-table new-set)) - (set-set-cardinality! set1 (set-cardinality new-set)) - set1] - [(second) - (set-set-table! set2 (set-table new-set)) - (set-set-cardinality! set2 (set-cardinality new-set)) - set2]))))) - - ; set set (opt (union 'new 'first 'second)) -> set - (define set-difference - (let (; set set -> set - [difference-into-new-set - (lambda (set1 set2) - (let ([table (make-hash-table)] - [count 0]) - (hash-table-for-each (set-table set1) - (lambda (value dummy) - (unless (set-in? set2 value) - (hash-table-put! table value dummy) - (set! count (add1 count))))) - (make-set count table)))]) - (opt-lambda (set1 set2 (which-set 'new)) - (let ([new-set (difference-into-new-set set1 set2)]) - (case which-set - [(new) new-set] - [(first) - (set-set-table! set1 (set-table new-set)) - (set-set-cardinality! set1 (set-cardinality new-set)) - set1] - [(second) - (set-set-table! set2 (set-table new-set)) - (set-set-cardinality! set2 (set-cardinality new-set)) - set2]))))) - - ; set set -> boolean - (define (set-subset? set1 set2) - (let/ec k - (hash-table-for-each (set-table set1) - (lambda (value dummy) - (unless (set-in? set2 value) - (k #f)))) - #t)) - - ) diff --git a/collects/mrflow/set-list.ss b/collects/mrflow/set-list.ss deleted file mode 100644 index 2d21cf0294..0000000000 --- a/collects/mrflow/set-list.ss +++ /dev/null @@ -1,347 +0,0 @@ -; sets implementation, using lists. -; - value equality based on eq? by default, uses equal? if given the 'equal flag -; - raises exn:set:value-not-found if value not in set when trying -; to remove a value. -; - raise exn:set:duplicate-value by default when trying to add a value to a -; set where it already exists -; - strange things might happen if you use set-union, set-intersection, -; or set-difference with two sets that don't use the same comparaison -; function: you might end up with duplicate values in some sets. -; -; Note: lots of set! and tail-recursive loops in this code, for speed - -(module set-list (lib "mrflow.ss" "mrflow") - (require - mzlib/list ; for foldr - mzlib/etc ; for opt-lambda - "set-exn.ss" ; no prefix so we can re-provide - ) - - ; table = (listof (cons value value)) - (define-struct set (=? cardinality table)) - - (provide/contract - (exn:set? (any/c . -> . boolean?)) - (struct (exn:set:value-not-found exn:set) ((message (and/c string? immutable?)) - (continuation-marks continuation-mark-set?) - (set set?) - (value any/c))) - (struct (exn:set:duplicate-value exn:set) ((message (and/c string? immutable?)) - (continuation-marks continuation-mark-set?) - (set set?) - (value any/c))) - (set-make (() ((symbols 'equal)) . opt-> . set?)) - (set-reset (set? . -> . set?)) - (set? (any/c . -> . boolean?)) - (set-set ((set? any/c) (boolean?) . opt-> . set?)) - (set-in? (set? any/c . -> . boolean?)) - (set-remove ((set? any/c) (boolean?) . opt-> . set?)) - (set-cardinality (set? . -> . non-negative-exact-integer?)) - (set-empty? (set? . -> . boolean?)) - (set-copy (set? . -> . set?)) - (set-map (set? (any/c . -> . any) . -> . (listof any/c))) - (set-fold (set? (any/c any/c . -> . any) any/c . -> . any)) - (set-for-each (set? (any/c . -> . any) . -> . set?)) - (set-for-each! (set? (any/c . -> . any) . -> . set?)) - (set-filter ((set? (any/c . -> . boolean?)) ((symbols 'new 'same)) . opt-> . set?)) - (set-union ((set? set?) ((symbols 'new 'first 'second)) . opt-> . set?)) - (set-intersection ((set? set?) ((symbols 'new 'first 'second)) . opt-> . set?)) - (set-difference ((set? set?) ((symbols 'new 'first 'second)) . opt-> . set?)) - (set-subset? (set? set? . -> . boolean?)) - ) - - ; (opt 'equal) -> set - ; we test the optional argument ourselves to preserve data abstraction even in the - ; presence of an exception - (define set-make - (case-lambda - [() (make-set eq? 0 '())] - [(flag) (make-set equal? 0 '())])) - - ; set -> set - ; doesn't change =? - (define (set-reset set) - (set-set-table! set '()) - (set-set-cardinality! set 0) - set) - - ; value -> boolean - ; set? comes from the structure definition - - ; set value (opt boolean) -> set - (define set-set - (opt-lambda (set value (exn? #t)) - (let ([=? (set-=? set)] - [original-table (set-table set)]) - (set-set-table! set (let loop ([table original-table]) - (if (null? table) - (begin - (set-set-cardinality! set (add1 (set-cardinality set))) - (cons value original-table)) - (if (=? (car table) value) - (if exn? - (raise-duplicate-value-exn "set-set" set value) - ; silently ignore - original-table) - (loop (cdr table))))))) - set)) - - ; set value -> boolean - (define (set-in? set value) - (let ([=? (set-=? set)]) - (ormap (lambda (current-value) - (=? current-value value)) - (set-table set)))) - - ; set value (opt boolean) -> set - (define set-remove - (opt-lambda (set value (exn? #t)) - (let ([=? (set-=? set)] - [original-table (set-table set)]) - (set-set-table! set - (let loop ([table original-table] - [previous #f]) - (if (null? table) - (if exn? - (raise-value-not-found-exn "set-remove" set value) - ; silently ignore - original-table) - (if (=? (car table) value) - (begin - (set-set-cardinality! set (sub1 (set-cardinality set))) - (if previous - (begin - ; return shortened table - (set-cdr! previous (cdr table)) - original-table) - (cdr original-table))) - (loop (cdr table) table)))))) - set)) - - ; set -> exact-non-negative-integer - ; set-cardinality comes from the structure definition - - ; set -> boolean - (define (set-empty? set) - (= 0 (set-cardinality set))) - - ; (listof value) (listof value) -> (listof value) - ; creates a (reversed) copy of l1 (to prevent list sharing between sets) and prefixes l2 with it - (define (copy-reverse-and-prefix-lists l1 l2) - (let loop ([l1 l1] - [l2 l2]) - (if (null? l1) - l2 - (loop (cdr l1) (cons (car l1) l2))))) - - ; (listof value) -> (listof value) - (define (copy-list l) - (copy-reverse-and-prefix-lists l '())) - - ; set -> set - (define (set-copy set) - (make-set (set-=? set) - (set-cardinality set) - (copy-list (set-table set)))) - - ; set (value -> value) -> (listof value) - (define (set-map set f) - (map f (set-table set))) - - ; set (value value -> value) value -> value - (define (set-fold set f acc) - (foldr f acc (set-table set))) - - ; set (value -> value) -> set - (define (set-for-each set f) - (for-each f (set-table set)) - set) - - ; set (value -> value) -> set - ; it's up to the user to make sure f is injective. Otherwise we might end up with - ; duplicates in the set. - ; we know lists are never shared between sets, so we can set-cdr! - (define (set-for-each! set f) - (let loop ([table (set-table set)]) - (unless (null? table) - (set-car! table (f (car table))) - (loop (cdr table)))) - set) - - ; set (value -> boolean) (opt (union 'new 'same)) -> set - (define set-filter - (let (; set (value -> boolean) -> set - [filter-into-new-set - (lambda (set tester) - (let loop ([table (set-table set)] - [new-table '()] - [count 0]) - (if (null? table) - (make-set (set-=? set) count new-table) - (let ([value (car table)]) - (if (tester value) - (loop (cdr table) (cons value new-table) (add1 count)) - (loop (cdr table) new-table count))))))]) - (opt-lambda (set tester (which-set 'new)) - (let ([new-set (filter-into-new-set set tester)]) - (case which-set - [(new) new-set] - [(same) - (set-set-table! set (set-table new-set)) - (set-set-cardinality! set (set-cardinality new-set)) - set]))))) - - ; set set (opt (union 'new 'first 'second)) -> set - (define set-union - (opt-lambda (set1 set2 (which-set 'new)) - (let* ([=? (set-=? set1)] - [new-set - (let loop ([table1 (set-table set1)] - ; we shouldn't modify the original list - [table2 (copy-list (set-table set2))] - [count1 (set-cardinality set1)] - [count2 (set-cardinality set2)] - [acc '()] - [count 0]) - (if (null? table1) - ; we have already copied table2, so we can destructively modify it - (make-set =? (+ count count2) - (append! table2 acc)) - (if (null? table2) - (make-set =? (+ count count1) - (copy-reverse-and-prefix-lists table1 acc)) - (let ([value1 (car table1)]) - ; search table2 for same value - (let loop-set2 ([t2 table2] - [previous #f]) - (if (null? t2) - (begin - (set! acc (cons value1 acc)) - (set! count (add1 count)) - (set! table1 (cdr table1)) - (set! count1 (sub1 count1))) - (if (=? value1 (car t2)) - (begin - (set! acc (cons value1 acc)) - (set! count (add1 count)) - (set! table1 (cdr table1)) - (set! count1 (sub1 count1)) - (if previous - (set-cdr! previous (cdr t2)) - (set! table2 (cdr table2))) - (set! count2 (sub1 count2))) - (loop-set2 (cdr t2) t2)))) - (loop table1 table2 count1 count2 acc count)))))]) - (case which-set - [(new) new-set] - [(first) - (set-set-cardinality! set1 (set-cardinality new-set)) - (set-set-table! set1 (set-table new-set)) - set1] - [(second) - (set-set-cardinality! set2 (set-cardinality new-set)) - (set-set-table! set2 (set-table new-set)) - set2])))) - - ; set set (opt (union 'new 'first 'second)) -> set - (define set-intersection - (opt-lambda (set1 set2 (which-set 'new)) - (let* ([=? (set-=? set1)] - [new-set - (let loop ([table1 (set-table set1)] - ; we shouldn't modify the original list - [table2 (copy-list (set-table set2))] - [count1 (set-cardinality set1)] - [count2 (set-cardinality set2)] - [acc '()] - [count 0]) - (if (null? table1) - (make-set =? count acc) - (if (null? table2) - (make-set =? count acc) - (let ([value1 (car table1)]) - ; search table2 for same value - (let loop-set2 ([t2 table2] - [previous #f]) - (if (null? t2) - (begin - (set! table1 (cdr table1)) - (set! count1 (sub1 count1))) - (if (=? value1 (car t2)) - (begin - (set! acc (cons value1 acc)) - (set! count (add1 count)) - (set! table1 (cdr table1)) - (set! count1 (sub1 count1)) - (if previous - (set-cdr! previous (cdr t2)) - (set! table2 (cdr table2))) - (set! count2 (sub1 count2))) - (loop-set2 (cdr t2) t2)))) - (loop table1 table2 count1 count2 acc count)))))]) - (case which-set - [(new) new-set] - [(first) - (set-set-cardinality! set1 (set-cardinality new-set)) - (set-set-table! set1 (set-table new-set)) - set1] - [(second) - (set-set-cardinality! set2 (set-cardinality new-set)) - (set-set-table! set2 (set-table new-set)) - set2])))) - - ; set set (opt (union 'new 'first 'second)) -> set - (define set-difference - (opt-lambda (set1 set2 (which-set 'new)) - (let* ([=? (set-=? set1)] - [new-set - (let loop ([table1 (set-table set1)] - ; we shouldn't modify the original list - [table2 (copy-list (set-table set2))] - [count1 (set-cardinality set1)] - [count2 (set-cardinality set2)] - [acc '()] - [count 0]) - (if (null? table1) - (make-set =? count acc) - (if (null? table2) - (make-set =? (+ count count1) - (copy-reverse-and-prefix-lists table1 acc)) - (let ([value1 (car table1)]) - ; search table2 for same value - (let loop-set2 ([t2 table2] - [previous #f]) - (if (null? t2) - (begin - (set! acc (cons value1 acc)) - (set! count (add1 count)) - (set! table1 (cdr table1)) - (set! count1 (sub1 count1))) - (if (=? value1 (car t2)) - (begin - (set! table1 (cdr table1)) - (set! count1 (sub1 count1)) - (if previous - (set-cdr! previous (cdr t2)) - (set! table2 (cdr table2))) - (set! count2 (sub1 count2))) - (loop-set2 (cdr t2) t2)))) - (loop table1 table2 count1 count2 acc count)))))]) - (case which-set - [(new) new-set] - [(first) - (set-set-cardinality! set1 (set-cardinality new-set)) - (set-set-table! set1 (set-table new-set)) - set1] - [(second) - (set-set-cardinality! set2 (set-cardinality new-set)) - (set-set-table! set2 (set-table new-set)) - set2])))) - - ; set set -> boolean - (define (set-subset? set1 set2) - (andmap (lambda (value) - (set-in? set2 value)) - (set-table set1))) - - ) diff --git a/collects/mrflow/snips-and-arrows-model.ss b/collects/mrflow/snips-and-arrows-model.ss deleted file mode 100644 index ad3064c61d..0000000000 --- a/collects/mrflow/snips-and-arrows-model.ss +++ /dev/null @@ -1,842 +0,0 @@ -; DrScheme starts counting positions at 0, MzScheme starts counting positions at 1. -; Syntax objects use MzScheme positions, all the positions in this file use DrScheme -; positions. In all cases positions are exact non-negative integer. -; Among DrScheme positions, some are so-called new positions "new-pos" and some are -; old positions "old-pos". An old position is a position in the editor before any snip -; was inserted. A new position is the same position in the editor, but after snips -; might have been inserted. -; (define-type position exact-non-negative-integer) -; DrScheme also has locations, which are real x and y coordinates in the editor. -; (define-type location real) these are not used here but are used in the view part. -; -; This whole module can only deal with snips that are on the left of the label (see -; new-pos->old-pos and old-pos->new-pos for example). - -(module snips-and-arrows-model (lib "mrflow.ss" "mrflow") - (require - (prefix lst: mzlib/list) - - (prefix cst: "constants.ss") - ;"set-list.ss" - "set-hash.ss" - ;"assoc-set-list.ss" - "assoc-set-hash.ss" - "labels.ss" - ) - - ; DATA STRUCTURES - ; label label boolean - (define-struct arrow (start-label end-label tacked? color)) - - ; exact-non-negative-integer - (define-struct snip-group (size)) - - ; We could recompute left-new-pos on the fly (from the MzScheme - ; pos from the label itself and old-pos->new-pos) each time we needed to repaint, - ; but in practice we repaint much more often then we add snips, so we keep the pos - ; here as a cache which is computed once from scratch when we add the label to - ; displayed-arrows and which is then just updated each time we add a new snip. - ; Likewise, total-number-of-snips could be recomputed on the fly from snip-groups-by-type, - ; but is used as a cache to speed up old-pos->new-pos and new-pos->old-pos, which are used - ; pretty often. - ; Note that the data structure for a single arrow will be shared between two - ; label-gui-data structures: it will appear once in the "starting-arrows" - ; set for its start label, and once in the "ending-arrows" set for its end label. - ; We need this because we need to be able to click at the end of an arrow and - ; remove it if necessary. - (define-struct label-gui-data (; position - left-new-pos - ; exact-integer - span-change - ; exact-non-negative-integer - total-number-of-snips - ; (assoc-setof symbol snip-group) - snip-groups-by-type - ; (setof arrow) - starting-arrows - ; (setof arrow) - ending-arrows)) - - ; Note that several labels might have a given position (due to macros) and we use a list - ; instead of a set because we expect the sets to be very small (i.e. only one label is - ; normally registered for a given position, maybe two or three if there are macros, so - ; we do expect the list to be very short) but we expect a great number of them (i.e. we - ; expect pretty much all terms in a program to be registered). Sets have an better asymptotic - ; access time but onyl for big sets compared to lists, and they consumme much more memory than - ; lists (since we usually use the hash-table-based implementation of sets), so using lists - ; here for labels-by-mzscheme-position is probably the fastest and most memory efficient - ; solution here given our assumptions. - (define-struct source-gui-data (; (assoc-setof label label-gui-data) - label-gui-data-by-label - ; (assoc-setof non-negative-exact-integer (non-empty-listof label)) - labels-by-mzscheme-position - ; exact-non-negative-integer - total-number-of-snips)) - - (define-struct gui-model-state (; (assoc-setof source source-gui-data) - source-gui-data-by-source - ; (label -> top) - get-source-from-label - ; (label -> non-negative-exact-integer) - get-mzscheme-position-from-label - ; (label -> non-negative-exact-integer) - get-original-span-from-label - ; (label -> non-negative-exact-integer) - get-span-from-label - ; (listof symbol) - snip-type-list - )) - - (provide/contract - (make-gui-model-state ((label? . -> . any) - (label? . -> . non-negative-exact-integer?) - (label? . -> . non-negative-exact-integer?) - (listof symbol?) - . -> . gui-model-state?)) - (rename get-related-labels-from-drscheme-new-pos-and-source - get-related-labels-from-drscheme-pos-and-source - (gui-model-state? non-negative-exact-integer? any/c . -> . (listof label?))) - (rename gui-model-state-get-span-from-label - make-get-span-from-label-from-model-state - (gui-model-state? . -> . (label? . -> . non-negative-exact-integer?))) - - (for-each-source (gui-model-state? (any/c . -> . void?) . -> . void?)) - (register-source-with-gui (gui-model-state? any/c . -> . any)) - (is-source-registered? (gui-model-state? any/c . -> . boolean?)) - - (register-label-with-gui (gui-model-state? label? . -> . any)) - (get-position-from-label (gui-model-state? label? . -> . non-negative-exact-integer?)) - (user-change-terms (gui-model-state? - (listof label?) - any/c - non-negative-exact-integer? - . -> . (values non-negative-exact-integer? non-negative-exact-integer?))) - (for-each-label-in-source (gui-model-state? any/c (label? . -> . void?) . -> . void?)) - - (add-arrow (gui-model-state? (list/c label? label? string?) boolean? . -> . void?)) - (remove-arrows (gui-model-state? label? (or/c symbol? boolean?) boolean? . -> . void?)) - (remove-all-arrows (gui-model-state? . -> . void?)) - (for-each-arrow (gui-model-state? (non-negative-exact-integer? non-negative-exact-integer? non-negative-exact-integer? non-negative-exact-integer? any/c any/c boolean? string? . -> . void?) . -> . void?)) - (get-tacked-arrows-from-label (gui-model-state? label? . -> . non-negative-exact-integer?)) - - (for-each-snip-type (gui-model-state? (symbol? . -> . void?) . -> . void?)) - (label-has-snips-of-this-type? (gui-model-state? label? symbol? . -> . boolean?)) - (snips-currently-displayed-in-source? (gui-model-state? any/c . -> . boolean?)) - (add-snips (gui-model-state? label? symbol? any/c non-negative-exact-integer? . -> . non-negative-exact-integer?)) - (remove-inserted-snips (gui-model-state? label? symbol? any/c . -> . (values non-negative-exact-integer? non-negative-exact-integer?))) - ) - - ; (label -> top) - ; (label -> non-negative-exact-integer) - ; (label -> non-negative-exact-integer) - ; (listof symbol) - ; -> gui-model-state - (set! make-gui-model-state - (let ([real-make-gui-model-state make-gui-model-state]) - (lambda (get-source-from-label - get-mzscheme-position-from-label - get-span-from-label - snip-type-list) - (let ([source-gui-data-by-source (assoc-set-make)]) - (real-make-gui-model-state - source-gui-data-by-source - get-source-from-label - get-mzscheme-position-from-label - get-span-from-label - (lambda (label) - (let* ([span (get-span-from-label label)] - [source-gui-data - (assoc-set-get source-gui-data-by-source (get-source-from-label label))] - [label-gui-data - (assoc-set-get (source-gui-data-label-gui-data-by-label source-gui-data) - label cst:thunk-false)]) - (if label-gui-data - (+ span (label-gui-data-span-change label-gui-data)) - span))) - snip-type-list))))) - - - ; DRSCHEME / MZSCHEME CONVERSIONS - ; non-negative-exact-integer -> non-negative-exact-integer - (define drscheme-pos->mzscheme-pos add1) - - ; non-negative-exact-integer -> non-negative-exact-integer - (define mzscheme-pos->drscheme-pos sub1) - - - ; SOURCES - ; gui-model-state top -> top - (define (register-source-with-gui gui-model-state source) - (assoc-set-set (gui-model-state-source-gui-data-by-source gui-model-state) - source - (make-source-gui-data (assoc-set-make) - (assoc-set-make) - 0)) - source) - - ; gui-model-state top -> boolean - (define (is-source-registered? gui-model-state source) - (assoc-set-in? (gui-model-state-source-gui-data-by-source gui-model-state) source)) - - ; gui-model-state (top -> void) -> void - ; applies f to each source - (define (for-each-source gui-model-state f) - (assoc-set-for-each (gui-model-state-source-gui-data-by-source gui-model-state) - (lambda (source source-gui-data) - (f source))) - cst:void) - - ; gui-model-state top -> boolean - ; are we currently displaying some snips in the source? - (define (snips-currently-displayed-in-source? gui-model-state source) - (let ([source-gui-data - (assoc-set-get (gui-model-state-source-gui-data-by-source gui-model-state) - source cst:thunk-false)]) - (if source-gui-data - (< 0 (source-gui-data-total-number-of-snips source-gui-data)) - #f))) - - - ; LABELS - ; gui-model-state label -> exact-non-negative-integer - ; returns the left position of the expression. The computation is done from scratch, - ; so only use this function if the position hasn't been yet cached in the label's gui data. - (define (get-new-pos-from-label gui-model-state label) - (old-pos->new-pos - gui-model-state - (mzscheme-pos->drscheme-pos - ((gui-model-state-get-mzscheme-position-from-label gui-model-state) label)) - ((gui-model-state-get-source-from-label gui-model-state) label))) - - ; gui-model-state label -> exact-non-negative-integer - ; returns the left position of the expression represented by the label - (define (get-position-from-label gui-model-state label) - (let* ([source ((gui-model-state-get-source-from-label gui-model-state) label)] - [source-gui-data - (assoc-set-get (gui-model-state-source-gui-data-by-source gui-model-state) source)] - [label-gui-data-by-label - (source-gui-data-label-gui-data-by-label source-gui-data)] - [label-gui-data - (assoc-set-get label-gui-data-by-label label cst:thunk-false)]) - (if label-gui-data - (label-gui-data-left-new-pos label-gui-data) - (get-new-pos-from-label gui-model-state label)))) - - ; gui-model-state label -> (or/c top #f) - ; we register the source of the label and the label by its position, - ; but we don't associate any label-gui-data with it yet, to save memory. - ; We'll associate some label-gui-data with it on the fly, as needed (when - ; needing to remember some arrows or snips for that label, not before). - ; We return the source only the first time a label is registered for it - ; (the view part uses this to initialize the state of the source). - (define (register-label-with-gui gui-model-state label) - (let* ([source-gui-data-by-source - (gui-model-state-source-gui-data-by-source gui-model-state)] - [source - ((gui-model-state-get-source-from-label gui-model-state) label)] - [source-gui-data - (assoc-set-get source-gui-data-by-source source cst:thunk-false)] - [mzscheme-pos - ((gui-model-state-get-mzscheme-position-from-label gui-model-state) label)]) - (if source-gui-data - (let ([labels-by-mzscheme-position - (source-gui-data-labels-by-mzscheme-position source-gui-data)]) - ; So, in the good old days I used to check whether a given label was already registered - ; for the given position, and gave an error when such was the case. But macros can - ; duplicate terms, so in the good not-so-old days I added a test such that an error - ; would show up only if the labels didn't represent the same original term. But Matthew - ; then told me that a given term that's duplicated by a macro might be represented by - ; two syntax objects that are not eq?. So at that point I had the choice between - ; converting the two syntax-objects into sexprs and using equal? to check whether - ; they actually represented the same term (and that would have been only a heurisitc, - ; since it would not have detected bugs in a macro that gave the same position to - ; two identical source terms), or what I do now: just register all the labels no - ; matter what. This solution also means I don't have to have a get-term-from-label - ; function in my interface. - ; Note that we still make sure the exact same label is not already registered with - ; the gui, otherwise we'll try to add the same arrows twice which will lead to error - ; messages in add-one-arrow-end - (let ([currently-registered-labels-for-this-position - (assoc-set-get labels-by-mzscheme-position - mzscheme-pos - cst:thunk-empty)]) - (unless (memq label currently-registered-labels-for-this-position) - (assoc-set-set labels-by-mzscheme-position - mzscheme-pos - (cons label currently-registered-labels-for-this-position) - #f)) - #f)) - (begin - ; source unknown: register it and try again - (register-source-with-gui gui-model-state source) - (register-label-with-gui gui-model-state label) - source)))) - - ; gui-model-state (listof label) text% exact-integer -> (values non-negative-exact-integer non-negative-exact-integer) - ; Modify the span of the labels and move snips on the right, returning the interval - ; that has to be deleted and the new interval that has to be colored (for a total of - ; three numbers, since both intervals start at the same position) - ; We know from saav:user-change-terms that all the labels represent the same term - (define (user-change-terms gui-model-state labels source new-span) - (let* ([source-gui-data-by-source (gui-model-state-source-gui-data-by-source gui-model-state)] - [source-gui-data (assoc-set-get source-gui-data-by-source source)] - [label-gui-data-by-label (source-gui-data-label-gui-data-by-label source-gui-data)] - [label (car labels)] - [old-span ((gui-model-state-get-span-from-label gui-model-state) label)] - [change (- new-span old-span)] - [left-new-pos (get-position-from-label gui-model-state label)]) - (for-each - (lambda (label) - (let ([label-gui-data (assoc-set-get label-gui-data-by-label label cst:thunk-false)]) - (if label-gui-data - (set-label-gui-data-span-change! - label-gui-data - (+ change (label-gui-data-span-change label-gui-data))) - (assoc-set-set label-gui-data-by-label - label - (make-label-gui-data left-new-pos - change - 0 - (assoc-set-make) - (set-make) - (set-make)))))) - labels) - (move-poss gui-model-state source left-new-pos change + >) - (values (+ left-new-pos old-span) (+ left-new-pos new-span)))) - - ; gui-model-state top (label -> void) -> void - ; apply f to all registered labels - (define (for-each-label-in-source gui-model-state source f) - (let ([source-gui-data - (assoc-set-get (gui-model-state-source-gui-data-by-source gui-model-state) source)]) - (when source-gui-data - (assoc-set-for-each - (source-gui-data-labels-by-mzscheme-position source-gui-data) - (lambda (mzscheme-pos labels) - (for-each f labels))))) - cst:void) - - - ; POS AND SOURCE TO LABEL CONVERSIONS - ; gui-model-state non-negative-exact-integer top -> (listof label) - ; finds the labels corresponding to a given new-pos in a given source - (define (get-related-labels-from-drscheme-new-pos-and-source gui-model-state new-pos source) - (get-related-labels-from-drscheme-old-pos-and-source - gui-model-state - (new-pos->old-pos gui-model-state new-pos source) - source)) - - ; gui-model-state non-negative-exact-integer top -> (listof label) - ; we loop down starting from old-pos, until we find a label. Then we have to check - ; that the original old-pos falls within the original span of that label. - (define (get-related-labels-from-drscheme-old-pos-and-source gui-model-state old-pos source) - (let ([get-original-span-from-label - (gui-model-state-get-original-span-from-label gui-model-state)] - [source-gui-data - (assoc-set-get (gui-model-state-source-gui-data-by-source gui-model-state) - source cst:thunk-false)]) - (if source-gui-data - (let ([labels-by-mzscheme-position (source-gui-data-labels-by-mzscheme-position source-gui-data)] - [starting-mzscheme-pos (drscheme-pos->mzscheme-pos old-pos)]) - (let loop ([current-mzscheme-pos starting-mzscheme-pos]) - (if (> 0 current-mzscheme-pos) - '() - (let ([labels (assoc-set-get labels-by-mzscheme-position current-mzscheme-pos cst:thunk-false)]) - (if labels - ; Note that if the label's span is too small, we stop looping. - ; This means that in an expression like (abc def), if the mouse - ; pointer points at the space character, #f will be returned, - ; not the label for the whole expression. - (let ([mouse-distance (- starting-mzscheme-pos current-mzscheme-pos)]) - (lst:filter (lambda (label) - (< mouse-distance (get-original-span-from-label label))) - labels)) - (loop (sub1 current-mzscheme-pos))))))) - '()))) - - - ; OLD-POS / NEW-POS CONVERSIONS - ; gui-model-state exact-non-negative-integer top -> exact-non-negative-integer - ; converts an old position (before insertion of any snip) to a new position - ; (after insertion of all the currently inserted snips). - ; Note: the test is "<=", which means the new position is to the right of all - ; the current snips that have positions corresponding to the same old position - ; (i.e. to the right of all the snips that have already been inserted for that label). - (define (old-pos->new-pos gui-model-state old-pos source) - (let ([new-pos old-pos] - [get-mzscheme-position-from-label - (gui-model-state-get-mzscheme-position-from-label gui-model-state)] - [get-original-span-from-label - (gui-model-state-get-original-span-from-label gui-model-state)] - [get-span-from-label - (gui-model-state-get-span-from-label gui-model-state)] - [source-gui-data - (assoc-set-get (gui-model-state-source-gui-data-by-source gui-model-state) - source cst:thunk-false)]) - (when source-gui-data - (assoc-set-for-each - (source-gui-data-label-gui-data-by-label source-gui-data) - (lambda (label label-gui-data) - (let ([label-left-old-pos (mzscheme-pos->drscheme-pos (get-mzscheme-position-from-label label))]) - (cond - ; the order of the clauses is important here - ; old-pos is on the right of the original expression represented by the label - [(<= (+ label-left-old-pos (get-original-span-from-label label)) old-pos) - (set! new-pos (+ new-pos - (label-gui-data-span-change label-gui-data) - (label-gui-data-total-number-of-snips label-gui-data)))] - ; old-pos is somewhere in the middle of the expression represented by the label - ; then we have to take care of the case when the current expression is smaller than - ; the original expression (because an identifier was changed) - [(<= label-left-old-pos old-pos) - (if (<= (+ label-left-old-pos (get-span-from-label label)) old-pos) - ; expression has shrinked, and old-pos was in the part that disappeared, - ; so we make sure the new-pos is at least within the current expression - ; by acting as if old-pos were label-left-old-pos (i.e. moving old-pos - ; to the left end of the expression). Note that this makes old-pos->new-pos - ; not bijective anymore. - (set! new-pos (+ new-pos - (- label-left-old-pos old-pos) - (label-gui-data-total-number-of-snips label-gui-data))) - ; either expression has not shrinked, or if it has, old-pos is sufficiently - ; in the left part that we don't have to worry about it - (set! new-pos (+ new-pos - (label-gui-data-total-number-of-snips label-gui-data))))] - ; old-pos is on the left of the expression => do nothing - ))))) - new-pos)) - - ; gui-model-state exact-non-negative-integer top -> exact-non-negative-integer - ; Note: the test is "<", because there might a snip that has the exact same - ; position as new-pos, so, since a snip at position n is shown graphically - ; between position n and n+1, we don't want to take that snip into account - ; (i.e. that snip is on the right of the cursor or mouse pointer, not on the - ; left). - ; Note also that we have to be carefull: in old-pos->new-pos we add all the snips - ; to the new-pos when the label has an old-pos to the left of or at the cursor. - ; But here the cursor might be between two snips. So we have to consider each snip - ; separately, we can't consider them group by group anymore. - (define (new-pos->old-pos gui-model-state new-pos source) - (let ([old-pos new-pos] - [get-original-span-from-label - (gui-model-state-get-original-span-from-label gui-model-state)] - [get-span-from-label - (gui-model-state-get-span-from-label gui-model-state)] - [source-gui-data - (assoc-set-get (gui-model-state-source-gui-data-by-source gui-model-state) - source cst:thunk-false)]) - (when source-gui-data - (assoc-set-for-each - (source-gui-data-label-gui-data-by-label source-gui-data) - (lambda (label label-gui-data) - (let ([label-left-new-pos (label-gui-data-left-new-pos label-gui-data)] - [total-number-of-snips (label-gui-data-total-number-of-snips label-gui-data)]) - (cond - ; the order of the clauses is important here - ; new-pos is on the right of the expression represented by the label - [(<= (+ label-left-new-pos (get-span-from-label label)) new-pos) - (set! old-pos (- old-pos - (label-gui-data-span-change label-gui-data) - (label-gui-data-total-number-of-snips label-gui-data)))] - ; new-pos is somewhere in the middle of the expression represented by the label - ; then we have to take care of the case when the current expression is bigger than - ; the original expression (because an identifier was changed) - [(<= label-left-new-pos new-pos) - (if (<= (+ label-left-new-pos (get-original-span-from-label label)) new-pos) - ; expression has expanded, and new-pos was in the part that was added, - ; so we make sure the old-pos is at least within the current expression - ; by acting as if new-pos were label-left-new-pos (i.e. moving new-pos - ; to the left end of the expression). Note that this makes new-pos->old-pos - ; not bijective anymore. - (set! old-pos (- old-pos - (- new-pos label-left-new-pos) - (label-gui-data-total-number-of-snips label-gui-data))) - ; either expression has not expanded, or if it has, new-pos is sufficiently - ; in the left part that we don't have to worry about it - (set! old-pos (- old-pos - (label-gui-data-total-number-of-snips label-gui-data))))] - ; new-pos is on the left of the expression but in the middle of the snips - ; at that point we could either loop over the snips groups one by one and test - ; them using their left-new-pos, or we can directly compute the total number of - ; snips on the left of new-pos using the label's left-new-pos and - ; total-number-of-snips. Since the second method is easier, we do it that way. - [(<= (- label-left-new-pos total-number-of-snips) new-pos) - (set! old-pos (- old-pos - (- total-number-of-snips (- label-left-new-pos new-pos))))] - ; new-pos is on the left of the expression and the snips => do nothing - ))))) - old-pos)) - - ; gui-model-state top exact-non-negative-integer exact-integer - ; (exact-non-negative-integer exact-integer -> exact-integer) - ; (exact-non-negative-integer exact-integer -> boolean) -> void - ; moves all snips and arrows that are after start, by len. start is a new position (i.e. after - ; insertion of snips). We need to do all that so that old-pos->new-pos and new-pos->old-pos - ; and the arrow display keep working correctly when we add new snips in the middle of others. - (define (move-poss gui-model-state source start len add comp) - (let ([move-pos (lambda (pos) (if (comp pos start) (add pos len) pos))] - [source-gui-data - (assoc-set-get (gui-model-state-source-gui-data-by-source gui-model-state) source)]) - (assoc-set-for-each - (source-gui-data-label-gui-data-by-label source-gui-data) - (lambda (label label-gui-data) - (set-label-gui-data-left-new-pos! - label-gui-data (move-pos (label-gui-data-left-new-pos label-gui-data)))))) - cst:void) - - - ; ARROWS - ; gui-model-state (list label label string) boolean -> void - ; add one arrow going from start-label to end-label, duh. - (define (add-arrow gui-model-state arrow-info tacked?) - (let* ([start-label (car arrow-info)] - [end-label (cadr arrow-info)] - [new-arrow (make-arrow start-label end-label tacked? (caddr arrow-info))]) - (add-one-arrow-end gui-model-state - new-arrow - start-label - end-label - arrow-end-label - label-gui-data-starting-arrows - (lambda () (set-set (set-make) new-arrow)) - set-make) - (add-one-arrow-end gui-model-state - new-arrow - end-label - start-label - arrow-start-label - label-gui-data-ending-arrows - set-make - (lambda () (set-set (set-make) new-arrow))))) - - ; gui-model-state arrow label label (arrow -> label) (label-gui-data -> (setof arrow) - ; (-> (setof arrow)) (-> (setof arrow)) -> void - ; adds arrow structure to the label's gui data, for one end of the arrow - (define (add-one-arrow-end gui-model-state new-arrow this-end-label other-end-label - arrow-other-end-label-selector label-gui-data-this-end-arrow-set-selector - make-starting-arrow-set make-ending-arrow-set) - (let* ([this-end-source - ((gui-model-state-get-source-from-label gui-model-state) this-end-label)] - [this-end-source-gui-data - (assoc-set-get (gui-model-state-source-gui-data-by-source gui-model-state) this-end-source)] - [this-end-label-gui-data-by-label - (source-gui-data-label-gui-data-by-label this-end-source-gui-data)] - [this-end-label-gui-data - (assoc-set-get this-end-label-gui-data-by-label this-end-label cst:thunk-false)]) - (if this-end-label-gui-data - (let* ([this-end-arrow-set - (label-gui-data-this-end-arrow-set-selector this-end-label-gui-data)] - [same-arrow-set (set-filter this-end-arrow-set - (lambda (arrow) - (eq? other-end-label - (arrow-other-end-label-selector arrow))))]) - (if (set-empty? same-arrow-set) - ; the arrow doesn't already exist, so add the arrow to the start set - (set-set this-end-arrow-set new-arrow) - ; the arrow already exists - (let* ([new-arrow-tacked? (arrow-tacked? new-arrow)] - [old-arrow (if (= (set-cardinality same-arrow-set) 1) - (car (set-map same-arrow-set cst:id)) - (error 'add-one-arrow-end "duplicate arrows"))] - [old-arrow-tacked? (arrow-tacked? old-arrow)]) - (if new-arrow-tacked? - (if old-arrow-tacked? - (error 'add-one-arrow-end "tacked arrow already exists") - (error 'add-one-arrow-end "can't tack arrow over untacked one")) - (if old-arrow-tacked? - cst:void ; happens when moving mouse over label with tacked arrows - (error 'add-one-arrow-end "untacked arrow already exists")))))) - (assoc-set-set this-end-label-gui-data-by-label - this-end-label - (make-label-gui-data (get-new-pos-from-label gui-model-state this-end-label) - 0 - 0 - (assoc-set-make) - (make-starting-arrow-set) - (make-ending-arrow-set))))) - cst:void) - - ; gui-model-state label (or/c symbol boolean) boolean -> void - ; remove arrows starting at given label AND arrows ending at same given label - ; Note that assoc-set-get will fail if we try to remove non-existant arrows... - (define (remove-arrows gui-model-state start-label tacked? exn?) - (let* ([source-gui-data-by-source - (gui-model-state-source-gui-data-by-source gui-model-state)] - [get-source-from-label (gui-model-state-get-source-from-label gui-model-state)] - [source (get-source-from-label start-label)] - [source-gui-data (assoc-set-get source-gui-data-by-source source)] - [label-gui-data-by-label - (source-gui-data-label-gui-data-by-label source-gui-data)] - [start-label-gui-data - (if exn? - (assoc-set-get label-gui-data-by-label start-label) - (assoc-set-get label-gui-data-by-label start-label cst:thunk-false))]) - ; at this point, if the key was not found, either exn? was true and an exception - ; was raised, or it was false and start-label-gui-data is false - (when start-label-gui-data - (remove-both-ends source-gui-data-by-source - (label-gui-data-starting-arrows start-label-gui-data) - tacked? - arrow-end-label - label-gui-data-ending-arrows - get-source-from-label) - (remove-both-ends source-gui-data-by-source - (label-gui-data-ending-arrows start-label-gui-data) - tacked? - arrow-start-label - label-gui-data-starting-arrows - get-source-from-label))) - cst:void) - - ; (assoc-setof top source-gui-data) (setof arrow) (or/c symbol boolean) - ; (arrow -> label) (label-gui-data -> (setof arrow)) - ; (label -> top) - ; -> (setof arrow) - ; remove arrows starting at given label OR arrows ending at given - ; label (depending on selectors/settors) - ; the result is thrown away by the caller... - (define (remove-both-ends source-gui-data-by-source set tacked? - arrow-other-end-label-selector label-gui-data-other-end-arrow-set-selector - get-source-from-label) - (if (eq? tacked? 'all) - ; remove all the other ends and reset this end - ; we could do without this case and use the set-filter way used in the "else" case - ; of this if, but doing it that way here is faster because we don't bother testing - ; and removing each arrow from the set one by one, we just reset the whole thing. - (begin - (set-for-each set (lambda (arrow) - (remove-other-end source-gui-data-by-source arrow - arrow-other-end-label-selector label-gui-data-other-end-arrow-set-selector - get-source-from-label))) - (set-reset set)) - ; remove other end while filtering this set - (set-filter set - (lambda (arrow) - (if (eq? tacked? (arrow-tacked? arrow)) - (begin - (remove-other-end source-gui-data-by-source arrow - arrow-other-end-label-selector label-gui-data-other-end-arrow-set-selector - get-source-from-label) - #f) - #t)) - 'same))) - - ; (assoc-setof top source-gui-data) arrow (arrow -> label) (label-gui-data -> (setof arrow)) - ; (label -> top) -> (setof arrow) - ; removes one arrow structure reference corresponding to the remote end of the arrow we - ; are removing in remove-both-ends above. We know the arrow is there, so no need to test - ; whether label-gui-data-by-source-and-label and label-gui-data-by-label are false or not. - ; the result is thrown away by the caller... - (define (remove-other-end source-gui-data-by-source arrow - arrow-other-end-label-selector label-gui-data-other-end-arrow-set-selector - get-source-from-label) - (let* ([other-end-label (arrow-other-end-label-selector arrow)] - [other-end-source (get-source-from-label other-end-label)] - [other-end-source-gui-data - (assoc-set-get source-gui-data-by-source other-end-source)] - [other-end-label-gui-data - (assoc-set-get (source-gui-data-label-gui-data-by-label other-end-source-gui-data) - other-end-label)] - [other-end-arrow-set (label-gui-data-other-end-arrow-set-selector other-end-label-gui-data)]) - (set-remove other-end-arrow-set arrow))) - - ; gui-model-state -> void - ; remove all arrows in all sources - ; This is faster than looping over each source and then each label in each source and - ; then removing each arrow one by one for each label using remove-arrows. - (define (remove-all-arrows gui-model-state) - (let ([source-gui-data-by-source (gui-model-state-source-gui-data-by-source gui-model-state)]) - (assoc-set-for-each - source-gui-data-by-source - (lambda (source source-gui-data) - (assoc-set-for-each - (source-gui-data-label-gui-data-by-label source-gui-data) - (lambda (label label-gui-data) - (set-reset (label-gui-data-starting-arrows label-gui-data)) - (set-reset (label-gui-data-ending-arrows label-gui-data))))))) - cst:void) - - ; gui-model-state - ; (non-negative-exact-integer non-negative-exact-integer non-negative-exact-integer non-negative-exact-integer top top boolean string -> void) - ; -> void - ; applies f to each arrow. The args for f are: the left new-pos of the start label, the - ; left new-pos of the end label, the corresponding spans, the start and end sources, - ; whether the arrow is tacked or not, and the color. - (define (for-each-arrow gui-model-state f) - (let ([get-span-from-label (gui-model-state-get-span-from-label gui-model-state)] - [get-source-from-label (gui-model-state-get-source-from-label gui-model-state)] - [source-gui-data-by-source (gui-model-state-source-gui-data-by-source gui-model-state)]) - (assoc-set-for-each - source-gui-data-by-source - (lambda (start-source start-source-gui-data) - (let ([label-gui-data-by-label (source-gui-data-label-gui-data-by-label start-source-gui-data)]) - (assoc-set-for-each - label-gui-data-by-label - (lambda (start-label start-label-gui-data) - (set-for-each (label-gui-data-starting-arrows start-label-gui-data) - (lambda (arrow) - (let* ([end-label (arrow-end-label arrow)] - [end-source (get-source-from-label end-label)] - [end-source-gui-data ; the arrow exists, so this is not #f - (assoc-set-get source-gui-data-by-source end-source)] - [end-label-gui-data-by-label - (source-gui-data-label-gui-data-by-label end-source-gui-data)] - [end-label-gui-data - (assoc-set-get end-label-gui-data-by-label end-label)]) - (f (label-gui-data-left-new-pos start-label-gui-data) - (label-gui-data-left-new-pos end-label-gui-data) - (get-span-from-label start-label) - (get-span-from-label end-label) - start-source - end-source - (arrow-tacked? arrow) - (arrow-color arrow))))))))))) - cst:void) - - ; (gui-model-state label -> non-negative-exact-integer) - ; counts how many arrows starting or ending at a given label are tacked - (define (get-tacked-arrows-from-label gui-model-state label) - (let ([source-gui-data - (assoc-set-get (gui-model-state-source-gui-data-by-source gui-model-state) - ((gui-model-state-get-source-from-label gui-model-state) label) - cst:thunk-false)]) - (if source-gui-data - (let* ([label-gui-data-by-label (source-gui-data-label-gui-data-by-label source-gui-data)] - [label-gui-data (assoc-set-get label-gui-data-by-label label cst:thunk-false)]) - (if label-gui-data - (+ (set-cardinality (set-filter (label-gui-data-starting-arrows label-gui-data) arrow-tacked?)) - (set-cardinality (set-filter (label-gui-data-ending-arrows label-gui-data) arrow-tacked?))) - 0)) - 0))) - - - ; SNIPS - ; gui-model-state (symbol -> void) -> void - ; applies f to each type of snips (not the snips themselves, just the types). - (define (for-each-snip-type gui-model-state f) - (for-each f (gui-model-state-snip-type-list gui-model-state))) - - ; gui-model-state label symbol -> boolean - ; does the label have snips of a given type currently displayed by the gui? - (define (label-has-snips-of-this-type? gui-model-state label type) - (let ([source-gui-data - (assoc-set-get (gui-model-state-source-gui-data-by-source gui-model-state) - ((gui-model-state-get-source-from-label gui-model-state) label) - cst:thunk-false)]) - (if source-gui-data - (let ([label-gui-data - (assoc-set-get (source-gui-data-label-gui-data-by-label source-gui-data) - label cst:thunk-false)]) - (if label-gui-data - (assoc-set-in? (label-gui-data-snip-groups-by-type label-gui-data) type) - #f)) - #f))) - - ; (assoc-setof symbol snip-group) symbol (listof symbol) -> non-negative-exact-integer - ; counts how many snips are currently displayed on the right of the position where - ; the snips of the given type currently are or would be displayed - (define (get-number-of-snips-on-right-from-type snip-groups-by-type type snip-type-list) - (let ([snip-types-on-right - (let ([types (memq type snip-type-list)]) - (if types - types - (error 'get-number-of-snips-on-right-from-type - "unknown snip type: ~a" type)))]) - (let loop ([snip-types-on-right (cdr snip-types-on-right)] - [number-of-snips-on-right 0]) - (if (null? snip-types-on-right) - number-of-snips-on-right - (loop (cdr snip-types-on-right) - (+ number-of-snips-on-right - (let ([snip-group (assoc-set-get snip-groups-by-type (car snip-types-on-right) cst:thunk-false)]) - (if snip-group - (snip-group-size snip-group) - 0)))))))) - - ; gui-model-state label symbol top non-negative-exact-integer -> non-negative-exact-integer - ; updates state (move existing snips and add new ones) and returns the position where - ; the snips should be inserted in the text - (define (add-snips gui-model-state label type source number-of-snips) - (let* ([source-gui-data - (assoc-set-get (gui-model-state-source-gui-data-by-source gui-model-state) - source cst:thunk-false)] - [label-gui-data-by-label (source-gui-data-label-gui-data-by-label source-gui-data)] - [label-gui-data (assoc-set-get label-gui-data-by-label label cst:thunk-false)]) - (set-source-gui-data-total-number-of-snips! - source-gui-data (+ (source-gui-data-total-number-of-snips source-gui-data) number-of-snips)) - (if label-gui-data - ; the label might already have some snips attached to it. - (let* ([snip-groups-by-type (label-gui-data-snip-groups-by-type label-gui-data)] - [label-starting-pos (label-gui-data-left-new-pos label-gui-data)] - [insertion-starting-pos - (- label-starting-pos - (get-number-of-snips-on-right-from-type - snip-groups-by-type type (gui-model-state-snip-type-list gui-model-state)))]) - (move-poss gui-model-state source insertion-starting-pos number-of-snips + >=) - (if (assoc-set-in? snip-groups-by-type type) - ; type already present, but, for a given label and type, we can have only one - ; group of snips - (error 'add-snips gui-model-state - "snips-and-arrows internal error; label ~a has already a snip group of type ~a" - label type) - ; new snip type for this label - (begin - (assoc-set-set snip-groups-by-type type (make-snip-group number-of-snips)) - (set-label-gui-data-total-number-of-snips! - label-gui-data - (+ (label-gui-data-total-number-of-snips label-gui-data) number-of-snips)))) - insertion-starting-pos) - ; create new label-gui-data for that label - (let ([label-starting-pos (get-new-pos-from-label gui-model-state label)]) - (move-poss gui-model-state source label-starting-pos number-of-snips + >=) - (assoc-set-set label-gui-data-by-label - label - (make-label-gui-data (+ label-starting-pos number-of-snips) - 0 - number-of-snips - (assoc-set-set (assoc-set-make) - type - (make-snip-group number-of-snips)) - (set-make) - (set-make))) - label-starting-pos)))) - - ; gui-model-state label symbol top -> (value non-negative-exact-integer non-negative-exact-integer) - ; removes all snips for a given label and type, move remaining snips, and returns the interval - ; to delete in the editor - (define (remove-inserted-snips gui-model-state label type source) - (let* ([source-gui-data - (assoc-set-get (gui-model-state-source-gui-data-by-source gui-model-state) - source cst:thunk-false)] - [label-gui-data - (assoc-set-get (source-gui-data-label-gui-data-by-label source-gui-data) - label cst:thunk-false)]) - (if label-gui-data - (let* ([snip-groups-by-type (label-gui-data-snip-groups-by-type label-gui-data)] - [snip-group (assoc-set-get snip-groups-by-type type cst:thunk-false)]) - (if snip-group - (let* ([size (snip-group-size snip-group)] - [label-starting-pos (label-gui-data-left-new-pos label-gui-data)] - [deletion-ending-pos - (- label-starting-pos - (get-number-of-snips-on-right-from-type - snip-groups-by-type type (gui-model-state-snip-type-list gui-model-state)))]) - (assoc-set-remove snip-groups-by-type type) - (move-poss gui-model-state source deletion-ending-pos size - >=) - (set-label-gui-data-total-number-of-snips! - label-gui-data - (- (label-gui-data-total-number-of-snips label-gui-data) - size)) - (set-source-gui-data-total-number-of-snips! - source-gui-data - (- (source-gui-data-total-number-of-snips source-gui-data) - size)) - (values (- deletion-ending-pos size) deletion-ending-pos)) - (error 'remove-inserted-snips - "label ~a has no snip group of type ~a" - label type))) - (error 'remove-inserted-snips - "label ~a has no snip groups at all, let alone of type ~a" - label type)))) - - ) diff --git a/collects/mrflow/snips-and-arrows-view.ss b/collects/mrflow/snips-and-arrows-view.ss deleted file mode 100644 index 93248a9060..0000000000 --- a/collects/mrflow/snips-and-arrows-view.ss +++ /dev/null @@ -1,588 +0,0 @@ - -(module snips-and-arrows-view (lib "mrflow.ss" "mrflow") - (require - mzlib/class - mred - (prefix arrow: (lib "arrow.ss" "drscheme")) - (only mzlib/list sort) - (prefix strcst: string-constants) - - (prefix cst: "constants.ss") - (prefix saam: "snips-and-arrows-model.ss") - ;"set-list.ss" - "set-hash.ss" - ;"assoc-set-list.ss" - "assoc-set-hash.ss" - "labels.ss" - ) - - (define-struct gui-view-state (; gui-model-state - gui-model-state - ; test% - top-editor - ; (label -> text%) - get-editor-from-label - ; boolean - ; so we can differenciate between actions done by the analysis and actions - ; done by the user. Also prevents an infinite loop when deleting: if the user - ; deletes something, it triggers a call to after-delete, which deletes all the - ; snips, which triggers calls to after-delete, etc... so after-delete needs to - ; be wrapped to prevent an infinite loop. - analysis-currently-modifying? - ; (symbol label -> (listof string)) - get-snip-text-from-snip-type-and-label - ; (label -> style-delta%) - get-style-delta-from-label - ; (listof (cons symbol style-delta%)) - snip-types-and-colors - ; boolean - clear-colors-immediately? - )) - - (provide/contract - (make-gui-view-state (text%? - (label? . -> . text%?) - (label? . -> . non-negative-exact-integer?) - (label? . -> . non-negative-exact-integer?) - (symbol? label? . -> . (listof string?)) - (label? . -> . style-delta%?) - (listof (cons/c symbol? string?)) - boolean? - . -> . gui-view-state?)) - - (rename gui-view-state-analysis-currently-modifying? - analysis-currently-modifying? - (gui-view-state? . -> . boolean?)) - (color-registered-labels (gui-view-state? (box/c (listof text%?)) . -> . void?)) - (after-user-action (gui-view-state? . -> . void?)) - - (register-label-with-gui (gui-view-state? label? (text%? . -> . void?) . -> . void?)) - (register-editor-with-gui (gui-view-state? text%? (text%? . -> . void?) . -> . void?)) - (is-editor-registered? (gui-view-state? text%? . -> . boolean?)) - (get-related-labels-from-drscheme-pos-and-editor (gui-view-state? non-negative-exact-integer? text%? . -> . (listof label?))) - (user-change-terms (gui-view-state? (listof (cons/c label? string?)) . -> . void?)) - - (add-arrow (gui-view-state? (list/c label? label? string?) boolean? . -> . void?)) - (get-tacked-arrows-from-label (gui-view-state? label? . -> . non-negative-exact-integer?)) - (remove-arrows (gui-view-state? label? (or/c symbol? boolean?) boolean? . -> . void?)) - (redraw-arrows (gui-view-state? (is-a?/c dc<%>) real? real? . -> . void?)) - - (invalidate-bitmap-cache (gui-view-state? . -> . void?)) - - (label-has-snips-of-this-type? (gui-view-state? label? symbol? . -> . boolean?)) - (snips-currently-displayed-in-editor? (gui-view-state? text%? . -> . boolean?)) - (for-each-snip-type (gui-view-state? (symbol? . -> . void?) . -> . void?)) - (run-thunk-without-snips (gui-view-state? (-> any) . -> . any)) - (add-snips (gui-view-state? label? symbol? text%? . -> . void?)) - (remove-inserted-snips (gui-view-state? label? symbol? text%? . -> . void?)) - (remove-all-snips-in-editor (gui-view-state? text%? . -> . void?)) - (remove-all-snips-in-all-editors (gui-view-state? . -> . void?)) - (remove-all-colors ((box/c (listof text%?)) . -> . void?)) - (remove-all-snips-and-arrows-and-colors (gui-view-state? . -> . void?)) - ) - - ; text% - ; (label -> text%) - ; (label -> non-negative-exact-integer) - ; (label -> non-negative-exact-integer) - ; (symbol label -> (listof string)) - ; (label -> style-delta%) - ; (listof (cons symbol style-delta%)) - ; boolean - ; -> gui-view-state - (set! make-gui-view-state - (let ([real-make-gui-view-state make-gui-view-state]) - (lambda (top-editor - get-editor-from-label - get-mzscheme-position-from-label - get-span-from-label - get-snip-text-from-snip-type-and-label - get-style-delta-from-label - snip-types-and-colors - clear-colors-immediately?) - (real-make-gui-view-state (saam:make-gui-model-state get-editor-from-label - get-mzscheme-position-from-label - get-span-from-label - (map car snip-types-and-colors)) - top-editor - get-editor-from-label - #f - get-snip-text-from-snip-type-and-label - get-style-delta-from-label - (map (lambda (snip-type-and-color) - (cons (car snip-type-and-color) - (send (make-object style-delta%) set-delta-foreground (cdr snip-type-and-color)))) - snip-types-and-colors) - clear-colors-immediately?)))) - - ; INTERFACE BETWEEN MODEL AND TOP MODULE - ; gui-view-state non-negative-exact-integer text% -> (listof label) - (define (get-related-labels-from-drscheme-pos-and-editor gui-view-state pos editor) - (saam:get-related-labels-from-drscheme-pos-and-source - (gui-view-state-gui-model-state gui-view-state) pos editor)) - - ; gui-view-state label (text% -> void) -> void - ; registers a label with the gui. We also need to initialize the editor's state the first time - ; we see that editor, to make sure all editors are sharing the same state. - ; Note that we could color the label as we go, thereby having incremental coloring as we - ; analyze terms, but that turns out to be *very* slow, because the editor has to be unlocked - ; (because of disable-evalution), the style changed, the editor re-lock and the bitmap cache - ; invalidated for each label in turn. It would also possibly not show all the arrows for a - ; given label while the analysis is still going on. - (define (register-label-with-gui gui-view-state label init-editor) - (let ([editor (saam:register-label-with-gui (gui-view-state-gui-model-state gui-view-state) label)]) - (when editor (init-editor editor))) - cst:void) - - ; gui-view-state text% (text% -> void) -> void - ; Same as above, except that we register an editor instead of a label. We use this to always - ; register the top editor (see comment in make-register-label-with-gui in - ; snips-and-arrows.ss). - (define (register-editor-with-gui gui-view-state editor init-editor) - (let ([editor (saam:register-source-with-gui (gui-view-state-gui-model-state gui-view-state) editor)]) - (when editor (init-editor editor))) - cst:void) - - ; gui-view-state text% -> boolean - (define (is-editor-registered? gui-view-state editor) - (saam:is-source-registered? (gui-view-state-gui-model-state gui-view-state) editor)) - - ; gui-view-state (symbol -> void) -> void - (define (for-each-snip-type gui-view-state f) - (saam:for-each-snip-type (gui-view-state-gui-model-state gui-view-state) f)) - - ; gui-view-state label symbol -> boolean - (define (label-has-snips-of-this-type? gui-view-state label type) - (saam:label-has-snips-of-this-type? (gui-view-state-gui-model-state gui-view-state) label type)) - - ; gui-view-state text% -> boolean - (define (snips-currently-displayed-in-editor? gui-view-state editor) - (saam:snips-currently-displayed-in-source? (gui-view-state-gui-model-state gui-view-state) editor)) - - ; gui-view-state label -> non-negative-exact-integer - (define (get-tacked-arrows-from-label gui-view-state label) - (saam:get-tacked-arrows-from-label (gui-view-state-gui-model-state gui-view-state) label)) - - ; gui-view-state (list label label string) boolean -> void - (define (add-arrow gui-view-state arrow-info tacked?) - (saam:add-arrow (gui-view-state-gui-model-state gui-view-state) arrow-info tacked?)) - - ; gui-view-state label (or/c symbol boolean) boolean -> void - (define (remove-arrows gui-view-state start-label tacked? exn?) - (saam:remove-arrows (gui-view-state-gui-model-state gui-view-state) start-label tacked? exn?)) - - - ; COLORING / CLEARING - ; gui-view-state (box (listof text%)) -> void - ; Color all registered labels. Note that we know that no user modifications will be - ; possible while we color (snips-and-arrows.ss takes care of that through can-insert? - ; can-delete?) so there's no need to lock the editors. - ; We remember all the editors in known-editors, because we might need that later, once - ; the state has been resetted, to correctly clear the colors in all editors. - (define (color-registered-labels gui-view-state known-editors) - (let* ([gui-model-state (gui-view-state-gui-model-state gui-view-state)] - [get-span-from-label (saam:make-get-span-from-label-from-model-state gui-model-state)] - [get-style-delta-from-label (gui-view-state-get-style-delta-from-label gui-view-state)]) - (saam:for-each-source - gui-model-state - (lambda (editor) - (when editor - (set-box! known-editors (cons editor (unbox known-editors))) - (let ([locked? (send editor is-locked?)]) - (send editor begin-edit-sequence #f) - (send editor lock #f) - (saam:for-each-label-in-source - gui-model-state - editor - (lambda (label) - (let ([label-left-pos (saam:get-position-from-label gui-model-state label)]) - (send editor change-style (get-style-delta-from-label label) - label-left-pos (+ label-left-pos (get-span-from-label label)) #f)))) - (send editor lock locked?) - (send editor end-edit-sequence))))) - (invalidate-bitmap-cache gui-view-state))) - - ; text% -> void - ; resets all colors to original style - (define (reset-editor-style editor) - (when editor - (let ([locked? (send editor is-locked?)]) - (send editor begin-edit-sequence #f) - (send editor lock #f) - ; comment this out if you want to keep all the pretty colors - (let* ([style-list (send editor get-style-list)] - [standard-style (send style-list find-named-style "Standard")]) - (when standard-style - (send editor change-style - standard-style - 0 (send editor last-position) #f))) - (send editor lock locked?) - (send editor end-edit-sequence)))) - - ; (box (listof text%)) -> void - (define (remove-all-colors known-editors) - (for-each reset-editor-style (unbox known-editors)) - (set-box! known-editors '())) - - ; gui-view-state -> void - (define (remove-all-colors-using-state gui-view-state) - (saam:for-each-source (gui-view-state-gui-model-state gui-view-state) reset-editor-style)) - - ; gui-view-state -> void - ; remove arrows and all snips, editor by editor. - (define (remove-all-snips-and-arrows gui-view-state) - (set-gui-view-state-analysis-currently-modifying?! gui-view-state #t) - (saam:remove-all-arrows (gui-view-state-gui-model-state gui-view-state)) - (invalidate-bitmap-cache gui-view-state) - (remove-all-snips-in-all-editors gui-view-state) - (set-gui-view-state-analysis-currently-modifying?! gui-view-state #f)) - - ; gui-view-state text% -> void - ; Remove all snips in a given editor. We loop over each label and then loop over each - ; snip type and remove the corresponding snip group. It would probably be much faster - ; to first get the positions of the groups of all snips for each label (since for a given - ; label all the groups of snips of different types are next to each other), sort them - ; by decreasing position (so that removing a group of snip doesn't require recomputing - ; the positions of the remaining groups), then remove them in that order. I might do - ; that one day if people complain of slowness... - (define (remove-all-snips-in-editor gui-view-state editor) - (let ([gui-model-state (gui-view-state-gui-model-state gui-view-state)]) - (saam:for-each-label-in-source - gui-model-state - editor - (lambda (label) - (saam:for-each-snip-type - gui-model-state - (lambda (type) - (when (saam:label-has-snips-of-this-type? gui-model-state label type) - (remove-inserted-snips gui-view-state label type editor)))))))) - - ; gui-view-state -> void - ; remove all snips - (define (remove-all-snips-in-all-editors gui-view-state) - (saam:for-each-source (gui-view-state-gui-model-state gui-view-state) - (lambda (editor) - (remove-all-snips-in-editor gui-view-state editor)))) - - ; gui-view-state -> void - ; clear all and reset all - (define (remove-all-snips-and-arrows-and-colors gui-view-state) - (remove-all-snips-and-arrows gui-view-state) - (remove-all-colors-using-state gui-view-state) - (reset-all-editors-state gui-view-state)) - - ; gui-view-state -> void - ; invalidates the bitmap cache of the top editor, which will call the overridden - ; on-paint method of the top editor and redraw the arrows. - (define (invalidate-bitmap-cache gui-view-state) - (send (gui-view-state-top-editor gui-view-state) invalidate-bitmap-cache)) - - ; gui-view-state -> void - ; Resets the state of all editors we know about. Last nail in the coffin for - ; this analysis round. - (define (reset-all-editors-state gui-view-state) - (saam:for-each-source (gui-view-state-gui-model-state gui-view-state) - (lambda (editor) - (send editor reset-snips-and-arrows-state)))) - - - ; EDITOR EVENTS INTERACTION - ; gui-view-state -> void - ; the user has started modifying stuff, so we just remove all snips (in other editors only, - ; since we know a user modification is only allowed if the current editor doesn't have - ; any snips - the current editor is currently locked anyway) and all arrows (in all editors), - (define (after-user-action gui-view-state) - (remove-all-snips-and-arrows gui-view-state) - (when (gui-view-state-clear-colors-immediately? gui-view-state) - (remove-all-colors-using-state gui-view-state)) - (reset-all-editors-state gui-view-state)) - - ; gui-view-state dc% real real -> void - ; redraws arrows during on-paint - (define (redraw-arrows gui-view-state dc dx dy) - (let ([top-editor (gui-view-state-top-editor gui-view-state)] - [untacked-arrow-brush (send the-brush-list find-or-create-brush "white" 'solid)] - [old-pen (send dc get-pen)] - [old-brush (send dc get-brush)]) - (saam:for-each-arrow (gui-view-state-gui-model-state gui-view-state) - (lambda (start-label-pos-left end-label-pos-left - start-label-span end-label-span - start-editor end-editor - tacked? color) - (send dc set-pen (send the-pen-list find-or-create-pen color 1 'solid)) - (if tacked? - (send dc set-brush (send the-brush-list find-or-create-brush color 'solid)) - (send dc set-brush untacked-arrow-brush)) - (draw-arrow start-label-pos-left - (+ start-label-pos-left start-label-span) - end-label-pos-left - (+ end-label-pos-left end-label-span) - top-editor - start-editor - end-editor - dc dx dy))) - (send dc set-pen old-pen) - (send dc set-brush old-brush))) - - ; TEXT - ; gui-view-state (listof (cons label string)) -> void - ; Resize and re-color the terms corresponding to all the labels. - ; We know there's at least one label in the list for each term to be changed, - ; but there might be several labels in the list for the same term. We need - ; to update *all* known labels for all term to be changed, and modify the - ; corresponding term only once. So we do it in two steps: - ; - we sort the new terms by editor and position, throwing away all the labels - ; (we only needed them to get the positions) - ; - from the positions and the editors, get all the labels (sounds redundant? - ; the idea is that we then know that we have *all* the labels for all the - ; terms to be changed, and we know that we have each label only once) and - ; actually do the changes, modifying all the labels for a given term and - ; modifying the content of the corresponding editor only once for a given - ; term, for all terms, by decreasing position in each editor. - ; At least we know that all labels for a given term have the same editor (unless - ; the user of this library really screwed up get-editor-from-label but then it's - ; not our problem if the user can't read the docs...) - (define (user-change-terms gui-view-state labels-and-new-terms) - (if (null? labels-and-new-terms) - (error 'user-change-terms "internal error: can't resize no labels~n") - (let ([get-editor-from-label (gui-view-state-get-editor-from-label gui-view-state)] - [get-style-delta-from-label (gui-view-state-get-style-delta-from-label gui-view-state)] - [new-terms-by-positions-by-editor (assoc-set-make)] - [gui-model-state (gui-view-state-gui-model-state gui-view-state)]) - (set-gui-view-state-analysis-currently-modifying?! gui-view-state #t) - ; first we sort the terms to be modified by editor and by position - ; at the end we throw away the labels, because we don't know whether we have - ; all of them, so since we'll have to get all of them ourselves, we might just - ; as well throw away all the onces the user gave us, at least we won't have to - ; do any sorting to make sure we don't have duplicates. - (for-each - (lambda (label-and-new-term) - (let* ([label (car label-and-new-term)] - [new-term (cdr label-and-new-term)] - [editor (get-editor-from-label label)] - [new-terms-by-position - (assoc-set-get new-terms-by-positions-by-editor - editor - (lambda () - (let ([new-terms-by-position (assoc-set-make)]) - (assoc-set-set new-terms-by-positions-by-editor - editor - new-terms-by-position) - new-terms-by-position)))] - [position (saam:get-position-from-label gui-model-state label)] - [current-new-term - (assoc-set-get new-terms-by-position - position - (lambda () - (assoc-set-set new-terms-by-position - position - new-term) - new-term))]) - (unless (string=? new-term current-new-term) - (error 'user-change-terms "two different terms specified for same position: ~a and ~a" - new-term current-new-term)))) - labels-and-new-terms) - ; then for each editor and each position we have found, we update all the labels - ; by changing their span in the model, and modify the editor at the right place (note - ; that we need to sort the positions of the labels in decreasing order for a given - ; editor, otherwise modifying one term would change the actual positions of the - ; remaining terms to change...) - ; - ; These changes can be undone only when the editor doesn't contain any snips, - ; otherwise the undo will undo at the wrong place. Even if we were to force - ; the change without undo, it would still not work because any previous action - ; could later be undone at the wrong place. The only way out it to put the - ; whole thing inside run-thunk-without-snips (which will make it undoable - ; from DrScheme's point of view) and provide our own undoer to undo the change. - ; XXX to be done later... same thing with user modifications (insert / delete): - ; use run-thunk-without-snips and provide our own undoer with add-undo. - ; In the meantime we just forbid the change. Note that we must test all the editors - ; for snips before doing any change, because otherwise we might change terms in one - ; editor and not in another and break the semantics of the change. - (let ([abort? #f]) - (assoc-set-for-each - new-terms-by-positions-by-editor - (lambda (editor new-terms-by-positions) - (when (snips-currently-displayed-in-editor? gui-view-state editor) - (set! abort? #t)))) - (if abort? - (message-box (strcst:string-constant snips-and-arrows-user-action-disallowed-title) - (strcst:string-constant snips-and-arrows-user-action-disallowed) - #f '(ok caution)) - ; the "save" button will show up... - (assoc-set-for-each - new-terms-by-positions-by-editor - (lambda (editor new-terms-by-positions) - (when editor - (let ([locked? (send editor is-locked?)]) - (send editor begin-edit-sequence #t) - (send editor lock #f) - (for-each - (lambda (position-and-new-term-pair) - (let* ([position (car position-and-new-term-pair)] - [new-term (cdr position-and-new-term-pair)] - [labels (get-related-labels-from-drscheme-pos-and-editor gui-view-state position editor)]) - (let-values ([(old-ending-pos new-ending-pos) - (saam:user-change-terms gui-model-state - labels editor - (string-length new-term))]) - (send editor insert new-term position old-ending-pos) - ; the styles for the different labels are hopefully the same... - (send editor change-style - (get-style-delta-from-label (car labels)) - position new-ending-pos #f)))) - (sort (assoc-set-map new-terms-by-positions cons) - (lambda (pos&term-pair1 pos&term-pair2) - (> (car pos&term-pair1) (car pos&term-pair2))))) - (send editor lock locked?) - (send editor end-edit-sequence))))))) - (set-gui-view-state-analysis-currently-modifying?! gui-view-state #f)))) - - - ; SNIPS - ; gui-view-state label symbol text% -> void - ; Adds snips of given type to given label. - ; We could get the editor from the label, but there's no reason to bother... - (define (add-snips gui-view-state label type editor) - (when editor - (let ([snips-content - ((gui-view-state-get-snip-text-from-snip-type-and-label gui-view-state) type label)]) - (unless (null? snips-content) - (set-gui-view-state-analysis-currently-modifying?! gui-view-state #t) - (let ([snip-style - (cdr (assq type (gui-view-state-snip-types-and-colors gui-view-state)))] - [starting-pos (saam:add-snips (gui-view-state-gui-model-state gui-view-state) - label type editor (length snips-content))] - [locked? (send editor is-locked?)] - [modified? (send editor is-modified?)]) - (send editor begin-edit-sequence #f) - (send editor lock #f) - (for-each (lambda (snip-content) - (let* ([snip-text (make-object text%)] - [snip (make-object editor-snip% snip-text)]) - (send snip-text insert snip-content) - (send snip-text lock #t) - (send editor insert snip starting-pos starting-pos) - ; XXX bug here on Solaris, can be worked around - ; (invalidate-bitmap-cache gui-view-state) - ; see collects/test/tool2.ss - (send editor change-style snip-style - starting-pos (add1 starting-pos) #f))) - snips-content) - (send editor set-modified modified?) - (send editor lock locked?) - (send editor end-edit-sequence)) - (invalidate-bitmap-cache gui-view-state) - (set-gui-view-state-analysis-currently-modifying?! gui-view-state #f))))) - - ; gui-view-state label symbol text% -> void - ; Remove snips for a given label and type. - ; We could get the editor from the label, but there's no reason to bother... - (define (remove-inserted-snips gui-view-state label type editor) - (when editor - (set-gui-view-state-analysis-currently-modifying?! gui-view-state #t) - (let-values ([(starting-pos ending-pos) - (saam:remove-inserted-snips (gui-view-state-gui-model-state gui-view-state) - label type editor)] - [(locked?) (send editor is-locked?)] - [(modified?) (send editor is-modified?)]) - ; all the snips for a given label and type are contiguous and deleted at once. - (send editor begin-edit-sequence #f) - (send editor lock #f) - (send editor delete starting-pos ending-pos #f) - (send editor set-modified modified?) - (send editor lock locked?) - (send editor end-edit-sequence)) - (invalidate-bitmap-cache gui-view-state) - (set-gui-view-state-analysis-currently-modifying?! gui-view-state #f))) - - ; gui-view-state (-> top) -> top - ; removes all the snips (and remembers them), runs the thunk, then puts all the snips back in... - ; remove-inserted-snips and add-snips take care of is-locked? and is-modified?, but even - ; though they also take care of begin/end-edit-sequence, we still need to wrap everything - ; in a sequence here otherwise the user would see the snips suddenly disappear and reappear... - (define (run-thunk-without-snips gui-view-state thunk) - (let ([gui-model-state (gui-view-state-gui-model-state gui-view-state)] - [snip-types-by-label-by-editor (assoc-set-make)]) - (saam:for-each-source - gui-model-state - (lambda (editor) - (send editor begin-edit-sequence #f) - (let ([snip-types-by-label (assoc-set-make)]) - (assoc-set-set snip-types-by-label-by-editor editor snip-types-by-label) - (saam:for-each-label-in-source - gui-model-state - editor - (lambda (label) - (saam:for-each-snip-type - gui-model-state - (lambda (type) - (when (saam:label-has-snips-of-this-type? gui-model-state label type) - (set-set (assoc-set-get snip-types-by-label label - (lambda () - (let ([set (set-make)]) - (assoc-set-set snip-types-by-label label set) - set))) - type) - (remove-inserted-snips gui-view-state label type editor))))))))) - (let ([result (thunk)]) - (assoc-set-for-each - snip-types-by-label-by-editor - (lambda (editor snip-types-by-label) - (assoc-set-for-each - snip-types-by-label - (lambda (label types-set) - (set-for-each - types-set - (lambda (type) - (add-snips gui-view-state label type editor))))) - (send editor end-edit-sequence))) - result))) - - - ; ARROWS - ; (box number) (box number) -> number - (define (average box1 box2) - (/ (+ (unbox box1) (unbox box2)) 2)) - - ; non-negative-exact-integer non-negative-exact-integer non-negative-exact-integer non-negative-exact-integer - ; text% text% text% dc% real real -> void - ; Computes actual locations for arrow and draws it. - ; Note that we don't do anything to prevent arrows of length zero from being drawn - these - ; might show up when using macros that duplicate terms, so arrows of length zero are then - ; the correct thing to do as far as I am concerned). - (define (draw-arrow start-label-pos-left start-label-pos-right - end-label-pos-left end-label-pos-right - top-editor start-editor end-editor - dc dx dy) - (let ([start-sub-ed-left-x-loc (box 0)] - [start-sub-ed-top-y-loc (box 0)] - [start-sub-ed-right-x-loc (box 0)] - [start-sub-ed-bot-y-loc (box 0)] - [end-sub-ed-left-x-loc (box 0)] - [end-sub-ed-top-y-loc (box 0)] - [end-sub-ed-right-x-loc (box 0)] - [end-sub-ed-bot-y-loc (box 0)]) - (send start-editor position-location start-label-pos-left start-sub-ed-left-x-loc start-sub-ed-top-y-loc #t) - (send start-editor position-location start-label-pos-right start-sub-ed-right-x-loc #f #f) - (send start-editor position-location (sub1 start-label-pos-right) #f start-sub-ed-bot-y-loc #f) - (send end-editor position-location end-label-pos-left end-sub-ed-left-x-loc end-sub-ed-top-y-loc #t) - (send end-editor position-location end-label-pos-right end-sub-ed-right-x-loc #f #f) - (send end-editor position-location (sub1 end-label-pos-right) #f end-sub-ed-bot-y-loc #f) - (let*-values - ([(start-sub-ed-x-loc) (average start-sub-ed-left-x-loc start-sub-ed-right-x-loc)] - [(start-sub-ed-y-loc) (average start-sub-ed-top-y-loc start-sub-ed-bot-y-loc)] - [(end-sub-ed-x-loc) (average end-sub-ed-left-x-loc end-sub-ed-right-x-loc)] - [(end-sub-ed-y-loc) (average end-sub-ed-top-y-loc end-sub-ed-bot-y-loc)] - [(start-dc-x-loc start-dc-y-loc) - (send start-editor editor-location-to-dc-location start-sub-ed-x-loc start-sub-ed-y-loc)] - [(end-dc-x-loc end-dc-y-loc) - (send end-editor editor-location-to-dc-location end-sub-ed-x-loc end-sub-ed-y-loc)] - [(start-top-ed-x-loc start-top-ed-y-loc) - (send top-editor dc-location-to-editor-location start-dc-x-loc start-dc-y-loc)] - [(end-top-ed-x-loc end-top-ed-y-loc) - (send top-editor dc-location-to-editor-location end-dc-x-loc end-dc-y-loc)]) - (arrow:draw-arrow - dc start-top-ed-x-loc start-top-ed-y-loc end-top-ed-x-loc end-top-ed-y-loc dx dy)))) - - ) diff --git a/collects/mrflow/snips-and-arrows.ss b/collects/mrflow/snips-and-arrows.ss deleted file mode 100644 index 23c4c3f78c..0000000000 --- a/collects/mrflow/snips-and-arrows.ss +++ /dev/null @@ -1,616 +0,0 @@ - -(module snips-and-arrows (lib "mrflow.ss" "mrflow") - - (require - mzlib/etc - mzlib/class - mred - (prefix strcst: string-constants) - - (prefix cst: "constants.ss") - (prefix saav: "snips-and-arrows-view.ss") - "labels.ss" - ) - - (provide/contract - (extend-all-editors-mixin mixin-contract) - (extend-top-editor-mixin mixin-contract) - (init-snips-and-arrows-gui (text%? - (label? . -> . text%?) - (label? . -> . non-negative-exact-integer?) - (label? . -> . non-negative-exact-integer?) - ((listof label?) . -> . (listof (list/c label? label? string?))) - (label? . -> . style-delta%?) - ((is-a?/c popup-menu%) (listof label?) . -> . void?) - (symbol? symbol? . -> . string?) - (symbol? label? . -> . (listof string?)) - (listof (cons/c symbol? string?)) - boolean? - . -> . - (values ((listof (cons/c label? string?)) . -> . void?) - (label? . -> . void?)))) - (init-snips-and-arrows-gui-for-syntax-objects (text%? - ((listof syntax?) . -> . (listof (list/c syntax? syntax? string?))) - (syntax? . -> . style-delta%?) - ((is-a?/c popup-menu%) (listof syntax?) . -> . void?) - (symbol? symbol? . -> . string?) - (symbol? syntax? . -> . (listof string?)) - (listof (cons/c symbol? string?)) - boolean? - . -> . - (values ((listof (cons/c syntax? string?)) . -> . void?) - (syntax? . -> . void?)))) - ) - - (define-struct gui-state (; gui-view-state - gui-view-state - ; ((listof label) -> (listof (list label label string))) - get-arrows-from-labels - ; (symbol symbol -> string) - get-menu-text-from-snip-type - ; (symbol label -> (listof string)) - get-snip-text-from-snip-type-and-label - ; (popup-menu% (listof label) -> void) - extend-menu-for-labels - ; (union #f (listof label)) - previous-labels - ; boolean - ; we need this one to prevent arrows and menus to show up - ; before the real analysis part is over, because as long as - ; the analysis is not finished we might not have all arrows - ; and not all errors (so wrong menus). - term-analysis-done? - )) - - ; MENUS - ; gui-state menu% (listof labels) symbol text% -> void - ; creates a menu entry for a given snip type - ; all labels correspond to the same term (because of macros) - (define (create-snips-menu-item-by-type gui-state menu labels type editor) - (let ([gui-view-state (gui-state-gui-view-state gui-state)] - [get-menu-text-from-snip-type (gui-state-get-menu-text-from-snip-type gui-state)] - [get-snip-text-from-snip-type-and-label - (gui-state-get-snip-text-from-snip-type-and-label gui-state)]) - (if (ormap (lambda (label) - (saav:label-has-snips-of-this-type? gui-view-state label type)) - labels) - ; at least one label has snips displayed => delete menu entry - (make-object menu-item% - (get-menu-text-from-snip-type type 'hide) - menu - (lambda (item event) - (for-each (lambda (label) - (when (saav:label-has-snips-of-this-type? gui-view-state label type) - (saav:remove-inserted-snips gui-view-state label type editor))) - labels))) - ; no label has snips displayed => show menu entry if one of them has snips associated - ; with it - (unless (andmap (lambda (label) - (null? (get-snip-text-from-snip-type-and-label type label))) - labels) - (make-object menu-item% - (get-menu-text-from-snip-type type 'show) - menu - (lambda (item event) - (for-each (lambda (label) - (saav:add-snips gui-view-state label type editor)) - labels)))))) - cst:void) - - ; gui-state menu% (listof label) -> menu-item% - ; create menu entries for arrows - ; all labels correspond to the same term (because of macros) - (define (create-arrow-menu-items gui-state menu labels) - (let* ([gui-view-state (gui-state-gui-view-state gui-state)] - [arrows-info ((gui-state-get-arrows-from-labels gui-state) labels)] - [max-arrows (length arrows-info)] - [tacked-arrows (apply + (map (lambda (label) - (saav:get-tacked-arrows-from-label gui-view-state label)) - labels))]) - (when (< tacked-arrows max-arrows) - (make-object menu-item% - (strcst:string-constant snips-and-arrows-popup-menu-tack-all-arrows) - menu - (lambda (item event) - ; remove all (possibly untacked) arrows and add all arrows, tacked. - ; we could just add the untacked ones, but what we do here is simple - ; and efficient enough - (for-each (lambda (label) - (saav:remove-arrows gui-view-state label 'all #t)) - labels) - (for-each - (lambda (arrow-info) - (saav:add-arrow gui-view-state arrow-info #t)) - arrows-info) - (saav:invalidate-bitmap-cache gui-view-state)))) - (when (> tacked-arrows 0) - (make-object menu-item% - (strcst:string-constant snips-and-arrows-popup-menu-untack-all-arrows) - menu - (lambda (item event) - (for-each (lambda (label) - (saav:remove-arrows gui-view-state label 'all #t)) - labels) - (saav:invalidate-bitmap-cache gui-view-state)))))) - - - ; gui-view-state -> boolean - ; User insertions cause problems: a user might insert something while our snips - ; are present. That would force us to remove all the snips, since as soon as - ; the user changes the program the results of the analysis become invalid. So - ; we would have to keep track of the user insertion (which is possible), update - ; the position of all our snips accordingly (which is possible too), then delete - ; all the snips because they would not be valid anymore (which is very possible). - ; In fact we used to do all that. The reason we got rid of it is because it does - ; not interact well with the undo feature: if, after the user insertion and the - ; automatic removal of snips, the user does an undo, the undo might delete random - ; stuff at the position where the user insertion initially occured, but that might - ; not be the position where that user-inserted stuff currently is, because removing - ; the snips between the insertion and the undo might have moved around the stuff - ; that was inserted... - ; - ; Note that it's not possible to delete our snips just right before the user action - ; is effected in the window (e.g. during a call to the on-insert method), - ; because the editor is locked at that time (and with reason: if we were to remove - ; the snips right after the user acts (which is the thing that decides we must - ; get rid of all our snips) but just before the action actually takes place in the - ; editor, then after removing the snips the user action would actually be effected - ; at the wrong position in the editor - i.e. we can't sweep the rug under DrScheme's - ; own insertion mechanism, and I don't think Matthew would be willing to add a mechanism - ; whereby one could notify DrScheme that the rug is being swept...) - ; - ; Same problem with trying to remove the snips inside can-insert? : the editor is - ; locked. - ; - ; Note also that things get even worse if the user tries to delete stuff instead of - ; inserting stuff: the user might try to delete one of our own snips! We could - ; check the stuff the user wants to delete and only allow the delete if the stuff - ; didn't contain one of our snips, but this still wouldn't solve the undo problem - ; (which exists in reverse: deleting and undoing would re-insert the deleted stuff - ; at the wrong place - I tried it!). - ; - ; Conclusion: it's impossible to solve the problem of user insertion and deletion - ; while snips are present, because the undo then becomes buggy. So we simply - ; completely disallow user insertions and deletions while snips are present (in - ; this editor - there's no problem with undo if the user action happens in another - ; editor that doesn't contain snips, and then we just use that as a signal to delete - ; all snips in all editors using the after-user-action fucntion). - ; - ; So this is what this function is doing: disallow user modifications to an editor - ; when the editor contains snips (or while the analysis is still running). - (define (is-action-allowed? gui-view-state editor) - (or (saav:analysis-currently-modifying? gui-view-state) - (if (saav:snips-currently-displayed-in-editor? gui-view-state editor) - (begin - (message-box (strcst:string-constant snips-and-arrows-user-action-disallowed-title) - (strcst:string-constant snips-and-arrows-user-action-disallowed) - #f '(ok caution)) - #f) - #t))) - - - ; MIXINS - ; to be applied to all editors and sub-editors containing registered labels - (define extend-all-editors-mixin - (lambda (super%) - (class super% - - ; State initialization and resetting - ; The state is created by the call to init-snips-and-arrows-gui in the callback - ; of the tool's button. The state is hidden inside the register-label-with-gui function - ; returned by the call. That means a new instance of the state is created each time - ; the user uses the tool. Then, each time the user uses register-label-with-gui, - ; the function checks whether the editor has been seen before or not, and if it hasn't - ; it calls the editor's initialize-snips-and-arrows-gui-state method to initialize the - ; editor's state. That ensures that all editors where coloring has to happen share the - ; same state. Note that the top editor has both extend-all-editors-mixin and - ; extend-top-editor-mixin applied to it, so the initialize-snips-and-arrows-gui-state - ; method is define/public in one case and define/override in the other case. - ; Note also that the initialization of the top editor is always done - ; as a special case inside init-snips-and-arrows-gui (see this function below) - ; because that editor still needs to have access to the state to redraw arrows even if - ; no label is registered for it. - ; - ; The state is reset in two cases: - ; - the user inserts or deletes something in an editor (see the comment for - ; is-action-allowed? above for details about when this is allowed), and - ; clear-colors-immediately? is true - ; - the gui makes a direct call to remove-all-snips-and-arrows-and-colors (probably inside - ; the clear-annotations method for the unit frame) - ; The state is reseted by calling the reset-snips-and-arrows-state method of each editor - ; for which a label has been registred. Since the unit frame has no direct reference to - ; the state but only through the register-label-with-gui function, and since the editors - ; don't have any reference to the state after their reset-snips-and-arrows-state method - ; is called, the state can be garbage collected as soon as the register-label-with-gui - ; function is not referenced by the unit frame anymore. - ; Note that it would be possible for the unit frame to re-use the state (and indeed that's - ; how it was working for a while) but it makes testing whether the analysis is currently - ; running a bit more difficult and doesn't make anything else any simpler. Besides, it - ; might also be a source of subtle errors if everything is not correctly reseted from one - ; run of the analysis to the next one. - - ; (union gui-state symbol) - (define gui-state 'uninitialized-gui-state-in-extend-all-editors-mixin) - - ; (union gui-view-state 'symbol) - (define gui-view-state 'uninitialized-gui-view-state-in-extend-all-editors-mixin) - - ; gui-state -> void - ; see the same method below for explanation - (define/public (initialize-snips-and-arrows-gui-state new-gui-state) - (set! gui-state new-gui-state) - (set! gui-view-state (gui-state-gui-view-state new-gui-state))) - - ; -> void - (define/public (reset-snips-and-arrows-state) - (set! gui-state 'reinitialized-gui-state-in-extend-all-editors-mixin) - (set! gui-view-state 'reinitialized-gui-view-state-in-extend-all-editors-mixin)) - - ; exact-non-negative-integer exact-non-negative-integer -> boolean - (define/augment (can-insert? start len) - (and (or (symbol? gui-state) - (and (gui-state-term-analysis-done? gui-state) - (is-action-allowed? gui-view-state this))) - (inner #t can-insert? start len))) - - ; exact-non-negative-integer exact-non-negative-integer -> boolean - (define/augment (can-delete? start len) - (and (or (symbol? gui-state) - (and (gui-state-term-analysis-done? gui-state) - (is-action-allowed? gui-view-state this))) - (inner #t can-delete? start len))) - - ; exact-non-negative-integer exact-non-negative-integer -> void - (define/augment (after-insert start len) - (unless (or (symbol? gui-state) - (saav:analysis-currently-modifying? gui-view-state)) - (saav:after-user-action gui-view-state)) - (inner cst:void after-insert start len)) - - ; exact-non-negative-integer exact-non-negative-integer -> void - (define/augment (after-delete start len) - (unless (or (symbol? gui-state) - (saav:analysis-currently-modifying? gui-view-state)) - (saav:after-user-action gui-view-state)) - (inner cst:void after-delete start len)) - - (super-instantiate ())))) - - ; to apply to the top editor - (define extend-top-editor-mixin - (lambda (super%) - (class super% - - ; (union gui-state symbol) - (define gui-state 'uninitialized-gui-state-in-extend-top-editor-mixin) - - ; (union gui-view-state symbol) - (define gui-view-state 'uninitialized-gui-view-state-in-extend-top-editor-mixin) - - ; (box (listof text%)) - (define known-editors (box '())) - - ; gui-state -> void - ; init-snips-and-arrows-gui creates register-label-with-gui, which will call - ; saav:register-label-with-gui, which will in turn find the editor for the label - ; and call this method (if necessary) to initialize the editor's state, thereby - ; allowing all the editors for a single analysis to share the same state (see - ; the same method above too). - (define/override (initialize-snips-and-arrows-gui-state new-gui-state) - (super initialize-snips-and-arrows-gui-state new-gui-state) - (set! gui-state new-gui-state) - (set! gui-view-state (gui-state-gui-view-state new-gui-state))) - - ; -> void - (define/override (reset-snips-and-arrows-state) - (super reset-snips-and-arrows-state) - (set! gui-state 'reinitialized-gui-state-in-extend-top-editor-mixin) - (set! gui-view-state 'reinitialized-gui-view-state-in-extend-top-editor-mixin)) - - ; string symbol -> boolean - ; We forbid saving if the analysis is in the middle of running or in the middle - ; of modifying the content of the editor - (define/augment (can-save-file? filename format) - (if (symbol? gui-state) - (inner #t can-save-file? filename format) - (if (and (gui-state-term-analysis-done? gui-state) - (not (saav:analysis-currently-modifying? gui-view-state))) - (inner #t can-save-file? filename format) - #f))) - - (define/override (save-file . args) - (if (symbol? gui-state) - (super save-file . args) - (saav:run-thunk-without-snips gui-view-state - (lambda () (super save-file . args))))) - - ; -> void - ; colors all registered labels - ; The analysis proper is only officially done after we've colored everything, otherwise - ; user insertions might occur before we have time to finish coloring and we will color - ; the wrong stuff... - (define/public (color-registered-labels) - (unless (symbol? gui-view-state) - (saav:color-registered-labels gui-view-state known-editors) - (set-gui-state-term-analysis-done?! gui-state #t))) - - ; -> void - ; remove all snips and arrows, and resets text style in all editors - (define/public (remove-all-snips-and-arrows-and-colors) - (if (symbol? gui-view-state) - (saav:remove-all-colors known-editors) - (saav:remove-all-snips-and-arrows-and-colors gui-view-state))) - - ; boolean dc% real real real real real real symbol -> void - (define/override (on-paint before? dc left top right bottom dx dy draw-caret) - (super on-paint before? dc left top right bottom dx dy draw-caret) - (when (and (not (symbol? gui-state)) - (not before?) - (gui-state-term-analysis-done? gui-state)) - (saav:redraw-arrows gui-view-state dc dx dy))) - - (inherit find-position dc-location-to-editor-location) - ; mouse-event% -> (values (union #f exact-non-negative-integer) (union #f text%)) - ; finds the editor in which a mouse-event% has occured, going down recursively - ; if there are embedded editors, but not going down the embedded editors when they - ; have been introduced by the analysis itself (e.g. type snips). - (define (get-drscheme-pos-and-editor event) - (let ([dc-x (send event get-x)] - [dc-y (send event get-y)] - [on-it? (box #f)]) - (let loop ([previous-pos #f] - [previous-editor #f] - [editor this]) - (let-values ([(ed-x ed-y) (send editor dc-location-to-editor-location dc-x dc-y)]) - (let ([pos (send editor find-position ed-x ed-y #f on-it?)]) - (if (not (unbox on-it?)) - (values #f #f) - (let ([snip (send editor find-snip pos 'after-or-none)]) - (if (and snip (is-a? snip editor-snip%)) - (let ([sub-editor (send snip get-editor)]) - (if (saav:is-editor-registered? gui-view-state sub-editor) - (loop pos editor sub-editor) - (values pos editor))) - (values pos editor))))))))) - - (inherit get-admin) - ; mouse-event% -> void - (define/override (on-event event) - (cond - [(or (symbol? gui-state) - (not (gui-state-term-analysis-done? gui-state))) - (super on-event event)] - [(and (send event button-down? 'right) - (let-values ([(pos editor) (get-drscheme-pos-and-editor event)]) - (if pos - (let ([labels (saav:get-related-labels-from-drscheme-pos-and-editor - gui-view-state pos editor)]) - (if (null? labels) - #f - (cons labels editor))) ; no "=>-values" so use cons... - #f))) - => - (lambda (labels&editor) - (let ([menu (make-object popup-menu%)] - [labels (car labels&editor)] - [editor (cdr labels&editor)]) - ; SNIPS - (let ([create-snips-menu-item - (lambda (snip-type) - (create-snips-menu-item-by-type gui-state menu labels snip-type editor))]) - (saav:for-each-snip-type gui-view-state create-snips-menu-item)) - ; ARROWS - (create-arrow-menu-items gui-state menu labels) - ; HIDE ALL SNIPS - (when (saav:snips-currently-displayed-in-editor? gui-view-state editor) - (make-object menu-item% - (strcst:string-constant snips-and-arrows-hide-all-snips-in-editor) - menu - (lambda (item event) - (saav:remove-all-snips-in-editor gui-view-state editor)))) - ; OTHER - ((gui-state-extend-menu-for-labels gui-state) menu labels) - - (when (not (null? (send menu get-items))) - (let-values ([(x y) (dc-location-to-editor-location (send event get-x) (send event get-y))]) - (send (get-admin) popup-menu menu x y))) - ))] - [(and (send event button-down? 'middle) - (let-values ([(pos editor) (get-drscheme-pos-and-editor event)]) - (if pos - (let ([labels (saav:get-related-labels-from-drscheme-pos-and-editor - gui-view-state pos editor)]) - (if (null? labels) - #f - (cons labels editor))) ; no "=>-values" so use cons... - #f))) - => - (lambda (labels&editor) - (let ([menu (make-object popup-menu%)] - [labels (car labels&editor)] - [editor (cdr labels&editor)] - [get-snip-text-from-snip-type-and-label - (gui-state-get-snip-text-from-snip-type-and-label gui-state)]) - (saav:for-each-snip-type - gui-view-state - (lambda (snip-type) - (unless (andmap (lambda (label) - (null? (get-snip-text-from-snip-type-and-label snip-type label))) - labels) - ; at least one label has snips of this type - (for-each (lambda (label) - (let ([snip-strings (get-snip-text-from-snip-type-and-label snip-type label)]) - (unless (null? snip-strings) - (for-each - (lambda (snip-string) - (make-object menu-item% - (if (<= (string-length snip-string) 200) - snip-string - (string-append - (substring snip-string 0 197) - "...")) - menu - (lambda (item event) cst:void))) - snip-strings)))) - labels) - (make-object separator-menu-item% menu)))) - (when (not (null? (send menu get-items))) - (let-values ([(x y) (dc-location-to-editor-location (send event get-x) (send event get-y))]) - (send (get-admin) popup-menu menu x y))) - ))] - [(send event leaving?) - (let ([previous-labels (gui-state-previous-labels gui-state)]) - (when previous-labels - (for-each (lambda (previous-label) - (saav:remove-arrows gui-view-state previous-label #f #f)) - previous-labels) - (set-gui-state-previous-labels! gui-state #f) - (saav:invalidate-bitmap-cache gui-view-state)))] - [(or (send event moving?) - (send event entering?)) - (if (or (send event get-left-down) - (send event get-middle-down) - (send event get-right-down)) - (super on-event event) - (let*-values ([(pos editor) (get-drscheme-pos-and-editor event)] - [(labels) - (if pos - (saav:get-related-labels-from-drscheme-pos-and-editor - gui-view-state pos editor) - #f)] - [(previous-labels) (gui-state-previous-labels gui-state)] - [(not-same-labels) (not (equal? labels previous-labels))]) - (when (and previous-labels not-same-labels) - (for-each (lambda (previous-label) - (saav:remove-arrows gui-view-state previous-label #f #f)) - previous-labels)) - (when (and labels not-same-labels) - (for-each (lambda (arrow-info) - (saav:add-arrow gui-view-state arrow-info #f)) - ((gui-state-get-arrows-from-labels gui-state) labels))) - (when not-same-labels - (when (or (not (null? previous-labels)) - (not (null? labels))) - ; something has changed, and we might have either removed some arrows or - ; added some (or both), so we redraw - (saav:invalidate-bitmap-cache gui-view-state)) - (set-gui-state-previous-labels! gui-state labels))))] - [else (super on-event event)])) - - (super-instantiate ())))) - - - ; ... see below ... -> (label -> void) - ; Ouch... The returned function can be used to register labels with this gui - (define (init-snips-and-arrows-gui - ; % text% - top-editor - ; (label -> text%) - get-editor-from-label - ; (label -> non-negative-exact-integer) - get-mzscheme-position-from-label - ; (label -> non-negative-exact-integer) - get-span-from-label - ; ((listof label) -> (listof (list label label string))) - get-arrows-from-labels - ; (label -> style-delta%) - get-style-delta-from-label - ; (popup-menu% (listof label) -> void) - extend-menu-for-labels - ; (symbol symbol -> string) - get-menu-text-from-snip-type - ; (symbol label -> (listof string)) - get-snip-text-from-snip-type-and-label - ; (listof (cons symbol string)) - snip-types-and-colors - ; boolean - clear-colors-immediately?) - (let* ([gui-view-state (saav:make-gui-view-state - top-editor - get-editor-from-label - get-mzscheme-position-from-label - get-span-from-label - get-snip-text-from-snip-type-and-label - get-style-delta-from-label - snip-types-and-colors - clear-colors-immediately?)] - [gui-state (make-gui-state - gui-view-state - get-arrows-from-labels - get-menu-text-from-snip-type - get-snip-text-from-snip-type-and-label - extend-menu-for-labels - #f - #f)]) - ; just make sure everything is clear before assigning a new state - (send top-editor remove-all-snips-and-arrows-and-colors) - - ; we need this to force the registration of the top editor, to make sure - ; on-paint and on-event work correctly even when no label has been registered for - ; the top editor itself. - (saav:register-editor-with-gui - gui-view-state top-editor - (lambda (editor) - (send editor initialize-snips-and-arrows-gui-state gui-state))) - - (values - ; (listof (cons label string)) -> void - (lambda (labels-and-new-terms) - (saav:user-change-terms gui-view-state labels-and-new-terms)) - - ; label -> void - ; to register a label with the gui - (lambda (label) - (saav:register-label-with-gui - gui-view-state label - (lambda (editor) - (send editor initialize-snips-and-arrows-gui-state gui-state)))) - ))) - - ; SIMPLIFIED INTERFACE - ; symbol -> void - ; default function for snip handling - (define error-no-snips - (case-lambda - [(_) (error-no-snips 'dummy 'dummy)] - [(_1 _2) (error 'snips-and-arrows "no snip info was provided when snips-and-arrows library was initialized")])) - - ; ... see below ... -> (values gui-state (label -> void)) - ; simplified version of make-snips-and-arrows-state, specialized for syntax objects, - ; and with default handling of snips - (define init-snips-and-arrows-gui-for-syntax-objects - (opt-lambda (; text% - top-editor - ; ((listof syntax-object) -> (listof (list syntax-object syntax-object string))) - get-arrows-from-syntax-objects - ; (syntax-object -> style-delta%) - get-style-delta-from-syntax-object - - ; OPTIONAL menu stuff - ; (popup-menu% (listof syntax-object) -> void) - (extand-menu-for-syntax-objects (lambda (menu stxs) cst:void)) - - ; OPTIONAL snip stuff - ; (symbol symbol -> string) - (get-menu-text-from-snip-type error-no-snips) - ; (symbol syntax-object -> (listof string)) - (get-snip-text-from-snip-type-and-syntax-object error-no-snips) - ; (listof (cons symbol string)) - (snip-types-and-colors '()) - - ; boolean - (clear-colors-immediately? #f)) - (init-snips-and-arrows-gui - top-editor - syntax-source - syntax-position - syntax-span - get-arrows-from-syntax-objects - get-style-delta-from-syntax-object - extand-menu-for-syntax-objects - get-menu-text-from-snip-type - get-snip-text-from-snip-type-and-syntax-object - snip-types-and-colors - clear-colors-immediately?))) - - ) diff --git a/collects/mrflow/trie.ss b/collects/mrflow/trie.ss deleted file mode 100644 index e635bc56d6..0000000000 --- a/collects/mrflow/trie.ss +++ /dev/null @@ -1,124 +0,0 @@ - -(module trie (lib "mrflow.ss" "mrflow") - (require (prefix list: mzlib/list) - (prefix cst: "constants.ss") - - "dfa.ss" - "types.ss" - "util.ss") - - ;; DFA Tries - Allows for testing of a DFA being previously hashconsed - ;; in Theta(|DFA|) time. - (provide (struct trie ()) - add-dfa-states - dfa-present?) - - ; DFA states are analogous to letters and at a node we have map of handles - ; indexed by the DFA representative (the handle of the last DFA state in a DFA - ; canonically ordered by minimization). - ; - ; Two equivalent (minimal, strongly connected) DFAs will yield the same - ; canonically ordered DFAs regardless of the start state picked. - ; - ; An association list and hash-table are used to store the maps, but perhaps - ; there is a better choice of data structures. - (define-struct trie (dfa-representative->handle dfa-state->trie)) - (set! make-trie - (let ([old-make-trie make-trie]) - (lambda () - (old-make-trie '() (make-hash-table 'equal))))) - - ; Get the trie on the edge labeled by the DFA state - (define/contract get-trie-child (trie? state? . -> . (or/c trie? false/c)) - (lambda (trie letter) - (hash-table-get (trie-dfa-state->trie trie) letter cst:thunk-false))) - - ; Each DFA state added to the trie must map to a unique handle. - (define/contract add-trie-state-handle! - (trie? handle? handle? . ->d . - (lambda (trie representative-handle state-handle) - (let ([dfa->handle (trie-dfa-representative->handle trie)]) - (when (assq representative-handle dfa->handle) - (error 'add-trie-state-handle! - "Mapping ~a to ~a, but trie already has mapping from DFA representative ~a to handle ~a" - representative-handle state-handle - representative-handle (cdr (assq representative-handle dfa->handle)))) - trie?))) - (lambda (trie representative-handle state-handle) - (let ([dfa->handle (trie-dfa-representative->handle trie)]) - (set-trie-dfa-representative->handle! trie (cons (cons representative-handle state-handle) dfa->handle)) - trie))) - - (define/contract get-state-handle (trie? handle? . -> . handle?) - (lambda (trie representative-handle) - (let ([dfa-representative->handle (trie-dfa-representative->handle trie)]) - (cdr (assq representative-handle dfa-representative->handle))))) - - (define/contract get-handle-from-representative - (trie? . ->d . - (lambda (trie) - (let ([dfa->handle (trie-dfa-representative->handle trie)]) - (unless (length-one? dfa->handle) - (error 'get-handle-from-representative - "~a (!= 1) representatives present: ~a" (length dfa->handle) dfa->handle)) - (unless (= (caar dfa->handle) (cdar dfa->handle)) - (error 'get-handle-from-representative "Representative handle ~a not equal to representative handle ~a" - (caar dfa->handle) (cdar dfa->handle))) - handle?))) - (lambda (trie) - (caar (trie-dfa-representative->handle trie)))) - - ; Return a handle of the DFAs start state if the DFA has already - ; been hasconsed. For each of the ordered DFA states we descend one - ; level in the trie until we reach the last state (the - ; representative). As we are descending we note which of the tries - ; contains the start state. Getting the representative handle, we - ; can lookup the handle of the start state in this noted trie. - (define/contract dfa-present? - (trie? (nonempty-list-of? state?) . -> . (or/c false/c (listof handle?))) - (lambda (trie nstates) - (let/ec return-with - (let* ([rev-tries (list:foldl (lambda (state tries) - (let ([trie (get-trie-child (car tries) state)]) - (if trie - (cons trie tries) - (return-with #f)))) - (list trie) - nstates)] - [rep-handle (get-handle-from-representative (car rev-tries))]) - ;; get the handles for each state, in reverse order from the (reversed) list of tries - (list:foldr (lambda (trie states) (cons (get-state-handle trie rep-handle) states)) - '() (cdr (reverse rev-tries))))))) - - ; Add a list of DFA states and their corresponding handles to the trie - (define/contract add-dfa-states - (trie? (nonempty-list-of? state?) (listof handle?) . ->d . - (lambda (trie states handles) - (unless (= (length states) (length handles)) - (error 'add "length of list of types ~a != length of DFA handle list ~a" - (length states) (length handles))) - (lambda (_) - (let loop ([trie trie] [states states]) - (if (null? states) - (begin - (unless (hash-table-empty? (trie-dfa-state->trie trie)) - (error 'add-dfa-states "Representative node has a child node")) - (unless (length-one? (trie-dfa-representative->handle trie)) - (error 'add-dfa-states "Representative node has more than one representative handle"))) - (loop (get-trie-child trie (car states)) (cdr states))))))) - (lambda (trie states handles) - (let ([add-child (lambda (trie letter representative-handle dfa-handle) - (add-trie-state-handle! - (if (get-trie-child trie letter) (get-trie-child trie letter) - (let ([child-trie (make-trie)]) - (hash-table-put! (trie-dfa-state->trie trie) letter child-trie) - child-trie)) - representative-handle dfa-handle))] - [representative-handle (list-ref handles (sub1 (length handles)))]) - (let loop ([trie trie] [states states] [handles handles]) - (unless (null? states) - (loop (add-child trie (car states) representative-handle (car handles)) - (cdr states) - (cdr handles))))))) - - ) ;; end module trie diff --git a/collects/mrflow/types.ss b/collects/mrflow/types.ss deleted file mode 100644 index fe718e1484..0000000000 --- a/collects/mrflow/types.ss +++ /dev/null @@ -1,122 +0,0 @@ -(module types mzscheme - (provide (all-defined)) - - (define-struct type () (make-inspector)) - - ; (make-type-empty) is the same as (make-type-cst 'bottom) for now. The reason we - ; *never* use (make-type-cst 'bottom) is because it would trigger the propagation of - ; bottom everywhere, thus slowing down the analysis. There's two solutions to that: - ; - not use initialize-label-set-for-value-source when using (make-type-cst 'bottom) - ; - use a separate (make-type-empty), which is more correct anyway (note that there's - ; currently no way to define the type for a primitive that returns the symbol 'bottom - ; (or 'number, or 'null, etc...)) - (define-struct (type-empty type) () (make-inspector)) - - (define-struct (type-cst type) (type) (make-inspector)) - (define-struct (type-cons type) (car cdr) (make-inspector)) - (define-struct (type-vector type) (element) (make-inspector)) - (define-struct (type-case-lambda type) (rest-arg?s req-args argss exps) (make-inspector)) - (define-struct (type-var type) (name reach handle) (make-inspector)) - (define-struct (type-union type) (elements) (make-inspector)) - (define-struct (type-rec type) (vars types body) (make-inspector)) - (define-struct (type-values type) (type) (make-inspector)) - (define-struct (type-promise type) (value) (make-inspector)) - - ; note: we have to keep the type label around, because that's the only thing - ; that allows us to differentiate structurally equivalent structure that have - ; the same name (i.e. the only way to have subtyping work in the presence of generative - ; structures). The reason for type-struct-type is because structure types are first - ; class values in mzscheme. Also, by keeping the type-label around, we avoid the need - ; to duplicate the type hierarchy all the way up to the root each time we compute the - ; type of a structure. - (define-struct (type-struct-value type) (type-label types) (make-inspector)) - (define-struct (type-struct-type type) (type-label) (make-inspector)) - - (define-struct (type-flow-var type) (name) (make-inspector)) - (define-struct (type-scheme type) (flow-vars type^cs type) (make-inspector)) - - - ;; - ;; Printing - ;; - - (require mzlib/match - (prefix string: mzlib/string) - "util.ss" - "labels.ss") - - (define type->list - (lambda (type) - (letrec - ([loop (lambda (type) - (match type - [($ type-empty) '_] - [($ type-cst type) - (if (null? type) - 'null - (string->symbol (string:expr->string type)))] - [($ type-struct-type label) - (string->symbol (string-append "#string (label-struct-type-name label)) - ">"))] - [($ type-cons hd tl) - (list 'cons (loop hd) (loop tl))] - [($ type-case-lambda rest-arg?s req-args argss exps) - (list 'case-lambda - (foldr-case-lambda-vector - (lambda (rest-arg? req-arg args exp acc) - (cons (list args (if rest-arg? '*-> '->) exp) acc)) - null - rest-arg?s req-args argss exps))] - [($ type-promise value) - (list 'promise (loop value))] - [($ type-struct-value label types) - (list (string->symbol - (string-append "#(struct:" - (symbol->string (if (label-struct-type? label) - (label-struct-type-name label) - label)))) - (map loop types))] - [($ type-values values-type) - (cond - [(type-empty? values-type) - (loop values-type)] - [(and (type-cst? values-type) (eq? (type-cst-type values-type) 'top)) - (loop values-type)] - [else - (list 'values (loop values-type))])] - [($ type-vector element) - (list 'vector (loop element))] - [($ type-union elements) - (list 'union (map loop elements))] - [($ type-rec vars binders body) - (list 'rec-type - (map (lambda (v b) - (list (loop v) (loop b))) - vars binders) - (loop body))] - [($ type-var name r h) - name] - [(? natural?) (string->symbol (string-append "h:" (number->string type)))]))]) - (loop type)))) - - (define handle? natural?) - - ;; Is there a better place for this? - (define foldr-case-lambda-vector - (lambda (f init rest-arg?s req-args argss exps) - (let* ([v-to-l (lambda (x) (if (list? x) (list->vector x) x))] - [rest-arg?s (v-to-l rest-arg?s)] - [req-args (v-to-l req-args)] - [argss (if (list? argss) (lol->vov argss) argss)] - [exps (v-to-l exps)] - [len (vector-length rest-arg?s)]) - (let loop ([i 0]) - (if (= i len) init - (f (vector-ref rest-arg?s i) - (vector-ref req-args i) - (vector-ref argss i) - (vector-ref exps i) - (loop (add1 i)))))))) - -) diff --git a/collects/mrflow/util.ss b/collects/mrflow/util.ss deleted file mode 100644 index cb7a4c5415..0000000000 --- a/collects/mrflow/util.ss +++ /dev/null @@ -1,269 +0,0 @@ - -(module util (lib "mrflow.ss" "mrflow") - (require (prefix list: mzlib/list) - mzlib/pretty - mzlib/class - (prefix cst: "constants.ss")) - - (provide (all-defined)) - - ;; - ;; Number functions - ;; - (define natural? (lambda (n) (and (integer? n) (>= n 0)))) - - - ;; - ;; List functions - ;; - (define length-one? - (lambda (x) (and (pair? x) (null? (cdr x))))) - - (define nonempty-list-of? - (lambda (p) (lambda (xs) (and (pair? xs) (andmap p xs))))) - - (define unfold-onto - (lambda (p f g seed onto) - (if (p seed) onto - (cons (f seed) (unfold-onto p f g (g seed) onto))))) - - (define unfold - (lambda (p f g seed) - (unfold-onto p f g seed '()))) - - ;; int -> list int - (define iota - (lambda (n) - (unfold (lambda (x) (= x n)) (lambda (x) x) add1 0))) - - (define min-list-numbers - (let ([remove-duplicates ;; remove duplicate numbers from a sorted list - (lambda (xs) ;; of numbers, returned list is reversed - (if (null? xs) '() - (let loop ((xs (cdr xs)) (acc (list (car xs)))) - (if (null? xs) acc - (if (< (car xs) (car acc)) - (loop (cdr xs) (cons (car xs) acc)) - (loop (cdr xs) acc))))))]) - (lambda (nums) - (remove-duplicates (list:sort nums >))))) - - (define/contract lol->vov ((listof (listof any/c)) . -> . vector?) - (lambda (xss) (list->vector (map list->vector xss)))) - - (define map2deep - (lambda (f xss) - (map (lambda (xs) (map f xs)) xss))) - - (define no-duplicates?/c - (flat-named-contract "List without duplicates" - (lambda (xs) - (let ([tbl (make-hash-table)]) - (let/ec return-with - (for-each (lambda (x) - (when (hash-table-get tbl x cst:thunk-false) - (return-with #f)) - (hash-table-put! tbl x #t)) - xs) - #t))))) - - ;; - ;; Vector functions - ;; - (define foldr-vector - (lambda (f init v) - (let loop ([i 0]) - (if (= i (vector-length v)) init - (f (vector-ref v i) (loop (add1 i))))))) - - (define interval->list - (lambda (v lo hi) - (let loop ([i lo]) - (if (= i hi) '() - (cons (vector-ref v i) (loop (add1 i))))))) - - (define list->immutable-vector - (lambda xs - (apply vector-immutable xs))) - - (define/contract map-vector ((any/c . -> . any) vector? . -> . vector?) - (lambda (f v) - (let* ([len (vector-length v)] - [new-v (make-vector len #f)]) - (let loop ([i 0]) - (when (< i len) - (vector-set! new-v i (f (vector-ref v i))) - (loop (add1 i)))) - new-v))) - - (define/contract map-vector-of-vector ((any/c . -> . any) (vectorof vector?) . -> . (vectorof vector?)) - (lambda (f vov) - (map-vector (lambda (v) (map-vector f v)) vov))) - - (define/contract for-each-vector ((any/c . -> . any) vector? . -> . void?) - (lambda (f v) - (let ([len (vector-length v)]) - (let loop ([i 0]) - (when (< i len) - (f (vector-ref v i)) - (loop (add1 i))))) - cst:void)) - - ; Replace each element e in a vector with (f e) - (define/contract for-each-vector! ((any/c . -> . any) vector? . -> . vector?) - (lambda (f v) - (let ([len (vector-length v)]) - (let loop ([i 0]) - (when (< i len) - (vector-set! v i (f (vector-ref v i))) - (loop (add1 i))))) - v)) - - (define/contract for-each-vov ((any/c . -> . any) (vectorof (vectorof any/c)) . -> . void?) - (lambda (f vov) - (for-each-vector (lambda (v) (for-each-vector f v) v) vov))) - - ; Replace each element in a vector of vectors with (f e) - (define/contract for-each-vov! ((any/c . -> . any) (vectorof (vectorof any/c)) . -> . any) - (lambda (f vov) - (for-each-vector! (lambda (v) (for-each-vector! f v) v) vov) - vov)) - - (define vector-of? - (lambda (pred v) - (let/ec escape - (let loop ([i 0]) - (if (= i (vector-length v)) #t - (if (pred (vector-ref v i)) - (loop (add1 i)) - (escape #f))))))) - - (define vector-of-vector-of? - (lambda (pred vov) - (vector-of? (lambda (v) (vector-of? pred v)) vov))) - - (define vector-has? - (lambda (pred v) - (let/ec escape - (let loop ([i 0]) - (if (= i (vector-length v)) #f - (if (pred (vector-ref v i)) - (escape #t) - (loop (add1 i)))))))) - - (define vector-of-vector-has? - (lambda (pred vov) - (vector-has? (lambda (v) (vector-has? pred v)) vov))) - - - ;; - ;; Hash functions - ;; - - (define hash-table-size - (lambda (h) - (let ([size 0]) - (hash-table-for-each h (lambda (_ _2) (set! size (add1 size)))) - size))) - - (define hash-table-empty? - (lambda (h) - (let/ec escape - (hash-table-for-each h (lambda (k v) (escape #f))) - #t))) - - (define/contract hash-table-has-key? (hash-table? any/c . -> . boolean?) - (lambda (hash-table key) - (if (hash-table-get hash-table key cst:thunk-false) #t #f))) - - ;; (hash-table key (list value)) key value -> (hash-table key (list value)) - (define/contract hash-table-prepend! (hash-table? any/c any/c . -> . any) - (lambda (hash-table key value) - (hash-table-put! hash-table key - (if (hash-table-has-key? hash-table key) - (cons value (hash-table-get hash-table key - (lambda () (error 'hash-table-prepend! "Could not prepend")))) - (list value))))) - - ;; - ;; Function functions - ;; - (define (curry f) - (lambda (x) (f x))) - - ;; - ;; Boolean functions - ;; - (define true? - (lambda (x) (eq? x #t))) - - ;; - ;; Random functions - ;; - - (define/contract numberify-symbol (symbol? integer? . -> . symbol?) - (lambda (sym x) - (string->symbol (string-append (symbol->string sym) ":" (number->string x))))) - - (define/contract numberify-list ((cons/c symbol? (listof any/c)) integer? . -> . (cons/c symbol? (listof any/c))) - (lambda (syms x) - (cons (numberify-symbol (car syms)) (cdr syms)))) - - (define/contract pretty-error (symbol? any/c . -> . any) - (lambda (sym v) - (let ([out (open-output-string)]) - (pretty-print v out) - (error sym (get-output-string out))))) - - (define andmap4-vector - (lambda (f v0 v1 v2 v3) - (let loop ([i 0]) - (if (= i (vector-length v0)) #t - (and (f (vector-ref v0 i) (vector-ref v1 i) (vector-ref v2 i) (vector-ref v3 i)) - (loop (add1 i))))))) - - (define andmap2-vector-interval - (lambda (f v0 v1 lo high) - (let loop ([i lo]) - (if (= i high) #t - (and (f (vector-ref v0 i) (vector-ref v1 i)) - (loop (add1 i))))))) - - (define andmap2-vector - (lambda (f v0 v1) - (andmap2-vector-interval f v0 v1 0 (vector-length v0)))) - - ; return #t if the p(i) = # for all i in the half-open interval lo <= i < hi - (define andmap-vector-interval - (lambda (f v0 lo high) - (let loop ([i lo]) - (if (= i high) #t - (and (f (vector-ref v0 i)) - (loop (add1 i))))))) - - (define andmap-vector - (lambda (f v0) - (andmap-vector-interval f v0 0 (vector-length v0)))) - - (define ormap4-vector - (lambda (f v0 v1 v2 v3) - (let loop ([i 0]) - (if (= i (vector-length v0)) #f - (or (f (vector-ref v0 i) (vector-ref v1 i) (vector-ref v2 i) (vector-ref v3 i)) - (loop (add1 i))))))) - - - ;; Classes - - (define counter% - (class object% - (init-field [start 0]) - (define count start) - - (define/public get - (lambda () count)) - - (define/public next! - (lambda () (set! count (add1 count)) count)) - (super-new))) - )