mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-10 14:00:21 +02:00
defining a smob or port type no longer mucks exports of (oop goops)
* libguile/goops.c (DEFVAR): Remove this helper macro, replacing its uses with scm_module_define, but without scm_module_export. (create_basic_classes, scm_init_goops_builtins): Update callers. (make_class_from_template, make_class_from_symbol): Change to not define variables for classes. This affects ports, struct classes, and smob classes. * module/oop/goops.scm: Explicitly list our exports, so there is no more trickery happening in C. (find-subclass): Private helper to grub the class hierarchy, so we can define bindings for smobs, ports, etc. Use to define the classes that goops.c used to define -- probably a subset, but it's better to have them listed.
This commit is contained in:
Andy Wingo
parent
26c81c7f40
commit
28d0871b55
2 changed files with 162 additions and 78 deletions
|
|
@ -85,13 +85,6 @@ SCM_SYMBOL (sym_change_class, "change-class");
|
|||
SCM_VARIABLE (scm_var_make_extended_generic, "make-extended-generic");
|
||||
|
||||
|
||||
/* FIXME, exports should come from the scm file only */
|
||||
#define DEFVAR(v, val) \
|
||||
{ scm_module_define (scm_module_goops, (v), (val)); \
|
||||
scm_module_export (scm_module_goops, scm_list_1 ((v))); \
|
||||
}
|
||||
|
||||
|
||||
/* Class redefinition protocol:
|
||||
|
||||
A class is represented by a heap header h1 which points to a
|
||||
|
|
@ -943,21 +936,21 @@ create_basic_classes (void)
|
|||
|
||||
prep_hashsets (scm_class_class);
|
||||
|
||||
DEFVAR(name, scm_class_class);
|
||||
scm_module_define (scm_module_goops, name, scm_class_class);
|
||||
|
||||
/**** <top> ****/
|
||||
name = scm_from_latin1_symbol ("<top>");
|
||||
scm_class_top = scm_basic_make_class (scm_class_class, name,
|
||||
SCM_EOL, SCM_EOL);
|
||||
|
||||
DEFVAR(name, scm_class_top);
|
||||
scm_module_define (scm_module_goops, name, scm_class_top);
|
||||
|
||||
/**** <object> ****/
|
||||
name = scm_from_latin1_symbol ("<object>");
|
||||
scm_class_object = scm_basic_make_class (scm_class_class, name,
|
||||
scm_list_1 (scm_class_top), SCM_EOL);
|
||||
|
||||
DEFVAR (name, scm_class_object);
|
||||
scm_module_define (scm_module_goops, name, scm_class_object);
|
||||
|
||||
/* <top> <object> and <class> were partially initialized. Correct them here */
|
||||
SCM_SET_SLOT (scm_class_object, scm_si_direct_subclasses, scm_list_1 (scm_class_class));
|
||||
|
|
@ -2320,7 +2313,7 @@ make_stdcls (SCM *var, char *name, SCM meta, SCM super, SCM slots)
|
|||
*var = scm_basic_make_class (meta, tmp,
|
||||
scm_is_pair (super) ? super : scm_list_1 (super),
|
||||
slots);
|
||||
DEFVAR(tmp, *var);
|
||||
scm_module_define (scm_module_goops, tmp, *var);
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -2515,7 +2508,7 @@ create_standard_classes (void)
|
|||
static SCM
|
||||
make_class_from_template (char const *template, char const *type_name, SCM supers, int applicablep)
|
||||
{
|
||||
SCM class, name;
|
||||
SCM name;
|
||||
if (type_name)
|
||||
{
|
||||
char buffer[100];
|
||||
|
|
@ -2525,20 +2518,15 @@ make_class_from_template (char const *template, char const *type_name, SCM super
|
|||
else
|
||||
name = SCM_GOOPS_UNBOUND;
|
||||
|
||||
class = scm_basic_make_class (applicablep ? scm_class_procedure_class : scm_class_class,
|
||||
name, supers, SCM_EOL);
|
||||
|
||||
/* Only define name if doesn't already exist. */
|
||||
if (!SCM_GOOPS_UNBOUNDP (name)
|
||||
&& scm_is_false (scm_module_variable (scm_module_goops, name)))
|
||||
DEFVAR (name, class);
|
||||
return class;
|
||||
return scm_basic_make_class (applicablep ? scm_class_procedure_class : scm_class_class,
|
||||
name, supers, SCM_EOL);
|
||||
}
|
||||
|
||||
static SCM
|
||||
make_class_from_symbol (SCM type_name_sym, SCM supers, int applicablep)
|
||||
{
|
||||
SCM class, name;
|
||||
SCM name;
|
||||
|
||||
if (scm_is_true (type_name_sym))
|
||||
{
|
||||
name = scm_string_append (scm_list_3 (scm_from_locale_string ("<"),
|
||||
|
|
@ -2549,14 +2537,8 @@ make_class_from_symbol (SCM type_name_sym, SCM supers, int applicablep)
|
|||
else
|
||||
name = SCM_GOOPS_UNBOUND;
|
||||
|
||||
class = scm_basic_make_class (applicablep ? scm_class_procedure_class : scm_class_class,
|
||||
name, supers, SCM_EOL);
|
||||
|
||||
/* Only define name if doesn't already exist. */
|
||||
if (!SCM_GOOPS_UNBOUNDP (name)
|
||||
&& scm_is_false (scm_module_variable (scm_module_goops, name)))
|
||||
DEFVAR (name, class);
|
||||
return class;
|
||||
return scm_basic_make_class (applicablep ? scm_class_procedure_class : scm_class_class,
|
||||
name, supers, SCM_EOL);
|
||||
}
|
||||
|
||||
SCM
|
||||
|
|
@ -2786,7 +2768,7 @@ scm_init_goops_builtins (void)
|
|||
SCM name = scm_from_latin1_symbol ("no-applicable-method");
|
||||
scm_no_applicable_method =
|
||||
scm_make (scm_list_3 (scm_class_generic, k_name, name));
|
||||
DEFVAR (name, scm_no_applicable_method);
|
||||
scm_module_define (scm_module_goops, name, scm_no_applicable_method);
|
||||
}
|
||||
|
||||
return SCM_UNSPECIFIED;
|
||||
|
|
|
|||
|
|
@ -26,54 +26,112 @@
|
|||
;;;;
|
||||
|
||||
(define-module (oop goops)
|
||||
:use-module (srfi srfi-1)
|
||||
:export-syntax (define-class class standard-define-class
|
||||
define-generic define-accessor define-method
|
||||
define-extended-generic define-extended-generics
|
||||
method)
|
||||
:export (is-a? class-of
|
||||
ensure-metaclass ensure-metaclass-with-supers
|
||||
make-class
|
||||
make-generic ensure-generic
|
||||
make-extended-generic
|
||||
make-accessor ensure-accessor
|
||||
add-method!
|
||||
class-slot-ref class-slot-set! slot-unbound slot-missing
|
||||
slot-definition-name slot-definition-options
|
||||
slot-definition-allocation
|
||||
slot-definition-getter slot-definition-setter
|
||||
slot-definition-accessor
|
||||
slot-definition-init-value slot-definition-init-form
|
||||
slot-definition-init-thunk slot-definition-init-keyword
|
||||
slot-init-function class-slot-definition
|
||||
method-source
|
||||
compute-cpl compute-std-cpl compute-get-n-set compute-slots
|
||||
compute-getter-method compute-setter-method
|
||||
allocate-instance initialize make-instance make
|
||||
no-next-method no-applicable-method no-method
|
||||
change-class update-instance-for-different-class
|
||||
shallow-clone deep-clone
|
||||
class-redefinition
|
||||
apply-generic apply-method apply-methods
|
||||
compute-applicable-methods %compute-applicable-methods
|
||||
method-more-specific? sort-applicable-methods
|
||||
class-subclasses class-methods
|
||||
goops-error
|
||||
min-fixnum max-fixnum
|
||||
;;; *fixme* Should go into goops.c
|
||||
instance? slot-ref-using-class
|
||||
slot-set-using-class! slot-bound-using-class?
|
||||
slot-exists-using-class? slot-ref slot-set! slot-bound?
|
||||
class-name class-direct-supers class-direct-subclasses
|
||||
class-direct-methods class-direct-slots class-precedence-list
|
||||
class-slots
|
||||
generic-function-name
|
||||
generic-function-methods method-generic-function
|
||||
method-specializers method-formals
|
||||
primitive-generic-generic enable-primitive-generic!
|
||||
method-procedure accessor-method-slot-definition
|
||||
slot-exists? make find-method get-keyword)
|
||||
:no-backtrace)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:export-syntax (define-class class standard-define-class
|
||||
define-generic define-accessor define-method
|
||||
define-extended-generic define-extended-generics
|
||||
method)
|
||||
#:export ( ;; The root of everything.
|
||||
<top>
|
||||
<class> <object>
|
||||
|
||||
;; Slot types.
|
||||
<foreign-slot> <protected-slot> <hidden-slot> <opaque-slot>
|
||||
<read-only-slot> <self-slot> <protected-opaque-slot>
|
||||
<protected-hidden-slot> <protected-read-only-slot>
|
||||
<scm-slot> <int-slot> <float-slot> <double-slot>
|
||||
|
||||
;; Methods are implementations of generic functions.
|
||||
<method> <accessor-method>
|
||||
|
||||
;; Applicable objects, either procedures or applicable structs.
|
||||
<procedure-class> <applicable>
|
||||
<procedure> <primitive-generic>
|
||||
|
||||
;; Applicable structs.
|
||||
<applicable-struct-class>
|
||||
<applicable-struct>
|
||||
<generic> <extended-generic>
|
||||
<generic-with-setter> <extended-generic-with-setter>
|
||||
<accessor> <extended-accessor>
|
||||
|
||||
;; Types with their own allocated typecodes.
|
||||
<boolean> <char> <list> <pair> <null> <string> <symbol>
|
||||
<vector> <bytevector> <uvec> <foreign> <hashtable>
|
||||
<fluid> <dynamic-state> <frame> <objcode> <vm> <vm-continuation>
|
||||
|
||||
;; Numbers.
|
||||
<number> <complex> <real> <integer> <fraction>
|
||||
|
||||
;; Unknown.
|
||||
<unknown>
|
||||
|
||||
;; Particular SMOB data types. All SMOB types have
|
||||
;; corresponding classes, which may be obtained via class-of,
|
||||
;; once you have an instance. Perhaps FIXME to provide a
|
||||
;; smob-type-name->class procedure.
|
||||
<arbiter> <promise> <thread> <mutex> <condition-variable>
|
||||
<regexp> <hook> <bitvector> <random-state> <async>
|
||||
<directory> <keyword> <array> <character-set>
|
||||
<dynamic-object> <guardian>
|
||||
|
||||
;; Modules.
|
||||
<module>
|
||||
|
||||
;; Ports.
|
||||
<port> <input-port> <output-port> <input-output-port>
|
||||
|
||||
;; Like SMOB types, all port types have their own classes,
|
||||
;; which can be accessed via `class-of' once you have an
|
||||
;; instance. Here we export bindings just for file ports.
|
||||
<file-port>
|
||||
<file-input-port> <file-output-port> <file-input-output-port>
|
||||
|
||||
is-a? class-of
|
||||
ensure-metaclass ensure-metaclass-with-supers
|
||||
make-class
|
||||
make-generic ensure-generic
|
||||
make-extended-generic
|
||||
make-accessor ensure-accessor
|
||||
add-method!
|
||||
class-slot-ref class-slot-set! slot-unbound slot-missing
|
||||
slot-definition-name slot-definition-options
|
||||
slot-definition-allocation
|
||||
|
||||
slot-definition-getter slot-definition-setter
|
||||
slot-definition-accessor
|
||||
slot-definition-init-value slot-definition-init-form
|
||||
slot-definition-init-thunk slot-definition-init-keyword
|
||||
slot-init-function class-slot-definition
|
||||
method-source
|
||||
compute-cpl compute-std-cpl compute-get-n-set compute-slots
|
||||
compute-getter-method compute-setter-method
|
||||
allocate-instance initialize make-instance make
|
||||
no-next-method no-applicable-method no-method
|
||||
change-class update-instance-for-different-class
|
||||
shallow-clone deep-clone
|
||||
class-redefinition
|
||||
apply-generic apply-method apply-methods
|
||||
compute-applicable-methods %compute-applicable-methods
|
||||
method-more-specific? sort-applicable-methods
|
||||
class-subclasses class-methods
|
||||
goops-error
|
||||
min-fixnum max-fixnum
|
||||
|
||||
;;; *fixme* Should go into goops.c
|
||||
instance? slot-ref-using-class
|
||||
slot-set-using-class! slot-bound-using-class?
|
||||
slot-exists-using-class? slot-ref slot-set! slot-bound?
|
||||
class-name class-direct-supers class-direct-subclasses
|
||||
class-direct-methods class-direct-slots class-precedence-list
|
||||
class-slots
|
||||
generic-function-name
|
||||
generic-function-methods method-generic-function
|
||||
method-specializers method-formals
|
||||
primitive-generic-generic enable-primitive-generic!
|
||||
method-procedure accessor-method-slot-definition
|
||||
slot-exists? make find-method get-keyword)
|
||||
#:no-backtrace)
|
||||
|
||||
(define *goops-module* (current-module))
|
||||
|
||||
|
|
@ -813,6 +871,20 @@
|
|||
;;; Handling of duplicate bindings in the module system
|
||||
;;;
|
||||
|
||||
(define (find-subclass super name)
|
||||
(let lp ((classes (class-direct-subclasses super)))
|
||||
(cond
|
||||
((null? classes)
|
||||
(error "class not found" name))
|
||||
((and (slot-bound? (car classes) 'name)
|
||||
(eq? (class-name (car classes)) name))
|
||||
(car classes))
|
||||
(else
|
||||
(lp (cdr classes))))))
|
||||
|
||||
;; A record type.
|
||||
(define <module> (find-subclass <top> '<module>))
|
||||
|
||||
(define-method (merge-generics (module <module>)
|
||||
(name <symbol>)
|
||||
(int1 <module>)
|
||||
|
|
@ -1657,3 +1729,33 @@
|
|||
|
||||
;; Tell C code that the main bulk of Goops has been loaded
|
||||
(%goops-loaded)
|
||||
|
||||
|
||||
|
||||
|
||||
;;;
|
||||
;;; {SMOB and port classes}
|
||||
;;;
|
||||
|
||||
(define <arbiter> (find-subclass <top> '<arbiter>))
|
||||
(define <promise> (find-subclass <top> '<promise>))
|
||||
(define <thread> (find-subclass <top> '<thread>))
|
||||
(define <mutex> (find-subclass <top> '<mutex>))
|
||||
(define <condition-variable> (find-subclass <top> '<condition-variable>))
|
||||
(define <regexp> (find-subclass <top> '<regexp>))
|
||||
(define <hook> (find-subclass <top> '<hook>))
|
||||
(define <bitvector> (find-subclass <top> '<bitvector>))
|
||||
(define <random-state> (find-subclass <top> '<random-state>))
|
||||
(define <async> (find-subclass <top> '<async>))
|
||||
(define <directory> (find-subclass <top> '<directory>))
|
||||
(define <keyword> (find-subclass <top> '<keyword>))
|
||||
(define <array> (find-subclass <top> '<array>))
|
||||
(define <character-set> (find-subclass <top> '<character-set>))
|
||||
(define <dynamic-object> (find-subclass <top> '<dynamic-object>))
|
||||
(define <guardian> (find-subclass <applicable> '<guardian>))
|
||||
|
||||
(define (define-class-subtree class)
|
||||
(define! (class-name class) class)
|
||||
(for-each define-class-subtree (class-direct-subclasses class)))
|
||||
|
||||
(define-class-subtree (find-subclass <port> '<file-port>))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue