From 06367272b68239c61d5286259b47ac5b50a7eb4f Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sat, 13 Aug 2011 16:11:20 -0400 Subject: [PATCH] Fix initial type environment for new-style keyword functions. original commit: 54c044c36a5738a862379e4f10d0b9453c8e27b0 --- .../typed-scheme/succeed/simple-kw-app.rkt | 8 + collects/typed-scheme/base-env/base-env.rkt | 23 +- .../base-env/base-special-env.rkt | 313 +++++++++++++++++- collects/typed-scheme/base-env/env-lang.rkt | 4 +- 4 files changed, 336 insertions(+), 12 deletions(-) create mode 100644 collects/tests/typed-scheme/succeed/simple-kw-app.rkt diff --git a/collects/tests/typed-scheme/succeed/simple-kw-app.rkt b/collects/tests/typed-scheme/succeed/simple-kw-app.rkt new file mode 100644 index 00000000..6f36f474 --- /dev/null +++ b/collects/tests/typed-scheme/succeed/simple-kw-app.rkt @@ -0,0 +1,8 @@ +#lang typed/racket + +((values file->string) "/dev/null" #:mode 'binary) +(file->string "/dev/null" #:mode 'text) + +file->value file->bytes + +(file->lines #:mode 'text #:line-mode 'linefeed "/dev/null") diff --git a/collects/typed-scheme/base-env/base-env.rkt b/collects/typed-scheme/base-env/base-env.rkt index d75da747..25aac651 100644 --- a/collects/typed-scheme/base-env/base-env.rkt +++ b/collects/typed-scheme/base-env/base-env.rkt @@ -1,8 +1,6 @@ #lang s-exp "env-lang.rkt" (require - - (for-template (except-in racket -> ->* one-of/c) racket/unsafe/ops @@ -739,6 +737,7 @@ ;Section 14.2.5 ;racket/file +#| [file->string (->key -Pathlike #:mode (one-of/c 'binary 'text) #f -String)] [file->bytes (->key -Pathlike #:mode (one-of/c 'binary 'text) #f -Bytes)] [file->value (->key -Pathlike #:mode (one-of/c 'binary 'text) #f Univ)] @@ -773,6 +772,7 @@ #:mode (one-of/c 'binary 'text) #f #:exists (one-of/c 'error 'append 'update 'replace 'truncate 'truncate/replace) #f -Void)] +|# [copy-directory/files (-> -Pathlike -Pathlike -Void)] [delete-directory/files (-> -Pathlike -Void)] @@ -790,7 +790,7 @@ [make-directory* (-> -Pathlike -Void)] [make-temporary-file (->opt [-String (Un -Pathlike (-val 'directory) (-val #f)) (-opt -Pathlike)] -Path)] - +#| [get-preference (let ((use-lock-type Univ) (timeout-lock-there-type (-opt (-> -Path Univ))) @@ -808,11 +808,12 @@ (->key Sym (-> Univ) Univ (-opt -Pathlike) #:use-lock? use-lock-type #f #:timeout-lock-there timeout-lock-there-type #f #:lock-there lock-there-type #f Univ)))] +|# [put-preferences (->opt (-lst -Symbol) (-lst Univ) [(-> -Path Univ) (-opt -Pathlike)] -Void)] [preferences-lock-file-mode (-> (one-of/c 'exists 'file-lock))] - +#| [make-handle-get-preference-locked (let ((lock-there-type (-opt (-> -Path Univ))) (max-delay-type -Real)) (cl->* @@ -839,6 +840,7 @@ #:delay -Real #f #:max-delay -Real #f a))] +|# [make-lock-file-name (->opt -Pathlike [-Pathlike] -Pathlike)] @@ -1139,6 +1141,7 @@ [variable-reference->resolved-module-path (-> -Variable-Reference (-opt -Resolved-Module-Path))] [variable-reference->module-source (-> -Variable-Reference (Un Sym (-val #f) -Path))] [variable-reference->phase (-> -Variable-Reference -Nat)] +[variable-reference-constant? (-> -Variable-Reference -Boolean)] @@ -1401,6 +1404,7 @@ [maybe-print-message (-String . -> . -Void)] +#| [sort (-poly (a b) (cl->* ((-lst a) (a a . -> . B) #:cache-keys? B #f . ->key . (-lst a)) @@ -1408,7 +1412,7 @@ #:key (a . -> . b) #t #:cache-keys? B #f . ->key . (-lst a))))] - +|# ;; scheme/function @@ -2083,7 +2087,9 @@ [port-count-lines-enabled (-Param Univ B)] ;Section 12.1.5 +#| [open-input-file (->key -Pathlike #:mode (one-of/c 'binary 'text) #f -Input-Port)] + [open-output-file (->key -Pathlike #:mode (one-of/c 'binary 'text) #f @@ -2107,6 +2113,7 @@ #:exists (one-of/c 'error 'append 'update 'replace 'truncate 'truncate/replace) #f #:mode (one-of/c 'binary 'text) #f . ->key . a))] + [call-with-input-file* (-poly (a) (-Pathlike (-Input-Port . -> . a) #:mode (Un (-val 'binary) (-val 'text)) #f . ->key . a))] [call-with-output-file* (-poly (a) (-Pathlike (-Output-Port . -> . a) #:exists (one-of/c 'error 'append 'update 'replace 'truncate 'truncate/replace) #f @@ -2123,7 +2130,7 @@ #f #:mode (one-of/c 'binary 'text) #f a))] - +|# [port-try-file-lock? (-> (Un -Input-Port -Output-Port) (one-of/c 'shared 'exclusive) B)] [port-file-unlock (-> (Un -Input-Port -Output-Port) -Void)] @@ -2174,6 +2181,7 @@ (->opt (-> -Input-Port a) [-Input-Port] (-lst a))))] [port->string (->opt [-Input-Port] -String)] [port->bytes (->opt [-Input-Port] -Bytes)] +#| [port->lines (cl->* (->key #:line-mode (one-of/c 'linefeed 'return 'return-linefeed 'any 'any-one) #f (-lst -String)) @@ -2183,10 +2191,11 @@ (->key #:line-mode (one-of/c 'linefeed 'return 'return-linefeed 'any 'any-one) #f (-lst -Bytes)) (->key -Input-Port #:line-mode (one-of/c 'linefeed 'return 'return-linefeed 'any 'any-one) #f (-lst -Bytes)))] + [display-lines (cl->* ((-lst Univ) #:separator Univ #f . ->key . -Void) ((-lst Univ) -Output-Port #:separator Univ #f . ->key . -Void))] - +|# [call-with-output-string (-> (-> -Output-Port ManyUniv) -String)] [call-with-output-bytes (-> (-> -Output-Port ManyUniv) -Bytes)] diff --git a/collects/typed-scheme/base-env/base-special-env.rkt b/collects/typed-scheme/base-env/base-special-env.rkt index 28a6b1f2..45d17eb0 100644 --- a/collects/typed-scheme/base-env/base-special-env.rkt +++ b/collects/typed-scheme/base-env/base-special-env.rkt @@ -5,6 +5,7 @@ "../utils/utils.rkt" racket/promise string-constants/string-constant + racket/private/kw racket/file racket/port (for-syntax racket/base syntax/parse (only-in racket/syntax syntax-local-eval) (utils tc-utils) (env init-envs) @@ -143,7 +144,7 @@ #:literals (let-values let) [(let-values ((_ (let _ (c . _) . _)) . _) - . _) + . _) #'c]) (-> Univ Univ Univ)] ;; check-in-lines @@ -152,7 +153,7 @@ #:literals (let-values #%app let) [(let-values ((_ (let _ (c . _) . _)) . _) - . _) + . _) #'c]) (-> Univ Univ Univ)] ;; check-in-port @@ -161,7 +162,7 @@ #:literals (let-values #%app let) [(let-values ((_ (let _ (c . _) . _)) . _) - . _) + . _) #'c]) (-> Univ Univ Univ)] ;; from the expansion of `with-syntax' @@ -183,5 +184,311 @@ (if _ (let-values _ (letrec-syntaxes+values _ _ (#%plain-app with-syntax-fail _))) _)))))) #'with-syntax-fail]) (-> (-Syntax Univ) (Un))] + + ;; below here: keyword-argument functions from the base environment + ;; FIXME: abstraction to remove duplication here + + [((kw-expander-proc (syntax-local-value #'file->string))) + (->key -Pathlike #:mode (one-of/c 'binary 'text) #f -String)] + [((kw-expander-impl (syntax-local-value #'file->string))) + (-> (Un (-val #f) (one-of/c 'binary 'text)) -Boolean -Pathlike -String)] + + [((kw-expander-proc (syntax-local-value #'file->bytes))) + (->key -Pathlike #:mode (one-of/c 'binary 'text) #f -Bytes)] + [((kw-expander-impl (syntax-local-value #'file->bytes))) + (-> (Un (-val #f) (one-of/c 'binary 'text)) -Boolean -Pathlike -Bytes)] + + [((kw-expander-proc (syntax-local-value #'file->value))) + (->key -Pathlike #:mode (one-of/c 'binary 'text) #f Univ)] + [((kw-expander-impl (syntax-local-value #'file->value))) + (-> (Un (-val #f) (one-of/c 'binary 'text)) -Boolean -Pathlike Univ)] + + [((kw-expander-proc (syntax-local-value #'file->lines))) + (->key -Pathlike #:mode (one-of/c 'binary 'text) #f + #:line-mode (one-of/c 'linefeed 'return 'return-linefeed 'any 'any-one) #f + (-lst -String))] + [((kw-expander-impl (syntax-local-value #'file->lines))) + (-> (Un (-val #f) (one-of/c 'linefeed 'return 'return-linefeed 'any 'any-one)) -Boolean + (Un (-val #f) (one-of/c 'binary 'text)) -Boolean + -Pathlike (-lst -String))] + + [((kw-expander-proc (syntax-local-value #'file->bytes-lines))) + (->key -Pathlike + #:line-mode (one-of/c 'linefeed 'return 'return-linefeed 'any 'any-one) #f + #:mode (one-of/c 'binary 'text) #f + (-lst -String))] + [((kw-expander-impl (syntax-local-value #'file->bytes-lines))) + (-> (Un (-val #f) (one-of/c 'linefeed 'return 'return-linefeed 'any 'any-one)) -Boolean + (Un (-val #f) (one-of/c 'binary 'text)) -Boolean + -Pathlike (-lst -Bytes))] + + [((kw-expander-proc (syntax-local-value #'display-to-file))) + (->key Univ -Pathlike + #:exists (one-of/c 'error 'append 'update 'replace 'truncate 'truncate/replace) #f + #:mode (one-of/c 'binary 'text) #f + -Void)] + [((kw-expander-impl (syntax-local-value #'display-to-file))) + (-> (Un (-val #f) (one-of/c 'error 'append 'update 'replace 'truncate 'truncate/replace)) -Boolean + (Un (-val #f) (one-of/c 'binary 'text)) -Boolean + Univ -Pathlike -Void)] + + [((kw-expander-proc (syntax-local-value #'display-lines-to-file))) + (->key (-lst Univ) -Pathlike + #:separator Univ #f + #:mode (one-of/c 'binary 'text) #f + #:exists (one-of/c 'error 'append 'update 'replace 'truncate 'truncate/replace) #f + -Void)] + [((kw-expander-impl (syntax-local-value #'display-lines-to-file))) + (-> (Un (-val #f) (one-of/c 'error 'append 'update 'replace 'truncate 'truncate/replace)) -Boolean + (Un (-val #f) (one-of/c 'binary 'text)) -Boolean + (Un (-val #f) Univ) -Boolean + (-lst Univ) -Pathlike -Void)] + + [((kw-expander-proc (syntax-local-value #'write-to-file))) + (->key Univ -Pathlike + #:exists (one-of/c 'error 'append 'update 'replace 'truncate 'truncate/replace) #f + #:mode (one-of/c 'binary 'text) #f + -Void)] + [((kw-expander-impl (syntax-local-value #'write-to-file))) + (-> (Un (-val #f) (one-of/c 'error 'append 'update 'replace 'truncate 'truncate/replace)) -Boolean + (Un (-val #f) (one-of/c 'binary 'text)) -Boolean + Univ -Pathlike -Void)] + + [((kw-expander-proc (syntax-local-value #'file->list))) + (-poly (a) + (cl->* (->key -Pathlike #:mode (one-of/c 'binary 'text) #f (-lst Univ)) + (->key -Pathlike (-> -Input-Port a) #:mode (one-of/c 'binary 'text) #f (-lst a))))] + [((kw-expander-impl (syntax-local-value #'file->list))) + (-poly (a) + (cl->* (-> (Un (-val #f) (one-of/c 'binary 'text)) -Boolean -Pathlike (-> -Input-Port a) (-val #t) (-lst a)) + (-> (Un (-val #f) (one-of/c 'binary 'text)) -Boolean -Pathlike Univ -Boolean (-lst Univ))))] + + [((kw-expander-proc (syntax-local-value #'get-preference))) + (let ((use-lock-type Univ) + (timeout-lock-there-type (-opt (-> -Path Univ))) + (lock-there-type (-opt (-> -Path Univ)))) + (cl->* + (->key -Symbol + #:use-lock? use-lock-type #f #:timeout-lock-there timeout-lock-there-type #f #:lock-there lock-there-type #f + Univ) + (->key -Symbol (-> Univ) + #:use-lock? use-lock-type #f #:timeout-lock-there timeout-lock-there-type #f #:lock-there lock-there-type #f + Univ) + (->key -Symbol (-> Univ) Univ + #:use-lock? use-lock-type #f #:timeout-lock-there timeout-lock-there-type #f #:lock-there lock-there-type #f + Univ) + (->key -Symbol (-> Univ) Univ (-opt -Pathlike) + #:use-lock? use-lock-type #f #:timeout-lock-there timeout-lock-there-type #f #:lock-there lock-there-type #f + Univ)))] + [((kw-expander-impl (syntax-local-value #'get-preference))) + (let ((use-lock-type Univ) + (timeout-lock-there-type (-opt (-> -Path Univ))) + (lock-there-type (-opt (-> -Path Univ)))) + (-> (-opt lock-there-type) -Boolean + (-opt timeout-lock-there-type) -Boolean + (-opt use-lock-type) -Boolean + -Symbol + (-opt (-> Univ)) (-opt Univ) (-opt (-opt -Pathlike)) + -Boolean -Boolean -Boolean + Univ))] + + [((kw-expander-proc (syntax-local-value #'make-handle-get-preference-locked))) + (let ((lock-there-type (-opt (-> -Path Univ))) (max-delay-type -Real)) + (cl->* + (->key -Real -Symbol + #:lock-there lock-there-type #f #:max-delay max-delay-type #f + (-> -Pathlike Univ)) + (->key -Real -Symbol (-> Univ) + #:lock-there lock-there-type #f #:max-delay max-delay-type #f + (-> -Pathlike Univ)) + (->key -Real -Symbol (-> Univ) Univ + #:lock-there lock-there-type #f #:max-delay max-delay-type #f + (-> -Pathlike Univ)) + (->key -Real -Symbol (-> Univ) Univ (-opt -Pathlike) + #:lock-there lock-there-type #f #:max-delay max-delay-type #f + (-> -Pathlike Univ))))] + [((kw-expander-impl (syntax-local-value #'make-handle-get-preference-locked))) + (let ((lock-there-type (-opt (-> -Path Univ))) (max-delay-type -Real)) + (-> (-opt lock-there-type) -Boolean + (-opt max-delay-type) -Boolean + -Real -Symbol + (-opt (-> Univ)) (-opt Univ) (-opt (-opt -Pathlike)) + -Boolean -Boolean -Boolean + (-> -Pathlike Univ)))] + + [((kw-expander-proc (syntax-local-value #'call-with-file-lock/timeout))) + (-poly (a) + (->key (-opt -Pathlike) + (one-of/c 'shared 'exclusive) + (-> a) + (-> a) + #:lock-file (-opt -Pathlike) #f + #:delay -Real #f + #:max-delay -Real #f + a))] + [((kw-expander-impl (syntax-local-value #'call-with-file-lock/timeout))) + (-poly (a) + (-> (-opt -Real) -Boolean + (-opt (-opt -Pathlike)) -Boolean + (-opt -Real) -Boolean + (-opt -Pathlike) + (one-of/c 'shared 'exclusive) + (-> a) + (-> a) + a))] + + [((kw-expander-proc (syntax-local-value #'sort))) + (-poly (a b) (cl->* ((-lst a) (a a . -> . -Boolean) + #:cache-keys? -Boolean #f + . ->key . (-lst a)) + ((-lst a) (b b . -> . -Boolean) + #:key (a . -> . b) #t + #:cache-keys? -Boolean #f + . ->key . (-lst a))))] + [((kw-expander-impl (syntax-local-value #'sort))) + (-poly (a b) + (cl->* + ;; #:key not provided + (-> + -Boolean -Boolean Univ (-val #f) + (-lst a) (a a . -> . -Boolean) + (-lst a)) + ;; #:key provided + (-> + -Boolean -Boolean (a . -> . b) (-val #t) + (-lst a) (b b . -> . -Boolean) + (-lst a))))] + + [((kw-expander-proc (syntax-local-value #'open-input-file))) + (->key -Pathlike #:mode (one-of/c 'binary 'text) #f -Input-Port)] + [((kw-expander-impl (syntax-local-value #'open-input-file))) + (-> (-opt (one-of/c 'binary 'text)) -Boolean -Pathlike -Input-Port)] + + [((kw-expander-proc (syntax-local-value #'open-output-file))) + (->key -Pathlike + #:mode (one-of/c 'binary 'text) #f + #:exists (one-of/c 'error 'append 'update 'can-update + 'replace 'truncate + 'must-truncate 'truncate/replace) + #f + -Output-Port)] + [((kw-expander-impl (syntax-local-value #'open-output-file))) + (-> (-opt (one-of/c 'error 'append 'update 'can-update + 'replace 'truncate + 'must-truncate 'truncate/replace)) + -Boolean + (-opt (one-of/c 'binary 'text)) -Boolean + -Pathlike + -Output-Port)] + + [((kw-expander-proc (syntax-local-value #'open-input-output-file))) + (->key -Pathlike + #:mode (one-of/c 'binary 'text) #f + #:exists (one-of/c 'error 'append 'update 'can-update + 'replace 'truncate + 'must-truncate 'truncate/replace) + #f + (-values (list -Input-Port -Output-Port)))] + [((kw-expander-impl (syntax-local-value #'open-input-output-file))) + (-> (-opt (one-of/c 'error 'append 'update 'can-update + 'replace 'truncate + 'must-truncate 'truncate/replace)) + -Boolean + (-opt (one-of/c 'binary 'text)) -Boolean + -Pathlike + (-values (list -Input-Port -Output-Port)))] + + [((kw-expander-proc (syntax-local-value #'call-with-input-file))) + (-poly (a) (-Pathlike (-Input-Port . -> . a) #:mode (Un (-val 'binary) (-val 'text)) #f . ->key . a))] + [((kw-expander-impl (syntax-local-value #'call-with-input-file))) + (-poly (a) (-> (-opt (one-of/c 'binary 'text)) -Boolean -Pathlike (-Input-Port . -> . a) a))] + + [((kw-expander-proc (syntax-local-value #'call-with-output-file))) + (-poly (a) (-Pathlike (-Output-Port . -> . a) + #:exists (one-of/c 'error 'append 'update 'replace 'truncate 'truncate/replace) #f + #:mode (one-of/c 'binary 'text) #f + . ->key . a))] + [((kw-expander-impl (syntax-local-value #'call-with-output-file))) + (-poly (a) (-> (-opt (one-of/c 'error 'append 'update 'can-update + 'replace 'truncate + 'must-truncate 'truncate/replace)) + -Boolean + (-opt (one-of/c 'binary 'text)) -Boolean + -Pathlike (-Output-Port . -> . a) + a))] + + ;; + + [((kw-expander-proc (syntax-local-value #'call-with-input-file*))) + (-poly (a) (-Pathlike (-Input-Port . -> . a) #:mode (Un (-val 'binary) (-val 'text)) #f . ->key . a))] + [((kw-expander-impl (syntax-local-value #'call-with-input-file*))) + (-poly (a) (-> (-opt (one-of/c 'binary 'text)) -Boolean -Pathlike (-Input-Port . -> . a) a))] + + [((kw-expander-proc (syntax-local-value #'call-with-output-file*))) + (-poly (a) (-Pathlike (-Output-Port . -> . a) + #:exists (one-of/c 'error 'append 'update 'replace 'truncate 'truncate/replace) #f + #:mode (one-of/c 'binary 'text) #f + . ->key . a))] + [((kw-expander-impl (syntax-local-value #'call-with-output-file*))) + (-poly (a) (-> (-opt (one-of/c 'error 'append 'update 'can-update + 'replace 'truncate + 'must-truncate 'truncate/replace)) + -Boolean + (-opt (one-of/c 'binary 'text)) -Boolean + -Pathlike (-Output-Port . -> . a) + a))] + ;; + [((kw-expander-proc (syntax-local-value #'with-input-from-file))) + (-poly (a) (-Pathlike (-> a) #:mode (Un (-val 'binary) (-val 'text)) #f . ->key . a))] + [((kw-expander-impl (syntax-local-value #'with-input-from-file))) + (-poly (a) (-> (-opt (one-of/c 'binary 'text)) -Boolean -Pathlike (-> a) a))] + + [((kw-expander-proc (syntax-local-value #'with-output-to-file))) + (-poly (a) (->key -Pathlike (-> a) + #:exists (one-of/c 'error 'append 'update 'can-update + 'replace 'truncate + 'must-truncate 'truncate/replace) + #f + #:mode (one-of/c 'binary 'text) #f + a))] + [((kw-expander-impl (syntax-local-value #'with-output-to-file))) + (-poly (a) (-> (-opt (one-of/c 'error 'append 'update 'can-update + 'replace 'truncate + 'must-truncate 'truncate/replace)) + -Boolean + (-opt (one-of/c 'binary 'text)) -Boolean + -Pathlike (-> a) + a))] + + + [((kw-expander-proc (syntax-local-value #'port->lines))) + (cl->* + (->key #:line-mode (one-of/c 'linefeed 'return 'return-linefeed 'any 'any-one) #f (-lst -String)) + (->key -Input-Port #:line-mode (one-of/c 'linefeed 'return 'return-linefeed 'any 'any-one) #f (-lst -String)))] + [((kw-expander-impl (syntax-local-value #'port->lines))) + ((-opt (one-of/c 'linefeed 'return 'return-linefeed 'any 'any-one)) -Boolean + (-opt -Input-Port) -Boolean + . -> . + (-lst -String))] + + [((kw-expander-proc (syntax-local-value #'port->bytes-lines))) + (cl->* + (->key #:line-mode (one-of/c 'linefeed 'return 'return-linefeed 'any 'any-one) #f (-lst -Bytes)) + (->key -Input-Port #:line-mode (one-of/c 'linefeed 'return 'return-linefeed 'any 'any-one) #f (-lst -Bytes)))] + [((kw-expander-impl (syntax-local-value #'port->bytes-lines))) + ((-opt (one-of/c 'linefeed 'return 'return-linefeed 'any 'any-one)) -Boolean + (-opt -Input-Port) -Boolean + . -> . + (-lst -Bytes))] + + [((kw-expander-proc (syntax-local-value #'display-lines))) + (cl->* + ((-lst Univ) #:separator Univ #f . ->key . -Void) + ((-lst Univ) -Output-Port #:separator Univ #f . ->key . -Void))] + [((kw-expander-impl (syntax-local-value #'display-lines))) + ((-opt Univ) -Boolean + (-lst Univ) + (-opt -Output-Port) -Boolean + . -> . -Void)] ) diff --git a/collects/typed-scheme/base-env/env-lang.rkt b/collects/typed-scheme/base-env/env-lang.rkt index 8ad2f2c8..4ed8cda1 100644 --- a/collects/typed-scheme/base-env/env-lang.rkt +++ b/collects/typed-scheme/base-env/env-lang.rkt @@ -1,4 +1,4 @@ -#lang scheme/base +#lang racket/base (require (rename-in "../utils/utils.rkt" [infer r:infer])) @@ -32,6 +32,6 @@ (provide (rename-out [-#%module-begin #%module-begin]) require - (except-out (all-from-out scheme/base) #%module-begin) + (except-out (all-from-out racket/base) #%module-begin) types rep private utils (types-out convenience union filter-ops))