From de59204fa51801f973407e49e85d40829b4c67fc Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 30 Jan 2007 00:54:23 +0000 Subject: [PATCH] some cleanup svn: r5503 --- collects/mzlib/contract.ss | 2 +- .../mzlib/private/contract-basic-opters.ss | 2 - collects/mzlib/private/contract-ds.ss | 3 +- collects/mzlib/private/contract-opt-guts.ss | 25 +------ collects/mzlib/private/contract-opt.ss | 75 +++++++++++++------ 5 files changed, 59 insertions(+), 48 deletions(-) diff --git a/collects/mzlib/contract.ss b/collects/mzlib/contract.ss index 59a268708f..2c2daed39d 100644 --- a/collects/mzlib/contract.ss +++ b/collects/mzlib/contract.ss @@ -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) diff --git a/collects/mzlib/private/contract-basic-opters.ss b/collects/mzlib/private/contract-basic-opters.ss index 37fbb6e153..5fae2d3d12 100644 --- a/collects/mzlib/private/contract-basic-opters.ss +++ b/collects/mzlib/private/contract-basic-opters.ss @@ -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) diff --git a/collects/mzlib/private/contract-ds.ss b/collects/mzlib/private/contract-ds.ss index 8f48b9d546..3a6649b62d 100644 --- a/collects/mzlib/private/contract-ds.ss +++ b/collects/mzlib/private/contract-ds.ss @@ -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 diff --git a/collects/mzlib/private/contract-opt-guts.ss b/collects/mzlib/private/contract-opt-guts.ss index 584175acb6..6e7d90b64f 100644 --- a/collects/mzlib/private/contract-opt-guts.ss +++ b/collects/mzlib/private/contract-opt-guts.ss @@ -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 diff --git a/collects/mzlib/private/contract-opt.ss b/collects/mzlib/private/contract-opt.ss index a98d4c385a..cf7d4bbdb9 100644 --- a/collects/mzlib/private/contract-opt.ss +++ b/collects/mzlib/private/contract-opt.ss @@ -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))