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

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

@ -750,41 +750,32 @@
;; 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) (and (new-procedure? p) 'method)))])
'method))
#f))])
(if p2 (if p2
;; Maybe the target is ok: ;; Maybe the target is ok:
(if (eq? p2 'method) (if (eq? p2 'method)
;; Build wrapper method: ;; Build wrapper method:
(let ([p3 (keyword-procedure-extract/method kws (add1 n) (let ([p3 (keyword-procedure-extract/method
(new-procedure-ref p) kws (add1 n) (new-procedure-ref p) (add1 method-n))])
(add1 method-n))])
(lambda (kws kw-args . args) (lambda (kws kw-args . args)
(apply p3 kws kw-args (cons p args)))) (apply p3 kws kw-args (cons p args))))
;; Recur: ;; Recur:
(keyword-procedure-extract/method kws n p2 method-n)) (keyword-procedure-extract/method kws n p2 method-n))
;; Not ok, period: ;; Not ok, period:
(lambda (kws kw-args . args) (lambda (kws kw-args . args)
(let-values ([(missing-kw extra-kw) (define-values (missing-kw extra-kw)
(if (keyword-procedure? p) (if (keyword-procedure? p)
(check-kw-args p kws) (check-kw-args p kws)
(values #f (car kws)))] (values #f (car kws))))
[(n) (let ([method-n (+ method-n (let ([n (let ([method-n
(if (or (keyword-method? p) (+ method-n
(okm? p)) (if (or (keyword-method? p) (okm? p)) 1 0))])
1 (if (n . >= . method-n) (- n method-n) n))]
0))]) [args-str
(if (n . >= . method-n) (if (and (null? args) (null? kws))
(- n method-n)
n))])
(let ([args-str
(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?
@ -793,9 +784,9 @@
(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
@ -804,32 +795,24 @@
(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
args-str)
(format (format
(string-append (string-append
"procedure application: expected a procedure that" "procedure application: expected a procedure that"
" accepts keyword arguments, given ~e; ~a") " accepts keyword arguments, given ~e; ~a")
p p args-str))
args-str))
(if missing-kw (if missing-kw
(format (format
(string-append (string-append
"procedure application: procedure: ~e; requires" "procedure application: procedure: ~e; requires"
" an argument with keyword ~a, not supplied; ~a") " an argument with keyword ~a, not supplied; ~a")
p p missing-kw args-str)
missing-kw
args-str)
(format (format
(string-append (string-append
"procedure application: no case matching ~a non-keyword" "procedure application: no case matching ~a non-keyword"
" argument~a for: ~e; ~a") " argument~a for: ~e; ~a")
(- n 2) (- n 2) (if (= 1 (- n 2)) "" "s") p args-str)))
(if (= 1 (- n 2)) "" "s") (current-continuation-marks)))))))))
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))