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

some cleanup

Browse Source 
svn: r5503
This commit is contained in:
Robby Findler 2007-01-30 00:54:23 +00:00
parent 8eee6a0298
commit de59204fa5
5 changed files with 59 additions and 48 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/mzlib/contract.ss
View File

@ -9,7 +9,7 @@
"private/contract-basic-opters.ss")
(provide
opt/c ;(all-from "private/contract-opt.ss")
opt/c #;define-opt/c ;(all-from "private/contract-opt.ss")
(all-from-except "private/contract-ds.ss"
lazy-depth-to-look)

2
collects/mzlib/private/contract-basic-opters.ss
View File

@ -8,7 +8,6 @@
;; opt/pred helper
;;
(define-for-syntax (opt/pred opt/info pred)
(printf "~s\n" (list 'opt/pred opt/info pred))
(with-syntax ((pred pred))
(values
(with-syntax ((val (opt/info-val opt/info))
@ -40,7 +39,6 @@
(syntax-case stx (null?)
[null? (opt/pred opt/info #'null?)]))
(define/opter (boolean? opt/i opt/info stx)
(printf "boolean opter\n")
(syntax-case stx (boolean?)
[boolean? (opt/pred opt/info #'boolean?)]))
(define/opter (integer? opt/i opt/info stx)

3
collects/mzlib/private/contract-ds.ss
View File

@ -360,8 +360,7 @@ it around flattened out.
(opt/info-recf opt/info)
(opt/info-base-pred opt/info)
(opt/info-this opt/info)
(opt/info-that opt/info)
(opt/info-sv-index opt/info))
(opt/info-that opt/info))
name
stx
clauses

25
collects/mzlib/private/contract-opt-guts.ss
View File

@ -19,10 +19,6 @@
opt/info-base-pred
opt/info-this
opt/info-that
opt/info-sv-index
sv-index
inc-sv-index!
opt/info-swap-blame)
@ -56,16 +52,7 @@
;; struct for color-keeping across opters
(define-struct opt/info (contract val pos neg src-info orig-str free-vars recf base-pred this that sv-index))
;; sv-index : opt/info -> int
(define (sv-index info)
(unbox (opt/info-sv-index info)))
;; inc-sv-index! : opt/info int -> unit
(define (inc-sv-index! info n)
(let ((old (unbox (opt/info-sv-index info))))
(set-box! (opt/info-sv-index info) (+ old n))))
(define-struct opt/info (contract val pos neg src-info orig-str free-vars recf base-pred this that))
;; opt/info-swap-blame : opt/info -> opt/info
;; swaps pos and neg
@ -80,9 +67,8 @@
(recf (opt/info-recf info))
(base-pred (opt/info-base-pred info))
(this (opt/info-this info))
(that (opt/info-that info))
(sv-index (opt/info-sv-index info)))
(make-opt/info ctc val pos neg src-info orig-str free-vars recf base-pred this that sv-index)))
(that (opt/info-that info)))
(make-opt/info ctc val pos neg src-info orig-str free-vars recf base-pred this that)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -126,11 +112,6 @@
(number? (syntax-e e))
(boolean? (syntax-e e)))
(values e lifts)]
#;
[x
(identifier? e)
(values e
(snoc (cons e e) lifts))]
[else
(let ([x (car (generate-temporaries (list id-hint)))])
(values x

75
collects/mzlib/private/contract-opt.ss
View File

@ -1,11 +1,13 @@
(module contract-opt mzscheme
(require "contract-guts.ss"
(lib "stxparam.ss")
(lib "etc.ss"))
(require-for-syntax "contract-opt-guts.ss"
(lib "etc.ss")
(lib "stxparam.ss")
(lib "list.ss"))
(provide opt/c define/opter define/osc opt-stronger-vars-ref)
(provide opt/c define-opt/c define/opter define/osc opt-stronger-vars-ref)
;; define/opter : id -> syntax
;;
@ -138,6 +140,19 @@
[argless-ctc
(and (identifier? #'argless-ctc) (opter #'argless-ctc))
((opter #'argless-ctc) opt/i opt/info stx)]
[(f arg ...)
(and (identifier? #'f)
(syntax-parameter-value #'define/opt-recursive-fn)
(module-identifier=? (syntax-parameter-value #'define/opt-recursive-fn)
#'f))
(values
#`(f #,(opt/info-val opt/info) arg ...)
null
null
null
#f
#f
null)]
[else
(opt/unknown opt/i opt/info stx)]))
@ -153,25 +168,44 @@
#f
#f
#'this
#'that
(box 0))]
#'that)]
[(next lifts superlifts partials _ __ stronger-ribs) (opt/i info #'e)])
(with-syntax ((next next))
(bind-superlifts
superlifts
(bind-lifts
lifts
#`(make-opt-contract
(λ (ctc)
(λ (pos neg src-info orig-str)
#,(bind-lifts
partials
#`(λ (val)
next))))
(λ () e)
(λ (this that) #f)
(vector)
(begin-lifted (box #f)))))))]))
(with-syntax ([next next])
(let ([superlifts2
(if (syntax-parameter-value #'define/opt-recursive-fn)
(cons (cons
(syntax-parameter-value #'define/opt-recursive-fn)
(with-syntax ([(args ...)
(syntax-parameter-value #'define/opt-recursive-args)])
#'(lambda (val info args ...) 'next)))
superlifts)
superlifts)])
(bind-superlifts
superlifts2
(bind-lifts
lifts
#`(make-opt-contract
(λ (ctc)
(λ (pos neg src-info orig-str)
#,(bind-lifts
partials
#`(λ (val)
next))))
(λ () e)
(λ (this that) #f)
(vector)
(begin-lifted (box #f))))))))]))
(define-syntax-parameter define/opt-recursive-fn #f)
(define-syntax-parameter define/opt-recursive-args #f)
(define-syntax (define-opt/c stx)
(syntax-case stx ()
[(_ (id args ...) body)
#'(define (id args ...)
(syntax-parameterize ([define/opt-recursive-fn #'id]
[define/opt-recursive-args #'(args ...)])
(opt/c body)))]))
;; define/osc : syntax -> syntax
;; define/osc allows you define optimized recursive contracts, and must be used
@ -210,8 +244,7 @@
#'f
#'base-pred
#'this
#'that
(box 0))]
#'that)]
[(next lifts superlifts partials _ __ stronger-ribs) (opt/i info #'e)])
(with-syntax ((next next)
((superlift ...) (map (λ (x) (with-syntax ((var (car x))