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

* lib.scm: Move module the system directives `export',

`export-syntax', `re-export' and `re-export-syntax' into the
  `define-module' form.  This is the recommended way of exporting
  bindings.

* srfi-2.scm, srfi-4.scm, srfi-8.scm, srfi-9.scm, srfi-10.scm,
srfi-11.scm, srfi-14.scm, srfi-16.scm: Move module the system
directives `export', `export-syntax', `re-export' and
`re-export-syntax' into the `define-module' form.  This is the
recommended way of exporting bindings.

* goops.scm, goops/active-slot.scm, goops/compile.scm,
goops/composite-slot.scm, goops/describe.scm, goops/dispatch.scm,
goops/old-define-method.scm, goops/save.scm, goops/util.scm: Move
module the system directives `export', `export-syntax',
`re-export' and `re-export-syntax' into the `define-module' form.
This is the recommended way of exporting bindings.

* slib.scm (array-indexes): New procedure.
(*features*): Extend.  (Probably some of these options should be
set elsewhere.)  (Thanks to Aubrey Jaffer.)

* and-let-star-compat.scm, and-let-star.scm, calling.scm,
  channel.scm, common-list.scm, debug.scm, debugger.scm,
  expect.scm, hcons.scm, lineio.scm, ls.scm, mapping.scm,
  null.scm, optargs.scm, poe.scm, popen.scm, pretty-print.scm,
  q.scm, r5rs.scm, rdelim.scm, regex.scm, runq.scm, safe-r5rs.scm,
  safe.scm, session.scm, slib.scm, streams.scm, string-fun.scm,
  syncase.scm, threads.scm: Move module the system directives
  `export', `export-syntax', `re-export' and `re-export-syntax'
  into the `define-module' form.  This is the recommended way of
  exporting bindings.
This commit is contained in:
Mikael Djurfeldt 2001-10-21 09:49:19 +00:00
parent b461abe73f
commit 1a179b03b0
51 changed files with 700 additions and 570 deletions

View file

@ -1,3 +1,20 @@
2001-10-21 Mikael Djurfeldt <mdj@linnaeus>
* slib.scm (array-indexes): New procedure.
(*features*): Extend. (Probably some of these options should be
set elsewhere.) (Thanks to Aubrey Jaffer.)
* and-let-star-compat.scm, and-let-star.scm, calling.scm,
channel.scm, common-list.scm, debug.scm, debugger.scm,
expect.scm, hcons.scm, lineio.scm, ls.scm, mapping.scm,
null.scm, optargs.scm, poe.scm, popen.scm, pretty-print.scm,
q.scm, r5rs.scm, rdelim.scm, regex.scm, runq.scm, safe-r5rs.scm,
safe.scm, session.scm, slib.scm, streams.scm, string-fun.scm,
syncase.scm, threads.scm: Move module the system directives
`export', `export-syntax', `re-export' and `re-export-syntax'
into the `define-module' form. This is the recommended way of
exporting bindings.
2001-10-17 Mikael Djurfeldt <mdj@linnaeus> 2001-10-17 Mikael Djurfeldt <mdj@linnaeus>
* boot-9.scm (process-define-module): New options: :export-syntax, * boot-9.scm (process-define-module): New options: :export-syntax,

View file

@ -42,7 +42,8 @@
;;;; whether to permit this exception to apply to your modifications. ;;;; whether to permit this exception to apply to your modifications.
;;;; If you do not wish that, delete this exception notice. ;;;; If you do not wish that, delete this exception notice.
(define-module (ice-9 and-let-star)) (define-module (ice-9 and-let-star)
:export-syntax (and-let*))
(defmacro and-let* (vars . body) (defmacro and-let* (vars . body)
@ -68,5 +69,3 @@
(error "not a proper list" vars)))) (error "not a proper list" vars))))
(expand vars body)) (expand vars body))
(export-syntax and-let*)

View file

@ -1,6 +1,6 @@
;;;; calling.scm --- Calling Conventions ;;;; calling.scm --- Calling Conventions
;;;; ;;;;
;;;; Copyright (C) 1995, 1996, 1997, 2000 Free Software Foundation, Inc. ;;;; Copyright (C) 1995, 1996, 1997, 2000, 2001 Free Software Foundation, Inc.
;;;; ;;;;
;;;; This program is free software; you can redistribute it and/or modify ;;;; 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 ;;;; it under the terms of the GNU General Public License as published by
@ -42,7 +42,15 @@
;;;; If you do not wish that, delete this exception notice. ;;;; If you do not wish that, delete this exception notice.
;;;; ;;;;
(define-module (ice-9 calling)) (define-module (ice-9 calling)
:export-syntax (with-excursion-function
with-getter-and-setter
with-getter
with-delegating-getter-and-setter
with-excursion-getter-and-setter
with-configuration-getter-and-setter
with-delegating-configuration-getter-and-setter
let-with-configuration-getter-and-setter))
;;;; ;;;;
;;; ;;;
@ -62,7 +70,7 @@
;;; entering and leaving the call to proc non-locally, such as using ;;; entering and leaving the call to proc non-locally, such as using
;;; call-with-current-continuation, error, or throw. ;;; call-with-current-continuation, error, or throw.
;;; ;;;
(defmacro-public with-excursion-function (vars proc) (defmacro with-excursion-function (vars proc)
`(,proc ,(excursion-function-syntax vars))) `(,proc ,(excursion-function-syntax vars)))
@ -107,7 +115,7 @@
;;; ;; takes its arguments in a different order. ;;; ;; takes its arguments in a different order.
;;; ;;;
;;; ;;;
(defmacro-public with-getter-and-setter (vars proc) (defmacro with-getter-and-setter (vars proc)
`(,proc ,@ (getter-and-setter-syntax vars))) `(,proc ,@ (getter-and-setter-syntax vars)))
;;; with-getter vars proc ;;; with-getter vars proc
@ -115,7 +123,7 @@
;;; The procedure is called: ;;; The procedure is called:
;;; (proc getter) ;;; (proc getter)
;;; ;;;
(defmacro-public with-getter (vars proc) (defmacro with-getter (vars proc)
`(,proc ,(car (getter-and-setter-syntax vars)))) `(,proc ,(car (getter-and-setter-syntax vars))))
@ -132,7 +140,7 @@
;;; proc is a procedure that is called ;;; proc is a procedure that is called
;;; (proc getter setter) ;;; (proc getter setter)
;;; ;;;
(defmacro-public with-delegating-getter-and-setter (vars get-delegate set-delegate proc) (defmacro with-delegating-getter-and-setter (vars get-delegate set-delegate proc)
`(,proc ,@ (delegating-getter-and-setter-syntax vars get-delegate set-delegate))) `(,proc ,@ (delegating-getter-and-setter-syntax vars get-delegate set-delegate)))
@ -146,7 +154,7 @@
;;; with-getter-and-setter ;;; with-getter-and-setter
;;; with-excursion-function ;;; with-excursion-function
;;; ;;;
(defmacro-public with-excursion-getter-and-setter (vars proc) (defmacro with-excursion-getter-and-setter (vars proc)
`(,proc ,(excursion-function-syntax vars) `(,proc ,(excursion-function-syntax vars)
,@ (getter-and-setter-syntax vars))) ,@ (getter-and-setter-syntax vars)))
@ -272,7 +280,7 @@
;;; for the corresponding variable. If omitted, the binding of <var> ;;; for the corresponding variable. If omitted, the binding of <var>
;;; is simply set using set!. ;;; is simply set using set!.
;;; ;;;
(defmacro-public with-configuration-getter-and-setter (vars-etc proc) (defmacro with-configuration-getter-and-setter (vars-etc proc)
`((lambda (simpler-get simpler-set body-proc) `((lambda (simpler-get simpler-set body-proc)
(with-delegating-getter-and-setter () (with-delegating-getter-and-setter ()
simpler-get simpler-set body-proc)) simpler-get simpler-set body-proc))
@ -295,7 +303,7 @@
,proc)) ,proc))
(defmacro-public with-delegating-configuration-getter-and-setter (vars-etc delegate-get delegate-set proc) (defmacro with-delegating-configuration-getter-and-setter (vars-etc delegate-get delegate-set proc)
`((lambda (simpler-get simpler-set body-proc) `((lambda (simpler-get simpler-set body-proc)
(with-delegating-getter-and-setter () (with-delegating-getter-and-setter ()
simpler-get simpler-set body-proc)) simpler-get simpler-set body-proc))
@ -337,10 +345,7 @@
;;; ...) ;;; ...)
;;; (with-configuration-getter-and-setter ((<var1> v1-get v1-set) ...) proc)) ;;; (with-configuration-getter-and-setter ((<var1> v1-get v1-set) ...) proc))
;;; ;;;
(defmacro-public let-with-configuration-getter-and-setter (vars-etc proc) (defmacro let-with-configuration-getter-and-setter (vars-etc proc)
`(let ,(map (lambda (v) `(,(car v) ,(cadr v))) vars-etc) `(let ,(map (lambda (v) `(,(car v) ,(cadr v))) vars-etc)
(with-configuration-getter-and-setter ,(map (lambda (v) `(,(car v) ,(caddr v) ,(cadddr v))) vars-etc) (with-configuration-getter-and-setter ,(map (lambda (v) `(,(car v) ,(caddr v) ,(cadddr v))) vars-etc)
,proc))) ,proc)))

View file

