guile-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Guile-commits] GNU Guile branch, master, updated. v2.1.0-140-gd682f70


From: Andy Wingo
Subject: [Guile-commits] GNU Guile branch, master, updated. v2.1.0-140-gd682f70
Date: Fri, 01 Jul 2011 11:17:26 +0000

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=d682f703c70239403a230bf89b13b87c211d4a0f

The branch, master has been updated
       via  d682f703c70239403a230bf89b13b87c211d4a0f (commit)
       via  28d0871b553a3959a6c59e2e4caec1c1509f8595 (commit)
      from  26c81c7f405c545ffe9d2dab59349d9aba146348 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit d682f703c70239403a230bf89b13b87c211d4a0f
Author: Andy Wingo <address@hidden>
Date:   Fri Jul 1 12:01:58 2011 +0200

    fix r6rs-records-syntactic.test to not shadow a literal
    
    * test-suite/tests/r6rs-records-syntactic.test (*parent-rtd): Fix test
      to not shadow a literal.

commit 28d0871b553a3959a6c59e2e4caec1c1509f8595
Author: Andy Wingo <address@hidden>
Date:   Fri Jul 1 11:46:32 2011 +0200

    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.

-----------------------------------------------------------------------

Summary of changes:
 libguile/goops.c                             |   42 ++----
 module/oop/goops.scm                         |  198 +++++++++++++++++++------
 test-suite/tests/r6rs-records-syntactic.test |   14 +-
 3 files changed, 170 insertions(+), 84 deletions(-)

diff --git a/libguile/goops.c b/libguile/goops.c
index 8ed37fa..9f61491 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 88dc9c6..39b7f3d 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>))
diff --git a/test-suite/tests/r6rs-records-syntactic.test 
b/test-suite/tests/r6rs-records-syntactic.test
index 9f9d373..edc88aa 100644
--- a/test-suite/tests/r6rs-records-syntactic.test
+++ b/test-suite/tests/r6rs-records-syntactic.test
@@ -30,12 +30,14 @@
 (define-record-type simple-rtd)
 (define-record-type 
   (specified-rtd specified-rtd-constructor specified-rtd-predicate))
-(define-record-type parent-rtd (fields x y))
+;; Can't be named as `parent-rtd', as that shadows the `parent-rtd'
+;; literal.
+(define-record-type *parent-rtd (fields x y))
 (define-record-type child-parent-rtd-rtd 
-  (parent-rtd (record-type-descriptor parent-rtd) 
-             (record-constructor-descriptor parent-rtd))
+  (parent-rtd (record-type-descriptor *parent-rtd) 
+             (record-constructor-descriptor *parent-rtd))
   (fields z))
-(define-record-type child-parent-rtd (parent parent-rtd) (fields z))
+(define-record-type child-parent-rtd (parent *parent-rtd) (fields z))
 (define-record-type mutable-fields-rtd 
   (fields (mutable mutable-bar) 
          (mutable mutable-baz mutable-baz-accessor mutable-baz-mutator)))
@@ -69,10 +71,10 @@
     (defined? 'specified-rtd-constructor)))
 
 (pass-if "parent-rtd clause includes specified parent"
-  (eq? (record-type-parent child-parent-rtd-rtd) parent-rtd))
+  (eq? (record-type-parent child-parent-rtd-rtd) *parent-rtd))
 
 (pass-if "parent clause includes specified parent"
-  (eq? (record-type-parent child-parent-rtd) parent-rtd))
+  (eq? (record-type-parent child-parent-rtd) *parent-rtd))
 
 (pass-if "protocol clause includes specified protocol"
   (let ((protocol-record (make-protocol-rtd 1 2)))


hooks/post-receive
-- 
GNU Guile



reply via email to

[Prev in Thread] Current Thread [Next in Thread]