;;; installed-scm-file
-;;;; Copyright (C) 1998,1999,2000,2001,2002, 2003, 2006 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 2.1 of the License, or (at your option) any later version.
-;;;;
+;;;; 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
make-extended-generic
make-accessor ensure-accessor
- make-method add-method!
- object-eqv? object-equal?
+ add-method!
class-slot-ref class-slot-set! slot-unbound slot-missing
slot-definition-name slot-definition-options
slot-definition-allocation
slot-exists-using-class? slot-ref slot-set! slot-bound?
class-name class-direct-supers class-direct-subclasses
class-direct-methods class-direct-slots class-precedence-list
- class-slots class-environment
+ class-slots
generic-function-name
- generic-function-methods method-generic-function method-specializers
+ generic-function-methods method-generic-function
+ method-specializers method-formals
primitive-generic-generic enable-primitive-generic!
method-procedure accessor-method-slot-definition
- slot-exists? make find-method get-keyword)
- :replace (<class> <operator-class> <entity-class> <entity>)
- :no-backtrace)
+ slot-exists? make find-method get-keyword))
(define *goops-module* (current-module))
;; First initialize the builtin part of GOOPS
-(eval-case
- ((load-toplevel compile-toplevel)
- (%init-goops-builtins)))
+(eval-when (expand load eval)
+ (%init-goops-builtins))
+
+(eval-when (expand load eval)
+ (use-modules ((language tree-il primitives) :select (add-interesting-primitive!)))
+ (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
-(define min-fixnum (- (expt 2 29)))
-
-(define max-fixnum (- (expt 2 29) 1))
+(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 '()))
;;
(set! table-of-metas (cons (cons meta-supers new) table-of-metas))
new))))))
-(define (ensure-metaclass supers env)
+(define (ensure-metaclass supers)
(if (null? supers)
<class>
(let* ((all-metas (map (lambda (x) (class-of x)) supers))
- (all-cpls (apply append
- (map (lambda (m)
- (cdr (class-precedence-list m)))
- all-metas)))
+ (all-cpls (append-map (lambda (m)
+ (cdr (class-precedence-list m)))
+ all-metas))
(needed-metas '()))
;; Find the most specific metaclasses. The new metaclass will be
;; a subclass of these.
;;; SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...)
;;; OPTION ::= KEYWORD VALUE
;;;
-(define (define-class-pre-definition kw val)
- (case kw
- ((#:getter #:setter)
- `(if (or (not (defined? ',val))
- (not (is-a? ,val <generic>)))
- (define-generic ,val)))
- ((#:accessor)
- `(if (or (not (defined? ',val))
- (not (is-a? ,val <accessor>)))
- (define-accessor ,val)))
- (else #f)))
(define (kw-do-map mapper f kwargs)
(define (keywords l)
(a (args kwargs)))
(mapper f k a)))
-;;; This code should be implemented in C.
-;;;
-(define-macro (define-class name supers . slots)
- ;; Some slot options require extra definitions to be made. In
- ;; particular, we want to make sure that the generic function objects
- ;; which represent accessors exist before `make-class' tries to add
- ;; methods to them.
- ;;
- ;; Postpone some error handling to class macro.
- ;;
- `(begin
- ;; define accessors
- ,@(append-map (lambda (slot)
- (kw-do-map filter-map
- define-class-pre-definition
- (if (pair? slot) (cdr slot) '())))
- (take-while (lambda (x) (not (keyword? x))) slots))
- (if (and (defined? ',name)
- (is-a? ,name <class>)
- (memq <object> (class-precedence-list ,name)))
- (class-redefinition ,name
- (class ,supers ,@slots #:name ',name))
- (define ,name (class ,supers ,@slots #:name ',name)))))
-
-(define standard-define-class define-class)
+(define (make-class supers slots . options)
+ (let* ((name (get-keyword #:name options (make-unbound)))
+ (supers (if (not (or-map (lambda (class)
+ (memq <object>
+ (class-precedence-list class)))
+ supers))
+ (append supers (list <object>))
+ supers))
+ (metaclass (or (get-keyword #:metaclass options #f)
+ (ensure-metaclass supers))))
+
+ ;; Verify that all direct slots are different and that we don't inherit
+ ;; several time from the same class
+ (let ((tmp1 (find-duplicate supers))
+ (tmp2 (find-duplicate (map slot-definition-name slots))))
+ (if tmp1
+ (goops-error "make-class: super class ~S is duplicate in class ~S"
+ tmp1 name))
+ (if tmp2
+ (goops-error "make-class: slot ~S is duplicate in class ~S"
+ tmp2 name)))
+
+ ;; Everything seems correct, build the class
+ (apply make metaclass
+ #:dsupers supers
+ #:slots slots
+ #:name name
+ options)))
;;; (class (SUPER ...) SLOT-DEFINITION ... OPTION ...)
;;;
(else
`(list ',def))))
slots))
-
(if (not (list? supers))
(goops-error "malformed superclass list: ~S" supers))
- (let ((slot-defs (cons #f '()))
- (slots (take-while (lambda (x) (not (keyword? x))) slots))
+ (let ((slots (take-while (lambda (x) (not (keyword? x))) slots))
(options (or (find-tail keyword? slots) '())))
`(make-class
;; evaluate super class variables
;; evaluate class options
,@options)))
-(define (make-class supers slots . options)
- (let ((env (or (get-keyword #:environment options #f)
- (top-level-env))))
- (let* ((name (get-keyword #:name options (make-unbound)))
- (supers (if (not (or-map (lambda (class)
- (memq <object>
- (class-precedence-list class)))
- supers))
- (append supers (list <object>))
- supers))
- (metaclass (or (get-keyword #:metaclass options #f)
- (ensure-metaclass supers env))))
-
- ;; Verify that all direct slots are different and that we don't inherit
- ;; several time from the same class
- (let ((tmp1 (find-duplicate supers))
- (tmp2 (find-duplicate (map slot-definition-name slots))))
- (if tmp1
- (goops-error "make-class: super class ~S is duplicate in class ~S"
- tmp1 name))
- (if tmp2
- (goops-error "make-class: slot ~S is duplicate in class ~S"
- tmp2 name)))
-
- ;; Everything seems correct, build the class
- (apply make metaclass
- #:dsupers supers
- #:slots slots
- #:name name
- #:environment env
- options))))
+(define-syntax define-class-pre-definition
+ (lambda (x)
+ (syntax-case x ()
+ ((_ (k arg rest ...) out ...)
+ (keyword? (syntax->datum #'k))
+ (case (syntax->datum #'k)
+ ((#:getter #:setter)
+ #'(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)
+ #'(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
+ #'(define-class-pre-definition (rest ...) out ...))))
+ ((_ () out ...)
+ #'(begin out ...)))))
+
+;; Some slot options require extra definitions to be made. In
+;; particular, we want to make sure that the generic function objects
+;; which represent accessors exist before `make-class' tries to add
+;; methods to them.
+(define-syntax define-class-pre-definitions
+ (lambda (x)
+ (syntax-case x ()
+ ((_ () out ...)
+ #'(begin out ...))
+ ((_ (slot rest ...) out ...)
+ (keyword? (syntax->datum #'slot))
+ #'(begin out ...))
+ ((_ (slot rest ...) out ...)
+ (identifier? #'slot)
+ #'(define-class-pre-definitions (rest ...)
+ out ...))
+ ((_ ((slotname slotopt ...) rest ...) out ...)
+ #'(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-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)))
(setters
- (apply append
- (map (lambda (gf)
+ (append-map (lambda (gf)
(if (is-a? gf <generic-with-setter>)
(list (ensure-generic (setter gf)
sname))
'()))
- gfs)))
+ gfs))
(es (make <extended-generic-with-setter>
#:name name
#:extends gfs
(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-macro (define-accessor name)
- (if (not (symbol? name))
- (goops-error "bad accessor name: ~S" name))
- `(define ,name
- (if (and (defined? ',name) (is-a? ,name <accessor>))
- (make <accessor> #:name ',name)
- (ensure-accessor (if (defined? ',name) ,name #f) ',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))
;;;
;;; {Methods}
;;;
-(define-macro (define-method head . body)
- (if (not (pair? head))
- (goops-error "bad method head: ~S" head))
- (let ((gf (car head)))
- (cond ((and (pair? gf)
- (eq? (car gf) 'setter)
- (pair? (cdr gf))
- (symbol? (cadr gf))
- (null? (cddr gf)))
- ;; named setter method
- (let ((name (cadr gf)))
- (cond ((not (symbol? name))
- `(add-method! (setter ,name)
- (method ,(cdr head) ,@body)))
- (else
- `(begin
- (if (or (not (defined? ',name))
- (not (is-a? ,name <accessor>)))
- (define-accessor ,name))
- (add-method! (setter ,name)
- (method ,(cdr head) ,@body)))))))
- ((not (symbol? gf))
- `(add-method! ,gf (method ,(cdr head) ,@body)))
- (else
- `(begin
- ;; FIXME: this code is how it always was, but it's quite
- ;; cracky: it will only define the generic function if it
- ;; was undefined before (ok), or *was defined to #f*. The
- ;; latter is crack. But there are bootstrap issues about
- ;; fixing this -- change it to (is-a? ,gf <generic>) and
- ;; see.
- (if (or (not (defined? ',gf))
- (not ,gf))
- (define-generic ,gf))
- (add-method! ,gf
- (method ,(cdr head) ,@body)))))))
-
-(define (make-method specializers procedure)
- (make <method>
- #:specializers specializers
- #:procedure procedure))
-
-(define-macro (method args . body)
- (letrec ((specializers
- (lambda (ls)
- (cond ((null? ls) (list (list 'quote '())))
- ((pair? ls) (cons (if (pair? (car ls))
- (cadar ls)
- '<top>)
- (specializers (cdr ls))))
- (else '(<top>)))))
- (formals
- (lambda (ls)
- (if (pair? ls)
- (cons (if (pair? (car ls)) (caar ls) (car ls))
- (formals (cdr ls)))
- ls))))
- `(make <method>
- #:specializers (cons* ,@(specializers args))
- #:formals ',(formals args)
- #:body ',body
- #:compile-env (compile-time-environment)
- #:procedure (lambda ,(formals args)
- ,@(if (null? body)
- '(begin)
- body)))))
+(define (toplevel-define! name val)
+ (module-define! (current-module) name val))
+
+(define-syntax define-method
+ (syntax-rules (setter)
+ ((_ ((setter name) . args) body ...)
+ (begin
+ (if (or (not (defined? 'name))
+ (not (is-a? name <accessor>)))
+ (toplevel-define! 'name
+ (ensure-accessor
+ (if (defined? 'name) name #f) 'name)))
+ (add-method! (setter name) (method args body ...))))
+ ((_ (name . args) body ...)
+ (begin
+ ;; FIXME: this code is how it always was, but it's quite cracky:
+ ;; it will only define the generic function if it was undefined
+ ;; before (ok), or *was defined to #f*. The latter is crack. But
+ ;; there are bootstrap issues about fixing this -- change it to
+ ;; (is-a? name <generic>) and see.
+ (if (or (not (defined? 'name))
+ (not name))
+ (toplevel-define! 'name (make <generic> #:name 'name)))
+ (add-method! name (method args body ...))))))
+
+(define-syntax method
+ (lambda (x)
+ (define (parse-args args)
+ (let lp ((ls args) (formals '()) (specializers '()))
+ (syntax-case ls ()
+ (((f s) . rest)
+ (and (identifier? #'f) (identifier? #'s))
+ (lp #'rest
+ (cons #'f formals)
+ (cons #'s specializers)))
+ ((f . rest)
+ (identifier? #'f)
+ (lp #'rest
+ (cons #'f formals)
+ (cons #'<top> specializers)))
+ (()
+ (list (reverse formals)
+ (reverse (cons #''() specializers))))
+ (tail
+ (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 #'x referent)
+ (find-free-id #'y referent)))
+ (x
+ (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))
+ #'(lambda formals body0 ...)))))
+
+ (define (->proper args)
+ (let lp ((ls args) (out '()))
+ (syntax-case ls ()
+ ((x . xs) (lp #'xs (cons #'x out)))
+ (() (reverse out))
+ (tail (reverse (cons #'tail out))))))
+
+ (define (compute-make-procedure formals body next-method)
+ (syntax-case body ()
+ ((body ...)
+ (with-syntax ((next-method next-method))
+ (syntax-case formals ()
+ ((formal ...)
+ #'(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 #'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
+ ;; pre-expansion source code. It's equivalent to just searching
+ ;; for referent in the datums. Ah well.
+ (let ((id (find-free-id body 'next-method)))
+ (if id
+ ;; return a make-procedure
+ (values #'#f
+ (compute-make-procedure formals body id))
+ (values (compute-procedure formals body)
+ #'#f))))
+
+ (syntax-case x ()
+ ((_ args) #'(method args (if #f #f)))
+ ((_ args body0 body1 ...)
+ (with-syntax (((formals (specializer ...)) (parse-args #'args)))
+ (call-with-values
+ (lambda ()
+ (compute-procedures #'formals #'(body0 body1 ...)))
+ (lambda (procedure make-procedure)
+ (with-syntax ((procedure procedure)
+ (make-procedure make-procedure))
+ #'(make <method>
+ #:specializers (cons* specializer ...)
+ #:formals 'formals
+ #:body '(body0 body1 ...)
+ #:make-procedure make-procedure
+ #:procedure procedure)))))))))
;;;
;;; {add-method!}
;; Add method in all the classes which appears in its specializers list
(for-each* (lambda (x)
(let ((dm (class-direct-methods x)))
- (if (not (memv m dm))
+ (if (not (memq m dm))
(slot-set! x 'direct-methods (cons m dm)))))
(method-specializers m)))
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*))
;;;
(define-method (method-source (m <method>))
(let* ((spec (map* class-name (slot-ref m 'specializers)))
- (proc (procedure-source (slot-ref m 'procedure)))
- (args (cadr proc))
- (body (cddr proc)))
- (cons 'method
- (cons (map* list args spec)
- body))))
+ (src (procedure-source (slot-ref m 'procedure))))
+ (and src
+ (let ((args (cadr src))
+ (body (cddr src)))
+ (cons 'method
+ (cons (map* list args spec)
+ body))))))
+
+(define-method (method-formals (m <method>))
+ (slot-ref m 'formals))
;;;
;;; Slots
(define (slot-init-function class slot-name)
(cadr (assq slot-name (slot-ref class 'getters-n-setters))))
+(define (accessor-method-slot-definition obj)
+ "Return the slot definition of the accessor @var{obj}."
+ (slot-ref obj 'slot-definition))
+
;;;
;;; {Standard methods used by the C runtime}
;;; Methods to compare objects
;;;
-(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))
+;; Have to do this in a strange order because equal? is used in the
+;; add-method! implementation; we need to make sure that when the
+;; primitive is extended, that the generic has a method. =
+(define g-equal? (make-generic 'equal?))
+;; When this generic gets called, we will have already checked eq? and
+;; eqv? -- the purpose of this generic is to extend equality. So by
+;; default, there is no extension, thus the #f return.
+(add-method! g-equal? (method (x y) #f))
+(set-primitive-generic! equal? g-equal?)
;;;
;;; methods to display/write an object
(display #\> file))
(next-method))))
-(define-method (write (o <foreign-object>) file)
- (let ((class (class-of o)))
- (if (slot-bound? class 'name)
- (begin
- (display "#<foreign-object " file)
- (display (class-name class) file)
- (display #\space file)
- (display-address o file)
- (display #\> file))
- (next-method))))
-
(define-method (write (class <class>) file)
(let ((meta (class-of class)))
(if (and (slot-bound? class 'name)
(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)))
(make-class (class-direct-supers c)
(class-direct-slots c)
#:name (class-name c)
- #:environment (slot-ref c 'environment)
#:metaclass (class-of c))))
;;;
;;; compute-slot-accessors
;;;
-(define (compute-slot-accessors class slots env)
+(define (compute-slot-accessors class slots)
(for-each
(lambda (s g-n-s)
- (let ((name (slot-definition-name s))
- (getter-function (slot-definition-getter s))
+ (let ((getter-function (slot-definition-getter s))
(setter-function (slot-definition-setter s))
(accessor (slot-definition-accessor s)))
(if getter-function
(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)
- (let ((source (and (closure? proc) (procedure-source proc))))
- (if (and source (null? (cdddr source)))
- (let ((obj (caadr source)))
- ;; smart closure compilation
- (local-eval
- `(lambda (,obj) (,assert-bound ,(caddr source) ,obj))
- (procedure-environment proc)))
- (lambda (o) (assert-bound (proc o) o)))))
-
-(define n-standard-accessor-methods 10)
-
-(define bound-check-get-methods (make-vector n-standard-accessor-methods #f))
-(define standard-get-methods (make-vector n-standard-accessor-methods #f))
-(define standard-set-methods (make-vector n-standard-accessor-methods #f))
-
-(define (standard-accessor-method make methods)
- (lambda (index)
- (cond ((>= index n-standard-accessor-methods) (make index))
- ((vector-ref methods index))
- (else (let ((m (make index)))
- (vector-set! methods index m)
- m)))))
+ (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.
-
-(eval-case
- ((load-toplevel compile-toplevel)
- (use-modules ((language scheme translate) :select (define-scheme-translator))
- ((language ghil) :select (make-ghil-inline))
- (system base pmatch))
-
- ;; unfortunately, can't use define-inline because these are primitive
- ;; syntaxen.
- (define-scheme-translator @slot-ref
- ((,obj ,index) (guard (integer? index)
- (>= index 0) (< index max-fixnum))
- (make-ghil-inline #f #f 'slot-ref
- (list (retrans obj) (retrans index)))))
-
- (define-scheme-translator @slot-set!
- ((,obj ,index ,val) (guard (integer? index)
- (>= index 0) (< index max-fixnum))
- (make-ghil-inline #f #f 'slot-set
- (list (retrans obj) (retrans index) (retrans val)))))))
-
-;; Irritatingly, we can't use `compile' here, as the module shadows
-;; the binding.
-(define (make-bound-check-get index)
- ((@ (system base compile) compile)
- `(lambda (o) (let ((x (@slot-ref o ,index)))
- (if (unbound? x)
- (slot-unbound obj)
- x)))
- #:env *goops-module*))
-
-(define (make-get index)
- ((@ (system base compile) compile)
- `(lambda (o) (@slot-ref o ,index))
- #:env *goops-module*))
-
-(define (make-set index)
- ((@ (system base compile) compile)
- `(lambda (o v) (@slot-set! o ,index v))
- #:env *goops-module*))
-
-(define bound-check-get
- (standard-accessor-method make-bound-check-get bound-check-get-methods))
-(define standard-get (standard-accessor-method make-get standard-get-methods))
-(define standard-set (standard-accessor-method make-set standard-set-methods))
+;; lookup.
+
+(eval-when (expand load eval)
+ (define num-standard-pre-cache 20))
+
+(define-macro (define-standard-accessor-method form . body)
+ (let ((name (caar form))
+ (n-var (cadar form))
+ (args (cdr form)))
+ (define (make-one x)
+ (define (body-trans form)
+ (cond ((not (pair? form)) form)
+ ((eq? (car form) 'struct-ref)
+ `(,(car form) ,(cadr form) ,x))
+ ((eq? (car form) 'struct-set!)
+ `(,(car form) ,(cadr form) ,x ,(cadddr form)))
+ (else
+ (map body-trans form))))
+ `(lambda ,args ,@(map body-trans body)))
+ `(define ,name
+ (let ((cache (vector ,@(map make-one (iota num-standard-pre-cache)))))
+ (lambda (n)
+ (if (< n ,num-standard-pre-cache)
+ (vector-ref cache n)
+ ((lambda (,n-var) (lambda ,args ,@body)) n)))))))
+
+(define-standard-accessor-method ((bound-check-get n) o)
+ (let ((x (struct-ref o n)))
+ (if (unbound? x)
+ (slot-unbound o)
+ x)))
+
+(define-standard-accessor-method ((standard-get n) o)
+ (struct-ref o n))
+
+(define-standard-accessor-method ((standard-set n) o v)
+ (struct-set! o n v))
;;; compute-getters-n-setters
;;;
-(define (make-thunk thunk)
- (lambda () (thunk)))
-
-(define (compute-getters-n-setters class slots env)
+(define (compute-getters-n-setters class slots)
(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)))))
+ (if (thunk? thunk)
+ thunk
+ (goops-error "Bad init-thunk for slot `~S' in ~S: ~S"
+ name class thunk))))
(let ((init (slot-definition-init-value s)))
(and (not (unbound? init))
(lambda () init)))))
(else
(let ((get (car l))
(set (cadr l)))
- ;; 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"
+ (if (not (procedure? get))
+ (goops-error "Bad getter closure for slot `~S' in ~S: ~S"
slot class get))
- (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"
+ (if (not (procedure? set))
+ (goops-error "Bad setter closure for slot `~S' in ~S: ~S"
slot class set))))))
(map (lambda (s)
;; '(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
(let ((get (get-keyword #:slot-ref (slot-definition-options s) #f))
- (set (get-keyword #:slot-set! (slot-definition-options s) #f))
- (env (class-environment class)))
+ (set (get-keyword #:slot-set! (slot-definition-options s) #f)))
(if (not (and get set))
(goops-error "You must supply a #:slot-ref and a #:slot-set! in ~S"
s))
(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)))
(define-method (initialize (class <class>) initargs)
(next-method)
(let ((dslots (get-keyword #:slots initargs '()))
- (supers (get-keyword #:dsupers initargs '()))
- (env (get-keyword #:environment initargs (top-level-env))))
-
+ (supers (get-keyword #:dsupers initargs '())))
(slot-set! class 'name (get-keyword #:name initargs '???))
(slot-set! class 'direct-supers supers)
(slot-set! class 'direct-slots dslots)
(slot-set! class 'direct-methods '())
(slot-set! class 'cpl (compute-cpl class))
(slot-set! class 'redefined #f)
- (slot-set! class 'environment env)
(let ((slots (compute-slots class)))
(slot-set! class 'slots slots)
(slot-set! class 'nfields 0)
(slot-set! class 'getters-n-setters (compute-getters-n-setters class
- slots
- env))
+ slots))
;; Build getters - setters - accessors
- (compute-slot-accessors class slots env))
+ (compute-slot-accessors class slots))
;; Update the "direct-subclasses" of each inherited classes
(for-each (lambda (x)
;; Support for the underlying structs:
- ;; Inherit class flags (invisible on scheme level) from supers
- (%inherit-magic! class supers)
-
;; Set the layout slot
- (%prep-layout! class)))
+ (%prep-layout! class)
+ ;; Inherit class flags (invisible on scheme level) from supers
+ (%inherit-magic! class supers)))
(define (initialize-object-procedure object initargs)
(let ((proc (get-keyword #:procedure initargs #f)))
(cond ((not proc))
((pair? proc)
- (apply set-object-procedure! object proc))
- ((valid-object-procedure? proc)
- (set-object-procedure! object proc))
+ (apply slot-set! object 'procedure proc))
(else
- (set-object-procedure! object
- (lambda args (apply proc args)))))))
-
-(define-method (initialize (class <operator-class>) initargs)
- (next-method)
- (initialize-object-procedure class initargs))
-
-(define-method (initialize (owsc <operator-with-setter-class>) initargs)
- (next-method)
- (%set-object-setter! owsc (get-keyword #:setter initargs #f)))
-
-(define-method (initialize (entity <entity>) initargs)
- (next-method)
- (initialize-object-procedure entity initargs))
+ (slot-set! object 'procedure proc)))))
-(define-method (initialize (ews <entity-with-setter>) initargs)
+(define-method (initialize (applicable-struct <applicable-struct>) initargs)
(next-method)
- (%set-object-setter! ews (get-keyword #:setter initargs #f)))
+ (initialize-object-procedure applicable-struct initargs))
(define-method (initialize (generic <generic>) initargs)
(let ((previous-definition (get-keyword #:default initargs #f))
(set-procedure-property! generic 'name name))
))
+(define-method (initialize (gws <generic-with-setter>) initargs)
+ (next-method)
+ (%set-object-setter! gws (get-keyword #:setter initargs #f)))
+
(define-method (initialize (eg <extended-generic>) initargs)
(next-method)
(slot-set! eg 'extends (get-keyword #:extends initargs '())))
(slot-set! method 'generic-function (get-keyword #:generic-function initargs #f))
(slot-set! method 'specializers (get-keyword #:specializers initargs '()))
(slot-set! method 'procedure
- (get-keyword #:procedure initargs dummy-procedure))
- (slot-set! method 'code-table '())
+ (get-keyword #:procedure initargs #f))
(slot-set! method 'formals (get-keyword #:formals initargs '()))
(slot-set! method 'body (get-keyword #:body initargs '()))
- (slot-set! method 'compile-env (get-keyword #:compile-env initargs #f)))
+ (slot-set! method 'make-procedure (get-keyword #:make-procedure initargs #f)))
-(define-method (initialize (obj <foreign-object>) initargs))
-
;;;
;;; {Change-class}
;;;
HCoop / bpt / guile.git / blobdiff