~ chicken-core (chicken-5) 513ba59749622230bfc8623c96d63beff9d09c61
commit 513ba59749622230bfc8623c96d63beff9d09c61
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Fri Apr 9 11:50:58 2010 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Fri Apr 9 11:50:58 2010 +0200
keyword-argument speedup, needs more testing
diff --git a/c-platform.scm b/c-platform.scm
index 17085013..8be0d25f 100644
--- a/c-platform.scm
+++ b/c-platform.scm
@@ -151,7 +151,7 @@
pointer-u32-ref pointer-s32-ref pointer-f32-ref pointer-f64-ref
pointer-u8-set! pointer-s8-set! pointer-u16-set! pointer-s16-set!
pointer-u32-set! pointer-s32-set! pointer-f32-set! pointer-f64-set!
- printf sprintf format) )
+ printf sprintf format get-keyword) )
(define internal-bindings
'(##sys#slot ##sys#setslot ##sys#block-ref ##sys#block-set!
@@ -163,7 +163,7 @@
##sys#fudge ##sys#immediate? ##sys#direct-return ##sys#context-switch
##sys#make-structure ##sys#apply ##sys#apply-values ##sys#continuation-graft
##sys#bytevector? ##sys#make-vector ##sys#setter ##sys#car ##sys#cdr ##sys#pair?
- ##sys#eq? ##sys#list? ##sys#vector? ##sys#eqv?
+ ##sys#eq? ##sys#list? ##sys#vector? ##sys#eqv? ##sys#get-keyword
##sys#foreign-char-argument ##sys#foreign-fixnum-argument ##sys#foreign-flonum-argument
##sys#foreign-block-argument ##sys#foreign-number-vector-argument
##sys#foreign-string-argument ##sys#foreign-pointer-argument ##sys#void
@@ -186,7 +186,7 @@
s32vector->blob/shared read-string read-string! o
address->pointer pointer->address
##sys#make-structure print* ##sys#make-vector ##sys#apply ##sys#setislot ##sys#block-ref
- ##sys#byte ##sys#setbyte
+ ##sys#byte ##sys#setbyte ##sys#get-keyword get-keyword
u8vector-length s8vector-length u16vector-length s16vector-length u32vector-length s32vector-length
f32vector-length f64vector-length ##sys#apply-values ##sys#setter setter
f32vector-set! f64vector-set!
@@ -1108,3 +1108,6 @@
(rewrite 'substring-ci=? 23 2 '##sys#substring-ci=? 0 0 #f)
(rewrite 'substring-index 23 2 '##sys#substring-index 0)
(rewrite 'substring-index-ci 23 2 '##sys#substring-index-ci 0)
+
+(rewrite 'get-keyword 7 2 "C_i_get_keyword" #f #t)
+(rewrite '##sys#get-keyword 7 2 "C_i_get_keyword" #f #t)
diff --git a/chicken.h b/chicken.h
index 4f122484..73de3b55 100644
--- a/chicken.h
+++ b/chicken.h
@@ -1783,6 +1783,7 @@ C_fctexport C_word C_fcall C_i_o_fixnum_xor(C_word x, C_word y) C_regparm;
C_fctexport C_word C_fcall C_a_i_flonum_round_proper(C_word **a, int c, C_word n) C_regparm;
C_fctexport C_word C_fcall C_i_getprop(C_word sym, C_word prop, C_word def) C_regparm;
C_fctexport C_word C_fcall C_putprop(C_word **a, C_word sym, C_word prop, C_word val) C_regparm;
+C_fctexport C_word C_fcall C_i_get_keyword(C_word key, C_word args, C_word def) C_regparm;
C_fctexport C_word C_fcall C_i_foreign_char_argumentp(C_word x) C_regparm;
C_fctexport C_word C_fcall C_i_foreign_fixnum_argumentp(C_word x) C_regparm;
diff --git a/expand.scm b/expand.scm
index 996c45ff..fc9421bf 100644
--- a/expand.scm
+++ b/expand.scm
@@ -369,11 +369,11 @@
`((,%let*
,(map (lambda (k)
(let ([s (car k)])
- `(,s (##sys#get-keyword
+ `(,s (##sys#get-keyword
',(->keyword s) ,rvar
,@(if (pair? (cdr k))
`((,%lambda () ,@(cdr k)))
- '() ) ) ) ) )
+ '())))))
(reverse key) )
,@body) ) ) ] )
(cond [(null? opt) body]
diff --git a/library.scm b/library.scm
index 7e45b9bf..82c2dbe6 100644
--- a/library.scm
+++ b/library.scm
@@ -1223,15 +1223,14 @@ EOF
(##sys#symbol->string kw)
(##sys#signal-hook #:type-error 'keyword->string "bad argument type - not a keyword" kw) ) ) ) )
-(define (##sys#get-keyword key args0 . default)
- (##sys#check-list args0 'get-keyword)
- (let ([a (memq key args0)])
- (if a
- (let ([r (##sys#slot a 1)])
- (if (pair? r)
- (##sys#slot r 0)
- (##sys#error 'get-keyword "missing keyword argument" args0 key) ) )
- (and (pair? default) ((car default))) ) ) )
+(define ##sys#get-keyword
+ (let ((tag (list 'tag)))
+ (lambda (key args #!optional thunk)
+ (##sys#check-list args 'get-keyword)
+ (let ((r (##core#inline "C_i_get_keyword" key args tag)))
+ (if (eq? r tag)
+ (and thunk (thunk))
+ r)))))
(define get-keyword ##sys#get-keyword)
diff --git a/runtime.c b/runtime.c
index c7214f47..73498f64 100644
--- a/runtime.c
+++ b/runtime.c
@@ -8729,3 +8729,29 @@ C_putprop(C_word **ptr, C_word sym, C_word prop, C_word val)
C_mutate(&C_block_item(sym, 2), pl);
return val;
}
+
+
+C_regparm C_word C_fcall
+C_i_get_keyword(C_word kw, C_word args, C_word def)
+{
+ while(!C_immediatep(args)) {
+ if(C_block_header(args) == C_PAIR_TAG) {
+ if(kw == C_u_i_car(args)) {
+ args = C_u_i_cdr(args);
+
+ if(C_immediatep(args) || C_block_header(args) != C_PAIR_TAG)
+ return def;
+ else return C_u_i_car(args);
+ }
+ else {
+ args = C_u_i_cdr(args);
+
+ if(C_immediatep(args) || C_block_header(args) != C_PAIR_TAG)
+ return def;
+ else args = C_u_i_cdr(args);
+ }
+ }
+ }
+
+ return def;
+}
Trap