X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/a8c10aa131eb5dd104f134d2ed66afe225fea8e6..583a23bf104c84d9617222856e188f3f3af4934d:/module/oop/goops.scm

diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index 0845d29e9..486a652c0 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -1,37 +1,38 @@
 ;;; installed-scm-file
 
-;;;; Copyright (C) 1998,1999,2000,2001,2002, 2003, 2006, 2009, 2010, 2011 Free Software Foundation, Inc.
-;;;; 
+;;;; Copyright (C) 1998,1999,2000,2001,2002, 2003, 2006, 2009, 2010, 2011, 2014, 2015 Free Software Foundation, Inc.
+;;;; Copyright (C) 1993-1998 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
+;;;;
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
 ;;;; License as published by the Free Software Foundation; either
 ;;;; version 3 of the License, or (at your option) any later version.
-;;;; 
+;;;;
 ;;;; This library is distributed in the hope that it will be useful,
 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 ;;;; Lesser General Public License for more details.
-;;;; 
+;;;;
 ;;;; You should have received a copy of the GNU Lesser General Public
 ;;;; License along with this library; if not, write to the Free Software
 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
-;;;; 
+;;;;
 
 
-;;;; This software is a derivative work of other copyrighted softwares; the
-;;;; copyright notices of these softwares are placed in the file COPYRIGHTS
 ;;;;
-;;;; This file is based upon stklos.stk from the STk distribution by
-;;;; Erick Gallesio <eg@unice.fr>.
+;;;; This file was based upon stklos.stk from the STk distribution
+;;;; version 4.0.1 by Erick Gallesio <eg@unice.fr>.
 ;;;;
 
 (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
+  #:use-module (srfi srfi-1)
+  #:use-module (ice-9 match)
+  #:use-module (oop goops util)
+  #: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
@@ -72,32 +73,72 @@
 	   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)
+	   slot-exists? make find-method get-keyword))
 
 (define *goops-module* (current-module))
 
 ;; First initialize the builtin part of GOOPS
