diff --git a/conventions.rkt b/conventions.rkt index bed4232..e259feb 100644 --- a/conventions.rkt +++ b/conventions.rkt @@ -276,12 +276,12 @@ (define-pretty format-if #:type node? (match/extract (node-content doc) #:as unfits tail - [([-if #t] [-conditional #f] [-true-branch #t] [-false-branch #t]) - (define args-list (list -conditional -true-branch -false-branch)) + [([-if #t] [-conditional #f]) + (define args-list (cons -conditional tail)) (define multi-line-args ((format-vertical/helper) args-list)) (define single-line-args (flatten (as-concat (map pretty args-list)))) (define args-doc - (if (or (node? -true-branch) (node? -false-branch)) + (if (ormap node? tail) multi-line-args (alt multi-line-args single-line-args))) (pretty-node #:unfits unfits diff --git a/tests/benchmarks/class-internal.rkt.out b/tests/benchmarks/class-internal.rkt.out index 5b01b0b..652a83a 100644 --- a/tests/benchmarks/class-internal.rkt.out +++ b/tests/benchmarks/class-internal.rkt.out @@ -176,9 +176,10 @@ [(_ elem ...) ;; Set taint mode on elem ... (with-syntax ([internal-id internal-id] - [(elem ...) - (for/list ([e (in-list (syntax->list #'(elem ...)))]) - (if (identifier? e) e (syntax-property e 'taint-mode 'transparent)))]) + [(elem ...) (for/list ([e (in-list (syntax->list #'(elem ...)))]) + (if (identifier? e) + e + (syntax-property e 'taint-mode 'transparent)))]) (class-syntax-protect (syntax-property (syntax/loc stx (internal-id elem ...)) 'taint-mode @@ -495,7 +496,11 @@ ;; Put i in ((iid eid) optional-expr) form (cond [(identifier? i) (list (list i i))] - [else (let ([a (stx-car i)]) (if (identifier? a) (cons (list a a) (stx-cdr i)) i))])) + [else + (let ([a (stx-car i)]) + (if (identifier? a) + (cons (list a a) (stx-cdr i)) + i))])) (define ((norm-init/field-iid/def-ctx def-ctx) norm) (syntax-local-identifier-as-binding (stx-car (stx-car norm)) def-ctx)) @@ -624,8 +629,9 @@ (andmap identifier? (syntax->list (syntax (id ...))))) (let* ([letrec? (free-identifier=? (syntax let-) (quote-syntax letrec-values))] [ids (syntax->list (syntax (id ...)))] - [new-ids - (if xform? (map (lambda (id) (datum->syntax #f (gensym (syntax-e id)))) ids) ids)] + [new-ids (if xform? + (map (lambda (id) (datum->syntax #f (gensym (syntax-e id)))) ids) + ids)] [body-locals (append ids locals)] [exprs (map (lambda (expr id) (loop expr #t id (if letrec? body-locals locals))) (syntax->list (syntax (expr ...))) @@ -738,7 +744,9 @@ [class-name (if name-id (syntax-e name-id) (let ([s (syntax-local-infer-name stx)]) - (if (syntax? s) (syntax-e s) s)))]) + (if (syntax? s) + (syntax-e s) + s)))]) ;; ------ Basic syntax checks ----- (for-each @@ -1070,8 +1078,12 @@ (bound-identifier=? i (car ids))) local-public-names)]) (loop (cdr exprs) - (if public? (cons (cons (car ids) expr) ms) ms) - (if public? pms (cons (cons (car ids) expr) pms)) + (if public? + (cons (cons (car ids) expr) ms) + ms) + (if public? + pms + (cons (cons (car ids) expr) pms)) es sd))) ;; Non-method defn: @@ -1345,10 +1357,12 @@ [(local-field ...) (definify (append field-names private-field-names))] [(local-field-localized ...) (map lookup-localize (append field-names private-field-names))] - [(local-field-pos ...) - (let loop ([pos 0] - [l (append field-names private-field-names)]) - (if (null? l) null (cons pos (loop (add1 pos) (cdr l)))))] + [(local-field-pos ...) (let loop ([pos 0] + [l (append field-names + private-field-names)]) + (if (null? l) + null + (cons pos (loop (add1 pos) (cdr l)))))] [(local-field-accessor ...) (generate-temporaries (append field-names private-field-names))] [(local-field-mutator ...) @@ -2188,7 +2202,10 @@ last few projections. (null? augride-names) (null? final-names))] [no-new-fields? (null? public-field-names)] - [xappend (lambda (a b) (if (null? b) a (append a b)))]) + [xappend (lambda (a b) + (if (null? b) + a + (append a b)))]) ;; -- Check interfaces --- (for-each (lambda (intf) @@ -2210,8 +2227,12 @@ last few projections. #:class-name name))) ;; -- Match method and field names to indices -- - (let ([method-ht (if no-new-methods? (class-method-ht super) (hash-copy (class-method-ht super)))] - [field-ht (if no-new-fields? (class-field-ht super) (hash-copy (class-field-ht super)))] + (let ([method-ht (if no-new-methods? + (class-method-ht super) + (hash-copy (class-method-ht super)))] + [field-ht (if no-new-fields? + (class-field-ht super) + (hash-copy (class-field-ht super)))] [super-method-ht (class-method-ht super)] [super-method-ids (class-method-ids super)] [super-field-ids (class-field-ids super)] @@ -2325,7 +2346,9 @@ last few projections. #:class-name name))) ;; ---- Make the class and its interface ---- - (let* ([class-make (if name (make-naming-constructor struct:class name "class") make-class)] + (let* ([class-make (if name + (make-naming-constructor struct:class name "class") + make-class)] [interface-make (if name (make-naming-constructor struct:interface (string->symbol (format "interface:~a" @@ -2345,21 +2368,30 @@ last few projections. (make-immutable-hash) #f null)] - [methods (if no-method-changes? (class-methods super) (make-vector method-width))] - [super-methods - (if no-method-changes? (class-super-methods super) (make-vector method-width))] - [int-methods - (if no-method-changes? (class-int-methods super) (make-vector method-width))] - [beta-methods - (if no-method-changes? (class-beta-methods super) (make-vector method-width))] - [inner-projs - (if no-method-changes? (class-inner-projs super) (make-vector method-width))] - [dynamic-idxs - (if no-method-changes? (class-dynamic-idxs super) (make-vector method-width))] - [dynamic-projs - (if no-method-changes? (class-dynamic-projs super) (make-vector method-width))] - [meth-flags - (if no-method-changes? (class-meth-flags super) (make-vector method-width))] + [methods (if no-method-changes? + (class-methods super) + (make-vector method-width))] + [super-methods (if no-method-changes? + (class-super-methods super) + (make-vector method-width))] + [int-methods (if no-method-changes? + (class-int-methods super) + (make-vector method-width))] + [beta-methods (if no-method-changes? + (class-beta-methods super) + (make-vector method-width))] + [inner-projs (if no-method-changes? + (class-inner-projs super) + (make-vector method-width))] + [dynamic-idxs (if no-method-changes? + (class-dynamic-idxs super) + (make-vector method-width))] + [dynamic-projs (if no-method-changes? + (class-dynamic-projs super) + (make-vector method-width))] + [meth-flags (if no-method-changes? + (class-meth-flags super) + (make-vector method-width))] [c (class-make name (add1 (class-pos super)) (list->vector (append (vector->list (class-supers super)) (list #f))) @@ -2402,7 +2434,9 @@ last few projections. #f ; serializer is set later (or check-undef? (class-check-undef? super)) (and make-struct:prim #t))] - [obj-name (if name (string->symbol (format "object:~a" name)) 'object)] + [obj-name (if name + (string->symbol (format "object:~a" name)) + 'object)] ;; Used only for prim classes [preparer (lambda (name) ;; Map symbol to number: @@ -2431,7 +2465,9 @@ last few projections. (if (impersonator-prop:has-wrapped-class-neg-party? super) (let* ([the-info (impersonator-prop:get-wrapped-class-info super)] [oh (wrapped-class-info-neg-acceptors-ht the-info)]) - (if no-method-changes? oh (hash-copy oh))) + (if no-method-changes? + oh + (hash-copy oh))) #f)) ;; --- Make the new object struct --- @@ -2712,7 +2748,10 @@ last few projections. (define ictc-infos (get-interface-contract-info (class-self-interface c) id)) (define meth-entry (vector-ref methods index)) - (define meth (if (pair? meth-entry) (car meth-entry) meth-entry)) + (define meth + (if (pair? meth-entry) + (car meth-entry) + meth-entry)) (vector-set! methods index (list meth @@ -2919,7 +2958,9 @@ An example (cons (list our-ctc our-name #f our-name) ;; replace occurrences of #f positive blame with this interface (map (λ (info) - (if (not (caddr info)) (list (car info) (cadr info) our-name (cadddr info)) info)) + (if (not (caddr info)) + (list (car info) (cadr info) our-name (cadddr info)) + info)) dedup-infos))])) ;; infos bool blame -> infos @@ -3165,8 +3206,9 @@ An example (for-each (lambda (p v) (let ([g (gensym)]) (hash-set! prop-ht g (vector g p v)))) props vals) ;; Check for [conflicting] implementation requirements (let ([class (get-implement-requirement supers 'interface #:intf-name name)] - [interface-make - (if name (make-naming-constructor struct:interface name "interface") make-interface)]) + [interface-make (if name + (make-naming-constructor struct:interface name "interface") + make-interface)]) ;; Add supervars to table: (for-each (lambda (super) (for-each (lambda (var) (hash-set! ht var #t)) (interface-public-ids super))) @@ -3255,7 +3297,9 @@ An example (recur elem-a elem-b)))))))) (define (object-hash-code obj recur) (let ([vec (inspectable-struct->vector obj)]) - (if vec (recur (vector (object-ref obj) vec)) (eq-hash-code obj)))) + (if vec + (recur (vector (object-ref obj) vec)) + (eq-hash-code obj)))) (define object<%> ((make-naming-constructor struct:interface 'interface:object% #f) 'object% @@ -3383,7 +3427,9 @@ An example [(_ do-make-object orig-stx first? (maker-arg ...) args (kw arg) ...) (andmap identifier? (syntax->list (syntax (kw ...)))) (with-syntax ([(kw ...) (map localize (syntax->list (syntax (kw ...))))] - [(blame ...) (if (syntax-e #'first?) #'((current-contract-region)) null)]) + [(blame ...) (if (syntax-e #'first?) + #'((current-contract-region)) + null)]) (class-syntax-protect (syntax/loc stx (do-make-object blame ... maker-arg ... args (list (cons `kw arg) ...)))))] @@ -3433,10 +3479,14 @@ An example [ictc-meths (class-method-ictcs cls)] [method-width (class-method-width cls)] [method-ht (class-method-ht cls)] - [meths (if (null? ictc-meths) (class-methods cls) (make-vector method-width))] + [meths (if (null? ictc-meths) + (class-methods cls) + (make-vector method-width))] [field-pub-width (class-field-pub-width cls)] [field-ht (class-field-ht cls)] - [class-make (if name (make-naming-constructor struct:class name "class") make-class)] + [class-make (if name + (make-naming-constructor struct:class name "class") + make-class)] [c (class-make name (class-pos cls) (list->vector (vector->list (class-supers cls))) @@ -3475,7 +3525,9 @@ An example #f ; serializer is never set (class-check-undef? cls) #f)] - [obj-name (if name (string->symbol (format "wrapper-object:~a" name)) 'object)]) + [obj-name (if name + (string->symbol (format "wrapper-object:~a" name)) + 'object)]) (vector-set! (class-supers c) (class-pos c) c) @@ -3622,7 +3674,9 @@ An example (do-merge by-pos-args (class-init-args c) c named-args by-pos-args c) ;; Non-merge for by-position initializers by-pos-args)] - [leftovers (if (not by-pos-only?) (get-leftovers named-args (class-init-args c)) null)]) + [leftovers (if (not by-pos-only?) + (get-leftovers named-args (class-init-args c)) + null)]) ;; In 'list mode, make sure no by-name arguments are left over (when (eq? 'list (class-init-mode c)) (unless (or (null? leftovers) (not (ormap car leftovers))) @@ -3681,7 +3735,9 @@ An example ;; All unconsumed named-args must have #f ;; "name"s, otherwise an error is raised in ;; the leftovers checking. - (if (null? al) named-args (append (map (lambda (x) (cons #f x)) al) named-args))] + (if (null? al) + named-args + (append (map (lambda (x) (cons #f x)) al) named-args))] [else (obj-error 'instantiate "too many initialization arguments" @@ -3711,7 +3767,9 @@ An example [else (obj-error 'instantiate "too few initialization arguments")]))) (define (extract-rest-args skip arguments) - (if (< skip (length arguments)) (map cdr (list-tail arguments skip)) null)) + (if (< skip (length arguments)) + (map cdr (list-tail arguments skip)) + null)) (define (make-pos-arg-string args) (let ([len (length args)]) (apply string-append (map (lambda (a) (format " ~e" a)) args)))) @@ -3757,7 +3815,9 @@ An example (define kw-args/var (and kw-args (list (car kw-args) #'kw-arg-tmp))) (define arg-list '()) (define let-bindings '()) - (for ([x (in-list (if (list? args) args (syntax->list args)))]) + (for ([x (in-list (if (list? args) + args + (syntax->list args)))]) (cond [(keyword? (syntax-e x)) (set! arg-list (cons x arg-list))] [else @@ -3772,7 +3832,9 @@ An example (let*-values ([(sym) (quasiquote (unsyntax (localize name)))] [(receiver) (unsyntax obj)] [(method) (find-method/who '(unsyntax form) receiver sym)]) - (let (#,@(if kw-args (list #`[kw-arg-tmp #,(cadr kw-args)]) (list)) + (let (#,@(if kw-args + (list #`[kw-arg-tmp #,(cadr kw-args)]) + (list)) #,@let-bindings) (unsyntax (make-method-call-to-possibly-wrapped-object stx @@ -3798,7 +3860,9 @@ An example #'form #'obj #'name - (if kws? (cddr (syntax->list #'args)) #'args) + (if kws? + (cddr (syntax->list #'args)) + #'args) apply? (and kws? (let ([l (syntax->list #'args)]) (list (car l) (cadr l))))) (if apply? @@ -3888,7 +3952,9 @@ An example => (lambda (cls) (define mth-idx (hash-ref (class-method-ht cls) name #f)) - (if mth-idx (vector-ref (class-methods cls) mth-idx) (no-such-method who name cls)))] + (if mth-idx + (vector-ref (class-methods cls) mth-idx) + (no-such-method who name cls)))] [(wrapped-object? in-object) (define cls (let loop ([obj in-object]) @@ -4029,7 +4095,9 @@ An example [(_ object generic . args) (let* ([args-stx (syntax args)] [proper? (stx-list? args-stx)] - [flat-stx (if proper? args-stx (flatten-args args-stx))]) + [flat-stx (if proper? + args-stx + (flatten-args args-stx))]) (with-syntax ([(gen obj) (generate-temporaries (syntax (generic object)))]) (class-syntax-protect (quasisyntax/loc stx (let* ([obj object] @@ -4314,7 +4382,9 @@ An example (define (object-info o) (unless (object? o) (raise-argument-error 'object-info "object?" o)) - (let ([o* (if (has-original-object? o) (original-object o) o)]) + (let ([o* (if (has-original-object? o) + (original-object o) + o)]) (let loop ([c (object-ref/unwrap o*)] [skipped? #f]) (if (struct? ((class-insp-mk c))) @@ -4325,7 +4395,9 @@ An example (loop (vector-ref (class-supers c) (sub1 (class-pos c))) #t)))))) (define (to-sym s) - (if (string? s) (string->symbol s) s)) + (if (string? s) + (string->symbol s) + s)) (define (class-info c) (unless (class? c) @@ -4353,21 +4425,29 @@ An example (raise-argument-error 'object->vector "object?" in-o)) (let ([o in-o]) (list->vector - (cons - (string->symbol (format "object:~a" (class-name (object-ref/unwrap o)))) - (reverse - (let-values ([(c skipped?) (object-info o)]) - (let loop ([c c] - [skipped? skipped?]) - (cond - [(not c) (if skipped? (list opaque-v) null)] - [else - (let-values ([(name num-fields field-ids field-ref field-set next next-skipped?) - (class-info c)]) - (let ([rest (loop next next-skipped?)] - [here (let loop ([n num-fields]) - (if (zero? n) null (cons (field-ref o (sub1 n)) (loop (sub1 n)))))]) - (append (if skipped? (list opaque-v) null) here rest)))]))))))))) + (cons (string->symbol (format "object:~a" (class-name (object-ref/unwrap o)))) + (reverse + (let-values ([(c skipped?) (object-info o)]) + (let loop ([c c] + [skipped? skipped?]) + (cond + [(not c) + (if skipped? + (list opaque-v) + null)] + [else + (let-values ([(name num-fields field-ids field-ref field-set next next-skipped?) + (class-info c)]) + (let ([rest (loop next next-skipped?)] + [here (let loop ([n num-fields]) + (if (zero? n) + null + (cons (field-ref o (sub1 n)) (loop (sub1 n)))))]) + (append (if skipped? + (list opaque-v) + null) + here + rest)))]))))))))) (define (object=? o1 o2) (cond @@ -4387,8 +4467,14 @@ An example (eq? (object=-original-object o1) (object=-original-object o2))) (define (object=-original-object o) - (define orig-o (if (has-original-object? o) (original-object o) o)) - (define orig-orig-o (if (wrapped-object? orig-o) (wrapped-object-object orig-o) orig-o)) + (define orig-o + (if (has-original-object? o) + (original-object o) + o)) + (define orig-orig-o + (if (wrapped-object? orig-o) + (wrapped-object-object orig-o) + orig-o)) orig-orig-o) (define (object=-hash-code o) @@ -4458,7 +4544,12 @@ An example ; #f => init args by position only ; sym => required arg ; sym--value list => optional arg - (and init-arg-names (map (lambda (s) (if (symbol? s) s (car s))) init-arg-names)) + (and init-arg-names + (map (lambda (s) + (if (symbol? s) + s + (car s))) + init-arg-names)) 'stop (lambda ignored (values @@ -4466,10 +4557,11 @@ An example override-methods null ; no augride-methods (lambda (this super-go/ignored si_c/ignored si_inited?/ignored si_leftovers/ignored init-args) - (apply - prim-init - this - (if init-arg-names (extract-primitive-args this name init-arg-names init-args) init-args))))) + (apply prim-init + this + (if init-arg-names + (extract-primitive-args this name init-arg-names init-args) + init-args))))) #f make-struct:prim)) @@ -4483,7 +4575,9 @@ An example null] [else (let* ([name (car names)] - [id (if (symbol? name) name (car name))]) + [id (if (symbol? name) + name + (car name))]) (let ([arg (assq id args)]) (cond [arg (cons (cdr arg) (loop (cdr names) (remq arg args)))] @@ -4566,8 +4660,12 @@ An example . fields) (define all-fields (append fields - (if class-name (list (string-append which-class "class name") (as-write class-name)) null) - (if intf-name (list "interface name" (as-write intf-name)) null))) + (if class-name + (list (string-append which-class "class name") (as-write class-name)) + null) + (if intf-name + (list "interface name" (as-write intf-name)) + null))) (raise (make-exn:fail:object (format "~a: ~a~a" @@ -4597,11 +4695,17 @@ An example (current-continuation-marks)))) (define (for-class name) - (if name (format " for class: ~a" name) "")) + (if name + (format " for class: ~a" name) + "")) (define (for-class/which which name) - (if name (format " for ~a class: ~a" which name) "")) + (if name + (format " for ~a class: ~a" which name) + "")) (define (for-intf name) - (if name (format " for interface: ~a" name) "")) + (if name + (format " for interface: ~a" name) + "")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; @@ -4768,7 +4872,9 @@ An example (interface* () ([prop:custom-write (lambda (obj port mode) - (if mode (send obj custom-write port) (send obj custom-display port)))]) + (if mode + (send obj custom-write port) + (send obj custom-display port)))]) custom-write custom-display)) diff --git a/tests/benchmarks/hash.rkt.out b/tests/benchmarks/hash.rkt.out index 60d0dba..0e88d99 100644 --- a/tests/benchmarks/hash.rkt.out +++ b/tests/benchmarks/hash.rkt.out @@ -6,12 +6,17 @@ (define (merge one two combine/key) (for/fold ([one one]) ([(k v) (in-hash two)]) - (hash-set one k (if (hash-has-key? one k) (combine/key k (hash-ref one k) v) v)))) + (hash-set one + k + (if (hash-has-key? one k) + (combine/key k (hash-ref one k) v) + v)))) (define (hash-union #:combine [combine #f] - #:combine/key - [combine/key - (if combine (lambda (_ x y) (combine x y)) (hash-duplicate-error 'hash-union))] + #:combine/key [combine/key + (if combine + (lambda (_ x y) (combine x y)) + (hash-duplicate-error 'hash-union))] one . rest) (define one-empty (hash-clear one)) @@ -24,21 +29,27 @@ [else (merge one two combine/key)]))) (define (hash-union! #:combine [combine #f] - #:combine/key - [combine/key - (if combine (lambda (_ x y) (combine x y)) (hash-duplicate-error 'hash-union!))] + #:combine/key [combine/key + (if combine + (lambda (_ x y) (combine x y)) + (hash-duplicate-error 'hash-union!))] one . rest) (for* ([two (in-list rest)] [(k v) (in-hash two)]) - (hash-set! one k (if (hash-has-key? one k) (combine/key k (hash-ref one k) v) v)))) + (hash-set! one + k + (if (hash-has-key? one k) + (combine/key k (hash-ref one k) v) + v)))) -(define (hash-intersect - #:combine [combine #f] - #:combine/key - [combine/key (if combine (λ (_ x y) (combine x y)) (hash-duplicate-error 'hash-intersect))] - one - . rest) +(define (hash-intersect #:combine [combine #f] + #:combine/key [combine/key + (if combine + (λ (_ x y) (combine x y)) + (hash-duplicate-error 'hash-intersect))] + one + . rest) (define hashes (cons one rest)) (define empty-h (hash-clear one)) ;; empty hash of same type as one (define (argmin f lst) ;; avoid racket/list to improve loading time @@ -47,7 +58,9 @@ #:result best) ([x (in-list lst)]) (define fx (f x)) - (if (< fx fbest) (values x fx) (values best fbest)))) + (if (< fx fbest) + (values x fx) + (values best fbest)))) (for/fold ([res empty-h]) ([k (in-hash-keys (argmin hash-count hashes))]) (if (for/and ([h (in-list hashes)]) (hash-has-key? h k)) diff --git a/tests/benchmarks/list.rkt.out b/tests/benchmarks/list.rkt.out index cb4576a..067092d 100644 --- a/tests/benchmarks/list.rkt.out +++ b/tests/benchmarks/list.rkt.out @@ -89,7 +89,9 @@ (let loop ([l l0] [pos npos]) (if (pair? l) - (if (eq? pos 1) (car l) (loop (cdr l) (sub1 pos))) + (if (eq? pos 1) + (car l) + (loop (cdr l) (sub1 pos))) (raise-arguments-error 'name "list contains too few elements" "list" l0))) (raise-argument-error 'name "list?" l0)))])) (define-lgetter second 2) @@ -106,14 +108,18 @@ (if (pair? l) (let loop ([l l] [x (cdr l)]) - (if (pair? x) (loop x (cdr x)) l)) + (if (pair? x) + (loop x (cdr x)) + l)) (raise-argument-error 'last-pair "pair?" l))) (define (last l) (if (and (pair? l) (list? l)) (let loop ([l l] [x (cdr l)]) - (if (pair? x) (loop x (cdr x)) (car l))) + (if (pair? x) + (loop x (cdr x)) + (car l))) (raise-argument-error 'last "(and/c list? (not/c empty?))" l))) (define (rest l) @@ -128,7 +134,9 @@ (raise-argument-error 'make-list "exact-nonnegative-integer?" 0 n x)) (let loop ([n n] [r '()]) - (if (zero? n) r (loop (sub1 n) (cons x r))))) + (if (zero? n) + r + (loop (sub1 n) (cons x r))))) (define (list-update l i f) (unless (list? l) @@ -150,7 +158,9 @@ ;; internal use below (define (drop* list n) ; no error checking, returns #f if index is too large - (if (zero? n) list (and (pair? list) (drop* (cdr list) (sub1 n))))) + (if (zero? n) + list + (and (pair? list) (drop* (cdr list) (sub1 n))))) (define (too-large who list n) (define proper? (list? list)) (raise-argument-error who @@ -192,7 +202,10 @@ (raise-argument-error 'takef "procedure?" 1 list pred)) (let loop ([list list]) (if (pair? list) - (let ([x (car list)]) (if (pred x) (cons x (loop (cdr list))) '())) + (let ([x (car list)]) + (if (pred x) + (cons x (loop (cdr list))) + '())) ;; could return `list' here, but make it behave like `take' ;; example: (takef '(a b c . d) symbol?) should be similar ;; to (take '(a b c . d) 3) @@ -202,7 +215,9 @@ (unless (procedure? pred) (raise-argument-error 'dropf "procedure?" 1 list pred)) (let loop ([list list]) - (if (and (pair? list) (pred (car list))) (loop (cdr list)) list))) + (if (and (pair? list) (pred (car list))) + (loop (cdr list)) + list))) (define (splitf-at list pred) (unless (procedure? pred) @@ -221,7 +236,9 @@ (let loop ([list list] [lead (or (drop* list n) (too-large 'take-right list n))]) ;; could throw an error for non-lists, but be more like `take' - (if (pair? lead) (loop (cdr list) (cdr lead)) list))) + (if (pair? lead) + (loop (cdr list) (cdr lead)) + list))) (define (drop-right list n) (unless (exact-nonnegative-integer? n) @@ -229,7 +246,9 @@ (let loop ([list list] [lead (or (drop* list n) (too-large 'drop-right list n))]) ;; could throw an error for non-lists, but be more like `drop' - (if (pair? lead) (cons (car list) (loop (cdr list) (cdr lead))) '()))) + (if (pair? lead) + (cons (car list) (loop (cdr list) (cdr lead))) + '()))) (define (split-at-right list n) (unless (exact-nonnegative-integer? n) @@ -238,7 +257,9 @@ [lead (or (drop* list n) (too-large 'split-at-right list n))] [pfx '()]) ;; could throw an error for non-lists, but be more like `split-at' - (if (pair? lead) (loop (cdr list) (cdr lead) (cons (car list) pfx)) (values (reverse pfx) list)))) + (if (pair? lead) + (loop (cdr list) (cdr lead) (cons (car list) pfx)) + (values (reverse pfx) list)))) ;; For just `takef-right', it's possible to do something smart that ;; scans the list in order, keeping a pointer to the beginning of the @@ -265,7 +286,9 @@ (loop (cdr list) (cons (car list) rev) (add1 n)) (let loop ([n n] [list rev]) - (if (and (pair? list) (pred (car list))) (loop (sub1 n) (cdr list)) n))))) + (if (and (pair? list) (pred (car list))) + (loop (sub1 n) (cdr list)) + n))))) (define (takef-right list pred) (drop list (count-from-right 'takef-right list pred))) @@ -371,7 +394,10 @@ (check-not-given before-first "#:before-first") (check-not-given after-last "#:after-last")]) (cond - [(or (null? l) (null? (cdr l))) (if splice? (append before-first l after-last) l)] + [(or (null? l) (null? (cdr l))) + (if splice? + (append before-first l after-last) + l)] ;; two cases for efficiency, maybe not needed [splice? (let* ([x (reverse x)] @@ -452,7 +478,9 @@ (begin (hash-set! h k #t) (cons x (loop l)))))))])]) - (if key (loop key) (loop no-key)))]))) + (if key + (loop key) + (loop no-key)))]))) ;; check-duplicates : (listof X) ;; [(K K -> bool)] @@ -466,7 +494,9 @@ (raise-argument-error 'check-duplicates "list?" 0 items)) (unless (and (procedure? key) (procedure-arity-includes? key 1)) (raise-argument-error 'check-duplicates "(-> any/c any/c)" key)) - (let ([fail-k (if (procedure? failure-result) failure-result (λ () failure-result))]) + (let ([fail-k (if (procedure? failure-result) + failure-result + (λ () failure-result))]) (cond [(eq? same? equal?) (check-duplicates/t items key (make-hash) fail-k)] [(eq? same? eq?) (check-duplicates/t items key (make-hasheq) fail-k)] @@ -532,10 +562,17 @@ (if (null? l) null (let ([x (apply f (car l) (map car ls))]) - (if x (cons x (loop (cdr l) (map cdr ls))) (loop (cdr l) (map cdr ls)))))) + (if x + (cons x (loop (cdr l) (map cdr ls))) + (loop (cdr l) (map cdr ls)))))) (raise-arguments-error 'filter-map "all lists must have same size"))) (let loop ([l l]) - (if (null? l) null (let ([x (f (car l))]) (if x (cons x (loop (cdr l))) (loop (cdr l)))))))) + (if (null? l) + null + (let ([x (f (car l))]) + (if x + (cons x (loop (cdr l))) + (loop (cdr l)))))))) ;; very similar to `filter-map', one more such function will justify some macro (define (count f l . ls) @@ -548,11 +585,20 @@ [c 0]) (if (null? l) c - (loop (cdr l) (map cdr ls) (if (apply f (car l) (map car ls)) (add1 c) c)))) + (loop (cdr l) + (map cdr ls) + (if (apply f (car l) (map car ls)) + (add1 c) + c)))) (raise-arguments-error 'count "all lists must have same size"))) (let loop ([l l] [c 0]) - (if (null? l) c (loop (cdr l) (if (f (car l)) (add1 c) c)))))) + (if (null? l) + c + (loop (cdr l) + (if (f (car l)) + (add1 c) + c)))))) ;; Originally from srfi-1 -- shares common tail with the input when possible ;; (define (partition f l) @@ -581,7 +627,9 @@ (values (reverse i) (reverse o)) (let ([x (car l)] [l (cdr l)]) - (if (pred x) (loop l (cons x i) o) (loop l i (cons x o))))))) + (if (pred x) + (loop l (cons x i) o) + (loop l i (cons x o))))))) ;; similar to in-range, but returns a list (define range-proc @@ -647,7 +695,12 @@ ;; faster than a plain loop (let loop ([l list] [result null]) - (if (null? l) (reverse result) (loop (cdr l) (if (f (car l)) result (cons (car l) result)))))) + (if (null? l) + (reverse result) + (loop (cdr l) + (if (f (car l)) + result + (cons (car l) result)))))) ;; Fisher-Yates Shuffle (define (shuffle l) @@ -689,7 +742,9 @@ (let ([curr (unbox curr-box)]) (if (< curr limit) (begin0 (for/fold ([acc '()]) ([i (in-range N-1 -1 -1)]) - (if (bitwise-bit-set? curr i) (cons (vector-ref v i) acc) acc)) + (if (bitwise-bit-set? curr i) + (cons (vector-ref v i) acc) + acc)) (set-box! curr-box (+ curr 1))) #f)))] [(< N k) (lambda () #f)] diff --git a/tests/benchmarks/xform.rkt.out b/tests/benchmarks/xform.rkt.out index 5482eb0..1e11c5c 100644 --- a/tests/benchmarks/xform.rkt.out +++ b/tests/benchmarks/xform.rkt.out @@ -71,9 +71,13 @@ ;; For very long lists, it's worth the effort to use a vector instead ;; of a list to save space: (define (seq->list s) - (if (vector? s) (vector->list s) s)) + (if (vector? s) + (vector->list s) + s)) (define (list->seq s) - (if (or (null? s) (null? (cdr s)) (null? (cddr s))) s (list->vector s))) + (if (or (null? s) (null? (cdr s)) (null? (cddr s))) + s + (list->vector s))) (define seqce vector) ;; A cheap way of getting rid of unneeded prototypes: @@ -96,7 +100,9 @@ (hash-set! used-symbols v (add1 (hash-ref used-symbols v (lambda () 0))))) (when (and src output-depends-info?) (hash-set! depends-files src #t)) - (if sysheader? (make-sysheader-tok v line src) (make-tok v line src))) + (if sysheader? + (make-sysheader-tok v line src) + (make-tok v line src))) (define (make-a-seq opener src line body) ((case opener @@ -161,7 +167,9 @@ (define (line-comment s p) (let loop ([p (add1 p)]) (let ([c (bytes-ref s p)]) - (if (or (equal? c 10) (equal? c 13)) (add1 p) (loop (add1 p)))))) + (if (or (equal? c 10) (equal? c 13)) + (add1 p) + (loop (add1 p)))))) (define re:line #rx#"^#[^\n\r]* ([0-9]+) \"([^\"]*)\"([^\r\n]*)") (define re:pragma #rx#"^#pragma ([^\r\n]*)") @@ -367,7 +375,9 @@ (define (read-all p) (let loop ([l null]) (let ([s (read-bytes 4096 p)]) - (if (eof-object? s) (apply bytes-append (reverse l)) (loop (cons s l)))))) + (if (eof-object? s) + (apply bytes-append (reverse l)) + (loop (cons s l)))))) (define (tokenize) (let* ([s (read-all (current-input-port))] @@ -383,7 +393,9 @@ [(char-whitespace? (integer->char char)) (loop (add1 p) result)] [(eq? char (char->integer #\#)) ;; We assume only #-based preprocessor left (let-values ([(pragma p) (do-cpp s p)]) - (if pragma (loop p (cons pragma result)) (loop p result)))] + (if pragma + (loop p (cons pragma result)) + (loop p result)))] [else (let ([simple (let ([sl (vector-ref simple-table char)]) @@ -472,7 +484,10 @@ [start 0] [quoted? #f]) (cond - [(= i (string-length s)) (if (= i start) '() (list (substring s start i)))] + [(= i (string-length s)) + (if (= i start) + '() + (list (substring s start i)))] [(and (not quoted?) (char=? #\space (string-ref s i))) (if (= i start) (loop (+ i 1) (+ i 1) #f) @@ -516,16 +531,21 @@ (define cpp-process (if (string? cpp) - (process2 - (format "~a~a~a" - cpp - (if pgc? (if pgc-really? " -DMZ_XFORM -DMZ_PRECISE_GC" " -DMZ_XFORM") "") - (if callee-restore? " -DGC_STACK_CALLEE_RESTORE" "")) - file-in) + (process2 (format "~a~a~a" + cpp + (if pgc? + (if pgc-really? " -DMZ_XFORM -DMZ_PRECISE_GC" " -DMZ_XFORM") + "") + (if callee-restore? " -DGC_STACK_CALLEE_RESTORE" "")) + file-in) (apply (verbose process*) (append cpp - (if pgc-really? '("-DMZ_XFORM" "-DMZ_PRECISE_GC") '("-DMZ_XFORM")) - (if callee-restore? '("-DGC_STACK_CALLEE_RESTORE") null) + (if pgc-really? + '("-DMZ_XFORM" "-DMZ_PRECISE_GC") + '("-DMZ_XFORM")) + (if callee-restore? + '("-DGC_STACK_CALLEE_RESTORE") + null) (list file-in))))) (close-output-port (cadr cpp-process)) @@ -647,7 +667,10 @@ (define log-warning log-error) - (define map-port (if palm-out (open-output-file palm-out #:exists 'truncate) #f)) + (define map-port + (if palm-out + (open-output-file palm-out #:exists 'truncate) + #f)) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Output common defns @@ -1504,10 +1527,16 @@ (values old-line old-file old-sysheader?) (let* ([v (car e)] [sv (extract-src-tok v)] - [line (if keep-lines? (or (and sv (tok-line sv)) old-line) old-line)] - [file (if keep-lines? (or (and sv (tok-file sv)) old-file) old-file)] + [line (if keep-lines? + (or (and sv (tok-line sv)) old-line) + old-line)] + [file (if keep-lines? + (or (and sv (tok-file sv)) old-file) + old-file)] [sysheader? (if keep-lines? - (if (and sv (tok-file sv)) (sysheader-tok? sv) old-sysheader?) + (if (and sv (tok-file sv)) + (sysheader-tok? sv) + old-sysheader?) old-sysheader?)] [inc-line! (lambda () (set! line (add1 line)))]) (when keep-lines? @@ -1538,7 +1567,10 @@ (parens? (car l)) (let ([l (seq->list (seq-in (car l)))]) (not (ormap (lambda (i) (eq? '= (tok-n i))) l))))))) - (display/indent v (if skip-parens? "" (tok-n v))) + (display/indent v + (if skip-parens? + "" + (tok-n v))) (let ([subindent (if (braces? v) (begin (newline/indent (+ indent 2)) @@ -1620,7 +1652,9 @@ (format "+~a_COUNT" (block-push-super-tag v)) "")] [tag (block-push-tag v)] - [tabbing (if (zero? indent) "" (make-string (sub1 indent) #\space))]) + [tabbing (if (zero? indent) + "" + (make-string (sub1 indent) #\space))]) (unless (zero? size) (display/indent v (format "BLOCK_SETUP~a((" @@ -1640,7 +1674,9 @@ (newline/indent indent) (inc-line!))] [(nested-setup? v) - (let ([tabbing (if (zero? indent) "" (make-string (sub1 indent) #\space))]) + (let ([tabbing (if (zero? indent) + "" + (make-string (sub1 indent) #\space))]) (case (tok-n v) [(nested) (printf "#~adefine BLOCK_SETUP(x) BLOCK_SETUP_each(x)\n" tabbing) @@ -1845,7 +1881,9 @@ (if (or precompiling-header? (> (hash-ref used-symbols name) 1) (ormap (lambda (v) (eq? (tok-n v) 'virtual)) e)) ; can't drop virtual methods! - (if palm? (add-segment-label name e) (clean-proto e)) + (if palm? + (add-segment-label name e) + (clean-proto e)) null))] [(struct-decl? e) (let ([e (skip-declspec-align e)]) @@ -2033,7 +2071,9 @@ (let ([once (lambda (s) (and (not precompiling-header?) (= 1 (hash-ref used-symbols (tok-n s)))))] [seps (list '|,| '* semi)]) - (let ([e (if (eq? '__extension__ (car e)) (cdr e) e)]) + (let ([e (if (eq? '__extension__ (car e)) + (cdr e) + e)]) (and (eq? (tok-n (cadr e)) 'struct) (symbol? (tok-n (caddr e))) @@ -2061,7 +2101,9 @@ e))) (define (skip-compiler-pragmas e) - (if (compiler-pragma? e) (skip-compiler-pragmas (cddr e)) e)) + (if (compiler-pragma? e) + (skip-compiler-pragmas (cddr e)) + e)) (define (struct-decl? e) (let ([e (skip-declspec-align e)]) @@ -2075,7 +2117,9 @@ (let ([l (length e)]) (and (> l 2) (let* ([_n (tok-n (list-ref e (sub1 l)))] - [ll (if (eq? _n semi) (- l 2) (sub1 l))]) + [ll (if (eq? _n semi) + (- l 2) + (sub1 l))]) (let ([v (list-ref e ll)]) (and (braces? v) (let ([v (list-ref e (sub1 ll))]) @@ -2139,7 +2183,9 @@ [(eq? '__attribute__ (tok-n (car e))) (loop (cddr e) type)] [(parens? (cadr e)) (let ([name (tok-n (let ([p (car e)]) - (if (parens? p) (car (seq->list (seq-in p))) p)))] + (if (parens? p) + (car (seq->list (seq-in p))) + p)))] [type (let loop ([t (reverse type)]) (if (pair? t) (if (or (memq (tok-n (car t)) @@ -2399,8 +2445,12 @@ ;; e is a struct decl; parse it an remember the results (define (register-struct e) - (let ([body (seq->list (seq-in (if (braces? (cadr e)) (cadr e) (caddr e))))] - [name (if (braces? (cadr e)) (gensym 'Anonymous) (tok-n (cadr e)))]) + (let ([body (seq->list (seq-in (if (braces? (cadr e)) + (cadr e) + (caddr e))))] + [name (if (braces? (cadr e)) + (gensym 'Anonymous) + (tok-n (cadr e)))]) (let ([l (get-pointer-vars-from-seq body "PTRFIELD" #f)]) (and (not (null? l)) (begin @@ -2432,7 +2482,9 @@ [(and (pointer-type? x) (pointer-type-base x)) (append (map (lambda (x) (make-tok x #f #f)) (pointer-type-base x)) (let loop ([n (pointer-type-stars x)]) - (if (zero? n) null (cons (make-tok '* #f #f) (loop (sub1 n))))))] + (if (zero? n) + null + (cons (make-tok '* #f #f) (loop (sub1 n))))))] [else (log-error "[TYPE] ~a in ~a: Can't render type declaration for ~a" (tok-line where-v) @@ -2456,7 +2508,9 @@ "Confused by form of class declaration at line ~a in ~a" (tok-line (car e)) (tok-file (car e)))) - (let* ([super (if (> body-pos 2) (tok-n (list-ref e (sub1 body-pos))) #f)] + (let* ([super (if (> body-pos 2) + (tok-n (list-ref e (sub1 body-pos))) + #f)] [cl (make-c++-class super (if (or super (eq? name 'gc)) super 'gc) null null)] [pt (prototyped)] [vs (top-vars)]) @@ -2631,55 +2685,57 @@ ;; to register locals with the GC. Do a little special work ;; for constructors, detected by a '|:| outside the body. (define (convert-function e name) - (let*-values - ([(body-v len) (let* ([len (sub1 (length e))] - [v (list-ref e len)]) - ;; Function may have trailing semicolon: - (if (eq? semi (tok-n v)) - (values (list-ref e (sub1 len)) (sub1 len)) - (values v len)))] - [(assert-no-conversion?) (eq? (tok-n (list-ref e (sub1 len))) - 'XFORM_ASSERT_NO_CONVERSION)] - [(body-e) (seq->list (seq-in body-v))] - [(class-name function-name func-pos) - (let loop ([e e] - [p 0]) - (cond - [(null? e) (values #f #f #f)] - [(null? (cdr e)) (values #f #f #f)] - [(eq? '|::| (tok-n (cadr e))) (values (tok-n (car e)) (tok-n (caddr e)) (+ p 2))] - [else (loop (cdr e) (add1 p))]))] - [(args-e) (seq->list - (seq-in (list-ref e - (if (and func-pos (eq? class-name function-name)) - (add1 func-pos) - (if assert-no-conversion? (- len 2) (sub1 len))))))] - [(arg-vars all-arg-vars) - (let-values ([(arg-pragmas arg-decls) - (body->lines (append args-e (list (make-tok '|,| #f #f))) #t)]) - (unless (null? arg-pragmas) - (error 'arg-decls "unexpected pragmas")) - (let loop ([l arg-decls] - [arg-vars null] - [all-arg-vars null]) - (if (null? l) - (values arg-vars all-arg-vars) - (let-values ([(ptrs non-ptrs) (get-vars (car l) "PTRARG" #f #t)]) - (loop (cdr l) - (append arg-vars ptrs) - (append all-arg-vars ptrs non-ptrs))))))] - [(c++-class) (let ([c++-class (find-c++-class class-name #t)]) - (and c++-class - (or (get-c++-class-method function-name c++-class) - (eq? function-name class-name) - (eq? function-name '~)) - c++-class))] - [(initializers) (let loop ([e e] - [len len]) - (cond - [(zero? len) #f] - [(eq? (tok-n (car e)) '|:|) (cons (cadr e) (caddr e))] - [else (loop (cdr e) (sub1 len))]))]) + (let*-values ([(body-v len) (let* ([len (sub1 (length e))] + [v (list-ref e len)]) + ;; Function may have trailing semicolon: + (if (eq? semi (tok-n v)) + (values (list-ref e (sub1 len)) (sub1 len)) + (values v len)))] + [(assert-no-conversion?) (eq? (tok-n (list-ref e (sub1 len))) + 'XFORM_ASSERT_NO_CONVERSION)] + [(body-e) (seq->list (seq-in body-v))] + [(class-name function-name func-pos) + (let loop ([e e] + [p 0]) + (cond + [(null? e) (values #f #f #f)] + [(null? (cdr e)) (values #f #f #f)] + [(eq? '|::| (tok-n (cadr e))) + (values (tok-n (car e)) (tok-n (caddr e)) (+ p 2))] + [else (loop (cdr e) (add1 p))]))] + [(args-e) (seq->list + (seq-in (list-ref e + (if (and func-pos (eq? class-name function-name)) + (add1 func-pos) + (if assert-no-conversion? + (- len 2) + (sub1 len))))))] + [(arg-vars all-arg-vars) + (let-values ([(arg-pragmas arg-decls) + (body->lines (append args-e (list (make-tok '|,| #f #f))) #t)]) + (unless (null? arg-pragmas) + (error 'arg-decls "unexpected pragmas")) + (let loop ([l arg-decls] + [arg-vars null] + [all-arg-vars null]) + (if (null? l) + (values arg-vars all-arg-vars) + (let-values ([(ptrs non-ptrs) (get-vars (car l) "PTRARG" #f #t)]) + (loop (cdr l) + (append arg-vars ptrs) + (append all-arg-vars ptrs non-ptrs))))))] + [(c++-class) (let ([c++-class (find-c++-class class-name #t)]) + (and c++-class + (or (get-c++-class-method function-name c++-class) + (eq? function-name class-name) + (eq? function-name '~)) + c++-class))] + [(initializers) (let loop ([e e] + [len len]) + (cond + [(zero? len) #f] + [(eq? (tok-n (car e)) '|:|) (cons (cadr e) (caddr e))] + [else (loop (cdr e) (sub1 len))]))]) (append ;; Build all of the function declaration up to the body: (let loop ([e e] @@ -2931,24 +2987,25 @@ (unless (assq (tok-n (cadr e)) (unbox new-vars-box)) (set-box! new-vars-box (cons (cons (tok-n (cadr e)) new-var) (unbox new-vars-box)))) - (loop (list* - (make-creation-parens - "(" - line - file - ")" - (seqce (make-tok new-var line file) - (make-tok '= line file) - (make-tok NEW_OBJ line file) - (make-parens "(" line file ")" (seqce (cadr e))) - (make-tok '|,| line file) - (make-tok new-var line file) - (make-tok '-> line file) - (make-gc-init-tok (tok-n (cadr e))) - (if args? (caddr e) (make-parens "(" line file ")" (seqce))) - (make-tok '|,| line file) - (make-tok new-var line file))) - ((if args? cdddr cddr) e)) + (loop (list* (make-creation-parens + "(" + line + file + ")" + (seqce (make-tok new-var line file) + (make-tok '= line file) + (make-tok NEW_OBJ line file) + (make-parens "(" line file ")" (seqce (cadr e))) + (make-tok '|,| line file) + (make-tok new-var line file) + (make-tok '-> line file) + (make-gc-init-tok (tok-n (cadr e))) + (if args? + (caddr e) + (make-parens "(" line file ")" (seqce))) + (make-tok '|,| line file) + (make-tok new-var line file))) + ((if args? cdddr cddr) e)) #t paren-arrows?))] [else @@ -3098,7 +3155,10 @@ (let*-values ([(end?) (memq (tok-n (caar body)) '(END_XFORM_SKIP XFORM_START_SKIP))] [(rest live-vars) ((if end? loop skip-loop) (cdr body))]) - (values (if end? rest (cons (car body) rest)) live-vars)))] + (values (if end? + rest + (cons (car body) rest)) + live-vars)))] [(eq? (tok-n (caar body)) XFORM_RESET_VAR_STACK) (let-values ([(rest live-vars) (loop (cdr body))]) (values (cons (car body) rest) live-vars))] @@ -3223,7 +3283,9 @@ orig-tag setup-stack-return-type))) (if setup-stack-return-type - (if once? (list no-nested-pushable) (list nested-pushable)) + (if once? + (list no-nested-pushable) + (list nested-pushable)) null)))) ;; Null out local vars: (map @@ -3401,7 +3463,9 @@ (let ([seql (seq->list (seq-in v))]) (= 3 (length seql)) (eq? '-> (tok-n (cadr seql))) - (if (parens? (car seql)) (extract-resolvable-record-var (car seql)) (car seql))))) + (if (parens? (car seql)) + (extract-resolvable-record-var (car seql)) + (car seql))))) ;; Found a sequance of argument expressions where function calls ;; are not allowed. Lift out the calls, inventing temporary variables @@ -3424,7 +3488,9 @@ ([lift-one? (lambda (e) (let ([e- (let ([e- (reverse e)]) - (if (null? (cdr el)) e- (cdr e-)))]) ; skip comma + (if (null? (cdr el)) + e- + (cdr e-)))]) ; skip comma (and (looks-like-call? e- #f) (cast-or-call e- @@ -3496,7 +3562,9 @@ (cons (wrap e) new-args) setups new-vars - (if must-convert? ok-calls (cons call-args ok-calls)) + (if must-convert? + ok-calls + (cons call-args ok-calls)) #t live-vars))))] [lift-in-arithmetic? @@ -3536,7 +3604,9 @@ (lambda (wrap) (k (lambda (x) (wrap (list* (car e) (cadr e) x)))))))] ;; look for: op n - [(let ([len (if (null? el) (length e) (sub1 (length e)))]) ; skip comma + [(let ([len (if (null? el) + (length e) + (sub1 (length e)))]) ; skip comma (and (>= len 3) (let ([n (tok-n (list-ref e (sub1 len)))]) (or (number? n) (symbol? n))) @@ -3553,20 +3623,25 @@ #cs XFORM_TRUST_MINUS)))) (let* ([last? (null? el)] - [len (if last? (length e) (sub1 (length e)))]) + [len (if last? + (length e) + (sub1 (length e)))]) (let ([k (lift-in-arithmetic? (let loop ([e e]) (if (null? ((if last? cddr cdddr) e)) - (if last? null (cddr e)) + (if last? + null + (cddr e)) (cons (car e) (loop (cdr e))))))]) (and k (lambda (wrap) (k (lambda (x) - (wrap - (append - x - (list (list-ref e (- len 2)) (list-ref e (- len 1))) - (if last? (list (list-ref e len)) null)))))))))] + (wrap (append x + (list (list-ref e (- len 2)) + (list-ref e (- len 1))) + (if last? + (list (list-ref e len)) + null)))))))))] [(lift-one? e) => values] @@ -3665,20 +3740,22 @@ (if (null? l) (cons (make-tok RET_NOTHING (tok-line (car e-)) (tok-file (car e-))) result) - (let ([has-empty-funccall? - ;; All calls must be empty calls, otherwise - ;; the result might not depend on the empty call - ;; (e.g., f() && empty(f()) ) - (let loop ([l l] - [one? #f]) - (cond - [(null? l) one?] - [(call? (car l)) - (if (null? (call-live (car l))) (loop (cdr l) #t) #f)] - [(seq? (car l)) - (and (loop (seq->list (seq-in (car l))) one?) - (loop (cdr l) one?))] - [else #f]))]) + (let (;; All calls must be empty calls, otherwise + ;; the result might not depend on the empty call + ;; (e.g., f() && empty(f()) ) + [has-empty-funccall? (let loop ([l l] + [one? #f]) + (cond + [(null? l) one?] + [(call? (car l)) + (if (null? (call-live (car l))) + (loop (cdr l) #t) + #f)] + [(seq? (car l)) + (and (loop (seq->list (seq-in (car l))) + one?) + (loop (cdr l) one?))] + [else #f]))]) (list* (make-tok (if has-empty-funccall? RET_VALUE_EMPTY_START RET_VALUE_START) (tok-line (car e-)) @@ -3744,7 +3821,9 @@ "[CALL] ~a in ~a: Bad place for function call~a, starting tok is ~s." (tok-line (car func)) (tok-file (car func)) - (if (list? complain-not-in) "" (format " (in ~a)" complain-not-in)) + (if (list? complain-not-in) + "" + (format " (in ~a)" complain-not-in)) (tok-n (car func)))) ;; Lift out function calls as arguments. (Can re-order code. ;; Racket source code must live with this change to C's semantics.) @@ -3907,7 +3986,9 @@ (append new-pushed old-pushed)) (+ (if (or non-gcing-call? setjmp-call?) 0 1) (live-var-info-num-calls live-vars)) - (+ (if (or non-gcing-call? setjmp-call?) 0 (if non-returning? 1 0)) + (+ (if (or non-gcing-call? setjmp-call?) + 0 + (if non-returning? 1 0)) (live-var-info-num-noreturn-calls live-vars)) (+ (if (or non-gcing-call? non-returning? setjmp-call?) 0 @@ -4117,7 +4198,9 @@ (loop rest (append - (if extra (list extra) null) + (if extra + (list extra) + null) (list (make-braces (tok-n v) (tok-line v) (tok-file v) (seq-close v) (list->seq e))) result) @@ -4253,9 +4336,13 @@ [(symbol? (tok-n next)) next] [(seq? (tok-n next)) (let ([l (seq->list (seq-in next))]) - (if (null? l) #f (loop (car l))))] + (if (null? l) + #f + (loop (car l))))] [else #f]))]) - (if next (cons (tok-n next) (loop (cdr e))) (loop (cdr e)))))] + (if next + (cons (tok-n next) (loop (cdr e))) + (loop (cdr e)))))] [(seq? (car e)) (append (find-&-vars (seq->list (seq-in (car e)))) (loop (cdr e)))] [else (loop (cdr e))]))) @@ -4267,7 +4354,9 @@ (let ([body-v (let* ([len (sub1 (length e))] [v (list-ref e len)]) ;; Function may have trailing semicolon: - (if (eq? semi (tok-n v)) (list-ref e (sub1 len)) v))]) + (if (eq? semi (tok-n v)) + (list-ref e (sub1 len)) + v))]) (call-graph/body name (seq->list (seq-in body-v))))) (define (call-graph/body name body-e) @@ -4410,7 +4499,9 @@ e #f (lambda (sube where) - (let* ([where (if (pragma? (car sube)) where (or (tok-file (car sube)) where))] + (let* ([where (if (pragma? (car sube)) + where + (or (tok-file (car sube)) where))] [sube (top-level sube where #t)]) (let-values ([(l f s?) (print-it sube 0 #t #f line file sysheader? keep-lines?)]) (set! line l) diff --git a/tests/test-cases/large.rkt.out b/tests/test-cases/large.rkt.out index 7e1a549..1d34704 100644 --- a/tests/test-cases/large.rkt.out +++ b/tests/test-cases/large.rkt.out @@ -174,9 +174,10 @@ [(_ elem ...) ;; Set taint mode on elem ... (with-syntax ([internal-id internal-id] - [(elem ...) - (for/list ([e (in-list (syntax->list #'(elem ...)))]) - (if (identifier? e) e (syntax-property e 'taint-mode 'transparent)))]) + [(elem ...) (for/list ([e (in-list (syntax->list #'(elem ...)))]) + (if (identifier? e) + e + (syntax-property e 'taint-mode 'transparent)))]) (class-syntax-protect (syntax-property (syntax/loc stx (internal-id elem ...)) 'taint-mode @@ -490,7 +491,11 @@ ;; Put i in ((iid eid) optional-expr) form (cond [(identifier? i) (list (list i i))] - [else (let ([a (stx-car i)]) (if (identifier? a) (cons (list a a) (stx-cdr i)) i))])) + [else + (let ([a (stx-car i)]) + (if (identifier? a) + (cons (list a a) (stx-cdr i)) + i))])) (define ((norm-init/field-iid/def-ctx def-ctx) norm) (syntax-local-identifier-as-binding (stx-car (stx-car norm)) def-ctx)) @@ -619,8 +624,9 @@ (andmap identifier? (syntax->list (syntax (id ...))))) (let* ([letrec? (free-identifier=? (syntax let-) (quote-syntax letrec-values))] [ids (syntax->list (syntax (id ...)))] - [new-ids - (if xform? (map (lambda (id) (datum->syntax #f (gensym (syntax-e id)))) ids) ids)] + [new-ids (if xform? + (map (lambda (id) (datum->syntax #f (gensym (syntax-e id)))) ids) + ids)] [body-locals (append ids locals)] [exprs (map (lambda (expr id) (loop expr #t id (if letrec? body-locals locals))) (syntax->list (syntax (expr ...))) @@ -733,7 +739,9 @@ [class-name (if name-id (syntax-e name-id) (let ([s (syntax-local-infer-name stx)]) - (if (syntax? s) (syntax-e s) s)))]) + (if (syntax? s) + (syntax-e s) + s)))]) ;; ------ Basic syntax checks ----- (for-each @@ -1065,8 +1073,12 @@ (bound-identifier=? i (car ids))) local-public-names)]) (loop (cdr exprs) - (if public? (cons (cons (car ids) expr) ms) ms) - (if public? pms (cons (cons (car ids) expr) pms)) + (if public? + (cons (cons (car ids) expr) ms) + ms) + (if public? + pms + (cons (cons (car ids) expr) pms)) es sd))) ;; Non-method defn: @@ -1340,10 +1352,12 @@ [(local-field ...) (definify (append field-names private-field-names))] [(local-field-localized ...) (map lookup-localize (append field-names private-field-names))] - [(local-field-pos ...) - (let loop ([pos 0] - [l (append field-names private-field-names)]) - (if (null? l) null (cons pos (loop (add1 pos) (cdr l)))))] + [(local-field-pos ...) (let loop ([pos 0] + [l (append field-names + private-field-names)]) + (if (null? l) + null + (cons pos (loop (add1 pos) (cdr l)))))] [(local-field-accessor ...) (generate-temporaries (append field-names private-field-names))] [(local-field-mutator ...) @@ -2180,7 +2194,10 @@ last few projections. [no-method-changes? (and (null? public-names) (null? override-names) (null? augride-names) (null? final-names))] [no-new-fields? (null? public-field-names)] - [xappend (lambda (a b) (if (null? b) a (append a b)))]) + [xappend (lambda (a b) + (if (null? b) + a + (append a b)))]) ;; -- Check interfaces --- (for-each (lambda (intf) @@ -2202,8 +2219,12 @@ last few projections. #:class-name name))) ;; -- Match method and field names to indices -- - (let ([method-ht (if no-new-methods? (class-method-ht super) (hash-copy (class-method-ht super)))] - [field-ht (if no-new-fields? (class-field-ht super) (hash-copy (class-field-ht super)))] + (let ([method-ht (if no-new-methods? + (class-method-ht super) + (hash-copy (class-method-ht super)))] + [field-ht (if no-new-fields? + (class-field-ht super) + (hash-copy (class-field-ht super)))] [super-method-ht (class-method-ht super)] [super-method-ids (class-method-ids super)] [super-field-ids (class-field-ids super)] @@ -2317,7 +2338,9 @@ last few projections. #:class-name name))) ;; ---- Make the class and its interface ---- - (let* ([class-make (if name (make-naming-constructor struct:class name "class") make-class)] + (let* ([class-make (if name + (make-naming-constructor struct:class name "class") + make-class)] [interface-make (if name (make-naming-constructor struct:interface (string->symbol (format "interface:~a" @@ -2337,21 +2360,30 @@ last few projections. (make-immutable-hash) #f null)] - [methods (if no-method-changes? (class-methods super) (make-vector method-width))] - [super-methods - (if no-method-changes? (class-super-methods super) (make-vector method-width))] - [int-methods - (if no-method-changes? (class-int-methods super) (make-vector method-width))] - [beta-methods - (if no-method-changes? (class-beta-methods super) (make-vector method-width))] - [inner-projs - (if no-method-changes? (class-inner-projs super) (make-vector method-width))] - [dynamic-idxs - (if no-method-changes? (class-dynamic-idxs super) (make-vector method-width))] - [dynamic-projs - (if no-method-changes? (class-dynamic-projs super) (make-vector method-width))] - [meth-flags - (if no-method-changes? (class-meth-flags super) (make-vector method-width))] + [methods (if no-method-changes? + (class-methods super) + (make-vector method-width))] + [super-methods (if no-method-changes? + (class-super-methods super) + (make-vector method-width))] + [int-methods (if no-method-changes? + (class-int-methods super) + (make-vector method-width))] + [beta-methods (if no-method-changes? + (class-beta-methods super) + (make-vector method-width))] + [inner-projs (if no-method-changes? + (class-inner-projs super) + (make-vector method-width))] + [dynamic-idxs (if no-method-changes? + (class-dynamic-idxs super) + (make-vector method-width))] + [dynamic-projs (if no-method-changes? + (class-dynamic-projs super) + (make-vector method-width))] + [meth-flags (if no-method-changes? + (class-meth-flags super) + (make-vector method-width))] [c (class-make name (add1 (class-pos super)) (list->vector (append (vector->list (class-supers super)) (list #f))) @@ -2394,7 +2426,9 @@ last few projections. #f ; serializer is set later (or check-undef? (class-check-undef? super)) (and make-struct:prim #t))] - [obj-name (if name (string->symbol (format "object:~a" name)) 'object)] + [obj-name (if name + (string->symbol (format "object:~a" name)) + 'object)] ;; Used only for prim classes [preparer (lambda (name) ;; Map symbol to number: @@ -2423,7 +2457,9 @@ last few projections. (if (impersonator-prop:has-wrapped-class-neg-party? super) (let* ([the-info (impersonator-prop:get-wrapped-class-info super)] [oh (wrapped-class-info-neg-acceptors-ht the-info)]) - (if no-method-changes? oh (hash-copy oh))) + (if no-method-changes? + oh + (hash-copy oh))) #f)) ;; --- Make the new object struct --- @@ -2704,7 +2740,10 @@ last few projections. (define ictc-infos (get-interface-contract-info (class-self-interface c) id)) (define meth-entry (vector-ref methods index)) - (define meth (if (pair? meth-entry) (car meth-entry) meth-entry)) + (define meth + (if (pair? meth-entry) + (car meth-entry) + meth-entry)) (vector-set! methods index (list meth @@ -2911,7 +2950,9 @@ An example (cons (list our-ctc our-name #f our-name) ;; replace occurrences of #f positive blame with this interface (map (λ (info) - (if (not (caddr info)) (list (car info) (cadr info) our-name (cadddr info)) info)) + (if (not (caddr info)) + (list (car info) (cadr info) our-name (cadddr info)) + info)) dedup-infos))])) ;; infos bool blame -> infos @@ -3157,8 +3198,9 @@ An example (for-each (lambda (p v) (let ([g (gensym)]) (hash-set! prop-ht g (vector g p v)))) props vals) ;; Check for [conflicting] implementation requirements (let ([class (get-implement-requirement supers 'interface #:intf-name name)] - [interface-make - (if name (make-naming-constructor struct:interface name "interface") make-interface)]) + [interface-make (if name + (make-naming-constructor struct:interface name "interface") + make-interface)]) ;; Add supervars to table: (for-each (lambda (super) (for-each (lambda (var) (hash-set! ht var #t)) (interface-public-ids super))) @@ -3247,7 +3289,9 @@ An example (recur elem-a elem-b)))))))) (define (object-hash-code obj recur) (let ([vec (inspectable-struct->vector obj)]) - (if vec (recur (vector (object-ref obj) vec)) (eq-hash-code obj)))) + (if vec + (recur (vector (object-ref obj) vec)) + (eq-hash-code obj)))) (define object<%> ((make-naming-constructor struct:interface 'interface:object% #f) 'object% @@ -3375,7 +3419,9 @@ An example [(_ do-make-object orig-stx first? (maker-arg ...) args (kw arg) ...) (andmap identifier? (syntax->list (syntax (kw ...)))) (with-syntax ([(kw ...) (map localize (syntax->list (syntax (kw ...))))] - [(blame ...) (if (syntax-e #'first?) #'((current-contract-region)) null)]) + [(blame ...) (if (syntax-e #'first?) + #'((current-contract-region)) + null)]) (class-syntax-protect (syntax/loc stx (do-make-object blame ... maker-arg ... args (list (cons `kw arg) ...)))))] @@ -3412,10 +3458,14 @@ An example [ictc-meths (class-method-ictcs cls)] [method-width (class-method-width cls)] [method-ht (class-method-ht cls)] - [meths (if (null? ictc-meths) (class-methods cls) (make-vector method-width))] + [meths (if (null? ictc-meths) + (class-methods cls) + (make-vector method-width))] [field-pub-width (class-field-pub-width cls)] [field-ht (class-field-ht cls)] - [class-make (if name (make-naming-constructor struct:class name "class") make-class)] + [class-make (if name + (make-naming-constructor struct:class name "class") + make-class)] [c (class-make name (class-pos cls) (list->vector (vector->list (class-supers cls))) @@ -3454,7 +3504,9 @@ An example #f ; serializer is never set (class-check-undef? cls) #f)] - [obj-name (if name (string->symbol (format "wrapper-object:~a" name)) 'object)]) + [obj-name (if name + (string->symbol (format "wrapper-object:~a" name)) + 'object)]) (vector-set! (class-supers c) (class-pos c) c) @@ -3601,7 +3653,9 @@ An example (do-merge by-pos-args (class-init-args c) c named-args by-pos-args c) ;; Non-merge for by-position initializers by-pos-args)] - [leftovers (if (not by-pos-only?) (get-leftovers named-args (class-init-args c)) null)]) + [leftovers (if (not by-pos-only?) + (get-leftovers named-args (class-init-args c)) + null)]) ;; In 'list mode, make sure no by-name arguments are left over (when (eq? 'list (class-init-mode c)) (unless (or (null? leftovers) (not (ormap car leftovers))) @@ -3660,7 +3714,9 @@ An example ;; All unconsumed named-args must have #f ;; "name"s, otherwise an error is raised in ;; the leftovers checking. - (if (null? al) named-args (append (map (lambda (x) (cons #f x)) al) named-args))] + (if (null? al) + named-args + (append (map (lambda (x) (cons #f x)) al) named-args))] [else (obj-error 'instantiate "too many initialization arguments" @@ -3690,7 +3746,9 @@ An example [else (obj-error 'instantiate "too few initialization arguments")]))) (define (extract-rest-args skip arguments) - (if (< skip (length arguments)) (map cdr (list-tail arguments skip)) null)) + (if (< skip (length arguments)) + (map cdr (list-tail arguments skip)) + null)) (define (make-pos-arg-string args) (let ([len (length args)]) (apply string-append (map (lambda (a) (format " ~e" a)) args)))) @@ -3736,7 +3794,9 @@ An example (define kw-args/var (and kw-args (list (car kw-args) #'kw-arg-tmp))) (define arg-list '()) (define let-bindings '()) - (for ([x (in-list (if (list? args) args (syntax->list args)))]) + (for ([x (in-list (if (list? args) + args + (syntax->list args)))]) (cond [(keyword? (syntax-e x)) (set! arg-list (cons x arg-list))] [else @@ -3751,7 +3811,9 @@ An example (let*-values ([(sym) (quasiquote (unsyntax (localize name)))] [(receiver) (unsyntax obj)] [(method) (find-method/who '(unsyntax form) receiver sym)]) - (let (#,@(if kw-args (list #`[kw-arg-tmp #,(cadr kw-args)]) (list)) + (let (#,@(if kw-args + (list #`[kw-arg-tmp #,(cadr kw-args)]) + (list)) #,@let-bindings) (unsyntax (make-method-call-to-possibly-wrapped-object stx @@ -3777,7 +3839,9 @@ An example #'form #'obj #'name - (if kws? (cddr (syntax->list #'args)) #'args) + (if kws? + (cddr (syntax->list #'args)) + #'args) apply? (and kws? (let ([l (syntax->list #'args)]) (list (car l) (cadr l))))) (if apply? @@ -3867,7 +3931,9 @@ An example => (lambda (cls) (define mth-idx (hash-ref (class-method-ht cls) name #f)) - (if mth-idx (vector-ref (class-methods cls) mth-idx) (no-such-method who name cls)))] + (if mth-idx + (vector-ref (class-methods cls) mth-idx) + (no-such-method who name cls)))] [(wrapped-object? in-object) (define cls (let loop ([obj in-object]) @@ -4008,7 +4074,9 @@ An example [(_ object generic . args) (let* ([args-stx (syntax args)] [proper? (stx-list? args-stx)] - [flat-stx (if proper? args-stx (flatten-args args-stx))]) + [flat-stx (if proper? + args-stx + (flatten-args args-stx))]) (with-syntax ([(gen obj) (generate-temporaries (syntax (generic object)))]) (class-syntax-protect (quasisyntax/loc stx (let* ([obj object] @@ -4293,7 +4361,9 @@ An example (define (object-info o) (unless (object? o) (raise-argument-error 'object-info "object?" o)) - (let ([o* (if (has-original-object? o) (original-object o) o)]) + (let ([o* (if (has-original-object? o) + (original-object o) + o)]) (let loop ([c (object-ref/unwrap o*)] [skipped? #f]) (if (struct? ((class-insp-mk c))) @@ -4304,7 +4374,9 @@ An example (loop (vector-ref (class-supers c) (sub1 (class-pos c))) #t)))))) (define (to-sym s) - (if (string? s) (string->symbol s) s)) + (if (string? s) + (string->symbol s) + s)) (define (class-info c) (unless (class? c) @@ -4332,21 +4404,29 @@ An example (raise-argument-error 'object->vector "object?" in-o)) (let ([o in-o]) (list->vector - (cons - (string->symbol (format "object:~a" (class-name (object-ref/unwrap o)))) - (reverse - (let-values ([(c skipped?) (object-info o)]) - (let loop ([c c] - [skipped? skipped?]) - (cond - [(not c) (if skipped? (list opaque-v) null)] - [else - (let-values ([(name num-fields field-ids field-ref field-set next next-skipped?) - (class-info c)]) - (let ([rest (loop next next-skipped?)] - [here (let loop ([n num-fields]) - (if (zero? n) null (cons (field-ref o (sub1 n)) (loop (sub1 n)))))]) - (append (if skipped? (list opaque-v) null) here rest)))]))))))))) + (cons (string->symbol (format "object:~a" (class-name (object-ref/unwrap o)))) + (reverse + (let-values ([(c skipped?) (object-info o)]) + (let loop ([c c] + [skipped? skipped?]) + (cond + [(not c) + (if skipped? + (list opaque-v) + null)] + [else + (let-values ([(name num-fields field-ids field-ref field-set next next-skipped?) + (class-info c)]) + (let ([rest (loop next next-skipped?)] + [here (let loop ([n num-fields]) + (if (zero? n) + null + (cons (field-ref o (sub1 n)) (loop (sub1 n)))))]) + (append (if skipped? + (list opaque-v) + null) + here + rest)))]))))))))) (define (object=? o1 o2) (cond @@ -4366,8 +4446,14 @@ An example (eq? (object=-original-object o1) (object=-original-object o2))) (define (object=-original-object o) - (define orig-o (if (has-original-object? o) (original-object o) o)) - (define orig-orig-o (if (wrapped-object? orig-o) (wrapped-object-object orig-o) orig-o)) + (define orig-o + (if (has-original-object? o) + (original-object o) + o)) + (define orig-orig-o + (if (wrapped-object? orig-o) + (wrapped-object-object orig-o) + orig-o)) orig-orig-o) (define (object=-hash-code o) @@ -4437,7 +4523,12 @@ An example ; #f => init args by position only ; sym => required arg ; sym--value list => optional arg - (and init-arg-names (map (lambda (s) (if (symbol? s) s (car s))) init-arg-names)) + (and init-arg-names + (map (lambda (s) + (if (symbol? s) + s + (car s))) + init-arg-names)) 'stop (lambda ignored (values @@ -4445,10 +4536,11 @@ An example override-methods null ; no augride-methods (lambda (this super-go/ignored si_c/ignored si_inited?/ignored si_leftovers/ignored init-args) - (apply - prim-init - this - (if init-arg-names (extract-primitive-args this name init-arg-names init-args) init-args))))) + (apply prim-init + this + (if init-arg-names + (extract-primitive-args this name init-arg-names init-args) + init-args))))) #f make-struct:prim)) @@ -4462,7 +4554,9 @@ An example null] [else (let* ([name (car names)] - [id (if (symbol? name) name (car name))]) + [id (if (symbol? name) + name + (car name))]) (let ([arg (assq id args)]) (cond [arg (cons (cdr arg) (loop (cdr names) (remq arg args)))] @@ -4545,8 +4639,12 @@ An example . fields) (define all-fields (append fields - (if class-name (list (string-append which-class "class name") (as-write class-name)) null) - (if intf-name (list "interface name" (as-write intf-name)) null))) + (if class-name + (list (string-append which-class "class name") (as-write class-name)) + null) + (if intf-name + (list "interface name" (as-write intf-name)) + null))) (raise (make-exn:fail:object (format "~a: ~a~a" @@ -4576,11 +4674,17 @@ An example (current-continuation-marks)))) (define (for-class name) - (if name (format " for class: ~a" name) "")) + (if name + (format " for class: ~a" name) + "")) (define (for-class/which which name) - (if name (format " for ~a class: ~a" which name) "")) + (if name + (format " for ~a class: ~a" which name) + "")) (define (for-intf name) - (if name (format " for interface: ~a" name) "")) + (if name + (format " for interface: ~a" name) + "")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; @@ -4747,7 +4851,9 @@ An example (interface* () ([prop:custom-write (lambda (obj port mode) - (if mode (send obj custom-write port) (send obj custom-display port)))]) + (if mode + (send obj custom-write port) + (send obj custom-display port)))]) custom-write custom-display)) diff --git a/tests/test-cases/large2.rkt.out b/tests/test-cases/large2.rkt.out index d05815b..f17b07f 100644 --- a/tests/test-cases/large2.rkt.out +++ b/tests/test-cases/large2.rkt.out @@ -188,7 +188,9 @@ (let* ([end (send text get-end-position)] [start (send text get-start-position)]) (unless (= 0 (send text last-position)) - (let* ([str (if (= end start) (find-symbol text position) (send text get-text start end))] + (let* ([str (if (= end start) + (find-symbol text position) + (send text get-text start end))] ;; almost the same code as "search-help-desk" in "rep.rkt" [l (send text get-canvas)] [l (and l (send l get-top-level-window))] @@ -201,9 +203,10 @@ (add-sep) (let ([short-str (shorten-str str 50)]) (make-object menu-item% - (gui-utils:format-literal-label - (string-constant search-help-desk-for) - (if (equal? short-str str) str (string-append short-str "..."))) + (gui-utils:format-literal-label (string-constant search-help-desk-for) + (if (equal? short-str str) + str + (string-append short-str "..."))) menu (λ x (help-desk:help-desk str (list ctxt name)))) (void))))))) @@ -261,11 +264,15 @@ (if (< i 0) chars (let ([char (send text get-character i)]) - (if (non-letter? char) chars (loop (- i 1) (cons char chars))))))] + (if (non-letter? char) + chars + (loop (- i 1) (cons char chars))))))] [after (let loop ([i pos]) (if (< i (send text last-position)) (let ([char (send text get-character i)]) - (if (non-letter? char) null (cons char (loop (+ i 1))))) + (if (non-letter? char) + null + (cons char (loop (+ i 1))))) null))]) (apply string (append before after))) ""))])) @@ -275,7 +282,9 @@ (define (non-letter? x) (or (char-whitespace? x) (memq x '(#\` #\' #\, #\; #\" #\{ #\( #\[ #\] #\) #\})))) (define (shorten-str str len) - (if ((string-length str) . <= . len) str (substring str 0 len))) + (if ((string-length str) . <= . len) + str + (substring str 0 len))) ; ; ; @@ -310,14 +319,19 @@ (define num-s (string->number (send num get-value))) (define den-s (string->number (send den get-value))) (define whole-s - (if (string=? (send whole get-value) "") 0 (string->number (send whole get-value)))) + (if (string=? (send whole get-value) "") + 0 + (string->number (send whole get-value)))) (cond [(or (not whole-s) (not (integer? whole-s))) (string-constant insert-number/bad-whole-part)] [(or (not num-s) (not (integer? num-s)) (< num-s 0)) (string-constant insert-number/bad-numerator)] [(or (not den-s) (not (integer? den-s)) (<= den-s 0)) (string-constant insert-number/bad-denominator)] - [else (if (< whole-s 0) (- whole-s (/ num-s den-s)) (+ whole-s (/ num-s den-s)))])) + [else + (if (< whole-s 0) + (- whole-s (/ num-s den-s)) + (+ whole-s (/ num-s den-s)))])) (define (ok-callback) (define v (validate-number)) (cond @@ -594,10 +608,11 @@ (super set-filename fn tmp?) (let ([f (get-top-level-window)]) (when (and f (is-a? f drracket:unit:frame<%>)) - (send - (send f get-interactions-text) - set-port-unsaved-name - (if fn "interactions from an unsaved editor" (format "interactions from ~a" fn))) + (send (send f get-interactions-text) + set-port-unsaved-name + (if fn + "interactions from an unsaved editor" + (format "interactions from ~a" fn))) (send f update-save-message)))])) (field [needs-execution-state #f] @@ -920,12 +935,16 @@ (define sort-by-name? (preferences:get 'drracket:defns-popup-sort-by-name?)) (define sorting-name - (if sort-by-name? (string-constant sort-by-position) (string-constant sort-by-name))) + (if sort-by-name? + (string-constant sort-by-position) + (string-constant sort-by-name))) (define/private (change-sorting-order) (set! sort-by-name? (not sort-by-name?)) (preferences:set 'drracket:defns-popup-sort-by-name? sort-by-name?) (set! sorting-name - (if sort-by-name? (string-constant sort-by-position) (string-constant sort-by-name)))) + (if sort-by-name? + (string-constant sort-by-position) + (string-constant sort-by-name)))) (define define-popup-capability-info (get-define-popup-info (drracket:language:get-capability-default 'drscheme:define-popup))) @@ -1507,7 +1526,10 @@ ;; just flush and redraw everything if there is one (or zero) logger messages (pair? (cdr logger-messages))) (define msg (cdr command)) - (define scroll? (if (object? logger-checkbox) (send logger-checkbox get-value) #t)) + (define scroll? + (if (object? logger-checkbox) + (send logger-checkbox get-value) + #t)) (send logger-gui-text begin-edit-sequence) (send logger-gui-text lock #f) (define start (send logger-gui-text last-position)) @@ -1701,30 +1723,31 @@ ;; if they say no, return #f. (define/private (ensure-empty transcript-directory) (let ([dir-list (directory-list transcript-directory)]) - (or - (null? dir-list) - (let ([query (message-box - (string-constant drscheme) - (gui-utils:format-literal-label (string-constant erase-log-directory-contents) - transcript-directory) - this - '(yes-no) - #:dialog-mixin frame:focus-table-mixin)]) - (cond - [(equal? query 'no) #f] - [(equal? query 'yes) - (with-handlers ([exn:fail:filesystem? - (λ (exn) - (message-box - (string-constant drscheme) - (gui-utils:format-literal-label - (string-constant error-erasing-log-directory) - (if (exn? exn) (format "~a" (exn-message exn)) (format "~s" exn))) - this - #:dialog-mixin frame:focus-table-mixin) - #f)]) - (for-each (λ (file) (delete-file (build-path transcript-directory file))) dir-list) - #t)]))))) + (or (null? dir-list) + (let ([query (message-box (string-constant drscheme) + (gui-utils:format-literal-label + (string-constant erase-log-directory-contents) + transcript-directory) + this + '(yes-no) + #:dialog-mixin frame:focus-table-mixin)]) + (cond + [(equal? query 'no) #f] + [(equal? query 'yes) + (with-handlers ([exn:fail:filesystem? + (λ (exn) + (message-box (string-constant drscheme) + (gui-utils:format-literal-label + (string-constant error-erasing-log-directory) + (if (exn? exn) + (format "~a" (exn-message exn)) + (format "~s" exn))) + this + #:dialog-mixin frame:focus-table-mixin) + #f)]) + (for-each (λ (file) (delete-file (build-path transcript-directory file))) + dir-list) + #t)]))))) (define/override (make-root-area-container cls parent) (let* ([_module-browser-parent-panel @@ -1895,7 +1918,11 @@ (sort-toolbar-buttons-panel)) (define/private (add-to-toolbar-buttons who button number/f) - (define number (or number/f (if smallest (- smallest 1) 100))) + (define number + (or number/f + (if smallest + (- smallest 1) + 100))) (define prev (hash-ref toolbar-buttons button #f)) (when (and prev (not (= prev number))) (error who @@ -1945,7 +1972,10 @@ [(is-a? item area-container<%>) (hash-ref sub-panel-nums item missing-num)] [else (hash-ref toolbar-buttons item missing-num)])) (define ans (sort l (cmp panel) #:key key)) - (set! min (if (null? ans) #f (key (car ans)))) + (set! min + (if (null? ans) + #f + (key (car ans)))) ans)) min) (void))) @@ -2087,7 +2117,10 @@ (λ (l) (cond [(= (send tabs-panel get-number) 1) (remq tabs-panel l)] - [else (if (memq tabs-panel l) l (cons tabs-panel l))])))) + [else + (if (memq tabs-panel l) + l + (cons tabs-panel l))])))) (define/private (update-tab-label tab) (let ([label (gui-utils:trim-string (get-defs-tab-label (send tab get-defs) tab) 200)]) @@ -2117,7 +2150,9 @@ (define/private (get-defs-tab-filename defs) (let ([fn (send defs get-filename)]) - (if fn (get-tab-label-from-filename fn) (send defs get-filename/untitled-name)))) + (if fn + (get-tab-label-from-filename fn) + (send defs get-filename/untitled-name)))) ;; tab-label-cache-valid : (listof path) ;; If the current set of filenames in the tabs is the @@ -2150,7 +2185,10 @@ (define/private (add-modified-flag text string) (if (send text is-modified?) - (let ([prefix (get-save-diamond-prefix)]) (if prefix (string-append prefix string) string)) + (let ([prefix (get-save-diamond-prefix)]) + (if prefix + (string-append prefix string) + string)) string)) (define/private (get-save-diamond-prefix) @@ -2179,7 +2217,9 @@ (let loop ([tabs tabs]) (unless (null? tabs) (let ([tab (car tabs)]) - (if (eq? (send tab get-ints) rep) (change-to-tab tab) (loop (cdr tabs))))))) + (if (eq? (send tab get-ints) rep) + (change-to-tab tab) + (loop (cdr tabs))))))) (unless interactions-shown? (toggle-show/hide-interactions) (update-shown))) @@ -2512,14 +2552,18 @@ (define (immediate child) (let loop ([child child]) (define immediate-parent (send child get-parent)) - (if (and immediate-parent (eq? immediate-parent parent)) child (loop immediate-parent)))) + (if (and immediate-parent (eq? immediate-parent parent)) + child + (loop immediate-parent)))) (for/list ([child children]) (immediate child))) (define/override (update-shown) (super update-shown) (let ([new-children (foldl (λ (shown? children sofar) - (if shown? (append children sofar) sofar)) + (if shown? + (append children sofar) + sofar)) null (list interactions-shown? definitions-shown?) (list interactions-canvases definitions-canvases))] @@ -2559,7 +2603,9 @@ [(null? children) (void)] [else (let ([child (car children)]) - (if (is-a? child editor-canvas%) child (loop (cdr children))))]))] + (if (is-a? child editor-canvas%) + child + (loop (cdr children))))]))] [old-focus (ormap (λ (x) (and (is-a? x editor-canvas%) (send x has-focus?) x)) old-children)]) @@ -2723,22 +2769,23 @@ (define/private (does-user-want-to-save-all-unsaved-files? save-candidates) (define-values (message-box-result checked?) - (message+check-box/custom - (string-constant drracket) - (if (= (length save-candidates) 1) - (format (string-constant one-file-not-saved-do-the-save?) - (get-tab-filename (car save-candidates))) - (apply string-append - (string-constant many-files-not-saved-do-the-save?) - (for/list ([tab (in-list save-candidates)]) - (~a "\n" (get-tab-filename tab))))) - (string-constant save-after-switching-tabs) - (string-constant save-all-files) - (string-constant dont-save) - #f - this ; parent - (append (if (preferences:get 'drracket:save-files-on-tab-switch?) '(checked) '()) - '(default=1)))) + (message+check-box/custom (string-constant drracket) + (if (= (length save-candidates) 1) + (format (string-constant one-file-not-saved-do-the-save?) + (get-tab-filename (car save-candidates))) + (apply string-append + (string-constant many-files-not-saved-do-the-save?) + (for/list ([tab (in-list save-candidates)]) + (~a "\n" (get-tab-filename tab))))) + (string-constant save-after-switching-tabs) + (string-constant save-all-files) + (string-constant dont-save) + #f + this ; parent + (append (if (preferences:get 'drracket:save-files-on-tab-switch?) + '(checked) + '()) + '(default=1)))) (preferences:set 'drracket:save-files-on-tab-switch? checked?) (case message-box-result [(1) (values #f #t)] ;; clicked save-all -> save (and run) @@ -2807,9 +2854,10 @@ (set! tabs (append tabs (list new-tab))) (send tabs-panel append - (gui-utils:trim-string - (if filename (get-tab-label-from-filename filename) (get-defs-tab-label defs #f)) - 200)) + (gui-utils:trim-string (if filename + (get-tab-label-from-filename filename) + (get-defs-tab-label defs #f)) + 200)) (init-definitions-text new-tab) (when filename (send defs load-file filename)) @@ -2887,7 +2935,9 @@ (let ([old-enabled (send from-tab get-enabled)] [new-enabled (send to-tab get-enabled)]) (unless (eq? old-enabled new-enabled) - (if new-enabled (enable-evaluation) (disable-evaluation)))) + (if new-enabled + (enable-evaluation) + (disable-evaluation)))) (inner (void) on-tab-change from-tab to-tab)) @@ -3016,7 +3066,9 @@ (let loop ([i (- regions-count canvases-count)] [canvases canvases]) (unless (zero? i) - (if ints? (split-interactions (car canvases)) (split-definitions (car canvases))) + (if ints? + (split-interactions (car canvases)) + (split-definitions (car canvases))) (loop (- i 1) (cdr canvases))))])))) (define (set-visible-regions txt regions) @@ -3059,7 +3111,10 @@ (change-to-tab tab)))) (define/public (find-matching-tab filename) - (define fn-path (if (string? filename) (string->path filename) filename)) + (define fn-path + (if (string? filename) + (string->path filename) + filename)) (for/or ([tab (in-list tabs)]) (define tab-filename (send (send tab get-defs) get-filename)) (and tab-filename (pathname-equal? fn-path tab-filename) tab))) @@ -3099,7 +3154,9 @@ (define just-one? (and (pair? tabs) (null? (cdr tabs)))) (send item set-label - (if just-one? (string-constant close-tab) (string-constant close-tab-amp))) + (if just-one? + (string-constant close-tab) + (string-constant close-tab-amp))) (when (preferences:get 'framework:menu-bindings) (send item set-shortcut (if just-one? #f #\w)))) @@ -3108,10 +3165,11 @@ [(equal? (system-type) 'unix) (send item set-label (string-constant close-menu-item))] [else (define just-one? (and (pair? tabs) (null? (cdr tabs)))) - (send - item - set-label - (if just-one? (string-constant close-window-menu-item) (string-constant close-window))) + (send item + set-label + (if just-one? + (string-constant close-window-menu-item) + (string-constant close-window))) (when (preferences:get 'framework:menu-bindings) (send item set-shortcut-prefix @@ -3238,9 +3296,10 @@ (string-constant hide-module-browser) (string-constant show-module-browser))) (parent (get-show-menu)) - (callback - (λ (menu evt) - (if module-browser-shown? (hide-module-browser) (show-module-browser)))))) + (callback (λ (menu evt) + (if module-browser-shown? + (hide-module-browser) + (show-module-browser)))))) (set-show-menu-sort-key module-browser-menu-item 401) (set! toolbar-menu (new menu% [parent show-menu] [label (string-constant toolbar)])) @@ -3651,7 +3710,10 @@ (make-object menu:can-restore-menu-item% (string-constant log-definitions-and-interactions) file-menu - (λ (x y) (if transcript (stop-transcript) (start-transcript))))) + (λ (x y) + (if transcript + (stop-transcript) + (start-transcript))))) (make-object separator-menu-item% file-menu) (super file-menu:between-save-as-and-print file-menu))) @@ -3731,34 +3793,37 @@ (send item enable on?))] [callback (λ (item evt) - (aspell-callback - (λ (problem?) - (unless problem? - (define ed (get-edit-target-object)) - (define orig-pos (send ed get-start-position)) - - (define (search start end mispelled?) - (let loop ([p start]) - (cond - [(< p end) - (define sp (send ed get-spell-suggestions p)) - (define found-something? (if mispelled? (list? sp) (not (list? sp)))) - (cond - [found-something? p] - [else (loop (+ p 1))])] - [else #f]))) - - (define first-well-spelled - (or (search orig-pos (send ed last-position) #f) (search 0 orig-pos #f))) - (cond - [first-well-spelled - (define mispelled - (or (search first-well-spelled (send ed last-position) #t) - (search 0 first-well-spelled #t))) - (cond - [mispelled (send ed set-position mispelled)] - [else (bell)])] - [else (bell)])))))]) + (aspell-callback (λ (problem?) + (unless problem? + (define ed (get-edit-target-object)) + (define orig-pos (send ed get-start-position)) + + (define (search start end mispelled?) + (let loop ([p start]) + (cond + [(< p end) + (define sp (send ed get-spell-suggestions p)) + (define found-something? + (if mispelled? + (list? sp) + (not (list? sp)))) + (cond + [found-something? p] + [else (loop (+ p 1))])] + [else #f]))) + + (define first-well-spelled + (or (search orig-pos (send ed last-position) #f) + (search 0 orig-pos #f))) + (cond + [first-well-spelled + (define mispelled + (or (search first-well-spelled (send ed last-position) #t) + (search 0 first-well-spelled #t))) + (cond + [mispelled (send ed set-position mispelled)] + [else (bell)])] + [else (bell)])))))]) (new menu:can-restore-menu-item% [label (string-constant spell-suggest-corrections)] @@ -4314,7 +4379,11 @@ (define fst (car lst)) (cond [(= pos (- (srcloc-position fst) 1)) - (values before (if (null? (cdr lst)) #f (cadr lst)) sorted)] + (values before + (if (null? (cdr lst)) + #f + (cadr lst)) + sorted)] [(< pos (- (srcloc-position fst) 1)) (values before fst sorted)] [else (loop (car lst) (cdr lst))])]))) @@ -4533,7 +4602,10 @@ (send btn set-label-visible #f) (send info-panel change-children (λ (l) (cons btn (remq* (list btn) l)))) btn)) - (define/private (set-bug-label v) (if (null? v) (send bug-icon show #f) (send bug-icon show #t))) + (define/private (set-bug-label v) + (if (null? v) + (send bug-icon show #f) + (send bug-icon show #t))) (set-bug-label (preferences:get 'drracket:saved-bug-reports)) (define remove-bug-icon-callback (preferences:add-callback 'drracket:saved-bug-reports (λ (p v) (set-bug-label v)))) @@ -4605,8 +4677,13 @@ (for/list ([info (in-list infos)] #:unless (member (define-popup-info-long-name info) hidden-prefixes)) info)) - (define the-info (if (null? visible-infos) (car infos) (car visible-infos))) - (if vertical? (define-popup-info-short-name the-info) (define-popup-info-long-name the-info))] + (define the-info + (if (null? visible-infos) + (car infos) + (car visible-infos))) + (if vertical? + (define-popup-info-short-name the-info) + (define-popup-info-long-name the-info))] [else #f])) (define execute-warning-canvas% (class canvas% @@ -4808,21 +4885,23 @@ (update-ok-button-state)) (define tb - (keymap:call/text-keymap-initializer - (λ () - (new text-field% - [label #f] - [parent top-hp] - [init-value (if current-limit (format "~a" current-limit) "128")] - [stretchable-width #f] - [min-width 100] - [callback - (λ (tf e) - (let ([ed (send tf get-editor)]) - (cond - [(is-valid-number? ed) (background clear-sd)] - [else (background yellow-sd)])) - (update-ok-button-state))])))) + (keymap:call/text-keymap-initializer (λ () + (new text-field% + [label #f] + [parent top-hp] + [init-value + (if current-limit + (format "~a" current-limit) + "128")] + [stretchable-width #f] + [min-width 100] + [callback + (λ (tf e) + (let ([ed (send tf get-editor)]) + (cond + [(is-valid-number? ed) (background clear-sd)] + [else (background yellow-sd)])) + (update-ok-button-state))])))) (define (update-ok-button-state) (cond @@ -5032,7 +5111,11 @@ (let loop ([item item]) (cond [(null? item) default] - [else (let ([rib (car item)]) (if (eq? (car rib) k) (cdr rib) (loop (cdr item))))]))) + [else + (let ([rib (car item)]) + (if (eq? (car rib) k) + (cdr rib) + (loop (cdr item))))]))) (define vp (new-vertical-panel% [style '(border)] [parent saved-bug-reports-panel] @@ -5053,7 +5136,10 @@ [stretchable-width #t] [label (string-append (lookup 'component "<>") - (let ([v (lookup 'version #f)]) (if v (string-append " " v) "")))] + (let ([v (lookup 'version #f)]) + (if v + (string-append " " v) + "")))] [parent hp])) (define forget (new button% diff --git a/tests/test-cases/test-if.rkt b/tests/test-cases/test-if.rkt index 74383ec..e000c62 100644 --- a/tests/test-cases/test-if.rkt +++ b/tests/test-cases/test-if.rkt @@ -21,7 +21,20 @@ (if (boolean? mred-launcher) (if mred-launcher 'mred 'mzscheme) #t)) (define if7 - (if ; condition + (if (< 10 20) + ; true branch + (* 4 10) + ; false branch + (+ 2 4))) + +(define if8 + (if ; check if ten is less than twenty + (< 10 20) + (* 4 10) + (+ 2 4))) + +(define if9 + (if ; check if ten is less than twenty (< 10 20) ; true branch (* 4 10) diff --git a/tests/test-cases/test-if.rkt.out b/tests/test-cases/test-if.rkt.out new file mode 100644 index 0000000..0c5d454 --- /dev/null +++ b/tests/test-cases/test-if.rkt.out @@ -0,0 +1,46 @@ +#lang racket + +(define if1 (if #t 1 0)) + +(define if2 + (if #t + (* 2 3) + (+ 3 4))) + +(define if3 (if (> (+ 2 3) (* 3 4)) #t #f)) + +(define (if4 subs expr restore loop shift) + (if subs + (list (restore expr (loop subs))) + (list (shift expr)))) + +(define (if5 s loop pi) + (if (< s 0) + (loop (+ s (* 2 pi))) + s)) + +(define (if6 mred-launcher) + (if (boolean? mred-launcher) + (if mred-launcher 'mred 'mzscheme) + #t)) + +(define if7 + (if (< 10 20) + ; true branch + (* 4 10) + ; false branch + (+ 2 4))) + +(define if8 + ; check if ten is less than twenty + (if (< 10 20) + (* 4 10) + (+ 2 4))) + +(define if9 + ; check if ten is less than twenty + (if (< 10 20) + ; true branch + (* 4 10) + ; false branch + (+ 2 4)))