code = SCM_CAR (access);
if (!SCM_CLOSUREP (code))
- return SCM_SUBRF (code) (obj);
+ return scm_call_1 (code, obj);
env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code),
scm_list_1 (obj),
SCM_ENV (code));
code = SCM_CADR (access);
if (!SCM_CLOSUREP (code))
- SCM_SUBRF (code) (obj, value);
+ scm_call_2 (code, obj, value);
else
{
env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code),
(else
(let ((get (car l))
(set (cadr l)))
- (if (not (and (closure? get)
- (= (car (procedure-property get 'arity)) 1)))
+ ;; note that we allow non-closures; we only check arity on
+ ;; the closures, though, because we inline their dispatch
+ ;; in %get-slot-value / %set-slot-value.
+ (if (or (not (procedure? get))
+ (and (closure? get)
+ (not (= (car (procedure-property get 'arity)) 1))))
(goops-error "Bad getter closure for slot `~S' in ~S: ~S"
slot class get))
- (if (not (and (closure? set)
- (= (car (procedure-property set 'arity)) 2)))
+ (if (or (not (procedure? set))
+ (and (closure? set)
+ (not (= (car (procedure-property set 'arity)) 2))))
(goops-error "Bad setter closure for slot `~S' in ~S: ~S"
slot class set))))))
AUTOMAKE_OPTIONS = gnu
-# These should be installed and distributed.
-goops_sources = \
+modpath = oop/goops
+SOURCES = \
active-slot.scm compile.scm composite-slot.scm describe.scm \
dispatch.scm internal.scm save.scm stklos.scm util.scm \
- old-define-method.scm accessors.scm simple.scm
+ accessors.scm simple.scm
-subpkgdatadir = $(pkgdatadir)/$(GUILE_EFFECTIVE_VERSION)/oop/goops
-subpkgdata_DATA = $(goops_sources)
-TAGS_FILES = $(subpkgdata_DATA)
-
-EXTRA_DIST = $(goops_sources)
+include $(top_srcdir)/guilec.mk
;;;;
\f
+;; There are circularities here; you can't import (oop goops compile)
+;; before (oop goops). So when compiling, make sure that things are
+;; kosher.
+(eval-case ((compile-toplevel) (resolve-module '(oop goops))))
+
(define-module (oop goops compile)
:use-module (oop goops)
:use-module (oop goops util)
(set-cdr! vcell (make-final-make-next-method method))
(@apply method (if (null? args) default-args args)))))))
+(define (compile-method/memoizer+next methods types proc formals body)
+ (let ((vcell (cons 'goops:make-next-method #f)))
+ (set-cdr! vcell
+ (make-make-next-method/memoizer
+ vcell
+ (method-generic-function (car methods))
+ (cdr methods) types))
+ ;;*fixme*
+ `(,(cons vcell (procedure-environment proc))
+ ,formals
+ ;;*fixme* Only do this on source where next-method can't be inlined
+ (let ((next-method ,(if (list? formals)
+ `(goops:make-next-method ,@formals)
+ `(apply goops:make-next-method
+ ,@(improper->proper formals)))))
+ ,@body))))
+
(define (compile-method/memoizer methods types)
(let* ((proc (method-procedure (car methods)))
;; XXX - procedure-source can not be guaranteed to be
;; reliable or efficient
- (src (procedure-source proc))
- (formals (source-formals src))
- (body (source-body src)))
- (if (next-method? body)
- (let ((vcell (cons 'goops:make-next-method #f)))
- (set-cdr! vcell
- (make-make-next-method/memoizer
- vcell
- (method-generic-function (car methods))
- (cdr methods) types))
- ;;*fixme*
- `(,(cons vcell (procedure-environment proc))
- ,formals
- ;;*fixme* Only do this on source where next-method can't be inlined
- (let ((next-method ,(if (list? formals)
- `(goops:make-next-method ,@formals)
- `(apply goops:make-next-method
- ,@(improper->proper formals)))))
- ,@body)))
- (cons (procedure-environment proc)
- (cons formals
- (%tag-body body)))
- )))
+ (src (procedure-source proc)))
+ (if src
+ (let ((formals (source-formals src))
+ (body (source-body src)))
+ (if (next-method? body)
+ (compile-method/memoizer+next methods types proc formals body)
+ (cons (procedure-environment proc)
+ (cons formals
+ (%tag-body body)))
+ ))
+ proc)))
;;;;
\f
+;; There are circularities here; you can't import (oop goops compile)
+;; before (oop goops). So when compiling, make sure that things are
+;; kosher.
+(eval-case ((compile-toplevel) (resolve-module '(oop goops))))
+
(define-module (oop goops dispatch)
:use-module (oop goops)
:use-module (oop goops util)
+++ /dev/null
-;;; installed-scm-file
-
-;;;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.
-;;;;
-;;;; 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 2.1 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
-;;;;
-\f
-
-(define-module (oop goops old-define-method)
- :use-module (oop goops)
- :export (define-method)
- :no-backtrace
- )
-
-(define define-method
- (procedure->memoizing-macro
- (lambda (exp env)
- (let ((name (cadr exp)))
- (if (and (pair? name)
- (eq? (car name) 'setter)
- (pair? (cdr name))
- (symbol? (cadr name))
- (null? (cddr name)))
- (let ((name (cadr name)))
- (cond ((not (symbol? name))
- (goops-error "bad method name: ~S" name))
- ((defined? name env)
- `(begin
- ;; *fixme* Temporary hack for the current module system
- (if (not ,name)
- (define-accessor ,name))
- (add-method! (setter ,name) (method ,@(cddr exp)))))
- (else
- `(begin
- (define-accessor ,name)
- (add-method! (setter ,name) (method ,@(cddr exp)))))))
- (cond ((not (symbol? name))
- (goops-error "bad method name: ~S" name))
- ((defined? name env)
- `(begin
- ;; *fixme* Temporary hack for the current module system
- (if (not ,name)
- (define-generic ,name))
- (add-method! ,name (method ,@(cddr exp)))))
- (else
- `(begin
- (define-generic ,name)
- (add-method! ,name (method ,@(cddr exp)))))))))))
HCoop / bpt / guile.git / commitdiff