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.

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

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))

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)

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)))