diff options
Diffstat (limited to 'module/oop')
| -rw-r--r-- | module/oop/ChangeLog-2008 | 300 | ||||
| -rw-r--r-- | module/oop/goops.scm | 1701 | ||||
| -rw-r--r-- | module/oop/goops/accessors.scm | 72 | ||||
| -rw-r--r-- | module/oop/goops/active-slot.scm | 66 | ||||
| -rw-r--r-- | module/oop/goops/compile.scm | 81 | ||||
| -rw-r--r-- | module/oop/goops/composite-slot.scm | 82 | ||||
| -rw-r--r-- | module/oop/goops/describe.scm | 200 | ||||
| -rw-r--r-- | module/oop/goops/dispatch.scm | 269 | ||||
| -rw-r--r-- | module/oop/goops/internal.scm | 30 | ||||
| -rw-r--r-- | module/oop/goops/save.scm | 866 | ||||
| -rw-r--r-- | module/oop/goops/simple.scm | 31 | ||||
| -rw-r--r-- | module/oop/goops/stklos.scm | 76 | ||||
| -rw-r--r-- | module/oop/goops/util.scm | 71 |
13 files changed, 3845 insertions, 0 deletions
diff --git a/module/oop/ChangeLog-2008 b/module/oop/ChangeLog-2008 new file mode 100644 index 000000000..6727ef3fb --- /dev/null +++ b/module/oop/ChangeLog-2008 @@ -0,0 +1,300 @@ +2008-03-18 Ludovic Courtès <ludo@gnu.org> + + * goops/util.scm (mapappend): Now an alias for SRFI-1's + `append-map', which is more efficient. + (every, any): Used and re-exported from SRFI-1. + +2008-03-12 Ludovic Courtès <ludo@gnu.org> + + * goops/describe.scm (describe): Provide `describe' (symbol), + not `"describe"' (string). Reported by David Pirotte + <david@altosw.be>. + +2007-05-05 Ludovic Courtès <ludo@chbouib.org> + + * goops/internal.scm: Use the public module API rather than hack + with `%module-public-interface', `nested-ref', et al. + +2005-03-24 Mikael Djurfeldt <djurfeldt@nada.kth.se> + + * accessors.scm, simple.scm: New files. + + * goops.scm (standard-define-class): Removed; Export + define-class as standard-define-class. + +2005-01-18 Marius Vollmer <marius.vollmer@uni-dortmund.de> + + * goops.scm (class-of): Changed from being re-exported to just + being exported. + +2004-02-08 Mikael Djurfeldt <djurfeldt@nada.kth.se> + + * Makefile.am, goops/Makefile.am (TAGS_FILES): Use this variable + instead of ETAGS_ARGS so that TAGS can be built using separate + build directory. + +2004-01-12 Marius Vollmer <mvo@zagadka.de> + + * goops.scm (compute-get-n-set): Use '#:' in error message instead + of ':'. Thanks to Richard Todd! + +2003-04-20 Mikael Djurfeldt <djurfeldt@nada.kth.se> + + * goops.scm (compute-getters-n-setters): Allow for primitive + procedure thunks. (Thanks to Neil W. Van Dyke.) + +2003-04-19 Mikael Djurfeldt <djurfeldt@nada.kth.se> + + * goops/dispatch.scm (cache-hashval): Corrected termination + condition for hashval computation. (Previously, it made erroneous + assumptions about the representation of environments; Thanks to + Andreas Rottmann.) + +2003-04-17 Mikael Djurfeldt <djurfeldt@nada.kth.se> + + * goops.scm (compute-getters-n-setters): Check for bad init-thunk. + (eqv?): Added default method. + (equal?): New default method which uses eqv?. + +2003-04-15 Mikael Djurfeldt <djurfeldt@nada.kth.se> + + * goops.scm (compute-getter-method): For custom getter: Check + boundness even if there is an init-thunk. (The getter can return + #<unbound> even if the slot has been set before.) + (remove-class-accessors!): Also remove accessor-method from its + accessor. + +2003-04-13 Mikael Djurfeldt <djurfeldt@nada.kth.se> + + * goops.scm (compute-getters-n-setters/verify-accessors): Better + check of format of value returned by compute-get-n-set. + (compute-getters-n-setters): Extended format of slot + getters-n-setters to indicate position and size of slot memory + allocated in instances. + +2003-04-05 Marius Vollmer <mvo@zagadka.de> + + * Changed license terms to the plain LGPL thru-out. + +2003-03-19 Mikael Djurfeldt <mdj@kvast.blakulla.net> + + * goops.scm (process-class-pre-define-accessor): Temporary kludge + to fix a problem introduced by my previous change. + +2003-03-17 Mikael Djurfeldt <djurfeldt@nada.kth.se> + + * goops.scm (process-class-pre-define-generic, + process-class-pre-define-accessor, process-define-generic, + process-define-accessor): New functions. + (define-class-pre-definition): Use + process-class-pre-define-generic and + process-class-pre-define-accessor; Make sure not to create a new + local variable if the variable has been imported. + (define-generic): Use process-define-generic. + (define-accessor): Use process-define-accessor. + +2003-03-12 Mikael Djurfeldt <djurfeldt@nada.kth.se> + + * goops.scm (merge-generics): Make sure not to merge a gf with + itself. That would be the cause of a real binding collision. + +2003-03-11 Mikael Djurfeldt <djurfeldt@nada.kth.se> + + * goops/util.scm (filter): Removed. (Now supplied by core.) + + * goops.scm (define-extended-generics): New syntax. + (<class> <operator-class> <entity-class> <entity>): Marked as + replacements. + (upgrade-accessor): Renamed from upgrade-generic-with-setter. + (ensure-accessor, upgrade-accessor): Rewritten to accomodate the + new <accessor> class. + (merge-accessors): Provide for merging of accessors imported from + different modules under the same name. + +2003-03-07 Mikael Djurfeldt <djurfeldt@nada.kth.se> + + * goops.scm (equal?): Define default method. + (merge-generics): Provide for merging of generic functions + imported into a module under the same name. + +2003-01-18 Mikael Djurfeldt <djurfeldt@nada.kth.se> + + * goops.scm (method): Construct a new copy of the constant '('()) + for every macro invocation. + +2003-01-08 Mikael Djurfeldt <djurfeldt@nada.kth.se> + + * goops.scm (upgrade-generic-with-setter, + compute-new-list-of-methods): Use methods slot directly instead of + generic-function-methods. + (upgrade-generic-with-setter): Handle <extended-generic>:s. + (define-extended-generic): New syntax. + (make-extended-generic): New function. + +2002-12-08 Rob Browning <rlb@defaultvalue.org> + + * Makefile.am (subpkgdatadir): VERSION -> GUILE_EFFECTIVE_VERSION. + + * goops/Makefile.am (subpkgdatadir): VERSION -> + GUILE_EFFECTIVE_VERSION. + +2002-11-16 Dirk Herrmann <D.Herrmann@tu-bs.de> + + * goops.scm (standard-define-class): Changed definition to form + a 'real' macro definition. + +2002-07-13 Dirk Herrmann <D.Herrmann@tu-bs.de> + + * goops.scm (define-generic, define-accessor): Make sure that + define-generic and define-accessor will continue to work when + mmacros are expanded before execution. + +2002-07-13 Dirk Herrmann <D.Herrmann@tu-bs.de> + + * goops.scm (define-class): Make sure that define-class will + continue to work when mmacros are expanded before execution. + +2002-07-08 Dirk Herrmann <D.Herrmann@tu-bs.de> + + * goops.scm (define-generic, define-accessor): Make sure that + implicit redefines only happen on top level. + + * goops.scm (define-class, define-generic, define-accessor), + goops/stklos.scm (define-class): Use mmacros instead of macros. + +2002-07-07 Dirk Herrmann <D.Herrmann@tu-bs.de> + + * goops/save.scm (restore): Replaced "macro" by mmacro. + +2001-10-21 Mikael Djurfeldt <mdj@linnaeus> + + * goops.scm, goops/active-slot.scm, goops/compile.scm, + goops/composite-slot.scm, goops/describe.scm, goops/dispatch.scm, + goops/old-define-method.scm, goops/save.scm, goops/util.scm: Move + module the system directives `export', `export-syntax', + `re-export' and `re-export-syntax' into the `define-module' form. + This is the recommended way of exporting bindings. + +2001-08-25 Marius Vollmer <mvo@zagadka.ping.de> + + * Makefile.am, goops/Makefile.am: (AUTOMAKE_OPTIONS): Change + "foreign" to "gnu". + +2001-07-29 Marius Vollmer <mvo@zagadka.ping.de> + + * goops/dispatch.scm (hashset-index): Renumbered, since the vcell + slot of structs has been removed. + +2001-07-18 Martin Grabmueller <mgrabmue@cs.tu-berlin.de> + + * goops/util.scm: Updated copyright notice. + +2001-07-17 Martin Grabmueller <mgrabmue@cs.tu-berlin.de> + + * goops/save.scm: Use `re-export' instead of `export' when + re-exporting `make-unbound'. + +2001-06-05 Marius Vollmer <mvo@zagadka.ping.de> + + * goops.scm: Use `re-export' instead of `export' when re-exporting + `class-of'. + +2001-05-19 Marius Vollmer <mvo@zagadka.ping.de> + + * goops.scm: Call `%init-goops-builtins' instead of using the + `(oop goops goopscore)' module. + +2001-05-10 Marius Vollmer <mvo@zagadka.ping.de> + + * goops/compile.scm (compile-method): Insert comment that + `procedure-source' can not be guaranteed to be reliable or + efficient. + +2001-05-05 Marius Vollmer <mvo@zagadka.ping.de> + + * goops.scm (initialize-object-procedure): Use + `valid-object-procedure?' instead of explicit tag magic. + (object-procedure-tags): Removed. + + * goops/util.scm (top-level-env): Use `current-module' instead of + the deprecated *top-level-lookup-closure*. + +2001-04-28 Rob Browning <rlb@cs.utexas.edu> + + * goops/save.scm (write-readably): rename list* to cons*. + + * goops.scm (method): rename list* to cons*. + +2001-04-10 Mikael Djurfeldt <mdj@linnaeus.mit.edu> + + * goops/Makefile.am, goops/goopscore.scm: Reverted changes of + 2001-04-03, 2001-03-09. + +2001-04-03 Keisuke Nishida <kxn30@po.cwru.edu> + + * goops/Makefile.am (goops_sources): Include goopscore.scm. + Thanks to Dale P. Smith. + +2001-03-29 Keisuke Nishida <kxn30@po.cwru.edu> + + * goops/goopscore.scm: New file. + +2001-03-09 Mikael Djurfeldt <mdj@linnaeus.mit.edu> + + * goops.scm (define-method): Only accept new syntax. + + * Makefile.am: Added old-define-method.scm. + + * goops/old-define-method.scm: New file. + + * goops.scm, goops/save.scm, goops/composite-slot.scm, + goops/active-slot.scm: Use new method syntax. + +2001-03-04 Mikael Djurfeldt <mdj@linnaeus.mit.edu> + + * goops/compile.scm (compile-method): Tag method closure for body + expansion. + + * goops.scm (change-object-class): Quote empty list constants. + (method): Reverted previous change (enclosing body); + Quote empty list. + (initialize <method>): Supply `dummy-procedure' as default instead + of creating a new closure. + + * goops/internal.scm: Re-export (oop goops) without copying + bindings. + +2001-02-23 Keisuke Nishida <kxn30@po.cwru.edu> + + * goops.scm (method): Enclosed BODY by `(let () ...)'. + This allows local defines at the beginning of methods. + +2000-12-15 Dirk Herrmann <D.Herrmann@tu-bs.de> + + * goops/save.scm (load-objects): eval-in-module is deprecated. + Use eval instead. + +2000-11-24 Dirk Herrmann <D.Herrmann@tu-bs.de> + + * goops.scm: Don't export removed %logand any more. + + * goops/dispatch.scm (cache-try-hash!): Use logand instead of + %logand. + +2000-11-06 Mikael Djurfeldt <mdj@linnaeus.mit.edu> + + * goops.scm (internal-add-method!): Set n-specialized of a generic + function to the number of specializers regardless if it has rest + args or not. + + * goops/dispatch.scm (method-cache-install!): Use n-specialized + + 1 args for type matching. (Thanks to Lars J. Aas.) + +2000-10-23 Mikael Djurfeldt <mdj@linnaeus.mit.edu> + + * goops.scm (goops-error): Removed use of oldfmt. + + +;; Local Variables: +;; coding: utf-8 +;; End: diff --git a/module/oop/goops.scm b/module/oop/goops.scm new file mode 100644 index 000000000..c1754da3e --- /dev/null +++ b/module/oop/goops.scm @@ -0,0 +1,1701 @@ +;;; installed-scm-file + +;;;; Copyright (C) 1998,1999,2000,2001,2002, 2003, 2006 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +;;;; + + +;;;; This software is a derivative work of other copyrighted softwares; the +;;;; copyright notices of these softwares are placed in the file COPYRIGHTS +;;;; +;;;; This file is based upon stklos.stk from the STk distribution by +;;;; Erick Gallesio <eg@unice.fr>. +;;;; + +(define-module (oop goops) + :use-module (srfi srfi-1) + :export-syntax (define-class class standard-define-class + define-generic define-accessor define-method + define-extended-generic define-extended-generics + method) + :export (goops-version is-a? class-of + ensure-metaclass ensure-metaclass-with-supers + make-class + make-generic ensure-generic + make-extended-generic + make-accessor ensure-accessor + add-method! + class-slot-ref class-slot-set! slot-unbound slot-missing + slot-definition-name slot-definition-options + slot-definition-allocation + slot-definition-getter slot-definition-setter + slot-definition-accessor + slot-definition-init-value slot-definition-init-form + slot-definition-init-thunk slot-definition-init-keyword + slot-init-function class-slot-definition + method-source + compute-cpl compute-std-cpl compute-get-n-set compute-slots + compute-getter-method compute-setter-method + allocate-instance initialize make-instance make + no-next-method no-applicable-method no-method + change-class update-instance-for-different-class + shallow-clone deep-clone + class-redefinition + apply-generic apply-method apply-methods + compute-applicable-methods %compute-applicable-methods + method-more-specific? sort-applicable-methods + class-subclasses class-methods + goops-error + min-fixnum max-fixnum + ;;; *fixme* Should go into goops.c + instance? slot-ref-using-class + slot-set-using-class! slot-bound-using-class? + slot-exists-using-class? slot-ref slot-set! slot-bound? + class-name class-direct-supers class-direct-subclasses + class-direct-methods class-direct-slots class-precedence-list + class-slots class-environment + generic-function-name + generic-function-methods method-generic-function + method-specializers method-formals + primitive-generic-generic enable-primitive-generic! + method-procedure accessor-method-slot-definition + slot-exists? make find-method get-keyword) + :replace (<class> <operator-class> <entity-class> <entity>) + :no-backtrace) + +(define *goops-module* (current-module)) + +;; First initialize the builtin part of GOOPS +(eval-when (eval load compile) + (%init-goops-builtins)) + +;; Then load the rest of GOOPS +(use-modules (oop goops util) + (oop goops dispatch) + (oop goops compile)) + + +(eval-when (eval load compile) + (define min-fixnum (- (expt 2 29))) + (define max-fixnum (- (expt 2 29) 1))) + +;; +;; goops-error +;; +(define (goops-error format-string . args) + (save-stack) + (scm-error 'goops-error #f format-string args '())) + +;; +;; is-a? +;; +(define (is-a? obj class) + (and (memq class (class-precedence-list (class-of obj))) #t)) + + +;;; +;;; {Meta classes} +;;; + +(define ensure-metaclass-with-supers + (let ((table-of-metas '())) + (lambda (meta-supers) + (let ((entry (assoc meta-supers table-of-metas))) + (if entry + ;; Found a previously created metaclass + (cdr entry) + ;; Create a new meta-class which inherit from "meta-supers" + (let ((new (make <class> #:dsupers meta-supers + #:slots '() + #:name (gensym "metaclass")))) + (set! table-of-metas (cons (cons meta-supers new) table-of-metas)) + new)))))) + +(define (ensure-metaclass supers env) + (if (null? supers) + <class> + (let* ((all-metas (map (lambda (x) (class-of x)) supers)) + (all-cpls (append-map (lambda (m) + (cdr (class-precedence-list m))) + all-metas)) + (needed-metas '())) + ;; Find the most specific metaclasses. The new metaclass will be + ;; a subclass of these. + (for-each + (lambda (meta) + (if (and (not (member meta all-cpls)) + (not (member meta needed-metas))) + (set! needed-metas (append needed-metas (list meta))))) + all-metas) + ;; Now return a subclass of the metaclasses we found. + (if (null? (cdr needed-metas)) + (car needed-metas) ; If there's only one, just use it. + (ensure-metaclass-with-supers needed-metas))))) + +;;; +;;; {Classes} +;;; + +;;; (define-class NAME (SUPER ...) SLOT-DEFINITION ... OPTION ...) +;;; +;;; SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...) +;;; OPTION ::= KEYWORD VALUE +;;; + +(define (kw-do-map mapper f kwargs) + (define (keywords l) + (cond + ((null? l) '()) + ((or (null? (cdr l)) (not (keyword? (car l)))) + (goops-error "malformed keyword arguments: ~a" kwargs)) + (else (cons (car l) (keywords (cddr l)))))) + (define (args l) + (if (null? l) '() (cons (cadr l) (args (cddr l))))) + ;; let* to check keywords first + (let* ((k (keywords kwargs)) + (a (args kwargs))) + (mapper f k a))) + +(define (make-class supers slots . options) + (let ((env (or (get-keyword #:environment options #f) + (top-level-env)))) + (let* ((name (get-keyword #:name options (make-unbound))) + (supers (if (not (or-map (lambda (class) + (memq <object> + (class-precedence-list class))) + supers)) + (append supers (list <object>)) + supers)) + (metaclass (or (get-keyword #:metaclass options #f) + (ensure-metaclass supers env)))) + + ;; Verify that all direct slots are different and that we don't inherit + ;; several time from the same class + (let ((tmp1 (find-duplicate supers)) + (tmp2 (find-duplicate (map slot-definition-name slots)))) + (if tmp1 + (goops-error "make-class: super class ~S is duplicate in class ~S" + tmp1 name)) + (if tmp2 + (goops-error "make-class: slot ~S is duplicate in class ~S" + tmp2 name))) + + ;; Everything seems correct, build the class + (apply make metaclass + #:dsupers supers + #:slots slots + #:name name + #:environment env + options)))) + +;;; (class (SUPER ...) SLOT-DEFINITION ... OPTION ...) +;;; +;;; SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...) +;;; OPTION ::= KEYWORD VALUE +;;; +(define-macro (class supers . slots) + (define (make-slot-definition-forms slots) + (map + (lambda (def) + (cond + ((pair? def) + `(list ',(car def) + ,@(kw-do-map append-map + (lambda (kw arg) + (case kw + ((#:init-form) + `(#:init-form ',arg + #:init-thunk (lambda () ,arg))) + (else (list kw arg)))) + (cdr def)))) + (else + `(list ',def)))) + slots)) + (if (not (list? supers)) + (goops-error "malformed superclass list: ~S" supers)) + (let ((slot-defs (cons #f '())) + (slots (take-while (lambda (x) (not (keyword? x))) slots)) + (options (or (find-tail keyword? slots) '()))) + `(make-class + ;; evaluate super class variables + (list ,@supers) + ;; evaluate slot definitions, except the slot name! + (list ,@(make-slot-definition-forms slots)) + ;; evaluate class options + ,@options))) + +(define-syntax define-class-pre-definition + (lambda (x) + (syntax-case x () + ((_ (k arg rest ...) out ...) + (keyword? (syntax->datum (syntax k))) + (case (syntax->datum (syntax k)) + ((#:getter #:setter) + (syntax + (define-class-pre-definition (rest ...) + out ... + (if (or (not (defined? 'arg)) + (not (is-a? arg <generic>))) + (toplevel-define! + 'arg + (ensure-generic (if (defined? 'arg) arg #f) 'arg)))))) + ((#:accessor) + (syntax + (define-class-pre-definition (rest ...) + out ... + (if (or (not (defined? 'arg)) + (not (is-a? arg <accessor>))) + (toplevel-define! + 'arg + (ensure-accessor (if (defined? 'arg) arg #f) 'arg)))))) + (else + (syntax + (define-class-pre-definition (rest ...) out ...))))) + ((_ () out ...) + (syntax (begin out ...)))))) + +;; Some slot options require extra definitions to be made. In +;; particular, we want to make sure that the generic function objects +;; which represent accessors exist before `make-class' tries to add +;; methods to them. +(define-syntax define-class-pre-definitions + (lambda (x) + (syntax-case x () + ((_ () out ...) + (syntax (begin out ...))) + ((_ (slot rest ...) out ...) + (keyword? (syntax->datum (syntax slot))) + (syntax (begin out ...))) + ((_ (slot rest ...) out ...) + (identifier? (syntax slot)) + (syntax (define-class-pre-definitions (rest ...) + out ...))) + ((_ ((slotname slotopt ...) rest ...) out ...) + (syntax (define-class-pre-definitions (rest ...) + out ... (define-class-pre-definition (slotopt ...)))))))) + +(define-syntax define-class + (syntax-rules () + ((_ name supers slot ...) + (begin + (define-class-pre-definitions (slot ...)) + (if (and (defined? 'name) + (is-a? name <class>) + (memq <object> (class-precedence-list name))) + (class-redefinition name + (class supers slot ... #:name 'name)) + (toplevel-define! 'name (class supers slot ... #:name 'name))))))) + +(define-syntax standard-define-class + (syntax-rules () + ((_ arg ...) (define-class arg ...)))) + +;;; +;;; {Generic functions and accessors} +;;; + +;; Apparently the desired semantics are that we extend previous +;; procedural definitions, but that if `name' was already a generic, we +;; overwrite its definition. +(define-macro (define-generic name) + (if (not (symbol? name)) + (goops-error "bad generic function name: ~S" name)) + `(define ,name + (if (and (defined? ',name) (is-a? ,name <generic>)) + (make <generic> #:name ',name) + (ensure-generic (if (defined? ',name) ,name #f) ',name)))) + +(define-macro (define-extended-generic name val) + (if (not (symbol? name)) + (goops-error "bad generic function name: ~S" name)) + `(define ,name (make-extended-generic ,val ',name))) + +(define-macro (define-extended-generics names . args) + (let ((prefixes (get-keyword #:prefix args #f))) + (if prefixes + `(begin + ,@(map (lambda (name) + `(define-extended-generic ,name + (list ,@(map (lambda (prefix) + (symbol-append prefix name)) + prefixes)))) + names)) + (goops-error "no prefixes supplied")))) + +(define (make-generic . name) + (let ((name (and (pair? name) (car name)))) + (make <generic> #:name name))) + +(define (make-extended-generic gfs . name) + (let* ((name (and (pair? name) (car name))) + (gfs (if (pair? gfs) gfs (list gfs))) + (gws? (any (lambda (gf) (is-a? gf <generic-with-setter>)) gfs))) + (let ((ans (if gws? + (let* ((sname (and name (make-setter-name name))) + (setters + (append-map (lambda (gf) + (if (is-a? gf <generic-with-setter>) + (list (ensure-generic (setter gf) + sname)) + '())) + gfs)) + (es (make <extended-generic-with-setter> + #:name name + #:extends gfs + #:setter (make <extended-generic> + #:name sname + #:extends setters)))) + (extended-by! setters (setter es)) + es) + (make <extended-generic> + #:name name + #:extends gfs)))) + (extended-by! gfs ans) + ans))) + +(define (extended-by! gfs eg) + (for-each (lambda (gf) + (slot-set! gf 'extended-by + (cons eg (slot-ref gf 'extended-by)))) + gfs)) + +(define (not-extended-by! gfs eg) + (for-each (lambda (gf) + (slot-set! gf 'extended-by + (delq! eg (slot-ref gf 'extended-by)))) + gfs)) + +(define (ensure-generic old-definition . name) + (let ((name (and (pair? name) (car name)))) + (cond ((is-a? old-definition <generic>) old-definition) + ((procedure-with-setter? old-definition) + (make <generic-with-setter> + #:name name + #:default (procedure old-definition) + #:setter (setter old-definition))) + ((procedure? old-definition) + (make <generic> #:name name #:default old-definition)) + (else (make <generic> #:name name))))) + +;; same semantics as <generic> +(define-syntax define-accessor + (syntax-rules () + ((_ name) + (define name + (cond ((not (defined? 'name)) (ensure-accessor #f 'name)) + ((is-a? name <accessor>) (make <accessor> #:name 'name)) + (else (ensure-accessor name 'name))))))) + +(define (make-setter-name name) + (string->symbol (string-append "setter:" (symbol->string name)))) + +(define (make-accessor . name) + (let ((name (and (pair? name) (car name)))) + (make <accessor> + #:name name + #:setter (make <generic> + #:name (and name (make-setter-name name)))))) + +(define (ensure-accessor proc . name) + (let ((name (and (pair? name) (car name)))) + (cond ((and (is-a? proc <accessor>) + (is-a? (setter proc) <generic>)) + proc) + ((is-a? proc <generic-with-setter>) + (upgrade-accessor proc (setter proc))) + ((is-a? proc <generic>) + (upgrade-accessor proc (make-generic name))) + ((procedure-with-setter? proc) + (make <accessor> + #:name name + #:default (procedure proc) + #:setter (ensure-generic (setter proc) name))) + ((procedure? proc) + (ensure-accessor (ensure-generic proc name) name)) + (else + (make-accessor name))))) + +(define (upgrade-accessor generic setter) + (let ((methods (slot-ref generic 'methods)) + (gws (make (if (is-a? generic <extended-generic>) + <extended-generic-with-setter> + <accessor>) + #:name (generic-function-name generic) + #:extended-by (slot-ref generic 'extended-by) + #:setter setter))) + (if (is-a? generic <extended-generic>) + (let ((gfs (slot-ref generic 'extends))) + (not-extended-by! gfs generic) + (slot-set! gws 'extends gfs) + (extended-by! gfs gws))) + ;; Steal old methods + (for-each (lambda (method) + (slot-set! method 'generic-function gws)) + methods) + (slot-set! gws 'methods methods) + gws)) + +;;; +;;; {Methods} +;;; + +(define (toplevel-define! name val) + (module-define! (current-module) name val)) + +(define-syntax define-method + (syntax-rules (setter) + ((_ ((setter name) . args) body ...) + (begin + (if (or (not (defined? 'name)) + (not (is-a? name <accessor>))) + (toplevel-define! 'name + (ensure-accessor + (if (defined? 'name) name #f) 'name))) + (add-method! (setter name) (method args body ...)))) + ((_ (name . args) body ...) + (begin + ;; FIXME: this code is how it always was, but it's quite cracky: + ;; it will only define the generic function if it was undefined + ;; before (ok), or *was defined to #f*. The latter is crack. But + ;; there are bootstrap issues about fixing this -- change it to + ;; (is-a? name <generic>) and see. + (if (or (not (defined? 'name)) + (not name)) + (toplevel-define! 'name (make <generic> #:name 'name))) + (add-method! name (method args body ...)))))) + +(define-syntax method + (lambda (x) + (define (parse-args args) + (let lp ((ls args) (formals '()) (specializers '())) + (syntax-case ls () + (((f s) . rest) + (and (identifier? (syntax f)) (identifier? (syntax s))) + (lp (syntax rest) + (cons (syntax f) formals) + (cons (syntax s) specializers))) + ((f . rest) + (identifier? (syntax f)) + (lp (syntax rest) + (cons (syntax f) formals) + (cons (syntax <top>) specializers))) + (() + (list (reverse formals) + (reverse (cons (syntax '()) specializers)))) + (tail + (identifier? (syntax tail)) + (list (append (reverse formals) (syntax tail)) + (reverse (cons (syntax <top>) specializers))))))) + + (define (find-free-id exp referent) + (syntax-case exp () + ((x . y) + (or (find-free-id (syntax x) referent) + (find-free-id (syntax y) referent))) + (x + (identifier? (syntax x)) + (let ((id (datum->syntax (syntax x) referent))) + (and (free-identifier=? (syntax x) id) id))) + (_ #f))) + + (define (compute-procedure formals body) + (syntax-case body () + ((body0 ...) + (with-syntax ((formals formals)) + (syntax (lambda formals body0 ...)))))) + + (define (->proper args) + (let lp ((ls args) (out '())) + (syntax-case ls () + ((x . xs) (lp (syntax xs) (cons (syntax x) out))) + (() (reverse out)) + (tail (reverse (cons (syntax tail) out)))))) + + (define (compute-make-procedure formals body next-method) + (syntax-case body () + ((body ...) + (with-syntax ((next-method next-method)) + (syntax-case formals () + ((formal ...) + (syntax + (lambda (real-next-method) + (lambda (formal ...) + (let ((next-method (lambda args + (if (null? args) + (real-next-method formal ...) + (apply real-next-method args))))) + body ...))))) + (formals + (with-syntax (((formal ...) (->proper (syntax formals)))) + (syntax + (lambda (real-next-method) + (lambda formals + (let ((next-method (lambda args + (if (null? args) + (apply real-next-method formal ...) + (apply real-next-method args))))) + body ...))))))))))) + + (define (compute-procedures formals body) + ;; So, our use of this is broken, because it operates on the + ;; pre-expansion source code. It's equivalent to just searching + ;; for referent in the datums. Ah well. + (let ((id (find-free-id body 'next-method))) + (if id + ;; return a make-procedure + (values (syntax #f) + (compute-make-procedure formals body id)) + (values (compute-procedure formals body) + (syntax #f))))) + + (syntax-case x () + ((_ args) (syntax (method args (if #f #f)))) + ((_ args body0 body1 ...) + (with-syntax (((formals (specializer ...)) (parse-args (syntax args)))) + (call-with-values + (lambda () + (compute-procedures (syntax formals) (syntax (body0 body1 ...)))) + (lambda (procedure make-procedure) + (with-syntax ((procedure procedure) + (make-procedure make-procedure)) + (syntax + (make <method> + #:specializers (cons* specializer ...) + #:formals 'formals + #:body '(body0 body1 ...) + #:make-procedure make-procedure + #:procedure procedure)))))))))) + +;;; +;;; {add-method!} +;;; + +(define (add-method-in-classes! m) + ;; Add method in all the classes which appears in its specializers list + (for-each* (lambda (x) + (let ((dm (class-direct-methods x))) + (if (not (memq m dm)) + (slot-set! x 'direct-methods (cons m dm))))) + (method-specializers m))) + +(define (remove-method-in-classes! m) + ;; Remove method in all the classes which appears in its specializers list + (for-each* (lambda (x) + (slot-set! x + 'direct-methods + (delv! m (class-direct-methods x)))) + (method-specializers m))) + +(define (compute-new-list-of-methods gf new) + (let ((new-spec (method-specializers new)) + (methods (slot-ref gf 'methods))) + (let loop ((l methods)) + (if (null? l) + (cons new methods) + (if (equal? (method-specializers (car l)) new-spec) + (begin + ;; This spec. list already exists. Remove old method from dependents + (remove-method-in-classes! (car l)) + (set-car! l new) + methods) + (loop (cdr l))))))) + +(define internal-add-method! + (method ((gf <generic>) (m <method>)) + (slot-set! m 'generic-function gf) + (slot-set! gf 'methods (compute-new-list-of-methods gf m)) + (let ((specializers (slot-ref m 'specializers))) + (slot-set! gf 'n-specialized + (max (length* specializers) + (slot-ref gf 'n-specialized)))) + (%invalidate-method-cache! gf) + (add-method-in-classes! m) + *unspecified*)) + +(define-generic add-method!) + +((method-procedure internal-add-method!) add-method! internal-add-method!) + +(define-method (add-method! (proc <procedure>) (m <method>)) + (if (generic-capability? proc) + (begin + (enable-primitive-generic! proc) + (add-method! proc m)) + (next-method))) + +(define-method (add-method! (pg <primitive-generic>) (m <method>)) + (add-method! (primitive-generic-generic pg) m)) + +(define-method (add-method! obj (m <method>)) + (goops-error "~S is not a valid generic function" obj)) + +;;; +;;; {Access to meta objects} +;;; + +;;; +;;; Methods +;;; +(define-method (method-source (m <method>)) + (let* ((spec (map* class-name (slot-ref m 'specializers))) + (src (procedure-source (slot-ref m 'procedure)))) + (and src + (let ((args (cadr src)) + (body (cddr src))) + (cons 'method + (cons (map* list args spec) + body)))))) + +(define-method (method-formals (m <method>)) + (slot-ref m 'formals)) + +;;; +;;; Slots +;;; +(define slot-definition-name car) + +(define slot-definition-options cdr) + +(define (slot-definition-allocation s) + (get-keyword #:allocation (cdr s) #:instance)) + +(define (slot-definition-getter s) + (get-keyword #:getter (cdr s) #f)) + +(define (slot-definition-setter s) + (get-keyword #:setter (cdr s) #f)) + +(define (slot-definition-accessor s) + (get-keyword #:accessor (cdr s) #f)) + +(define (slot-definition-init-value s) + ;; can be #f, so we can't use #f as non-value + (get-keyword #:init-value (cdr s) (make-unbound))) + +(define (slot-definition-init-form s) + (get-keyword #:init-form (cdr s) (make-unbound))) + +(define (slot-definition-init-thunk s) + (get-keyword #:init-thunk (cdr s) #f)) + +(define (slot-definition-init-keyword s) + (get-keyword #:init-keyword (cdr s) #f)) + +(define (class-slot-definition class slot-name) + (assq slot-name (class-slots class))) + +(define (slot-init-function class slot-name) + (cadr (assq slot-name (slot-ref class 'getters-n-setters)))) + + +;;; +;;; {Standard methods used by the C runtime} +;;; + +;;; Methods to compare objects +;;; + +(define-method (eqv? x y) #f) +(define-method (equal? x y) (eqv? x y)) + +;;; +;;; methods to display/write an object +;;; + +; Code for writing objects must test that the slots they use are +; bound. Otherwise a slot-unbound method will be called and will +; conduct to an infinite loop. + +;; Write +(define (display-address o file) + (display (number->string (object-address o) 16) file)) + +(define-method (write o file) + (display "#<instance " file) + (display-address o file) + (display #\> file)) + +(define write-object (primitive-generic-generic write)) + +(define-method (write (o <object>) file) + (let ((class (class-of o))) + (if (slot-bound? class 'name) + (begin + (display "#<" file) + (display (class-name class) file) + (display #\space file) + (display-address o file) + (display #\> file)) + (next-method)))) + +(define-method (write (o <foreign-object>) file) + (let ((class (class-of o))) + (if (slot-bound? class 'name) + (begin + (display "#<foreign-object " file) + (display (class-name class) file) + (display #\space file) + (display-address o file) + (display #\> file)) + (next-method)))) + +(define-method (write (class <class>) file) + (let ((meta (class-of class))) + (if (and (slot-bound? class 'name) + (slot-bound? meta 'name)) + (begin + (display "#<" file) + (display (class-name meta) file) + (display #\space file) + (display (class-name class) file) + (display #\space file) + (display-address class file) + (display #\> file)) + (next-method)))) + +(define-method (write (gf <generic>) file) + (let ((meta (class-of gf))) + (if (and (slot-bound? meta 'name) + (slot-bound? gf 'methods)) + (begin + (display "#<" file) + (display (class-name meta) file) + (let ((name (generic-function-name gf))) + (if name + (begin + (display #\space file) + (display name file)))) + (display " (" file) + (display (length (generic-function-methods gf)) file) + (display ")>" file)) + (next-method)))) + +(define-method (write (o <method>) file) + (let ((meta (class-of o))) + (if (and (slot-bound? meta 'name) + (slot-bound? o 'specializers)) + (begin + (display "#<" file) + (display (class-name meta) file) + (display #\space file) + (display (map* (lambda (spec) + (if (slot-bound? spec 'name) + (slot-ref spec 'name) + spec)) + (method-specializers o)) + file) + (display #\space file) + (display-address o file) + (display #\> file)) + (next-method)))) + +;; Display (do the same thing as write by default) +(define-method (display o file) + (write-object o file)) + +;;; +;;; Handling of duplicate bindings in the module system +;;; + +(define-method (merge-generics (module <module>) + (name <symbol>) + (int1 <module>) + (val1 <top>) + (int2 <module>) + (val2 <top>) + (var <top>) + (val <top>)) + #f) + +(define-method (merge-generics (module <module>) + (name <symbol>) + (int1 <module>) + (val1 <generic>) + (int2 <module>) + (val2 <generic>) + (var <top>) + (val <boolean>)) + (and (not (eq? val1 val2)) + (make-variable (make-extended-generic (list val2 val1) name)))) + +(define-method (merge-generics (module <module>) + (name <symbol>) + (int1 <module>) + (val1 <generic>) + (int2 <module>) + (val2 <generic>) + (var <top>) + (gf <extended-generic>)) + (and (not (memq val2 (slot-ref gf 'extends))) + (begin + (slot-set! gf + 'extends + (cons val2 (delq! val2 (slot-ref gf 'extends)))) + (slot-set! val2 + 'extended-by + (cons gf (delq! gf (slot-ref val2 'extended-by)))) + var))) + +(module-define! duplicate-handlers 'merge-generics merge-generics) + +(define-method (merge-accessors (module <module>) + (name <symbol>) + (int1 <module>) + (val1 <top>) + (int2 <module>) + (val2 <top>) + (var <top>) + (val <top>)) + #f) + +(define-method (merge-accessors (module <module>) + (name <symbol>) + (int1 <module>) + (val1 <accessor>) + (int2 <module>) + (val2 <accessor>) + (var <top>) + (val <top>)) + (merge-generics module name int1 val1 int2 val2 var val)) + +(module-define! duplicate-handlers 'merge-accessors merge-accessors) + +;;; +;;; slot access +;;; + +(define (class-slot-g-n-s class slot-name) + (let* ((this-slot (assq slot-name (slot-ref class 'slots))) + (g-n-s (cddr (or (assq slot-name (slot-ref class 'getters-n-setters)) + (slot-missing class slot-name))))) + (if (not (memq (slot-definition-allocation this-slot) + '(#:class #:each-subclass))) + (slot-missing class slot-name)) + g-n-s)) + +(define (class-slot-ref class slot) + (let ((x ((car (class-slot-g-n-s class slot)) #f))) + (if (unbound? x) + (slot-unbound class slot) + x))) + +(define (class-slot-set! class slot value) + ((cadr (class-slot-g-n-s class slot)) #f value)) + +(define-method (slot-unbound (c <class>) (o <object>) s) + (goops-error "Slot `~S' is unbound in object ~S" s o)) + +(define-method (slot-unbound (c <class>) s) + (goops-error "Slot `~S' is unbound in class ~S" s c)) + +(define-method (slot-unbound (o <object>)) + (goops-error "Unbound slot in object ~S" o)) + +(define-method (slot-missing (c <class>) (o <object>) s) + (goops-error "No slot with name `~S' in object ~S" s o)) + +(define-method (slot-missing (c <class>) s) + (goops-error "No class slot with name `~S' in class ~S" s c)) + + +(define-method (slot-missing (c <class>) (o <object>) s value) + (slot-missing c o s)) + +;;; Methods for the possible error we can encounter when calling a gf + +(define-method (no-next-method (gf <generic>) args) + (goops-error "No next method when calling ~S\nwith arguments ~S" gf args)) + +(define-method (no-applicable-method (gf <generic>) args) + (goops-error "No applicable method for ~S in call ~S" + gf (cons (generic-function-name gf) args))) + +(define-method (no-method (gf <generic>) args) + (goops-error "No method defined for ~S" gf)) + +;;; +;;; {Cloning functions (from rdeline@CS.CMU.EDU)} +;;; + +(define-method (shallow-clone (self <object>)) + (let ((clone (%allocate-instance (class-of self) '())) + (slots (map slot-definition-name + (class-slots (class-of self))))) + (for-each (lambda (slot) + (if (slot-bound? self slot) + (slot-set! clone slot (slot-ref self slot)))) + slots) + clone)) + +(define-method (deep-clone (self <object>)) + (let ((clone (%allocate-instance (class-of self) '())) + (slots (map slot-definition-name + (class-slots (class-of self))))) + (for-each (lambda (slot) + (if (slot-bound? self slot) + (slot-set! clone slot + (let ((value (slot-ref self slot))) + (if (instance? value) + (deep-clone value) + value))))) + slots) + clone)) + +;;; +;;; {Class redefinition utilities} +;;; + +;;; (class-redefinition OLD NEW) +;;; + +;;; Has correct the following conditions: + +;;; Methods +;;; +;;; 1. New accessor specializers refer to new header +;;; +;;; Classes +;;; +;;; 1. New class cpl refers to the new class header +;;; 2. Old class header exists on old super classes direct-subclass lists +;;; 3. New class header exists on new super classes direct-subclass lists + +(define-method (class-redefinition (old <class>) (new <class>)) + ;; Work on direct methods: + ;; 1. Remove accessor methods from the old class + ;; 2. Patch the occurences of new in the specializers by old + ;; 3. Displace the methods from old to new + (remove-class-accessors! old) ;; -1- + (let ((methods (class-direct-methods new))) + (for-each (lambda (m) + (update-direct-method! m new old)) ;; -2- + methods) + (slot-set! new + 'direct-methods + (append methods (class-direct-methods old)))) + + ;; Substitute old for new in new cpl + (set-car! (slot-ref new 'cpl) old) + + ;; Remove the old class from the direct-subclasses list of its super classes + (for-each (lambda (c) (slot-set! c 'direct-subclasses + (delv! old (class-direct-subclasses c)))) + (class-direct-supers old)) + + ;; Replace the new class with the old in the direct-subclasses of the supers + (for-each (lambda (c) + (slot-set! c 'direct-subclasses + (cons old (delv! new (class-direct-subclasses c))))) + (class-direct-supers new)) + + ;; Swap object headers + (%modify-class old new) + + ;; Now old is NEW! + + ;; Redefine all the subclasses of old to take into account modification + (for-each + (lambda (c) + (update-direct-subclass! c new old)) + (class-direct-subclasses new)) + + ;; Invalidate class so that subsequent instances slot accesses invoke + ;; change-object-class + (slot-set! new 'redefined old) + (%invalidate-class new) ;must come after slot-set! + + old) + +;;; +;;; remove-class-accessors! +;;; + +(define-method (remove-class-accessors! (c <class>)) + (for-each (lambda (m) + (if (is-a? m <accessor-method>) + (let ((gf (slot-ref m 'generic-function))) + ;; remove the method from its GF + (slot-set! gf 'methods + (delq1! m (slot-ref gf 'methods))) + (%invalidate-method-cache! gf) + ;; remove the method from its specializers + (remove-method-in-classes! m)))) + (class-direct-methods c))) + +;;; +;;; update-direct-method! +;;; + +(define-method (update-direct-method! (m <method>) + (old <class>) + (new <class>)) + (let loop ((l (method-specializers m))) + ;; Note: the <top> in dotted list is never used. + ;; So we can work as if we had only proper lists. + (if (pair? l) + (begin + (if (eqv? (car l) old) + (set-car! l new)) + (loop (cdr l)))))) + +;;; +;;; update-direct-subclass! +;;; + +(define-method (update-direct-subclass! (c <class>) + (old <class>) + (new <class>)) + (class-redefinition c + (make-class (class-direct-supers c) + (class-direct-slots c) + #:name (class-name c) + #:environment (slot-ref c 'environment) + #:metaclass (class-of c)))) + +;;; +;;; {Utilities for INITIALIZE methods} +;;; + +;;; compute-slot-accessors +;;; +(define (compute-slot-accessors class slots env) + (for-each + (lambda (s g-n-s) + (let ((name (slot-definition-name s)) + (getter-function (slot-definition-getter s)) + (setter-function (slot-definition-setter s)) + (accessor (slot-definition-accessor s))) + (if getter-function + (add-method! getter-function + (compute-getter-method class g-n-s))) + (if setter-function + (add-method! setter-function + (compute-setter-method class g-n-s))) + (if accessor + (begin + (add-method! accessor + (compute-getter-method class g-n-s)) + (add-method! (setter accessor) + (compute-setter-method class g-n-s)))))) + slots (slot-ref class 'getters-n-setters))) + +(define-method (compute-getter-method (class <class>) slotdef) + (let ((init-thunk (cadr slotdef)) + (g-n-s (cddr slotdef))) + (make <accessor-method> + #:specializers (list class) + #:procedure (cond ((pair? g-n-s) + (make-generic-bound-check-getter (car g-n-s))) + (init-thunk + (standard-get g-n-s)) + (else + (bound-check-get g-n-s))) + #:slot-definition slotdef))) + +(define-method (compute-setter-method (class <class>) slotdef) + (let ((g-n-s (cddr slotdef))) + (make <accessor-method> + #:specializers (list class <top>) + #:procedure (if (pair? g-n-s) + (cadr g-n-s) + (standard-set g-n-s)) + #:slot-definition slotdef))) + +(define (make-generic-bound-check-getter proc) + (let ((source (and (closure? proc) (procedure-source proc)))) + (if (and source (null? (cdddr source))) + (let ((obj (caadr source))) + ;; smart closure compilation + (local-eval + `(lambda (,obj) (,assert-bound ,(caddr source) ,obj)) + (procedure-environment proc))) + (lambda (o) (assert-bound (proc o) o))))) + +;; the idea is to compile the index into the procedure, for fastest +;; lookup. Also, @slot-ref and @slot-set! have their own bytecodes. + +(eval-when (compile) + (use-modules ((language tree-il primitives) :select (add-interesting-primitive!))) + (add-interesting-primitive! '@slot-ref) + (add-interesting-primitive! '@slot-set!)) + +(eval-when (eval load compile) + (define num-standard-pre-cache 20)) + +(define-macro (define-standard-accessor-method form . body) + (let ((name (caar form)) + (n-var (cadar form)) + (args (cdr form))) + (define (make-one x) + (define (body-trans form) + (cond ((not (pair? form)) form) + ((eq? (car form) '@slot-ref) + `(,(car form) ,(cadr form) ,x)) + ((eq? (car form) '@slot-set!) + `(,(car form) ,(cadr form) ,x ,(cadddr form))) + (else + (map body-trans form)))) + `(lambda ,args ,@(map body-trans body))) + `(define ,name + (let ((cache (vector ,@(map make-one (iota num-standard-pre-cache))))) + (lambda (n) + (if (< n ,num-standard-pre-cache) + (vector-ref cache n) + ((lambda (,n-var) (lambda ,args ,@body)) n))))))) + +(define-standard-accessor-method ((bound-check-get n) o) + (let ((x (@slot-ref o n))) + (if (unbound? x) + (slot-unbound obj) + x))) + +(define-standard-accessor-method ((standard-get n) o) + (@slot-ref o n)) + +(define-standard-accessor-method ((standard-set n) o v) + (@slot-set! o n v)) + +;;; compute-getters-n-setters +;;; +(define (make-thunk thunk) + (lambda () (thunk))) + +(define (compute-getters-n-setters class slots env) + + (define (compute-slot-init-function name s) + (or (let ((thunk (slot-definition-init-thunk s))) + (and thunk + (cond ((not (thunk? thunk)) + (goops-error "Bad init-thunk for slot `~S' in ~S: ~S" + name class thunk)) + ((closure? thunk) thunk) + (else (make-thunk thunk))))) + (let ((init (slot-definition-init-value s))) + (and (not (unbound? init)) + (lambda () init))))) + + (define (verify-accessors slot l) + (cond ((integer? l)) + ((not (and (list? l) (= (length l) 2))) + (goops-error "Bad getter and setter for slot `~S' in ~S: ~S" + slot class l)) + (else + (let ((get (car l)) + (set (cadr l))) + ;; note that we allow non-closures; we only check arity on + ;; the closures, though, because we inline their dispatch + ;; in %get-slot-value / %set-slot-value. + (if (or (not (procedure? get)) + (and (closure? get) + (not (= (car (procedure-property get 'arity)) 1)))) + (goops-error "Bad getter closure for slot `~S' in ~S: ~S" + slot class get)) + (if (or (not (procedure? set)) + (and (closure? set) + (not (= (car (procedure-property set 'arity)) 2)))) + (goops-error "Bad setter closure for slot `~S' in ~S: ~S" + slot class set)))))) + + (map (lambda (s) + ;; The strange treatment of nfields is due to backward compatibility. + (let* ((index (slot-ref class 'nfields)) + (g-n-s (compute-get-n-set class s)) + (size (- (slot-ref class 'nfields) index)) + (name (slot-definition-name s))) + ;; NOTE: The following is interdependent with C macros + ;; defined above goops.c:scm_sys_prep_layout_x. + ;; + ;; For simple instance slots, we have the simplest form + ;; '(name init-function . index) + ;; For other slots we have + ;; '(name init-function getter setter . alloc) + ;; where alloc is: + ;; '(index size) for instance allocated slots + ;; '() for other slots + (verify-accessors name g-n-s) + (cons name + (cons (compute-slot-init-function name s) + (if (or (integer? g-n-s) + (zero? size)) + g-n-s + (append g-n-s (list index size))))))) + slots)) + +;;; compute-cpl +;;; +;;; Correct behaviour: +;;; +;;; (define-class food ()) +;;; (define-class fruit (food)) +;;; (define-class spice (food)) +;;; (define-class apple (fruit)) +;;; (define-class cinnamon (spice)) +;;; (define-class pie (apple cinnamon)) +;;; => cpl (pie) = pie apple fruit cinnamon spice food object top +;;; +;;; (define-class d ()) +;;; (define-class e ()) +;;; (define-class f ()) +;;; (define-class b (d e)) +;;; (define-class c (e f)) +;;; (define-class a (b c)) +;;; => cpl (a) = a b d c e f object top +;;; + +(define-method (compute-cpl (class <class>)) + (compute-std-cpl class class-direct-supers)) + +;; Support + +(define (only-non-null lst) + (filter (lambda (l) (not (null? l))) lst)) + +(define (compute-std-cpl c get-direct-supers) + (let ((c-direct-supers (get-direct-supers c))) + (merge-lists (list c) + (only-non-null (append (map class-precedence-list + c-direct-supers) + (list c-direct-supers)))))) + +(define (merge-lists reversed-partial-result inputs) + (cond + ((every null? inputs) + (reverse! reversed-partial-result)) + (else + (let* ((candidate (lambda (c) + (and (not (any (lambda (l) + (memq c (cdr l))) + inputs)) + c))) + (candidate-car (lambda (l) + (and (not (null? l)) + (candidate (car l))))) + (next (any candidate-car inputs))) + (if (not next) + (goops-error "merge-lists: Inconsistent precedence graph")) + (let ((remove-next (lambda (l) + (if (eq? (car l) next) + (cdr l) + l)))) + (merge-lists (cons next reversed-partial-result) + (only-non-null (map remove-next inputs)))))))) + +;; Modified from TinyClos: +;; +;; A simple topological sort. +;; +;; It's in this file so that both TinyClos and Objects can use it. +;; +;; This is a fairly modified version of code I originally got from Anurag +;; Mendhekar <anurag@moose.cs.indiana.edu>. +;; + +(define (compute-clos-cpl c get-direct-supers) + (top-sort ((build-transitive-closure get-direct-supers) c) + ((build-constraints get-direct-supers) c) + (std-tie-breaker get-direct-supers))) + + +(define (top-sort elements constraints tie-breaker) + (let loop ((elements elements) + (constraints constraints) + (result '())) + (if (null? elements) + result + (let ((can-go-in-now + (filter + (lambda (x) + (every (lambda (constraint) + (or (not (eq? (cadr constraint) x)) + (memq (car constraint) result))) + constraints)) + elements))) + (if (null? can-go-in-now) + (goops-error "top-sort: Invalid constraints") + (let ((choice (if (null? (cdr can-go-in-now)) + (car can-go-in-now) + (tie-breaker result + can-go-in-now)))) + (loop + (filter (lambda (x) (not (eq? x choice))) + elements) + constraints + (append result (list choice))))))))) + +(define (std-tie-breaker get-supers) + (lambda (partial-cpl min-elts) + (let loop ((pcpl (reverse partial-cpl))) + (let ((current-elt (car pcpl))) + (let ((ds-of-ce (get-supers current-elt))) + (let ((common (filter (lambda (x) + (memq x ds-of-ce)) + min-elts))) + (if (null? common) + (if (null? (cdr pcpl)) + (goops-error "std-tie-breaker: Nothing valid") + (loop (cdr pcpl))) + (car common)))))))) + + +(define (build-transitive-closure get-follow-ons) + (lambda (x) + (let track ((result '()) + (pending (list x))) + (if (null? pending) + result + (let ((next (car pending))) + (if (memq next result) + (track result (cdr pending)) + (track (cons next result) + (append (get-follow-ons next) + (cdr pending))))))))) + +(define (build-constraints get-follow-ons) + (lambda (x) + (let loop ((elements ((build-transitive-closure get-follow-ons) x)) + (this-one '()) + (result '())) + (if (or (null? this-one) (null? (cdr this-one))) + (if (null? elements) + result + (loop (cdr elements) + (cons (car elements) + (get-follow-ons (car elements))) + result)) + (loop elements + (cdr this-one) + (cons (list (car this-one) (cadr this-one)) + result)))))) + +;;; compute-get-n-set +;;; +(define-method (compute-get-n-set (class <class>) s) + (case (slot-definition-allocation s) + ((#:instance) ;; Instance slot + ;; get-n-set is just its offset + (let ((already-allocated (slot-ref class 'nfields))) + (slot-set! class 'nfields (+ already-allocated 1)) + already-allocated)) + + ((#:class) ;; Class slot + ;; Class-slots accessors are implemented as 2 closures around + ;; a Scheme variable. As instance slots, class slots must be + ;; unbound at init time. + (let ((name (slot-definition-name s))) + (if (memq name (map slot-definition-name (class-direct-slots class))) + ;; This slot is direct; create a new shared variable + (make-closure-variable class) + ;; Slot is inherited. Find its definition in superclass + (let loop ((l (cdr (class-precedence-list class)))) + (let ((r (assoc name (slot-ref (car l) 'getters-n-setters)))) + (if r + (cddr r) + (loop (cdr l)))))))) + + ((#:each-subclass) ;; slot shared by instances of direct subclass. + ;; (Thomas Buerger, April 1998) + (make-closure-variable class)) + + ((#:virtual) ;; No allocation + ;; slot-ref and slot-set! function must be given by the user + (let ((get (get-keyword #:slot-ref (slot-definition-options s) #f)) + (set (get-keyword #:slot-set! (slot-definition-options s) #f)) + (env (class-environment class))) + (if (not (and get set)) + (goops-error "You must supply a #:slot-ref and a #:slot-set! in ~S" + s)) + (list get set))) + (else (next-method)))) + +(define (make-closure-variable class) + (let ((shared-variable (make-unbound))) + (list (lambda (o) shared-variable) + (lambda (o v) (set! shared-variable v))))) + +(define-method (compute-get-n-set (o <object>) s) + (goops-error "Allocation \"~S\" is unknown" (slot-definition-allocation s))) + +(define-method (compute-slots (class <class>)) + (%compute-slots class)) + +;;; +;;; {Initialize} +;;; + +(define-method (initialize (object <object>) initargs) + (%initialize-object object initargs)) + +(define-method (initialize (class <class>) initargs) + (next-method) + (let ((dslots (get-keyword #:slots initargs '())) + (supers (get-keyword #:dsupers initargs '())) + (env (get-keyword #:environment initargs (top-level-env)))) + + (slot-set! class 'name (get-keyword #:name initargs '???)) + (slot-set! class 'direct-supers supers) + (slot-set! class 'direct-slots dslots) + (slot-set! class 'direct-subclasses '()) + (slot-set! class 'direct-methods '()) + (slot-set! class 'cpl (compute-cpl class)) + (slot-set! class 'redefined #f) + (slot-set! class 'environment env) + (let ((slots (compute-slots class))) + (slot-set! class 'slots slots) + (slot-set! class 'nfields 0) + (slot-set! class 'getters-n-setters (compute-getters-n-setters class + slots + env)) + ;; Build getters - setters - accessors + (compute-slot-accessors class slots env)) + + ;; Update the "direct-subclasses" of each inherited classes + (for-each (lambda (x) + (slot-set! x + 'direct-subclasses + (cons class (slot-ref x 'direct-subclasses)))) + supers) + + ;; Support for the underlying structs: + + ;; Inherit class flags (invisible on scheme level) from supers + (%inherit-magic! class supers) + + ;; Set the layout slot + (%prep-layout! class))) + +(define (initialize-object-procedure object initargs) + (let ((proc (get-keyword #:procedure initargs #f))) + (cond ((not proc)) + ((pair? proc) + (apply set-object-procedure! object proc)) + ((valid-object-procedure? proc) + (set-object-procedure! object proc)) + (else + (set-object-procedure! object + (lambda args (apply proc args))))))) + +(define-method (initialize (class <operator-class>) initargs) + (next-method) + (initialize-object-procedure class initargs)) + +(define-method (initialize (owsc <operator-with-setter-class>) initargs) + (next-method) + (%set-object-setter! owsc (get-keyword #:setter initargs #f))) + +(define-method (initialize (entity <entity>) initargs) + (next-method) + (initialize-object-procedure entity initargs)) + +(define-method (initialize (ews <entity-with-setter>) initargs) + (next-method) + (%set-object-setter! ews (get-keyword #:setter initargs #f))) + +(define-method (initialize (generic <generic>) initargs) + (let ((previous-definition (get-keyword #:default initargs #f)) + (name (get-keyword #:name initargs #f))) + (next-method) + (slot-set! generic 'methods (if (is-a? previous-definition <procedure>) + (list (method args + (apply previous-definition args))) + '())) + (if name + (set-procedure-property! generic 'name name)) + )) + +(define-method (initialize (eg <extended-generic>) initargs) + (next-method) + (slot-set! eg 'extends (get-keyword #:extends initargs '()))) + +(define dummy-procedure (lambda args *unspecified*)) + +(define-method (initialize (method <method>) initargs) + (next-method) + (slot-set! method 'generic-function (get-keyword #:generic-function initargs #f)) + (slot-set! method 'specializers (get-keyword #:specializers initargs '())) + (slot-set! method 'procedure + (get-keyword #:procedure initargs #f)) + (slot-set! method 'code-table '()) + (slot-set! method 'formals (get-keyword #:formals initargs '())) + (slot-set! method 'body (get-keyword #:body initargs '())) + (slot-set! method 'make-procedure (get-keyword #:make-procedure initargs #f))) + + +(define-method (initialize (obj <foreign-object>) initargs)) + +;;; +;;; {Change-class} +;;; + +(define (change-object-class old-instance old-class new-class) + (let ((new-instance (allocate-instance new-class '()))) + ;; Initialize the slots of the new instance + (for-each (lambda (slot) + (if (and (slot-exists-using-class? old-class old-instance slot) + (eq? (slot-definition-allocation + (class-slot-definition old-class slot)) + #:instance) + (slot-bound-using-class? old-class old-instance slot)) + ;; Slot was present and allocated in old instance; copy it + (slot-set-using-class! + new-class + new-instance + slot + (slot-ref-using-class old-class old-instance slot)) + ;; slot was absent; initialize it with its default value + (let ((init (slot-init-function new-class slot))) + (if init + (slot-set-using-class! + new-class + new-instance + slot + (apply init '())))))) + (map slot-definition-name (class-slots new-class))) + ;; Exchange old and new instance in place to keep pointers valid + (%modify-instance old-instance new-instance) + ;; Allow class specific updates of instances (which now are swapped) + (update-instance-for-different-class new-instance old-instance) + old-instance)) + + +(define-method (update-instance-for-different-class (old-instance <object>) + (new-instance + <object>)) + ;;not really important what we do, we just need a default method + new-instance) + +(define-method (change-class (old-instance <object>) (new-class <class>)) + (change-object-class old-instance (class-of old-instance) new-class)) + +;;; +;;; {make} +;;; +;;; A new definition which overwrites the previous one which was built-in +;;; + +(define-method (allocate-instance (class <class>) initargs) + (%allocate-instance class initargs)) + +(define-method (make-instance (class <class>) . initargs) + (let ((instance (allocate-instance class initargs))) + (initialize instance initargs) + instance)) + +(define make make-instance) + +;;; +;;; {apply-generic} +;;; +;;; Protocol for calling standard generic functions. This protocol is +;;; not used for real <generic> functions (in this case we use a +;;; completely C hard-coded protocol). Apply-generic is used by +;;; goops for calls to subclasses of <generic> and <generic-with-setter>. +;;; The code below is similar to the first MOP described in AMOP. In +;;; particular, it doesn't used the currified approach to gf +;;; call. There are 2 reasons for that: +;;; - the protocol below is exposed to mimic completely the one written in C +;;; - the currified protocol would be imho inefficient in C. +;;; + +(define-method (apply-generic (gf <generic>) args) + (if (null? (slot-ref gf 'methods)) + (no-method gf args)) + (let ((methods (compute-applicable-methods gf args))) + (if methods + (apply-methods gf (sort-applicable-methods gf methods args) args) + (no-applicable-method gf args)))) + +;; compute-applicable-methods is bound to %compute-applicable-methods. +;; *fixme* use let +(define %%compute-applicable-methods + (make <generic> #:name 'compute-applicable-methods)) + +(define-method (%%compute-applicable-methods (gf <generic>) args) + (%compute-applicable-methods gf args)) + +(set! compute-applicable-methods %%compute-applicable-methods) + +(define-method (sort-applicable-methods (gf <generic>) methods args) + (let ((targs (map class-of args))) + (sort methods (lambda (m1 m2) (method-more-specific? m1 m2 targs))))) + +(define-method (method-more-specific? (m1 <method>) (m2 <method>) targs) + (%method-more-specific? m1 m2 targs)) + +(define-method (apply-method (gf <generic>) methods build-next args) + (apply (method-procedure (car methods)) + (build-next (cdr methods) args) + args)) + +(define-method (apply-methods (gf <generic>) (l <list>) args) + (letrec ((next (lambda (procs args) + (lambda new-args + (let ((a (if (null? new-args) args new-args))) + (if (null? procs) + (no-next-method gf a) + (apply-method gf procs next a))))))) + (apply-method gf l next args))) + +;; We don't want the following procedure to turn up in backtraces: +(for-each (lambda (proc) + (set-procedure-property! proc 'system-procedure #t)) + (list slot-unbound + slot-missing + no-next-method + no-applicable-method + no-method + )) + +;;; +;;; {<composite-metaclass> and <active-metaclass>} +;;; + +;(autoload "active-slot" <active-metaclass>) +;(autoload "composite-slot" <composite-metaclass>) +;(export <composite-metaclass> <active-metaclass>) + +;;; +;;; {Tools} +;;; + +;; list2set +;; +;; duplicate the standard list->set function but using eq instead of +;; eqv which really sucks a lot, uselessly here +;; +(define (list2set l) + (let loop ((l l) + (res '())) + (cond + ((null? l) res) + ((memq (car l) res) (loop (cdr l) res)) + (else (loop (cdr l) (cons (car l) res)))))) + +(define (class-subclasses c) + (letrec ((allsubs (lambda (c) + (cons c (mapappend allsubs + (class-direct-subclasses c)))))) + (list2set (cdr (allsubs c))))) + +(define (class-methods c) + (list2set (mapappend class-direct-methods + (cons c (class-subclasses c))))) + +;;; +;;; {Final initialization} +;;; + +;; Tell C code that the main bulk of Goops has been loaded +(%goops-loaded) diff --git a/module/oop/goops/accessors.scm b/module/oop/goops/accessors.scm new file mode 100644 index 000000000..5b05d3b15 --- /dev/null +++ b/module/oop/goops/accessors.scm @@ -0,0 +1,72 @@ +;;;; Copyright (C) 1999, 2000, 2005, 2006 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +;;;; + + +(define-module (oop goops accessors) + :use-module (oop goops) + :re-export (standard-define-class) + :export (define-class-with-accessors + define-class-with-accessors-keywords)) + +(define-macro (define-class-with-accessors name supers . slots) + (let ((eat? #f)) + `(standard-define-class + ,name ,supers + ,@(map-in-order + (lambda (slot) + (cond (eat? + (set! eat? #f) + slot) + ((keyword? slot) + (set! eat? #t) + slot) + ((pair? slot) + (if (get-keyword #:accessor (cdr slot) #f) + slot + (let ((name (car slot))) + `(,name #:accessor ,name ,@(cdr slot))))) + (else + `(,slot #:accessor ,slot)))) + slots)))) + +(define-macro (define-class-with-accessors-keywords name supers . slots) + (let ((eat? #f)) + `(standard-define-class + ,name ,supers + ,@(map-in-order + (lambda (slot) + (cond (eat? + (set! eat? #f) + slot) + ((keyword? slot) + (set! eat? #t) + slot) + ((pair? slot) + (let ((slot + (if (get-keyword #:accessor (cdr slot) #f) + slot + (let ((name (car slot))) + `(,name #:accessor ,name ,@(cdr slot)))))) + (if (get-keyword #:init-keyword (cdr slot) #f) + slot + (let* ((name (car slot)) + (keyword (symbol->keyword name))) + `(,name #:init-keyword ,keyword ,@(cdr slot)))))) + (else + `(,slot #:accessor ,slot + #:init-keyword ,(symbol->keyword slot))))) + slots)))) diff --git a/module/oop/goops/active-slot.scm b/module/oop/goops/active-slot.scm new file mode 100644 index 000000000..5cd2afe10 --- /dev/null +++ b/module/oop/goops/active-slot.scm @@ -0,0 +1,66 @@ +;;; installed-scm-file + +;;;; Copyright (C) 1999, 2001, 2006 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +;;;; + + +;;;; This software is a derivative work of other copyrighted softwares; the +;;;; copyright notices of these softwares are placed in the file COPYRIGHTS +;;;; +;;;; This file is based upon active-slot.stklos from the STk +;;;; distribution by Erick Gallesio <eg@unice.fr>. +;;;; + +(define-module (oop goops active-slot) + :use-module (oop goops internal) + :export (<active-class>)) + +(define-class <active-class> (<class>)) + +(define-method (compute-get-n-set (class <active-class>) slot) + (if (eq? (slot-definition-allocation slot) #:active) + (let* ((index (slot-ref class 'nfields)) + (name (car slot)) + (s (cdr slot)) + (env (class-environment class)) + (before-ref (get-keyword #:before-slot-ref s #f)) + (after-ref (get-keyword #:after-slot-ref s #f)) + (before-set! (get-keyword #:before-slot-set! s #f)) + (after-set! (get-keyword #:after-slot-set! s #f)) + (unbound (make-unbound))) + (slot-set! class 'nfields (+ index 1)) + (list (lambda (o) + (if before-ref + (if (before-ref o) + (let ((res (%fast-slot-ref o index))) + (and after-ref (not (eqv? res unbound)) (after-ref o)) + res) + (make-unbound)) + (let ((res (%fast-slot-ref o index))) + (and after-ref (not (eqv? res unbound)) (after-ref o)) + res))) + + (lambda (o v) + (if before-set! + (if (before-set! o v) + (begin + (%fast-slot-set! o index v) + (and after-set! (after-set! o v)))) + (begin + (%fast-slot-set! o index v) + (and after-set! (after-set! o v))))))) + (next-method))) diff --git a/module/oop/goops/compile.scm b/module/oop/goops/compile.scm new file mode 100644 index 000000000..5db406cd0 --- /dev/null +++ b/module/oop/goops/compile.scm @@ -0,0 +1,81 @@ +;;;; Copyright (C) 1999, 2001, 2006 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +;;;; + + +;; There are circularities here; you can't import (oop goops compile) +;; before (oop goops). So when compiling, make sure that things are +;; kosher. +(eval-when (compile) (resolve-module '(oop goops))) + +(define-module (oop goops compile) + :use-module (oop goops) + :use-module (oop goops util) + :export (compute-cmethod) + :no-backtrace + ) + +;;; +;;; Method entries +;;; + +(define code-table-lookup + (letrec ((check-entry (lambda (entry types) + (cond + ((not (pair? entry)) (and (null? types) entry)) + ((null? types) #f) + (else + (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)) + (else (code-table-lookup (cdr code-table) types)))))) + +(define (compute-cmethod methods types) + (or (code-table-lookup (slot-ref (car methods) 'code-table) types) + (let* ((method (car methods)) + (cmethod (compile-method methods types)) + (entry (append types cmethod))) + (slot-set! method 'code-table + (cons entry (slot-ref method 'code-table))) + cmethod))) + +;;; +;;; Compiling next methods into method bodies +;;; + +;;; So, for the reader: there basic idea is that, given that the +;;; semantics of `next-method' depend on the concrete types being +;;; dispatched, why not compile a specific procedure to handle each type +;;; combination that we see at runtime. +;;; +;;; In theory we can do much better than a bytecode compilation, because +;;; we know the *exact* types of the arguments. It's ideal for native +;;; compilation. A task for the future. +;;; +;;; I think this whole generic application mess would benefit from a +;;; strict MOP. + +(define (compile-method methods types) + (let ((make-procedure (slot-ref (car methods) 'make-procedure))) + (if make-procedure + (make-procedure + (if (null? methods) + (lambda args + (no-next-method (method-generic-function (car methods)) args)) + (compute-cmethod (cdr methods) types))) + (method-procedure (car methods))))) diff --git a/module/oop/goops/composite-slot.scm b/module/oop/goops/composite-slot.scm new file mode 100644 index 000000000..b3f8cc038 --- /dev/null +++ b/module/oop/goops/composite-slot.scm @@ -0,0 +1,82 @@ +;;; installed-scm-file + +;;;; Copyright (C) 1999, 2000, 2001, 2006 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +;;;; + + +;;;; This software is a derivative work of other copyrighted softwares; the +;;;; copyright notices of these softwares are placed in the file COPYRIGHTS +;;;; +;;;; This file is based upon composite-slot.stklos from the STk +;;;; distribution by Erick Gallesio <eg@unice.fr>. +;;;; + +(define-module (oop goops composite-slot) + :use-module (oop goops) + :export (<composite-class>)) + +;;; +;;; (define-class CLASS SUPERS +;;; ... +;;; (OBJECT ...) +;;; ... +;;; (SLOT #:allocation #:propagated +;;; #:propagate-to '(PROPAGATION ...)) +;;; ... +;;; #:metaclass <composite-class>) +;;; +;;; PROPAGATION ::= OBJECT | (OBJECT TARGETSLOT) +;;; +;;; The slot SLOT will be propagated to the slot TARGETSLOT in the object +;;; stored in slot OBJECT. If TARGETSLOT is omitted, assume that the target +;;; slot is named SLOT. +;;; + +(define-class <composite-class> (<class>)) + +(define-method (compute-get-n-set (class <composite-class>) slot) + (if (eq? (slot-definition-allocation slot) #:propagated) + (compute-propagated-get-n-set slot) + (next-method))) + +(define (compute-propagated-get-n-set s) + (let ((prop (get-keyword #:propagate-to (cdr s) #f)) + (s-name (slot-definition-name s))) + + (if (not prop) + (goops-error "Propagation not specified for slot ~S" s-name)) + (if (not (pair? prop)) + (goops-error "Bad propagation list for slot ~S" s-name)) + + (let ((objects (map (lambda (p) (if (pair? p) (car p) p)) prop)) + (slots (map (lambda (p) (if (pair? p) (cadr p) s-name)) prop))) + (let ((first-object (car objects)) + (first-slot (car slots))) + (list + ;; The getter + (lambda (o) + (slot-ref (slot-ref o first-object) first-slot)) + + ;; The setter + (if (null? (cdr objects)) + (lambda (o v) + (slot-set! (slot-ref o first-object) first-slot v)) + (lambda (o v) + (for-each (lambda (object slot) + (slot-set! (slot-ref o object) slot v)) + objects + slots)))))))) diff --git a/module/oop/goops/describe.scm b/module/oop/goops/describe.scm new file mode 100644 index 000000000..fa7bc466c --- /dev/null +++ b/module/oop/goops/describe.scm @@ -0,0 +1,200 @@ +;;; installed-scm-file + +;;;; Copyright (C) 1998, 1999, 2001, 2006, 2008 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +;;;; + + +;;;; This software is a derivative work of other copyrighted softwares; the +;;;; copyright notices of these softwares are placed in the file COPYRIGHTS +;;;; +;;;; This file is based upon describe.stklos from the STk distribution by +;;;; Erick Gallesio <eg@unice.fr>. +;;;; + +(define-module (oop goops describe) + :use-module (oop goops) + :use-module (ice-9 session) + :use-module (ice-9 format) + :export (describe)) ; Export the describe generic function + +;;; +;;; describe for simple objects +;;; +(define-method (describe (x <top>)) + (format #t "~s is " x) + (cond + ((integer? x) (format #t "an integer")) + ((real? x) (format #t "a real")) + ((complex? x) (format #t "a complex number")) + ((null? x) (format #t "an empty list")) + ((boolean? x) (format #t "a boolean value (~s)" (if x 'true 'false))) + ((char? x) (format #t "a character, ascii value is ~s" + (char->integer x))) + ((symbol? x) (format #t "a symbol")) + ((list? x) (format #t "a list")) + ((pair? x) (if (pair? (cdr x)) + (format #t "an improper list") + (format #t "a pair"))) + ((string? x) (if (eqv? x "") + (format #t "an empty string") + (format #t "a string of length ~s" (string-length x)))) + ((vector? x) (if (eqv? x '#()) + (format #t "an empty vector") + (format #t "a vector of length ~s" (vector-length x)))) + ((eof-object? x) (format #t "the end-of-file object")) + (else (format #t "an unknown object (~s)" x))) + (format #t ".~%") + *unspecified*) + +(define-method (describe (x <procedure>)) + (let ((name (procedure-name x))) + (if name + (format #t "`~s'" name) + (display x)) + (display " is ") + (display (if name #\a "an anonymous")) + (display (cond ((closure? x) " procedure") + ((not (struct? x)) " primitive procedure") + ((entity? x) " entity") + (else " operator"))) + (display " with ") + (arity x))) + +;;; +;;; describe for GOOPS instances +;;; +(define (safe-class-name class) + (if (slot-bound? class 'name) + (class-name class) + class)) + +(define-method (describe (x <object>)) + (format #t "~S is an instance of class ~A~%" + x (safe-class-name (class-of x))) + + ;; print all the instance slots + (format #t "Slots are: ~%") + (for-each (lambda (slot) + (let ((name (slot-definition-name slot))) + (format #t " ~S = ~A~%" + name + (if (slot-bound? x name) + (format #f "~S" (slot-ref x name)) + "#<unbound>")))) + (class-slots (class-of x))) + *unspecified*) + +;;; +;;; Describe for classes +;;; +(define-method (describe (x <class>)) + (format #t "~S is a class. It's an instance of ~A~%" + (safe-class-name x) (safe-class-name (class-of x))) + + ;; Super classes + (format #t "Superclasses are:~%") + (for-each (lambda (class) (format #t " ~A~%" (safe-class-name class))) + (class-direct-supers x)) + + ;; Direct slots + (let ((slots (class-direct-slots x))) + (if (null? slots) + (format #t "(No direct slot)~%") + (begin + (format #t "Directs slots are:~%") + (for-each (lambda (s) + (format #t " ~A~%" (slot-definition-name s))) + slots)))) + + + ;; Direct subclasses + (let ((classes (class-direct-subclasses x))) + (if (null? classes) + (format #t "(No direct subclass)~%") + (begin + (format #t "Directs subclasses are:~%") + (for-each (lambda (s) + (format #t " ~A~%" (safe-class-name s))) + classes)))) + + ;; CPL + (format #t "Class Precedence List is:~%") + (for-each (lambda (s) (format #t " ~A~%" (safe-class-name s))) + (class-precedence-list x)) + + ;; Direct Methods + (let ((methods (class-direct-methods x))) + (if (null? methods) + (format #t "(No direct method)~%") + (begin + (format #t "Class direct methods are:~%") + (for-each describe methods)))) + +; (format #t "~%Field Initializers ~% ") +; (write (slot-ref x 'initializers)) (newline) + +; (format #t "~%Getters and Setters~% ") +; (write (slot-ref x 'getters-n-setters)) (newline) +) + +;;; +;;; Describe for generic functions +;;; +(define-method (describe (x <generic>)) + (let ((name (generic-function-name x)) + (methods (generic-function-methods x))) + ;; Title + (format #t "~S is a generic function. It's an instance of ~A.~%" + name (safe-class-name (class-of x))) + ;; Methods + (if (null? methods) + (format #t "(No method defined for ~S)~%" name) + (begin + (format #t "Methods defined for ~S~%" name) + (for-each (lambda (x) (describe x #t)) methods))))) + +;;; +;;; Describe for methods +;;; +(define-method (describe (x <method>) . omit-generic) + (letrec ((print-args (lambda (args) + ;; take care of dotted arg lists + (cond ((null? args) (newline)) + ((pair? args) + (display #\space) + (display (safe-class-name (car args))) + (print-args (cdr args))) + (else + (display #\space) + (display (safe-class-name args)) + (newline)))))) + + ;; Title + (format #t " Method ~A~%" x) + + ;; Associated generic + (if (null? omit-generic) + (let ((gf (method-generic-function x))) + (if gf + (format #t "\t Generic: ~A~%" (generic-function-name gf)) + (format #t "\t(No generic)~%")))) + + ;; GF specializers + (format #t "\tSpecializers:") + (print-args (method-specializers x)))) + +(provide 'describe) diff --git a/module/oop/goops/dispatch.scm b/module/oop/goops/dispatch.scm new file mode 100644 index 000000000..0dd169d59 --- /dev/null +++ b/module/oop/goops/dispatch.scm @@ -0,0 +1,269 @@ +;;;; Copyright (C) 1999, 2000, 2001, 2003, 2006 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +;;;; + + +;; There are circularities here; you can't import (oop goops compile) +;; before (oop goops). So when compiling, make sure that things are +;; kosher. +(eval-when (compile) (resolve-module '(oop goops))) + +(define-module (oop goops dispatch) + :use-module (oop goops) + :use-module (oop goops util) + :use-module (oop goops compile) + :export (memoize-method!) + :no-backtrace + ) + +;;; +;;; 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 6) + +(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 (or (not (pair? entry)) (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 (cache-hashval hashset entry) + (let ((hashset-index (+ hashset-index hashset))) + (do ((sum 0) + (classes entry (cdr classes))) + ((not (and (pair? classes) (struct? (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))) + (let outer ((in entries) (max-misses 0)) + (if (null? in) + max-misses + (let inner ((i (logand mask (cache-hashval hashset (car in)))) + (misses 0)) + (cond + ((and (pair? (vector-ref cache i)) + (eq? (car (vector-ref cache i)) 'no-method)) + (vector-set! cache i (car in)) + (outer (cdr in) (if (> misses max-misses) misses max-misses))) + (else + (let ((misses (+ 1 misses))) + (if (>= misses min-misses) + misses ;; this is a return, yo. + (inner (logand mask (+ i 1)) misses)))))))))) + +;;; +;;; Memoization +;;; + +;; Backward compatibility +(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) + (+ 1 (slot-ref (method-cache-generic-function exp) + 'n-specialized))))) + (let* ((types (map class-of (first-n args n-specializers))) + (cmethod (compute-cmethod applicable types))) + (insert! exp (append types cmethod)) ; entry = types + cmethod + cmethod))))) ; cmethod diff --git a/module/oop/goops/internal.scm b/module/oop/goops/internal.scm new file mode 100644 index 000000000..15919d44b --- /dev/null +++ b/module/oop/goops/internal.scm @@ -0,0 +1,30 @@ +;;; installed-scm-file + +;;;; Copyright (C) 1999, 2001, 2006 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +;;;; + + +(define-module (oop goops internal) + :use-module (oop goops)) + +;; Export all the bindings that are internal to `(oop goops)'. +(let ((public-i (module-public-interface (current-module)))) + (module-for-each (lambda (name var) + (if (eq? name '%module-public-interface) + #t + (module-add! public-i name var))) + (resolve-module '(oop goops)))) diff --git a/module/oop/goops/save.scm b/module/oop/goops/save.scm new file mode 100644 index 000000000..0c7d71a2d --- /dev/null +++ b/module/oop/goops/save.scm @@ -0,0 +1,866 @@ +;;; installed-scm-file + +;;;; Copyright (C) 2000,2001,2002, 2006 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +;;;; + + +(define-module (oop goops save) + :use-module (oop goops internal) + :use-module (oop goops util) + :re-export (make-unbound) + :export (save-objects load-objects restore + enumerate! enumerate-component! + write-readably write-component write-component-procedure + literal? readable make-readable)) + +;;; +;;; save-objects ALIST PORT [EXCLUDED] [USES] +;;; +;;; ALIST ::= ((NAME . OBJECT) ...) +;;; +;;; Save OBJECT ... to PORT so that when the data is read and evaluated +;;; OBJECT ... are re-created under names NAME ... . +;;; Exclude any references to objects in the list EXCLUDED. +;;; Add a (use-modules . USES) line to the top of the saved text. +;;; +;;; In some instances, when `save-object' doesn't know how to produce +;;; readable syntax for an object, you can explicitly register read +;;; syntax for an object using the special form `readable'. +;;; +;;; Example: +;;; +;;; The function `foo' produces an object of obscure structure. +;;; Only `foo' can construct such objects. Because of this, an +;;; object such as +;;; +;;; (define x (vector 1 (foo))) +;;; +;;; cannot be saved by `save-objects'. But if you instead write +;;; +;;; (define x (vector 1 (readable (foo)))) +;;; +;;; `save-objects' will happily produce the necessary read syntax. +;;; +;;; To add new read syntax, hang methods on `enumerate!' and +;;; `write-readably'. +;;; +;;; enumerate! OBJECT ENV +;;; Should call `enumerate-component!' (which takes same args) on +;;; each component object. Should return #t if the composite object +;;; can be written as a literal. (`enumerate-component!' returns #t +;;; if the component is a literal. +;;; +;;; write-readably OBJECT PORT ENV +;;; Should write a readable representation of OBJECT to PORT. +;;; Should use `write-component' to print each component object. +;;; Use `literal?' to decide if a component is a literal. +;;; +;;; Utilities: +;;; +;;; enumerate-component! OBJECT ENV +;;; +;;; write-component OBJECT PATCHER PORT ENV +;;; PATCHER is an expression which, when evaluated, stores OBJECT +;;; into its current location. +;;; +;;; Example: +;;; +;;; (write-component (car ls) `(set-car! ,ls ,(car ls)) file env) +;;; +;;; write-component is a macro. +;;; +;;; literal? COMPONENT ENV +;;; + +(define-method (immediate? (o <top>)) #f) + +(define-method (immediate? (o <null>)) #t) +(define-method (immediate? (o <number>)) #t) +(define-method (immediate? (o <boolean>)) #t) +(define-method (immediate? (o <symbol>)) #t) +(define-method (immediate? (o <char>)) #t) +(define-method (immediate? (o <keyword>)) #t) + +;;; enumerate! OBJECT ENVIRONMENT +;;; +;;; Return #t if object is a literal. +;;; +(define-method (enumerate! (o <top>) env) #t) + +(define-method (write-readably (o <top>) file env) + ;;(goops-error "No read-syntax defined for object `~S'" o) + (write o file) ;doesn't catch bugs, but is much more flexible + ) + +;;; +;;; Readables +;;; + +(define readables (make-weak-key-hash-table 61)) + +(define-macro (readable exp) + `(make-readable ,exp ',(copy-tree exp))) + +(define (make-readable obj expr) + (hashq-set! readables obj expr) + obj) + +(define (readable-expression obj) + `(readable ,(hashq-ref readables obj))) + +(define (readable? obj) + (hashq-get-handle readables obj)) + +;;; +;;; Strings +;;; + +(define-method (enumerate! (o <string>) env) #f) + +;;; +;;; Vectors +;;; + +(define-method (enumerate! (o <vector>) env) + (or (not (vector? o)) + (let ((literal? #t)) + (array-for-each (lambda (o) + (if (not (enumerate-component! o env)) + (set! literal? #f))) + o) + literal?))) + +(define-method (write-readably (o <vector>) file env) + (if (not (vector? o)) + (write o file) + (let ((n (vector-length o))) + (if (zero? n) + (display "#()" file) + (let ((not-literal? (not (literal? o env)))) + (display (if not-literal? + "(vector " + "#(") + file) + (if (and not-literal? + (literal? (vector-ref o 0) env)) + (display #\' file)) + (write-component (vector-ref o 0) + `(vector-set! ,o 0 ,(vector-ref o 0)) + file + env) + (do ((i 1 (+ 1 i))) + ((= i n)) + (display #\space file) + (if (and not-literal? + (literal? (vector-ref o i) env)) + (display #\' file)) + (write-component (vector-ref o i) + `(vector-set! ,o ,i ,(vector-ref o i)) + file + env)) + (display #\) file)))))) + + +;;; +;;; Arrays +;;; + +(define-method (enumerate! (o <array>) env) + (enumerate-component! (shared-array-root o) env)) + +(define (make-mapper array) + (let* ((dims (array-dimensions array)) + (n (array-rank array)) + (indices (reverse (if (<= n 11) + (list-tail '(t s r q p n m l k j i) (- 11 n)) + (let loop ((n n) + (ls '())) + (if (zero? n) + ls + (loop (- n 1) + (cons (gensym "i") ls)))))))) + `(lambda ,indices + (+ ,(shared-array-offset array) + ,@(map (lambda (ind dim inc) + `(* ,inc ,(if (pair? dim) `(- ,ind ,(car dim)) ind))) + indices + (array-dimensions array) + (shared-array-increments array)))))) + +(define (write-array prefix o not-literal? file env) + (letrec ((inner (lambda (n indices) + (if (not (zero? n)) + (let ((el (apply array-ref o + (reverse (cons 0 indices))))) + (if (and not-literal? + (literal? el env)) + (display #\' file)) + (write-component + el + `(array-set! ,o ,el ,@indices) + file + env))) + (do ((i 1 (+ 1 i))) + ((= i n)) + (display #\space file) + (let ((el (apply array-ref o + (reverse (cons i indices))))) + (if (and not-literal? + (literal? el env)) + (display #\' file)) + (write-component + el + `(array-set! ,o ,el ,@indices) + file + env)))))) + (display prefix file) + (let loop ((dims (array-dimensions o)) + (indices '())) + (cond ((null? (cdr dims)) + (inner (car dims) indices)) + (else + (let ((n (car dims))) + (do ((i 0 (+ 1 i))) + ((= i n)) + (if (> i 0) + (display #\space file)) + (display prefix file) + (loop (cdr dims) (cons i indices)) + (display #\) file)))))) + (display #\) file))) + +(define-method (write-readably (o <array>) file env) + (let ((root (shared-array-root o))) + (cond ((literal? o env) + (if (not (vector? root)) + (write o file) + (begin + (display #\# file) + (display (array-rank o) file) + (write-array #\( o #f file env)))) + ((binding? root env) + (display "(make-shared-array " file) + (if (literal? root env) + (display #\' file)) + (write-component root + (goops-error "write-readably(<array>): internal error") + file + env) + (display #\space file) + (display (make-mapper o) file) + (for-each (lambda (dim) + (display #\space file) + (display dim file)) + (array-dimensions o)) + (display #\) file)) + (else + (display "(list->uniform-array " file) + (display (array-rank o) file) + (display " '() " file) + (write-array "(list " o file env))))) + +;;; +;;; Pairs +;;; + +;;; These methods have more complex structure than is required for +;;; most objects, since they take over some of the logic of +;;; `write-component'. +;;; + +(define-method (enumerate! (o <pair>) env) + (let ((literal? (enumerate-component! (car o) env))) + (and (enumerate-component! (cdr o) env) + literal?))) + +(define-method (write-readably (o <pair>) file env) + (let ((proper? (let loop ((ls o)) + (or (null? ls) + (and (pair? ls) + (not (binding? (cdr ls) env)) + (loop (cdr ls)))))) + (1? (or (not (pair? (cdr o))) + (binding? (cdr o) env))) + (not-literal? (not (literal? o env))) + (infos '()) + (refs (ref-stack env))) + (display (cond ((not not-literal?) #\() + (proper? "(list ") + (1? "(cons ") + (else "(cons* ")) + 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-macro (restore class slots . exps) + "(restore CLASS (SLOT-NAME1 ...) EXP1 ...)" + `(let ((o ((@@ (oop goops) %allocate-instance) ,class '()))) + (for-each (lambda (name val) + (slot-set! o name val)) + ',slots + (list ,@exps)) + o)) + +(define-method (enumerate! (o <object>) env) + (get-set-for-each (lambda (get set) + (let ((val (get o))) + (if (not (unbound? val)) + (enumerate-component! val env)))) + (class-of o)) + #f) + +(define-method (write-readably (o <object>) file env) + (let ((class (class-of o))) + (display "(restore " file) + (display (class-name class) file) + (display " (" file) + (let ((slotdefs + (filter (lambda (slotdef) + (not (or (memq (slot-definition-allocation slotdef) + '(#:class #:each-subclass)) + (and (slot-bound? o (slot-definition-name slotdef)) + (excluded? + (slot-ref o (slot-definition-name slotdef)) + env))))) + (class-slots class)))) + (if (not (null? slotdefs)) + (begin + (display (slot-definition-name (car slotdefs)) file) + (for-each (lambda (slotdef) + (display #\space file) + (display (slot-definition-name slotdef) file)) + (cdr slotdefs))))) + (display #\) file) + (access-for-each (lambda (name aname get set) + (display #\space file) + (let ((val (get o))) + (cond ((unbound? val) + (display '(make-unbound) file)) + ((excluded? val env)) + (else + (if (literal? val env) + (display #\' file)) + (write-component val + (if aname + `(set! (,aname ,o) ,val) + `(slot-set! ,o ',name ,val)) + file env))))) + class) + (display #\) file))) + +;;; +;;; Classes +;;; + +;;; Currently, we don't support reading in class objects +;;; + +(define-method (enumerate! (o <class>) env) #f) + +(define-method (write-readably (o <class>) file env) + (display (class-name o) file)) + +;;; +;;; Generics +;;; + +;;; Currently, we don't support reading in generic functions +;;; + +(define-method (enumerate! (o <generic>) env) #f) + +(define-method (write-readably (o <generic>) file env) + (display (generic-function-name o) file)) + +;;; +;;; Method +;;; + +;;; Currently, we don't support reading in methods +;;; + +(define-method (enumerate! (o <method>) env) #f) + +(define-method (write-readably (o <method>) file env) + (goops-error "No read-syntax for <method> defined")) + +;;; +;;; Environments +;;; + +(define-class <environment> () + (object-info #:accessor object-info + #:init-form (make-hash-table 61)) + (excluded #:accessor excluded + #:init-form (make-hash-table 61)) + (pass-2? #:accessor pass-2? + #:init-value #f) + (ref-stack #:accessor ref-stack + #:init-value '()) + (objects #:accessor objects + #:init-value '()) + (pre-defines #:accessor pre-defines + #:init-value '()) + (locals #:accessor locals + #:init-value '()) + (stand-ins #:accessor stand-ins + #:init-value '()) + (post-defines #:accessor post-defines + #:init-value '()) + (patchers #:accessor patchers + #:init-value '()) + (multiple-bound #:accessor multiple-bound + #:init-value '()) + ) + +(define-method (initialize (env <environment>) initargs) + (next-method) + (cond ((get-keyword #:excluded initargs #f) + => (lambda (excludees) + (for-each (lambda (e) + (hashq-create-handle! (excluded env) e #f)) + excludees))))) + +(define-method (object-info o env) + (hashq-ref (object-info env) o)) + +(define-method ((setter object-info) o env x) + (hashq-set! (object-info env) o x)) + +(define (excluded? o env) + (hashq-get-handle (excluded env) o)) + +(define (add-patcher! patcher env) + (set! (patchers env) (cons patcher (patchers env)))) + +(define (push-ref! o env) + (set! (ref-stack env) (cons o (ref-stack env)))) + +(define (pop-ref! env) + (set! (ref-stack env) (cdr (ref-stack env)))) + +(define (container env) + (car (ref-stack env))) + +(define-class <object-info> () + (visiting #:accessor visiting + #:init-value #f) + (binding #:accessor binding + #:init-value #f) + (literal? #:accessor literal? + #:init-value #f) + ) + +(define visiting? visiting) + +(define-method (binding (info <boolean>)) + #f) + +(define-method (binding o env) + (binding (object-info o env))) + +(define binding? binding) + +(define-method (literal? (info <boolean>)) + #t) + +;;; Note that this method is intended to be used only during the +;;; writing pass +;;; +(define-method (literal? o env) + (or (immediate? o) + (excluded? o env) + (let ((info (object-info o env))) + ;; write-component sets all bindings first to #:defining, + ;; then to #:defined + (and (or (not (binding? info)) + ;; we might be using `literal?' in a write-readably method + ;; to query about the object being defined + (and (eq? (visiting info) #:defining) + (null? (cdr (ref-stack env))))) + (literal? info))))) + +;;; +;;; Enumeration +;;; + +;;; Enumeration has two passes. +;;; +;;; Pass 1: Detect common substructure, circular references and order +;;; +;;; Pass 2: Detect literals + +(define (enumerate-component! o env) + (cond ((immediate? o) #t) + ((readable? o) #f) + ((excluded? o env) #t) + ((pass-2? env) + (let ((info (object-info o env))) + (if (binding? info) + ;; if circular reference, we print as a literal + ;; (note that during pass-2, circular references are + ;; forward references, i.e. *not* yet marked with #:pass-2 + (not (eq? (visiting? info) #:pass-2)) + (and (enumerate! o env) + (begin + (set! (literal? info) #t) + #t))))) + ((object-info o env) + => (lambda (info) + (set! (binding info) #t) + (if (visiting? info) + ;; circular reference--mark container + (set! (binding (object-info (container env) env)) #t)))) + (else + (let ((info (make <object-info>))) + (set! (object-info o env) info) + (push-ref! o env) + (set! (visiting? info) #t) + (enumerate! o env) + (set! (visiting? info) #f) + (pop-ref! env) + (set! (objects env) (cons o (objects env))))))) + +(define (write-component-procedure o file env) + "Return #f if circular reference" + (cond ((immediate? o) (write o file) #t) + ((readable? o) (write (readable-expression o) file) #t) + ((excluded? o env) (display #f file) #t) + (else + (let ((info (object-info o env))) + (cond ((not (binding? info)) (write-readably o file env) #t) + ((not (eq? (visiting info) #:defined)) #f) ;forward reference + (else (display (binding info) file) #t)))))) + +;;; write-component OBJECT PATCHER FILE ENV +;;; +(define-macro (write-component object patcher file env) + `(or (write-component-procedure ,object ,file ,env) + (begin + (display #f ,file) + (add-patcher! ,patcher ,env)))) + +;;; +;;; Main engine +;;; + +(define binding-name car) +(define binding-object cdr) + +(define (pass-1! alist env) + ;; Determine object order and necessary bindings + (for-each (lambda (binding) + (enumerate-component! (binding-object binding) env)) + alist)) + +(define (make-local i) + (string->symbol (string-append "%o" (number->string i)))) + +(define (name-bindings! alist env) + ;; Name top-level bindings + (for-each (lambda (b) + (let ((o (binding-object b))) + (if (not (or (immediate? o) + (readable? o) + (excluded? o env))) + (let ((info (object-info o env))) + (if (symbol? (binding info)) + ;; already bound to a variable + (set! (multiple-bound env) + (acons (binding info) + (binding-name b) + (multiple-bound env))) + (set! (binding info) + (binding-name b))))))) + alist) + ;; Name rest of bindings and create stand-in and definition lists + (let post-loop ((ls (objects env)) + (post-defs '())) + (cond ((or (null? ls) + (eq? (binding (car ls) env) #t)) + (set! (post-defines env) post-defs) + (set! (objects env) ls)) + ((not (binding (car ls) env)) + (post-loop (cdr ls) post-defs)) + (else + (post-loop (cdr ls) (cons (car ls) post-defs))))) + (let pre-loop ((ls (reverse (objects env))) + (i 0) + (pre-defs '()) + (locs '()) + (sins '())) + (if (null? ls) + (begin + (set! (pre-defines env) (reverse pre-defs)) + (set! (locals env) (reverse locs)) + (set! (stand-ins env) (reverse sins))) + (let ((info (object-info (car ls) env))) + (cond ((not (binding? info)) + (pre-loop (cdr ls) i pre-defs locs sins)) + ((boolean? (binding info)) + ;; local + (set! (binding info) (make-local i)) + (pre-loop (cdr ls) + (+ 1 i) + pre-defs + (cons (car ls) locs) + sins)) + ((null? locs) + (pre-loop (cdr ls) + i + (cons (car ls) pre-defs) + locs + sins)) + (else + (let ((real-name (binding info))) + (set! (binding info) (make-local i)) + (pre-loop (cdr ls) + (+ 1 i) + pre-defs + (cons (car ls) locs) + (acons (binding info) real-name sins))))))))) + +(define (pass-2! env) + (set! (pass-2? env) #t) + (for-each (lambda (o) + (let ((info (object-info o env))) + (set! (literal? info) (enumerate! o env)) + (set! (visiting info) #:pass-2))) + (append (pre-defines env) + (locals env) + (post-defines env)))) + +(define (write-define! name val literal? file) + (display "(define " file) + (display name file) + (display #\space file) + (if literal? (display #\' file)) + (write val file) + (display ")\n" file)) + +(define (write-empty-defines! file env) + (for-each (lambda (stand-in) + (write-define! (cdr stand-in) #f #f file)) + (stand-ins env)) + (for-each (lambda (o) + (write-define! (binding o env) #f #f file)) + (post-defines env))) + +(define (write-definition! prefix o file env) + (display prefix file) + (let ((info (object-info o env))) + (display (binding info) file) + (display #\space file) + (if (literal? info) + (display #\' file)) + (push-ref! o env) + (set! (visiting info) #:defining) + (write-readably o file env) + (set! (visiting info) #:defined) + (pop-ref! env) + (display #\) file))) + +(define (write-let*-head! file env) + (display "(let* (" file) + (write-definition! "(" (car (locals env)) file env) + (for-each (lambda (o) + (write-definition! "\n (" o file env)) + (cdr (locals env))) + (display ")\n" file)) + +(define (write-rebindings! prefix bindings file env) + (for-each (lambda (patch) + (display prefix file) + (display (cdr patch) file) + (display #\space file) + (display (car patch) file) + (display ")\n" file)) + bindings)) + +(define (write-definitions! selector prefix file env) + (for-each (lambda (o) + (write-definition! prefix o file env) + (newline file)) + (selector env))) + +(define (write-patches! prefix file env) + (for-each (lambda (patch) + (display prefix file) + (display (let name-objects ((patcher patch)) + (cond ((binding patcher env) + => (lambda (name) + (cond ((assq name (stand-ins env)) + => cdr) + (else name)))) + ((pair? patcher) + (cons (name-objects (car patcher)) + (name-objects (cdr patcher)))) + (else patcher))) + file) + (newline file)) + (reverse (patchers env)))) + +(define (write-immediates! alist file) + (for-each (lambda (b) + (if (immediate? (binding-object b)) + (write-define! (binding-name b) + (binding-object b) + #t + file))) + alist)) + +(define (write-readables! alist file env) + (let ((written '())) + (for-each (lambda (b) + (cond ((not (readable? (binding-object b)))) + ((assq (binding-object b) written) + => (lambda (p) + (set! (multiple-bound env) + (acons (cdr p) + (binding-name b) + (multiple-bound env))))) + (else + (write-define! (binding-name b) + (readable-expression (binding-object b)) + #f + file) + (set! written (acons (binding-object b) + (binding-name b) + written))))) + alist))) + +(define-method (save-objects (alist <pair>) (file <string>) . rest) + (let ((port (open-output-file file))) + (apply save-objects alist port rest) + (close-port port) + *unspecified*)) + +(define-method (save-objects (alist <pair>) (file <output-port>) . rest) + (let ((excluded (if (>= (length rest) 1) (car rest) '())) + (uses (if (>= (length rest) 2) (cadr rest) '()))) + (let ((env (make <environment> #:excluded excluded))) + (pass-1! alist env) + (name-bindings! alist env) + (pass-2! env) + (if (not (null? uses)) + (begin + (write `(use-modules ,@uses) file) + (newline file))) + (write-immediates! alist file) + (if (null? (locals env)) + (begin + (write-definitions! post-defines "(define " file env) + (write-patches! "" file env)) + (begin + (write-definitions! pre-defines "(define " file env) + (write-empty-defines! file env) + (write-let*-head! file env) + (write-rebindings! " (set! " (stand-ins env) file env) + (write-definitions! post-defines " (set! " file env) + (write-patches! " " file env) + (display " )\n" file))) + (write-readables! alist file env) + (write-rebindings! "(define " (reverse (multiple-bound env)) file env)))) + +(define-method (load-objects (file <string>)) + (let* ((port (open-input-file file)) + (objects (load-objects port))) + (close-port port) + objects)) + +(define-method (load-objects (file <input-port>)) + (let ((m (make-module))) + (module-use! m the-scm-module) + (module-use! m %module-public-interface) + (save-module-excursion + (lambda () + (set-current-module m) + (let loop ((sexp (read file))) + (if (not (eof-object? sexp)) + (begin + (eval sexp m) + (loop (read file))))))) + (module-map (lambda (name var) + (cons name (variable-ref var))) + m))) diff --git a/module/oop/goops/simple.scm b/module/oop/goops/simple.scm new file mode 100644 index 000000000..bc5405a8d --- /dev/null +++ b/module/oop/goops/simple.scm @@ -0,0 +1,31 @@ +;;; installed-scm-file + +;;;; Copyright (C) 2005, 2006 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +;;;; + + +(define-module (oop goops simple) + :use-module (oop goops accessors) + :export (define-class) + :no-backtrace) + +(define-syntax define-class + (syntax-rules () + ((_ arg ...) + (define-class-with-accessors-keywords arg ...)))) + +(module-use! %module-public-interface (resolve-interface '(oop goops))) diff --git a/module/oop/goops/stklos.scm b/module/oop/goops/stklos.scm new file mode 100644 index 000000000..835969f13 --- /dev/null +++ b/module/oop/goops/stklos.scm @@ -0,0 +1,76 @@ +;;;; Copyright (C) 1999,2002, 2006 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +;;;; + + +(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-syntax define-class + (syntax-rules () + ((_ name supers (slot ...) rest ...) + (standard-define-class name supers slot ... rest ...)))) + +(define (toplevel-define! name val) + (module-define! (current-module) name val)) + +(define-syntax define-method + (syntax-rules (setter) + ((_ (setter name) rest ...) + (begin + (if (or (not (defined? 'name)) + (not (is-a? name <generic-with-setter>))) + (toplevel-define! 'name + (ensure-accessor + (if (defined? 'name) name #f) 'name))) + (add-method! (setter name) (method rest ...)))) + ((_ name rest ...) + (begin + (if (or (not (defined? 'name)) + (not (or (is-a? name <generic>) + (is-a? name <primitive-generic>)))) + (toplevel-define! 'name + (ensure-generic + (if (defined? 'name) name #f) 'name))) + (add-method! name (method rest ...)))))) diff --git a/module/oop/goops/util.scm b/module/oop/goops/util.scm new file mode 100644 index 000000000..69bb898bf --- /dev/null +++ b/module/oop/goops/util.scm @@ -0,0 +1,71 @@ +;;;; Copyright (C) 1999, 2000, 2001, 2003, 2006, 2008 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +;;;; + + +(define-module (oop goops util) + :export (mapappend find-duplicate top-level-env top-level-env? + map* for-each* length* improper->proper) + :use-module (srfi srfi-1) + :re-export (any every) + :no-backtrace + ) + + +;;; +;;; {Utilities} +;;; + +(define mapappend append-map) + +(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) + (let ((mod (current-module))) + (if mod + (module-eval-closure mod) + '()))) + +(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))) |