;;; installed-scm-file
-;;;; Copyright (C) 1998,1999,2000,2001,2002, 2003, 2006, 2009 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
-;;;;
+;;;;
\f
-;;;; 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 (goops-version 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
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))))))))
\f
-(eval-when (eval load compile)
+(eval-when (expand load eval)
(define min-fixnum (- (expt 2 29)))
(define max-fixnum (- (expt 2 29) 1)))
;; goops-error
;;
(define (goops-error format-string . args)
- (save-stack)
(scm-error 'goops-error #f format-string args '()))
;;
(lambda (x)
(syntax-case x ()
((_ (k arg rest ...) out ...)
- (keyword? (syntax->datum (syntax k)))
- (case (syntax->datum (syntax k))
+ (keyword? (syntax->datum #'k))
+ (case (syntax->datum #'k)
((#:getter #:setter)
- (syntax
- (define-class-pre-definition (rest ...)
- out ...
- (if (or (not (defined? 'arg))
- (not (is-a? arg <generic>)))
- (toplevel-define!
- 'arg
- (ensure-generic (if (defined? 'arg) arg #f) 'arg))))))
+ #'(define-class-pre-definition (rest ...)
+ out ...
+ (if (or (not (defined? 'arg))
+ (not (is-a? arg <generic>)))
+ (toplevel-define!
+ 'arg
+ (ensure-generic (if (defined? 'arg) arg #f) 'arg)))))
((#:accessor)
- (syntax
- (define-class-pre-definition (rest ...)
- out ...
- (if (or (not (defined? 'arg))
- (not (is-a? arg <accessor>)))
- (toplevel-define!
- 'arg
- (ensure-accessor (if (defined? 'arg) arg #f) 'arg))))))
+ #'(define-class-pre-definition (rest ...)
+ out ...
+ (if (or (not (defined? 'arg))
+ (not (is-a? arg <accessor>)))
+ (toplevel-define!
+ 'arg
+ (ensure-accessor (if (defined? 'arg) arg #f) 'arg)))))
(else
- (syntax
- (define-class-pre-definition (rest ...) out ...)))))
+ #'(define-class-pre-definition (rest ...) out ...))))
((_ () out ...)
- (syntax (begin out ...))))))
+ #'(begin out ...)))))
;; Some slot options require extra definitions to be made. In
;; particular, we want to make sure that the generic function objects
(lambda (x)
(syntax-case x ()
((_ () out ...)
- (syntax (begin out ...)))
+ #'(begin out ...))
((_ (slot rest ...) out ...)
- (keyword? (syntax->datum (syntax slot)))
- (syntax (begin out ...)))
+ (keyword? (syntax->datum #'slot))
+ #'(begin out ...))
((_ (slot rest ...) out ...)
- (identifier? (syntax slot))
- (syntax (define-class-pre-definitions (rest ...)
- out ...)))
+ (identifier? #'slot)
+ #'(define-class-pre-definitions (rest ...)
+ out ...))
((_ ((slotname slotopt ...) rest ...) out ...)
- (syntax (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-class-pre-definitions (rest ...)
+ out ... (define-class-pre-definition (slotopt ...)))))))
+
+(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}
names))
(goops-error "no prefixes supplied"))))
-(define (make-generic . name)
- (let ((name (and (pair? name) (car name))))
- (make <generic> #:name name)))
+(define* (make-generic #:optional name)
+ (make <generic> #:name name))
-(define (make-extended-generic gfs . name)
- (let* ((name (and (pair? name) (car name)))
- (gfs (if (pair? gfs) gfs (list gfs)))
+(define* (make-extended-generic gfs #:optional name)
+ (let* ((gfs (if (list? gfs) gfs (list gfs)))
(gws? (any (lambda (gf) (is-a? gf <generic-with-setter>)) gfs)))
(let ((ans (if gws?
(let* ((sname (and name (make-setter-name name)))
(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))
-
-(define (ensure-generic old-definition . name)
- (let ((name (and (pair? name) (car name))))
- (cond ((is-a? old-definition <generic>) old-definition)
- ((procedure-with-setter? old-definition)
- (make <generic-with-setter>
- #:name name
- #:default (procedure old-definition)
- #:setter (setter old-definition)))
- ((procedure? old-definition)
- (make <generic> #:name name #:default old-definition))
- (else (make <generic> #:name name)))))
+ gfs)
+ (invalidate-method-cache! eg))
+
+(define* (ensure-generic old-definition #:optional name)
+ (cond ((is-a? old-definition <generic>) old-definition)
+ ((procedure-with-setter? old-definition)
+ (make <generic-with-setter>
+ #:name name
+ #:default (procedure old-definition)
+ #:setter (setter old-definition)))
+ ((procedure? old-definition)
+ (if (generic-capability? old-definition) old-definition
+ (make <generic> #:name name #:default old-definition)))
+ (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))))
-(define (make-accessor . name)
- (let ((name (and (pair? name) (car name))))
- (make <accessor>
- #:name name
- #:setter (make <generic>
- #:name (and name (make-setter-name name))))))
-
-(define (ensure-accessor proc . name)
- (let ((name (and (pair? name) (car name))))
- (cond ((and (is-a? proc <accessor>)
- (is-a? (setter proc) <generic>))
- proc)
- ((is-a? proc <generic-with-setter>)
- (upgrade-accessor proc (setter proc)))
- ((is-a? proc <generic>)
- (upgrade-accessor proc (make-generic name)))
- ((procedure-with-setter? proc)
- (make <accessor>
- #:name name
- #:default (procedure proc)
- #:setter (ensure-generic (setter proc) name)))
- ((procedure? proc)
- (ensure-accessor (ensure-generic proc name) name))
- (else
- (make-accessor name)))))
+(define* (make-accessor #:optional name)
+ (make <accessor>
+ #:name name
+ #:setter (make <generic>
+ #:name (and name (make-setter-name name)))))
+
+(define* (ensure-accessor proc #:optional name)
+ (cond ((and (is-a? proc <accessor>)
+ (is-a? (setter proc) <generic>))
+ proc)
+ ((is-a? proc <generic-with-setter>)
+ (upgrade-accessor proc (setter proc)))
+ ((is-a? proc <generic>)
+ (upgrade-accessor proc (make-generic name)))
+ ((procedure-with-setter? proc)
+ (make <accessor>
+ #:name name
+ #:default (procedure proc)
+ #:setter (ensure-generic (setter proc) name)))
+ ((procedure? proc)
+ (ensure-accessor (if (generic-capability? proc)
+ (make <generic> #:name name #:default proc)
+ (ensure-generic proc name))
+ name))
+ (else
+ (make-accessor name))))
(define (upgrade-accessor generic setter)
(let ((methods (slot-ref generic 'methods))
(slot-set! method 'generic-function gws))
methods)
(slot-set! gws 'methods methods)
+ (invalidate-method-cache! gws)
gws))
;;;
(let lp ((ls args) (formals '()) (specializers '()))
(syntax-case ls ()
(((f s) . rest)
- (and (identifier? (syntax f)) (identifier? (syntax s)))
- (lp (syntax rest)
- (cons (syntax f) formals)
- (cons (syntax s) specializers)))
+ (and (identifier? #'f) (identifier? #'s))
+ (lp #'rest
+ (cons #'f formals)
+ (cons #'s specializers)))
((f . rest)
- (identifier? (syntax f))
- (lp (syntax rest)
- (cons (syntax f) formals)
- (cons (syntax <top>) specializers)))
+ (identifier? #'f)
+ (lp #'rest
+ (cons #'f formals)
+ (cons #'<top> specializers)))
(()
(list (reverse formals)
- (reverse (cons (syntax '()) specializers))))
+ (reverse (cons #''() specializers))))
(tail
- (identifier? (syntax tail))
- (list (append (reverse formals) (syntax tail))
- (reverse (cons (syntax <top>) specializers)))))))
+ (identifier? #'tail)
+ (list (append (reverse formals) #'tail)
+ (reverse (cons #'<top> specializers)))))))
(define (find-free-id exp referent)
(syntax-case exp ()
((x . y)
- (or (find-free-id (syntax x) referent)
- (find-free-id (syntax y) referent)))
+ (or (find-free-id #'x referent)
+ (find-free-id #'y referent)))
(x
- (identifier? (syntax x))
- (let ((id (datum->syntax (syntax x) referent)))
- (and (free-identifier=? (syntax x) id) id)))
+ (identifier? #'x)
+ (let ((id (datum->syntax #'x referent)))
+ (and (free-identifier=? #'x id) id)))
(_ #f)))
(define (compute-procedure formals body)
(syntax-case body ()
((body0 ...)
(with-syntax ((formals formals))
- (syntax (lambda formals body0 ...))))))
+ #'(lambda formals body0 ...)))))
(define (->proper args)
(let lp ((ls args) (out '()))
(syntax-case ls ()
- ((x . xs) (lp (syntax xs) (cons (syntax x) out)))
+ ((x . xs) (lp #'xs (cons #'x out)))
(() (reverse out))
- (tail (reverse (cons (syntax tail) out))))))
+ (tail (reverse (cons #'tail out))))))
(define (compute-make-procedure formals body next-method)
(syntax-case body ()
(with-syntax ((next-method next-method))
(syntax-case formals ()
((formal ...)
- (syntax
- (lambda (real-next-method)
- (lambda (formal ...)
- (let ((next-method (lambda args
- (if (null? args)
- (real-next-method formal ...)
- (apply real-next-method args)))))
- body ...)))))
+ #'(lambda (real-next-method)
+ (lambda (formal ...)
+ (let ((next-method (lambda args
+ (if (null? args)
+ (real-next-method formal ...)
+ (apply real-next-method args)))))
+ body ...))))
(formals
- (with-syntax (((formal ...) (->proper (syntax formals))))
- (syntax
- (lambda (real-next-method)
- (lambda formals
- (let ((next-method (lambda args
- (if (null? args)
- (apply real-next-method formal ...)
- (apply real-next-method args)))))
- body ...)))))))))))
+ (with-syntax (((formal ...) (->proper #'formals)))
+ #'(lambda (real-next-method)
+ (lambda formals
+ (let ((next-method (lambda args
+ (if (null? args)
+ (apply real-next-method formal ...)
+ (apply real-next-method args)))))
+ body ...))))))))))
(define (compute-procedures formals body)
;; So, our use of this is broken, because it operates on the
(let ((id (find-free-id body 'next-method)))
(if id
;; return a make-procedure
- (values (syntax #f)
+ (values #'#f
(compute-make-procedure formals body id))
(values (compute-procedure formals body)
- (syntax #f)))))
+ #'#f))))
(syntax-case x ()
- ((_ args) (syntax (method args (if #f #f))))
+ ((_ args) #'(method args (if #f #f)))
((_ args body0 body1 ...)
- (with-syntax (((formals (specializer ...)) (parse-args (syntax args))))
+ (with-syntax (((formals (specializer ...)) (parse-args #'args)))
(call-with-values
(lambda ()
- (compute-procedures (syntax formals) (syntax (body0 body1 ...))))
+ (compute-procedures #'formals #'(body0 body1 ...)))
(lambda (procedure make-procedure)
(with-syntax ((procedure procedure)
(make-procedure make-procedure))
- (syntax
- (make <method>
- #:specializers (cons* specializer ...)
- #:formals 'formals
- #:body '(body0 body1 ...)
- #:make-procedure make-procedure
- #:procedure procedure))))))))))
+ #'(make <method>
+ #:specializers (cons* specializer ...)
+ #:formals 'formals
+ #:body '(body0 body1 ...)
+ #:make-procedure make-procedure
+ #:procedure procedure)))))))))
;;;
;;; {add-method!}
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*))
(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)
;; 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)))
(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)
(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))))
((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
;;;
;; '(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
;;; 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
(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))))
((#: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
(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)))
(let ((proc (get-keyword #:procedure initargs #f)))
(cond ((not proc))
((pair? proc)
- (apply set-object-procedure! object proc))
+ (apply slot-set! object 'procedure proc))
(else
- (set-object-procedure! object proc)))))
+ (slot-set! object 'procedure proc)))))
(define-method (initialize (applicable-struct <applicable-struct>) initargs)
(next-method)
HCoop / bpt / guile.git / blobdiff