1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00

Fold (oop goops util) into (oop goops)

* module/oop/goops/util.scm: Removed.  Instead we fold these definitions
  into goops.scm.

* module/oop/goops/save.scm: Remove useless import of util.scm.

* module/oop/goops.scm: Fold in util.scm.  Since we always use
  add-interesting-primitive!, import (language tree-il primitives) in
  the header.  Clean up some early comments, and use of eval-when.

* module/Makefile.am: Adapt.
This commit is contained in:
Andy Wingo 2015-01-12 21:43:48 +01:00
parent 06d54b3f70
commit ac5185c262
4 changed files with 30 additions and 57 deletions

View file

@ -361,7 +361,6 @@ OOP_SOURCES = \
oop/goops/internal.scm \
oop/goops/save.scm \
oop/goops/stklos.scm \
oop/goops/util.scm \
oop/goops/accessors.scm \
oop/goops/simple.scm

View file

@ -27,8 +27,9 @@
(define-module (oop goops)
#:use-module (srfi srfi-1)
#:use-module (ice-9 match)
#:use-module (oop goops util)
#:use-module (system base target)
#:use-module ((language tree-il primitives)
:select (add-interesting-primitive!))
#:export-syntax (define-class class standard-define-class
define-generic define-accessor define-method
define-extended-generic define-extended-generics
@ -121,7 +122,6 @@
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?
@ -136,18 +136,10 @@
slot-exists? make find-method get-keyword)
#:no-backtrace)
;; XXX FIXME: figure out why the 'eval-when's in this file must use
;; 'compile' and must avoid 'expand', but only in 2.2, and only when
;; compiling something that imports goops, e.g. (ice-9 occam-channel),
;; before (oop goops) itself has been compiled.
;; First initialize the builtin part of GOOPS
(eval-when (compile load eval)
(eval-when (expand load eval)
(load-extension (string-append "libguile-" (effective-version))
"scm_init_goops_builtins"))
(eval-when (compile load eval)
(use-modules ((language tree-il primitives) :select (add-interesting-primitive!)))
"scm_init_goops_builtins")
(add-interesting-primitive! 'class-of))
(define-syntax macro-fold-left
@ -1697,6 +1689,31 @@ followed by its associated value. If @var{l} does not hold a value for
#:make-procedure make-procedure
#:procedure procedure)))))))))
;;;
;;; {Utilities}
;;;
;;; These are useful when dealing with method specializers, which might
;;; have a rest argument.
;;;
(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)))
;;;
;;; {add-method!}
;;;

View file

@ -1,6 +1,6 @@
;;; installed-scm-file
;;;; Copyright (C) 2000,2001,2002, 2006, 2009, 2010, 2013 Free Software Foundation, Inc.
;;;; Copyright (C) 2000,2001,2002, 2006, 2009, 2010, 2013, 2015 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
@ -20,7 +20,6 @@
(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!

View file

@ -1,42 +0,0 @@
;;;; Copyright (C) 1999, 2000, 2001, 2003, 2006, 2008, 2012, 2015 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 (map* for-each* length*))
;;;
;;; {Utilities}
;;;
(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)))