Added support for foreign object types with multiple tags and (foreig…

…n? obj) and (foreign-tags obj)

doc/gambit-c.txi

@@ -3265,7 +3265,9 @@ The procedures in this section are not yet documented.
 @deffn procedure err-code->string @var{code}
 @end deffn
 
-@deffn procedure foreign-address @var{foreign}
+@deffn procedure foreign? @var{obj}
+@deffnx procedure foreign-tags @var{foreign}
+@deffnx procedure foreign-address @var{foreign}
 @deffnx procedure foreign-release! @var{foreign}
 @deffnx procedure foreign-released? @var{foreign}
 @end deffn
@@ -12768,21 +12770,21 @@ C type
 @code{float32}
 @item float64
 @code{float64}
-@item (struct "@var{c-struct-id}" @r{[}@var{tag} @r{[}@var{release-function}@r{]}@r{]})
+@item (struct "@var{c-struct-id}" @r{[}@var{tags} @r{[}@var{release-function}@r{]}@r{]})
 @code{struct @var{c-struct-id}}  (where @var{c-struct-id} is the name of a
-C structure; see below for the meaning of @var{tag} and @var{release-function})
-@item (union "@var{c-union-id}" @r{[}@var{tag} @r{[}@var{release-function}@r{]}@r{]})
+C structure; see below for the meaning of @var{tags} and @var{release-function})
+@item (union "@var{c-union-id}" @r{[}@var{tags} @r{[}@var{release-function}@r{]}@r{]})
 @code{union @var{c-union-id}}  (where @var{c-union-id} is the name of a
-C union; see below for the meaning of @var{tag} and @var{release-function})
-@item (type "@var{c-type-id}" @r{[}@var{tag} @r{[}@var{release-function}@r{]}@r{]})
+C union; see below for the meaning of @var{tags} and @var{release-function})
+@item (type "@var{c-type-id}" @r{[}@var{tags} @r{[}@var{release-function}@r{]}@r{]})
 @code{@var{c-type-id}}  (where @var{c-type-id} is an identifier naming a
-C type; see below for the meaning of @var{tag} and @var{release-function})
-@item (pointer @var{type} @r{[}@var{tag} @r{[}@var{release-function}@r{]}@r{]})
+C type; see below for the meaning of @var{tags} and @var{release-function})
+@item (pointer @var{type} @r{[}@var{tags} @r{[}@var{release-function}@r{]}@r{]})
 @code{@var{T}*}  (where @var{T} is the C equivalent of @var{type}
 which must be the Scheme notation of a C type; see below for the meaning
-of @var{tag} and @var{release-function})
-@item (nonnull-pointer @var{type} @r{[}@var{tag} @r{[}@var{release-function}@r{]}@r{]})
-same as @code{(pointer @var{type} @r{[}@var{tag} @r{[}@var{release-function}@r{]}@r{]})}
+of @var{tags} and @var{release-function})
+@item (nonnull-pointer @var{type} @r{[}@var{tags} @r{[}@var{release-function}@r{]}@r{]})
+same as @code{(pointer @var{type} @r{[}@var{tags} @r{[}@var{release-function}@r{]}@r{]})}
 except the @code{NULL} pointer is not allowed
 @item (function (@var{type1}@dots{}) @var{result-type})
 function with the given argument types and result type
@@ -12857,21 +12859,44 @@ dereferences the internal pointer (no allocation from the C heap is
 performed).  Deallocation of the copy on the C heap is under the control
 of the release function attached to the foreign object (see below).
 
