~ chicken-core (chicken-5) 664036a3b78a62e13bbf7c089f7ee770b28d029d
commit 664036a3b78a62e13bbf7c089f7ee770b28d029d
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Fri Mar 26 11:45:41 2010 +0100
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Fri Mar 26 11:45:41 2010 +0100
added fxodd? and fxeven?; expander tuning; get/put implemented in C
diff --git a/c-platform.scm b/c-platform.scm
index 87f960c8..17085013 100644
--- a/c-platform.scm
+++ b/c-platform.scm
@@ -125,7 +125,7 @@
(define default-extended-bindings
'(bitwise-and bitwise-ior bitwise-xor bitwise-not add1 sub1 fx+ fx- fx* fx/ fxmod o
fx= fx> fx< fx>= fx<= fixnum? fxneg fxmax fxmin identity fp+ fp- fp* fp/ fpmin fpmax fpneg
- fp> fp< fp= fp>= fp<= fxand fxnot fxior fxxor fxshr fxshl bit-set?
+ fp> fp< fp= fp>= fp<= fxand fxnot fxior fxxor fxshr fxshl bit-set? fxodd? fxeven?
fpfloor fpceiling fptruncate fpround fpsin fpcos fptan fpasin fpacos fpatan
fpatan2 fpexp fpexpt fplog fpsqrt fpabs fpinteger?
arithmetic-shift void flush-output thread-specific thread-specific-set!
@@ -785,10 +785,11 @@
(rewrite 'odd? 14 'fixnum 1 "C_i_fixnumoddp" "C_i_fixnumoddp")
(rewrite 'remainder 14 'fixnum 2 "C_fixnum_modulo" "C_fixnum_modulo")
-(rewrite 'even? 2 1 "C_i_evenp" #t)
-(rewrite 'even? 2 1 "C_u_i_evenp" #f)
-(rewrite 'odd? 2 1 "C_i_oddp" #t)
-(rewrite 'odd? 2 1 "C_u_i_oddp" #f)
+(rewrite 'even? 17 1 "C_i_evenp" "C_u_i_evenp")
+(rewrite 'odd? 17 1 "C_i_oddp" "C_u_i_oddp")
+
+(rewrite 'fxodd? 2 1 "C_fixnumoddp" #t)
+(rewrite 'fxeven? 2 1 "C_fixnumevenp" #t)
(rewrite 'floor 15 'flonum 'fixnum 'fpfloor #f)
(rewrite 'ceiling 15 'flonum 'fixnum 'fpceiling #f)
diff --git a/chicken.h b/chicken.h
index f142b641..8e9e539e 100644
--- a/chicken.h
+++ b/chicken.h
@@ -1194,6 +1194,7 @@ extern double trunc(double);
#define C_i_set_i_slot(x, i, y) (C_set_block_item(x, C_unfix(i), y), C_SCHEME_UNDEFINED)
#define C_u_i_set_car(p, x) (C_mutate(&C_u_i_car(p), x), C_SCHEME_UNDEFINED)
#define C_u_i_set_cdr(p, x) (C_mutate(&C_u_i_cdr(p), x), C_SCHEME_UNDEFINED)
+#define C_a_i_putprop(p, c, x, y, z) C_putprop(p, x, y, z)
#define C_i_not(x) (C_truep(x) ? C_SCHEME_FALSE : C_SCHEME_TRUE)
#define C_i_equalp(x, y) C_mk_bool(C_equalp((x), (y)))
@@ -1719,7 +1720,6 @@ C_fctexport C_word C_fcall C_i_string_ref(C_word s, C_word i) C_regparm;
C_fctexport C_word C_fcall C_i_vector_length(C_word v) C_regparm;
C_fctexport C_word C_fcall C_i_string_length(C_word s) C_regparm;
C_fctexport C_word C_fcall C_i_assq(C_word x, C_word lst) C_regparm;
-C_fctexport C_word C_fcall C_u_i_assq(C_word x, C_word lst) C_regparm;
C_fctexport C_word C_fcall C_i_assv(C_word x, C_word lst) C_regparm;
C_fctexport C_word C_fcall C_i_assoc(C_word x, C_word lst) C_regparm;
C_fctexport C_word C_fcall C_i_memq(C_word x, C_word lst) C_regparm;
@@ -1780,6 +1780,8 @@ C_fctexport C_word C_fcall C_i_o_fixnum_and(C_word x, C_word y) C_regparm;
C_fctexport C_word C_fcall C_i_o_fixnum_ior(C_word x, C_word y) C_regparm;
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_foreign_char_argumentp(C_word x) C_regparm;
C_fctexport C_word C_fcall C_i_foreign_fixnum_argumentp(C_word x) C_regparm;
@@ -2187,6 +2189,21 @@ C_inline C_word C_i_safe_pointerp(C_word x)
}
+C_inline C_word C_u_i_assq(C_word x, C_word lst)
+{
+ C_word a;
+
+ while(!C_immediatep(lst)) {
+ a = C_u_i_car(lst);
+
+ if(C_u_i_car(a) == x) return a;
+ else lst = C_u_i_cdr(lst);
+ }
+
+ return C_SCHEME_FALSE;
+}
+
+
#ifdef C_PRIVATE_REPOSITORY
# if defined(C_MACOSX) && defined(C_GUI)
# include <CoreFoundation/CoreFoundation.h>
diff --git a/expand.scm b/expand.scm
index 24d0f678..73d4b9e5 100644
--- a/expand.scm
+++ b/expand.scm
@@ -30,13 +30,12 @@
(fixnum)
(hide match-expression
macro-alias module-indirect-exports
- d dd dm dc map-se merge-se
+ d dd dm dx map-se merge-se
lookup check-for-redef)
(not inline ##sys#syntax-error-hook ##sys#compiler-syntax-hook
##sys#alias-global-hook ##sys#toplevel-definition-hook))
-
(set! ##sys#features
(append '(#:hygienic-macros #:syntax-rules #:explicit-renaming) ##sys#features))
@@ -62,6 +61,12 @@
(define-syntax dm (syntax-rules () ((_ . _) (void))))
(define-syntax dx (syntax-rules () ((_ . _) (void)))) )
+(define-inline (getp sym prop)
+ (##core#inline "C_i_getprop" sym prop #f))
+
+(define-inline (putp sym prop val)
+ (##core#inline_allocate ("C_a_i_putprop" 8) sym prop val))
+
;;; Syntactic environments
@@ -69,8 +74,8 @@
(define ##sys#current-meta-environment (make-parameter '()))
(define (lookup id se)
- (cond ((assq id se) => cdr)
- ((##sys#get id '##core#macro-alias))
+ (cond ((##core#inline "C_u_i_assq" id se) => cdr)
+ ((getp id '##core#macro-alias))
(else #f)))
(define (macro-alias var se)
@@ -82,8 +87,8 @@
var
(let* ((alias (gensym var))
(ua (or (lookup var se) var)))
- (##sys#put! alias '##core#macro-alias ua)
- (##sys#put! alias '##core#real-name var)
+ (putp alias '##core#macro-alias ua)
+ (putp alias '##core#real-name var)
(dd "aliasing " alias " (real: " var ") to "
(if (pair? ua)
'<macro>
@@ -104,8 +109,8 @@
((symbol? x)
(let ((x2 (if se
(lookup x se)
- (get x '##core#macro-alias) ) ) )
- (cond ((get x '##core#real-name))
+ (getp x '##core#macro-alias) ) ) )
+ (cond ((getp x '##core#real-name))
((and alias (not (assq x se)))
(##sys#alias-global-hook x #f))
((not x2) x)
@@ -203,6 +208,7 @@
ex) )
(let ((exp2
(if cs
+ ;; compiler-syntax may "fall through"
(fluid-let ((##sys#syntax-rules-mismatch (lambda (input) exp))) ; a bit of a hack
(handler exp se dse))
(handler exp se dse))) )
@@ -217,7 +223,7 @@
(define (expand head exp mdef)
(dd `(EXPAND:
,head
- ,(cond ((##sys#get head '##core#macro-alias) =>
+ ,(cond ((getp head '##core#macro-alias) =>
(lambda (a) (if (symbol? a) a '<macro>)) )
(else '_))
,exp
@@ -256,7 +262,7 @@
,@(##sys#map cadr bs) )
#t) ) ]
[else (values exp #f)] ) ) ]
- ((and cs? (symbol? head2) (##sys#get head2 '##compiler#compiler-syntax)) =>
+ ((and cs? (symbol? head2) (getp head2 '##compiler#compiler-syntax)) =>
(lambda (cs)
(let ((result (call-handler head (car cs) exp (cdr cs) #t)))
(cond ((eq? result exp) (expand head exp head2))
@@ -287,11 +293,11 @@
(##sys#module-rename sym (module-name mod))))
(else sym)))
(cond ((##sys#qualified-symbol? sym) sym)
- ((##sys#get sym '##core#primitive) =>
+ ((getp sym '##core#primitive) =>
(lambda (p)
(dm "(ALIAS) primitive: " p)
p))
- ((##sys#get sym '##core#aliased)
+ ((getp sym '##core#aliased)
(dm "(ALIAS) marked: " sym)
sym)
((assq sym (##sys#current-environment)) =>
@@ -300,7 +306,7 @@
(let ((sym2 (cdr a)))
(if (pair? sym2) ; macro (*** can this be?)
(mrename sym)
- (or (##sys#get sym2 '##core#primitive) sym2)))))
+ (or (getp sym2 '##core#primitive) sym2)))))
(else (mrename sym))))
@@ -739,16 +745,16 @@
(f #t (compare (vector-ref s1 i) (vector-ref s2 i))))
((or (fx>= i len) (not f)) f))))))
((and (symbol? s1) (symbol? s2))
- (let ((ss1 (or (##sys#get s1 '##core#macro-alias)
+ (let ((ss1 (or (getp s1 '##core#macro-alias)
(lookup2 1 s1 dse)
s1) )
- (ss2 (or (##sys#get s2 '##core#macro-alias)
+ (ss2 (or (getp s2 '##core#macro-alias)
(lookup2 2 s2 dse)
s2) ) )
(cond ((symbol? ss1)
(cond ((symbol? ss2)
- (eq? (or (##sys#get ss1 '##core#primitive) ss1)
- (or (##sys#get ss2 '##core#primitive) ss2)))
+ (eq? (or (getp ss1 '##core#primitive) ss1)
+ (or (getp ss2 '##core#primitive) ss2)))
((assq ss1 (##sys#macro-environment)) =>
(lambda (a) (eq? (cdr a) ss2)))
(else #f) ) )
@@ -899,7 +905,7 @@
(lambda (imp)
(let* ((id (car imp))
(aid (cdr imp))
- (prim (##sys#get aid '##core#primitive)))
+ (prim (getp aid '##core#primitive)))
(when prim
(set! prims (cons imp prims)))
(and-let* ((a (assq id (import-env)))
@@ -935,7 +941,7 @@
(define (##sys#mark-primitive prims)
(for-each
- (lambda (a) (##sys#put! (cdr a) '##core#primitive (car a)))
+ (lambda (a) (putp (cdr a) '##core#primitive (car a)))
prims))
(##sys#extend-macro-environment
@@ -1561,7 +1567,7 @@
(lambda (imp)
(when (and (symbol? (cdr imp)) (not (eq? (car imp) (cdr imp))))
(dm `(MARKING: ,(cdr imp)))
- (##sys#put! (cdr imp) '##core#aliased #t)))
+ (putp (cdr imp) '##core#aliased #t)))
se))
(define (module-indirect-exports mod)
@@ -1708,7 +1714,7 @@
(let ((palias
(##sys#string->symbol
(##sys#string-append "#%" (##sys#slot sym 1)))))
- (##sys#put! palias '##core#primitive sym)
+ (putp palias '##core#primitive sym)
palias))
(define (##sys#register-primitive-module name vexports #!optional (sexports '()))
@@ -1790,7 +1796,7 @@
(unless (memq u elist)
(set! missing #t)
(##sys#warn "reference to possibly unbound identifier" u)
- (and-let* ((a (##sys#get u '##core#db)))
+ (and-let* ((a (getp u '##core#db)))
(if (= 1 (length a))
(##sys#warn
(string-append
diff --git a/library.scm b/library.scm
index cd0dbc2f..fcc476d5 100644
--- a/library.scm
+++ b/library.scm
@@ -728,6 +728,8 @@ EOF
(define (fxnot x) (##core#inline "C_fixnum_not" x))
(define (fxshl x y) (##core#inline "C_fixnum_shift_left" x y))
(define (fxshr x y) (##core#inline "C_fixnum_shift_right" x y))
+(define (fxodd? x) (##core#inline "C_i_fixnumoddp" x))
+(define (fxeven? x) (##core#inline "C_i_fixnumevenp" x))
(define-inline (fx-check-divison-by-zero x y loc)
(when (eq? 0 y)
@@ -4563,20 +4565,13 @@ EOF
(define (##sys#put! sym prop val)
(##sys#check-symbol sym 'put!)
- (let loop ((plist (##sys#slot sym 2)))
- (cond ((null? plist) (##sys#setslot sym 2 (cons prop (cons val (##sys#slot sym 2)))) )
- ((eq? (##sys#slot plist 0) prop) (##sys#setslot (##sys#slot plist 1) 0 val))
- (else (loop (##sys#slot (##sys#slot plist 1) 1)))) )
- val)
+ (##core#inline_allocate ("C_a_i_putprop" 8) sym prop val) )
(define put! ##sys#put!)
-(define (##sys#get sym prop . default)
+(define (##sys#get sym prop #!optional default)
(##sys#check-symbol sym 'get)
- (let loop ((plist (##sys#slot sym 2)))
- (cond ((null? plist) (optional default #f))
- ((eq? (##sys#slot plist 0) prop) (##sys#slot (##sys#slot plist 1) 0))
- (else (loop (##sys#slot (##sys#slot plist 1) 1))))) )
+ (##core#inline "C_i_getprop" sym prop default))
(define get (getter-with-setter ##sys#get put!))
@@ -4602,7 +4597,11 @@ EOF
(lambda (sym lst)
(##sys#check-symbol sym 'symbol-plist)
(##sys#check-list lst 'symbol-plist/setter)
- (##sys#setslot sym 2 lst) ) ) )
+ (if (##core#inline "C_i_fixnumevenp" (##core#inline "C_i_length" lst))
+ (##sys#setslot sym 2 lst)
+ (##sys#signal-hook
+ #:type-error "property-list must be of even length"
+ lst sym)))))
(define (get-properties sym props)
(##sys#check-symbol sym 'get-properties)
diff --git a/manual/Unit library b/manual/Unit library
index 74ec955e..a152cd2a 100644
--- a/manual/Unit library
+++ b/manual/Unit library
@@ -48,11 +48,6 @@ set, or {{#f}} otherwise. The rightmost/least-significant bit is bit 0.
<procedure>(fxneg N)</procedure>
<procedure>(fxmin N1 N2)</procedure>
<procedure>(fxmax N1 N2)</procedure>
-<procedure>(fx= N1 N2)</procedure>
-<procedure>(fx> N1 N2)</procedure>
-<procedure>(fx< N1 N2)</procedure>
-<procedure>(fx>= N1 N2)</procedure>
-<procedure>(fx<= N1 N2)</procedure>
<procedure>(fxand N1 N2)</procedure>
<procedure>(fxior N1 N2)</procedure>
<procedure>(fxxor N1 N2)</procedure>
@@ -70,6 +65,18 @@ On division by zero, {{fx/}} and {{fxmod}} signal a condition of kind
{{fxshl}} and {{fxshr}} perform arithmetic shift left and right,
respectively.
+==== Fixnum comparison and predicates
+
+<procedure>(fxodd? N)</procedure>
+<procedure>(fxeven? N)</procedure>
+<procedure>(fx= N1 N2)</procedure>
+<procedure>(fx> N1 N2)</procedure>
+<procedure>(fx< N1 N2)</procedure>
+<procedure>(fx>= N1 N2)</procedure>
+<procedure>(fx<= N1 N2)</procedure>
+
+Comparison of fixnums and predicates on them.
+
==== fixnum?
<procedure>(fixnum? X)</procedure>
diff --git a/manual/faq b/manual/faq
index ec91855c..57324258 100644
--- a/manual/faq
+++ b/manual/faq
@@ -424,6 +424,7 @@ The following extended bindings are handled specially:
{{fx+}}
{{fx-}} {{fx*}} {{fx/}} {{fxmod}}
{{fx=}} {{fx>}} {{fx>=}} {{fixnum?}} {{fxneg}} {{fxmax}} {{fxmin}}
+{{fxodd?}} {{fxeven?}}
{{fxand}} {{fxior}} {{fxxor}} {{fxnot}} {{fxshl}} {{fxshr}}
{{finite?}} {{fp=}} {{fp>}} {{fp<}} {{fp>=}} {{fp<=}} {{fpinteger?}}
{{flonum?}} {{fp+}}
diff --git a/runtime.c b/runtime.c
index fd0e07e1..dcf43dac 100644
--- a/runtime.c
+++ b/runtime.c
@@ -5216,21 +5216,6 @@ C_regparm C_word C_fcall C_i_assq(C_word x, C_word lst)
}
-C_regparm C_word C_fcall C_u_i_assq(C_word x, C_word lst)
-{
- C_word a;
-
- while(!C_immediatep(lst)) {
- a = C_u_i_car(lst);
-
- if(C_u_i_car(a) == x) return a;
- else lst = C_u_i_cdr(lst);
- }
-
- return C_SCHEME_FALSE;
-}
-
-
C_regparm C_word C_fcall C_i_assv(C_word x, C_word lst)
{
C_word a;
@@ -8699,3 +8684,38 @@ C_private_repository_path()
{
return private_repository;
}
+
+
+C_regparm C_word C_fcall
+C_i_getprop(C_word sym, C_word prop, C_word def)
+{
+ C_word pl = C_block_item(sym, 2);
+
+ while(pl != C_SCHEME_END_OF_LIST) {
+ if(C_block_item(pl, 0) == prop)
+ return C_u_i_car(C_u_i_cdr(pl));
+ else pl = C_u_i_cdr(C_u_i_cdr(pl));
+ }
+
+ return def;
+}
+
+
+C_regparm C_word C_fcall
+C_putprop(C_word **ptr, C_word sym, C_word prop, C_word val)
+{
+ C_word pl = C_block_item(sym, 2);
+
+ while(pl != C_SCHEME_END_OF_LIST) {
+ if(C_block_item(pl, 0) == prop) {
+ C_mutate(&C_u_i_car(C_u_i_cdr(pl)), val);
+ return val;
+ }
+ else pl = C_u_i_cdr(C_u_i_cdr(pl));
+ }
+
+ pl = C_pair(ptr, val, C_block_item(sym, 2));
+ pl = C_pair(ptr, prop, pl);
+ C_mutate(&C_block_item(sym, 2), pl);
+ return val;
+}
Trap