Added uses of unstable/struct

This commit is contained in:
Ryan Culpepper 2010-07-01 20:07:01 -06:00
parent df4e37fe08
commit 07f57aac9b
7 changed files with 21 additions and 16 deletions

View File

@ -2,6 +2,7 @@
(require mzlib/etc (require mzlib/etc
scheme/match scheme/match
scheme/list scheme/list
unstable/struct
compiler/zo-structs) compiler/zo-structs)
(provide zo-parse) (provide zo-parse)
@ -529,7 +530,7 @@
(apply (apply
make-prefab-struct make-prefab-struct
k k
(map loop (cdr (vector->list (struct->vector v)))))))] (map loop (struct->list v)))))]
[else (add-wrap v)])) [else (add-wrap v)]))
;; Decode sub-elements that have their own wraps: ;; Decode sub-elements that have their own wraps:
(let-values ([(v counter) (if (exact-integer? (car v)) (let-values ([(v counter) (if (exact-integer? (car v))
@ -551,7 +552,7 @@
(apply (apply
make-prefab-struct make-prefab-struct
k k
(map loop (cdr (vector->list (struct->vector v)))))))] (map loop (struct->list v)))))]
[else (add-wrap v)])))))) [else (add-wrap v)]))))))
(define (decode-wraps cp w) (define (decode-wraps cp w)

View File

@ -1,5 +1,6 @@
(module serialize racket/base (module serialize racket/base
(require syntax/modcollapse (require syntax/modcollapse
unstable/struct
"serialize-structs.rkt") "serialize-structs.rkt")
;; This module implements the core serializer. The syntactic ;; This module implements the core serializer. The syntactic
@ -212,7 +213,7 @@
(for-each loop (vector->list ((serialize-info-vectorizer info) v))))] (for-each loop (vector->list ((serialize-info-vectorizer info) v))))]
[(and (struct? v) [(and (struct? v)
(prefab-struct-key v)) (prefab-struct-key v))
(for-each loop (cdr (vector->list (struct->vector v))))] (for-each loop (struct->list v))]
[(or (string? v) [(or (string? v)
(bytes? v) (bytes? v)
(path-for-some-system? v)) (path-for-some-system? v))
@ -229,7 +230,7 @@
[(box? v) [(box? v)
(loop (unbox v))] (loop (unbox v))]
[(date? v) [(date? v)
(for-each loop (cdr (vector->list (struct->vector v))))] (for-each loop (struct->list v))]
[(hash? v) [(hash? v)
(hash-for-each v (lambda (k v) (hash-for-each v (lambda (k v)
(loop k) (loop k)
@ -282,7 +283,7 @@
(cons 'f (cons 'f
(cons (cons
k k
(map (serial #t) (cdr (vector->list (struct->vector v)))))))] (map (serial #t) (struct->list v)))))]
[(or (string? v) [(or (string? v)
(bytes? v)) (bytes? v))
(cons 'u v)] (cons 'u v)]
@ -316,7 +317,7 @@
(loop v))))))] (loop v))))))]
[(date? v) [(date? v)
(cons 'date (cons 'date
(map (serial #t) (cdr (vector->list (struct->vector v)))))] (map (serial #t) (struct->list v)))]
[(arity-at-least? v) [(arity-at-least? v)
(cons 'arity-at-least (cons 'arity-at-least
((serial #t) (arity-at-least-value v)))] ((serial #t) (arity-at-least-value v)))]

View File

@ -73,7 +73,7 @@
[(p ...) (struct->list (syntax-e #'s))]) [(p ...) (struct->list (syntax-e #'s))])
#'(let ([xkey (prefab-struct-key x)]) #'(let ([xkey (prefab-struct-key x)])
(if (equal? xkey 'key) (if (equal? xkey 'key)
(let ([xps (cdr (vector->list (struct->vector x)))]) (let ([xps (struct->list x)])
(match-p xps (list p ...) success failure)) (match-p xps (list p ...) success failure))
failure)))])) failure)))]))

View File

@ -1,5 +1,6 @@
#lang scheme/base #lang scheme/base
(require "../stx.ss") (require "../stx.ss"
unstable/struct)
(provide template-map-apply) (provide template-map-apply)
@ -82,5 +83,5 @@
stx stx
(loop (prefab-fields tmap) (loop (prefab-fields tmap)
(cdr data) (cdr data)
(cdr (vector->list (struct->vector (syntax-e stx))))))] (struct->list (syntax-e stx))))]
[else (error "template-map-apply fallthrough")]))) [else (error "template-map-apply fallthrough")])))

