diff --git a/boot/pb/equates.h b/boot/pb/equates.h index c971a9f32..286854a32 100644 --- a/boot/pb/equates.h +++ b/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 diff --git a/boot/pb/petite.boot b/boot/pb/petite.boot index 1b27f289f..1efde15f4 100644 Binary files a/boot/pb/petite.boot and b/boot/pb/petite.boot differ diff --git a/boot/pb/scheme.boot b/boot/pb/scheme.boot index 4bc72761f..8822b619d 100644 Binary files a/boot/pb/scheme.boot and b/boot/pb/scheme.boot differ diff --git a/boot/pb/scheme.h b/boot/pb/scheme.h index cea71232d..b8ae62c3f 100644 --- a/boot/pb/scheme.h +++ b/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 */ diff --git a/build.zuo b/build.zuo index 0a25a28ab..b910380f2 100644 --- a/build.zuo +++ b/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) diff --git a/c/fasl.c b/c/fasl.c index 8ecb5b8e9..d6d8d972a 100644 --- a/c/fasl.c +++ b/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 diff --git a/csug/foreign.stex b/csug/foreign.stex index 72371a12f..31e6780dc 100644 --- a/csug/foreign.stex +++ b/csug/foreign.stex @@ -668,7 +668,7 @@ 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 @@ -676,7 +676,7 @@ other words, this type is specific to foreign pointers created with \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})} diff --git a/mats/foreign.ms b/mats/foreign.ms index 1ec0bcbbb..ab2354a32 100644 --- a/mats/foreign.ms +++ b/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)))) diff --git a/mats/foreign2.c b/mats/foreign2.c index 8181ffe70..a21b14c45 100644 --- a/mats/foreign2.c +++ b/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); +} diff --git a/mats/ftype.ms b/mats/ftype.ms index 35c94e639..f95ad186b 100644 --- a/mats/ftype.ms +++ b/mats/ftype.ms @@ -124,6 +124,44 @@ (define-ftype F1 (function (int) int)) #t) + (error? ; bad uid + (define-ftype P1 ftype-pointer (nongenerative 100))) + + (error? ; require gensym for uid + (define-ftype P1 ftype-pointer (nongenerative p))) + + (error? ; must include a uid + (define-ftype I1 int (nongenerative))) + + (error? ; bad syntax + (define-ftype I1 int (ng #{int of6r270eh1theews7ikmyh8vo-0}))) + + (error? ; bad syntax + (define-ftype I1 int nongenerative)) + + (error? ; must include a uid + (define-ftype (I1 int (nongenerative)))) + + (error? ; bad syntax + (define-ftype (I1 int (ng #{int of6r270eh1theews7ikmyh8vo-0})))) + + (error? ; bad syntax + (define-ftype (I1 int nongenerative))) + + (error? ; alias cannot have a uid + (define-ftype I1 int (nongenerative #{int of6r270eh1theews7ikmyh8vo-0}))) + + (begin + (define-ftype PI1 (* int) (nongenerative #{int of6r270eh1theews7ikmyh8vo-0})) + (define-ftype PI2 (* int) (nongenerative #{int of6r270eh1theews7ikmyh8vo-0})) + (define-ftype + (PI3 (* int) (nongenerative #{int of6r270eh1theews7ikmyh8vo-0})) + (PI4 (* long) (nongenerative #{int of6r270eh1theews7ikmyh8vo-2}))) + #t) + + (error? ; mismatch + (define-ftype PI5 (* long) (nongenerative #{int of6r270eh1theews7ikmyh8vo-0}))) + (error? ; function ftypes have unknown size (ftype-sizeof F1)) @@ -170,6 +208,18 @@ (ftype-pointer-address (ftype-&ref Ac (c3) x)))) '(6 1 16 0 2 4 6 8)) + (equivalent-expansion? + (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f]) + (expand/optimize + '(lambda () + (#2%list + (ftype-pointer-address (ftype-&ref Ac (c1 a1) (make-ftype-pointer Ac 0))) + (ftype-pointer-address (ftype-&ref Ac (c1 a2) (make-ftype-pointer Ac 0))) + (ftype-pointer-address (ftype-&ref Ac (c1 a3) (make-ftype-pointer Ac 0))) + (ftype-pointer-address (ftype-&ref Ac (c2 b1) (make-ftype-pointer Ac 0))) + (ftype-pointer-address (ftype-&ref Ac (c3) (make-ftype-pointer Ac 0))))))) + '(lambda () (#2%list 0 2 4 6 8))) + (begin (define addr (foreign-alloc (ftype-sizeof Ac))) (define x (make-ftype-pointer Ac addr)) @@ -707,6 +757,17 @@ [P3 (struct [a ftype-scheme-object-pointer])] [P4 (struct [a (* ftype-scheme-object-pointer)])]) + ; ---------------- + + (begin + (define-ftype TSsub + (struct [a ftype-scheme-object-pointer])) + (define-ftype TAsub + (array 10 ftype-scheme-object-pointer)) + #t) + (not (ftype-scheme-object-pointer? (make-ftype-pointer TSsub 0))) + (not (ftype-scheme-object-pointer? (make-ftype-pointer TAsub 0))) + ; ---------------- (equal? @@ -1392,6 +1453,55 @@ (foreign-free (ftype-pointer-address s-fptr)) (equal? (list a b c d) (list 42 7.125 75 8.25)))) + ; ------------------------------------------------------------ + (begin + (define-ftype x-pointer ftype-pointer) + (define-ftype x1-pointer ftype-pointer (nongenerative #{x1 febdtjdl3qff3qc00rnyph70g-0})) + (define-ftype x2-pointer x1-pointer (nongenerative #{x2 febdtjdl3qff3qc00rnyph70g-2})) + (define-ftype s-pointer ftype-scheme-object-pointer) + (define-ftype s1-pointer ftype-scheme-object-pointer (nongenerative #{s1 febdtjdl3qff3qc00rnyph70g-1})) + (define-ftype s2-pointer s1-pointer (nongenerative #{s2 febdtjdl3qff3qc00rnyph70g-3})) + #t) + + (error? ; cannot use scheme-object pointer ftype + (make-ftype-pointer s-pointer 0)) + (error? ; must use scheme-object pointer ftype + (make-ftype-scheme-object-pointer 0 0 x-pointer)) + + (ftype-pointer? (make-ftype-pointer x-pointer 0)) + (ftype-pointer? x-pointer (make-ftype-pointer x-pointer 0)) + (not (ftype-pointer? x1-pointer (make-ftype-pointer x-pointer 0))) + (not (ftype-pointer? x2-pointer (make-ftype-pointer x-pointer 0))) + (ftype-pointer? x-pointer (make-ftype-pointer x1-pointer 0)) + (ftype-pointer? x-pointer (make-ftype-pointer x2-pointer 0)) + (ftype-pointer? x1-pointer (make-ftype-pointer x2-pointer 0)) + (not (ftype-pointer? x2-pointer (make-ftype-pointer x1-pointer 0))) + + (ftype-pointer? (make-ftype-scheme-object-pointer 0 0 s-pointer)) + (ftype-pointer? x-pointer (make-ftype-scheme-object-pointer 0 0 s-pointer)) + (ftype-pointer? s-pointer (make-ftype-scheme-object-pointer 0 0 s-pointer)) + (not (ftype-pointer? s1-pointer (make-ftype-scheme-object-pointer 0 0 s-pointer))) + (not (ftype-pointer? s2-pointer (make-ftype-scheme-object-pointer 0 0 s-pointer))) + (not (ftype-pointer? x1-pointer (make-ftype-scheme-object-pointer 0 0 s-pointer))) + (not (ftype-pointer? x2-pointer (make-ftype-scheme-object-pointer 0 0 s-pointer))) + (ftype-scheme-object-pointer? (make-ftype-scheme-object-pointer 0 0 s-pointer)) + (ftype-scheme-object-pointer? (make-ftype-scheme-object-pointer 0 0 s1-pointer)) + (ftype-scheme-object-pointer? (make-ftype-scheme-object-pointer 0 0 s2-pointer)) + (ftype-pointer? s-pointer (make-ftype-scheme-object-pointer 0 0 s1-pointer)) + (ftype-pointer? s1-pointer (make-ftype-scheme-object-pointer 0 0 s1-pointer)) + (not (ftype-pointer? s2-pointer (make-ftype-scheme-object-pointer 0 0 s1-pointer))) + (ftype-pointer? s2-pointer (make-ftype-scheme-object-pointer 0 0 s2-pointer)) + + (let loop ([n 1000]) + (or (zero? n) + (let () + (define bstr (make-bytevector 100)) + (define p (make-ftype-scheme-object-pointer bstr 0 s2-pointer)) + (collect) + (and (eq? bstr (ftype-scheme-object-pointer-object p)) + (loop (sub1 n)))))) + + ; ------------------------------------------------------------ (begin ;; Show that binding does not interfere with native types. (define-syntax unsigned-16 (make-compile-time-value "Non-interfering binding")) @@ -3074,6 +3184,36 @@ (begin (load "testfile-ftype5.so") (ftype-pointer? ftype5-A (make-ftype-pointer ftype5-A 0))) + + (begin + (with-output-to-file "testfile-ftype6.ss" + (lambda () + (pretty-print + '(define-ftype ftype6-A (struct [a double] [b wchar]) + (nongenerative #{ftype-6 jni7x5i9jgwk8q0utdook23gt-1}))) + (pretty-print + '(define a (make-ftype-pointer ftype6-A (foreign-alloc (ftype-sizeof ftype6-A)))))) + 'replace) + (load "testfile-ftype6.ss") + #t) + (begin + (for-each separate-compile '(ftype6)) + (load "testfile-ftype6.so") + #t) + (begin + ;; separate compile with same uid should be ok + (with-output-to-file "testfile-ftype6.ss" + (lambda () + (pretty-print + '(define-ftype ftype6-A (union [a double] [b wchar]) + (nongenerative #{ftype-6 jni7x5i9jgwk8q0utdook23gt-1})))) + 'replace) + (for-each separate-compile '(ftype6)) + #t) + (error? + ;; ...but fail on load + (load "testfile-ftype6.so")) + ) (mat ftype-bits diff --git a/mats/misc.ms b/mats/misc.ms index 2259f126d..dec4f411f 100644 --- a/mats/misc.ms +++ b/mats/misc.ms @@ -2058,7 +2058,9 @@ (box 88) "" '#() '#vu8() (make-fxvector 0) (make-flvector 0) (string->immutable-string "") (vector->immutable-vector '#()) - (bytevector->immutable-bytevector '#vu8()))) + (bytevector->immutable-bytevector '#vu8()) + (make-ftype-pointer ftype-pointer 16) + (make-ftype-scheme-object-pointer #t 1))) (define (same-vfasl-content? v) (andmap (lambda (a b) (or (eqv? a b) @@ -2078,6 +2080,16 @@ (vfasl-demo-x b)) (equal? (vfasl-demo-y a) (vfasl-demo-y b))) + (and (ftype-scheme-object-pointer? a) + (ftype-scheme-object-pointer? b) + (equal? (ftype-scheme-object-pointer-object a) + (ftype-scheme-object-pointer-object b)) + (eqv? (ftype-scheme-object-pointer-offset a) + (ftype-scheme-object-pointer-offset b))) + (and (ftype-pointer? a) + (ftype-pointer? b) + (eqv? (ftype-pointer-address a) + (ftype-pointer-address b))) (begin (printf "~s ~s\n" a b) #f))) diff --git a/mats/patch-compile-0-f-t-f b/mats/patch-compile-0-f-t-f index 840fc2157..992a3fb80 100644 --- a/mats/patch-compile-0-f-t-f +++ b/mats/patch-compile-0-f-t-f @@ -1,5 +1,5 @@ -*** output-compile-0-f-f-f-experr/errors-compile-0-f-f-f 2026-03-10 17:14:12.556278673 -0700 ---- output-compile-0-f-t-f-experr/errors-compile-0-f-t-f 2026-03-10 17:14:08.862276807 -0700 +*** output-compile-0-f-f-f-experr/errors-compile-0-f-f-f Sat Mar 14 11:28:51 2026 +--- output-compile-0-f-t-f-experr/errors-compile-0-f-t-f Sat Mar 14 11:28:48 2026 *************** *** 212,218 **** 3.mo:Expected error in mat dipa-letrec: "attempt to reference undefined variable a". @@ -18,22 +18,24 @@ 3.mo:Expected error in mat dipa-letrec: "attempt to reference undefined variable a". 3.mo:Expected error in mat dipa-letrec: "attempt to reference undefined variable a". *************** -*** 231,237 **** +*** 231,238 **** 3.mo:Expected error in mat cpvalid: "attempt to reference undefined variable b". 3.mo:Expected error in mat cpvalid: "attempt to reference undefined variable a". 3.mo:Expected error in mat cpvalid: "attempt to reference undefined variable g". -! 3.mo:Expected error in mat cpvalid: "attempt to reference undefined variable f". 3.mo:Expected error in mat cpvalid: "attempt to reference undefined variable f". +- 3.mo:Expected error in mat cpvalid: "attempt to reference undefined variable f". 3.mo:Expected error in mat cpvalid: "attempt to reference undefined variable c". 3.mo:Expected warning in mat cpvalid: "possible attempt to reference undefined variable x". ---- 231,237 ---- + 3.mo:Expected error in mat cpvalid: "attempt to reference undefined variable x". +--- 231,238 ---- 3.mo:Expected error in mat cpvalid: "attempt to reference undefined variable b". 3.mo:Expected error in mat cpvalid: "attempt to reference undefined variable a". 3.mo:Expected error in mat cpvalid: "attempt to reference undefined variable g". -! 3.mo:Expected error in mat cpvalid: "attempt to reference undefined variable g". ++ 3.mo:Expected error in mat cpvalid: "attempt to reference undefined variable g". 3.mo:Expected error in mat cpvalid: "attempt to reference undefined variable f". 3.mo:Expected error in mat cpvalid: "attempt to reference undefined variable c". 3.mo:Expected warning in mat cpvalid: "possible attempt to reference undefined variable x". + 3.mo:Expected error in mat cpvalid: "attempt to reference undefined variable x". *************** *** 278,287 **** 3.mo:Expected error in mat mrvs: "returned 3 values to single value return context". diff --git a/mats/patch-compile-0-t-f-f b/mats/patch-compile-0-t-f-f index 74e14a584..5a0583b12 100644 --- a/mats/patch-compile-0-t-f-f +++ b/mats/patch-compile-0-t-f-f @@ -1,5 +1,5 @@ -*** output-compile-0-f-f-f-experr/errors-compile-0-f-f-f 2026-03-10 17:14:12.556278673 -0700 ---- output-compile-0-t-f-f-experr/errors-compile-0-t-f-f 2026-03-10 17:14:26.327284163 -0700 +*** output-compile-0-f-f-f-experr/errors-compile-0-f-f-f Sat Mar 14 11:28:51 2026 +--- output-compile-0-t-f-f-experr/errors-compile-0-t-f-f Sat Mar 14 11:32:58 2026 *************** *** 180,186 **** 3.mo:Expected error in mat case-lambda: "incorrect number of arguments 2 to #". @@ -4721,22 +4721,24 @@ 7.mo:Expected error in mat top-level-value-functions: "define-top-level-value: # is not a symbol". 7.mo:Expected error in mat top-level-value-functions: "variable i-am-not-bound-i-hope is not bound". *************** -*** 8317,8323 **** +*** 8317,8324 **** record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 1 to #". record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 1 to #". record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 3 to #". -! record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 3 to #". +- record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 3 to #". record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 4 to #". record.mo:Expected error in mat r6rs-records-procedural: "make-record-constructor-descriptor: record constructor descriptor # is not for parent of record type #". record.mo:Expected error in mat r6rs-records-procedural: "make-record-type-descriptor: cannot extend sealed record type # as foo". ---- 8317,8323 ---- + record.mo:Expected error in mat r6rs-records-syntactic: "invalid syntax point". +--- 8317,8324 ---- record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 1 to #". record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 1 to #". record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 3 to #". -! record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 4 to #". record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 4 to #". ++ record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 4 to #". record.mo:Expected error in mat r6rs-records-procedural: "make-record-constructor-descriptor: record constructor descriptor # is not for parent of record type #". record.mo:Expected error in mat r6rs-records-procedural: "make-record-type-descriptor: cannot extend sealed record type # as foo". + record.mo:Expected error in mat r6rs-records-syntactic: "invalid syntax point". *************** *** 8408,8527 **** hash.mo:Expected error in mat old-hash-table: "hash-table-for-each: ((a . b)) is not an eq hashtable". @@ -6434,7 +6436,7 @@ foreign.mo:Expected error in mat foreign-sizeof: "foreign-sizeof: invalid foreign type specifier 1". foreign.mo:Expected error in mat foreign-bytevectors: "u8*->u8*: invalid foreign-procedure argument "hello"". *************** -*** 10976,10988 **** +*** 10991,11003 **** unix.mo:Expected error in mat file-operations: "file-access-time: failed for "testlink": no such file or directory". unix.mo:Expected error in mat file-operations: "file-change-time: failed for "testlink": no such file or directory". unix.mo:Expected error in mat file-operations: "file-modification-time: failed for "testlink": no such file or directory". @@ -6448,7 +6450,7 @@ windows.mo:Expected error in mat registry: "get-registry: pooh is not a string". windows.mo:Expected error in mat registry: "put-registry!: 3 is not a string". windows.mo:Expected error in mat registry: "put-registry!: 3 is not a string". ---- 10976,10988 ---- +--- 10991,11003 ---- unix.mo:Expected error in mat file-operations: "file-access-time: failed for "testlink": no such file or directory". unix.mo:Expected error in mat file-operations: "file-change-time: failed for "testlink": no such file or directory". unix.mo:Expected error in mat file-operations: "file-modification-time: failed for "testlink": no such file or directory". @@ -6463,7 +6465,7 @@ windows.mo:Expected error in mat registry: "put-registry!: 3 is not a string". windows.mo:Expected error in mat registry: "put-registry!: 3 is not a string". *************** -*** 11010,11081 **** +*** 11025,11096 **** ieee.mo:Expected error in mat flonum->fixnum: "flonum->fixnum: result for -inf.0 would be outside of fixnum range". ieee.mo:Expected error in mat flonum->fixnum: "flonum->fixnum: result for +nan.0 would be outside of fixnum range". ieee.mo:Expected error in mat fllp: "fllp: 3 is not a flonum". @@ -6536,7 +6538,7 @@ date.mo:Expected error in mat time: "time>=?: 3 is not a time record". date.mo:Expected error in mat time: "time>=?: # is not a time record". date.mo:Expected error in mat time: "time>=?: types of