@ -95,7 +95,11 @@
;;; Code: ;;; Code:
(define-module (ice-9 channel)) (define-module (ice-9 channel)
:export (make-object-channel
channel-open
channel-print-value
channel-print-token))
;;; ;;;
;;; Channel type ;;; Channel type
@ -106,7 +110,7 @@
(define make-channel (record-constructor channel-type)) (define make-channel (record-constructor channel-type))
(define-public (make-object-channel printer) (define (make-object-channel printer)
(make-channel (current-input-port) (make-channel (current-input-port)
(current-output-port) (current-output-port)
printer printer
@ -121,7 +125,7 @@
;;; Channel ;;; Channel
;;; ;;;
(define-public (channel-open ch) (define (channel-open ch)
(let ((stdin (channel-stdin ch)) (let ((stdin (channel-stdin ch))
(stdout (channel-stdout ch)) (stdout (channel-stdout ch))
(printer (channel-printer ch)) (printer (channel-printer ch))
@ -155,10 +159,10 @@
(list key (apply format #f (cadr args) (caddr args)))) (list key (apply format #f (cadr args) (caddr args))))
(loop)))))))) (loop))))))))
(define-public (channel-print-value ch val) (define (channel-print-value ch val)
(format (channel-stdout ch) "value = ~S\n" val)) (format (channel-stdout ch) "value = ~S\n" val))
(define-public (channel-print-token ch val) (define (channel-print-token ch val)
(let* ((token (symbol-append (gensym "%%") '%%)) (let* ((token (symbol-append (gensym "%%") '%%))
(pair (cons token (object->string val)))) (pair (cons token (object->string val))))
(format (channel-stdout ch) "token = ~S\n" pair) (format (channel-stdout ch) "token = ~S\n" pair)

View file

@ -75,7 +75,11 @@
;;; Code: ;;; Code:
(define-module (ice-9 common-list)) (define-module (ice-9 common-list)
:export (adjoin union intersection set-difference reduce-init reduce
some every notany notevery count-if find-if member-if remove-if
remove-if-not delete-if! delete-if-not! butlast and? or?
has-duplicates? pick pick-mappings uniq))
;;"comlist.scm" Implementation of COMMON LISP list functions for Scheme ;;"comlist.scm" Implementation of COMMON LISP list functions for Scheme
; Copyright (C) 1991, 1993, 1995 Aubrey Jaffer. ; Copyright (C) 1991, 1993, 1995 Aubrey Jaffer.
@ -96,11 +100,11 @@
;promotional, or sales literature without prior written consent in ;promotional, or sales literature without prior written consent in
;each case. ;each case.
(define-public (adjoin e l) (define (adjoin e l)
"Return list L, possibly with element E added if it is not already in L." "Return list L, possibly with element E added if it is not already in L."
(if (memq e l) l (cons e l))) (if (memq e l) l (cons e l)))
(define-public (union l1 l2) (define (union l1 l2)
"Return a new list that is the union of L1 and L2. "Return a new list that is the union of L1 and L2.
Elements that occur in both lists occur only once in Elements that occur in both lists occur only once in
the result list." the result list."
@ -108,7 +112,7 @@ the result list."
((null? l2) l1) ((null? l2) l1)
(else (union (cdr l1) (adjoin (car l1) l2))))) (else (union (cdr l1) (adjoin (car l1) l2)))))
(define-public (intersection l1 l2) (define (intersection l1 l2)
"Return a new list that is the intersection of L1 and L2. "Return a new list that is the intersection of L1 and L2.
Only elements that occur in both lists occur in the result list." Only elements that occur in both lists occur in the result list."
(if (null? l2) l2 (if (null? l2) l2
@ -117,20 +121,20 @@ Only elements that occur in both lists occur in the result list."
((memv (car l1) l2) (loop (cdr l1) (cons (car l1) result))) ((memv (car l1) l2) (loop (cdr l1) (cons (car l1) result)))
(else (loop (cdr l1) result)))))) (else (loop (cdr l1) result))))))
(define-public (set-difference l1 l2) (define (set-difference l1 l2)
"Return elements from list L1 that are not in list L2." "Return elements from list L1 that are not in list L2."
(let loop ((l1 l1) (result '())) (let loop ((l1 l1) (result '()))
(cond ((null? l1) (reverse! result)) (cond ((null? l1) (reverse! result))
((memv (car l1) l2) (loop (cdr l1) result)) ((memv (car l1) l2) (loop (cdr l1) result))
(else (loop (cdr l1) (cons (car l1) result)))))) (else (loop (cdr l1) (cons (car l1) result))))))
(define-public (reduce-init p init l) (define (reduce-init p init l)
"Same as `reduce' except it implicitly inserts INIT at the start of L." "Same as `reduce' except it implicitly inserts INIT at the start of L."
(if (null? l) (if (null? l)
init init
(reduce-init p (p init (car l)) (cdr l)))) (reduce-init p (p init (car l)) (cdr l))))
(define-public (reduce p l) (define (reduce p l)
"Combine all the elements of sequence L using a binary operation P. "Combine all the elements of sequence L using a binary operation P.
The combination is left-associative. For example, using +, one can The combination is left-associative. For example, using +, one can
add up all the elements. `reduce' allows you to apply a function which add up all the elements. `reduce' allows you to apply a function which
@ -140,7 +144,7 @@ programmers usually refer to this as foldl."
((null? (cdr l)) (car l)) ((null? (cdr l)) (car l))
(else (reduce-init p (car l) (cdr l))))) (else (reduce-init p (car l) (cdr l)))))
(define-public (some pred l . rest) (define (some pred l . rest)
"PRED is a boolean function of as many arguments as there are list "PRED is a boolean function of as many arguments as there are list
arguments to `some', i.e., L plus any optional arguments. PRED is arguments to `some', i.e., L plus any optional arguments. PRED is
applied to successive elements of the list arguments in order. As soon applied to successive elements of the list arguments in order. As soon
@ -156,7 +160,7 @@ All the lists should have the same length."
(or (apply pred (car l) (map car rest)) (or (apply pred (car l) (map car rest))
(mapf (cdr l) (map cdr rest)))))))) (mapf (cdr l) (map cdr rest))))))))
(define-public (every pred l . rest) (define (every pred l . rest)
"Return #t iff every application of PRED to L, etc., returns #t. "Return #t iff every application of PRED to L, etc., returns #t.
Analogous to `some' except it returns #t if every application of Analogous to `some' except it returns #t if every application of
PRED is #t and #f otherwise." PRED is #t and #f otherwise."
@ -169,39 +173,39 @@ PRED is #t and #f otherwise."
(and (apply pred (car l) (map car rest)) (and (apply pred (car l) (map car rest))
(mapf (cdr l) (map cdr rest)))))))) (mapf (cdr l) (map cdr rest))))))))
(define-public (notany pred . ls) (define (notany pred . ls)
"Return #t iff every application of PRED to L, etc., returns #f. "Return #t iff every application of PRED to L, etc., returns #f.
Analogous to some but returns #t if no application of PRED returns a Analogous to some but returns #t if no application of PRED returns a
true value or #f as soon as any one does." true value or #f as soon as any one does."
(not (apply some pred ls))) (not (apply some pred ls)))
(define-public (notevery pred . ls) (define (notevery pred . ls)
"Return #t iff there is an application of PRED to L, etc., that returns #f. "Return #t iff there is an application of PRED to L, etc., that returns #f.
Analogous to some but returns #t as soon as an application of PRED returns #f, Analogous to some but returns #t as soon as an application of PRED returns #f,
or #f otherwise." or #f otherwise."
(not (apply every pred ls))) (not (apply every pred ls)))
(define-public (count-if pred l) (define (count-if pred l)
"Return the number of elements in L for which (PRED element) returns true." "Return the number of elements in L for which (PRED element) returns true."
(let loop ((n 0) (l l)) (let loop ((n 0) (l l))
(cond ((null? l) n) (cond ((null? l) n)
((pred (car l)) (loop (+ n 1) (cdr l))) ((pred (car l)) (loop (+ n 1) (cdr l)))
(else (loop n (cdr l)))))) (else (loop n (cdr l))))))
(define-public (find-if pred l) (define (find-if pred l)
"Search for the first element in L for which (PRED element) returns true. "Search for the first element in L for which (PRED element) returns true.
If found, return that element, otherwise return #f." If found, return that element, otherwise return #f."
(cond ((null? l) #f) (cond ((null? l) #f)
((pred (car l)) (car l)) ((pred (car l)) (car l))
(else (find-if pred (cdr l))))) (else (find-if pred (cdr l)))))
(define-public (member-if pred l) (define (member-if pred l)
"Return the first sublist of L for whose car PRED is true." "Return the first sublist of L for whose car PRED is true."
(cond ((null? l) #f) (cond ((null? l) #f)
((pred (car l)) l) ((pred (car l)) l)
(else (member-if pred (cdr l))))) (else (member-if pred (cdr l)))))
(define-public (remove-if pred l) (define (remove-if pred l)
"Remove all elements from L where (PRED element) is true. "Remove all elements from L where (PRED element) is true.
Return everything that's left." Return everything that's left."
(let loop ((l l) (result '())) (let loop ((l l) (result '()))
@ -209,7 +213,7 @@ Return everything that's left."
((pred (car l)) (loop (cdr l) result)) ((pred (car l)) (loop (cdr l) result))
(else (loop (cdr l) (cons (car l) result)))))) (else (loop (cdr l) (cons (car l) result))))))
(define-public (remove-if-not pred l) (define (remove-if-not pred l)
"Remove all elements from L where (PRED element) is #f. "Remove all elements from L where (PRED element) is #f.
Return everything that's left." Return everything that's left."
(let loop ((l l) (result '())) (let loop ((l l) (result '()))
@ -217,7 +221,7 @@ Return everything that's left."
((not (pred (car l))) (loop (cdr l) result)) ((not (pred (car l))) (loop (cdr l) result))
(else (loop (cdr l) (cons (car l) result)))))) (else (loop (cdr l) (cons (car l) result))))))
(define-public (delete-if! pred l) (define (delete-if! pred l)
"Destructive version of `remove-if'." "Destructive version of `remove-if'."
(let delete-if ((l l)) (let delete-if ((l l))
(cond ((null? l) '()) (cond ((null? l) '())
@ -226,7 +230,7 @@ Return everything that's left."
(set-cdr! l (delete-if (cdr l))) (set-cdr! l (delete-if (cdr l)))
l)))) l))))
(define-public (delete-if-not! pred l) (define (delete-if-not! pred l)
"Destructive version of `remove-if-not'." "Destructive version of `remove-if-not'."
(let delete-if-not ((l l)) (let delete-if-not ((l l))
(cond ((null? l) '()) (cond ((null? l) '())
@ -235,7 +239,7 @@ Return everything that's left."
(set-cdr! l (delete-if-not (cdr l))) (set-cdr! l (delete-if-not (cdr l)))
l)))) l))))
(define-public (butlast lst n) (define (butlast lst n)
"Return all but the last N elements of LST." "Return all but the last N elements of LST."
(letrec ((l (- (length lst) n)) (letrec ((l (- (length lst) n))
(bl (lambda (lst n) (bl (lambda (lst n)
@ -247,25 +251,25 @@ Return everything that's left."
(error "negative argument to butlast" n) (error "negative argument to butlast" n)
l)))) l))))
(define-public (and? . args) (define (and? . args)
"Return #t iff all of ARGS are true." "Return #t iff all of ARGS are true."
(cond ((null? args) #t) (cond ((null? args) #t)
((car args) (apply and? (cdr args))) ((car args) (apply and? (cdr args)))
(else #f))) (else #f)))
(define-public (or? . args) (define (or? . args)
"Return #t iff any of ARGS is true." "Return #t iff any of ARGS is true."
(cond ((null? args) #f) (cond ((null? args) #f)
((car args) #t) ((car args) #t)
(else (apply or? (cdr args))))) (else (apply or? (cdr args)))))
(define-public (has-duplicates? lst) (define (has-duplicates? lst)
"Return #t iff 2 members of LST are equal?, else #f." "Return #t iff 2 members of LST are equal?, else #f."
(cond ((null? lst) #f) (cond ((null? lst) #f)
((member (car lst) (cdr lst)) #t) ((member (car lst) (cdr lst)) #t)
(else (has-duplicates? (cdr lst))))) (else (has-duplicates? (cdr lst)))))
(define-public (pick p l) (define (pick p l)
"Apply P to each element of L, returning a list of elts "Apply P to each element of L, returning a list of elts
for which P returns a non-#f value." for which P returns a non-#f value."
(let loop ((s '()) (let loop ((s '())
@ -275,7 +279,7 @@ for which P returns a non-#f value."
((p (car l)) (loop (cons (car l) s) (cdr l))) ((p (car l)) (loop (cons (car l) s) (cdr l)))
(else (loop s (cdr l)))))) (else (loop s (cdr l))))))
(define-public (pick-mappings p l) (define (pick-mappings p l)
"Apply P to each element of L, returning a list of the "Apply P to each element of L, returning a list of the
non-#f return values of P." non-#f return values of P."
(let loop ((s '()) (let loop ((s '())
@ -285,7 +289,7 @@ non-#f return values of P."
((p (car l)) => (lambda (mapping) (loop (cons mapping s) (cdr l)))) ((p (car l)) => (lambda (mapping) (loop (cons mapping s) (cdr l))))
(else (loop s (cdr l)))))) (else (loop s (cdr l))))))
(define-public (uniq l) (define (uniq l)
"Return a list containing elements of L, with duplicates removed." "Return a list containing elements of L, with duplicates removed."
(let loop ((acc '()) (let loop ((acc '())
(l l)) (l l))

View file

@ -44,12 +44,13 @@
;;;; ;;;;
(define-module (ice-9 debug)) (define-module (ice-9 debug)
:export (frame-number->index trace untrace trace-stack untrace-stack))
;;; {Misc} ;;; {Misc}
;;; ;;;
(define-public (frame-number->index n . stack) (define (frame-number->index n . stack)
(let ((stack (if (null? stack) (let ((stack (if (null? stack)
(fluid-ref the-last-stack) (fluid-ref the-last-stack)
(car stack)))) (car stack))))
@ -66,7 +67,7 @@
;;; ;;;
(define traced-procedures '()) (define traced-procedures '())
(define-public (trace . args) (define (trace . args)
(if (null? args) (if (null? args)
(nameify traced-procedures) (nameify traced-procedures)
(begin (begin
@ -87,7 +88,7 @@
(debug-enable 'trace) (debug-enable 'trace)
(nameify args)))) (nameify args))))
(define-public (untrace . args) (define (untrace . args)
(if (and (null? args) (if (and (null? args)
(not (null? traced-procedures))) (not (null? traced-procedures)))
(apply untrace traced-procedures) (apply untrace traced-procedures)
@ -112,7 +113,7 @@
(define traced-stack-ids (list 'repl-stack)) (define traced-stack-ids (list 'repl-stack))
(define trace-all-stacks? #f) (define trace-all-stacks? #f)
(define-public (trace-stack id) (define (trace-stack id)
"Add ID to the set of stack ids for which tracing is active. "Add ID to the set of stack ids for which tracing is active.
If `#t' is in this set, tracing is active regardless of stack context. If `#t' is in this set, tracing is active regardless of stack context.
To remove ID again, use `untrace-stack'. If you add the same ID twice To remove ID again, use `untrace-stack'. If you add the same ID twice
@ -120,7 +121,7 @@ using `trace-stack', you will need to remove it twice."
(set! traced-stack-ids (cons id traced-stack-ids)) (set! traced-stack-ids (cons id traced-stack-ids))
(set! trace-all-stacks? (memq #t traced-stack-ids))) (set! trace-all-stacks? (memq #t traced-stack-ids)))
(define-public (untrace-stack id) (define (untrace-stack id)
"Remove ID from the set of stack ids for which tracing is active." "Remove ID from the set of stack ids for which tracing is active."
(set! traced-stack-ids (delq1! id traced-stack-ids)) (set! traced-stack-ids (delq1! id traced-stack-ids))
(set! trace-all-stacks? (memq #t traced-stack-ids))) (set! trace-all-stacks? (memq #t traced-stack-ids)))

View file

@ -44,6 +44,7 @@
(define-module (ice-9 debugger) (define-module (ice-9 debugger)
:use-module (ice-9 debug) :use-module (ice-9 debug)
:use-module (ice-9 format) :use-module (ice-9 format)
:export (debug)
:no-backtrace :no-backtrace
) )
@ -54,7 +55,7 @@
(define debugger-prompt "debug> ") (define debugger-prompt "debug> ")
(define-public (debug) (define (debug)
(let ((stack (fluid-ref the-last-stack))) (let ((stack (fluid-ref the-last-stack)))
(if stack (if stack
(let ((state (make-state stack 0))) (let ((state (make-state stack 0)))

View file

@ -53,22 +53,26 @@
;;; Code: ;;; Code:
(define-module (ice-9 expect) (define-module (ice-9 expect)
:use-module (ice-9 regex)) :use-module (ice-9 regex)
:export-syntax (expect expect-strings)
:export (expect-port expect-timeout expect-timeout-proc
expect-eof-proc expect-char-proc expect-strings-compile-flags
expect-strings-exec-flags expect-select expect-regexec))
;;; Expect: a macro for selecting actions based on what it reads from a port. ;;; Expect: a macro for selecting actions based on what it reads from a port.
;;; The idea is from Don Libes' expect based on Tcl. ;;; The idea is from Don Libes' expect based on Tcl.
;;; This version by Gary Houston incorporating ideas from Aubrey Jaffer. ;;; This version by Gary Houston incorporating ideas from Aubrey Jaffer.
(define-public expect-port #f) (define expect-port #f)
(define-public expect-timeout #f) (define expect-timeout #f)
(define-public expect-timeout-proc #f) (define expect-timeout-proc #f)
(define-public expect-eof-proc #f) (define expect-eof-proc #f)
(define-public expect-char-proc #f) (define expect-char-proc #f)
;;; expect: each test is a procedure which is applied to the accumulating ;;; expect: each test is a procedure which is applied to the accumulating
;;; string. ;;; string.
(defmacro-public expect clauses (defmacro expect clauses
(let ((s (gensym)) (let ((s (gensym))
(c (gensym)) (c (gensym))
(port (gensym)) (port (gensym))
@ -134,12 +138,12 @@
(next-char))))))))))) (next-char)))))))))))
(define-public expect-strings-compile-flags regexp/newline) (define expect-strings-compile-flags regexp/newline)
(define-public expect-strings-exec-flags regexp/noteol) (define expect-strings-exec-flags regexp/noteol)
;;; the regexec front-end to expect: ;;; the regexec front-end to expect:
;;; each test must evaluate to a regular expression. ;;; each test must evaluate to a regular expression.
(defmacro-public expect-strings clauses (defmacro expect-strings clauses
`(let ,@(let next-test ((tests (map car clauses)) `(let ,@(let next-test ((tests (map car clauses))
(exprs (map cdr clauses)) (exprs (map cdr clauses))
(defs '()) (defs '())
@ -162,7 +166,7 @@
;;; simplified select: returns #t if input is waiting or #f if timed out or ;;; simplified select: returns #t if input is waiting or #f if timed out or
;;; select was interrupted by a signal. ;;; select was interrupted by a signal.
;;; timeout is an absolute time in floating point seconds. ;;; timeout is an absolute time in floating point seconds.
(define-public (expect-select port timeout) (define (expect-select port timeout)
(let* ((secs-usecs (gettimeofday)) (let* ((secs-usecs (gettimeofday))
(relative (- timeout (relative (- timeout
(car secs-usecs) (car secs-usecs)
@ -175,7 +179,7 @@
;;; match a string against a regexp, returning a list of strings (required ;;; match a string against a regexp, returning a list of strings (required
;;; by the => syntax) or #f. called once each time a character is added ;;; by the => syntax) or #f. called once each time a character is added
;;; to s (eof? will be #f), and once when eof is reached (with eof? #t). ;;; to s (eof? will be #f), and once when eof is reached (with eof? #t).
(define-public (expect-regexec rx s eof?) (define (expect-regexec rx s eof?)
;; if expect-strings-exec-flags contains regexp/noteol, ;; if expect-strings-exec-flags contains regexp/noteol,
;; remove it for the eof test. ;; remove it for the eof test.
(let* ((flags (if (and eof? (let* ((flags (if (and eof?

View file

@ -1,6 +1,6 @@
;;; installed-scm-file ;;; installed-scm-file
;;;; Copyright (C) 1995, 1996, 1998 Free Software Foundation, Inc. ;;;; Copyright (C) 1995, 1996, 1998, 2001 Free Software Foundation, Inc.
;;;; ;;;;
;;;; This program is free software; you can redistribute it and/or modify ;;;; 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 ;;;; it under the terms of the GNU General Public License as published by
@ -43,7 +43,10 @@
;;;; ;;;;
(define-module (ice-9 hcons)) (define-module (ice-9 hcons)
:export (hashq-cons-hash hashq-cons-assoc hashq-cons-get-handle
hashq-cons-create-handle! hashq-cons-ref hashq-cons-set! hashq-cons
hashq-conser make-gc-buffer))
;;; {Eq? hash-consing} ;;; {Eq? hash-consing}
@ -54,12 +57,12 @@
;;; A hash conser does not contribute life to the pairs it returns. ;;; A hash conser does not contribute life to the pairs it returns.
;;; ;;;
(define-public (hashq-cons-hash pair n) (define (hashq-cons-hash pair n)
(modulo (logxor (hashq (car pair) 4194303) (modulo (logxor (hashq (car pair) 4194303)
(hashq (cdr pair) 4194303)) (hashq (cdr pair) 4194303))
n)) n))
(define-public (hashq-cons-assoc key l) (define (hashq-cons-assoc key l)
(and (not (null? l)) (and (not (null? l))
(or (and (pair? l) ; If not a pair, use its cdr? (or (and (pair? l) ; If not a pair, use its cdr?
(pair? (car l)) (pair? (car l))
@ -69,22 +72,22 @@
(car l)) (car l))
(hashq-cons-assoc key (cdr l))))) (hashq-cons-assoc key (cdr l)))))
(define-public (hashq-cons-get-handle table key) (define (hashq-cons-get-handle table key)
(hashx-get-handle hashq-cons-hash hashq-cons-assoc table key #f)) (hashx-get-handle hashq-cons-hash hashq-cons-assoc table key #f))
(define-public (hashq-cons-create-handle! table key init) (define (hashq-cons-create-handle! table key init)
(hashx-create-handle! hashq-cons-hash hashq-cons-assoc table key init)) (hashx-create-handle! hashq-cons-hash hashq-cons-assoc table key init))
(define-public (hashq-cons-ref table key) (define (hashq-cons-ref table key)
(hashx-ref hashq-cons-hash hashq-cons-assoc table key #f)) (hashx-ref hashq-cons-hash hashq-cons-assoc table key #f))
(define-public (hashq-cons-set! table key val) (define (hashq-cons-set! table key val)
(hashx-set! hashq-cons-hash hashq-cons-assoc table key val)) (hashx-set! hashq-cons-hash hashq-cons-assoc table key val))
(define-public (hashq-cons table a d) (define (hashq-cons table a d)
(car (hashq-cons-create-handle! table (cons a d) #f))) (car (hashq-cons-create-handle! table (cons a d) #f)))
(define-public (hashq-conser hash-tab-or-size) (define (hashq-conser hash-tab-or-size)
(let ((table (if (vector? hash-tab-or-size) (let ((table (if (vector? hash-tab-or-size)
hash-tab-or-size hash-tab-or-size
(make-doubly-weak-hash-table hash-tab-or-size)))) (make-doubly-weak-hash-table hash-tab-or-size))))
@ -93,7 +96,7 @@
(define-public (make-gc-buffer n) (define (make-gc-buffer n)
(let ((ring (make-list n #f))) (let ((ring (make-list n #f)))
(append! ring ring) (append! ring ring)
(lambda (next) (lambda (next)

View file

@ -45,7 +45,9 @@
(define-module (ice-9 lineio) (define-module (ice-9 lineio)
:use-module (ice-9 readline)) :use-module (ice-9 readline)
:export (unread-string read-string lineio-port?
make-line-buffering-input-port))
;;; {Line Buffering Input Ports} ;;; {Line Buffering Input Ports}
@ -77,15 +79,15 @@
;; 'unread-string and 'read-string properties, bound to hooks ;; 'unread-string and 'read-string properties, bound to hooks
;; implementing these functions. ;; implementing these functions.
;; ;;
(define-public (unread-string str line-buffering-input-port) (define (unread-string str line-buffering-input-port)
((object-property line-buffering-input-port 'unread-string) str)) ((object-property line-buffering-input-port 'unread-string) str))
;; ;;
(define-public (read-string line-buffering-input-port) (define (read-string line-buffering-input-port)
((object-property line-buffering-input-port 'read-string))) ((object-property line-buffering-input-port 'read-string)))
(define-public (lineio-port? port) (define (lineio-port? port)
(not (not (object-property port 'read-string)))) (not (not (object-property port 'read-string))))
;; make-line-buffering-input-port port ;; make-line-buffering-input-port port
@ -96,7 +98,7 @@
;; to read-char, read-string, and unread-string. ;; to read-char, read-string, and unread-string.
;; ;;
(define-public (make-line-buffering-input-port underlying-port) (define (make-line-buffering-input-port underlying-port)
(let* (;; buffers - a list of strings put back by unread-string or cached (let* (;; buffers - a list of strings put back by unread-string or cached
;; using read-line. ;; using read-line.
;; ;;

View file

@ -1,6 +1,6 @@
;;;; ls.scm --- functions for browsing modules ;;;; ls.scm --- functions for browsing modules
;;;; ;;;;
;;;; Copyright (C) 1995, 1996, 1997, 1999 Free Software Foundation, Inc. ;;;; Copyright (C) 1995, 1996, 1997, 1999, 2001 Free Software Foundation, Inc.
;;;; ;;;;
;;;; This program is free software; you can redistribute it and/or modify ;;;; 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 ;;;; it under the terms of the GNU General Public License as published by
@ -43,7 +43,9 @@
;;;; ;;;;
(define-module (ice-9 ls) (define-module (ice-9 ls)
:use-module (ice-9 common-list)) :use-module (ice-9 common-list)
:export (local-definitions-in definitions-in ls lls
recursive-local-define))
;;;; ;;;;
;;; local-definitions-in root name ;;; local-definitions-in root name
@ -76,7 +78,7 @@
;;; ;;;
;;; Analogous to `ls', but with local definitions only. ;;; Analogous to `ls', but with local definitions only.
(define-public (local-definitions-in root names) (define (local-definitions-in root names)
(let ((m (nested-ref root names)) (let ((m (nested-ref root names))
(answer '())) (answer '()))
(if (not (module? m)) (if (not (module? m))
@ -84,7 +86,7 @@
(module-for-each (lambda (k v) (set! answer (cons k answer))) m)) (module-for-each (lambda (k v) (set! answer (cons k answer))) m))
answer)) answer))
(define-public (definitions-in root names) (define (definitions-in root names)
(let ((m (nested-ref root names))) (let ((m (nested-ref root names)))
(if (not (module? m)) (if (not (module? m))
m m
@ -93,7 +95,7 @@
(map (lambda (m2) (definitions-in m2 '())) (map (lambda (m2) (definitions-in m2 '()))
(module-uses m))))))) (module-uses m)))))))
(define-public (ls . various-refs) (define (ls . various-refs)
(if (pair? various-refs) (if (pair? various-refs)
(if (cdr various-refs) (if (cdr various-refs)
(map (lambda (ref) (map (lambda (ref)
@ -102,7 +104,7 @@
(definitions-in (current-module) (car various-refs))) (definitions-in (current-module) (car various-refs)))
(definitions-in (current-module) '()))) (definitions-in (current-module) '())))
(define-public (lls . various-refs) (define (lls . various-refs)
(if (pair? various-refs) (if (pair? various-refs)
(if (cdr various-refs) (if (cdr various-refs)
(map (lambda (ref) (map (lambda (ref)
@ -111,7 +113,7 @@
(local-definitions-in (current-module) (car various-refs))) (local-definitions-in (current-module) (car various-refs)))
(local-definitions-in (current-module) '()))) (local-definitions-in (current-module) '())))
(define-public (recursive-local-define name value) (define (recursive-local-define name value)
(let ((parent (reverse! (cdr (reverse name))))) (let ((parent (reverse! (cdr (reverse name)))))
(and parent (make-modules-in (current-module) parent)) (and parent (make-modules-in (current-module) parent))
(local-define name value))) (local-define name value)))

View file

@ -1,6 +1,6 @@
;;; installed-scm-file ;;; installed-scm-file
;;;; Copyright (C) 1996 Free Software Foundation, Inc. ;;;; Copyright (C) 1996, 2001 Free Software Foundation, Inc.
;;;; ;;;;
;;;; This program is free software; you can redistribute it and/or modify ;;;; 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 ;;;; it under the terms of the GNU General Public License as published by
@ -45,46 +45,53 @@
(define-module (ice-9 mapping) (define-module (ice-9 mapping)
:use-module (ice-9 poe)) :use-module (ice-9 poe)
:export (mapping-hooks-type make-mapping-hooks mapping-hooks?
mapping-hooks-get-handle mapping-hooks-create-handle
mapping-hooks-remove mapping-type make-mapping mapping?
mapping-hooks mapping-data set-mapping-hooks! set-mapping-data!
mapping-get-handle mapping-create-handle! mapping-remove!
mapping-ref mapping-set! hash-table-mapping-hooks
make-hash-table-mapping hash-table-mapping))
(define-public mapping-hooks-type (make-record-type 'mapping-hooks '(get-handle (define mapping-hooks-type (make-record-type 'mapping-hooks '(get-handle
create-handle create-handle
remove))) remove)))
(define-public make-mapping-hooks (perfect-funcq 17 (record-constructor mapping-hooks-type))) (define make-mapping-hooks (perfect-funcq 17 (record-constructor mapping-hooks-type)))
(define-public mapping-hooks? (record-predicate mapping-hooks-type)) (define mapping-hooks? (record-predicate mapping-hooks-type))
(define-public mapping-hooks-get-handle (record-accessor mapping-hooks-type 'get-handle)) (define mapping-hooks-get-handle (record-accessor mapping-hooks-type 'get-handle))
(define-public mapping-hooks-create-handle (record-accessor mapping-hooks-type 'create-handle)) (define mapping-hooks-create-handle (record-accessor mapping-hooks-type 'create-handle))
(define-public mapping-hooks-remove (record-accessor mapping-hooks-type 'remove)) (define mapping-hooks-remove (record-accessor mapping-hooks-type 'remove))
(define-public mapping-type (make-record-type 'mapping '(hooks data))) (define mapping-type (make-record-type 'mapping '(hooks data)))
(define-public make-mapping (record-constructor mapping-type)) (define make-mapping (record-constructor mapping-type))
(define-public mapping? (record-predicate mapping-type)) (define mapping? (record-predicate mapping-type))
(define-public mapping-hooks (record-accessor mapping-type 'hooks)) (define mapping-hooks (record-accessor mapping-type 'hooks))
(define-public mapping-data (record-accessor mapping-type 'data)) (define mapping-data (record-accessor mapping-type 'data))
(define-public set-mapping-hooks! (record-modifier mapping-type 'hooks)) (define set-mapping-hooks! (record-modifier mapping-type 'hooks))
(define-public set-mapping-data! (record-modifier mapping-type 'data)) (define set-mapping-data! (record-modifier mapping-type 'data))
(define-public (mapping-get-handle map key) (define (mapping-get-handle map key)
((mapping-hooks-get-handle (mapping-hooks map)) map key)) ((mapping-hooks-get-handle (mapping-hooks map)) map key))
(define-public (mapping-create-handle! map key . opts) (define (mapping-create-handle! map key . opts)
(apply (mapping-hooks-create-handle (mapping-hooks map)) map key opts)) (apply (mapping-hooks-create-handle (mapping-hooks map)) map key opts))
(define-public (mapping-remove! map key) (define (mapping-remove! map key)
((mapping-hooks-remove (mapping-hooks map)) map key)) ((mapping-hooks-remove (mapping-hooks map)) map key))
(define-public (mapping-ref map key . dflt) (define (mapping-ref map key . dflt)
(cond (cond
((mapping-get-handle map key) => cdr) ((mapping-get-handle map key) => cdr)
(dflt => car) (dflt => car)
(else #f))) (else #f)))
(define-public (mapping-set! map key val) (define (mapping-set! map key val)
(set-cdr! (mapping-create-handle! map key #f) val)) (set-cdr! (mapping-create-handle! map key #f) val))
(define-public hash-table-mapping-hooks (define hash-table-mapping-hooks
(let ((wrap (lambda (proc) (lambda (1st . rest) (apply proc (mapping-data 1st) rest))))) (let ((wrap (lambda (proc) (lambda (1st . rest) (apply proc (mapping-data 1st) rest)))))
(perfect-funcq 17 (perfect-funcq 17
@ -114,10 +121,10 @@
(lambda (table key) (lambda (table key)
(hashx-get-handle hash-proc assoc-proc delete-proc table key))))))))))) (hashx-get-handle hash-proc assoc-proc delete-proc table key)))))))))))
(define-public (make-hash-table-mapping table hash-proc assoc-proc delete-proc) (define (make-hash-table-mapping table hash-proc assoc-proc delete-proc)
(make-mapping (hash-table-mapping-hooks hash-proc assoc-proc delete-proc) table)) (make-mapping (hash-table-mapping-hooks hash-proc assoc-proc delete-proc) table))
(define-public (hash-table-mapping . options) (define (hash-table-mapping . options)
(let* ((size (or (and options (number? (car options)) (car options)) (let* ((size (or (and options (number? (car options)) (car options))
71)) 71))
(hash-proc (or (kw-arg-ref options :hash-proc) hash)) (hash-proc (or (kw-arg-ref options :hash-proc) hash))

View file

@ -43,9 +43,8 @@
;;;; The null environment - only syntactic bindings ;;;; The null environment - only syntactic bindings
(define-module (ice-9 null) (define-module (ice-9 null)
:use-module (ice-9 syncase)) :use-module (ice-9 syncase)
:re-export-syntax (define quote lambda if set!
(re-export define quote lambda if set!
cond case and or cond case and or
@ -58,4 +57,4 @@
quasiquote quasiquote
define-syntax define-syntax
let-syntax letrec-syntax) let-syntax letrec-syntax))

View file

@ -82,7 +82,15 @@
;;; Code: ;;; Code:
(define-module (ice-9 optargs)) (define-module (ice-9 optargs)
:export-syntax (let-optional
let-optional*
let-keywords
let-keywords*
define* lambda*
define*-public
defmacro*
defmacro*-public))
;; let-optional rest-arg (binding ...) . body ;; let-optional rest-arg (binding ...) . body
;; let-optional* rest-arg (binding ...) . body ;; let-optional* rest-arg (binding ...) . body
@ -100,10 +108,10 @@
;; bound to whatever may have been left of rest-arg. ;; bound to whatever may have been left of rest-arg.
;; ;;
(defmacro-public let-optional (REST-ARG BINDINGS . BODY) (defmacro let-optional (REST-ARG BINDINGS . BODY)
(let-optional-template REST-ARG BINDINGS BODY 'let)) (let-optional-template REST-ARG BINDINGS BODY 'let))
(defmacro-public let-optional* (REST-ARG BINDINGS . BODY) (defmacro let-optional* (REST-ARG BINDINGS . BODY)
(let-optional-template REST-ARG BINDINGS BODY 'let*)) (let-optional-template REST-ARG BINDINGS BODY 'let*))
@ -123,10 +131,10 @@
;; ;;
(defmacro-public let-keywords (REST-ARG ALLOW-OTHER-KEYS? BINDINGS . BODY) (defmacro let-keywords (REST-ARG ALLOW-OTHER-KEYS? BINDINGS . BODY)
(let-keywords-template REST-ARG ALLOW-OTHER-KEYS? BINDINGS BODY 'let)) (let-keywords-template REST-ARG ALLOW-OTHER-KEYS? BINDINGS BODY 'let))
(defmacro-public let-keywords* (REST-ARG ALLOW-OTHER-KEYS? BINDINGS . BODY) (defmacro let-keywords* (REST-ARG ALLOW-OTHER-KEYS? BINDINGS . BODY)
(let-keywords-template REST-ARG ALLOW-OTHER-KEYS? BINDINGS BODY 'let*)) (let-keywords-template REST-ARG ALLOW-OTHER-KEYS? BINDINGS BODY 'let*))
@ -248,7 +256,7 @@
;; Lisp dialects. ;; Lisp dialects.
(defmacro-public lambda* (ARGLIST . BODY) (defmacro lambda* (ARGLIST . BODY)
(parse-arglist (parse-arglist
ARGLIST ARGLIST
(lambda (non-optional-args optionals keys aok? rest-arg) (lambda (non-optional-args optionals keys aok? rest-arg)
@ -387,10 +395,10 @@
;; Of course, define*[-public] also supports #:rest and #:allow-other-keys ;; Of course, define*[-public] also supports #:rest and #:allow-other-keys
;; in the same way as lambda*. ;; in the same way as lambda*.
(defmacro-public define* (ARGLIST . BODY) (defmacro define* (ARGLIST . BODY)
(define*-guts 'define ARGLIST BODY)) (define*-guts 'define ARGLIST BODY))
(defmacro-public define*-public (ARGLIST . BODY) (defmacro define*-public (ARGLIST . BODY)
(define*-guts 'define-public ARGLIST BODY)) (define*-guts 'define-public ARGLIST BODY))
;; The guts of define* and define*-public. ;; The guts of define* and define*-public.
@ -421,10 +429,10 @@
;; semantics. Here is an example of a macro with an optional argument: ;; semantics. Here is an example of a macro with an optional argument:
;; (defmacro* transmorgify (a #:optional b) ;; (defmacro* transmorgify (a #:optional b)
(defmacro-public defmacro* (NAME ARGLIST . BODY) (defmacro defmacro* (NAME ARGLIST . BODY)
(defmacro*-guts 'define NAME ARGLIST BODY)) (defmacro*-guts 'define NAME ARGLIST BODY))
(defmacro-public defmacro*-public (NAME ARGLIST . BODY) (defmacro defmacro*-public (NAME ARGLIST . BODY)
(defmacro*-guts 'define-public NAME ARGLIST BODY)) (defmacro*-guts 'define-public NAME ARGLIST BODY))
;; The guts of defmacro* and defmacro*-public ;; The guts of defmacro* and defmacro*-public

View file

@ -1,6 +1,6 @@
;;; installed-scm-file ;;; installed-scm-file
;;;; Copyright (C) 1996 Free Software Foundation, Inc. ;;;; Copyright (C) 1996, 2001 Free Software Foundation, Inc.
;;;; ;;;;
;;;; This program is free software; you can redistribute it and/or modify ;;;; 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 ;;;; it under the terms of the GNU General Public License as published by
@ -44,7 +44,8 @@
(define-module (ice-9 poe) (define-module (ice-9 poe)
:use-module (ice-9 hcons)) :use-module (ice-9 hcons)
:export (pure-funcq perfect-funcq))
@ -95,7 +96,7 @@
(define-public (pure-funcq base-func) (define (pure-funcq base-func)
(lambda args (lambda args
(let ((cached (hashx-get-handle funcq-hash funcq-assoc funcq-memo (cons base-func args)))) (let ((cached (hashx-get-handle funcq-hash funcq-assoc funcq-memo (cons base-func args))))
(if cached (if cached
@ -117,7 +118,7 @@
;;; funcq never does. ;;; funcq never does.
;;; ;;;
(define-public (perfect-funcq size base-func) (define (perfect-funcq size base-func)
(define funcq-memo (make-hash-table size)) (define funcq-memo (make-hash-table size))
(lambda args (lambda args

View file

@ -1,6 +1,6 @@
;; popen emulation, for non-stdio based ports. ;; popen emulation, for non-stdio based ports.
;;;; Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc. ;;;; Copyright (C) 1998, 1999, 2000, 2001 Free Software Foundation, Inc.
;;;; ;;;;
;;;; This program is free software; you can redistribute it and/or modify ;;;; 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 ;;;; it under the terms of the GNU General Public License as published by
@ -42,7 +42,9 @@
;;;; If you do not wish that, delete this exception notice. ;;;; If you do not wish that, delete this exception notice.
;;;; ;;;;
(define-module (ice-9 popen)) (define-module (ice-9 popen)
:export (port/pid-table open-pipe close-pipe open-input-pipe
open-output-pipe))
;; (define-module (guile popen) ;; (define-module (guile popen)
;; :use-module (guile posix)) ;; :use-module (guile posix))
@ -52,7 +54,7 @@
(define pipe-guardian (make-guardian)) (define pipe-guardian (make-guardian))
;; a weak hash-table to store the process ids. ;; a weak hash-table to store the process ids.
(define-public port/pid-table (make-weak-key-hash-table 31)) (define port/pid-table (make-weak-key-hash-table 31))
(define (ensure-fdes port mode) (define (ensure-fdes port mode)
(or (false-if-exception (fileno port)) (or (false-if-exception (fileno port))
@ -134,7 +136,7 @@
(cdr p)) (cdr p))
pid)))))) pid))))))
(define-public (open-pipe command mode) (define (open-pipe command mode)
"Executes the shell command @var{command} (a string) in a subprocess. "Executes the shell command @var{command} (a string) in a subprocess.
A pipe to the process is created and returned. @var{modes} specifies A pipe to the process is created and returned. @var{modes} specifies
whether an input or output pipe to the process is created: it should whether an input or output pipe to the process is created: it should
@ -173,7 +175,7 @@ be the value of @code{OPEN_READ} or @code{OPEN_WRITE}."
(car port/pid) (cdr port/pid)))))) (car port/pid) (cdr port/pid))))))
(lambda args #f))) (lambda args #f)))
(define-public (close-pipe p) (define (close-pipe p)
"Closes the pipe created by @code{open-pipe}, then waits for the process "Closes the pipe created by @code{open-pipe}, then waits for the process
to terminate and returns its status value, @xref{Processes, waitpid}, for to terminate and returns its status value, @xref{Processes, waitpid}, for
information on how to interpret this value." information on how to interpret this value."
@ -194,10 +196,10 @@ information on how to interpret this value."
(add-hook! after-gc-hook reap-pipes) (add-hook! after-gc-hook reap-pipes)
(define-public (open-input-pipe command) (define (open-input-pipe command)
"Equivalent to @code{open-pipe} with mode @code{OPEN_READ}" "Equivalent to @code{open-pipe} with mode @code{OPEN_READ}"
(open-pipe command OPEN_READ)) (open-pipe command OPEN_READ))
(define-public (open-output-pipe command) (define (open-output-pipe command)
"Equivalent to @code{open-pipe} with mode @code{OPEN_WRITE}" "Equivalent to @code{open-pipe} with mode @code{OPEN_WRITE}"
(open-pipe command OPEN_WRITE)) (open-pipe command OPEN_WRITE))

View file

@ -41,9 +41,8 @@
;;;; whether to permit this exception to apply to your modifications. ;;;; whether to permit this exception to apply to your modifications.
;;;; If you do not wish that, delete this exception notice. ;;;; If you do not wish that, delete this exception notice.
;;;; ;;;;
(define-module (ice-9 pretty-print)) (define-module (ice-9 pretty-print)
:export (pretty-print))
(export pretty-print)
;; From SLIB. ;; From SLIB.

View file

@ -81,7 +81,9 @@
;;; Code: ;;; Code:
(define-module (ice-9 q)) (define-module (ice-9 q)
:export (sync-q! make-q q? q-empty? q-empty-check q-front q-rear
q-remove! q-push! enq! q-pop! deq! q-length))
;;; sync-q! ;;; sync-q!
;;; The procedure ;;; The procedure
@ -90,7 +92,7 @@
;;; ;;;
;;; recomputes and resets the <last-pair> component of a queue. ;;; recomputes and resets the <last-pair> component of a queue.
;;; ;;;
(define-public (sync-q! q) (define (sync-q! q)
(set-cdr! q (if (pair? (car q)) (last-pair (car q)) (set-cdr! q (if (pair? (car q)) (last-pair (car q))
#f)) #f))
q) q)
@ -98,7 +100,7 @@
;;; make-q ;;; make-q
;;; return a new q. ;;; return a new q.
;;; ;;;
(define-public (make-q) (cons '() #f)) (define (make-q) (cons '() #f))
;;; q? obj ;;; q? obj
;;; Return true if obj is a Q. ;;; Return true if obj is a Q.
@ -106,7 +108,7 @@
;;; or it is a pair P with (list? (car P)) ;;; or it is a pair P with (list? (car P))
;;; and (eq? (cdr P) (last-pair (car P))). ;;; and (eq? (cdr P) (last-pair (car P))).
;;; ;;;
(define-public (q? obj) (define (q? obj)
(and (pair? obj) (and (pair? obj)
(if (pair? (car obj)) (if (pair? (car obj))
(eq? (cdr obj) (last-pair (car obj))) (eq? (cdr obj) (last-pair (car obj)))
@ -115,29 +117,29 @@
;;; q-empty? obj ;;; q-empty? obj
;;; ;;;
(define-public (q-empty? obj) (null? (car obj))) (define (q-empty? obj) (null? (car obj)))
;;; q-empty-check q ;;; q-empty-check q
;;; Throw a q-empty exception if Q is empty. ;;; Throw a q-empty exception if Q is empty.
(define-public (q-empty-check q) (if (q-empty? q) (throw 'q-empty q))) (define (q-empty-check q) (if (q-empty? q) (throw 'q-empty q)))
;;; q-front q ;;; q-front q
;;; Return the first element of Q. ;;; Return the first element of Q.
(define-public (q-front q) (q-empty-check q) (caar q)) (define (q-front q) (q-empty-check q) (caar q))
;;; q-rear q ;;; q-rear q
;;; Return the last element of Q. ;;; Return the last element of Q.
(define-public (q-rear q) (q-empty-check q) (cadr q)) (define (q-rear q) (q-empty-check q) (cadr q))
;;; q-remove! q obj ;;; q-remove! q obj
;;; Remove all occurences of obj from Q. ;;; Remove all occurences of obj from Q.
(define-public (q-remove! q obj) (define (q-remove! q obj)
(set-car! q (delq! obj (car q))) (set-car! q (delq! obj (car q)))
(sync-q! q)) (sync-q! q))
;;; q-push! q obj ;;; q-push! q obj
;;; Add obj to the front of Q ;;; Add obj to the front of Q
(define-public (q-push! q obj) (define (q-push! q obj)
(let ((h (cons obj (car q)))) (let ((h (cons obj (car q))))
(set-car! q h) (set-car! q h)
(or (cdr q) (set-cdr! q h))) (or (cdr q) (set-cdr! q h)))
@ -145,7 +147,7 @@
;;; enq! q obj ;;; enq! q obj
;;; Add obj to the rear of Q ;;; Add obj to the rear of Q
(define-public (enq! q obj) (define (enq! q obj)
(let ((h (cons obj '()))) (let ((h (cons obj '())))
(if (null? (car q)) (if (null? (car q))
(set-car! q h) (set-car! q h)
@ -155,7 +157,7 @@
;;; q-pop! q ;;; q-pop! q
;;; Take the front of Q and return it. ;;; Take the front of Q and return it.
(define-public (q-pop! q) (define (q-pop! q)
(q-empty-check q) (q-empty-check q)
(let ((it (caar q)) (let ((it (caar q))
(next (cdar q))) (next (cdar q)))
@ -166,11 +168,11 @@
;;; deq! q ;;; deq! q
;;; Take the front of Q and return it. ;;; Take the front of Q and return it.
(define-public deq! q-pop!) (define deq! q-pop!)
;;; q-length q ;;; q-length q
;;; Return the number of enqueued elements. ;;; Return the number of enqueued elements.
;;; ;;;
(define-public (q-length q) (length (car q))) (define (q-length q) (length (car q)))
;;; q.scm ends here ;;; q.scm ends here

View file

@ -42,24 +42,21 @@
;;;; R5RS bindings ;;;; R5RS bindings
(define-module (ice-9 r5rs)) (define-module (ice-9 r5rs)
:export (scheme-report-environment
(module-use! %module-public-interface (resolve-interface '(ice-9 safe-r5rs)))
(export scheme-report-environment
;;transcript-on ;;transcript-on
;;transcript-off ;;transcript-off
) )
:re-export (interaction-environment
(re-export interaction-environment
call-with-input-file call-with-output-file call-with-input-file call-with-output-file
with-input-from-file with-output-to-file with-input-from-file with-output-to-file
open-input-file open-output-file open-input-file open-output-file
close-input-port close-output-port close-input-port close-output-port
load load))
)
(module-use! %module-public-interface (resolve-interface '(ice-9 safe-r5rs)))
(define scheme-report-interface %module-public-interface) (define scheme-report-interface %module-public-interface)

View file

@ -46,13 +46,13 @@
;;; This is the Scheme part of the module for delimited I/O. It's ;;; This is the Scheme part of the module for delimited I/O. It's
;;; similar to (scsh rdelim) but somewhat incompatible. ;;; similar to (scsh rdelim) but somewhat incompatible.
(define-module (ice-9 rdelim)) (define-module (ice-9 rdelim)
:export (read-line read-line! read-delimited read-delimited!
%read-delimited! %read-line write-line) ; C
)
(%init-rdelim-builtins) (%init-rdelim-builtins)
(export read-line read-line! read-delimited read-delimited!)
(export %read-delimited! %read-line write-line) ; C
(define (read-line! string . maybe-port) (define (read-line! string . maybe-port)
;; corresponds to SCM_LINE_INCREMENTORS in libguile. ;; corresponds to SCM_LINE_INCREMENTORS in libguile.
(define scm-line-incrementors "\n") (define scm-line-incrementors "\n")

View file

@ -1,4 +1,4 @@
;;;; Copyright (C) 1997, 1999 Free Software Foundation, Inc. ;;;; Copyright (C) 1997, 1999, 2001 Free Software Foundation, Inc.
;;;; ;;;;
;;;; This program is free software; you can redistribute it and/or modify ;;;; 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 ;;;; it under the terms of the GNU General Public License as published by
@ -42,7 +42,11 @@
;;;; POSIX regex support functions. ;;;; POSIX regex support functions.
(define-module (ice-9 regex)) (define-module (ice-9 regex)
:export (match:count match:string match:prefix match:suffix
regexp-match? regexp-quote match:start match:end match:substring
string-match regexp-substitute fold-matches list-matches
regexp-substitute/global))
;;; FIXME: ;;; FIXME:
;;; It is not clear what should happen if a `match' function ;;; It is not clear what should happen if a `match' function
@ -53,22 +57,22 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; These procedures are not defined in SCSH, but I found them useful. ;;;; These procedures are not defined in SCSH, but I found them useful.
(define-public (match:count match) (define (match:count match)
(- (vector-length match) 1)) (- (vector-length match) 1))
(define-public (match:string match) (define (match:string match)
(vector-ref match 0)) (vector-ref match 0))
(define-public (match:prefix match) (define (match:prefix match)
(substring (match:string match) 0 (match:start match 0))) (substring (match:string match) 0 (match:start match 0)))
(define-public (match:suffix match) (define (match:suffix match)
(substring (match:string match) (match:end match 0))) (substring (match:string match) (match:end match 0)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; SCSH compatibility routines. ;;;; SCSH compatibility routines.
(define-public (regexp-match? match) (define (regexp-match? match)
(and (vector? match) (and (vector? match)
(string? (vector-ref match 0)) (string? (vector-ref match 0))
(let loop ((i 1)) (let loop ((i 1))
@ -79,7 +83,7 @@
(loop (+ 1 i))) (loop (+ 1 i)))
(else #f))))) (else #f)))))
(define-public (regexp-quote regexp) (define (regexp-quote regexp)
(call-with-output-string (call-with-output-string
(lambda (p) (lambda (p)
(let loop ((i 0)) (let loop ((i 0))
@ -91,21 +95,21 @@
(write-char (string-ref regexp i) p) (write-char (string-ref regexp i) p)
(loop (1+ i)))))))) (loop (1+ i))))))))
(define-public (match:start match . args) (define (match:start match . args)
(let* ((matchnum (if (pair? args) (let* ((matchnum (if (pair? args)
(+ 1 (car args)) (+ 1 (car args))
1)) 1))
(start (car (vector-ref match matchnum)))) (start (car (vector-ref match matchnum))))
(if (= start -1) #f start))) (if (= start -1) #f start)))
(define-public (match:end match . args) (define (match:end match . args)
(let* ((matchnum (if (pair? args) (let* ((matchnum (if (pair? args)
(+ 1 (car args)) (+ 1 (car args))
1)) 1))
(end (cdr (vector-ref match matchnum)))) (end (cdr (vector-ref match matchnum))))
(if (= end -1) #f end))) (if (= end -1) #f end)))
(define-public (match:substring match . args) (define (match:substring match . args)
(let* ((matchnum (if (pair? args) (let* ((matchnum (if (pair? args)
(car args) (car args)
0)) 0))
@ -113,12 +117,12 @@
(end (match:end match matchnum))) (end (match:end match matchnum)))
(and start end (substring (match:string match) start end)))) (and start end (substring (match:string match) start end))))
(define-public (string-match pattern str . args) (define (string-match pattern str . args)
(let ((rx (make-regexp pattern)) (let ((rx (make-regexp pattern))
(start (if (pair? args) (car args) 0))) (start (if (pair? args) (car args) 0)))
(regexp-exec rx str start))) (regexp-exec rx str start)))
(define-public (regexp-substitute port match . items) (define (regexp-substitute port match . items)
;; If `port' is #f, send output to a string. ;; If `port' is #f, send output to a string.
(if (not port) (if (not port)
(call-with-output-string (call-with-output-string
@ -153,7 +157,7 @@
;;; `b'. Around or within `xxx', only the match covering all three ;;; `b'. Around or within `xxx', only the match covering all three
;;; x's counts, because the rest are not maximal. ;;; x's counts, because the rest are not maximal.
(define-public (fold-matches regexp string init proc . flags) (define (fold-matches regexp string init proc . flags)
(let ((regexp (if (regexp? regexp) regexp (make-regexp regexp))) (let ((regexp (if (regexp? regexp) regexp (make-regexp regexp)))
(flags (if (null? flags) 0 flags))) (flags (if (null? flags) 0 flags)))
(let loop ((start 0) (let loop ((start 0)
@ -171,10 +175,10 @@
(else (else
(loop (match:end m) (proc m value) #t))))))) (loop (match:end m) (proc m value) #t)))))))
(define-public (list-matches regexp string . flags) (define (list-matches regexp string . flags)
(reverse! (apply fold-matches regexp string '() cons flags))) (reverse! (apply fold-matches regexp string '() cons flags)))
(define-public (regexp-substitute/global port regexp string . items) (define (regexp-substitute/global port regexp string . items)
;; If `port' is #f, send output to a string. ;; If `port' is #f, send output to a string.
(if (not port) (if (not port)

View file

@ -72,7 +72,10 @@
;;; Code: ;;; Code:
(define-module (ice-9 runq) (define-module (ice-9 runq)
:use-module (ice-9 q)) :use-module (ice-9 q)
:export (runq-control make-void-runq make-fair-runq
make-exclusive-runq make-subordinate-runq-to strip-sequence
fair-strip-subtask))
;;;; ;;;;
;;; (runq-control q msg . args) ;;; (runq-control q msg . args)
@ -91,7 +94,7 @@
;;; 'kill! ;; empty the queue ;;; 'kill! ;; empty the queue
;;; else ;; throw 'not-understood ;;; else ;; throw 'not-understood
;;; ;;;
(define-public (runq-control q msg . args) (define (runq-control q msg . args)
(case msg (case msg
((add!) (for-each (lambda (t) (enq! q t)) args) '*unspecified*) ((add!) (for-each (lambda (t) (enq! q t)) args) '*unspecified*)
((enqueue!) (for-each (lambda (t) (enq! q t)) args) '*unspecified*) ((enqueue!) (for-each (lambda (t) (enq! q t)) args) '*unspecified*)
@ -109,7 +112,7 @@
;;; Make a runq that discards all messages except "length", for which ;;; Make a runq that discards all messages except "length", for which
;;; it returns 0. ;;; it returns 0.
;;; ;;;
(define-public (make-void-runq) (define (make-void-runq)
(lambda opts (lambda opts
(and opts (and opts
(apply-to-args opts (apply-to-args opts
@ -129,7 +132,7 @@
;;; to the end of the queue, meaning it will be the last to execute ;;; to the end of the queue, meaning it will be the last to execute
;;; of all the remaining procedures. ;;; of all the remaining procedures.
;;; ;;;
(define-public (make-fair-runq) (define (make-fair-runq)
(letrec ((q (make-q)) (letrec ((q (make-q))
(self (self
(lambda ctl (lambda ctl
@ -165,7 +168,7 @@
;;; of that (if the CDR is not nil). This way, the rest of the thunks ;;; of that (if the CDR is not nil). This way, the rest of the thunks
;;; in the list that contained W have priority over the return value of W. ;;; in the list that contained W have priority over the return value of W.
;;; ;;;
(define-public (make-exclusive-runq) (define (make-exclusive-runq)
(letrec ((q (make-q)) (letrec ((q (make-q))
(self (self
(lambda ctl (lambda ctl
@ -197,7 +200,7 @@
;;; N is the length of the basic-inferior queue when the proxy ;;; N is the length of the basic-inferior queue when the proxy
;;; strip is entered. [Countless scheduling variations are possible.] ;;; strip is entered. [Countless scheduling variations are possible.]
;;; ;;;
(define-public (make-subordinate-runq-to superior-runq basic-runq) (define (make-subordinate-runq-to superior-runq basic-runq)
(let ((runq-task (cons #f #f))) (let ((runq-task (cons #f #f)))
(set-car! runq-task (set-car! runq-task
(lambda () (lambda ()
@ -238,7 +241,7 @@
;;; ;;;
;;; Returns a new strip which is the concatenation of the argument strips. ;;; Returns a new strip which is the concatenation of the argument strips.
;;; ;;;
(define-public ((strip-sequence . strips)) (define ((strip-sequence . strips))
(let loop ((st (let ((a strips)) (set! strips #f) a))) (let loop ((st (let ((a strips)) (set! strips #f) a)))
(and (not (null? st)) (and (not (null? st))
(let ((then ((car st)))) (let ((then ((car st))))
@ -255,7 +258,7 @@
;;; ;;;
;;; ;;;
;;; ;;;
(define-public (fair-strip-subtask . initial-strips) (define (fair-strip-subtask . initial-strips)
(let ((st (make-fair-runq))) (let ((st (make-fair-runq)))
(apply st 'add! initial-strips) (apply st 'add! initial-strips)
st)) st))

View file

@ -42,13 +42,8 @@
;;;; Safe subset of R5RS bindings ;;;; Safe subset of R5RS bindings
(define-module (ice-9 safe-r5rs)) (define-module (ice-9 safe-r5rs)
:re-export (eqv? eq? equal?
(define null-interface (resolve-interface '(ice-9 null)))
(module-use! %module-public-interface null-interface)
(re-export eqv? eq? equal?
number? complex? real? rational? integer? number? complex? real? rational? integer?
exact? inexact? exact? inexact?
= < > <= >= = < > <= >=
@ -155,7 +150,11 @@
;;transcript-off ;;transcript-off
) )
(export null-environment) :export (null-environment))
(define null-interface (resolve-interface '(ice-9 null)))
(module-use! %module-public-interface null-interface)
(define (null-environment n) (define (null-environment n)
(if (not (= n 5)) (if (not (= n 5))

View file

@ -1,4 +1,4 @@
;;;; Copyright (C) 2000 Free Software Foundation, Inc. ;;;; Copyright (C) 2000, 2001 Free Software Foundation, Inc.
;;;; ;;;;
;;;; This program is free software; you can redistribute it and/or modify ;;;; 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 ;;;; it under the terms of the GNU General Public License as published by
@ -42,11 +42,12 @@
;;;; Safe subset of R5RS bindings ;;;; Safe subset of R5RS bindings
(define-module (ice-9 safe)) (define-module (ice-9 safe)
:export (safe-environment make-safe-module))
(define safe-r5rs-interface (resolve-interface '(ice-9 safe-r5rs))) (define safe-r5rs-interface (resolve-interface '(ice-9 safe-r5rs)))
(define-public (safe-environment n) (define (safe-environment n)
(if (not (= n 5)) (if (not (= n 5))
(scm-error 'misc-error 'safe-environment (scm-error 'misc-error 'safe-environment
"~A is not a valid version" "~A is not a valid version"
@ -54,5 +55,5 @@
'())) '()))
safe-r5rs-interface) safe-r5rs-interface)
(define-public (make-safe-module) (define (make-safe-module)
(make-module 1021 (list safe-r5rs-interface))) (make-module 1021 (list safe-r5rs-interface)))

View file

@ -44,13 +44,16 @@
(define-module (ice-9 session) (define-module (ice-9 session)
:use-module (ice-9 documentation) :use-module (ice-9 documentation)
:use-module (ice-9 regex) :use-module (ice-9 regex)
:use-module (ice-9 rdelim)) :use-module (ice-9 rdelim)
:export (help apropos apropos-internal apropos-fold
apropos-fold-accessible apropos-fold-exported apropos-fold-all
source arity system-module))
;;; Documentation ;;; Documentation
;;; ;;;
(define-public help (define help
(procedure->syntax (procedure->syntax
(lambda (exp env) (lambda (exp env)
"(help [NAME]) "(help [NAME])
@ -255,7 +258,7 @@ where OPTIONSET is one of debug, read, eval, print
;;; Author: Roland Orre <orre@nada.kth.se> ;;; Author: Roland Orre <orre@nada.kth.se>
;;; ;;;
(define-public (apropos rgx . options) (define (apropos rgx . options)
"Search for bindings: apropos regexp {options= 'full 'shadow 'value}" "Search for bindings: apropos regexp {options= 'full 'shadow 'value}"
(if (zero? (string-length rgx)) (if (zero? (string-length rgx))
"Empty string not allowed" "Empty string not allowed"
@ -300,7 +303,7 @@ where OPTIONSET is one of debug, read, eval, print
obarray))) obarray)))
modules)))) modules))))
(define-public (apropos-internal rgx) (define (apropos-internal rgx)
"Return a list of accessible variable names." "Return a list of accessible variable names."
(apropos-fold (lambda (module name var data) (apropos-fold (lambda (module name var data)
(cons name data)) (cons name data))
@ -308,7 +311,7 @@ where OPTIONSET is one of debug, read, eval, print
rgx rgx
(apropos-fold-accessible (current-module)))) (apropos-fold-accessible (current-module))))
(define-public (apropos-fold proc init rgx folder) (define (apropos-fold proc init rgx folder)
"Folds PROCEDURE over bindings matching third arg REGEXP. "Folds PROCEDURE over bindings matching third arg REGEXP.
Result is Result is
@ -369,7 +372,7 @@ It is an image under the mapping EXTRACT."
data))) data)))
((null? modules) data)))))) ((null? modules) data))))))
(define-public (apropos-fold-accessible module) (define (apropos-fold-accessible module)
(make-fold-modules (lambda () (list module)) (make-fold-modules (lambda () (list module))
module-uses module-uses
identity)) identity))
@ -388,18 +391,18 @@ It is an image under the mapping EXTRACT."
'() '()
(module-obarray m))) (module-obarray m)))
(define-public apropos-fold-exported (define apropos-fold-exported
(make-fold-modules root-modules submodules module-public-interface)) (make-fold-modules root-modules submodules module-public-interface))
(define-public apropos-fold-all (define apropos-fold-all
(make-fold-modules root-modules submodules identity)) (make-fold-modules root-modules submodules identity))
(define-public (source obj) (define (source obj)
(cond ((procedure? obj) (procedure-source obj)) (cond ((procedure? obj) (procedure-source obj))
((macro? obj) (procedure-source (macro-transformer obj))) ((macro? obj) (procedure-source (macro-transformer obj)))
(else #f))) (else #f)))
(define-public (arity obj) (define (arity obj)
(define (display-arg-list arg-list) (define (display-arg-list arg-list)
(display #\`) (display #\`)
(display (car arg-list)) (display (car arg-list))
@ -480,7 +483,7 @@ It is an image under the mapping EXTRACT."
(display #\')))))))) (display #\'))))))))
(display ".\n")) (display ".\n"))
(define-public system-module (define system-module
(procedure->syntax (procedure->syntax
(lambda (exp env) (lambda (exp env)
(let* ((m (nested-ref the-root-module (let* ((m (nested-ref the-root-module

View file

@ -1,6 +1,6 @@
;;;; slib.scm --- definitions needed to get SLIB to work with Guile ;;;; slib.scm --- definitions needed to get SLIB to work with Guile
;;;; ;;;;
;;;; Copyright (C) 1997, 1998, 2000 Free Software Foundation, Inc. ;;;; Copyright (C) 1997, 1998, 2000, 2001 Free Software Foundation, Inc.
;;;; ;;;;
;;;; This file is part of GUILE. ;;;; This file is part of GUILE.
;;;; ;;;;
@ -44,6 +44,16 @@
;;;; If you do not wish that, delete this exception notice. ;;;; If you do not wish that, delete this exception notice.
;;;; ;;;;
(define-module (ice-9 slib) (define-module (ice-9 slib)
:export (slib:load slib:load-source defmacro:load
implementation-vicinity library-vicinity home-vicinity
scheme-implementation-type scheme-implementation-version
output-port-width output-port-height identity array-indexes
make-random-state require slib:error slib:exit slib:warn slib:eval
defmacro:eval logical:logand logical:logior logical:logxor
logical:lognot logical:ash logical:logcount logical:integer-length
logical:bit-extract logical:integer-expt logical:ipow-by-squaring
slib:eval-load slib:tab slib:form-feed difftime offset-time
software-type)
:no-backtrace) :no-backtrace)
@ -86,26 +96,72 @@
(define (defined? symbol) (define (defined? symbol)
(module-defined? slib-module symbol)) (module-defined? slib-module symbol))
(define slib:features ;;; *FEATURES* should be set to a list of symbols describing features
(append '(source ;;; of this implementation. Suggestions for features are:
eval (define *features*
abort (append
alist '(
defmacro source ;can load scheme source files
delay ;(slib:load-source "filename")
dynamic-wind ; compiled ;can load compiled files
full-continuation ;(slib:load-compiled "filename")
hash
hash-table ;; Scheme report features
line-i/o
logical ; rev5-report ;conforms to
multiarg/and- eval ;R5RS two-argument eval
multiarg-apply ; values ;R5RS multiple values
promise dynamic-wind ;R5RS dynamic-wind
rev2-procedures ; macro ;R5RS high level macros
rev4-optional-procedures delay ;has DELAY and FORCE
string-port multiarg-apply ;APPLY can take more than 2 args.
with-file) ; rationalize
rev4-optional-procedures ;LIST-TAIL, STRING->LIST,
;LIST->STRING, STRING-COPY,
;STRING-FILL!, LIST->VECTOR,
;VECTOR->LIST, and VECTOR-FILL!
; rev4-report ;conforms to
; ieee-p1178 ;conforms to
; rev3-report ;conforms to
rev2-procedures ;SUBSTRING-MOVE-LEFT!,
;SUBSTRING-MOVE-RIGHT!,
;SUBSTRING-FILL!,
;STRING-NULL?, APPEND!, 1+,
;-1+, <?, <=?, =?, >?, >=?
; object-hash ;has OBJECT-HASH
multiarg/and- ;/ and - can take more than 2 args.
with-file ;has WITH-INPUT-FROM-FILE and
;WITH-OUTPUT-FROM-FILE
; transcript ;TRANSCRIPT-ON and TRANSCRIPT-OFF
; ieee-floating-point ;conforms to IEEE Standard 754-1985
;IEEE Standard for Binary
;Floating-Point Arithmetic.
full-continuation ;can return multiple times
;; Other common features
; srfi ;srfi-0, COND-EXPAND finds all srfi-*
; sicp ;runs code from Structure and
;Interpretation of Computer
;Programs by Abelson and Sussman.
defmacro ;has Common Lisp DEFMACRO
; record ;has user defined data structures
string-port ;has CALL-WITH-INPUT-STRING and
;CALL-WITH-OUTPUT-STRING
; sort
; pretty-print
; object->string
; format ;Common-lisp output formatting
; trace ;has macros: TRACE and UNTRACE
; compiler ;has (COMPILER)
; ed ;(ED) is editor
random
)
(if (defined? 'getenv) (if (defined? 'getenv)
'(getenv) '(getenv)
@ -131,26 +187,7 @@
'(array-for-each) '(array-for-each)
'()) '())
(if (and (string->number "0.0") (inexact? (string->number "0.0"))) *features*))
'(inexact)
'())
(if (rational? (string->number "1/19"))
'(rational)
'())
(if (real? (string->number "0.0"))
'(real)
())
(if (complex? (string->number "1+i"))
'(complex)
'())
(let ((n (string->number "9999999999999999999999999999999")))
(if (and n (exact? n))
'(bignum)
'()))))
;;; FIXME: Because uers want require to search the path, this uses ;;; FIXME: Because uers want require to search the path, this uses
@ -162,7 +199,7 @@
;;; changing catalog:get in slib/require.scm, and I don't expect ;;; changing catalog:get in slib/require.scm, and I don't expect
;;; Aubrey will integrate such a change. So I'm just going to punt ;;; Aubrey will integrate such a change. So I'm just going to punt
;;; for the time being. ;;; for the time being.
(define-public (slib:load name) (define (slib:load name)
(save-module-excursion (save-module-excursion
(lambda () (lambda ()
(set-current-module slib-module) (set-current-module slib-module)
@ -189,23 +226,34 @@
(substring path 0 (- (string-length path) 17)) (substring path 0 (- (string-length path) 17))
(error "Could not find slib/require.scm in " %load-path)))) (error "Could not find slib/require.scm in " %load-path))))
(define-public (implementation-vicinity) (define (implementation-vicinity)
(string-append slib-parent-dir "/")) (string-append slib-parent-dir "/"))
(define-public (library-vicinity) (define (library-vicinity)
(string-append (implementation-vicinity) "slib/")) (string-append (implementation-vicinity) "slib/"))
(define-public home-vicinity (define home-vicinity
(let ((home-path (getenv "HOME"))) (let ((home-path (getenv "HOME")))
(lambda () home-path))) (lambda () home-path)))
(define-public (scheme-implementation-type) 'guile) (define (scheme-implementation-type) 'guile)
(define-public (scheme-implementation-version) "") (define scheme-implementation-version version)
;;; (scheme-implementation-home-page) should return a (string) URI
;;; (Uniform Resource Identifier) for this scheme implementation's home
;;; page; or false if there isn't one.
(define (scheme-implementation-home-page)
"http://www.gnu.org/software/guile/guile.html")
(define (output-port-width . arg) 80) (define (output-port-width . arg) 80)
(define (output-port-height . arg) 24) (define (output-port-height . arg) 24)
(define (identity x) x) (define (identity x) x)
;;; {array-for-each}
(define (array-indexes ra)
(let ((ra0 (apply make-array '() (array-shape ra))))
(array-index-map! ra0 list)
ra0))
;;; {Random numbers} ;;; {Random numbers}
;;; ;;;
(define-public (make-random-state . args) (define (make-random-state . args)
(let ((seed (if (null? args) *random-state* (car args)))) (let ((seed (if (null? args) *random-state* (car args))))
(cond ((string? seed)) (cond ((string? seed))
((number? seed) (set! seed (number->string seed))) ((number? seed) (set! seed (number->string seed)))
@ -251,7 +299,7 @@ no other easy or unambiguous way of detecting such features."
(slib:load (in-vicinity (library-vicinity) "require.scm")) (slib:load (in-vicinity (library-vicinity) "require.scm"))
(define-public require require:require) (define require require:require)
;; {Extensions to the require system so that the user can add new ;; {Extensions to the require system so that the user can add new
;; require modules easily.} ;; require modules easily.}

View file

@ -46,15 +46,14 @@
;; (i.e. ripped off) Scheme48's `stream' package, ;; (i.e. ripped off) Scheme48's `stream' package,
;; modulo stream-empty? -> stream-null? renaming. ;; modulo stream-empty? -> stream-null? renaming.
(define-module (ice-9 streams)) (define-module (ice-9 streams)
:export (make-stream
(export make-stream
stream-car stream-cdr stream-null? stream-car stream-cdr stream-null?
list->stream vector->stream port->stream list->stream vector->stream port->stream
stream->list stream->reversed-list stream->list stream->reversed-list
stream->list&length stream->reversed-list&length stream->list&length stream->reversed-list&length
stream->vector stream->vector
stream-fold stream-for-each stream-map) stream-fold stream-for-each stream-map))
;; Use: ;; Use:
;; ;;

View file

@ -1,6 +1,6 @@
;;;; string-fun.scm --- string manipulation functions ;;;; string-fun.scm --- string manipulation functions
;;;; ;;;;
;;;; Copyright (C) 1995, 1996, 1997, 1999 Free Software Foundation, Inc. ;;;; Copyright (C) 1995, 1996, 1997, 1999, 2001 Free Software Foundation, Inc.
;;;; ;;;;
;;;; This program is free software; you can redistribute it and/or modify ;;;; 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 ;;;; it under the terms of the GNU General Public License as published by
@ -42,7 +42,15 @@
;;;; If you do not wish that, delete this exception notice. ;;;; If you do not wish that, delete this exception notice.
;;;; ;;;;
(define-module (ice-9 string-fun)) (define-module (ice-9 string-fun)
:export (split-after-char split-before-char split-discarding-char
split-after-char-last split-before-char-last
split-discarding-char-last split-before-predicate
split-after-predicate split-discarding-predicate
separate-fields-discarding-char separate-fields-after-char
separate-fields-before-char string-prefix-predicate string-prefix=?
sans-surrounding-whitespace sans-trailing-whitespace
sans-leading-whitespace sans-final-newline has-trailing-newline?))
;;;; ;;;;
;;; ;;;
@ -112,53 +120,53 @@
;;; complicated with these functions, consider using regular expressions. ;;; complicated with these functions, consider using regular expressions.
;;; ;;;
(define-public (split-after-char char str ret) (define (split-after-char char str ret)
(let ((end (cond (let ((end (cond
((string-index str char) => 1+) ((string-index str char) => 1+)
(else (string-length str))))) (else (string-length str)))))
(ret (substring str 0 end) (ret (substring str 0 end)
(substring str end)))) (substring str end))))
(define-public (split-before-char char str ret) (define (split-before-char char str ret)
(let ((end (or (string-index str char) (let ((end (or (string-index str char)
(string-length str)))) (string-length str))))
(ret (substring str 0 end) (ret (substring str 0 end)
(substring str end)))) (substring str end))))
(define-public (split-discarding-char char str ret) (define (split-discarding-char char str ret)
(let ((end (string-index str char))) (let ((end (string-index str char)))
(if (not end) (if (not end)
(ret str "") (ret str "")
(ret (substring str 0 end) (ret (substring str 0 end)
(substring str (1+ end)))))) (substring str (1+ end))))))
(define-public (split-after-char-last char str ret) (define (split-after-char-last char str ret)
(let ((end (cond (let ((end (cond
((string-rindex str char) => 1+) ((string-rindex str char) => 1+)
(else 0)))) (else 0))))
(ret (substring str 0 end) (ret (substring str 0 end)
(substring str end)))) (substring str end))))
(define-public (split-before-char-last char str ret) (define (split-before-char-last char str ret)
(let ((end (or (string-rindex str char) 0))) (let ((end (or (string-rindex str char) 0)))
(ret (substring str 0 end) (ret (substring str 0 end)
(substring str end)))) (substring str end))))
(define-public (split-discarding-char-last char str ret) (define (split-discarding-char-last char str ret)
(let ((end (string-rindex str char))) (let ((end (string-rindex str char)))
(if (not end) (if (not end)
(ret str "") (ret str "")
(ret (substring str 0 end) (ret (substring str 0 end)
(substring str (1+ end)))))) (substring str (1+ end))))))
(define-public (split-before-predicate pred str ret) (define (split-before-predicate pred str ret)
(let loop ((n 0)) (let loop ((n 0))
(cond (cond
((= n (string-length str)) (ret str "")) ((= n (string-length str)) (ret str ""))
((not (pred (string-ref str n))) (loop (1+ n))) ((not (pred (string-ref str n))) (loop (1+ n)))
(else (ret (substring str 0 n) (else (ret (substring str 0 n)
(substring str n)))))) (substring str n))))))
(define-public (split-after-predicate pred str ret) (define (split-after-predicate pred str ret)
(let loop ((n 0)) (let loop ((n 0))
(cond (cond
((= n (string-length str)) (ret str "")) ((= n (string-length str)) (ret str ""))
@ -166,7 +174,7 @@
(else (ret (substring str 0 (1+ n)) (else (ret (substring str 0 (1+ n))
(substring str (1+ n))))))) (substring str (1+ n)))))))
(define-public (split-discarding-predicate pred str ret) (define (split-discarding-predicate pred str ret)
(let loop ((n 0)) (let loop ((n 0))
(cond (cond
((= n (string-length str)) (ret str "")) ((= n (string-length str)) (ret str ""))
@ -174,7 +182,7 @@
(else (ret (substring str 0 n) (else (ret (substring str 0 n)
(substring str (1+ n))))))) (substring str (1+ n)))))))
(define-public (separate-fields-discarding-char ch str ret) (define (separate-fields-discarding-char ch str ret)
(let loop ((fields '()) (let loop ((fields '())
(str str)) (str str))
(cond (cond
@ -183,7 +191,7 @@
(substring str 0 w)))) (substring str 0 w))))
(else (apply ret str fields))))) (else (apply ret str fields)))))
(define-public (separate-fields-after-char ch str ret) (define (separate-fields-after-char ch str ret)
(reverse (reverse
(let loop ((fields '()) (let loop ((fields '())
(str str)) (str str))
@ -193,7 +201,7 @@
(substring str (+ 1 w))))) (substring str (+ 1 w)))))
(else (apply ret str fields)))))) (else (apply ret str fields))))))
(define-public (separate-fields-before-char ch str ret) (define (separate-fields-before-char ch str ret)
(let loop ((fields '()) (let loop ((fields '())
(str str)) (str str))
(cond (cond
@ -214,11 +222,11 @@
;;; (define-public string-prefix=? (string-prefix-predicate string=?)) ;;; (define-public string-prefix=? (string-prefix-predicate string=?))
;;; ;;;
(define-public ((string-prefix-predicate pred?) prefix str) (define ((string-prefix-predicate pred?) prefix str)
(and (<= (string-length prefix) (string-length str)) (and (<= (string-length prefix) (string-length str))
(pred? prefix (substring str 0 (string-length prefix))))) (pred? prefix (substring str 0 (string-length prefix)))))
(define-public string-prefix=? (string-prefix-predicate string=?)) (define string-prefix=? (string-prefix-predicate string=?))
;;; {String Fun: Strippers} ;;; {String Fun: Strippers}
@ -231,7 +239,7 @@
;;; | final-newline ;;; | final-newline
;;; ;;;
(define-public (sans-surrounding-whitespace s) (define (sans-surrounding-whitespace s)
(let ((st 0) (let ((st 0)
(end (string-length s))) (end (string-length s)))
(while (and (< st (string-length s)) (while (and (< st (string-length s))
@ -244,7 +252,7 @@
"" ""
(substring s st end)))) (substring s st end))))
(define-public (sans-trailing-whitespace s) (define (sans-trailing-whitespace s)
(let ((st 0) (let ((st 0)
(end (string-length s))) (end (string-length s)))
(while (and (< 0 end) (while (and (< 0 end)
@ -254,7 +262,7 @@
"" ""
(substring s st end)))) (substring s st end))))
(define-public (sans-leading-whitespace s) (define (sans-leading-whitespace s)
(let ((st 0) (let ((st 0)
(end (string-length s))) (end (string-length s)))
(while (and (< st (string-length s)) (while (and (< st (string-length s))
@ -264,7 +272,7 @@
"" ""
(substring s st end)))) (substring s st end))))
(define-public (sans-final-newline str) (define (sans-final-newline str)
(cond (cond
((= 0 (string-length str)) ((= 0 (string-length str))
str) str)
@ -277,7 +285,7 @@
;;; {String Fun: has-trailing-newline?} ;;; {String Fun: has-trailing-newline?}
;;; ;;;
(define-public (has-trailing-newline? str) (define (has-trailing-newline? str)
(and (< 0 (string-length str)) (and (< 0 (string-length str))
(char=? #\nl (string-ref str (1- (string-length str)))))) (char=? #\nl (string-ref str (1- (string-length str))))))

View file

@ -1,4 +1,4 @@
;;;; Copyright (C) 1997, 2000 Free Software Foundation, Inc. ;;;; Copyright (C) 1997, 2000, 2001 Free Software Foundation, Inc.
;;;; ;;;;
;;;; This program is free software; you can redistribute it and/or modify ;;;; 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 ;;;; it under the terms of the GNU General Public License as published by
@ -42,40 +42,50 @@
(define-module (ice-9 syncase) (define-module (ice-9 syncase)
:use-module (ice-9 debug)) :use-module (ice-9 debug)
:export-syntax (sc-macro define-syntax eval-when fluid-let-syntax
identifier-syntax let-syntax
letrec-syntax syntax syntax-case syntax-rules
with-syntax
include)
:export (sc-expand sc-expand3 install-global-transformer
syntax-dispatch syntax-error bound-identifier=?
datum->syntax-object free-identifier=?
generate-temporaries identifier? syntax-object->datum
void eval syncase))
(define-public sc-macro (define sc-macro
(procedure->memoizing-macro (procedure->memoizing-macro
(lambda (exp env) (lambda (exp env)
(sc-expand exp)))) (sc-expand exp))))
;;; Exported variables ;;; Exported variables
(define-public sc-expand #f) (define sc-expand #f)
(define-public sc-expand3 #f) (define sc-expand3 #f)
(define-public install-global-transformer #f) (define install-global-transformer #f)
(define-public syntax-dispatch #f) (define syntax-dispatch #f)
(define-public syntax-error #f) (define syntax-error #f)
(define-public bound-identifier=? #f) (define bound-identifier=? #f)
(define-public datum->syntax-object #f) (define datum->syntax-object #f)
(define-public define-syntax sc-macro) (define define-syntax sc-macro)
(define-public eval-when sc-macro) (define eval-when sc-macro)
(define-public fluid-let-syntax sc-macro) (define fluid-let-syntax sc-macro)
(define-public free-identifier=? #f) (define free-identifier=? #f)
(define-public generate-temporaries #f) (define generate-temporaries #f)
(define-public identifier? #f) (define identifier? #f)
(define-public identifier-syntax sc-macro) (define identifier-syntax sc-macro)
(define-public let-syntax sc-macro) (define let-syntax sc-macro)
(define-public letrec-syntax sc-macro) (define letrec-syntax sc-macro)
(define-public syntax sc-macro) (define syntax sc-macro)
(define-public syntax-case sc-macro) (define syntax-case sc-macro)
(define-public syntax-object->datum #f) (define syntax-object->datum #f)
(define-public syntax-rules sc-macro) (define syntax-rules sc-macro)
(define-public with-syntax sc-macro) (define with-syntax sc-macro)
(define-public include sc-macro) (define include sc-macro)
(define primitive-syntax '(quote lambda letrec if set! begin define or (define primitive-syntax '(quote lambda letrec if set! begin define or
and let let* cond do quasiquote unquote and let let* cond do quasiquote unquote
@ -87,7 +97,7 @@
;;; Hooks needed by the syntax-case macro package ;;; Hooks needed by the syntax-case macro package
(define-public (void) *unspecified*) (define (void) *unspecified*)
(define andmap (define andmap
(lambda (f first . rest) (lambda (f first . rest)
@ -161,7 +171,7 @@
(define internal-eval (nested-ref the-scm-module '(app modules guile eval))) (define internal-eval (nested-ref the-scm-module '(app modules guile eval)))
(define-public (eval x environment) (define (eval x environment)
(internal-eval (if (and (pair? x) (internal-eval (if (and (pair? x)
(equal? (car x) "noexpand")) (equal? (car x) "noexpand"))
(cadr x) (cadr x)
@ -175,4 +185,4 @@
'*sc-expander* '*sc-expander*
'(define)))) '(define))))
(define-public syncase sc-expand) (define syncase sc-expand)

View file

@ -56,7 +56,12 @@
;;; Code: ;;; Code:
(define-module (ice-9 threads)) (define-module (ice-9 threads)
:export-syntax (make-thread
begin-thread
with-mutex
monitor)
:export (%thread-handler))
@ -109,13 +114,4 @@
(begin (begin
,first ,@rest))) ,first ,@rest)))
;; export
(export %thread-handler)
(export-syntax make-thread
begin-thread
with-mutex
monitor)
;;; threads.scm ends here ;;; threads.scm ends here

View file

@ -1,3 +1,12 @@
2001-10-21 Mikael Djurfeldt <mdj@linnaeus>
* goops.scm, goops/active-slot.scm, goops/compile.scm,
goops/composite-slot.scm, goops/describe.scm, goops/dispatch.scm,
goops/old-define-method.scm, goops/save.scm, goops/util.scm: Move
module the system directives `export', `export-syntax',
`re-export' and `re-export-syntax' into the `define-module' form.
This is the recommended way of exporting bindings.
2001-08-25 Marius Vollmer <mvo@zagadka.ping.de> 2001-08-25 Marius Vollmer <mvo@zagadka.ping.de>
* Makefile.am, goops/Makefile.am: (AUTOMAKE_OPTIONS): Change * Makefile.am, goops/Makefile.am: (AUTOMAKE_OPTIONS): Change

View file

@ -51,27 +51,21 @@
;;;; ;;;;
(define-module (oop goops) (define-module (oop goops)
:no-backtrace) :export-syntax (define-class class
define-generic define-accessor define-method
;; First initialize the builtin part of GOOPS method)
(%init-goops-builtins) :export (goops-version is-a?
;; Then load the rest of GOOPS
(use-modules (oop goops util)
(oop goops dispatch)
(oop goops compile))
(export ; Define the exported symbols of this file
goops-version is-a?
ensure-metaclass ensure-metaclass-with-supers ensure-metaclass ensure-metaclass-with-supers
define-class class make-class make-class
define-generic make-generic ensure-generic make-generic ensure-generic
define-accessor make-accessor ensure-accessor make-accessor ensure-accessor
define-method make-method method add-method! make-method add-method!
object-eqv? object-equal? object-eqv? object-equal?
class-slot-ref class-slot-set! slot-unbound slot-missing class-slot-ref class-slot-set! slot-unbound slot-missing
slot-definition-name slot-definition-options slot-definition-allocation slot-definition-name slot-definition-options
slot-definition-getter slot-definition-setter slot-definition-accessor slot-definition-allocation
slot-definition-getter slot-definition-setter
slot-definition-accessor
slot-definition-init-value slot-definition-init-form slot-definition-init-value slot-definition-init-form
slot-definition-init-thunk slot-definition-init-keyword slot-definition-init-thunk slot-definition-init-keyword
slot-init-function class-slot-definition slot-init-function class-slot-definition
@ -89,11 +83,7 @@
class-subclasses class-methods class-subclasses class-methods
goops-error goops-error
min-fixnum max-fixnum min-fixnum max-fixnum
)
;;; *fixme* Should go into goops.c ;;; *fixme* Should go into goops.c
(export
instance? slot-ref-using-class instance? slot-ref-using-class
slot-set-using-class! slot-bound-using-class? slot-set-using-class! slot-bound-using-class?
slot-exists-using-class? slot-ref slot-set! slot-bound? slot-exists-using-class? slot-ref slot-set! slot-bound?
@ -105,8 +95,16 @@
primitive-generic-generic enable-primitive-generic! primitive-generic-generic enable-primitive-generic!
method-procedure accessor-method-slot-definition method-procedure accessor-method-slot-definition
slot-exists? make find-method get-keyword) slot-exists? make find-method get-keyword)
:re-export (class-of) ;; from (guile)
:no-backtrace)
(re-export class-of) ;; from (guile) ;; First initialize the builtin part of GOOPS
(%init-goops-builtins)
;; Then load the rest of GOOPS
(use-modules (oop goops util)
(oop goops dispatch)
(oop goops compile))
(define min-fixnum (- (expt 2 29))) (define min-fixnum (- (expt 2 29)))

View file

@ -51,9 +51,8 @@
;;;; ;;;;
(define-module (oop goops active-slot) (define-module (oop goops active-slot)
:use-module (oop goops internal)) :use-module (oop goops internal)
:export (<active-class>))
(export <active-class>)
(define-class <active-class> (<class>)) (define-class <active-class> (<class>))

View file

@ -44,12 +44,11 @@
(define-module (oop goops compile) (define-module (oop goops compile)
:use-module (oop goops) :use-module (oop goops)
:use-module (oop goops util) :use-module (oop goops util)
:export (compute-cmethod compute-entry-with-cmethod
compile-method cmethod-code cmethod-environment)
:no-backtrace :no-backtrace
) )
(export compute-cmethod compute-entry-with-cmethod
compile-method cmethod-code cmethod-environment)
(define source-formals cadr) (define source-formals cadr)
(define source-body cddr) (define source-body cddr)

View file

@ -51,9 +51,8 @@
;;;; ;;;;
(define-module (oop goops composite-slot) (define-module (oop goops composite-slot)
:use-module (oop goops)) :use-module (oop goops)
:export (<composite-class>))
(export <composite-class>)
;;; ;;;
;;; (define-class CLASS SUPERS ;;; (define-class CLASS SUPERS

View file

@ -53,9 +53,8 @@
(define-module (oop goops describe) (define-module (oop goops describe)
:use-module (oop goops) :use-module (oop goops)
:use-module (ice-9 session) :use-module (ice-9 session)
:use-module (ice-9 format)) :use-module (ice-9 format)
:export (describe)) ; Export the describe generic function
(export describe) ; Export the describe generic function
;;; ;;;
;;; describe for simple objects ;;; describe for simple objects

View file

@ -1,4 +1,4 @@
;;;; Copyright (C) 1999, 2000 Free Software Foundation, Inc. ;;;; Copyright (C) 1999, 2000, 2001 Free Software Foundation, Inc.
;;;; ;;;;
;;;; This program is free software; you can redistribute it and/or modify ;;;; 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 ;;;; it under the terms of the GNU General Public License as published by
@ -45,11 +45,10 @@
:use-module (oop goops) :use-module (oop goops)
:use-module (oop goops util) :use-module (oop goops util)
:use-module (oop goops compile) :use-module (oop goops compile)
:export (memoize-method!)
:no-backtrace :no-backtrace
) )
(export memoize-method!)
;;; ;;;
;;; This file implements method memoization. It will finally be ;;; This file implements method memoization. It will finally be
;;; implemented on C level in order to obtain fast generic function ;;; implemented on C level in order to obtain fast generic function

View file

@ -45,11 +45,10 @@
(define-module (oop goops old-define-method) (define-module (oop goops old-define-method)
:use-module (oop goops) :use-module (oop goops)
:export (define-method)
:no-backtrace :no-backtrace
) )
(export define-method)
(define define-method (define define-method
(procedure->memoizing-macro (procedure->memoizing-macro
(lambda (exp env) (lambda (exp env)

View file

@ -46,14 +46,11 @@
(define-module (oop goops save) (define-module (oop goops save)
:use-module (oop goops internal) :use-module (oop goops internal)
:use-module (oop goops util) :use-module (oop goops util)
) :re-export (make-unbound)
:export (save-objects load-objects restore
(re-export make-unbound)
(export save-objects load-objects restore
enumerate! enumerate-component! enumerate! enumerate-component!
write-readably write-component write-component-procedure write-readably write-component write-component-procedure
literal? readable make-readable) literal? readable make-readable))
;;; ;;;
;;; save-objects ALIST PORT [EXCLUDED] [USES] ;;; save-objects ALIST PORT [EXCLUDED] [USES]

View file

@ -42,13 +42,12 @@
(define-module (oop goops util) (define-module (oop goops util)
:export (any every filter
mapappend find-duplicate top-level-env top-level-env?
map* for-each* length* improper->proper)
:no-backtrace :no-backtrace
) )
(export any every filter
mapappend find-duplicate top-level-env top-level-env?
map* for-each* length* improper->proper
)
;;; ;;;
;;; {Utilities} ;;; {Utilities}

View file

@ -1,3 +1,11 @@
2001-10-21 Mikael Djurfeldt <mdj@linnaeus>
* srfi-2.scm, srfi-4.scm, srfi-8.scm, srfi-9.scm, srfi-10.scm,
srfi-11.scm, srfi-14.scm, srfi-16.scm: Move module the system
directives `export', `export-syntax', `re-export' and
`re-export-syntax' into the `define-module' form. This is the
recommended way of exporting bindings.
2001-09-22 Mikael Djurfeldt <mdj@linnaeus> 2001-09-22 Mikael Djurfeldt <mdj@linnaeus>
* srfi-19.scm (priv:split-real): Inserted missing call to * srfi-19.scm (priv:split-real): Inserted missing call to

View file

@ -69,9 +69,8 @@
;;; Code: ;;; Code:
(define-module (srfi srfi-10) (define-module (srfi srfi-10)
#:use-module (ice-9 rdelim)) :use-module (ice-9 rdelim)
:export (define-reader-ctor))
(export define-reader-ctor)
(cond-expand-provide (current-module) '(srfi-10)) (cond-expand-provide (current-module) '(srfi-10))

View file

@ -42,7 +42,8 @@
;;; If you do not wish that, delete this exception notice. ;;; If you do not wish that, delete this exception notice.
(define-module (srfi srfi-11) (define-module (srfi srfi-11)
:use-module (ice-9 syncase)) :use-module (ice-9 syncase)
:export-syntax (let-values let*-values))
(cond-expand-provide (current-module) '(srfi-11)) (cond-expand-provide (current-module) '(srfi-11))
@ -256,6 +257,3 @@
; (if (null? vars) ; (if (null? vars)
; `(begin ,@body) ; `(begin ,@body)
; (let-values-helper vars body))) ; (let-values-helper vars body)))
(export-syntax let-values
let*-values)

View file

@ -41,9 +41,8 @@
;;;; whether to permit this exception to apply to your modifications. ;;;; whether to permit this exception to apply to your modifications.
;;;; If you do not wish that, delete this exception notice. ;;;; If you do not wish that, delete this exception notice.
(define-module (srfi srfi-14)) (define-module (srfi srfi-14)
:export (
(export
;;; General procedures ;;; General procedures
char-set? char-set?
char-set= char-set=
@ -112,7 +111,7 @@
char-set:ascii char-set:ascii
char-set:empty char-set:empty
char-set:full char-set:full
) ))
(cond-expand-provide (current-module) '(srfi-14)) (cond-expand-provide (current-module) '(srfi-14))

View file

@ -69,9 +69,8 @@
;;; Author: Martin Grabmueller ;;; Author: Martin Grabmueller
;;; Code: ;;; Code:
(define-module (srfi srfi-16)) (define-module (srfi srfi-16)
:export-syntax (case-lambda))
(export-syntax case-lambda)
(cond-expand-provide (current-module) '(srfi-16)) (cond-expand-provide (current-module) '(srfi-16))

View file

@ -42,8 +42,7 @@
;;;; If you do not wish that, delete this exception notice. ;;;; If you do not wish that, delete this exception notice.
(define-module (srfi srfi-2) (define-module (srfi srfi-2)
:use-module (ice-9 and-let-star)) :use-module (ice-9 and-let-star)
:re-export-syntax (and-let*))
(re-export-syntax and-let*)
(cond-expand-provide (current-module) '(srfi-2)) (cond-expand-provide (current-module) '(srfi-2))

View file

@ -49,9 +49,8 @@
;;; Author: Martin Grabmueller <mgrabmue@cs.tu-berlin.de> ;;; Author: Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
(define-module (srfi srfi-4)) (define-module (srfi srfi-4)
:export (
(export
;;; Unsigned 8-bit vectors. ;;; Unsigned 8-bit vectors.
u8vector? make-u8vector u8vector u8vector-length u8vector-ref u8vector? make-u8vector u8vector u8vector-length u8vector-ref
u8vector-set! u8vector->list list->u8vector u8vector-set! u8vector->list list->u8vector
@ -91,7 +90,7 @@
;;; 64-bit floating point vectors. ;;; 64-bit floating point vectors.
f64vector? make-f64vector f64vector f64vector-length f64vector-ref f64vector? make-f64vector f64vector f64vector-length f64vector-ref
f64vector-set! f64vector->list list->f64vector f64vector-set! f64vector->list list->f64vector
) ))
;; Make 'srfi-4 available as a feature identifiere to `cond-expand'. ;; Make 'srfi-4 available as a feature identifiere to `cond-expand'.

View file

@ -42,8 +42,7 @@
;;; If you do not wish that, delete this exception notice. ;;; If you do not wish that, delete this exception notice.
(define-module (srfi srfi-8) (define-module (srfi srfi-8)
:use-module (ice-9 receive)) :use-module (ice-9 receive)
:re-export-syntax (receive))
(re-export-syntax receive)
(cond-expand-provide (current-module) '(srfi-8)) (cond-expand-provide (current-module) '(srfi-8))

View file

@ -83,9 +83,8 @@
;;; Code: ;;; Code:
(define-module (srfi srfi-9)) (define-module (srfi srfi-9)
:export-syntax (define-record-type))
(export-syntax define-record-type)
(cond-expand-provide (current-module) '(srfi-9)) (cond-expand-provide (current-module) '(srfi-9))

View file

@ -1,3 +1,10 @@
2001-10-21 Mikael Djurfeldt <mdj@linnaeus>
* lib.scm: Move module the system directives `export',
`export-syntax', `re-export' and `re-export-syntax' into the
`define-module' form. This is the recommended way of exporting
bindings.
2001-10-18 Dirk Herrmann <D.Herrmann@tu-bs.de> 2001-10-18 Dirk Herrmann <D.Herrmann@tu-bs.de>
* tests/syntax.test: Added test cases for 'cond =>' syntax with * tests/syntax.test: Added test cases for 'cond =>' syntax with

View file

@ -18,9 +18,8 @@
(define-module (test-suite lib) (define-module (test-suite lib)
:use-module (ice-9 stack-catch) :use-module (ice-9 stack-catch)
:use-module (ice-9 regex)) :use-module (ice-9 regex)
:export (
(export
;; Exceptions which are commonly being tested for. ;; Exceptions which are commonly being tested for.
exception:out-of-range exception:unbound-var exception:out-of-range exception:unbound-var
@ -40,7 +39,7 @@
make-log-reporter make-log-reporter
full-reporter full-reporter
user-reporter user-reporter
format-test-name) format-test-name))
;;;; If you're using Emacs's Scheme mode: ;;;; If you're using Emacs's Scheme mode: