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