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:
parent
b461abe73f
commit
1a179b03b0
51 changed files with 700 additions and 570 deletions
|
@ -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,
|
||||||
|
|
|
@ -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*)
|
|
||||||
|
|
|
@ -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)))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
|
@ -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)
|
||||||
|
|
|
@ -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))
|
||||||
|
|
|
@ -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)))
|
||||||
|
|
|
@ -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)))
|
||||||
|
|
|
@ -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?
|
||||||
|
|
|
@ -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)
|
||||||
|
|
|
@ -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.
|
||||||
;;
|
;;
|
||||||
|
|
16
ice-9/ls.scm
16
ice-9/ls.scm
|
@ -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)))
|
||||||
|
|
|
@ -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))
|
||||||
|
|
|
@ -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))
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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))
|
||||||
|
|
|
@ -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.
|
||||||
|
|
||||||
|
|
30
ice-9/q.scm
30
ice-9/q.scm
|
@ -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
|
||||||
|
|
|
@ -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)
|
||||||
|
|
||||||
|
|
|
@ -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")
|
||||||
|
|
|
@ -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)
|
||||||
|
|
|
@ -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))
|
||||||
|
|
|
@ -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))
|
||||||
|
|
|
@ -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)))
|
||||||
|
|
|
@ -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
|
||||||
|
|
146
ice-9/slib.scm
146
ice-9/slib.scm
|
@ -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.}
|
||||||
|
|
|
@ -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:
|
||||||
;;
|
;;
|
||||||
|
|
|
@ -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))))))
|
||||||
|
|
||||||
|
|
|
@ -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)
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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)))
|
||||||
|
|
|
@ -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>))
|
||||||
|
|
||||||
|
|
|
@ -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)
|
||||||
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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)
|
||||||
|
|
|
@ -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]
|
||||||
|
|
|
@ -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}
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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))
|
||||||
|
|
||||||
|
|
|
@ -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)
|
|
||||||
|
|
|
@ -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))
|
||||||
|
|
||||||
|
|
|
@ -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))
|
||||||
|
|
||||||
|
|
|
@ -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))
|
||||||
|
|
|
@ -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'.
|
||||||
|
|
|
@ -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))
|
||||||
|
|
|
@ -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))
|
||||||
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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:
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue