+2000-10-25 Mikael Djurfeldt <mdj@linnaeus.mit.edu>
+
+ * GUILE-VERSION (LIBGUILE_MAJOR_VERSION): Incremented major
+ version number to 10 due to the merge of GOOPS.
+
+ * oop: New directory.
+
2000-09-20 Keisuke Nishida <kxn30@po.cwru.edu>
* libguile.h: #include "libguile/properties.h".
## to the Free Software Foundation, Inc., 59 Temple Place, Suite
## 330, Boston, MA 02111-1307 USA
-SUBDIRS = ice-9 qt libltdl libguile guile-config guile-readline doc
+SUBDIRS = ice-9 oop qt libltdl libguile guile-config guile-readline doc
include_HEADERS = libguile.h
* Changes to the distribution
+** New modules (oop goops) etc
+
+The new modules
+
+ (oop goops)
+ (oop goops describe)
+ (oop goops save)
+ (oop goops active-slot)
+ (oop goops composite-slot)
+
+plus some GOOPS utility modules have been added.
+
* Changes to the stand-alone interpreter
+** GOOPS has been merged into Guile
+
+The Guile Object Oriented Programming System has been integrated into
+Guile.
+
+Type
+
+ (use-modules (oop goops))
+
+access GOOPS bindings.
+
+We're now ready to try some basic GOOPS functionality.
+
+Generic functions
+
+ (define-method (+ (x <string>) (y <string>))
+ (string-append x y))
+
+ (+ 1 2) --> 3
+ (+ "abc" "de") --> "abcde"
+
+User-defined types
+
+ (define-class <2D-vector> ()
+ (x #:init-value 0 #:accessor x-component #:init-keyword #:x)
+ (y #:init-value 0 #:accessor y-component #:init-keyword #:y))
+
+ (define-method write ((obj <2D-vector>) port)
+ (display (format #f "<~S, ~S>" (x-component obj) (y-component obj))
+ port))
+
+ (define v (make <2D-vector> #:x 3 #:y 4))
+ v --> <3, 4>
+
+ (define-method + ((x <2D-vector>) (y <2D-vector>))
+ (make <2D-vector>
+ #:x (+ (x-component x) (x-component y))
+ #:y (+ (y-component x) (y-component y))))
+
+ (+ v v) --> <6, 8>
+
+Asking for the type of an object
+
+ (class-of v) --> #<<class> <2D-vector> 40241ac0>
+ <2D-vector> --> #<<class> <2D-vector> 40241ac0>
+ (class-of 1) --> #<<class> <integer> 401b2a98>
+ <integer> --> #<<class> <integer> 401b2a98>
+
+ (is-a? v <2D-vector>) --> #t
+
+See further in the GOOPS tutorial available in the guile-doc
+distribution in info (goops.info) and texinfo formats.
+
** It's now possible to create modules with controlled environments
Example:
AC_SUBST(LIBLOBJS)
AC_SUBST(EXTRA_DOT_DOC_FILES)
-AC_OUTPUT([Makefile libguile/Makefile libguile/guile-snarf libguile/guile-doc-snarf libguile/guile-func-name-check libguile/guile-snarf.awk libguile/versiondat.h ice-9/Makefile qt/Makefile qt/qt.h qt/md/Makefile qt/time/Makefile guile-config/Makefile doc/Makefile], [chmod +x libguile/guile-snarf libguile/guile-doc-snarf libguile/guile-func-name-check])
+AC_OUTPUT([Makefile libguile/Makefile libguile/guile-snarf libguile/guile-doc-snarf libguile/guile-func-name-check libguile/guile-snarf.awk libguile/versiondat.h ice-9/Makefile oop/Makefile oop/goops/Makefile qt/Makefile qt/qt.h qt/md/Makefile qt/time/Makefile guile-config/Makefile doc/Makefile], [chmod +x libguile/guile-snarf libguile/guile-doc-snarf libguile/guile-func-name-check])
dnl Local Variables:
dnl comment-start: "dnl "
#include "libguile/fports.h"
#include "libguile/gc.h"
#include "libguile/gdbint.h"
+#include "libguile/goops.h"
#include "libguile/gsubr.h"
#include "libguile/guardians.h"
#include "libguile/hash.h"
+2000-10-25 Mikael Djurfeldt <mdj@linnaeus.mit.edu>
+
+ This change merges the GOOPS code into Guile. However, GOOPS
+ is still not initialized until someone asks for the module.
+ We need to optimize GOOPS initialization time before initializing
+ it together with the rest of libguile. We also need to add the
+ C API + primitive methods. Then we can start using it to
+ modularize Guile, implement a real exception system etc.
+
+ * goops.c, objects.c, objects.h, eval.c (scm_make_extended_class,
+ scm_make_port_classes, scm_change_object_class,
+ scm_memoize_method): Changed to ordinary functions (was plugin
+ slots).
+
+ * goops.c (wrap_init, scm_wrap_object): Unconditionally use
+ SCM_STRUCT_GC_CHAIN.
+ (scm_goops_version): Removed.
+ (scm_oldfmt): and all uses of it: Removed.
+ (scm_shared_array_root, scm_shared_array_offset,
+ scm_shared_array_increments): Removed.
+ (scm_init_goops): No need to support two arg mutex init.
+ Removed #include "versiondat.h", #include "goops.h".
+
+ * goops.h: Removed various superfluous conditions.
+
+ * init.c (scm_init_guile_1): Call the goops module registration
+ function.
+ Added #include "libguile/goops.h".
+
+ * Makefile.am (libguile_la_SOURCES): Added goops.c
+ (DOT_X_FILES): Added goops.x
+ (DOT_DOC_FILES): Added goops.doc
+ (modinclude_HEADERS): Added goops.h
+
2000-10-25 Dirk Herrmann <D.Herrmann@tu-bs.de>
* gc.c (scm_igc): Remove references to scm_vector_set_length_x.
* validated.h (SCM_VALIDATE_STRINGORSUBSTR): Deprecated.
+>>>>>>> 1.1152
2000-10-20 Marius Vollmer <mvo@zagadka.ping.de>
* init.c (scm_init_guile_1, invoke_main_func): Call
--- /dev/null
+2000-10-23 Mikael Djurfeldt <mdj@linnaeus.mit.edu>
+
+ * goops.scm (goops-error): Removed use of oldfmt.
+
--- /dev/null
+## Process this file with automake to produce Makefile.in.
+##
+## Copyright (C) 2000 Free Software Foundation, Inc.
+##
+## This file is part of GUILE.
+##
+## GUILE is free software; you can redistribute it and/or modify
+## it under the terms of the GNU General Public License as
+## published by the Free Software Foundation; either version 2, or
+## (at your option) any later version.
+##
+## GUILE is distributed in the hope that it will be useful, but
+## WITHOUT ANY WARRANTY; without even the implied warranty of
+## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+## GNU General Public License for more details.
+##
+## You should have received a copy of the GNU General Public
+## License along with GUILE; see the file COPYING. If not, write
+## to the Free Software Foundation, Inc., 59 Temple Place, Suite
+## 330, Boston, MA 02111-1307 USA
+
+AUTOMAKE_OPTIONS = foreign
+
+SUBDIRS = goops
+
+# These should be installed and distributed.
+oop_sources = goops.scm
+
+subpkgdatadir = $(pkgdatadir)/$(VERSION)/oop
+subpkgdata_DATA = $(oop_sources)
+ETAGS_ARGS = $(subpkgdata_DATA)
+
+EXTRA_DIST = $(oop_sources)
--- /dev/null
+;;; installed-scm-file
+
+;;;; Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;;; GNU General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+;;;; Boston, MA 02111-1307 USA
+;;;;
+\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>.
+;;;;
+
+(define-module (oop goops)
+ :use-module (oop goops goopscore)
+ :use-module (oop goops util)
+ :use-module (oop goops dispatch)
+ :use-module (oop goops compile)
+ :no-backtrace
+ )
+
+(export ; Define the exported symbols of this file
+ goops-version is-a?
+ ensure-metaclass ensure-metaclass-with-supers
+ define-class class make-class
+ define-generic make-generic ensure-generic
+ define-accessor make-accessor ensure-accessor
+ define-method make-method method add-method!
+ object-eqv? object-equal?
+ 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
+
+(export
+ instance? slot-ref-using-class
+ slot-set-using-class! slot-bound-using-class?
+ slot-exists-using-class? slot-ref slot-set! slot-bound? class-of
+ 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
+ primitive-generic-generic enable-primitive-generic!
+ method-procedure accessor-method-slot-definition
+ slot-exists? make find-method get-keyword
+ %logand)
+
+\f
+(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 (apply 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 (define-class-pre-definition keyword exp env)
+ (case keyword
+ ((#:getter #:setter)
+ (if (defined? exp env)
+ `(define ,exp (ensure-generic ,exp ',exp))
+ `(define ,exp (make-generic ',exp))))
+ ((#:accessor)
+ (if (defined? exp env)
+ `(define ,exp (ensure-accessor ,exp ',exp))
+ `(define ,exp (make-accessor ',exp))))
+ (else #f)))
+
+;;; This code should be implemented in C.
+;;;
+(define define-class
+ (letrec (;; 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 error handling to class macro.
+ ;;
+ (pre-definitions
+ (lambda (slots env)
+ (do ((slots slots (cdr slots))
+ (definitions '()
+ (if (pair? (car slots))
+ (do ((options (cdar slots) (cddr options))
+ (definitions definitions
+ (cond ((not (symbol? (cadr options)))
+ definitions)
+ ((define-class-pre-definition
+ (car options)
+ (cadr options)
+ env)
+ => (lambda (definition)
+ (cons definition definitions)))
+ (else definitions))))
+ ((not (and (pair? options)
+ (pair? (cdr options))))
+ definitions))
+ definitions)))
+ ((or (not (pair? slots))
+ (keyword? (car slots)))
+ (reverse definitions)))))
+
+ ;; Syntax
+ (name cadr)
+ (slots cdddr))
+
+ (procedure->macro
+ (lambda (exp env)
+ (cond ((not (top-level-env? env))
+ (goops-error "define-class: Only allowed at top level"))
+ ((not (and (list? exp) (>= (length exp) 3)))
+ (goops-error "missing or extra expression"))
+ (else
+ (let ((name (name exp)))
+ `(begin
+ ;; define accessors
+ ,@(pre-definitions (slots exp) env)
+
+ ,(if (defined? name env)
+
+ ;; redefine an old class
+ `(define ,name
+ (let ((old ,name)
+ (new (class ,@(cddr exp) #:name ',name)))
+ (if (and (is-a? old <class>)
+ ;; Prevent redefinition of non-objects
+ (memq <object>
+ (class-precedence-list old)))
+ (class-redefinition old new)
+ new)))
+
+ ;; define a new class
+ `(define ,name
+ (class ,@(cddr exp) #:name ',name)))))))))))
+
+(define standard-define-class define-class)
+
+;;; (class (SUPER ...) SLOT-DEFINITION ... OPTION ...)
+;;;
+;;; SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...)
+;;; OPTION ::= KEYWORD VALUE
+;;;
+(define class
+ (letrec ((slot-option-keyword car)
+ (slot-option-value cadr)
+ (process-slot-options
+ (lambda (options)
+ (let loop ((options options)
+ (res '()))
+ (cond ((null? options)
+ (reverse res))
+ ((null? (cdr options))
+ (goops-error "malformed slot option list"))
+ ((not (keyword? (slot-option-keyword options)))
+ (goops-error "malformed slot option list"))
+ (else
+ (case (slot-option-keyword options)
+ ((#:init-form)
+ (loop (cddr options)
+ (append (list `(lambda ()
+ ,(slot-option-value options))
+ #:init-thunk
+ (list 'quote
+ (slot-option-value options))
+ #:init-form)
+ res)))
+ (else
+ (loop (cddr options)
+ (cons (cadr options)
+ (cons (car options)
+ res)))))))))))
+
+ (procedure->memoizing-macro
+ (let ((supers cadr)
+ (slots cddr)
+ (options cdddr))
+ (lambda (exp env)
+ (cond ((not (and (list? exp) (>= (length exp) 2)))
+ (goops-error "missing or extra expression"))
+ ((not (list? (supers exp)))
+ (goops-error "malformed superclass list: ~S" (supers exp)))
+ (else
+ (let ((slot-defs (cons #f '())))
+ (do ((slots (slots exp) (cdr slots))
+ (defs slot-defs (cdr defs)))
+ ((or (null? slots)
+ (keyword? (car slots)))
+ `(make-class
+ ;; evaluate super class variables
+ (list ,@(supers exp))
+ ;; evaluate slot definitions, except the slot name!
+ (list ,@(cdr slot-defs))
+ ;; evaluate class options
+ ,@slots
+ ;; place option last in case someone wants to
+ ;; pass a different value
+ #:environment ',env))
+ (set-cdr!
+ defs
+ (list (if (pair? (car slots))
+ `(list ',(slot-definition-name (car slots))
+ ,@(process-slot-options
+ (slot-definition-options
+ (car slots))))
+ `(list ',(car slots))))))))))))))
+
+(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))))
+
+;;;
+;;; {Generic functions and accessors}
+;;;
+
+(define define-generic
+ (procedure->macro
+ (lambda (exp env)
+ (let ((name (cadr exp)))
+ (cond ((not (symbol? name))
+ (goops-error "bad generic function name: ~S" name))
+ ((defined? name env)
+ `(define ,name
+ (if (is-a? ,name <generic>)
+ (make <generic> #:name ',name)
+ (ensure-generic ,name ',name))))
+ (else
+ `(define ,name (make <generic> #:name ',name))))))))
+
+(define (make-generic . name)
+ (let ((name (and (pair? name) (car name))))
+ (make <generic> #:name name)))
+
+(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)))))
+
+(define define-accessor
+ (procedure->macro
+ (lambda (exp env)
+ (let ((name (cadr exp)))
+ (cond ((not (symbol? name))
+ (goops-error "bad accessor name: ~S" name))
+ ((defined? name env)
+ `(define ,name
+ (if (and (is-a? ,name <generic-with-setter>)
+ (is-a? (setter ,name) <generic>))
+ (make-accessor ',name)
+ (ensure-accessor ,name ',name))))
+ (else
+ `(define ,name (make-accessor ',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 <generic-with-setter>
+ #: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 ((is-a? proc <generic-with-setter>)
+ (if (is-a? (setter proc) <generic>)
+ proc
+ (upgrade-generic-with-setter proc (setter proc))))
+ ((is-a? proc <generic>)
+ (upgrade-generic-with-setter proc (make-generic name)))
+ ((procedure-with-setter? proc)
+ (make <generic-with-setter>
+ #: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-generic-with-setter generic setter)
+ (let ((methods (generic-function-methods generic))
+ (gws (make <generic-with-setter>
+ #:name (generic-function-name generic)
+ #:setter setter)))
+ ;; Steal old methods
+ (for-each (lambda (method)
+ (slot-set! method 'generic-function gws))
+ methods)
+ (slot-set! gws 'methods methods)
+ gws))
+
+;;;
+;;; {Methods}
+;;;
+
+(define define-method
+ (procedure->memoizing-macro
+ (lambda (exp env)
+ (let ((name (cadr exp)))
+ (if (and (pair? name)
+ (eq? (car name) 'setter)
+ (pair? (cdr name))
+ (symbol? (cadr name))
+ (null? (cddr name)))
+ (let ((name (cadr name)))
+ (cond ((not (symbol? name))
+ (goops-error "bad method name: ~S" name))
+ ((defined? name env)
+ `(begin
+ ;; *fixme* Temporary hack for the current module system
+ (if (not ,name)
+ (define-generic ,name))
+ (add-method! (setter ,name) (method ,@(cddr exp)))))
+ (else
+ `(begin
+ (define-accessor ,name)
+ (add-method! (setter ,name) (method ,@(cddr exp)))))))
+ (cond ((pair? name)
+ ;; Convert new syntax to old
+ `(define-method ,(car name) ,(cdr name) ,@(cddr exp)))
+ ((not (symbol? name))
+ (goops-error "bad method name: ~S" name))
+ ((defined? name env)
+ `(begin
+ ;; *fixme* Temporary hack for the current module system
+ (if (not ,name)
+ (define-generic ,name))
+ (add-method! ,name (method ,@(cddr exp)))))
+ (else
+ `(begin
+ (define-generic ,name)
+ (add-method! ,name (method ,@(cddr exp)))))))))))
+
+(define (make-method specializers procedure)
+ (make <method>
+ #:specializers specializers
+ #:procedure procedure))
+
+(define method
+ (letrec ((specializers
+ (lambda (ls)
+ (cond ((null? ls) (list ls))
+ ((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))))
+ (procedure->memoizing-macro
+ (lambda (exp env)
+ (let ((args (cadr exp))
+ (body (cddr exp)))
+ `(make <method>
+ #:specializers (list* ,@(specializers args))
+ #:procedure (lambda ,(formals args)
+ ,@(if (null? body)
+ (list *unspecified*)
+ body))))))))
+
+;;;
+;;; {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 (memv 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 (generic-function-methods gf)))
+ (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! gf m)
+ (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
+ (let ((n-specialized (slot-ref gf 'n-specialized)))
+ ;; The magnitude indicates # specializers.
+ ;; A negative value indicates that at least one
+ ;; method has rest arguments. (Ugly but effective
+ ;; space optimization saving one slot in GF objects.)
+ (cond ((negative? n-specialized)
+ (- (max (+ 1 (length* specializers))
+ (abs n-specialized))))
+ ((list? specializers)
+ (max (length specializers)
+ n-specialized))
+ (else
+ (- (+ 1 (max (length* specializers)
+ n-specialized)))))
+ )))
+ (%invalidate-method-cache! gf)
+ (add-method-in-classes! m)
+ *unspecified*)
+
+(define-generic add-method!)
+
+(internal-add-method! add-method!
+ (make <method>
+ #:specializers (list <generic> <method>)
+ #:procedure 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)))
+ (proc (procedure-source (slot-ref m 'procedure)))
+ (args (cadr proc))
+ (body (cddr proc)))
+ (cons 'method
+ (cons (map* list args spec)
+ body))))
+
+;;;
+;;; 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 object-eqv? (x y) #f)
+(define-method object-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))
+
+;;;
+;;; 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>)
+ (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)
+ (if init-thunk
+ (car 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)))))
+
+(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)))))
+
+(define (make-bound-check-get index)
+ (local-eval `(lambda (o) (@assert-bound-ref o ,index)) (the-environment)))
+
+(define (make-get index)
+ (local-eval `(lambda (o) (@slot-ref o ,index)) (the-environment)))
+
+(define (make-set index)
+ (local-eval `(lambda (o v) (@slot-set! o ,index v)) (the-environment)))
+
+(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))
+
+;;; compute-getters-n-setters
+;;;
+(define (compute-getters-n-setters class slots env)
+
+ (define (compute-slot-init-function s)
+ (or (slot-definition-init-thunk s)
+ (let ((init (slot-definition-init-value s)))
+ (and (not (unbound? init))
+ (lambda () init)))))
+
+ (define (verify-accessors slot l)
+ (if (pair? l)
+ (let ((get (car l))
+ (set (cadr l)))
+ (if (not (and (closure? get)
+ (= (car (procedure-property get 'arity)) 1)))
+ (goops-error "Bad getter closure for slot `~S' in ~S: ~S"
+ slot class get))
+ (if (not (and (closure? set)
+ (= (car (procedure-property set 'arity)) 2)))
+ (goops-error "Bad setter closure for slot `~S' in ~S: ~S"
+ slot class set)))))
+
+ (map (lambda (s)
+ (let* ((g-n-s (compute-get-n-set class s))
+ (name (slot-definition-name s)))
+ ; For each slot we have '(name init-function getter setter)
+ ; If slot, we have the simplest form '(name init-function . index)
+ (verify-accessors name g-n-s)
+ (cons name
+ (cons (compute-slot-init-function s)
+ g-n-s))))
+ 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 object-procedure-tags
+ '(utag_closure utag_subr_1 utag_subr_2 utag_subr3 utag_lsubr_2))
+
+(define (initialize-object-procedure object initargs)
+ (let ((proc (get-keyword #:procedure initargs #f)))
+ (cond ((not proc))
+ ((pair? proc)
+ (apply set-object-procedure! object proc))
+ ((memq (tag proc) object-procedure-tags)
+ (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 (make <method>
+ #:specializers <top>
+ #:procedure
+ (lambda l
+ (apply previous-definition
+ l))))
+ '()))
+ (if name
+ (set-procedure-property! generic 'name name))
+ ))
+
+(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 (lambda l '())))
+ (slot-set! method 'code-table '()))
+
+(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 ())))
+ ;; Initalize the slot 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)
--- /dev/null
+## Process this file with automake to produce Makefile.in.
+##
+## Copyright (C) 2000 Free Software Foundation, Inc.
+##
+## This file is part of GUILE.
+##
+## GUILE is free software; you can redistribute it and/or modify
+## it under the terms of the GNU General Public License as
+## published by the Free Software Foundation; either version 2, or
+## (at your option) any later version.
+##
+## GUILE is distributed in the hope that it will be useful, but
+## WITHOUT ANY WARRANTY; without even the implied warranty of
+## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+## GNU General Public License for more details.
+##
+## You should have received a copy of the GNU General Public
+## License along with GUILE; see the file COPYING. If not, write
+## to the Free Software Foundation, Inc., 59 Temple Place, Suite
+## 330, Boston, MA 02111-1307 USA
+
+AUTOMAKE_OPTIONS = foreign
+
+# These should be installed and distributed.
+goops_sources = \
+ active-slot.scm compile.scm composite-slot.scm describe.scm \
+ dispatch.scm internal.scm save.scm stklos.scm util.scm
+
+subpkgdatadir = $(pkgdatadir)/$(VERSION)/oop/goops
+subpkgdata_DATA = $(goops_sources)
+ETAGS_ARGS = $(subpkgdata_DATA)
+
+EXTRA_DIST = $(goops_sources)
--- /dev/null
+;;; installed-scm-file
+
+;;;; Copyright (C) 1999 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;;; GNU General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+;;;; Boston, MA 02111-1307 USA
+;;;;
+\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 active-slot.stklos from the STk
+;;;; distribution by Erick Gallesio <eg@unice.fr>.
+;;;;
+
+(define-module (oop goops active-slot)
+ :use-module (oop goops internal))
+
+(export <active-class>)
+
+(define-class <active-class> (<class>))
+
+(define-method compute-get-n-set ((class <active-class>) slot)
+ (if (eq? (slot-definition-allocation slot) #:active)
+ (let* ((index (slot-ref class 'nfields))
+ (name (car slot))
+ (s (cdr slot))
+ (env (class-environment class))
+ (before-ref (get-keyword #:before-slot-ref s #f))
+ (after-ref (get-keyword #:after-slot-ref s #f))
+ (before-set! (get-keyword #:before-slot-set! s #f))
+ (after-set! (get-keyword #:after-slot-set! s #f))
+ (unbound (make-unbound)))
+ (slot-set! class 'nfields (+ index 1))
+ (list (lambda (o)
+ (if before-ref
+ (if (before-ref o)
+ (let ((res (%fast-slot-ref o index)))
+ (and after-ref (not (eqv? res unbound)) (after-ref o))
+ res)
+ (make-unbound))
+ (let ((res (%fast-slot-ref o index)))
+ (and after-ref (not (eqv? res unbound)) (after-ref o))
+ res)))
+
+ (lambda (o v)
+ (if before-set!
+ (if (before-set! o v)
+ (begin
+ (%fast-slot-set! o index v)
+ (and after-set! (after-set! o v))))
+ (begin
+ (%fast-slot-set! o index v)
+ (and after-set! (after-set! o v)))))))
+ (next-method)))
--- /dev/null
+;;;; Copyright (C) 1999 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;;; GNU General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+;;;; Boston, MA 02111-1307 USA
+;;;;
+\f
+
+(define-module (oop goops compile)
+ :use-module (oop goops)
+ :use-module (oop goops util)
+ :no-backtrace
+ )
+
+(export compute-cmethod compute-entry-with-cmethod
+ compile-method cmethod-code cmethod-environment)
+
+(define source-formals cadr)
+(define source-body cddr)
+
+(define cmethod-code cdr)
+(define cmethod-environment car)
+
+
+;;;
+;;; Method entries
+;;;
+
+(define code-table-lookup
+ (letrec ((check-entry (lambda (entry types)
+ (if (null? types)
+ (and (not (struct? (car entry)))
+ entry)
+ (and (eq? (car entry) (car types))
+ (check-entry (cdr entry) (cdr types)))))))
+ (lambda (code-table types)
+ (cond ((null? code-table) #f)
+ ((check-entry (car code-table) types)
+ => (lambda (cmethod)
+ (cons (car code-table) cmethod)))
+ (else (code-table-lookup (cdr code-table) types))))))
+
+(define (compute-entry-with-cmethod methods types)
+ (or (code-table-lookup (slot-ref (car methods) 'code-table) types)
+ (let* ((method (car methods))
+ (place-holder (list #f))
+ (entry (append types place-holder)))
+ ;; In order to handle recursion nicely, put the entry
+ ;; into the code-table before compiling the method
+ (slot-set! (car methods) 'code-table
+ (cons entry (slot-ref (car methods) 'code-table)))
+ (let ((cmethod (compile-method methods types)))
+ (set-car! place-holder (car cmethod))
+ (set-cdr! place-holder (cdr cmethod)))
+ (cons entry place-holder))))
+
+(define (compute-cmethod methods types)
+ (cdr (compute-entry-with-cmethod methods types)))
+
+;;;
+;;; Next methods
+;;;
+
+;;; Temporary solution---return #f if x doesn't refer to `next-method'.
+(define (next-method? x)
+ (and (pair? x)
+ (or (eq? (car x) 'next-method)
+ (next-method? (car x))
+ (next-method? (cdr x)))))
+
+(define (make-final-make-next-method method)
+ (lambda default-args
+ (lambda args
+ (@apply method (if (null? args) default-args args)))))
+
+(define (make-final-make-no-next-method gf)
+ (lambda default-args
+ (lambda args
+ (no-next-method gf (if (null? args) default-args args)))))
+
+(define (make-make-next-method vcell gf methods types)
+ (lambda default-args
+ (lambda args
+ (if (null? methods)
+ (begin
+ (set-cdr! vcell (make-final-make-no-next-method gf))
+ (no-next-method gf (if (null? args) default-args args)))
+ (let* ((cmethod (compute-cmethod methods types))
+ (method (local-eval (cons 'lambda (cmethod-code cmethod))
+ (cmethod-environment cmethod))))
+ (set-cdr! vcell (make-final-make-next-method method))
+ (@apply method (if (null? args) default-args args)))))))
+
+;;;
+;;; Method compilation
+;;;
+
+;;; NOTE: This section is far from finished. It will finally be
+;;; implemented on C level.
+
+(define (compile-method methods types)
+ (let* ((proc (method-procedure (car methods)))
+ (src (procedure-source proc))
+ (formals (source-formals src))
+ (body (source-body src)))
+ (if (next-method? body)
+ (let ((vcell (cons 'goops:make-next-method #f)))
+ (set-cdr! vcell
+ (make-make-next-method
+ vcell
+ (method-generic-function (car methods))
+ (cdr methods) types))
+ ;;*fixme*
+ `(,(cons vcell (procedure-environment proc))
+ ,formals
+ ;;*fixme* Only do this on source where next-method can't be inlined
+ (let ((next-method ,(if (list? formals)
+ `(goops:make-next-method ,@formals)
+ `(apply goops:make-next-method
+ ,@(improper->proper formals)))))
+ ,@body)))
+ (cons (procedure-environment proc)
+ (cons formals
+ body))
+ )))
--- /dev/null
+;;; installed-scm-file
+
+;;;; Copyright (C) 1999, 2000 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;;; GNU General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+;;;; Boston, MA 02111-1307 USA
+;;;;
+\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 composite-slot.stklos from the STk
+;;;; distribution by Erick Gallesio <eg@unice.fr>.
+;;;;
+
+(define-module (oop goops composite-slot)
+ :use-module (oop goops))
+
+(export <composite-class>)
+
+;;;
+;;; (define-class CLASS SUPERS
+;;; ...
+;;; (OBJECT ...)
+;;; ...
+;;; (SLOT #:allocation #:propagated
+;;; #:propagate-to '(PROPAGATION ...))
+;;; ...
+;;; #:metaclass <composite-class>)
+;;;
+;;; PROPAGATION ::= OBJECT | (OBJECT TARGETSLOT)
+;;;
+;;; The slot SLOT will be propagated to the slot TARGETSLOT in the object
+;;; stored in slot OBJECT. If TARGETSLOT is omitted, assume that the target
+;;; slot is named SLOT.
+;;;
+
+(define-class <composite-class> (<class>))
+
+(define-method compute-get-n-set ((class <composite-class>) slot)
+ (if (eq? (slot-definition-allocation slot) #:propagated)
+ (compute-propagated-get-n-set slot)
+ (next-method)))
+
+(define (compute-propagated-get-n-set s)
+ (let ((prop (get-keyword #:propagate-to (cdr s) #f))
+ (s-name (slot-definition-name s)))
+
+ (if (not prop)
+ (goops-error "Propagation not specified for slot ~S" s-name))
+ (if (not (pair? prop))
+ (goops-error "Bad propagation list for slot ~S" s-name))
+
+ (let ((objects (map (lambda (p) (if (pair? p) (car p) p)) prop))
+ (slots (map (lambda (p) (if (pair? p) (cadr p) s-name)) prop)))
+ (let ((first-object (car objects))
+ (first-slot (car slots)))
+ (list
+ ;; The getter
+ (lambda (o)
+ (slot-ref (slot-ref o first-object) first-slot))
+
+ ;; The setter
+ (if (null? (cdr objects))
+ (lambda (o v)
+ (slot-set! (slot-ref o first-object) first-slot v))
+ (lambda (o v)
+ (for-each (lambda (object slot)
+ (slot-set! (slot-ref o object) slot v))
+ objects
+ slots))))))))
--- /dev/null
+;;; installed-scm-file
+
+;;;; Copyright (C) 1998, 1999 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;;; GNU General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+;;;; Boston, MA 02111-1307 USA
+;;;;
+\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 describe.stklos from the STk distribution by
+;;;; Erick Gallesio <eg@unice.fr>.
+;;;;
+
+(define-module (oop goops describe)
+ :use-module (oop goops)
+ :use-module (ice-9 session)
+ :use-module (ice-9 format))
+
+(export describe) ; Export the describe generic function
+
+;;;
+;;; describe for simple objects
+;;;
+(define-method describe ((x <top>))
+ (format #t "~s is " x)
+ (cond
+ ((integer? x) (format #t "an integer"))
+ ((real? x) (format #t "a real"))
+ ((complex? x) (format #t "a complex number"))
+ ((null? x) (format #t "an empty list"))
+ ((boolean? x) (format #t "a boolean value (~s)" (if x 'true 'false)))
+ ((char? x) (format #t "a character, ascii value is ~s"
+ (char->integer x)))
+ ((symbol? x) (format #t "a symbol"))
+ ((list? x) (format #t "a list"))
+ ((pair? x) (if (pair? (cdr x))
+ (format #t "an improper list")
+ (format #t "a pair")))
+ ((string? x) (if (eqv? x "")
+ (format #t "an empty string")
+ (format #t "a string of length ~s" (string-length x))))
+ ((vector? x) (if (eqv? x '#())
+ (format #t "an empty vector")
+ (format #t "a vector of length ~s" (vector-length x))))
+ ((eof-object? x) (format #t "the end-of-file object"))
+ (else (format #t "an unknown object (~s)" x)))
+ (format #t ".~%")
+ *unspecified*)
+
+(define-method describe ((x <procedure>))
+ (let ((name (procedure-name x)))
+ (if name
+ (format #t "`~s'" name)
+ (display x))
+ (display " is ")
+ (display (if name #\a "an anonymous"))
+ (display (cond ((closure? x) " procedure")
+ ((not (struct? x)) " primitive procedure")
+ ((entity? x) " entity")
+ (else " operator")))
+ (display " with ")
+ (arity x)))
+
+;;;
+;;; describe for GOOPS instances
+;;;
+(define (safe-class-name class)
+ (if (slot-bound? class 'name)
+ (class-name class)
+ class))
+
+(define-method describe ((x <object>))
+ (format #t "~S is an instance of class ~A~%"
+ x (safe-class-name (class-of x)))
+
+ ;; print all the instance slots
+ (format #t "Slots are: ~%")
+ (for-each (lambda (slot)
+ (let ((name (slot-definition-name slot)))
+ (format #t " ~S = ~A~%"
+ name
+ (if (slot-bound? x name)
+ (format #f "~S" (slot-ref x name))
+ "#<unbound>"))))
+ (class-slots (class-of x)))
+ *unspecified*)
+
+;;;
+;;; Describe for classes
+;;;
+(define-method describe ((x <class>))
+ (format #t "~S is a class. It's an instance of ~A~%"
+ (safe-class-name x) (safe-class-name (class-of x)))
+
+ ;; Super classes
+ (format #t "Superclasses are:~%")
+ (for-each (lambda (class) (format #t " ~A~%" (safe-class-name class)))
+ (class-direct-supers x))
+
+ ;; Direct slots
+ (let ((slots (class-direct-slots x)))
+ (if (null? slots)
+ (format #t "(No direct slot)~%")
+ (begin
+ (format #t "Directs slots are:~%")
+ (for-each (lambda (s)
+ (format #t " ~A~%" (slot-definition-name s)))
+ slots))))
+
+
+ ;; Direct subclasses
+ (let ((classes (class-direct-subclasses x)))
+ (if (null? classes)
+ (format #t "(No direct subclass)~%")
+ (begin
+ (format #t "Directs subclasses are:~%")
+ (for-each (lambda (s)
+ (format #t " ~A~%" (safe-class-name s)))
+ classes))))
+
+ ;; CPL
+ (format #t "Class Precedence List is:~%")
+ (for-each (lambda (s) (format #t " ~A~%" (safe-class-name s)))
+ (class-precedence-list x))
+
+ ;; Direct Methods
+ (let ((methods (class-direct-methods x)))
+ (if (null? methods)
+ (format #t "(No direct method)~%")
+ (begin
+ (format #t "Class direct methods are:~%")
+ (for-each describe methods))))
+
+; (format #t "~%Field Initializers ~% ")
+; (write (slot-ref x 'initializers)) (newline)
+
+; (format #t "~%Getters and Setters~% ")
+; (write (slot-ref x 'getters-n-setters)) (newline)
+)
+
+;;;
+;;; Describe for generic functions
+;;;
+(define-method describe ((x <generic>))
+ (let ((name (generic-function-name x))
+ (methods (generic-function-methods x)))
+ ;; Title
+ (format #t "~S is a generic function. It's an instance of ~A.~%"
+ name (safe-class-name (class-of x)))
+ ;; Methods
+ (if (null? methods)
+ (format #t "(No method defined for ~S)~%" name)
+ (begin
+ (format #t "Methods defined for ~S~%" name)
+ (for-each (lambda (x) (describe x #t)) methods)))))
+
+;;;
+;;; Describe for methods
+;;;
+(define-method describe ((x <method>) . omit-generic)
+ (letrec ((print-args (lambda (args)
+ ;; take care of dotted arg lists
+ (cond ((null? args) (newline))
+ ((pair? args)
+ (display #\space)
+ (display (safe-class-name (car args)))
+ (print-args (cdr args)))
+ (else
+ (display #\space)
+ (display (safe-class-name args))
+ (newline))))))
+
+ ;; Title
+ (format #t " Method ~A~%" x)
+
+ ;; Associated generic
+ (if (null? omit-generic)
+ (let ((gf (method-generic-function x)))
+ (if gf
+ (format #t "\t Generic: ~A~%" (generic-function-name gf))
+ (format #t "\t(No generic)~%"))))
+
+ ;; GF specializers
+ (format #t "\tSpecializers:")
+ (print-args (method-specializers x))))
+
+(provide "describe")
--- /dev/null
+;;;; Copyright (C) 1999, 2000 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;;; GNU General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+;;;; Boston, MA 02111-1307 USA
+;;;;
+\f
+
+(define-module (oop goops dispatch)
+ :use-module (oop goops)
+ :use-module (oop goops util)
+ :use-module (oop goops compile)
+ :no-backtrace
+ )
+
+(export memoize-method!)
+
+;;;
+;;; This file implements method memoization. It will finally be
+;;; implemented on C level in order to obtain fast generic function
+;;; application also during the first pass through the code.
+;;;
+
+;;;
+;;; Constants
+;;;
+
+(define hashsets 8)
+(define hashset-index 7)
+
+(define hash-threshold 3)
+(define initial-hash-size 4) ;must be a power of 2 and >= hash-threshold
+
+(define initial-hash-size-1 (- initial-hash-size 1))
+
+(define the-list-of-no-method '(no-method))
+
+;;;
+;;; Method cache
+;;;
+
+;; (#@dispatch args N-SPECIALIZED #((TYPE1 ... ENV FORMALS FORM1 ...) ...) GF)
+;; (#@dispatch args N-SPECIALIZED HASHSET MASK
+;; #((TYPE1 ... ENV FORMALS FORM1 ...) ...)
+;; GF)
+
+;;; Representation
+
+;; non-hashed form
+
+(define method-cache-entries cadddr)
+
+(define (set-method-cache-entries! mcache entries)
+ (set-car! (cdddr mcache) entries))
+
+(define (method-cache-n-methods exp)
+ (n-cache-methods (method-cache-entries exp)))
+
+(define (method-cache-methods exp)
+ (cache-methods (method-cache-entries exp)))
+
+;; hashed form
+
+(define (set-hashed-method-cache-hashset! exp hashset)
+ (set-car! (cdddr exp) hashset))
+
+(define (set-hashed-method-cache-mask! exp mask)
+ (set-car! (cddddr exp) mask))
+
+(define (hashed-method-cache-entries exp)
+ (list-ref exp 5))
+
+(define (set-hashed-method-cache-entries! exp entries)
+ (set-car! (list-cdr-ref exp 5) entries))
+
+;; either form
+
+(define (method-cache-generic-function exp)
+ (list-ref exp (if (method-cache-hashed? exp) 6 4)))
+
+;;; Predicates
+
+(define (method-cache-hashed? x)
+ (integer? (cadddr x)))
+
+(define max-non-hashed-index (- hash-threshold 2))
+
+(define (passed-hash-threshold? exp)
+ (and (> (vector-length (method-cache-entries exp)) max-non-hashed-index)
+ (struct? (car (vector-ref (method-cache-entries exp)
+ max-non-hashed-index)))))
+
+;;; Converting a method cache to hashed form
+
+(define (method-cache->hashed! exp)
+ (set-cdr! (cddr exp) (cons 0 (cons initial-hash-size-1 (cdddr exp))))
+ exp)
+
+;;;
+;;; Cache entries
+;;;
+
+(define (n-cache-methods entries)
+ (do ((i (- (vector-length entries) 1) (- i 1)))
+ ((or (< i 0) (struct? (car (vector-ref entries i))))
+ (+ i 1))))
+
+(define (cache-methods entries)
+ (do ((i (- (vector-length entries) 1) (- i 1))
+ (methods '() (let ((entry (vector-ref entries i)))
+ (if (struct? (car entry))
+ (cons entry methods)
+ methods))))
+ ((< i 0) methods)))
+
+;;;
+;;; Method insertion
+;;;
+
+(define (method-cache-insert! exp entry)
+ (let* ((entries (method-cache-entries exp))
+ (n (n-cache-methods entries)))
+ (if (>= n (vector-length entries))
+ ;; grow cache
+ (let ((new-entries (make-vector (* 2 (vector-length entries))
+ the-list-of-no-method)))
+ (do ((i 0 (+ i 1)))
+ ((= i n))
+ (vector-set! new-entries i (vector-ref entries i)))
+ (vector-set! new-entries n entry)
+ (set-method-cache-entries! exp new-entries))
+ (vector-set! entries n entry))))
+
+(define (hashed-method-cache-insert! exp entry)
+ (let* ((cache (hashed-method-cache-entries exp))
+ (size (vector-length cache)))
+ (let* ((entries (cons entry (cache-methods cache)))
+ (size (if (<= (length entries) size)
+ size
+ ;; larger size required
+ (let ((new-size (* 2 size)))
+ (set-hashed-method-cache-mask! exp (- new-size 1))
+ new-size)))
+ (min-misses size)
+ (best #f))
+ (do ((hashset 0 (+ 1 hashset)))
+ ((= hashset hashsets))
+ (let* ((test-cache (make-vector size the-list-of-no-method))
+ (misses (cache-try-hash! min-misses hashset test-cache entries)))
+ (cond ((zero? misses)
+ (set! min-misses 0)
+ (set! best hashset)
+ (set! cache test-cache)
+ (set! hashset (- hashsets 1)))
+ ((< misses min-misses)
+ (set! min-misses misses)
+ (set! best hashset)
+ (set! cache test-cache)))))
+ (set-hashed-method-cache-hashset! exp best)
+ (set-hashed-method-cache-entries! exp cache))))
+
+;;;
+;;; Caching
+;;;
+
+(define environment? pair?)
+
+(define (cache-hashval hashset entry)
+ (let ((hashset-index (+ hashset-index hashset)))
+ (do ((sum 0)
+ (classes entry (cdr classes)))
+ ((environment? (car classes)) sum)
+ (set! sum (+ sum (struct-ref (car classes) hashset-index))))))
+
+(define (cache-try-hash! min-misses hashset cache entries)
+ (let ((max-misses 0)
+ (mask (- (vector-length cache) 1)))
+ (catch 'misses
+ (lambda ()
+ (do ((ls entries (cdr ls))
+ (misses 0 0))
+ ((null? ls) max-misses)
+ (do ((i (%logand mask (cache-hashval hashset (car ls)))
+ (%logand mask (+ i 1))))
+ ((not (struct? (car (vector-ref cache i))))
+ (vector-set! cache i (car ls)))
+ (set! misses (+ 1 misses))
+ (if (>= misses min-misses)
+ (throw 'misses misses)))
+ (if (> misses max-misses)
+ (set! max-misses misses))))
+ (lambda (key misses)
+ misses))))
+
+;;;
+;;; Memoization
+;;;
+
+;; Backward compatibility
+(if (not (defined? 'lookup-create-cmethod))
+ (define (lookup-create-cmethod gf args)
+ (no-applicable-method (car args) (cadr args))))
+
+(define (memoize-method! gf args exp)
+ (if (not (slot-ref gf 'used-by))
+ (slot-set! gf 'used-by '()))
+ (let ((applicable ((if (eq? gf compute-applicable-methods)
+ %compute-applicable-methods
+ compute-applicable-methods)
+ gf args)))
+ (cond (applicable
+ ;; *fixme* dispatch.scm needs rewriting Since the current
+ ;; code mutates the method cache, we have to work on a
+ ;; copy. Otherwise we might disturb another thread
+ ;; currently dispatching on the cache. (No need to copy
+ ;; the vector.)
+ (let* ((new (list-copy exp))
+ (res
+ (cond ((method-cache-hashed? new)
+ (method-cache-install! hashed-method-cache-insert!
+ new args applicable))
+ ((passed-hash-threshold? new)
+ (method-cache-install! hashed-method-cache-insert!
+ (method-cache->hashed! new)
+ args
+ applicable))
+ (else
+ (method-cache-install! method-cache-insert!
+ new args applicable)))))
+ (set-cdr! (cdr exp) (cddr new))
+ res))
+ ((null? args)
+ (lookup-create-cmethod no-applicable-method (list gf '())))
+ (else
+ ;; Mutate arglist to fit no-applicable-method
+ (set-cdr! args (list (cons (car args) (cdr args))))
+ (set-car! args gf)
+ (lookup-create-cmethod no-applicable-method args)))))
+
+(set-procedure-property! memoize-method! 'system-procedure #t)
+
+(define method-cache-install!
+ (letrec ((first-n
+ (lambda (ls n)
+ (if (or (zero? n) (null? ls))
+ '()
+ (cons (car ls) (first-n (cdr ls) (- n 1)))))))
+ (lambda (insert! exp args applicable)
+ (let* ((specializers (method-specializers (car applicable)))
+ (n-specializers
+ (if (list? specializers)
+ (length specializers)
+ (abs (slot-ref (method-cache-generic-function exp)
+ 'n-specialized)))))
+ (let* ((types (map class-of (first-n args n-specializers)))
+ (entry+cmethod (compute-entry-with-cmethod applicable types)))
+ (insert! exp (car entry+cmethod)) ; entry = types + cmethod
+ (cdr entry+cmethod) ; cmethod
+ )))))
--- /dev/null
+;;; installed-scm-file
+
+;;;; Copyright (C) 1999 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;;; GNU General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+;;;; Boston, MA 02111-1307 USA
+;;;;
+\f
+
+(define-module (oop goops internal)
+ :use-module (oop goops))
+
+;; Export all bindings from (oop goops)
+(module-for-each (lambda (sym var)
+ (module-add! %module-public-interface sym var))
+ (nested-ref the-root-module '(app modules oop goops)))
--- /dev/null
+;;; installed-scm-file
+
+;;;; Copyright (C) 2000 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;;; GNU General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+;;;; Boston, MA 02111-1307 USA
+;;;;
+\f
+
+(define-module (oop goops save)
+ :use-module (oop goops internal)
+ :use-module (oop goops util)
+ )
+
+(export save-objects load-objects restore make-unbound
+ enumerate! enumerate-component!
+ write-readably write-component write-component-procedure
+ literal? readable make-readable)
+
+;;;
+;;; save-objects ALIST PORT [EXCLUDED] [USES]
+;;;
+;;; ALIST ::= ((NAME . OBJECT) ...)
+;;;
+;;; Save OBJECT ... to PORT so that when the data is read and evaluated
+;;; OBJECT ... are re-created under names NAME ... .
+;;; Exclude any references to objects in the list EXCLUDED.
+;;; Add a (use-modules . USES) line to the top of the saved text.
+;;;
+;;; In some instances, when `save-object' doesn't know how to produce
+;;; readable syntax for an object, you can explicitly register read
+;;; syntax for an object using the special form `readable'.
+;;;
+;;; Example:
+;;;
+;;; The function `foo' produces an object of obscure structure.
+;;; Only `foo' can construct such objects. Because of this, an
+;;; object such as
+;;;
+;;; (define x (vector 1 (foo)))
+;;;
+;;; cannot be saved by `save-objects'. But if you instead write
+;;;
+;;; (define x (vector 1 (readable (foo))))
+;;;
+;;; `save-objects' will happily produce the necessary read syntax.
+;;;
+;;; To add new read syntax, hang methods on `enumerate!' and
+;;; `write-readably'.
+;;;
+;;; enumerate! OBJECT ENV
+;;; Should call `enumerate-component!' (which takes same args) on
+;;; each component object. Should return #t if the composite object
+;;; can be written as a literal. (`enumerate-component!' returns #t
+;;; if the component is a literal.
+;;;
+;;; write-readably OBJECT PORT ENV
+;;; Should write a readable representation of OBJECT to PORT.
+;;; Should use `write-component' to print each component object.
+;;; Use `literal?' to decide if a component is a literal.
+;;;
+;;; Utilities:
+;;;
+;;; enumerate-component! OBJECT ENV
+;;;
+;;; write-component OBJECT PATCHER PORT ENV
+;;; PATCHER is an expression which, when evaluated, stores OBJECT
+;;; into its current location.
+;;;
+;;; Example:
+;;;
+;;; (write-component (car ls) `(set-car! ,ls ,(car ls)) file env)
+;;;
+;;; write-component is a macro.
+;;;
+;;; literal? COMPONENT ENV
+;;;
+
+(define-method immediate? ((o <top>)) #f)
+
+(define-method immediate? ((o <null>)) #t)
+(define-method immediate? ((o <number>)) #t)
+(define-method immediate? ((o <boolean>)) #t)
+(define-method immediate? ((o <symbol>)) #t)
+(define-method immediate? ((o <char>)) #t)
+(define-method immediate? ((o <keyword>)) #t)
+
+;;; enumerate! OBJECT ENVIRONMENT
+;;;
+;;; Return #t if object is a literal.
+;;;
+(define-method enumerate! ((o <top>) env) #t)
+
+(define-method write-readably ((o <top>) file env)
+ ;;(goops-error "No read-syntax defined for object `~S'" o)
+ (write o file) ;doesn't catch bugs, but is much more flexible
+ )
+
+;;;
+;;; Readables
+;;;
+
+(if (or (not (defined? 'readables))
+ (not readables))
+ (define readables (make-weak-key-hash-table 61)))
+
+(define readable
+ (procedure->memoizing-macro
+ (lambda (exp env)
+ `(make-readable ,(cadr exp) ',(copy-tree (cadr exp))))))
+
+(define (make-readable obj expr)
+ (hashq-set! readables obj expr)
+ obj)
+
+(define (readable-expression obj)
+ `(readable ,(hashq-ref readables obj)))
+
+(define (readable? obj)
+ (hashq-get-handle readables obj))
+
+;;;
+;;; Strings
+;;;
+
+(define-method enumerate! ((o <string>) env) #f)
+
+;;;
+;;; Vectors
+;;;
+
+(define-method enumerate! ((o <vector>) env)
+ (or (not (vector? o))
+ (let ((literal? #t))
+ (array-for-each (lambda (o)
+ (if (not (enumerate-component! o env))
+ (set! literal? #f)))
+ o)
+ literal?)))
+
+(define-method write-readably ((o <vector>) file env)
+ (if (not (vector? o))
+ (write o file)
+ (let ((n (vector-length o)))
+ (if (zero? n)
+ (display "#()" file)
+ (let ((not-literal? (not (literal? o env))))
+ (display (if not-literal?
+ "(vector "
+ "#(")
+ file)
+ (if (and not-literal?
+ (literal? (vector-ref o 0) env))
+ (display #\' file))
+ (write-component (vector-ref o 0)
+ `(vector-set! ,o 0 ,(vector-ref o 0))
+ file
+ env)
+ (do ((i 1 (+ 1 i)))
+ ((= i n))
+ (display #\space file)
+ (if (and not-literal?
+ (literal? (vector-ref o i) env))
+ (display #\' file))
+ (write-component (vector-ref o i)
+ `(vector-set! ,o ,i ,(vector-ref o i))
+ file
+ env))
+ (display #\) file))))))
+
+
+;;;
+;;; Arrays
+;;;
+
+(define-method enumerate! ((o <array>) env)
+ (enumerate-component! (shared-array-root o) env))
+
+(define (make-mapper array)
+ (let* ((dims (array-dimensions array))
+ (n (array-rank array))
+ (indices (reverse (if (<= n 11)
+ (list-tail '(t s r q p n m l k j i) (- 11 n))
+ (let loop ((n n)
+ (ls '()))
+ (if (zero? n)
+ ls
+ (loop (- n 1)
+ (cons (gensym "i") ls))))))))
+ `(lambda ,indices
+ (+ ,(shared-array-offset array)
+ ,@(map (lambda (ind dim inc)
+ `(* ,inc ,(if (pair? dim) `(- ,ind ,(car dim)) ind)))
+ indices
+ (array-dimensions array)
+ (shared-array-increments array))))))
+
+(define (write-array prefix o not-literal? file env)
+ (letrec ((inner (lambda (n indices)
+ (if (not (zero? n))
+ (let ((el (apply array-ref o
+ (reverse (cons 0 indices)))))
+ (if (and not-literal?
+ (literal? el env))
+ (display #\' file))
+ (write-component
+ el
+ `(array-set! ,o ,el ,@indices)
+ file
+ env)))
+ (do ((i 1 (+ 1 i)))
+ ((= i n))
+ (display #\space file)
+ (let ((el (apply array-ref o
+ (reverse (cons i indices)))))
+ (if (and not-literal?
+ (literal? el env))
+ (display #\' file))
+ (write-component
+ el
+ `(array-set! ,o ,el ,@indices)
+ file
+ env))))))
+ (display prefix file)
+ (let loop ((dims (array-dimensions o))
+ (indices '()))
+ (cond ((null? (cdr dims))
+ (inner (car dims) indices))
+ (else
+ (let ((n (car dims)))
+ (do ((i 0 (+ 1 i)))
+ ((= i n))
+ (if (> i 0)
+ (display #\space file))
+ (display prefix file)
+ (loop (cdr dims) (cons i indices))
+ (display #\) file))))))
+ (display #\) file)))
+
+(define-method write-readably ((o <array>) file env)
+ (let ((root (shared-array-root o)))
+ (cond ((literal? o env)
+ (if (not (vector? root))
+ (write o file)
+ (begin
+ (display #\# file)
+ (display (array-rank o) file)
+ (write-array #\( o #f file env))))
+ ((binding? root env)
+ (display "(make-shared-array " file)
+ (if (literal? root env)
+ (display #\' file))
+ (write-component root
+ (goops-error "write-readably(<array>): internal error")
+ file
+ env)
+ (display #\space file)
+ (display (make-mapper o) file)
+ (for-each (lambda (dim)
+ (display #\space file)
+ (display dim file))
+ (array-dimensions o))
+ (display #\) file))
+ (else
+ (display "(list->uniform-array " file)
+ (display (array-rank o) file)
+ (display " '() " file)
+ (write-array "(list " o file env)))))
+
+;;;
+;;; Pairs
+;;;
+
+;;; These methods have more complex structure than is required for
+;;; most objects, since they take over some of the logic of
+;;; `write-component'.
+;;;
+
+(define-method enumerate! ((o <pair>) env)
+ (let ((literal? (enumerate-component! (car o) env)))
+ (and (enumerate-component! (cdr o) env)
+ literal?)))
+
+(define-method write-readably ((o <pair>) file env)
+ (let ((proper? (let loop ((ls o))
+ (or (null? ls)
+ (and (pair? ls)
+ (not (binding? (cdr ls) env))
+ (loop (cdr ls))))))
+ (1? (or (not (pair? (cdr o)))
+ (binding? (cdr o) env)))
+ (not-literal? (not (literal? o env)))
+ (infos '())
+ (refs (ref-stack env)))
+ (display (cond ((not not-literal?) #\()
+ (proper? "(list ")
+ (1? "(cons ")
+ (else "(list* "))
+ file)
+ (if (and not-literal?
+ (literal? (car o) env))
+ (display #\' file))
+ (write-component (car o) `(set-car! ,o ,(car o)) file env)
+ (do ((ls (cdr o) (cdr ls))
+ (prev o ls))
+ ((or (not (pair? ls))
+ (binding? ls env))
+ (if (not (null? ls))
+ (begin
+ (if (not not-literal?)
+ (display " ." file))
+ (display #\space file)
+ (if (and not-literal?
+ (literal? ls env))
+ (display #\' file))
+ (write-component ls `(set-cdr! ,prev ,ls) file env)))
+ (display #\) file))
+ (display #\space file)
+ (set! infos (cons (object-info ls env) infos))
+ (push-ref! ls env) ;*fixme* optimize
+ (set! (visiting? (car infos)) #t)
+ (if (and not-literal?
+ (literal? (car ls) env))
+ (display #\' file))
+ (write-component (car ls) `(set-car! ,ls ,(car ls)) file env)
+ )
+ (for-each (lambda (info)
+ (set! (visiting? info) #f))
+ infos)
+ (set! (ref-stack env) refs)
+ ))
+
+;;;
+;;; Objects
+;;;
+
+;;; Doesn't yet handle unbound slots
+
+;; Don't export this function! This is all very temporary.
+;;
+(define (get-set-for-each proc class)
+ (for-each (lambda (slotdef g-n-s)
+ (let ((g-n-s (cddr g-n-s)))
+ (cond ((integer? g-n-s)
+ (proc (standard-get g-n-s) (standard-set g-n-s)))
+ ((not (memq (slot-definition-allocation slotdef)
+ '(#:class #:each-subclass)))
+ (proc (car g-n-s) (cadr g-n-s))))))
+ (class-slots class)
+ (slot-ref class 'getters-n-setters)))
+
+(define (access-for-each proc class)
+ (for-each (lambda (slotdef g-n-s)
+ (let ((g-n-s (cddr g-n-s))
+ (a (slot-definition-accessor slotdef)))
+ (cond ((integer? g-n-s)
+ (proc (slot-definition-name slotdef)
+ (and a (generic-function-name a))
+ (standard-get g-n-s)
+ (standard-set g-n-s)))
+ ((not (memq (slot-definition-allocation slotdef)
+ '(#:class #:each-subclass)))
+ (proc (slot-definition-name slotdef)
+ (and a (generic-function-name a))
+ (car g-n-s)
+ (cadr g-n-s))))))
+ (class-slots class)
+ (slot-ref class 'getters-n-setters)))
+
+(define restore
+ (procedure->macro
+ (lambda (exp env)
+ "(restore CLASS (SLOT-NAME1 ...) EXP1 ...)"
+ `(let ((o (,%allocate-instance ,(cadr exp) '())))
+ (for-each (lambda (name val)
+ (,slot-set! o name val))
+ ',(caddr exp)
+ (list ,@(cdddr exp)))
+ o))))
+
+(define-method enumerate! ((o <object>) env)
+ (get-set-for-each (lambda (get set)
+ (let ((val (get o)))
+ (if (not (unbound? val))
+ (enumerate-component! val env))))
+ (class-of o))
+ #f)
+
+(define-method write-readably ((o <object>) file env)
+ (let ((class (class-of o)))
+ (display "(restore " file)
+ (display (class-name class) file)
+ (display " (" file)
+ (let ((slotdefs
+ (filter (lambda (slotdef)
+ (not (or (memq (slot-definition-allocation slotdef)
+ '(#:class #:each-subclass))
+ (and (slot-bound? o (slot-definition-name slotdef))
+ (excluded?
+ (slot-ref o (slot-definition-name slotdef))
+ env)))))
+ (class-slots class))))
+ (if (not (null? slotdefs))
+ (begin
+ (display (slot-definition-name (car slotdefs)) file)
+ (for-each (lambda (slotdef)
+ (display #\space file)
+ (display (slot-definition-name slotdef) file))
+ (cdr slotdefs)))))
+ (display #\) file)
+ (access-for-each (lambda (name aname get set)
+ (display #\space file)
+ (let ((val (get o)))
+ (cond ((unbound? val)
+ (display '(make-unbound) file))
+ ((excluded? val env))
+ (else
+ (if (literal? val env)
+ (display #\' file))
+ (write-component val
+ (if aname
+ `(set! (,aname ,o) ,val)
+ `(slot-set! ,o ',name ,val))
+ file env)))))
+ class)
+ (display #\) file)))
+
+;;;
+;;; Classes
+;;;
+
+;;; Currently, we don't support reading in class objects
+;;;
+
+(define-method enumerate! ((o <class>) env) #f)
+
+(define-method write-readably ((o <class>) file env)
+ (display (class-name o) file))
+
+;;;
+;;; Generics
+;;;
+
+;;; Currently, we don't support reading in generic functions
+;;;
+
+(define-method enumerate! ((o <generic>) env) #f)
+
+(define-method write-readably ((o <generic>) file env)
+ (display (generic-function-name o) file))
+
+;;;
+;;; Method
+;;;
+
+;;; Currently, we don't support reading in methods
+;;;
+
+(define-method enumerate! ((o <method>) env) #f)
+
+(define-method write-readably ((o <method>) file env)
+ (goops-error "No read-syntax for <method> defined"))
+
+;;;
+;;; Environments
+;;;
+
+(define-class <environment> ()
+ (object-info #:accessor object-info
+ #:init-form (make-hash-table 61))
+ (excluded #:accessor excluded
+ #:init-form (make-hash-table 61))
+ (pass-2? #:accessor pass-2?
+ #:init-value #f)
+ (ref-stack #:accessor ref-stack
+ #:init-value '())
+ (objects #:accessor objects
+ #:init-value '())
+ (pre-defines #:accessor pre-defines
+ #:init-value '())
+ (locals #:accessor locals
+ #:init-value '())
+ (stand-ins #:accessor stand-ins
+ #:init-value '())
+ (post-defines #:accessor post-defines
+ #:init-value '())
+ (patchers #:accessor patchers
+ #:init-value '())
+ (multiple-bound #:accessor multiple-bound
+ #:init-value '())
+ )
+
+(define-method (initialize (env <environment>) initargs)
+ (next-method)
+ (cond ((get-keyword #:excluded initargs #f)
+ => (lambda (excludees)
+ (for-each (lambda (e)
+ (hashq-create-handle! (excluded env) e #f))
+ excludees)))))
+
+(define-method (object-info o env)
+ (hashq-ref (object-info env) o))
+
+(define-method ((setter object-info) o env x)
+ (hashq-set! (object-info env) o x))
+
+(define (excluded? o env)
+ (hashq-get-handle (excluded env) o))
+
+(define (add-patcher! patcher env)
+ (set! (patchers env) (cons patcher (patchers env))))
+
+(define (push-ref! o env)
+ (set! (ref-stack env) (cons o (ref-stack env))))
+
+(define (pop-ref! env)
+ (set! (ref-stack env) (cdr (ref-stack env))))
+
+(define (container env)
+ (car (ref-stack env)))
+
+(define-class <object-info> ()
+ (visiting #:accessor visiting
+ #:init-value #f)
+ (binding #:accessor binding
+ #:init-value #f)
+ (literal? #:accessor literal?
+ #:init-value #f)
+ )
+
+(define visiting? visiting)
+
+(define-method (binding (info <boolean>))
+ #f)
+
+(define-method (binding o env)
+ (binding (object-info o env)))
+
+(define binding? binding)
+
+(define-method (literal? (info <boolean>))
+ #t)
+
+;;; Note that this method is intended to be used only during the
+;;; writing pass
+;;;
+(define-method (literal? o env)
+ (or (immediate? o)
+ (excluded? o env)
+ (let ((info (object-info o env)))
+ ;; write-component sets all bindings first to #:defining,
+ ;; then to #:defined
+ (and (or (not (binding? info))
+ ;; we might be using `literal?' in a write-readably method
+ ;; to query about the object being defined
+ (and (eq? (visiting info) #:defining)
+ (null? (cdr (ref-stack env)))))
+ (literal? info)))))
+
+;;;
+;;; Enumeration
+;;;
+
+;;; Enumeration has two passes.
+;;;
+;;; Pass 1: Detect common substructure, circular references and order
+;;;
+;;; Pass 2: Detect literals
+
+(define (enumerate-component! o env)
+ (cond ((immediate? o) #t)
+ ((readable? o) #f)
+ ((excluded? o env) #t)
+ ((pass-2? env)
+ (let ((info (object-info o env)))
+ (if (binding? info)
+ ;; if circular reference, we print as a literal
+ ;; (note that during pass-2, circular references are
+ ;; forward references, i.e. *not* yet marked with #:pass-2
+ (not (eq? (visiting? info) #:pass-2))
+ (and (enumerate! o env)
+ (begin
+ (set! (literal? info) #t)
+ #t)))))
+ ((object-info o env)
+ => (lambda (info)
+ (set! (binding info) #t)
+ (if (visiting? info)
+ ;; circular reference--mark container
+ (set! (binding (object-info (container env) env)) #t))))
+ (else
+ (let ((info (make <object-info>)))
+ (set! (object-info o env) info)
+ (push-ref! o env)
+ (set! (visiting? info) #t)
+ (enumerate! o env)
+ (set! (visiting? info) #f)
+ (pop-ref! env)
+ (set! (objects env) (cons o (objects env)))))))
+
+(define (write-component-procedure o file env)
+ "Return #f if circular reference"
+ (cond ((immediate? o) (write o file) #t)
+ ((readable? o) (write (readable-expression o) file) #t)
+ ((excluded? o env) (display #f file) #t)
+ (else
+ (let ((info (object-info o env)))
+ (cond ((not (binding? info)) (write-readably o file env) #t)
+ ((not (eq? (visiting info) #:defined)) #f) ;forward reference
+ (else (display (binding info) file) #t))))))
+
+;;; write-component OBJECT PATCHER FILE ENV
+;;;
+(define write-component
+ (procedure->memoizing-macro
+ (lambda (exp env)
+ `(or (write-component-procedure ,(cadr exp) ,@(cdddr exp))
+ (begin
+ (display #f ,(cadddr exp))
+ (add-patcher! ,(caddr exp) env))))))
+
+;;;
+;;; Main engine
+;;;
+
+(define binding-name car)
+(define binding-object cdr)
+
+(define (pass-1! alist env)
+ ;; Determine object order and necessary bindings
+ (for-each (lambda (binding)
+ (enumerate-component! (binding-object binding) env))
+ alist))
+
+(define (make-local i)
+ (string->symbol (string-append "%o" (number->string i))))
+
+(define (name-bindings! alist env)
+ ;; Name top-level bindings
+ (for-each (lambda (b)
+ (let ((o (binding-object b)))
+ (if (not (or (immediate? o)
+ (readable? o)
+ (excluded? o env)))
+ (let ((info (object-info o env)))
+ (if (symbol? (binding info))
+ ;; already bound to a variable
+ (set! (multiple-bound env)
+ (acons (binding info)
+ (binding-name b)
+ (multiple-bound env)))
+ (set! (binding info)
+ (binding-name b)))))))
+ alist)
+ ;; Name rest of bindings and create stand-in and definition lists
+ (let post-loop ((ls (objects env))
+ (post-defs '()))
+ (cond ((or (null? ls)
+ (eq? (binding (car ls) env) #t))
+ (set! (post-defines env) post-defs)
+ (set! (objects env) ls))
+ ((not (binding (car ls) env))
+ (post-loop (cdr ls) post-defs))
+ (else
+ (post-loop (cdr ls) (cons (car ls) post-defs)))))
+ (let pre-loop ((ls (reverse (objects env)))
+ (i 0)
+ (pre-defs '())
+ (locs '())
+ (sins '()))
+ (if (null? ls)
+ (begin
+ (set! (pre-defines env) (reverse pre-defs))
+ (set! (locals env) (reverse locs))
+ (set! (stand-ins env) (reverse sins)))
+ (let ((info (object-info (car ls) env)))
+ (cond ((not (binding? info))
+ (pre-loop (cdr ls) i pre-defs locs sins))
+ ((boolean? (binding info))
+ ;; local
+ (set! (binding info) (make-local i))
+ (pre-loop (cdr ls)
+ (+ 1 i)
+ pre-defs
+ (cons (car ls) locs)
+ sins))
+ ((null? locs)
+ (pre-loop (cdr ls)
+ i
+ (cons (car ls) pre-defs)
+ locs
+ sins))
+ (else
+ (let ((real-name (binding info)))
+ (set! (binding info) (make-local i))
+ (pre-loop (cdr ls)
+ (+ 1 i)
+ pre-defs
+ (cons (car ls) locs)
+ (acons (binding info) real-name sins)))))))))
+
+(define (pass-2! env)
+ (set! (pass-2? env) #t)
+ (for-each (lambda (o)
+ (let ((info (object-info o env)))
+ (set! (literal? info) (enumerate! o env))
+ (set! (visiting info) #:pass-2)))
+ (append (pre-defines env)
+ (locals env)
+ (post-defines env))))
+
+(define (write-define! name val literal? file)
+ (display "(define " file)
+ (display name file)
+ (display #\space file)
+ (if literal? (display #\' file))
+ (write val file)
+ (display ")\n" file))
+
+(define (write-empty-defines! file env)
+ (for-each (lambda (stand-in)
+ (write-define! (cdr stand-in) #f #f file))
+ (stand-ins env))
+ (for-each (lambda (o)
+ (write-define! (binding o env) #f #f file))
+ (post-defines env)))
+
+(define (write-definition! prefix o file env)
+ (display prefix file)
+ (let ((info (object-info o env)))
+ (display (binding info) file)
+ (display #\space file)
+ (if (literal? info)
+ (display #\' file))
+ (push-ref! o env)
+ (set! (visiting info) #:defining)
+ (write-readably o file env)
+ (set! (visiting info) #:defined)
+ (pop-ref! env)
+ (display #\) file)))
+
+(define (write-let*-head! file env)
+ (display "(let* (" file)
+ (write-definition! "(" (car (locals env)) file env)
+ (for-each (lambda (o)
+ (write-definition! "\n (" o file env))
+ (cdr (locals env)))
+ (display ")\n" file))
+
+(define (write-rebindings! prefix bindings file env)
+ (for-each (lambda (patch)
+ (display prefix file)
+ (display (cdr patch) file)
+ (display #\space file)
+ (display (car patch) file)
+ (display ")\n" file))
+ bindings))
+
+(define (write-definitions! selector prefix file env)
+ (for-each (lambda (o)
+ (write-definition! prefix o file env)
+ (newline file))
+ (selector env)))
+
+(define (write-patches! prefix file env)
+ (for-each (lambda (patch)
+ (display prefix file)
+ (display (let name-objects ((patcher patch))
+ (cond ((binding patcher env)
+ => (lambda (name)
+ (cond ((assq name (stand-ins env))
+ => cdr)
+ (else name))))
+ ((pair? patcher)
+ (cons (name-objects (car patcher))
+ (name-objects (cdr patcher))))
+ (else patcher)))
+ file)
+ (newline file))
+ (reverse (patchers env))))
+
+(define (write-immediates! alist file)
+ (for-each (lambda (b)
+ (if (immediate? (binding-object b))
+ (write-define! (binding-name b)
+ (binding-object b)
+ #t
+ file)))
+ alist))
+
+(define (write-readables! alist file env)
+ (let ((written '()))
+ (for-each (lambda (b)
+ (cond ((not (readable? (binding-object b))))
+ ((assq (binding-object b) written)
+ => (lambda (p)
+ (set! (multiple-bound env)
+ (acons (cdr p)
+ (binding-name b)
+ (multiple-bound env)))))
+ (else
+ (write-define! (binding-name b)
+ (readable-expression (binding-object b))
+ #f
+ file)
+ (set! written (acons (binding-object b)
+ (binding-name b)
+ written)))))
+ alist)))
+
+(define-method save-objects ((alist <pair>) (file <string>) . rest)
+ (let ((port (open-output-file file)))
+ (apply save-objects alist port rest)
+ (close-port port)
+ *unspecified*))
+
+(define-method save-objects ((alist <pair>) (file <output-port>) . rest)
+ (let ((excluded (if (>= (length rest) 1) (car rest) '()))
+ (uses (if (>= (length rest) 2) (cadr rest) '())))
+ (let ((env (make <environment> #:excluded excluded)))
+ (pass-1! alist env)
+ (name-bindings! alist env)
+ (pass-2! env)
+ (if (not (null? uses))
+ (begin
+ (write `(use-modules ,@uses) file)
+ (newline file)))
+ (write-immediates! alist file)
+ (if (null? (locals env))
+ (begin
+ (write-definitions! post-defines "(define " file env)
+ (write-patches! "" file env))
+ (begin
+ (write-definitions! pre-defines "(define " file env)
+ (write-empty-defines! file env)
+ (write-let*-head! file env)
+ (write-rebindings! " (set! " (stand-ins env) file env)
+ (write-definitions! post-defines " (set! " file env)
+ (write-patches! " " file env)
+ (display " )\n" file)))
+ (write-readables! alist file env)
+ (write-rebindings! "(define " (reverse (multiple-bound env)) file env))))
+
+(define-method load-objects ((file <string>))
+ (let* ((port (open-input-file file))
+ (objects (load-objects port)))
+ (close-port port)
+ objects))
+
+(define-method load-objects ((file <input-port>))
+ (let ((m (make-module)))
+ (module-use! m the-scm-module)
+ (module-use! m %module-public-interface)
+ (save-module-excursion
+ (lambda ()
+ (set-current-module m)
+ (let loop ((sexp (read file)))
+ (if (not (eof-object? sexp))
+ (begin
+ (eval-in-module sexp m)
+ (loop (read file)))))))
+ (module-map (lambda (name var)
+ (cons name (variable-ref var)))
+ m)))
--- /dev/null
+;;;; Copyright (C) 1999 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;;; GNU General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+;;;; Boston, MA 02111-1307 USA
+;;;;
+\f
+
+(define-module (oop goops stklos)
+ :use-module (oop goops internal)
+ :no-backtrace
+ )
+
+;;;
+;;; This is the stklos compatibility module.
+;;;
+;;; WARNING: This module is under construction. While we expect to be able
+;;; to run most stklos code without problems in the future, this is not the
+;;; case now. The current compatibility is only superficial.
+;;;
+;;; Any comments/complaints/patches are welcome. Tell us about
+;;; your incompatibility problems (bug-guile@gnu.org).
+;;;
+
+;; Export all bindings that are exported from (oop goops)...
+(module-for-each (lambda (sym var)
+ (module-add! %module-public-interface sym var))
+ (nested-ref the-root-module '(app modules oop goops
+ %module-public-interface)))
+
+;; ...but replace the following bindings:
+(export define-class define-method)
+
+;; Also export the following
+(export write-object)
+
+;;; Enable keyword support (*fixme*---currently this has global effect)
+(read-set! keywords 'prefix)
+
+(define standard-define-class-transformer
+ (macro-transformer standard-define-class))
+
+(define define-class
+ ;; Syntax
+ (let ((name cadr)
+ (supers caddr)
+ (slots cadddr)
+ (rest cddddr))
+ (procedure->macro
+ (lambda (exp env)
+ (standard-define-class-transformer
+ `(define-class ,(name exp) ,(supers exp) ,@(slots exp)
+ ,@(rest exp))
+ env)))))
+
+(define define-method
+ (procedure->memoizing-macro
+ (lambda (exp env)
+ (let ((name (cadr exp)))
+ (if (and (pair? name)
+ (eq? (car name) 'setter)
+ (pair? (cdr name))
+ (null? (cddr name)))
+ (let ((name (cadr name)))
+ (cond ((not (symbol? name))
+ (goops-error "bad method name: ~S" name))
+ ((defined? name env)
+ `(begin
+ (if (not (is-a? ,name <generic-with-setter>))
+ (define-accessor ,name))
+ (add-method! (setter ,name) (method ,@(cddr exp)))))
+ (else
+ `(begin
+ (define-accessor ,name)
+ (add-method! (setter ,name) (method ,@(cddr exp)))))))
+ (cond ((not (symbol? name))
+ (goops-error "bad method name: ~S" name))
+ ((defined? name env)
+ `(begin
+ (if (not (or (is-a? ,name <generic>)
+ (is-a? ,name <primitive-generic>)))
+ (define-generic ,name))
+ (add-method! ,name (method ,@(cddr exp)))))
+ (else
+ `(begin
+ (define-generic ,name)
+ (add-method! ,name (method ,@(cddr exp)))))))))))
--- /dev/null
+;;;; Copyright (C) 1999, 2000 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;;; GNU General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+;;;; Boston, MA 02111-1307 USA
+;;;;
+\f
+
+(define-module (oop goops util)
+ :no-backtrace
+ )
+
+(export any every filter
+ mapappend find-duplicate top-level-env top-level-env?
+ map* for-each* length* improper->proper
+ )
+
+;;;
+;;; {Utilities}
+;;;
+
+(define (any pred lst . rest)
+ (if (null? rest) ;fast path
+ (and (not (null? lst))
+ (let loop ((head (car lst)) (tail (cdr lst)))
+ (if (null? tail)
+ (pred head)
+ (or (pred head)
+ (loop (car tail) (cdr tail))))))
+ (let ((lsts (cons lst rest)))
+ (and (not (any null? lsts))
+ (let loop ((heads (map car lsts)) (tails (map cdr lsts)))
+ (if (any null? tails)
+ (apply pred heads)
+ (or (apply pred heads)
+ (loop (map car tails) (map cdr tails)))))))))
+
+(define (every pred lst . rest)
+ (if (null? rest) ;fast path
+ (or (null? lst)
+ (let loop ((head (car lst)) (tail (cdr lst)))
+ (if (null? tail)
+ (pred head)
+ (and (pred head)
+ (loop (car tail) (cdr tail))))))
+ (let ((lsts (cons lst rest)))
+ (or (any null? lsts)
+ (let loop ((heads (map car lsts)) (tails (map cdr lsts)))
+ (if (any null? tails)
+ (apply pred heads)
+ (and (apply pred heads)
+ (loop (map car tails) (map cdr tails)))))))))
+
+(define (filter test? list)
+ (cond ((null? list) '())
+ ((test? (car list)) (cons (car list) (filter test? (cdr list))))
+ (else (filter test? (cdr list)))))
+
+(define (mapappend func . args)
+ (if (memv '() args)
+ '()
+ (append (apply func (map car args))
+ (apply mapappend func (map cdr args)))))
+
+(define (find-duplicate l) ; find a duplicate in a list; #f otherwise
+ (cond
+ ((null? l) #f)
+ ((memv (car l) (cdr l)) (car l))
+ (else (find-duplicate (cdr l)))))
+
+(define (top-level-env)
+ (if *top-level-lookup-closure*
+ (list *top-level-lookup-closure*)
+ '()))
+
+(define (top-level-env? env)
+ (or (null? env)
+ (procedure? (car env))))
+
+(define (map* fn . l) ; A map which accepts dotted lists (arg lists
+ (cond ; must be "isomorph"
+ ((null? (car l)) '())
+ ((pair? (car l)) (cons (apply fn (map car l))
+ (apply map* fn (map cdr l))))
+ (else (apply fn l))))
+
+(define (for-each* fn . l) ; A for-each which accepts dotted lists (arg lists
+ (cond ; must be "isomorph"
+ ((null? (car l)) '())
+ ((pair? (car l)) (apply fn (map car l)) (apply for-each* fn (map cdr l)))
+ (else (apply fn l))))
+
+(define (length* ls)
+ (do ((n 0 (+ 1 n))
+ (ls ls (cdr ls)))
+ ((not (pair? ls)) n)))
+
+(define (improper->proper ls)
+ (if (pair? ls)
+ (cons (car ls) (improper->proper (cdr ls)))
+ (list ls)))
HCoop / bpt / guile.git / commitdiff