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

fix extended {read,peek}-char-or-special

Browse Source 
The changes in 08ca76b741 require the primitives to be reclassified
from non-CM to general.

Also, add an internal shortcut for checking arity.
This commit is contained in:
Matthew Flatt 2017-01-15 06:51:57 -07:00
parent 2cf6691439
commit b138c340e1
4 changed files with 39 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/racket-test-core/tests/racket/read.rktl
View File

@ -1098,6 +1098,8 @@
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(parameterize ([read-accept-dot #f])
(err/rt-test (read (open-input-string ".")) exn:fail:read?))
(parameterize ([current-readtable (make-readtable (current-readtable) #\. #\a #f)])
(test '|.| read (open-input-string ".")))
(parameterize ([current-readtable (make-readtable (current-readtable) #\. #\a #f)]

31
racket/src/racket/src/fun.c
View File

@ -2139,6 +2139,37 @@ static Scheme_Object *clone_arity(Scheme_Object *a, int delta, int mode)
return a;
}
int scheme_fast_check_arity(Scheme_Object *p, int a)
/* Faster version of get_or_check_arity() in check mode;
a 0 result means "maybe" */
{
Scheme_Type type;
int mina, maxa;
type = SCHEME_TYPE(p);
if (type == scheme_prim_type) {
mina = ((Scheme_Primitive_Proc *)p)->mina;
maxa = ((Scheme_Primitive_Proc *)p)->mu.maxa;
if (mina < 0)
return 0;
else {
if (maxa > SCHEME_MAX_ARGS)
maxa = -1;
}
} else if (type == scheme_closed_prim_type) {
mina = ((Scheme_Closed_Primitive_Proc *)p)->mina;
maxa = ((Scheme_Closed_Primitive_Proc *)p)->maxa;
if (mina == -2)
return 0;
} else
return 0;
if (a >= mina && (maxa < 0 || a <= maxa))
return 1;
return 0;
}
static Scheme_Object *get_or_check_arity(Scheme_Object *p, intptr_t a, Scheme_Object *bign, int inc_ok)
/* a == -1 => get arity
a == -2 => check for allowing bignum

10
racket/src/racket/src/portfun.c
View File

@ -275,9 +275,9 @@ scheme_init_port_fun(Scheme_Env *env)
GLOBAL_NONCM_PRIM("read-syntax/recursive", read_syntax_recur_f, 0, 5, env);
GLOBAL_PRIM_W_ARITY2("read-language", read_language, 0, 2, 0, -1, env);
GLOBAL_NONCM_PRIM("read-char", read_char, 0, 1, env);
GLOBAL_NONCM_PRIM("read-char-or-special", read_char_spec, 0, 3, env);
GLOBAL_PRIM_W_ARITY2("read-char-or-special", read_char_spec, 0, 3, 0, -1, env);
GLOBAL_NONCM_PRIM("read-byte", read_byte, 0, 1, env);
GLOBAL_NONCM_PRIM("read-byte-or-special", read_byte_spec, 0, 3, env);
GLOBAL_PRIM_W_ARITY2("read-byte-or-special", read_byte_spec, 0, 3, 0, -1, env);
GLOBAL_NONCM_PRIM("read-bytes-line", read_byte_line, 0, 2, env);
GLOBAL_NONCM_PRIM("read-line", read_line, 0, 2, env);
GLOBAL_NONCM_PRIM("read-string", sch_read_string, 1, 2, env);
@ -305,9 +305,9 @@ scheme_init_port_fun(Scheme_Env *env)
GLOBAL_NONCM_PRIM("write-special", scheme_write_special, 1, 2, env);
GLOBAL_NONCM_PRIM("write-special-avail*", scheme_write_special_nonblock, 1, 2, env);
GLOBAL_NONCM_PRIM("peek-char", peek_char, 0, 2, env);
GLOBAL_NONCM_PRIM("peek-char-or-special", peek_char_spec, 0, 4, env);
GLOBAL_PRIM_W_ARITY2("peek-char-or-special", peek_char_spec, 0, 4, 0, -1, env);
GLOBAL_NONCM_PRIM("peek-byte", peek_byte, 0, 2, env);
GLOBAL_NONCM_PRIM("peek-byte-or-special", peek_byte_spec, 0, 5, env);
GLOBAL_PRIM_W_ARITY2("peek-byte-or-special", peek_byte_spec, 0, 5, 0, -1, env);
GLOBAL_NONCM_PRIM("byte-ready?", byte_ready_p, 0, 1, env);
GLOBAL_NONCM_PRIM("char-ready?", char_ready_p, 0, 1, env);
GLOBAL_NONCM_PRIM("newline", newline, 0, 1, env);
@ -3087,7 +3087,7 @@ do_read_char(char *name, int argc, Scheme_Object *argv[], int peek, int spec, in
spec_wrap = argv[pos];
if (SCHEME_FALSEP(spec_wrap))
spec_wrap = NULL;
else
else if (!scheme_fast_check_arity(spec_wrap, 1))
scheme_check_proc_arity2(name, 1, pos, argc, argv, 1);
pos++;
if (argc > pos) {

1
racket/src/racket/src/schpriv.h
View File

@ -4147,6 +4147,7 @@ Scheme_Object *scheme_special_comment_value(Scheme_Object *o);
Scheme_Object *scheme_get_stack_trace(Scheme_Object *mark_set);
XFORM_NONGCING int scheme_fast_check_arity(Scheme_Object *v, int a);
Scheme_Object *scheme_get_or_check_arity(Scheme_Object *p, intptr_t a);
int scheme_native_arity_check(Scheme_Object *closure, int argc);
Scheme_Object *scheme_get_native_arity(Scheme_Object *closure, int mode);