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

reformat some

Browse Source 
svn: r14435
This commit is contained in:
Eli Barzilay 2009-04-06 11:17:15 +00:00
parent b2959e3308
commit 2cc94cbf02
1 changed files with 65 additions and 82 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

147
collects/scheme/private/kw.ss
View File

@ -747,89 +747,72 @@
(procedure-arity-includes? (keyword-procedure-proc p) n) (procedure-arity-includes? (keyword-procedure-proc p) n)
(let-values ([(missing-kw extra-kw) (check-kw-args p kws)]) (let-values ([(missing-kw extra-kw) (check-kw-args p kws)])
(and (not missing-kw) (not extra-kw)))) (and (not missing-kw) (not extra-kw))))
;; Ok: ;; Ok:
(keyword-procedure-proc p) (keyword-procedure-proc p)
;; Not ok, so far: ;; Not ok, so far:
(let ([p2 (if (keyword-procedure? p) (let ([p2 (and (not (keyword-procedure? p))
#f (procedure? p)
(if (procedure? p) (or (procedure-extract-target p)
(or (procedure-extract-target p) (and (new-procedure? p) 'method)))])
(and (new-procedure? p) (if p2
'method)) ;; Maybe the target is ok:
#f))]) (if (eq? p2 'method)
(if p2 ;; Build wrapper method:
;; Maybe the target is ok: (let ([p3 (keyword-procedure-extract/method
(if (eq? p2 'method) kws (add1 n) (new-procedure-ref p) (add1 method-n))])
;; Build wrapper method:
(let ([p3 (keyword-procedure-extract/method kws (add1 n)
(new-procedure-ref p)
(add1 method-n))])
(lambda (kws kw-args . args)
(apply p3 kws kw-args (cons p args))))
;; Recur:
(keyword-procedure-extract/method kws n p2 method-n))
;; Not ok, period:
(lambda (kws kw-args . args) (lambda (kws kw-args . args)
(let-values ([(missing-kw extra-kw) (apply p3 kws kw-args (cons p args))))
(if (keyword-procedure? p) ;; Recur:
(check-kw-args p kws) (keyword-procedure-extract/method kws n p2 method-n))
(values #f (car kws)))] ;; Not ok, period:
[(n) (let ([method-n (+ method-n (lambda (kws kw-args . args)
(if (or (keyword-method? p) (define-values (missing-kw extra-kw)
(okm? p)) (if (keyword-procedure? p)
1 (check-kw-args p kws)
0))]) (values #f (car kws))))
(if (n . >= . method-n) (let ([n (let ([method-n
(- n method-n) (+ method-n
n))]) (if (or (keyword-method? p) (okm? p)) 1 0))])
(let ([args-str (if (n . >= . method-n) (- n method-n) n))]
(if (and (null? args) [args-str
(null? kws)) (if (and (null? args) (null? kws))
"no arguments supplied" "no arguments supplied"
;; Hack to format arguments: ;; Hack to format arguments:
(with-handlers ([exn:fail? (with-handlers ([exn:fail?
(lambda (exn) (lambda (exn)
(format "arguments were: ~a" (format "arguments were: ~a"
(cadr (regexp-match (cadr (regexp-match
#rx"other arguments were: (.*)$" #rx"other arguments were: (.*)$"
(exn-message exn)))))]) (exn-message exn)))))])
(apply raise-type-error 'x "x" 0 'x (apply
(append args raise-type-error 'x "x" 0 'x
(apply append (map list kws kw-args))))))]) (append args (apply append (map list kws kw-args))))))])
(raise (raise
(make-exn:fail:contract (make-exn:fail:contract
(if extra-kw (if extra-kw
(if (keyword-procedure? p) (if (keyword-procedure? p)
(format (format
(string-append (string-append
"procedure application: procedure: ~e;" "procedure application: procedure: ~e;"
" does not expect an argument with keyword ~a; ~a") " does not expect an argument with keyword ~a; ~a")
p p extra-kw args-str)
extra-kw (format
args-str) (string-append
(format "procedure application: expected a procedure that"
(string-append " accepts keyword arguments, given ~e; ~a")
"procedure application: expected a procedure that" p args-str))
" accepts keyword arguments, given ~e; ~a") (if missing-kw
p (format
args-str)) (string-append
(if missing-kw "procedure application: procedure: ~e; requires"
(format " an argument with keyword ~a, not supplied; ~a")
(string-append p missing-kw args-str)
"procedure application: procedure: ~e; requires" (format
" an argument with keyword ~a, not supplied; ~a") (string-append
p "procedure application: no case matching ~a non-keyword"
missing-kw " argument~a for: ~e; ~a")
args-str) (- n 2) (if (= 1 (- n 2)) "" "s") p args-str)))
(format (current-continuation-marks)))))))))
(string-append
"procedure application: no case matching ~a non-keyword"
" argument~a for: ~e; ~a")
(- n 2)
(if (= 1 (- n 2)) "" "s")
p
args-str)))
(current-continuation-marks))))))))))
(define (keyword-procedure-extract kws n p) (define (keyword-procedure-extract kws n p)
(keyword-procedure-extract/method kws n p 0)) (keyword-procedure-extract/method kws n p 0))