diff --git a/oop/Makefile.am b/oop/Makefile.am index dcc20985c..2f3965c09 100644 --- 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 406210891..2b450dd35 100644 --- 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 ) (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-generic add-method!) -(internal-add-method! add-method! - (make - #:specializers (list ) - #:procedure internal-add-method!)) +((method-procedure internal-add-method!) add-method! internal-add-method!) (define-method (add-method! (proc ) (m )) (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 ) - (list (make - #:specializers - #: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 2e7a16f77..2e5836503 100644 --- 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 62daec55e..bc2ceb1b7 100644 --- 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)))