Change else in match to _
This fixes at least one "potential" bug in the file `collects/pkg/private/create.rkt`, where `else` in the `cond` is bound to `else` from `match` instead of `racket/base`. (though it turns out that the format will always be truthy, making the program happen to be correct.)
This commit is contained in:
parent
6edc3dbfab
commit
66547f3aaf
|
@ -124,7 +124,7 @@
|
|||
['start (when (verbose) (printf " ~a making ~a\n" id (->rel work)))]
|
||||
['done (when (verbose) (printf " ~a made ~a\n" id (->rel work)))]
|
||||
['output (printf " ~a output from: ~a\n~a~a" id work out err)]
|
||||
[else (printf " ~a error compiling ~a\n~a\n~a~a" id work msg out err)]))
|
||||
[_ (printf " ~a error compiling ~a\n~a\n~a~a" id work msg out err)]))
|
||||
#:options (let ([cons-if-true (lambda (bool carv cdrv)
|
||||
(if bool
|
||||
(cons carv cdrv)
|
||||
|
|
|
@ -63,7 +63,7 @@
|
|||
[plt-home-rel? (printf " unpack to main installation\n")]
|
||||
[plt-rel? (printf " unpack to user add-ons\n")]
|
||||
[else (printf " unpack locally\n")])]
|
||||
[else
|
||||
[_
|
||||
(printf "config function:\n")
|
||||
(pretty-write config)]))
|
||||
a)
|
||||
|
@ -74,7 +74,7 @@
|
|||
(printf "setup collections:\n")
|
||||
(for ([c (in-list c)])
|
||||
(printf " ~s\n" (string-join c "/")))]
|
||||
[else
|
||||
[_
|
||||
(printf "setup unit:\n")
|
||||
(pretty-write setup)]))
|
||||
a)
|
||||
|
|
|
@ -282,9 +282,9 @@
|
|||
num-shares share-vec
|
||||
mutable-fill-vec
|
||||
result-vec)]
|
||||
[else
|
||||
[_
|
||||
(decompile-linklet l)])]
|
||||
[else
|
||||
[_
|
||||
(decompile-linklet l)])]
|
||||
[(struct faslable-correlated-linklet (expr name))
|
||||
(match (strip-correlated expr)
|
||||
|
@ -307,9 +307,9 @@
|
|||
num-shares share-vec
|
||||
mutable-fill-vec
|
||||
result-vec)]
|
||||
[else
|
||||
[_
|
||||
(decompile-linklet l)])]
|
||||
[else
|
||||
[_
|
||||
(decompile-linklet l)]))
|
||||
|
||||
(define (decompile-form form globs stack closed)
|
||||
|
@ -330,7 +330,7 @@
|
|||
`(begin ,@(map (lambda (form)
|
||||
(decompile-form form globs stack closed))
|
||||
forms))]
|
||||
[else
|
||||
[_
|
||||
(decompile-expr form globs stack closed)]))
|
||||
|
||||
(define (extract-name name)
|
||||
|
@ -348,7 +348,7 @@
|
|||
(extract-name name)]
|
||||
[(struct closure (lam gen-id))
|
||||
(extract-id lam)]
|
||||
[else #f]))
|
||||
[_ #f]))
|
||||
|
||||
(define (extract-ids! body ids)
|
||||
(match body
|
||||
|
@ -362,7 +362,7 @@
|
|||
(extract-ids! body ids)]
|
||||
[(struct boxenv (pos body))
|
||||
(extract-ids! body ids)]
|
||||
[else #f]))
|
||||
[_ #f]))
|
||||
|
||||
(define (decompile-tl expr globs stack closed no-check?)
|
||||
(match expr
|
||||
|
@ -441,10 +441,10 @@
|
|||
`(begin
|
||||
(set! ,id (#%box ,id))
|
||||
,(decompile-expr body globs stack closed)))]
|
||||
[(struct branch (test then else))
|
||||
[(struct branch (test then els))
|
||||
`(if ,(decompile-expr test globs stack closed)
|
||||
,(decompile-expr then globs stack closed)
|
||||
,(decompile-expr else globs stack closed))]
|
||||
,(decompile-expr els globs stack closed))]
|
||||
[(struct application (rator rands))
|
||||
(let ([stack (append (for/list ([i (in-list rands)]) (gensym 'rand))
|
||||
stack)])
|
||||
|
@ -485,7 +485,7 @@
|
|||
(hash-set! closed gen-id #t)
|
||||
`(#%closed ,gen-id ,(decompile-expr lam globs stack closed))))]
|
||||
[(? void?) (list 'void)]
|
||||
[else `(quote ,expr)]))
|
||||
[_ `(quote ,expr)]))
|
||||
|
||||
(define (decompile-lam expr globs stack closed)
|
||||
(match expr
|
||||
|
|
|
@ -160,7 +160,7 @@
|
|||
[(def-values ids rhs)
|
||||
(for/or ([id (in-list ids)])
|
||||
(eq? 'used (hash-ref used (toplevel-pos id) #f)))]
|
||||
[else (not (pure? b))]))
|
||||
[_ (not (pure? b))]))
|
||||
b))
|
||||
|
||||
(define new-body (remap-positions used-body
|
||||
|
|
|
@ -97,7 +97,7 @@
|
|||
(match n
|
||||
[(? (lambda (x) (x . < . 0))) (raise (format "split-n: n: ~a less than 0" n))]
|
||||
[1 lst]
|
||||
[else
|
||||
[_
|
||||
(define splits (sub1 n))
|
||||
(define-values (q r) (quotient/remainder (length lst) n))
|
||||
(let loop ([lst-in lst]
|
||||
|
|
|
@ -153,16 +153,16 @@
|
|||
;; if this happens, this code should be updated
|
||||
(error 'make-script
|
||||
"internal error: unexpected tooltip"))]
|
||||
[else body])])
|
||||
[_ body])])
|
||||
(values (compact-url href) (compact-body body)))]
|
||||
[else
|
||||
[_
|
||||
(log-error "search script: unrecognized index-entry shape: ~e" e)
|
||||
(values #f #f)])))
|
||||
(define (lib->name lib)
|
||||
(quote-string (let loop ([lib lib])
|
||||
(match lib
|
||||
[`',lib (string-append "'" (loop lib))]
|
||||
[else (format "~s" lib)]))))
|
||||
[_ (format "~s" lib)]))))
|
||||
(define from-libs
|
||||
(cond
|
||||
[(exported-index-desc? desc)
|
||||
|
|
|
@ -576,10 +576,10 @@
|
|||
[_ 'no]))
|
||||
|
||||
(comp 1
|
||||
(match (box 'x) ('#&x 1) (else #f)))
|
||||
(match (box 'x) ('#&x 1) (_ #f)))
|
||||
|
||||
(comp 2
|
||||
(match (vector 1 2) ('#(1 2) 2) (else #f)))
|
||||
(match (vector 1 2) ('#(1 2) 2) (_ #f)))
|
||||
|
||||
(comp 'yes
|
||||
(with-handlers ([exn:fail? (lambda _ 'yes)]
|
||||
|
@ -622,7 +622,7 @@
|
|||
(comp 'bad
|
||||
(match #(1)
|
||||
[(vector a b) a]
|
||||
[else 'bad]))
|
||||
[_ 'bad]))
|
||||
|
||||
(comp '(1 2)
|
||||
(call-with-values
|
||||
|
@ -680,7 +680,7 @@
|
|||
|
||||
(match (make-pose 1 2 3)
|
||||
[(struct pose (x y a)) "Gotcha!"]
|
||||
[else "Epic fail!"])))
|
||||
[_ "Epic fail!"])))
|
||||
|
||||
(comp #f
|
||||
(match (list 'a 'b 'c)
|
||||
|
|
|
@ -16,11 +16,11 @@
|
|||
(check eq? #t (match '(tile a b c)
|
||||
[`(tile ,@'(a b c))
|
||||
#t]
|
||||
[else #f]))
|
||||
[_ #f]))
|
||||
(check eq? #t (match '(tile a b c)
|
||||
[`(tile ,@`(a b c))
|
||||
#t]
|
||||
[else #f])))))
|
||||
[_ #f])))))
|
||||
(define cons-tests
|
||||
(test-suite "Tests for cons pattern"
|
||||
(test-case "simple"
|
||||
|
@ -197,7 +197,7 @@
|
|||
(define (origin? pt)
|
||||
(match pt
|
||||
((struct point (0 0)) #t)
|
||||
(else #f)))
|
||||
(_ #f)))
|
||||
(check-true (origin? (make-point 0 0)))
|
||||
(check-false (origin? (make-point 1 1)))))
|
||||
; These tests ensures that the unsafe struct optimization is correct
|
||||
|
@ -209,7 +209,7 @@
|
|||
(define (origin? pt)
|
||||
(match pt
|
||||
((struct point (0 0)) #t)
|
||||
(else #f)))
|
||||
(_ #f)))
|
||||
(check-true (origin? (make-point 'a 0 0)))
|
||||
(check-false (origin? (make-point 'a 1 1))))))
|
||||
(test-case "struct patterns (with fake struct info)"
|
||||
|
@ -221,7 +221,7 @@
|
|||
(define (origin? pt)
|
||||
(match pt
|
||||
((struct point (0 1)) #t)
|
||||
(else #f)))
|
||||
(_ #f)))
|
||||
(check-true (origin? (list 0 1)))
|
||||
(check-false (origin? (list 1 1)))
|
||||
(check-false (origin? (list 1 1 1)))
|
||||
|
|
|
@ -37,7 +37,7 @@
|
|||
(define (origin? pt)
|
||||
(match pt
|
||||
(($ point 0 0) #t)
|
||||
(else #f)))
|
||||
(_ #f)))
|
||||
(check-true (origin? (make-point 0 0)))
|
||||
(check-false (origin? (make-point 1 1)))))
|
||||
(test-case "empty hash-table pattern bug"
|
||||
|
|
|
@ -39,56 +39,56 @@
|
|||
|
||||
(mytest (match "hello"
|
||||
((pregexp (pregexp "hello")) #t)
|
||||
(else #f))
|
||||
(_ #f))
|
||||
#t)
|
||||
|
||||
(mytest (match 123
|
||||
((pregexp "123") #t)
|
||||
(else #f))
|
||||
(_ #f))
|
||||
#f)
|
||||
(mytest (match 123
|
||||
((regexp "123") #t)
|
||||
(else #f))
|
||||
(_ #f))
|
||||
#f)
|
||||
(mytest (match 123
|
||||
((pregexp "123" (list a ...)) #t)
|
||||
(else #f))
|
||||
(_ #f))
|
||||
#f)
|
||||
(mytest (match 123
|
||||
((regexp "123" (list a ...)) #t)
|
||||
(else #f))
|
||||
(_ #f))
|
||||
#f)
|
||||
|
||||
(mytest (match "hello"
|
||||
((regexp "hello") #t)
|
||||
(else #f))
|
||||
(_ #f))
|
||||
#t)
|
||||
|
||||
(mytest (match "frank"
|
||||
((regexp "hello") #t)
|
||||
((regexp "frank") 2)
|
||||
(else #f))
|
||||
(_ #f))
|
||||
2)
|
||||
|
||||
(mytest (match "frank"
|
||||
((pregexp "hello") #t)
|
||||
((pregexp "frank") 2)
|
||||
(else #f))
|
||||
(_ #f))
|
||||
2)
|
||||
|
||||
(mytest (match "frank"
|
||||
((regexp "hello") #t)
|
||||
(else #f))
|
||||
(_ #f))
|
||||
#f)
|
||||
|
||||
(mytest (match "hello"
|
||||
((regexp "(hel)lo" (list whol a rest ...)) a)
|
||||
(else #f))
|
||||
(_ #f))
|
||||
"hel")
|
||||
|
||||
(mytest (match "hello"
|
||||
((pregexp "(hel)lo" (list whole a rest ...)) a)
|
||||
(else #f))
|
||||
(_ #f))
|
||||
"hel")
|
||||
|
||||
(mytest (match-let*
|
||||
|
@ -117,28 +117,28 @@
|
|||
[(list 'case-> types ...) 1]
|
||||
[(list '->) 2]
|
||||
[(list '-> types ...) 3]
|
||||
[else 4])
|
||||
[_ 4])
|
||||
1)
|
||||
|
||||
(mytest (match '(->)
|
||||
[(list 'case-> types ...) 1]
|
||||
[(list '->) 2]
|
||||
[(list '-> types ...) 3]
|
||||
[else 4])
|
||||
[_ 4])
|
||||
2)
|
||||
|
||||
(mytest (match '(-> a b)
|
||||
[(list 'case-> types ...) 1]
|
||||
[(list '->) 2]
|
||||
[(list '-> types ...) 3]
|
||||
[else 4])
|
||||
[_ 4])
|
||||
3)
|
||||
|
||||
(mytest (match 'x
|
||||
[(list 'case-> types ...) 1]
|
||||
[(list '->) 2]
|
||||
[(list '-> types ...) 3]
|
||||
[else 4])
|
||||
[_ 4])
|
||||
4)
|
||||
|
||||
(mytest (match '((r a))
|
||||
|
|
|
@ -21,7 +21,7 @@
|
|||
['start (printf " Making ~a\n" work)]
|
||||
['done (printf " Made ~a\n" work)]
|
||||
['output (printf " Output from: ~a\n~a~a" work out err)]
|
||||
[else (eprintf " Error compiling ~a\n~a\n~a~a" work msg out err)])))
|
||||
[_ (eprintf " Error compiling ~a\n~a\n~a~a" work msg out err)])))
|
||||
|
||||
(define compiled (car (use-compiled-file-paths)))
|
||||
|
||||
|
|
|
@ -36,7 +36,7 @@
|
|||
[(linkl-bundle table)
|
||||
;; single linklet bundle:
|
||||
(zo-marshal-bundle-to table outp)]
|
||||
[else
|
||||
[_
|
||||
(error 'zo-marshal-top "not a linklet bundle or directory:" top)]))
|
||||
|
||||
(define (zo-marshal-directory-to top outp)
|
||||
|
@ -616,11 +616,11 @@
|
|||
(out-number boxenv-type-num out)
|
||||
(out-anything pos out)
|
||||
(out-anything (protect-quote body) out)]
|
||||
[(struct branch (test then else))
|
||||
[(struct branch (test then els))
|
||||
(out-byte CPT_BRANCH out)
|
||||
(out-anything (protect-quote test) out)
|
||||
(out-anything (protect-quote then) out)
|
||||
(out-anything (protect-quote else) out)]
|
||||
(out-anything (protect-quote els) out)]
|
||||
[(struct application (rator rands))
|
||||
(let ([len (length rands)])
|
||||
(if (len . < . (- CPT_SMALL_APPLICATION_END CPT_SMALL_APPLICATION_START))
|
||||
|
@ -826,7 +826,7 @@
|
|||
(define bstr (get-output-bytes s))
|
||||
(out-number (bytes-length bstr) out)
|
||||
(out-bytes bstr out)]
|
||||
[else (error 'out-anything "~s" (current-type-trace))])))))
|
||||
[_ (error 'out-anything "~s" (current-type-trace))])))))
|
||||
|
||||
(define (out-linklet linklet-form out)
|
||||
(out-byte CPT_LINKLET out)
|
||||
|
|
|
@ -432,7 +432,7 @@
|
|||
(pkg-desc url-str (if reject-existing? 'clone current-type) name
|
||||
checksum auto? extra-path)]
|
||||
[else #f])]
|
||||
[else #f]))
|
||||
[_ #f]))
|
||||
|
||||
;; For a `desc`, extract it's clone location, if it's a clone
|
||||
(define (desc-clone desc)
|
||||
|
|
|
@ -133,7 +133,7 @@
|
|||
(define (default-pkg-scope)
|
||||
(match (default-pkg-scope-as-string)
|
||||
["installation" 'installation]
|
||||
[else 'user]))
|
||||
[_ 'user]))
|
||||
(define (default-pkg-scope-as-string)
|
||||
(read-pkg-cfg/def 'default-scope))
|
||||
|
||||
|
|
|
@ -35,7 +35,7 @@
|
|||
(find-files file-exists?)))])
|
||||
(display f)
|
||||
(newline))))]
|
||||
[else
|
||||
[_
|
||||
(define pkg (format "~a.~a" pkg-name create:format))
|
||||
(define actual-dest-dir (if dest-dir
|
||||
(path->complete-path dest-dir)
|
||||
|
|
|
@ -26,7 +26,7 @@
|
|||
(system "whoami")]
|
||||
['windows
|
||||
(system "echo %username%")]
|
||||
[else (pkg-error "not supported")])))))
|
||||
[_ (pkg-error "not supported")])))))
|
||||
|
||||
(define ====
|
||||
(make-string (string-length name) #\=))
|
||||
|
|
|
@ -151,7 +151,7 @@
|
|||
;; Can use compiled bytecode, etc.:
|
||||
(parameterize ([current-namespace ns])
|
||||
(dynamic-require file '#%info-lookup)))))])]
|
||||
[else (err "does not contain a module of the right shape")])))
|
||||
[_ (err "does not contain a module of the right shape")])))
|
||||
|
||||
(define (filter-environment-variables ev)
|
||||
(let ([keep (environment-variables-ref ev #"PLT_INFO_ALLOW_VARS")]
|
||||
|
|
|
@ -58,7 +58,7 @@
|
|||
(idle! +1)
|
||||
(hash-set! depends wrkr (cons w fn))
|
||||
(list w (append waitlst (list wrkr)))]))]
|
||||
[else
|
||||
[_
|
||||
(wrkr/send wrkr (list 'locked))
|
||||
(list wrkr null)]))
|
||||
(not v)))
|
||||
|
@ -122,18 +122,18 @@
|
|||
(append-error cc "making" #f out err "output"))
|
||||
;(when last (printer (current-output-port) "made" "~a" (cc-name cc)))
|
||||
#t]
|
||||
[else (eprintf "Failed trying to match:\n~s\n" result-type)]))]
|
||||
[_ (eprintf "Failed trying to match:\n~s\n" result-type)]))]
|
||||
[(list _ (list 'ADD fn))
|
||||
;; Currently ignoring queued individual files
|
||||
#f]
|
||||
[else
|
||||
[_
|
||||
(match work
|
||||
[(list-rest (list cc file last) message)
|
||||
(append-error cc "making" #f "" "" "error")
|
||||
(eprintf "work-done match cc failed.\n")
|
||||
(eprintf "trying to match:\n~e\n" (list work msg))
|
||||
#t]
|
||||
[else
|
||||
[_
|
||||
(eprintf "work-done match cc failed.\n")
|
||||
(eprintf "trying to match:\n~e\n" (list work msg))
|
||||
(eprintf "FATAL\n")
|
||||
|
@ -176,7 +176,7 @@
|
|||
[(cons (list cc (cons file ft) subs) tail)
|
||||
(hash-set! hash id (cons (list cc ft subs) tail))
|
||||
(build-job cc file #f)]
|
||||
[else
|
||||
[_
|
||||
(eprintf "get-job match cc failed.\n")
|
||||
(eprintf "trying to match:\n~v\n" cc)]))
|
||||
|
||||
|
@ -258,7 +258,7 @@
|
|||
(set! filelist (cons fn filelist))
|
||||
(set! seen (hash-set seen fn #t)))
|
||||
#f]
|
||||
[else
|
||||
[_
|
||||
(handler id 'fatalerror (format "Error matching work: ~a queue ~a" work filelist) "" "") #t]))
|
||||
|
||||
(define/public (get-job workerid)
|
||||
|
@ -316,12 +316,12 @@
|
|||
[(list 'compiled) #f]
|
||||
[(list 'DIE) (worker/die 1)]
|
||||
[x (send/error (format "DIDNT MATCH B ~v\n" x))]
|
||||
[else (send/error (format "DIDNT MATCH B\n"))])]
|
||||
[_ (send/error (format "DIDNT MATCH B\n"))])]
|
||||
['unlock
|
||||
(DEBUG_COMM (eprintf "UNLOCKING ~a ~a ~a\n" worker-id name _full-file))
|
||||
(send/msg (list (list 'UNLOCK (path->bytes fn)) "" ""))]
|
||||
[x (send/error (format "DIDNT MATCH C ~v\n" x))]
|
||||
[else (send/error (format "DIDNT MATCH C\n"))]))
|
||||
[_ (send/error (format "DIDNT MATCH C\n"))]))
|
||||
(with-handlers ([exn:fail? (lambda (x)
|
||||
(send/resp (list 'ERROR
|
||||
;; Long form shows context:
|
||||
|
@ -364,7 +364,7 @@
|
|||
(stop-logging-thread))
|
||||
(send/resp 'DONE))]
|
||||
[x (send/error (format "DIDNT MATCH A ~v\n" x))]
|
||||
[else (send/error (format "DIDNT MATCH A\n"))]))))
|
||||
[_ (send/error (format "DIDNT MATCH A\n"))]))))
|
||||
|
||||
(define (parallel-compile-files list-of-files
|
||||
#:worker-count [worker-count (processor-count)]
|
||||
|
|
|
@ -293,7 +293,7 @@
|
|||
(begin
|
||||
(queue/work-done work-queue node wrkr (string-append msg (wrkr/read-all wrkr)))
|
||||
(kill/remove-dead-worker node-worker wrkr))))))]
|
||||
[else
|
||||
[_
|
||||
(log-error (format "parallel-do-event-loop match node-worker failed trying to match: ~e"
|
||||
node-worker))]))
|
||||
(DEBUG_COMM (printf "WAITING ON WORKERS TO RESPOND\n"))
|
||||
|
|
|
@ -1276,7 +1276,7 @@
|
|||
(and (path? base)
|
||||
(equal? (path->directory-path p)
|
||||
(path->directory-path base)))))))]
|
||||
[else
|
||||
[_
|
||||
#t])
|
||||
p)]))
|
||||
(if (and dir
|
||||
|
|
|
@ -301,7 +301,7 @@
|
|||
(not (eq? test-dirs 'else))
|
||||
(cadr test-dirs))]
|
||||
[else (failure)]))]
|
||||
[else
|
||||
[_
|
||||
(error "info-procedure S-expression did not have the expected shape: "
|
||||
v)]))])
|
||||
(unless (and (procedure? info)
|
||||
|
@ -458,7 +458,7 @@
|
|||
((length target-dir-info) . > . 1)
|
||||
print-status)
|
||||
collections]
|
||||
[else
|
||||
[_
|
||||
(error "expected a `unit' pattern, got" u)])))
|
||||
|
||||
;; Cancelled: no collections
|
||||
|
|
|
@ -558,7 +558,7 @@ EOS
|
|||
out))]
|
||||
[#"highest_type" (display highest-type out)]
|
||||
[#"lowest_type" (display lowest-type out)]
|
||||
[else
|
||||
[_
|
||||
(let ([m2 (regexp-match (format "~a, */[*] ([0-9]+) [*]/" (cadr m))
|
||||
styles)])
|
||||
(if m2
|
||||
|
|
|
@ -362,5 +362,5 @@
|
|||
(match v
|
||||
[`(begin ,vs ...)
|
||||
(for-each loop vs)]
|
||||
[else
|
||||
[_
|
||||
(pretty-write (rename-functions (rename-locals v)))])))))))
|
||||
|
|
|
@ -75,7 +75,7 @@
|
|||
;; Strip away a `begin` that's there to record a function name:
|
||||
(match orig-body
|
||||
[`(begin (quote ,_) ,e) e]
|
||||
[else orig-body]))
|
||||
[_ orig-body]))
|
||||
(cond
|
||||
[(let ([result (extract-result body)])
|
||||
(and (pair? result)
|
||||
|
|
|
@ -69,7 +69,7 @@
|
|||
(cons (prune rator #f)
|
||||
(for/list ([rand (in-list rands)])
|
||||
(prune rand #f)))]
|
||||
[else e]))
|
||||
[_ e]))
|
||||
|
||||
(define (get-single-id ids)
|
||||
(and (pair? ids)
|
||||
|
|
|
@ -298,13 +298,13 @@
|
|||
[`(,def ,err-val ,flags ,ret ,name ,args)
|
||||
`(,def ,err-val ,flags ,(update-type ret) ,name
|
||||
,(map (lambda (a) (update-bind a #:as-argument? #t)) args))]
|
||||
[else e]))
|
||||
[_ e]))
|
||||
|
||||
(define (update-type-types e)
|
||||
(match e
|
||||
[`(define-struct-type ,name ,fields)
|
||||
`(define-struct-type ,name ,(map update-bind fields))]
|
||||
[else e]))
|
||||
[_ e]))
|
||||
|
||||
(define content
|
||||
(append
|
||||
|
|
Loading…
Reference in New Issue
Block a user