mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 03:40:34 +02:00
* 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.
This commit is contained in:
Mikael Djurfeldt
parent
b0dff01890
commit
c614a00b8c
10 changed files with 143 additions and 62 deletions
|
|
@ -1,7 +1,16 @@
|
|||
2003-03-11 Mikael Djurfeldt <djurfeldt@nada.kth.se>
|
||||
|
||||
* 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):
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -1,5 +1,7 @@
|
|||
2003-03-11 Mikael Djurfeldt <djurfeldt@nada.kth.se>
|
||||
|
||||
* 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
|
||||
|
|
|
|||
|
|
@ -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 <stdarg.h>
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 */
|
||||
|
|
|
|||
|
|
@ -1,5 +1,7 @@
|
|||
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.
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
'()
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
2003-03-11 Mikael Djurfeldt <djurfeldt@nada.kth.se>
|
||||
|
||||
* 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 <djurfeldt@nada.kth.se>
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue