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

Make TR use syntax-length instead of (length (syntax->list x)).

Browse Source
This commit is contained in:
Eric Dobson 2013-05-25 00:38:51 -07:00
parent 0d771fb4f1
commit 4af6b6ffcf
9 changed files with 28 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/typed-racket/base-env/colon.rkt
View File

@ -1,6 +1,6 @@
#lang racket/base #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") "internal.rkt" "../utils/disappeared-use.rkt")
"../typecheck/internal-forms.rkt" "../typecheck/internal-forms.rkt"
(prefix-in t: "base-types-extra.rkt")) (prefix-in t: "base-types-extra.rkt"))
@ -34,7 +34,7 @@
(syntax-property (internal (syntax/loc stx (:-internal i ty))) (syntax-property (internal (syntax/loc stx (:-internal i ty)))
'disappeared-use #'i)] 'disappeared-use #'i)]
[(_ i:id x ...) [(_ i:id x ...)
(case (length (syntax->list #'(x ...))) (case (syntax-length #'(x ...))
[(1) (err "can only annotate identifiers with types" #'i)] [(1) (err "can only annotate identifiers with types" #'i)]
[(0) (err "missing type")] [(0) (err "missing type")]
[else (err "bad syntax (multiple types after identifier)")])])) [else (err "bad syntax (multiple types after identifier)")])]))

5
collects/typed-racket/base-env/prims.rkt
View File

