;;; installed-scm-file
-;;;; Copyright (C) 1998,1999,2000,2001,2002, 2003, 2006, 2009, 2010, 2011 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 (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)))
#'(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-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}
(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))
+ gfs)
+ (invalidate-method-cache! eg))
(define* (ensure-generic old-definition #:optional name)
(cond ((is-a? old-definition <generic>) 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))))
(slot-set! method 'generic-function gws))
methods)
(slot-set! gws 'methods methods)
+ (invalidate-method-cache! gws)
gws))
;;;
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)))
HCoop / bpt / guile.git / blobdiff