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

fix bugs related to changes in keyword-argument error messages

Browse Source 
svn: r15098
This commit is contained in:
Matthew Flatt 2009-06-05 21:45:05 +00:00
parent 74cb273fb7
commit 62325eb7cf
1 changed files with 8 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -99,6 +99,9 @@
struct:okp struct:okp
0 0 #f)) 0 0 #f))
(define-values (prop:named-keyword-procedure named-keyword-procedure? keyword-procedure-name)
(make-struct-type-property 'named-keyword-procedure))
;; Constructor generator for a procedure with a required keyword. ;; Constructor generator for a procedure with a required keyword.
;; (This is used with lift-expression, so that the same constructor ;; (This is used with lift-expression, so that the same constructor
;; is used for each evaluation of a keyword lambda.) ;; is used for each evaluation of a keyword lambda.)
@ -111,7 +114,8 @@
struct:keyword-method struct:keyword-method
struct:keyword-procedure) struct:keyword-procedure)
0 0 #f 0 0 #f
(list (cons prop:arity-string generate-arity-string)) (list (cons prop:arity-string generate-arity-string)
(cons prop:named-keyword-procedure name))
(current-inspector) fail-proc)]) (current-inspector) fail-proc)])
mk)) mk))
@ -788,8 +792,8 @@
(apply (apply
raise-type-error 'x "x" 0 'x raise-type-error 'x "x" 0 'x
(append args (apply append (map list kws kw-args))))))] (append args (apply append (map list kws kw-args))))))]
[proc-name (lambda (p) (or (and (keyword-procedure? p) [proc-name (lambda (p) (or (and (named-keyword-procedure? p)
(substring (symbol->string (object-name p)) 10)) ; strip "procedure:" (keyword-procedure-name p))
(object-name p) (object-name p)
p))]) p))])
(raise (raise
@ -812,7 +816,7 @@
(format (format
(string-append (string-append
"~a: no case matching ~a non-keyword" "~a: no case matching ~a non-keyword"
" argument~a for: ~e; ~a") " argument~a; ~a")
(proc-name p) (proc-name p)
(- n 2) (if (= 1 (- n 2)) "" "s") args-str))) (- n 2) (if (= 1 (- n 2)) "" "s") args-str)))
(current-continuation-marks))))))))) (current-continuation-marks)))))))))