@ -52,6 +52,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
syntax/parse syntax/parse
racket/syntax racket/syntax
unstable/sequence unstable/sequence
unstable/syntax
racket/base racket/base
racket/struct-info racket/struct-info
syntax/struct 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) (define ((r/t-maker legacy) stx)
(syntax-parse stx (syntax-parse stx
[(_ lib:expr (~var c (clause legacy #'lib)) ...) [(_ 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)) (raise-syntax-error #f "at least one specification is required" stx))
#`(begin c.spec ...)] #`(begin c.spec ...)]
[(_ #:internal nm:opt-rename ty lib (~optional [~seq #:struct-maker parent]) ...) [(_ #: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)] [hidden (generate-temporary #'name.nm)]
[orig-struct-info (generate-temporary #'nm)] [orig-struct-info (generate-temporary #'nm)]
[spec (if (syntax-e #'name.parent) #'(nm parent) #'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)] [(type-des _ pred sel ...) (build-struct-names #'nm (syntax->list #'(fld ...)) #f #t)]
[(mut ...) (map (lambda _ #'#f) (syntax->list #'(sel ...)))] [(mut ...) (map (lambda _ #'#f) (syntax->list #'(sel ...)))]
[maker-name #'input-maker.name] [maker-name #'input-maker.name]

2
collects/typed-racket/optimizer/unboxed-let.rkt
View File

@ -128,7 +128,7 @@
#:with (opt-functions:unboxed-fun-clause ...) #'(function-candidates ...) #:with (opt-functions:unboxed-fun-clause ...) #'(function-candidates ...)
#:with (opt-others:opt-let-clause ...) #'(others ...) #:with (opt-others:opt-let-clause ...) #'(others ...)
#:with opt #: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 ;; only log when we actually optimize
(log-optimization "unboxed let bindings" (log-optimization "unboxed let bindings"
arity-raising-opt-msg arity-raising-opt-msg

4
collects/typed-racket/typecheck/tc-app/tc-app-hetero.rkt
View File

@ -2,7 +2,7 @@
(require "../../utils/utils.rkt" (require "../../utils/utils.rkt"
(prefix-in c: (contract-req)) (prefix-in c: (contract-req))
syntax/parse racket/match unstable/sequence syntax/parse racket/match unstable/sequence unstable/syntax
syntax/parse/experimental/reflect syntax/parse/experimental/reflect
"signatures.rkt" "signatures.rkt"
"utils.rkt" "utils.rkt"
@ -112,7 +112,7 @@
(tc-expr/check e (ret t)) (tc-expr/check e (ret t))
t)))] t)))]
[(tc-result1: (app resolve (HeterogeneousVector: ts))) [(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" (tc-error/expr "expected vector with ~a elements, but got ~a"
(length ts) (length ts)
(make-HeterogeneousVector (map tc-expr/t (syntax->list #'(args ...)))))) (make-HeterogeneousVector (map tc-expr/t (syntax->list #'(args ...))))))

12
collects/typed-racket/typecheck/tc-app/tc-app-lambda.rkt
View File

@ -5,7 +5,7 @@
"utils.rkt" "utils.rkt"
syntax/parse racket/match racket/list syntax/parse racket/match racket/list
syntax/parse/experimental/reflect syntax/parse/experimental/reflect
unstable/sequence unstable/sequence unstable/syntax
(typecheck signatures tc-funapp find-annotation) (typecheck signatures tc-funapp find-annotation)
(types abbrev utils generalize type-table) (types abbrev utils generalize type-table)
(private type-annotation) (private type-annotation)
@ -27,22 +27,22 @@
(let-loop-check #'lam #'lp #'actuals #'(args ...) #'body expected)) (let-loop-check #'lam #'lp #'actuals #'(args ...) #'body expected))
;; inference for ((lambda ;; inference for ((lambda
(pattern ((#%plain-lambda (x ...) . body) args ...) (pattern ((#%plain-lambda (x ...) . body) args ...)
#:fail-unless (= (length (syntax->list #'(x ...))) #:fail-unless (= (syntax-length #'(x ...))
(length (syntax->list #'(args ...)))) #f (syntax-length #'(args ...))) #f
#:fail-when (andmap type-annotation (syntax->list #'(x ...))) #f #:fail-when (andmap type-annotation (syntax->list #'(x ...))) #f
(tc/let-values #'((x) ...) #'(args ...) #'body (tc/let-values #'((x) ...) #'(args ...) #'body
#'(let-values ([(x) args] ...) . body) #'(let-values ([(x) args] ...) . body)
expected)) expected))
;; inference for ((lambda with dotted rest ;; inference for ((lambda with dotted rest
(pattern ((#%plain-lambda (x ... . rst:id) . body) args ...) (pattern ((#%plain-lambda (x ... . rst:id) . body) args ...)
#:fail-unless (<= (length (syntax->list #'(x ...))) #:fail-unless (<= (syntax-length #'(x ...))
(length (syntax->list #'(args ...)))) #f (syntax-length #'(args ...))) #f
;; FIXME - remove this restriction - doesn't work because the annotation ;; FIXME - remove this restriction - doesn't work because the annotation
;; on rst is not a normal annotation, may have * or ... ;; on rst is not a normal annotation, may have * or ...
#:fail-when (type-annotation #'rst) #f #:fail-when (type-annotation #'rst) #f
#:fail-when (andmap type-annotation (syntax->list #'(x ...))) #f #:fail-when (andmap type-annotation (syntax->list #'(x ...))) #f
(let-values ([(fixed-args varargs) (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] (with-syntax ([(fixed-args ...) fixed-args]
[varg #`(#%plain-app list #,@varargs)]) [varg #`(#%plain-app list #,@varargs)])
(tc/let-values #'((x) ... (rst)) #`(fixed-args ... varg) #'body (tc/let-values #'((x) ... (rst)) #`(fixed-args ... varg) #'body

4
collects/typed-racket/typecheck/tc-app/tc-app-list.rkt
View File

@ -4,7 +4,7 @@
(require "../../utils/utils.rkt" (require "../../utils/utils.rkt"
"signatures.rkt" "signatures.rkt"
"utils.rkt" "utils.rkt"
syntax/parse racket/match unstable/sequence syntax/parse racket/match unstable/sequence unstable/syntax
syntax/parse/experimental/reflect syntax/parse/experimental/reflect
(only-in '#%kernel [reverse k:reverse]) (only-in '#%kernel [reverse k:reverse])
(typecheck signatures tc-funapp) (typecheck signatures tc-funapp)
@ -84,7 +84,7 @@
(for ([i (in-syntax #'args)]) (for ([i (in-syntax #'args)])
(tc-expr/check i (ret elem-ty))) (tc-expr/check i (ret elem-ty)))
expected] expected]
[(tc-result1: (List: (? (lambda (ts) (= (length (syntax->list #'args)) [(tc-result1: (List: (? (lambda (ts) (= (syntax-length #'args)
(length ts))) (length ts)))
ts))) ts)))
(for ([ac (in-syntax #'args)] (for ([ac (in-syntax #'args)]

6
collects/typed-racket/typecheck/tc-app/tc-app-objects.rkt
View File

@ -3,7 +3,7 @@
(require "../../utils/utils.rkt" (require "../../utils/utils.rkt"
"signatures.rkt" "signatures.rkt"
"utils.rkt" "utils.rkt"
syntax/parse racket/match unstable/sequence syntax/parse racket/match unstable/sequence unstable/syntax
syntax/parse/experimental/reflect syntax/parse/experimental/reflect
(typecheck signatures tc-funapp) (typecheck signatures tc-funapp)
(types abbrev union utils) (types abbrev union utils)
@ -39,9 +39,9 @@
[(tc-result1: (Union: '())) (ret (Un))] [(tc-result1: (Union: '())) (ret (Un))]
[(tc-result1: (and c (Class: pos-tys (list (and tnflds (list tnames _ _)) ...) _))) [(tc-result1: (and c (Class: pos-tys (list (and tnflds (list tnames _ _)) ...) _)))
(unless (= (length pos-tys) (unless (= (length pos-tys)
(length (syntax->list pos-args))) (syntax-length pos-args))
(tc-error/delayed "expected ~a positional arguments, but got ~a" (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 ;; use for, since they might be different lengths in error case
(for ([pa (in-syntax pos-args)] (for ([pa (in-syntax pos-args)]
[pt (in-list pos-tys)]) [pt (in-list pos-tys)])

6
collects/typed-racket/typecheck/tc-app/tc-app-values.rkt
View File

@ -3,7 +3,7 @@
(require "../../utils/utils.rkt" (require "../../utils/utils.rkt"
"signatures.rkt" "signatures.rkt"
"utils.rkt" "utils.rkt"
syntax/parse racket/match unstable/sequence syntax/parse racket/match unstable/sequence unstable/syntax
syntax/parse/experimental/reflect syntax/parse/experimental/reflect
(typecheck signatures tc-funapp) (typecheck signatures tc-funapp)
(types abbrev utils) (types abbrev utils)
@ -50,10 +50,10 @@
[ef (in-list efs)] [ef (in-list efs)]
[eo (in-list eos)]) [eo (in-list eos)])
(single-value arg (ret et ef eo)))]) (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) (ret ts fs os)
(tc-error/expr #:return expected "wrong number of values: expected ~a but got ~a" (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) ...) [_ (match-let ([(list (tc-result1: ts fs os) ...)
(for/list ([arg (in-syntax #'args)]) (for/list ([arg (in-syntax #'args)])
(single-value arg))]) (single-value arg))])

12
collects/typed-racket/typecheck/tc-expr-unit.rkt
View File

@ -13,8 +13,8 @@
(utils tc-utils stxclass-util) (utils tc-utils stxclass-util)
(env lexical-env type-env-structs tvar-env index-env) (env lexical-env type-env-structs tvar-env index-env)
racket/private/class-internal racket/private/class-internal
syntax/parse syntax/parse
unstable/function #;unstable/debug unstable/function unstable/syntax #;unstable/debug
(only-in srfi/1 split-at) (only-in srfi/1 split-at)
(for-template "internal-forms.rkt" (only-in '#%paramz [parameterization-key pz:pk]))) (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" (tc-error/expr #:return (Un) "Cannot instantiate non-polymorphic type ~a"
(cleanup-type ty))] (cleanup-type ty))]
[(and (Poly? ty) [(and (Poly? ty)
(not (= (length (syntax->list inst)) (Poly-n ty)))) (not (= (syntax-length inst) (Poly-n ty))))
(tc-error/expr #:return (Un) (tc-error/expr #:return (Un)
"Wrong number of type arguments to polymorphic type ~a:\nexpected: ~a\ngot: ~a" "Wrong number of type arguments to polymorphic type ~a:\nexpected: ~a\ngot: ~a"
(cleanup-type ty) (Poly-n ty) (length (syntax->list inst)))] (cleanup-type ty) (Poly-n ty) (syntax-length inst))]
[(and (PolyDots? ty) (not (>= (length (syntax->list inst)) (sub1 (PolyDots-n ty))))) [(and (PolyDots? ty) (not (>= (syntax-length inst) (sub1 (PolyDots-n ty)))))
;; we can provide 0 arguments for the ... var ;; we can provide 0 arguments for the ... var
(tc-error/expr #:return (Un) (tc-error/expr #:return (Un)
"Wrong number of type arguments to polymorphic type ~a:\nexpected at least: ~a\ngot: ~a" "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) [(PolyDots? ty)
;; In this case, we need to check the last thing. If it's a dotted var, then we need to ;; 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. ;; use instantiate-poly-dotted, otherwise we do the normal thing.