From 7ed2a1540b1d58fddb4b79a8f85a20aeaa99f9f9 Mon Sep 17 00:00:00 2001 From: Eric Dobson Date: Sat, 25 May 2013 00:38:51 -0700 Subject: [PATCH] Make TR use syntax-length instead of (length (syntax->list x)). original commit: 4af6b6ffcfefe047a2d77723a50476324146824a --- collects/typed-racket/base-env/colon.rkt | 4 ++-- collects/typed-racket/base-env/prims.rkt | 5 +++-- collects/typed-racket/optimizer/unboxed-let.rkt | 2 +- .../typed-racket/typecheck/tc-app/tc-app-hetero.rkt | 4 ++-- .../typed-racket/typecheck/tc-app/tc-app-lambda.rkt | 12 ++++++------ .../typed-racket/typecheck/tc-app/tc-app-list.rkt | 4 ++-- .../typed-racket/typecheck/tc-app/tc-app-objects.rkt | 6 +++--- .../typed-racket/typecheck/tc-app/tc-app-values.rkt | 6 +++--- collects/typed-racket/typecheck/tc-expr-unit.rkt | 12 ++++++------ 9 files changed, 28 insertions(+), 27 deletions(-) diff --git a/collects/typed-racket/base-env/colon.rkt b/collects/typed-racket/base-env/colon.rkt index 85ee88f5..fed3f6f8 100644 --- a/collects/typed-racket/base-env/colon.rkt +++ b/collects/typed-racket/base-env/colon.rkt @@ -1,6 +1,6 @@ #lang racket/base -(require (for-syntax racket/base syntax/parse unstable/sequence +(require (for-syntax racket/base syntax/parse unstable/sequence unstable/syntax "internal.rkt" "../utils/disappeared-use.rkt") "../typecheck/internal-forms.rkt" (prefix-in t: "base-types-extra.rkt")) @@ -34,7 +34,7 @@ (syntax-property (internal (syntax/loc stx (:-internal i ty))) 'disappeared-use #'i)] [(_ i:id x ...) - (case (length (syntax->list #'(x ...))) + (case (syntax-length #'(x ...)) [(1) (err "can only annotate identifiers with types" #'i)] [(0) (err "missing type")] [else (err "bad syntax (multiple types after identifier)")])])) diff --git a/collects/typed-racket/base-env/prims.rkt b/collects/typed-racket/base-env/prims.rkt index b97caecc..6d5f6f22 100644 --- a/collects/typed-racket/base-env/prims.rkt +++ b/collects/typed-racket/base-env/prims.rkt @@ -52,6 +52,7 @@ This file defines two sorts of primitives. All of them are provided into any mod syntax/parse racket/syntax unstable/sequence + unstable/syntax racket/base racket/struct-info syntax/struct @@ -131,7 +132,7 @@ This file defines two sorts of primitives. All of them are provided into any mod (define ((r/t-maker legacy) stx) (syntax-parse stx [(_ lib:expr (~var c (clause legacy #'lib)) ...) - (unless (< 0 (length (syntax->list #'(c ...)))) + (when (zero? (syntax-length #'(c ...))) (raise-syntax-error #f "at least one specification is required" stx)) #`(begin c.spec ...)] [(_ #:internal nm:opt-rename ty lib (~optional [~seq #:struct-maker parent]) ...) @@ -640,7 +641,7 @@ This file defines two sorts of primitives. All of them are provided into any mod [hidden (generate-temporary #'name.nm)] [orig-struct-info (generate-temporary #'nm)] [spec (if (syntax-e #'name.parent) #'(nm parent) #'nm)] - [num-fields (length (syntax->list #'(fld ...)))] + [num-fields (syntax-length #'(fld ...))] [(type-des _ pred sel ...) (build-struct-names #'nm (syntax->list #'(fld ...)) #f #t)] [(mut ...) (map (lambda _ #'#f) (syntax->list #'(sel ...)))] [maker-name #'input-maker.name] diff --git a/collects/typed-racket/optimizer/unboxed-let.rkt b/collects/typed-racket/optimizer/unboxed-let.rkt index fc9a5de3..9bc90ea8 100644 --- a/collects/typed-racket/optimizer/unboxed-let.rkt +++ b/collects/typed-racket/optimizer/unboxed-let.rkt @@ -128,7 +128,7 @@ #:with (opt-functions:unboxed-fun-clause ...) #'(function-candidates ...) #:with (opt-others:opt-let-clause ...) #'(others ...) #:with opt - (begin (when (not (null? (syntax->list #'(opt-candidates.id ...)))) + (begin (unless (zero? (syntax-length #'(opt-candidates.id ...))) ;; only log when we actually optimize (log-optimization "unboxed let bindings" arity-raising-opt-msg diff --git a/collects/typed-racket/typecheck/tc-app/tc-app-hetero.rkt b/collects/typed-racket/typecheck/tc-app/tc-app-hetero.rkt index c320d156..118b3ef2 100644 --- a/collects/typed-racket/typecheck/tc-app/tc-app-hetero.rkt +++ b/collects/typed-racket/typecheck/tc-app/tc-app-hetero.rkt @@ -2,7 +2,7 @@ (require "../../utils/utils.rkt" (prefix-in c: (contract-req)) - syntax/parse racket/match unstable/sequence + syntax/parse racket/match unstable/sequence unstable/syntax syntax/parse/experimental/reflect "signatures.rkt" "utils.rkt" @@ -112,7 +112,7 @@ (tc-expr/check e (ret t)) t)))] [(tc-result1: (app resolve (HeterogeneousVector: ts))) - (unless (= (length ts) (length (syntax->list #'(args ...)))) + (unless (= (length ts) (syntax-length #'(args ...))) (tc-error/expr "expected vector with ~a elements, but got ~a" (length ts) (make-HeterogeneousVector (map tc-expr/t (syntax->list #'(args ...)))))) diff --git a/collects/typed-racket/typecheck/tc-app/tc-app-lambda.rkt b/collects/typed-racket/typecheck/tc-app/tc-app-lambda.rkt index 7b1a0111..8cbbb149 100644 --- a/collects/typed-racket/typecheck/tc-app/tc-app-lambda.rkt +++ b/collects/typed-racket/typecheck/tc-app/tc-app-lambda.rkt @@ -5,7 +5,7 @@ "utils.rkt" syntax/parse racket/match racket/list syntax/parse/experimental/reflect - unstable/sequence + unstable/sequence unstable/syntax (typecheck signatures tc-funapp find-annotation) (types abbrev utils generalize type-table) (private type-annotation) @@ -27,22 +27,22 @@ (let-loop-check #'lam #'lp #'actuals #'(args ...) #'body expected)) ;; inference for ((lambda (pattern ((#%plain-lambda (x ...) . body) args ...) - #:fail-unless (= (length (syntax->list #'(x ...))) - (length (syntax->list #'(args ...)))) #f + #:fail-unless (= (syntax-length #'(x ...)) + (syntax-length #'(args ...))) #f #:fail-when (andmap type-annotation (syntax->list #'(x ...))) #f (tc/let-values #'((x) ...) #'(args ...) #'body #'(let-values ([(x) args] ...) . body) expected)) ;; inference for ((lambda with dotted rest (pattern ((#%plain-lambda (x ... . rst:id) . body) args ...) - #:fail-unless (<= (length (syntax->list #'(x ...))) - (length (syntax->list #'(args ...)))) #f + #:fail-unless (<= (syntax-length #'(x ...)) + (syntax-length #'(args ...))) #f ;; FIXME - remove this restriction - doesn't work because the annotation ;; on rst is not a normal annotation, may have * or ... #:fail-when (type-annotation #'rst) #f #:fail-when (andmap type-annotation (syntax->list #'(x ...))) #f (let-values ([(fixed-args varargs) - (split-at (syntax->list #'(args ...)) (length (syntax->list #'(x ...))))]) + (split-at (syntax->list #'(args ...)) (syntax-length #'(x ...)))]) (with-syntax ([(fixed-args ...) fixed-args] [varg #`(#%plain-app list #,@varargs)]) (tc/let-values #'((x) ... (rst)) #`(fixed-args ... varg) #'body diff --git a/collects/typed-racket/typecheck/tc-app/tc-app-list.rkt b/collects/typed-racket/typecheck/tc-app/tc-app-list.rkt index c9b2824b..218266cd 100644 --- a/collects/typed-racket/typecheck/tc-app/tc-app-list.rkt +++ b/collects/typed-racket/typecheck/tc-app/tc-app-list.rkt @@ -4,7 +4,7 @@ (require "../../utils/utils.rkt" "signatures.rkt" "utils.rkt" - syntax/parse racket/match unstable/sequence + syntax/parse racket/match unstable/sequence unstable/syntax syntax/parse/experimental/reflect (only-in '#%kernel [reverse k:reverse]) (typecheck signatures tc-funapp) @@ -84,7 +84,7 @@ (for ([i (in-syntax #'args)]) (tc-expr/check i (ret elem-ty))) expected] - [(tc-result1: (List: (? (lambda (ts) (= (length (syntax->list #'args)) + [(tc-result1: (List: (? (lambda (ts) (= (syntax-length #'args) (length ts))) ts))) (for ([ac (in-syntax #'args)] diff --git a/collects/typed-racket/typecheck/tc-app/tc-app-objects.rkt b/collects/typed-racket/typecheck/tc-app/tc-app-objects.rkt index 9ed8335f..769ab4aa 100644 --- a/collects/typed-racket/typecheck/tc-app/tc-app-objects.rkt +++ b/collects/typed-racket/typecheck/tc-app/tc-app-objects.rkt @@ -3,7 +3,7 @@ (require "../../utils/utils.rkt" "signatures.rkt" "utils.rkt" - syntax/parse racket/match unstable/sequence + syntax/parse racket/match unstable/sequence unstable/syntax syntax/parse/experimental/reflect (typecheck signatures tc-funapp) (types abbrev union utils) @@ -39,9 +39,9 @@ [(tc-result1: (Union: '())) (ret (Un))] [(tc-result1: (and c (Class: pos-tys (list (and tnflds (list tnames _ _)) ...) _))) (unless (= (length pos-tys) - (length (syntax->list pos-args))) + (syntax-length pos-args)) (tc-error/delayed "expected ~a positional arguments, but got ~a" - (length pos-tys) (length (syntax->list pos-args)))) + (length pos-tys) (syntax-length pos-args))) ;; use for, since they might be different lengths in error case (for ([pa (in-syntax pos-args)] [pt (in-list pos-tys)]) diff --git a/collects/typed-racket/typecheck/tc-app/tc-app-values.rkt b/collects/typed-racket/typecheck/tc-app/tc-app-values.rkt index a041cbbe..d8cefcb3 100644 --- a/collects/typed-racket/typecheck/tc-app/tc-app-values.rkt +++ b/collects/typed-racket/typecheck/tc-app/tc-app-values.rkt @@ -3,7 +3,7 @@ (require "../../utils/utils.rkt" "signatures.rkt" "utils.rkt" - syntax/parse racket/match unstable/sequence + syntax/parse racket/match unstable/sequence unstable/syntax syntax/parse/experimental/reflect (typecheck signatures tc-funapp) (types abbrev utils) @@ -50,10 +50,10 @@ [ef (in-list efs)] [eo (in-list eos)]) (single-value arg (ret et ef eo)))]) - (if (= (length ts) (length ets) (length (syntax->list #'args))) + (if (= (length ts) (length ets) (syntax-length #'args)) (ret ts fs os) (tc-error/expr #:return expected "wrong number of values: expected ~a but got ~a" - (length ets) (length (syntax->list #'args)))))] + (length ets) (syntax-length #'args))))] [_ (match-let ([(list (tc-result1: ts fs os) ...) (for/list ([arg (in-syntax #'args)]) (single-value arg))]) diff --git a/collects/typed-racket/typecheck/tc-expr-unit.rkt b/collects/typed-racket/typecheck/tc-expr-unit.rkt index 2f3cbd59..e27d1103 100644 --- a/collects/typed-racket/typecheck/tc-expr-unit.rkt +++ b/collects/typed-racket/typecheck/tc-expr-unit.rkt @@ -13,8 +13,8 @@ (utils tc-utils stxclass-util) (env lexical-env type-env-structs tvar-env index-env) racket/private/class-internal - syntax/parse - unstable/function #;unstable/debug + syntax/parse + unstable/function unstable/syntax #;unstable/debug (only-in srfi/1 split-at) (for-template "internal-forms.rkt" (only-in '#%paramz [parameterization-key pz:pk]))) @@ -45,15 +45,15 @@ (tc-error/expr #:return (Un) "Cannot instantiate non-polymorphic type ~a" (cleanup-type ty))] [(and (Poly? ty) - (not (= (length (syntax->list inst)) (Poly-n ty)))) + (not (= (syntax-length inst) (Poly-n ty)))) (tc-error/expr #:return (Un) "Wrong number of type arguments to polymorphic type ~a:\nexpected: ~a\ngot: ~a" - (cleanup-type ty) (Poly-n ty) (length (syntax->list inst)))] - [(and (PolyDots? ty) (not (>= (length (syntax->list inst)) (sub1 (PolyDots-n ty))))) + (cleanup-type ty) (Poly-n ty) (syntax-length inst))] + [(and (PolyDots? ty) (not (>= (syntax-length inst) (sub1 (PolyDots-n ty))))) ;; we can provide 0 arguments for the ... var (tc-error/expr #:return (Un) "Wrong number of type arguments to polymorphic type ~a:\nexpected at least: ~a\ngot: ~a" - (cleanup-type ty) (sub1 (PolyDots-n ty)) (length (syntax->list inst)))] + (cleanup-type ty) (sub1 (PolyDots-n ty)) (syntax-length inst))] [(PolyDots? ty) ;; In this case, we need to check the last thing. If it's a dotted var, then we need to ;; use instantiate-poly-dotted, otherwise we do the normal thing.