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

Remove memq, memv, member from #%kernel

Browse Source 
These are now implmented purely in Racket on all
platforms.
This commit is contained in:
Asumu Takikawa 2013-06-10 15:18:06 -04:00
parent bab1997e58
commit c305dba649
19 changed files with 796 additions and 932 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/racket/private/define-et-al.rkt
View File

@ -4,7 +4,7 @@
(module define-et-al '#%kernel
(#%require (for-syntax '#%kernel "stx.rkt" "qq-and-or.rkt"
"cond.rkt"))
"member.rkt" "cond.rkt"))
;; No error checking here, because these macros merely help
;; us write macros before the real define and define-syntax

1
collects/racket/private/define-struct.rkt
View File

@ -5,6 +5,7 @@
(#%require "small-scheme.rkt" "define.rkt" "../stxparam.rkt"
(for-syntax '#%kernel "define.rkt"
"procedure-alias.rkt"
"member.rkt"
"stx.rkt" "stxcase-scheme.rkt" "small-scheme.rkt"
"stxloc.rkt" "qqstx.rkt"
"struct-info.rkt"))

2
collects/racket/private/for.rkt
View File

@ -4,12 +4,14 @@
"misc.rkt"
"define.rkt"
"letstx-scheme.rkt"
"member.rkt"
"reverse.rkt"
'#%unsafe
(for-syntax '#%kernel
"stx.rkt"
"qqstx.rkt"
"define.rkt"
"member.rkt"
"small-scheme.rkt"
"stxcase-scheme.rkt"))

1
collects/racket/private/kw.rkt
View File

@ -7,6 +7,7 @@
"stx.rkt"
"small-scheme.rkt"
"stxcase-scheme.rkt"
"member.rkt"
"name.rkt"
"norm-define.rkt"
"qqstx.rkt"

41
collects/racket/private/list.rkt
View File

