From 14f1d9fec8091a5d29c3f2ac57b31c28825476cb Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Wed, 25 Oct 2000 14:51:33 +0000 Subject: [PATCH] *** empty log message *** --- ChangeLog | 7 + Makefile.am | 2 +- NEWS | 65 ++ configure.in | 2 +- libguile.h | 1 + libguile/ChangeLog | 35 + oop/ChangeLog | 4 + oop/Makefile.am | 33 + oop/goops.scm | 1503 ++++++++++++++++++++++++++++++++++ oop/goops/Makefile.am | 33 + oop/goops/active-slot.scm | 68 ++ oop/goops/compile.scm | 136 +++ oop/goops/composite-slot.scm | 84 ++ oop/goops/describe.scm | 202 +++++ oop/goops/dispatch.scm | 270 ++++++ oop/goops/internal.scm | 28 + oop/goops/save.scm | 876 ++++++++++++++++++++ oop/goops/stklos.scm | 98 +++ oop/goops/util.scm | 112 +++ 19 files changed, 3557 insertions(+), 2 deletions(-) create mode 100644 oop/ChangeLog create mode 100644 oop/Makefile.am create mode 100644 oop/goops.scm create mode 100644 oop/goops/Makefile.am create mode 100644 oop/goops/active-slot.scm create mode 100644 oop/goops/compile.scm create mode 100644 oop/goops/composite-slot.scm create mode 100644 oop/goops/describe.scm create mode 100644 oop/goops/dispatch.scm create mode 100644 oop/goops/internal.scm create mode 100644 oop/goops/save.scm create mode 100644 oop/goops/stklos.scm create mode 100644 oop/goops/util.scm diff --git a/ChangeLog b/ChangeLog index e45f5f71e..d9012543f 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,10 @@ +2000-10-25 Mikael Djurfeldt + + * 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 * libguile.h: #include "libguile/properties.h". diff --git a/Makefile.am b/Makefile.am index 97d238ee0..847e90e33 100644 --- a/Makefile.am +++ b/Makefile.am @@ -19,7 +19,7 @@ ## 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 diff --git a/NEWS b/NEWS index cb6e69f6e..a4e93984a 100644 --- a/NEWS +++ b/NEWS @@ -8,8 +8,73 @@ Changes since Guile 1.4: * 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 ) (y )) + (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) --> #< <2D-vector> 40241ac0> + <2D-vector> --> #< <2D-vector> 40241ac0> + (class-of 1) --> #< 401b2a98> + --> #< 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: diff --git a/configure.in b/configure.in index 09e897dee..39f848d3c 100644 --- a/configure.in +++ b/configure.in @@ -507,7 +507,7 @@ AC_SUBST(AWK) 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 " diff --git a/libguile.h b/libguile.h index 14a80703c..71e641564 100644 --- a/libguile.h +++ b/libguile.h @@ -78,6 +78,7 @@ extern "C" { #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" diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 6a1ce3a17..2845fdc77 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,37 @@ +2000-10-25 Mikael Djurfeldt + + 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 * gc.c (scm_igc): Remove references to scm_vector_set_length_x. @@ -59,6 +93,7 @@ * validated.h (SCM_VALIDATE_STRINGORSUBSTR): Deprecated. +>>>>>>> 1.1152 2000-10-20 Marius Vollmer * init.c (scm_init_guile_1, invoke_main_func): Call diff --git a/oop/ChangeLog b/oop/ChangeLog new file mode 100644 index 000000000..8dd08b4f9 --- /dev/null +++ b/oop/ChangeLog @@ -0,0 +1,4 @@ +2000-10-23 Mikael Djurfeldt + + * goops.scm (goops-error): Removed use of oldfmt. + diff --git a/oop/Makefile.am b/oop/Makefile.am new file mode 100644 index 000000000..0587c83be --- /dev/null +++ b/oop/Makefile.am @@ -0,0 +1,33 @@ +## 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) diff --git a/oop/goops.scm b/oop/goops.scm new file mode 100644 index 000000000..892cb9ab6 --- /dev/null +++ b/oop/goops.scm @@ -0,0 +1,1503 @@ +;;; 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 +;;;; + + +;;;; 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 . +;;;; + +(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) + + +(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 #: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) + + (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 ) + ;; Prevent redefinition of non-objects + (memq + (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 + (class-precedence-list class))) + supers)) + (append supers (list )) + 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 ) + (make #:name ',name) + (ensure-generic ,name ',name)))) + (else + `(define ,name (make #:name ',name)))))))) + +(define (make-generic . name) + (let ((name (and (pair? name) (car name)))) + (make #:name name))) + +(define (ensure-generic old-definition . name) + (let ((name (and (pair? name) (car name)))) + (cond ((is-a? old-definition ) old-definition) + ((procedure-with-setter? old-definition) + (make + #:name name + #:default (procedure old-definition) + #:setter (setter old-definition))) + ((procedure? old-definition) + (make #:name name #:default old-definition)) + (else (make #: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 ) + (is-a? (setter ,name) )) + (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 + #:name name + #:setter (make + #:name (and name (make-setter-name name)))))) + +(define (ensure-accessor proc . name) + (let ((name (and (pair? name) (car name)))) + (cond ((is-a? proc ) + (if (is-a? (setter proc) ) + proc + (upgrade-generic-with-setter proc (setter proc)))) + ((is-a? proc ) + (upgrade-generic-with-setter proc (make-generic name))) + ((procedure-with-setter? proc) + (make + #: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 + #: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 + #:specializers specializers + #:procedure procedure)) + +(define method + (letrec ((specializers + (lambda (ls) + (cond ((null? ls) (list ls)) + ((pair? ls) (cons (if (pair? (car ls)) + (cadar ls) + ') + (specializers (cdr ls)))) + (else '())))) + (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 + #: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 + #:specializers (list ) + #:procedure internal-add-method!)) + +(define-method add-method! ((proc ) (m )) + (if (generic-capability? proc) + (begin + (enable-primitive-generic! proc) + (add-method! proc m)) + (next-method))) + +(define-method add-method! ((pg ) (m )) + (add-method! (primitive-generic-generic pg) m)) + +(define-method add-method! (obj (m )) + (goops-error "~S is not a valid generic function" obj)) + +;;; +;;; {Access to meta objects} +;;; + +;;; +;;; Methods +;;; +(define-method method-source ((m )) + (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 "# file)) + +(define write-object (primitive-generic-generic write)) + +(define-method write ((o ) 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 ) file) + (let ((class (class-of o))) + (if (slot-bound? class 'name) + (begin + (display "# file)) + (next-method)))) + +(define-method write ((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 ) 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 ) 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 ) (o ) s) + (goops-error "Slot `~S' is unbound in object ~S" s o)) + +(define-method slot-unbound ((c ) s) + (goops-error "Slot `~S' is unbound in class ~S" s c)) + +(define-method slot-unbound ((o )) + (goops-error "Unbound slot in object ~S" o)) + +(define-method slot-missing ((c ) (o ) s) + (goops-error "No slot with name `~S' in object ~S" s o)) + +(define-method slot-missing ((c ) s) + (goops-error "No class slot with name `~S' in class ~S" s c)) + + +(define-method slot-missing ((c ) (o ) 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 ) args) + (goops-error "No next method when calling ~S\nwith arguments ~S" gf args)) + +(define-method no-applicable-method ((gf ) args) + (goops-error "No applicable method for ~S in call ~S" + gf (cons (generic-function-name gf) args))) + +(define-method no-method ((gf ) args) + (goops-error "No method defined for ~S" gf)) + +;;; +;;; {Cloning functions (from rdeline@CS.CMU.EDU)} +;;; + +(define-method shallow-clone ((self )) + (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 )) + (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 ) (new )) + ;; 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 )) + (for-each (lambda (m) + (if (is-a? m ) + (remove-method-in-classes! m))) + (class-direct-methods c))) + +;;; +;;; update-direct-method! +;;; + +(define-method update-direct-method! ((m ) + (old ) + (new )) + (let loop ((l (method-specializers m))) + ;; Note: the 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 ) + (old ) + (new )) + (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 ) slotdef) + (let ((init-thunk (cadr slotdef)) + (g-n-s (cddr slotdef))) + (make + #: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 ) slotdef) + (let ((g-n-s (cddr slotdef))) + (make + #:specializers (list class ) + #: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 )) + (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 . +;; + +(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 ) 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 ) s) + (goops-error "Allocation \"~S\" is unknown" (slot-definition-allocation s))) + +(define-method compute-slots ((class )) + (%compute-slots class)) + +;;; +;;; {Initialize} +;;; + +(define-method initialize ((object ) initargs) + (%initialize-object object initargs)) + +(define-method initialize ((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 ) initargs) + (next-method) + (initialize-object-procedure class initargs)) + +(define-method initialize ((owsc ) initargs) + (next-method) + (%set-object-setter! owsc (get-keyword #:setter initargs #f))) + +(define-method initialize ((entity ) initargs) + (next-method) + (initialize-object-procedure entity initargs)) + +(define-method initialize ((ews ) initargs) + (next-method) + (%set-object-setter! ews (get-keyword #:setter initargs #f))) + +(define-method initialize ((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 ) + (list (make + #:specializers + #:procedure + (lambda l + (apply previous-definition + l)))) + '())) + (if name + (set-procedure-property! generic 'name name)) + )) + +(define-method initialize ((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 ) 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 ) + (new-instance + )) + ;;not really important what we do, we just need a default method + new-instance) + +(define-method change-class ((old-instance ) (new-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 ) initargs) + (%allocate-instance class initargs)) + +(define-method make-instance ((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 functions (in this case we use a +;;; completely C hard-coded protocol). Apply-generic is used by +;;; goops for calls to subclasses of and . +;;; 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 ) 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 #:name 'compute-applicable-methods)) + +(define-method %%compute-applicable-methods ((gf ) args) + (%compute-applicable-methods gf args)) + +(set! compute-applicable-methods %%compute-applicable-methods) + +(define-method sort-applicable-methods ((gf ) 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 ) (m2 ) targs) + (%method-more-specific? m1 m2 targs)) + +(define-method apply-method ((gf ) methods build-next args) + (apply (method-procedure (car methods)) + (build-next (cdr methods) args) + args)) + +(define-method apply-methods ((gf ) (l ) 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 + )) + +;;; +;;; { and } +;;; + +;(autoload "active-slot" ) +;(autoload "composite-slot" ) +;(export ) + +;;; +;;; {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) diff --git a/oop/goops/Makefile.am b/oop/goops/Makefile.am new file mode 100644 index 000000000..73a77e474 --- /dev/null +++ b/oop/goops/Makefile.am @@ -0,0 +1,33 @@ +## 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) diff --git a/oop/goops/active-slot.scm b/oop/goops/active-slot.scm new file mode 100644 index 000000000..ca9424d0f --- /dev/null +++ b/oop/goops/active-slot.scm @@ -0,0 +1,68 @@ +;;; 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 +;;;; + + +;;;; 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 . +;;;; + +(define-module (oop goops active-slot) + :use-module (oop goops internal)) + +(export ) + +(define-class ()) + +(define-method compute-get-n-set ((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))) diff --git a/oop/goops/compile.scm b/oop/goops/compile.scm new file mode 100644 index 000000000..ab185f3c5 --- /dev/null +++ b/oop/goops/compile.scm @@ -0,0 +1,136 @@ +;;;; 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 +;;;; + + +(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)) + ))) diff --git a/oop/goops/composite-slot.scm b/oop/goops/composite-slot.scm new file mode 100644 index 000000000..4f44f0619 --- /dev/null +++ b/oop/goops/composite-slot.scm @@ -0,0 +1,84 @@ +;;; 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 +;;;; + + +;;;; 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 . +;;;; + +(define-module (oop goops composite-slot) + :use-module (oop goops)) + +(export ) + +;;; +;;; (define-class CLASS SUPERS +;;; ... +;;; (OBJECT ...) +;;; ... +;;; (SLOT #:allocation #:propagated +;;; #:propagate-to '(PROPAGATION ...)) +;;; ... +;;; #:metaclass ) +;;; +;;; 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 ()) + +(define-method compute-get-n-set ((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)))))))) diff --git a/oop/goops/describe.scm b/oop/goops/describe.scm new file mode 100644 index 000000000..c6e51084e --- /dev/null +++ b/oop/goops/describe.scm @@ -0,0 +1,202 @@ +;;; 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 +;;;; + + +;;;; 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 . +;;;; + +(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 )) + (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 )) + (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 )) + (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)) + "#")))) + (class-slots (class-of x))) + *unspecified*) + +;;; +;;; Describe for classes +;;; +(define-method describe ((x )) + (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 )) + (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 ) . 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") diff --git a/oop/goops/dispatch.scm b/oop/goops/dispatch.scm new file mode 100644 index 000000000..26d832a6e --- /dev/null +++ b/oop/goops/dispatch.scm @@ -0,0 +1,270 @@ +;;;; 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 +;;;; + + +(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 + ))))) diff --git a/oop/goops/internal.scm b/oop/goops/internal.scm new file mode 100644 index 000000000..6331ef6df --- /dev/null +++ b/oop/goops/internal.scm @@ -0,0 +1,28 @@ +;;; 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 +;;;; + + +(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))) diff --git a/oop/goops/save.scm b/oop/goops/save.scm new file mode 100644 index 000000000..148264dc4 --- /dev/null +++ b/oop/goops/save.scm @@ -0,0 +1,876 @@ +;;; 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 +;;;; + + +(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 )) #f) + +(define-method immediate? ((o )) #t) +(define-method immediate? ((o )) #t) +(define-method immediate? ((o )) #t) +(define-method immediate? ((o )) #t) +(define-method immediate? ((o )) #t) +(define-method immediate? ((o )) #t) + +;;; enumerate! OBJECT ENVIRONMENT +;;; +;;; Return #t if object is a literal. +;;; +(define-method enumerate! ((o ) env) #t) + +(define-method write-readably ((o ) 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 ) env) #f) + +;;; +;;; Vectors +;;; + +(define-method enumerate! ((o ) 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 ) 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 ) 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 ) 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(): 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 ) env) + (let ((literal? (enumerate-component! (car o) env))) + (and (enumerate-component! (cdr o) env) + literal?))) + +(define-method write-readably ((o ) 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 ) 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 ) 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 ) env) #f) + +(define-method write-readably ((o ) file env) + (display (class-name o) file)) + +;;; +;;; Generics +;;; + +;;; Currently, we don't support reading in generic functions +;;; + +(define-method enumerate! ((o ) env) #f) + +(define-method write-readably ((o ) file env) + (display (generic-function-name o) file)) + +;;; +;;; Method +;;; + +;;; Currently, we don't support reading in methods +;;; + +(define-method enumerate! ((o ) env) #f) + +(define-method write-readably ((o ) file env) + (goops-error "No read-syntax for defined")) + +;;; +;;; Environments +;;; + +(define-class () + (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 ) 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 () + (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 )) + #f) + +(define-method (binding o env) + (binding (object-info o env))) + +(define binding? binding) + +(define-method (literal? (info )) + #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 ))) + (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 ) (file ) . rest) + (let ((port (open-output-file file))) + (apply save-objects alist port rest) + (close-port port) + *unspecified*)) + +(define-method save-objects ((alist ) (file ) . rest) + (let ((excluded (if (>= (length rest) 1) (car rest) '())) + (uses (if (>= (length rest) 2) (cadr rest) '()))) + (let ((env (make #: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 )) + (let* ((port (open-input-file file)) + (objects (load-objects port))) + (close-port port) + objects)) + +(define-method load-objects ((file )) + (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))) diff --git a/oop/goops/stklos.scm b/oop/goops/stklos.scm new file mode 100644 index 000000000..be9594faa --- /dev/null +++ b/oop/goops/stklos.scm @@ -0,0 +1,98 @@ +;;;; 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 +;;;; + + +(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 )) + (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 ) + (is-a? ,name ))) + (define-generic ,name)) + (add-method! ,name (method ,@(cddr exp))))) + (else + `(begin + (define-generic ,name) + (add-method! ,name (method ,@(cddr exp))))))))))) diff --git a/oop/goops/util.scm b/oop/goops/util.scm new file mode 100644 index 000000000..0e6df4147 --- /dev/null +++ b/oop/goops/util.scm @@ -0,0 +1,112 @@ +;;;; 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 +;;;; + + +(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))) -- 2.20.1