[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Chicken-hackers] [PATCH(5)] Remove srfi-18 and srfi-69
|
From: |
Felix Winkelmann |
|
Subject: |
[Chicken-hackers] [PATCH(5)] Remove srfi-18 and srfi-69 |
|
Date: |
Fri, 12 Sep 2014 10:39:59 +0200 (CEST) |
Hello!
This patch removes support for srfi-18 and srfi-69. I had to remove
some tests as well, specifically those that use threads.
I will also move the eggs into the release/5 branch, together with
most tests that have been removed from the core test suite.
felix
>From 5992ca450b290caebc37f29d247bcb800fbc3136 Mon Sep 17 00:00:00 2001
From: felix <address@hidden>
Date: Thu, 11 Sep 2014 20:58:56 +0200
Subject: [PATCH] Removed srfi-18 and srfi-69.
---
README | 2 -
chicken-install.scm | 2 -
chicken-profile.scm | 19 +-
chicken.scm | 3 +-
defaults.make | 2 +-
distribution/manifest | 17 -
eval.scm | 2 +-
lolevel.scm | 1 -
manual/Embedding | 3 +-
manual/Modules | 2 -
manual/Non-standard macros and special forms | 6 +-
manual/Supported language | 2 -
manual/Unit posix | 2 +-
manual/Unit srfi-18 | 1045 ------------------------
manual/Unit srfi-69 | 395 ---------
manual/faq | 14 +-
rules.make | 6 +-
scripts/compile-all | 2 +-
scripts/makedist.scm | 2 +-
setup.defaults | 2 +-
srfi-18.import.scm | 71 --
srfi-18.scm | 461 -----------
srfi-69.import.scm | 73 --
srfi-69.scm | 1132 --------------------------
tests/feeley-dynwind.scm | 71 --
tests/hash-table-tests.scm | 242 ------
tests/loopy-test.scm | 8 -
tests/mutex-test.scm | 76 --
tests/port-tests.scm | 29 -
tests/reexport-m1.scm | 4 +-
tests/runtests.bat | 12 -
tests/runtests.sh | 19 +-
tests/signal-tests.scm | 2 +-
tests/simple-thread-test.scm | 19 -
tests/thread-list.scm | 44 -
types.db | 148 ----
36 files changed, 38 insertions(+), 3902 deletions(-)
delete mode 100644 manual/Unit srfi-18
delete mode 100644 manual/Unit srfi-69
delete mode 100644 srfi-18.import.scm
delete mode 100644 srfi-18.scm
delete mode 100644 srfi-69.import.scm
delete mode 100644 srfi-69.scm
delete mode 100644 tests/feeley-dynwind.scm
delete mode 100644 tests/hash-table-tests.scm
delete mode 100644 tests/mutex-test.scm
delete mode 100644 tests/simple-thread-test.scm
delete mode 100644 tests/thread-list.scm
diff --git a/README b/README
index 8a90bb5..c7ffd5b 100644
--- a/README
+++ b/README
@@ -300,9 +300,7 @@
| | |-- setup-download.so
| | |-- srfi-1.import.so
| | |-- srfi-14.import.so
- | | |-- srfi-18.import.so
| | |-- srfi-4.import.so
- | | |-- srfi-69.import.so
| | |-- tcp.import.so
| | |-- types.db
| | `-- utils.import.so
diff --git a/chicken-install.scm b/chicken-install.scm
index 6021469..097d0f7 100644
--- a/chicken-install.scm
+++ b/chicken-install.scm
@@ -47,12 +47,10 @@
"ports.import.so"
"files.import.so"
"posix.import.so"
- "srfi-69.import.so"
"extras.import.so"
"srfi-14.import.so"
"tcp.import.so"
"foreign.import.so"
- "srfi-18.import.so"
"utils.import.so"
"csi.import.so"
"irregex.import.so"
diff --git a/chicken-profile.scm b/chicken-profile.scm
index 46a8637..bc4b17c 100644
--- a/chicken-profile.scm
+++ b/chicken-profile.scm
@@ -29,10 +29,11 @@
(block)
(uses srfi-1
data-structures
- srfi-69
posix
utils))
+(define symbol-table-size 3001)
+
(define sort-by #f)
(define file #f)
(define no-unused #f)
@@ -151,16 +152,24 @@ EOF
(set! percent-digits (arg-digit 2)))
(error "invalid argument to -decimals option" arg)))
+(define (make-sysmbol-table)
+ (make-vector symbol-table-size '()))
+
(define (read-profile)
- (let ((hash (make-hash-table eq?)))
+ (let ((hash (make-symbol-table)))
(do ((line (read) (read)))
((eof-object? line))
- (hash-table-set!
+ (##sys#hash-table-set!
hash (first line)
(map (lambda (x y) (and x y (+ x y)))
- (hash-table-ref/default hash (first line) '(0 0))
+ (or (##sys#hash-table-ref hash (first line)) '(0 0))
(cdr line))))
- (hash-table->alist hash)))
+ (let ((alist '()))
+ (##sys#hash-table-for-each
+ (lambda (sym counts)
+ (set! alist (alist-cons sym counts alist)))
+ hash)
+ alist)))
(define (format-string str cols #!optional right (padc #\space))
(let* ((len (string-length str))
diff --git a/chicken.scm b/chicken.scm
index 5e85efd..c4e8391 100644
--- a/chicken.scm
+++ b/chicken.scm
@@ -30,8 +30,7 @@
srfi-1 srfi-4 utils files extras data-structures support
compiler optimizer lfa2 compiler-syntax scrutinizer
;; TODO: These three need to be made configurable somehow
- batch-driver c-platform c-backend
- srfi-69))
+ batch-driver c-platform c-backend))
(include "tweaks")
diff --git a/defaults.make b/defaults.make
index 589306c..7f64f8f 100644
--- a/defaults.make
+++ b/defaults.make
@@ -275,7 +275,7 @@ CHICKEN_INSTALL_PROGRAM =
$(PROGRAM_PREFIX)chicken-install$(PROGRAM_SUFFIX)
CHICKEN_UNINSTALL_PROGRAM = $(PROGRAM_PREFIX)chicken-uninstall$(PROGRAM_SUFFIX)
CHICKEN_STATUS_PROGRAM = $(PROGRAM_PREFIX)chicken-status$(PROGRAM_SUFFIX)
CHICKEN_BUG_PROGRAM = $(PROGRAM_PREFIX)chicken-bug$(PROGRAM_SUFFIX)
-IMPORT_LIBRARIES = chicken lolevel srfi-1 srfi-4 data-structures ports files
posix srfi-69 extras srfi-14 tcp foreign srfi-18 utils csi irregex
+IMPORT_LIBRARIES = chicken lolevel srfi-1 srfi-4 data-structures ports files
posix extras srfi-14 tcp foreign utils csi irregex
IMPORT_LIBRARIES += setup-api setup-download
ifdef STATICBUILD
diff --git a/distribution/manifest b/distribution/manifest
index 6f5747d..4d662dc 100644
--- a/distribution/manifest
+++ b/distribution/manifest
@@ -37,10 +37,8 @@ posixunix.c
posixwin.c
profiler.c
scheduler.c
-srfi-69.c
srfi-1.c
srfi-14.c
-srfi-18.c
srfi-4.c
stub.c
support.c
@@ -92,10 +90,8 @@ posix-common.scm
profiler.scm
runtime.c
scheduler.scm
-srfi-69.scm
srfi-1.scm
srfi-14.scm
-srfi-18.scm
srfi-4.scm
stub.scm
support.scm
@@ -104,7 +100,6 @@ build-version.scm
build-version.c
buildid
buildtag.h
-tests/thread-list.scm
tests/data-structures-tests.scm
tests/environment-tests.scm
tests/gobble.scm
@@ -124,12 +119,8 @@ tests/runtests.sh
tests/runtests.bat
tests/runbench.sh
tests/srfi-4-tests.scm
-tests/srfi-18-signal-test.scm
tests/srfi-14-tests.scm
tests/srfi-45-tests.scm
-tests/simple-thread-test.scm
-tests/mutex-test.scm
-tests/hash-table-tests.scm
tests/apply-test.scm
tests/embedded1.c
tests/embedded2.scm
@@ -185,7 +176,6 @@ tests/specialization-test-2.scm
tests/test-irregex.scm
tests/re-tests.txt
tests/lolevel-tests.scm
-tests/feeley-dynwind.scm
tests/compiler-syntax-tests.scm
tests/compiler.scm
tests/fft.scm
@@ -215,7 +205,6 @@ tests/reverser/tags/1.1/reverser.meta
tests/reverser/tags/1.1/reverser.setup
tests/reverser/tags/1.1/reverser.scm
tests/rev-app.scm
-tests/signal-tests.scm
tests/version-tests.scm
tweaks.scm
utils.scm
@@ -264,24 +253,20 @@ srfi-1.import.scm
srfi-4.import.scm
data-structures.import.scm
posix.import.scm
-srfi-69.import.scm
extras.import.scm
irregex.import.scm
srfi-14.import.scm
tcp.import.scm
-srfi-18.import.scm
utils.import.scm
lolevel.import.c
srfi-1.import.c
srfi-4.import.c
data-structures.import.c
posix.import.c
-srfi-69.import.c
extras.import.c
irregex.import.c
srfi-14.import.c
tcp.import.c
-srfi-18.import.c
utils.import.c
csi.import.scm
csi.import.c
@@ -357,9 +342,7 @@ manual-html/Unit posix.html
manual-html/Unit irregex.html
manual-html/Unit srfi-1.html
manual-html/Unit srfi-14.html
-manual-html/Unit srfi-18.html
manual-html/Unit srfi-4.html
-manual-html/Unit srfi-69.html
manual-html/Unit tcp.html
manual-html/Unit utils.html
manual-html/Using the compiler.html
diff --git a/eval.scm b/eval.scm
index cfb0194..d5224fc 100644
--- a/eval.scm
+++ b/eval.scm
@@ -62,7 +62,7 @@
(define ##sys#core-library-modules
'(extras lolevel utils files tcp irregex posix srfi-1 srfi-4
- srfi-14 srfi-18 srfi-69 data-structures ports))
+ srfi-14 data-structures ports))
(define ##sys#core-syntax-modules
'(chicken-syntax chicken-ffi-syntax))
diff --git a/lolevel.scm b/lolevel.scm
index aeaeb79..b638541 100644
--- a/lolevel.scm
+++ b/lolevel.scm
@@ -27,7 +27,6 @@
(declare
(unit lolevel)
- (uses srfi-69)
(hide ipc-hook-0 *set-invalid-procedure-call-handler! xproc-tag
##sys#check-block
##sys#check-become-alist
diff --git a/manual/Embedding b/manual/Embedding
index 2b688a7..d9661f4 100644
--- a/manual/Embedding
+++ b/manual/Embedding
@@ -152,8 +152,7 @@ Returns a textual description of the most recent error that
occurred in executin
If threads have been spawned during earlier invocations of embedded Scheme
code, then this function
will run the next scheduled thread for one complete time-slice. This is
useful, for example, inside
-an ''idle'' handler in a GUI application with background Scheme threads. Note
that the
-{{srfi-18}} library unit has to be linked in for this.
+an ''idle'' handler in a GUI application with background Scheme threads.
diff --git a/manual/Modules b/manual/Modules
index 9a2b95c..d3ca0d9 100644
--- a/manual/Modules
+++ b/manual/Modules
@@ -281,8 +281,6 @@ Everything from the {{library}}, {{eval}} and {{expand}}
library units.
[module] srfi-1
[module] srfi-4
[module] srfi-14
- [module] srfi-18
- [module] srfi-69
[module] tcp
[module] utils
diff --git a/manual/Non-standard macros and special forms b/manual/Non-standard
macros and special forms
index b63db49..d49cbbd 100644
--- a/manual/Non-standard macros and special forms
+++ b/manual/Non-standard macros and special forms
@@ -535,11 +535,11 @@ Expands by selecting feature clauses. This form is
allowed to appear in non-topl
Predefined feature-identifiers are "situation" specific:
-; compile : {{chicken}}, {{compiling}}, {{library}}, {{eval}}, {{extras}},
{{utils}}, {{regex}}, {{srfi-0}}, {{srfi-1}}, {{srfi-2}}, {{srfi-4}},
{{srfi-6}}, {{srfi-8}}, {{srfi-9}}, {{srfi-10}}, {{srfi-11}}, {{srfi-12}},
{{srfi-15}}, {{srfi-16}}, {{srfi-17}}, {{srfi-23}}, {{srfi-26}}, {{srfi-28}},
{{srfi-30}}, {{srfi-31}}, {{srfi-39}}, {{srfi-55}}, {{srfi-61}}, {{srfi-62}},
{{srfi-69}}
+; compile : {{chicken}}, {{compiling}}, {{library}}, {{eval}}, {{extras}},
{{utils}}, {{regex}}, {{srfi-0}}, {{srfi-1}}, {{srfi-2}}, {{srfi-4}},
{{srfi-6}}, {{srfi-8}}, {{srfi-9}}, {{srfi-10}}, {{srfi-11}}, {{srfi-12}},
{{srfi-15}}, {{srfi-16}}, {{srfi-17}}, {{srfi-23}}, {{srfi-26}}, {{srfi-28}},
{{srfi-30}}, {{srfi-31}}, {{srfi-39}}, {{srfi-55}}, {{srfi-61}}, {{srfi-62}}
-; load : {{chicken}}, {{extras}}, {{srfi-0}}, {{srfi-2}}, {{srfi-6}},
{{srfi-8}}, {{srfi-9}}, {{srfi-10}}, {{srfi-12}}, {{srfi-17}}, {{srfi-23}},
{{srfi-28}}, {{srfi-30}}, {{srfi-39}}, {{srfi-55}}, {{srfi-61}}, {{srfi-62}},
{{srfi-69}}. {{library}} is implicit.
+; load : {{chicken}}, {{extras}}, {{srfi-0}}, {{srfi-2}}, {{srfi-6}},
{{srfi-8}}, {{srfi-9}}, {{srfi-10}}, {{srfi-12}}, {{srfi-17}}, {{srfi-23}},
{{srfi-28}}, {{srfi-30}}, {{srfi-39}}, {{srfi-55}}, {{srfi-61}}, {{srfi-62}}.
{{library}} is implicit.
-; eval : {{csi}}, {{chicken}}, {{extras}}, {{srfi-0}}, {{srfi-2}}, {{srfi-6}},
{{srfi-8}}, {{srfi-9}}, {{srfi-10}}, {{srfi-11}}, {{srfi-12}}, {{srfi-15}},
{{srfi-16}}, {{srfi-17}}, {{srfi-23}}, {{srfi-26}}, {{srfi-28}}, {{srfi-30}},
{{srfi-31}}, {{srfi-39}}, {{srfi-55}}, {{srfi-61}}, {{srfi-62}}, {{srfi-69}}.
{{library}} is implicit.
+; eval : {{csi}}, {{chicken}}, {{extras}}, {{srfi-0}}, {{srfi-2}}, {{srfi-6}},
{{srfi-8}}, {{srfi-9}}, {{srfi-10}}, {{srfi-11}}, {{srfi-12}}, {{srfi-15}},
{{srfi-16}}, {{srfi-17}}, {{srfi-23}}, {{srfi-26}}, {{srfi-28}}, {{srfi-30}},
{{srfi-31}}, {{srfi-39}}, {{srfi-55}}, {{srfi-61}}, {{srfi-62}}. {{library}} is
implicit.
The following feature-identifier classes are available in all situations:
{{(machine-byte-order)}}, {{(machine-type)}}, {{(software-type)}},
diff --git a/manual/Supported language b/manual/Supported language
index 849a26b..66782f8 100644
--- a/manual/Supported language
+++ b/manual/Supported language
@@ -24,8 +24,6 @@
* [[Unit srfi-1]] List Library
* [[Unit srfi-4]] Homogeneous numeric vectors
* [[Unit srfi-14]] Character set library
-* [[Unit srfi-18]] multithreading
-* [[Unit srfi-69]] Hashtable Library
* [[Unit posix]] Unix-like services
* [[Unit utils]] Shell scripting and file operations
* [[Unit tcp]] Basic TCP-sockets
diff --git a/manual/Unit posix b/manual/Unit posix
index 7305097..b7b0c07 100644
--- a/manual/Unit posix
+++ b/manual/Unit posix
@@ -1433,6 +1433,6 @@ Returns:
* -1 when failure
----
-Previous: [[Unit srfi-69]]
+Previous: [[Unit srfi-14]]
Next: [[Unit utils]]
diff --git a/manual/Unit srfi-18 b/manual/Unit srfi-18
deleted file mode 100644
index 96b30db..0000000
--- a/manual/Unit srfi-18
+++ /dev/null
@@ -1,1045 +0,0 @@
-[[tags: manual]]
-
-[[toc:]]
-
-== Unit srfi-18
-
-A multithreading package, largely following the specification
-of [[http://srfi.schemers.org/srfi-18/srfi-18.html|SRFI-18]]. This
-document contains the core of the SRFI-18 documentation as well as
-information on CHICKEN deviations from the spec.
-
-The threads implemented in CHICKEN are so called "green" threads,
-based on first-class continuations. Native threads that map directly
-to the threads provided by the operating system are not supported.
-The advantage of this is that threads are very lightweight and
-somewhat larger degree of determinism. The disadvantage is that
-execution of Scheme code on multiple processor cores is not available.
-
-SRFI-18 defines the following multithreading datatypes:
-
-* Thread
-* Mutex
-* Condition variable
-* Time
-
-It also defines a mechanism to handle exceptions and some multithreading
-exception datatypes.
-
-== CHICKEN implementation
-
-=== Notes
-
-* {{thread-start!}} accepts a thunk (a zero argument procedure) as argument,
which is equivalent to {{(thread-start! (make-thread THUNK))}}.
-
-* {{thread-sleep!}} accepts a seconds real number value in addition to a time
object.
-
-* When an uncaught exception (i.e. an error) is signalled in a thread other
than the primordial thread and warnings are enabled (see: {{enable-warnings}},
then a warning message is written to the port that is the value of
{{(current-error-port)}}.
-
-* Blocking I/O will block all threads, except for some socket operations (see
the section about the {{tcp}} unit). An exception is the read-eval-print loop
on UNIX platforms: waiting for input will not block other threads, provided the
current input port reads input from a console.
-
-* It is generally not a good idea for one thread to call a continuation
created by another thread, if {{dynamic-wind}} is involved.
-
-* When more than one thread compete for the current time-slice, the thread
that was waiting first will become the next runnable thread.
-
-* The dynamic environment of a thread consists of the following state:
-
-** The current input-, output- and error-port
-
-** The current exception handler
-
-** The values of all current parameters (created by {{make-parameter}})
-
-** Any pending {{dynamic-wind}} thunks.
-
-* When an error is triggered inside the execution context of a thread, the
default exception-handler will simply terminate the thread (and store the error
condition for later use). Pending {{dynamic-wind}} thunks will ''not'' be
invoked. Use a custom exception handler for the thread in that case.
-
-=== Procedures
-
-The following procedures are provided in addition to the procedures defined in
SRFI-18.
-
-<procedure>(thread-signal! THREAD X)</procedure>
-
-This will cause {{THREAD}} to signal the condition {{X}} once it is scheduled
-for execution. After signalling the condition, the thread continues with its
normal
-execution.
-
-<procedure>(thread-quantum THREAD)</procedure>
-
-Returns the quantum of {{THREAD}}, which is an exact integer
-specifying the approximate time-slice of the thread in milliseconds.
-
-<procedure>(thread-quantum-set! THREAD QUANTUM)</procedure>
-
-Sets the quantum of {{THREAD}} to {{QUANTUM}}.
-
-<procedure>(thread-suspend! THREAD)</procedure>
-
-Suspends the execution of {{THREAD}} until resumed.
-
-<procedure>(thread-resume! THREAD)</procedure>
-
-Readies the suspended thread {{THREAD}}.
-
-<procedure>(thread-wait-for-i/o! FD [MODE])</procedure>
-
-Suspends the current thread until input ({{MODE}} is {{#:input}}), output
({{MODE}} is {{#:output}})
-or both ({{MODE}} is {{#:all}}) is available. {{FD}} should be a
file-descriptor (not a port!) open
-for input or output, respectively.
-
-<procedure>(thread-state thread)</procedure><br>
-
-Returns information about the state of the {{thread}}. The possible results
-are:
-
-
-* '''symbol {{created}}''': the {{thread}} is in the created state
-* '''symbol {{ready}}''': the {{thread}} is in the ready state
-* '''symbol {{running}}''': the {{thread}} is in the running state
-* '''symbol {{blocked}}''': the {{thread}} is in the blocked state
-* '''symbol {{suspended}}''': the {{thread}} is in the suspended state
-* '''symbol {{sleeping}}''': the {{thread}} is in the sleeping state
-* '''symbol {{terminated}}''': the {{thread}} is in the terminated state
-* '''symbol {{dead}}''': the {{thread}} is in the dead state
-
-
-== SRFI-18 specification
-
-The thread system provides the following data types:
-
-* Thread (a virtual processor which shares object space with all other
threads)
-* Mutex (a mutual exclusion device, also known as a lock and binary semaphore)
-* Condition variable (a set of blocked threads)
-* Time (an absolute point on the time line)
-
-Some multithreading exception datatypes are also specified, and a general
-mechanism for handling exceptions.
-
-=== Background information
-
-==== Threads
-
-A "running" thread is a thread that is currently executing. There can be
-more than one running thread on a multiprocessor machine. A "runnable"
-thread is a thread that is ready to execute or running. A thread is
-"blocked" if it is waiting for a mutex to become unlocked, an I/O operation
-to become possible, the end of a "sleep" period, etc. A "new" thread is a
-thread that has not yet become runnable. A new thread becomes runnable when
-it is started. A "terminated" thread is a thread that can no longer become
-runnable (but "deadlocked" threads are not considered terminated). The
-only valid transitions between the thread states are from new to runnable,
-between runnable and blocked, and from any state to terminated:
-
-
- unblock
- start <-------
- NEW -------> RUNNABLE -------> BLOCKED
- \ | block /
- \ v /
- +-----> TERMINATED <----+
-
-
-Each thread has a "specific" field which can be used in an application
-specific way to associate data with the thread (some thread systems call
-this "thread local storage").
-
-==== Mutexes
-
-A mutex can be in one of four states: locked (either owned or not owned)
-and unlocked (either abandoned or not abandoned). An attempt to lock
-a mutex only succeeds if the mutex is in an unlocked state, otherwise
-the current thread must wait. A mutex in the locked/owned state has an
-associated "owner" thread, which by convention is the thread that is
-responsible for unlocking the mutex (this case is typical of critical
-sections implemented as "lock mutex, perform operation, unlock mutex"). A
-mutex in the locked/not-owned state is not linked to a particular thread.
-A mutex becomes locked when a thread locks it using the {{mutex-lock!}}
-primitive. A mutex becomes unlocked/abandoned when the owner of a
-locked/owned mutex terminates. A mutex becomes unlocked/not-abandoned
-when a thread unlocks it using the {{mutex-unlock!}} primitive. The mutex
-primitives specified in this SRFI do not implement "recursive" mutex
-semantics; an attempt to lock a mutex that is locked implies that the
-current thread must wait even if the mutex is owned by the current thread
-(this can lead to a deadlock if no other thread unlocks the mutex).
-
-Each mutex has a "specific" field which can be used in an application
-specific way to associate data with the mutex.
-
-
-==== Condition variables
-
-A condition variable represents a set of blocked threads. These blocked
-threads are waiting for a certain condition to become true. When a thread
-modifies some program state that might make the condition true, the thread
-unblocks some number of threads (one or all depending on the primitive
-used) so they can check the value of the condition. This allows complex
-forms of interthread synchronization to be expressed more conveniently than
-with mutexes alone.
-
-Each condition variable has a "specific" field which can be used in an
-application specific way to associate data with the condition variable.
-
-
-==== Fairness
-
-In various situations the scheduler must select one thread from a set of
-threads (e.g. which thread to run when a running thread blocks or expires
-its quantum, which thread to unblock when a mutex unlocks or a condition
-variable is signaled). The constraints on the selection process determine
-the scheduler's "fairness". Typically the selection depends on the order in
-which threads become runnable or blocked and on some "priority" attached to
-the threads.
-
-Because we do not wish to preclude extensions to this SRFI (such as for
-real-time multithreading) that require specific fairness constraints, there
-are no fairness constraints imposed by this SRFI. It is expected however
-that implementations of Scheme that support this SRFI will document the
-fairness constraints they provide.
-
-
-==== Memory coherency and lack of atomicity
-
-Read and write operations on the store (such as reading and writing a
-variable, an element of a vector or a string) are not required to be
-atomic. It is an error for a thread to write a location in the store
-while some other thread reads or writes that same location. It is the
-responsibility of the application to avoid write/read and write/write races
-through appropriate uses of the synchronization primitives.
-
-Concurrent reads and writes to ports are allowed. It is the responsibility
-of the implementation to serialize accesses to a given port using the
-appropriate synchronization primitives.
-
-
-==== Dynamic environments, continuations and {{dynamic-wind}}
-
-The "dynamic environment" is a structure which allows the system to find
-the value returned by {{current-input-port}}, {{current-output-port}},
-etc. The procedures {{with-input-from-file}}, {{with-output-to-file}},
-etc extend the dynamic environment to produce a new dynamic environment
-which is in effect for the duration of the call to the thunk passed as the
-last argument. Some Scheme systems generalize the dynamic environment by
-providing procedures and special forms to define new "dynamic variables"
-and bind them in the dynamic environment (e.g. {{make-parameter}} and
-{{parameterize}}).
-
-Each thread has its own dynamic environment. When a thread's dynamic
-environment is extended this does not affect the dynamic environment
-of other threads. When a thread creates a continuation, the thread's
-dynamic environment and the {{dynamic-wind}} stack are saved within
-the continuation (an alternate but equivalent point of view is that the
-{{dynamic-wind}} stack is part of the dynamic environment). When this
-continuation is invoked the required {{dynamic-wind}} before and after
-thunks are called and the saved dynamic environment is reinstated as the
-dynamic environment of the current thread. During the call to each required
-{{dynamic-wind}} before and after thunk, the dynamic environment and the
-{{dynamic-wind}} stack in effect when the corresponding {{dynamic-wind}}
-was executed are reinstated. Note that this specification clearly defines
-the semantics of calling {{call-with-current-continuation}} or invoking a
-continuation within a before or after thunk. The semantics are well defined
-even when a continuation created by another thread is invoked. Below is an
-example exercising the subtleties of this semantics.
-
-
- (with-output-to-file
- "foo"
- (lambda ()
- (let ((k (call-with-current-continuation
- (lambda (exit)
- (with-output-to-file
- "bar"
- (lambda ()
- (dynamic-wind
- (lambda () (write '(b1)))
- (lambda ()
- (let ((x (call-with-current-continuation
- (lambda (cont) (exit cont)))))
- (write '(t1))
- x))
- (lambda () (write '(a1))))))))))
- (if k
- (dynamic-wind
- (lambda () (write '(b2)))
- (lambda ()
- (with-output-to-file
- "baz"
- (lambda ()
- (write '(t2))
- ; go back inside (with-output-to-file "bar" ...)
- (k #f))))
- (lambda () (write '(a2))))))))
-
-In an implementation of Scheme where {{with-output-to-file}} only closes
-the port it opened when the thunk returns normally, then the following
-actions will occur: {{(b1)(a1)}} is written to "bar", {{(b2)}} is written
-to "foo", {{(t2)}} is written to "baz", {{(a2)}} is written to "foo", and
-{{(b1)(t1)(a1)}} is written to "bar".
-
-When the scheduler stops the execution of a running thread T1 (whether
-because it blocked, expired its quantum, was terminated, etc) and then
-resumes the execution of a thread T2, there is in a sense a transfer of
-control between T1's current continuation and the continuation of T2. This
-transfer of control by the scheduler does not cause any {{dynamic-wind}}
-before and after thunks to be called. It is only when a thread itself
-transfers control to a continuation that {{dynamic-wind}} before and after
-thunks are called.
-
-
-==== Time objects and timeouts
-
-A time object represents a point on the time line. Its resolution is
-implementation dependent (implementations are encouraged to implement at
-least millisecond resolution so that precise timing is possible). Using
-{{time->seconds}} and {{seconds->time}}, a time object can be converted
-to and from a real number which corresponds to the number of seconds from
-a reference point on the time line. The reference point is implementation
-dependent and does not change for a given execution of the program (e.g.
-the reference point could be the time at which the program started).
-
-All synchronization primitives which take a timeout parameter accept three
-types of values as a timeout, with the following meaning:
-
-
-* a time object represents an absolute point in time
-* an exact or inexact real number represents a relative time in seconds from
the moment the primitive was called
-* {{#f}} means that there is no timeout
-
-When a timeout denotes the current time or a time in the past, the
-synchronization primitive claims that the timeout has been reached only
-after the other synchronization conditions have been checked. Moreover the
-thread remains running (it does not enter the blocked state). For example,
-{{(mutex-lock! m 0)}} will lock mutex {{m}} and return {{#t}} if {{m}} is
-currently unlocked, otherwise {{#f}} is returned because the timeout is
-reached.
-
-
-==== Primitives and exceptions
-
-When one of the primitives defined in this SRFI raises an exception defined
-in this SRFI, the exception handler is called with the same continuation
-as the primitive (i.e. it is a tail call to the exception handler). This
-requirement avoids having to use {{call-with-current-continuation}} to get
-the same effect in some situations.
-
-
-==== Primordial thread
-
-The execution of a program is initially under the control of a single
-thread known as the "primordial thread". The primordial thread has an
-unspecified name, specific field, dynamic environment, {{dynamic-wind}}
-stack, and exception handler. All threads are terminated when the
-primordial thread terminates (normally or not).
-
-
-=== Procedures
-
-<procedure>(current-thread)</procedure><br>
-
-Returns the current thread.
-
-
- (eq? (current-thread) (current-thread)) ==> #t
-
-
-<procedure>(thread? obj)</procedure><br>
-
-Returns {{#t}} if {{obj}} is a thread, otherwise returns {{#f}}.
-
-
- (thread? (current-thread)) ==> #t
- (thread? 'foo) ==> #f
-
-<procedure>(make-thread thunk [name])</procedure><br>
-
-Returns a new thread. This thread is not automatically made runnable
-(the procedure {{thread-start!}} must be used for this).
-
-A thread has the following fields: name, specific, end-result,
-end-exception, and a list of locked/owned mutexes it owns. The
-thread's execution consists of a call to ''thunk'' with the "initial
-continuation". This continuation causes the (then) current thread to
-store the result in its end-result field, abandon all mutexes it owns,
-and finally terminate. The {{dynamic-wind}} stack of the initial
-continuation is empty. The optional {{name}} is an arbitrary Scheme
-object which identifies the thread (useful for debugging); it defaults
-to an unspecified value. The specific field is set to an unspecified
-value.
-
-The thread inherits the dynamic environment from the current
-thread. Moreover, in this dynamic environment the exception handler is
-bound to the "initial exception handler" which is a unary procedure
-which causes the (then) current thread to store in its end-exception
-field an "uncaught exception" object whose "reason" is the argument of
-the handler, abandon all mutexes it owns, and finally terminate.
-
- (make-thread (lambda () (write 'hello))) ==> ''a thread''
-
-<procedure>(thread-name thread)</procedure><br>
-
-Returns the name of the {{thread}}.
-
-
- (thread-name (make-thread (lambda () #f) 'foo)) ==> foo
-
-<procedure>(thread-specific thread)</procedure><br>
-
-Returns the content of the {{thread}}'s specific field.
-
-<procedure>(thread-specific-set! thread obj)</procedure><br>
-
-Stores {{obj}} into the {{thread}}'s specific field.
-{{thread-specific-set!}} returns an unspecified value.
-
- (thread-specific-set! (current-thread) "hello") ==> ''unspecified''
-
- (thread-specific (current-thread)) ==> "hello"
-
-Alternatively, you can use
-
- (set! (thread-specific (current-thread)) "hello")
-
-<procedure>(thread-start! thread)</procedure><br>
-
-Makes {{thread}} runnable. The {{thread}} must be a new thread.
-{{thread-start!}} returns the {{thread}}.
-
-
- (let ((t (thread-start! (make-thread (lambda () (write 'a))))))
- (write 'b)
- (thread-join! t)) ==> ''unspecified''
- ''after writing'' ab ''or'' ba
-
-NOTE: It is useful to separate thread creation and thread activation to
-avoid the race condition that would occur if the created thread tries to
-examine a table in which the current thread stores the created thread. See
-the last example of {{thread-terminate!}} which contains mutually recursive
-threads.
-
-<procedure>(thread-yield!)</procedure><br>
-
-The current thread exits the running state as if its quantum had expired.
-{{thread-yield!}} returns an unspecified value.
-
-
- ; a busy loop that avoids being too wasteful of the CPU
-
- (let loop ()
- (if (mutex-lock! m 0) ; try to lock m but don't block
- (begin
- (display "locked mutex m")
- (mutex-unlock! m))
- (begin
- (do-something-else)
- (thread-yield!) ; relinquish rest of quantum
- (loop))))
-
-<procedure>(thread-sleep! timeout)</procedure><br>
-
-The current thread waits until the timeout is reached. This blocks the
-thread only if {{timeout}} represents a point in the future. It is an error
-for {{timeout}} to be {{#f}}. {{thread-sleep!}} returns an unspecified
-value.
-
-
- ; a clock with a gradual drift:
-
- (let loop ((x 1))
- (thread-sleep! 1)
- (write x)
- (loop (+ x 1)))
-
- ; a clock with no drift:
-
- (let ((start (time->seconds (current-time)))
- (let loop ((x 1))
- (thread-sleep! (seconds->time (+ x start)))
- (write x)
- (loop (+ x 1))))
-
-<procedure>(thread-terminate! thread)</procedure><br>
-
-Causes an abnormal termination of the {{thread}}. If the {{thread}}
-is not already terminated, all mutexes owned by the {{thread}} become
-unlocked/abandoned and a "terminated thread exception" object is stored in
-the {{thread}}'s end-exception field. If {{thread}} is the current thread,
-{{thread-terminate!}} does not return. Otherwise {{thread-terminate!}}
-returns an unspecified value; the termination of the {{thread}} will occur
-before {{thread-terminate!}} returns.
-
-
- (thread-terminate! (current-thread)) ==> ''does not return''
-
- (define (amb thunk1 thunk2)
- (let ((result #f)
- (result-mutex (make-mutex))
- (done-mutex (make-mutex)))
- (letrec ((child1
- (make-thread
- (lambda ()
- (let ((x (thunk1)))
- (mutex-lock! result-mutex #f #f)
- (set! result x)
- (thread-terminate! child2)
- (mutex-unlock! done-mutex)))))
- (child2
- (make-thread
- (lambda ()
- (let ((x (thunk2)))
- (mutex-lock! result-mutex #f #f)
- (set! result x)
- (thread-terminate! child1)
- (mutex-unlock! done-mutex))))))
- (mutex-lock! done-mutex #f #f)
- (thread-start! child1)
- (thread-start! child2)
- (mutex-lock! done-mutex #f #f)
- result)))
-
-
-NOTE: This operation must be used carefully because it terminates a
-thread abruptly and it is impossible for that thread to perform any kind
-of cleanup. This may be a problem if the thread is in the middle of a
-critical section where some structure has been put in an inconsistent
-state. However, another thread attempting to enter this critical
-section will raise an "abandoned mutex exception" because the mutex is
-unlocked/abandoned. This helps avoid observing an inconsistent state. Clean
-termination can be obtained by polling, as shown in the example below.
-
-
- (define (spawn thunk)
- (let ((t (make-thread thunk)))
- (thread-specific-set! t #t)
- (thread-start! t)
- t))
-
- (define (stop! thread)
- (thread-specific-set! thread #f)
- (thread-join! thread))
-
- (define (keep-going?)
- (thread-specific (current-thread)))
-
- (define count!
- (let ((m (make-mutex))
- (i 0))
- (lambda ()
- (mutex-lock! m)
- (let ((x (+ i 1)))
- (set! i x)
- (mutex-unlock! m)
- x))))
-
- (define (increment-forever!)
- (let loop () (count!) (if (keep-going?) (loop))))
-
- (let ((t1 (spawn increment-forever!))
- (t2 (spawn increment-forever!)))
- (thread-sleep! 1)
- (stop! t1)
- (stop! t2)
- (count!)) ==> 377290
-
-<procedure>(thread-join! thread [timeout [timeout-val]])</procedure><br>
-
-The current thread waits until the {{thread}} terminates (normally or
-not) or until the timeout is reached if {{timeout}} is supplied. If the
-timeout is reached, {{thread-join!}} returns {{timeout-val}} if it is
-supplied, otherwise a "join timeout exception" is raised. If the {{thread}}
-terminated normally, the content of the end-result field is returned,
-otherwise the content of the end-exception field is raised.
-
-
- (let ((t (thread-start! (make-thread (lambda () (expt 2 100))))))
- (do-something-else)
- (thread-join! t)) ==> 1267650600228229401496703205376
-
- (let ((t (thread-start! (make-thread (lambda () (raise 123))))))
- (do-something-else)
- (with-exception-handler
- (lambda (exc)
- (if (uncaught-exception? exc)
- (* 10 (uncaught-exception-reason exc))
- 99999))
- (lambda ()
- (+ 1 (thread-join! t))))) ==> 1231
-
- (define thread-alive?
- (let ((unique (list 'unique)))
- (lambda (thread)
- ; Note: this procedure raises an exception if
- ; the thread terminated abnormally.
- (eq? (thread-join! thread 0 unique) unique))))
-
- (define (wait-for-termination! thread)
- (let ((eh (current-exception-handler)))
- (with-exception-handler
- (lambda (exc)
- (if (not (or (terminated-thread-exception? exc)
- (uncaught-exception? exc)))
- (eh exc))) ; unexpected exceptions are handled by eh
- (lambda ()
- ; The following call to thread-join! will wait until the
- ; thread terminates. If the thread terminated normally
- ; thread-join! will return normally. If the thread
- ; terminated abnormally then one of these two exceptions
- ; is raised by thread-join!:
- ; - terminated thread exception
- ; - uncaught exception
- (thread-join! thread)
- #f)))) ; ignore result of thread-join!
-
-<procedure>(mutex? obj)</procedure><br>
-
-Returns {{#t}} if {{obj}} is a mutex, otherwise returns {{#f}}.
-
-
- (mutex? (make-mutex)) ==> #t
- (mutex? 'foo) ==> #f
-
-<procedure>(make-mutex [name])</procedure><br>
-
-Returns a new mutex in the unlocked/not-abandoned state. The optional
-{{name}} is an arbitrary Scheme object which identifies the mutex (useful
-for debugging); it defaults to an unspecified value. The mutex's specific
-field is set to an unspecified value.
-
-
- (make-mutex) ==> ''an unlocked/not-abandoned mutex''
- (make-mutex 'foo) ==> ''an unlocked/not-abandoned mutex named'' foo
-
-
-<procedure>(mutex-name mutex)</procedure><br>
-
-Returns the name of the {{mutex}}.
-
-
- (mutex-name (make-mutex 'foo)) ==> foo
-
-
-<procedure>(mutex-specific mutex)</procedure><br>
-
-Returns the content of the {{mutex}}'s specific field.
-
-<procedure>(mutex-specific-set! mutex obj)</procedure><br>
-
-Stores {{obj}} into the {{mutex}}'s specific field. {{mutex-specific-set!}}
-returns an unspecified value.
-
-
- (define m (make-mutex))
- (mutex-specific-set! m "hello") ==> ''unspecified''
-
- (mutex-specific m) ==> "hello"
-
- (define (mutex-lock-recursively! mutex)
- (if (eq? (mutex-state mutex) (current-thread))
- (let ((n (mutex-specific mutex)))
- (mutex-specific-set! mutex (+ n 1)))
- (begin
- (mutex-lock! mutex)
- (mutex-specific-set! mutex 0))))
-
- (define (mutex-unlock-recursively! mutex)
- (let ((n (mutex-specific mutex)))
- (if (= n 0)
- (mutex-unlock! mutex)
- (mutex-specific-set! mutex (- n 1)))))
-
-<procedure>(mutex-state mutex)</procedure><br>
-
-Returns information about the state of the {{mutex}}. The possible results
-are:
-
-
-* '''thread T''': the {{mutex}} is in the locked/owned state and thread T is
the owner of the {{mutex}}
-* '''symbol {{not-owned}}''': the {{mutex}} is in the locked/not-owned state
-* '''symbol {{abandoned}}''': the {{mutex}} is in the unlocked/abandoned state
-* '''symbol {{not-abandoned}}''': the {{mutex}} is in the
unlocked/not-abandoned state
-
-
- (mutex-state (make-mutex)) ==> not-abandoned
-
- (define (thread-alive? thread)
- (let ((mutex (make-mutex)))
- (mutex-lock! mutex #f thread)
- (let ((state (mutex-state mutex)))
- (mutex-unlock! mutex) ; avoid space leak
- (eq? state thread))))
-
-<procedure>(mutex-lock! mutex [timeout [thread]])</procedure><br>
-
-If the {{mutex}} is currently locked, the current thread waits until the
-{{mutex}} is unlocked, or until the timeout is reached if {{timeout}}
-is supplied. If the timeout is reached, {{mutex-lock!}} returns {{#f}}.
-Otherwise, the state of the {{mutex}} is changed as follows:
-
-
-* if {{thread}} is {{#f}} the {{mutex}} becomes locked/not-owned,
-* otherwise, let T be {{thread}} (or the current thread if {{thread}} is not
supplied),
-** if T is terminated the {{mutex}} becomes unlocked/abandoned,
-** otherwise {{mutex}} becomes locked/owned with T as the owner.
-
-After changing the state of the {{mutex}}, an "abandoned mutex exception"
-is raised if the {{mutex}} was unlocked/abandoned before the state change,
-otherwise {{mutex-lock!}} returns {{#t}}. It is not an error if the
-{{mutex}} is owned by the current thread (but the current thread will have
-to wait).
-
-
- ; an implementation of a mailbox object of depth one; this
- ; implementation does not behave well in the presence of forced
- ; thread terminations using thread-terminate! (deadlock can occur
- ; if a thread is terminated in the middle of a put! or get! operation)
-
- (define (make-empty-mailbox)
- (let ((put-mutex (make-mutex)) ; allow put! operation
- (get-mutex (make-mutex))
- (cell #f))
-
- (define (put! obj)
- (mutex-lock! put-mutex #f #f) ; prevent put! operation
- (set! cell obj)
- (mutex-unlock! get-mutex)) ; allow get! operation
-
- (define (get!)
- (mutex-lock! get-mutex #f #f) ; wait until object in mailbox
- (let ((result cell))
- (set! cell #f) ; prevent space leaks
- (mutex-unlock! put-mutex) ; allow put! operation
- result))
-
- (mutex-lock! get-mutex #f #f) ; prevent get! operation
-
- (lambda (msg)
- (case msg
- ((put!) put!)
- ((get!) get!)
- (else (error "unknown message"))))))
-
- (define (mailbox-put! m obj) ((m 'put!) obj))
- (define (mailbox-get! m) ((m 'get!)))
-
- ; an alternate implementation of thread-sleep!
-
- (define (sleep! timeout)
- (let ((m (make-mutex)))
- (mutex-lock! m #f #f)
- (mutex-lock! m timeout #f)))
-
- ; a procedure that waits for one of two mutexes to unlock
-
- (define (lock-one-of! mutex1 mutex2)
- ; this procedure assumes that neither mutex1 or mutex2
- ; are owned by the current thread
- (let ((ct (current-thread))
- (done-mutex (make-mutex)))
- (mutex-lock! done-mutex #f #f)
- (let ((t1 (thread-start!
- (make-thread
- (lambda ()
- (mutex-lock! mutex1 #f ct)
- (mutex-unlock! done-mutex)))))
- (t2 (thread-start!
- (make-thread
- (lambda ()
- (mutex-lock! mutex2 #f ct)
- (mutex-unlock! done-mutex))))))
- (mutex-lock! done-mutex #f #f)
- (thread-terminate! t1)
- (thread-terminate! t2)
- (if (eq? (mutex-state mutex1) ct)
- (begin
- (if (eq? (mutex-state mutex2) ct)
- (mutex-unlock! mutex2)) ; don't lock both
- mutex1)
- mutex2))))
-
-<procedure>(mutex-unlock! mutex [condition-variable [timeout]])</procedure><br>
-
-Unlocks the {{mutex}} by making it unlocked/not-abandoned. It is not an
-error to unlock an unlocked mutex and a mutex that is owned by any thread.
-If {{condition-variable}} is supplied, the current thread is blocked
-and added to the {{condition-variable}} before unlocking {{mutex}}; the
-thread can unblock at any time but no later than when an appropriate call
-to {{condition-variable-signal!}} or {{condition-variable-broadcast!}}
-is performed (see below), and no later than the timeout (if {{timeout}}
-is supplied). If there are threads waiting to lock this {{mutex}},
-the scheduler selects a thread, the mutex becomes locked/owned or
-locked/not-owned, and the thread is unblocked. {{mutex-unlock!}} returns
-{{#f}} when the timeout is reached, otherwise it returns {{#t}}.
-
-NOTE: The reason the thread can unblock at any time (when
-{{condition-variable}} is supplied) is to allow extending this SRFI with
-primitives that force a specific blocked thread to become runnable. For
-example a primitive to interrupt a thread so that it performs a certain
-operation, whether the thread is blocked or not, may be useful to handle
-the case where the scheduler has detected a serious problem (such as a
-deadlock) and it must unblock one of the threads (such as the primordial
-thread) so that it can perform some appropriate action. After a thread
-blocked on a condition-variable has handled such an interrupt it would be
-wrong for the scheduler to return the thread to the blocked state, because
-any calls to {{condition-variable-broadcast!}} during the interrupt will
-have gone unnoticed. It is necessary for the thread to remain runnable and
-return from the call to {{mutex-unlock!}} with a result of {{#t}}.
-
-NOTE: {{mutex-unlock!}} is related to the "wait" operation on condition
-variables available in other thread systems. The main difference is that
-"wait" automatically locks {{mutex}} just after the thread is unblocked.
-This operation is not performed by {{mutex-unlock!}} and so must be
-done by an explicit call to {{mutex-lock!}}. This has the advantages
-that a different timeout and exception handler can be specified on the
-{{mutex-lock!}} and {{mutex-unlock!}} and the location of all the mutex
-operations is clearly apparent. A typical use with a condition variable is:
-
-
- (let loop ()
- (mutex-lock! m)
- (if (condition-is-true?)
- (begin
- (do-something-when-condition-is-true)
- (mutex-unlock! m))
- (begin
- (mutex-unlock! m cv)
- (loop))))
-
-<procedure>(condition-variable? obj)</procedure><br>
-
-Returns {{#t}} if {{obj}} is a condition variable, otherwise returns
-{{#f}}.
-
-
- (condition-variable? (make-condition-variable)) ==> #t
- (condition-variable? 'foo) ==> #f
-
-<procedure>(make-condition-variable [name])</procedure><br>
-
-Returns a new empty condition variable. The optional {{name}} is an
-arbitrary Scheme object which identifies the condition variable (useful for
-debugging); it defaults to an unspecified value. The condition variable's
-specific field is set to an unspecified value.
-
-
- (make-condition-variable) ==> ''an empty condition variable''
-
-<procedure>(condition-variable-name condition-variable)</procedure><br>
-
-Returns the name of the {{condition-variable}}.
-
-
- (condition-variable-name (make-condition-variable 'foo)) ==> foo
-
-<procedure>(condition-variable-specific condition-variable)</procedure><br>
-
-Returns the content of the {{condition-variable}}'s specific field.
-
-<procedure>(condition-variable-specific-set! condition-variable
obj)</procedure><br>
-
-Stores {{obj}} into the {{condition-variable}}'s specific field.
-{{condition-variable-specific-set!}} returns an unspecified value.
-
-
- (define cv (make-condition-variable))
- (condition-variable-specific-set! cv "hello") ==> ''unspecified''
-
- (condition-variable-specific cv) ==> "hello"
-
-<procedure>(condition-variable-signal! condition-variable)</procedure><br>
-
-If there are threads blocked on the {{condition-variable}}, the scheduler
-selects a thread and unblocks it. {{condition-variable-signal!}} returns an
-unspecified value.
-
-
- ; an implementation of a mailbox object of depth one; this
- ; implementation behaves gracefully when threads are forcibly
- ; terminated using thread-terminate! (the "abandoned mutex"
- ; exception will be raised when a put! or get! operation is attempted
- ; after a thread is terminated in the middle of a put! or get!
- ; operation)
-
- (define (make-empty-mailbox)
- (let ((mutex (make-mutex))
- (put-condvar (make-condition-variable))
- (get-condvar (make-condition-variable))
- (full? #f)
- (cell #f))
-
- (define (put! obj)
- (mutex-lock! mutex)
- (if full?
- (begin
- (mutex-unlock! mutex put-condvar)
- (put! obj))
- (begin
- (set! cell obj)
- (set! full? #t)
- (condition-variable-signal! get-condvar)
- (mutex-unlock! mutex))))
-
- (define (get!)
- (mutex-lock! mutex)
- (if (not full?)
- (begin
- (mutex-unlock! mutex get-condvar)
- (get!))
- (let ((result cell))
- (set! cell #f) ; avoid space leaks
- (set! full? #f)
- (condition-variable-signal! put-condvar)
- (mutex-unlock! mutex))))
-
- (lambda (msg)
- (case msg
- ((put!) put!)
- ((get!) get!)
- (else (error "unknown message"))))))
-
- (define (mailbox-put! m obj) ((m 'put!) obj))
- (define (mailbox-get! m) ((m 'get!)))
-
-<procedure>(condition-variable-broadcast! condition-variable)</procedure><br>
-
-Unblocks all the threads blocked on the {{condition-variable}}.
-{{condition-variable-broadcast!}} returns an unspecified value.
-
-
- (define (make-semaphore n)
- (vector n (make-mutex) (make-condition-variable)))
-
- (define (semaphore-wait! sema)
- (mutex-lock! (vector-ref sema 1))
- (let ((n (vector-ref sema 0)))
- (if (> n 0)
- (begin
- (vector-set! sema 0 (- n 1))
- (mutex-unlock! (vector-ref sema 1)))
- (begin
- (mutex-unlock! (vector-ref sema 1) (vector-ref sema 2))
- (semaphore-wait! sema))))
-
- (define (semaphore-signal-by! sema increment)
- (mutex-lock! (vector-ref sema 1))
- (let ((n (+ (vector-ref sema 0) increment)))
- (vector-set! sema 0 n)
- (if (> n 0)
- (condition-variable-broadcast! (vector-ref sema 2)))
- (mutex-unlock! (vector-ref sema 1))))
-
-<procedure>(current-time)</procedure><br>
-
-Returns the time object corresponding to the current time.
-
-
- (current-time) ==> ''a time object''
-
-<procedure>(time? obj)</procedure><br>
-
-Returns {{#t}} if {{obj}} is a time object, otherwise returns {{#f}}.
-
-
- (time? (current-time)) ==> #t
- (time? 123) ==> #f
-
-<procedure>(time->seconds time)</procedure><br>
-
-Converts the time object {{time}} into an exact or inexact real number
-representing the number of seconds elapsed since some implementation
-dependent reference point.
-
-
- (time->seconds (current-time)) ==> 955039784.928075
-
-<procedure>(seconds->time x)</procedure><br>
-
-Converts into a time object the exact or inexact real number {{x}}
-representing the number of seconds elapsed since some implementation
-dependent reference point.
-
-
- (seconds->time (+ 10 (time->seconds (current-time)))
- ==> ''a time object representing 10 seconds in the future''
-
-
-<procedure>(current-exception-handler)</procedure><br>
-
-Returns the current exception handler.
-
-
- (current-exception-handler) ==> ''a procedure''
-
-<procedure>(with-exception-handler handler thunk)</procedure><br>
-
-Returns the result(s) of calling {{thunk}} with no arguments. The
-{{handler}}, which must be a procedure, is installed as the current
-exception handler in the dynamic environment in effect during the call to
-{{thunk}}.
-
-
- (with-exception-handler
- list
- current-exception-handler) ==> ''the procedure'' list
-
-<procedure>(raise obj)</procedure><br>
-
-Calls the current exception handler with {{obj}} as the single argument.
-{{obj}} may be any Scheme object.
-
-
- (define (f n)
- (if (< n 0) (raise "negative arg") (sqrt n))))
-
- (define (g)
- (call-with-current-continuation
- (lambda (return)
- (with-exception-handler
- (lambda (exc)
- (return
- (if (string? exc)
- (string-append "error: " exc)
- "unknown error")))
- (lambda ()
- (write (f 4.))
- (write (f -1.))
- (write (f 9.)))))))
-
- (g) ==> ''writes'' 2. ''and returns'' "error: negative arg"
-
-
-<procedure>(join-timeout-exception? obj)</procedure><br>
-
-Returns {{#t}} if {{obj}} is a "join timeout exception" object, otherwise
-returns {{#f}}. A join timeout exception is raised when {{thread-join!}} is
-called, the timeout is reached and no {{timeout-val}} is supplied.
-
-<procedure>(abandoned-mutex-exception? obj)</procedure><br>
-
-Returns {{#t}} if {{obj}} is an "abandoned mutex exception" object,
-otherwise returns {{#f}}. An abandoned mutex exception is raised when the
-current thread locks a mutex that was owned by a thread which terminated
-(see {{mutex-lock!}}).
-
-<procedure>(terminated-thread-exception? obj)</procedure><br>
-
-Returns {{#t}} if {{obj}} is a "terminated thread exception" object,
-otherwise returns {{#f}}. A terminated thread exception is raised when
-{{thread-join!}} is called and the target thread has terminated as a result
-of a call to {{thread-terminate!}}.
-
-<procedure>(uncaught-exception? obj)</procedure><br>
-
-Returns {{#t}} if {{obj}} is an "uncaught exception" object, otherwise
-returns {{#f}}. An uncaught exception is raised when {{thread-join!}} is
-called and the target thread has terminated because it raised an exception
-that called the initial exception handler of that thread.
-
-<procedure>(uncaught-exception-reason exc)</procedure><br>
-
-{{exc}} must be an "uncaught exception" object.
-{{uncaught-exception-reason}} returns the object which was passed to the
-initial exception handler of that thread.
-
-
----
-Previous: [[Unit srfi-14]]
-
-Next: [[Unit srfi-69]]
diff --git a/manual/Unit srfi-69 b/manual/Unit srfi-69
deleted file mode 100644
index 44da7d3..0000000
--- a/manual/Unit srfi-69
+++ /dev/null
@@ -1,395 +0,0 @@
-[[tags: manual]]
-[[toc:]]
-
-== Unit srfi-69
-
-CHICKEN implements SRFI 69 with SRFI 90 extensions. For more information, see
-[[http://srfi.schemers.org/srfi-69/srfi-69.html|SRFI-69]] and
-[[http://srfi.schemers.org/srfi-90/srfi-90.html|SRFI-90]].
-
-
-=== Hash Table Procedures
-
-
-==== make-hash-table
-
-<procedure>(make-hash-table [TEST HASH SIZE] [#:test TEST] [#:hash HASH]
[#:size SIZE] [#:initial INITIAL] [#:min-load MIN-LOAD] [#:max-load MAX-LOAD]
[#:weak-keys WEAK-KEYS] [#:weak-values WEAK-VALUES])</procedure>
-
-Returns a new {{HASH-TABLE}} with the supplied configuration.
-
-; {{TEST}} : The equivalence function.
-; {{HASH}} : The hash function.
-; {{SIZE}} : The expected number of table elements.
-; {{INITIAL}} : The default initial value.
-; {{MIN-LOAD}} : The minimum load factor. A {{flonum}} in (0.0 1.0).
-; {{MAX-LOAD}} : The maximum load factor. A {{flonum}} in (0.0 1.0).
-; {{WEAK-KEYS}} : Use weak references for keys. (Ignored)
-; {{WEAK-VALUES}} : Use weak references for values. (Ignored)
-
-Please note that hash tables are ''not'' guaranteed to compare {{equal?}}
-to each other, even if they contain exactly the same key/value pairs.
-
-
-==== alist->hash-table
-
-<procedure>(alist->hash-table A-LIST [#:test TEST] [#:hash HASH] [#:size SIZE]
[#:initial INITIAL] [#:min-load MIN-LOAD] [#:max-load MAX-LOAD] [#:weak-keys
WEAK-KEYS] [#:weak-values WEAK-VALUES])</procedure>
-
-Returns a new {{HASH-TABLE}}. The {{HASH-TABLE}} is populated from the
-{{A-LIST}}. The keyword arguments are per {{make-hash-table}}.
-
-
-==== hash-table?
-
-<procedure>(hash-table? OBJECT)</procedure>
-
-Is the {{OBJECT}} a {{hash-table}}?
-
-
-==== hash-table-size
-
-<procedure>(hash-table-size HASH-TABLE)</procedure>
-
-The {{HASH-TABLE}} size.
-
-
-==== hash-table-equivalence-function
-
-<procedure>(hash-table-equivalence-function HASH-TABLE)</procedure>
-
-The {{HASH-TABLE}} {{equivalence-function}}.
-
-
-==== hash-table-hash-function
-
-<procedure>(hash-table-hash-function HASH-TABLE)</procedure>
-
-The {{HASH-TABLE}} {{hash-function}}.
-
-
-==== hash-table-min-load
-
-<procedure>(hash-table-min-load HASH-TABLE)</procedure>
-
-The {{HASH-TABLE}} minimum load factor.
-
-
-==== hash-table-max-load
-
-<procedure>(hash-table-max-load HASH-TABLE)</procedure>
-
-The {{HASH-TABLE}} maximum load factor.
-
-
-==== hash-table-weak-keys
-
-<procedure>(hash-table-weak-keys HASH-TABLE)</procedure>
-
-Does the {{HASH-TABLE}} use weak references for keys?
-
-
-==== hash-table-weak-values
-
-<procedure>(hash-table-weak-values HASH-TABLE)</procedure>
-
-Does the {{HASH-TABLE}} use weak references for values?
-
-
-==== hash-table-has-initial?
-
-<procedure>(hash-table-has-initial? HASH-TABLE)</procedure>
-
-Does the {{HASH-TABLE}} have a default initial value?
-
-
-==== hash-table-initial
-
-<procedure>(hash-table-initial HASH-TABLE)</procedure>
-
-The {{HASH-TABLE}} default initial value.
-
-
-==== hash-table-keys
-
-<procedure>(hash-table-keys HASH-TABLE)</procedure>
-
-Returns a list of the keys in the {{HASH-TABLE}} population.
-
-
-==== hash-table-values
-
-<procedure>(hash-table-values HASH-TABLE)</procedure>
-
-Returns a list of the values in the {{HASH-TABLE}} population.
-
-
-==== hash-table->alist
-
-<procedure>(hash-table->alist HASH-TABLE)</procedure>
-
-Returns the population of the {{HASH-TABLE}} as an {{a-list}}.
-
-
-
-==== hash-table-ref
-
-<procedure>(hash-table-ref HASH-TABLE KEY)</procedure>
-
-Returns the {{VALUE}} for the {{KEY}} in the {{HASH-TABLE}}.
-
-Aborts with an exception when the {{KEY}} is missing.
-
-
-==== hash-table-ref/default
-
-<procedure>(hash-table-ref/default HASH-TABLE KEY DEFAULT)</procedure>
-
-Returns the {{VALUE}} for the {{KEY}} in the {{HASH-TABLE}}, or the {{DEFAULT}}
-when the {{KEY}} is missing.
-
-
-==== hash-table-exists?
-
-<procedure>(hash-table-exists? HASH-TABLE KEY)</procedure>
-
-Does the {{KEY}} exist in the {{HASH-TABLE}}?
-
-
-==== hash-table-set!
-
-<procedure>(hash-table-set! HASH-TABLE KEY VALUE)</procedure>
-
-Set the {{VALUE}} for the {{KEY}} in the {{HASH-TABLE}}.
-
-A setter for {{hash-table-ref}} is defined, so
-
-<enscript highlight=scheme>
-(set! (hash-table-ref HASH-TABLE KEY) VALUE)
-</enscript>
-
-is equivalent to
-
-<enscript highlight=scheme>
-(hash-table-set! HASH-TABLE KEY VALUE)
-</enscript>
-
-
-==== hash-table-update!
-
-<procedure>(hash-table-update! HASH-TABLE KEY [UPDATE-FUNCTION
[DEFAULT-VALUE-FUNCTION]])</procedure>
-
-Sets or replaces the {{VALUE}} for {{KEY}} in the {{HASH-TABLE}}.
-
-The {{UPDATE-FUNCTION}} takes the existing {{VALUE}} for {{KEY}} and returns
-the new {{VALUE}}. The default is {{identity}}
-
-The {{DEFAULT-VALUE-FUNCTION}} is called when the entry for {{KEY}} is missing.
-The default uses the {{(hash-table-initial-value)}}, if provided. Otherwise
-aborts with an exception.
-
-Returns the new {{VALUE}}.
-
-
-==== hash-table-update!/default
-
-<procedure>(hash-table-update!/default HASH-TABLE KEY UPDATE-FUNCTION
DEFAULT-VALUE)</procedure>
-
-Sets or replaces the {{VALUE}} for {{KEY}} in the {{HASH-TABLE}}.
-
-The {{UPDATE-FUNCTION}} takes the existing {{VALUE}} for {{KEY}} and returns
-the new {{VALUE}}.
-
-The {{DEFAULT-VALUE}} is used when the entry for {{KEY}} is missing.
-
-Returns the new {{VALUE}}.
-
-
-==== hash-table-copy
-
-<procedure>(hash-table-copy HASH-TABLE)</procedure>
-
-Returns a shallow copy of the {{HASH-TABLE}}.
-
-
-==== hash-table-delete!
-
-<procedure>(hash-table-delete! HASH-TABLE KEY)</procedure>
-
-Deletes the entry for {{KEY}} in the {{HASH-TABLE}}.
-
-
-==== hash-table-remove!
-
-<procedure>(hash-table-remove! HASH-TABLE PROC)</procedure>
-
-Calls {{PROC}} for all entries in {{HASH-TABLE}} with the key and value of each
-entry. If {{PROC}} returns true, then that entry is removed.
-
-
-==== hash-table-clear!
-
-<procedure>(hash-table-clear! HASH-TABLE)</procedure>
-
-Deletes all entries in {{HASH-TABLE}}.
-
-
-==== hash-table-merge
-
-<procedure>(hash-table-merge HASH-TABLE-1 HASH-TABLE-2)</procedure>
-
-Returns a new {{HASH-TABLE}} with the union of {{HASH-TABLE-1}} and
-{{HASH-TABLE-2}}.
-
-
-==== hash-table-merge!
-
-<procedure>(hash-table-merge! HASH-TABLE-1 HASH-TABLE-2)</procedure>
-
-Returns {{HASH-TABLE-1}} as the union of {{HASH-TABLE-1}} and
-{{HASH-TABLE-2}}.
-
-
-==== hash-table-map
-
-<procedure>(hash-table-map HASH-TABLE FUNC)</procedure>
-
-Calls {{FUNC}} for all entries in {{HASH-TABLE}} with the key and value of each
-entry.
-
-Returns a list of the results of each call.
-
-
-==== hash-table-fold
-
-<procedure>(hash-table-fold HASH-TABLE FUNC INIT)</procedure>
-
-Calls {{FUNC}} for all entries in {{HASH-TABLE}} with the key and value of each
-entry, and the current folded value. The initial folded value is {{INIT}}.
-
-Returns the final folded value.
-
-
-==== hash-table-for-each
-
-<procedure>(hash-table-for-each HASH-TABLE PROC)</procedure>
-
-Calls {{PROC}} for all entries in {{HASH-TABLE}} with the key and value of each
-entry.
-
-
-==== hash-table-walk
-
-<procedure>(hash-table-walk HASH-TABLE PROC)</procedure>
-
-Calls {{PROC}} for all entries in {{HASH-TABLE}} with the key and value of each
-entry.
-
-
-=== Hashing Functions
-
-All hash functions return a {{fixnum}} in the range [0 {{BOUND}}).
-
-When given the fixnum RANDOMIZATION, these functions will use this
-to perturb the value; if not specified, the value will differ for
-each invocation of your program. This is for security reasons; an
-attacker who knows what a value hashes to can deliberately try to
-cause collisions, thereby flattening your hash table, effectively
-reducing it to a list. Always make sure you don't expose any
-hashed value to an attacker.
-
-
-==== number-hash
-
-<procedure>(number-hash NUMBER [BOUND RANDOMIZATION])</procedure>
-
-For use with {{=}} as a {{hash-table-equivalence-function}}.
-
-
-==== object-uid-hash
-
-<procedure>(object-uid-hash OBJECT [BOUND RANDOMIZATION])</procedure>
-
-Currently a synonym for {{equal?-hash}}.
-
-
-==== symbol-hash
-
-<procedure>(symbol-hash SYMBOL [BOUND RANDOMIZATION])</procedure>
-
-For use with {{eq?}} as a {{hash-table-equivalence-function}}.
-
-
-==== keyword-hash
-
-<procedure>(keyword-hash KEYWORD [BOUND RANDOMIZATION])</procedure>
-
-For use with {{eq?}} as a {{hash-table-equivalence-function}}.
-
-
-==== string-hash
-
-<procedure>(string-hash STRING [BOUND START END RANDOMIZATION])</procedure>
-
-For use with {{string=?}} as a {{hash-table-equivalence-function}}.
-The optional {{START}} and {{END}} arguments may be given to limit
-the hash calculation to a specific sub-section of {{STRING}}.
-
-
-==== string-ci-hash
-
-<procedure>(string-hash-ci STRING [BOUND START END
RANDOMIZATION])</procedure><br>
-<procedure>(string-ci-hash STRING [BOUND START END RANDOMIZATION])</procedure>
-
-For use with {{string-ci=?}} as a {{hash-table-equivalence-function}}.
-
-
-==== eq?-hash
-
-<procedure>(eq?-hash OBJECT [BOUND RANDOMIZATION])</procedure>
-
-For use with {{eq?}} as a {{hash-table-equivalence-function}}.
-
-
-==== eqv?-hash
-
-<procedure>(eqv?-hash OBJECT [BOUND RANDOMIZATION])</procedure>
-
-For use with {{eqv?}} as a {{hash-table-equivalence-function}}.
-
-
-==== equal?-hash
-
-<procedure>(equal?-hash OBJECT [BOUND RANDOMIZATION])</procedure>
-
-For use with {{equal?}} as a {{hash-table-equivalence-function}}.
-
-
-==== hash
-
-<procedure>(hash OBJECT [BOUND RANDOMIZATION])</procedure>
-
-Synonym for {{equal?-hash}}.
-
-
-==== hash-by-identity
-
-<procedure>(hash-by-identity OBJECT [BOUND RANDOMIZATION])</procedure>
-
-Synonym for {{eq?-hash}}.
-
-
-=== recursive-hash-max-depth
-
-<parameter>(recursive-hash-max-depth)</parameter>
-
-The maximum structure depth to follow when computing a hash value. The default
is {{4}}.
-
-
-=== recursive-hash-max-length
-
-<parameter>(recursive-hash-max-length)</parameter>
-
-The maximum vector length to follow when computing a hash value. The default
is {{4}}.
-
-Previous: [[Unit srfi-18]]
-Next: [[Unit posix]]
-
diff --git a/manual/faq b/manual/faq
index 18f79c9..a32136a 100644
--- a/manual/faq
+++ b/manual/faq
@@ -104,7 +104,7 @@ For a different approach to concurrency, please see the
The system does not directly support Unicode, but there is an extension for
UTF-8 strings: [[http://wiki.call-cc.org/egg/utf8|utf8]].
-=== Why are `dynamic-wind' thunks not executed when a SRFI-18 thread signals
an error?
+=== Why are `dynamic-wind' thunks not executed when a thread signals an error?
Here is what Marc Feeley, the author of
[[http://srfi.schemers.org/srfi-18|SRFI-18]] has to
say about this subject:
@@ -321,20 +321,20 @@ the file containing the sharp-comma form, like this:
(print #,(integer->char 33))
</enscript>
-==== Why do built-in units, such as srfi-1, srfi-18, and posix fail to load?
+==== Why do built-in units, such as srfi-1 and posix fail to load?
-When you try to {{use}} a built-in unit such as {{srfi-18}}, you may get the
following error:
+When you try to {{use}} a built-in unit such as {{posix}}, you may get the
following error:
<enscript highlight=scheme>
- #;1> (use srfi-18)
- ; loading library srfi-18 ...
+ #;1> (use posix)
+ ; loading library posix ...
Error: (load-library) unable to load library
- srfi-18
+ posix
"dlopen(libchicken.dylib, 9): image not found" ;; on a Mac
"libchicken.so: cannot open shared object file: No such file or directory"
;; Linux
</enscript>
-Another symptom is that {{(require 'srfi-18)}} will silently fail.
+Another symptom is that {{(require 'posix)}} will silently fail.
This typically happens because the CHICKEN libraries have been installed in a
non-standard location, such as your home directory. The workaround is to
explicitly tell the dynamic linker where to look for your libraries:
diff --git a/rules.make b/rules.make
index 5936e4f..7c4ac10 100644
--- a/rules.make
+++ b/rules.make
@@ -37,7 +37,7 @@ SETUP_API_OBJECTS_1 = setup-api setup-download
LIBCHICKEN_SCHEME_OBJECTS_1 = \
library eval data-structures ports files extras lolevel utils tcp
srfi-1 srfi-4 \
- srfi-14 srfi-18 srfi-69 $(POSIXFILE) irregex scheduler \
+ srfi-14 $(POSIXFILE) irregex scheduler \
profiler stub expand modules chicken-syntax chicken-ffi-syntax
build-version
LIBCHICKEN_OBJECTS_1 = $(LIBCHICKEN_SCHEME_OBJECTS_1) runtime
LIBCHICKEN_SHARED_OBJECTS = $(LIBCHICKEN_OBJECTS_1:=$(O))
@@ -530,8 +530,6 @@ posixunix.c: $(SRCDIR)posixunix.scm
$(SRCDIR)posix-common.scm $(SRCDIR)common-de
$(bootstrap-lib)
posixwin.c: $(SRCDIR)posixwin.scm $(SRCDIR)posix-common.scm
$(SRCDIR)common-declarations.scm
$(bootstrap-lib)
-srfi-69.c: $(SRCDIR)srfi-69.scm $(SRCDIR)common-declarations.scm
- $(bootstrap-lib)
irregex.c: $(SRCDIR)irregex.scm $(SRCDIR)irregex-core.scm
$(SRCDIR)irregex-utils.scm $(SRCDIR)common-declarations.scm
$(bootstrap-lib)
#
@@ -557,8 +555,6 @@ srfi-4.c: $(SRCDIR)srfi-4.scm
$(SRCDIR)common-declarations.scm
$(bootstrap-lib)
srfi-14.c: $(SRCDIR)srfi-14.scm $(SRCDIR)common-declarations.scm
$(bootstrap-lib)
-srfi-18.c: $(SRCDIR)srfi-18.scm $(SRCDIR)common-declarations.scm
- $(bootstrap-lib)
utils.c: $(SRCDIR)utils.scm $(SRCDIR)common-declarations.scm
$(bootstrap-lib)
scheduler.c: $(SRCDIR)scheduler.scm $(SRCDIR)common-declarations.scm
diff --git a/scripts/compile-all b/scripts/compile-all
index 2be1b48..109d93a 100755
--- a/scripts/compile-all
+++ b/scripts/compile-all
@@ -12,7 +12,7 @@ library_options="-optimize-level 2 -include-path .
-include-path ./ -inline -ign
compiler="$1"
shift
-for x in library eval data-structures ports files extras lolevel utils tcp
srfi-1 srfi-4 srfi-14 srfi-18 srfi-69 posixunix posixwin irregex scheduler
profiler stub expand modules chicken-syntax chicken-ffi-syntax build-version; do
+for x in library eval data-structures ports files extras lolevel utils tcp
srfi-1 srfi-4 srfi-14 posixunix posixwin irregex scheduler profiler stub expand
modules chicken-syntax chicken-ffi-syntax build-version; do
$compiler $x.scm $library_options -output-file /tmp/xxx.c "$@"
done
diff --git a/scripts/makedist.scm b/scripts/makedist.scm
index 6108a8e..d3891a1 100644
--- a/scripts/makedist.scm
+++ b/scripts/makedist.scm
@@ -1,7 +1,7 @@
;;;; makedist.scm - Make distribution tarballs
-(use srfi-69 irregex srfi-1 setup-api)
+(use irregex srfi-1 setup-api)
(define *release* #f)
(define *help* #f)
diff --git a/setup.defaults b/setup.defaults
index 88638dd..5d1d149 100644
--- a/setup.defaults
+++ b/setup.defaults
@@ -30,7 +30,7 @@
(data-structures
extras files foreign irregex lolevel ports tcp utils
posix irregex setup-api setup-download
- srfi-1 srfi-4 srfi-14 srfi-18 srfi-69
+ srfi-1 srfi-4 srfi-14
->) )
diff --git a/srfi-18.import.scm b/srfi-18.import.scm
deleted file mode 100644
index 8c6968c..0000000
--- a/srfi-18.import.scm
+++ /dev/null
@@ -1,71 +0,0 @@
-;;;; srfi-18.import.scm - import library for "srfi-18" module
-;
-; Copyright (c) 2008-2014, The CHICKEN Team
-; All rights reserved.
-;
-; Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following
-; conditions are met:
-;
-; Redistributions of source code must retain the above copyright notice,
this list of conditions and the following
-; disclaimer.
-; Redistributions in binary form must reproduce the above copyright notice,
this list of conditions and the following
-; disclaimer in the documentation and/or other materials provided with the
distribution.
-; Neither the name of the author nor the names of its contributors may be
used to endorse or promote
-; products derived from this software without specific prior written
permission.
-;
-; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
AND ANY EXPRESS
-; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
OF MERCHANTABILITY
-; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
COPYRIGHT HOLDERS OR
-; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
EXEMPLARY, OR
-; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
SUBSTITUTE GOODS OR
-; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY
-; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR
-; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
ADVISED OF THE
-; POSSIBILITY OF SUCH DAMAGE.
-
-
-(##sys#register-primitive-module
- 'srfi-18
- '(abandoned-mutex-exception?
- condition-variable-broadcast!
- condition-variable-signal!
- condition-variable-name
- condition-variable-specific
- condition-variable-specific-set!
- condition-variable?
- current-thread
- current-time
- join-timeout-exception?
- make-condition-variable
- make-mutex
- make-thread
- mutex-lock!
- mutex-name
- mutex-specific
- mutex-specific-set!
- mutex-state
- mutex-unlock!
- mutex?
- raise
- seconds->time
- terminated-thread-exception?
- thread-join!
- thread-name
- thread-quantum
- thread-quantum-set!
- thread-resume!
- thread-signal!
- thread-sleep!
- thread-specific
- thread-specific-set!
- thread-start!
- thread-state
- thread-suspend!
- thread-terminate!
- thread-wait-for-i/o!
- thread-yield!
- thread?
- time->seconds
- time?
- uncaught-exception-reason
- uncaught-exception?))
diff --git a/srfi-18.scm b/srfi-18.scm
deleted file mode 100644
index 189ba66..0000000
--- a/srfi-18.scm
+++ /dev/null
@@ -1,461 +0,0 @@
-;;;; srfi-18.scm - Simple thread unit - felix
-;
-; Copyright (c) 2008-2014, The CHICKEN Team
-; Copyright (c) 2000-2007, Felix L. Winkelmann
-; All rights reserved.
-;
-; Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following
-; conditions are met:
-;
-; Redistributions of source code must retain the above copyright notice,
this list of conditions and the following
-; disclaimer.
-; Redistributions in binary form must reproduce the above copyright notice,
this list of conditions and the following
-; disclaimer in the documentation and/or other materials provided with the
distribution.
-; Neither the name of the author nor the names of its contributors may be
used to endorse or promote
-; products derived from this software without specific prior written
permission.
-;
-; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
AND ANY EXPRESS
-; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
OF MERCHANTABILITY
-; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
COPYRIGHT HOLDERS OR
-; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
EXEMPLARY, OR
-; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
SUBSTITUTE GOODS OR
-; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY
-; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR
-; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
ADVISED OF THE
-; POSSIBILITY OF SUCH DAMAGE.
-
-
-(declare
- (unit srfi-18)
- (uses scheduler)
- (disable-interrupts)
- (hide compute-time-limit) )
-
-(include "common-declarations.scm")
-
-(register-feature! 'srfi-18)
-
-(define-syntax dbg
- (syntax-rules ()
- ((_ . _) #f)))
-
-#;(define-syntax dbg
- (syntax-rules ()
- ((_ x ...) (print x ...))))
-
-;;; Helper routines:
-
-(define (compute-time-limit tm loc)
- (cond ((not tm) #f)
- ((##sys#structure? tm 'time) (##sys#slot tm 1))
- ((number? tm) (+ (current-milliseconds) (* tm 1000)))
- (else (##sys#signal-hook #:type-error loc "invalid timeout argument"
tm))))
-
-
-;;; Time objects:
-
-(define (current-time)
- (##sys#make-structure 'time (current-milliseconds)))
-
-(define (time->seconds tm)
- (##sys#check-structure tm 'time 'time->seconds)
- (fp/ (##sys#slot tm 1) 1000.0))
-
-(define (seconds->time n)
- (##sys#check-number n 'seconds->time)
- (##sys#make-structure 'time (fp* (##sys#exact->inexact n) 1000.0)))
-
-(define (time? x) (##sys#structure? x 'time))
-
-
-;;; Exception handling:
-
-(define raise ##sys#signal)
-
-(define (join-timeout-exception? x)
- (and (##sys#structure? x 'condition)
- (memq 'join-timeout-exception (##sys#slot x 1)) ) )
-
-(define (abandoned-mutex-exception? x)
- (and (##sys#structure? x 'condition)
- (memq 'abandoned-mutex-exception (##sys#slot x 1)) ) )
-
-(define (terminated-thread-exception? x)
- (and (##sys#structure? x 'condition)
- (memq 'terminated-thread-exception (##sys#slot x 1)) ) )
-
-(define (uncaught-exception? x)
- (and (##sys#structure? x 'condition)
- (memq 'uncaught-exception (##sys#slot x 1)) ) )
-
-(define uncaught-exception-reason
- (condition-property-accessor 'uncaught-exception 'reason) )
-
-
-;;; Threads:
-
-(define make-thread
- (lambda (thunk . name)
- (let ((thread
- (##sys#make-thread
- #f
- 'created
- (if (pair? name) (##sys#slot name 0) (gensym 'thread))
- (##sys#slot ##sys#current-thread 9) ) ) )
- (##sys#setslot
- thread 1
- (lambda ()
- (##sys#call-with-values
- thunk
- (lambda results
- (##sys#setslot thread 2 results)
- (##sys#thread-kill! thread 'dead)
- (##sys#schedule) ) ) ) )
- thread) ) )
-
-(define (thread? x) (##sys#structure? x 'thread))
-(define (current-thread) ##sys#current-thread)
-
-(define (thread-state thread)
- (##sys#check-structure thread 'thread 'thread-state)
- (##sys#slot thread 3) )
-
-(define (thread-specific-set! thread x)
- (##sys#check-structure thread 'thread 'thread-specific-set!)
- (##sys#setslot thread 10 x) )
-
-(define thread-specific
- (getter-with-setter
- (lambda (thread)
- (##sys#check-structure thread 'thread 'thread-specific)
- (##sys#slot thread 10) )
- thread-specific-set!))
-
-(define (thread-quantum thread)
- (##sys#check-structure thread 'thread 'thread-quantum)
- (##sys#slot thread 9) )
-
-(define (thread-quantum-set! thread q)
- (##sys#check-structure thread 'thread 'thread-quantum-set!)
- (##sys#check-exact q 'thread-quantum-set!)
- (##sys#setislot thread 9 (fxmax q 10)) )
-
-(define (thread-name x)
- (##sys#check-structure x 'thread 'thread-name)
- (##sys#slot x 6) )
-
-(define thread-start!
- (lambda (thread)
- (if (procedure? thread)
- (set! thread (make-thread thread))
- (##sys#check-structure thread 'thread 'thread-start!) )
- (unless (eq? 'created (##sys#slot thread 3))
- (##sys#error 'thread-start! "thread cannot be started a second time"
thread) )
- (##sys#setslot thread 3 'ready)
- (##sys#add-to-ready-queue thread)
- thread) )
-
-(define thread-yield! ##sys#thread-yield!) ;In library.scm
-
-(define thread-join!
- (lambda (thread . timeout)
- (##sys#check-structure thread 'thread 'thread-join!)
- (let* ((limit (and (pair? timeout)
- (compute-time-limit (##sys#slot timeout 0)
'thread-join!)))
- (rest (and (pair? timeout) (##sys#slot timeout 1)))
- (tosupplied (and rest (pair? rest)))
- (toval (and tosupplied (##sys#slot rest 0))) )
- (##sys#call-with-current-continuation
- (lambda (return)
- (let ((ct ##sys#current-thread))
- (when limit (##sys#thread-block-for-timeout! ct limit))
- (##sys#setslot
- ct 1
- (lambda ()
- (case (##sys#slot thread 3)
- ((dead)
- (unless (##sys#slot ct 13) ; not unblocked by timeout
- (##sys#remove-from-timeout-list ct))
- (apply return (##sys#slot thread 2)))
- ((terminated)
- (return
- (##sys#signal
- (##sys#make-structure
- 'condition '(uncaught-exception)
- (list '(uncaught-exception . reason) (##sys#slot thread 7))
) ) ) )
- ((blocked ready)
- (if limit
- (return
- (if tosupplied
- toval
- (##sys#signal
- (##sys#make-structure 'condition
'(join-timeout-exception) '())) ) )
- (##sys#thread-block-for-termination! ct thread) ) )
- (else
- (##sys#error 'thread-join!
- "Internal scheduler error: unknown thread state:
"
- ct (##sys#slot thread 3)) ) ) ) )
- (##sys#thread-block-for-termination! ct thread)
- (##sys#schedule) ) ) ) ) ) )
-
-(define (thread-terminate! thread)
- (##sys#check-structure thread 'thread 'thread-terminate!)
- (when (eq? thread ##sys#primordial-thread)
- ((##sys#exit-handler)) )
- (##sys#setslot thread 2 (list (##core#undefined)))
- (##sys#setslot thread 7 (##sys#make-structure 'condition
'(terminated-thread-exception) '()))
- (##sys#thread-kill! thread 'terminated)
- (when (eq? thread ##sys#current-thread) (##sys#schedule)) )
-
-(define (thread-suspend! thread)
- (##sys#check-structure thread 'thread 'thread-suspend!)
- (##sys#setslot thread 3 'suspended)
- (when (eq? thread ##sys#current-thread) ;XXX what if thread is ready or
blocked?
- (##sys#call-with-current-continuation
- (lambda (return)
- (##sys#setslot thread 1 (lambda () (return (##core#undefined))))
- (##sys#schedule) ) ) ) )
-
-(define (thread-resume! thread)
- (##sys#check-structure thread 'thread 'thread-resume!)
- (when (eq? (##sys#slot thread 3) 'suspended) ;XXX what if thread is ready or
blocked?
- (##sys#setslot thread 3 'ready)
- (##sys#add-to-ready-queue thread) ) )
-
-(define (thread-sleep! tm)
- (define (sleep limit)
- (##sys#call-with-current-continuation
- (lambda (return)
- (let ((ct ##sys#current-thread))
- (##sys#setslot ct 1 (lambda () (return (##core#undefined))))
- (##sys#thread-block-for-timeout! ct limit)
- (##sys#schedule) ) ) ) )
- (unless tm (##sys#signal-hook #:type-error 'thread-sleep! "invalid timeout
argument" tm))
- (sleep (compute-time-limit tm 'thread-sleep!)) )
-
-
-;;; Mutexes:
-
-(define (mutex? x) (##sys#structure? x 'mutex))
-
-(define (make-mutex #!optional (id (gensym 'mutex)))
- (##sys#make-mutex id #f))
-
-(define (mutex-name x)
- (##sys#check-structure x 'mutex 'mutex-name)
- (##sys#slot x 1) )
-
-(define (mutex-specific mutex)
- (##sys#check-structure mutex 'mutex 'mutex-specific)
- (##sys#slot mutex 6) )
-
-(define (mutex-specific-set! mutex x)
- (##sys#check-structure mutex 'mutex 'mutex-specific-set!)
- (##sys#setslot mutex 6 x) )
-
-(define (mutex-state mutex)
- (##sys#check-structure mutex 'mutex 'mutex-state)
- (cond [(##sys#slot mutex 5) (or (##sys#slot mutex 2) 'not-owned)]
- [(##sys#slot mutex 4) 'abandoned]
- [else 'not-abandoned] ) )
-
-(define mutex-lock!
- (lambda (mutex . ms-and-t)
- (##sys#check-structure mutex 'mutex 'mutex-lock!)
- (let* ([limitsup (pair? ms-and-t)]
- [limit (and limitsup (compute-time-limit (car ms-and-t)
'mutex-lock!))]
- [threadsup (fx> (length ms-and-t) 1)]
- [thread (and threadsup (cadr ms-and-t))] )
- (when thread (##sys#check-structure thread 'thread 'mutex-lock!))
- (##sys#call-with-current-continuation
- (lambda (return)
- (let ([ct ##sys#current-thread])
- (define (switch)
- (dbg ct " sleeping on mutex " (mutex-name mutex))
- (##sys#setslot mutex 3 (##sys#append (##sys#slot mutex 3) (list
ct)))
- (##sys#schedule) )
- (define (check)
- (when (##sys#slot mutex 4) ; abandoned
- (return
- (##sys#signal
- (##sys#make-structure 'condition '(abandoned-mutex-exception)
'()))) ) )
- (dbg ct ": locking " (mutex-name mutex))
- (cond [(not (##sys#slot mutex 5))
- (if (and threadsup (not thread))
- (begin
- (##sys#setislot mutex 2 #f)
- (##sys#setislot mutex 5 #t) )
- (let* ([t (or thread ct)]
- [ts (##sys#slot t 3)] )
- (if (or (eq? 'terminated ts) (eq? 'dead ts))
- (##sys#setislot mutex 4 #t)
- (begin
- (##sys#setislot mutex 5 #t)
- (##sys#setslot t 8 (cons mutex (##sys#slot t 8)))
- (##sys#setslot t 11 mutex)
- (##sys#setslot mutex 2 t) ) ) ) )
- (check)
- (return #t) ]
- [limit
- (check)
- (##sys#setslot
- ct 1
- (lambda ()
- (##sys#setslot mutex 3 (##sys#delq ct (##sys#slot mutex
3)))
- (unless (##sys#slot ct 13) ; not unblocked by timeout
- (##sys#remove-from-timeout-list ct))
- (check)
- (##sys#setslot ct 8 (cons mutex (##sys#slot ct 8)))
- (##sys#setslot ct 11 #f)
- (##sys#setslot mutex 2 thread)
- (return #f) ))
- (##sys#thread-block-for-timeout! ct limit)
- (switch) ]
- [else
- (##sys#setslot ct 3 'sleeping)
- (##sys#setslot ct 11 mutex)
- (##sys#setslot ct 1 (lambda () (check) (return #t)))
- (switch) ] ) ) ) ) ) ) )
-
-(define mutex-unlock!
- (lambda (mutex . cvar-and-to)
- (##sys#check-structure mutex 'mutex 'mutex-unlock!)
- (let ([ct ##sys#current-thread]
- [cvar (and (pair? cvar-and-to) (car cvar-and-to))]
- [timeout (and (fx> (length cvar-and-to) 1) (cadr cvar-and-to))] )
- (dbg ct ": unlocking " (mutex-name mutex))
- (when cvar
- (##sys#check-structure cvar 'condition-variable 'mutex-unlock!))
- (##sys#call-with-current-continuation
- (lambda (return)
- (let ([waiting (##sys#slot mutex 3)]
- [limit (and timeout (compute-time-limit timeout
'mutex-unlock!))] )
- (##sys#setislot mutex 4 #f) ; abandoned
- (##sys#setislot mutex 5 #f) ; blocked
- (let ((t (##sys#slot mutex 2)))
- (when t
- (##sys#setslot t 8 (##sys#delq mutex (##sys#slot t 8))))) ;
unown from owner
- (when cvar
- (##sys#setslot cvar 2 (##sys#append (##sys#slot cvar 2)
(##sys#list ct)))
- (##sys#setslot ct 11 cvar) ; block object
- (cond (limit
- (##sys#setslot
- ct 1
- (lambda ()
- (##sys#setslot cvar 2 (##sys#delq ct (##sys#slot cvar
2)))
- (##sys#setslot ct 11 #f) ; block object
- (if (##sys#slot ct 13) ; unblocked by timeout
- (return #f)
- (begin
- (##sys#remove-from-timeout-list ct)
- (return #t))) ) )
- (##sys#thread-block-for-timeout! ct limit) )
- (else
- (##sys#setslot ct 1 (lambda () (return #t)))
- (##sys#setslot ct 3 'sleeping)) ) )
- (unless (null? waiting)
- (let* ([wt (##sys#slot waiting 0)]
- [wts (##sys#slot wt 3)] )
- (##sys#setslot mutex 3 (##sys#slot waiting 1))
- (##sys#setislot mutex 5 #t)
- (when (or (eq? wts 'blocked) (eq? wts 'sleeping))
- (##sys#setslot mutex 2 wt)
- (##sys#setslot wt 8 (cons mutex (##sys#slot wt 8)))
- (##sys#setslot wt 11 #f)
- (when (eq? wts 'sleeping) (##sys#add-to-ready-queue wt) ) ) ) )
- (if (eq? (##sys#slot ct 3) 'running)
- (return #t)
- (##sys#schedule)) ) ) ) ) ))
-
-;;; Condition variables:
-
-(define make-condition-variable
- (lambda name
- (##sys#make-structure
- 'condition-variable
- (if (pair? name) ; #1 name
- (car name)
- (gensym 'condition-variable) )
- '() ; #2 list of waiting threads
- (##core#undefined) ) ) ) ; #3 specific
-
-(define (condition-variable? x)
- (##sys#structure? x 'condition-variable) )
-
-(define (condition-variable-name cv)
- (##sys#check-structure cv 'condition-variable 'condition-variable-name)
- (##sys#slot cv 1) )
-
-(define (condition-variable-specific cv)
- (##sys#check-structure cv 'condition-variable 'condition-variable-specific)
- (##sys#slot cv 3) )
-
-(define (condition-variable-specific-set! cv x)
- (##sys#check-structure cv 'condition-variable
'condition-variable-specific-set!)
- (##sys#setslot cv 3 x) )
-
-(define (condition-variable-signal! cvar)
- (##sys#check-structure cvar 'condition-variable 'condition-variable-signal!)
- (dbg "signalling " cvar)
- (let ([ts (##sys#slot cvar 2)])
- (unless (null? ts)
- (let* ([t0 (##sys#slot ts 0)]
- [t0s (##sys#slot t0 3)] )
- (##sys#setslot cvar 2 (##sys#slot ts 1))
- (when (or (eq? t0s 'blocked) (eq? t0s 'sleeping))
- (##sys#thread-basic-unblock! t0) ) ) ) ) )
-
-(define (condition-variable-broadcast! cvar)
- (##sys#check-structure cvar 'condition-variable
'condition-variable-broadcast!)
- (dbg "broadcasting " cvar)
- (##sys#for-each
- (lambda (ti)
- (let ([tis (##sys#slot ti 3)])
- (when (or (eq? tis 'blocked) (eq? tis 'sleeping))
- (##sys#thread-basic-unblock! ti) ) ) )
- (##sys#slot cvar 2) )
- (##sys#setislot cvar 2 '()) )
-
-
-;;; Change continuation of thread to signal an exception:
-
-(define (thread-signal! thread exn)
- (##sys#check-structure thread 'thread 'thread-signal!)
- (dbg "signal " thread exn)
- (if (eq? thread ##sys#current-thread)
- (##sys#signal exn)
- (let ([old (##sys#slot thread 1)]
- [blocked (##sys#slot thread 11)])
- (cond
- ((##sys#structure? blocked 'condition-variable)
- (##sys#setslot blocked 2 (##sys#delq thread (##sys#slot blocked 2))))
- ((##sys#structure? blocked 'mutex)
- (##sys#setslot blocked 3 (##sys#delq thread (##sys#slot blocked 3))))
- ((##sys#structure? blocked 'thread)
- (##sys#setslot blocked 12 (##sys#delq thread (##sys#slot blocked
12)))))
- (##sys#setslot
- thread 1
- (lambda ()
- (##sys#signal exn)
- (old) ) )
- (##sys#setslot thread 3 'blocked)
- (##sys#thread-unblock! thread) ) ) )
-
-
-;;; Don't block in the repl: (by Chris Double)
-
-(set! ##sys#read-prompt-hook
- (let ([old ##sys#read-prompt-hook])
- (lambda ()
- (when (or (##sys#fudge 12) (##sys#tty-port? ##sys#standard-input))
- (old)
- (##sys#thread-block-for-i/o! ##sys#current-thread 0 #:input)
- (thread-yield!)))) )
-
-
-;;; Waiting for I/O on file-descriptor
-
-(define (thread-wait-for-i/o! fd #!optional (mode #:all))
- (##sys#check-exact fd 'thread-wait-for-i/o!)
- (##sys#thread-block-for-i/o! ##sys#current-thread fd mode)
- (thread-yield!) )
diff --git a/srfi-69.import.scm b/srfi-69.import.scm
deleted file mode 100644
index 600fb35..0000000
--- a/srfi-69.import.scm
+++ /dev/null
@@ -1,73 +0,0 @@
-;;;; srfi-69.import.scm - import library for "srfi-69" module
-;
-; Copyright (c) 2008-2014, The CHICKEN Team
-; All rights reserved.
-;
-; Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following
-; conditions are met:
-;
-; Redistributions of source code must retain the above copyright notice,
this list of conditions and the following
-; disclaimer.
-; Redistributions in binary form must reproduce the above copyright notice,
this list of conditions and the following
-; disclaimer in the documentation and/or other materials provided with the
distribution.
-; Neither the name of the author nor the names of its contributors may be
used to endorse or promote
-; products derived from this software without specific prior written
permission.
-;
-; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
AND ANY EXPRESS
-; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
OF MERCHANTABILITY
-; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
COPYRIGHT HOLDERS OR
-; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
EXEMPLARY, OR
-; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
SUBSTITUTE GOODS OR
-; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY
-; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR
-; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
ADVISED OF THE
-; POSSIBILITY OF SUCH DAMAGE.
-
-
-(##sys#register-primitive-module
- 'srfi-69
- '(alist->hash-table
- eq?-hash
- equal?-hash
- eqv?-hash
- hash
- hash-by-identity
- hash-table->alist
- hash-table-clear!
- hash-table-copy
- hash-table-delete!
- hash-table-equivalence-function
- hash-table-exists?
- hash-table-fold
- hash-table-for-each
- hash-table-has-initial?
- hash-table-hash-function
- hash-table-initial
- hash-table-keys
- hash-table-map
- hash-table-max-load
- hash-table-merge
- hash-table-merge!
- hash-table-min-load
- hash-table-ref
- hash-table-ref/default
- hash-table-remove!
- hash-table-set!
- hash-table-size
- hash-table-update!
- hash-table-update!/default
- hash-table-values
- hash-table-walk
- hash-table-weak-keys
- hash-table-weak-values
- hash-table?
- keyword-hash
- make-hash-table
- number-hash
- object-uid-hash
- recursive-hash-max-depth
- recursive-hash-max-length
- string-hash-ci
- string-ci-hash
- string-hash
- symbol-hash))
diff --git a/srfi-69.scm b/srfi-69.scm
deleted file mode 100644
index c65235a..0000000
--- a/srfi-69.scm
+++ /dev/null
@@ -1,1132 +0,0 @@
-;;; srfi-69.scm - Optional non-standard extensions
-;
-; Copyright (c) 2008-2014, The CHICKEN Team
-; Copyright (c) 2000-2007, Felix L. Winkelmann
-; All rights reserved.
-;
-; Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following
-; conditions are met:
-;
-; Redistributions of source code must retain the above copyright notice,
this list of conditions and the following
-; disclaimer.
-; Redistributions in binary form must reproduce the above copyright notice,
this list of conditions and the following
-; disclaimer in the documentation and/or other materials provided with the
distribution.
-; Neither the name of the author nor the names of its contributors may be
used to endorse or promote
-; products derived from this software without specific prior written
permission.
-;
-; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
AND ANY EXPRESS
-; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
OF MERCHANTABILITY
-; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
COPYRIGHT HOLDERS OR
-; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
EXEMPLARY, OR
-; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
SUBSTITUTE GOODS OR
-; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY
-; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR
-; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
ADVISED OF THE
-; POSSIBILITY OF SUCH DAMAGE.
-
-(declare
- (unit srfi-69)
- (hide
- *eq?-hash *eqv?-hash *equal?-hash
- *make-hash-table
- *hash-table-copy *hash-table-merge! *hash-table-update!/default
- *hash-table-for-each *hash-table-fold hash-default-randomization
- hash-table-canonical-length hash-table-rehash! hash-table-check-resize! ) )
-
-(include "common-declarations.scm")
-
-(foreign-declare "#define C_rnd_fix() (C_fix(rand()))")
-
-(register-feature! 'srfi-69)
-
-
-;;; Naming Conventions:
-
-;; %foo - inline primitive
-;; %%foo - local inline (no such thing but at least it looks different)
-;; $foo - local macro
-;; *foo - local unchecked variant of a checked procedure
-;; ##sys#foo - public, but undocumented, un-checked procedure
-;; foo - public checked procedure
-;;
-
-
-;;; Core Inlines:
-
-(define-inline (%fix wrd)
- (##core#inline "C_fix" wrd) )
-
-(define-inline (%block? obj)
- (##core#inline "C_blockp" obj) )
-
-(define-inline (%immediate? obj)
- (not (##core#inline "C_blockp" obj)) )
-
-(define-inline (%special? obj)
- (##core#inline "C_specialp" obj) )
-
-(define-inline (%port? obj)
- (##core#inline "C_portp" obj) )
-
-(define-inline (%byte-block? obj)
- (##core#inline "C_byteblockp" obj) )
-
-(define-inline (%string-hash str rnd)
- (##core#inline "C_u_i_string_hash" str rnd) )
-
-(define-inline (%string-ci-hash str rnd)
- (##core#inline "C_u_i_string_ci_hash" str rnd) )
-
-(define-inline (%subbyte bytvec i)
- (##core#inline "C_subbyte" bytvec i) )
-
-(define-inline (exactify n)
- (if (##sys#immediate? n)
- n
- (##core#inline "C_i_inexact_to_exact" n)))
-
-
-;;; Generation of hash-values:
-
-;; All '%foo-hash' return a fixnum, not necessarily positive. The "overflow" of
-;; a, supposedly, unsigned hash value into negative is not checked during
-;; intermediate computation.
-;;
-;; The body of '*eq?-hash' is duplicated in '*eqv?-hash' and the body of
'*eqv?-hash'
-;; is duplicated in '*equal?-hash' to save on procedure calls.
-
-;; Fixed hash-values:
-
-(define-constant other-hash-value 99)
-(define-constant true-hash-value 256)
-(define-constant false-hash-value 257)
-(define-constant null-hash-value 258)
-(define-constant eof-hash-value 259)
-(define-constant input-port-hash-value 260)
-(define-constant output-port-hash-value 261)
-(define-constant unknown-immediate-hash-value 262)
-
-(define-constant hash-default-bound 536870912)
-(define hash-default-randomization (##core#inline "C_rnd_fix"))
-
-;; Force Hash to Bounded Fixnum:
-
-(define-inline (%fxabs fxn)
- (if (fx< fxn 0) (fxneg fxn) fxn ) )
-
-(define-inline (%hash/limit hsh lim)
- ;; use 32-bit mask to have identical hashes on 64-bit platforms
- (fxmod (fxand (foreign-value "C_MOST_POSITIVE_32_BIT_FIXNUM" int)
- (%fxabs hsh))
- lim) )
-
-;; Number Hash:
-
-(define-constant flonum-magic 331804471)
-
-(define-syntax $flonum-hash
- (er-macro-transformer
- (lambda (form r c)
- (let ( (flo (cadr form))
- (_%subbyte (r '%subbyte))
- (_flonum-magic (r 'flonum-magic))
- (_fx+ (r 'fx+))
- (_fx* (r 'fx*))
- (_fxshl (r 'fxshl)) )
- `(,_fx* ,_flonum-magic
- ,(let loop ( (idx (fx- (##sys#size 1.0) 1)) )
- (if (fx= 0 idx)
- `(,_%subbyte ,flo 0)
- `(,_fx+ (,_%subbyte ,flo ,idx)
- (,_fxshl ,(loop (fx- idx 1)) 1)) ) ) ) ) )) )
-
-(define (##sys#number-hash-hook obj rnd)
- (*equal?-hash obj rnd) )
-
-(define-inline (%non-fixnum-number-hash obj rnd)
- (cond [(flonum? obj) ($flonum-hash obj rnd)]
- [else (%fix (##sys#number-hash-hook obj rnd))] ) )
-
-(define-inline (%number-hash obj rnd)
- (cond [(fixnum? obj) (fxxor obj rnd)]
- [else (%non-fixnum-number-hash obj rnd)] ) )
-
-(define (number-hash obj #!optional (bound hash-default-bound)
- (randomization hash-default-randomization))
- (unless (number? obj)
- (##sys#signal-hook #:type 'number-hash "invalid number" obj) )
- (##sys#check-exact bound 'number-hash)
- (%hash/limit (%number-hash obj randomization) bound) )
-
-;; Object UID Hash:
-
-#; ;NOT YET (no weak-reference)
-(define-inline (%object-uid-hash obj)
- (%uid-hash (##sys#object->uid obj)) )
-
-(define-inline (%object-uid-hash obj rnd)
- (*equal?-hash obj rnd) )
-
-(define (object-uid-hash obj #!optional (bound hash-default-bound)
- (randomization hash-default-randomization))
- (##sys#check-exact bound 'object-uid-hash)
- (%hash/limit (%object-uid-hash obj randomization) bound) )
-
-;; Symbol Hash:
-
-#; ;NOT YET (no unique-symbol-hash)
-(define-inline (%symbol-hash obj)
- (##sys#slot obj INDEX-OF-UNIQUE-HASH-VALUE-COMPUTED-DURING-SYMBOL-CREATION) )
-
-(define-inline (%symbol-hash obj rnd)
- (%string-hash (##sys#slot obj 1) rnd) )
-
-(define (symbol-hash obj #!optional (bound hash-default-bound)
- (randomization hash-default-randomization))
- (##sys#check-symbol obj 'symbol-hash)
- (##sys#check-exact bound 'symbol-hash)
- (%hash/limit (%symbol-hash obj randomization) bound) )
-
-;; Keyword Hash:
-
-(define (##sys#check-keyword x . y)
- (unless (keyword? x)
- (##sys#signal-hook #:type-error
- (and (not (null? y)) (car y))
- "bad argument type - not a keyword" x) ) )
-
-#; ;NOT YET (no unique-keyword-hash)
-(define-inline (%keyword-hash obj)
- (##sys#slot obj INDEX-OF-UNIQUE-HASH-VALUE-COMPUTED-DURING-KEYWORD-CREATION)
)
-
-(define-inline (%keyword-hash obj rnd)
- (%string-hash (##sys#slot obj 1) rnd) )
-
-(define (keyword-hash obj #!optional (bound hash-default-bound)
- (randomization hash-default-randomization))
- (##sys#check-keyword obj 'keyword-hash)
- (##sys#check-exact bound 'keyword-hash)
- (%hash/limit (%keyword-hash obj randomization) bound) )
-
-;; Eq Hash:
-
-(define-inline (%eq?-hash-object? obj)
- (or (%immediate? obj)
- (symbol? obj)
- #; ;NOT YET (no keyword vs. symbol issue)
- (keyword? obj) ) )
-
-(define (*eq?-hash obj rnd)
- (cond [(fixnum? obj) (fxxor obj rnd)]
- [(char? obj) (fxxor (char->integer obj) rnd)]
- [(eq? obj #t) (fxxor true-hash-value rnd)]
- [(eq? obj #f) (fxxor false-hash-value rnd)]
- [(null? obj) (fxxor null-hash-value rnd)]
- [(eof-object? obj) (fxxor eof-hash-value rnd)]
- [(symbol? obj) (%symbol-hash obj rnd)]
- #; ;NOT YET (no keyword vs. symbol issue)
- [(keyword? obj) (%keyword-hash obj rnd)]
- [(%immediate? obj) (fxxor unknown-immediate-hash-value rnd)]
- [else (%object-uid-hash obj rnd) ] ) )
-
-(define (eq?-hash obj #!optional (bound hash-default-bound)
- (randomization hash-default-randomization))
- (##sys#check-exact bound 'eq?-hash)
- (%hash/limit (*eq?-hash obj randomization) bound) )
-
-(define hash-by-identity eq?-hash)
-
-;; Eqv Hash:
-
-(define-inline (%eqv?-hash-object? obj)
- (or (%eq?-hash-object? obj)
- (number? obj) ) )
-
-(define (*eqv?-hash obj rnd)
- (cond [(fixnum? obj) (fxxor obj rnd)]
- [(char? obj) (fxxor (char->integer obj) rnd)]
- [(eq? obj #t) (fxxor true-hash-value rnd)]
- [(eq? obj #f) (fxxor false-hash-value rnd)]
- [(null? obj) (fxxor null-hash-value rnd)]
- [(eof-object? obj) (fxxor eof-hash-value rnd)]
- [(symbol? obj) (%symbol-hash obj rnd)]
- #; ;NOT YET (no keyword vs. symbol issue)
- [(keyword? obj) (%keyword-hash obj rnd)]
- [(number? obj) (%non-fixnum-number-hash obj rnd)]
- [(%immediate? obj) (fxxor unknown-immediate-hash-value rnd)]
- [else (%object-uid-hash obj rnd) ] ) )
-
-(define (eqv?-hash obj #!optional (bound hash-default-bound)
- (randomization hash-default-randomization))
- (##sys#check-exact bound 'eqv?-hash)
- (%hash/limit (*eqv?-hash obj randomization) bound) )
-
-;; Equal Hash:
-
-(define-constant default-recursive-hash-max-depth 4)
-(define-constant default-recursive-hash-max-length 4)
-
-(define *recursive-hash-max-depth* default-recursive-hash-max-depth)
-(define recursive-hash-max-depth (make-parameter
default-recursive-hash-max-depth
- (lambda (x)
- (if (and (fixnum? x) (positive? x))
- (begin
- (set! *recursive-hash-max-depth* x)
- x )
- *recursive-hash-max-depth*))))
-
-(define *recursive-hash-max-length* default-recursive-hash-max-length)
-(define recursive-hash-max-length (make-parameter
default-recursive-hash-max-length
- (lambda (x)
- (if (and (fixnum? x) (positive? x))
- (begin
- (set! *recursive-hash-max-length* x)
- x )
- *recursive-hash-max-length*))))
-
-;; NOTE - These refer to identifiers available only within the body of
'*equal?-hash'.
-
-(define-inline (%%pair-hash obj rnd)
- (fx+ (fxshl (recursive-hash (##sys#slot obj 0) (fx+ depth 1) rnd) 16)
- (recursive-hash (##sys#slot obj 1) (fx+ depth 1) rnd)) )
-
-(define-inline (%%port-hash obj rnd)
- (fx+ (fxxor (fxshl (##sys#peek-fixnum obj 0) 4) rnd) ; Little extra
"identity"
- (if (input-port? obj)
- input-port-hash-value
- output-port-hash-value)) )
-
-(define-inline (%%special-vector-hash obj rnd)
- (vector-hash obj (##sys#peek-fixnum obj 0) depth 1 rnd) )
-
-(define-inline (%%regular-vector-hash obj rnd)
- (vector-hash obj 0 depth 0 rnd) )
-
-(define (*equal?-hash obj rnd)
-
- ; Recurse into some portion of the vector's slots
- (define (vector-hash obj seed depth start rnd)
- (let ([len (##sys#size obj)])
- (let loop ([hsh (fx+ len (fxxor seed rnd))]
- [i start]
- [len (fx- (fxmax start (fxmin *recursive-hash-max-length*
len)) start)] )
- (if (fx= len 0)
- hsh
- (loop (fx+ hsh
- (fx+ (fxshl hsh 4)
- (recursive-hash (##sys#slot obj i) (fx+ depth 1)
rnd)))
- (fx+ i 1)
- (fx- len 1) ) ) ) ) )
-
- ; Recurse into structured objects
- (define (recursive-hash obj depth rnd)
- (cond [(fx>= depth *recursive-hash-max-depth*)
- (fxxor other-hash-value rnd)]
- [(fixnum? obj) (fxxor obj rnd)]
- [(char? obj) (fxxor (char->integer obj) rnd)]
- [(eq? obj #t) (fxxor true-hash-value rnd)]
- [(eq? obj #f) (fxxor false-hash-value rnd)]
- [(null? obj) (fxxor null-hash-value rnd)]
- [(eof-object? obj) (fxxor eof-hash-value rnd)]
- [(symbol? obj) (%symbol-hash obj rnd)]
- #; ;NOT YET (no keyword vs. symbol issue)
- [(keyword? obj) (%keyword-hash obj rnd)]
- [(number? obj) (%non-fixnum-number-hash obj rnd)]
- [(%immediate? obj) (fxxor unknown-immediate-hash-value rnd)]
- [(%byte-block? obj) (%string-hash obj rnd)]
- [(pair? obj) (%%pair-hash obj rnd)]
- [(%port? obj) (%%port-hash obj rnd)]
- [(%special? obj) (%%special-vector-hash obj rnd)]
- [else (%%regular-vector-hash obj rnd)] ) )
-
- ;
- (recursive-hash obj 0 rnd) )
-
-(define (equal?-hash obj #!optional (bound hash-default-bound)
- (randomization hash-default-randomization))
- (##sys#check-exact bound 'hash)
- (%hash/limit (*equal?-hash obj randomization) bound) )
-
-(define hash equal?-hash)
-
-;; String Hash:
-
-(define (string-hash str #!optional (bound hash-default-bound) start end
- (randomization hash-default-randomization))
- (##sys#check-string str 'string-hash)
- (##sys#check-exact bound 'string-hash)
- (let ((str (if start
- (let ((end (or end (##sys#size str))))
- (##sys#check-range start 0 (##sys#size str) 'string-hash)
- (##sys#check-range end 0 (##sys#size str) 'string-hash)
- (##sys#substring str start end))
- str)) )
- (%hash/limit (%string-hash str randomization) bound) ) )
-
-(define (string-ci-hash str #!optional (bound hash-default-bound) start end
- (randomization hash-default-randomization))
- (##sys#check-string str 'string-ci-hash)
- (##sys#check-exact bound 'string-ci-hash)
- (let ((str (if start
- (let ((end (or end (##sys#size str))))
- (##sys#check-range start 0 (##sys#size str) 'string-hash)
- (##sys#check-range end 0 (##sys#size str) 'string-hash)
- (##sys#substring str start end))
- str)) )
- (%hash/limit (%string-ci-hash str randomization) bound) ) )
-
-(define string-hash-ci string-ci-hash)
-
-
-;;; Hash-Tables:
-
-; Predefined sizes for the hash tables:
-;
-; Starts with 307; each element is the smallest prime that is at least twice in
-; magnitude as the previous element in the list.
-;
-; The last number is an exception: it is the largest 32-bit fixnum we can
represent.
-
-(define-constant hash-table-prime-lengths
- '(307 617
- 1237 2477 4957 9923
- 19853 39709 79423
- 158849 317701 635413
- 1270849 2541701 5083423
- 10166857 20333759 40667527 81335063 162670129
- 325340273 650680571
- ;
- 1073741823))
-
-(define-constant hash-table-default-length 307)
-(define-constant hash-table-max-length 1073741823)
-(define-constant hash-table-new-length-factor 2)
-
-(define-constant hash-table-default-min-load 0.5)
-(define-constant hash-table-default-max-load 0.8)
-
-;; Restrict hash-table length to tabled lengths:
-
-(define (hash-table-canonical-length tab req)
- (let loop ([tab tab])
- (let ([cur (##sys#slot tab 0)]
- [nxt (##sys#slot tab 1)])
- (if (or (fx>= cur req)
- (null? nxt))
- cur
- (loop nxt) ) ) ) )
-
-(define *make-hash-function
- (let ((eq?-hash eq?-hash) (eqv?-hash eqv?-hash) (equal?-hash equal?-hash)
- (hash hash) (string-hash string-hash) (string-hash-ci string-hash-ci)
- (number-hash number-hash) (object-uid-hash object-uid-hash)
- (symbol-hash symbol-hash) (keyword-hash keyword-hash))
- (lambda (user-function)
- (if (memq user-function (list eq?-hash eqv?-hash equal?-hash hash
- string-hash string-hash-ci number-hash
- object-uid-hash symbol-hash keyword-hash))
- ;; Don't add unnecessary bounds checks for procedures known to be
- ;; well-behaved (these are not user-*created* functions)
- (let ((randomization (##core#inline "C_rnd_fix")))
- (if (memq user-function (list string-hash string-hash-ci))
- ;; String functions have differing signatures; treat them
specially
- (lambda (object bound)
- (user-function object bound #f #f randomization))
- (lambda (object bound)
- (user-function object bound randomization))))
- (lambda (object bound)
- (let ((hash (user-function object bound)))
- (##sys#check-exact hash 'hash user-function)
- (if (and (fx< hash bound) (fx>= hash 0))
- hash
- (##sys#signal-hook
- #:bounds-error 'hash
- "Hash value out of bounds" bound hash user-function) )))))))
-
-;; "Raw" make-hash-table:
-
-(define *make-hash-table
- (let ([make-vector make-vector])
- (lambda (test hash len min-load max-load weak-keys weak-values initial
- #!optional (vec (make-vector len '())))
- (let ((ht (##sys#make-structure 'hash-table
- vec 0 test hash min-load max-load #f #f initial #f)))
- (##sys#setslot ht 10 (*make-hash-function hash))
- ht) ) ) )
-
-;; SRFI-69 & SRFI-90'ish.
-;;
-;; Argument list is the pattern
-;;
-;; (make-hash-table #!optional test hash size
-;; #!key test hash size initial
-;; min-load max-load weak-keys weak-values)
-;;
-;; where a keyword argument takes precedence over the corresponding optional
-;; argument. Keyword arguments MUST come after optional & required
-;; arugments.
-;;
-;; Wish DSSSL (extended) argument list processing Did-What-I-Want (DWIW).
-
-(define make-hash-table
- (let ([core-eq? eq?]
- [core-eqv? eqv?]
- [core-equal? equal?]
- [core-string=? string=?]
- [core-string-ci=? string-ci=?]
- [core= =]
- (eq?-hash eq?-hash) (eqv?-hash eqv?-hash) (equal?-hash equal?-hash)
- (hash hash) (string-hash string-hash) (string-hash-ci string-hash-ci)
- (number-hash number-hash))
- (lambda arguments0
- (let ([arguments arguments0]
- [test equal?]
- [hash #f]
- [size hash-table-default-length]
- [initial #f]
- [min-load hash-table-default-min-load]
- [max-load hash-table-default-max-load]
- [weak-keys #f]
- [weak-values #f])
- (let ([hash-for-test
- (lambda ()
- (cond [(or (eq? core-eq? test)
- (eq? eq? test)) eq?-hash]
- [(or (eq? core-eqv? test)
- (eq? eqv? test)) eqv?-hash]
- [(or (eq? core-equal? test)
- (eq? equal? test)) equal?-hash]
- [(or (eq? core-string=? test)
- (eq? string=? test)) string-hash]
- [(or (eq? core-string-ci=? test)
- (eq? string-ci=? test)) string-hash-ci]
- [(or (eq? core= test)
- (eq? = test)) number-hash]
- [else #f] ) ) ] )
- ; Process optional arguments
- (unless (null? arguments)
- (let ([arg (car arguments)])
- (unless (keyword? arg)
- (##sys#check-closure arg 'make-hash-table)
- (set! test arg)
- (set! arguments (cdr arguments)) ) ) )
- (unless (null? arguments)
- (let ([arg (car arguments)])
- (unless (keyword? arg)
- (##sys#check-closure arg 'make-hash-table)
- (set! hash arg)
- (set! arguments (cdr arguments)) ) ) )
- (unless (null? arguments)
- (let ([arg (car arguments)])
- (unless (keyword? arg)
- (##sys#check-exact arg 'make-hash-table)
- (unless (fx< 0 arg)
- (error 'make-hash-table "invalid size" arg) )
- (set! size (fxmin hash-table-max-length arg))
- (set! arguments (cdr arguments)) ) ) )
- ; Process keyword arguments
- (let loop ([args arguments])
- (unless (null? args)
- (let ([arg (car args)])
- (let ([invarg-err
- (lambda (msg)
- (error 'make-hash-table msg arg arguments0))])
- (if (keyword? arg)
- (let* ([nxt (cdr args)]
- [val (if (pair? nxt)
- (car nxt)
- (invarg-err "missing keyword value"))])
- (case arg
- [(#:test)
- (##sys#check-closure val 'make-hash-table)
- (set! test val)]
- [(#:hash)
- (##sys#check-closure val 'make-hash-table)
- (set! hash val)]
- [(#:size)
- (##sys#check-exact val 'make-hash-table)
- (unless (fx< 0 val)
- (error 'make-hash-table "invalid size" val) )
- (set! size (fxmin hash-table-max-length val))]
- [(#:initial)
- (set! initial (lambda () val))]
- [(#:min-load)
- (##sys#check-inexact val 'make-hash-table)
- (unless (and (fp< 0.0 val) (fp< val 1.0))
- (error 'make-hash-table "invalid min-load" val) )
- (set! min-load val)]
- [(#:max-load)
- (##sys#check-inexact val 'make-hash-table)
- (unless (and (fp< 0.0 val) (fp< val 1.0))
- (error 'make-hash-table "invalid max-load" val) )
- (set! max-load val)]
- [(#:weak-keys)
- (set! weak-keys (and val #t))]
- [(#:weak-values)
- (set! weak-values (and val #t))]
- [else
- (invarg-err "unknown keyword")])
- (loop (cdr nxt)) )
- (invarg-err "missing keyword") ) ) ) ) )
- ; Load must be a proper interval
- (when (fp< max-load min-load)
- (error 'make-hash-table "min-load greater than max-load" min-load
max-load) )
- ; Force canonical hash-table vector length
- (set! size (hash-table-canonical-length hash-table-prime-lengths
size))
- ; Decide on a hash function when not supplied
- (unless hash
- (let ([func (hash-for-test)])
- (if func
- (set! hash func)
- (begin
- (warning 'make-hash-table "user test without user hash")
- (set! hash equal?-hash) ) ) ) )
- ; Done
- (*make-hash-table test hash size min-load max-load weak-keys
weak-values initial) ) ) ) ) )
-
-;; Hash-Table Predicate:
-
-(define (hash-table? obj)
- (##sys#structure? obj 'hash-table) )
-
-;; Hash-Table Properties:
-
-(define (hash-table-size ht)
- (##sys#check-structure ht 'hash-table 'hash-table-size)
- (##sys#slot ht 2) )
-
-(define (hash-table-equivalence-function ht)
- (##sys#check-structure ht 'hash-table 'hash-table-equivalence-function)
- (##sys#slot ht 3) )
-
-(define (hash-table-hash-function ht)
- (##sys#check-structure ht 'hash-table 'hash-table-hash-function)
- (##sys#slot ht 4) )
-
-(define (hash-table-min-load ht)
- (##sys#check-structure ht 'hash-table 'hash-table-min-load)
- (##sys#slot ht 5) )
-
-(define (hash-table-max-load ht)
- (##sys#check-structure ht 'hash-table 'hash-table-max-load)
- (##sys#slot ht 6) )
-
-(define (hash-table-weak-keys ht)
- (##sys#check-structure ht 'hash-table 'hash-table-weak-keys)
- (##sys#slot ht 7) )
-
-(define (hash-table-weak-values ht)
- (##sys#check-structure ht 'hash-table 'hash-table-weak-values)
- (##sys#slot ht 8) )
-
-(define (hash-table-has-initial? ht)
- (##sys#check-structure ht 'hash-table 'hash-table-has-initial?)
- (and (##sys#slot ht 9)
- #t ) )
-
-(define (hash-table-initial ht)
- (##sys#check-structure ht 'hash-table 'hash-table-initial)
- (and-let* ([thunk (##sys#slot ht 9)])
- (thunk) ) )
-
-;; hash-table-rehash!:
-
-(define (hash-table-rehash! vec1 vec2 hash)
- (let ([len1 (##sys#size vec1)]
- [len2 (##sys#size vec2)] )
- (do ([i 0 (fx+ i 1)])
- [(fx>= i len1)]
- (let loop ([bucket (##sys#slot vec1 i)])
- (unless (null? bucket)
- (let* ([pare (##sys#slot bucket 0)]
- [key (##sys#slot pare 0)]
- [hshidx (hash key len2)] )
- (##sys#setslot vec2 hshidx
- (cons (cons key (##sys#slot pare 1)) (##sys#slot
vec2 hshidx)))
- (loop (##sys#slot bucket 1)) ) ) ) ) ) )
-
-;; hash-table-resize!:
-
-(define (hash-table-resize! ht vec len)
- (let* ([deslen (fxmin hash-table-max-length (fx* len
hash-table-new-length-factor))]
- [newlen (hash-table-canonical-length hash-table-prime-lengths deslen)]
- [vec2 (make-vector newlen '())] )
- (hash-table-rehash! vec vec2 (##sys#slot ht 10))
- (##sys#setslot ht 1 vec2) ) )
-
-;; hash-table-check-resize!:
-
-(define-inline (hash-table-check-resize! ht newsiz)
- (let ([vec (##sys#slot ht 1)]
- [min-load (##sys#slot ht 5)]
- [max-load (##sys#slot ht 6)] )
- (let ([len (##sys#size vec)] )
- (let ([min-load-len (exactify (floor (* len min-load)))]
- [max-load-len (exactify (floor (* len max-load)))] )
- (if (and (fx< len hash-table-max-length)
- (fx<= min-load-len newsiz) (fx<= newsiz max-load-len))
- (hash-table-resize! ht vec len) ) ) ) ) )
-
-;; hash-table-copy:
-
-(define *hash-table-copy
- (let ((make-vector make-vector))
- (lambda (ht)
- (let* ((vec1 (##sys#slot ht 1))
- (len (##sys#size vec1))
- (vec2 (make-vector len '()))
- (ht2 (do ((i 0 (fx+ i 1)))
- ((fx>= i len)
- (*make-hash-table
- (##sys#slot ht 3) (##sys#slot ht 4)
- (##sys#slot ht 2)
- (##sys#slot ht 5) (##sys#slot ht 6)
- (##sys#slot ht 7) (##sys#slot ht 8)
- (##sys#slot ht 9) vec2))
- (##sys#setslot vec2 i
- (let copy-loop ((bucket (##sys#slot vec1
i)))
- (if (null? bucket)
- '()
- (let ((pare (##sys#slot bucket 0)))
- (cons (cons (##sys#slot pare 0)
(##sys#slot pare 1))
- (copy-loop (##sys#slot bucket
1))))))) )))
- ;; Size and randomized hashing function are reset by *make-hash-table,
- ;; so we copy over the ones from the original hash table.
- (##sys#setslot ht2 2 (##sys#slot ht 2))
- (##sys#setslot ht2 10 (##sys#slot ht 10))
- ht2 ) ) ) )
-
-(define (hash-table-copy ht)
- (##sys#check-structure ht 'hash-table 'hash-table-copy)
- (*hash-table-copy ht) )
-
-;; hash-table-update!:
-;;
-;; This one was suggested by Sven Hartrumpf (and subsequently added in
SRFI-69).
-;; Modified for ht props min & max load.
-
-(define hash-table-update!
- (let ([core-eq? eq?] )
- (lambda (ht key func
- #!optional
- (thunk
- (let ([thunk (##sys#slot ht 9)])
- (or thunk
- (lambda ()
- (##sys#signal-hook
- #:access-error
- 'hash-table-update!
- "hash-table does not contain key" key ht))))))
- (##sys#check-structure ht 'hash-table 'hash-table-update!)
- (##sys#check-closure func 'hash-table-update!)
- (##sys#check-closure thunk 'hash-table-update!)
- (let ([newsiz (fx+ (##sys#slot ht 2) 1)] )
- (hash-table-check-resize! ht newsiz)
- (let ([hash (##sys#slot ht 10)]
- [test (##sys#slot ht 3)]
- [vec (##sys#slot ht 1)])
- (let* ([len (##sys#size vec)]
- [hshidx (hash key len)]
- [bucket0 (##sys#slot vec hshidx)] )
- (if (eq? core-eq? test)
- ; Fast path (eq? is rewritten by the compiler):
- (let loop ([bucket bucket0])
- (if (null? bucket)
- (let ([val (func (thunk))])
- (##sys#setslot vec hshidx (cons (cons key val)
bucket0))
- (##sys#setislot ht 2 newsiz)
- val )
- (let ([pare (##sys#slot bucket 0)])
- (if (eq? key (##sys#slot pare 0))
- (let ([val (func (##sys#slot pare 1))])
- (##sys#setslot pare 1 val)
- val)
- (loop (##sys#slot bucket 1)) ) ) ) )
- ; Slow path
- (let loop ([bucket bucket0])
- (if (null? bucket)
- (let ([val (func (thunk))])
- (##sys#setslot vec hshidx (cons (cons key val)
bucket0))
- (##sys#setislot ht 2 newsiz)
- val )
- (let ([pare (##sys#slot bucket 0)])
- (if (test key (##sys#slot pare 0))
- (let ([val (func (##sys#slot pare 1))])
- (##sys#setslot pare 1 val)
- val )
- (loop (##sys#slot bucket 1)) ) ) ) ) ) ) ) ) ) ) )
-
-(define *hash-table-update!/default
- (let ([core-eq? eq?] )
- (lambda (ht key func def)
- (let ([newsiz (fx+ (##sys#slot ht 2) 1)] )
- (hash-table-check-resize! ht newsiz)
- (let ([hash (##sys#slot ht 10)]
- [test (##sys#slot ht 3)]
- [vec (##sys#slot ht 1)])
- (let* ([len (##sys#size vec)]
- [hshidx (hash key len)]
- [bucket0 (##sys#slot vec hshidx)] )
- (if (eq? core-eq? test)
- ; Fast path (eq? is rewritten by the compiler):
- (let loop ([bucket bucket0])
- (if (null? bucket)
- (let ([val (func def)])
- (##sys#setslot vec hshidx (cons (cons key val)
bucket0))
- (##sys#setislot ht 2 newsiz)
- val )
- (let ([pare (##sys#slot bucket 0)])
- (if (eq? key (##sys#slot pare 0))
- (let ([val (func (##sys#slot pare 1))])
- (##sys#setslot pare 1 val)
- val)
- (loop (##sys#slot bucket 1)) ) ) ) )
- ; Slow path
- (let loop ([bucket bucket0])
- (if (null? bucket)
- (let ([val (func def)])
- (##sys#setslot vec hshidx (cons (cons key val)
bucket0))
- (##sys#setislot ht 2 newsiz)
- val )
- (let ([pare (##sys#slot bucket 0)])
- (if (test key (##sys#slot pare 0))
- (let ([val (func (##sys#slot pare 1))])
- (##sys#setslot pare 1 val)
- val )
- (loop (##sys#slot bucket 1)) ) ) ) ) ) ) ) ) ) ) )
-
-(define (hash-table-update!/default ht key func def)
- (##sys#check-structure ht 'hash-table 'hash-table-update!/default)
- (##sys#check-closure func 'hash-table-update!/default)
- (*hash-table-update!/default ht key func def) )
-
-(define hash-table-set!
- (let ([core-eq? eq?] )
- (lambda (ht key val)
- (##sys#check-structure ht 'hash-table 'hash-table-set!)
- (let ([newsiz (fx+ (##sys#slot ht 2) 1)] )
- (hash-table-check-resize! ht newsiz)
- (let ([hash (##sys#slot ht 10)]
- [test (##sys#slot ht 3)]
- [vec (##sys#slot ht 1)])
- (let* ([len (##sys#size vec)]
- [hshidx (hash key len)]
- [bucket0 (##sys#slot vec hshidx)] )
- (if (eq? core-eq? test)
- ; Fast path (eq? is rewritten by the compiler):
- (let loop ([bucket bucket0])
- (if (null? bucket)
- (begin
- (##sys#setslot vec hshidx (cons (cons key val)
bucket0))
- (##sys#setislot ht 2 newsiz) )
- (let ([pare (##sys#slot bucket 0)])
- (if (eq? key (##sys#slot pare 0))
- (##sys#setslot pare 1 val)
- (loop (##sys#slot bucket 1)) ) ) ) )
- ; Slow path
- (let loop ([bucket bucket0])
- (if (null? bucket)
- (begin
- (##sys#setslot vec hshidx (cons (cons key val)
bucket0))
- (##sys#setislot ht 2 newsiz) )
- (let ([pare (##sys#slot bucket 0)])
- (if (test key (##sys#slot pare 0))
- (##sys#setslot pare 1 val)
- (loop (##sys#slot bucket 1)) ) ) ) ) )
- (void) ) ) ) ) ) )
-
-;; Hash-Table Reference:
-
-(define hash-table-ref
- (getter-with-setter
- (let ([core-eq? eq?])
- (lambda (ht key #!optional (def (lambda ()
- (##sys#signal-hook #:access-error
- 'hash-table-ref
- "hash-table does not contain key" key
ht))))
- (##sys#check-structure ht 'hash-table 'hash-table-ref)
- (##sys#check-closure def 'hash-table-ref)
- (let ([vec (##sys#slot ht 1)]
- [test (##sys#slot ht 3)])
- (let* ([hash (##sys#slot ht 10)]
- [hshidx (hash key (##sys#size vec))] )
- (if (eq? core-eq? test)
- ; Fast path (eq? is rewritten by the compiler):
- (let loop ([bucket (##sys#slot vec hshidx)])
- (if (null? bucket)
- (def)
- (let ([pare (##sys#slot bucket 0)])
- (if (eq? key (##sys#slot pare 0))
- (##sys#slot pare 1)
- (loop (##sys#slot bucket 1)) ) ) ) )
- ; Slow path
- (let loop ([bucket (##sys#slot vec hshidx)])
- (if (null? bucket)
- (def)
- (let ([pare (##sys#slot bucket 0)])
- (if (test key (##sys#slot pare 0))
- (##sys#slot pare 1)
- (loop (##sys#slot bucket 1)) ) ) ) ) ) ) ) ) )
- hash-table-set!
- "(hash-table-ref ht key . def)") )
-
-(define hash-table-ref/default
- (let ([core-eq? eq?])
- (lambda (ht key def)
- (##sys#check-structure ht 'hash-table 'hash-table-ref/default)
- (let ([vec (##sys#slot ht 1)]
- [test (##sys#slot ht 3)])
- (let* ([hash (##sys#slot ht 10)]
- [hshidx (hash key (##sys#size vec))] )
- (if (eq? core-eq? test)
- ; Fast path (eq? is rewritten by the compiler):
- (let loop ([bucket (##sys#slot vec hshidx)])
- (if (null? bucket)
- def
- (let ([pare (##sys#slot bucket 0)])
- (if (eq? key (##sys#slot pare 0))
- (##sys#slot pare 1)
- (loop (##sys#slot bucket 1)) ) ) ) )
- ; Slow path
- (let loop ([bucket (##sys#slot vec hshidx)])
- (if (null? bucket)
- def
- (let ([pare (##sys#slot bucket 0)])
- (if (test key (##sys#slot pare 0))
- (##sys#slot pare 1)
- (loop (##sys#slot bucket 1)) ) ) ) ) ) ) ) ) ) )
-
-(define hash-table-exists?
- (let ([core-eq? eq?])
- (lambda (ht key)
- (##sys#check-structure ht 'hash-table 'hash-table-exists?)
- (let ([vec (##sys#slot ht 1)]
- [test (##sys#slot ht 3)])
- (let* ([hash (##sys#slot ht 10)]
- [hshidx (hash key (##sys#size vec))] )
- (if (eq? core-eq? test)
- ; Fast path (eq? is rewritten by the compiler):
- (let loop ([bucket (##sys#slot vec hshidx)])
- (and (not (null? bucket))
- (let ([pare (##sys#slot bucket 0)])
- (or (eq? key (##sys#slot pare 0))
- (loop (##sys#slot bucket 1)) ) ) ) )
- ; Slow path
- (let loop ([bucket (##sys#slot vec hshidx)])
- (and (not (null? bucket))
- (let ([pare (##sys#slot bucket 0)])
- (or (test key (##sys#slot pare 0))
- (loop (##sys#slot bucket 1)) ) ) ) ) ) ) ) ) ) )
-
-;; hash-table-delete!:
-
-(define hash-table-delete!
- (let ([core-eq? eq?])
- (lambda (ht key)
- (##sys#check-structure ht 'hash-table 'hash-table-delete!)
- (let* ([vec (##sys#slot ht 1)]
- [len (##sys#size vec)]
- [hash (##sys#slot ht 10)]
- [hshidx (hash key len)] )
- (let ([test (##sys#slot ht 3)]
- [newsiz (fx- (##sys#slot ht 2) 1)]
- [bucket0 (##sys#slot vec hshidx)] )
- (if (eq? core-eq? test)
- ; Fast path (eq? is rewritten by the compiler):
- (let loop ([prev #f] [bucket bucket0])
- (and (not (null? bucket))
- (let ([pare (##sys#slot bucket 0)]
- [nxt (##sys#slot bucket 1)])
- (if (eq? key (##sys#slot pare 0))
- (begin
- (if prev
- (##sys#setslot prev 1 nxt)
- (##sys#setslot vec hshidx nxt) )
- (##sys#setislot ht 2 newsiz)
- #t )
- (loop bucket nxt) ) ) ) )
- ; Slow path
- (let loop ([prev #f] [bucket bucket0])
- (and (not (null? bucket))
- (let ([pare (##sys#slot bucket 0)]
- [nxt (##sys#slot bucket 1)])
- (if (test key (##sys#slot pare 0))
- (begin
- (if prev
- (##sys#setslot prev 1 nxt)
- (##sys#setslot vec hshidx nxt) )
- (##sys#setislot ht 2 newsiz)
- #t )
- (loop bucket nxt) ) ) ) ) ) ) ) ) ) )
-
-;; hash-table-remove!:
-
-(define (hash-table-remove! ht func)
- (##sys#check-structure ht 'hash-table 'hash-table-remove!)
- (##sys#check-closure func 'hash-table-remove!)
- (let* ([vec (##sys#slot ht 1)]
- [len (##sys#size vec)] )
- (let ([siz (##sys#slot ht 2)])
- (do ([i 0 (fx+ i 1)])
- [(fx>= i len) (##sys#setislot ht 2 siz)]
- (let loop ([prev #f] [bucket (##sys#slot vec i)])
- (and (not (null? bucket))
- (let ([pare (##sys#slot bucket 0)]
- [nxt (##sys#slot bucket 1)])
- (if (func (##sys#slot pare 0) (##sys#slot pare 1))
- (begin
- (if prev
- (##sys#setslot prev 1 nxt)
- (##sys#setslot vec i nxt) )
- (set! siz (fx- siz 1))
- #t )
- (loop bucket nxt ) ) ) ) ) ) ) ) )
-
-;; hash-table-clear!:
-
-(define (hash-table-clear! ht)
- (##sys#check-structure ht 'hash-table 'hash-table-clear!)
- (vector-fill! (##sys#slot ht 1) '())
- (##sys#setislot ht 2 0) )
-
-;; Hash Table Merge:
-
-(define (*hash-table-merge! ht1 ht2)
- (let* ([vec (##sys#slot ht2 1)]
- [len (##sys#size vec)] )
- (do ([i 0 (fx+ i 1)])
- [(fx>= i len) ht1]
- (do ([lst (##sys#slot vec i) (##sys#slot lst 1)])
- [(null? lst)]
- (let ([b (##sys#slot lst 0)])
- (*hash-table-update!/default ht1 (##sys#slot b 0) (lambda (x) x)
(##sys#slot b 1)) ) ) ) ) )
-
-(define (hash-table-merge! ht1 ht2)
- (##sys#check-structure ht1 'hash-table 'hash-table-merge!)
- (##sys#check-structure ht2 'hash-table 'hash-table-merge!)
- (*hash-table-merge! ht1 ht2) )
-
-(define (hash-table-merge ht1 ht2)
- (##sys#check-structure ht1 'hash-table 'hash-table-merge)
- (##sys#check-structure ht2 'hash-table 'hash-table-merge)
- (*hash-table-merge! (*hash-table-copy ht1) ht2) )
-
-;; Hash-Table <-> Association-List:
-
-(define (hash-table->alist ht)
- (##sys#check-structure ht 'hash-table 'hash-table->alist)
- (let* ([vec (##sys#slot ht 1)]
- [len (##sys#size vec)] )
- (let loop ([i 0] [lst '()])
- (if (fx>= i len)
- lst
- (let loop2 ([bucket (##sys#slot vec i)]
- [lst lst])
- (if (null? bucket)
- (loop (fx+ i 1) lst)
- (loop2 (##sys#slot bucket 1)
- (let ([x (##sys#slot bucket 0)])
- (cons (cons (##sys#slot x 0) (##sys#slot x 1)) lst) )
) ) ) ) ) ) )
-
-(define alist->hash-table
- (lambda (alist . rest)
- (##sys#check-list alist 'alist->hash-table)
- (let ([ht (apply make-hash-table rest)])
- (for-each
- (lambda (x)
- (##sys#check-pair x 'alist->hash-table)
- (*hash-table-update!/default ht (##sys#slot x 0) (lambda (x) x)
(##sys#slot x 1)) )
- alist)
- ht ) ) )
-
-;; Hash-Table Keys & Values:
-
-(define (hash-table-keys ht)
- (##sys#check-structure ht 'hash-table 'hash-table-keys)
- (let* ([vec (##sys#slot ht 1)]
- [len (##sys#size vec)] )
- (let loop ([i 0] [lst '()])
- (if (fx>= i len)
- lst
- (let loop2 ([bucket (##sys#slot vec i)]
- [lst lst])
- (if (null? bucket)
- (loop (fx+ i 1) lst)
- (loop2 (##sys#slot bucket 1)
- (let ([x (##sys#slot bucket 0)])
- (cons (##sys#slot x 0) lst) ) ) ) ) ) ) ) )
-
-(define (hash-table-values ht)
- (##sys#check-structure ht 'hash-table 'hash-table-values)
- (let* ([vec (##sys#slot ht 1)]
- [len (##sys#size vec)] )
- (let loop ([i 0] [lst '()])
- (if (fx>= i len)
- lst
- (let loop2 ([bucket (##sys#slot vec i)]
- [lst lst])
- (if (null? bucket)
- (loop (fx+ i 1) lst)
- (loop2 (##sys#slot bucket 1)
- (let ([x (##sys#slot bucket 0)])
- (cons (##sys#slot x 1) lst) ) ) ) ) ) ) ) )
-
-;; Mapping Over Hash-Table Keys & Values:
-;;
-;; hash-table-for-each:
-;; hash-table-walk:
-;; hash-table-fold:
-;; hash-table-map:
-
-(define (*hash-table-for-each ht proc)
- (let* ([vec (##sys#slot ht 1)]
- [len (##sys#size vec)] )
- (do ([i 0 (fx+ i 1)] )
- [(fx>= i len)]
- (##sys#for-each (lambda (bucket)
- (proc (##sys#slot bucket 0) (##sys#slot bucket 1)) )
- (##sys#slot vec i)) ) ) )
-
-(define (*hash-table-fold ht func init)
- (let* ([vec (##sys#slot ht 1)]
- [len (##sys#size vec)] )
- (let loop ([i 0] [acc init])
- (if (fx>= i len)
- acc
- (let fold2 ([bucket (##sys#slot vec i)]
- [acc acc])
- (if (null? bucket)
- (loop (fx+ i 1) acc)
- (let ([pare (##sys#slot bucket 0)])
- (fold2 (##sys#slot bucket 1)
- (func (##sys#slot pare 0) (##sys#slot pare 1) acc) ) )
) ) ) ) ) )
-
-(define (hash-table-fold ht func init)
- (##sys#check-structure ht 'hash-table 'hash-table-fold)
- (##sys#check-closure func 'hash-table-fold)
- (*hash-table-fold ht func init) )
-
-(define (hash-table-for-each ht proc)
- (##sys#check-structure ht 'hash-table 'hash-table-for-each)
- (##sys#check-closure proc 'hash-table-for-each)
- (*hash-table-for-each ht proc) )
-
-(define (hash-table-walk ht proc)
- (##sys#check-structure ht 'hash-table 'hash-table-walk)
- (##sys#check-closure proc 'hash-table-walk)
- (*hash-table-for-each ht proc) )
-
-(define (hash-table-map ht func)
- (##sys#check-structure ht 'hash-table 'hash-table-map)
- (##sys#check-closure func 'hash-table-map)
- (*hash-table-fold ht (lambda (k v a) (cons (func k v) a)) '()) )
-
-
-;;; printing
-
-(##sys#register-record-printer
- 'hash-table
- (lambda (ht port)
- (##sys#print "#<hash-table (" #f port)
- (##sys#print (##sys#slot ht 2) #f port)
- (##sys#print ")>" #f port) ) )
diff --git a/tests/feeley-dynwind.scm b/tests/feeley-dynwind.scm
deleted file mode 100644
index fd103ec..0000000
--- a/tests/feeley-dynwind.scm
+++ /dev/null
@@ -1,71 +0,0 @@
-;;; by Marc Feeley
-;
-; This fails. Currently to heavy stuff to debug
-
-(use srfi-18)
-
-(define (dw tag thunk)
- (dynamic-wind
- (lambda () (pp (list 'before tag (current-thread))))
- thunk
- (lambda () (pp (list 'after tag (current-thread))))))
-
-(define c1 #f)
-(define c2 #f)
-(define c3 #f)
-(define c4 #f)
-
-(define (f)
- (call/cc
- (lambda (k1)
- (set! c1 k1)
- (dw 111
- (lambda ()
- (call/cc
- (lambda (k2)
- (set! c2 k2)
- (dw 222
- (lambda ()
- (call/cc
- (lambda (k3)
- (set! c3 k3)
- (dw 333
- (lambda ()
- (call/cc
- (lambda (k4)
- (set! c4 k4)
-; (xxx) ;; error
- (pp 'inner)))))))))))))))
- (pp (list 'done (current-thread))))
-
-(thread-join!
- (thread-start!
- (make-thread (lambda () (f)))))
-
-(thread-join!
- (thread-start!
- (make-thread (lambda () (c4 'dummy)))))
-
-(thread-join!
- (thread-start!
- (make-thread (lambda () (c1 'dummy)))))
-
-
-;; expected result:
-
-;; (before 111 #<thread #2>)
-;; (before 222 #<thread #2>)
-;; (before 333 #<thread #2>)
-;; inner
-;; (after 333 #<thread #2>)
-;; (after 222 #<thread #2>)
-;; (after 111 #<thread #2>)
-;; (done #<thread #2>)
-;; (before 111 #<thread #3>)
-;; (before 222 #<thread #3>)
-;; (before 333 #<thread #3>)
-;; (after 333 #<thread #3>)
-;; (after 222 #<thread #3>)
-;; (after 111 #<thread #3>)
-;; (done #<thread #3>)
-;; (done #<thread #4>)
diff --git a/tests/hash-table-tests.scm b/tests/hash-table-tests.scm
deleted file mode 100644
index 99960bd..0000000
--- a/tests/hash-table-tests.scm
+++ /dev/null
@@ -1,242 +0,0 @@
-;;;; hash-table-tests.scm
-
-(require-extension srfi-69 data-structures extras)
-
-(print "SRFI 69 procedures")
-(assert (eq? hash equal?-hash))
-(assert (eq? hash-by-identity eq?-hash))
-
-;; Re-use variable
-(define ht)
-
-(print "HT - No Parameters")
-(set! ht (make-hash-table))
-(assert (hash-table? ht))
-(assert (eq? equal? (hash-table-equivalence-function ht)))
-(assert (eq? equal?-hash (hash-table-hash-function ht)))
-(assert (not (hash-table-has-initial? ht)))
-
-(print "HT - Test Parameter")
-(set! ht (make-hash-table eq?))
-(assert (hash-table? ht))
-(assert (eq? eq? (hash-table-equivalence-function ht)))
-(assert (eq? eq?-hash (hash-table-hash-function ht)))
-(assert (not (hash-table-has-initial? ht)))
-
-(print "HT - Number Test Parameter")
-(set! ht (make-hash-table =))
-(assert (hash-table? ht))
-(assert (eq? = (hash-table-equivalence-function ht)))
-(assert (eq? number-hash (hash-table-hash-function ht)))
-(assert (not (hash-table-has-initial? ht)))
-
-(print "HT - All Optional Parameters")
-(set! ht (make-hash-table eqv? eqv?-hash 23))
-(assert (hash-table? ht))
-(assert (not (hash-table-has-initial? ht)))
-
-(print "HT - All Parameters")
-(set! ht (make-hash-table eqv? eqv?-hash 23
- #:test equal? #:hash equal?-hash
- #:initial 'foo
- #:size 500
- #:min-load 0.45 #:max-load 0.85
- #:weak-keys #t #:weak-values #t))
-(assert (hash-table? ht))
-(assert (not (hash-table-weak-keys ht)))
-(assert (not (hash-table-weak-values ht)))
-(assert (eq? equal? (hash-table-equivalence-function ht)))
-(assert (eq? equal?-hash (hash-table-hash-function ht)))
-(assert (hash-table-has-initial? ht))
-(assert (eq? (hash-table-initial ht) 'foo))
-
-(print "HT - Insert with setter")
-(set! (hash-table-ref ht 23.0) 'bar)
-(assert (eq? (hash-table-ref ht 23.0) 'bar))
-
-(print "HT - Insert with update!")
-(hash-table-update! ht 'baz identity (lambda () 'foo))
-(assert (eq? (hash-table-ref ht 'baz) 'foo))
-(assert (= (hash-table-size ht) 2))
-
-(print "HT - A-List")
-(let ([alist (hash-table->alist ht)])
- (assert (list? alist))
- (assert (= (length alist) 2))
- (assert (eq? (alist-ref 23.0 alist) 'bar))
- (assert (eq? (alist-ref 'baz alist) 'foo)) )
-
-(print "HT - set! overwrites")
-(hash-table-set! ht 23.0 'foo-bar)
-(assert (eq? (hash-table-ref ht 23.0) 'foo-bar))
-
-(print "HT - Delete")
-(assert (hash-table-delete! ht 23.0))
-(assert (not (hash-table-exists? ht 23.0)))
-(assert (= (hash-table-size ht) 1))
-
-(print "HT - Remove")
-(assert (hash-table-remove! ht (lambda (k v) (eq? k 'baz))))
-(assert (not (hash-table-exists? ht 'baz)))
-(assert (= (hash-table-size ht) 0))
-
-(print "HT - Make from A-List")
-(set! ht (alist->hash-table '(("abc" . #t) ("cbs" . #t) ("cnn" . #f))))
-(assert (hash-table? ht))
-(assert (= (hash-table-size ht) 3))
-
-(print "HT - Merge!")
-(let ([ht2 (make-hash-table)])
- (set! (hash-table-ref ht2 23.0) 'bar)
- (set! (hash-table-ref ht2 'baz) 'foo)
- (let ([ht3 (hash-table-merge! ht2 ht)])
- (assert (eq? ht3 ht2))
- (assert (not (eq? ht3 ht)))
- (let ([alist (hash-table->alist ht3)])
- (assert (list? alist))
- (assert (= (length alist) 5))
- (assert (eq? (alist-ref "abc" alist equal?) #t))
- (assert (eq? (alist-ref "cbs" alist equal?) #t))
- (assert (eq? (alist-ref "cnn" alist equal?) #f))
- (assert (eq? (alist-ref 23.0 alist) 'bar))
- (assert (eq? (alist-ref 'baz alist) 'foo)) ) ) )
-
-(print "HT - Merge")
-(let ([ht2 (make-hash-table)])
- (set! (hash-table-ref ht2 23.0) 'bar)
- (set! (hash-table-ref ht2 'baz) 'foo)
- (let ([ht3 (hash-table-merge ht2 ht)])
- (assert (not (eq? ht3 ht2)))
- (assert (not (eq? ht3 ht)))
- (let ([alist (hash-table->alist ht3)])
- (assert (list? alist))
- (assert (= (length alist) 5))
- (assert (eq? (alist-ref "abc" alist equal?) #t))
- (assert (eq? (alist-ref "cbs" alist equal?) #t))
- (assert (eq? (alist-ref "cnn" alist equal?) #f))
- (assert (eq? (alist-ref 23.0 alist) 'bar))
- (assert (eq? (alist-ref 'baz alist) 'foo)) ) ) )
-
-(print "HT - Map")
-(let ([alist (hash-table-map ht (lambda (k v) (cons k v)))])
- (assert (list? alist))
- (assert (= (length alist) 3)) )
-
-(print "HT - Fold")
-(let ([alist (hash-table-fold ht (lambda (k v a) (cons (cons k v) a)) '())])
- (assert (list? alist))
- (assert (= (length alist) 3)) )
-
-(print "HT - Built-in string hash function")
-(set! ht (make-hash-table string=?))
-(hash-table-set! ht "test" 123)
-(hash-table-set! ht "one" 1)
-(assert (= 123 (hash-table-ref ht "test")))
-(assert (= 1 (hash-table-ref ht "one")))
-
-;; Issue #818, found by Jim Ursetto (srfi-13 defines its own string-hash)
-(print "HT - After overwriting 'string-hash' should still work")
-(set! string-hash (lambda (x) (error "Wrong string-hash called")))
-(set! ht (make-hash-table string=?))
-(hash-table-set! ht "foo" "bar")
-(assert (string=? (hash-table-ref ht "foo") "bar"))
-
-(set! ht (make-hash-table equal? (lambda (object bounds)
- (case object
- ((test) 0)
- ((one two) 1)
- (else (+ bounds 1))))))
-(print "HT - custom hash function")
-(hash-table-set! ht 'test 123)
-(hash-table-set! ht 'one 1)
-(hash-table-set! ht 'two 2)
-(assert (= 123 (hash-table-ref ht 'test)))
-(assert (= 1 (hash-table-ref ht 'one)))
-(assert (= 2 (hash-table-ref ht 'two)))
-
-(print "HT - out of bounds value is caught")
-(assert (handle-exceptions exn #t (hash-table-set! ht 'out-of-bounds 123) #f))
-
-(print "Hash collision weaknesses")
-;; If these fail, it might be bad luck caused by the randomization/modulo combo
-;; So don't *immediately* dismiss a hash implementation when it fails here
-(assert (not (= (hash "a" 10 1) (hash "a" 10 2))))
-(assert (not (= (hash (make-string 1 #\nul) 10 10) 0)))
-;; Long identical suffixes should not hash to the same value
-(assert (not (= (hash (string-append (make-string 1000000 #\a)
- (make-string 1000000 #\c)) 10 1)
- (hash (string-append (make-string 1000000 #\b)
- (make-string 1000000 #\c)) 10 1))))
-;; Same for prefixes
-(assert (not (= (hash (string-append (make-string 1000000 #\a)
- (make-string 1000000 #\b)) 10 1)
- (hash (string-append (make-string 1000000 #\a)
- (make-string 1000000 #\c)) 10 1))))
-;; And palindromes, too
-(assert (not (= (hash (string-append (make-string 1000000 #\a)
- (make-string 1000000 #\b)
- (make-string 1000000 #\a)) 10 1)
- (hash (string-append (make-string 1000000 #\a)
- (make-string 1000000 #\c)
- (make-string 1000000 #\a)) 10 1))))
-;; differing number of nul bytes should not be identical
-(assert (not (= (hash (make-string 1 #\nul) 10 1)
- (hash (make-string 2 #\nul) 10 1))))
-;; ensure very long NUL strings don't cause the random value to get pushed out
-(assert (not (= (hash (make-string 1000000 #\nul) 10 1)
- (hash (make-string 1000001 #\nul) 10 1))))
-
-;; Stress Test
-
-(set! ht (make-hash-table))
-
-(define-constant stress-size 100000)
-
-(print "HT - Stress Insert " stress-size " Fixnum Key Items")
-(time
- (do ([i 0 (fx+ i 1)])
- [(fx= i stress-size)]
- (set! (hash-table-ref ht i) i) ) )
-
-(print "HT - Stress Retrieve " stress-size " Fixnum Key Items")
-(time
- (do ([i 0 (fx+ i 1)])
- [(fx= i stress-size)]
- (assert (fx= i (hash-table-ref ht i))) ) )
-
-(print "HT - copy")
-(define l '((1 a) (2 b) (3 c)))
-(set! ht (alist->hash-table l))
-(define ht2 (hash-table-copy ht))
-(assert (= (hash-table-size ht2) (hash-table-size ht)))
-(print l " -- " (hash-table->alist ht2))
-(assert (equal? l (sort (hash-table->alist ht2)
- (lambda (e1 e2) (< (car e1) (car e2))))))
-;; Ensure that lookup still works (#905, randomization value was reset)
-(assert (equal? '(a) (hash-table-ref ht2 1)))
-
-(print "HT - recursive depth/length")
-(assert (fixnum? (recursive-hash-max-depth)))
-(assert (positive? (recursive-hash-max-depth)))
-(assert (fixnum? (recursive-hash-max-length)))
-(assert (positive? (recursive-hash-max-length)))
-
-(let ((dd (recursive-hash-max-depth))
- (tls (list (random 100000) (random 100000) (list (random 100000) (list
(random 100000) (list (random 100000) (list (random 100000) (list (random
100000) (list (random 100000) (list (random 100000) (list (random 100000) (list
(random 100000) (list (random 100000) (list (random 100000) (list (random
100000))))))))))))))))
- (let ((hsh1 (equal?-hash tls 536870912 0)))
- (recursive-hash-max-depth 10)
- (assert (fx= 10 (recursive-hash-max-depth)))
- (let ((hsh2 (equal?-hash tls 536870912 0)))
- (recursive-hash-max-depth dd)
- (print hsh1 " <?> " hsh2)
- (assert (not (= hsh1 hsh2))) ) ) )
-
-(let ((dl (recursive-hash-max-length))
- (tv (vector (random 100000) (random 100000) (random 100000) (random
100000) (random 100000) (random 100000) (random 100000) (random 100000) (random
100000) (random 100000) (random 100000) (random 100000))))
- (let ((hsh1 (equal?-hash tv 536870912 0)))
- (recursive-hash-max-length 10)
- (assert (fx= 10 (recursive-hash-max-length)))
- (let ((hsh2 (equal?-hash tv 536870912 0)))
- (recursive-hash-max-length dl)
- (print hsh1 " <?> " hsh2)
- (assert (not (= hsh1 hsh2))) ) ) )
diff --git a/tests/loopy-test.scm b/tests/loopy-test.scm
index 86d450b..43978f6 100644
--- a/tests/loopy-test.scm
+++ b/tests/loopy-test.scm
@@ -1,7 +1,6 @@
(load-relative "loopy-loop.scm")
(load-relative "matchable.scm")
-(require-extension srfi-69)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SRFI-64 subset + test-approx=
@@ -190,12 +189,5 @@
(loop ((p <- in-combinations '(a b c) 2) (res <- collecting p)) => res)
'((a b) (a c) (b c)))
-(test-equal
- "in-hash-table"
- (loop ((k v <- in-hash-table (alist->hash-table '((a . 1))))
- (res <- collecting (cons k v)))
- => res)
- '((a . 1)))
-
(test-end "loop")
diff --git a/tests/mutex-test.scm b/tests/mutex-test.scm
deleted file mode 100644
index 8962a1e..0000000
--- a/tests/mutex-test.scm
+++ /dev/null
@@ -1,76 +0,0 @@
-;;;; mutex-test.scm
-
-
-(require-extension srfi-18)
-
-(cond-expand (dribble
-(define-for-syntax count 0)
-(define-syntax trail
- (lambda (form r c) ; doesn't bother much with renaming
- (let ((loc (cadr form))
- (expr (caddr form)))
- (set! count (add1 count))
- `(,(r 'begin)
- (print "(" ,count ") " ,loc ": " ',expr ": get: " (##sys#slot get-mutex
5) ", put: " (##sys#slot put-mutex 5))
- (let ((xxx ,expr))
- (print " (" ,count ") " ,loc ": " ',expr ": get: " (##sys#slot
get-mutex 5) ", put: " (##sys#slot put-mutex 5))
- xxx) ) ))))
-(else (define-syntax trail (syntax-rules () ((_ loc expr) expr)))))
-
-(define (tprint . x)
- (printf "~a " (current-milliseconds))
- (apply print x))
-
-(define (make-empty-mailbox)
- (let ((put-mutex (make-mutex)) ; allow put! operation
- (get-mutex (make-mutex))
- (cell #f))
-
- (define (put! obj)
- (trail 'put! (mutex-lock! put-mutex #f #f)) ; prevent put! operation
- (set! cell obj)
- (trail 'put! (mutex-unlock! get-mutex)) )
-
- (define (get!)
- (trail 'get! (mutex-lock! get-mutex #f #f)) ; wait until object in
mailbox
- (let ((result cell))
- (set! cell #f) ; prevent space leaks
- (trail 'get! (mutex-unlock! put-mutex)) ; allow put! operation
- result))
-
- (trail 'main (mutex-lock! get-mutex #f #f)) ; prevent get! operation
-
- (lambda (print)
- (case print
- ((put!) put!)
- ((get!) get!)
- (else (error "unknown message"))))))
-
-(define (mailbox-put! m obj) ((m 'put!) obj))
-(define (mailbox-get! m) ((m 'get!)))
-
-;(tprint 'start)
-
-(define mb (make-empty-mailbox))
-
-(thread-start!
- (make-thread
- (lambda ()
- (let lp ()
- ;(print "1: get")
- (let ((x (mailbox-get! mb)))
- ;(tprint "read: " x)
- (assert x)
- (lp))))))
-
-(thread-start!
- (make-thread
- (lambda ()
- (thread-sleep! 1)
- ;(tprint 'put)
- ;(print "2: put")
- (mailbox-put! mb 'test)
- #;(print "2: endput"))))
-
-(thread-sleep! 3)
-;(tprint 'exit)
diff --git a/tests/port-tests.scm b/tests/port-tests.scm
index 259892c..3577794 100644
--- a/tests/port-tests.scm
+++ b/tests/port-tests.scm
@@ -258,27 +258,6 @@ EOF
(define (read-echo-line/pos str limit)
(read-process-line/pos "echo" (list "-n" str) limit))
-(use srfi-18)
-(define (read-tcp-line/pos str limit)
- (let ((pn 8079))
- (thread-start! (lambda ()
- (let ((L (tcp-listen pn)))
- (let-values (((i o) (tcp-accept L)))
- (display str o)
- (close-input-port i)
- (close-output-port o)
- (tcp-close L)))))
- (let-values (((i o)
- (let lp ((n 10))
- (if (zero? n)
- (error "timeout connecting to server")
- (condition-case (tcp-connect "localhost" pn)
- ((exn i/o net) (thread-sleep! 0.1) (lp
(- n 1))))))))
- (let ((rc (read-line/pos i limit)))
- (close-input-port i)
- (close-output-port o)
- rc))))
-
(define (test-port-position proc)
(test-equal "advance row when encountering delim"
(proc "abcde\nfghi" 6)
@@ -382,14 +361,6 @@ EOF
"read-line process port position tests"
(test-port-position read-echo-line/pos))
-;; Disabled because currently fragile if port is already taken by
-;; another service.
-;; Uncomment locally to run.
-#;
-(test-group
- "read-line TCP port position tests"
- (test-port-position read-tcp-line/pos))
-
;;;
(test-end)
diff --git a/tests/reexport-m1.scm b/tests/reexport-m1.scm
index 0253877..ae18619 100644
--- a/tests/reexport-m1.scm
+++ b/tests/reexport-m1.scm
@@ -2,5 +2,5 @@
(module reexport-m1 ()
(import scheme chicken)
- (require-library srfi-1 srfi-69)
- (reexport (only srfi-1 cons*) srfi-69))
+ (require-library srfi-1)
+ (reexport (only srfi-1 cons*)))
diff --git a/tests/runtests.bat b/tests/runtests.bat
index c7f0f2b..bb3186e 100644
--- a/tests/runtests.bat
+++ b/tests/runtests.bat
@@ -146,8 +146,6 @@ a.out >dwindtst.out
if errorlevel 1 exit /b 1
fc /w dwindtst.expected dwindtst.out
if errorlevel 1 exit /b 1
-echo *** Skipping "feeley-dynwind" for now ***
-rem %interpret% -s feeley-dynwind.scm
echo ======================================== lolevel tests ...
%interpret% -s lolevel-tests.scm
@@ -346,10 +344,6 @@ if errorlevel 1 exit /b 1
rem %compile% ec-tests.scm
rem a.out # takes ages to compile
-echo ======================================== hash-table tests ...
-%interpret% -s hash-table-tests.scm
-if errorlevel 1 exit /b 1
-
echo ======================================== port tests ...
%interpret% -s port-tests.scm
if errorlevel 1 exit /b 1
@@ -380,12 +374,6 @@ echo ======================================== condition
tests ...
%interpret% -s condition-tests.scm
if errorlevel 1 exit /b 1
-echo ======================================== srfi-18 tests ...
-%interpret% -s simple-thread-test.scm
-if errorlevel 1 exit /b 1
-%interpret% -s mutex-test.scm
-if errorlevel 1 exit /b 1
-
echo ======================================== data-structures tests ...
%interpret% -s data-structures-tests.scm
if errorlevel 1 exit /b 1
diff --git a/tests/runtests.sh b/tests/runtests.sh
index 1237f82..53389ac 100755
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -39,9 +39,9 @@ for x in setup-api.so setup-api.import.so setup-download.so \
setup-download.import.so chicken.import.so lolevel.import.so \
srfi-1.import.so srfi-4.import.so data-structures.import.so \
ports.import.so files.import.so posix.import.so \
- srfi-69.import.so extras.import.so \
+ extras.import.so \
irregex.import.so srfi-14.import.so tcp.import.so \
- foreign.import.so srfi-18.import.so \
+ foreign.import.so \
utils.import.so csi.import.so irregex.import.so types.db; do
cp ../$x test-repository
done
@@ -160,8 +160,6 @@ diff $DIFF_OPTS dwindtst.expected dwindtst.out
$compile dwindtst.scm
./a.out >dwindtst.out
diff $DIFF_OPTS dwindtst.expected dwindtst.out
-echo "*** Skipping \"feeley-dynwind\" for now ***"
-# $interpret -s feeley-dynwind.scm
echo "======================================== lolevel tests ..."
$interpret -s lolevel-tests.scm
@@ -292,9 +290,6 @@ $interpret -bnq ec.so ec-tests.scm
# $compile ec-tests.scm
# ./a.out # takes ages to compile
-echo "======================================== hash-table tests ..."
-$interpret -s hash-table-tests.scm
-
echo "======================================== port tests ..."
$interpret -s port-tests.scm
@@ -316,12 +311,6 @@ $compile srfi-14-tests.scm
echo "======================================== condition tests ..."
$interpret -s condition-tests.scm
-echo "======================================== srfi-18 tests ..."
-$interpret -s simple-thread-test.scm
-$interpret -s mutex-test.scm
-$compile srfi-18-signal-test.scm
-./a.out
-
echo "======================================== data-structures tests ..."
$interpret -s data-structures-tests.scm
@@ -344,10 +333,6 @@ fi
$interpret -R posix -e '(delete-directory "tmpdir" #t)'
-echo "======================================== signal tests ..."
-$compile signal-tests.scm
-./a.out
-
echo "======================================== regular expression tests ..."
$interpret -bnq test-irregex.scm
$interpret -bnq test-glob.scm
diff --git a/tests/signal-tests.scm b/tests/signal-tests.scm
index 0289fdc..9c07a8c 100644
--- a/tests/signal-tests.scm
+++ b/tests/signal-tests.scm
@@ -7,7 +7,7 @@
(exit))
-(use posix srfi-18 extras)
+(use posix extras)
(define all-go? (make-parameter #f))
diff --git a/tests/simple-thread-test.scm b/tests/simple-thread-test.scm
deleted file mode 100644
index 0e77eb5..0000000
--- a/tests/simple-thread-test.scm
+++ /dev/null
@@ -1,19 +0,0 @@
-;;;; simple-thread-test.scm
-
-
-(use srfi-18 extras)
-
-
-(define (spin)
- (do ((i 0 (add1 i)))
- ((>= i 10))
- (print (current-thread) " sleeps ...")
- (thread-sleep! (random 3)))
- (print (current-thread) " finished."))
-
-(thread-start! spin)
-(thread-start! spin)
-(spin)
-(print (current-thread) " waits ...")
-(thread-sleep! 3)
-(print "end.")
diff --git a/tests/thread-list.scm b/tests/thread-list.scm
deleted file mode 100644
index 74ffdd6..0000000
--- a/tests/thread-list.scm
+++ /dev/null
@@ -1,44 +0,0 @@
-;;;; thread-list.scm
-;
-; usage: csi -s thread-list.scm [COUNT]
-
-(use srfi-18)
-
-
-(define count #f)
-
-(define (run n)
- (set! count n)
- (print "creating " n " threads ...")
- (let loop ((n n) (prev #f))
- (cond ((negative? n)
- (print "starting ...")
- (thread-start! prev))
- (else
- (loop
- (sub1 n)
- (make-thread
- (lambda ()
- (bump n)
- (thread-start! prev))))))))
-
-(define (bump n)
- (set! count (sub1 count))
- (cond ((zero? count)
- (newline)
- (exit))
- ((and (zero? (modulo n 10000)) (##sys#fudge 13))
- (print* "."))))
-
-(run (string->number (optional (command-line-arguments) "250000")))
-(thread-sleep! 604800)
-
-
-; time csi -s thread-list.scm 1000000 -:h1g
-; 11 secs
-;
-; csc thread-list.scm -o a.out -v -O4 -f -d0
-; time a.out 1000000 -:h1g
-; 4 secs
-;
-; (x86, Core2 Duo, 2.4Ghz, 2GB RAM)
diff --git a/types.db b/types.db
index 79ecec5..96f209b 100644
--- a/types.db
+++ b/types.db
@@ -2106,84 +2106,6 @@
(ucs-range->char-set! (#(procedure #:clean #:enforce) ucs-range->char-set!
(fixnum fixnum #!optional * (struct char-set)) (struct char-set)))
-;; srfi-18
-
-(abandoned-mutex-exception? (#(procedure #:pure) abandoned-mutex-exception?
(*) boolean))
-(condition-variable-broadcast! (#(procedure #:clean #:enforce)
condition-variable-broadcast! ((struct condition-variable)) undefined))
-(condition-variable-name (#(procedure #:clean #:enforce)
condition-variable-name ((struct condition-variable)) *))
-(condition-variable-signal! (#(procedure #:clean #:enforce)
condition-variable-signal! ((struct condition-variable)) undefined))
-(condition-variable-specific (#(procedure #:clean #:enforce)
condition-variable-specific ((struct condition-variable)) *))
-(condition-variable-specific-set! (#(procedure #:clean #:enforce)
condition-variable-specific-set! ((struct condition-variable) *) undefined))
-
-(condition-variable? (#(procedure #:pure #:predicate (struct
condition-variable))
- condition-variable? (*)
- boolean))
-
-(current-thread (#(procedure #:clean) current-thread () (struct thread))) ;XXX
-
-(current-time (#(procedure #:clean) current-time () (struct time)))
-(join-timeout-exception? (#(procedure #:pure) join-timeout-exception? (*)
boolean))
-(make-condition-variable (#(procedure #:clean) make-condition-variable
(#!optional *) (struct condition-variable)))
-(make-mutex (#(procedure #:clean) make-mutex (#!optional *) (struct mutex)))
-(make-thread (#(procedure #:clean #:enforce) make-thread ((procedure () . *)
#!optional *) (struct thread)))
-(mutex-lock! (#(procedure #:clean #:enforce) mutex-lock! ((struct mutex)
#!optional (or false number (struct time)) (or false (struct thread))) boolean))
-
-(mutex-name (#(procedure #:clean #:enforce) mutex-name ((struct mutex)) *)
- (((struct mutex)) (##sys#slot #(1) '1)))
-
-(mutex-specific (#(procedure #:clean #:enforce) mutex-specific ((struct
mutex)) *)
- (((struct mutex)) (##sys#slot #(1) '6)))
-
-(mutex-specific-set! (#(procedure #:clean #:enforce) mutex-specific-set!
((struct mutex) *) undefined)
- (((struct mutex) *) (##sys#setslot #(1) '6 #(2))))
-
-(mutex-state (#(procedure #:clean #:enforce) mutex-state ((struct mutex)) (or
symbol (struct thread))))
-(mutex-unlock! (#(procedure #:clean #:enforce) mutex-unlock! ((struct mutex)
#!optional (struct condition-variable) *) undefined))
-
-(mutex? (#(procedure #:pure #:predicate (struct mutex)) mutex? (*) boolean))
-
-(raise (procedure raise (*) noreturn))
-(seconds->time (#(procedure #:clean #:enforce) seconds->time (number) (struct
time)))
-(terminated-thread-exception? (#(procedure #:pure)
terminated-thread-exception? (*) boolean))
-(thread-join! (#(procedure #:clean #:enforce) thread-join! ((struct thread)
#!optional * *) . *))
-
-(thread-name (#(procedure #:clean #:enforce) thread-name ((struct thread)) *)
- (((struct thread)) (##sys#slot #(1) '6)))
-
-(thread-quantum (#(procedure #:clean #:enforce) thread-quantum ((struct
thread)) fixnum)
- (((struct thread)) (##sys#slot #(1) '9)))
-
-(thread-quantum-set! (#(procedure #:clean #:enforce) thread-quantum-set!
((struct thread) fixnum) undefined))
-(thread-resume! (#(procedure #:clean #:enforce) thread-resume! ((struct
thread)) undefined))
-(thread-signal! (#(procedure #:clean #:enforce) thread-signal! ((struct
thread) *) undefined))
-(thread-sleep! (#(procedure #:clean) thread-sleep! (*) undefined))
-
-(thread-specific (#(procedure #:clean #:enforce) thread-specific ((struct
thread)) *)
- (((struct thread)) (##sys#slot #(1) '10)))
-
-(thread-specific-set! (#(procedure #:clean #:enforce) thread-specific-set!
((struct thread) *) undefined)
- (((struct thread) *) (##sys#setslot #(1) '10 #(2))))
-
-(thread-start! (#(procedure #:enforce) thread-start! ((or (struct thread)
(procedure () . *))) (struct thread)))
-
-(thread-state (#(procedure #:clean #:enforce) thread-state ((struct thread))
symbol)
- (((struct thread)) (##sys#slot #(1) '3)))
-
-(thread-suspend! (#(procedure #:clean #:enforce) thread-suspend! ((struct
thread)) undefined))
-(thread-terminate! (#(procedure #:clean #:enforce) thread-terminate! ((struct
thread)) undefined))
-(thread-wait-for-i/o! (#(procedure #:clean #:enforce) thread-wait-for-i/o!
(fixnum #!optional symbol) undefined))
-(thread-yield! (#(procedure #:clean) thread-yield! () undefined))
-
-(thread? (#(procedure #:pure #:predicate (struct thread)) thread? (*) boolean))
-
-(time->seconds (#(procedure #:clean #:enforce) time->seconds ((struct time))
number))
-
-(time? (#(procedure #:pure #:predicate (struct time)) time? (*) boolean))
-
-(uncaught-exception-reason (#(procedure #:clean #:enforce)
uncaught-exception-reason ((struct condition)) *))
-(uncaught-exception? (#(procedure #:pure) uncaught-exception? (*) boolean))
-
-
;; srfi-4
(blob->f32vector (#(procedure #:clean #:enforce) blob->f32vector (blob)
(struct f32vector)))
@@ -2339,76 +2261,6 @@
(##sys#srfi-4-vector? (#(procedure #:pure #:predicate (or (struct u8vector)
(struct u16vector) (struct s8vector) (struct s16vector) (struct u32vector)
(struct s32vector) (struct f32vector) (struct f64vector))) ##sys#srfi-4-vector?
(*) boolean))
-;; srfi-69
-
-(alist->hash-table (#(procedure #:clean #:enforce) alist->hash-table ((list-of
pair) #!rest) (struct hash-table)))
-(eq?-hash (#(procedure #:clean #:enforce) eq?-hash (* #!optional fixnum
fixnum) fixnum))
-(equal?-hash (#(procedure #:clean #:enforce) equal?-hash (* #!optional fixnum
fixnum) fixnum))
-(eqv?-hash (#(procedure #:clean #:enforce) eqv?-hash (* #!optional fixnum
fixnum) fixnum))
-(hash (#(procedure #:pure #:enforce) hash (* #!optional fixnum fixnum) fixnum))
-(hash-by-identity (#(procedure #:pure #:enforce) hash-by-identity (*
#!optional fixnum fixnum) fixnum))
-(hash-table->alist (#(procedure #:clean #:enforce) hash-table->alist ((struct
hash-table)) (list-of pair)))
-(hash-table-clear! (#(procedure #:clean #:enforce) hash-table-clear! ((struct
hash-table)) undefined))
-(hash-table-copy (#(procedure #:clean #:enforce) hash-table-copy ((struct
hash-table)) (struct hash-table)))
-(hash-table-delete! (#(procedure #:clean #:enforce) hash-table-delete!
((struct hash-table) *) boolean))
-(hash-table-equivalence-function (#(procedure #:clean #:enforce)
hash-table-equivalence-function ((struct hash-table)) (procedure (* *) *)))
-(hash-table-exists? (#(procedure #:clean #:enforce) hash-table-exists?
((struct hash-table) *) boolean))
-(hash-table-fold (#(procedure #:enforce) hash-table-fold ((struct hash-table)
(procedure (* * *) *) *) *))
-(hash-table-for-each (#(procedure #:enforce) hash-table-for-each ((struct
hash-table) (procedure (* *) . *)) undefined))
-
-(hash-table-has-initial? (#(procedure #:clean #:enforce)
hash-table-has-initial? ((struct hash-table)) boolean)
- (((struct hash-table)) (##sys#slot #(1) '9))) ;XXX
might return other than #t
-
-(hash-table-hash-function (#(procedure #:clean #:enforce)
hash-table-hash-function ((struct hash-table)) (procedure (* fixnum) fixnum))
- (((struct hash-table)) (##sys#slot #(1) '4)))
-
-(hash-table-initial (#(procedure #:clean #:enforce) hash-table-initial
((struct hash-table)) *))
-(hash-table-keys (#(procedure #:clean #:enforce) hash-table-keys ((struct
hash-table)) list))
-(hash-table-map (#(procedure #:clean #:enforce) hash-table-map ((struct
hash-table) (procedure (* *) *)) list))
-
-(hash-table-max-load (#(procedure #:clean #:enforce) hash-table-max-load
((struct hash-table)) fixnum)
- (((struct hash-table)) (##sys#slot #(1) '6)))
-
-(hash-table-merge (#(procedure #:clean #:enforce) hash-table-merge ((struct
hash-table) (struct hash-table)) (struct hash-table)))
-(hash-table-merge! (#(procedure #:clean #:enforce) hash-table-merge! ((struct
hash-table) (struct hash-table)) undefined))
-
-(hash-table-min-load (#(procedure #:clean #:enforce) hash-table-min-load
((struct hash-table)) fixnum)
- (((struct hash-table)) (##sys#slot #(1) '5)))
-
-(hash-table-ref (#(procedure #:clean #:enforce) hash-table-ref ((struct
hash-table) * #!optional (procedure () *)) *))
-(hash-table-ref/default (#(procedure #:clean #:enforce) hash-table-ref/default
((struct hash-table) * *) *))
-(hash-table-remove! (#(procedure #:clean #:enforce) hash-table-remove!
((struct hash-table) (procedure (* *) *)) undefined))
-(hash-table-set! (#(procedure #:clean #:enforce) hash-table-set! ((struct
hash-table) * *) undefined))
-
-(hash-table-size (#(procedure #:clean #:enforce) hash-table-size ((struct
hash-table)) fixnum)
- (((struct hash-table)) (##sys#slot #(1) '2)))
-
-(hash-table-update! (#(procedure #:enforce) hash-table-update! ((struct
hash-table) * (procedure (*) *) #!optional (procedure () *)) *))
-(hash-table-update!/default (#(procedure #:clean #:enforce)
hash-table-update!/default ((struct hash-table) * (procedure (*) *) *) *))
-(hash-table-values (#(procedure #:clean #:enforce) hash-table-values ((struct
hash-table)) list))
-(hash-table-walk (#(procedure #:enforce) hash-table-walk ((struct hash-table)
(procedure (* *) . *)) undefined))
-
-(hash-table-weak-keys (#(procedure #:clean #:enforce) hash-table-weak-keys
((struct hash-table)) boolean)
- (((struct hash-table)) (##sys#slot #(1) '7)))
-
-(hash-table-weak-values (#(procedure #:clean #:enforce) hash-table-weak-values
((struct hash-table)) boolean)
- (((struct hash-table)) (##sys#slot #(1) '8)))
-
-(hash-table? (#(procedure #:pure #:predicate (struct hash-table)) hash-table?
(*) boolean))
-
-;;XXX if we want to hardcode hash-default-bound here, we could rewrite the
1-arg case...
-; (applies to all hash-functions)
-(keyword-hash (#(procedure #:clean #:enforce) keyword-hash (* #!optional
fixnum fixnum) fixnum))
-
-(make-hash-table (#(procedure #:clean #:enforce) make-hash-table (#!rest)
(struct hash-table)))
-(number-hash (#(procedure #:clean #:enforce) number-hash (fixnum #!optional
fixnum fixnum) fixnum))
-(object-uid-hash (#(procedure #:clean #:enforce) object-uid-hash (* #!optional
fixnum fixnum) fixnum))
-(symbol-hash (#(procedure #:clean #:enforce) symbol-hash (symbol #!optional
fixnum fixnum) fixnum))
-(string-hash (#(procedure #:clean #:enforce) string-hash (string #!optional
fixnum fixnum fixnum fixnum) number))
-(string-hash-ci (#(procedure #:clean #:enforce) string-hash-ci (string
#!optional fixnum fixnum fixnum fixnum) number))
-(string-ci-hash (#(procedure #:clean #:enforce) string-ci-hash (string
#!optional fixnum fixnum fixnum fixnum) number))
-
-
;; tcp
(tcp-abandon-port (#(procedure #:clean #:enforce) tcp-abandon-port (port)
undefined))
--
1.7.9.5
- [Chicken-hackers] [PATCH(5)] Remove srfi-18 and srfi-69,
Felix Winkelmann <=
- Re: [Chicken-hackers] [PATCH(5)] Remove srfi-18 and srfi-69, Christian Kellermann, 2014/09/12
- Re: [Chicken-hackers] [PATCH(5)] Remove srfi-18 and srfi-69, Peter Bex, 2014/09/12
- Re: [Chicken-hackers] [PATCH(5)] Remove srfi-18 and srfi-69, Felix Winkelmann, 2014/09/12
- Re: [Chicken-hackers] [PATCH(5)] Remove srfi-18 and srfi-69, Christian Kellermann, 2014/09/12
- Re: [Chicken-hackers] [PATCH(5)] Remove srfi-18 and srfi-69, Felix Winkelmann, 2014/09/12
- Re: [Chicken-hackers] [PATCH(5)] Remove srfi-18 and srfi-69, Christian Kellermann, 2014/09/12
- Re: [Chicken-hackers] [PATCH(5)] Remove srfi-18 and srfi-69, Felix Winkelmann, 2014/09/12
- Re: [Chicken-hackers] [PATCH(5)] Remove srfi-18 and srfi-69, Christian Kellermann, 2014/09/12
- Re: [Chicken-hackers] [PATCH(5)] Remove srfi-18 and srfi-69, Felix Winkelmann, 2014/09/12