add stdbool foreign type

The `stdbool` type corresponds to `bool` as defined by the host machine's "stdbool.h", which is 1 byte for all currently supported platforms. That's different than `boolean`, which instead reflects a traditional C encoding of booleans as `int`, which is 4 bytes for all currently supported platforms. The "stdbool.h" header is standard as of C99, while Chez Scheme's implementation generally sticks to C89. But the header needed only for a test file, and it tends to be available in C89 enviornments, too.
cisco · Sep 20, 2024 · 834ce00 · 834ce00
1 parent f01e22d
commit 834ce00
Show file tree

Hide file tree

Showing 13 changed files with 183 additions and 39 deletions.
diff --git a/csug/foreign.stex b/csug/foreign.stex
@@ -492,6 +492,12 @@ Transmission of fixnums is slightly faster than transmission of
 \scheme{#f} is converted to 0; all other objects are converted to 1.
 The argument is passed to C as an \scheme{int}.
 
+\foreigntype{\scheme{stdbool}}
+\index{\scheme{stdbool}}Any Scheme object may be passed as a boolean.
+\scheme{#f} is converted to 0; all other objects are converted to 1.
+The argument is passed to C as a \scheme{bool} defined by the the host
+machine's \scheme{stdbool.h} include file.
+
 \foreigntype{\scheme{char}}
 \index{\scheme{char}}Only Scheme characters with Unicode scalar values
 in the range 0 through 255 are valid \scheme{char} parameters.
@@ -772,6 +778,12 @@ fixed-size type above, depending on the size of a C pointer.
 into a Scheme boolean.
 0 is converted to \scheme{#f}; all other values are converted to \scheme{#t}.
 
+\foreigntype{\scheme{stdbool}}
+\index{\scheme{stdbool}}This type converts a C \scheme{bool} return value
+into a Scheme boolean, where \scheme{bool} is from the host machine's \scheme{stdbool.h}
+include file.
+0 is converted to \scheme{#f}; all other values are converted to \scheme{#t}.
+
 \foreigntype{\scheme{char}}
 \index{\scheme{char}}This type converts a C \scheme{unsigned char} return value
 into a Scheme character, as if via \scheme{integer->char}.
@@ -1427,8 +1439,9 @@ Several additional machine-dependent types are recognized:
 \begin{itemize}
 \item \scheme{iptr},
 \item \scheme{uptr},
-\item \scheme{fixnum}, and
-\item \scheme{boolean}.
+\item \scheme{fixnum},
+\item \scheme{boolean}, and
+\item \scheme{stdbool}.
 \end{itemize}
 
 \scheme{uptr} is equivalent to \scheme{void*}; both are treated as
@@ -1439,6 +1452,9 @@ to the fixnum range.
 \scheme{boolean} is treated as an \scheme{int}, with zero
 converted to the Scheme value \scheme{#f} and all
 other values converted to \scheme{#t}.
+\scheme{stdbool} is treated as an \scheme{bool} from \scheme{stdbool.h}, with zero
+converted to the Scheme value \scheme{#f} and all
+other values converted to \scheme{#t}.
 
 Finally, several fixed-sized types are also supported:
 
@@ -1482,7 +1498,7 @@ to be stored, one of those listed in the description of
 \scheme{foreign-ref} above.
 Scheme characters are converted to type \scheme{char} or \scheme{wchar_t}
 as if via \scheme{char->integer}.
-For type \scheme{boolean}, Scheme \scheme{#f} is converted to the
+For type \scheme{boolean} or \scheme{stdbool}, Scheme \scheme{#f} is converted to the
 \scheme{int} 0, and any other Scheme object is converted to 1.
 
 \var{address} must be an exact integer in the range $-2^{w-1}$ through

diff --git a/mats/foreign.ms b/mats/foreign.ms
@@ -933,6 +933,7 @@
   (equal? (foreign-sizeof 'unsigned-long) (foreign-sizeof 'long))
   (equal? (foreign-sizeof 'unsigned-long-long) (foreign-sizeof 'long-long))
   (equal? (foreign-sizeof 'boolean) (foreign-sizeof 'int))
+  (equal? (foreign-sizeof 'stdbool) (foreign-sizeof 'stdbool))
   (equal? (foreign-sizeof 'fixnum) (foreign-sizeof 'iptr))
   (equal? (foreign-sizeof 'scheme-object) (foreign-sizeof 'void*))
   (equal? (foreign-sizeof 'ptr) (foreign-sizeof 'void*))
@@ -2594,6 +2595,19 @@
     (and
       (eqv? (Srvtest_boolean Frvtest_boolean "abcdefg") #t)
       (eqv? (Srvtest_boolean Frvtest_boolean "gfedcba") #f)))
+  (let ()
+    (define Frvtest_stdbool
+      (foreign-callable
+        (lambda (x) (equal? x "abCDEfg"))
+        (scheme-object)
+        stdbool))
+    (define Srvtest_stdbool
+      (foreign-procedure "Srvtest_stdbool"
+        (scheme-object scheme-object)
+        stdbool))
+    (and
+      (eqv? (Srvtest_stdbool Frvtest_stdbool "abCDEfg") #t)
+      (eqv? (Srvtest_stdbool Frvtest_stdbool "gfEDCba") #f)))
   (let ()
     (define Frvtest_fixnum
       (foreign-callable

diff --git a/mats/foreign3.c b/mats/foreign3.c
@@ -31,6 +31,9 @@
 #include "scheme.h"
 #endif
 
+/* Standard in C99, but widely available in environments for earlier C dialects: */
+#include <stdbool.h>
+
 EXPORT int chk_data(void) {
     static char c[10]="ABCDEFGH";
 
@@ -178,6 +181,10 @@ EXPORT char Srvtest_char(ptr code, ptr x1) {
     return (*((char (*)(ptr))Sforeign_callable_entry_point(code)))(x1);
 }
 
+EXPORT bool Srvtest_stdbool(ptr code, ptr x1) {
+    return (*((bool (*)(ptr))Sforeign_callable_entry_point(code)))(x1);
+}
+
 #ifdef _WIN32
 EXPORT int __stdcall sum_stdcall(int a, int b) {
     return a + b;

diff --git a/mats/ftype.ms b/mats/ftype.ms
@@ -443,6 +443,7 @@
         (uptr . ,(if (< (fixnum-width) 32) "uint32_t" "uint64_t"))
         (fixnum . ,(if (< (fixnum-width) 32) "int32_t" "int64_t"))
         (boolean . "int")
+        (stdbool . "int8_t")
         (integer-8 . "int8_t")
         (unsigned-8 . "uint8_t")
         (integer-16 . "int16_t")
@@ -723,7 +724,8 @@
            [a15 fixnum]
            [a16 iptr]
            [a17 uptr]
-           [a18 void*]))
+           [a18 void*]
+           [a19 stdbool]))
        (define a (make-ftype-pointer A (foreign-alloc (ftype-sizeof A))))
        (free-after a
          (ftype-set! A (a1) a 3.5)
@@ -744,6 +746,7 @@
          (ftype-set! A (a16) a -30004)
          (ftype-set! A (a17) a #xabcdef07)
          (ftype-set! A (a18) a 25000)
+         (ftype-set! A (a19) a 'howdy)
          (list
            (ftype-ref A (a1) a)
            (ftype-ref A (a2) a)
@@ -762,7 +765,8 @@
            (ftype-ref A (a15) a)
            (ftype-ref A (a16) a)
            (ftype-ref A (a17) a)
-           (ftype-ref A (a18) a))))
+           (ftype-ref A (a18) a)
+           (ftype-ref A (a19) a))))
     `(3.5
       -4.5
       -30000
@@ -780,7 +784,8 @@
       ,(most-positive-fixnum)
       -30004
       #xabcdef07
-      25000))
+      25000
+      #t))
 
   (begin
     (define-ftype A
@@ -4022,7 +4027,8 @@
              [a15 fixnum]
              [a16 iptr]
              [a17 uptr]
-             [a18 void*])))
+             [a18 void*]
+             [a19 stdbool])))
        (define a (make-ftype-pointer A (foreign-alloc (ftype-sizeof A))))
        (free-after a
          (ftype-set! A (a1) a 3.5)
@@ -4043,6 +4049,7 @@
          (ftype-set! A (a16) a -30004)
          (ftype-set! A (a17) a #xabcdef07)
          (ftype-set! A (a18) a 25000)
+         (ftype-set! A (a19) a 'howdy)
          (list
            (ftype-ref A (a1) a)
            (ftype-ref A (a2) a)
@@ -4061,7 +4068,8 @@
            (ftype-ref A (a15) a)
            (ftype-ref A (a16) a)
            (ftype-ref A (a17) a)
-           (ftype-ref A (a18) a))))
+           (ftype-ref A (a18) a)
+           (ftype-ref A (a19) a))))
     `(3.5
       -4.5
       -30000
@@ -4079,7 +4087,8 @@
       ,(most-positive-fixnum)
       -30004
       #xabcdef07
-      25000))
+      25000
+      #t))
   (equal?
     (let ()
        (define-ftype A
@@ -4102,7 +4111,8 @@
              [a15 fixnum]
              [a16 iptr]
              [a17 uptr]
-             [a18 void*])))
+             [a18 void*]
+             [a19 stdbool])))
        (define a (make-ftype-pointer A (foreign-alloc (ftype-sizeof A))))
        (free-after a
          (ftype-set! A (a1) a 3.5)
@@ -4123,6 +4133,7 @@
          (ftype-set! A (a16) a -30004)
          (ftype-set! A (a17) a #xabcdef07)
          (ftype-set! A (a18) a 25000)
+         (ftype-set! A (a19) a 'howdy)
          (list
            (ftype-ref A (a1) a)
            (ftype-ref A (a2) a)
@@ -4141,7 +4152,8 @@
            (ftype-ref A (a15) a)
            (ftype-ref A (a16) a)
            (ftype-ref A (a17) a)
-           (ftype-ref A (a18) a))))
+           (ftype-ref A (a18) a)
+           (ftype-ref A (a19) a))))
     `(3.5
       -4.5
       -30000
@@ -4159,7 +4171,8 @@
       ,(most-positive-fixnum)
       -30004
       #xabcdef07
-      25000))
+      25000
+      #t))
   (equal?
     (let ()
        (define-ftype A
@@ -4182,7 +4195,8 @@
              [a15 fixnum]
              [a16 iptr]
              [a17 uptr]
-             [a18 void*])))
+             [a18 void*]
+             [a19 stdbool])))
        (define a (make-ftype-pointer A (foreign-alloc (ftype-sizeof A))))
        (free-after a
          (ftype-set! A (a1) a 3.5)
@@ -4203,6 +4217,7 @@
          (ftype-set! A (a16) a -30004)
          (ftype-set! A (a17) a #xabcdef07)
          (ftype-set! A (a18) a 25000)
+         (ftype-set! A (a19) a 'howdy)
          (list
            (ftype-ref A (a1) a)
            (ftype-ref A (a2) a)
@@ -4221,7 +4236,8 @@
            (ftype-ref A (a15) a)
            (ftype-ref A (a16) a)
            (ftype-ref A (a17) a)
-           (ftype-ref A (a18) a))))
+           (ftype-ref A (a18) a)
+           (ftype-ref A (a19) a))))
     `(3.5
       -4.5
       -30000
@@ -4239,7 +4255,8 @@
       ,(most-positive-fixnum)
       -30004
       #xabcdef07
-      25000))
+      25000
+      #t))
 
  ; ----------------
   (begin
@@ -5667,7 +5684,8 @@
           [a15 fixnum]
           [a16 iptr]
           [a17 uptr]
-          [a18 void*])))
+          [a18 void*]
+          [a19 stdbool])))
     #t)
   (equivalent-expansion?
     (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
@@ -5691,6 +5709,7 @@
            (ftype-ref A (a16) x)
            (ftype-ref A (a17) x)
            (ftype-ref A (a18) x)
+           (ftype-ref A (a19) x)
            x)))
     '(lambda (x) x))
   (equivalent-expansion?
@@ -5715,6 +5734,7 @@
            (ftype-&ref A (a16) x)
            (ftype-&ref A (a17) x)
            (ftype-&ref A (a18) x)
+           (ftype-&ref A (a19) x)
            x)))
     '(lambda (x) x))
   (begin
@@ -5738,7 +5758,8 @@
           [a15 fixnum]
           [a16 iptr]
           [a17 uptr]
-          [a18 void*])))
+          [a18 void*]
+          [a19 stdbool])))
     #t)
   (equivalent-expansion?
     (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
@@ -5762,6 +5783,7 @@
            (ftype-ref A (a16) x)
            (ftype-ref A (a17) x)
            (ftype-ref A (a18) x)
+           (ftype-ref A (a19) x)
            x)))
     '(lambda (x) x))
   (equivalent-expansion?
@@ -5786,6 +5808,7 @@
            (ftype-&ref A (a16) x)
            (ftype-&ref A (a17) x)
            (ftype-&ref A (a18) x)
+           (ftype-&ref A (a19) x)
            x)))
     '(lambda (x) x))
   (begin

diff --git a/release_notes/release_notes.stex b/release_notes/release_notes.stex
@@ -124,6 +124,11 @@ iOS compilation target. Native-code support for iOS is currently limited
 to applications attached to a debugger as the platform does not allow
 executable code to be loaded at runtime.
 
+\subsection{Standard boolean foreign type (10.1.0)}
+
+The \scheme{stdbool} foregin type corresponds to \scheme{bool} as
+defined by the host machine's \scheme{stdbool.h} include file.
+
 \subsection{Unicode 15.1 support (10.0.0)}
 
 The character sets, character classes, and word-breaking algorithms for character, string,

diff --git a/s/cmacros.ss b/s/cmacros.ss
@@ -357,7 +357,7 @@
 ;; ---------------------------------------------------------------------
 ;; Version and machine types:
 
-(define-constant scheme-version #x0a010002)
+(define-constant scheme-version #x0a010003)
 
 (define-syntax define-machine-types
   (lambda (x)
@@ -419,7 +419,7 @@
   rv64nb    trv64nb
   la64le    tla64le
 )
-
+<
 (include "machine.def")
 
 (define-constant machine-type-name (cdr (assv (constant machine-type) (constant machine-type-alist))))
@@ -1209,7 +1209,8 @@
       (fixnum (constant ptr-bytes) fixnum?)
       (char 1 $foreign-char?)
       (wchar (fxsrl (constant wchar-bits) 3) $foreign-wchar?)
-      (boolean (fxsrl (constant int-bits) 3) (lambda (x) #t)))))
+      (boolean (fxsrl (constant int-bits) 3) (lambda (x) #t))
+      (stdbool (fxsrl (constant stdbool-bits) 3) (lambda (x) #t)))))
 )
 
 (define-syntax record-datatype

diff --git a/s/cp0.ss b/s/cp0.ss
@@ -3729,7 +3729,7 @@
                 (lambda (x)
                   (syntax-case x ()
                     [(_ type bytes pred)
-                     (if (memq (datum type) '(scheme-object boolean))
+                     (if (memq (datum type) '(scheme-object boolean stdbool))
                          #'($oops who "unexpected type ~s" 'type)
                          #'(build-primcall 3 'pred
                              (list (build-ref val-t))))])))
@@ -3752,7 +3752,7 @@
                                    (lambda (fld t check*)
                                      (let* ([type (fld-type fld)]
                                             [real-type (filter-foreign-type type)])
-                                       (if (memq real-type '(scheme-object boolean))
+                                       (if (memq real-type '(scheme-object boolean stdbool))
                                            check*
                                            (cons
                                              `(if ,(type->pred 'record-constructor real-type t)
@@ -4007,7 +4007,7 @@
                                      [rec-t (cp0-make-temp #t)]
                                      [val-t (cp0-make-temp #t)])
                                 (let ([expr `(record-set! ,rtd ,type ,index (ref #f ,rec-t) (ref #f ,val-t))]
-                                      [pred (and (not (memq real-type '(scheme-object boolean)))
+                                      [pred (and (not (memq real-type '(scheme-object boolean stdbool)))
                                                  (type->pred who real-type val-t))])
                                   (cond
                                     [(fx= level 3)