From fb29a2498e964c6d7651ca6cc6a19c07ca28760b Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sun, 15 Nov 2009 22:15:29 +0000 Subject: [PATCH] Move a bunch of functions from typed-scheme/utils/utils to unstable. Add convenience lib for unstable docs. Add char support to format-{id,symbol} Add unstable/sequence library. svn: r16789 --- collects/scheme/match/match-expander.ss | 6 +- .../scribblings/reference/contracts.scrbl | 2 +- collects/scribblings/reference/mz.ss | 41 +++-- .../scribblings/reference/sequences.scrbl | 7 - collects/typed-scheme/env/lexical-env.ss | 4 +- collects/typed-scheme/env/type-alias-env.ss | 4 +- collects/typed-scheme/env/type-env.ss | 4 +- .../typed-scheme/infer/constraint-structs.ss | 16 +- collects/typed-scheme/infer/constraints.ss | 5 +- collects/typed-scheme/infer/dmap.ss | 9 +- collects/typed-scheme/infer/infer-unit.ss | 5 +- collects/typed-scheme/private/parse-type.ss | 4 +- collects/typed-scheme/private/prims.ss | 4 +- .../typed-scheme/private/type-annotation.ss | 4 +- .../typed-scheme/private/type-contract.ss | 12 +- collects/typed-scheme/rep/rep-utils.ss | 22 +-- .../typecheck/check-subforms-unit.ss | 4 +- .../typecheck/provide-handling.ss | 4 +- collects/typed-scheme/typecheck/tc-app.ss | 3 +- .../typed-scheme/typecheck/tc-dots-unit.ss | 4 +- collects/typed-scheme/typecheck/tc-if.ss | 2 +- .../typed-scheme/typecheck/tc-lambda-unit.ss | 2 +- collects/typed-scheme/typecheck/tc-structs.ss | 4 +- .../typed-scheme/typecheck/tc-toplevel.ss | 1 + collects/typed-scheme/typed-scheme.ss | 10 +- .../typed-scheme/types/remove-intersect.ss | 4 +- collects/typed-scheme/utils/utils.ss | 155 ++++-------------- collects/unstable/list.ss | 11 ++ collects/unstable/scribblings/list.scrbl | 33 +++- collects/unstable/scribblings/sequence.scrbl | 40 +++++ collects/unstable/scribblings/syntax.scrbl | 27 ++- collects/unstable/scribblings/unstable.scrbl | 1 + collects/unstable/scribblings/utils.ss | 15 ++ collects/unstable/sequence.ss | 45 +++++ collects/unstable/syntax.ss | 17 +- 35 files changed, 310 insertions(+), 221 deletions(-) create mode 100644 collects/unstable/scribblings/sequence.scrbl create mode 100644 collects/unstable/scribblings/utils.ss create mode 100644 collects/unstable/sequence.ss diff --git a/collects/scheme/match/match-expander.ss b/collects/scheme/match/match-expander.ss index 54221b18c5..ff51aa776b 100644 --- a/collects/scheme/match/match-expander.ss +++ b/collects/scheme/match/match-expander.ss @@ -47,8 +47,10 @@ legacy-xform (lambda (stx) (syntax-case stx (set!) - [(nm args (... ...)) #'(macro-xform args (... ...))] - [nm #'macro-xform])) + [(nm . args) #'(macro-xform . args)] + [nm (identifier? #'nm) #'macro-xform] + [(set! . _) + (raise-syntax-error #f "match expander cannot be target of a set!" stx)])) (syntax-local-certifier)))) (syntax/loc stx (define-syntax id diff --git a/collects/scribblings/reference/contracts.scrbl b/collects/scribblings/reference/contracts.scrbl index c3ab96f2cf..8d315d675e 100644 --- a/collects/scribblings/reference/contracts.scrbl +++ b/collects/scribblings/reference/contracts.scrbl @@ -327,7 +327,7 @@ If the @scheme[immutable] argument is @scheme[#f] or and the @scheme[key] and @scheme[val] arguments must also be flat contracts. -If @scheme[immtable] is @scheme[#t], then the other arguments do not +If @scheme[immutable] is @scheme[#t], then the other arguments do not have to be flat contracts, the result is not a flat contract, and checking this contract involves making a copy of the hash-table. } diff --git a/collects/scribblings/reference/mz.ss b/collects/scribblings/reference/mz.ss index 9eb2124533..5381a13a70 100644 --- a/collects/scribblings/reference/mz.ss +++ b/collects/scribblings/reference/mz.ss @@ -5,14 +5,14 @@ scribble/decode scheme/contract "../icons.ss") - + (provide (all-from-out scribble/manual) (all-from-out scribble/eval) (all-from-out scheme/contract)) - + (require (for-label scheme)) (provide (for-label (all-from-out scheme))) - + (provide mz-examples) (define mz-eval (make-base-eval)) (define-syntax mz-examples @@ -21,10 +21,10 @@ (examples #:eval . rest)] [(_ . rest) (examples #:eval mz-eval . rest)])) - + (define AllUnix "Unix and Mac OS X") (provide AllUnix) - + (provide note-lib) (define-syntax note-lib (syntax-rules () @@ -45,7 +45,7 @@ . more)))] [(_ lib . more) (note-lib lib #:use-sources () . more)])) - + (provide note-init-lib) (define-syntax note-init-lib (syntax-rules () @@ -64,7 +64,7 @@ . more)))] [(_ lib . more) (note-init-lib lib #:use-sources () . more)])) - + (provide note-lib-only) (define-syntax note-lib-only (syntax-rules () @@ -78,7 +78,7 @@ . more))] [(_ lib . more) (note-lib-only lib #:use-sources () . more)])) - + (define (*exnraise s) (make-element #f (list s " exception is raised"))) (define-syntax exnraise @@ -88,21 +88,21 @@ (syntax-rules () [(_ s) (scheme s)])) (provide exnraise Exn) - + (provide margin-note/ref refalso moreref Guide guideintro guidesecref HonuManual) - + (define (margin-note/ref . s) (apply margin-note (decode-content (cons magnify s)))) - + (define (refalso tag . s) (apply margin-note (decode-content (append (list magnify (secref tag) " also provides information on ") s (list "."))))) - + (define (moreref tag . s) (apply margin-note (decode-content (append (list magnify (secref tag) " provides more information on ") @@ -111,16 +111,23 @@ (define (guidesecref s) (secref #:doc '(lib "scribblings/guide/guide.scrbl") s)) - + (define (guideintro tag . s) (apply margin-note (decode-content (append (list finger (guidesecref tag) " in " Guide " introduces ") s (list "."))))) - + (define Guide (other-manual '(lib "scribblings/guide/guide.scrbl"))) - + (define HonuManual - (other-manual '(lib "scribblings/honu/honu.scrbl")))) - + (other-manual '(lib "scribblings/honu/honu.scrbl"))) + + (provide speed) + (define-syntax speed + (syntax-rules () + [(_ id what) + (t "An" (scheme id) "application can provide better performance for" + (elem what) + "iteration when it appears directly in a" (scheme for) "clause.")]))) diff --git a/collects/scribblings/reference/sequences.scrbl b/collects/scribblings/reference/sequences.scrbl index 6117644025..6e05b9a45c 100644 --- a/collects/scribblings/reference/sequences.scrbl +++ b/collects/scribblings/reference/sequences.scrbl @@ -4,13 +4,6 @@ scribble/scheme (for-label scheme/generator)) -@(define-syntax speed - (syntax-rules () - [(_ id what) - @t{An @scheme[id] application can provide better performance for - @elem[what] - iteration when it appears directly in a @scheme[for] clause.}])) - @(define generator-eval (lambda () (let ([the-eval (make-base-eval)]) diff --git a/collects/typed-scheme/env/lexical-env.ss b/collects/typed-scheme/env/lexical-env.ss index 5e64695a2c..52b2659d89 100644 --- a/collects/typed-scheme/env/lexical-env.ss +++ b/collects/typed-scheme/env/lexical-env.ss @@ -1,7 +1,7 @@ #lang scheme/base -(require (except-in "../utils/utils.ss" extend)) -(require "type-environments.ss" +(require "../utils/utils.ss" + "type-environments.ss" "type-env.ss" unstable/mutated-vars (only-in scheme/contract ->* ->) diff --git a/collects/typed-scheme/env/type-alias-env.ss b/collects/typed-scheme/env/type-alias-env.ss index f8506de824..ece991cb3b 100644 --- a/collects/typed-scheme/env/type-alias-env.ss +++ b/collects/typed-scheme/env/type-alias-env.ss @@ -1,7 +1,7 @@ #lang scheme/base -(require (except-in "../utils/utils.ss" extend)) -(require syntax/boundmap +(require "../utils/utils.ss" + syntax/boundmap (utils tc-utils) mzlib/trace scheme/match) diff --git a/collects/typed-scheme/env/type-env.ss b/collects/typed-scheme/env/type-env.ss index 496c79208b..d454e0623a 100644 --- a/collects/typed-scheme/env/type-env.ss +++ b/collects/typed-scheme/env/type-env.ss @@ -1,7 +1,7 @@ #lang scheme/base -(require (except-in "../utils/utils.ss" extend)) -(require syntax/boundmap +(require "../utils/utils.ss" + syntax/boundmap (utils tc-utils) (types utils)) diff --git a/collects/typed-scheme/infer/constraint-structs.ss b/collects/typed-scheme/infer/constraint-structs.ss index 604c8caa53..a676a8fbd5 100644 --- a/collects/typed-scheme/infer/constraint-structs.ss +++ b/collects/typed-scheme/infer/constraint-structs.ss @@ -1,8 +1,6 @@ #lang scheme/base -(require (except-in "../utils/utils.ss" extend)) -(require (rep type-rep) - scheme/contract) +(require "../utils/utils.ss" (rep type-rep) scheme/contract) ;; S, T types ;; X a var @@ -31,9 +29,9 @@ ;; don't want to rule them out too early (define-struct cset (maps) #:prefab) -(provide/contract (struct c ([S Type?] [X symbol?] [T Type?])) - (struct dcon ([fixed (listof c?)] [rest (or/c c? false/c)])) - (struct dcon-exact ([fixed (listof c?)] [rest c?])) - (struct dcon-dotted ([type c?] [bound symbol?])) - (struct dmap ([map (hashof symbol? (or/c dcon? dcon-exact? dcon-dotted?))])) - (struct cset ([maps (listof (cons/c (hashof symbol? c?) dmap?))]))) +(p/c (struct c ([S Type?] [X symbol?] [T Type?])) + (struct dcon ([fixed (listof c?)] [rest (or/c c? false/c)])) + (struct dcon-exact ([fixed (listof c?)] [rest c?])) + (struct dcon-dotted ([type c?] [bound symbol?])) + (struct dmap ([map (hash/c symbol? (or/c dcon? dcon-exact? dcon-dotted?))])) + (struct cset ([maps (listof (cons/c (hash/c symbol? c?) dmap?))]))) diff --git a/collects/typed-scheme/infer/constraints.ss b/collects/typed-scheme/infer/constraints.ss index cacc1863b2..08534ef421 100644 --- a/collects/typed-scheme/infer/constraints.ss +++ b/collects/typed-scheme/infer/constraints.ss @@ -1,9 +1,10 @@ #lang scheme/unit -(require (except-in "../utils/utils.ss" extend)) -(require (types convenience utils union subtype) +(require "../utils/utils.ss" + (types convenience utils union subtype) (rep type-rep) (utils tc-utils) + unstable/sequence "signatures.ss" "constraint-structs.ss" scheme/match) diff --git a/collects/typed-scheme/infer/dmap.ss b/collects/typed-scheme/infer/dmap.ss index 92747bf43d..412482e336 100644 --- a/collects/typed-scheme/infer/dmap.ss +++ b/collects/typed-scheme/infer/dmap.ss @@ -1,8 +1,9 @@ #lang scheme/unit -(require (except-in "../utils/utils.ss" extend)) -(require "signatures.ss" "constraint-structs.ss" +(require "../utils/utils.ss" + "signatures.ss" "constraint-structs.ss" (utils tc-utils) + unstable/sequence scheme/match) (import constraints^) @@ -35,7 +36,7 @@ (fail! fixed1 fixed2)) (make-dcon (for/list ([c1 fixed1] - [c2 (in-list-forever fixed2 rest)]) + [c2 (in-sequence-forever fixed2 rest)]) (c-meet c1 c2 (c-X c1))) #f)] [((struct dcon (fixed1 rest)) (struct dcon (fixed2 #f))) @@ -47,7 +48,7 @@ (values fixed2 fixed1 rest2 rest1))]) (make-dcon (for/list ([c1 longer] - [c2 (in-list-forever shorter srest)]) + [c2 (in-sequence-forever shorter srest)]) (c-meet c1 c2 (c-X c1))) (c-meet lrest srest (c-X lrest))))] [((struct dcon-dotted (c1 bound1)) (struct dcon-dotted (c2 bound2))) diff --git a/collects/typed-scheme/infer/infer-unit.ss b/collects/typed-scheme/infer/infer-unit.ss index 893f59cde4..eb2ce09350 100644 --- a/collects/typed-scheme/infer/infer-unit.ss +++ b/collects/typed-scheme/infer/infer-unit.ss @@ -1,7 +1,7 @@ #lang scheme/unit -(require (except-in "../utils/utils.ss")) -(require (rep free-variance type-rep filter-rep rep-utils) +(require "../utils/utils.ss" + (rep free-variance type-rep filter-rep rep-utils) (types convenience union subtype remove-intersect resolve) (except-in (utils tc-utils) make-env) (env type-name-env) @@ -12,6 +12,7 @@ scheme/match mzlib/etc mzlib/trace + unstable/sequence unstable/list scheme/list) (import dmap^ constraints^ promote-demote^) diff --git a/collects/typed-scheme/private/parse-type.ss b/collects/typed-scheme/private/parse-type.ss index aa6fbe1f05..613c5a5768 100644 --- a/collects/typed-scheme/private/parse-type.ss +++ b/collects/typed-scheme/private/parse-type.ss @@ -1,7 +1,7 @@ #lang scheme/base -(require (except-in "../utils/utils.ss" extend)) -(require (except-in (rep type-rep) make-arr) +(require "../utils/utils.ss" + (except-in (rep type-rep) make-arr) (rename-in (types convenience union utils) [make-arr* make-arr]) (utils tc-utils stxclass-util) syntax/stx (prefix-in c: scheme/contract) diff --git a/collects/typed-scheme/private/prims.ss b/collects/typed-scheme/private/prims.ss index ce6d0c34b5..190c832a1d 100644 --- a/collects/typed-scheme/private/prims.ss +++ b/collects/typed-scheme/private/prims.ss @@ -24,8 +24,8 @@ This file defines two sorts of primitives. All of them are provided into any mod (rename-out [define-typed-struct define-struct:] [define-typed-struct/exec define-struct/exec:])) -(require (except-in "../utils/utils.ss" extend)) -(require (for-syntax +(require "../utils/utils.ss" + (for-syntax syntax/parse syntax/private/util scheme/base diff --git a/collects/typed-scheme/private/type-annotation.ss b/collects/typed-scheme/private/type-annotation.ss index 17cb1a37f4..0564ca5ba6 100644 --- a/collects/typed-scheme/private/type-annotation.ss +++ b/collects/typed-scheme/private/type-annotation.ss @@ -1,7 +1,7 @@ #lang scheme/base -(require (except-in "../utils/utils.ss" extend)) -(require (rep type-rep) +(require "../utils/utils.ss" + (rep type-rep) (utils tc-utils) (env type-env) (except-in (types subtype union convenience resolve utils) -> ->*) diff --git a/collects/typed-scheme/private/type-contract.ss b/collects/typed-scheme/private/type-contract.ss index 07a5d1cbcc..0d8806c7e8 100644 --- a/collects/typed-scheme/private/type-contract.ss +++ b/collects/typed-scheme/private/type-contract.ss @@ -2,8 +2,8 @@ (provide type->contract define/fixup-contract? generate-contract-def change-contract-fixups) -(require (except-in "../utils/utils.ss" extend)) (require + "../utils/utils.ss" (rep type-rep filter-rep object-rep) (typecheck internal-forms) (utils tc-utils require-contract) @@ -11,11 +11,7 @@ (types resolve utils) (prefix-in t: (types convenience)) (private parse-type) - scheme/match - syntax/struct - syntax/stx - mzlib/trace - scheme/list + scheme/match syntax/struct syntax/stx mzlib/trace unstable/syntax scheme/list (only-in scheme/contract -> ->* case-> cons/c flat-rec-contract provide/contract any/c) (for-template scheme/base scheme/contract unstable/poly-c (only-in scheme/class object% is-a?/c subclass?/c))) @@ -111,8 +107,8 @@ [else (int-err "unknown var: ~a" v)])] [(Poly: vs (and b (Function: _))) (match-let ([(Poly-names: vs-nm _) ty]) - (with-syntax ([(vs+ ...) (generate-temporaries (for/list ([v vs-nm]) (symbol-append v '+)))] - [(vs- ...) (generate-temporaries (for/list ([v vs-nm]) (symbol-append v '-)))]) + (with-syntax ([(vs+ ...) (generate-temporaries (for/list ([v vs-nm]) (format-symbol "~a+" v)))] + [(vs- ...) (generate-temporaries (for/list ([v vs-nm]) (format-symbol "~a-" v)))]) (parameterize ([vars (append (map list vs (syntax->list #'(vs+ ...)) diff --git a/collects/typed-scheme/rep/rep-utils.ss b/collects/typed-scheme/rep/rep-utils.ss index f576dc1d61..115c8e86fb 100644 --- a/collects/typed-scheme/rep/rep-utils.ss +++ b/collects/typed-scheme/rep/rep-utils.ss @@ -6,6 +6,7 @@ syntax/boundmap "free-variance.ss" "interning.ss" + unstable/syntax mzlib/etc scheme/contract (for-syntax @@ -17,6 +18,7 @@ syntax/struct syntax/stx scheme/contract + unstable/syntax (rename-in (except-in (utils utils stxclass-util) bytes byte-regexp regexp byte-pregexp #;pregexp) [id* id] [keyword* keyword]))) @@ -75,13 +77,13 @@ (~optional [#:contract cnt:expr]) (~optional no-provide?:no-provide-kw)) ...) (with-syntax* - ([ex (mk-id #'nm #'nm ":")] - [fold-name (mk-id #f #'nm "-fold")] + ([ex (format-id #'nm "~a:" #'nm)] + [fold-name (format-id #f "~a-fold" #'nm)] [kw-stx (string->keyword (symbol->string (attribute nm.datum)))] [parent par] [(s:ty maker pred acc ...) (build-struct-names #'nm (syntax->list #'flds.fs) #f #t #'nm)] - [*maker (mk-id #'nm "*" #'nm)] - [**maker (mk-id #'nm "**" #'nm)] + [*maker (format-id #'nm "*~a" #'nm)] + [**maker (format-id #'nm "**~a" #'nm)] [*maker-cnt (if enable-contracts? (or (attribute cnt) #'(flds.cnt ... . -> . pred)) #'any/c)] @@ -251,12 +253,12 @@ #:with name #'i #:with keyword (datum->syntax #f (string->keyword (symbol->string (syntax-e #'i)))) #:with tmp-rec-id (generate-temporary) - #:with case (mk-id #'i (attribute lower-s) "-case") - #:with printer (mk-id #'i "print-" (attribute lower-s) "*") - #:with ht (mk-id #'i (attribute lower-s) "-name-ht") - #:with rec-id (mk-id #'i (attribute lower-s) "-rec-id") - #:with d-id (mk-id #'i "d" (attribute first-letter)) - #:with (_ _ pred? accs ...) + #:with case (format-id #'i "~a-case" (attribute lower-s)) + #:with printer (format-id #'i "print-~a*" (attribute lower-s)) + #:with ht (format-id #'i "~a-name-ht" (attribute lower-s)) + #:with rec-id (format-id #'i "~a-rec-id" (attribute lower-s)) + #:with d-id (format-id #'i "d~a" (attribute first-letter)) + #:with (_ _ pred? accs ...) (datum->syntax #f (build-struct-names #'name (syntax->list #'(fld-names ...)) #f #t #'name)))) (syntax-parse stx [(_ i:type-name ...) diff --git a/collects/typed-scheme/typecheck/check-subforms-unit.ss b/collects/typed-scheme/typecheck/check-subforms-unit.ss index f31aa592f0..ea97a7f1fd 100644 --- a/collects/typed-scheme/typecheck/check-subforms-unit.ss +++ b/collects/typed-scheme/typecheck/check-subforms-unit.ss @@ -1,7 +1,7 @@ #lang scheme/unit -(require (except-in "../utils/utils.ss" extend)) -(require syntax/kerncase +(require "../utils/utils.ss" + syntax/kerncase scheme/match "signatures.ss" "tc-metafunctions.ss" (types utils convenience union subtype) diff --git a/collects/typed-scheme/typecheck/provide-handling.ss b/collects/typed-scheme/typecheck/provide-handling.ss index 72329df85a..5fb645cabd 100644 --- a/collects/typed-scheme/typecheck/provide-handling.ss +++ b/collects/typed-scheme/typecheck/provide-handling.ss @@ -1,7 +1,7 @@ #lang scheme/base -(require (except-in "../utils/utils.ss" extend)) -(require (only-in srfi/1/list s:member) +(require "../utils/utils.ss" + (only-in srfi/1/list s:member) syntax/kerncase syntax/boundmap (env type-name-env type-alias-env) mzlib/trace diff --git a/collects/typed-scheme/typecheck/tc-app.ss b/collects/typed-scheme/typecheck/tc-app.ss index c87ca28668..4c21412390 100644 --- a/collects/typed-scheme/typecheck/tc-app.ss +++ b/collects/typed-scheme/typecheck/tc-app.ss @@ -4,6 +4,7 @@ "signatures.ss" "tc-metafunctions.ss" "tc-app-helper.ss" "find-annotation.ss" syntax/parse scheme/match mzlib/trace scheme/list + unstable/sequence ;; fixme - don't need to be bound in this phase - only to make syntax/parse happy scheme/bool (only-in scheme/private/class-internal make-object do-make-object) @@ -677,7 +678,7 @@ [(and rest (< (length t-a) (length dom))) (tc-error/expr #:return (ret t-r) "Wrong number of arguments, expected at least ~a and got ~a" (length dom) (length t-a))]) - (for ([dom-t (if rest (in-list-forever dom rest) (in-list dom))] [a (syntax->list args-stx)] [arg-t (in-list t-a)]) + (for ([dom-t (if rest (in-sequence-forever dom rest) (in-list dom))] [a (syntax->list args-stx)] [arg-t (in-list t-a)]) (parameterize ([current-orig-stx a]) (check-below arg-t dom-t)))) (let* (;; Listof[Listof[LFilterSet]] [lfs-f (for/list ([lf lf-r]) diff --git a/collects/typed-scheme/typecheck/tc-dots-unit.ss b/collects/typed-scheme/typecheck/tc-dots-unit.ss index ddffd4d724..e9a6d9d251 100644 --- a/collects/typed-scheme/typecheck/tc-dots-unit.ss +++ b/collects/typed-scheme/typecheck/tc-dots-unit.ss @@ -1,7 +1,7 @@ #lang scheme/unit -(require (except-in "../utils/utils.ss" extend)) -(require "signatures.ss" +(require "../utils/utils.ss" + "signatures.ss" (utils tc-utils) (env type-environments) (types utils) diff --git a/collects/typed-scheme/typecheck/tc-if.ss b/collects/typed-scheme/typecheck/tc-if.ss index 5e03751843..94f6aabe0c 100644 --- a/collects/typed-scheme/typecheck/tc-if.ss +++ b/collects/typed-scheme/typecheck/tc-if.ss @@ -1,7 +1,7 @@ #lang scheme/unit -(require (rename-in "../utils/utils.ss" [infer r:infer] [extend r:extend])) +(require (rename-in "../utils/utils.ss" [infer r:infer])) (require "signatures.ss" (rep type-rep filter-rep object-rep) (rename-in (types convenience subtype union utils comparison remove-intersect) diff --git a/collects/typed-scheme/typecheck/tc-lambda-unit.ss b/collects/typed-scheme/typecheck/tc-lambda-unit.ss index cba789f5dc..bb1d173c40 100644 --- a/collects/typed-scheme/typecheck/tc-lambda-unit.ss +++ b/collects/typed-scheme/typecheck/tc-lambda-unit.ss @@ -1,6 +1,6 @@ #lang scheme/unit -(require (rename-in "../utils/utils.ss" [infer r:infer] [extend r:extend]) +(require (rename-in "../utils/utils.ss" [infer r:infer]) "signatures.ss" "tc-metafunctions.ss" mzlib/trace diff --git a/collects/typed-scheme/typecheck/tc-structs.ss b/collects/typed-scheme/typecheck/tc-structs.ss index d1d37b38d8..5f313573df 100644 --- a/collects/typed-scheme/typecheck/tc-structs.ss +++ b/collects/typed-scheme/typecheck/tc-structs.ss @@ -1,7 +1,7 @@ #lang scheme/base -(require (except-in "../utils/utils.ss" extend)) -(require (rep type-rep) +(require "../utils/utils.ss" + (rep type-rep) (private parse-type) (types convenience utils union resolve abbrev) (env type-env type-environments type-name-env) diff --git a/collects/typed-scheme/typecheck/tc-toplevel.ss b/collects/typed-scheme/typecheck/tc-toplevel.ss index 793eefb8e1..86023b30eb 100644 --- a/collects/typed-scheme/typecheck/tc-toplevel.ss +++ b/collects/typed-scheme/typecheck/tc-toplevel.ss @@ -3,6 +3,7 @@ (require (rename-in "../utils/utils.ss" [infer r:infer])) (require syntax/kerncase + unstable/list mzlib/etc scheme/match "signatures.ss" diff --git a/collects/typed-scheme/typed-scheme.ss b/collects/typed-scheme/typed-scheme.ss index e17d5281ed..fd719d3e0d 100644 --- a/collects/typed-scheme/typed-scheme.ss +++ b/collects/typed-scheme/typed-scheme.ss @@ -13,7 +13,7 @@ (r:infer infer) (utils tc-utils) (rep type-rep) - (except-in (utils utils) infer extend) + (except-in (utils utils) infer) (only-in (r:infer infer-dummy) infer-param) scheme/nest syntax/kerncase @@ -36,11 +36,7 @@ (define-syntax (module-begin stx) (define module-name (syntax-property stx 'enclosing-module-name)) ;(printf "BEGIN: ~a~n" (syntax->datum stx)) - (with-logging-to-file - (build-path (find-system-path 'temp-dir) "ts-poly.log") - #; - (log-file-name (syntax-source stx) module-name) - (syntax-case stx () + (syntax-case stx () [(mb forms ...) (nest ([begin (set-box! typed-context? #t) @@ -90,7 +86,7 @@ #;(printf "tried to create ~a types~n" (all-count!)) #;(printf "created ~a union types~n" (union-count!)) ;; reconstruct the module with the extra code - #'(#%module-begin transformed-body ... after-code check-syntax-help))]))) + #'(#%module-begin transformed-body ... after-code check-syntax-help))])) (define-syntax (top-interaction stx) (syntax-case stx () diff --git a/collects/typed-scheme/types/remove-intersect.ss b/collects/typed-scheme/types/remove-intersect.ss index 02c77acb93..1dce9f4dad 100644 --- a/collects/typed-scheme/types/remove-intersect.ss +++ b/collects/typed-scheme/types/remove-intersect.ss @@ -1,7 +1,7 @@ #lang scheme/base -(require (except-in "../utils/utils.ss" extend)) -(require (rep type-rep rep-utils) +(require "../utils/utils.ss" + (rep type-rep rep-utils) (types union subtype resolve convenience utils) scheme/match mzlib/trace) diff --git a/collects/typed-scheme/utils/utils.ss b/collects/typed-scheme/utils/utils.ss index 40564564dc..d2a2491481 100644 --- a/collects/typed-scheme/utils/utils.ss +++ b/collects/typed-scheme/utils/utils.ss @@ -8,24 +8,23 @@ at least theoretically. (require (for-syntax scheme/base syntax/parse scheme/string) scheme/contract mzlib/plt-match scheme/require-syntax scheme/provide-syntax mzlib/struct scheme/unit - (except-in syntax/parse id)) + scheme/pretty mzlib/pconvert + (except-in syntax/parse id)) -(provide with-syntax* syntax-map start-timing do-time reverse-begin printf/log - with-logging-to-file log-file-name == - define-struct/printer - (rename-out [id mk-id]) - filter-multiple - hash-union - in-pairs - in-list-forever - extend - debug - in-syntax - symbol-append - custom-printer - rep utils typecheck infer env private - hashof) +;; to move to unstable +(provide == hash-union debug reverse-begin) +(provide + ;; timing + start-timing do-time + ;; logging + printf/log + ;; struct printing + custom-printer define-struct/printer + ;; provide macros + rep utils typecheck infer env private) + +;; fancy require syntax (define-syntax (define-requirer stx) (syntax-parse stx [(_ nm:id nm-out:id) @@ -81,13 +80,7 @@ at least theoretically. (define-requirer private private-out) (define-requirer types types-out) -(define-sequence-syntax in-syntax - (lambda () #'syntax->list) - (lambda (stx) - (syntax-case stx () - [[ids (_ arg)] - #'[ids (in-list (syntax->list arg))]]))) - +;; printf debugging convenience (define-syntax debug (syntax-rules () [(_ (f . args)) @@ -106,58 +99,23 @@ at least theoretically. (printf "result was ~a~n" e) e))])) -(define-syntax (with-syntax* stx) - (syntax-case stx () - [(_ (cl) body ...) #'(with-syntax (cl) body ...)] - [(_ (cl cls ...) body ...) - #'(with-syntax (cl) (with-syntax* (cls ...) body ...))] - )) +;; run `h' last, but drop its return value +(define-syntax-rule (reverse-begin h . forms) (begin0 (begin . forms) h)) -(define (filter-multiple l . fs) - (apply values - (map (lambda (f) (filter f l)) fs))) - -(define (syntax-map f stxl) - (map f (syntax->list stxl))) - -(define-syntax reverse-begin - (syntax-rules () [(_ h . forms) (begin0 (begin . forms) h)])) - -#; -(define-syntax define-simple-syntax - (syntax-rules () - [(dss (n . pattern) template) - (define-syntax n (syntax-rules () [(n . pattern) template]))])) - -(define log-file (make-parameter #f)) +;; conditionalized logging +;; there's some logging code in the source +;; which was used for gathering statistics about various programs +;; no longer used, probably bitrotted (define-for-syntax logging? #f) -(require (only-in mzlib/file file-name-from-path)) - (define-syntax (printf/log stx) (if logging? (syntax-case stx () [(_ fmt . args) - #'(when (log-file) - (fprintf (log-file) (string-append "~a: " fmt) - (file-name-from-path (object-name (log-file))) - . args))]) + #'(log-debug (format fmt . args))]) #'(void))) -(define (log-file-name src module-name) - (if (path? src) - (path-replace-suffix src ".log") - (format "~a.log" module-name))) - -(define-syntax (with-logging-to-file stx) - (syntax-case stx () - [(_ file . body) - (if logging? - #'(parameterize ([log-file (open-output-file file #:exists 'append)]) - . body) - #'(begin . body))])) - - +;; some macros to do some timing, only when `timing?' is #t (define-for-syntax timing? #f) (define last-time (make-parameter #f)) @@ -184,9 +142,6 @@ at least theoretically. (values (lambda _ #'(void)) (lambda _ #'(void))))) -(define (symbol-append . args) - (string->symbol (apply string-append (map symbol->string args)))) - (define-match-expander == (lambda (stx) @@ -194,6 +149,11 @@ at least theoretically. [(_ val) #'(? (lambda (x) (equal? val x)))]))) +;; custom printing +;; this requires lots of work for two reasons: +;; - 1 printers have to be defined at the same time as the structs +;; - 2 we want to support things printing corectly even when the custom printer is off + (define-for-syntax printing? #t) (define-syntax-rule (defprinter t ...) @@ -217,8 +177,6 @@ at least theoretically. (define custom-printer (make-parameter #t)) -(require scheme/pretty mzlib/pconvert) - (define-syntax (define-struct/printer stx) (syntax-case stx () [(form name (flds ...) printer) @@ -228,16 +186,6 @@ at least theoretically. #'([prop:custom-write pseudo-printer])) #f)])) -(define (id kw . args) - (define (f v) - (cond [(string? v) v] - [(symbol? v) (symbol->string v)] - [(char? v) (string v)] - [(identifier? v) (symbol->string (syntax-e v))] - [else (error "not coerceable:" v)])) - (datum->syntax kw (string->symbol (apply string-append (map f args))))) - - ;; map map (key val val -> val) -> map (define (hash-union h1 h2 f) (for/fold ([h* h1]) @@ -249,36 +197,12 @@ at least theoretically. (hash-set h* k new-val)))) -(define (in-pairs seq) - (make-do-sequence - (lambda () - (let-values ([(more? gen) (sequence-generate seq)]) - (values (lambda (e) (let ([e (gen)]) (values (car e) (cdr e)))) - (lambda (_) #t) - #t - (lambda (_) (more?)) - (lambda _ #t) - (lambda _ #t)))))) - -(define (in-list-forever seq val) - (make-do-sequence - (lambda () - (let-values ([(more? gen) (sequence-generate seq)]) - (values (lambda (e) (let ([e (if (more?) (gen) val)]) e)) - (lambda (_) #t) - #t - (lambda (_) #t) - (lambda _ #t) - (lambda _ #t)))))) - -;; Listof[A] Listof[B] B -> Listof[B] -;; pads out t to be as long as s -(define (extend s t extra) - (append t (build-list (- (length s) (length t)) (lambda _ extra)))) +;; turn contracts on and off - off by default for performance. (define-for-syntax enable-contracts? #f) (provide (for-syntax enable-contracts?) p/c w/c cnt d-s/c d/c) +;; these are versions of the contract forms conditionalized by `enable-contracts?' (define-syntax p/c (if enable-contracts? (make-rename-transformer #'provide/contract) @@ -286,7 +210,10 @@ at least theoretically. (define-syntax-class clause #:literals () #:attributes (i) - (pattern [rename out:id in:id cnt:expr] + (pattern [struct nm:id (flds ...)] + #:fail-unless (eq? (syntax-e #'struct) 'struct) #f + #:with i #'(struct-out nm)) + (pattern [rename out:id in:id cnt:expr] #:fail-unless (eq? (syntax-e #'rename) 'rename) #f #:with i #'(rename-out [out in])) (pattern [i:id cnt:expr])) @@ -323,15 +250,3 @@ at least theoretically. (if enable-contracts? (list #'[contracted (nm cnt)]) (list #'nm))])) - - -(define (hashof k/c v/c) - (flat-named-contract - (format "#" k/c v/c) - (lambda (h) - (define k/c? (if (flat-contract? k/c) (flat-contract-predicate k/c) k/c)) - (define v/c? (if (flat-contract? v/c) (flat-contract-predicate v/c) v/c)) - (and (hash? h) - (for/and ([(k v) h]) - (and (k/c? k) - (v/c? v))))))) diff --git a/collects/unstable/list.ss b/collects/unstable/list.ss index 1ecf6aab41..697f100c98 100644 --- a/collects/unstable/list.ss +++ b/collects/unstable/list.ss @@ -28,3 +28,14 @@ (provide/contract [list-prefix? (list? list? . -> . boolean?)]) + +(define (filter-multiple l . fs) + (apply values + (map (lambda (f) (filter f l)) fs))) + +;; Listof[A] Listof[B] B -> Listof[B] +;; pads out t to be as long as s +(define (extend s t extra) + (append t (build-list (- (length s) (length t)) (lambda _ extra)))) + +(provide filter-multiple extend) \ No newline at end of file diff --git a/collects/unstable/scribblings/list.scrbl b/collects/unstable/scribblings/list.scrbl index ed7e3d16e0..ac5f7bf9ed 100644 --- a/collects/unstable/scribblings/list.scrbl +++ b/collects/unstable/scribblings/list.scrbl @@ -1,9 +1,14 @@ #lang scribble/doc @(require scribble/base scribble/manual - (for-label unstable/list - scheme/contract - scheme/base)) + scribble/eval + "utils.ss" + (for-label unstable/list + scheme/contract + scheme/base)) + +@(define the-eval (make-base-eval)) +@(the-eval '(require unstable/list)) @title[#:tag "list"]{Lists} @@ -13,4 +18,26 @@ [r list?]) boolean?]{ True if @scheme[l] is a prefix of @scheme[r]. +@examples[#:eval the-eval +(list-prefix? '(1 2) '(1 2 3 4 5)) +] } + +@addition{Sam Tobin-Hochstadt} + +@defproc[(filter-multiple [l list?] [f procedure?] ...) (values list? ...)]{ +Produces @scheme[(values (filter f l) ...)]. + +@examples[#:eval the-eval +(filter-multiple (list 1 2 3 4 5) even? odd?) +] +} + +@defproc[(extend [l1 list?] [l2 list?] [v any/c]) list?]{ +Extends @scheme[l2] to be as long as @scheme[l1] by adding @scheme[(- +(length l1) (length l2))] copies of @scheme[v] to the end of +@scheme[l2]. + +@examples[#:eval the-eval] +(extend '(1 2 3) '(a) 'b) +} \ No newline at end of file diff --git a/collects/unstable/scribblings/sequence.scrbl b/collects/unstable/scribblings/sequence.scrbl new file mode 100644 index 0000000000..9c9057ee3c --- /dev/null +++ b/collects/unstable/scribblings/sequence.scrbl @@ -0,0 +1,40 @@ +#lang scribble/doc +@(require scribble/base + scribble/manual + scribble/eval + scribblings/reference/mz + "utils.ss" + (for-label unstable/sequence + scheme/contract + scheme/base)) + +@(define the-eval (make-base-eval)) +@(the-eval '(require unstable/sequence)) + +@title[#:tag "sequence"]{Sequences} + +@defmodule[unstable/sequence] + +@unstable[@author+email["Sam Tobin-Hochstadt" "samth@ccs.neu.edu"]] + + +@defproc[(in-syntax [stx syntax?]) sequence?]{ +Produces a sequence equivalent to @scheme[(syntax->list lst)]. +@speed[in-syntax "syntax"] + +@examples[#:eval the-eval +(for/list ([x (in-syntax #'(1 2 3))]) + x)]} + +@defproc[(in-pairs [seq sequence?]) sequence?]{ +Produces a sequence equivalent to + @scheme[(in-parallel (lift car seq) (lift cdr seq))]. +} + +@defproc[(in-sequence-forever [seq sequence?] [val any/c]) sequence?]{ +Produces a sequence whose values are the elements of @scheme[seq], followed by @scheme[val] repeated. +} + +@defproc[(sequence-lift [f procedure?] [seq sequence?]) sequence?]{ +Produces the sequence of @scheme[f] applied to each element of @scheme[seq]. +} \ No newline at end of file diff --git a/collects/unstable/scribblings/syntax.scrbl b/collects/unstable/scribblings/syntax.scrbl index 226f74f756..7ef0fdc571 100644 --- a/collects/unstable/scribblings/syntax.scrbl +++ b/collects/unstable/scribblings/syntax.scrbl @@ -2,6 +2,7 @@ @(require scribble/struct scribble/decode scribble/eval + "utils.ss" (for-label scheme/base scheme/contract unstable/syntax)) @@ -183,7 +184,7 @@ or similar, has no effect. @;{----} @defproc[(format-symbol [fmt string?] - [v (or/c string? symbol? identifier? keyword? number?)] ...) + [v (or/c string? symbol? identifier? keyword? char? number?)] ...) symbol?]{ Like @scheme[format], but produces a symbol. The format string must @@ -200,7 +201,7 @@ are automatically converted to symbols. [#:props props (or/c syntax? #f) #f] [#:cert cert (or/c syntax? #f) #f] [fmt string?] - [v (or/c string? symbol? identifier? keyword? number?)] ...) + [v (or/c string? symbol? identifier? keyword? char? number?)] ...) identifier?]{ Like @scheme[format-symbol], but converts the symbol into an @@ -230,3 +231,25 @@ in the argument list are automatically converted to symbols. (Scribble doesn't show it, but the DrScheme pinpoints the location of the second error but not of the first.) } + +@addition{Sam Tobin-Hochstadt} + +@defform[(with-syntax* ([pattern stx-expr] ...) + body ...+)]{ +Similar to @scheme[with-syntax], but the pattern variables are bound in the remaining +@scheme[stx-expr]s as well as the @scheme[body]s, and the @scheme[pattern]s need not +bind distinct pattern variables; later bindings shadow earlier bindings. + +@examples[#:eval the-eval +(with-syntax* ([(x y) (list #'val1 #'val2)] + [nest #'((x) (y))]) + #'nest) +] +} + +@defproc[(syntax-map [f (-> syntax? A)] [stxl syntax?] ...) (listof A)]{ +Performs @scheme[(map f (syntax->list stxl) ...)]. + +@examples[#:eval the-eval +(syntax-map syntax-e #'(a b c))] +} \ No newline at end of file diff --git a/collects/unstable/scribblings/unstable.scrbl b/collects/unstable/scribblings/unstable.scrbl index 3dde2e3c66..d92d2ff1ac 100644 --- a/collects/unstable/scribblings/unstable.scrbl +++ b/collects/unstable/scribblings/unstable.scrbl @@ -84,6 +84,7 @@ Keep documentation and tests up to date. @include-section["mutated-vars.scrbl"] @include-section["find.scrbl"] @include-section["class-iop.scrbl"] +@include-section["sequence.scrbl"] @;{--------} diff --git a/collects/unstable/scribblings/utils.ss b/collects/unstable/scribblings/utils.ss new file mode 100644 index 0000000000..633dee902c --- /dev/null +++ b/collects/unstable/scribblings/utils.ss @@ -0,0 +1,15 @@ +#lang at-exp scheme/base + +(require scribble/base scribble/manual) + +(provide unstable addition) +(define (unstable . authors) + (begin + (apply author authors) + @para{This library is @emph{unstable}; compatibility will not be maintained. + See @secref{unstable} for more information.})) + +(define (addition name) + @margin-note{The subsequent bindings were added by @|name|.}) + + diff --git a/collects/unstable/sequence.ss b/collects/unstable/sequence.ss new file mode 100644 index 0000000000..7b58201904 --- /dev/null +++ b/collects/unstable/sequence.ss @@ -0,0 +1,45 @@ +#lang scheme/base + +(require (for-syntax scheme/base)) + +(provide in-syntax in-pairs in-sequence-forever sequence-lift) + +(define-sequence-syntax in-syntax + (lambda () #'(lambda (e) (in-list (syntax->list e)))) + (lambda (stx) + (syntax-case stx () + [[ids (_ arg)] + #'[ids (in-list (syntax->list arg))]]))) + +(define (in-pairs seq) + (make-do-sequence + (lambda () + (let-values ([(more? gen) (sequence-generate seq)]) + (values (lambda (e) (let ([e (gen)]) (values (car e) (cdr e)))) + (lambda (_) #t) + #t + (lambda (_) (more?)) + (lambda _ #t) + (lambda _ #t)))))) + +(define (in-sequence-forever seq val) + (make-do-sequence + (lambda () + (let-values ([(more? gen) (sequence-generate seq)]) + (values (lambda (e) (let ([e (if (more?) (gen) val)]) e)) + (lambda (_) #t) + #t + (lambda (_) #t) + (lambda _ #t) + (lambda _ #t)))))) + +(define (sequence-lift f seq) + (make-do-sequence + (lambda () + (let-values ([(more? gen) (sequence-generate seq)]) + (values (lambda (e) (compose f gen)) + (lambda (_) #t) + #t + (lambda (_) (more?)) + (lambda _ #t) + (lambda _ #t)))))) diff --git a/collects/unstable/syntax.ss b/collects/unstable/syntax.ss index 001b24168b..e4f5e4fb6d 100644 --- a/collects/unstable/syntax.ss +++ b/collects/unstable/syntax.ss @@ -24,7 +24,10 @@ format-id current-syntax-context - wrong-syntax) + wrong-syntax + + with-syntax* + syntax-map) ;; Unwrapping syntax @@ -158,8 +161,9 @@ [(identifier? x) (syntax-e x)] [(keyword? x) (keyword->string x)] [(number? x) x] + [(char? x) x] [else (raise-type-error err - "string, symbol, identifier, keyword, or number" + "string, symbol, identifier, keyword, character, or number" x)])) ;; Error reporting @@ -177,3 +181,12 @@ stx extras))) ;; Eli: The `report-error-as' thing seems arbitrary to me. + +(define-syntax (with-syntax* stx) + (syntax-case stx () + [(_ (cl) body ...) #'(with-syntax (cl) body ...)] + [(_ (cl cls ...) body ...) + #'(with-syntax (cl) (with-syntax* (cls ...) body ...))])) + +(define (syntax-map f . stxls) + (apply map f (map syntax->list stxls))) \ No newline at end of file