support (nongenerative uid) in define-ftype

boot/pb/equates.h

@@ -1,4 +1,4 @@
-/* equates.h for Chez Scheme Version 10.4.0-pre-release.3 */
+/* equates.h for Chez Scheme Version 10.4.0-pre-release.4 */
 
 /* Do not edit this file.  It is automatically generated and */
 /* specifically tailored to the version of Chez Scheme named */
@@ -119,6 +119,7 @@ typedef uint64_t U64;
 #define code_flag_guardian 0x8
 #define code_flag_lift_barrier 0x80
 #define code_flag_mutable_closure 0x10
+#define code_flag_no_interrupt_trap 0x100
 #define code_flag_single_valued 0x40
 #define code_flag_system 0x1
 #define code_flag_template 0x4
@@ -1018,7 +1019,7 @@ typedef uint64_t U64;
 #define rtd_sealed 0x4
 #define sbwp (ptr)0x4E
 #define scaled_shot_1_shot_flag -0x8
-#define scheme_version 0xA040003
+#define scheme_version 0xA040004
 #define seginfo_generation_disp 0x1
 #define seginfo_list_bits_disp 0x8
 #define seginfo_space_disp 0x0

boot/pb/scheme.h

@@ -1,4 +1,4 @@
-/* scheme.h for Chez Scheme Version 10.4.0-pre-release.3 (pb) */
+/* scheme.h for Chez Scheme Version 10.4.0-pre-release.4 (pb) */
 
 /* Do not edit this file.  It is automatically generated and */
 /* specifically tailored to the version of Chez Scheme named */
@@ -40,7 +40,7 @@
 #endif
 
 /* Chez Scheme Version and machine type */
-#define VERSION "10.4.0-pre-release.3"
+#define VERSION "10.4.0-pre-release.4"
 #define MACHINE_TYPE "pb"
 
 /* Integer typedefs */

build.zuo

@@ -271,7 +271,16 @@
                   (run-make ""))]
       [:target ,(string->symbol (~a "install-" name)) (,name-sym)
                ,(lambda (token . args)
-                  (run-make "install"))]))
+                  (run-make "install"))]
+      [:target ,(string->symbol (~a "clean-" name)) (,mf-out)
+               ,(lambda (token . args)
+                  (run-make (~a name ".clean"))
+                  (for-each (lambda (name)
+                              (when (member (car (reverse (string-split name ".")))
+                                            '("tex" "html" "aux" "bbl" "out" "pdf"
+                                                    "firstrun" "secondrun" "thirdrun" "idx"))
+                                (rm* (build-path doc-dir name))))
+                            (ls doc-dir)))]))
 
   (define (check-boot-file-version)
     (define src-ver (source-version))
@@ -408,7 +417,8 @@
                 ,void]
        [:target install-docs (install-csug install-release_notes)
                 ,void]
