compile goops

The pending task is to make the accessors compiled too, and also to
compile compile.scm and dispatch.scm, and to integrate dispatch into the
VM.

* oop/Makefile.am (SOURCES): VM-ify the makefile, so we compile goops.scm
  by default.

* oop/goops.scm (load-toplevel): Load goops builtins when compiling too.
  (method): Fix a literal #<unspecified> in the generated procedure (for
  an empty body).
  (internal-add-method!): Cleverness when bootstrapping add-method!.
  Neat!
  (initialize for <generic>): Use the `method' macro so we get
  compilation support.

* oop/goops/dispatch.scm (cache-methods): Don't assume entries are pairs.

diff --git a/oop/Makefile.am b/oop/Makefile.am
index dcc2098..2f3965c 100644 (file)
--- a/oop/Makefile.am
+++ b/oop/Makefile.am
@@ -23,11 +23,8 @@ AUTOMAKE_OPTIONS = gnu
 
 SUBDIRS = goops
 
-# These should be installed and distributed.
-oop_sources = goops.scm
+modpath = oop
+SOURCES = goops.scm
+include $(top_srcdir)/guilec.mk
 
-subpkgdatadir = $(pkgdatadir)/$(GUILE_EFFECTIVE_VERSION)/oop
-subpkgdata_DATA = $(oop_sources)
-TAGS_FILES = $(subpkgdata_DATA)
-
-EXTRA_DIST = $(oop_sources) ChangeLog-2008
+EXTRA_DIST += ChangeLog-2008

diff --git a/oop/goops.scm b/oop/goops.scm
index 4062108..2b450dd 100644 (file)
--- a/oop/goops.scm
+++ b/oop/goops.scm
@@ -79,7 +79,9 @@
 (define *goops-module* (current-module))
 
 ;; First initialize the builtin part of GOOPS
-(%init-goops-builtins)
+(eval-case
+ ((load-toplevel compile-toplevel)
+  (%init-goops-builtins)))
 
 ;; Then load the rest of GOOPS
 (use-modules (oop goops util)
@@ -489,7 +491,7 @@
        #:compile-env (compile-time-environment)
        #:procedure (lambda ,(formals args)
                      ,@(if (null? body)
-                           (list *unspecified*)
+                           '(begin)
                            body)))))
 
 ;;;
@@ -526,23 +528,21 @@
                methods)
              (loop (cdr l)))))))
 
-(define (internal-add-method! gf m)
-  (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)
-  (add-method-in-classes! m)
-  *unspecified*)
+(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)
+    (add-method-in-classes! m)
+    *unspecified*))
 
 (define-generic add-method!)
 
-(internal-add-method! add-method!
-                     (make <method>
-                       #:specializers (list <generic> <method>)
-                       #:procedure internal-add-method!))
+((method-procedure internal-add-method!) add-method! internal-add-method!)
 
 (define-method (add-method! (proc <procedure>) (m <method>))
   (if (generic-capability? proc)
@@ -1407,12 +1407,8 @@
        (name (get-keyword #:name initargs #f)))
     (next-method)
     (slot-set! generic 'methods (if (is-a? previous-definition <procedure>)
-                                   (list (make <method>
-                                               #:specializers <top>
-                                               #:procedure
-                                               (lambda l
-                                                 (apply previous-definition 
-                                                        l))))
+                                   (list (method args
+                                            (apply previous-definition args)))
                                    '()))
     (if name
        (set-procedure-property! generic 'name name))

diff --git a/oop/goops/compile.scm b/oop/goops/compile.scm
index 2e7a16f..2e58365 100644 (file)
--- a/oop/goops/compile.scm
+++ b/oop/goops/compile.scm
@@ -184,7 +184,7 @@
   (let* ((proc (method-procedure (car methods)))
         ;; XXX - procedure-source can not be guaranteed to be
         ;;       reliable or efficient
-        (src (procedure-source proc)) 
+        (src (procedure-source proc))
         (formals (source-formals src))
         (body (source-body src)))
     (if (next-method? body)

diff --git a/oop/goops/dispatch.scm b/oop/goops/dispatch.scm
index 62daec5..bc2ceb1 100644 (file)
--- a/oop/goops/dispatch.scm
+++ b/oop/goops/dispatch.scm
@@ -117,7 +117,7 @@
 (define (cache-methods entries)
   (do ((i (- (vector-length entries) 1) (- i 1))
        (methods '() (let ((entry (vector-ref entries i)))
-                     (if (struct? (car entry))
+                     (if (or (not (pair? entry)) (struct? (car entry)))
                          (cons entry methods)
                          methods))))
       ((< i 0) methods)))