improved the known-good-contract? predicate by including more known
contracts and speeding it up
This commit is contained in:
Robby Findler
parent
1bedd9a9f6
commit
f2b5538b56
|
|
@ -161,137 +161,210 @@
|
|||
[(= i n) '()]
|
||||
[else (cons i (loop (+ i 1)))])))
|
||||
|
||||
(define known-good-ids
|
||||
(list #'absolute-path?
|
||||
#'bound-identifier=?
|
||||
#'box?
|
||||
#'byte-pregexp?
|
||||
#'byte-regexp?
|
||||
#'byte?
|
||||
#'bytes-converter?
|
||||
#'bytes=?
|
||||
#'bytes?
|
||||
#'channel?
|
||||
#'char-alphabetic?
|
||||
#'char-blank?
|
||||
#'char-graphic?
|
||||
#'char-iso-control?
|
||||
#'char-lower-case?
|
||||
#'char-numeric?
|
||||
#'char-punctuation?
|
||||
#'char-symbolic?
|
||||
#'char-title-case?
|
||||
#'char-upper-case?
|
||||
#'char-whitespace?
|
||||
#'compiled-expression?
|
||||
#'compiled-module-expression?
|
||||
#'complete-path?
|
||||
#'continuation-mark-set?
|
||||
#'continuation-prompt-available?
|
||||
#'custodian-box?
|
||||
#'custodian-memory-accounting-available?
|
||||
#'custodian?
|
||||
#'directory-exists?
|
||||
#'ephemeron?
|
||||
#'evt?
|
||||
#'exn:break?
|
||||
#'exn:fail:contract:arity?
|
||||
#'exn:fail:contract:continuation?
|
||||
#'exn:fail:contract:divide-by-zero?
|
||||
#'exn:fail:contract:variable?
|
||||
#'exn:fail:contract?
|
||||
#'exn:fail:filesystem:exists?
|
||||
#'exn:fail:filesystem:version?
|
||||
#'exn:fail:filesystem?
|
||||
#'exn:fail:network?
|
||||
#'exn:fail:out-of-memory?
|
||||
#'exn:fail:read:eof?
|
||||
#'exn:fail:read:non-char?
|
||||
#'exn:fail:read?
|
||||
#'exn:fail:syntax?
|
||||
#'exn:fail:unsupported?
|
||||
#'exn:fail:user?
|
||||
#'exn:fail?
|
||||
#'exn?
|
||||
#'file-exists?
|
||||
#'file-stream-port?
|
||||
#'free-identifier=?
|
||||
#'handle-evt?
|
||||
#'hash-table?
|
||||
#'identifier?
|
||||
#'immutable?
|
||||
#'inspector?
|
||||
#'keyword?
|
||||
#'link-exists?
|
||||
#'module-identifier=?
|
||||
#'module-path-index?
|
||||
#'module-provide-protected?
|
||||
#'module-template-identifier=?
|
||||
#'module-transformer-identifier=?
|
||||
#'namespace?
|
||||
#'parameter-procedure=?
|
||||
#'parameter?
|
||||
#'parameterization?
|
||||
#'path-for-some-system?
|
||||
#'path-string?
|
||||
#'path?
|
||||
#'port-closed?
|
||||
#'port-provides-progress-evts?
|
||||
#'port-writes-atomic?
|
||||
#'port-writes-special?
|
||||
#'port?
|
||||
#'pregexp?
|
||||
#'primitive-closure?
|
||||
#'primitive?
|
||||
#'procedure-arity-includes?
|
||||
#'procedure-closure-contents-eq?
|
||||
#'procedure-struct-type?
|
||||
#'promise?
|
||||
#'pseudo-random-generator?
|
||||
#'regexp-match?
|
||||
#'regexp?
|
||||
#'relative-path?
|
||||
#'rename-transformer?
|
||||
#'security-guard?
|
||||
#'semaphore-try-wait?
|
||||
#'semaphore?
|
||||
#'set!-transformer?
|
||||
#'special-comment?
|
||||
#'string-locale-ci=?
|
||||
#'string-locale=?
|
||||
#'struct-accessor-procedure?
|
||||
#'struct-constructor-procedure?
|
||||
#'struct-mutator-procedure?
|
||||
#'struct-predicate-procedure?
|
||||
#'struct-type-property?
|
||||
#'struct-type?
|
||||
#'struct?
|
||||
#'subprocess?
|
||||
#'syntax-graph?
|
||||
#'syntax-original?
|
||||
#'syntax-transforming?
|
||||
#'syntax?
|
||||
#'system-big-endian?
|
||||
#'tcp-accept-ready?
|
||||
#'tcp-listener?
|
||||
#'tcp-port?
|
||||
#'terminal-port?
|
||||
#'thread-cell?
|
||||
#'thread-dead?
|
||||
#'thread-group?
|
||||
#'thread-running?
|
||||
#'thread?
|
||||
#'udp-bound?
|
||||
#'udp-connected?
|
||||
#'udp?
|
||||
#'void?
|
||||
#'weak-box?
|
||||
#'will-executor?
|
||||
#'arity-at-least?
|
||||
#'exn:srclocs?
|
||||
#'srcloc?))
|
||||
#|
|
||||
|
||||
;; the code below builds the known-good-syms-ht
|
||||
|
||||
(define cm
|
||||
(parameterize ([read-accept-compiled #t])
|
||||
(call-with-input-file
|
||||
"C:\\Users\\robby\\git\\plt\\collects\\racket\\compiled\\base_rkt.zo" read)))
|
||||
|
||||
(define ns (make-base-namespace))
|
||||
(parameterize ([current-namespace ns])
|
||||
(namespace-require 'racket/base))
|
||||
|
||||
(define-values (vars stx) (module-compiled-exports cm))
|
||||
(define known-good-syms
|
||||
(filter (λ (x) (and (regexp-match #rx"[?]$" (symbol->string x))
|
||||
(procedure-arity-includes? (eval x ns) 1)))
|
||||
(map car (cdr (assoc 0 vars)))))
|
||||
(define table-to-be-turned-into-a-literal-hash
|
||||
(map (λ (x) (cons x #t))
|
||||
(sort known-good-syms
|
||||
string<=?
|
||||
#:key symbol->string)))
|
||||
|
||||
|#
|
||||
|
||||
(define known-good-syms-ht
|
||||
'#hash((absolute-path? . #t)
|
||||
(arity-at-least? . #t)
|
||||
(boolean? . #t)
|
||||
(box? . #t)
|
||||
(byte-pregexp? . #t)
|
||||
(byte-ready? . #t)
|
||||
(byte-regexp? . #t)
|
||||
(byte? . #t)
|
||||
(bytes-converter? . #t)
|
||||
(bytes? . #t)
|
||||
(channel? . #t)
|
||||
(chaperone? . #t)
|
||||
(char-alphabetic? . #t)
|
||||
(char-blank? . #t)
|
||||
(char-graphic? . #t)
|
||||
(char-iso-control? . #t)
|
||||
(char-lower-case? . #t)
|
||||
(char-numeric? . #t)
|
||||
(char-punctuation? . #t)
|
||||
(char-ready? . #t)
|
||||
(char-symbolic? . #t)
|
||||
(char-title-case? . #t)
|
||||
(char-upper-case? . #t)
|
||||
(char-whitespace? . #t)
|
||||
(char? . #t)
|
||||
(compiled-expression? . #t)
|
||||
(compiled-module-expression? . #t)
|
||||
(complete-path? . #t)
|
||||
(complex? . #t)
|
||||
(continuation-mark-set? . #t)
|
||||
(continuation-prompt-available? . #t)
|
||||
(continuation-prompt-tag? . #t)
|
||||
(continuation? . #t)
|
||||
(custodian-box? . #t)
|
||||
(custodian? . #t)
|
||||
(custom-print-quotable? . #t)
|
||||
(custom-write? . #t)
|
||||
(date*? . #t)
|
||||
(date-dst? . #t)
|
||||
(date? . #t)
|
||||
(directory-exists? . #t)
|
||||
(double-flonum? . #t)
|
||||
(eof-object? . #t)
|
||||
(ephemeron? . #t)
|
||||
(even? . #t)
|
||||
(evt? . #t)
|
||||
(exact-integer? . #t)
|
||||
(exact-nonnegative-integer? . #t)
|
||||
(exact-positive-integer? . #t)
|
||||
(exact? . #t)
|
||||
(exn:break? . #t)
|
||||
(exn:fail:contract:arity? . #t)
|
||||
(exn:fail:contract:continuation? . #t)
|
||||
(exn:fail:contract:divide-by-zero? . #t)
|
||||
(exn:fail:contract:non-fixnum-result? . #t)
|
||||
(exn:fail:contract:variable? . #t)
|
||||
(exn:fail:contract? . #t)
|
||||
(exn:fail:filesystem:exists? . #t)
|
||||
(exn:fail:filesystem:version? . #t)
|
||||
(exn:fail:filesystem? . #t)
|
||||
(exn:fail:network? . #t)
|
||||
(exn:fail:out-of-memory? . #t)
|
||||
(exn:fail:read:eof? . #t)
|
||||
(exn:fail:read:non-char? . #t)
|
||||
(exn:fail:read? . #t)
|
||||
(exn:fail:syntax:unbound? . #t)
|
||||
(exn:fail:syntax? . #t)
|
||||
(exn:fail:unsupported? . #t)
|
||||
(exn:fail:user? . #t)
|
||||
(exn:fail? . #t)
|
||||
(exn:srclocs? . #t)
|
||||
(exn? . #t)
|
||||
(file-exists? . #t)
|
||||
(file-stream-port? . #t)
|
||||
(fixnum? . #t)
|
||||
(flonum? . #t)
|
||||
(handle-evt? . #t)
|
||||
(hash-eq? . #t)
|
||||
(hash-equal? . #t)
|
||||
(hash-eqv? . #t)
|
||||
(hash-placeholder? . #t)
|
||||
(hash-weak? . #t)
|
||||
(hash? . #t)
|
||||
(identifier? . #t)
|
||||
(immutable? . #t)
|
||||
(impersonator-property-accessor-procedure? . #t)
|
||||
(impersonator-property? . #t)
|
||||
(impersonator? . #t)
|
||||
(inexact-real? . #t)
|
||||
(inexact? . #t)
|
||||
(input-port? . #t)
|
||||
(inspector? . #t)
|
||||
(integer? . #t)
|
||||
(internal-definition-context? . #t)
|
||||
(keyword? . #t)
|
||||
(liberal-define-context? . #t)
|
||||
(link-exists? . #t)
|
||||
(list? . #t)
|
||||
(log-receiver? . #t)
|
||||
(logger? . #t)
|
||||
(module-path-index? . #t)
|
||||
(module-path? . #t)
|
||||
(mpair? . #t)
|
||||
(namespace-anchor? . #t)
|
||||
(namespace? . #t)
|
||||
(negative? . #t)
|
||||
(null? . #t)
|
||||
(number? . #t)
|
||||
(odd? . #t)
|
||||
(output-port? . #t)
|
||||
(pair? . #t)
|
||||
(parameter? . #t)
|
||||
(parameterization? . #t)
|
||||
(path-for-some-system? . #t)
|
||||
(path-string? . #t)
|
||||
(path? . #t)
|
||||
(placeholder? . #t)
|
||||
(port-closed? . #t)
|
||||
(port-provides-progress-evts? . #t)
|
||||
(port-writes-atomic? . #t)
|
||||
(port-writes-special? . #t)
|
||||
(port? . #t)
|
||||
(positive? . #t)
|
||||
(pregexp? . #t)
|
||||
(primitive-closure? . #t)
|
||||
(primitive? . #t)
|
||||
(procedure-arity? . #t)
|
||||
(procedure-struct-type? . #t)
|
||||
(procedure? . #t)
|
||||
(pseudo-random-generator? . #t)
|
||||
(rational? . #t)
|
||||
(readtable? . #t)
|
||||
(real? . #t)
|
||||
(regexp? . #t)
|
||||
(relative-path? . #t)
|
||||
(rename-transformer? . #t)
|
||||
(resolved-module-path? . #t)
|
||||
(security-guard? . #t)
|
||||
(semaphore-try-wait? . #t)
|
||||
(semaphore? . #t)
|
||||
(sequence? . #t)
|
||||
(set!-transformer? . #t)
|
||||
(single-flonum? . #t)
|
||||
(special-comment? . #t)
|
||||
(srcloc? . #t)
|
||||
(string? . #t)
|
||||
(struct-accessor-procedure? . #t)
|
||||
(struct-constructor-procedure? . #t)
|
||||
(struct-mutator-procedure? . #t)
|
||||
(struct-predicate-procedure? . #t)
|
||||
(struct-type-property-accessor-procedure? . #t)
|
||||
(struct-type-property? . #t)
|
||||
(struct-type? . #t)
|
||||
(struct? . #t)
|
||||
(subprocess? . #t)
|
||||
(symbol-interned? . #t)
|
||||
(symbol-unreadable? . #t)
|
||||
(symbol? . #t)
|
||||
(syntax-original? . #t)
|
||||
(syntax-tainted? . #t)
|
||||
(syntax? . #t)
|
||||
(terminal-port? . #t)
|
||||
(thread-cell? . #t)
|
||||
(thread-dead? . #t)
|
||||
(thread-group? . #t)
|
||||
(thread-running? . #t)
|
||||
(thread? . #t)
|
||||
(variable-reference-constant? . #t)
|
||||
(variable-reference? . #t)
|
||||
(vector? . #t)
|
||||
(void? . #t)
|
||||
(weak-box? . #t)
|
||||
(will-executor? . #t)
|
||||
(zero? . #t)))
|
||||
|
||||
(define (known-good-contract? id)
|
||||
(and (identifier? id)
|
||||
(ormap (λ (x) (free-identifier=? x id))
|
||||
known-good-ids)))
|
||||
(define r-id (syntax-e id))
|
||||
(and (symbol? r-id)
|
||||
(hash-ref known-good-syms-ht (syntax-e id) #t)
|
||||
(free-identifier=? id (datum->syntax #'here r-id))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user