mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-14 15:40:19 +02:00
Code Activity

move ice-9/ and oop/ under module/

Browse source 
Moved ice-9/ and oop/ under module/, with the idea being that we have
only scheme under module/. Adjusted configure.in and Makefile.am
appropriately. Put oop/ at the end of the compilation order.
This commit is contained in:
Andy Wingo 2008-11-01 12:44:21 +01:00
parent 5192c9e89b
commit 00d0489205
95 changed files with 8 additions and 8 deletions
Download patch file Download diff file Expand all files Collapse all files

300
module/oop/ChangeLog-2008 Normal file
View file

@ -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:

30
module/oop/Makefile.am Normal file
View file

@ -0,0 +1,30 @@
## Process this file with automake to produce Makefile.in.
##
## Copyright (C) 2000, 2004, 2006, 2008 Free Software Foundation, Inc.
##
## This file is part of GUILE.
##
## GUILE is free software; you can redistribute it and/or modify
## it under the terms of the GNU General Public License as
## published by the Free Software Foundation; either version 2, or
## (at your option) any later version.
##
## GUILE is distributed in the hope that it will be useful, but
## WITHOUT ANY WARRANTY; without even the implied warranty of
## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
## GNU General Public License for more details.
##
## You should have received a copy of the GNU General Public
## License along with GUILE; see the file COPYING. If not, write
## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
## Floor, Boston, MA 02110-1301 USA
AUTOMAKE_OPTIONS = gnu
SUBDIRS = goops
modpath = oop
SOURCES = goops.scm
include $(top_srcdir)/guilec.mk
EXTRA_DIST += ChangeLog-2008

1636
module/oop/goops.scm Normal file
View file

File diff suppressed because it is too large Load diff

30
module/oop/goops/Makefile.am Normal file
View file

@ -0,0 +1,30 @@
## Process this file with automake to produce Makefile.in.
##
## Copyright (C) 2000, 2001, 2004, 2005, 2006 Free Software Foundation, Inc.
##
## This file is part of GUILE.
##
## GUILE is free software; you can redistribute it and/or modify
## it under the terms of the GNU General Public License as
## published by the Free Software Foundation; either version 2, or
## (at your option) any later version.
##
## GUILE is distributed in the hope that it will be useful, but
## WITHOUT ANY WARRANTY; without even the implied warranty of
## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
## GNU General Public License for more details.
##
## You should have received a copy of the GNU General Public
## License along with GUILE; see the file COPYING. If not, write
## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
## Floor, Boston, MA 02110-1301 USA
AUTOMAKE_OPTIONS = gnu
modpath = oop/goops
SOURCES = \
active-slot.scm compile.scm composite-slot.scm describe.scm \
dispatch.scm internal.scm save.scm stklos.scm util.scm \
accessors.scm simple.scm
include $(top_srcdir)/guilec.mk

73
module/oop/goops/accessors.scm Normal file
View file

@ -0,0 +1,73 @@
;;;; Copyright (C) 1999, 2000, 2005, 2006 Free Software Foundation, Inc.
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2, or (at your option)
;;;; any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING. If not, write to
;;;; the Free Software Foundation, Inc., 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))))

66
module/oop/goops/active-slot.scm Normal file
View file

@ -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 2.1 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)))

222
module/oop/goops/compile.scm Normal file
View file

