- added experimental pointer manipulation primitives.

scheme/Makefile.am

@@ -27,7 +27,7 @@ EXTRA_DIST=ikarus.boot.4.prebuilt ikarus.boot.8.prebuilt \
   ikarus.io.ss ikarus.time-and-date.ss ikarus.not-yet-implemented.ss \
   ikarus.string-to-number.ss ikarus.compiler.source-optimizer.ss \
   ikarus.compiler.tag-annotation-analysis.ss ikarus.ontology.ss \
-  ikarus.reader.annotated.ss
+  ikarus.reader.annotated.ss ikarus.pointers.ss
  
 all: $(nodist_pkglib_DATA)
 

scheme/Makefile.in

@@ -181,7 +181,7 @@ EXTRA_DIST = ikarus.boot.4.prebuilt ikarus.boot.8.prebuilt \
   ikarus.io.ss ikarus.time-and-date.ss ikarus.not-yet-implemented.ss \
   ikarus.string-to-number.ss ikarus.compiler.source-optimizer.ss \
   ikarus.compiler.tag-annotation-analysis.ss ikarus.ontology.ss \
-  ikarus.reader.annotated.ss
+  ikarus.reader.annotated.ss ikarus.pointers.ss
 
 revno = "$(shell sed 's/ .*//' ../.bzr/branch/last-revision 2>/dev/null)"
 sizeofvoidp = $(shell grep SIZEOF_VOID_P ../config.h | sed "s/.*\(.\)/\1/g")

scheme/ikarus.pointers.ss

@@ -0,0 +1,25 @@
+
+(library (ikarus.pointers)
+  (export pointer? integer->pointer pointer->integer)
+  (import (except (ikarus) pointer? integer->pointer pointer->integer))
+
+  (define (pointer? x)
+    (foreign-call "ikrt_isapointer" x))
+
+  (define (integer->pointer x)
+    (cond
+      [(fixnum? x) 
+       (foreign-call "ikrt_fx_to_pointer" x)]
+      [(bignum? x)
+       (foreign-call "ikrt_bn_to_pointer" x)]
+      [else 
+       (die 'integer->pointer "not an integer" x)]))
+
+  (define (pointer->integer x)
+    (cond
+      [(pointer? x) 
+       (foreign-call "ikrt_pointer_to_int" x)]
+      [else 
+       (die 'pointer->integer "not a pointer" x)])))
+
+

scheme/ikarus.writer.ss

@@ -391,6 +391,12 @@
           (write-positive-hex-fx b p))
       (write-char #\; p)))
 
+  (define (write-hex x n p)
+    (define s "0123456789ABCDEF")
+    (unless (zero? n)
+      (write-hex (sra x 4) (- n 1) p)
+      (write-char (string-ref s (bitwise-and x #xF)) p)))
+
   (define write-string-escape
     (lambda (x p)
       (define loop 
@@ -605,6 +611,13 @@
          (let ([n ($transcoder->data x)])
            (write-char* (number->string n) p))
          (write-char* ">" p)]
+        [(pointer? x) 
+         (write-char* "#<pointer #x" p)
+         (write-hex 
+           (pointer->integer x)
+           (if (<= (fixnum-width) 32) 8 16)
+           p)
+         (write-char* ">" p)]
         [else 
          (write-char* "#<unknown>" p)
          i])))

scheme/last-revision

@@ -1 +1 @@
-1588
+1589

scheme/makefile.ss

@@ -104,6 +104,7 @@
     "ikarus.promises.ss"
     "ikarus.enumerations.ss"
     "ikarus.command-line.ss"
+    "ikarus.pointers.ss"
     "ikarus.not-yet-implemented.ss"
     "ikarus.main.ss"
     ))
@@ -1450,6 +1451,9 @@
     [cp0-effort-limit i]
     [tag-analysis-output i]
     [perform-tag-analysis i]
+    [pointer? i]
+    [pointer->integer i]
+    [integer->pointer i]
   ))
 
 (define (macro-identifier? x) 

scheme/run-tests.ss

@@ -39,6 +39,7 @@
         (tests case-folding)
         (tests sorting)
         (tests fasl)
+        (tests pointers)
         )
 
 (define (test-exact-integer-sqrt)
@@ -84,4 +85,5 @@
 (test-fasl)
 (test-numerics)
 (test-enums)
+(test-pointers)
 (printf "Happy Happy Joy Joy\n")

scheme/tests/pointers.ss

@@ -0,0 +1,42 @@
+
+(library (tests pointers)
+  (export test-pointers)
+  (import (ikarus))
+
+  (define bits 
+    (if (<= (fixnum-width) 32) 32 64))
+  
+  (define mask (sub1 (sll 1 bits)))
+
+  (define (test-pointer n)
+    (let* ([np (integer->pointer n)]
+           [m (pointer->integer np)]
+           [mp (integer->pointer m)])
+      (printf "test ~x/~s  => ~x/~s\n" n np m mp)
+      (unless (= (bitwise-and n mask) (bitwise-and m mask))
+        (error 'test "failed/got" n m 
+               (bitwise-and n mask) (bitwise-and m mask)))))
+      
+  (define (test-pointers)
+    (test-pointer 0)
+    (test-pointer 100)
+    (test-pointer -100)
+    (test-pointer (greatest-fixnum))
+    (test-pointer (least-fixnum))
+    (test-pointer (+ 1 (greatest-fixnum)))
+    (test-pointer (+ 1 (least-fixnum)))
+    (test-pointer (- 1 (greatest-fixnum)))
+    (test-pointer (- 1 (least-fixnum)))
+    (test-pointer (+ -1 (greatest-fixnum)))
+    (test-pointer (+ -1 (least-fixnum)))
+    (test-pointer (- -1 (greatest-fixnum)))
+    (test-pointer (- -1 (least-fixnum)))
+    (test-pointer (* 2 (greatest-fixnum)))
+    (test-pointer (* 2 (least-fixnum)))
+    (test-pointer (* 4 (greatest-fixnum)))
+    (test-pointer (* 4 (least-fixnum)))
+    (test-pointer (* 8 (greatest-fixnum)))
+    (test-pointer (* 8 (least-fixnum)))
+    (test-pointer (* 16 (greatest-fixnum)))
+    (test-pointer (* 16 (least-fixnum)))))
+

src/Makefile.am

@@ -7,7 +7,7 @@ SRCS = ikarus-collect.c ikarus-exec.c ikarus-fasl.c \
   ikarus-weak-pairs.c ikarus-winmmap.c ikarus-data.h \
   ikarus-winmmap.h ikarus-enter.S cpu_has_sse2.S ikarus-io.c \
   ikarus-process.c ikarus-getaddrinfo.h ikarus-getaddrinfo.c \
-  ikarus-errno.c ikarus-main.h 
+  ikarus-errno.c ikarus-main.h ikarus-pointers.c
 
 ikarus_SOURCES = $(SRCS) ikarus.c
 scheme_script_SOURCES = $(SRCS) scheme-script.c

src/Makefile.in

@@ -55,7 +55,7 @@ am__objects_1 = ikarus-collect.$(OBJEXT) ikarus-exec.$(OBJEXT) \
 	ikarus-winmmap.$(OBJEXT) ikarus-enter.$(OBJEXT) \
 	cpu_has_sse2.$(OBJEXT) ikarus-io.$(OBJEXT) \
 	ikarus-process.$(OBJEXT) ikarus-getaddrinfo.$(OBJEXT) \
-	ikarus-errno.$(OBJEXT)
+	ikarus-errno.$(OBJEXT) ikarus-pointers.$(OBJEXT)
 am_ikarus_OBJECTS = $(am__objects_1) ikarus.$(OBJEXT)
 nodist_ikarus_OBJECTS =
 ikarus_OBJECTS = $(am_ikarus_OBJECTS) $(nodist_ikarus_OBJECTS)
@@ -184,7 +184,7 @@ SRCS = ikarus-collect.c ikarus-exec.c ikarus-fasl.c \
   ikarus-weak-pairs.c ikarus-winmmap.c ikarus-data.h \
   ikarus-winmmap.h ikarus-enter.S cpu_has_sse2.S ikarus-io.c \
   ikarus-process.c ikarus-getaddrinfo.h ikarus-getaddrinfo.c \
-  ikarus-errno.c ikarus-main.h 
+  ikarus-errno.c ikarus-main.h ikarus-pointers.c
 
 ikarus_SOURCES = $(SRCS) ikarus.c
 scheme_script_SOURCES = $(SRCS) scheme-script.c
@@ -272,6 +272,7 @@ distclean-compile:
 @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/ikarus-io.Po@am__quote@
 @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/ikarus-main.Po@am__quote@
 @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/ikarus-numerics.Po@am__quote@
+@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/ikarus-pointers.Po@am__quote@
 @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/ikarus-print.Po@am__quote@
 @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/ikarus-process.Po@am__quote@
 @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/ikarus-runtime.Po@am__quote@

src/ikarus-collect.c

@@ -1239,6 +1239,14 @@ add_object_proc(gc_t* gc, ikptr x) {
       ref(y, disp_cflonum_imag-vector_tag) = add_object(gc, im, "imag");
       return y;
     }
+    else if(fst == pointer_tag){
+      ikptr y = gc_alloc_new_data(pointer_size, gc) + vector_tag;
+      ref(y, -vector_tag) = pointer_tag;
+      ref(y, wordsize-vector_tag) = ref(x, wordsize-vector_tag);
+      ref(x, -vector_tag) = forward_ptr;
+      ref(x, wordsize-vector_tag) = y;
+      return y;
+    }
     else {
       fprintf(stderr, "unhandled vector with fst=0x%016lx\n",
                (long int)fst);

src/ikarus-data.h

@@ -406,4 +406,7 @@ ikptr ik_safe_alloc(ikpcb* pcb, int size);
 #define ik_eof_p(x) ((x) == ik_eof_object)
 #define page_index(x) (((unsigned long int)(x)) >> pageshift)
 
+#define pointer_tag           ((ikptr) 0x107)
+#define pointer_size          (2 * wordsize)
+
 #endif

src/ikarus-pointers.c

@@ -0,0 +1,58 @@
+
+#include "ikarus-data.h"
+
+ikptr
+ikrt_isapointer(ikptr x, ikpcb* pcb){
+  if ((tagof(x) == vector_tag) && (ref(x, -vector_tag) == pointer_tag)) {
+    return true_object;
+  } else {
+    return false_object;
+  }
+}
+
+ikptr
+ikrt_pointer_to_int(ikptr x, ikpcb* pcb) {
+  long int p = (long int) ref(x, wordsize-vector_tag);
+  ikptr pfx = fix(p);
+  if (unfix(pfx) == p) {
+    return pfx;
+  } else {
+    ikptr bn = ik_safe_alloc(pcb, align(wordsize+disp_bignum_data));
+    if (p > 0){
+      ref(bn, 0) = (ikptr)(bignum_tag | (1 << bignum_length_shift)); 
+      ref(bn, disp_bignum_data) = (ikptr)p;
+    } else {
+      ref(bn, 0) = 
+        (ikptr)(bignum_tag | 
+              (1 << bignum_length_shift) | 
+              (1 << bignum_sign_shift));
+      ref(bn, disp_bignum_data) = (ikptr)-p;
+    } 
+    return bn+vector_tag;
+  }
+}
+
+static ikptr
+make_pointer(long int x, ikpcb* pcb) {
+  ikptr r = ik_safe_alloc(pcb, pointer_size);
+  ref(r, 0) = pointer_tag;
+  ref(r, wordsize) = (ikptr)x;
+  return r+vector_tag;
+}
+
+ikptr
+ikrt_fx_to_pointer(ikptr x, ikpcb* pcb) {
+  return make_pointer(unfix(x), pcb);
+}
+
+#define bnfst_negative(x) \
+  (((unsigned long int)(x)) & bignum_sign_mask)
+ikptr
+ikrt_bn_to_pointer(ikptr x, ikpcb* pcb) {
+  if(bnfst_negative(ref(x, -vector_tag))){
+    return make_pointer(-ref(x, wordsize-vector_tag), pcb);
+  } else {
+    return make_pointer(ref(x, wordsize-vector_tag), pcb);
+  }
+}
+