mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 20:00:19 +02:00
* srfi-13.scm: Mark replacements.
* srfi-17.scm: Mark replacements. * boot-9.scm (module-make-local-var!): Use module-add!. (module-primitive-add!): New function. (resolve-interface): Use (call-with-deferred-observers, module-call-observers): New functions. (module-defer-observers, module-defer-observers-mute, module-defer-observers-table): New variables. (process-define-module, process-use-modules, export, re-export): Use call-with-deferred-observers. * syncase.scm (eval): Mark as replacement. * boot-9.scm (defmacro-public): Use export-syntax instead of export.
This commit is contained in:
parent
70a9dc9cde
commit
d57da08b6d
6 changed files with 100 additions and 39 deletions
|
@ -1,5 +1,19 @@
|
|||
2003-03-12 Mikael Djurfeldt <djurfeldt@nada.kth.se>
|
||||
|
||||
* boot-9.scm (module-make-local-var!): Use module-add!.
|
||||
(module-primitive-add!): New function.
|
||||
(resolve-interface): Use
|
||||
(call-with-deferred-observers, module-call-observers): New
|
||||
functions.
|
||||
(module-defer-observers, module-defer-observers-mute,
|
||||
module-defer-observers-table): New variables.
|
||||
(process-define-module, process-use-modules, export, re-export):
|
||||
Use call-with-deferred-observers.
|
||||
|
||||
* syncase.scm (eval): Mark as replacement.
|
||||
|
||||
* boot-9.scm (defmacro-public): Use export-syntax instead of export.
|
||||
|
||||
* slib.scm (*features*): Set the core variable instead of defining
|
||||
a local version.
|
||||
(provide, provided?): Mark as replacements.
|
||||
|
|
|
@ -1072,7 +1072,33 @@
|
|||
(set-module-observers! module (delq1! id (module-observers module)))))
|
||||
*unspecified*)
|
||||
|
||||
(define module-defer-observers #f)
|
||||
(define module-defer-observers-mutex (make-mutex))
|
||||
(define module-defer-observers-table (make-hash-table))
|
||||
|
||||
(define (module-modified m)
|
||||
(if module-defer-observers
|
||||
(hash-set! module-defer-observers-table m #t)
|
||||
(module-call-observers m)))
|
||||
|
||||
;;; This function can be used to delay calls to observers so that they
|
||||
;;; can be called once only in the face of massive updating of modules.
|
||||
;;;
|
||||
(define (call-with-deferred-observers thunk)
|
||||
(dynamic-wind
|
||||
(lambda ()
|
||||
(lock-mutex module-defer-observers-mutex)
|
||||
(set! module-defer-observers #t))
|
||||
thunk
|
||||
(lambda ()
|
||||
(set! module-defer-observers #f)
|
||||
(hash-for-each (lambda (m dummy)
|
||||
(module-call-observers m))
|
||||
module-defer-observers-table)
|
||||
(hash-clear! module-defer-observers-table)
|
||||
(unlock-mutex module-defer-observers-mutex))))
|
||||
|
||||
(define (module-call-observers m)
|
||||
(for-each (lambda (proc) (proc m)) (module-observers m))
|
||||
(hash-fold (lambda (id proc res) (proc m)) #f (module-weak-observers m)))
|
||||
|
||||
|
@ -1267,18 +1293,21 @@
|
|||
;; If no variable was already there, then create a new and uninitialzied
|
||||
;; variable.
|
||||
;;
|
||||
;; This function is used in modules.c.
|
||||
;;
|
||||
(define (module-make-local-var! m v)
|
||||
(or (let ((b (module-obarray-ref (module-obarray m) v)))
|
||||
(and (variable? b)
|
||||
(begin
|
||||
;; Mark as modified since this function is called when
|
||||
;; the standard eval closure defines a binding
|
||||
(module-modified m)
|
||||
b)))
|
||||
(and (module-binder m)
|
||||
((module-binder m) m v #t))
|
||||
(begin
|
||||
(let ((answer (make-undefined-variable)))
|
||||
(module-obarray-set! (module-obarray m) v answer)
|
||||
(module-modified m)
|
||||
(module-add! m v answer)
|
||||
answer))))
|
||||
|
||||
;; module-ensure-local-variable! module symbol
|
||||
|
@ -1778,11 +1807,12 @@
|
|||
(re-exports '())
|
||||
(replacements '()))
|
||||
(if (null? kws)
|
||||
(begin
|
||||
(call-with-deferred-observers
|
||||
(lambda ()
|
||||
(module-use-interfaces! module (reverse reversed-interfaces))
|
||||
(module-export! module exports)
|
||||
(module-replace! module replacements)
|
||||
(module-re-export! module re-exports))
|
||||
(module-re-export! module re-exports)))
|
||||
(case (car kws)
|
||||
((#:use-module #:use-syntax)
|
||||
(or (pair? (cdr kws))
|
||||
|
@ -2639,11 +2669,13 @@
|
|||
;; to change scm_c_use_module as well.
|
||||
|
||||
(define (process-use-modules module-interface-args)
|
||||
(module-use-interfaces! (current-module)
|
||||
(map (lambda (mif-args)
|
||||
(let ((interfaces (map (lambda (mif-args)
|
||||
(or (apply resolve-interface mif-args)
|
||||
(error "no such module" mif-args)))
|
||||
module-interface-args)))
|
||||
(call-with-deferred-observers
|
||||
(lambda ()
|
||||
(module-use-interfaces! (current-module) interfaces)))))
|
||||
|
||||
(defmacro use-modules modules
|
||||
`(eval-case
|
||||
|
@ -2703,7 +2735,7 @@
|
|||
(#t
|
||||
(let ((name (defined-name (car args))))
|
||||
`(begin
|
||||
(eval-case ((load-toplevel) (export ,name)))
|
||||
(eval-case ((load-toplevel) (export-syntax ,name)))
|
||||
(defmacro ,@args))))))
|
||||
|
||||
;; Export a local variable
|
||||
|
@ -2743,14 +2775,18 @@
|
|||
(defmacro export names
|
||||
`(eval-case
|
||||
((load-toplevel)
|
||||
(module-export! (current-module) ',names))
|
||||
(call-with-deferred-observers
|
||||
(lambda ()
|
||||
(module-export! (current-module) ',names))))
|
||||
(else
|
||||
(error "export can only be used at the top level"))))
|
||||
|
||||
(defmacro re-export names
|
||||
`(eval-case
|
||||
((load-toplevel)
|
||||
(module-re-export! (current-module) ',names))
|
||||
(call-with-deferred-observers
|
||||
(lambda ()
|
||||
(module-re-export! (current-module) ',names))))
|
||||
(else
|
||||
(error "re-export can only be used at the top level"))))
|
||||
|
||||
|
|
|
@ -54,7 +54,8 @@
|
|||
syntax-dispatch syntax-error bound-identifier=?
|
||||
datum->syntax-object free-identifier=?
|
||||
generate-temporaries identifier? syntax-object->datum
|
||||
void eval syncase))
|
||||
void syncase)
|
||||
:replace (eval))
|
||||
|
||||
|
||||
|
||||
|
|
|
@ -1,3 +1,9 @@
|
|||
2003-03-12 Mikael Djurfeldt <djurfeldt@nada.kth.se>
|
||||
|
||||
* srfi-13.scm: Mark replacements.
|
||||
|
||||
* srfi-17.scm: Mark replacements.
|
||||
|
||||
2003-03-11 Mikael Djurfeldt <djurfeldt@nada.kth.se>
|
||||
|
||||
* srfi-1.scm (iota, map, for-each, map-in-order, list-index,
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
;;; srfi-13.scm --- String Library
|
||||
|
||||
;; Copyright (C) 2001, 2002 Free Software Foundation, Inc.
|
||||
;; Copyright (C) 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
|
||||
|
@ -47,9 +47,8 @@
|
|||
|
||||
;;; Code:
|
||||
|
||||
(define-module (srfi srfi-13))
|
||||
|
||||
(export
|
||||
(define-module (srfi srfi-13)
|
||||
:export (
|
||||
;;; Predicates
|
||||
;; string? string-null? <= in the core
|
||||
string-any string-every
|
||||
|
@ -59,14 +58,14 @@
|
|||
string-tabulate
|
||||
|
||||
;;; List/string conversion
|
||||
string->list
|
||||
;; string->list extended
|
||||
;; list->string <= in the core
|
||||
reverse-list->string
|
||||
string-join
|
||||
|
||||
;;; Selection
|
||||
;; string-length string-ref <= in the core
|
||||
string-copy
|
||||
;; string-copy extended
|
||||
substring/shared
|
||||
string-copy!
|
||||
string-take string-take-right
|
||||
|
@ -77,7 +76,7 @@
|
|||
|
||||
;;; Modification
|
||||
;; string-set! <= in the core
|
||||
string-fill!
|
||||
;; string-fill! extended
|
||||
|
||||
;;; Comparison
|
||||
string-compare string-compare-ci
|
||||
|
@ -100,15 +99,16 @@
|
|||
string-suffix-ci?
|
||||
|
||||
;;; Searching
|
||||
string-index string-index-right
|
||||
;; string-index extended
|
||||
string-index-right
|
||||
string-skip string-skip-right
|
||||
string-count
|
||||
string-contains string-contains-ci
|
||||
|
||||
;;; Alphabetic case mapping
|
||||
|
||||
string-upcase string-upcase!
|
||||
string-downcase string-downcase!
|
||||
;; string-upcase string-upcase! extended
|
||||
;; string-downcase string-downcase! extended
|
||||
string-titlecase string-titlecase!
|
||||
|
||||
;;; Reverse/Append
|
||||
|
@ -140,6 +140,10 @@
|
|||
string-filter
|
||||
string-delete
|
||||
)
|
||||
:replace (string->list string-copy string-fill!
|
||||
string-upcase! string-upcase string-downcase! string-downcase
|
||||
string-index)
|
||||
)
|
||||
|
||||
(cond-expand-provide (current-module) '(srfi-13))
|
||||
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
;;; srfi-17.scm --- Generalized set!
|
||||
|
||||
;; Copyright (C) 2001, 2002 Free Software Foundation, Inc.
|
||||
;; Copyright (C) 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
|
||||
|
@ -68,9 +68,9 @@
|
|||
;;; Code:
|
||||
|
||||
(define-module (srfi srfi-17)
|
||||
:export (getter-with-setter
|
||||
:export (getter-with-setter)
|
||||
:replace (;; redefined standard procedures
|
||||
setter
|
||||
;; redefined standard procedures
|
||||
car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar
|
||||
cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr
|
||||
caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue