suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

contracts: union => or/c

Browse Source 
svn: r2290
This commit is contained in:
Philippe Meunier 2006-02-20 23:09:21 +00:00
parent cf85841c57
commit 4190ed9af2
6 changed files with 34 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
collects/mrflow/constraints-gen-and-prop.ss
View File

@ -201,7 +201,7 @@
env))
env args args-labels))
; syntax-object (listof (cons symbol label)) -> (union label #f)
; 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
@ -224,7 +224,7 @@
(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 -> (union label #f)
; 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))
@ -3222,7 +3222,7 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; PRIMITIVE TYPE PARSER AND LOOKUP
; sba-state symbol -> (union prim-data #f)
; 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))
@ -4450,14 +4450,14 @@
; 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? (union false/c label?) . -> . boolean?)
(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? (union false/c label?) . -> . boolean?)
(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
@ -4493,11 +4493,11 @@
(eq? term-type '#%top)
(eq? term-type 'quote))))))
; label -> (union number #f)
; label -> (or/c number #f)
(define (get-span-from-label label)
(syntax-span (label-term label)))
; sba-state label (union 'red 'green 'orange) string -> void
; 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)
@ -4573,7 +4573,7 @@
(set-type-var-reach! (label-type-var label) set)
set))))
; label -> (union type-var handle)
; 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)]
@ -4646,7 +4646,7 @@
(set-type-var-handle! (label-type-var label) handle)
handle)))
; type (union (hash-table-of type-flow-var (cons label type)) symbol) -> string
; 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.

8
collects/mrflow/dfa.ss
View File

@ -109,7 +109,7 @@
(lambda (dfa state-number)
(hash-table-get (dfa-stnum->state dfa) state-number)))
(define/contract greatest-handle (dfa? . -> . (union false/c handle?))
(define/contract greatest-handle (dfa? . -> . (or/c false/c handle?))
(lambda (dfa)
(let ([greatest-handle -1])
(hash-table-for-each (dfa-stnum->state dfa)
@ -292,7 +292,7 @@
(hash-table-put! state->var state str)
str)))]
[statify
(lambda (sym state) ;((union symbol? list?) state-number? . -> . (union symbol? list?))
(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)))])
@ -802,13 +802,13 @@
;;
(define/contract set-equiv-class-of-state-number!
((vectorof (union false/c natural?)) equiv-class? state-number? . -> . void?)
((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? . -> . (union integer? boolean?)))
(define discriminator? (state? . -> . (or/c integer? boolean?)))
(define/contract block->partition (block? . -> . partition?)
list-immutable)

26
collects/mrflow/hashcons.ss
View File

@ -48,16 +48,16 @@
;(pretty-print-columns 105)
;; Some predicates for contracts
(define label-type? (union type-case-lambda? type-cons? type-promise?
type-struct-value? type-union? type-values? type-vector?))
(define base-type? (union type-empty? type-cst? type-struct-type?))
(define hashcons-type? (union label-type? base-type? type-rec?))
(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 -> (union dfa label base-type)
(from-handle ;; handle -> (or/c dfa label base-type)
from-dfa ;; dfa -> handle
from-label ;; label -> handle
from-base-type ;; base-type -> handle
@ -270,7 +270,7 @@
;; 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? (union type? handle?) . -> . (union type? handle?))
(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)
@ -374,7 +374,7 @@
(hashcons type))))
(define/contract bottom-up-hashcons-rec-type
(hashcons-table? . -> . ((listof type-var?) (listof (union type? handle?)) (union type? handle?) . ->d .
(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)))
@ -646,7 +646,7 @@
[else (error 'fold-type "Unmatched type ~a" type)])))))
;; Return a type with handles replacing variables
(define/contract subst-handles/vars ((union label-type? handle? type-var?) tenv? . -> . (union type? handle?))
(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
@ -684,7 +684,7 @@
[else (error 'subst-handles/vars "Unmatched type ~a" type)]))))
(define/contract subst-handles/vars-if-possible
((union hashcons-type? handle? type-var?) tenv? . -> . (union type? handle?))
((or/c hashcons-type? handle? type-var?) tenv? . -> . (or/c type? handle?))
(lambda (type tenv)
(let subst ([type type])
(match type
@ -722,7 +722,7 @@
type])
)))
(define/contract has-free-vars? ((union type? handle?) . -> . boolean?)
(define/contract has-free-vars? ((or/c type? handle?) . -> . boolean?)
(lambda (type)
(let* ([bound-vars (make-hash-table)]
[bind (lambda (var)
@ -769,7 +769,7 @@
[_ (error 'has-free-vars? "Unmatched type ~a" type)])])
(has-free-vars? type))))))
(define/contract get-referenced-vars ((union type? handle?) . -> . (listof symbol?))
(define/contract get-referenced-vars ((or/c type? handle?) . -> . (listof symbol?))
(lambda (type)
(let ([refed (make-hash-table)])
(let loop ([type type])
@ -797,7 +797,7 @@
(hash-table-map refed (lambda (v _) v))))))
(define/contract same-label-type?
(hashcons-table? state? (union type? handle?) . -> . boolean?)
(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))
@ -1163,7 +1163,7 @@
(hash-table-put! handle->var handle str)
str)))]
[handlify
(lambda (str handle) ;(any/c handle? . -> . (union symbol? (cons/p symbol? any/c)))
(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

8
collects/mrflow/snips-and-arrows-model.ss
View File

@ -114,7 +114,7 @@
(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? (union symbol? boolean?) 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?))
@ -222,7 +222,7 @@
(label-gui-data-left-new-pos label-gui-data)
(get-new-pos-from-label gui-model-state label))))
; gui-model-state label -> (union top #f)
; 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
@ -556,7 +556,7 @@
(make-ending-arrow-set)))))
cst:void)
; gui-model-state label (union symbol boolean) boolean -> 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?)
@ -588,7 +588,7 @@
get-source-from-label)))
cst:void)
; (assoc-setof top source-gui-data) (setof arrow) (union symbol boolean)
; (assoc-setof top source-gui-data) (setof arrow) (or/c symbol boolean)
; (arrow -> label) (label-gui-data -> (setof arrow))
; (label -> top)
; -> (setof arrow)

4
collects/mrflow/snips-and-arrows-view.ss
View File

@ -64,7 +64,7 @@
(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? (union symbol? boolean?) boolean? . -> . void?))
(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?))
@ -167,7 +167,7 @@
(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 (union symbol boolean) boolean -> void
; 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?))

4
collects/mrflow/trie.ss
View File

@ -29,7 +29,7 @@
(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? . -> . (union trie? false/c))
(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)))
@ -75,7 +75,7 @@
; 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?) . -> . (union false/c (listof handle?)))
(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)