-(eval-when (eval load compile)
+(eval-when (expand load eval)
   (%init-goops-builtins))
 
-(eval-when (eval load compile)
+(eval-when (expand load eval)
   (use-modules ((language tree-il primitives) :select (add-interesting-primitive!)))
-  (add-interesting-primitive! 'class-of)
-  (define (@slot-ref o n)
-    (struct-ref o n))
-  (define (@slot-set! o n v)
-    (struct-set! o n v))
-  (add-interesting-primitive! '@slot-ref)
-  (add-interesting-primitive! '@slot-set!))
+  (add-interesting-primitive! 'class-of))
 
 ;; Then load the rest of GOOPS
-(use-modules (oop goops util)
-	     (oop goops dispatch)
-	     (oop goops compile))
+(use-modules (oop goops dispatch))
+
+;;;
+;;; Compiling next methods into method bodies
+;;;
+
+;;; So, for the reader: there basic idea is that, given that the
+;;; semantics of `next-method' depend on the concrete types being
+;;; dispatched, why not compile a specific procedure to handle each type
+;;; combination that we see at runtime.
+;;;
+;;; In theory we can do much better than a bytecode compilation, because
+;;; we know the *exact* types of the arguments. It's ideal for native
+;;; compilation. A task for the future.
+;;;
+;;; I think this whole generic application mess would benefit from a
+;;; strict MOP.
+
+(define (compute-cmethod methods types)
+  (match methods
+    ((method . methods)
+     (cond
+      ((is-a? method <accessor-method>)
+       (match types
+         ((class . _)
+          (let* ((name (car (accessor-method-slot-definition method)))
+                 (g-n-s (assq name (slot-ref class 'getters-n-setters)))
+                 (init-thunk (cadr g-n-s))
+                 (g-n-s (cddr g-n-s)))
+            (match types
+              ((class)
+               (cond ((pair? g-n-s)
+                      (make-generic-bound-check-getter (car g-n-s)))
+                     (init-thunk
+                      (standard-get g-n-s))
+                     (else
+                      (bound-check-get g-n-s))))
+              ((class value)
+               (if (pair? g-n-s)
+                   (cadr g-n-s)
+                   (standard-set g-n-s))))))))
+      (else
+       (let ((make-procedure (slot-ref method 'make-procedure)))
+         (if make-procedure
+             (make-procedure
+              (if (null? methods)
+                  (lambda args
+                    (no-next-method (method-generic-function method) args))
+                  (compute-cmethod methods types)))
+             (method-procedure method))))))))
 
 
-(eval-when (eval load compile)
+(eval-when (expand load eval)
   (define min-fixnum (- (expt 2 29)))
   (define max-fixnum (- (expt 2 29) 1)))
 
@@ -288,21 +329,18 @@
        #'(define-class-pre-definitions (rest ...) 
          out ... (define-class-pre-definition (slotopt ...)))))))
 
-(define-syntax define-class
-  (syntax-rules ()
-    ((_ name supers slot ...)
-     (begin
-       (define-class-pre-definitions (slot ...))
-       (if (and (defined? 'name)
-                (is-a? name <class>)
-                (memq <object> (class-precedence-list name)))
-           (class-redefinition name
-                               (class supers slot ... #:name 'name))
-           (toplevel-define! 'name (class supers slot ... #:name 'name)))))))
+(define-syntax-rule (define-class name supers slot ...)
+  (begin
+    (define-class-pre-definitions (slot ...))
+    (if (and (defined? 'name)
+             (is-a? name <class>)
+             (memq <object> (class-precedence-list name)))
+        (class-redefinition name
+                            (class supers slot ... #:name 'name))
+        (toplevel-define! 'name (class supers slot ... #:name 'name)))))
        
-(define-syntax standard-define-class
-  (syntax-rules ()
-    ((_ arg ...) (define-class arg ...))))
+(define-syntax-rule (standard-define-class arg ...)
+  (define-class arg ...))
 
 ;;;
 ;;; {Generic functions and accessors}
@@ -369,13 +407,15 @@
   (for-each (lambda (gf)
 	      (slot-set! gf 'extended-by
 			 (cons eg (slot-ref gf 'extended-by))))
-	    gfs))
+	    gfs)
+  (invalidate-method-cache! eg))
 
 (define (not-extended-by! gfs eg)
   (for-each (lambda (gf)
 	      (slot-set! gf 'extended-by
 			 (delq! eg (slot-ref gf 'extended-by))))
-	    gfs))
+	    gfs)
+  (invalidate-method-cache! eg))
 
 (define* (ensure-generic old-definition #:optional name)
   (cond ((is-a? old-definition <generic>) old-definition)
@@ -390,13 +430,11 @@
         (else (make <generic> #:name name))))
 
 ;; same semantics as <generic>
-(define-syntax define-accessor
-  (syntax-rules ()
-    ((_ name)
-     (define name
-       (cond ((not (defined? 'name))  (ensure-accessor #f 'name))
-             ((is-a? name <accessor>) (make <accessor> #:name 'name))
-             (else                    (ensure-accessor name 'name)))))))
+(define-syntax-rule (define-accessor name)
+  (define name
+    (cond ((not (defined? 'name))  (ensure-accessor #f 'name))
+          ((is-a? name <accessor>) (make <accessor> #:name 'name))
+          (else                    (ensure-accessor name 'name)))))
 
 (define (make-setter-name name)
   (string->symbol (string-append "setter:" (symbol->string name))))
@@ -446,6 +484,7 @@
 		(slot-set! method 'generic-function gws))
 	      methods)
     (slot-set! gws 'methods methods)
+    (invalidate-method-cache! gws)
     gws))
 
 ;;;
@@ -610,15 +649,25 @@
 		methods)
 	      (loop (cdr l)))))))
 
+(define (method-n-specializers m)
+  (length* (slot-ref m 'specializers)))
+
+(define (calculate-n-specialized gf)
+  (fold (lambda (m n) (max n (method-n-specializers m)))
+        0
+        (generic-function-methods gf)))
+
+(define (invalidate-method-cache! gf)
+  (%invalidate-method-cache! gf)
+  (slot-set! gf 'n-specialized (calculate-n-specialized gf))
+  (for-each (lambda (gf) (invalidate-method-cache! gf))
+            (slot-ref gf 'extended-by)))
+
 (define internal-add-method!
   (method ((gf <generic>) (m <method>))
     (slot-set! m  'generic-function gf)
     (slot-set! gf 'methods (compute-new-list-of-methods gf m))
-    (let ((specializers (slot-ref m 'specializers)))
-      (slot-set! gf 'n-specialized
-                 (max (length* specializers)
-                      (slot-ref gf 'n-specialized))))
-    (%invalidate-method-cache! gf)
+    (invalidate-method-cache! gf)
     (add-method-in-classes! m)
     *unspecified*))
 
@@ -844,6 +893,7 @@
 	 (slot-set! val2
 		    'extended-by
 		    (cons gf (delq! gf (slot-ref val2 'extended-by))))
+         (invalidate-method-cache! gf)
 	 var)))
 
 (module-define! duplicate-handlers 'merge-generics merge-generics)
@@ -1027,7 +1077,7 @@
 		    ;; remove the method from its GF
 		    (slot-set! gf 'methods
 			       (delq1! m (slot-ref gf 'methods)))
-		    (%invalidate-method-cache! gf)
+		    (invalidate-method-cache! gf)
 		    ;; remove the method from its specializers
 		    (remove-method-in-classes! m))))
 	    (class-direct-methods c)))
@@ -1087,35 +1137,27 @@
 			     (compute-setter-method class g-n-s))))))
       slots (slot-ref class 'getters-n-setters)))
 
-(define-method (compute-getter-method (class <class>) slotdef)
-  (let ((init-thunk (cadr slotdef))
-	(g-n-s (cddr slotdef)))
+(define-method (compute-getter-method (class <class>) g-n-s)
+  (let ((name (car g-n-s)))
     (make <accessor-method>
           #:specializers (list class)
-	  #:procedure (cond ((pair? g-n-s)
-			     (make-generic-bound-check-getter (car g-n-s)))
-			    (init-thunk
-			     (standard-get g-n-s))
-			    (else
-			     (bound-check-get g-n-s)))
-	  #:slot-definition slotdef)))
-
-(define-method (compute-setter-method (class <class>) slotdef)
-  (let ((g-n-s (cddr slotdef)))
+          #:procedure (lambda (o) (slot-ref o name))
+          #:slot-definition g-n-s)))
+
+(define-method (compute-setter-method (class <class>) g-n-s)
+  (let ((name (car g-n-s)))
     (make <accessor-method>
-          #:specializers (list class <top>)
-	  #:procedure (if (pair? g-n-s)
-			  (cadr g-n-s)
-			  (standard-set g-n-s))
-	  #:slot-definition slotdef)))
+      #:specializers (list class <top>)
+      #:procedure (lambda (o v) (slot-set! o name v))
+      #:slot-definition g-n-s)))
 
 (define (make-generic-bound-check-getter proc)
   (lambda (o) (assert-bound (proc o) o)))
 
 ;; the idea is to compile the index into the procedure, for fastest
-;; lookup. Also, @slot-ref and @slot-set! have their own bytecodes.
+;; lookup.
 
-(eval-when (eval load compile)
+(eval-when (expand load eval)
   (define num-standard-pre-cache 20))
 
 (define-macro (define-standard-accessor-method form . body)
@@ -1125,9 +1167,9 @@
     (define (make-one x)
       (define (body-trans form)
         (cond ((not (pair? form)) form)
-              ((eq? (car form) '@slot-ref)
+              ((eq? (car form) 'struct-ref)
                `(,(car form) ,(cadr form) ,x))
-              ((eq? (car form) '@slot-set!)
+              ((eq? (car form) 'struct-set!)
                `(,(car form) ,(cadr form) ,x ,(cadddr form)))
               (else
                (map body-trans form))))
@@ -1140,16 +1182,16 @@
                ((lambda (,n-var) (lambda ,args ,@body)) n)))))))
 
 (define-standard-accessor-method ((bound-check-get n) o)
-  (let ((x (@slot-ref o n)))
+  (let ((x (struct-ref o n)))
     (if (unbound? x)
         (slot-unbound o)
         x)))
 
 (define-standard-accessor-method ((standard-get n) o)
-  (@slot-ref o n))
+  (struct-ref o n))
 
 (define-standard-accessor-method ((standard-set n) o v)
-  (@slot-set! o n v))
+  (struct-set! o n v))
 
 ;;; compute-getters-n-setters
 ;;;
@@ -1198,12 +1240,20 @@
 	   ;;   '(index size) for instance allocated slots
 	   ;;   '() for other slots
 	   (verify-accessors name g-n-s)
-	   (cons name
-		 (cons (compute-slot-init-function name s)
-		       (if (or (integer? g-n-s)
-			       (zero? size))
-			   g-n-s
-			   (append g-n-s (list index size)))))))
+           (case (slot-definition-allocation s)
+             ((#:each-subclass #:class)
+              (unless (and (zero? size) (pair? g-n-s))
+                (error "Class-allocated slots should not reserve fields"))
+              ;; Don't initialize the slot; that's handled when the slot
+              ;; is allocated, in compute-get-n-set.
+              (cons name (cons #f g-n-s)))
+             (else
+              (cons name
+                    (cons (compute-slot-init-function name s)
+                          (if (or (integer? g-n-s)
+                                  (zero? size))
+                              g-n-s
+                              (append g-n-s (list index size)))))))))
        slots))
 
 ;;; compute-cpl
@@ -1355,6 +1405,12 @@
 ;;; compute-get-n-set
 ;;;
 (define-method (compute-get-n-set (class <class>) s)
+  (define (class-slot-init-value)
+    (let ((thunk (slot-definition-init-thunk s)))
+      (if thunk
+          (thunk)
+          (slot-definition-init-value s))))
+
   (case (slot-definition-allocation s)
     ((#:instance) ;; Instance slot
      ;; get-n-set is just its offset
@@ -1369,7 +1425,7 @@
      (let ((name (slot-definition-name s)))
        (if (memq name (map slot-definition-name (class-direct-slots class)))
 	   ;; This slot is direct; create a new shared variable
-	   (make-closure-variable class)
+	   (make-closure-variable class (class-slot-init-value))
 	   ;; Slot is inherited. Find its definition in superclass
 	   (let loop ((l (cdr (class-precedence-list class))))
 	     (let ((r (assoc name (slot-ref (car l) 'getters-n-setters))))
@@ -1379,7 +1435,7 @@
 
     ((#:each-subclass) ;; slot shared by instances of direct subclass.
      ;; (Thomas Buerger, April 1998)
-     (make-closure-variable class))
+     (make-closure-variable class (class-slot-init-value)))
 
     ((#:virtual) ;; No allocation
      ;; slot-ref and slot-set! function must be given by the user
@@ -1391,10 +1447,9 @@
        (list get set)))
     (else    (next-method))))
 
-(define (make-closure-variable class)
-  (let ((shared-variable (make-unbound)))
-    (list (lambda (o) shared-variable)
-	  (lambda (o v) (set! shared-variable v)))))
+(define (make-closure-variable class value)
+  (list (lambda (o) value)
+        (lambda (o v) (set! value v))))
 
 (define-method (compute-get-n-set (o <object>) s)
   (goops-error "Allocation \"~S\" is unknown" (slot-definition-allocation s)))