suzanne.soy/typed-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 
original commit: 4af6b6ffcfefe047a2d77723a50476324146824a
This commit is contained in:
Eric Dobson 2013-05-25 00:38:51 -07:00
parent 2960e2663f
commit 7ed2a1540b
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
(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)")])]))

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
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]

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

@ -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

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

@ -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 ...))))))

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

@ -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

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

@ -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)]

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

@ -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)])

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

@ -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))])

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

@ -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.