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

Move a bunch of functions from typed-scheme/utils/utils to unstable.

Browse Source 
Add convenience lib for unstable docs.
Add char support to format-{id,symbol}
Add unstable/sequence library.

svn: r16789
This commit is contained in:
Sam Tobin-Hochstadt 2009-11-15 22:15:29 +00:00
parent 960bf4caab
commit fb29a2498e
35 changed files with 310 additions and 221 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
collects/scheme/match/match-expander.ss
View File

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

2
collects/scribblings/reference/contracts.scrbl
View File

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

9
collects/scribblings/reference/mz.ss
View File

@ -122,5 +122,12 @@
(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.")])))

7
collects/scribblings/reference/sequences.scrbl
View File

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

4
collects/typed-scheme/env/lexical-env.ss vendored
View File

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

4
collects/typed-scheme/env/type-alias-env.ss vendored
View File

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

4
collects/typed-scheme/env/type-env.ss vendored
View File

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

10
collects/typed-scheme/infer/constraint-structs.ss
View File

@ -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?]))
(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 (hashof symbol? (or/c dcon? dcon-exact? dcon-dotted?))]))
(struct cset ([maps (listof (cons/c (hashof symbol? c?) dmap?))])))
(struct dmap ([map (hash/c symbol? (or/c dcon? dcon-exact? dcon-dotted?))]))
(struct cset ([maps (listof (cons/c (hash/c symbol? c?) dmap?))])))

5
collects/typed-scheme/infer/constraints.ss
View File

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

9
collects/typed-scheme/infer/dmap.ss
View File

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

5
collects/typed-scheme/infer/infer-unit.ss
View File

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

4
collects/typed-scheme/private/parse-type.ss
View File

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

4
collects/typed-scheme/private/prims.ss
View File

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

4
collects/typed-scheme/private/type-annotation.ss
View File

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

12
collects/typed-scheme/private/type-contract.ss
View File

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

20
collects/typed-scheme/rep/rep-utils.ss
View File

@ -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,11 +253,11 @@
#: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 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

4
collects/typed-scheme/typecheck/check-subforms-unit.ss
View File

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

4
collects/typed-scheme/typecheck/provide-handling.ss
View File

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

3
collects/typed-scheme/typecheck/tc-app.ss
View File

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

4
collects/typed-scheme/typecheck/tc-dots-unit.ss
View File

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

2
collects/typed-scheme/typecheck/tc-if.ss
View File

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

2
collects/typed-scheme/typecheck/tc-lambda-unit.ss
View File

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

4
collects/typed-scheme/typecheck/tc-structs.ss
View File

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

1
collects/typed-scheme/typecheck/tc-toplevel.ss
View File

@ -3,6 +3,7 @@
(require (rename-in "../utils/utils.ss" [infer r:infer]))
(require syntax/kerncase
unstable/list
mzlib/etc
scheme/match
"signatures.ss"

8
collects/typed-scheme/typed-scheme.ss
View File

@ -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,10 +36,6 @@
(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 ()
[(mb forms ...)
(nest
@ -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 ()

4
collects/typed-scheme/types/remove-intersect.ss
View File

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

151
collects/typed-scheme/utils/utils.ss
View File

@ -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
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,6 +210,9 @@ at least theoretically.
(define-syntax-class clause
#:literals ()
#:attributes (i)
(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]))
@ -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 "#<hashof ~a ~a>" 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)))))))

11
collects/unstable/list.ss
View File

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

27
collects/unstable/scribblings/list.scrbl
View File

@ -1,10 +1,15 @@
#lang scribble/doc
@(require scribble/base
scribble/manual
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}
@defmodule[unstable/list]
@ -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)
}

40
collects/unstable/scribblings/sequence.scrbl Normal file
View File

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

27
collects/unstable/scribblings/syntax.scrbl
View File

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

1
collects/unstable/scribblings/unstable.scrbl
View File

@ -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"]
@;{--------}

15
collects/unstable/scribblings/utils.ss Normal file
View File

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

45
collects/unstable/sequence.ss Normal file
View File

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

17
collects/unstable/syntax.ss
View File

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