@ -0,0 +1,222 @@
;;;; 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 2.1 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-case ((compile-toplevel) (resolve-module '(oop goops))))
(define-module (oop goops compile)
:use-module (oop goops)
:use-module (oop goops util)
:export (compute-cmethod compute-entry-with-cmethod
compile-method cmethod-code cmethod-environment)
:no-backtrace
)
;;;
;;; Method entries
;;;
(define code-table-lookup
(letrec ((check-entry (lambda (entry types)
(if (null? types)
(and (not (struct? (car entry)))
entry)
(and (eq? (car entry) (car types))
(check-entry (cdr entry) (cdr types)))))))
(lambda (code-table types)
(cond ((null? code-table) #f)
((check-entry (car code-table) types)
=> (lambda (cmethod)
(cons (car code-table) cmethod)))
(else (code-table-lookup (cdr code-table) types))))))
(define (compute-entry-with-cmethod methods types)
(or (code-table-lookup (slot-ref (car methods) 'code-table) types)
(let* ((method (car methods))
(cmethod (compile-method methods types))
(entry (append types cmethod)))
(slot-set! method 'code-table
(cons entry (slot-ref method 'code-table)))
(cons entry cmethod))))
(define (compute-cmethod methods types)
(cdr (compute-entry-with-cmethod methods types)))
;;;
;;; Next methods
;;;
;;; Temporary solution---return #f if x doesn't refer to `next-method'.
(define (next-method? x)
(and (pair? x)
(or (eq? (car x) 'next-method)
(next-method? (car x))
(next-method? (cdr x)))))
(define (make-final-make-next-method method)
(lambda default-args
(lambda args
(@apply method (if (null? args) default-args args)))))
(define (make-final-make-no-next-method gf)
(lambda default-args
(lambda args
(no-next-method gf (if (null? args) default-args args)))))
;;;
;;; Method compilation
;;;
;;; 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. There are two compilation
;;; strategies implemented: one for the memoizer, and one for the VM
;;; compiler.
;;;
;;; 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)
(if (slot-ref (car methods) 'compile-env)
(compile-method/vm methods types)
(compile-method/memoizer methods types)))
(define (make-next-method gf methods types)
(if (null? methods)
(lambda args (no-next-method gf args))
(let ((cmethod (compute-cmethod methods types)))
(if (pair? cmethod)
;; if it's a pair, the next-method is interpreted
(local-eval (cons 'lambda (cmethod-code cmethod))
(cmethod-environment cmethod))
;; otherwise a normal procedure
cmethod))))
(define (compile-method/vm methods types)
(let* ((program-external (@ (system vm program) program-external))
(formals (slot-ref (car methods) 'formals))
(body (slot-ref (car methods) 'body)))
(cond
((not (next-method? body))
;; just one method to call -- in the future we could compile this
;; based on the types that we see, but for now just return the
;; method procedure (which is vm-compiled already)
(method-procedure (car methods)))
;; (and-map (lambda (m) (null? (slot-ref m 'compile-env))) methods)
;; many methods, but with no lexical bindings: can inline, in theory.
;;
;; modules complicate this though, the different method bodies only
;; make sense in the contexts of their modules. so while we could
;; expand this to a big letrec, there wouldn't be real inlining.
(else
(let* ((next-method-sym (gensym " next-method"))
(method (car methods))
(cmethod (compile
`(let ((,next-method-sym #f))
(lambda ,formals
(let ((next-method
(lambda args
(if (null? args)
,(if (list? formals)
`(,next-method-sym ,@formals)
`(apply
,next-method-sym
,@(improper->proper formals)))
(apply ,next-method-sym args)))))
,@body)))
(slot-ref method 'compile-env))))
(list-set! (program-external cmethod) 0
(make-next-method (method-generic-function method)
(cdr methods)
types))
cmethod)))))
;;;
;;; Compiling methods for the memoizer
;;;
(define source-formals cadr)
(define source-body cddr)
(define cmethod-code cdr)
(define cmethod-environment car)
(define %tag-body
(nested-ref the-root-module '(app modules oop goops %tag-body)))
;;; An exegetical note: the strategy here seems to be to (a) only put in
;;; next-method if it's referenced in the code; (b) memoize the lookup
;;; lazily, when `next-method' is first called.
(define (make-make-next-method/memoizer vcell gf methods types)
(lambda default-args
(lambda args
(if (null? methods)
(begin
(set-cdr! vcell (make-final-make-no-next-method gf))
(no-next-method gf (if (null? args) default-args args)))
(let* ((cmethod (compute-cmethod methods types))
(method
(if (pair? cmethod)
(local-eval (cons 'lambda (cmethod-code cmethod))
(cmethod-environment cmethod))
cmethod)))
(set-cdr! vcell (make-final-make-next-method method))
(@apply method (if (null? args) default-args args)))))))
(define (compile-method/memoizer+next methods types proc formals body)
(let ((vcell (cons 'goops:make-next-method #f)))
(set-cdr! vcell
(make-make-next-method/memoizer
vcell
(method-generic-function (car methods))
(cdr methods) types))
;;*fixme*
`(,(cons vcell (procedure-environment proc))
,formals
;;*fixme* Only do this on source where next-method can't be inlined
(let ((next-method ,(if (list? formals)
`(goops:make-next-method ,@formals)
`(apply goops:make-next-method
,@(improper->proper formals)))))
,@body))))
(define (compile-method/memoizer methods types)
(let* ((proc (method-procedure (car methods)))
;; XXX - procedure-source can not be guaranteed to be
;; reliable or efficient
(src (procedure-source proc)))
(if src
(let ((formals (source-formals src))
(body (source-body src)))
(if (next-method? body)
(compile-method/memoizer+next methods types proc formals body)
(cons (procedure-environment proc)
(cons formals
(%tag-body body)))
))
proc)))

82
module/oop/goops/composite-slot.scm Normal file
View file

@ -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 2.1 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))))))))

200
module/oop/goops/describe.scm Normal file
View file

@ -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 2.1 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)

275
module/oop/goops/dispatch.scm Normal file
View file

@ -0,0 +1,275 @@
;;;; 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 2.1 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-case ((compile-toplevel) (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))))))
;;; FIXME: the throw probably is expensive, given that this function
;;; might be called an average of 3 or 4 times per rehash...
(define (cache-try-hash! min-misses hashset cache entries)
(let ((max-misses 0)
(mask (- (vector-length cache) 1)))
(catch 'misses
(lambda ()
(do ((ls entries (cdr ls))
(misses 0 0))
((null? ls) max-misses)
(do ((i (logand mask (cache-hashval hashset (car ls)))
(logand mask (+ i 1))))
((and (pair? (vector-ref cache i))
(eq? (car (vector-ref cache i)) 'no-method))
(vector-set! cache i (car ls)))
(set! misses (+ 1 misses))
(if (>= misses min-misses)
(throw 'misses misses)))
(if (> misses max-misses)
(set! max-misses misses))))
(lambda (key misses)
misses))))
;;;
;;; Memoization
;;;
;; Backward compatibility
(if (not (defined? 'lookup-create-cmethod))
(define (lookup-create-cmethod gf args)
(no-applicable-method (car args) (cadr args))))
(define (memoize-method! gf args exp)
(if (not (slot-ref gf 'used-by))
(slot-set! gf 'used-by '()))
(let ((applicable ((if (eq? gf compute-applicable-methods)
%compute-applicable-methods
compute-applicable-methods)
gf args)))
(cond (applicable
;; *fixme* dispatch.scm needs rewriting Since the current
;; code mutates the method cache, we have to work on a
;; copy. Otherwise we might disturb another thread
;; currently dispatching on the cache. (No need to copy
;; the vector.)
(let* ((new (list-copy exp))
(res
(cond ((method-cache-hashed? new)
(method-cache-install! hashed-method-cache-insert!
new args applicable))
((passed-hash-threshold? new)
(method-cache-install! hashed-method-cache-insert!
(method-cache->hashed! new)
args
applicable))
(else
(method-cache-install! method-cache-insert!
new args applicable)))))
(set-cdr! (cdr exp) (cddr new))
res))
((null? args)
(lookup-create-cmethod no-applicable-method (list gf '())))
(else
;; Mutate arglist to fit no-applicable-method
(set-cdr! args (list (cons (car args) (cdr args))))
(set-car! args gf)
(lookup-create-cmethod no-applicable-method args)))))
(set-procedure-property! memoize-method! 'system-procedure #t)
(define method-cache-install!
(letrec ((first-n
(lambda (ls n)
(if (or (zero? n) (null? ls))
'()
(cons (car ls) (first-n (cdr ls) (- n 1)))))))
(lambda (insert! exp args applicable)
(let* ((specializers (method-specializers (car applicable)))
(n-specializers
(if (list? specializers)
(length specializers)
(+ 1 (slot-ref (method-cache-generic-function exp)
'n-specialized)))))
(let* ((types (map class-of (first-n args n-specializers)))
(entry+cmethod (compute-entry-with-cmethod applicable types)))
(insert! exp (car entry+cmethod)) ; entry = types + cmethod
(cdr entry+cmethod) ; cmethod
)))))

30
module/oop/goops/internal.scm Normal file
View file

@ -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 2.1 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))))

868
module/oop/goops/save.scm Normal file
View file

@ -0,0 +1,868 @@
;;; 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 2.1 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
;;;
(if (or (not (defined? 'readables))
(not 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)))

28
module/oop/goops/simple.scm Normal file
View file

@ -0,0 +1,28 @@
;;; 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 2.1 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 define-class define-class-with-accessors-keywords)
(module-use! %module-public-interface (resolve-interface '(oop goops)))

97
module/oop/goops/stklos.scm Normal file
View file

@ -0,0 +1,97 @@
;;;; 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 2.1 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 standard-define-class-transformer
(macro-transformer standard-define-class))
(define define-class
;; Syntax
(let ((name cadr)
(supers caddr)
(slots cadddr)
(rest cddddr))
(procedure->memoizing-macro
(lambda (exp env)
(standard-define-class-transformer
`(define-class ,(name exp) ,(supers exp) ,@(slots exp)
,@(rest exp))
env)))))
(define define-method
(procedure->memoizing-macro
(lambda (exp env)
(let ((name (cadr exp)))
(if (and (pair? name)
(eq? (car name) 'setter)
(pair? (cdr name))
(null? (cddr name)))
(let ((name (cadr name)))
(cond ((not (symbol? name))
(goops-error "bad method name: ~S" name))
((defined? name env)
`(begin
(if (not (is-a? ,name <generic-with-setter>))
(define-accessor ,name))
(add-method! (setter ,name) (method ,@(cddr exp)))))
(else
`(begin
(define-accessor ,name)
(add-method! (setter ,name) (method ,@(cddr exp)))))))
(cond ((not (symbol? name))
(goops-error "bad method name: ~S" name))
((defined? name env)
`(begin
(if (not (or (is-a? ,name <generic>)
(is-a? ,name <primitive-generic>)))
(define-generic ,name))
(add-method! ,name (method ,@(cddr exp)))))
(else
`(begin
(define-generic ,name)
(add-method! ,name (method ,@(cddr exp)))))))))))

71
module/oop/goops/util.scm Normal file
View file

@ -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 2.1 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)))