-
+       [:target clean-docs (clean-csug clean-release_notes)
+                ,void]
 
        [:target rpm ()
                 ,(lambda (token)

c/fasl.c

@@ -226,6 +226,7 @@ static iptr stringin(ptr *pstrbuf, iptr start, faslFile f);
 static void faslin(ptr tc, ptr *x, ptr t, ptr *pstrbuf, faslFile f);
 static void fasl_record(ptr tc, ptr *x, ptr t, ptr *pstrbuf, faslFile f, uptr size);
 static IBOOL rtd_equiv(ptr x, ptr y);
+static IBOOL rtd_extras_equiv(ptr x, ptr y);
 static IBOOL equalp(ptr x, ptr y);
 #ifdef PORTABLE_BYTECODE
 static void pb_set_abs(void *address, uptr item);
@@ -1396,7 +1397,17 @@ static IBOOL rtd_equiv(ptr x, ptr y) {
          equalp(RECORDDESCMPM(x), RECORDDESCMPM(y)) &&
          equalp(RECORDDESCFLDS(x), RECORDDESCFLDS(y)) &&
          RECORDDESCSIZE(x) == RECORDDESCSIZE(y) &&
-         RECORDDESCFLAGS(x) == RECORDDESCFLAGS(y);
+         RECORDDESCFLAGS(x) == RECORDDESCFLAGS(y) &&
+         ((RECORDDESCSIZE(RECORDINSTTYPE(x)) == FIX(size_record_type))
+          || rtd_extras_equiv(x, y));
+}
+
+static IBOOL rtd_extras_equiv(ptr x, ptr y) {
+  iptr count = (UNFIX(RECORDDESCSIZE(RECORDINSTTYPE(x))) >> log2_ptr_bytes) - 1;
+  iptr i;
+  for (i = (size_record_type >> log2_ptr_bytes) - 1; i < count; i++)
+    if (!equalp(RECORDINSTIT(x, i), RECORDINSTIT(y, i))) return 0;
+  return 1;
 }
 
 #ifdef HPUX

csug/foreign.stex

@@ -668,15 +668,15 @@ and the actual argument is the address encapsulated in the
 ftype pointer.
 
 \foreigntype{\scheme{ftype-pointer}}
-\index{ftype-pointer}This type allows any pointer to a foreign type
+\index{\scheme{ftype-pointer}}This type allows any pointer to a foreign type
 (ftype) to be passed, independent of the foreign type, and including
 generic foreign pointers and foreign pointers to Scheme objects. In
 other words, this type is specific to foreign pointers created with
 \scheme{make-ftype-pointer} and similar, but otherwise generic like
 \scheme{void*}.
 
 \foreigntype{\scheme{ftype-scheme-object-pointer}}
-\index{ftype-scheme-object-pointer}This type allows a foreign pointer
+\index{\scheme{ftype-scheme-object-pointer}}This type allows a foreign pointer
 to a Scheme object, such as one created with
 \scheme{make-ftype-scheme-object-pointer}. The address received on the
 C side is like the one produced by \scheme{object->reference-address}
@@ -703,14 +703,9 @@ content at the foreign pointer's address instead of as the
 address. For example, if \var{ftype-name} identifies a \scheme{struct} type,
 then \scheme{(& \var{ftype-name})} passes a struct argument instead of
 a struct-pointer argument. The \var{ftype-name} cannot refer to an array type.
-The variant \scheme{(& \var{ftype-name} ftype-pointer)} is the same,
-except that the Scheme-side representation can be any foreign pointer
-type, not necessarily one specific to \var{ftype-name}.
-The variant \scheme{(& \var{ftype-name} ftype-scheme-object-pointer)}
-is also the same, except that Scheme-side representation must be a
-foreign object pointer to a Scheme object like one created by
-\scheme{make-ftype-scheme-object-pointer}.
-
+The variant \scheme{(& \var{ftype-name} \var{ftype-name})} is the same,
+except that the Scheme-side representation corresponds to the second
+\var{ftype-name}, which can be any pointer type.
 
 \medskip\noindent
 The result types are similar to the parameter types with the addition of a
@@ -1024,15 +1019,9 @@ all other arguments to receive the result. An unspecified Scheme object
 is returned when the foreign procedure is called, since the result
 is instead written into storage referenced by the extra argument.
 The \var{ftype-name} cannot refer to an array type.
-The variant \scheme{(& \var{ftype-name} ftype-pointer)} is the same,
+The variant \scheme{(& \var{ftype-name} \var{ftype-name})} is the same,
 except that the foreign pointer passed as an extra initial argument
-can be any foreign pointer type, not necessarily one specific to
-\var{ftype-name}.
-The variant \scheme{(& \var{ftype-name} ftype-scheme-object-pointer)}
-is also the same, except that the foreign pointer passed as an extra
-initial argument must be a foreign object pointer to a Scheme object
-like one created by \scheme{make-ftype-scheme-object-pointer}.
-
+corresponds to the second \var{ftype-name}, which can be any pointer type.
 
 
 \medskip\noindent
@@ -1195,6 +1184,9 @@ A \scheme{(& \var{ftype})} result type for a callable causes the Scheme
 procedure to receive an extra \scheme{(& \var{ftype})} argument before
 all others; the Scheme procedure should write a result into the extra
 argument, and the direct result of the Scheme procedure is ignored.
+A \scheme{(& \var{ftype-name} \var{ftype-name})} argument or result is the same,
+except that the Scheme-side representation corresponds to the second
+\var{ftype-name}, which can be any pointer type.
 Type checking is performed for result values but not argument values,
 since the parameter
 values are provided by the foreign code and must be assumed to be
@@ -1647,7 +1639,8 @@ of \scheme{foreign-ref} above.
 %----------------------------------------------------------------------------
 \entryheader\label{defn:define-ftype}
 \formdef{define-ftype}{\categorysyntax}{(define-ftype \var{ftype-name} \var{ftype})}
-\formdef{define-ftype}{\categorysyntax}{(define-ftype (\var{ftype-name} \var{ftype}) \dots)}
+\formdef{define-ftype}{\categorysyntax}{(define-ftype \var{ftype-name} \var{ftype} (nongenerative \var{uid}))}
+\formdef{define-ftype}{\categorysyntax}{(define-ftype (\var{ftype-name} \var{ftype} \var{maybe-uid-clause}) \dots)}
 \returns unspecified
 \listlibraries
 \endentryheader
@@ -1662,6 +1655,9 @@ to the foreign type represented \var{ftype} or the foreign types
 represented by \scheme{\var{ftype} \dots}.
 Each \var{ftype-name} can be used to access foreign objects with the
 declared shape, and each can be used in the formation of other ftypes.
+When multiple \var{ftype-name}s are provided, each \var{maybe-uid-clause}
+is either empty or of the form \scheme{(nongenerative \var{uid})}.
+Each \var{uid} must be a gensym.
 
 An \var{ftype} must take one of the following forms:
 
@@ -1789,7 +1785,7 @@ Each \var{ftype-name} in an \var{ftype} must either
 (b) be defined by the current \scheme{define-ftype},
 (c) be a base-type name, i.e., one of the type names supported by
 \scheme{foreign-ref} and \scheme{foreign-set!}, or
-(d) \scheme{ftype-pointer} or \scheme{ftype-scheme-object-pointer},
+(d) be \scheme{ftype-pointer} or \scheme{ftype-scheme-object-pointer},
 which indicate a generic ftype pointer or an ftype pointer for a Scheme
 object, respectively.
 In case (b), any reference within one \var{ftype} to the
@@ -1862,7 +1858,7 @@ inserted.
 
 Multiple-byte scalar values are stored in memory using the
 target machine's native ``endianness,'' e.g., \scheme{little}
-on X86 and X86\_64-based platforms and \scheme{big} on
+on x86 and x86\_64-based platforms and \scheme{big} on
 Sparc-based platforms.
 Big-endian or little-endian representation can be forced via
 the \scheme{endian} ftype with a \scheme{big} or \scheme{little}
@@ -1888,13 +1884,32 @@ virtual machine), a bit field must be specified explicitly
 as \scheme{big} or \scheme{little} endian by an enclosing
 declaration.
 
-Two ftypes are considered equivalent only if defined by the
-same \scheme{ftype} binding.
-If two ftype definitions look identical but appear in two
+When \var{ftype} is an immediate \var{ftype-name} or an
+\var{ftype-name} wrapped only by \scheme{packed}, \scheme{unpacked},
+or \scheme{endian}, then the defined \var{ftype-name} is an
+alias for the \var{ftype}. Otherwise, a ftype definition is syntactically
+generative in the same way as using \scheme{(nongenerative)} with
+\scheme{define-record-type}: two ftypes are equivalent only if defined by the
+same \scheme{ftype} binding. In that case,
+if two ftype definitions look identical but appear in two
 parts of the same program, the ftypes are not identical,
 and attempts to access one using the name of the other via
 the operators described below will fail with a run-time
-exception.
+exception. When a \var{uid} is provided via \scheme{(nongenerative \var{uid})},
+then the defined ftype is equivalent to any other binding with the
+same \var{uid}. A definition with a \var{uid} is rejected if it is
+incompatible with a previous definition using the same \var{uid}.
+A \var{uid} can be provided when \var{ftype-name} is
+\scheme{ftype-pointer}, \scheme{ftype-scheme-object-pointer}, or a
+subtype of one of those; in that case, the definition is generative
+(instead of defining an alias), and it creates a subtype of the given
+\var{ftype-name}.
+
+\index{derived Scheme-object pointer type}%
+If \var{ftype} is \scheme{ftype-scheme-object-pointer}, then the
+defined \var{ftype-name} is a derived Scheme-object pointer type. If
+\var{ftype} is itself a derived Scheme-object pointer type, then so
+is the defined \var{ftype-name}.
 
 Array bounds must always be constant.
 If an array's length cannot be known until run time, the array
@@ -1961,7 +1976,8 @@ with additional fields or elements.
 This allows an instance of the struct or array to be treated as an instance
 of the type of its first field or element, without the need to use
 \scheme{ftype-&ref} to allocate a new pointer to the field or element.
-
+A subtype of \scheme{ftype-scheme-object-pointer} is never created
+in this way, however.
 
 %----------------------------------------------------------------------------
 \entryheader
@@ -2006,7 +2022,9 @@ of a function cannot generally be determined.
 
 If \var{ftype-name} does not describe a function ftype, \var{expr}
 must evaluate to an \var{address} represented as an exact integer in
-the appropriate range for the target machine.
+the appropriate range for the target machine. The type identified
+by \var{ftype-name} must not be \var{ftype-scheme-object-pointer}
+or a derived Scheme-object pointer type.
 
 The ftype-pointer object returned by this procedure encapsulates the
 address and is tagged with a representation of the type identified by
@@ -2114,6 +2132,7 @@ via one of the methods described in Section ~\ref{SECTFOREIGNACCESS}.
 \entryheader\label{desc:make-ftype-scheme-object-pointer}
 \formdef{make-ftype-scheme-object-pointer}{\categorysyntax}{(make-ftype-scheme-object-pointer \var{expr})}
 \formdef{make-ftype-scheme-object-pointer}{\categorysyntax}{(make-ftype-scheme-object-pointer \var{expr} \var{offset})}
+\formdef{make-ftype-scheme-object-pointer}{\categorysyntax}{(make-ftype-scheme-object-pointer \var{expr} \var{offset} \var{ftype-name})}
 \returns an ftype-pointer object that refers to a Scheme object
 \listlibraries
 \endentryheader
@@ -2131,6 +2150,10 @@ The resulting ftype pointer is recognized by
 \scheme{ftype-scheme-object-pointer?} as well as
 \scheme{ftype-pointer?} without an \var{ftype-name}.
 
+If \var{ftype-name} is provided, it must be
+\var{ftype-scheme-object-pointer} or a derived Scheme-object pointer
+type that is defined using \scheme{define-ftype}.
+
 %----------------------------------------------------------------------------
 \entryheader
 \formdef{ftype-pointer?}{\categorysyntax}{(ftype-pointer? \var{obj})}

mats/foreign.ms

@@ -2396,6 +2396,97 @@
   (ftype-pointer-null? (void*->obj-void* (make-ftype-pointer integer-8 0) 0))
   (ftype-pointer-null? (void*->obj-void* (make-ftype-pointer integer-8 -1) 1))
 
+  (begin
+    (define-ftype IUI (struct [a int] [b unsigned-int] [c int]))
+    (define-ftype unsigned-int-ptr (* unsigned-int))
+    (define get-int-uint-int (foreign-procedure "get_int_uint_int" (int unsigned-int int) (& IUI)))
+    (define get-int-uint-int-as-ptr (foreign-procedure "get_int_uint_int" (int unsigned-int int) (& IUI ftype-pointer)))
+    (define get-int-uint-int-as-uint* (foreign-procedure "get_int_uint_int" (int unsigned-int int) (& IUI unsigned-int-ptr)))
+    (define-ftype iui-callback (function ((& IUI)) int))
+    (define-ftype iui-callback-as-ptr (function ((& IUI ftype-pointer)) int))
+    (define-ftype iui-callback-as-uint* (function ((& IUI unsigned-int-ptr)) int))
+    (define call-with-int-uint-int (foreign-procedure "call_with_int_uint_int" ((* iui-callback) int unsigned-int int) int))
+    (define call-with-int-uint-int-as-ptr (foreign-procedure "call_with_int_uint_int" ((* iui-callback-as-ptr) int unsigned-int int) int))
+    (define call-with-int-uint-int-as-uint* (foreign-procedure "call_with_int_uint_int" ((* iui-callback-as-uint*) int unsigned-int int) int))
+    #t)
+
+  (let* ([addr (foreign-alloc (ftype-sizeof IUI))]
+         [p (make-ftype-pointer IUI addr)])
+    (get-int-uint-int p -10 3 100)
+    (and (= -9 (ftype-ref IUI (a) p))
+         (= -9 (ftype-ref int () p))
+         (= 6 (ftype-ref IUI (b) p))
+         (= 99 (ftype-ref IUI (c) p))
+         (begin (foreign-free addr) #t)))
+
+  (let* ([addr (foreign-alloc (ftype-sizeof IUI))]
+         [p (make-ftype-pointer int addr)])
+    (get-int-uint-int-as-ptr p -10 3 100)
+    (and (= -9 (ftype-ref int () p))
+         (= 6 (ftype-any-ref unsigned-int () p (ftype-sizeof int)))
+         (= 99 (ftype-ref int () p 2))
+         (begin (foreign-free addr) #t)))
+
+  (let* ([addr (foreign-alloc (ftype-sizeof IUI))]
+         [p (make-ftype-pointer unsigned-int addr)])
+    (get-int-uint-int-as-ptr p -10 3 100)
+    (and (= 4294967287 (ftype-ref unsigned-int () p))
+         (= 6 (ftype-ref unsigned-int () p 1))
+         (= 99 (ftype-ref unsigned-int () p 2))
+         (begin (foreign-free addr) #t)))
+
+  (let* ([bv (make-bytevector (ftype-sizeof IUI))]
+         [p (make-ftype-scheme-object-pointer bv)])
+    (get-int-uint-int-as-ptr p -10 3 100)
+    (and (= -9 (bytevector-s32-native-ref bv 0))
+         (= 6 (bytevector-s32-native-ref bv 4))
+         (= 99 (bytevector-s32-native-ref bv 8))))
+
+  (error? (let* ([addr (foreign-alloc (ftype-sizeof IUI))]
+                 [p (make-ftype-pointer IUI addr)])
+            (dynamic-wind
+             void
+             (lambda () (get-int-uint-int-as-uint* p -10 3 100))
+             (lambda () (foreign-free addr)))))
+
+  (error? (let* ([addr (foreign-alloc (ftype-sizeof IUI))]
+                 [p (make-ftype-pointer int addr)])
+            (dynamic-wind
+             void
+             (lambda () (get-int-uint-int p -10 3 100))
+             (lambda () (foreign-free addr)))))
+
+  (let* ([cb (lambda (p) ; IUI pointer
+               (+ (ftype-ref IUI (a) p)
+                  (ftype-ref int () p)
+                  (ftype-ref IUI (b) p)
+                  (ftype-ref IUI (c) p)))]
+         [p (make-ftype-pointer iui-callback cb)])
+    (and (= 87 (call-with-int-uint-int p -10 3 100))
+         (begin
+           (unlock-object (foreign-callable-code-object (ftype-pointer-address p)))
+           #t)))
+
+  (let* ([cb (lambda (p) ; generic pointer
+               (+ (ftype-any-ref int () p)
+                  (ftype-any-ref int () p (ftype-sizeof int))
+                  (ftype-any-ref int () p (* 2 (ftype-sizeof int)))))]
+         [p (make-ftype-pointer iui-callback-as-ptr cb)])
+    (and (= 96 (call-with-int-uint-int-as-ptr p -10 3 100))
+         (begin
+           (unlock-object (foreign-callable-code-object (ftype-pointer-address p)))
+           #t)))
+
+  (let* ([cb (lambda (p) ; unsigned-int pointer
+               (+ (quotient (ftype-ref unsigned-int () p) 16)
+                  (ftype-ref unsigned-int () p 1)
+                  (ftype-ref unsigned-int () p 2)))]
+         [p (make-ftype-pointer iui-callback-as-uint* cb)])
+    (and (= (+ (quotient 4294967287 16) 6 99) (call-with-int-uint-int-as-uint* p -10 3 100))
+         (begin
+           (unlock-object (foreign-callable-code-object (ftype-pointer-address p)))
+           #t)))
+
   (begin 
     (define-ftype A (struct [x uptr] [y uptr]))
     (define a (make-ftype-pointer A (foreign-alloc (ftype-sizeof A))))

mats/foreign2.c

@@ -567,3 +567,19 @@ EXPORT double many_doubles_and_float_and_three_floats(double a, double b, double
 EXPORT double many_doubles_and_three_floats_and_three_floats(double a, double b, double c, double d, double e, double f, double g, double h, three_floats i, three_floats j) {
   return a + b + c + d + e + f + g + h + i.a + i.b + i.c + j.a + j.b + j.c;
 }
+
+typedef struct {
+  int a;
+  unsigned int b;
+  int c;
+} int_uint_int;
+
+EXPORT int_uint_int get_int_uint_int(int a, unsigned int b, int c){
+  int_uint_int iui = { a + 1, b * 2, c - 1 };
+  return iui;
+}
+
+EXPORT int call_with_int_uint_int(int (*f)(int_uint_int), int a, unsigned int b, int c){
+  int_uint_int iui = { a + 1, b * 2, c - 1 };
+  return f(iui);
+}