make-foreign-object-type: add #:super to provide superclasses

* module/system/foreign-object.scm (make-foreign-object-type): allow
specification of superclasses via #:super.

NEWS

@@ -37,6 +37,10 @@ SEEK_HOLE values can now be passed to the 'seek' procedure to change
 file offset to the next piece of data or to the next hole in sparse
 files.  See "Random Access" in the manual for details.
 
+** ((scm foreign-object) make-foreign-object-type) now supports #:super
+
+A list of superclasses can now be provided via #:super.
+
 * Bug fixes
 
 ** Fix incorrect comparison between exact and inexact numbers

doc/ref/api-foreign-objects.texi

@@ -103,11 +103,14 @@ and Scheme}, for some examples.
 (use-modules (system foreign-object))
 @end example
 
-@deffn {Scheme Procedure} make-foreign-object-type name slots [#:finalizer=#f]
+@deffn {Scheme Procedure} make-foreign-object-type name slots [#:finalizer=#f] [#:supers='()]
+
 Make a new foreign object type.  See the above documentation for
 @code{scm_make_foreign_object_type}; these functions are exactly
 equivalent, except for the way in which the finalizer gets attached to
-instances (an internal detail).
+instances (an internal detail), and the fact that this function accepts
+an optional list of superclasses, which will be paseed to
+@code{make-class}.
 
 The resulting value is a GOOPS class.  @xref{GOOPS}, for more on classes
 in Guile.

module/system/foreign-object.scm

@@ -1,6 +1,6 @@
 ;;; Wrapping foreign objects in Scheme
 
-;;; Copyright (C) 2014, 2015 Free Software Foundation, Inc.
+;;; Copyright (C) 2014, 2015, 2024 Free Software Foundation, Inc.
 ;;; 
 ;;; This library is free software; you can redistribute it and/or
 ;;; modify it under the terms of the GNU Lesser General Public
@@ -46,7 +46,8 @@
     instance))
 
 (define* (make-foreign-object-type name slots #:key finalizer
-                                   (getters (map (const #f) slots)))
+                                   (getters (map (const #f) slots))
+                                   (supers '()))
   (unless (symbol? name)
     (error "type name should be a symbol" name))
   (unless (or (not finalizer) (procedure? finalizer))
@@ -61,11 +62,11 @@
                      slots
                      getters)))
     (if finalizer
-        (make-class '() dslots #:name name
+        (make-class supers dslots #:name name
                     #:finalizer finalizer
                     #:static-slot-allocation? #t
                     #:metaclass <foreign-class-with-finalizer>)
-        (make-class '() dslots #:name name
+        (make-class supers dslots #:name name
                     #:static-slot-allocation? #t
                     #:metaclass <foreign-class>))))