~ chicken-core (chicken-5) a3e2aaea6cb8d0fc6987e75fc00e4e46177bc6c9
commit a3e2aaea6cb8d0fc6987e75fc00e4e46177bc6c9
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Wed Feb 23 09:01:07 2011 -0500
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Wed Feb 23 09:01:07 2011 -0500
types.db enhancements
diff --git a/common-declarations.scm b/common-declarations.scm
index 4528d1ec..530592eb 100644
--- a/common-declarations.scm
+++ b/common-declarations.scm
@@ -25,8 +25,7 @@
(declare
- (usual-integrations)
- (hide d))
+ (usual-integrations))
(cond-expand
(debugbuild
diff --git a/scrutinizer.scm b/scrutinizer.scm
index c237c75b..80d39451 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -93,13 +93,13 @@
((flonum) 'flonum)
(else 'number))) ; in case...
((boolean? lit) 'boolean)
- ((list? lit) 'list)
+ ((null? lit) 'null)
((pair? lit) 'pair)
+ ((list? lit) 'list)
((eof-object? lit) 'eof)
((vector? lit) 'vector)
((and (not (##sys#immediate? lit)) ##sys#generic-structure? lit)
`(struct ,(##sys#slot lit 0)))
- ((null? lit) 'null)
((char? lit) 'char)
(else '*)))
(define (global-result id loc)
diff --git a/types.db b/types.db
index a01bf8d5..4e2e4318 100644
--- a/types.db
+++ b/types.db
@@ -28,18 +28,30 @@
(not (procedure not (*) boolean)
(((not boolean)) '#t))
+
(boolean? (procedure boolean? (*) boolean)
((boolean) '#t)
(((not boolean)) '#f))
+
(eq? (procedure eq? (* *) boolean))
+
(eqv? (procedure eqv? (* *) boolean)
(((and (not number) (not flonum)) *) (eq? #(1) #(2)))
((* (and (not number) (not flonum))) (eq? #(1) #(2))))
-(equal? (procedure equal? (* *) boolean))
-(pair? (procedure pair? (*) boolean))
+
+(equal? (procedure equal? (* *) boolean)
+ (((or fixnum symbol char eof null undefined) *) (eq? #(1) #(2)))
+ ((* (or fixnum symbol char eof null undefined) (eq? #(1) #(2)))))
+
+(pair? (procedure pair? (*) boolean)
+ ((pair) '#t)
+ (((not pair)) '#f))
+
(cons (procedure cons (* *) pair))
-(car (procedure car (pair) *))
-(cdr (procedure cdr (pair) *))
+
+(car (procedure car (pair) *) ((pair) (##core#inline "C_u_i_car" #(1))))
+(cdr (procedure cdr (pair) *) ((pair) (##core#inline "C_u_i_cdr" #(1))))
+
(caar (procedure caar (pair) *))
(cadr (procedure cadr (pair) *))
(cdar (procedure cdar (pair) *))
@@ -68,10 +80,14 @@
(cddadr (procedure cddadr (pair) *))
(cdddar (procedure cdddar (pair) *))
(cddddr (procedure cddddr (pair) *))
-(set-car! (procedure set-car! (pair *) undefined))
-(set-cdr! (procedure set-cdr! (pair *) undefined))
-(null? (procedure null? (*) boolean))
-(list? (procedure list? (*) boolean))
+
+(set-car! (procedure set-car! (pair *) undefined) ((pair *) (##sys#setslot #(1) 0 #(2))))
+(set-cdr! (procedure set-cdr! (pair *) undefined) ((pair *) (##sys#setslot #(1) 1 #(2))))
+
+(null? (procedure null? (*) boolean) ((null) #t) ((not null) #f))
+(list? (procedure list? (*) boolean) (((or null pair list)) #t) (((not (or null pair list))) #f))
+
+;;;XXX...
(list (procedure list (#!rest) list))
(length (procedure length (list) fixnum))
(list-tail (procedure list-tail (list fixnum) *))
Trap