diff options
Diffstat (limited to 'module/oop/goops.scm')
| -rw-r--r-- | module/oop/goops.scm | 1701 |
1 files changed, 1701 insertions, 0 deletions
diff --git a/module/oop/goops.scm b/module/oop/goops.scm new file mode 100644 index 000000000..c1754da3e --- /dev/null +++ b/module/oop/goops.scm @@ -0,0 +1,1701 @@ +;;; installed-scm-file + +;;;; Copyright (C) 1998,1999,2000,2001,2002, 2003, 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 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 +;;;; + + +;;;; 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>. +;;;; + +(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 + ensure-metaclass ensure-metaclass-with-supers + make-class + make-generic ensure-generic + make-extended-generic + make-accessor ensure-accessor + add-method! + class-slot-ref class-slot-set! slot-unbound slot-missing + slot-definition-name slot-definition-options + slot-definition-allocation + slot-definition-getter slot-definition-setter + slot-definition-accessor + slot-definition-init-value slot-definition-init-form + slot-definition-init-thunk slot-definition-init-keyword + slot-init-function class-slot-definition + method-source + compute-cpl compute-std-cpl compute-get-n-set compute-slots + compute-getter-method compute-setter-method + allocate-instance initialize make-instance make + no-next-method no-applicable-method no-method + change-class update-instance-for-different-class + shallow-clone deep-clone + class-redefinition + apply-generic apply-method apply-methods + compute-applicable-methods %compute-applicable-methods + method-more-specific? sort-applicable-methods + class-subclasses class-methods + goops-error + min-fixnum max-fixnum + ;;; *fixme* Should go into goops.c + instance? slot-ref-using-class + slot-set-using-class! slot-bound-using-class? + 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 + generic-function-name + 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) + +(define *goops-module* (current-module)) + +;; First initialize the builtin part of GOOPS +(eval-when (eval load compile) + (%init-goops-builtins)) + +;; Then load the rest of GOOPS +(use-modules (oop goops util) + (oop goops dispatch) + (oop goops compile)) + + +(eval-when (eval load compile) + (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 '())) + +;; +;; is-a? +;; +(define (is-a? obj class) + (and (memq class (class-precedence-list (class-of obj))) #t)) + + +;;; +;;; {Meta classes} +;;; + +(define ensure-metaclass-with-supers + (let ((table-of-metas '())) + (lambda (meta-supers) + (let ((entry (assoc meta-supers table-of-metas))) + (if entry + ;; Found a previously created metaclass + (cdr entry) + ;; Create a new meta-class which inherit from "meta-supers" + (let ((new (make <class> #:dsupers meta-supers + #:slots '() + #:name (gensym "metaclass")))) + (set! table-of-metas (cons (cons meta-supers new) table-of-metas)) + new)))))) + +(define (ensure-metaclass supers env) + (if (null? supers) + <class> + (let* ((all-metas (map (lambda (x) (class-of x)) supers)) + (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. + (for-each + (lambda (meta) + (if (and (not (member meta all-cpls)) + (not (member meta needed-metas))) + (set! needed-metas (append needed-metas (list meta))))) + all-metas) + ;; Now return a subclass of the metaclasses we found. + (if (null? (cdr needed-metas)) + (car needed-metas) ; If there's only one, just use it. + (ensure-metaclass-with-supers needed-metas))))) + +;;; +;;; {Classes} +;;; + +;;; (define-class NAME (SUPER ...) SLOT-DEFINITION ... OPTION ...) +;;; +;;; SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...) +;;; OPTION ::= KEYWORD VALUE +;;; + +(define (kw-do-map mapper f kwargs) + (define (keywords l) + (cond + ((null? l) '()) + ((or (null? (cdr l)) (not (keyword? (car l)))) + (goops-error "malformed keyword arguments: ~a" kwargs)) + (else (cons (car l) (keywords (cddr l)))))) + (define (args l) + (if (null? l) '() (cons (cadr l) (args (cddr l))))) + ;; let* to check keywords first + (let* ((k (keywords kwargs)) + (a (args kwargs))) + (mapper f k a))) + +(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)))) + +;;; (class (SUPER ...) SLOT-DEFINITION ... OPTION ...) +;;; +;;; SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...) +;;; OPTION ::= KEYWORD VALUE +;;; +(define-macro (class supers . slots) + (define (make-slot-definition-forms slots) + (map + (lambda (def) + (cond + ((pair? def) + `(list ',(car def) + ,@(kw-do-map append-map + (lambda (kw arg) + (case kw + ((#:init-form) + `(#:init-form ',arg + #:init-thunk (lambda () ,arg))) + (else (list kw arg)))) + (cdr def)))) + (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)) + (options (or (find-tail keyword? slots) '()))) + `(make-class + ;; evaluate super class variables + (list ,@supers) + ;; evaluate slot definitions, except the slot name! + (list ,@(make-slot-definition-forms slots)) + ;; evaluate class options + ,@options))) + +(define-syntax define-class-pre-definition + (lambda (x) + (syntax-case x () + ((_ (k arg rest ...) out ...) + (keyword? (syntax->datum (syntax k))) + (case (syntax->datum (syntax 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)))))) + ((#: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)))))) + (else + (syntax + (define-class-pre-definition (rest ...) out ...))))) + ((_ () out ...) + (syntax (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 ...) + (syntax (begin out ...))) + ((_ (slot rest ...) out ...) + (keyword? (syntax->datum (syntax slot))) + (syntax (begin out ...))) + ((_ (slot rest ...) out ...) + (identifier? (syntax slot)) + (syntax (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-syntax standard-define-class + (syntax-rules () + ((_ arg ...) (define-class arg ...)))) + +;;; +;;; {Generic functions and accessors} +;;; + +;; Apparently the desired semantics are that we extend previous +;; procedural definitions, but that if `name' was already a generic, we +;; overwrite its definition. +(define-macro (define-generic name) + (if (not (symbol? name)) + (goops-error "bad generic function name: ~S" name)) + `(define ,name + (if (and (defined? ',name) (is-a? ,name <generic>)) + (make <generic> #:name ',name) + (ensure-generic (if (defined? ',name) ,name #f) ',name)))) + +(define-macro (define-extended-generic name val) + (if (not (symbol? name)) + (goops-error "bad generic function name: ~S" name)) + `(define ,name (make-extended-generic ,val ',name))) + +(define-macro (define-extended-generics names . args) + (let ((prefixes (get-keyword #:prefix args #f))) + (if prefixes + `(begin + ,@(map (lambda (name) + `(define-extended-generic ,name + (list ,@(map (lambda (prefix) + (symbol-append prefix name)) + prefixes)))) + names)) + (goops-error "no prefixes supplied")))) + +(define (make-generic . name) + (let ((name (and (pair? name) (car 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))) + (gws? (any (lambda (gf) (is-a? gf <generic-with-setter>)) gfs))) + (let ((ans (if gws? + (let* ((sname (and name (make-setter-name name))) + (setters + (append-map (lambda (gf) + (if (is-a? gf <generic-with-setter>) + (list (ensure-generic (setter gf) + sname)) + '())) + gfs)) + (es (make <extended-generic-with-setter> + #:name name + #:extends gfs + #:setter (make <extended-generic> + #:name sname + #:extends setters)))) + (extended-by! setters (setter es)) + es) + (make <extended-generic> + #:name name + #:extends gfs)))) + (extended-by! gfs ans) + ans))) + +(define (extended-by! gfs eg) + (for-each (lambda (gf) + (slot-set! gf 'extended-by + (cons eg (slot-ref gf 'extended-by)))) + gfs)) + +(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))))) + +;; 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 (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 (upgrade-accessor generic setter) + (let ((methods (slot-ref generic 'methods)) + (gws (make (if (is-a? generic <extended-generic>) + <extended-generic-with-setter> + <accessor>) + #:name (generic-function-name generic) + #:extended-by (slot-ref generic 'extended-by) + #:setter setter))) + (if (is-a? generic <extended-generic>) + (let ((gfs (slot-ref generic 'extends))) + (not-extended-by! gfs generic) + (slot-set! gws 'extends gfs) + (extended-by! gfs gws))) + ;; Steal old methods + (for-each (lambda (method) + (slot-set! method 'generic-function gws)) + methods) + (slot-set! gws 'methods methods) + gws)) + +;;; +;;; {Methods} +;;; + +(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? (syntax f)) (identifier? (syntax s))) + (lp (syntax rest) + (cons (syntax f) formals) + (cons (syntax s) specializers))) + ((f . rest) + (identifier? (syntax f)) + (lp (syntax rest) + (cons (syntax f) formals) + (cons (syntax <top>) specializers))) + (() + (list (reverse formals) + (reverse (cons (syntax '()) specializers)))) + (tail + (identifier? (syntax tail)) + (list (append (reverse formals) (syntax tail)) + (reverse (cons (syntax <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))) + (x + (identifier? (syntax x)) + (let ((id (datum->syntax (syntax x) referent))) + (and (free-identifier=? (syntax x) id) id))) + (_ #f))) + + (define (compute-procedure formals body) + (syntax-case body () + ((body0 ...) + (with-syntax ((formals formals)) + (syntax (lambda formals body0 ...)))))) + + (define (->proper args) + (let lp ((ls args) (out '())) + (syntax-case ls () + ((x . xs) (lp (syntax xs) (cons (syntax x) out))) + (() (reverse out)) + (tail (reverse (cons (syntax tail) out)))))) + + (define (compute-make-procedure formals body next-method) + (syntax-case body () + ((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 ...))))) + (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 ...))))))))))) + + (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 (syntax #f) + (compute-make-procedure formals body id)) + (values (compute-procedure formals body) + (syntax #f))))) + + (syntax-case x () + ((_ args) (syntax (method args (if #f #f)))) + ((_ args body0 body1 ...) + (with-syntax (((formals (specializer ...)) (parse-args (syntax args)))) + (call-with-values + (lambda () + (compute-procedures (syntax formals) (syntax (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)))))))))) + +;;; +;;; {add-method!} +;;; + +(define (add-method-in-classes! m) + ;; Add method in all the classes which appears in its specializers list + (for-each* (lambda (x) + (let ((dm (class-direct-methods x))) + (if (not (memq m dm)) + (slot-set! x 'direct-methods (cons m dm))))) + (method-specializers m))) + +(define (remove-method-in-classes! m) + ;; Remove method in all the classes which appears in its specializers list + (for-each* (lambda (x) + (slot-set! x + 'direct-methods + (delv! m (class-direct-methods x)))) + (method-specializers m))) + +(define (compute-new-list-of-methods gf new) + (let ((new-spec (method-specializers new)) + (methods (slot-ref gf 'methods))) + (let loop ((l methods)) + (if (null? l) + (cons new methods) + (if (equal? (method-specializers (car l)) new-spec) + (begin + ;; This spec. list already exists. Remove old method from dependents + (remove-method-in-classes! (car l)) + (set-car! l new) + methods) + (loop (cdr l))))))) + +(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) + (add-method-in-classes! m) + *unspecified*)) + +(define-generic add-method!) + +((method-procedure internal-add-method!) add-method! internal-add-method!) + +(define-method (add-method! (proc <procedure>) (m <method>)) + (if (generic-capability? proc) + (begin + (enable-primitive-generic! proc) + (add-method! proc m)) + (next-method))) + +(define-method (add-method! (pg <primitive-generic>) (m <method>)) + (add-method! (primitive-generic-generic pg) m)) + +(define-method (add-method! obj (m <method>)) + (goops-error "~S is not a valid generic function" obj)) + +;;; +;;; {Access to meta objects} +;;; + +;;; +;;; Methods +;;; +(define-method (method-source (m <method>)) + (let* ((spec (map* class-name (slot-ref m 'specializers))) + (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-definition-name car) + +(define slot-definition-options cdr) + +(define (slot-definition-allocation s) + (get-keyword #:allocation (cdr s) #:instance)) + +(define (slot-definition-getter s) + (get-keyword #:getter (cdr s) #f)) + +(define (slot-definition-setter s) + (get-keyword #:setter (cdr s) #f)) + +(define (slot-definition-accessor s) + (get-keyword #:accessor (cdr s) #f)) + +(define (slot-definition-init-value s) + ;; can be #f, so we can't use #f as non-value + (get-keyword #:init-value (cdr s) (make-unbound))) + +(define (slot-definition-init-form s) + (get-keyword #:init-form (cdr s) (make-unbound))) + +(define (slot-definition-init-thunk s) + (get-keyword #:init-thunk (cdr s) #f)) + +(define (slot-definition-init-keyword s) + (get-keyword #:init-keyword (cdr s) #f)) + +(define (class-slot-definition class slot-name) + (assq slot-name (class-slots class))) + +(define (slot-init-function class slot-name) + (cadr (assq slot-name (slot-ref class 'getters-n-setters)))) + + +;;; +;;; {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)) + +;;; +;;; methods to display/write an object +;;; + +; Code for writing objects must test that the slots they use are +; bound. Otherwise a slot-unbound method will be called and will +; conduct to an infinite loop. + +;; Write +(define (display-address o file) + (display (number->string (object-address o) 16) file)) + +(define-method (write o file) + (display "#<instance " file) + (display-address o file) + (display #\> file)) + +(define write-object (primitive-generic-generic write)) + +(define-method (write (o <object>) file) + (let ((class (class-of o))) + (if (slot-bound? class 'name) + (begin + (display "#<" file) + (display (class-name class) file) + (display #\space file) + (display-address o file) + (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-bound? meta 'name)) + (begin + (display "#<" file) + (display (class-name meta) file) + (display #\space file) + (display (class-name class) file) + (display #\space file) + (display-address class file) + (display #\> file)) + (next-method)))) + +(define-method (write (gf <generic>) file) + (let ((meta (class-of gf))) + (if (and (slot-bound? meta 'name) + (slot-bound? gf 'methods)) + (begin + (display "#<" file) + (display (class-name meta) file) + (let ((name (generic-function-name gf))) + (if name + (begin + (display #\space file) + (display name file)))) + (display " (" file) + (display (length (generic-function-methods gf)) file) + (display ")>" file)) + (next-method)))) + +(define-method (write (o <method>) file) + (let ((meta (class-of o))) + (if (and (slot-bound? meta 'name) + (slot-bound? o 'specializers)) + (begin + (display "#<" file) + (display (class-name meta) file) + (display #\space file) + (display (map* (lambda (spec) + (if (slot-bound? spec 'name) + (slot-ref spec 'name) + spec)) + (method-specializers o)) + file) + (display #\space file) + (display-address o file) + (display #\> file)) + (next-method)))) + +;; Display (do the same thing as write by default) +(define-method (display o file) + (write-object o file)) + +;;; +;;; Handling of duplicate bindings in the module system +;;; + +(define-method (merge-generics (module <module>) + (name <symbol>) + (int1 <module>) + (val1 <top>) + (int2 <module>) + (val2 <top>) + (var <top>) + (val <top>)) + #f) + +(define-method (merge-generics (module <module>) + (name <symbol>) + (int1 <module>) + (val1 <generic>) + (int2 <module>) + (val2 <generic>) + (var <top>) + (val <boolean>)) + (and (not (eq? val1 val2)) + (make-variable (make-extended-generic (list val2 val1) name)))) + +(define-method (merge-generics (module <module>) + (name <symbol>) + (int1 <module>) + (val1 <generic>) + (int2 <module>) + (val2 <generic>) + (var <top>) + (gf <extended-generic>)) + (and (not (memq val2 (slot-ref gf 'extends))) + (begin + (slot-set! gf + 'extends + (cons val2 (delq! val2 (slot-ref gf 'extends)))) + (slot-set! val2 + 'extended-by + (cons gf (delq! gf (slot-ref val2 'extended-by)))) + var))) + +(module-define! duplicate-handlers 'merge-generics merge-generics) + +(define-method (merge-accessors (module <module>) + (name <symbol>) + (int1 <module>) + (val1 <top>) + (int2 <module>) + (val2 <top>) + (var <top>) + (val <top>)) + #f) + +(define-method (merge-accessors (module <module>) + (name <symbol>) + (int1 <module>) + (val1 <accessor>) + (int2 <module>) + (val2 <accessor>) + (var <top>) + (val <top>)) + (merge-generics module name int1 val1 int2 val2 var val)) + +(module-define! duplicate-handlers 'merge-accessors merge-accessors) + +;;; +;;; slot access +;;; + +(define (class-slot-g-n-s class slot-name) + (let* ((this-slot (assq slot-name (slot-ref class 'slots))) + (g-n-s (cddr (or (assq slot-name (slot-ref class 'getters-n-setters)) + (slot-missing class slot-name))))) + (if (not (memq (slot-definition-allocation this-slot) + '(#:class #:each-subclass))) + (slot-missing class slot-name)) + g-n-s)) + +(define (class-slot-ref class slot) + (let ((x ((car (class-slot-g-n-s class slot)) #f))) + (if (unbound? x) + (slot-unbound class slot) + x))) + +(define (class-slot-set! class slot value) + ((cadr (class-slot-g-n-s class slot)) #f value)) + +(define-method (slot-unbound (c <class>) (o <object>) s) + (goops-error "Slot `~S' is unbound in object ~S" s o)) + +(define-method (slot-unbound (c <class>) s) + (goops-error "Slot `~S' is unbound in class ~S" s c)) + +(define-method (slot-unbound (o <object>)) + (goops-error "Unbound slot in object ~S" o)) + +(define-method (slot-missing (c <class>) (o <object>) s) + (goops-error "No slot with name `~S' in object ~S" s o)) + +(define-method (slot-missing (c <class>) s) + (goops-error "No class slot with name `~S' in class ~S" s c)) + + +(define-method (slot-missing (c <class>) (o <object>) s value) + (slot-missing c o s)) + +;;; Methods for the possible error we can encounter when calling a gf + +(define-method (no-next-method (gf <generic>) args) + (goops-error "No next method when calling ~S\nwith arguments ~S" gf args)) + +(define-method (no-applicable-method (gf <generic>) args) + (goops-error "No applicable method for ~S in call ~S" + gf (cons (generic-function-name gf) args))) + +(define-method (no-method (gf <generic>) args) + (goops-error "No method defined for ~S" gf)) + +;;; +;;; {Cloning functions (from rdeline@CS.CMU.EDU)} +;;; + +(define-method (shallow-clone (self <object>)) + (let ((clone (%allocate-instance (class-of self) '())) + (slots (map slot-definition-name + (class-slots (class-of self))))) + (for-each (lambda (slot) + (if (slot-bound? self slot) + (slot-set! clone slot (slot-ref self slot)))) + slots) + clone)) + +(define-method (deep-clone (self <object>)) + (let ((clone (%allocate-instance (class-of self) '())) + (slots (map slot-definition-name + (class-slots (class-of self))))) + (for-each (lambda (slot) + (if (slot-bound? self slot) + (slot-set! clone slot + (let ((value (slot-ref self slot))) + (if (instance? value) + (deep-clone value) + value))))) + slots) + clone)) + +;;; +;;; {Class redefinition utilities} +;;; + +;;; (class-redefinition OLD NEW) +;;; + +;;; Has correct the following conditions: + +;;; Methods +;;; +;;; 1. New accessor specializers refer to new header +;;; +;;; Classes +;;; +;;; 1. New class cpl refers to the new class header +;;; 2. Old class header exists on old super classes direct-subclass lists +;;; 3. New class header exists on new super classes direct-subclass lists + +(define-method (class-redefinition (old <class>) (new <class>)) + ;; Work on direct methods: + ;; 1. Remove accessor methods from the old class + ;; 2. Patch the occurences of new in the specializers by old + ;; 3. Displace the methods from old to new + (remove-class-accessors! old) ;; -1- + (let ((methods (class-direct-methods new))) + (for-each (lambda (m) + (update-direct-method! m new old)) ;; -2- + methods) + (slot-set! new + 'direct-methods + (append methods (class-direct-methods old)))) + + ;; Substitute old for new in new cpl + (set-car! (slot-ref new 'cpl) old) + + ;; Remove the old class from the direct-subclasses list of its super classes + (for-each (lambda (c) (slot-set! c 'direct-subclasses + (delv! old (class-direct-subclasses c)))) + (class-direct-supers old)) + + ;; Replace the new class with the old in the direct-subclasses of the supers + (for-each (lambda (c) + (slot-set! c 'direct-subclasses + (cons old (delv! new (class-direct-subclasses c))))) + (class-direct-supers new)) + + ;; Swap object headers + (%modify-class old new) + + ;; Now old is NEW! + + ;; Redefine all the subclasses of old to take into account modification + (for-each + (lambda (c) + (update-direct-subclass! c new old)) + (class-direct-subclasses new)) + + ;; Invalidate class so that subsequent instances slot accesses invoke + ;; change-object-class + (slot-set! new 'redefined old) + (%invalidate-class new) ;must come after slot-set! + + old) + +;;; +;;; remove-class-accessors! +;;; + +(define-method (remove-class-accessors! (c <class>)) + (for-each (lambda (m) + (if (is-a? m <accessor-method>) + (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))) + +;;; +;;; update-direct-method! +;;; + +(define-method (update-direct-method! (m <method>) + (old <class>) + (new <class>)) + (let loop ((l (method-specializers m))) + ;; Note: the <top> in dotted list is never used. + ;; So we can work as if we had only proper lists. + (if (pair? l) + (begin + (if (eqv? (car l) old) + (set-car! l new)) + (loop (cdr l)))))) + +;;; +;;; update-direct-subclass! +;;; + +(define-method (update-direct-subclass! (c <class>) + (old <class>) + (new <class>)) + (class-redefinition c + (make-class (class-direct-supers c) + (class-direct-slots c) + #:name (class-name c) + #:environment (slot-ref c 'environment) + #:metaclass (class-of c)))) + +;;; +;;; {Utilities for INITIALIZE methods} +;;; + +;;; compute-slot-accessors +;;; +(define (compute-slot-accessors class slots env) + (for-each + (lambda (s g-n-s) + (let ((name (slot-definition-name s)) + (getter-function (slot-definition-getter s)) + (setter-function (slot-definition-setter s)) + (accessor (slot-definition-accessor s))) + (if getter-function + (add-method! getter-function + (compute-getter-method class g-n-s))) + (if setter-function + (add-method! setter-function + (compute-setter-method class g-n-s))) + (if accessor + (begin + (add-method! accessor + (compute-getter-method class g-n-s)) + (add-method! (setter accessor) + (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))) + (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))) + (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))) + +(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))))) + +;; the idea is to compile the index into the procedure, for fastest +;; lookup. Also, @slot-ref and @slot-set! have their own bytecodes. + +(eval-when (compile) + (use-modules ((language tree-il primitives) :select (add-interesting-primitive!))) + (add-interesting-primitive! '@slot-ref) + (add-interesting-primitive! '@slot-set!)) + +(eval-when (eval load compile) + (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) '@slot-ref) + `(,(car form) ,(cadr form) ,x)) + ((eq? (car form) '@slot-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 (@slot-ref o n))) + (if (unbound? x) + (slot-unbound obj) + x))) + +(define-standard-accessor-method ((standard-get n) o) + (@slot-ref o n)) + +(define-standard-accessor-method ((standard-set n) o v) + (@slot-set! o n v)) + +;;; compute-getters-n-setters +;;; +(define (make-thunk thunk) + (lambda () (thunk))) + +(define (compute-getters-n-setters class slots env) + + (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) + (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))) + ;; 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 (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)))))) + + (map (lambda (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))) + ;; 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 name s) + (if (or (integer? g-n-s) + (zero? size)) + g-n-s + (append g-n-s (list index size))))))) + slots)) + +;;; compute-cpl +;;; +;;; Correct behaviour: +;;; +;;; (define-class food ()) +;;; (define-class fruit (food)) +;;; (define-class spice (food)) +;;; (define-class apple (fruit)) +;;; (define-class cinnamon (spice)) +;;; (define-class pie (apple cinnamon)) +;;; => cpl (pie) = pie apple fruit cinnamon spice food object top +;;; +;;; (define-class d ()) +;;; (define-class e ()) +;;; (define-class f ()) +;;; (define-class b (d e)) +;;; (define-class c (e f)) +;;; (define-class a (b c)) +;;; => cpl (a) = a b d c e f object top +;;; + +(define-method (compute-cpl (class <class>)) + (compute-std-cpl class class-direct-supers)) + +;; Support + +(define (only-non-null lst) + (filter (lambda (l) (not (null? l))) lst)) + +(define (compute-std-cpl c get-direct-supers) + (let ((c-direct-supers (get-direct-supers c))) + (merge-lists (list c) + (only-non-null (append (map class-precedence-list + c-direct-supers) + (list c-direct-supers)))))) + +(define (merge-lists reversed-partial-result inputs) + (cond + ((every null? inputs) + (reverse! reversed-partial-result)) + (else + (let* ((candidate (lambda (c) + (and (not (any (lambda (l) + (memq c (cdr l))) + inputs)) + c))) + (candidate-car (lambda (l) + (and (not (null? l)) + (candidate (car l))))) + (next (any candidate-car inputs))) + (if (not next) + (goops-error "merge-lists: Inconsistent precedence graph")) + (let ((remove-next (lambda (l) + (if (eq? (car l) next) + (cdr l) + l)))) + (merge-lists (cons next reversed-partial-result) + (only-non-null (map remove-next inputs)))))))) + +;; Modified from TinyClos: +;; +;; A simple topological sort. +;; +;; It's in this file so that both TinyClos and Objects can use it. +;; +;; This is a fairly modified version of code I originally got from Anurag +;; Mendhekar <anurag@moose.cs.indiana.edu>. +;; + +(define (compute-clos-cpl c get-direct-supers) + (top-sort ((build-transitive-closure get-direct-supers) c) + ((build-constraints get-direct-supers) c) + (std-tie-breaker get-direct-supers))) + + +(define (top-sort elements constraints tie-breaker) + (let loop ((elements elements) + (constraints constraints) + (result '())) + (if (null? elements) + result + (let ((can-go-in-now + (filter + (lambda (x) + (every (lambda (constraint) + (or (not (eq? (cadr constraint) x)) + (memq (car constraint) result))) + constraints)) + elements))) + (if (null? can-go-in-now) + (goops-error "top-sort: Invalid constraints") + (let ((choice (if (null? (cdr can-go-in-now)) + (car can-go-in-now) + (tie-breaker result + can-go-in-now)))) + (loop + (filter (lambda (x) (not (eq? x choice))) + elements) + constraints + (append result (list choice))))))))) + +(define (std-tie-breaker get-supers) + (lambda (partial-cpl min-elts) + (let loop ((pcpl (reverse partial-cpl))) + (let ((current-elt (car pcpl))) + (let ((ds-of-ce (get-supers current-elt))) + (let ((common (filter (lambda (x) + (memq x ds-of-ce)) + min-elts))) + (if (null? common) + (if (null? (cdr pcpl)) + (goops-error "std-tie-breaker: Nothing valid") + (loop (cdr pcpl))) + (car common)))))))) + + +(define (build-transitive-closure get-follow-ons) + (lambda (x) + (let track ((result '()) + (pending (list x))) + (if (null? pending) + result + (let ((next (car pending))) + (if (memq next result) + (track result (cdr pending)) + (track (cons next result) + (append (get-follow-ons next) + (cdr pending))))))))) + +(define (build-constraints get-follow-ons) + (lambda (x) + (let loop ((elements ((build-transitive-closure get-follow-ons) x)) + (this-one '()) + (result '())) + (if (or (null? this-one) (null? (cdr this-one))) + (if (null? elements) + result + (loop (cdr elements) + (cons (car elements) + (get-follow-ons (car elements))) + result)) + (loop elements + (cdr this-one) + (cons (list (car this-one) (cadr this-one)) + result)))))) + +;;; compute-get-n-set +;;; +(define-method (compute-get-n-set (class <class>) s) + (case (slot-definition-allocation s) + ((#:instance) ;; Instance slot + ;; get-n-set is just its offset + (let ((already-allocated (slot-ref class 'nfields))) + (slot-set! class 'nfields (+ already-allocated 1)) + already-allocated)) + + ((#:class) ;; Class slot + ;; Class-slots accessors are implemented as 2 closures around + ;; a Scheme variable. As instance slots, class slots must be + ;; unbound at init time. + (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) + ;; 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)))) + (if r + (cddr r) + (loop (cdr l)))))))) + + ((#:each-subclass) ;; slot shared by instances of direct subclass. + ;; (Thomas Buerger, April 1998) + (make-closure-variable class)) + + ((#: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))) + (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-method (compute-get-n-set (o <object>) s) + (goops-error "Allocation \"~S\" is unknown" (slot-definition-allocation s))) + +(define-method (compute-slots (class <class>)) + (%compute-slots class)) + +;;; +;;; {Initialize} +;;; + +(define-method (initialize (object <object>) initargs) + (%initialize-object object initargs)) + +(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)))) + + (slot-set! class 'name (get-keyword #:name initargs '???)) + (slot-set! class 'direct-supers supers) + (slot-set! class 'direct-slots dslots) + (slot-set! class 'direct-subclasses '()) + (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)) + ;; Build getters - setters - accessors + (compute-slot-accessors class slots env)) + + ;; Update the "direct-subclasses" of each inherited classes + (for-each (lambda (x) + (slot-set! x + 'direct-subclasses + (cons class (slot-ref x 'direct-subclasses)))) + supers) + + ;; 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))) + +(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)) + (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)) + +(define-method (initialize (ews <entity-with-setter>) initargs) + (next-method) + (%set-object-setter! ews (get-keyword #:setter initargs #f))) + +(define-method (initialize (generic <generic>) initargs) + (let ((previous-definition (get-keyword #:default initargs #f)) + (name (get-keyword #:name initargs #f))) + (next-method) + (slot-set! generic 'methods (if (is-a? previous-definition <procedure>) + (list (method args + (apply previous-definition args))) + '())) + (if name + (set-procedure-property! generic 'name name)) + )) + +(define-method (initialize (eg <extended-generic>) initargs) + (next-method) + (slot-set! eg 'extends (get-keyword #:extends initargs '()))) + +(define dummy-procedure (lambda args *unspecified*)) + +(define-method (initialize (method <method>) initargs) + (next-method) + (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 #f)) + (slot-set! method 'code-table '()) + (slot-set! method 'formals (get-keyword #:formals initargs '())) + (slot-set! method 'body (get-keyword #:body initargs '())) + (slot-set! method 'make-procedure (get-keyword #:make-procedure initargs #f))) + + +(define-method (initialize (obj <foreign-object>) initargs)) + +;;; +;;; {Change-class} +;;; + +(define (change-object-class old-instance old-class new-class) + (let ((new-instance (allocate-instance new-class '()))) + ;; 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 + (class-slot-definition old-class slot)) + #:instance) + (slot-bound-using-class? old-class old-instance slot)) + ;; Slot was present and allocated in old instance; copy it + (slot-set-using-class! + new-class + new-instance + slot + (slot-ref-using-class old-class old-instance slot)) + ;; slot was absent; initialize it with its default value + (let ((init (slot-init-function new-class slot))) + (if init + (slot-set-using-class! + new-class + new-instance + slot + (apply init '())))))) + (map slot-definition-name (class-slots new-class))) + ;; Exchange old and new instance in place to keep pointers valid + (%modify-instance old-instance new-instance) + ;; Allow class specific updates of instances (which now are swapped) + (update-instance-for-different-class new-instance old-instance) + old-instance)) + + +(define-method (update-instance-for-different-class (old-instance <object>) + (new-instance + <object>)) + ;;not really important what we do, we just need a default method + new-instance) + +(define-method (change-class (old-instance <object>) (new-class <class>)) + (change-object-class old-instance (class-of old-instance) new-class)) + +;;; +;;; {make} +;;; +;;; A new definition which overwrites the previous one which was built-in +;;; + +(define-method (allocate-instance (class <class>) initargs) + (%allocate-instance class initargs)) + +(define-method (make-instance (class <class>) . initargs) + (let ((instance (allocate-instance class initargs))) + (initialize instance initargs) + instance)) + +(define make make-instance) + +;;; +;;; {apply-generic} +;;; +;;; Protocol for calling standard generic functions. This protocol is +;;; not used for real <generic> functions (in this case we use a +;;; completely C hard-coded protocol). Apply-generic is used by +;;; goops for calls to subclasses of <generic> and <generic-with-setter>. +;;; The code below is similar to the first MOP described in AMOP. In +;;; particular, it doesn't used the currified approach to gf +;;; call. There are 2 reasons for that: +;;; - the protocol below is exposed to mimic completely the one written in C +;;; - the currified protocol would be imho inefficient in C. +;;; + +(define-method (apply-generic (gf <generic>) args) + (if (null? (slot-ref gf 'methods)) + (no-method gf args)) + (let ((methods (compute-applicable-methods gf args))) + (if methods + (apply-methods gf (sort-applicable-methods gf methods args) args) + (no-applicable-method gf args)))) + +;; compute-applicable-methods is bound to %compute-applicable-methods. +;; *fixme* use let +(define %%compute-applicable-methods + (make <generic> #:name 'compute-applicable-methods)) + +(define-method (%%compute-applicable-methods (gf <generic>) args) + (%compute-applicable-methods gf args)) + +(set! compute-applicable-methods %%compute-applicable-methods) + +(define-method (sort-applicable-methods (gf <generic>) methods args) + (let ((targs (map class-of args))) + (sort methods (lambda (m1 m2) (method-more-specific? m1 m2 targs))))) + +(define-method (method-more-specific? (m1 <method>) (m2 <method>) targs) + (%method-more-specific? m1 m2 targs)) + +(define-method (apply-method (gf <generic>) methods build-next args) + (apply (method-procedure (car methods)) + (build-next (cdr methods) args) + args)) + +(define-method (apply-methods (gf <generic>) (l <list>) args) + (letrec ((next (lambda (procs args) + (lambda new-args + (let ((a (if (null? new-args) args new-args))) + (if (null? procs) + (no-next-method gf a) + (apply-method gf procs next a))))))) + (apply-method gf l next args))) + +;; We don't want the following procedure to turn up in backtraces: +(for-each (lambda (proc) + (set-procedure-property! proc 'system-procedure #t)) + (list slot-unbound + slot-missing + no-next-method + no-applicable-method + no-method + )) + +;;; +;;; {<composite-metaclass> and <active-metaclass>} +;;; + +;(autoload "active-slot" <active-metaclass>) +;(autoload "composite-slot" <composite-metaclass>) +;(export <composite-metaclass> <active-metaclass>) + +;;; +;;; {Tools} +;;; + +;; list2set +;; +;; duplicate the standard list->set function but using eq instead of +;; eqv which really sucks a lot, uselessly here +;; +(define (list2set l) + (let loop ((l l) + (res '())) + (cond + ((null? l) res) + ((memq (car l) res) (loop (cdr l) res)) + (else (loop (cdr l) (cons (car l) res)))))) + +(define (class-subclasses c) + (letrec ((allsubs (lambda (c) + (cons c (mapappend allsubs + (class-direct-subclasses c)))))) + (list2set (cdr (allsubs c))))) + +(define (class-methods c) + (list2set (mapappend class-direct-methods + (cons c (class-subclasses c))))) + +;;; +;;; {Final initialization} +;;; + +;; Tell C code that the main bulk of Goops has been loaded +(%goops-loaded) |