@ -27,10 +27,7 @@
build-string
build-list
(rename-out [alt-reverse reverse]
[alt-memq memq]
[alt-memv memv]
[alt-member member])
(rename-out [alt-reverse reverse])
compose
compose1)
@ -412,40 +409,4 @@
(mk-simple-compose app1 f g)
(mk-simple-compose app* f g))))
(values compose1 compose)))
(define-values (alt-memq alt-memv alt-member)
(if (eval-jit-enabled)
(let ()
(define-syntax-rule (mk id eq?)
(let ([id
(lambda (v orig-l)
(let loop ([ls orig-l])
(cond
[(null? ls) #f]
[(not (pair? ls))
(bad-list 'id orig-l)]
[(eq? v (car ls)) ls]
[else (loop (cdr ls))])))])
id))
;; Create the `member` function that takes an extra argument
;; Uses `mk` to construct the body
(define-syntax-rule (mk-member id)
(let* ([default (mk member equal?)]
[id (case-lambda
([v orig-l] (default v orig-l))
([v orig-l eq?]
(unless (and (procedure? eq?)
(procedure-arity-includes? eq? 2))
(raise-argument-error
'member
"(procedure-arity-includes/c 2)"
eq?))
((mk member eq?) v orig-l)))])
id))
(values (mk memq eq?)
(mk memv eqv?)
;; Note that this uses `mk-member`
(mk-member member)))
(values memq memv member)))
)

1
collects/racket/private/more-scheme.rkt
View File

@ -4,6 +4,7 @@
(module more-scheme '#%kernel
(#%require "small-scheme.rkt" "define.rkt" '#%paramz "case.rkt" "logger.rkt"
"member.rkt"
(for-syntax '#%kernel "stx.rkt" "small-scheme.rkt" "stxcase-scheme.rkt" "qqstx.rkt"))
(define-syntax case-test

1
collects/racket/private/namespace.rkt
View File

@ -1,5 +1,6 @@
(module namespace "pre-base.rkt"
(require (for-syntax '#%kernel "define.rkt"
"member.rkt"
"stx.rkt" "stxcase-scheme.rkt" "small-scheme.rkt"
"stxloc.rkt"))

3
collects/racket/private/norm-define.rkt
View File

@ -1,6 +1,7 @@
(module norm-define '#%kernel
(#%require "small-scheme.rkt" "stxcase-scheme.rkt" "stx.rkt" "qqstx.rkt")
(#%require "small-scheme.rkt" "stxcase-scheme.rkt"
"member.rkt" "stx.rkt" "qqstx.rkt")
(#%provide normalize-definition)

3
collects/racket/private/old-procs.rkt
View File

@ -2,7 +2,8 @@
(module old-procs '#%kernel
(#%require "small-scheme.rkt"
"more-scheme.rkt"
"define.rkt")
"define.rkt"
"member.rkt")
(#%provide make-namespace
free-identifier=?*

2
collects/racket/private/pre-base.rkt
View File

@ -14,6 +14,7 @@
(prefix printing: "modbeg.rkt")
"for.rkt"
"map.rkt" ; shadows #%kernel bindings
"member.rkt"
"kernstruct.rkt"
"norm-arity.rkt"
"top-int.rkt"
@ -188,6 +189,7 @@
prop:stream in-stream empty-stream make-do-stream
split-for-body)
(all-from "kernstruct.rkt")
(all-from "member.rkt")
#%top-interaction
map for-each andmap ormap

1
collects/racket/private/reqprov.rkt
View File

@ -3,6 +3,7 @@
(for-syntax '#%kernel
"stx.rkt" "stxcase-scheme.rkt" "small-scheme.rkt"
"stxloc.rkt" "qqstx.rkt" "more-scheme.rkt"
"member.rkt"
"../require-transform.rkt"
"../provide-transform.rkt"
"struct-info.rkt"))

3
collects/racket/private/stxcase.rkt
View File

@ -4,7 +4,8 @@
(module stxcase '#%kernel
(#%require "stx.rkt" "small-scheme.rkt" '#%paramz '#%unsafe
"ellipses.rkt"
(for-syntax "stx.rkt" "small-scheme.rkt" "sc.rkt" '#%kernel))
(for-syntax "stx.rkt" "small-scheme.rkt"
"member.rkt" "sc.rkt" '#%kernel))
(-define (datum->syntax/shape orig datum)
(if (syntax? datum)

4
collects/scheme/mzscheme.rkt
View File

@ -21,8 +21,8 @@
(only racket/private/cond old-cond)
;; shadows #%kernel bindings:
(only racket/private/list
assq assv assoc reverse
memq memv member)
assq assv assoc reverse)
racket/private/member
racket/tcp
racket/udp
'#%builtin) ; so it's attached

3
collects/setup/main.rkt
View File

@ -11,7 +11,8 @@
(module main '#%kernel
(#%require '#%min-stx
;; Need to make sure they're here:
'#%builtin)
'#%builtin
racket/private/member)
(when (file-stream-port? (current-output-port))
(file-stream-buffer-mode (current-output-port) 'line))

9
collects/typed-racket/base-env/base-env.rkt
View File

@ -10,8 +10,7 @@
(only-in rnrs/lists-6 fold-left)
'#%paramz
"extra-procs.rkt"
(only-in '#%kernel [apply kernel:apply] [reverse kernel:reverse]
[memq kernel:memq] [memv kernel:memv] [member kernel:member])
(only-in '#%kernel [apply kernel:apply] [reverse kernel:reverse])
(only-in racket/private/pre-base new-apply-proc)
racket/promise racket/system
racket/function
@ -521,18 +520,12 @@
[append (-poly (a) (->* (list) (-lst a) (-lst a)))]
[length (-poly (a) (-> (-lst a) -Index))]
[memq (-poly (a) (-> a (-lst a) (-opt (-lst a))))]
[kernel:memq (-poly (a) (-> a (-lst a) (-opt (-lst a))))]
[memv (-poly (a) (-> a (-lst a) (-opt (-lst a))))]
[kernel:memv (-poly (a) (-> a (-lst a) (-opt (-lst a))))]
[memf (-poly (a) ((a . -> . Univ) (-lst a) . -> . (-opt (-lst a))))]
[member (-poly (a)
(cl->* (a (-lst a) . -> . (-opt (-lst a)))
(a (-lst a) (-> a a Univ)
. -> . (-opt (-lst a)))))]
[kernel:member (-poly (a)
(cl->* (a (-lst a) . -> . (-opt (-lst a)))
(a (-lst a) (-> a a Univ)
. -> . (-opt (-lst a)))))]
[findf (-poly (a) ((a . -> . B) (-lst a) . -> . (-opt a)))]
[char=? (->* (list -Char -Char) -Char B)]

1542
src/racket/src/cstartup.inc
View File

File diff suppressed because it is too large Load Diff

103
src/racket/src/list.c
View File

@ -60,9 +60,6 @@ static Scheme_Object *immutablep (int argc, Scheme_Object *argv[]);
static Scheme_Object *length_prim (int argc, Scheme_Object *argv[]);
static Scheme_Object *append_prim (int argc, Scheme_Object *argv[]);
static Scheme_Object *reverse_prim (int argc, Scheme_Object *argv[]);
static Scheme_Object *memv (int argc, Scheme_Object *argv[]);
static Scheme_Object *memq (int argc, Scheme_Object *argv[]);
static Scheme_Object *member (int argc, Scheme_Object *argv[]);
static Scheme_Object *assv (int argc, Scheme_Object *argv[]);
static Scheme_Object *assq (int argc, Scheme_Object *argv[]);
static Scheme_Object *assoc (int argc, Scheme_Object *argv[]);
@ -297,21 +294,6 @@ scheme_init_list (Scheme_Env *env)
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED);
scheme_add_global_constant ("list-ref",p, env);
scheme_add_global_constant ("memq",
scheme_make_immed_prim(memq,
"memq",
2, 2),
env);
scheme_add_global_constant ("memv",
scheme_make_immed_prim(memv,
"memv",
2, 2),
env);
scheme_add_global_constant ("member",
scheme_make_immed_prim(member,
"member",
2, 3),
env);
scheme_add_global_constant ("assq",
scheme_make_immed_prim(assq,
"assq",
@ -1455,91 +1437,6 @@ static void mem_past_end(const char *name, Scheme_Object *s_arg, Scheme_Object *
NULL);
}
#define GEN_MEM(name, scheme_name, comp) \
static Scheme_Object * \
name (int argc, Scheme_Object *argv[]) \
{ \
Scheme_Object *list, *turtle; \
list = turtle = argv[1]; \
while (SCHEME_PAIRP(list)) \
{ \
if (comp (argv[0], SCHEME_CAR (list))) \
{ \
return list; \
} \
list = SCHEME_CDR (list); \
if (SCHEME_PAIRP(list)) { \
if (comp (argv[0], SCHEME_CAR (list))) \
{ \
return list; \
} \
if (SAME_OBJ(list, turtle)) break; \
list = SCHEME_CDR (list); \
turtle = SCHEME_CDR (turtle); \
SCHEME_USE_FUEL(1); \
} \
} \
if (!SCHEME_NULLP(list)) { \
mem_past_end(#scheme_name, argv[0], argv[1]); \
} \
return (scheme_false); \
}
GEN_MEM(memv, memv, scheme_eqv)
GEN_MEM(memq, memq, SAME_OBJ)
static Scheme_Object *member(int argc, Scheme_Object *argv[])
{
Scheme_Object *list, *turtle;
Scheme_Object *comp = NULL;
Scheme_Object *a[2];
list = turtle = argv[1];
if (argc > 2) {
if (SCHEME_PROCP(argv[2]) && scheme_check_proc_arity("member", 2, 2, 3, argv)) {
comp = argv[2];
} else {
scheme_wrong_contract("member", "(procedure-arity-includes/c 2)", 2, argc, argv);
}
}
while (SCHEME_PAIRP(list)) {
if (comp) {
a[0] = argv[0];
a[1] = SCHEME_CAR(list);
if (SCHEME_TRUEP(scheme_apply(comp, 2, a))) {
return list;
}
} else {
if (scheme_equal(argv[0], SCHEME_CAR(list))) {
return list;
}
}
list = SCHEME_CDR(list);
if (SCHEME_PAIRP(list)) {
if (comp) {
a[0] = argv[0];
a[1] = SCHEME_CAR(list);
if (SCHEME_TRUEP(scheme_apply(comp, 2, a))) {
return list;
}
} else {
if (scheme_equal(argv[0], SCHEME_CAR(list))) {
return list;
}
}
if (SAME_OBJ(list, turtle)) break;
list = SCHEME_CDR (list);
turtle = SCHEME_CDR (turtle);
SCHEME_USE_FUEL(1);
}
}
if (!SCHEME_NULLP(list)) {
mem_past_end("member", argv[0], argv[1]);
}
return (scheme_false);
}
static void ass_non_pair(const char *name, Scheme_Object *np, Scheme_Object *s_arg, Scheme_Object *arg)
{
scheme_contract_error(name,

2
src/racket/src/schminc.h
View File

@ -14,7 +14,7 @@
#define USE_COMPILED_STARTUP 1
#define EXPECTED_PRIM_COUNT 1108
#define EXPECTED_PRIM_COUNT 1105
#define EXPECTED_UNSAFE_COUNT 100
#define EXPECTED_FLFXNUM_COUNT 69
#define EXPECTED_EXTFL_COUNT 45

4
src/racket/src/schvers.h
View File

@ -13,12 +13,12 @@
consistently.)
*/
#define MZSCHEME_VERSION "5.3.4.11"
#define MZSCHEME_VERSION "5.3.4.12"
#define MZSCHEME_VERSION_X 5
#define MZSCHEME_VERSION_Y 3
#define MZSCHEME_VERSION_Z 4
#define MZSCHEME_VERSION_W 11
#define MZSCHEME_VERSION_W 12
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)