diff options
author | Andy Wingo <wingo@pobox.com> | 2011-07-01 11:46:32 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2011-07-01 11:46:32 +0200 |
commit | 28d0871b553a3959a6c59e2e4caec1c1509f8595 (patch) | |
tree | dd505994bba4a0cd04d183e74be485263c727d1d | |
parent | 26c81c7f405c545ffe9d2dab59349d9aba146348 (diff) | |
download | guile-28d0871b553a3959a6c59e2e4caec1c1509f8595.tar.gz |
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.
-rw-r--r-- | libguile/goops.c | 42 | ||||
-rw-r--r-- | module/oop/goops.scm | 198 |
2 files changed, 162 insertions, 78 deletions
diff --git a/libguile/goops.c b/libguile/goops.c index 8ed37fac5..9f6149171 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -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; diff --git a/module/oop/goops.scm b/module/oop/goops.scm index 88dc9c613..39b7f3d97 100644 --- a/module/oop/goops.scm +++ b/module/oop/goops.scm @@ -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>)) |