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):
;;
(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
(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)
;; 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
;;
;; 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.
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)))
(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)
(define keys
;; sym key quote?
'((:select #:select #t)
+ (:hide #:hide #t)
(:prefix #:prefix #t)
(:renamer #:renamer #f)))
(if (not (pair? (car spec)))
(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))
;;;; 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
;;; 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)
(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)
\f
-(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)
(define-command-alias '("info" "stack") "backtrace")
\f
-(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)
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
-/* 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
#include "libguile/validate.h"
#include "libguile/list.h"
+#include "libguile/eval.h"
#ifdef __STDC__
#include <stdarg.h>
}
#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
\f
void
#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
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 */
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.
-;;;; 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
\f
(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
(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)
'()
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>
filter-map
;;; Filtering & partitioning
- filter
+ ;; filter <= in the core
partition
remove
- filter!
+ ;; filter! <= in the core
partition!
remove!
;;; 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 '() '())
(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
HCoop / bpt / guile.git / commitdiff