;;; installed-scm-file
-;;;; Copyright (C) 1998,1999,2000,2001,2002, 2003 Free Software Foundation, Inc.
+;;;; Copyright (C) 1998,1999,2000,2001,2002, 2003, 2006 Free Software Foundation, Inc.
;;;;
-;;;; This program is free software; you can redistribute it and/or modify
-;;;; it under the terms of the GNU General Public License as published by
-;;;; the Free Software Foundation; either version 2, or (at your option)
-;;;; any later version.
+;;;; 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 program is distributed in the hope that it will be useful,
+;;;; 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 General Public License for more details.
+;;;; 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 General Public License
-;;;; along with this software; see the file COPYING. If not, write to
-;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
-;;;; Boston, MA 02111-1307 USA
-;;;;
-;;;; As a special exception, the Free Software Foundation gives permission
-;;;; for additional uses of the text contained in its release of GUILE.
-;;;;
-;;;; The exception is that, if you link the GUILE library with other files
-;;;; to produce an executable, this does not by itself cause the
-;;;; resulting executable to be covered by the GNU General Public License.
-;;;; Your use of that executable is in no way restricted on account of
-;;;; linking the GUILE library code into it.
-;;;;
-;;;; This exception does not however invalidate any other reasons why
-;;;; the executable file might be covered by the GNU General Public License.
-;;;;
-;;;; This exception applies only to the code released by the
-;;;; Free Software Foundation under the name GUILE. If you copy
-;;;; code from other Free Software Foundation releases into a copy of
-;;;; GUILE, as the General Public License permits, the exception does
-;;;; not apply to the code that you add in this way. To avoid misleading
-;;;; anyone as to the status of such modified files, you must delete
-;;;; this exception notice from them.
-;;;;
-;;;; If you write modifications of your own for GUILE, it is your choice
-;;;; whether to permit this exception to apply to your modifications.
-;;;; If you do not wish that, delete this exception notice.
+;;;; 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)
- :export-syntax (define-class class
+ :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?
+ :export (goops-version is-a? class-of
ensure-metaclass ensure-metaclass-with-supers
make-class
make-generic ensure-generic
make-extended-generic
make-accessor ensure-accessor
+ process-class-pre-define-generic
+ process-class-pre-define-accessor
+ process-define-generic
+ process-define-accessor
make-method add-method!
object-eqv? object-equal?
class-slot-ref class-slot-set! slot-unbound slot-missing
method-procedure accessor-method-slot-definition
slot-exists? make find-method get-keyword)
:replace (<class> <operator-class> <entity-class> <entity>)
- :re-export (class-of) ;; from (guile)
:no-backtrace)
;; First initialize the builtin part of GOOPS
(define (define-class-pre-definition keyword exp env)
(case keyword
((#:getter #:setter)
- (if (defined? exp env)
- `(define ,exp (ensure-generic ,exp ',exp))
- `(define ,exp (make-generic ',exp))))
+ `(process-class-pre-define-generic ',exp))
((#:accessor)
- (if (defined? exp env)
- `(define ,exp (ensure-accessor ,exp ',exp))
- `(define ,exp (make-accessor ',exp))))
+ `(process-class-pre-define-accessor ',exp))
(else #f)))
+(define (process-class-pre-define-generic name)
+ (let ((var (module-variable (current-module) name)))
+ (if (not (and var
+ (variable-bound? var)
+ (is-a? (variable-ref var) <generic>)))
+ (process-define-generic name))))
+
+(define (process-class-pre-define-accessor name)
+ (let ((var (module-variable (current-module) name)))
+ (cond ((or (not var)
+ (not (variable-bound? var)))
+ (process-define-accessor name))
+ ((or (is-a? (variable-ref var) <accessor>)
+ (is-a? (variable-ref var) <extended-generic-with-setter>)))
+ ((is-a? (variable-ref var) <generic>)
+ ;;*fixme* don't mutate an imported object!
+ (variable-set! var (ensure-accessor (variable-ref var) name)))
+ (else
+ (process-define-accessor name)))))
+
;;; This code should be implemented in C.
;;;
(define define-class
(variable-set! var (class-redefinition old class))
(variable-set! var class)))))))))))
-(defmacro standard-define-class args
- `(define-class ,@args))
+(define standard-define-class define-class)
;;; (class (SUPER ...) SLOT-DEFINITION ... OPTION ...)
;;;
(cond ((not (symbol? name))
(goops-error "bad generic function name: ~S" name))
((top-level-env? env)
- `(let* ((var (module-ensure-local-variable!
- (current-module) ',name))
- (old (and (variable-bound? var) (variable-ref var))))
- (if (or (not old) (is-a? old <generic>))
- (variable-set! var (make <generic> #:name ',name))
- (variable-set! var (ensure-generic old ',name)))))
+ `(process-define-generic ',name))
(else
`(define ,name (make <generic> #:name ',name))))))))
+(define (process-define-generic name)
+ (let ((var (module-ensure-local-variable! (current-module) name)))
+ (if (or (not var)
+ (not (variable-bound? var))
+ (is-a? (variable-ref var) <generic>))
+ ;; redefine if NAME isn't defined previously, or is another generic
+ (variable-set! var (make <generic> #:name name))
+ ;; otherwise try to upgrade the object to a generic
+ (variable-set! var (ensure-generic (variable-ref var) name)))))
+
(define define-extended-generic
(procedure->memoizing-macro
(lambda (exp env)
(cond ((not (symbol? name))
(goops-error "bad accessor name: ~S" name))
((top-level-env? env)
- `(let* ((var (module-ensure-local-variable!
- (current-module) ',name))
- (old (and (variable-bound? var) (variable-ref var))))
- (if (or (not old)
- (and (is-a? old <accessor>)
- (is-a? (setter old) <generic>)))
- (variable-set! var (make-accessor ',name))
- (variable-set! var (ensure-accessor old ',name)))))
+ `(process-define-accessor ',name))
(else
`(define ,name (make-accessor ',name))))))))
+(define (process-define-accessor name)
+ (let ((var (module-ensure-local-variable! (current-module) name)))
+ (if (or (not var)
+ (not (variable-bound? var))
+ (is-a? (variable-ref var) <accessor>)
+ (is-a? (variable-ref var) <extended-generic-with-setter>))
+ ;; redefine if NAME isn't defined previously, or is another accessor
+ (variable-set! var (make-accessor name))
+ ;; otherwise try to upgrade the object to an accessor
+ (variable-set! var (ensure-accessor (variable-ref var) name)))))
+
(define (make-setter-name name)
(string->symbol (string-append "setter:" (symbol->string name))))
;;; Methods to compare objects
;;;
-(define-method (equal? x y) #f)
+(define-method (eqv? x y) #f)
+(define-method (equal? x y) (eqv? x y))
+;;; These following two methods are for backward compatibility only.
+;;; They are not called by the Guile interpreter.
+;;;
(define-method (object-eqv? x y) #f)
(define-method (object-equal? x y) (eqv? x y))
(define-method (remove-class-accessors! (c <class>))
(for-each (lambda (m)
(if (is-a? m <accessor-method>)
- (remove-method-in-classes! m)))
+ (let ((gf (slot-ref m 'generic-function)))
+ ;; remove the method from its GF
+ (slot-set! gf 'methods
+ (delq1! m (slot-ref gf 'methods)))
+ (%invalidate-method-cache! gf)
+ ;; remove the method from its specializers
+ (remove-method-in-classes! m))))
(class-direct-methods c)))
;;;
(make <accessor-method>
#:specializers (list class)
#:procedure (cond ((pair? g-n-s)
- (if init-thunk
- (car g-n-s)
- (make-generic-bound-check-getter (car g-n-s))
- ))
+ (make-generic-bound-check-getter (car g-n-s)))
(init-thunk
(standard-get g-n-s))
(else
(define standard-set (standard-accessor-method make-set standard-set-methods))
;;; compute-getters-n-setters
-;;;
+;;;
+(define (make-thunk thunk)
+ (lambda () (thunk)))
+
(define (compute-getters-n-setters class slots env)
- (define (compute-slot-init-function s)
- (or (slot-definition-init-thunk s)
+ (define (compute-slot-init-function name s)
+ (or (let ((thunk (slot-definition-init-thunk s)))
+ (and thunk
+ (cond ((not (thunk? thunk))
+ (goops-error "Bad init-thunk for slot `~S' in ~S: ~S"
+ name class thunk))
+ ((closure? thunk) thunk)
+ (else (make-thunk thunk)))))
(let ((init (slot-definition-init-value s)))
(and (not (unbound? init))
(lambda () init)))))
(define (verify-accessors slot l)
- (if (pair? l)
- (let ((get (car l))
- (set (cadr l)))
- (if (not (and (closure? get)
- (= (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)))
- (goops-error "Bad setter closure for slot `~S' in ~S: ~S"
- slot class set)))))
+ (cond ((integer? l))
+ ((not (and (list? l) (= (length l) 2)))
+ (goops-error "Bad getter and setter for slot `~S' in ~S: ~S"
+ slot class l))
+ (else
+ (let ((get (car l))
+ (set (cadr l)))
+ (if (not (and (closure? get)
+ (= (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)))
+ (goops-error "Bad setter closure for slot `~S' in ~S: ~S"
+ slot class set))))))
(map (lambda (s)
- (let* ((g-n-s (compute-get-n-set class s))
+ ;; The strange treatment of nfields is due to backward compatibility.
+ (let* ((index (slot-ref class 'nfields))
+ (g-n-s (compute-get-n-set class s))
+ (size (- (slot-ref class 'nfields) index))
(name (slot-definition-name s)))
- ; For each slot we have '(name init-function getter setter)
- ; If slot, we have the simplest form '(name init-function . index)
+ ;; NOTE: The following is interdependent with C macros
+ ;; defined above goops.c:scm_sys_prep_layout_x.
+ ;;
+ ;; For simple instance slots, we have the simplest form
+ ;; '(name init-function . index)
+ ;; For other slots we have
+ ;; '(name init-function getter setter . alloc)
+ ;; where alloc is:
+ ;; '(index size) for instance allocated slots
+ ;; '() for other slots
(verify-accessors name g-n-s)
(cons name
- (cons (compute-slot-init-function s)
- g-n-s))))
+ (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
(set (get-keyword #:slot-set! (slot-definition-options s) #f))
(env (class-environment class)))
(if (not (and get set))
- (goops-error "You must supply a :slot-ref and a :slot-set! in ~S"
+ (goops-error "You must supply a #:slot-ref and a #:slot-set! in ~S"
s))
(list get set)))
(else (next-method))))
(define (change-object-class old-instance old-class new-class)
(let ((new-instance (allocate-instance new-class '())))
- ;; Initalize the slot of the new instance
+ ;; Initialize the slots of the new instance
(for-each (lambda (slot)
(if (and (slot-exists-using-class? old-class old-instance slot)
(eq? (slot-definition-allocation
HCoop / bpt / guile.git / blobdiff