~ chicken-core (chicken-5) caebbf19b11d7231357333aa01a5053316afd31e

commit caebbf19b11d7231357333aa01a5053316afd31e
Author:     felix <felix@z.(none)>
AuthorDate: Tue Mar 8 17:37:46 2011 +0100
Commit:     felix <felix@z.(none)>
CommitDate: Tue Mar 8 17:37:46 2011 +0100

    types work

diff --git a/types.db b/types.db
index 39b5a2cc..d8cb229c 100644
--- a/types.db
+++ b/types.db
@@ -972,20 +972,16 @@
 
 ;; lolevel
 
-;;XXX...
-(address->pointer (procedure address->pointer (fixnum) pointer))
+(address->pointer (procedure address->pointer (fixnum) pointer)
+		  ((fixnum) (##sys#address->pointer #(1))))
+
 (align-to-word (procedure align-to-word (*) *))
 (allocate (procedure allocate (fixnum) pointer))
 (block-ref (procedure block-ref (* fixnum) *))
 (block-set! (procedure block-set! (* fixnum *) *))
-(clear-unbound-variable-value! (procedure clear-unbound-variable-value! () undefined))
 (extend-procedure (procedure extend-procedure (procedure *) procedure))
 (extended-procedure? (procedure extended-procedure? (*) boolean))
 (free (procedure free (pointer) *))
-(global-bound? deprecated)
-(global-make-unbound! deprecated)
-(global-ref deprecated)
-(global-set! deprecated)
 (invalid-procedure-call-handler (procedure invalid-procedure-call-handler () procedure))
 (locative->object (procedure locative->object (locative) *))
 (locative-ref (procedure locative-ref (locative) *))
@@ -998,9 +994,14 @@
 (move-memory! (procedure move-memory! (* * #!optional fixnum fixnum fixnum) *))
 (mutate-procedure (procedure mutate-procedure (procedure procedure) procedure))
 (null-pointer (procedure null-pointer () pointer))
-(null-pointer? (procedure null-pointer? (pointer) boolean))
+
+(null-pointer? (procedure null-pointer? (pointer) boolean)
+	       ((pointer) (##core#inline "C_null_pointerp" #(1))))
+
 (number-of-bytes (procedure number-of-bytes (*) fixnum))
-(number-of-slots (procedure number-of-slots (*) fixnum))
+
+(number-of-slots (procedure number-of-slots (*) fixnum)) ;XXX
+
 (object->pointer (procedure object->pointer (*) *))
 (object-become! (procedure object-become! (list) *))
 (object-copy (procedure object-copy (*) *))
@@ -1011,18 +1012,29 @@
 (object-size (procedure object-size (*) fixnum))
 (object-unevict (procedure object-unevict (* #!optional *) *))
 (pointer+ (procedure pointer+ (pointer fixnum) pointer))
-(pointer->address (procedure pointer->address (pointer) number))
-(pointer->object (procedure pointer->object (pointer) *))
-(pointer-offset deprecated)
+
+(pointer->address (procedure pointer->address (pointer) number)
+		  ((pointer) (##sys#pointer->address #(1))))
+
+(pointer->object (procedure pointer->object (pointer) *)
+		 ((pointer) (##core#inline "C_pointer_to_object" #(1))))
+
 (pointer-like? (procedure pointer-like? (*) boolean))
 (pointer-f32-ref (procedure pointer-f32-ref (pointer) number))
 (pointer-f32-set! (procedure pointer-f32-set! (pointer number) undefined))
 (pointer-f64-ref (procedure pointer-f64-ref (pointer) number))
 (pointer-f64-set! (procedure pointer-f64-set! (pointer number) undefined))
 (pointer-vector (procedure pointer-vector (#!rest pointer-vector) boolean))
-(pointer-vector? (procedure pointer-vector? (*) boolean))
+
+(pointer-vector? (procedure pointer-vector? (*) boolean)
+		 ((pointer-vector) (let ((#:tmp #(1))) #t))
+		 (((not pointer-vector)) (let ((#:tmp #(1))) #f)))
+
 (pointer-vector-fill! (procedure pointer-vector-fill! (pointer-vector pointer) undefined))
-(pointer-vector-length (procedure pointer-vector-length (pointer-vector) fixnum))
+
+(pointer-vector-length (procedure pointer-vector-length (pointer-vector) fixnum)
+		       ((pointer-vector) (##sys#slot #(1) 1)))
+
 (pointer-vector-ref (procedure pointer-vector-ref (pointer-vector fixnum) pointer))
 (pointer-vector-set! (procedure pointer-vector-set! (pointer-vector fixnum pointer) pointer))
 (pointer-s16-ref (procedure pointer-s16-ref (pointer) fixnum))
@@ -1038,8 +1050,14 @@
 (pointer-u32-set! (procedure pointer-u32-set! (pointer number) undefined))
 (pointer-u8-ref (procedure pointer-u8-ref (pointer) fixnum))
 (pointer-u8-set! (procedure pointer-u8-set! (pointer fixnum) undefined))
-(pointer=? (procedure pointer=? (pointer pointer) boolean))
-(pointer? (procedure pointer? (*) boolean))
+
+(pointer=? (procedure pointer=? (pointer pointer) boolean)
+	   ((pointer pointer) (##core#inline "C_pointer_eqp" #(1) #(2))))
+
+(pointer? (procedure pointer? (*) boolean)
+	  ((pointer) (let ((#:tmp #(1))) #t))
+	  (((not pointer)) (let ((#:tmp #(1))) #f)))
+
 (procedure-data (procedure procedure-data (procedure) *))
 (record->vector (procedure record->vector (*) vector))
 (record-instance? (procedure record-instance? (*) boolean))
@@ -1049,13 +1067,8 @@
 (record-instance-type (procedure record-instance-type (*) *))
 (set-invalid-procedure-call-handler! (procedure set-invalid-procedure-call-handler! (procedure) undefined))
 (set-procedure-data! (procedure set-procedure-data! (procedure *) undefined))
-(set-unbound-variable-value! (procedure set-unbound-variable-value! (*) undefined))
 (tag-pointer (procedure tag-pointer (pointer *) pointer))
 (tagged-pointer? (procedure tagged-pointer? (* #!optional *) boolean))
-(unbound-variable-value (procedure unbound-variable-value (#!optional *) undefined))
-(unbound-variable-given-value (procedure unbound-variable-given-value () *))
-(unbound-variable-signals-error? (procedure unbound-variable-signals-error? () boolean))
-(vector-like? (procedure vector-like? (*) boolean))
 
 ;; ports
 
@@ -1081,7 +1094,6 @@
 (_exit (procedure _exit (fixnum) noreturn))
 (call-with-input-pipe (procedure call-with-input-pipe (string (procedure (port) . *) #!optional symbol) . *))
 (call-with-output-pipe (procedure call-with-output-pipe (string (procedure (port) . *) #!optional symbol) . *))
-(canonical-path deprecated)
 (change-directory (procedure change-directory (string) string))
 (change-file-mode (procedure change-file-mode (string fixnum) undefined))
 (change-file-owner (procedure change-file-owner (string fixnum fixnum) undefined))
@@ -1312,6 +1324,7 @@
 
 ;; srfi-1
 
+;;XXX...
 (alist-cons (procedure alist-cons (* * *) list))
 (alist-copy (procedure alist-copy (list) list))
 (alist-delete (procedure alist-delete (* list #!optional (procedure (* *) *)) list))