From c614a00b8c155b59c76c0fe1e272aa2df1f3faf5 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Tue, 11 Mar 2003 19:58:14 +0000 Subject: [PATCH] * srfi-1.scm (filter, filter!): Removed. (Now implemented in the core.) * goops/util.scm (filter): Removed. (Now supplied by core.) * list.c, list.h (scm_filter, scm_filter_x): New functions. * debugger/command-loop.scm: Prefix all commands imported from (ice-9 debugger command-loop) with debugger:. * boot-9.scm (resolve-interface): Process #:hide; Name custom interfaces appropriately. (module-use!, module-use-interfaces!): Remove existing interfaces on the use-list based on module name rather than interface identity so that custom interfaces truly replaces their previous version. --- ice-9/ChangeLog | 9 +++++ ice-9/boot-9.scm | 64 +++++++++++++++++++++++---------- ice-9/debugger/command-loop.scm | 30 ++++++++-------- libguile/ChangeLog | 2 ++ libguile/list.c | 61 ++++++++++++++++++++++++++++++- libguile/list.h | 4 ++- oop/ChangeLog | 2 ++ oop/goops/util.scm | 9 ++--- srfi/ChangeLog | 5 +-- srfi/srfi-1.scm | 19 ++-------- 10 files changed, 143 insertions(+), 62 deletions(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 66ff590d7..695083234 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,7 +1,16 @@ 2003-03-11 Mikael Djurfeldt + * debugger/command-loop.scm: Prefix all commands imported from + (ice-9 debugger command-loop) with debugger:. + * boot-9.scm (process-duplicates): Use module-import-interface. (module-symbol-interface): Removed. + (resolve-interface): Process #:hide; Name custom interfaces + appropriately. + (module-use!, module-use-interfaces!): Remove existing interfaces + on the use-list based on module name rather than interface + identity so that custom interfaces truly replaces their previous + version. * boot-9.scm (module-override!, make-mutable-parameter, lookup-duplicates-handlers, default-module-duplicates-handler): diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index a447e9b76..96cb250c2 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -1444,7 +1444,11 @@ ;; (define (module-use! module interface) (set-module-uses! module - (cons interface (delq! interface (module-uses module)))) + (cons interface + (filter (lambda (m) + (not (equal? (module-name m) + (module-name interface)))) + (module-uses module)))) (module-modified module)) ;; MODULE-USE-INTERFACES! module interfaces @@ -1459,7 +1463,11 @@ (set! uses (delq! (cdr duplicates-info) uses)) ;; remove interfaces to be added (for-each (lambda (interface) - (set! uses (delq! interface uses))) + (set! uses + (filter (lambda (m) + (not (equal? (module-name m) + (module-name interface)))) + uses))) interfaces) ;; add interfaces to use list (set-module-uses! module uses) @@ -1663,7 +1671,7 @@ ;; Return a module that is an interface to the module designated by ;; NAME. ;; -;; `resolve-interface' takes two keyword arguments: +;; `resolve-interface' takes four keyword arguments: ;; ;; #:select SELECTION ;; @@ -1676,17 +1684,20 @@ ;; are made available in the interface. Bindings that are added later ;; are not picked up. ;; -;; #:renamer RENAMER +;; #:hide BINDINGS ;; -;; RENAMER is a procedure that takes a symbol and returns its new -;; name. The default is to append a specified prefix (see below) or -;; not perform any renaming. +;; BINDINGS is a list of bindings which should not be imported. ;; ;; #:prefix PREFIX ;; ;; PREFIX is a symbol that will be appended to each exported name. ;; The default is to not perform any renaming. ;; +;; #:renamer RENAMER +;; +;; RENAMER is a procedure that takes a symbol and returns its new +;; name. The default is not perform any renaming. +;; ;; Signal "no code for module" error if module name is not resolvable ;; or its public interface is not available. Signal "no binding" ;; error if selected binding does not exist in the used module. @@ -1703,6 +1714,7 @@ def))) (let* ((select (get-keyword-arg args #:select #f)) + (hide (get-keyword-arg args #:hide '())) (renamer (or (get-keyword-arg args #:renamer #f) (let ((prefix (get-keyword-arg args #:prefix #f))) (and prefix (symbol-prefix-proc prefix))) @@ -1711,27 +1723,40 @@ (public-i (and module (module-public-interface module)))) (and (or (not module) (not public-i)) (error "no code for module" name)) - (if (and (not select) (eq? renamer identity)) + (if (and (not select) (null? hide) (eq? renamer identity)) public-i (let ((selection (or select (module-map (lambda (sym var) sym) public-i))) (custom-i (make-module 31))) - (set-module-kind! custom-i 'interface) + (set-module-kind! custom-i 'custom-interface) + (set-module-name! custom-i name) ;; XXX - should use a lazy binder so that changes to the ;; used module are picked up automatically. (for-each (lambda (bspec) (let* ((direct? (symbol? bspec)) (orig (if direct? bspec (car bspec))) - (seen (if direct? bspec (cdr bspec)))) - (module-add! custom-i (renamer seen) - (or (module-local-variable public-i orig) - (module-local-variable module orig) - (error - ;; fixme: format manually for now - (simple-format - #f "no binding `~A' in module ~A" - orig name)))))) + (seen (if direct? bspec (cdr bspec))) + (var (or (module-local-variable public-i orig) + (module-local-variable module orig) + (error + ;; fixme: format manually for now + (simple-format + #f "no binding `~A' in module ~A" + orig name))))) + (if (memq orig hide) + (set! hide (delq! orig hide)) + (module-add! custom-i + (renamer seen) + var)))) selection) + ;; Check that we are not hiding bindings which don't exist + (for-each (lambda (binding) + (if (not (module-local-variable public-i binding)) + (error + (simple-format + #f "no binding `~A' to hide in module ~A" + binding name)))) + hide) custom-i)))) (define (symbol-prefix-proc prefix) @@ -2551,6 +2576,7 @@ (define keys ;; sym key quote? '((:select #:select #t) + (:hide #:hide #t) (:prefix #:prefix #t) (:renamer #:renamer #f))) (if (not (pair? (car spec))) @@ -2853,7 +2879,7 @@ (define (make-duplicates-interface) (let ((m (make-module))) - (set-module-kind! m 'interface) + (set-module-kind! m 'custom-interface) (set-module-name! m 'duplicates) m)) diff --git a/ice-9/debugger/command-loop.scm b/ice-9/debugger/command-loop.scm index 763c56b90..4473a0a14 100644 --- a/ice-9/debugger/command-loop.scm +++ b/ice-9/debugger/command-loop.scm @@ -1,6 +1,6 @@ ;;;; Guile Debugger command loop -;;; Copyright (C) 1999, 2001, 2002 Free Software Foundation, Inc. +;;; Copyright (C) 1999, 2001, 2002, 2003 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 @@ -42,7 +42,7 @@ ;;; If you do not wish that, delete this exception notice. (define-module (ice-9 debugger command-loop) - #:use-module (ice-9 debugger commands) + #:use-module ((ice-9 debugger commands) :prefix debugger:) #:export (debugger-command-loop debugger-command-loop-error debugger-command-loop-quit) @@ -538,21 +538,21 @@ (error "Unknown value from lookup-command:" value))))) state)) -(define-command "frame" '('optional exact-nonnegative-integer) frame) +(define-command "frame" '('optional exact-nonnegative-integer) debugger:frame) -(define-command "position" '() position) +(define-command "position" '() debugger:position) -(define-command "up" '('optional exact-integer) up) +(define-command "up" '('optional exact-integer) debugger:up) -(define-command "down" '('optional exact-integer) down) +(define-command "down" '('optional exact-integer) debugger:down) -(define-command "backtrace" '('optional exact-integer) backtrace) +(define-command "backtrace" '('optional exact-integer) debugger:backtrace) -(define-command "evaluate" '(object) evaluate) +(define-command "evaluate" '(object) debugger:evaluate) -(define-command '("info" "args") '() info-args) +(define-command '("info" "args") '() debugger:info-args) -(define-command '("info" "frame") '() info-frame) +(define-command '("info" "frame") '() debugger:info-frame) (define-command "quit" '() (lambda (state) @@ -567,12 +567,12 @@ (define-command-alias '("info" "stack") "backtrace") -(define-command "continue" '() continue) +(define-command "continue" '() debugger:continue) -(define-command "finish" '() finish) +(define-command "finish" '() debugger:finish) -(define-command "trace-finish" '() trace-finish) +(define-command "trace-finish" '() debugger:trace-finish) -(define-command "step" '('optional exact-integer) step) +(define-command "step" '('optional exact-integer) debugger:step) -(define-command "next" '('optional exact-integer) next) +(define-command "next" '('optional exact-integer) debugger:next) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index a11364aae..afb2bcdbd 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,5 +1,7 @@ 2003-03-11 Mikael Djurfeldt + * list.c, list.h (scm_filter, scm_filter_x): New functions. + * modules.c (scm_module_import_interface): New function. * goops.c, goops.h (scm_class_accessor_method): Renamed from diff --git a/libguile/list.c b/libguile/list.c index e62ad5b37..41ff2c3fb 100644 --- a/libguile/list.c +++ b/libguile/list.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,2000,2001 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,2000,2001, 2003 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 @@ -47,6 +47,7 @@ #include "libguile/validate.h" #include "libguile/list.h" +#include "libguile/eval.h" #ifdef __STDC__ #include @@ -830,6 +831,64 @@ SCM_DEFINE (scm_delete1_x, "delete1!", 2, 0, 0, } #undef FUNC_NAME +SCM_DEFINE (scm_filter, "filter", 2, 0, 0, + (SCM pred, SCM list), + "Return all the elements of 2nd arg @var{list} that satisfy predicate @var{pred}.\n" + "The list is not disordered -- elements that appear in the result list occur\n" + "in the same order as they occur in the argument list. The returned list may\n" + "share a common tail with the argument list. The dynamic order in which the\n" + "various applications of pred are made is not specified.\n\n" + "@lisp\n" + "(filter even? '(0 7 8 8 43 -4)) => (0 8 8 -4)\n" + "@end lisp") +#define FUNC_NAME s_scm_filter +{ + scm_t_trampoline_1 call = scm_trampoline_1 (pred); + SCM walk; + SCM *prev; + SCM res = SCM_EOL; + SCM_ASSERT (call, pred, 1, FUNC_NAME); + SCM_VALIDATE_LIST (2, list); + + for (prev = &res, walk = list; + SCM_CONSP (walk); + walk = SCM_CDR (walk)) + { + if (!SCM_FALSEP (call (pred, SCM_CAR (walk)))) + { + *prev = scm_cons (SCM_CAR (walk), SCM_EOL); + prev = SCM_CDRLOC (*prev); + } + } + + return res; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_filter_x, "filter!", 2, 0, 0, + (SCM pred, SCM list), + "Linear-update variant of @code{filter}.") +#define FUNC_NAME s_scm_filter_x +{ + scm_t_trampoline_1 call = scm_trampoline_1 (pred); + SCM walk; + SCM *prev; + SCM_ASSERT (call, pred, 1, FUNC_NAME); + SCM_VALIDATE_LIST (2, list); + + for (prev = &list, walk = list; + SCM_CONSP (walk); + walk = SCM_CDR (walk)) + { + if (!SCM_FALSEP (call (pred, SCM_CAR (walk)))) + prev = SCM_CDRLOC (walk); + else + *prev = SCM_CDR (walk); + } + + return list; +} +#undef FUNC_NAME void diff --git a/libguile/list.h b/libguile/list.h index 8fc71992c..3eef19444 100644 --- a/libguile/list.h +++ b/libguile/list.h @@ -3,7 +3,7 @@ #ifndef SCM_LIST_H #define SCM_LIST_H -/* Copyright (C) 1995,1996,1997,2000,2001 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,2000,2001, 2003 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 @@ -86,6 +86,8 @@ SCM_API SCM scm_delete (SCM item, SCM lst); SCM_API SCM scm_delq1_x (SCM item, SCM lst); SCM_API SCM scm_delv1_x (SCM item, SCM lst); SCM_API SCM scm_delete1_x (SCM item, SCM lst); +SCM_API SCM scm_filter (SCM pred, SCM list); +SCM_API SCM scm_filter_x (SCM pred, SCM list); SCM_API void scm_init_list (void); #endif /* SCM_LIST_H */ diff --git a/oop/ChangeLog b/oop/ChangeLog index c03665a43..d9a74f87a 100644 --- a/oop/ChangeLog +++ b/oop/ChangeLog @@ -1,5 +1,7 @@ 2003-03-11 Mikael Djurfeldt + * goops/util.scm (filter): Removed. (Now supplied by core.) + * goops.scm (define-extended-generics): New syntax. ( ): Marked as replacements. diff --git a/oop/goops/util.scm b/oop/goops/util.scm index 9e6a3c927..c88687d93 100644 --- a/oop/goops/util.scm +++ b/oop/goops/util.scm @@ -1,4 +1,4 @@ -;;;; Copyright (C) 1999, 2000, 2001 Free Software Foundation, Inc. +;;;; Copyright (C) 1999, 2000, 2001, 2003 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 @@ -42,7 +42,7 @@ (define-module (oop goops util) - :export (any every filter + :export (any every mapappend find-duplicate top-level-env top-level-env? map* for-each* length* improper->proper) :no-backtrace @@ -85,11 +85,6 @@ (and (apply pred heads) (loop (map car tails) (map cdr tails))))))))) -(define (filter test? list) - (cond ((null? list) '()) - ((test? (car list)) (cons (car list) (filter test? (cdr list)))) - (else (filter test? (cdr list))))) - (define (mapappend func . args) (if (memv '() args) '() diff --git a/srfi/ChangeLog b/srfi/ChangeLog index 638bd828e..ee32af7ba 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,7 +1,8 @@ 2003-03-11 Mikael Djurfeldt - * srfi-1.scm (iota map for-each map-in-order list-index member - delete delete! assoc): Marked as replacements. + * srfi-1.scm (iota, map, for-each, map-in-order, list-index, + member, delete, delete!, assoc): Marked as replacements. + (filter, filter!): Removed. (Now implemented in the core.) 2003-03-06 Mikael Djurfeldt diff --git a/srfi/srfi-1.scm b/srfi/srfi-1.scm index 98ffeb46f..9fadee8e2 100644 --- a/srfi/srfi-1.scm +++ b/srfi/srfi-1.scm @@ -174,10 +174,10 @@ filter-map ;;; Filtering & partitioning - filter + ;; filter <= in the core partition remove - filter! + ;; filter! <= in the core partition! remove! @@ -687,18 +687,6 @@ ;;; Filtering & partitioning -(define (filter pred list) - (check-arg-type list? list "filter") ; reject circular lists. - (letrec ((filiter (lambda (pred rest result) - (if (null? rest) - (reverse! result) - (filiter pred (cdr rest) - (cond ((pred (car rest)) - (cons (car rest) result)) - (else - result))))))) - (filiter pred list '()))) - (define (partition pred list) (if (null? list) (values '() '()) @@ -711,9 +699,6 @@ (define (remove pred list) (filter (lambda (x) (not (pred x))) list)) -(define (filter! pred list) - (filter pred list)) ; XXX:optimize - (define (partition! pred list) (partition pred list)) ; XXX:optimize