View File

@ -1,4 +1,5 @@
#lang scheme/base #lang racket/base
(require unstable/struct)
(provide strip-context (provide strip-context
replace-context) replace-context)
@ -23,5 +24,5 @@
=> (lambda (k) => (lambda (k)
(apply make-prefab-struct (apply make-prefab-struct
k k
(replace-context ctx (cdr (vector->list (struct->vector e))))))] (replace-context ctx (struct->list e))))]
[else e])) [else e]))

View File

@ -1,5 +1,6 @@
#lang scheme/base #lang scheme/base
(require "stx.ss" (require "stx.ss"
unstable/struct
(for-template scheme/base (for-template scheme/base
"private/template-runtime.ss")) "private/template-runtime.ss"))
@ -71,7 +72,7 @@
[_ [_
(let ([k (prefab-struct-key (syntax-e tmpl))]) (let ([k (prefab-struct-key (syntax-e tmpl))])
(and k (and k
(let ([as (loop (cdr (vector->list (struct->vector (syntax-e tmpl))) in-ellipses?))]) (let ([as (loop (struct->list (syntax-e tmpl)) in-ellipses?)])
(and (or as (not const-leaf?)) (and (or as (not const-leaf?))
(make-prefab k as)) (make-prefab k as))
#f)))]))) #f)))])))
@ -115,7 +116,7 @@
[(prefab? tmap) [(prefab? tmap)
(cons (s->d template) (cons (s->d template)
(loop (prefab-fields tmap) (loop (prefab-fields tmap)
(cdr (vector->list (struct->vector (syntax-e template))))))] (struct->list (syntax-e template))))]
[else (error "template-map-collect fall-through")]))) [else (error "template-map-collect fall-through")])))
(define (group-ellipses tmap template) (define (group-ellipses tmap template)
@ -164,7 +165,7 @@
make-prefab-struct make-prefab-struct
(prefab-key tmap) (prefab-key tmap)
(loop (prefab-fields tmap) (loop (prefab-fields tmap)
(cdr (vector->list (struct->vector (syntax-e template)))))))] (struct->list (syntax-e template)))))]
[else (error "group-ellipses fall-through")]))) [else (error "group-ellipses fall-through")])))
(define (transform-template template-stx (define (transform-template template-stx

View File

@ -6,7 +6,7 @@
syntax/boundmap syntax/boundmap
"free-variance.rkt" "free-variance.rkt"
"interning.rkt" "interning.rkt"
unstable/syntax unstable/match unstable/syntax unstable/match unstable/struct
mzlib/etc mzlib/etc
scheme/contract scheme/contract
(for-syntax (for-syntax
@ -255,7 +255,7 @@
(define (replace-field val new-val idx) (define (replace-field val new-val idx)
(define-values (type skipped) (struct-info val)) (define-values (type skipped) (struct-info val))
(define maker (struct-type-make-constructor type)) (define maker (struct-type-make-constructor type))
(define flds (cdr (vector->list (struct->vector val)))) (define flds (struct->list val))
(apply maker (list-set flds idx new-val))) (apply maker (list-set flds idx new-val)))
(define (replace-syntax rep stx) (define (replace-syntax rep stx)