some reformatting
svn: r16472
This commit is contained in:
Eli Barzilay
parent
87a5092c82
commit
52ac79406b
|
|
@ -1,5 +1,5 @@
|
|||
(module for '#%kernel
|
||||
|
||||
|
||||
(#%require "more-scheme.ss"
|
||||
"misc.ss"
|
||||
"define.ss"
|
||||
|
|
@ -52,14 +52,14 @@
|
|||
sequence?
|
||||
sequence-generate
|
||||
prop:sequence
|
||||
|
||||
|
||||
define-sequence-syntax
|
||||
make-do-sequence
|
||||
:do-in)
|
||||
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; sequence transformers:
|
||||
|
||||
|
||||
(begin-for-syntax
|
||||
(define-values (struct:sequence-transformer
|
||||
make-sequence-transformer
|
||||
|
|
@ -85,24 +85,25 @@
|
|||
"procedure (arity 1)"
|
||||
1
|
||||
proc1 proc2))
|
||||
(make-sequence-transformer (if (procedure-arity-includes? proc1 0)
|
||||
(lambda (stx)
|
||||
(if (identifier? stx)
|
||||
(proc1)
|
||||
(datum->syntax stx
|
||||
#`(#,(proc1) . #,(cdr (syntax-e stx)))
|
||||
stx
|
||||
stx)))
|
||||
proc1)
|
||||
proc2
|
||||
cert))
|
||||
(make-sequence-transformer
|
||||
(if (procedure-arity-includes? proc1 0)
|
||||
(lambda (stx)
|
||||
(if (identifier? stx)
|
||||
(proc1)
|
||||
(datum->syntax stx
|
||||
#`(#,(proc1) . #,(cdr (syntax-e stx)))
|
||||
stx
|
||||
stx)))
|
||||
proc1)
|
||||
proc2
|
||||
cert))
|
||||
|
||||
(define cert-key (gensym 'for-cert))
|
||||
|
||||
|
||||
(define (certify-clause src-stx clause certifier introducer)
|
||||
;; This is slightly painful. The expansion into `:do-in' involves a lot of pieces
|
||||
;; that are no treated as sub-expressions. We have to push the certificates
|
||||
;; down to all the relevant identifiers and expressions:
|
||||
;; This is slightly painful. The expansion into `:do-in' involves a lot
|
||||
;; of pieces that are no treated as sub-expressions. We have to push the
|
||||
;; certificates down to all the relevant identifiers and expressions:
|
||||
(define (recert s) (syntax-recertify s src-stx (current-inspector) cert-key))
|
||||
(define (cert s) (certifier (recert s) cert-key introducer))
|
||||
(define (map-cert s) (map cert (syntax->list s)))
|
||||
|
|
@ -123,9 +124,8 @@
|
|||
[outer-check (cert #'outer-check)]
|
||||
[(loop-expr ...) (map-cert #'(loop-expr ...))]
|
||||
[pos-guard (cert #'pos-guard)]
|
||||
[((inner-id ...) ...)
|
||||
(map map-cert
|
||||
(syntax->list #'((inner-id ...) ...)))]
|
||||
[((inner-id ...) ...)
|
||||
(map map-cert (syntax->list #'((inner-id ...) ...)))]
|
||||
[pre-guard (cert #'pre-guard)]
|
||||
[post-guard (cert #'post-guard)]
|
||||
[(loop-arg ...) (map-cert #'(loop-arg ...))])
|
||||
|
|
@ -142,7 +142,7 @@
|
|||
[_
|
||||
;; ill-formed clause...
|
||||
clause]))
|
||||
|
||||
|
||||
(define (expand-clause orig-stx clause)
|
||||
(let eloop ([use-transformer? #t])
|
||||
(syntax-case clause (values in-parallel stop-before stop-after :do-in)
|
||||
|
|
@ -158,11 +158,8 @@
|
|||
ids)
|
||||
(let ([dup (check-duplicate-identifier (syntax->list #'(id ...)))])
|
||||
(when dup
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"duplicate identifier as sequence binding"
|
||||
orig-stx
|
||||
dup)))
|
||||
(raise-syntax-error #f
|
||||
"duplicate identifier as sequence binding" orig-stx dup)))
|
||||
#f)
|
||||
'just-checking]
|
||||
[[(id ...) (form . rest)]
|
||||
|
|
@ -177,7 +174,7 @@
|
|||
(if xformed
|
||||
(expand-clause orig-stx (certify-clause (syntax-case clause ()
|
||||
[(_ rhs) #'rhs])
|
||||
(syntax-local-introduce (introducer xformed))
|
||||
(syntax-local-introduce (introducer xformed))
|
||||
certifier
|
||||
introducer))
|
||||
(eloop #f)))))]
|
||||
|
|
@ -259,7 +256,7 @@
|
|||
(with-syntax ([[(id ...) rhs] (introducer (syntax-local-introduce clause))])
|
||||
(syntax-local-introduce
|
||||
(introducer
|
||||
#`(([(pos->vals pos-next init pos-cont? val-cont? all-cont?)
|
||||
#`(([(pos->vals pos-next init pos-cont? val-cont? all-cont?)
|
||||
(#,((syntax-local-certifier #f) #'make-sequence) '(id ...) rhs)])
|
||||
(void)
|
||||
([pos init])
|
||||
|
|
@ -269,51 +266,45 @@
|
|||
(all-cont? pos id ...)
|
||||
((pos-next pos)))))))]
|
||||
[_
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"bad sequence binding clause"
|
||||
orig-stx
|
||||
clause)]))))
|
||||
(raise-syntax-error #f
|
||||
"bad sequence binding clause" orig-stx clause)]))))
|
||||
|
||||
(define-syntax (:do-in stx)
|
||||
(raise-syntax-error #f "illegal outside of a loop or comprehension binding" stx))
|
||||
(raise-syntax-error #f
|
||||
"illegal outside of a loop or comprehension binding" stx))
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; sequences
|
||||
|
||||
|
||||
(define-values (struct:do-sequence
|
||||
make-do-sequence
|
||||
do-sequence?
|
||||
do-sequence-ref
|
||||
do-sequence-set!)
|
||||
(make-struct-type 'sequence #f
|
||||
1 0 #f))
|
||||
(make-struct-type 'sequence #f 1 0 #f))
|
||||
|
||||
(define-values (prop:sequence :sequence? :sequence-ref)
|
||||
(make-struct-type-property 'sequence
|
||||
(lambda (v sinfo)
|
||||
(unless (and (procedure? v)
|
||||
(procedure-arity-includes? v 1))
|
||||
(raise-type-error
|
||||
'sequence-property-guard
|
||||
"procedure (arity 1)"
|
||||
v))
|
||||
(lambda (self)
|
||||
(let ([s (v self)])
|
||||
(unless (sequence? s)
|
||||
(raise-mismatch-error
|
||||
'sequence-generate
|
||||
"procedure (value of prop:sequence) produced a non-sequence: "
|
||||
s))
|
||||
s)))))
|
||||
(make-struct-type-property
|
||||
'sequence
|
||||
(lambda (v sinfo)
|
||||
(unless (and (procedure? v) (procedure-arity-includes? v 1))
|
||||
(raise-type-error 'sequence-property-guard "procedure (arity 1)" v))
|
||||
(lambda (self)
|
||||
(let ([s (v self)])
|
||||
(unless (sequence? s)
|
||||
(raise-mismatch-error
|
||||
'sequence-generate
|
||||
"procedure (value of prop:sequence) produced a non-sequence: "
|
||||
s))
|
||||
s)))))
|
||||
|
||||
(define-syntax define-sequence-syntax
|
||||
(syntax-rules ()
|
||||
[(_ id expr-transformer-expr clause-transformer-expr)
|
||||
(define-syntax id (create-sequence-transformer
|
||||
expr-transformer-expr
|
||||
clause-transformer-expr
|
||||
(syntax-local-certifier #f)))]))
|
||||
(define-syntax id
|
||||
(create-sequence-transformer expr-transformer-expr
|
||||
clause-transformer-expr
|
||||
(syntax-local-certifier #f)))]))
|
||||
|
||||
(define (sequence? v)
|
||||
(or (do-sequence? v)
|
||||
|
|
@ -323,9 +314,8 @@
|
|||
(bytes? v)
|
||||
(input-port? v)
|
||||
(hash? v)
|
||||
(and (:sequence? v)
|
||||
(not (struct-type? v)))))
|
||||
|
||||
(and (:sequence? v) (not (struct-type? v)))))
|
||||
|
||||
(define (make-sequence who v)
|
||||
(cond
|
||||
[(do-sequence? v) ((do-sequence-ref v 0))]
|
||||
|
|
@ -344,7 +334,7 @@
|
|||
who)
|
||||
v)
|
||||
(current-continuation-marks)))]))
|
||||
|
||||
|
||||
(define in-range
|
||||
(case-lambda
|
||||
[(b) (in-range 0 b 1)]
|
||||
|
|
@ -377,13 +367,12 @@
|
|||
(make-do-sequence (lambda () (values values add1 n void void void)))]))
|
||||
|
||||
(define (in-list l)
|
||||
; (unless (list? l) (raise-type-error 'in-list "list" l))
|
||||
;; (unless (list? l) (raise-type-error 'in-list "list" l))
|
||||
(make-do-sequence (lambda () (:list-gen l))))
|
||||
|
||||
|
||||
(define (:list-gen l)
|
||||
(values car cdr l pair? void void))
|
||||
|
||||
|
||||
(define (check-ranges who start stop step)
|
||||
(unless (exact-nonnegative-integer? start) (raise-type-error who "exact non-negative integer" start))
|
||||
(unless (exact-nonnegative-integer? stop) (raise-type-error who "exact non-negative integer or #f" stop))
|
||||
|
|
@ -485,6 +474,22 @@
|
|||
(lambda (x) (not (eof-object? x)))
|
||||
void))))
|
||||
|
||||
(define in-port
|
||||
(let ([mk (lambda (p r)
|
||||
(make-do-sequence
|
||||
(lambda ()
|
||||
(values r values p void
|
||||
(lambda (x) (not (eof-object? x)))
|
||||
void))))])
|
||||
(case-lambda
|
||||
[() (mk (current-input-port) read)]
|
||||
[(r) (mk (current-input-port) r)]
|
||||
[(r p)
|
||||
(unless (and (procedure? r) (procedure-arity-includes? r 1))
|
||||
(raise-type-error 'in->port "procedure (arity 1)" r))
|
||||
(unless (input-port? p) (raise-type-error 'in-port "input-port" p))
|
||||
(mk p r)])))
|
||||
|
||||
(define in-lines
|
||||
(let ([mk (lambda (p m)
|
||||
(make-do-sequence
|
||||
|
|
@ -505,22 +510,6 @@
|
|||
mode))
|
||||
(mk p mode)])))
|
||||
|
||||
(define in-port
|
||||
(let ([mk (lambda (p r)
|
||||
(make-do-sequence
|
||||
(lambda ()
|
||||
(values r values p void
|
||||
(lambda (x) (not (eof-object? x)))
|
||||
void))))])
|
||||
(case-lambda
|
||||
[() (mk (current-input-port) read)]
|
||||
[(r) (mk (current-input-port) r)]
|
||||
[(r p)
|
||||
(unless (and (procedure? r) (procedure-arity-includes? r 1))
|
||||
(raise-type-error 'in->port "procedure (arity 1)" r))
|
||||
(unless (input-port? p) (raise-type-error 'in-port "input-port" p))
|
||||
(mk p r)])))
|
||||
|
||||
(define (in-hash ht)
|
||||
(unless (hash? ht) (raise-type-error 'in-hash "hash" ht))
|
||||
(make-do-sequence (lambda () (:hash-key+val-gen ht))))
|
||||
|
|
@ -563,7 +552,7 @@
|
|||
pos-next
|
||||
init
|
||||
pos-cont?
|
||||
(case-lambda
|
||||
(case-lambda
|
||||
[(val) (and (pre-cont? val)
|
||||
(not (pred val)))]
|
||||
[vals (and (apply pre-cont? vals)
|
||||
|
|
@ -583,7 +572,7 @@
|
|||
init
|
||||
pos-cont?
|
||||
pre-cont?
|
||||
(case-lambda
|
||||
(case-lambda
|
||||
[(pos val) (and (post-cont? pos val)
|
||||
(not (pred val)))]
|
||||
[(pos . vals) (and (apply pos-cont? pos vals)
|
||||
|
|
@ -711,7 +700,7 @@
|
|||
[init-prep-val!
|
||||
(lambda ()
|
||||
(if (pos-cont? pos)
|
||||
(call-with-values
|
||||
(call-with-values
|
||||
(lambda () (pos->val pos))
|
||||
(lambda vals
|
||||
(if (apply pre-cont? vals)
|
||||
|
|
@ -861,7 +850,7 @@
|
|||
null
|
||||
(cons (cadr bs) (loop (cddr bs)))))]
|
||||
[_
|
||||
;; a syntax error; let the /derived form handle it, and
|
||||
;; a syntax error; let the /derived form handle it, and
|
||||
;; no need to wrap any more:
|
||||
bs])))])
|
||||
(quasisyntax/loc stx
|
||||
|
|
@ -874,8 +863,9 @@
|
|||
(define-syntax define-syntax-via-derived
|
||||
(syntax-rules ()
|
||||
[(_ id derived-id fold-bind wrap rhs-wrap combine)
|
||||
(define-syntax (id stx) (for-variant-stx stx #'derived-id #'fold-bind wrap rhs-wrap combine))]))
|
||||
|
||||
(define-syntax (id stx)
|
||||
(for-variant-stx stx #'derived-id #'fold-bind wrap rhs-wrap combine))]))
|
||||
|
||||
(define-syntax define-for-variants
|
||||
(syntax-rules ()
|
||||
[(_ (for for*) fold-bind wrap rhs-wrap combine)
|
||||
|
|
@ -891,17 +881,17 @@
|
|||
[(_ . rest) (quasisyntax/loc stx (for*/fold/derived #,stx . rest))]))
|
||||
|
||||
(define-for-variants (for for*)
|
||||
([fold-var (void)])
|
||||
([fold-var (void)])
|
||||
(lambda (x) x)
|
||||
(lambda (x) x)
|
||||
(lambda (x) `(,#'begin ,x ,#'(void))))
|
||||
|
||||
|
||||
(define-for-variants (for/list for*/list)
|
||||
([fold-var null])
|
||||
(lambda (x) `(,#'reverse ,x))
|
||||
(lambda (x) x)
|
||||
(lambda (x) `(,#'cons ,x ,#'fold-var)))
|
||||
|
||||
|
||||
(define-for-syntax (do-for/lists for/fold-id stx)
|
||||
(syntax-case stx ()
|
||||
[(_ (id ...) bindings expr1 expr ...)
|
||||
|
|
@ -923,16 +913,16 @@
|
|||
expr ...)])
|
||||
(values* (cons id2 id) ...)))])
|
||||
(values* (reverse id) ...))))]))
|
||||
|
||||
|
||||
(define-syntax (for/lists stx) (do-for/lists #'for/fold/derived stx))
|
||||
(define-syntax (for*/lists stx) (do-for/lists #'for*/fold/derived stx))
|
||||
|
||||
|
||||
(define-for-variants (for/and for*/and)
|
||||
([result #t])
|
||||
(lambda (x) x)
|
||||
(lambda (rhs) #`(stop-after #,rhs (lambda x (not result))))
|
||||
(lambda (x) x))
|
||||
|
||||
|
||||
(define-for-variants (for/or for*/or)
|
||||
([result #f])
|
||||
(lambda (x) x)
|
||||
|
|
@ -944,7 +934,7 @@
|
|||
(lambda (x) #`(let-values ([(val _) #,x]) val))
|
||||
(lambda (rhs) #`(stop-after #,rhs (lambda x stop?)))
|
||||
(lambda (x) #`(values #,x #t)))
|
||||
|
||||
|
||||
(define-for-variants (for/last for*/last)
|
||||
([result #f])
|
||||
(lambda (x) x)
|
||||
|
|
@ -975,44 +965,41 @@
|
|||
(lambda (stx)
|
||||
(let loop ([stx stx])
|
||||
(syntax-case stx ()
|
||||
[[(id) (_ a b step)] (let ([all-fx?
|
||||
(and (fixnum? (syntax-e #'a))
|
||||
(fixnum? (syntax-e #'b))
|
||||
(memq (syntax-e #'step) '(1 -1)))])
|
||||
#`[(id)
|
||||
(:do-in
|
||||
;; outer bindings:
|
||||
([(start) a] [(end) b] [(inc) step])
|
||||
;; outer check:
|
||||
(unless (and (real? start) (real? end) (real? inc))
|
||||
;; let `in-range' report the error:
|
||||
(in-range start end inc))
|
||||
;; loop bindings:
|
||||
([pos start])
|
||||
;; pos check
|
||||
#,(if all-fx?
|
||||
;; Special case, can use unsafe ops:
|
||||
(cond
|
||||
[((syntax-e #'step) . >= . 0)
|
||||
#'(unsafe-fx< pos end)]
|
||||
[else
|
||||
#'(unsafe-fx> pos end)])
|
||||
;; General case:
|
||||
(cond
|
||||
[(not (number? (syntax-e #'step)))
|
||||
#`(if (step . >= . 0) (< pos end) (> pos end))]
|
||||
[((syntax-e #'step) . >= . 0)
|
||||
#'(< pos end)]
|
||||
[else
|
||||
#'(> pos end)]))
|
||||
;; inner bindings
|
||||
([(id) pos])
|
||||
;; pre guard
|
||||
#t
|
||||
;; post guard
|
||||
#t
|
||||
;; loop args
|
||||
((#,(if all-fx? #'unsafe-fx+ #'+) pos inc)))])]
|
||||
[[(id) (_ a b step)]
|
||||
(let ([all-fx? (and (fixnum? (syntax-e #'a))
|
||||
(fixnum? (syntax-e #'b))
|
||||
(memq (syntax-e #'step) '(1 -1)))])
|
||||
#`[(id)
|
||||
(:do-in
|
||||
;; outer bindings:
|
||||
([(start) a] [(end) b] [(inc) step])
|
||||
;; outer check:
|
||||
(unless (and (real? start) (real? end) (real? inc))
|
||||
;; let `in-range' report the error:
|
||||
(in-range start end inc))
|
||||
;; loop bindings:
|
||||
([pos start])
|
||||
;; pos check
|
||||
#,(cond [all-fx?
|
||||
;; Special case, can use unsafe ops:
|
||||
(if ((syntax-e #'step) . >= . 0)
|
||||
#'(unsafe-fx< pos end)
|
||||
#'(unsafe-fx> pos end))]
|
||||
;; General cases:
|
||||
[(not (number? (syntax-e #'step)))
|
||||
#`(if (step . >= . 0) (< pos end) (> pos end))]
|
||||
[((syntax-e #'step) . >= . 0)
|
||||
#'(< pos end)]
|
||||
[else
|
||||
#'(> pos end)])
|
||||
;; inner bindings
|
||||
([(id) pos])
|
||||
;; pre guard
|
||||
#t
|
||||
;; post guard
|
||||
#t
|
||||
;; loop args
|
||||
((#,(if all-fx? #'unsafe-fx+ #'+) pos inc)))])]
|
||||
[[(id) (_ a b)] (loop #'[(id) (_ a b 1)])]
|
||||
[[(id) (_ b)] (loop #'[(id) (_ 0 b 1)])]
|
||||
[_ #f]))))
|
||||
|
|
@ -1052,7 +1039,7 @@
|
|||
(lambda () #'in-list)
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[((id) (_ lst-expr))
|
||||
[[(id) (_ lst-expr)]
|
||||
#'[(id)
|
||||
(:do-in
|
||||
;;outer bindings
|
||||
|
|
@ -1084,7 +1071,7 @@
|
|||
[unsafe-vector-ref unsafe-vector-ref-id])
|
||||
(syntax-case stx ()
|
||||
;; Fast case
|
||||
[((id) (_ vec-expr))
|
||||
[[(id) (_ vec-expr)]
|
||||
#'[(id)
|
||||
(:do-in
|
||||
;;outer bindings
|
||||
|
|
@ -1158,49 +1145,47 @@
|
|||
((#,(if all-fx? #'unsafe-fx+ #'+) idx step)))])]
|
||||
[_ #f])))
|
||||
in-vector-like)
|
||||
|
||||
|
||||
(define-sequence-syntax *in-vector
|
||||
(lambda () #'in-vector)
|
||||
(vector-like-gen #'vector?
|
||||
#'unsafe-vector-length
|
||||
#'in-vector
|
||||
#'unsafe-vector-ref))
|
||||
|
||||
|
||||
(define-sequence-syntax *in-string
|
||||
(lambda () #'in-string)
|
||||
(vector-like-gen #'string?
|
||||
#'string-length
|
||||
#'in-string
|
||||
#'string-ref))
|
||||
|
||||
|
||||
(define-sequence-syntax *in-bytes
|
||||
(lambda () #'in-bytes)
|
||||
(vector-like-gen #'bytes?
|
||||
#'bytes-length
|
||||
#'in-bytes
|
||||
#'bytes-ref))
|
||||
|
||||
|
||||
(define-sequence-syntax *in-indexed
|
||||
(lambda () #'in-indexed)
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[((id1 id2) (_ gen-expr))
|
||||
[[(id1 id2) (_ gen-expr)]
|
||||
#'[(id1 id2) (in-parallel gen-expr (*in-naturals))]])))
|
||||
|
||||
(define-sequence-syntax *in-value
|
||||
(lambda () #'in-value)
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[((id) (_ expr))
|
||||
#'[(id)
|
||||
(:do-in ([(id) expr])
|
||||
#t () #t () #t #f ())]])))
|
||||
[[(id) (_ expr)]
|
||||
#'[(id) (:do-in ([(id) expr]) #t () #t () #t #f ())]])))
|
||||
|
||||
(define-sequence-syntax *in-producer
|
||||
(lambda () #'in-producer)
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[((id) (_ producer stop more ...))
|
||||
[[(id) (_ producer stop more ...)]
|
||||
(with-syntax ([(more* ...) (generate-temporaries #'(more ...))])
|
||||
#'[(id)
|
||||
(:do-in
|
||||
|
|
@ -1223,7 +1208,7 @@
|
|||
;; loop args
|
||||
())])]
|
||||
;; multiple-values version
|
||||
[((id ...) (_ producer stop more ...))
|
||||
[[(id ...) (_ producer stop more ...)]
|
||||
(with-syntax ([(more* ...) (generate-temporaries #'(more ...))])
|
||||
#'[(id ...)
|
||||
(:do-in
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user