-For type checking on the Scheme side, a @var{tag} can be specified
-within a foreign type specification.  The @var{tag} must be @code{#f} or
-a symbol.  When it is not specified the @var{tag} defaults to a symbol
-whose name, as returned by @code{symbol->string}, is the C type
-declaration for that type.  For example the default tag for the type
-@samp{(pointer (pointer char))} is the symbol @samp{char**}.  Two
-foreign types are compatible (i.e. can be converted from one to the
-other) if they have identical tags or if at least one of the tags is
-@code{#f}.  For the safest code the @code{#f} tag should be used
+The optional @var{tags} field of foreign type specifications is used
+for type checking on the Scheme side.  The @var{tags} field must be
+@code{#f}, a symbol or a non-empty list of symbols.  When it is not
+specified the @var{tags} field defaults to a symbol whose name, as
+returned by @code{symbol->string}, is the C type declaration for that
+type.  For example the symbol @samp{char**} is the default for the
+type @samp{(pointer (pointer char))}.  A @var{tags} field that is a
+single symbol is equivalent to a list containing only that symbol.
+The first symbol in the list of tags is the primary tag.  For example
+the primary tag of the type @samp{(pointer char)} is @samp{char*} and
+the primary tag of the type @samp{(pointer char (foo bar))} is
+@samp{foo}.
+
+Type compatibility between two foreign types depends on their tags.
+An instance of a foreign type @var{T} can be used where a foreign type
+@var{E} is expected if and only if
+
+@itemize @bullet{}
+
+@item
+@var{T}'s @var{tags} field is @code{#f}, or
+
+@item
+@var{E}'s @var{tags} field is @code{#f}, or
+
+@item
+@var{T}'s primary tag is a member of @var{E}'s tags.
+
+@end itemize
+
+For the safest code a @var{tags} field of @code{#f} should be used
 sparingly, as it completely bypasses type checking.  The external
 representation of Scheme foreign objects (used by the @code{write}
-procedure) contains the tag if it is not @code{#f}, and the hexadecimal
-address denoted by the internal pointer, for example @samp{#<char** #2
-0x2AAC535C>}.  Note that the hexadecimal address is in C notation, which
-can be easily transferred to a C debugger with a ``cut-and-paste''.
+procedure) contains the primary tag (if the @var{tags} field is not
+@code{#f}), and the hexadecimal address denoted by the internal
+pointer, for example @samp{#<char** #2 0x2AAC535C>}.  Note that the
+hexadecimal address is in C notation, which can be easily transferred
+to a C debugger with a ``cut-and-paste''.
 
 A @var{release-function} can also be specified within a foreign type
 specification.  The @var{release-function} must be @code{#f} or a string
@@ -12907,9 +12932,12 @@ invokes the @var{release-function} if the foreign object is not yet
 released, and does nothing otherwise.  The call
 @code{(foreign-released? @var{obj})} returns a boolean indicating
 whether the foreign object @var{obj} has been released yet or not.
-Finally, the call @code{(foreign-address @var{obj})} returns the
-address denoted by the internal pointer of foreign object @var{obj}
-or 0 if it has been released.
+The call @code{(foreign-address @var{obj})} returns the address
+denoted by the internal pointer of foreign object @var{obj} or 0 if it
+has been released.  The call @code{(foreign? @var{obj})} tests that
+@var{obj} is a foreign object.  Finally the call @code{(foreign-tags
+@var{obj})} returns the list of tags of foreign object @var{obj}, or
+@code{#f}.
 
 The following table gives the C types to which each Scheme type
 can be converted:
@@ -12954,7 +12982,7 @@ Allowed target C types
 @code{wchar_t-string};
 @code{nonnull-wchar_t-string}
 @item foreign object
-@code{scheme-object}; @code{bool}; @code{struct}/@code{union}/@code{type}/@code{pointer}/@code{nonnull-pointer} with the appropriate tag
+@code{scheme-object}; @code{bool}; @code{struct}/@code{union}/@code{type}/@code{pointer}/@code{nonnull-pointer} with the appropriate tags
 @item vector
 @code{scheme-object}; @code{bool}
 @item symbol
@@ -12988,7 +13016,7 @@ string or @code{#f} if it is equal to @samp{NULL}
 @item @code{nonnull-char-string}; @code{nonnull-ISO-8859-1-string}; @code{nonnull-UTF-8-string}; @code{nonnull-UCS-2-string}; @code{nonnull-UCS-4-string}; @code{nonnull-wchar_t-string}
 string
 @item @code{struct}/@code{union}/@code{type}/@code{pointer}/@code{nonnull-pointer}
-foreign object with the appropriate tag
+foreign object with the appropriate tags
 or @code{#f} in the case of a @code{pointer} equal to @samp{NULL}
 @item @code{function}
 procedure or @code{#f} if it is equal to @samp{NULL}
@@ -13053,14 +13081,14 @@ fresh Scheme string containing a copy of the C string (unless the C
 string is equal to @code{NULL}, in which case it is converted to
 @code{#f}).
 
-A foreign type passed to the Scheme environment causes the creation and
-initialization of a Scheme foreign object with the appropriate tag
-(except for the case of a @code{pointer} equal to @code{NULL} which is
-converted to @code{#f}).  A Scheme foreign object can be passed where a
-foreign type is expected, on the condition that the tags are appropriate
-(identical or one is @code{#f}) and the Scheme foreign object is not yet
-released.  The value @code{#f} is also acceptable for a @code{pointer}
-type, and is converted to @code{NULL}.
+A foreign type passed to the Scheme environment causes the creation
+and initialization of a Scheme foreign object with the appropriate
+tags (except for the case of a @code{pointer} equal to @code{NULL}
+which is converted to @code{#f}).  A Scheme foreign object can be
+passed where a foreign type is expected, on the condition that the
+tags are compatible and the Scheme foreign object is not yet released.
+The value @code{#f} is also acceptable for a @code{pointer} type, and
+is converted to @code{NULL}.
 
 Scheme procedures defined with the @code{c-define} special form can be
 passed where the @code{function} and @code{nonnull-function} types are

gsc/_ptree2.scm

@@ -1,8 +1,8 @@
 ;;;============================================================================
 
-;;; File: "_ptree2.scm", Time-stamp: <2007-09-27 13:58:22 feeley>
+;;; File: "_ptree2.scm", Time-stamp: <2008-01-10 16:52:16 feeley>
 
-;;; Copyright (c) 1994-2007 by Marc Feeley, All Rights Reserved.
+;;; Copyright (c) 1994-2008 by Marc Feeley, All Rights Reserved.
 
 (include "fixnum.scm")
 
@@ -1815,7 +1815,14 @@
                             (or (< len 2)
                                 (let ((tag (source-code (caddr typ))))
                                   (or (false-object? tag)
-                                      (symbol-object? tag))))
+                                      (symbol-object? tag)
+                                      (and (pair? tag)
+                                           (proper-length tag)
+                                           (every?
+                                            (lambda (x)
+                                              (symbol-object?
+                                               (source-code x)))
+                                            tag)))))
                             (or (< len 3)
                                 (let ((id (source-code (cadddr typ))))
                                   (or (false-object? id)
@@ -1997,18 +2004,19 @@
     (compiler-internal-error "c-type-converter, unknown C type"))
 
   (define (convert kind name tag id)
-    (let ((tag
+    (let ((tag-str
            (if (false-object? tag)
              (string-append c-id-prefix "FAL")
-             (let ((x (pos-in-list tag c-interface-objs)))
+             (let* ((tag-list (if (symbol-object? tag) (list tag) tag))
+                    (x (object-pos-in-list tag-list c-interface-objs)))
                (string-append
                 c-id-prefix
                 "C_OBJ_"
                 (number->string
                  (if x
                    (- (- c-interface-obj-count x) 1)
                    (let ((n c-interface-obj-count))
-                     (add-c-obj tag)
+                     (add-c-obj tag-list)
                      n))))))))
       (if to-scmobj?
 
@@ -2027,7 +2035,7 @@
                         "TYPE_TO_SCMOBJ("))
                  name
                  ",")))
-         from "_voidstar," tag ","
+         from "_voidstar," tag-str ","
          (if (false-object? id)
            (if (or (eq? kind pointer-sym)
                    (eq? kind nonnull-pointer-sym))
@@ -2084,7 +2092,7 @@
                         "SCMOBJ_TO_TYPE("))
                  name
                  ",")))
-         from "," to "_voidstar," tag))))
+         from "," to "_voidstar," tag-str))))
 
   (let ((t (source-code typ)))
     (cond ((pair? t)
@@ -2099,7 +2107,7 @@
                      head
                      (source-code (cadr t))
                      (if (>= len 2)
-                       (source-code (caddr t))
+                       (source->expression (caddr t))
                        (string->symbol (c-type-decl typ "")))
                      (if (>= len 3)
                        (source-code (cadddr t))

gsc/_utils.scm

@@ -1,6 +1,6 @@
 ;;;============================================================================
 
-;;; File: "_utils.scm", Time-stamp: <2007-04-04 11:38:34 feeley>
+;;; File: "_utils.scm", Time-stamp: <2008-01-10 15:50:42 feeley>
 
 ;;; Copyright (c) 1994-2007 by Marc Feeley, All Rights Reserved.
 
@@ -36,6 +36,12 @@
           ((eq? (car l) x) i)
           (else            (loop (cdr l) (+ i 1))))))
 
+(define (object-pos-in-list x l)
+  (let loop ((l l) (i 0))
+    (cond ((not    (pair? l)) #f)
+          ((equal? (car l) x) i)
+          (else               (loop (cdr l) (+ i 1))))))
+
 (define (string-pos-in-list x l)
   (let loop ((l l) (i 0))
     (cond ((not (pair? l))      #f)
@@ -629,6 +635,12 @@
           ((eq? (car l) x) i)
           (else            (loop (cdr l) (+ i 1))))))
 
+(define (object-pos-in-list x l)
+  (let loop ((l l) (i 0))
+    (cond ((not    (pair? l)) #f)
+          ((equal? (car l) x) i)
+          (else               (loop (cdr l) (+ i 1))))))
+
 (define (string-pos-in-list x l)
   (let loop ((l l) (i 0))
     (cond ((not (pair? l))      #f)