* Added procedure-annotation primitive that returns the annotation

object stored in the closure's code.

bin/ikarus-fasl.c

@@ -281,6 +281,7 @@ static ikp do_read(ikpcb* pcb, fasl_port* p){
     ref(code, 0) = code_tag;
     ref(code, disp_code_code_size) = fix(code_size);
     ref(code, disp_code_freevars) = freevars;
+    ref(code, disp_code_annotation) = false_object;
     fasl_read_buf(p, code+disp_code_data, code_size);
     if(put_mark_index){
       p->marks[put_mark_index] = code+vector_tag;

src/ikarus.code-objects.ss

@@ -3,13 +3,14 @@
   (export
     make-code code-reloc-vector code-freevars
     code-size code-ref code-set! set-code-reloc-vector!
-    set-code-annotation!
+    set-code-annotation! procedure-annotation
     code->thunk)
   (import
     (ikarus system $fx)
     (ikarus system $codes)
     (except (ikarus) make-code code-reloc-vector code-freevars
             code-size code-ref code-set! set-code-reloc-vector!
+            procedure-annotation
             set-code-annotation!))
 
   (define make-code
@@ -80,5 +81,10 @@
         (error 'code->thunk "~s has free variables" x))
       ($code->closure x)))
 
+  (define (procedure-annotation x)
+    (if (procedure? x) 
+        ($code-annotation ($closure-code x))
+        (error 'procedure-annotation "~s is not a procedure" x)))
+
   )
 

src/ikarus.fasl.ss

@@ -41,7 +41,7 @@
 (library (ikarus fasl read)
   (export fasl-read)
   (import (ikarus)
-          (ikarus code-objects)
+          (except (ikarus code-objects) procedure-annotation)
           (ikarus system $codes)
           (ikarus system $records))
 

src/ikarus.fasl.write.ss

@@ -12,7 +12,7 @@
     (ikarus system $strings)
     (ikarus system $flonums)
     (ikarus system $bignums)
-    (ikarus code-objects)
+    (except (ikarus code-objects) procedure-annotation)
     (except (ikarus) fasl-write))
 
   (define write-fixnum 

src/ikarus.intel-assembler.ss

@@ -4,7 +4,7 @@
   (export assemble-sources code-entry-adjustment)
   (import 
     (ikarus)
-    (ikarus code-objects)
+    (except (ikarus code-objects) procedure-annotation)
     (ikarus system $pairs))
 
 (define fold

src/makefile.ss

@@ -779,6 +779,7 @@
     [$code-ref                $codes]
     [$code-set!               $codes]
     [$set-code-annotation!    $codes]
+    [procedure-annotation     i]
 
     [$make-tcbucket           $tcbuckets]
     [$tcbucket-key            $tcbuckets]